From edcc77dbd9f95301a8be1a2f2b0d774680b46a1a Mon Sep 17 00:00:00 2001 From: Nicolas Roche Date: Fri, 8 Sep 2017 15:12:17 +0000 Subject: Make-lang.in, [...]: Find runtime source in libgnat/ 2017-09-08 Nicolas Roche * gcc-interface/Make-lang.in, gcc-interface/Makefile.in: Find runtime source in libgnat/ * a-lfztio.ads, g-timsta.ads, g-sercom-linux.adb, s-osprim-solaris.adb, a-inteio.ads, s-stchop-rtems.adb, s-casuti.adb, s-pack39.adb, i-vxwork-x86.ads, a-strbou.adb, a-stzmap.adb, s-assert.adb, a-sfecin.ads, a-cohama.adb, s-casuti.ads, a-suenco.adb, s-pack39.ads, a-stzmap.ads, a-strbou.ads, s-stalib.adb, s-trasym.adb, g-comver.adb, s-assert.ads, s-vector.ads, g-cgi.adb, a-cohama.ads, s-wchcnv.adb, a-titest.adb, s-pack48.adb, a-suenco.ads, a-strunb.adb, s-stalib.ads, s-trasym.ads, a-nudira.adb, g-comver.ads, a-nuflra.adb, g-cgi.ads, a-chacon.adb, s-wchcnv.ads, a-excach.adb, s-pack48.ads, a-titest.ads, a-strunb.ads, s-dwalin.adb, a-nudira.ads, a-chtgbo.adb, s-resfil.adb, a-scteio.ads, a-nuflra.ads, g-soliop-mingw.ads, s-pack57.adb, a-chacon.ads, s-bytswa.ads, s-pooloc.adb, g-os_lib.adb, s-dwalin.ads, a-szuzha.adb, s-resfil.ads, a-chtgbo.ads, s-spsufi.adb, s-pack57.ads, s-pooloc.ads, g-os_lib.ads, a-stfiha.ads, a-lcteio.ads, a-wtcoau.adb, a-szuzha.ads, s-mmosin-unix.adb, a-stmaco.ads, s-spsufi.ads, s-stchop-limit.ads, a-wtcoau.ads, a-exctra.adb, s-mmosin-unix.ads, s-sequio.adb, s-conca2.adb, g-table.adb, s-imglli.adb, a-numaux-x86.adb, a-strsea.adb, s-wchstw.adb, a-clrefi.adb, a-wwboio.adb, a-exctra.ads, s-sequio.ads, s-conca2.ads, a-wwunio.ads, system-linux-hppa.ads, g-table.ads, s-dimkio.ads, s-imglli.ads, a-cofove.adb, a-numaux-x86.ads, s-wchstw.ads, a-strsea.ads, a-clrefi.ads, a-wwboio.ads, s-stratt-xdr.adb, s-crc32.adb, s-excmac-arm.adb, g-busora.adb, a-cofove.ads, s-osprim-unix.adb, g-io.adb, s-pack49.adb, s-crc32.ads, s-excmac-arm.ads, a-fzteio.ads, g-busora.ads, s-stausa.adb, system-linux-mips.ads, sequenio.ads, g-exctra.adb, g-rewdat.adb, a-cgaaso.adb, g-io.ads, s-pack49.ads, a-wtflau.adb, a-undesu.adb, s-stausa.ads, a-ztenau.adb, g-enutst.ads, calendar.ads, s-pack58.adb, g-rewdat.ads, g-exctra.ads, s-ststop.adb, a-cgaaso.ads, a-strfix.adb, a-comlin.adb, a-strunb-shared.adb, a-wtflau.ads, a-undesu.ads, a-cbhase.adb, a-ztenau.ads, s-os_lib.adb, a-coorse.adb, a-chlat1.ads, s-pack58.ads, s-ststop.ads, a-strfix.ads, a-comlin.ads, a-strunb-shared.ads, a-nscefu.ads, s-valboo.adb, directio.ads, a-chtgke.adb, a-cbhase.ads, a-wtinau.adb, system-linux-alpha.ads, s-os_lib.ads, a-coorse.ads, system-linux-s390.ads, s-imgwiu.adb, a-chtgop.adb, s-valboo.ads, a-chtgke.ads, a-tienio.adb, s-conca3.adb, a-wtinau.ads, system-darwin-ppc.ads, i-c.adb, s-expllu.adb, g-expect.adb, g-sha256.ads, s-vallld.adb, s-imgwiu.ads, a-chtgop.ads, a-strmap.adb, a-tienio.ads, s-conca3.ads, s-imgint.adb, i-c.ads, s-expllu.ads, s-osprim-darwin.adb, a-cogeso.adb, g-expect.ads, a-iwteio.ads, s-vallld.ads, a-coinho-shared.adb, g-shsh64.adb, a-strmap.ads, g-comlin.adb, a-excpol.adb, s-imgint.ads, a-ztdeau.adb, a-cogeso.ads, a-coinho-shared.ads, g-shsh64.ads, g-comlin.ads, a-stzsup.adb, a-rbtgbk.adb, a-wtmoau.adb, a-ztdeau.ads, s-exnlli.adb, g-tty.adb, g-heasor.adb, g-socthi-dummy.adb, s-llflex.ads, a-zchara.ads, a-stzsup.ads, a-ztcstr.adb, a-rbtgbk.ads, a-sfwtio.ads, a-wtmoau.ads, a-sulcin.adb, s-exnlli.ads, system-freebsd.ads, a-stunha.adb, a-charac.ads, g-tty.ads, g-heasor.ads, s-exctra.adb, g-socthi-dummy.ads, a-coboho.adb, a-ztcstr.ads, a-tideio.adb, a-sulcin.ads, a-wrstfi.adb, g-alleve.adb, s-pack59.adb, a-ngrear.adb, a-stboha.adb, a-stunau-shared.adb, a-stunha.ads, a-lfwtio.ads, s-fileio.adb, s-exctra.ads, a-coboho.ads, a-ioexce.ads, a-tideio.ads, a-ngrear.ads, a-wrstfi.ads, s-pack59.ads, g-alleve.ads, a-stboha.ads, s-poosiz.adb, g-traceb.adb, g-rannum.adb, machcode.ads, s-purexc.ads, s-fileio.ads, a-cfinve.adb, a-crbtgk.adb, system-solaris-x86.ads, s-poosiz.ads, g-rannum.ads, g-traceb.ads, a-except.adb, s-conca4.adb, a-stream.adb, a-cfinve.ads, a-crbtgk.ads, s-wchwts.adb, system-mingw.ads, a-except.ads, s-conca4.ads, a-chzla9.ads, s-valenu.adb, s-soflin.adb, a-stream.ads, a-cgarso.adb, s-valllu.adb, g-crc32.adb, s-wchwts.ads, s-fatflt.ads, s-imguns.adb, s-strcom.adb, g-decstr.adb, s-valenu.ads, s-soflin.ads, a-cgarso.ads, a-cwila1.ads, s-valllu.ads, g-crc32.ads, s-imguns.ads, g-spipat.adb, s-valwch.adb, s-strcom.ads, g-decstr.ads, text_io.ads, g-debuti.adb, s-stchop.adb, g-spipat.ads, s-valwch.ads, a-string.ads, s-exnint.adb, g-awk.adb, g-tasloc.adb, s-wwdenu.adb, s-boustr.adb, a-zchuni.adb, s-stchop.ads, g-debuti.ads, s-stopoo.adb, system-dragonfly-x86_64.ads, system-linux-x86.ads, s-exnint.ads, g-awk.ads, a-stzhas.adb, g-tasloc.ads, s-wwdenu.ads, g-debpoo.adb, g-except.ads, g-sse.ads, s-boustr.ads, a-zchuni.ads, s-bitops.adb, s-wwdwch.adb, s-stopoo.ads, a-catizo.adb, a-stzhas.ads, a-nlcefu.ads, g-debpoo.ads, i-vxwoio.adb, s-bitops.ads, g-io-put-vxworks.adb, s-wwdwch.ads, g-sehamd.adb, a-ssicst.adb, a-catizo.ads, s-mmap.adb, g-string.adb, s-traceb.adb, a-swunau.adb, s-rannum.adb, a-ticoau.adb, i-vxwoio.ads, g-sehamd.ads, a-stwiun.adb, a-ssicst.ads, s-conca5.adb, a-ssitio.ads, s-mmap.ads, a-zttest.adb, g-string.ads, g-sercom.adb, a-cdlili.adb, a-swunau.ads, s-traceb.ads, s-rannum.ads, a-ticoau.ads, system-aix.ads, a-cforma.adb, a-stwiun.ads, s-conca5.ads, s-carsi8.adb, a-zttest.ads, g-sercom.ads, a-cdlili.ads, a-cihama.adb, g-sptain.ads, a-cforma.ads, s-maccod.ads, s-carsi8.ads, a-strsup.adb, g-sha1.adb, a-cihama.ads, g-stseme.adb, s-traent.adb, s-valcha.adb, g-curexc.ads, a-strsup.ads, g-sha1.ads, a-sflcin.ads, s-traent.ads, s-pack10.adb, s-valcha.ads, a-coteio.ads, s-tasloc.adb, g-utf_32.adb, a-suteio.adb, s-except.adb, a-direct.adb, g-stsifd-sockets.adb, a-numaux-vxworks.ads, s-winext.ads, s-pack10.ads, a-ztexio.adb, a-tiflau.adb, system-vxworks-arm.ads, s-tasloc.ads, a-suteio.ads, g-utf_32.ads, s-except.ads, a-direct.ads, a-swbwha.adb, g-hesorg.adb, s-wwdcha.adb, a-wtedit.adb, a-ztexio.ads, a-wtcoio.adb, a-tiflau.ads, a-ssizti.ads, s-casi32.adb, a-swbwha.ads, s-veboop.adb, g-hesorg.ads, s-parame-rtems.adb, s-wwdcha.ads, a-wtedit.ads, a-stuten.adb, a-coinve.adb, a-wtcoio.ads, s-casi32.ads, s-string.adb, a-tiinau.adb, a-cusyqu.adb, s-conca6.adb, s-veboop.ads, a-cgcaso.adb, a-numaux-darwin.adb, a-envvar.adb, a-stuten.ads, s-secsta.adb, a-coinve.ads, s-string.ads, a-cusyqu.ads, a-tiinau.ads, s-osprim-vxworks.adb, s-conca6.ads, g-spchge.adb, s-parint.adb, a-cuprqu.adb, a-cgcaso.ads, a-numaux-darwin.ads, a-envvar.ads, s-secsta.ads, g-spchge.ads, s-parint.ads, a-cuprqu.ads, a-swuwti.adb, a-flteio.ads, a-sbhcin.adb, a-coprnu.adb, g-u3spch.adb, s-atocou.adb, g-ctrl_c.adb, a-swuwti.ads, a-calend.adb, a-sbhcin.ads, a-coprnu.ads, g-dirope.adb, g-sha512.ads, g-u3spch.ads, s-atocou.ads, g-ctrl_c.ads, a-timoau.adb, a-witeio.adb, s-pack11.adb, a-strhas.adb, a-wtflio.adb, g-spitbo.adb, a-calend.ads, a-ztenio.adb, g-dirope.ads, a-slcain.adb, g-sechas.adb, a-timoau.ads, a-witeio.ads, s-pack11.ads, s-shasto.adb, s-traceb-mastop.adb, a-ciorse.adb, s-utf_32.adb, a-strhas.ads, a-wtflio.ads, g-spitbo.ads, a-ztenio.ads, a-slcain.ads, g-sechas.ads, s-gearop.adb, a-siztio.ads, s-pack20.adb, s-shasto.ads, a-ciorse.ads, s-utf_32.ads, s-crtl.ads, a-wtinio.adb, s-elaall.adb, s-explli.adb, s-chepoo.ads, s-gearop.ads, a-einuoc.adb, s-pack20.ads, system-linux-ia64.ads, a-swunau-shared.adb, a-wtinio.ads, g-alvety.ads, a-liztio.ads, g-calend.adb, s-conca7.adb, s-elaall.ads, s-explli.ads, a-einuoc.ads, s-widboo.adb, s-imgdec.adb, a-cbhama.adb, g-calend.ads, s-conca7.ads, a-llitio.ads, i-cexten.ads, a-coorma.adb, s-widboo.ads, s-diflio.adb, g-souinf.ads, s-imgdec.ads, g-strhas.ads, a-cbhama.ads, g-shshco.adb, a-ztdeio.adb, s-gloloc.adb, a-coorma.ads, g-wispch.adb, s-pack03.adb, g-eacodu.adb, s-casi16.adb, s-diflio.ads, a-colien.adb, g-shshco.ads, a-wtmoio.adb, a-rbtgbo.adb, a-ztdeio.ads, system-rtems.ads, s-gloloc.ads, a-csquin.ads, a-cofuse.adb, g-wispch.ads, s-pack03.ads, s-casi16.ads, s-io.adb, a-colien.ads, g-alveop.adb, gnat.ads, s-diinio.adb, a-cfdlli.adb, g-pehage.adb, a-wtmoio.ads, a-stwiha.adb, a-locale.adb, a-tirsfi.adb, a-nscoty.ads, a-rbtgbo.ads, s-pack12.adb, a-cofuse.ads, a-sfteio.ads, s-io.ads, g-alveop.ads, a-cfdlli.ads, s-diinio.ads, a-stwiha.ads, g-pehage.ads, a-locale.ads, a-tirsfi.ads, s-pack12.ads, s-valuti.adb, g-cppexc.adb, system-vxworks-ppc.ads, g-memdum.adb, a-lfteio.ads, s-pack21.adb, s-unstyp.ads, s-valuti.ads, g-cppexc.ads, system-hpux-ia64.ads, g-memdum.ads, g-soccon.ads, g-altive.ads, a-crbtgo.adb, s-pack21.ads, a-llizti.ads, a-numaux-libc-x86.ads, s-expint.adb, s-conca8.adb, a-crbtgo.ads, s-pack30.adb, s-vallli.adb, s-geveop.adb, s-expint.ads, a-direio.adb, s-conca8.ads, a-widcha.ads, s-pack30.ads, s-vallli.ads, s-strhas.adb, s-geveop.ads, g-md5.adb, a-direio.ads, a-numaux.ads, s-ransee.adb, a-szbzha.adb, i-cobol.adb, g-busorg.adb, s-strhas.ads, g-md5.ads, s-widenu.adb, s-ransee.ads, s-widllu.adb, a-szbzha.ads, a-ststio.adb, i-cobol.ads, g-busorg.ads, g-regpat.adb, s-widenu.ads, a-secain.adb, s-widllu.ads, s-pack13.adb, g-encstr.adb, a-ztcoau.adb, a-ststio.ads, s-widwch.adb, g-regpat.ads, s-atacco.adb, a-cborse.adb, a-secain.ads, s-pack13.ads, g-encstr.ads, a-ztcoau.ads, s-widwch.ads, g-io_aux.adb, s-atacco.ads, a-ncelfu.ads, interfac.ads, a-cborse.ads, g-regexp.adb, s-pack22.adb, a-szuzti.adb, g-io_aux.ads, s-caun32.adb, a-nselfu.ads, g-regexp.ads, s-pack22.ads, a-ticoio.adb, a-szuzti.ads, g-diopit.adb, s-caun32.ads, s-conca9.adb, a-tags.adb, a-swmwco.ads, a-sbecin.adb, s-pack31.adb, s-expuns.adb, a-ticoio.ads, s-valint.adb, s-conca9.ads, g-diopit.ads, a-tags.ads, a-nllcef.ads, a-izteio.ads, a-sbecin.ads, s-expuns.ads, s-pack31.ads, g-dyntab.adb, s-powtab.ads, s-flocon-none.adb, s-valint.ads, a-ssiwti.ads, s-mmosin-mingw.adb, s-pack40.adb, s-pack05.adb, a-ztflau.adb, g-dyntab.ads, a-szuzti-shared.adb, g-alvevi.ads, a-stwise.adb, s-mmosin-mingw.ads, s-pack40.ads, a-diocst.adb, a-ztflau.ads, s-pack05.ads, a-nlcoty.ads, a-contai.ads, a-stwisu.adb, g-byorma.adb, a-siwtio.ads, a-stwise.ads, s-regpat.adb, g-mbdira.adb, s-pack14.adb, a-diocst.ads, g-flocon.ads, g-mbflra.adb, a-ztinau.adb, s-dim.ads, s-mantis.adb, a-stwisu.ads, g-byorma.ads, s-atopri.adb, g-wistsp.ads, a-uncdea.ads, s-widcha.adb, a-caldel.adb, s-regpat.ads, g-mbdira.ads, a-tiflio.adb, s-pack14.ads, s-parame.adb, a-liwtio.ads, s-memory.adb, g-mbflra.ads, a-ztinau.ads, a-wtgeau.adb, s-direio.adb, s-mantis.ads, s-atopri.ads, s-widcha.ads, a-caldel.ads, s-pack23.adb, a-unccon.ads, a-tiflio.ads, s-parame.ads, a-llftio.ads, s-memory.ads, s-regexp.adb, a-wtgeau.ads, a-exexda.adb, s-direio.ads, s-pack23.ads, g-stheme.adb, a-tiinio.adb, g-sestin.ads, s-regexp.ads, a-wtfiio.adb, a-comutr.adb, a-exexpr.adb, a-tiinio.ads, a-ztmoau.adb, a-cohata.ads, a-wtfiio.ads, s-imgrea.adb, ada.ads, a-szunau-shared.adb, a-comutr.ads, s-valuns.adb, a-ztmoau.ads, system-linux-arm.ads, s-osprim-x32.adb, s-pack41.adb, s-pack06.adb, s-imgrea.ads, s-valuns.ads, s-finroo.adb, s-caun16.adb, s-pooglo.adb, a-zrstfi.adb, a-suenst.adb, s-pack41.ads, g-binenv.adb, s-pack06.ads, a-calari.adb, a-nlcoar.ads, s-finroo.ads, a-timoio.adb, s-caun16.ads, s-flocon.adb, a-suenst.ads, a-zrstfi.ads, s-pooglo.ads, s-wchcon.adb, s-traceb-hpux.adb, s-pack50.adb, i-fortra.adb, s-pack15.adb, a-ngcefu.adb, g-sptavs.ads, g-binenv.ads, s-wchjis.adb, a-calari.ads, a-timoio.ads, a-decima.adb, s-flocon.ads, s-wchcon.ads, a-llfzti.ads, i-fortra.ads, s-pack50.ads, s-pack15.ads, a-ngcefu.ads, a-cfhase.adb, s-wchjis.ads, g-soliop.ads, a-decima.ads, a-chlat9.ads, s-pack24.adb, a-nlelfu.ads, a-cfhase.ads, g-locfil.adb, s-atocou-builtin.adb, s-memcop.ads, a-szunau.adb, s-pack24.ads, s-imgllb.adb, s-auxdec.adb, g-locfil.ads, s-pack33.adb, a-szunau.ads, s-parame-vxworks.adb, s-imgllb.ads, a-ciorma.adb, s-auxdec.ads, a-cobove.adb, s-dsaser.ads, a-elchha.adb, s-pack33.ads, a-cofuve.adb, s-parame-vxworks.ads, a-ciorma.ads, system-darwin-x86.ads, s-multip.adb, a-stwiun-shared.adb, a-wichun.adb, a-cobove.ads, s-imgbiu.adb, s-tsmona-mingw.adb, a-coormu.adb, a-siocst.adb, s-win32.ads, a-elchha.ads, s-pack42.adb, s-pack07.adb, a-cofuve.ads, system-hpux.ads, a-teioed.adb, a-convec.adb, g-speche.adb, s-multip.ads, a-stwiun-shared.ads, a-wichun.ads, s-imgbiu.ads, a-numeri.ads, a-siocst.ads, a-coormu.ads, a-lliwti.ads, s-pack42.ads, s-pack07.ads, a-teioed.ads, a-convec.ads, g-speche.ads, g-socthi.adb, a-nucoty.ads, a-szmzco.ads, s-pack51.adb, s-osprim-mingw.adb, s-casi64.adb, g-strspl.ads, g-socthi.ads, g-socket-dummy.adb, s-pack51.ads, s-dimmks.ads, s-casi64.ads, a-wtenau.adb, s-stchop-vxworks.adb, s-pack60.adb, system-solaris-sparc.ads, s-pack25.adb, g-socket-dummy.ads, a-exstat.adb, a-cofuma.adb, s-tsmona-linux.adb, a-wtenau.ads, s-pack60.ads, s-pack25.ads, i-cstrea.adb, a-cofuma.ads, g-exptty.adb, a-chzla1.ads, s-pack34.adb, i-cstrea.ads, s-excdeb.adb, a-iteint.ads, g-exptty.ads, i-pacdec.adb, s-pack34.ads, s-rident.ads, s-sopco3.adb, i-vxwork.ads, s-excdeb.ads, system-linux-ppc.ads, a-swuwti-shared.adb, s-widlli.adb, s-pack43.adb, i-pacdec.ads, a-cwila9.ads, s-sopco3.ads, a-fwteio.ads, s-widlli.ads, s-pack43.ads, a-suhcin.adb, a-wtdeau.adb, g-allein.ads, a-suezst.adb, a-dirval-mingw.adb, g-zspche.adb, s-bignum.adb, a-ztedit.adb, g-regist.adb, a-nllefu.ads, a-ztcoio.adb, s-pack52.adb, a-llctio.ads, a-nucoar.ads, s-pack17.adb, a-suhcin.ads, a-wtdeau.ads, a-suezst.ads, a-dirval.adb, g-zspche.ads, g-regist.ads, a-ztedit.ads, s-bignum.ads, a-wtcstr.adb, system.ads, s-pack52.ads, a-ztcoio.ads, s-pack17.ads, s-imgboo.adb, a-rbtgso.adb, a-dirval.ads, a-cohase.adb, s-pack61.adb, a-wtcstr.ads, s-pack26.adb, s-osprim.ads, a-tigeau.adb, s-imgboo.ads, a-nuelfu.ads, a-swfwha.ads, s-commun.adb, g-socthi-vxworks.adb, a-rbtgso.ads, a-cohase.ads, g-zstspl.ads, s-pack61.ads, s-pack26.ads, a-intnam-dragonfly.ads, s-imglld.adb, a-tigeau.ads, s-commun.ads, g-socthi-vxworks.ads, a-cborma.adb, a-stwifi.adb, g-moreex.adb, s-pack35.adb, s-imglld.ads, s-valdec.adb, a-tifiio.adb, a-cborma.ads, g-moreex.ads, a-stwifi.ads, s-pack35.ads, s-sopco4.adb, g-sha224.ads, g-socket.adb, a-intnam-rtems.ads, s-finmas.adb, s-valdec.ads, s-addima.adb, a-finali.adb, a-tifiio.ads, s-rpc.adb, a-ztflio.adb, s-pack44.adb, s-pack09.adb, a-sblcin.adb, s-sopco4.ads, a-textio.adb, g-socket.ads, g-sptabo.ads, s-finmas.ads, g-shsh32.adb, s-addima.ads, a-finali.ads, s-mmauni-long.ads, s-rpc.ads, a-ztflio.ads, system-djgpp.ads, s-stache.adb, s-pack44.ads, s-pack09.ads, a-sblcin.ads, a-textio.ads, a-cidlli.adb, g-shsh32.ads, a-chtgbk.adb, a-tiocst.adb, s-pack53.adb, s-pack18.adb, s-stache.ads, a-zchhan.adb, s-fatlfl.ads, a-ztinio.adb, s-strops.adb, a-siteio.ads, a-cidlli.ads, a-chtgbk.ads, g-ssvety.ads, a-tiocst.ads, s-pack53.ads, s-parame-hpux.ads, s-pack18.ads, a-zchhan.ads, s-strops.ads, a-ztinio.ads, a-wichha.adb, a-stwima.adb, a-nlrear.ads, a-liteio.ads, s-pack62.adb, s-pack27.adb, s-fore.adb, s-vercon.adb, a-wichha.ads, a-stwima.ads, s-pack62.ads, system-linux-sparc.ads, s-pack27.ads, g-dynhta.adb, s-fore.ads, s-vercon.ads, a-cofuba.adb, a-cimutr.adb, i-cpoint.adb, s-imgenu.adb, a-stwibo.adb, s-pack36.adb, i-cstrin.adb, s-imgllu.adb, a-suteio-shared.adb, g-excact.adb, s-stoele.adb, s-addope.adb, g-dynhta.ads, a-cofuba.ads, a-ztmoio.adb, a-llfwti.ads, a-cimutr.ads, i-cpoint.ads, s-imgenu.ads, a-stwibo.ads, a-wttest.adb, s-pack36.ads, a-tgdico.ads, s-sopco5.adb, s-scaval.adb, i-cstrin.ads, s-imgllu.ads, g-excact.ads, s-stoele.ads, g-deutst.ads, s-addope.ads, s-imgwch.adb, g-sha384.ads, a-ztmoio.ads, s-pack45.adb, a-wttest.ads, s-sopco5.ads, s-excmac-gcc.adb, s-scaval.ads, a-storio.adb, a-coinho.adb, a-btgbso.adb, s-imgwch.ads, s-carun8.adb, memtrack.adb, s-pack45.ads, a-sfhcin.ads, s-excmac-gcc.ads, a-storio.ads, a-coinho.ads, a-btgbso.ads, s-stratt.adb, s-carun8.ads, a-shcain.adb, s-pack54.adb, s-pack19.adb, a-colire.adb, a-tigeli.adb, s-caun64.adb, s-stratt.ads, s-fatgen.adb, a-shcain.ads, a-stzunb-shared.adb, s-pack54.ads, s-pack19.ads, a-colire.ads, a-calcon.adb, s-caun64.ads, s-fatgen.ads, s-pack63.adb, g-arrspl.adb, a-stzunb-shared.ads, s-pack28.adb, a-nllrar.ads, a-zzboio.adb, a-zzunio.ads, a-stunau.adb, a-calcon.ads, g-cgideb.adb, s-objrea.adb, s-mastop.adb, a-tienau.adb, g-altcon.adb, g-arrspl.ads, s-pack63.ads, s-restri.adb, s-pack28.ads, a-zzboio.ads, a-stunau.ads, g-cgideb.ads, g-htable.adb, g-sothco.adb, s-objrea.ads, g-soliop-solaris.ads, s-mastop.ads, a-tienau.ads, system-linux-m68k.ads, g-altcon.ads, s-dmotpr.ads, s-memory-mingw.adb, g-cgicoo.adb, s-pack37.adb, s-restri.ads, s-fatllf.ads, s-expmod.adb, a-swuwha.adb, a-exextr.adb, a-cfhama.adb, s-gloloc-mingw.adb, a-tiboio.adb, g-forstr.adb, g-sothco.ads, a-stzbou.adb, a-nllcty.ads, a-suecin.adb, g-htable.ads, s-exctab.adb, a-tiunio.ads, g-cgicoo.ads, s-osprim-posix.adb, s-pack37.ads, a-ciormu.adb, s-atocou-x86.adb, a-swuwha.ads, s-expmod.ads, a-cfhama.ads, s-ficobl.ads, a-ngcoty.adb, g-forstr.ads, a-tiboio.ads, a-calfor.adb, a-stzbou.ads, a-suecin.ads, a-conhel.adb, a-crbltr.ads, s-exctab.ads, a-dhfina.ads, s-imgcha.adb, s-pack46.adb, a-ciormu.ads, system-linux-sh4.ads, a-chahan.adb, a-ngcoty.ads, a-stzunb.adb, a-szfzha.ads, a-calfor.ads, a-cbdlli.adb, a-conhel.ads, s-imgcha.ads, s-pack46.ads, a-assert.adb, a-chahan.ads, a-stzunb.ads, a-crdlli.adb, s-pack55.adb, a-cbdlli.ads, a-tideau.adb, a-assert.ads, ioexcept.ads, s-boarop.ads, g-hesora.adb, a-crdlli.ads, s-pack55.ads, a-tideau.ads, g-bubsor.adb, a-wtenio.adb, a-cbsyqu.adb, g-hesora.ads, s-pack29.adb, a-nurear.ads, g-catiio.adb, s-stposu.adb, g-bubsor.ads, a-wtenio.ads, a-cbsyqu.ads, a-suewst.adb, system-vxworks-x86.ads, s-pack29.ads, a-cbmutr.adb, a-cbprqu.adb, s-imenne.adb, g-sothco-dummy.adb, g-casuti.adb, g-catiio.ads, s-stposu.ads, a-stzsea.adb, s-pack38.adb, a-suewst.ads, s-imgllw.adb, a-cbprqu.ads, a-cbmutr.ads, s-imenne.ads, g-sothco-dummy.ads, g-casuti.ads, s-htable.adb, s-fatsfl.ads, g-trasym.adb, unchconv.ads, a-stzsea.ads, s-arit64.adb, s-pack38.ads, a-nllcar.ads, s-valrea.adb, s-imgllw.ads, s-htable.ads, a-sequio.adb, g-trasym.ads, a-ngcoar.adb, s-exnllf.adb, s-pack47.adb, s-arit64.ads, g-sercom-mingw.adb, s-valrea.ads, g-socthi-mingw.adb, g-bytswa.adb, g-sehash.adb, unchdeal.ads, a-sequio.ads, a-ngcoar.ads, s-exnllf.ads, a-wtdeio.adb, s-pack47.ads, g-socthi-mingw.ads, a-excpol-abort.adb, a-ztgeau.adb, g-bytswa.ads, g-sehash.ads, s-pack56.adb, a-wtdeio.ads, a-ngelfu.adb, a-ztgeau.ads, a-cforse.adb, s-filatt.ads, a-stzfix.adb, a-cihase.adb, s-pack56.ads, a-sfztio.ads, a-ngelfu.ads, s-trasym-dwarf.adb, a-cforse.ads, a-ztfiio.adb, g-timsta.adb, a-stzfix.ads, a-cihase.ads, a-ztfiio.ads, system-darwin-arm.ads: Move non-tasking runtime sources to libgnat subdirectory. From-SVN: r251902 --- gcc/ada/ChangeLog | 279 + gcc/ada/a-assert.adb | 53 - gcc/ada/a-assert.ads | 66 - gcc/ada/a-btgbso.adb | 703 -- gcc/ada/a-btgbso.ads | 103 - gcc/ada/a-calari.adb | 100 - gcc/ada/a-calari.ads | 65 - gcc/ada/a-calcon.adb | 148 - gcc/ada/a-calcon.ads | 113 - gcc/ada/a-caldel.adb | 110 - gcc/ada/a-caldel.ads | 53 - gcc/ada/a-calend.adb | 1580 --- gcc/ada/a-calend.ads | 395 - gcc/ada/a-calfor.adb | 882 -- gcc/ada/a-calfor.ads | 215 - gcc/ada/a-catizo.adb | 69 - gcc/ada/a-catizo.ads | 32 - gcc/ada/a-cbdlli.adb | 2399 ---- gcc/ada/a-cbdlli.ads | 398 - gcc/ada/a-cbhama.adb | 1252 --- gcc/ada/a-cbhama.ads | 468 - gcc/ada/a-cbhase.adb | 1946 ---- gcc/ada/a-cbhase.ads | 605 - gcc/ada/a-cbmutr.adb | 3327 ------ gcc/ada/a-cbmutr.ads | 406 - gcc/ada/a-cborma.adb | 1637 --- gcc/ada/a-cborma.ads | 376 - gcc/ada/a-cborse.adb | 2044 ---- gcc/ada/a-cborse.ads | 450 - gcc/ada/a-cbprqu.adb | 220 - gcc/ada/a-cbprqu.ads | 137 - gcc/ada/a-cbsyqu.adb | 168 - gcc/ada/a-cbsyqu.ads | 103 - gcc/ada/a-cdlili.adb | 2186 ---- gcc/ada/a-cdlili.ads | 406 - gcc/ada/a-cfdlli.adb | 1894 ---- gcc/ada/a-cfdlli.ads | 1623 --- gcc/ada/a-cfhama.adb | 888 -- gcc/ada/a-cfhama.ads | 815 -- gcc/ada/a-cfhase.adb | 1573 --- gcc/ada/a-cfhase.ads | 1335 --- gcc/ada/a-cfinve.adb | 1404 --- gcc/ada/a-cfinve.ads | 937 -- gcc/ada/a-cforma.adb | 1159 -- gcc/ada/a-cforma.ads | 1052 -- gcc/ada/a-cforse.adb | 1898 ---- gcc/ada/a-cforse.ads | 1784 --- gcc/ada/a-cgaaso.adb | 47 - gcc/ada/a-cgaaso.ads | 41 - gcc/ada/a-cgarso.adb | 50 - gcc/ada/a-cgarso.ads | 26 - gcc/ada/a-cgcaso.adb | 121 - gcc/ada/a-cgcaso.ads | 27 - gcc/ada/a-chacon.adb | 261 - gcc/ada/a-chacon.ads | 86 - gcc/ada/a-chahan.adb | 609 - gcc/ada/a-chahan.ads | 159 - gcc/ada/a-charac.ads | 18 - gcc/ada/a-chlat1.ads | 296 - gcc/ada/a-chlat9.ads | 332 - gcc/ada/a-chtgbk.adb | 346 - gcc/ada/a-chtgbk.ads | 120 - gcc/ada/a-chtgbo.adb | 553 - gcc/ada/a-chtgbo.ads | 156 - gcc/ada/a-chtgke.adb | 329 - gcc/ada/a-chtgke.ads | 120 - gcc/ada/a-chtgop.adb | 838 -- gcc/ada/a-chtgop.ads | 215 - gcc/ada/a-chzla1.ads | 376 - gcc/ada/a-chzla9.ads | 388 - gcc/ada/a-cidlli.adb | 2290 ---- gcc/ada/a-cidlli.ads | 397 - gcc/ada/a-cihama.adb | 1364 --- gcc/ada/a-cihama.ads | 455 - gcc/ada/a-cihase.adb | 2401 ---- gcc/ada/a-cihase.ads | 595 - gcc/ada/a-cimutr.adb | 2698 ----- gcc/ada/a-cimutr.ads | 456 - gcc/ada/a-ciorma.adb | 1686 --- gcc/ada/a-ciorma.ads | 388 - gcc/ada/a-ciormu.adb | 2013 ---- gcc/ada/a-ciormu.ads | 566 - gcc/ada/a-ciorse.adb | 2191 ---- gcc/ada/a-ciorse.ads | 467 - gcc/ada/a-clrefi.adb | 36 - gcc/ada/a-clrefi.ads | 35 - gcc/ada/a-coboho.adb | 99 - gcc/ada/a-coboho.ads | 114 - gcc/ada/a-cobove.adb | 2805 ----- gcc/ada/a-cobove.ads | 506 - gcc/ada/a-cofove.adb | 1398 --- gcc/ada/a-cofove.ads | 924 -- gcc/ada/a-cofuba.adb | 250 - gcc/ada/a-cofuba.ads | 117 - gcc/ada/a-cofuma.adb | 284 - gcc/ada/a-cofuma.ads | 361 - gcc/ada/a-cofuse.adb | 174 - gcc/ada/a-cofuse.ads | 322 - gcc/ada/a-cofuve.adb | 255 - gcc/ada/a-cofuve.ads | 393 - gcc/ada/a-cogeso.adb | 127 - gcc/ada/a-cogeso.ads | 40 - gcc/ada/a-cohama.adb | 1200 -- gcc/ada/a-cohama.ads | 470 - gcc/ada/a-cohase.adb | 2184 ---- gcc/ada/a-cohase.ads | 609 - gcc/ada/a-cohata.ads | 82 - gcc/ada/a-coinho-shared.adb | 528 - gcc/ada/a-coinho-shared.ads | 192 - gcc/ada/a-coinho.adb | 383 - gcc/ada/a-coinho.ads | 178 - gcc/ada/a-coinve.adb | 3663 ------ gcc/ada/a-coinve.ads | 509 - gcc/ada/a-colien.adb | 72 - gcc/ada/a-colien.ads | 55 - gcc/ada/a-colire.adb | 124 - gcc/ada/a-colire.ads | 79 - gcc/ada/a-comlin.adb | 123 - gcc/ada/a-comlin.ads | 144 - gcc/ada/a-comutr.adb | 2676 ----- gcc/ada/a-comutr.ads | 511 - gcc/ada/a-conhel.adb | 186 - gcc/ada/a-conhel.ads | 159 - gcc/ada/a-contai.ads | 24 - gcc/ada/a-convec.adb | 3274 ------ gcc/ada/a-convec.ads | 518 - gcc/ada/a-coorma.adb | 1556 --- gcc/ada/a-coorma.ads | 392 - gcc/ada/a-coormu.adb | 1895 ---- gcc/ada/a-coormu.ads | 570 - gcc/ada/a-coorse.adb | 1999 ---- gcc/ada/a-coorse.ads | 453 - gcc/ada/a-coprnu.adb | 58 - gcc/ada/a-coprnu.ads | 51 - gcc/ada/a-coteio.ads | 24 - gcc/ada/a-crbltr.ads | 80 - gcc/ada/a-crbtgk.adb | 690 -- gcc/ada/a-crbtgk.ads | 192 - gcc/ada/a-crbtgo.adb | 1159 -- gcc/ada/a-crbtgo.ads | 163 - gcc/ada/a-crdlli.adb | 1503 --- gcc/ada/a-crdlli.ads | 337 - gcc/ada/a-csquin.ads | 56 - gcc/ada/a-cuprqu.adb | 110 - gcc/ada/a-cuprqu.ads | 137 - gcc/ada/a-cusyqu.adb | 174 - gcc/ada/a-cusyqu.ads | 106 - gcc/ada/a-cwila1.ads | 322 - gcc/ada/a-cwila9.ads | 334 - gcc/ada/a-decima.adb | 60 - gcc/ada/a-decima.ads | 67 - gcc/ada/a-dhfina.ads | 46 - gcc/ada/a-diocst.adb | 88 - gcc/ada/a-diocst.ads | 54 - gcc/ada/a-direct.adb | 1344 --- gcc/ada/a-direct.ads | 487 - gcc/ada/a-direio.adb | 289 - gcc/ada/a-direio.ads | 193 - gcc/ada/a-dirval-mingw.adb | 175 - gcc/ada/a-dirval.adb | 104 - gcc/ada/a-dirval.ads | 49 - gcc/ada/a-einuoc.adb | 48 - gcc/ada/a-einuoc.ads | 40 - gcc/ada/a-elchha.adb | 141 - gcc/ada/a-elchha.ads | 41 - gcc/ada/a-envvar.adb | 228 - gcc/ada/a-envvar.ads | 69 - gcc/ada/a-excach.adb | 74 - gcc/ada/a-except.adb | 1748 --- gcc/ada/a-except.ads | 349 - gcc/ada/a-excpol-abort.adb | 62 - gcc/ada/a-excpol.adb | 42 - gcc/ada/a-exctra.adb | 43 - gcc/ada/a-exctra.ads | 63 - gcc/ada/a-exexda.adb | 744 -- gcc/ada/a-exexpr.adb | 439 - gcc/ada/a-exextr.adb | 201 - gcc/ada/a-exstat.adb | 266 - gcc/ada/a-finali.adb | 36 - gcc/ada/a-finali.ads | 68 - gcc/ada/a-flteio.ads | 21 - gcc/ada/a-fwteio.ads | 19 - gcc/ada/a-fzteio.ads | 19 - gcc/ada/a-inteio.ads | 19 - gcc/ada/a-intnam-dragonfly.ads | 136 - gcc/ada/a-intnam-rtems.ads | 114 - gcc/ada/a-ioexce.ads | 30 - gcc/ada/a-iteint.ads | 39 - gcc/ada/a-iwteio.ads | 19 - gcc/ada/a-izteio.ads | 19 - gcc/ada/a-lcteio.ads | 24 - gcc/ada/a-lfteio.ads | 19 - gcc/ada/a-lfwtio.ads | 19 - gcc/ada/a-lfztio.ads | 19 - gcc/ada/a-liteio.ads | 19 - gcc/ada/a-liwtio.ads | 19 - gcc/ada/a-liztio.ads | 19 - gcc/ada/a-llctio.ads | 24 - gcc/ada/a-llftio.ads | 19 - gcc/ada/a-llfwti.ads | 19 - gcc/ada/a-llfzti.ads | 19 - gcc/ada/a-llitio.ads | 19 - gcc/ada/a-lliwti.ads | 19 - gcc/ada/a-llizti.ads | 19 - gcc/ada/a-locale.adb | 64 - gcc/ada/a-locale.ads | 40 - gcc/ada/a-ncelfu.ads | 23 - gcc/ada/a-ngcefu.adb | 710 -- gcc/ada/a-ngcefu.ads | 55 - gcc/ada/a-ngcoar.adb | 1255 --- gcc/ada/a-ngcoar.ads | 281 - gcc/ada/a-ngcoty.adb | 681 -- gcc/ada/a-ngcoty.ads | 157 - gcc/ada/a-ngelfu.adb | 997 -- gcc/ada/a-ngelfu.ads | 205 - gcc/ada/a-ngrear.adb | 777 -- gcc/ada/a-ngrear.ads | 142 - gcc/ada/a-nlcefu.ads | 22 - gcc/ada/a-nlcoar.ads | 23 - gcc/ada/a-nlcoty.ads | 21 - gcc/ada/a-nlelfu.ads | 21 - gcc/ada/a-nllcar.ads | 24 - gcc/ada/a-nllcef.ads | 22 - gcc/ada/a-nllcty.ads | 21 - gcc/ada/a-nllefu.ads | 21 - gcc/ada/a-nllrar.ads | 21 - gcc/ada/a-nlrear.ads | 21 - gcc/ada/a-nscefu.ads | 22 - gcc/ada/a-nscoty.ads | 21 - gcc/ada/a-nselfu.ads | 21 - gcc/ada/a-nucoar.ads | 23 - gcc/ada/a-nucoty.ads | 21 - gcc/ada/a-nudira.adb | 96 - gcc/ada/a-nudira.ads | 75 - gcc/ada/a-nuelfu.ads | 21 - gcc/ada/a-nuflra.adb | 104 - gcc/ada/a-nuflra.ads | 74 - gcc/ada/a-numaux-darwin.adb | 211 - gcc/ada/a-numaux-darwin.ads | 103 - gcc/ada/a-numaux-libc-x86.ads | 97 - gcc/ada/a-numaux-vxworks.ads | 97 - gcc/ada/a-numaux-x86.adb | 577 - gcc/ada/a-numaux-x86.ads | 76 - gcc/ada/a-numaux.ads | 112 - gcc/ada/a-numeri.ads | 32 - gcc/ada/a-nurear.ads | 21 - gcc/ada/a-rbtgbk.adb | 627 -- gcc/ada/a-rbtgbk.ads | 193 - gcc/ada/a-rbtgbo.adb | 1127 -- gcc/ada/a-rbtgbo.ads | 156 - gcc/ada/a-rbtgso.adb | 739 -- gcc/ada/a-rbtgso.ads | 106 - gcc/ada/a-sbecin.adb | 40 - gcc/ada/a-sbecin.ads | 42 - gcc/ada/a-sbhcin.adb | 38 - gcc/ada/a-sbhcin.ads | 44 - gcc/ada/a-sblcin.adb | 40 - gcc/ada/a-sblcin.ads | 42 - gcc/ada/a-scteio.ads | 24 - gcc/ada/a-secain.adb | 59 - gcc/ada/a-secain.ads | 38 - gcc/ada/a-sequio.adb | 314 - gcc/ada/a-sequio.ads | 160 - gcc/ada/a-sfecin.ads | 40 - gcc/ada/a-sfhcin.ads | 41 - gcc/ada/a-sflcin.ads | 40 - gcc/ada/a-sfteio.ads | 19 - gcc/ada/a-sfwtio.ads | 19 - gcc/ada/a-sfztio.ads | 19 - gcc/ada/a-shcain.adb | 41 - gcc/ada/a-shcain.ads | 37 - gcc/ada/a-siocst.adb | 86 - gcc/ada/a-siocst.ads | 54 - gcc/ada/a-siteio.ads | 19 - gcc/ada/a-siwtio.ads | 19 - gcc/ada/a-siztio.ads | 19 - gcc/ada/a-slcain.adb | 72 - gcc/ada/a-slcain.ads | 36 - gcc/ada/a-ssicst.adb | 87 - gcc/ada/a-ssicst.ads | 53 - gcc/ada/a-ssitio.ads | 19 - gcc/ada/a-ssiwti.ads | 19 - gcc/ada/a-ssizti.ads | 19 - gcc/ada/a-stboha.adb | 40 - gcc/ada/a-stboha.ads | 25 - gcc/ada/a-stfiha.ads | 21 - gcc/ada/a-stmaco.ads | 915 -- gcc/ada/a-storio.adb | 60 - gcc/ada/a-storio.ads | 47 - gcc/ada/a-strbou.adb | 106 - gcc/ada/a-strbou.ads | 914 -- gcc/ada/a-stream.adb | 70 - gcc/ada/a-stream.ads | 87 - gcc/ada/a-strfix.adb | 747 -- gcc/ada/a-strfix.ads | 251 - gcc/ada/a-strhas.adb | 38 - gcc/ada/a-strhas.ads | 25 - gcc/ada/a-string.ads | 35 - gcc/ada/a-strmap.adb | 322 - gcc/ada/a-strmap.ads | 411 - gcc/ada/a-strsea.adb | 645 -- gcc/ada/a-strsea.ads | 121 - gcc/ada/a-strsup.adb | 1925 ---- gcc/ada/a-strsup.ads | 493 - gcc/ada/a-strunb-shared.adb | 2115 ---- gcc/ada/a-strunb-shared.ads | 490 - gcc/ada/a-strunb.adb | 1073 -- gcc/ada/a-strunb.ads | 437 - gcc/ada/a-ststio.adb | 490 - gcc/ada/a-ststio.ads | 223 - gcc/ada/a-stunau-shared.adb | 62 - gcc/ada/a-stunau.adb | 62 - gcc/ada/a-stunau.ads | 77 - gcc/ada/a-stunha.adb | 40 - gcc/ada/a-stunha.ads | 21 - gcc/ada/a-stuten.adb | 209 - gcc/ada/a-stuten.ads | 144 - gcc/ada/a-stwibo.adb | 94 - gcc/ada/a-stwibo.ads | 921 -- gcc/ada/a-stwifi.adb | 688 -- gcc/ada/a-stwifi.ads | 254 - gcc/ada/a-stwiha.adb | 40 - gcc/ada/a-stwiha.ads | 21 - gcc/ada/a-stwima.adb | 742 -- gcc/ada/a-stwima.ads | 240 - gcc/ada/a-stwise.adb | 614 -- gcc/ada/a-stwise.ads | 125 - gcc/ada/a-stwisu.adb | 1933 ---- gcc/ada/a-stwisu.ads | 499 - gcc/ada/a-stwiun-shared.adb | 2128 ---- gcc/ada/a-stwiun-shared.ads | 494 - gcc/ada/a-stwiun.adb | 1097 -- gcc/ada/a-stwiun.ads | 443 - gcc/ada/a-stzbou.adb | 94 - gcc/ada/a-stzbou.ads | 937 -- gcc/ada/a-stzfix.adb | 694 -- gcc/ada/a-stzfix.ads | 264 - gcc/ada/a-stzhas.adb | 36 - gcc/ada/a-stzhas.ads | 25 - gcc/ada/a-stzmap.adb | 747 -- gcc/ada/a-stzmap.ads | 242 - gcc/ada/a-stzsea.adb | 617 -- gcc/ada/a-stzsea.ads | 129 - gcc/ada/a-stzsup.adb | 1941 ---- gcc/ada/a-stzsup.ads | 508 - gcc/ada/a-stzunb-shared.adb | 2137 ---- gcc/ada/a-stzunb-shared.ads | 513 - gcc/ada/a-stzunb.adb | 1107 -- gcc/ada/a-stzunb.ads | 452 - gcc/ada/a-suecin.adb | 47 - gcc/ada/a-suecin.ads | 38 - gcc/ada/a-suenco.adb | 418 - gcc/ada/a-suenco.ads | 61 - gcc/ada/a-suenst.adb | 350 - gcc/ada/a-suenst.ads | 65 - gcc/ada/a-suewst.adb | 370 - gcc/ada/a-suewst.ads | 67 - gcc/ada/a-suezst.adb | 429 - gcc/ada/a-suezst.ads | 64 - gcc/ada/a-suhcin.adb | 43 - gcc/ada/a-suhcin.ads | 40 - gcc/ada/a-sulcin.adb | 47 - gcc/ada/a-sulcin.ads | 38 - gcc/ada/a-suteio-shared.adb | 132 - gcc/ada/a-suteio.adb | 159 - gcc/ada/a-suteio.ads | 61 - gcc/ada/a-swbwha.adb | 41 - gcc/ada/a-swbwha.ads | 25 - gcc/ada/a-swfwha.ads | 22 - gcc/ada/a-swmwco.ads | 450 - gcc/ada/a-swunau-shared.adb | 65 - gcc/ada/a-swunau.adb | 65 - gcc/ada/a-swunau.ads | 76 - gcc/ada/a-swuwha.adb | 40 - gcc/ada/a-swuwha.ads | 23 - gcc/ada/a-swuwti-shared.adb | 134 - gcc/ada/a-swuwti.adb | 161 - gcc/ada/a-swuwti.ads | 69 - gcc/ada/a-szbzha.adb | 41 - gcc/ada/a-szbzha.ads | 28 - gcc/ada/a-szfzha.ads | 24 - gcc/ada/a-szmzco.ads | 450 - gcc/ada/a-szunau-shared.adb | 65 - gcc/ada/a-szunau.adb | 65 - gcc/ada/a-szunau.ads | 78 - gcc/ada/a-szuzha.adb | 40 - gcc/ada/a-szuzha.ads | 21 - gcc/ada/a-szuzti-shared.adb | 135 - gcc/ada/a-szuzti.adb | 162 - gcc/ada/a-szuzti.ads | 71 - gcc/ada/a-tags.adb | 1100 -- gcc/ada/a-tags.ads | 612 -- gcc/ada/a-teioed.adb | 2860 ----- gcc/ada/a-teioed.ads | 194 - gcc/ada/a-textio.adb | 2182 ---- gcc/ada/a-textio.ads | 471 - gcc/ada/a-tgdico.ads | 29 - gcc/ada/a-tiboio.adb | 179 - gcc/ada/a-tiboio.ads | 50 - gcc/ada/a-ticoau.adb | 202 - gcc/ada/a-ticoau.ads | 69 - gcc/ada/a-ticoio.adb | 140 - gcc/ada/a-ticoio.ads | 84 - gcc/ada/a-tideau.adb | 261 - gcc/ada/a-tideau.ads | 92 - gcc/ada/a-tideio.adb | 137 - gcc/ada/a-tideio.ads | 89 - gcc/ada/a-tienau.adb | 283 - gcc/ada/a-tienau.ads | 69 - gcc/ada/a-tienio.adb | 137 - gcc/ada/a-tienio.ads | 55 - gcc/ada/a-tifiio.adb | 716 -- gcc/ada/a-tifiio.ads | 69 - gcc/ada/a-tiflau.adb | 235 - gcc/ada/a-tiflau.ads | 72 - gcc/ada/a-tiflio.adb | 145 - gcc/ada/a-tiflio.ads | 89 - gcc/ada/a-tigeau.adb | 487 - gcc/ada/a-tigeau.ads | 191 - gcc/ada/a-tigeli.adb | 241 - gcc/ada/a-tiinau.adb | 297 - gcc/ada/a-tiinau.ads | 83 - gcc/ada/a-tiinio.adb | 154 - gcc/ada/a-tiinio.ads | 85 - gcc/ada/a-timoau.adb | 305 - gcc/ada/a-timoau.ads | 87 - gcc/ada/a-timoio.adb | 141 - gcc/ada/a-timoio.ads | 85 - gcc/ada/a-tiocst.adb | 84 - gcc/ada/a-tiocst.ads | 53 - gcc/ada/a-tirsfi.adb | 39 - gcc/ada/a-tirsfi.ads | 40 - gcc/ada/a-titest.adb | 46 - gcc/ada/a-titest.ads | 23 - gcc/ada/a-tiunio.ads | 61 - gcc/ada/a-unccon.ads | 24 - gcc/ada/a-uncdea.ads | 23 - gcc/ada/a-undesu.adb | 43 - gcc/ada/a-undesu.ads | 19 - gcc/ada/a-wichha.adb | 195 - gcc/ada/a-wichha.ads | 127 - gcc/ada/a-wichun.adb | 178 - gcc/ada/a-wichun.ads | 197 - gcc/ada/a-widcha.ads | 21 - gcc/ada/a-witeio.adb | 1965 ---- gcc/ada/a-witeio.ads | 495 - gcc/ada/a-wrstfi.adb | 39 - gcc/ada/a-wrstfi.ads | 41 - gcc/ada/a-wtcoau.adb | 202 - gcc/ada/a-wtcoau.ads | 69 - gcc/ada/a-wtcoio.adb | 159 - gcc/ada/a-wtcoio.ads | 62 - gcc/ada/a-wtcstr.adb | 85 - gcc/ada/a-wtcstr.ads | 53 - gcc/ada/a-wtdeau.adb | 265 - gcc/ada/a-wtdeau.ads | 93 - gcc/ada/a-wtdeio.adb | 155 - gcc/ada/a-wtdeio.ads | 64 - gcc/ada/a-wtedit.adb | 2716 ----- gcc/ada/a-wtedit.ads | 197 - gcc/ada/a-wtenau.adb | 349 - gcc/ada/a-wtenau.ads | 69 - gcc/ada/a-wtenio.adb | 104 - gcc/ada/a-wtenio.ads | 54 - gcc/ada/a-wtfiio.adb | 126 - gcc/ada/a-wtfiio.ads | 64 - gcc/ada/a-wtflau.adb | 235 - gcc/ada/a-wtflau.ads | 72 - gcc/ada/a-wtflio.adb | 127 - gcc/ada/a-wtflio.ads | 64 - gcc/ada/a-wtgeau.adb | 528 - gcc/ada/a-wtgeau.ads | 184 - gcc/ada/a-wtinau.adb | 295 - gcc/ada/a-wtinau.ads | 83 - gcc/ada/a-wtinio.adb | 145 - gcc/ada/a-wtinio.ads | 60 - gcc/ada/a-wtmoau.adb | 305 - gcc/ada/a-wtmoau.ads | 87 - gcc/ada/a-wtmoio.adb | 141 - gcc/ada/a-wtmoio.ads | 62 - gcc/ada/a-wttest.adb | 46 - gcc/ada/a-wttest.ads | 24 - gcc/ada/a-wwboio.adb | 179 - gcc/ada/a-wwboio.ads | 50 - gcc/ada/a-wwunio.ads | 61 - gcc/ada/a-zchara.ads | 18 - gcc/ada/a-zchhan.adb | 187 - gcc/ada/a-zchhan.ads | 132 - gcc/ada/a-zchuni.adb | 178 - gcc/ada/a-zchuni.ads | 196 - gcc/ada/a-zrstfi.adb | 39 - gcc/ada/a-zrstfi.ads | 41 - gcc/ada/a-ztcoau.adb | 202 - gcc/ada/a-ztcoau.ads | 53 - gcc/ada/a-ztcoio.adb | 159 - gcc/ada/a-ztcoio.ads | 62 - gcc/ada/a-ztcstr.adb | 85 - gcc/ada/a-ztcstr.ads | 53 - gcc/ada/a-ztdeau.adb | 263 - gcc/ada/a-ztdeau.ads | 93 - gcc/ada/a-ztdeio.adb | 164 - gcc/ada/a-ztdeio.ads | 64 - gcc/ada/a-ztedit.adb | 2712 ----- gcc/ada/a-ztedit.ads | 198 - gcc/ada/a-ztenau.adb | 353 - gcc/ada/a-ztenau.ads | 69 - gcc/ada/a-ztenio.adb | 104 - gcc/ada/a-ztenio.ads | 54 - gcc/ada/a-ztexio.adb | 1939 ---- gcc/ada/a-ztexio.ads | 497 - gcc/ada/a-ztfiio.adb | 126 - gcc/ada/a-ztfiio.ads | 64 - gcc/ada/a-ztflau.adb | 235 - gcc/ada/a-ztflau.ads | 72 - gcc/ada/a-ztflio.adb | 126 - gcc/ada/a-ztflio.ads | 64 - gcc/ada/a-ztgeau.adb | 528 - gcc/ada/a-ztgeau.ads | 184 - gcc/ada/a-ztinau.adb | 295 - gcc/ada/a-ztinau.ads | 83 - gcc/ada/a-ztinio.adb | 145 - gcc/ada/a-ztinio.ads | 60 - gcc/ada/a-ztmoau.adb | 305 - gcc/ada/a-ztmoau.ads | 88 - gcc/ada/a-ztmoio.adb | 141 - gcc/ada/a-ztmoio.ads | 60 - gcc/ada/a-zttest.adb | 46 - gcc/ada/a-zttest.ads | 24 - gcc/ada/a-zzboio.adb | 180 - gcc/ada/a-zzboio.ads | 50 - gcc/ada/a-zzunio.ads | 63 - gcc/ada/ada.ads | 20 - gcc/ada/calendar.ads | 18 - gcc/ada/directio.ads | 24 - gcc/ada/g-allein.ads | 304 - gcc/ada/g-alleve.adb | 4956 --------- gcc/ada/g-alleve.ads | 525 - gcc/ada/g-altcon.adb | 514 - gcc/ada/g-altcon.ads | 101 - gcc/ada/g-altive.ads | 766 -- gcc/ada/g-alveop.adb | 11008 ------------------- gcc/ada/g-alveop.ads | 8362 -------------- gcc/ada/g-alvety.ads | 150 - gcc/ada/g-alvevi.ads | 156 - gcc/ada/g-arrspl.adb | 352 - gcc/ada/g-arrspl.ads | 190 - gcc/ada/g-awk.adb | 1488 --- gcc/ada/g-awk.ads | 642 -- gcc/ada/g-binenv.adb | 83 - gcc/ada/g-binenv.ads | 40 - gcc/ada/g-bubsor.adb | 56 - gcc/ada/g-bubsor.ads | 66 - gcc/ada/g-busora.adb | 58 - gcc/ada/g-busora.ads | 63 - gcc/ada/g-busorg.adb | 58 - gcc/ada/g-busorg.ads | 72 - gcc/ada/g-byorma.adb | 195 - gcc/ada/g-byorma.ads | 100 - gcc/ada/g-bytswa.adb | 113 - gcc/ada/g-bytswa.ads | 206 - gcc/ada/g-calend.adb | 652 -- gcc/ada/g-calend.ads | 185 - gcc/ada/g-casuti.adb | 38 - gcc/ada/g-casuti.ads | 77 - gcc/ada/g-catiio.adb | 1242 --- gcc/ada/g-catiio.ads | 168 - gcc/ada/g-cgi.adb | 494 - gcc/ada/g-cgi.ads | 255 - gcc/ada/g-cgicoo.adb | 405 - gcc/ada/g-cgicoo.ads | 120 - gcc/ada/g-cgideb.adb | 314 - gcc/ada/g-cgideb.ads | 47 - gcc/ada/g-comlin.adb | 3613 ------ gcc/ada/g-comlin.ads | 1201 -- gcc/ada/g-comver.adb | 72 - gcc/ada/g-comver.ads | 61 - gcc/ada/g-cppexc.adb | 139 - gcc/ada/g-cppexc.ads | 48 - gcc/ada/g-crc32.adb | 85 - gcc/ada/g-crc32.ads | 111 - gcc/ada/g-ctrl_c.adb | 63 - gcc/ada/g-ctrl_c.ads | 59 - gcc/ada/g-curexc.ads | 112 - gcc/ada/g-debpoo.adb | 2520 ----- gcc/ada/g-debpoo.ads | 409 - gcc/ada/g-debuti.adb | 188 - gcc/ada/g-debuti.ads | 81 - gcc/ada/g-decstr.adb | 796 -- gcc/ada/g-decstr.ads | 176 - gcc/ada/g-deutst.ads | 43 - gcc/ada/g-diopit.adb | 396 - gcc/ada/g-diopit.ads | 92 - gcc/ada/g-dirope.adb | 775 -- gcc/ada/g-dirope.ads | 262 - gcc/ada/g-dynhta.adb | 369 - gcc/ada/g-dynhta.ads | 266 - gcc/ada/g-dyntab.adb | 497 - gcc/ada/g-dyntab.ads | 293 - gcc/ada/g-eacodu.adb | 49 - gcc/ada/g-encstr.adb | 258 - gcc/ada/g-encstr.ads | 109 - gcc/ada/g-enutst.ads | 43 - gcc/ada/g-excact.adb | 131 - gcc/ada/g-excact.ads | 118 - gcc/ada/g-except.ads | 82 - gcc/ada/g-exctra.adb | 36 - gcc/ada/g-exctra.ads | 39 - gcc/ada/g-expect.adb | 1488 --- gcc/ada/g-expect.ads | 647 -- gcc/ada/g-exptty.adb | 324 - gcc/ada/g-exptty.ads | 137 - gcc/ada/g-flocon.ads | 38 - gcc/ada/g-forstr.adb | 984 -- gcc/ada/g-forstr.ads | 311 - gcc/ada/g-heasor.adb | 130 - gcc/ada/g-heasor.ads | 72 - gcc/ada/g-hesora.adb | 134 - gcc/ada/g-hesora.ads | 69 - gcc/ada/g-hesorg.adb | 142 - gcc/ada/g-hesorg.ads | 88 - gcc/ada/g-htable.adb | 40 - gcc/ada/g-htable.ads | 60 - gcc/ada/g-io-put-vxworks.adb | 53 - gcc/ada/g-io.adb | 191 - gcc/ada/g-io.ads | 91 - gcc/ada/g-io_aux.adb | 105 - gcc/ada/g-io_aux.ads | 54 - gcc/ada/g-locfil.adb | 134 - gcc/ada/g-locfil.ads | 72 - gcc/ada/g-mbdira.adb | 282 - gcc/ada/g-mbdira.ads | 123 - gcc/ada/g-mbflra.adb | 314 - gcc/ada/g-mbflra.ads | 103 - gcc/ada/g-md5.adb | 36 - gcc/ada/g-md5.ads | 49 - gcc/ada/g-memdum.adb | 179 - gcc/ada/g-memdum.ads | 77 - gcc/ada/g-moreex.adb | 85 - gcc/ada/g-moreex.ads | 74 - gcc/ada/g-os_lib.adb | 36 - gcc/ada/g-os_lib.ads | 51 - gcc/ada/g-pehage.adb | 2600 ----- gcc/ada/g-pehage.ads | 238 - gcc/ada/g-rannum.adb | 344 - gcc/ada/g-rannum.ads | 161 - gcc/ada/g-regexp.adb | 36 - gcc/ada/g-regexp.ads | 70 - gcc/ada/g-regist.adb | 553 - gcc/ada/g-regist.ads | 161 - gcc/ada/g-regpat.adb | 37 - gcc/ada/g-regpat.ads | 72 - gcc/ada/g-rewdat.adb | 253 - gcc/ada/g-rewdat.ads | 152 - gcc/ada/g-sechas.adb | 486 - gcc/ada/g-sechas.ads | 240 - gcc/ada/g-sehamd.adb | 342 - gcc/ada/g-sehamd.ads | 74 - gcc/ada/g-sehash.adb | 179 - gcc/ada/g-sehash.ads | 72 - gcc/ada/g-sercom-linux.adb | 314 - gcc/ada/g-sercom-mingw.adb | 316 - gcc/ada/g-sercom.adb | 136 - gcc/ada/g-sercom.ads | 190 - gcc/ada/g-sestin.ads | 48 - gcc/ada/g-sha1.adb | 36 - gcc/ada/g-sha1.ads | 49 - gcc/ada/g-sha224.ads | 50 - gcc/ada/g-sha256.ads | 50 - gcc/ada/g-sha384.ads | 50 - gcc/ada/g-sha512.ads | 50 - gcc/ada/g-shsh32.adb | 80 - gcc/ada/g-shsh32.ads | 108 - gcc/ada/g-shsh64.adb | 80 - gcc/ada/g-shsh64.ads | 132 - gcc/ada/g-shshco.adb | 135 - gcc/ada/g-shshco.ads | 66 - gcc/ada/g-soccon.ads | 40 - gcc/ada/g-socket-dummy.adb | 32 - gcc/ada/g-socket-dummy.ads | 37 - gcc/ada/g-socket.adb | 2786 ----- gcc/ada/g-socket.ads | 1288 --- gcc/ada/g-socthi-dummy.adb | 32 - gcc/ada/g-socthi-dummy.ads | 37 - gcc/ada/g-socthi-mingw.adb | 631 -- gcc/ada/g-socthi-mingw.ads | 242 - gcc/ada/g-socthi-vxworks.adb | 487 - gcc/ada/g-socthi-vxworks.ads | 228 - gcc/ada/g-socthi.adb | 491 - gcc/ada/g-socthi.ads | 259 - gcc/ada/g-soliop-mingw.ads | 42 - gcc/ada/g-soliop-solaris.ads | 43 - gcc/ada/g-soliop.ads | 42 - gcc/ada/g-sothco-dummy.adb | 32 - gcc/ada/g-sothco-dummy.ads | 37 - gcc/ada/g-sothco.adb | 77 - gcc/ada/g-sothco.ads | 409 - gcc/ada/g-souinf.ads | 96 - gcc/ada/g-spchge.adb | 161 - gcc/ada/g-spchge.ads | 65 - gcc/ada/g-speche.adb | 51 - gcc/ada/g-speche.ads | 55 - gcc/ada/g-spipat.adb | 6489 ----------- gcc/ada/g-spipat.ads | 1187 -- gcc/ada/g-spitbo.adb | 769 -- gcc/ada/g-spitbo.ads | 394 - gcc/ada/g-sptabo.ads | 41 - gcc/ada/g-sptain.ads | 41 - gcc/ada/g-sptavs.ads | 40 - gcc/ada/g-sse.ads | 139 - gcc/ada/g-ssvety.ads | 105 - gcc/ada/g-stheme.adb | 55 - gcc/ada/g-strhas.ads | 43 - gcc/ada/g-string.adb | 36 - gcc/ada/g-string.ads | 38 - gcc/ada/g-strspl.ads | 44 - gcc/ada/g-stseme.adb | 48 - gcc/ada/g-stsifd-sockets.adb | 234 - gcc/ada/g-table.adb | 205 - gcc/ada/g-table.ads | 150 - gcc/ada/g-tasloc.adb | 36 - gcc/ada/g-tasloc.ads | 46 - gcc/ada/g-timsta.adb | 59 - gcc/ada/g-timsta.ads | 40 - gcc/ada/g-traceb.adb | 50 - gcc/ada/g-traceb.ads | 101 - gcc/ada/g-trasym.adb | 36 - gcc/ada/g-trasym.ads | 37 - gcc/ada/g-tty.adb | 134 - gcc/ada/g-tty.ads | 73 - gcc/ada/g-u3spch.adb | 51 - gcc/ada/g-u3spch.ads | 57 - gcc/ada/g-utf_32.adb | 36 - gcc/ada/g-utf_32.ads | 47 - gcc/ada/g-wispch.adb | 49 - gcc/ada/g-wispch.ads | 53 - gcc/ada/g-wistsp.ads | 44 - gcc/ada/g-zspche.adb | 49 - gcc/ada/g-zspche.ads | 53 - gcc/ada/g-zstspl.ads | 44 - gcc/ada/gcc-interface/Make-lang.in | 348 +- gcc/ada/gcc-interface/Makefile.in | 550 +- gcc/ada/gnat.ads | 37 - gcc/ada/i-c.adb | 826 -- gcc/ada/i-c.ads | 230 - gcc/ada/i-cexten.ads | 458 - gcc/ada/i-cobol.adb | 993 -- gcc/ada/i-cobol.ads | 553 - gcc/ada/i-cpoint.adb | 295 - gcc/ada/i-cpoint.ads | 102 - gcc/ada/i-cstrea.adb | 133 - gcc/ada/i-cstrea.ads | 315 - gcc/ada/i-cstrin.adb | 360 - gcc/ada/i-cstrin.ads | 106 - gcc/ada/i-fortra.adb | 142 - gcc/ada/i-fortra.ads | 107 - gcc/ada/i-pacdec.adb | 352 - gcc/ada/i-pacdec.ads | 149 - gcc/ada/i-vxwoio.adb | 72 - gcc/ada/i-vxwoio.ads | 229 - gcc/ada/i-vxwork-x86.ads | 220 - gcc/ada/i-vxwork.ads | 216 - gcc/ada/interfac.ads | 184 - gcc/ada/ioexcept.ads | 24 - gcc/ada/libgnarl/a-intnam-dragonfly.ads | 136 + gcc/ada/libgnarl/a-intnam-rtems.ads | 114 + gcc/ada/libgnat/a-assert.adb | 53 + gcc/ada/libgnat/a-assert.ads | 66 + gcc/ada/libgnat/a-btgbso.adb | 703 ++ gcc/ada/libgnat/a-btgbso.ads | 103 + gcc/ada/libgnat/a-calari.adb | 100 + gcc/ada/libgnat/a-calari.ads | 65 + gcc/ada/libgnat/a-calcon.adb | 148 + gcc/ada/libgnat/a-calcon.ads | 113 + gcc/ada/libgnat/a-caldel.adb | 110 + gcc/ada/libgnat/a-caldel.ads | 53 + gcc/ada/libgnat/a-calend.adb | 1580 +++ gcc/ada/libgnat/a-calend.ads | 395 + gcc/ada/libgnat/a-calfor.adb | 882 ++ gcc/ada/libgnat/a-calfor.ads | 215 + gcc/ada/libgnat/a-catizo.adb | 69 + gcc/ada/libgnat/a-catizo.ads | 32 + gcc/ada/libgnat/a-cbdlli.adb | 2399 ++++ gcc/ada/libgnat/a-cbdlli.ads | 398 + gcc/ada/libgnat/a-cbhama.adb | 1252 +++ gcc/ada/libgnat/a-cbhama.ads | 468 + gcc/ada/libgnat/a-cbhase.adb | 1946 ++++ gcc/ada/libgnat/a-cbhase.ads | 605 + gcc/ada/libgnat/a-cbmutr.adb | 3327 ++++++ gcc/ada/libgnat/a-cbmutr.ads | 406 + gcc/ada/libgnat/a-cborma.adb | 1637 +++ gcc/ada/libgnat/a-cborma.ads | 376 + gcc/ada/libgnat/a-cborse.adb | 2044 ++++ gcc/ada/libgnat/a-cborse.ads | 450 + gcc/ada/libgnat/a-cbprqu.adb | 220 + gcc/ada/libgnat/a-cbprqu.ads | 137 + gcc/ada/libgnat/a-cbsyqu.adb | 168 + gcc/ada/libgnat/a-cbsyqu.ads | 103 + gcc/ada/libgnat/a-cdlili.adb | 2186 ++++ gcc/ada/libgnat/a-cdlili.ads | 406 + gcc/ada/libgnat/a-cfdlli.adb | 1894 ++++ gcc/ada/libgnat/a-cfdlli.ads | 1623 +++ gcc/ada/libgnat/a-cfhama.adb | 888 ++ gcc/ada/libgnat/a-cfhama.ads | 815 ++ gcc/ada/libgnat/a-cfhase.adb | 1573 +++ gcc/ada/libgnat/a-cfhase.ads | 1335 +++ gcc/ada/libgnat/a-cfinve.adb | 1404 +++ gcc/ada/libgnat/a-cfinve.ads | 937 ++ gcc/ada/libgnat/a-cforma.adb | 1159 ++ gcc/ada/libgnat/a-cforma.ads | 1052 ++ gcc/ada/libgnat/a-cforse.adb | 1898 ++++ gcc/ada/libgnat/a-cforse.ads | 1784 +++ gcc/ada/libgnat/a-cgaaso.adb | 47 + gcc/ada/libgnat/a-cgaaso.ads | 41 + gcc/ada/libgnat/a-cgarso.adb | 50 + gcc/ada/libgnat/a-cgarso.ads | 26 + gcc/ada/libgnat/a-cgcaso.adb | 121 + gcc/ada/libgnat/a-cgcaso.ads | 27 + gcc/ada/libgnat/a-chacon.adb | 261 + gcc/ada/libgnat/a-chacon.ads | 86 + gcc/ada/libgnat/a-chahan.adb | 609 + gcc/ada/libgnat/a-chahan.ads | 159 + gcc/ada/libgnat/a-charac.ads | 18 + gcc/ada/libgnat/a-chlat1.ads | 296 + gcc/ada/libgnat/a-chlat9.ads | 332 + gcc/ada/libgnat/a-chtgbk.adb | 346 + gcc/ada/libgnat/a-chtgbk.ads | 120 + gcc/ada/libgnat/a-chtgbo.adb | 553 + gcc/ada/libgnat/a-chtgbo.ads | 156 + gcc/ada/libgnat/a-chtgke.adb | 329 + gcc/ada/libgnat/a-chtgke.ads | 120 + gcc/ada/libgnat/a-chtgop.adb | 838 ++ gcc/ada/libgnat/a-chtgop.ads | 215 + gcc/ada/libgnat/a-chzla1.ads | 376 + gcc/ada/libgnat/a-chzla9.ads | 388 + gcc/ada/libgnat/a-cidlli.adb | 2290 ++++ gcc/ada/libgnat/a-cidlli.ads | 397 + gcc/ada/libgnat/a-cihama.adb | 1364 +++ gcc/ada/libgnat/a-cihama.ads | 455 + gcc/ada/libgnat/a-cihase.adb | 2401 ++++ gcc/ada/libgnat/a-cihase.ads | 595 + gcc/ada/libgnat/a-cimutr.adb | 2698 +++++ gcc/ada/libgnat/a-cimutr.ads | 456 + gcc/ada/libgnat/a-ciorma.adb | 1686 +++ gcc/ada/libgnat/a-ciorma.ads | 388 + gcc/ada/libgnat/a-ciormu.adb | 2013 ++++ gcc/ada/libgnat/a-ciormu.ads | 566 + gcc/ada/libgnat/a-ciorse.adb | 2191 ++++ gcc/ada/libgnat/a-ciorse.ads | 467 + gcc/ada/libgnat/a-clrefi.adb | 36 + gcc/ada/libgnat/a-clrefi.ads | 35 + gcc/ada/libgnat/a-coboho.adb | 99 + gcc/ada/libgnat/a-coboho.ads | 114 + gcc/ada/libgnat/a-cobove.adb | 2805 +++++ gcc/ada/libgnat/a-cobove.ads | 506 + gcc/ada/libgnat/a-cofove.adb | 1398 +++ gcc/ada/libgnat/a-cofove.ads | 924 ++ gcc/ada/libgnat/a-cofuba.adb | 250 + gcc/ada/libgnat/a-cofuba.ads | 117 + gcc/ada/libgnat/a-cofuma.adb | 284 + gcc/ada/libgnat/a-cofuma.ads | 361 + gcc/ada/libgnat/a-cofuse.adb | 174 + gcc/ada/libgnat/a-cofuse.ads | 322 + gcc/ada/libgnat/a-cofuve.adb | 255 + gcc/ada/libgnat/a-cofuve.ads | 393 + gcc/ada/libgnat/a-cogeso.adb | 127 + gcc/ada/libgnat/a-cogeso.ads | 40 + gcc/ada/libgnat/a-cohama.adb | 1200 ++ gcc/ada/libgnat/a-cohama.ads | 470 + gcc/ada/libgnat/a-cohase.adb | 2184 ++++ gcc/ada/libgnat/a-cohase.ads | 609 + gcc/ada/libgnat/a-cohata.ads | 82 + gcc/ada/libgnat/a-coinho-shared.adb | 528 + gcc/ada/libgnat/a-coinho-shared.ads | 192 + gcc/ada/libgnat/a-coinho.adb | 383 + gcc/ada/libgnat/a-coinho.ads | 178 + gcc/ada/libgnat/a-coinve.adb | 3663 ++++++ gcc/ada/libgnat/a-coinve.ads | 509 + gcc/ada/libgnat/a-colien.adb | 72 + gcc/ada/libgnat/a-colien.ads | 55 + gcc/ada/libgnat/a-colire.adb | 124 + gcc/ada/libgnat/a-colire.ads | 79 + gcc/ada/libgnat/a-comlin.adb | 123 + gcc/ada/libgnat/a-comlin.ads | 144 + gcc/ada/libgnat/a-comutr.adb | 2676 +++++ gcc/ada/libgnat/a-comutr.ads | 511 + gcc/ada/libgnat/a-conhel.adb | 186 + gcc/ada/libgnat/a-conhel.ads | 159 + gcc/ada/libgnat/a-contai.ads | 24 + gcc/ada/libgnat/a-convec.adb | 3274 ++++++ gcc/ada/libgnat/a-convec.ads | 518 + gcc/ada/libgnat/a-coorma.adb | 1556 +++ gcc/ada/libgnat/a-coorma.ads | 392 + gcc/ada/libgnat/a-coormu.adb | 1895 ++++ gcc/ada/libgnat/a-coormu.ads | 570 + gcc/ada/libgnat/a-coorse.adb | 1999 ++++ gcc/ada/libgnat/a-coorse.ads | 453 + gcc/ada/libgnat/a-coprnu.adb | 58 + gcc/ada/libgnat/a-coprnu.ads | 51 + gcc/ada/libgnat/a-coteio.ads | 24 + gcc/ada/libgnat/a-crbltr.ads | 80 + gcc/ada/libgnat/a-crbtgk.adb | 690 ++ gcc/ada/libgnat/a-crbtgk.ads | 192 + gcc/ada/libgnat/a-crbtgo.adb | 1159 ++ gcc/ada/libgnat/a-crbtgo.ads | 163 + gcc/ada/libgnat/a-crdlli.adb | 1503 +++ gcc/ada/libgnat/a-crdlli.ads | 337 + gcc/ada/libgnat/a-csquin.ads | 56 + gcc/ada/libgnat/a-cuprqu.adb | 110 + gcc/ada/libgnat/a-cuprqu.ads | 137 + gcc/ada/libgnat/a-cusyqu.adb | 174 + gcc/ada/libgnat/a-cusyqu.ads | 106 + gcc/ada/libgnat/a-cwila1.ads | 322 + gcc/ada/libgnat/a-cwila9.ads | 334 + gcc/ada/libgnat/a-decima.adb | 60 + gcc/ada/libgnat/a-decima.ads | 67 + gcc/ada/libgnat/a-dhfina.ads | 46 + gcc/ada/libgnat/a-diocst.adb | 88 + gcc/ada/libgnat/a-diocst.ads | 54 + gcc/ada/libgnat/a-direct.adb | 1344 +++ gcc/ada/libgnat/a-direct.ads | 487 + gcc/ada/libgnat/a-direio.adb | 289 + gcc/ada/libgnat/a-direio.ads | 193 + gcc/ada/libgnat/a-dirval-mingw.adb | 175 + gcc/ada/libgnat/a-dirval.adb | 104 + gcc/ada/libgnat/a-dirval.ads | 49 + gcc/ada/libgnat/a-einuoc.adb | 48 + gcc/ada/libgnat/a-einuoc.ads | 40 + gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb | 150 + gcc/ada/libgnat/a-elchha.adb | 141 + gcc/ada/libgnat/a-elchha.ads | 41 + gcc/ada/libgnat/a-envvar.adb | 228 + gcc/ada/libgnat/a-envvar.ads | 69 + gcc/ada/libgnat/a-excach.adb | 74 + gcc/ada/libgnat/a-except.adb | 1748 +++ gcc/ada/libgnat/a-except.ads | 349 + gcc/ada/libgnat/a-excpol-abort.adb | 62 + gcc/ada/libgnat/a-excpol.adb | 42 + gcc/ada/libgnat/a-exctra.adb | 43 + gcc/ada/libgnat/a-exctra.ads | 63 + gcc/ada/libgnat/a-exexda.adb | 744 ++ gcc/ada/libgnat/a-exexpr.adb | 439 + gcc/ada/libgnat/a-exextr.adb | 201 + gcc/ada/libgnat/a-exstat.adb | 266 + gcc/ada/libgnat/a-finali.adb | 36 + gcc/ada/libgnat/a-finali.ads | 68 + gcc/ada/libgnat/a-flteio.ads | 21 + gcc/ada/libgnat/a-fwteio.ads | 19 + gcc/ada/libgnat/a-fzteio.ads | 19 + gcc/ada/libgnat/a-inteio.ads | 19 + gcc/ada/libgnat/a-ioexce.ads | 30 + gcc/ada/libgnat/a-iteint.ads | 39 + gcc/ada/libgnat/a-iwteio.ads | 19 + gcc/ada/libgnat/a-izteio.ads | 19 + gcc/ada/libgnat/a-lcteio.ads | 24 + gcc/ada/libgnat/a-lfteio.ads | 19 + gcc/ada/libgnat/a-lfwtio.ads | 19 + gcc/ada/libgnat/a-lfztio.ads | 19 + gcc/ada/libgnat/a-liteio.ads | 19 + gcc/ada/libgnat/a-liwtio.ads | 19 + gcc/ada/libgnat/a-liztio.ads | 19 + gcc/ada/libgnat/a-llctio.ads | 24 + gcc/ada/libgnat/a-llftio.ads | 19 + gcc/ada/libgnat/a-llfwti.ads | 19 + gcc/ada/libgnat/a-llfzti.ads | 19 + gcc/ada/libgnat/a-llitio.ads | 19 + gcc/ada/libgnat/a-lliwti.ads | 19 + gcc/ada/libgnat/a-llizti.ads | 19 + gcc/ada/libgnat/a-locale.adb | 64 + gcc/ada/libgnat/a-locale.ads | 40 + gcc/ada/libgnat/a-ncelfu.ads | 23 + gcc/ada/libgnat/a-ngcefu.adb | 710 ++ gcc/ada/libgnat/a-ngcefu.ads | 55 + gcc/ada/libgnat/a-ngcoar.adb | 1255 +++ gcc/ada/libgnat/a-ngcoar.ads | 281 + gcc/ada/libgnat/a-ngcoty.adb | 681 ++ gcc/ada/libgnat/a-ngcoty.ads | 157 + gcc/ada/libgnat/a-ngelfu.adb | 997 ++ gcc/ada/libgnat/a-ngelfu.ads | 205 + gcc/ada/libgnat/a-ngrear.adb | 777 ++ gcc/ada/libgnat/a-ngrear.ads | 142 + gcc/ada/libgnat/a-nlcefu.ads | 22 + gcc/ada/libgnat/a-nlcoar.ads | 23 + gcc/ada/libgnat/a-nlcoty.ads | 21 + gcc/ada/libgnat/a-nlelfu.ads | 21 + gcc/ada/libgnat/a-nllcar.ads | 24 + gcc/ada/libgnat/a-nllcef.ads | 22 + gcc/ada/libgnat/a-nllcty.ads | 21 + gcc/ada/libgnat/a-nllefu.ads | 21 + gcc/ada/libgnat/a-nllrar.ads | 21 + gcc/ada/libgnat/a-nlrear.ads | 21 + gcc/ada/libgnat/a-nscefu.ads | 22 + gcc/ada/libgnat/a-nscoty.ads | 21 + gcc/ada/libgnat/a-nselfu.ads | 21 + gcc/ada/libgnat/a-nucoar.ads | 23 + gcc/ada/libgnat/a-nucoty.ads | 21 + gcc/ada/libgnat/a-nudira.adb | 96 + gcc/ada/libgnat/a-nudira.ads | 75 + gcc/ada/libgnat/a-nuelfu.ads | 21 + gcc/ada/libgnat/a-nuflra.adb | 104 + gcc/ada/libgnat/a-nuflra.ads | 74 + gcc/ada/libgnat/a-numaux-darwin.adb | 211 + gcc/ada/libgnat/a-numaux-darwin.ads | 103 + gcc/ada/libgnat/a-numaux-libc-x86.ads | 97 + gcc/ada/libgnat/a-numaux-vxworks.ads | 97 + gcc/ada/libgnat/a-numaux-x86.adb | 577 + gcc/ada/libgnat/a-numaux-x86.ads | 76 + gcc/ada/libgnat/a-numaux.ads | 112 + gcc/ada/libgnat/a-numeri.ads | 32 + gcc/ada/libgnat/a-nurear.ads | 21 + gcc/ada/libgnat/a-rbtgbk.adb | 627 ++ gcc/ada/libgnat/a-rbtgbk.ads | 193 + gcc/ada/libgnat/a-rbtgbo.adb | 1127 ++ gcc/ada/libgnat/a-rbtgbo.ads | 156 + gcc/ada/libgnat/a-rbtgso.adb | 739 ++ gcc/ada/libgnat/a-rbtgso.ads | 106 + gcc/ada/libgnat/a-sbecin.adb | 40 + gcc/ada/libgnat/a-sbecin.ads | 42 + gcc/ada/libgnat/a-sbhcin.adb | 38 + gcc/ada/libgnat/a-sbhcin.ads | 44 + gcc/ada/libgnat/a-sblcin.adb | 40 + gcc/ada/libgnat/a-sblcin.ads | 42 + gcc/ada/libgnat/a-scteio.ads | 24 + gcc/ada/libgnat/a-secain.adb | 59 + gcc/ada/libgnat/a-secain.ads | 38 + gcc/ada/libgnat/a-sequio.adb | 314 + gcc/ada/libgnat/a-sequio.ads | 160 + gcc/ada/libgnat/a-sfecin.ads | 40 + gcc/ada/libgnat/a-sfhcin.ads | 41 + gcc/ada/libgnat/a-sflcin.ads | 40 + gcc/ada/libgnat/a-sfteio.ads | 19 + gcc/ada/libgnat/a-sfwtio.ads | 19 + gcc/ada/libgnat/a-sfztio.ads | 19 + gcc/ada/libgnat/a-shcain.adb | 41 + gcc/ada/libgnat/a-shcain.ads | 37 + gcc/ada/libgnat/a-siocst.adb | 86 + gcc/ada/libgnat/a-siocst.ads | 54 + gcc/ada/libgnat/a-siteio.ads | 19 + gcc/ada/libgnat/a-siwtio.ads | 19 + gcc/ada/libgnat/a-siztio.ads | 19 + gcc/ada/libgnat/a-slcain.adb | 72 + gcc/ada/libgnat/a-slcain.ads | 36 + gcc/ada/libgnat/a-ssicst.adb | 87 + gcc/ada/libgnat/a-ssicst.ads | 53 + gcc/ada/libgnat/a-ssitio.ads | 19 + gcc/ada/libgnat/a-ssiwti.ads | 19 + gcc/ada/libgnat/a-ssizti.ads | 19 + gcc/ada/libgnat/a-stboha.adb | 40 + gcc/ada/libgnat/a-stboha.ads | 25 + gcc/ada/libgnat/a-stfiha.ads | 21 + gcc/ada/libgnat/a-stmaco.ads | 915 ++ gcc/ada/libgnat/a-storio.adb | 60 + gcc/ada/libgnat/a-storio.ads | 47 + gcc/ada/libgnat/a-strbou.adb | 106 + gcc/ada/libgnat/a-strbou.ads | 914 ++ gcc/ada/libgnat/a-stream.adb | 70 + gcc/ada/libgnat/a-stream.ads | 87 + gcc/ada/libgnat/a-strfix.adb | 747 ++ gcc/ada/libgnat/a-strfix.ads | 251 + gcc/ada/libgnat/a-strhas.adb | 38 + gcc/ada/libgnat/a-strhas.ads | 25 + gcc/ada/libgnat/a-string.ads | 35 + gcc/ada/libgnat/a-strmap.adb | 322 + gcc/ada/libgnat/a-strmap.ads | 411 + gcc/ada/libgnat/a-strsea.adb | 645 ++ gcc/ada/libgnat/a-strsea.ads | 121 + gcc/ada/libgnat/a-strsup.adb | 1925 ++++ gcc/ada/libgnat/a-strsup.ads | 493 + gcc/ada/libgnat/a-strunb-shared.adb | 2115 ++++ gcc/ada/libgnat/a-strunb-shared.ads | 490 + gcc/ada/libgnat/a-strunb.adb | 1073 ++ gcc/ada/libgnat/a-strunb.ads | 437 + gcc/ada/libgnat/a-ststio.adb | 490 + gcc/ada/libgnat/a-ststio.ads | 223 + gcc/ada/libgnat/a-stunau-shared.adb | 62 + gcc/ada/libgnat/a-stunau.adb | 62 + gcc/ada/libgnat/a-stunau.ads | 77 + gcc/ada/libgnat/a-stunha.adb | 40 + gcc/ada/libgnat/a-stunha.ads | 21 + gcc/ada/libgnat/a-stuten.adb | 209 + gcc/ada/libgnat/a-stuten.ads | 144 + gcc/ada/libgnat/a-stwibo.adb | 94 + gcc/ada/libgnat/a-stwibo.ads | 921 ++ gcc/ada/libgnat/a-stwifi.adb | 688 ++ gcc/ada/libgnat/a-stwifi.ads | 254 + gcc/ada/libgnat/a-stwiha.adb | 40 + gcc/ada/libgnat/a-stwiha.ads | 21 + gcc/ada/libgnat/a-stwima.adb | 742 ++ gcc/ada/libgnat/a-stwima.ads | 240 + gcc/ada/libgnat/a-stwise.adb | 614 ++ gcc/ada/libgnat/a-stwise.ads | 125 + gcc/ada/libgnat/a-stwisu.adb | 1933 ++++ gcc/ada/libgnat/a-stwisu.ads | 499 + gcc/ada/libgnat/a-stwiun-shared.adb | 2128 ++++ gcc/ada/libgnat/a-stwiun-shared.ads | 494 + gcc/ada/libgnat/a-stwiun.adb | 1097 ++ gcc/ada/libgnat/a-stwiun.ads | 443 + gcc/ada/libgnat/a-stzbou.adb | 94 + gcc/ada/libgnat/a-stzbou.ads | 937 ++ gcc/ada/libgnat/a-stzfix.adb | 694 ++ gcc/ada/libgnat/a-stzfix.ads | 264 + gcc/ada/libgnat/a-stzhas.adb | 36 + gcc/ada/libgnat/a-stzhas.ads | 25 + gcc/ada/libgnat/a-stzmap.adb | 747 ++ gcc/ada/libgnat/a-stzmap.ads | 242 + gcc/ada/libgnat/a-stzsea.adb | 617 ++ gcc/ada/libgnat/a-stzsea.ads | 129 + gcc/ada/libgnat/a-stzsup.adb | 1941 ++++ gcc/ada/libgnat/a-stzsup.ads | 508 + gcc/ada/libgnat/a-stzunb-shared.adb | 2137 ++++ gcc/ada/libgnat/a-stzunb-shared.ads | 513 + gcc/ada/libgnat/a-stzunb.adb | 1107 ++ gcc/ada/libgnat/a-stzunb.ads | 452 + gcc/ada/libgnat/a-suecin.adb | 47 + gcc/ada/libgnat/a-suecin.ads | 38 + gcc/ada/libgnat/a-suenco.adb | 418 + gcc/ada/libgnat/a-suenco.ads | 61 + gcc/ada/libgnat/a-suenst.adb | 350 + gcc/ada/libgnat/a-suenst.ads | 65 + gcc/ada/libgnat/a-suewst.adb | 370 + gcc/ada/libgnat/a-suewst.ads | 67 + gcc/ada/libgnat/a-suezst.adb | 429 + gcc/ada/libgnat/a-suezst.ads | 64 + gcc/ada/libgnat/a-suhcin.adb | 43 + gcc/ada/libgnat/a-suhcin.ads | 40 + gcc/ada/libgnat/a-sulcin.adb | 47 + gcc/ada/libgnat/a-sulcin.ads | 38 + gcc/ada/libgnat/a-suteio-shared.adb | 132 + gcc/ada/libgnat/a-suteio.adb | 159 + gcc/ada/libgnat/a-suteio.ads | 61 + gcc/ada/libgnat/a-swbwha.adb | 41 + gcc/ada/libgnat/a-swbwha.ads | 25 + gcc/ada/libgnat/a-swfwha.ads | 22 + gcc/ada/libgnat/a-swmwco.ads | 450 + gcc/ada/libgnat/a-swunau-shared.adb | 65 + gcc/ada/libgnat/a-swunau.adb | 65 + gcc/ada/libgnat/a-swunau.ads | 76 + gcc/ada/libgnat/a-swuwha.adb | 40 + gcc/ada/libgnat/a-swuwha.ads | 23 + gcc/ada/libgnat/a-swuwti-shared.adb | 134 + gcc/ada/libgnat/a-swuwti.adb | 161 + gcc/ada/libgnat/a-swuwti.ads | 69 + gcc/ada/libgnat/a-szbzha.adb | 41 + gcc/ada/libgnat/a-szbzha.ads | 28 + gcc/ada/libgnat/a-szfzha.ads | 24 + gcc/ada/libgnat/a-szmzco.ads | 450 + gcc/ada/libgnat/a-szunau-shared.adb | 65 + gcc/ada/libgnat/a-szunau.adb | 65 + gcc/ada/libgnat/a-szunau.ads | 78 + gcc/ada/libgnat/a-szuzha.adb | 40 + gcc/ada/libgnat/a-szuzha.ads | 21 + gcc/ada/libgnat/a-szuzti-shared.adb | 135 + gcc/ada/libgnat/a-szuzti.adb | 162 + gcc/ada/libgnat/a-szuzti.ads | 71 + gcc/ada/libgnat/a-tags.adb | 1100 ++ gcc/ada/libgnat/a-tags.ads | 612 ++ gcc/ada/libgnat/a-teioed.adb | 2860 +++++ gcc/ada/libgnat/a-teioed.ads | 194 + gcc/ada/libgnat/a-textio.adb | 2182 ++++ gcc/ada/libgnat/a-textio.ads | 471 + gcc/ada/libgnat/a-tgdico.ads | 29 + gcc/ada/libgnat/a-tiboio.adb | 179 + gcc/ada/libgnat/a-tiboio.ads | 50 + gcc/ada/libgnat/a-ticoau.adb | 202 + gcc/ada/libgnat/a-ticoau.ads | 69 + gcc/ada/libgnat/a-ticoio.adb | 140 + gcc/ada/libgnat/a-ticoio.ads | 84 + gcc/ada/libgnat/a-tideau.adb | 261 + gcc/ada/libgnat/a-tideau.ads | 92 + gcc/ada/libgnat/a-tideio.adb | 137 + gcc/ada/libgnat/a-tideio.ads | 89 + gcc/ada/libgnat/a-tienau.adb | 283 + gcc/ada/libgnat/a-tienau.ads | 69 + gcc/ada/libgnat/a-tienio.adb | 137 + gcc/ada/libgnat/a-tienio.ads | 55 + gcc/ada/libgnat/a-tifiio.adb | 716 ++ gcc/ada/libgnat/a-tifiio.ads | 69 + gcc/ada/libgnat/a-tiflau.adb | 235 + gcc/ada/libgnat/a-tiflau.ads | 72 + gcc/ada/libgnat/a-tiflio.adb | 145 + gcc/ada/libgnat/a-tiflio.ads | 89 + gcc/ada/libgnat/a-tigeau.adb | 487 + gcc/ada/libgnat/a-tigeau.ads | 191 + gcc/ada/libgnat/a-tigeli.adb | 241 + gcc/ada/libgnat/a-tiinau.adb | 297 + gcc/ada/libgnat/a-tiinau.ads | 83 + gcc/ada/libgnat/a-tiinio.adb | 154 + gcc/ada/libgnat/a-tiinio.ads | 85 + gcc/ada/libgnat/a-timoau.adb | 305 + gcc/ada/libgnat/a-timoau.ads | 87 + gcc/ada/libgnat/a-timoio.adb | 141 + gcc/ada/libgnat/a-timoio.ads | 85 + gcc/ada/libgnat/a-tiocst.adb | 84 + gcc/ada/libgnat/a-tiocst.ads | 53 + gcc/ada/libgnat/a-tirsfi.adb | 39 + gcc/ada/libgnat/a-tirsfi.ads | 40 + gcc/ada/libgnat/a-titest.adb | 46 + gcc/ada/libgnat/a-titest.ads | 23 + gcc/ada/libgnat/a-tiunio.ads | 61 + gcc/ada/libgnat/a-unccon.ads | 24 + gcc/ada/libgnat/a-uncdea.ads | 23 + gcc/ada/libgnat/a-undesu.adb | 43 + gcc/ada/libgnat/a-undesu.ads | 19 + gcc/ada/libgnat/a-wichha.adb | 195 + gcc/ada/libgnat/a-wichha.ads | 127 + gcc/ada/libgnat/a-wichun.adb | 178 + gcc/ada/libgnat/a-wichun.ads | 197 + gcc/ada/libgnat/a-widcha.ads | 21 + gcc/ada/libgnat/a-witeio.adb | 1965 ++++ gcc/ada/libgnat/a-witeio.ads | 495 + gcc/ada/libgnat/a-wrstfi.adb | 39 + gcc/ada/libgnat/a-wrstfi.ads | 41 + gcc/ada/libgnat/a-wtcoau.adb | 202 + gcc/ada/libgnat/a-wtcoau.ads | 69 + gcc/ada/libgnat/a-wtcoio.adb | 159 + gcc/ada/libgnat/a-wtcoio.ads | 62 + gcc/ada/libgnat/a-wtcstr.adb | 85 + gcc/ada/libgnat/a-wtcstr.ads | 53 + gcc/ada/libgnat/a-wtdeau.adb | 265 + gcc/ada/libgnat/a-wtdeau.ads | 93 + gcc/ada/libgnat/a-wtdeio.adb | 155 + gcc/ada/libgnat/a-wtdeio.ads | 64 + gcc/ada/libgnat/a-wtedit.adb | 2716 +++++ gcc/ada/libgnat/a-wtedit.ads | 197 + gcc/ada/libgnat/a-wtenau.adb | 349 + gcc/ada/libgnat/a-wtenau.ads | 69 + gcc/ada/libgnat/a-wtenio.adb | 104 + gcc/ada/libgnat/a-wtenio.ads | 54 + gcc/ada/libgnat/a-wtfiio.adb | 126 + gcc/ada/libgnat/a-wtfiio.ads | 64 + gcc/ada/libgnat/a-wtflau.adb | 235 + gcc/ada/libgnat/a-wtflau.ads | 72 + gcc/ada/libgnat/a-wtflio.adb | 127 + gcc/ada/libgnat/a-wtflio.ads | 64 + gcc/ada/libgnat/a-wtgeau.adb | 528 + gcc/ada/libgnat/a-wtgeau.ads | 184 + gcc/ada/libgnat/a-wtinau.adb | 295 + gcc/ada/libgnat/a-wtinau.ads | 83 + gcc/ada/libgnat/a-wtinio.adb | 145 + gcc/ada/libgnat/a-wtinio.ads | 60 + gcc/ada/libgnat/a-wtmoau.adb | 305 + gcc/ada/libgnat/a-wtmoau.ads | 87 + gcc/ada/libgnat/a-wtmoio.adb | 141 + gcc/ada/libgnat/a-wtmoio.ads | 62 + gcc/ada/libgnat/a-wttest.adb | 46 + gcc/ada/libgnat/a-wttest.ads | 24 + gcc/ada/libgnat/a-wwboio.adb | 179 + gcc/ada/libgnat/a-wwboio.ads | 50 + gcc/ada/libgnat/a-wwunio.ads | 61 + gcc/ada/libgnat/a-zchara.ads | 18 + gcc/ada/libgnat/a-zchhan.adb | 187 + gcc/ada/libgnat/a-zchhan.ads | 132 + gcc/ada/libgnat/a-zchuni.adb | 178 + gcc/ada/libgnat/a-zchuni.ads | 196 + gcc/ada/libgnat/a-zrstfi.adb | 39 + gcc/ada/libgnat/a-zrstfi.ads | 41 + gcc/ada/libgnat/a-ztcoau.adb | 202 + gcc/ada/libgnat/a-ztcoau.ads | 53 + gcc/ada/libgnat/a-ztcoio.adb | 159 + gcc/ada/libgnat/a-ztcoio.ads | 62 + gcc/ada/libgnat/a-ztcstr.adb | 85 + gcc/ada/libgnat/a-ztcstr.ads | 53 + gcc/ada/libgnat/a-ztdeau.adb | 263 + gcc/ada/libgnat/a-ztdeau.ads | 93 + gcc/ada/libgnat/a-ztdeio.adb | 164 + gcc/ada/libgnat/a-ztdeio.ads | 64 + gcc/ada/libgnat/a-ztedit.adb | 2712 +++++ gcc/ada/libgnat/a-ztedit.ads | 198 + gcc/ada/libgnat/a-ztenau.adb | 353 + gcc/ada/libgnat/a-ztenau.ads | 69 + gcc/ada/libgnat/a-ztenio.adb | 104 + gcc/ada/libgnat/a-ztenio.ads | 54 + gcc/ada/libgnat/a-ztexio.adb | 1939 ++++ gcc/ada/libgnat/a-ztexio.ads | 497 + gcc/ada/libgnat/a-ztfiio.adb | 126 + gcc/ada/libgnat/a-ztfiio.ads | 64 + gcc/ada/libgnat/a-ztflau.adb | 235 + gcc/ada/libgnat/a-ztflau.ads | 72 + gcc/ada/libgnat/a-ztflio.adb | 126 + gcc/ada/libgnat/a-ztflio.ads | 64 + gcc/ada/libgnat/a-ztgeau.adb | 528 + gcc/ada/libgnat/a-ztgeau.ads | 184 + gcc/ada/libgnat/a-ztinau.adb | 295 + gcc/ada/libgnat/a-ztinau.ads | 83 + gcc/ada/libgnat/a-ztinio.adb | 145 + gcc/ada/libgnat/a-ztinio.ads | 60 + gcc/ada/libgnat/a-ztmoau.adb | 305 + gcc/ada/libgnat/a-ztmoau.ads | 88 + gcc/ada/libgnat/a-ztmoio.adb | 141 + gcc/ada/libgnat/a-ztmoio.ads | 60 + gcc/ada/libgnat/a-zttest.adb | 46 + gcc/ada/libgnat/a-zttest.ads | 24 + gcc/ada/libgnat/a-zzboio.adb | 180 + gcc/ada/libgnat/a-zzboio.ads | 50 + gcc/ada/libgnat/a-zzunio.ads | 63 + gcc/ada/libgnat/ada.ads | 22 + gcc/ada/libgnat/calendar.ads | 18 + gcc/ada/libgnat/directio.ads | 24 + gcc/ada/libgnat/g-allein.ads | 304 + gcc/ada/libgnat/g-alleve-hard.adb | 35 + gcc/ada/libgnat/g-alleve-hard.ads | 593 + gcc/ada/libgnat/g-alleve.adb | 4956 +++++++++ gcc/ada/libgnat/g-alleve.ads | 525 + gcc/ada/libgnat/g-altcon.adb | 514 + gcc/ada/libgnat/g-altcon.ads | 101 + gcc/ada/libgnat/g-altive.ads | 766 ++ gcc/ada/libgnat/g-alveop.adb | 11008 +++++++++++++++++++ gcc/ada/libgnat/g-alveop.ads | 8362 ++++++++++++++ gcc/ada/libgnat/g-alvety.ads | 150 + gcc/ada/libgnat/g-alvevi.ads | 156 + gcc/ada/libgnat/g-arrspl.adb | 352 + gcc/ada/libgnat/g-arrspl.ads | 190 + gcc/ada/libgnat/g-awk.adb | 1488 +++ gcc/ada/libgnat/g-awk.ads | 642 ++ gcc/ada/libgnat/g-binenv.adb | 83 + gcc/ada/libgnat/g-binenv.ads | 40 + gcc/ada/libgnat/g-bubsor.adb | 56 + gcc/ada/libgnat/g-bubsor.ads | 66 + gcc/ada/libgnat/g-busora.adb | 58 + gcc/ada/libgnat/g-busora.ads | 63 + gcc/ada/libgnat/g-busorg.adb | 58 + gcc/ada/libgnat/g-busorg.ads | 72 + gcc/ada/libgnat/g-byorma.adb | 195 + gcc/ada/libgnat/g-byorma.ads | 100 + gcc/ada/libgnat/g-bytswa.adb | 113 + gcc/ada/libgnat/g-bytswa.ads | 206 + gcc/ada/libgnat/g-calend.adb | 652 ++ gcc/ada/libgnat/g-calend.ads | 185 + gcc/ada/libgnat/g-casuti.adb | 38 + gcc/ada/libgnat/g-casuti.ads | 77 + gcc/ada/libgnat/g-catiio.adb | 1242 +++ gcc/ada/libgnat/g-catiio.ads | 168 + gcc/ada/libgnat/g-cgi.adb | 494 + gcc/ada/libgnat/g-cgi.ads | 255 + gcc/ada/libgnat/g-cgicoo.adb | 405 + gcc/ada/libgnat/g-cgicoo.ads | 120 + gcc/ada/libgnat/g-cgideb.adb | 314 + gcc/ada/libgnat/g-cgideb.ads | 47 + gcc/ada/libgnat/g-comlin.adb | 3613 ++++++ gcc/ada/libgnat/g-comlin.ads | 1201 ++ gcc/ada/libgnat/g-comver.adb | 72 + gcc/ada/libgnat/g-comver.ads | 61 + gcc/ada/libgnat/g-cppexc.adb | 139 + gcc/ada/libgnat/g-cppexc.ads | 48 + gcc/ada/libgnat/g-crc32.adb | 85 + gcc/ada/libgnat/g-crc32.ads | 111 + gcc/ada/libgnat/g-ctrl_c.adb | 63 + gcc/ada/libgnat/g-ctrl_c.ads | 59 + gcc/ada/libgnat/g-curexc.ads | 112 + gcc/ada/libgnat/g-debpoo.adb | 2520 +++++ gcc/ada/libgnat/g-debpoo.ads | 409 + gcc/ada/libgnat/g-debuti.adb | 188 + gcc/ada/libgnat/g-debuti.ads | 81 + gcc/ada/libgnat/g-decstr.adb | 796 ++ gcc/ada/libgnat/g-decstr.ads | 176 + gcc/ada/libgnat/g-deutst.ads | 43 + gcc/ada/libgnat/g-diopit.adb | 396 + gcc/ada/libgnat/g-diopit.ads | 92 + gcc/ada/libgnat/g-dirope.adb | 775 ++ gcc/ada/libgnat/g-dirope.ads | 262 + gcc/ada/libgnat/g-dynhta.adb | 369 + gcc/ada/libgnat/g-dynhta.ads | 266 + gcc/ada/libgnat/g-dyntab.adb | 497 + gcc/ada/libgnat/g-dyntab.ads | 293 + gcc/ada/libgnat/g-eacodu.adb | 49 + gcc/ada/libgnat/g-encstr.adb | 258 + gcc/ada/libgnat/g-encstr.ads | 109 + gcc/ada/libgnat/g-enutst.ads | 43 + gcc/ada/libgnat/g-excact.adb | 131 + gcc/ada/libgnat/g-excact.ads | 118 + gcc/ada/libgnat/g-except.ads | 82 + gcc/ada/libgnat/g-exctra.adb | 36 + gcc/ada/libgnat/g-exctra.ads | 39 + gcc/ada/libgnat/g-expect.adb | 1488 +++ gcc/ada/libgnat/g-expect.ads | 647 ++ gcc/ada/libgnat/g-exptty.adb | 324 + gcc/ada/libgnat/g-exptty.ads | 137 + gcc/ada/libgnat/g-flocon.ads | 38 + gcc/ada/libgnat/g-forstr.adb | 984 ++ gcc/ada/libgnat/g-forstr.ads | 311 + gcc/ada/libgnat/g-heasor.adb | 130 + gcc/ada/libgnat/g-heasor.ads | 72 + gcc/ada/libgnat/g-hesora.adb | 134 + gcc/ada/libgnat/g-hesora.ads | 69 + gcc/ada/libgnat/g-hesorg.adb | 142 + gcc/ada/libgnat/g-hesorg.ads | 88 + gcc/ada/libgnat/g-htable.adb | 40 + gcc/ada/libgnat/g-htable.ads | 60 + gcc/ada/libgnat/g-io-put-vxworks.adb | 53 + gcc/ada/libgnat/g-io.adb | 191 + gcc/ada/libgnat/g-io.ads | 91 + gcc/ada/libgnat/g-io_aux.adb | 105 + gcc/ada/libgnat/g-io_aux.ads | 54 + gcc/ada/libgnat/g-locfil.adb | 134 + gcc/ada/libgnat/g-locfil.ads | 72 + gcc/ada/libgnat/g-mbdira.adb | 282 + gcc/ada/libgnat/g-mbdira.ads | 123 + gcc/ada/libgnat/g-mbflra.adb | 314 + gcc/ada/libgnat/g-mbflra.ads | 103 + gcc/ada/libgnat/g-md5.adb | 36 + gcc/ada/libgnat/g-md5.ads | 49 + gcc/ada/libgnat/g-memdum.adb | 179 + gcc/ada/libgnat/g-memdum.ads | 77 + gcc/ada/libgnat/g-moreex.adb | 85 + gcc/ada/libgnat/g-moreex.ads | 74 + gcc/ada/libgnat/g-os_lib.adb | 36 + gcc/ada/libgnat/g-os_lib.ads | 51 + gcc/ada/libgnat/g-pehage.adb | 2600 +++++ gcc/ada/libgnat/g-pehage.ads | 238 + gcc/ada/libgnat/g-rannum.adb | 344 + gcc/ada/libgnat/g-rannum.ads | 161 + gcc/ada/libgnat/g-regexp.adb | 36 + gcc/ada/libgnat/g-regexp.ads | 70 + gcc/ada/libgnat/g-regist.adb | 553 + gcc/ada/libgnat/g-regist.ads | 161 + gcc/ada/libgnat/g-regpat.adb | 37 + gcc/ada/libgnat/g-regpat.ads | 72 + gcc/ada/libgnat/g-rewdat.adb | 253 + gcc/ada/libgnat/g-rewdat.ads | 152 + gcc/ada/libgnat/g-sechas.adb | 486 + gcc/ada/libgnat/g-sechas.ads | 240 + gcc/ada/libgnat/g-sehamd.adb | 342 + gcc/ada/libgnat/g-sehamd.ads | 74 + gcc/ada/libgnat/g-sehash.adb | 179 + gcc/ada/libgnat/g-sehash.ads | 72 + gcc/ada/libgnat/g-sercom-linux.adb | 314 + gcc/ada/libgnat/g-sercom-mingw.adb | 316 + gcc/ada/libgnat/g-sercom.adb | 136 + gcc/ada/libgnat/g-sercom.ads | 190 + gcc/ada/libgnat/g-sestin.ads | 48 + gcc/ada/libgnat/g-sha1.adb | 36 + gcc/ada/libgnat/g-sha1.ads | 49 + gcc/ada/libgnat/g-sha224.ads | 50 + gcc/ada/libgnat/g-sha256.ads | 50 + gcc/ada/libgnat/g-sha384.ads | 50 + gcc/ada/libgnat/g-sha512.ads | 50 + gcc/ada/libgnat/g-shsh32.adb | 80 + gcc/ada/libgnat/g-shsh32.ads | 108 + gcc/ada/libgnat/g-shsh64.adb | 80 + gcc/ada/libgnat/g-shsh64.ads | 132 + gcc/ada/libgnat/g-shshco.adb | 135 + gcc/ada/libgnat/g-shshco.ads | 66 + gcc/ada/libgnat/g-soccon.ads | 40 + gcc/ada/libgnat/g-socket-dummy.adb | 32 + gcc/ada/libgnat/g-socket-dummy.ads | 37 + gcc/ada/libgnat/g-socket.adb | 2786 +++++ gcc/ada/libgnat/g-socket.ads | 1288 +++ gcc/ada/libgnat/g-socthi-dummy.adb | 32 + gcc/ada/libgnat/g-socthi-dummy.ads | 37 + gcc/ada/libgnat/g-socthi-mingw.adb | 631 ++ gcc/ada/libgnat/g-socthi-mingw.ads | 242 + gcc/ada/libgnat/g-socthi-vxworks.adb | 487 + gcc/ada/libgnat/g-socthi-vxworks.ads | 228 + gcc/ada/libgnat/g-socthi.adb | 491 + gcc/ada/libgnat/g-socthi.ads | 259 + gcc/ada/libgnat/g-soliop-mingw.ads | 42 + gcc/ada/libgnat/g-soliop-solaris.ads | 43 + gcc/ada/libgnat/g-soliop.ads | 42 + gcc/ada/libgnat/g-sothco-dummy.adb | 32 + gcc/ada/libgnat/g-sothco-dummy.ads | 37 + gcc/ada/libgnat/g-sothco.adb | 77 + gcc/ada/libgnat/g-sothco.ads | 409 + gcc/ada/libgnat/g-souinf.ads | 96 + gcc/ada/libgnat/g-spchge.adb | 161 + gcc/ada/libgnat/g-spchge.ads | 65 + gcc/ada/libgnat/g-speche.adb | 51 + gcc/ada/libgnat/g-speche.ads | 55 + gcc/ada/libgnat/g-spipat.adb | 6489 +++++++++++ gcc/ada/libgnat/g-spipat.ads | 1187 ++ gcc/ada/libgnat/g-spitbo.adb | 769 ++ gcc/ada/libgnat/g-spitbo.ads | 394 + gcc/ada/libgnat/g-sptabo.ads | 41 + gcc/ada/libgnat/g-sptain.ads | 41 + gcc/ada/libgnat/g-sptavs.ads | 40 + gcc/ada/libgnat/g-sse.ads | 139 + gcc/ada/libgnat/g-ssvety.ads | 105 + gcc/ada/libgnat/g-stheme.adb | 55 + gcc/ada/libgnat/g-strhas.ads | 43 + gcc/ada/libgnat/g-string.adb | 36 + gcc/ada/libgnat/g-string.ads | 38 + gcc/ada/libgnat/g-strspl.ads | 44 + gcc/ada/libgnat/g-stseme.adb | 48 + gcc/ada/libgnat/g-stsifd-sockets.adb | 234 + gcc/ada/libgnat/g-table.adb | 205 + gcc/ada/libgnat/g-table.ads | 150 + gcc/ada/libgnat/g-tasloc.adb | 36 + gcc/ada/libgnat/g-tasloc.ads | 46 + gcc/ada/libgnat/g-timsta.adb | 59 + gcc/ada/libgnat/g-timsta.ads | 40 + gcc/ada/libgnat/g-traceb.adb | 50 + gcc/ada/libgnat/g-traceb.ads | 101 + gcc/ada/libgnat/g-trasym.adb | 36 + gcc/ada/libgnat/g-trasym.ads | 37 + gcc/ada/libgnat/g-tty.adb | 134 + gcc/ada/libgnat/g-tty.ads | 73 + gcc/ada/libgnat/g-u3spch.adb | 51 + gcc/ada/libgnat/g-u3spch.ads | 57 + gcc/ada/libgnat/g-utf_32.adb | 36 + gcc/ada/libgnat/g-utf_32.ads | 47 + gcc/ada/libgnat/g-wispch.adb | 49 + gcc/ada/libgnat/g-wispch.ads | 53 + gcc/ada/libgnat/g-wistsp.ads | 44 + gcc/ada/libgnat/g-zspche.adb | 49 + gcc/ada/libgnat/g-zspche.ads | 53 + gcc/ada/libgnat/g-zstspl.ads | 44 + gcc/ada/libgnat/gnat.ads | 37 + gcc/ada/libgnat/i-c.adb | 826 ++ gcc/ada/libgnat/i-c.ads | 230 + gcc/ada/libgnat/i-cexten.ads | 458 + gcc/ada/libgnat/i-cobol.adb | 993 ++ gcc/ada/libgnat/i-cobol.ads | 553 + gcc/ada/libgnat/i-cpoint.adb | 295 + gcc/ada/libgnat/i-cpoint.ads | 102 + gcc/ada/libgnat/i-cstrea.adb | 133 + gcc/ada/libgnat/i-cstrea.ads | 315 + gcc/ada/libgnat/i-cstrin.adb | 360 + gcc/ada/libgnat/i-cstrin.ads | 106 + gcc/ada/libgnat/i-fortra.adb | 142 + gcc/ada/libgnat/i-fortra.ads | 107 + gcc/ada/libgnat/i-pacdec.adb | 352 + gcc/ada/libgnat/i-pacdec.ads | 149 + gcc/ada/libgnat/i-vxwoio.adb | 72 + gcc/ada/libgnat/i-vxwoio.ads | 229 + gcc/ada/libgnat/i-vxwork-x86.ads | 220 + gcc/ada/libgnat/i-vxwork.ads | 216 + gcc/ada/libgnat/interfac.ads | 184 + gcc/ada/libgnat/ioexcept.ads | 24 + gcc/ada/libgnat/machcode.ads | 18 + gcc/ada/libgnat/memtrack.adb | 401 + gcc/ada/libgnat/s-addima.adb | 72 + gcc/ada/libgnat/s-addima.ads | 43 + gcc/ada/libgnat/s-addope.adb | 110 + gcc/ada/libgnat/s-addope.ads | 87 + gcc/ada/libgnat/s-arit64.adb | 605 + gcc/ada/libgnat/s-arit64.ads | 84 + gcc/ada/libgnat/s-assert.adb | 49 + gcc/ada/libgnat/s-assert.ads | 50 + gcc/ada/libgnat/s-atacco.adb | 36 + gcc/ada/libgnat/s-atacco.ads | 63 + gcc/ada/libgnat/s-atocou-builtin.adb | 111 + gcc/ada/libgnat/s-atocou-x86.adb | 112 + gcc/ada/libgnat/s-atocou.adb | 93 + gcc/ada/libgnat/s-atocou.ads | 107 + gcc/ada/libgnat/s-atopri.adb | 201 + gcc/ada/libgnat/s-atopri.ads | 180 + gcc/ada/libgnat/s-auxdec.adb | 718 ++ gcc/ada/libgnat/s-auxdec.ads | 656 ++ gcc/ada/libgnat/s-bignum.adb | 1105 ++ gcc/ada/libgnat/s-bignum.ads | 116 + gcc/ada/libgnat/s-bitops.adb | 220 + gcc/ada/libgnat/s-bitops.ads | 99 + gcc/ada/libgnat/s-boarop.ads | 65 + gcc/ada/libgnat/s-boustr.adb | 104 + gcc/ada/libgnat/s-boustr.ads | 62 + gcc/ada/libgnat/s-bytswa.ads | 53 + gcc/ada/libgnat/s-carsi8.adb | 143 + gcc/ada/libgnat/s-carsi8.ads | 62 + gcc/ada/libgnat/s-carun8.adb | 144 + gcc/ada/libgnat/s-carun8.ads | 64 + gcc/ada/libgnat/s-casi16.adb | 133 + gcc/ada/libgnat/s-casi16.ads | 53 + gcc/ada/libgnat/s-casi32.adb | 116 + gcc/ada/libgnat/s-casi32.ads | 53 + gcc/ada/libgnat/s-casi64.adb | 116 + gcc/ada/libgnat/s-casi64.ads | 52 + gcc/ada/libgnat/s-casuti.adb | 105 + gcc/ada/libgnat/s-casuti.ads | 66 + gcc/ada/libgnat/s-caun16.adb | 133 + gcc/ada/libgnat/s-caun16.ads | 53 + gcc/ada/libgnat/s-caun32.adb | 116 + gcc/ada/libgnat/s-caun32.ads | 52 + gcc/ada/libgnat/s-caun64.adb | 115 + gcc/ada/libgnat/s-caun64.ads | 52 + gcc/ada/libgnat/s-chepoo.ads | 59 + gcc/ada/libgnat/s-commun.adb | 55 + gcc/ada/libgnat/s-commun.ads | 50 + gcc/ada/libgnat/s-conca2.adb | 73 + gcc/ada/libgnat/s-conca2.ads | 52 + gcc/ada/libgnat/s-conca3.adb | 78 + gcc/ada/libgnat/s-conca3.ads | 52 + gcc/ada/libgnat/s-conca4.adb | 82 + gcc/ada/libgnat/s-conca4.ads | 52 + gcc/ada/libgnat/s-conca5.adb | 86 + gcc/ada/libgnat/s-conca5.ads | 52 + gcc/ada/libgnat/s-conca6.adb | 90 + gcc/ada/libgnat/s-conca6.ads | 52 + gcc/ada/libgnat/s-conca7.adb | 97 + gcc/ada/libgnat/s-conca7.ads | 54 + gcc/ada/libgnat/s-conca8.adb | 102 + gcc/ada/libgnat/s-conca8.ads | 54 + gcc/ada/libgnat/s-conca9.adb | 106 + gcc/ada/libgnat/s-conca9.ads | 54 + gcc/ada/libgnat/s-crc32.adb | 137 + gcc/ada/libgnat/s-crc32.ads | 83 + gcc/ada/libgnat/s-crtl.ads | 241 + gcc/ada/libgnat/s-diflio.adb | 132 + gcc/ada/libgnat/s-diflio.ads | 184 + gcc/ada/libgnat/s-diinio.adb | 109 + gcc/ada/libgnat/s-diinio.ads | 167 + gcc/ada/libgnat/s-dim.ads | 68 + gcc/ada/libgnat/s-dimkio.ads | 38 + gcc/ada/libgnat/s-dimmks.ads | 393 + gcc/ada/libgnat/s-direio.adb | 399 + gcc/ada/libgnat/s-direio.ads | 142 + gcc/ada/libgnat/s-dmotpr.ads | 172 + gcc/ada/libgnat/s-dsaser.ads | 54 + gcc/ada/libgnat/s-dwalin.adb | 1627 +++ gcc/ada/libgnat/s-dwalin.ads | 191 + gcc/ada/libgnat/s-elaall.adb | 72 + gcc/ada/libgnat/s-elaall.ads | 57 + gcc/ada/libgnat/s-excdeb.adb | 77 + gcc/ada/libgnat/s-excdeb.ads | 78 + gcc/ada/libgnat/s-except.adb | 45 + gcc/ada/libgnat/s-except.ads | 66 + gcc/ada/libgnat/s-excmac-arm.adb | 42 + gcc/ada/libgnat/s-excmac-arm.ads | 180 + gcc/ada/libgnat/s-excmac-gcc.adb | 43 + gcc/ada/libgnat/s-excmac-gcc.ads | 185 + gcc/ada/libgnat/s-exctab.adb | 339 + gcc/ada/libgnat/s-exctab.ads | 75 + gcc/ada/libgnat/s-exctra.adb | 124 + gcc/ada/libgnat/s-exctra.ads | 107 + gcc/ada/libgnat/s-exnint.adb | 70 + gcc/ada/libgnat/s-exnint.ads | 39 + gcc/ada/libgnat/s-exnllf.adb | 182 + gcc/ada/libgnat/s-exnllf.ads | 49 + gcc/ada/libgnat/s-exnlli.adb | 74 + gcc/ada/libgnat/s-exnlli.ads | 42 + gcc/ada/libgnat/s-expint.adb | 83 + gcc/ada/libgnat/s-expint.ads | 42 + gcc/ada/libgnat/s-explli.adb | 83 + gcc/ada/libgnat/s-explli.ads | 42 + gcc/ada/libgnat/s-expllu.adb | 74 + gcc/ada/libgnat/s-expllu.ads | 47 + gcc/ada/libgnat/s-expmod.adb | 79 + gcc/ada/libgnat/s-expmod.ads | 56 + gcc/ada/libgnat/s-expuns.adb | 73 + gcc/ada/libgnat/s-expuns.ads | 47 + gcc/ada/libgnat/s-fatflt.ads | 47 + gcc/ada/libgnat/s-fatgen.adb | 931 ++ gcc/ada/libgnat/s-fatgen.ads | 118 + gcc/ada/libgnat/s-fatlfl.ads | 47 + gcc/ada/libgnat/s-fatllf.ads | 47 + gcc/ada/libgnat/s-fatsfl.ads | 47 + gcc/ada/libgnat/s-ficobl.ads | 159 + gcc/ada/libgnat/s-filatt.ads | 71 + gcc/ada/libgnat/s-fileio.adb | 1322 +++ gcc/ada/libgnat/s-fileio.ads | 255 + gcc/ada/libgnat/s-finmas.adb | 554 + gcc/ada/libgnat/s-finmas.ads | 206 + gcc/ada/libgnat/s-finroo.adb | 63 + gcc/ada/libgnat/s-finroo.ads | 46 + gcc/ada/libgnat/s-flocon-none.adb | 46 + gcc/ada/libgnat/s-flocon.adb | 47 + gcc/ada/libgnat/s-flocon.ads | 59 + gcc/ada/libgnat/s-fore.adb | 56 + gcc/ada/libgnat/s-fore.ads | 41 + gcc/ada/libgnat/s-gearop.adb | 934 ++ gcc/ada/libgnat/s-gearop.ads | 502 + gcc/ada/libgnat/s-geveop.adb | 133 + gcc/ada/libgnat/s-geveop.ads | 66 + gcc/ada/libgnat/s-gloloc-mingw.adb | 107 + gcc/ada/libgnat/s-gloloc.adb | 149 + gcc/ada/libgnat/s-gloloc.ads | 63 + gcc/ada/libgnat/s-htable.adb | 412 + gcc/ada/libgnat/s-htable.ads | 222 + gcc/ada/libgnat/s-imenne.adb | 128 + gcc/ada/libgnat/s-imenne.ads | 85 + gcc/ada/libgnat/s-imgbiu.adb | 158 + gcc/ada/libgnat/s-imgbiu.ads | 72 + gcc/ada/libgnat/s-imgboo.adb | 54 + gcc/ada/libgnat/s-imgboo.ads | 45 + gcc/ada/libgnat/s-imgcha.adb | 180 + gcc/ada/libgnat/s-imgcha.ads | 55 + gcc/ada/libgnat/s-imgdec.adb | 420 + gcc/ada/libgnat/s-imgdec.ads | 83 + gcc/ada/libgnat/s-imgenu.adb | 128 + gcc/ada/libgnat/s-imgenu.ads | 78 + gcc/ada/libgnat/s-imgint.adb | 103 + gcc/ada/libgnat/s-imgint.ads | 57 + gcc/ada/libgnat/s-imgllb.adb | 161 + gcc/ada/libgnat/s-imgllb.ads | 72 + gcc/ada/libgnat/s-imglld.adb | 82 + gcc/ada/libgnat/s-imglld.ads | 67 + gcc/ada/libgnat/s-imglli.adb | 102 + gcc/ada/libgnat/s-imglli.ads | 57 + gcc/ada/libgnat/s-imgllu.adb | 73 + gcc/ada/libgnat/s-imgllu.ads | 61 + gcc/ada/libgnat/s-imgllw.adb | 140 + gcc/ada/libgnat/s-imgllw.ads | 69 + gcc/ada/libgnat/s-imgrea.adb | 699 ++ gcc/ada/libgnat/s-imgrea.ads | 76 + gcc/ada/libgnat/s-imguns.adb | 73 + gcc/ada/libgnat/s-imguns.ads | 60 + gcc/ada/libgnat/s-imgwch.adb | 125 + gcc/ada/libgnat/s-imgwch.ads | 56 + gcc/ada/libgnat/s-imgwiu.adb | 138 + gcc/ada/libgnat/s-imgwiu.ads | 69 + gcc/ada/libgnat/s-io.adb | 125 + gcc/ada/libgnat/s-io.ads | 64 + gcc/ada/libgnat/s-llflex.ads | 42 + gcc/ada/libgnat/s-maccod.ads | 131 + gcc/ada/libgnat/s-mantis.adb | 53 + gcc/ada/libgnat/s-mantis.ads | 42 + gcc/ada/libgnat/s-mastop.adb | 108 + gcc/ada/libgnat/s-mastop.ads | 104 + gcc/ada/libgnat/s-memcop.ads | 72 + gcc/ada/libgnat/s-memory-mingw.adb | 221 + gcc/ada/libgnat/s-memory.adb | 163 + gcc/ada/libgnat/s-memory.ads | 107 + gcc/ada/libgnat/s-mmap.adb | 576 + gcc/ada/libgnat/s-mmap.ads | 283 + gcc/ada/libgnat/s-mmauni-long.ads | 69 + gcc/ada/libgnat/s-mmosin-mingw.adb | 345 + gcc/ada/libgnat/s-mmosin-mingw.ads | 235 + gcc/ada/libgnat/s-mmosin-unix.adb | 229 + gcc/ada/libgnat/s-mmosin-unix.ads | 105 + gcc/ada/libgnat/s-multip.adb | 51 + gcc/ada/libgnat/s-multip.ads | 28 + gcc/ada/libgnat/s-objrea.adb | 2246 ++++ gcc/ada/libgnat/s-objrea.ads | 451 + gcc/ada/libgnat/s-os_lib.adb | 3083 ++++++ gcc/ada/libgnat/s-os_lib.ads | 1111 ++ gcc/ada/libgnat/s-osprim-darwin.adb | 169 + gcc/ada/libgnat/s-osprim-mingw.adb | 413 + gcc/ada/libgnat/s-osprim-posix.adb | 172 + gcc/ada/libgnat/s-osprim-posix2008.adb | 172 + gcc/ada/libgnat/s-osprim-solaris.adb | 126 + gcc/ada/libgnat/s-osprim-unix.adb | 126 + gcc/ada/libgnat/s-osprim-vxworks.adb | 162 + gcc/ada/libgnat/s-osprim-x32.adb | 167 + gcc/ada/libgnat/s-osprim.ads | 85 + gcc/ada/libgnat/s-pack03.adb | 157 + gcc/ada/libgnat/s-pack03.ads | 60 + gcc/ada/libgnat/s-pack05.adb | 157 + gcc/ada/libgnat/s-pack05.ads | 60 + gcc/ada/libgnat/s-pack06.adb | 250 + gcc/ada/libgnat/s-pack06.ads | 77 + gcc/ada/libgnat/s-pack07.adb | 157 + gcc/ada/libgnat/s-pack07.ads | 60 + gcc/ada/libgnat/s-pack09.adb | 157 + gcc/ada/libgnat/s-pack09.ads | 60 + gcc/ada/libgnat/s-pack10.adb | 250 + gcc/ada/libgnat/s-pack10.ads | 77 + gcc/ada/libgnat/s-pack11.adb | 157 + gcc/ada/libgnat/s-pack11.ads | 60 + gcc/ada/libgnat/s-pack12.adb | 250 + gcc/ada/libgnat/s-pack12.ads | 77 + gcc/ada/libgnat/s-pack13.adb | 157 + gcc/ada/libgnat/s-pack13.ads | 60 + gcc/ada/libgnat/s-pack14.adb | 250 + gcc/ada/libgnat/s-pack14.ads | 77 + gcc/ada/libgnat/s-pack15.adb | 157 + gcc/ada/libgnat/s-pack15.ads | 60 + gcc/ada/libgnat/s-pack17.adb | 157 + gcc/ada/libgnat/s-pack17.ads | 60 + gcc/ada/libgnat/s-pack18.adb | 250 + gcc/ada/libgnat/s-pack18.ads | 77 + gcc/ada/libgnat/s-pack19.adb | 157 + gcc/ada/libgnat/s-pack19.ads | 60 + gcc/ada/libgnat/s-pack20.adb | 250 + gcc/ada/libgnat/s-pack20.ads | 77 + gcc/ada/libgnat/s-pack21.adb | 157 + gcc/ada/libgnat/s-pack21.ads | 60 + gcc/ada/libgnat/s-pack22.adb | 250 + gcc/ada/libgnat/s-pack22.ads | 77 + gcc/ada/libgnat/s-pack23.adb | 157 + gcc/ada/libgnat/s-pack23.ads | 60 + gcc/ada/libgnat/s-pack24.adb | 250 + gcc/ada/libgnat/s-pack24.ads | 77 + gcc/ada/libgnat/s-pack25.adb | 157 + gcc/ada/libgnat/s-pack25.ads | 60 + gcc/ada/libgnat/s-pack26.adb | 250 + gcc/ada/libgnat/s-pack26.ads | 77 + gcc/ada/libgnat/s-pack27.adb | 157 + gcc/ada/libgnat/s-pack27.ads | 60 + gcc/ada/libgnat/s-pack28.adb | 250 + gcc/ada/libgnat/s-pack28.ads | 77 + gcc/ada/libgnat/s-pack29.adb | 157 + gcc/ada/libgnat/s-pack29.ads | 60 + gcc/ada/libgnat/s-pack30.adb | 250 + gcc/ada/libgnat/s-pack30.ads | 77 + gcc/ada/libgnat/s-pack31.adb | 157 + gcc/ada/libgnat/s-pack31.ads | 60 + gcc/ada/libgnat/s-pack33.adb | 157 + gcc/ada/libgnat/s-pack33.ads | 60 + gcc/ada/libgnat/s-pack34.adb | 250 + gcc/ada/libgnat/s-pack34.ads | 77 + gcc/ada/libgnat/s-pack35.adb | 157 + gcc/ada/libgnat/s-pack35.ads | 60 + gcc/ada/libgnat/s-pack36.adb | 250 + gcc/ada/libgnat/s-pack36.ads | 77 + gcc/ada/libgnat/s-pack37.adb | 157 + gcc/ada/libgnat/s-pack37.ads | 60 + gcc/ada/libgnat/s-pack38.adb | 250 + gcc/ada/libgnat/s-pack38.ads | 77 + gcc/ada/libgnat/s-pack39.adb | 157 + gcc/ada/libgnat/s-pack39.ads | 60 + gcc/ada/libgnat/s-pack40.adb | 250 + gcc/ada/libgnat/s-pack40.ads | 77 + gcc/ada/libgnat/s-pack41.adb | 157 + gcc/ada/libgnat/s-pack41.ads | 60 + gcc/ada/libgnat/s-pack42.adb | 250 + gcc/ada/libgnat/s-pack42.ads | 77 + gcc/ada/libgnat/s-pack43.adb | 157 + gcc/ada/libgnat/s-pack43.ads | 60 + gcc/ada/libgnat/s-pack44.adb | 250 + gcc/ada/libgnat/s-pack44.ads | 77 + gcc/ada/libgnat/s-pack45.adb | 157 + gcc/ada/libgnat/s-pack45.ads | 60 + gcc/ada/libgnat/s-pack46.adb | 250 + gcc/ada/libgnat/s-pack46.ads | 77 + gcc/ada/libgnat/s-pack47.adb | 157 + gcc/ada/libgnat/s-pack47.ads | 60 + gcc/ada/libgnat/s-pack48.adb | 250 + gcc/ada/libgnat/s-pack48.ads | 77 + gcc/ada/libgnat/s-pack49.adb | 157 + gcc/ada/libgnat/s-pack49.ads | 60 + gcc/ada/libgnat/s-pack50.adb | 250 + gcc/ada/libgnat/s-pack50.ads | 77 + gcc/ada/libgnat/s-pack51.adb | 157 + gcc/ada/libgnat/s-pack51.ads | 60 + gcc/ada/libgnat/s-pack52.adb | 250 + gcc/ada/libgnat/s-pack52.ads | 77 + gcc/ada/libgnat/s-pack53.adb | 157 + gcc/ada/libgnat/s-pack53.ads | 60 + gcc/ada/libgnat/s-pack54.adb | 250 + gcc/ada/libgnat/s-pack54.ads | 77 + gcc/ada/libgnat/s-pack55.adb | 157 + gcc/ada/libgnat/s-pack55.ads | 60 + gcc/ada/libgnat/s-pack56.adb | 250 + gcc/ada/libgnat/s-pack56.ads | 77 + gcc/ada/libgnat/s-pack57.adb | 157 + gcc/ada/libgnat/s-pack57.ads | 60 + gcc/ada/libgnat/s-pack58.adb | 250 + gcc/ada/libgnat/s-pack58.ads | 77 + gcc/ada/libgnat/s-pack59.adb | 157 + gcc/ada/libgnat/s-pack59.ads | 60 + gcc/ada/libgnat/s-pack60.adb | 250 + gcc/ada/libgnat/s-pack60.ads | 77 + gcc/ada/libgnat/s-pack61.adb | 157 + gcc/ada/libgnat/s-pack61.ads | 60 + gcc/ada/libgnat/s-pack62.adb | 250 + gcc/ada/libgnat/s-pack62.ads | 77 + gcc/ada/libgnat/s-pack63.adb | 157 + gcc/ada/libgnat/s-pack63.ads | 60 + gcc/ada/libgnat/s-parame-hpux.ads | 199 + gcc/ada/libgnat/s-parame-rtems.adb | 78 + gcc/ada/libgnat/s-parame-vxworks.adb | 80 + gcc/ada/libgnat/s-parame-vxworks.ads | 201 + gcc/ada/libgnat/s-parame.adb | 82 + gcc/ada/libgnat/s-parame.ads | 201 + gcc/ada/libgnat/s-parint.adb | 320 + gcc/ada/libgnat/s-parint.ads | 191 + gcc/ada/libgnat/s-pooglo.adb | 156 + gcc/ada/libgnat/s-pooglo.ads | 79 + gcc/ada/libgnat/s-pooloc.adb | 165 + gcc/ada/libgnat/s-pooloc.ads | 74 + gcc/ada/libgnat/s-poosiz.adb | 412 + gcc/ada/libgnat/s-poosiz.ads | 82 + gcc/ada/libgnat/s-powtab.ads | 70 + gcc/ada/libgnat/s-purexc.ads | 77 + gcc/ada/libgnat/s-rannum.adb | 693 ++ gcc/ada/libgnat/s-rannum.ads | 162 + gcc/ada/libgnat/s-ransee.adb | 55 + gcc/ada/libgnat/s-ransee.ads | 49 + gcc/ada/libgnat/s-regexp.adb | 1729 +++ gcc/ada/libgnat/s-regexp.ads | 141 + gcc/ada/libgnat/s-regpat.adb | 3754 +++++++ gcc/ada/libgnat/s-regpat.ads | 649 ++ gcc/ada/libgnat/s-resfil.adb | 525 + gcc/ada/libgnat/s-resfil.ads | 99 + gcc/ada/libgnat/s-restri.adb | 59 + gcc/ada/libgnat/s-restri.ads | 77 + gcc/ada/libgnat/s-rident.ads | 642 ++ gcc/ada/libgnat/s-rpc.adb | 111 + gcc/ada/libgnat/s-rpc.ads | 91 + gcc/ada/libgnat/s-scaval.adb | 328 + gcc/ada/libgnat/s-scaval.ads | 93 + gcc/ada/libgnat/s-secsta.adb | 547 + gcc/ada/libgnat/s-secsta.ads | 123 + gcc/ada/libgnat/s-sequio.adb | 165 + gcc/ada/libgnat/s-sequio.ads | 78 + gcc/ada/libgnat/s-shasto.adb | 588 + gcc/ada/libgnat/s-shasto.ads | 179 + gcc/ada/libgnat/s-soflin.adb | 312 + gcc/ada/libgnat/s-soflin.ads | 399 + gcc/ada/libgnat/s-sopco3.adb | 64 + gcc/ada/libgnat/s-sopco3.ads | 46 + gcc/ada/libgnat/s-sopco4.adb | 66 + gcc/ada/libgnat/s-sopco4.ads | 46 + gcc/ada/libgnat/s-sopco5.adb | 68 + gcc/ada/libgnat/s-sopco5.ads | 46 + gcc/ada/libgnat/s-spsufi.adb | 89 + gcc/ada/libgnat/s-spsufi.ads | 48 + gcc/ada/libgnat/s-stache.adb | 38 + gcc/ada/libgnat/s-stache.ads | 82 + gcc/ada/libgnat/s-stalib.adb | 105 + gcc/ada/libgnat/s-stalib.ads | 263 + gcc/ada/libgnat/s-stausa.adb | 566 + gcc/ada/libgnat/s-stausa.ads | 339 + gcc/ada/libgnat/s-stchop-limit.ads | 53 + gcc/ada/libgnat/s-stchop-rtems.adb | 113 + gcc/ada/libgnat/s-stchop-vxworks.adb | 145 + gcc/ada/libgnat/s-stchop.adb | 279 + gcc/ada/libgnat/s-stchop.ads | 82 + gcc/ada/libgnat/s-stoele.adb | 131 + gcc/ada/libgnat/s-stoele.ads | 117 + gcc/ada/libgnat/s-stopoo.adb | 62 + gcc/ada/libgnat/s-stopoo.ads | 100 + gcc/ada/libgnat/s-stposu.adb | 828 ++ gcc/ada/libgnat/s-stposu.ads | 358 + gcc/ada/libgnat/s-stratt-xdr.adb | 1901 ++++ gcc/ada/libgnat/s-stratt.adb | 708 ++ gcc/ada/libgnat/s-stratt.ads | 207 + gcc/ada/libgnat/s-strcom.adb | 140 + gcc/ada/libgnat/s-strcom.ads | 59 + gcc/ada/libgnat/s-strhas.adb | 69 + gcc/ada/libgnat/s-strhas.ads | 64 + gcc/ada/libgnat/s-string.adb | 59 + gcc/ada/libgnat/s-string.ads | 63 + gcc/ada/libgnat/s-strops.adb | 109 + gcc/ada/libgnat/s-strops.ads | 56 + gcc/ada/libgnat/s-ststop.adb | 915 ++ gcc/ada/libgnat/s-ststop.ads | 260 + gcc/ada/libgnat/s-tasloc.adb | 54 + gcc/ada/libgnat/s-tasloc.ads | 98 + gcc/ada/libgnat/s-thread.ads | 90 + gcc/ada/libgnat/s-traceb-hpux.adb | 627 ++ gcc/ada/libgnat/s-traceb-mastop.adb | 137 + gcc/ada/libgnat/s-traceb.adb | 118 + gcc/ada/libgnat/s-traceb.ads | 87 + gcc/ada/libgnat/s-traent.adb | 58 + gcc/ada/libgnat/s-traent.ads | 67 + gcc/ada/libgnat/s-trasym-dwarf.adb | 689 ++ gcc/ada/libgnat/s-trasym.adb | 112 + gcc/ada/libgnat/s-trasym.ads | 111 + gcc/ada/libgnat/s-tsmona-linux.adb | 190 + gcc/ada/libgnat/s-tsmona-mingw.adb | 93 + gcc/ada/libgnat/s-tsmona.adb | 67 + gcc/ada/libgnat/s-unstyp.ads | 215 + gcc/ada/libgnat/s-utf_32.adb | 6356 +++++++++++ gcc/ada/libgnat/s-utf_32.ads | 212 + gcc/ada/libgnat/s-valboo.adb | 59 + gcc/ada/libgnat/s-valboo.ads | 38 + gcc/ada/libgnat/s-valcha.adb | 76 + gcc/ada/libgnat/s-valcha.ads | 38 + gcc/ada/libgnat/s-valdec.adb | 68 + gcc/ada/libgnat/s-valdec.ads | 80 + gcc/ada/libgnat/s-valenu.adb | 155 + gcc/ada/libgnat/s-valenu.ads | 80 + gcc/ada/libgnat/s-valint.adb | 118 + gcc/ada/libgnat/s-valint.ads | 73 + gcc/ada/libgnat/s-vallld.adb | 70 + gcc/ada/libgnat/s-vallld.ads | 81 + gcc/ada/libgnat/s-vallli.adb | 120 + gcc/ada/libgnat/s-vallli.ads | 73 + gcc/ada/libgnat/s-valllu.adb | 330 + gcc/ada/libgnat/s-valllu.ads | 129 + gcc/ada/libgnat/s-valrea.adb | 415 + gcc/ada/libgnat/s-valrea.ads | 74 + gcc/ada/libgnat/s-valuns.adb | 325 + gcc/ada/libgnat/s-valuns.ads | 129 + gcc/ada/libgnat/s-valuti.adb | 334 + gcc/ada/libgnat/s-valuti.ads | 126 + gcc/ada/libgnat/s-valwch.adb | 175 + gcc/ada/libgnat/s-valwch.ads | 53 + gcc/ada/libgnat/s-veboop.adb | 125 + gcc/ada/libgnat/s-veboop.ads | 66 + gcc/ada/libgnat/s-vector.ads | 49 + gcc/ada/libgnat/s-vercon.adb | 58 + gcc/ada/libgnat/s-vercon.ads | 52 + gcc/ada/libgnat/s-wchcnv.adb | 465 + gcc/ada/libgnat/s-wchcnv.ads | 116 + gcc/ada/libgnat/s-wchcon.adb | 84 + gcc/ada/libgnat/s-wchcon.ads | 220 + gcc/ada/libgnat/s-wchjis.adb | 189 + gcc/ada/libgnat/s-wchjis.ads | 78 + gcc/ada/libgnat/s-wchstw.adb | 173 + gcc/ada/libgnat/s-wchstw.ads | 69 + gcc/ada/libgnat/s-wchwts.adb | 122 + gcc/ada/libgnat/s-wchwts.ads | 63 + gcc/ada/libgnat/s-widboo.adb | 51 + gcc/ada/libgnat/s-widboo.ads | 41 + gcc/ada/libgnat/s-widcha.adb | 56 + gcc/ada/libgnat/s-widcha.ads | 41 + gcc/ada/libgnat/s-widenu.adb | 135 + gcc/ada/libgnat/s-widenu.ads | 73 + gcc/ada/libgnat/s-widlli.adb | 73 + gcc/ada/libgnat/s-widlli.ads | 45 + gcc/ada/libgnat/s-widllu.adb | 73 + gcc/ada/libgnat/s-widllu.ads | 47 + gcc/ada/libgnat/s-widwch.adb | 104 + gcc/ada/libgnat/s-widwch.ads | 46 + gcc/ada/libgnat/s-win32.ads | 342 + gcc/ada/libgnat/s-winext.ads | 130 + gcc/ada/libgnat/s-wwdcha.adb | 74 + gcc/ada/libgnat/s-wwdcha.ads | 45 + gcc/ada/libgnat/s-wwdenu.adb | 273 + gcc/ada/libgnat/s-wwdenu.ads | 98 + gcc/ada/libgnat/s-wwdwch.adb | 130 + gcc/ada/libgnat/s-wwdwch.ads | 61 + gcc/ada/libgnat/sequenio.ads | 24 + gcc/ada/libgnat/system-aix.ads | 158 + gcc/ada/libgnat/system-darwin-arm.ads | 174 + gcc/ada/libgnat/system-darwin-ppc.ads | 174 + gcc/ada/libgnat/system-darwin-x86.ads | 174 + gcc/ada/libgnat/system-djgpp.ads | 148 + gcc/ada/libgnat/system-dragonfly-x86_64.ads | 148 + gcc/ada/libgnat/system-freebsd.ads | 149 + gcc/ada/libgnat/system-hpux-ia64.ads | 148 + gcc/ada/libgnat/system-hpux.ads | 223 + gcc/ada/libgnat/system-linux-alpha.ads | 148 + gcc/ada/libgnat/system-linux-arm.ads | 157 + gcc/ada/libgnat/system-linux-hppa.ads | 147 + gcc/ada/libgnat/system-linux-ia64.ads | 156 + gcc/ada/libgnat/system-linux-m68k.ads | 158 + gcc/ada/libgnat/system-linux-mips.ads | 148 + gcc/ada/libgnat/system-linux-ppc.ads | 156 + gcc/ada/libgnat/system-linux-s390.ads | 147 + gcc/ada/libgnat/system-linux-sh4.ads | 155 + gcc/ada/libgnat/system-linux-sparc.ads | 147 + gcc/ada/libgnat/system-linux-x86.ads | 156 + gcc/ada/libgnat/system-mingw.ads | 200 + gcc/ada/libgnat/system-rtems.ads | 166 + gcc/ada/libgnat/system-solaris-sparc.ads | 148 + gcc/ada/libgnat/system-solaris-x86.ads | 148 + gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads | 172 + gcc/ada/libgnat/system-vxworks-arm-rtp.ads | 171 + gcc/ada/libgnat/system-vxworks-arm.ads | 166 + gcc/ada/libgnat/system-vxworks-e500-kernel.ads | 167 + gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads | 173 + gcc/ada/libgnat/system-vxworks-e500-rtp.ads | 171 + gcc/ada/libgnat/system-vxworks-e500-vthread.ads | 164 + gcc/ada/libgnat/system-vxworks-ppc-kernel.ads | 166 + gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads | 187 + gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads | 172 + gcc/ada/libgnat/system-vxworks-ppc-rtp.ads | 171 + gcc/ada/libgnat/system-vxworks-ppc-vthread.ads | 164 + gcc/ada/libgnat/system-vxworks-ppc.ads | 169 + gcc/ada/libgnat/system-vxworks-ppc64-kernel.ads | 168 + gcc/ada/libgnat/system-vxworks-x86-kernel.ads | 170 + gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads | 171 + gcc/ada/libgnat/system-vxworks-x86-rtp.ads | 170 + gcc/ada/libgnat/system-vxworks-x86-vthread.ads | 165 + gcc/ada/libgnat/system-vxworks-x86.ads | 166 + gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads | 167 + gcc/ada/libgnat/system-vxworks7-arm.ads | 162 + gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads | 172 + gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads | 171 + gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads | 171 + gcc/ada/libgnat/system-vxworks7-x86-kernel.ads | 167 + gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads | 170 + gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads | 167 + gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads | 170 + gcc/ada/libgnat/system.ads | 178 + gcc/ada/libgnat/text_io.ads | 24 + gcc/ada/libgnat/unchconv.ads | 22 + gcc/ada/libgnat/unchdeal.ads | 21 + gcc/ada/machcode.ads | 18 - gcc/ada/memtrack.adb | 401 - gcc/ada/s-addima.adb | 72 - gcc/ada/s-addima.ads | 43 - gcc/ada/s-addope.adb | 110 - gcc/ada/s-addope.ads | 87 - gcc/ada/s-arit64.adb | 605 - gcc/ada/s-arit64.ads | 84 - gcc/ada/s-assert.adb | 49 - gcc/ada/s-assert.ads | 50 - gcc/ada/s-atacco.adb | 36 - gcc/ada/s-atacco.ads | 63 - gcc/ada/s-atocou-builtin.adb | 111 - gcc/ada/s-atocou-x86.adb | 112 - gcc/ada/s-atocou.adb | 93 - gcc/ada/s-atocou.ads | 107 - gcc/ada/s-atopri.adb | 201 - gcc/ada/s-atopri.ads | 180 - gcc/ada/s-auxdec.adb | 718 -- gcc/ada/s-auxdec.ads | 654 -- gcc/ada/s-bignum.adb | 1105 -- gcc/ada/s-bignum.ads | 116 - gcc/ada/s-bitops.adb | 220 - gcc/ada/s-bitops.ads | 99 - gcc/ada/s-boarop.ads | 65 - gcc/ada/s-boustr.adb | 104 - gcc/ada/s-boustr.ads | 62 - gcc/ada/s-bytswa.ads | 53 - gcc/ada/s-carsi8.adb | 143 - gcc/ada/s-carsi8.ads | 62 - gcc/ada/s-carun8.adb | 144 - gcc/ada/s-carun8.ads | 64 - gcc/ada/s-casi16.adb | 133 - gcc/ada/s-casi16.ads | 53 - gcc/ada/s-casi32.adb | 116 - gcc/ada/s-casi32.ads | 53 - gcc/ada/s-casi64.adb | 116 - gcc/ada/s-casi64.ads | 52 - gcc/ada/s-casuti.adb | 105 - gcc/ada/s-casuti.ads | 66 - gcc/ada/s-caun16.adb | 133 - gcc/ada/s-caun16.ads | 53 - gcc/ada/s-caun32.adb | 116 - gcc/ada/s-caun32.ads | 52 - gcc/ada/s-caun64.adb | 115 - gcc/ada/s-caun64.ads | 52 - gcc/ada/s-chepoo.ads | 59 - gcc/ada/s-commun.adb | 55 - gcc/ada/s-commun.ads | 50 - gcc/ada/s-conca2.adb | 73 - gcc/ada/s-conca2.ads | 52 - gcc/ada/s-conca3.adb | 78 - gcc/ada/s-conca3.ads | 52 - gcc/ada/s-conca4.adb | 82 - gcc/ada/s-conca4.ads | 52 - gcc/ada/s-conca5.adb | 86 - gcc/ada/s-conca5.ads | 52 - gcc/ada/s-conca6.adb | 90 - gcc/ada/s-conca6.ads | 52 - gcc/ada/s-conca7.adb | 97 - gcc/ada/s-conca7.ads | 54 - gcc/ada/s-conca8.adb | 102 - gcc/ada/s-conca8.ads | 54 - gcc/ada/s-conca9.adb | 106 - gcc/ada/s-conca9.ads | 54 - gcc/ada/s-crc32.adb | 137 - gcc/ada/s-crc32.ads | 83 - gcc/ada/s-crtl.ads | 241 - gcc/ada/s-diflio.adb | 132 - gcc/ada/s-diflio.ads | 184 - gcc/ada/s-diinio.adb | 109 - gcc/ada/s-diinio.ads | 167 - gcc/ada/s-dim.ads | 68 - gcc/ada/s-dimkio.ads | 38 - gcc/ada/s-dimmks.ads | 393 - gcc/ada/s-direio.adb | 399 - gcc/ada/s-direio.ads | 142 - gcc/ada/s-dmotpr.ads | 172 - gcc/ada/s-dsaser.ads | 54 - gcc/ada/s-dwalin.adb | 1627 --- gcc/ada/s-dwalin.ads | 191 - gcc/ada/s-elaall.adb | 72 - gcc/ada/s-elaall.ads | 57 - gcc/ada/s-excdeb.adb | 77 - gcc/ada/s-excdeb.ads | 78 - gcc/ada/s-except.adb | 45 - gcc/ada/s-except.ads | 66 - gcc/ada/s-excmac-arm.adb | 42 - gcc/ada/s-excmac-arm.ads | 180 - gcc/ada/s-excmac-gcc.adb | 43 - gcc/ada/s-excmac-gcc.ads | 185 - gcc/ada/s-exctab.adb | 339 - gcc/ada/s-exctab.ads | 75 - gcc/ada/s-exctra.adb | 124 - gcc/ada/s-exctra.ads | 107 - gcc/ada/s-exnint.adb | 70 - gcc/ada/s-exnint.ads | 39 - gcc/ada/s-exnllf.adb | 182 - gcc/ada/s-exnllf.ads | 49 - gcc/ada/s-exnlli.adb | 74 - gcc/ada/s-exnlli.ads | 42 - gcc/ada/s-expint.adb | 83 - gcc/ada/s-expint.ads | 42 - gcc/ada/s-explli.adb | 83 - gcc/ada/s-explli.ads | 42 - gcc/ada/s-expllu.adb | 74 - gcc/ada/s-expllu.ads | 47 - gcc/ada/s-expmod.adb | 79 - gcc/ada/s-expmod.ads | 56 - gcc/ada/s-expuns.adb | 73 - gcc/ada/s-expuns.ads | 47 - gcc/ada/s-fatflt.ads | 47 - gcc/ada/s-fatgen.adb | 931 -- gcc/ada/s-fatgen.ads | 118 - gcc/ada/s-fatlfl.ads | 47 - gcc/ada/s-fatllf.ads | 47 - gcc/ada/s-fatsfl.ads | 47 - gcc/ada/s-ficobl.ads | 159 - gcc/ada/s-filatt.ads | 71 - gcc/ada/s-fileio.adb | 1322 --- gcc/ada/s-fileio.ads | 255 - gcc/ada/s-finmas.adb | 554 - gcc/ada/s-finmas.ads | 206 - gcc/ada/s-finroo.adb | 63 - gcc/ada/s-finroo.ads | 46 - gcc/ada/s-flocon-none.adb | 46 - gcc/ada/s-flocon.adb | 47 - gcc/ada/s-flocon.ads | 59 - gcc/ada/s-fore.adb | 56 - gcc/ada/s-fore.ads | 41 - gcc/ada/s-gearop.adb | 934 -- gcc/ada/s-gearop.ads | 502 - gcc/ada/s-geveop.adb | 133 - gcc/ada/s-geveop.ads | 66 - gcc/ada/s-gloloc-mingw.adb | 107 - gcc/ada/s-gloloc.adb | 149 - gcc/ada/s-gloloc.ads | 63 - gcc/ada/s-htable.adb | 412 - gcc/ada/s-htable.ads | 222 - gcc/ada/s-imenne.adb | 128 - gcc/ada/s-imenne.ads | 85 - gcc/ada/s-imgbiu.adb | 158 - gcc/ada/s-imgbiu.ads | 72 - gcc/ada/s-imgboo.adb | 54 - gcc/ada/s-imgboo.ads | 45 - gcc/ada/s-imgcha.adb | 180 - gcc/ada/s-imgcha.ads | 55 - gcc/ada/s-imgdec.adb | 420 - gcc/ada/s-imgdec.ads | 83 - gcc/ada/s-imgenu.adb | 128 - gcc/ada/s-imgenu.ads | 78 - gcc/ada/s-imgint.adb | 103 - gcc/ada/s-imgint.ads | 57 - gcc/ada/s-imgllb.adb | 161 - gcc/ada/s-imgllb.ads | 72 - gcc/ada/s-imglld.adb | 82 - gcc/ada/s-imglld.ads | 67 - gcc/ada/s-imglli.adb | 102 - gcc/ada/s-imglli.ads | 57 - gcc/ada/s-imgllu.adb | 73 - gcc/ada/s-imgllu.ads | 61 - gcc/ada/s-imgllw.adb | 140 - gcc/ada/s-imgllw.ads | 69 - gcc/ada/s-imgrea.adb | 699 -- gcc/ada/s-imgrea.ads | 76 - gcc/ada/s-imguns.adb | 73 - gcc/ada/s-imguns.ads | 60 - gcc/ada/s-imgwch.adb | 125 - gcc/ada/s-imgwch.ads | 56 - gcc/ada/s-imgwiu.adb | 138 - gcc/ada/s-imgwiu.ads | 69 - gcc/ada/s-io.adb | 125 - gcc/ada/s-io.ads | 64 - gcc/ada/s-llflex.ads | 42 - gcc/ada/s-maccod.ads | 131 - gcc/ada/s-mantis.adb | 53 - gcc/ada/s-mantis.ads | 42 - gcc/ada/s-mastop.adb | 108 - gcc/ada/s-mastop.ads | 104 - gcc/ada/s-memcop.ads | 72 - gcc/ada/s-memory-mingw.adb | 221 - gcc/ada/s-memory.adb | 163 - gcc/ada/s-memory.ads | 107 - gcc/ada/s-mmap.adb | 576 - gcc/ada/s-mmap.ads | 283 - gcc/ada/s-mmauni-long.ads | 69 - gcc/ada/s-mmosin-mingw.adb | 345 - gcc/ada/s-mmosin-mingw.ads | 235 - gcc/ada/s-mmosin-unix.adb | 229 - gcc/ada/s-mmosin-unix.ads | 105 - gcc/ada/s-multip.adb | 51 - gcc/ada/s-multip.ads | 28 - gcc/ada/s-objrea.adb | 2246 ---- gcc/ada/s-objrea.ads | 451 - gcc/ada/s-os_lib.adb | 3083 ------ gcc/ada/s-os_lib.ads | 1111 -- gcc/ada/s-osprim-darwin.adb | 169 - gcc/ada/s-osprim-mingw.adb | 413 - gcc/ada/s-osprim-posix.adb | 172 - gcc/ada/s-osprim-solaris.adb | 126 - gcc/ada/s-osprim-unix.adb | 126 - gcc/ada/s-osprim-vxworks.adb | 162 - gcc/ada/s-osprim-x32.adb | 167 - gcc/ada/s-osprim.ads | 85 - gcc/ada/s-pack03.adb | 157 - gcc/ada/s-pack03.ads | 60 - gcc/ada/s-pack05.adb | 157 - gcc/ada/s-pack05.ads | 60 - gcc/ada/s-pack06.adb | 250 - gcc/ada/s-pack06.ads | 77 - gcc/ada/s-pack07.adb | 157 - gcc/ada/s-pack07.ads | 60 - gcc/ada/s-pack09.adb | 157 - gcc/ada/s-pack09.ads | 60 - gcc/ada/s-pack10.adb | 250 - gcc/ada/s-pack10.ads | 77 - gcc/ada/s-pack11.adb | 157 - gcc/ada/s-pack11.ads | 60 - gcc/ada/s-pack12.adb | 250 - gcc/ada/s-pack12.ads | 77 - gcc/ada/s-pack13.adb | 157 - gcc/ada/s-pack13.ads | 60 - gcc/ada/s-pack14.adb | 250 - gcc/ada/s-pack14.ads | 77 - gcc/ada/s-pack15.adb | 157 - gcc/ada/s-pack15.ads | 60 - gcc/ada/s-pack17.adb | 157 - gcc/ada/s-pack17.ads | 60 - gcc/ada/s-pack18.adb | 250 - gcc/ada/s-pack18.ads | 77 - gcc/ada/s-pack19.adb | 157 - gcc/ada/s-pack19.ads | 60 - gcc/ada/s-pack20.adb | 250 - gcc/ada/s-pack20.ads | 77 - gcc/ada/s-pack21.adb | 157 - gcc/ada/s-pack21.ads | 60 - gcc/ada/s-pack22.adb | 250 - gcc/ada/s-pack22.ads | 77 - gcc/ada/s-pack23.adb | 157 - gcc/ada/s-pack23.ads | 60 - gcc/ada/s-pack24.adb | 250 - gcc/ada/s-pack24.ads | 77 - gcc/ada/s-pack25.adb | 157 - gcc/ada/s-pack25.ads | 60 - gcc/ada/s-pack26.adb | 250 - gcc/ada/s-pack26.ads | 77 - gcc/ada/s-pack27.adb | 157 - gcc/ada/s-pack27.ads | 60 - gcc/ada/s-pack28.adb | 250 - gcc/ada/s-pack28.ads | 77 - gcc/ada/s-pack29.adb | 157 - gcc/ada/s-pack29.ads | 60 - gcc/ada/s-pack30.adb | 250 - gcc/ada/s-pack30.ads | 77 - gcc/ada/s-pack31.adb | 157 - gcc/ada/s-pack31.ads | 60 - gcc/ada/s-pack33.adb | 157 - gcc/ada/s-pack33.ads | 60 - gcc/ada/s-pack34.adb | 250 - gcc/ada/s-pack34.ads | 77 - gcc/ada/s-pack35.adb | 157 - gcc/ada/s-pack35.ads | 60 - gcc/ada/s-pack36.adb | 250 - gcc/ada/s-pack36.ads | 77 - gcc/ada/s-pack37.adb | 157 - gcc/ada/s-pack37.ads | 60 - gcc/ada/s-pack38.adb | 250 - gcc/ada/s-pack38.ads | 77 - gcc/ada/s-pack39.adb | 157 - gcc/ada/s-pack39.ads | 60 - gcc/ada/s-pack40.adb | 250 - gcc/ada/s-pack40.ads | 77 - gcc/ada/s-pack41.adb | 157 - gcc/ada/s-pack41.ads | 60 - gcc/ada/s-pack42.adb | 250 - gcc/ada/s-pack42.ads | 77 - gcc/ada/s-pack43.adb | 157 - gcc/ada/s-pack43.ads | 60 - gcc/ada/s-pack44.adb | 250 - gcc/ada/s-pack44.ads | 77 - gcc/ada/s-pack45.adb | 157 - gcc/ada/s-pack45.ads | 60 - gcc/ada/s-pack46.adb | 250 - gcc/ada/s-pack46.ads | 77 - gcc/ada/s-pack47.adb | 157 - gcc/ada/s-pack47.ads | 60 - gcc/ada/s-pack48.adb | 250 - gcc/ada/s-pack48.ads | 77 - gcc/ada/s-pack49.adb | 157 - gcc/ada/s-pack49.ads | 60 - gcc/ada/s-pack50.adb | 250 - gcc/ada/s-pack50.ads | 77 - gcc/ada/s-pack51.adb | 157 - gcc/ada/s-pack51.ads | 60 - gcc/ada/s-pack52.adb | 250 - gcc/ada/s-pack52.ads | 77 - gcc/ada/s-pack53.adb | 157 - gcc/ada/s-pack53.ads | 60 - gcc/ada/s-pack54.adb | 250 - gcc/ada/s-pack54.ads | 77 - gcc/ada/s-pack55.adb | 157 - gcc/ada/s-pack55.ads | 60 - gcc/ada/s-pack56.adb | 250 - gcc/ada/s-pack56.ads | 77 - gcc/ada/s-pack57.adb | 157 - gcc/ada/s-pack57.ads | 60 - gcc/ada/s-pack58.adb | 250 - gcc/ada/s-pack58.ads | 77 - gcc/ada/s-pack59.adb | 157 - gcc/ada/s-pack59.ads | 60 - gcc/ada/s-pack60.adb | 250 - gcc/ada/s-pack60.ads | 77 - gcc/ada/s-pack61.adb | 157 - gcc/ada/s-pack61.ads | 60 - gcc/ada/s-pack62.adb | 250 - gcc/ada/s-pack62.ads | 77 - gcc/ada/s-pack63.adb | 157 - gcc/ada/s-pack63.ads | 60 - gcc/ada/s-parame-hpux.ads | 199 - gcc/ada/s-parame-rtems.adb | 78 - gcc/ada/s-parame-vxworks.adb | 80 - gcc/ada/s-parame-vxworks.ads | 201 - gcc/ada/s-parame.adb | 82 - gcc/ada/s-parame.ads | 201 - gcc/ada/s-parint.adb | 320 - gcc/ada/s-parint.ads | 191 - gcc/ada/s-pooglo.adb | 156 - gcc/ada/s-pooglo.ads | 79 - gcc/ada/s-pooloc.adb | 165 - gcc/ada/s-pooloc.ads | 74 - gcc/ada/s-poosiz.adb | 412 - gcc/ada/s-poosiz.ads | 82 - gcc/ada/s-powtab.ads | 70 - gcc/ada/s-purexc.ads | 77 - gcc/ada/s-rannum.adb | 693 -- gcc/ada/s-rannum.ads | 162 - gcc/ada/s-ransee.adb | 55 - gcc/ada/s-ransee.ads | 49 - gcc/ada/s-regexp.adb | 1729 --- gcc/ada/s-regexp.ads | 141 - gcc/ada/s-regpat.adb | 3754 ------- gcc/ada/s-regpat.ads | 649 -- gcc/ada/s-resfil.adb | 525 - gcc/ada/s-resfil.ads | 99 - gcc/ada/s-restri.adb | 59 - gcc/ada/s-restri.ads | 77 - gcc/ada/s-rident.ads | 642 -- gcc/ada/s-rpc.adb | 111 - gcc/ada/s-rpc.ads | 91 - gcc/ada/s-scaval.adb | 328 - gcc/ada/s-scaval.ads | 93 - gcc/ada/s-secsta.adb | 547 - gcc/ada/s-secsta.ads | 123 - gcc/ada/s-sequio.adb | 165 - gcc/ada/s-sequio.ads | 78 - gcc/ada/s-shasto.adb | 588 - gcc/ada/s-shasto.ads | 179 - gcc/ada/s-soflin.adb | 312 - gcc/ada/s-soflin.ads | 399 - gcc/ada/s-sopco3.adb | 64 - gcc/ada/s-sopco3.ads | 46 - gcc/ada/s-sopco4.adb | 66 - gcc/ada/s-sopco4.ads | 46 - gcc/ada/s-sopco5.adb | 68 - gcc/ada/s-sopco5.ads | 46 - gcc/ada/s-spsufi.adb | 89 - gcc/ada/s-spsufi.ads | 48 - gcc/ada/s-stache.adb | 38 - gcc/ada/s-stache.ads | 82 - gcc/ada/s-stalib.adb | 105 - gcc/ada/s-stalib.ads | 263 - gcc/ada/s-stausa.adb | 566 - gcc/ada/s-stausa.ads | 339 - gcc/ada/s-stchop-limit.ads | 53 - gcc/ada/s-stchop-rtems.adb | 113 - gcc/ada/s-stchop-vxworks.adb | 145 - gcc/ada/s-stchop.adb | 279 - gcc/ada/s-stchop.ads | 82 - gcc/ada/s-stoele.adb | 131 - gcc/ada/s-stoele.ads | 117 - gcc/ada/s-stopoo.adb | 62 - gcc/ada/s-stopoo.ads | 100 - gcc/ada/s-stposu.adb | 828 -- gcc/ada/s-stposu.ads | 358 - gcc/ada/s-stratt-xdr.adb | 1901 ---- gcc/ada/s-stratt.adb | 708 -- gcc/ada/s-stratt.ads | 207 - gcc/ada/s-strcom.adb | 140 - gcc/ada/s-strcom.ads | 59 - gcc/ada/s-strhas.adb | 69 - gcc/ada/s-strhas.ads | 64 - gcc/ada/s-string.adb | 59 - gcc/ada/s-string.ads | 63 - gcc/ada/s-strops.adb | 109 - gcc/ada/s-strops.ads | 56 - gcc/ada/s-ststop.adb | 915 -- gcc/ada/s-ststop.ads | 260 - gcc/ada/s-tasloc.adb | 54 - gcc/ada/s-tasloc.ads | 98 - gcc/ada/s-traceb-hpux.adb | 627 -- gcc/ada/s-traceb-mastop.adb | 137 - gcc/ada/s-traceb.adb | 118 - gcc/ada/s-traceb.ads | 87 - gcc/ada/s-traent.adb | 58 - gcc/ada/s-traent.ads | 67 - gcc/ada/s-trasym-dwarf.adb | 689 -- gcc/ada/s-trasym.adb | 112 - gcc/ada/s-trasym.ads | 98 - gcc/ada/s-tsmona-linux.adb | 190 - gcc/ada/s-tsmona-mingw.adb | 93 - gcc/ada/s-unstyp.ads | 215 - gcc/ada/s-utf_32.adb | 6356 ----------- gcc/ada/s-utf_32.ads | 212 - gcc/ada/s-valboo.adb | 59 - gcc/ada/s-valboo.ads | 38 - gcc/ada/s-valcha.adb | 76 - gcc/ada/s-valcha.ads | 38 - gcc/ada/s-valdec.adb | 68 - gcc/ada/s-valdec.ads | 80 - gcc/ada/s-valenu.adb | 155 - gcc/ada/s-valenu.ads | 80 - gcc/ada/s-valint.adb | 118 - gcc/ada/s-valint.ads | 73 - gcc/ada/s-vallld.adb | 70 - gcc/ada/s-vallld.ads | 81 - gcc/ada/s-vallli.adb | 120 - gcc/ada/s-vallli.ads | 73 - gcc/ada/s-valllu.adb | 330 - gcc/ada/s-valllu.ads | 129 - gcc/ada/s-valrea.adb | 415 - gcc/ada/s-valrea.ads | 74 - gcc/ada/s-valuns.adb | 325 - gcc/ada/s-valuns.ads | 129 - gcc/ada/s-valuti.adb | 334 - gcc/ada/s-valuti.ads | 126 - gcc/ada/s-valwch.adb | 175 - gcc/ada/s-valwch.ads | 53 - gcc/ada/s-veboop.adb | 125 - gcc/ada/s-veboop.ads | 66 - gcc/ada/s-vector.ads | 49 - gcc/ada/s-vercon.adb | 58 - gcc/ada/s-vercon.ads | 52 - gcc/ada/s-wchcnv.adb | 465 - gcc/ada/s-wchcnv.ads | 116 - gcc/ada/s-wchcon.adb | 84 - gcc/ada/s-wchcon.ads | 220 - gcc/ada/s-wchjis.adb | 189 - gcc/ada/s-wchjis.ads | 78 - gcc/ada/s-wchstw.adb | 173 - gcc/ada/s-wchstw.ads | 69 - gcc/ada/s-wchwts.adb | 122 - gcc/ada/s-wchwts.ads | 63 - gcc/ada/s-widboo.adb | 51 - gcc/ada/s-widboo.ads | 41 - gcc/ada/s-widcha.adb | 56 - gcc/ada/s-widcha.ads | 41 - gcc/ada/s-widenu.adb | 135 - gcc/ada/s-widenu.ads | 73 - gcc/ada/s-widlli.adb | 73 - gcc/ada/s-widlli.ads | 45 - gcc/ada/s-widllu.adb | 73 - gcc/ada/s-widllu.ads | 47 - gcc/ada/s-widwch.adb | 104 - gcc/ada/s-widwch.ads | 46 - gcc/ada/s-win32.ads | 342 - gcc/ada/s-winext.ads | 130 - gcc/ada/s-wwdcha.adb | 74 - gcc/ada/s-wwdcha.ads | 45 - gcc/ada/s-wwdenu.adb | 273 - gcc/ada/s-wwdenu.ads | 98 - gcc/ada/s-wwdwch.adb | 130 - gcc/ada/s-wwdwch.ads | 61 - gcc/ada/sequenio.ads | 24 - gcc/ada/system-aix.ads | 158 - gcc/ada/system-darwin-arm.ads | 174 - gcc/ada/system-darwin-ppc.ads | 174 - gcc/ada/system-darwin-x86.ads | 174 - gcc/ada/system-djgpp.ads | 148 - gcc/ada/system-dragonfly-x86_64.ads | 148 - gcc/ada/system-freebsd.ads | 149 - gcc/ada/system-hpux-ia64.ads | 148 - gcc/ada/system-hpux.ads | 223 - gcc/ada/system-linux-alpha.ads | 148 - gcc/ada/system-linux-arm.ads | 157 - gcc/ada/system-linux-hppa.ads | 147 - gcc/ada/system-linux-ia64.ads | 156 - gcc/ada/system-linux-m68k.ads | 158 - gcc/ada/system-linux-mips.ads | 148 - gcc/ada/system-linux-ppc.ads | 156 - gcc/ada/system-linux-s390.ads | 147 - gcc/ada/system-linux-sh4.ads | 155 - gcc/ada/system-linux-sparc.ads | 147 - gcc/ada/system-linux-x86.ads | 156 - gcc/ada/system-mingw.ads | 200 - gcc/ada/system-rtems.ads | 166 - gcc/ada/system-solaris-sparc.ads | 148 - gcc/ada/system-solaris-x86.ads | 148 - gcc/ada/system-vxworks-arm.ads | 166 - gcc/ada/system-vxworks-ppc.ads | 169 - gcc/ada/system-vxworks-x86.ads | 166 - gcc/ada/system.ads | 178 - gcc/ada/text_io.ads | 24 - gcc/ada/unchconv.ads | 22 - gcc/ada/unchdeal.ads | 21 - 2562 files changed, 385488 insertions(+), 379948 deletions(-) delete mode 100644 gcc/ada/a-assert.adb delete mode 100644 gcc/ada/a-assert.ads delete mode 100644 gcc/ada/a-btgbso.adb delete mode 100644 gcc/ada/a-btgbso.ads delete mode 100644 gcc/ada/a-calari.adb delete mode 100644 gcc/ada/a-calari.ads delete mode 100644 gcc/ada/a-calcon.adb delete mode 100644 gcc/ada/a-calcon.ads delete mode 100644 gcc/ada/a-caldel.adb delete mode 100644 gcc/ada/a-caldel.ads delete mode 100644 gcc/ada/a-calend.adb delete mode 100644 gcc/ada/a-calend.ads delete mode 100644 gcc/ada/a-calfor.adb delete mode 100644 gcc/ada/a-calfor.ads delete mode 100644 gcc/ada/a-catizo.adb delete mode 100644 gcc/ada/a-catizo.ads delete mode 100644 gcc/ada/a-cbdlli.adb delete mode 100644 gcc/ada/a-cbdlli.ads delete mode 100644 gcc/ada/a-cbhama.adb delete mode 100644 gcc/ada/a-cbhama.ads delete mode 100644 gcc/ada/a-cbhase.adb delete mode 100644 gcc/ada/a-cbhase.ads delete mode 100644 gcc/ada/a-cbmutr.adb delete mode 100644 gcc/ada/a-cbmutr.ads delete mode 100644 gcc/ada/a-cborma.adb delete mode 100644 gcc/ada/a-cborma.ads delete mode 100644 gcc/ada/a-cborse.adb delete mode 100644 gcc/ada/a-cborse.ads delete mode 100644 gcc/ada/a-cbprqu.adb delete mode 100644 gcc/ada/a-cbprqu.ads delete mode 100644 gcc/ada/a-cbsyqu.adb delete mode 100644 gcc/ada/a-cbsyqu.ads delete mode 100644 gcc/ada/a-cdlili.adb delete mode 100644 gcc/ada/a-cdlili.ads delete mode 100644 gcc/ada/a-cfdlli.adb delete mode 100644 gcc/ada/a-cfdlli.ads delete mode 100644 gcc/ada/a-cfhama.adb delete mode 100644 gcc/ada/a-cfhama.ads delete mode 100644 gcc/ada/a-cfhase.adb delete mode 100644 gcc/ada/a-cfhase.ads delete mode 100644 gcc/ada/a-cfinve.adb delete mode 100644 gcc/ada/a-cfinve.ads delete mode 100644 gcc/ada/a-cforma.adb delete mode 100644 gcc/ada/a-cforma.ads delete mode 100644 gcc/ada/a-cforse.adb delete mode 100644 gcc/ada/a-cforse.ads delete mode 100644 gcc/ada/a-cgaaso.adb delete mode 100644 gcc/ada/a-cgaaso.ads delete mode 100644 gcc/ada/a-cgarso.adb delete mode 100644 gcc/ada/a-cgarso.ads delete mode 100644 gcc/ada/a-cgcaso.adb delete mode 100644 gcc/ada/a-cgcaso.ads delete mode 100644 gcc/ada/a-chacon.adb delete mode 100644 gcc/ada/a-chacon.ads delete mode 100644 gcc/ada/a-chahan.adb delete mode 100644 gcc/ada/a-chahan.ads delete mode 100644 gcc/ada/a-charac.ads delete mode 100644 gcc/ada/a-chlat1.ads delete mode 100644 gcc/ada/a-chlat9.ads delete mode 100644 gcc/ada/a-chtgbk.adb delete mode 100644 gcc/ada/a-chtgbk.ads delete mode 100644 gcc/ada/a-chtgbo.adb delete mode 100644 gcc/ada/a-chtgbo.ads delete mode 100644 gcc/ada/a-chtgke.adb delete mode 100644 gcc/ada/a-chtgke.ads delete mode 100644 gcc/ada/a-chtgop.adb delete mode 100644 gcc/ada/a-chtgop.ads delete mode 100644 gcc/ada/a-chzla1.ads delete mode 100644 gcc/ada/a-chzla9.ads delete mode 100644 gcc/ada/a-cidlli.adb delete mode 100644 gcc/ada/a-cidlli.ads delete mode 100644 gcc/ada/a-cihama.adb delete mode 100644 gcc/ada/a-cihama.ads delete mode 100644 gcc/ada/a-cihase.adb delete mode 100644 gcc/ada/a-cihase.ads delete mode 100644 gcc/ada/a-cimutr.adb delete mode 100644 gcc/ada/a-cimutr.ads delete mode 100644 gcc/ada/a-ciorma.adb delete mode 100644 gcc/ada/a-ciorma.ads delete mode 100644 gcc/ada/a-ciormu.adb delete mode 100644 gcc/ada/a-ciormu.ads delete mode 100644 gcc/ada/a-ciorse.adb delete mode 100644 gcc/ada/a-ciorse.ads delete mode 100644 gcc/ada/a-clrefi.adb delete mode 100644 gcc/ada/a-clrefi.ads delete mode 100644 gcc/ada/a-coboho.adb delete mode 100644 gcc/ada/a-coboho.ads delete mode 100644 gcc/ada/a-cobove.adb delete mode 100644 gcc/ada/a-cobove.ads delete mode 100644 gcc/ada/a-cofove.adb delete mode 100644 gcc/ada/a-cofove.ads delete mode 100644 gcc/ada/a-cofuba.adb delete mode 100644 gcc/ada/a-cofuba.ads delete mode 100644 gcc/ada/a-cofuma.adb delete mode 100644 gcc/ada/a-cofuma.ads delete mode 100644 gcc/ada/a-cofuse.adb delete mode 100644 gcc/ada/a-cofuse.ads delete mode 100644 gcc/ada/a-cofuve.adb delete mode 100644 gcc/ada/a-cofuve.ads delete mode 100644 gcc/ada/a-cogeso.adb delete mode 100644 gcc/ada/a-cogeso.ads delete mode 100644 gcc/ada/a-cohama.adb delete mode 100644 gcc/ada/a-cohama.ads delete mode 100644 gcc/ada/a-cohase.adb delete mode 100644 gcc/ada/a-cohase.ads delete mode 100644 gcc/ada/a-cohata.ads delete mode 100644 gcc/ada/a-coinho-shared.adb delete mode 100644 gcc/ada/a-coinho-shared.ads delete mode 100644 gcc/ada/a-coinho.adb delete mode 100644 gcc/ada/a-coinho.ads delete mode 100644 gcc/ada/a-coinve.adb delete mode 100644 gcc/ada/a-coinve.ads delete mode 100644 gcc/ada/a-colien.adb delete mode 100644 gcc/ada/a-colien.ads delete mode 100644 gcc/ada/a-colire.adb delete mode 100644 gcc/ada/a-colire.ads delete mode 100644 gcc/ada/a-comlin.adb delete mode 100644 gcc/ada/a-comlin.ads delete mode 100644 gcc/ada/a-comutr.adb delete mode 100644 gcc/ada/a-comutr.ads delete mode 100644 gcc/ada/a-conhel.adb delete mode 100644 gcc/ada/a-conhel.ads delete mode 100644 gcc/ada/a-contai.ads delete mode 100644 gcc/ada/a-convec.adb delete mode 100644 gcc/ada/a-convec.ads delete mode 100644 gcc/ada/a-coorma.adb delete mode 100644 gcc/ada/a-coorma.ads delete mode 100644 gcc/ada/a-coormu.adb delete mode 100644 gcc/ada/a-coormu.ads delete mode 100644 gcc/ada/a-coorse.adb delete mode 100644 gcc/ada/a-coorse.ads delete mode 100644 gcc/ada/a-coprnu.adb delete mode 100644 gcc/ada/a-coprnu.ads delete mode 100644 gcc/ada/a-coteio.ads delete mode 100644 gcc/ada/a-crbltr.ads delete mode 100644 gcc/ada/a-crbtgk.adb delete mode 100644 gcc/ada/a-crbtgk.ads delete mode 100644 gcc/ada/a-crbtgo.adb delete mode 100644 gcc/ada/a-crbtgo.ads delete mode 100644 gcc/ada/a-crdlli.adb delete mode 100644 gcc/ada/a-crdlli.ads delete mode 100644 gcc/ada/a-csquin.ads delete mode 100644 gcc/ada/a-cuprqu.adb delete mode 100644 gcc/ada/a-cuprqu.ads delete mode 100644 gcc/ada/a-cusyqu.adb delete mode 100644 gcc/ada/a-cusyqu.ads delete mode 100644 gcc/ada/a-cwila1.ads delete mode 100644 gcc/ada/a-cwila9.ads delete mode 100644 gcc/ada/a-decima.adb delete mode 100644 gcc/ada/a-decima.ads delete mode 100644 gcc/ada/a-dhfina.ads delete mode 100644 gcc/ada/a-diocst.adb delete mode 100644 gcc/ada/a-diocst.ads delete mode 100644 gcc/ada/a-direct.adb delete mode 100644 gcc/ada/a-direct.ads delete mode 100644 gcc/ada/a-direio.adb delete mode 100644 gcc/ada/a-direio.ads delete mode 100644 gcc/ada/a-dirval-mingw.adb delete mode 100644 gcc/ada/a-dirval.adb delete mode 100644 gcc/ada/a-dirval.ads delete mode 100644 gcc/ada/a-einuoc.adb delete mode 100644 gcc/ada/a-einuoc.ads delete mode 100644 gcc/ada/a-elchha.adb delete mode 100644 gcc/ada/a-elchha.ads delete mode 100644 gcc/ada/a-envvar.adb delete mode 100644 gcc/ada/a-envvar.ads delete mode 100644 gcc/ada/a-excach.adb delete mode 100644 gcc/ada/a-except.adb delete mode 100644 gcc/ada/a-except.ads delete mode 100644 gcc/ada/a-excpol-abort.adb delete mode 100644 gcc/ada/a-excpol.adb delete mode 100644 gcc/ada/a-exctra.adb delete mode 100644 gcc/ada/a-exctra.ads delete mode 100644 gcc/ada/a-exexda.adb delete mode 100644 gcc/ada/a-exexpr.adb delete mode 100644 gcc/ada/a-exextr.adb delete mode 100644 gcc/ada/a-exstat.adb delete mode 100644 gcc/ada/a-finali.adb delete mode 100644 gcc/ada/a-finali.ads delete mode 100644 gcc/ada/a-flteio.ads delete mode 100644 gcc/ada/a-fwteio.ads delete mode 100644 gcc/ada/a-fzteio.ads delete mode 100644 gcc/ada/a-inteio.ads delete mode 100644 gcc/ada/a-intnam-dragonfly.ads delete mode 100644 gcc/ada/a-intnam-rtems.ads delete mode 100644 gcc/ada/a-ioexce.ads delete mode 100644 gcc/ada/a-iteint.ads delete mode 100644 gcc/ada/a-iwteio.ads delete mode 100644 gcc/ada/a-izteio.ads delete mode 100644 gcc/ada/a-lcteio.ads delete mode 100644 gcc/ada/a-lfteio.ads delete mode 100644 gcc/ada/a-lfwtio.ads delete mode 100644 gcc/ada/a-lfztio.ads delete mode 100644 gcc/ada/a-liteio.ads delete mode 100644 gcc/ada/a-liwtio.ads delete mode 100644 gcc/ada/a-liztio.ads delete mode 100644 gcc/ada/a-llctio.ads delete mode 100644 gcc/ada/a-llftio.ads delete mode 100644 gcc/ada/a-llfwti.ads delete mode 100644 gcc/ada/a-llfzti.ads delete mode 100644 gcc/ada/a-llitio.ads delete mode 100644 gcc/ada/a-lliwti.ads delete mode 100644 gcc/ada/a-llizti.ads delete mode 100644 gcc/ada/a-locale.adb delete mode 100644 gcc/ada/a-locale.ads delete mode 100644 gcc/ada/a-ncelfu.ads delete mode 100644 gcc/ada/a-ngcefu.adb delete mode 100644 gcc/ada/a-ngcefu.ads delete mode 100644 gcc/ada/a-ngcoar.adb delete mode 100644 gcc/ada/a-ngcoar.ads delete mode 100644 gcc/ada/a-ngcoty.adb delete mode 100644 gcc/ada/a-ngcoty.ads delete mode 100644 gcc/ada/a-ngelfu.adb delete mode 100644 gcc/ada/a-ngelfu.ads delete mode 100644 gcc/ada/a-ngrear.adb delete mode 100644 gcc/ada/a-ngrear.ads delete mode 100644 gcc/ada/a-nlcefu.ads delete mode 100644 gcc/ada/a-nlcoar.ads delete mode 100644 gcc/ada/a-nlcoty.ads delete mode 100644 gcc/ada/a-nlelfu.ads delete mode 100644 gcc/ada/a-nllcar.ads delete mode 100644 gcc/ada/a-nllcef.ads delete mode 100644 gcc/ada/a-nllcty.ads delete mode 100644 gcc/ada/a-nllefu.ads delete mode 100644 gcc/ada/a-nllrar.ads delete mode 100644 gcc/ada/a-nlrear.ads delete mode 100644 gcc/ada/a-nscefu.ads delete mode 100644 gcc/ada/a-nscoty.ads delete mode 100644 gcc/ada/a-nselfu.ads delete mode 100644 gcc/ada/a-nucoar.ads delete mode 100644 gcc/ada/a-nucoty.ads delete mode 100644 gcc/ada/a-nudira.adb delete mode 100644 gcc/ada/a-nudira.ads delete mode 100644 gcc/ada/a-nuelfu.ads delete mode 100644 gcc/ada/a-nuflra.adb delete mode 100644 gcc/ada/a-nuflra.ads delete mode 100644 gcc/ada/a-numaux-darwin.adb delete mode 100644 gcc/ada/a-numaux-darwin.ads delete mode 100644 gcc/ada/a-numaux-libc-x86.ads delete mode 100644 gcc/ada/a-numaux-vxworks.ads delete mode 100644 gcc/ada/a-numaux-x86.adb delete mode 100644 gcc/ada/a-numaux-x86.ads delete mode 100644 gcc/ada/a-numaux.ads delete mode 100644 gcc/ada/a-numeri.ads delete mode 100644 gcc/ada/a-nurear.ads delete mode 100644 gcc/ada/a-rbtgbk.adb delete mode 100644 gcc/ada/a-rbtgbk.ads delete mode 100644 gcc/ada/a-rbtgbo.adb delete mode 100644 gcc/ada/a-rbtgbo.ads delete mode 100644 gcc/ada/a-rbtgso.adb delete mode 100644 gcc/ada/a-rbtgso.ads delete mode 100644 gcc/ada/a-sbecin.adb delete mode 100644 gcc/ada/a-sbecin.ads delete mode 100644 gcc/ada/a-sbhcin.adb delete mode 100644 gcc/ada/a-sbhcin.ads delete mode 100644 gcc/ada/a-sblcin.adb delete mode 100644 gcc/ada/a-sblcin.ads delete mode 100644 gcc/ada/a-scteio.ads delete mode 100644 gcc/ada/a-secain.adb delete mode 100644 gcc/ada/a-secain.ads delete mode 100644 gcc/ada/a-sequio.adb delete mode 100644 gcc/ada/a-sequio.ads delete mode 100644 gcc/ada/a-sfecin.ads delete mode 100644 gcc/ada/a-sfhcin.ads delete mode 100644 gcc/ada/a-sflcin.ads delete mode 100644 gcc/ada/a-sfteio.ads delete mode 100644 gcc/ada/a-sfwtio.ads delete mode 100644 gcc/ada/a-sfztio.ads delete mode 100644 gcc/ada/a-shcain.adb delete mode 100644 gcc/ada/a-shcain.ads delete mode 100644 gcc/ada/a-siocst.adb delete mode 100644 gcc/ada/a-siocst.ads delete mode 100644 gcc/ada/a-siteio.ads delete mode 100644 gcc/ada/a-siwtio.ads delete mode 100644 gcc/ada/a-siztio.ads delete mode 100644 gcc/ada/a-slcain.adb delete mode 100644 gcc/ada/a-slcain.ads delete mode 100644 gcc/ada/a-ssicst.adb delete mode 100644 gcc/ada/a-ssicst.ads delete mode 100644 gcc/ada/a-ssitio.ads delete mode 100644 gcc/ada/a-ssiwti.ads delete mode 100644 gcc/ada/a-ssizti.ads delete mode 100644 gcc/ada/a-stboha.adb delete mode 100644 gcc/ada/a-stboha.ads delete mode 100644 gcc/ada/a-stfiha.ads delete mode 100644 gcc/ada/a-stmaco.ads delete mode 100644 gcc/ada/a-storio.adb delete mode 100644 gcc/ada/a-storio.ads delete mode 100644 gcc/ada/a-strbou.adb delete mode 100644 gcc/ada/a-strbou.ads delete mode 100644 gcc/ada/a-stream.adb delete mode 100644 gcc/ada/a-stream.ads delete mode 100644 gcc/ada/a-strfix.adb delete mode 100644 gcc/ada/a-strfix.ads delete mode 100644 gcc/ada/a-strhas.adb delete mode 100644 gcc/ada/a-strhas.ads delete mode 100644 gcc/ada/a-string.ads delete mode 100644 gcc/ada/a-strmap.adb delete mode 100644 gcc/ada/a-strmap.ads delete mode 100644 gcc/ada/a-strsea.adb delete mode 100644 gcc/ada/a-strsea.ads delete mode 100644 gcc/ada/a-strsup.adb delete mode 100644 gcc/ada/a-strsup.ads delete mode 100644 gcc/ada/a-strunb-shared.adb delete mode 100644 gcc/ada/a-strunb-shared.ads delete mode 100644 gcc/ada/a-strunb.adb delete mode 100644 gcc/ada/a-strunb.ads delete mode 100644 gcc/ada/a-ststio.adb delete mode 100644 gcc/ada/a-ststio.ads delete mode 100644 gcc/ada/a-stunau-shared.adb delete mode 100644 gcc/ada/a-stunau.adb delete mode 100644 gcc/ada/a-stunau.ads delete mode 100644 gcc/ada/a-stunha.adb delete mode 100644 gcc/ada/a-stunha.ads delete mode 100644 gcc/ada/a-stuten.adb delete mode 100644 gcc/ada/a-stuten.ads delete mode 100644 gcc/ada/a-stwibo.adb delete mode 100644 gcc/ada/a-stwibo.ads delete mode 100644 gcc/ada/a-stwifi.adb delete mode 100644 gcc/ada/a-stwifi.ads delete mode 100644 gcc/ada/a-stwiha.adb delete mode 100644 gcc/ada/a-stwiha.ads delete mode 100644 gcc/ada/a-stwima.adb delete mode 100644 gcc/ada/a-stwima.ads delete mode 100644 gcc/ada/a-stwise.adb delete mode 100644 gcc/ada/a-stwise.ads delete mode 100644 gcc/ada/a-stwisu.adb delete mode 100644 gcc/ada/a-stwisu.ads delete mode 100644 gcc/ada/a-stwiun-shared.adb delete mode 100644 gcc/ada/a-stwiun-shared.ads delete mode 100644 gcc/ada/a-stwiun.adb delete mode 100644 gcc/ada/a-stwiun.ads delete mode 100644 gcc/ada/a-stzbou.adb delete mode 100644 gcc/ada/a-stzbou.ads delete mode 100644 gcc/ada/a-stzfix.adb delete mode 100644 gcc/ada/a-stzfix.ads delete mode 100644 gcc/ada/a-stzhas.adb delete mode 100644 gcc/ada/a-stzhas.ads delete mode 100644 gcc/ada/a-stzmap.adb delete mode 100644 gcc/ada/a-stzmap.ads delete mode 100644 gcc/ada/a-stzsea.adb delete mode 100644 gcc/ada/a-stzsea.ads delete mode 100644 gcc/ada/a-stzsup.adb delete mode 100644 gcc/ada/a-stzsup.ads delete mode 100644 gcc/ada/a-stzunb-shared.adb delete mode 100644 gcc/ada/a-stzunb-shared.ads delete mode 100644 gcc/ada/a-stzunb.adb delete mode 100644 gcc/ada/a-stzunb.ads delete mode 100644 gcc/ada/a-suecin.adb delete mode 100644 gcc/ada/a-suecin.ads delete mode 100644 gcc/ada/a-suenco.adb delete mode 100644 gcc/ada/a-suenco.ads delete mode 100644 gcc/ada/a-suenst.adb delete mode 100644 gcc/ada/a-suenst.ads delete mode 100644 gcc/ada/a-suewst.adb delete mode 100644 gcc/ada/a-suewst.ads delete mode 100644 gcc/ada/a-suezst.adb delete mode 100644 gcc/ada/a-suezst.ads delete mode 100644 gcc/ada/a-suhcin.adb delete mode 100644 gcc/ada/a-suhcin.ads delete mode 100644 gcc/ada/a-sulcin.adb delete mode 100644 gcc/ada/a-sulcin.ads delete mode 100644 gcc/ada/a-suteio-shared.adb delete mode 100644 gcc/ada/a-suteio.adb delete mode 100644 gcc/ada/a-suteio.ads delete mode 100644 gcc/ada/a-swbwha.adb delete mode 100644 gcc/ada/a-swbwha.ads delete mode 100644 gcc/ada/a-swfwha.ads delete mode 100644 gcc/ada/a-swmwco.ads delete mode 100644 gcc/ada/a-swunau-shared.adb delete mode 100644 gcc/ada/a-swunau.adb delete mode 100644 gcc/ada/a-swunau.ads delete mode 100644 gcc/ada/a-swuwha.adb delete mode 100644 gcc/ada/a-swuwha.ads delete mode 100644 gcc/ada/a-swuwti-shared.adb delete mode 100644 gcc/ada/a-swuwti.adb delete mode 100644 gcc/ada/a-swuwti.ads delete mode 100644 gcc/ada/a-szbzha.adb delete mode 100644 gcc/ada/a-szbzha.ads delete mode 100644 gcc/ada/a-szfzha.ads delete mode 100644 gcc/ada/a-szmzco.ads delete mode 100644 gcc/ada/a-szunau-shared.adb delete mode 100644 gcc/ada/a-szunau.adb delete mode 100644 gcc/ada/a-szunau.ads delete mode 100644 gcc/ada/a-szuzha.adb delete mode 100644 gcc/ada/a-szuzha.ads delete mode 100644 gcc/ada/a-szuzti-shared.adb delete mode 100644 gcc/ada/a-szuzti.adb delete mode 100644 gcc/ada/a-szuzti.ads delete mode 100644 gcc/ada/a-tags.adb delete mode 100644 gcc/ada/a-tags.ads delete mode 100644 gcc/ada/a-teioed.adb delete mode 100644 gcc/ada/a-teioed.ads delete mode 100644 gcc/ada/a-textio.adb delete mode 100644 gcc/ada/a-textio.ads delete mode 100644 gcc/ada/a-tgdico.ads delete mode 100644 gcc/ada/a-tiboio.adb delete mode 100644 gcc/ada/a-tiboio.ads delete mode 100644 gcc/ada/a-ticoau.adb delete mode 100644 gcc/ada/a-ticoau.ads delete mode 100644 gcc/ada/a-ticoio.adb delete mode 100644 gcc/ada/a-ticoio.ads delete mode 100644 gcc/ada/a-tideau.adb delete mode 100644 gcc/ada/a-tideau.ads delete mode 100644 gcc/ada/a-tideio.adb delete mode 100644 gcc/ada/a-tideio.ads delete mode 100644 gcc/ada/a-tienau.adb delete mode 100644 gcc/ada/a-tienau.ads delete mode 100644 gcc/ada/a-tienio.adb delete mode 100644 gcc/ada/a-tienio.ads delete mode 100644 gcc/ada/a-tifiio.adb delete mode 100644 gcc/ada/a-tifiio.ads delete mode 100644 gcc/ada/a-tiflau.adb delete mode 100644 gcc/ada/a-tiflau.ads delete mode 100644 gcc/ada/a-tiflio.adb delete mode 100644 gcc/ada/a-tiflio.ads delete mode 100644 gcc/ada/a-tigeau.adb delete mode 100644 gcc/ada/a-tigeau.ads delete mode 100644 gcc/ada/a-tigeli.adb delete mode 100644 gcc/ada/a-tiinau.adb delete mode 100644 gcc/ada/a-tiinau.ads delete mode 100644 gcc/ada/a-tiinio.adb delete mode 100644 gcc/ada/a-tiinio.ads delete mode 100644 gcc/ada/a-timoau.adb delete mode 100644 gcc/ada/a-timoau.ads delete mode 100644 gcc/ada/a-timoio.adb delete mode 100644 gcc/ada/a-timoio.ads delete mode 100644 gcc/ada/a-tiocst.adb delete mode 100644 gcc/ada/a-tiocst.ads delete mode 100644 gcc/ada/a-tirsfi.adb delete mode 100644 gcc/ada/a-tirsfi.ads delete mode 100644 gcc/ada/a-titest.adb delete mode 100644 gcc/ada/a-titest.ads delete mode 100644 gcc/ada/a-tiunio.ads delete mode 100644 gcc/ada/a-unccon.ads delete mode 100644 gcc/ada/a-uncdea.ads delete mode 100644 gcc/ada/a-undesu.adb delete mode 100644 gcc/ada/a-undesu.ads delete mode 100644 gcc/ada/a-wichha.adb delete mode 100644 gcc/ada/a-wichha.ads delete mode 100644 gcc/ada/a-wichun.adb delete mode 100644 gcc/ada/a-wichun.ads delete mode 100644 gcc/ada/a-widcha.ads delete mode 100644 gcc/ada/a-witeio.adb delete mode 100644 gcc/ada/a-witeio.ads delete mode 100644 gcc/ada/a-wrstfi.adb delete mode 100644 gcc/ada/a-wrstfi.ads delete mode 100644 gcc/ada/a-wtcoau.adb delete mode 100644 gcc/ada/a-wtcoau.ads delete mode 100644 gcc/ada/a-wtcoio.adb delete mode 100644 gcc/ada/a-wtcoio.ads delete mode 100644 gcc/ada/a-wtcstr.adb delete mode 100644 gcc/ada/a-wtcstr.ads delete mode 100644 gcc/ada/a-wtdeau.adb delete mode 100644 gcc/ada/a-wtdeau.ads delete mode 100644 gcc/ada/a-wtdeio.adb delete mode 100644 gcc/ada/a-wtdeio.ads delete mode 100644 gcc/ada/a-wtedit.adb delete mode 100644 gcc/ada/a-wtedit.ads delete mode 100644 gcc/ada/a-wtenau.adb delete mode 100644 gcc/ada/a-wtenau.ads delete mode 100644 gcc/ada/a-wtenio.adb delete mode 100644 gcc/ada/a-wtenio.ads delete mode 100644 gcc/ada/a-wtfiio.adb delete mode 100644 gcc/ada/a-wtfiio.ads delete mode 100644 gcc/ada/a-wtflau.adb delete mode 100644 gcc/ada/a-wtflau.ads delete mode 100644 gcc/ada/a-wtflio.adb delete mode 100644 gcc/ada/a-wtflio.ads delete mode 100644 gcc/ada/a-wtgeau.adb delete mode 100644 gcc/ada/a-wtgeau.ads delete mode 100644 gcc/ada/a-wtinau.adb delete mode 100644 gcc/ada/a-wtinau.ads delete mode 100644 gcc/ada/a-wtinio.adb delete mode 100644 gcc/ada/a-wtinio.ads delete mode 100644 gcc/ada/a-wtmoau.adb delete mode 100644 gcc/ada/a-wtmoau.ads delete mode 100644 gcc/ada/a-wtmoio.adb delete mode 100644 gcc/ada/a-wtmoio.ads delete mode 100644 gcc/ada/a-wttest.adb delete mode 100644 gcc/ada/a-wttest.ads delete mode 100644 gcc/ada/a-wwboio.adb delete mode 100644 gcc/ada/a-wwboio.ads delete mode 100644 gcc/ada/a-wwunio.ads delete mode 100644 gcc/ada/a-zchara.ads delete mode 100644 gcc/ada/a-zchhan.adb delete mode 100644 gcc/ada/a-zchhan.ads delete mode 100644 gcc/ada/a-zchuni.adb delete mode 100644 gcc/ada/a-zchuni.ads delete mode 100644 gcc/ada/a-zrstfi.adb delete mode 100644 gcc/ada/a-zrstfi.ads delete mode 100644 gcc/ada/a-ztcoau.adb delete mode 100644 gcc/ada/a-ztcoau.ads delete mode 100644 gcc/ada/a-ztcoio.adb delete mode 100644 gcc/ada/a-ztcoio.ads delete mode 100644 gcc/ada/a-ztcstr.adb delete mode 100644 gcc/ada/a-ztcstr.ads delete mode 100644 gcc/ada/a-ztdeau.adb delete mode 100644 gcc/ada/a-ztdeau.ads delete mode 100644 gcc/ada/a-ztdeio.adb delete mode 100644 gcc/ada/a-ztdeio.ads delete mode 100644 gcc/ada/a-ztedit.adb delete mode 100644 gcc/ada/a-ztedit.ads delete mode 100644 gcc/ada/a-ztenau.adb delete mode 100644 gcc/ada/a-ztenau.ads delete mode 100644 gcc/ada/a-ztenio.adb delete mode 100644 gcc/ada/a-ztenio.ads delete mode 100644 gcc/ada/a-ztexio.adb delete mode 100644 gcc/ada/a-ztexio.ads delete mode 100644 gcc/ada/a-ztfiio.adb delete mode 100644 gcc/ada/a-ztfiio.ads delete mode 100644 gcc/ada/a-ztflau.adb delete mode 100644 gcc/ada/a-ztflau.ads delete mode 100644 gcc/ada/a-ztflio.adb delete mode 100644 gcc/ada/a-ztflio.ads delete mode 100644 gcc/ada/a-ztgeau.adb delete mode 100644 gcc/ada/a-ztgeau.ads delete mode 100644 gcc/ada/a-ztinau.adb delete mode 100644 gcc/ada/a-ztinau.ads delete mode 100644 gcc/ada/a-ztinio.adb delete mode 100644 gcc/ada/a-ztinio.ads delete mode 100644 gcc/ada/a-ztmoau.adb delete mode 100644 gcc/ada/a-ztmoau.ads delete mode 100644 gcc/ada/a-ztmoio.adb delete mode 100644 gcc/ada/a-ztmoio.ads delete mode 100644 gcc/ada/a-zttest.adb delete mode 100644 gcc/ada/a-zttest.ads delete mode 100644 gcc/ada/a-zzboio.adb delete mode 100644 gcc/ada/a-zzboio.ads delete mode 100644 gcc/ada/a-zzunio.ads delete mode 100644 gcc/ada/ada.ads delete mode 100644 gcc/ada/calendar.ads delete mode 100644 gcc/ada/directio.ads delete mode 100644 gcc/ada/g-allein.ads delete mode 100644 gcc/ada/g-alleve.adb delete mode 100644 gcc/ada/g-alleve.ads delete mode 100644 gcc/ada/g-altcon.adb delete mode 100644 gcc/ada/g-altcon.ads delete mode 100644 gcc/ada/g-altive.ads delete mode 100644 gcc/ada/g-alveop.adb delete mode 100644 gcc/ada/g-alveop.ads delete mode 100644 gcc/ada/g-alvety.ads delete mode 100644 gcc/ada/g-alvevi.ads delete mode 100644 gcc/ada/g-arrspl.adb delete mode 100644 gcc/ada/g-arrspl.ads delete mode 100644 gcc/ada/g-awk.adb delete mode 100644 gcc/ada/g-awk.ads delete mode 100644 gcc/ada/g-binenv.adb delete mode 100644 gcc/ada/g-binenv.ads delete mode 100644 gcc/ada/g-bubsor.adb delete mode 100644 gcc/ada/g-bubsor.ads delete mode 100644 gcc/ada/g-busora.adb delete mode 100644 gcc/ada/g-busora.ads delete mode 100644 gcc/ada/g-busorg.adb delete mode 100644 gcc/ada/g-busorg.ads delete mode 100644 gcc/ada/g-byorma.adb delete mode 100644 gcc/ada/g-byorma.ads delete mode 100644 gcc/ada/g-bytswa.adb delete mode 100644 gcc/ada/g-bytswa.ads delete mode 100644 gcc/ada/g-calend.adb delete mode 100644 gcc/ada/g-calend.ads delete mode 100644 gcc/ada/g-casuti.adb delete mode 100644 gcc/ada/g-casuti.ads delete mode 100644 gcc/ada/g-catiio.adb delete mode 100644 gcc/ada/g-catiio.ads delete mode 100644 gcc/ada/g-cgi.adb delete mode 100644 gcc/ada/g-cgi.ads delete mode 100644 gcc/ada/g-cgicoo.adb delete mode 100644 gcc/ada/g-cgicoo.ads delete mode 100644 gcc/ada/g-cgideb.adb delete mode 100644 gcc/ada/g-cgideb.ads delete mode 100644 gcc/ada/g-comlin.adb delete mode 100644 gcc/ada/g-comlin.ads delete mode 100644 gcc/ada/g-comver.adb delete mode 100644 gcc/ada/g-comver.ads delete mode 100644 gcc/ada/g-cppexc.adb delete mode 100644 gcc/ada/g-cppexc.ads delete mode 100644 gcc/ada/g-crc32.adb delete mode 100644 gcc/ada/g-crc32.ads delete mode 100644 gcc/ada/g-ctrl_c.adb delete mode 100644 gcc/ada/g-ctrl_c.ads delete mode 100644 gcc/ada/g-curexc.ads delete mode 100644 gcc/ada/g-debpoo.adb delete mode 100644 gcc/ada/g-debpoo.ads delete mode 100644 gcc/ada/g-debuti.adb delete mode 100644 gcc/ada/g-debuti.ads delete mode 100644 gcc/ada/g-decstr.adb delete mode 100644 gcc/ada/g-decstr.ads delete mode 100644 gcc/ada/g-deutst.ads delete mode 100644 gcc/ada/g-diopit.adb delete mode 100644 gcc/ada/g-diopit.ads delete mode 100644 gcc/ada/g-dirope.adb delete mode 100644 gcc/ada/g-dirope.ads delete mode 100644 gcc/ada/g-dynhta.adb delete mode 100644 gcc/ada/g-dynhta.ads delete mode 100644 gcc/ada/g-dyntab.adb delete mode 100644 gcc/ada/g-dyntab.ads delete mode 100644 gcc/ada/g-eacodu.adb delete mode 100644 gcc/ada/g-encstr.adb delete mode 100644 gcc/ada/g-encstr.ads delete mode 100644 gcc/ada/g-enutst.ads delete mode 100644 gcc/ada/g-excact.adb delete mode 100644 gcc/ada/g-excact.ads delete mode 100644 gcc/ada/g-except.ads delete mode 100644 gcc/ada/g-exctra.adb delete mode 100644 gcc/ada/g-exctra.ads delete mode 100644 gcc/ada/g-expect.adb delete mode 100644 gcc/ada/g-expect.ads delete mode 100644 gcc/ada/g-exptty.adb delete mode 100644 gcc/ada/g-exptty.ads delete mode 100644 gcc/ada/g-flocon.ads delete mode 100644 gcc/ada/g-forstr.adb delete mode 100644 gcc/ada/g-forstr.ads delete mode 100644 gcc/ada/g-heasor.adb delete mode 100644 gcc/ada/g-heasor.ads delete mode 100644 gcc/ada/g-hesora.adb delete mode 100644 gcc/ada/g-hesora.ads delete mode 100644 gcc/ada/g-hesorg.adb delete mode 100644 gcc/ada/g-hesorg.ads delete mode 100644 gcc/ada/g-htable.adb delete mode 100644 gcc/ada/g-htable.ads delete mode 100644 gcc/ada/g-io-put-vxworks.adb delete mode 100644 gcc/ada/g-io.adb delete mode 100644 gcc/ada/g-io.ads delete mode 100644 gcc/ada/g-io_aux.adb delete mode 100644 gcc/ada/g-io_aux.ads delete mode 100644 gcc/ada/g-locfil.adb delete mode 100644 gcc/ada/g-locfil.ads delete mode 100644 gcc/ada/g-mbdira.adb delete mode 100644 gcc/ada/g-mbdira.ads delete mode 100644 gcc/ada/g-mbflra.adb delete mode 100644 gcc/ada/g-mbflra.ads delete mode 100644 gcc/ada/g-md5.adb delete mode 100644 gcc/ada/g-md5.ads delete mode 100644 gcc/ada/g-memdum.adb delete mode 100644 gcc/ada/g-memdum.ads delete mode 100644 gcc/ada/g-moreex.adb delete mode 100644 gcc/ada/g-moreex.ads delete mode 100644 gcc/ada/g-os_lib.adb delete mode 100644 gcc/ada/g-os_lib.ads delete mode 100644 gcc/ada/g-pehage.adb delete mode 100644 gcc/ada/g-pehage.ads delete mode 100644 gcc/ada/g-rannum.adb delete mode 100644 gcc/ada/g-rannum.ads delete mode 100644 gcc/ada/g-regexp.adb delete mode 100644 gcc/ada/g-regexp.ads delete mode 100644 gcc/ada/g-regist.adb delete mode 100644 gcc/ada/g-regist.ads delete mode 100644 gcc/ada/g-regpat.adb delete mode 100644 gcc/ada/g-regpat.ads delete mode 100644 gcc/ada/g-rewdat.adb delete mode 100644 gcc/ada/g-rewdat.ads delete mode 100644 gcc/ada/g-sechas.adb delete mode 100644 gcc/ada/g-sechas.ads delete mode 100644 gcc/ada/g-sehamd.adb delete mode 100644 gcc/ada/g-sehamd.ads delete mode 100644 gcc/ada/g-sehash.adb delete mode 100644 gcc/ada/g-sehash.ads delete mode 100644 gcc/ada/g-sercom-linux.adb delete mode 100644 gcc/ada/g-sercom-mingw.adb delete mode 100644 gcc/ada/g-sercom.adb delete mode 100644 gcc/ada/g-sercom.ads delete mode 100644 gcc/ada/g-sestin.ads delete mode 100644 gcc/ada/g-sha1.adb delete mode 100644 gcc/ada/g-sha1.ads delete mode 100644 gcc/ada/g-sha224.ads delete mode 100644 gcc/ada/g-sha256.ads delete mode 100644 gcc/ada/g-sha384.ads delete mode 100644 gcc/ada/g-sha512.ads delete mode 100644 gcc/ada/g-shsh32.adb delete mode 100644 gcc/ada/g-shsh32.ads delete mode 100644 gcc/ada/g-shsh64.adb delete mode 100644 gcc/ada/g-shsh64.ads delete mode 100644 gcc/ada/g-shshco.adb delete mode 100644 gcc/ada/g-shshco.ads delete mode 100644 gcc/ada/g-soccon.ads delete mode 100644 gcc/ada/g-socket-dummy.adb delete mode 100644 gcc/ada/g-socket-dummy.ads delete mode 100644 gcc/ada/g-socket.adb delete mode 100644 gcc/ada/g-socket.ads delete mode 100644 gcc/ada/g-socthi-dummy.adb delete mode 100644 gcc/ada/g-socthi-dummy.ads delete mode 100644 gcc/ada/g-socthi-mingw.adb delete mode 100644 gcc/ada/g-socthi-mingw.ads delete mode 100644 gcc/ada/g-socthi-vxworks.adb delete mode 100644 gcc/ada/g-socthi-vxworks.ads delete mode 100644 gcc/ada/g-socthi.adb delete mode 100644 gcc/ada/g-socthi.ads delete mode 100644 gcc/ada/g-soliop-mingw.ads delete mode 100644 gcc/ada/g-soliop-solaris.ads delete mode 100644 gcc/ada/g-soliop.ads delete mode 100644 gcc/ada/g-sothco-dummy.adb delete mode 100644 gcc/ada/g-sothco-dummy.ads delete mode 100644 gcc/ada/g-sothco.adb delete mode 100644 gcc/ada/g-sothco.ads delete mode 100644 gcc/ada/g-souinf.ads delete mode 100644 gcc/ada/g-spchge.adb delete mode 100644 gcc/ada/g-spchge.ads delete mode 100644 gcc/ada/g-speche.adb delete mode 100644 gcc/ada/g-speche.ads delete mode 100644 gcc/ada/g-spipat.adb delete mode 100644 gcc/ada/g-spipat.ads delete mode 100644 gcc/ada/g-spitbo.adb delete mode 100644 gcc/ada/g-spitbo.ads delete mode 100644 gcc/ada/g-sptabo.ads delete mode 100644 gcc/ada/g-sptain.ads delete mode 100644 gcc/ada/g-sptavs.ads delete mode 100644 gcc/ada/g-sse.ads delete mode 100644 gcc/ada/g-ssvety.ads delete mode 100644 gcc/ada/g-stheme.adb delete mode 100644 gcc/ada/g-strhas.ads delete mode 100644 gcc/ada/g-string.adb delete mode 100644 gcc/ada/g-string.ads delete mode 100644 gcc/ada/g-strspl.ads delete mode 100644 gcc/ada/g-stseme.adb delete mode 100644 gcc/ada/g-stsifd-sockets.adb delete mode 100644 gcc/ada/g-table.adb delete mode 100644 gcc/ada/g-table.ads delete mode 100644 gcc/ada/g-tasloc.adb delete mode 100644 gcc/ada/g-tasloc.ads delete mode 100644 gcc/ada/g-timsta.adb delete mode 100644 gcc/ada/g-timsta.ads delete mode 100644 gcc/ada/g-traceb.adb delete mode 100644 gcc/ada/g-traceb.ads delete mode 100644 gcc/ada/g-trasym.adb delete mode 100644 gcc/ada/g-trasym.ads delete mode 100644 gcc/ada/g-tty.adb delete mode 100644 gcc/ada/g-tty.ads delete mode 100644 gcc/ada/g-u3spch.adb delete mode 100644 gcc/ada/g-u3spch.ads delete mode 100644 gcc/ada/g-utf_32.adb delete mode 100644 gcc/ada/g-utf_32.ads delete mode 100644 gcc/ada/g-wispch.adb delete mode 100644 gcc/ada/g-wispch.ads delete mode 100644 gcc/ada/g-wistsp.ads delete mode 100644 gcc/ada/g-zspche.adb delete mode 100644 gcc/ada/g-zspche.ads delete mode 100644 gcc/ada/g-zstspl.ads delete mode 100644 gcc/ada/gnat.ads delete mode 100644 gcc/ada/i-c.adb delete mode 100644 gcc/ada/i-c.ads delete mode 100644 gcc/ada/i-cexten.ads delete mode 100644 gcc/ada/i-cobol.adb delete mode 100644 gcc/ada/i-cobol.ads delete mode 100644 gcc/ada/i-cpoint.adb delete mode 100644 gcc/ada/i-cpoint.ads delete mode 100644 gcc/ada/i-cstrea.adb delete mode 100644 gcc/ada/i-cstrea.ads delete mode 100644 gcc/ada/i-cstrin.adb delete mode 100644 gcc/ada/i-cstrin.ads delete mode 100644 gcc/ada/i-fortra.adb delete mode 100644 gcc/ada/i-fortra.ads delete mode 100644 gcc/ada/i-pacdec.adb delete mode 100644 gcc/ada/i-pacdec.ads delete mode 100644 gcc/ada/i-vxwoio.adb delete mode 100644 gcc/ada/i-vxwoio.ads delete mode 100644 gcc/ada/i-vxwork-x86.ads delete mode 100644 gcc/ada/i-vxwork.ads delete mode 100644 gcc/ada/interfac.ads delete mode 100644 gcc/ada/ioexcept.ads create mode 100644 gcc/ada/libgnarl/a-intnam-dragonfly.ads create mode 100644 gcc/ada/libgnarl/a-intnam-rtems.ads create mode 100644 gcc/ada/libgnat/a-assert.adb create mode 100644 gcc/ada/libgnat/a-assert.ads create mode 100644 gcc/ada/libgnat/a-btgbso.adb create mode 100644 gcc/ada/libgnat/a-btgbso.ads create mode 100644 gcc/ada/libgnat/a-calari.adb create mode 100644 gcc/ada/libgnat/a-calari.ads create mode 100644 gcc/ada/libgnat/a-calcon.adb create mode 100644 gcc/ada/libgnat/a-calcon.ads create mode 100644 gcc/ada/libgnat/a-caldel.adb create mode 100644 gcc/ada/libgnat/a-caldel.ads create mode 100644 gcc/ada/libgnat/a-calend.adb create mode 100644 gcc/ada/libgnat/a-calend.ads create mode 100644 gcc/ada/libgnat/a-calfor.adb create mode 100644 gcc/ada/libgnat/a-calfor.ads create mode 100644 gcc/ada/libgnat/a-catizo.adb create mode 100644 gcc/ada/libgnat/a-catizo.ads create mode 100644 gcc/ada/libgnat/a-cbdlli.adb create mode 100644 gcc/ada/libgnat/a-cbdlli.ads create mode 100644 gcc/ada/libgnat/a-cbhama.adb create mode 100644 gcc/ada/libgnat/a-cbhama.ads create mode 100644 gcc/ada/libgnat/a-cbhase.adb create mode 100644 gcc/ada/libgnat/a-cbhase.ads create mode 100644 gcc/ada/libgnat/a-cbmutr.adb create mode 100644 gcc/ada/libgnat/a-cbmutr.ads create mode 100644 gcc/ada/libgnat/a-cborma.adb create mode 100644 gcc/ada/libgnat/a-cborma.ads create mode 100644 gcc/ada/libgnat/a-cborse.adb create mode 100644 gcc/ada/libgnat/a-cborse.ads create mode 100644 gcc/ada/libgnat/a-cbprqu.adb create mode 100644 gcc/ada/libgnat/a-cbprqu.ads create mode 100644 gcc/ada/libgnat/a-cbsyqu.adb create mode 100644 gcc/ada/libgnat/a-cbsyqu.ads create mode 100644 gcc/ada/libgnat/a-cdlili.adb create mode 100644 gcc/ada/libgnat/a-cdlili.ads create mode 100644 gcc/ada/libgnat/a-cfdlli.adb create mode 100644 gcc/ada/libgnat/a-cfdlli.ads create mode 100644 gcc/ada/libgnat/a-cfhama.adb create mode 100644 gcc/ada/libgnat/a-cfhama.ads create mode 100644 gcc/ada/libgnat/a-cfhase.adb create mode 100644 gcc/ada/libgnat/a-cfhase.ads create mode 100644 gcc/ada/libgnat/a-cfinve.adb create mode 100644 gcc/ada/libgnat/a-cfinve.ads create mode 100644 gcc/ada/libgnat/a-cforma.adb create mode 100644 gcc/ada/libgnat/a-cforma.ads create mode 100644 gcc/ada/libgnat/a-cforse.adb create mode 100644 gcc/ada/libgnat/a-cforse.ads create mode 100644 gcc/ada/libgnat/a-cgaaso.adb create mode 100644 gcc/ada/libgnat/a-cgaaso.ads create mode 100644 gcc/ada/libgnat/a-cgarso.adb create mode 100644 gcc/ada/libgnat/a-cgarso.ads create mode 100644 gcc/ada/libgnat/a-cgcaso.adb create mode 100644 gcc/ada/libgnat/a-cgcaso.ads create mode 100644 gcc/ada/libgnat/a-chacon.adb create mode 100644 gcc/ada/libgnat/a-chacon.ads create mode 100644 gcc/ada/libgnat/a-chahan.adb create mode 100644 gcc/ada/libgnat/a-chahan.ads create mode 100644 gcc/ada/libgnat/a-charac.ads create mode 100644 gcc/ada/libgnat/a-chlat1.ads create mode 100644 gcc/ada/libgnat/a-chlat9.ads create mode 100644 gcc/ada/libgnat/a-chtgbk.adb create mode 100644 gcc/ada/libgnat/a-chtgbk.ads create mode 100644 gcc/ada/libgnat/a-chtgbo.adb create mode 100644 gcc/ada/libgnat/a-chtgbo.ads create mode 100644 gcc/ada/libgnat/a-chtgke.adb create mode 100644 gcc/ada/libgnat/a-chtgke.ads create mode 100644 gcc/ada/libgnat/a-chtgop.adb create mode 100644 gcc/ada/libgnat/a-chtgop.ads create mode 100644 gcc/ada/libgnat/a-chzla1.ads create mode 100644 gcc/ada/libgnat/a-chzla9.ads create mode 100644 gcc/ada/libgnat/a-cidlli.adb create mode 100644 gcc/ada/libgnat/a-cidlli.ads create mode 100644 gcc/ada/libgnat/a-cihama.adb create mode 100644 gcc/ada/libgnat/a-cihama.ads create mode 100644 gcc/ada/libgnat/a-cihase.adb create mode 100644 gcc/ada/libgnat/a-cihase.ads create mode 100644 gcc/ada/libgnat/a-cimutr.adb create mode 100644 gcc/ada/libgnat/a-cimutr.ads create mode 100644 gcc/ada/libgnat/a-ciorma.adb create mode 100644 gcc/ada/libgnat/a-ciorma.ads create mode 100644 gcc/ada/libgnat/a-ciormu.adb create mode 100644 gcc/ada/libgnat/a-ciormu.ads create mode 100644 gcc/ada/libgnat/a-ciorse.adb create mode 100644 gcc/ada/libgnat/a-ciorse.ads create mode 100644 gcc/ada/libgnat/a-clrefi.adb create mode 100644 gcc/ada/libgnat/a-clrefi.ads create mode 100644 gcc/ada/libgnat/a-coboho.adb create mode 100644 gcc/ada/libgnat/a-coboho.ads create mode 100644 gcc/ada/libgnat/a-cobove.adb create mode 100644 gcc/ada/libgnat/a-cobove.ads create mode 100644 gcc/ada/libgnat/a-cofove.adb create mode 100644 gcc/ada/libgnat/a-cofove.ads create mode 100644 gcc/ada/libgnat/a-cofuba.adb create mode 100644 gcc/ada/libgnat/a-cofuba.ads create mode 100644 gcc/ada/libgnat/a-cofuma.adb create mode 100644 gcc/ada/libgnat/a-cofuma.ads create mode 100644 gcc/ada/libgnat/a-cofuse.adb create mode 100644 gcc/ada/libgnat/a-cofuse.ads create mode 100644 gcc/ada/libgnat/a-cofuve.adb create mode 100644 gcc/ada/libgnat/a-cofuve.ads create mode 100644 gcc/ada/libgnat/a-cogeso.adb create mode 100644 gcc/ada/libgnat/a-cogeso.ads create mode 100644 gcc/ada/libgnat/a-cohama.adb create mode 100644 gcc/ada/libgnat/a-cohama.ads create mode 100644 gcc/ada/libgnat/a-cohase.adb create mode 100644 gcc/ada/libgnat/a-cohase.ads create mode 100644 gcc/ada/libgnat/a-cohata.ads create mode 100644 gcc/ada/libgnat/a-coinho-shared.adb create mode 100644 gcc/ada/libgnat/a-coinho-shared.ads create mode 100644 gcc/ada/libgnat/a-coinho.adb create mode 100644 gcc/ada/libgnat/a-coinho.ads create mode 100644 gcc/ada/libgnat/a-coinve.adb create mode 100644 gcc/ada/libgnat/a-coinve.ads create mode 100644 gcc/ada/libgnat/a-colien.adb create mode 100644 gcc/ada/libgnat/a-colien.ads create mode 100644 gcc/ada/libgnat/a-colire.adb create mode 100644 gcc/ada/libgnat/a-colire.ads create mode 100644 gcc/ada/libgnat/a-comlin.adb create mode 100644 gcc/ada/libgnat/a-comlin.ads create mode 100644 gcc/ada/libgnat/a-comutr.adb create mode 100644 gcc/ada/libgnat/a-comutr.ads create mode 100644 gcc/ada/libgnat/a-conhel.adb create mode 100644 gcc/ada/libgnat/a-conhel.ads create mode 100644 gcc/ada/libgnat/a-contai.ads create mode 100644 gcc/ada/libgnat/a-convec.adb create mode 100644 gcc/ada/libgnat/a-convec.ads create mode 100644 gcc/ada/libgnat/a-coorma.adb create mode 100644 gcc/ada/libgnat/a-coorma.ads create mode 100644 gcc/ada/libgnat/a-coormu.adb create mode 100644 gcc/ada/libgnat/a-coormu.ads create mode 100644 gcc/ada/libgnat/a-coorse.adb create mode 100644 gcc/ada/libgnat/a-coorse.ads create mode 100644 gcc/ada/libgnat/a-coprnu.adb create mode 100644 gcc/ada/libgnat/a-coprnu.ads create mode 100644 gcc/ada/libgnat/a-coteio.ads create mode 100644 gcc/ada/libgnat/a-crbltr.ads create mode 100644 gcc/ada/libgnat/a-crbtgk.adb create mode 100644 gcc/ada/libgnat/a-crbtgk.ads create mode 100644 gcc/ada/libgnat/a-crbtgo.adb create mode 100644 gcc/ada/libgnat/a-crbtgo.ads create mode 100644 gcc/ada/libgnat/a-crdlli.adb create mode 100644 gcc/ada/libgnat/a-crdlli.ads create mode 100644 gcc/ada/libgnat/a-csquin.ads create mode 100644 gcc/ada/libgnat/a-cuprqu.adb create mode 100644 gcc/ada/libgnat/a-cuprqu.ads create mode 100644 gcc/ada/libgnat/a-cusyqu.adb create mode 100644 gcc/ada/libgnat/a-cusyqu.ads create mode 100644 gcc/ada/libgnat/a-cwila1.ads create mode 100644 gcc/ada/libgnat/a-cwila9.ads create mode 100644 gcc/ada/libgnat/a-decima.adb create mode 100644 gcc/ada/libgnat/a-decima.ads create mode 100644 gcc/ada/libgnat/a-dhfina.ads create mode 100644 gcc/ada/libgnat/a-diocst.adb create mode 100644 gcc/ada/libgnat/a-diocst.ads create mode 100644 gcc/ada/libgnat/a-direct.adb create mode 100644 gcc/ada/libgnat/a-direct.ads create mode 100644 gcc/ada/libgnat/a-direio.adb create mode 100644 gcc/ada/libgnat/a-direio.ads create mode 100644 gcc/ada/libgnat/a-dirval-mingw.adb create mode 100644 gcc/ada/libgnat/a-dirval.adb create mode 100644 gcc/ada/libgnat/a-dirval.ads create mode 100644 gcc/ada/libgnat/a-einuoc.adb create mode 100644 gcc/ada/libgnat/a-einuoc.ads create mode 100644 gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb create mode 100644 gcc/ada/libgnat/a-elchha.adb create mode 100644 gcc/ada/libgnat/a-elchha.ads create mode 100644 gcc/ada/libgnat/a-envvar.adb create mode 100644 gcc/ada/libgnat/a-envvar.ads create mode 100644 gcc/ada/libgnat/a-excach.adb create mode 100644 gcc/ada/libgnat/a-except.adb create mode 100644 gcc/ada/libgnat/a-except.ads create mode 100644 gcc/ada/libgnat/a-excpol-abort.adb create mode 100644 gcc/ada/libgnat/a-excpol.adb create mode 100644 gcc/ada/libgnat/a-exctra.adb create mode 100644 gcc/ada/libgnat/a-exctra.ads create mode 100644 gcc/ada/libgnat/a-exexda.adb create mode 100644 gcc/ada/libgnat/a-exexpr.adb create mode 100644 gcc/ada/libgnat/a-exextr.adb create mode 100644 gcc/ada/libgnat/a-exstat.adb create mode 100644 gcc/ada/libgnat/a-finali.adb create mode 100644 gcc/ada/libgnat/a-finali.ads create mode 100644 gcc/ada/libgnat/a-flteio.ads create mode 100644 gcc/ada/libgnat/a-fwteio.ads create mode 100644 gcc/ada/libgnat/a-fzteio.ads create mode 100644 gcc/ada/libgnat/a-inteio.ads create mode 100644 gcc/ada/libgnat/a-ioexce.ads create mode 100644 gcc/ada/libgnat/a-iteint.ads create mode 100644 gcc/ada/libgnat/a-iwteio.ads create mode 100644 gcc/ada/libgnat/a-izteio.ads create mode 100644 gcc/ada/libgnat/a-lcteio.ads create mode 100644 gcc/ada/libgnat/a-lfteio.ads create mode 100644 gcc/ada/libgnat/a-lfwtio.ads create mode 100644 gcc/ada/libgnat/a-lfztio.ads create mode 100644 gcc/ada/libgnat/a-liteio.ads create mode 100644 gcc/ada/libgnat/a-liwtio.ads create mode 100644 gcc/ada/libgnat/a-liztio.ads create mode 100644 gcc/ada/libgnat/a-llctio.ads create mode 100644 gcc/ada/libgnat/a-llftio.ads create mode 100644 gcc/ada/libgnat/a-llfwti.ads create mode 100644 gcc/ada/libgnat/a-llfzti.ads create mode 100644 gcc/ada/libgnat/a-llitio.ads create mode 100644 gcc/ada/libgnat/a-lliwti.ads create mode 100644 gcc/ada/libgnat/a-llizti.ads create mode 100644 gcc/ada/libgnat/a-locale.adb create mode 100644 gcc/ada/libgnat/a-locale.ads create mode 100644 gcc/ada/libgnat/a-ncelfu.ads create mode 100644 gcc/ada/libgnat/a-ngcefu.adb create mode 100644 gcc/ada/libgnat/a-ngcefu.ads create mode 100644 gcc/ada/libgnat/a-ngcoar.adb create mode 100644 gcc/ada/libgnat/a-ngcoar.ads create mode 100644 gcc/ada/libgnat/a-ngcoty.adb create mode 100644 gcc/ada/libgnat/a-ngcoty.ads create mode 100644 gcc/ada/libgnat/a-ngelfu.adb create mode 100644 gcc/ada/libgnat/a-ngelfu.ads create mode 100644 gcc/ada/libgnat/a-ngrear.adb create mode 100644 gcc/ada/libgnat/a-ngrear.ads create mode 100644 gcc/ada/libgnat/a-nlcefu.ads create mode 100644 gcc/ada/libgnat/a-nlcoar.ads create mode 100644 gcc/ada/libgnat/a-nlcoty.ads create mode 100644 gcc/ada/libgnat/a-nlelfu.ads create mode 100644 gcc/ada/libgnat/a-nllcar.ads create mode 100644 gcc/ada/libgnat/a-nllcef.ads create mode 100644 gcc/ada/libgnat/a-nllcty.ads create mode 100644 gcc/ada/libgnat/a-nllefu.ads create mode 100644 gcc/ada/libgnat/a-nllrar.ads create mode 100644 gcc/ada/libgnat/a-nlrear.ads create mode 100644 gcc/ada/libgnat/a-nscefu.ads create mode 100644 gcc/ada/libgnat/a-nscoty.ads create mode 100644 gcc/ada/libgnat/a-nselfu.ads create mode 100644 gcc/ada/libgnat/a-nucoar.ads create mode 100644 gcc/ada/libgnat/a-nucoty.ads create mode 100644 gcc/ada/libgnat/a-nudira.adb create mode 100644 gcc/ada/libgnat/a-nudira.ads create mode 100644 gcc/ada/libgnat/a-nuelfu.ads create mode 100644 gcc/ada/libgnat/a-nuflra.adb create mode 100644 gcc/ada/libgnat/a-nuflra.ads create mode 100644 gcc/ada/libgnat/a-numaux-darwin.adb create mode 100644 gcc/ada/libgnat/a-numaux-darwin.ads create mode 100644 gcc/ada/libgnat/a-numaux-libc-x86.ads create mode 100644 gcc/ada/libgnat/a-numaux-vxworks.ads create mode 100644 gcc/ada/libgnat/a-numaux-x86.adb create mode 100644 gcc/ada/libgnat/a-numaux-x86.ads create mode 100644 gcc/ada/libgnat/a-numaux.ads create mode 100644 gcc/ada/libgnat/a-numeri.ads create mode 100644 gcc/ada/libgnat/a-nurear.ads create mode 100644 gcc/ada/libgnat/a-rbtgbk.adb create mode 100644 gcc/ada/libgnat/a-rbtgbk.ads create mode 100644 gcc/ada/libgnat/a-rbtgbo.adb create mode 100644 gcc/ada/libgnat/a-rbtgbo.ads create mode 100644 gcc/ada/libgnat/a-rbtgso.adb create mode 100644 gcc/ada/libgnat/a-rbtgso.ads create mode 100644 gcc/ada/libgnat/a-sbecin.adb create mode 100644 gcc/ada/libgnat/a-sbecin.ads create mode 100644 gcc/ada/libgnat/a-sbhcin.adb create mode 100644 gcc/ada/libgnat/a-sbhcin.ads create mode 100644 gcc/ada/libgnat/a-sblcin.adb create mode 100644 gcc/ada/libgnat/a-sblcin.ads create mode 100644 gcc/ada/libgnat/a-scteio.ads create mode 100644 gcc/ada/libgnat/a-secain.adb create mode 100644 gcc/ada/libgnat/a-secain.ads create mode 100644 gcc/ada/libgnat/a-sequio.adb create mode 100644 gcc/ada/libgnat/a-sequio.ads create mode 100644 gcc/ada/libgnat/a-sfecin.ads create mode 100644 gcc/ada/libgnat/a-sfhcin.ads create mode 100644 gcc/ada/libgnat/a-sflcin.ads create mode 100644 gcc/ada/libgnat/a-sfteio.ads create mode 100644 gcc/ada/libgnat/a-sfwtio.ads create mode 100644 gcc/ada/libgnat/a-sfztio.ads create mode 100644 gcc/ada/libgnat/a-shcain.adb create mode 100644 gcc/ada/libgnat/a-shcain.ads create mode 100644 gcc/ada/libgnat/a-siocst.adb create mode 100644 gcc/ada/libgnat/a-siocst.ads create mode 100644 gcc/ada/libgnat/a-siteio.ads create mode 100644 gcc/ada/libgnat/a-siwtio.ads create mode 100644 gcc/ada/libgnat/a-siztio.ads create mode 100644 gcc/ada/libgnat/a-slcain.adb create mode 100644 gcc/ada/libgnat/a-slcain.ads create mode 100644 gcc/ada/libgnat/a-ssicst.adb create mode 100644 gcc/ada/libgnat/a-ssicst.ads create mode 100644 gcc/ada/libgnat/a-ssitio.ads create mode 100644 gcc/ada/libgnat/a-ssiwti.ads create mode 100644 gcc/ada/libgnat/a-ssizti.ads create mode 100644 gcc/ada/libgnat/a-stboha.adb create mode 100644 gcc/ada/libgnat/a-stboha.ads create mode 100644 gcc/ada/libgnat/a-stfiha.ads create mode 100644 gcc/ada/libgnat/a-stmaco.ads create mode 100644 gcc/ada/libgnat/a-storio.adb create mode 100644 gcc/ada/libgnat/a-storio.ads create mode 100644 gcc/ada/libgnat/a-strbou.adb create mode 100644 gcc/ada/libgnat/a-strbou.ads create mode 100644 gcc/ada/libgnat/a-stream.adb create mode 100644 gcc/ada/libgnat/a-stream.ads create mode 100644 gcc/ada/libgnat/a-strfix.adb create mode 100644 gcc/ada/libgnat/a-strfix.ads create mode 100644 gcc/ada/libgnat/a-strhas.adb create mode 100644 gcc/ada/libgnat/a-strhas.ads create mode 100644 gcc/ada/libgnat/a-string.ads create mode 100644 gcc/ada/libgnat/a-strmap.adb create mode 100644 gcc/ada/libgnat/a-strmap.ads create mode 100644 gcc/ada/libgnat/a-strsea.adb create mode 100644 gcc/ada/libgnat/a-strsea.ads create mode 100644 gcc/ada/libgnat/a-strsup.adb create mode 100644 gcc/ada/libgnat/a-strsup.ads create mode 100644 gcc/ada/libgnat/a-strunb-shared.adb create mode 100644 gcc/ada/libgnat/a-strunb-shared.ads create mode 100644 gcc/ada/libgnat/a-strunb.adb create mode 100644 gcc/ada/libgnat/a-strunb.ads create mode 100644 gcc/ada/libgnat/a-ststio.adb create mode 100644 gcc/ada/libgnat/a-ststio.ads create mode 100644 gcc/ada/libgnat/a-stunau-shared.adb create mode 100644 gcc/ada/libgnat/a-stunau.adb create mode 100644 gcc/ada/libgnat/a-stunau.ads create mode 100644 gcc/ada/libgnat/a-stunha.adb create mode 100644 gcc/ada/libgnat/a-stunha.ads create mode 100644 gcc/ada/libgnat/a-stuten.adb create mode 100644 gcc/ada/libgnat/a-stuten.ads create mode 100644 gcc/ada/libgnat/a-stwibo.adb create mode 100644 gcc/ada/libgnat/a-stwibo.ads create mode 100644 gcc/ada/libgnat/a-stwifi.adb create mode 100644 gcc/ada/libgnat/a-stwifi.ads create mode 100644 gcc/ada/libgnat/a-stwiha.adb create mode 100644 gcc/ada/libgnat/a-stwiha.ads create mode 100644 gcc/ada/libgnat/a-stwima.adb create mode 100644 gcc/ada/libgnat/a-stwima.ads create mode 100644 gcc/ada/libgnat/a-stwise.adb create mode 100644 gcc/ada/libgnat/a-stwise.ads create mode 100644 gcc/ada/libgnat/a-stwisu.adb create mode 100644 gcc/ada/libgnat/a-stwisu.ads create mode 100644 gcc/ada/libgnat/a-stwiun-shared.adb create mode 100644 gcc/ada/libgnat/a-stwiun-shared.ads create mode 100644 gcc/ada/libgnat/a-stwiun.adb create mode 100644 gcc/ada/libgnat/a-stwiun.ads create mode 100644 gcc/ada/libgnat/a-stzbou.adb create mode 100644 gcc/ada/libgnat/a-stzbou.ads create mode 100644 gcc/ada/libgnat/a-stzfix.adb create mode 100644 gcc/ada/libgnat/a-stzfix.ads create mode 100644 gcc/ada/libgnat/a-stzhas.adb create mode 100644 gcc/ada/libgnat/a-stzhas.ads create mode 100644 gcc/ada/libgnat/a-stzmap.adb create mode 100644 gcc/ada/libgnat/a-stzmap.ads create mode 100644 gcc/ada/libgnat/a-stzsea.adb create mode 100644 gcc/ada/libgnat/a-stzsea.ads create mode 100644 gcc/ada/libgnat/a-stzsup.adb create mode 100644 gcc/ada/libgnat/a-stzsup.ads create mode 100644 gcc/ada/libgnat/a-stzunb-shared.adb create mode 100644 gcc/ada/libgnat/a-stzunb-shared.ads create mode 100644 gcc/ada/libgnat/a-stzunb.adb create mode 100644 gcc/ada/libgnat/a-stzunb.ads create mode 100644 gcc/ada/libgnat/a-suecin.adb create mode 100644 gcc/ada/libgnat/a-suecin.ads create mode 100644 gcc/ada/libgnat/a-suenco.adb create mode 100644 gcc/ada/libgnat/a-suenco.ads create mode 100644 gcc/ada/libgnat/a-suenst.adb create mode 100644 gcc/ada/libgnat/a-suenst.ads create mode 100644 gcc/ada/libgnat/a-suewst.adb create mode 100644 gcc/ada/libgnat/a-suewst.ads create mode 100644 gcc/ada/libgnat/a-suezst.adb create mode 100644 gcc/ada/libgnat/a-suezst.ads create mode 100644 gcc/ada/libgnat/a-suhcin.adb create mode 100644 gcc/ada/libgnat/a-suhcin.ads create mode 100644 gcc/ada/libgnat/a-sulcin.adb create mode 100644 gcc/ada/libgnat/a-sulcin.ads create mode 100644 gcc/ada/libgnat/a-suteio-shared.adb create mode 100644 gcc/ada/libgnat/a-suteio.adb create mode 100644 gcc/ada/libgnat/a-suteio.ads create mode 100644 gcc/ada/libgnat/a-swbwha.adb create mode 100644 gcc/ada/libgnat/a-swbwha.ads create mode 100644 gcc/ada/libgnat/a-swfwha.ads create mode 100644 gcc/ada/libgnat/a-swmwco.ads create mode 100644 gcc/ada/libgnat/a-swunau-shared.adb create mode 100644 gcc/ada/libgnat/a-swunau.adb create mode 100644 gcc/ada/libgnat/a-swunau.ads create mode 100644 gcc/ada/libgnat/a-swuwha.adb create mode 100644 gcc/ada/libgnat/a-swuwha.ads create mode 100644 gcc/ada/libgnat/a-swuwti-shared.adb create mode 100644 gcc/ada/libgnat/a-swuwti.adb create mode 100644 gcc/ada/libgnat/a-swuwti.ads create mode 100644 gcc/ada/libgnat/a-szbzha.adb create mode 100644 gcc/ada/libgnat/a-szbzha.ads create mode 100644 gcc/ada/libgnat/a-szfzha.ads create mode 100644 gcc/ada/libgnat/a-szmzco.ads create mode 100644 gcc/ada/libgnat/a-szunau-shared.adb create mode 100644 gcc/ada/libgnat/a-szunau.adb create mode 100644 gcc/ada/libgnat/a-szunau.ads create mode 100644 gcc/ada/libgnat/a-szuzha.adb create mode 100644 gcc/ada/libgnat/a-szuzha.ads create mode 100644 gcc/ada/libgnat/a-szuzti-shared.adb create mode 100644 gcc/ada/libgnat/a-szuzti.adb create mode 100644 gcc/ada/libgnat/a-szuzti.ads create mode 100644 gcc/ada/libgnat/a-tags.adb create mode 100644 gcc/ada/libgnat/a-tags.ads create mode 100644 gcc/ada/libgnat/a-teioed.adb create mode 100644 gcc/ada/libgnat/a-teioed.ads create mode 100644 gcc/ada/libgnat/a-textio.adb create mode 100644 gcc/ada/libgnat/a-textio.ads create mode 100644 gcc/ada/libgnat/a-tgdico.ads create mode 100644 gcc/ada/libgnat/a-tiboio.adb create mode 100644 gcc/ada/libgnat/a-tiboio.ads create mode 100644 gcc/ada/libgnat/a-ticoau.adb create mode 100644 gcc/ada/libgnat/a-ticoau.ads create mode 100644 gcc/ada/libgnat/a-ticoio.adb create mode 100644 gcc/ada/libgnat/a-ticoio.ads create mode 100644 gcc/ada/libgnat/a-tideau.adb create mode 100644 gcc/ada/libgnat/a-tideau.ads create mode 100644 gcc/ada/libgnat/a-tideio.adb create mode 100644 gcc/ada/libgnat/a-tideio.ads create mode 100644 gcc/ada/libgnat/a-tienau.adb create mode 100644 gcc/ada/libgnat/a-tienau.ads create mode 100644 gcc/ada/libgnat/a-tienio.adb create mode 100644 gcc/ada/libgnat/a-tienio.ads create mode 100644 gcc/ada/libgnat/a-tifiio.adb create mode 100644 gcc/ada/libgnat/a-tifiio.ads create mode 100644 gcc/ada/libgnat/a-tiflau.adb create mode 100644 gcc/ada/libgnat/a-tiflau.ads create mode 100644 gcc/ada/libgnat/a-tiflio.adb create mode 100644 gcc/ada/libgnat/a-tiflio.ads create mode 100644 gcc/ada/libgnat/a-tigeau.adb create mode 100644 gcc/ada/libgnat/a-tigeau.ads create mode 100644 gcc/ada/libgnat/a-tigeli.adb create mode 100644 gcc/ada/libgnat/a-tiinau.adb create mode 100644 gcc/ada/libgnat/a-tiinau.ads create mode 100644 gcc/ada/libgnat/a-tiinio.adb create mode 100644 gcc/ada/libgnat/a-tiinio.ads create mode 100644 gcc/ada/libgnat/a-timoau.adb create mode 100644 gcc/ada/libgnat/a-timoau.ads create mode 100644 gcc/ada/libgnat/a-timoio.adb create mode 100644 gcc/ada/libgnat/a-timoio.ads create mode 100644 gcc/ada/libgnat/a-tiocst.adb create mode 100644 gcc/ada/libgnat/a-tiocst.ads create mode 100644 gcc/ada/libgnat/a-tirsfi.adb create mode 100644 gcc/ada/libgnat/a-tirsfi.ads create mode 100644 gcc/ada/libgnat/a-titest.adb create mode 100644 gcc/ada/libgnat/a-titest.ads create mode 100644 gcc/ada/libgnat/a-tiunio.ads create mode 100644 gcc/ada/libgnat/a-unccon.ads create mode 100644 gcc/ada/libgnat/a-uncdea.ads create mode 100644 gcc/ada/libgnat/a-undesu.adb create mode 100644 gcc/ada/libgnat/a-undesu.ads create mode 100644 gcc/ada/libgnat/a-wichha.adb create mode 100644 gcc/ada/libgnat/a-wichha.ads create mode 100644 gcc/ada/libgnat/a-wichun.adb create mode 100644 gcc/ada/libgnat/a-wichun.ads create mode 100644 gcc/ada/libgnat/a-widcha.ads create mode 100644 gcc/ada/libgnat/a-witeio.adb create mode 100644 gcc/ada/libgnat/a-witeio.ads create mode 100644 gcc/ada/libgnat/a-wrstfi.adb create mode 100644 gcc/ada/libgnat/a-wrstfi.ads create mode 100644 gcc/ada/libgnat/a-wtcoau.adb create mode 100644 gcc/ada/libgnat/a-wtcoau.ads create mode 100644 gcc/ada/libgnat/a-wtcoio.adb create mode 100644 gcc/ada/libgnat/a-wtcoio.ads create mode 100644 gcc/ada/libgnat/a-wtcstr.adb create mode 100644 gcc/ada/libgnat/a-wtcstr.ads create mode 100644 gcc/ada/libgnat/a-wtdeau.adb create mode 100644 gcc/ada/libgnat/a-wtdeau.ads create mode 100644 gcc/ada/libgnat/a-wtdeio.adb create mode 100644 gcc/ada/libgnat/a-wtdeio.ads create mode 100644 gcc/ada/libgnat/a-wtedit.adb create mode 100644 gcc/ada/libgnat/a-wtedit.ads create mode 100644 gcc/ada/libgnat/a-wtenau.adb create mode 100644 gcc/ada/libgnat/a-wtenau.ads create mode 100644 gcc/ada/libgnat/a-wtenio.adb create mode 100644 gcc/ada/libgnat/a-wtenio.ads create mode 100644 gcc/ada/libgnat/a-wtfiio.adb create mode 100644 gcc/ada/libgnat/a-wtfiio.ads create mode 100644 gcc/ada/libgnat/a-wtflau.adb create mode 100644 gcc/ada/libgnat/a-wtflau.ads create mode 100644 gcc/ada/libgnat/a-wtflio.adb create mode 100644 gcc/ada/libgnat/a-wtflio.ads create mode 100644 gcc/ada/libgnat/a-wtgeau.adb create mode 100644 gcc/ada/libgnat/a-wtgeau.ads create mode 100644 gcc/ada/libgnat/a-wtinau.adb create mode 100644 gcc/ada/libgnat/a-wtinau.ads create mode 100644 gcc/ada/libgnat/a-wtinio.adb create mode 100644 gcc/ada/libgnat/a-wtinio.ads create mode 100644 gcc/ada/libgnat/a-wtmoau.adb create mode 100644 gcc/ada/libgnat/a-wtmoau.ads create mode 100644 gcc/ada/libgnat/a-wtmoio.adb create mode 100644 gcc/ada/libgnat/a-wtmoio.ads create mode 100644 gcc/ada/libgnat/a-wttest.adb create mode 100644 gcc/ada/libgnat/a-wttest.ads create mode 100644 gcc/ada/libgnat/a-wwboio.adb create mode 100644 gcc/ada/libgnat/a-wwboio.ads create mode 100644 gcc/ada/libgnat/a-wwunio.ads create mode 100644 gcc/ada/libgnat/a-zchara.ads create mode 100644 gcc/ada/libgnat/a-zchhan.adb create mode 100644 gcc/ada/libgnat/a-zchhan.ads create mode 100644 gcc/ada/libgnat/a-zchuni.adb create mode 100644 gcc/ada/libgnat/a-zchuni.ads create mode 100644 gcc/ada/libgnat/a-zrstfi.adb create mode 100644 gcc/ada/libgnat/a-zrstfi.ads create mode 100644 gcc/ada/libgnat/a-ztcoau.adb create mode 100644 gcc/ada/libgnat/a-ztcoau.ads create mode 100644 gcc/ada/libgnat/a-ztcoio.adb create mode 100644 gcc/ada/libgnat/a-ztcoio.ads create mode 100644 gcc/ada/libgnat/a-ztcstr.adb create mode 100644 gcc/ada/libgnat/a-ztcstr.ads create mode 100644 gcc/ada/libgnat/a-ztdeau.adb create mode 100644 gcc/ada/libgnat/a-ztdeau.ads create mode 100644 gcc/ada/libgnat/a-ztdeio.adb create mode 100644 gcc/ada/libgnat/a-ztdeio.ads create mode 100644 gcc/ada/libgnat/a-ztedit.adb create mode 100644 gcc/ada/libgnat/a-ztedit.ads create mode 100644 gcc/ada/libgnat/a-ztenau.adb create mode 100644 gcc/ada/libgnat/a-ztenau.ads create mode 100644 gcc/ada/libgnat/a-ztenio.adb create mode 100644 gcc/ada/libgnat/a-ztenio.ads create mode 100644 gcc/ada/libgnat/a-ztexio.adb create mode 100644 gcc/ada/libgnat/a-ztexio.ads create mode 100644 gcc/ada/libgnat/a-ztfiio.adb create mode 100644 gcc/ada/libgnat/a-ztfiio.ads create mode 100644 gcc/ada/libgnat/a-ztflau.adb create mode 100644 gcc/ada/libgnat/a-ztflau.ads create mode 100644 gcc/ada/libgnat/a-ztflio.adb create mode 100644 gcc/ada/libgnat/a-ztflio.ads create mode 100644 gcc/ada/libgnat/a-ztgeau.adb create mode 100644 gcc/ada/libgnat/a-ztgeau.ads create mode 100644 gcc/ada/libgnat/a-ztinau.adb create mode 100644 gcc/ada/libgnat/a-ztinau.ads create mode 100644 gcc/ada/libgnat/a-ztinio.adb create mode 100644 gcc/ada/libgnat/a-ztinio.ads create mode 100644 gcc/ada/libgnat/a-ztmoau.adb create mode 100644 gcc/ada/libgnat/a-ztmoau.ads create mode 100644 gcc/ada/libgnat/a-ztmoio.adb create mode 100644 gcc/ada/libgnat/a-ztmoio.ads create mode 100644 gcc/ada/libgnat/a-zttest.adb create mode 100644 gcc/ada/libgnat/a-zttest.ads create mode 100644 gcc/ada/libgnat/a-zzboio.adb create mode 100644 gcc/ada/libgnat/a-zzboio.ads create mode 100644 gcc/ada/libgnat/a-zzunio.ads create mode 100644 gcc/ada/libgnat/ada.ads create mode 100644 gcc/ada/libgnat/calendar.ads create mode 100644 gcc/ada/libgnat/directio.ads create mode 100644 gcc/ada/libgnat/g-allein.ads create mode 100644 gcc/ada/libgnat/g-alleve-hard.adb create mode 100644 gcc/ada/libgnat/g-alleve-hard.ads create mode 100644 gcc/ada/libgnat/g-alleve.adb create mode 100644 gcc/ada/libgnat/g-alleve.ads create mode 100644 gcc/ada/libgnat/g-altcon.adb create mode 100644 gcc/ada/libgnat/g-altcon.ads create mode 100644 gcc/ada/libgnat/g-altive.ads create mode 100644 gcc/ada/libgnat/g-alveop.adb create mode 100644 gcc/ada/libgnat/g-alveop.ads create mode 100644 gcc/ada/libgnat/g-alvety.ads create mode 100644 gcc/ada/libgnat/g-alvevi.ads create mode 100644 gcc/ada/libgnat/g-arrspl.adb create mode 100644 gcc/ada/libgnat/g-arrspl.ads create mode 100644 gcc/ada/libgnat/g-awk.adb create mode 100644 gcc/ada/libgnat/g-awk.ads create mode 100644 gcc/ada/libgnat/g-binenv.adb create mode 100644 gcc/ada/libgnat/g-binenv.ads create mode 100644 gcc/ada/libgnat/g-bubsor.adb create mode 100644 gcc/ada/libgnat/g-bubsor.ads create mode 100644 gcc/ada/libgnat/g-busora.adb create mode 100644 gcc/ada/libgnat/g-busora.ads create mode 100644 gcc/ada/libgnat/g-busorg.adb create mode 100644 gcc/ada/libgnat/g-busorg.ads create mode 100644 gcc/ada/libgnat/g-byorma.adb create mode 100644 gcc/ada/libgnat/g-byorma.ads create mode 100644 gcc/ada/libgnat/g-bytswa.adb create mode 100644 gcc/ada/libgnat/g-bytswa.ads create mode 100644 gcc/ada/libgnat/g-calend.adb create mode 100644 gcc/ada/libgnat/g-calend.ads create mode 100644 gcc/ada/libgnat/g-casuti.adb create mode 100644 gcc/ada/libgnat/g-casuti.ads create mode 100644 gcc/ada/libgnat/g-catiio.adb create mode 100644 gcc/ada/libgnat/g-catiio.ads create mode 100644 gcc/ada/libgnat/g-cgi.adb create mode 100644 gcc/ada/libgnat/g-cgi.ads create mode 100644 gcc/ada/libgnat/g-cgicoo.adb create mode 100644 gcc/ada/libgnat/g-cgicoo.ads create mode 100644 gcc/ada/libgnat/g-cgideb.adb create mode 100644 gcc/ada/libgnat/g-cgideb.ads create mode 100644 gcc/ada/libgnat/g-comlin.adb create mode 100644 gcc/ada/libgnat/g-comlin.ads create mode 100644 gcc/ada/libgnat/g-comver.adb create mode 100644 gcc/ada/libgnat/g-comver.ads create mode 100644 gcc/ada/libgnat/g-cppexc.adb create mode 100644 gcc/ada/libgnat/g-cppexc.ads create mode 100644 gcc/ada/libgnat/g-crc32.adb create mode 100644 gcc/ada/libgnat/g-crc32.ads create mode 100644 gcc/ada/libgnat/g-ctrl_c.adb create mode 100644 gcc/ada/libgnat/g-ctrl_c.ads create mode 100644 gcc/ada/libgnat/g-curexc.ads create mode 100644 gcc/ada/libgnat/g-debpoo.adb create mode 100644 gcc/ada/libgnat/g-debpoo.ads create mode 100644 gcc/ada/libgnat/g-debuti.adb create mode 100644 gcc/ada/libgnat/g-debuti.ads create mode 100644 gcc/ada/libgnat/g-decstr.adb create mode 100644 gcc/ada/libgnat/g-decstr.ads create mode 100644 gcc/ada/libgnat/g-deutst.ads create mode 100644 gcc/ada/libgnat/g-diopit.adb create mode 100644 gcc/ada/libgnat/g-diopit.ads create mode 100644 gcc/ada/libgnat/g-dirope.adb create mode 100644 gcc/ada/libgnat/g-dirope.ads create mode 100644 gcc/ada/libgnat/g-dynhta.adb create mode 100644 gcc/ada/libgnat/g-dynhta.ads create mode 100644 gcc/ada/libgnat/g-dyntab.adb create mode 100644 gcc/ada/libgnat/g-dyntab.ads create mode 100644 gcc/ada/libgnat/g-eacodu.adb create mode 100644 gcc/ada/libgnat/g-encstr.adb create mode 100644 gcc/ada/libgnat/g-encstr.ads create mode 100644 gcc/ada/libgnat/g-enutst.ads create mode 100644 gcc/ada/libgnat/g-excact.adb create mode 100644 gcc/ada/libgnat/g-excact.ads create mode 100644 gcc/ada/libgnat/g-except.ads create mode 100644 gcc/ada/libgnat/g-exctra.adb create mode 100644 gcc/ada/libgnat/g-exctra.ads create mode 100644 gcc/ada/libgnat/g-expect.adb create mode 100644 gcc/ada/libgnat/g-expect.ads create mode 100644 gcc/ada/libgnat/g-exptty.adb create mode 100644 gcc/ada/libgnat/g-exptty.ads create mode 100644 gcc/ada/libgnat/g-flocon.ads create mode 100644 gcc/ada/libgnat/g-forstr.adb create mode 100644 gcc/ada/libgnat/g-forstr.ads create mode 100644 gcc/ada/libgnat/g-heasor.adb create mode 100644 gcc/ada/libgnat/g-heasor.ads create mode 100644 gcc/ada/libgnat/g-hesora.adb create mode 100644 gcc/ada/libgnat/g-hesora.ads create mode 100644 gcc/ada/libgnat/g-hesorg.adb create mode 100644 gcc/ada/libgnat/g-hesorg.ads create mode 100644 gcc/ada/libgnat/g-htable.adb create mode 100644 gcc/ada/libgnat/g-htable.ads create mode 100644 gcc/ada/libgnat/g-io-put-vxworks.adb create mode 100644 gcc/ada/libgnat/g-io.adb create mode 100644 gcc/ada/libgnat/g-io.ads create mode 100644 gcc/ada/libgnat/g-io_aux.adb create mode 100644 gcc/ada/libgnat/g-io_aux.ads create mode 100644 gcc/ada/libgnat/g-locfil.adb create mode 100644 gcc/ada/libgnat/g-locfil.ads create mode 100644 gcc/ada/libgnat/g-mbdira.adb create mode 100644 gcc/ada/libgnat/g-mbdira.ads create mode 100644 gcc/ada/libgnat/g-mbflra.adb create mode 100644 gcc/ada/libgnat/g-mbflra.ads create mode 100644 gcc/ada/libgnat/g-md5.adb create mode 100644 gcc/ada/libgnat/g-md5.ads create mode 100644 gcc/ada/libgnat/g-memdum.adb create mode 100644 gcc/ada/libgnat/g-memdum.ads create mode 100644 gcc/ada/libgnat/g-moreex.adb create mode 100644 gcc/ada/libgnat/g-moreex.ads create mode 100644 gcc/ada/libgnat/g-os_lib.adb create mode 100644 gcc/ada/libgnat/g-os_lib.ads create mode 100644 gcc/ada/libgnat/g-pehage.adb create mode 100644 gcc/ada/libgnat/g-pehage.ads create mode 100644 gcc/ada/libgnat/g-rannum.adb create mode 100644 gcc/ada/libgnat/g-rannum.ads create mode 100644 gcc/ada/libgnat/g-regexp.adb create mode 100644 gcc/ada/libgnat/g-regexp.ads create mode 100644 gcc/ada/libgnat/g-regist.adb create mode 100644 gcc/ada/libgnat/g-regist.ads create mode 100644 gcc/ada/libgnat/g-regpat.adb create mode 100644 gcc/ada/libgnat/g-regpat.ads create mode 100644 gcc/ada/libgnat/g-rewdat.adb create mode 100644 gcc/ada/libgnat/g-rewdat.ads create mode 100644 gcc/ada/libgnat/g-sechas.adb create mode 100644 gcc/ada/libgnat/g-sechas.ads create mode 100644 gcc/ada/libgnat/g-sehamd.adb create mode 100644 gcc/ada/libgnat/g-sehamd.ads create mode 100644 gcc/ada/libgnat/g-sehash.adb create mode 100644 gcc/ada/libgnat/g-sehash.ads create mode 100644 gcc/ada/libgnat/g-sercom-linux.adb create mode 100644 gcc/ada/libgnat/g-sercom-mingw.adb create mode 100644 gcc/ada/libgnat/g-sercom.adb create mode 100644 gcc/ada/libgnat/g-sercom.ads create mode 100644 gcc/ada/libgnat/g-sestin.ads create mode 100644 gcc/ada/libgnat/g-sha1.adb create mode 100644 gcc/ada/libgnat/g-sha1.ads create mode 100644 gcc/ada/libgnat/g-sha224.ads create mode 100644 gcc/ada/libgnat/g-sha256.ads create mode 100644 gcc/ada/libgnat/g-sha384.ads create mode 100644 gcc/ada/libgnat/g-sha512.ads create mode 100644 gcc/ada/libgnat/g-shsh32.adb create mode 100644 gcc/ada/libgnat/g-shsh32.ads create mode 100644 gcc/ada/libgnat/g-shsh64.adb create mode 100644 gcc/ada/libgnat/g-shsh64.ads create mode 100644 gcc/ada/libgnat/g-shshco.adb create mode 100644 gcc/ada/libgnat/g-shshco.ads create mode 100644 gcc/ada/libgnat/g-soccon.ads create mode 100644 gcc/ada/libgnat/g-socket-dummy.adb create mode 100644 gcc/ada/libgnat/g-socket-dummy.ads create mode 100644 gcc/ada/libgnat/g-socket.adb create mode 100644 gcc/ada/libgnat/g-socket.ads create mode 100644 gcc/ada/libgnat/g-socthi-dummy.adb create mode 100644 gcc/ada/libgnat/g-socthi-dummy.ads create mode 100644 gcc/ada/libgnat/g-socthi-mingw.adb create mode 100644 gcc/ada/libgnat/g-socthi-mingw.ads create mode 100644 gcc/ada/libgnat/g-socthi-vxworks.adb create mode 100644 gcc/ada/libgnat/g-socthi-vxworks.ads create mode 100644 gcc/ada/libgnat/g-socthi.adb create mode 100644 gcc/ada/libgnat/g-socthi.ads create mode 100644 gcc/ada/libgnat/g-soliop-mingw.ads create mode 100644 gcc/ada/libgnat/g-soliop-solaris.ads create mode 100644 gcc/ada/libgnat/g-soliop.ads create mode 100644 gcc/ada/libgnat/g-sothco-dummy.adb create mode 100644 gcc/ada/libgnat/g-sothco-dummy.ads create mode 100644 gcc/ada/libgnat/g-sothco.adb create mode 100644 gcc/ada/libgnat/g-sothco.ads create mode 100644 gcc/ada/libgnat/g-souinf.ads create mode 100644 gcc/ada/libgnat/g-spchge.adb create mode 100644 gcc/ada/libgnat/g-spchge.ads create mode 100644 gcc/ada/libgnat/g-speche.adb create mode 100644 gcc/ada/libgnat/g-speche.ads create mode 100644 gcc/ada/libgnat/g-spipat.adb create mode 100644 gcc/ada/libgnat/g-spipat.ads create mode 100644 gcc/ada/libgnat/g-spitbo.adb create mode 100644 gcc/ada/libgnat/g-spitbo.ads create mode 100644 gcc/ada/libgnat/g-sptabo.ads create mode 100644 gcc/ada/libgnat/g-sptain.ads create mode 100644 gcc/ada/libgnat/g-sptavs.ads create mode 100644 gcc/ada/libgnat/g-sse.ads create mode 100644 gcc/ada/libgnat/g-ssvety.ads create mode 100644 gcc/ada/libgnat/g-stheme.adb create mode 100644 gcc/ada/libgnat/g-strhas.ads create mode 100644 gcc/ada/libgnat/g-string.adb create mode 100644 gcc/ada/libgnat/g-string.ads create mode 100644 gcc/ada/libgnat/g-strspl.ads create mode 100644 gcc/ada/libgnat/g-stseme.adb create mode 100644 gcc/ada/libgnat/g-stsifd-sockets.adb create mode 100644 gcc/ada/libgnat/g-table.adb create mode 100644 gcc/ada/libgnat/g-table.ads create mode 100644 gcc/ada/libgnat/g-tasloc.adb create mode 100644 gcc/ada/libgnat/g-tasloc.ads create mode 100644 gcc/ada/libgnat/g-timsta.adb create mode 100644 gcc/ada/libgnat/g-timsta.ads create mode 100644 gcc/ada/libgnat/g-traceb.adb create mode 100644 gcc/ada/libgnat/g-traceb.ads create mode 100644 gcc/ada/libgnat/g-trasym.adb create mode 100644 gcc/ada/libgnat/g-trasym.ads create mode 100644 gcc/ada/libgnat/g-tty.adb create mode 100644 gcc/ada/libgnat/g-tty.ads create mode 100644 gcc/ada/libgnat/g-u3spch.adb create mode 100644 gcc/ada/libgnat/g-u3spch.ads create mode 100644 gcc/ada/libgnat/g-utf_32.adb create mode 100644 gcc/ada/libgnat/g-utf_32.ads create mode 100644 gcc/ada/libgnat/g-wispch.adb create mode 100644 gcc/ada/libgnat/g-wispch.ads create mode 100644 gcc/ada/libgnat/g-wistsp.ads create mode 100644 gcc/ada/libgnat/g-zspche.adb create mode 100644 gcc/ada/libgnat/g-zspche.ads create mode 100644 gcc/ada/libgnat/g-zstspl.ads create mode 100644 gcc/ada/libgnat/gnat.ads create mode 100644 gcc/ada/libgnat/i-c.adb create mode 100644 gcc/ada/libgnat/i-c.ads create mode 100644 gcc/ada/libgnat/i-cexten.ads create mode 100644 gcc/ada/libgnat/i-cobol.adb create mode 100644 gcc/ada/libgnat/i-cobol.ads create mode 100644 gcc/ada/libgnat/i-cpoint.adb create mode 100644 gcc/ada/libgnat/i-cpoint.ads create mode 100644 gcc/ada/libgnat/i-cstrea.adb create mode 100644 gcc/ada/libgnat/i-cstrea.ads create mode 100644 gcc/ada/libgnat/i-cstrin.adb create mode 100644 gcc/ada/libgnat/i-cstrin.ads create mode 100644 gcc/ada/libgnat/i-fortra.adb create mode 100644 gcc/ada/libgnat/i-fortra.ads create mode 100644 gcc/ada/libgnat/i-pacdec.adb create mode 100644 gcc/ada/libgnat/i-pacdec.ads create mode 100644 gcc/ada/libgnat/i-vxwoio.adb create mode 100644 gcc/ada/libgnat/i-vxwoio.ads create mode 100644 gcc/ada/libgnat/i-vxwork-x86.ads create mode 100644 gcc/ada/libgnat/i-vxwork.ads create mode 100644 gcc/ada/libgnat/interfac.ads create mode 100644 gcc/ada/libgnat/ioexcept.ads create mode 100644 gcc/ada/libgnat/machcode.ads create mode 100644 gcc/ada/libgnat/memtrack.adb create mode 100644 gcc/ada/libgnat/s-addima.adb create mode 100644 gcc/ada/libgnat/s-addima.ads create mode 100644 gcc/ada/libgnat/s-addope.adb create mode 100644 gcc/ada/libgnat/s-addope.ads create mode 100644 gcc/ada/libgnat/s-arit64.adb create mode 100644 gcc/ada/libgnat/s-arit64.ads create mode 100644 gcc/ada/libgnat/s-assert.adb create mode 100644 gcc/ada/libgnat/s-assert.ads create mode 100644 gcc/ada/libgnat/s-atacco.adb create mode 100644 gcc/ada/libgnat/s-atacco.ads create mode 100644 gcc/ada/libgnat/s-atocou-builtin.adb create mode 100644 gcc/ada/libgnat/s-atocou-x86.adb create mode 100644 gcc/ada/libgnat/s-atocou.adb create mode 100644 gcc/ada/libgnat/s-atocou.ads create mode 100644 gcc/ada/libgnat/s-atopri.adb create mode 100644 gcc/ada/libgnat/s-atopri.ads create mode 100644 gcc/ada/libgnat/s-auxdec.adb create mode 100644 gcc/ada/libgnat/s-auxdec.ads create mode 100644 gcc/ada/libgnat/s-bignum.adb create mode 100644 gcc/ada/libgnat/s-bignum.ads create mode 100644 gcc/ada/libgnat/s-bitops.adb create mode 100644 gcc/ada/libgnat/s-bitops.ads create mode 100644 gcc/ada/libgnat/s-boarop.ads create mode 100644 gcc/ada/libgnat/s-boustr.adb create mode 100644 gcc/ada/libgnat/s-boustr.ads create mode 100644 gcc/ada/libgnat/s-bytswa.ads create mode 100644 gcc/ada/libgnat/s-carsi8.adb create mode 100644 gcc/ada/libgnat/s-carsi8.ads create mode 100644 gcc/ada/libgnat/s-carun8.adb create mode 100644 gcc/ada/libgnat/s-carun8.ads create mode 100644 gcc/ada/libgnat/s-casi16.adb create mode 100644 gcc/ada/libgnat/s-casi16.ads create mode 100644 gcc/ada/libgnat/s-casi32.adb create mode 100644 gcc/ada/libgnat/s-casi32.ads create mode 100644 gcc/ada/libgnat/s-casi64.adb create mode 100644 gcc/ada/libgnat/s-casi64.ads create mode 100644 gcc/ada/libgnat/s-casuti.adb create mode 100644 gcc/ada/libgnat/s-casuti.ads create mode 100644 gcc/ada/libgnat/s-caun16.adb create mode 100644 gcc/ada/libgnat/s-caun16.ads create mode 100644 gcc/ada/libgnat/s-caun32.adb create mode 100644 gcc/ada/libgnat/s-caun32.ads create mode 100644 gcc/ada/libgnat/s-caun64.adb create mode 100644 gcc/ada/libgnat/s-caun64.ads create mode 100644 gcc/ada/libgnat/s-chepoo.ads create mode 100644 gcc/ada/libgnat/s-commun.adb create mode 100644 gcc/ada/libgnat/s-commun.ads create mode 100644 gcc/ada/libgnat/s-conca2.adb create mode 100644 gcc/ada/libgnat/s-conca2.ads create mode 100644 gcc/ada/libgnat/s-conca3.adb create mode 100644 gcc/ada/libgnat/s-conca3.ads create mode 100644 gcc/ada/libgnat/s-conca4.adb create mode 100644 gcc/ada/libgnat/s-conca4.ads create mode 100644 gcc/ada/libgnat/s-conca5.adb create mode 100644 gcc/ada/libgnat/s-conca5.ads create mode 100644 gcc/ada/libgnat/s-conca6.adb create mode 100644 gcc/ada/libgnat/s-conca6.ads create mode 100644 gcc/ada/libgnat/s-conca7.adb create mode 100644 gcc/ada/libgnat/s-conca7.ads create mode 100644 gcc/ada/libgnat/s-conca8.adb create mode 100644 gcc/ada/libgnat/s-conca8.ads create mode 100644 gcc/ada/libgnat/s-conca9.adb create mode 100644 gcc/ada/libgnat/s-conca9.ads create mode 100644 gcc/ada/libgnat/s-crc32.adb create mode 100644 gcc/ada/libgnat/s-crc32.ads create mode 100644 gcc/ada/libgnat/s-crtl.ads create mode 100644 gcc/ada/libgnat/s-diflio.adb create mode 100644 gcc/ada/libgnat/s-diflio.ads create mode 100644 gcc/ada/libgnat/s-diinio.adb create mode 100644 gcc/ada/libgnat/s-diinio.ads create mode 100644 gcc/ada/libgnat/s-dim.ads create mode 100644 gcc/ada/libgnat/s-dimkio.ads create mode 100644 gcc/ada/libgnat/s-dimmks.ads create mode 100644 gcc/ada/libgnat/s-direio.adb create mode 100644 gcc/ada/libgnat/s-direio.ads create mode 100644 gcc/ada/libgnat/s-dmotpr.ads create mode 100644 gcc/ada/libgnat/s-dsaser.ads create mode 100644 gcc/ada/libgnat/s-dwalin.adb create mode 100644 gcc/ada/libgnat/s-dwalin.ads create mode 100644 gcc/ada/libgnat/s-elaall.adb create mode 100644 gcc/ada/libgnat/s-elaall.ads create mode 100644 gcc/ada/libgnat/s-excdeb.adb create mode 100644 gcc/ada/libgnat/s-excdeb.ads create mode 100644 gcc/ada/libgnat/s-except.adb create mode 100644 gcc/ada/libgnat/s-except.ads create mode 100644 gcc/ada/libgnat/s-excmac-arm.adb create mode 100644 gcc/ada/libgnat/s-excmac-arm.ads create mode 100644 gcc/ada/libgnat/s-excmac-gcc.adb create mode 100644 gcc/ada/libgnat/s-excmac-gcc.ads create mode 100644 gcc/ada/libgnat/s-exctab.adb create mode 100644 gcc/ada/libgnat/s-exctab.ads create mode 100644 gcc/ada/libgnat/s-exctra.adb create mode 100644 gcc/ada/libgnat/s-exctra.ads create mode 100644 gcc/ada/libgnat/s-exnint.adb create mode 100644 gcc/ada/libgnat/s-exnint.ads create mode 100644 gcc/ada/libgnat/s-exnllf.adb create mode 100644 gcc/ada/libgnat/s-exnllf.ads create mode 100644 gcc/ada/libgnat/s-exnlli.adb create mode 100644 gcc/ada/libgnat/s-exnlli.ads create mode 100644 gcc/ada/libgnat/s-expint.adb create mode 100644 gcc/ada/libgnat/s-expint.ads create mode 100644 gcc/ada/libgnat/s-explli.adb create mode 100644 gcc/ada/libgnat/s-explli.ads create mode 100644 gcc/ada/libgnat/s-expllu.adb create mode 100644 gcc/ada/libgnat/s-expllu.ads create mode 100644 gcc/ada/libgnat/s-expmod.adb create mode 100644 gcc/ada/libgnat/s-expmod.ads create mode 100644 gcc/ada/libgnat/s-expuns.adb create mode 100644 gcc/ada/libgnat/s-expuns.ads create mode 100644 gcc/ada/libgnat/s-fatflt.ads create mode 100644 gcc/ada/libgnat/s-fatgen.adb create mode 100644 gcc/ada/libgnat/s-fatgen.ads create mode 100644 gcc/ada/libgnat/s-fatlfl.ads create mode 100644 gcc/ada/libgnat/s-fatllf.ads create mode 100644 gcc/ada/libgnat/s-fatsfl.ads create mode 100644 gcc/ada/libgnat/s-ficobl.ads create mode 100644 gcc/ada/libgnat/s-filatt.ads create mode 100644 gcc/ada/libgnat/s-fileio.adb create mode 100644 gcc/ada/libgnat/s-fileio.ads create mode 100644 gcc/ada/libgnat/s-finmas.adb create mode 100644 gcc/ada/libgnat/s-finmas.ads create mode 100644 gcc/ada/libgnat/s-finroo.adb create mode 100644 gcc/ada/libgnat/s-finroo.ads create mode 100644 gcc/ada/libgnat/s-flocon-none.adb create mode 100644 gcc/ada/libgnat/s-flocon.adb create mode 100644 gcc/ada/libgnat/s-flocon.ads create mode 100644 gcc/ada/libgnat/s-fore.adb create mode 100644 gcc/ada/libgnat/s-fore.ads create mode 100644 gcc/ada/libgnat/s-gearop.adb create mode 100644 gcc/ada/libgnat/s-gearop.ads create mode 100644 gcc/ada/libgnat/s-geveop.adb create mode 100644 gcc/ada/libgnat/s-geveop.ads create mode 100644 gcc/ada/libgnat/s-gloloc-mingw.adb create mode 100644 gcc/ada/libgnat/s-gloloc.adb create mode 100644 gcc/ada/libgnat/s-gloloc.ads create mode 100644 gcc/ada/libgnat/s-htable.adb create mode 100644 gcc/ada/libgnat/s-htable.ads create mode 100644 gcc/ada/libgnat/s-imenne.adb create mode 100644 gcc/ada/libgnat/s-imenne.ads create mode 100644 gcc/ada/libgnat/s-imgbiu.adb create mode 100644 gcc/ada/libgnat/s-imgbiu.ads create mode 100644 gcc/ada/libgnat/s-imgboo.adb create mode 100644 gcc/ada/libgnat/s-imgboo.ads create mode 100644 gcc/ada/libgnat/s-imgcha.adb create mode 100644 gcc/ada/libgnat/s-imgcha.ads create mode 100644 gcc/ada/libgnat/s-imgdec.adb create mode 100644 gcc/ada/libgnat/s-imgdec.ads create mode 100644 gcc/ada/libgnat/s-imgenu.adb create mode 100644 gcc/ada/libgnat/s-imgenu.ads create mode 100644 gcc/ada/libgnat/s-imgint.adb create mode 100644 gcc/ada/libgnat/s-imgint.ads create mode 100644 gcc/ada/libgnat/s-imgllb.adb create mode 100644 gcc/ada/libgnat/s-imgllb.ads create mode 100644 gcc/ada/libgnat/s-imglld.adb create mode 100644 gcc/ada/libgnat/s-imglld.ads create mode 100644 gcc/ada/libgnat/s-imglli.adb create mode 100644 gcc/ada/libgnat/s-imglli.ads create mode 100644 gcc/ada/libgnat/s-imgllu.adb create mode 100644 gcc/ada/libgnat/s-imgllu.ads create mode 100644 gcc/ada/libgnat/s-imgllw.adb create mode 100644 gcc/ada/libgnat/s-imgllw.ads create mode 100644 gcc/ada/libgnat/s-imgrea.adb create mode 100644 gcc/ada/libgnat/s-imgrea.ads create mode 100644 gcc/ada/libgnat/s-imguns.adb create mode 100644 gcc/ada/libgnat/s-imguns.ads create mode 100644 gcc/ada/libgnat/s-imgwch.adb create mode 100644 gcc/ada/libgnat/s-imgwch.ads create mode 100644 gcc/ada/libgnat/s-imgwiu.adb create mode 100644 gcc/ada/libgnat/s-imgwiu.ads create mode 100644 gcc/ada/libgnat/s-io.adb create mode 100644 gcc/ada/libgnat/s-io.ads create mode 100644 gcc/ada/libgnat/s-llflex.ads create mode 100644 gcc/ada/libgnat/s-maccod.ads create mode 100644 gcc/ada/libgnat/s-mantis.adb create mode 100644 gcc/ada/libgnat/s-mantis.ads create mode 100644 gcc/ada/libgnat/s-mastop.adb create mode 100644 gcc/ada/libgnat/s-mastop.ads create mode 100644 gcc/ada/libgnat/s-memcop.ads create mode 100644 gcc/ada/libgnat/s-memory-mingw.adb create mode 100644 gcc/ada/libgnat/s-memory.adb create mode 100644 gcc/ada/libgnat/s-memory.ads create mode 100644 gcc/ada/libgnat/s-mmap.adb create mode 100644 gcc/ada/libgnat/s-mmap.ads create mode 100644 gcc/ada/libgnat/s-mmauni-long.ads create mode 100644 gcc/ada/libgnat/s-mmosin-mingw.adb create mode 100644 gcc/ada/libgnat/s-mmosin-mingw.ads create mode 100644 gcc/ada/libgnat/s-mmosin-unix.adb create mode 100644 gcc/ada/libgnat/s-mmosin-unix.ads create mode 100644 gcc/ada/libgnat/s-multip.adb create mode 100644 gcc/ada/libgnat/s-multip.ads create mode 100644 gcc/ada/libgnat/s-objrea.adb create mode 100644 gcc/ada/libgnat/s-objrea.ads create mode 100644 gcc/ada/libgnat/s-os_lib.adb create mode 100644 gcc/ada/libgnat/s-os_lib.ads create mode 100644 gcc/ada/libgnat/s-osprim-darwin.adb create mode 100644 gcc/ada/libgnat/s-osprim-mingw.adb create mode 100644 gcc/ada/libgnat/s-osprim-posix.adb create mode 100644 gcc/ada/libgnat/s-osprim-posix2008.adb create mode 100644 gcc/ada/libgnat/s-osprim-solaris.adb create mode 100644 gcc/ada/libgnat/s-osprim-unix.adb create mode 100644 gcc/ada/libgnat/s-osprim-vxworks.adb create mode 100644 gcc/ada/libgnat/s-osprim-x32.adb create mode 100644 gcc/ada/libgnat/s-osprim.ads create mode 100644 gcc/ada/libgnat/s-pack03.adb create mode 100644 gcc/ada/libgnat/s-pack03.ads create mode 100644 gcc/ada/libgnat/s-pack05.adb create mode 100644 gcc/ada/libgnat/s-pack05.ads create mode 100644 gcc/ada/libgnat/s-pack06.adb create mode 100644 gcc/ada/libgnat/s-pack06.ads create mode 100644 gcc/ada/libgnat/s-pack07.adb create mode 100644 gcc/ada/libgnat/s-pack07.ads create mode 100644 gcc/ada/libgnat/s-pack09.adb create mode 100644 gcc/ada/libgnat/s-pack09.ads create mode 100644 gcc/ada/libgnat/s-pack10.adb create mode 100644 gcc/ada/libgnat/s-pack10.ads create mode 100644 gcc/ada/libgnat/s-pack11.adb create mode 100644 gcc/ada/libgnat/s-pack11.ads create mode 100644 gcc/ada/libgnat/s-pack12.adb create mode 100644 gcc/ada/libgnat/s-pack12.ads create mode 100644 gcc/ada/libgnat/s-pack13.adb create mode 100644 gcc/ada/libgnat/s-pack13.ads create mode 100644 gcc/ada/libgnat/s-pack14.adb create mode 100644 gcc/ada/libgnat/s-pack14.ads create mode 100644 gcc/ada/libgnat/s-pack15.adb create mode 100644 gcc/ada/libgnat/s-pack15.ads create mode 100644 gcc/ada/libgnat/s-pack17.adb create mode 100644 gcc/ada/libgnat/s-pack17.ads create mode 100644 gcc/ada/libgnat/s-pack18.adb create mode 100644 gcc/ada/libgnat/s-pack18.ads create mode 100644 gcc/ada/libgnat/s-pack19.adb create mode 100644 gcc/ada/libgnat/s-pack19.ads create mode 100644 gcc/ada/libgnat/s-pack20.adb create mode 100644 gcc/ada/libgnat/s-pack20.ads create mode 100644 gcc/ada/libgnat/s-pack21.adb create mode 100644 gcc/ada/libgnat/s-pack21.ads create mode 100644 gcc/ada/libgnat/s-pack22.adb create mode 100644 gcc/ada/libgnat/s-pack22.ads create mode 100644 gcc/ada/libgnat/s-pack23.adb create mode 100644 gcc/ada/libgnat/s-pack23.ads create mode 100644 gcc/ada/libgnat/s-pack24.adb create mode 100644 gcc/ada/libgnat/s-pack24.ads create mode 100644 gcc/ada/libgnat/s-pack25.adb create mode 100644 gcc/ada/libgnat/s-pack25.ads create mode 100644 gcc/ada/libgnat/s-pack26.adb create mode 100644 gcc/ada/libgnat/s-pack26.ads create mode 100644 gcc/ada/libgnat/s-pack27.adb create mode 100644 gcc/ada/libgnat/s-pack27.ads create mode 100644 gcc/ada/libgnat/s-pack28.adb create mode 100644 gcc/ada/libgnat/s-pack28.ads create mode 100644 gcc/ada/libgnat/s-pack29.adb create mode 100644 gcc/ada/libgnat/s-pack29.ads create mode 100644 gcc/ada/libgnat/s-pack30.adb create mode 100644 gcc/ada/libgnat/s-pack30.ads create mode 100644 gcc/ada/libgnat/s-pack31.adb create mode 100644 gcc/ada/libgnat/s-pack31.ads create mode 100644 gcc/ada/libgnat/s-pack33.adb create mode 100644 gcc/ada/libgnat/s-pack33.ads create mode 100644 gcc/ada/libgnat/s-pack34.adb create mode 100644 gcc/ada/libgnat/s-pack34.ads create mode 100644 gcc/ada/libgnat/s-pack35.adb create mode 100644 gcc/ada/libgnat/s-pack35.ads create mode 100644 gcc/ada/libgnat/s-pack36.adb create mode 100644 gcc/ada/libgnat/s-pack36.ads create mode 100644 gcc/ada/libgnat/s-pack37.adb create mode 100644 gcc/ada/libgnat/s-pack37.ads create mode 100644 gcc/ada/libgnat/s-pack38.adb create mode 100644 gcc/ada/libgnat/s-pack38.ads create mode 100644 gcc/ada/libgnat/s-pack39.adb create mode 100644 gcc/ada/libgnat/s-pack39.ads create mode 100644 gcc/ada/libgnat/s-pack40.adb create mode 100644 gcc/ada/libgnat/s-pack40.ads create mode 100644 gcc/ada/libgnat/s-pack41.adb create mode 100644 gcc/ada/libgnat/s-pack41.ads create mode 100644 gcc/ada/libgnat/s-pack42.adb create mode 100644 gcc/ada/libgnat/s-pack42.ads create mode 100644 gcc/ada/libgnat/s-pack43.adb create mode 100644 gcc/ada/libgnat/s-pack43.ads create mode 100644 gcc/ada/libgnat/s-pack44.adb create mode 100644 gcc/ada/libgnat/s-pack44.ads create mode 100644 gcc/ada/libgnat/s-pack45.adb create mode 100644 gcc/ada/libgnat/s-pack45.ads create mode 100644 gcc/ada/libgnat/s-pack46.adb create mode 100644 gcc/ada/libgnat/s-pack46.ads create mode 100644 gcc/ada/libgnat/s-pack47.adb create mode 100644 gcc/ada/libgnat/s-pack47.ads create mode 100644 gcc/ada/libgnat/s-pack48.adb create mode 100644 gcc/ada/libgnat/s-pack48.ads create mode 100644 gcc/ada/libgnat/s-pack49.adb create mode 100644 gcc/ada/libgnat/s-pack49.ads create mode 100644 gcc/ada/libgnat/s-pack50.adb create mode 100644 gcc/ada/libgnat/s-pack50.ads create mode 100644 gcc/ada/libgnat/s-pack51.adb create mode 100644 gcc/ada/libgnat/s-pack51.ads create mode 100644 gcc/ada/libgnat/s-pack52.adb create mode 100644 gcc/ada/libgnat/s-pack52.ads create mode 100644 gcc/ada/libgnat/s-pack53.adb create mode 100644 gcc/ada/libgnat/s-pack53.ads create mode 100644 gcc/ada/libgnat/s-pack54.adb create mode 100644 gcc/ada/libgnat/s-pack54.ads create mode 100644 gcc/ada/libgnat/s-pack55.adb create mode 100644 gcc/ada/libgnat/s-pack55.ads create mode 100644 gcc/ada/libgnat/s-pack56.adb create mode 100644 gcc/ada/libgnat/s-pack56.ads create mode 100644 gcc/ada/libgnat/s-pack57.adb create mode 100644 gcc/ada/libgnat/s-pack57.ads create mode 100644 gcc/ada/libgnat/s-pack58.adb create mode 100644 gcc/ada/libgnat/s-pack58.ads create mode 100644 gcc/ada/libgnat/s-pack59.adb create mode 100644 gcc/ada/libgnat/s-pack59.ads create mode 100644 gcc/ada/libgnat/s-pack60.adb create mode 100644 gcc/ada/libgnat/s-pack60.ads create mode 100644 gcc/ada/libgnat/s-pack61.adb create mode 100644 gcc/ada/libgnat/s-pack61.ads create mode 100644 gcc/ada/libgnat/s-pack62.adb create mode 100644 gcc/ada/libgnat/s-pack62.ads create mode 100644 gcc/ada/libgnat/s-pack63.adb create mode 100644 gcc/ada/libgnat/s-pack63.ads create mode 100644 gcc/ada/libgnat/s-parame-hpux.ads create mode 100644 gcc/ada/libgnat/s-parame-rtems.adb create mode 100644 gcc/ada/libgnat/s-parame-vxworks.adb create mode 100644 gcc/ada/libgnat/s-parame-vxworks.ads create mode 100644 gcc/ada/libgnat/s-parame.adb create mode 100644 gcc/ada/libgnat/s-parame.ads create mode 100644 gcc/ada/libgnat/s-parint.adb create mode 100644 gcc/ada/libgnat/s-parint.ads create mode 100644 gcc/ada/libgnat/s-pooglo.adb create mode 100644 gcc/ada/libgnat/s-pooglo.ads create mode 100644 gcc/ada/libgnat/s-pooloc.adb create mode 100644 gcc/ada/libgnat/s-pooloc.ads create mode 100644 gcc/ada/libgnat/s-poosiz.adb create mode 100644 gcc/ada/libgnat/s-poosiz.ads create mode 100644 gcc/ada/libgnat/s-powtab.ads create mode 100644 gcc/ada/libgnat/s-purexc.ads create mode 100644 gcc/ada/libgnat/s-rannum.adb create mode 100644 gcc/ada/libgnat/s-rannum.ads create mode 100644 gcc/ada/libgnat/s-ransee.adb create mode 100644 gcc/ada/libgnat/s-ransee.ads create mode 100644 gcc/ada/libgnat/s-regexp.adb create mode 100644 gcc/ada/libgnat/s-regexp.ads create mode 100644 gcc/ada/libgnat/s-regpat.adb create mode 100644 gcc/ada/libgnat/s-regpat.ads create mode 100644 gcc/ada/libgnat/s-resfil.adb create mode 100644 gcc/ada/libgnat/s-resfil.ads create mode 100644 gcc/ada/libgnat/s-restri.adb create mode 100644 gcc/ada/libgnat/s-restri.ads create mode 100644 gcc/ada/libgnat/s-rident.ads create mode 100644 gcc/ada/libgnat/s-rpc.adb create mode 100644 gcc/ada/libgnat/s-rpc.ads create mode 100644 gcc/ada/libgnat/s-scaval.adb create mode 100644 gcc/ada/libgnat/s-scaval.ads create mode 100644 gcc/ada/libgnat/s-secsta.adb create mode 100644 gcc/ada/libgnat/s-secsta.ads create mode 100644 gcc/ada/libgnat/s-sequio.adb create mode 100644 gcc/ada/libgnat/s-sequio.ads create mode 100644 gcc/ada/libgnat/s-shasto.adb create mode 100644 gcc/ada/libgnat/s-shasto.ads create mode 100644 gcc/ada/libgnat/s-soflin.adb create mode 100644 gcc/ada/libgnat/s-soflin.ads create mode 100644 gcc/ada/libgnat/s-sopco3.adb create mode 100644 gcc/ada/libgnat/s-sopco3.ads create mode 100644 gcc/ada/libgnat/s-sopco4.adb create mode 100644 gcc/ada/libgnat/s-sopco4.ads create mode 100644 gcc/ada/libgnat/s-sopco5.adb create mode 100644 gcc/ada/libgnat/s-sopco5.ads create mode 100644 gcc/ada/libgnat/s-spsufi.adb create mode 100644 gcc/ada/libgnat/s-spsufi.ads create mode 100644 gcc/ada/libgnat/s-stache.adb create mode 100644 gcc/ada/libgnat/s-stache.ads create mode 100644 gcc/ada/libgnat/s-stalib.adb create mode 100644 gcc/ada/libgnat/s-stalib.ads create mode 100644 gcc/ada/libgnat/s-stausa.adb create mode 100644 gcc/ada/libgnat/s-stausa.ads create mode 100644 gcc/ada/libgnat/s-stchop-limit.ads create mode 100644 gcc/ada/libgnat/s-stchop-rtems.adb create mode 100644 gcc/ada/libgnat/s-stchop-vxworks.adb create mode 100644 gcc/ada/libgnat/s-stchop.adb create mode 100644 gcc/ada/libgnat/s-stchop.ads create mode 100644 gcc/ada/libgnat/s-stoele.adb create mode 100644 gcc/ada/libgnat/s-stoele.ads create mode 100644 gcc/ada/libgnat/s-stopoo.adb create mode 100644 gcc/ada/libgnat/s-stopoo.ads create mode 100644 gcc/ada/libgnat/s-stposu.adb create mode 100644 gcc/ada/libgnat/s-stposu.ads create mode 100644 gcc/ada/libgnat/s-stratt-xdr.adb create mode 100644 gcc/ada/libgnat/s-stratt.adb create mode 100644 gcc/ada/libgnat/s-stratt.ads create mode 100644 gcc/ada/libgnat/s-strcom.adb create mode 100644 gcc/ada/libgnat/s-strcom.ads create mode 100644 gcc/ada/libgnat/s-strhas.adb create mode 100644 gcc/ada/libgnat/s-strhas.ads create mode 100644 gcc/ada/libgnat/s-string.adb create mode 100644 gcc/ada/libgnat/s-string.ads create mode 100644 gcc/ada/libgnat/s-strops.adb create mode 100644 gcc/ada/libgnat/s-strops.ads create mode 100644 gcc/ada/libgnat/s-ststop.adb create mode 100644 gcc/ada/libgnat/s-ststop.ads create mode 100644 gcc/ada/libgnat/s-tasloc.adb create mode 100644 gcc/ada/libgnat/s-tasloc.ads create mode 100644 gcc/ada/libgnat/s-thread.ads create mode 100644 gcc/ada/libgnat/s-traceb-hpux.adb create mode 100644 gcc/ada/libgnat/s-traceb-mastop.adb create mode 100644 gcc/ada/libgnat/s-traceb.adb create mode 100644 gcc/ada/libgnat/s-traceb.ads create mode 100644 gcc/ada/libgnat/s-traent.adb create mode 100644 gcc/ada/libgnat/s-traent.ads create mode 100644 gcc/ada/libgnat/s-trasym-dwarf.adb create mode 100644 gcc/ada/libgnat/s-trasym.adb create mode 100644 gcc/ada/libgnat/s-trasym.ads create mode 100644 gcc/ada/libgnat/s-tsmona-linux.adb create mode 100644 gcc/ada/libgnat/s-tsmona-mingw.adb create mode 100644 gcc/ada/libgnat/s-tsmona.adb create mode 100644 gcc/ada/libgnat/s-unstyp.ads create mode 100644 gcc/ada/libgnat/s-utf_32.adb create mode 100644 gcc/ada/libgnat/s-utf_32.ads create mode 100644 gcc/ada/libgnat/s-valboo.adb create mode 100644 gcc/ada/libgnat/s-valboo.ads create mode 100644 gcc/ada/libgnat/s-valcha.adb create mode 100644 gcc/ada/libgnat/s-valcha.ads create mode 100644 gcc/ada/libgnat/s-valdec.adb create mode 100644 gcc/ada/libgnat/s-valdec.ads create mode 100644 gcc/ada/libgnat/s-valenu.adb create mode 100644 gcc/ada/libgnat/s-valenu.ads create mode 100644 gcc/ada/libgnat/s-valint.adb create mode 100644 gcc/ada/libgnat/s-valint.ads create mode 100644 gcc/ada/libgnat/s-vallld.adb create mode 100644 gcc/ada/libgnat/s-vallld.ads create mode 100644 gcc/ada/libgnat/s-vallli.adb create mode 100644 gcc/ada/libgnat/s-vallli.ads create mode 100644 gcc/ada/libgnat/s-valllu.adb create mode 100644 gcc/ada/libgnat/s-valllu.ads create mode 100644 gcc/ada/libgnat/s-valrea.adb create mode 100644 gcc/ada/libgnat/s-valrea.ads create mode 100644 gcc/ada/libgnat/s-valuns.adb create mode 100644 gcc/ada/libgnat/s-valuns.ads create mode 100644 gcc/ada/libgnat/s-valuti.adb create mode 100644 gcc/ada/libgnat/s-valuti.ads create mode 100644 gcc/ada/libgnat/s-valwch.adb create mode 100644 gcc/ada/libgnat/s-valwch.ads create mode 100644 gcc/ada/libgnat/s-veboop.adb create mode 100644 gcc/ada/libgnat/s-veboop.ads create mode 100644 gcc/ada/libgnat/s-vector.ads create mode 100644 gcc/ada/libgnat/s-vercon.adb create mode 100644 gcc/ada/libgnat/s-vercon.ads create mode 100644 gcc/ada/libgnat/s-wchcnv.adb create mode 100644 gcc/ada/libgnat/s-wchcnv.ads create mode 100644 gcc/ada/libgnat/s-wchcon.adb create mode 100644 gcc/ada/libgnat/s-wchcon.ads create mode 100644 gcc/ada/libgnat/s-wchjis.adb create mode 100644 gcc/ada/libgnat/s-wchjis.ads create mode 100644 gcc/ada/libgnat/s-wchstw.adb create mode 100644 gcc/ada/libgnat/s-wchstw.ads create mode 100644 gcc/ada/libgnat/s-wchwts.adb create mode 100644 gcc/ada/libgnat/s-wchwts.ads create mode 100644 gcc/ada/libgnat/s-widboo.adb create mode 100644 gcc/ada/libgnat/s-widboo.ads create mode 100644 gcc/ada/libgnat/s-widcha.adb create mode 100644 gcc/ada/libgnat/s-widcha.ads create mode 100644 gcc/ada/libgnat/s-widenu.adb create mode 100644 gcc/ada/libgnat/s-widenu.ads create mode 100644 gcc/ada/libgnat/s-widlli.adb create mode 100644 gcc/ada/libgnat/s-widlli.ads create mode 100644 gcc/ada/libgnat/s-widllu.adb create mode 100644 gcc/ada/libgnat/s-widllu.ads create mode 100644 gcc/ada/libgnat/s-widwch.adb create mode 100644 gcc/ada/libgnat/s-widwch.ads create mode 100644 gcc/ada/libgnat/s-win32.ads create mode 100644 gcc/ada/libgnat/s-winext.ads create mode 100644 gcc/ada/libgnat/s-wwdcha.adb create mode 100644 gcc/ada/libgnat/s-wwdcha.ads create mode 100644 gcc/ada/libgnat/s-wwdenu.adb create mode 100644 gcc/ada/libgnat/s-wwdenu.ads create mode 100644 gcc/ada/libgnat/s-wwdwch.adb create mode 100644 gcc/ada/libgnat/s-wwdwch.ads create mode 100644 gcc/ada/libgnat/sequenio.ads create mode 100644 gcc/ada/libgnat/system-aix.ads create mode 100644 gcc/ada/libgnat/system-darwin-arm.ads create mode 100644 gcc/ada/libgnat/system-darwin-ppc.ads create mode 100644 gcc/ada/libgnat/system-darwin-x86.ads create mode 100644 gcc/ada/libgnat/system-djgpp.ads create mode 100644 gcc/ada/libgnat/system-dragonfly-x86_64.ads create mode 100644 gcc/ada/libgnat/system-freebsd.ads create mode 100644 gcc/ada/libgnat/system-hpux-ia64.ads create mode 100644 gcc/ada/libgnat/system-hpux.ads create mode 100644 gcc/ada/libgnat/system-linux-alpha.ads create mode 100644 gcc/ada/libgnat/system-linux-arm.ads create mode 100644 gcc/ada/libgnat/system-linux-hppa.ads create mode 100644 gcc/ada/libgnat/system-linux-ia64.ads create mode 100644 gcc/ada/libgnat/system-linux-m68k.ads create mode 100644 gcc/ada/libgnat/system-linux-mips.ads create mode 100644 gcc/ada/libgnat/system-linux-ppc.ads create mode 100644 gcc/ada/libgnat/system-linux-s390.ads create mode 100644 gcc/ada/libgnat/system-linux-sh4.ads create mode 100644 gcc/ada/libgnat/system-linux-sparc.ads create mode 100644 gcc/ada/libgnat/system-linux-x86.ads create mode 100644 gcc/ada/libgnat/system-mingw.ads create mode 100644 gcc/ada/libgnat/system-rtems.ads create mode 100644 gcc/ada/libgnat/system-solaris-sparc.ads create mode 100644 gcc/ada/libgnat/system-solaris-x86.ads create mode 100644 gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-arm-rtp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-arm.ads create mode 100644 gcc/ada/libgnat/system-vxworks-e500-kernel.ads create mode 100644 gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-e500-rtp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-e500-vthread.ads create mode 100644 gcc/ada/libgnat/system-vxworks-ppc-kernel.ads create mode 100644 gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads create mode 100644 gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-ppc-rtp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-ppc-vthread.ads create mode 100644 gcc/ada/libgnat/system-vxworks-ppc.ads create mode 100644 gcc/ada/libgnat/system-vxworks-ppc64-kernel.ads create mode 100644 gcc/ada/libgnat/system-vxworks-x86-kernel.ads create mode 100644 gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-x86-rtp.ads create mode 100644 gcc/ada/libgnat/system-vxworks-x86-vthread.ads create mode 100644 gcc/ada/libgnat/system-vxworks-x86.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-arm.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-x86-kernel.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads create mode 100644 gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads create mode 100644 gcc/ada/libgnat/system.ads create mode 100644 gcc/ada/libgnat/text_io.ads create mode 100644 gcc/ada/libgnat/unchconv.ads create mode 100644 gcc/ada/libgnat/unchdeal.ads delete mode 100644 gcc/ada/machcode.ads delete mode 100644 gcc/ada/memtrack.adb delete mode 100644 gcc/ada/s-addima.adb delete mode 100644 gcc/ada/s-addima.ads delete mode 100644 gcc/ada/s-addope.adb delete mode 100644 gcc/ada/s-addope.ads delete mode 100644 gcc/ada/s-arit64.adb delete mode 100644 gcc/ada/s-arit64.ads delete mode 100644 gcc/ada/s-assert.adb delete mode 100644 gcc/ada/s-assert.ads delete mode 100644 gcc/ada/s-atacco.adb delete mode 100644 gcc/ada/s-atacco.ads delete mode 100644 gcc/ada/s-atocou-builtin.adb delete mode 100644 gcc/ada/s-atocou-x86.adb delete mode 100644 gcc/ada/s-atocou.adb delete mode 100644 gcc/ada/s-atocou.ads delete mode 100644 gcc/ada/s-atopri.adb delete mode 100644 gcc/ada/s-atopri.ads delete mode 100644 gcc/ada/s-auxdec.adb delete mode 100644 gcc/ada/s-auxdec.ads delete mode 100644 gcc/ada/s-bignum.adb delete mode 100644 gcc/ada/s-bignum.ads delete mode 100644 gcc/ada/s-bitops.adb delete mode 100644 gcc/ada/s-bitops.ads delete mode 100644 gcc/ada/s-boarop.ads delete mode 100644 gcc/ada/s-boustr.adb delete mode 100644 gcc/ada/s-boustr.ads delete mode 100644 gcc/ada/s-bytswa.ads delete mode 100644 gcc/ada/s-carsi8.adb delete mode 100644 gcc/ada/s-carsi8.ads delete mode 100644 gcc/ada/s-carun8.adb delete mode 100644 gcc/ada/s-carun8.ads delete mode 100644 gcc/ada/s-casi16.adb delete mode 100644 gcc/ada/s-casi16.ads delete mode 100644 gcc/ada/s-casi32.adb delete mode 100644 gcc/ada/s-casi32.ads delete mode 100644 gcc/ada/s-casi64.adb delete mode 100644 gcc/ada/s-casi64.ads delete mode 100644 gcc/ada/s-casuti.adb delete mode 100644 gcc/ada/s-casuti.ads delete mode 100644 gcc/ada/s-caun16.adb delete mode 100644 gcc/ada/s-caun16.ads delete mode 100644 gcc/ada/s-caun32.adb delete mode 100644 gcc/ada/s-caun32.ads delete mode 100644 gcc/ada/s-caun64.adb delete mode 100644 gcc/ada/s-caun64.ads delete mode 100644 gcc/ada/s-chepoo.ads delete mode 100644 gcc/ada/s-commun.adb delete mode 100644 gcc/ada/s-commun.ads delete mode 100644 gcc/ada/s-conca2.adb delete mode 100644 gcc/ada/s-conca2.ads delete mode 100644 gcc/ada/s-conca3.adb delete mode 100644 gcc/ada/s-conca3.ads delete mode 100644 gcc/ada/s-conca4.adb delete mode 100644 gcc/ada/s-conca4.ads delete mode 100644 gcc/ada/s-conca5.adb delete mode 100644 gcc/ada/s-conca5.ads delete mode 100644 gcc/ada/s-conca6.adb delete mode 100644 gcc/ada/s-conca6.ads delete mode 100644 gcc/ada/s-conca7.adb delete mode 100644 gcc/ada/s-conca7.ads delete mode 100644 gcc/ada/s-conca8.adb delete mode 100644 gcc/ada/s-conca8.ads delete mode 100644 gcc/ada/s-conca9.adb delete mode 100644 gcc/ada/s-conca9.ads delete mode 100644 gcc/ada/s-crc32.adb delete mode 100644 gcc/ada/s-crc32.ads delete mode 100644 gcc/ada/s-crtl.ads delete mode 100644 gcc/ada/s-diflio.adb delete mode 100644 gcc/ada/s-diflio.ads delete mode 100644 gcc/ada/s-diinio.adb delete mode 100644 gcc/ada/s-diinio.ads delete mode 100644 gcc/ada/s-dim.ads delete mode 100644 gcc/ada/s-dimkio.ads delete mode 100644 gcc/ada/s-dimmks.ads delete mode 100644 gcc/ada/s-direio.adb delete mode 100644 gcc/ada/s-direio.ads delete mode 100644 gcc/ada/s-dmotpr.ads delete mode 100644 gcc/ada/s-dsaser.ads delete mode 100644 gcc/ada/s-dwalin.adb delete mode 100644 gcc/ada/s-dwalin.ads delete mode 100644 gcc/ada/s-elaall.adb delete mode 100644 gcc/ada/s-elaall.ads delete mode 100644 gcc/ada/s-excdeb.adb delete mode 100644 gcc/ada/s-excdeb.ads delete mode 100644 gcc/ada/s-except.adb delete mode 100644 gcc/ada/s-except.ads delete mode 100644 gcc/ada/s-excmac-arm.adb delete mode 100644 gcc/ada/s-excmac-arm.ads delete mode 100644 gcc/ada/s-excmac-gcc.adb delete mode 100644 gcc/ada/s-excmac-gcc.ads delete mode 100644 gcc/ada/s-exctab.adb delete mode 100644 gcc/ada/s-exctab.ads delete mode 100644 gcc/ada/s-exctra.adb delete mode 100644 gcc/ada/s-exctra.ads delete mode 100644 gcc/ada/s-exnint.adb delete mode 100644 gcc/ada/s-exnint.ads delete mode 100644 gcc/ada/s-exnllf.adb delete mode 100644 gcc/ada/s-exnllf.ads delete mode 100644 gcc/ada/s-exnlli.adb delete mode 100644 gcc/ada/s-exnlli.ads delete mode 100644 gcc/ada/s-expint.adb delete mode 100644 gcc/ada/s-expint.ads delete mode 100644 gcc/ada/s-explli.adb delete mode 100644 gcc/ada/s-explli.ads delete mode 100644 gcc/ada/s-expllu.adb delete mode 100644 gcc/ada/s-expllu.ads delete mode 100644 gcc/ada/s-expmod.adb delete mode 100644 gcc/ada/s-expmod.ads delete mode 100644 gcc/ada/s-expuns.adb delete mode 100644 gcc/ada/s-expuns.ads delete mode 100644 gcc/ada/s-fatflt.ads delete mode 100644 gcc/ada/s-fatgen.adb delete mode 100644 gcc/ada/s-fatgen.ads delete mode 100644 gcc/ada/s-fatlfl.ads delete mode 100644 gcc/ada/s-fatllf.ads delete mode 100644 gcc/ada/s-fatsfl.ads delete mode 100644 gcc/ada/s-ficobl.ads delete mode 100644 gcc/ada/s-filatt.ads delete mode 100644 gcc/ada/s-fileio.adb delete mode 100644 gcc/ada/s-fileio.ads delete mode 100644 gcc/ada/s-finmas.adb delete mode 100644 gcc/ada/s-finmas.ads delete mode 100644 gcc/ada/s-finroo.adb delete mode 100644 gcc/ada/s-finroo.ads delete mode 100644 gcc/ada/s-flocon-none.adb delete mode 100644 gcc/ada/s-flocon.adb delete mode 100644 gcc/ada/s-flocon.ads delete mode 100644 gcc/ada/s-fore.adb delete mode 100644 gcc/ada/s-fore.ads delete mode 100644 gcc/ada/s-gearop.adb delete mode 100644 gcc/ada/s-gearop.ads delete mode 100644 gcc/ada/s-geveop.adb delete mode 100644 gcc/ada/s-geveop.ads delete mode 100644 gcc/ada/s-gloloc-mingw.adb delete mode 100644 gcc/ada/s-gloloc.adb delete mode 100644 gcc/ada/s-gloloc.ads delete mode 100644 gcc/ada/s-htable.adb delete mode 100644 gcc/ada/s-htable.ads delete mode 100644 gcc/ada/s-imenne.adb delete mode 100644 gcc/ada/s-imenne.ads delete mode 100644 gcc/ada/s-imgbiu.adb delete mode 100644 gcc/ada/s-imgbiu.ads delete mode 100644 gcc/ada/s-imgboo.adb delete mode 100644 gcc/ada/s-imgboo.ads delete mode 100644 gcc/ada/s-imgcha.adb delete mode 100644 gcc/ada/s-imgcha.ads delete mode 100644 gcc/ada/s-imgdec.adb delete mode 100644 gcc/ada/s-imgdec.ads delete mode 100644 gcc/ada/s-imgenu.adb delete mode 100644 gcc/ada/s-imgenu.ads delete mode 100644 gcc/ada/s-imgint.adb delete mode 100644 gcc/ada/s-imgint.ads delete mode 100644 gcc/ada/s-imgllb.adb delete mode 100644 gcc/ada/s-imgllb.ads delete mode 100644 gcc/ada/s-imglld.adb delete mode 100644 gcc/ada/s-imglld.ads delete mode 100644 gcc/ada/s-imglli.adb delete mode 100644 gcc/ada/s-imglli.ads delete mode 100644 gcc/ada/s-imgllu.adb delete mode 100644 gcc/ada/s-imgllu.ads delete mode 100644 gcc/ada/s-imgllw.adb delete mode 100644 gcc/ada/s-imgllw.ads delete mode 100644 gcc/ada/s-imgrea.adb delete mode 100644 gcc/ada/s-imgrea.ads delete mode 100644 gcc/ada/s-imguns.adb delete mode 100644 gcc/ada/s-imguns.ads delete mode 100644 gcc/ada/s-imgwch.adb delete mode 100644 gcc/ada/s-imgwch.ads delete mode 100644 gcc/ada/s-imgwiu.adb delete mode 100644 gcc/ada/s-imgwiu.ads delete mode 100644 gcc/ada/s-io.adb delete mode 100644 gcc/ada/s-io.ads delete mode 100644 gcc/ada/s-llflex.ads delete mode 100644 gcc/ada/s-maccod.ads delete mode 100644 gcc/ada/s-mantis.adb delete mode 100644 gcc/ada/s-mantis.ads delete mode 100644 gcc/ada/s-mastop.adb delete mode 100644 gcc/ada/s-mastop.ads delete mode 100644 gcc/ada/s-memcop.ads delete mode 100644 gcc/ada/s-memory-mingw.adb delete mode 100644 gcc/ada/s-memory.adb delete mode 100644 gcc/ada/s-memory.ads delete mode 100644 gcc/ada/s-mmap.adb delete mode 100644 gcc/ada/s-mmap.ads delete mode 100644 gcc/ada/s-mmauni-long.ads delete mode 100644 gcc/ada/s-mmosin-mingw.adb delete mode 100644 gcc/ada/s-mmosin-mingw.ads delete mode 100644 gcc/ada/s-mmosin-unix.adb delete mode 100644 gcc/ada/s-mmosin-unix.ads delete mode 100644 gcc/ada/s-multip.adb delete mode 100644 gcc/ada/s-multip.ads delete mode 100644 gcc/ada/s-objrea.adb delete mode 100644 gcc/ada/s-objrea.ads delete mode 100644 gcc/ada/s-os_lib.adb delete mode 100644 gcc/ada/s-os_lib.ads delete mode 100644 gcc/ada/s-osprim-darwin.adb delete mode 100644 gcc/ada/s-osprim-mingw.adb delete mode 100644 gcc/ada/s-osprim-posix.adb delete mode 100644 gcc/ada/s-osprim-solaris.adb delete mode 100644 gcc/ada/s-osprim-unix.adb delete mode 100644 gcc/ada/s-osprim-vxworks.adb delete mode 100644 gcc/ada/s-osprim-x32.adb delete mode 100644 gcc/ada/s-osprim.ads delete mode 100644 gcc/ada/s-pack03.adb delete mode 100644 gcc/ada/s-pack03.ads delete mode 100644 gcc/ada/s-pack05.adb delete mode 100644 gcc/ada/s-pack05.ads delete mode 100644 gcc/ada/s-pack06.adb delete mode 100644 gcc/ada/s-pack06.ads delete mode 100644 gcc/ada/s-pack07.adb delete mode 100644 gcc/ada/s-pack07.ads delete mode 100644 gcc/ada/s-pack09.adb delete mode 100644 gcc/ada/s-pack09.ads delete mode 100644 gcc/ada/s-pack10.adb delete mode 100644 gcc/ada/s-pack10.ads delete mode 100644 gcc/ada/s-pack11.adb delete mode 100644 gcc/ada/s-pack11.ads delete mode 100644 gcc/ada/s-pack12.adb delete mode 100644 gcc/ada/s-pack12.ads delete mode 100644 gcc/ada/s-pack13.adb delete mode 100644 gcc/ada/s-pack13.ads delete mode 100644 gcc/ada/s-pack14.adb delete mode 100644 gcc/ada/s-pack14.ads delete mode 100644 gcc/ada/s-pack15.adb delete mode 100644 gcc/ada/s-pack15.ads delete mode 100644 gcc/ada/s-pack17.adb delete mode 100644 gcc/ada/s-pack17.ads delete mode 100644 gcc/ada/s-pack18.adb delete mode 100644 gcc/ada/s-pack18.ads delete mode 100644 gcc/ada/s-pack19.adb delete mode 100644 gcc/ada/s-pack19.ads delete mode 100644 gcc/ada/s-pack20.adb delete mode 100644 gcc/ada/s-pack20.ads delete mode 100644 gcc/ada/s-pack21.adb delete mode 100644 gcc/ada/s-pack21.ads delete mode 100644 gcc/ada/s-pack22.adb delete mode 100644 gcc/ada/s-pack22.ads delete mode 100644 gcc/ada/s-pack23.adb delete mode 100644 gcc/ada/s-pack23.ads delete mode 100644 gcc/ada/s-pack24.adb delete mode 100644 gcc/ada/s-pack24.ads delete mode 100644 gcc/ada/s-pack25.adb delete mode 100644 gcc/ada/s-pack25.ads delete mode 100644 gcc/ada/s-pack26.adb delete mode 100644 gcc/ada/s-pack26.ads delete mode 100644 gcc/ada/s-pack27.adb delete mode 100644 gcc/ada/s-pack27.ads delete mode 100644 gcc/ada/s-pack28.adb delete mode 100644 gcc/ada/s-pack28.ads delete mode 100644 gcc/ada/s-pack29.adb delete mode 100644 gcc/ada/s-pack29.ads delete mode 100644 gcc/ada/s-pack30.adb delete mode 100644 gcc/ada/s-pack30.ads delete mode 100644 gcc/ada/s-pack31.adb delete mode 100644 gcc/ada/s-pack31.ads delete mode 100644 gcc/ada/s-pack33.adb delete mode 100644 gcc/ada/s-pack33.ads delete mode 100644 gcc/ada/s-pack34.adb delete mode 100644 gcc/ada/s-pack34.ads delete mode 100644 gcc/ada/s-pack35.adb delete mode 100644 gcc/ada/s-pack35.ads delete mode 100644 gcc/ada/s-pack36.adb delete mode 100644 gcc/ada/s-pack36.ads delete mode 100644 gcc/ada/s-pack37.adb delete mode 100644 gcc/ada/s-pack37.ads delete mode 100644 gcc/ada/s-pack38.adb delete mode 100644 gcc/ada/s-pack38.ads delete mode 100644 gcc/ada/s-pack39.adb delete mode 100644 gcc/ada/s-pack39.ads delete mode 100644 gcc/ada/s-pack40.adb delete mode 100644 gcc/ada/s-pack40.ads delete mode 100644 gcc/ada/s-pack41.adb delete mode 100644 gcc/ada/s-pack41.ads delete mode 100644 gcc/ada/s-pack42.adb delete mode 100644 gcc/ada/s-pack42.ads delete mode 100644 gcc/ada/s-pack43.adb delete mode 100644 gcc/ada/s-pack43.ads delete mode 100644 gcc/ada/s-pack44.adb delete mode 100644 gcc/ada/s-pack44.ads delete mode 100644 gcc/ada/s-pack45.adb delete mode 100644 gcc/ada/s-pack45.ads delete mode 100644 gcc/ada/s-pack46.adb delete mode 100644 gcc/ada/s-pack46.ads delete mode 100644 gcc/ada/s-pack47.adb delete mode 100644 gcc/ada/s-pack47.ads delete mode 100644 gcc/ada/s-pack48.adb delete mode 100644 gcc/ada/s-pack48.ads delete mode 100644 gcc/ada/s-pack49.adb delete mode 100644 gcc/ada/s-pack49.ads delete mode 100644 gcc/ada/s-pack50.adb delete mode 100644 gcc/ada/s-pack50.ads delete mode 100644 gcc/ada/s-pack51.adb delete mode 100644 gcc/ada/s-pack51.ads delete mode 100644 gcc/ada/s-pack52.adb delete mode 100644 gcc/ada/s-pack52.ads delete mode 100644 gcc/ada/s-pack53.adb delete mode 100644 gcc/ada/s-pack53.ads delete mode 100644 gcc/ada/s-pack54.adb delete mode 100644 gcc/ada/s-pack54.ads delete mode 100644 gcc/ada/s-pack55.adb delete mode 100644 gcc/ada/s-pack55.ads delete mode 100644 gcc/ada/s-pack56.adb delete mode 100644 gcc/ada/s-pack56.ads delete mode 100644 gcc/ada/s-pack57.adb delete mode 100644 gcc/ada/s-pack57.ads delete mode 100644 gcc/ada/s-pack58.adb delete mode 100644 gcc/ada/s-pack58.ads delete mode 100644 gcc/ada/s-pack59.adb delete mode 100644 gcc/ada/s-pack59.ads delete mode 100644 gcc/ada/s-pack60.adb delete mode 100644 gcc/ada/s-pack60.ads delete mode 100644 gcc/ada/s-pack61.adb delete mode 100644 gcc/ada/s-pack61.ads delete mode 100644 gcc/ada/s-pack62.adb delete mode 100644 gcc/ada/s-pack62.ads delete mode 100644 gcc/ada/s-pack63.adb delete mode 100644 gcc/ada/s-pack63.ads delete mode 100644 gcc/ada/s-parame-hpux.ads delete mode 100644 gcc/ada/s-parame-rtems.adb delete mode 100644 gcc/ada/s-parame-vxworks.adb delete mode 100644 gcc/ada/s-parame-vxworks.ads delete mode 100644 gcc/ada/s-parame.adb delete mode 100644 gcc/ada/s-parame.ads delete mode 100644 gcc/ada/s-parint.adb delete mode 100644 gcc/ada/s-parint.ads delete mode 100644 gcc/ada/s-pooglo.adb delete mode 100644 gcc/ada/s-pooglo.ads delete mode 100644 gcc/ada/s-pooloc.adb delete mode 100644 gcc/ada/s-pooloc.ads delete mode 100644 gcc/ada/s-poosiz.adb delete mode 100644 gcc/ada/s-poosiz.ads delete mode 100644 gcc/ada/s-powtab.ads delete mode 100644 gcc/ada/s-purexc.ads delete mode 100644 gcc/ada/s-rannum.adb delete mode 100644 gcc/ada/s-rannum.ads delete mode 100644 gcc/ada/s-ransee.adb delete mode 100644 gcc/ada/s-ransee.ads delete mode 100644 gcc/ada/s-regexp.adb delete mode 100644 gcc/ada/s-regexp.ads delete mode 100644 gcc/ada/s-regpat.adb delete mode 100644 gcc/ada/s-regpat.ads delete mode 100644 gcc/ada/s-resfil.adb delete mode 100644 gcc/ada/s-resfil.ads delete mode 100644 gcc/ada/s-restri.adb delete mode 100644 gcc/ada/s-restri.ads delete mode 100644 gcc/ada/s-rident.ads delete mode 100644 gcc/ada/s-rpc.adb delete mode 100644 gcc/ada/s-rpc.ads delete mode 100644 gcc/ada/s-scaval.adb delete mode 100644 gcc/ada/s-scaval.ads delete mode 100644 gcc/ada/s-secsta.adb delete mode 100644 gcc/ada/s-secsta.ads delete mode 100644 gcc/ada/s-sequio.adb delete mode 100644 gcc/ada/s-sequio.ads delete mode 100644 gcc/ada/s-shasto.adb delete mode 100644 gcc/ada/s-shasto.ads delete mode 100644 gcc/ada/s-soflin.adb delete mode 100644 gcc/ada/s-soflin.ads delete mode 100644 gcc/ada/s-sopco3.adb delete mode 100644 gcc/ada/s-sopco3.ads delete mode 100644 gcc/ada/s-sopco4.adb delete mode 100644 gcc/ada/s-sopco4.ads delete mode 100644 gcc/ada/s-sopco5.adb delete mode 100644 gcc/ada/s-sopco5.ads delete mode 100644 gcc/ada/s-spsufi.adb delete mode 100644 gcc/ada/s-spsufi.ads delete mode 100644 gcc/ada/s-stache.adb delete mode 100644 gcc/ada/s-stache.ads delete mode 100644 gcc/ada/s-stalib.adb delete mode 100644 gcc/ada/s-stalib.ads delete mode 100644 gcc/ada/s-stausa.adb delete mode 100644 gcc/ada/s-stausa.ads delete mode 100644 gcc/ada/s-stchop-limit.ads delete mode 100644 gcc/ada/s-stchop-rtems.adb delete mode 100644 gcc/ada/s-stchop-vxworks.adb delete mode 100644 gcc/ada/s-stchop.adb delete mode 100644 gcc/ada/s-stchop.ads delete mode 100644 gcc/ada/s-stoele.adb delete mode 100644 gcc/ada/s-stoele.ads delete mode 100644 gcc/ada/s-stopoo.adb delete mode 100644 gcc/ada/s-stopoo.ads delete mode 100644 gcc/ada/s-stposu.adb delete mode 100644 gcc/ada/s-stposu.ads delete mode 100644 gcc/ada/s-stratt-xdr.adb delete mode 100644 gcc/ada/s-stratt.adb delete mode 100644 gcc/ada/s-stratt.ads delete mode 100644 gcc/ada/s-strcom.adb delete mode 100644 gcc/ada/s-strcom.ads delete mode 100644 gcc/ada/s-strhas.adb delete mode 100644 gcc/ada/s-strhas.ads delete mode 100644 gcc/ada/s-string.adb delete mode 100644 gcc/ada/s-string.ads delete mode 100644 gcc/ada/s-strops.adb delete mode 100644 gcc/ada/s-strops.ads delete mode 100644 gcc/ada/s-ststop.adb delete mode 100644 gcc/ada/s-ststop.ads delete mode 100644 gcc/ada/s-tasloc.adb delete mode 100644 gcc/ada/s-tasloc.ads delete mode 100644 gcc/ada/s-traceb-hpux.adb delete mode 100644 gcc/ada/s-traceb-mastop.adb delete mode 100644 gcc/ada/s-traceb.adb delete mode 100644 gcc/ada/s-traceb.ads delete mode 100644 gcc/ada/s-traent.adb delete mode 100644 gcc/ada/s-traent.ads delete mode 100644 gcc/ada/s-trasym-dwarf.adb delete mode 100644 gcc/ada/s-trasym.adb delete mode 100644 gcc/ada/s-trasym.ads delete mode 100644 gcc/ada/s-tsmona-linux.adb delete mode 100644 gcc/ada/s-tsmona-mingw.adb delete mode 100644 gcc/ada/s-unstyp.ads delete mode 100644 gcc/ada/s-utf_32.adb delete mode 100644 gcc/ada/s-utf_32.ads delete mode 100644 gcc/ada/s-valboo.adb delete mode 100644 gcc/ada/s-valboo.ads delete mode 100644 gcc/ada/s-valcha.adb delete mode 100644 gcc/ada/s-valcha.ads delete mode 100644 gcc/ada/s-valdec.adb delete mode 100644 gcc/ada/s-valdec.ads delete mode 100644 gcc/ada/s-valenu.adb delete mode 100644 gcc/ada/s-valenu.ads delete mode 100644 gcc/ada/s-valint.adb delete mode 100644 gcc/ada/s-valint.ads delete mode 100644 gcc/ada/s-vallld.adb delete mode 100644 gcc/ada/s-vallld.ads delete mode 100644 gcc/ada/s-vallli.adb delete mode 100644 gcc/ada/s-vallli.ads delete mode 100644 gcc/ada/s-valllu.adb delete mode 100644 gcc/ada/s-valllu.ads delete mode 100644 gcc/ada/s-valrea.adb delete mode 100644 gcc/ada/s-valrea.ads delete mode 100644 gcc/ada/s-valuns.adb delete mode 100644 gcc/ada/s-valuns.ads delete mode 100644 gcc/ada/s-valuti.adb delete mode 100644 gcc/ada/s-valuti.ads delete mode 100644 gcc/ada/s-valwch.adb delete mode 100644 gcc/ada/s-valwch.ads delete mode 100644 gcc/ada/s-veboop.adb delete mode 100644 gcc/ada/s-veboop.ads delete mode 100644 gcc/ada/s-vector.ads delete mode 100644 gcc/ada/s-vercon.adb delete mode 100644 gcc/ada/s-vercon.ads delete mode 100644 gcc/ada/s-wchcnv.adb delete mode 100644 gcc/ada/s-wchcnv.ads delete mode 100644 gcc/ada/s-wchcon.adb delete mode 100644 gcc/ada/s-wchcon.ads delete mode 100644 gcc/ada/s-wchjis.adb delete mode 100644 gcc/ada/s-wchjis.ads delete mode 100644 gcc/ada/s-wchstw.adb delete mode 100644 gcc/ada/s-wchstw.ads delete mode 100644 gcc/ada/s-wchwts.adb delete mode 100644 gcc/ada/s-wchwts.ads delete mode 100644 gcc/ada/s-widboo.adb delete mode 100644 gcc/ada/s-widboo.ads delete mode 100644 gcc/ada/s-widcha.adb delete mode 100644 gcc/ada/s-widcha.ads delete mode 100644 gcc/ada/s-widenu.adb delete mode 100644 gcc/ada/s-widenu.ads delete mode 100644 gcc/ada/s-widlli.adb delete mode 100644 gcc/ada/s-widlli.ads delete mode 100644 gcc/ada/s-widllu.adb delete mode 100644 gcc/ada/s-widllu.ads delete mode 100644 gcc/ada/s-widwch.adb delete mode 100644 gcc/ada/s-widwch.ads delete mode 100644 gcc/ada/s-win32.ads delete mode 100644 gcc/ada/s-winext.ads delete mode 100644 gcc/ada/s-wwdcha.adb delete mode 100644 gcc/ada/s-wwdcha.ads delete mode 100644 gcc/ada/s-wwdenu.adb delete mode 100644 gcc/ada/s-wwdenu.ads delete mode 100644 gcc/ada/s-wwdwch.adb delete mode 100644 gcc/ada/s-wwdwch.ads delete mode 100644 gcc/ada/sequenio.ads delete mode 100644 gcc/ada/system-aix.ads delete mode 100644 gcc/ada/system-darwin-arm.ads delete mode 100644 gcc/ada/system-darwin-ppc.ads delete mode 100644 gcc/ada/system-darwin-x86.ads delete mode 100644 gcc/ada/system-djgpp.ads delete mode 100644 gcc/ada/system-dragonfly-x86_64.ads delete mode 100644 gcc/ada/system-freebsd.ads delete mode 100644 gcc/ada/system-hpux-ia64.ads delete mode 100644 gcc/ada/system-hpux.ads delete mode 100644 gcc/ada/system-linux-alpha.ads delete mode 100644 gcc/ada/system-linux-arm.ads delete mode 100644 gcc/ada/system-linux-hppa.ads delete mode 100644 gcc/ada/system-linux-ia64.ads delete mode 100644 gcc/ada/system-linux-m68k.ads delete mode 100644 gcc/ada/system-linux-mips.ads delete mode 100644 gcc/ada/system-linux-ppc.ads delete mode 100644 gcc/ada/system-linux-s390.ads delete mode 100644 gcc/ada/system-linux-sh4.ads delete mode 100644 gcc/ada/system-linux-sparc.ads delete mode 100644 gcc/ada/system-linux-x86.ads delete mode 100644 gcc/ada/system-mingw.ads delete mode 100644 gcc/ada/system-rtems.ads delete mode 100644 gcc/ada/system-solaris-sparc.ads delete mode 100644 gcc/ada/system-solaris-x86.ads delete mode 100644 gcc/ada/system-vxworks-arm.ads delete mode 100644 gcc/ada/system-vxworks-ppc.ads delete mode 100644 gcc/ada/system-vxworks-x86.ads delete mode 100644 gcc/ada/system.ads delete mode 100644 gcc/ada/text_io.ads delete mode 100644 gcc/ada/unchconv.ads delete mode 100644 gcc/ada/unchdeal.ads (limited to 'gcc') diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 113cbca..7b3ab76 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,282 @@ +2017-09-08 Nicolas Roche + + * gcc-interface/Make-lang.in, gcc-interface/Makefile.in: Find runtime + source in libgnat/ + * a-lfztio.ads, g-timsta.ads, g-sercom-linux.adb, s-osprim-solaris.adb, + a-inteio.ads, s-stchop-rtems.adb, s-casuti.adb, s-pack39.adb, + i-vxwork-x86.ads, a-strbou.adb, a-stzmap.adb, s-assert.adb, + a-sfecin.ads, a-cohama.adb, s-casuti.ads, a-suenco.adb, s-pack39.ads, + a-stzmap.ads, a-strbou.ads, s-stalib.adb, s-trasym.adb, g-comver.adb, + s-assert.ads, s-vector.ads, g-cgi.adb, a-cohama.ads, s-wchcnv.adb, + a-titest.adb, s-pack48.adb, a-suenco.ads, a-strunb.adb, s-stalib.ads, + s-trasym.ads, a-nudira.adb, g-comver.ads, a-nuflra.adb, g-cgi.ads, + a-chacon.adb, s-wchcnv.ads, a-excach.adb, s-pack48.ads, a-titest.ads, + a-strunb.ads, s-dwalin.adb, a-nudira.ads, a-chtgbo.adb, s-resfil.adb, + a-scteio.ads, a-nuflra.ads, g-soliop-mingw.ads, s-pack57.adb, + a-chacon.ads, s-bytswa.ads, s-pooloc.adb, g-os_lib.adb, s-dwalin.ads, + a-szuzha.adb, s-resfil.ads, a-chtgbo.ads, s-spsufi.adb, s-pack57.ads, + s-pooloc.ads, g-os_lib.ads, a-stfiha.ads, a-lcteio.ads, a-wtcoau.adb, + a-szuzha.ads, s-mmosin-unix.adb, a-stmaco.ads, s-spsufi.ads, + s-stchop-limit.ads, a-wtcoau.ads, a-exctra.adb, s-mmosin-unix.ads, + s-sequio.adb, s-conca2.adb, g-table.adb, s-imglli.adb, + a-numaux-x86.adb, a-strsea.adb, s-wchstw.adb, a-clrefi.adb, + a-wwboio.adb, a-exctra.ads, s-sequio.ads, s-conca2.ads, a-wwunio.ads, + system-linux-hppa.ads, g-table.ads, s-dimkio.ads, s-imglli.ads, + a-cofove.adb, a-numaux-x86.ads, s-wchstw.ads, a-strsea.ads, + a-clrefi.ads, a-wwboio.ads, s-stratt-xdr.adb, s-crc32.adb, + s-excmac-arm.adb, g-busora.adb, a-cofove.ads, s-osprim-unix.adb, + g-io.adb, s-pack49.adb, s-crc32.ads, s-excmac-arm.ads, a-fzteio.ads, + g-busora.ads, s-stausa.adb, system-linux-mips.ads, sequenio.ads, + g-exctra.adb, g-rewdat.adb, a-cgaaso.adb, g-io.ads, s-pack49.ads, + a-wtflau.adb, a-undesu.adb, s-stausa.ads, a-ztenau.adb, g-enutst.ads, + calendar.ads, s-pack58.adb, g-rewdat.ads, g-exctra.ads, s-ststop.adb, + a-cgaaso.ads, a-strfix.adb, a-comlin.adb, a-strunb-shared.adb, + a-wtflau.ads, a-undesu.ads, a-cbhase.adb, a-ztenau.ads, s-os_lib.adb, + a-coorse.adb, a-chlat1.ads, s-pack58.ads, s-ststop.ads, a-strfix.ads, + a-comlin.ads, a-strunb-shared.ads, a-nscefu.ads, s-valboo.adb, + directio.ads, a-chtgke.adb, a-cbhase.ads, a-wtinau.adb, + system-linux-alpha.ads, s-os_lib.ads, a-coorse.ads, + system-linux-s390.ads, s-imgwiu.adb, a-chtgop.adb, s-valboo.ads, + a-chtgke.ads, a-tienio.adb, s-conca3.adb, a-wtinau.ads, + system-darwin-ppc.ads, i-c.adb, s-expllu.adb, g-expect.adb, + g-sha256.ads, s-vallld.adb, s-imgwiu.ads, a-chtgop.ads, a-strmap.adb, + a-tienio.ads, s-conca3.ads, s-imgint.adb, i-c.ads, s-expllu.ads, + s-osprim-darwin.adb, a-cogeso.adb, g-expect.ads, a-iwteio.ads, + s-vallld.ads, a-coinho-shared.adb, g-shsh64.adb, a-strmap.ads, + g-comlin.adb, a-excpol.adb, s-imgint.ads, a-ztdeau.adb, a-cogeso.ads, + a-coinho-shared.ads, g-shsh64.ads, g-comlin.ads, a-stzsup.adb, + a-rbtgbk.adb, a-wtmoau.adb, a-ztdeau.ads, s-exnlli.adb, g-tty.adb, + g-heasor.adb, g-socthi-dummy.adb, s-llflex.ads, a-zchara.ads, + a-stzsup.ads, a-ztcstr.adb, a-rbtgbk.ads, a-sfwtio.ads, a-wtmoau.ads, + a-sulcin.adb, s-exnlli.ads, system-freebsd.ads, a-stunha.adb, + a-charac.ads, g-tty.ads, g-heasor.ads, s-exctra.adb, + g-socthi-dummy.ads, a-coboho.adb, a-ztcstr.ads, a-tideio.adb, + a-sulcin.ads, a-wrstfi.adb, g-alleve.adb, s-pack59.adb, a-ngrear.adb, + a-stboha.adb, a-stunau-shared.adb, a-stunha.ads, a-lfwtio.ads, + s-fileio.adb, s-exctra.ads, a-coboho.ads, a-ioexce.ads, a-tideio.ads, + a-ngrear.ads, a-wrstfi.ads, s-pack59.ads, g-alleve.ads, a-stboha.ads, + s-poosiz.adb, g-traceb.adb, g-rannum.adb, machcode.ads, s-purexc.ads, + s-fileio.ads, a-cfinve.adb, a-crbtgk.adb, system-solaris-x86.ads, + s-poosiz.ads, g-rannum.ads, g-traceb.ads, a-except.adb, s-conca4.adb, + a-stream.adb, a-cfinve.ads, a-crbtgk.ads, s-wchwts.adb, + system-mingw.ads, a-except.ads, s-conca4.ads, a-chzla9.ads, + s-valenu.adb, s-soflin.adb, a-stream.ads, a-cgarso.adb, s-valllu.adb, + g-crc32.adb, s-wchwts.ads, s-fatflt.ads, s-imguns.adb, s-strcom.adb, + g-decstr.adb, s-valenu.ads, s-soflin.ads, a-cgarso.ads, a-cwila1.ads, + s-valllu.ads, g-crc32.ads, s-imguns.ads, g-spipat.adb, s-valwch.adb, + s-strcom.ads, g-decstr.ads, text_io.ads, g-debuti.adb, s-stchop.adb, + g-spipat.ads, s-valwch.ads, a-string.ads, s-exnint.adb, g-awk.adb, + g-tasloc.adb, s-wwdenu.adb, s-boustr.adb, a-zchuni.adb, s-stchop.ads, + g-debuti.ads, s-stopoo.adb, system-dragonfly-x86_64.ads, + system-linux-x86.ads, s-exnint.ads, g-awk.ads, a-stzhas.adb, + g-tasloc.ads, s-wwdenu.ads, g-debpoo.adb, g-except.ads, + g-sse.ads, s-boustr.ads, a-zchuni.ads, s-bitops.adb, s-wwdwch.adb, + s-stopoo.ads, a-catizo.adb, a-stzhas.ads, a-nlcefu.ads, g-debpoo.ads, + i-vxwoio.adb, s-bitops.ads, g-io-put-vxworks.adb, s-wwdwch.ads, + g-sehamd.adb, a-ssicst.adb, a-catizo.ads, s-mmap.adb, g-string.adb, + s-traceb.adb, a-swunau.adb, s-rannum.adb, a-ticoau.adb, i-vxwoio.ads, + g-sehamd.ads, a-stwiun.adb, a-ssicst.ads, s-conca5.adb, a-ssitio.ads, + s-mmap.ads, a-zttest.adb, g-string.ads, g-sercom.adb, a-cdlili.adb, + a-swunau.ads, s-traceb.ads, s-rannum.ads, a-ticoau.ads, system-aix.ads, + a-cforma.adb, a-stwiun.ads, s-conca5.ads, s-carsi8.adb, a-zttest.ads, + g-sercom.ads, a-cdlili.ads, a-cihama.adb, g-sptain.ads, a-cforma.ads, + s-maccod.ads, s-carsi8.ads, a-strsup.adb, g-sha1.adb, a-cihama.ads, + g-stseme.adb, s-traent.adb, s-valcha.adb, g-curexc.ads, a-strsup.ads, + g-sha1.ads, a-sflcin.ads, s-traent.ads, s-pack10.adb, s-valcha.ads, + a-coteio.ads, s-tasloc.adb, g-utf_32.adb, a-suteio.adb, s-except.adb, + a-direct.adb, g-stsifd-sockets.adb, a-numaux-vxworks.ads, s-winext.ads, + s-pack10.ads, a-ztexio.adb, a-tiflau.adb, system-vxworks-arm.ads, + s-tasloc.ads, a-suteio.ads, g-utf_32.ads, s-except.ads, + a-direct.ads, a-swbwha.adb, g-hesorg.adb, s-wwdcha.adb, a-wtedit.adb, + a-ztexio.ads, a-wtcoio.adb, a-tiflau.ads, a-ssizti.ads, s-casi32.adb, + a-swbwha.ads, s-veboop.adb, g-hesorg.ads, s-parame-rtems.adb, + s-wwdcha.ads, a-wtedit.ads, a-stuten.adb, a-coinve.adb, a-wtcoio.ads, + s-casi32.ads, s-string.adb, a-tiinau.adb, a-cusyqu.adb, s-conca6.adb, + s-veboop.ads, a-cgcaso.adb, a-numaux-darwin.adb, a-envvar.adb, + a-stuten.ads, s-secsta.adb, a-coinve.ads, s-string.ads, a-cusyqu.ads, + a-tiinau.ads, s-osprim-vxworks.adb, s-conca6.ads, g-spchge.adb, + s-parint.adb, a-cuprqu.adb, a-cgcaso.ads, a-numaux-darwin.ads, + a-envvar.ads, s-secsta.ads, g-spchge.ads, s-parint.ads, a-cuprqu.ads, + a-swuwti.adb, a-flteio.ads, a-sbhcin.adb, a-coprnu.adb, g-u3spch.adb, + s-atocou.adb, g-ctrl_c.adb, a-swuwti.ads, a-calend.adb, a-sbhcin.ads, + a-coprnu.ads, g-dirope.adb, g-sha512.ads, g-u3spch.ads, s-atocou.ads, + g-ctrl_c.ads, a-timoau.adb, a-witeio.adb, s-pack11.adb, a-strhas.adb, + a-wtflio.adb, g-spitbo.adb, a-calend.ads, a-ztenio.adb, g-dirope.ads, + a-slcain.adb, g-sechas.adb, a-timoau.ads, a-witeio.ads, s-pack11.ads, + s-shasto.adb, s-traceb-mastop.adb, a-ciorse.adb, s-utf_32.adb, + a-strhas.ads, a-wtflio.ads, g-spitbo.ads, a-ztenio.ads, a-slcain.ads, + g-sechas.ads, s-gearop.adb, a-siztio.ads, s-pack20.adb, s-shasto.ads, + a-ciorse.ads, s-utf_32.ads, s-crtl.ads, a-wtinio.adb, s-elaall.adb, + s-explli.adb, s-chepoo.ads, s-gearop.ads, a-einuoc.adb, s-pack20.ads, + system-linux-ia64.ads, a-swunau-shared.adb, a-wtinio.ads, g-alvety.ads, + a-liztio.ads, g-calend.adb, s-conca7.adb, s-elaall.ads, s-explli.ads, + a-einuoc.ads, s-widboo.adb, s-imgdec.adb, a-cbhama.adb, g-calend.ads, + s-conca7.ads, a-llitio.ads, i-cexten.ads, a-coorma.adb, s-widboo.ads, + s-diflio.adb, g-souinf.ads, s-imgdec.ads, g-strhas.ads, a-cbhama.ads, + g-shshco.adb, a-ztdeio.adb, s-gloloc.adb, a-coorma.ads, g-wispch.adb, + s-pack03.adb, g-eacodu.adb, s-casi16.adb, s-diflio.ads, a-colien.adb, + g-shshco.ads, a-wtmoio.adb, a-rbtgbo.adb, a-ztdeio.ads, + system-rtems.ads, s-gloloc.ads, a-csquin.ads, a-cofuse.adb, + g-wispch.ads, s-pack03.ads, s-casi16.ads, s-io.adb, a-colien.ads, + g-alveop.adb, gnat.ads, s-diinio.adb, a-cfdlli.adb, g-pehage.adb, + a-wtmoio.ads, a-stwiha.adb, a-locale.adb, a-tirsfi.adb, a-nscoty.ads, + a-rbtgbo.ads, s-pack12.adb, a-cofuse.ads, a-sfteio.ads, s-io.ads, + g-alveop.ads, a-cfdlli.ads, s-diinio.ads, a-stwiha.ads, g-pehage.ads, + a-locale.ads, a-tirsfi.ads, s-pack12.ads, s-valuti.adb, g-cppexc.adb, + system-vxworks-ppc.ads, g-memdum.adb, a-lfteio.ads, s-pack21.adb, + s-unstyp.ads, s-valuti.ads, g-cppexc.ads, system-hpux-ia64.ads, + g-memdum.ads, g-soccon.ads, g-altive.ads, a-crbtgo.adb, s-pack21.ads, + a-llizti.ads, a-numaux-libc-x86.ads, s-expint.adb, s-conca8.adb, + a-crbtgo.ads, s-pack30.adb, s-vallli.adb, s-geveop.adb, s-expint.ads, + a-direio.adb, s-conca8.ads, a-widcha.ads, s-pack30.ads, s-vallli.ads, + s-strhas.adb, s-geveop.ads, g-md5.adb, a-direio.ads, a-numaux.ads, + s-ransee.adb, a-szbzha.adb, i-cobol.adb, g-busorg.adb, s-strhas.ads, + g-md5.ads, s-widenu.adb, s-ransee.ads, s-widllu.adb, a-szbzha.ads, + a-ststio.adb, i-cobol.ads, g-busorg.ads, g-regpat.adb, s-widenu.ads, + a-secain.adb, s-widllu.ads, s-pack13.adb, g-encstr.adb, a-ztcoau.adb, + a-ststio.ads, s-widwch.adb, g-regpat.ads, s-atacco.adb, a-cborse.adb, + a-secain.ads, s-pack13.ads, g-encstr.ads, a-ztcoau.ads, s-widwch.ads, + g-io_aux.adb, s-atacco.ads, a-ncelfu.ads, interfac.ads, a-cborse.ads, + g-regexp.adb, s-pack22.adb, a-szuzti.adb, g-io_aux.ads, s-caun32.adb, + a-nselfu.ads, g-regexp.ads, s-pack22.ads, a-ticoio.adb, a-szuzti.ads, + g-diopit.adb, s-caun32.ads, s-conca9.adb, a-tags.adb, a-swmwco.ads, + a-sbecin.adb, s-pack31.adb, s-expuns.adb, a-ticoio.ads, s-valint.adb, + s-conca9.ads, g-diopit.ads, a-tags.ads, a-nllcef.ads, a-izteio.ads, + a-sbecin.ads, s-expuns.ads, s-pack31.ads, g-dyntab.adb, s-powtab.ads, + s-flocon-none.adb, s-valint.ads, a-ssiwti.ads, s-mmosin-mingw.adb, + s-pack40.adb, s-pack05.adb, a-ztflau.adb, g-dyntab.ads, + a-szuzti-shared.adb, g-alvevi.ads, a-stwise.adb, s-mmosin-mingw.ads, + s-pack40.ads, a-diocst.adb, a-ztflau.ads, s-pack05.ads, a-nlcoty.ads, + a-contai.ads, a-stwisu.adb, g-byorma.adb, a-siwtio.ads, a-stwise.ads, + s-regpat.adb, g-mbdira.adb, s-pack14.adb, a-diocst.ads, g-flocon.ads, + g-mbflra.adb, a-ztinau.adb, s-dim.ads, s-mantis.adb, a-stwisu.ads, + g-byorma.ads, s-atopri.adb, g-wistsp.ads, a-uncdea.ads, s-widcha.adb, + a-caldel.adb, s-regpat.ads, g-mbdira.ads, a-tiflio.adb, s-pack14.ads, + s-parame.adb, a-liwtio.ads, s-memory.adb, g-mbflra.ads, a-ztinau.ads, + a-wtgeau.adb, s-direio.adb, s-mantis.ads, s-atopri.ads, s-widcha.ads, + a-caldel.ads, s-pack23.adb, a-unccon.ads, a-tiflio.ads, s-parame.ads, + a-llftio.ads, s-memory.ads, s-regexp.adb, a-wtgeau.ads, a-exexda.adb, + s-direio.ads, s-pack23.ads, g-stheme.adb, a-tiinio.adb, g-sestin.ads, + s-regexp.ads, a-wtfiio.adb, a-comutr.adb, a-exexpr.adb, a-tiinio.ads, + a-ztmoau.adb, a-cohata.ads, a-wtfiio.ads, s-imgrea.adb, ada.ads, + a-szunau-shared.adb, a-comutr.ads, s-valuns.adb, a-ztmoau.ads, + system-linux-arm.ads, s-osprim-x32.adb, s-pack41.adb, s-pack06.adb, + s-imgrea.ads, s-valuns.ads, s-finroo.adb, s-caun16.adb, s-pooglo.adb, + a-zrstfi.adb, a-suenst.adb, s-pack41.ads, g-binenv.adb, s-pack06.ads, + a-calari.adb, a-nlcoar.ads, s-finroo.ads, a-timoio.adb, s-caun16.ads, + s-flocon.adb, a-suenst.ads, a-zrstfi.ads, s-pooglo.ads, s-wchcon.adb, + s-traceb-hpux.adb, s-pack50.adb, i-fortra.adb, s-pack15.adb, + a-ngcefu.adb, g-sptavs.ads, g-binenv.ads, s-wchjis.adb, a-calari.ads, + a-timoio.ads, a-decima.adb, s-flocon.ads, s-wchcon.ads, a-llfzti.ads, + i-fortra.ads, s-pack50.ads, s-pack15.ads, a-ngcefu.ads, a-cfhase.adb, + s-wchjis.ads, g-soliop.ads, a-decima.ads, a-chlat9.ads, s-pack24.adb, + a-nlelfu.ads, a-cfhase.ads, g-locfil.adb, s-atocou-builtin.adb, + s-memcop.ads, a-szunau.adb, s-pack24.ads, s-imgllb.adb, s-auxdec.adb, + g-locfil.ads, s-pack33.adb, a-szunau.ads, s-parame-vxworks.adb, + s-imgllb.ads, a-ciorma.adb, s-auxdec.ads, a-cobove.adb, s-dsaser.ads, + a-elchha.adb, s-pack33.ads, a-cofuve.adb, s-parame-vxworks.ads, + a-ciorma.ads, system-darwin-x86.ads, s-multip.adb, a-stwiun-shared.adb, + a-wichun.adb, a-cobove.ads, s-imgbiu.adb, s-tsmona-mingw.adb, + a-coormu.adb, a-siocst.adb, s-win32.ads, a-elchha.ads, s-pack42.adb, + s-pack07.adb, a-cofuve.ads, system-hpux.ads, a-teioed.adb, + a-convec.adb, g-speche.adb, s-multip.ads, a-stwiun-shared.ads, + a-wichun.ads, s-imgbiu.ads, a-numeri.ads, a-siocst.ads, a-coormu.ads, + a-lliwti.ads, s-pack42.ads, s-pack07.ads, a-teioed.ads, a-convec.ads, + g-speche.ads, g-socthi.adb, a-nucoty.ads, a-szmzco.ads, s-pack51.adb, + s-osprim-mingw.adb, s-casi64.adb, g-strspl.ads, g-socthi.ads, + g-socket-dummy.adb, s-pack51.ads, s-dimmks.ads, s-casi64.ads, + a-wtenau.adb, s-stchop-vxworks.adb, s-pack60.adb, + system-solaris-sparc.ads, s-pack25.adb, g-socket-dummy.ads, + a-exstat.adb, a-cofuma.adb, s-tsmona-linux.adb, a-wtenau.ads, + s-pack60.ads, s-pack25.ads, i-cstrea.adb, a-cofuma.ads, g-exptty.adb, + a-chzla1.ads, s-pack34.adb, i-cstrea.ads, s-excdeb.adb, a-iteint.ads, + g-exptty.ads, i-pacdec.adb, s-pack34.ads, s-rident.ads, s-sopco3.adb, + i-vxwork.ads, s-excdeb.ads, system-linux-ppc.ads, a-swuwti-shared.adb, + s-widlli.adb, s-pack43.adb, i-pacdec.ads, a-cwila9.ads, s-sopco3.ads, + a-fwteio.ads, s-widlli.ads, s-pack43.ads, a-suhcin.adb, a-wtdeau.adb, + g-allein.ads, a-suezst.adb, a-dirval-mingw.adb, g-zspche.adb, + s-bignum.adb, a-ztedit.adb, g-regist.adb, a-nllefu.ads, a-ztcoio.adb, + s-pack52.adb, a-llctio.ads, a-nucoar.ads, s-pack17.adb, a-suhcin.ads, + a-wtdeau.ads, a-suezst.ads, a-dirval.adb, g-zspche.ads, g-regist.ads, + a-ztedit.ads, s-bignum.ads, a-wtcstr.adb, system.ads, s-pack52.ads, + a-ztcoio.ads, s-pack17.ads, s-imgboo.adb, a-rbtgso.adb, a-dirval.ads, + a-cohase.adb, s-pack61.adb, a-wtcstr.ads, s-pack26.adb, s-osprim.ads, + a-tigeau.adb, s-imgboo.ads, a-nuelfu.ads, a-swfwha.ads, s-commun.adb, + g-socthi-vxworks.adb, a-rbtgso.ads, a-cohase.ads, g-zstspl.ads, + s-pack61.ads, s-pack26.ads, a-intnam-dragonfly.ads, s-imglld.adb, + a-tigeau.ads, s-commun.ads, g-socthi-vxworks.ads, a-cborma.adb, + a-stwifi.adb, g-moreex.adb, s-pack35.adb, s-imglld.ads, s-valdec.adb, + a-tifiio.adb, a-cborma.ads, g-moreex.ads, a-stwifi.ads, s-pack35.ads, + s-sopco4.adb, g-sha224.ads, g-socket.adb, a-intnam-rtems.ads, + s-finmas.adb, s-valdec.ads, s-addima.adb, a-finali.adb, a-tifiio.ads, + s-rpc.adb, a-ztflio.adb, s-pack44.adb, s-pack09.adb, a-sblcin.adb, + s-sopco4.ads, a-textio.adb, g-socket.ads, g-sptabo.ads, s-finmas.ads, + g-shsh32.adb, s-addima.ads, a-finali.ads, s-mmauni-long.ads, s-rpc.ads, + a-ztflio.ads, system-djgpp.ads, s-stache.adb, s-pack44.ads, + s-pack09.ads, a-sblcin.ads, a-textio.ads, a-cidlli.adb, g-shsh32.ads, + a-chtgbk.adb, a-tiocst.adb, s-pack53.adb, s-pack18.adb, s-stache.ads, + a-zchhan.adb, s-fatlfl.ads, a-ztinio.adb, s-strops.adb, a-siteio.ads, + a-cidlli.ads, a-chtgbk.ads, g-ssvety.ads, a-tiocst.ads, s-pack53.ads, + s-parame-hpux.ads, s-pack18.ads, a-zchhan.ads, s-strops.ads, + a-ztinio.ads, a-wichha.adb, a-stwima.adb, a-nlrear.ads, a-liteio.ads, + s-pack62.adb, s-pack27.adb, s-fore.adb, s-vercon.adb, a-wichha.ads, + a-stwima.ads, s-pack62.ads, system-linux-sparc.ads, s-pack27.ads, + g-dynhta.adb, s-fore.ads, s-vercon.ads, a-cofuba.adb, a-cimutr.adb, + i-cpoint.adb, s-imgenu.adb, a-stwibo.adb, s-pack36.adb, i-cstrin.adb, + s-imgllu.adb, a-suteio-shared.adb, g-excact.adb, s-stoele.adb, + s-addope.adb, g-dynhta.ads, a-cofuba.ads, a-ztmoio.adb, a-llfwti.ads, + a-cimutr.ads, i-cpoint.ads, s-imgenu.ads, a-stwibo.ads, a-wttest.adb, + s-pack36.ads, a-tgdico.ads, s-sopco5.adb, s-scaval.adb, i-cstrin.ads, + s-imgllu.ads, g-excact.ads, s-stoele.ads, g-deutst.ads, s-addope.ads, + s-imgwch.adb, g-sha384.ads, a-ztmoio.ads, s-pack45.adb, a-wttest.ads, + s-sopco5.ads, s-excmac-gcc.adb, s-scaval.ads, a-storio.adb, + a-coinho.adb, a-btgbso.adb, s-imgwch.ads, s-carun8.adb, memtrack.adb, + s-pack45.ads, a-sfhcin.ads, s-excmac-gcc.ads, a-storio.ads, + a-coinho.ads, a-btgbso.ads, s-stratt.adb, s-carun8.ads, a-shcain.adb, + s-pack54.adb, s-pack19.adb, a-colire.adb, a-tigeli.adb, s-caun64.adb, + s-stratt.ads, s-fatgen.adb, a-shcain.ads, a-stzunb-shared.adb, + s-pack54.ads, s-pack19.ads, a-colire.ads, a-calcon.adb, s-caun64.ads, + s-fatgen.ads, s-pack63.adb, g-arrspl.adb, a-stzunb-shared.ads, + s-pack28.adb, a-nllrar.ads, a-zzboio.adb, a-zzunio.ads, a-stunau.adb, + a-calcon.ads, g-cgideb.adb, s-objrea.adb, s-mastop.adb, a-tienau.adb, + g-altcon.adb, g-arrspl.ads, s-pack63.ads, s-restri.adb, s-pack28.ads, + a-zzboio.ads, a-stunau.ads, g-cgideb.ads, g-htable.adb, g-sothco.adb, + s-objrea.ads, g-soliop-solaris.ads, s-mastop.ads, a-tienau.ads, + system-linux-m68k.ads, g-altcon.ads, s-dmotpr.ads, s-memory-mingw.adb, + g-cgicoo.adb, s-pack37.adb, s-restri.ads, s-fatllf.ads, s-expmod.adb, + a-swuwha.adb, a-exextr.adb, a-cfhama.adb, s-gloloc-mingw.adb, + a-tiboio.adb, g-forstr.adb, g-sothco.ads, a-stzbou.adb, a-nllcty.ads, + a-suecin.adb, g-htable.ads, s-exctab.adb, a-tiunio.ads, g-cgicoo.ads, + s-osprim-posix.adb, s-pack37.ads, a-ciormu.adb, s-atocou-x86.adb, + a-swuwha.ads, s-expmod.ads, a-cfhama.ads, s-ficobl.ads, a-ngcoty.adb, + g-forstr.ads, a-tiboio.ads, a-calfor.adb, a-stzbou.ads, a-suecin.ads, + a-conhel.adb, a-crbltr.ads, s-exctab.ads, a-dhfina.ads, s-imgcha.adb, + s-pack46.adb, a-ciormu.ads, system-linux-sh4.ads, a-chahan.adb, + a-ngcoty.ads, a-stzunb.adb, a-szfzha.ads, a-calfor.ads, a-cbdlli.adb, + a-conhel.ads, s-imgcha.ads, s-pack46.ads, a-assert.adb, a-chahan.ads, + a-stzunb.ads, a-crdlli.adb, s-pack55.adb, a-cbdlli.ads, a-tideau.adb, + a-assert.ads, ioexcept.ads, s-boarop.ads, g-hesora.adb, a-crdlli.ads, + s-pack55.ads, a-tideau.ads, g-bubsor.adb, a-wtenio.adb, a-cbsyqu.adb, + g-hesora.ads, s-pack29.adb, a-nurear.ads, g-catiio.adb, s-stposu.adb, + g-bubsor.ads, a-wtenio.ads, a-cbsyqu.ads, a-suewst.adb, + system-vxworks-x86.ads, s-pack29.ads, a-cbmutr.adb, a-cbprqu.adb, + s-imenne.adb, g-sothco-dummy.adb, g-casuti.adb, g-catiio.ads, + s-stposu.ads, a-stzsea.adb, s-pack38.adb, a-suewst.ads, s-imgllw.adb, + a-cbprqu.ads, a-cbmutr.ads, s-imenne.ads, g-sothco-dummy.ads, + g-casuti.ads, s-htable.adb, s-fatsfl.ads, g-trasym.adb, unchconv.ads, + a-stzsea.ads, s-arit64.adb, s-pack38.ads, a-nllcar.ads, s-valrea.adb, + s-imgllw.ads, s-htable.ads, a-sequio.adb, g-trasym.ads, a-ngcoar.adb, + s-exnllf.adb, s-pack47.adb, s-arit64.ads, g-sercom-mingw.adb, + s-valrea.ads, g-socthi-mingw.adb, g-bytswa.adb, g-sehash.adb, + unchdeal.ads, a-sequio.ads, a-ngcoar.ads, s-exnllf.ads, a-wtdeio.adb, + s-pack47.ads, g-socthi-mingw.ads, a-excpol-abort.adb, a-ztgeau.adb, + g-bytswa.ads, g-sehash.ads, s-pack56.adb, a-wtdeio.ads, a-ngelfu.adb, + a-ztgeau.ads, a-cforse.adb, s-filatt.ads, a-stzfix.adb, a-cihase.adb, + s-pack56.ads, a-sfztio.ads, a-ngelfu.ads, s-trasym-dwarf.adb, + a-cforse.ads, a-ztfiio.adb, g-timsta.adb, a-stzfix.ads, a-cihase.ads, + a-ztfiio.ads, system-darwin-arm.ads: Move non-tasking runtime sources + to libgnat subdirectory. + 2017-09-08 Yannick Moy * sem_aux.adb, sem_aux.ads (Get_Called_Entity): New function to diff --git a/gcc/ada/a-assert.adb b/gcc/ada/a-assert.adb deleted file mode 100644 index bfdcd15..0000000 --- a/gcc/ada/a-assert.adb +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . A S S E R T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Assertions with - SPARK_Mode -is - ------------ - -- Assert -- - ------------ - - procedure Assert (Check : Boolean) is - begin - if Check = False then - raise Ada.Assertions.Assertion_Error; - end if; - end Assert; - - procedure Assert (Check : Boolean; Message : String) is - begin - if Check = False then - raise Ada.Assertions.Assertion_Error with Message; - end if; - end Assert; - -end Ada.Assertions; diff --git a/gcc/ada/a-assert.ads b/gcc/ada/a-assert.ads deleted file mode 100644 index d0ce6f0..0000000 --- a/gcc/ada/a-assert.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . A S S E R T I O N S -- --- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- --- -- --- S p e c -- --- -- --- 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 contracts that have been added. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Preconditions in this unit are meant for analysis only, not for run-time --- checking, so that the expected exceptions are raised when calling Assert. --- This is enforced by setting the corresponding assertion policy to Ignore. - -pragma Assertion_Policy (Pre => Ignore); - --- We do a with of System.Assertions to get hold of the exception (following --- the specific RM permission that lets' Assertion_Error being a renaming). --- The suppression of Warnings stops the warning about bad categorization. - -pragma Warnings (Off); -with System.Assertions; -pragma Warnings (On); - -package Ada.Assertions with - SPARK_Mode -is - pragma Pure (Assertions); - - Assertion_Error : exception renames System.Assertions.Assert_Failure; - -- This is the renaming that is allowed by 11.4.2(24). Note that the - -- Exception_Name will refer to the one in System.Assertions (see - -- AARM-11.4.1(12.b)). - - procedure Assert (Check : Boolean) with - Pre => Check; - - procedure Assert (Check : Boolean; Message : String) with - Pre => Check; - -end Ada.Assertions; diff --git a/gcc/ada/a-btgbso.adb b/gcc/ada/a-btgbso.adb deleted file mode 100644 index 363b77e..0000000 --- a/gcc/ada/a-btgbso.adb +++ /dev/null @@ -1,703 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; use type System.Address; - -package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy (Source : Set_Type) return Set_Type; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set_Type) return Set_Type is - begin - return Target : Set_Type (Source.Length) do - Assign (Target => Target, Source => Source); - end return; - end Copy; - - ---------------- - -- Difference -- - ---------------- - - procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is - Tgt, Src : Count_Type; - - TN : Nodes_Type renames Target.Nodes; - SN : Nodes_Type renames Source.Nodes; - - Compare : Integer; - - begin - if Target'Address = Source'Address then - TC_Check (Target.TC); - - Tree_Operations.Clear_Tree (Target); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - TC_Check (Target.TC); - - Tgt := Target.First; - Src := Source.First; - loop - if Tgt = 0 then - exit; - end if; - - if Src = 0 then - exit; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (TN (Tgt), SN (Src)) then - Compare := -1; - elsif Is_Less (SN (Src), TN (Tgt)) then - Compare := 1; - else - Compare := 0; - end if; - end; - - if Compare < 0 then - Tgt := Tree_Operations.Next (Target, Tgt); - - elsif Compare > 0 then - Src := Tree_Operations.Next (Source, Src); - - else - declare - X : constant Count_Type := Tgt; - begin - Tgt := Tree_Operations.Next (Target, Tgt); - - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Tree_Operations.Free (Target, X); - end; - - Src := Tree_Operations.Next (Source, Src); - end if; - end loop; - end Set_Difference; - - function Set_Difference (Left, Right : Set_Type) return Set_Type is - begin - if Left'Address = Right'Address then - return S : Set_Type (0); -- Empty set - end if; - - if Left.Length = 0 then - return S : Set_Type (0); -- Empty set - end if; - - if Right.Length = 0 then - return Copy (Left); - end if; - - return Result : Set_Type (Left.Length) do - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - exit; - end if; - - if R_Node = 0 then - while L_Node /= 0 loop - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (Left, L_Node); - end loop; - - exit; - end if; - - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (Left, L_Node); - - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); - - else - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; - end; - end return; - end Set_Difference; - - ------------------ - -- Intersection -- - ------------------ - - procedure Set_Intersection - (Target : in out Set_Type; - Source : Set_Type) - is - Tgt : Count_Type; - Src : Count_Type; - - Compare : Integer; - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Target.TC); - - if Source.Length = 0 then - Tree_Operations.Clear_Tree (Target); - return; - end if; - - Tgt := Target.First; - Src := Source.First; - while Tgt /= 0 - and then Src /= 0 - loop - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then - Compare := -1; - elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then - Compare := 1; - else - Compare := 0; - end if; - end; - - if Compare < 0 then - declare - X : constant Count_Type := Tgt; - begin - Tgt := Tree_Operations.Next (Target, Tgt); - - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Tree_Operations.Free (Target, X); - end; - - elsif Compare > 0 then - Src := Tree_Operations.Next (Source, Src); - - else - Tgt := Tree_Operations.Next (Target, Tgt); - Src := Tree_Operations.Next (Source, Src); - end if; - end loop; - - while Tgt /= 0 loop - declare - X : constant Count_Type := Tgt; - begin - Tgt := Tree_Operations.Next (Target, Tgt); - - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Tree_Operations.Free (Target, X); - end; - end loop; - end Set_Intersection; - - function Set_Intersection (Left, Right : Set_Type) return Set_Type is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - exit; - end if; - - if R_Node = 0 then - exit; - end if; - - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - L_Node := Tree_Operations.Next (Left, L_Node); - - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); - - else - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; - end; - end return; - end Set_Intersection; - - --------------- - -- Is_Subset -- - --------------- - - function Set_Subset - (Subset : Set_Type; - Of_Set : Set_Type) return Boolean - is - begin - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Subset.Length > Of_Set.Length then - return False; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); - Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); - - Subset_Node : Count_Type; - Set_Node : Count_Type; - begin - Subset_Node := Subset.First; - Set_Node := Of_Set.First; - loop - if Set_Node = 0 then - return Subset_Node = 0; - end if; - - if Subset_Node = 0 then - return True; - end if; - - if Is_Less (Subset.Nodes (Subset_Node), - Of_Set.Nodes (Set_Node)) - then - return False; - end if; - - if Is_Less (Of_Set.Nodes (Set_Node), - Subset.Nodes (Subset_Node)) - then - Set_Node := Tree_Operations.Next (Of_Set, Set_Node); - else - Set_Node := Tree_Operations.Next (Of_Set, Set_Node); - Subset_Node := Tree_Operations.Next (Subset, Subset_Node); - end if; - end loop; - end; - end Set_Subset; - - ------------- - -- Overlap -- - ------------- - - function Set_Overlap (Left, Right : Set_Type) return Boolean is - begin - if Left'Address = Right'Address then - return Left.Length /= 0; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Count_Type; - R_Node : Count_Type; - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 - or else R_Node = 0 - then - return False; - end if; - - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - L_Node := Tree_Operations.Next (Left, L_Node); - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - R_Node := Tree_Operations.Next (Right, R_Node); - else - return True; - end if; - end loop; - end; - end Set_Overlap; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Set_Symmetric_Difference - (Target : in out Set_Type; - Source : Set_Type) - is - Tgt : Count_Type; - Src : Count_Type; - - New_Tgt_Node : Count_Type; - pragma Warnings (Off, New_Tgt_Node); - - Compare : Integer; - - begin - if Target'Address = Source'Address then - Tree_Operations.Clear_Tree (Target); - return; - end if; - - Tgt := Target.First; - Src := Source.First; - loop - if Tgt = 0 then - while Src /= 0 loop - Insert_With_Hint - (Dst_Set => Target, - Dst_Hint => 0, - Src_Node => Source.Nodes (Src), - Dst_Node => New_Tgt_Node); - - Src := Tree_Operations.Next (Source, Src); - end loop; - - return; - end if; - - if Src = 0 then - return; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then - Compare := -1; - elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then - Compare := 1; - else - Compare := 0; - end if; - end; - - if Compare < 0 then - Tgt := Tree_Operations.Next (Target, Tgt); - - elsif Compare > 0 then - Insert_With_Hint - (Dst_Set => Target, - Dst_Hint => Tgt, - Src_Node => Source.Nodes (Src), - Dst_Node => New_Tgt_Node); - - Src := Tree_Operations.Next (Source, Src); - - else - declare - X : constant Count_Type := Tgt; - begin - Tgt := Tree_Operations.Next (Target, Tgt); - - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Tree_Operations.Free (Target, X); - end; - - Src := Tree_Operations.Next (Source, Src); - end if; - end loop; - end Set_Symmetric_Difference; - - function Set_Symmetric_Difference - (Left, Right : Set_Type) return Set_Type - is - begin - if Left'Address = Right'Address then - return S : Set_Type (0); -- Empty set - end if; - - if Right.Length = 0 then - return Copy (Left); - end if; - - if Left.Length = 0 then - return Copy (Right); - end if; - - return Result : Set_Type (Left.Length + Right.Length) do - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Count_Type; - R_Node : Count_Type; - - Dst_Node : Count_Type; - pragma Warnings (Off, Dst_Node); - - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = 0 then - while R_Node /= 0 loop - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Right.Nodes (R_Node), - Dst_Node => Dst_Node); - - R_Node := Tree_Operations.Next (Right, R_Node); - end loop; - - exit; - end if; - - if R_Node = 0 then - while L_Node /= 0 loop - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (Left, L_Node); - end loop; - - exit; - end if; - - if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Left.Nodes (L_Node), - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (Left, L_Node); - - elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => 0, - Src_Node => Right.Nodes (R_Node), - Dst_Node => Dst_Node); - - R_Node := Tree_Operations.Next (Right, R_Node); - - else - L_Node := Tree_Operations.Next (Left, L_Node); - R_Node := Tree_Operations.Next (Right, R_Node); - end if; - end loop; - end; - end return; - end Set_Symmetric_Difference; - - ----------- - -- Union -- - ----------- - - procedure Set_Union (Target : in out Set_Type; Source : Set_Type) is - Hint : Count_Type := 0; - - procedure Process (Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is new Tree_Operations.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Count_Type) is - begin - Insert_With_Hint - (Dst_Set => Target, - Dst_Hint => Hint, - Src_Node => Source.Nodes (Node), - Dst_Node => Hint); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - -- Note that there's no way to decide a priori whether the target has - -- enough capacity for the union with source. We cannot simply - -- compare the sum of the existing lengths to the capacity of the - -- target, because equivalent items from source are not included in - -- the union. - - Iterate (Source); - end; - end Set_Union; - - function Set_Union (Left, Right : Set_Type) return Set_Type is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - if Left.Length = 0 then - return Copy (Right); - end if; - - if Right.Length = 0 then - return Copy (Left); - end if; - - return Result : Set_Type (Left.Length + Right.Length) do - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - begin - Assign (Target => Result, Source => Left); - - Insert_Right : declare - Hint : Count_Type := 0; - - procedure Process (Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Count_Type) is - begin - Insert_With_Hint - (Dst_Set => Result, - Dst_Hint => Hint, - Src_Node => Right.Nodes (Node), - Dst_Node => Hint); - end Process; - - -- Start of processing for Insert_Right - - begin - Iterate (Right); - end Insert_Right; - end; - end return; - end Set_Union; - -end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; diff --git a/gcc/ada/a-btgbso.ads b/gcc/ada/a-btgbso.ads deleted file mode 100644 index 0527a90..0000000 --- a/gcc/ada/a-btgbso.ads +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Tree_Type is used to implement ordered containers. This package declares --- set-based tree operations. - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; - -generic - with package Tree_Operations is new Generic_Bounded_Operations (<>); - - type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private; - - use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; - - with procedure Assign (Target : in out Set_Type; Source : Set_Type); - - with procedure Insert_With_Hint - (Dst_Set : in out Set_Type; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type); - - with function Is_Less (Left, Right : Node_Type) return Boolean; - -package Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is - pragma Pure; - - procedure Set_Union (Target : in out Set_Type; Source : Set_Type); - -- Attempts to insert each element of Source in Target. If Target is - -- busy then Program_Error is raised. We say "attempts" here because - -- if these are unique-element sets, then the insertion should fail - -- (not insert a new item) when the insertion item from Source is - -- equivalent to an item already in Target. If these are multisets - -- then of course the attempt should always succeed. - - function Set_Union (Left, Right : Set_Type) return Set_Type; - -- Makes a copy of Left, and attempts to insert each element of - -- Right into the copy, then returns the copy. - - procedure Set_Intersection (Target : in out Set_Type; Source : Set_Type); - -- Removes elements from Target that are not equivalent to items in - -- Source. If Target is busy then Program_Error is raised. - - function Set_Intersection (Left, Right : Set_Type) return Set_Type; - -- Returns a set comprising all the items in Left equivalent to items in - -- Right. - - procedure Set_Difference (Target : in out Set_Type; Source : Set_Type); - -- Removes elements from Target that are equivalent to items in Source. If - -- Target is busy then Program_Error is raised. - - function Set_Difference (Left, Right : Set_Type) return Set_Type; - -- Returns a set comprising all the items in Left not equivalent to items - -- in Right. - - procedure Set_Symmetric_Difference - (Target : in out Set_Type; - Source : Set_Type); - -- Removes from Target elements that are equivalent to items in Source, - -- and inserts into Target items from Source not equivalent elements in - -- Target. If Target is busy then Program_Error is raised. - - function Set_Symmetric_Difference (Left, Right : Set_Type) return Set_Type; - -- Returns a set comprising the union of the elements in Left not - -- equivalent to items in Right, and the elements in Right not equivalent - -- to items in Left. - - function Set_Subset (Subset : Set_Type; Of_Set : Set_Type) return Boolean; - -- Returns False if Subset contains at least one element not equivalent to - -- any item in Of_Set; returns True otherwise. - - function Set_Overlap (Left, Right : Set_Type) return Boolean; - -- Returns True if at least one element of Left is equivalent to an item in - -- Right; returns False otherwise. - -end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; diff --git a/gcc/ada/a-calari.adb b/gcc/ada/a-calari.adb deleted file mode 100644 index 1166b43..0000000 --- a/gcc/ada/a-calari.adb +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . A R I T H M E T I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Calendar.Arithmetic is - - -------------------------- - -- Implementation Notes -- - -------------------------- - - -- All operations in this package are target and time representation - -- independent, thus only one source file is needed for multiple targets. - - --------- - -- "+" -- - --------- - - function "+" (Left : Time; Right : Day_Count) return Time is - R : constant Long_Integer := Long_Integer (Right); - begin - return Arithmetic_Operations.Add (Left, R); - end "+"; - - function "+" (Left : Day_Count; Right : Time) return Time is - L : constant Long_Integer := Long_Integer (Left); - begin - return Arithmetic_Operations.Add (Right, L); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Time; Right : Day_Count) return Time is - R : constant Long_Integer := Long_Integer (Right); - begin - return Arithmetic_Operations.Subtract (Left, R); - end "-"; - - function "-" (Left, Right : Time) return Day_Count is - Days : Long_Integer; - Seconds : Duration; - Leap_Seconds : Integer; - pragma Warnings (Off, Seconds); -- temporary ??? - pragma Warnings (Off, Leap_Seconds); -- temporary ??? - pragma Unreferenced (Seconds, Leap_Seconds); - begin - Arithmetic_Operations.Difference - (Left, Right, Days, Seconds, Leap_Seconds); - return Day_Count (Days); - end "-"; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Left : Time; - Right : Time; - Days : out Day_Count; - Seconds : out Duration; - Leap_Seconds : out Leap_Seconds_Count) - is - Op_Days : Long_Integer; - Op_Leaps : Integer; - begin - Arithmetic_Operations.Difference - (Left, Right, Op_Days, Seconds, Op_Leaps); - Days := Day_Count (Op_Days); - Leap_Seconds := Leap_Seconds_Count (Op_Leaps); - end Difference; - -end Ada.Calendar.Arithmetic; diff --git a/gcc/ada/a-calari.ads b/gcc/ada/a-calari.ads deleted file mode 100644 index 64ebc62..0000000 --- a/gcc/ada/a-calari.ads +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . A R I T H M E T I C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2008, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This package provides arithmetic operations of time values using days --- and leap seconds. Ada.Calendar.Arithmetic is defined in the Ada 2005 --- RM (9.6.1). - -package Ada.Calendar.Arithmetic is - - -- Arithmetic on days: - - -- Rough estimate on the number of days over the range of Ada time - - type Day_Count is range - -(366 * (1 + Year_Number'Last - Year_Number'First)) - .. - +(366 * (1 + Year_Number'Last - Year_Number'First)); - - subtype Leap_Seconds_Count is Integer range -2047 .. 2047; - -- Count of leap seconds. Negative leap seconds occur whenever the - -- astronomical time is faster than the atomic time or as a result of - -- Difference when Left < Right. - - procedure Difference - (Left : Time; - Right : Time; - Days : out Day_Count; - Seconds : out Duration; - Leap_Seconds : out Leap_Seconds_Count); - -- Returns the difference between Left and Right. Days is the number of - -- days of difference, Seconds is the remainder seconds of difference - -- excluding leap seconds, and Leap_Seconds is the number of leap seconds. - -- If Left < Right, then Seconds <= 0.0, Days <= 0, and Leap_Seconds <= 0, - -- otherwise all values are nonnegative. The absolute value of Seconds is - -- always less than 86_400.0. For the returned values, if Days = 0, then - -- Seconds + Duration (Leap_Seconds) = Calendar."-" (Left, Right) - - function "+" (Left : Time; Right : Day_Count) return Time; - function "+" (Left : Day_Count; Right : Time) return Time; - -- Adds a number of days to a time value. Time_Error is raised if the - -- result is not representable as a value of type Time. - - function "-" (Left : Time; Right : Day_Count) return Time; - -- Subtracts a number of days from a time value. Time_Error is raised if - -- the result is not representable as a value of type Time. - - function "-" (Left : Time; Right : Time) return Day_Count; - -- Subtracts two time values, and returns the number of days between them. - -- This is the same value that Difference would return in Days. - -end Ada.Calendar.Arithmetic; diff --git a/gcc/ada/a-calcon.adb b/gcc/ada/a-calcon.adb deleted file mode 100644 index f24b971..0000000 --- a/gcc/ada/a-calcon.adb +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . C O N V E R S I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C; use Interfaces.C; - -package body Ada.Calendar.Conversions is - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time (Unix_Time : long) return Time is - Val : constant Long_Integer := Long_Integer (Unix_Time); - begin - return Conversion_Operations.To_Ada_Time (Val); - end To_Ada_Time; - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time - (tm_year : int; - tm_mon : int; - tm_day : int; - tm_hour : int; - tm_min : int; - tm_sec : int; - tm_isdst : int) return Time - is - Year : constant Integer := Integer (tm_year); - Month : constant Integer := Integer (tm_mon); - Day : constant Integer := Integer (tm_day); - Hour : constant Integer := Integer (tm_hour); - Minute : constant Integer := Integer (tm_min); - Second : constant Integer := Integer (tm_sec); - DST : constant Integer := Integer (tm_isdst); - begin - return - Conversion_Operations.To_Ada_Time - (Year, Month, Day, Hour, Minute, Second, DST); - end To_Ada_Time; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration - (tv_sec : long; - tv_nsec : long) return Duration - is - Secs : constant Long_Integer := Long_Integer (tv_sec); - Nano_Secs : constant Long_Integer := Long_Integer (tv_nsec); - begin - return Conversion_Operations.To_Duration (Secs, Nano_Secs); - end To_Duration; - - ------------------------ - -- To_Struct_Timespec -- - ------------------------ - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out long; - tv_nsec : out long) - is - Secs : Long_Integer; - Nano_Secs : Long_Integer; - - begin - Conversion_Operations.To_Struct_Timespec (D, Secs, Nano_Secs); - - tv_sec := long (Secs); - tv_nsec := long (Nano_Secs); - end To_Struct_Timespec; - - ------------------ - -- To_Struct_Tm -- - ------------------ - - procedure To_Struct_Tm - (T : Time; - tm_year : out int; - tm_mon : out int; - tm_day : out int; - tm_hour : out int; - tm_min : out int; - tm_sec : out int) - is - Year : Integer; - Month : Integer; - Day : Integer; - Hour : Integer; - Minute : Integer; - Second : Integer; - - begin - Conversion_Operations.To_Struct_Tm - (T, Year, Month, Day, Hour, Minute, Second); - - tm_year := int (Year); - tm_mon := int (Month); - tm_day := int (Day); - tm_hour := int (Hour); - tm_min := int (Minute); - tm_sec := int (Second); - end To_Struct_Tm; - - ------------------ - -- To_Unix_Time -- - ------------------ - - function To_Unix_Time (Ada_Time : Time) return long is - Val : constant Long_Integer := - Conversion_Operations.To_Unix_Time (Ada_Time); - begin - return long (Val); - end To_Unix_Time; - -end Ada.Calendar.Conversions; diff --git a/gcc/ada/a-calcon.ads b/gcc/ada/a-calcon.ads deleted file mode 100644 index 0fbf4a1..0000000 --- a/gcc/ada/a-calcon.ads +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . C O N V E R S I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides various routines for conversion between Ada and Unix --- time models - Time, Duration, struct tm and struct timespec. - -with Interfaces.C; - -package Ada.Calendar.Conversions is - - function To_Ada_Time (Unix_Time : Interfaces.C.long) return Time; - -- Convert a time value represented as number of seconds since the - -- Unix Epoch to a time value relative to an Ada implementation-defined - -- Epoch. The units of the result are nanoseconds on all targets. Raises - -- Time_Error if the result cannot fit into a Time value. - - function To_Ada_Time - (tm_year : Interfaces.C.int; - tm_mon : Interfaces.C.int; - tm_day : Interfaces.C.int; - tm_hour : Interfaces.C.int; - tm_min : Interfaces.C.int; - tm_sec : Interfaces.C.int; - tm_isdst : Interfaces.C.int) return Time; - -- Convert a time value expressed in Unix-like fields of struct tm into - -- a Time value relative to the Ada Epoch. The ranges of the formals are - -- as follows: - - -- tm_year -- years since 1900 - -- tm_mon -- months since January [0 .. 11] - -- tm_day -- day of the month [1 .. 31] - -- tm_hour -- hours since midnight [0 .. 24] - -- tm_min -- minutes after the hour [0 .. 59] - -- tm_sec -- seconds after the minute [0 .. 60] - -- tm_isdst -- Daylight Savings Time flag [-1 .. 1] - - -- The returned value is in UTC and may or may not contain leap seconds - -- depending on whether binder flag "-y" was used. Raises Time_Error if - -- the input values are out of the defined ranges or if tm_sec equals 60 - -- and the instance in time is not a leap second occurrence. - - function To_Duration - (tv_sec : Interfaces.C.long; - tv_nsec : Interfaces.C.long) return Duration; - -- Convert an elapsed time value expressed in Unix-like fields of struct - -- timespec into a Duration value. The expected ranges are: - - -- tv_sec - seconds - -- tv_nsec - nanoseconds - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out Interfaces.C.long; - tv_nsec : out Interfaces.C.long); - -- Convert a Duration value into the constituents of struct timespec. - -- Formal tv_sec denotes seconds and tv_nsecs denotes nanoseconds. - - procedure To_Struct_Tm - (T : Time; - tm_year : out Interfaces.C.int; - tm_mon : out Interfaces.C.int; - tm_day : out Interfaces.C.int; - tm_hour : out Interfaces.C.int; - tm_min : out Interfaces.C.int; - tm_sec : out Interfaces.C.int); - -- Convert a Time value set in the Ada Epoch into the constituents of - -- struct tm. The ranges of the out formals are as follows: - - -- tm_year -- years since 1900 - -- tm_mon -- months since January [0 .. 11] - -- tm_day -- day of the month [1 .. 31] - -- tm_hour -- hours since midnight [0 .. 24] - -- tm_min -- minutes after the hour [0 .. 59] - -- tm_sec -- seconds after the minute [0 .. 60] - -- tm_isdst -- Daylight Savings Time flag [-1 .. 1] - - -- The input date is considered to be in UTC - - function To_Unix_Time (Ada_Time : Time) return Interfaces.C.long; - -- Convert a time value represented as number of time units since the Ada - -- implementation-defined Epoch to a value relative to the Unix Epoch. The - -- units of the result are seconds. Raises Time_Error if the result cannot - -- fit into a Time value. - -end Ada.Calendar.Conversions; diff --git a/gcc/ada/a-caldel.adb b/gcc/ada/a-caldel.adb deleted file mode 100644 index efa4478..0000000 --- a/gcc/ada/a-caldel.adb +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . C A L E N D A R . D E L A Y S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1991-1994, Florida State University -- --- Copyright (C) 1995-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.OS_Primitives; -with System.Soft_Links; - -package body Ada.Calendar.Delays is - - package OSP renames System.OS_Primitives; - package SSL renames System.Soft_Links; - - use type SSL.Timed_Delay_Call; - - -- Earlier, System.Time_Operations was used to implement the following - -- operations. The idea was to avoid sucking in the tasking packages. This - -- did not work. Logically, we can't have it both ways. There is no way to - -- implement time delays that will have correct task semantics without - -- reference to the tasking run-time system. To achieve this goal, we now - -- use soft links. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Timed_Delay_NT (Time : Duration; Mode : Integer); - -- Timed delay procedure used when no tasking is active - - --------------- - -- Delay_For -- - --------------- - - procedure Delay_For (D : Duration) is - begin - SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay), - OSP.Relative); - end Delay_For; - - ----------------- - -- Delay_Until -- - ----------------- - - procedure Delay_Until (T : Time) is - D : constant Duration := To_Duration (T); - - begin - SSL.Timed_Delay.all (D, OSP.Absolute_Calendar); - end Delay_Until; - - -------------------- - -- Timed_Delay_NT -- - -------------------- - - procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is - begin - OSP.Timed_Delay (Time, Mode); - end Timed_Delay_NT; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : Time) return Duration is - begin - -- Since time has multiple representations on different platforms, a - -- target independent operation in Ada.Calendar is used to perform - -- this conversion. - - return Delay_Operations.To_Duration (T); - end To_Duration; - -begin - -- Set up the Timed_Delay soft link to the non tasking version if it has - -- not been already set. If tasking is present, Timed_Delay has already set - -- this soft link, or this will be overridden during the elaboration of - -- System.Tasking.Initialization - - if SSL.Timed_Delay = null then - SSL.Timed_Delay := Timed_Delay_NT'Access; - end if; - -end Ada.Calendar.Delays; diff --git a/gcc/ada/a-caldel.ads b/gcc/ada/a-caldel.ads deleted file mode 100644 index 1a0b129..0000000 --- a/gcc/ada/a-caldel.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . C A L E N D A R . D E L A Y S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements Calendar.Time delays using protected objects - --- Note: the compiler generates direct calls to this interface, in the --- processing of time types. - -package Ada.Calendar.Delays is - - procedure Delay_For (D : Duration); - -- Delay until an interval of length (at least) D seconds has passed, or - -- the task is aborted to at least the current ATC nesting level. This is - -- an abort completion point. The body of this procedure must perform all - -- the processing required for an abort point. - - procedure Delay_Until (T : Time); - -- Delay until Clock has reached (at least) time T, or the task is aborted - -- to at least the current ATC nesting level. The body of this procedure - -- must perform all the processing required for an abort point. - - function To_Duration (T : Time) return Duration; - -- Convert Time to Duration elapsed since UNIX epoch - -end Ada.Calendar.Delays; diff --git a/gcc/ada/a-calend.adb b/gcc/ada/a-calend.adb deleted file mode 100644 index b0fba5d..0000000 --- a/gcc/ada/a-calend.adb +++ /dev/null @@ -1,1580 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.OS_Primitives; - -package body Ada.Calendar with - SPARK_Mode => Off -is - - -------------------------- - -- Implementation Notes -- - -------------------------- - - -- In complex algorithms, some variables of type Ada.Calendar.Time carry - -- suffix _S or _N to denote units of seconds or nanoseconds. - -- - -- Because time is measured in different units and from different origins - -- on various targets, a system independent model is incorporated into - -- Ada.Calendar. The idea behind the design is to encapsulate all target - -- dependent machinery in a single package, thus providing a uniform - -- interface to all existing and any potential children. - - -- package Ada.Calendar - -- procedure Split (5 parameters) -------+ - -- | Call from local routine - -- private | - -- package Formatting_Operations | - -- procedure Split (11 parameters) <--+ - -- end Formatting_Operations | - -- end Ada.Calendar | - -- | - -- package Ada.Calendar.Formatting | Call from child routine - -- procedure Split (9 or 10 parameters) -+ - -- end Ada.Calendar.Formatting - - -- The behavior of the interfacing routines is controlled via various - -- flags. All new Ada 2005 types from children of Ada.Calendar are - -- emulated by a similar type. For instance, type Day_Number is replaced - -- by Integer in various routines. One ramification of this model is that - -- the caller site must perform validity checks on returned results. - -- The end result of this model is the lack of target specific files per - -- child of Ada.Calendar (e.g. a-calfor). - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Check_Within_Time_Bounds (T : Time_Rep); - -- Ensure that a time representation value falls withing the bounds of Ada - -- time. Leap seconds support is taken into account. - - procedure Cumulative_Leap_Seconds - (Start_Date : Time_Rep; - End_Date : Time_Rep; - Elapsed_Leaps : out Natural; - Next_Leap : out Time_Rep); - -- Elapsed_Leaps is the sum of the leap seconds that have occurred on or - -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec - -- represents the next leap second occurrence on or after End_Date. If - -- there are no leaps seconds after End_Date, End_Of_Time is returned. - -- End_Of_Time can be used as End_Date to count all the leap seconds that - -- have occurred on or after Start_Date. - -- - -- Note: Any sub seconds of Start_Date and End_Date are discarded before - -- the calculations are done. For instance: if 113 seconds is a leap - -- second (it isn't) and 113.5 is input as an End_Date, the leap second - -- at 113 will not be counted in Leaps_Between, but it will be returned - -- as Next_Leap_Sec. Thus, if the caller wants to know if the End_Date is - -- a leap second, the comparison should be: - -- - -- End_Date >= Next_Leap_Sec; - -- - -- After_Last_Leap is designed so that this comparison works without - -- having to first check if Next_Leap_Sec is a valid leap second. - - function Duration_To_Time_Rep is - new Ada.Unchecked_Conversion (Duration, Time_Rep); - -- Convert a duration value into a time representation value - - function Time_Rep_To_Duration is - new Ada.Unchecked_Conversion (Time_Rep, Duration); - -- Convert a time representation value into a duration value - - function UTC_Time_Offset - (Date : Time; - Is_Historic : Boolean) return Long_Integer; - -- This routine acts as an Ada wrapper around __gnat_localtime_tzoff which - -- in turn utilizes various OS-dependent mechanisms to calculate the time - -- zone offset of a date. Formal parameter Date represents an arbitrary - -- time stamp, either in the past, now, or in the future. If the flag - -- Is_Historic is set, this routine would try to calculate to the best of - -- the OS's abilities the time zone offset that was or will be in effect - -- on Date. If the flag is set to False, the routine returns the current - -- time zone with Date effectively set to Clock. - -- - -- NOTE: Targets which support localtime_r will aways return a historic - -- time zone even if flag Is_Historic is set to False because this is how - -- localtime_r operates. - - ----------------- - -- Local Types -- - ----------------- - - -- An integer time duration. The type is used whenever a positive elapsed - -- duration is needed, for instance when splitting a time value. Here is - -- how Time_Rep and Time_Dur are related: - - -- 'First Ada_Low Ada_High 'Last - -- Time_Rep: +-------+------------------------+---------+ - -- Time_Dur: +------------------------+---------+ - -- 0 'Last - - type Time_Dur is range 0 .. 2 ** 63 - 1; - - -------------------------- - -- Leap seconds control -- - -------------------------- - - Flag : Integer; - pragma Import (C, Flag, "__gl_leap_seconds_support"); - -- This imported value is used to determine whether the compilation had - -- binder flag "-y" present which enables leap seconds. A value of zero - -- signifies no leap seconds support while a value of one enables support. - - Leap_Support : constant Boolean := (Flag = 1); - -- Flag to controls the usage of leap seconds in all Ada.Calendar routines - - Leap_Seconds_Count : constant Natural := 25; - - --------------------- - -- Local Constants -- - --------------------- - - Ada_Min_Year : constant Year_Number := Year_Number'First; - Secs_In_Four_Years : constant := (3 * 365 + 366) * Secs_In_Day; - Secs_In_Non_Leap_Year : constant := 365 * Secs_In_Day; - Nanos_In_Four_Years : constant := Secs_In_Four_Years * Nano; - - -- Lower and upper bound of Ada time. The zero (0) value of type Time is - -- positioned at year 2150. Note that the lower and upper bound account - -- for the non-leap centennial years. - - Ada_Low : constant Time_Rep := -(61 * 366 + 188 * 365) * Nanos_In_Day; - Ada_High : constant Time_Rep := (60 * 366 + 190 * 365) * Nanos_In_Day; - - -- Even though the upper bound of time is 2399-12-31 23:59:59.999999999 - -- UTC, it must be increased to include all leap seconds. - - Ada_High_And_Leaps : constant Time_Rep := - Ada_High + Time_Rep (Leap_Seconds_Count) * Nano; - - -- Two constants used in the calculations of elapsed leap seconds. - -- End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time - -- is earlier than Ada_Low in time zone +28. - - End_Of_Time : constant Time_Rep := - Ada_High + Time_Rep (3) * Nanos_In_Day; - Start_Of_Time : constant Time_Rep := - Ada_Low - Time_Rep (3) * Nanos_In_Day; - - -- The Unix lower time bound expressed as nanoseconds since the start of - -- Ada time in UTC. - - Unix_Min : constant Time_Rep := - Ada_Low + Time_Rep (17 * 366 + 52 * 365) * Nanos_In_Day; - - -- The Unix upper time bound expressed as nanoseconds since the start of - -- Ada time in UTC. - - Unix_Max : constant Time_Rep := - Ada_Low + Time_Rep (34 * 366 + 102 * 365) * Nanos_In_Day + - Time_Rep (Leap_Seconds_Count) * Nano; - - Epoch_Offset : constant Time_Rep := (136 * 365 + 44 * 366) * Nanos_In_Day; - -- The difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in - -- nanoseconds. Note that year 2100 is non-leap. - - Cumulative_Days_Before_Month : - constant array (Month_Number) of Natural := - (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334); - - -- The following table contains the hard time values of all existing leap - -- seconds. The values are produced by the utility program xleaps.adb. This - -- must be updated when additional leap second times are defined. - - Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of Time_Rep := - (-5601484800000000000, - -5585587199000000000, - -5554051198000000000, - -5522515197000000000, - -5490979196000000000, - -5459356795000000000, - -5427820794000000000, - -5396284793000000000, - -5364748792000000000, - -5317487991000000000, - -5285951990000000000, - -5254415989000000000, - -5191257588000000000, - -5112287987000000000, - -5049129586000000000, - -5017593585000000000, - -4970332784000000000, - -4938796783000000000, - -4907260782000000000, - -4859827181000000000, - -4812566380000000000, - -4765132779000000000, - -4544207978000000000, - -4449513577000000000, - -4339180776000000000); - - --------- - -- "+" -- - --------- - - function "+" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - Left_N : constant Time_Rep := Time_Rep (Left); - begin - return Time (Left_N + Duration_To_Time_Rep (Right)); - exception - when Constraint_Error => - raise Time_Error; - end "+"; - - function "+" (Left : Duration; Right : Time) return Time is - begin - return Right + Left; - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Time; Right : Duration) return Time is - pragma Unsuppress (Overflow_Check); - Left_N : constant Time_Rep := Time_Rep (Left); - begin - return Time (Left_N - Duration_To_Time_Rep (Right)); - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - function "-" (Left : Time; Right : Time) return Duration is - pragma Unsuppress (Overflow_Check); - - Dur_Low : constant Time_Rep := Duration_To_Time_Rep (Duration'First); - Dur_High : constant Time_Rep := Duration_To_Time_Rep (Duration'Last); - -- The bounds of type Duration expressed as time representations - - Res_N : Time_Rep; - - begin - Res_N := Time_Rep (Left) - Time_Rep (Right); - - -- Due to the extended range of Ada time, "-" is capable of producing - -- results which may exceed the range of Duration. In order to prevent - -- the generation of bogus values by the Unchecked_Conversion, we apply - -- the following check. - - if Res_N < Dur_Low or else Res_N > Dur_High then - raise Time_Error; - end if; - - return Time_Rep_To_Duration (Res_N); - - exception - when Constraint_Error => - raise Time_Error; - end "-"; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Time) return Boolean is - begin - return Time_Rep (Left) < Time_Rep (Right); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left, Right : Time) return Boolean is - begin - return Time_Rep (Left) <= Time_Rep (Right); - end "<="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Time) return Boolean is - begin - return Time_Rep (Left) > Time_Rep (Right); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (Left, Right : Time) return Boolean is - begin - return Time_Rep (Left) >= Time_Rep (Right); - end ">="; - - ------------------------------ - -- Check_Within_Time_Bounds -- - ------------------------------ - - procedure Check_Within_Time_Bounds (T : Time_Rep) is - begin - if Leap_Support then - if T < Ada_Low or else T > Ada_High_And_Leaps then - raise Time_Error; - end if; - else - if T < Ada_Low or else T > Ada_High then - raise Time_Error; - end if; - end if; - end Check_Within_Time_Bounds; - - ----------- - -- Clock -- - ----------- - - function Clock return Time is - Elapsed_Leaps : Natural; - Next_Leap_N : Time_Rep; - - -- The system clock returns the time in UTC since the Unix Epoch of - -- 1970-01-01 00:00:00.0. We perform an origin shift to the Ada Epoch - -- by adding the number of nanoseconds between the two origins. - - Res_N : Time_Rep := - Duration_To_Time_Rep (System.OS_Primitives.Clock) + Unix_Min; - - begin - -- If the target supports leap seconds, determine the number of leap - -- seconds elapsed until this moment. - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); - - -- The system clock may fall exactly on a leap second - - if Res_N >= Next_Leap_N then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - end if; - - Res_N := Res_N + Time_Rep (Elapsed_Leaps) * Nano; - - return Time (Res_N); - end Clock; - - ----------------------------- - -- Cumulative_Leap_Seconds -- - ----------------------------- - - procedure Cumulative_Leap_Seconds - (Start_Date : Time_Rep; - End_Date : Time_Rep; - Elapsed_Leaps : out Natural; - Next_Leap : out Time_Rep) - is - End_Index : Positive; - End_T : Time_Rep := End_Date; - Start_Index : Positive; - Start_T : Time_Rep := Start_Date; - - begin - -- Both input dates must be normalized to UTC - - pragma Assert (Leap_Support and then End_Date >= Start_Date); - - Next_Leap := End_Of_Time; - - -- Make sure that the end date does not exceed the upper bound - -- of Ada time. - - if End_Date > Ada_High then - End_T := Ada_High; - end if; - - -- Remove the sub seconds from both dates - - Start_T := Start_T - (Start_T mod Nano); - End_T := End_T - (End_T mod Nano); - - -- Some trivial cases: - -- Leap 1 . . . Leap N - -- ---+========+------+############+-------+========+----- - -- Start_T End_T Start_T End_T - - if End_T < Leap_Second_Times (1) then - Elapsed_Leaps := 0; - Next_Leap := Leap_Second_Times (1); - return; - - elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then - Elapsed_Leaps := 0; - Next_Leap := End_Of_Time; - return; - end if; - - -- Perform the calculations only if the start date is within the leap - -- second occurrences table. - - if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then - - -- 1 2 N - 1 N - -- +----+----+-- . . . --+-------+---+ - -- | T1 | T2 | | N - 1 | N | - -- +----+----+-- . . . --+-------+---+ - -- ^ ^ - -- | Start_Index | End_Index - -- +-------------------+ - -- Leaps_Between - - -- The idea behind the algorithm is to iterate and find two - -- closest dates which are after Start_T and End_T. Their - -- corresponding index difference denotes the number of leap - -- seconds elapsed. - - Start_Index := 1; - loop - exit when Leap_Second_Times (Start_Index) >= Start_T; - Start_Index := Start_Index + 1; - end loop; - - End_Index := Start_Index; - loop - exit when End_Index > Leap_Seconds_Count - or else Leap_Second_Times (End_Index) >= End_T; - End_Index := End_Index + 1; - end loop; - - if End_Index <= Leap_Seconds_Count then - Next_Leap := Leap_Second_Times (End_Index); - end if; - - Elapsed_Leaps := End_Index - Start_Index; - - else - Elapsed_Leaps := 0; - end if; - end Cumulative_Leap_Seconds; - - --------- - -- Day -- - --------- - - function Day (Date : Time) return Day_Number is - D : Day_Number; - Y : Year_Number; - M : Month_Number; - S : Day_Duration; - pragma Unreferenced (Y, M, S); - begin - Split (Date, Y, M, D, S); - return D; - end Day; - - ------------- - -- Is_Leap -- - ------------- - - function Is_Leap (Year : Year_Number) return Boolean is - begin - -- Leap centennial years - - if Year mod 400 = 0 then - return True; - - -- Non-leap centennial years - - elsif Year mod 100 = 0 then - return False; - - -- Regular years - - else - return Year mod 4 = 0; - end if; - end Is_Leap; - - ----------- - -- Month -- - ----------- - - function Month (Date : Time) return Month_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, D, S); - begin - Split (Date, Y, M, D, S); - return M; - end Month; - - ------------- - -- Seconds -- - ------------- - - function Seconds (Date : Time) return Day_Duration is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (Y, M, D); - begin - Split (Date, Y, M, D, S); - return S; - end Seconds; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration) - is - H : Integer; - M : Integer; - Se : Integer; - Ss : Duration; - Le : Boolean; - - pragma Unreferenced (H, M, Se, Ss, Le); - - begin - -- Even though the input time zone is UTC (0), the flag Use_TZ will - -- ensure that Split picks up the local time zone. - - Formatting_Operations.Split - (Date => Date, - Year => Year, - Month => Month, - Day => Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Ss, - Leap_Sec => Le, - Use_TZ => False, - Is_Historic => True, - Time_Zone => 0); - - -- Validity checks - - if not Year'Valid or else - not Month'Valid or else - not Day'Valid or else - not Seconds'Valid - then - raise Time_Error; - end if; - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) return Time - is - -- The values in the following constants are irrelevant, they are just - -- placeholders; the choice of constructing a Day_Duration value is - -- controlled by the Use_Day_Secs flag. - - H : constant Integer := 1; - M : constant Integer := 1; - Se : constant Integer := 1; - Ss : constant Duration := 0.1; - - begin - -- Validity checks - - if not Year'Valid or else - not Month'Valid or else - not Day'Valid or else - not Seconds'Valid - then - raise Time_Error; - end if; - - -- Even though the input time zone is UTC (0), the flag Use_TZ will - -- ensure that Split picks up the local time zone. - - return - Formatting_Operations.Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Ss, - Leap_Sec => False, - Use_Day_Secs => True, - Use_TZ => False, - Is_Historic => True, - Time_Zone => 0); - end Time_Of; - - --------------------- - -- UTC_Time_Offset -- - --------------------- - - function UTC_Time_Offset - (Date : Time; - Is_Historic : Boolean) return Long_Integer - is - -- The following constants denote February 28 during non-leap centennial - -- years, the units are nanoseconds. - - T_2100_2_28 : constant Time_Rep := Ada_Low + - (Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day + - Time_Rep (Leap_Seconds_Count)) * Nano; - - T_2200_2_28 : constant Time_Rep := Ada_Low + - (Time_Rep (73 * 366 + 226 * 365 + 59) * Secs_In_Day + - Time_Rep (Leap_Seconds_Count)) * Nano; - - T_2300_2_28 : constant Time_Rep := Ada_Low + - (Time_Rep (97 * 366 + 302 * 365 + 59) * Secs_In_Day + - Time_Rep (Leap_Seconds_Count)) * Nano; - - -- 56 years (14 leap years + 42 non-leap years) in nanoseconds: - - Nanos_In_56_Years : constant := (14 * 366 + 42 * 365) * Nanos_In_Day; - - type int_Pointer is access all Interfaces.C.int; - type long_Pointer is access all Interfaces.C.long; - - type time_t is - range -(2 ** (Standard'Address_Size - Integer'(1))) .. - +(2 ** (Standard'Address_Size - Integer'(1)) - 1); - type time_t_Pointer is access all time_t; - - procedure localtime_tzoff - (timer : time_t_Pointer; - is_historic : int_Pointer; - off : long_Pointer); - pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff"); - -- This routine is a interfacing wrapper around the library function - -- __gnat_localtime_tzoff. Parameter 'timer' represents a Unix-based - -- time equivalent of the input date. If flag 'is_historic' is set, this - -- routine would try to calculate to the best of the OS's abilities the - -- time zone offset that was or will be in effect on 'timer'. If the - -- flag is set to False, the routine returns the current time zone - -- regardless of what 'timer' designates. Parameter 'off' captures the - -- UTC offset of 'timer'. - - Adj_Cent : Integer; - Date_N : Time_Rep; - Flag : aliased Interfaces.C.int; - Offset : aliased Interfaces.C.long; - Secs_T : aliased time_t; - - -- Start of processing for UTC_Time_Offset - - begin - Date_N := Time_Rep (Date); - - -- Dates which are 56 years apart fall on the same day, day light saving - -- and so on. Non-leap centennial years violate this rule by one day and - -- as a consequence, special adjustment is needed. - - Adj_Cent := - (if Date_N <= T_2100_2_28 then 0 - elsif Date_N <= T_2200_2_28 then 1 - elsif Date_N <= T_2300_2_28 then 2 - else 3); - - if Adj_Cent > 0 then - Date_N := Date_N - Time_Rep (Adj_Cent) * Nanos_In_Day; - end if; - - -- Shift the date within bounds of Unix time - - while Date_N < Unix_Min loop - Date_N := Date_N + Nanos_In_56_Years; - end loop; - - while Date_N >= Unix_Max loop - Date_N := Date_N - Nanos_In_56_Years; - end loop; - - -- Perform a shift in origins from Ada to Unix - - Date_N := Date_N - Unix_Min; - - -- Convert the date into seconds - - Secs_T := time_t (Date_N / Nano); - - -- Determine whether to treat the input date as historical or not. A - -- value of "0" signifies that the date is NOT historic. - - Flag := (if Is_Historic then 1 else 0); - - localtime_tzoff - (Secs_T'Unchecked_Access, - Flag'Unchecked_Access, - Offset'Unchecked_Access); - - return Long_Integer (Offset); - end UTC_Time_Offset; - - ---------- - -- Year -- - ---------- - - function Year (Date : Time) return Year_Number is - Y : Year_Number; - M : Month_Number; - D : Day_Number; - S : Day_Duration; - pragma Unreferenced (M, D, S); - begin - Split (Date, Y, M, D, S); - return Y; - end Year; - - -- The following packages assume that Time is a signed 64 bit integer - -- type, the units are nanoseconds and the origin is the start of Ada - -- time (1901-01-01 00:00:00.0 UTC). - - --------------------------- - -- Arithmetic_Operations -- - --------------------------- - - package body Arithmetic_Operations is - - --------- - -- Add -- - --------- - - function Add (Date : Time; Days : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Date_N : constant Time_Rep := Time_Rep (Date); - begin - return Time (Date_N + Time_Rep (Days) * Nanos_In_Day); - exception - when Constraint_Error => - raise Time_Error; - end Add; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Left : Time; - Right : Time; - Days : out Long_Integer; - Seconds : out Duration; - Leap_Seconds : out Integer) - is - Res_Dur : Time_Dur; - Earlier : Time_Rep; - Elapsed_Leaps : Natural; - Later : Time_Rep; - Negate : Boolean := False; - Next_Leap_N : Time_Rep; - Sub_Secs : Duration; - Sub_Secs_Diff : Time_Rep; - - begin - -- Both input time values are assumed to be in UTC - - if Left >= Right then - Later := Time_Rep (Left); - Earlier := Time_Rep (Right); - else - Later := Time_Rep (Right); - Earlier := Time_Rep (Left); - Negate := True; - end if; - - -- If the target supports leap seconds, process them - - if Leap_Support then - Cumulative_Leap_Seconds - (Earlier, Later, Elapsed_Leaps, Next_Leap_N); - - if Later >= Next_Leap_N then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - end if; - - -- Sub seconds processing. We add the resulting difference to one - -- of the input dates in order to account for any potential rounding - -- of the difference in the next step. - - Sub_Secs_Diff := Later mod Nano - Earlier mod Nano; - Earlier := Earlier + Sub_Secs_Diff; - Sub_Secs := Duration (Sub_Secs_Diff) / Nano_F; - - -- Difference processing. This operation should be able to calculate - -- the difference between opposite values which are close to the end - -- and start of Ada time. To accommodate the large range, we convert - -- to seconds. This action may potentially round the two values and - -- either add or drop a second. We compensate for this issue in the - -- previous step. - - Res_Dur := - Time_Dur (Later / Nano - Earlier / Nano) - Time_Dur (Elapsed_Leaps); - - Days := Long_Integer (Res_Dur / Secs_In_Day); - Seconds := Duration (Res_Dur mod Secs_In_Day) + Sub_Secs; - Leap_Seconds := Integer (Elapsed_Leaps); - - if Negate then - Days := -Days; - Seconds := -Seconds; - - if Leap_Seconds /= 0 then - Leap_Seconds := -Leap_Seconds; - end if; - end if; - end Difference; - - -------------- - -- Subtract -- - -------------- - - function Subtract (Date : Time; Days : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Date_N : constant Time_Rep := Time_Rep (Date); - begin - return Time (Date_N - Time_Rep (Days) * Nanos_In_Day); - exception - when Constraint_Error => - raise Time_Error; - end Subtract; - - end Arithmetic_Operations; - - --------------------------- - -- Conversion_Operations -- - --------------------------- - - package body Conversion_Operations is - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time (Unix_Time : Long_Integer) return Time is - pragma Unsuppress (Overflow_Check); - Unix_Rep : constant Time_Rep := Time_Rep (Unix_Time) * Nano; - begin - return Time (Unix_Rep - Epoch_Offset); - exception - when Constraint_Error => - raise Time_Error; - end To_Ada_Time; - - ----------------- - -- To_Ada_Time -- - ----------------- - - function To_Ada_Time - (tm_year : Integer; - tm_mon : Integer; - tm_day : Integer; - tm_hour : Integer; - tm_min : Integer; - tm_sec : Integer; - tm_isdst : Integer) return Time - is - pragma Unsuppress (Overflow_Check); - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Second : Integer; - Leap : Boolean; - Result : Time_Rep; - - begin - -- Input processing - - Year := Year_Number (1900 + tm_year); - Month := Month_Number (1 + tm_mon); - Day := Day_Number (tm_day); - - -- Step 1: Validity checks of input values - - if not Year'Valid or else not Month'Valid or else not Day'Valid - or else tm_hour not in 0 .. 24 - or else tm_min not in 0 .. 59 - or else tm_sec not in 0 .. 60 - or else tm_isdst not in -1 .. 1 - then - raise Time_Error; - end if; - - -- Step 2: Potential leap second - - if tm_sec = 60 then - Leap := True; - Second := 59; - else - Leap := False; - Second := tm_sec; - end if; - - -- Step 3: Calculate the time value - - Result := - Time_Rep - (Formatting_Operations.Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => 0.0, -- Time is given in h:m:s - Hour => tm_hour, - Minute => tm_min, - Second => Second, - Sub_Sec => 0.0, -- No precise sub second given - Leap_Sec => Leap, - Use_Day_Secs => False, -- Time is given in h:m:s - Use_TZ => True, -- Force usage of explicit time zone - Is_Historic => True, - Time_Zone => 0)); -- Place the value in UTC - - -- Step 4: Daylight Savings Time - - if tm_isdst = 1 then - Result := Result + Time_Rep (3_600) * Nano; - end if; - - return Time (Result); - - exception - when Constraint_Error => - raise Time_Error; - end To_Ada_Time; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration - (tv_sec : Long_Integer; - tv_nsec : Long_Integer) return Duration - is - pragma Unsuppress (Overflow_Check); - begin - return Duration (tv_sec) + Duration (tv_nsec) / Nano_F; - end To_Duration; - - ------------------------ - -- To_Struct_Timespec -- - ------------------------ - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out Long_Integer; - tv_nsec : out Long_Integer) - is - pragma Unsuppress (Overflow_Check); - Secs : Duration; - Nano_Secs : Duration; - - begin - -- Seconds extraction, avoid potential rounding errors - - Secs := D - 0.5; - tv_sec := Long_Integer (Secs); - - -- Nanoseconds extraction - - Nano_Secs := D - Duration (tv_sec); - tv_nsec := Long_Integer (Nano_Secs * Nano); - end To_Struct_Timespec; - - ------------------ - -- To_Struct_Tm -- - ------------------ - - procedure To_Struct_Tm - (T : Time; - tm_year : out Integer; - tm_mon : out Integer; - tm_day : out Integer; - tm_hour : out Integer; - tm_min : out Integer; - tm_sec : out Integer) - is - pragma Unsuppress (Overflow_Check); - Year : Year_Number; - Month : Month_Number; - Second : Integer; - Day_Secs : Day_Duration; - Sub_Sec : Duration; - Leap_Sec : Boolean; - - begin - -- Step 1: Split the input time - - Formatting_Operations.Split - (Date => T, - Year => Year, - Month => Month, - Day => tm_day, - Day_Secs => Day_Secs, - Hour => tm_hour, - Minute => tm_min, - Second => Second, - Sub_Sec => Sub_Sec, - Leap_Sec => Leap_Sec, - Use_TZ => True, - Is_Historic => False, - Time_Zone => 0); - - -- Step 2: Correct the year and month - - tm_year := Year - 1900; - tm_mon := Month - 1; - - -- Step 3: Handle leap second occurrences - - tm_sec := (if Leap_Sec then 60 else Second); - end To_Struct_Tm; - - ------------------ - -- To_Unix_Time -- - ------------------ - - function To_Unix_Time (Ada_Time : Time) return Long_Integer is - pragma Unsuppress (Overflow_Check); - Ada_Rep : constant Time_Rep := Time_Rep (Ada_Time); - begin - return Long_Integer ((Ada_Rep + Epoch_Offset) / Nano); - exception - when Constraint_Error => - raise Time_Error; - end To_Unix_Time; - end Conversion_Operations; - - ---------------------- - -- Delay_Operations -- - ---------------------- - - package body Delay_Operations is - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (Date : Time) return Duration is - pragma Unsuppress (Overflow_Check); - - Safe_Ada_High : constant Time_Rep := Ada_High - Epoch_Offset; - -- This value represents a "safe" end of time. In order to perform a - -- proper conversion to Unix duration, we will have to shift origins - -- at one point. For very distant dates, this means an overflow check - -- failure. To prevent this, the function returns the "safe" end of - -- time (roughly 2219) which is still distant enough. - - Elapsed_Leaps : Natural; - Next_Leap_N : Time_Rep; - Res_N : Time_Rep; - - begin - Res_N := Time_Rep (Date); - - -- Step 1: If the target supports leap seconds, remove any leap - -- seconds elapsed up to the input date. - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); - - -- The input time value may fall on a leap second occurrence - - if Res_N >= Next_Leap_N then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - end if; - - Res_N := Res_N - Time_Rep (Elapsed_Leaps) * Nano; - - -- Step 2: Perform a shift in origins to obtain a Unix equivalent of - -- the input. Guard against very large delay values such as the end - -- of time since the computation will overflow. - - Res_N := (if Res_N > Safe_Ada_High then Safe_Ada_High - else Res_N + Epoch_Offset); - - return Time_Rep_To_Duration (Res_N); - end To_Duration; - - end Delay_Operations; - - --------------------------- - -- Formatting_Operations -- - --------------------------- - - package body Formatting_Operations is - - ----------------- - -- Day_Of_Week -- - ----------------- - - function Day_Of_Week (Date : Time) return Integer is - Date_N : constant Time_Rep := Time_Rep (Date); - Time_Zone : constant Long_Integer := UTC_Time_Offset (Date, True); - Ada_Low_N : Time_Rep; - Day_Count : Long_Integer; - Day_Dur : Time_Dur; - High_N : Time_Rep; - Low_N : Time_Rep; - - begin - -- As declared, the Ada Epoch is set in UTC. For this calculation to - -- work properly, both the Epoch and the input date must be in the - -- same time zone. The following places the Epoch in the input date's - -- time zone. - - Ada_Low_N := Ada_Low - Time_Rep (Time_Zone) * Nano; - - if Date_N > Ada_Low_N then - High_N := Date_N; - Low_N := Ada_Low_N; - else - High_N := Ada_Low_N; - Low_N := Date_N; - end if; - - -- Determine the elapsed seconds since the start of Ada time - - Day_Dur := Time_Dur (High_N / Nano - Low_N / Nano); - - -- Count the number of days since the start of Ada time. 1901-01-01 - -- GMT was a Tuesday. - - Day_Count := Long_Integer (Day_Dur / Secs_In_Day) + 1; - - return Integer (Day_Count mod 7); - end Day_Of_Week; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Day_Secs : out Day_Duration; - Hour : out Integer; - Minute : out Integer; - Second : out Integer; - Sub_Sec : out Duration; - Leap_Sec : out Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) - is - -- The following constants represent the number of nanoseconds - -- elapsed since the start of Ada time to and including the non - -- leap centennial years. - - Year_2101 : constant Time_Rep := Ada_Low + - Time_Rep (49 * 366 + 151 * 365) * Nanos_In_Day; - Year_2201 : constant Time_Rep := Ada_Low + - Time_Rep (73 * 366 + 227 * 365) * Nanos_In_Day; - Year_2301 : constant Time_Rep := Ada_Low + - Time_Rep (97 * 366 + 303 * 365) * Nanos_In_Day; - - Date_Dur : Time_Dur; - Date_N : Time_Rep; - Day_Seconds : Natural; - Elapsed_Leaps : Natural; - Four_Year_Segs : Natural; - Hour_Seconds : Natural; - Is_Leap_Year : Boolean; - Next_Leap_N : Time_Rep; - Rem_Years : Natural; - Sub_Sec_N : Time_Rep; - Year_Day : Natural; - - begin - Date_N := Time_Rep (Date); - - -- Step 1: Leap seconds processing in UTC - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Date_N, Elapsed_Leaps, Next_Leap_N); - - Leap_Sec := Date_N >= Next_Leap_N; - - if Leap_Sec then - Elapsed_Leaps := Elapsed_Leaps + 1; - end if; - - -- The target does not support leap seconds - - else - Elapsed_Leaps := 0; - Leap_Sec := False; - end if; - - Date_N := Date_N - Time_Rep (Elapsed_Leaps) * Nano; - - -- Step 2: Time zone processing. This action converts the input date - -- from GMT to the requested time zone. Applies from Ada 2005 on. - - if Use_TZ then - if Time_Zone /= 0 then - Date_N := Date_N + Time_Rep (Time_Zone) * 60 * Nano; - end if; - - -- Ada 83 and 95 - - else - declare - Off : constant Long_Integer := - UTC_Time_Offset (Time (Date_N), Is_Historic); - - begin - Date_N := Date_N + Time_Rep (Off) * Nano; - end; - end if; - - -- Step 3: Non-leap centennial year adjustment in local time zone - - -- In order for all divisions to work properly and to avoid more - -- complicated arithmetic, we add fake February 29s to dates which - -- occur after a non-leap centennial year. - - if Date_N >= Year_2301 then - Date_N := Date_N + Time_Rep (3) * Nanos_In_Day; - - elsif Date_N >= Year_2201 then - Date_N := Date_N + Time_Rep (2) * Nanos_In_Day; - - elsif Date_N >= Year_2101 then - Date_N := Date_N + Time_Rep (1) * Nanos_In_Day; - end if; - - -- Step 4: Sub second processing in local time zone - - Sub_Sec_N := Date_N mod Nano; - Sub_Sec := Duration (Sub_Sec_N) / Nano_F; - Date_N := Date_N - Sub_Sec_N; - - -- Convert Date_N into a time duration value, changing the units - -- to seconds. - - Date_Dur := Time_Dur (Date_N / Nano - Ada_Low / Nano); - - -- Step 5: Year processing in local time zone. Determine the number - -- of four year segments since the start of Ada time and the input - -- date. - - Four_Year_Segs := Natural (Date_Dur / Secs_In_Four_Years); - - if Four_Year_Segs > 0 then - Date_Dur := Date_Dur - Time_Dur (Four_Year_Segs) * - Secs_In_Four_Years; - end if; - - -- Calculate the remaining non-leap years - - Rem_Years := Natural (Date_Dur / Secs_In_Non_Leap_Year); - - if Rem_Years > 3 then - Rem_Years := 3; - end if; - - Date_Dur := Date_Dur - Time_Dur (Rem_Years) * Secs_In_Non_Leap_Year; - - Year := Ada_Min_Year + Natural (4 * Four_Year_Segs + Rem_Years); - Is_Leap_Year := Is_Leap (Year); - - -- Step 6: Month and day processing in local time zone - - Year_Day := Natural (Date_Dur / Secs_In_Day) + 1; - - Month := 1; - - -- Processing for months after January - - if Year_Day > 31 then - Month := 2; - Year_Day := Year_Day - 31; - - -- Processing for a new month or a leap February - - if Year_Day > 28 - and then (not Is_Leap_Year or else Year_Day > 29) - then - Month := 3; - Year_Day := Year_Day - 28; - - if Is_Leap_Year then - Year_Day := Year_Day - 1; - end if; - - -- Remaining months - - while Year_Day > Days_In_Month (Month) loop - Year_Day := Year_Day - Days_In_Month (Month); - Month := Month + 1; - end loop; - end if; - end if; - - -- Step 7: Hour, minute, second and sub second processing in local - -- time zone. - - Day := Day_Number (Year_Day); - Day_Seconds := Integer (Date_Dur mod Secs_In_Day); - Day_Secs := Duration (Day_Seconds) + Sub_Sec; - Hour := Day_Seconds / 3_600; - Hour_Seconds := Day_Seconds mod 3_600; - Minute := Hour_Seconds / 60; - Second := Hour_Seconds mod 60; - - exception - when Constraint_Error => - raise Time_Error; - end Split; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - Hour : Integer; - Minute : Integer; - Second : Integer; - Sub_Sec : Duration; - Leap_Sec : Boolean; - Use_Day_Secs : Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) return Time - is - Count : Integer; - Elapsed_Leaps : Natural; - Next_Leap_N : Time_Rep; - Res_N : Time_Rep; - Rounded_Res_N : Time_Rep; - - begin - -- Step 1: Check whether the day, month and year form a valid date - - if Day > Days_In_Month (Month) - and then (Day /= 29 or else Month /= 2 or else not Is_Leap (Year)) - then - raise Time_Error; - end if; - - -- Start accumulating nanoseconds from the low bound of Ada time - - Res_N := Ada_Low; - - -- Step 2: Year processing and centennial year adjustment. Determine - -- the number of four year segments since the start of Ada time and - -- the input date. - - Count := (Year - Year_Number'First) / 4; - - for Four_Year_Segments in 1 .. Count loop - Res_N := Res_N + Nanos_In_Four_Years; - end loop; - - -- Note that non-leap centennial years are automatically considered - -- leap in the operation above. An adjustment of several days is - -- required to compensate for this. - - if Year > 2300 then - Res_N := Res_N - Time_Rep (3) * Nanos_In_Day; - - elsif Year > 2200 then - Res_N := Res_N - Time_Rep (2) * Nanos_In_Day; - - elsif Year > 2100 then - Res_N := Res_N - Time_Rep (1) * Nanos_In_Day; - end if; - - -- Add the remaining non-leap years - - Count := (Year - Year_Number'First) mod 4; - Res_N := Res_N + Time_Rep (Count) * Secs_In_Non_Leap_Year * Nano; - - -- Step 3: Day of month processing. Determine the number of days - -- since the start of the current year. Do not add the current - -- day since it has not elapsed yet. - - Count := Cumulative_Days_Before_Month (Month) + Day - 1; - - -- The input year is leap and we have passed February - - if Is_Leap (Year) - and then Month > 2 - then - Count := Count + 1; - end if; - - Res_N := Res_N + Time_Rep (Count) * Nanos_In_Day; - - -- Step 4: Hour, minute, second and sub second processing - - if Use_Day_Secs then - Res_N := Res_N + Duration_To_Time_Rep (Day_Secs); - - else - Res_N := - Res_N + Time_Rep (Hour * 3_600 + Minute * 60 + Second) * Nano; - - if Sub_Sec = 1.0 then - Res_N := Res_N + Time_Rep (1) * Nano; - else - Res_N := Res_N + Duration_To_Time_Rep (Sub_Sec); - end if; - end if; - - -- At this point, the generated time value should be withing the - -- bounds of Ada time. - - Check_Within_Time_Bounds (Res_N); - - -- Step 4: Time zone processing. At this point we have built an - -- arbitrary time value which is not related to any time zone. - -- For simplicity, the time value is normalized to GMT, producing - -- a uniform representation which can be treated by arithmetic - -- operations for instance without any additional corrections. - - if Use_TZ then - if Time_Zone /= 0 then - Res_N := Res_N - Time_Rep (Time_Zone) * 60 * Nano; - end if; - - -- Ada 83 and 95 - - else - declare - Cur_Off : constant Long_Integer := - UTC_Time_Offset (Time (Res_N), Is_Historic); - Cur_Res_N : constant Time_Rep := - Res_N - Time_Rep (Cur_Off) * Nano; - Off : constant Long_Integer := - UTC_Time_Offset (Time (Cur_Res_N), Is_Historic); - - begin - Res_N := Res_N - Time_Rep (Off) * Nano; - end; - end if; - - -- Step 5: Leap seconds processing in GMT - - if Leap_Support then - Cumulative_Leap_Seconds - (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); - - Res_N := Res_N + Time_Rep (Elapsed_Leaps) * Nano; - - -- An Ada 2005 caller requesting an explicit leap second or an - -- Ada 95 caller accounting for an invisible leap second. - - if Leap_Sec or else Res_N >= Next_Leap_N then - Res_N := Res_N + Time_Rep (1) * Nano; - end if; - - -- Leap second validity check - - Rounded_Res_N := Res_N - (Res_N mod Nano); - - if Use_TZ - and then Leap_Sec - and then Rounded_Res_N /= Next_Leap_N - then - raise Time_Error; - end if; - end if; - - return Time (Res_N); - end Time_Of; - - end Formatting_Operations; - - --------------------------- - -- Time_Zones_Operations -- - --------------------------- - - package body Time_Zones_Operations is - - --------------------- - -- UTC_Time_Offset -- - --------------------- - - function UTC_Time_Offset (Date : Time) return Long_Integer is - begin - return UTC_Time_Offset (Date, True); - end UTC_Time_Offset; - - end Time_Zones_Operations; - --- Start of elaboration code for Ada.Calendar - -begin - System.OS_Primitives.Initialize; - -end Ada.Calendar; diff --git a/gcc/ada/a-calend.ads b/gcc/ada/a-calend.ads deleted file mode 100644 index 39e9c33..0000000 --- a/gcc/ada/a-calend.ads +++ /dev/null @@ -1,395 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Calendar with - SPARK_Mode, - Abstract_State => (Clock_Time with Synchronous, - External => (Async_Readers, - Async_Writers)), - Initializes => Clock_Time -is - - type Time is private; - - -- Declarations representing limits of allowed local time values. Note that - -- these do NOT constrain the possible stored values of time which may well - -- permit a larger range of times (this is explicitly allowed in Ada 95). - - subtype Year_Number is Integer range 1901 .. 2399; - subtype Month_Number is Integer range 1 .. 12; - subtype Day_Number is Integer range 1 .. 31; - - -- A Day_Duration value of 86_400.0 designates a new day - - subtype Day_Duration is Duration range 0.0 .. 86_400.0; - - function Clock return Time with - Volatile_Function, - Global => Clock_Time; - -- The returned time value is the number of nanoseconds since the start - -- of Ada time (1901-01-01 00:00:00.0 UTC). If leap seconds are enabled, - -- the result will contain all elapsed leap seconds since the start of - -- Ada time until now. - - function Year (Date : Time) return Year_Number; - function Month (Date : Time) return Month_Number; - function Day (Date : Time) return Day_Number; - function Seconds (Date : Time) return Day_Duration; - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration); - -- Break down a time value into its date components set in the current - -- time zone. If Split is called on a time value created using Ada 2005 - -- Time_Of in some arbitrary time zone, the input value will always be - -- interpreted as relative to the local time zone. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0) return Time; - -- GNAT Note: Normally when procedure Split is called on a Time value - -- result of a call to function Time_Of, the out parameters of procedure - -- Split are identical to the in parameters of function Time_Of. However, - -- when a non-existent time of day is specified, the values for Seconds - -- may or may not be different. This may happen when Daylight Saving Time - -- (DST) is in effect, on the day when switching to DST, if Seconds - -- specifies a time of day in the hour that does not exist. For example, - -- in New York: - -- - -- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0) - -- - -- will return a Time value T. If Split is called on T, the resulting - -- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being - -- a time that not exist). - - function "+" (Left : Time; Right : Duration) return Time; - function "+" (Left : Duration; Right : Time) return Time; - function "-" (Left : Time; Right : Duration) return Time; - function "-" (Left : Time; Right : Time) return Duration; - -- The first three functions will raise Time_Error if the resulting time - -- value is less than the start of Ada time in UTC or greater than the - -- end of Ada time in UTC. The last function will raise Time_Error if the - -- resulting difference cannot fit into a duration value. - - function "<" (Left, Right : Time) return Boolean; - function "<=" (Left, Right : Time) return Boolean; - function ">" (Left, Right : Time) return Boolean; - function ">=" (Left, Right : Time) return Boolean; - - Time_Error : exception; - -private - -- Mark the private part as SPARK_Mode Off to avoid accounting for variable - -- Invalid_Time_Zone_Offset in abstract state. - - pragma SPARK_Mode (Off); - - pragma Inline (Clock); - - pragma Inline (Year); - pragma Inline (Month); - pragma Inline (Day); - - pragma Inline ("+"); - pragma Inline ("-"); - - pragma Inline ("<"); - pragma Inline ("<="); - pragma Inline (">"); - pragma Inline (">="); - - -- The units used in this version of Ada.Calendar are nanoseconds. The - -- following constants provide values used in conversions of seconds or - -- days to the underlying units. - - Nano : constant := 1_000_000_000; - Nano_F : constant := 1_000_000_000.0; - Nanos_In_Day : constant := 86_400_000_000_000; - Secs_In_Day : constant := 86_400; - - ---------------------------- - -- Implementation of Time -- - ---------------------------- - - -- Time is represented as a signed 64 bit integer count of nanoseconds - -- since the start of Ada time (1901-01-01 00:00:00.0 UTC). Time values - -- produced by Time_Of are internally normalized to UTC regardless of their - -- local time zone. This representation ensures correct handling of leap - -- seconds as well as performing arithmetic. In Ada 95, Split and Time_Of - -- will treat a time value as being in the local time zone, in Ada 2005, - -- Split and Time_Of will treat a time value as being in the designated - -- time zone by the formal parameter or in UTC by default. The size of the - -- type is large enough to cover the Ada 2005 range of time (1901-01-01 - -- 00:00:00.0 UTC - 2399-12-31-23:59:59.999999999 UTC). - - ------------------ - -- Leap Seconds -- - ------------------ - - -- Due to Earth's slowdown, the astronomical time is not as precise as the - -- International Atomic Time. To compensate for this inaccuracy, a single - -- leap second is added after the last day of June or December. The count - -- of seconds during those occurrences becomes: - - -- ... 58, 59, leap second 60, 0, 1, 2 ... - - -- Unlike leap days, leap seconds occur simultaneously around the world. - -- In other words, if a leap second occurs at 23:59:60 UTC, it also occurs - -- on 18:59:60 -5 the same day or 2:59:60 +2 on the next day. - - -- Leap seconds do not follow a formula. The International Earth Rotation - -- and Reference System Service decides when to add one. Leap seconds are - -- included in the representation of time in Ada 95 mode. As a result, - -- the following two time values will differ by two seconds: - - -- 1972-06-30 23:59:59.0 - -- 1972-07-01 00:00:00.0 - - -- When a new leap second is introduced, the following steps must be - -- carried out: - - -- 1) Increment Leap_Seconds_Count in a-calend.adb by one - -- 2) Increment LS_Count in xleaps.adb by one - -- 3) Add the new date to the aggregate of array LS_Dates in - -- xleaps.adb - -- 4) Compile and execute xleaps - -- 5) Replace the values of Leap_Second_Times in a-calend.adb with the - -- aggregate generated by xleaps - - -- The algorithms that build the actual leap second values and discover - -- how many leap seconds have occurred between two dates do not need any - -- modification. - - ------------------------------ - -- Non-leap Centennial Years -- - ------------------------------ - - -- Over the range of Ada time, centennial years 2100, 2200 and 2300 are - -- non-leap. As a consequence, seven non-leap years occur over the period - -- of year - 4 to year + 4. Internally, routines Split and Time_Of add or - -- subtract a "fake" February 29 to facilitate the arithmetic involved. - - ------------------------ - -- Local Declarations -- - ------------------------ - - type Time_Rep is new Long_Long_Integer; - type Time is new Time_Rep; - -- The underlying type of Time has been chosen to be a 64 bit signed - -- integer number since it allows for easier processing of sub-seconds - -- and arithmetic. We use Long_Long_Integer to allow this unit to compile - -- when using custom target configuration files where the max integer is - -- 32 bits. This is useful for static analysis tools such as SPARK or - -- CodePeer. - -- - -- Note: the reason we have two separate types here is to avoid problems - -- with overloading ambiguities in the body if we tried to use Time as an - -- internal computational type. - - Days_In_Month : constant array (Month_Number) of Day_Number := - (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); - -- Days in month for non-leap year, leap year case is adjusted in code - - Invalid_Time_Zone_Offset : Long_Integer; - pragma Import (C, Invalid_Time_Zone_Offset, "__gnat_invalid_tzoff"); - - function Is_Leap (Year : Year_Number) return Boolean; - -- Determine whether a given year is leap - - ---------------------------------------------------------- - -- Target-Independent Interface to Children of Calendar -- - ---------------------------------------------------------- - - -- The following packages provide a target-independent interface to the - -- children of Calendar - Arithmetic, Conversions, Delays, Formatting and - -- Time_Zones. - - --------------------------- - -- Arithmetic_Operations -- - --------------------------- - - package Arithmetic_Operations is - - function Add (Date : Time; Days : Long_Integer) return Time; - -- Add a certain number of days to a time value - - procedure Difference - (Left : Time; - Right : Time; - Days : out Long_Integer; - Seconds : out Duration; - Leap_Seconds : out Integer); - -- Calculate the difference between two time values in terms of days, - -- seconds and leap seconds elapsed. The leap seconds are not included - -- in the seconds returned. If Left is greater than Right, the returned - -- values are positive, negative otherwise. - - function Subtract (Date : Time; Days : Long_Integer) return Time; - -- Subtract a certain number of days from a time value - - end Arithmetic_Operations; - - --------------------------- - -- Conversion_Operations -- - --------------------------- - - package Conversion_Operations is - - function To_Ada_Time (Unix_Time : Long_Integer) return Time; - -- Unix to Ada Epoch conversion - - function To_Ada_Time - (tm_year : Integer; - tm_mon : Integer; - tm_day : Integer; - tm_hour : Integer; - tm_min : Integer; - tm_sec : Integer; - tm_isdst : Integer) return Time; - -- Struct tm to Ada Epoch conversion - - function To_Duration - (tv_sec : Long_Integer; - tv_nsec : Long_Integer) return Duration; - -- Struct timespec to Duration conversion - - procedure To_Struct_Timespec - (D : Duration; - tv_sec : out Long_Integer; - tv_nsec : out Long_Integer); - -- Duration to struct timespec conversion - - procedure To_Struct_Tm - (T : Time; - tm_year : out Integer; - tm_mon : out Integer; - tm_day : out Integer; - tm_hour : out Integer; - tm_min : out Integer; - tm_sec : out Integer); - -- Time to struct tm conversion - - function To_Unix_Time (Ada_Time : Time) return Long_Integer; - -- Ada to Unix Epoch conversion - - end Conversion_Operations; - - ---------------------- - -- Delay_Operations -- - ---------------------- - - package Delay_Operations is - - function To_Duration (Date : Time) return Duration; - -- Given a time value in nanoseconds since 1901, convert it into a - -- duration value giving the number of nanoseconds since the Unix Epoch. - - end Delay_Operations; - - --------------------------- - -- Formatting_Operations -- - --------------------------- - - package Formatting_Operations is - - function Day_Of_Week (Date : Time) return Integer; - -- Determine which day of week Date falls on. The returned values are - -- within the range of 0 .. 6 (Monday .. Sunday). - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Day_Secs : out Day_Duration; - Hour : out Integer; - Minute : out Integer; - Second : out Integer; - Sub_Sec : out Duration; - Leap_Sec : out Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer); - pragma Export (Ada, Split, "__gnat_split"); - -- Split a time value into its components. If flag Is_Historic is set, - -- this routine would try to use to the best of the OS's abilities the - -- time zone offset that was or will be in effect on Date. Set Use_TZ - -- to use the local time zone (the value in Time_Zone is ignored) when - -- splitting a time value. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - Hour : Integer; - Minute : Integer; - Second : Integer; - Sub_Sec : Duration; - Leap_Sec : Boolean; - Use_Day_Secs : Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) return Time; - pragma Export (Ada, Time_Of, "__gnat_time_of"); - -- Given all the components of a date, return the corresponding time - -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the - -- day duration will be calculated from Hour, Minute, Second and Sub_ - -- Sec. If flag Is_Historic is set, this routine would try to use to the - -- best of the OS's abilities the time zone offset that was or will be - -- in effect on the input date. Set Use_TZ to use the local time zone - -- (the value in formal Time_Zone is ignored) when building a time value - -- and to verify the validity of a requested leap second. - - end Formatting_Operations; - - --------------------------- - -- Time_Zones_Operations -- - --------------------------- - - package Time_Zones_Operations is - - function UTC_Time_Offset (Date : Time) return Long_Integer; - -- Return (in seconds) the difference between the local time zone and - -- UTC time at a specific historic date. - - end Time_Zones_Operations; - -end Ada.Calendar; diff --git a/gcc/ada/a-calfor.adb b/gcc/ada/a-calfor.adb deleted file mode 100644 index 6da6f1d..0000000 --- a/gcc/ada/a-calfor.adb +++ /dev/null @@ -1,882 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . F O R M A T T I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Calendar; use Ada.Calendar; -with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones; - -package body Ada.Calendar.Formatting is - - -------------------------- - -- Implementation Notes -- - -------------------------- - - -- All operations in this package are target and time representation - -- independent, thus only one source file is needed for multiple targets. - - procedure Check_Char (S : String; C : Character; Index : Integer); - -- Subsidiary to the two versions of Value. Determine whether the input - -- string S has character C at position Index. Raise Constraint_Error if - -- there is a mismatch. - - procedure Check_Digit (S : String; Index : Integer); - -- Subsidiary to the two versions of Value. Determine whether the character - -- of string S at position Index is a digit. This catches invalid input - -- such as 1983-*1-j3 u5:n7:k9 which should be 1983-01-03 05:07:09. Raise - -- Constraint_Error if there is a mismatch. - - ---------------- - -- Check_Char -- - ---------------- - - procedure Check_Char (S : String; C : Character; Index : Integer) is - begin - if S (Index) /= C then - raise Constraint_Error; - end if; - end Check_Char; - - ----------------- - -- Check_Digit -- - ----------------- - - procedure Check_Digit (S : String; Index : Integer) is - begin - if S (Index) not in '0' .. '9' then - raise Constraint_Error; - end if; - end Check_Digit; - - --------- - -- Day -- - --------- - - function Day - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Day_Number - is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - H : Hour_Number; - Mi : Minute_Number; - Se : Second_Number; - Ss : Second_Duration; - Le : Boolean; - - pragma Unreferenced (Y, Mo, H, Mi); - - begin - Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); - return D; - end Day; - - ----------------- - -- Day_Of_Week -- - ----------------- - - function Day_Of_Week (Date : Time) return Day_Name is - begin - return Day_Name'Val (Formatting_Operations.Day_Of_Week (Date)); - end Day_Of_Week; - - ---------- - -- Hour -- - ---------- - - function Hour - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Hour_Number - is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - H : Hour_Number; - Mi : Minute_Number; - Se : Second_Number; - Ss : Second_Duration; - Le : Boolean; - - pragma Unreferenced (Y, Mo, D, Mi); - - begin - Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); - return H; - end Hour; - - ----------- - -- Image -- - ----------- - - function Image - (Elapsed_Time : Duration; - Include_Time_Fraction : Boolean := False) return String - is - To_Char : constant array (0 .. 9) of Character := "0123456789"; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Duration; - SS_Nat : Natural; - - -- Determine the two slice bounds for the result string depending on - -- whether the input is negative and whether fractions are requested. - - First : constant Integer := (if Elapsed_Time < 0.0 then 1 else 2); - Last : constant Integer := (if Include_Time_Fraction then 12 else 9); - - Result : String := "-00:00:00.00"; - - begin - Split (abs (Elapsed_Time), Hour, Minute, Second, Sub_Second); - - -- Hour processing, positions 2 and 3 - - Result (2) := To_Char (Hour / 10); - Result (3) := To_Char (Hour mod 10); - - -- Minute processing, positions 5 and 6 - - Result (5) := To_Char (Minute / 10); - Result (6) := To_Char (Minute mod 10); - - -- Second processing, positions 8 and 9 - - Result (8) := To_Char (Second / 10); - Result (9) := To_Char (Second mod 10); - - -- Optional sub second processing, positions 11 and 12 - - if Include_Time_Fraction and then Sub_Second > 0.0 then - - -- Prevent rounding up when converting to natural, avoiding the zero - -- case to prevent rounding down to a negative number. - - SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5); - - Result (11) := To_Char (SS_Nat / 10); - Result (12) := To_Char (SS_Nat mod 10); - end if; - - return Result (First .. Last); - end Image; - - ----------- - -- Image -- - ----------- - - function Image - (Date : Time; - Include_Time_Fraction : Boolean := False; - Time_Zone : Time_Zones.Time_Offset := 0) return String - is - To_Char : constant array (0 .. 9) of Character := "0123456789"; - - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Duration; - SS_Nat : Natural; - Leap_Second : Boolean; - - -- The result length depends on whether fractions are requested. - - Result : String := "0000-00-00 00:00:00.00"; - Last : constant Positive := - Result'Last - (if Include_Time_Fraction then 0 else 3); - - begin - Split (Date, Year, Month, Day, - Hour, Minute, Second, Sub_Second, Leap_Second, Time_Zone); - - -- Year processing, positions 1, 2, 3 and 4 - - Result (1) := To_Char (Year / 1000); - Result (2) := To_Char (Year / 100 mod 10); - Result (3) := To_Char (Year / 10 mod 10); - Result (4) := To_Char (Year mod 10); - - -- Month processing, positions 6 and 7 - - Result (6) := To_Char (Month / 10); - Result (7) := To_Char (Month mod 10); - - -- Day processing, positions 9 and 10 - - Result (9) := To_Char (Day / 10); - Result (10) := To_Char (Day mod 10); - - Result (12) := To_Char (Hour / 10); - Result (13) := To_Char (Hour mod 10); - - -- Minute processing, positions 15 and 16 - - Result (15) := To_Char (Minute / 10); - Result (16) := To_Char (Minute mod 10); - - -- Second processing, positions 18 and 19 - - Result (18) := To_Char (Second / 10); - Result (19) := To_Char (Second mod 10); - - -- Optional sub second processing, positions 21 and 22 - - if Include_Time_Fraction and then Sub_Second > 0.0 then - - -- Prevent rounding up when converting to natural, avoiding the zero - -- case to prevent rounding down to a negative number. - - SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5); - - Result (21) := To_Char (SS_Nat / 10); - Result (22) := To_Char (SS_Nat mod 10); - end if; - - return Result (Result'First .. Last); - end Image; - - ------------ - -- Minute -- - ------------ - - function Minute - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Minute_Number - is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - H : Hour_Number; - Mi : Minute_Number; - Se : Second_Number; - Ss : Second_Duration; - Le : Boolean; - - pragma Unreferenced (Y, Mo, D, H); - - begin - Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); - return Mi; - end Minute; - - ----------- - -- Month -- - ----------- - - function Month - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Month_Number - is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - H : Hour_Number; - Mi : Minute_Number; - Se : Second_Number; - Ss : Second_Duration; - Le : Boolean; - - pragma Unreferenced (Y, D, H, Mi); - - begin - Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); - return Mo; - end Month; - - ------------ - -- Second -- - ------------ - - function Second (Date : Time) return Second_Number is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - H : Hour_Number; - Mi : Minute_Number; - Se : Second_Number; - Ss : Second_Duration; - Le : Boolean; - - pragma Unreferenced (Y, Mo, D, H, Mi); - - begin - Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le); - return Se; - end Second; - - ---------------- - -- Seconds_Of -- - ---------------- - - function Seconds_Of - (Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number := 0; - Sub_Second : Second_Duration := 0.0) return Day_Duration is - - begin - -- Validity checks - - if not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - then - raise Constraint_Error; - end if; - - return Day_Duration (Hour * 3_600) + - Day_Duration (Minute * 60) + - Day_Duration (Second) + - Sub_Second; - end Seconds_Of; - - ----------- - -- Split -- - ----------- - - procedure Split - (Seconds : Day_Duration; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration) - is - Secs : Natural; - - begin - -- Validity checks - - if not Seconds'Valid then - raise Constraint_Error; - end if; - - Secs := (if Seconds = 0.0 then 0 else Natural (Seconds - 0.5)); - - Sub_Second := Second_Duration (Seconds - Day_Duration (Secs)); - Hour := Hour_Number (Secs / 3_600); - Secs := Secs mod 3_600; - Minute := Minute_Number (Secs / 60); - Second := Second_Number (Secs mod 60); - - -- Validity checks - - if not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - then - raise Time_Error; - end if; - end Split; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration; - Leap_Second : out Boolean; - Time_Zone : Time_Zones.Time_Offset := 0) - is - H : Integer; - M : Integer; - Se : Integer; - Su : Duration; - Tz : constant Long_Integer := Long_Integer (Time_Zone); - - begin - Formatting_Operations.Split - (Date => Date, - Year => Year, - Month => Month, - Day => Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Su, - Leap_Sec => Leap_Second, - Use_TZ => True, - Is_Historic => True, - Time_Zone => Tz); - - -- Validity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Seconds'Valid - then - raise Time_Error; - end if; - end Split; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration; - Time_Zone : Time_Zones.Time_Offset := 0) - is - Dd : Day_Duration; - Le : Boolean; - Tz : constant Long_Integer := Long_Integer (Time_Zone); - - begin - Formatting_Operations.Split - (Date => Date, - Year => Year, - Month => Month, - Day => Day, - Day_Secs => Dd, - Hour => Hour, - Minute => Minute, - Second => Second, - Sub_Sec => Sub_Second, - Leap_Sec => Le, - Use_TZ => True, - Is_Historic => True, - Time_Zone => Tz); - - -- Validity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - then - raise Time_Error; - end if; - end Split; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration; - Leap_Second : out Boolean; - Time_Zone : Time_Zones.Time_Offset := 0) - is - Dd : Day_Duration; - Tz : constant Long_Integer := Long_Integer (Time_Zone); - - begin - Formatting_Operations.Split - (Date => Date, - Year => Year, - Month => Month, - Day => Day, - Day_Secs => Dd, - Hour => Hour, - Minute => Minute, - Second => Second, - Sub_Sec => Sub_Second, - Leap_Sec => Leap_Second, - Use_TZ => True, - Is_Historic => True, - Time_Zone => Tz); - - -- Validity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - then - raise Time_Error; - end if; - end Split; - - ---------------- - -- Sub_Second -- - ---------------- - - function Sub_Second (Date : Time) return Second_Duration is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - H : Hour_Number; - Mi : Minute_Number; - Se : Second_Number; - Ss : Second_Duration; - Le : Boolean; - - pragma Unreferenced (Y, Mo, D, H, Mi); - - begin - Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le); - return Ss; - end Sub_Second; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0; - Leap_Second : Boolean := False; - Time_Zone : Time_Zones.Time_Offset := 0) return Time - is - Adj_Year : Year_Number := Year; - Adj_Month : Month_Number := Month; - Adj_Day : Day_Number := Day; - - H : constant Integer := 1; - M : constant Integer := 1; - Se : constant Integer := 1; - Ss : constant Duration := 0.1; - Tz : constant Long_Integer := Long_Integer (Time_Zone); - - begin - -- Validity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Seconds'Valid - or else not Time_Zone'Valid - then - raise Constraint_Error; - end if; - - -- A Seconds value of 86_400 denotes a new day. This case requires an - -- adjustment to the input values. - - if Seconds = 86_400.0 then - if Day < Days_In_Month (Month) - or else (Is_Leap (Year) - and then Month = 2) - then - Adj_Day := Day + 1; - else - Adj_Day := 1; - - if Month < 12 then - Adj_Month := Month + 1; - else - Adj_Month := 1; - Adj_Year := Year + 1; - end if; - end if; - end if; - - return - Formatting_Operations.Time_Of - (Year => Adj_Year, - Month => Adj_Month, - Day => Adj_Day, - Day_Secs => Seconds, - Hour => H, - Minute => M, - Second => Se, - Sub_Sec => Ss, - Leap_Sec => Leap_Second, - Use_Day_Secs => True, - Use_TZ => True, - Is_Historic => True, - Time_Zone => Tz); - end Time_Of; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0; - Leap_Second : Boolean := False; - Time_Zone : Time_Zones.Time_Offset := 0) return Time - is - Dd : constant Day_Duration := Day_Duration'First; - Tz : constant Long_Integer := Long_Integer (Time_Zone); - - begin - -- Validity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - or else not Time_Zone'Valid - then - raise Constraint_Error; - end if; - - return - Formatting_Operations.Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => Dd, - Hour => Hour, - Minute => Minute, - Second => Second, - Sub_Sec => Sub_Second, - Leap_Sec => Leap_Second, - Use_Day_Secs => False, - Use_TZ => True, - Is_Historic => True, - Time_Zone => Tz); - end Time_Of; - - ----------- - -- Value -- - ----------- - - function Value - (Date : String; - Time_Zone : Time_Zones.Time_Offset := 0) return Time - is - D : String (1 .. 22); - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0; - - begin - -- Validity checks - - if not Time_Zone'Valid then - raise Constraint_Error; - end if; - - -- Length checks - - if Date'Length /= 19 - and then Date'Length /= 22 - then - raise Constraint_Error; - end if; - - -- After the correct length has been determined, it is safe to copy the - -- Date in order to avoid Date'First + N indexing. - - D (1 .. Date'Length) := Date; - - -- Format checks - - Check_Char (D, '-', 5); - Check_Char (D, '-', 8); - Check_Char (D, ' ', 11); - Check_Char (D, ':', 14); - Check_Char (D, ':', 17); - - if Date'Length = 22 then - Check_Char (D, '.', 20); - end if; - - -- Leading zero checks - - Check_Digit (D, 6); - Check_Digit (D, 9); - Check_Digit (D, 12); - Check_Digit (D, 15); - Check_Digit (D, 18); - - if Date'Length = 22 then - Check_Digit (D, 21); - end if; - - -- Value extraction - - Year := Year_Number (Year_Number'Value (D (1 .. 4))); - Month := Month_Number (Month_Number'Value (D (6 .. 7))); - Day := Day_Number (Day_Number'Value (D (9 .. 10))); - Hour := Hour_Number (Hour_Number'Value (D (12 .. 13))); - Minute := Minute_Number (Minute_Number'Value (D (15 .. 16))); - Second := Second_Number (Second_Number'Value (D (18 .. 19))); - - -- Optional part - - if Date'Length = 22 then - Sub_Second := Second_Duration (Second_Duration'Value (D (20 .. 22))); - end if; - - -- Sanity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - then - raise Constraint_Error; - end if; - - return Time_Of (Year, Month, Day, - Hour, Minute, Second, Sub_Second, False, Time_Zone); - - exception - when others => raise Constraint_Error; - end Value; - - ----------- - -- Value -- - ----------- - - function Value (Elapsed_Time : String) return Duration is - D : String (1 .. 11); - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0; - - begin - -- Length checks - - if Elapsed_Time'Length /= 8 - and then Elapsed_Time'Length /= 11 - then - raise Constraint_Error; - end if; - - -- After the correct length has been determined, it is safe to copy the - -- Elapsed_Time in order to avoid Date'First + N indexing. - - D (1 .. Elapsed_Time'Length) := Elapsed_Time; - - -- Format checks - - Check_Char (D, ':', 3); - Check_Char (D, ':', 6); - - if Elapsed_Time'Length = 11 then - Check_Char (D, '.', 9); - end if; - - -- Leading zero checks - - Check_Digit (D, 1); - Check_Digit (D, 4); - Check_Digit (D, 7); - - if Elapsed_Time'Length = 11 then - Check_Digit (D, 10); - end if; - - -- Value extraction - - Hour := Hour_Number (Hour_Number'Value (D (1 .. 2))); - Minute := Minute_Number (Minute_Number'Value (D (4 .. 5))); - Second := Second_Number (Second_Number'Value (D (7 .. 8))); - - -- Optional part - - if Elapsed_Time'Length = 11 then - Sub_Second := Second_Duration (Second_Duration'Value (D (9 .. 11))); - end if; - - -- Sanity checks - - if not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Sub_Second'Valid - then - raise Constraint_Error; - end if; - - return Seconds_Of (Hour, Minute, Second, Sub_Second); - - exception - when others => raise Constraint_Error; - end Value; - - ---------- - -- Year -- - ---------- - - function Year - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Year_Number - is - Y : Year_Number; - Mo : Month_Number; - D : Day_Number; - H : Hour_Number; - Mi : Minute_Number; - Se : Second_Number; - Ss : Second_Duration; - Le : Boolean; - - pragma Unreferenced (Mo, D, H, Mi); - - begin - Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); - return Y; - end Year; - -end Ada.Calendar.Formatting; diff --git a/gcc/ada/a-calfor.ads b/gcc/ada/a-calfor.ads deleted file mode 100644 index 8cfd6a4..0000000 --- a/gcc/ada/a-calfor.ads +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . F O R M A T T I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2013, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This package provides additional components to Time, as well as new --- Time_Of and Split routines which handle time zones and leap seconds. --- This package is defined in the Ada 2005 RM (9.6.1). - -with Ada.Calendar.Time_Zones; - -package Ada.Calendar.Formatting is - - -- Day of the week - - type Day_Name is - (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); - - function Day_Of_Week (Date : Time) return Day_Name; - - -- Hours:Minutes:Seconds access - - subtype Hour_Number is Natural range 0 .. 23; - subtype Minute_Number is Natural range 0 .. 59; - subtype Second_Number is Natural range 0 .. 59; - subtype Second_Duration is Day_Duration range 0.0 .. 1.0; - - function Year - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Year_Number; - - function Month - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Month_Number; - - function Day - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Day_Number; - - function Hour - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Hour_Number; - - function Minute - (Date : Time; - Time_Zone : Time_Zones.Time_Offset := 0) return Minute_Number; - - function Second - (Date : Time) return Second_Number; - - function Sub_Second - (Date : Time) return Second_Duration; - - function Seconds_Of - (Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number := 0; - Sub_Second : Second_Duration := 0.0) return Day_Duration; - -- Returns a Day_Duration value for the combination of the given Hour, - -- Minute, Second, and Sub_Second. This value can be used in Ada.Calendar. - -- Time_Of as well as the argument to Calendar."+" and Calendar."-". If - -- Seconds_Of is called with a Sub_Second value of 1.0, the value returned - -- is equal to the value of Seconds_Of for the next second with a Sub_ - -- Second value of 0.0. - - procedure Split - (Seconds : Day_Duration; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration); - -- Splits Seconds into Hour, Minute, Second and Sub_Second in such a way - -- that the resulting values all belong to their respective subtypes. The - -- value returned in the Sub_Second parameter is always less than 1.0. - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration; - Time_Zone : Time_Zones.Time_Offset := 0); - -- Splits Date into its constituent parts (Year, Month, Day, Hour, Minute, - -- Second, Sub_Second), relative to the specified time zone offset. The - -- value returned in the Sub_Second parameter is always less than 1.0. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0; - Leap_Second : Boolean := False; - Time_Zone : Time_Zones.Time_Offset := 0) return Time; - -- If Leap_Second is False, returns a Time built from the date and time - -- values, relative to the specified time zone offset. If Leap_Second is - -- True, returns the Time that represents the time within the leap second - -- that is one second later than the time specified by the parameters. - -- Time_Error is raised if the parameters do not form a proper date or - -- time. If Time_Of is called with a Sub_Second value of 1.0, the value - -- returned is equal to the value of Time_Of for the next second with a - -- Sub_Second value of 0.0. - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Seconds : Day_Duration := 0.0; - Leap_Second : Boolean := False; - Time_Zone : Time_Zones.Time_Offset := 0) return Time; - -- If Leap_Second is False, returns a Time built from the date and time - -- values, relative to the specified time zone offset. If Leap_Second is - -- True, returns the Time that represents the time within the leap second - -- that is one second later than the time specified by the parameters. - -- Time_Error is raised if the parameters do not form a proper date or - -- time. If Time_Of is called with a Seconds value of 86_400.0, the value - -- returned is equal to the value of Time_Of for the next day with a - -- Seconds value of 0.0. - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration; - Leap_Second : out Boolean; - Time_Zone : Time_Zones.Time_Offset := 0); - -- If Date does not represent a time within a leap second, splits Date - -- into its constituent parts (Year, Month, Day, Hour, Minute, Second, - -- Sub_Second), relative to the specified time zone offset, and sets - -- Leap_Second to False. If Date represents a time within a leap second, - -- set the constituent parts to values corresponding to a time one second - -- earlier than that given by Date, relative to the specified time zone - -- offset, and sets Leap_Seconds to True. The value returned in the - -- Sub_Second parameter is always less than 1.0. - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Seconds : out Day_Duration; - Leap_Second : out Boolean; - Time_Zone : Time_Zones.Time_Offset := 0); - -- If Date does not represent a time within a leap second, splits Date - -- into its constituent parts (Year, Month, Day, Seconds), relative to the - -- specified time zone offset, and sets Leap_Second to False. If Date - -- represents a time within a leap second, set the constituent parts to - -- values corresponding to a time one second earlier than that given by - -- Date, relative to the specified time zone offset, and sets Leap_Seconds - -- to True. The value returned in the Seconds parameter is always less - -- than 86_400.0. - - -- Simple image and value - - function Image - (Date : Time; - Include_Time_Fraction : Boolean := False; - Time_Zone : Time_Zones.Time_Offset := 0) return String; - -- Returns a string form of the Date relative to the given Time_Zone. The - -- format is "Year-Month-Day Hour:Minute:Second", where the Year is a - -- 4-digit value, and all others are 2-digit values, of the functions - -- defined in Ada.Calendar and Ada.Calendar.Formatting, including a - -- leading zero, if needed. The separators between the values are a minus, - -- another minus, a colon, and a single space between the Day and Hour. If - -- Include_Time_Fraction is True, the integer part of Sub_Seconds*100 is - -- suffixed to the string as a point followed by a 2-digit value. - - function Value - (Date : String; - Time_Zone : Time_Zones.Time_Offset := 0) return Time; - -- Returns a Time value for the image given as Date, relative to the given - -- time zone. Constraint_Error is raised if the string is not formatted as - -- described for Image, or the function cannot interpret the given string - -- as a Time value. - - function Image - (Elapsed_Time : Duration; - Include_Time_Fraction : Boolean := False) return String; - -- Returns a string form of the Elapsed_Time. The format is "Hour:Minute: - -- Second", where all values are 2-digit values, including a leading zero, - -- if needed. The separators between the values are colons. If Include_ - -- Time_Fraction is True, the integer part of Sub_Seconds*100 is suffixed - -- to the string as a point followed by a 2-digit value. If Elapsed_Time < - -- 0.0, the result is Image (abs Elapsed_Time, Include_Time_Fraction) - -- prefixed with a minus sign. If abs Elapsed_Time represents 100 hours or - -- more, the result is implementation-defined. - - function Value (Elapsed_Time : String) return Duration; - -- Returns a Duration value for the image given as Elapsed_Time. - -- Constraint_Error is raised if the string is not formatted as described - -- for Image, or the function cannot interpret the given string as a - -- Duration value. - -end Ada.Calendar.Formatting; diff --git a/gcc/ada/a-catizo.adb b/gcc/ada/a-catizo.adb deleted file mode 100644 index 3c3c02f..0000000 --- a/gcc/ada/a-catizo.adb +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . T I M E _ Z O N E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Calendar.Time_Zones is - - -------------------------- - -- Implementation Notes -- - -------------------------- - - -- All operations in this package are target and time representation - -- independent, thus only one source file is needed for multiple targets. - - --------------------- - -- UTC_Time_Offset -- - --------------------- - - function UTC_Time_Offset (Date : Time := Clock) return Time_Offset is - Offset_L : constant Long_Integer := - Time_Zones_Operations.UTC_Time_Offset (Date); - Offset : Time_Offset; - - begin - if Offset_L = Invalid_Time_Zone_Offset then - raise Unknown_Zone_Error; - end if; - - -- The offset returned by Time_Zones_Operations.UTC_Time_Offset is in - -- seconds, the returned value needs to be in minutes. - - Offset := Time_Offset (Offset_L / 60); - - -- Validity checks - - if not Offset'Valid then - raise Unknown_Zone_Error; - end if; - - return Offset; - end UTC_Time_Offset; - -end Ada.Calendar.Time_Zones; diff --git a/gcc/ada/a-catizo.ads b/gcc/ada/a-catizo.ads deleted file mode 100644 index 5f55869..0000000 --- a/gcc/ada/a-catizo.ads +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C A L E N D A R . T I M E _ Z O N E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This package provides routines to determine the offset of dates to GMT. --- It is defined in the Ada 2005 RM (9.6.1). - -package Ada.Calendar.Time_Zones is - - -- Time zone manipulation - - type Time_Offset is range -(28 * 60) .. 28 * 60; - - Unknown_Zone_Error : exception; - - function UTC_Time_Offset (Date : Time := Clock) return Time_Offset; - -- Returns (in minutes), the difference between the implementation-defined - -- time zone of Calendar, and UTC time, at the time Date. If the time zone - -- of the Calendar implementation is unknown, raises Unknown_Zone_Error. - -end Ada.Calendar.Time_Zones; diff --git a/gcc/ada/a-cbdlli.adb b/gcc/ada/a-cbdlli.adb deleted file mode 100644 index 8f7b537..0000000 --- a/gcc/ada/a-cbdlli.adb +++ /dev/null @@ -1,2399 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; use type System.Address; - -package body Ada.Containers.Bounded_Doubly_Linked_Lists is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type); - - procedure Allocate - (Container : in out List; - Stream : not null access Root_Stream_Type'Class; - New_Node : out Count_Type); - - procedure Free - (Container : in out List; - X : Count_Type); - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type); - - procedure Splice_Internal - (Target : in out List; - Before : Count_Type; - Source : in out List); - - procedure Splice_Internal - (Target : in out List; - Before : Count_Type; - Source : in out List; - Src_Pos : Count_Type; - Tgt_Pos : out Count_Type); - - function Vet (Position : Cursor) return Boolean; - -- Checks invariants of the cursor and its designated container, as a - -- simple way of detecting dangling references (see operation Free for a - -- description of the detection mechanism), returning True if all checks - -- pass. Invocations of Vet are used here as the argument of pragma Assert, - -- so the checks are performed only when assertions are enabled. - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : List) return Boolean is - begin - if Left.Length /= Right.Length then - return False; - end if; - - if Left.Length = 0 then - return True; - end if; - - declare - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - LN : Node_Array renames Left.Nodes; - RN : Node_Array renames Right.Nodes; - - LI : Count_Type := Left.First; - RI : Count_Type := Right.First; - begin - for J in 1 .. Left.Length loop - if LN (LI).Element /= RN (RI).Element then - return False; - end if; - - LI := LN (LI).Next; - RI := RN (RI).Next; - end loop; - end; - - return True; - end "="; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Free >= 0 then - New_Node := Container.Free; - - -- We always perform the assignment first, before we change container - -- state, in order to defend against exceptions duration assignment. - - N (New_Node).Element := New_Item; - Container.Free := N (New_Node).Next; - - else - -- A negative free store value means that the links of the nodes in - -- the free store have not been initialized. In this case, the nodes - -- are physically contiguous in the array, starting at the index that - -- is the absolute value of the Container.Free, and continuing until - -- the end of the array (Nodes'Last). - - New_Node := abs Container.Free; - - -- As above, we perform this assignment first, before modifying any - -- container state. - - N (New_Node).Element := New_Item; - Container.Free := Container.Free - 1; - end if; - end Allocate; - - procedure Allocate - (Container : in out List; - Stream : not null access Root_Stream_Type'Class; - New_Node : out Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Free >= 0 then - New_Node := Container.Free; - - -- We always perform the assignment first, before we change container - -- state, in order to defend against exceptions duration assignment. - - Element_Type'Read (Stream, N (New_Node).Element); - Container.Free := N (New_Node).Next; - - else - -- A negative free store value means that the links of the nodes in - -- the free store have not been initialized. In this case, the nodes - -- are physically contiguous in the array, starting at the index that - -- is the absolute value of the Container.Free, and continuing until - -- the end of the array (Nodes'Last). - - New_Node := abs Container.Free; - - -- As above, we perform this assignment first, before modifying any - -- container state. - - Element_Type'Read (Stream, N (New_Node).Element); - Container.Free := Container.Free - 1; - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, No_Element, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out List; Source : List) is - SN : Node_Array renames Source.Nodes; - J : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error -- ??? - with "Target capacity is less than Source length"; - end if; - - Target.Clear; - - J := Source.First; - while J /= 0 loop - Target.Append (SN (J).Element); - J := SN (J).Next; - end loop; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Container.Length = 0 then - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - pragma Assert (Container.TC = (Busy => 0, Lock => 0)); - return; - end if; - - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - TC_Check (Container.TC); - - while Container.Length > 1 loop - X := Container.First; - pragma Assert (N (N (X).Next).Prev = Container.First); - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - - X := Container.First; - pragma Assert (X = Container.Last); - - Container.First := 0; - Container.Last := 0; - Container.Length := 0; - - Free (Container, X); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : List; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : List; Capacity : Count_Type := 0) return List is - C : Count_Type; - - begin - if Capacity < Source.Length then - if Checks and then Capacity /= 0 then - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - C := Source.Length; - else - C := Capacity; - end if; - - return Target : List (Capacity => C) do - Assign (Target => Target, Source => Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Delete"); - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; - return; - end if; - - if Count = 0 then - Position := No_Element; - return; - end if; - - TC_Check (Container.TC); - - for Index in 1 .. Count loop - pragma Assert (Container.Length >= 2); - - X := Position.Node; - Container.Length := Container.Length - 1; - - if X = Container.Last then - Position := No_Element; - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Free (Container, X); - return; - end if; - - Position.Node := N (X).Next; - - N (N (X).Next).Prev := N (X).Prev; - N (N (X).Prev).Next := N (X).Next; - - Free (Container, X); - end loop; - - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - for J in 1 .. Count loop - X := Container.First; - pragma Assert (N (N (X).Next).Prev = Container.First); - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (N (N (X).Prev).Next = Container.Last); - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Element"); - - return Position.Container.Nodes (Position.Node).Element; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := Position.Node; - - begin - if Node = 0 then - Node := Container.First; - - else - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Find"); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - while Node /= 0 loop - if Nodes (Node).Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := Nodes (Node).Next; - end loop; - - return No_Element; - end; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : List) return Cursor is - begin - if Container.First = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.First); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is 0, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is positive, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = 0 then - return Bounded_Doubly_Linked_Lists.First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : List) return Element_Type is - begin - if Checks and then Container.First = 0 then - raise Constraint_Error with "list is empty"; - end if; - - return Container.Nodes (Container.First).Element; - end First_Element; - - ---------- - -- Free -- - ---------- - - procedure Free - (Container : in out List; - X : Count_Type) - is - pragma Assert (X > 0); - pragma Assert (X <= Container.Capacity); - - N : Node_Array renames Container.Nodes; - pragma Assert (N (X).Prev >= 0); -- node is active - - begin - -- The list container actually contains two lists: one for the "active" - -- nodes that contain elements that have been inserted onto the list, - -- and another for the "inactive" nodes for the free store. - - -- We desire that merely declaring an object should have only minimal - -- cost; specially, we want to avoid having to initialize the free - -- store (to fill in the links), especially if the capacity is large. - - -- The head of the free list is indicated by Container.Free. If its - -- value is non-negative, then the free store has been initialized in - -- the "normal" way: Container.Free points to the head of the list of - -- free (inactive) nodes, and the value 0 means the free list is empty. - -- Each node on the free list has been initialized to point to the next - -- free node (via its Next component), and the value 0 means that this - -- is the last free node. - - -- If Container.Free is negative, then the links on the free store have - -- not been initialized. In this case the link values are implied: the - -- free store comprises the components of the node array started with - -- the absolute value of Container.Free, and continuing until the end of - -- the array (Nodes'Last). - - -- If the list container is manipulated on one end only (for example if - -- the container were being used as a stack), then there is no need to - -- initialize the free store, since the inactive nodes are physically - -- contiguous (in fact, they lie immediately beyond the logical end - -- being manipulated). The only time we need to actually initialize the - -- nodes in the free store is if the node that becomes inactive is not - -- at the end of the list. The free store would then be discontiguous - -- and so its nodes would need to be linked in the traditional way. - - -- ??? - -- It might be possible to perform an optimization here. Suppose that - -- the free store can be represented as having two parts: one comprising - -- the non-contiguous inactive nodes linked together in the normal way, - -- and the other comprising the contiguous inactive nodes (that are not - -- linked together, at the end of the nodes array). This would allow us - -- to never have to initialize the free store, except in a lazy way as - -- nodes become inactive. - - -- When an element is deleted from the list container, its node becomes - -- inactive, and so we set its Prev component to a negative value, to - -- indicate that it is now inactive. This provides a useful way to - -- detect a dangling cursor reference (and which is used in Vet). - - N (X).Prev := -1; -- Node is deallocated (not on active list) - - if Container.Free >= 0 then - - -- The free store has previously been initialized. All we need to - -- do here is link the newly-free'd node onto the free list. - - N (X).Next := Container.Free; - Container.Free := X; - - elsif X + 1 = abs Container.Free then - - -- The free store has not been initialized, and the node becoming - -- inactive immediately precedes the start of the free store. All - -- we need to do is move the start of the free store back by one. - - -- Note: initializing Next to zero is not strictly necessary but - -- seems cleaner and marginally safer. - - N (X).Next := 0; - Container.Free := Container.Free + 1; - - else - -- The free store has not been initialized, and the node becoming - -- inactive does not immediately precede the free store. Here we - -- first initialize the free store (meaning the links are given - -- values in the traditional way), and then link the newly-free'd - -- node onto the head of the free store. - - -- ??? - -- See the comments above for an optimization opportunity. If the - -- next link for a node on the free store is negative, then this - -- means the remaining nodes on the free store are physically - -- contiguous, starting as the absolute value of that index value. - - Container.Free := abs Container.Free; - - if Container.Free > Container.Capacity then - Container.Free := 0; - - else - for I in Container.Free .. Container.Capacity - 1 loop - N (I).Next := I + 1; - end loop; - - N (Container.Capacity).Next := 0; - end if; - - N (X).Next := Container.Free; - Container.Free := X; - end if; - end Free; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : List) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type; - begin - Node := Container.First; - for J in 2 .. Container.Length loop - if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then - return False; - end if; - - Node := Nodes (Node).Next; - end loop; - - return True; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge - (Target : in out List; - Source : in out List) - is - begin - -- The semantics of Merge changed slightly per AI05-0021. It was - -- originally the case that if Target and Source denoted the same - -- container object, then the GNAT implementation of Merge did - -- nothing. However, it was argued that RM05 did not precisely - -- specify the semantics for this corner case. The decision of the - -- ARG was that if Target and Source denote the same non-empty - -- container object, then Program_Error is raised. - - if Source.Is_Empty then - return; - end if; - - if Checks and then Target'Address = Source'Address then - raise Program_Error with - "Target and Source denote same non-empty container"; - end if; - - if Checks and then Target.Length > Count_Type'Last - Source.Length - then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - if Checks and then Target.Length + Source.Length > Target.Capacity - then - raise Capacity_Error with "new length exceeds target capacity"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unchecked_Access); - Lock_Source : With_Lock (Source.TC'Unchecked_Access); - - LN : Node_Array renames Target.Nodes; - RN : Node_Array renames Source.Nodes; - - LI, LJ, RI, RJ : Count_Type; - - begin - LI := Target.First; - RI := Source.First; - while RI /= 0 loop - pragma Assert (RN (RI).Next = 0 - or else not (RN (RN (RI).Next).Element < - RN (RI).Element)); - - if LI = 0 then - Splice_Internal (Target, 0, Source); - exit; - end if; - - pragma Assert (LN (LI).Next = 0 - or else not (LN (LN (LI).Next).Element < - LN (LI).Element)); - - if RN (RI).Element < LN (LI).Element then - RJ := RI; - RI := RN (RI).Next; - Splice_Internal (Target, LI, Source, RJ, LJ); - - else - LI := LN (LI).Next; - end if; - end loop; - end; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out List) is - N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot, Back : Count_Type); - -- What does this do ??? - - procedure Sort (Front, Back : Count_Type); - -- Internal procedure, what does it do??? rename it??? - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot, Back : Count_Type) is - Node : Count_Type; - - begin - Node := N (Pivot).Next; - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Count_Type) is - Pivot : constant Count_Type := - (if Front = 0 then Container.First else N (Front).Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - TC_Check (Container.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Sort (Front => 0, Back => 0); - end; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Sort; - - end Generic_Sorting; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Nodes (Position.Node).Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= 0; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - First_Node : Count_Type; - New_Node : Count_Type; - - begin - if Before.Container /= null then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Before cursor designates wrong list"; - end if; - - pragma Assert (Vet (Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - - if Checks and then Container.Length > Container.Capacity - Count then - raise Capacity_Error with "capacity exceeded"; - end if; - - TC_Check (Container.TC); - - Allocate (Container, New_Item, New_Node); - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); - - for Index in Count_Type'(2) .. Count loop - Allocate (Container, New_Item, New_Node); - Insert_Internal (Container, Before.Node, New_Node); - end loop; - - Position := Cursor'(Container'Unchecked_Access, First_Node); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Position : Cursor; - pragma Unreferenced (Position); - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - pragma Warnings (Off); - New_Item : Element_Type; - -- OK to reference, see below. Note that we need to suppress both the - -- front end warning and the back end warning. - - begin - -- There is no explicit element provided, but in an instance the element - -- type may be a scalar with a Default_Value aspect, or a composite - -- type with such a scalar component, or components with default - -- initialization, so insert the specified number of possibly - -- initialized elements at the given position. - - Insert (Container, Before, New_Item, Position, Count); - pragma Warnings (On); - end Insert; - - --------------------- - -- Insert_Internal -- - --------------------- - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Length = 0 then - pragma Assert (Before = 0); - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - - Container.First := New_Node; - N (Container.First).Prev := 0; - - Container.Last := New_Node; - N (Container.Last).Next := 0; - - -- Before = zero means append - - elsif Before = 0 then - pragma Assert (N (Container.Last).Next = 0); - - N (Container.Last).Next := New_Node; - N (New_Node).Prev := Container.Last; - - Container.Last := New_Node; - N (Container.Last).Next := 0; - - -- Before = Container.First means prepend - - elsif Before = Container.First then - pragma Assert (N (Container.First).Prev = 0); - - N (Container.First).Prev := New_Node; - N (New_Node).Next := Container.First; - - Container.First := New_Node; - N (Container.First).Prev := 0; - - else - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - N (New_Node).Next := Before; - N (New_Node).Prev := N (Before).Prev; - - N (N (Before).Prev).Next := New_Node; - N (Before).Prev := New_Node; - end if; - - Container.Length := Container.Length + 1; - end Insert_Internal; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : List) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - Node : Count_Type := Container.First; - - begin - while Node /= 0 loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Container.Nodes (Node).Next; - end loop; - end Iterate; - - function Iterate - (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is 0 (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a - -- complete iterator, meaning that the iteration starts from the - -- (logical) beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => 0) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : List; - Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong list"; - end if; - - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is positive (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : List) return Cursor is - begin - if Container.Last = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.Last); - end if; - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is 0, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is positive, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = 0 then - return Bounded_Doubly_Linked_Lists.Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : List) return Element_Type is - begin - if Checks and then Container.Last = 0 then - raise Constraint_Error with "list is empty"; - end if; - - return Container.Nodes (Container.Last).Element; - end Last_Element; - - ------------ - -- Length -- - ------------ - - function Length (Container : List) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out List; - Source : in out List) - is - N : Node_Array renames Source.Nodes; - X : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error with "Source length exceeds Target capacity"; - end if; - - TC_Check (Source.TC); - - -- Clear target, note that this checks busy bits of Target - - Clear (Target); - - while Source.Length > 1 loop - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last /= Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy first element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); - - -- Unlink first node of Source - - Source.First := N (X).Next; - N (Source.First).Prev := 0; - - Source.Length := Source.Length - 1; - - -- The representation invariants for Source have been restored. It is - -- now safe to free the unlinked node, without fear of corrupting the - -- active links of Source. - - -- Note that the algorithm we use here models similar algorithms used - -- in the unbounded form of the doubly-linked list container. In that - -- case, Free is an instantation of Unchecked_Deallocation, which can - -- fail (because PE will be raised if controlled Finalize fails), so - -- we must defer the call until the last step. Here in the bounded - -- form, Free merely links the node we have just "deallocated" onto a - -- list of inactive nodes, so technically Free cannot fail. However, - -- for consistency, we handle Free the same way here as we do for the - -- unbounded form, with the pessimistic assumption that it can fail. - - Free (Source, X); - end loop; - - if Source.Length = 1 then - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last = Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); - - -- Unlink node of Source - - Source.First := 0; - Source.Last := 0; - Source.Length := 0; - - -- Return the unlinked node to the free store - - Free (Source, X); - end if; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - Nodes : Node_Array renames Position.Container.Nodes; - Node : constant Count_Type := Nodes (Position.Node).Next; - begin - if Node = 0 then - return No_Element; - else - return Cursor'(Position.Container, Node); - end if; - end; - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong list"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, First (Container), New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Previous"); - - declare - Nodes : Node_Array renames Position.Container.Nodes; - Node : constant Count_Type := Nodes (Position.Node).Prev; - begin - if Node = 0 then - return No_Element; - else - return Cursor'(Position.Container, Node); - end if; - end; - end Previous; - - function Previous - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong list"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased List'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - Lock : With_Lock (Position.Container.TC'Unrestricted_Access); - C : List renames Position.Container.all'Unrestricted_Access.all; - N : Node_Type renames C.Nodes (Position.Node); - begin - Process (N.Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List) - is - N : Count_Type'Base; - X : Count_Type; - - begin - Clear (Item); - Count_Type'Base'Read (Stream, N); - - if Checks and then N < 0 then - raise Program_Error with "bad list length (corrupt stream)"; - end if; - - if N = 0 then - return; - end if; - - if Checks and then N > Item.Capacity then - raise Constraint_Error with "length exceeds capacity"; - end if; - - for Idx in 1 .. N loop - Allocate (Item, Stream, New_Node => X); - Insert_Internal (Item, Before => 0, New_Node => X); - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out List; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Reference"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unchecked_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - TE_Check (Container.TC); - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - N : Node_Array renames Container.Nodes; - I : Count_Type := Container.First; - J : Count_Type := Container.Last; - - procedure Swap (L, R : Count_Type); - - ---------- - -- Swap -- - ---------- - - procedure Swap (L, R : Count_Type) is - LN : constant Count_Type := N (L).Next; - LP : constant Count_Type := N (L).Prev; - - RN : constant Count_Type := N (R).Next; - RP : constant Count_Type := N (R).Prev; - - begin - if LP /= 0 then - N (LP).Next := R; - end if; - - if RN /= 0 then - N (RN).Prev := L; - end if; - - N (L).Next := RN; - N (R).Prev := LP; - - if LN = R then - pragma Assert (RP = L); - - N (L).Prev := R; - N (R).Next := L; - - else - N (L).Prev := RP; - N (RP).Next := L; - - N (R).Next := LN; - N (LN).Prev := R; - end if; - end Swap; - - -- Start of processing for Reverse_Elements - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - TC_Check (Container.TC); - - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); - - J := N (J).Next; - exit when I = J; - - I := N (I).Prev; - exit when I = J; - - Swap (L => J, R => I); - - I := N (I).Next; - exit when I = J; - - J := N (J).Prev; - exit when I = J; - end loop; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Node : Count_Type := Position.Node; - - begin - if Node = 0 then - Node := Container.Last; - - else - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - while Node /= 0 loop - if Container.Nodes (Node).Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := Container.Nodes (Node).Prev; - end loop; - - return No_Element; - end; - end Reverse_Find; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - Node : Count_Type := Container.Last; - - begin - while Node /= 0 loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Container.Nodes (Node).Prev; - end loop; - end Reverse_Iterate; - - ------------ - -- Splice -- - ------------ - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - is - begin - if Before.Container /= null then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - pragma Assert (Vet (Before), "bad cursor in Splice"); - end if; - - if Target'Address = Source'Address or else Source.Length = 0 then - return; - end if; - - if Checks and then Target.Length > Count_Type'Last - Source.Length then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - if Checks and then Target.Length + Source.Length > Target.Capacity then - raise Capacity_Error with "new length exceeds target capacity"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - Splice_Internal (Target, Before.Node, Source); - end Splice; - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - is - N : Node_Array renames Container.Nodes; - - begin - if Before.Container /= null then - if Checks and then Before.Container /= Container'Unchecked_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - end if; - - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Position.Node = Before.Node - or else N (Position.Node).Next = Before.Node - then - return; - end if; - - pragma Assert (Container.Length >= 2); - - TC_Check (Container.TC); - - if Before.Node = 0 then - pragma Assert (Position.Node /= Container.Last); - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.Last).Next := Position.Node; - N (Position.Node).Prev := Container.Last; - - Container.Last := Position.Node; - N (Container.Last).Next := 0; - - return; - end if; - - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.First).Prev := Position.Node; - N (Position.Node).Next := Container.First; - - Container.First := Position.Node; - N (Container.First).Prev := 0; - - return; - end if; - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - elsif Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (N (Before.Node).Prev).Next := Position.Node; - N (Position.Node).Prev := N (Before.Node).Prev; - - N (Before.Node).Prev := Position.Node; - N (Position.Node).Next := Before.Node; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Splice; - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - is - Target_Position : Count_Type; - - begin - if Target'Address = Source'Address then - Splice (Target, Before, Position); - return; - end if; - - if Before.Container /= null then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - end if; - - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Source'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Checks and then Target.Length >= Target.Capacity then - raise Capacity_Error with "Target is full"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - Splice_Internal - (Target => Target, - Before => Before.Node, - Source => Source, - Src_Pos => Position.Node, - Tgt_Pos => Target_Position); - - Position := Cursor'(Target'Unrestricted_Access, Target_Position); - end Splice; - - --------------------- - -- Splice_Internal -- - --------------------- - - procedure Splice_Internal - (Target : in out List; - Before : Count_Type; - Source : in out List) - is - N : Node_Array renames Source.Nodes; - X : Count_Type; - - begin - -- This implements the corresponding Splice operation, after the - -- parameters have been vetted, and corner-cases disposed of. - - pragma Assert (Target'Address /= Source'Address); - pragma Assert (Source.Length > 0); - pragma Assert (Source.First /= 0); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (Source.Last /= 0); - pragma Assert (N (Source.Last).Next = 0); - pragma Assert (Target.Length <= Count_Type'Last - Source.Length); - pragma Assert (Target.Length + Source.Length <= Target.Capacity); - - while Source.Length > 1 loop - -- Copy first element of Source onto Target - - Allocate (Target, N (Source.First).Element, New_Node => X); - Insert_Internal (Target, Before => Before, New_Node => X); - - -- Unlink the first node from Source - - X := Source.First; - pragma Assert (N (N (X).Next).Prev = X); - - Source.First := N (X).Next; - N (Source.First).Prev := 0; - - Source.Length := Source.Length - 1; - - -- Return the Source node to its free store - - Free (Source, X); - end loop; - - -- Copy first (and only remaining) element of Source onto Target - - Allocate (Target, N (Source.First).Element, New_Node => X); - Insert_Internal (Target, Before => Before, New_Node => X); - - -- Unlink the node from Source - - X := Source.First; - pragma Assert (X = Source.Last); - - Source.First := 0; - Source.Last := 0; - - Source.Length := 0; - - -- Return the Source node to its free store - - Free (Source, X); - end Splice_Internal; - - procedure Splice_Internal - (Target : in out List; - Before : Count_Type; -- node of Target - Source : in out List; - Src_Pos : Count_Type; -- node of Source - Tgt_Pos : out Count_Type) - is - N : Node_Array renames Source.Nodes; - - begin - -- This implements the corresponding Splice operation, after the - -- parameters have been vetted, and corner-cases handled. - - pragma Assert (Target'Address /= Source'Address); - pragma Assert (Target.Length < Target.Capacity); - pragma Assert (Source.Length > 0); - pragma Assert (Source.First /= 0); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (Source.Last /= 0); - pragma Assert (N (Source.Last).Next = 0); - pragma Assert (Src_Pos /= 0); - - Allocate (Target, N (Src_Pos).Element, New_Node => Tgt_Pos); - Insert_Internal (Target, Before => Before, New_Node => Tgt_Pos); - - if Source.Length = 1 then - pragma Assert (Source.First = Source.Last); - pragma Assert (Src_Pos = Source.First); - - Source.First := 0; - Source.Last := 0; - - elsif Src_Pos = Source.First then - pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); - - Source.First := N (Src_Pos).Next; - N (Source.First).Prev := 0; - - elsif Src_Pos = Source.Last then - pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); - - Source.Last := N (Src_Pos).Prev; - N (Source.Last).Next := 0; - - else - pragma Assert (Source.Length >= 3); - pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); - pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); - - N (N (Src_Pos).Next).Prev := N (Src_Pos).Prev; - N (N (Src_Pos).Prev).Next := N (Src_Pos).Next; - end if; - - Source.Length := Source.Length - 1; - Free (Source, Src_Pos); - end Splice_Internal; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out List; - I, J : Cursor) - is - begin - if Checks and then I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unchecked_Access then - raise Program_Error with "I cursor designates wrong container"; - end if; - - if Checks and then J.Container /= Container'Unchecked_Access then - raise Program_Error with "J cursor designates wrong container"; - end if; - - if I.Node = J.Node then - return; - end if; - - TE_Check (Container.TC); - - pragma Assert (Vet (I), "bad I cursor in Swap"); - pragma Assert (Vet (J), "bad J cursor in Swap"); - - declare - EI : Element_Type renames Container.Nodes (I.Node).Element; - EJ : Element_Type renames Container.Nodes (J.Node).Element; - - EI_Copy : constant Element_Type := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - ---------------- - -- Swap_Links -- - ---------------- - - procedure Swap_Links - (Container : in out List; - I, J : Cursor) - is - begin - if Checks and then I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor designates wrong container"; - end if; - - if Checks and then J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor designates wrong container"; - end if; - - if I.Node = J.Node then - return; - end if; - - TC_Check (Container.TC); - - pragma Assert (Vet (I), "bad I cursor in Swap_Links"); - pragma Assert (Vet (J), "bad J cursor in Swap_Links"); - - declare - I_Next : constant Cursor := Next (I); - - begin - if I_Next = J then - Splice (Container, Before => I, Position => J); - - else - declare - J_Next : constant Cursor := Next (J); - - begin - if J_Next = I then - Splice (Container, Before => J, Position => I); - - else - pragma Assert (Container.Length >= 3); - - Splice (Container, Before => I_Next, Position => J); - Splice (Container, Before => J_Next, Position => I); - end if; - end; - end if; - end; - end Swap_Links; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unchecked_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - N : Node_Type renames Container.Nodes (Position.Node); - begin - Process (N.Element); - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - declare - L : List renames Position.Container.all; - N : Node_Array renames L.Nodes; - - begin - if L.Length = 0 then - return False; - end if; - - if L.First = 0 or L.First > L.Capacity then - return False; - end if; - - if L.Last = 0 or L.Last > L.Capacity then - return False; - end if; - - if N (L.First).Prev /= 0 then - return False; - end if; - - if N (L.Last).Next /= 0 then - return False; - end if; - - if Position.Node > L.Capacity then - return False; - end if; - - -- An invariant of an active node is that its Previous and Next - -- components are non-negative. Operation Free sets the Previous - -- component of the node to the value -1 before actually deallocating - -- the node, to mark the node as inactive. (By "dellocating" we mean - -- only that the node is linked onto a list of inactive nodes used - -- for storage.) This marker gives us a simple way to detect a - -- dangling reference to a node. - - if N (Position.Node).Prev < 0 then -- see Free - return False; - end if; - - if N (Position.Node).Prev > L.Capacity then - return False; - end if; - - if N (Position.Node).Next = Position.Node then - return False; - end if; - - if N (Position.Node).Prev = Position.Node then - return False; - end if; - - if N (Position.Node).Prev = 0 - and then Position.Node /= L.First - then - return False; - end if; - - pragma Assert (N (Position.Node).Prev /= 0 - or else Position.Node = L.First); - - if N (Position.Node).Next = 0 - and then Position.Node /= L.Last - then - return False; - end if; - - pragma Assert (N (Position.Node).Next /= 0 - or else Position.Node = L.Last); - - if L.Length = 1 then - return L.First = L.Last; - end if; - - if L.First = L.Last then - return False; - end if; - - if N (L.First).Next = 0 then - return False; - end if; - - if N (L.Last).Prev = 0 then - return False; - end if; - - if N (N (L.First).Next).Prev /= L.First then - return False; - end if; - - if N (N (L.Last).Prev).Next /= L.Last then - return False; - end if; - - if L.Length = 2 then - if N (L.First).Next /= L.Last then - return False; - end if; - - if N (L.Last).Prev /= L.First then - return False; - end if; - - return True; - end if; - - if N (L.First).Next = L.Last then - return False; - end if; - - if N (L.Last).Prev = L.First then - return False; - end if; - - -- Eliminate earlier possibility - - if Position.Node = L.First then - return True; - end if; - - pragma Assert (N (Position.Node).Prev /= 0); - - -- Eliminate another possibility - - if Position.Node = L.Last then - return True; - end if; - - pragma Assert (N (Position.Node).Next /= 0); - - if N (N (Position.Node).Next).Prev /= Position.Node then - return False; - end if; - - if N (N (Position.Node).Prev).Next /= Position.Node then - return False; - end if; - - if L.Length = 3 then - if N (L.First).Next /= Position.Node then - return False; - end if; - - if N (L.Last).Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List) - is - Node : Count_Type; - - begin - Count_Type'Base'Write (Stream, Item.Length); - - Node := Item.First; - while Node /= 0 loop - Element_Type'Write (Stream, Item.Nodes (Node).Element); - Node := Item.Nodes (Node).Next; - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cbdlli.ads b/gcc/ada/a-cbdlli.ads deleted file mode 100644 index 8489153..0000000 --- a/gcc/ada/a-cbdlli.ads +++ /dev/null @@ -1,398 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Streams; -private with Ada.Finalization; - -generic - type Element_Type is private; - - with function "=" (Left, Right : Element_Type) - return Boolean is <>; - -package Ada.Containers.Bounded_Doubly_Linked_Lists is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - pragma Remote_Types; - - type List (Capacity : Count_Type) is tagged private with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (List); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_List : constant List; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package List_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : List) return Boolean; - - function Length (Container : List) return Count_Type; - - function Is_Empty (Container : List) return Boolean; - - procedure Clear (Container : in out List); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased in out List; - Position : Cursor) return Reference_Type; - - procedure Assign (Target : in out List; Source : List); - - function Copy (Source : List; Capacity : Count_Type := 0) return List; - - procedure Move - (Target : in out List; - Source : in out List); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Insert - (Container : in out List; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1); - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1); - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1); - - procedure Reverse_Elements (Container : in out List); - - function Iterate - (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : List; - Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'class; - - procedure Swap - (Container : in out List; - I, J : Cursor); - - procedure Swap_Links - (Container : in out List; - I, J : Cursor); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor); - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor); - - function First (Container : List) return Cursor; - - function First_Element (Container : List) return Element_Type; - - function Last (Container : List) return Cursor; - - function Last_Element (Container : List) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Contains - (Container : List; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : List) return Boolean; - - procedure Sort (Container : in out List); - - procedure Merge (Target, Source : in out List); - - end Generic_Sorting; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - use Ada.Streams; - use Ada.Finalization; - - type Node_Type is record - Prev : Count_Type'Base; - Next : Count_Type; - Element : aliased Element_Type; - end record; - - type Node_Array is array (Count_Type range <>) of Node_Type; - - type List (Capacity : Count_Type) is tagged record - Nodes : Node_Array (1 .. Capacity) := (others => <>); - Free : Count_Type'Base := -1; - First : Count_Type := 0; - Last : Count_Type := 0; - Length : Count_Type := 0; - TC : aliased Tamper_Counts; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List); - - for List'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List); - - for List'Write use Write; - - type List_Access is access all List; - for List_Access'Storage_Size use 0; - - type Cursor is record - Container : List_Access; - Node : Count_Type := 0; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased List'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_List : constant List := (Capacity => 0, others => <>); - - No_Element : constant Cursor := Cursor'(null, 0); - - type Iterator is new Limited_Controlled and - List_Iterator_Interfaces.Reversible_Iterator with - record - Container : List_Access; - Node : Count_Type; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cbhama.adb b/gcc/ada/a-cbhama.adb deleted file mode 100644 index 02c1901..0000000 --- a/gcc/ada/a-cbhama.adb +++ /dev/null @@ -1,1252 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); - -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; - -with System; use type System.Address; - -package body Ada.Containers.Bounded_Hashed_Maps is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Key_Node); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Hash_Tables.Generic_Bounded_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Key_Ops is new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - function Find_Equal_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean; - - function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key); - R_Node : Count_Type := R_HT.Buckets (R_Index); - - begin - while R_Node /= 0 loop - if Equivalent_Keys (L_Node.Key, R_HT.Nodes (R_Node).Key) then - return L_Node.Element = R_HT.Nodes (R_Node).Element; - end if; - - R_Node := R_HT.Nodes (R_Node).Next; - end loop; - - return False; - end Find_Equal_Key; - - -- Start of processing for "=" - - begin - return Is_Equal (Left, Right); - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Element (Source_Node : Count_Type); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Source_Node); - C : Cursor; - B : Boolean; - - begin - Insert (Target, N.Key, N.Element, C, B); - pragma Assert (B); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error - with "Target capacity is less than Source length"; - end if; - - HT_Ops.Clear (Target); - Insert_Elements (Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Map) return Count_Type is - begin - return Container.Capacity; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - HT_Ops.Clear (Container); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert (Vet (Position), - "Position cursor in Constant_Reference is bad"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Count_Type := - Key_Ops.Find (Container'Unrestricted_Access.all, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Map; - Capacity : Count_Type := 0; - Modulus : Hash_Type := 0) return Map - is - C : Count_Type; - M : Hash_Type; - - begin - if Capacity = 0 then - C := Source.Length; - - elsif Capacity >= Source.Length then - C := Capacity; - - elsif Checks then - raise Capacity_Error with "Capacity value too small"; - end if; - - if Modulus = 0 then - M := Default_Modulus (C); - else - M := Modulus; - end if; - - return Target : Map (Capacity => C, Modulus => M) do - Assign (Target => Target, Source => Source); - end return; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Count_Type; - - begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); - - if Checks and then X = 0 then - raise Constraint_Error with "attempt to delete key not in map"; - end if; - - HT_Ops.Free (Container, X); - end Delete; - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Delete equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Delete designates wrong map"; - end if; - - TC_Check (Container.TC); - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - HT_Ops.Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Count_Type := - Key_Ops.Find (Container'Unrestricted_Access.all, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Nodes (Node).Element; - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of function Element equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - return Position.Container.Nodes (Position.Node).Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean is - begin - return Equivalent_Keys (Key, Node.Key); - end Equivalent_Key_Node; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Cursor) - return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - if Checks and then Right.Node = 0 then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad"); - pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - RN : Node_Type renames Right.Container.Nodes (Right.Node); - - begin - return Equivalent_Keys (LN.Key, RN.Key); - end; - end Equivalent_Keys; - - function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - - begin - return Equivalent_Keys (LN.Key, Right); - end; - end Equivalent_Keys; - - function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = 0 then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); - - declare - RN : Node_Type renames Right.Container.Nodes (Right.Node); - - begin - return Equivalent_Keys (Left, RN.Key); - end; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Count_Type; - begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); - HT_Ops.Free (Container, X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := - Key_Ops.Find (Container'Unrestricted_Access.all, Key); - begin - if Node = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); - end if; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container); - begin - if Node = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - return Object.Container.First; - end First; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Nodes (Position.Node).Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= 0; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Key); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.TC); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new HT_Ops.Generic_Allocate (Assign_Key); - - ----------------- - -- Assign_Key -- - ----------------- - - procedure Assign_Key (Node : in out Node_Type) is - New_Item : Element_Type; - pragma Unmodified (New_Item); - -- Default-initialized element (ok to reference, see below) - - begin - Node.Key := Key; - - -- There is no explicit element provided, but in an instance the - -- element type may be a scalar with a Default_Value aspect, or a - -- composite type with such a scalar component, or components with - -- default initialization, so insert a possibly initialized element - -- under the given key. - - Node.Element := New_Item; - end Assign_Key; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - -- The buckets array length is specified by the user as a discriminant - -- of the container type, so it is possible for the buckets array to - -- have a length of zero. We must check for this case specifically, in - -- order to prevent divide-by-zero errors later, when we compute the - -- buckets array index value for a key, given its hash value. - - if Checks and then Container.Buckets'Length = 0 then - raise Capacity_Error with "No capacity for insertion"; - end if; - - Local_Insert (Container, Key, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new HT_Ops.Generic_Allocate (Assign_Key); - - ----------------- - -- Assign_Key -- - ----------------- - - procedure Assign_Key (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Assign_Key; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - -- The buckets array length is specified by the user as a discriminant - -- of the container type, so it is possible for the buckets array to - -- have a length of zero. We must check for this case specifically, in - -- order to prevent divide-by-zero errors later, when we compute the - -- buckets array index value for a key, given its hash value. - - if Checks and then Container.Buckets'Length = 0 then - raise Capacity_Error with "No capacity for insertion"; - end if; - - Local_Insert (Container, Key, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (Container); - end Iterate; - - function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class - is - begin - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of function Key equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - - return Position.Container.Nodes (Position.Node).Key; - end Key; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Map; - Source : in out Map) - is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Assign (Source); - Source.Clear; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Next"); - - declare - M : Map renames Position.Container.all; - Node : constant Count_Type := HT_Ops.Next (M, Position.Node); - begin - if Node = 0 then - return No_Element; - else - return Cursor'(Position.Container, Node); - end if; - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong map"; - end if; - - return Next (Position); - end Next; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - M : Map renames Position.Container.all; - N : Node_Type renames M.Nodes (Position.Node); - Lock : With_Lock (M.TC'Unrestricted_Access); - begin - Process (N.Key, N.Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Count_Type; - -- pragma Inline (Read_Node); ??? - - procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Count_Type - is - procedure Read_Element (Node : in out Node_Type); - -- pragma Inline (Read_Element); ??? - - procedure Allocate is - new HT_Ops.Generic_Allocate (Read_Element); - - procedure Read_Element (Node : in out Node_Type) is - begin - Key_Type'Read (Stream, Node.Key); - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - Node : Count_Type; - - -- Start of processing for Read_Node - - begin - Allocate (Container, Node); - return Node; - end Read_Node; - - -- Start of processing for Read - - begin - Read_Nodes (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert (Vet (Position), - "Position cursor in function Reference is bad"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type - is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with - "attempt to replace key not in map"; - end if; - - TE_Check (Container.TC); - - declare - N : Node_Type renames Container.Nodes (Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Replace_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Replace_Element designates wrong map"; - end if; - - TE_Check (Position.Container.TC); - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - is - begin - if Checks and then Capacity > Container.Capacity then - raise Capacity_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Update_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Update_Element designates wrong map"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - Process (N.Key, N.Element); - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - declare - M : Map renames Position.Container.all; - X : Count_Type; - - begin - if M.Length = 0 then - return False; - end if; - - if M.Capacity = 0 then - return False; - end if; - - if M.Buckets'Length = 0 then - return False; - end if; - - if Position.Node > M.Capacity then - return False; - end if; - - if M.Nodes (Position.Node).Next = Position.Node then - return False; - end if; - - X := M.Buckets (Key_Ops.Checked_Index - (M, M.Nodes (Position.Node).Key)); - - for J in 1 .. M.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = M.Nodes (X).Next then -- to prevent unnecessary looping - return False; - end if; - - X := M.Nodes (X).Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Bounded_Hashed_Maps; diff --git a/gcc/ada/a-cbhama.ads b/gcc/ada/a-cbhama.ads deleted file mode 100644 index 0bab22e..0000000 --- a/gcc/ada/a-cbhama.ads +++ /dev/null @@ -1,468 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Hash_Tables; -private with Ada.Streams; -private with Ada.Finalization; - -generic - type Key_Type is private; - type Element_Type is private; - - with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Bounded_Hashed_Maps is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - pragma Remote_Types; - - type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Map); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Map : constant Map; - -- Map objects declared without an initialization expression are - -- initialized to the value Empty_Map. - - No_Element : constant Cursor; - -- Cursor objects declared without an initialization expression are - -- initialized to the value No_Element. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Map_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Map) return Boolean; - -- For each key/element pair in Left, equality attempts to find the key in - -- Right; if a search fails the equality returns False. The search works by - -- calling Hash to find the bucket in the Right map that corresponds to the - -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys - -- to compare the key (in Left) to the key of each node in the bucket (in - -- Right); if the keys are equivalent, then the equality test for this - -- key/element pair (in Left) completes by calling the element equality - -- operator to compare the element (in Left) to the element of the node - -- (in Right) whose key matched. - - function Capacity (Container : Map) return Count_Type; - -- Returns the current capacity of the map. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); - -- If the value of the Capacity actual parameter is less or equal to - -- Container.Capacity, then the operation has no effect. Otherwise it - -- raises Capacity_Error (as no expansion of capacity is possible for a - -- bounded form). - - function Default_Modulus (Capacity : Count_Type) return Hash_Type; - -- Returns a modulus value (hash table size) which is optimal for the - -- specified capacity (which corresponds to the maximum number of items). - - function Length (Container : Map) return Count_Type; - -- Returns the number of items in the map - - function Is_Empty (Container : Map) return Boolean; - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Map); - -- Removes all of the items from the map - - function Key (Position : Cursor) return Key_Type; - -- Returns the key of the node designated by the cursor - - function Element (Position : Cursor) return Element_Type; - -- Returns the element of the node designated by the cursor - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type); - -- Assigns the value New_Item to the element designated by the cursor - - procedure Query_Element - (Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - -- Calls Process with the key and element (both having only a constant - -- view) of the node designed by the cursor. - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - -- Calls Process with the key (with only a constant view) and element (with - -- a variable view) of the node designed by the cursor. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type; - - procedure Assign (Target : in out Map; Source : Map); - -- If Target denotes the same object as Source, then the operation has no - -- effect. If the Target capacity is less than the Source length, then - -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then - -- copies the (active) elements from Source to Target. - - function Copy - (Source : Map; - Capacity : Count_Type := 0; - Modulus : Hash_Type := 0) return Map; - -- Constructs a new set object whose elements correspond to Source. If the - -- Capacity parameter is 0, then the capacity of the result is the same as - -- the length of Source. If the Capacity parameter is equal or greater than - -- the length of Source, then the capacity of the result is the specified - -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter - -- is 0, then the modulus of the result is the value returned by a call to - -- Default_Modulus with the capacity parameter determined as above; - -- otherwise the modulus of the result is the specified value. - - procedure Move (Target : in out Map; Source : in out Map); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - -- Conditionally inserts New_Item into the map. If Key is already in the - -- map, then Inserted returns False and Position designates the node - -- containing the existing key/element pair (neither of which is modified). - -- If Key is not already in the map, the Inserted returns True and Position - -- designates the newly-inserted node container Key and New_Item. The - -- search for the key works as follows. Hash is called to determine Key's - -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to - -- compare Key to each node in that bucket. If the bucket is empty, or - -- there were no matching keys in the bucket, the search "fails" and the - -- key/item pair is inserted in the map (and Inserted returns True); - -- otherwise, the search "succeeds" (and Inserted returns False). - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - -- The same as the (conditional) Insert that accepts an element parameter, - -- with the difference that if Inserted returns True, then the element of - -- the newly-inserted node is initialized to its default value. - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Attempts to insert Key into the map, performing the usual search (which - -- involves calling both Hash and Equivalent_Keys); if the search succeeds - -- (because Key is already in the map), then it raises Constraint_Error. - -- (This version of Insert is similar to Replace, but having the opposite - -- exception behavior. It is intended for use when you want to assert that - -- Key is not already in the map.) - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Attempts to insert Key into the map. If Key is already in the map, then - -- both the existing key and element are assigned the values of Key and - -- New_Item, respectively. (This version of Insert only raises an exception - -- if cursor tampering occurs. It is intended for use when you want to - -- insert the key/element pair in the map, and you don't care whether Key - -- is already present.) - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Searches for Key in the map; if the search fails (because Key was not in - -- the map), then it raises Constraint_Error. Otherwise, both the existing - -- key and element are assigned the values of Key and New_Item rsp. (This - -- is similar to Insert, but with the opposite exception behavior. It is to - -- be used when you want to assert that Key is already in the map.) - - procedure Exclude (Container : in out Map; Key : Key_Type); - -- Searches for Key in the map, and if found, removes its node from the map - -- and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the key's bucket; if the bucket is not empty, it - -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is - -- the deletion analog of Include. It is intended for use when you want to - -- remove the item from the map, but don't care whether the key is already - -- in the map.) - - procedure Delete (Container : in out Map; Key : Key_Type); - -- Searches for Key in the map (which involves calling both Hash and - -- Equivalent_Keys). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the map and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the map.) - - procedure Delete (Container : in out Map; Position : in out Cursor); - -- Removes the node designated by Position from the map, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Keys). - - function First (Container : Map) return Cursor; - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Position : Cursor) return Cursor; - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Find (Container : Map; Key : Key_Type) return Cursor; - -- Searches for Key in the map. Find calls Hash to determine the key's - -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare - -- Key to each key in the bucket. If the search succeeds, Find returns a - -- cursor designating the matching node; otherwise, it returns No_Element. - - function Contains (Container : Map; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - function Element (Container : Map; Key : Key_Type) return Element_Type; - -- Equivalent to Element (Find (Container, Key)) - - function Equivalent_Keys (Left, Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Keys with the keys of the nodes - -- designated by cursors Left and Right. - - function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; - -- Returns the result of calling Equivalent_Keys with key of the node - -- designated by Left and key Right. - - function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Keys with key Left and the node - -- designated by Right. - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - -- Calls Process for each node in the map - - function Iterate (Container : Map) - return Map_Iterator_Interfaces.Forward_Iterator'class; - -private - pragma Inline (Length); - pragma Inline (Is_Empty); - pragma Inline (Clear); - pragma Inline (Key); - pragma Inline (Element); - pragma Inline (Move); - pragma Inline (Contains); - pragma Inline (Capacity); - pragma Inline (Reserve_Capacity); - pragma Inline (Has_Element); - pragma Inline (Next); - - type Node_Type is record - Key : Key_Type; - Element : aliased Element_Type; - Next : Count_Type; - end record; - - package HT_Types is - new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); - - type Map (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - - use HT_Types, HT_Types.Implementation; - use Ada.Streams; - use Ada.Finalization; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; - - -- Note: If a Cursor object has no explicit initialization expression, - -- it must default initialize to the same value as constant No_Element. - -- The Node component of type Cursor has scalar type Count_Type, so it - -- requires an explicit initialization expression of its own declaration, - -- in order for objects of record type Cursor to properly initialize. - - type Cursor is record - Container : Map_Access; - Node : Count_Type := 0; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Map : constant Map := - (Hash_Table_Type with Capacity => 0, Modulus => 0); - - No_Element : constant Cursor := (Container => null, Node => 0); - - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Forward_Iterator with - record - Container : Map_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Bounded_Hashed_Maps; diff --git a/gcc/ada/a-cbhase.adb b/gcc/ada/a-cbhase.adb deleted file mode 100644 index 59b0bdb..0000000 --- a/gcc/ada/a-cbhase.adb +++ /dev/null @@ -1,1946 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); - -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; - -with System; use type System.Address; - -package body Ada.Containers.Bounded_Hashed_Sets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - function Is_In (HT : Set; Key : Node_Type) return Boolean; - pragma Inline (Is_In); - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type); - pragma Inline (Set_Element); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Hash_Tables.Generic_Bounded_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Element_Keys is new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - procedure Replace_Element is - new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - function Find_Equal_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equal_Key); - - function Is_Equal is - new HT_Ops.Generic_Equal (Find_Equal_Key); - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - - R_Node : Count_Type := R_HT.Buckets (R_Index); - - begin - loop - if R_Node = 0 then - return False; - end if; - - if L_Node.Element = R_HT.Nodes (R_Node).Element then - return True; - end if; - - R_Node := Next (R_HT.Nodes (R_Node)); - end loop; - end Find_Equal_Key; - - -- Start of processing for "=" - - begin - return Is_Equal (Left, Right); - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - procedure Insert_Element (Source_Node : Count_Type); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Source_Node); - X : Count_Type; - B : Boolean; - begin - Insert (Target, N.Element, X, B); - pragma Assert (B); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error - with "Target capacity is less than Source length"; - end if; - - HT_Ops.Clear (Target); - Insert_Elements (Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Set) return Count_Type is - begin - return Container.Capacity; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - HT_Ops.Clear (Container); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Set; - Capacity : Count_Type := 0; - Modulus : Hash_Type := 0) return Set - is - C : Count_Type; - M : Hash_Type; - - begin - if Capacity = 0 then - C := Source.Length; - elsif Capacity >= Source.Length then - C := Capacity; - elsif Checks then - raise Capacity_Error with "Capacity value too small"; - end if; - - if Modulus = 0 then - M := Default_Modulus (C); - else - M := Modulus; - end if; - - return Target : Set (Capacity => C, Modulus => M) do - Assign (Target => Target, Source => Source); - end return; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Item : Element_Type) - is - X : Count_Type; - - begin - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - - if Checks and then X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - HT_Ops.Free (Container, X); - end Delete; - - procedure Delete - (Container : in out Set; - Position : in out Cursor) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - TC_Check (Container.TC); - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - HT_Ops.Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Target : in out Set; - Source : Set) - is - Tgt_Node, Src_Node : Count_Type; - - Src : Set renames Source'Unrestricted_Access.all; - - TN : Nodes_Type renames Target.Nodes; - SN : Nodes_Type renames Source.Nodes; - - begin - if Target'Address = Source'Address then - HT_Ops.Clear (Target); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - TC_Check (Target.TC); - - if Source.Length < Target.Length then - Src_Node := HT_Ops.First (Source); - while Src_Node /= 0 loop - Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element); - - if Tgt_Node /= 0 then - HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); - HT_Ops.Free (Target, Tgt_Node); - end if; - - Src_Node := HT_Ops.Next (Src, Src_Node); - end loop; - - else - Tgt_Node := HT_Ops.First (Target); - while Tgt_Node /= 0 loop - if Is_In (Source, TN (Tgt_Node)) then - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - HT_Ops.Free (Target, X); - end; - - else - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - end if; - end loop; - end if; - end Difference; - - function Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Left.Length = 0 then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; - - return Result : Set (Left.Length, To_Prime (Left.Length)) do - Iterate_Left : declare - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - N : Node_Type renames Left.Nodes (L_Node); - X : Count_Type; - B : Boolean; - begin - if not Is_In (Right, N) then - Insert (Result, N.Element, X, B); -- optimize this ??? - pragma Assert (B); - pragma Assert (X > 0); - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left); - end Iterate_Left; - end return; - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - declare - S : Set renames Position.Container.all; - N : Node_Type renames S.Nodes (Position.Node); - begin - return N.Element; - end; - end Element; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equivalent_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - - R_Node : Count_Type := R_HT.Buckets (R_Index); - - RN : Nodes_Type renames R_HT.Nodes; - - begin - loop - if R_Node = 0 then - return False; - end if; - - if Equivalent_Elements (L_Node.Element, RN (R_Node).Element) then - return True; - end if; - - R_Node := Next (R_HT.Nodes (R_Node)); - end loop; - end Find_Equivalent_Key; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left, Right); - end Equivalent_Sets; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Cursor) - return Boolean is - - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - if Checks and then Right.Node = 0 then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); - - -- AI05-0022 requires that a container implementation detect element - -- tampering by a generic actual subprogram. However, the following case - -- falls outside the scope of that AI. Randy Brukardt explained on the - -- ARG list on 2013/02/07 that: - - -- (Begin Quote): - -- But for an operation like "<" [the ordered set analog of - -- Equivalent_Elements], there is no need to "dereference" a cursor - -- after the call to the generic formal parameter function, so nothing - -- bad could happen if tampering is undetected. And the operation can - -- safely return a result without a problem even if an element is - -- deleted from the container. - -- (End Quote). - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - RN : Node_Type renames Right.Container.Nodes (Right.Node); - begin - return Equivalent_Elements (LN.Element, RN.Element); - end; - end Equivalent_Elements; - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean - is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - begin - return Equivalent_Elements (LN.Element, Right); - end; - end Equivalent_Elements; - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean - is - begin - if Checks and then Right.Node = 0 then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert - (Vet (Right), - "Right cursor of Equivalent_Elements is bad"); - - declare - RN : Node_Type renames Right.Container.Nodes (Right.Node); - begin - return Equivalent_Elements (Left, RN.Element); - end; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Elements (Key, Node.Element); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Item : Element_Type) - is - X : Count_Type; - begin - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - HT_Ops.Free (Container, X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Item : Element_Type) return Cursor - is - Node : constant Count_Type := - Element_Keys.Find (Container'Unrestricted_Access.all, Item); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end First; - - overriding function First (Object : Iterator) return Cursor is - begin - return Object.Container.First; - end First; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Nodes (Position.Node).Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= 0; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Element); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.TC); - - Container.Nodes (Position.Node).Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert (Container, New_Item, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Allocate_Set_Element (Node : in out Node_Type); - pragma Inline (Allocate_Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new HT_Ops.Generic_Allocate (Allocate_Set_Element); - - --------------------------- - -- Allocate_Set_Element -- - --------------------------- - - procedure Allocate_Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Allocate_Set_Element; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - -- The buckets array length is specified by the user as a discriminant - -- of the container type, so it is possible for the buckets array to - -- have a length of zero. We must check for this case specifically, in - -- order to prevent divide-by-zero errors later, when we compute the - -- buckets array index value for an element, given its hash value. - - if Checks and then Container.Buckets'Length = 0 then - raise Capacity_Error with "No capacity for insertion"; - end if; - - Local_Insert (Container, New_Item, Node, Inserted); - end Insert; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection - (Target : in out Set; - Source : Set) - is - Tgt_Node : Count_Type; - TN : Nodes_Type renames Target.Nodes; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.Length = 0 then - HT_Ops.Clear (Target); - return; - end if; - - TC_Check (Target.TC); - - Tgt_Node := HT_Ops.First (Target); - while Tgt_Node /= 0 loop - if Is_In (Source, TN (Tgt_Node)) then - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - - else - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - HT_Ops.Free (Target, X); - end; - end if; - end loop; - end Intersection; - - function Intersection (Left, Right : Set) return Set is - C : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - C := Count_Type'Min (Left.Length, Right.Length); - - if C = 0 then - return Empty_Set; - end if; - - return Result : Set (C, To_Prime (C)) do - Iterate_Left : declare - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - N : Node_Type renames Left.Nodes (L_Node); - X : Count_Type; - B : Boolean; - - begin - if Is_In (Right, N) then - Insert (Result, N.Element, X, B); -- optimize ??? - pragma Assert (B); - pragma Assert (X > 0); - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left); - end Iterate_Left; - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ----------- - -- Is_In -- - ----------- - - function Is_In (HT : Set; Key : Node_Type) return Boolean is - begin - return Element_Keys.Find (HT'Unrestricted_Access.all, Key.Element) /= 0; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - Subset_Node : Count_Type; - SN : Nodes_Type renames Subset.Nodes; - - begin - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Subset.Length > Of_Set.Length then - return False; - end if; - - Subset_Node := HT_Ops.First (Subset); - while Subset_Node /= 0 loop - if not Is_In (Of_Set, SN (Subset_Node)) then - return False; - end if; - Subset_Node := HT_Ops.Next - (Subset'Unrestricted_Access.all, Subset_Node); - end loop; - - return True; - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Iterate (Container); - end Iterate; - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class - is - begin - Busy (Container.TC'Unrestricted_Access.all); - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access); - end Iterate; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Assign (Source); - Source.Clear; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - HT : Set renames Position.Container.all; - Node : constant Count_Type := HT_Ops.Next (HT, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - Left_Node : Count_Type; - - begin - if Right.Length = 0 then - return False; - end if; - - if Left'Address = Right'Address then - return True; - end if; - - Left_Node := HT_Ops.First (Left); - while Left_Node /= 0 loop - if Is_In (Right, Left.Nodes (Left_Node)) then - return True; - end if; - Left_Node := HT_Ops.Next (Left'Unrestricted_Access.all, Left_Node); - end loop; - - return False; - end Overlap; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - S : Set renames Position.Container.all; - Lock : With_Lock (S.TC'Unrestricted_Access); - begin - Process (S.Nodes (Position.Node).Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type; - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new HT_Ops.Generic_Allocate (Read_Element); - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - Node : Count_Type; - - -- Start of processing for Read_Node - - begin - Allocate (Container, Node); - return Node; - end Read_Node; - - -- Start of processing for Read - - begin - Read_Nodes (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - New_Item : Element_Type) - is - Node : constant Count_Type := Element_Keys.Find (Container, New_Item); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - TE_Check (Container.TC); - - Container.Nodes (Node).Element := New_Item; - end Replace; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Replace_Element (Container, Position.Node, New_Item); - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - is - begin - if Checks and then Capacity > Container.Capacity then - raise Capacity_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - ------------------ - -- Set_Element -- - ------------------ - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is - begin - Node.Element := Item; - end Set_Element; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference - (Target : in out Set; - Source : Set) - is - procedure Process (Source_Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Source_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Source_Node); - X : Count_Type; - B : Boolean; - - begin - if Is_In (Target, N) then - Delete (Target, N.Element); - else - Insert (Target, N.Element, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Symmetric_Difference - - begin - if Target'Address = Source'Address then - HT_Ops.Clear (Target); - return; - end if; - - if Target.Length = 0 then - Assign (Target => Target, Source => Source); - return; - end if; - - TC_Check (Target.TC); - - Iterate (Source); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - C : Count_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - C := Left.Length + Right.Length; - - return Result : Set (C, To_Prime (C)) do - Iterate_Left : declare - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - N : Node_Type renames Left.Nodes (L_Node); - X : Count_Type; - B : Boolean; - begin - if not Is_In (Right, N) then - Insert (Result, N.Element, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left); - end Iterate_Left; - - Iterate_Right : declare - procedure Process (R_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (R_Node : Count_Type) is - N : Node_Type renames Right.Nodes (R_Node); - X : Count_Type; - B : Boolean; - begin - if not Is_In (Left, N) then - Insert (Result, N.Element, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Iterate_Right - - begin - Iterate (Right); - end Iterate_Right; - end return; - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - X : Count_Type; - B : Boolean; - begin - return Result : Set (1, 1) do - Insert (Result, New_Item, X, B); - pragma Assert (B); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union - (Target : in out Set; - Source : Set) - is - procedure Process (Src_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Src_Node); - X : Count_Type; - B : Boolean; - begin - Insert (Target, N.Element, X, B); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Target.TC); - - -- ??? why is this code commented out ??? - -- declare - -- N : constant Count_Type := Target.Length + Source.Length; - -- begin - -- if N > HT_Ops.Capacity (Target.HT) then - -- HT_Ops.Reserve_Capacity (Target.HT, N); - -- end if; - -- end; - - Iterate (Source); - end Union; - - function Union (Left, Right : Set) return Set is - C : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - C := Left.Length + Right.Length; - - return Result : Set (C, To_Prime (C)) do - Assign (Target => Result, Source => Left); - Union (Target => Result, Source => Right); - end return; - end Union; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - declare - S : Set renames Position.Container.all; - N : Nodes_Type renames S.Nodes; - X : Count_Type; - - begin - if S.Length = 0 then - return False; - end if; - - if Position.Node > N'Last then - return False; - end if; - - if N (Position.Node).Next = Position.Node then - return False; - end if; - - X := S.Buckets (Element_Keys.Checked_Index - (S, N (Position.Node).Element)); - - for J in 1 .. S.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = N (X).Next then -- to prevent unnecessary looping - return False; - end if; - - X := N (X).Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Count_Type := - Key_Keys.Find (Container'Unrestricted_Access.all, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Key : Key_Type) return Boolean - is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Key : Key_Type) - is - X : Count_Type; - - begin - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - - if Checks and then X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - HT_Ops.Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - Node : constant Count_Type := - Key_Keys.Find (Container'Unrestricted_Access.all, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - return Container.Nodes (Node).Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); - end Equivalent_Key_Node; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Key : Key_Type) - is - X : Count_Type; - begin - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - HT_Ops.Free (Container, X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Impl.Reference_Control_Type (Control).Finalize; - - if Checks and then - Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash - then - HT_Ops.Delete_Node_At_Index - (Control.Container.all, Control.Index, Control.Old_Pos.Node); - raise Program_Error with "key not preserved in reference"; - end if; - - Control.Container := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Key : Key_Type) return Cursor - is - Node : constant Count_Type := - Key_Keys.Find (Container'Unrestricted_Access.all, Key); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - return Key (Position.Container.Nodes (Position.Node).Element); - end Key; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert - (Vet (Position), - "bad cursor in function Reference_Preserving_Key"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - return R : constant Reference_Type := - (Element => N.Element'Unrestricted_Access, - Control => - (Controlled with - Container.TC'Unrestricted_Access, - Container'Unrestricted_Access, - Index => Key_Keys.Index (Container, Key (Position)), - Old_Pos => Position, - Old_Hash => Hash (Key (Position)))) - do - Lock (Container.TC); - end return; - end; - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - P : constant Cursor := Find (Container, Key); - begin - return R : constant Reference_Type := - (Element => Container.Nodes (Node).Element'Unrestricted_Access, - Control => - (Controlled with - Container.TC'Unrestricted_Access, - Container'Unrestricted_Access, - Index => Key_Keys.Index (Container, Key), - Old_Pos => P, - Old_Hash => Hash (Key))) - do - Lock (Container.TC); - end return; - end; - end Reference_Preserving_Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container, Node, New_Item); - end Replace; - - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - Indx : Hash_Type; - N : Nodes_Type renames Container.Nodes; - - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - -- ??? why is this code commented out ??? - -- if HT.Buckets = null - -- or else HT.Buckets'Length = 0 - -- or else HT.Length = 0 - -- or else Position.Node.Next = Position.Node - -- then - -- raise Program_Error with - -- "Position cursor is bad (set is empty)"; - -- end if; - - pragma Assert - (Vet (Position), - "bad cursor in Update_Element_Preserving_Key"); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - E : Element_Type renames N (Position.Node).Element; - K : constant Key_Type := Key (E); - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - -- Record bucket now, in case key is changed - Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); - - Process (E); - - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - -- Key was modified, so remove this node from set. - - if Container.Buckets (Indx) = Position.Node then - Container.Buckets (Indx) := N (Position.Node).Next; - - else - declare - Prev : Count_Type := Container.Buckets (Indx); - - begin - while N (Prev).Next /= Position.Node loop - Prev := N (Prev).Next; - - if Checks and then Prev = 0 then - raise Program_Error with - "Position cursor is bad (node not found)"; - end if; - end loop; - - N (Prev).Next := N (Position.Node).Next; - end; - end if; - - Container.Length := Container.Length - 1; - HT_Ops.Free (Container, Position.Node); - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - end Generic_Keys; - -end Ada.Containers.Bounded_Hashed_Sets; diff --git a/gcc/ada/a-cbhase.ads b/gcc/ada/a-cbhase.ads deleted file mode 100644 index 1023fc5..0000000 --- a/gcc/ada/a-cbhase.ads +++ /dev/null @@ -1,605 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Hash_Tables; -with Ada.Containers.Helpers; -private with Ada.Streams; -private with Ada.Finalization; use Ada.Finalization; - -generic - type Element_Type is private; - - with function Hash (Element : Element_Type) return Hash_Type; - - with function Equivalent_Elements - (Left, Right : Element_Type) return Boolean; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Bounded_Hashed_Sets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - pragma Remote_Types; - - type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private - with Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Set : constant Set; - -- Set objects declared without an initialization expression are - -- initialized to the value Empty_Set. - - No_Element : constant Cursor; - -- Cursor objects declared without an initialization expression are - -- initialized to the value No_Element. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - -- For each element in Left, set equality attempts to find the equal - -- element in Right; if a search fails, then set equality immediately - -- returns False. The search works by calling Hash to find the bucket in - -- the Right set that corresponds to the Left element. If the bucket is - -- non-empty, the search calls the generic formal element equality operator - -- to compare the element (in Left) to the element of each node in the - -- bucket (in Right); the search terminates when a matching node in the - -- bucket is found, or the nodes in the bucket are exhausted. (Note that - -- element equality is called here, not Equivalent_Elements. Set equality - -- is the only operation in which element equality is used. Compare set - -- equality to Equivalent_Sets, which does call Equivalent_Elements.) - - function Equivalent_Sets (Left, Right : Set) return Boolean; - -- Similar to set equality, with the difference that the element in Left is - -- compared to the elements in Right using the generic formal - -- Equivalent_Elements operation instead of element equality. - - function To_Set (New_Item : Element_Type) return Set; - -- Constructs a singleton set comprising New_Element. To_Set calls Hash to - -- determine the bucket for New_Item. - - function Capacity (Container : Set) return Count_Type; - -- Returns the current capacity of the set. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); - -- If the value of the Capacity actual parameter is less or equal to - -- Container.Capacity, then the operation has no effect. Otherwise it - -- raises Capacity_Error (as no expansion of capacity is possible for a - -- bounded form). - - function Default_Modulus (Capacity : Count_Type) return Hash_Type; - -- Returns a modulus value (hash table size) which is optimal for the - -- specified capacity (which corresponds to the maximum number of items). - - function Length (Container : Set) return Count_Type; - -- Returns the number of items in the set - - function Is_Empty (Container : Set) return Boolean; - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Set); - -- Removes all of the items from the set - - function Element (Position : Cursor) return Element_Type; - -- Returns the element of the node designated by the cursor - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - -- If New_Item is equivalent (as determined by calling Equivalent_Elements) - -- to the element of the node designated by Position, then New_Element is - -- assigned to that element. Otherwise, it calls Hash to determine the - -- bucket for New_Item. If the bucket is not empty, then it calls - -- Equivalent_Elements for each node in that bucket to determine whether - -- New_Item is equivalent to an element in that bucket. If - -- Equivalent_Elements returns True then Program_Error is raised (because - -- an element may appear only once in the set); otherwise, New_Item is - -- assigned to the node designated by Position, and the node is moved to - -- its new bucket. - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - -- Calls Process with the element (having only a constant view) of the node - -- designated by the cursor. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - - procedure Assign (Target : in out Set; Source : Set); - -- If Target denotes the same object as Source, then the operation has no - -- effect. If the Target capacity is less than the Source length, then - -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then - -- copies the (active) elements from Source to Target. - - function Copy - (Source : Set; - Capacity : Count_Type := 0; - Modulus : Hash_Type := 0) return Set; - -- Constructs a new set object whose elements correspond to Source. If the - -- Capacity parameter is 0, then the capacity of the result is the same as - -- the length of Source. If the Capacity parameter is equal or greater than - -- the length of Source, then the capacity of the result is the specified - -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter - -- is 0, then the modulus of the result is the value returned by a call to - -- Default_Modulus with the capacity parameter determined as above; - -- otherwise the modulus of the result is the specified value. - - procedure Move (Target : in out Set; Source : in out Set); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - -- Conditionally inserts New_Item into the set. If New_Item is already in - -- the set, then Inserted returns False and Position designates the node - -- containing the existing element (which is not modified). If New_Item is - -- not already in the set, then Inserted returns True and Position - -- designates the newly-inserted node containing New_Item. The search for - -- an existing element works as follows. Hash is called to determine - -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements - -- is called to compare New_Item to the element of each node in that - -- bucket. If the bucket is empty, or there were no equivalent elements in - -- the bucket, the search "fails" and the New_Item is inserted in the set - -- (and Inserted returns True); otherwise, the search "succeeds" (and - -- Inserted returns False). - - procedure Insert (Container : in out Set; New_Item : Element_Type); - -- Attempts to insert New_Item into the set, performing the usual insertion - -- search (which involves calling both Hash and Equivalent_Elements); if - -- the search succeeds (New_Item is equivalent to an element already in the - -- set, and so was not inserted), then this operation raises - -- Constraint_Error. (This version of Insert is similar to Replace, but - -- having the opposite exception behavior. It is intended for use when you - -- want to assert that the item is not already in the set.) - - procedure Include (Container : in out Set; New_Item : Element_Type); - -- Attempts to insert New_Item into the set. If an element equivalent to - -- New_Item is already in the set (the insertion search succeeded, and - -- hence New_Item was not inserted), then the value of New_Item is assigned - -- to the existing element. (This insertion operation only raises an - -- exception if cursor tampering occurs. It is intended for use when you - -- want to insert the item in the set, and you don't care whether an - -- equivalent element is already present.) - - procedure Replace (Container : in out Set; New_Item : Element_Type); - -- Searches for New_Item in the set; if the search fails (because an - -- equivalent element was not in the set), then it raises - -- Constraint_Error. Otherwise, the existing element is assigned the value - -- New_Item. (This is similar to Insert, but with the opposite exception - -- behavior. It is intended for use when you want to assert that the item - -- is already in the set.) - - procedure Exclude (Container : in out Set; Item : Element_Type); - -- Searches for Item in the set, and if found, removes its node from the - -- set and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the item's bucket; if the bucket is not empty, - -- it calls Equivalent_Elements to compare Item to the element of each node - -- in the bucket. (This is the deletion analog of Include. It is intended - -- for use when you want to remove the item from the set, but don't care - -- whether the item is already in the set.) - - procedure Delete (Container : in out Set; Item : Element_Type); - -- Searches for Item in the set (which involves calling both Hash and - -- Equivalent_Elements). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the set and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the set.) - - procedure Delete (Container : in out Set; Position : in out Cursor); - -- Removes the node designated by Position from the set, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Elements). - - procedure Union (Target : in out Set; Source : Set); - -- Iterates over the Source set, and conditionally inserts each element - -- into Target. - - function Union (Left, Right : Set) return Set; - -- The operation first copies the Left set to the result, and then iterates - -- over the Right set to conditionally insert each element into the result. - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - -- Iterates over the Target set (calling First and Next), calling Find to - -- determine whether the element is in Source. If an equivalent element is - -- not found in Source, the element is deleted from Target. - - function Intersection (Left, Right : Set) return Set; - -- Iterates over the Left set, calling Find to determine whether the - -- element is in Right. If an equivalent element is found, it is inserted - -- into the result set. - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - -- Iterates over the Source (calling First and Next), calling Find to - -- determine whether the element is in Target. If an equivalent element is - -- found, it is deleted from Target. - - function Difference (Left, Right : Set) return Set; - -- Iterates over the Left set, calling Find to determine whether the - -- element is in the Right set. If an equivalent element is not found, the - -- element is inserted into the result set. - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - -- The operation iterates over the Source set, searching for the element - -- in Target (calling Hash and Equivalent_Elements). If an equivalent - -- element is found, it is removed from Target; otherwise it is inserted - -- into Target. - - function Symmetric_Difference (Left, Right : Set) return Set; - -- The operation first iterates over the Left set. It calls Find to - -- determine whether the element is in the Right set. If no equivalent - -- element is found, the element from Left is inserted into the result. The - -- operation then iterates over the Right set, to determine whether the - -- element is in the Left set. If no equivalent element is found, the Right - -- element is inserted into the result. - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - -- Iterates over the Left set (calling First and Next), calling Find to - -- determine whether the element is in the Right set. If an equivalent - -- element is found, the operation immediately returns True. The operation - -- returns False if the iteration over Left terminates without finding any - -- equivalent element in Right. - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - -- Iterates over Subset (calling First and Next), calling Find to determine - -- whether the element is in Of_Set. If no equivalent element is found in - -- Of_Set, the operation immediately returns False. The operation returns - -- True if the iteration over Subset terminates without finding an element - -- not in Of_Set (that is, every element in Subset is equivalent to an - -- element in Of_Set). - - function First (Container : Set) return Cursor; - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Position : Cursor) return Cursor; - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Find - (Container : Set; - Item : Element_Type) return Cursor; - -- Searches for Item in the set. Find calls Hash to determine the item's - -- bucket; if the bucket is not empty, it calls Equivalent_Elements to - -- compare Item to each element in the bucket. If the search succeeds, Find - -- returns a cursor designating the node containing the equivalent element; - -- otherwise, it returns No_Element. - - function Contains (Container : Set; Item : Element_Type) return Boolean; - -- Equivalent to Find (Container, Item) /= No_Element - - function Equivalent_Elements (Left, Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Elements with the elements of - -- the nodes designated by cursors Left and Right. - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean; - -- Returns the result of calling Equivalent_Elements with element of the - -- node designated by Left and element Right. - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Elements with element Left and - -- the element of the node designated by Right. - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - -- Calls Process for each node in the set - - function Iterate - (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - package Generic_Keys is - - function Key (Position : Cursor) return Key_Type; - -- Applies generic formal operation Key to the element of the node - -- designated by Position. - - function Element (Container : Set; Key : Key_Type) return Element_Type; - -- Searches (as per the key-based Find) for the node containing Key, and - -- returns the associated element. - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type); - -- Searches (as per the key-based Find) for the node containing Key, and - -- then replaces the element of that node (as per the element-based - -- Replace_Element). - - procedure Exclude (Container : in out Set; Key : Key_Type); - -- Searches for Key in the set, and if found, removes its node from the - -- set and then deallocates it. The search works by first calling Hash - -- (on Key) to determine the bucket; if the bucket is not empty, it - -- calls Equivalent_Keys to compare parameter Key to the value of - -- generic formal operation Key applied to element of each node in the - -- bucket. - - procedure Delete (Container : in out Set; Key : Key_Type); - -- Deletes the node containing Key as per Exclude, with the difference - -- that Constraint_Error is raised if Key is not found. - - function Find (Container : Set; Key : Key_Type) return Cursor; - -- Searches for the node containing Key, and returns a cursor - -- designating the node. The search works by first calling Hash (on Key) - -- to determine the bucket. If the bucket is not empty, the search - -- compares Key to the element of each node in the bucket, and returns - -- the matching node. The comparison itself works by applying the - -- generic formal Key operation to the element of the node, and then - -- calling generic formal operation Equivalent_Keys. - - function Contains (Container : Set; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - -- Calls Process with the element of the node designated by Position, - -- but with the restriction that the key-value of the element is not - -- modified. The operation first makes a copy of the value returned by - -- applying generic formal operation Key on the element of the node, and - -- then calls Process with the element. The operation verifies that the - -- key-part has not been modified by calling generic formal operation - -- Equivalent_Keys to compare the saved key-value to the value returned - -- by applying generic formal operation Key to the post-Process value of - -- element. If the key values compare equal then the operation - -- completes. Otherwise, the node is removed from the map and - -- Program_Error is raised. - - type Reference_Type (Element : not null access Element_Type) is private - with Implicit_Dereference => Element; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type; - - private - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - package Impl is new Helpers.Generic_Implementation; - - type Reference_Control_Type is - new Impl.Reference_Control_Type with - record - Container : Set_Access; - Index : Hash_Type; - Old_Pos : Cursor; - Old_Hash : Hash_Type; - end record; - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type; - end record; - - use Ada.Streams; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - end Generic_Keys; - -private - pragma Inline (Next); - - type Node_Type is record - Element : aliased Element_Type; - Next : Count_Type; - end record; - - package HT_Types is - new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); - - type Set (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - - use HT_Types, HT_Types.Implementation; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - -- Note: If a Cursor object has no explicit initialization expression, - -- it must default initialize to the same value as constant No_Element. - -- The Node component of type Cursor has scalar type Count_Type, so it - -- requires an explicit initialization expression of its own declaration, - -- in order for objects of record type Cursor to properly initialize. - - type Cursor is record - Container : Set_Access; - Node : Count_Type := 0; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Set : constant Set := - (Hash_Table_Type with Capacity => 0, Modulus => 0); - - No_Element : constant Cursor := (Container => null, Node => 0); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Forward_Iterator with - record - Container : Set_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Bounded_Hashed_Sets; diff --git a/gcc/ada/a-cbmutr.adb b/gcc/ada/a-cbmutr.adb deleted file mode 100644 index 3fe986d..0000000 --- a/gcc/ada/a-cbmutr.adb +++ /dev/null @@ -1,3327 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Finalization; -with System; use type System.Address; - -package body Ada.Containers.Bounded_Multiway_Trees is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - use Finalization; - - -------------------- - -- Root_Iterator -- - -------------------- - - type Root_Iterator is abstract new Limited_Controlled and - Tree_Iterator_Interfaces.Forward_Iterator with - record - Container : Tree_Access; - Subtree : Count_Type; - end record; - - overriding procedure Finalize (Object : in out Root_Iterator); - - ----------------------- - -- Subtree_Iterator -- - ----------------------- - - type Subtree_Iterator is new Root_Iterator with null record; - - overriding function First (Object : Subtree_Iterator) return Cursor; - - overriding function Next - (Object : Subtree_Iterator; - Position : Cursor) return Cursor; - - --------------------- - -- Child_Iterator -- - --------------------- - - type Child_Iterator is new Root_Iterator and - Tree_Iterator_Interfaces.Reversible_Iterator with null record; - - overriding function First (Object : Child_Iterator) return Cursor; - - overriding function Next - (Object : Child_Iterator; - Position : Cursor) return Cursor; - - overriding function Last (Object : Child_Iterator) return Cursor; - - overriding function Previous - (Object : Child_Iterator; - Position : Cursor) return Cursor; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Initialize_Node (Container : in out Tree; Index : Count_Type); - procedure Initialize_Root (Container : in out Tree); - - procedure Allocate_Node - (Container : in out Tree; - Initialize_Element : not null access procedure (Index : Count_Type); - New_Node : out Count_Type); - - procedure Allocate_Node - (Container : in out Tree; - New_Item : Element_Type; - New_Node : out Count_Type); - - procedure Allocate_Node - (Container : in out Tree; - Stream : not null access Root_Stream_Type'Class; - New_Node : out Count_Type); - - procedure Deallocate_Node - (Container : in out Tree; - X : Count_Type); - - procedure Deallocate_Children - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type); - - procedure Deallocate_Subtree - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type); - - function Equal_Children - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean; - - function Equal_Subtree - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean; - - procedure Iterate_Children - (Container : Tree; - Subtree : Count_Type; - Process : not null access procedure (Position : Cursor)); - - procedure Iterate_Subtree - (Container : Tree; - Subtree : Count_Type; - Process : not null access procedure (Position : Cursor)); - - procedure Copy_Children - (Source : Tree; - Source_Parent : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Count : in out Count_Type); - - procedure Copy_Subtree - (Source : Tree; - Source_Subtree : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Target_Subtree : out Count_Type; - Count : in out Count_Type); - - function Find_In_Children - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type; - - function Find_In_Subtree - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type; - - function Child_Count - (Container : Tree; - Parent : Count_Type) return Count_Type; - - function Subtree_Node_Count - (Container : Tree; - Subtree : Count_Type) return Count_Type; - - function Is_Reachable - (Container : Tree; - From, To : Count_Type) return Boolean; - - function Root_Node (Container : Tree) return Count_Type; - - procedure Remove_Subtree - (Container : in out Tree; - Subtree : Count_Type); - - procedure Insert_Subtree_Node - (Container : in out Tree; - Subtree : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base); - - procedure Insert_Subtree_List - (Container : in out Tree; - First : Count_Type'Base; - Last : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base); - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source_Parent : Count_Type); - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Source_Parent : Count_Type); - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Position : in out Count_Type); -- source on input, target on output - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Tree) return Boolean is - begin - if Left.Count /= Right.Count then - return False; - end if; - - if Left.Count = 0 then - return True; - end if; - - return Equal_Children - (Left_Tree => Left, - Left_Subtree => Root_Node (Left), - Right_Tree => Right, - Right_Subtree => Root_Node (Right)); - end "="; - - ------------------- - -- Allocate_Node -- - ------------------- - - procedure Allocate_Node - (Container : in out Tree; - Initialize_Element : not null access procedure (Index : Count_Type); - New_Node : out Count_Type) - is - begin - if Container.Free >= 0 then - New_Node := Container.Free; - pragma Assert (New_Node in Container.Elements'Range); - - -- We always perform the assignment first, before we change container - -- state, in order to defend against exceptions duration assignment. - - Initialize_Element (New_Node); - - Container.Free := Container.Nodes (New_Node).Next; - - else - -- A negative free store value means that the links of the nodes in - -- the free store have not been initialized. In this case, the nodes - -- are physically contiguous in the array, starting at the index that - -- is the absolute value of the Container.Free, and continuing until - -- the end of the array (Nodes'Last). - - New_Node := abs Container.Free; - pragma Assert (New_Node in Container.Elements'Range); - - -- As above, we perform this assignment first, before modifying any - -- container state. - - Initialize_Element (New_Node); - - Container.Free := Container.Free - 1; - - if abs Container.Free > Container.Capacity then - Container.Free := 0; - end if; - end if; - - Initialize_Node (Container, New_Node); - end Allocate_Node; - - procedure Allocate_Node - (Container : in out Tree; - New_Item : Element_Type; - New_Node : out Count_Type) - is - procedure Initialize_Element (Index : Count_Type); - - procedure Initialize_Element (Index : Count_Type) is - begin - Container.Elements (Index) := New_Item; - end Initialize_Element; - - begin - Allocate_Node (Container, Initialize_Element'Access, New_Node); - end Allocate_Node; - - procedure Allocate_Node - (Container : in out Tree; - Stream : not null access Root_Stream_Type'Class; - New_Node : out Count_Type) - is - procedure Initialize_Element (Index : Count_Type); - - procedure Initialize_Element (Index : Count_Type) is - begin - Element_Type'Read (Stream, Container.Elements (Index)); - end Initialize_Element; - - begin - Allocate_Node (Container, Initialize_Element'Access, New_Node); - end Allocate_Node; - - ------------------- - -- Ancestor_Find -- - ------------------- - - function Ancestor_Find - (Position : Cursor; - Item : Element_Type) return Cursor - is - R, N : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- AI-0136 says to raise PE if Position equals the root node. This does - -- not seem correct, as this value is just the limiting condition of the - -- search. For now we omit this check, pending a ruling from the ARG. - -- ??? - -- - -- if Checks and then Is_Root (Position) then - -- raise Program_Error with "Position cursor designates root"; - -- end if; - - R := Root_Node (Position.Container.all); - N := Position.Node; - while N /= R loop - if Position.Container.Elements (N) = Item then - return Cursor'(Position.Container, N); - end if; - - N := Position.Container.Nodes (N).Parent; - end loop; - - return No_Element; - end Ancestor_Find; - - ------------------ - -- Append_Child -- - ------------------ - - procedure Append_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Nodes : Tree_Node_Array renames Container.Nodes; - First, Last : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Count = 0 then - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => No_Node); -- means "insert at end of list" - - Container.Count := Container.Count + Count; - end Append_Child; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Tree; Source : Tree) is - Target_Count : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Count then - raise Capacity_Error -- ??? - with "Target capacity is less than Source count"; - end if; - - Target.Clear; -- Checks busy bit - - if Source.Count = 0 then - return; - end if; - - Initialize_Root (Target); - - -- Copy_Children returns the number of nodes that it allocates, but it - -- does this by incrementing the count value passed in, so we must - -- initialize the count before calling Copy_Children. - - Target_Count := 0; - - Copy_Children - (Source => Source, - Source_Parent => Root_Node (Source), - Target => Target, - Target_Parent => Root_Node (Target), - Count => Target_Count); - - pragma Assert (Target_Count = Source.Count); - Target.Count := Source.Count; - end Assign; - - ----------------- - -- Child_Count -- - ----------------- - - function Child_Count (Parent : Cursor) return Count_Type is - begin - if Parent = No_Element then - return 0; - - elsif Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return 0; - - else - return Child_Count (Parent.Container.all, Parent.Node); - end if; - end Child_Count; - - function Child_Count - (Container : Tree; - Parent : Count_Type) return Count_Type - is - NN : Tree_Node_Array renames Container.Nodes; - CC : Children_Type renames NN (Parent).Children; - - Result : Count_Type; - Node : Count_Type'Base; - - begin - Result := 0; - Node := CC.First; - while Node > 0 loop - Result := Result + 1; - Node := NN (Node).Next; - end loop; - - return Result; - end Child_Count; - - ----------------- - -- Child_Depth -- - ----------------- - - function Child_Depth (Parent, Child : Cursor) return Count_Type is - Result : Count_Type; - N : Count_Type'Base; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Child = No_Element then - raise Constraint_Error with "Child cursor has no element"; - end if; - - if Checks and then Parent.Container /= Child.Container then - raise Program_Error with "Parent and Child in different containers"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - pragma Assert (Child = Parent); - return 0; - end if; - - Result := 0; - N := Child.Node; - while N /= Parent.Node loop - Result := Result + 1; - N := Parent.Container.Nodes (N).Parent; - - if Checks and then N < 0 then - raise Program_Error with "Parent is not ancestor of Child"; - end if; - end loop; - - return Result; - end Child_Depth; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Tree) is - Container_Count : constant Count_Type := Container.Count; - Count : Count_Type; - - begin - TC_Check (Container.TC); - - if Container_Count = 0 then - return; - end if; - - Container.Count := 0; - - -- Deallocate_Children returns the number of nodes that it deallocates, - -- but it does this by incrementing the count value that is passed in, - -- so we must first initialize the count return value before calling it. - - Count := 0; - - Deallocate_Children - (Container => Container, - Subtree => Root_Node (Container), - Count => Count); - - pragma Assert (Count = Container_Count); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Container.Elements (Position.Node)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Tree; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Tree; - Capacity : Count_Type := 0) return Tree - is - C : Count_Type; - - begin - if Capacity = 0 then - C := Source.Count; - elsif Capacity >= Source.Count then - C := Capacity; - elsif Checks then - raise Capacity_Error with "Capacity value too small"; - end if; - - return Target : Tree (Capacity => C) do - Initialize_Root (Target); - - if Source.Count = 0 then - return; - end if; - - Copy_Children - (Source => Source, - Source_Parent => Root_Node (Source), - Target => Target, - Target_Parent => Root_Node (Target), - Count => Target.Count); - - pragma Assert (Target.Count = Source.Count); - end return; - end Copy; - - ------------------- - -- Copy_Children -- - ------------------- - - procedure Copy_Children - (Source : Tree; - Source_Parent : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Count : in out Count_Type) - is - S_Nodes : Tree_Node_Array renames Source.Nodes; - S_Node : Tree_Node_Type renames S_Nodes (Source_Parent); - - T_Nodes : Tree_Node_Array renames Target.Nodes; - T_Node : Tree_Node_Type renames T_Nodes (Target_Parent); - - pragma Assert (T_Node.Children.First <= 0); - pragma Assert (T_Node.Children.Last <= 0); - - T_CC : Children_Type; - C : Count_Type'Base; - - begin - -- We special-case the first allocation, in order to establish the - -- representation invariants for type Children_Type. - - C := S_Node.Children.First; - - if C <= 0 then -- source parent has no children - return; - end if; - - Copy_Subtree - (Source => Source, - Source_Subtree => C, - Target => Target, - Target_Parent => Target_Parent, - Target_Subtree => T_CC.First, - Count => Count); - - T_CC.Last := T_CC.First; - - -- The representation invariants for the Children_Type list have been - -- established, so we can now copy the remaining children of Source. - - C := S_Nodes (C).Next; - while C > 0 loop - Copy_Subtree - (Source => Source, - Source_Subtree => C, - Target => Target, - Target_Parent => Target_Parent, - Target_Subtree => T_Nodes (T_CC.Last).Next, - Count => Count); - - T_Nodes (T_Nodes (T_CC.Last).Next).Prev := T_CC.Last; - T_CC.Last := T_Nodes (T_CC.Last).Next; - - C := S_Nodes (C).Next; - end loop; - - -- We add the newly-allocated children to their parent list only after - -- the allocation has succeeded, in order to preserve invariants of the - -- parent. - - T_Node.Children := T_CC; - end Copy_Children; - - ------------------ - -- Copy_Subtree -- - ------------------ - - procedure Copy_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : Cursor) - is - Target_Subtree : Count_Type; - Target_Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Target'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then - Before.Container.Nodes (Before.Node).Parent /= Parent.Node - then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Source = No_Element then - return; - end if; - - if Checks and then Is_Root (Source) then - raise Constraint_Error with "Source cursor designates root"; - end if; - - if Target.Count = 0 then - Initialize_Root (Target); - end if; - - -- Copy_Subtree returns a count of the number of nodes that it - -- allocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Copy_Subtree. - - Target_Count := 0; - - Copy_Subtree - (Source => Source.Container.all, - Source_Subtree => Source.Node, - Target => Target, - Target_Parent => Parent.Node, - Target_Subtree => Target_Subtree, - Count => Target_Count); - - Insert_Subtree_Node - (Container => Target, - Subtree => Target_Subtree, - Parent => Parent.Node, - Before => Before.Node); - - Target.Count := Target.Count + Target_Count; - end Copy_Subtree; - - procedure Copy_Subtree - (Source : Tree; - Source_Subtree : Count_Type; - Target : in out Tree; - Target_Parent : Count_Type; - Target_Subtree : out Count_Type; - Count : in out Count_Type) - is - T_Nodes : Tree_Node_Array renames Target.Nodes; - - begin - -- First we allocate the root of the target subtree. - - Allocate_Node - (Container => Target, - New_Item => Source.Elements (Source_Subtree), - New_Node => Target_Subtree); - - T_Nodes (Target_Subtree).Parent := Target_Parent; - Count := Count + 1; - - -- We now have a new subtree (for the Target tree), containing only a - -- copy of the corresponding element in the Source subtree. Next we copy - -- the children of the Source subtree as children of the new Target - -- subtree. - - Copy_Children - (Source => Source, - Source_Parent => Source_Subtree, - Target => Target, - Target_Parent => Target_Subtree, - Count => Count); - end Copy_Subtree; - - ------------------------- - -- Deallocate_Children -- - ------------------------- - - procedure Deallocate_Children - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type) - is - Nodes : Tree_Node_Array renames Container.Nodes; - Node : Tree_Node_Type renames Nodes (Subtree); -- parent - CC : Children_Type renames Node.Children; - C : Count_Type'Base; - - begin - while CC.First > 0 loop - C := CC.First; - CC.First := Nodes (C).Next; - - Deallocate_Subtree (Container, C, Count); - end loop; - - CC.Last := 0; - end Deallocate_Children; - - --------------------- - -- Deallocate_Node -- - --------------------- - - procedure Deallocate_Node - (Container : in out Tree; - X : Count_Type) - is - NN : Tree_Node_Array renames Container.Nodes; - pragma Assert (X > 0); - pragma Assert (X <= NN'Last); - - N : Tree_Node_Type renames NN (X); - pragma Assert (N.Parent /= X); -- node is active - - begin - -- The tree container actually contains two lists: one for the "active" - -- nodes that contain elements that have been inserted onto the tree, - -- and another for the "inactive" nodes of the free store, from which - -- nodes are allocated when a new child is inserted in the tree. - - -- We desire that merely declaring a tree object should have only - -- minimal cost; specially, we want to avoid having to initialize the - -- free store (to fill in the links), especially if the capacity of the - -- tree object is large. - - -- The head of the free list is indicated by Container.Free. If its - -- value is non-negative, then the free store has been initialized in - -- the "normal" way: Container.Free points to the head of the list of - -- free (inactive) nodes, and the value 0 means the free list is - -- empty. Each node on the free list has been initialized to point to - -- the next free node (via its Next component), and the value 0 means - -- that this is the last node of the free list. - - -- If Container.Free is negative, then the links on the free store have - -- not been initialized. In this case the link values are implied: the - -- free store comprises the components of the node array started with - -- the absolute value of Container.Free, and continuing until the end of - -- the array (Nodes'Last). - - -- We prefer to lazy-init the free store (in fact, we would prefer to - -- not initialize it at all, because such initialization is an O(n) - -- operation). The time when we need to actually initialize the nodes in - -- the free store is when the node that becomes inactive is not at the - -- end of the active list. The free store would then be discontigous and - -- so its nodes would need to be linked in the traditional way. - - -- It might be possible to perform an optimization here. Suppose that - -- the free store can be represented as having two parts: one comprising - -- the non-contiguous inactive nodes linked together in the normal way, - -- and the other comprising the contiguous inactive nodes (that are not - -- linked together, at the end of the nodes array). This would allow us - -- to never have to initialize the free store, except in a lazy way as - -- nodes become inactive. ??? - - -- When an element is deleted from the list container, its node becomes - -- inactive, and so we set its Parent and Prev components to an - -- impossible value (the index of the node itself), to indicate that it - -- is now inactive. This provides a useful way to detect a dangling - -- cursor reference. - - N.Parent := X; -- Node is deallocated (not on active list) - N.Prev := X; - - if Container.Free >= 0 then - -- The free store has previously been initialized. All we need to do - -- here is link the newly-free'd node onto the free list. - - N.Next := Container.Free; - Container.Free := X; - - elsif X + 1 = abs Container.Free then - -- The free store has not been initialized, and the node becoming - -- inactive immediately precedes the start of the free store. All - -- we need to do is move the start of the free store back by one. - - N.Next := X; -- Not strictly necessary, but marginally safer - Container.Free := Container.Free + 1; - - else - -- The free store has not been initialized, and the node becoming - -- inactive does not immediately precede the free store. Here we - -- first initialize the free store (meaning the links are given - -- values in the traditional way), and then link the newly-free'd - -- node onto the head of the free store. - - -- See the comments above for an optimization opportunity. If the - -- next link for a node on the free store is negative, then this - -- means the remaining nodes on the free store are physically - -- contiguous, starting at the absolute value of that index value. - -- ??? - - Container.Free := abs Container.Free; - - if Container.Free > Container.Capacity then - Container.Free := 0; - - else - for J in Container.Free .. Container.Capacity - 1 loop - NN (J).Next := J + 1; - end loop; - - NN (Container.Capacity).Next := 0; - end if; - - NN (X).Next := Container.Free; - Container.Free := X; - end if; - end Deallocate_Node; - - ------------------------ - -- Deallocate_Subtree -- - ------------------------ - - procedure Deallocate_Subtree - (Container : in out Tree; - Subtree : Count_Type; - Count : in out Count_Type) - is - begin - Deallocate_Children (Container, Subtree, Count); - Deallocate_Node (Container, Subtree); - Count := Count + 1; - end Deallocate_Subtree; - - --------------------- - -- Delete_Children -- - --------------------- - - procedure Delete_Children - (Container : in out Tree; - Parent : Cursor) - is - Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return; - end if; - - -- Deallocate_Children returns a count of the number of nodes that it - -- deallocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Deallocate_Children. - - Count := 0; - - Deallocate_Children (Container, Parent.Node, Count); - pragma Assert (Count <= Container.Count); - - Container.Count := Container.Count - Count; - end Delete_Children; - - ----------------- - -- Delete_Leaf -- - ----------------- - - procedure Delete_Leaf - (Container : in out Tree; - Position : in out Cursor) - is - X : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Checks and then not Is_Leaf (Position) then - raise Constraint_Error with "Position cursor does not designate leaf"; - end if; - - TC_Check (Container.TC); - - X := Position.Node; - Position := No_Element; - - Remove_Subtree (Container, X); - Container.Count := Container.Count - 1; - - Deallocate_Node (Container, X); - end Delete_Leaf; - - -------------------- - -- Delete_Subtree -- - -------------------- - - procedure Delete_Subtree - (Container : in out Tree; - Position : in out Cursor) - is - X : Count_Type; - Count : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - TC_Check (Container.TC); - - X := Position.Node; - Position := No_Element; - - Remove_Subtree (Container, X); - - -- Deallocate_Subtree returns a count of the number of nodes that it - -- deallocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Deallocate_Subtree. - - Count := 0; - - Deallocate_Subtree (Container, X, Count); - pragma Assert (Count <= Container.Count); - - Container.Count := Container.Count - Count; - end Delete_Subtree; - - ----------- - -- Depth -- - ----------- - - function Depth (Position : Cursor) return Count_Type is - Result : Count_Type; - N : Count_Type'Base; - - begin - if Position = No_Element then - return 0; - end if; - - if Is_Root (Position) then - return 1; - end if; - - Result := 0; - N := Position.Node; - while N >= 0 loop - N := Position.Container.Nodes (N).Parent; - Result := Result + 1; - end loop; - - return Result; - end Depth; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Node = Root_Node (Position.Container.all) - then - raise Program_Error with "Position cursor designates root"; - end if; - - return Position.Container.Elements (Position.Node); - end Element; - - -------------------- - -- Equal_Children -- - -------------------- - - function Equal_Children - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean - is - L_NN : Tree_Node_Array renames Left_Tree.Nodes; - R_NN : Tree_Node_Array renames Right_Tree.Nodes; - - Left_Children : Children_Type renames L_NN (Left_Subtree).Children; - Right_Children : Children_Type renames R_NN (Right_Subtree).Children; - - L, R : Count_Type'Base; - - begin - if Child_Count (Left_Tree, Left_Subtree) - /= Child_Count (Right_Tree, Right_Subtree) - then - return False; - end if; - - L := Left_Children.First; - R := Right_Children.First; - while L > 0 loop - if not Equal_Subtree (Left_Tree, L, Right_Tree, R) then - return False; - end if; - - L := L_NN (L).Next; - R := R_NN (R).Next; - end loop; - - return True; - end Equal_Children; - - ------------------- - -- Equal_Subtree -- - ------------------- - - function Equal_Subtree - (Left_Position : Cursor; - Right_Position : Cursor) return Boolean - is - begin - if Checks and then Left_Position = No_Element then - raise Constraint_Error with "Left cursor has no element"; - end if; - - if Checks and then Right_Position = No_Element then - raise Constraint_Error with "Right cursor has no element"; - end if; - - if Left_Position = Right_Position then - return True; - end if; - - if Is_Root (Left_Position) then - if not Is_Root (Right_Position) then - return False; - end if; - - if Left_Position.Container.Count = 0 then - return Right_Position.Container.Count = 0; - end if; - - if Right_Position.Container.Count = 0 then - return False; - end if; - - return Equal_Children - (Left_Tree => Left_Position.Container.all, - Left_Subtree => Left_Position.Node, - Right_Tree => Right_Position.Container.all, - Right_Subtree => Right_Position.Node); - end if; - - if Is_Root (Right_Position) then - return False; - end if; - - return Equal_Subtree - (Left_Tree => Left_Position.Container.all, - Left_Subtree => Left_Position.Node, - Right_Tree => Right_Position.Container.all, - Right_Subtree => Right_Position.Node); - end Equal_Subtree; - - function Equal_Subtree - (Left_Tree : Tree; - Left_Subtree : Count_Type; - Right_Tree : Tree; - Right_Subtree : Count_Type) return Boolean - is - begin - if Left_Tree.Elements (Left_Subtree) /= - Right_Tree.Elements (Right_Subtree) - then - return False; - end if; - - return Equal_Children - (Left_Tree => Left_Tree, - Left_Subtree => Left_Subtree, - Right_Tree => Right_Tree, - Right_Subtree => Right_Subtree); - end Equal_Subtree; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Root_Iterator) is - begin - Unbusy (Object.Container.TC); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Tree; - Item : Element_Type) return Cursor - is - Node : Count_Type; - - begin - if Container.Count = 0 then - return No_Element; - end if; - - Node := Find_In_Children (Container, Root_Node (Container), Item); - - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Find; - - ----------- - -- First -- - ----------- - - overriding function First (Object : Subtree_Iterator) return Cursor is - begin - if Object.Subtree = Root_Node (Object.Container.all) then - return First_Child (Root (Object.Container.all)); - else - return Cursor'(Object.Container, Object.Subtree); - end if; - end First; - - overriding function First (Object : Child_Iterator) return Cursor is - begin - return First_Child (Cursor'(Object.Container, Object.Subtree)); - end First; - - ----------------- - -- First_Child -- - ----------------- - - function First_Child (Parent : Cursor) return Cursor is - Node : Count_Type'Base; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return No_Element; - end if; - - Node := Parent.Container.Nodes (Parent.Node).Children.First; - - if Node <= 0 then - return No_Element; - end if; - - return Cursor'(Parent.Container, Node); - end First_Child; - - ------------------------- - -- First_Child_Element -- - ------------------------- - - function First_Child_Element (Parent : Cursor) return Element_Type is - begin - return Element (First_Child (Parent)); - end First_Child_Element; - - ---------------------- - -- Find_In_Children -- - ---------------------- - - function Find_In_Children - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type - is - N : Count_Type'Base; - Result : Count_Type; - - begin - N := Container.Nodes (Subtree).Children.First; - while N > 0 loop - Result := Find_In_Subtree (Container, N, Item); - - if Result > 0 then - return Result; - end if; - - N := Container.Nodes (N).Next; - end loop; - - return 0; - end Find_In_Children; - - --------------------- - -- Find_In_Subtree -- - --------------------- - - function Find_In_Subtree - (Position : Cursor; - Item : Element_Type) return Cursor - is - Result : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Commented-out pending ruling by ARG. ??? - - -- if Checks and then - -- Position.Container /= Container'Unrestricted_Access - -- then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - if Is_Root (Position) then - Result := Find_In_Children - (Container => Position.Container.all, - Subtree => Position.Node, - Item => Item); - - else - Result := Find_In_Subtree - (Container => Position.Container.all, - Subtree => Position.Node, - Item => Item); - end if; - - if Result = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Result); - end Find_In_Subtree; - - function Find_In_Subtree - (Container : Tree; - Subtree : Count_Type; - Item : Element_Type) return Count_Type - is - begin - if Container.Elements (Subtree) = Item then - return Subtree; - end if; - - return Find_In_Children (Container, Subtree, Item); - end Find_In_Subtree; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Elements (Position.Node)'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - if Position = No_Element then - return False; - end if; - - return Position.Node /= Root_Node (Position.Container.all); - end Has_Element; - - --------------------- - -- Initialize_Node -- - --------------------- - - procedure Initialize_Node - (Container : in out Tree; - Index : Count_Type) - is - begin - Container.Nodes (Index) := - (Parent => No_Node, - Prev => 0, - Next => 0, - Children => (others => 0)); - end Initialize_Node; - - --------------------- - -- Initialize_Root -- - --------------------- - - procedure Initialize_Root (Container : in out Tree) is - begin - Initialize_Node (Container, Root_Node (Container)); - end Initialize_Root; - - ------------------ - -- Insert_Child -- - ------------------ - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Position : Cursor; - pragma Unreferenced (Position); - - begin - Insert_Child (Container, Parent, Before, New_Item, Position, Count); - end Insert_Child; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - Nodes : Tree_Node_Array renames Container.Nodes; - First : Count_Type; - Last : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then - Before.Container.Nodes (Before.Node).Parent /= Parent.Node - then - raise Constraint_Error with "Parent cursor not parent of Before"; - end if; - end if; - - if Count = 0 then - Position := No_Element; -- Need ruling from ARG ??? - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => Before.Node); - - Container.Count := Container.Count + Count; - - Position := Cursor'(Parent.Container, First); - end Insert_Child; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Nodes : Tree_Node_Array renames Container.Nodes; - First : Count_Type; - Last : Count_Type; - - New_Item : Element_Type; - pragma Unmodified (New_Item); - -- OK to reference, see below - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then - Before.Container.Nodes (Before.Node).Parent /= Parent.Node - then - raise Constraint_Error with "Parent cursor not parent of Before"; - end if; - end if; - - if Count = 0 then - Position := No_Element; -- Need ruling from ARG ??? - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - -- There is no explicit element provided, but in an instance the element - -- type may be a scalar with a Default_Value aspect, or a composite - -- type with such a scalar component, or components with default - -- initialization, so insert the specified number of possibly - -- initialized elements at the given position. - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => Before.Node); - - Container.Count := Container.Count + Count; - - Position := Cursor'(Parent.Container, First); - end Insert_Child; - - ------------------------- - -- Insert_Subtree_List -- - ------------------------- - - procedure Insert_Subtree_List - (Container : in out Tree; - First : Count_Type'Base; - Last : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base) - is - NN : Tree_Node_Array renames Container.Nodes; - N : Tree_Node_Type renames NN (Parent); - CC : Children_Type renames N.Children; - - begin - -- This is a simple utility operation to insert a list of nodes - -- (First..Last) as children of Parent. The Before node specifies where - -- the new children should be inserted relative to existing children. - - if First <= 0 then - pragma Assert (Last <= 0); - return; - end if; - - pragma Assert (Last > 0); - pragma Assert (Before <= 0 or else NN (Before).Parent = Parent); - - if CC.First <= 0 then -- no existing children - CC.First := First; - NN (CC.First).Prev := 0; - CC.Last := Last; - NN (CC.Last).Next := 0; - - elsif Before <= 0 then -- means "insert after existing nodes" - NN (CC.Last).Next := First; - NN (First).Prev := CC.Last; - CC.Last := Last; - NN (CC.Last).Next := 0; - - elsif Before = CC.First then - NN (Last).Next := CC.First; - NN (CC.First).Prev := Last; - CC.First := First; - NN (CC.First).Prev := 0; - - else - NN (NN (Before).Prev).Next := First; - NN (First).Prev := NN (Before).Prev; - NN (Last).Next := Before; - NN (Before).Prev := Last; - end if; - end Insert_Subtree_List; - - ------------------------- - -- Insert_Subtree_Node -- - ------------------------- - - procedure Insert_Subtree_Node - (Container : in out Tree; - Subtree : Count_Type'Base; - Parent : Count_Type; - Before : Count_Type'Base) - is - begin - -- This is a simple wrapper operation to insert a single child into the - -- Parent's children list. - - Insert_Subtree_List - (Container => Container, - First => Subtree, - Last => Subtree, - Parent => Parent, - Before => Before); - end Insert_Subtree_Node; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Tree) return Boolean is - begin - return Container.Count = 0; - end Is_Empty; - - ------------- - -- Is_Leaf -- - ------------- - - function Is_Leaf (Position : Cursor) return Boolean is - begin - if Position = No_Element then - return False; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return True; - end if; - - return Position.Container.Nodes (Position.Node).Children.First <= 0; - end Is_Leaf; - - ------------------ - -- Is_Reachable -- - ------------------ - - function Is_Reachable - (Container : Tree; - From, To : Count_Type) return Boolean - is - Idx : Count_Type; - - begin - Idx := From; - while Idx >= 0 loop - if Idx = To then - return True; - end if; - - Idx := Container.Nodes (Idx).Parent; - end loop; - - return False; - end Is_Reachable; - - ------------- - -- Is_Root -- - ------------- - - function Is_Root (Position : Cursor) return Boolean is - begin - return - (if Position.Container = null then False - else Position.Node = Root_Node (Position.Container.all)); - end Is_Root; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Tree; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - if Container.Count = 0 then - return; - end if; - - Iterate_Children - (Container => Container, - Subtree => Root_Node (Container), - Process => Process); - end Iterate; - - function Iterate (Container : Tree) - return Tree_Iterator_Interfaces.Forward_Iterator'Class - is - begin - return Iterate_Subtree (Root (Container)); - end Iterate; - - ---------------------- - -- Iterate_Children -- - ---------------------- - - procedure Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)) - is - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return; - end if; - - declare - C : Count_Type; - NN : Tree_Node_Array renames Parent.Container.Nodes; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - - begin - C := NN (Parent.Node).Children.First; - while C > 0 loop - Process (Cursor'(Parent.Container, Node => C)); - C := NN (C).Next; - end loop; - end; - end Iterate_Children; - - procedure Iterate_Children - (Container : Tree; - Subtree : Count_Type; - Process : not null access procedure (Position : Cursor)) - is - NN : Tree_Node_Array renames Container.Nodes; - N : Tree_Node_Type renames NN (Subtree); - C : Count_Type; - - begin - -- This is a helper function to recursively iterate over all the nodes - -- in a subtree, in depth-first fashion. This particular helper just - -- visits the children of this subtree, not the root of the subtree - -- itself. This is useful when starting from the ultimate root of the - -- entire tree (see Iterate), as that root does not have an element. - - C := N.Children.First; - while C > 0 loop - Iterate_Subtree (Container, C, Process); - C := NN (C).Next; - end loop; - end Iterate_Children; - - function Iterate_Children - (Container : Tree; - Parent : Cursor) - return Tree_Iterator_Interfaces.Reversible_Iterator'Class - is - C : constant Tree_Access := Container'Unrestricted_Access; - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= C then - raise Program_Error with "Parent cursor not in container"; - end if; - - return It : constant Child_Iterator := - Child_Iterator'(Limited_Controlled with - Container => C, - Subtree => Parent.Node) - do - Busy (C.TC); - end return; - end Iterate_Children; - - --------------------- - -- Iterate_Subtree -- - --------------------- - - function Iterate_Subtree - (Position : Cursor) - return Tree_Iterator_Interfaces.Forward_Iterator'Class - is - C : constant Tree_Access := Position.Container; - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Implement Vet for multiway trees??? - -- pragma Assert (Vet (Position), "bad subtree cursor"); - - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => C, - Subtree => Position.Node) - do - Busy (C.TC); - end return; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Position : Cursor; - Process : not null access procedure (Position : Cursor)) - is - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return; - end if; - - declare - T : Tree renames Position.Container.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - begin - if Is_Root (Position) then - Iterate_Children (T, Position.Node, Process); - else - Iterate_Subtree (T, Position.Node, Process); - end if; - end; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Container : Tree; - Subtree : Count_Type; - Process : not null access procedure (Position : Cursor)) - is - begin - -- This is a helper function to recursively iterate over all the nodes - -- in a subtree, in depth-first fashion. It first visits the root of the - -- subtree, then visits its children. - - Process (Cursor'(Container'Unrestricted_Access, Subtree)); - Iterate_Children (Container, Subtree, Process); - end Iterate_Subtree; - - ---------- - -- Last -- - ---------- - - overriding function Last (Object : Child_Iterator) return Cursor is - begin - return Last_Child (Cursor'(Object.Container, Object.Subtree)); - end Last; - - ---------------- - -- Last_Child -- - ---------------- - - function Last_Child (Parent : Cursor) return Cursor is - Node : Count_Type'Base; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return No_Element; - end if; - - Node := Parent.Container.Nodes (Parent.Node).Children.Last; - - if Node <= 0 then - return No_Element; - end if; - - return Cursor'(Parent.Container, Node); - end Last_Child; - - ------------------------ - -- Last_Child_Element -- - ------------------------ - - function Last_Child_Element (Parent : Cursor) return Element_Type is - begin - return Element (Last_Child (Parent)); - end Last_Child_Element; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Tree; Source : in out Tree) is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Assign (Source); - Source.Clear; - end Move; - - ---------- - -- Next -- - ---------- - - overriding function Next - (Object : Subtree_Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong tree"; - end if; - - pragma Assert (Object.Container.Count > 0); - pragma Assert (Position.Node /= Root_Node (Object.Container.all)); - - declare - Nodes : Tree_Node_Array renames Object.Container.Nodes; - Node : Count_Type; - - begin - Node := Position.Node; - - if Nodes (Node).Children.First > 0 then - return Cursor'(Object.Container, Nodes (Node).Children.First); - end if; - - while Node /= Object.Subtree loop - if Nodes (Node).Next > 0 then - return Cursor'(Object.Container, Nodes (Node).Next); - end if; - - Node := Nodes (Node).Parent; - end loop; - - return No_Element; - end; - end Next; - - overriding function Next - (Object : Child_Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong tree"; - end if; - - pragma Assert (Object.Container.Count > 0); - pragma Assert (Position.Node /= Root_Node (Object.Container.all)); - - return Next_Sibling (Position); - end Next; - - ------------------ - -- Next_Sibling -- - ------------------ - - function Next_Sibling (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - declare - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - - begin - if N.Next <= 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, N.Next); - end; - end Next_Sibling; - - procedure Next_Sibling (Position : in out Cursor) is - begin - Position := Next_Sibling (Position); - end Next_Sibling; - - ---------------- - -- Node_Count -- - ---------------- - - function Node_Count (Container : Tree) return Count_Type is - begin - -- Container.Count is the number of nodes we have actually allocated. We - -- cache the value specifically so this Node_Count operation can execute - -- in O(1) time, which makes it behave similarly to how the Length - -- selector function behaves for other containers. - -- - -- The cached node count value only describes the nodes we have - -- allocated; the root node itself is not included in that count. The - -- Node_Count operation returns a value that includes the root node - -- (because the RM says so), so we must add 1 to our cached value. - - return 1 + Container.Count; - end Node_Count; - - ------------ - -- Parent -- - ------------ - - function Parent (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - declare - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - - begin - if N.Parent < 0 then - pragma Assert (Position.Node = Root_Node (T)); - return No_Element; - end if; - - return Cursor'(Position.Container, N.Parent); - end; - end Parent; - - ------------------- - -- Prepend_Child -- - ------------------- - - procedure Prepend_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Nodes : Tree_Node_Array renames Container.Nodes; - First, Last : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Count = 0 then - return; - end if; - - if Checks and then Container.Count > Container.Capacity - Count then - raise Capacity_Error - with "requested count exceeds available storage"; - end if; - - TC_Check (Container.TC); - - if Container.Count = 0 then - Initialize_Root (Container); - end if; - - Allocate_Node (Container, New_Item, First); - Nodes (First).Parent := Parent.Node; - - Last := First; - for J in Count_Type'(2) .. Count loop - Allocate_Node (Container, New_Item, Nodes (Last).Next); - Nodes (Nodes (Last).Next).Parent := Parent.Node; - Nodes (Nodes (Last).Next).Prev := Last; - - Last := Nodes (Last).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => First, - Last => Last, - Parent => Parent.Node, - Before => Nodes (Parent.Node).Children.First); - - Container.Count := Container.Count + Count; - end Prepend_Child; - - -------------- - -- Previous -- - -------------- - - overriding function Previous - (Object : Child_Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong tree"; - end if; - - return Previous_Sibling (Position); - end Previous; - - ---------------------- - -- Previous_Sibling -- - ---------------------- - - function Previous_Sibling (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return No_Element; - end if; - - declare - T : Tree renames Position.Container.all; - NN : Tree_Node_Array renames T.Nodes; - N : Tree_Node_Type renames NN (Position.Node); - - begin - if N.Prev <= 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, N.Prev); - end; - end Previous_Sibling; - - procedure Previous_Sibling (Position : in out Cursor) is - begin - Position := Previous_Sibling (Position); - end Previous_Sibling; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Tree'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Element => T.Elements (Position.Node)); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Tree) - is - procedure Read_Children (Subtree : Count_Type); - - function Read_Subtree - (Parent : Count_Type) return Count_Type; - - NN : Tree_Node_Array renames Container.Nodes; - - Total_Count : Count_Type'Base; - -- Value read from the stream that says how many elements follow - - Read_Count : Count_Type'Base; - -- Actual number of elements read from the stream - - ------------------- - -- Read_Children -- - ------------------- - - procedure Read_Children (Subtree : Count_Type) is - Count : Count_Type'Base; - -- number of child subtrees - - CC : Children_Type; - - begin - Count_Type'Read (Stream, Count); - - if Checks and then Count < 0 then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - if Count = 0 then - return; - end if; - - CC.First := Read_Subtree (Parent => Subtree); - CC.Last := CC.First; - - for J in Count_Type'(2) .. Count loop - NN (CC.Last).Next := Read_Subtree (Parent => Subtree); - NN (NN (CC.Last).Next).Prev := CC.Last; - CC.Last := NN (CC.Last).Next; - end loop; - - -- Now that the allocation and reads have completed successfully, it - -- is safe to link the children to their parent. - - NN (Subtree).Children := CC; - end Read_Children; - - ------------------ - -- Read_Subtree -- - ------------------ - - function Read_Subtree - (Parent : Count_Type) return Count_Type - is - Subtree : Count_Type; - - begin - Allocate_Node (Container, Stream, Subtree); - Container.Nodes (Subtree).Parent := Parent; - - Read_Count := Read_Count + 1; - - Read_Children (Subtree); - - return Subtree; - end Read_Subtree; - - -- Start of processing for Read - - begin - Container.Clear; -- checks busy bit - - Count_Type'Read (Stream, Total_Count); - - if Checks and then Total_Count < 0 then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - if Total_Count = 0 then - return; - end if; - - if Checks and then Total_Count > Container.Capacity then - raise Capacity_Error -- ??? - with "node count in stream exceeds container capacity"; - end if; - - Initialize_Root (Container); - - Read_Count := 0; - - Read_Children (Root_Node (Container)); - - if Checks and then Read_Count /= Total_Count then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - Container.Count := Total_Count; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to read tree cursor from stream"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Tree; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Container.Elements (Position.Node)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - -------------------- - -- Remove_Subtree -- - -------------------- - - procedure Remove_Subtree - (Container : in out Tree; - Subtree : Count_Type) - is - NN : Tree_Node_Array renames Container.Nodes; - N : Tree_Node_Type renames NN (Subtree); - CC : Children_Type renames NN (N.Parent).Children; - - begin - -- This is a utility operation to remove a subtree node from its - -- parent's list of children. - - if CC.First = Subtree then - pragma Assert (N.Prev <= 0); - - if CC.Last = Subtree then - pragma Assert (N.Next <= 0); - CC.First := 0; - CC.Last := 0; - - else - CC.First := N.Next; - NN (CC.First).Prev := 0; - end if; - - elsif CC.Last = Subtree then - pragma Assert (N.Next <= 0); - CC.Last := N.Prev; - NN (CC.Last).Next := 0; - - else - NN (N.Prev).Next := N.Next; - NN (N.Next).Prev := N.Prev; - end if; - end Remove_Subtree; - - ---------------------- - -- Replace_Element -- - ---------------------- - - procedure Replace_Element - (Container : in out Tree; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - TE_Check (Container.TC); - - Container.Elements (Position.Node) := New_Item; - end Replace_Element; - - ------------------------------ - -- Reverse_Iterate_Children -- - ------------------------------ - - procedure Reverse_Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)) - is - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Parent.Container.Count = 0 then - pragma Assert (Is_Root (Parent)); - return; - end if; - - declare - NN : Tree_Node_Array renames Parent.Container.Nodes; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - C : Count_Type; - - begin - C := NN (Parent.Node).Children.Last; - while C > 0 loop - Process (Cursor'(Parent.Container, Node => C)); - C := NN (C).Prev; - end loop; - end; - end Reverse_Iterate_Children; - - ---------- - -- Root -- - ---------- - - function Root (Container : Tree) return Cursor is - begin - return (Container'Unrestricted_Access, Root_Node (Container)); - end Root; - - --------------- - -- Root_Node -- - --------------- - - function Root_Node (Container : Tree) return Count_Type is - pragma Unreferenced (Container); - - begin - return 0; - end Root_Node; - - --------------------- - -- Splice_Children -- - --------------------- - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Source_Parent : Cursor) - is - begin - if Checks and then Target_Parent = No_Element then - raise Constraint_Error with "Target_Parent cursor has no element"; - end if; - - if Checks and then Target_Parent.Container /= Target'Unrestricted_Access - then - raise Program_Error - with "Target_Parent cursor not in Target container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error - with "Before cursor not in Target container"; - end if; - - if Checks and then - Target.Nodes (Before.Node).Parent /= Target_Parent.Node - then - raise Constraint_Error - with "Before cursor not child of Target_Parent"; - end if; - end if; - - if Checks and then Source_Parent = No_Element then - raise Constraint_Error with "Source_Parent cursor has no element"; - end if; - - if Checks and then Source_Parent.Container /= Source'Unrestricted_Access - then - raise Program_Error - with "Source_Parent cursor not in Source container"; - end if; - - if Source.Count = 0 then - pragma Assert (Is_Root (Source_Parent)); - return; - end if; - - if Target'Address = Source'Address then - if Target_Parent = Source_Parent then - return; - end if; - - TC_Check (Target.TC); - - if Checks and then Is_Reachable (Container => Target, - From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Container => Target, - Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - if Target.Count = 0 then - Initialize_Root (Target); - end if; - - Splice_Children - (Target => Target, - Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source => Source, - Source_Parent => Source_Parent.Node); - end Splice_Children; - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source_Parent : Cursor) - is - begin - if Checks and then Target_Parent = No_Element then - raise Constraint_Error with "Target_Parent cursor has no element"; - end if; - - if Checks and then - Target_Parent.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Target_Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Before cursor not in container"; - end if; - - if Checks and then - Container.Nodes (Before.Node).Parent /= Target_Parent.Node - then - raise Constraint_Error - with "Before cursor not child of Target_Parent"; - end if; - end if; - - if Checks and then Source_Parent = No_Element then - raise Constraint_Error with "Source_Parent cursor has no element"; - end if; - - if Checks and then - Source_Parent.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Source_Parent cursor not in container"; - end if; - - if Target_Parent = Source_Parent then - return; - end if; - - pragma Assert (Container.Count > 0); - - TC_Check (Container.TC); - - if Checks and then Is_Reachable (Container => Container, - From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Container => Container, - Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - end Splice_Children; - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source_Parent : Count_Type) - is - NN : Tree_Node_Array renames Container.Nodes; - CC : constant Children_Type := NN (Source_Parent).Children; - C : Count_Type'Base; - - begin - -- This is a utility operation to remove the children from Source parent - -- and insert them into Target parent. - - NN (Source_Parent).Children := Children_Type'(others => 0); - - -- Fix up the Parent pointers of each child to designate its new Target - -- parent. - - C := CC.First; - while C > 0 loop - NN (C).Parent := Target_Parent; - C := NN (C).Next; - end loop; - - Insert_Subtree_List - (Container => Container, - First => CC.First, - Last => CC.Last, - Parent => Target_Parent, - Before => Before); - end Splice_Children; - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Source_Parent : Count_Type) - is - S_NN : Tree_Node_Array renames Source.Nodes; - S_CC : Children_Type renames S_NN (Source_Parent).Children; - - Target_Count, Source_Count : Count_Type; - T, S : Count_Type'Base; - - begin - -- This is a utility operation to copy the children from the Source - -- parent and insert them as children of the Target parent, and then - -- delete them from the Source. (This is not a true splice operation, - -- but it is the best we can do in a bounded form.) The Before position - -- specifies where among the Target parent's exising children the new - -- children are inserted. - - -- Before we attempt the insertion, we must count the sources nodes in - -- order to determine whether the target have enough storage - -- available. Note that calculating this value is an O(n) operation. - - -- Here is an optimization opportunity: iterate of each children the - -- source explicitly, and keep a running count of the total number of - -- nodes. Compare the running total to the capacity of the target each - -- pass through the loop. This is more efficient than summing the counts - -- of child subtree (which is what Subtree_Node_Count does) and then - -- comparing that total sum to the target's capacity. ??? - - -- Here is another possibility. We currently treat the splice as an - -- all-or-nothing proposition: either we can insert all of children of - -- the source, or we raise exception with modifying the target. The - -- price for not causing side-effect is an O(n) determination of the - -- source count. If we are willing to tolerate side-effect, then we - -- could loop over the children of the source, counting that subtree and - -- then immediately inserting it in the target. The issue here is that - -- the test for available storage could fail during some later pass, - -- after children have already been inserted into target. ??? - - Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1; - - if Source_Count = 0 then - return; - end if; - - if Checks and then Target.Count > Target.Capacity - Source_Count then - raise Capacity_Error -- ??? - with "Source count exceeds available storage on Target"; - end if; - - -- Copy_Subtree returns a count of the number of nodes it inserts, but - -- it does this by incrementing the value passed in. Therefore we must - -- initialize the count before calling Copy_Subtree. - - Target_Count := 0; - - S := S_CC.First; - while S > 0 loop - Copy_Subtree - (Source => Source, - Source_Subtree => S, - Target => Target, - Target_Parent => Target_Parent, - Target_Subtree => T, - Count => Target_Count); - - Insert_Subtree_Node - (Container => Target, - Subtree => T, - Parent => Target_Parent, - Before => Before); - - S := S_NN (S).Next; - end loop; - - pragma Assert (Target_Count = Source_Count); - Target.Count := Target.Count + Target_Count; - - -- As with Copy_Subtree, operation Deallocate_Children returns a count - -- of the number of nodes it deallocates, but it works by incrementing - -- the value passed in. We must therefore initialize the count before - -- calling it. - - Source_Count := 0; - - Deallocate_Children (Source, Source_Parent, Source_Count); - pragma Assert (Source_Count = Target_Count); - - Source.Count := Source.Count - Source_Count; - end Splice_Children; - - -------------------- - -- Splice_Subtree -- - -------------------- - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Position : in out Cursor) - is - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Target'Unrestricted_Access then - raise Program_Error with "Parent cursor not in Target container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with "Before cursor not in Target container"; - end if; - - if Checks and then Target.Nodes (Before.Node).Parent /= Parent.Node - then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Source'Unrestricted_Access then - raise Program_Error with "Position cursor not in Source container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Target'Address = Source'Address then - if Target.Nodes (Position.Node).Parent = Parent.Node then - if Before = No_Element then - if Target.Nodes (Position.Node).Next <= 0 then -- last child - return; - end if; - - elsif Position.Node = Before.Node then - return; - - elsif Target.Nodes (Position.Node).Next = Before.Node then - return; - end if; - end if; - - TC_Check (Target.TC); - - if Checks and then Is_Reachable (Container => Target, - From => Parent.Node, - To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Target, Position.Node); - - Target.Nodes (Position.Node).Parent := Parent.Node; - Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - if Target.Count = 0 then - Initialize_Root (Target); - end if; - - Splice_Subtree - (Target => Target, - Parent => Parent.Node, - Before => Before.Node, - Source => Source, - Position => Position.Node); -- modified during call - - Position.Container := Target'Unrestricted_Access; - end Splice_Subtree; - - procedure Splice_Subtree - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : Cursor) - is - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Container.Nodes (Before.Node).Parent /= Parent.Node - then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - - -- Should this be PE instead? Need ARG confirmation. ??? - - raise Constraint_Error with "Position cursor designates root"; - end if; - - if Container.Nodes (Position.Node).Parent = Parent.Node then - if Before = No_Element then - if Container.Nodes (Position.Node).Next <= 0 then -- last child - return; - end if; - - elsif Position.Node = Before.Node then - return; - - elsif Container.Nodes (Position.Node).Next = Before.Node then - return; - end if; - end if; - - TC_Check (Container.TC); - - if Checks and then Is_Reachable (Container => Container, - From => Parent.Node, - To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Container, Position.Node); - Container.Nodes (Position.Node).Parent := Parent.Node; - Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node); - end Splice_Subtree; - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Count_Type; - Before : Count_Type'Base; - Source : in out Tree; - Position : in out Count_Type) -- Source on input, Target on output - is - Source_Count : Count_Type := Subtree_Node_Count (Source, Position); - pragma Assert (Source_Count >= 1); - - Target_Subtree : Count_Type; - Target_Count : Count_Type; - - begin - -- This is a utility operation to do the heavy lifting associated with - -- splicing a subtree from one tree to another. Note that "splicing" - -- is a bit of a misnomer here in the case of a bounded tree, because - -- the elements must be copied from the source to the target. - - if Checks and then Target.Count > Target.Capacity - Source_Count then - raise Capacity_Error -- ??? - with "Source count exceeds available storage on Target"; - end if; - - -- Copy_Subtree returns a count of the number of nodes it inserts, but - -- it does this by incrementing the value passed in. Therefore we must - -- initialize the count before calling Copy_Subtree. - - Target_Count := 0; - - Copy_Subtree - (Source => Source, - Source_Subtree => Position, - Target => Target, - Target_Parent => Parent, - Target_Subtree => Target_Subtree, - Count => Target_Count); - - pragma Assert (Target_Count = Source_Count); - - -- Now link the newly-allocated subtree into the target. - - Insert_Subtree_Node - (Container => Target, - Subtree => Target_Subtree, - Parent => Parent, - Before => Before); - - Target.Count := Target.Count + Target_Count; - - -- The manipulation of the Target container is complete. Now we remove - -- the subtree from the Source container. - - Remove_Subtree (Source, Position); -- unlink the subtree - - -- As with Copy_Subtree, operation Deallocate_Subtree returns a count of - -- the number of nodes it deallocates, but it works by incrementing the - -- value passed in. We must therefore initialize the count before - -- calling it. - - Source_Count := 0; - - Deallocate_Subtree (Source, Position, Source_Count); - pragma Assert (Source_Count = Target_Count); - - Source.Count := Source.Count - Source_Count; - - Position := Target_Subtree; - end Splice_Subtree; - - ------------------------ - -- Subtree_Node_Count -- - ------------------------ - - function Subtree_Node_Count (Position : Cursor) return Count_Type is - begin - if Position = No_Element then - return 0; - end if; - - if Position.Container.Count = 0 then - pragma Assert (Is_Root (Position)); - return 1; - end if; - - return Subtree_Node_Count (Position.Container.all, Position.Node); - end Subtree_Node_Count; - - function Subtree_Node_Count - (Container : Tree; - Subtree : Count_Type) return Count_Type - is - Result : Count_Type; - Node : Count_Type'Base; - - begin - Result := 1; - Node := Container.Nodes (Subtree).Children.First; - while Node > 0 loop - Result := Result + Subtree_Node_Count (Container, Node); - Node := Container.Nodes (Node).Next; - end loop; - return Result; - end Subtree_Node_Count; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Tree; - I, J : Cursor) - is - begin - if Checks and then I = No_Element then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor not in container"; - end if; - - if Checks and then Is_Root (I) then - raise Program_Error with "I cursor designates root"; - end if; - - if I = J then -- make this test sooner??? - return; - end if; - - if Checks and then J = No_Element then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor not in container"; - end if; - - if Checks and then Is_Root (J) then - raise Program_Error with "J cursor designates root"; - end if; - - TE_Check (Container.TC); - - declare - EE : Element_Array renames Container.Elements; - EI : constant Element_Type := EE (I.Node); - - begin - EE (I.Node) := EE (J.Node); - EE (J.Node) := EI; - end; - end Swap; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Tree; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - declare - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Element => T.Elements (Position.Node)); - end; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Tree) - is - procedure Write_Children (Subtree : Count_Type); - procedure Write_Subtree (Subtree : Count_Type); - - -------------------- - -- Write_Children -- - -------------------- - - procedure Write_Children (Subtree : Count_Type) is - CC : Children_Type renames Container.Nodes (Subtree).Children; - C : Count_Type'Base; - - begin - Count_Type'Write (Stream, Child_Count (Container, Subtree)); - - C := CC.First; - while C > 0 loop - Write_Subtree (C); - C := Container.Nodes (C).Next; - end loop; - end Write_Children; - - ------------------- - -- Write_Subtree -- - ------------------- - - procedure Write_Subtree (Subtree : Count_Type) is - begin - Element_Type'Write (Stream, Container.Elements (Subtree)); - Write_Children (Subtree); - end Write_Subtree; - - -- Start of processing for Write - - begin - Count_Type'Write (Stream, Container.Count); - - if Container.Count = 0 then - return; - end if; - - Write_Children (Root_Node (Container)); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to write tree cursor to stream"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Bounded_Multiway_Trees; diff --git a/gcc/ada/a-cbmutr.ads b/gcc/ada/a-cbmutr.ads deleted file mode 100644 index 6600197..0000000 --- a/gcc/ada/a-cbmutr.ads +++ /dev/null @@ -1,406 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2014-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Streams; - -generic - type Element_Type is private; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Bounded_Multiway_Trees is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - pragma Remote_Types; - - type Tree (Capacity : Count_Type) is tagged private - with Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - pragma Preelaborable_Initialization (Tree); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Tree : constant Tree; - - No_Element : constant Cursor; - function Has_Element (Position : Cursor) return Boolean; - - package Tree_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function Equal_Subtree - (Left_Position : Cursor; - Right_Position : Cursor) return Boolean; - - function "=" (Left, Right : Tree) return Boolean; - - function Is_Empty (Container : Tree) return Boolean; - - function Node_Count (Container : Tree) return Count_Type; - - function Subtree_Node_Count (Position : Cursor) return Count_Type; - - function Depth (Position : Cursor) return Count_Type; - - function Is_Root (Position : Cursor) return Boolean; - - function Is_Leaf (Position : Cursor) return Boolean; - - function Root (Container : Tree) return Cursor; - - procedure Clear (Container : in out Tree); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Tree; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Tree; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Tree; - Position : Cursor) return Reference_Type; - - procedure Assign (Target : in out Tree; Source : Tree); - - function Copy (Source : Tree; Capacity : Count_Type := 0) return Tree; - - procedure Move (Target : in out Tree; Source : in out Tree); - - procedure Delete_Leaf - (Container : in out Tree; - Position : in out Cursor); - - procedure Delete_Subtree - (Container : in out Tree; - Position : in out Cursor); - - procedure Swap - (Container : in out Tree; - I, J : Cursor); - - function Find - (Container : Tree; - Item : Element_Type) return Cursor; - - function Find_In_Subtree - (Position : Cursor; - Item : Element_Type) return Cursor; - - function Ancestor_Find - (Position : Cursor; - Item : Element_Type) return Cursor; - - function Contains - (Container : Tree; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : Tree; - Process : not null access procedure (Position : Cursor)); - - procedure Iterate_Subtree - (Position : Cursor; - Process : not null access procedure (Position : Cursor)); - - function Iterate (Container : Tree) - return Tree_Iterator_Interfaces.Forward_Iterator'Class; - - function Iterate_Subtree (Position : Cursor) - return Tree_Iterator_Interfaces.Forward_Iterator'Class; - - function Iterate_Children - (Container : Tree; - Parent : Cursor) - return Tree_Iterator_Interfaces.Reversible_Iterator'Class; - - function Child_Count (Parent : Cursor) return Count_Type; - - function Child_Depth (Parent, Child : Cursor) return Count_Type; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Delete_Children - (Container : in out Tree; - Parent : Cursor); - - procedure Copy_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : Cursor); - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Position : in out Cursor); - - procedure Splice_Subtree - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : Cursor); - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Source_Parent : Cursor); - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source_Parent : Cursor); - - function Parent (Position : Cursor) return Cursor; - - function First_Child (Parent : Cursor) return Cursor; - - function First_Child_Element (Parent : Cursor) return Element_Type; - - function Last_Child (Parent : Cursor) return Cursor; - - function Last_Child_Element (Parent : Cursor) return Element_Type; - - function Next_Sibling (Position : Cursor) return Cursor; - - function Previous_Sibling (Position : Cursor) return Cursor; - - procedure Next_Sibling (Position : in out Cursor); - - procedure Previous_Sibling (Position : in out Cursor); - - procedure Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)); - -private - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - use Ada.Streams; - - No_Node : constant Count_Type'Base := -1; - -- Need to document all global declarations such as this ??? - - -- Following decls also need much more documentation ??? - - type Children_Type is record - First : Count_Type'Base; - Last : Count_Type'Base; - end record; - - type Tree_Node_Type is record - Parent : Count_Type'Base; - Prev : Count_Type'Base; - Next : Count_Type'Base; - Children : Children_Type; - end record; - - type Tree_Node_Array is array (Count_Type range <>) of Tree_Node_Type; - type Element_Array is array (Count_Type range <>) of aliased Element_Type; - - type Tree (Capacity : Count_Type) is tagged record - Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); - Elements : Element_Array (1 .. Capacity) := (others => <>); - Free : Count_Type'Base := No_Node; - TC : aliased Tamper_Counts; - Count : Count_Type := 0; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Tree); - - for Tree'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Tree); - - for Tree'Read use Read; - - type Tree_Access is access all Tree; - for Tree_Access'Storage_Size use 0; - - type Cursor is record - Container : Tree_Access; - Node : Count_Type'Base := No_Node; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - for Constant_Reference_Type'Read use Read; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Tree'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Tree : constant Tree := (Capacity => 0, others => <>); - - No_Element : constant Cursor := Cursor'(others => <>); - -end Ada.Containers.Bounded_Multiway_Trees; diff --git a/gcc/ada/a-cborma.adb b/gcc/ada/a-cborma.adb deleted file mode 100644 index 611e895..0000000 --- a/gcc/ada/a-cborma.adb +++ /dev/null @@ -1,1637 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); - -with System; use type System.Address; - -package body Ada.Containers.Bounded_Ordered_Maps is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------------- - -- Node Access Subprograms -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color (Node : Node_Type) return Color_Type; - pragma Inline (Color); - - function Left (Node : Node_Type) return Count_Type; - pragma Inline (Left); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right (Node : Node_Type) return Count_Type; - pragma Inline (Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Color (Node : in out Node_Type; Color : Color_Type); - pragma Inline (Set_Color); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types); - - use Tree_Operations; - - package Key_Ops is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; - end if; - - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "Left cursor of ""<"" is bad"); - - pragma Assert (Vet (Right.Container.all, Right.Node), - "Right cursor of ""<"" is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - RN : Node_Type renames Right.Container.Nodes (Right.Node); - - begin - return LN.Key < RN.Key; - end; - end "<"; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "Left cursor of ""<"" is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - - begin - return LN.Key < Right; - end; - end "<"; - - function "<" (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.all, Right.Node), - "Right cursor of ""<"" is bad"); - - declare - RN : Node_Type renames Right.Container.Nodes (Right.Node); - - begin - return Left < RN.Key; - end; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - function Is_Equal_Node_Node (L, R : Node_Type) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node - (L, R : Node_Type) return Boolean is - begin - if L.Key < R.Key then - return False; - - elsif R.Key < L.Key then - return False; - - else - return L.Element = R.Element; - end if; - end Is_Equal_Node_Node; - - -- Start of processing for "=" - - begin - return Is_Equal (Left, Right); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor of "">"" equals No_Element"; - end if; - - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor of "">"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "Left cursor of "">"" is bad"); - - pragma Assert (Vet (Right.Container.all, Right.Node), - "Right cursor of "">"" is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - RN : Node_Type renames Right.Container.Nodes (Right.Node); - - begin - return RN.Key < LN.Key; - end; - end ">"; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor of "">"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "Left cursor of "">"" is bad"); - - declare - LN : Node_Type renames Left.Container.Nodes (Left.Node); - begin - return Right < LN.Key; - end; - end ">"; - - function ">" (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor of "">"" equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.all, Right.Node), - "Right cursor of "">"" is bad"); - - declare - RN : Node_Type renames Right.Container.Nodes (Right.Node); - - begin - return RN.Key < Left; - end; - end ">"; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Key_Ops.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Key_Ops.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - - begin - Allocate (Target, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Key := SN.Key; - Node.Element := SN.Element; - end Set_Element; - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target, - Hint => 0, - Key => SN.Key, - Node => Target_Node); - end Append_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error - with "Target capacity is less than Source length"; - end if; - - Tree_Operations.Clear_Tree (Target); - Append_Elements (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - Tree_Operations.Clear_Tree (Container); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor in Constant_Reference is bad"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map is - C : Count_Type; - - begin - if Capacity = 0 then - C := Source.Length; - - elsif Capacity >= Source.Length then - C := Capacity; - - elsif Checks then - raise Capacity_Error with "Capacity value too small"; - end if; - - return Target : Map (Capacity => C) do - Assign (Target => Target, Source => Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Delete equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Delete designates wrong map"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Delete is bad"); - - Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); - Tree_Operations.Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Checks and then X = 0 then - raise Constraint_Error with "key not in map"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Map) is - X : constant Count_Type := Container.First; - - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Map) is - X : constant Count_Type := Container.Last; - - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of function Element equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "Position cursor of function Element is bad"); - - return Position.Container.Nodes (Position.Node).Element; - end Element; - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - return Container.Nodes (Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - begin - if Node = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); - end if; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - begin - if Container.First = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.First); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is 0, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is positive, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = 0 then - return Bounded_Ordered_Maps.First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Map) return Element_Type is - begin - if Checks and then Container.First = 0 then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (Container.First).Element; - end First_Element; - - --------------- - -- First_Key -- - --------------- - - function First_Key (Container : Map) return Key_Type is - begin - if Checks and then Container.First = 0 then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (Container.First).Key; - end First_Key; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Floor (Container, Key); - begin - if Node = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); - end if; - end Floor; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Nodes (Position.Node).Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.TC); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign (Node : in out Node_Type); - pragma Inline (Assign); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Assign); - - ------------ - -- Assign -- - ------------ - - procedure Assign (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Assign; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container, - Key, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with "key already in map"; - end if; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign (Node : in out Node_Type); - pragma Inline (Assign); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Assign); - - ------------ - -- Assign -- - ------------ - - procedure Assign (Node : in out Node_Type) is - New_Item : Element_Type; - pragma Unmodified (New_Item); - -- Default-initialized element (ok to reference, see below) - - begin - Node.Key := Key; - - -- There is no explicit element provided, but in an instance the element - -- type may be a scalar with a Default_Value aspect, or a composite type - -- with such a scalar component or with defaulted components, so insert - -- possibly initialized elements at the given position. - - Node.Element := New_Item; - end Assign; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container, - Key, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - -- Left > Right same as Right < Left - - return Right.Key < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Key; - end Is_Less_Key_Node; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (Container); - end Iterate; - - function Iterate - (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is 0 (as is the case here), this means the iterator object - -- was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => 0) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : Map; - Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- Iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong map"; - end if; - - pragma Assert (Vet (Container, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is positive (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. (Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration.) - - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of function Key equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "Position cursor of function Key is bad"); - - return Position.Container.Nodes (Position.Node).Key; - end Key; - - ---------- - -- Last -- - ---------- - - function Last (Container : Map) return Cursor is - begin - if Container.Last = 0 then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.Last); - end if; - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is 0, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is positive, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = 0 then - return Bounded_Ordered_Maps.Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Map) return Element_Type is - begin - if Checks and then Container.Last = 0 then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (Container.Last).Element; - end Last_Element; - - -------------- - -- Last_Key -- - -------------- - - function Last_Key (Container : Map) return Key_Type is - begin - if Checks and then Container.Last = 0 then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (Container.Last).Key; - end Last_Key; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Map; Source : in out Map) is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Assign (Source); - Source.Clear; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "Position cursor of Next is bad"); - - declare - M : Map renames Position.Container.all; - - Node : constant Count_Type := - Tree_Operations.Next (M, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong map"; - end if; - - return Next (Position); - end Next; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "Position cursor of Previous is bad"); - - declare - M : Map renames Position.Container.all; - - Node : constant Count_Type := - Tree_Operations.Previous (M, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Previous; - - function Previous - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong map"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "Position cursor of Query_Element is bad"); - - declare - M : Map renames Position.Container.all; - N : Node_Type renames M.Nodes (Position.Node); - Lock : With_Lock (M.TC'Unrestricted_Access); - begin - Process (N.Key, N.Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Read_Element); - - procedure Read_Elements is - new Tree_Operations.Generic_Read (Allocate); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Key_Type'Read (Stream, Node.Key); - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - -- Start of processing for Read - - begin - Read_Elements (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor in function Reference is bad"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type - is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - TE_Check (Container.TC); - - declare - N : Node_Type renames Container.Nodes (Node); - - begin - N.Key := Key; - N.Element := New_Item; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Replace_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Replace_Element designates wrong map"; - end if; - - TE_Check (Container.TC); - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Replace_Element is bad"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (Container); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color - (Node : in out Node_Type; - Color : Color_Type) - is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor of Update_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Update_Element designates wrong map"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Update_Element is bad"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - Process (N.Key, N.Element); - end; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Node); - - procedure Write_Nodes is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write_Nodes (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/a-cborma.ads b/gcc/ada/a-cborma.ads deleted file mode 100644 index 7aa6e6c..0000000 --- a/gcc/ada/a-cborma.ads +++ /dev/null @@ -1,376 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Red_Black_Trees; -private with Ada.Streams; -private with Ada.Finalization; - -generic - type Key_Type is private; - type Element_Type is private; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Bounded_Ordered_Maps is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - pragma Remote_Types; - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - type Map (Capacity : Count_Type) is tagged private with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Map); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Map : constant Map; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package Map_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Map) return Boolean; - - function Length (Container : Map) return Count_Type; - - function Is_Empty (Container : Map) return Boolean; - - procedure Clear (Container : in out Map); - - function Key (Position : Cursor) return Key_Type; - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type; - - procedure Assign (Target : in out Map; Source : Map); - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map; - - procedure Move (Target : in out Map; Source : in out Map); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Exclude (Container : in out Map; Key : Key_Type); - - procedure Delete (Container : in out Map; Key : Key_Type); - - procedure Delete (Container : in out Map; Position : in out Cursor); - - procedure Delete_First (Container : in out Map); - - procedure Delete_Last (Container : in out Map); - - function First (Container : Map) return Cursor; - - function First_Element (Container : Map) return Element_Type; - - function First_Key (Container : Map) return Key_Type; - - function Last (Container : Map) return Cursor; - - function Last_Element (Container : Map) return Element_Type; - - function Last_Key (Container : Map) return Key_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find (Container : Map; Key : Key_Type) return Cursor; - - function Element (Container : Map; Key : Key_Type) return Element_Type; - - function Floor (Container : Map; Key : Key_Type) return Cursor; - - function Ceiling (Container : Map; Key : Key_Type) return Cursor; - - function Contains (Container : Map; Key : Key_Type) return Boolean; - - function "<" (Left, Right : Cursor) return Boolean; - - function ">" (Left, Right : Cursor) return Boolean; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean; - - function "<" (Left : Key_Type; Right : Cursor) return Boolean; - - function ">" (Left : Key_Type; Right : Cursor) return Boolean; - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - - function Iterate - (Container : Map) - return Map_Iterator_Interfaces.Reversible_Iterator'Class; - - function Iterate - (Container : Map; - Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'Class; - -private - - use Ada.Finalization; - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type is record - Parent : Count_Type; - Left : Count_Type; - Right : Count_Type; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Key : Key_Type; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Map (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; - - use Red_Black_Trees; - use Tree_Types, Tree_Types.Implementation; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; - - type Cursor is record - Container : Map_Access; - Node : Count_Type := 0; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0); - - No_Element : constant Cursor := Cursor'(null, 0); - - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Reversible_Iterator with - record - Container : Map_Access; - Node : Count_Type; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/a-cborse.adb b/gcc/ada/a-cborse.adb deleted file mode 100644 index 85d6566..0000000 --- a/gcc/ada/a-cborse.adb +++ /dev/null @@ -1,2044 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); - -with System; use type System.Address; - -package body Ada.Containers.Bounded_Ordered_Sets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ------------------------------ - -- Access to Fields of Node -- - ------------------------------ - - -- These subprograms provide functional notation for access to fields - -- of a node, and procedural notation for modifying these fields. - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; - pragma Inline (Color); - - function Left (Node : Node_Type) return Count_Type; - pragma Inline (Left); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right (Node : Node_Type) return Count_Type; - pragma Inline (Right); - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Insert_Sans_Hint - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Insert_With_Hint - (Dst_Set : in out Set; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean; - pragma Inline (Is_Less_Node_Node); - - procedure Replace_Element - (Container : in out Set; - Index : Count_Type; - Item : Element_Type); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types); - - use Tree_Operations; - - package Element_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - package Set_Ops is - new Red_Black_Trees.Generic_Bounded_Set_Operations - (Tree_Operations => Tree_Operations, - Set_Type => Set, - Assign => Assign, - Insert_With_Hint => Insert_With_Hint, - Is_Less => Is_Less_Node_Node); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "bad Left cursor in ""<"""); - - pragma Assert (Vet (Right.Container.all, Right.Node), - "bad Right cursor in ""<"""); - - declare - LN : Nodes_Type renames Left.Container.Nodes; - RN : Nodes_Type renames Right.Container.Nodes; - begin - return LN (Left.Node).Element < RN (Right.Node).Element; - end; - end "<"; - - function "<" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "bad Left cursor in ""<"""); - - return Left.Container.Nodes (Left.Node).Element < Right; - end "<"; - - function "<" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.all, Right.Node), - "bad Right cursor in ""<"""); - - return Left < Right.Container.Nodes (Right.Node).Element; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - function Is_Equal_Node_Node (L, R : Node_Type) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is - begin - return L.Element = R.Element; - end Is_Equal_Node_Node; - - -- Start of processing for Is_Equal - - begin - return Is_Equal (Left, Right); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "bad Left cursor in "">"""); - - pragma Assert (Vet (Right.Container.all, Right.Node), - "bad Right cursor in "">"""); - - -- L > R same as R < L - - declare - LN : Nodes_Type renames Left.Container.Nodes; - RN : Nodes_Type renames Right.Container.Nodes; - begin - return RN (Right.Node).Element < LN (Left.Node).Element; - end; - end ">"; - - function ">" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = 0 then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.all, Right.Node), - "bad Right cursor in "">"""); - - return Right.Container.Nodes (Right.Node).Element < Left; - end ">"; - - function ">" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Checks and then Left.Node = 0 then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.all, Left.Node), - "bad Left cursor in "">"""); - - return Right < Left.Container.Nodes (Left.Node).Element; - end ">"; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Target, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := SN.Element; - end Set_Element; - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target, - Hint => 0, - Key => SN.Element, - Node => Target_Node); - end Append_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error - with "Target capacity is less than Source length"; - end if; - - Target.Clear; - Append_Elements (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := - Element_Keys.Ceiling (Container, Item); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - Tree_Operations.Clear_Tree (Container); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert - (Vet (Container, Position.Node), - "bad cursor in Constant_Reference"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set is - C : Count_Type; - - begin - if Capacity = 0 then - C := Source.Length; - elsif Capacity >= Source.Length then - C := Capacity; - elsif Checks then - raise Capacity_Error with "Capacity value too small"; - end if; - - return Target : Set (Capacity => C) do - Assign (Target => Target, Source => Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - TC_Check (Container.TC); - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Delete"); - - Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); - Tree_Operations.Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container, Item); - - begin - Tree_Operations.Delete_Node_Sans_Free (Container, X); - - if Checks and then X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Tree_Operations.Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - X : constant Count_Type := Container.First; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - X : constant Count_Type := Container.Last; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end if; - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) - renames Set_Ops.Set_Difference; - - function Difference (Left, Right : Set) return Set - renames Set_Ops.Set_Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "bad cursor in Element"); - - return Position.Container.Nodes (Position.Node).Element; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - return (if Left < Right or else Right < Left then False else True); - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is - begin - return (if L.Element < R.Element then False - elsif R.Element < L.Element then False - else True); - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left, Right); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container, Item); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := Element_Keys.Find (Container, Item); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - return (if Container.First = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Container.First)); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is 0, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is positive, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = 0 then - return Bounded_Ordered_Sets.First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - begin - if Checks and then Container.First = 0 then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Nodes (Container.First).Element; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := Element_Keys.Floor (Container, Item); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Floor; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := - Key_Keys.Ceiling (Container, Key); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Ceiling; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => N.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Checks and then X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - return Container.Nodes (Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - return (if Left < Right or else Right < Left then False else True); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container, Key); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Tree_Operations.Free (Container, X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Impl.Reference_Control_Type (Control).Finalize; - - if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) - then - Delete (Control.Container.all, Key (Control.Pos)); - raise Program_Error; - end if; - - Control.Container := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Floor (Container, Key); - begin - return (if Node = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Floor; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Key (Right.Element) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Key (Right.Element); - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "bad cursor in Key"); - - return Key (Position.Container.Nodes (Position.Node).Element); - end Key; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert - (Vet (Container, Position.Node), - "bad cursor in function Reference_Preserving_Key"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => - (Controlled with - Container.TC'Unrestricted_Access, - Container => Container'Access, - Pos => Position, - Old_Key => new Key_Type'(Key (Position)))) - do - Lock (Container.TC); - end return; - end; - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - begin - return R : constant Reference_Type := - (Element => N.Element'Access, - Control => - (Controlled with - Container.TC'Unrestricted_Access, - Container => Container'Access, - Pos => Find (Container, Key), - Old_Key => new Key_Type'(Key))) - do - Lock (Container.TC); - end return; - end; - end Reference_Preserving_Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container, Node, New_Item); - end Replace; - - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Update_Element_Preserving_Key"); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - N : Node_Type renames Container.Nodes (Position.Node); - E : Element_Type renames N.Element; - K : constant Key_Type := Key (E); - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - Process (E); - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); - Tree_Operations.Free (Container, Position.Node); - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - end Generic_Keys; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Nodes (Position.Node).Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.TC); - - Container.Nodes (Position.Node).Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert_Sans_Hint - (Container, - New_Item, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Conditional_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Set_Element; - - -- Start of processing for Insert_Sans_Hint - - begin - TC_Check (Container.TC); - - Conditional_Insert_Sans_Hint - (Container, - New_Item, - Node, - Inserted); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Set : in out Set; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type) - is - Success : Boolean; - pragma Unreferenced (Success); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Insert_Post, - Insert_Sans_Hint); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Dst_Set, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := Src_Node.Element; - end Set_Element; - - -- Start of processing for Insert_With_Hint - - begin - Local_Insert_With_Hint - (Dst_Set, - Dst_Hint, - Src_Node.Element, - Dst_Node, - Success); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) - renames Set_Ops.Set_Intersection; - - function Intersection (Left, Right : Set) return Set - renames Set_Ops.Set_Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - -- Compute e > node same as node < e - - return Right.Element < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Element; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean is - begin - return L.Element < R.Element; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean - renames Set_Ops.Set_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - S : Set renames Container'Unrestricted_Access.all; - Busy : With_Busy (S.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (S); - end Iterate; - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is 0 (as is the case here), this means the iterator object - -- was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => 0) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong set"; - end if; - - pragma Assert (Vet (Container, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is positive (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. (Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration.) - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - return (if Container.Last = 0 then No_Element - else Cursor'(Container'Unrestricted_Access, Container.Last)); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is 0, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is positive, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = 0 then - return Bounded_Ordered_Sets.Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Checks and then Container.Last = 0 then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Nodes (Container.Last).Element; - end Last_Element; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Assign (Source); - Source.Clear; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "bad cursor in Next"); - - declare - Node : constant Count_Type := - Tree_Operations.Next (Position.Container.all, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean - renames Set_Ops.Set_Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Count_Type := - Tree_Operations.Previous (Position.Container.all, Position.Node); - begin - return (if Node = 0 then No_Element - else Cursor'(Position.Container, Node)); - end; - end Previous; - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong set"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.all, Position.Node), - "bad cursor in Query_Element"); - - declare - S : Set renames Position.Container.all; - Lock : With_Lock (S.TC'Unrestricted_Access); - begin - Process (S.Nodes (Position.Node).Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - procedure Read_Element (Node : in out Node_Type); - pragma Inline (Read_Element); - - procedure Allocate is - new Tree_Operations.Generic_Allocate (Read_Element); - - procedure Read_Elements is - new Tree_Operations.Generic_Read (Allocate); - - ------------------ - -- Read_Element -- - ------------------ - - procedure Read_Element (Node : in out Node_Type) is - begin - Element_Type'Read (Stream, Node.Element); - end Read_Element; - - -- Start of processing for Read - - begin - Read_Elements (Stream, Container); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Count_Type := Element_Keys.Find (Container, New_Item); - - begin - if Checks and then Node = 0 then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - TE_Check (Container.TC); - - Container.Nodes (Node).Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Set; - Index : Count_Type; - Item : Element_Type) - is - pragma Assert (Index /= 0); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Local_Insert_Post, - Local_Insert_Sans_Hint); - - Nodes : Nodes_Type renames Container.Nodes; - Node : Node_Type renames Nodes (Index); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - begin - Node.Element := Item; - Node.Color := Red_Black_Trees.Red; - Node.Parent := 0; - Node.Right := 0; - Node.Left := 0; - return Index; - end New_Node; - - Hint : Count_Type; - Result : Count_Type; - Inserted : Boolean; - Compare : Boolean; - - -- Start of processing for Replace_Element - - begin - -- Replace_Element assigns value Item to the element designated by Node, - -- per certain semantic constraints, described as follows. - - -- If Item is equivalent to the element, then element is replaced and - -- there's nothing else to do. This is the easy case. - - -- If Item is not equivalent, then the node will (possibly) have to move - -- to some other place in the tree. This is slighly more complicated, - -- because we must ensure that Item is not equivalent to some other - -- element in the tree (in which case, the replacement is not allowed). - - -- Determine whether Item is equivalent to element on the specified - -- node. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - Compare := (if Item < Node.Element then False - elsif Node.Element < Item then False - else True); - end; - - if Compare then - - -- Item is equivalent to the node's element, so we will not have to - -- move the node. - - TE_Check (Container.TC); - - Node.Element := Item; - return; - end if; - - -- The replacement Item is not equivalent to the element on the - -- specified node, which means that it will need to be re-inserted in a - -- different position in the tree. We must now determine whether Item is - -- equivalent to some other element in the tree (which would prohibit - -- the assignment and hence the move). - - -- Ceiling returns the smallest element equivalent or greater than the - -- specified Item; if there is no such element, then it returns 0. - - Hint := Element_Keys.Ceiling (Container, Item); - - if Hint /= 0 then -- Item <= Nodes (Hint).Element - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - Compare := Item < Nodes (Hint).Element; - end; - - -- Item is equivalent to Nodes (Hint).Element - - if Checks and then not Compare then - - -- Ceiling returns an element that is equivalent or greater than - -- Item. If Item is "not less than" the element, then by - -- elimination we know that Item is equivalent to the element. - - -- But this means that it is not possible to assign the value of - -- Item to the specified element (on Node), because a different - -- element (on Hint) equivalent to Item already exsits. (Were we - -- to change Node's element value, we would have to move Node, but - -- we would be unable to move the Node, because its new position - -- in the tree is already occupied by an equivalent element.) - - raise Program_Error with "attempt to replace existing element"; - end if; - - -- Item is not equivalent to any other element in the tree - -- (specifically, it is less than Nodes (Hint).Element), so it is - -- safe to assign the value of Item to Node.Element. This means that - -- the node will have to move to a different position in the tree - -- (because its element will have a different value). - - -- The nearest (greater) neighbor of Item is Hint. This will be the - -- insertion position of Node (because its element will have Item as - -- its new value). - - -- If Node equals Hint, the relative position of Node does not - -- change. This allows us to perform an optimization: we need not - -- remove Node from the tree and then reinsert it with its new value, - -- because it would only be placed in the exact same position. - - if Hint = Index then - TE_Check (Container.TC); - - Node.Element := Item; - return; - end if; - end if; - - -- If we get here, it is because Item was greater than all elements in - -- the tree (Hint = 0), or because Item was less than some element at a - -- different place in the tree (Item < Nodes (Hint).Element and Hint /= - -- Index). In either case, we remove Node from the tree and then insert - -- Item into the tree, onto the same Node. - - Tree_Operations.Delete_Node_Sans_Free (Container, Index); - - Local_Insert_With_Hint - (Tree => Container, - Position => Hint, - Key => Item, - Node => Result, - Inserted => Inserted); - - pragma Assert (Inserted); - pragma Assert (Result = Index); - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = 0 then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container, Position.Node, New_Item); - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Count_Type); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Count_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - S : Set renames Container'Unrestricted_Access.all; - Busy : With_Busy (S.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (S); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type) - is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) - renames Set_Ops.Set_Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set - renames Set_Ops.Set_Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Node : Count_Type; - Inserted : Boolean; - begin - return S : Set (1) do - Insert_Sans_Hint (S, New_Item, Node, Inserted); - pragma Assert (Inserted); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) - renames Set_Ops.Set_Union; - - function Union (Left, Right : Set) return Set - renames Set_Ops.Set_Union; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Element - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - pragma Inline (Write_Element); - - procedure Write_Elements is - new Tree_Operations.Generic_Write (Write_Element); - - ------------------- - -- Write_Element -- - ------------------- - - procedure Write_Element - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Element; - - -- Start of processing for Write - - begin - Write_Elements (Stream, Container); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/a-cborse.ads b/gcc/ada/a-cborse.ads deleted file mode 100644 index f342ab8..0000000 --- a/gcc/ada/a-cborse.ads +++ /dev/null @@ -1,450 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Containers.Red_Black_Trees; -private with Ada.Streams; -private with Ada.Finalization; - -generic - type Element_Type is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Bounded_Ordered_Sets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - pragma Remote_Types; - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean; - - type Set (Capacity : Count_Type) is tagged private - with Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Set : constant Set; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - - function Equivalent_Sets (Left, Right : Set) return Boolean; - - function To_Set (New_Item : Element_Type) return Set; - - function Length (Container : Set) return Count_Type; - - function Is_Empty (Container : Set) return Boolean; - - procedure Clear (Container : in out Set); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set; - - procedure Move (Target : in out Set; Source : in out Set); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type); - - procedure Include - (Container : in out Set; - New_Item : Element_Type); - - procedure Replace - (Container : in out Set; - New_Item : Element_Type); - - procedure Exclude - (Container : in out Set; - Item : Element_Type); - - procedure Delete - (Container : in out Set; - Item : Element_Type); - - procedure Delete - (Container : in out Set; - Position : in out Cursor); - - procedure Delete_First (Container : in out Set); - - procedure Delete_Last (Container : in out Set); - - procedure Union (Target : in out Set; Source : Set); - - function Union (Left, Right : Set) return Set; - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - - function Intersection (Left, Right : Set) return Set; - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - - function Difference (Left, Right : Set) return Set; - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - - function Symmetric_Difference (Left, Right : Set) return Set; - - function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - - function First (Container : Set) return Cursor; - - function First_Element (Container : Set) return Element_Type; - - function Last (Container : Set) return Cursor; - - function Last_Element (Container : Set) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find (Container : Set; Item : Element_Type) return Cursor; - - function Floor (Container : Set; Item : Element_Type) return Cursor; - - function Ceiling (Container : Set; Item : Element_Type) return Cursor; - - function Contains (Container : Set; Item : Element_Type) return Boolean; - - function "<" (Left, Right : Cursor) return Boolean; - - function ">" (Left, Right : Cursor) return Boolean; - - function "<" (Left : Cursor; Right : Element_Type) return Boolean; - - function ">" (Left : Cursor; Right : Element_Type) return Boolean; - - function "<" (Left : Element_Type; Right : Cursor) return Boolean; - - function ">" (Left : Element_Type; Right : Cursor) return Boolean; - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - - function Iterate - (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : Set; - Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - function Key (Position : Cursor) return Key_Type; - - function Element (Container : Set; Key : Key_Type) return Element_Type; - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type); - - procedure Exclude (Container : in out Set; Key : Key_Type); - - procedure Delete (Container : in out Set; Key : Key_Type); - - function Find (Container : Set; Key : Key_Type) return Cursor; - - function Floor (Container : Set; Key : Key_Type) return Cursor; - - function Ceiling (Container : Set; Key : Key_Type) return Cursor; - - function Contains (Container : Set; Key : Key_Type) return Boolean; - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type; - - private - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - type Key_Access is access all Key_Type; - - use Ada.Streams; - - package Impl is new Helpers.Generic_Implementation; - - type Reference_Control_Type is - new Impl.Reference_Control_Type with - record - Container : Set_Access; - Pos : Cursor; - Old_Key : Key_Access; - end record; - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - end Generic_Keys; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type is record - Parent : Count_Type; - Left : Count_Type; - Right : Count_Type; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Set (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; - - use Tree_Types, Tree_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - -- Note: If a Cursor object has no explicit initialization expression, - -- it must default initialize to the same value as constant No_Element. - -- The Node component of type Cursor has scalar type Count_Type, so it - -- requires an explicit initialization expression of its own declaration, - -- in order for objects of record type Cursor to properly initialize. - - type Cursor is record - Container : Set_Access; - Node : Count_Type := 0; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0); - - No_Element : constant Cursor := Cursor'(null, 0); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Count_Type; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/a-cbprqu.adb b/gcc/ada/a-cbprqu.adb deleted file mode 100644 index 8256d86..0000000 --- a/gcc/ada/a-cbprqu.adb +++ /dev/null @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_PRIORITY_QUEUES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Bounded_Priority_Queues is - - package body Implementation is - - ------------- - -- Dequeue -- - ------------- - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type) - is - begin - Element := List.Container.First_Element; - List.Container.Delete_First; - end Dequeue; - - procedure Dequeue - (List : in out List_Type; - At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean) - is - begin - -- This operation dequeues a high priority item if it exists in the - -- queue. By "high priority" we mean an item whose priority is equal - -- or greater than the value At_Least. The generic formal operation - -- Before has the meaning "has higher priority than". To dequeue an - -- item (meaning that we return True as our Success value), we need - -- as our predicate the equivalent of "has equal or higher priority - -- than", but we cannot say that directly, so we require some logical - -- gymnastics to make it so. - - -- If E is the element at the head of the queue, and symbol ">" - -- refers to the "is higher priority than" function Before, then we - -- derive our predicate as follows: - - -- original: P(E) >= At_Least - -- same as: not (P(E) < At_Least) - -- same as: not (At_Least > P(E)) - -- same as: not Before (At_Least, P(E)) - - -- But that predicate needs to be true in order to successfully - -- dequeue an item. If it's false, it means no item is dequeued, and - -- we return False as the Success value. - - if List.Length = 0 - or else Before (At_Least, - Get_Priority (List.Container.First_Element)) - then - Success := False; - return; - end if; - - List.Dequeue (Element); - Success := True; - end Dequeue; - - ------------- - -- Enqueue -- - ------------- - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type) - is - P : constant Queue_Priority := Get_Priority (New_Item); - - C : List_Types.Cursor; - use List_Types; - - Count : Count_Type; - - begin - C := List.Container.First; - while Has_Element (C) loop - - -- ??? why is following commented out ??? - -- if Before (P, Get_Priority (List.Constant_Reference (C))) then - - if Before (P, Get_Priority (Element (C))) then - List.Container.Insert (C, New_Item); - exit; - end if; - - Next (C); - end loop; - - if not Has_Element (C) then - List.Container.Append (New_Item); - end if; - - Count := List.Container.Length; - - if Count > List.Max_Length then - List.Max_Length := Count; - end if; - end Enqueue; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element - (List : List_Type) return Queue_Interfaces.Element_Type - is - begin - - -- Use Constant_Reference for this. ??? - - return List.Container.First_Element; - end First_Element; - - ------------ - -- Length -- - ------------ - - function Length (List : List_Type) return Count_Type is - begin - return List.Container.Length; - end Length; - - ---------------- - -- Max_Length -- - ---------------- - - function Max_Length (List : List_Type) return Count_Type is - begin - return List.Max_Length; - end Max_Length; - - end Implementation; - - protected body Queue is - - ------------------ - -- Current_Use -- - ------------------ - - function Current_Use return Count_Type is - begin - return List.Length; - end Current_Use; - - -------------- - -- Dequeue -- - -------------- - - entry Dequeue (Element : out Queue_Interfaces.Element_Type) - when List.Length > 0 - is - begin - List.Dequeue (Element); - end Dequeue; - - -------------------------------- - -- Dequeue_Only_High_Priority -- - -------------------------------- - - procedure Dequeue_Only_High_Priority - (At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean) - is - begin - List.Dequeue (At_Least, Element, Success); - end Dequeue_Only_High_Priority; - - -------------- - -- Enqueue -- - -------------- - - entry Enqueue (New_Item : Queue_Interfaces.Element_Type) - when List.Length < Capacity - is - begin - List.Enqueue (New_Item); - end Enqueue; - - --------------- - -- Peak_Use -- - --------------- - - function Peak_Use return Count_Type is - begin - return List.Max_Length; - end Peak_Use; - - end Queue; - -end Ada.Containers.Bounded_Priority_Queues; diff --git a/gcc/ada/a-cbprqu.ads b/gcc/ada/a-cbprqu.ads deleted file mode 100644 index d3e7e0f..0000000 --- a/gcc/ada/a-cbprqu.ads +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_PRIORITY_QUEUES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; - -with Ada.Containers.Synchronized_Queue_Interfaces; -with Ada.Containers.Bounded_Doubly_Linked_Lists; - -generic - with package Queue_Interfaces is - new Ada.Containers.Synchronized_Queue_Interfaces (<>); - - type Queue_Priority is private; - - with function Get_Priority - (Element : Queue_Interfaces.Element_Type) return Queue_Priority is <>; - - with function Before - (Left, Right : Queue_Priority) return Boolean is <>; - - Default_Capacity : Count_Type; - Default_Ceiling : System.Any_Priority := System.Priority'Last; - -package Ada.Containers.Bounded_Priority_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - - package Implementation is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - type List_Type (Capacity : Count_Type) is tagged limited private; - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type); - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type); - - procedure Dequeue - (List : in out List_Type; - At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean); - - function First_Element - (List : List_Type) return Queue_Interfaces.Element_Type; - - function Length (List : List_Type) return Count_Type; - - function Max_Length (List : List_Type) return Count_Type; - - private - - -- We need a better data structure here, such as a proper heap. ??? - - pragma Warnings (Off); - -- Otherwise, we get warnings for the uninitialized variable in Insert - -- in Ada.Containers.Bounded_Doubly_Linked_Lists. - package List_Types is new Bounded_Doubly_Linked_Lists - (Element_Type => Queue_Interfaces.Element_Type, - "=" => Queue_Interfaces."="); - pragma Warnings (On); - - type List_Type (Capacity : Count_Type) is tagged limited record - Container : List_Types.List (Capacity); - Max_Length : Count_Type := 0; - end record; - - end Implementation; - - protected type Queue - (Capacity : Count_Type := Default_Capacity; - Ceiling : System.Any_Priority := Default_Ceiling) - with - Priority => Ceiling - is new Queue_Interfaces.Queue with - - overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); - - overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); - - -- The priority queue operation Dequeue_Only_High_Priority had been a - -- protected entry in early drafts of AI05-0159, but it was discovered - -- that that operation as specified was not in fact implementable. The - -- operation was changed from an entry to a protected procedure per the - -- ARG meeting in Edinburgh (June 2011), with a different signature and - -- semantics. - - procedure Dequeue_Only_High_Priority - (At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean); - - overriding function Current_Use return Count_Type; - - overriding function Peak_Use return Count_Type; - - private - List : Implementation.List_Type (Capacity); - end Queue; - -end Ada.Containers.Bounded_Priority_Queues; diff --git a/gcc/ada/a-cbsyqu.adb b/gcc/ada/a-cbsyqu.adb deleted file mode 100644 index 0f29d9f..0000000 --- a/gcc/ada/a-cbsyqu.adb +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_SYNCHRONIZED_QUEUES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Bounded_Synchronized_Queues is - - package body Implementation is - - ------------- - -- Dequeue -- - ------------- - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type) - is - EE : Element_Array renames List.Elements; - - begin - Element := EE (List.First); - List.Length := List.Length - 1; - - if List.Length = 0 then - List.First := 0; - List.Last := 0; - - elsif List.First <= List.Last then - List.First := List.First + 1; - - else - List.First := List.First + 1; - - if List.First > List.Capacity then - List.First := 1; - end if; - end if; - end Dequeue; - - ------------- - -- Enqueue -- - ------------- - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type) - is - begin - if List.Length >= List.Capacity then - raise Capacity_Error with "No capacity for insertion"; - end if; - - if List.Length = 0 then - List.Elements (1) := New_Item; - List.First := 1; - List.Last := 1; - - elsif List.First <= List.Last then - if List.Last < List.Capacity then - List.Elements (List.Last + 1) := New_Item; - List.Last := List.Last + 1; - - else - List.Elements (1) := New_Item; - List.Last := 1; - end if; - - else - List.Elements (List.Last + 1) := New_Item; - List.Last := List.Last + 1; - end if; - - List.Length := List.Length + 1; - - if List.Length > List.Max_Length then - List.Max_Length := List.Length; - end if; - end Enqueue; - - ------------ - -- Length -- - ------------ - - function Length (List : List_Type) return Count_Type is - begin - return List.Length; - end Length; - - ---------------- - -- Max_Length -- - ---------------- - - function Max_Length (List : List_Type) return Count_Type is - begin - return List.Max_Length; - end Max_Length; - - end Implementation; - - protected body Queue is - - ----------------- - -- Current_Use -- - ----------------- - - function Current_Use return Count_Type is - begin - return List.Length; - end Current_Use; - - ------------- - -- Dequeue -- - ------------- - - entry Dequeue (Element : out Queue_Interfaces.Element_Type) - when List.Length > 0 - is - begin - List.Dequeue (Element); - end Dequeue; - - ------------- - -- Enqueue -- - ------------- - - entry Enqueue (New_Item : Queue_Interfaces.Element_Type) - when List.Length < Capacity - is - begin - List.Enqueue (New_Item); - end Enqueue; - - -------------- - -- Peak_Use -- - -------------- - - function Peak_Use return Count_Type is - begin - return List.Max_Length; - end Peak_Use; - - end Queue; - -end Ada.Containers.Bounded_Synchronized_Queues; diff --git a/gcc/ada/a-cbsyqu.ads b/gcc/ada/a-cbsyqu.ads deleted file mode 100644 index e22e082..0000000 --- a/gcc/ada/a-cbsyqu.ads +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.BOUNDED_SYNCHRONIZED_QUEUES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; -with Ada.Containers.Synchronized_Queue_Interfaces; - -generic - with package Queue_Interfaces is - new Ada.Containers.Synchronized_Queue_Interfaces (<>); - - Default_Capacity : Count_Type; - Default_Ceiling : System.Any_Priority := System.Priority'Last; - -package Ada.Containers.Bounded_Synchronized_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - - package Implementation is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - type List_Type (Capacity : Count_Type) is tagged limited private; - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type); - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type); - - function Length (List : List_Type) return Count_Type; - - function Max_Length (List : List_Type) return Count_Type; - - private - - -- Need proper heap data structure here ??? - - type Element_Array is - array (Count_Type range <>) of Queue_Interfaces.Element_Type; - - type List_Type (Capacity : Count_Type) is tagged limited record - First, Last : Count_Type := 0; - Length : Count_Type := 0; - Max_Length : Count_Type := 0; - Elements : Element_Array (1 .. Capacity) := (others => <>); - end record; - - end Implementation; - - protected type Queue - (Capacity : Count_Type := Default_Capacity; - Ceiling : System.Any_Priority := Default_Ceiling) - with - Priority => Ceiling - is new Queue_Interfaces.Queue with - - overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); - - overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); - - overriding function Current_Use return Count_Type; - - overriding function Peak_Use return Count_Type; - - private - List : Implementation.List_Type (Capacity); - end Queue; - -end Ada.Containers.Bounded_Synchronized_Queues; diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb deleted file mode 100644 index 011c395..0000000 --- a/gcc/ada/a-cdlili.adb +++ /dev/null @@ -1,2186 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Doubly_Linked_Lists is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Free (X : in out Node_Access); - - procedure Insert_Internal - (Container : in out List; - Before : Node_Access; - New_Node : Node_Access); - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; - Source : in out List); - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; - Source : in out List; - Position : Node_Access); - - function Vet (Position : Cursor) return Boolean; - -- Checks invariants of the cursor and its designated container, as a - -- simple way of detecting dangling references (see operation Free for a - -- description of the detection mechanism), returning True if all checks - -- pass. Invocations of Vet are used here as the argument of pragma Assert, - -- so the checks are performed only when assertions are enabled. - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : List) return Boolean is - begin - if Left.Length /= Right.Length then - return False; - end if; - - if Left.Length = 0 then - return True; - end if; - - declare - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L : Node_Access := Left.First; - R : Node_Access := Right.First; - begin - for J in 1 .. Left.Length loop - if L.Element /= R.Element then - return False; - end if; - - L := L.Next; - R := R.Next; - end loop; - end; - - return True; - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out List) is - Src : Node_Access := Container.First; - - begin - -- If the counts are nonzero, execution is technically erroneous, but - -- it seems friendly to allow things like concurrent "=" on shared - -- constants. - - Zero_Counts (Container.TC); - - if Src = null then - pragma Assert (Container.Last = null); - pragma Assert (Container.Length = 0); - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - pragma Assert (Container.Length > 0); - - Container.First := null; - Container.Last := null; - Container.Length := 0; - Zero_Counts (Container.TC); - - Container.First := new Node_Type'(Src.Element, null, null); - Container.Last := Container.First; - Container.Length := 1; - - Src := Src.Next; - while Src /= null loop - Container.Last.Next := new Node_Type'(Element => Src.Element, - Prev => Container.Last, - Next => null); - Container.Last := Container.Last.Next; - Container.Length := Container.Length + 1; - - Src := Src.Next; - end loop; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, No_Element, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out List; Source : List) is - Node : Node_Access; - - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - - Node := Source.First; - while Node /= null loop - Target.Append (Node.Element); - Node := Node.Next; - end loop; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - X : Node_Access; - - begin - if Container.Length = 0 then - pragma Assert (Container.First = null); - pragma Assert (Container.Last = null); - pragma Assert (Container.TC = (Busy => 0, Lock => 0)); - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - TC_Check (Container.TC); - - while Container.Length > 1 loop - X := Container.First; - pragma Assert (X.Next.Prev = Container.First); - - Container.First := X.Next; - Container.First.Prev := null; - - Container.Length := Container.Length - 1; - - Free (X); - end loop; - - X := Container.First; - pragma Assert (X = Container.Last); - - Container.First := null; - Container.Last := null; - Container.Length := 0; - - pragma Warnings (Off); - Free (X); - pragma Warnings (On); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : List; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : List) return List is - begin - return Target : List do - Target.Assign (Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1) - is - X : Node_Access; - - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; -- Post-York behavior - return; - end if; - - if Count = 0 then - Position := No_Element; -- Post-York behavior - return; - end if; - - TC_Check (Container.TC); - - for Index in 1 .. Count loop - X := Position.Node; - Container.Length := Container.Length - 1; - - if X = Container.Last then - Position := No_Element; - - Container.Last := X.Prev; - Container.Last.Next := null; - - Free (X); - return; - end if; - - Position.Node := X.Next; - - X.Next.Prev := X.Prev; - X.Prev.Next := X.Next; - - Free (X); - end loop; - - -- The following comment is unacceptable, more detail needed ??? - - Position := No_Element; -- Post-York behavior - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1) - is - X : Node_Access; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - for J in 1 .. Count loop - X := Container.First; - pragma Assert (X.Next.Prev = Container.First); - - Container.First := X.Next; - Container.First.Prev := null; - - Container.Length := Container.Length - 1; - - Free (X); - end loop; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1) - is - X : Node_Access; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (X.Prev.Next = Container.Last); - - Container.Last := X.Prev; - Container.Last.Next := null; - - Container.Length := Container.Length - 1; - - Free (X); - end loop; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Element"); - - return Position.Node.Element; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Node : Node_Access := Position.Node; - - begin - if Node = null then - Node := Container.First; - - else - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Find"); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - while Node /= null loop - if Node.Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := Node.Next; - end loop; - - return No_Element; - end; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : List) return Cursor is - begin - if Container.First = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.First); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Doubly_Linked_Lists.First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : List) return Element_Type is - begin - if Checks and then Container.First = null then - raise Constraint_Error with "list is empty"; - end if; - - return Container.First.Element; - end First_Element; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - -- While a node is in use, as an active link in a list, its Previous and - -- Next components must be null, or designate a different node; this is - -- a node invariant. Before actually deallocating the node, we set both - -- access value components of the node to point to the node itself, thus - -- falsifying the node invariant. Subprogram Vet inspects the value of - -- the node components when interrogating the node, in order to detect - -- whether the cursor's node access value is dangling. - - -- Note that we have no guarantee that the storage for the node isn't - -- modified when it is deallocated, but there are other tests that Vet - -- does if node invariants appear to be satisifed. However, in practice - -- this simple test works well enough, detecting dangling references - -- immediately, without needing further interrogation. - - X.Prev := X; - X.Next := X; - - Deallocate (X); - end Free; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : List) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - - Node : Node_Access; - begin - Node := Container.First; - for Idx in 2 .. Container.Length loop - if Node.Next.Element < Node.Element then - return False; - end if; - - Node := Node.Next; - end loop; - - return True; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge - (Target : in out List; - Source : in out List) - is - begin - -- The semantics of Merge changed slightly per AI05-0021. It was - -- originally the case that if Target and Source denoted the same - -- container object, then the GNAT implementation of Merge did - -- nothing. However, it was argued that RM05 did not precisely - -- specify the semantics for this corner case. The decision of the - -- ARG was that if Target and Source denote the same non-empty - -- container object, then Program_Error is raised. - - if Source.Is_Empty then - return; - end if; - - if Checks and then Target'Address = Source'Address then - raise Program_Error with - "Target and Source denote same non-empty container"; - end if; - - if Checks and then Target.Length > Count_Type'Last - Source.Length - then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unchecked_Access); - Lock_Source : With_Lock (Source.TC'Unchecked_Access); - - LI, RI, RJ : Node_Access; - - begin - LI := Target.First; - RI := Source.First; - while RI /= null loop - pragma Assert (RI.Next = null - or else not (RI.Next.Element < RI.Element)); - - if LI = null then - Splice_Internal (Target, null, Source); - exit; - end if; - - pragma Assert (LI.Next = null - or else not (LI.Next.Element < LI.Element)); - - if RI.Element < LI.Element then - RJ := RI; - RI := RI.Next; - Splice_Internal (Target, LI, Source, RJ); - - else - LI := LI.Next; - end if; - end loop; - end; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out List) is - - procedure Partition (Pivot : Node_Access; Back : Node_Access); - - procedure Sort (Front, Back : Node_Access); - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot : Node_Access; Back : Node_Access) is - Node : Node_Access; - - begin - Node := Pivot.Next; - while Node /= Back loop - if Node.Element < Pivot.Element then - declare - Prev : constant Node_Access := Node.Prev; - Next : constant Node_Access := Node.Next; - - begin - Prev.Next := Next; - - if Next = null then - Container.Last := Prev; - else - Next.Prev := Prev; - end if; - - Node.Next := Pivot; - Node.Prev := Pivot.Prev; - - Pivot.Prev := Node; - - if Node.Prev = null then - Container.First := Node; - else - Node.Prev.Next := Node; - end if; - - Node := Next; - end; - - else - Node := Node.Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Node_Access) is - Pivot : constant Node_Access := - (if Front = null then Container.First else Front.Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - TC_Check (Container.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Sort (Front => null, Back => null); - end; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - end Sort; - - end Generic_Sorting; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= null; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - First_Node : Node_Access; - New_Node : Node_Access; - - begin - if Before.Container /= null then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Before cursor designates wrong list"; - end if; - - pragma Assert (Vet (Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - - if Checks and then Container.Length > Count_Type'Last - Count then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - TC_Check (Container.TC); - - New_Node := new Node_Type'(New_Item, null, null); - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); - - for J in 2 .. Count loop - New_Node := new Node_Type'(New_Item, null, null); - Insert_Internal (Container, Before.Node, New_Node); - end loop; - - Position := Cursor'(Container'Unchecked_Access, First_Node); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Position : Cursor; - pragma Unreferenced (Position); - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - First_Node : Node_Access; - New_Node : Node_Access; - - begin - if Before.Container /= null then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Before cursor designates wrong list"; - end if; - - pragma Assert (Vet (Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - - if Checks and then Container.Length > Count_Type'Last - Count then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - TC_Check (Container.TC); - - New_Node := new Node_Type; - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); - - for J in 2 .. Count loop - New_Node := new Node_Type; - Insert_Internal (Container, Before.Node, New_Node); - end loop; - - Position := Cursor'(Container'Unchecked_Access, First_Node); - end Insert; - - --------------------- - -- Insert_Internal -- - --------------------- - - procedure Insert_Internal - (Container : in out List; - Before : Node_Access; - New_Node : Node_Access) - is - begin - if Container.Length = 0 then - pragma Assert (Before = null); - pragma Assert (Container.First = null); - pragma Assert (Container.Last = null); - - Container.First := New_Node; - Container.Last := New_Node; - - elsif Before = null then - pragma Assert (Container.Last.Next = null); - - Container.Last.Next := New_Node; - New_Node.Prev := Container.Last; - - Container.Last := New_Node; - - elsif Before = Container.First then - pragma Assert (Container.First.Prev = null); - - Container.First.Prev := New_Node; - New_Node.Next := Container.First; - - Container.First := New_Node; - - else - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - New_Node.Next := Before; - New_Node.Prev := Before.Prev; - - Before.Prev.Next := New_Node; - Before.Prev := New_Node; - end if; - - Container.Length := Container.Length + 1; - end Insert_Internal; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : List) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - Node : Node_Access := Container.First; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Next; - end loop; - end Iterate; - - function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a - -- complete iterator, meaning that the iteration starts from the - -- (logical) beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate (Container : List; Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong list"; - end if; - - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this is a - -- partial iteration, over a subset of the complete sequence of items. - -- The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this is - -- a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : List) return Cursor is - begin - if Container.Last = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.Last); - end if; - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Doubly_Linked_Lists.Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : List) return Element_Type is - begin - if Checks and then Container.Last = null then - raise Constraint_Error with "list is empty"; - end if; - - return Container.Last.Element; - end Last_Element; - - ------------ - -- Length -- - ------------ - - function Length (Container : List) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out List; - Source : in out List) - is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Clear (Target); - - Target.First := Source.First; - Source.First := null; - - Target.Last := Source.Last; - Source.Last := null; - - Target.Length := Source.Length; - Source.Length := 0; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = null then - return No_Element; - - else - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - Next_Node : constant Node_Access := Position.Node.Next; - begin - if Next_Node = null then - return No_Element; - else - return Cursor'(Position.Container, Next_Node); - end if; - end; - end if; - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong list"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, First (Container), New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Node = null then - return No_Element; - - else - pragma Assert (Vet (Position), "bad cursor in Previous"); - - declare - Prev_Node : constant Node_Access := Position.Node.Prev; - begin - if Prev_Node = null then - return No_Element; - else - return Cursor'(Position.Container, Prev_Node); - end if; - end; - end if; - end Previous; - - function Previous - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong list"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased List'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - Lock : With_Lock (Position.Container.TC'Unrestricted_Access); - begin - Process (Position.Node.Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List) - is - N : Count_Type'Base; - X : Node_Access; - - begin - Clear (Item); - Count_Type'Base'Read (Stream, N); - - if N = 0 then - return; - end if; - - X := new Node_Type; - - begin - Element_Type'Read (Stream, X.Element); - exception - when others => - Free (X); - raise; - end; - - Item.First := X; - Item.Last := X; - - loop - Item.Length := Item.Length + 1; - exit when Item.Length = N; - - X := new Node_Type; - - begin - Element_Type'Read (Stream, X.Element); - exception - when others => - Free (X); - raise; - end; - - X.Prev := Item.Last; - Item.Last.Next := X; - Item.Last := X; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out List; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unchecked_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Reference"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unchecked_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - TE_Check (Container.TC); - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Position.Node.Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - I : Node_Access := Container.First; - J : Node_Access := Container.Last; - - procedure Swap (L, R : Node_Access); - - ---------- - -- Swap -- - ---------- - - procedure Swap (L, R : Node_Access) is - LN : constant Node_Access := L.Next; - LP : constant Node_Access := L.Prev; - - RN : constant Node_Access := R.Next; - RP : constant Node_Access := R.Prev; - - begin - if LP /= null then - LP.Next := R; - end if; - - if RN /= null then - RN.Prev := L; - end if; - - L.Next := RN; - R.Prev := LP; - - if LN = R then - pragma Assert (RP = L); - - L.Prev := R; - R.Next := L; - - else - L.Prev := RP; - RP.Next := L; - - R.Next := LN; - LN.Prev := R; - end if; - end Swap; - - -- Start of processing for Reverse_Elements - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - TC_Check (Container.TC); - - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); - - J := J.Next; - exit when I = J; - - I := I.Prev; - exit when I = J; - - Swap (L => J, R => I); - - I := I.Next; - exit when I = J; - - J := J.Prev; - exit when I = J; - end loop; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Node : Node_Access := Position.Node; - - begin - if Node = null then - Node := Container.Last; - - else - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - while Node /= null loop - if Node.Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := Node.Prev; - end loop; - - return No_Element; - end; - end Reverse_Find; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - Node : Node_Access := Container.Last; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Prev; - end loop; - end Reverse_Iterate; - - ------------ - -- Splice -- - ------------ - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - is - begin - if Before.Container /= null then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - pragma Assert (Vet (Before), "bad cursor in Splice"); - end if; - - if Target'Address = Source'Address or else Source.Length = 0 then - return; - end if; - - if Checks and then Target.Length > Count_Type'Last - Source.Length then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - Splice_Internal (Target, Before.Node, Source); - end Splice; - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - is - begin - if Before.Container /= null then - if Checks and then Before.Container /= Container'Unchecked_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - end if; - - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Position.Node = Before.Node - or else Position.Node.Next = Before.Node - then - return; - end if; - - pragma Assert (Container.Length >= 2); - - TC_Check (Container.TC); - - if Before.Node = null then - pragma Assert (Position.Node /= Container.Last); - - if Position.Node = Container.First then - Container.First := Position.Node.Next; - Container.First.Prev := null; - else - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; - end if; - - Container.Last.Next := Position.Node; - Position.Node.Prev := Container.Last; - - Container.Last := Position.Node; - Container.Last.Next := null; - - return; - end if; - - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := Position.Node.Prev; - Container.Last.Next := null; - else - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; - end if; - - Container.First.Prev := Position.Node; - Position.Node.Next := Container.First; - - Container.First := Position.Node; - Container.First.Prev := null; - - return; - end if; - - if Position.Node = Container.First then - Container.First := Position.Node.Next; - Container.First.Prev := null; - - elsif Position.Node = Container.Last then - Container.Last := Position.Node.Prev; - Container.Last.Next := null; - - else - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; - end if; - - Before.Node.Prev.Next := Position.Node; - Position.Node.Prev := Before.Node.Prev; - - Before.Node.Prev := Position.Node; - Position.Node.Next := Before.Node; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - end Splice; - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - is - begin - if Target'Address = Source'Address then - Splice (Target, Before, Position); - return; - end if; - - if Before.Container /= null then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - end if; - - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Source'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Checks and then Target.Length = Count_Type'Last then - raise Constraint_Error with "Target is full"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - Splice_Internal (Target, Before.Node, Source, Position.Node); - Position.Container := Target'Unchecked_Access; - end Splice; - - --------------------- - -- Splice_Internal -- - --------------------- - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; - Source : in out List) - is - begin - -- This implements the corresponding Splice operation, after the - -- parameters have been vetted, and corner-cases disposed of. - - pragma Assert (Target'Address /= Source'Address); - pragma Assert (Source.Length > 0); - pragma Assert (Source.First /= null); - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last /= null); - pragma Assert (Source.Last.Next = null); - pragma Assert (Target.Length <= Count_Type'Last - Source.Length); - - if Target.Length = 0 then - pragma Assert (Target.First = null); - pragma Assert (Target.Last = null); - pragma Assert (Before = null); - - Target.First := Source.First; - Target.Last := Source.Last; - - elsif Before = null then - pragma Assert (Target.Last.Next = null); - - Target.Last.Next := Source.First; - Source.First.Prev := Target.Last; - - Target.Last := Source.Last; - - elsif Before = Target.First then - pragma Assert (Target.First.Prev = null); - - Source.Last.Next := Target.First; - Target.First.Prev := Source.Last; - - Target.First := Source.First; - - else - pragma Assert (Target.Length >= 2); - - Before.Prev.Next := Source.First; - Source.First.Prev := Before.Prev; - - Before.Prev := Source.Last; - Source.Last.Next := Before; - end if; - - Source.First := null; - Source.Last := null; - - Target.Length := Target.Length + Source.Length; - Source.Length := 0; - end Splice_Internal; - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; -- node of Target - Source : in out List; - Position : Node_Access) -- node of Source - is - begin - -- This implements the corresponding Splice operation, after the - -- parameters have been vetted. - - pragma Assert (Target'Address /= Source'Address); - pragma Assert (Target.Length < Count_Type'Last); - pragma Assert (Source.Length > 0); - pragma Assert (Source.First /= null); - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last /= null); - pragma Assert (Source.Last.Next = null); - pragma Assert (Position /= null); - - if Position = Source.First then - Source.First := Position.Next; - - if Position = Source.Last then - pragma Assert (Source.First = null); - pragma Assert (Source.Length = 1); - Source.Last := null; - - else - Source.First.Prev := null; - end if; - - elsif Position = Source.Last then - pragma Assert (Source.Length >= 2); - Source.Last := Position.Prev; - Source.Last.Next := null; - - else - pragma Assert (Source.Length >= 3); - Position.Prev.Next := Position.Next; - Position.Next.Prev := Position.Prev; - end if; - - if Target.Length = 0 then - pragma Assert (Target.First = null); - pragma Assert (Target.Last = null); - pragma Assert (Before = null); - - Target.First := Position; - Target.Last := Position; - - Target.First.Prev := null; - Target.Last.Next := null; - - elsif Before = null then - pragma Assert (Target.Last.Next = null); - Target.Last.Next := Position; - Position.Prev := Target.Last; - - Target.Last := Position; - Target.Last.Next := null; - - elsif Before = Target.First then - pragma Assert (Target.First.Prev = null); - Target.First.Prev := Position; - Position.Next := Target.First; - - Target.First := Position; - Target.First.Prev := null; - - else - pragma Assert (Target.Length >= 2); - Before.Prev.Next := Position; - Position.Prev := Before.Prev; - - Before.Prev := Position; - Position.Next := Before; - end if; - - Target.Length := Target.Length + 1; - Source.Length := Source.Length - 1; - end Splice_Internal; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out List; - I, J : Cursor) - is - begin - if Checks and then I.Node = null then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then J.Node = null then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unchecked_Access then - raise Program_Error with "I cursor designates wrong container"; - end if; - - if Checks and then J.Container /= Container'Unchecked_Access then - raise Program_Error with "J cursor designates wrong container"; - end if; - - if I.Node = J.Node then - return; - end if; - - TE_Check (Container.TC); - - pragma Assert (Vet (I), "bad I cursor in Swap"); - pragma Assert (Vet (J), "bad J cursor in Swap"); - - declare - EI : Element_Type renames I.Node.Element; - EJ : Element_Type renames J.Node.Element; - - EI_Copy : constant Element_Type := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - ---------------- - -- Swap_Links -- - ---------------- - - procedure Swap_Links - (Container : in out List; - I, J : Cursor) - is - begin - if Checks and then I.Node = null then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then J.Node = null then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor designates wrong container"; - end if; - - if Checks and then J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor designates wrong container"; - end if; - - if I.Node = J.Node then - return; - end if; - - TC_Check (Container.TC); - - pragma Assert (Vet (I), "bad I cursor in Swap_Links"); - pragma Assert (Vet (J), "bad J cursor in Swap_Links"); - - declare - I_Next : constant Cursor := Next (I); - - begin - if I_Next = J then - Splice (Container, Before => I, Position => J); - - else - declare - J_Next : constant Cursor := Next (J); - - begin - if J_Next = I then - Splice (Container, Before => J, Position => I); - - else - pragma Assert (Container.Length >= 3); - - Splice (Container, Before => I_Next, Position => J); - Splice (Container, Before => J_Next, Position => I); - end if; - end; - end if; - end; - end Swap_Links; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unchecked_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Process (Position.Node.Element); - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = null then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - -- An invariant of a node is that its Previous and Next components can - -- be null, or designate a different node. Operation Free sets the - -- access value components of the node to designate the node itself - -- before actually deallocating the node, thus deliberately violating - -- the node invariant. This gives us a simple way to detect a dangling - -- reference to a node. - - if Position.Node.Next = Position.Node then - return False; - end if; - - if Position.Node.Prev = Position.Node then - return False; - end if; - - -- In practice the tests above will detect most instances of a dangling - -- reference. If we get here, it means that the invariants of the - -- designated node are satisfied (they at least appear to be satisfied), - -- so we perform some more tests, to determine whether invariants of the - -- designated list are satisfied too. - - declare - L : List renames Position.Container.all; - - begin - if L.Length = 0 then - return False; - end if; - - if L.First = null then - return False; - end if; - - if L.Last = null then - return False; - end if; - - if L.First.Prev /= null then - return False; - end if; - - if L.Last.Next /= null then - return False; - end if; - - if Position.Node.Prev = null and then Position.Node /= L.First then - return False; - end if; - - pragma Assert - (Position.Node.Prev /= null or else Position.Node = L.First); - - if Position.Node.Next = null and then Position.Node /= L.Last then - return False; - end if; - - pragma Assert - (Position.Node.Next /= null - or else Position.Node = L.Last); - - if L.Length = 1 then - return L.First = L.Last; - end if; - - if L.First = L.Last then - return False; - end if; - - if L.First.Next = null then - return False; - end if; - - if L.Last.Prev = null then - return False; - end if; - - if L.First.Next.Prev /= L.First then - return False; - end if; - - if L.Last.Prev.Next /= L.Last then - return False; - end if; - - if L.Length = 2 then - if L.First.Next /= L.Last then - return False; - elsif L.Last.Prev /= L.First then - return False; - else - return True; - end if; - end if; - - if L.First.Next = L.Last then - return False; - end if; - - if L.Last.Prev = L.First then - return False; - end if; - - -- Eliminate earlier possibility - - if Position.Node = L.First then - return True; - end if; - - pragma Assert (Position.Node.Prev /= null); - - -- Eliminate earlier possibility - - if Position.Node = L.Last then - return True; - end if; - - pragma Assert (Position.Node.Next /= null); - - if Position.Node.Next.Prev /= Position.Node then - return False; - end if; - - if Position.Node.Prev.Next /= Position.Node then - return False; - end if; - - if L.Length = 3 then - if L.First.Next /= Position.Node then - return False; - elsif L.Last.Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List) - is - Node : Node_Access; - - begin - Count_Type'Base'Write (Stream, Item.Length); - - Node := Item.First; - while Node /= null loop - Element_Type'Write (Stream, Node.Element); - Node := Node.Next; - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads deleted file mode 100644 index a1bc17c..0000000 --- a/gcc/ada/a-cdlili.ads +++ /dev/null @@ -1,406 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type is private; - - with function "=" (Left, Right : Element_Type) - return Boolean is <>; - -package Ada.Containers.Doubly_Linked_Lists is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type List is tagged private - with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (List); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_List : constant List; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package List_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : List) return Boolean; - - function Length (Container : List) return Count_Type; - - function Is_Empty (Container : List) return Boolean; - - procedure Clear (Container : in out List); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out List; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out List; Source : List); - - function Copy (Source : List) return List; - - procedure Move - (Target : in out List; - Source : in out List); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Insert - (Container : in out List; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1); - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1); - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1); - - procedure Reverse_Elements (Container : in out List); - - function Iterate (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'Class; - - function Iterate (Container : List; Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'Class; - - procedure Swap - (Container : in out List; - I, J : Cursor); - - procedure Swap_Links - (Container : in out List; - I, J : Cursor); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor); - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor); - - function First (Container : List) return Cursor; - - function First_Element (Container : List) return Element_Type; - - function Last (Container : List) return Cursor; - - function Last_Element (Container : List) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Contains - (Container : List; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : List) return Boolean; - - procedure Sort (Container : in out List); - - procedure Merge (Target, Source : in out List); - - end Generic_Sorting; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - type Node_Type; - type Node_Access is access Node_Type; - - type Node_Type is - limited record - Element : aliased Element_Type; - Next : Node_Access; - Prev : Node_Access; - end record; - - use Ada.Finalization; - use Ada.Streams; - - type List is - new Controlled with record - First : Node_Access := null; - Last : Node_Access := null; - Length : Count_Type := 0; - TC : aliased Tamper_Counts; - end record; - - overriding procedure Adjust (Container : in out List); - - overriding procedure Finalize (Container : in out List) renames Clear; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List); - - for List'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List); - - for List'Write use Write; - - type List_Access is access all List; - for List_Access'Storage_Size use 0; - - type Cursor is - record - Container : List_Access; - Node : Node_Access; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased List'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_List : constant List := (Controlled with others => <>); - - No_Element : constant Cursor := Cursor'(null, null); - - type Iterator is new Limited_Controlled and - List_Iterator_Interfaces.Reversible_Iterator with - record - Container : List_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/a-cfdlli.adb b/gcc/ada/a-cfdlli.adb deleted file mode 100644 index 0b4674d..0000000 --- a/gcc/ada/a-cfdlli.adb +++ /dev/null @@ -1,1894 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with System; use type System.Address; - -package body Ada.Containers.Formal_Doubly_Linked_Lists with - SPARK_Mode => Off -is - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type); - - procedure Free (Container : in out List; X : Count_Type); - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type); - - function Vet (L : List; Position : Cursor) return Boolean; - - --------- - -- "=" -- - --------- - - function "=" (Left : List; Right : List) return Boolean is - LI : Count_Type; - RI : Count_Type; - - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Length /= Right.Length then - return False; - end if; - - LI := Left.First; - RI := Left.First; - while LI /= 0 loop - if Left.Nodes (LI).Element /= Right.Nodes (LI).Element then - return False; - end if; - - LI := Left.Nodes (LI).Next; - RI := Right.Nodes (RI).Next; - end loop; - - return True; - end "="; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Container : in out List; - New_Item : Element_Type; - New_Node : out Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Free >= 0 then - New_Node := Container.Free; - N (New_Node).Element := New_Item; - Container.Free := N (New_Node).Next; - - else - New_Node := abs Container.Free; - N (New_Node).Element := New_Item; - Container.Free := Container.Free - 1; - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out List; New_Item : Element_Type) is - begin - Insert (Container, No_Element, New_Item, 1); - end Append; - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, No_Element, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out List; Source : List) is - N : Node_Array renames Source.Nodes; - J : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - J := Source.First; - while J /= 0 loop - Append (Target, N (J).Element, 1); - J := N (J).Next; - end loop; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Container.Length = 0 then - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - return; - end if; - - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - while Container.Length > 1 loop - X := Container.First; - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - - X := Container.First; - - Container.First := 0; - Container.Last := 0; - Container.Length := 0; - - Free (Container, X); - end Clear; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : List; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : List; - Capacity : Count_Type := 0) return List - is - C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); - N : Count_Type; - P : List (C); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - N := 1; - while N <= Source.Capacity loop - P.Nodes (N).Prev := Source.Nodes (N).Prev; - P.Nodes (N).Next := Source.Nodes (N).Next; - P.Nodes (N).Element := Source.Nodes (N).Element; - N := N + 1; - end loop; - - P.Free := Source.Free; - P.Length := Source.Length; - P.First := Source.First; - P.Last := Source.Last; - - if P.Free >= 0 then - N := Source.Capacity + 1; - while N <= C loop - Free (P, N); - N := N + 1; - end loop; - end if; - - return P; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out List; Position : in out Cursor) is - begin - Delete - (Container => Container, - Position => Position, - Count => 1); - end Delete; - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if not Has_Element (Container => Container, - Position => Position) - then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; - return; - end if; - - if Count = 0 then - Position := No_Element; - return; - end if; - - for Index in 1 .. Count loop - pragma Assert (Container.Length >= 2); - - X := Position.Node; - Container.Length := Container.Length - 1; - - if X = Container.Last then - Position := No_Element; - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Free (Container, X); - return; - end if; - - Position.Node := N (X).Next; - pragma Assert (N (Position.Node).Prev >= 0); - - N (N (X).Next).Prev := N (X).Prev; - N (N (X).Prev).Next := N (X).Next; - - Free (Container, X); - end loop; - - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out List) is - begin - Delete_First - (Container => Container, - Count => 1); - end Delete_First; - - procedure Delete_First (Container : in out List; Count : Count_Type) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - for J in 1 .. Count loop - X := Container.First; - pragma Assert (N (N (X).Next).Prev = Container.First); - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out List) is - begin - Delete_Last - (Container => Container, - Count => 1); - end Delete_Last; - - procedure Delete_Last (Container : in out List; Count : Count_Type) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (N (N (X).Prev).Next = Container.Last); - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : List; - Position : Cursor) return Element_Type - is - begin - if not Has_Element (Container => Container, Position => Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - return Container.Nodes (Position.Node).Element; - end Element; - - ---------- - -- Find -- - ---------- - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - From : Count_Type := Position.Node; - - begin - if From = 0 and Container.Length = 0 then - return No_Element; - end if; - - if From = 0 then - From := Container.First; - end if; - - if Position.Node /= 0 and then not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - while From /= 0 loop - if Container.Nodes (From).Element = Item then - return (Node => From); - end if; - - From := Container.Nodes (From).Next; - end loop; - - return No_Element; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : List) return Cursor is - begin - if Container.First = 0 then - return No_Element; - end if; - - return (Node => Container.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : List) return Element_Type is - F : constant Count_Type := Container.First; - - begin - if F = 0 then - raise Constraint_Error with "list is empty"; - else - return Container.Nodes (F).Element; - end if; - end First_Element; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : List) is null; - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - Elem : Element_Type; - - begin - for Index in 1 .. M.Length (Container) loop - Elem := Element (Container, Index); - - if not M.Contains (Left, 1, M.Length (Left), Elem) - and then not M.Contains (Right, 1, M.Length (Right), Elem) - then - return False; - end if; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Positive_Count_Type := 1; - L_Lst : Count_Type; - Right : M.Sequence; - R_Fst : Positive_Count_Type := 1; - R_Lst : Count_Type) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Count_Type := R_Fst - 1; - - begin - while not Found and J < R_Lst loop - J := J + 1; - if Element (Left, I) = Element (Right, J) then - Found := True; - end if; - end loop; - - if not Found then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_Included; - - ------------------------- - -- M_Elements_Reversed -- - ------------------------- - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - is - L : constant Count_Type := M.Length (Left); - - begin - if L /= M.Length (Right) then - return False; - end if; - - for I in 1 .. L loop - if Element (Left, I) /= Element (Right, L - I + 1) then - return False; - end if; - end loop; - - return True; - end M_Elements_Reversed; - - ------------------------ - -- M_Elements_Swapted -- - ------------------------ - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Positive_Count_Type; - Y : Positive_Count_Type) return Boolean - is - begin - if M.Length (Left) /= M.Length (Right) - or else Element (Left, X) /= Element (Right, Y) - or else Element (Left, Y) /= Element (Right, X) - then - return False; - end if; - - for I in 1 .. M.Length (Left) loop - if I /= X and then I /= Y - and then Element (Left, I) /= Element (Right, I) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Swapped; - - ----------- - -- Model -- - ----------- - - function Model (Container : List) return M.Sequence is - Position : Count_Type := Container.First; - R : M.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := M.Add (R, Container.Nodes (Position).Element); - Position := Container.Nodes (Position).Next; - end loop; - - return R; - end Model; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (M_Left : M.Sequence; - M_Right : M.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > M.Length (M_Left) - or else P.Get (P_Right, C) > M.Length (M_Right) - or else M.Get (M_Left, P.Get (P_Left, C)) /= - M.Get (M_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - for C of P_Right loop - if not P.Has_Key (P_Left, C) then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------- - -- P_Positions_Shifted -- - ------------------------- - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) + Count - then - return False; - end if; - - else - if P.Has_Key (Small, Cu) then - return False; - end if; - end if; - end; - end loop; - - return True; - end P_Positions_Shifted; - - ------------------------- - -- P_Positions_Swapped -- - ------------------------- - - function P_Positions_Swapped - (Left : P.Map; - Right : P.Map; - X : Cursor; - Y : Cursor) return Boolean - is - begin - if not P.Has_Key (Left, X) - or not P.Has_Key (Left, Y) - or not P.Has_Key (Right, X) - or not P.Has_Key (Right, Y) - then - return False; - end if; - - if P.Get (Left, X) /= P.Get (Right, Y) - or P.Get (Left, Y) /= P.Get (Right, X) - then - return False; - end if; - - for C of Left loop - if not P.Has_Key (Right, C) then - return False; - end if; - end loop; - - for C of Right loop - if not P.Has_Key (Left, C) - or else (C /= X - and C /= Y - and P.Get (Left, C) /= P.Get (Right, C)) - then - return False; - end if; - end loop; - - return True; - end P_Positions_Swapped; - - --------------------------- - -- P_Positions_Truncated -- - --------------------------- - - function P_Positions_Truncated - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - return False; - - elsif P.Has_Key (Small, Cu) then - return False; - end if; - end; - end loop; - - return True; - end P_Positions_Truncated; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : List) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.First; - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); - Position := Container.Nodes (Position).Next; - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (Container : in out List; X : Count_Type) is - pragma Assert (X > 0); - pragma Assert (X <= Container.Capacity); - - N : Node_Array renames Container.Nodes; - - begin - N (X).Prev := -1; -- Node is deallocated (not on active list) - - if Container.Free >= 0 then - N (X).Next := Container.Free; - Container.Free := X; - - elsif X + 1 = abs Container.Free then - N (X).Next := 0; -- Not strictly necessary, but marginally safer - Container.Free := Container.Free + 1; - - else - Container.Free := abs Container.Free; - - if Container.Free > Container.Capacity then - Container.Free := 0; - - else - for J in Container.Free .. Container.Capacity - 1 loop - N (J).Next := J + 1; - end loop; - - N (Container.Capacity).Next := 0; - end if; - - N (X).Next := Container.Free; - Container.Free := X; - end if; - end Free; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting with SPARK_Mode => Off is - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Elements_Sorted -- - ----------------------- - - function M_Elements_Sorted (Container : M.Sequence) return Boolean is - begin - if M.Length (Container) = 0 then - return True; - end if; - - declare - E1 : Element_Type := Element (Container, 1); - - begin - for I in 2 .. M.Length (Container) loop - declare - E2 : constant Element_Type := Element (Container, I); - - begin - if E2 < E1 then - return False; - end if; - - E1 := E2; - end; - end loop; - end; - - return True; - end M_Elements_Sorted; - - end Formal_Model; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : List) return Boolean is - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := Container.First; - - begin - for J in 2 .. Container.Length loop - if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then - return False; - else - Node := Nodes (Node).Next; - end if; - end loop; - - return True; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out List; Source : in out List) is - LN : Node_Array renames Target.Nodes; - RN : Node_Array renames Source.Nodes; - LI : Cursor; - RI : Cursor; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - LI := First (Target); - RI := First (Source); - while RI.Node /= 0 loop - pragma Assert - (RN (RI.Node).Next = 0 - or else not (RN (RN (RI.Node).Next).Element < - RN (RI.Node).Element)); - - if LI.Node = 0 then - Splice (Target, No_Element, Source); - return; - end if; - - pragma Assert - (LN (LI.Node).Next = 0 - or else not (LN (LN (LI.Node).Next).Element < - LN (LI.Node).Element)); - - if RN (RI.Node).Element < LN (LI.Node).Element then - declare - RJ : Cursor := RI; - pragma Warnings (Off, RJ); - begin - RI.Node := RN (RI.Node).Next; - Splice (Target, LI, Source, RJ); - end; - - else - LI.Node := LN (LI.Node).Next; - end if; - end loop; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out List) is - N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot : Count_Type; Back : Count_Type); - procedure Sort (Front : Count_Type; Back : Count_Type); - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot : Count_Type; Back : Count_Type) is - Node : Count_Type; - - begin - Node := N (Pivot).Next; - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front : Count_Type; Back : Count_Type) is - Pivot : Count_Type; - - begin - if Front = 0 then - Pivot := Container.First; - else - Pivot := N (Front).Next; - end if; - - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - Sort (Front => 0, Back => 0); - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Sort; - - end Generic_Sorting; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : List; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - end if; - - return Container.Nodes (Position.Node).Prev /= -1; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type) - is - J : Count_Type; - - begin - if Before.Node /= 0 then - pragma Assert (Vet (Container, Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - - if Container.Length > Container.Capacity - Count then - raise Constraint_Error with "new length exceeds capacity"; - end if; - - Allocate (Container, New_Item, New_Node => J); - Insert_Internal (Container, Before.Node, New_Node => J); - Position := (Node => J); - - for Index in 2 .. Count loop - Allocate (Container, New_Item, New_Node => J); - Insert_Internal (Container, Before.Node, New_Node => J); - end loop; - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor) - is - begin - Insert - (Container => Container, - Before => Before, - New_Item => New_Item, - Position => Position, - Count => 1); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type) - is - Position : Cursor; - - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type) - is - Position : Cursor; - - begin - Insert (Container, Before, New_Item, Position, 1); - end Insert; - - --------------------- - -- Insert_Internal -- - --------------------- - - procedure Insert_Internal - (Container : in out List; - Before : Count_Type; - New_Node : Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Length = 0 then - pragma Assert (Before = 0); - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - - Container.First := New_Node; - Container.Last := New_Node; - - N (Container.First).Prev := 0; - N (Container.Last).Next := 0; - - elsif Before = 0 then - pragma Assert (N (Container.Last).Next = 0); - - N (Container.Last).Next := New_Node; - N (New_Node).Prev := Container.Last; - - Container.Last := New_Node; - N (Container.Last).Next := 0; - - elsif Before = Container.First then - pragma Assert (N (Container.First).Prev = 0); - - N (Container.First).Prev := New_Node; - N (New_Node).Next := Container.First; - - Container.First := New_Node; - N (Container.First).Prev := 0; - - else - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - N (New_Node).Next := Before; - N (New_Node).Prev := N (Before).Prev; - - N (N (Before).Prev).Next := New_Node; - N (Before).Prev := New_Node; - end if; - - Container.Length := Container.Length + 1; - end Insert_Internal; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : List) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ---------- - -- Last -- - ---------- - - function Last (Container : List) return Cursor is - begin - if Container.Last = 0 then - return No_Element; - end if; - - return (Node => Container.Last); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : List) return Element_Type is - L : constant Count_Type := Container.Last; - - begin - if L = 0 then - raise Constraint_Error with "list is empty"; - else - return Container.Nodes (L).Element; - end if; - end Last_Element; - - ------------ - -- Length -- - ------------ - - function Length (Container : List) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out List; Source : in out List) is - N : Node_Array renames Source.Nodes; - X : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - while Source.Length > 1 loop - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last /= Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy first element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); -- optimize away??? - - -- Unlink first node of Source - - Source.First := N (X).Next; - N (Source.First).Prev := 0; - - Source.Length := Source.Length - 1; - - -- The representation invariants for Source have been restored. It is - -- now safe to free the unlinked node, without fear of corrupting the - -- active links of Source. - - -- Note that the algorithm we use here models similar algorithms used - -- in the unbounded form of the doubly-linked list container. In that - -- case, Free is an instantation of Unchecked_Deallocation, which can - -- fail (because PE will be raised if controlled Finalize fails), so - -- we must defer the call until the last step. Here in the bounded - -- form, Free merely links the node we have just "deallocated" onto a - -- list of inactive nodes, so technically Free cannot fail. However, - -- for consistency, we handle Free the same way here as we do for the - -- unbounded form, with the pessimistic assumption that it can fail. - - Free (Source, X); - end loop; - - if Source.Length = 1 then - pragma Assert (Source.First in 1 .. Source.Capacity); - pragma Assert (Source.Last = Source.First); - pragma Assert (N (Source.First).Prev = 0); - pragma Assert (N (Source.Last).Next = 0); - - -- Copy element from Source to Target - - X := Source.First; - Append (Target, N (X).Element); - - -- Unlink node of Source - - Source.First := 0; - Source.Last := 0; - Source.Length := 0; - - -- Return the unlinked node to the free store - - Free (Source, X); - end if; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Container : List; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - function Next (Container : List; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Program_Error with "Position cursor has no element"; - end if; - - return (Node => Container.Nodes (Position.Node).Next); - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend (Container : in out List; New_Item : Element_Type) is - begin - Insert (Container, First (Container), New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, First (Container), New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Container : List; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - function Previous (Container : List; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Program_Error with "Position cursor has no element"; - end if; - - return (Node => Container.Nodes (Position.Node).Prev); - end Previous; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - N : Node_Array renames Container.Nodes; - I : Count_Type := Container.First; - J : Count_Type := Container.Last; - - procedure Swap (L : Count_Type; R : Count_Type); - - ---------- - -- Swap -- - ---------- - - procedure Swap (L : Count_Type; R : Count_Type) is - LN : constant Count_Type := N (L).Next; - LP : constant Count_Type := N (L).Prev; - - RN : constant Count_Type := N (R).Next; - RP : constant Count_Type := N (R).Prev; - - begin - if LP /= 0 then - N (LP).Next := R; - end if; - - if RN /= 0 then - N (RN).Prev := L; - end if; - - N (L).Next := RN; - N (R).Prev := LP; - - if LN = R then - pragma Assert (RP = L); - - N (L).Prev := R; - N (R).Next := L; - - else - N (L).Prev := RP; - N (RP).Next := L; - - N (R).Next := LN; - N (LN).Prev := R; - end if; - end Swap; - - -- Start of processing for Reverse_Elements - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); - - J := N (J).Next; - exit when I = J; - - I := N (I).Prev; - exit when I = J; - - Swap (L => J, R => I); - - I := N (I).Next; - exit when I = J; - - J := N (J).Prev; - exit when I = J; - end loop; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - CFirst : Count_Type := Position.Node; - - begin - if CFirst = 0 then - CFirst := Container.Last; - end if; - - if Container.Length = 0 then - return No_Element; - - else - while CFirst /= 0 loop - if Container.Nodes (CFirst).Element = Item then - return (Node => CFirst); - else - CFirst := Container.Nodes (CFirst).Prev; - end if; - end loop; - - return No_Element; - end if; - end Reverse_Find; - - ------------ - -- Splice -- - ------------ - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - is - SN : Node_Array renames Source.Nodes; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Before.Node /= 0 then - pragma Assert (Vet (Target, Before), "bad cursor in Splice"); - end if; - - pragma Assert (SN (Source.First).Prev = 0); - pragma Assert (SN (Source.Last).Next = 0); - - if Target.Length > Count_Type'Base'Last - Source.Length then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - if Target.Length + Source.Length > Target.Capacity then - raise Constraint_Error; - end if; - - loop - Insert (Target, Before, SN (Source.Last).Element); - Delete_Last (Source); - exit when Is_Empty (Source); - end loop; - end Splice; - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - is - Target_Position : Cursor; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Source, Position), "bad Position cursor in Splice"); - - if Target.Length >= Target.Capacity then - raise Constraint_Error; - end if; - - Insert - (Container => Target, - Before => Before, - New_Item => Source.Nodes (Position.Node).Element, - Position => Target_Position); - - Delete (Source, Position); - Position := Target_Position; - end Splice; - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - is - N : Node_Array renames Container.Nodes; - - begin - if Before.Node /= 0 then - pragma Assert - (Vet (Container, Before), "bad Before cursor in Splice"); - end if; - - if Position.Node = 0 then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad Position cursor in Splice"); - - if Position.Node = Before.Node - or else N (Position.Node).Next = Before.Node - then - return; - end if; - - pragma Assert (Container.Length >= 2); - - if Before.Node = 0 then - pragma Assert (Position.Node /= Container.Last); - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.Last).Next := Position.Node; - N (Position.Node).Prev := Container.Last; - - Container.Last := Position.Node; - N (Container.Last).Next := 0; - - return; - end if; - - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.First).Prev := Position.Node; - N (Position.Node).Next := Container.First; - - Container.First := Position.Node; - N (Container.First).Prev := 0; - - return; - end if; - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - elsif Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (N (Before.Node).Prev).Next := Position.Node; - N (Position.Node).Prev := N (Before.Node).Prev; - - N (Before.Node).Prev := Position.Node; - N (Position.Node).Next := Before.Node; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Splice; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out List; - I : Cursor; - J : Cursor) - is - begin - if I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Node = J.Node then - return; - end if; - - pragma Assert (Vet (Container, I), "bad I cursor in Swap"); - pragma Assert (Vet (Container, J), "bad J cursor in Swap"); - - declare - NN : Node_Array renames Container.Nodes; - NI : Node_Type renames NN (I.Node); - NJ : Node_Type renames NN (J.Node); - - EI_Copy : constant Element_Type := NI.Element; - - begin - NI.Element := NJ.Element; - NJ.Element := EI_Copy; - end; - end Swap; - - ---------------- - -- Swap_Links -- - ---------------- - - procedure Swap_Links - (Container : in out List; - I : Cursor; - J : Cursor) - is - I_Next : Cursor; - J_Next : Cursor; - - begin - if I.Node = 0 then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Node = 0 then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Node = J.Node then - return; - end if; - - pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); - pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); - - I_Next := Next (Container, I); - - if I_Next = J then - Splice (Container, Before => I, Position => J); - - else - J_Next := Next (Container, J); - - if J_Next = I then - Splice (Container, Before => J, Position => I); - - else - pragma Assert (Container.Length >= 3); - Splice (Container, Before => I_Next, Position => J); - Splice (Container, Before => J_Next, Position => I); - end if; - end if; - end Swap_Links; - - --------- - -- Vet -- - --------- - - function Vet (L : List; Position : Cursor) return Boolean is - N : Node_Array renames L.Nodes; - - begin - if L.Length = 0 then - return False; - end if; - - if L.First = 0 then - return False; - end if; - - if L.Last = 0 then - return False; - end if; - - if Position.Node > L.Capacity then - return False; - end if; - - if N (Position.Node).Prev < 0 - or else N (Position.Node).Prev > L.Capacity - then - return False; - end if; - - if N (Position.Node).Next > L.Capacity then - return False; - end if; - - if N (L.First).Prev /= 0 then - return False; - end if; - - if N (L.Last).Next /= 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 and then Position.Node /= L.First then - return False; - end if; - - if N (Position.Node).Next = 0 and then Position.Node /= L.Last then - return False; - end if; - - if L.Length = 1 then - return L.First = L.Last; - end if; - - if L.First = L.Last then - return False; - end if; - - if N (L.First).Next = 0 then - return False; - end if; - - if N (L.Last).Prev = 0 then - return False; - end if; - - if N (N (L.First).Next).Prev /= L.First then - return False; - end if; - - if N (N (L.Last).Prev).Next /= L.Last then - return False; - end if; - - if L.Length = 2 then - if N (L.First).Next /= L.Last then - return False; - end if; - - if N (L.Last).Prev /= L.First then - return False; - end if; - - return True; - end if; - - if N (L.First).Next = L.Last then - return False; - end if; - - if N (L.Last).Prev = L.First then - return False; - end if; - - if Position.Node = L.First then - return True; - end if; - - if Position.Node = L.Last then - return True; - end if; - - if N (Position.Node).Next = 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 then - return False; - end if; - - if N (N (Position.Node).Next).Prev /= Position.Node then - return False; - end if; - - if N (N (Position.Node).Prev).Next /= Position.Node then - return False; - end if; - - if L.Length = 3 then - if N (L.First).Next /= Position.Node then - return False; - end if; - - if N (L.Last).Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end Vet; - -end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cfdlli.ads b/gcc/ada/a-cfdlli.ads deleted file mode 100644 index f6638cb..0000000 --- a/gcc/ada/a-cfdlli.ads +++ /dev/null @@ -1,1623 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; - -generic - type Element_Type is private; - -package Ada.Containers.Formal_Doubly_Linked_Lists with - SPARK_Mode -is - pragma Annotate (CodePeer, Skip_Analysis); - - type List (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (List); - pragma Preelaborable_Initialization (List); - - type Cursor is record - Node : Count_Type := 0; - end record; - - No_Element : constant Cursor := Cursor'(Node => 0); - - Empty_List : constant List; - - function Length (Container : List) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Positive_Count_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in 1 .. M.Length (Container) => - (for some J in 1 .. M.Length (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in 1 .. M.Length (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Positive_Count_Type := 1; - L_Lst : Count_Type; - Right : M.Sequence; - R_Fst : Positive_Count_Type := 1; - R_Lst : Count_Type) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in 1 .. M.Length (Left) => - Element (Left, I) = - Element (Right, M.Length (Left) - I + 1)) - and (for all I in 1 .. M.Length (Left) => - Element (Right, I) = - Element (Left, M.Length (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Positive_Count_Type; - Y : Positive_Count_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Length (Left) and Y <= M.Length (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function P_Positions_Swapped - (Left : P.Map; - Right : P.Map; - X : Cursor; - Y : Cursor) return Boolean - -- Left and Right contain the same cursors, but the positions of X and Y - -- are reversed. - with - Ghost, - Global => null, - Post => - P_Positions_Swapped'Result = - (P.Same_Keys (Left, Right) - and P.Elements_Equal_Except (Left, Right, X, Y) - and P.Has_Key (Left, X) - and P.Has_Key (Left, Y) - and P.Get (Left, X) = P.Get (Right, Y) - and P.Get (Left, Y) = P.Get (Right, X)); - - function P_Positions_Truncated - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Ghost, - Global => null, - Post => - P_Positions_Truncated'Result = - - -- Big contains all cursors of Small at the same position - - (Small <= Big - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Mapping_Preserved - (M_Left : M.Sequence; - M_Right : M.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Left and Right contain the same cursors - - P.Same_Keys (P_Left, P_Right) - - -- Mappings from cursors to elements induced by M_Left, P_Left - -- and M_Right, P_Right are the same. - - and (for all C of P_Left => - M.Get (M_Left, P.Get (P_Left, C)) = - M.Get (M_Right, P.Get (P_Right, C)))); - - function Model (Container : List) return M.Sequence with - -- The high-level model of a list is a sequence of elements. Cursors are - -- not represented in this model. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); - - function Positions (Container : List) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and map them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length. - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : List) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access to the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level cursor-aware view of a container to a high-level - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Elt of Model (Container) => - (for some I of Positions (Container) => - M.Get (Model (Container), P.Get (Positions (Container), I)) = - Elt)); - - function Element - (S : M.Sequence; - I : Count_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : List) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Is_Empty (Container : List) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out List) with - Global => null, - Post => Length (Container) = 0; - - procedure Assign (Target : in out List; Source : List) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => Model (Target) = Model (Source); - - function Copy (Source : List; Capacity : Count_Type := 0) return List with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Element - (Container : List; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - Element (Model (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Cursors are preserved - - and Positions (Container)'Old = Positions (Container) - - -- The element at the position of Position in Container is New_Item - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- Other elements are preserved - - and M.Equal_Except - (Model (Container)'Old, - Model (Container), - P.Get (Positions (Container), Position)); - - procedure Move (Target : in out List; Source : in out List) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => Model (Target) = Model (Source'Old) and Length (Source) = 0; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + 1, - Contract_Cases => - (Before = No_Element => - - -- Positions contains a new mapping from the last cursor of - -- Container to its length. - - P.Get (Positions (Container), Last (Container)) = Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at the previous position of Before in - -- Container. - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = New_Item - - -- A new cursor has been inserted at position Before in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before))); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Container.Capacity - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Before = No_Element => - - -- The elements of Container are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Container contains Count times New_Item at the end - - and M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item) - - -- A Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count), - - others => - - -- The elements of Container located before Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Before - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before), - Lst => - P.Get (Positions (Container)'Old, Before) - 1 + Count, - Item => New_Item) - - -- Count cursors have been inserted at position Before in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container)'Old, Before), - Count => Count)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - and P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = Length (Container) - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is stored at Position in Container - - and Element - (Model (Container), - P.Get (Positions (Container), Position)) = New_Item - - -- A new cursor has been inserted at position Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position)); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Container.Capacity - Count - and then (Has_Element (Container, Before) - or else Before = No_Element), - Post => Length (Container) = Length (Container)'Old + Count, - Contract_Cases => - (Count = 0 => - Position = Before - and Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - others => - - -- Positions is valid in Container and it is located either before - -- Before if it is valid in Container or at the end if it is - -- No_Element. - - P.Has_Key (Positions (Container), Position) - and (if Before = No_Element then - P.Get (Positions (Container), Position) = - Length (Container)'Old + 1 - else - P.Get (Positions (Container), Position) = - P.Get (Positions (Container)'Old, Before)) - - -- The elements of Container located before Position are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => Count) - - -- Container contains Count times New_Item after position Position - - and M.Constant_Range - (Container => Model (Container), - Fst => P.Get (Positions (Container), Position), - Lst => - P.Get (Positions (Container), Position) - 1 + Count, - Item => New_Item) - - -- Count cursor have been inserted at Position in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position), - Count => Count)); - - procedure Prepend (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Container.Capacity, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => 1) - - -- New_Item is the first element of Container - - and Element (Model (Container), 1) = New_Item - - -- A new cursor has been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1); - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Container.Capacity - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => Length (Container)'Old, - Offset => Count) - - -- Container starts with Count times New_Item - - and M.Constant_Range - (Container => Model (Container), - Fst => 1, - Lst => Count, - Item => New_Item) - - -- Count cursors have been inserted at the beginning of Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => 1, - Count => Count); - - procedure Append (Container : in out List; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Container.Capacity, - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Positions contains a new mapping from the last cursor of Container - -- to its length. - - and P.Get (Positions (Container), Last (Container)) = - Length (Container) - - -- Other cursors come from Container'Old - - and P.Keys_Included_Except - (Left => Positions (Container), - Right => Positions (Container)'Old, - New_Key => Last (Container)) - - -- Cursors of Container'Old keep the same position - - and Positions (Container)'Old <= Positions (Container) - - -- Model contains a new element New_Item at the end - - and Element (Model (Container), Length (Container)) = New_Item - - -- Elements of Container'Old are preserved - - and Model (Container)'Old <= Model (Container); - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Container.Capacity - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Container contains Count times New_Item at the end - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Length (Container)'Old + 1, - Lst => Length (Container), - Item => New_Item)) - - -- Count cursors have been inserted at the end of Container - - and P_Positions_Truncated - (Positions (Container)'Old, - Positions (Container), - Cut => Length (Container)'Old + 1, - Count => Count); - - procedure Delete (Container : in out List; Position : in out Cursor) with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- Position is set to No_Element - - and Position = No_Element - - -- The elements of Container located before Position are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count < P.Get (Positions (Container), Position) => - Length (Container) = - P.Get (Positions (Container)'Old, Position'Old) - 1 - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => Count) - - -- Count cursors have been removed from Container at Position - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old), - Count => Count)); - - procedure Delete_First (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- The first cursor of Container has been removed - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1); - - procedure Delete_First (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => Count) - - -- The first Count cursors have been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1, - Count => Count)); - - procedure Delete_Last (Container : in out List) with - Global => null, - Pre => not Is_Empty (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- The last cursor of Container has been removed - - and not P.Has_Key (Positions (Container), Last (Container)'Old) - - -- Other cursors are still valid - - and P.Keys_Included_Except - (Left => Positions (Container)'Old, - Right => Positions (Container)'Old, - New_Key => Last (Container)'Old) - - -- The positions of other cursors are preserved - - and Positions (Container) <= Positions (Container)'Old; - - procedure Delete_Last (Container : in out List; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => - Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old - - -- At most Count cursors have been removed at the end of Container - - and P_Positions_Truncated - (Positions (Container), - Positions (Container)'Old, - Cut => Length (Container) + 1, - Count => Count)); - - procedure Reverse_Elements (Container : in out List) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container)'Old, - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - - and Positions (Container) = Positions (Container)'Old; - - procedure Swap_Links - (Container : in out List; - I : Cursor; - J : Cursor) - with - Global => null, - Pre => Has_Element (Container, I) and then Has_Element (Container, J), - Post => - M_Elements_Swapped - (Model (Container'Old), - Model (Container), - X => P.Get (Positions (Container)'Old, I), - Y => P.Get (Positions (Container)'Old, J)) - and P_Positions_Swapped - (Positions (Container)'Old, Positions (Container), I, J); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - -- Target and Source should not be aliased - with - Global => null, - Pre => - Length (Source) <= Target.Capacity - Length (Target) - and then (Has_Element (Target, Before) - or else Before = No_Element), - Post => - Length (Source) = 0 - and Length (Target) = Length (Target)'Old + Length (Source)'Old, - Contract_Cases => - (Before = No_Element => - - -- The elements of Target are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => Length (Target)'Old) - - -- The elements of Source are appended to target, the order is not - -- specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => Length (Target)'Old + 1, - R_Lst => Length (Target)) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => Length (Target)'Old + 1, - L_Lst => Length (Target), - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Cursors have been inserted at the end of Target - - and P_Positions_Truncated - (Positions (Target)'Old, - Positions (Target), - Cut => Length (Target)'Old + 1, - Count => Length (Source)'Old), - - others => - - -- The elements of Target located before Before are preserved - - M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target)'Old, Before) - 1) - - -- The elements of Source are inserted before Before, the order is - -- not specified. - - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Fst => P.Get (Positions (Target)'Old, Before), - R_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old) - - and M_Elements_Included - (Left => Model (Target), - L_Fst => P.Get (Positions (Target)'Old, Before), - L_Lst => - P.Get (Positions (Target)'Old, Before) - 1 + - Length (Source)'Old, - Right => Model (Source)'Old, - R_Lst => Length (Source)'Old) - - -- Other elements are shifted by the length of Source - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target)'Old, Before), - Lst => Length (Target)'Old, - Offset => Length (Source)'Old) - - -- Cursors have been inserted at position Before in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target)'Old, Before), - Count => Length (Source)'Old)); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - -- Target and Source should not be aliased - with - Global => null, - Pre => - (Has_Element (Target, Before) or else Before = No_Element) - and then Has_Element (Source, Position) - and then Length (Target) < Target.Capacity, - Post => - Length (Target) = Length (Target)'Old + 1 - and Length (Source) = Length (Source)'Old - 1 - - -- The elements of Source located before Position are preserved - - and M.Range_Equal - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => 1, - Lst => P.Get (Positions (Source)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Source)'Old, - Right => Model (Source), - Fst => P.Get (Positions (Source)'Old, Position'Old) + 1, - Lst => Length (Source)'Old, - Offset => -1) - - -- Position has been removed from Source - - and P_Positions_Shifted - (Positions (Source), - Positions (Source)'Old, - Cut => P.Get (Positions (Source)'Old, Position'Old)) - - -- Positions is valid in Target and it is located either before - -- Before if it is valid in Target or at the end if it is No_Element. - - and P.Has_Key (Positions (Target), Position) - and (if Before = No_Element then - P.Get (Positions (Target), Position) = Length (Target) - else - P.Get (Positions (Target), Position) = - P.Get (Positions (Target)'Old, Before)) - - -- The elements of Target located before Position are preserved - - and M.Range_Equal - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => 1, - Lst => P.Get (Positions (Target), Position) - 1) - - -- Other elements are shifted by 1 - - and M.Range_Shifted - (Left => Model (Target)'Old, - Right => Model (Target), - Fst => P.Get (Positions (Target), Position), - Lst => Length (Target)'Old, - Offset => 1) - - -- The element located at Position in Source is moved to Target - - and Element (Model (Target), - P.Get (Positions (Target), Position)) = - Element (Model (Source)'Old, - P.Get (Positions (Source)'Old, Position'Old)) - - -- A new cursor has been inserted at position Position in Target - - and P_Positions_Shifted - (Positions (Target)'Old, - Positions (Target), - Cut => P.Get (Positions (Target), Position)); - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - with - Global => null, - Pre => - (Has_Element (Container, Before) or else Before = No_Element) - and then Has_Element (Container, Position), - Post => Length (Container) = Length (Container)'Old, - Contract_Cases => - (Before = Position => - Model (Container) = Model (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - Before = No_Element => - - -- The elements located before Position are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1) - - -- The elements located after Position are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => Length (Container)'Old, - Offset => -1) - - -- The last element of Container is the one that was previously at - -- Position. - - and Element (Model (Container), - Length (Container)) = - Element (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)), - - others => - - -- The elements located before Position and Before are preserved - - M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => 1, - Lst => - Count_Type'Min - (P.Get (Positions (Container)'Old, Position) - 1, - P.Get (Positions (Container)'Old, Before) - 1)) - - -- The elements located after Position and Before are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => - Count_Type'Max - (P.Get (Positions (Container)'Old, Position) + 1, - P.Get (Positions (Container)'Old, Before) + 1), - Lst => Length (Container)) - - -- The elements located after Before and before Position are - -- shifted by 1 to the right. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Before) + 1, - Lst => P.Get (Positions (Container)'Old, Position) - 1, - Offset => 1) - - -- The elements located after Position and before Before are - -- shifted by 1 to the left. - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => P.Get (Positions (Container)'Old, Position) + 1, - Lst => P.Get (Positions (Container)'Old, Before) - 1, - Offset => -1) - - -- The element previously at Position is now before Before - - and Element - (Model (Container), - P.Get (Positions (Container)'Old, Before)) = - Element - (Model (Container)'Old, - P.Get (Positions (Container)'Old, Position)) - - -- Cursors from Container continue designating the same elements - - and Mapping_Preserved - (M_Left => Model (Container)'Old, - M_Right => Model (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container))); - - function First (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => First_Element'Result = M.Get (Model (Container), 1); - - function Last (Container : List) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : List) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = M.Get (Model (Container), Length (Container)); - - function Next (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : List; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : List; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container after Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => Length (Container), - Item => Item) - => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Find'Result)) = Item - - -- The result of Find is located after Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Find'Result) >= - P.Get (Positions (Container), Position)) - - -- It is the first occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - (if Position = No_Element then - 1 - else - P.Get (Positions (Container), Position)), - Lst => - P.Get (Positions (Container), Find'Result) - 1, - Item => Item)); - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - - -- If Item is not contained in Container before Position, Find returns - -- No_Element. - - (not M.Contains - (Container => Model (Container), - Fst => 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item) - => - Reverse_Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Reverse_Find'Result) - - -- The element designated by the result of Find is Item - - and Element - (Model (Container), - P.Get (Positions (Container), Reverse_Find'Result)) = Item - - -- The result of Find is located before Position - - and (if Position /= No_Element then - P.Get (Positions (Container), Reverse_Find'Result) <= - P.Get (Positions (Container), Position)) - - -- It is the last occurrence of Item in this slice - - and not M.Contains - (Container => Model (Container), - Fst => - P.Get (Positions (Container), - Reverse_Find'Result) + 1, - Lst => - (if Position = No_Element then - Length (Container) - else - P.Get (Positions (Container), Position)), - Item => Item)); - - function Contains - (Container : List; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = M.Contains (Container => Model (Container), - Fst => 1, - Lst => Length (Container), - Item => Item); - - function Has_Element - (Container : List; - Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in 1 .. M.Length (Container) => - (for all J in I .. M.Length (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : List) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out List) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Length (Container), - Right => Model (Container), - R_Lst => Length (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Length (Container), - Right => Model (Container)'Old, - R_Lst => Length (Container)); - - procedure Merge (Target : in out List; Source : in out List) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Target.Capacity - Length (Target), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Length (Target)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Length (Source)'Old, - Right => Model (Target), - R_Lst => Length (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - type Node_Type is record - Prev : Count_Type'Base := -1; - Next : Count_Type; - Element : Element_Type; - end record; - - function "=" (L, R : Node_Type) return Boolean is abstract; - - type Node_Array is array (Count_Type range <>) of Node_Type; - function "=" (L, R : Node_Array) return Boolean is abstract; - - type List (Capacity : Count_Type) is record - Free : Count_Type'Base := -1; - Length : Count_Type := 0; - First : Count_Type := 0; - Last : Count_Type := 0; - Nodes : Node_Array (1 .. Capacity) := (others => <>); - end record; - - Empty_List : constant List := (0, others => <>); - -end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cfhama.adb b/gcc/ada/a-cfhama.adb deleted file mode 100644 index bf782c6..0000000 --- a/gcc/ada/a-cfhama.adb +++ /dev/null @@ -1,888 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); - -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); - -with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Hashed_Maps with - SPARK_Mode => Off -is - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All local subprograms require comments ??? - - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - procedure Free - (HT : in out Map; - X : Count_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out Map; - Node : out Count_Type); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Container : Map; Position : Cursor) return Boolean; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is - new Hash_Tables.Generic_Bounded_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Key_Ops is - new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Length (Left) = 0 then - return True; - end if; - - declare - Node : Count_Type; - ENode : Count_Type; - - begin - Node := Left.First.Node; - while Node /= 0 loop - ENode := - Find - (Container => Right, - Key => Left.Nodes (Node).Key).Node; - - if ENode = 0 or else - Right.Nodes (ENode).Element /= Left.Nodes (Node).Element - then - return False; - end if; - - Node := HT_Ops.Next (Left, Node); - end loop; - - return True; - end; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Element (Source_Node : Count_Type); - pragma Inline (Insert_Element); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Source_Node); - begin - Insert (Target, N.Key, N.Element); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- correct exception ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - Insert_Elements (Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Map) return Count_Type is - begin - return Container.Nodes'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - HT_Ops.Clear (Container); - end Clear; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - is - C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); - Cu : Cursor; - H : Hash_Type; - N : Count_Type; - Target : Map (C, Source.Modulus); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - Target.Length := Source.Length; - Target.Free := Source.Free; - - H := 1; - while H <= Source.Modulus loop - Target.Buckets (H) := Source.Buckets (H); - H := H + 1; - end loop; - - N := 1; - while N <= Source.Capacity loop - Target.Nodes (N) := Source.Nodes (N); - N := N + 1; - end loop; - - while N <= C loop - Cu := (Node => N); - Free (Target, Cu.Node); - N := N + 1; - end loop; - - return Target; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Count_Type; - - begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete key not in map"; - end if; - - Free (Container, X); - end Delete; - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Delete has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - - Free (Container, Position.Node); - Position := No_Element; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Container.Nodes (Node).Element; - end Element; - - function Element (Container : Map; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Nodes (Position.Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Node.Key); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Count_Type; - begin - Key_Ops.Delete_Key_Sans_Free (Container, Key, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end First; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------- - -- Find -- - ---------- - - function Find - (Container : K.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. K.Length (Container) loop - if Equivalent_Keys (Key, K.Get (Container, I)) then - return I; - end if; - end loop; - return 0; - end Find; - - --------------------- - -- K_Keys_Included -- - --------------------- - - function K_Keys_Included - (Left : K.Sequence; - Right : K.Sequence) return Boolean - is - begin - for I in 1 .. K.Length (Left) loop - if not K.Contains (Right, 1, K.Length (Right), K.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end K_Keys_Included; - - ---------- - -- Keys -- - ---------- - - function Keys (Container : Map) return K.Sequence is - Position : Count_Type := HT_Ops.First (Container); - R : K.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := K.Add (R, Container.Nodes (Position).Key); - Position := HT_Ops.Next (Container, Position); - end loop; - - return R; - end Keys; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Map) is null; - - ----------------------- - -- Mapping_preserved -- - ----------------------- - - function Mapping_Preserved - (K_Left : K.Sequence; - K_Right : K.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > K.Length (K_Left) - or else P.Get (P_Right, C) > K.Length (K_Right) - or else K.Get (K_Left, P.Get (P_Left, C)) /= - K.Get (K_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ----------- - -- Model -- - ----------- - - function Model (Container : Map) return M.Map is - Position : Count_Type := HT_Ops.First (Container); - R : M.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - New_Key => Container.Nodes (Position).Key, - New_Item => Container.Nodes (Position).Element); - - Position := HT_Ops.Next (Container, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Map) return P.Map is - I : Count_Type := 1; - Position : Count_Type := HT_Ops.First (Container); - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); - Position := HT_Ops.Next (Container, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (HT : in out Map; X : Count_Type) is - begin - HT.Nodes (X).Has_Element := False; - HT_Ops.Free (HT, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is - procedure Allocate is - new HT_Ops.Generic_Allocate (Set_Element); - - begin - Allocate (HT, Node); - HT.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Map; Position : Cursor) return Boolean is - begin - if Position.Node = 0 - or else not Container.Nodes (Position.Node).Has_Element - then - return False; - else - return True; - end if; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Key); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - procedure Assign_Key (Node : in out Node_Type); - pragma Inline (Assign_Key); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Assign_Key); - - ----------------- - -- Assign_Key -- - ----------------- - - procedure Assign_Key (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Assign_Key; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - Local_Insert (Container, Key, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with "attempt to insert key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - --------- - -- Key -- - --------- - - function Key (Container : Map; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Key has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in function Key"); - - return Container.Nodes (Position.Node).Key; - end Key; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Map; - Source : in out Map) - is - NN : HT_Types.Nodes_Type renames Source.Nodes; - X : Count_Type; - Y : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - if Source.Length = 0 then - return; - end if; - - X := HT_Ops.First (Source); - while X /= 0 loop - Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - - Y := HT_Ops.Next (Source, X); - - HT_Ops.Delete_Node_Sans_Free (Source, X); - Free (Source, X); - - X := Y; - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Container : Map; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in function Next"); - - declare - Node : constant Count_Type := HT_Ops.Next (Container, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Next; - - procedure Next (Container : Map; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace key not in map"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Replace_Element has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - is - begin - if Capacity > Container.Capacity then - raise Capacity_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - --------- - -- Vet -- - --------- - - function Vet (Container : Map; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return True; - end if; - - declare - X : Count_Type; - - begin - if Container.Length = 0 then - return False; - end if; - - if Container.Capacity = 0 then - return False; - end if; - - if Container.Buckets'Length = 0 then - return False; - end if; - - if Position.Node > Container.Capacity then - return False; - end if; - - if Container.Nodes (Position.Node).Next = Position.Node then - return False; - end if; - - X := - Container.Buckets - (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key)); - - for J in 1 .. Container.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = Container.Nodes (X).Next then - - -- Prevent unnecessary looping - - return False; - end if; - - X := Container.Nodes (X).Next; - end loop; - - return False; - end; - end Vet; - -end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/a-cfhama.ads b/gcc/ada/a-cfhama.ads deleted file mode 100644 index e02accc..0000000 --- a/gcc/ada/a-cfhama.ads +++ /dev/null @@ -1,815 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- This spec is derived from package Ada.Containers.Bounded_Hashed_Maps in the --- Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- contents of a container: Key, Element, Next, Query_Element, Has_Element, --- Iterate, Equivalent_Keys. This change is motivated by the need to have --- cursors which are valid on different containers (typically a container C --- and its previous version C'Old) for expressing properties, which is not --- possible if cursors encapsulate an access to the underlying container. - --- Iteration over maps is done using the Iterable aspect, which is SPARK --- compatible. "For of" iteration ranges over keys instead of elements. - -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; -private with Ada.Containers.Hash_Tables; - -generic - type Key_Type is private; - type Element_Type is private; - - with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys - (Left : Key_Type; - Right : Key_Type) return Boolean is "="; - -package Ada.Containers.Formal_Hashed_Maps with - SPARK_Mode -is - pragma Annotate (CodePeer, Skip_Analysis); - - type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Key), - Default_Initial_Condition => Is_Empty (Map); - pragma Preelaborable_Initialization (Map); - - Empty_Map : constant Map; - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Map) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Maps - (Element_Type => Element_Type, - Key_Type => Key_Type, - Equivalent_Keys => Equivalent_Keys); - - function "=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."="; - - function "<=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."<="; - - package K is new Ada.Containers.Functional_Vectors - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."="; - - function "<" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<"; - - function "<=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<="; - - function Find (Container : K.Sequence; Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= K.Length (Container) - and Equivalent_Keys (Key, K.Get (Container, Find'Result))); - - function K_Keys_Included - (Left : K.Sequence; - Right : K.Sequence) return Boolean - -- Return True if Right contains all the keys of Left - - with - Global => null, - Post => - K_Keys_Included'Result = - (for all I in 1 .. K.Length (Left) => - Find (Right, K.Get (Left, I)) > 0 - and then K.Get (Right, Find (Right, K.Get (Left, I))) = - K.Get (Left, I)); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function Mapping_Preserved - (K_Left : K.Sequence; - K_Right : K.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the keys of Left - - and K_Keys_Included (K_Left, K_Right) - - -- Mappings from cursors to elements induced by K_Left, P_Left - -- and K_Right, P_Right are the same. - - and (for all C of P_Left => - K.Get (K_Left, P.Get (P_Left, C)) = - K.Get (K_Right, P.Get (P_Right, C)))); - - function Model (Container : Map) return M.Map with - -- The high-level model of a map is a map from keys to elements. Neither - -- cursors nor order of elements are represented in this model. Keys are - -- modeled up to equivalence. - - Ghost, - Global => null; - - function Keys (Container : Map) return K.Sequence with - -- The Keys sequence represents the underlying list structure of maps - -- that is used for iteration. It stores the actual values of keys in - -- the map. It does not model cursors nor elements. - - Ghost, - Global => null, - Post => - K.Length (Keys'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Key of Keys'Result => - M.Has_Key (Model (Container), Key)) - - -- It contains all the keys contained in Model - - and (for all Key of Model (Container) => - (Find (Keys'Result, Key) > 0 - and then Equivalent_Keys - (K.Get (Keys'Result, Find (Keys'Result, Key)), - Key))) - - -- It has no duplicate - - and (for all I in 1 .. Length (Container) => - Find (Keys'Result, K.Get (Keys'Result, I)) = I) - - and (for all I in 1 .. Length (Container) => - (for all J in 1 .. Length (Container) => - (if Equivalent_Keys - (K.Get (Keys'Result, I), K.Get (Keys'Result, J)) - then - I = J))); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); - - function Positions (Container : Map) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Map) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Key of Keys (Container) => - (for some I of Positions (Container) => - K.Get (Keys (Container), P.Get (Positions (Container), I)) = - Key)); - - function Contains - (C : M.Map; - K : Key_Type) return Boolean renames M.Has_Key; - -- To improve readability of contracts, we rename the function used to - -- search for a key in the model to Contains. - - function Element - (C : M.Map; - K : Key_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : Map) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Capacity (Container : Map) return Count_Type with - Global => null, - Post => Capacity'Result = Container.Capacity; - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => - Model (Container) = Model (Container)'Old - and Length (Container)'Old = Length (Container) - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Container), Keys (Container)'Old) - and K_Keys_Included (Keys (Container)'Old, Keys (Container)); - - function Is_Empty (Container : Map) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Map) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Map; Source : Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Length (Source) = Length (Target) - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Target), Keys (Source)) - and K_Keys_Included (Keys (Source), Keys (Target)); - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Keys (Copy'Result) = Keys (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - -- Copy returns a container stricty equal to Source. It must have the same - -- cursors associated with each element. Therefore: - -- - capacity=0 means use Source.Capacity as capacity of target - -- - the modulus cannot be changed. - - function Key (Container : Map; Position : Cursor) return Key_Type with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Key'Result = - K.Get (Keys (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element - (Container : Map; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = Element (Model (Container), Key (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old - - -- New_Item is now associated with the key at position Position in - -- Container. - - and Element (Container, Position) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key (Container, Position)); - - procedure Move (Target : in out Map; Source : in out Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0 - - -- Actual keys are preserved - - and K_Keys_Included (Keys (Target), Keys (Source)'Old) - and K_Keys_Included (Keys (Source)'Old, Keys (Target)); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) - and Has_Element (Container, Position) - and Equivalent_Keys - (Formal_Hashed_Maps.Key (Container, Position), Key), - Contract_Cases => - - -- If Key is already in Container, it is not modified and Inserted is - -- set to False. - - (Contains (Container, Key) => - not Inserted - and Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is inserted in Container and Inserted is set to True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Key now maps to New_Item - - and Formal_Hashed_Maps.Key (Container, Position) = Key - and Element (Model (Container), Key) = New_Item - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Position)); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, Key)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, Key) - - -- Key now maps to New_Item - - and Formal_Hashed_Maps.Key (Container, Find (Container, Key)) = Key - and Element (Model (Container), Key) = New_Item - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, Key)); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) and Element (Container, Key) = New_Item, - Contract_Cases => - - -- If Key is already in Container, Key is mapped to New_Item - - (Contains (Container, Key) => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key), - - -- Otherwise, Key is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other keys are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Key is inserted in Container - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container)'Old, - K_Right => Keys (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, Key))); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - P.Get (Positions (Container), Find (Container, Key))) - - -- New_Item is now associated with the Key in Container - - and Element (Model (Container), Key) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key); - - procedure Exclude (Container : in out Map; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old)); - - procedure Delete (Container : in out Map; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old); - - procedure Delete (Container : in out Map; Position : in out Cursor) with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The key at position Position is no longer in Container - - and not Contains (Container, Key (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other keys are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key (Container, Position)'Old) - - -- Mapping from cursors to keys is preserved - - and Mapping_Preserved - (K_Left => Keys (Container), - K_Right => Keys (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Position'Old); - - function First (Container : Map) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function Next (Container : Map; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : Map; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Find (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Key) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Keys (Container), Key) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Formal_Hashed_Maps.Key (Container, Find'Result), Key)); - - function Contains (Container : Map; Key : Key_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Element (Container : Map; Key : Key_Type) return Element_Type with - Global => null, - Pre => Contains (Container, Key), - Post => Element'Result = Element (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - function Has_Element (Container : Map; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - function Default_Modulus (Capacity : Count_Type) return Hash_Type with - Global => null; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Length); - pragma Inline (Is_Empty); - pragma Inline (Clear); - pragma Inline (Key); - pragma Inline (Element); - pragma Inline (Contains); - pragma Inline (Capacity); - pragma Inline (Has_Element); - pragma Inline (Equivalent_Keys); - pragma Inline (Next); - - type Node_Type is record - Key : Key_Type; - Element : Element_Type; - Next : Count_Type; - Has_Element : Boolean := False; - end record; - - package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); - - type Map (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - - use HT_Types; - - Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); - -end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/a-cfhase.adb b/gcc/ada/a-cfhase.adb deleted file mode 100644 index 9b2c9a4..0000000 --- a/gcc/ada/a-cfhase.adb +++ /dev/null @@ -1,1573 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); - -with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); - -with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode => Off -is - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All need comments ??? - - procedure Difference (Left : Set; Right : Set; Target : in out Set); - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Keys); - - procedure Free - (HT : in out Set; - X : Count_Type); - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out Set; - Node : out Count_Type); - - function Hash_Node (Node : Node_Type) return Hash_Type; - pragma Inline (Hash_Node); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Intersection - (Left : Set; - Right : Set; - Target : in out Set); - - function Is_In - (HT : Set; - Key : Node_Type) return Boolean; - pragma Inline (Is_In); - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type); - pragma Inline (Set_Element); - - function Next (Node : Node_Type) return Count_Type; - pragma Inline (Next); - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type); - pragma Inline (Set_Next); - - function Vet (Container : Set; Position : Cursor) return Boolean; - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Hash_Tables.Generic_Bounded_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next); - - package Element_Keys is new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - procedure Replace_Element is - new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Length (Left) = 0 then - return True; - end if; - - declare - Node : Count_Type; - ENode : Count_Type; - - begin - Node := First (Left).Node; - while Node /= 0 loop - ENode := - Find - (Container => Right, - Item => Left.Nodes (Node).Element).Node; - - if ENode = 0 - or else Right.Nodes (ENode).Element /= Left.Nodes (Node).Element - then - return False; - end if; - - Node := HT_Ops.Next (Left, Node); - end loop; - - return True; - end; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - procedure Insert_Element (Source_Node : Count_Type); - - procedure Insert_Elements is - new HT_Ops.Generic_Iteration (Insert_Element); - - -------------------- - -- Insert_Element -- - -------------------- - - procedure Insert_Element (Source_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Source_Node); - X : Count_Type; - B : Boolean; - - begin - Insert (Target, N.Element, X, B); - pragma Assert (B); - end Insert_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Storage_Error with "not enough capacity"; -- SE or CE? ??? - end if; - - HT_Ops.Clear (Target); - Insert_Elements (Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Set) return Count_Type is - begin - return Container.Nodes'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - HT_Ops.Clear (Container); - end Clear; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - is - C : constant Count_Type := - Count_Type'Max (Capacity, Source.Capacity); - Cu : Cursor; - H : Hash_Type; - N : Count_Type; - Target : Set (C, Source.Modulus); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - Target.Length := Source.Length; - Target.Free := Source.Free; - - H := 1; - while H <= Source.Modulus loop - Target.Buckets (H) := Source.Buckets (H); - H := H + 1; - end loop; - - N := 1; - while N <= Source.Capacity loop - Target.Nodes (N) := Source.Nodes (N); - N := N + 1; - end loop; - - while N <= C loop - Cu := (Node => N); - Free (Target, Cu.Node); - N := N + 1; - end loop; - - return Target; - end Copy; - - --------------------- - -- Default_Modulus -- - --------------------- - - function Default_Modulus (Capacity : Count_Type) return Hash_Type is - begin - return To_Prime (Capacity); - end Default_Modulus; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : Count_Type; - - begin - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Free (Container, X); - end Delete; - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); - Free (Container, Position.Node); - - Position := No_Element; - end Delete; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - Src_Last : Count_Type; - Src_Length : Count_Type; - Src_Node : Count_Type; - Tgt_Node : Count_Type; - - TN : Nodes_Type renames Target.Nodes; - SN : Nodes_Type renames Source.Nodes; - - begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - Src_Length := Source.Length; - - if Src_Length = 0 then - return; - end if; - - if Src_Length >= Target.Length then - Tgt_Node := HT_Ops.First (Target); - while Tgt_Node /= 0 loop - if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - Free (Target, X); - end; - - else - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - end if; - end loop; - - return; - else - Src_Node := HT_Ops.First (Source); - Src_Last := 0; - end if; - - while Src_Node /= Src_Last loop - Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element); - - if Tgt_Node /= 0 then - HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); - Free (Target, Tgt_Node); - end if; - - Src_Node := HT_Ops.Next (Source, Src_Node); - end loop; - end Difference; - - procedure Difference (Left : Set; Right : Set; Target : in out Set) is - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - B : Boolean; - E : Element_Type renames Left.Nodes (L_Node).Element; - X : Count_Type; - - begin - if Find (Right, E).Node = 0 then - Insert (Target, E, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Difference - - begin - Iterate (Left); - end Difference; - - function Difference (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Left) = 0 then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Left.Copy; - end if; - - C := Length (Left); - H := Default_Modulus (C); - - return S : Set (C, H) do - Difference (Left, Right, Target => S); - end return; - end Difference; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Position : Cursor) return Element_Type - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Element"); - - return Container.Nodes (Position.Node).Element; - end Element; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean; - pragma Inline (Find_Equivalent_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type'Class; - L_Node : Node_Type) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - R_Node : Count_Type := R_HT.Buckets (R_Index); - RN : Nodes_Type renames R_HT.Nodes; - - begin - loop - if R_Node = 0 then - return False; - end if; - - if Equivalent_Elements - (L_Node.Element, RN (R_Node).Element) - then - return True; - end if; - - R_Node := HT_Ops.Next (R_HT, R_Node); - end loop; - end Find_Equivalent_Key; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left, Right); - end Equivalent_Sets; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Elements (Key, Node.Element); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : Count_Type; - begin - Element_Keys.Delete_Key_Sans_Free (Container, Item, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Item : Element_Type) return Cursor - is - Node : constant Count_Type := Element_Keys.Find (Container, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - Node : constant Count_Type := HT_Ops.First (Container); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end First; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Elements_Included -- - ------------------------- - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - declare - Item : constant Element_Type := E.Get (Left, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Container) loop - declare - Item : constant Element_Type := E.Get (Container, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Left, 1, E.Length (Left), Item) then - return False; - end if; - else - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Elements (Item, E.Get (Container, I)) then - return I; - end if; - end loop; - return 0; - end Find; - - -------------- - -- Elements -- - -------------- - - function Elements (Container : Set) return E.Sequence is - Position : Count_Type := HT_Ops.First (Container); - R : E.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := E.Add (R, Container.Nodes (Position).Element); - Position := HT_Ops.Next (Container, Position); - end loop; - - return R; - end Elements; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Set) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------------ - -- Mapping_Preserved_Except -- - ------------------------------ - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - is - begin - for C of P_Left loop - if C /= Position - and (not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C))) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved_Except; - - ----------- - -- Model -- - ----------- - - function Model (Container : Set) return M.Set is - Position : Count_Type := HT_Ops.First (Container); - R : M.Set; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - Item => Container.Nodes (Position).Element); - - Position := HT_Ops.Next (Container, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Set) return P.Map is - I : Count_Type := 1; - Position : Count_Type := HT_Ops.First (Container); - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); - Position := HT_Ops.Next (Container, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (HT : in out Set; X : Count_Type) is - begin - HT.Nodes (X).Has_Element := False; - HT_Ops.Free (HT, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate (HT : in out Set; Node : out Count_Type) is - procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); - begin - Allocate (HT, Node); - HT.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - package body Generic_Keys with SPARK_Mode => Off is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean; - pragma Inline (Equivalent_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is new Hash_Tables.Generic_Bounded_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Key : Key_Type) return Boolean - is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : Count_Type; - - begin - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - Node : constant Count_Type := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - return Container.Nodes (Node).Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Type) return Boolean - is - begin - return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); - end Equivalent_Key_Node; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : Count_Type; - begin - Key_Keys.Delete_Key_Sans_Free (Container, Key, X); - Free (Container, X); - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Key : Key_Type) return Cursor - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Find; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Included_Except -- - ----------------------- - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - is - begin - for E of Left loop - if not Contains (Right, E) - and not Equivalent_Keys (Generic_Keys.Key (E), Key) - then - return False; - end if; - end loop; - - return True; - end M_Included_Except; - - end Formal_Model; - - --------- - -- Key -- - --------- - - function Key (Container : Set; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in function Key"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - return Key (N.Element); - end; - end Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace key not in set"; - end if; - - Replace_Element (Container, Node, New_Item); - end Replace; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Set; Position : Cursor) return Boolean is - begin - if Position.Node = 0 - or else not Container.Nodes (Position.Node).Has_Element - then - return False; - end if; - - return True; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Type) return Hash_Type is - begin - return Hash (Node.Element); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Inserted : Boolean; - Position : Cursor; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - Container.Nodes (Position.Node).Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert (Container, New_Item, Position.Node, Inserted); - end Insert; - - procedure Insert (Container : in out Set; New_Item : Element_Type) is - Inserted : Boolean; - Position : Cursor; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Allocate_Set_Element (Node : in out Node_Type); - pragma Inline (Allocate_Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - procedure Allocate is - new Generic_Allocate (Allocate_Set_Element); - - --------------------------- - -- Allocate_Set_Element -- - --------------------------- - - procedure Allocate_Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Allocate_Set_Element; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - -- Start of processing for Insert - - begin - Local_Insert (Container, New_Item, Node, Inserted); - end Insert; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - Tgt_Node : Count_Type; - TN : Nodes_Type renames Target.Nodes; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.Length = 0 then - Clear (Target); - return; - end if; - - Tgt_Node := HT_Ops.First (Target); - while Tgt_Node /= 0 loop - if Find (Source, TN (Tgt_Node).Element).Node /= 0 then - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - - else - declare - X : constant Count_Type := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target, X); - Free (Target, X); - end; - end if; - end loop; - end Intersection; - - procedure Intersection (Left : Set; Right : Set; Target : in out Set) is - procedure Process (L_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Count_Type) is - E : Element_Type renames Left.Nodes (L_Node).Element; - X : Count_Type; - B : Boolean; - - begin - if Find (Right, E).Node /= 0 then - Insert (Target, E, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Intersection - - begin - Iterate (Left); - end Intersection; - - function Intersection (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; - - begin - if Left'Address = Right'Address then - return Left.Copy; - end if; - - C := Count_Type'Min (Length (Left), Length (Right)); -- ??? - H := Default_Modulus (C); - - return S : Set (C, H) do - if Length (Left) /= 0 and Length (Right) /= 0 then - Intersection (Left, Right, Target => S); - end if; - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ----------- - -- Is_In -- - ----------- - - function Is_In (HT : Set; Key : Node_Type) return Boolean is - begin - return Element_Keys.Find (HT, Key.Element) /= 0; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - Subset_Node : Count_Type; - Subset_Nodes : Nodes_Type renames Subset.Nodes; - - begin - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Length (Subset) > Length (Of_Set) then - return False; - end if; - - Subset_Node := First (Subset).Node; - while Subset_Node /= 0 loop - declare - N : Node_Type renames Subset_Nodes (Subset_Node); - E : Element_Type renames N.Element; - - begin - if Find (Of_Set, E).Node = 0 then - return False; - end if; - end; - - Subset_Node := HT_Ops.Next (Subset, Subset_Node); - end loop; - - return True; - end Is_Subset; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - -- Comments??? - - procedure Move (Target : in out Set; Source : in out Set) is - NN : HT_Types.Nodes_Type renames Source.Nodes; - X, Y : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - if Source.Length = 0 then - return; - end if; - - X := HT_Ops.First (Source); - while X /= 0 loop - Insert (Target, NN (X).Element); -- optimize??? - - Y := HT_Ops.Next (Source, X); - - HT_Ops.Delete_Node_Sans_Free (Source, X); - Free (Source, X); - - X := Y; - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Type) return Count_Type is - begin - return Node.Next; - end Next; - - function Next (Container : Set; Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position has no element"; - end if; - - pragma Assert (Vet (Container, Position), "bad cursor in Next"); - - return (Node => HT_Ops.Next (Container, Position.Node)); - end Next; - - procedure Next (Container : Set; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - Left_Node : Count_Type; - Left_Nodes : Nodes_Type renames Left.Nodes; - - begin - if Length (Right) = 0 or Length (Left) = 0 then - return False; - end if; - - if Left'Address = Right'Address then - return True; - end if; - - Left_Node := First (Left).Node; - while Left_Node /= 0 loop - declare - N : Node_Type renames Left_Nodes (Left_Node); - E : Element_Type renames N.Element; - begin - if Find (Right, E).Node /= 0 then - return True; - end if; - end; - - Left_Node := HT_Ops.Next (Left, Left_Node); - end loop; - - return False; - end Overlap; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Count_Type := Element_Keys.Find (Container, New_Item); - - begin - if Node = 0 then - raise Constraint_Error with "attempt to replace element not in set"; - end if; - - Container.Nodes (Node).Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert - (Vet (Container, Position), "bad cursor in Replace_Element"); - - Replace_Element (Container, Position.Node, New_Item); - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - is - begin - if Capacity > Container.Capacity then - raise Constraint_Error with "requested capacity is too large"; - end if; - end Reserve_Capacity; - - ------------------ - -- Set_Element -- - ------------------ - - procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is - begin - Node.Element := Item; - end Set_Element; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is - begin - Node.Next := Next; - end Set_Next; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - procedure Process (Source_Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Source_Node : Count_Type) is - B : Boolean; - N : Node_Type renames Source.Nodes (Source_Node); - X : Count_Type; - - begin - if Is_In (Target, N) then - Delete (Target, N.Element); - else - Insert (Target, N.Element, X, B); - pragma Assert (B); - end if; - end Process; - - -- Start of processing for Symmetric_Difference - - begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - if Length (Target) = 0 then - Assign (Target, Source); - return; - end if; - - Iterate (Source); - end Symmetric_Difference; - - function Symmetric_Difference (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Left.Copy; - end if; - - if Length (Left) = 0 then - return Right.Copy; - end if; - - C := Length (Left) + Length (Right); - H := Default_Modulus (C); - - return S : Set (C, H) do - Difference (Left, Right, S); - Difference (Right, Left, S); - end return; - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - X : Count_Type; - B : Boolean; - - begin - return S : Set (Capacity => 1, Modulus => 1) do - Insert (S, New_Item, X, B); - pragma Assert (B); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - procedure Process (Src_Node : Count_Type); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Count_Type) is - N : Node_Type renames Source.Nodes (Src_Node); - E : Element_Type renames N.Element; - - X : Count_Type; - B : Boolean; - - begin - Insert (Target, E, X, B); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - Iterate (Source); - end Union; - - function Union (Left : Set; Right : Set) return Set is - C : Count_Type; - H : Hash_Type; - - begin - if Left'Address = Right'Address then - return Left.Copy; - end if; - - if Length (Right) = 0 then - return Left.Copy; - end if; - - if Length (Left) = 0 then - return Right.Copy; - end if; - - C := Length (Left) + Length (Right); - H := Default_Modulus (C); - return S : Set (C, H) do - Assign (Target => S, Source => Left); - Union (Target => S, Source => Right); - end return; - end Union; - - --------- - -- Vet -- - --------- - - function Vet (Container : Set; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return True; - end if; - - declare - S : Set renames Container; - N : Nodes_Type renames S.Nodes; - X : Count_Type; - - begin - if S.Length = 0 then - return False; - end if; - - if Position.Node > N'Last then - return False; - end if; - - if N (Position.Node).Next = Position.Node then - return False; - end if; - - X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element)); - - for J in 1 .. S.Length loop - if X = Position.Node then - return True; - end if; - - if X = 0 then - return False; - end if; - - if X = N (X).Next then -- to prevent unnecessary looping - return False; - end if; - - X := N (X).Next; - end loop; - - return False; - end; - end Vet; - -end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cfhase.ads b/gcc/ada/a-cfhase.ads deleted file mode 100644 index fd3d007..0000000 --- a/gcc/ada/a-cfhase.ads +++ /dev/null @@ -1,1335 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- This spec is derived from package Ada.Containers.Bounded_Hashed_Sets in the --- Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Element, Next, Query_Element, Has_Element, Key, --- Iterate, Equivalent_Elements. This change is motivated by the need to --- have cursors which are valid on different containers (typically a --- container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. - -with Ada.Containers.Functional_Maps; -with Ada.Containers.Functional_Sets; -with Ada.Containers.Functional_Vectors; -private with Ada.Containers.Hash_Tables; - -generic - type Element_Type is private; - - with function Hash (Element : Element_Type) return Hash_Type; - - with function Equivalent_Elements - (Left : Element_Type; - Right : Element_Type) return Boolean is "="; - -package Ada.Containers.Formal_Hashed_Sets with - SPARK_Mode -is - pragma Annotate (CodePeer, Skip_Analysis); - - type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (Set); - pragma Preelaborable_Initialization (Set); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Set) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Sets - (Element_Type => Element_Type, - Equivalent_Elements => Equivalent_Elements); - - function "=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."="; - - function "<=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."<="; - - package E is new Ada.Containers.Functional_Vectors - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."="; - - function "<" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<"; - - function "<=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<="; - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - -- Search for Item in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Elements - (Item, E.Get (Container, Find'Result))); - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Left are contained in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - (if M.Contains (Model, E.Get (Left, I)) then - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Left and others - -- are in Right. - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Container) => - (if M.Contains (Model, E.Get (Container, I)) then - Find (Left, E.Get (Container, I)) > 0 - and then E.Get (Left, Find (Left, E.Get (Container, I))) = - E.Get (Container, I) - else - Find (Right, E.Get (Container, I)) > 0 - and then E.Get - (Right, Find (Right, E.Get (Container, I))) = - E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the elements of Left - - and E_Elements_Included (E_Left, E_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same. - - and (for all C of P_Left => - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C)))); - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved_Except'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same except for Position. - - and (for all C of P_Left => - (if C /= Position then - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C))))); - - function Model (Container : Set) return M.Set with - -- The high-level model of a set is a set of elements. Neither cursors - -- nor order of elements are represented in this model. Elements are - -- modeled up to equivalence. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - - function Elements (Container : Set) return E.Sequence with - -- The Elements sequence represents the underlying list structure of - -- sets that is used for iteration. It stores the actual values of - -- elements in the set. It does not model cursors. - - Ghost, - Global => null, - Post => - E.Length (Elements'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Item of Elements'Result => - M.Contains (Model (Container), Item)) - - -- It contains all the elements contained in Model - - and (for all Item of Model (Container) => - (Find (Elements'Result, Item) > 0 - and then Equivalent_Elements - (E.Get (Elements'Result, - Find (Elements'Result, Item)), - Item))) - - -- It has no duplicate - - and (for all I in 1 .. Length (Container) => - Find (Elements'Result, E.Get (Elements'Result, I)) = I) - - and (for all I in 1 .. Length (Container) => - (for all J in 1 .. Length (Container) => - (if Equivalent_Elements - (E.Get (Elements'Result, I), - E.Get (Elements'Result, J)) - then I = J))); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); - - function Positions (Container : Set) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Set) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Item of Elements (Container) => - (for some I of Positions (Container) => - E.Get (Elements (Container), P.Get (Positions (Container), I)) = - Item)); - - function Contains - (C : M.Set; - K : Element_Type) return Boolean renames M.Contains; - -- To improve readability of contracts, we rename the function used to - -- search for an element in the model to Contains. - - end Formal_Model; - use Formal_Model; - - Empty_Set : constant Set; - - function "=" (Left, Right : Set) return Boolean with - Global => null, - Post => - "="'Result = - (Length (Left) = Length (Right) - and E_Elements_Included (Elements (Left), Elements (Right))) - and - "="'Result = - (E_Elements_Included (Elements (Left), Elements (Right)) - and E_Elements_Included (Elements (Right), Elements (Left))); - - function Equivalent_Sets (Left, Right : Set) return Boolean with - Global => null, - Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); - - function To_Set (New_Item : Element_Type) return Set with - Global => null, - Post => - M.Is_Singleton (Model (To_Set'Result), New_Item) - and Length (To_Set'Result) = 1 - and E.Get (Elements (To_Set'Result), 1) = New_Item; - - function Capacity (Container : Set) return Count_Type with - Global => null, - Post => Capacity'Result = Container.Capacity; - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - with - Global => null, - Pre => Capacity <= Container.Capacity, - Post => - Model (Container) = Model (Container)'Old - and Length (Container)'Old = Length (Container) - - -- Actual elements are preserved - - and E_Elements_Included - (Elements (Container), Elements (Container)'Old) - and E_Elements_Included - (Elements (Container)'Old, Elements (Container)); - - function Is_Empty (Container : Set) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Set) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Set; Source : Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Length (Target) = Length (Source) - - -- Actual elements are preserved - - and E_Elements_Included (Elements (Target), Elements (Source)) - and E_Elements_Included (Elements (Source), Elements (Target)); - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Elements (Copy'Result) = Elements (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Element - (Container : Set; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Position) - and Positions (Container) = Positions (Container)'Old; - - procedure Move (Target : in out Set; Source : in out Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Length (Source) = 0 - and Model (Target) = Model (Source)'Old - and Length (Target) = Length (Source)'Old - - -- Actual elements are preserved - - and E_Elements_Included (Elements (Target), Elements (Source)'Old) - and E_Elements_Included (Elements (Source)'Old, Elements (Target)); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Has_Element (Container, Position) - and Equivalent_Elements (Element (Container, Position), New_Item), - Contract_Cases => - - -- If New_Item is already in Container, it is not modified and Inserted - -- is set to False. - - (Contains (Container, New_Item) => - not Inserted - and Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, New_Item is inserted in Container and Inserted is set to - -- True. - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Position)); - - procedure Insert (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, New_Item) - and Element (Container, Find (Container, New_Item)) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, New_Item)); - - procedure Include (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Element (Container, Find (Container, New_Item)) = New_Item, - Contract_Cases => - - -- If an element equivalent to New_Item is already in Container, it is - -- replaced by New_Item. - - (Contains (Container, New_Item) => - - -- Elements are preserved modulo equivalence - - Model (Container) = Model (Container)'Old - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The actual value of other elements is preserved - - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - P.Get (Positions (Container), Find (Container, New_Item))), - - -- Otherwise, New_Item is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container)) - and P.Keys_Included_Except - (Positions (Container), - Positions (Container)'Old, - Find (Container, New_Item))); - - procedure Replace (Container : in out Set; New_Item : Element_Type) with - Global => null, - Pre => Contains (Container, New_Item), - Post => - - -- Elements are preserved modulo equivalence - - Model (Container) = Model (Container)'Old - and Contains (Container, New_Item) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and Element (Container, Find (Container, New_Item)) = New_Item - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - P.Get (Positions (Container), Find (Container, New_Item))); - - procedure Exclude (Container : in out Set; Item : Element_Type) with - Global => null, - Post => not Contains (Container, Item), - Contract_Cases => - - -- If Item is not in Container, nothing is changed - - (not Contains (Container, Item) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Item is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Item)'Old)); - - procedure Delete (Container : in out Set; Item : Element_Type) with - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Item is no longer in Container - - and not Contains (Container, Item) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Item)'Old); - - procedure Delete (Container : in out Set; Position : in out Cursor) with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The element at position Position is no longer in Container - - and not Contains (Container, Element (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Position'Old); - - procedure Union (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target), - Post => - Length (Target) = Length (Target)'Old - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Length (Source) - - -- Elements already in Target are still in Target - - and Model (Target)'Old <= Model (Target) - - -- Elements of Source are included in Target - - and Model (Source) <= Model (Target) - - -- Elements of Target come from either Source or Target - - and M.Included_In_Union - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - - and E_Elements_Included - (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) - - and E_Elements_Included - (Elements (Source), - Model (Target)'Old, - Elements (Source), - Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target)'Old, - E_Right => Elements (Target), - P_Left => Positions (Target)'Old, - P_Right => Positions (Target)); - - function Union (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Length (Union'Result) = Length (Left) - - M.Num_Overlaps (Model (Left), Model (Right)) - + Length (Right) - - -- Elements of Left and Right are in the result of Union - - and Model (Left) <= Model (Union'Result) - and Model (Right) <= Model (Union'Result) - - -- Elements of the result of union come from either Left or Right - - and - M.Included_In_Union - (Model (Union'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Union'Result), - Model (Left), - Elements (Left), - Elements (Right)) - - and E_Elements_Included - (Elements (Left), Model (Left), Elements (Union'Result)) - - and E_Elements_Included - (Elements (Right), - Model (Left), - Elements (Right), - Elements (Union'Result)); - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set) with - Global => null, - Post => - Length (Target) = - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are in Source - - and Model (Target) <= Model (Source) - - -- Elements both in Source and Target are in the intersection - - and M.Includes_Intersection - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and E_Elements_Included - (Elements (Target)'Old, Model (Source), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Intersection (Left, Right : Set) return Set with - Global => null, - Post => - Length (Intersection'Result) = - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements in the result of Intersection are in Left and Right - - and Model (Intersection'Result) <= Model (Left) - and Model (Intersection'Result) <= Model (Right) - - -- Elements both in Left and Right are in the result of Intersection - - and M.Includes_Intersection - (Model (Intersection'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from Left - - and E_Elements_Included - (Elements (Intersection'Result), Elements (Left)) - - and E_Elements_Included - (Elements (Left), Model (Right), - Elements (Intersection'Result)); - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set) with - Global => null, - Post => - Length (Target) = Length (Target)'Old - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are not in Source - - and M.No_Overlap (Model (Target), Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Difference (Left, Right : Set) return Set with - Global => null, - Post => - Length (Difference'Result) = Length (Left) - - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements of the result of Difference are in Left - - and Model (Difference'Result) <= Model (Left) - - -- Elements of the result of Difference are in Right - - and M.No_Overlap (Model (Difference'Result), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and M.Included_In_Union - (Model (Left), Model (Difference'Result), Model (Right)) - - -- Actual value of elements come from Left - - and E_Elements_Included - (Elements (Difference'Result), Elements (Left)) - - and E_Elements_Included - (Elements (Left), - Model (Difference'Result), - Elements (Difference'Result)); - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target) + Length (Target and Source), - Post => - Length (Target) = Length (Target)'Old - - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Length (Source) - - -- Elements of the difference were not both in Source and in Target - - and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Elements in Source but not in Target are in the difference - - and M.Included_In_Union - (Model (Source), Model (Target), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - - and E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - and E_Elements_Included - (Elements (Source), Model (Target), Elements (Target)); - - function Symmetric_Difference (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Length (Symmetric_Difference'Result) = Length (Left) - - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Length (Right) - - -- Elements of the difference were not both in Left and Right - - and M.Not_In_Both - (Model (Symmetric_Difference'Result), - Model (Left), - Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and M.Included_In_Union - (Model (Left), - Model (Symmetric_Difference'Result), - Model (Right)) - - -- Elements in Right but not in Left are in the difference - - and M.Included_In_Union - (Model (Right), - Model (Symmetric_Difference'Result), - Model (Left)) - - -- Actual value of elements come from either Left or Right - - and E_Elements_Included - (Elements (Symmetric_Difference'Result), - Model (Left), - Elements (Left), - Elements (Right)) - - and E_Elements_Included - (Elements (Left), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)) - - and E_Elements_Included - (Elements (Right), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)); - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean with - Global => null, - Post => - Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with - Global => null, - Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); - - function First (Container : Set) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function Next (Container : Set; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : Set; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Find - (Container : Set; - Item : Element_Type) return Cursor - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Item) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Item) - - -- The element designated by the result of Find is Item - - and Equivalent_Elements - (Element (Container, Find'Result), Item)); - - function Contains (Container : Set; Item : Element_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Set; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - function Default_Modulus (Capacity : Count_Type) return Hash_Type with - Global => null; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - package Generic_Keys with SPARK_Mode is - - package Formal_Model with Ghost is - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - with - Global => null, - Post => - M_Included_Except'Result = - (for all E of Left => - Contains (Right, E) - or Equivalent_Keys (Generic_Keys.Key (E), Key)); - - end Formal_Model; - use Formal_Model; - - function Key (Container : Set; Position : Cursor) return Key_Type with - Global => null, - Post => Key'Result = Key (Element (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element (Container : Set; Key : Key_Type) return Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Element'Result = Element (Container, Find (Container, Key)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - - -- Key now maps to New_Item - - and Element (Container, Key) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Find (Container, Key)) - and Positions (Container) = Positions (Container)'Old; - - procedure Exclude (Container : in out Set; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old)); - - procedure Delete (Container : in out Set; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Container), - E_Right => Elements (Container)'Old, - P_Left => Positions (Container), - P_Right => Positions (Container)'Old) - and P.Keys_Included_Except - (Positions (Container)'Old, - Positions (Container), - Find (Container, Key)'Old); - - function Find (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - ((for all E of Model (Container) => - not Equivalent_Keys (Key, Generic_Keys.Key (E))) => - Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Generic_Keys.Key (Container, Find'Result), Key)); - - function Contains (Container : Set; Key : Key_Type) return Boolean with - Global => null, - Post => - Contains'Result = - (for some E of Model (Container) => - Equivalent_Keys (Key, Generic_Keys.Key (E))); - - end Generic_Keys; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - - type Node_Type is - record - Element : Element_Type; - Next : Count_Type; - Has_Element : Boolean := False; - end record; - - package HT_Types is new - Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); - - type Set (Capacity : Count_Type; Modulus : Hash_Type) is - new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; - - use HT_Types; - - Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>); - -end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/a-cfinve.adb b/gcc/ada/a-cfinve.adb deleted file mode 100644 index 8a9d11d..0000000 --- a/gcc/ada/a-cfinve.adb +++ /dev/null @@ -1,1404 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode => Off -is - function H (New_Item : Element_Type) return Holder renames To_Holder; - function E (Container : Holder) return Element_Type renames Get; - - Growth_Factor : constant := 2; - -- When growing a container, multiply current capacity by this. Doubling - -- leads to amortized linear-time copying. - - type Int is range System.Min_Int .. System.Max_Int; - - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); - - type Maximal_Array_Ptr is access all Elements_Array (Array_Index) - with Storage_Size => 0; - type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) - with Storage_Size => 0; - - function Elems (Container : in out Vector) return Maximal_Array_Ptr; - function Elemsc - (Container : Vector) return Maximal_Array_Ptr_Const; - -- Returns a pointer to the Elements array currently in use -- either - -- Container.Elements_Ptr or a pointer to Container.Elements. We work with - -- pointers to a bogus array subtype that is constrained with the maximum - -- possible bounds. This means that the pointer is a thin pointer. This is - -- necessary because 'Unrestricted_Access doesn't work when it produces - -- access-to-unconstrained and is returned from a function. - -- - -- Note that this is dangerous: make sure calls to this use an indexed - -- component or slice that is within the bounds 1 .. Length (Container). - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type; - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - - function Current_Capacity (Container : Vector) return Capacity_Range; - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - --------- - -- "=" -- - --------- - - function "=" (Left : Vector; Right : Vector) return Boolean is - begin - if Left'Address = Right'Address then - return True; - end if; - - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Length (Left) loop - if Get_Element (Left, J) /= Get_Element (Right, J) then - return False; - end if; - end loop; - - return True; - end "="; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item); - end Append; - - procedure Append (Container : in out Vector; New_Item : Element_Type) is - begin - Append (Container, New_Item, 1); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - Container.Last := No_Index; - - -- Free element, note that this is OK if Elements_Ptr is null - - Free (Container.Elements_Ptr); - end Clear; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - is - LS : constant Capacity_Range := Length (Source); - C : Capacity_Range; - - begin - if Capacity = 0 then - C := LS; - elsif Capacity >= LS then - C := Capacity; - else - raise Capacity_Error; - end if; - - return Target : Vector (C) do - Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS); - Target.Last := Source.Last; - end return; - end Copy; - - ---------------------- - -- Current_Capacity -- - ---------------------- - - function Current_Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Length - else - Container.Elements_Ptr.all'Length); - end Current_Capacity; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Vector; Index : Extended_Index) is - begin - Delete (Container, Index, 1); - end Delete; - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - is - Old_Last : constant Index_Type'Base := Container.Last; - Old_Len : constant Count_Type := Length (Container); - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - Off : Count_Type'Base; -- Index expressed as offset from IT'First - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - if Count = 0 then - return; - end if; - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements that aren't being deleted (the requested - -- count was less than the available count), so we must slide them down - -- to Index. We first calculate the index values of the respective array - -- slices, using the wider of Index_Type'Base and Count_Type'Base as the - -- type for intermediate calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Off := Count_Type'Base (Index - Index_Type'First); - New_Last := Old_Last - Index_Type'Base (Count); - else - Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - end if; - - -- The array index values for each slice have already been determined, - -- so we just slide down to Index the elements that weren't deleted. - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - Idx : constant Count_Type := EA'First + Off; - - begin - EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); - Container.Last := New_Last; - end; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Vector) is - begin - Delete_First (Container, 1); - end Delete_First; - - procedure Delete_First (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Vector) is - begin - Delete_Last (Container, 1); - end Delete_Last; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - end if; - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Length (Container) then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - return Get_Element (Container, I); - end; - end Element; - - -------------- - -- Elements -- - -------------- - - function Elems (Container : in out Vector) return Maximal_Array_Ptr is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elems; - - function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elemsc; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - K : Capacity_Range; - Last : constant Index_Type := Last_Index (Container); - - begin - K := Capacity_Range (Int (Index) - Int (No_Index)); - for Indx in Index .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K + 1; - end loop; - - return No_Index; - end Find_Index; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, 1); - end if; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - begin - for Index in Index_Type'First .. M.Last (Container) loop - declare - Elem : constant Element_Type := Element (Container, Index); - begin - if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) - and then - not M.Contains - (Right, Index_Type'First, M.Last (Right), Elem) - then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Extended_Index := R_Fst - 1; - - begin - while not Found and J < R_Lst loop - J := J + 1; - if Element (Left, I) = Element (Right, J) then - Found := True; - end if; - end loop; - - if not Found then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_Included; - - ------------------------- - -- M_Elements_Reversed -- - ------------------------- - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - is - L : constant Index_Type := M.Last (Left); - - begin - if L /= M.Last (Right) then - return False; - end if; - - for I in Index_Type'First .. L loop - if Element (Left, I) /= Element (Right, L - I + 1) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Reversed; - - ------------------------ - -- M_Elements_Swapted -- - ------------------------ - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - is - begin - if M.Length (Left) /= M.Length (Right) - or else Element (Left, X) /= Element (Right, Y) - or else Element (Left, Y) /= Element (Right, X) - then - return False; - end if; - - for I in Index_Type'First .. M.Last (Left) loop - if I /= X and then I /= Y - and then Element (Left, I) /= Element (Right, I) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Swapped; - - ----------- - -- Model -- - ----------- - - function Model (Container : Vector) return M.Sequence is - R : M.Sequence; - - begin - for Position in 1 .. Length (Container) loop - R := M.Add (R, E (Elemsc (Container) (Position))); - end loop; - - return R; - end Model; - - end Formal_Model; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting with SPARK_Mode => Off is - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Elements_Sorted -- - ----------------------- - - function M_Elements_Sorted (Container : M.Sequence) return Boolean is - begin - if M.Length (Container) = 0 then - return True; - end if; - - declare - E1 : Element_Type := Element (Container, Index_Type'First); - - begin - for I in Index_Type'First + 1 .. M.Last (Container) loop - declare - E2 : constant Element_Type := Element (Container, I); - - begin - if E2 < E1 then - return False; - end if; - - E1 := E2; - end; - end loop; - end; - - return True; - end M_Elements_Sorted; - - end Formal_Model; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - L : constant Capacity_Range := Length (Container); - - begin - for J in 1 .. L - 1 loop - if Get_Element (Container, J + 1) < Get_Element (Container, J) then - return False; - end if; - end loop; - - return True; - end Is_Sorted; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - function "<" (Left : Holder; Right : Holder) return Boolean is - (E (Left) < E (Right)); - - procedure Sort is new Generic_Array_Sort - (Index_Type => Array_Index, - Element_Type => Holder, - Array_Type => Elements_Array, - "<" => "<"); - - Len : constant Capacity_Range := Length (Container); - - begin - if Container.Last <= Index_Type'First then - return; - else - Sort (Elems (Container) (1 .. Len)); - end if; - end Sort; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out Vector; Source : in out Vector) is - I : Count_Type; - J : Count_Type; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Length (Source) = 0 then - return; - end if; - - if Length (Target) = 0 then - Move (Target => Target, Source => Source); - return; - end if; - - I := Length (Target); - - declare - New_Length : constant Count_Type := I + Length (Source); - - begin - if not Bounded - and then Current_Capacity (Target) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Target, - Capacity_Range'Max - (Current_Capacity (Target) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Target.Last := No_Index + Index_Type'Base (New_Length); - - else - Target.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end; - - declare - TA : Maximal_Array_Ptr renames Elems (Target); - SA : Maximal_Array_Ptr renames Elems (Source); - - begin - J := Length (Target); - while Length (Source) /= 0 loop - if I = 0 then - TA (1 .. J) := SA (1 .. Length (Source)); - Source.Last := No_Index; - exit; - end if; - - if E (SA (Length (Source))) < E (TA (I)) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Length (Source)); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - end Generic_Sorting; - - ----------------- - -- Get_Element -- - ----------------- - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type - is - begin - return E (Elemsc (Container) (Position)); - end Get_Element; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - begin - return Position in First_Index (Container) .. Last_Index (Container); - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - is - begin - Insert (Container, Before, New_Item, 1); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - is - J : Count_Type'Base; -- scratch - - begin - -- Use Insert_Space to create the "hole" (the destination slice) - - Insert_Space (Container, Before, Count); - - J := To_Array_Index (Before); - - Elems (Container) (J .. J - 1 + Count) := (others => H (New_Item)); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - B : Count_Type; -- index Before converted to Count_Type - - begin - if Container'Address = New_Item'Address then - raise Program_Error with - "Container and New_Item denote same container"; - end if; - - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - B := To_Array_Index (Before); - - Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Length (Container); - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before - 1 > Container.Last - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, so we - -- simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion - -- count. Note that we cannot simply add these values, because of the - -- possibility of overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - J := To_Array_Index (Before); - - -- Increase the capacity of container if needed - - if not Bounded - and then Current_Capacity (Container) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Container, - Capacity_Range'Max - (Current_Capacity (Container) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - - begin - if Before <= Container.Last then - - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. - - EA (J + Count .. New_Length) := EA (J .. Old_Length); - end if; - end; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Last_Index (Container) < Index_Type'First; - end Is_Empty; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, Length (Container)); - end if; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Capacity_Range is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Capacity_Range (N); - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Vector; Source : in out Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - Clear (Source); - end Move; - - ------------ - -- Prepend -- - ------------ - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) is - begin - Prepend (Container, New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - Elems (Container) (I) := H (New_Item); - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - is - begin - if Bounded then - if Capacity > Container.Capacity then - raise Constraint_Error with "Capacity is out of range"; - end if; - - else - if Capacity > Current_Capacity (Container) then - declare - New_Elements : constant Elements_Array_Ptr := - new Elements_Array (1 .. Capacity); - L : constant Capacity_Range := Length (Container); - - begin - New_Elements (1 .. L) := Elemsc (Container) (1 .. L); - Free (Container.Elements_Ptr); - Container.Elements_Ptr := New_Elements; - end; - end if; - end if; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Length (Container) <= 1 then - return; - end if; - - declare - I : Capacity_Range; - J : Capacity_Range; - E : Elements_Array renames - Elems (Container) (1 .. Length (Container)); - - begin - I := 1; - J := Length (Container); - while I < J loop - declare - EI : constant Holder := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - Last : Index_Type'Base; - K : Capacity_Range; - - begin - if Index > Last_Index (Container) then - Last := Last_Index (Container); - else - Last := Index; - end if; - - K := Capacity_Range (Int (Last) - Int (No_Index)); - for Indx in reverse Index_Type'First .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K - 1; - end loop; - - return No_Index; - end Reverse_Find_Index; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - is - begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - declare - II : constant Int'Base := Int (I) - Int (No_Index); - JJ : constant Int'Base := Int (J) - Int (No_Index); - - EI : Holder renames Elems (Container) (Capacity_Range (II)); - EJ : Holder renames Elems (Container) (Capacity_Range (JJ)); - - EI_Copy : constant Holder := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - -------------------- - -- To_Array_Index -- - -------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is - Offset : Count_Type'Base; - - begin - -- We know that - -- Index >= Index_Type'First - -- hence we also know that - -- Index - Index_Type'First >= 0 - - -- The issue is that even though 0 is guaranteed to be a value in the - -- type Index_Type'Base, there's no guarantee that the difference is a - -- value in that type. To prevent overflow we use the wider of - -- Count_Type'Base and Index_Type'Base to perform intermediate - -- calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Offset := Count_Type'Base (Index - Index_Type'First); - - else - Offset := Count_Type'Base (Index) - - Count_Type'Base (Index_Type'First); - end if; - - -- The array index subtype for all container element arrays always - -- starts with 1. - - return 1 + Offset; - end To_Array_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return - (Capacity => Length, - Last => Last, - Elements_Ptr => <>, - Elements => (others => H (New_Item))); - end; - end To_Vector; - -end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/a-cfinve.ads b/gcc/ada/a-cfinve.ads deleted file mode 100644 index a7799e5..0000000 --- a/gcc/ada/a-cfinve.ads +++ /dev/null @@ -1,937 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2014-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- Similar to Ada.Containers.Formal_Vectors. The main difference is that --- Element_Type may be indefinite (but not an unconstrained array). - -with Ada.Containers.Bounded_Holders; -with Ada.Containers.Functional_Vectors; - -generic - type Index_Type is range <>; - type Element_Type (<>) is private; - Max_Size_In_Storage_Elements : Natural := - Element_Type'Max_Size_In_Storage_Elements; - -- Maximum size of Vector elements in bytes. This has the same meaning as - -- in Ada.Containers.Bounded_Holders, with the same restrictions. Note that - -- setting this too small can lead to erroneous execution; see comments in - -- Ada.Containers.Bounded_Holders. If Element_Type is class-wide, it is the - -- responsibility of clients to calculate the maximum size of all types in - -- the class. - - Bounded : Boolean := True; - -- If True, the containers are bounded; the initial capacity is the maximum - -- size, and heap allocation will be avoided. If False, the containers can - -- grow via heap allocation. - -package Ada.Containers.Formal_Indefinite_Vectors with - SPARK_Mode => On -is - pragma Annotate (CodePeer, Skip_Analysis); - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then - 0 - elsif Index_Type'Last < -1 - or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then - Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else - Count_Type'Last); - -- Maximal capacity of any vector. It is the minimum of the size of the - -- index range and the last possible Count_Type. - - subtype Capacity_Range is Count_Type range 0 .. Last_Count; - - type Vector (Capacity : Capacity_Range) is limited private with - Default_Initial_Condition => Is_Empty (Vector); - -- In the bounded case, Capacity is the capacity of the container, which - -- never changes. In the unbounded case, Capacity is the initial capacity - -- of the container, and operations such as Reserve_Capacity and Append can - -- increase the capacity. The capacity never shrinks, except in the case of - -- Clear. - -- - -- Note that all objects of type Vector are constrained, including in the - -- unbounded case; you can't assign from one object to another if the - -- Capacity is different. - - function Length (Container : Vector) return Capacity_Range with - Global => null, - Post => Length'Result <= Capacity (Container); - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Index_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for some J in Index_Type'First .. M.Last (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in Index_Type'First .. M.Last (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in Index_Type'First .. M.Last (Left) => - Element (Left, I) = - Element (Right, M.Last (Left) - I + 1)) - and (for all I in Index_Type'First .. M.Last (Right) => - Element (Right, I) = - Element (Left, M.Last (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Last (Left) and Y <= M.Last (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - function Model (Container : Vector) return M.Sequence with - -- The high-level model of a vector is a sequence of elements. The - -- sequence really is similar to the vector itself. However, it is not - -- limited which allows usage of 'Old and 'Loop_Entry attributes. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - - function Element - (S : M.Sequence; - I : Index_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function Empty_Vector return Vector with - Global => null, - Post => Length (Empty_Vector'Result) = 0; - - function "=" (Left, Right : Vector) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - with - Global => null, - Post => - Formal_Indefinite_Vectors.Length (To_Vector'Result) = Length - and M.Constant_Range - (Container => Model (To_Vector'Result), - Fst => Index_Type'First, - Lst => Last_Index (To_Vector'Result), - Item => New_Item); - - function Capacity (Container : Vector) return Capacity_Range with - Global => null, - Post => - Capacity'Result = - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - pragma Annotate (GNATprove, Inline_For_Proof, Capacity); - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - with - Global => null, - Pre => (if Bounded then Capacity <= Container.Capacity), - Post => Model (Container) = Model (Container)'Old; - - function Is_Empty (Container : Vector) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Vector) with - Global => null, - Post => Length (Container) = 0; - -- Note that this reclaims storage in the unbounded case. You need to call - -- this before a container goes out of scope in order to avoid storage - -- leaks. In addition, "X := ..." can leak unless you Clear(X) first. - - procedure Assign (Target : in out Vector; Source : Vector) with - Global => null, - Pre => (if Bounded then Length (Source) <= Target.Capacity), - Post => Model (Target) = Model (Source); - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - with - Global => null, - Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)), - Post => - Model (Copy'Result) = Model (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Length (Source) - else - Copy'Result.Capacity = Capacity); - - procedure Move (Target : in out Vector; Source : in out Vector) - with - Global => null, - Pre => (if Bounded then Length (Source) <= Capacity (Target)), - Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => Element'Result = Element (Model (Container), Index); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - - -- Container now has New_Item at index Index - - and Element (Model (Container), Index) = New_Item - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container)'Old, - Right => Model (Container), - Position => Index); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item) - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Elements of New_Item are inserted at position Before - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => Count_Type (Before - Index_Type'First))) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Capacity (Container) - and then (Before in Index_Type'First .. Last_Index (Container) + 1), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Container now has New_Item at index Before - - and Element (Model (Container), Before) = New_Item - - -- Elements located after Before in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Count - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- New_Item is inserted Count times at position Before - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Before, - Lst => Before + Index_Type'Base (Count - 1), - Item => New_Item)) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Prepend (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements of New_Item are inserted at the beginning of Container - - and M.Range_Equal - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item)) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Container now has New_Item at Index_Type'First - - and Element (Model (Container), Index_Type'First) = New_Item - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- New_Item is inserted Count times at the beginning of Container - - and M.Constant_Range - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Index_Type'First + Index_Type'Base (Count - 1), - Item => New_Item) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Append (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Elements of New_Item are inserted at the end of Container - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => - Count_Type - (Last_Index (Container)'Old - Index_Type'First + 1))); - - procedure Append (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements of Container are preserved - - and Model (Container)'Old < Model (Container) - - -- Container now has New_Item at the end of Container - - and Element - (Model (Container), Last_Index (Container)'Old + 1) = New_Item; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- New_Item is inserted Count times at the end of Container - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Last_Index (Container)'Old + 1, - Lst => - Last_Index (Container)'Old + Index_Type'Base (Count), - Item => New_Item)); - - procedure Delete (Container : in out Vector; Index : Extended_Index) with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements located before Index in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1) - - -- Elements located after Index in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - with - Global => null, - Pre => - Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- The elements of Container located before Index are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => - Length (Container) = Count_Type (Index - Index_Type'First), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_First (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete_First (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_Last (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are preserved - - and Model (Container) < Model (Container)'Old; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old); - - procedure Reverse_Elements (Container : in out Vector) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - with - Global => null, - Pre => - I in First_Index (Container) .. Last_Index (Container) - and then J in First_Index (Container) .. Last_Index (Container), - Post => - M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); - - function First_Index (Container : Vector) return Index_Type with - Global => null, - Post => First_Index'Result = Index_Type'First; - pragma Annotate (GNATprove, Inline_For_Proof, First_Index); - - function First_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = Element (Model (Container), Index_Type'First); - pragma Annotate (GNATprove, Inline_For_Proof, First_Element); - - function Last_Index (Container : Vector) return Extended_Index with - Global => null, - Post => Last_Index'Result = M.Last (Model (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); - - function Last_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = - Element (Model (Container), Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container after Index, Find_Index - -- returns No_Index. - - (Index > Last_Index (Container) - or else not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Last_Index (Container), - Item => Item) - => - Find_Index'Result = No_Index, - - -- Otherwise, Find_Index returns a valid index greater than Index - - others => - Find_Index'Result in Index .. Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Find_Index'Result) = Item - - -- It is the first occurrence of Item after Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Find_Index'Result - 1, - Item => Item)); - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container before Index, - -- Reverse_Find_Index returns No_Index. - - (not M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => (if Index <= Last_Index (Container) then Index - else Last_Index (Container)), - Item => Item) - => - Reverse_Find_Index'Result = No_Index, - - -- Otherwise, Reverse_Find_Index returns a valid index smaller than - -- Index - - others => - Reverse_Find_Index'Result in Index_Type'First .. Index - and Reverse_Find_Index'Result <= Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Reverse_Find_Index'Result) = Item - - -- It is the last occurrence of Item before Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Reverse_Find_Index'Result + 1, - Lst => - (if Index <= Last_Index (Container) then - Index - else - Last_Index (Container)), - Item => Item)); - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = - M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container), - Item => Item); - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for all J in I .. M.Last (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : Vector) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out Vector) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Last_Index (Container), - Right => Model (Container), - R_Lst => Last_Index (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Last_Index (Container), - Right => Model (Container)'Old, - R_Lst => Last_Index (Container)); - - procedure Merge (Target : in out Vector; Source : in out Vector) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Capacity (Target) - Length (Target), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Last_Index (Target)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Last_Index (Source)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Replace_Element); - pragma Inline (Contains); - - -- The implementation method is to instantiate Bounded_Holders to get a - -- definite type for Element_Type. - - package Holders is new Bounded_Holders - (Element_Type, Max_Size_In_Storage_Elements, "="); - use Holders; - - subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; - type Elements_Array is array (Array_Index range <>) of Holder; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Elements_Array_Ptr is access all Elements_Array; - - type Vector (Capacity : Capacity_Range) is limited record - - -- In the bounded case, the elements are stored in Elements. In the - -- unbounded case, the elements are initially stored in Elements, until - -- we run out of room, then we switch to Elements_Ptr. - - Last : Extended_Index := No_Index; - Elements_Ptr : Elements_Array_Ptr := null; - Elements : aliased Elements_Array (1 .. Capacity); - end record; - - -- The primary reason Vector is limited is that in the unbounded case, once - -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will - -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr, - -- so for example "Append (X, ...);" will modify BOTH X and Y. That would - -- allow SPARK to "prove" things that are false. We could fix that by - -- making Vector a controlled type, and override Adjust to make a deep - -- copy, but finalization is not allowed in SPARK. - -- - -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not - -- allowed on Vectors. - - function Empty_Vector return Vector is - ((Capacity => 0, others => <>)); - -end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/a-cforma.adb b/gcc/ada/a-cforma.adb deleted file mode 100644 index 5967973..0000000 --- a/gcc/ada/a-cforma.adb +++ /dev/null @@ -1,1159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); - -with System; use type System.Address; - -package body Ada.Containers.Formal_Ordered_Maps with - SPARK_Mode => Off -is - - ----------------------------- - -- Node Access Subprograms -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color - (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type; - pragma Inline (Color); - - function Left_Son (Node : Node_Type) return Count_Type; - pragma Inline (Left_Son); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right_Son (Node : Node_Type) return Count_Type; - pragma Inline (Right_Son); - - procedure Set_Color - (Node : in out Node_Type; - Color : Ada.Containers.Red_Black_Trees.Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All need comments ??? - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type); - - procedure Free (Tree : in out Map; X : Count_Type); - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations - (Tree_Types => Tree_Types, - Left => Left_Son, - Right => Right_Son); - - use Tree_Operations; - - package Key_Ops is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - Lst : Count_Type; - Node : Count_Type; - ENode : Count_Type; - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Is_Empty (Left) then - return True; - end if; - - Lst := Next (Left, Last (Left).Node); - - Node := First (Left).Node; - while Node /= Lst loop - ENode := Find (Right, Left.Nodes (Node).Key).Node; - - if ENode = 0 or else - Left.Nodes (Node).Element /= Right.Nodes (ENode).Element - then - return False; - end if; - - Node := Next (Left, Node); - end loop; - - return True; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Key_Ops.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Key_Ops.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Target, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Key := SN.Key; - Node.Element := SN.Element; - end Set_Element; - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target, - Hint => 0, - Key => SN.Key, - Node => Target_Node); - end Append_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Storage_Error with "not enough capacity"; -- SE or CE? ??? - end if; - - Tree_Operations.Clear_Tree (Target); - Append_Elements (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - Tree_Operations.Clear_Tree (Container); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Color_Type is - begin - return Node.Color; - end Color; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map is - Node : Count_Type := 1; - N : Count_Type; - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do - if Length (Source) > 0 then - Target.Length := Source.Length; - Target.Root := Source.Root; - Target.First := Source.First; - Target.Last := Source.Last; - Target.Free := Source.Free; - - while Node <= Source.Capacity loop - Target.Nodes (Node).Element := - Source.Nodes (Node).Element; - Target.Nodes (Node).Key := - Source.Nodes (Node).Key; - Target.Nodes (Node).Parent := - Source.Nodes (Node).Parent; - Target.Nodes (Node).Left := - Source.Nodes (Node).Left; - Target.Nodes (Node).Right := - Source.Nodes (Node).Right; - Target.Nodes (Node).Color := - Source.Nodes (Node).Color; - Target.Nodes (Node).Has_Element := - Source.Nodes (Node).Has_Element; - Node := Node + 1; - end loop; - - while Node <= Target.Capacity loop - N := Node; - Formal_Ordered_Maps.Free (Tree => Target, X => N); - Node := Node + 1; - end loop; - end if; - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Delete has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Delete is bad"); - - Tree_Operations.Delete_Node_Sans_Free (Container, - Position.Node); - Formal_Ordered_Maps.Free (Container, Position.Node); - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : constant Node_Access := Key_Ops.Find (Container, Key); - - begin - if X = 0 then - raise Constraint_Error with "key not in map"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Maps.Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Map) is - X : constant Node_Access := First (Container).Node; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Maps.Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Map) is - X : constant Node_Access := Last (Container).Node; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Maps.Free (Container, X); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Element has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of function Element is bad"); - - return Container.Nodes (Position.Node).Element; - - end Element; - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Find (Container, Key).Node; - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - return Container.Nodes (Node).Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : constant Node_Access := Key_Ops.Find (Container, Key); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Maps.Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Find (Container, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Map) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (First (Container).Node).Element; - end First_Element; - - --------------- - -- First_Key -- - --------------- - - function First_Key (Container : Map) return Key_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (First (Container).Node).Key; - end First_Key; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Map; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Ops.Floor (Container, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ---------- - -- Find -- - ---------- - - function Find - (Container : K.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. K.Length (Container) loop - if Equivalent_Keys (Key, K.Get (Container, I)) then - return I; - elsif Key < K.Get (Container, I) then - return 0; - end if; - end loop; - return 0; - end Find; - - ------------------------- - -- K_Bigger_Than_Range -- - ------------------------- - - function K_Bigger_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (K.Get (Container, I) < Key) then - return False; - end if; - end loop; - return True; - end K_Bigger_Than_Range; - - --------------- - -- K_Is_Find -- - --------------- - - function K_Is_Find - (Container : K.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Key < K.Get (Container, I) then - return False; - end if; - end loop; - - if Position < K.Length (Container) then - for I in Position + 1 .. K.Length (Container) loop - if K.Get (Container, I) < Key then - return False; - end if; - end loop; - end if; - return True; - end K_Is_Find; - - -------------------------- - -- K_Smaller_Than_Range -- - -------------------------- - - function K_Smaller_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Key < K.Get (Container, I)) then - return False; - end if; - end loop; - return True; - end K_Smaller_Than_Range; - - ---------- - -- Keys -- - ---------- - - function Keys (Container : Map) return K.Sequence is - Position : Count_Type := Container.First; - R : K.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := K.Add (R, Container.Nodes (Position).Key); - Position := Tree_Operations.Next (Container, Position); - end loop; - - return R; - end Keys; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Map) is null; - - ----------- - -- Model -- - ----------- - - function Model (Container : Map) return M.Map is - Position : Count_Type := Container.First; - R : M.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - New_Key => Container.Nodes (Position).Key, - New_Item => Container.Nodes (Position).Element); - - Position := Tree_Operations.Next (Container, Position); - end loop; - - return R; - end Model; - - ------------------------- - -- P_Positions_Shifted -- - ------------------------- - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) + Count - then - return False; - end if; - - else - if P.Has_Key (Small, Cu) then - return False; - end if; - end if; - end; - end loop; - - return True; - end P_Positions_Shifted; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Map) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.First; - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); - Position := Tree_Operations.Next (Container, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free - (Tree : in out Map; - X : Count_Type) - is - begin - Tree.Nodes (X).Has_Element := False; - Tree_Operations.Free (Tree, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type) - is - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - begin - Allocate (Tree, Node); - Tree.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Map; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - end if; - - return Container.Nodes (Position.Node).Has_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - declare - N : Node_Type renames Container.Nodes (Position.Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end if; - end Include; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - -- Comment ??? - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - procedure Initialize (Node : in out Node_Type); - procedure Allocate_Node is new Generic_Allocate (Initialize); - - procedure Initialize (Node : in out Node_Type) is - begin - Node.Key := Key; - Node.Element := New_Item; - end Initialize; - - X : Node_Access; - - begin - Allocate_Node (Container, X); - return X; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container, - Key, - Position.Node, - Inserted); - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with "key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - -- k > node same as node < k - - return Right.Key < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Key; - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Container : Map; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of function Key has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of function Key is bad"); - - return Container.Nodes (Position.Node).Key; - end Key; - - ---------- - -- Last -- - ---------- - - function Last (Container : Map) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.Last); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Map) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (Last (Container).Node).Element; - end Last_Element; - - -------------- - -- Last_Key -- - -------------- - - function Last_Key (Container : Map) return Key_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "map is empty"; - end if; - - return Container.Nodes (Last (Container).Node).Key; - end Last_Key; - - -------------- - -- Left_Son -- - -------------- - - function Left_Son (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left_Son; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Map; Source : in out Map) is - NN : Tree_Types.Nodes_Type renames Source.Nodes; - X : Node_Access; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - loop - X := First (Source).Node; - exit when X = 0; - - -- Here we insert a copy of the source element into the target, and - -- then delete the element from the source. Another possibility is - -- that delete it first (and hang onto its index), then insert it. - -- ??? - - Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? - - Tree_Operations.Delete_Node_Sans_Free (Source, X); - Formal_Ordered_Maps.Free (Source, X); - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Container : Map; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - function Next (Container : Map; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Next"); - - return (Node => Tree_Operations.Next (Container, Position.Node)); - end Next; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Container : Map; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - function Previous (Container : Map; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Count_Type := - Tree_Operations.Previous (Container, Position.Node); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Previous; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - begin - declare - Node : constant Node_Access := Key_Ops.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in map"; - end if; - - declare - N : Node_Type renames Container.Nodes (Node); - begin - N.Key := Key; - N.Element := New_Item; - end; - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor of Replace_Element has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "Position cursor of Replace_Element is bad"); - - Container.Nodes (Position.Node).Element := New_Item; - end Replace_Element; - - --------------- - -- Right_Son -- - --------------- - - function Right_Son (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right_Son; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - -end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforma.ads b/gcc/ada/a-cforma.ads deleted file mode 100644 index ed4e872..0000000 --- a/gcc/ada/a-cforma.ads +++ /dev/null @@ -1,1052 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- This spec is derived from package Ada.Containers.Bounded_Ordered_Maps in --- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Key, Element, Next, Query_Element, Previous, --- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the --- need to have cursors which are valid on different containers (typically a --- container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. The operators "<" and ">" that could not be modified that way --- have been removed. - --- Iteration over maps is done using the Iterable aspect, which is SPARK --- compatible. "For of" iteration ranges over keys instead of elements. - -with Ada.Containers.Functional_Vectors; -with Ada.Containers.Functional_Maps; -private with Ada.Containers.Red_Black_Trees; - -generic - type Key_Type is private; - type Element_Type is private; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - -package Ada.Containers.Formal_Ordered_Maps with - SPARK_Mode -is - pragma Annotate (CodePeer, Skip_Analysis); - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean with - Global => null, - Post => - Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); - - type Map (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Key), - Default_Initial_Condition => Is_Empty (Map); - pragma Preelaborable_Initialization (Map); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - Empty_Map : constant Map; - - function Length (Container : Map) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Maps - (Element_Type => Element_Type, - Key_Type => Key_Type, - Equivalent_Keys => Equivalent_Keys); - - function "=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."="; - - function "<=" - (Left : M.Map; - Right : M.Map) return Boolean renames M."<="; - - package K is new Ada.Containers.Functional_Vectors - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."="; - - function "<" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<"; - - function "<=" - (Left : K.Sequence; - Right : K.Sequence) return Boolean renames K."<="; - - function K_Bigger_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= K.Length (Container), - Post => - K_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => K.Get (Container, I) < Key); - pragma Annotate (GNATprove, Inline_For_Proof, K_Bigger_Than_Range); - - function K_Smaller_Than_Range - (Container : K.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= K.Length (Container), - Post => - K_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => Key < K.Get (Container, I)); - pragma Annotate (GNATprove, Inline_For_Proof, K_Smaller_Than_Range); - - function K_Is_Find - (Container : K.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= K.Length (Container), - Post => - K_Is_Find'Result = - ((if Position > 0 then - K_Bigger_Than_Range (Container, 1, Position - 1, Key)) - - and - (if Position < K.Length (Container) then - K_Smaller_Than_Range - (Container, - Position + 1, - K.Length (Container), - Key))); - pragma Annotate (GNATprove, Inline_For_Proof, K_Is_Find); - - function Find (Container : K.Sequence; Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= K.Length (Container) - and Equivalent_Keys (Key, K.Get (Container, Find'Result))); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Model (Container : Map) return M.Map with - -- The high-level model of a map is a map from keys to elements. Neither - -- cursors nor order of elements are represented in this model. Keys are - -- modeled up to equivalence. - - Ghost, - Global => null; - - function Keys (Container : Map) return K.Sequence with - -- The Keys sequence represents the underlying list structure of maps - -- that is used for iteration. It stores the actual values of keys in - -- the map. It does not model cursors nor elements. - - Ghost, - Global => null, - Post => - K.Length (Keys'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Key of Keys'Result => - M.Has_Key (Model (Container), Key)) - - -- It contains all the keys contained in Model - - and (for all Key of Model (Container) => - (Find (Keys'Result, Key) > 0 - and then Equivalent_Keys - (K.Get (Keys'Result, Find (Keys'Result, Key)), - Key))) - - -- It is sorted in increasing order - - and (for all I in 1 .. Length (Container) => - Find (Keys'Result, K.Get (Keys'Result, I)) = I - and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I)); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); - - function Positions (Container : Map) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length. - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Map) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Key of Keys (Container) => - (for some I of Positions (Container) => - K.Get (Keys (Container), P.Get (Positions (Container), I)) = - Key)); - - function Contains - (C : M.Map; - K : Key_Type) return Boolean renames M.Has_Key; - -- To improve readability of contracts, we rename the function used to - -- search for a key in the model to Contains. - - function Element - (C : M.Map; - K : Key_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - end Formal_Model; - use Formal_Model; - - function "=" (Left, Right : Map) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function Is_Empty (Container : Map) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Map) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Map; Source : Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Keys (Target) = Keys (Source) - and Length (Source) = Length (Target); - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Keys (Copy'Result) = Keys (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Key (Container : Map; Position : Cursor) return Key_Type with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Key'Result = - K.Get (Keys (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element - (Container : Map; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = Element (Model (Container), Key (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - - -- Order of keys and cursors is preserved - - Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old - - -- New_Item is now associated with the key at position Position in - -- Container. - - and Element (Container, Position) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key (Container, Position)); - - procedure Move (Target : in out Map; Source : in out Map) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Keys (Target) = Keys (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) - and Has_Element (Container, Position) - and Equivalent_Keys - (Formal_Ordered_Maps.Key (Container, Position), Key) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Position)), - Contract_Cases => - - -- If Key is already in Container, it is not modified and Inserted is - -- set to False. - - (Contains (Container, Key) => - not Inserted - and Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is inserted in Container and Inserted is set to True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Key now maps to New_Item - - and Formal_Ordered_Maps.Key (Container, Position) = Key - and Element (Model (Container), Key) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- The keys of Container located before Position are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted at position Position in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position))); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, Key)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, Key) - - -- Key now maps to New_Item - - and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key - and Element (Model (Container), Key) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => Find (Keys (Container), Key), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Keys (Container), Key)); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity or Contains (Container, Key), - Post => - Contains (Container, Key) and Element (Container, Key) = New_Item, - Contract_Cases => - - -- If Key is already in Container, Key is mapped to New_Item - - (Contains (Container, Key) => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get - (Keys (Container), Find (Keys (Container), Key)) = Key - - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - Find (Keys (Container), Key)) - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key), - - -- Otherwise, Key is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Keys_Included_Except - (Model (Container), - Model (Container)'Old, - Key) - - -- Key is inserted in Container - - and K.Get - (Keys (Container), Find (Keys (Container), Key)) = Key - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key) - 1) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => Find (Keys (Container), Key), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Keys (Container), Key))); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - - -- Cursors are preserved - - Positions (Container) = Positions (Container)'Old - - -- The key equivalent to Key in Container is replaced by Key - - and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key - and K.Equal_Except - (Keys (Container)'Old, - Keys (Container), - Find (Keys (Container), Key)) - - -- New_Item is now associated with the Key in Container - - and Element (Model (Container), Key) = New_Item - - -- Elements associated with other keys are preserved - - and M.Same_Keys (Model (Container), Model (Container)'Old) - and M.Elements_Equal_Except - (Model (Container), - Model (Container)'Old, - Key); - - procedure Exclude (Container : in out Map; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Keys (Container) = Keys (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key)'Old - 1) - - -- The keys located after Key are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => Find (Keys (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Keys (Container), Key)'Old)); - - procedure Delete (Container : in out Map; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The keys of Container located before Key are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Find (Keys (Container), Key)'Old - 1) - - -- The keys located after Key are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => Find (Keys (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Keys (Container), Key)'Old); - - procedure Delete (Container : in out Map; Position : in out Cursor) with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The key at position Position is no longer in Container - - and not Contains (Container, Key (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Key (Container, Position)'Old) - - -- The keys of Container located before Position are preserved. - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The keys located after Position are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete_First (Container : in out Map) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The first key has been removed from Container - - and not Contains (Container, First_Key (Container)'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - First_Key (Container)'Old) - - -- Other keys are shifted by 1 - - and K.Range_Shifted - (Left => Keys (Container), - Right => Keys (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- First has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1)); - - procedure Delete_Last (Container : in out Map) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The last key has been removed from Container - - and not Contains (Container, Last_Key (Container)'Old) - - -- Other mappings are preserved - - and Model (Container) <= Model (Container)'Old - and M.Keys_Included_Except - (Model (Container)'Old, - Model (Container), - Last_Key (Container)'Old) - - -- Others keys of Container are preserved - - and K.Range_Equal - (Left => Keys (Container)'Old, - Right => Keys (Container), - Fst => 1, - Lst => Length (Container)) - - -- Last cursor has been removed from Container - - and Positions (Container) <= Positions (Container)'Old); - - function First (Container : Map) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : Map) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = - Element (Model (Container), First_Key (Container)); - - function First_Key (Container : Map) return Key_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Key'Result = K.Get (Keys (Container), 1) - and K_Smaller_Than_Range - (Keys (Container), 2, Length (Container), First_Key'Result); - - function Last (Container : Map) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : Map) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = Element (Model (Container), Last_Key (Container)); - - function Last_Key (Container : Map) return Key_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Key'Result = K.Get (Keys (Container), Length (Container)) - and K_Bigger_Than_Range - (Keys (Container), 1, Length (Container) - 1, Last_Key'Result); - - function Next (Container : Map; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : Map; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : Map; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : Map; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Key) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Keys (Container), Key) - - -- The key designated by the result of Find is Key - - and Equivalent_Keys - (Formal_Ordered_Maps.Key (Container, Find'Result), Key)); - - function Element (Container : Map; Key : Key_Type) return Element_Type with - Global => null, - Pre => Contains (Container, Key), - Post => Element'Result = Element (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - function Floor (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Key < First_Key (Container) => - Floor'Result = No_Element, - - others => - Has_Element (Container, Floor'Result) - and not (Key < K.Get (Keys (Container), - P.Get (Positions (Container), Floor'Result))) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Map; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Last_Key (Container) < Key => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and not (K.Get - (Keys (Container), - P.Get (Positions (Container), Ceiling'Result)) < Key) - and K_Is_Find - (Keys (Container), - Key, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Map; Key : Key_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Key); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Map; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - pragma Inline (Previous); - - subtype Node_Access is Count_Type; - - use Red_Black_Trees; - - type Node_Type is record - Has_Element : Boolean := False; - Parent : Node_Access := 0; - Left : Node_Access := 0; - Right : Node_Access := 0; - Color : Red_Black_Trees.Color_Type := Red; - Key : Key_Type; - Element : Element_Type; - end record; - - package Tree_Types is - new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Map (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; - - Empty_Map : constant Map := (Capacity => 0, others => <>); - -end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/a-cforse.adb b/gcc/ada/a-cforse.adb deleted file mode 100644 index 6c7f8e4..0000000 --- a/gcc/ada/a-cforse.adb +++ /dev/null @@ -1,1898 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; -pragma Elaborate_All - (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); - -with System; use type System.Address; - -package body Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode => Off -is - - ------------------------------ - -- Access to Fields of Node -- - ------------------------------ - - -- These subprograms provide functional notation for access to fields - -- of a node, and procedural notation for modifiying these fields. - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; - pragma Inline (Color); - - function Left_Son (Node : Node_Type) return Count_Type; - pragma Inline (Left_Son); - - function Parent (Node : Node_Type) return Count_Type; - pragma Inline (Parent); - - function Right_Son (Node : Node_Type) return Count_Type; - pragma Inline (Right_Son); - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type); - pragma Inline (Set_Left); - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- Comments needed??? - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type); - - procedure Free (Tree : in out Set; X : Count_Type); - - procedure Insert_Sans_Hint - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Insert_With_Hint - (Dst_Set : in out Set; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean; - pragma Inline (Is_Less_Node_Node); - - procedure Replace_Element - (Tree : in out Set; - Node : Count_Type; - Item : Element_Type); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Bounded_Operations - (Tree_Types, - Left => Left_Son, - Right => Right_Son); - - use Tree_Operations; - - package Element_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - package Set_Ops is - new Red_Black_Trees.Generic_Bounded_Set_Operations - (Tree_Operations => Tree_Operations, - Set_Type => Set, - Assign => Assign, - Insert_With_Hint => Insert_With_Hint, - Is_Less => Is_Less_Node_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - Lst : Count_Type; - Node : Count_Type; - ENode : Count_Type; - - begin - if Length (Left) /= Length (Right) then - return False; - end if; - - if Is_Empty (Left) then - return True; - end if; - - Lst := Next (Left, Last (Left).Node); - - Node := First (Left).Node; - while Node /= Lst loop - ENode := Find (Right, Left.Nodes (Node).Element).Node; - if ENode = 0 - or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element - then - return False; - end if; - - Node := Next (Left, Node); - end loop; - - return True; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - procedure Append_Element (Source_Node : Count_Type); - - procedure Append_Elements is - new Tree_Operations.Generic_Iteration (Append_Element); - - -------------------- - -- Append_Element -- - -------------------- - - procedure Append_Element (Source_Node : Count_Type) is - SN : Node_Type renames Source.Nodes (Source_Node); - - procedure Set_Element (Node : in out Node_Type); - pragma Inline (Set_Element); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert_Sans_Hint is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - procedure Unconditional_Insert_Avec_Hint is - new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Unconditional_Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Target, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := SN.Element; - end Set_Element; - - -- Local variables - - Target_Node : Count_Type; - - -- Start of processing for Append_Element - - begin - Unconditional_Insert_Avec_Hint - (Tree => Target, - Hint => 0, - Key => SN.Element, - Node => Target_Node); - end Append_Element; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error - with "Target capacity is less than Source length"; - end if; - - Tree_Operations.Clear_Tree (Target); - Append_Elements (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := Element_Keys.Ceiling (Container, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - Tree_Operations.Clear_Tree (Container); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is - begin - return Node.Color; - end Color; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set is - Node : Count_Type; - N : Count_Type; - Target : Set (Count_Type'Max (Source.Capacity, Capacity)); - - begin - if 0 < Capacity and then Capacity < Source.Capacity then - raise Capacity_Error; - end if; - - if Length (Source) > 0 then - Target.Length := Source.Length; - Target.Root := Source.Root; - Target.First := Source.First; - Target.Last := Source.Last; - Target.Free := Source.Free; - - Node := 1; - while Node <= Source.Capacity loop - Target.Nodes (Node).Element := - Source.Nodes (Node).Element; - Target.Nodes (Node).Parent := - Source.Nodes (Node).Parent; - Target.Nodes (Node).Left := - Source.Nodes (Node).Left; - Target.Nodes (Node).Right := - Source.Nodes (Node).Right; - Target.Nodes (Node).Color := - Source.Nodes (Node).Color; - Target.Nodes (Node).Has_Element := - Source.Nodes (Node).Has_Element; - Node := Node + 1; - end loop; - - while Node <= Target.Capacity loop - N := Node; - Formal_Ordered_Sets.Free (Tree => Target, X => N); - Node := Node + 1; - end loop; - end if; - - return Target; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Delete"); - - Tree_Operations.Delete_Node_Sans_Free (Container, - Position.Node); - Formal_Ordered_Sets.Free (Container, Position.Node); - Position := No_Element; - end Delete; - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container, Item); - - begin - if X = 0 then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - X : constant Count_Type := Container.First; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - X : constant Count_Type := Container.Last; - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end if; - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Difference (Target, Source); - end Difference; - - function Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Left) = 0 then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Left.Copy; - end if; - - return S : Set (Length (Left)) do - Assign (S, Set_Ops.Set_Difference (Left, Right)); - end return; - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Position : Cursor) return Element_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Element"); - - return Container.Nodes (Position.Node).Element; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - function Is_Equivalent_Node_Node - (L, R : Node_Type) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is - begin - if L.Element < R.Element then - return False; - elsif R.Element < L.Element then - return False; - else - return True; - end if; - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left, Right); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : constant Count_Type := Element_Keys.Find (Container, Item); - begin - if X /= 0 then - Tree_Operations.Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Count_Type := Element_Keys.Find (Container, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - if Length (Container) = 0 then - return No_Element; - end if; - - return (Node => Container.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - Fst : constant Count_Type := First (Container).Node; - begin - if Fst = 0 then - raise Constraint_Error with "set is empty"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - begin - return N (Fst).Element; - end; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - begin - declare - Node : constant Count_Type := Element_Keys.Floor (Container, Item); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end; - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Bigger_Than_Range -- - ------------------------- - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (E.Get (Container, I) < Item) then - return False; - end if; - end loop; - - return True; - end E_Bigger_Than_Range; - - ------------------------- - -- E_Elements_Included -- - ------------------------- - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) - then - return False; - end if; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Left) loop - declare - Item : constant Element_Type := E.Get (Left, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - is - begin - for I in 1 .. E.Length (Container) loop - declare - Item : constant Element_Type := E.Get (Container, I); - begin - if M.Contains (Model, Item) then - if not E.Contains (Left, 1, E.Length (Left), Item) then - return False; - end if; - else - if not E.Contains (Right, 1, E.Length (Right), Item) then - return False; - end if; - end if; - end; - end loop; - - return True; - end E_Elements_Included; - - --------------- - -- E_Is_Find -- - --------------- - - function E_Is_Find - (Container : E.Sequence; - Item : Element_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Item < E.Get (Container, I) then - return False; - end if; - end loop; - - if Position < E.Length (Container) then - for I in Position + 1 .. E.Length (Container) loop - if E.Get (Container, I) < Item then - return False; - end if; - end loop; - end if; - - return True; - end E_Is_Find; - - -------------------------- - -- E_Smaller_Than_Range -- - -------------------------- - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Item < E.Get (Container, I)) then - return False; - end if; - end loop; - - return True; - end E_Smaller_Than_Range; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Elements (Item, E.Get (Container, I)) then - return I; - end if; - end loop; - - return 0; - end Find; - - -------------- - -- Elements -- - -------------- - - function Elements (Container : Set) return E.Sequence is - Position : Count_Type := Container.First; - R : E.Sequence; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := E.Add (R, Container.Nodes (Position).Element); - Position := Tree_Operations.Next (Container, Position); - end loop; - - return R; - end Elements; - - ---------------------------- - -- Lift_Abstraction_Level -- - ---------------------------- - - procedure Lift_Abstraction_Level (Container : Set) is null; - - ----------------------- - -- Mapping_Preserved -- - ----------------------- - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - is - begin - for C of P_Left loop - if not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C)) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved; - - ------------------------------ - -- Mapping_Preserved_Except -- - ------------------------------ - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - is - begin - for C of P_Left loop - if C /= Position - and (not P.Has_Key (P_Right, C) - or else P.Get (P_Left, C) > E.Length (E_Left) - or else P.Get (P_Right, C) > E.Length (E_Right) - or else E.Get (E_Left, P.Get (P_Left, C)) /= - E.Get (E_Right, P.Get (P_Right, C))) - then - return False; - end if; - end loop; - - return True; - end Mapping_Preserved_Except; - - ------------------------- - -- P_Positions_Shifted -- - ------------------------- - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - is - begin - for Cu of Small loop - if not P.Has_Key (Big, Cu) then - return False; - end if; - end loop; - - for Cu of Big loop - declare - Pos : constant Positive_Count_Type := P.Get (Big, Cu); - - begin - if Pos < Cut then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) - then - return False; - end if; - - elsif Pos >= Cut + Count then - if not P.Has_Key (Small, Cu) - or else Pos /= P.Get (Small, Cu) + Count - then - return False; - end if; - - else - if P.Has_Key (Small, Cu) then - return False; - end if; - end if; - end; - end loop; - - return True; - end P_Positions_Shifted; - - ----------- - -- Model -- - ----------- - - function Model (Container : Set) return M.Set is - Position : Count_Type := Container.First; - R : M.Set; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := - M.Add - (Container => R, - Item => Container.Nodes (Position).Element); - - Position := Tree_Operations.Next (Container, Position); - end loop; - - return R; - end Model; - - --------------- - -- Positions -- - --------------- - - function Positions (Container : Set) return P.Map is - I : Count_Type := 1; - Position : Count_Type := Container.First; - R : P.Map; - - begin - -- Can't use First, Next or Element here, since they depend on models - -- for their postconditions. - - while Position /= 0 loop - R := P.Add (R, (Node => Position), I); - pragma Assert (P.Length (R) = I); - Position := Tree_Operations.Next (Container, Position); - I := I + 1; - end loop; - - return R; - end Positions; - - end Formal_Model; - - ---------- - -- Free -- - ---------- - - procedure Free (Tree : in out Set; X : Count_Type) is - begin - Tree.Nodes (X).Has_Element := False; - Tree_Operations.Free (Tree, X); - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (Tree : in out Tree_Types.Tree_Type'Class; - Node : out Count_Type) - is - procedure Allocate is - new Tree_Operations.Generic_Allocate (Set_Element); - begin - Allocate (Tree, Node); - Tree.Nodes (Node).Has_Element := True; - end Generic_Allocate; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys with SPARK_Mode => Off is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Bounded_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Ceiling (Container, Key); - - begin - if Node = 0 then - return No_Element; - end if; - - return (Node => Node); - end Ceiling; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if X = 0 then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - - begin - if Node = 0 then - raise Constraint_Error with "key not in set"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - begin - return N (Node).Element; - end; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : constant Count_Type := Key_Keys.Find (Container, Key); - begin - if X /= 0 then - Delete_Node_Sans_Free (Container, X); - Formal_Ordered_Sets.Free (Container, X); - end if; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Count_Type := Key_Keys.Floor (Container, Key); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end Floor; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- E_Bigger_Than_Range -- - ------------------------- - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Generic_Keys.Key (E.Get (Container, I)) < Key) then - return False; - end if; - end loop; - return True; - end E_Bigger_Than_Range; - - --------------- - -- E_Is_Find -- - --------------- - - function E_Is_Find - (Container : E.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - is - begin - for I in 1 .. Position - 1 loop - if Key < Generic_Keys.Key (E.Get (Container, I)) then - return False; - end if; - end loop; - - if Position < E.Length (Container) then - for I in Position + 1 .. E.Length (Container) loop - if Generic_Keys.Key (E.Get (Container, I)) < Key then - return False; - end if; - end loop; - end if; - return True; - end E_Is_Find; - - -------------------------- - -- E_Smaller_Than_Range -- - -------------------------- - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if not (Key < Generic_Keys.Key (E.Get (Container, I))) then - return False; - end if; - end loop; - return True; - end E_Smaller_Than_Range; - - ---------- - -- Find -- - ---------- - - function Find - (Container : E.Sequence; - Key : Key_Type) return Count_Type - is - begin - for I in 1 .. E.Length (Container) loop - if Equivalent_Keys - (Key, Generic_Keys.Key (E.Get (Container, I))) - then - return I; - end if; - end loop; - return 0; - end Find; - - ----------------------- - -- M_Included_Except -- - ----------------------- - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - is - begin - for E of Left loop - if not Contains (Right, E) - and not Equivalent_Keys (Generic_Keys.Key (E), Key) - then - return False; - end if; - end loop; - return True; - end M_Included_Except; - end Formal_Model; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Key (Right.Element) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Key (Right.Element); - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Container : Set; Position : Cursor) return Key_Type is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Key"); - - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - begin - return Key (N (Position.Node).Element); - end; - end Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Count_Type := Key_Keys.Find (Container, Key); - begin - if not Has_Element (Container, (Node => Node)) then - raise Constraint_Error with - "attempt to replace key not in set"; - else - Replace_Element (Container, Node, New_Item); - end if; - end Replace; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Container : Set; Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return False; - else - return Container.Nodes (Position.Node).Has_Element; - end if; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - begin - N (Position.Node).Element := New_Item; - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted); - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Container : in out Set; - New_Item : Element_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - procedure Set_Element (Node : in out Node_Type); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Conditional_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Container, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := New_Item; - end Set_Element; - - -- Start of processing for Insert_Sans_Hint - - begin - Conditional_Insert_Sans_Hint - (Container, - New_Item, - Node, - Inserted); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Set : in out Set; - Dst_Hint : Count_Type; - Src_Node : Node_Type; - Dst_Node : out Count_Type) - is - Success : Boolean; - pragma Unreferenced (Success); - - procedure Set_Element (Node : in out Node_Type); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Insert_Post, Insert_Sans_Hint); - - procedure Allocate is new Generic_Allocate (Set_Element); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - Result : Count_Type; - begin - Allocate (Dst_Set, Result); - return Result; - end New_Node; - - ----------------- - -- Set_Element -- - ----------------- - - procedure Set_Element (Node : in out Node_Type) is - begin - Node.Element := Src_Node.Element; - end Set_Element; - - -- Start of processing for Insert_With_Hint - - begin - Local_Insert_With_Hint - (Dst_Set, - Dst_Hint, - Src_Node.Element, - Dst_Node, - Success); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Intersection (Target, Source); - end Intersection; - - function Intersection (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Left.Copy; - end if; - - return S : Set (Count_Type'Min (Length (Left), Length (Right))) do - Assign (S, Set_Ops.Set_Intersection (Left, Right)); - end return; - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Length (Container) = 0; - end Is_Empty; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - -- Compute e > node same as node < e - - return Right.Element < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Type) return Boolean - is - begin - return Left < Right.Element; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Type) return Boolean is - begin - return L.Element < R.Element; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - begin - return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set); - end Is_Subset; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - return (if Length (Container) = 0 - then No_Element - else (Node => Container.Last)); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Last (Container).Node = 0 then - raise Constraint_Error with "set is empty"; - end if; - - declare - N : Tree_Types.Nodes_Type renames Container.Nodes; - begin - return N (Last (Container).Node).Element; - end; - end Last_Element; - - -------------- - -- Left_Son -- - -------------- - - function Left_Son (Node : Node_Type) return Count_Type is - begin - return Node.Left; - end Left_Son; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - N : Tree_Types.Nodes_Type renames Source.Nodes; - X : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Length (Source) then - raise Constraint_Error with -- ??? - "Source length exceeds Target capacity"; - end if; - - Clear (Target); - - loop - X := Source.First; - exit when X = 0; - - Insert (Target, N (X).Element); -- optimize??? - - Tree_Operations.Delete_Node_Sans_Free (Source, X); - Formal_Ordered_Sets.Free (Source, X); - end loop; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Container : Set; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Next"); - return (Node => Tree_Operations.Next (Container, Position.Node)); - end Next; - - procedure Next (Container : Set; Position : in out Cursor) is - begin - Position := Next (Container, Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - begin - return Set_Ops.Set_Overlap (Left, Right); - end Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Type) return Count_Type is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - function Previous (Container : Set; Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if not Has_Element (Container, Position) then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Count_Type := - Tree_Operations.Previous (Container, Position.Node); - begin - return (if Node = 0 then No_Element else (Node => Node)); - end; - end Previous; - - procedure Previous (Container : Set; Position : in out Cursor) is - begin - Position := Previous (Container, Position); - end Previous; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Count_Type := Element_Keys.Find (Container, New_Item); - - begin - if Node = 0 then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - Container.Nodes (Node).Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Tree : in out Set; - Node : Count_Type; - Item : Element_Type) - is - pragma Assert (Node /= 0); - - function New_Node return Count_Type; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Local_Insert_Post, - Local_Insert_Sans_Hint); - - NN : Tree_Types.Nodes_Type renames Tree.Nodes; - - -------------- - -- New_Node -- - -------------- - - function New_Node return Count_Type is - N : Node_Type renames NN (Node); - begin - N.Element := Item; - N.Color := Red; - N.Parent := 0; - N.Right := 0; - N.Left := 0; - return Node; - end New_Node; - - Hint : Count_Type; - Result : Count_Type; - Inserted : Boolean; - - -- Start of processing for Insert - - begin - if Item < NN (Node).Element - or else NN (Node).Element < Item - then - null; - - else - NN (Node).Element := Item; - return; - end if; - - Hint := Element_Keys.Ceiling (Tree, Item); - - if Hint = 0 then - null; - - elsif Item < NN (Hint).Element then - if Hint = Node then - NN (Node).Element := Item; - return; - end if; - - else - pragma Assert (not (NN (Hint).Element < Item)); - raise Program_Error with "attempt to replace existing element"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); - - Local_Insert_With_Hint - (Tree => Tree, - Position => Hint, - Key => Item, - Node => Result, - Inserted => Inserted); - - pragma Assert (Inserted); - pragma Assert (Result = Node); - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if not Has_Element (Container, Position) then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Container, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container, Position.Node, New_Item); - end Replace_Element; - - --------------- - -- Right_Son -- - --------------- - - function Right_Son (Node : Node_Type) return Count_Type is - begin - return Node.Right; - end Right_Son; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color - (Node : in out Node_Type; - Color : Red_Black_Trees.Color_Type) - is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Symmetric_Difference (Target, Source); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Length (Right) = 0 then - return Left.Copy; - end if; - - if Length (Left) = 0 then - return Right.Copy; - end if; - - return S : Set (Length (Left) + Length (Right)) do - Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right)); - end return; - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Node : Count_Type; - Inserted : Boolean; - begin - return S : Set (Capacity => 1) do - Insert_Sans_Hint (S, New_Item, Node, Inserted); - pragma Assert (Inserted); - end return; - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - begin - Set_Ops.Set_Union (Target, Source); - end Union; - - function Union (Left, Right : Set) return Set is - begin - if Left'Address = Right'Address then - return Left.Copy; - end if; - - if Length (Left) = 0 then - return Right.Copy; - end if; - - if Length (Right) = 0 then - return Left.Copy; - end if; - - return S : Set (Length (Left) + Length (Right)) do - Assign (S, Source => Left); - Union (S, Right); - end return; - end Union; - -end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cforse.ads b/gcc/ada/a-cforse.ads deleted file mode 100644 index 6c1323d..0000000 --- a/gcc/ada/a-cforse.ads +++ /dev/null @@ -1,1784 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- This spec is derived from package Ada.Containers.Bounded_Ordered_Sets in --- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by --- making it easier to express properties, and by making the specification of --- this unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - --- The modifications are: - --- A parameter for the container is added to every function reading the --- content of a container: Key, Element, Next, Query_Element, Previous, --- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the --- need to have cursors which are valid on different containers (typically --- a container C and its previous version C'Old) for expressing properties, --- which is not possible if cursors encapsulate an access to the underlying --- container. The operators "<" and ">" that could not be modified that way --- have been removed. - -with Ada.Containers.Functional_Maps; -with Ada.Containers.Functional_Sets; -with Ada.Containers.Functional_Vectors; -private with Ada.Containers.Red_Black_Trees; - -generic - type Element_Type is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Formal_Ordered_Sets with - SPARK_Mode -is - pragma Annotate (CodePeer, Skip_Analysis); - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean - with - Global => null, - Post => - Equivalent_Elements'Result = - (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Elements); - - type Set (Capacity : Count_Type) is private with - Iterable => (First => First, - Next => Next, - Has_Element => Has_Element, - Element => Element), - Default_Initial_Condition => Is_Empty (Set); - pragma Preelaborable_Initialization (Set); - - type Cursor is record - Node : Count_Type; - end record; - - No_Element : constant Cursor := (Node => 0); - - function Length (Container : Set) return Count_Type with - Global => null, - Post => Length'Result <= Container.Capacity; - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package M is new Ada.Containers.Functional_Sets - (Element_Type => Element_Type, - Equivalent_Elements => Equivalent_Elements); - - function "=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."="; - - function "<=" - (Left : M.Set; - Right : M.Set) return Boolean renames M."<="; - - package E is new Ada.Containers.Functional_Vectors - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - function "=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."="; - - function "<" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<"; - - function "<=" - (Left : E.Sequence; - Right : E.Sequence) return Boolean renames E."<="; - - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => E.Get (Container, I) < Item); - pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Item : Element_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => Item < E.Get (Container, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); - - function E_Is_Find - (Container : E.Sequence; - Item : Element_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= E.Length (Container), - Post => - E_Is_Find'Result = - - ((if Position > 0 then - E_Bigger_Than_Range (Container, 1, Position - 1, Item)) - - and (if Position < E.Length (Container) then - E_Smaller_Than_Range - (Container, - Position + 1, - E.Length (Container), - Item))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); - - function Find - (Container : E.Sequence; - Item : Element_Type) return Count_Type - -- Search for Item in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Elements (Item, E.Get (Container, Find'Result))); - - function E_Elements_Included - (Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Left are contained in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I)); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Left : E.Sequence; - Model : M.Set; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Right - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Left) => - (if M.Contains (Model, E.Get (Left, I)) then - Find (Right, E.Get (Left, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Left, I))) = - E.Get (Left, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - function E_Elements_Included - (Container : E.Sequence; - Model : M.Set; - Left : E.Sequence; - Right : E.Sequence) return Boolean - -- The elements of Container contained in Model are in Left and others - -- are in Right. - - with - Global => null, - Post => - E_Elements_Included'Result = - (for all I in 1 .. E.Length (Container) => - (if M.Contains (Model, E.Get (Container, I)) then - Find (Left, E.Get (Container, I)) > 0 - and then E.Get (Left, Find (Left, E.Get (Container, I))) = - E.Get (Container, I) - else - Find (Right, E.Get (Container, I)) > 0 - and then E.Get (Right, Find (Right, E.Get (Container, I))) = - E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); - - package P is new Ada.Containers.Functional_Maps - (Key_Type => Cursor, - Element_Type => Positive_Count_Type, - Equivalent_Keys => "=", - Enable_Handling_Of_Equivalence => False); - - function "=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."="; - - function "<=" - (Left : P.Map; - Right : P.Map) return Boolean renames P."<="; - - function P_Positions_Shifted - (Small : P.Map; - Big : P.Map; - Cut : Positive_Count_Type; - Count : Count_Type := 1) return Boolean - with - Global => null, - Post => - P_Positions_Shifted'Result = - - -- Big contains all cursors of Small - - (P.Keys_Included (Small, Big) - - -- Cursors located before Cut are not moved, cursors located - -- after are shifted by Count. - - and (for all I of Small => - (if P.Get (Small, I) < Cut then - P.Get (Big, I) = P.Get (Small, I) - else - P.Get (Big, I) - Count = P.Get (Small, I))) - - -- New cursors of Big (if any) are between Cut and Cut - 1 + - -- Count. - - and (for all I of Big => - P.Has_Key (Small, I) - or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); - - function Mapping_Preserved - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Right contains all the elements of Left - - and E_Elements_Included (E_Left, E_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same. - - and (for all C of P_Left => - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C)))); - - function Mapping_Preserved_Except - (E_Left : E.Sequence; - E_Right : E.Sequence; - P_Left : P.Map; - P_Right : P.Map; - Position : Cursor) return Boolean - with - Ghost, - Global => null, - Post => - (if Mapping_Preserved_Except'Result then - - -- Right contains all the cursors of Left - - P.Keys_Included (P_Left, P_Right) - - -- Mappings from cursors to elements induced by E_Left, P_Left - -- and E_Right, P_Right are the same except for Position. - - and (for all C of P_Left => - (if C /= Position then - E.Get (E_Left, P.Get (P_Left, C)) = - E.Get (E_Right, P.Get (P_Right, C))))); - - function Model (Container : Set) return M.Set with - -- The high-level model of a set is a set of elements. Neither cursors - -- nor order of elements are represented in this model. Elements are - -- modeled up to equivalence. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - - function Elements (Container : Set) return E.Sequence with - -- The Elements sequence represents the underlying list structure of - -- sets that is used for iteration. It stores the actual values of - -- elements in the set. It does not model cursors. - - Ghost, - Global => null, - Post => - E.Length (Elements'Result) = Length (Container) - - -- It only contains keys contained in Model - - and (for all Item of Elements'Result => - M.Contains (Model (Container), Item)) - - -- It contains all the elements contained in Model - - and (for all Item of Model (Container) => - (Find (Elements'Result, Item) > 0 - and then Equivalent_Elements - (E.Get (Elements'Result, Find (Elements'Result, Item)), - Item))) - - -- It is sorted in increasing order - - and (for all I in 1 .. Length (Container) => - Find (Elements'Result, E.Get (Elements'Result, I)) = I - and - E_Is_Find - (Elements'Result, E.Get (Elements'Result, I), I)); - pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); - - function Positions (Container : Set) return P.Map with - -- The Positions map is used to model cursors. It only contains valid - -- cursors and maps them to their position in the container. - - Ghost, - Global => null, - Post => - not P.Has_Key (Positions'Result, No_Element) - - -- Positions of cursors are smaller than the container's length - - and then - (for all I of Positions'Result => - P.Get (Positions'Result, I) in 1 .. Length (Container) - - -- No two cursors have the same position. Note that we do not - -- state that there is a cursor in the map for each position, as - -- it is rarely needed. - - and then - (for all J of Positions'Result => - (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) - then I = J))); - - procedure Lift_Abstraction_Level (Container : Set) with - -- Lift_Abstraction_Level is a ghost procedure that does nothing but - -- assume that we can access the same elements by iterating over - -- positions or cursors. - -- This information is not generally useful except when switching from - -- a low-level, cursor-aware view of a container, to a high-level, - -- position-based view. - - Ghost, - Global => null, - Post => - (for all Item of Elements (Container) => - (for some I of Positions (Container) => - E.Get (Elements (Container), P.Get (Positions (Container), I)) = - Item)); - - function Contains - (C : M.Set; - K : Element_Type) return Boolean renames M.Contains; - -- To improve readability of contracts, we rename the function used to - -- search for an element in the model to Contains. - - end Formal_Model; - use Formal_Model; - - Empty_Set : constant Set; - - function "=" (Left, Right : Set) return Boolean with - Global => null, - Post => - - -- If two sets are equal, they contain the same elements in the same - -- order. - - (if "="'Result then Elements (Left) = Elements (Right) - - -- If they are different, then they do not contain the same elements - - else - not E_Elements_Included (Elements (Left), Elements (Right)) - or not E_Elements_Included (Elements (Right), Elements (Left))); - - function Equivalent_Sets (Left, Right : Set) return Boolean with - Global => null, - Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); - - function To_Set (New_Item : Element_Type) return Set with - Global => null, - Post => - M.Is_Singleton (Model (To_Set'Result), New_Item) - and Length (To_Set'Result) = 1 - and E.Get (Elements (To_Set'Result), 1) = New_Item; - - function Is_Empty (Container : Set) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Set) with - Global => null, - Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); - - procedure Assign (Target : in out Set; Source : Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source) - and Elements (Target) = Elements (Source) - and Length (Target) = Length (Source); - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set with - Global => null, - Pre => Capacity = 0 or else Capacity >= Source.Capacity, - Post => - Model (Copy'Result) = Model (Source) - and Elements (Copy'Result) = Elements (Source) - and Positions (Copy'Result) = Positions (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Source.Capacity - else - Copy'Result.Capacity = Capacity); - - function Element - (Container : Set; - Position : Cursor) return Element_Type - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Element'Result = - E.Get (Elements (Container), P.Get (Positions (Container), Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Length (Container) = Length (Container)'Old - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Position) - and Positions (Container) = Positions (Container)'Old; - - procedure Move (Target : in out Set; Source : in out Set) with - Global => null, - Pre => Target.Capacity >= Length (Source), - Post => - Model (Target) = Model (Source)'Old - and Elements (Target) = Elements (Source)'Old - and Length (Source)'Old = Length (Target) - and Length (Source) = 0; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => - Contains (Container, New_Item) - and Has_Element (Container, Position) - and Equivalent_Elements (Element (Container, Position), New_Item) - and E_Is_Find - (Elements (Container), - New_Item, - P.Get (Positions (Container), Position)), - Contract_Cases => - - -- If New_Item is already in Container, it is not modified and Inserted - -- is set to False. - - (Contains (Container, New_Item) => - not Inserted - and Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, New_Item is inserted in Container and Inserted is set to - -- True - - others => - Inserted - and Length (Container) = Length (Container)'Old + 1 - - -- Position now maps to New_Item - - and Element (Container, Position) = New_Item - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- The elements of Container located before Position are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => P.Get (Positions (Container), Position) - 1) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => P.Get (Positions (Container), Position), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted at position Position in - -- Container. - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => P.Get (Positions (Container), Position))); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - and then (not Contains (Container, New_Item)), - Post => - Length (Container) = Length (Container)'Old + 1 - and Contains (Container, New_Item) - - -- New_Item is inserted in the set - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - -- Other mappings are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- The elements of Container located before New_Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), New_Item) - 1) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => Find (Elements (Container), New_Item), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Elements (Container), New_Item)); - - procedure Include - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Container.Capacity - or Contains (Container, New_Item), - Post => Contains (Container, New_Item), - Contract_Cases => - - -- If New_Item is already in Container - - (Contains (Container, New_Item) => - - -- Elements are preserved - - Model (Container)'Old = Model (Container) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - Find (Elements (Container), New_Item)), - - -- Otherwise, New_Item is inserted in Container - - others => - Length (Container) = Length (Container)'Old + 1 - - -- Other elements are preserved - - and Model (Container)'Old <= Model (Container) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- New_Item is inserted in Container - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - - -- The Elements of Container located before New_Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), New_Item) - 1) - - -- Other Elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => Find (Elements (Container), New_Item), - Lst => Length (Container)'Old, - Offset => 1) - - -- A new cursor has been inserted in Container - - and P_Positions_Shifted - (Positions (Container)'Old, - Positions (Container), - Cut => Find (Elements (Container), New_Item))); - - procedure Replace - (Container : in out Set; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, New_Item), - Post => - - -- Elements are preserved - - Model (Container)'Old = Model (Container) - - -- Cursors are preserved - - and Positions (Container) = Positions (Container)'Old - - -- The element equivalent to New_Item in Container is replaced by - -- New_Item. - - and E.Get (Elements (Container), - Find (Elements (Container), New_Item)) = New_Item - and E.Equal_Except - (Elements (Container)'Old, - Elements (Container), - Find (Elements (Container), New_Item)); - - procedure Exclude - (Container : in out Set; - Item : Element_Type) - with - Global => null, - Post => not Contains (Container, Item), - Contract_Cases => - - -- If Item is not in Container, nothing is changed - - (not Contains (Container, Item) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Item is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- The elements of Container located before Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Item)'Old - 1) - - -- The elements located after Item are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Item)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Item)'Old)); - - procedure Delete - (Container : in out Set; - Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Item is no longer in Container - - and not Contains (Container, Item) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Item) - - -- The elements of Container located before Item are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Item)'Old - 1) - - -- The elements located after Item are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Item)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Item)'Old); - - procedure Delete - (Container : in out Set; - Position : in out Cursor) - with - Global => null, - Pre => Has_Element (Container, Position), - Post => - Position = No_Element - and Length (Container) = Length (Container)'Old - 1 - - -- The element at position Position is no longer in Container - - and not Contains (Container, Element (Container, Position)'Old) - and not P.Has_Key (Positions (Container), Position'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Element (Container, Position)'Old) - - -- The elements of Container located before Position are preserved. - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) - - -- The elements located after Position are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => P.Get (Positions (Container)'Old, Position'Old), - Lst => Length (Container), - Offset => 1) - - -- Position has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => P.Get (Positions (Container)'Old, Position'Old)); - - procedure Delete_First (Container : in out Set) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The first element has been removed from Container - - and not Contains (Container, First_Element (Container)'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - First_Element (Container)'Old) - - -- Other elements are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => 1, - Lst => Length (Container), - Offset => 1) - - -- First has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => 1)); - - procedure Delete_Last (Container : in out Set) with - Global => null, - Contract_Cases => - (Length (Container) = 0 => Length (Container) = 0, - others => - Length (Container) = Length (Container)'Old - 1 - - -- The last element has been removed from Container - - and not Contains (Container, Last_Element (Container)'Old) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M.Included_Except - (Model (Container)'Old, - Model (Container), - Last_Element (Container)'Old) - - -- Others elements of Container are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Length (Container)) - - -- Last cursor has been removed from Container - - and Positions (Container) <= Positions (Container)'Old); - - procedure Union (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target), - Post => - Length (Target) = Length (Target)'Old - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - + Length (Source) - - -- Elements already in Target are still in Target - - and Model (Target)'Old <= Model (Target) - - -- Elements of Source are included in Target - - and Model (Source) <= Model (Target) - - -- Elements of Target come from either Source or Target - - and - M.Included_In_Union - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) - and - E_Elements_Included - (Elements (Source), - Model (Target)'Old, - Elements (Source), - Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target)'Old, - E_Right => Elements (Target), - P_Left => Positions (Target)'Old, - P_Right => Positions (Target)); - - function Union (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Length (Union'Result) = Length (Left) - - M.Num_Overlaps (Model (Left), Model (Right)) - + Length (Right) - - -- Elements of Left and Right are in the result of Union - - and Model (Left) <= Model (Union'Result) - and Model (Right) <= Model (Union'Result) - - -- Elements of the result of union come from either Left or Right - - and - M.Included_In_Union - (Model (Union'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Union'Result), - Model (Left), - Elements (Left), - Elements (Right)) - and - E_Elements_Included - (Elements (Left), Model (Left), Elements (Union'Result)) - and - E_Elements_Included - (Elements (Right), - Model (Left), - Elements (Right), - Elements (Union'Result)); - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set) with - Global => null, - Post => - Length (Target) = - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are in Source - - and Model (Target) <= Model (Source) - - -- Elements both in Source and Target are in the intersection - - and - M.Includes_Intersection - (Model (Target), Model (Source), Model (Target)'Old) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and - E_Elements_Included - (Elements (Target)'Old, Model (Source), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Intersection (Left, Right : Set) return Set with - Global => null, - Post => - Length (Intersection'Result) = - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements in the result of Intersection are in Left and Right - - and Model (Intersection'Result) <= Model (Left) - and Model (Intersection'Result) <= Model (Right) - - -- Elements both in Left and Right are in the result of Intersection - - and - M.Includes_Intersection - (Model (Intersection'Result), Model (Left), Model (Right)) - - -- Actual value of elements come from Left - - and - E_Elements_Included - (Elements (Intersection'Result), Elements (Left)) - and - E_Elements_Included - (Elements (Left), Model (Right), Elements (Intersection'Result)); - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set) with - Global => null, - Post => - Length (Target) = Length (Target)'Old - - M.Num_Overlaps (Model (Target)'Old, Model (Source)) - - -- Elements of Target were already in Target - - and Model (Target) <= Model (Target)'Old - - -- Elements of Target are not in Source - - and M.No_Overlap (Model (Target), Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and - M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Actual value of elements of Target is preserved - - and E_Elements_Included (Elements (Target), Elements (Target)'Old) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - - -- Mapping from cursors of Target to elements is preserved - - and Mapping_Preserved - (E_Left => Elements (Target), - E_Right => Elements (Target)'Old, - P_Left => Positions (Target), - P_Right => Positions (Target)'Old); - - function Difference (Left, Right : Set) return Set with - Global => null, - Post => - Length (Difference'Result) = Length (Left) - - M.Num_Overlaps (Model (Left), Model (Right)) - - -- Elements of the result of Difference are in Left - - and Model (Difference'Result) <= Model (Left) - - -- Elements of the result of Difference are in Right - - and M.No_Overlap (Model (Difference'Result), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and - M.Included_In_Union - (Model (Left), Model (Difference'Result), Model (Right)) - - -- Actual value of elements come from Left - - and - E_Elements_Included (Elements (Difference'Result), Elements (Left)) - and - E_Elements_Included - (Elements (Left), - Model (Difference'Result), - Elements (Difference'Result)); - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set) with - Global => null, - Pre => - Length (Source) - Length (Target and Source) <= - Target.Capacity - Length (Target) + Length (Target and Source), - Post => - Length (Target) = Length (Target)'Old - - 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + - Length (Source) - - -- Elements of the difference were not both in Source and in Target - - and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) - - -- Elements in Target but not in Source are in the difference - - and - M.Included_In_Union - (Model (Target)'Old, Model (Target), Model (Source)) - - -- Elements in Source but not in Target are in the difference - - and - M.Included_In_Union - (Model (Source), Model (Target), Model (Target)'Old) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Target), - Model (Target)'Old, - Elements (Target)'Old, - Elements (Source)) - and - E_Elements_Included - (Elements (Target)'Old, Model (Target), Elements (Target)) - and - E_Elements_Included - (Elements (Source), Model (Target), Elements (Target)); - - function Symmetric_Difference (Left, Right : Set) return Set with - Global => null, - Pre => Length (Left) <= Count_Type'Last - Length (Right), - Post => - Length (Symmetric_Difference'Result) = Length (Left) - - 2 * M.Num_Overlaps (Model (Left), Model (Right)) + - Length (Right) - - -- Elements of the difference were not both in Left and Right - - and - M.Not_In_Both - (Model (Symmetric_Difference'Result), Model (Left), Model (Right)) - - -- Elements in Left but not in Right are in the difference - - and - M.Included_In_Union - (Model (Left), Model (Symmetric_Difference'Result), Model (Right)) - - -- Elements in Right but not in Left are in the difference - - and - M.Included_In_Union - (Model (Right), Model (Symmetric_Difference'Result), Model (Left)) - - -- Actual value of elements come from either Left or Right - - and - E_Elements_Included - (Elements (Symmetric_Difference'Result), - Model (Left), - Elements (Left), - Elements (Right)) - and - E_Elements_Included - (Elements (Left), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)) - and - E_Elements_Included - (Elements (Right), - Model (Symmetric_Difference'Result), - Elements (Symmetric_Difference'Result)); - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean with - Global => null, - Post => - Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with - Global => null, - Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); - - function First (Container : Set) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - First'Result = No_Element, - - others => - Has_Element (Container, First'Result) - and P.Get (Positions (Container), First'Result) = 1); - - function First_Element (Container : Set) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = E.Get (Elements (Container), 1) - and E_Smaller_Than_Range - (Elements (Container), - 2, - Length (Container), - First_Element'Result); - - function Last (Container : Set) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 => - Last'Result = No_Element, - - others => - Has_Element (Container, Last'Result) - and P.Get (Positions (Container), Last'Result) = - Length (Container)); - - function Last_Element (Container : Set) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = E.Get (Elements (Container), Length (Container)) - and E_Bigger_Than_Range - (Elements (Container), - 1, - Length (Container) - 1, - Last_Element'Result); - - function Next (Container : Set; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Next'Result = No_Element, - - others => - Has_Element (Container, Next'Result) - and then P.Get (Positions (Container), Next'Result) = - P.Get (Positions (Container), Position) + 1); - - procedure Next (Container : Set; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = Length (Container) - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) + 1); - - function Previous (Container : Set; Position : Cursor) return Cursor with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Previous'Result = No_Element, - - others => - Has_Element (Container, Previous'Result) - and then P.Get (Positions (Container), Previous'Result) = - P.Get (Positions (Container), Position) - 1); - - procedure Previous (Container : Set; Position : in out Cursor) with - Global => null, - Pre => - Has_Element (Container, Position) or else Position = No_Element, - Contract_Cases => - (Position = No_Element - or else P.Get (Positions (Container), Position) = 1 - => - Position = No_Element, - - others => - Has_Element (Container, Position) - and then P.Get (Positions (Container), Position) = - P.Get (Positions (Container), Position'Old) - 1); - - function Find (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container, Find returns No_Element - - (not Contains (Model (Container), Item) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Item) - - -- The element designated by the result of Find is Item - - and Equivalent_Elements - (Element (Container, Find'Result), Item)); - - function Floor (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Item < First_Element (Container) => - Floor'Result = No_Element, - others => - Has_Element (Container, Floor'Result) - and - not (Item < E.Get (Elements (Container), - P.Get (Positions (Container), Floor'Result))) - and E_Is_Find - (Elements (Container), - Item, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Set; Item : Element_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 or else Last_Element (Container) < Item => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and - not (E.Get (Elements (Container), - P.Get (Positions (Container), Ceiling'Result)) < - Item) - and E_Is_Find - (Elements (Container), - Item, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Set; Item : Element_Type) return Boolean with - Global => null, - Post => Contains'Result = Contains (Model (Container), Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Has_Element (Container : Set; Position : Cursor) return Boolean - with - Global => null, - Post => - Has_Element'Result = P.Has_Key (Positions (Container), Position); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys with SPARK_Mode is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean with - Global => null, - Post => - Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); - - package Formal_Model with Ghost is - function E_Bigger_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Bigger_Than_Range'Result = - (for all I in Fst .. Lst => - Generic_Keys.Key (E.Get (Container, I)) < Key); - pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); - - function E_Smaller_Than_Range - (Container : E.Sequence; - Fst : Positive_Count_Type; - Lst : Count_Type; - Key : Key_Type) return Boolean - with - Global => null, - Pre => Lst <= E.Length (Container), - Post => - E_Smaller_Than_Range'Result = - (for all I in Fst .. Lst => - Key < Generic_Keys.Key (E.Get (Container, I))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); - - function E_Is_Find - (Container : E.Sequence; - Key : Key_Type; - Position : Count_Type) return Boolean - with - Global => null, - Pre => Position - 1 <= E.Length (Container), - Post => - E_Is_Find'Result = - - ((if Position > 0 then - E_Bigger_Than_Range (Container, 1, Position - 1, Key)) - - and (if Position < E.Length (Container) then - E_Smaller_Than_Range - (Container, - Position + 1, - E.Length (Container), - Key))); - pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); - - function Find - (Container : E.Sequence; - Key : Key_Type) return Count_Type - -- Search for Key in Container - - with - Global => null, - Post => - (if Find'Result > 0 then - Find'Result <= E.Length (Container) - and Equivalent_Keys - (Key, Generic_Keys.Key (E.Get (Container, Find'Result))) - and E_Is_Find (Container, Key, Find'Result)); - - function M_Included_Except - (Left : M.Set; - Right : M.Set; - Key : Key_Type) return Boolean - with - Global => null, - Post => - M_Included_Except'Result = - (for all E of Left => - Contains (Right, E) - or Equivalent_Keys (Generic_Keys.Key (E), Key)); - end Formal_Model; - use Formal_Model; - - function Key (Container : Set; Position : Cursor) return Key_Type with - Global => null, - Post => Key'Result = Key (Element (Container, Position)); - pragma Annotate (GNATprove, Inline_For_Proof, Key); - - function Element (Container : Set; Key : Key_Type) return Element_Type - with - Global => null, - Pre => Contains (Container, Key), - Post => - Element'Result = Element (Container, Find (Container, Key)); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - - -- Key now maps to New_Item - - and Element (Container, Key) = New_Item - - -- New_Item is contained in Container - - and Contains (Model (Container), New_Item) - - -- Other elements are preserved - - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - and M.Included_Except - (Model (Container), - Model (Container)'Old, - New_Item) - - -- Mapping from cursors to elements is preserved - - and Mapping_Preserved_Except - (E_Left => Elements (Container)'Old, - E_Right => Elements (Container), - P_Left => Positions (Container)'Old, - P_Right => Positions (Container), - Position => Find (Container, Key)) - and Positions (Container) = Positions (Container)'Old; - - procedure Exclude (Container : in out Set; Key : Key_Type) with - Global => null, - Post => not Contains (Container, Key), - Contract_Cases => - - -- If Key is not in Container, nothing is changed - - (not Contains (Container, Key) => - Model (Container) = Model (Container)'Old - and Elements (Container) = Elements (Container)'Old - and Positions (Container) = Positions (Container)'Old, - - -- Otherwise, Key is removed from Container - - others => - Length (Container) = Length (Container)'Old - 1 - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The elements of Container located before Key are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Key)'Old - 1) - - -- The elements located after Key are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Key)'Old)); - - procedure Delete (Container : in out Set; Key : Key_Type) with - Global => null, - Pre => Contains (Container, Key), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Key is no longer in Container - - and not Contains (Container, Key) - - -- Other elements are preserved - - and Model (Container) <= Model (Container)'Old - and M_Included_Except - (Model (Container)'Old, - Model (Container), - Key) - - -- The elements of Container located before Key are preserved - - and E.Range_Equal - (Left => Elements (Container)'Old, - Right => Elements (Container), - Fst => 1, - Lst => Find (Elements (Container), Key)'Old - 1) - - -- The elements located after Key are shifted by 1 - - and E.Range_Shifted - (Left => Elements (Container), - Right => Elements (Container)'Old, - Fst => Find (Elements (Container), Key)'Old, - Lst => Length (Container), - Offset => 1) - - -- A cursor has been removed from Container - - and P_Positions_Shifted - (Positions (Container), - Positions (Container)'Old, - Cut => Find (Elements (Container), Key)'Old); - - function Find (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - - -- If Key is not contained in Container, Find returns No_Element - - ((for all E of Model (Container) => - not Equivalent_Keys (Key, Generic_Keys.Key (E))) => - not P.Has_Key (Positions (Container), Find'Result) - and Find'Result = No_Element, - - -- Otherwise, Find returns a valid cursor in Container - - others => - P.Has_Key (Positions (Container), Find'Result) - and P.Get (Positions (Container), Find'Result) = - Find (Elements (Container), Key) - - -- The element designated by the result of Find is Key - - and Equivalent_Keys - (Generic_Keys.Key (Element (Container, Find'Result)), Key)); - - function Floor (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 - or else Key < Generic_Keys.Key (First_Element (Container)) => - Floor'Result = No_Element, - others => - Has_Element (Container, Floor'Result) - and - not (Key < - Generic_Keys.Key - (E.Get (Elements (Container), - P.Get (Positions (Container), Floor'Result)))) - and E_Is_Find - (Elements (Container), - Key, - P.Get (Positions (Container), Floor'Result))); - - function Ceiling (Container : Set; Key : Key_Type) return Cursor with - Global => null, - Contract_Cases => - (Length (Container) = 0 - or else Generic_Keys.Key (Last_Element (Container)) < Key => - Ceiling'Result = No_Element, - others => - Has_Element (Container, Ceiling'Result) - and - not (Generic_Keys.Key - (E.Get (Elements (Container), - P.Get (Positions (Container), Ceiling'Result))) - < Key) - and E_Is_Find - (Elements (Container), - Key, - P.Get (Positions (Container), Ceiling'Result))); - - function Contains (Container : Set; Key : Key_Type) return Boolean with - Global => null, - Post => - Contains'Result = - (for some E of Model (Container) => - Equivalent_Keys (Key, Generic_Keys.Key (E))); - - end Generic_Keys; - -private - pragma SPARK_Mode (Off); - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type is record - Has_Element : Boolean := False; - Parent : Count_Type := 0; - Left : Count_Type := 0; - Right : Count_Type := 0; - Color : Red_Black_Trees.Color_Type; - Element : Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); - - type Set (Capacity : Count_Type) is - new Tree_Types.Tree_Type (Capacity) with null record; - - use Red_Black_Trees; - - Empty_Set : constant Set := (Capacity => 0, others => <>); - -end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/a-cgaaso.adb b/gcc/ada/a-cgaaso.adb deleted file mode 100644 index 12763f1..0000000 --- a/gcc/ada/a-cgaaso.adb +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- This unit was originally a GNAT-specific addition to Ada 2005. A unit --- providing the same feature, Ada.Containers.Generic_Sort, was defined for --- Ada 2012. We retain Generic_Anonymous_Array_Sort for compatibility, but --- implement it in terms of the official unit, Generic_Sort. - -with Ada.Containers.Generic_Sort; - -procedure Ada.Containers.Generic_Anonymous_Array_Sort - (First, Last : Index_Type'Base) -is - procedure Sort is new Ada.Containers.Generic_Sort - (Index_Type => Index_Type, - Before => Less, - Swap => Swap); - -begin - Sort (First, Last); -end Ada.Containers.Generic_Anonymous_Array_Sort; diff --git a/gcc/ada/a-cgaaso.ads b/gcc/ada/a-cgaaso.ads deleted file mode 100644 index f44c220..0000000 --- a/gcc/ada/a-cgaaso.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Allows an anonymous array (or array-like container) to be sorted. Generic --- formal Less returns the result of comparing the elements designated by the --- indexes, and generic formal Swap exchanges the designated elements. - -generic - type Index_Type is (<>); - with function Less (Left, Right : Index_Type) return Boolean is <>; - with procedure Swap (Left, Right : Index_Type) is <>; - -procedure Ada.Containers.Generic_Anonymous_Array_Sort - (First, Last : Index_Type'Base); -pragma Pure (Ada.Containers.Generic_Anonymous_Array_Sort); diff --git a/gcc/ada/a-cgarso.adb b/gcc/ada/a-cgarso.adb deleted file mode 100644 index 0947747..0000000 --- a/gcc/ada/a-cgarso.adb +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . G E N E R I C _ A R R A Y _ S O R T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Constrained_Array_Sort; - -procedure Ada.Containers.Generic_Array_Sort - (Container : in out Array_Type) -is - subtype Index_Subtype is - Index_Type range Container'First .. Container'Last; - - subtype Array_Subtype is - Array_Type (Index_Subtype); - - procedure Sort is - new Generic_Constrained_Array_Sort - (Index_Type => Index_Subtype, - Element_Type => Element_Type, - Array_Type => Array_Subtype, - "<" => "<"); - -begin - Sort (Container); -end Ada.Containers.Generic_Array_Sort; diff --git a/gcc/ada/a-cgarso.ads b/gcc/ada/a-cgarso.ads deleted file mode 100644 index 77281b5..0000000 --- a/gcc/ada/a-cgarso.ads +++ /dev/null @@ -1,26 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . G E N E R I C _ A R R A Y _ S O R T -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -generic - type Index_Type is (<>); - type Element_Type is private; - type Array_Type is array (Index_Type range <>) of Element_Type; - - with function "<" (Left, Right : Element_Type) - return Boolean is <>; - -procedure Ada.Containers.Generic_Array_Sort (Container : in out Array_Type); - -pragma Pure (Ada.Containers.Generic_Array_Sort); diff --git a/gcc/ada/a-cgcaso.adb b/gcc/ada/a-cgcaso.adb deleted file mode 100644 index 6461377..0000000 --- a/gcc/ada/a-cgcaso.adb +++ /dev/null @@ -1,121 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb]) - -with System; - -procedure Ada.Containers.Generic_Constrained_Array_Sort - (Container : in out Array_Type) -is - type T is range System.Min_Int .. System.Max_Int; - - function To_Index (J : T) return Index_Type; - pragma Inline (To_Index); - - procedure Sift (S : T); - - A : Array_Type renames Container; - - -------------- - -- To_Index -- - -------------- - - function To_Index (J : T) return Index_Type is - K : constant T'Base := Index_Type'Pos (A'First) + J - T'(1); - begin - return Index_Type'Val (K); - end To_Index; - - Max : T := A'Length; - Temp : Element_Type; - - ---------- - -- Sift -- - ---------- - - procedure Sift (S : T) is - C : T := S; - Son : T; - - begin - loop - Son := 2 * C; - - exit when Son > Max; - - declare - Son_Index : Index_Type := To_Index (Son); - - begin - if Son < Max then - if A (Son_Index) < A (Index_Type'Succ (Son_Index)) then - Son := Son + 1; - Son_Index := Index_Type'Succ (Son_Index); - end if; - end if; - - A (To_Index (C)) := A (Son_Index); -- Move (Son, C); - end; - - C := Son; - end loop; - - while C /= S loop - declare - Father : constant T := C / 2; - begin - if A (To_Index (Father)) < Temp then -- Lt (Father, 0) - A (To_Index (C)) := A (To_Index (Father)); -- Move (Father, C) - C := Father; - else - exit; - end if; - end; - end loop; - - A (To_Index (C)) := Temp; -- Move (0, C); - end Sift; - --- Start of processing for Generic_Constrained_Array_Sort - -begin - for J in reverse 1 .. Max / 2 loop - Temp := Container (To_Index (J)); -- Move (J, 0); - Sift (J); - end loop; - - while Max > 1 loop - Temp := A (To_Index (Max)); -- Move (Max, 0); - A (To_Index (Max)) := A (A'First); -- Move (1, Max); - - Max := Max - 1; - Sift (1); - end loop; -end Ada.Containers.Generic_Constrained_Array_Sort; diff --git a/gcc/ada/a-cgcaso.ads b/gcc/ada/a-cgcaso.ads deleted file mode 100644 index 39ebee6..0000000 --- a/gcc/ada/a-cgcaso.ads +++ /dev/null @@ -1,27 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -generic - type Index_Type is (<>); - type Element_Type is private; - type Array_Type is array (Index_Type) of Element_Type; - - with function "<" (Left, Right : Element_Type) - return Boolean is <>; - -procedure Ada.Containers.Generic_Constrained_Array_Sort - (Container : in out Array_Type); - -pragma Pure (Ada.Containers.Generic_Constrained_Array_Sort); diff --git a/gcc/ada/a-chacon.adb b/gcc/ada/a-chacon.adb deleted file mode 100644 index 36029fd..0000000 --- a/gcc/ada/a-chacon.adb +++ /dev/null @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . C O N V E R S I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Characters.Conversions is - - ------------------ - -- Is_Character -- - ------------------ - - function Is_Character (Item : Wide_Character) return Boolean is - begin - return Wide_Character'Pos (Item) < 256; - end Is_Character; - - function Is_Character (Item : Wide_Wide_Character) return Boolean is - begin - return Wide_Wide_Character'Pos (Item) < 256; - end Is_Character; - - --------------- - -- Is_String -- - --------------- - - function Is_String (Item : Wide_String) return Boolean is - begin - for J in Item'Range loop - if Wide_Character'Pos (Item (J)) >= 256 then - return False; - end if; - end loop; - - return True; - end Is_String; - - function Is_String (Item : Wide_Wide_String) return Boolean is - begin - for J in Item'Range loop - if Wide_Wide_Character'Pos (Item (J)) >= 256 then - return False; - end if; - end loop; - - return True; - end Is_String; - - ----------------------- - -- Is_Wide_Character -- - ----------------------- - - function Is_Wide_Character (Item : Wide_Wide_Character) return Boolean is - begin - return Wide_Wide_Character'Pos (Item) < 2**16; - end Is_Wide_Character; - - -------------------- - -- Is_Wide_String -- - -------------------- - - function Is_Wide_String (Item : Wide_Wide_String) return Boolean is - begin - for J in Item'Range loop - if Wide_Wide_Character'Pos (Item (J)) >= 2**16 then - return False; - end if; - end loop; - - return True; - end Is_Wide_String; - - ------------------ - -- To_Character -- - ------------------ - - function To_Character - (Item : Wide_Character; - Substitute : Character := ' ') return Character - is - begin - if Is_Character (Item) then - return Character'Val (Wide_Character'Pos (Item)); - else - return Substitute; - end if; - end To_Character; - - function To_Character - (Item : Wide_Wide_Character; - Substitute : Character := ' ') return Character - is - begin - if Is_Character (Item) then - return Character'Val (Wide_Wide_Character'Pos (Item)); - else - return Substitute; - end if; - end To_Character; - - --------------- - -- To_String -- - --------------- - - function To_String - (Item : Wide_String; - Substitute : Character := ' ') return String - is - Result : String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); - end loop; - - return Result; - end To_String; - - function To_String - (Item : Wide_Wide_String; - Substitute : Character := ' ') return String - is - Result : String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); - end loop; - - return Result; - end To_String; - - ----------------------- - -- To_Wide_Character -- - ----------------------- - - function To_Wide_Character - (Item : Character) return Wide_Character - is - begin - return Wide_Character'Val (Character'Pos (Item)); - end To_Wide_Character; - - function To_Wide_Character - (Item : Wide_Wide_Character; - Substitute : Wide_Character := ' ') return Wide_Character - is - begin - if Wide_Wide_Character'Pos (Item) < 2**16 then - return Wide_Character'Val (Wide_Wide_Character'Pos (Item)); - else - return Substitute; - end if; - end To_Wide_Character; - - -------------------- - -- To_Wide_String -- - -------------------- - - function To_Wide_String - (Item : String) return Wide_String - is - Result : Wide_String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Wide_Character (Item (J)); - end loop; - - return Result; - end To_Wide_String; - - function To_Wide_String - (Item : Wide_Wide_String; - Substitute : Wide_Character := ' ') return Wide_String - is - Result : Wide_String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := - To_Wide_Character (Item (J), Substitute); - end loop; - - return Result; - end To_Wide_String; - - ---------------------------- - -- To_Wide_Wide_Character -- - ---------------------------- - - function To_Wide_Wide_Character - (Item : Character) return Wide_Wide_Character - is - begin - return Wide_Wide_Character'Val (Character'Pos (Item)); - end To_Wide_Wide_Character; - - function To_Wide_Wide_Character - (Item : Wide_Character) return Wide_Wide_Character - is - begin - return Wide_Wide_Character'Val (Wide_Character'Pos (Item)); - end To_Wide_Wide_Character; - - ------------------------- - -- To_Wide_Wide_String -- - ------------------------- - - function To_Wide_Wide_String - (Item : String) return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Wide_Wide_Character (Item (J)); - end loop; - - return Result; - end To_Wide_Wide_String; - - function To_Wide_Wide_String - (Item : Wide_String) return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Wide_Wide_Character (Item (J)); - end loop; - - return Result; - end To_Wide_Wide_String; - -end Ada.Characters.Conversions; diff --git a/gcc/ada/a-chacon.ads b/gcc/ada/a-chacon.ads deleted file mode 100644 index 77525a4..0000000 --- a/gcc/ada/a-chacon.ads +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . C O N V E R S I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2012, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Characters.Conversions is - pragma Pure; - - function Is_Character (Item : Wide_Character) return Boolean; - function Is_String (Item : Wide_String) return Boolean; - function Is_Character (Item : Wide_Wide_Character) return Boolean; - function Is_String (Item : Wide_Wide_String) return Boolean; - - function Is_Wide_Character (Item : Wide_Wide_Character) return Boolean; - function Is_Wide_String (Item : Wide_Wide_String) return Boolean; - - function To_Wide_Character (Item : Character) return Wide_Character; - function To_Wide_String (Item : String) return Wide_String; - - function To_Wide_Wide_Character - (Item : Character) return Wide_Wide_Character; - - function To_Wide_Wide_String - (Item : String) return Wide_Wide_String; - - function To_Wide_Wide_Character - (Item : Wide_Character) return Wide_Wide_Character; - - function To_Wide_Wide_String - (Item : Wide_String) return Wide_Wide_String; - - function To_Character - (Item : Wide_Character; - Substitute : Character := ' ') return Character; - - function To_String - (Item : Wide_String; - Substitute : Character := ' ') return String; - - function To_Character - (Item : Wide_Wide_Character; - Substitute : Character := ' ') return Character; - - function To_String - (Item : Wide_Wide_String; - Substitute : Character := ' ') return String; - - function To_Wide_Character - (Item : Wide_Wide_Character; - Substitute : Wide_Character := ' ') return Wide_Character; - - function To_Wide_String - (Item : Wide_Wide_String; - Substitute : Wide_Character := ' ') return Wide_String; - -end Ada.Characters.Conversions; diff --git a/gcc/ada/a-chahan.adb b/gcc/ada/a-chahan.adb deleted file mode 100644 index f95a7bb..0000000 --- a/gcc/ada/a-chahan.adb +++ /dev/null @@ -1,609 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; -with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; - -package body Ada.Characters.Handling is - - ------------------------------------ - -- Character Classification Table -- - ------------------------------------ - - type Character_Flags is mod 256; - for Character_Flags'Size use 8; - - Control : constant Character_Flags := 1; - Lower : constant Character_Flags := 2; - Upper : constant Character_Flags := 4; - Basic : constant Character_Flags := 8; - Hex_Digit : constant Character_Flags := 16; - Digit : constant Character_Flags := 32; - Special : constant Character_Flags := 64; - Line_Term : constant Character_Flags := 128; - - Letter : constant Character_Flags := Lower or Upper; - Alphanum : constant Character_Flags := Letter or Digit; - Graphic : constant Character_Flags := Alphanum or Special; - - Char_Map : constant array (Character) of Character_Flags := - ( - NUL => Control, - SOH => Control, - STX => Control, - ETX => Control, - EOT => Control, - ENQ => Control, - ACK => Control, - BEL => Control, - BS => Control, - HT => Control, - LF => Control + Line_Term, - VT => Control + Line_Term, - FF => Control + Line_Term, - CR => Control + Line_Term, - SO => Control, - SI => Control, - - DLE => Control, - DC1 => Control, - DC2 => Control, - DC3 => Control, - DC4 => Control, - NAK => Control, - SYN => Control, - ETB => Control, - CAN => Control, - EM => Control, - SUB => Control, - ESC => Control, - FS => Control, - GS => Control, - RS => Control, - US => Control, - - Space => Special, - Exclamation => Special, - Quotation => Special, - Number_Sign => Special, - Dollar_Sign => Special, - Percent_Sign => Special, - Ampersand => Special, - Apostrophe => Special, - Left_Parenthesis => Special, - Right_Parenthesis => Special, - Asterisk => Special, - Plus_Sign => Special, - Comma => Special, - Hyphen => Special, - Full_Stop => Special, - Solidus => Special, - - '0' .. '9' => Digit + Hex_Digit, - - Colon => Special, - Semicolon => Special, - Less_Than_Sign => Special, - Equals_Sign => Special, - Greater_Than_Sign => Special, - Question => Special, - Commercial_At => Special, - - 'A' .. 'F' => Upper + Basic + Hex_Digit, - 'G' .. 'Z' => Upper + Basic, - - Left_Square_Bracket => Special, - Reverse_Solidus => Special, - Right_Square_Bracket => Special, - Circumflex => Special, - Low_Line => Special, - Grave => Special, - - 'a' .. 'f' => Lower + Basic + Hex_Digit, - 'g' .. 'z' => Lower + Basic, - - Left_Curly_Bracket => Special, - Vertical_Line => Special, - Right_Curly_Bracket => Special, - Tilde => Special, - - DEL => Control, - Reserved_128 => Control, - Reserved_129 => Control, - BPH => Control, - NBH => Control, - Reserved_132 => Control, - NEL => Control + Line_Term, - SSA => Control, - ESA => Control, - HTS => Control, - HTJ => Control, - VTS => Control, - PLD => Control, - PLU => Control, - RI => Control, - SS2 => Control, - SS3 => Control, - - DCS => Control, - PU1 => Control, - PU2 => Control, - STS => Control, - CCH => Control, - MW => Control, - SPA => Control, - EPA => Control, - - SOS => Control, - Reserved_153 => Control, - SCI => Control, - CSI => Control, - ST => Control, - OSC => Control, - PM => Control, - APC => Control, - - No_Break_Space => Special, - Inverted_Exclamation => Special, - Cent_Sign => Special, - Pound_Sign => Special, - Currency_Sign => Special, - Yen_Sign => Special, - Broken_Bar => Special, - Section_Sign => Special, - Diaeresis => Special, - Copyright_Sign => Special, - Feminine_Ordinal_Indicator => Special, - Left_Angle_Quotation => Special, - Not_Sign => Special, - Soft_Hyphen => Special, - Registered_Trade_Mark_Sign => Special, - Macron => Special, - Degree_Sign => Special, - Plus_Minus_Sign => Special, - Superscript_Two => Special, - Superscript_Three => Special, - Acute => Special, - Micro_Sign => Special, - Pilcrow_Sign => Special, - Middle_Dot => Special, - Cedilla => Special, - Superscript_One => Special, - Masculine_Ordinal_Indicator => Special, - Right_Angle_Quotation => Special, - Fraction_One_Quarter => Special, - Fraction_One_Half => Special, - Fraction_Three_Quarters => Special, - Inverted_Question => Special, - - UC_A_Grave => Upper, - UC_A_Acute => Upper, - UC_A_Circumflex => Upper, - UC_A_Tilde => Upper, - UC_A_Diaeresis => Upper, - UC_A_Ring => Upper, - UC_AE_Diphthong => Upper + Basic, - UC_C_Cedilla => Upper, - UC_E_Grave => Upper, - UC_E_Acute => Upper, - UC_E_Circumflex => Upper, - UC_E_Diaeresis => Upper, - UC_I_Grave => Upper, - UC_I_Acute => Upper, - UC_I_Circumflex => Upper, - UC_I_Diaeresis => Upper, - UC_Icelandic_Eth => Upper + Basic, - UC_N_Tilde => Upper, - UC_O_Grave => Upper, - UC_O_Acute => Upper, - UC_O_Circumflex => Upper, - UC_O_Tilde => Upper, - UC_O_Diaeresis => Upper, - - Multiplication_Sign => Special, - - UC_O_Oblique_Stroke => Upper, - UC_U_Grave => Upper, - UC_U_Acute => Upper, - UC_U_Circumflex => Upper, - UC_U_Diaeresis => Upper, - UC_Y_Acute => Upper, - UC_Icelandic_Thorn => Upper + Basic, - - LC_German_Sharp_S => Lower + Basic, - LC_A_Grave => Lower, - LC_A_Acute => Lower, - LC_A_Circumflex => Lower, - LC_A_Tilde => Lower, - LC_A_Diaeresis => Lower, - LC_A_Ring => Lower, - LC_AE_Diphthong => Lower + Basic, - LC_C_Cedilla => Lower, - LC_E_Grave => Lower, - LC_E_Acute => Lower, - LC_E_Circumflex => Lower, - LC_E_Diaeresis => Lower, - LC_I_Grave => Lower, - LC_I_Acute => Lower, - LC_I_Circumflex => Lower, - LC_I_Diaeresis => Lower, - LC_Icelandic_Eth => Lower + Basic, - LC_N_Tilde => Lower, - LC_O_Grave => Lower, - LC_O_Acute => Lower, - LC_O_Circumflex => Lower, - LC_O_Tilde => Lower, - LC_O_Diaeresis => Lower, - - Division_Sign => Special, - - LC_O_Oblique_Stroke => Lower, - LC_U_Grave => Lower, - LC_U_Acute => Lower, - LC_U_Circumflex => Lower, - LC_U_Diaeresis => Lower, - LC_Y_Acute => Lower, - LC_Icelandic_Thorn => Lower + Basic, - LC_Y_Diaeresis => Lower - ); - - --------------------- - -- Is_Alphanumeric -- - --------------------- - - function Is_Alphanumeric (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Alphanum) /= 0; - end Is_Alphanumeric; - - -------------- - -- Is_Basic -- - -------------- - - function Is_Basic (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Basic) /= 0; - end Is_Basic; - - ------------------ - -- Is_Character -- - ------------------ - - function Is_Character (Item : Wide_Character) return Boolean is - begin - return Wide_Character'Pos (Item) < 256; - end Is_Character; - - ---------------- - -- Is_Control -- - ---------------- - - function Is_Control (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Control) /= 0; - end Is_Control; - - -------------- - -- Is_Digit -- - -------------- - - function Is_Digit (Item : Character) return Boolean is - begin - return Item in '0' .. '9'; - end Is_Digit; - - ---------------- - -- Is_Graphic -- - ---------------- - - function Is_Graphic (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Graphic) /= 0; - end Is_Graphic; - - -------------------------- - -- Is_Hexadecimal_Digit -- - -------------------------- - - function Is_Hexadecimal_Digit (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Hex_Digit) /= 0; - end Is_Hexadecimal_Digit; - - ---------------- - -- Is_ISO_646 -- - ---------------- - - function Is_ISO_646 (Item : Character) return Boolean is - begin - return Item in ISO_646; - end Is_ISO_646; - - -- Note: much more efficient coding of the following function is possible - -- by testing several 16#80# bits in a complete word in a single operation - - function Is_ISO_646 (Item : String) return Boolean is - begin - for J in Item'Range loop - if Item (J) not in ISO_646 then - return False; - end if; - end loop; - - return True; - end Is_ISO_646; - - --------------- - -- Is_Letter -- - --------------- - - function Is_Letter (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Letter) /= 0; - end Is_Letter; - - ------------------------ - -- Is_Line_Terminator -- - ------------------------ - - function Is_Line_Terminator (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Line_Term) /= 0; - end Is_Line_Terminator; - - -------------- - -- Is_Lower -- - -------------- - - function Is_Lower (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Lower) /= 0; - end Is_Lower; - - ------------- - -- Is_Mark -- - ------------- - - function Is_Mark (Item : Character) return Boolean is - pragma Unreferenced (Item); - begin - return False; - end Is_Mark; - - --------------------- - -- Is_Other_Format -- - --------------------- - - function Is_Other_Format (Item : Character) return Boolean is - begin - return Item = Soft_Hyphen; - end Is_Other_Format; - - ------------------------------ - -- Is_Punctuation_Connector -- - ------------------------------ - - function Is_Punctuation_Connector (Item : Character) return Boolean is - begin - return Item = '_'; - end Is_Punctuation_Connector; - - -------------- - -- Is_Space -- - -------------- - - function Is_Space (Item : Character) return Boolean is - begin - return Item = ' ' or else Item = No_Break_Space; - end Is_Space; - - ---------------- - -- Is_Special -- - ---------------- - - function Is_Special (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Special) /= 0; - end Is_Special; - - --------------- - -- Is_String -- - --------------- - - function Is_String (Item : Wide_String) return Boolean is - begin - for J in Item'Range loop - if Wide_Character'Pos (Item (J)) >= 256 then - return False; - end if; - end loop; - - return True; - end Is_String; - - -------------- - -- Is_Upper -- - -------------- - - function Is_Upper (Item : Character) return Boolean is - begin - return (Char_Map (Item) and Upper) /= 0; - end Is_Upper; - - -------------- - -- To_Basic -- - -------------- - - function To_Basic (Item : Character) return Character is - begin - return Value (Basic_Map, Item); - end To_Basic; - - function To_Basic (Item : String) return String is - begin - return Result : String (1 .. Item'Length) do - for J in Item'Range loop - Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); - end loop; - end return; - end To_Basic; - - ------------------ - -- To_Character -- - ------------------ - - function To_Character - (Item : Wide_Character; - Substitute : Character := ' ') return Character - is - begin - if Is_Character (Item) then - return Character'Val (Wide_Character'Pos (Item)); - else - return Substitute; - end if; - end To_Character; - - ---------------- - -- To_ISO_646 -- - ---------------- - - function To_ISO_646 - (Item : Character; - Substitute : ISO_646 := ' ') return ISO_646 - is - begin - return (if Item in ISO_646 then Item else Substitute); - end To_ISO_646; - - function To_ISO_646 - (Item : String; - Substitute : ISO_646 := ' ') return String - is - Result : String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := - (if Item (J) in ISO_646 then Item (J) else Substitute); - end loop; - - return Result; - end To_ISO_646; - - -------------- - -- To_Lower -- - -------------- - - function To_Lower (Item : Character) return Character is - begin - return Value (Lower_Case_Map, Item); - end To_Lower; - - function To_Lower (Item : String) return String is - begin - return Result : String (1 .. Item'Length) do - for J in Item'Range loop - Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); - end loop; - end return; - end To_Lower; - - --------------- - -- To_String -- - --------------- - - function To_String - (Item : Wide_String; - Substitute : Character := ' ') return String - is - Result : String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); - end loop; - - return Result; - end To_String; - - -------------- - -- To_Upper -- - -------------- - - function To_Upper - (Item : Character) return Character - is - begin - return Value (Upper_Case_Map, Item); - end To_Upper; - - function To_Upper - (Item : String) return String - is - begin - return Result : String (1 .. Item'Length) do - for J in Item'Range loop - Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); - end loop; - end return; - end To_Upper; - - ----------------------- - -- To_Wide_Character -- - ----------------------- - - function To_Wide_Character - (Item : Character) return Wide_Character - is - begin - return Wide_Character'Val (Character'Pos (Item)); - end To_Wide_Character; - - -------------------- - -- To_Wide_String -- - -------------------- - - function To_Wide_String - (Item : String) return Wide_String - is - Result : Wide_String (1 .. Item'Length); - - begin - for J in Item'Range loop - Result (J - (Item'First - 1)) := To_Wide_Character (Item (J)); - end loop; - - return Result; - end To_Wide_String; - -end Ada.Characters.Handling; diff --git a/gcc/ada/a-chahan.ads b/gcc/ada/a-chahan.ads deleted file mode 100644 index c34e5e2..0000000 --- a/gcc/ada/a-chahan.ads +++ /dev/null @@ -1,159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . H A N D L I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Characters.Handling is - pragma Pure; - -- In accordance with Ada 2005 AI-362 - - ---------------------------------------- - -- Character Classification Functions -- - ---------------------------------------- - - function Is_Control (Item : Character) return Boolean; - function Is_Graphic (Item : Character) return Boolean; - function Is_Letter (Item : Character) return Boolean; - function Is_Lower (Item : Character) return Boolean; - function Is_Upper (Item : Character) return Boolean; - function Is_Basic (Item : Character) return Boolean; - function Is_Digit (Item : Character) return Boolean; - function Is_Decimal_Digit (Item : Character) return Boolean - renames Is_Digit; - function Is_Hexadecimal_Digit (Item : Character) return Boolean; - function Is_Alphanumeric (Item : Character) return Boolean; - function Is_Special (Item : Character) return Boolean; - function Is_Line_Terminator (Item : Character) return Boolean; - function Is_Mark (Item : Character) return Boolean; - function Is_Other_Format (Item : Character) return Boolean; - function Is_Punctuation_Connector (Item : Character) return Boolean; - function Is_Space (Item : Character) return Boolean; - - --------------------------------------------------- - -- Conversion Functions for Character and String -- - --------------------------------------------------- - - function To_Lower (Item : Character) return Character; - function To_Upper (Item : Character) return Character; - function To_Basic (Item : Character) return Character; - - function To_Lower (Item : String) return String; - function To_Upper (Item : String) return String; - function To_Basic (Item : String) return String; - - ---------------------------------------------------------------------- - -- Classifications of and Conversions Between Character and ISO 646 -- - ---------------------------------------------------------------------- - - subtype ISO_646 is - Character range Character'Val (0) .. Character'Val (127); - - function Is_ISO_646 (Item : Character) return Boolean; - function Is_ISO_646 (Item : String) return Boolean; - - function To_ISO_646 - (Item : Character; - Substitute : ISO_646 := ' ') return ISO_646; - - function To_ISO_646 - (Item : String; - Substitute : ISO_646 := ' ') return String; - - ------------------------------------------------------ - -- Classifications of Wide_Character and Characters -- - ------------------------------------------------------ - - -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions - -- and are considered obsolete in Ada.Characters.Handling. However we do - -- not complain about this obsolescence, since in practice it is necessary - -- to use these routines when creating code that is intended to run in - -- either Ada 95 or Ada 2005 mode. - - -- We do however have to flag these if the pragma No_Obsolescent_Features - -- restriction is active (see Restrict.Check_Obsolescent_2005_Entity). - - function Is_Character (Item : Wide_Character) return Boolean; - function Is_String (Item : Wide_String) return Boolean; - - ------------------------------------------------------ - -- Conversions between Wide_Character and Character -- - ------------------------------------------------------ - - -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions - -- and are considered obsolete in Ada.Characters.Handling. However we do - -- not complain about this obsolescence, since in practice it is necessary - -- to use these routines when creating code that is intended to run in - -- either Ada 95 or Ada 2005 mode. - - -- We do however have to flag these if the pragma No_Obsolescent_Features - -- restriction is active (see Restrict.Check_Obsolescent_2005_Entity). - - function To_Character - (Item : Wide_Character; - Substitute : Character := ' ') return Character; - - function To_String - (Item : Wide_String; - Substitute : Character := ' ') return String; - - function To_Wide_Character - (Item : Character) return Wide_Character; - - function To_Wide_String - (Item : String) return Wide_String; - -private - pragma Inline (Is_Alphanumeric); - pragma Inline (Is_Basic); - pragma Inline (Is_Character); - pragma Inline (Is_Control); - pragma Inline (Is_Digit); - pragma Inline (Is_Graphic); - pragma Inline (Is_Hexadecimal_Digit); - pragma Inline (Is_ISO_646); - pragma Inline (Is_Letter); - pragma Inline (Is_Line_Terminator); - pragma Inline (Is_Lower); - pragma Inline (Is_Mark); - pragma Inline (Is_Other_Format); - pragma Inline (Is_Punctuation_Connector); - pragma Inline (Is_Space); - pragma Inline (Is_Special); - pragma Inline (Is_Upper); - pragma Inline (To_Basic); - pragma Inline (To_Character); - pragma Inline (To_Lower); - pragma Inline (To_Upper); - pragma Inline (To_Wide_Character); - -end Ada.Characters.Handling; diff --git a/gcc/ada/a-charac.ads b/gcc/ada/a-charac.ads deleted file mode 100644 index 8355f54..0000000 --- a/gcc/ada/a-charac.ads +++ /dev/null @@ -1,18 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Characters is - pragma Pure; -end Ada.Characters; diff --git a/gcc/ada/a-chlat1.ads b/gcc/ada/a-chlat1.ads deleted file mode 100644 index 2e20d92..0000000 --- a/gcc/ada/a-chlat1.ads +++ /dev/null @@ -1,296 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . L A T I N _ 1 -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package Ada.Characters.Latin_1 is - pragma Pure; - - ------------------------ - -- Control Characters -- - ------------------------ - - NUL : constant Character := Character'Val (0); - SOH : constant Character := Character'Val (1); - STX : constant Character := Character'Val (2); - ETX : constant Character := Character'Val (3); - EOT : constant Character := Character'Val (4); - ENQ : constant Character := Character'Val (5); - ACK : constant Character := Character'Val (6); - BEL : constant Character := Character'Val (7); - BS : constant Character := Character'Val (8); - HT : constant Character := Character'Val (9); - LF : constant Character := Character'Val (10); - VT : constant Character := Character'Val (11); - FF : constant Character := Character'Val (12); - CR : constant Character := Character'Val (13); - SO : constant Character := Character'Val (14); - SI : constant Character := Character'Val (15); - - DLE : constant Character := Character'Val (16); - DC1 : constant Character := Character'Val (17); - DC2 : constant Character := Character'Val (18); - DC3 : constant Character := Character'Val (19); - DC4 : constant Character := Character'Val (20); - NAK : constant Character := Character'Val (21); - SYN : constant Character := Character'Val (22); - ETB : constant Character := Character'Val (23); - CAN : constant Character := Character'Val (24); - EM : constant Character := Character'Val (25); - SUB : constant Character := Character'Val (26); - ESC : constant Character := Character'Val (27); - FS : constant Character := Character'Val (28); - GS : constant Character := Character'Val (29); - RS : constant Character := Character'Val (30); - US : constant Character := Character'Val (31); - - -------------------------------- - -- ISO 646 Graphic Characters -- - -------------------------------- - - Space : constant Character := ' '; -- Character'Val(32) - Exclamation : constant Character := '!'; -- Character'Val(33) - Quotation : constant Character := '"'; -- Character'Val(34) - Number_Sign : constant Character := '#'; -- Character'Val(35) - Dollar_Sign : constant Character := '$'; -- Character'Val(36) - Percent_Sign : constant Character := '%'; -- Character'Val(37) - Ampersand : constant Character := '&'; -- Character'Val(38) - Apostrophe : constant Character := '''; -- Character'Val(39) - Left_Parenthesis : constant Character := '('; -- Character'Val(40) - Right_Parenthesis : constant Character := ')'; -- Character'Val(41) - Asterisk : constant Character := '*'; -- Character'Val(42) - Plus_Sign : constant Character := '+'; -- Character'Val(43) - Comma : constant Character := ','; -- Character'Val(44) - Hyphen : constant Character := '-'; -- Character'Val(45) - Minus_Sign : Character renames Hyphen; - Full_Stop : constant Character := '.'; -- Character'Val(46) - Solidus : constant Character := '/'; -- Character'Val(47) - - -- Decimal digits '0' though '9' are at positions 48 through 57 - - Colon : constant Character := ':'; -- Character'Val(58) - Semicolon : constant Character := ';'; -- Character'Val(59) - Less_Than_Sign : constant Character := '<'; -- Character'Val(60) - Equals_Sign : constant Character := '='; -- Character'Val(61) - Greater_Than_Sign : constant Character := '>'; -- Character'Val(62) - Question : constant Character := '?'; -- Character'Val(63) - Commercial_At : constant Character := '@'; -- Character'Val(64) - - -- Letters 'A' through 'Z' are at positions 65 through 90 - - Left_Square_Bracket : constant Character := '['; -- Character'Val (91) - Reverse_Solidus : constant Character := '\'; -- Character'Val (92) - Right_Square_Bracket : constant Character := ']'; -- Character'Val (93) - Circumflex : constant Character := '^'; -- Character'Val (94) - Low_Line : constant Character := '_'; -- Character'Val (95) - - Grave : constant Character := '`'; -- Character'Val (96) - LC_A : constant Character := 'a'; -- Character'Val (97) - LC_B : constant Character := 'b'; -- Character'Val (98) - LC_C : constant Character := 'c'; -- Character'Val (99) - LC_D : constant Character := 'd'; -- Character'Val (100) - LC_E : constant Character := 'e'; -- Character'Val (101) - LC_F : constant Character := 'f'; -- Character'Val (102) - LC_G : constant Character := 'g'; -- Character'Val (103) - LC_H : constant Character := 'h'; -- Character'Val (104) - LC_I : constant Character := 'i'; -- Character'Val (105) - LC_J : constant Character := 'j'; -- Character'Val (106) - LC_K : constant Character := 'k'; -- Character'Val (107) - LC_L : constant Character := 'l'; -- Character'Val (108) - LC_M : constant Character := 'm'; -- Character'Val (109) - LC_N : constant Character := 'n'; -- Character'Val (110) - LC_O : constant Character := 'o'; -- Character'Val (111) - LC_P : constant Character := 'p'; -- Character'Val (112) - LC_Q : constant Character := 'q'; -- Character'Val (113) - LC_R : constant Character := 'r'; -- Character'Val (114) - LC_S : constant Character := 's'; -- Character'Val (115) - LC_T : constant Character := 't'; -- Character'Val (116) - LC_U : constant Character := 'u'; -- Character'Val (117) - LC_V : constant Character := 'v'; -- Character'Val (118) - LC_W : constant Character := 'w'; -- Character'Val (119) - LC_X : constant Character := 'x'; -- Character'Val (120) - LC_Y : constant Character := 'y'; -- Character'Val (121) - LC_Z : constant Character := 'z'; -- Character'Val (122) - Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123) - Vertical_Line : constant Character := '|'; -- Character'Val (124) - Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125) - Tilde : constant Character := '~'; -- Character'Val (126) - DEL : constant Character := Character'Val (127); - - --------------------------------- - -- ISO 6429 Control Characters -- - --------------------------------- - - IS4 : Character renames FS; - IS3 : Character renames GS; - IS2 : Character renames RS; - IS1 : Character renames US; - - Reserved_128 : constant Character := Character'Val (128); - Reserved_129 : constant Character := Character'Val (129); - BPH : constant Character := Character'Val (130); - NBH : constant Character := Character'Val (131); - Reserved_132 : constant Character := Character'Val (132); - NEL : constant Character := Character'Val (133); - SSA : constant Character := Character'Val (134); - ESA : constant Character := Character'Val (135); - HTS : constant Character := Character'Val (136); - HTJ : constant Character := Character'Val (137); - VTS : constant Character := Character'Val (138); - PLD : constant Character := Character'Val (139); - PLU : constant Character := Character'Val (140); - RI : constant Character := Character'Val (141); - SS2 : constant Character := Character'Val (142); - SS3 : constant Character := Character'Val (143); - - DCS : constant Character := Character'Val (144); - PU1 : constant Character := Character'Val (145); - PU2 : constant Character := Character'Val (146); - STS : constant Character := Character'Val (147); - CCH : constant Character := Character'Val (148); - MW : constant Character := Character'Val (149); - SPA : constant Character := Character'Val (150); - EPA : constant Character := Character'Val (151); - - SOS : constant Character := Character'Val (152); - Reserved_153 : constant Character := Character'Val (153); - SCI : constant Character := Character'Val (154); - CSI : constant Character := Character'Val (155); - ST : constant Character := Character'Val (156); - OSC : constant Character := Character'Val (157); - PM : constant Character := Character'Val (158); - APC : constant Character := Character'Val (159); - - ------------------------------ - -- Other Graphic Characters -- - ------------------------------ - - -- Character positions 160 (16#A0#) .. 175 (16#AF#) - - No_Break_Space : constant Character := Character'Val (160); - NBSP : Character renames No_Break_Space; - Inverted_Exclamation : constant Character := Character'Val (161); - Cent_Sign : constant Character := Character'Val (162); - Pound_Sign : constant Character := Character'Val (163); - Currency_Sign : constant Character := Character'Val (164); - Yen_Sign : constant Character := Character'Val (165); - Broken_Bar : constant Character := Character'Val (166); - Section_Sign : constant Character := Character'Val (167); - Diaeresis : constant Character := Character'Val (168); - Copyright_Sign : constant Character := Character'Val (169); - Feminine_Ordinal_Indicator : constant Character := Character'Val (170); - Left_Angle_Quotation : constant Character := Character'Val (171); - Not_Sign : constant Character := Character'Val (172); - Soft_Hyphen : constant Character := Character'Val (173); - Registered_Trade_Mark_Sign : constant Character := Character'Val (174); - Macron : constant Character := Character'Val (175); - - -- Character positions 176 (16#B0#) .. 191 (16#BF#) - - Degree_Sign : constant Character := Character'Val (176); - Ring_Above : Character renames Degree_Sign; - Plus_Minus_Sign : constant Character := Character'Val (177); - Superscript_Two : constant Character := Character'Val (178); - Superscript_Three : constant Character := Character'Val (179); - Acute : constant Character := Character'Val (180); - Micro_Sign : constant Character := Character'Val (181); - Pilcrow_Sign : constant Character := Character'Val (182); - Paragraph_Sign : Character renames Pilcrow_Sign; - Middle_Dot : constant Character := Character'Val (183); - Cedilla : constant Character := Character'Val (184); - Superscript_One : constant Character := Character'Val (185); - Masculine_Ordinal_Indicator : constant Character := Character'Val (186); - Right_Angle_Quotation : constant Character := Character'Val (187); - Fraction_One_Quarter : constant Character := Character'Val (188); - Fraction_One_Half : constant Character := Character'Val (189); - Fraction_Three_Quarters : constant Character := Character'Val (190); - Inverted_Question : constant Character := Character'Val (191); - - -- Character positions 192 (16#C0#) .. 207 (16#CF#) - - UC_A_Grave : constant Character := Character'Val (192); - UC_A_Acute : constant Character := Character'Val (193); - UC_A_Circumflex : constant Character := Character'Val (194); - UC_A_Tilde : constant Character := Character'Val (195); - UC_A_Diaeresis : constant Character := Character'Val (196); - UC_A_Ring : constant Character := Character'Val (197); - UC_AE_Diphthong : constant Character := Character'Val (198); - UC_C_Cedilla : constant Character := Character'Val (199); - UC_E_Grave : constant Character := Character'Val (200); - UC_E_Acute : constant Character := Character'Val (201); - UC_E_Circumflex : constant Character := Character'Val (202); - UC_E_Diaeresis : constant Character := Character'Val (203); - UC_I_Grave : constant Character := Character'Val (204); - UC_I_Acute : constant Character := Character'Val (205); - UC_I_Circumflex : constant Character := Character'Val (206); - UC_I_Diaeresis : constant Character := Character'Val (207); - - -- Character positions 208 (16#D0#) .. 223 (16#DF#) - - UC_Icelandic_Eth : constant Character := Character'Val (208); - UC_N_Tilde : constant Character := Character'Val (209); - UC_O_Grave : constant Character := Character'Val (210); - UC_O_Acute : constant Character := Character'Val (211); - UC_O_Circumflex : constant Character := Character'Val (212); - UC_O_Tilde : constant Character := Character'Val (213); - UC_O_Diaeresis : constant Character := Character'Val (214); - Multiplication_Sign : constant Character := Character'Val (215); - UC_O_Oblique_Stroke : constant Character := Character'Val (216); - UC_U_Grave : constant Character := Character'Val (217); - UC_U_Acute : constant Character := Character'Val (218); - UC_U_Circumflex : constant Character := Character'Val (219); - UC_U_Diaeresis : constant Character := Character'Val (220); - UC_Y_Acute : constant Character := Character'Val (221); - UC_Icelandic_Thorn : constant Character := Character'Val (222); - LC_German_Sharp_S : constant Character := Character'Val (223); - - -- Character positions 224 (16#E0#) .. 239 (16#EF#) - - LC_A_Grave : constant Character := Character'Val (224); - LC_A_Acute : constant Character := Character'Val (225); - LC_A_Circumflex : constant Character := Character'Val (226); - LC_A_Tilde : constant Character := Character'Val (227); - LC_A_Diaeresis : constant Character := Character'Val (228); - LC_A_Ring : constant Character := Character'Val (229); - LC_AE_Diphthong : constant Character := Character'Val (230); - LC_C_Cedilla : constant Character := Character'Val (231); - LC_E_Grave : constant Character := Character'Val (232); - LC_E_Acute : constant Character := Character'Val (233); - LC_E_Circumflex : constant Character := Character'Val (234); - LC_E_Diaeresis : constant Character := Character'Val (235); - LC_I_Grave : constant Character := Character'Val (236); - LC_I_Acute : constant Character := Character'Val (237); - LC_I_Circumflex : constant Character := Character'Val (238); - LC_I_Diaeresis : constant Character := Character'Val (239); - - -- Character positions 240 (16#F0#) .. 255 (16#FF) - LC_Icelandic_Eth : constant Character := Character'Val (240); - LC_N_Tilde : constant Character := Character'Val (241); - LC_O_Grave : constant Character := Character'Val (242); - LC_O_Acute : constant Character := Character'Val (243); - LC_O_Circumflex : constant Character := Character'Val (244); - LC_O_Tilde : constant Character := Character'Val (245); - LC_O_Diaeresis : constant Character := Character'Val (246); - Division_Sign : constant Character := Character'Val (247); - LC_O_Oblique_Stroke : constant Character := Character'Val (248); - LC_U_Grave : constant Character := Character'Val (249); - LC_U_Acute : constant Character := Character'Val (250); - LC_U_Circumflex : constant Character := Character'Val (251); - LC_U_Diaeresis : constant Character := Character'Val (252); - LC_Y_Acute : constant Character := Character'Val (253); - LC_Icelandic_Thorn : constant Character := Character'Val (254); - LC_Y_Diaeresis : constant Character := Character'Val (255); - -end Ada.Characters.Latin_1; diff --git a/gcc/ada/a-chlat9.ads b/gcc/ada/a-chlat9.ads deleted file mode 100644 index 82821cc..0000000 --- a/gcc/ada/a-chlat9.ads +++ /dev/null @@ -1,332 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . L A T I N _ 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2009, 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 modifications made to Ada.Characters.Latin_1, noted -- --- in the text, to derive the equivalent Latin-9 package. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides definitions for Latin-9 (ISO-8859-15) analogous to --- those defined in the standard package Ada.Characters.Latin_1 for Latin-1. - -package Ada.Characters.Latin_9 is - pragma Pure; - - ------------------------ - -- Control Characters -- - ------------------------ - - NUL : constant Character := Character'Val (0); - SOH : constant Character := Character'Val (1); - STX : constant Character := Character'Val (2); - ETX : constant Character := Character'Val (3); - EOT : constant Character := Character'Val (4); - ENQ : constant Character := Character'Val (5); - ACK : constant Character := Character'Val (6); - BEL : constant Character := Character'Val (7); - BS : constant Character := Character'Val (8); - HT : constant Character := Character'Val (9); - LF : constant Character := Character'Val (10); - VT : constant Character := Character'Val (11); - FF : constant Character := Character'Val (12); - CR : constant Character := Character'Val (13); - SO : constant Character := Character'Val (14); - SI : constant Character := Character'Val (15); - - DLE : constant Character := Character'Val (16); - DC1 : constant Character := Character'Val (17); - DC2 : constant Character := Character'Val (18); - DC3 : constant Character := Character'Val (19); - DC4 : constant Character := Character'Val (20); - NAK : constant Character := Character'Val (21); - SYN : constant Character := Character'Val (22); - ETB : constant Character := Character'Val (23); - CAN : constant Character := Character'Val (24); - EM : constant Character := Character'Val (25); - SUB : constant Character := Character'Val (26); - ESC : constant Character := Character'Val (27); - FS : constant Character := Character'Val (28); - GS : constant Character := Character'Val (29); - RS : constant Character := Character'Val (30); - US : constant Character := Character'Val (31); - - -------------------------------- - -- ISO 646 Graphic Characters -- - -------------------------------- - - Space : constant Character := ' '; -- Character'Val(32) - Exclamation : constant Character := '!'; -- Character'Val(33) - Quotation : constant Character := '"'; -- Character'Val(34) - Number_Sign : constant Character := '#'; -- Character'Val(35) - Dollar_Sign : constant Character := '$'; -- Character'Val(36) - Percent_Sign : constant Character := '%'; -- Character'Val(37) - Ampersand : constant Character := '&'; -- Character'Val(38) - Apostrophe : constant Character := '''; -- Character'Val(39) - Left_Parenthesis : constant Character := '('; -- Character'Val(40) - Right_Parenthesis : constant Character := ')'; -- Character'Val(41) - Asterisk : constant Character := '*'; -- Character'Val(42) - Plus_Sign : constant Character := '+'; -- Character'Val(43) - Comma : constant Character := ','; -- Character'Val(44) - Hyphen : constant Character := '-'; -- Character'Val(45) - Minus_Sign : Character renames Hyphen; - Full_Stop : constant Character := '.'; -- Character'Val(46) - Solidus : constant Character := '/'; -- Character'Val(47) - - -- Decimal digits '0' though '9' are at positions 48 through 57 - - Colon : constant Character := ':'; -- Character'Val(58) - Semicolon : constant Character := ';'; -- Character'Val(59) - Less_Than_Sign : constant Character := '<'; -- Character'Val(60) - Equals_Sign : constant Character := '='; -- Character'Val(61) - Greater_Than_Sign : constant Character := '>'; -- Character'Val(62) - Question : constant Character := '?'; -- Character'Val(63) - - Commercial_At : constant Character := '@'; -- Character'Val(64) - - -- Letters 'A' through 'Z' are at positions 65 through 90 - - Left_Square_Bracket : constant Character := '['; -- Character'Val (91) - Reverse_Solidus : constant Character := '\'; -- Character'Val (92) - Right_Square_Bracket : constant Character := ']'; -- Character'Val (93) - Circumflex : constant Character := '^'; -- Character'Val (94) - Low_Line : constant Character := '_'; -- Character'Val (95) - - Grave : constant Character := '`'; -- Character'Val (96) - LC_A : constant Character := 'a'; -- Character'Val (97) - LC_B : constant Character := 'b'; -- Character'Val (98) - LC_C : constant Character := 'c'; -- Character'Val (99) - LC_D : constant Character := 'd'; -- Character'Val (100) - LC_E : constant Character := 'e'; -- Character'Val (101) - LC_F : constant Character := 'f'; -- Character'Val (102) - LC_G : constant Character := 'g'; -- Character'Val (103) - LC_H : constant Character := 'h'; -- Character'Val (104) - LC_I : constant Character := 'i'; -- Character'Val (105) - LC_J : constant Character := 'j'; -- Character'Val (106) - LC_K : constant Character := 'k'; -- Character'Val (107) - LC_L : constant Character := 'l'; -- Character'Val (108) - LC_M : constant Character := 'm'; -- Character'Val (109) - LC_N : constant Character := 'n'; -- Character'Val (110) - LC_O : constant Character := 'o'; -- Character'Val (111) - LC_P : constant Character := 'p'; -- Character'Val (112) - LC_Q : constant Character := 'q'; -- Character'Val (113) - LC_R : constant Character := 'r'; -- Character'Val (114) - LC_S : constant Character := 's'; -- Character'Val (115) - LC_T : constant Character := 't'; -- Character'Val (116) - LC_U : constant Character := 'u'; -- Character'Val (117) - LC_V : constant Character := 'v'; -- Character'Val (118) - LC_W : constant Character := 'w'; -- Character'Val (119) - LC_X : constant Character := 'x'; -- Character'Val (120) - LC_Y : constant Character := 'y'; -- Character'Val (121) - LC_Z : constant Character := 'z'; -- Character'Val (122) - Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123) - Vertical_Line : constant Character := '|'; -- Character'Val (124) - Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125) - Tilde : constant Character := '~'; -- Character'Val (126) - DEL : constant Character := Character'Val (127); - - --------------------------------- - -- ISO 6429 Control Characters -- - --------------------------------- - - IS4 : Character renames FS; - IS3 : Character renames GS; - IS2 : Character renames RS; - IS1 : Character renames US; - - Reserved_128 : constant Character := Character'Val (128); - Reserved_129 : constant Character := Character'Val (129); - BPH : constant Character := Character'Val (130); - NBH : constant Character := Character'Val (131); - Reserved_132 : constant Character := Character'Val (132); - NEL : constant Character := Character'Val (133); - SSA : constant Character := Character'Val (134); - ESA : constant Character := Character'Val (135); - HTS : constant Character := Character'Val (136); - HTJ : constant Character := Character'Val (137); - VTS : constant Character := Character'Val (138); - PLD : constant Character := Character'Val (139); - PLU : constant Character := Character'Val (140); - RI : constant Character := Character'Val (141); - SS2 : constant Character := Character'Val (142); - SS3 : constant Character := Character'Val (143); - - DCS : constant Character := Character'Val (144); - PU1 : constant Character := Character'Val (145); - PU2 : constant Character := Character'Val (146); - STS : constant Character := Character'Val (147); - CCH : constant Character := Character'Val (148); - MW : constant Character := Character'Val (149); - SPA : constant Character := Character'Val (150); - EPA : constant Character := Character'Val (151); - - SOS : constant Character := Character'Val (152); - Reserved_153 : constant Character := Character'Val (153); - SCI : constant Character := Character'Val (154); - CSI : constant Character := Character'Val (155); - ST : constant Character := Character'Val (156); - OSC : constant Character := Character'Val (157); - PM : constant Character := Character'Val (158); - APC : constant Character := Character'Val (159); - - ------------------------------ - -- Other Graphic Characters -- - ------------------------------ - - -- Character positions 160 (16#A0#) .. 175 (16#AF#) - - No_Break_Space : constant Character := Character'Val (160); - NBSP : Character renames No_Break_Space; - Inverted_Exclamation : constant Character := Character'Val (161); - Cent_Sign : constant Character := Character'Val (162); - Pound_Sign : constant Character := Character'Val (163); - Euro_Sign : constant Character := Character'Val (164); - Yen_Sign : constant Character := Character'Val (165); - UC_S_Caron : constant Character := Character'Val (166); - Section_Sign : constant Character := Character'Val (167); - LC_S_Caron : constant Character := Character'Val (168); - Copyright_Sign : constant Character := Character'Val (169); - Feminine_Ordinal_Indicator : constant Character := Character'Val (170); - Left_Angle_Quotation : constant Character := Character'Val (171); - Not_Sign : constant Character := Character'Val (172); - Soft_Hyphen : constant Character := Character'Val (173); - Registered_Trade_Mark_Sign : constant Character := Character'Val (174); - Macron : constant Character := Character'Val (175); - - -- Character positions 176 (16#B0#) .. 191 (16#BF#) - - Degree_Sign : constant Character := Character'Val (176); - Ring_Above : Character renames Degree_Sign; - Plus_Minus_Sign : constant Character := Character'Val (177); - Superscript_Two : constant Character := Character'Val (178); - Superscript_Three : constant Character := Character'Val (179); - UC_Z_Caron : constant Character := Character'Val (180); - Micro_Sign : constant Character := Character'Val (181); - Pilcrow_Sign : constant Character := Character'Val (182); - Paragraph_Sign : Character renames Pilcrow_Sign; - Middle_Dot : constant Character := Character'Val (183); - LC_Z_Caron : constant Character := Character'Val (184); - Superscript_One : constant Character := Character'Val (185); - Masculine_Ordinal_Indicator : constant Character := Character'Val (186); - Right_Angle_Quotation : constant Character := Character'Val (187); - UC_Ligature_OE : constant Character := Character'Val (188); - LC_Ligature_OE : constant Character := Character'Val (189); - UC_Y_Diaeresis : constant Character := Character'Val (190); - Inverted_Question : constant Character := Character'Val (191); - - -- Character positions 192 (16#C0#) .. 207 (16#CF#) - - UC_A_Grave : constant Character := Character'Val (192); - UC_A_Acute : constant Character := Character'Val (193); - UC_A_Circumflex : constant Character := Character'Val (194); - UC_A_Tilde : constant Character := Character'Val (195); - UC_A_Diaeresis : constant Character := Character'Val (196); - UC_A_Ring : constant Character := Character'Val (197); - UC_AE_Diphthong : constant Character := Character'Val (198); - UC_C_Cedilla : constant Character := Character'Val (199); - UC_E_Grave : constant Character := Character'Val (200); - UC_E_Acute : constant Character := Character'Val (201); - UC_E_Circumflex : constant Character := Character'Val (202); - UC_E_Diaeresis : constant Character := Character'Val (203); - UC_I_Grave : constant Character := Character'Val (204); - UC_I_Acute : constant Character := Character'Val (205); - UC_I_Circumflex : constant Character := Character'Val (206); - UC_I_Diaeresis : constant Character := Character'Val (207); - - -- Character positions 208 (16#D0#) .. 223 (16#DF#) - - UC_Icelandic_Eth : constant Character := Character'Val (208); - UC_N_Tilde : constant Character := Character'Val (209); - UC_O_Grave : constant Character := Character'Val (210); - UC_O_Acute : constant Character := Character'Val (211); - UC_O_Circumflex : constant Character := Character'Val (212); - UC_O_Tilde : constant Character := Character'Val (213); - UC_O_Diaeresis : constant Character := Character'Val (214); - Multiplication_Sign : constant Character := Character'Val (215); - UC_O_Oblique_Stroke : constant Character := Character'Val (216); - UC_U_Grave : constant Character := Character'Val (217); - UC_U_Acute : constant Character := Character'Val (218); - UC_U_Circumflex : constant Character := Character'Val (219); - UC_U_Diaeresis : constant Character := Character'Val (220); - UC_Y_Acute : constant Character := Character'Val (221); - UC_Icelandic_Thorn : constant Character := Character'Val (222); - LC_German_Sharp_S : constant Character := Character'Val (223); - - -- Character positions 224 (16#E0#) .. 239 (16#EF#) - - LC_A_Grave : constant Character := Character'Val (224); - LC_A_Acute : constant Character := Character'Val (225); - LC_A_Circumflex : constant Character := Character'Val (226); - LC_A_Tilde : constant Character := Character'Val (227); - LC_A_Diaeresis : constant Character := Character'Val (228); - LC_A_Ring : constant Character := Character'Val (229); - LC_AE_Diphthong : constant Character := Character'Val (230); - LC_C_Cedilla : constant Character := Character'Val (231); - LC_E_Grave : constant Character := Character'Val (232); - LC_E_Acute : constant Character := Character'Val (233); - LC_E_Circumflex : constant Character := Character'Val (234); - LC_E_Diaeresis : constant Character := Character'Val (235); - LC_I_Grave : constant Character := Character'Val (236); - LC_I_Acute : constant Character := Character'Val (237); - LC_I_Circumflex : constant Character := Character'Val (238); - LC_I_Diaeresis : constant Character := Character'Val (239); - - -- Character positions 240 (16#F0#) .. 255 (16#FF) - LC_Icelandic_Eth : constant Character := Character'Val (240); - LC_N_Tilde : constant Character := Character'Val (241); - LC_O_Grave : constant Character := Character'Val (242); - LC_O_Acute : constant Character := Character'Val (243); - LC_O_Circumflex : constant Character := Character'Val (244); - LC_O_Tilde : constant Character := Character'Val (245); - LC_O_Diaeresis : constant Character := Character'Val (246); - Division_Sign : constant Character := Character'Val (247); - LC_O_Oblique_Stroke : constant Character := Character'Val (248); - LC_U_Grave : constant Character := Character'Val (249); - LC_U_Acute : constant Character := Character'Val (250); - LC_U_Circumflex : constant Character := Character'Val (251); - LC_U_Diaeresis : constant Character := Character'Val (252); - LC_Y_Acute : constant Character := Character'Val (253); - LC_Icelandic_Thorn : constant Character := Character'Val (254); - LC_Y_Diaeresis : constant Character := Character'Val (255); - - ------------------------------------------------ - -- Summary of Changes from Latin-1 => Latin-9 -- - ------------------------------------------------ - - -- 164 Currency => Euro_Sign - -- 166 Broken_Bar => UC_S_Caron - -- 168 Diaeresis => LC_S_Caron - -- 180 Acute => UC_Z_Caron - -- 184 Cedilla => LC_Z_Caron - -- 188 Fraction_One_Quarter => UC_Ligature_OE - -- 189 Fraction_One_Half => LC_Ligature_OE - -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis - -end Ada.Characters.Latin_9; diff --git a/gcc/ada/a-chtgbk.adb b/gcc/ada/a-chtgbk.adb deleted file mode 100644 index 43d0c1a..0000000 --- a/gcc/ada/a-chtgbk.adb +++ /dev/null @@ -1,346 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------------- - -- Checked_Equivalent_Keys -- - ----------------------------- - - function Checked_Equivalent_Keys - (HT : aliased in out Hash_Table_Type'Class; - Key : Key_Type; - Node : Count_Type) return Boolean - is - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - return Equivalent_Keys (Key, HT.Nodes (Node)); - end Checked_Equivalent_Keys; - - ------------------- - -- Checked_Index -- - ------------------- - - function Checked_Index - (HT : aliased in out Hash_Table_Type'Class; - Key : Key_Type) return Hash_Type - is - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; - end Checked_Index; - - -------------------------- - -- Delete_Key_Sans_Free -- - -------------------------- - - procedure Delete_Key_Sans_Free - (HT : in out Hash_Table_Type'Class; - Key : Key_Type; - X : out Count_Type) - is - Indx : Hash_Type; - Prev : Count_Type; - - begin - if HT.Length = 0 then - X := 0; - return; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TC_Check (HT.TC); - - Indx := Checked_Index (HT, Key); - X := HT.Buckets (Indx); - - if X = 0 then - return; - end if; - - if Checked_Equivalent_Keys (HT, Key, X) then - TC_Check (HT.TC); - HT.Buckets (Indx) := Next (HT.Nodes (X)); - HT.Length := HT.Length - 1; - return; - end if; - - loop - Prev := X; - X := Next (HT.Nodes (Prev)); - - if X = 0 then - return; - end if; - - if Checked_Equivalent_Keys (HT, Key, X) then - TC_Check (HT.TC); - Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); - HT.Length := HT.Length - 1; - return; - end if; - end loop; - end Delete_Key_Sans_Free; - - ---------- - -- Find -- - ---------- - - function Find - (HT : Hash_Table_Type'Class; - Key : Key_Type) return Count_Type - is - Indx : Hash_Type; - Node : Count_Type; - - begin - if HT.Length = 0 then - return 0; - end if; - - Indx := Checked_Index (HT'Unrestricted_Access.all, Key); - - Node := HT.Buckets (Indx); - while Node /= 0 loop - if Checked_Equivalent_Keys - (HT'Unrestricted_Access.all, Key, Node) - then - return Node; - end if; - Node := Next (HT.Nodes (Node)); - end loop; - - return 0; - end Find; - - -------------------------------- - -- Generic_Conditional_Insert -- - -------------------------------- - - procedure Generic_Conditional_Insert - (HT : in out Hash_Table_Type'Class; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - Indx : Hash_Type; - - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TC_Check (HT.TC); - - Indx := Checked_Index (HT, Key); - Node := HT.Buckets (Indx); - - if Node = 0 then - if Checks and then HT.Length = HT.Capacity then - raise Capacity_Error with "no more capacity for insertion"; - end if; - - Node := New_Node; - Set_Next (HT.Nodes (Node), Next => 0); - - Inserted := True; - - HT.Buckets (Indx) := Node; - HT.Length := HT.Length + 1; - - return; - end if; - - loop - if Checked_Equivalent_Keys (HT, Key, Node) then - Inserted := False; - return; - end if; - - Node := Next (HT.Nodes (Node)); - - exit when Node = 0; - end loop; - - if Checks and then HT.Length = HT.Capacity then - raise Capacity_Error with "no more capacity for insertion"; - end if; - - Node := New_Node; - Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); - - Inserted := True; - - HT.Buckets (Indx) := Node; - HT.Length := HT.Length + 1; - end Generic_Conditional_Insert; - - ----------------------------- - -- Generic_Replace_Element -- - ----------------------------- - - procedure Generic_Replace_Element - (HT : in out Hash_Table_Type'Class; - Node : Count_Type; - Key : Key_Type) - is - pragma Assert (HT.Length > 0); - pragma Assert (Node /= 0); - - BB : Buckets_Type renames HT.Buckets; - NN : Nodes_Type renames HT.Nodes; - - Old_Indx : Hash_Type; - New_Indx : constant Hash_Type := Checked_Index (HT, Key); - - New_Bucket : Count_Type renames BB (New_Indx); - N, M : Count_Type; - - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - -- The following block appears to be vestigial -- this should be done - -- using Checked_Index instead. Also, we might have to move the actual - -- tampering checks to the top of the subprogram, in order to prevent - -- infinite recursion when calling Hash. (This is similar to how Insert - -- and Delete are implemented.) This implies that we will have to defer - -- the computation of New_Index until after the tampering check. ??? - - declare - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; - end; - - -- Replace_Element is allowed to change a node's key to Key - -- (generic formal operation Assign provides the mechanism), but - -- only if Key is not already in the hash table. (In a unique-key - -- hash table as this one, a key is mapped to exactly one node.) - - if Checked_Equivalent_Keys (HT, Key, Node) then - TE_Check (HT.TC); - - -- The new Key value is mapped to this same Node, so Node - -- stays in the same bucket. - - Assign (NN (Node), Key); - return; - end if; - - -- Key is not equivalent to Node, so we now have to determine if it's - -- equivalent to some other node in the hash table. This is the case - -- irrespective of whether Key is in the same or a different bucket from - -- Node. - - N := New_Bucket; - while N /= 0 loop - if Checks and then Checked_Equivalent_Keys (HT, Key, N) then - pragma Assert (N /= Node); - raise Program_Error with - "attempt to replace existing element"; - end if; - - N := Next (NN (N)); - end loop; - - -- We have determined that Key is not already in the hash table, so - -- the change is tentatively allowed. We now perform the standard - -- checks to determine whether the hash table is locked (because you - -- cannot change an element while it's in use by Query_Element or - -- Update_Element), or if the container is busy (because moving a - -- node to a different bucket would interfere with iteration). - - if Old_Indx = New_Indx then - -- The node is already in the bucket implied by Key. In this case - -- we merely change its value without moving it. - - TE_Check (HT.TC); - - Assign (NN (Node), Key); - return; - end if; - - -- The node is a bucket different from the bucket implied by Key - - TC_Check (HT.TC); - - -- Do the assignment first, before moving the node, so that if Assign - -- propagates an exception, then the hash table will not have been - -- modified (except for any possible side-effect Assign had on Node). - - Assign (NN (Node), Key); - - -- Now we can safely remove the node from its current bucket - - N := BB (Old_Indx); -- get value of first node in old bucket - pragma Assert (N /= 0); - - if N = Node then -- node is first node in its bucket - BB (Old_Indx) := Next (NN (Node)); - - else - pragma Assert (HT.Length > 1); - - loop - M := Next (NN (N)); - pragma Assert (M /= 0); - - if M = Node then - Set_Next (NN (N), Next => Next (NN (Node))); - exit; - end if; - - N := M; - end loop; - end if; - - -- Now we link the node into its new bucket (corresponding to Key) - - Set_Next (NN (Node), Next => New_Bucket); - New_Bucket := Node; - end Generic_Replace_Element; - - ----------- - -- Index -- - ----------- - - function Index - (HT : Hash_Table_Type'Class; - Key : Key_Type) return Hash_Type is - begin - return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; - end Index; - -end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; diff --git a/gcc/ada/a-chtgbk.ads b/gcc/ada/a-chtgbk.ads deleted file mode 100644 index 037a87e..0000000 --- a/gcc/ada/a-chtgbk.ads +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Hash_Table_Type is used to implement hashed containers. This package --- declares hash-table operations that depend on keys. - -generic - with package HT_Types is - new Generic_Bounded_Hash_Table_Types (<>); - - use HT_Types, HT_Types.Implementation; - - with function Next (Node : Node_Type) return Count_Type; - - with procedure Set_Next - (Node : in out Node_Type; - Next : Count_Type); - - type Key_Type (<>) is limited private; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys - (Key : Key_Type; - Node : Node_Type) return Boolean; - -package Ada.Containers.Hash_Tables.Generic_Bounded_Keys is - pragma Pure; - - function Index - (HT : Hash_Table_Type'Class; - Key : Key_Type) return Hash_Type; - pragma Inline (Index); - -- Returns the bucket number (array index value) for the given key - - function Checked_Index - (HT : aliased in out Hash_Table_Type'Class; - Key : Key_Type) return Hash_Type; - pragma Inline (Checked_Index); - -- Calls Index, but also locks and unlocks the container, per AI05-0022, in - -- order to detect element tampering by the generic actual Hash function. - - function Checked_Equivalent_Keys - (HT : aliased in out Hash_Table_Type'Class; - Key : Key_Type; - Node : Count_Type) return Boolean; - -- Calls Equivalent_Keys, but locks and unlocks the container, per - -- AI05-0022, in order to detect element tampering by that generic actual. - - procedure Delete_Key_Sans_Free - (HT : in out Hash_Table_Type'Class; - Key : Key_Type; - X : out Count_Type); - -- Removes the node (if any) with the given key from the hash table, - -- without deallocating it. Program_Error is raised if the hash - -- table is busy. - - function Find - (HT : Hash_Table_Type'Class; - Key : Key_Type) return Count_Type; - -- Returns the node (if any) corresponding to the given key - - generic - with function New_Node return Count_Type; - procedure Generic_Conditional_Insert - (HT : in out Hash_Table_Type'Class; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean); - -- Attempts to insert a new node with the given key into the hash table. - -- If a node with that key already exists in the table, then that node - -- is returned and Inserted returns False. Otherwise New_Node is called - -- to allocate a new node, and Inserted returns True. Program_Error is - -- raised if the hash table is busy. - - generic - with function Hash (Node : Node_Type) return Hash_Type; - with procedure Assign (Node : in out Node_Type; Key : Key_Type); - procedure Generic_Replace_Element - (HT : in out Hash_Table_Type'Class; - Node : Count_Type; - Key : Key_Type); - -- Assigns Key to Node, possibly changing its equivalence class. If Node - -- is in the same equivalence class as Key (that is, it's already in the - -- bucket implied by Key), then if the hash table is locked then - -- Program_Error is raised; otherwise Assign is called to assign Key to - -- Node. If Node is in a different bucket from Key, then Program_Error is - -- raised if the hash table is busy. Otherwise it Assigns Key to Node and - -- moves the Node from its current bucket to the bucket implied by Key. - -- Note that it is never proper to assign to Node a key value already - -- in the map, and so if Key is equivalent to some other node then - -- Program_Error is raised. - -end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; diff --git a/gcc/ada/a-chtgbo.adb b/gcc/ada/a-chtgbo.adb deleted file mode 100644 index 034b592..0000000 --- a/gcc/ada/a-chtgbo.adb +++ /dev/null @@ -1,553 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; use type System.Address; - -package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ------------------- - -- Checked_Index -- - ------------------- - - function Checked_Index - (Hash_Table : aliased in out Hash_Table_Type'Class; - Node : Count_Type) return Hash_Type - is - Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); - begin - return Index (Hash_Table, Hash_Table.Nodes (Node)); - end Checked_Index; - - ----------- - -- Clear -- - ----------- - - procedure Clear (HT : in out Hash_Table_Type'Class) is - begin - TC_Check (HT.TC); - - HT.Length := 0; - -- HT.Busy := 0; - -- HT.Lock := 0; - HT.Free := -1; - HT.Buckets := (others => 0); -- optimize this somehow ??? - end Clear; - - -------------------------- - -- Delete_Node_At_Index -- - -------------------------- - - procedure Delete_Node_At_Index - (HT : in out Hash_Table_Type'Class; - Indx : Hash_Type; - X : Count_Type) - is - Prev : Count_Type; - Curr : Count_Type; - - begin - Prev := HT.Buckets (Indx); - - if Checks and then Prev = 0 then - raise Program_Error with - "attempt to delete node from empty hash bucket"; - end if; - - if Prev = X then - HT.Buckets (Indx) := Next (HT.Nodes (Prev)); - HT.Length := HT.Length - 1; - return; - end if; - - if Checks and then HT.Length = 1 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - loop - Curr := Next (HT.Nodes (Prev)); - - if Checks and then Curr = 0 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - Prev := Curr; - end loop; - end Delete_Node_At_Index; - - --------------------------- - -- Delete_Node_Sans_Free -- - --------------------------- - - procedure Delete_Node_Sans_Free - (HT : in out Hash_Table_Type'Class; - X : Count_Type) - is - pragma Assert (X /= 0); - - Indx : Hash_Type; - Prev : Count_Type; - Curr : Count_Type; - - begin - if Checks and then HT.Length = 0 then - raise Program_Error with - "attempt to delete node from empty hashed container"; - end if; - - Indx := Checked_Index (HT, X); - Prev := HT.Buckets (Indx); - - if Checks and then Prev = 0 then - raise Program_Error with - "attempt to delete node from empty hash bucket"; - end if; - - if Prev = X then - HT.Buckets (Indx) := Next (HT.Nodes (Prev)); - HT.Length := HT.Length - 1; - return; - end if; - - if Checks and then HT.Length = 1 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - loop - Curr := Next (HT.Nodes (Prev)); - - if Checks and then Curr = 0 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - if Curr = X then - Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr))); - HT.Length := HT.Length - 1; - return; - end if; - - Prev := Curr; - end loop; - end Delete_Node_Sans_Free; - - ----------- - -- First -- - ----------- - - function First (HT : Hash_Table_Type'Class) return Count_Type is - Indx : Hash_Type; - - begin - if HT.Length = 0 then - return 0; - end if; - - Indx := HT.Buckets'First; - loop - if HT.Buckets (Indx) /= 0 then - return HT.Buckets (Indx); - end if; - - Indx := Indx + 1; - end loop; - end First; - - ---------- - -- Free -- - ---------- - - procedure Free - (HT : in out Hash_Table_Type'Class; - X : Count_Type) - is - N : Nodes_Type renames HT.Nodes; - - begin - -- This subprogram "deallocates" a node by relinking the node off of the - -- active list and onto the free list. Previously it would flag index - -- value 0 as an error. The precondition was weakened, so that index - -- value 0 is now allowed, and this value is interpreted to mean "do - -- nothing". This makes its behavior analogous to the behavior of - -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add - -- special-case checks at the point of call. - - if X = 0 then - return; - end if; - - pragma Assert (X <= HT.Capacity); - - -- pragma Assert (N (X).Prev >= 0); -- node is active - -- Find a way to mark a node as active vs. inactive; we could - -- use a special value in Color_Type for this. ??? - - -- The hash table actually contains two data structures: a list for - -- the "active" nodes that contain elements that have been inserted - -- onto the container, and another for the "inactive" nodes of the free - -- store. - -- - -- We desire that merely declaring an object should have only minimal - -- cost; specially, we want to avoid having to initialize the free - -- store (to fill in the links), especially if the capacity is large. - -- - -- The head of the free list is indicated by Container.Free. If its - -- value is non-negative, then the free store has been initialized - -- in the "normal" way: Container.Free points to the head of the list - -- of free (inactive) nodes, and the value 0 means the free list is - -- empty. Each node on the free list has been initialized to point - -- to the next free node (via its Parent component), and the value 0 - -- means that this is the last free node. - -- - -- If Container.Free is negative, then the links on the free store - -- have not been initialized. In this case the link values are - -- implied: the free store comprises the components of the node array - -- started with the absolute value of Container.Free, and continuing - -- until the end of the array (Nodes'Last). - -- - -- ??? - -- It might be possible to perform an optimization here. Suppose that - -- the free store can be represented as having two parts: one - -- comprising the non-contiguous inactive nodes linked together - -- in the normal way, and the other comprising the contiguous - -- inactive nodes (that are not linked together, at the end of the - -- nodes array). This would allow us to never have to initialize - -- the free store, except in a lazy way as nodes become inactive. - - -- When an element is deleted from the list container, its node - -- becomes inactive, and so we set its Next component to value of - -- the node's index (in the nodes array), to indicate that it is - -- now inactive. This provides a useful way to detect a dangling - -- cursor reference. ??? - - Set_Next (N (X), Next => X); -- Node is deallocated (not on active list) - - if HT.Free >= 0 then - -- The free store has previously been initialized. All we need to - -- do here is link the newly-free'd node onto the free list. - - Set_Next (N (X), HT.Free); - HT.Free := X; - - elsif X + 1 = abs HT.Free then - -- The free store has not been initialized, and the node becoming - -- inactive immediately precedes the start of the free store. All - -- we need to do is move the start of the free store back by one. - - HT.Free := HT.Free + 1; - - else - -- The free store has not been initialized, and the node becoming - -- inactive does not immediately precede the free store. Here we - -- first initialize the free store (meaning the links are given - -- values in the traditional way), and then link the newly-free'd - -- node onto the head of the free store. - - -- ??? - -- See the comments above for an optimization opportunity. If - -- the next link for a node on the free store is negative, then - -- this means the remaining nodes on the free store are - -- physically contiguous, starting as the absolute value of - -- that index value. - - HT.Free := abs HT.Free; - - if HT.Free > HT.Capacity then - HT.Free := 0; - - else - for I in HT.Free .. HT.Capacity - 1 loop - Set_Next (Node => N (I), Next => I + 1); - end loop; - - Set_Next (Node => N (HT.Capacity), Next => 0); - end if; - - Set_Next (Node => N (X), Next => HT.Free); - HT.Free := X; - end if; - end Free; - - ---------------------- - -- Generic_Allocate -- - ---------------------- - - procedure Generic_Allocate - (HT : in out Hash_Table_Type'Class; - Node : out Count_Type) - is - N : Nodes_Type renames HT.Nodes; - - begin - if HT.Free >= 0 then - Node := HT.Free; - - -- We always perform the assignment first, before we - -- change container state, in order to defend against - -- exceptions duration assignment. - - Set_Element (N (Node)); - HT.Free := Next (N (Node)); - - else - -- A negative free store value means that the links of the nodes - -- in the free store have not been initialized. In this case, the - -- nodes are physically contiguous in the array, starting at the - -- index that is the absolute value of the Container.Free, and - -- continuing until the end of the array (Nodes'Last). - - Node := abs HT.Free; - - -- As above, we perform this assignment first, before modifying - -- any container state. - - Set_Element (N (Node)); - HT.Free := HT.Free - 1; - end if; - end Generic_Allocate; - - ------------------- - -- Generic_Equal -- - ------------------- - - function Generic_Equal - (L, R : Hash_Table_Type'Class) return Boolean - is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_L : With_Lock (L.TC'Unrestricted_Access); - Lock_R : With_Lock (R.TC'Unrestricted_Access); - - L_Index : Hash_Type; - L_Node : Count_Type; - - N : Count_Type; - - begin - if L'Address = R'Address then - return True; - end if; - - if L.Length /= R.Length then - return False; - end if; - - if L.Length = 0 then - return True; - end if; - - -- Find the first node of hash table L - - L_Index := L.Buckets'First; - loop - L_Node := L.Buckets (L_Index); - exit when L_Node /= 0; - L_Index := L_Index + 1; - end loop; - - -- For each node of hash table L, search for an equivalent node in hash - -- table R. - - N := L.Length; - loop - if not Find (HT => R, Key => L.Nodes (L_Node)) then - return False; - end if; - - N := N - 1; - - L_Node := Next (L.Nodes (L_Node)); - - if L_Node = 0 then - - -- We have exhausted the nodes in this bucket - - if N = 0 then - return True; - end if; - - -- Find the next bucket - - loop - L_Index := L_Index + 1; - L_Node := L.Buckets (L_Index); - exit when L_Node /= 0; - end loop; - end if; - end loop; - end Generic_Equal; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration (HT : Hash_Table_Type'Class) is - Node : Count_Type; - - begin - if HT.Length = 0 then - return; - end if; - - for Indx in HT.Buckets'Range loop - Node := HT.Buckets (Indx); - while Node /= 0 loop - Process (Node); - Node := Next (HT.Nodes (Node)); - end loop; - end loop; - end Generic_Iteration; - - ------------------ - -- Generic_Read -- - ------------------ - - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - HT : out Hash_Table_Type'Class) - is - N : Count_Type'Base; - - begin - Clear (HT); - - Count_Type'Base'Read (Stream, N); - - if Checks and then N < 0 then - raise Program_Error with "stream appears to be corrupt"; - end if; - - if N = 0 then - return; - end if; - - if Checks and then N > HT.Capacity then - raise Capacity_Error with "too many elements in stream"; - end if; - - for J in 1 .. N loop - declare - Node : constant Count_Type := New_Node (Stream); - Indx : constant Hash_Type := Checked_Index (HT, Node); - B : Count_Type renames HT.Buckets (Indx); - begin - Set_Next (HT.Nodes (Node), Next => B); - B := Node; - end; - - HT.Length := HT.Length + 1; - end loop; - end Generic_Read; - - ------------------- - -- Generic_Write -- - ------------------- - - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - HT : Hash_Table_Type'Class) - is - procedure Write (Node : Count_Type); - pragma Inline (Write); - - procedure Write is new Generic_Iteration (Write); - - ----------- - -- Write -- - ----------- - - procedure Write (Node : Count_Type) is - begin - Write (Stream, HT.Nodes (Node)); - end Write; - - begin - Count_Type'Base'Write (Stream, HT.Length); - Write (HT); - end Generic_Write; - - ----------- - -- Index -- - ----------- - - function Index - (Buckets : Buckets_Type; - Node : Node_Type) return Hash_Type is - begin - return Buckets'First + Hash_Node (Node) mod Buckets'Length; - end Index; - - function Index - (HT : Hash_Table_Type'Class; - Node : Node_Type) return Hash_Type is - begin - return Index (HT.Buckets, Node); - end Index; - - ---------- - -- Next -- - ---------- - - function Next - (HT : Hash_Table_Type'Class; - Node : Count_Type) return Count_Type - is - Result : Count_Type; - First : Hash_Type; - - begin - Result := Next (HT.Nodes (Node)); - - if Result /= 0 then -- another node in same bucket - return Result; - end if; - - -- This was the last node in the bucket, so move to the next - -- bucket, and start searching for next node from there. - - First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1; - for Indx in First .. HT.Buckets'Last loop - Result := HT.Buckets (Indx); - - if Result /= 0 then -- bucket is not empty - return Result; - end if; - end loop; - - return 0; - end Next; - -end Ada.Containers.Hash_Tables.Generic_Bounded_Operations; diff --git a/gcc/ada/a-chtgbo.ads b/gcc/ada/a-chtgbo.ads deleted file mode 100644 index 184cefc..0000000 --- a/gcc/ada/a-chtgbo.ads +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Hash_Table_Type is used to implement hashed containers. This package --- declares hash-table operations that do not depend on keys. - -with Ada.Streams; - -generic - with package HT_Types is - new Generic_Bounded_Hash_Table_Types (<>); - - use HT_Types, HT_Types.Implementation; - - with function Hash_Node (Node : Node_Type) return Hash_Type; - - with function Next (Node : Node_Type) return Count_Type; - - with procedure Set_Next - (Node : in out Node_Type; - Next : Count_Type); - -package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is - pragma Pure; - - function Index - (Buckets : Buckets_Type; - Node : Node_Type) return Hash_Type; - pragma Inline (Index); - -- Uses the hash value of Node to compute its Buckets array index - - function Index - (HT : Hash_Table_Type'Class; - Node : Node_Type) return Hash_Type; - pragma Inline (Index); - -- Uses the hash value of Node to compute its Hash_Table buckets array - -- index. - - function Checked_Index - (Hash_Table : aliased in out Hash_Table_Type'Class; - Node : Count_Type) return Hash_Type; - -- Calls Index, but also locks and unlocks the container, per AI05-0022, in - -- order to detect element tampering by the generic actual Hash function. - - generic - with function Find - (HT : Hash_Table_Type'Class; - Key : Node_Type) return Boolean; - function Generic_Equal (L, R : Hash_Table_Type'Class) return Boolean; - -- Used to implement hashed container equality. For each node in hash table - -- L, it calls Find to search for an equivalent item in hash table R. If - -- Find returns False for any node then Generic_Equal terminates - -- immediately and returns False. Otherwise if Find returns True for every - -- node then Generic_Equal returns True. - - procedure Clear (HT : in out Hash_Table_Type'Class); - -- Deallocates each node in hash table HT. (Note that it only deallocates - -- the nodes, not the buckets array.) Program_Error is raised if the hash - -- table is busy. - - procedure Delete_Node_At_Index - (HT : in out Hash_Table_Type'Class; - Indx : Hash_Type; - X : Count_Type); - -- Delete a node whose bucket position is known. extracted from following - -- subprogram, but also used directly to remove a node whose element has - -- been modified through a key_preserving reference: in that case we cannot - -- use the value of the element precisely because the current value does - -- not correspond to the hash code that determines its bucket. - - procedure Delete_Node_Sans_Free - (HT : in out Hash_Table_Type'Class; - X : Count_Type); - -- Removes node X from the hash table without deallocating the node - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (HT : in out Hash_Table_Type'Class; - Node : out Count_Type); - -- Claim a node from the free store. Generic_Allocate first - -- calls Set_Element on the potential node, and then returns - -- the node's index as the value of the Node parameter. - - procedure Free - (HT : in out Hash_Table_Type'Class; - X : Count_Type); - -- Return a node back to the free store, from where it had - -- been previously claimed via Generic_Allocate. - - function First (HT : Hash_Table_Type'Class) return Count_Type; - -- Returns the head of the list in the first (lowest-index) non-empty - -- bucket. - - function Next - (HT : Hash_Table_Type'Class; - Node : Count_Type) return Count_Type; - -- Returns the node that immediately follows Node. This corresponds to - -- either the next node in the same bucket, or (if Node is the last node in - -- its bucket) the head of the list in the first non-empty bucket that - -- follows. - - generic - with procedure Process (Node : Count_Type); - procedure Generic_Iteration (HT : Hash_Table_Type'Class); - -- Calls Process for each node in hash table HT - - generic - use Ada.Streams; - with procedure Write - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - HT : Hash_Table_Type'Class); - -- Used to implement the streaming attribute for hashed containers. It - -- calls Write for each node to write its value into Stream. - - generic - use Ada.Streams; - with function New_Node (Stream : not null access Root_Stream_Type'Class) - return Count_Type; - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - HT : out Hash_Table_Type'Class); - -- Used to implement the streaming attribute for hashed containers. It - -- first clears hash table HT, then populates the hash table by calling - -- New_Node for each item in Stream. - -end Ada.Containers.Hash_Tables.Generic_Bounded_Operations; diff --git a/gcc/ada/a-chtgke.adb b/gcc/ada/a-chtgke.adb deleted file mode 100644 index cab0c09..0000000 --- a/gcc/ada/a-chtgke.adb +++ /dev/null @@ -1,329 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Hash_Tables.Generic_Keys is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------------- - -- Checked_Equivalent_Keys -- - ----------------------------- - - function Checked_Equivalent_Keys - (HT : aliased in out Hash_Table_Type; - Key : Key_Type; - Node : Node_Access) return Boolean - is - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - return Equivalent_Keys (Key, Node); - end Checked_Equivalent_Keys; - - ------------------- - -- Checked_Index -- - ------------------- - - function Checked_Index - (HT : aliased in out Hash_Table_Type; - Key : Key_Type) return Hash_Type - is - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - return Hash (Key) mod HT.Buckets'Length; - end Checked_Index; - - -------------------------- - -- Delete_Key_Sans_Free -- - -------------------------- - - procedure Delete_Key_Sans_Free - (HT : in out Hash_Table_Type; - Key : Key_Type; - X : out Node_Access) - is - Indx : Hash_Type; - Prev : Node_Access; - - begin - if HT.Length = 0 then - X := null; - return; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TC_Check (HT.TC); - - Indx := Checked_Index (HT, Key); - X := HT.Buckets (Indx); - - if X = null then - return; - end if; - - if Checked_Equivalent_Keys (HT, Key, X) then - TC_Check (HT.TC); - HT.Buckets (Indx) := Next (X); - HT.Length := HT.Length - 1; - return; - end if; - - loop - Prev := X; - X := Next (Prev); - - if X = null then - return; - end if; - - if Checked_Equivalent_Keys (HT, Key, X) then - TC_Check (HT.TC); - Set_Next (Node => Prev, Next => Next (X)); - HT.Length := HT.Length - 1; - return; - end if; - end loop; - end Delete_Key_Sans_Free; - - ---------- - -- Find -- - ---------- - - function Find - (HT : aliased in out Hash_Table_Type; - Key : Key_Type) return Node_Access - is - Indx : Hash_Type; - Node : Node_Access; - - begin - if HT.Length = 0 then - return null; - end if; - - Indx := Checked_Index (HT, Key); - - Node := HT.Buckets (Indx); - while Node /= null loop - if Checked_Equivalent_Keys (HT, Key, Node) then - return Node; - end if; - Node := Next (Node); - end loop; - - return null; - end Find; - - -------------------------------- - -- Generic_Conditional_Insert -- - -------------------------------- - - procedure Generic_Conditional_Insert - (HT : in out Hash_Table_Type; - Key : Key_Type; - Node : out Node_Access; - Inserted : out Boolean) - is - Indx : Hash_Type; - - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - TC_Check (HT.TC); - - Indx := Checked_Index (HT, Key); - Node := HT.Buckets (Indx); - - if Node = null then - if Checks and then HT.Length = Count_Type'Last then - raise Constraint_Error; - end if; - - Node := New_Node (Next => null); - Inserted := True; - - HT.Buckets (Indx) := Node; - HT.Length := HT.Length + 1; - - return; - end if; - - loop - if Checked_Equivalent_Keys (HT, Key, Node) then - Inserted := False; - return; - end if; - - Node := Next (Node); - - exit when Node = null; - end loop; - - if Checks and then HT.Length = Count_Type'Last then - raise Constraint_Error; - end if; - - Node := New_Node (Next => HT.Buckets (Indx)); - Inserted := True; - - HT.Buckets (Indx) := Node; - HT.Length := HT.Length + 1; - end Generic_Conditional_Insert; - - ----------------------------- - -- Generic_Replace_Element -- - ----------------------------- - - procedure Generic_Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - Key : Key_Type) - is - pragma Assert (HT.Length > 0); - pragma Assert (Node /= null); - - Old_Indx : Hash_Type; - New_Indx : constant Hash_Type := Checked_Index (HT, Key); - - New_Bucket : Node_Access renames HT.Buckets (New_Indx); - N, M : Node_Access; - - begin - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - Old_Indx := Hash (Node) mod HT.Buckets'Length; - end; - - if Checked_Equivalent_Keys (HT, Key, Node) then - TE_Check (HT.TC); - - -- We can change a node's key to Key (that's what Assign is for), but - -- only if Key is not already in the hash table. (In a unique-key - -- hash table as this one a key is mapped to exactly one node only.) - -- The exception is when Key is mapped to Node, in which case the - -- change is allowed. - - Assign (Node, Key); - return; - end if; - - -- Key is not equivalent to Node, so we now have to determine if it's - -- equivalent to some other node in the hash table. This is the case - -- irrespective of whether Key is in the same or a different bucket from - -- Node. - - N := New_Bucket; - while N /= null loop - if Checks and then Checked_Equivalent_Keys (HT, Key, N) then - pragma Assert (N /= Node); - raise Program_Error with - "attempt to replace existing element"; - end if; - - N := Next (N); - end loop; - - -- We have determined that Key is not already in the hash table, so - -- the change is tentatively allowed. We now perform the standard - -- checks to determine whether the hash table is locked (because you - -- cannot change an element while it's in use by Query_Element or - -- Update_Element), or if the container is busy (because moving a - -- node to a different bucket would interfere with iteration). - - if Old_Indx = New_Indx then - -- The node is already in the bucket implied by Key. In this case - -- we merely change its value without moving it. - - TE_Check (HT.TC); - - Assign (Node, Key); - return; - end if; - - -- The node is a bucket different from the bucket implied by Key - - TC_Check (HT.TC); - - -- Do the assignment first, before moving the node, so that if Assign - -- propagates an exception, then the hash table will not have been - -- modified (except for any possible side-effect Assign had on Node). - - Assign (Node, Key); - - -- Now we can safely remove the node from its current bucket - - N := HT.Buckets (Old_Indx); - pragma Assert (N /= null); - - if N = Node then - HT.Buckets (Old_Indx) := Next (Node); - - else - pragma Assert (HT.Length > 1); - - loop - M := Next (N); - pragma Assert (M /= null); - - if M = Node then - Set_Next (Node => N, Next => Next (Node)); - exit; - end if; - - N := M; - end loop; - end if; - - -- Now we link the node into its new bucket (corresponding to Key) - - Set_Next (Node => Node, Next => New_Bucket); - New_Bucket := Node; - end Generic_Replace_Element; - - ----------- - -- Index -- - ----------- - - function Index - (HT : Hash_Table_Type; - Key : Key_Type) return Hash_Type - is - begin - return Hash (Key) mod HT.Buckets'Length; - end Index; - -end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgke.ads b/gcc/ada/a-chtgke.ads deleted file mode 100644 index 00b3138..0000000 --- a/gcc/ada/a-chtgke.ads +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Hash_Table_Type is used to implement hashed containers. This package --- declares hash-table operations that depend on keys. - -generic - with package HT_Types is - new Generic_Hash_Table_Types (<>); - - use HT_Types, HT_Types.Implementation; - - with function Next (Node : Node_Access) return Node_Access; - - with procedure Set_Next - (Node : Node_Access; - Next : Node_Access); - - type Key_Type (<>) is limited private; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys - (Key : Key_Type; - Node : Node_Access) return Boolean; - -package Ada.Containers.Hash_Tables.Generic_Keys is - pragma Preelaborate; - - function Index - (HT : Hash_Table_Type; - Key : Key_Type) return Hash_Type; - pragma Inline (Index); - -- Returns the bucket number (array index value) for the given key - - function Checked_Index - (HT : aliased in out Hash_Table_Type; - Key : Key_Type) return Hash_Type; - pragma Inline (Checked_Index); - -- Calls Index, but also locks and unlocks the container, per AI05-0022, in - -- order to detect element tampering by the generic actual Hash function. - - function Checked_Equivalent_Keys - (HT : aliased in out Hash_Table_Type; - Key : Key_Type; - Node : Node_Access) return Boolean; - -- Calls Equivalent_Keys, but locks and unlocks the container, per - -- AI05-0022, in order to detect element tampering by that generic actual. - - procedure Delete_Key_Sans_Free - (HT : in out Hash_Table_Type; - Key : Key_Type; - X : out Node_Access); - -- Removes the node (if any) with the given key from the hash table, - -- without deallocating it. Program_Error is raised if the hash - -- table is busy. - - function Find - (HT : aliased in out Hash_Table_Type; - Key : Key_Type) return Node_Access; - -- Returns the node (if any) corresponding to the given key - - generic - with function New_Node (Next : Node_Access) return Node_Access; - procedure Generic_Conditional_Insert - (HT : in out Hash_Table_Type; - Key : Key_Type; - Node : out Node_Access; - Inserted : out Boolean); - -- Attempts to insert a new node with the given key into the hash table. - -- If a node with that key already exists in the table, then that node - -- is returned and Inserted returns False. Otherwise New_Node is called - -- to allocate a new node, and Inserted returns True. Program_Error is - -- raised if the hash table is busy. - - generic - with function Hash (Node : Node_Access) return Hash_Type; - with procedure Assign (Node : Node_Access; Key : Key_Type); - procedure Generic_Replace_Element - (HT : in out Hash_Table_Type; - Node : Node_Access; - Key : Key_Type); - -- Assigns Key to Node, possibly changing its equivalence class. If Node - -- is in the same equivalence class as Key (that is, it's already in the - -- bucket implied by Key), then if the hash table is locked then - -- Program_Error is raised; otherwise Assign is called to assign Key to - -- Node. If Node is in a different bucket from Key, then Program_Error is - -- raised if the hash table is busy. Otherwise it Assigns Key to Node and - -- moves the Node from its current bucket to the bucket implied by Key. - -- Note that it is never proper to assign to Node a key value already - -- in the map, and so if Key is equivalent to some other node then - -- Program_Error is raised. - -end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/a-chtgop.adb b/gcc/ada/a-chtgop.adb deleted file mode 100644 index ad951e4..0000000 --- a/gcc/ada/a-chtgop.adb +++ /dev/null @@ -1,838 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Prime_Numbers; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Hash_Tables.Generic_Operations is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - type Buckets_Allocation is access all Buckets_Type; - -- Used for allocation and deallocation (see New_Buckets and Free_Buckets). - -- This is necessary because Buckets_Access has an empty storage pool. - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (HT : in out Hash_Table_Type) is - Src_Buckets : constant Buckets_Access := HT.Buckets; - N : constant Count_Type := HT.Length; - Src_Node : Node_Access; - Dst_Prev : Node_Access; - - begin - -- If the counts are nonzero, execution is technically erroneous, but - -- it seems friendly to allow things like concurrent "=" on shared - -- constants. - - Zero_Counts (HT.TC); - - HT.Buckets := null; - HT.Length := 0; - - if N = 0 then - return; - end if; - - -- Technically it isn't necessary to allocate the exact same length - -- buckets array, because our only requirement is that following - -- assignment the source and target containers compare equal (that is, - -- operator "=" returns True). We can satisfy this requirement with any - -- hash table length, but we decide here to match the length of the - -- source table. This has the benefit that when iterating, elements of - -- the target are delivered in the exact same order as for the source. - - HT.Buckets := New_Buckets (Length => Src_Buckets'Length); - - for Src_Index in Src_Buckets'Range loop - Src_Node := Src_Buckets (Src_Index); - - if Src_Node /= null then - declare - Dst_Node : constant Node_Access := Copy_Node (Src_Node); - - -- See note above - - pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index); - - begin - HT.Buckets (Src_Index) := Dst_Node; - HT.Length := HT.Length + 1; - - Dst_Prev := Dst_Node; - end; - - Src_Node := Next (Src_Node); - while Src_Node /= null loop - declare - Dst_Node : constant Node_Access := Copy_Node (Src_Node); - - -- See note above - - pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index); - - begin - Set_Next (Node => Dst_Prev, Next => Dst_Node); - HT.Length := HT.Length + 1; - - Dst_Prev := Dst_Node; - end; - - Src_Node := Next (Src_Node); - end loop; - end if; - end loop; - - pragma Assert (HT.Length = N); - end Adjust; - - -------------- - -- Capacity -- - -------------- - - function Capacity (HT : Hash_Table_Type) return Count_Type is - begin - if HT.Buckets = null then - return 0; - end if; - - return HT.Buckets'Length; - end Capacity; - - ------------------- - -- Checked_Index -- - ------------------- - - function Checked_Index - (Hash_Table : aliased in out Hash_Table_Type; - Buckets : Buckets_Type; - Node : Node_Access) return Hash_Type - is - Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); - begin - return Index (Buckets, Node); - end Checked_Index; - - function Checked_Index - (Hash_Table : aliased in out Hash_Table_Type; - Node : Node_Access) return Hash_Type - is - begin - return Checked_Index (Hash_Table, Hash_Table.Buckets.all, Node); - end Checked_Index; - - ----------- - -- Clear -- - ----------- - - procedure Clear (HT : in out Hash_Table_Type) is - Index : Hash_Type := 0; - Node : Node_Access; - - begin - TC_Check (HT.TC); - - while HT.Length > 0 loop - while HT.Buckets (Index) = null loop - Index := Index + 1; - end loop; - - declare - Bucket : Node_Access renames HT.Buckets (Index); - begin - loop - Node := Bucket; - Bucket := Next (Bucket); - HT.Length := HT.Length - 1; - Free (Node); - exit when Bucket = null; - end loop; - end; - end loop; - end Clear; - - -------------------------- - -- Delete_Node_At_Index -- - -------------------------- - - procedure Delete_Node_At_Index - (HT : in out Hash_Table_Type; - Indx : Hash_Type; - X : in out Node_Access) - is - Prev : Node_Access; - Curr : Node_Access; - - begin - Prev := HT.Buckets (Indx); - - if Prev = X then - HT.Buckets (Indx) := Next (Prev); - HT.Length := HT.Length - 1; - Free (X); - return; - end if; - - if Checks and then HT.Length = 1 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - loop - Curr := Next (Prev); - - if Checks and then Curr = null then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - if Curr = X then - Set_Next (Node => Prev, Next => Next (Curr)); - HT.Length := HT.Length - 1; - Free (X); - return; - end if; - - Prev := Curr; - end loop; - end Delete_Node_At_Index; - - --------------------------- - -- Delete_Node_Sans_Free -- - --------------------------- - - procedure Delete_Node_Sans_Free - (HT : in out Hash_Table_Type; - X : Node_Access) - is - pragma Assert (X /= null); - - Indx : Hash_Type; - Prev : Node_Access; - Curr : Node_Access; - - begin - if Checks and then HT.Length = 0 then - raise Program_Error with - "attempt to delete node from empty hashed container"; - end if; - - Indx := Checked_Index (HT, X); - Prev := HT.Buckets (Indx); - - if Checks and then Prev = null then - raise Program_Error with - "attempt to delete node from empty hash bucket"; - end if; - - if Prev = X then - HT.Buckets (Indx) := Next (Prev); - HT.Length := HT.Length - 1; - return; - end if; - - if Checks and then HT.Length = 1 then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - loop - Curr := Next (Prev); - - if Checks and then Curr = null then - raise Program_Error with - "attempt to delete node not in its proper hash bucket"; - end if; - - if Curr = X then - Set_Next (Node => Prev, Next => Next (Curr)); - HT.Length := HT.Length - 1; - return; - end if; - - Prev := Curr; - end loop; - end Delete_Node_Sans_Free; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (HT : in out Hash_Table_Type) is - begin - Clear (HT); - Free_Buckets (HT.Buckets); - end Finalize; - - ----------- - -- First -- - ----------- - - function First - (HT : Hash_Table_Type) return Node_Access - is - Dummy : Hash_Type; - begin - return First (HT, Dummy); - end First; - - function First - (HT : Hash_Table_Type; - Position : out Hash_Type) return Node_Access is - begin - if HT.Length = 0 then - Position := Hash_Type'Last; - return null; - end if; - - Position := HT.Buckets'First; - loop - if HT.Buckets (Position) /= null then - return HT.Buckets (Position); - end if; - - Position := Position + 1; - end loop; - end First; - - ------------------ - -- Free_Buckets -- - ------------------ - - procedure Free_Buckets (Buckets : in out Buckets_Access) is - procedure Free is - new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation); - - begin - -- Buckets must have been created by New_Buckets. Here, we convert back - -- to the Buckets_Allocation type, and do the free on that. - - Free (Buckets_Allocation (Buckets)); - end Free_Buckets; - - --------------------- - -- Free_Hash_Table -- - --------------------- - - procedure Free_Hash_Table (Buckets : in out Buckets_Access) is - Node : Node_Access; - - begin - if Buckets = null then - return; - end if; - - for J in Buckets'Range loop - while Buckets (J) /= null loop - Node := Buckets (J); - Buckets (J) := Next (Node); - Free (Node); - end loop; - end loop; - - Free_Buckets (Buckets); - end Free_Hash_Table; - - ------------------- - -- Generic_Equal -- - ------------------- - - function Generic_Equal - (L, R : Hash_Table_Type) return Boolean - is - begin - if L.Length /= R.Length then - return False; - end if; - - if L.Length = 0 then - return True; - end if; - - declare - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_L : With_Lock (L.TC'Unrestricted_Access); - Lock_R : With_Lock (R.TC'Unrestricted_Access); - - L_Index : Hash_Type; - L_Node : Node_Access; - - N : Count_Type; - begin - -- Find the first node of hash table L - - L_Index := 0; - loop - L_Node := L.Buckets (L_Index); - exit when L_Node /= null; - L_Index := L_Index + 1; - end loop; - - -- For each node of hash table L, search for an equivalent node in - -- hash table R. - - N := L.Length; - loop - if not Find (HT => R, Key => L_Node) then - return False; - end if; - - N := N - 1; - - L_Node := Next (L_Node); - - if L_Node = null then - -- We have exhausted the nodes in this bucket - - if N = 0 then - return True; - end if; - - -- Find the next bucket - - loop - L_Index := L_Index + 1; - L_Node := L.Buckets (L_Index); - exit when L_Node /= null; - end loop; - end if; - end loop; - end; - end Generic_Equal; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration (HT : Hash_Table_Type) is - procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type); - - ------------- - -- Wrapper -- - ------------- - - procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type) is - begin - Process (Node); - end Wrapper; - - procedure Internal_With_Pos is - new Generic_Iteration_With_Position (Wrapper); - - -- Start of processing for Generic_Iteration - - begin - Internal_With_Pos (HT); - end Generic_Iteration; - - ------------------------------------- - -- Generic_Iteration_With_Position -- - ------------------------------------- - - procedure Generic_Iteration_With_Position - (HT : Hash_Table_Type) - is - Node : Node_Access; - - begin - if HT.Length = 0 then - return; - end if; - - for Indx in HT.Buckets'Range loop - Node := HT.Buckets (Indx); - while Node /= null loop - Process (Node, Indx); - Node := Next (Node); - end loop; - end loop; - end Generic_Iteration_With_Position; - - ------------------ - -- Generic_Read -- - ------------------ - - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - HT : out Hash_Table_Type) - is - N : Count_Type'Base; - NN : Hash_Type; - - begin - Clear (HT); - - Count_Type'Base'Read (Stream, N); - - if Checks and then N < 0 then - raise Program_Error with "stream appears to be corrupt"; - end if; - - if N = 0 then - return; - end if; - - -- The RM does not specify whether or how the capacity changes when a - -- hash table is streamed in. Therefore we decide here to allocate a new - -- buckets array only when it's necessary to preserve representation - -- invariants. - - if HT.Buckets = null - or else HT.Buckets'Length < N - then - Free_Buckets (HT.Buckets); - NN := Prime_Numbers.To_Prime (N); - HT.Buckets := New_Buckets (Length => NN); - end if; - - for J in 1 .. N loop - declare - Node : constant Node_Access := New_Node (Stream); - Indx : constant Hash_Type := Checked_Index (HT, Node); - B : Node_Access renames HT.Buckets (Indx); - begin - Set_Next (Node => Node, Next => B); - B := Node; - end; - - HT.Length := HT.Length + 1; - end loop; - end Generic_Read; - - ------------------- - -- Generic_Write -- - ------------------- - - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - HT : Hash_Table_Type) - is - procedure Write (Node : Node_Access); - pragma Inline (Write); - - procedure Write is new Generic_Iteration (Write); - - ----------- - -- Write -- - ----------- - - procedure Write (Node : Node_Access) is - begin - Write (Stream, Node); - end Write; - - begin - -- See Generic_Read for an explanation of why we do not stream out the - -- buckets array length too. - - Count_Type'Base'Write (Stream, HT.Length); - Write (HT); - end Generic_Write; - - ----------- - -- Index -- - ----------- - - function Index - (Buckets : Buckets_Type; - Node : Node_Access) return Hash_Type is - begin - return Hash_Node (Node) mod Buckets'Length; - end Index; - - function Index - (Hash_Table : Hash_Table_Type; - Node : Node_Access) return Hash_Type is - begin - return Index (Hash_Table.Buckets.all, Node); - end Index; - - ---------- - -- Move -- - ---------- - - procedure Move (Target, Source : in out Hash_Table_Type) is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Clear (Target); - - declare - Buckets : constant Buckets_Access := Target.Buckets; - begin - Target.Buckets := Source.Buckets; - Source.Buckets := Buckets; - end; - - Target.Length := Source.Length; - Source.Length := 0; - end Move; - - ----------------- - -- New_Buckets -- - ----------------- - - function New_Buckets (Length : Hash_Type) return Buckets_Access is - subtype Rng is Hash_Type range 0 .. Length - 1; - - begin - -- Allocate in Buckets_Allocation'Storage_Pool, then convert to - -- Buckets_Access. - - return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng))); - end New_Buckets; - - ---------- - -- Next -- - ---------- - - function Next - (HT : aliased in out Hash_Table_Type; - Node : Node_Access; - Position : in out Hash_Type) return Node_Access - is - Result : Node_Access; - First : Hash_Type; - - begin - -- First, check if the node has other nodes chained to it - Result := Next (Node); - - if Result /= null then - return Result; - end if; - - -- Check if we were supplied a position for Node, from which we - -- can start iteration on the buckets. - - if Position /= Hash_Type'Last then - First := Position + 1; - else - First := Checked_Index (HT, Node) + 1; - end if; - - for Indx in First .. HT.Buckets'Last loop - Result := HT.Buckets (Indx); - - if Result /= null then - Position := Indx; - return Result; - end if; - end loop; - - return null; - end Next; - - function Next - (HT : aliased in out Hash_Table_Type; - Node : Node_Access) return Node_Access - is - Pos : Hash_Type := Hash_Type'Last; - begin - return Next (HT, Node, Pos); - end Next; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (HT : in out Hash_Table_Type; - N : Count_Type) - is - NN : Hash_Type; - - begin - if HT.Buckets = null then - if N > 0 then - NN := Prime_Numbers.To_Prime (N); - HT.Buckets := New_Buckets (Length => NN); - end if; - - return; - end if; - - if HT.Length = 0 then - - -- This is the easy case. There are no nodes, so no rehashing is - -- necessary. All we need to do is allocate a new buckets array - -- having a length implied by the specified capacity. (We say - -- "implied by" because bucket arrays are always allocated with a - -- length that corresponds to a prime number.) - - if N = 0 then - Free_Buckets (HT.Buckets); - return; - end if; - - if N = HT.Buckets'Length then - return; - end if; - - NN := Prime_Numbers.To_Prime (N); - - if NN = HT.Buckets'Length then - return; - end if; - - declare - X : Buckets_Access := HT.Buckets; - pragma Warnings (Off, X); - begin - HT.Buckets := New_Buckets (Length => NN); - Free_Buckets (X); - end; - - return; - end if; - - if N = HT.Buckets'Length then - return; - end if; - - if N < HT.Buckets'Length then - - -- This is a request to contract the buckets array. The amount of - -- contraction is bounded in order to preserve the invariant that the - -- buckets array length is never smaller than the number of elements - -- (the load factor is 1). - - if HT.Length >= HT.Buckets'Length then - return; - end if; - - NN := Prime_Numbers.To_Prime (HT.Length); - - if NN >= HT.Buckets'Length then - return; - end if; - - else - NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length)); - - if NN = HT.Buckets'Length then -- can't expand any more - return; - end if; - end if; - - TC_Check (HT.TC); - - Rehash : declare - Dst_Buckets : Buckets_Access := New_Buckets (Length => NN); - Src_Buckets : Buckets_Access := HT.Buckets; - pragma Warnings (Off, Src_Buckets); - - L : Count_Type renames HT.Length; - LL : constant Count_Type := L; - - Src_Index : Hash_Type := Src_Buckets'First; - - begin - while L > 0 loop - declare - Src_Bucket : Node_Access renames Src_Buckets (Src_Index); - - begin - while Src_Bucket /= null loop - declare - Src_Node : constant Node_Access := Src_Bucket; - - Dst_Index : constant Hash_Type := - Checked_Index (HT, Dst_Buckets.all, Src_Node); - - Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); - - begin - Src_Bucket := Next (Src_Node); - - Set_Next (Src_Node, Dst_Bucket); - - Dst_Bucket := Src_Node; - end; - - pragma Assert (L > 0); - L := L - 1; - end loop; - - exception - when others => - - -- If there's an error computing a hash value during a - -- rehash, then AI-302 says the nodes "become lost." The - -- issue is whether to actually deallocate these lost nodes, - -- since they might be designated by extant cursors. Here - -- we decide to deallocate the nodes, since it's better to - -- solve real problems (storage consumption) rather than - -- imaginary ones (the user might, or might not, dereference - -- a cursor designating a node that has been deallocated), - -- and because we have a way to vet a dangling cursor - -- reference anyway, and hence can actually detect the - -- problem. - - for Dst_Index in Dst_Buckets'Range loop - declare - B : Node_Access renames Dst_Buckets (Dst_Index); - X : Node_Access; - begin - while B /= null loop - X := B; - B := Next (X); - Free (X); - end loop; - end; - end loop; - - Free_Buckets (Dst_Buckets); - raise Program_Error with - "hash function raised exception during rehash"; - end; - - Src_Index := Src_Index + 1; - end loop; - - HT.Buckets := Dst_Buckets; - HT.Length := LL; - - Free_Buckets (Src_Buckets); - end Rehash; - end Reserve_Capacity; - -end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/a-chtgop.ads b/gcc/ada/a-chtgop.ads deleted file mode 100644 index ea2209b..0000000 --- a/gcc/ada/a-chtgop.ads +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Hash_Table_Type is used to implement hashed containers. This package --- declares hash-table operations that do not depend on keys. - -with Ada.Streams; - -generic - - with package HT_Types is - new Generic_Hash_Table_Types (<>); - - use HT_Types, HT_Types.Implementation; - - with function Hash_Node (Node : Node_Access) return Hash_Type; - - with function Next (Node : Node_Access) return Node_Access; - - with procedure Set_Next - (Node : Node_Access; - Next : Node_Access); - - with function Copy_Node (Source : Node_Access) return Node_Access; - - with procedure Free (X : in out Node_Access); - -package Ada.Containers.Hash_Tables.Generic_Operations is - pragma Preelaborate; - - procedure Free_Hash_Table (Buckets : in out Buckets_Access); - -- First frees the nodes in all non-null buckets of Buckets, and then frees - -- the Buckets array itself. - - function Index - (Buckets : Buckets_Type; - Node : Node_Access) return Hash_Type; - pragma Inline (Index); - -- Uses the hash value of Node to compute its Buckets array index - - function Index - (Hash_Table : Hash_Table_Type; - Node : Node_Access) return Hash_Type; - pragma Inline (Index); - -- Uses the hash value of Node to compute its Hash_Table buckets array - -- index. - - function Checked_Index - (Hash_Table : aliased in out Hash_Table_Type; - Buckets : Buckets_Type; - Node : Node_Access) return Hash_Type; - -- Calls Index, but also locks and unlocks the container, per AI05-0022, in - -- order to detect element tampering by the generic actual Hash function. - - function Checked_Index - (Hash_Table : aliased in out Hash_Table_Type; - Node : Node_Access) return Hash_Type; - -- Calls Checked_Index using Hash_Table's buckets array. - - procedure Adjust (HT : in out Hash_Table_Type); - -- Used to implement controlled Adjust. It is assumed that HT has the value - -- of the bit-wise copy that immediately follows controlled Finalize. - -- Adjust first allocates a new buckets array for HT (having the same - -- length as the source), and then allocates a copy of each node of source. - - procedure Finalize (HT : in out Hash_Table_Type); - -- Used to implement controlled Finalize. It first calls Clear to - -- deallocate any remaining nodes, and then deallocates the buckets array. - - generic - with function Find - (HT : Hash_Table_Type; - Key : Node_Access) return Boolean; - function Generic_Equal - (L, R : Hash_Table_Type) return Boolean; - -- Used to implement hashed container equality. For each node in hash table - -- L, it calls Find to search for an equivalent item in hash table R. If - -- Find returns False for any node then Generic_Equal terminates - -- immediately and returns False. Otherwise if Find returns True for every - -- node then Generic_Equal returns True. - - procedure Clear (HT : in out Hash_Table_Type); - -- Deallocates each node in hash table HT. (Note that it only deallocates - -- the nodes, not the buckets array.) Program_Error is raised if the hash - -- table is busy. - - procedure Move (Target, Source : in out Hash_Table_Type); - -- Moves (not copies) the buckets array and nodes from Source to - -- Target. Program_Error is raised if Source is busy. The Target is first - -- cleared to deallocate its nodes (implying that Program_Error is also - -- raised if Target is busy). Source is empty following the move. - - function Capacity (HT : Hash_Table_Type) return Count_Type; - -- Returns the length of the buckets array - - procedure Reserve_Capacity - (HT : in out Hash_Table_Type; - N : Count_Type); - -- If N is greater than the current capacity, then it expands the buckets - -- array to at least the value N. If N is less than the current capacity, - -- then it contracts the buckets array. In either case existing nodes are - -- rehashed onto the new buckets array, and the old buckets array is - -- deallocated. Program_Error is raised if the hash table is busy. - - procedure Delete_Node_At_Index - (HT : in out Hash_Table_Type; - Indx : Hash_Type; - X : in out Node_Access); - -- Delete a node whose bucket position is known. Used to remove a node - -- whose element has been modified through a key_preserving reference. - -- We cannot use the value of the element precisely because the current - -- value does not correspond to the hash code that determines the bucket. - - procedure Delete_Node_Sans_Free - (HT : in out Hash_Table_Type; - X : Node_Access); - -- Removes node X from the hash table without deallocating the node - - function First - (HT : Hash_Table_Type) return Node_Access; - function First - (HT : Hash_Table_Type; - Position : out Hash_Type) return Node_Access; - -- Returns the head of the list in the first (lowest-index) non-empty - -- bucket. Position will be the index of the bucket of the first node. - -- It is provided so that clients can implement efficient iterators. - - function Next - (HT : aliased in out Hash_Table_Type; - Node : Node_Access) return Node_Access; - function Next - (HT : aliased in out Hash_Table_Type; - Node : Node_Access; - Position : in out Hash_Type) return Node_Access; - -- Returns the node that immediately follows Node. This corresponds to - -- either the next node in the same bucket, or (if Node is the last node in - -- its bucket) the head of the list in the first non-empty bucket that - -- follows. - -- - -- If Node_Position is supplied, then it will be used as a starting point - -- for iteration (Node_Position must be the index of Node's buckets). If it - -- is not supplied, it will be recomputed. It is provided so that clients - -- can implement efficient iterators. - - generic - with procedure Process (Node : Node_Access; Position : Hash_Type); - procedure Generic_Iteration_With_Position (HT : Hash_Table_Type); - -- Calls Process for each node in hash table HT - - generic - with procedure Process (Node : Node_Access); - procedure Generic_Iteration (HT : Hash_Table_Type); - -- Calls Process for each node in hash table HT - - generic - use Ada.Streams; - with procedure Write - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - HT : Hash_Table_Type); - -- Used to implement the streaming attribute for hashed containers. It - -- calls Write for each node to write its value into Stream. - - generic - use Ada.Streams; - with function New_Node - (Stream : not null access Root_Stream_Type'Class) - return Node_Access; - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - HT : out Hash_Table_Type); - -- Used to implement the streaming attribute for hashed containers. It - -- first clears hash table HT, then populates the hash table by calling - -- New_Node for each item in Stream. - - function New_Buckets (Length : Hash_Type) return Buckets_Access; - pragma Inline (New_Buckets); - -- Allocate a new Buckets_Type array with bounds 0 .. Length - 1 - - procedure Free_Buckets (Buckets : in out Buckets_Access); - pragma Inline (Free_Buckets); - -- Unchecked_Deallocate Buckets - - -- Note: New_Buckets and Free_Buckets are needed because Buckets_Access has - -- an empty pool. - -end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/a-chzla1.ads b/gcc/ada/a-chzla1.ads deleted file mode 100644 index cd360d4..0000000 --- a/gcc/ada/a-chzla1.ads +++ /dev/null @@ -1,376 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides definitions analogous to those in the RM defined --- package Ada.Characters.Latin_1 except that the type of the constants --- is Wide_Wide_Character instead of Character. The provision of this package --- is in accordance with the implementation permission in RM (A.3.3(27)). - -package Ada.Characters.Wide_Wide_Latin_1 is - pragma Pure; - - ------------------------ - -- Control Characters -- - ------------------------ - - NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0); - SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1); - STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2); - ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3); - EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4); - ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5); - ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6); - BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7); - BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8); - HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9); - LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10); - VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11); - FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12); - CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13); - SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14); - SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15); - - DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16); - DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17); - DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18); - DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19); - DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20); - NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21); - SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22); - ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23); - CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24); - EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25); - SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26); - ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27); - FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28); - GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29); - RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30); - US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31); - - ------------------------------------- - -- ISO 646 Graphic Wide_Wide_Characters -- - ------------------------------------- - - Space : constant Wide_Wide_Character := ' '; -- WC'Val(32) - Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33) - Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34) - Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35) - Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36) - Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37) - Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38) - Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39) - Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40) - Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41) - Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42) - Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43) - Comma : constant Wide_Wide_Character := ','; -- WC'Val(44) - Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45) - Minus_Sign : Wide_Wide_Character renames Hyphen; - Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46) - Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47) - - -- Decimal digits '0' though '9' are at positions 48 through 57 - - Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58) - Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59) - Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60) - Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61) - Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62) - Question : constant Wide_Wide_Character := '?'; -- WC'Val(63) - - Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64) - - -- Letters 'A' through 'Z' are at positions 65 through 90 - - Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91) - Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92) - Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93) - Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94) - Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95) - - Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96) - LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97) - LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98) - LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99) - LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100) - LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101) - LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102) - LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103) - LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104) - LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105) - LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106) - LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107) - LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108) - LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109) - LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110) - LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111) - LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112) - LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113) - LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114) - LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115) - LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116) - LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117) - LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118) - LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119) - LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120) - LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121) - LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122) - Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123) - Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124) - Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125) - Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126) - DEL : constant Wide_Wide_Character := - Wide_Wide_Character'Val (127); - - -------------------------------------- - -- ISO 6429 Control Wide_Wide_Characters -- - -------------------------------------- - - IS4 : Wide_Wide_Character renames FS; - IS3 : Wide_Wide_Character renames GS; - IS2 : Wide_Wide_Character renames RS; - IS1 : Wide_Wide_Character renames US; - - Reserved_128 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (128); - Reserved_129 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (129); - BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130); - NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131); - Reserved_132 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (132); - NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133); - SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134); - ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135); - HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136); - HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137); - VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138); - PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139); - PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140); - RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141); - SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142); - SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143); - - DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144); - PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145); - PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146); - STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147); - CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148); - MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149); - SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150); - EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151); - - SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152); - Reserved_153 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (153); - SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154); - CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155); - ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156); - OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157); - PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158); - APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159); - - ----------------------------------- - -- Other Graphic Wide_Wide_Characters -- - ----------------------------------- - - -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) - - No_Break_Space - : constant Wide_Wide_Character := Wide_Wide_Character'Val (160); - NBSP : Wide_Wide_Character renames No_Break_Space; - Inverted_Exclamation - : constant Wide_Wide_Character := Wide_Wide_Character'Val (161); - Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162); - Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163); - Currency_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (164); - Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165); - Broken_Bar : constant Wide_Wide_Character := Wide_Wide_Character'Val (166); - Section_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (167); - Diaeresis : constant Wide_Wide_Character := Wide_Wide_Character'Val (168); - Copyright_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (169); - Feminine_Ordinal_Indicator - : constant Wide_Wide_Character := Wide_Wide_Character'Val (170); - Left_Angle_Quotation - : constant Wide_Wide_Character := Wide_Wide_Character'Val (171); - Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172); - Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173); - Registered_Trade_Mark_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (174); - Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175); - - -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) - - Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176); - Ring_Above : Wide_Wide_Character renames Degree_Sign; - Plus_Minus_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (177); - Superscript_Two - : constant Wide_Wide_Character := Wide_Wide_Character'Val (178); - Superscript_Three - : constant Wide_Wide_Character := Wide_Wide_Character'Val (179); - Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (180); - Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181); - Pilcrow_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (182); - Paragraph_Sign - : Wide_Wide_Character renames Pilcrow_Sign; - Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183); - Cedilla : constant Wide_Wide_Character := Wide_Wide_Character'Val (184); - Superscript_One - : constant Wide_Wide_Character := Wide_Wide_Character'Val (185); - Masculine_Ordinal_Indicator - : constant Wide_Wide_Character := Wide_Wide_Character'Val (186); - Right_Angle_Quotation - : constant Wide_Wide_Character := Wide_Wide_Character'Val (187); - Fraction_One_Quarter - : constant Wide_Wide_Character := Wide_Wide_Character'Val (188); - Fraction_One_Half - : constant Wide_Wide_Character := Wide_Wide_Character'Val (189); - Fraction_Three_Quarters - : constant Wide_Wide_Character := Wide_Wide_Character'Val (190); - Inverted_Question - : constant Wide_Wide_Character := Wide_Wide_Character'Val (191); - - -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) - - UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192); - UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193); - UC_A_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (194); - UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195); - UC_A_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (196); - UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197); - UC_AE_Diphthong - : constant Wide_Wide_Character := Wide_Wide_Character'Val (198); - UC_C_Cedilla - : constant Wide_Wide_Character := Wide_Wide_Character'Val (199); - UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200); - UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201); - UC_E_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (202); - UC_E_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (203); - UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204); - UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205); - UC_I_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (206); - UC_I_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (207); - - -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) - - UC_Icelandic_Eth - : constant Wide_Wide_Character := Wide_Wide_Character'Val (208); - UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209); - UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210); - UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211); - UC_O_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (212); - UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213); - UC_O_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (214); - Multiplication_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (215); - UC_O_Oblique_Stroke - : constant Wide_Wide_Character := Wide_Wide_Character'Val (216); - UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217); - UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218); - UC_U_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (219); - UC_U_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (220); - UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221); - UC_Icelandic_Thorn - : constant Wide_Wide_Character := Wide_Wide_Character'Val (222); - LC_German_Sharp_S - : constant Wide_Wide_Character := Wide_Wide_Character'Val (223); - - -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) - - LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224); - LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225); - LC_A_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (226); - LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227); - LC_A_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (228); - LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229); - LC_AE_Diphthong - : constant Wide_Wide_Character := Wide_Wide_Character'Val (230); - LC_C_Cedilla - : constant Wide_Wide_Character := Wide_Wide_Character'Val (231); - LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232); - LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233); - LC_E_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (234); - LC_E_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (235); - LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236); - LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237); - LC_I_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (238); - LC_I_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (239); - - -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF) - - LC_Icelandic_Eth - : constant Wide_Wide_Character := Wide_Wide_Character'Val (240); - LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241); - LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242); - LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243); - LC_O_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (244); - LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245); - LC_O_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (246); - Division_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (247); - LC_O_Oblique_Stroke - : constant Wide_Wide_Character := Wide_Wide_Character'Val (248); - LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249); - LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250); - LC_U_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (251); - LC_U_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (252); - LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253); - LC_Icelandic_Thorn - : constant Wide_Wide_Character := Wide_Wide_Character'Val (254); - LC_Y_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (255); - -end Ada.Characters.Wide_Wide_Latin_1; diff --git a/gcc/ada/a-chzla9.ads b/gcc/ada/a-chzla9.ads deleted file mode 100644 index 89a7d63..0000000 --- a/gcc/ada/a-chzla9.ads +++ /dev/null @@ -1,388 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides definitions analogous to those in the GNAT package --- Ada.Characters.Latin_9 except that the type of the various constants is --- Wide_Wide_Character instead of Character. The provision of this package --- is in accordance with the implementation permission in RM (A.3.3(27)). - -package Ada.Characters.Wide_Wide_Latin_9 is - pragma Pure; - - ------------------------ - -- Control Characters -- - ------------------------ - - NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0); - SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1); - STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2); - ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3); - EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4); - ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5); - ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6); - BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7); - BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8); - HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9); - LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10); - VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11); - FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12); - CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13); - SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14); - SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15); - - DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16); - DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17); - DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18); - DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19); - DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20); - NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21); - SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22); - ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23); - CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24); - EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25); - SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26); - ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27); - FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28); - GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29); - RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30); - US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31); - - ------------------------------------- - -- ISO 646 Graphic Wide_Wide_Characters -- - ------------------------------------- - - Space : constant Wide_Wide_Character := ' '; -- WC'Val(32) - Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33) - Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34) - Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35) - Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36) - Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37) - Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38) - Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39) - Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40) - Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41) - Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42) - Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43) - Comma : constant Wide_Wide_Character := ','; -- WC'Val(44) - Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45) - Minus_Sign : Wide_Wide_Character renames Hyphen; - Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46) - Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47) - - -- Decimal digits '0' though '9' are at positions 48 through 57 - - Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58) - Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59) - Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60) - Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61) - Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62) - Question : constant Wide_Wide_Character := '?'; -- WC'Val(63) - - Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64) - - -- Letters 'A' through 'Z' are at positions 65 through 90 - - Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91) - Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92) - Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93) - Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94) - Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95) - - Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96) - LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97) - LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98) - LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99) - LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100) - LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101) - LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102) - LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103) - LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104) - LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105) - LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106) - LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107) - LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108) - LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109) - LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110) - LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111) - LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112) - LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113) - LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114) - LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115) - LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116) - LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117) - LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118) - LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119) - LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120) - LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121) - LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122) - Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123) - Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124) - Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125) - Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126) - DEL : constant Wide_Wide_Character := - Wide_Wide_Character'Val (127); - - -------------------------------------- - -- ISO 6429 Control Wide_Wide_Characters -- - -------------------------------------- - - IS4 : Wide_Wide_Character renames FS; - IS3 : Wide_Wide_Character renames GS; - IS2 : Wide_Wide_Character renames RS; - IS1 : Wide_Wide_Character renames US; - - Reserved_128 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (128); - Reserved_129 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (129); - BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130); - NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131); - Reserved_132 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (132); - NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133); - SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134); - ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135); - HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136); - HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137); - VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138); - PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139); - PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140); - RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141); - SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142); - SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143); - - DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144); - PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145); - PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146); - STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147); - CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148); - MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149); - SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150); - EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151); - - SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152); - Reserved_153 - : constant Wide_Wide_Character := Wide_Wide_Character'Val (153); - SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154); - CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155); - ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156); - OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157); - PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158); - APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159); - - ----------------------------------- - -- Other Graphic Wide_Wide_Characters -- - ----------------------------------- - - -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) - - No_Break_Space - : constant Wide_Wide_Character := Wide_Wide_Character'Val (160); - NBSP : Wide_Wide_Character renames No_Break_Space; - Inverted_Exclamation - : constant Wide_Wide_Character := Wide_Wide_Character'Val (161); - Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162); - Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163); - Euro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (164); - Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165); - UC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (166); - Section_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (167); - LC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (168); - Copyright_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (169); - Feminine_Ordinal_Indicator - : constant Wide_Wide_Character := Wide_Wide_Character'Val (170); - Left_Angle_Quotation - : constant Wide_Wide_Character := Wide_Wide_Character'Val (171); - Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172); - Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173); - Registered_Trade_Mark_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (174); - Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175); - - -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) - - Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176); - Ring_Above : Wide_Wide_Character renames Degree_Sign; - Plus_Minus_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (177); - Superscript_Two - : constant Wide_Wide_Character := Wide_Wide_Character'Val (178); - Superscript_Three - : constant Wide_Wide_Character := Wide_Wide_Character'Val (179); - UC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (180); - Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181); - Pilcrow_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (182); - Paragraph_Sign - : Wide_Wide_Character renames Pilcrow_Sign; - Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183); - LC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (184); - Superscript_One - : constant Wide_Wide_Character := Wide_Wide_Character'Val (185); - Masculine_Ordinal_Indicator - : constant Wide_Wide_Character := Wide_Wide_Character'Val (186); - Right_Angle_Quotation - : constant Wide_Wide_Character := Wide_Wide_Character'Val (187); - UC_Ligature_OE - : constant Wide_Wide_Character := Wide_Wide_Character'Val (188); - LC_Ligature_OE - : constant Wide_Wide_Character := Wide_Wide_Character'Val (189); - UC_Y_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (190); - Inverted_Question - : constant Wide_Wide_Character := Wide_Wide_Character'Val (191); - - -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) - - UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192); - UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193); - UC_A_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (194); - UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195); - UC_A_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (196); - UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197); - UC_AE_Diphthong - : constant Wide_Wide_Character := Wide_Wide_Character'Val (198); - UC_C_Cedilla - : constant Wide_Wide_Character := Wide_Wide_Character'Val (199); - UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200); - UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201); - UC_E_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (202); - UC_E_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (203); - UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204); - UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205); - UC_I_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (206); - UC_I_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (207); - - -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) - - UC_Icelandic_Eth - : constant Wide_Wide_Character := Wide_Wide_Character'Val (208); - UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209); - UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210); - UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211); - UC_O_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (212); - UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213); - UC_O_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (214); - Multiplication_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (215); - UC_O_Oblique_Stroke - : constant Wide_Wide_Character := Wide_Wide_Character'Val (216); - UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217); - UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218); - UC_U_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (219); - UC_U_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (220); - UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221); - UC_Icelandic_Thorn - : constant Wide_Wide_Character := Wide_Wide_Character'Val (222); - LC_German_Sharp_S - : constant Wide_Wide_Character := Wide_Wide_Character'Val (223); - - -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) - - LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224); - LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225); - LC_A_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (226); - LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227); - LC_A_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (228); - LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229); - LC_AE_Diphthong - : constant Wide_Wide_Character := Wide_Wide_Character'Val (230); - LC_C_Cedilla - : constant Wide_Wide_Character := Wide_Wide_Character'Val (231); - LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232); - LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233); - LC_E_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (234); - LC_E_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (235); - LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236); - LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237); - LC_I_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (238); - LC_I_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (239); - - -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF) - - LC_Icelandic_Eth - : constant Wide_Wide_Character := Wide_Wide_Character'Val (240); - LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241); - LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242); - LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243); - LC_O_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (244); - LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245); - LC_O_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (246); - Division_Sign - : constant Wide_Wide_Character := Wide_Wide_Character'Val (247); - LC_O_Oblique_Stroke - : constant Wide_Wide_Character := Wide_Wide_Character'Val (248); - LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249); - LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250); - LC_U_Circumflex - : constant Wide_Wide_Character := Wide_Wide_Character'Val (251); - LC_U_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (252); - LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253); - LC_Icelandic_Thorn - : constant Wide_Wide_Character := Wide_Wide_Character'Val (254); - LC_Y_Diaeresis - : constant Wide_Wide_Character := Wide_Wide_Character'Val (255); - - ------------------------------------------------ - -- Summary of Changes from Latin-1 => Latin-9 -- - ------------------------------------------------ - - -- 164 Currency => Euro_Sign - -- 166 Broken_Bar => UC_S_Caron - -- 168 Diaeresis => LC_S_Caron - -- 180 Acute => UC_Z_Caron - -- 184 Cedilla => LC_Z_Caron - -- 188 Fraction_One_Quarter => UC_Ligature_OE - -- 189 Fraction_One_Half => LC_Ligature_OE - -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis - -end Ada.Characters.Wide_Wide_Latin_9; diff --git a/gcc/ada/a-cidlli.adb b/gcc/ada/a-cidlli.adb deleted file mode 100644 index 58c1e93..0000000 --- a/gcc/ada/a-cidlli.adb +++ /dev/null @@ -1,2290 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Doubly_Linked_Lists is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Free (X : in out Node_Access); - - procedure Insert_Internal - (Container : in out List; - Before : Node_Access; - New_Node : Node_Access); - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; - Source : in out List); - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; - Source : in out List; - Position : Node_Access); - - function Vet (Position : Cursor) return Boolean; - -- Checks invariants of the cursor and its designated container, as a - -- simple way of detecting dangling references (see operation Free for a - -- description of the detection mechanism), returning True if all checks - -- pass. Invocations of Vet are used here as the argument of pragma Assert, - -- so the checks are performed only when assertions are enabled. - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : List) return Boolean is - begin - if Left.Length /= Right.Length then - return False; - end if; - - if Left.Length = 0 then - return True; - end if; - - declare - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L : Node_Access := Left.First; - R : Node_Access := Right.First; - begin - for J in 1 .. Left.Length loop - if L.Element.all /= R.Element.all then - return False; - end if; - - L := L.Next; - R := R.Next; - end loop; - end; - - return True; - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out List) is - Src : Node_Access := Container.First; - Dst : Node_Access; - - begin - -- If the counts are nonzero, execution is technically erroneous, but - -- it seems friendly to allow things like concurrent "=" on shared - -- constants. - - Zero_Counts (Container.TC); - - if Src = null then - pragma Assert (Container.Last = null); - pragma Assert (Container.Length = 0); - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - pragma Assert (Container.Length > 0); - - Container.First := null; - Container.Last := null; - Container.Length := 0; - - declare - Element : Element_Access := new Element_Type'(Src.Element.all); - begin - Dst := new Node_Type'(Element, null, null); - exception - when others => - Free (Element); - raise; - end; - - Container.First := Dst; - Container.Last := Dst; - Container.Length := 1; - - Src := Src.Next; - while Src /= null loop - declare - Element : Element_Access := new Element_Type'(Src.Element.all); - begin - Dst := new Node_Type'(Element, null, Prev => Container.Last); - exception - when others => - Free (Element); - raise; - end; - - Container.Last.Next := Dst; - Container.Last := Dst; - Container.Length := Container.Length + 1; - - Src := Src.Next; - end loop; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, No_Element, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out List; Source : List) is - Node : Node_Access; - - begin - if Target'Address = Source'Address then - return; - - else - Target.Clear; - - Node := Source.First; - while Node /= null loop - Target.Append (Node.Element.all); - Node := Node.Next; - end loop; - end if; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - X : Node_Access; - pragma Warnings (Off, X); - - begin - if Container.Length = 0 then - pragma Assert (Container.First = null); - pragma Assert (Container.Last = null); - pragma Assert (Container.TC = (Busy => 0, Lock => 0)); - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - TC_Check (Container.TC); - - while Container.Length > 1 loop - X := Container.First; - pragma Assert (X.Next.Prev = Container.First); - - Container.First := X.Next; - Container.First.Prev := null; - - Container.Length := Container.Length - 1; - - Free (X); - end loop; - - X := Container.First; - pragma Assert (X = Container.Last); - - Container.First := null; - Container.Last := null; - Container.Length := 0; - - Free (X); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : List; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : List) return List is - begin - return Target : List do - Target.Assign (Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1) - is - X : Node_Access; - - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; -- Post-York behavior - return; - end if; - - if Count = 0 then - Position := No_Element; -- Post-York behavior - return; - end if; - - TC_Check (Container.TC); - - for Index in 1 .. Count loop - X := Position.Node; - Container.Length := Container.Length - 1; - - if X = Container.Last then - Position := No_Element; - - Container.Last := X.Prev; - Container.Last.Next := null; - - Free (X); - return; - end if; - - Position.Node := X.Next; - - X.Next.Prev := X.Prev; - X.Prev.Next := X.Next; - - Free (X); - end loop; - - -- Fix this junk comment ??? - - Position := No_Element; -- Post-York behavior - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1) - is - X : Node_Access; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - for J in 1 .. Count loop - X := Container.First; - pragma Assert (X.Next.Prev = Container.First); - - Container.First := X.Next; - Container.First.Prev := null; - - Container.Length := Container.Length - 1; - - Free (X); - end loop; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1) - is - X : Node_Access; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - for J in 1 .. Count loop - X := Container.Last; - pragma Assert (X.Prev.Next = Container.Last); - - Container.Last := X.Prev; - Container.Last.Next := null; - - Container.Length := Container.Length - 1; - - Free (X); - end loop; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Element"); - - return Position.Node.Element.all; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Node : Node_Access := Position.Node; - - begin - if Node = null then - Node := Container.First; - - else - if Checks and then Node.Element = null then - raise Program_Error; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Find"); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - while Node /= null loop - if Node.Element.all = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := Node.Next; - end loop; - - return No_Element; - end; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : List) return Cursor is - begin - if Container.First = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.First); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Indefinite_Doubly_Linked_Lists.First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : List) return Element_Type is - begin - if Checks and then Container.First = null then - raise Constraint_Error with "list is empty"; - end if; - - return Container.First.Element.all; - end First_Element; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - -- While a node is in use, as an active link in a list, its Previous and - -- Next components must be null, or designate a different node; this is - -- a node invariant. For this indefinite list, there is an additional - -- invariant: that the element access value be non-null. Before actually - -- deallocating the node, we set the node access value components of the - -- node to point to the node itself, and set the element access value to - -- null (by deallocating the node's element), thus falsifying the node - -- invariant. Subprogram Vet inspects the value of the node components - -- when interrogating the node, in order to detect whether the cursor's - -- node access value is dangling. - - -- Note that we have no guarantee that the storage for the node isn't - -- modified when it is deallocated, but there are other tests that Vet - -- does if node invariants appear to be satisifed. However, in practice - -- this simple test works well enough, detecting dangling references - -- immediately, without needing further interrogation. - - X.Next := X; - X.Prev := X; - - begin - Free (X.Element); - exception - when others => - X.Element := null; - Deallocate (X); - raise; - end; - - Deallocate (X); - end Free; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : List) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - - Node : Node_Access; - begin - Node := Container.First; - for J in 2 .. Container.Length loop - if Node.Next.Element.all < Node.Element.all then - return False; - end if; - - Node := Node.Next; - end loop; - - return True; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge - (Target : in out List; - Source : in out List) - is - begin - -- The semantics of Merge changed slightly per AI05-0021. It was - -- originally the case that if Target and Source denoted the same - -- container object, then the GNAT implementation of Merge did - -- nothing. However, it was argued that RM05 did not precisely - -- specify the semantics for this corner case. The decision of the - -- ARG was that if Target and Source denote the same non-empty - -- container object, then Program_Error is raised. - - if Source.Is_Empty then - return; - end if; - - if Checks and then Target'Address = Source'Address then - raise Program_Error with - "Target and Source denote same non-empty container"; - end if; - - if Checks and then Target.Length > Count_Type'Last - Source.Length - then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - declare - Lock_Target : With_Lock (Target.TC'Unchecked_Access); - Lock_Source : With_Lock (Source.TC'Unchecked_Access); - - LI, RI, RJ : Node_Access; - - begin - LI := Target.First; - RI := Source.First; - while RI /= null loop - pragma Assert (RI.Next = null - or else not (RI.Next.Element.all < - RI.Element.all)); - - if LI = null then - Splice_Internal (Target, null, Source); - exit; - end if; - - pragma Assert (LI.Next = null - or else not (LI.Next.Element.all < - LI.Element.all)); - - if RI.Element.all < LI.Element.all then - RJ := RI; - RI := RI.Next; - Splice_Internal (Target, LI, Source, RJ); - - else - LI := LI.Next; - end if; - end loop; - end; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out List) is - procedure Partition (Pivot : Node_Access; Back : Node_Access); - -- Comment ??? - - procedure Sort (Front, Back : Node_Access); - -- Comment??? Confusing name??? change name??? - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot : Node_Access; Back : Node_Access) is - Node : Node_Access; - - begin - Node := Pivot.Next; - while Node /= Back loop - if Node.Element.all < Pivot.Element.all then - declare - Prev : constant Node_Access := Node.Prev; - Next : constant Node_Access := Node.Next; - - begin - Prev.Next := Next; - - if Next = null then - Container.Last := Prev; - else - Next.Prev := Prev; - end if; - - Node.Next := Pivot; - Node.Prev := Pivot.Prev; - - Pivot.Prev := Node; - - if Node.Prev = null then - Container.First := Node; - else - Node.Prev.Next := Node; - end if; - - Node := Next; - end; - - else - Node := Node.Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Node_Access) is - Pivot : constant Node_Access := - (if Front = null then Container.First else Front.Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - TC_Check (Container.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Sort (Front => null, Back => null); - end; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - end Sort; - - end Generic_Sorting; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= null; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - First_Node : Node_Access; - New_Node : Node_Access; - - begin - if Before.Container /= null then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Before cursor designates wrong list"; - end if; - - if Checks and then - (Before.Node = null or else Before.Node.Element = null) - then - raise Program_Error with - "Before cursor has no element"; - end if; - - pragma Assert (Vet (Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - - if Checks and then Container.Length > Count_Type'Last - Count then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - TC_Check (Container.TC); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the - -- allocator in the loop below, because the one in this block would - -- have failed already. - - pragma Unsuppress (Accessibility_Check); - - Element : Element_Access := new Element_Type'(New_Item); - - begin - New_Node := new Node_Type'(Element, null, null); - First_Node := New_Node; - - exception - when others => - Free (Element); - raise; - end; - - Insert_Internal (Container, Before.Node, New_Node); - - for J in 2 .. Count loop - declare - Element : Element_Access := new Element_Type'(New_Item); - begin - New_Node := new Node_Type'(Element, null, null); - exception - when others => - Free (Element); - raise; - end; - - Insert_Internal (Container, Before.Node, New_Node); - end loop; - - Position := Cursor'(Container'Unchecked_Access, First_Node); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Position : Cursor; - pragma Unreferenced (Position); - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - --------------------- - -- Insert_Internal -- - --------------------- - - procedure Insert_Internal - (Container : in out List; - Before : Node_Access; - New_Node : Node_Access) - is - begin - if Container.Length = 0 then - pragma Assert (Before = null); - pragma Assert (Container.First = null); - pragma Assert (Container.Last = null); - - Container.First := New_Node; - Container.Last := New_Node; - - elsif Before = null then - pragma Assert (Container.Last.Next = null); - - Container.Last.Next := New_Node; - New_Node.Prev := Container.Last; - - Container.Last := New_Node; - - elsif Before = Container.First then - pragma Assert (Container.First.Prev = null); - - Container.First.Prev := New_Node; - New_Node.Next := Container.First; - - Container.First := New_Node; - - else - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - New_Node.Next := Before; - New_Node.Prev := Before.Prev; - - Before.Prev.Next := New_Node; - Before.Prev := New_Node; - end if; - - Container.Length := Container.Length + 1; - end Insert_Internal; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : List) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - Node : Node_Access := Container.First; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Next; - end loop; - end Iterate; - - function Iterate - (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a - -- complete iterator, meaning that the iteration starts from the - -- (logical) beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : List; - Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong list"; - end if; - - pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the - -- First and Last selector functions of the iterator object. When - -- the Node component is non-null (as is the case here), it means - -- that this is a partial iteration, over a subset of the complete - -- sequence of items. The iterator object was constructed with - -- a start expression, indicating the position from which the - -- iteration begins. Note that the start position has the same value - -- irrespective of whether this is a forward or reverse iteration. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : List) return Cursor is - begin - if Container.Last = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Container.Last); - end if; - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : List) return Element_Type is - begin - if Checks and then Container.Last = null then - raise Constraint_Error with "list is empty"; - end if; - - return Container.Last.Element.all; - end Last_Element; - - ------------ - -- Length -- - ------------ - - function Length (Container : List) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out List; Source : in out List) is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Clear (Target); - - Target.First := Source.First; - Source.First := null; - - Target.Last := Source.Last; - Source.Last := null; - - Target.Length := Source.Length; - Source.Length := 0; - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = null then - return No_Element; - - else - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - Next_Node : constant Node_Access := Position.Node.Next; - begin - if Next_Node = null then - return No_Element; - else - return Cursor'(Position.Container, Next_Node); - end if; - end; - end if; - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong list"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, First (Container), New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Node = null then - return No_Element; - - else - pragma Assert (Vet (Position), "bad cursor in Previous"); - - declare - Prev_Node : constant Node_Access := Position.Node.Prev; - begin - if Prev_Node = null then - return No_Element; - else - return Cursor'(Position.Container, Prev_Node); - end if; - end; - end if; - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong list"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased List'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - Lock : With_Lock (Position.Container.TC'Unrestricted_Access); - begin - Process (Position.Node.Element.all); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List) - is - N : Count_Type'Base; - Dst : Node_Access; - - begin - Clear (Item); - - Count_Type'Base'Read (Stream, N); - - if N = 0 then - return; - end if; - - declare - Element : Element_Access := - new Element_Type'(Element_Type'Input (Stream)); - begin - Dst := new Node_Type'(Element, null, null); - exception - when others => - Free (Element); - raise; - end; - - Item.First := Dst; - Item.Last := Dst; - Item.Length := 1; - - while Item.Length < N loop - declare - Element : Element_Access := - new Element_Type'(Element_Type'Input (Stream)); - begin - Dst := new Node_Type'(Element, Next => null, Prev => Item.Last); - exception - when others => - Free (Element); - raise; - end; - - Item.Last.Next := Dst; - Item.Last := Dst; - Item.Length := Item.Length + 1; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out List; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Reference"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unchecked_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - TE_Check (Container.TC); - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - X : Element_Access := Position.Node.Element; - - begin - Position.Node.Element := new Element_Type'(New_Item); - Free (X); - end; - end Replace_Element; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - I : Node_Access := Container.First; - J : Node_Access := Container.Last; - - procedure Swap (L, R : Node_Access); - - ---------- - -- Swap -- - ---------- - - procedure Swap (L, R : Node_Access) is - LN : constant Node_Access := L.Next; - LP : constant Node_Access := L.Prev; - - RN : constant Node_Access := R.Next; - RP : constant Node_Access := R.Prev; - - begin - if LP /= null then - LP.Next := R; - end if; - - if RN /= null then - RN.Prev := L; - end if; - - L.Next := RN; - R.Prev := LP; - - if LN = R then - pragma Assert (RP = L); - - L.Prev := R; - R.Next := L; - - else - L.Prev := RP; - RP.Next := L; - - R.Next := LN; - LN.Prev := R; - end if; - end Swap; - - -- Start of processing for Reverse_Elements - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - - TC_Check (Container.TC); - - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); - - J := J.Next; - exit when I = J; - - I := I.Prev; - exit when I = J; - - Swap (L => J, R => I); - - I := I.Next; - exit when I = J; - - J := J.Prev; - exit when I = J; - end loop; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Node : Node_Access := Position.Node; - - begin - if Node = null then - Node := Container.Last; - - else - if Checks and then Node.Element = null then - raise Program_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - while Node /= null loop - if Node.Element.all = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := Node.Prev; - end loop; - - return No_Element; - end; - end Reverse_Find; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - Node : Node_Access := Container.Last; - - begin - while Node /= null loop - Process (Cursor'(Container'Unrestricted_Access, Node)); - Node := Node.Prev; - end loop; - end Reverse_Iterate; - - ------------ - -- Splice -- - ------------ - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List) - is - begin - if Before.Container /= null then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - if Checks and then - (Before.Node = null or else Before.Node.Element = null) - then - raise Program_Error with - "Before cursor has no element"; - end if; - - pragma Assert (Vet (Before), "bad cursor in Splice"); - end if; - - if Target'Address = Source'Address or else Source.Length = 0 then - return; - end if; - - if Checks and then Target.Length > Count_Type'Last - Source.Length then - raise Constraint_Error with "new length exceeds maximum"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - Splice_Internal (Target, Before.Node, Source); - end Splice; - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor) - is - begin - if Before.Container /= null then - if Checks and then Before.Container /= Container'Unchecked_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - if Checks and then - (Before.Node = null or else Before.Node.Element = null) - then - raise Program_Error with - "Before cursor has no element"; - end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - end if; - - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Position.Node = Before.Node - or else Position.Node.Next = Before.Node - then - return; - end if; - - pragma Assert (Container.Length >= 2); - - TC_Check (Container.TC); - - if Before.Node = null then - pragma Assert (Position.Node /= Container.Last); - - if Position.Node = Container.First then - Container.First := Position.Node.Next; - Container.First.Prev := null; - else - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; - end if; - - Container.Last.Next := Position.Node; - Position.Node.Prev := Container.Last; - - Container.Last := Position.Node; - Container.Last.Next := null; - - return; - end if; - - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := Position.Node.Prev; - Container.Last.Next := null; - else - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; - end if; - - Container.First.Prev := Position.Node; - Position.Node.Next := Container.First; - - Container.First := Position.Node; - Container.First.Prev := null; - - return; - end if; - - if Position.Node = Container.First then - Container.First := Position.Node.Next; - Container.First.Prev := null; - - elsif Position.Node = Container.Last then - Container.Last := Position.Node.Prev; - Container.Last.Next := null; - - else - Position.Node.Prev.Next := Position.Node.Next; - Position.Node.Next.Prev := Position.Node.Prev; - end if; - - Before.Node.Prev.Next := Position.Node; - Position.Node.Prev := Before.Node.Prev; - - Before.Node.Prev := Position.Node; - Position.Node.Next := Before.Node; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - end Splice; - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor) - is - begin - if Target'Address = Source'Address then - Splice (Target, Before, Position); - return; - end if; - - if Before.Container /= null then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with - "Before cursor designates wrong container"; - end if; - - if Checks and then - (Before.Node = null or else Before.Node.Element = null) - then - raise Program_Error with - "Before cursor has no element"; - end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - end if; - - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Source'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Checks and then Target.Length = Count_Type'Last then - raise Constraint_Error with "Target is full"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - Splice_Internal (Target, Before.Node, Source, Position.Node); - Position.Container := Target'Unchecked_Access; - end Splice; - - --------------------- - -- Splice_Internal -- - --------------------- - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; - Source : in out List) - is - begin - -- This implements the corresponding Splice operation, after the - -- parameters have been vetted, and corner-cases disposed of. - - pragma Assert (Target'Address /= Source'Address); - pragma Assert (Source.Length > 0); - pragma Assert (Source.First /= null); - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last /= null); - pragma Assert (Source.Last.Next = null); - pragma Assert (Target.Length <= Count_Type'Last - Source.Length); - - if Target.Length = 0 then - pragma Assert (Before = null); - pragma Assert (Target.First = null); - pragma Assert (Target.Last = null); - - Target.First := Source.First; - Target.Last := Source.Last; - - elsif Before = null then - pragma Assert (Target.Last.Next = null); - - Target.Last.Next := Source.First; - Source.First.Prev := Target.Last; - - Target.Last := Source.Last; - - elsif Before = Target.First then - pragma Assert (Target.First.Prev = null); - - Source.Last.Next := Target.First; - Target.First.Prev := Source.Last; - - Target.First := Source.First; - - else - pragma Assert (Target.Length >= 2); - Before.Prev.Next := Source.First; - Source.First.Prev := Before.Prev; - - Before.Prev := Source.Last; - Source.Last.Next := Before; - end if; - - Source.First := null; - Source.Last := null; - - Target.Length := Target.Length + Source.Length; - Source.Length := 0; - end Splice_Internal; - - procedure Splice_Internal - (Target : in out List; - Before : Node_Access; -- node of Target - Source : in out List; - Position : Node_Access) -- node of Source - is - begin - -- This implements the corresponding Splice operation, after the - -- parameters have been vetted. - - pragma Assert (Target'Address /= Source'Address); - pragma Assert (Target.Length < Count_Type'Last); - pragma Assert (Source.Length > 0); - pragma Assert (Source.First /= null); - pragma Assert (Source.First.Prev = null); - pragma Assert (Source.Last /= null); - pragma Assert (Source.Last.Next = null); - pragma Assert (Position /= null); - - if Position = Source.First then - Source.First := Position.Next; - - if Position = Source.Last then - pragma Assert (Source.First = null); - pragma Assert (Source.Length = 1); - Source.Last := null; - - else - Source.First.Prev := null; - end if; - - elsif Position = Source.Last then - pragma Assert (Source.Length >= 2); - Source.Last := Position.Prev; - Source.Last.Next := null; - - else - pragma Assert (Source.Length >= 3); - Position.Prev.Next := Position.Next; - Position.Next.Prev := Position.Prev; - end if; - - if Target.Length = 0 then - pragma Assert (Before = null); - pragma Assert (Target.First = null); - pragma Assert (Target.Last = null); - - Target.First := Position; - Target.Last := Position; - - Target.First.Prev := null; - Target.Last.Next := null; - - elsif Before = null then - pragma Assert (Target.Last.Next = null); - Target.Last.Next := Position; - Position.Prev := Target.Last; - - Target.Last := Position; - Target.Last.Next := null; - - elsif Before = Target.First then - pragma Assert (Target.First.Prev = null); - Target.First.Prev := Position; - Position.Next := Target.First; - - Target.First := Position; - Target.First.Prev := null; - - else - pragma Assert (Target.Length >= 2); - Before.Prev.Next := Position; - Position.Prev := Before.Prev; - - Before.Prev := Position; - Position.Next := Before; - end if; - - Target.Length := Target.Length + 1; - Source.Length := Source.Length - 1; - end Splice_Internal; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out List; - I, J : Cursor) - is - begin - if Checks and then I.Node = null then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then J.Node = null then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unchecked_Access then - raise Program_Error with "I cursor designates wrong container"; - end if; - - if Checks and then J.Container /= Container'Unchecked_Access then - raise Program_Error with "J cursor designates wrong container"; - end if; - - if I.Node = J.Node then - return; - end if; - - TE_Check (Container.TC); - - pragma Assert (Vet (I), "bad I cursor in Swap"); - pragma Assert (Vet (J), "bad J cursor in Swap"); - - declare - EI_Copy : constant Element_Access := I.Node.Element; - - begin - I.Node.Element := J.Node.Element; - J.Node.Element := EI_Copy; - end; - end Swap; - - ---------------- - -- Swap_Links -- - ---------------- - - procedure Swap_Links - (Container : in out List; - I, J : Cursor) - is - begin - if Checks and then I.Node = null then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then J.Node = null then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor designates wrong container"; - end if; - - if Checks and then J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor designates wrong container"; - end if; - - if I.Node = J.Node then - return; - end if; - - TC_Check (Container.TC); - - pragma Assert (Vet (I), "bad I cursor in Swap_Links"); - pragma Assert (Vet (J), "bad J cursor in Swap_Links"); - - declare - I_Next : constant Cursor := Next (I); - - begin - if I_Next = J then - Splice (Container, Before => I, Position => J); - - else - declare - J_Next : constant Cursor := Next (J); - - begin - if J_Next = I then - Splice (Container, Before => J, Position => I); - - else - pragma Assert (Container.Length >= 3); - - Splice (Container, Before => I_Next, Position => J); - Splice (Container, Before => J_Next, Position => I); - end if; - end; - end if; - end; - - pragma Assert (Container.First.Prev = null); - pragma Assert (Container.Last.Next = null); - end Swap_Links; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unchecked_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Process (Position.Node.Element.all); - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = null then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - -- An invariant of a node is that its Previous and Next components can - -- be null, or designate a different node. Also, its element access - -- value must be non-null. Operation Free sets the node access value - -- components of the node to designate the node itself, and the element - -- access value to null, before actually deallocating the node, thus - -- deliberately violating the node invariant. This gives us a simple way - -- to detect a dangling reference to a node. - - if Position.Node.Next = Position.Node then - return False; - end if; - - if Position.Node.Prev = Position.Node then - return False; - end if; - - if Position.Node.Element = null then - return False; - end if; - - -- In practice the tests above will detect most instances of a dangling - -- reference. If we get here, it means that the invariants of the - -- designated node are satisfied (they at least appear to be satisfied), - -- so we perform some more tests, to determine whether invariants of the - -- designated list are satisfied too. - - declare - L : List renames Position.Container.all; - - begin - if L.Length = 0 then - return False; - end if; - - if L.First = null then - return False; - end if; - - if L.Last = null then - return False; - end if; - - if L.First.Prev /= null then - return False; - end if; - - if L.Last.Next /= null then - return False; - end if; - - if Position.Node.Prev = null and then Position.Node /= L.First then - return False; - end if; - - if Position.Node.Next = null and then Position.Node /= L.Last then - return False; - end if; - - if L.Length = 1 then - return L.First = L.Last; - end if; - - if L.First = L.Last then - return False; - end if; - - if L.First.Next = null then - return False; - end if; - - if L.Last.Prev = null then - return False; - end if; - - if L.First.Next.Prev /= L.First then - return False; - end if; - - if L.Last.Prev.Next /= L.Last then - return False; - end if; - - if L.Length = 2 then - if L.First.Next /= L.Last then - return False; - end if; - - if L.Last.Prev /= L.First then - return False; - end if; - - return True; - end if; - - if L.First.Next = L.Last then - return False; - end if; - - if L.Last.Prev = L.First then - return False; - end if; - - if Position.Node = L.First then - return True; - end if; - - if Position.Node = L.Last then - return True; - end if; - - if Position.Node.Next = null then - return False; - end if; - - if Position.Node.Prev = null then - return False; - end if; - - if Position.Node.Next.Prev /= Position.Node then - return False; - end if; - - if Position.Node.Prev.Next /= Position.Node then - return False; - end if; - - if L.Length = 3 then - if L.First.Next /= Position.Node then - return False; - end if; - - if L.Last.Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List) - is - Node : Node_Access := Item.First; - - begin - Count_Type'Base'Write (Stream, Item.Length); - - while Node /= null loop - Element_Type'Output (Stream, Node.Element.all); - Node := Node.Next; - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream list cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cidlli.ads b/gcc/ada/a-cidlli.ads deleted file mode 100644 index 44dc32d..0000000 --- a/gcc/ada/a-cidlli.ads +++ /dev/null @@ -1,397 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type (<>) is private; - - with function "=" (Left, Right : Element_Type) - return Boolean is <>; - -package Ada.Containers.Indefinite_Doubly_Linked_Lists is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type List is tagged private with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (List); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_List : constant List; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package List_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : List) return Boolean; - - function Length (Container : List) return Count_Type; - - function Is_Empty (Container : List) return Boolean; - - procedure Clear (Container : in out List); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased List; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out List; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out List; Source : List); - - function Copy (Source : List) return List; - - procedure Move - (Target : in out List; - Source : in out List); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1); - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1); - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1); - - procedure Reverse_Elements (Container : in out List); - - procedure Swap (Container : in out List; I, J : Cursor); - - procedure Swap_Links (Container : in out List; I, J : Cursor); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List); - - procedure Splice - (Target : in out List; - Before : Cursor; - Source : in out List; - Position : in out Cursor); - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : Cursor); - - function First (Container : List) return Cursor; - - function First_Element (Container : List) return Element_Type; - - function Last (Container : List) return Cursor; - - function Last_Element (Container : List) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Contains - (Container : List; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - - function Iterate - (Container : List) - return List_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : List; - Start : Cursor) - return List_Iterator_Interfaces.Reversible_Iterator'class; - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : List) return Boolean; - - procedure Sort (Container : in out List); - - procedure Merge (Target, Source : in out List); - - end Generic_Sorting; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - type Node_Type; - type Node_Access is access Node_Type; - - type Element_Access is access all Element_Type; - - type Node_Type is - limited record - Element : Element_Access; - Next : Node_Access; - Prev : Node_Access; - end record; - - use Ada.Finalization; - use Ada.Streams; - - type List is - new Controlled with record - First : Node_Access := null; - Last : Node_Access := null; - Length : Count_Type := 0; - TC : aliased Tamper_Counts; - end record; - - overriding procedure Adjust (Container : in out List); - - overriding procedure Finalize (Container : in out List) renames Clear; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out List); - - for List'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : List); - - for List'Write use Write; - - type List_Access is access all List; - for List_Access'Storage_Size use 0; - - type Cursor is - record - Container : List_Access; - Node : Node_Access; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased List'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_List : constant List := List'(Controlled with others => <>); - - No_Element : constant Cursor := Cursor'(null, null); - - type Iterator is new Limited_Controlled and - List_Iterator_Interfaces.Reversible_Iterator with - record - Container : List_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/a-cihama.adb b/gcc/ada/a-cihama.adb deleted file mode 100644 index 43a0380..0000000 --- a/gcc/ada/a-cihama.adb +++ /dev/null @@ -1,1364 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Hash_Tables.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); - -with Ada.Containers.Hash_Tables.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Hashed_Maps is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - procedure Free_Key is - new Ada.Unchecked_Deallocation (Key_Type, Key_Access); - - procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node (Node : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Key_Node); - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean; - - procedure Free (X : in out Node_Access); - -- pragma Inline (Free); - - function Hash_Node (Node : Node_Access) return Hash_Type; - pragma Inline (Hash_Node); - - function Next (Node : Node_Access) return Node_Access; - pragma Inline (Next); - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - - procedure Set_Next (Node : Node_Access; Next : Node_Access); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Ada.Containers.Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); - - package Key_Ops is new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - --------- - -- "=" -- - --------- - - function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); - - overriding function "=" (Left, Right : Map) return Boolean is - begin - return Is_Equal (Left.HT, Right.HT); - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Map) is - begin - HT_Ops.Adjust (Container.HT); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Item (Node : Node_Access); - pragma Inline (Insert_Item); - - procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item); - - ----------------- - -- Insert_Item -- - ----------------- - - procedure Insert_Item (Node : Node_Access) is - begin - Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all); - end Insert_Item; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - - if Target.Capacity < Source.Length then - Target.Reserve_Capacity (Source.Length); - end if; - - Insert_Items (Source.HT); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Map) return Count_Type is - begin - return HT_Ops.Capacity (Container.HT); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - HT_Ops.Clear (Container.HT); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Position), - "Position cursor in Constant_Reference is bad"); - - declare - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "key has no element"; - end if; - - declare - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - is - C : Count_Type; - - begin - if Capacity < Source.Length then - if Checks and then Capacity /= 0 then - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - C := Source.Length; - else - C := Capacity; - end if; - - return Target : Map do - Target.Reserve_Capacity (C); - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Node : Node_Access) return Node_Access is - K : Key_Access := new Key_Type'(Node.Key.all); - E : Element_Access; - begin - E := new Element_Type'(Node.Element.all); - return new Node_Type'(K, E, null); - exception - when others => - Free_Key (K); - Free_Element (E); - raise; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Node_Access; - - begin - Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - - if Checks and then X = null then - raise Constraint_Error with "attempt to delete key not in map"; - end if; - - Free (X); - end Delete; - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Delete equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Delete designates wrong map"; - end if; - - TC_Check (Container.HT.TC); - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); - - Free (Position.Node); - Position.Container := null; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Key : Key_Type) return Element_Type is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Node.Element.all; - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Element equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor of function Element is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - return Position.Node.Element.all; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean - is - begin - return Equivalent_Keys (Key, Node.Key.all); - end Equivalent_Key_Node; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - if Checks and then Left.Node.Key = null then - raise Program_Error with - "Left cursor of Equivalent_Keys is bad"; - end if; - - if Checks and then Right.Node.Key = null then - raise Program_Error with - "Right cursor of Equivalent_Keys is bad"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); - - return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all); - end Equivalent_Keys; - - function Equivalent_Keys - (Left : Cursor; - Right : Key_Type) return Boolean - is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - if Checks and then Left.Node.Key = null then - raise Program_Error with - "Left cursor of Equivalent_Keys is bad"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); - - return Equivalent_Keys (Left.Node.Key.all, Right); - end Equivalent_Keys; - - function Equivalent_Keys - (Left : Key_Type; - Right : Cursor) return Boolean - is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - if Checks and then Right.Node.Key = null then - raise Program_Error with - "Right cursor of Equivalent_Keys is bad"; - end if; - - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); - - return Equivalent_Keys (Left, Right.Node.Key.all); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Node_Access; - begin - Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - Free (X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Map) is - begin - HT_Ops.Finalize (Container.HT); - end Finalize; - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.HT.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); - end Find; - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean - is - R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all); - R_Node : Node_Access := R_HT.Buckets (R_Index); - - begin - while R_Node /= null loop - if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then - return L_Node.Element.all = R_Node.Element.all; - end if; - - R_Node := R_Node.Next; - end loop; - - return False; - end Find_Equal_Key; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - Pos : Hash_Type; - Node : constant Node_Access := HT_Ops.First (Container.HT, Pos); - begin - if Node = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node, Pos); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - return Object.Container.First; - end First; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X = null then - return; - end if; - - X.Next := X; -- detect mischief (in Vet) - - begin - Free_Key (X.Key); - - exception - when others => - X.Key := null; - - begin - Free_Element (X.Element); - exception - when others => - X.Element := null; - end; - - Deallocate (X); - raise; - end; - - begin - Free_Element (X.Element); - exception - when others => - X.Element := null; - Deallocate (X); - raise; - end; - - Deallocate (X); - end Free; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= null; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Access) return Hash_Type is - begin - return Hash (Node.Key.all); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - K : Key_Access; - E : Element_Access; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.HT.TC); - - K := Position.Node.Key; - E := Position.Node.Element; - - Position.Node.Key := new Key_Type'(Key); - - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Position.Node.Element := new Element_Type'(New_Item); - - exception - when others => - Free_Key (K); - raise; - end; - - Free_Key (K); - Free_Element (E); - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node (Next : Node_Access) return Node_Access; - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - K : Key_Access := new Key_Type'(Key); - E : Element_Access; - - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - E := new Element_Type'(New_Item); - return new Node_Type'(K, E, Next); - - exception - when others => - Free_Key (K); - Free_Element (E); - raise; - end New_Node; - - HT : Hash_Table_Type renames Container.HT; - - -- Start of processing for Insert - - begin - if HT_Ops.Capacity (HT) = 0 then - HT_Ops.Reserve_Capacity (HT, 1); - end if; - - Local_Insert (HT, Key, Position.Node, Inserted); - - if Inserted - and then HT.Length > HT_Ops.Capacity (HT) - then - HT_Ops.Reserve_Capacity (HT, HT.Length); - end if; - - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Container.HT.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access; Position : Hash_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new HT_Ops.Generic_Iteration_With_Position (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access; Position : Hash_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node, Position)); - end Process_Node; - - Busy : With_Busy (Container.HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (Container.HT); - end Iterate; - - function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class - is - begin - return It : constant Iterator := - (Limited_Controlled with Container => Container'Unrestricted_Access) - do - Busy (Container.HT.TC'Unrestricted_Access.all); - end return; - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Key equals No_Element"; - end if; - - if Checks and then Position.Node.Key = null then - raise Program_Error with - "Position cursor of function Key is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - - return Position.Node.Key.all; - end Key; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.HT.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Map; - Source : in out Map) - is - begin - HT_Ops.Move (Target => Target.HT, Source => Source.HT); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Access) return Node_Access is - begin - return Node.Next; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - Node : Node_Access; - Pos : Hash_Type; - begin - if Position.Node = null then - return No_Element; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with "Position cursor of Next is bad"; - end if; - - pragma Assert (Vet (Position), "Position cursor of Next is bad"); - - Pos := Position.Position; - Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos); - - if Node = null then - return No_Element; - else - return Cursor'(Position.Container, Node, Pos); - end if; - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong map"; - end if; - - return Next (Position); - end Next; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with - "Position cursor of Query_Element is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - Lock : With_Lock (HT.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - begin - Read_Nodes (Stream, Container.HT); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - - begin - begin - Node.Key := new Key_Type'(Key_Type'Input (Stream)); - exception - when others => - Free (Node); - raise; - end; - - begin - Node.Element := new Element_Type'(Element_Type'Input (Stream)); - exception - when others => - Free_Key (Node.Key); - Free (Node); - raise; - end; - - return Node; - end Read_Node; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor has no element"; - end if; - - pragma Assert - (Vet (Position), - "Position cursor in function Reference is bad"); - - declare - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type - is - HT : Hash_Table_Type renames Container.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "key has no element"; - end if; - - declare - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); - - K : Key_Access; - E : Element_Access; - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace key not in map"; - end if; - - TE_Check (Container.HT.TC); - - K := Node.Key; - E := Node.Element; - - Node.Key := new Key_Type'(Key); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(New_Item); - - exception - when others => - Free_Key (K); - raise; - end; - - Free_Key (K); - Free_Element (E); - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Replace_Element equals No_Element"; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with - "Position cursor of Replace_Element is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Replace_Element designates wrong map"; - end if; - - TE_Check (Position.Container.HT.TC); - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - declare - X : Element_Access := Position.Node.Element; - - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Position.Node.Element := new Element_Type'(New_Item); - Free_Element (X); - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - is - begin - HT_Ops.Reserve_Capacity (Container.HT, Capacity); - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : Node_Access; Next : Node_Access) is - begin - Node.Next := Next; - end Set_Next; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Update_Element equals No_Element"; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with - "Position cursor of Update_Element is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Update_Element designates wrong map"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - HT : Hash_Table_Type renames Container.HT; - Lock : With_Lock (HT.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = null then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - if Position.Node.Next = Position.Node then - return False; - end if; - - if Position.Node.Key = null then - return False; - end if; - - if Position.Node.Element = null then - return False; - end if; - - declare - HT : Hash_Table_Type renames Position.Container.HT; - X : Node_Access; - - begin - if HT.Length = 0 then - return False; - end if; - - if HT.Buckets = null - or else HT.Buckets'Length = 0 - then - return False; - end if; - - X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key.all)); - - for J in 1 .. HT.Length loop - if X = Position.Node then - return True; - end if; - - if X = null then - return False; - end if; - - if X = X.Next then -- to prevent unnecessary looping - return False; - end if; - - X := X.Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - begin - Write_Nodes (Stream, Container.HT); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Key_Type'Output (Stream, Node.Key.all); - Element_Type'Output (Stream, Node.Element.all); - end Write_Node; - -end Ada.Containers.Indefinite_Hashed_Maps; diff --git a/gcc/ada/a-cihama.ads b/gcc/ada/a-cihama.ads deleted file mode 100644 index dad3475..0000000 --- a/gcc/ada/a-cihama.ads +++ /dev/null @@ -1,455 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Hash_Tables; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Key_Type (<>) is private; - type Element_Type (<>) is private; - - with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Hashed_Maps is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type Map is tagged private with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Map); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Map : constant Map; - -- Map objects declared without an initialization expression are - -- initialized to the value Empty_Map. - - No_Element : constant Cursor; - -- Cursor objects declared without an initialization expression are - -- initialized to the value No_Element. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Map_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - overriding function "=" (Left, Right : Map) return Boolean; - -- For each key/element pair in Left, equality attempts to find the key in - -- Right; if a search fails the equality returns False. The search works by - -- calling Hash to find the bucket in the Right map that corresponds to the - -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys - -- to compare the key (in Left) to the key of each node in the bucket (in - -- Right); if the keys are equivalent, then the equality test for this - -- key/element pair (in Left) completes by calling the element equality - -- operator to compare the element (in Left) to the element of the node - -- (in Right) whose key matched. - - function Capacity (Container : Map) return Count_Type; - -- Returns the current capacity of the map. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); - -- Adjusts the current capacity, by allocating a new buckets array. If the - -- requested capacity is less than the current capacity, then the capacity - -- is contracted (to a value not less than the current length). If the - -- requested capacity is greater than the current capacity, then the - -- capacity is expanded (to a value not less than what is requested). In - -- either case, the nodes are rehashed from the old buckets array onto the - -- new buckets array (Hash is called once for each existing key in order to - -- compute the new index), and then the old buckets array is deallocated. - - function Length (Container : Map) return Count_Type; - -- Returns the number of items in the map - - function Is_Empty (Container : Map) return Boolean; - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Map); - -- Removes all of the items from the map - - function Key (Position : Cursor) return Key_Type; - -- Returns the key of the node designated by the cursor - - function Element (Position : Cursor) return Element_Type; - -- Returns the element of the node designated by the cursor - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type); - -- Assigns the value New_Item to the element designated by the cursor - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)); - -- Calls Process with the key and element (both having only a constant - -- view) of the node designed by the cursor. - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)); - -- Calls Process with the key (with only a constant view) and element (with - -- a variable view) of the node designed by the cursor. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Map; Source : Map); - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map; - - procedure Move (Target : in out Map; Source : in out Map); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - -- Conditionally inserts New_Item into the map. If Key is already in the - -- map, then Inserted returns False and Position designates the node - -- containing the existing key/element pair (neither of which is modified). - -- If Key is not already in the map, the Inserted returns True and Position - -- designates the newly-inserted node container Key and New_Item. The - -- search for the key works as follows. Hash is called to determine Key's - -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to - -- compare Key to each node in that bucket. If the bucket is empty, or - -- there were no matching keys in the bucket, the search "fails" and the - -- key/item pair is inserted in the map (and Inserted returns True); - -- otherwise, the search "succeeds" (and Inserted returns False). - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Attempts to insert Key into the map, performing the usual search (which - -- involves calling both Hash and Equivalent_Keys); if the search succeeds - -- (because Key is already in the map), then it raises Constraint_Error. - -- (This version of Insert is similar to Replace, but having the opposite - -- exception behavior. It is intended for use when you want to assert that - -- Key is not already in the map.) - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Attempts to insert Key into the map. If Key is already in the map, then - -- both the existing key and element are assigned the values of Key and - -- New_Item, respectively. (This version of Insert only raises an exception - -- if cursor tampering occurs. It is intended for use when you want to - -- insert the key/element pair in the map, and you don't care whether Key - -- is already present.) - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Searches for Key in the map; if the search fails (because Key was not in - -- the map), then it raises Constraint_Error. Otherwise, both the existing - -- key and element are assigned the values of Key and New_Item rsp. (This - -- is similar to Insert, but with the opposite exception behavior. It is - -- intended for use when you want to assert that Key is already in the - -- map.) - - procedure Exclude (Container : in out Map; Key : Key_Type); - -- Searches for Key in the map, and if found, removes its node from the map - -- and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the key's bucket; if the bucket is not empty, it - -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is - -- the deletion analog of Include. It is intended for use when you want to - -- remove the item from the map, but don't care whether the key is already - -- in the map.) - - procedure Delete (Container : in out Map; Key : Key_Type); - -- Searches for Key in the map (which involves calling both Hash and - -- Equivalent_Keys). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the map and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the map.) - - procedure Delete (Container : in out Map; Position : in out Cursor); - -- Removes the node designated by Position from the map, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Keys). - - function First (Container : Map) return Cursor; - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Position : Cursor) return Cursor; - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Find (Container : Map; Key : Key_Type) return Cursor; - -- Searches for Key in the map. Find calls Hash to determine the key's - -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare - -- Key to each key in the bucket. If the search succeeds, Find returns a - -- cursor designating the matching node; otherwise, it returns No_Element. - - function Contains (Container : Map; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - function Element (Container : Map; Key : Key_Type) return Element_Type; - -- Equivalent to Element (Find (Container, Key)) - - function Equivalent_Keys (Left, Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Keys with the keys of the nodes - -- designated by cursors Left and Right. - - function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; - -- Returns the result of calling Equivalent_Keys with key of the node - -- designated by Left and key Right. - - function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Keys with key Left and the node - -- designated by Right. - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - -- Calls Process for each node in the map - - function Iterate (Container : Map) - return Map_Iterator_Interfaces.Forward_Iterator'class; - -private - pragma Inline ("="); - pragma Inline (Length); - pragma Inline (Is_Empty); - pragma Inline (Clear); - pragma Inline (Key); - pragma Inline (Element); - pragma Inline (Move); - pragma Inline (Contains); - pragma Inline (Capacity); - pragma Inline (Reserve_Capacity); - pragma Inline (Has_Element); - pragma Inline (Equivalent_Keys); - pragma Inline (Next); - - type Node_Type; - type Node_Access is access Node_Type; - - type Key_Access is access Key_Type; - type Element_Access is access all Element_Type; - - type Node_Type is limited record - Key : Key_Access; - Element : Element_Access; - Next : Node_Access; - end record; - - package HT_Types is - new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); - - type Map is new Ada.Finalization.Controlled with record - HT : HT_Types.Hash_Table_Type; - end record; - - overriding procedure Adjust (Container : in out Map); - - overriding procedure Finalize (Container : in out Map); - - use HT_Types, HT_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; - - type Cursor is record - Container : Map_Access; - Node : Node_Access; - Position : Hash_Type := Hash_Type'Last; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Map : constant Map := (Controlled with others => <>); - - No_Element : constant Cursor := - (Container => null, Node => null, Position => Hash_Type'Last); - - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Forward_Iterator with - record - Container : Map_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Indefinite_Hashed_Maps; diff --git a/gcc/ada/a-cihase.adb b/gcc/ada/a-cihase.adb deleted file mode 100644 index 6d913cb..0000000 --- a/gcc/ada/a-cihase.adb +++ /dev/null @@ -1,2401 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Hash_Tables.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); - -with Ada.Containers.Hash_Tables.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Prime_Numbers; - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Hashed_Sets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Assign (Node : Node_Access; Item : Element_Type); - pragma Inline (Assign); - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean; - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean; - - procedure Free (X : in out Node_Access); - - function Hash_Node (Node : Node_Access) return Hash_Type; - pragma Inline (Hash_Node); - - procedure Insert - (HT : in out Hash_Table_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean); - - function Is_In - (HT : aliased in out Hash_Table_Type; - Key : Node_Access) return Boolean; - pragma Inline (Is_In); - - function Next (Node : Node_Access) return Node_Access; - pragma Inline (Next); - - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Node_Access; - pragma Inline (Read_Node); - - procedure Set_Next (Node : Node_Access; Next : Node_Access); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - package HT_Ops is new Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); - - package Element_Keys is new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - function Is_Equal is - new HT_Ops.Generic_Equal (Find_Equal_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - procedure Replace_Element is - new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); - - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - return Is_Equal (Left.HT, Right.HT); - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Set) is - begin - HT_Ops.Adjust (Container.HT); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Node : Node_Access; Item : Element_Type) is - X : Element_Access := Node.Element; - - -- The element allocator may need an accessibility check in the case the - -- actual type is class-wide or has access discriminants (RM 4.8(10.1) - -- and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(Item); - Free_Element (X); - end Assign; - - procedure Assign (Target : in out Set; Source : Set) is - begin - if Target'Address = Source'Address then - return; - else - Target.Clear; - Target.Union (Source); - end if; - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Set) return Count_Type is - begin - return HT_Ops.Capacity (Container.HT); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - HT_Ops.Clear (Container.HT); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - - declare - HT : Hash_Table_Type renames Position.Container.all.HT; - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - is - C : Count_Type; - - begin - if Capacity < Source.Length then - if Checks and then Capacity /= 0 then - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - C := Source.Length; - else - C := Capacity; - end if; - - return Target : Set do - Target.Reserve_Capacity (C); - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - E : Element_Access := new Element_Type'(Source.Element.all); - begin - return new Node_Type'(Element => E, Next => null); - exception - when others => - Free_Element (E); - raise; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Item : Element_Type) - is - X : Node_Access; - - begin - Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - - if Checks and then X = null then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Free (X); - end Delete; - - procedure Delete - (Container : in out Set; - Position : in out Cursor) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - TC_Check (Container.HT.TC); - - pragma Assert (Vet (Position), "Position cursor is bad"); - - HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); - - Free (Position.Node); - Position.Container := null; - end Delete; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Target : in out Set; - Source : Set) - is - Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; - Tgt_Node : Node_Access; - - begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - if Src_HT.Length = 0 then - return; - end if; - - TC_Check (Target.HT.TC); - - if Src_HT.Length < Target.HT.Length then - declare - Src_Node : Node_Access; - - begin - Src_Node := HT_Ops.First (Src_HT); - while Src_Node /= null loop - Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all); - - if Tgt_Node /= null then - HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); - Free (Tgt_Node); - end if; - - Src_Node := HT_Ops.Next (Src_HT, Src_Node); - end loop; - end; - - else - Tgt_Node := HT_Ops.First (Target.HT); - while Tgt_Node /= null loop - if Is_In (Src_HT, Tgt_Node) then - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.HT, X); - Free (X); - end; - - else - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - end if; - end loop; - end if; - end Difference; - - function Difference (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Left.Length = 0 then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; - - declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Length := 0; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - begin - if not Is_In (Right_HT, L_Node) then - declare - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - Indx : constant Hash_Type := - HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); - - Bucket : Node_Access renames Buckets (Indx); - Src : Element_Type renames L_Node.Element.all; - Tgt : Element_Access := new Element_Type'(Src); - - begin - Bucket := new Node_Type'(Tgt, Bucket); - - exception - when others => - Free_Element (Tgt); - raise; - end; - - Length := Length + 1; - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left.HT); - - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor of equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - -- handle dangling reference - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - return Position.Node.Element.all; - end Element; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - begin - return Is_Equivalent (Left.HT, Right.HT); - end Equivalent_Sets; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - if Checks and then Left.Node.Element = null then - raise Program_Error with - "Left cursor of Equivalent_Elements is bad"; - end if; - - if Checks and then Right.Node.Element = null then - raise Program_Error with - "Right cursor of Equivalent_Elements is bad"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); - - -- AI05-0022 requires that a container implementation detect element - -- tampering by a generic actual subprogram. However, the following case - -- falls outside the scope of that AI. Randy Brukardt explained on the - -- ARG list on 2013/02/07 that: - - -- (Begin Quote): - -- But for an operation like "<" [the ordered set analog of - -- Equivalent_Elements], there is no need to "dereference" a cursor - -- after the call to the generic formal parameter function, so nothing - -- bad could happen if tampering is undetected. And the operation can - -- safely return a result without a problem even if an element is - -- deleted from the container. - -- (End Quote). - - return Equivalent_Elements - (Left.Node.Element.all, - Right.Node.Element.all); - end Equivalent_Elements; - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean - is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - if Checks and then Left.Node.Element = null then - raise Program_Error with - "Left cursor of Equivalent_Elements is bad"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); - - return Equivalent_Elements (Left.Node.Element.all, Right); - end Equivalent_Elements; - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean - is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - if Checks and then Right.Node.Element = null then - raise Program_Error with - "Right cursor of Equivalent_Elements is bad"; - end if; - - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); - - return Equivalent_Elements (Left, Right.Node.Element.all); - end Equivalent_Elements; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Access) return Boolean - is - begin - return Equivalent_Elements (Key, Node.Element.all); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Item : Element_Type) - is - X : Node_Access; - begin - Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - Free (X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Set) is - begin - HT_Ops.Finalize (Container.HT); - end Finalize; - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.HT.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Item : Element_Type) return Cursor - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Element_Keys.Find (HT, Item); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element.all); - - R_Node : Node_Access := R_HT.Buckets (R_Index); - - begin - loop - if R_Node = null then - return False; - end if; - - if L_Node.Element.all = R_Node.Element.all then - return True; - end if; - - R_Node := Next (R_Node); - end loop; - end Find_Equal_Key; - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element.all); - - R_Node : Node_Access := R_HT.Buckets (R_Index); - - begin - loop - if R_Node = null then - return False; - end if; - - if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then - return True; - end if; - - R_Node := Next (R_Node); - end loop; - end Find_Equivalent_Key; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - Node : constant Node_Access := HT_Ops.First (Container.HT); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end First; - - function First (Object : Iterator) return Cursor is - begin - return Object.Container.First; - end First; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X = null then - return; - end if; - - X.Next := X; -- detect mischief (in Vet) - - begin - Free_Element (X.Element); - - exception - when others => - X.Element := null; - Deallocate (X); - raise; - end; - - Deallocate (X); - end Free; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= null; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Access) return Hash_Type is - begin - return Hash (Node.Element.all); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - X : Element_Access; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.HT.TC); - - X := Position.Node.Element; - - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Position.Node.Element := new Element_Type'(New_Item); - end; - - Free_Element (X); - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert (Container.HT, New_Item, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - procedure Insert - (HT : in out Hash_Table_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean) - is - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - Element : Element_Access := new Element_Type'(New_Item); - - begin - return new Node_Type'(Element, Next); - - exception - when others => - Free_Element (Element); - raise; - end New_Node; - - -- Start of processing for Insert - - begin - if HT_Ops.Capacity (HT) = 0 then - HT_Ops.Reserve_Capacity (HT, 1); - end if; - - Local_Insert (HT, New_Item, Node, Inserted); - - if Inserted and then HT.Length > HT_Ops.Capacity (HT) then - HT_Ops.Reserve_Capacity (HT, HT.Length); - end if; - end Insert; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection - (Target : in out Set; - Source : Set) - is - Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; - Tgt_Node : Node_Access; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.Length = 0 then - Clear (Target); - return; - end if; - - TC_Check (Target.HT.TC); - - Tgt_Node := HT_Ops.First (Target.HT); - while Tgt_Node /= null loop - if Is_In (Src_HT, Tgt_Node) then - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - - else - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.HT, X); - Free (X); - end; - end if; - end loop; - end Intersection; - - function Intersection (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - Length := Count_Type'Min (Left.Length, Right.Length); - - if Length = 0 then - return Empty_Set; - end if; - - declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Length := 0; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - begin - if Is_In (Right_HT, L_Node) then - declare - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - Indx : constant Hash_Type := - HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); - - Bucket : Node_Access renames Buckets (Indx); - - Src : Element_Type renames L_Node.Element.all; - Tgt : Element_Access := new Element_Type'(Src); - - begin - Bucket := new Node_Type'(Tgt, Bucket); - - exception - when others => - Free_Element (Tgt); - raise; - end; - - Length := Length + 1; - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left.HT); - - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.HT.Length = 0; - end Is_Empty; - - ----------- - -- Is_In -- - ----------- - - function Is_In - (HT : aliased in out Hash_Table_Type; - Key : Node_Access) return Boolean - is - begin - return Element_Keys.Find (HT, Key.Element.all) /= null; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset - (Subset : Set; - Of_Set : Set) return Boolean - is - Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT; - Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT; - Subset_Node : Node_Access; - - begin - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Subset.Length > Of_Set.Length then - return False; - end if; - - Subset_Node := HT_Ops.First (Subset_HT); - while Subset_Node /= null loop - if not Is_In (Of_Set_HT, Subset_Node) then - return False; - end if; - - Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node); - end loop; - - return True; - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Iterate (Container.HT); - end Iterate; - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class - is - begin - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access) - do - Busy (Container.HT.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.HT.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - begin - HT_Ops.Move (Target => Target.HT, Source => Source.HT); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Access) return Node_Access is - begin - return Node.Next; - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = null then - return No_Element; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "bad cursor in Next"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - HT : Hash_Table_Type renames Position.Container.HT; - Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Left_Node : Node_Access; - - begin - if Right.Length = 0 then - return False; - end if; - - if Left'Address = Right'Address then - return True; - end if; - - Left_Node := HT_Ops.First (Left_HT); - while Left_Node /= null loop - if Is_In (Right_HT, Left_Node) then - return True; - end if; - - Left_Node := HT_Ops.Next (Left_HT, Left_Node); - end loop; - - return False; - end Overlap; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "bad cursor in Query_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - HT : Hash_Table_Type renames - Position.Container'Unrestricted_Access.all.HT; - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - Process (Position.Node.Element.all); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - begin - Read_Nodes (Stream, Container.HT); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); - begin - return new Node_Type'(X, null); - exception - when others => - Free_Element (X); - raise; - end Read_Node; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - New_Item : Element_Type) - is - Node : constant Node_Access := - Element_Keys.Find (Container.HT, New_Item); - - X : Element_Access; - pragma Warnings (Off, X); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - TE_Check (Container.HT.TC); - - X := Node.Element; - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(New_Item); - end; - - Free_Element (X); - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "bad cursor in Replace_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Replace_Element (Container.HT, Position.Node, New_Item); - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - is - begin - HT_Ops.Reserve_Capacity (Container.HT, Capacity); - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : Node_Access; Next : Node_Access) is - begin - Node.Next := Next; - end Set_Next; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference - (Target : in out Set; - Source : Set) - is - Tgt_HT : Hash_Table_Type renames Target.HT; - Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; - begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - TC_Check (Tgt_HT.TC); - - declare - N : constant Count_Type := Target.Length + Source.Length; - begin - if N > HT_Ops.Capacity (Tgt_HT) then - HT_Ops.Reserve_Capacity (Tgt_HT, N); - end if; - end; - - if Target.Length = 0 then - Iterate_Source_When_Empty_Target : declare - procedure Process (Src_Node : Node_Access); - - procedure Iterate is new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - E : Element_Type renames Src_Node.Element.all; - B : Buckets_Type renames Tgt_HT.Buckets.all; - J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Tgt_HT.Length; - - begin - declare - X : Element_Access := new Element_Type'(E); - begin - B (J) := new Node_Type'(X, B (J)); - exception - when others => - Free_Element (X); - raise; - end; - - N := N + 1; - end Process; - - -- Per AI05-0022, the container implementation is required to - -- detect element tampering by a generic actual subprogram. - - Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); - Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Source_When_Empty_Target - - begin - Iterate (Src_HT); - end Iterate_Source_When_Empty_Target; - - else - Iterate_Source : declare - procedure Process (Src_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - E : Element_Type renames Src_Node.Element.all; - B : Buckets_Type renames Tgt_HT.Buckets.all; - J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Tgt_HT.Length; - - begin - if B (J) = null then - declare - X : Element_Access := new Element_Type'(E); - begin - B (J) := new Node_Type'(X, null); - exception - when others => - Free_Element (X); - raise; - end; - - N := N + 1; - - elsif Equivalent_Elements (E, B (J).Element.all) then - declare - X : Node_Access := B (J); - begin - B (J) := B (J).Next; - N := N - 1; - Free (X); - end; - - else - declare - Prev : Node_Access := B (J); - Curr : Node_Access := Prev.Next; - - begin - while Curr /= null loop - if Equivalent_Elements (E, Curr.Element.all) then - Prev.Next := Curr.Next; - N := N - 1; - Free (Curr); - return; - end if; - - Prev := Curr; - Curr := Prev.Next; - end loop; - - declare - X : Element_Access := new Element_Type'(E); - begin - B (J) := new Node_Type'(X, B (J)); - exception - when others => - Free_Element (X); - raise; - end; - - N := N + 1; - end; - end if; - end Process; - - -- Per AI05-0022, the container implementation is required to - -- detect element tampering by a generic actual subprogram. - - Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); - Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Source - - begin - Iterate (Src_HT); - end Iterate_Source; - end if; - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - declare - Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Length := 0; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - begin - if not Is_In (Right_HT, L_Node) then - declare - E : Element_Type renames L_Node.Element.all; - - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - J : constant Hash_Type := - HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); - - begin - declare - X : Element_Access := new Element_Type'(E); - begin - Buckets (J) := new Node_Type'(X, Buckets (J)); - exception - when others => - Free_Element (X); - raise; - end; - - Length := Length + 1; - end; - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left_HT); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - Iterate_Right : declare - procedure Process (R_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (R_Node : Node_Access) is - begin - if not Is_In (Left_HT, R_Node) then - declare - E : Element_Type renames R_Node.Element.all; - - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - J : constant Hash_Type := - HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); - - begin - declare - X : Element_Access := new Element_Type'(E); - begin - Buckets (J) := new Node_Type'(X, Buckets (J)); - exception - when others => - Free_Element (X); - raise; - end; - - Length := Length + 1; - end; - end if; - end Process; - - -- Start of processing for Iterate_Right - - begin - Iterate (Right_HT); - - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Right; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - HT : Hash_Table_Type; - Node : Node_Access; - Inserted : Boolean; - pragma Unreferenced (Node, Inserted); - begin - Insert (HT, New_Item, Node, Inserted); - return Set'(Controlled with HT); - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union - (Target : in out Set; - Source : Set) - is - procedure Process (Src_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - Src : Element_Type renames Src_Node.Element.all; - - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - Tgt : Element_Access := new Element_Type'(Src); - begin - return new Node_Type'(Tgt, Next); - exception - when others => - Free_Element (Tgt); - raise; - end New_Node; - - Tgt_Node : Node_Access; - Success : Boolean; - pragma Unreferenced (Tgt_Node, Success); - - -- Start of processing for Process - - begin - Insert (Target.HT, Src, Tgt_Node, Success); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Target.HT.TC); - - declare - N : constant Count_Type := Target.Length + Source.Length; - begin - if N > HT_Ops.Capacity (Target.HT) then - HT_Ops.Reserve_Capacity (Target.HT, N); - end if; - end; - - Iterate (Source.HT); - end Union; - - function Union (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; - Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - declare - Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - Src : Element_Type renames L_Node.Element.all; - J : constant Hash_Type := Hash (Src) mod Buckets'Length; - Bucket : Node_Access renames Buckets (J); - Tgt : Element_Access := new Element_Type'(Src); - begin - Bucket := new Node_Type'(Tgt, Bucket); - exception - when others => - Free_Element (Tgt); - raise; - end Process; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram, hence the use of - -- Checked_Index instead of a simple invocation of generic formal - -- Hash. - - Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Left - - begin - Iterate (Left_HT); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - Length := Left.Length; - - Iterate_Right : declare - procedure Process (Src_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - Src : Element_Type renames Src_Node.Element.all; - Idx : constant Hash_Type := Hash (Src) mod Buckets'Length; - - Tgt_Node : Node_Access := Buckets (Idx); - - begin - while Tgt_Node /= null loop - if Equivalent_Elements (Src, Tgt_Node.Element.all) then - return; - end if; - Tgt_Node := Next (Tgt_Node); - end loop; - - declare - Tgt : Element_Access := new Element_Type'(Src); - begin - Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx)); - exception - when others => - Free_Element (Tgt); - raise; - end; - - Length := Length + 1; - end Process; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram, hence the use of - -- Checked_Index instead of a simple invocation of generic formal - -- Hash. - - Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Right - - begin - Iterate (Right.HT); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Right; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Union; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = null then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - if Position.Node.Next = Position.Node then - return False; - end if; - - if Position.Node.Element = null then - return False; - end if; - - declare - HT : Hash_Table_Type renames Position.Container.HT; - X : Node_Access; - - begin - if HT.Length = 0 then - return False; - end if; - - if HT.Buckets = null - or else HT.Buckets'Length = 0 - then - return False; - end if; - - X := HT.Buckets (Element_Keys.Checked_Index - (HT, - Position.Node.Element.all)); - - for J in 1 .. HT.Length loop - if X = Position.Node then - return True; - end if; - - if X = null then - return False; - end if; - - if X = X.Next then -- to prevent unnecessary looping - return False; - end if; - - X := X.Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - begin - Write_Nodes (Stream, Container.HT); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Element_Type'Output (Stream, Node.Element.all); - end Write_Node; - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Keys.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "Key not in set"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - declare - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Key : Key_Type) return Boolean - is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Key : Key_Type) - is - X : Node_Access; - - begin - Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - - if Checks and then X = null then - raise Constraint_Error with "key not in set"; - end if; - - Free (X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Keys.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in set"; - end if; - - return Node.Element.all; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean is - begin - return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all)); - end Equivalent_Key_Node; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Key : Key_Type) - is - X : Node_Access; - begin - Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - Free (X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Impl.Reference_Control_Type (Control).Finalize; - - if Checks and then Hash (Key (Control.Old_Pos)) /= Control.Old_Hash - then - HT_Ops.Delete_Node_At_Index - (Control.Container.HT, Control.Index, Control.Old_Pos.Node); - raise Program_Error; - end if; - - Control.Container := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Key : Key_Type) return Cursor - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Keys.Find (HT, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - - return Key (Position.Node.Element.all); - end Key; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert - (Vet (Position), - "bad cursor in function Reference_Preserving_Key"); - - declare - HT : Hash_Table_Type renames Container.HT; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => - (Controlled with - HT.TC'Unrestricted_Access, - Container => Container'Access, - Index => HT_Ops.Index (HT, Position.Node), - Old_Pos => Position, - Old_Hash => Hash (Key (Position)))) - do - Lock (HT.TC); - end return; - end; - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "Key not in set"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - declare - HT : Hash_Table_Type renames Container.HT; - P : constant Cursor := Find (Container, Key); - begin - return R : constant Reference_Type := - (Element => Node.Element.all'Access, - Control => - (Controlled with - HT.TC'Unrestricted_Access, - Container => Container'Access, - Index => HT_Ops.Index (HT, P.Node), - Old_Pos => P, - Old_Hash => Hash (Key))) - do - Lock (HT.TC); - end return; - end; - end Reference_Preserving_Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container.HT, Node, New_Item); - end Replace; - - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - HT : Hash_Table_Type renames Container.HT; - Indx : Hash_Type; - - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then - (Position.Node.Element = null - or else Position.Node.Next = Position.Node) - then - raise Program_Error with "Position cursor is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - if Checks and then - (HT.Buckets = null - or else HT.Buckets'Length = 0 - or else HT.Length = 0) - then - raise Program_Error with "Position cursor is bad (set is empty)"; - end if; - - pragma Assert - (Vet (Position), - "bad cursor in Update_Element_Preserving_Key"); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - E : Element_Type renames Position.Node.Element.all; - K : constant Key_Type := Key (E); - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - Indx := HT_Ops.Index (HT, Position.Node); - Process (E); - - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - if HT.Buckets (Indx) = Position.Node then - HT.Buckets (Indx) := Position.Node.Next; - - else - declare - Prev : Node_Access := HT.Buckets (Indx); - - begin - while Prev.Next /= Position.Node loop - Prev := Prev.Next; - - if Checks and then Prev = null then - raise Program_Error with - "Position cursor is bad (node not found)"; - end if; - end loop; - - Prev.Next := Position.Node.Next; - end; - end if; - - HT.Length := HT.Length - 1; - - declare - X : Node_Access := Position.Node; - - begin - Free (X); - end; - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - end Generic_Keys; - -end Ada.Containers.Indefinite_Hashed_Sets; diff --git a/gcc/ada/a-cihase.ads b/gcc/ada/a-cihase.ads deleted file mode 100644 index 2eae9d2..0000000 --- a/gcc/ada/a-cihase.ads +++ /dev/null @@ -1,595 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Hash_Tables; -with Ada.Containers.Helpers; -private with Ada.Streams; -private with Ada.Finalization; - -generic - type Element_Type (<>) is private; - - with function Hash (Element : Element_Type) return Hash_Type; - - with function Equivalent_Elements (Left, Right : Element_Type) - return Boolean; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Hashed_Sets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type Set is tagged private - with Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Set : constant Set; - -- Set objects declared without an initialization expression are - -- initialized to the value Empty_Set. - - No_Element : constant Cursor; - -- Cursor objects declared without an initialization expression are - -- initialized to the value No_Element. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - -- For each element in Left, set equality attempts to find the equal - -- element in Right; if a search fails, then set equality immediately - -- returns False. The search works by calling Hash to find the bucket in - -- the Right set that corresponds to the Left element. If the bucket is - -- non-empty, the search calls the generic formal element equality operator - -- to compare the element (in Left) to the element of each node in the - -- bucket (in Right); the search terminates when a matching node in the - -- bucket is found, or the nodes in the bucket are exhausted. (Note that - -- element equality is called here, not Equivalent_Elements. Set equality - -- is the only operation in which element equality is used. Compare set - -- equality to Equivalent_Sets, which does call Equivalent_Elements.) - - function Equivalent_Sets (Left, Right : Set) return Boolean; - -- Similar to set equality, with the difference that the element in Left is - -- compared to the elements in Right using the generic formal - -- Equivalent_Elements operation instead of element equality. - - function To_Set (New_Item : Element_Type) return Set; - -- Constructs a singleton set comprising New_Element. To_Set calls Hash to - -- determine the bucket for New_Item. - - function Capacity (Container : Set) return Count_Type; - -- Returns the current capacity of the set. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); - -- Adjusts the current capacity, by allocating a new buckets array. If the - -- requested capacity is less than the current capacity, then the capacity - -- is contracted (to a value not less than the current length). If the - -- requested capacity is greater than the current capacity, then the - -- capacity is expanded (to a value not less than what is requested). In - -- either case, the nodes are rehashed from the old buckets array onto the - -- new buckets array (Hash is called once for each existing element in - -- order to compute the new index), and then the old buckets array is - -- deallocated. - - function Length (Container : Set) return Count_Type; - -- Returns the number of items in the set - - function Is_Empty (Container : Set) return Boolean; - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Set); - -- Removes all of the items from the set - - function Element (Position : Cursor) return Element_Type; - -- Returns the element of the node designated by the cursor - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - -- If New_Item is equivalent (as determined by calling Equivalent_Elements) - -- to the element of the node designated by Position, then New_Element is - -- assigned to that element. Otherwise, it calls Hash to determine the - -- bucket for New_Item. If the bucket is not empty, then it calls - -- Equivalent_Elements for each node in that bucket to determine whether - -- New_Item is equivalent to an element in that bucket. If - -- Equivalent_Elements returns True then Program_Error is raised (because - -- an element may appear only once in the set); otherwise, New_Item is - -- assigned to the node designated by Position, and the node is moved to - -- its new bucket. - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - -- Calls Process with the element (having only a constant view) of the node - -- designated by the cursor. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set; - - procedure Move (Target : in out Set; Source : in out Set); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - -- Conditionally inserts New_Item into the set. If New_Item is already in - -- the set, then Inserted returns False and Position designates the node - -- containing the existing element (which is not modified). If New_Item is - -- not already in the set, then Inserted returns True and Position - -- designates the newly-inserted node containing New_Item. The search for - -- an existing element works as follows. Hash is called to determine - -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements - -- is called to compare New_Item to the element of each node in that - -- bucket. If the bucket is empty, or there were no equivalent elements in - -- the bucket, the search "fails" and the New_Item is inserted in the set - -- (and Inserted returns True); otherwise, the search "succeeds" (and - -- Inserted returns False). - - procedure Insert (Container : in out Set; New_Item : Element_Type); - -- Attempts to insert New_Item into the set, performing the usual insertion - -- search (which involves calling both Hash and Equivalent_Elements); if - -- the search succeeds (New_Item is equivalent to an element already in the - -- set, and so was not inserted), then this operation raises - -- Constraint_Error. (This version of Insert is similar to Replace, but - -- having the opposite exception behavior. It is intended for use when you - -- want to assert that the item is not already in the set.) - - procedure Include (Container : in out Set; New_Item : Element_Type); - -- Attempts to insert New_Item into the set. If an element equivalent to - -- New_Item is already in the set (the insertion search succeeded, and - -- hence New_Item was not inserted), then the value of New_Item is assigned - -- to the existing element. (This insertion operation only raises an - -- exception if cursor tampering occurs. It is intended for use when you - -- want to insert the item in the set, and you don't care whether an - -- equivalent element is already present.) - - procedure Replace (Container : in out Set; New_Item : Element_Type); - -- Searches for New_Item in the set; if the search fails (because an - -- equivalent element was not in the set), then it raises - -- Constraint_Error. Otherwise, the existing element is assigned the value - -- New_Item. (This is similar to Insert, but with the opposite exception - -- behavior. It is intended for use when you want to assert that the item - -- is already in the set.) - - procedure Exclude (Container : in out Set; Item : Element_Type); - -- Searches for Item in the set, and if found, removes its node from the - -- set and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the item's bucket; if the bucket is not empty, - -- it calls Equivalent_Elements to compare Item to the element of each node - -- in the bucket. (This is the deletion analog of Include. It is intended - -- for use when you want to remove the item from the set, but don't care - -- whether the item is already in the set.) - - procedure Delete (Container : in out Set; Item : Element_Type); - -- Searches for Item in the set (which involves calling both Hash and - -- Equivalent_Elements). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the set and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the set.) - - procedure Delete (Container : in out Set; Position : in out Cursor); - -- Removes the node designated by Position from the set, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Elements). - - procedure Union (Target : in out Set; Source : Set); - -- The operation first calls Reserve_Capacity if the current capacity is - -- less than the sum of the lengths of Source and Target. It then iterates - -- over the Source set, and conditionally inserts each element into Target. - - function Union (Left, Right : Set) return Set; - -- The operation first copies the Left set to the result, and then iterates - -- over the Right set to conditionally insert each element into the result. - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - -- Iterates over the Target set (calling First and Next), calling Find to - -- determine whether the element is in Source. If an equivalent element is - -- not found in Source, the element is deleted from Target. - - function Intersection (Left, Right : Set) return Set; - -- Iterates over the Left set, calling Find to determine whether the - -- element is in Right. If an equivalent element is found, it is inserted - -- into the result set. - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - -- Iterates over the Source (calling First and Next), calling Find to - -- determine whether the element is in Target. If an equivalent element is - -- found, it is deleted from Target. - - function Difference (Left, Right : Set) return Set; - -- Iterates over the Left set, calling Find to determine whether the - -- element is in the Right set. If an equivalent element is not found, the - -- element is inserted into the result set. - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - -- The operation first calls Reserve_Capacity if the current capacity is - -- less than the sum of the lengths of Source and Target. It then iterates - -- over the Source set, searching for the element in Target (calling Hash - -- and Equivalent_Elements). If an equivalent element is found, it is - -- removed from Target; otherwise it is inserted into Target. - - function Symmetric_Difference (Left, Right : Set) return Set; - -- The operation first iterates over the Left set. It calls Find to - -- determine whether the element is in the Right set. If no equivalent - -- element is found, the element from Left is inserted into the result. The - -- operation then iterates over the Right set, to determine whether the - -- element is in the Left set. If no equivalent element is found, the Right - -- element is inserted into the result. - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - -- Iterates over the Left set (calling First and Next), calling Find to - -- determine whether the element is in the Right set. If an equivalent - -- element is found, the operation immediately returns True. The operation - -- returns False if the iteration over Left terminates without finding any - -- equivalent element in Right. - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - -- Iterates over Subset (calling First and Next), calling Find to determine - -- whether the element is in Of_Set. If no equivalent element is found in - -- Of_Set, the operation immediately returns False. The operation returns - -- True if the iteration over Subset terminates without finding an element - -- not in Of_Set (that is, every element in Subset is equivalent to an - -- element in Of_Set). - - function First (Container : Set) return Cursor; - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Position : Cursor) return Cursor; - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Find (Container : Set; Item : Element_Type) return Cursor; - -- Searches for Item in the set. Find calls Hash to determine the item's - -- bucket; if the bucket is not empty, it calls Equivalent_Elements to - -- compare Item to each element in the bucket. If the search succeeds, Find - -- returns a cursor designating the node containing the equivalent element; - -- otherwise, it returns No_Element. - - function Contains (Container : Set; Item : Element_Type) return Boolean; - -- Equivalent to Find (Container, Item) /= No_Element - - function Equivalent_Elements (Left, Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Elements with the elements of - -- the nodes designated by cursors Left and Right. - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean; - -- Returns the result of calling Equivalent_Elements with element of the - -- node designated by Left and element Right. - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Elements with element Left and - -- the element of the node designated by Right. - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - -- Calls Process for each node in the set - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Forward_Iterator'Class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - package Generic_Keys is - - function Key (Position : Cursor) return Key_Type; - -- Applies generic formal operation Key to the element of the node - -- designated by Position. - - function Element (Container : Set; Key : Key_Type) return Element_Type; - -- Searches (as per the key-based Find) for the node containing Key, and - -- returns the associated element. - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type); - -- Searches (as per the key-based Find) for the node containing Key, and - -- then replaces the element of that node (as per the element-based - -- Replace_Element). - - procedure Exclude (Container : in out Set; Key : Key_Type); - -- Searches for Key in the set, and if found, removes its node from the - -- set and then deallocates it. The search works by first calling Hash - -- (on Key) to determine the bucket; if the bucket is not empty, it - -- calls Equivalent_Keys to compare parameter Key to the value of - -- generic formal operation Key applied to element of each node in the - -- bucket. - - procedure Delete (Container : in out Set; Key : Key_Type); - -- Deletes the node containing Key as per Exclude, with the difference - -- that Constraint_Error is raised if Key is not found. - - function Find (Container : Set; Key : Key_Type) return Cursor; - -- Searches for the node containing Key, and returns a cursor - -- designating the node. The search works by first calling Hash (on Key) - -- to determine the bucket. If the bucket is not empty, the search - -- compares Key to the element of each node in the bucket, and returns - -- the matching node. The comparison itself works by applying the - -- generic formal Key operation to the element of the node, and then - -- calling generic formal operation Equivalent_Keys. - - function Contains (Container : Set; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - -- Calls Process with the element of the node designated by Position, - -- but with the restriction that the key-value of the element is not - -- modified. The operation first makes a copy of the value returned by - -- applying generic formal operation Key on the element of the node, and - -- then calls Process with the element. The operation verifies that the - -- key-part has not been modified by calling generic formal operation - -- Equivalent_Keys to compare the saved key-value to the value returned - -- by applying generic formal operation Key to the post-Process value of - -- element. If the key values compare equal then the operation - -- completes. Otherwise, the node is removed from the map and - -- Program_Error is raised. - - type Reference_Type (Element : not null access Element_Type) is private - with Implicit_Dereference => Element; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type; - - private - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - package Impl is new Helpers.Generic_Implementation; - - type Reference_Control_Type is - new Impl.Reference_Control_Type with - record - Container : Set_Access; - Index : Hash_Type; - Old_Pos : Cursor; - Old_Hash : Hash_Type; - end record; - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - use Ada.Streams; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - end Generic_Keys; - -private - pragma Inline (Next); - - type Node_Type; - type Node_Access is access Node_Type; - - type Element_Access is access all Element_Type; - - type Node_Type is limited record - Element : Element_Access; - Next : Node_Access; - end record; - - package HT_Types is - new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); - - type Set is new Ada.Finalization.Controlled with record - HT : HT_Types.Hash_Table_Type; - end record; - - overriding procedure Adjust (Container : in out Set); - - overriding procedure Finalize (Container : in out Set); - - use HT_Types, HT_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - type Cursor is record - Container : Set_Access; - Node : Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Set : constant Set := (Controlled with others => <>); - - No_Element : constant Cursor := (Container => null, Node => null); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Forward_Iterator with - record - Container : Set_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Indefinite_Hashed_Sets; diff --git a/gcc/ada/a-cimutr.adb b/gcc/ada/a-cimutr.adb deleted file mode 100644 index 756b512..0000000 --- a/gcc/ada/a-cimutr.adb +++ /dev/null @@ -1,2698 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Multiway_Trees is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - -------------------- - -- Root_Iterator -- - -------------------- - - type Root_Iterator is abstract new Limited_Controlled and - Tree_Iterator_Interfaces.Forward_Iterator with - record - Container : Tree_Access; - Subtree : Tree_Node_Access; - end record; - - overriding procedure Finalize (Object : in out Root_Iterator); - - ----------------------- - -- Subtree_Iterator -- - ----------------------- - - type Subtree_Iterator is new Root_Iterator with null record; - - overriding function First (Object : Subtree_Iterator) return Cursor; - - overriding function Next - (Object : Subtree_Iterator; - Position : Cursor) return Cursor; - - --------------------- - -- Child_Iterator -- - --------------------- - - type Child_Iterator is new Root_Iterator and - Tree_Iterator_Interfaces.Reversible_Iterator with null record; - - overriding function First (Object : Child_Iterator) return Cursor; - - overriding function Next - (Object : Child_Iterator; - Position : Cursor) return Cursor; - - overriding function Last (Object : Child_Iterator) return Cursor; - - overriding function Previous - (Object : Child_Iterator; - Position : Cursor) return Cursor; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Root_Node (Container : Tree) return Tree_Node_Access; - - procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - procedure Deallocate_Node (X : in out Tree_Node_Access); - - procedure Deallocate_Children - (Subtree : Tree_Node_Access; - Count : in out Count_Type); - - procedure Deallocate_Subtree - (Subtree : in out Tree_Node_Access; - Count : in out Count_Type); - - function Equal_Children - (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; - - function Equal_Subtree - (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; - - procedure Iterate_Children - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)); - - procedure Iterate_Subtree - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)); - - procedure Copy_Children - (Source : Children_Type; - Parent : Tree_Node_Access; - Count : in out Count_Type); - - procedure Copy_Subtree - (Source : Tree_Node_Access; - Parent : Tree_Node_Access; - Target : out Tree_Node_Access; - Count : in out Count_Type); - - function Find_In_Children - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access; - - function Find_In_Subtree - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access; - - function Child_Count (Children : Children_Type) return Count_Type; - - function Subtree_Node_Count - (Subtree : Tree_Node_Access) return Count_Type; - - function Is_Reachable (From, To : Tree_Node_Access) return Boolean; - - procedure Remove_Subtree (Subtree : Tree_Node_Access); - - procedure Insert_Subtree_Node - (Subtree : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access); - - procedure Insert_Subtree_List - (First : Tree_Node_Access; - Last : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access); - - procedure Splice_Children - (Target_Parent : Tree_Node_Access; - Before : Tree_Node_Access; - Source_Parent : Tree_Node_Access); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Tree) return Boolean is - begin - return Equal_Children (Root_Node (Left), Root_Node (Right)); - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Tree) is - Source : constant Children_Type := Container.Root.Children; - Source_Count : constant Count_Type := Container.Count; - Target_Count : Count_Type; - - begin - -- We first restore the target container to its default-initialized - -- state, before we attempt any allocation, to ensure that invariants - -- are preserved in the event that the allocation fails. - - Container.Root.Children := Children_Type'(others => null); - Zero_Counts (Container.TC); - Container.Count := 0; - - -- Copy_Children returns a count of the number of nodes that it - -- allocates, but it works by incrementing the value that is passed in. - -- We must therefore initialize the count value before calling - -- Copy_Children. - - Target_Count := 0; - - -- Now we attempt the allocation of subtrees. The invariants are - -- satisfied even if the allocation fails. - - Copy_Children (Source, Root_Node (Container), Target_Count); - pragma Assert (Target_Count = Source_Count); - - Container.Count := Source_Count; - end Adjust; - - ------------------- - -- Ancestor_Find -- - ------------------- - - function Ancestor_Find - (Position : Cursor; - Item : Element_Type) return Cursor - is - R, N : Tree_Node_Access; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Commented-out pending ARG ruling. ??? - - -- if Checks and then - -- Position.Container /= Container'Unrestricted_Access - -- then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - - -- AI-0136 says to raise PE if Position equals the root node. This does - -- not seem correct, as this value is just the limiting condition of the - -- search. For now we omit this check pending a ruling from the ARG.??? - - -- if Checks and then Is_Root (Position) then - -- raise Program_Error with "Position cursor designates root"; - -- end if; - - R := Root_Node (Position.Container.all); - N := Position.Node; - while N /= R loop - if N.Element.all = Item then - return Cursor'(Position.Container, N); - end if; - - N := N.Parent; - end loop; - - return No_Element; - end Ancestor_Find; - - ------------------ - -- Append_Child -- - ------------------ - - procedure Append_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - First, Last : Tree_Node_Access; - Element : Element_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the - -- allocator in the loop below, because the one in this block would - -- have failed already. - - pragma Unsuppress (Accessibility_Check); - - begin - Element := new Element_Type'(New_Item); - end; - - First := new Tree_Node_Type'(Parent => Parent.Node, - Element => Element, - others => <>); - - Last := First; - - for J in Count_Type'(2) .. Count loop - - -- Reclaim other nodes if Storage_Error. ??? - - Element := new Element_Type'(New_Item); - Last.Next := new Tree_Node_Type'(Parent => Parent.Node, - Prev => Last, - Element => Element, - others => <>); - - Last := Last.Next; - end loop; - - Insert_Subtree_List - (First => First, - Last => Last, - Parent => Parent.Node, - Before => null); -- null means "insert at end of list" - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Container.Count := Container.Count + Count; - end Append_Child; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Tree; Source : Tree) is - Source_Count : constant Count_Type := Source.Count; - Target_Count : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; -- checks busy bit - - -- Copy_Children returns the number of nodes that it allocates, but it - -- does this by incrementing the count value passed in, so we must - -- initialize the count before calling Copy_Children. - - Target_Count := 0; - - -- Note that Copy_Children inserts the newly-allocated children into - -- their parent list only after the allocation of all the children has - -- succeeded. This preserves invariants even if the allocation fails. - - Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count); - pragma Assert (Target_Count = Source_Count); - - Target.Count := Source_Count; - end Assign; - - ----------------- - -- Child_Count -- - ----------------- - - function Child_Count (Parent : Cursor) return Count_Type is - begin - if Parent = No_Element then - return 0; - else - return Child_Count (Parent.Node.Children); - end if; - end Child_Count; - - function Child_Count (Children : Children_Type) return Count_Type is - Result : Count_Type; - Node : Tree_Node_Access; - - begin - Result := 0; - Node := Children.First; - while Node /= null loop - Result := Result + 1; - Node := Node.Next; - end loop; - - return Result; - end Child_Count; - - ----------------- - -- Child_Depth -- - ----------------- - - function Child_Depth (Parent, Child : Cursor) return Count_Type is - Result : Count_Type; - N : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Child = No_Element then - raise Constraint_Error with "Child cursor has no element"; - end if; - - if Checks and then Parent.Container /= Child.Container then - raise Program_Error with "Parent and Child in different containers"; - end if; - - Result := 0; - N := Child.Node; - while N /= Parent.Node loop - Result := Result + 1; - N := N.Parent; - - if Checks and then N = null then - raise Program_Error with "Parent is not ancestor of Child"; - end if; - end loop; - - return Result; - end Child_Depth; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Tree) is - Container_Count : Count_Type; - Children_Count : Count_Type; - - begin - TC_Check (Container.TC); - - -- We first set the container count to 0, in order to preserve - -- invariants in case the deallocation fails. (This works because - -- Deallocate_Children immediately removes the children from their - -- parent, and then does the actual deallocation.) - - Container_Count := Container.Count; - Container.Count := 0; - - -- Deallocate_Children returns the number of nodes that it deallocates, - -- but it does this by incrementing the count value that is passed in, - -- so we must first initialize the count return value before calling it. - - Children_Count := 0; - - -- See comment above. Deallocate_Children immediately removes the - -- children list from their parent node (here, the root of the tree), - -- and only after that does it attempt the actual deallocation. So even - -- if the deallocation fails, the representation invariants - - Deallocate_Children (Root_Node (Container), Children_Count); - pragma Assert (Children_Count = Container_Count); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Tree; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Tree) return Tree is - begin - return Target : Tree do - Copy_Children - (Source => Source.Root.Children, - Parent => Root_Node (Target), - Count => Target.Count); - - pragma Assert (Target.Count = Source.Count); - end return; - end Copy; - - ------------------- - -- Copy_Children -- - ------------------- - - procedure Copy_Children - (Source : Children_Type; - Parent : Tree_Node_Access; - Count : in out Count_Type) - is - pragma Assert (Parent /= null); - pragma Assert (Parent.Children.First = null); - pragma Assert (Parent.Children.Last = null); - - CC : Children_Type; - C : Tree_Node_Access; - - begin - -- We special-case the first allocation, in order to establish the - -- representation invariants for type Children_Type. - - C := Source.First; - - if C = null then - return; - end if; - - Copy_Subtree - (Source => C, - Parent => Parent, - Target => CC.First, - Count => Count); - - CC.Last := CC.First; - - -- The representation invariants for the Children_Type list have been - -- established, so we can now copy the remaining children of Source. - - C := C.Next; - while C /= null loop - Copy_Subtree - (Source => C, - Parent => Parent, - Target => CC.Last.Next, - Count => Count); - - CC.Last.Next.Prev := CC.Last; - CC.Last := CC.Last.Next; - - C := C.Next; - end loop; - - -- We add the newly-allocated children to their parent list only after - -- the allocation has succeeded, in order to preserve invariants of the - -- parent. - - Parent.Children := CC; - end Copy_Children; - - ------------------ - -- Copy_Subtree -- - ------------------ - - procedure Copy_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : Cursor) - is - Target_Subtree : Tree_Node_Access; - Target_Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Target'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Source = No_Element then - return; - end if; - - if Checks and then Is_Root (Source) then - raise Constraint_Error with "Source cursor designates root"; - end if; - - -- Copy_Subtree returns a count of the number of nodes that it - -- allocates, but it works by incrementing the value that is passed in. - -- We must therefore initialize the count value before calling - -- Copy_Subtree. - - Target_Count := 0; - - Copy_Subtree - (Source => Source.Node, - Parent => Parent.Node, - Target => Target_Subtree, - Count => Target_Count); - - pragma Assert (Target_Subtree /= null); - pragma Assert (Target_Subtree.Parent = Parent.Node); - pragma Assert (Target_Count >= 1); - - Insert_Subtree_Node - (Subtree => Target_Subtree, - Parent => Parent.Node, - Before => Before.Node); - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Target.Count := Target.Count + Target_Count; - end Copy_Subtree; - - procedure Copy_Subtree - (Source : Tree_Node_Access; - Parent : Tree_Node_Access; - Target : out Tree_Node_Access; - Count : in out Count_Type) - is - E : constant Element_Access := new Element_Type'(Source.Element.all); - - begin - Target := new Tree_Node_Type'(Element => E, - Parent => Parent, - others => <>); - - Count := Count + 1; - - Copy_Children - (Source => Source.Children, - Parent => Target, - Count => Count); - end Copy_Subtree; - - ------------------------- - -- Deallocate_Children -- - ------------------------- - - procedure Deallocate_Children - (Subtree : Tree_Node_Access; - Count : in out Count_Type) - is - pragma Assert (Subtree /= null); - - CC : Children_Type := Subtree.Children; - C : Tree_Node_Access; - - begin - -- We immediately remove the children from their parent, in order to - -- preserve invariants in case the deallocation fails. - - Subtree.Children := Children_Type'(others => null); - - while CC.First /= null loop - C := CC.First; - CC.First := C.Next; - - Deallocate_Subtree (C, Count); - end loop; - end Deallocate_Children; - - --------------------- - -- Deallocate_Node -- - --------------------- - - procedure Deallocate_Node (X : in out Tree_Node_Access) is - procedure Free_Node is - new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access); - - -- Start of processing for Deallocate_Node - - begin - if X /= null then - Free_Element (X.Element); - Free_Node (X); - end if; - end Deallocate_Node; - - ------------------------ - -- Deallocate_Subtree -- - ------------------------ - - procedure Deallocate_Subtree - (Subtree : in out Tree_Node_Access; - Count : in out Count_Type) - is - begin - Deallocate_Children (Subtree, Count); - Deallocate_Node (Subtree); - Count := Count + 1; - end Deallocate_Subtree; - - --------------------- - -- Delete_Children -- - --------------------- - - procedure Delete_Children - (Container : in out Tree; - Parent : Cursor) - is - Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - TC_Check (Container.TC); - - -- Deallocate_Children returns a count of the number of nodes - -- that it deallocates, but it works by incrementing the - -- value that is passed in. We must therefore initialize - -- the count value before calling Deallocate_Children. - - Count := 0; - - Deallocate_Children (Parent.Node, Count); - pragma Assert (Count <= Container.Count); - - Container.Count := Container.Count - Count; - end Delete_Children; - - ----------------- - -- Delete_Leaf -- - ----------------- - - procedure Delete_Leaf - (Container : in out Tree; - Position : in out Cursor) - is - X : Tree_Node_Access; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Checks and then not Is_Leaf (Position) then - raise Constraint_Error with "Position cursor does not designate leaf"; - end if; - - TC_Check (Container.TC); - - X := Position.Node; - Position := No_Element; - - -- Restore represention invariants before attempting the actual - -- deallocation. - - Remove_Subtree (X); - Container.Count := Container.Count - 1; - - -- It is now safe to attempt the deallocation. This leaf node has been - -- disassociated from the tree, so even if the deallocation fails, - -- representation invariants will remain satisfied. - - Deallocate_Node (X); - end Delete_Leaf; - - -------------------- - -- Delete_Subtree -- - -------------------- - - procedure Delete_Subtree - (Container : in out Tree; - Position : in out Cursor) - is - X : Tree_Node_Access; - Count : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - TC_Check (Container.TC); - - X := Position.Node; - Position := No_Element; - - -- Here is one case where a deallocation failure can result in the - -- violation of a representation invariant. We disassociate the subtree - -- from the tree now, but we only decrement the total node count after - -- we attempt the deallocation. However, if the deallocation fails, the - -- total node count will not get decremented. - - -- One way around this dilemma is to count the nodes in the subtree - -- before attempt to delete the subtree, but that is an O(n) operation, - -- so it does not seem worth it. - - -- Perhaps this is much ado about nothing, since the only way - -- deallocation can fail is if Controlled Finalization fails: this - -- propagates Program_Error so all bets are off anyway. ??? - - Remove_Subtree (X); - - -- Deallocate_Subtree returns a count of the number of nodes that it - -- deallocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Deallocate_Subtree. - - Count := 0; - - Deallocate_Subtree (X, Count); - pragma Assert (Count <= Container.Count); - - -- See comments above. We would prefer to do this sooner, but there's no - -- way to satisfy that goal without an potentially severe execution - -- penalty. - - Container.Count := Container.Count - Count; - end Delete_Subtree; - - ----------- - -- Depth -- - ----------- - - function Depth (Position : Cursor) return Count_Type is - Result : Count_Type; - N : Tree_Node_Access; - - begin - Result := 0; - N := Position.Node; - while N /= null loop - N := N.Parent; - Result := Result + 1; - end loop; - - return Result; - end Depth; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Node = Root_Node (Position.Container.all) - then - raise Program_Error with "Position cursor designates root"; - end if; - - return Position.Node.Element.all; - end Element; - - -------------------- - -- Equal_Children -- - -------------------- - - function Equal_Children - (Left_Subtree : Tree_Node_Access; - Right_Subtree : Tree_Node_Access) return Boolean - is - Left_Children : Children_Type renames Left_Subtree.Children; - Right_Children : Children_Type renames Right_Subtree.Children; - - L, R : Tree_Node_Access; - - begin - if Child_Count (Left_Children) /= Child_Count (Right_Children) then - return False; - end if; - - L := Left_Children.First; - R := Right_Children.First; - while L /= null loop - if not Equal_Subtree (L, R) then - return False; - end if; - - L := L.Next; - R := R.Next; - end loop; - - return True; - end Equal_Children; - - ------------------- - -- Equal_Subtree -- - ------------------- - - function Equal_Subtree - (Left_Position : Cursor; - Right_Position : Cursor) return Boolean - is - begin - if Checks and then Left_Position = No_Element then - raise Constraint_Error with "Left cursor has no element"; - end if; - - if Checks and then Right_Position = No_Element then - raise Constraint_Error with "Right cursor has no element"; - end if; - - if Left_Position = Right_Position then - return True; - end if; - - if Is_Root (Left_Position) then - if not Is_Root (Right_Position) then - return False; - end if; - - return Equal_Children (Left_Position.Node, Right_Position.Node); - end if; - - if Is_Root (Right_Position) then - return False; - end if; - - return Equal_Subtree (Left_Position.Node, Right_Position.Node); - end Equal_Subtree; - - function Equal_Subtree - (Left_Subtree : Tree_Node_Access; - Right_Subtree : Tree_Node_Access) return Boolean - is - begin - if Left_Subtree.Element.all /= Right_Subtree.Element.all then - return False; - end if; - - return Equal_Children (Left_Subtree, Right_Subtree); - end Equal_Subtree; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Root_Iterator) is - begin - Unbusy (Object.Container.TC); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Tree; - Item : Element_Type) return Cursor - is - N : constant Tree_Node_Access := - Find_In_Children (Root_Node (Container), Item); - - begin - if N = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, N); - end Find; - - ----------- - -- First -- - ----------- - - overriding function First (Object : Subtree_Iterator) return Cursor is - begin - if Object.Subtree = Root_Node (Object.Container.all) then - return First_Child (Root (Object.Container.all)); - else - return Cursor'(Object.Container, Object.Subtree); - end if; - end First; - - overriding function First (Object : Child_Iterator) return Cursor is - begin - return First_Child (Cursor'(Object.Container, Object.Subtree)); - end First; - - ----------------- - -- First_Child -- - ----------------- - - function First_Child (Parent : Cursor) return Cursor is - Node : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - Node := Parent.Node.Children.First; - - if Node = null then - return No_Element; - end if; - - return Cursor'(Parent.Container, Node); - end First_Child; - - ------------------------- - -- First_Child_Element -- - ------------------------- - - function First_Child_Element (Parent : Cursor) return Element_Type is - begin - return Element (First_Child (Parent)); - end First_Child_Element; - - ---------------------- - -- Find_In_Children -- - ---------------------- - - function Find_In_Children - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access - is - N, Result : Tree_Node_Access; - - begin - N := Subtree.Children.First; - while N /= null loop - Result := Find_In_Subtree (N, Item); - - if Result /= null then - return Result; - end if; - - N := N.Next; - end loop; - - return null; - end Find_In_Children; - - --------------------- - -- Find_In_Subtree -- - --------------------- - - function Find_In_Subtree - (Position : Cursor; - Item : Element_Type) return Cursor - is - Result : Tree_Node_Access; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Commented-out pending ruling from ARG. ??? - - -- if Checks and then - -- Position.Container /= Container'Unrestricted_Access - -- then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - - if Is_Root (Position) then - Result := Find_In_Children (Position.Node, Item); - - else - Result := Find_In_Subtree (Position.Node, Item); - end if; - - if Result = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Result); - end Find_In_Subtree; - - function Find_In_Subtree - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access - is - begin - if Subtree.Element.all = Item then - return Subtree; - end if; - - return Find_In_Children (Subtree, Item); - end Find_In_Subtree; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - if Position = No_Element then - return False; - end if; - - return Position.Node.Parent /= null; - end Has_Element; - - ------------------ - -- Insert_Child -- - ------------------ - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Position : Cursor; - pragma Unreferenced (Position); - - begin - Insert_Child (Container, Parent, Before, New_Item, Position, Count); - end Insert_Child; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - First : Tree_Node_Access; - Last : Tree_Node_Access; - Element : Element_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Parent cursor not parent of Before"; - end if; - end if; - - if Count = 0 then - Position := No_Element; -- Need ruling from ARG ??? - return; - end if; - - TC_Check (Container.TC); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the - -- allocator in the loop below, because the one in this block would - -- have failed already. - - pragma Unsuppress (Accessibility_Check); - - begin - Element := new Element_Type'(New_Item); - end; - - First := new Tree_Node_Type'(Parent => Parent.Node, - Element => Element, - others => <>); - - Last := First; - for J in Count_Type'(2) .. Count loop - - -- Reclaim other nodes if Storage_Error. ??? - - Element := new Element_Type'(New_Item); - Last.Next := new Tree_Node_Type'(Parent => Parent.Node, - Prev => Last, - Element => Element, - others => <>); - - Last := Last.Next; - end loop; - - Insert_Subtree_List - (First => First, - Last => Last, - Parent => Parent.Node, - Before => Before.Node); - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Container.Count := Container.Count + Count; - - Position := Cursor'(Parent.Container, First); - end Insert_Child; - - ------------------------- - -- Insert_Subtree_List -- - ------------------------- - - procedure Insert_Subtree_List - (First : Tree_Node_Access; - Last : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access) - is - pragma Assert (Parent /= null); - C : Children_Type renames Parent.Children; - - begin - -- This is a simple utility operation to insert a list of nodes (from - -- First..Last) as children of Parent. The Before node specifies where - -- the new children should be inserted relative to the existing - -- children. - - if First = null then - pragma Assert (Last = null); - return; - end if; - - pragma Assert (Last /= null); - pragma Assert (Before = null or else Before.Parent = Parent); - - if C.First = null then - C.First := First; - C.First.Prev := null; - C.Last := Last; - C.Last.Next := null; - - elsif Before = null then -- means "insert after existing nodes" - C.Last.Next := First; - First.Prev := C.Last; - C.Last := Last; - C.Last.Next := null; - - elsif Before = C.First then - Last.Next := C.First; - C.First.Prev := Last; - C.First := First; - C.First.Prev := null; - - else - Before.Prev.Next := First; - First.Prev := Before.Prev; - Last.Next := Before; - Before.Prev := Last; - end if; - end Insert_Subtree_List; - - ------------------------- - -- Insert_Subtree_Node -- - ------------------------- - - procedure Insert_Subtree_Node - (Subtree : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access) - is - begin - -- This is a simple wrapper operation to insert a single child into the - -- Parent's children list. - - Insert_Subtree_List - (First => Subtree, - Last => Subtree, - Parent => Parent, - Before => Before); - end Insert_Subtree_Node; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Tree) return Boolean is - begin - return Container.Root.Children.First = null; - end Is_Empty; - - ------------- - -- Is_Leaf -- - ------------- - - function Is_Leaf (Position : Cursor) return Boolean is - begin - if Position = No_Element then - return False; - end if; - - return Position.Node.Children.First = null; - end Is_Leaf; - - ------------------ - -- Is_Reachable -- - ------------------ - - function Is_Reachable (From, To : Tree_Node_Access) return Boolean is - pragma Assert (From /= null); - pragma Assert (To /= null); - - N : Tree_Node_Access; - - begin - N := From; - while N /= null loop - if N = To then - return True; - end if; - - N := N.Parent; - end loop; - - return False; - end Is_Reachable; - - ------------- - -- Is_Root -- - ------------- - - function Is_Root (Position : Cursor) return Boolean is - begin - if Position.Container = null then - return False; - end if; - - return Position = Root (Position.Container.all); - end Is_Root; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Tree; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - Iterate_Children - (Container => Container'Unrestricted_Access, - Subtree => Root_Node (Container), - Process => Process); - end Iterate; - - function Iterate (Container : Tree) - return Tree_Iterator_Interfaces.Forward_Iterator'Class - is - begin - return Iterate_Subtree (Root (Container)); - end Iterate; - - ---------------------- - -- Iterate_Children -- - ---------------------- - - procedure Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)) - is - C : Tree_Node_Access; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - C := Parent.Node.Children.First; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Next; - end loop; - end Iterate_Children; - - procedure Iterate_Children - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)) - is - Node : Tree_Node_Access; - - begin - -- This is a helper function to recursively iterate over all the nodes - -- in a subtree, in depth-first fashion. This particular helper just - -- visits the children of this subtree, not the root of the subtree node - -- itself. This is useful when starting from the ultimate root of the - -- entire tree (see Iterate), as that root does not have an element. - - Node := Subtree.Children.First; - while Node /= null loop - Iterate_Subtree (Container, Node, Process); - Node := Node.Next; - end loop; - end Iterate_Children; - - function Iterate_Children - (Container : Tree; - Parent : Cursor) - return Tree_Iterator_Interfaces.Reversible_Iterator'Class - is - C : constant Tree_Access := Container'Unrestricted_Access; - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= C then - raise Program_Error with "Parent cursor not in container"; - end if; - - return It : constant Child_Iterator := - Child_Iterator'(Limited_Controlled with - Container => C, - Subtree => Parent.Node) - do - Busy (C.TC); - end return; - end Iterate_Children; - - --------------------- - -- Iterate_Subtree -- - --------------------- - - function Iterate_Subtree - (Position : Cursor) - return Tree_Iterator_Interfaces.Forward_Iterator'Class - is - C : constant Tree_Access := Position.Container; - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Implement Vet for multiway trees??? - -- pragma Assert (Vet (Position), "bad subtree cursor"); - - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => Position.Container, - Subtree => Position.Node) - do - Busy (C.TC); - end return; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Position : Cursor; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Position.Container.TC'Unrestricted_Access); - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Is_Root (Position) then - Iterate_Children (Position.Container, Position.Node, Process); - else - Iterate_Subtree (Position.Container, Position.Node, Process); - end if; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)) - is - begin - -- This is a helper function to recursively iterate over all the nodes - -- in a subtree, in depth-first fashion. It first visits the root of the - -- subtree, then visits its children. - - Process (Cursor'(Container, Subtree)); - Iterate_Children (Container, Subtree, Process); - end Iterate_Subtree; - - ---------- - -- Last -- - ---------- - - overriding function Last (Object : Child_Iterator) return Cursor is - begin - return Last_Child (Cursor'(Object.Container, Object.Subtree)); - end Last; - - ---------------- - -- Last_Child -- - ---------------- - - function Last_Child (Parent : Cursor) return Cursor is - Node : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - Node := Parent.Node.Children.Last; - - if Node = null then - return No_Element; - end if; - - return (Parent.Container, Node); - end Last_Child; - - ------------------------ - -- Last_Child_Element -- - ------------------------ - - function Last_Child_Element (Parent : Cursor) return Element_Type is - begin - return Element (Last_Child (Parent)); - end Last_Child_Element; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Tree; Source : in out Tree) is - Node : Tree_Node_Access; - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Clear; -- checks busy bit - - Target.Root.Children := Source.Root.Children; - Source.Root.Children := Children_Type'(others => null); - - Node := Target.Root.Children.First; - while Node /= null loop - Node.Parent := Root_Node (Target); - Node := Node.Next; - end loop; - - Target.Count := Source.Count; - Source.Count := 0; - end Move; - - ---------- - -- Next -- - ---------- - - function Next - (Object : Subtree_Iterator; - Position : Cursor) return Cursor - is - Node : Tree_Node_Access; - - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong tree"; - end if; - - Node := Position.Node; - - if Node.Children.First /= null then - return Cursor'(Object.Container, Node.Children.First); - end if; - - while Node /= Object.Subtree loop - if Node.Next /= null then - return Cursor'(Object.Container, Node.Next); - end if; - - Node := Node.Parent; - end loop; - - return No_Element; - end Next; - - function Next - (Object : Child_Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong tree"; - end if; - - return Next_Sibling (Position); - end Next; - - ------------------ - -- Next_Sibling -- - ------------------ - - function Next_Sibling (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Node.Next = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Position.Node.Next); - end Next_Sibling; - - procedure Next_Sibling (Position : in out Cursor) is - begin - Position := Next_Sibling (Position); - end Next_Sibling; - - ---------------- - -- Node_Count -- - ---------------- - - function Node_Count (Container : Tree) return Count_Type is - begin - -- Container.Count is the number of nodes we have actually allocated. We - -- cache the value specifically so this Node_Count operation can execute - -- in O(1) time, which makes it behave similarly to how the Length - -- selector function behaves for other containers. - -- - -- The cached node count value only describes the nodes we have - -- allocated; the root node itself is not included in that count. The - -- Node_Count operation returns a value that includes the root node - -- (because the RM says so), so we must add 1 to our cached value. - - return 1 + Container.Count; - end Node_Count; - - ------------ - -- Parent -- - ------------ - - function Parent (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Node.Parent = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Position.Node.Parent); - end Parent; - - ------------------- - -- Prepent_Child -- - ------------------- - - procedure Prepend_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - First, Last : Tree_Node_Access; - Element : Element_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the - -- allocator in the loop below, because the one in this block would - -- have failed already. - - pragma Unsuppress (Accessibility_Check); - - begin - Element := new Element_Type'(New_Item); - end; - - First := new Tree_Node_Type'(Parent => Parent.Node, - Element => Element, - others => <>); - - Last := First; - - for J in Count_Type'(2) .. Count loop - - -- Reclaim other nodes if Storage_Error. ??? - - Element := new Element_Type'(New_Item); - Last.Next := new Tree_Node_Type'(Parent => Parent.Node, - Prev => Last, - Element => Element, - others => <>); - - Last := Last.Next; - end loop; - - Insert_Subtree_List - (First => First, - Last => Last, - Parent => Parent.Node, - Before => Parent.Node.Children.First); - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Container.Count := Container.Count + Count; - end Prepend_Child; - - -------------- - -- Previous -- - -------------- - - overriding function Previous - (Object : Child_Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong tree"; - end if; - - return Previous_Sibling (Position); - end Previous; - - ---------------------- - -- Previous_Sibling -- - ---------------------- - - function Previous_Sibling (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Node.Prev = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Position.Node.Prev); - end Previous_Sibling; - - procedure Previous_Sibling (Position : in out Cursor) is - begin - Position := Previous_Sibling (Position); - end Previous_Sibling; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Tree'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - Process (Position.Node.Element.all); - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Tree) - is - procedure Read_Children (Subtree : Tree_Node_Access); - - function Read_Subtree - (Parent : Tree_Node_Access) return Tree_Node_Access; - - Total_Count : Count_Type'Base; - -- Value read from the stream that says how many elements follow - - Read_Count : Count_Type'Base; - -- Actual number of elements read from the stream - - ------------------- - -- Read_Children -- - ------------------- - - procedure Read_Children (Subtree : Tree_Node_Access) is - pragma Assert (Subtree /= null); - pragma Assert (Subtree.Children.First = null); - pragma Assert (Subtree.Children.Last = null); - - Count : Count_Type'Base; - -- Number of child subtrees - - C : Children_Type; - - begin - Count_Type'Read (Stream, Count); - - if Checks and then Count < 0 then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - if Count = 0 then - return; - end if; - - C.First := Read_Subtree (Parent => Subtree); - C.Last := C.First; - - for J in Count_Type'(2) .. Count loop - C.Last.Next := Read_Subtree (Parent => Subtree); - C.Last.Next.Prev := C.Last; - C.Last := C.Last.Next; - end loop; - - -- Now that the allocation and reads have completed successfully, it - -- is safe to link the children to their parent. - - Subtree.Children := C; - end Read_Children; - - ------------------ - -- Read_Subtree -- - ------------------ - - function Read_Subtree - (Parent : Tree_Node_Access) return Tree_Node_Access - is - Element : constant Element_Access := - new Element_Type'(Element_Type'Input (Stream)); - - Subtree : constant Tree_Node_Access := - new Tree_Node_Type' - (Parent => Parent, Element => Element, others => <>); - - begin - Read_Count := Read_Count + 1; - - Read_Children (Subtree); - - return Subtree; - end Read_Subtree; - - -- Start of processing for Read - - begin - Container.Clear; -- checks busy bit - - Count_Type'Read (Stream, Total_Count); - - if Checks and then Total_Count < 0 then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - if Total_Count = 0 then - return; - end if; - - Read_Count := 0; - - Read_Children (Root_Node (Container)); - - if Checks and then Read_Count /= Total_Count then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - Container.Count := Total_Count; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to read tree cursor from stream"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Tree; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - -------------------- - -- Remove_Subtree -- - -------------------- - - procedure Remove_Subtree (Subtree : Tree_Node_Access) is - C : Children_Type renames Subtree.Parent.Children; - - begin - -- This is a utility operation to remove a subtree node from its - -- parent's list of children. - - if C.First = Subtree then - pragma Assert (Subtree.Prev = null); - - if C.Last = Subtree then - pragma Assert (Subtree.Next = null); - C.First := null; - C.Last := null; - - else - C.First := Subtree.Next; - C.First.Prev := null; - end if; - - elsif C.Last = Subtree then - pragma Assert (Subtree.Next = null); - C.Last := Subtree.Prev; - C.Last.Next := null; - - else - Subtree.Prev.Next := Subtree.Next; - Subtree.Next.Prev := Subtree.Prev; - end if; - end Remove_Subtree; - - ---------------------- - -- Replace_Element -- - ---------------------- - - procedure Replace_Element - (Container : in out Tree; - Position : Cursor; - New_Item : Element_Type) - is - E, X : Element_Access; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - TE_Check (Container.TC); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - E := new Element_Type'(New_Item); - end; - - X := Position.Node.Element; - Position.Node.Element := E; - - Free_Element (X); - end Replace_Element; - - ------------------------------ - -- Reverse_Iterate_Children -- - ------------------------------ - - procedure Reverse_Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)) - is - C : Tree_Node_Access; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - C := Parent.Node.Children.Last; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Prev; - end loop; - end Reverse_Iterate_Children; - - ---------- - -- Root -- - ---------- - - function Root (Container : Tree) return Cursor is - begin - return (Container'Unrestricted_Access, Root_Node (Container)); - end Root; - - --------------- - -- Root_Node -- - --------------- - - function Root_Node (Container : Tree) return Tree_Node_Access is - begin - return Container.Root'Unrestricted_Access; - end Root_Node; - - --------------------- - -- Splice_Children -- - --------------------- - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Source_Parent : Cursor) - is - Count : Count_Type; - - begin - if Checks and then Target_Parent = No_Element then - raise Constraint_Error with "Target_Parent cursor has no element"; - end if; - - if Checks and then Target_Parent.Container /= Target'Unrestricted_Access - then - raise Program_Error - with "Target_Parent cursor not in Target container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error - with "Before cursor not in Target container"; - end if; - - if Checks and then Before.Node.Parent /= Target_Parent.Node then - raise Constraint_Error - with "Before cursor not child of Target_Parent"; - end if; - end if; - - if Checks and then Source_Parent = No_Element then - raise Constraint_Error with "Source_Parent cursor has no element"; - end if; - - if Checks and then Source_Parent.Container /= Source'Unrestricted_Access - then - raise Program_Error - with "Source_Parent cursor not in Source container"; - end if; - - if Target'Address = Source'Address then - if Target_Parent = Source_Parent then - return; - end if; - - TC_Check (Target.TC); - - if Checks and then Is_Reachable (From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - -- We cache the count of the nodes we have allocated, so that operation - -- Node_Count can execute in O(1) time. But that means we must count the - -- nodes in the subtree we remove from Source and insert into Target, in - -- order to keep the count accurate. - - Count := Subtree_Node_Count (Source_Parent.Node); - pragma Assert (Count >= 1); - - Count := Count - 1; -- because Source_Parent node does not move - - Splice_Children - (Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - - Source.Count := Source.Count - Count; - Target.Count := Target.Count + Count; - end Splice_Children; - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source_Parent : Cursor) - is - begin - if Checks and then Target_Parent = No_Element then - raise Constraint_Error with "Target_Parent cursor has no element"; - end if; - - if Checks and then - Target_Parent.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Target_Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Target_Parent.Node then - raise Constraint_Error - with "Before cursor not child of Target_Parent"; - end if; - end if; - - if Checks and then Source_Parent = No_Element then - raise Constraint_Error with "Source_Parent cursor has no element"; - end if; - - if Checks and then - Source_Parent.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Source_Parent cursor not in container"; - end if; - - if Target_Parent = Source_Parent then - return; - end if; - - TC_Check (Container.TC); - - if Checks and then Is_Reachable (From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - end Splice_Children; - - procedure Splice_Children - (Target_Parent : Tree_Node_Access; - Before : Tree_Node_Access; - Source_Parent : Tree_Node_Access) - is - CC : constant Children_Type := Source_Parent.Children; - C : Tree_Node_Access; - - begin - -- This is a utility operation to remove the children from Source parent - -- and insert them into Target parent. - - Source_Parent.Children := Children_Type'(others => null); - - -- Fix up the Parent pointers of each child to designate its new Target - -- parent. - - C := CC.First; - while C /= null loop - C.Parent := Target_Parent; - C := C.Next; - end loop; - - Insert_Subtree_List - (First => CC.First, - Last => CC.Last, - Parent => Target_Parent, - Before => Before); - end Splice_Children; - - -------------------- - -- Splice_Subtree -- - -------------------- - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Position : in out Cursor) - is - Subtree_Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Target'Unrestricted_Access then - raise Program_Error with "Parent cursor not in Target container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with "Before cursor not in Target container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Source'Unrestricted_Access then - raise Program_Error with "Position cursor not in Source container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Target'Address = Source'Address then - if Position.Node.Parent = Parent.Node then - if Position.Node = Before.Node then - return; - end if; - - if Position.Node.Next = Before.Node then - return; - end if; - end if; - - TC_Check (Target.TC); - - if Checks and then - Is_Reachable (From => Parent.Node, To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Position.Node); - - Position.Node.Parent := Parent.Node; - Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - -- This is an unfortunate feature of this API: we must count the nodes - -- in the subtree that we remove from the source tree, which is an O(n) - -- operation. It would have been better if the Tree container did not - -- have a Node_Count selector; a user that wants the number of nodes in - -- the tree could simply call Subtree_Node_Count, with the understanding - -- that such an operation is O(n). - -- - -- Of course, we could choose to implement the Node_Count selector as an - -- O(n) operation, which would turn this splice operation into an O(1) - -- operation. ??? - - Subtree_Count := Subtree_Node_Count (Position.Node); - pragma Assert (Subtree_Count <= Source.Count); - - Remove_Subtree (Position.Node); - Source.Count := Source.Count - Subtree_Count; - - Position.Node.Parent := Parent.Node; - Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); - - Target.Count := Target.Count + Subtree_Count; - - Position.Container := Target'Unrestricted_Access; - end Splice_Subtree; - - procedure Splice_Subtree - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : Cursor) - is - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - - -- Should this be PE instead? Need ARG confirmation. ??? - - raise Constraint_Error with "Position cursor designates root"; - end if; - - if Position.Node.Parent = Parent.Node then - if Position.Node = Before.Node then - return; - end if; - - if Position.Node.Next = Before.Node then - return; - end if; - end if; - - TC_Check (Container.TC); - - if Checks and then - Is_Reachable (From => Parent.Node, To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Position.Node); - - Position.Node.Parent := Parent.Node; - Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); - end Splice_Subtree; - - ------------------------ - -- Subtree_Node_Count -- - ------------------------ - - function Subtree_Node_Count (Position : Cursor) return Count_Type is - begin - if Position = No_Element then - return 0; - end if; - - return Subtree_Node_Count (Position.Node); - end Subtree_Node_Count; - - function Subtree_Node_Count - (Subtree : Tree_Node_Access) return Count_Type - is - Result : Count_Type; - Node : Tree_Node_Access; - - begin - Result := 1; - Node := Subtree.Children.First; - while Node /= null loop - Result := Result + Subtree_Node_Count (Node); - Node := Node.Next; - end loop; - - return Result; - end Subtree_Node_Count; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Tree; - I, J : Cursor) - is - begin - if Checks and then I = No_Element then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor not in container"; - end if; - - if Checks and then Is_Root (I) then - raise Program_Error with "I cursor designates root"; - end if; - - if I = J then -- make this test sooner??? - return; - end if; - - if Checks and then J = No_Element then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor not in container"; - end if; - - if Checks and then Is_Root (J) then - raise Program_Error with "J cursor designates root"; - end if; - - TE_Check (Container.TC); - - declare - EI : constant Element_Access := I.Node.Element; - - begin - I.Node.Element := J.Node.Element; - J.Node.Element := EI; - end; - end Swap; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Tree; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - Process (Position.Node.Element.all); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Tree) - is - procedure Write_Children (Subtree : Tree_Node_Access); - procedure Write_Subtree (Subtree : Tree_Node_Access); - - -------------------- - -- Write_Children -- - -------------------- - - procedure Write_Children (Subtree : Tree_Node_Access) is - CC : Children_Type renames Subtree.Children; - C : Tree_Node_Access; - - begin - Count_Type'Write (Stream, Child_Count (CC)); - - C := CC.First; - while C /= null loop - Write_Subtree (C); - C := C.Next; - end loop; - end Write_Children; - - ------------------- - -- Write_Subtree -- - ------------------- - - procedure Write_Subtree (Subtree : Tree_Node_Access) is - begin - Element_Type'Output (Stream, Subtree.Element.all); - Write_Children (Subtree); - end Write_Subtree; - - -- Start of processing for Write - - begin - Count_Type'Write (Stream, Container.Count); - - if Container.Count = 0 then - return; - end if; - - Write_Children (Root_Node (Container)); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to write tree cursor to stream"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Multiway_Trees; diff --git a/gcc/ada/a-cimutr.ads b/gcc/ada/a-cimutr.ads deleted file mode 100644 index 7edb0d1..0000000 --- a/gcc/ada/a-cimutr.ads +++ /dev/null @@ -1,456 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type (<>) is private; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Multiway_Trees is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type Tree is tagged private - with Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Tree); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Tree : constant Tree; - - No_Element : constant Cursor; - function Has_Element (Position : Cursor) return Boolean; - - package Tree_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function Equal_Subtree - (Left_Position : Cursor; - Right_Position : Cursor) return Boolean; - - function "=" (Left, Right : Tree) return Boolean; - - function Is_Empty (Container : Tree) return Boolean; - - function Node_Count (Container : Tree) return Count_Type; - - function Subtree_Node_Count (Position : Cursor) return Count_Type; - - function Depth (Position : Cursor) return Count_Type; - - function Is_Root (Position : Cursor) return Boolean; - - function Is_Leaf (Position : Cursor) return Boolean; - - function Root (Container : Tree) return Cursor; - - procedure Clear (Container : in out Tree); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Tree; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Tree; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Tree; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Tree; Source : Tree); - - function Copy (Source : Tree) return Tree; - - procedure Move (Target : in out Tree; Source : in out Tree); - - procedure Delete_Leaf - (Container : in out Tree; - Position : in out Cursor); - - procedure Delete_Subtree - (Container : in out Tree; - Position : in out Cursor); - - procedure Swap - (Container : in out Tree; - I, J : Cursor); - - function Find - (Container : Tree; - Item : Element_Type) return Cursor; - - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Find_In_Subtree this way: - -- - -- function Find_In_Subtree - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - - function Find_In_Subtree - (Position : Cursor; - Item : Element_Type) return Cursor; - - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Ancestor_Find this way: - -- - -- function Ancestor_Find - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - - function Ancestor_Find - (Position : Cursor; - Item : Element_Type) return Cursor; - - function Contains - (Container : Tree; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : Tree; - Process : not null access procedure (Position : Cursor)); - - procedure Iterate_Subtree - (Position : Cursor; - Process : not null access procedure (Position : Cursor)); - - function Iterate (Container : Tree) - return Tree_Iterator_Interfaces.Forward_Iterator'Class; - - function Iterate_Subtree (Position : Cursor) - return Tree_Iterator_Interfaces.Forward_Iterator'Class; - - function Iterate_Children - (Container : Tree; - Parent : Cursor) - return Tree_Iterator_Interfaces.Reversible_Iterator'Class; - - function Child_Count (Parent : Cursor) return Count_Type; - - function Child_Depth (Parent, Child : Cursor) return Count_Type; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Delete_Children - (Container : in out Tree; - Parent : Cursor); - - procedure Copy_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : Cursor); - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Position : in out Cursor); - - procedure Splice_Subtree - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : Cursor); - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Source_Parent : Cursor); - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source_Parent : Cursor); - - function Parent (Position : Cursor) return Cursor; - - function First_Child (Parent : Cursor) return Cursor; - - function First_Child_Element (Parent : Cursor) return Element_Type; - - function Last_Child (Parent : Cursor) return Cursor; - - function Last_Child_Element (Parent : Cursor) return Element_Type; - - function Next_Sibling (Position : Cursor) return Cursor; - - function Previous_Sibling (Position : Cursor) return Cursor; - - procedure Next_Sibling (Position : in out Cursor); - - procedure Previous_Sibling (Position : in out Cursor); - - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Iterate_Children this way: - -- - -- procedure Iterate_Children - -- (Container : Tree; - -- Parent : Cursor; - -- Process : not null access procedure (Position : Cursor)); - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - - procedure Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)); - -private - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - type Tree_Node_Type; - type Tree_Node_Access is access all Tree_Node_Type; - - type Children_Type is record - First : Tree_Node_Access; - Last : Tree_Node_Access; - end record; - - type Element_Access is access all Element_Type; - - type Tree_Node_Type is record - Parent : Tree_Node_Access; - Prev : Tree_Node_Access; - Next : Tree_Node_Access; - Children : Children_Type; - Element : Element_Access; - end record; - - use Ada.Finalization; - - -- The Count component of type Tree represents the number of nodes that - -- have been (dynamically) allocated. It does not include the root node - -- itself. As implementors, we decide to cache this value, so that the - -- selector function Node_Count can execute in O(1) time, in order to be - -- consistent with the behavior of the Length selector function for other - -- standard container library units. This does mean, however, that the - -- two-container forms for Splice_XXX (that move subtrees across tree - -- containers) will execute in O(n) time, because we must count the number - -- of nodes in the subtree(s) that get moved. (We resolve the tension - -- between Node_Count and Splice_XXX in favor of Node_Count, under the - -- assumption that Node_Count is the more common operation). - - type Tree is new Controlled with record - Root : aliased Tree_Node_Type; - TC : aliased Tamper_Counts; - Count : Count_Type := 0; - end record; - - overriding procedure Adjust (Container : in out Tree); - - overriding procedure Finalize (Container : in out Tree) renames Clear; - - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Tree); - - for Tree'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Tree); - - for Tree'Read use Read; - - type Tree_Access is access all Tree; - for Tree_Access'Storage_Size use 0; - - type Cursor is record - Container : Tree_Access; - Node : Tree_Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Tree'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Tree : constant Tree := (Controlled with others => <>); - - No_Element : constant Cursor := (others => <>); - -end Ada.Containers.Indefinite_Multiway_Trees; diff --git a/gcc/ada/a-ciorma.adb b/gcc/ada/a-ciorma.adb deleted file mode 100644 index 5d07151..0000000 --- a/gcc/ada/a-ciorma.adb +++ /dev/null @@ -1,1686 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Red_Black_Trees.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Ordered_Maps is - pragma Suppress (All_Checks); - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------------- - -- Node Access Subprograms -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color (Node : Node_Access) return Color_Type; - pragma Inline (Color); - - function Left (Node : Node_Access) return Node_Access; - pragma Inline (Left); - - function Parent (Node : Node_Access) return Node_Access; - pragma Inline (Parent); - - function Right (Node : Node_Access) return Node_Access; - pragma Inline (Right); - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access); - pragma Inline (Set_Parent); - - procedure Set_Left (Node : Node_Access; Left : Node_Access); - pragma Inline (Set_Left); - - procedure Set_Right (Node : Node_Access; Right : Node_Access); - pragma Inline (Set_Right); - - procedure Set_Color (Node : Node_Access; Color : Color_Type); - pragma Inline (Set_Color); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - procedure Free (X : in out Node_Access); - - function Is_Equal_Node_Node - (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Operations (Tree_Types); - - procedure Delete_Tree is - new Tree_Operations.Generic_Delete_Tree (Free); - - function Copy_Tree is - new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); - - use Tree_Operations; - - package Key_Ops is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - procedure Free_Key is - new Ada.Unchecked_Deallocation (Key_Type, Key_Access); - - procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; - end if; - - if Checks and then Left.Node.Key = null then - raise Program_Error with "Left cursor in ""<"" is bad"; - end if; - - if Checks and then Right.Node.Key = null then - raise Program_Error with "Right cursor in ""<"" is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor in ""<"" is bad"); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor in ""<"" is bad"); - - return Left.Node.Key.all < Right.Node.Key.all; - end "<"; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; - end if; - - if Checks and then Left.Node.Key = null then - raise Program_Error with "Left cursor in ""<"" is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor in ""<"" is bad"); - - return Left.Node.Key.all < Right; - end "<"; - - function "<" (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; - end if; - - if Checks and then Right.Node.Key = null then - raise Program_Error with "Right cursor in ""<"" is bad"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor in ""<"" is bad"); - - return Left < Right.Node.Key.all; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - begin - return Is_Equal (Left.Tree, Right.Tree); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of "">"" equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of "">"" equals No_Element"; - end if; - - if Checks and then Left.Node.Key = null then - raise Program_Error with "Left cursor in ""<"" is bad"; - end if; - - if Checks and then Right.Node.Key = null then - raise Program_Error with "Right cursor in ""<"" is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor in "">"" is bad"); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor in "">"" is bad"); - - return Right.Node.Key.all < Left.Node.Key.all; - end ">"; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of "">"" equals No_Element"; - end if; - - if Checks and then Left.Node.Key = null then - raise Program_Error with "Left cursor in ""<"" is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor in "">"" is bad"); - - return Right < Left.Node.Key.all; - end ">"; - - function ">" (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of "">"" equals No_Element"; - end if; - - if Checks and then Right.Node.Key = null then - raise Program_Error with "Right cursor in ""<"" is bad"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor in "">"" is bad"); - - return Right.Node.Key.all < Left; - end ">"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); - - procedure Adjust (Container : in out Map) is - begin - Adjust (Container.Tree); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Item (Node : Node_Access); - pragma Inline (Insert_Item); - - procedure Insert_Items is - new Tree_Operations.Generic_Iteration (Insert_Item); - - ----------------- - -- Insert_Item -- - ----------------- - - procedure Insert_Item (Node : Node_Access) is - begin - Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all); - end Insert_Item; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Insert_Items (Source.Tree); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree); - - procedure Clear (Container : in out Map) is - begin - Clear (Container.Tree); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Access) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor in Constant_Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Map) return Map is - begin - return Target : Map do - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - K : Key_Access := new Key_Type'(Source.Key.all); - E : Element_Access; - - begin - E := new Element_Type'(Source.Element.all); - - return new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Source.Color, - Key => K, - Element => E); - - exception - when others => - Free_Key (K); - Free_Element (E); - raise; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Map; - Position : in out Cursor) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Delete equals No_Element"; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with "Position cursor of Delete is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Delete designates wrong map"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor of Delete is bad"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); - Free (Position.Node); - - Position.Container := null; - end Delete; - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then X = null then - raise Constraint_Error with "key not in map"; - end if; - - Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Map) is - X : Node_Access := Container.Tree.First; - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Map) is - X : Node_Access := Container.Tree.Last; - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Element equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor of function Element is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of function Element is bad"); - - return Position.Node.Element.all; - end Element; - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - return Node.Element.all; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - return (if Left < Right or else Right < Left then False else True); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Node_Access := Key_Ops.Find (Container.Tree, Key); - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.Tree.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - T : Tree_Type renames Container.Tree; - begin - return (if T.First = null then No_Element - else Cursor'(Container'Unrestricted_Access, T.First)); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Object.Container.First; - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Map) return Element_Type is - T : Tree_Type renames Container.Tree; - begin - if Checks and then T.First = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.First.Element.all; - end First_Element; - - --------------- - -- First_Key -- - --------------- - - function First_Key (Container : Map) return Key_Type is - T : Tree_Type renames Container.Tree; - begin - if Checks and then T.First = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.First.Key.all; - end First_Key; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Floor; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X = null then - return; - end if; - - X.Parent := X; - X.Left := X; - X.Right := X; - - begin - Free_Key (X.Key); - - exception - when others => - X.Key := null; - - begin - Free_Element (X.Element); - exception - when others => - X.Element := null; - end; - - Deallocate (X); - raise; - end; - - begin - Free_Element (X.Element); - - exception - when others => - X.Element := null; - - Deallocate (X); - raise; - end; - - Deallocate (X); - end Free; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - K : Key_Access; - E : Element_Access; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.Tree.TC); - - K := Position.Node.Key; - E := Position.Node.Element; - - Position.Node.Key := new Key_Type'(Key); - - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Position.Node.Element := new Element_Type'(New_Item); - - exception - when others => - Free_Key (K); - raise; - end; - - Free_Key (K); - Free_Element (E); - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - Node : Node_Access := new Node_Type; - - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Key := new Key_Type'(Key); - Node.Element := new Element_Type'(New_Item); - return Node; - - exception - when others => - - -- On exception, deallocate key and elem. Note that free - -- deallocates both the key and the elem. - - Free (Node); - raise; - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container.Tree, - Key, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with "key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Container.Tree.Length = 0; - end Is_Empty; - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is - begin - return (if L.Key.all < R.Key.all then False - elsif R.Key.all < L.Key.all then False - else L.Element.all = R.Element.all); - end Is_Equal_Node_Node; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - -- k > node same as node < k - - return Right.Key.all < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean is - begin - return Left < Right.Key.all; - end Is_Less_Key_Node; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (Container.Tree); - end Iterate; - - function Iterate - (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null) - do - Busy (Container.Tree.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : Map; - Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong map"; - end if; - - pragma Assert (Vet (Container.Tree, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.Tree.TC'Unrestricted_Access.all); - end return; - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Key equals No_Element"; - end if; - - if Checks and then Position.Node.Key = null then - raise Program_Error with - "Position cursor of function Key is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of function Key is bad"); - - return Position.Node.Key.all; - end Key; - - ---------- - -- Last -- - ---------- - - function Last (Container : Map) return Cursor is - T : Tree_Type renames Container.Tree; - begin - return (if T.Last = null then No_Element - else Cursor'(Container'Unrestricted_Access, T.Last)); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Object.Container.Last; - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Map) return Element_Type is - T : Tree_Type renames Container.Tree; - - begin - if Checks and then T.Last = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.Last.Element.all; - end Last_Element; - - -------------- - -- Last_Key -- - -------------- - - function Last_Key (Container : Map) return Key_Type is - T : Tree_Type renames Container.Tree; - - begin - if Checks and then T.Last = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.Last.Key.all; - end Last_Key; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Access) return Node_Access is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Tree.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move is new Tree_Operations.Generic_Move (Clear); - - procedure Move (Target : in out Map; Source : in out Map) is - begin - Move (Target => Target.Tree, Source => Source.Tree); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Key /= null); - pragma Assert (Position.Node.Element /= null); - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of Next is bad"); - - declare - Node : constant Node_Access := - Tree_Operations.Next (Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong map"; - end if; - - return Next (Position); - end Next; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Access) return Node_Access is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Position.Node /= null); - pragma Assert (Position.Node.Key /= null); - pragma Assert (Position.Node.Element /= null); - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of Previous is bad"); - - declare - Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Previous; - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong map"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with - "Position cursor of Query_Element is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of Query_Element is bad"); - - declare - T : Tree_Type renames Position.Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - pragma Inline (Read_Node); - - procedure Read is - new Tree_Operations.Generic_Read (Clear, Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - begin - Node.Key := new Key_Type'(Key_Type'Input (Stream)); - Node.Element := new Element_Type'(Element_Type'Input (Stream)); - return Node; - exception - when others => - Free (Node); -- Note that Free deallocates key and elem too - raise; - end Read_Node; - - -- Start of processing for Read - - begin - Read (Stream, Container.Tree); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor in function Reference is bad"); - - declare - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type - is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - K : Key_Access; - E : Element_Access; - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - TE_Check (Container.Tree.TC); - - K := Node.Key; - E := Node.Element; - - Node.Key := new Key_Type'(Key); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(New_Item); - - exception - when others => - Free_Key (K); - raise; - end; - - Free_Key (K); - Free_Element (E); - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Replace_Element equals No_Element"; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with - "Position cursor of Replace_Element is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Replace_Element designates wrong map"; - end if; - - TE_Check (Container.Tree.TC); - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor of Replace_Element is bad"); - - declare - X : Element_Access := Position.Node.Element; - - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Position.Node.Element := new Element_Type'(New_Item); - Free_Element (X); - end; - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (Container.Tree); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Access) return Node_Access is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : Node_Access; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : Node_Access; Left : Node_Access) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : Node_Access; Right : Node_Access) is - begin - Node.Right := Right; - end Set_Right; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Update_Element equals No_Element"; - end if; - - if Checks and then - (Position.Node.Key = null or else Position.Node.Element = null) - then - raise Program_Error with - "Position cursor of Update_Element is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Update_Element designates wrong map"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor of Update_Element is bad"); - - declare - T : Tree_Type renames Position.Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key.all; - E : Element_Type renames Position.Node.Element.all; - begin - Process (K, E); - end; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - procedure Write is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Key_Type'Output (Stream, Node.Key.all); - Element_Type'Output (Stream, Node.Element.all); - end Write_Node; - - -- Start of processing for Write - - begin - Write (Stream, Container.Tree); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/a-ciorma.ads b/gcc/ada/a-ciorma.ads deleted file mode 100644 index fa65755..0000000 --- a/gcc/ada/a-ciorma.ads +++ /dev/null @@ -1,388 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Red_Black_Trees; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Key_Type (<>) is private; - type Element_Type (<>) is private; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Ordered_Maps is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - type Map is tagged private - with Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Map); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Map : constant Map; - - No_Element : constant Cursor; - function Has_Element (Position : Cursor) return Boolean; - - package Map_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Map) return Boolean; - - function Length (Container : Map) return Count_Type; - - function Is_Empty (Container : Map) return Boolean; - - procedure Clear (Container : in out Map); - - function Key (Position : Cursor) return Key_Type; - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)); - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Map; Source : Map); - - function Copy (Source : Map) return Map; - - procedure Move (Target : in out Map; Source : in out Map); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Exclude (Container : in out Map; Key : Key_Type); - - procedure Delete (Container : in out Map; Key : Key_Type); - - procedure Delete (Container : in out Map; Position : in out Cursor); - - procedure Delete_First (Container : in out Map); - - procedure Delete_Last (Container : in out Map); - - function First (Container : Map) return Cursor; - - function First_Element (Container : Map) return Element_Type; - - function First_Key (Container : Map) return Key_Type; - - function Last (Container : Map) return Cursor; - - function Last_Element (Container : Map) return Element_Type; - - function Last_Key (Container : Map) return Key_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find (Container : Map; Key : Key_Type) return Cursor; - - function Element (Container : Map; Key : Key_Type) return Element_Type; - - function Floor (Container : Map; Key : Key_Type) return Cursor; - - function Ceiling (Container : Map; Key : Key_Type) return Cursor; - - function Contains (Container : Map; Key : Key_Type) return Boolean; - - function "<" (Left, Right : Cursor) return Boolean; - - function ">" (Left, Right : Cursor) return Boolean; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean; - - function "<" (Left : Key_Type; Right : Cursor) return Boolean; - - function ">" (Left : Key_Type; Right : Cursor) return Boolean; - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - - -- The map container supports iteration in both the forward and reverse - -- directions, hence these constructor functions return an object that - -- supports the Reversible_Iterator interface. - - function Iterate - (Container : Map) - return Map_Iterator_Interfaces.Reversible_Iterator'Class; - - function Iterate - (Container : Map; - Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'Class; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type; - type Node_Access is access Node_Type; - - type Key_Access is access Key_Type; - type Element_Access is access all Element_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Key : Key_Access; - Element : Element_Access; - end record; - - package Tree_Types is new Red_Black_Trees.Generic_Tree_Types - (Node_Type, - Node_Access); - - type Map is new Ada.Finalization.Controlled with record - Tree : Tree_Types.Tree_Type; - end record; - - overriding procedure Adjust (Container : in out Map); - - overriding procedure Finalize (Container : in out Map) renames Clear; - - use Red_Black_Trees; - use Tree_Types, Tree_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; - - type Cursor is record - Container : Map_Access; - Node : Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Map : constant Map := (Controlled with others => <>); - - No_Element : constant Cursor := Cursor'(null, null); - - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Reversible_Iterator with - record - Container : Map_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/a-ciormu.adb b/gcc/ada/a-ciormu.adb deleted file mode 100644 index 4bf00c6..0000000 --- a/gcc/ada/a-ciormu.adb +++ /dev/null @@ -1,2013 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Red_Black_Trees.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Ordered_Multisets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------------- - -- Node Access Subprograms -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color (Node : Node_Access) return Color_Type; - pragma Inline (Color); - - function Left (Node : Node_Access) return Node_Access; - pragma Inline (Left); - - function Parent (Node : Node_Access) return Node_Access; - pragma Inline (Parent); - - function Right (Node : Node_Access) return Node_Access; - pragma Inline (Right); - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access); - pragma Inline (Set_Parent); - - procedure Set_Left (Node : Node_Access; Left : Node_Access); - pragma Inline (Set_Left); - - procedure Set_Right (Node : Node_Access; Right : Node_Access); - pragma Inline (Set_Right); - - procedure Set_Color (Node : Node_Access; Color : Color_Type); - pragma Inline (Set_Color); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - procedure Free (X : in out Node_Access); - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access); - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access); - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Less_Node_Node); - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Operations (Tree_Types); - - procedure Delete_Tree is - new Tree_Operations.Generic_Delete_Tree (Free); - - function Copy_Tree is - new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); - - use Tree_Operations; - - procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - package Set_Ops is - new Generic_Set_Operations - (Tree_Operations => Tree_Operations, - Insert_With_Hint => Insert_With_Hint, - Copy_Tree => Copy_Tree, - Delete_Tree => Delete_Tree, - Is_Less => Is_Less_Node_Node, - Free => Free); - - package Element_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - if Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left.Node.Element.all < Right.Node.Element.all; - end "<"; - - function "<" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - return Left.Node.Element.all < Right; - end "<"; - - function "<" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left < Right.Node.Element.all; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - return Is_Equal (Left.Tree, Right.Tree); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - if Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - -- L > R same as R < L - - return Right.Node.Element.all < Left.Node.Element.all; - end ">"; - - function ">" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - return Right < Left.Node.Element.all; - end ">"; - - function ">" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - return Right.Node.Element.all < Left; - end ">"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust is - new Tree_Operations.Generic_Adjust (Copy_Tree); - - procedure Adjust (Container : in out Set) is - begin - Adjust (Container.Tree); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Target.Union (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := - Element_Keys.Ceiling (Container.Tree, Item); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear is - new Tree_Operations.Generic_Clear (Delete_Tree); - - procedure Clear (Container : in out Set) is - begin - Clear (Container.Tree); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Access) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Constant_Reference"); - - -- Note: in predefined container units, the creation of a reference - -- increments the busy bit of the container, and its finalization - -- decrements it. In the absence of control machinery, this tampering - -- protection is missing. - - declare - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - pragma Unreferenced (T); - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element, - Control => (Container => Container'Unrestricted_Access)) - do - null; - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set) return Set is - begin - return Target : Set do - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - X : Element_Access := new Element_Type'(Source.Element.all); - - begin - return new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Source.Color, - Element => X); - - exception - when others => - Free_Element (X); - raise; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Item : Element_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Element_Keys.Ceiling (Tree, Item); - Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); - X : Node_Access; - - begin - if Node = Done then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - - exit when Node = Done; - end loop; - end Delete; - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Delete"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); - Free (Position.Node); - - Position.Container := null; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.First; - - begin - if X = null then - return; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.Last; - - begin - if X = null then - return; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Difference (Target.Tree, Source.Tree); - end Difference; - - function Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Element"); - - return Position.Node.Element.all; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is - begin - if L.Element.all < R.Element.all then - return False; - elsif R.Element.all < L.Element.all then - return False; - else - return True; - end if; - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Tree, Right.Tree); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Element_Keys.Ceiling (Tree, Item); - Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); - X : Node_Access; - - begin - while Node /= Done loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end loop; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Find; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - Unbusy (Object.Container.Tree.TC); - end Finalize; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - if Container.Tree.First = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Container.Tree.First); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Object.Container.First; - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - begin - if Container.Tree.First = null then - raise Constraint_Error with "set is empty"; - end if; - - pragma Assert (Container.Tree.First.Element /= null); - return Container.Tree.First.Element.all; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Floor; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X = null then - return; - end if; - - X.Parent := X; - X.Left := X; - X.Right := X; - - begin - Free_Element (X.Element); - exception - when others => - X.Element := null; - Deallocate (X); - raise; - end; - - Deallocate (X); - end Free; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Key_Node); - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Ceiling; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Key_Keys.Ceiling (Tree, Key); - Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); - X : Node_Access; - - begin - if Node = Done then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - - exit when Node = Done; - end loop; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Node = null then - raise Constraint_Error with "key not in set"; - end if; - - return Node.Element.all; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Key_Keys.Ceiling (Tree, Key); - Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); - X : Node_Access; - - begin - while Node /= Done loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end loop; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Floor; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - return Key (Right.Element.all) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Key (Right.Element.all); - end Is_Less_Key_Node; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Key_Keys.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T, Key); - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Position.Node.Element = null then - raise Program_Error with - "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Key"); - - return Key (Position.Node.Element.all); - end Key; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - ------------- - -- Iterate -- - ------------- - - procedure Local_Reverse_Iterate is - new Key_Keys.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T, Key); - end Reverse_Iterate; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - Tree : Tree_Type renames Container.Tree; - Node : constant Node_Access := Position.Node; - - begin - if Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Tree, Node), - "bad cursor in Update_Element"); - - declare - E : Element_Type renames Node.Element.all; - K : constant Key_Type := Key (E); - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Process (E); - - if Equivalent_Keys (Left => K, Right => Key (E)) then - return; - end if; - end; - - -- Delete_Node checks busy-bit - - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); - - Insert_New_Item : declare - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - Node.Color := Red_Black_Trees.Red; - Node.Parent := null; - Node.Left := null; - Node.Right := null; - - return Node; - end New_Node; - - Result : Node_Access; - - -- Start of processing for Insert_New_Item - - begin - Unconditional_Insert - (Tree => Tree, - Key => Node.Element.all, - Node => Result); - - pragma Assert (Result = Node); - end Insert_New_Item; - end Update_Element; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - pragma Unreferenced (Position); - begin - Insert (Container, New_Item, Position); - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor) - is - begin - Insert_Sans_Hint (Container.Tree, New_Item, Position.Node); - Position.Container := Container'Unrestricted_Access; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - Element : Element_Access := new Element_Type'(New_Item); - - begin - return new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red_Black_Trees.Red, - Element => Element); - - exception - when others => - Free_Element (Element); - raise; - end New_Node; - - -- Start of processing for Insert_Sans_Hint - - begin - Unconditional_Insert (Tree, New_Item, Node); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Insert_Sans_Hint); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - X : Element_Access := new Element_Type'(Src_Node.Element.all); - - begin - return new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red, - Element => X); - - exception - when others => - Free_Element (X); - raise; - end New_Node; - - -- Start of processing for Insert_With_Hint - - begin - Local_Insert_With_Hint - (Dst_Tree, - Dst_Hint, - Src_Node.Element.all, - Dst_Node); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - begin - Set_Ops.Intersection (Target.Tree, Source.Tree); - end Intersection; - - function Intersection (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Tree.Length = 0; - end Is_Empty; - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element.all = R.Element.all; - end Is_Equal_Node_Node; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - -- e > node same as node < e - - return Right.Element.all < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Right.Element.all; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element.all < R.Element.all; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - begin - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Element_Keys.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T, Item); - end Iterate; - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T); - end Iterate; - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'Class - is - S : constant Set_Access := Container'Unrestricted_Access; - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := (Limited_Controlled with S, null) do - Busy (S.Tree.TC); - end return; - end Iterate; - - function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'Class - is - S : constant Set_Access := Container'Unrestricted_Access; - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this is a - -- partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this is - -- a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with S, Start.Node) - do - Busy (S.Tree.TC); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - if Container.Tree.Last = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Object.Container.Last; - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Container.Tree.Last = null then - raise Constraint_Error with "set is empty"; - end if; - - pragma Assert (Container.Tree.Last.Element /= null); - return Container.Tree.Last.Element.all; - end Last_Element; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Access) return Node_Access is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Tree.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move is - new Tree_Operations.Generic_Move (Clear); - - procedure Move (Target : in out Set; Source : in out Set) is - begin - Move (Target => Target.Tree, Source => Source.Tree); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Next"); - - declare - Node : constant Node_Access := - Tree_Operations.Next (Position.Node); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - begin - return Set_Ops.Overlap (Left.Tree, Right.Tree); - end Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Access) return Node_Access is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Previous; - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong set"; - end if; - - return Previous (Position); - end Previous; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Query_Element"); - - declare - T : Tree_Type renames Position.Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Position.Node.Element.all); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - pragma Inline (Read_Node); - - procedure Read is - new Tree_Operations.Generic_Read (Clear, Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - begin - Node.Element := new Element_Type'(Element_Type'Input (Stream)); - return Node; - exception - when others => - Free (Node); -- Note that Free deallocates elem too - raise; - end Read_Node; - - -- Start of processing for Read - - begin - Read (Stream, Container.Tree); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type) - is - begin - if Item < Node.Element.all - or else Node.Element.all < Item - then - null; - else - TE_Check (Tree.TC); - - declare - X : Element_Access := Node.Element; - - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(Item); - Free_Element (X); - end; - - return; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - - Insert_New_Item : declare - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(Item); -- OK if fails - Node.Color := Red_Black_Trees.Red; - Node.Parent := null; - Node.Left := null; - Node.Right := null; - - return Node; - end New_Node; - - Result : Node_Access; - - X : Element_Access := Node.Element; - - -- Start of processing for Insert_New_Item - - begin - Unconditional_Insert - (Tree => Tree, - Key => Item, - Node => Result); - pragma Assert (Result = Node); - - Free_Element (X); -- OK if fails - end Insert_New_Item; - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container.Tree, Position.Node, New_Item); - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Element_Keys.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T, Item); - end Reverse_Iterate; - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Access) return Node_Access is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : Node_Access; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : Node_Access; Left : Node_Access) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : Node_Access; Right : Node_Access) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Tree : Tree_Type; - Node : Node_Access; - pragma Unreferenced (Node); - begin - Insert_Sans_Hint (Tree, New_Item, Node); - return Set'(Controlled with Tree); - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - begin - Set_Ops.Union (Target.Tree, Source.Tree); - end Union; - - function Union (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Union (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Union; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - procedure Write is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Element_Type'Output (Stream, Node.Element.all); - end Write_Node; - - -- Start of processing for Write - - begin - Write (Stream, Container.Tree); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; -end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciormu.ads b/gcc/ada/a-ciormu.ads deleted file mode 100644 index 4eab5b1..0000000 --- a/gcc/ada/a-ciormu.ads +++ /dev/null @@ -1,566 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- The indefinite ordered multiset container is similar to the indefinite --- ordered set, but with the difference that multiple equivalent elements are --- allowed. It also provides additional operations, to iterate over items that --- are equivalent. - -private with Ada.Containers.Red_Black_Trees; -private with Ada.Finalization; -private with Ada.Streams; -with Ada.Iterator_Interfaces; - -generic - type Element_Type (<>) is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Ordered_Multisets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean; - -- Returns False if Left is less than Right, or Right is less than Left; - -- otherwise, it returns True. - - type Set is tagged private - with Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Set : constant Set; - -- The default value for set objects declared without an explicit - -- initialization expression. - - No_Element : constant Cursor; - -- The default value for cursor objects declared without an explicit - -- initialization expression. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - -- If Left denotes the same set object as Right, then equality returns - -- True. If the length of Left is different from the length of Right, then - -- it returns False. Otherwise, set equality iterates over Left and Right, - -- comparing the element of Left to the element of Right using the equality - -- operator for elements. If the elements compare False, then the iteration - -- terminates and set equality returns False. Otherwise, if all elements - -- compare True, then set equality returns True. - - function Equivalent_Sets (Left, Right : Set) return Boolean; - -- Similar to set equality, but with the difference that elements are - -- compared for equivalence instead of equality. - - function To_Set (New_Item : Element_Type) return Set; - -- Constructs a set object with New_Item as its single element - - function Length (Container : Set) return Count_Type; - -- Returns the total number of elements in Container - - function Is_Empty (Container : Set) return Boolean; - -- Returns True if Container.Length is 0 - - procedure Clear (Container : in out Set); - -- Deletes all elements from Container - - function Element (Position : Cursor) return Element_Type; - -- If Position equals No_Element, then Constraint_Error is raised. - -- Otherwise, function Element returns the element designed by Position. - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - -- If Position equals No_Element, then Constraint_Error is raised. If - -- Position is associated with a set different from Container, then - -- Program_Error is raised. If New_Item is equivalent to the element - -- designated by Position, then if Container is locked (element tampering - -- has been attempted), Program_Error is raised; otherwise, the element - -- designated by Position is assigned the value of New_Item. If New_Item is - -- not equivalent to the element designated by Position, then if the - -- container is busy (cursor tampering has been attempted), Program_Error - -- is raised; otherwise, the element designed by Position is assigned the - -- value of New_Item, and the node is moved to its new position (in - -- canonical insertion order). - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - -- If Position equals No_Element, then Constraint_Error is - -- raised. Otherwise, it calls Process with the element designated by - -- Position as the parameter. This call locks the container, so attempts to - -- change the value of the element while Process is executing (to "tamper - -- with elements") will raise Program_Error. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set) return Set; - - procedure Move (Target : in out Set; Source : in out Set); - -- If Target denotes the same object as Source, the operation does - -- nothing. If either Target or Source is busy (cursor tampering is - -- attempted), then it raises Program_Error. Otherwise, Target is cleared, - -- and the nodes from Source are moved (not copied) to Target (so Source - -- becomes empty). - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor); - -- Insert adds New_Item to Container, and returns cursor Position - -- designating the newly inserted node. The node is inserted after any - -- existing elements less than or equivalent to New_Item (and before any - -- elements greater than New_Item). Note that the issue of where the new - -- node is inserted relative to equivalent elements does not arise for - -- unique-key containers, since in that case the insertion would simply - -- fail. For a multiple-key container (the case here), insertion always - -- succeeds, and is defined such that the new item is positioned after any - -- equivalent elements already in the container. - - procedure Insert (Container : in out Set; New_Item : Element_Type); - -- Inserts New_Item in Container, but does not return a cursor designating - -- the newly-inserted node. - --- TODO: include Replace too??? --- --- procedure Replace --- (Container : in out Set; --- New_Item : Element_Type); - - procedure Exclude (Container : in out Set; Item : Element_Type); - -- Deletes from Container all of the elements equivalent to Item - - procedure Delete (Container : in out Set; Item : Element_Type); - -- Deletes from Container all of the elements equivalent to Item. If there - -- are no elements equivalent to Item, then it raises Constraint_Error. - - procedure Delete (Container : in out Set; Position : in out Cursor); - -- If Position equals No_Element, then Constraint_Error is raised. If - -- Position is associated with a set different from Container, then - -- Program_Error is raised. Otherwise, the node designated by Position is - -- removed from Container, and Position is set to No_Element. - - procedure Delete_First (Container : in out Set); - -- Removes the first node from Container - - procedure Delete_Last (Container : in out Set); - -- Removes the last node from Container - - procedure Union (Target : in out Set; Source : Set); - -- If Target is busy (cursor tampering is attempted), then Program_Error is - -- raised. Otherwise, it inserts each element of Source into Target. - -- Elements are inserted in the canonical order for multisets, such that - -- the elements from Source are inserted after equivalent elements already - -- in Target. - - function Union (Left, Right : Set) return Set; - -- Returns a set comprising the all elements from Left and all of the - -- elements from Right. The elements from Right follow the equivalent - -- elements from Left. - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - -- If Target denotes the same object as Source, the operation does - -- nothing. If Target is busy (cursor tampering is attempted), - -- Program_Error is raised. Otherwise, the elements in Target having no - -- equivalent element in Source are deleted from Target. - - function Intersection (Left, Right : Set) return Set; - -- If Left denotes the same object as Right, then the function returns a - -- copy of Left. Otherwise, it returns a set comprising the equivalent - -- elements from both Left and Right. Items are inserted in the result set - -- in canonical order, such that the elements from Left precede the - -- equivalent elements from Right. - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - -- If Target is busy (cursor tampering is attempted), then Program_Error is - -- raised. Otherwise, the elements in Target that are equivalent to - -- elements in Source are deleted from Target. - - function Difference (Left, Right : Set) return Set; - -- Returns a set comprising the elements from Left that have no equivalent - -- element in Right. - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - -- If Target is busy, then Program_Error is raised. Otherwise, the elements - -- in Target equivalent to elements in Source are deleted from Target, and - -- the elements in Source not equivalent to elements in Target are inserted - -- into Target. - - function Symmetric_Difference (Left, Right : Set) return Set; - -- Returns a set comprising the union of the elements from Target having no - -- equivalent in Source, and the elements of Source having no equivalent in - -- Target. - - function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - -- Returns True if Left contains an element equivalent to an element of - -- Right. - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - -- Returns True if every element in Subset has an equivalent element in - -- Of_Set. - - function First (Container : Set) return Cursor; - -- If Container is empty, the function returns No_Element. Otherwise, it - -- returns a cursor designating the smallest element. - - function First_Element (Container : Set) return Element_Type; - -- Equivalent to Element (First (Container)) - - function Last (Container : Set) return Cursor; - -- If Container is empty, the function returns No_Element. Otherwise, it - -- returns a cursor designating the largest element. - - function Last_Element (Container : Set) return Element_Type; - -- Equivalent to Element (Last (Container)) - - function Next (Position : Cursor) return Cursor; - -- If Position equals No_Element or Last (Container), the function returns - -- No_Element. Otherwise, it returns a cursor designating the node that - -- immediately follows (as per the insertion order) the node designated by - -- Position. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Previous (Position : Cursor) return Cursor; - -- If Position equals No_Element or First (Container), the function returns - -- No_Element. Otherwise, it returns a cursor designating the node that - -- immediately precedes (as per the insertion order) the node designated by - -- Position. - - procedure Previous (Position : in out Cursor); - -- Equivalent to Position := Previous (Position) - - function Find (Container : Set; Item : Element_Type) return Cursor; - -- Returns a cursor designating the first element in Container equivalent - -- to Item. If there is no equivalent element, it returns No_Element. - - function Floor (Container : Set; Item : Element_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to elements in Container, it returns a cursor designating the - -- first equivalent element. Otherwise, it returns a cursor designating the - -- largest element less than Item, or No_Element if all elements are - -- greater than Item. - - function Ceiling (Container : Set; Item : Element_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to elements of Container, it returns a cursor designating the - -- last equivalent element. Otherwise, it returns a cursor designating the - -- smallest element greater than Item, or No_Element if all elements are - -- less than Item. - - function Contains (Container : Set; Item : Element_Type) return Boolean; - -- Equivalent to Container.Find (Item) /= No_Element - - function "<" (Left, Right : Cursor) return Boolean; - -- Equivalent to Element (Left) < Element (Right) - - function ">" (Left, Right : Cursor) return Boolean; - -- Equivalent to Element (Right) < Element (Left) - - function "<" (Left : Cursor; Right : Element_Type) return Boolean; - -- Equivalent to Element (Left) < Right - - function ">" (Left : Cursor; Right : Element_Type) return Boolean; - -- Equivalent to Right < Element (Left) - - function "<" (Left : Element_Type; Right : Cursor) return Boolean; - -- Equivalent to Left < Element (Right) - - function ">" (Left : Element_Type; Right : Cursor) return Boolean; - -- Equivalent to Element (Right) < Left - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - -- Calls Process with a cursor designating each element of Container, in - -- order from Container.First to Container.Last. - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - -- Calls Process with a cursor designating each element of Container, in - -- order from Container.Last to Container.First. - - procedure Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to Item, - -- in order from Container.Floor (Item) to Container.Ceiling (Item). - - procedure Reverse_Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to Item, - -- in order from Container.Ceiling (Item) to Container.Floor (Item). - - function Iterate - (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : Set; - Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - -- Returns False if Left is less than Right, or Right is less than Left; - -- otherwise, it returns True. - - function Key (Position : Cursor) return Key_Type; - -- Equivalent to Key (Element (Position)) - - function Element (Container : Set; Key : Key_Type) return Element_Type; - -- Equivalent to Element (Find (Container, Key)) - - procedure Exclude (Container : in out Set; Key : Key_Type); - -- Deletes from Container any elements whose key is equivalent to Key - - procedure Delete (Container : in out Set; Key : Key_Type); - -- Deletes from Container any elements whose key is equivalent to - -- Key. If there are no such elements, then it raises Constraint_Error. - - function Find (Container : Set; Key : Key_Type) return Cursor; - -- Returns a cursor designating the first element in Container whose key - -- is equivalent to Key. If there is no equivalent element, it returns - -- No_Element. - - function Floor (Container : Set; Key : Key_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to the keys of elements in Container, it returns a cursor - -- designating the first such element. Otherwise, it returns a cursor - -- designating the largest element whose key is less than Item, or - -- No_Element if all keys are greater than Item. - - function Ceiling (Container : Set; Key : Key_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to the keys of elements of Container, it returns a cursor - -- designating the last such element. Otherwise, it returns a cursor - -- designating the smallest element whose key is greater than Item, or - -- No_Element if all keys are less than Item. - - function Contains (Container : Set; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - procedure Update_Element -- Update_Element_Preserving_Key ??? - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - -- If Position equals No_Element, then Constraint_Error is raised. If - -- Position is associated with a set object different from Container, - -- then Program_Error is raised. Otherwise, it makes a copy of the key - -- of the element designated by Position, and then calls Process with - -- the element as the parameter. Update_Element then compares the key - -- value obtained before calling Process to the key value obtained from - -- the element after calling Process. If the keys are equivalent then - -- the operation terminates. If Container is busy (cursor tampering has - -- been attempted), then Program_Error is raised. Otherwise, the node - -- is moved to its new position (in canonical order). - - procedure Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to - -- Key, in order from Floor (Container, Key) to - -- Ceiling (Container, Key). - - procedure Reverse_Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to - -- Key, in order from Ceiling (Container, Key) to - -- Floor (Container, Key). - - end Generic_Keys; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type; - type Node_Access is access Node_Type; - - type Element_Access is access Element_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Element : Element_Access; - end record; - - package Tree_Types is new Red_Black_Trees.Generic_Tree_Types - (Node_Type, - Node_Access); - - type Set is new Ada.Finalization.Controlled with record - Tree : Tree_Types.Tree_Type; - end record; - - overriding procedure Adjust (Container : in out Set); - - overriding procedure Finalize (Container : in out Set) renames Clear; - - use Red_Black_Trees; - use Tree_Types, Tree_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - -- In all predefined libraries the following type is controlled, for proper - -- management of tampering checks. For performance reason we omit this - -- machinery for multisets, which are used in a number of our tools. - - type Reference_Control_Type is record - Container : Set_Access; - end record; - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - type Cursor is record - Container : Set_Access; - Node : Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - No_Element : constant Cursor := Cursor'(null, null); - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - Empty_Set : constant Set := (Controlled with others => <>); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/a-ciorse.adb b/gcc/ada/a-ciorse.adb deleted file mode 100644 index 6ebc143..0000000 --- a/gcc/ada/a-ciorse.adb +++ /dev/null @@ -1,2191 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Red_Black_Trees.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); - -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Ordered_Sets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Color (Node : Node_Access) return Color_Type; - pragma Inline (Color); - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - procedure Free (X : in out Node_Access); - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean); - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Less_Node_Node); - - function Left (Node : Node_Access) return Node_Access; - pragma Inline (Left); - - function Parent (Node : Node_Access) return Node_Access; - pragma Inline (Parent); - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type); - - function Right (Node : Node_Access) return Node_Access; - pragma Inline (Right); - - procedure Set_Color (Node : Node_Access; Color : Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : Node_Access; Left : Node_Access); - pragma Inline (Set_Left); - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access); - pragma Inline (Set_Parent); - - procedure Set_Right (Node : Node_Access; Right : Node_Access); - pragma Inline (Set_Right); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - procedure Free_Element is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - package Tree_Operations is - new Red_Black_Trees.Generic_Operations (Tree_Types); - - procedure Delete_Tree is - new Tree_Operations.Generic_Delete_Tree (Free); - - function Copy_Tree is - new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); - - use Tree_Operations; - - package Element_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - package Set_Ops is - new Generic_Set_Operations - (Tree_Operations => Tree_Operations, - Insert_With_Hint => Insert_With_Hint, - Copy_Tree => Copy_Tree, - Delete_Tree => Delete_Tree, - Is_Less => Is_Less_Node_Node, - Free => Free); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Checks and then Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - if Checks and then Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left.Node.Element.all < Right.Node.Element.all; - end "<"; - - function "<" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - return Left.Node.Element.all < Right; - end "<"; - - function "<" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Checks and then Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left < Right.Node.Element.all; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element.all = R.Element.all; - end Is_Equal_Node_Node; - - -- Start of processing for "=" - - begin - return Is_Equal (Left.Tree, Right.Tree); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Checks and then Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - if Checks and then Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - -- L > R same as R < L - - return Right.Node.Element.all < Left.Node.Element.all; - end ">"; - - function ">" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Left.Node.Element = null then - raise Program_Error with "Left cursor is bad"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - return Right < Left.Node.Element.all; - end ">"; - - function ">" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - if Checks and then Right.Node.Element = null then - raise Program_Error with "Right cursor is bad"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - return Right.Node.Element.all < Left; - end ">"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); - - procedure Adjust (Container : in out Set) is - begin - Adjust (Container.Tree); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Target.Union (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := - Element_Keys.Ceiling (Container.Tree, Item); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear is - new Tree_Operations.Generic_Clear (Delete_Tree); - - procedure Clear (Container : in out Set) is - begin - Clear (Container.Tree); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Access) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert - (Vet (Container.Tree, Position.Node), - "bad cursor in Constant_Reference"); - - declare - Tree : Tree_Type renames Position.Container.all.Tree; - TC : constant Tamper_Counts_Access := - Tree.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set) return Set is - begin - return Target : Set do - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - Element : Element_Access := new Element_Type'(Source.Element.all); - - begin - return new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Source.Color, - Element => Element); - - exception - when others => - Free_Element (Element); - raise; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Delete"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); - Free (Position.Node); - Position.Container := null; - end Delete; - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : Node_Access := Element_Keys.Find (Container.Tree, Item); - begin - if Checks and then X = null then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.First; - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.Last; - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end if; - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Difference (Target.Tree, Source.Tree); - end Difference; - - function Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Element"); - - return Position.Node.Element.all; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - if Left < Right or else Right < Left then - return False; - else - return True; - end if; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is - begin - if L.Element.all < R.Element.all then - return False; - elsif R.Element.all < L.Element.all then - return False; - else - return True; - end if; - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Tree, Right.Tree); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : Node_Access := Element_Keys.Find (Container.Tree, Item); - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.Tree.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); - begin - if Node = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); - end if; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - return - (if Container.Tree.First = null then No_Element - else Cursor'(Container'Unrestricted_Access, Container.Tree.First)); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Object.Container.First; - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - begin - if Checks and then Container.Tree.First = null then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Tree.First.Element.all; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Floor; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X = null then - return; - end if; - - X.Parent := X; - X.Left := X; - X.Right := X; - - begin - Free_Element (X.Element); - exception - when others => - X.Element := null; - Deallocate (X); - raise; - end; - - Deallocate (X); - end Free; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Ceiling; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "Key not in set"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - declare - Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; - TC : constant Tamper_Counts_Access := - Tree.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element.all'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then X = null then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in set"; - end if; - - return Node.Element.all; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right or else Right < Left then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : Node_Access := Key_Keys.Find (Container.Tree, Key); - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Impl.Reference_Control_Type (Control).Finalize; - - if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) - then - Delete (Control.Container.all, Key (Control.Pos)); - raise Program_Error; - end if; - - Control.Container := null; - Control.Old_Key := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Floor; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - return Key (Right.Element.all) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Key (Right.Element.all); - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with - "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Key"); - - return Key (Position.Node.Element.all); - end Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container.Tree, Node, New_Item); - end Replace; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - pragma Assert - (Vet (Container.Tree, Position.Node), - "bad cursor in function Reference_Preserving_Key"); - - declare - Tree : Tree_Type renames Container.Tree; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element.all'Unchecked_Access, - Control => - (Controlled with - Tree.TC'Unrestricted_Access, - Container => Container'Access, - Pos => Position, - Old_Key => new Key_Type'(Key (Position)))) - do - Lock (Tree.TC); - end return; - end; - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "Key not in set"; - end if; - - if Checks and then Node.Element = null then - raise Program_Error with "Node has no element"; - end if; - - declare - Tree : Tree_Type renames Container.Tree; - begin - return R : constant Reference_Type := - (Element => Node.Element.all'Unchecked_Access, - Control => - (Controlled with - Tree.TC'Unrestricted_Access, - Container => Container'Access, - Pos => Find (Container, Key), - Old_Key => new Key_Type'(Key))) - do - Lock (Tree.TC); - end return; - end; - end Reference_Preserving_Key; - - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - Tree : Tree_Type renames Container.Tree; - - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Update_Element_Preserving_Key"); - - declare - E : Element_Type renames Position.Node.Element.all; - K : constant Key_Type := Key (E); - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Process (E); - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - declare - X : Node_Access := Position.Node; - begin - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end; - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - end Generic_Keys; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; - - X : Element_Access; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.Tree.TC); - - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - X := Position.Node.Element; - Position.Node.Element := new Element_Type'(New_Item); - Free_Element (X); - end; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert_Sans_Hint - (Container.Tree, - New_Item, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Conditional_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - Element : Element_Access := new Element_Type'(New_Item); - - begin - return new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red_Black_Trees.Red, - Element => Element); - - exception - when others => - Free_Element (Element); - raise; - end New_Node; - - -- Start of processing for Insert_Sans_Hint - - begin - Conditional_Insert_Sans_Hint - (Tree, - New_Item, - Node, - Inserted); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access) - is - Success : Boolean; - pragma Unreferenced (Success); - - function New_Node return Node_Access; - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Insert_Post, - Insert_Sans_Hint); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - Element : Element_Access := new Element_Type'(Src_Node.Element.all); - Node : Node_Access; - - begin - begin - Node := new Node_Type; - exception - when others => - Free_Element (Element); - raise; - end; - - Node.Element := Element; - return Node; - end New_Node; - - -- Start of processing for Insert_With_Hint - - begin - Insert_With_Hint - (Dst_Tree, - Dst_Hint, - Src_Node.Element.all, - Dst_Node, - Success); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - begin - Set_Ops.Intersection (Target.Tree, Source.Tree); - end Intersection; - - function Intersection (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Tree.Length = 0; - end Is_Empty; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - -- e > node same as node < e - - return Right.Element.all < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Right.Element.all; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element.all < R.Element.all; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - begin - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T); - end Iterate; - - function Iterate - (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null) - do - Busy (Container.Tree.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : Set; - Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this is a - -- partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this is - -- a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.Tree.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - return - (if Container.Tree.Last = null then No_Element - else Cursor'(Container'Unrestricted_Access, Container.Tree.Last)); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Object.Container.Last; - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Checks and then Container.Tree.Last = null then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Tree.Last.Element.all; - end Last_Element; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Access) return Node_Access is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Tree.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move is new Tree_Operations.Generic_Move (Clear); - - procedure Move (Target : in out Set; Source : in out Set) is - begin - Move (Target => Target.Tree, Source => Source.Tree); - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Next"); - - declare - Node : constant Node_Access := Tree_Operations.Next (Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - begin - return Set_Ops.Overlap (Left.Tree, Right.Tree); - end Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Access) return Node_Access is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Previous; - - function Previous - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong set"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Query_Element"); - - declare - T : Tree_Type renames Position.Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Position.Node.Element.all); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - pragma Inline (Read_Node); - - procedure Read is - new Tree_Operations.Generic_Read (Clear, Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - - begin - Node.Element := new Element_Type'(Element_Type'Input (Stream)); - return Node; - - exception - when others => - Free (Node); -- Note that Free deallocates elem too - raise; - end Read_Node; - - -- Start of processing for Read - - begin - Read (Stream, Container.Tree); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Node_Access := - Element_Keys.Find (Container.Tree, New_Item); - - X : Element_Access; - pragma Warnings (Off, X); - - begin - if Checks and then Node = null then - raise Constraint_Error with "attempt to replace element not in set"; - end if; - - TE_Check (Container.Tree.TC); - - declare - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - X := Node.Element; - Node.Element := new Element_Type'(New_Item); - Free_Element (X); - end; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type) - is - pragma Assert (Node /= null); - pragma Assert (Node.Element /= null); - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Local_Insert_Post, - Local_Insert_Sans_Hint); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - - -- The element allocator may need an accessibility check in the case - -- the actual type is class-wide or has access discriminants (see - -- RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(Item); -- OK if fails - Node.Color := Red; - Node.Parent := null; - Node.Right := null; - Node.Left := null; - return Node; - end New_Node; - - Hint : Node_Access; - Result : Node_Access; - Inserted : Boolean; - Compare : Boolean; - - X : Element_Access := Node.Element; - - -- Start of processing for Replace_Element - - begin - -- Replace_Element assigns value Item to the element designated by Node, - -- per certain semantic constraints, described as follows. - - -- If Item is equivalent to the element, then element is replaced and - -- there's nothing else to do. This is the easy case. - - -- If Item is not equivalent, then the node will (possibly) have to move - -- to some other place in the tree. This is slighly more complicated, - -- because we must ensure that Item is not equivalent to some other - -- element in the tree (in which case, the replacement is not allowed). - - -- Determine whether Item is equivalent to element on the specified - -- node. - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := (if Item < Node.Element.all then False - elsif Node.Element.all < Item then False - else True); - end; - - if Compare then - -- Item is equivalent to the node's element, so we will not have to - -- move the node. - - TE_Check (Tree.TC); - - declare - -- The element allocator may need an accessibility check in the - -- case the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(Item); - Free_Element (X); - end; - - return; - end if; - - -- The replacement Item is not equivalent to the element on the - -- specified node, which means that it will need to be re-inserted in a - -- different position in the tree. We must now determine whether Item is - -- equivalent to some other element in the tree (which would prohibit - -- the assignment and hence the move). - - -- Ceiling returns the smallest element equivalent or greater than the - -- specified Item; if there is no such element, then it returns null. - - Hint := Element_Keys.Ceiling (Tree, Item); - - if Hint /= null then - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Item < Hint.Element.all; - end; - - -- Item >= Hint.Element - - if Checks and then not Compare then - - -- Ceiling returns an element that is equivalent or greater - -- than Item. If Item is "not less than" the element, then - -- by elimination we know that Item is equivalent to the element. - - -- But this means that it is not possible to assign the value of - -- Item to the specified element (on Node), because a different - -- element (on Hint) equivalent to Item already exsits. (Were we - -- to change Node's element value, we would have to move Node, but - -- we would be unable to move the Node, because its new position - -- in the tree is already occupied by an equivalent element.) - - raise Program_Error with "attempt to replace existing element"; - end if; - - -- Item is not equivalent to any other element in the tree, so it is - -- safe to assign the value of Item to Node.Element. This means that - -- the node will have to move to a different position in the tree - -- (because its element will have a different value). - - -- The nearest (greater) neighbor of Item is Hint. This will be the - -- insertion position of Node (because its element will have Item as - -- its new value). - - -- If Node equals Hint, the relative position of Node does not - -- change. This allows us to perform an optimization: we need not - -- remove Node from the tree and then reinsert it with its new value, - -- because it would only be placed in the exact same position. - - if Hint = Node then - TE_Check (Tree.TC); - - declare - -- The element allocator may need an accessibility check in the - -- case actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Node.Element := new Element_Type'(Item); - Free_Element (X); - end; - - return; - end if; - end if; - - -- If we get here, it is because Item was greater than all elements in - -- the tree (Hint = null), or because Item was less than some element at - -- a different place in the tree (Item < Hint.Element.all). In either - -- case, we remove Node from the tree (without actually deallocating - -- it), and then insert Item into the tree, onto the same Node (so no - -- new node is actually allocated). - - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - - Local_Insert_With_Hint - (Tree => Tree, - Position => Hint, - Key => Item, - Node => Result, - Inserted => Inserted); - - pragma Assert (Inserted); - pragma Assert (Result = Node); - - Free_Element (X); - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Node.Element = null then - raise Program_Error with "Position cursor is bad"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container.Tree, Position.Node, New_Item); - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Access) return Node_Access is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : Node_Access; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : Node_Access; Left : Node_Access) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : Node_Access; Right : Node_Access) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Tree : Tree_Type; - Node : Node_Access; - Inserted : Boolean; - pragma Unreferenced (Node, Inserted); - begin - Insert_Sans_Hint (Tree, New_Item, Node, Inserted); - return Set'(Controlled with Tree); - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - begin - Set_Ops.Union (Target.Tree, Source.Tree); - end Union; - - function Union (Left, Right : Set) return Set is - Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Union; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - procedure Write is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Element_Type'Output (Stream, Node.Element.all); - end Write_Node; - - -- Start of processing for Write - - begin - Write (Stream, Container.Tree); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-ciorse.ads b/gcc/ada/a-ciorse.ads deleted file mode 100644 index 2e1c018..0000000 --- a/gcc/ada/a-ciorse.ads +++ /dev/null @@ -1,467 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Containers.Red_Black_Trees; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type (<>) is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Ordered_Sets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean; - - type Set is tagged private with - Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Set : constant Set; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - - function Equivalent_Sets (Left, Right : Set) return Boolean; - - function To_Set (New_Item : Element_Type) return Set; - - function Length (Container : Set) return Count_Type; - - function Is_Empty (Container : Set) return Boolean; - - procedure Clear (Container : in out Set); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set) return Set; - - procedure Move (Target : in out Set; Source : in out Set); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type); - - procedure Include - (Container : in out Set; - New_Item : Element_Type); - - procedure Replace - (Container : in out Set; - New_Item : Element_Type); - - procedure Exclude - (Container : in out Set; - Item : Element_Type); - - procedure Delete - (Container : in out Set; - Item : Element_Type); - - procedure Delete - (Container : in out Set; - Position : in out Cursor); - - procedure Delete_First (Container : in out Set); - - procedure Delete_Last (Container : in out Set); - - procedure Union (Target : in out Set; Source : Set); - - function Union (Left, Right : Set) return Set; - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - - function Intersection (Left, Right : Set) return Set; - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - - function Difference (Left, Right : Set) return Set; - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - - function Symmetric_Difference (Left, Right : Set) return Set; - - function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - - function First (Container : Set) return Cursor; - - function First_Element (Container : Set) return Element_Type; - - function Last (Container : Set) return Cursor; - - function Last_Element (Container : Set) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find - (Container : Set; - Item : Element_Type) return Cursor; - - function Floor - (Container : Set; - Item : Element_Type) return Cursor; - - function Ceiling - (Container : Set; - Item : Element_Type) return Cursor; - - function Contains - (Container : Set; - Item : Element_Type) return Boolean; - - function "<" (Left, Right : Cursor) return Boolean; - - function ">" (Left, Right : Cursor) return Boolean; - - function "<" (Left : Cursor; Right : Element_Type) return Boolean; - - function ">" (Left : Cursor; Right : Element_Type) return Boolean; - - function "<" (Left : Element_Type; Right : Cursor) return Boolean; - - function ">" (Left : Element_Type; Right : Cursor) return Boolean; - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - - function Iterate - (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : Set; - Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - function Key (Position : Cursor) return Key_Type; - - function Element (Container : Set; Key : Key_Type) return Element_Type; - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type); - - procedure Exclude (Container : in out Set; Key : Key_Type); - - procedure Delete (Container : in out Set; Key : Key_Type); - - function Find - (Container : Set; - Key : Key_Type) return Cursor; - - function Floor - (Container : Set; - Key : Key_Type) return Cursor; - - function Ceiling - (Container : Set; - Key : Key_Type) return Cursor; - - function Contains - (Container : Set; - Key : Key_Type) return Boolean; - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type; - - private - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - type Key_Access is access all Key_Type; - - package Impl is new Helpers.Generic_Implementation; - - type Reference_Control_Type is - new Impl.Reference_Control_Type with - record - Container : Set_Access; - Pos : Cursor; - Old_Key : Key_Access; - end record; - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type; - end record; - - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - end Generic_Keys; - -private - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type; - type Node_Access is access Node_Type; - - type Element_Access is access all Element_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Element : Element_Access; - end record; - - package Tree_Types is new Red_Black_Trees.Generic_Tree_Types - (Node_Type, - Node_Access); - - type Set is new Ada.Finalization.Controlled with record - Tree : Tree_Types.Tree_Type; - end record; - - overriding procedure Adjust (Container : in out Set); - - overriding procedure Finalize (Container : in out Set) renames Clear; - - use Red_Black_Trees; - use Tree_Types, Tree_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - type Cursor is record - Container : Set_Access; - Node : Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Set : constant Set := (Controlled with others => <>); - - No_Element : constant Cursor := Cursor'(null, null); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/a-clrefi.adb b/gcc/ada/a-clrefi.adb deleted file mode 100644 index 71d05ff..0000000 --- a/gcc/ada/a-clrefi.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/a-clrefi.ads b/gcc/ada/a-clrefi.ads deleted file mode 100644 index 14971f3..0000000 --- a/gcc/ada/a-clrefi.ads +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- See s-resfil.ads for documentation - -with System.Response_File; -package Ada.Command_Line.Response_File renames System.Response_File; diff --git a/gcc/ada/a-coboho.adb b/gcc/ada/a-coboho.adb deleted file mode 100644 index 75fc638..0000000 --- a/gcc/ada/a-coboho.adb +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ H O L D E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Unchecked_Conversion; - -package body Ada.Containers.Bounded_Holders is - - function Size_In_Storage_Elements (Element : Element_Type) return Natural; - -- This returns the size of Element in storage units. It raises an - -- exception if the size is not a multiple of Storage_Unit, or if the size - -- is too big. - - ------------------------------ - -- Size_In_Storage_Elements -- - ------------------------------ - - function Size_In_Storage_Elements (Element : Element_Type) return Natural is - Max_Size : Natural renames Max_Size_In_Storage_Elements; - - begin - return S : constant Natural := Element'Size / System.Storage_Unit do - pragma Assert - (Element'Size mod System.Storage_Unit = 0, - "Size must be a multiple of Storage_Unit"); - - pragma Assert - (S <= Max_Size, "Size is too big:" & S'Img & " >" & Max_Size'Img); - end return; - end Size_In_Storage_Elements; - - function Cast is new - Unchecked_Conversion (System.Address, Element_Access); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Holder) return Boolean is - begin - return Get (Left) = Get (Right); - end "="; - - ------------- - -- Element -- - ------------- - - function Get (Container : Holder) return Element_Type is - begin - return Cast (Container'Address).all; - end Get; - - --------- - -- Set -- - --------- - - procedure Set (Container : in out Holder; New_Item : Element_Type) is - Storage : Storage_Array - (1 .. Size_In_Storage_Elements (New_Item)) with - Address => New_Item'Address; - begin - Container.Data (Storage'Range) := Storage; - end Set; - - --------------- - -- To_Holder -- - --------------- - - function To_Holder (New_Item : Element_Type) return Holder is - begin - return Result : Holder do - Set (Result, New_Item); - end return; - end To_Holder; - -end Ada.Containers.Bounded_Holders; diff --git a/gcc/ada/a-coboho.ads b/gcc/ada/a-coboho.ads deleted file mode 100644 index 67b27f2..0000000 --- a/gcc/ada/a-coboho.ads +++ /dev/null @@ -1,114 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ H O L D E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -private with System; - -generic - type Element_Type (<>) is private; - Max_Size_In_Storage_Elements : Natural := - Element_Type'Max_Size_In_Storage_Elements; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Bounded_Holders is - pragma Annotate (CodePeer, Skip_Analysis); - - -- This package is patterned after Ada.Containers.Indefinite_Holders. It is - -- used to treat indefinite subtypes as definite, but without using heap - -- allocation. For example, you might like to say: - -- - -- type A is array (...) of T'Class; -- illegal - -- - -- Instead, you can instantiate this package with Element_Type => T'Class, - -- and say: - -- - -- type A is array (...) of Holder; - -- - -- Each object of type Holder is allocated Max_Size_In_Storage_Elements - -- bytes. If you try to create a holder from an object of type Element_Type - -- that is too big, an exception is raised (assuming assertions are - -- enabled). This applies to To_Holder and Set. If you pass an Element_Type - -- object that is smaller than Max_Size_In_Storage_Elements, it works fine, - -- but some space is wasted. - -- - -- NOTE: If assertions are disabled, and you try to use an Element that is - -- too big, execution is erroneous, and anything can happen, such as - -- overwriting arbitrary memory locations. - -- - -- Element_Type must not be an unconstrained array type. It can be a - -- class-wide type or a type with non-defaulted discriminants. - -- - -- The 'Size of each Element_Type object must be a multiple of - -- System.Storage_Unit; e.g. creating Holders from 5-bit objects won't - -- work. - - type Holder is private; - - function "=" (Left, Right : Holder) return Boolean; - - function To_Holder (New_Item : Element_Type) return Holder; - function "+" (New_Item : Element_Type) return Holder renames To_Holder; - - function Get (Container : Holder) return Element_Type; - - procedure Set (Container : in out Holder; New_Item : Element_Type); - -private - - -- The implementation uses low-level tricks (Address clauses and unchecked - -- conversions of access types) to treat the elements as storage arrays. - - pragma Assert (Element_Type'Alignment <= Standard'Maximum_Alignment); - -- This prevents elements with a user-specified Alignment that is too big - - type Storage_Element is mod System.Storage_Unit; - type Storage_Array is array (Positive range <>) of Storage_Element; - type Holder is record - Data : Storage_Array (1 .. Max_Size_In_Storage_Elements); - end record - with Alignment => Standard'Maximum_Alignment; - -- We would like to say "Alignment => Element_Type'Alignment", but that - -- is illegal because it's not static, so we use the maximum possible - -- (default) alignment instead. - - type Element_Access is access all Element_Type; - pragma Assert (Element_Access'Size = Standard'Address_Size, - "cannot instantiate with an array type"); - -- If Element_Access is a fat pointer, Element_Type must be an - -- unconstrained array, which is not allowed. Arrays won't work, because - -- the 'Address of an array points to the first element, thus losing the - -- bounds. - - pragma No_Strict_Aliasing (Element_Access); - -- Needed because we are unchecked-converting from Address to - -- Element_Access (see package body), which is a violation of the - -- normal aliasing rules enforced by gcc. - -end Ada.Containers.Bounded_Holders; diff --git a/gcc/ada/a-cobove.adb b/gcc/ada/a-cobove.adb deleted file mode 100644 index 59d6c27..0000000 --- a/gcc/ada/a-cobove.adb +++ /dev/null @@ -1,2805 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; - -with System; use type System.Address; - -package body Ada.Containers.Bounded_Vectors is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - - --------- - -- "&" -- - --------- - - function "&" (Left, Right : Vector) return Vector is - LN : constant Count_Type := Length (Left); - RN : constant Count_Type := Length (Right); - N : Count_Type'Base; -- length of result - J : Count_Type'Base; -- for computing intermediate index values - Last : Index_Type'Base; -- Last index of result - - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the vector parameters. We could decide to make it larger, but we - -- have no basis for knowing how much larger, so we just allocate the - -- minimum amount of storage. - - -- Here we handle the easy cases first, when one of the vector - -- parameters is empty. (We say "easy" because there's nothing to - -- compute, that can potentially overflow.) - - if LN = 0 then - if RN = 0 then - return Empty_Vector; - end if; - - return Vector'(Capacity => RN, - Elements => Right.Elements (1 .. RN), - Last => Right.Last, - others => <>); - end if; - - if RN = 0 then - return Vector'(Capacity => LN, - Elements => Left.Elements (1 .. LN), - Last => Left.Last, - others => <>); - end if; - - -- Neither of the vector parameters is empty, so must compute the length - -- of the result vector and its last index. (This is the harder case, - -- because our computations must avoid overflow.) - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the combined lengths. Note that we cannot - -- simply add the lengths, because of the possibility of overflow. - - if Checks and then LN > Count_Type'Last - RN then - raise Constraint_Error with "new length is out of range"; - end if; - - -- It is now safe to compute the length of the new vector, without fear - -- of overflow. - - N := LN + RN; - - -- The second constraint is that the new Last index value cannot - -- exceed Index_Type'Last. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (N) < No_Index - then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (N); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of length. - - J := Count_Type'Base (No_Index) + N; -- Last - - if Checks and then J > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (J); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - J := Count_Type'Base (Index_Type'Last) - N; -- No_Index - - if Checks and then J < Count_Type'Base (No_Index) then - raise Constraint_Error with "new length is out of range"; - end if; - - -- We have determined that the result length would not create a Last - -- index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + N); - end if; - - declare - LE : Elements_Array renames Left.Elements (1 .. LN); - RE : Elements_Array renames Right.Elements (1 .. RN); - - begin - return Vector'(Capacity => N, - Elements => LE & RE, - Last => Last, - others => <>); - end; - end "&"; - - function "&" (Left : Vector; Right : Element_Type) return Vector is - LN : constant Count_Type := Length (Left); - - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We must compute the length of the result vector and its last index, - -- but in such a way that overflow is avoided. We must satisfy two - -- constraints: the new length cannot exceed Count_Type'Last, and the - -- new Last index cannot exceed Index_Type'Last. - - if Checks and then LN = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Checks and then Left.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - return Vector'(Capacity => LN + 1, - Elements => Left.Elements (1 .. LN) & Right, - Last => Left.Last + 1, - others => <>); - end "&"; - - function "&" (Left : Element_Type; Right : Vector) return Vector is - RN : constant Count_Type := Length (Right); - - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We compute the length of the result vector and its last index, but in - -- such a way that overflow is avoided. We must satisfy two constraints: - -- the new length cannot exceed Count_Type'Last, and the new Last index - -- cannot exceed Index_Type'Last. - - if Checks and then RN = Count_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - if Checks and then Right.Last >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - return Vector'(Capacity => 1 + RN, - Elements => Left & Right.Elements (1 .. RN), - Last => Right.Last + 1, - others => <>); - end "&"; - - function "&" (Left, Right : Element_Type) return Vector is - begin - -- We decide that the capacity of the result is the sum of the lengths - -- of the parameters. We could decide to make it larger, but we have no - -- basis for knowing how much larger, so we just allocate the minimum - -- amount of storage. - - -- We must compute the length of the result vector and its last index, - -- but in such a way that overflow is avoided. We must satisfy two - -- constraints: the new length cannot exceed Count_Type'Last (here, we - -- know that that condition is satisfied), and the new Last index cannot - -- exceed Index_Type'Last. - - if Checks and then Index_Type'First >= Index_Type'Last then - raise Constraint_Error with "new length is out of range"; - end if; - - return Vector'(Capacity => 2, - Elements => (Left, Right), - Last => Index_Type'First + 1, - others => <>); - end "&"; - - --------- - -- "=" -- - --------- - - overriding function "=" (Left, Right : Vector) return Boolean is - begin - if Left.Last /= Right.Last then - return False; - end if; - - if Left.Length = 0 then - return True; - end if; - - declare - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - begin - for J in Count_Type range 1 .. Left.Length loop - if Left.Elements (J) /= Right.Elements (J) then - return False; - end if; - end loop; - end; - - return True; - end "="; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error -- ??? - with "Target capacity is less than Source length"; - end if; - - Target.Clear; - - Target.Elements (1 .. Source.Length) := - Source.Elements (1 .. Source.Length); - - Target.Last := Source.Last; - end Assign; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if New_Item.Is_Empty then - return; - end if; - - if Checks and then Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Container.Insert (Container.Last + 1, New_Item); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - if Count = 0 then - return; - end if; - - if Checks and then Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Container.Insert (Container.Last + 1, New_Item, Count); - end Append; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Count_Type is - begin - return Container.Elements'Length; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - TC_Check (Container.TC); - - Container.Last := No_Index; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Checks and then Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - declare - A : Elements_Array renames Container.Elements; - J : constant Count_Type := To_Array_Index (Position.Index); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => A (J)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return Constant_Reference_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - A : Elements_Array renames Container.Elements; - J : constant Count_Type := To_Array_Index (Index); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => A (J)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Count_Type := 0) return Vector - is - C : Count_Type; - - begin - if Capacity = 0 then - C := Source.Length; - - elsif Capacity >= Source.Length then - C := Capacity; - - elsif Checks then - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - return Target : Vector (C) do - Target.Elements (1 .. Source.Length) := - Source.Elements (1 .. Source.Length); - - Target.Last := Source.Last; - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type := 1) - is - Old_Last : constant Index_Type'Base := Container.Last; - Old_Len : constant Count_Type := Container.Length; - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - Off : Count_Type'Base; -- Index expressed as offset from IT'First - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Checks and then Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Checks and then Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - -- Here and elsewhere we treat deleting 0 items from the container as a - -- no-op, even when the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete checks the count to determine whether it is - -- being called while the associated callback procedure is executing. - - TC_Check (Container.TC); - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements aren't being deleted (the requested count was - -- less than the available count), so we must slide them down to - -- Index. We first calculate the index values of the respective array - -- slices, using the wider of Index_Type'Base and Count_Type'Base as the - -- type for intermediate calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Off := Count_Type'Base (Index - Index_Type'First); - New_Last := Old_Last - Index_Type'Base (Count); - else - Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - end if; - - -- The array index values for each slice have already been determined, - -- so we just slide down to Index the elements that weren't deleted. - - declare - EA : Elements_Array renames Container.Elements; - Idx : constant Count_Type := EA'First + Off; - begin - EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); - Container.Last := New_Last; - end; - end Delete; - - procedure Delete - (Container : in out Vector; - Position : in out Cursor; - Count : Count_Type := 1) - is - pragma Warnings (Off, Position); - - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Checks and then Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - - Delete (Container, Position.Index, Count); - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - -- It is not permitted to delete items while the container is busy (for - -- example, we're in the middle of a passive iteration). However, we - -- always treat deleting 0 items as a no-op, even when we're busy, so we - -- simply return without checking. - - if Count = 0 then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete_Last checks the count to determine whether - -- it is being called while the associated callback procedure is - -- executing. - - TC_Check (Container.TC); - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Container.Length then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - else - return Container.Elements (To_Array_Index (Index)); - end if; - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - else - return Position.Container.Element (Position.Index); - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - Unbusy (Object.Container.TC); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - begin - if Position.Container /= null then - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Checks and then Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for J in Position.Index .. Container.Last loop - if Container.Elements (To_Array_Index (J)) = Item then - return Cursor'(Container'Unrestricted_Access, J); - end if; - end loop; - - return No_Element; - end; - end Find; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for Indx in Index .. Container.Last loop - if Container.Elements (To_Array_Index (Indx)) = Item then - return Indx; - end if; - end loop; - - return No_Index; - end Find_Index; - - ----------- - -- First -- - ----------- - - function First (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - else - return (Container'Unrestricted_Access, Index_Type'First); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the First (and Last) selector function. - - -- When the Index component is No_Index, this means the iterator - -- object was constructed without a start expression, in which case the - -- (forward) iteration starts from the (logical) beginning of the entire - -- sequence of items (corresponding to Container.First, for a forward - -- iterator). - - -- Otherwise, this is iteration over a partial sequence of items. - -- When the Index component isn't No_Index, the iterator object was - -- constructed with a start expression, that specifies the position - -- from which the (forward) partial iteration begins. - - if Object.Index = No_Index then - return First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Checks and then Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - end if; - - return Container.Elements (To_Array_Index (Index_Type'First)); - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - begin - if Container.Last <= Index_Type'First then - return True; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - EA : Elements_Array renames Container.Elements; - begin - for J in 1 .. Container.Length - 1 loop - if EA (J + 1) < EA (J) then - return False; - end if; - end loop; - - return True; - end; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target, Source : in out Vector) is - I, J : Count_Type; - - begin - -- The semantics of Merge changed slightly per AI05-0021. It was - -- originally the case that if Target and Source denoted the same - -- container object, then the GNAT implementation of Merge did - -- nothing. However, it was argued that RM05 did not precisely - -- specify the semantics for this corner case. The decision of the - -- ARG was that if Target and Source denote the same non-empty - -- container object, then Program_Error is raised. - - if Source.Is_Empty then - return; - end if; - - if Checks and then Target'Address = Source'Address then - raise Program_Error with - "Target and Source denote same non-empty container"; - end if; - - if Target.Is_Empty then - Move (Target => Target, Source => Source); - return; - end if; - - TC_Check (Source.TC); - - I := Target.Length; - Target.Set_Length (I + Source.Length); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - TA : Elements_Array renames Target.Elements; - SA : Elements_Array renames Source.Elements; - - Lock_Target : With_Lock (Target.TC'Unchecked_Access); - Lock_Source : With_Lock (Source.TC'Unchecked_Access); - begin - J := Target.Length; - while not Source.Is_Empty loop - pragma Assert (Source.Length <= 1 - or else not (SA (Source.Length) < SA (Source.Length - 1))); - - if I = 0 then - TA (1 .. J) := SA (1 .. Source.Length); - Source.Last := No_Index; - exit; - end if; - - pragma Assert (I <= 1 - or else not (TA (I) < TA (I - 1))); - - if SA (Source.Length) < TA (I) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Source.Length); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - procedure Sort is - new Generic_Array_Sort - (Index_Type => Count_Type, - Element_Type => Element_Type, - Array_Type => Elements_Array, - "<" => "<"); - - begin - if Container.Last <= Index_Type'First then - return; - end if; - - -- The exception behavior for the vector container must match that - -- for the list container, so we check for cursor tampering here - -- (which will catch more things) instead of for element tampering - -- (which will catch fewer things). It's true that the elements of - -- this vector container could be safely moved around while (say) an - -- iteration is taking place (iteration only increments the busy - -- counter), and so technically all we would need here is a test for - -- element tampering (indicated by the lock counter), that's simply - -- an artifact of our array-based implementation. Logically Sort - -- requires a check for cursor tampering. - - TC_Check (Container.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Sort (Container.Elements (1 .. Container.Length)); - end; - end Sort; - - end Generic_Sorting; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Elements - (To_Array_Index (Position.Index))'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - if Position.Container = null then - return False; - end if; - - return Position.Index <= Position.Container.Last; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type := 1) - is - EA : Elements_Array renames Container.Elements; - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Checks and then Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Checks and then Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion - -- count. Note that we cannot simply add these values, because of the - -- possibility of overflow. - - if Checks and then Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= - Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if Checks and then New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - TC_Check (Container.TC); - - if Checks and then New_Length > Container.Capacity then - raise Capacity_Error with "New length is larger than capacity"; - end if; - - J := To_Array_Index (Before); - - if Before > Container.Last then - - -- The new items are being appended to the vector, so no - -- sliding of existing elements is required. - - EA (J .. New_Length) := (others => New_Item); - - else - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. - - EA (J + Count .. New_Length) := EA (J .. Old_Length); - EA (J .. J + Count - 1) := (others => New_Item); - end if; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - B : Count_Type; -- index Before converted to Count_Type - - begin - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - B := To_Array_Index (Before); - - if Container'Address /= New_Item'Address then - -- This is the simple case. New_Item denotes an object different - -- from Container, so there's nothing special we need to do to copy - -- the source items to their destination, because all of the source - -- items are contiguous. - - Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N); - return; - end if; - - -- We refer to array index value Before + N - 1 as J. This is the last - -- index value of the destination slice. - - -- New_Item denotes the same object as Container, so an insertion has - -- potentially split the source items. The destination is always the - -- range [Before, J], but the source is [Index_Type'First, Before) and - -- (J, Container.Last]. We perform the copy in two steps, using each of - -- the two slices of the source items. - - declare - subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1; - - Src : Elements_Array renames Container.Elements (Src_Index_Subtype); - - begin - -- We first copy the source items that precede the space we - -- inserted. (If Before equals Index_Type'First, then this first - -- source slice will be empty, which is harmless.) - - Container.Elements (B .. B + Src'Length - 1) := Src; - end; - - declare - subtype Src_Index_Subtype is Count_Type'Base range - B + N .. Container.Length; - - Src : Elements_Array renames Container.Elements (Src_Index_Subtype); - - begin - -- We next copy the source items that follow the space we inserted. - - Container.Elements (B + N - Src'Length .. B + N - 1) := Src; - end; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unchecked_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector; - Position : out Cursor) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unchecked_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - - Position := Cursor'(Container'Unchecked_Access, Index); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unchecked_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unchecked_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - - Position := Cursor'(Container'Unchecked_Access, Index); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - - begin - Insert (Container, Before, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - EA : Elements_Array renames Container.Elements; - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Checks and then Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Checks and then Before > Container.Last - and then Before > Container.Last + 1 - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note that we cannot simply add these values, because of the - -- possibility of overflow. - - if Checks and then Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= - Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if Checks and then New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - TC_Check (Container.TC); - - -- An internal array has already been allocated, so we need to check - -- whether there is enough unused storage for the new items. - - if Checks and then New_Length > Container.Capacity then - raise Capacity_Error with "New length is larger than capacity"; - end if; - - -- In this case, we're inserting space into a vector that has already - -- allocated an internal array, and the existing array has enough - -- unused storage for the new items. - - if Before <= Container.Last then - - -- The space is being inserted before some existing elements, - -- so we must slide the existing elements up to their new home. - - J := To_Array_Index (Before); - EA (J + Count .. New_Length) := EA (J .. Old_Length); - end if; - - -- New_Last is the last index value of the items in the container after - -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to - -- compute its value from the New_Length. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert_Space; - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unchecked_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null - or else Before.Index > Container.Last - then - Position := No_Element; - else - Position := (Container'Unchecked_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null - or else Before.Index > Container.Last - then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert_Space (Container, Index, Count => Count); - - Position := Cursor'(Container'Unchecked_Access, Index); - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Container.Last < Index_Type'First; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - end Iterate; - - function Iterate - (Container : Vector) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - begin - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is No_Index (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => No_Index) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : Vector; - Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; - - if Checks and then Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is not No_Index (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this is - -- a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => Start.Index) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - else - return (Container'Unrestricted_Access, Container.Last); - end if; - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the Last (and First) selector function. - - -- When the Index component is No_Index, this means the iterator object - -- was constructed without a start expression, in which case the - -- (reverse) iteration starts from the (logical) beginning of the entire - -- sequence (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Index component is not No_Index, the iterator object was - -- constructed with a start expression, that specifies the position from - -- which the (reverse) partial iteration begins. - - if Object.Index = No_Index then - return Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Checks and then Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - end if; - - return Container.Elements (Container.Length); - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Count_Type is - L : constant Index_Type'Base := Container.Last; - F : constant Index_Type := Index_Type'First; - - begin - -- The base range of the index type (Index_Type'Base) might not include - -- all values for length (Count_Type). Contrariwise, the index type - -- might include values outside the range of length. Hence we use - -- whatever type is wider for intermediate values when calculating - -- length. Note that no matter what the index type is, the maximum - -- length to which a vector is allowed to grow is always the minimum - -- of Count_Type'Last and (IT'Last - IT'First + 1). - - -- For example, an Index_Type with range -127 .. 127 is only guaranteed - -- to have a base range of -128 .. 127, but the corresponding vector - -- would have lengths in the range 0 .. 255. In this case we would need - -- to use Count_Type'Base for intermediate values. - - -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The - -- vector would have a maximum length of 10, but the index values lie - -- outside the range of Count_Type (which is only 32 bits). In this - -- case we would need to use Index_Type'Base for intermediate values. - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - return Count_Type'Base (L) - Count_Type'Base (F) + 1; - else - return Count_Type (L - F + 1); - end if; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Vector; - Source : in out Vector) - is - begin - if Target'Address = Source'Address then - return; - end if; - - if Checks and then Target.Capacity < Source.Length then - raise Capacity_Error -- ??? - with "Target capacity is less than Source length"; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - -- Clear Target now, in case element assignment fails - - Target.Last := No_Index; - - Target.Elements (1 .. Source.Length) := - Source.Elements (1 .. Source.Length); - - Target.Last := Source.Last; - Source.Last := No_Index; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Position.Index < Position.Container.Last then - return (Position.Container, Position.Index + 1); - else - return No_Element; - end if; - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong vector"; - end if; - - return Next (Position); - end Next; - - procedure Next (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index < Position.Container.Last then - Position.Index := Position.Index + 1; - else - Position := No_Element; - end if; - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, - Index_Type'First, - New_Item, - Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index > Index_Type'First then - Position.Index := Position.Index - 1; - else - Position := No_Element; - end if; - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Position.Index > Index_Type'First then - return (Position.Container, Position.Index - 1); - else - return No_Element; - end if; - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong vector"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Vector'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)) - is - Lock : With_Lock (Container.TC'Unrestricted_Access); - V : Vector renames Container'Unrestricted_Access.all; - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - Process (V.Elements (To_Array_Index (Index))); - end Query_Element; - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - Query_Element (Position.Container.all, Position.Index, Process); - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector) - is - Length : Count_Type'Base; - Last : Index_Type'Base := No_Index; - - begin - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - Reserve_Capacity (Container, Capacity => Length); - - for Idx in Count_Type range 1 .. Length loop - Last := Last + 1; - Element_Type'Read (Stream, Container.Elements (Idx)); - Container.Last := Last; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Vector; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Checks and then Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - declare - A : Elements_Array renames Container.Elements; - J : constant Count_Type := To_Array_Index (Position.Index); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => A (J)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Vector; - Index : Index_Type) return Reference_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - A : Elements_Array renames Container.Elements; - J : constant Count_Type := To_Array_Index (Index); - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => A (J)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - TE_Check (Container.TC); - - Container.Elements (To_Array_Index (Index)) := New_Item; - end Replace_Element; - - procedure Replace_Element - (Container : in out Vector; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Checks and then Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - - TE_Check (Container.TC); - - Container.Elements (To_Array_Index (Position.Index)) := New_Item; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Count_Type) - is - begin - if Checks and then Capacity > Container.Capacity then - raise Capacity_Error with "Capacity is out of range"; - end if; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - E : Elements_Array renames Container.Elements; - Idx : Count_Type; - Jdx : Count_Type; - - begin - if Container.Length <= 1 then - return; - end if; - - -- The exception behavior for the vector container must match that for - -- the list container, so we check for cursor tampering here (which will - -- catch more things) instead of for element tampering (which will catch - -- fewer things). It's true that the elements of this vector container - -- could be safely moved around while (say) an iteration is taking place - -- (iteration only increments the busy counter), and so technically - -- all we would need here is a test for element tampering (indicated - -- by the lock counter), that's simply an artifact of our array-based - -- implementation. Logically Reverse_Elements requires a check for - -- cursor tampering. - - TC_Check (Container.TC); - - Idx := 1; - Jdx := Container.Length; - while Idx < Jdx loop - declare - EI : constant Element_Type := E (Idx); - - begin - E (Idx) := E (Jdx); - E (Jdx) := EI; - end; - - Idx := Idx + 1; - Jdx := Jdx - 1; - end loop; - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Last : Index_Type'Base; - - begin - if Checks and then Position.Container /= null - and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - Last := - (if Position.Container = null or else Position.Index > Container.Last - then Container.Last - else Position.Index); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements (To_Array_Index (Indx)) = Item then - return Cursor'(Container'Unrestricted_Access, Indx); - end if; - end loop; - - return No_Element; - end; - end Reverse_Find; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - - Last : constant Index_Type'Base := - Index_Type'Min (Container.Last, Index); - - begin - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements (To_Array_Index (Indx)) = Item then - return Indx; - end if; - end loop; - - return No_Index; - end Reverse_Find_Index; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - end Reverse_Iterate; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length (Container : in out Vector; Length : Count_Type) is - Count : constant Count_Type'Base := Container.Length - Length; - - begin - -- Set_Length allows the user to set the length explicitly, instead of - -- implicitly as a side-effect of deletion or insertion. If the - -- requested length is less than the current length, this is equivalent - -- to deleting items from the back end of the vector. If the requested - -- length is greater than the current length, then this is equivalent to - -- inserting "space" (nonce items) at the end. - - if Count >= 0 then - Container.Delete_Last (Count); - elsif Checks and then Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - else - Container.Insert_Space (Container.Last + 1, -Count); - end if; - end Set_Length; - - ---------- - -- Swap -- - ---------- - - procedure Swap (Container : in out Vector; I, J : Index_Type) is - E : Elements_Array renames Container.Elements; - - begin - if Checks and then I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if Checks and then J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - TE_Check (Container.TC); - - declare - EI_Copy : constant Element_Type := E (To_Array_Index (I)); - begin - E (To_Array_Index (I)) := E (To_Array_Index (J)); - E (To_Array_Index (J)) := EI_Copy; - end; - end Swap; - - procedure Swap (Container : in out Vector; I, J : Cursor) is - begin - if Checks and then I.Container = null then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then J.Container = null then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; - end if; - - if Checks and then J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; - end if; - - Swap (Container, I.Index, J.Index); - end Swap; - - -------------------- - -- To_Array_Index -- - -------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is - Offset : Count_Type'Base; - - begin - -- We know that - -- Index >= Index_Type'First - -- hence we also know that - -- Index - Index_Type'First >= 0 - - -- The issue is that even though 0 is guaranteed to be a value in - -- the type Index_Type'Base, there's no guarantee that the difference - -- is a value in that type. To prevent overflow we use the wider - -- of Count_Type'Base and Index_Type'Base to perform intermediate - -- calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Offset := Count_Type'Base (Index - Index_Type'First); - - else - Offset := Count_Type'Base (Index) - - Count_Type'Base (Index_Type'First); - end if; - - -- The array index subtype for all container element arrays - -- always starts with 1. - - return 1 + Offset; - end To_Array_Index; - - --------------- - -- To_Cursor -- - --------------- - - function To_Cursor - (Container : Vector; - Index : Extended_Index) return Cursor - is - begin - if Index not in Index_Type'First .. Container.Last then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Index); - end To_Cursor; - - -------------- - -- To_Index -- - -------------- - - function To_Index (Position : Cursor) return Extended_Index is - begin - if Position.Container = null then - return No_Index; - end if; - - if Position.Index <= Position.Container.Last then - return Position.Index; - end if; - - return No_Index; - end To_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector (Length : Count_Type) return Vector is - Index : Count_Type'Base; - Last : Index_Type'Base; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Length) < No_Index - then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - return V : Vector (Capacity => Length) do - V.Last := Last; - end return; - end To_Vector; - - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector - is - Index : Count_Type'Base; - Last : Index_Type'Base; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Length) < No_Index - then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - return V : Vector (Capacity => Length) do - V.Elements := (others => New_Item); - V.Last := Last; - end return; - end To_Vector; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)) - is - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - Process (Container.Elements (To_Array_Index (Index))); - end Update_Element; - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - Update_Element (Container, Position.Index, Process); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector) - is - N : Count_Type; - - begin - N := Container.Length; - Count_Type'Base'Write (Stream, N); - - for J in 1 .. N loop - Element_Type'Write (Stream, Container.Elements (J)); - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/a-cobove.ads b/gcc/ada/a-cobove.ads deleted file mode 100644 index c315702..0000000 --- a/gcc/ada/a-cobove.ads +++ /dev/null @@ -1,506 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Streams; -private with Ada.Finalization; - -generic - type Index_Type is range <>; - type Element_Type is private; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Bounded_Vectors is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - pragma Remote_Types; - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - type Vector (Capacity : Count_Type) is tagged private with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Vector); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Vector : constant Vector; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package Vector_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - overriding function "=" (Left, Right : Vector) return Boolean; - - function To_Vector (Length : Count_Type) return Vector; - - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector; - - function "&" (Left, Right : Vector) return Vector; - - function "&" (Left : Vector; Right : Element_Type) return Vector; - - function "&" (Left : Element_Type; Right : Vector) return Vector; - - function "&" (Left, Right : Element_Type) return Vector; - - function Capacity (Container : Vector) return Count_Type; - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Count_Type); - - function Length (Container : Vector) return Count_Type; - - procedure Set_Length - (Container : in out Vector; - Length : Count_Type); - - function Is_Empty (Container : Vector) return Boolean; - - procedure Clear (Container : in out Vector); - - function To_Cursor - (Container : Vector; - Index : Extended_Index) return Cursor; - - function To_Index (Position : Cursor) return Extended_Index; - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type; - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type); - - procedure Replace_Element - (Container : in out Vector; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Vector; - Position : Cursor) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Vector; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return Constant_Reference_Type; - - function Reference - (Container : aliased in out Vector; - Index : Index_Type) return Reference_Type; - - procedure Assign (Target : in out Vector; Source : Vector); - - function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; - - procedure Move (Target : in out Vector; Source : in out Vector); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector; - Position : out Cursor); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Vector); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append - (Container : in out Vector; - New_Item : Vector); - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type := 1); - - procedure Delete - (Container : in out Vector; - Position : in out Cursor; - Count : Count_Type := 1); - - procedure Delete_First - (Container : in out Vector; - Count : Count_Type := 1); - - procedure Delete_Last - (Container : in out Vector; - Count : Count_Type := 1); - - procedure Reverse_Elements (Container : in out Vector); - - procedure Swap (Container : in out Vector; I, J : Index_Type); - - procedure Swap (Container : in out Vector; I, J : Cursor); - - function First_Index (Container : Vector) return Index_Type; - - function First (Container : Vector) return Cursor; - - function First_Element (Container : Vector) return Element_Type; - - function Last_Index (Container : Vector) return Extended_Index; - - function Last (Container : Vector) return Cursor; - - function Last_Element (Container : Vector) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index; - - function Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index; - - function Reverse_Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)); - - function Iterate - (Container : Vector) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class; - - function Iterate - (Container : Vector; - Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'class; - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : Vector) return Boolean; - - procedure Sort (Container : in out Vector); - - procedure Merge (Target : in out Vector; Source : in out Vector); - - end Generic_Sorting; - -private - - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Query_Element); - pragma Inline (Update_Element); - pragma Inline (Replace_Element); - pragma Inline (Is_Empty); - pragma Inline (Contains); - pragma Inline (Next); - pragma Inline (Previous); - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - use Ada.Streams; - use Ada.Finalization; - - type Elements_Array is array (Count_Type range <>) of aliased Element_Type; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Vector (Capacity : Count_Type) is tagged record - Elements : Elements_Array (1 .. Capacity) := (others => <>); - Last : Extended_Index := No_Index; - TC : aliased Tamper_Counts; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector); - - for Vector'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector); - - for Vector'Read use Read; - - type Vector_Access is access all Vector; - for Vector_Access'Storage_Size use 0; - - type Cursor is record - Container : Vector_Access; - Index : Index_Type := Index_Type'First; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Vector'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Vector : constant Vector := (Capacity => 0, others => <>); - - No_Element : constant Cursor := Cursor'(null, Index_Type'First); - - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/a-cofove.adb b/gcc/ada/a-cofove.adb deleted file mode 100644 index 63cbebb..0000000 --- a/gcc/ada/a-cofove.adb +++ /dev/null @@ -1,1398 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Formal_Vectors with - SPARK_Mode => Off -is - - Growth_Factor : constant := 2; - -- When growing a container, multiply current capacity by this. Doubling - -- leads to amortized linear-time copying. - - type Int is range System.Min_Int .. System.Max_Int; - - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); - - type Maximal_Array_Ptr is access all Elements_Array (Array_Index) - with Storage_Size => 0; - type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) - with Storage_Size => 0; - - function Elems (Container : in out Vector) return Maximal_Array_Ptr; - function Elemsc - (Container : Vector) return Maximal_Array_Ptr_Const; - -- Returns a pointer to the Elements array currently in use -- either - -- Container.Elements_Ptr or a pointer to Container.Elements. We work with - -- pointers to a bogus array subtype that is constrained with the maximum - -- possible bounds. This means that the pointer is a thin pointer. This is - -- necessary because 'Unrestricted_Access doesn't work when it produces - -- access-to-unconstrained and is returned from a function. - -- - -- Note that this is dangerous: make sure calls to this use an indexed - -- component or slice that is within the bounds 1 .. Length (Container). - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type; - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; - - function Current_Capacity (Container : Vector) return Capacity_Range; - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - --------- - -- "=" -- - --------- - - function "=" (Left : Vector; Right : Vector) return Boolean is - begin - if Left'Address = Right'Address then - return True; - end if; - - if Length (Left) /= Length (Right) then - return False; - end if; - - for J in 1 .. Length (Left) loop - if Get_Element (Left, J) /= Get_Element (Right, J) then - return False; - end if; - end loop; - - return True; - end "="; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item); - end Append; - - procedure Append (Container : in out Vector; New_Item : Element_Type) is - begin - Append (Container, New_Item, 1); - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - end if; - - if Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - end if; - - Insert (Container, Container.Last + 1, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - Container.Last := No_Index; - - -- Free element, note that this is OK if Elements_Ptr is null - - Free (Container.Elements_Ptr); - end Clear; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - is - LS : constant Capacity_Range := Length (Source); - C : Capacity_Range; - - begin - if Capacity = 0 then - C := LS; - elsif Capacity >= LS then - C := Capacity; - else - raise Capacity_Error; - end if; - - return Target : Vector (C) do - Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS); - Target.Last := Source.Last; - end return; - end Copy; - - ---------------------- - -- Current_Capacity -- - ---------------------- - - function Current_Capacity (Container : Vector) return Capacity_Range is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Length - else - Container.Elements_Ptr.all'Length); - end Current_Capacity; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Vector; Index : Extended_Index) is - begin - Delete (Container, Index, 1); - end Delete; - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - is - Old_Last : constant Index_Type'Base := Container.Last; - Old_Len : constant Count_Type := Length (Container); - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - Off : Count_Type'Base; -- Index expressed as offset from IT'First - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - end if; - - return; - end if; - - if Count = 0 then - return; - end if; - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements aren't being deleted (the requested count was - -- less than the available count), so we must slide them down to Index. - -- We first calculate the index values of the respective array slices, - -- using the wider of Index_Type'Base and Count_Type'Base as the type - -- for intermediate calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Off := Count_Type'Base (Index - Index_Type'First); - New_Last := Old_Last - Index_Type'Base (Count); - else - Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - end if; - - -- The array index values for each slice have already been determined, - -- so we just slide down to Index the elements that weren't deleted. - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - Idx : constant Count_Type := EA'First + Off; - begin - EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); - Container.Last := New_Last; - end; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Vector) is - begin - Delete_First (Container, 1); - end Delete_First; - - procedure Delete_First (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Vector) is - begin - Delete_Last (Container, 1); - end Delete_Last; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) is - begin - if Count = 0 then - return; - end if; - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Length (Container) then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - begin - return Get_Element (Container, I); - end; - end Element; - - -------------- - -- Elements -- - -------------- - - function Elems (Container : in out Vector) return Maximal_Array_Ptr is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elems; - - function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is - begin - return - (if Container.Elements_Ptr = null then - Container.Elements'Unrestricted_Access - else - Container.Elements_Ptr.all'Unrestricted_Access); - end Elemsc; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - K : Capacity_Range; - Last : constant Index_Type := Last_Index (Container); - - begin - K := Capacity_Range (Int (Index) - Int (No_Index)); - for Indx in Index .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K + 1; - end loop; - - return No_Index; - end Find_Index; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, 1); - end if; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ------------------------- - -- M_Elements_In_Union -- - ------------------------- - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - is - Elem : Element_Type; - - begin - for Index in Index_Type'First .. M.Last (Container) loop - Elem := Element (Container, Index); - - if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) - and then - not M.Contains (Right, Index_Type'First, M.Last (Right), Elem) - then - return False; - end if; - end loop; - - return True; - end M_Elements_In_Union; - - ------------------------- - -- M_Elements_Included -- - ------------------------- - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - is - begin - for I in L_Fst .. L_Lst loop - declare - Found : Boolean := False; - J : Extended_Index := R_Fst - 1; - - begin - while not Found and J < R_Lst loop - J := J + 1; - if Element (Left, I) = Element (Right, J) then - Found := True; - end if; - end loop; - - if not Found then - return False; - end if; - end; - end loop; - - return True; - end M_Elements_Included; - - ------------------------- - -- M_Elements_Reversed -- - ------------------------- - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - is - L : constant Index_Type := M.Last (Left); - - begin - if L /= M.Last (Right) then - return False; - end if; - - for I in Index_Type'First .. L loop - if Element (Left, I) /= Element (Right, L - I + 1) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Reversed; - - ------------------------ - -- M_Elements_Swapted -- - ------------------------ - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - is - begin - if M.Length (Left) /= M.Length (Right) - or else Element (Left, X) /= Element (Right, Y) - or else Element (Left, Y) /= Element (Right, X) - then - return False; - end if; - - for I in Index_Type'First .. M.Last (Left) loop - if I /= X and then I /= Y - and then Element (Left, I) /= Element (Right, I) - then - return False; - end if; - end loop; - - return True; - end M_Elements_Swapped; - - ----------- - -- Model -- - ----------- - - function Model (Container : Vector) return M.Sequence is - R : M.Sequence; - - begin - for Position in 1 .. Length (Container) loop - R := M.Add (R, Elemsc (Container) (Position)); - end loop; - - return R; - end Model; - - end Formal_Model; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting with SPARK_Mode => Off is - - ------------------ - -- Formal_Model -- - ------------------ - - package body Formal_Model is - - ----------------------- - -- M_Elements_Sorted -- - ----------------------- - - function M_Elements_Sorted (Container : M.Sequence) return Boolean is - begin - if M.Length (Container) = 0 then - return True; - end if; - - declare - E1 : Element_Type := Element (Container, Index_Type'First); - - begin - for I in Index_Type'First + 1 .. M.Last (Container) loop - declare - E2 : constant Element_Type := Element (Container, I); - - begin - if E2 < E1 then - return False; - end if; - - E1 := E2; - end; - end loop; - end; - - return True; - end M_Elements_Sorted; - - end Formal_Model; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - L : constant Capacity_Range := Length (Container); - - begin - for J in 1 .. L - 1 loop - if Get_Element (Container, J + 1) < - Get_Element (Container, J) - then - return False; - end if; - end loop; - - return True; - end Is_Sorted; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - procedure Sort is - new Generic_Array_Sort - (Index_Type => Array_Index, - Element_Type => Element_Type, - Array_Type => Elements_Array, - "<" => "<"); - - Len : constant Capacity_Range := Length (Container); - - begin - if Container.Last <= Index_Type'First then - return; - else - Sort (Elems (Container) (1 .. Len)); - end if; - end Sort; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target : in out Vector; Source : in out Vector) is - I : Count_Type; - J : Count_Type; - - begin - if Target'Address = Source'Address then - raise Program_Error with "Target and Source denote same container"; - end if; - - if Length (Source) = 0 then - return; - end if; - - if Length (Target) = 0 then - Move (Target => Target, Source => Source); - return; - end if; - - I := Length (Target); - - declare - New_Length : constant Count_Type := I + Length (Source); - - begin - if not Bounded - and then Current_Capacity (Target) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Target, - Capacity_Range'Max - (Current_Capacity (Target) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Target.Last := No_Index + Index_Type'Base (New_Length); - - else - Target.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end; - - declare - TA : Maximal_Array_Ptr renames Elems (Target); - SA : Maximal_Array_Ptr renames Elems (Source); - - begin - J := Length (Target); - while Length (Source) /= 0 loop - if I = 0 then - TA (1 .. J) := SA (1 .. Length (Source)); - Source.Last := No_Index; - exit; - end if; - - if SA (Length (Source)) < TA (I) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Length (Source)); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - end Generic_Sorting; - - ----------------- - -- Get_Element -- - ----------------- - - function Get_Element - (Container : Vector; - Position : Capacity_Range) return Element_Type - is - begin - return Elemsc (Container) (Position); - end Get_Element; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - is - begin - return Position in First_Index (Container) .. Last_Index (Container); - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - is - begin - Insert (Container, Before, New_Item, 1); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - is - J : Count_Type'Base; -- scratch - - begin - -- Use Insert_Space to create the "hole" (the destination slice) - - Insert_Space (Container, Before, Count); - - J := To_Array_Index (Before); - - Elems (Container) (J .. J - 1 + Count) := (others => New_Item); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - B : Count_Type; -- index Before converted to Count_Type - - begin - if Container'Address = New_Item'Address then - raise Program_Error with - "Container and New_Item denote same container"; - end if; - - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - B := To_Array_Index (Before); - - Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Length (Container); - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - begin - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying where the new - -- items should be inserted, so we must manually check. (That the user - -- is allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for the - -- case of appending items to the back end of the vector. (It is assumed - -- that specifying an index value greater than Last + 1 indicates some - -- deeper flaw in the caller's algorithm, so that case is treated as a - -- proper error.) - - if Before > Container.Last - and then Before - 1 > Container.Last - then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - - -- We treat inserting 0 items into the container as a no-op, so we - -- simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note that the value cannot be simply added because the result may - -- overflow. - - if Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) - then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - J := To_Array_Index (Before); - - -- Increase the capacity of container if needed - - if not Bounded - and then Current_Capacity (Container) < Capacity_Range (New_Length) - then - Reserve_Capacity - (Container, - Capacity_Range'Max (Current_Capacity (Container) * Growth_Factor, - Capacity_Range (New_Length))); - end if; - - declare - EA : Maximal_Array_Ptr renames Elems (Container); - - begin - if Before <= Container.Last then - - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. - - EA (J + Count .. New_Length) := EA (J .. Old_Length); - end if; - end; - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Container.Last := No_Index + Index_Type'Base (New_Length); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Last_Index (Container) < Index_Type'First; - end Is_Empty; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Is_Empty (Container) then - raise Constraint_Error with "Container is empty"; - else - return Get_Element (Container, Length (Container)); - end if; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Capacity_Range is - L : constant Int := Int (Container.Last); - F : constant Int := Int (Index_Type'First); - N : constant Int'Base := L - F + 1; - - begin - return Capacity_Range (N); - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Vector; Source : in out Vector) is - LS : constant Capacity_Range := Length (Source); - - begin - if Target'Address = Source'Address then - return; - end if; - - if Bounded and then Target.Capacity < LS then - raise Constraint_Error; - end if; - - Clear (Target); - Append (Target, Source); - Clear (Source); - end Move; - - ------------ - -- Prepend -- - ------------ - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) is - begin - Prepend (Container, New_Item, 1); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - II : constant Int'Base := Int (Index) - Int (No_Index); - I : constant Capacity_Range := Capacity_Range (II); - - begin - Elems (Container) (I) := New_Item; - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - is - begin - if Bounded then - if Capacity > Container.Capacity then - raise Constraint_Error with "Capacity is out of range"; - end if; - - else - if Capacity > Formal_Vectors.Current_Capacity (Container) then - declare - New_Elements : constant Elements_Array_Ptr := - new Elements_Array (1 .. Capacity); - L : constant Capacity_Range := Length (Container); - - begin - New_Elements (1 .. L) := Elemsc (Container) (1 .. L); - Free (Container.Elements_Ptr); - Container.Elements_Ptr := New_Elements; - end; - end if; - end if; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Length (Container) <= 1 then - return; - end if; - - declare - I, J : Capacity_Range; - E : Elements_Array renames - Elems (Container) (1 .. Length (Container)); - - begin - I := 1; - J := Length (Container); - while I < J loop - declare - EI : constant Element_Type := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - Last : Index_Type'Base; - K : Capacity_Range; - - begin - if Index > Last_Index (Container) then - Last := Last_Index (Container); - else - Last := Index; - end if; - - K := Capacity_Range (Int (Last) - Int (No_Index)); - for Indx in reverse Index_Type'First .. Last loop - if Get_Element (Container, K) = Item then - return Indx; - end if; - - K := K - 1; - end loop; - - return No_Index; - end Reverse_Find_Index; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - is - begin - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - - if I = J then - return; - end if; - - declare - II : constant Int'Base := Int (I) - Int (No_Index); - JJ : constant Int'Base := Int (J) - Int (No_Index); - - EI : Element_Type renames Elems (Container) (Capacity_Range (II)); - EJ : Element_Type renames Elems (Container) (Capacity_Range (JJ)); - - EI_Copy : constant Element_Type := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - -------------------- - -- To_Array_Index -- - -------------------- - - function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is - Offset : Count_Type'Base; - - begin - -- We know that - -- Index >= Index_Type'First - -- hence we also know that - -- Index - Index_Type'First >= 0 - - -- The issue is that even though 0 is guaranteed to be a value in - -- the type Index_Type'Base, there's no guarantee that the difference - -- is a value in that type. To prevent overflow we use the wider - -- of Count_Type'Base and Index_Type'Base to perform intermediate - -- calculations. - - if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then - Offset := Count_Type'Base (Index - Index_Type'First); - - else - Offset := - Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); - end if; - - -- The array index subtype for all container element arrays always - -- starts with 1. - - return 1 + Offset; - end To_Array_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - is - begin - if Length = 0 then - return Empty_Vector; - end if; - - declare - First : constant Int := Int (Index_Type'First); - Last_As_Int : constant Int'Base := First + Int (Length) - 1; - Last : Index_Type; - - begin - if Last_As_Int > Index_Type'Pos (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; -- ??? - end if; - - Last := Index_Type (Last_As_Int); - - return - (Capacity => Length, - Last => Last, - Elements_Ptr => <>, - Elements => (others => New_Item)); - end; - end To_Vector; - -end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/a-cofove.ads b/gcc/ada/a-cofove.ads deleted file mode 100644 index 681e513..0000000 --- a/gcc/ada/a-cofove.ads +++ /dev/null @@ -1,924 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- This spec is derived from package Ada.Containers.Bounded_Vectors in the Ada --- 2012 RM. The modifications are meant to facilitate formal proofs by making --- it easier to express properties, and by making the specification of this --- unit compatible with SPARK 2014. Note that the API of this unit may be --- subject to incompatible changes as SPARK 2014 evolves. - -with Ada.Containers.Functional_Vectors; - -generic - type Index_Type is range <>; - type Element_Type is private; - - Bounded : Boolean := True; - -- If True, the containers are bounded; the initial capacity is the maximum - -- size, and heap allocation will be avoided. If False, the containers can - -- grow via heap allocation. - -package Ada.Containers.Formal_Vectors with - SPARK_Mode -is - pragma Annotate (CodePeer, Skip_Analysis); - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - Last_Count : constant Count_Type := - (if Index_Type'Last < Index_Type'First then - 0 - elsif Index_Type'Last < -1 - or else Index_Type'Pos (Index_Type'First) > - Index_Type'Pos (Index_Type'Last) - Count_Type'Last - then - Index_Type'Pos (Index_Type'Last) - - Index_Type'Pos (Index_Type'First) + 1 - else - Count_Type'Last); - -- Maximal capacity of any vector. It is the minimum of the size of the - -- index range and the last possible Count_Type. - - subtype Capacity_Range is Count_Type range 0 .. Last_Count; - - type Vector (Capacity : Capacity_Range) is limited private with - Default_Initial_Condition => Is_Empty (Vector); - -- In the bounded case, Capacity is the capacity of the container, which - -- never changes. In the unbounded case, Capacity is the initial capacity - -- of the container, and operations such as Reserve_Capacity and Append can - -- increase the capacity. The capacity never shrinks, except in the case of - -- Clear. - -- - -- Note that all objects of type Vector are constrained, including in the - -- unbounded case; you can't assign from one object to another if the - -- Capacity is different. - - function Length (Container : Vector) return Capacity_Range with - Global => null, - Post => Length'Result <= Capacity (Container); - - pragma Unevaluated_Use_Of_Old (Allow); - - package Formal_Model with Ghost is - - package M is new Ada.Containers.Functional_Vectors - (Index_Type => Index_Type, - Element_Type => Element_Type); - - function "=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."="; - - function "<" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<"; - - function "<=" - (Left : M.Sequence; - Right : M.Sequence) return Boolean renames M."<="; - - function M_Elements_In_Union - (Container : M.Sequence; - Left : M.Sequence; - Right : M.Sequence) return Boolean - -- The elements of Container are contained in either Left or Right - with - Global => null, - Post => - M_Elements_In_Union'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for some J in Index_Type'First .. M.Last (Left) => - Element (Container, I) = Element (Left, J)) - or (for some J in Index_Type'First .. M.Last (Right) => - Element (Container, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); - - function M_Elements_Included - (Left : M.Sequence; - L_Fst : Index_Type := Index_Type'First; - L_Lst : Extended_Index; - Right : M.Sequence; - R_Fst : Index_Type := Index_Type'First; - R_Lst : Extended_Index) return Boolean - -- The elements of the slice from L_Fst to L_Lst in Left are contained - -- in the slide from R_Fst to R_Lst in Right. - with - Global => null, - Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right), - Post => - M_Elements_Included'Result = - (for all I in L_Fst .. L_Lst => - (for some J in R_Fst .. R_Lst => - Element (Left, I) = Element (Right, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); - - function M_Elements_Reversed - (Left : M.Sequence; - Right : M.Sequence) return Boolean - -- Right is Left in reverse order - with - Global => null, - Post => - M_Elements_Reversed'Result = - (M.Length (Left) = M.Length (Right) - and (for all I in Index_Type'First .. M.Last (Left) => - Element (Left, I) = - Element (Right, M.Last (Left) - I + 1)) - and (for all I in Index_Type'First .. M.Last (Right) => - Element (Right, I) = - Element (Left, M.Last (Left) - I + 1))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); - - function M_Elements_Swapped - (Left : M.Sequence; - Right : M.Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Elements stored at X and Y are reversed in Left and Right - with - Global => null, - Pre => X <= M.Last (Left) and Y <= M.Last (Left), - Post => - M_Elements_Swapped'Result = - (M.Length (Left) = M.Length (Right) - and Element (Left, X) = Element (Right, Y) - and Element (Left, Y) = Element (Right, X) - and M.Equal_Except (Left, Right, X, Y)); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); - - function Model (Container : Vector) return M.Sequence with - -- The high-level model of a vector is a sequence of elements. The - -- sequence really is similar to the vector itself. However, it is not - -- limited which allows usage of 'Old and 'Loop_Entry attributes. - - Ghost, - Global => null, - Post => M.Length (Model'Result) = Length (Container); - - function Element - (S : M.Sequence; - I : Index_Type) return Element_Type renames M.Get; - -- To improve readability of contracts, we rename the function used to - -- access an element in the model to Element. - - end Formal_Model; - use Formal_Model; - - function Empty_Vector return Vector with - Global => null, - Post => Length (Empty_Vector'Result) = 0; - - function "=" (Left, Right : Vector) return Boolean with - Global => null, - Post => "="'Result = (Model (Left) = Model (Right)); - - function To_Vector - (New_Item : Element_Type; - Length : Capacity_Range) return Vector - with - Global => null, - Post => - Formal_Vectors.Length (To_Vector'Result) = Length - and M.Constant_Range - (Container => Model (To_Vector'Result), - Fst => Index_Type'First, - Lst => Last_Index (To_Vector'Result), - Item => New_Item); - - function Capacity (Container : Vector) return Capacity_Range with - Global => null, - Post => - Capacity'Result = - (if Bounded then - Container.Capacity - else - Capacity_Range'Last); - pragma Annotate (GNATprove, Inline_For_Proof, Capacity); - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Capacity_Range) - with - Global => null, - Pre => (if Bounded then Capacity <= Container.Capacity), - Post => Model (Container) = Model (Container)'Old; - - function Is_Empty (Container : Vector) return Boolean with - Global => null, - Post => Is_Empty'Result = (Length (Container) = 0); - - procedure Clear (Container : in out Vector) with - Global => null, - Post => Length (Container) = 0; - -- Note that this reclaims storage in the unbounded case. You need to call - -- this before a container goes out of scope in order to avoid storage - -- leaks. In addition, "X := ..." can leak unless you Clear(X) first. - - procedure Assign (Target : in out Vector; Source : Vector) with - Global => null, - Pre => (if Bounded then Length (Source) <= Target.Capacity), - Post => Model (Target) = Model (Source); - - function Copy - (Source : Vector; - Capacity : Capacity_Range := 0) return Vector - with - Global => null, - Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)), - Post => - Model (Copy'Result) = Model (Source) - and (if Capacity = 0 then - Copy'Result.Capacity = Length (Source) - else - Copy'Result.Capacity = Capacity); - - procedure Move (Target : in out Vector; Source : in out Vector) - with - Global => null, - Pre => (if Bounded then Length (Source) <= Capacity (Target)), - Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => Element'Result = Element (Model (Container), Index); - pragma Annotate (GNATprove, Inline_For_Proof, Element); - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - - -- Container now has New_Item at index Index - - and Element (Model (Container), Index) = New_Item - - -- All other elements are preserved - - and M.Equal_Except - (Left => Model (Container)'Old, - Right => Model (Container), - Position => Index); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item) - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Elements of New_Item are inserted at position Before - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => Count_Type (Before - Index_Type'First))) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type) - with - Global => null, - Pre => - Length (Container) < Capacity (Container) - and then (Before in Index_Type'First .. Last_Index (Container) + 1), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- Container now has New_Item at index Before - - and Element (Model (Container), Before) = New_Item - - -- Elements located after Before in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Count - and (Before in Index_Type'First .. Last_Index (Container) - or (Before /= No_Index - and then Before - 1 = Last_Index (Container))), - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements located before Before in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Before - 1) - - -- New_Item is inserted Count times at position Before - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Before, - Lst => Before + Index_Type'Base (Count - 1), - Item => New_Item)) - - -- Elements located after Before in Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Before, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Prepend (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- Elements of New_Item are inserted at the beginning of Container - - and M.Range_Equal - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item)) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Length (New_Item)); - - procedure Prepend (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Container now has New_Item at Index_Type'First - - and Element (Model (Container), Index_Type'First) = New_Item - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- New_Item is inserted Count times at the beginning of Container - - and M.Constant_Range - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Index_Type'First + Index_Type'Base (Count - 1), - Item => New_Item) - - -- Elements of Container are shifted - - and M.Range_Shifted - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container)'Old, - Offset => Count); - - procedure Append (Container : in out Vector; New_Item : Vector) with - Global => null, - Pre => - Length (Container) <= Capacity (Container) - Length (New_Item), - Post => - Length (Container) = Length (Container)'Old + Length (New_Item) - - -- The elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- Elements of New_Item are inserted at the end of Container - - and (if Length (New_Item) > 0 then - M.Range_Shifted - (Left => Model (New_Item), - Right => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (New_Item), - Offset => - Count_Type - (Last_Index (Container)'Old - Index_Type'First + 1))); - - procedure Append (Container : in out Vector; New_Item : Element_Type) with - Global => null, - Pre => Length (Container) < Capacity (Container), - Post => - Length (Container) = Length (Container)'Old + 1 - - -- Elements of Container are preserved - - and Model (Container)'Old < Model (Container) - - -- Container now has New_Item at the end of Container - - and Element - (Model (Container), Last_Index (Container)'Old + 1) = New_Item; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - with - Global => null, - Pre => Length (Container) <= Capacity (Container) - Count, - Post => - Length (Container) = Length (Container)'Old + Count - - -- Elements of Container are preserved - - and Model (Container)'Old <= Model (Container) - - -- New_Item is inserted Count times at the end of Container - - and (if Count > 0 then - M.Constant_Range - (Container => Model (Container), - Fst => Last_Index (Container)'Old + 1, - Lst => - Last_Index (Container)'Old + Index_Type'Base (Count), - Item => New_Item)); - - procedure Delete (Container : in out Vector; Index : Extended_Index) with - Global => null, - Pre => Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements located before Index in Container are preserved - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1) - - -- Elements located after Index in Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type) - with - Global => null, - Pre => - Index in First_Index (Container) .. Last_Index (Container), - Post => - Length (Container) in - Length (Container)'Old - Count .. Length (Container)'Old - - -- The elements of Container located before Index are preserved. - - and M.Range_Equal - (Left => Model (Container)'Old, - Right => Model (Container), - Fst => Index_Type'First, - Lst => Index - 1), - - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => - Length (Container) = Count_Type (Index - Index_Type'First), - - others => - Length (Container) = Length (Container)'Old - Count - - -- Other elements are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_First (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are shifted by 1 - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => 1); - - procedure Delete_First (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements of Container have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- Elements of Container are shifted by Count - - and M.Range_Shifted - (Left => Model (Container), - Right => Model (Container)'Old, - Fst => Index_Type'First, - Lst => Last_Index (Container), - Offset => Count)); - - procedure Delete_Last (Container : in out Vector) with - Global => null, - Pre => Length (Container) > 0, - Post => - Length (Container) = Length (Container)'Old - 1 - - -- Elements of Container are preserved - - and Model (Container) < Model (Container)'Old; - - procedure Delete_Last (Container : in out Vector; Count : Count_Type) with - Global => null, - Contract_Cases => - - -- All the elements after Position have been erased - - (Length (Container) <= Count => Length (Container) = 0, - - others => - Length (Container) = Length (Container)'Old - Count - - -- The elements of Container are preserved - - and Model (Container) <= Model (Container)'Old); - - procedure Reverse_Elements (Container : in out Vector) with - Global => null, - Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); - - procedure Swap - (Container : in out Vector; - I : Index_Type; - J : Index_Type) - with - Global => null, - Pre => - I in First_Index (Container) .. Last_Index (Container) - and then J in First_Index (Container) .. Last_Index (Container), - Post => - M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); - - function First_Index (Container : Vector) return Index_Type with - Global => null, - Post => First_Index'Result = Index_Type'First; - pragma Annotate (GNATprove, Inline_For_Proof, First_Index); - - function First_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - First_Element'Result = Element (Model (Container), Index_Type'First); - pragma Annotate (GNATprove, Inline_For_Proof, First_Element); - - function Last_Index (Container : Vector) return Extended_Index with - Global => null, - Post => Last_Index'Result = M.Last (Model (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); - - function Last_Element (Container : Vector) return Element_Type with - Global => null, - Pre => not Is_Empty (Container), - Post => - Last_Element'Result = - Element (Model (Container), Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container after Index, Find_Index - -- returns No_Index. - - (Index > Last_Index (Container) - or else not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Last_Index (Container), - Item => Item) - => - Find_Index'Result = No_Index, - - -- Otherwise, Find_Index returns a valid index greater than Index - - others => - Find_Index'Result in Index .. Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Find_Index'Result) = Item - - -- It is the first occurrence of Item after Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Index, - Lst => Find_Index'Result - 1, - Item => Item)); - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - with - Global => null, - Contract_Cases => - - -- If Item is not contained in Container before Index, - -- Reverse_Find_Index returns No_Index. - - (not M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => (if Index <= Last_Index (Container) then Index - else Last_Index (Container)), - Item => Item) - => - Reverse_Find_Index'Result = No_Index, - - -- Otherwise, Reverse_Find_Index returns a valid index smaller than - -- Index - - others => - Reverse_Find_Index'Result in Index_Type'First .. Index - and Reverse_Find_Index'Result <= Last_Index (Container) - - -- The element at this index in Container is Item - - and Element (Model (Container), Reverse_Find_Index'Result) = Item - - -- It is the last occurrence of Item before Index in Container - - and not M.Contains - (Container => Model (Container), - Fst => Reverse_Find_Index'Result + 1, - Lst => - (if Index <= Last_Index (Container) then - Index - else - Last_Index (Container)), - Item => Item)); - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - with - Global => null, - Post => - Contains'Result = - M.Contains - (Container => Model (Container), - Fst => Index_Type'First, - Lst => Last_Index (Container), - Item => Item); - - function Has_Element - (Container : Vector; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Has_Element'Result = - (Position in Index_Type'First .. Last_Index (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting with SPARK_Mode is - - package Formal_Model with Ghost is - - function M_Elements_Sorted (Container : M.Sequence) return Boolean - with - Global => null, - Post => - M_Elements_Sorted'Result = - (for all I in Index_Type'First .. M.Last (Container) => - (for all J in I .. M.Last (Container) => - Element (Container, I) = Element (Container, J) - or Element (Container, I) < Element (Container, J))); - pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); - - end Formal_Model; - use Formal_Model; - - function Is_Sorted (Container : Vector) return Boolean with - Global => null, - Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); - - procedure Sort (Container : in out Vector) with - Global => null, - Post => - Length (Container) = Length (Container)'Old - and M_Elements_Sorted (Model (Container)) - and M_Elements_Included - (Left => Model (Container)'Old, - L_Lst => Last_Index (Container), - Right => Model (Container), - R_Lst => Last_Index (Container)) - and M_Elements_Included - (Left => Model (Container), - L_Lst => Last_Index (Container), - Right => Model (Container)'Old, - R_Lst => Last_Index (Container)); - - procedure Merge (Target : in out Vector; Source : in out Vector) with - -- Target and Source should not be aliased - Global => null, - Pre => Length (Source) <= Capacity (Target) - Length (Target), - Post => - Length (Target) = Length (Target)'Old + Length (Source)'Old - and Length (Source) = 0 - and (if M_Elements_Sorted (Model (Target)'Old) - and M_Elements_Sorted (Model (Source)'Old) - then - M_Elements_Sorted (Model (Target))) - and M_Elements_Included - (Left => Model (Target)'Old, - L_Lst => Last_Index (Target)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_Included - (Left => Model (Source)'Old, - L_Lst => Last_Index (Source)'Old, - Right => Model (Target), - R_Lst => Last_Index (Target)) - and M_Elements_In_Union - (Model (Target), - Model (Source)'Old, - Model (Target)'Old); - end Generic_Sorting; - -private - pragma SPARK_Mode (Off); - - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Replace_Element); - pragma Inline (Contains); - - subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; - type Elements_Array is array (Array_Index range <>) of Element_Type; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Elements_Array_Ptr is access all Elements_Array; - - type Vector (Capacity : Capacity_Range) is limited record - - -- In the bounded case, the elements are stored in Elements. In the - -- unbounded case, the elements are initially stored in Elements, until - -- we run out of room, then we switch to Elements_Ptr. - - Last : Extended_Index := No_Index; - Elements_Ptr : Elements_Array_Ptr := null; - Elements : aliased Elements_Array (1 .. Capacity); - end record; - - -- The primary reason Vector is limited is that in the unbounded case, once - -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will - -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr, - -- so for example "Append (X, ...);" will modify BOTH X and Y. That would - -- allow SPARK to "prove" things that are false. We could fix that by - -- making Vector a controlled type, and override Adjust to make a deep - -- copy, but finalization is not allowed in SPARK. - -- - -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not - -- allowed on Vectors. - - function Empty_Vector return Vector is - ((Capacity => 0, others => <>)); - -end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/a-cofuba.adb b/gcc/ada/a-cofuba.adb deleted file mode 100644 index 4e7ac38..0000000 --- a/gcc/ada/a-cofuba.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_BASE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -pragma Ada_2012; - -package body Ada.Containers.Functional_Base with SPARK_Mode => Off is - - function To_Count (Idx : Extended_Index) return Count_Type is - (Count_Type - (Extended_Index'Pos (Idx) - - Extended_Index'Pos (Extended_Index'First))); - - function To_Index (Position : Count_Type) return Extended_Index is - (Extended_Index'Val - (Position + Extended_Index'Pos (Extended_Index'First))); - -- Conversion functions between Index_Type and Count_Type - - function Find (C : Container; E : access Element_Type) return Count_Type; - -- Search a container C for an element equal to E.all, returning the - -- position in the underlying array. - - --------- - -- "=" -- - --------- - - function "=" (C1 : Container; C2 : Container) return Boolean is - begin - if C1.Elements'Length /= C2.Elements'Length then - return False; - end if; - - for I in C1.Elements'Range loop - if C1.Elements (I).all /= C2.Elements (I).all then - return False; - end if; - end loop; - - return True; - end "="; - - ---------- - -- "<=" -- - ---------- - - function "<=" (C1 : Container; C2 : Container) return Boolean is - begin - for I in C1.Elements'Range loop - if Find (C2, C1.Elements (I)) = 0 then - return False; - end if; - end loop; - - return True; - end "<="; - - --------- - -- Add -- - --------- - - function Add - (C : Container; - I : Index_Type; - E : Element_Type) return Container - is - A : constant Element_Array_Access := - new Element_Array'(1 .. C.Elements'Last + 1 => <>); - P : Count_Type := 0; - - begin - for J in 1 .. C.Elements'Last + 1 loop - if J /= To_Count (I) then - P := P + 1; - A (J) := C.Elements (P); - else - A (J) := new Element_Type'(E); - end if; - end loop; - - return Container'(Elements => A); - end Add; - - ---------- - -- Find -- - ---------- - - function Find (C : Container; E : access Element_Type) return Count_Type is - begin - for I in C.Elements'Range loop - if C.Elements (I).all = E.all then - return I; - end if; - end loop; - - return 0; - end Find; - - function Find (C : Container; E : Element_Type) return Extended_Index is - (To_Index (Find (C, E'Unrestricted_Access))); - - --------- - -- Get -- - --------- - - function Get (C : Container; I : Index_Type) return Element_Type is - (C.Elements (To_Count (I)).all); - - ------------------ - -- Intersection -- - ------------------ - - function Intersection (C1 : Container; C2 : Container) return Container is - A : constant Element_Array_Access := - new Element_Array'(1 .. Num_Overlaps (C1, C2) => <>); - P : Count_Type := 0; - - begin - for I in C1.Elements'Range loop - if Find (C2, C1.Elements (I)) > 0 then - P := P + 1; - A (P) := C1.Elements (I); - end if; - end loop; - - return Container'(Elements => A); - end Intersection; - - ------------ - -- Length -- - ------------ - - function Length (C : Container) return Count_Type is (C.Elements'Length); - - --------------------- - -- Num_Overlaps -- - --------------------- - - function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is - P : Count_Type := 0; - - begin - for I in C1.Elements'Range loop - if Find (C2, C1.Elements (I)) > 0 then - P := P + 1; - end if; - end loop; - - return P; - end Num_Overlaps; - - ------------ - -- Remove -- - ------------ - - function Remove (C : Container; I : Index_Type) return Container is - A : constant Element_Array_Access := - new Element_Array'(1 .. C.Elements'Last - 1 => <>); - P : Count_Type := 0; - - begin - for J in C.Elements'Range loop - if J /= To_Count (I) then - P := P + 1; - A (P) := C.Elements (J); - end if; - end loop; - - return Container'(Elements => A); - end Remove; - - --------- - -- Set -- - --------- - - function Set - (C : Container; - I : Index_Type; - E : Element_Type) return Container - is - Result : constant Container := - Container'(Elements => new Element_Array'(C.Elements.all)); - - begin - Result.Elements (To_Count (I)) := new Element_Type'(E); - return Result; - end Set; - - ----------- - -- Union -- - ----------- - - function Union (C1 : Container; C2 : Container) return Container is - N : constant Count_Type := Num_Overlaps (C1, C2); - - begin - -- if C2 is completely included in C1 then return C1 - - if N = Length (C2) then - return C1; - end if; - - -- else loop through C2 to find the remaining elements - - declare - L : constant Count_Type := Length (C1) - N + Length (C2); - A : constant Element_Array_Access := - new Element_Array' - (C1.Elements.all & (Length (C1) + 1 .. L => <>)); - P : Count_Type := Length (C1); - - begin - for I in C2.Elements'Range loop - if Find (C1, C2.Elements (I)) = 0 then - P := P + 1; - A (P) := C2.Elements (I); - end if; - end loop; - - return Container'(Elements => A); - end; - end Union; - -end Ada.Containers.Functional_Base; diff --git a/gcc/ada/a-cofuba.ads b/gcc/ada/a-cofuba.ads deleted file mode 100644 index 92bc6bd..0000000 --- a/gcc/ada/a-cofuba.ads +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_BASE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- --- Functional containers are neither controlled nor limited. This is safe, as --- no primitives are provided to modify them. --- Memory allocated inside functional containers is never reclaimed. - -pragma Ada_2012; - -private generic - type Index_Type is (<>); - -- To avoid Constraint_Error being raised at run time, Index_Type'Base - -- should have at least one more element at the low end than Index_Type. - - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Functional_Base with SPARK_Mode => Off is - - subtype Extended_Index is Index_Type'Base range - Index_Type'Pred (Index_Type'First) .. Index_Type'Last; - - type Container is private; - - function "=" (C1 : Container; C2 : Container) return Boolean; - -- Return True if C1 and C2 contain the same elements at the same position - - function Length (C : Container) return Count_Type; - -- Number of elements stored in C - - function Get (C : Container; I : Index_Type) return Element_Type; - -- Access to the element at index I in C - - function Set - (C : Container; - I : Index_Type; - E : Element_Type) return Container; - -- Return a new container which is equal to C except for the element at - -- index I, which is set to E. - - function Add - (C : Container; - I : Index_Type; - E : Element_Type) return Container; - -- Return a new container that is C with E inserted at index I - - function Remove (C : Container; I : Index_Type) return Container; - -- Return a new container that is C without the element at index I - - function Find (C : Container; E : Element_Type) return Extended_Index; - -- Return the first index for which the element stored in C is I. If there - -- are no such indexes, return Extended_Index'First. - - -------------------- - -- Set Operations -- - -------------------- - - function "<=" (C1 : Container; C2 : Container) return Boolean; - -- Return True if every element of C1 is in C2 - - function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type; - -- Return the number of elements that are in both C1 and C2 - - function Union (C1 : Container; C2 : Container) return Container; - -- Return a container which is C1 plus all the elements of C2 that are not - -- in C1. - - function Intersection (C1 : Container; C2 : Container) return Container; - -- Return a container which is C1 minus all the elements that are also in - -- C2. - -private - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - type Element_Access is access all Element_Type; - - type Element_Array is - array (Positive_Count_Type range <>) of Element_Access; - - type Element_Array_Access is not null access Element_Array; - - Empty_Element_Array_Access : constant Element_Array_Access := - new Element_Array'(1 .. 0 => null); - - type Container is record - Elements : Element_Array_Access := Empty_Element_Array_Access; - end record; - -end Ada.Containers.Functional_Base; diff --git a/gcc/ada/a-cofuma.adb b/gcc/ada/a-cofuma.adb deleted file mode 100644 index 93a38b5..0000000 --- a/gcc/ada/a-cofuma.adb +++ /dev/null @@ -1,284 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_MAPS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is - use Key_Containers; - use Element_Containers; - - --------- - -- "=" -- - --------- - - function "=" (Left : Map; Right : Map) return Boolean is - (Left.Keys <= Right.Keys and Right <= Left); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Map; Right : Map) return Boolean is - I2 : Count_Type; - - begin - for I1 in 1 .. Length (Left.Keys) loop - I2 := Find (Right.Keys, Get (Left.Keys, I1)); - if I2 = 0 - or else Get (Right.Elements, I2) /= Get (Left.Elements, I1) - then - return False; - end if; - end loop; - return True; - end "<="; - - --------- - -- Add -- - --------- - - function Add - (Container : Map; - New_Key : Key_Type; - New_Item : Element_Type) return Map - is - begin - return - (Keys => - Add (Container.Keys, Length (Container.Keys) + 1, New_Key), - Elements => - Add - (Container.Elements, Length (Container.Elements) + 1, New_Item)); - end Add; - - --------------------------- - -- Elements_Equal_Except -- - --------------------------- - - function Elements_Equal_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - is - begin - for I in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, I); - begin - if not Equivalent_Keys (K, New_Key) - and then - (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, I)) - then - return False; - end if; - end; - end loop; - return True; - end Elements_Equal_Except; - - function Elements_Equal_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - is - begin - for I in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, I); - begin - if not Equivalent_Keys (K, X) - and then not Equivalent_Keys (K, Y) - and then - (Find (Right.Keys, K) = 0 - or else Get (Right.Elements, Find (Right.Keys, K)) /= - Get (Left.Elements, I)) - then - return False; - end if; - end; - end loop; - return True; - end Elements_Equal_Except; - - --------- - -- Get -- - --------- - - function Get (Container : Map; Key : Key_Type) return Element_Type is - begin - return Get (Container.Elements, Find (Container.Keys, Key)); - end Get; - - ------------- - -- Has_Key -- - ------------- - - function Has_Key (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container.Keys, Key) > 0; - end Has_Key; - - ----------------- - -- Has_Witness -- - ----------------- - - function Has_Witness - (Container : Map; - Witness : Count_Type) return Boolean - is - (Witness in 1 .. Length (Container.Keys)); - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Length (Container.Keys) = 0; - end Is_Empty; - - ------------------- - -- Keys_Included -- - ------------------- - - function Keys_Included (Left : Map; Right : Map) return Boolean is - begin - for I in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, I); - begin - if Find (Right.Keys, K) = 0 then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included; - - -------------------------- - -- Keys_Included_Except -- - -------------------------- - - function Keys_Included_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - is - begin - for I in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, I); - begin - if not Equivalent_Keys (K, New_Key) - and then Find (Right.Keys, K) = 0 - then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included_Except; - - function Keys_Included_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - is - begin - for I in 1 .. Length (Left.Keys) loop - declare - K : constant Key_Type := Get (Left.Keys, I); - begin - if not Equivalent_Keys (K, X) - and then not Equivalent_Keys (K, Y) - and then Find (Right.Keys, K) = 0 - then - return False; - end if; - end; - end loop; - - return True; - end Keys_Included_Except; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Length (Container.Elements); - end Length; - - --------------- - -- Same_Keys -- - --------------- - - function Same_Keys (Left : Map; Right : Map) return Boolean is - (Keys_Included (Left, Right) - and Keys_Included (Left => Right, Right => Left)); - - --------- - -- Set -- - --------- - - function Set - (Container : Map; - Key : Key_Type; - New_Item : Element_Type) return Map - is - (Keys => Container.Keys, - Elements => - Set (Container.Elements, Find (Container.Keys, Key), New_Item)); - - ----------- - -- W_Get -- - ----------- - - function W_Get - (Container : Map; - Witness : Count_Type) return Element_Type - is - (Get (Container.Elements, Witness)); - - ------------- - -- Witness -- - ------------- - - function Witness (Container : Map; Key : Key_Type) return Count_Type is - (Find (Container.Keys, Key)); - -end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/a-cofuma.ads b/gcc/ada/a-cofuma.ads deleted file mode 100644 index f98bfe7..0000000 --- a/gcc/ada/a-cofuma.ads +++ /dev/null @@ -1,361 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_MAPS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -private with Ada.Containers.Functional_Base; - -generic - type Key_Type (<>) is private; - type Element_Type (<>) is private; - - with function Equivalent_Keys - (Left : Key_Type; - Right : Key_Type) return Boolean is "="; - - Enable_Handling_Of_Equivalence : Boolean := True; - -- This constant should only be set to False when no particular handling - -- of equivalence over keys is needed, that is, Equivalent_Keys defines a - -- key uniquely. - -package Ada.Containers.Functional_Maps with SPARK_Mode is - - type Map is private with - Default_Initial_Condition => Is_Empty (Map) and Length (Map) = 0, - Iterable => (First => Iter_First, - Next => Iter_Next, - Has_Element => Iter_Has_Element, - Element => Iter_Element); - -- Maps are empty when default initialized. - -- "For in" quantification over maps should not be used. - -- "For of" quantification over maps iterates over keys. - -- Note that, for proof, "for of" quantification is understood modulo - -- equivalence (the range of quantification comprises all the keys that are - -- equivalent to any key of the map). - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Maps are axiomatized using Has_Key and Get, encoding respectively the - -- presence of a key in a map and an accessor to elements associated with - -- its keys. The length of a map is also added to protect Add against - -- overflows but it is not actually modeled. - - function Has_Key (Container : Map; Key : Key_Type) return Boolean with - -- Return True if Key is present in Container - - Global => null, - Post => - (if Enable_Handling_Of_Equivalence then - - -- Has_Key returns the same result on all equivalent keys - - (if (for some K of Container => Equivalent_Keys (K, Key)) then - Has_Key'Result)); - - function Get (Container : Map; Key : Key_Type) return Element_Type with - -- Return the element associated with Key in Container - - Global => null, - Pre => Has_Key (Container, Key), - Post => - (if Enable_Handling_Of_Equivalence then - - -- Get returns the same result on all equivalent keys - - Get'Result = W_Get (Container, Witness (Container, Key)) - and (for all K of Container => - (Equivalent_Keys (K, Key) = - (Witness (Container, Key) = Witness (Container, K))))); - - function Length (Container : Map) return Count_Type with - Global => null; - -- Return the number of mappings in Container - - ------------------------ - -- Property Functions -- - ------------------------ - - function "<=" (Left : Map; Right : Map) return Boolean with - -- Map inclusion - - Global => null, - Post => - "<="'Result = - (for all Key of Left => - Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key)); - - function "=" (Left : Map; Right : Map) return Boolean with - -- Extensional equality over maps - - Global => null, - Post => - "="'Result = - ((for all Key of Left => - Has_Key (Right, Key) - and then Get (Right, Key) = Get (Left, Key)) - and (for all Key of Right => Has_Key (Left, Key))); - - pragma Warnings (Off, "unused variable ""Key"""); - function Is_Empty (Container : Map) return Boolean with - -- A map is empty if it contains no key - - Global => null, - Post => Is_Empty'Result = (for all Key of Container => False); - pragma Warnings (On, "unused variable ""Key"""); - - function Keys_Included (Left : Map; Right : Map) return Boolean - -- Returns True if every Key of Left is in Right - - with - Global => null, - Post => - Keys_Included'Result = (for all Key of Left => Has_Key (Right, Key)); - - function Same_Keys (Left : Map; Right : Map) return Boolean - -- Returns True if Left and Right have the same keys - - with - Global => null, - Post => - Same_Keys'Result = - (Keys_Included (Left, Right) - and Keys_Included (Left => Right, Right => Left)); - pragma Annotate (GNATprove, Inline_For_Proof, Same_Keys); - - function Keys_Included_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - -- Returns True if Left contains only keys of Right and possibly New_Key - - with - Global => null, - Post => - Keys_Included_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, New_Key) then - Has_Key (Right, Key))); - - function Keys_Included_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - -- Returns True if Left contains only keys of Right and possibly X and Y - - with - Global => null, - Post => - Keys_Included_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, X) - and not Equivalent_Keys (Key, Y) - then - Has_Key (Right, Key))); - - function Elements_Equal_Except - (Left : Map; - Right : Map; - New_Key : Key_Type) return Boolean - -- Returns True if all the keys of Left are mapped to the same elements in - -- Left and Right except New_Key. - - with - Global => null, - Post => - Elements_Equal_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, New_Key) then - Has_Key (Right, Key) - and then Get (Left, Key) = Get (Right, Key))); - - function Elements_Equal_Except - (Left : Map; - Right : Map; - X : Key_Type; - Y : Key_Type) return Boolean - -- Returns True if all the keys of Left are mapped to the same elements in - -- Left and Right except X and Y. - - with - Global => null, - Post => - Elements_Equal_Except'Result = - (for all Key of Left => - (if not Equivalent_Keys (Key, X) - and not Equivalent_Keys (Key, Y) - then - Has_Key (Right, Key) - and then Get (Left, Key) = Get (Right, Key))); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Add - (Container : Map; - New_Key : Key_Type; - New_Item : Element_Type) return Map - -- Returns Container augmented with the mapping Key -> New_Item - - with - Global => null, - Pre => - not Has_Key (Container, New_Key) - and Length (Container) < Count_Type'Last, - Post => - Length (Container) + 1 = Length (Add'Result) - and Has_Key (Add'Result, New_Key) - and Get (Add'Result, New_Key) = New_Item - and Container <= Add'Result - and Keys_Included_Except (Add'Result, Container, New_Key); - - function Set - (Container : Map; - Key : Key_Type; - New_Item : Element_Type) return Map - -- Returns Container, where the element associated with Key has been - -- replaced by New_Item. - - with - Global => null, - Pre => Has_Key (Container, Key), - Post => - Length (Container) = Length (Set'Result) - and Get (Set'Result, Key) = New_Item - and Same_Keys (Container, Set'Result) - and Elements_Equal_Except (Container, Set'Result, Key); - - ------------------------------ - -- Handling of Equivalence -- - ------------------------------ - - -- These functions are used to specify that Get returns the same value on - -- equivalent keys. They should not be used directly in user code. - - function Has_Witness (Container : Map; Witness : Count_Type) return Boolean - with - Ghost, - Global => null; - -- Returns True if there is a key with witness Witness in Container - - function Witness (Container : Map; Key : Key_Type) return Count_Type with - -- Returns the witness of Key in Container - - Ghost, - Global => null, - Pre => Has_Key (Container, Key), - Post => Has_Witness (Container, Witness'Result); - - function W_Get (Container : Map; Witness : Count_Type) return Element_Type - with - -- Returns the element associated with a witness in Container - - Ghost, - Global => null, - Pre => Has_Witness (Container, Witness); - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - type Private_Key is private; - - function Iter_First (Container : Map) return Private_Key with - Global => null; - - function Iter_Has_Element - (Container : Map; - Key : Private_Key) return Boolean - with - Global => null; - - function Iter_Next (Container : Map; Key : Private_Key) return Private_Key - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - - function Iter_Element (Container : Map; Key : Private_Key) return Key_Type - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Has_Key); - -private - - pragma SPARK_Mode (Off); - - function "=" - (Left : Key_Type; - Right : Key_Type) return Boolean renames Equivalent_Keys; - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - package Element_Containers is new Ada.Containers.Functional_Base - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - package Key_Containers is new Ada.Containers.Functional_Base - (Element_Type => Key_Type, - Index_Type => Positive_Count_Type); - - type Map is record - Keys : Key_Containers.Container; - Elements : Element_Containers.Container; - end record; - - type Private_Key is new Count_Type; - - function Iter_First (Container : Map) return Private_Key is (1); - - function Iter_Has_Element - (Container : Map; - Key : Private_Key) return Boolean - is - (Count_Type (Key) in 1 .. Key_Containers.Length (Container.Keys)); - - function Iter_Next - (Container : Map; - Key : Private_Key) return Private_Key - is - (if Key = Private_Key'Last then 0 else Key + 1); - - function Iter_Element - (Container : Map; - Key : Private_Key) return Key_Type - is - (Key_Containers.Get (Container.Keys, Count_Type (Key))); - -end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/a-cofuse.adb b/gcc/ada/a-cofuse.adb deleted file mode 100644 index 22bf688..0000000 --- a/gcc/ada/a-cofuse.adb +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_SETS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -pragma Ada_2012; - -package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is - use Containers; - - --------- - -- "=" -- - --------- - - function "=" (Left : Set; Right : Set) return Boolean is - (Left.Content <= Right.Content and Right.Content <= Left.Content); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Set; Right : Set) return Boolean is - (Left.Content <= Right.Content); - - --------- - -- Add -- - --------- - - function Add (Container : Set; Item : Element_Type) return Set is - (Content => - Add (Container.Content, Length (Container.Content) + 1, Item)); - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - (Find (Container.Content, Item) > 0); - - --------------------- - -- Included_Except -- - --------------------- - - function Included_Except - (Left : Set; - Right : Set; - Item : Element_Type) return Boolean - is - (for all E of Left => - Equivalent_Elements (E, Item) or Contains (Right, E)); - - ----------------------- - -- Included_In_Union -- - ----------------------- - - function Included_In_Union - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Container => - Contains (Left, Item) or Contains (Right, Item)); - - --------------------------- - -- Includes_Intersection -- - --------------------------- - - function Includes_Intersection - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Left => - (if Contains (Right, Item) then Contains (Container, Item))); - - ------------------ - -- Intersection -- - ------------------ - - function Intersection (Left : Set; Right : Set) return Set is - (Content => Intersection (Left.Content, Right.Content)); - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - (Length (Container.Content) = 0); - - ------------------ - -- Is_Singleton -- - ------------------ - - function Is_Singleton - (Container : Set; - New_Item : Element_Type) return Boolean - is - (Length (Container.Content) = 1 - and New_Item = Get (Container.Content, 1)); - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - (Length (Container.Content)); - - ----------------- - -- Not_In_Both -- - ----------------- - - function Not_In_Both - (Container : Set; - Left : Set; - Right : Set) return Boolean - is - (for all Item of Container => - not Contains (Right, Item) or not Contains (Left, Item)); - - ---------------- - -- No_Overlap -- - ---------------- - - function No_Overlap (Left : Set; Right : Set) return Boolean is - (Num_Overlaps (Left.Content, Right.Content) = 0); - - ------------------ - -- Num_Overlaps -- - ------------------ - - function Num_Overlaps (Left : Set; Right : Set) return Count_Type is - (Num_Overlaps (Left.Content, Right.Content)); - - ------------ - -- Remove -- - ------------ - - function Remove (Container : Set; Item : Element_Type) return Set is - (Content => Remove (Container.Content, Find (Container.Content, Item))); - - ----------- - -- Union -- - ----------- - - function Union (Left : Set; Right : Set) return Set is - (Content => Union (Left.Content, Right.Content)); - -end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/a-cofuse.ads b/gcc/ada/a-cofuse.ads deleted file mode 100644 index 5eafbc4..0000000 --- a/gcc/ada/a-cofuse.ads +++ /dev/null @@ -1,322 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_SETS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -private with Ada.Containers.Functional_Base; - -generic - type Element_Type (<>) is private; - - with function Equivalent_Elements - (Left : Element_Type; - Right : Element_Type) return Boolean is "="; - - Enable_Handling_Of_Equivalence : Boolean := True; - -- This constant should only be set to False when no particular handling - -- of equivalence over elements is needed, that is, Equivalent_Elements - -- defines an element uniquely. - -package Ada.Containers.Functional_Sets with SPARK_Mode is - - type Set is private with - Default_Initial_Condition => Is_Empty (Set), - Iterable => (First => Iter_First, - Next => Iter_Next, - Has_Element => Iter_Has_Element, - Element => Iter_Element); - -- Sets are empty when default initialized. - -- "For in" quantification over sets should not be used. - -- "For of" quantification over sets iterates over elements. - -- Note that, for proof, "for of" quantification is understood modulo - -- equivalence (the range of quantification comprises all the elements that - -- are equivalent to any element of the set). - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Sets are axiomatized using Contains, which encodes whether an element is - -- contained in a set. The length of a set is also added to protect Add - -- against overflows but it is not actually modeled. - - function Contains (Container : Set; Item : Element_Type) return Boolean with - -- Return True if Item is contained in Container - - Global => null, - Post => - (if Enable_Handling_Of_Equivalence then - - -- Contains returns the same result on all equivalent elements - - (if (for some E of Container => Equivalent_Elements (E, Item)) then - Contains'Result)); - - function Length (Container : Set) return Count_Type with - Global => null; - -- Return the number of elements in Container - - ------------------------ - -- Property Functions -- - ------------------------ - - function "<=" (Left : Set; Right : Set) return Boolean with - -- Set inclusion - - Global => null, - Post => "<="'Result = (for all Item of Left => Contains (Right, Item)); - - function "=" (Left : Set; Right : Set) return Boolean with - -- Extensional equality over sets - - Global => null, - Post => "="'Result = (Left <= Right and Right <= Left); - - pragma Warnings (Off, "unused variable ""Item"""); - function Is_Empty (Container : Set) return Boolean with - -- A set is empty if it contains no element - - Global => null, - Post => - Is_Empty'Result = (for all Item of Container => False) - and Is_Empty'Result = (Length (Container) = 0); - pragma Warnings (On, "unused variable ""Item"""); - - function Included_Except - (Left : Set; - Right : Set; - Item : Element_Type) return Boolean - -- Return True if Left contains only elements of Right except possibly - -- Item. - - with - Global => null, - Post => - Included_Except'Result = - (for all E of Left => - Contains (Right, E) or Equivalent_Elements (E, Item)); - - function Includes_Intersection - (Container : Set; - Left : Set; - Right : Set) return Boolean - with - -- Return True if every element of the intersection of Left and Right is - -- in Container. - - Global => null, - Post => - Includes_Intersection'Result = - (for all Item of Left => - (if Contains (Right, Item) then Contains (Container, Item))); - - function Included_In_Union - (Container : Set; - Left : Set; - Right : Set) return Boolean - with - -- Return True if every element of Container is the union of Left and Right - - Global => null, - Post => - Included_In_Union'Result = - (for all Item of Container => - Contains (Left, Item) or Contains (Right, Item)); - - function Is_Singleton - (Container : Set; - New_Item : Element_Type) return Boolean - with - -- Return True Container only contains New_Item - - Global => null, - Post => - Is_Singleton'Result = - (for all Item of Container => Equivalent_Elements (Item, New_Item)); - - function Not_In_Both - (Container : Set; - Left : Set; - Right : Set) return Boolean - -- Return True if there are no elements in Container that are in Left and - -- Right. - - with - Global => null, - Post => - Not_In_Both'Result = - (for all Item of Container => - not Contains (Left, Item) or not Contains (Right, Item)); - - function No_Overlap (Left : Set; Right : Set) return Boolean with - -- Return True if there are no equivalent elements in Left and Right - - Global => null, - Post => - No_Overlap'Result = - (for all Item of Left => not Contains (Right, Item)); - - function Num_Overlaps (Left : Set; Right : Set) return Count_Type with - -- Number of elements that are both in Left and Right - - Global => null, - Post => - Num_Overlaps'Result = Length (Intersection (Left, Right)) - and (if Left <= Right then Num_Overlaps'Result = Length (Left) - else Num_Overlaps'Result < Length (Left)) - and (if Right <= Left then Num_Overlaps'Result = Length (Right) - else Num_Overlaps'Result < Length (Right)) - and (Num_Overlaps'Result = 0) = No_Overlap (Left, Right); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Add (Container : Set; Item : Element_Type) return Set with - -- Return a new set containing all the elements of Container plus E - - Global => null, - Pre => - not Contains (Container, Item) - and Length (Container) < Count_Type'Last, - Post => - Length (Add'Result) = Length (Container) + 1 - and Contains (Add'Result, Item) - and Container <= Add'Result - and Included_Except (Add'Result, Container, Item); - - function Remove (Container : Set; Item : Element_Type) return Set with - -- Return a new set containing all the elements of Container except E - - Global => null, - Pre => Contains (Container, Item), - Post => - Length (Remove'Result) = Length (Container) - 1 - and not Contains (Remove'Result, Item) - and Remove'Result <= Container - and Included_Except (Container, Remove'Result, Item); - - function Intersection (Left : Set; Right : Set) return Set with - -- Returns the intersection of Left and Right - - Global => null, - Post => - Intersection'Result <= Left - and Intersection'Result <= Right - and Includes_Intersection (Intersection'Result, Left, Right); - - function Union (Left : Set; Right : Set) return Set with - -- Returns the union of Left and Right - - Global => null, - Pre => - Length (Left) - Num_Overlaps (Left, Right) <= - Count_Type'Last - Length (Right), - Post => - Length (Union'Result) = - Length (Left) - Num_Overlaps (Left, Right) + Length (Right) - and Left <= Union'Result - and Right <= Union'Result - and Included_In_Union (Union'Result, Left, Right); - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - type Private_Key is private; - - function Iter_First (Container : Set) return Private_Key with - Global => null; - - function Iter_Has_Element - (Container : Set; - Key : Private_Key) return Boolean - with - Global => null; - - function Iter_Next - (Container : Set; - Key : Private_Key) return Private_Key - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - - function Iter_Element - (Container : Set; - Key : Private_Key) return Element_Type - with - Global => null, - Pre => Iter_Has_Element (Container, Key); - pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Contains); - -private - - pragma SPARK_Mode (Off); - - subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; - - function "=" - (Left : Element_Type; - Right : Element_Type) return Boolean renames Equivalent_Elements; - - package Containers is new Ada.Containers.Functional_Base - (Element_Type => Element_Type, - Index_Type => Positive_Count_Type); - - type Set is record - Content : Containers.Container; - end record; - - type Private_Key is new Count_Type; - - function Iter_First (Container : Set) return Private_Key is (1); - - function Iter_Has_Element - (Container : Set; - Key : Private_Key) return Boolean - is - (Count_Type (Key) in 1 .. Containers.Length (Container.Content)); - - function Iter_Next - (Container : Set; - Key : Private_Key) return Private_Key - is - (if Key = Private_Key'Last then 0 else Key + 1); - - function Iter_Element - (Container : Set; - Key : Private_Key) return Element_Type - is - (Containers.Get (Container.Content, Count_Type (Key))); - -end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/a-cofuve.adb b/gcc/ada/a-cofuve.adb deleted file mode 100644 index 2984bcc..0000000 --- a/gcc/ada/a-cofuve.adb +++ /dev/null @@ -1,255 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_VECTORS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is - use Containers; - - --------- - -- "<" -- - --------- - - function "<" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left.Content) < Length (Right.Content) - and then (for all I in Index_Type'First .. Last (Left) => - Get (Left.Content, I) = Get (Right.Content, I))); - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left : Sequence; Right : Sequence) return Boolean is - (Length (Left.Content) <= Length (Right.Content) - and then (for all I in Index_Type'First .. Last (Left) => - Get (Left.Content, I) = Get (Right.Content, I))); - - --------- - -- "=" -- - --------- - - function "=" (Left : Sequence; Right : Sequence) return Boolean is - (Left.Content = Right.Content); - - --------- - -- Add -- - --------- - - function Add - (Container : Sequence; - New_Item : Element_Type) return Sequence - is - (Content => - Add (Container.Content, - Index_Type'Val (Index_Type'Pos (Index_Type'First) + - Length (Container.Content)), - New_Item)); - - function Add - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - is - (Content => Add (Container.Content, Position, New_Item)); - - -------------------- - -- Constant_Range -- - -------------------- - - function Constant_Range - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean is - begin - for I in Fst .. Lst loop - if Get (Container.Content, I) /= Item then - return False; - end if; - end loop; - - return True; - end Constant_Range; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Container.Content, I) = Item then - return True; - end if; - end loop; - - return False; - end Contains; - - ------------------ - -- Range_Except -- - ------------------ - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Index_Type) return Boolean - is - begin - if Length (Left.Content) /= Length (Right.Content) then - return False; - end if; - - for I in Index_Type'First .. Last (Left) loop - if I /= Position - and then Get (Left.Content, I) /= Get (Right.Content, I) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - is - begin - if Length (Left.Content) /= Length (Right.Content) then - return False; - end if; - - for I in Index_Type'First .. Last (Left) loop - if I /= X and then I /= Y - and then Get (Left.Content, I) /= Get (Right.Content, I) - then - return False; - end if; - end loop; - - return True; - end Equal_Except; - - --------- - -- Get -- - --------- - - function Get (Container : Sequence; - Position : Extended_Index) return Element_Type - is - (Get (Container.Content, Position)); - - ---------- - -- Last -- - ---------- - - function Last (Container : Sequence) return Extended_Index is - (Index_Type'Val - ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container))); - - ------------ - -- Length -- - ------------ - - function Length (Container : Sequence) return Count_Type is - (Length (Container.Content)); - - ----------------- - -- Range_Equal -- - ----------------- - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Left, I) /= Get (Right, I) then - return False; - end if; - end loop; - - return True; - end Range_Equal; - - ------------------- - -- Range_Shifted -- - ------------------- - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Offset : Count_Type'Base) return Boolean - is - begin - for I in Fst .. Lst loop - if Get (Left, I) /= - Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset)) - then - return False; - end if; - end loop; - return True; - end Range_Shifted; - - ------------ - -- Remove -- - ------------ - - function Remove - (Container : Sequence; - Position : Index_Type) return Sequence - is - (Content => Remove (Container.Content, Position)); - - --------- - -- Set -- - --------- - - function Set - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - is - (Content => Set (Container.Content, Position, New_Item)); - -end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/a-cofuve.ads b/gcc/ada/a-cofuve.ads deleted file mode 100644 index b48330c..0000000 --- a/gcc/ada/a-cofuve.ads +++ /dev/null @@ -1,393 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.FUNCTIONAL_VECTORS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -pragma Ada_2012; -private with Ada.Containers.Functional_Base; - -generic - type Index_Type is (<>); - -- To avoid Constraint_Error being raised at run time, Index_Type'Base - -- should have at least one more element at the low end than Index_Type. - - type Element_Type (<>) is private; - -package Ada.Containers.Functional_Vectors with SPARK_Mode is - - subtype Extended_Index is Index_Type'Base range - Index_Type'Pred (Index_Type'First) .. Index_Type'Last; - -- Index_Type with one more element at the low end of the range. - -- This type is never used but it forces GNATprove to check that there is - -- room for one more element at the low end of Index_Type. - - type Sequence is private - with Default_Initial_Condition => Length (Sequence) = 0, - Iterable => (First => Iter_First, - Has_Element => Iter_Has_Element, - Next => Iter_Next, - Element => Get); - -- Sequences are empty when default initialized. - -- Quantification over sequences can be done using the regular - -- quantification over its range or directly on its elements with "for of". - - ----------------------- - -- Basic operations -- - ----------------------- - - -- Sequences are axiomatized using Length and Get, providing respectively - -- the length of a sequence and an accessor to its Nth element: - - function Length (Container : Sequence) return Count_Type with - -- Length of a sequence - - Global => null, - Post => - (Index_Type'Pos (Index_Type'First) - 1) + Length'Result <= - Index_Type'Pos (Index_Type'Last); - - function Get - (Container : Sequence; - Position : Extended_Index) return Element_Type - -- Access the Element at position Position in Container - - with - Global => null, - Pre => Position in Index_Type'First .. Last (Container); - - function Last (Container : Sequence) return Extended_Index with - -- Last index of a sequence - - Global => null, - Post => - Last'Result = - Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) + - Length (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Last); - - function First return Extended_Index is (Index_Type'First); - -- First index of a sequence - - ------------------------ - -- Property Functions -- - ------------------------ - - function "=" (Left : Sequence; Right : Sequence) return Boolean with - -- Extensional equality over sequences - - Global => null, - Post => - "="'Result = - (Length (Left) = Length (Right) - and then (for all N in Index_Type'First .. Last (Left) => - Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "="); - - function "<" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a strict subsequence of Right - - Global => null, - Post => - "<"'Result = - (Length (Left) < Length (Right) - and then (for all N in Index_Type'First .. Last (Left) => - Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<"); - - function "<=" (Left : Sequence; Right : Sequence) return Boolean with - -- Left is a subsequence of Right - - Global => null, - Post => - "<="'Result = - (Length (Left) <= Length (Right) - and then (for all N in Index_Type'First .. Last (Left) => - Get (Left, N) = Get (Right, N))); - pragma Annotate (GNATprove, Inline_For_Proof, "<="); - - function Contains - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean - -- Returns True if Item occurs in the range from Fst to Lst of Container - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Contains'Result = - (for some I in Fst .. Lst => Get (Container, I) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Contains); - - function Constant_Range - (Container : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Item : Element_Type) return Boolean - -- Returns True if every element of the range from Fst to Lst of Container - -- is equal to Item. - - with - Global => null, - Pre => Lst <= Last (Container), - Post => - Constant_Range'Result = - (for all I in Fst .. Lst => Get (Container, I) = Item); - pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - Position : Index_Type) return Boolean - -- Returns True is Left and Right are the same except at position Position - - with - Global => null, - Pre => Position <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all I in Index_Type'First .. Last (Left) => - (if I /= Position then Get (Left, I) = Get (Right, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Equal_Except - (Left : Sequence; - Right : Sequence; - X : Index_Type; - Y : Index_Type) return Boolean - -- Returns True is Left and Right are the same except at positions X and Y - - with - Global => null, - Pre => X <= Last (Left) and Y <= Last (Left), - Post => - Equal_Except'Result = - (Length (Left) = Length (Right) - and then (for all I in Index_Type'First .. Last (Left) => - (if I /= X and I /= Y then - Get (Left, I) = Get (Right, I)))); - pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); - - function Range_Equal - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index) return Boolean - -- Returns True if the ranges from Fst to Lst contain the same elements in - -- Left and Right. - - with - Global => null, - Pre => Lst <= Last (Left) and Lst <= Last (Right), - Post => - Range_Equal'Result = - (for all I in Fst .. Lst => Get (Left, I) = Get (Right, I)); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal); - - function Range_Shifted - (Left : Sequence; - Right : Sequence; - Fst : Index_Type; - Lst : Extended_Index; - Offset : Count_Type'Base) return Boolean - -- Returns True if the range from Fst to Lst in Left contains the same - -- elements as the range from Fst + Offset to Lst + Offset in Right. - - with - Global => null, - Pre => - Lst <= Last (Left) - and then - (if Offset < 0 then - Index_Type'Pos (Index_Type'Base'First) - Offset <= - Index_Type'Pos (Index_Type'First)) - and then - (if Fst <= Lst then - Offset in - Index_Type'Pos (Index_Type'First) - Index_Type'Pos (Fst) .. - (Index_Type'Pos (Index_Type'First) - 1) + Length (Right) - - Index_Type'Pos (Lst)), - Post => - Range_Shifted'Result = - ((for all I in Fst .. Lst => - Get (Left, I) = - Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset))) - and - (for all I in Index_Type'Val (Index_Type'Pos (Fst) + Offset) .. - Index_Type'Val (Index_Type'Pos (Lst) + Offset) - => - Get (Left, Index_Type'Val (Index_Type'Pos (I) - Offset)) = - Get (Right, I))); - pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted); - - ---------------------------- - -- Construction Functions -- - ---------------------------- - - -- For better efficiency of both proofs and execution, avoid using - -- construction functions in annotations and rather use property functions. - - function Set - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except for the one at position Position which is replaced by New_Item. - - with - Global => null, - Pre => Position in Index_Type'First .. Last (Container), - Post => - Get (Set'Result, Position) = New_Item - and then Equal_Except (Container, Set'Result, Position); - - function Add (Container : Sequence; New_Item : Element_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- plus New_Item at the end. - - with - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then Last (Container) < Index_Type'Last, - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Last (Add'Result)) = New_Item - and then Container <= Add'Result; - - function Add - (Container : Sequence; - Position : Index_Type; - New_Item : Element_Type) return Sequence - with - -- Returns a new sequence which contains the same elements as Container - -- except that New_Item has been inserted at position Position. - - Global => null, - Pre => - Length (Container) < Count_Type'Last - and then Last (Container) < Index_Type'Last - and then Position <= Extended_Index'Succ (Last (Container)), - Post => - Length (Add'Result) = Length (Container) + 1 - and then Get (Add'Result, Position) = New_Item - and then Range_Equal - (Left => Container, - Right => Add'Result, - Fst => Index_Type'First, - Lst => Index_Type'Pred (Position)) - and then Range_Shifted - (Left => Container, - Right => Add'Result, - Fst => Position, - Lst => Last (Container), - Offset => 1); - - function Remove - (Container : Sequence; - Position : Index_Type) return Sequence - -- Returns a new sequence which contains the same elements as Container - -- except that the element at position Position has been removed. - - with - Global => null, - Pre => Position in Index_Type'First .. Last (Container), - Post => - Length (Remove'Result) = Length (Container) - 1 - and then Range_Equal - (Left => Container, - Right => Remove'Result, - Fst => Index_Type'First, - Lst => Index_Type'Pred (Position)) - and then Range_Shifted - (Left => Remove'Result, - Right => Container, - Fst => Position, - Lst => Last (Remove'Result), - Offset => 1); - - --------------------------- - -- Iteration Primitives -- - --------------------------- - - function Iter_First (Container : Sequence) return Extended_Index with - Global => null; - - function Iter_Has_Element - (Container : Sequence; - Position : Extended_Index) return Boolean - with - Global => null, - Post => - Iter_Has_Element'Result = - (Position in Index_Type'First .. Last (Container)); - pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); - - function Iter_Next - (Container : Sequence; - Position : Extended_Index) return Extended_Index - with - Global => null, - Pre => Iter_Has_Element (Container, Position); - -private - - pragma SPARK_Mode (Off); - - package Containers is new Ada.Containers.Functional_Base - (Index_Type => Index_Type, - Element_Type => Element_Type); - - type Sequence is record - Content : Containers.Container; - end record; - - function Iter_First (Container : Sequence) return Extended_Index is - (Index_Type'First); - - function Iter_Next - (Container : Sequence; - Position : Extended_Index) return Extended_Index - is - (if Position = Extended_Index'Last then - Extended_Index'First - else - Extended_Index'Succ (Position)); - - function Iter_Has_Element - (Container : Sequence; - Position : Extended_Index) return Boolean - is - (Position in Index_Type'First .. - (Index_Type'Val - ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container)))); - -end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/a-cogeso.adb b/gcc/ada/a-cogeso.adb deleted file mode 100644 index fc2198c..0000000 --- a/gcc/ada/a-cogeso.adb +++ /dev/null @@ -1,127 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.GENERIC_SORT -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb]) - -with System; - -procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base) is - type T is range System.Min_Int .. System.Max_Int; - - function To_Index (J : T) return Index_Type; - pragma Inline (To_Index); - - function Lt (J, K : T) return Boolean; - pragma Inline (Lt); - - procedure Xchg (J, K : T); - pragma Inline (Xchg); - - procedure Sift (S : T); - - -------------- - -- To_Index -- - -------------- - - function To_Index (J : T) return Index_Type is - K : constant T'Base := Index_Type'Pos (First) + J - T'(1); - begin - return Index_Type'Val (K); - end To_Index; - - -------- - -- Lt -- - -------- - - function Lt (J, K : T) return Boolean is - begin - return Before (To_Index (J), To_Index (K)); - end Lt; - - ---------- - -- Xchg -- - ---------- - - procedure Xchg (J, K : T) is - begin - Swap (To_Index (J), To_Index (K)); - end Xchg; - - Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1); - - ---------- - -- Sift -- - ---------- - - procedure Sift (S : T) is - C : T := S; - Son : T; - Father : T; - - begin - loop - Son := C + C; - - if Son < Max then - if Lt (Son, Son + 1) then - Son := Son + 1; - end if; - elsif Son > Max then - exit; - end if; - - Xchg (Son, C); - C := Son; - end loop; - - while C /= S loop - Father := C / 2; - - if Lt (Father, C) then - Xchg (Father, C); - C := Father; - else - exit; - end if; - end loop; - end Sift; - --- Start of processing for Generic_Sort - -begin - for J in reverse 1 .. Max / 2 loop - Sift (J); - end loop; - - while Max > 1 loop - Xchg (1, Max); - Max := Max - 1; - Sift (1); - end loop; -end Ada.Containers.Generic_Sort; diff --git a/gcc/ada/a-cogeso.ads b/gcc/ada/a-cogeso.ads deleted file mode 100644 index ebf805a..0000000 --- a/gcc/ada/a-cogeso.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.GENERIC_SORT -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Allows an anonymous array (or array-like container) to be sorted. Generic --- formal Before returns the result of comparing the elements designated by --- the indexes, and generic formal Swap exchanges the designated elements. - -generic - type Index_Type is (<>); - with function Before (Left, Right : Index_Type) return Boolean; - with procedure Swap (Left, Right : Index_Type); - -procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base); -pragma Pure (Ada.Containers.Generic_Sort); diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb deleted file mode 100644 index 4ead925..0000000 --- a/gcc/ada/a-cohama.adb +++ /dev/null @@ -1,1200 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Hash_Tables.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); - -with Ada.Containers.Hash_Tables.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with System; use type System.Address; - -package body Ada.Containers.Hashed_Maps is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node - (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Key_Node); - - procedure Free (X : in out Node_Access); - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean; - - function Hash_Node (Node : Node_Access) return Hash_Type; - pragma Inline (Hash_Node); - - function Next (Node : Node_Access) return Node_Access; - pragma Inline (Next); - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - pragma Inline (Read_Node); - - procedure Set_Next (Node : Node_Access; Next : Node_Access); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); - - package Key_Ops is new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); - - procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); - procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - begin - return Is_Equal (Left.HT, Right.HT); - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Map) is - begin - HT_Ops.Adjust (Container.HT); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Item (Node : Node_Access); - pragma Inline (Insert_Item); - - procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item); - - ----------------- - -- Insert_Item -- - ----------------- - - procedure Insert_Item (Node : Node_Access) is - begin - Target.Insert (Key => Node.Key, New_Item => Node.Element); - end Insert_Item; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - - if Target.Capacity < Source.Length then - Target.Reserve_Capacity (Source.Length); - end if; - - Insert_Items (Source.HT); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Map) return Count_Type is - begin - return HT_Ops.Capacity (Container.HT); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Map) is - begin - HT_Ops.Clear (Container.HT); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert - (Vet (Position), - "Position cursor in Constant_Reference is bad"); - - declare - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - declare - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Map; - Capacity : Count_Type := 0) return Map - is - C : Count_Type; - - begin - if Capacity < Source.Length then - if Checks and then Capacity /= 0 then - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - C := Source.Length; - else - C := Capacity; - end if; - - return Target : Map do - Target.Reserve_Capacity (C); - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node - (Source : Node_Access) return Node_Access - is - Target : constant Node_Access := - new Node_Type'(Key => Source.Key, - Element => Source.Element, - Next => null); - begin - return Target; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Node_Access; - - begin - Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - - if Checks and then X = null then - raise Constraint_Error with "attempt to delete key not in map"; - end if; - - Free (X); - end Delete; - - procedure Delete (Container : in out Map; Position : in out Cursor) is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Delete equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Delete designates wrong map"; - end if; - - TC_Check (Container.HT.TC); - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); - - Free (Position.Node); - Position.Container := null; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Map; Key : Key_Type) return Element_Type is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "no element available because key not in map"; - end if; - - return Node.Element; - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Element equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - return Position.Node.Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean is - begin - return Equivalent_Keys (Key, Node.Key); - end Equivalent_Key_Node; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Cursor) - return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad"); - pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); - - return Equivalent_Keys (Left.Node.Key, Right.Node.Key); - end Equivalent_Keys; - - function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Keys equals No_Element"; - end if; - - pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad"); - - return Equivalent_Keys (Left.Node.Key, Right); - end Equivalent_Keys; - - function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Keys equals No_Element"; - end if; - - pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); - - return Equivalent_Keys (Left, Right.Node.Key); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Node_Access; - begin - Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); - Free (X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Map) is - begin - HT_Ops.Finalize (Container.HT); - end Finalize; - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.HT.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); - end Find; - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean - is - R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key); - R_Node : Node_Access := R_HT.Buckets (R_Index); - - begin - while R_Node /= null loop - if Equivalent_Keys (L_Node.Key, R_Node.Key) then - return L_Node.Element = R_Node.Element; - end if; - - R_Node := R_Node.Next; - end loop; - - return False; - end Find_Equal_Key; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - Pos : Hash_Type; - Node : constant Node_Access := HT_Ops.First (Container.HT, Pos); - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node, Pos); - end First; - - function First (Object : Iterator) return Cursor is - begin - return Object.Container.First; - end First; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - begin - if X /= null then - X.Next := X; -- detect mischief (in Vet) - Deallocate (X); - end if; - end Free; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= null; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Access) return Hash_Type is - begin - return Hash (Node.Key); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.HT.TC); - - Position.Node.Key := Key; - Position.Node.Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - begin - return new Node_Type'(Key => Key, - Element => <>, - Next => Next); - end New_Node; - - HT : Hash_Table_Type renames Container.HT; - - -- Start of processing for Insert - - begin - if HT_Ops.Capacity (HT) = 0 then - HT_Ops.Reserve_Capacity (HT, 1); - end if; - - Local_Insert (HT, Key, Position.Node, Inserted); - - if Inserted - and then HT.Length > HT_Ops.Capacity (HT) - then - HT_Ops.Reserve_Capacity (HT, HT.Length); - end if; - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert is - new Key_Ops.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - begin - return new Node_Type'(Key, New_Item, Next); - end New_Node; - - HT : Hash_Table_Type renames Container.HT; - - -- Start of processing for Insert - - begin - if HT_Ops.Capacity (HT) = 0 then - HT_Ops.Reserve_Capacity (HT, 1); - end if; - - Local_Insert (HT, Key, Position.Node, Inserted); - - if Inserted - and then HT.Length > HT_Ops.Capacity (HT) - then - HT_Ops.Reserve_Capacity (HT, HT.Length); - end if; - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert key already in map"; - end if; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Container.HT.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access; Position : Hash_Type); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new HT_Ops.Generic_Iteration_With_Position (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access; Position : Hash_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node, Position)); - end Process_Node; - - Busy : With_Busy (Container.HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (Container.HT); - end Iterate; - - function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class - is - begin - return It : constant Iterator := - (Limited_Controlled with Container => Container'Unrestricted_Access) - do - Busy (Container.HT.TC'Unrestricted_Access.all); - end return; - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Key equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - - return Position.Node.Key; - end Key; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.HT.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Map; - Source : in out Map) - is - begin - HT_Ops.Move (Target => Target.HT, Source => Source.HT); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Access) return Node_Access is - begin - return Node.Next; - end Next; - - function Next (Position : Cursor) return Cursor is - Node : Node_Access := null; - - Pos : Hash_Type; - -- Position of cursor's element in the map buckets. - begin - if Position.Node = null then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Next"); - - -- Initialize to current position, so that HT_Ops.Next can use it - Pos := Position.Position; - - Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos); - - if Node = null then - return No_Element; - else - return Cursor'(Position.Container, Node, Pos); - end if; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong map"; - end if; - - return Next (Position); - end Next; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - M : Map renames Position.Container.all; - HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; - Lock : With_Lock (HT.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - begin - Read_Nodes (Stream, Container.HT); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert - (Vet (Position), - "Position cursor in function Reference is bad"); - - declare - HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type - is - HT : Hash_Table_Type renames Container.HT; - Node : constant Node_Access := Key_Ops.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - declare - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - - begin - Key_Type'Read (Stream, Node.Key); - Element_Type'Read (Stream, Node.Element); - return Node; - - exception - when others => - Free (Node); - raise; - end Read_Node; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace key not in map"; - end if; - - TE_Check (Container.HT.TC); - - Node.Key := Key; - Node.Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Replace_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Replace_Element designates wrong map"; - end if; - - TE_Check (Position.Container.HT.TC); - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Position.Node.Element := New_Item; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Map; - Capacity : Count_Type) - is - begin - HT_Ops.Reserve_Capacity (Container.HT, Capacity); - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : Node_Access; Next : Node_Access) is - begin - Node.Next := Next; - end Set_Next; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Update_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Update_Element designates wrong map"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - HT : Hash_Table_Type renames Container.HT; - Lock : With_Lock (HT.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = null then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - if Position.Node.Next = Position.Node then - return False; - end if; - - declare - HT : Hash_Table_Type renames Position.Container.HT; - X : Node_Access; - - begin - if HT.Length = 0 then - return False; - end if; - - if HT.Buckets = null - or else HT.Buckets'Length = 0 - then - return False; - end if; - - X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key)); - - for J in 1 .. HT.Length loop - if X = Position.Node then - return True; - end if; - - if X = null then - return False; - end if; - - if X = X.Next then -- to prevent unnecessary looping - return False; - end if; - - X := X.Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - begin - Write_Nodes (Stream, Container.HT); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - -end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads deleted file mode 100644 index 8a6f8c2..0000000 --- a/gcc/ada/a-cohama.ads +++ /dev/null @@ -1,470 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Hash_Tables; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Key_Type is private; - type Element_Type is private; - - with function Hash (Key : Key_Type) return Hash_Type; - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Hashed_Maps is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type Map is tagged private - with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Map); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Map : constant Map; - -- Map objects declared without an initialization expression are - -- initialized to the value Empty_Map. - - No_Element : constant Cursor; - -- Cursor objects declared without an initialization expression are - -- initialized to the value No_Element. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Map_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Map) return Boolean; - -- For each key/element pair in Left, equality attempts to find the key in - -- Right; if a search fails the equality returns False. The search works by - -- calling Hash to find the bucket in the Right map that corresponds to the - -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys - -- to compare the key (in Left) to the key of each node in the bucket (in - -- Right); if the keys are equivalent, then the equality test for this - -- key/element pair (in Left) completes by calling the element equality - -- operator to compare the element (in Left) to the element of the node - -- (in Right) whose key matched. - - function Capacity (Container : Map) return Count_Type; - -- Returns the current capacity of the map. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); - -- Adjusts the current capacity, by allocating a new buckets array. If the - -- requested capacity is less than the current capacity, then the capacity - -- is contracted (to a value not less than the current length). If the - -- requested capacity is greater than the current capacity, then the - -- capacity is expanded (to a value not less than what is requested). In - -- either case, the nodes are rehashed from the old buckets array onto the - -- new buckets array (Hash is called once for each existing key in order to - -- compute the new index), and then the old buckets array is deallocated. - - function Length (Container : Map) return Count_Type; - -- Returns the number of items in the map - - function Is_Empty (Container : Map) return Boolean; - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Map); - -- Removes all of the items from the map - - function Key (Position : Cursor) return Key_Type; - -- Returns the key of the node designated by the cursor - - function Element (Position : Cursor) return Element_Type; - -- Returns the element of the node designated by the cursor - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type); - -- Assigns the value New_Item to the element designated by the cursor - - procedure Query_Element - (Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - -- Calls Process with the key and element (both having only a constant - -- view) of the node designed by the cursor. - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - -- Calls Process with the key (with only a constant view) and element (with - -- a variable view) of the node designed by the cursor. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Map; Source : Map); - - function Copy (Source : Map; Capacity : Count_Type := 0) return Map; - - procedure Move (Target : in out Map; Source : in out Map); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - -- Conditionally inserts New_Item into the map. If Key is already in the - -- map, then Inserted returns False and Position designates the node - -- containing the existing key/element pair (neither of which is modified). - -- If Key is not already in the map, the Inserted returns True and Position - -- designates the newly-inserted node container Key and New_Item. The - -- search for the key works as follows. Hash is called to determine Key's - -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to - -- compare Key to each node in that bucket. If the bucket is empty, or - -- there were no matching keys in the bucket, the search "fails" and the - -- key/item pair is inserted in the map (and Inserted returns True); - -- otherwise, the search "succeeds" (and Inserted returns False). - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - -- The same as the (conditional) Insert that accepts an element parameter, - -- with the difference that if Inserted returns True, then the element of - -- the newly-inserted node is initialized to its default value. - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Attempts to insert Key into the map, performing the usual search (which - -- involves calling both Hash and Equivalent_Keys); if the search succeeds - -- (because Key is already in the map), then it raises Constraint_Error. - -- (This version of Insert is similar to Replace, but having the opposite - -- exception behavior. It is intended for use when you want to assert that - -- Key is not already in the map.) - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Attempts to insert Key into the map. If Key is already in the map, then - -- both the existing key and element are assigned the values of Key and - -- New_Item, respectively. (This version of Insert only raises an exception - -- if cursor tampering occurs. It is intended for use when you want to - -- insert the key/element pair in the map, and you don't care whether Key - -- is already present.) - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - -- Searches for Key in the map; if the search fails (because Key was not in - -- the map), then it raises Constraint_Error. Otherwise, both the existing - -- key and element are assigned the values of Key and New_Item rsp. (This - -- is similar to Insert, but with the opposite exception behavior. It is to - -- be used when you want to assert that Key is already in the map.) - - procedure Exclude (Container : in out Map; Key : Key_Type); - -- Searches for Key in the map, and if found, removes its node from the map - -- and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the key's bucket; if the bucket is not empty, it - -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is - -- the deletion analog of Include. It is intended for use when you want to - -- remove the item from the map, but don't care whether the key is already - -- in the map.) - - procedure Delete (Container : in out Map; Key : Key_Type); - -- Searches for Key in the map (which involves calling both Hash and - -- Equivalent_Keys). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the map and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the map.) - - procedure Delete (Container : in out Map; Position : in out Cursor); - -- Removes the node designated by Position from the map, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Keys). - - function First (Container : Map) return Cursor; - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Position : Cursor) return Cursor; - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Find (Container : Map; Key : Key_Type) return Cursor; - -- Searches for Key in the map. Find calls Hash to determine the key's - -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare - -- Key to each key in the bucket. If the search succeeds, Find returns a - -- cursor designating the matching node; otherwise, it returns No_Element. - - function Contains (Container : Map; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - function Element (Container : Map; Key : Key_Type) return Element_Type; - -- Equivalent to Element (Find (Container, Key)) - - function Equivalent_Keys (Left, Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Keys with the keys of the nodes - -- designated by cursors Left and Right. - - function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; - -- Returns the result of calling Equivalent_Keys with key of the node - -- designated by Left and key Right. - - function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Keys with key Left and the node - -- designated by Right. - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - -- Calls Process for each node in the map - - function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class; - -private - pragma Inline ("="); - pragma Inline (Length); - pragma Inline (Is_Empty); - pragma Inline (Clear); - pragma Inline (Key); - pragma Inline (Element); - pragma Inline (Move); - pragma Inline (Contains); - pragma Inline (Capacity); - pragma Inline (Reserve_Capacity); - pragma Inline (Has_Element); - pragma Inline (Equivalent_Keys); - pragma Inline (Next); - - type Node_Type; - type Node_Access is access Node_Type; - - type Node_Type is limited record - Key : Key_Type; - Element : aliased Element_Type; - Next : Node_Access; - end record; - - package HT_Types is - new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); - - type Map is new Ada.Finalization.Controlled with record - HT : HT_Types.Hash_Table_Type; - end record; - - overriding procedure Adjust (Container : in out Map); - - overriding procedure Finalize (Container : in out Map); - - use HT_Types, HT_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; - - type Cursor is record - Container : Map_Access; - -- Access to this cursor's container - - Node : Node_Access; - -- Access to the node pointed to by this cursor - - Position : Hash_Type := Hash_Type'Last; - -- Position of the node in the buckets of the container. If this is - -- equal to Hash_Type'Last, then it will not be used. - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Map : constant Map := (Controlled with others => <>); - - No_Element : constant Cursor := (Container => null, Node => null, - Position => Hash_Type'Last); - - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Forward_Iterator with - record - Container : Map_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb deleted file mode 100644 index 3056f54..0000000 --- a/gcc/ada/a-cohase.adb +++ /dev/null @@ -1,2184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Hash_Tables.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); - -with Ada.Containers.Hash_Tables.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Prime_Numbers; - -with System; use type System.Address; - -package body Ada.Containers.Hashed_Sets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Assign (Node : Node_Access; Item : Element_Type); - pragma Inline (Assign); - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - function Equivalent_Keys - (Key : Element_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Keys); - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean; - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean; - - procedure Free (X : in out Node_Access); - - function Hash_Node (Node : Node_Access) return Hash_Type; - pragma Inline (Hash_Node); - - procedure Insert - (HT : in out Hash_Table_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean); - - function Is_In - (HT : aliased in out Hash_Table_Type; - Key : Node_Access) return Boolean; - pragma Inline (Is_In); - - function Next (Node : Node_Access) return Node_Access; - pragma Inline (Next); - - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Node_Access; - pragma Inline (Read_Node); - - procedure Set_Next (Node : Node_Access; Next : Node_Access); - pragma Inline (Set_Next); - - function Vet (Position : Cursor) return Boolean; - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package HT_Ops is new Hash_Tables.Generic_Operations - (HT_Types => HT_Types, - Hash_Node => Hash_Node, - Next => Next, - Set_Next => Set_Next, - Copy_Node => Copy_Node, - Free => Free); - - package Element_Keys is new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Element_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Keys); - - function Is_Equal is - new HT_Ops.Generic_Equal (Find_Equal_Key); - - function Is_Equivalent is - new HT_Ops.Generic_Equal (Find_Equivalent_Key); - - procedure Read_Nodes is - new HT_Ops.Generic_Read (Read_Node); - - procedure Replace_Element is - new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); - - procedure Write_Nodes is - new HT_Ops.Generic_Write (Write_Node); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - return Is_Equal (Left.HT, Right.HT); - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Set) is - begin - HT_Ops.Adjust (Container.HT); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Node : Node_Access; Item : Element_Type) is - begin - Node.Element := Item; - end Assign; - - procedure Assign (Target : in out Set; Source : Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Target.Union (Source); - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Set) return Count_Type is - begin - return HT_Ops.Capacity (Container.HT); - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Set) is - begin - HT_Ops.Clear (Container.HT); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); - - declare - HT : Hash_Table_Type renames Position.Container.all.HT; - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Set; - Capacity : Count_Type := 0) return Set - is - C : Count_Type; - - begin - if Capacity < Source.Length then - if Checks and then Capacity /= 0 then - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - C := Source.Length; - else - C := Capacity; - end if; - - return Target : Set do - Target.Reserve_Capacity (C); - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - begin - return new Node_Type'(Element => Source.Element, Next => null); - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Item : Element_Type) - is - X : Node_Access; - - begin - Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - - if Checks and then X = null then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Free (X); - end Delete; - - procedure Delete - (Container : in out Set; - Position : in out Cursor) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - TC_Check (Container.HT.TC); - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); - - Free (Position.Node); - Position.Container := null; - end Delete; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference - (Target : in out Set; - Source : Set) - is - Tgt_Node : Node_Access; - Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; - - begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - if Src_HT.Length = 0 then - return; - end if; - - TC_Check (Target.HT.TC); - - if Src_HT.Length < Target.HT.Length then - declare - Src_Node : Node_Access; - - begin - Src_Node := HT_Ops.First (Src_HT); - while Src_Node /= null loop - Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element); - - if Tgt_Node /= null then - HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); - Free (Tgt_Node); - end if; - - Src_Node := HT_Ops.Next (Src_HT, Src_Node); - end loop; - end; - - else - Tgt_Node := HT_Ops.First (Target.HT); - while Tgt_Node /= null loop - if Is_In (Src_HT, Tgt_Node) then - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.HT, X); - Free (X); - end; - - else - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - end if; - end loop; - end if; - end Difference; - - function Difference (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Left_HT.Length = 0 then - return Empty_Set; - end if; - - if Right_HT.Length = 0 then - return Left; - end if; - - declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Length := 0; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - begin - if not Is_In (Right_HT, L_Node) then - declare - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - J : constant Hash_Type := - HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); - - Bucket : Node_Access renames Buckets (J); - - begin - Bucket := new Node_Type'(L_Node.Element, Bucket); - end; - - Length := Length + 1; - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left_HT); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Element"); - - return Position.Node.Element; - end Element; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - begin - return Is_Equivalent (Left.HT, Right.HT); - end Equivalent_Sets; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Cursor) - return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); - pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); - - -- AI05-0022 requires that a container implementation detect element - -- tampering by a generic actual subprogram. However, the following case - -- falls outside the scope of that AI. Randy Brukardt explained on the - -- ARG list on 2013/02/07 that: - - -- (Begin Quote): - -- But for an operation like "<" [the ordered set analog of - -- Equivalent_Elements], there is no need to "dereference" a cursor - -- after the call to the generic formal parameter function, so nothing - -- bad could happen if tampering is undetected. And the operation can - -- safely return a result without a problem even if an element is - -- deleted from the container. - -- (End Quote). - - return Equivalent_Elements (Left.Node.Element, Right.Node.Element); - end Equivalent_Elements; - - function Equivalent_Elements (Left : Cursor; Right : Element_Type) - return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with - "Left cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad"); - - return Equivalent_Elements (Left.Node.Element, Right); - end Equivalent_Elements; - - function Equivalent_Elements (Left : Element_Type; Right : Cursor) - return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with - "Right cursor of Equivalent_Elements equals No_Element"; - end if; - - pragma Assert - (Vet (Right), - "Right cursor of Equivalent_Elements is bad"); - - return Equivalent_Elements (Left, Right.Node.Element); - end Equivalent_Elements; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Key : Element_Type; Node : Node_Access) - return Boolean is - begin - return Equivalent_Elements (Key, Node.Element); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Item : Element_Type) - is - X : Node_Access; - begin - Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); - Free (X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Set) is - begin - HT_Ops.Finalize (Container.HT); - end Finalize; - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.HT.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Item : Element_Type) return Cursor - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Element_Keys.Find (HT, Item); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); - end Find; - - -------------------- - -- Find_Equal_Key -- - -------------------- - - function Find_Equal_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - - R_Node : Node_Access := R_HT.Buckets (R_Index); - - begin - loop - if R_Node = null then - return False; - end if; - - if L_Node.Element = R_Node.Element then - return True; - end if; - - R_Node := Next (R_Node); - end loop; - end Find_Equal_Key; - - ------------------------- - -- Find_Equivalent_Key -- - ------------------------- - - function Find_Equivalent_Key - (R_HT : Hash_Table_Type; - L_Node : Node_Access) return Boolean - is - R_Index : constant Hash_Type := - Element_Keys.Index (R_HT, L_Node.Element); - - R_Node : Node_Access := R_HT.Buckets (R_Index); - - begin - loop - if R_Node = null then - return False; - end if; - - if Equivalent_Elements (L_Node.Element, R_Node.Element) then - return True; - end if; - - R_Node := Next (R_Node); - end loop; - end Find_Equivalent_Key; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - Pos : Hash_Type; - Node : constant Node_Access := HT_Ops.First (Container.HT, Pos); - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node, Pos); - end First; - - function First (Object : Iterator) return Cursor is - begin - return Object.Container.First; - end First; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X /= null then - X.Next := X; -- detect mischief (in Vet) - Deallocate (X); - end if; - end Free; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= null; - end Has_Element; - - --------------- - -- Hash_Node -- - --------------- - - function Hash_Node (Node : Node_Access) return Hash_Type is - begin - return Hash (Node.Element); - end Hash_Node; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.HT.TC); - - Position.Node.Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert (Container.HT, New_Item, Position.Node, Inserted); - Position.Container := Container'Unchecked_Access; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - procedure Insert - (HT : in out Hash_Table_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean) - is - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - begin - return new Node_Type'(New_Item, Next); - end New_Node; - - -- Start of processing for Insert - - begin - if HT_Ops.Capacity (HT) = 0 then - HT_Ops.Reserve_Capacity (HT, 1); - end if; - - TC_Check (HT.TC); - - Local_Insert (HT, New_Item, Node, Inserted); - - if Inserted - and then HT.Length > HT_Ops.Capacity (HT) - then - HT_Ops.Reserve_Capacity (HT, HT.Length); - end if; - end Insert; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection - (Target : in out Set; - Source : Set) - is - Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; - Tgt_Node : Node_Access; - - begin - if Target'Address = Source'Address then - return; - end if; - - if Source.HT.Length = 0 then - Clear (Target); - return; - end if; - - TC_Check (Target.HT.TC); - - Tgt_Node := HT_Ops.First (Target.HT); - while Tgt_Node /= null loop - if Is_In (Src_HT, Tgt_Node) then - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - - else - declare - X : Node_Access := Tgt_Node; - begin - Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); - HT_Ops.Delete_Node_Sans_Free (Target.HT, X); - Free (X); - end; - end if; - end loop; - end Intersection; - - function Intersection (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - Length := Count_Type'Min (Left.Length, Right.Length); - - if Length = 0 then - return Empty_Set; - end if; - - declare - Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Length := 0; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - begin - if Is_In (Right_HT, L_Node) then - declare - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - J : constant Hash_Type := - HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); - - Bucket : Node_Access renames Buckets (J); - - begin - Bucket := new Node_Type'(L_Node.Element, Bucket); - end; - - Length := Length + 1; - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left_HT); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.HT.Length = 0; - end Is_Empty; - - ----------- - -- Is_In -- - ----------- - - function Is_In - (HT : aliased in out Hash_Table_Type; - Key : Node_Access) return Boolean - is - begin - return Element_Keys.Find (HT, Key.Element) /= null; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT; - Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT; - Subset_Node : Node_Access; - - begin - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Subset.Length > Of_Set.Length then - return False; - end if; - - Subset_Node := HT_Ops.First (Subset_HT); - while Subset_Node /= null loop - if not Is_In (Of_Set_HT, Subset_Node) then - return False; - end if; - Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node); - end loop; - - return True; - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access; Position : Hash_Type); - pragma Inline (Process_Node); - - procedure Iterate is - new HT_Ops.Generic_Iteration_With_Position (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access; Position : Hash_Type) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node, Position)); - end Process_Node; - - Busy : With_Busy (Container.HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Iterate (Container.HT); - end Iterate; - - function Iterate - (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class - is - begin - Busy (Container.HT.TC'Unrestricted_Access.all); - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access); - end Iterate; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.HT.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Set; Source : in out Set) is - begin - HT_Ops.Move (Target => Target.HT, Source => Source.HT); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Access) return Node_Access is - begin - return Node.Next; - end Next; - - function Next (Position : Cursor) return Cursor is - Node : Node_Access; - Pos : Hash_Type; - begin - if Position.Node = null then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - - Pos := Position.Position; - Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos); - - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node, Pos); - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Left_Node : Node_Access; - - begin - if Right.Length = 0 then - return False; - end if; - - if Left'Address = Right'Address then - return True; - end if; - - Left_Node := HT_Ops.First (Left_HT); - while Left_Node /= null loop - if Is_In (Right_HT, Left_Node) then - return True; - end if; - Left_Node := HT_Ops.Next (Left_HT, Left_Node); - end loop; - - return False; - end Overlap; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.HT.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - HT : Hash_Table_Type renames Position.Container.HT; - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - Process (Position.Node.Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - begin - Read_Nodes (Stream, Container.HT); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Read_Node -- - --------------- - - function Read_Node (Stream : not null access Root_Stream_Type'Class) - return Node_Access - is - Node : Node_Access := new Node_Type; - begin - Element_Type'Read (Stream, Node.Element); - return Node; - exception - when others => - Free (Node); - raise; - end Read_Node; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - New_Item : Element_Type) - is - Node : constant Node_Access := - Element_Keys.Find (Container.HT, New_Item); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - TE_Check (Container.HT.TC); - - Node.Element := New_Item; - end Replace; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - Replace_Element (Container.HT, Position.Node, New_Item); - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Set; - Capacity : Count_Type) - is - begin - HT_Ops.Reserve_Capacity (Container.HT, Capacity); - end Reserve_Capacity; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (Node : Node_Access; Next : Node_Access) is - begin - Node.Next := Next; - end Set_Next; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference - (Target : in out Set; - Source : Set) - is - Tgt_HT : Hash_Table_Type renames Target.HT; - Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; - begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - TC_Check (Tgt_HT.TC); - - declare - N : constant Count_Type := Target.Length + Source.Length; - begin - if N > HT_Ops.Capacity (Tgt_HT) then - HT_Ops.Reserve_Capacity (Tgt_HT, N); - end if; - end; - - if Target.Length = 0 then - Iterate_Source_When_Empty_Target : declare - procedure Process (Src_Node : Node_Access); - - procedure Iterate is new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - E : Element_Type renames Src_Node.Element; - B : Buckets_Type renames Tgt_HT.Buckets.all; - J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Tgt_HT.Length; - - begin - B (J) := new Node_Type'(E, B (J)); - N := N + 1; - end Process; - - -- Per AI05-0022, the container implementation is required to - -- detect element tampering by a generic actual subprogram. - - Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); - Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Source_When_Empty_Target - - begin - Iterate (Src_HT); - end Iterate_Source_When_Empty_Target; - - else - Iterate_Source : declare - procedure Process (Src_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - E : Element_Type renames Src_Node.Element; - B : Buckets_Type renames Tgt_HT.Buckets.all; - J : constant Hash_Type := Hash (E) mod B'Length; - N : Count_Type renames Tgt_HT.Length; - - begin - if B (J) = null then - B (J) := new Node_Type'(E, null); - N := N + 1; - - elsif Equivalent_Elements (E, B (J).Element) then - declare - X : Node_Access := B (J); - begin - B (J) := B (J).Next; - N := N - 1; - Free (X); - end; - - else - declare - Prev : Node_Access := B (J); - Curr : Node_Access := Prev.Next; - - begin - while Curr /= null loop - if Equivalent_Elements (E, Curr.Element) then - Prev.Next := Curr.Next; - N := N - 1; - Free (Curr); - return; - end if; - - Prev := Curr; - Curr := Prev.Next; - end loop; - - B (J) := new Node_Type'(E, B (J)); - N := N + 1; - end; - end if; - end Process; - - -- Per AI05-0022, the container implementation is required to - -- detect element tampering by a generic actual subprogram. - - Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); - Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Source - - begin - Iterate (Src_HT); - end Iterate_Source; - end if; - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; - Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Empty_Set; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - declare - Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Length := 0; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - begin - if not Is_In (Right_HT, L_Node) then - declare - E : Element_Type renames L_Node.Element; - - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - J : constant Hash_Type := - HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); - - begin - Buckets (J) := new Node_Type'(E, Buckets (J)); - Length := Length + 1; - end; - end if; - end Process; - - -- Start of processing for Iterate_Left - - begin - Iterate (Left_HT); - - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - Iterate_Right : declare - procedure Process (R_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (R_Node : Node_Access) is - begin - if not Is_In (Left_HT, R_Node) then - declare - E : Element_Type renames R_Node.Element; - - -- Per AI05-0022, the container implementation is required - -- to detect element tampering by a generic actual - -- subprogram, hence the use of Checked_Index instead of a - -- simple invocation of generic formal Hash. - - J : constant Hash_Type := - HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); - - begin - Buckets (J) := new Node_Type'(E, Buckets (J)); - Length := Length + 1; - end; - end if; - end Process; - - -- Start of processing for Iterate_Right - - begin - Iterate (Right_HT); - - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Right; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - HT : Hash_Table_Type; - - Node : Node_Access; - Inserted : Boolean; - pragma Unreferenced (Node, Inserted); - - begin - Insert (HT, New_Item, Node, Inserted); - return Set'(Controlled with HT); - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union - (Target : in out Set; - Source : Set) - is - procedure Process (Src_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - function New_Node (Next : Node_Access) return Node_Access; - pragma Inline (New_Node); - - procedure Insert is - new Element_Keys.Generic_Conditional_Insert (New_Node); - - -------------- - -- New_Node -- - -------------- - - function New_Node (Next : Node_Access) return Node_Access is - Node : constant Node_Access := - new Node_Type'(Src_Node.Element, Next); - begin - return Node; - end New_Node; - - Tgt_Node : Node_Access; - Success : Boolean; - pragma Unreferenced (Tgt_Node, Success); - - -- Start of processing for Process - - begin - Insert (Target.HT, Src_Node.Element, Tgt_Node, Success); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Target.HT.TC); - - declare - N : constant Count_Type := Target.Length + Source.Length; - begin - if N > HT_Ops.Capacity (Target.HT) then - HT_Ops.Reserve_Capacity (Target.HT, N); - end if; - end; - - Iterate (Source.HT); - end Union; - - function Union (Left, Right : Set) return Set is - Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; - Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; - Buckets : HT_Types.Buckets_Access; - Length : Count_Type; - - begin - if Left'Address = Right'Address then - return Left; - end if; - - if Right.Length = 0 then - return Left; - end if; - - if Left.Length = 0 then - return Right; - end if; - - declare - Size : constant Hash_Type := - Prime_Numbers.To_Prime (Left.Length + Right.Length); - begin - Buckets := HT_Ops.New_Buckets (Length => Size); - end; - - Iterate_Left : declare - procedure Process (L_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (L_Node : Node_Access) is - J : constant Hash_Type := - Hash (L_Node.Element) mod Buckets'Length; - - begin - Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J)); - end Process; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram, hence the use of - -- Checked_Index instead of a simple invocation of generic formal - -- Hash. - - Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Left - - begin - Iterate (Left_HT); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Left; - - Length := Left.Length; - - Iterate_Right : declare - procedure Process (Src_Node : Node_Access); - - procedure Iterate is - new HT_Ops.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Src_Node : Node_Access) is - J : constant Hash_Type := - Hash (Src_Node.Element) mod Buckets'Length; - - Tgt_Node : Node_Access := Buckets (J); - - begin - while Tgt_Node /= null loop - if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then - return; - end if; - - Tgt_Node := Next (Tgt_Node); - end loop; - - Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J)); - Length := Length + 1; - end Process; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram, hence the use of - -- Checked_Index instead of a simple invocation of generic formal - -- Hash. - - Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); - - -- Start of processing for Iterate_Right - - begin - Iterate (Right_HT); - exception - when others => - HT_Ops.Free_Hash_Table (Buckets); - raise; - end Iterate_Right; - - return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); - end Union; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = null then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - if Position.Node.Next = Position.Node then - return False; - end if; - - declare - HT : Hash_Table_Type renames Position.Container.HT; - X : Node_Access; - - begin - if HT.Length = 0 then - return False; - end if; - - if HT.Buckets = null - or else HT.Buckets'Length = 0 - then - return False; - end if; - - X := HT.Buckets (Element_Keys.Checked_Index - (HT, - Position.Node.Element)); - - for J in 1 .. HT.Length loop - if X = Position.Node then - return True; - end if; - - if X = null then - return False; - end if; - - if X = X.Next then -- to prevent unnecessary looping - return False; - end if; - - X := X.Next; - end loop; - - return False; - end; - end Vet; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - begin - Write_Nodes (Stream, Container.HT); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean; - pragma Inline (Equivalent_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Hash_Tables.Generic_Keys - (HT_Types => HT_Types, - Next => Next, - Set_Next => Set_Next, - Key_Type => Key_Type, - Hash => Hash, - Equivalent_Keys => Equivalent_Key_Node); - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Keys.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "Key not in set"; - end if; - - declare - TC : constant Tamper_Counts_Access := - HT.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Key : Key_Type) return Boolean - is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Set; - Key : Key_Type) - is - X : Node_Access; - - begin - Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - - if Checks and then X = null then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Free (X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Set; - Key : Key_Type) return Element_Type - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Keys.Find (HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in set"; - end if; - - return Node.Element; - end Element; - - ------------------------- - -- Equivalent_Key_Node -- - ------------------------- - - function Equivalent_Key_Node - (Key : Key_Type; - Node : Node_Access) return Boolean - is - begin - return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); - end Equivalent_Key_Node; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude - (Container : in out Set; - Key : Key_Type) - is - X : Node_Access; - begin - Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); - Free (X); - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Impl.Reference_Control_Type (Control).Finalize; - - if Checks and then - Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash - then - HT_Ops.Delete_Node_At_Index - (Control.Container.HT, Control.Index, Control.Old_Pos.Node); - raise Program_Error with "key not preserved in reference"; - end if; - - Control.Container := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Set; - Key : Key_Type) return Cursor - is - HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; - Node : constant Node_Access := Key_Keys.Find (HT, Key); - begin - if Node = null then - return No_Element; - else - return Cursor' - (Container'Unrestricted_Access, Node, Hash_Type'Last); - end if; - end Find; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position), "bad cursor in function Key"); - - return Key (Position.Node.Element); - end Key; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert - (Vet (Position), - "bad cursor in function Reference_Preserving_Key"); - - declare - HT : Hash_Table_Type renames Position.Container.all.HT; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => - (Controlled with - HT.TC'Unrestricted_Access, - Container'Unrestricted_Access, - Index => HT_Ops.Index (HT, Position.Node), - Old_Pos => Position, - Old_Hash => Hash (Key (Position)))) - do - Lock (HT.TC); - end return; - end; - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in set"; - end if; - - declare - HT : Hash_Table_Type renames Container.HT; - P : constant Cursor := Find (Container, Key); - begin - return R : constant Reference_Type := - (Element => Node.Element'Access, - Control => - (Controlled with - HT.TC'Unrestricted_Access, - Container'Unrestricted_Access, - Index => HT_Ops.Index (HT, P.Node), - Old_Pos => P, - Old_Hash => Hash (Key))) - do - Lock (HT.TC); - end return; - end; - end Reference_Preserving_Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container.HT, Node, New_Item); - end Replace; - - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)) - is - HT : Hash_Table_Type renames Container.HT; - Indx : Hash_Type; - - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - if Checks and then - (HT.Buckets = null - or else HT.Buckets'Length = 0 - or else HT.Length = 0 - or else Position.Node.Next = Position.Node) - then - raise Program_Error with "Position cursor is bad (set is empty)"; - end if; - - pragma Assert - (Vet (Position), - "bad cursor in Update_Element_Preserving_Key"); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - E : Element_Type renames Position.Node.Element; - K : constant Key_Type := Key (E); - Lock : With_Lock (HT.TC'Unrestricted_Access); - begin - Indx := HT_Ops.Index (HT, Position.Node); - Process (E); - - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - if HT.Buckets (Indx) = Position.Node then - HT.Buckets (Indx) := Position.Node.Next; - - else - declare - Prev : Node_Access := HT.Buckets (Indx); - - begin - while Prev.Next /= Position.Node loop - Prev := Prev.Next; - - if Checks and then Prev = null then - raise Program_Error with - "Position cursor is bad (node not found)"; - end if; - end loop; - - Prev.Next := Position.Node.Next; - end; - end if; - - HT.Length := HT.Length - 1; - - declare - X : Node_Access := Position.Node; - - begin - Free (X); - end; - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - end Generic_Keys; - -end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads deleted file mode 100644 index 79e3400..0000000 --- a/gcc/ada/a-cohase.ads +++ /dev/null @@ -1,609 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Hash_Tables; -with Ada.Containers.Helpers; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type is private; - - with function Hash (Element : Element_Type) return Hash_Type; - - with function Equivalent_Elements - (Left, Right : Element_Type) return Boolean; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Hashed_Sets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type Set is tagged private - with - Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Set : constant Set; - -- Set objects declared without an initialization expression are - -- initialized to the value Empty_Set. - - No_Element : constant Cursor; - -- Cursor objects declared without an initialization expression are - -- initialized to the value No_Element. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - -- For each element in Left, set equality attempts to find the equal - -- element in Right; if a search fails, then set equality immediately - -- returns False. The search works by calling Hash to find the bucket in - -- the Right set that corresponds to the Left element. If the bucket is - -- non-empty, the search calls the generic formal element equality operator - -- to compare the element (in Left) to the element of each node in the - -- bucket (in Right); the search terminates when a matching node in the - -- bucket is found, or the nodes in the bucket are exhausted. (Note that - -- element equality is called here, not Equivalent_Elements. Set equality - -- is the only operation in which element equality is used. Compare set - -- equality to Equivalent_Sets, which does call Equivalent_Elements.) - - function Equivalent_Sets (Left, Right : Set) return Boolean; - -- Similar to set equality, with the difference that the element in Left is - -- compared to the elements in Right using the generic formal - -- Equivalent_Elements operation instead of element equality. - - function To_Set (New_Item : Element_Type) return Set; - -- Constructs a singleton set comprising New_Element. To_Set calls Hash to - -- determine the bucket for New_Item. - - function Capacity (Container : Set) return Count_Type; - -- Returns the current capacity of the set. Capacity is the maximum length - -- before which rehashing in guaranteed not to occur. - - procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); - -- Adjusts the current capacity, by allocating a new buckets array. If the - -- requested capacity is less than the current capacity, then the capacity - -- is contracted (to a value not less than the current length). If the - -- requested capacity is greater than the current capacity, then the - -- capacity is expanded (to a value not less than what is requested). In - -- either case, the nodes are rehashed from the old buckets array onto the - -- new buckets array (Hash is called once for each existing element in - -- order to compute the new index), and then the old buckets array is - -- deallocated. - - function Length (Container : Set) return Count_Type; - -- Returns the number of items in the set - - function Is_Empty (Container : Set) return Boolean; - -- Equivalent to Length (Container) = 0 - - procedure Clear (Container : in out Set); - -- Removes all of the items from the set - - function Element (Position : Cursor) return Element_Type; - -- Returns the element of the node designated by the cursor - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - -- If New_Item is equivalent (as determined by calling Equivalent_Elements) - -- to the element of the node designated by Position, then New_Element is - -- assigned to that element. Otherwise, it calls Hash to determine the - -- bucket for New_Item. If the bucket is not empty, then it calls - -- Equivalent_Elements for each node in that bucket to determine whether - -- New_Item is equivalent to an element in that bucket. If - -- Equivalent_Elements returns True then Program_Error is raised (because - -- an element may appear only once in the set); otherwise, New_Item is - -- assigned to the node designated by Position, and the node is moved to - -- its new bucket. - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - -- Calls Process with the element (having only a constant view) of the node - -- designed by the cursor. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set; Capacity : Count_Type := 0) return Set; - - procedure Move (Target : in out Set; Source : in out Set); - -- Clears Target (if it's not empty), and then moves (not copies) the - -- buckets array and nodes from Source to Target. - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - -- Conditionally inserts New_Item into the set. If New_Item is already in - -- the set, then Inserted returns False and Position designates the node - -- containing the existing element (which is not modified). If New_Item is - -- not already in the set, then Inserted returns True and Position - -- designates the newly-inserted node containing New_Item. The search for - -- an existing element works as follows. Hash is called to determine - -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements - -- is called to compare New_Item to the element of each node in that - -- bucket. If the bucket is empty, or there were no equivalent elements in - -- the bucket, the search "fails" and the New_Item is inserted in the set - -- (and Inserted returns True); otherwise, the search "succeeds" (and - -- Inserted returns False). - - procedure Insert (Container : in out Set; New_Item : Element_Type); - -- Attempts to insert New_Item into the set, performing the usual insertion - -- search (which involves calling both Hash and Equivalent_Elements); if - -- the search succeeds (New_Item is equivalent to an element already in the - -- set, and so was not inserted), then this operation raises - -- Constraint_Error. (This version of Insert is similar to Replace, but - -- having the opposite exception behavior. It is intended for use when you - -- want to assert that the item is not already in the set.) - - procedure Include (Container : in out Set; New_Item : Element_Type); - -- Attempts to insert New_Item into the set. If an element equivalent to - -- New_Item is already in the set (the insertion search succeeded, and - -- hence New_Item was not inserted), then the value of New_Item is assigned - -- to the existing element. (This insertion operation only raises an - -- exception if cursor tampering occurs. It is intended for use when you - -- want to insert the item in the set, and you don't care whether an - -- equivalent element is already present.) - - procedure Replace (Container : in out Set; New_Item : Element_Type); - -- Searches for New_Item in the set; if the search fails (because an - -- equivalent element was not in the set), then it raises - -- Constraint_Error. Otherwise, the existing element is assigned the value - -- New_Item. (This is similar to Insert, but with the opposite exception - -- behavior. It is intended for use when you want to assert that the item - -- is already in the set.) - - procedure Exclude (Container : in out Set; Item : Element_Type); - -- Searches for Item in the set, and if found, removes its node from the - -- set and then deallocates it. The search works as follows. The operation - -- calls Hash to determine the item's bucket; if the bucket is not empty, - -- it calls Equivalent_Elements to compare Item to the element of each node - -- in the bucket. (This is the deletion analog of Include. It is intended - -- for use when you want to remove the item from the set, but don't care - -- whether the item is already in the set.) - - procedure Delete (Container : in out Set; Item : Element_Type); - -- Searches for Item in the set (which involves calling both Hash and - -- Equivalent_Elements). If the search fails, then the operation raises - -- Constraint_Error. Otherwise it removes the node from the set and then - -- deallocates it. (This is the deletion analog of non-conditional - -- Insert. It is intended for use when you want to assert that the item is - -- already in the set.) - - procedure Delete (Container : in out Set; Position : in out Cursor); - -- Removes the node designated by Position from the set, and then - -- deallocates the node. The operation calls Hash to determine the bucket, - -- and then compares Position to each node in the bucket until there's a - -- match (it does not call Equivalent_Elements). - - procedure Union (Target : in out Set; Source : Set); - -- The operation first calls Reserve_Capacity if the current capacity is - -- less than the sum of the lengths of Source and Target. It then iterates - -- over the Source set, and conditionally inserts each element into Target. - - function Union (Left, Right : Set) return Set; - -- The operation first copies the Left set to the result, and then iterates - -- over the Right set to conditionally insert each element into the result. - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - -- Iterates over the Target set (calling First and Next), calling Find to - -- determine whether the element is in Source. If an equivalent element is - -- not found in Source, the element is deleted from Target. - - function Intersection (Left, Right : Set) return Set; - -- Iterates over the Left set, calling Find to determine whether the - -- element is in Right. If an equivalent element is found, it is inserted - -- into the result set. - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - -- Iterates over the Source (calling First and Next), calling Find to - -- determine whether the element is in Target. If an equivalent element is - -- found, it is deleted from Target. - - function Difference (Left, Right : Set) return Set; - -- Iterates over the Left set, calling Find to determine whether the - -- element is in the Right set. If an equivalent element is not found, the - -- element is inserted into the result set. - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - -- The operation first calls Reserve_Capacity if the current capacity is - -- less than the sum of the lengths of Source and Target. It then iterates - -- over the Source set, searching for the element in Target (calling Hash - -- and Equivalent_Elements). If an equivalent element is found, it is - -- removed from Target; otherwise it is inserted into Target. - - function Symmetric_Difference (Left, Right : Set) return Set; - -- The operation first iterates over the Left set. It calls Find to - -- determine whether the element is in the Right set. If no equivalent - -- element is found, the element from Left is inserted into the result. The - -- operation then iterates over the Right set, to determine whether the - -- element is in the Left set. If no equivalent element is found, the Right - -- element is inserted into the result. - - function "xor" (Left, Right : Set) return Set - renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - -- Iterates over the Left set (calling First and Next), calling Find to - -- determine whether the element is in the Right set. If an equivalent - -- element is found, the operation immediately returns True. The operation - -- returns False if the iteration over Left terminates without finding any - -- equivalent element in Right. - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - -- Iterates over Subset (calling First and Next), calling Find to determine - -- whether the element is in Of_Set. If no equivalent element is found in - -- Of_Set, the operation immediately returns False. The operation returns - -- True if the iteration over Subset terminates without finding an element - -- not in Of_Set (that is, every element in Subset is equivalent to an - -- element in Of_Set). - - function First (Container : Set) return Cursor; - -- Returns a cursor that designates the first non-empty bucket, by - -- searching from the beginning of the buckets array. - - function Next (Position : Cursor) return Cursor; - -- Returns a cursor that designates the node that follows the current one - -- designated by Position. If Position designates the last node in its - -- bucket, the operation calls Hash to compute the index of this bucket, - -- and searches the buckets array for the first non-empty bucket, starting - -- from that index; otherwise, it simply follows the link to the next node - -- in the same bucket. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Find - (Container : Set; - Item : Element_Type) return Cursor; - -- Searches for Item in the set. Find calls Hash to determine the item's - -- bucket; if the bucket is not empty, it calls Equivalent_Elements to - -- compare Item to each element in the bucket. If the search succeeds, Find - -- returns a cursor designating the node containing the equivalent element; - -- otherwise, it returns No_Element. - - function Contains (Container : Set; Item : Element_Type) return Boolean; - -- Equivalent to Find (Container, Item) /= No_Element - - function Equivalent_Elements (Left, Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Elements with the elements of - -- the nodes designated by cursors Left and Right. - - function Equivalent_Elements - (Left : Cursor; - Right : Element_Type) return Boolean; - -- Returns the result of calling Equivalent_Elements with element of the - -- node designated by Left and element Right. - - function Equivalent_Elements - (Left : Element_Type; - Right : Cursor) return Boolean; - -- Returns the result of calling Equivalent_Elements with element Left and - -- the element of the node designated by Right. - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - -- Calls Process for each node in the set - - function Iterate - (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function Hash (Key : Key_Type) return Hash_Type; - - with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - package Generic_Keys is - - function Key (Position : Cursor) return Key_Type; - -- Applies generic formal operation Key to the element of the node - -- designated by Position. - - function Element (Container : Set; Key : Key_Type) return Element_Type; - -- Searches (as per the key-based Find) for the node containing Key, and - -- returns the associated element. - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type); - -- Searches (as per the key-based Find) for the node containing Key, and - -- then replaces the element of that node (as per the element-based - -- Replace_Element). - - procedure Exclude (Container : in out Set; Key : Key_Type); - -- Searches for Key in the set, and if found, removes its node from the - -- set and then deallocates it. The search works by first calling Hash - -- (on Key) to determine the bucket; if the bucket is not empty, it - -- calls Equivalent_Keys to compare parameter Key to the value of - -- generic formal operation Key applied to element of each node in the - -- bucket. - - procedure Delete (Container : in out Set; Key : Key_Type); - -- Deletes the node containing Key as per Exclude, with the difference - -- that Constraint_Error is raised if Key is not found. - - function Find (Container : Set; Key : Key_Type) return Cursor; - -- Searches for the node containing Key, and returns a cursor - -- designating the node. The search works by first calling Hash (on Key) - -- to determine the bucket. If the bucket is not empty, the search - -- compares Key to the element of each node in the bucket, and returns - -- the matching node. The comparison itself works by applying the - -- generic formal Key operation to the element of the node, and then - -- calling generic formal operation Equivalent_Keys. - - function Contains (Container : Set; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - -- Calls Process with the element of the node designated by Position, - -- but with the restriction that the key-value of the element is not - -- modified. The operation first makes a copy of the value returned by - -- applying generic formal operation Key on the element of the node, and - -- then calls Process with the element. The operation verifies that the - -- key-part has not been modified by calling generic formal operation - -- Equivalent_Keys to compare the saved key-value to the value returned - -- by applying generic formal operation Key to the post-Process value of - -- element. If the key values compare equal then the operation - -- completes. Otherwise, the node is removed from the set and - -- Program_Error is raised. - - type Reference_Type (Element : not null access Element_Type) is private - with Implicit_Dereference => Element; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type; - - private - use Ada.Streams; - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - -- Key_Preserving references must carry information to allow removal - -- of elements whose value may have been altered improperly, i.e. have - -- been given values incompatible with the hash-code of the previous - -- value, and are thus in the wrong bucket. (RM 18.7 (96.6/3)) - - -- We cannot store the key directly because it is an unconstrained type. - -- To avoid using additional dynamic allocation we store the old cursor - -- which simplifies possible removal. This is not possible for some - -- other set types. - - -- The mechanism is different for Update_Element_Preserving_Key, as - -- in that case the check that buckets have not changed is performed - -- at the time of the update, not when the reference is finalized. - - package Impl is new Helpers.Generic_Implementation; - - type Reference_Control_Type is - new Impl.Reference_Control_Type with - record - Container : Set_Access; - Index : Hash_Type; - Old_Pos : Cursor; - Old_Hash : Hash_Type; - end record; - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - end Generic_Keys; - -private - pragma Inline (Next); - - type Node_Type; - type Node_Access is access Node_Type; - - type Node_Type is limited record - Element : aliased Element_Type; - Next : Node_Access; - end record; - - package HT_Types is - new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); - - type Set is new Ada.Finalization.Controlled with record - HT : HT_Types.Hash_Table_Type; - end record; - - overriding procedure Adjust (Container : in out Set); - - overriding procedure Finalize (Container : in out Set); - - use HT_Types, HT_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - type Cursor is record - Container : Set_Access; - Node : Node_Access; - Position : Hash_Type := Hash_Type'Last; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Set : constant Set := (Controlled with others => <>); - - No_Element : constant Cursor := - (Container => null, Node => null, Position => Hash_Type'Last); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Forward_Iterator with - record - Container : Set_Access; - end record - with Disable_Controlled => not T_Check; - - overriding function First (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - overriding procedure Finalize (Object : in out Iterator); - -end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/a-cohata.ads b/gcc/ada/a-cohata.ads deleted file mode 100644 index c83e8c0..0000000 --- a/gcc/ada/a-cohata.ads +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . H A S H _ T A B L E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- This package declares the hash-table type used to implement hashed --- containers. - -with Ada.Containers.Helpers; - -package Ada.Containers.Hash_Tables is - pragma Pure; - -- Declare Pure so this can be imported by Remote_Types packages - - generic - type Node_Type (<>) is limited private; - - type Node_Access is access Node_Type; - - package Generic_Hash_Table_Types is - - type Buckets_Type is array (Hash_Type range <>) of Node_Access; - - type Buckets_Access is access all Buckets_Type; - for Buckets_Access'Storage_Size use 0; - -- Storage_Size of zero so this package can be Pure - - type Hash_Table_Type is tagged record - Buckets : Buckets_Access := null; - Length : Count_Type := 0; - TC : aliased Helpers.Tamper_Counts; - end record; - - package Implementation is new Helpers.Generic_Implementation; - end Generic_Hash_Table_Types; - - generic - type Node_Type is private; - package Generic_Bounded_Hash_Table_Types is - - type Nodes_Type is array (Count_Type range <>) of Node_Type; - type Buckets_Type is array (Hash_Type range <>) of Count_Type; - - type Hash_Table_Type - (Capacity : Count_Type; - Modulus : Hash_Type) is - tagged record - Length : Count_Type := 0; - TC : aliased Helpers.Tamper_Counts; - Free : Count_Type'Base := -1; - Nodes : Nodes_Type (1 .. Capacity) := (others => <>); - Buckets : Buckets_Type (1 .. Modulus) := (others => 0); - end record; - - package Implementation is new Helpers.Generic_Implementation; - end Generic_Bounded_Hash_Table_Types; - -end Ada.Containers.Hash_Tables; diff --git a/gcc/ada/a-coinho-shared.adb b/gcc/ada/a-coinho-shared.adb deleted file mode 100644 index 3373dbd..0000000 --- a/gcc/ada/a-coinho-shared.adb +++ /dev/null @@ -1,528 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- Note: special attention must be paid to the case of simultaneous access --- to internal shared objects and elements by different tasks. The Reference --- counter of internal shared object is the only component protected using --- atomic operations; other components and elements can be modified only when --- reference counter is equal to one (so there are no other references to this --- internal shared object and element). - -with Ada.Unchecked_Deallocation; - -package body Ada.Containers.Indefinite_Holders is - - procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - procedure Detach (Container : Holder); - -- Detach data from shared copy if necessary. This is necessary to prepare - -- container to be modified. - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Holder) return Boolean is - begin - if Left.Reference = Right.Reference then - - -- Covers both null and not null but the same shared object cases - - return True; - - elsif Left.Reference /= null and Right.Reference /= null then - return Left.Reference.Element.all = Right.Reference.Element.all; - - else - return False; - end if; - end "="; - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (Container : in out Holder) is - begin - if Container.Reference /= null then - if Container.Busy = 0 then - - -- Container is not locked, reuse existing internal shared object - - Reference (Container.Reference); - else - -- Otherwise, create copy of both internal shared object and - -- element. - - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => - new Element_Type'(Container.Reference.Element.all)); - end if; - end if; - - Container.Busy := 0; - end Adjust; - - overriding procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Reference (Control.Container.Reference); - Control.Container.Busy := Control.Container.Busy + 1; - end if; - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Holder; Source : Holder) is - begin - if Target.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Target.Reference /= Source.Reference then - if Target.Reference /= null then - Unreference (Target.Reference); - end if; - - Target.Reference := Source.Reference; - - if Source.Reference /= null then - Reference (Target.Reference); - end if; - end if; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Holder) is - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Container.Reference /= null then - Unreference (Container.Reference); - Container.Reference := null; - end if; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Holder) return Constant_Reference_Type is - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - declare - Ref : constant Constant_Reference_Type := - (Element => Container.Reference.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); - begin - Reference (Ref.Control.Container.Reference); - Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; - return Ref; - end; - end Constant_Reference; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Holder) return Holder is - begin - if Source.Reference = null then - return (Controlled with null, 0); - - elsif Source.Busy = 0 then - - -- Container is not locked, reuse internal shared object - - Reference (Source.Reference); - - return (Controlled with Source.Reference, 0); - - else - -- Otherwise, create copy of both internal shared object and element - - return - (Controlled with - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Source.Reference.Element.all)), - 0); - end if; - end Copy; - - ------------ - -- Detach -- - ------------ - - procedure Detach (Container : Holder) is - begin - if Container.Busy = 0 - and then not System.Atomic_Counters.Is_One - (Container.Reference.Counter) - then - -- Container is not locked and internal shared object is used by - -- other container, create copy of both internal shared object and - -- element. - - declare - Old : constant Shared_Holder_Access := Container.Reference; - - begin - Container'Unrestricted_Access.Reference := - new Shared_Holder' - (Counter => <>, - Element => - new Element_Type'(Container.Reference.Element.all)); - Unreference (Old); - end; - end if; - end Detach; - - ------------- - -- Element -- - ------------- - - function Element (Container : Holder) return Element_Type is - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - else - return Container.Reference.Element.all; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Container : in out Holder) is - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Container.Reference /= null then - Unreference (Container.Reference); - Container.Reference := null; - end if; - end Finalize; - - overriding procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Unreference (Control.Container.Reference); - Control.Container.Busy := Control.Container.Busy - 1; - Control.Container := null; - end if; - end Finalize; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Holder) return Boolean is - begin - return Container.Reference = null; - end Is_Empty; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Holder; Source : in out Holder) is - begin - if Target.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Source.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Target.Reference /= Source.Reference then - if Target.Reference /= null then - Unreference (Target.Reference); - end if; - - Target.Reference := Source.Reference; - Source.Reference := null; - end if; - end Move; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Holder; - Process : not null access procedure (Element : Element_Type)) - is - B : Natural renames Container'Unrestricted_Access.Busy; - - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - B := B + 1; - - begin - Process (Container.Reference.Element.all); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : out Holder) - is - begin - Clear (Container); - - if not Boolean'Input (Stream) then - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(Element_Type'Input (Stream))); - end if; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_Holder_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - function Reference - (Container : aliased in out Holder) return Reference_Type - is - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - declare - Ref : constant Reference_Type := - (Element => Container.Reference.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); - begin - Reference (Ref.Control.Container.Reference); - Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; - return Ref; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Holder; - New_Item : Element_Type) - is - -- Element allocator may need an accessibility check in case actual type - -- is class-wide or has access discriminants (RM 4.8(10.1) and - -- AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Container.Reference = null then - -- Holder is empty, allocate new Shared_Holder. - - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(New_Item)); - - elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then - -- Shared_Holder can be reused. - - Free (Container.Reference.Element); - Container.Reference.Element := new Element_Type'(New_Item); - - else - Unreference (Container.Reference); - Container.Reference := - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(New_Item)); - end if; - end Replace_Element; - - --------------- - -- To_Holder -- - --------------- - - function To_Holder (New_Item : Element_Type) return Holder is - -- The element allocator may need an accessibility check in the case the - -- actual type is class-wide or has access discriminants (RM 4.8(10.1) - -- and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - return - (Controlled with - new Shared_Holder' - (Counter => <>, - Element => new Element_Type'(New_Item)), 0); - end To_Holder; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_Holder_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access); - - Aux : Shared_Holder_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - Free (Aux.Element); - Free (Aux); - end if; - end Unreference; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Holder; - Process : not null access procedure (Element : in out Element_Type)) - is - B : Natural renames Container.Busy; - - begin - if Container.Reference = null then - raise Constraint_Error with "container is empty"; - end if; - - Detach (Container); - - B := B + 1; - - begin - Process (Container.Reference.Element.all); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : Holder) - is - begin - Boolean'Output (Stream, Container.Reference = null); - - if Container.Reference /= null then - Element_Type'Output (Stream, Container.Reference.Element.all); - end if; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/a-coinho-shared.ads b/gcc/ada/a-coinho-shared.ads deleted file mode 100644 index e5dfb54..0000000 --- a/gcc/ada/a-coinho-shared.ads +++ /dev/null @@ -1,192 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - --- This is an optimized version of Indefinite_Holders using copy-on-write. --- It is used on platforms that support atomic built-ins. - -private with Ada.Finalization; -private with Ada.Streams; - -private with System.Atomic_Counters; - -generic - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Holders is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate (Indefinite_Holders); - pragma Remote_Types (Indefinite_Holders); - - type Holder is tagged private; - pragma Preelaborable_Initialization (Holder); - - Empty_Holder : constant Holder; - - function "=" (Left, Right : Holder) return Boolean; - - function To_Holder (New_Item : Element_Type) return Holder; - - function Is_Empty (Container : Holder) return Boolean; - - procedure Clear (Container : in out Holder); - - function Element (Container : Holder) return Element_Type; - - procedure Replace_Element - (Container : in out Holder; - New_Item : Element_Type); - - procedure Query_Element - (Container : Holder; - Process : not null access procedure (Element : Element_Type)); - procedure Update_Element - (Container : in out Holder; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Holder) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Holder) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Holder; Source : Holder); - - function Copy (Source : Holder) return Holder; - - procedure Move (Target : in out Holder; Source : in out Holder); - -private - - use Ada.Finalization; - use Ada.Streams; - - type Element_Access is access all Element_Type; - type Holder_Access is access all Holder; - - type Shared_Holder is record - Counter : System.Atomic_Counters.Atomic_Counter; - Element : Element_Access; - end record; - - type Shared_Holder_Access is access all Shared_Holder; - - procedure Reference (Item : not null Shared_Holder_Access); - -- Increment reference counter - - procedure Unreference (Item : not null Shared_Holder_Access); - -- Decrement reference counter, deallocate Item when counter goes to zero - - procedure Read - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : out Holder); - - procedure Write - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : Holder); - - type Holder is new Ada.Finalization.Controlled with record - Reference : Shared_Holder_Access; - Busy : Natural := 0; - end record; - for Holder'Read use Read; - for Holder'Write use Write; - - overriding procedure Adjust (Container : in out Holder); - overriding procedure Finalize (Container : in out Holder); - - type Reference_Control_Type is new Controlled with record - Container : Holder_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - Empty_Holder : constant Holder := (Controlled with null, 0); - -end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/a-coinho.adb b/gcc/ada/a-coinho.adb deleted file mode 100644 index e9f40ac..0000000 --- a/gcc/ada/a-coinho.adb +++ /dev/null @@ -1,383 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2012-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -package body Ada.Containers.Indefinite_Holders is - - procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Holder) return Boolean is - begin - if Left.Element = null and Right.Element = null then - return True; - elsif Left.Element /= null and Right.Element /= null then - return Left.Element.all = Right.Element.all; - else - return False; - end if; - end "="; - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (Container : in out Holder) is - begin - if Container.Element /= null then - Container.Element := new Element_Type'(Container.Element.all); - end if; - - Container.Busy := 0; - end Adjust; - - overriding procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - B : Natural renames Control.Container.Busy; - begin - B := B + 1; - end; - end if; - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Holder; Source : Holder) is - begin - if Target.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Target.Element /= Source.Element then - Free (Target.Element); - - if Source.Element /= null then - Target.Element := new Element_Type'(Source.Element.all); - end if; - end if; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Holder) is - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - Free (Container.Element); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Holder) return Constant_Reference_Type - is - Ref : constant Constant_Reference_Type := - (Element => Container.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); - B : Natural renames Ref.Control.Container.Busy; - begin - B := B + 1; - return Ref; - end Constant_Reference; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Holder) return Holder is - begin - if Source.Element = null then - return (Controlled with null, 0); - else - return (Controlled with new Element_Type'(Source.Element.all), 0); - end if; - end Copy; - - ------------- - -- Element -- - ------------- - - function Element (Container : Holder) return Element_Type is - begin - if Container.Element = null then - raise Constraint_Error with "container is empty"; - else - return Container.Element.all; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Container : in out Holder) is - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - Free (Container.Element); - end Finalize; - - overriding procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - declare - B : Natural renames Control.Container.Busy; - begin - B := B - 1; - end; - end if; - - Control.Container := null; - end Finalize; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Holder) return Boolean is - begin - return Container.Element = null; - end Is_Empty; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Holder; Source : in out Holder) is - begin - if Target.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Source.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - if Target.Element /= Source.Element then - Free (Target.Element); - Target.Element := Source.Element; - Source.Element := null; - end if; - end Move; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Holder; - Process : not null access procedure (Element : Element_Type)) - is - B : Natural renames Container'Unrestricted_Access.Busy; - - begin - if Container.Element = null then - raise Constraint_Error with "container is empty"; - end if; - - B := B + 1; - - begin - Process (Container.Element.all); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : out Holder) - is - begin - Clear (Container); - - if not Boolean'Input (Stream) then - Container.Element := new Element_Type'(Element_Type'Input (Stream)); - end if; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Holder) return Reference_Type - is - Ref : constant Reference_Type := - (Element => Container.Element.all'Access, - Control => (Controlled with Container'Unrestricted_Access)); - begin - Container.Busy := Container.Busy + 1; - return Ref; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Holder; - New_Item : Element_Type) - is - begin - if Container.Busy /= 0 then - raise Program_Error with "attempt to tamper with elements"; - end if; - - declare - X : Element_Access := Container.Element; - - -- Element allocator may need an accessibility check in case actual - -- type is class-wide or has access discriminants (RM 4.8(10.1) and - -- AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Container.Element := new Element_Type'(New_Item); - Free (X); - end; - end Replace_Element; - - --------------- - -- To_Holder -- - --------------- - - function To_Holder (New_Item : Element_Type) return Holder is - - -- The element allocator may need an accessibility check in the case the - -- actual type is class-wide or has access discriminants (RM 4.8(10.1) - -- and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - return (Controlled with new Element_Type'(New_Item), 0); - end To_Holder; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Holder; - Process : not null access procedure (Element : in out Element_Type)) - is - B : Natural renames Container.Busy; - - begin - if Container.Element = null then - raise Constraint_Error with "container is empty"; - end if; - - B := B + 1; - - begin - Process (Container.Element.all); - exception - when others => - B := B - 1; - raise; - end; - - B := B - 1; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : Holder) - is - begin - Boolean'Output (Stream, Container.Element = null); - - if Container.Element /= null then - Element_Type'Output (Stream, Container.Element.all); - end if; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/a-coinho.ads b/gcc/ada/a-coinho.ads deleted file mode 100644 index 7cfd193..0000000 --- a/gcc/ada/a-coinho.ads +++ /dev/null @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type (<>) is private; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Holders is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate (Indefinite_Holders); - pragma Remote_Types (Indefinite_Holders); - - type Holder is tagged private; - pragma Preelaborable_Initialization (Holder); - - Empty_Holder : constant Holder; - - function "=" (Left, Right : Holder) return Boolean; - - function To_Holder (New_Item : Element_Type) return Holder; - - function Is_Empty (Container : Holder) return Boolean; - - procedure Clear (Container : in out Holder); - - function Element (Container : Holder) return Element_Type; - - procedure Replace_Element - (Container : in out Holder; - New_Item : Element_Type); - - procedure Query_Element - (Container : Holder; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Holder; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Holder) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Holder) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Holder; Source : Holder); - - function Copy (Source : Holder) return Holder; - - procedure Move (Target : in out Holder; Source : in out Holder); - -private - - use Ada.Finalization; - use Ada.Streams; - - type Element_Access is access all Element_Type; - - type Holder_Access is access all Holder; - for Holder_Access'Storage_Size use 0; - - procedure Read - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : out Holder); - - procedure Write - (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - Container : Holder); - - type Holder is new Ada.Finalization.Controlled with record - Element : Element_Access; - Busy : Natural := 0; - end record; - for Holder'Read use Read; - for Holder'Write use Write; - - overriding procedure Adjust (Container : in out Holder); - overriding procedure Finalize (Container : in out Holder); - - type Reference_Control_Type is new Controlled with - record - Container : Holder_Access; - end record; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - Empty_Holder : constant Holder := (Controlled with null, 0); - -end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/a-coinve.adb b/gcc/ada/a-coinve.adb deleted file mode 100644 index 3c19727..0000000 --- a/gcc/ada/a-coinve.adb +++ /dev/null @@ -1,3663 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Indefinite_Vectors is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - - procedure Free is - new Ada.Unchecked_Deallocation (Element_Type, Element_Access); - - procedure Append_Slow_Path - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type); - -- This is the slow path for Append. This is split out to minimize the size - -- of Append, because we have Inline (Append). - - --------- - -- "&" -- - --------- - - -- We decide that the capacity of the result of "&" is the minimum needed - -- -- the sum of the lengths of the vector parameters. We could decide to - -- make it larger, but we have no basis for knowing how much larger, so we - -- just allocate the minimum amount of storage. - - function "&" (Left, Right : Vector) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, Length (Left) + Length (Right)); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - function "&" (Left : Vector; Right : Element_Type) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, Length (Left) + 1); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - function "&" (Left : Element_Type; Right : Vector) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, 1 + Length (Right)); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - function "&" (Left, Right : Element_Type) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, 1 + 1); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - --------- - -- "=" -- - --------- - - overriding function "=" (Left, Right : Vector) return Boolean is - begin - if Left.Last /= Right.Last then - return False; - end if; - - if Left.Length = 0 then - return True; - end if; - - declare - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - begin - for J in Index_Type range Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) = null then - if Right.Elements.EA (J) /= null then - return False; - end if; - - elsif Right.Elements.EA (J) = null then - return False; - - elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then - return False; - end if; - end loop; - end; - - return True; - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Vector) is - begin - -- If the counts are nonzero, execution is technically erroneous, but - -- it seems friendly to allow things like concurrent "=" on shared - -- constants. - - Zero_Counts (Container.TC); - - if Container.Last = No_Index then - Container.Elements := null; - return; - end if; - - declare - L : constant Index_Type := Container.Last; - E : Elements_Array renames - Container.Elements.EA (Index_Type'First .. L); - - begin - Container.Elements := null; - Container.Last := No_Index; - - Container.Elements := new Elements_Type (L); - - for J in E'Range loop - if E (J) /= null then - Container.Elements.EA (J) := new Element_Type'(E (J).all); - end if; - - Container.Last := J; - end loop; - end; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - elsif Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - else - Insert (Container, Container.Last + 1, New_Item); - end if; - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - -- In the general case, we pass the buck to Insert, but for efficiency, - -- we check for the usual case where Count = 1 and the vector has enough - -- room for at least one more element. - - if Count = 1 - and then Container.Elements /= null - and then Container.Last /= Container.Elements.Last - then - TC_Check (Container.TC); - - -- Increment Container.Last after assigning the New_Item, so we - -- leave the Container unmodified in case Finalize/Adjust raises - -- an exception. - - declare - New_Last : constant Index_Type := Container.Last + 1; - - -- The element allocator may need an accessibility check in the - -- case actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - begin - Container.Elements.EA (New_Last) := new Element_Type'(New_Item); - Container.Last := New_Last; - end; - - else - Append_Slow_Path (Container, New_Item, Count); - end if; - end Append; - - ---------------------- - -- Append_Slow_Path -- - ---------------------- - - procedure Append_Slow_Path - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - elsif Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - else - Insert (Container, Container.Last + 1, New_Item, Count); - end if; - end Append_Slow_Path; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - begin - if Target'Address = Source'Address then - return; - else - Target.Clear; - Target.Append (Source); - end if; - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Count_Type is - begin - if Container.Elements = null then - return 0; - else - return Container.Elements.EA'Length; - end if; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - TC_Check (Container.TC); - - while Container.Last >= Index_Type'First loop - declare - X : Element_Access := Container.Elements.EA (Container.Last); - begin - Container.Elements.EA (Container.Last) := null; - Container.Last := Container.Last - 1; - Free (X); - end; - end loop; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Position.Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return Constant_Reference_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Count_Type := 0) return Vector - is - C : Count_Type; - - begin - if Capacity < Source.Length then - if Checks and then Capacity /= 0 then - raise Capacity_Error - with "Requested capacity is less than Source length"; - end if; - - C := Source.Length; - else - C := Capacity; - end if; - - return Target : Vector do - Target.Reserve_Capacity (C); - Target.Assign (Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type := 1) - is - Old_Last : constant Index_Type'Base := Container.Last; - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - J : Index_Type'Base; -- first index of items that slide down - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Checks and then Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Checks and then Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - else - return; - end if; - end if; - - -- Here and elsewhere we treat deleting 0 items from the container as a - -- no-op, even when the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- The internal elements array isn't guaranteed to exist unless we have - -- elements, so we handle that case here in order to avoid having to - -- check it later. (Note that an empty vector can never be busy, so - -- there's no semantic harm in returning early.) - - if Container.Is_Empty then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete checks the count to determine whether it is - -- being called while the associated callback procedure is executing. - - TC_Check (Container.TC); - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If the number of elements requested (Count) for deletion is equal to - -- (or greater than) the number of elements available (Count2) for - -- deletion beginning at Index, then everything from Index to - -- Container.Last is deleted (this is equivalent to Delete_Last). - - if Count >= Count2 then - -- Elements in an indefinite vector are allocated, so we must iterate - -- over the loop and deallocate elements one-at-a-time. We work from - -- back to front, deleting the last element during each pass, in - -- order to gracefully handle deallocation failures. - - declare - EA : Elements_Array renames Container.Elements.EA; - - begin - while Container.Last >= Index loop - declare - K : constant Index_Type := Container.Last; - X : Element_Access := EA (K); - - begin - -- We first isolate the element we're deleting, removing it - -- from the vector before we attempt to deallocate it, in - -- case the deallocation fails. - - EA (K) := null; - Container.Last := K - 1; - - -- Container invariants have been restored, so it is now - -- safe to attempt to deallocate the element. - - Free (X); - end; - end loop; - end; - - return; - end if; - - -- There are some elements that aren't being deleted (the requested - -- count was less than the available count), so we must slide them down - -- to Index. We first calculate the index values of the respective array - -- slices, using the wider of Index_Type'Base and Count_Type'Base as the - -- type for intermediate calculations. For the elements that slide down, - -- index value New_Last is the last index value of their new home, and - -- index value J is the first index of their old home. - - if Index_Type'Base'Last >= Count_Type_Last then - New_Last := Old_Last - Index_Type'Base (Count); - J := Index + Index_Type'Base (Count); - else - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - J := Index_Type'Base (Count_Type'Base (Index) + Count); - end if; - - -- The internal elements array isn't guaranteed to exist unless we have - -- elements, but we have that guarantee here because we know we have - -- elements to slide. The array index values for each slice have - -- already been determined, so what remains to be done is to first - -- deallocate the elements that are being deleted, and then slide down - -- to Index the elements that aren't being deleted. - - declare - EA : Elements_Array renames Container.Elements.EA; - - begin - -- Before we can slide down the elements that aren't being deleted, - -- we need to deallocate the elements that are being deleted. - - for K in Index .. J - 1 loop - declare - X : Element_Access := EA (K); - - begin - -- First we remove the element we're about to deallocate from - -- the vector, in case the deallocation fails, in order to - -- preserve representation invariants. - - EA (K) := null; - - -- The element has been removed from the vector, so it is now - -- safe to attempt to deallocate it. - - Free (X); - end; - end loop; - - EA (Index .. New_Last) := EA (J .. Old_Last); - Container.Last := New_Last; - end; - end Delete; - - procedure Delete - (Container : in out Vector; - Position : in out Cursor; - Count : Count_Type := 1) - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - - elsif Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - end if; - - Delete (Container, Position.Index, Count); - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - -- It is not permitted to delete items while the container is busy (for - -- example, we're in the middle of a passive iteration). However, we - -- always treat deleting 0 items as a no-op, even when we're busy, so we - -- simply return without checking. - - if Count = 0 then - return; - end if; - - -- We cannot simply subsume the empty case into the loop below (the loop - -- would iterate 0 times), because we rename the internal array object - -- (which is allocated), but an empty vector isn't guaranteed to have - -- actually allocated an array. (Note that an empty vector can never be - -- busy, so there's no semantic harm in returning early here.) - - if Container.Is_Empty then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete_Last checks the count to determine whether - -- it is being called while the associated callback procedure is - -- executing. - - TC_Check (Container.TC); - - -- Elements in an indefinite vector are allocated, so we must iterate - -- over the loop and deallocate elements one-at-a-time. We work from - -- back to front, deleting the last element during each pass, in order - -- to gracefully handle deallocation failures. - - declare - E : Elements_Array renames Container.Elements.EA; - - begin - for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop - declare - J : constant Index_Type := Container.Last; - X : Element_Access := E (J); - - begin - -- Note that we first isolate the element we're deleting, - -- removing it from the vector, before we actually deallocate - -- it, in order to preserve representation invariants even if - -- the deallocation fails. - - E (J) := null; - Container.Last := J - 1; - - -- Container invariants have been restored, so it is now safe - -- to deallocate the element. - - Free (X); - end; - end loop; - end; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - EA : constant Element_Access := Container.Elements.EA (Index); - begin - if Checks and then EA = null then - raise Constraint_Error with "element is empty"; - else - return EA.all; - end if; - end; - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - declare - EA : constant Element_Access := - Position.Container.Elements.EA (Position.Index); - begin - if Checks and then EA = null then - raise Constraint_Error with "element is empty"; - else - return EA.all; - end if; - end; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Vector) is - begin - Clear (Container); -- Checks busy-bit - - declare - X : Elements_Access := Container.Elements; - begin - Container.Elements := null; - Free (X); - end; - end Finalize; - - procedure Finalize (Object : in out Iterator) is - begin - Unbusy (Object.Container.TC); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - begin - if Checks and then Position.Container /= null then - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J).all = Item then - return Cursor'(Container'Unrestricted_Access, J); - end if; - end loop; - - return No_Element; - end; - end Find; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for Indx in Index .. Container.Last loop - if Container.Elements.EA (Indx).all = Item then - return Indx; - end if; - end loop; - - return No_Index; - end Find_Index; - - ----------- - -- First -- - ----------- - - function First (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - end if; - - return (Container'Unrestricted_Access, Index_Type'First); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the First (and Last) selector function. - - -- When the Index component is No_Index, this means the iterator - -- object was constructed without a start expression, in which case the - -- (forward) iteration starts from the (logical) beginning of the entire - -- sequence of items (corresponding to Container.First, for a forward - -- iterator). - - -- Otherwise, this is iteration over a partial sequence of items. - -- When the Index component isn't No_Index, the iterator object was - -- constructed with a start expression, that specifies the position - -- from which the (forward) partial iteration begins. - - if Object.Index = No_Index then - return First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Checks and then Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - end if; - - declare - EA : constant Element_Access := - Container.Elements.EA (Index_Type'First); - begin - if Checks and then EA = null then - raise Constraint_Error with "first element is empty"; - else - return EA.all; - end if; - end; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Less (L, R : Element_Access) return Boolean; - pragma Inline (Is_Less); - - ------------- - -- Is_Less -- - ------------- - - function Is_Less (L, R : Element_Access) return Boolean is - begin - if L = null then - return R /= null; - elsif R = null then - return False; - else - return L.all < R.all; - end if; - end Is_Less; - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - begin - if Container.Last <= Index_Type'First then - return True; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - E : Elements_Array renames Container.Elements.EA; - begin - for J in Index_Type'First .. Container.Last - 1 loop - if Is_Less (E (J + 1), E (J)) then - return False; - end if; - end loop; - - return True; - end; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target, Source : in out Vector) is - I, J : Index_Type'Base; - - begin - -- The semantics of Merge changed slightly per AI05-0021. It was - -- originally the case that if Target and Source denoted the same - -- container object, then the GNAT implementation of Merge did - -- nothing. However, it was argued that RM05 did not precisely - -- specify the semantics for this corner case. The decision of the - -- ARG was that if Target and Source denote the same non-empty - -- container object, then Program_Error is raised. - - if Source.Last < Index_Type'First then -- Source is empty - return; - end if; - - if Checks and then Target'Address = Source'Address then - raise Program_Error with - "Target and Source denote same non-empty container"; - end if; - - if Target.Last < Index_Type'First then -- Target is empty - Move (Target => Target, Source => Source); - return; - end if; - - TC_Check (Source.TC); - - I := Target.Last; -- original value (before Set_Length) - Target.Set_Length (Length (Target) + Length (Source)); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - TA : Elements_Array renames Target.Elements.EA; - SA : Elements_Array renames Source.Elements.EA; - - Lock_Target : With_Lock (Target.TC'Unchecked_Access); - Lock_Source : With_Lock (Source.TC'Unchecked_Access); - begin - J := Target.Last; -- new value (after Set_Length) - while Source.Last >= Index_Type'First loop - pragma Assert - (Source.Last <= Index_Type'First - or else not (Is_Less (SA (Source.Last), - SA (Source.Last - 1)))); - - if I < Index_Type'First then - declare - Src : Elements_Array renames - SA (Index_Type'First .. Source.Last); - begin - TA (Index_Type'First .. J) := Src; - Src := (others => null); - end; - - Source.Last := No_Index; - exit; - end if; - - pragma Assert - (I <= Index_Type'First - or else not (Is_Less (TA (I), TA (I - 1)))); - - declare - Src : Element_Access renames SA (Source.Last); - Tgt : Element_Access renames TA (I); - - begin - if Is_Less (Src, Tgt) then - Target.Elements.EA (J) := Tgt; - Tgt := null; - I := I - 1; - - else - Target.Elements.EA (J) := Src; - Src := null; - Source.Last := Source.Last - 1; - end if; - end; - - J := J - 1; - end loop; - end; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - procedure Sort is new Generic_Array_Sort - (Index_Type => Index_Type, - Element_Type => Element_Access, - Array_Type => Elements_Array, - "<" => Is_Less); - - -- Start of processing for Sort - - begin - if Container.Last <= Index_Type'First then - return; - end if; - - -- The exception behavior for the vector container must match that - -- for the list container, so we check for cursor tampering here - -- (which will catch more things) instead of for element tampering - -- (which will catch fewer things). It's true that the elements of - -- this vector container could be safely moved around while (say) an - -- iteration is taking place (iteration only increments the busy - -- counter), and so technically all we would need here is a test for - -- element tampering (indicated by the lock counter), that's simply - -- an artifact of our array-based implementation. Logically Sort - -- requires a check for cursor tampering. - - TC_Check (Container.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); - end; - end Sort; - - end Generic_Sorting; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access - is - Ptr : constant Element_Access := - Position.Container.Elements.EA (Position.Index); - - begin - -- An indefinite vector may contain spaces that hold no elements. - -- Any iteration over an indefinite vector with spaces will raise - -- Constraint_Error. - - if Ptr = null then - raise Constraint_Error; - - else - return Ptr; - end if; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - if Position.Container = null then - return False; - else - return Position.Index <= Position.Container.Last; - end if; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - New_Last : Index_Type'Base; -- last index of vector after insertion - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - New_Capacity : Count_Type'Base; -- length of new, expanded array - Dst_Last : Index_Type'Base; -- last index of new, expanded array - Dst : Elements_Access; -- new, expanded internal array - - begin - if Checks then - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we - -- do not allow that as the value for Index when specifying where the - -- new items should be inserted, so we must manually check. (That the - -- user is allowed to specify the value at all here is a consequence - -- of the declaration of the Extended_Index subtype, which includes - -- the values in the base range that immediately precede and - -- immediately follow the values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for - -- the case of appending items to the back end of the vector. (It is - -- assumed that specifying an index value greater than Last + 1 - -- indicates some deeper flaw in the caller's algorithm, so that case - -- is treated as a proper error.) - - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note: we cannot simply add these values, because of the possibility - -- of overflow. - - if Checks and then Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if Checks and then New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- New_Last is the last index value of the items in the container after - -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to - -- compute its value from the New_Length. - - if Index_Type'Base'Last >= Count_Type_Last then - New_Last := No_Index + Index_Type'Base (New_Length); - else - New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - - if Container.Elements = null then - pragma Assert (Container.Last = No_Index); - - -- This is the simplest case, with which we must always begin: we're - -- inserting items into an empty vector that hasn't allocated an - -- internal array yet. Note that we don't need to check the busy bit - -- here, because an empty container cannot be busy. - - -- In an indefinite vector, elements are allocated individually, and - -- stored as access values on the internal array (the length of which - -- represents the vector "capacity"), which is separately allocated. - - Container.Elements := new Elements_Type (New_Last); - - -- The element backbone has been successfully allocated, so now we - -- allocate the elements. - - for Idx in Container.Elements.EA'Range loop - - -- In order to preserve container invariants, we always attempt - -- the element allocation first, before setting the Last index - -- value, in case the allocation fails (either because there is no - -- storage available, or because element initialization fails). - - declare - -- The element allocator may need an accessibility check in the - -- case actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Container.Elements.EA (Idx) := new Element_Type'(New_Item); - end; - - -- The allocation of the element succeeded, so it is now safe to - -- update the Last index, restoring container invariants. - - Container.Last := Idx; - end loop; - - return; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - TC_Check (Container.TC); - - if New_Length <= Container.Elements.EA'Length then - - -- In this case, we're inserting elements into a vector that has - -- already allocated an internal array, and the existing array has - -- enough unused storage for the new items. - - declare - E : Elements_Array renames Container.Elements.EA; - K : Index_Type'Base; - - begin - if Before > Container.Last then - - -- The new items are being appended to the vector, so no - -- sliding of existing elements is required. - - for Idx in Before .. New_Last loop - - -- In order to preserve container invariants, we always - -- attempt the element allocation first, before setting the - -- Last index value, in case the allocation fails (either - -- because there is no storage available, or because element - -- initialization fails). - - declare - -- The element allocator may need an accessibility check - -- in case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - E (Idx) := new Element_Type'(New_Item); - end; - - -- The allocation of the element succeeded, so it is now - -- safe to update the Last index, restoring container - -- invariants. - - Container.Last := Idx; - end loop; - - else - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate index values. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - -- The new items are being inserted in the middle of the array, - -- in the range [Before, Index). Copy the existing elements to - -- the end of the array, to make room for the new items. - - E (Index .. New_Last) := E (Before .. Container.Last); - Container.Last := New_Last; - - -- We have copied the existing items up to the end of the - -- array, to make room for the new items in the middle of - -- the array. Now we actually allocate the new items. - - -- Note: initialize K outside loop to make it clear that - -- K always has a value if the exception handler triggers. - - K := Before; - - declare - -- The element allocator may need an accessibility check in - -- the case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - while K < Index loop - E (K) := new Element_Type'(New_Item); - K := K + 1; - end loop; - - exception - when others => - - -- Values in the range [Before, K) were successfully - -- allocated, but values in the range [K, Index) are - -- stale (these array positions contain copies of the - -- old items, that did not get assigned a new item, - -- because the allocation failed). We must finish what - -- we started by clearing out all of the stale values, - -- leaving a "hole" in the middle of the array. - - E (K .. Index - 1) := (others => null); - raise; - end; - end if; - end; - - return; - end if; - - -- In this case, we're inserting elements into a vector that has already - -- allocated an internal array, but the existing array does not have - -- enough storage, so we must allocate a new, longer array. In order to - -- guarantee that the amortized insertion cost is O(1), we always - -- allocate an array whose length is some power-of-two factor of the - -- current array length. (The new array cannot have a length less than - -- the New_Length of the container, but its last index value cannot be - -- greater than Index_Type'Last.) - - New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); - while New_Capacity < New_Length loop - if New_Capacity > Count_Type'Last / 2 then - New_Capacity := Count_Type'Last; - exit; - end if; - - New_Capacity := 2 * New_Capacity; - end loop; - - if New_Capacity > Max_Length then - - -- We have reached the limit of capacity, so no further expansion - -- will occur. (This is not a problem, as there is never a need to - -- have more capacity than the maximum container length.) - - New_Capacity := Max_Length; - end if; - - -- We have computed the length of the new internal array (and this is - -- what "vector capacity" means), so use that to compute its last index. - - if Index_Type'Base'Last >= Count_Type_Last then - Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else - Dst_Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); - end if; - - -- Now we allocate the new, longer internal array. If the allocation - -- fails, we have not changed any container state, so no side-effect - -- will occur as a result of propagating the exception. - - Dst := new Elements_Type (Dst_Last); - - -- We have our new internal array. All that needs to be done now is to - -- copy the existing items (if any) from the old array (the "source" - -- array) to the new array (the "destination" array), and then - -- deallocate the old array. - - declare - Src : Elements_Access := Container.Elements; - - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); - - if Before > Container.Last then - - -- The new items are being appended to the vector, so no - -- sliding of existing elements is required. - - -- We have copied the elements from to the old source array to the - -- new destination array, so we can now deallocate the old array. - - Container.Elements := Dst; - Free (Src); - - -- Now we append the new items. - - for Idx in Before .. New_Last loop - - -- In order to preserve container invariants, we always attempt - -- the element allocation first, before setting the Last index - -- value, in case the allocation fails (either because there - -- is no storage available, or because element initialization - -- fails). - - declare - -- The element allocator may need an accessibility check in - -- the case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Dst.EA (Idx) := new Element_Type'(New_Item); - end; - - -- The allocation of the element succeeded, so it is now safe - -- to update the Last index, restoring container invariants. - - Container.Last := Idx; - end loop; - - else - -- The new items are being inserted before some existing elements, - -- so we must slide the existing elements up to their new home. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - - -- We have copied the elements from to the old source array to the - -- new destination array, so we can now deallocate the old array. - - Container.Elements := Dst; - Container.Last := New_Last; - Free (Src); - - -- The new array has a range in the middle containing null access - -- values. Fill in that partition of the array with the new items. - - for Idx in Before .. Index - 1 loop - - -- Note that container invariants have already been satisfied - -- (in particular, the Last index value of the vector has - -- already been updated), so if this allocation fails we simply - -- let it propagate. - - declare - -- The element allocator may need an accessibility check in - -- the case the actual type is class-wide or has access - -- discriminants (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Dst.EA (Idx) := new Element_Type'(New_Item); - end; - end loop; - end if; - end; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - J : Index_Type'Base; - - begin - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - if Container'Address /= New_Item'Address then - - -- This is the simple case. New_Item denotes an object different - -- from Container, so there's nothing special we need to do to copy - -- the source items to their destination, because all of the source - -- items are contiguous. - - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. New_Item.Last; - - Src : Elements_Array renames - New_Item.Elements.EA (Src_Index_Subtype); - - Dst : Elements_Array renames Container.Elements.EA; - - Dst_Index : Index_Type'Base; - - begin - Dst_Index := Before - 1; - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - end; - - return; - end if; - - -- New_Item denotes the same object as Container, so an insertion has - -- potentially split the source items. The first source slice is - -- [Index_Type'First, Before), and the second source slice is - -- [J, Container.Last], where index value J is the first index of the - -- second slice. (J gets computed below, but only after we have - -- determined that the second source slice is non-empty.) The - -- destination slice is always the range [Before, J). We perform the - -- copy in two steps, using each of the two slices of the source items. - - declare - L : constant Index_Type'Base := Before - 1; - - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. L; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - Dst : Elements_Array renames Container.Elements.EA; - - Dst_Index : Index_Type'Base; - - begin - -- We first copy the source items that precede the space we - -- inserted. (If Before equals Index_Type'First, then this first - -- source slice will be empty, which is harmless.) - - Dst_Index := Before - 1; - for Src_Index in Src'Range loop - Dst_Index := Dst_Index + 1; - - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - end loop; - - if Src'Length = N then - - -- The new items were effectively appended to the container, so we - -- have already copied all of the items that need to be copied. - -- We return early here, even though the source slice below is - -- empty (so the assignment would be harmless), because we want to - -- avoid computing J, which will overflow if J is greater than - -- Index_Type'Base'Last. - - return; - end if; - end; - - -- Index value J is the first index of the second source slice. (It is - -- also 1 greater than the last index of the destination slice.) Note: - -- avoid computing J if J is greater than Index_Type'Base'Last, in order - -- to avoid overflow. Prevent that by returning early above, immediately - -- after copying the first slice of the source, and determining that - -- this second slice of the source is empty. - - if Index_Type'Base'Last >= Count_Type_Last then - J := Before + Index_Type'Base (N); - else - J := Index_Type'Base (Count_Type'Base (Before) + N); - end if; - - declare - subtype Src_Index_Subtype is Index_Type'Base range - J .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - Dst : Elements_Array renames Container.Elements.EA; - - Dst_Index : Index_Type'Base; - - begin - -- We next copy the source items that follow the space we inserted. - -- Index value Dst_Index is the first index of that portion of the - -- destination that receives this slice of the source. (For the - -- reasons given above, this slice is guaranteed to be non-empty.) - - if Index_Type'Base'Last >= Count_Type_Last then - Dst_Index := J - Index_Type'Base (Src'Length); - else - Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); - end if; - - for Src_Index in Src'Range loop - if Src (Src_Index) /= null then - Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); - end if; - - Dst_Index := Dst_Index + 1; - end loop; - end; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector; - Position : out Cursor) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - if Before.Container = null or else Before.Index > Container.Last then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - - Position := (Container'Unrestricted_Access, Index); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null or else Before.Index > Container.Last then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - - Position := (Container'Unrestricted_Access, Index); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - New_Last : Index_Type'Base; -- last index of vector after insertion - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - New_Capacity : Count_Type'Base; -- length of new, expanded array - Dst_Last : Index_Type'Base; -- last index of new, expanded array - Dst : Elements_Access; -- new, expanded internal array - - begin - if Checks then - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we - -- do not allow that as the value for Index when specifying where the - -- new items should be inserted, so we must manually check. (That the - -- user is allowed to specify the value at all here is a consequence - -- of the declaration of the Extended_Index subtype, which includes - -- the values in the base range that immediately precede and - -- immediately follow the values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for - -- the case of appending items to the back end of the vector. (It is - -- assumed that specifying an index value greater than Last + 1 - -- indicates some deeper flaw in the caller's algorithm, so that case - -- is treated as a proper error.) - - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note: we cannot simply add these values, because of the possibility - -- of overflow. - - if Checks and then Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type_Last then - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if Checks and then New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- New_Last is the last index value of the items in the container after - -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to - -- compute its value from the New_Length. - - if Index_Type'Base'Last >= Count_Type_Last then - New_Last := No_Index + Index_Type'Base (New_Length); - else - New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - - if Container.Elements = null then - pragma Assert (Container.Last = No_Index); - - -- This is the simplest case, with which we must always begin: we're - -- inserting items into an empty vector that hasn't allocated an - -- internal array yet. Note that we don't need to check the busy bit - -- here, because an empty container cannot be busy. - - -- In an indefinite vector, elements are allocated individually, and - -- stored as access values on the internal array (the length of which - -- represents the vector "capacity"), which is separately allocated. - -- We have no elements here (because we're inserting "space"), so all - -- we need to do is allocate the backbone. - - Container.Elements := new Elements_Type (New_Last); - Container.Last := New_Last; - - return; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on exit. - -- Insert checks the count to determine whether it is being called while - -- the associated callback procedure is executing. - - TC_Check (Container.TC); - - if New_Length <= Container.Elements.EA'Length then - - -- In this case, we are inserting elements into a vector that has - -- already allocated an internal array, and the existing array has - -- enough unused storage for the new items. - - declare - E : Elements_Array renames Container.Elements.EA; - - begin - if Before <= Container.Last then - - -- The new space is being inserted before some existing - -- elements, so we must slide the existing elements up to - -- their new home. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate index values. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - E (Index .. New_Last) := E (Before .. Container.Last); - E (Before .. Index - 1) := (others => null); - end if; - end; - - Container.Last := New_Last; - return; - end if; - - -- In this case, we're inserting elements into a vector that has already - -- allocated an internal array, but the existing array does not have - -- enough storage, so we must allocate a new, longer array. In order to - -- guarantee that the amortized insertion cost is O(1), we always - -- allocate an array whose length is some power-of-two factor of the - -- current array length. (The new array cannot have a length less than - -- the New_Length of the container, but its last index value cannot be - -- greater than Index_Type'Last.) - - New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); - while New_Capacity < New_Length loop - if New_Capacity > Count_Type'Last / 2 then - New_Capacity := Count_Type'Last; - exit; - end if; - - New_Capacity := 2 * New_Capacity; - end loop; - - if New_Capacity > Max_Length then - - -- We have reached the limit of capacity, so no further expansion - -- will occur. (This is not a problem, as there is never a need to - -- have more capacity than the maximum container length.) - - New_Capacity := Max_Length; - end if; - - -- We have computed the length of the new internal array (and this is - -- what "vector capacity" means), so use that to compute its last index. - - if Index_Type'Base'Last >= Count_Type_Last then - Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else - Dst_Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); - end if; - - -- Now we allocate the new, longer internal array. If the allocation - -- fails, we have not changed any container state, so no side-effect - -- will occur as a result of propagating the exception. - - Dst := new Elements_Type (Dst_Last); - - -- We have our new internal array. All that needs to be done now is to - -- copy the existing items (if any) from the old array (the "source" - -- array) to the new array (the "destination" array), and then - -- deallocate the old array. - - declare - Src : Elements_Access := Container.Elements; - - begin - Dst.EA (Index_Type'First .. Before - 1) := - Src.EA (Index_Type'First .. Before - 1); - - if Before <= Container.Last then - - -- The new items are being inserted before some existing elements, - -- so we must slide the existing elements up to their new home. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); - end if; - - -- We have copied the elements from to the old, source array to the - -- new, destination array, so we can now restore invariants, and - -- deallocate the old array. - - Container.Elements := Dst; - Container.Last := New_Last; - Free (Src); - end; - end Insert_Space; - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null or else Before.Index > Container.Last then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert_Space (Container, Index, Count); - - Position := (Container'Unrestricted_Access, Index); - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Container.Last < Index_Type'First; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - end Iterate; - - function Iterate - (Container : Vector) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - begin - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is No_Index (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => No_Index) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : Vector; - Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks then - if Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; - - if Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - end if; - - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is not No_Index (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => Start.Index) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - end if; - - return (Container'Unrestricted_Access, Container.Last); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the Last (and First) selector function. - - -- When the Index component is No_Index, this means the iterator - -- object was constructed without a start expression, in which case the - -- (reverse) iteration starts from the (logical) beginning of the entire - -- sequence (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. - -- When the Index component is not No_Index, the iterator object was - -- constructed with a start expression, that specifies the position - -- from which the (reverse) partial iteration begins. - - if Object.Index = No_Index then - return Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Checks and then Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - end if; - - declare - EA : constant Element_Access := - Container.Elements.EA (Container.Last); - begin - if Checks and then EA = null then - raise Constraint_Error with "last element is empty"; - else - return EA.all; - end if; - end; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Count_Type is - L : constant Index_Type'Base := Container.Last; - F : constant Index_Type := Index_Type'First; - - begin - -- The base range of the index type (Index_Type'Base) might not include - -- all values for length (Count_Type). Contrariwise, the index type - -- might include values outside the range of length. Hence we use - -- whatever type is wider for intermediate values when calculating - -- length. Note that no matter what the index type is, the maximum - -- length to which a vector is allowed to grow is always the minimum - -- of Count_Type'Last and (IT'Last - IT'First + 1). - - -- For example, an Index_Type with range -127 .. 127 is only guaranteed - -- to have a base range of -128 .. 127, but the corresponding vector - -- would have lengths in the range 0 .. 255. In this case we would need - -- to use Count_Type'Base for intermediate values. - - -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The - -- vector would have a maximum length of 10, but the index values lie - -- outside the range of Count_Type (which is only 32 bits). In this - -- case we would need to use Index_Type'Base for intermediate values. - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - return Count_Type'Base (L) - Count_Type'Base (F) + 1; - else - return Count_Type (L - F + 1); - end if; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Vector; - Source : in out Vector) - is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Clear (Target); -- Checks busy-bit - - declare - Target_Elements : constant Elements_Access := Target.Elements; - begin - Target.Elements := Source.Elements; - Source.Elements := Target_Elements; - end; - - Target.Last := Source.Last; - Source.Last := No_Index; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Position.Index < Position.Container.Last then - return (Position.Container, Position.Index + 1); - else - return No_Element; - end if; - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong vector"; - else - return Next (Position); - end if; - end Next; - - procedure Next (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index < Position.Container.Last then - Position.Index := Position.Index + 1; - else - Position := No_Element; - end if; - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Position.Index > Index_Type'First then - return (Position.Container, Position.Index - 1); - else - return No_Element; - end if; - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong vector"; - else - return Previous (Position); - end if; - end Previous; - - procedure Previous (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index > Index_Type'First then - Position.Index := Position.Index - 1; - else - Position := No_Element; - end if; - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Vector'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)) - is - Lock : With_Lock (Container.TC'Unrestricted_Access); - V : Vector renames Container'Unrestricted_Access.all; - - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - if Checks and then V.Elements.EA (Index) = null then - raise Constraint_Error with "element is null"; - end if; - - Process (V.Elements.EA (Index).all); - end Query_Element; - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - else - Query_Element (Position.Container.all, Position.Index, Process); - end if; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector) - is - Length : Count_Type'Base; - Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); - B : Boolean; - - begin - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; - - for J in Count_Type range 1 .. Length loop - Last := Last + 1; - - Boolean'Read (Stream, B); - - if B then - Container.Elements.EA (Last) := - new Element_Type'(Element_Type'Input (Stream)); - end if; - - Container.Last := Last; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Vector; - Position : Cursor) return Reference_Type - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Reference_Type := - (Element => Container.Elements.EA (Position.Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Vector; - Index : Index_Type) return Reference_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - -- The following will raise Constraint_Error if Element is null - - return R : constant Reference_Type := - (Element => Container.Elements.EA (Index), - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - TE_Check (Container.TC); - - declare - X : Element_Access := Container.Elements.EA (Index); - - -- The element allocator may need an accessibility check in the case - -- where the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Container.Elements.EA (Index) := new Element_Type'(New_Item); - Free (X); - end; - end Replace_Element; - - procedure Replace_Element - (Container : in out Vector; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - TE_Check (Container.TC); - - declare - X : Element_Access := Container.Elements.EA (Position.Index); - - -- The element allocator may need an accessibility check in the case - -- where the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - Container.Elements.EA (Position.Index) := new Element_Type'(New_Item); - Free (X); - end; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Count_Type) - is - N : constant Count_Type := Length (Container); - - Index : Count_Type'Base; - Last : Index_Type'Base; - - begin - -- Reserve_Capacity can be used to either expand the storage available - -- for elements (this would be its typical use, in anticipation of - -- future insertion), or to trim back storage. In the latter case, - -- storage can only be trimmed back to the limit of the container - -- length. Note that Reserve_Capacity neither deletes (active) elements - -- nor inserts elements; it only affects container capacity, never - -- container length. - - if Capacity = 0 then - - -- This is a request to trim back storage, to the minimum amount - -- possible given the current state of the container. - - if N = 0 then - - -- The container is empty, so in this unique case we can - -- deallocate the entire internal array. Note that an empty - -- container can never be busy, so there's no need to check the - -- tampering bits. - - declare - X : Elements_Access := Container.Elements; - - begin - -- First we remove the internal array from the container, to - -- handle the case when the deallocation raises an exception - -- (although that's unlikely, since this is simply an array of - -- access values, all of which are null). - - Container.Elements := null; - - -- Container invariants have been restored, so it is now safe - -- to attempt to deallocate the internal array. - - Free (X); - end; - - elsif N < Container.Elements.EA'Length then - - -- The container is not empty, and the current length is less than - -- the current capacity, so there's storage available to trim. In - -- this case, we allocate a new internal array having a length - -- that exactly matches the number of items in the - -- container. (Reserve_Capacity does not delete active elements, - -- so this is the best we can do with respect to minimizing - -- storage). - - TC_Check (Container.TC); - - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; - - begin - -- Although we have isolated the old internal array that we're - -- going to deallocate, we don't deallocate it until we have - -- successfully allocated a new one. If there is an exception - -- during allocation (because there is not enough storage), we - -- let it propagate without causing any side-effect. - - Container.Elements := new Elements_Type'(Container.Last, Src); - - -- We have successfully allocated a new internal array (with a - -- smaller length than the old one, and containing a copy of - -- just the active elements in the container), so we can - -- deallocate the old array. - - Free (X); - end; - end if; - - return; - end if; - - -- Reserve_Capacity can be used to expand the storage available for - -- elements, but we do not let the capacity grow beyond the number of - -- values in Index_Type'Range. (Were it otherwise, there would be no way - -- to refer to the elements with index values greater than - -- Index_Type'Last, so that storage would be wasted.) Here we compute - -- the Last index value of the new internal array, in a way that avoids - -- any possibility of overflow. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index - then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Capacity); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Capacity is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Capacity. - - Index := Count_Type'Base (No_Index) + Capacity; -- Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We have determined that the value of Capacity would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); - end if; - - -- The requested capacity is non-zero, but we don't know yet whether - -- this is a request for expansion or contraction of storage. - - if Container.Elements = null then - - -- The container is empty (it doesn't even have an internal array), - -- so this represents a request to allocate storage having the given - -- capacity. - - Container.Elements := new Elements_Type (Last); - return; - end if; - - if Capacity <= N then - - -- This is a request to trim back storage, but only to the limit of - -- what's already in the container. (Reserve_Capacity never deletes - -- active elements, it only reclaims excess storage.) - - if N < Container.Elements.EA'Length then - - -- The container is not empty (because the requested capacity is - -- positive, and less than or equal to the container length), and - -- the current length is less than the current capacity, so there - -- is storage available to trim. In this case, we allocate a new - -- internal array having a length that exactly matches the number - -- of items in the container. - - TC_Check (Container.TC); - - declare - subtype Array_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Array_Index_Subtype); - - X : Elements_Access := Container.Elements; - - begin - -- Although we have isolated the old internal array that we're - -- going to deallocate, we don't deallocate it until we have - -- successfully allocated a new one. If there is an exception - -- during allocation (because there is not enough storage), we - -- let it propagate without causing any side-effect. - - Container.Elements := new Elements_Type'(Container.Last, Src); - - -- We have successfully allocated a new internal array (with a - -- smaller length than the old one, and containing a copy of - -- just the active elements in the container), so it is now - -- safe to deallocate the old array. - - Free (X); - end; - end if; - - return; - end if; - - -- The requested capacity is larger than the container length (the - -- number of active elements). Whether this represents a request for - -- expansion or contraction of the current capacity depends on what the - -- current capacity is. - - if Capacity = Container.Elements.EA'Length then - - -- The requested capacity matches the existing capacity, so there's - -- nothing to do here. We treat this case as a no-op, and simply - -- return without checking the busy bit. - - return; - end if; - - -- There is a change in the capacity of a non-empty container, so a new - -- internal array will be allocated. (The length of the new internal - -- array could be less or greater than the old internal array. We know - -- only that the length of the new internal array is greater than the - -- number of active elements in the container.) We must check whether - -- the container is busy before doing anything else. - - TC_Check (Container.TC); - - -- We now allocate a new internal array, having a length different from - -- its current value. - - declare - X : Elements_Access := Container.Elements; - - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - begin - -- We now allocate a new internal array, having a length different - -- from its current value. - - Container.Elements := new Elements_Type (Last); - - -- We have successfully allocated the new internal array, so now we - -- move the existing elements from the existing the old internal - -- array onto the new one. Note that we're just copying access - -- values, to this should not raise any exceptions. - - Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype); - - -- We have moved the elements from the old internal array, so now we - -- can deallocate it. - - Free (X); - end; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Container.Length <= 1 then - return; - end if; - - -- The exception behavior for the vector container must match that for - -- the list container, so we check for cursor tampering here (which will - -- catch more things) instead of for element tampering (which will catch - -- fewer things). It's true that the elements of this vector container - -- could be safely moved around while (say) an iteration is taking place - -- (iteration only increments the busy counter), and so technically all - -- we would need here is a test for element tampering (indicated by the - -- lock counter), that's simply an artifact of our array-based - -- implementation. Logically Reverse_Elements requires a check for - -- cursor tampering. - - TC_Check (Container.TC); - - declare - I : Index_Type; - J : Index_Type; - E : Elements_Array renames Container.Elements.EA; - - begin - I := Index_Type'First; - J := Container.Last; - while I < J loop - declare - EI : constant Element_Access := E (I); - - begin - E (I) := E (J); - E (J) := EI; - end; - - I := I + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Last : Index_Type'Base; - - begin - if Checks and then Position.Container /= null - and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - Last := - (if Position.Container = null or else Position.Index > Container.Last - then Container.Last - else Position.Index); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - return Cursor'(Container'Unrestricted_Access, Indx); - end if; - end loop; - - return No_Element; - end; - end Reverse_Find; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - - Last : constant Index_Type'Base := - Index_Type'Min (Container.Last, Index); - - begin - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) /= null - and then Container.Elements.EA (Indx).all = Item - then - return Indx; - end if; - end loop; - - return No_Index; - end Reverse_Find_Index; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - end Reverse_Iterate; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length (Container : in out Vector; Length : Count_Type) is - Count : constant Count_Type'Base := Container.Length - Length; - - begin - -- Set_Length allows the user to set the length explicitly, instead of - -- implicitly as a side-effect of deletion or insertion. If the - -- requested length is less than the current length, this is equivalent - -- to deleting items from the back end of the vector. If the requested - -- length is greater than the current length, then this is equivalent to - -- inserting "space" (nonce items) at the end. - - if Count >= 0 then - Container.Delete_Last (Count); - - elsif Checks and then Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - - else - Container.Insert_Space (Container.Last + 1, -Count); - end if; - end Set_Length; - - ---------- - -- Swap -- - ---------- - - procedure Swap (Container : in out Vector; I, J : Index_Type) is - begin - if Checks then - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - end if; - - if I = J then - return; - end if; - - TE_Check (Container.TC); - - declare - EI : Element_Access renames Container.Elements.EA (I); - EJ : Element_Access renames Container.Elements.EA (J); - - EI_Copy : constant Element_Access := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - procedure Swap - (Container : in out Vector; - I, J : Cursor) - is - begin - if Checks then - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; - end if; - - if J.Container = null then - raise Constraint_Error with "J cursor has no element"; - end if; - - if I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; - end if; - - if J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; - end if; - end if; - - Swap (Container, I.Index, J.Index); - end Swap; - - --------------- - -- To_Cursor -- - --------------- - - function To_Cursor - (Container : Vector; - Index : Extended_Index) return Cursor - is - begin - if Index not in Index_Type'First .. Container.Last then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Index); - end To_Cursor; - - -------------- - -- To_Index -- - -------------- - - function To_Index (Position : Cursor) return Extended_Index is - begin - if Position.Container = null then - return No_Index; - elsif Position.Index <= Position.Container.Last then - return Position.Index; - else - return No_Index; - end if; - end To_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector (Length : Count_Type) return Vector is - Index : Count_Type'Base; - Last : Index_Type'Base; - Elements : Elements_Access; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Length) < No_Index - then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - Elements := new Elements_Type (Last); - - return Vector'(Controlled with Elements, Last, TC => <>); - end To_Vector; - - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector - is - Index : Count_Type'Base; - Last : Index_Type'Base; - Elements : Elements_Access; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Length) < No_Index - then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - Elements := new Elements_Type (Last); - - -- We use Last as the index of the loop used to populate the internal - -- array with items. In general, we prefer to initialize the loop index - -- immediately prior to entering the loop. However, Last is also used in - -- the exception handler (to reclaim elements that have been allocated, - -- before propagating the exception), and the initialization of Last - -- after entering the block containing the handler confuses some static - -- analysis tools, with respect to whether Last has been properly - -- initialized when the handler executes. So here we initialize our loop - -- variable earlier than we prefer, before entering the block, so there - -- is no ambiguity. - - Last := Index_Type'First; - - declare - -- The element allocator may need an accessibility check in the case - -- where the actual type is class-wide or has access discriminants - -- (see RM 4.8(10.1) and AI12-0035). - - pragma Unsuppress (Accessibility_Check); - - begin - loop - Elements.EA (Last) := new Element_Type'(New_Item); - exit when Last = Elements.Last; - Last := Last + 1; - end loop; - - exception - when others => - for J in Index_Type'First .. Last - 1 loop - Free (Elements.EA (J)); - end loop; - - Free (Elements); - raise; - end; - - return (Controlled with Elements, Last, TC => <>); - end To_Vector; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)) - is - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - if Checks and then Container.Elements.EA (Index) = null then - raise Constraint_Error with "element is null"; - end if; - - Process (Container.Elements.EA (Index).all); - end Update_Element; - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - end if; - - Update_Element (Container, Position.Index, Process); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector) - is - N : constant Count_Type := Length (Container); - - begin - Count_Type'Base'Write (Stream, N); - - if N = 0 then - return; - end if; - - declare - E : Elements_Array renames Container.Elements.EA; - - begin - for Indx in Index_Type'First .. Container.Last loop - if E (Indx) = null then - Boolean'Write (Stream, False); - else - Boolean'Write (Stream, True); - Element_Type'Output (Stream, E (Indx).all); - end if; - end loop; - end; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-coinve.ads b/gcc/ada/a-coinve.ads deleted file mode 100644 index 8be2121..0000000 --- a/gcc/ada/a-coinve.ads +++ /dev/null @@ -1,509 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Index_Type is range <>; - type Element_Type (<>) is private; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Indefinite_Vectors is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - type Vector is tagged private - with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Vector); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Vector : constant Vector; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package Vector_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - overriding function "=" (Left, Right : Vector) return Boolean; - - function To_Vector (Length : Count_Type) return Vector; - - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector; - - function "&" (Left, Right : Vector) return Vector; - - function "&" (Left : Vector; Right : Element_Type) return Vector; - - function "&" (Left : Element_Type; Right : Vector) return Vector; - - function "&" (Left, Right : Element_Type) return Vector; - - function Capacity (Container : Vector) return Count_Type; - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Count_Type); - - function Length (Container : Vector) return Count_Type; - - procedure Set_Length - (Container : in out Vector; - Length : Count_Type); - - function Is_Empty (Container : Vector) return Boolean; - - procedure Clear (Container : in out Vector); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Vector; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Vector; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Vector; - Index : Index_Type) return Reference_Type; - pragma Inline (Reference); - - function To_Cursor - (Container : Vector; - Index : Extended_Index) return Cursor; - - function To_Index (Position : Cursor) return Extended_Index; - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type; - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type); - - procedure Replace_Element - (Container : in out Vector; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Assign (Target : in out Vector; Source : Vector); - - function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; - - procedure Move (Target : in out Vector; Source : in out Vector); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector; - Position : out Cursor); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Vector); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append - (Container : in out Vector; - New_Item : Vector); - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type := 1); - - procedure Delete - (Container : in out Vector; - Position : in out Cursor; - Count : Count_Type := 1); - - procedure Delete_First - (Container : in out Vector; - Count : Count_Type := 1); - - procedure Delete_Last - (Container : in out Vector; - Count : Count_Type := 1); - - procedure Reverse_Elements (Container : in out Vector); - - procedure Swap (Container : in out Vector; I, J : Index_Type); - - procedure Swap (Container : in out Vector; I, J : Cursor); - - function First_Index (Container : Vector) return Index_Type; - - function First (Container : Vector) return Cursor; - - function First_Element (Container : Vector) return Element_Type; - - function Last_Index (Container : Vector) return Extended_Index; - - function Last (Container : Vector) return Cursor; - - function Last_Element (Container : Vector) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index; - - function Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index; - - function Reverse_Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)); - - function Iterate (Container : Vector) - return Vector_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : Vector; - Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'class; - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)); - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : Vector) return Boolean; - - procedure Sort (Container : in out Vector); - - procedure Merge (Target : in out Vector; Source : in out Vector); - - end Generic_Sorting; - -private - - pragma Inline (Append); - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Query_Element); - pragma Inline (Update_Element); - pragma Inline (Replace_Element); - pragma Inline (Is_Empty); - pragma Inline (Contains); - pragma Inline (Next); - pragma Inline (Previous); - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - type Element_Access is access Element_Type; - - type Elements_Array is array (Index_Type range <>) of Element_Access; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Elements_Type (Last : Extended_Index) is limited record - EA : Elements_Array (Index_Type'First .. Last); - end record; - - type Elements_Access is access all Elements_Type; - - use Finalization; - use Streams; - - type Vector is new Controlled with record - Elements : Elements_Access := null; - Last : Extended_Index := No_Index; - TC : aliased Tamper_Counts; - end record; - - overriding procedure Adjust (Container : in out Vector); - overriding procedure Finalize (Container : in out Vector); - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector); - - for Vector'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector); - - for Vector'Read use Read; - - type Vector_Access is access all Vector; - for Vector_Access'Storage_Size use 0; - - type Cursor is record - Container : Vector_Access; - Index : Index_Type := Index_Type'First; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Vector'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - No_Element : constant Cursor := Cursor'(null, Index_Type'First); - - Empty_Vector : constant Vector := (Controlled with others => <>); - - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/a-colien.adb b/gcc/ada/a-colien.adb deleted file mode 100644 index bd2f9d2..0000000 --- a/gcc/ada/a-colien.adb +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; - -package body Ada.Command_Line.Environment is - - ----------------------- - -- Environment_Count -- - ----------------------- - - function Environment_Count return Natural is - function Env_Count return Natural; - pragma Import (C, Env_Count, "__gnat_env_count"); - - begin - return Env_Count; - end Environment_Count; - - ----------------------- - -- Environment_Value -- - ----------------------- - - function Environment_Value (Number : Positive) return String is - procedure Fill_Env (E : System.Address; Env_Num : Integer); - pragma Import (C, Fill_Env, "__gnat_fill_env"); - - function Len_Env (Env_Num : Integer) return Integer; - pragma Import (C, Len_Env, "__gnat_len_env"); - - begin - if Number > Environment_Count then - raise Constraint_Error; - end if; - - declare - Env : aliased String (1 .. Len_Env (Number - 1)); - begin - Fill_Env (Env'Address, Number - 1); - return Env; - end; - end Environment_Value; - -end Ada.Command_Line.Environment; diff --git a/gcc/ada/a-colien.ads b/gcc/ada/a-colien.ads deleted file mode 100644 index 224e70e..0000000 --- a/gcc/ada/a-colien.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: Services offered by this package are guaranteed to be platform --- independent as long as no call to GNAT.OS_Lib.Setenv or to C putenv --- routine is done. On some platforms the services below will report new --- environment variables (e.g. Windows) on some others it will not --- (e.g. GNU/Linux and Solaris). - -package Ada.Command_Line.Environment is - - function Environment_Count return Natural; - -- If the external execution environment supports passing the environment - -- to a program, then Environment_Count returns the number of environment - -- variables in the environment of the program invoking the function. - -- Otherwise it returns 0. And that's a lot of environment. - - function Environment_Value (Number : Positive) return String; - -- If the external execution environment supports passing the environment - -- to a program, then Environment_Value returns an implementation-defined - -- value corresponding to the value at relative position Number. If Number - -- is outside the range 1 .. Environment_Count, then Constraint_Error is - -- propagated. - -- - -- in GNAT: Corresponds to envp [n-1] (for n > 0) in C. - -end Ada.Command_Line.Environment; diff --git a/gcc/ada/a-colire.adb b/gcc/ada/a-colire.adb deleted file mode 100644 index 31a2855..0000000 --- a/gcc/ada/a-colire.adb +++ /dev/null @@ -1,124 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E . R E M O V E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Command_Line.Remove is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Initialize; - -- Initialize the Remove_Count and Remove_Args variables - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - if Remove_Args = null then - Remove_Count := Argument_Count; - Remove_Args := new Arg_Nums (1 .. Argument_Count); - - for J in Remove_Args'Range loop - Remove_Args (J) := J; - end loop; - end if; - end Initialize; - - --------------------- - -- Remove_Argument -- - --------------------- - - procedure Remove_Argument (Number : Positive) is - begin - Initialize; - - if Number > Remove_Count then - raise Constraint_Error; - end if; - - Remove_Count := Remove_Count - 1; - - for J in Number .. Remove_Count loop - Remove_Args (J) := Remove_Args (J + 1); - end loop; - end Remove_Argument; - - procedure Remove_Argument (Argument : String) is - begin - for J in reverse 1 .. Argument_Count loop - if Argument = Ada.Command_Line.Argument (J) then - Remove_Argument (J); - end if; - end loop; - end Remove_Argument; - - ---------------------- - -- Remove_Arguments -- - ---------------------- - - procedure Remove_Arguments (From : Positive; To : Natural) is - begin - Initialize; - - if From > Remove_Count - or else To > Remove_Count - then - raise Constraint_Error; - end if; - - if To >= From then - Remove_Count := Remove_Count - (To - From + 1); - - for J in From .. Remove_Count loop - Remove_Args (J) := Remove_Args (J + (To - From + 1)); - end loop; - end if; - end Remove_Arguments; - - procedure Remove_Arguments (Argument_Prefix : String) is - begin - for J in reverse 1 .. Argument_Count loop - declare - Arg : constant String := Argument (J); - - begin - if Arg'Length >= Argument_Prefix'Length - and then Arg (1 .. Argument_Prefix'Length) = Argument_Prefix - then - Remove_Argument (J); - end if; - end; - end loop; - end Remove_Arguments; - -end Ada.Command_Line.Remove; diff --git a/gcc/ada/a-colire.ads b/gcc/ada/a-colire.ads deleted file mode 100644 index a454509..0000000 --- a/gcc/ada/a-colire.ads +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E . R E M O V E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is intended to be used in conjunction with its parent unit, --- Ada.Command_Line. It provides facilities for logically removing arguments --- from the command line, so that subsequent calls to Argument_Count and --- Argument will reflect the removals. - --- For example, if the original command line has three arguments A B C, so --- that Argument_Count is initially three, then after removing B, the second --- argument, Argument_Count will be 2, and Argument (2) will return C. - -package Ada.Command_Line.Remove is - pragma Preelaborate; - - procedure Remove_Argument (Number : Positive); - -- Removes the argument identified by Number, which must be in the - -- range 1 .. Argument_Count (i.e. an in range argument number which - -- reflects removals). If Number is out of range Constraint_Error - -- will be raised. - -- - -- Note: the numbering of arguments greater than Number is affected - -- by the call. If you need a loop through the arguments, removing - -- some as you go, run the loop in reverse to avoid confusion from - -- this renumbering: - -- - -- for J in reverse 1 .. Argument_Count loop - -- if Should_Remove (Arguments (J)) then - -- Remove_Argument (J); - -- end if; - -- end loop; - -- - -- Reversing the loop in this manner avoids the confusion. - - procedure Remove_Arguments (From : Positive; To : Natural); - -- Removes arguments in the given From..To range. From must be in the - -- range 1 .. Argument_Count and To in the range 0 .. Argument_Count. - -- Constraint_Error is raised if either argument is out of range. If - -- To is less than From, then the call has no effect. - - procedure Remove_Argument (Argument : String); - -- Removes the argument which matches the given string Argument. Has - -- no effect if no argument matches the string. If more than one - -- argument matches the string, all are removed. - - procedure Remove_Arguments (Argument_Prefix : String); - -- Removes all arguments whose prefix matches Argument_Prefix. Has - -- no effect if no argument matches the string. For example a call - -- to Remove_Arguments ("--") removes all arguments starting with --. - -end Ada.Command_Line.Remove; diff --git a/gcc/ada/a-comlin.adb b/gcc/ada/a-comlin.adb deleted file mode 100644 index a555410..0000000 --- a/gcc/ada/a-comlin.adb +++ /dev/null @@ -1,123 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; - -package body Ada.Command_Line is - - function Arg_Count return Natural; - pragma Import (C, Arg_Count, "__gnat_arg_count"); - - procedure Fill_Arg (A : System.Address; Arg_Num : Integer); - pragma Import (C, Fill_Arg, "__gnat_fill_arg"); - - function Len_Arg (Arg_Num : Integer) return Integer; - pragma Import (C, Len_Arg, "__gnat_len_arg"); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Initialized return Boolean; - -- Checks to ensure that gnat_argc and gnat_argv have been properly - -- initialized. Returns false if not, or if argv / argc are - -- unsupported on the target (e.g. VxWorks). - - -------------- - -- Argument -- - -------------- - - function Argument (Number : Positive) return String is - begin - if Number > Argument_Count then - raise Constraint_Error; - end if; - - declare - Num : constant Positive := - (if Remove_Args = null then Number else Remove_Args (Number)); - Arg : aliased String (1 .. Len_Arg (Num)); - begin - Fill_Arg (Arg'Address, Num); - return Arg; - end; - end Argument; - - -------------------- - -- Argument_Count -- - -------------------- - - function Argument_Count return Natural is - begin - if not Initialized then - -- RM A.15 (11) - return 0; - end if; - - if Remove_Args = null then - return Arg_Count - 1; - else - return Remove_Count; - end if; - end Argument_Count; - - ----------------- - -- Initialized -- - ----------------- - - function Initialized return Boolean is - gnat_argv : System.Address; - pragma Import (C, gnat_argv, "gnat_argv"); - - begin - return gnat_argv /= System.Null_Address; - end Initialized; - - ------------------ - -- Command_Name -- - ------------------ - - function Command_Name return String is - begin - if not Initialized then - return ""; - end if; - - declare - Arg : aliased String (1 .. Len_Arg (0)); - - begin - Fill_Arg (Arg'Address, 0); - return Arg; - end; - end Command_Name; - -end Ada.Command_Line; diff --git a/gcc/ada/a-comlin.ads b/gcc/ada/a-comlin.ads deleted file mode 100644 index c4eecef..0000000 --- a/gcc/ada/a-comlin.ads +++ /dev/null @@ -1,144 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M M A N D _ L I N E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Command_Line is - pragma Preelaborate; - - function Argument_Count return Natural; - -- If the external execution environment supports passing arguments to a - -- program, then Argument_Count returns the number of arguments passed to - -- the program invoking the function. Otherwise it return 0. - -- - -- In GNAT: Corresponds to (argc - 1) in C. - - pragma Assertion_Policy (Pre => Ignore); - -- We need to ignore the precondition of Argument, below, so that we don't - -- raise Assertion_Error. The body raises Constraint_Error. It would be - -- cleaner to add "or else raise Constraint_Error" to the precondition, but - -- SPARK does not yet support raise expressions. - - function Argument (Number : Positive) return String with - Pre => Number <= Argument_Count; - -- If the external execution environment supports passing arguments to - -- a program, then Argument returns an implementation-defined value - -- corresponding to the argument at relative position Number. If Number - -- is outside the range 1 .. Argument_Count, then Constraint_Error is - -- propagated. - -- - -- in GNAT: Corresponds to argv [n] (for n > 0) in C. - - function Command_Name return String; - -- If the external execution environment supports passing arguments to - -- a program, then Command_Name returns an implementation-defined value - -- corresponding to the name of the command invoking the program. - -- Otherwise Command_Name returns the null string. - -- - -- in GNAT: Corresponds to argv [0] in C. - - type Exit_Status is new Integer; - - Success : constant Exit_Status; - Failure : constant Exit_Status; - - procedure Set_Exit_Status (Code : Exit_Status); - - ------------------------------------ - -- Note on Interface Requirements -- - ------------------------------------ - - -- Services in this package are not supported during the elaboration of an - -- auto-initialized Stand-Alone Library. - - -- If the main program is in Ada, this package works as specified without - -- any other work than the normal steps of WITH'ing the package and then - -- calling the desired routines. - - -- If the main program is not in Ada, then the information must be made - -- available for this package to work correctly. In particular, it is - -- required that the global variable "gnat_argc" contain the number of - -- arguments, and that the global variable "gnat_argv" points to an - -- array of null-terminated strings, the first entry being the command - -- name, and the remaining entries being the command arguments. - - -- These correspond to the normal argc/argv variables passed to a C - -- main program, and the following is an example of a complete C main - -- program that stores the required information: - - -- main(int argc, char **argv, char **envp) - -- { - -- extern int gnat_argc; - -- extern char **gnat_argv; - -- extern char **gnat_envp; - -- gnat_argc = argc; - -- gnat_argv = argv; - -- gnat_envp = envp; - - -- adainit(); - -- adamain(); - -- adafinal(); - -- } - - -- The assignment statements ensure that the necessary information is - -- available for finding the command name and command line arguments. - -private - Success : constant Exit_Status := 0; - Failure : constant Exit_Status := 1; - - -- The following locations support the operation of the package - -- Ada.Command_Line.Remove, which provides facilities for logically - -- removing arguments from the command line. If one of the remove - -- procedures is called in this unit, then Remove_Args/Remove_Count - -- are set to indicate which arguments are removed. If no such calls - -- have been made, then Remove_Args is null. - - Remove_Count : Natural; - -- Number of arguments reflecting removals. Not defined unless - -- Remove_Args is non-null. - - type Arg_Nums is array (Positive range <>) of Positive; - type Arg_Nums_Ptr is access Arg_Nums; - -- An array that maps logical argument numbers (reflecting removal) - -- to physical argument numbers (e.g. if the first argument has been - -- removed, but not the second, then Arg_Nums (1) will be set to 2. - - Remove_Args : Arg_Nums_Ptr := null; - -- Left set to null if no remove calls have been made, otherwise set - -- to point to an appropriate mapping array. Only the first Remove_Count - -- elements are relevant. - - pragma Import (C, Set_Exit_Status, "__gnat_set_exit_status"); - -end Ada.Command_Line; diff --git a/gcc/ada/a-comutr.adb b/gcc/ada/a-comutr.adb deleted file mode 100644 index 7804b0f..0000000 --- a/gcc/ada/a-comutr.adb +++ /dev/null @@ -1,2676 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Multiway_Trees is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - -------------------- - -- Root_Iterator -- - -------------------- - - type Root_Iterator is abstract new Limited_Controlled and - Tree_Iterator_Interfaces.Forward_Iterator with - record - Container : Tree_Access; - Subtree : Tree_Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Root_Iterator); - - ----------------------- - -- Subtree_Iterator -- - ----------------------- - - -- ??? these headers are a bit odd, but for sure they do not substitute - -- for documenting things, what *is* a Subtree_Iterator? - - type Subtree_Iterator is new Root_Iterator with null record; - - overriding function First (Object : Subtree_Iterator) return Cursor; - - overriding function Next - (Object : Subtree_Iterator; - Position : Cursor) return Cursor; - - --------------------- - -- Child_Iterator -- - --------------------- - - type Child_Iterator is new Root_Iterator and - Tree_Iterator_Interfaces.Reversible_Iterator with null record - with Disable_Controlled => not T_Check; - - overriding function First (Object : Child_Iterator) return Cursor; - - overriding function Next - (Object : Child_Iterator; - Position : Cursor) return Cursor; - - overriding function Last (Object : Child_Iterator) return Cursor; - - overriding function Previous - (Object : Child_Iterator; - Position : Cursor) return Cursor; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Root_Node (Container : Tree) return Tree_Node_Access; - - procedure Deallocate_Node is - new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access); - - procedure Deallocate_Children - (Subtree : Tree_Node_Access; - Count : in out Count_Type); - - procedure Deallocate_Subtree - (Subtree : in out Tree_Node_Access; - Count : in out Count_Type); - - function Equal_Children - (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; - - function Equal_Subtree - (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; - - procedure Iterate_Children - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)); - - procedure Iterate_Subtree - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)); - - procedure Copy_Children - (Source : Children_Type; - Parent : Tree_Node_Access; - Count : in out Count_Type); - - procedure Copy_Subtree - (Source : Tree_Node_Access; - Parent : Tree_Node_Access; - Target : out Tree_Node_Access; - Count : in out Count_Type); - - function Find_In_Children - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access; - - function Find_In_Subtree - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access; - - function Child_Count (Children : Children_Type) return Count_Type; - - function Subtree_Node_Count - (Subtree : Tree_Node_Access) return Count_Type; - - function Is_Reachable (From, To : Tree_Node_Access) return Boolean; - - procedure Remove_Subtree (Subtree : Tree_Node_Access); - - procedure Insert_Subtree_Node - (Subtree : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access); - - procedure Insert_Subtree_List - (First : Tree_Node_Access; - Last : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access); - - procedure Splice_Children - (Target_Parent : Tree_Node_Access; - Before : Tree_Node_Access; - Source_Parent : Tree_Node_Access); - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Tree) return Boolean is - begin - return Equal_Children (Root_Node (Left), Root_Node (Right)); - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Tree) is - Source : constant Children_Type := Container.Root.Children; - Source_Count : constant Count_Type := Container.Count; - Target_Count : Count_Type; - - begin - -- We first restore the target container to its default-initialized - -- state, before we attempt any allocation, to ensure that invariants - -- are preserved in the event that the allocation fails. - - Container.Root.Children := Children_Type'(others => null); - Zero_Counts (Container.TC); - Container.Count := 0; - - -- Copy_Children returns a count of the number of nodes that it - -- allocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Copy_Children. - - Target_Count := 0; - - -- Now we attempt the allocation of subtrees. The invariants are - -- satisfied even if the allocation fails. - - Copy_Children (Source, Root_Node (Container), Target_Count); - pragma Assert (Target_Count = Source_Count); - - Container.Count := Source_Count; - end Adjust; - - ------------------- - -- Ancestor_Find -- - ------------------- - - function Ancestor_Find - (Position : Cursor; - Item : Element_Type) return Cursor - is - R, N : Tree_Node_Access; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Commented-out pending official ruling from ARG. ??? - - -- if Position.Container /= Container'Unrestricted_Access then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - - -- AI-0136 says to raise PE if Position equals the root node. This does - -- not seem correct, as this value is just the limiting condition of the - -- search. For now we omit this check, pending a ruling from the ARG.??? - - -- if Checks and then Is_Root (Position) then - -- raise Program_Error with "Position cursor designates root"; - -- end if; - - R := Root_Node (Position.Container.all); - N := Position.Node; - while N /= R loop - if N.Element = Item then - return Cursor'(Position.Container, N); - end if; - - N := N.Parent; - end loop; - - return No_Element; - end Ancestor_Find; - - ------------------ - -- Append_Child -- - ------------------ - - procedure Append_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - First : Tree_Node_Access; - Last : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - First := new Tree_Node_Type'(Parent => Parent.Node, - Element => New_Item, - others => <>); - - Last := First; - for J in Count_Type'(2) .. Count loop - - -- Reclaim other nodes if Storage_Error. ??? - - Last.Next := new Tree_Node_Type'(Parent => Parent.Node, - Prev => Last, - Element => New_Item, - others => <>); - - Last := Last.Next; - end loop; - - Insert_Subtree_List - (First => First, - Last => Last, - Parent => Parent.Node, - Before => null); -- null means "insert at end of list" - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Container.Count := Container.Count + Count; - end Append_Child; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Tree; Source : Tree) is - Source_Count : constant Count_Type := Source.Count; - Target_Count : Count_Type; - - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; -- checks busy bit - - -- Copy_Children returns the number of nodes that it allocates, but it - -- does this by incrementing the count value passed in, so we must - -- initialize the count before calling Copy_Children. - - Target_Count := 0; - - -- Note that Copy_Children inserts the newly-allocated children into - -- their parent list only after the allocation of all the children has - -- succeeded. This preserves invariants even if the allocation fails. - - Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count); - pragma Assert (Target_Count = Source_Count); - - Target.Count := Source_Count; - end Assign; - - ----------------- - -- Child_Count -- - ----------------- - - function Child_Count (Parent : Cursor) return Count_Type is - begin - return (if Parent = No_Element - then 0 else Child_Count (Parent.Node.Children)); - end Child_Count; - - function Child_Count (Children : Children_Type) return Count_Type is - Result : Count_Type; - Node : Tree_Node_Access; - - begin - Result := 0; - Node := Children.First; - while Node /= null loop - Result := Result + 1; - Node := Node.Next; - end loop; - - return Result; - end Child_Count; - - ----------------- - -- Child_Depth -- - ----------------- - - function Child_Depth (Parent, Child : Cursor) return Count_Type is - Result : Count_Type; - N : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Child = No_Element then - raise Constraint_Error with "Child cursor has no element"; - end if; - - if Checks and then Parent.Container /= Child.Container then - raise Program_Error with "Parent and Child in different containers"; - end if; - - Result := 0; - N := Child.Node; - while N /= Parent.Node loop - Result := Result + 1; - N := N.Parent; - - if Checks and then N = null then - raise Program_Error with "Parent is not ancestor of Child"; - end if; - end loop; - - return Result; - end Child_Depth; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Tree) is - Container_Count, Children_Count : Count_Type; - - begin - TC_Check (Container.TC); - - -- We first set the container count to 0, in order to preserve - -- invariants in case the deallocation fails. (This works because - -- Deallocate_Children immediately removes the children from their - -- parent, and then does the actual deallocation.) - - Container_Count := Container.Count; - Container.Count := 0; - - -- Deallocate_Children returns the number of nodes that it deallocates, - -- but it does this by incrementing the count value that is passed in, - -- so we must first initialize the count return value before calling it. - - Children_Count := 0; - - -- See comment above. Deallocate_Children immediately removes the - -- children list from their parent node (here, the root of the tree), - -- and only after that does it attempt the actual deallocation. So even - -- if the deallocation fails, the representation invariants for the tree - -- are preserved. - - Deallocate_Children (Root_Node (Container), Children_Count); - pragma Assert (Children_Count = Container_Count); - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - C : Tree renames Position.Container.all; - TC : constant Tamper_Counts_Access := - C.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Tree; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Tree) return Tree is - begin - return Target : Tree do - Copy_Children - (Source => Source.Root.Children, - Parent => Root_Node (Target), - Count => Target.Count); - - pragma Assert (Target.Count = Source.Count); - end return; - end Copy; - - ------------------- - -- Copy_Children -- - ------------------- - - procedure Copy_Children - (Source : Children_Type; - Parent : Tree_Node_Access; - Count : in out Count_Type) - is - pragma Assert (Parent /= null); - pragma Assert (Parent.Children.First = null); - pragma Assert (Parent.Children.Last = null); - - CC : Children_Type; - C : Tree_Node_Access; - - begin - -- We special-case the first allocation, in order to establish the - -- representation invariants for type Children_Type. - - C := Source.First; - - if C = null then - return; - end if; - - Copy_Subtree - (Source => C, - Parent => Parent, - Target => CC.First, - Count => Count); - - CC.Last := CC.First; - - -- The representation invariants for the Children_Type list have been - -- established, so we can now copy the remaining children of Source. - - C := C.Next; - while C /= null loop - Copy_Subtree - (Source => C, - Parent => Parent, - Target => CC.Last.Next, - Count => Count); - - CC.Last.Next.Prev := CC.Last; - CC.Last := CC.Last.Next; - - C := C.Next; - end loop; - - -- Add the newly-allocated children to their parent list only after the - -- allocation has succeeded, so as to preserve invariants of the parent. - - Parent.Children := CC; - end Copy_Children; - - ------------------ - -- Copy_Subtree -- - ------------------ - - procedure Copy_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : Cursor) - is - Target_Subtree : Tree_Node_Access; - Target_Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Target'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Source = No_Element then - return; - end if; - - if Checks and then Is_Root (Source) then - raise Constraint_Error with "Source cursor designates root"; - end if; - - -- Copy_Subtree returns a count of the number of nodes that it - -- allocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Copy_Subtree. - - Target_Count := 0; - - Copy_Subtree - (Source => Source.Node, - Parent => Parent.Node, - Target => Target_Subtree, - Count => Target_Count); - - pragma Assert (Target_Subtree /= null); - pragma Assert (Target_Subtree.Parent = Parent.Node); - pragma Assert (Target_Count >= 1); - - Insert_Subtree_Node - (Subtree => Target_Subtree, - Parent => Parent.Node, - Before => Before.Node); - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Target.Count := Target.Count + Target_Count; - end Copy_Subtree; - - procedure Copy_Subtree - (Source : Tree_Node_Access; - Parent : Tree_Node_Access; - Target : out Tree_Node_Access; - Count : in out Count_Type) - is - begin - Target := new Tree_Node_Type'(Element => Source.Element, - Parent => Parent, - others => <>); - - Count := Count + 1; - - Copy_Children - (Source => Source.Children, - Parent => Target, - Count => Count); - end Copy_Subtree; - - ------------------------- - -- Deallocate_Children -- - ------------------------- - - procedure Deallocate_Children - (Subtree : Tree_Node_Access; - Count : in out Count_Type) - is - pragma Assert (Subtree /= null); - - CC : Children_Type := Subtree.Children; - C : Tree_Node_Access; - - begin - -- We immediately remove the children from their parent, in order to - -- preserve invariants in case the deallocation fails. - - Subtree.Children := Children_Type'(others => null); - - while CC.First /= null loop - C := CC.First; - CC.First := C.Next; - - Deallocate_Subtree (C, Count); - end loop; - end Deallocate_Children; - - ------------------------ - -- Deallocate_Subtree -- - ------------------------ - - procedure Deallocate_Subtree - (Subtree : in out Tree_Node_Access; - Count : in out Count_Type) - is - begin - Deallocate_Children (Subtree, Count); - Deallocate_Node (Subtree); - Count := Count + 1; - end Deallocate_Subtree; - - --------------------- - -- Delete_Children -- - --------------------- - - procedure Delete_Children - (Container : in out Tree; - Parent : Cursor) - is - Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - TC_Check (Container.TC); - - -- Deallocate_Children returns a count of the number of nodes that it - -- deallocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Deallocate_Children. - - Count := 0; - - Deallocate_Children (Parent.Node, Count); - pragma Assert (Count <= Container.Count); - - Container.Count := Container.Count - Count; - end Delete_Children; - - ----------------- - -- Delete_Leaf -- - ----------------- - - procedure Delete_Leaf - (Container : in out Tree; - Position : in out Cursor) - is - X : Tree_Node_Access; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Checks and then not Is_Leaf (Position) then - raise Constraint_Error with "Position cursor does not designate leaf"; - end if; - - TC_Check (Container.TC); - - X := Position.Node; - Position := No_Element; - - -- Restore represention invariants before attempting the actual - -- deallocation. - - Remove_Subtree (X); - Container.Count := Container.Count - 1; - - -- It is now safe to attempt the deallocation. This leaf node has been - -- disassociated from the tree, so even if the deallocation fails, - -- representation invariants will remain satisfied. - - Deallocate_Node (X); - end Delete_Leaf; - - -------------------- - -- Delete_Subtree -- - -------------------- - - procedure Delete_Subtree - (Container : in out Tree; - Position : in out Cursor) - is - X : Tree_Node_Access; - Count : Count_Type; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - TC_Check (Container.TC); - - X := Position.Node; - Position := No_Element; - - -- Here is one case where a deallocation failure can result in the - -- violation of a representation invariant. We disassociate the subtree - -- from the tree now, but we only decrement the total node count after - -- we attempt the deallocation. However, if the deallocation fails, the - -- total node count will not get decremented. - - -- One way around this dilemma is to count the nodes in the subtree - -- before attempt to delete the subtree, but that is an O(n) operation, - -- so it does not seem worth it. - - -- Perhaps this is much ado about nothing, since the only way - -- deallocation can fail is if Controlled Finalization fails: this - -- propagates Program_Error so all bets are off anyway. ??? - - Remove_Subtree (X); - - -- Deallocate_Subtree returns a count of the number of nodes that it - -- deallocates, but it works by incrementing the value that is passed - -- in. We must therefore initialize the count value before calling - -- Deallocate_Subtree. - - Count := 0; - - Deallocate_Subtree (X, Count); - pragma Assert (Count <= Container.Count); - - -- See comments above. We would prefer to do this sooner, but there's no - -- way to satisfy that goal without a potentially severe execution - -- penalty. - - Container.Count := Container.Count - Count; - end Delete_Subtree; - - ----------- - -- Depth -- - ----------- - - function Depth (Position : Cursor) return Count_Type is - Result : Count_Type; - N : Tree_Node_Access; - - begin - Result := 0; - N := Position.Node; - while N /= null loop - N := N.Parent; - Result := Result + 1; - end loop; - - return Result; - end Depth; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Node = Root_Node (Position.Container.all) - then - raise Program_Error with "Position cursor designates root"; - end if; - - return Position.Node.Element; - end Element; - - -------------------- - -- Equal_Children -- - -------------------- - - function Equal_Children - (Left_Subtree : Tree_Node_Access; - Right_Subtree : Tree_Node_Access) return Boolean - is - Left_Children : Children_Type renames Left_Subtree.Children; - Right_Children : Children_Type renames Right_Subtree.Children; - - L, R : Tree_Node_Access; - - begin - if Child_Count (Left_Children) /= Child_Count (Right_Children) then - return False; - end if; - - L := Left_Children.First; - R := Right_Children.First; - while L /= null loop - if not Equal_Subtree (L, R) then - return False; - end if; - - L := L.Next; - R := R.Next; - end loop; - - return True; - end Equal_Children; - - ------------------- - -- Equal_Subtree -- - ------------------- - - function Equal_Subtree - (Left_Position : Cursor; - Right_Position : Cursor) return Boolean - is - begin - if Checks and then Left_Position = No_Element then - raise Constraint_Error with "Left cursor has no element"; - end if; - - if Checks and then Right_Position = No_Element then - raise Constraint_Error with "Right cursor has no element"; - end if; - - if Left_Position = Right_Position then - return True; - end if; - - if Is_Root (Left_Position) then - if not Is_Root (Right_Position) then - return False; - end if; - - return Equal_Children (Left_Position.Node, Right_Position.Node); - end if; - - if Is_Root (Right_Position) then - return False; - end if; - - return Equal_Subtree (Left_Position.Node, Right_Position.Node); - end Equal_Subtree; - - function Equal_Subtree - (Left_Subtree : Tree_Node_Access; - Right_Subtree : Tree_Node_Access) return Boolean - is - begin - if Left_Subtree.Element /= Right_Subtree.Element then - return False; - end if; - - return Equal_Children (Left_Subtree, Right_Subtree); - end Equal_Subtree; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Root_Iterator) is - begin - Unbusy (Object.Container.TC); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Tree; - Item : Element_Type) return Cursor - is - N : constant Tree_Node_Access := - Find_In_Children (Root_Node (Container), Item); - begin - if N = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, N); - end if; - end Find; - - ----------- - -- First -- - ----------- - - overriding function First (Object : Subtree_Iterator) return Cursor is - begin - if Object.Subtree = Root_Node (Object.Container.all) then - return First_Child (Root (Object.Container.all)); - else - return Cursor'(Object.Container, Object.Subtree); - end if; - end First; - - overriding function First (Object : Child_Iterator) return Cursor is - begin - return First_Child (Cursor'(Object.Container, Object.Subtree)); - end First; - - ----------------- - -- First_Child -- - ----------------- - - function First_Child (Parent : Cursor) return Cursor is - Node : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - Node := Parent.Node.Children.First; - - if Node = null then - return No_Element; - end if; - - return Cursor'(Parent.Container, Node); - end First_Child; - - ------------------------- - -- First_Child_Element -- - ------------------------- - - function First_Child_Element (Parent : Cursor) return Element_Type is - begin - return Element (First_Child (Parent)); - end First_Child_Element; - - ---------------------- - -- Find_In_Children -- - ---------------------- - - function Find_In_Children - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access - is - N, Result : Tree_Node_Access; - - begin - N := Subtree.Children.First; - while N /= null loop - Result := Find_In_Subtree (N, Item); - - if Result /= null then - return Result; - end if; - - N := N.Next; - end loop; - - return null; - end Find_In_Children; - - --------------------- - -- Find_In_Subtree -- - --------------------- - - function Find_In_Subtree - (Position : Cursor; - Item : Element_Type) return Cursor - is - Result : Tree_Node_Access; - - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Commented out pending official ruling by ARG. ??? - - -- if Checks and then - -- Position.Container /= Container'Unrestricted_Access - -- then - -- raise Program_Error with "Position cursor not in container"; - -- end if; - - Result := - (if Is_Root (Position) - then Find_In_Children (Position.Node, Item) - else Find_In_Subtree (Position.Node, Item)); - - if Result = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Result); - end Find_In_Subtree; - - function Find_In_Subtree - (Subtree : Tree_Node_Access; - Item : Element_Type) return Tree_Node_Access - is - begin - if Subtree.Element = Item then - return Subtree; - end if; - - return Find_In_Children (Subtree, Item); - end Find_In_Subtree; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return (if Position = No_Element then False - else Position.Node.Parent /= null); - end Has_Element; - - ------------------ - -- Insert_Child -- - ------------------ - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Position : Cursor; - pragma Unreferenced (Position); - - begin - Insert_Child (Container, Parent, Before, New_Item, Position, Count); - end Insert_Child; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - First : Tree_Node_Access; - Last : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Parent cursor not parent of Before"; - end if; - end if; - - if Count = 0 then - Position := No_Element; -- Need ruling from ARG ??? - return; - end if; - - TC_Check (Container.TC); - - First := new Tree_Node_Type'(Parent => Parent.Node, - Element => New_Item, - others => <>); - - Last := First; - for J in Count_Type'(2) .. Count loop - - -- Reclaim other nodes if Storage_Error. ??? - - Last.Next := new Tree_Node_Type'(Parent => Parent.Node, - Prev => Last, - Element => New_Item, - others => <>); - - Last := Last.Next; - end loop; - - Insert_Subtree_List - (First => First, - Last => Last, - Parent => Parent.Node, - Before => Before.Node); - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Container.Count := Container.Count + Count; - - Position := Cursor'(Parent.Container, First); - end Insert_Child; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - First : Tree_Node_Access; - Last : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Parent cursor not parent of Before"; - end if; - end if; - - if Count = 0 then - Position := No_Element; -- Need ruling from ARG ??? - return; - end if; - - TC_Check (Container.TC); - - First := new Tree_Node_Type'(Parent => Parent.Node, - Element => <>, - others => <>); - - Last := First; - for J in Count_Type'(2) .. Count loop - - -- Reclaim other nodes if Storage_Error. ??? - - Last.Next := new Tree_Node_Type'(Parent => Parent.Node, - Prev => Last, - Element => <>, - others => <>); - - Last := Last.Next; - end loop; - - Insert_Subtree_List - (First => First, - Last => Last, - Parent => Parent.Node, - Before => Before.Node); - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Container.Count := Container.Count + Count; - - Position := Cursor'(Parent.Container, First); - end Insert_Child; - - ------------------------- - -- Insert_Subtree_List -- - ------------------------- - - procedure Insert_Subtree_List - (First : Tree_Node_Access; - Last : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access) - is - pragma Assert (Parent /= null); - C : Children_Type renames Parent.Children; - - begin - -- This is a simple utility operation to insert a list of nodes (from - -- First..Last) as children of Parent. The Before node specifies where - -- the new children should be inserted relative to the existing - -- children. - - if First = null then - pragma Assert (Last = null); - return; - end if; - - pragma Assert (Last /= null); - pragma Assert (Before = null or else Before.Parent = Parent); - - if C.First = null then - C.First := First; - C.First.Prev := null; - C.Last := Last; - C.Last.Next := null; - - elsif Before = null then -- means "insert after existing nodes" - C.Last.Next := First; - First.Prev := C.Last; - C.Last := Last; - C.Last.Next := null; - - elsif Before = C.First then - Last.Next := C.First; - C.First.Prev := Last; - C.First := First; - C.First.Prev := null; - - else - Before.Prev.Next := First; - First.Prev := Before.Prev; - Last.Next := Before; - Before.Prev := Last; - end if; - end Insert_Subtree_List; - - ------------------------- - -- Insert_Subtree_Node -- - ------------------------- - - procedure Insert_Subtree_Node - (Subtree : Tree_Node_Access; - Parent : Tree_Node_Access; - Before : Tree_Node_Access) - is - begin - -- This is a simple wrapper operation to insert a single child into the - -- Parent's children list. - - Insert_Subtree_List - (First => Subtree, - Last => Subtree, - Parent => Parent, - Before => Before); - end Insert_Subtree_Node; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Tree) return Boolean is - begin - return Container.Root.Children.First = null; - end Is_Empty; - - ------------- - -- Is_Leaf -- - ------------- - - function Is_Leaf (Position : Cursor) return Boolean is - begin - return (if Position = No_Element then False - else Position.Node.Children.First = null); - end Is_Leaf; - - ------------------ - -- Is_Reachable -- - ------------------ - - function Is_Reachable (From, To : Tree_Node_Access) return Boolean is - pragma Assert (From /= null); - pragma Assert (To /= null); - - N : Tree_Node_Access; - - begin - N := From; - while N /= null loop - if N = To then - return True; - end if; - - N := N.Parent; - end loop; - - return False; - end Is_Reachable; - - ------------- - -- Is_Root -- - ------------- - - function Is_Root (Position : Cursor) return Boolean is - begin - return (if Position.Container = null then False - else Position = Root (Position.Container.all)); - end Is_Root; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Tree; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - Iterate_Children - (Container => Container'Unrestricted_Access, - Subtree => Root_Node (Container), - Process => Process); - end Iterate; - - function Iterate (Container : Tree) - return Tree_Iterator_Interfaces.Forward_Iterator'Class - is - begin - return Iterate_Subtree (Root (Container)); - end Iterate; - - ---------------------- - -- Iterate_Children -- - ---------------------- - - procedure Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)) - is - C : Tree_Node_Access; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - C := Parent.Node.Children.First; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Next; - end loop; - end Iterate_Children; - - procedure Iterate_Children - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)) - is - Node : Tree_Node_Access; - - begin - -- This is a helper function to recursively iterate over all the nodes - -- in a subtree, in depth-first fashion. This particular helper just - -- visits the children of this subtree, not the root of the subtree node - -- itself. This is useful when starting from the ultimate root of the - -- entire tree (see Iterate), as that root does not have an element. - - Node := Subtree.Children.First; - while Node /= null loop - Iterate_Subtree (Container, Node, Process); - Node := Node.Next; - end loop; - end Iterate_Children; - - function Iterate_Children - (Container : Tree; - Parent : Cursor) - return Tree_Iterator_Interfaces.Reversible_Iterator'Class - is - C : constant Tree_Access := Container'Unrestricted_Access; - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= C then - raise Program_Error with "Parent cursor not in container"; - end if; - - return It : constant Child_Iterator := - (Limited_Controlled with - Container => C, - Subtree => Parent.Node) - do - Busy (C.TC); - end return; - end Iterate_Children; - - --------------------- - -- Iterate_Subtree -- - --------------------- - - function Iterate_Subtree - (Position : Cursor) - return Tree_Iterator_Interfaces.Forward_Iterator'Class - is - C : constant Tree_Access := Position.Container; - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - -- Implement Vet for multiway trees??? - -- pragma Assert (Vet (Position), "bad subtree cursor"); - - return It : constant Subtree_Iterator := - (Limited_Controlled with - Container => C, - Subtree => Position.Node) - do - Busy (C.TC); - end return; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Position : Cursor; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Position.Container.TC'Unrestricted_Access); - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Is_Root (Position) then - Iterate_Children (Position.Container, Position.Node, Process); - else - Iterate_Subtree (Position.Container, Position.Node, Process); - end if; - end Iterate_Subtree; - - procedure Iterate_Subtree - (Container : Tree_Access; - Subtree : Tree_Node_Access; - Process : not null access procedure (Position : Cursor)) - is - begin - -- This is a helper function to recursively iterate over all the nodes - -- in a subtree, in depth-first fashion. It first visits the root of the - -- subtree, then visits its children. - - Process (Cursor'(Container, Subtree)); - Iterate_Children (Container, Subtree, Process); - end Iterate_Subtree; - - ---------- - -- Last -- - ---------- - - overriding function Last (Object : Child_Iterator) return Cursor is - begin - return Last_Child (Cursor'(Object.Container, Object.Subtree)); - end Last; - - ---------------- - -- Last_Child -- - ---------------- - - function Last_Child (Parent : Cursor) return Cursor is - Node : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - Node := Parent.Node.Children.Last; - - if Node = null then - return No_Element; - end if; - - return (Parent.Container, Node); - end Last_Child; - - ------------------------ - -- Last_Child_Element -- - ------------------------ - - function Last_Child_Element (Parent : Cursor) return Element_Type is - begin - return Element (Last_Child (Parent)); - end Last_Child_Element; - - ---------- - -- Move -- - ---------- - - procedure Move (Target : in out Tree; Source : in out Tree) is - Node : Tree_Node_Access; - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Target.Clear; -- checks busy bit - - Target.Root.Children := Source.Root.Children; - Source.Root.Children := Children_Type'(others => null); - - Node := Target.Root.Children.First; - while Node /= null loop - Node.Parent := Root_Node (Target); - Node := Node.Next; - end loop; - - Target.Count := Source.Count; - Source.Count := 0; - end Move; - - ---------- - -- Next -- - ---------- - - function Next - (Object : Subtree_Iterator; - Position : Cursor) return Cursor - is - Node : Tree_Node_Access; - - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong tree"; - end if; - - Node := Position.Node; - - if Node.Children.First /= null then - return Cursor'(Object.Container, Node.Children.First); - end if; - - while Node /= Object.Subtree loop - if Node.Next /= null then - return Cursor'(Object.Container, Node.Next); - end if; - - Node := Node.Parent; - end loop; - - return No_Element; - end Next; - - function Next - (Object : Child_Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong tree"; - end if; - - return Next_Sibling (Position); - end Next; - - ------------------ - -- Next_Sibling -- - ------------------ - - function Next_Sibling (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Node.Next = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Position.Node.Next); - end Next_Sibling; - - procedure Next_Sibling (Position : in out Cursor) is - begin - Position := Next_Sibling (Position); - end Next_Sibling; - - ---------------- - -- Node_Count -- - ---------------- - - function Node_Count (Container : Tree) return Count_Type is - begin - -- Container.Count is the number of nodes we have actually allocated. We - -- cache the value specifically so this Node_Count operation can execute - -- in O(1) time, which makes it behave similarly to how the Length - -- selector function behaves for other containers. - - -- The cached node count value only describes the nodes we have - -- allocated; the root node itself is not included in that count. The - -- Node_Count operation returns a value that includes the root node - -- (because the RM says so), so we must add 1 to our cached value. - - return 1 + Container.Count; - end Node_Count; - - ------------ - -- Parent -- - ------------ - - function Parent (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - if Position.Node.Parent = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Position.Node.Parent); - end Parent; - - ------------------- - -- Prepent_Child -- - ------------------- - - procedure Prepend_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - First, Last : Tree_Node_Access; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Count = 0 then - return; - end if; - - TC_Check (Container.TC); - - First := new Tree_Node_Type'(Parent => Parent.Node, - Element => New_Item, - others => <>); - - Last := First; - - for J in Count_Type'(2) .. Count loop - - -- Reclaim other nodes if Storage_Error??? - - Last.Next := new Tree_Node_Type'(Parent => Parent.Node, - Prev => Last, - Element => New_Item, - others => <>); - - Last := Last.Next; - end loop; - - Insert_Subtree_List - (First => First, - Last => Last, - Parent => Parent.Node, - Before => Parent.Node.Children.First); - - -- In order for operation Node_Count to complete in O(1) time, we cache - -- the count value. Here we increment the total count by the number of - -- nodes we just inserted. - - Container.Count := Container.Count + Count; - end Prepend_Child; - - -------------- - -- Previous -- - -------------- - - overriding function Previous - (Object : Child_Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong tree"; - end if; - - return Previous_Sibling (Position); - end Previous; - - ---------------------- - -- Previous_Sibling -- - ---------------------- - - function Previous_Sibling (Position : Cursor) return Cursor is - begin - return - (if Position = No_Element then No_Element - elsif Position.Node.Prev = null then No_Element - else Cursor'(Position.Container, Position.Node.Prev)); - end Previous_Sibling; - - procedure Previous_Sibling (Position : in out Cursor) is - begin - Position := Previous_Sibling (Position); - end Previous_Sibling; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Tree'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - Process (Position.Node.Element); - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Tree) - is - procedure Read_Children (Subtree : Tree_Node_Access); - - function Read_Subtree - (Parent : Tree_Node_Access) return Tree_Node_Access; - - Total_Count : Count_Type'Base; - -- Value read from the stream that says how many elements follow - - Read_Count : Count_Type'Base; - -- Actual number of elements read from the stream - - ------------------- - -- Read_Children -- - ------------------- - - procedure Read_Children (Subtree : Tree_Node_Access) is - pragma Assert (Subtree /= null); - pragma Assert (Subtree.Children.First = null); - pragma Assert (Subtree.Children.Last = null); - - Count : Count_Type'Base; - -- Number of child subtrees - - C : Children_Type; - - begin - Count_Type'Read (Stream, Count); - - if Checks and then Count < 0 then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - if Count = 0 then - return; - end if; - - C.First := Read_Subtree (Parent => Subtree); - C.Last := C.First; - - for J in Count_Type'(2) .. Count loop - C.Last.Next := Read_Subtree (Parent => Subtree); - C.Last.Next.Prev := C.Last; - C.Last := C.Last.Next; - end loop; - - -- Now that the allocation and reads have completed successfully, it - -- is safe to link the children to their parent. - - Subtree.Children := C; - end Read_Children; - - ------------------ - -- Read_Subtree -- - ------------------ - - function Read_Subtree - (Parent : Tree_Node_Access) return Tree_Node_Access - is - Subtree : constant Tree_Node_Access := - new Tree_Node_Type' - (Parent => Parent, - Element => Element_Type'Input (Stream), - others => <>); - - begin - Read_Count := Read_Count + 1; - - Read_Children (Subtree); - - return Subtree; - end Read_Subtree; - - -- Start of processing for Read - - begin - Container.Clear; -- checks busy bit - - Count_Type'Read (Stream, Total_Count); - - if Checks and then Total_Count < 0 then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - if Total_Count = 0 then - return; - end if; - - Read_Count := 0; - - Read_Children (Root_Node (Container)); - - if Checks and then Read_Count /= Total_Count then - raise Program_Error with "attempt to read from corrupt stream"; - end if; - - Container.Count := Total_Count; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to read tree cursor from stream"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Tree; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - if Checks and then Position.Node = Root_Node (Container) then - raise Program_Error with "Position cursor designates root"; - end if; - - -- Implement Vet for multiway tree??? - -- pragma Assert (Vet (Position), - -- "Position cursor in Constant_Reference is bad"); - - declare - C : Tree renames Position.Container.all; - TC : constant Tamper_Counts_Access := - C.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - -------------------- - -- Remove_Subtree -- - -------------------- - - procedure Remove_Subtree (Subtree : Tree_Node_Access) is - C : Children_Type renames Subtree.Parent.Children; - - begin - -- This is a utility operation to remove a subtree node from its - -- parent's list of children. - - if C.First = Subtree then - pragma Assert (Subtree.Prev = null); - - if C.Last = Subtree then - pragma Assert (Subtree.Next = null); - C.First := null; - C.Last := null; - - else - C.First := Subtree.Next; - C.First.Prev := null; - end if; - - elsif C.Last = Subtree then - pragma Assert (Subtree.Next = null); - C.Last := Subtree.Prev; - C.Last.Next := null; - - else - Subtree.Prev.Next := Subtree.Next; - Subtree.Next.Prev := Subtree.Prev; - end if; - end Remove_Subtree; - - ---------------------- - -- Replace_Element -- - ---------------------- - - procedure Replace_Element - (Container : in out Tree; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - TE_Check (Container.TC); - - Position.Node.Element := New_Item; - end Replace_Element; - - ------------------------------ - -- Reverse_Iterate_Children -- - ------------------------------ - - procedure Reverse_Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)) - is - C : Tree_Node_Access; - Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - C := Parent.Node.Children.Last; - while C /= null loop - Process (Position => Cursor'(Parent.Container, Node => C)); - C := C.Prev; - end loop; - end Reverse_Iterate_Children; - - ---------- - -- Root -- - ---------- - - function Root (Container : Tree) return Cursor is - begin - return (Container'Unrestricted_Access, Root_Node (Container)); - end Root; - - --------------- - -- Root_Node -- - --------------- - - function Root_Node (Container : Tree) return Tree_Node_Access is - type Root_Node_Access is access all Root_Node_Type; - for Root_Node_Access'Storage_Size use 0; - pragma Convention (C, Root_Node_Access); - - function To_Tree_Node_Access is - new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access); - - -- Start of processing for Root_Node - - begin - -- This is a utility function for converting from an access type that - -- designates the distinguished root node to an access type designating - -- a non-root node. The representation of a root node does not have an - -- element, but is otherwise identical to a non-root node, so the - -- conversion itself is safe. - - return To_Tree_Node_Access (Container.Root'Unrestricted_Access); - end Root_Node; - - --------------------- - -- Splice_Children -- - --------------------- - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Source_Parent : Cursor) - is - Count : Count_Type; - - begin - if Checks and then Target_Parent = No_Element then - raise Constraint_Error with "Target_Parent cursor has no element"; - end if; - - if Checks and then Target_Parent.Container /= Target'Unrestricted_Access - then - raise Program_Error - with "Target_Parent cursor not in Target container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error - with "Before cursor not in Target container"; - end if; - - if Checks and then Before.Node.Parent /= Target_Parent.Node then - raise Constraint_Error - with "Before cursor not child of Target_Parent"; - end if; - end if; - - if Checks and then Source_Parent = No_Element then - raise Constraint_Error with "Source_Parent cursor has no element"; - end if; - - if Checks and then Source_Parent.Container /= Source'Unrestricted_Access - then - raise Program_Error - with "Source_Parent cursor not in Source container"; - end if; - - if Target'Address = Source'Address then - if Target_Parent = Source_Parent then - return; - end if; - - TC_Check (Target.TC); - - if Checks and then Is_Reachable (From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - -- We cache the count of the nodes we have allocated, so that operation - -- Node_Count can execute in O(1) time. But that means we must count the - -- nodes in the subtree we remove from Source and insert into Target, in - -- order to keep the count accurate. - - Count := Subtree_Node_Count (Source_Parent.Node); - pragma Assert (Count >= 1); - - Count := Count - 1; -- because Source_Parent node does not move - - Splice_Children - (Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - - Source.Count := Source.Count - Count; - Target.Count := Target.Count + Count; - end Splice_Children; - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source_Parent : Cursor) - is - begin - if Checks and then Target_Parent = No_Element then - raise Constraint_Error with "Target_Parent cursor has no element"; - end if; - - if Checks and then - Target_Parent.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Target_Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Target_Parent.Node then - raise Constraint_Error - with "Before cursor not child of Target_Parent"; - end if; - end if; - - if Checks and then Source_Parent = No_Element then - raise Constraint_Error with "Source_Parent cursor has no element"; - end if; - - if Checks and then - Source_Parent.Container /= Container'Unrestricted_Access - then - raise Program_Error - with "Source_Parent cursor not in container"; - end if; - - if Target_Parent = Source_Parent then - return; - end if; - - TC_Check (Container.TC); - - if Checks and then Is_Reachable (From => Target_Parent.Node, - To => Source_Parent.Node) - then - raise Constraint_Error - with "Source_Parent is ancestor of Target_Parent"; - end if; - - Splice_Children - (Target_Parent => Target_Parent.Node, - Before => Before.Node, - Source_Parent => Source_Parent.Node); - end Splice_Children; - - procedure Splice_Children - (Target_Parent : Tree_Node_Access; - Before : Tree_Node_Access; - Source_Parent : Tree_Node_Access) - is - CC : constant Children_Type := Source_Parent.Children; - C : Tree_Node_Access; - - begin - -- This is a utility operation to remove the children from - -- Source parent and insert them into Target parent. - - Source_Parent.Children := Children_Type'(others => null); - - -- Fix up the Parent pointers of each child to designate - -- its new Target parent. - - C := CC.First; - while C /= null loop - C.Parent := Target_Parent; - C := C.Next; - end loop; - - Insert_Subtree_List - (First => CC.First, - Last => CC.Last, - Parent => Target_Parent, - Before => Before); - end Splice_Children; - - -------------------- - -- Splice_Subtree -- - -------------------- - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Position : in out Cursor) - is - Subtree_Count : Count_Type; - - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Target'Unrestricted_Access then - raise Program_Error with "Parent cursor not in Target container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Target'Unrestricted_Access then - raise Program_Error with "Before cursor not in Target container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Source'Unrestricted_Access then - raise Program_Error with "Position cursor not in Source container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - if Target'Address = Source'Address then - if Position.Node.Parent = Parent.Node then - if Position.Node = Before.Node then - return; - end if; - - if Position.Node.Next = Before.Node then - return; - end if; - end if; - - TC_Check (Target.TC); - - if Checks and then - Is_Reachable (From => Parent.Node, To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Position.Node); - - Position.Node.Parent := Parent.Node; - Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); - - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - -- This is an unfortunate feature of this API: we must count the nodes - -- in the subtree that we remove from the source tree, which is an O(n) - -- operation. It would have been better if the Tree container did not - -- have a Node_Count selector; a user that wants the number of nodes in - -- the tree could simply call Subtree_Node_Count, with the understanding - -- that such an operation is O(n). - - -- Of course, we could choose to implement the Node_Count selector as an - -- O(n) operation, which would turn this splice operation into an O(1) - -- operation. ??? - - Subtree_Count := Subtree_Node_Count (Position.Node); - pragma Assert (Subtree_Count <= Source.Count); - - Remove_Subtree (Position.Node); - Source.Count := Source.Count - Subtree_Count; - - Position.Node.Parent := Parent.Node; - Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); - - Target.Count := Target.Count + Subtree_Count; - - Position.Container := Target'Unrestricted_Access; - end Splice_Subtree; - - procedure Splice_Subtree - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : Cursor) - is - begin - if Checks and then Parent = No_Element then - raise Constraint_Error with "Parent cursor has no element"; - end if; - - if Checks and then Parent.Container /= Container'Unrestricted_Access then - raise Program_Error with "Parent cursor not in container"; - end if; - - if Before /= No_Element then - if Checks and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor not in container"; - end if; - - if Checks and then Before.Node.Parent /= Parent.Node then - raise Constraint_Error with "Before cursor not child of Parent"; - end if; - end if; - - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - - -- Should this be PE instead? Need ARG confirmation. ??? - - raise Constraint_Error with "Position cursor designates root"; - end if; - - if Position.Node.Parent = Parent.Node then - if Position.Node = Before.Node then - return; - end if; - - if Position.Node.Next = Before.Node then - return; - end if; - end if; - - TC_Check (Container.TC); - - if Checks and then - Is_Reachable (From => Parent.Node, To => Position.Node) - then - raise Constraint_Error with "Position is ancestor of Parent"; - end if; - - Remove_Subtree (Position.Node); - - Position.Node.Parent := Parent.Node; - Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); - end Splice_Subtree; - - ------------------------ - -- Subtree_Node_Count -- - ------------------------ - - function Subtree_Node_Count (Position : Cursor) return Count_Type is - begin - if Position = No_Element then - return 0; - end if; - - return Subtree_Node_Count (Position.Node); - end Subtree_Node_Count; - - function Subtree_Node_Count - (Subtree : Tree_Node_Access) return Count_Type - is - Result : Count_Type; - Node : Tree_Node_Access; - - begin - Result := 1; - Node := Subtree.Children.First; - while Node /= null loop - Result := Result + Subtree_Node_Count (Node); - Node := Node.Next; - end loop; - - return Result; - end Subtree_Node_Count; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out Tree; - I, J : Cursor) - is - begin - if Checks and then I = No_Element then - raise Constraint_Error with "I cursor has no element"; - end if; - - if Checks and then I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor not in container"; - end if; - - if Checks and then Is_Root (I) then - raise Program_Error with "I cursor designates root"; - end if; - - if I = J then -- make this test sooner??? - return; - end if; - - if Checks and then J = No_Element then - raise Constraint_Error with "J cursor has no element"; - end if; - - if Checks and then J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor not in container"; - end if; - - if Checks and then Is_Root (J) then - raise Program_Error with "J cursor designates root"; - end if; - - TE_Check (Container.TC); - - declare - EI : constant Element_Type := I.Node.Element; - - begin - I.Node.Element := J.Node.Element; - J.Node.Element := EI; - end; - end Swap; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Tree; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - T : Tree renames Position.Container.all'Unrestricted_Access.all; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - if Checks and then Position = No_Element then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor not in container"; - end if; - - if Checks and then Is_Root (Position) then - raise Program_Error with "Position cursor designates root"; - end if; - - Process (Position.Node.Element); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Tree) - is - procedure Write_Children (Subtree : Tree_Node_Access); - procedure Write_Subtree (Subtree : Tree_Node_Access); - - -------------------- - -- Write_Children -- - -------------------- - - procedure Write_Children (Subtree : Tree_Node_Access) is - CC : Children_Type renames Subtree.Children; - C : Tree_Node_Access; - - begin - Count_Type'Write (Stream, Child_Count (CC)); - - C := CC.First; - while C /= null loop - Write_Subtree (C); - C := C.Next; - end loop; - end Write_Children; - - ------------------- - -- Write_Subtree -- - ------------------- - - procedure Write_Subtree (Subtree : Tree_Node_Access) is - begin - Element_Type'Output (Stream, Subtree.Element); - Write_Children (Subtree); - end Write_Subtree; - - -- Start of processing for Write - - begin - Count_Type'Write (Stream, Container.Count); - - if Container.Count = 0 then - return; - end if; - - Write_Children (Root_Node (Container)); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to write tree cursor to stream"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Multiway_Trees; diff --git a/gcc/ada/a-comutr.ads b/gcc/ada/a-comutr.ads deleted file mode 100644 index ef55696..0000000 --- a/gcc/ada/a-comutr.ads +++ /dev/null @@ -1,511 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type is private; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Multiway_Trees is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - type Tree is tagged private - with Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - pragma Preelaborable_Initialization (Tree); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Tree : constant Tree; - - No_Element : constant Cursor; - function Has_Element (Position : Cursor) return Boolean; - - package Tree_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function Equal_Subtree - (Left_Position : Cursor; - Right_Position : Cursor) return Boolean; - - function "=" (Left, Right : Tree) return Boolean; - - function Is_Empty (Container : Tree) return Boolean; - - function Node_Count (Container : Tree) return Count_Type; - - function Subtree_Node_Count (Position : Cursor) return Count_Type; - - function Depth (Position : Cursor) return Count_Type; - - function Is_Root (Position : Cursor) return Boolean; - - function Is_Leaf (Position : Cursor) return Boolean; - - function Root (Container : Tree) return Cursor; - - procedure Clear (Container : in out Tree); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Tree; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Tree; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - type Reference_Type - (Element : not null access Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Tree; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Tree; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Tree; Source : Tree); - - function Copy (Source : Tree) return Tree; - - procedure Move (Target : in out Tree; Source : in out Tree); - - procedure Delete_Leaf - (Container : in out Tree; - Position : in out Cursor); - - procedure Delete_Subtree - (Container : in out Tree; - Position : in out Cursor); - - procedure Swap - (Container : in out Tree; - I, J : Cursor); - - function Find - (Container : Tree; - Item : Element_Type) return Cursor; - - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Find_In_Subtree this way: - -- - -- function Find_In_Subtree - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - - function Find_In_Subtree - (Position : Cursor; - Item : Element_Type) return Cursor; - - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Ancestor_Find this way: - -- - -- function Ancestor_Find - -- (Container : Tree; - -- Item : Element_Type; - -- Position : Cursor) return Cursor; - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - - function Ancestor_Find - (Position : Cursor; - Item : Element_Type) return Cursor; - - function Contains - (Container : Tree; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : Tree; - Process : not null access procedure (Position : Cursor)); - - procedure Iterate_Subtree - (Position : Cursor; - Process : not null access procedure (Position : Cursor)); - - function Iterate (Container : Tree) - return Tree_Iterator_Interfaces.Forward_Iterator'Class; - - function Iterate_Subtree (Position : Cursor) - return Tree_Iterator_Interfaces.Forward_Iterator'Class; - - function Iterate_Children - (Container : Tree; - Parent : Cursor) - return Tree_Iterator_Interfaces.Reversible_Iterator'Class; - - function Child_Count (Parent : Cursor) return Count_Type; - - function Child_Depth (Parent, Child : Cursor) return Count_Type; - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Insert_Child - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append_Child - (Container : in out Tree; - Parent : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Delete_Children - (Container : in out Tree; - Parent : Cursor); - - procedure Copy_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : Cursor); - - procedure Splice_Subtree - (Target : in out Tree; - Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Position : in out Cursor); - - procedure Splice_Subtree - (Container : in out Tree; - Parent : Cursor; - Before : Cursor; - Position : Cursor); - - procedure Splice_Children - (Target : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source : in out Tree; - Source_Parent : Cursor); - - procedure Splice_Children - (Container : in out Tree; - Target_Parent : Cursor; - Before : Cursor; - Source_Parent : Cursor); - - function Parent (Position : Cursor) return Cursor; - - function First_Child (Parent : Cursor) return Cursor; - - function First_Child_Element (Parent : Cursor) return Element_Type; - - function Last_Child (Parent : Cursor) return Cursor; - - function Last_Child_Element (Parent : Cursor) return Element_Type; - - function Next_Sibling (Position : Cursor) return Cursor; - - function Previous_Sibling (Position : Cursor) return Cursor; - - procedure Next_Sibling (Position : in out Cursor); - - procedure Previous_Sibling (Position : in out Cursor); - - -- This version of the AI: - -- 10-06-02 AI05-0136-1/07 - -- declares Iterate_Children this way: - -- - -- procedure Iterate_Children - -- (Container : Tree; - -- Parent : Cursor; - -- Process : not null access procedure (Position : Cursor)); - -- - -- It seems that the Container parameter is there by mistake, but we need - -- an official ruling from the ARG. ??? - - procedure Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate_Children - (Parent : Cursor; - Process : not null access procedure (Position : Cursor)); - -private - -- A node of this multiway tree comprises an element and a list of children - -- (that are themselves trees). The root node is distinguished because it - -- contains only children: it does not have an element itself. - - -- This design feature puts two design goals in tension with one another: - -- (1) treat the root node the same as any other node - -- (2) not declare any objects of type Element_Type unnecessarily - - -- To satisfy (1), we could simply declare the Root node of the tree - -- using the normal Tree_Node_Type, but that would mean that (2) is not - -- satisfied. To resolve the tension (in favor of (2)), we declare the - -- component Root as having a different node type, without an Element - -- component (thus satisfying goal (2)) but otherwise identical to a normal - -- node, and then use Unchecked_Conversion to convert an access object - -- designating the Root node component to the access type designating a - -- normal, non-root node (thus satisfying goal (1)). We make an explicit - -- check for Root when there is any attempt to manipulate the Element - -- component of the node (a check required by the RM anyway). - - -- In order to be explicit about node (and pointer) representation, we - -- specify that the respective node types have convention C, to ensure - -- that the layout of the components of the node records is the same, - -- thus guaranteeing that (unchecked) conversions between access types - -- designating each kind of node type is a meaningful conversion. - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - type Tree_Node_Type; - type Tree_Node_Access is access all Tree_Node_Type; - pragma Convention (C, Tree_Node_Access); - pragma No_Strict_Aliasing (Tree_Node_Access); - -- The above-mentioned Unchecked_Conversion is a violation of the normal - -- aliasing rules. - - type Children_Type is record - First : Tree_Node_Access; - Last : Tree_Node_Access; - end record; - - -- See the comment above. This declaration must exactly match the - -- declaration of Root_Node_Type (except for the Element component). - - type Tree_Node_Type is record - Parent : Tree_Node_Access; - Prev : Tree_Node_Access; - Next : Tree_Node_Access; - Children : Children_Type; - Element : aliased Element_Type; - end record; - pragma Convention (C, Tree_Node_Type); - - -- See the comment above. This declaration must match the declaration of - -- Tree_Node_Type (except for the Element component). - - type Root_Node_Type is record - Parent : Tree_Node_Access; - Prev : Tree_Node_Access; - Next : Tree_Node_Access; - Children : Children_Type; - end record; - pragma Convention (C, Root_Node_Type); - - for Root_Node_Type'Alignment use Standard'Maximum_Alignment; - -- The alignment has to be large enough to allow Root_Node to Tree_Node - -- access value conversions, and Tree_Node_Type's alignment may be bumped - -- up by the Element component. - - use Ada.Finalization; - - -- The Count component of type Tree represents the number of nodes that - -- have been (dynamically) allocated. It does not include the root node - -- itself. As implementors, we decide to cache this value, so that the - -- selector function Node_Count can execute in O(1) time, in order to be - -- consistent with the behavior of the Length selector function for other - -- standard container library units. This does mean, however, that the - -- two-container forms for Splice_XXX (that move subtrees across tree - -- containers) will execute in O(n) time, because we must count the number - -- of nodes in the subtree(s) that get moved. (We resolve the tension - -- between Node_Count and Splice_XXX in favor of Node_Count, under the - -- assumption that Node_Count is the more common operation). - - type Tree is new Controlled with record - Root : aliased Root_Node_Type; - TC : aliased Tamper_Counts; - Count : Count_Type := 0; - end record; - - overriding procedure Adjust (Container : in out Tree); - - overriding procedure Finalize (Container : in out Tree) renames Clear; - - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Tree); - - for Tree'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Tree); - - for Tree'Read use Read; - - type Tree_Access is access all Tree; - for Tree_Access'Storage_Size use 0; - - type Cursor is record - Container : Tree_Access; - Node : Tree_Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Tree'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Tree : constant Tree := (Controlled with others => <>); - - No_Element : constant Cursor := (others => <>); - -end Ada.Containers.Multiway_Trees; diff --git a/gcc/ada/a-conhel.adb b/gcc/ada/a-conhel.adb deleted file mode 100644 index 864b217..0000000 --- a/gcc/ada/a-conhel.adb +++ /dev/null @@ -1,186 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . H E L P E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2015-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Helpers is - - package body Generic_Implementation is - - use type SAC.Atomic_Unsigned; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Control : in out Reference_Control_Type) is - begin - if Control.T_Counts /= null then - Lock (Control.T_Counts.all); - end if; - end Adjust; - - ---------- - -- Busy -- - ---------- - - procedure Busy (T_Counts : in out Tamper_Counts) is - begin - if T_Check then - SAC.Increment (T_Counts.Busy); - end if; - end Busy; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.T_Counts /= null then - Unlock (Control.T_Counts.all); - Control.T_Counts := null; - end if; - end Finalize; - - -- No need to protect against double Finalize here, because these types - -- are limited. - - procedure Finalize (Busy : in out With_Busy) is - pragma Warnings (Off); - pragma Assert (T_Check); -- not called if check suppressed - pragma Warnings (On); - begin - Unbusy (Busy.T_Counts.all); - end Finalize; - - procedure Finalize (Lock : in out With_Lock) is - pragma Warnings (Off); - pragma Assert (T_Check); -- not called if check suppressed - pragma Warnings (On); - begin - Unlock (Lock.T_Counts.all); - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Busy : in out With_Busy) is - pragma Warnings (Off); - pragma Assert (T_Check); -- not called if check suppressed - pragma Warnings (On); - begin - Generic_Implementation.Busy (Busy.T_Counts.all); - end Initialize; - - procedure Initialize (Lock : in out With_Lock) is - pragma Warnings (Off); - pragma Assert (T_Check); -- not called if check suppressed - pragma Warnings (On); - begin - Generic_Implementation.Lock (Lock.T_Counts.all); - end Initialize; - - ---------- - -- Lock -- - ---------- - - procedure Lock (T_Counts : in out Tamper_Counts) is - begin - if T_Check then - SAC.Increment (T_Counts.Lock); - SAC.Increment (T_Counts.Busy); - end if; - end Lock; - - -------------- - -- TC_Check -- - -------------- - - procedure TC_Check (T_Counts : Tamper_Counts) is - begin - if T_Check and then T_Counts.Busy > 0 then - raise Program_Error with - "attempt to tamper with cursors"; - end if; - - -- The lock status (which monitors "element tampering") always - -- implies that the busy status (which monitors "cursor tampering") - -- is set too; this is a representation invariant. Thus if the busy - -- bit is not set, then the lock bit must not be set either. - - pragma Assert (T_Counts.Lock = 0); - end TC_Check; - - -------------- - -- TE_Check -- - -------------- - - procedure TE_Check (T_Counts : Tamper_Counts) is - begin - if T_Check and then T_Counts.Lock > 0 then - raise Program_Error with - "attempt to tamper with elements"; - end if; - end TE_Check; - - ------------ - -- Unbusy -- - ------------ - - procedure Unbusy (T_Counts : in out Tamper_Counts) is - begin - if T_Check then - SAC.Decrement (T_Counts.Busy); - end if; - end Unbusy; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock (T_Counts : in out Tamper_Counts) is - begin - if T_Check then - SAC.Decrement (T_Counts.Lock); - SAC.Decrement (T_Counts.Busy); - end if; - end Unlock; - - ----------------- - -- Zero_Counts -- - ----------------- - - procedure Zero_Counts (T_Counts : out Tamper_Counts) is - begin - if T_Check then - T_Counts := (others => <>); - end if; - end Zero_Counts; - - end Generic_Implementation; - -end Ada.Containers.Helpers; diff --git a/gcc/ada/a-conhel.ads b/gcc/ada/a-conhel.ads deleted file mode 100644 index 008ef8a..0000000 --- a/gcc/ada/a-conhel.ads +++ /dev/null @@ -1,159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . H E L P E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- ------------------------------------------------------------------------------- - -with Ada.Finalization; -with System.Atomic_Counters; - -package Ada.Containers.Helpers is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - - -- Miscellaneous helpers shared among various containers - - package SAC renames System.Atomic_Counters; - - Count_Type_Last : constant := Count_Type'Last; - -- Count_Type'Last as a universal_integer, so we can compare Index_Type - -- values against this without type conversions that might overflow. - - type Tamper_Counts is record - Busy : aliased SAC.Atomic_Unsigned := 0; - Lock : aliased SAC.Atomic_Unsigned := 0; - end record; - - -- Busy is positive when tampering with cursors is prohibited. Busy and - -- Lock are both positive when tampering with elements is prohibited. - - type Tamper_Counts_Access is access all Tamper_Counts; - for Tamper_Counts_Access'Storage_Size use 0; - - generic - package Generic_Implementation is - - -- Generic package used in the implementation of containers. - - -- This needs to be generic so that the 'Enabled attribute will return - -- the value that is relevant at the point where a container generic is - -- instantiated. For example: - -- - -- pragma Suppress (Container_Checks); - -- package My_Vectors is new Ada.Containers.Vectors (...); - -- - -- should suppress all container-related checks within the instance - -- My_Vectors. - - -- Shorthands for "checks enabled" and "tampering checks enabled". Note - -- that suppressing either Container_Checks or Tampering_Check disables - -- tampering checks. Note that this code needs to be in a generic - -- package, because we want to take account of check suppressions at the - -- instance. We use these flags, along with pragma Inline, to ensure - -- that the compiler can optimize away the checks, as well as the - -- tampering check machinery, when checks are suppressed. - - Checks : constant Boolean := Container_Checks'Enabled; - T_Check : constant Boolean := - Container_Checks'Enabled and Tampering_Check'Enabled; - - -- Reference_Control_Type is used as a component of reference types, to - -- prohibit tampering with elements so long as references exist. - - type Reference_Control_Type is - new Finalization.Controlled with record - T_Counts : Tamper_Counts_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Adjust (Control : in out Reference_Control_Type); - pragma Inline (Adjust); - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - procedure Zero_Counts (T_Counts : out Tamper_Counts); - pragma Inline (Zero_Counts); - -- Set Busy and Lock to zero - - procedure Busy (T_Counts : in out Tamper_Counts); - pragma Inline (Busy); - -- Prohibit tampering with cursors - - procedure Unbusy (T_Counts : in out Tamper_Counts); - pragma Inline (Unbusy); - -- Allow tampering with cursors - - procedure Lock (T_Counts : in out Tamper_Counts); - pragma Inline (Lock); - -- Prohibit tampering with elements - - procedure Unlock (T_Counts : in out Tamper_Counts); - pragma Inline (Unlock); - -- Allow tampering with elements - - procedure TC_Check (T_Counts : Tamper_Counts); - pragma Inline (TC_Check); - -- Tampering-with-cursors check - - procedure TE_Check (T_Counts : Tamper_Counts); - pragma Inline (TE_Check); - -- Tampering-with-elements check - - ----------------- - -- RAII Types -- - ----------------- - - -- Initialize of With_Busy increments the Busy count, and Finalize - -- decrements it. Thus, to prohibit tampering with elements within a - -- given scope, declare an object of type With_Busy. The Busy count - -- will be correctly decremented in case of exception or abort. - - -- With_Lock is the same as With_Busy, except it increments/decrements - -- BOTH Busy and Lock, thus prohibiting tampering with cursors. - - type With_Busy (T_Counts : not null access Tamper_Counts) is - new Finalization.Limited_Controlled with null record - with Disable_Controlled => not T_Check; - overriding procedure Initialize (Busy : in out With_Busy); - overriding procedure Finalize (Busy : in out With_Busy); - - type With_Lock (T_Counts : not null access Tamper_Counts) is - new Finalization.Limited_Controlled with null record - with Disable_Controlled => not T_Check; - overriding procedure Initialize (Lock : in out With_Lock); - overriding procedure Finalize (Lock : in out With_Lock); - - -- Variables of type With_Busy and With_Lock are declared only for the - -- effects of Initialize and Finalize, so they are not referenced; - -- disable warnings about that. Note that all variables of these types - -- have names starting with "Busy" or "Lock". These pragmas need to be - -- present wherever these types are used. - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - - end Generic_Implementation; - -end Ada.Containers.Helpers; diff --git a/gcc/ada/a-contai.ads b/gcc/ada/a-contai.ads deleted file mode 100644 index be8a808..0000000 --- a/gcc/ada/a-contai.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Containers is - pragma Pure; - - type Hash_Type is mod 2**32; - type Count_Type is range 0 .. 2**31 - 1; - - Capacity_Error : exception; - -end Ada.Containers; diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb deleted file mode 100644 index d77e011..0000000 --- a/gcc/ada/a-convec.adb +++ /dev/null @@ -1,3274 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . V E C T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers.Generic_Array_Sort; -with Ada.Unchecked_Deallocation; - -with System; use type System.Address; - -package body Ada.Containers.Vectors is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - procedure Free is - new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); - - procedure Append_Slow_Path - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type); - -- This is the slow path for Append. This is split out to minimize the size - -- of Append, because we have Inline (Append). - - --------- - -- "&" -- - --------- - - -- We decide that the capacity of the result of "&" is the minimum needed - -- -- the sum of the lengths of the vector parameters. We could decide to - -- make it larger, but we have no basis for knowing how much larger, so we - -- just allocate the minimum amount of storage. - - function "&" (Left, Right : Vector) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, Length (Left) + Length (Right)); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - function "&" (Left : Vector; Right : Element_Type) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, Length (Left) + 1); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - function "&" (Left : Element_Type; Right : Vector) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, 1 + Length (Right)); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - function "&" (Left, Right : Element_Type) return Vector is - begin - return Result : Vector do - Reserve_Capacity (Result, 1 + 1); - Append (Result, Left); - Append (Result, Right); - end return; - end "&"; - - --------- - -- "=" -- - --------- - - overriding function "=" (Left, Right : Vector) return Boolean is - begin - if Left.Last /= Right.Last then - return False; - end if; - - if Left.Length = 0 then - return True; - end if; - - declare - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - begin - for J in Index_Type range Index_Type'First .. Left.Last loop - if Left.Elements.EA (J) /= Right.Elements.EA (J) then - return False; - end if; - end loop; - end; - - return True; - end "="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Container : in out Vector) is - begin - -- If the counts are nonzero, execution is technically erroneous, but - -- it seems friendly to allow things like concurrent "=" on shared - -- constants. - - Zero_Counts (Container.TC); - - if Container.Last = No_Index then - Container.Elements := null; - return; - end if; - - declare - L : constant Index_Type := Container.Last; - EA : Elements_Array renames - Container.Elements.EA (Index_Type'First .. L); - - begin - Container.Elements := null; - - -- Note: it may seem that the following assignment to Container.Last - -- is useless, since we assign it to L below. However this code is - -- used in case 'new Elements_Type' below raises an exception, to - -- keep Container in a consistent state. - - Container.Last := No_Index; - Container.Elements := new Elements_Type'(L, EA); - Container.Last := L; - end; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append (Container : in out Vector; New_Item : Vector) is - begin - if Is_Empty (New_Item) then - return; - elsif Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - else - Insert (Container, Container.Last + 1, New_Item); - end if; - end Append; - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - -- In the general case, we pass the buck to Insert, but for efficiency, - -- we check for the usual case where Count = 1 and the vector has enough - -- room for at least one more element. - - if Count = 1 - and then Container.Elements /= null - and then Container.Last /= Container.Elements.Last - then - TC_Check (Container.TC); - - -- Increment Container.Last after assigning the New_Item, so we - -- leave the Container unmodified in case Finalize/Adjust raises - -- an exception. - - declare - New_Last : constant Index_Type := Container.Last + 1; - begin - Container.Elements.EA (New_Last) := New_Item; - Container.Last := New_Last; - end; - - else - Append_Slow_Path (Container, New_Item, Count); - end if; - end Append; - - ---------------------- - -- Append_Slow_Path -- - ---------------------- - - procedure Append_Slow_Path - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type) - is - begin - if Count = 0 then - return; - elsif Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - else - Insert (Container, Container.Last + 1, New_Item, Count); - end if; - end Append_Slow_Path; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Vector; Source : Vector) is - begin - if Target'Address = Source'Address then - return; - else - Target.Clear; - Target.Append (Source); - end if; - end Assign; - - -------------- - -- Capacity -- - -------------- - - function Capacity (Container : Vector) return Count_Type is - begin - if Container.Elements = null then - return 0; - else - return Container.Elements.EA'Length; - end if; - end Capacity; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out Vector) is - begin - TC_Check (Container.TC); - Container.Last := No_Index; - end Clear; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Vector; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return Constant_Reference_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean - is - begin - return Find_Index (Container, Item) /= No_Index; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy - (Source : Vector; - Capacity : Count_Type := 0) return Vector - is - C : Count_Type; - - begin - if Capacity >= Source.Length then - C := Capacity; - - else - C := Source.Length; - - if Checks and then Capacity /= 0 then - raise Capacity_Error with - "Requested capacity is less than Source length"; - end if; - end if; - - return Target : Vector do - Target.Reserve_Capacity (C); - Target.Assign (Source); - end return; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type := 1) - is - Old_Last : constant Index_Type'Base := Container.Last; - New_Last : Index_Type'Base; - Count2 : Count_Type'Base; -- count of items from Index to Old_Last - J : Index_Type'Base; -- first index of items that slide down - - begin - -- Delete removes items from the vector, the number of which is the - -- minimum of the specified Count and the items (if any) that exist from - -- Index to Container.Last. There are no constraints on the specified - -- value of Count (it can be larger than what's available at this - -- position in the vector, for example), but there are constraints on - -- the allowed values of the Index. - - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we do - -- not allow that as the value for Index when specifying which items - -- should be deleted, so we must manually check. (That the user is - -- allowed to specify the value at all here is a consequence of the - -- declaration of the Extended_Index subtype, which includes the values - -- in the base range that immediately precede and immediately follow the - -- values in the Index_Type.) - - if Checks and then Index < Index_Type'First then - raise Constraint_Error with "Index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows the - -- corner case of deleting no items from the back end of the vector to - -- be treated as a no-op. (It is assumed that specifying an index value - -- greater than Last + 1 indicates some deeper flaw in the caller's - -- algorithm, so that case is treated as a proper error.) - - if Index > Old_Last then - if Checks and then Index > Old_Last + 1 then - raise Constraint_Error with "Index is out of range (too large)"; - else - return; - end if; - end if; - - -- Here and elsewhere we treat deleting 0 items from the container as a - -- no-op, even when the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete checks the count to determine whether it is - -- being called while the associated callback procedure is executing. - - TC_Check (Container.TC); - - -- We first calculate what's available for deletion starting at - -- Index. Here and elsewhere we use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate values. (See function - -- Length for more information.) - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; - else - Count2 := Count_Type'Base (Old_Last - Index + 1); - end if; - - -- If more elements are requested (Count) for deletion than are - -- available (Count2) for deletion beginning at Index, then everything - -- from Index is deleted. There are no elements to slide down, and so - -- all we need to do is set the value of Container.Last. - - if Count >= Count2 then - Container.Last := Index - 1; - return; - end if; - - -- There are some elements that aren't being deleted (the requested - -- count was less than the available count), so we must slide them down - -- to Index. We first calculate the index values of the respective array - -- slices, using the wider of Index_Type'Base and Count_Type'Base as the - -- type for intermediate calculations. For the elements that slide down, - -- index value New_Last is the last index value of their new home, and - -- index value J is the first index of their old home. - - if Index_Type'Base'Last >= Count_Type_Last then - New_Last := Old_Last - Index_Type'Base (Count); - J := Index + Index_Type'Base (Count); - else - New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); - J := Index_Type'Base (Count_Type'Base (Index) + Count); - end if; - - -- The internal elements array isn't guaranteed to exist unless we have - -- elements, but we have that guarantee here because we know we have - -- elements to slide. The array index values for each slice have - -- already been determined, so we just slide down to Index the elements - -- that weren't deleted. - - declare - EA : Elements_Array renames Container.Elements.EA; - begin - EA (Index .. New_Last) := EA (J .. Old_Last); - Container.Last := New_Last; - end; - end Delete; - - procedure Delete - (Container : in out Vector; - Position : in out Cursor; - Count : Count_Type := 1) - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - - elsif Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - end if; - - Delete (Container, Position.Index, Count); - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - if Count = 0 then - return; - - elsif Count >= Length (Container) then - Clear (Container); - return; - - else - Delete (Container, Index_Type'First, Count); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out Vector; - Count : Count_Type := 1) - is - begin - -- It is not permitted to delete items while the container is busy (for - -- example, we're in the middle of a passive iteration). However, we - -- always treat deleting 0 items as a no-op, even when we're busy, so we - -- simply return without checking. - - if Count = 0 then - return; - end if; - - -- The tampering bits exist to prevent an item from being deleted (or - -- otherwise harmfully manipulated) while it is being visited. Query, - -- Update, and Iterate increment the busy count on entry, and decrement - -- the count on exit. Delete_Last checks the count to determine whether - -- it is being called while the associated callback procedure is - -- executing. - - TC_Check (Container.TC); - - -- There is no restriction on how large Count can be when deleting - -- items. If it is equal or greater than the current length, then this - -- is equivalent to clearing the vector. (In particular, there's no need - -- for us to actually calculate the new value for Last.) - - -- If the requested count is less than the current length, then we must - -- calculate the new value for Last. For the type we use the widest of - -- Index_Type'Base and Count_Type'Base for the intermediate values of - -- our calculation. (See the comments in Length for more information.) - - if Count >= Container.Length then - Container.Last := No_Index; - - elsif Index_Type'Base'Last >= Count_Type_Last then - Container.Last := Container.Last - Index_Type'Base (Count); - - else - Container.Last := - Index_Type'Base (Count_Type'Base (Container.Last) - Count); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - return Container.Elements.EA (Index); - end Element; - - function Element (Position : Cursor) return Element_Type is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - return Position.Container.Elements.EA (Position.Index); - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Container : in out Vector) is - X : Elements_Access := Container.Elements; - - begin - Container.Elements := null; - Container.Last := No_Index; - - Free (X); - - TC_Check (Container.TC); - end Finalize; - - procedure Finalize (Object : in out Iterator) is - begin - Unbusy (Object.Container.TC); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - begin - if Checks and then Position.Container /= null then - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Container.Last then - raise Program_Error with "Position index is out of range"; - end if; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for J in Position.Index .. Container.Last loop - if Container.Elements.EA (J) = Item then - return Cursor'(Container'Unrestricted_Access, J); - end if; - end loop; - - return No_Element; - end; - end Find; - - ---------------- - -- Find_Index -- - ---------------- - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index - is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for Indx in Index .. Container.Last loop - if Container.Elements.EA (Indx) = Item then - return Indx; - end if; - end loop; - - return No_Index; - end Find_Index; - - ----------- - -- First -- - ----------- - - function First (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - end if; - - return (Container'Unrestricted_Access, Index_Type'First); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the First (and Last) selector function. - - -- When the Index component is No_Index, this means the iterator - -- object was constructed without a start expression, in which case the - -- (forward) iteration starts from the (logical) beginning of the entire - -- sequence of items (corresponding to Container.First, for a forward - -- iterator). - - -- Otherwise, this is iteration over a partial sequence of items. - -- When the Index component isn't No_Index, the iterator object was - -- constructed with a start expression, that specifies the position - -- from which the (forward) partial iteration begins. - - if Object.Index = No_Index then - return First (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Vector) return Element_Type is - begin - if Checks and then Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - else - return Container.Elements.EA (Index_Type'First); - end if; - end First_Element; - - ----------------- - -- First_Index -- - ----------------- - - function First_Index (Container : Vector) return Index_Type is - pragma Unreferenced (Container); - begin - return Index_Type'First; - end First_Index; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : Vector) return Boolean is - begin - if Container.Last <= Index_Type'First then - return True; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - EA : Elements_Array renames Container.Elements.EA; - begin - for J in Index_Type'First .. Container.Last - 1 loop - if EA (J + 1) < EA (J) then - return False; - end if; - end loop; - - return True; - end; - end Is_Sorted; - - ----------- - -- Merge -- - ----------- - - procedure Merge (Target, Source : in out Vector) is - I : Index_Type'Base := Target.Last; - J : Index_Type'Base; - - begin - -- The semantics of Merge changed slightly per AI05-0021. It was - -- originally the case that if Target and Source denoted the same - -- container object, then the GNAT implementation of Merge did - -- nothing. However, it was argued that RM05 did not precisely - -- specify the semantics for this corner case. The decision of the - -- ARG was that if Target and Source denote the same non-empty - -- container object, then Program_Error is raised. - - if Source.Last < Index_Type'First then -- Source is empty - return; - end if; - - if Checks and then Target'Address = Source'Address then - raise Program_Error with - "Target and Source denote same non-empty container"; - end if; - - if Target.Last < Index_Type'First then -- Target is empty - Move (Target => Target, Source => Source); - return; - end if; - - TC_Check (Source.TC); - - Target.Set_Length (Length (Target) + Length (Source)); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - TA : Elements_Array renames Target.Elements.EA; - SA : Elements_Array renames Source.Elements.EA; - - Lock_Target : With_Lock (Target.TC'Unchecked_Access); - Lock_Source : With_Lock (Source.TC'Unchecked_Access); - begin - J := Target.Last; - while Source.Last >= Index_Type'First loop - pragma Assert (Source.Last <= Index_Type'First - or else not (SA (Source.Last) < - SA (Source.Last - 1))); - - if I < Index_Type'First then - TA (Index_Type'First .. J) := - SA (Index_Type'First .. Source.Last); - - Source.Last := No_Index; - exit; - end if; - - pragma Assert (I <= Index_Type'First - or else not (TA (I) < TA (I - 1))); - - if SA (Source.Last) < TA (I) then - TA (J) := TA (I); - I := I - 1; - - else - TA (J) := SA (Source.Last); - Source.Last := Source.Last - 1; - end if; - - J := J - 1; - end loop; - end; - end Merge; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out Vector) is - procedure Sort is - new Generic_Array_Sort - (Index_Type => Index_Type, - Element_Type => Element_Type, - Array_Type => Elements_Array, - "<" => "<"); - - begin - if Container.Last <= Index_Type'First then - return; - end if; - - -- The exception behavior for the vector container must match that - -- for the list container, so we check for cursor tampering here - -- (which will catch more things) instead of for element tampering - -- (which will catch fewer things). It's true that the elements of - -- this vector container could be safely moved around while (say) an - -- iteration is taking place (iteration only increments the busy - -- counter), and so technically all we would need here is a test for - -- element tampering (indicated by the lock counter), that's simply - -- an artifact of our array-based implementation. Logically Sort - -- requires a check for cursor tampering. - - TC_Check (Container.TC); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); - end; - end Sort; - - end Generic_Sorting; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Container.Elements.EA (Position.Index)'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - New_Last : Index_Type'Base; -- last index of vector after insertion - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - New_Capacity : Count_Type'Base; -- length of new, expanded array - Dst_Last : Index_Type'Base; -- last index of new, expanded array - Dst : Elements_Access; -- new, expanded internal array - - begin - if Checks then - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we - -- do not allow that as the value for Index when specifying where the - -- new items should be inserted, so we must manually check. (That the - -- user is allowed to specify the value at all here is a consequence - -- of the declaration of the Extended_Index subtype, which includes - -- the values in the base range that immediately precede and - -- immediately follow the values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for - -- the case of appending items to the back end of the vector. (It is - -- assumed that specifying an index value greater than Last + 1 - -- indicates some deeper flaw in the caller's algorithm, so that case - -- is treated as a proper error.) - - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note: we cannot simply add these values, because of the possibility - -- of overflow. - - if Checks and then Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if Checks and then New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- New_Last is the last index value of the items in the container after - -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to - -- compute its value from the New_Length. - - if Index_Type'Base'Last >= Count_Type_Last then - New_Last := No_Index + Index_Type'Base (New_Length); - else - New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - - if Container.Elements = null then - pragma Assert (Container.Last = No_Index); - - -- This is the simplest case, with which we must always begin: we're - -- inserting items into an empty vector that hasn't allocated an - -- internal array yet. Note that we don't need to check the busy bit - -- here, because an empty container cannot be busy. - - -- In order to preserve container invariants, we allocate the new - -- internal array first, before setting the Last index value, in case - -- the allocation fails (which can happen either because there is no - -- storage available, or because element initialization fails). - - Container.Elements := new Elements_Type' - (Last => New_Last, - EA => (others => New_Item)); - - -- The allocation of the new, internal array succeeded, so it is now - -- safe to update the Last index, restoring container invariants. - - Container.Last := New_Last; - - return; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - TC_Check (Container.TC); - - -- An internal array has already been allocated, so we must determine - -- whether there is enough unused storage for the new items. - - if New_Length <= Container.Elements.EA'Length then - - -- In this case, we're inserting elements into a vector that has - -- already allocated an internal array, and the existing array has - -- enough unused storage for the new items. - - declare - EA : Elements_Array renames Container.Elements.EA; - - begin - if Before > Container.Last then - - -- The new items are being appended to the vector, so no - -- sliding of existing elements is required. - - EA (Before .. New_Last) := (others => New_Item); - - else - -- The new items are being inserted before some existing - -- elements, so we must slide the existing elements up to their - -- new home. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate index values. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - EA (Index .. New_Last) := EA (Before .. Container.Last); - EA (Before .. Index - 1) := (others => New_Item); - end if; - end; - - Container.Last := New_Last; - return; - end if; - - -- In this case, we're inserting elements into a vector that has already - -- allocated an internal array, but the existing array does not have - -- enough storage, so we must allocate a new, longer array. In order to - -- guarantee that the amortized insertion cost is O(1), we always - -- allocate an array whose length is some power-of-two factor of the - -- current array length. (The new array cannot have a length less than - -- the New_Length of the container, but its last index value cannot be - -- greater than Index_Type'Last.) - - New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); - while New_Capacity < New_Length loop - if New_Capacity > Count_Type'Last / 2 then - New_Capacity := Count_Type'Last; - exit; - else - New_Capacity := 2 * New_Capacity; - end if; - end loop; - - if New_Capacity > Max_Length then - - -- We have reached the limit of capacity, so no further expansion - -- will occur. (This is not a problem, as there is never a need to - -- have more capacity than the maximum container length.) - - New_Capacity := Max_Length; - end if; - - -- We have computed the length of the new internal array (and this is - -- what "vector capacity" means), so use that to compute its last index. - - if Index_Type'Base'Last >= Count_Type_Last then - Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else - Dst_Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); - end if; - - -- Now we allocate the new, longer internal array. If the allocation - -- fails, we have not changed any container state, so no side-effect - -- will occur as a result of propagating the exception. - - Dst := new Elements_Type (Dst_Last); - - -- We have our new internal array. All that needs to be done now is to - -- copy the existing items (if any) from the old array (the "source" - -- array, object SA below) to the new array (the "destination" array, - -- object DA below), and then deallocate the old array. - - declare - SA : Elements_Array renames Container.Elements.EA; -- source - DA : Elements_Array renames Dst.EA; -- destination - - begin - DA (Index_Type'First .. Before - 1) := - SA (Index_Type'First .. Before - 1); - - if Before > Container.Last then - DA (Before .. New_Last) := (others => New_Item); - - else - -- The new items are being inserted before some existing elements, - -- so we must slide the existing elements up to their new home. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - DA (Before .. Index - 1) := (others => New_Item); - DA (Index .. New_Last) := SA (Before .. Container.Last); - end if; - - exception - when others => - Free (Dst); - raise; - end; - - -- We have successfully copied the items onto the new array, so the - -- final thing to do is deallocate the old array. - - declare - X : Elements_Access := Container.Elements; - - begin - -- We first isolate the old internal array, removing it from the - -- container and replacing it with the new internal array, before we - -- deallocate the old array (which can fail if finalization of - -- elements propagates an exception). - - Container.Elements := Dst; - Container.Last := New_Last; - - -- The container invariants have been restored, so it is now safe to - -- attempt to deallocate the old array. - - Free (X); - end; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector) - is - N : constant Count_Type := Length (New_Item); - J : Index_Type'Base; - - begin - -- Use Insert_Space to create the "hole" (the destination slice) into - -- which we copy the source items. - - Insert_Space (Container, Before, Count => N); - - if N = 0 then - - -- There's nothing else to do here (vetting of parameters was - -- performed already in Insert_Space), so we simply return. - - return; - end if; - - -- We calculate the last index value of the destination slice using the - -- wider of Index_Type'Base and count_Type'Base. - - if Index_Type'Base'Last >= Count_Type_Last then - J := (Before - 1) + Index_Type'Base (N); - else - J := Index_Type'Base (Count_Type'Base (Before - 1) + N); - end if; - - if Container'Address /= New_Item'Address then - - -- This is the simple case. New_Item denotes an object different - -- from Container, so there's nothing special we need to do to copy - -- the source items to their destination, because all of the source - -- items are contiguous. - - Container.Elements.EA (Before .. J) := - New_Item.Elements.EA (Index_Type'First .. New_Item.Last); - - return; - end if; - - -- New_Item denotes the same object as Container, so an insertion has - -- potentially split the source items. The destination is always the - -- range [Before, J], but the source is [Index_Type'First, Before) and - -- (J, Container.Last]. We perform the copy in two steps, using each of - -- the two slices of the source items. - - declare - L : constant Index_Type'Base := Before - 1; - - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. L; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - K : Index_Type'Base; - - begin - -- We first copy the source items that precede the space we - -- inserted. Index value K is the last index of that portion - -- destination that receives this slice of the source. (If Before - -- equals Index_Type'First, then this first source slice will be - -- empty, which is harmless.) - - if Index_Type'Base'Last >= Count_Type_Last then - K := L + Index_Type'Base (Src'Length); - else - K := Index_Type'Base (Count_Type'Base (L) + Src'Length); - end if; - - Container.Elements.EA (Before .. K) := Src; - - if Src'Length = N then - - -- The new items were effectively appended to the container, so we - -- have already copied all of the items that need to be copied. - -- We return early here, even though the source slice below is - -- empty (so the assignment would be harmless), because we want to - -- avoid computing J + 1, which will overflow if J equals - -- Index_Type'Base'Last. - - return; - end if; - end; - - declare - -- Note that we want to avoid computing J + 1 here, in case J equals - -- Index_Type'Base'Last. We prevent that by returning early above, - -- immediately after copying the first slice of the source, and - -- determining that this second slice of the source is empty. - - F : constant Index_Type'Base := J + 1; - - subtype Src_Index_Subtype is Index_Type'Base range - F .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - K : Index_Type'Base; - - begin - -- We next copy the source items that follow the space we inserted. - -- Index value K is the first index of that portion of the - -- destination that receives this slice of the source. (For the - -- reasons given above, this slice is guaranteed to be non-empty.) - - if Index_Type'Base'Last >= Count_Type_Last then - K := F - Index_Type'Base (Src'Length); - else - K := Index_Type'Base (Count_Type'Base (F) - Src'Length); - end if; - - Container.Elements.EA (K .. J) := Src; - end; - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector; - Position : out Cursor) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Is_Empty (New_Item) then - if Before.Container = null or else Before.Index > Container.Last then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item); - - Position := (Container'Unrestricted_Access, Index); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - else - Index := Container.Last + 1; - end if; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null or else Before.Index > Container.Last then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - end if; - - Index := Container.Last + 1; - - else - Index := Before.Index; - end if; - - Insert (Container, Index, New_Item, Count); - - Position := (Container'Unrestricted_Access, Index); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - - begin - Insert (Container, Before, New_Item, Count); - end Insert; - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Default-initialized value - pragma Warnings (Off, New_Item); - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - ------------------ - -- Insert_Space -- - ------------------ - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1) - is - Old_Length : constant Count_Type := Container.Length; - - Max_Length : Count_Type'Base; -- determined from range of Index_Type - New_Length : Count_Type'Base; -- sum of current length and Count - New_Last : Index_Type'Base; -- last index of vector after insertion - - Index : Index_Type'Base; -- scratch for intermediate values - J : Count_Type'Base; -- scratch - - New_Capacity : Count_Type'Base; -- length of new, expanded array - Dst_Last : Index_Type'Base; -- last index of new, expanded array - Dst : Elements_Access; -- new, expanded internal array - - begin - if Checks then - -- As a precondition on the generic actual Index_Type, the base type - -- must include Index_Type'Pred (Index_Type'First); this is the value - -- that Container.Last assumes when the vector is empty. However, we - -- do not allow that as the value for Index when specifying where the - -- new items should be inserted, so we must manually check. (That the - -- user is allowed to specify the value at all here is a consequence - -- of the declaration of the Extended_Index subtype, which includes - -- the values in the base range that immediately precede and - -- immediately follow the values in the Index_Type.) - - if Before < Index_Type'First then - raise Constraint_Error with - "Before index is out of range (too small)"; - end if; - - -- We do allow a value greater than Container.Last to be specified as - -- the Index, but only if it's immediately greater. This allows for - -- the case of appending items to the back end of the vector. (It is - -- assumed that specifying an index value greater than Last + 1 - -- indicates some deeper flaw in the caller's algorithm, so that case - -- is treated as a proper error.) - - if Before > Container.Last + 1 then - raise Constraint_Error with - "Before index is out of range (too large)"; - end if; - end if; - - -- We treat inserting 0 items into the container as a no-op, even when - -- the container is busy, so we simply return. - - if Count = 0 then - return; - end if; - - -- There are two constraints we need to satisfy. The first constraint is - -- that a container cannot have more than Count_Type'Last elements, so - -- we must check the sum of the current length and the insertion count. - -- Note: we cannot simply add these values, because of the possibility - -- of overflow. - - if Checks and then Old_Length > Count_Type'Last - Count then - raise Constraint_Error with "Count is out of range"; - end if; - - -- It is now safe compute the length of the new vector, without fear of - -- overflow. - - New_Length := Old_Length + Count; - - -- The second constraint is that the new Last index value cannot exceed - -- Index_Type'Last. In each branch below, we calculate the maximum - -- length (computed from the range of values in Index_Type), and then - -- compare the new length to the maximum length. If the new length is - -- acceptable, then we compute the new last index from that. - - if Index_Type'Base'Last >= Count_Type_Last then - -- We have to handle the case when there might be more values in the - -- range of Index_Type than in the range of Count_Type. - - if Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is - -- less than 0, so it is safe to compute the following sum without - -- fear of overflow. - - Index := No_Index + Index_Type'Base (Count_Type'Last); - - if Index <= Index_Type'Last then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute - -- the difference without fear of overflow (which we would have to - -- worry about if No_Index were less than 0, but that case is - -- handled above). - - if Index_Type'Last - No_Index >= Count_Type_Last then - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the - -- maximum number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than in Count_Type, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := Count_Type'Base (Index_Type'Last - No_Index); - end if; - end if; - - elsif Index_Type'First <= 0 then - - -- We know that No_Index (the same as Index_Type'First - 1) is less - -- than 0, so it is safe to compute the following sum without fear of - -- overflow. - - J := Count_Type'Base (No_Index) + Count_Type'Last; - - if J <= Count_Type'Base (Index_Type'Last) then - - -- We have determined that range of Index_Type has at least as - -- many values as in Count_Type, so Count_Type'Last is the maximum - -- number of items that are allowed. - - Max_Length := Count_Type'Last; - - else - -- The range of Index_Type has fewer values than Count_Type does, - -- so the maximum number of items is computed from the range of - -- the Index_Type. - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - else - -- No_Index is equal or greater than 0, so we can safely compute the - -- difference without fear of overflow (which we would have to worry - -- about if No_Index were less than 0, but that case is handled - -- above). - - Max_Length := - Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); - end if; - - -- We have just computed the maximum length (number of items). We must - -- now compare the requested length to the maximum length, as we do not - -- allow a vector expand beyond the maximum (because that would create - -- an internal array with a last index value greater than - -- Index_Type'Last, with no way to index those elements). - - if Checks and then New_Length > Max_Length then - raise Constraint_Error with "Count is out of range"; - end if; - - -- New_Last is the last index value of the items in the container after - -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to - -- compute its value from the New_Length. - - if Index_Type'Base'Last >= Count_Type_Last then - New_Last := No_Index + Index_Type'Base (New_Length); - else - New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); - end if; - - if Container.Elements = null then - pragma Assert (Container.Last = No_Index); - - -- This is the simplest case, with which we must always begin: we're - -- inserting items into an empty vector that hasn't allocated an - -- internal array yet. Note that we don't need to check the busy bit - -- here, because an empty container cannot be busy. - - -- In order to preserve container invariants, we allocate the new - -- internal array first, before setting the Last index value, in case - -- the allocation fails (which can happen either because there is no - -- storage available, or because default-valued element - -- initialization fails). - - Container.Elements := new Elements_Type (New_Last); - - -- The allocation of the new, internal array succeeded, so it is now - -- safe to update the Last index, restoring container invariants. - - Container.Last := New_Last; - - return; - end if; - - -- The tampering bits exist to prevent an item from being harmfully - -- manipulated while it is being visited. Query, Update, and Iterate - -- increment the busy count on entry, and decrement the count on - -- exit. Insert checks the count to determine whether it is being called - -- while the associated callback procedure is executing. - - TC_Check (Container.TC); - - -- An internal array has already been allocated, so we must determine - -- whether there is enough unused storage for the new items. - - if New_Last <= Container.Elements.Last then - - -- In this case, we're inserting space into a vector that has already - -- allocated an internal array, and the existing array has enough - -- unused storage for the new items. - - declare - EA : Elements_Array renames Container.Elements.EA; - - begin - if Before <= Container.Last then - - -- The space is being inserted before some existing elements, - -- so we must slide the existing elements up to their new - -- home. We use the wider of Index_Type'Base and - -- Count_Type'Base as the type for intermediate index values. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - EA (Index .. New_Last) := EA (Before .. Container.Last); - end if; - end; - - Container.Last := New_Last; - return; - end if; - - -- In this case, we're inserting space into a vector that has already - -- allocated an internal array, but the existing array does not have - -- enough storage, so we must allocate a new, longer array. In order to - -- guarantee that the amortized insertion cost is O(1), we always - -- allocate an array whose length is some power-of-two factor of the - -- current array length. (The new array cannot have a length less than - -- the New_Length of the container, but its last index value cannot be - -- greater than Index_Type'Last.) - - New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); - while New_Capacity < New_Length loop - if New_Capacity > Count_Type'Last / 2 then - New_Capacity := Count_Type'Last; - exit; - end if; - - New_Capacity := 2 * New_Capacity; - end loop; - - if New_Capacity > Max_Length then - - -- We have reached the limit of capacity, so no further expansion - -- will occur. (This is not a problem, as there is never a need to - -- have more capacity than the maximum container length.) - - New_Capacity := Max_Length; - end if; - - -- We have computed the length of the new internal array (and this is - -- what "vector capacity" means), so use that to compute its last index. - - if Index_Type'Base'Last >= Count_Type_Last then - Dst_Last := No_Index + Index_Type'Base (New_Capacity); - else - Dst_Last := - Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); - end if; - - -- Now we allocate the new, longer internal array. If the allocation - -- fails, we have not changed any container state, so no side-effect - -- will occur as a result of propagating the exception. - - Dst := new Elements_Type (Dst_Last); - - -- We have our new internal array. All that needs to be done now is to - -- copy the existing items (if any) from the old array (the "source" - -- array, object SA below) to the new array (the "destination" array, - -- object DA below), and then deallocate the old array. - - declare - SA : Elements_Array renames Container.Elements.EA; -- source - DA : Elements_Array renames Dst.EA; -- destination - - begin - DA (Index_Type'First .. Before - 1) := - SA (Index_Type'First .. Before - 1); - - if Before <= Container.Last then - - -- The space is being inserted before some existing elements, so - -- we must slide the existing elements up to their new home. - - if Index_Type'Base'Last >= Count_Type_Last then - Index := Before + Index_Type'Base (Count); - else - Index := Index_Type'Base (Count_Type'Base (Before) + Count); - end if; - - DA (Index .. New_Last) := SA (Before .. Container.Last); - end if; - - exception - when others => - Free (Dst); - raise; - end; - - -- We have successfully copied the items onto the new array, so the - -- final thing to do is restore invariants, and deallocate the old - -- array. - - declare - X : Elements_Access := Container.Elements; - - begin - -- We first isolate the old internal array, removing it from the - -- container and replacing it with the new internal array, before we - -- deallocate the old array (which can fail if finalization of - -- elements propagates an exception). - - Container.Elements := Dst; - Container.Last := New_Last; - - -- The container invariants have been restored, so it is now safe to - -- attempt to deallocate the old array. - - Free (X); - end; - end Insert_Space; - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - Index : Index_Type'Base; - - begin - if Checks and then Before.Container /= null - and then Before.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Before cursor denotes wrong container"; - end if; - - if Count = 0 then - if Before.Container = null or else Before.Index > Container.Last then - Position := No_Element; - else - Position := (Container'Unrestricted_Access, Before.Index); - end if; - - return; - end if; - - if Before.Container = null or else Before.Index > Container.Last then - if Checks and then Container.Last = Index_Type'Last then - raise Constraint_Error with - "vector is already at its maximum length"; - else - Index := Container.Last + 1; - end if; - - else - Index := Before.Index; - end if; - - Insert_Space (Container, Index, Count); - - Position := (Container'Unrestricted_Access, Index); - end Insert_Space; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Vector) return Boolean is - begin - return Container.Last < Index_Type'First; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - for Indx in Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - end Iterate; - - function Iterate - (Container : Vector) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - begin - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is No_Index (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => No_Index) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate - (Container : Vector; - Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class - is - V : constant Vector_Access := Container'Unrestricted_Access; - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks then - if Start.Container = null then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Start.Container /= V then - raise Program_Error with - "Start cursor of Iterate designates wrong vector"; - end if; - - if Start.Index > V.Last then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - end if; - - -- The value of its Index component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Index - -- component is not No_Index (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with - Container => V, - Index => Start.Index) - do - Busy (Container.TC'Unrestricted_Access.all); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Vector) return Cursor is - begin - if Is_Empty (Container) then - return No_Element; - else - return (Container'Unrestricted_Access, Container.Last); - end if; - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Index component influences the - -- behavior of the Last (and First) selector function. - - -- When the Index component is No_Index, this means the iterator - -- object was constructed without a start expression, in which case the - -- (reverse) iteration starts from the (logical) beginning of the entire - -- sequence (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. - -- When the Index component is not No_Index, the iterator object was - -- constructed with a start expression, that specifies the position - -- from which the (reverse) partial iteration begins. - - if Object.Index = No_Index then - return Last (Object.Container.all); - else - return Cursor'(Object.Container, Object.Index); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Vector) return Element_Type is - begin - if Checks and then Container.Last = No_Index then - raise Constraint_Error with "Container is empty"; - else - return Container.Elements.EA (Container.Last); - end if; - end Last_Element; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index (Container : Vector) return Extended_Index is - begin - return Container.Last; - end Last_Index; - - ------------ - -- Length -- - ------------ - - function Length (Container : Vector) return Count_Type is - L : constant Index_Type'Base := Container.Last; - F : constant Index_Type := Index_Type'First; - - begin - -- The base range of the index type (Index_Type'Base) might not include - -- all values for length (Count_Type). Contrariwise, the index type - -- might include values outside the range of length. Hence we use - -- whatever type is wider for intermediate values when calculating - -- length. Note that no matter what the index type is, the maximum - -- length to which a vector is allowed to grow is always the minimum - -- of Count_Type'Last and (IT'Last - IT'First + 1). - - -- For example, an Index_Type with range -127 .. 127 is only guaranteed - -- to have a base range of -128 .. 127, but the corresponding vector - -- would have lengths in the range 0 .. 255. In this case we would need - -- to use Count_Type'Base for intermediate values. - - -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The - -- vector would have a maximum length of 10, but the index values lie - -- outside the range of Count_Type (which is only 32 bits). In this - -- case we would need to use Index_Type'Base for intermediate values. - - if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then - return Count_Type'Base (L) - Count_Type'Base (F) + 1; - else - return Count_Type (L - F + 1); - end if; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move - (Target : in out Vector; - Source : in out Vector) - is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Target.TC); - TC_Check (Source.TC); - - declare - Target_Elements : constant Elements_Access := Target.Elements; - begin - Target.Elements := Source.Elements; - Source.Elements := Target_Elements; - end; - - Target.Last := Source.Last; - Source.Last := No_Index; - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Position.Index < Position.Container.Last then - return (Position.Container, Position.Index + 1); - else - return No_Element; - end if; - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong vector"; - else - return Next (Position); - end if; - end Next; - - procedure Next (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index < Position.Container.Last then - Position.Index := Position.Index + 1; - else - Position := No_Element; - end if; - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend (Container : in out Vector; New_Item : Vector) is - begin - Insert (Container, Index_Type'First, New_Item); - end Prepend; - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, Index_Type'First, New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Position.Index > Index_Type'First then - return (Position.Container, Position.Index - 1); - else - return No_Element; - end if; - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - elsif Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong vector"; - else - return Previous (Position); - end if; - end Previous; - - procedure Previous (Position : in out Cursor) is - begin - if Position.Container = null then - return; - elsif Position.Index > Index_Type'First then - Position.Index := Position.Index - 1; - else - Position := No_Element; - end if; - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Vector'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)) - is - Lock : With_Lock (Container.TC'Unrestricted_Access); - V : Vector renames Container'Unrestricted_Access.all; - - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - Process (V.Elements.EA (Index)); - end Query_Element; - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - else - Query_Element (Position.Container.all, Position.Index, Process); - end if; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector) - is - Length : Count_Type'Base; - Last : Index_Type'Base := No_Index; - - begin - Clear (Container); - - Count_Type'Base'Read (Stream, Length); - - if Length > Capacity (Container) then - Reserve_Capacity (Container, Capacity => Length); - end if; - - for J in Count_Type range 1 .. Length loop - Last := Last + 1; - Element_Type'Read (Stream, Container.Elements.EA (Last)); - Container.Last := Last; - end loop; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Vector; - Position : Cursor) return Reference_Type - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - if Position.Index > Position.Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Container.Elements.EA (Position.Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Vector; - Index : Index_Type) return Reference_Type - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - declare - TC : constant Tamper_Counts_Access := - Container.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Container.Elements.EA (Index)'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type) - is - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - TE_Check (Container.TC); - Container.Elements.EA (Index) := New_Item; - end Replace_Element; - - procedure Replace_Element - (Container : in out Vector; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - - elsif Position.Index > Container.Last then - raise Constraint_Error with "Position cursor is out of range"; - end if; - end if; - - TE_Check (Container.TC); - Container.Elements.EA (Position.Index) := New_Item; - end Replace_Element; - - ---------------------- - -- Reserve_Capacity -- - ---------------------- - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Count_Type) - is - N : constant Count_Type := Length (Container); - - Index : Count_Type'Base; - Last : Index_Type'Base; - - begin - -- Reserve_Capacity can be used to either expand the storage available - -- for elements (this would be its typical use, in anticipation of - -- future insertion), or to trim back storage. In the latter case, - -- storage can only be trimmed back to the limit of the container - -- length. Note that Reserve_Capacity neither deletes (active) elements - -- nor inserts elements; it only affects container capacity, never - -- container length. - - if Capacity = 0 then - - -- This is a request to trim back storage, to the minimum amount - -- possible given the current state of the container. - - if N = 0 then - - -- The container is empty, so in this unique case we can - -- deallocate the entire internal array. Note that an empty - -- container can never be busy, so there's no need to check the - -- tampering bits. - - declare - X : Elements_Access := Container.Elements; - - begin - -- First we remove the internal array from the container, to - -- handle the case when the deallocation raises an exception. - - Container.Elements := null; - - -- Container invariants have been restored, so it is now safe - -- to attempt to deallocate the internal array. - - Free (X); - end; - - elsif N < Container.Elements.EA'Length then - - -- The container is not empty, and the current length is less than - -- the current capacity, so there's storage available to trim. In - -- this case, we allocate a new internal array having a length - -- that exactly matches the number of items in the - -- container. (Reserve_Capacity does not delete active elements, - -- so this is the best we can do with respect to minimizing - -- storage). - - TC_Check (Container.TC); - - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - X : Elements_Access := Container.Elements; - - begin - -- Although we have isolated the old internal array that we're - -- going to deallocate, we don't deallocate it until we have - -- successfully allocated a new one. If there is an exception - -- during allocation (either because there is not enough - -- storage, or because initialization of the elements fails), - -- we let it propagate without causing any side-effect. - - Container.Elements := new Elements_Type'(Container.Last, Src); - - -- We have successfully allocated a new internal array (with a - -- smaller length than the old one, and containing a copy of - -- just the active elements in the container), so it is now - -- safe to attempt to deallocate the old array. The old array - -- has been isolated, and container invariants have been - -- restored, so if the deallocation fails (because finalization - -- of the elements fails), we simply let it propagate. - - Free (X); - end; - end if; - - return; - end if; - - -- Reserve_Capacity can be used to expand the storage available for - -- elements, but we do not let the capacity grow beyond the number of - -- values in Index_Type'Range. (Were it otherwise, there would be no way - -- to refer to the elements with an index value greater than - -- Index_Type'Last, so that storage would be wasted.) Here we compute - -- the Last index value of the new internal array, in a way that avoids - -- any possibility of overflow. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index - then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Capacity); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Capacity is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Capacity. - - Index := Count_Type'Base (No_Index) + Capacity; -- Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Capacity is out of range"; - end if; - - -- We have determined that the value of Capacity would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); - end if; - - -- The requested capacity is non-zero, but we don't know yet whether - -- this is a request for expansion or contraction of storage. - - if Container.Elements = null then - - -- The container is empty (it doesn't even have an internal array), - -- so this represents a request to allocate (expand) storage having - -- the given capacity. - - Container.Elements := new Elements_Type (Last); - return; - end if; - - if Capacity <= N then - - -- This is a request to trim back storage, but only to the limit of - -- what's already in the container. (Reserve_Capacity never deletes - -- active elements, it only reclaims excess storage.) - - if N < Container.Elements.EA'Length then - - -- The container is not empty (because the requested capacity is - -- positive, and less than or equal to the container length), and - -- the current length is less than the current capacity, so - -- there's storage available to trim. In this case, we allocate a - -- new internal array having a length that exactly matches the - -- number of items in the container. - - TC_Check (Container.TC); - - declare - subtype Src_Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Src_Index_Subtype); - - X : Elements_Access := Container.Elements; - - begin - -- Although we have isolated the old internal array that we're - -- going to deallocate, we don't deallocate it until we have - -- successfully allocated a new one. If there is an exception - -- during allocation (either because there is not enough - -- storage, or because initialization of the elements fails), - -- we let it propagate without causing any side-effect. - - Container.Elements := new Elements_Type'(Container.Last, Src); - - -- We have successfully allocated a new internal array (with a - -- smaller length than the old one, and containing a copy of - -- just the active elements in the container), so it is now - -- safe to attempt to deallocate the old array. The old array - -- has been isolated, and container invariants have been - -- restored, so if the deallocation fails (because finalization - -- of the elements fails), we simply let it propagate. - - Free (X); - end; - end if; - - return; - end if; - - -- The requested capacity is larger than the container length (the - -- number of active elements). Whether this represents a request for - -- expansion or contraction of the current capacity depends on what the - -- current capacity is. - - if Capacity = Container.Elements.EA'Length then - - -- The requested capacity matches the existing capacity, so there's - -- nothing to do here. We treat this case as a no-op, and simply - -- return without checking the busy bit. - - return; - end if; - - -- There is a change in the capacity of a non-empty container, so a new - -- internal array will be allocated. (The length of the new internal - -- array could be less or greater than the old internal array. We know - -- only that the length of the new internal array is greater than the - -- number of active elements in the container.) We must check whether - -- the container is busy before doing anything else. - - TC_Check (Container.TC); - - -- We now allocate a new internal array, having a length different from - -- its current value. - - declare - E : Elements_Access := new Elements_Type (Last); - - begin - -- We have successfully allocated the new internal array. We first - -- attempt to copy the existing elements from the old internal array - -- ("src" elements) onto the new internal array ("tgt" elements). - - declare - subtype Index_Subtype is Index_Type'Base range - Index_Type'First .. Container.Last; - - Src : Elements_Array renames - Container.Elements.EA (Index_Subtype); - - Tgt : Elements_Array renames E.EA (Index_Subtype); - - begin - Tgt := Src; - - exception - when others => - Free (E); - raise; - end; - - -- We have successfully copied the existing elements onto the new - -- internal array, so now we can attempt to deallocate the old one. - - declare - X : Elements_Access := Container.Elements; - - begin - -- First we isolate the old internal array, and replace it in the - -- container with the new internal array. - - Container.Elements := E; - - -- Container invariants have been restored, so it is now safe to - -- attempt to deallocate the old internal array. - - Free (X); - end; - end; - end Reserve_Capacity; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out Vector) is - begin - if Container.Length <= 1 then - return; - end if; - - -- The exception behavior for the vector container must match that for - -- the list container, so we check for cursor tampering here (which will - -- catch more things) instead of for element tampering (which will catch - -- fewer things). It's true that the elements of this vector container - -- could be safely moved around while (say) an iteration is taking place - -- (iteration only increments the busy counter), and so technically - -- all we would need here is a test for element tampering (indicated - -- by the lock counter), that's simply an artifact of our array-based - -- implementation. Logically Reverse_Elements requires a check for - -- cursor tampering. - - TC_Check (Container.TC); - - declare - K : Index_Type; - J : Index_Type; - E : Elements_Type renames Container.Elements.all; - - begin - K := Index_Type'First; - J := Container.Last; - while K < J loop - declare - EK : constant Element_Type := E.EA (K); - begin - E.EA (K) := E.EA (J); - E.EA (J) := EK; - end; - - K := K + 1; - J := J - 1; - end loop; - end; - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Last : Index_Type'Base; - - begin - if Checks and then Position.Container /= null - and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - - Last := - (if Position.Container = null or else Position.Index > Container.Last - then Container.Last - else Position.Index); - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock : With_Lock (Container.TC'Unrestricted_Access); - begin - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) = Item then - return Cursor'(Container'Unrestricted_Access, Indx); - end if; - end loop; - - return No_Element; - end; - end Reverse_Find; - - ------------------------ - -- Reverse_Find_Index -- - ------------------------ - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index - is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Container.TC'Unrestricted_Access); - - Last : constant Index_Type'Base := - Index_Type'Min (Container.Last, Index); - - begin - for Indx in reverse Index_Type'First .. Last loop - if Container.Elements.EA (Indx) = Item then - return Indx; - end if; - end loop; - - return No_Index; - end Reverse_Find_Index; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)) - is - Busy : With_Busy (Container.TC'Unrestricted_Access); - begin - for Indx in reverse Index_Type'First .. Container.Last loop - Process (Cursor'(Container'Unrestricted_Access, Indx)); - end loop; - end Reverse_Iterate; - - ---------------- - -- Set_Length -- - ---------------- - - procedure Set_Length (Container : in out Vector; Length : Count_Type) is - Count : constant Count_Type'Base := Container.Length - Length; - - begin - -- Set_Length allows the user to set the length explicitly, instead - -- of implicitly as a side-effect of deletion or insertion. If the - -- requested length is less than the current length, this is equivalent - -- to deleting items from the back end of the vector. If the requested - -- length is greater than the current length, then this is equivalent - -- to inserting "space" (nonce items) at the end. - - if Count >= 0 then - Container.Delete_Last (Count); - - elsif Checks and then Container.Last >= Index_Type'Last then - raise Constraint_Error with "vector is already at its maximum length"; - - else - Container.Insert_Space (Container.Last + 1, -Count); - end if; - end Set_Length; - - ---------- - -- Swap -- - ---------- - - procedure Swap (Container : in out Vector; I, J : Index_Type) is - begin - if Checks then - if I > Container.Last then - raise Constraint_Error with "I index is out of range"; - end if; - - if J > Container.Last then - raise Constraint_Error with "J index is out of range"; - end if; - end if; - - if I = J then - return; - end if; - - TE_Check (Container.TC); - - declare - EI_Copy : constant Element_Type := Container.Elements.EA (I); - begin - Container.Elements.EA (I) := Container.Elements.EA (J); - Container.Elements.EA (J) := EI_Copy; - end; - end Swap; - - procedure Swap (Container : in out Vector; I, J : Cursor) is - begin - if Checks then - if I.Container = null then - raise Constraint_Error with "I cursor has no element"; - - elsif J.Container = null then - raise Constraint_Error with "J cursor has no element"; - - elsif I.Container /= Container'Unrestricted_Access then - raise Program_Error with "I cursor denotes wrong container"; - - elsif J.Container /= Container'Unrestricted_Access then - raise Program_Error with "J cursor denotes wrong container"; - end if; - end if; - - Swap (Container, I.Index, J.Index); - end Swap; - - --------------- - -- To_Cursor -- - --------------- - - function To_Cursor - (Container : Vector; - Index : Extended_Index) return Cursor - is - begin - if Index not in Index_Type'First .. Container.Last then - return No_Element; - else - return (Container'Unrestricted_Access, Index); - end if; - end To_Cursor; - - -------------- - -- To_Index -- - -------------- - - function To_Index (Position : Cursor) return Extended_Index is - begin - if Position.Container = null then - return No_Index; - elsif Position.Index <= Position.Container.Last then - return Position.Index; - else - return No_Index; - end if; - end To_Index; - - --------------- - -- To_Vector -- - --------------- - - function To_Vector (Length : Count_Type) return Vector is - Index : Count_Type'Base; - Last : Index_Type'Base; - Elements : Elements_Access; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Length) < No_Index - then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - Elements := new Elements_Type (Last); - - return Vector'(Controlled with Elements, Last, TC => <>); - end To_Vector; - - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector - is - Index : Count_Type'Base; - Last : Index_Type'Base; - Elements : Elements_Access; - - begin - if Length = 0 then - return Empty_Vector; - end if; - - -- We create a vector object with a capacity that matches the specified - -- Length, but we do not allow the vector capacity (the length of the - -- internal array) to exceed the number of values in Index_Type'Range - -- (otherwise, there would be no way to refer to those components via an - -- index). We must therefore check whether the specified Length would - -- create a Last index value greater than Index_Type'Last. - - if Index_Type'Base'Last >= Count_Type_Last then - - -- We perform a two-part test. First we determine whether the - -- computed Last value lies in the base range of the type, and then - -- determine whether it lies in the range of the index (sub)type. - - -- Last must satisfy this relation: - -- First + Length - 1 <= Last - -- We regroup terms: - -- First - 1 <= Last - Length - -- Which can rewrite as: - -- No_Index <= Last - Length - - if Checks and then - Index_Type'Base'Last - Index_Type'Base (Length) < No_Index - then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We now know that the computed value of Last is within the base - -- range of the type, so it is safe to compute its value: - - Last := No_Index + Index_Type'Base (Length); - - -- Finally we test whether the value is within the range of the - -- generic actual index subtype: - - if Checks and then Last > Index_Type'Last then - raise Constraint_Error with "Length is out of range"; - end if; - - elsif Index_Type'First <= 0 then - - -- Here we can compute Last directly, in the normal way. We know that - -- No_Index is less than 0, so there is no danger of overflow when - -- adding the (positive) value of Length. - - Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last - - if Checks and then Index > Count_Type'Base (Index_Type'Last) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We know that the computed value (having type Count_Type) of Last - -- is within the range of the generic actual index subtype, so it is - -- safe to convert to Index_Type: - - Last := Index_Type'Base (Index); - - else - -- Here Index_Type'First (and Index_Type'Last) is positive, so we - -- must test the length indirectly (by working backwards from the - -- largest possible value of Last), in order to prevent overflow. - - Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index - - if Checks and then Index < Count_Type'Base (No_Index) then - raise Constraint_Error with "Length is out of range"; - end if; - - -- We have determined that the value of Length would not create a - -- Last index value outside of the range of Index_Type, so we can now - -- safely compute its value. - - Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); - end if; - - Elements := new Elements_Type'(Last, EA => (others => New_Item)); - - return (Controlled with Elements, Last, TC => <>); - end To_Vector; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)) - is - Lock : With_Lock (Container.TC'Unchecked_Access); - begin - if Checks and then Index > Container.Last then - raise Constraint_Error with "Index is out of range"; - end if; - - Process (Container.Elements.EA (Index)); - end Update_Element; - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Checks then - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - elsif Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor denotes wrong container"; - end if; - end if; - - Update_Element (Container, Position.Index, Process); - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector) - is - begin - Count_Type'Base'Write (Stream, Length (Container)); - - for J in Index_Type'First .. Container.Last loop - Element_Type'Write (Stream, Container.Elements.EA (J)); - end loop; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor) - is - begin - raise Program_Error with "attempt to stream vector cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Vectors; diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads deleted file mode 100644 index 5e0de79..0000000 --- a/gcc/ada/a-convec.ads +++ /dev/null @@ -1,518 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . V E C T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Index_Type is range <>; - type Element_Type is private; - - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Vectors is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - subtype Extended_Index is Index_Type'Base - range Index_Type'First - 1 .. - Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; - - No_Index : constant Extended_Index := Extended_Index'First; - - type Vector is tagged private - with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - pragma Preelaborable_Initialization (Vector); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package Vector_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - Empty_Vector : constant Vector; - - overriding function "=" (Left, Right : Vector) return Boolean; - - function To_Vector (Length : Count_Type) return Vector; - - function To_Vector - (New_Item : Element_Type; - Length : Count_Type) return Vector; - - function "&" (Left, Right : Vector) return Vector; - - function "&" (Left : Vector; Right : Element_Type) return Vector; - - function "&" (Left : Element_Type; Right : Vector) return Vector; - - function "&" (Left, Right : Element_Type) return Vector; - - function Capacity (Container : Vector) return Count_Type; - - procedure Reserve_Capacity - (Container : in out Vector; - Capacity : Count_Type); - - function Length (Container : Vector) return Count_Type; - - procedure Set_Length - (Container : in out Vector; - Length : Count_Type); - - function Is_Empty (Container : Vector) return Boolean; - - procedure Clear (Container : in out Vector); - - function To_Cursor - (Container : Vector; - Index : Extended_Index) return Cursor; - - function To_Index (Position : Cursor) return Extended_Index; - - function Element - (Container : Vector; - Index : Index_Type) return Element_Type; - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Vector; - Index : Index_Type; - New_Item : Element_Type); - - procedure Replace_Element - (Container : in out Vector; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Container : Vector; - Index : Index_Type; - Process : not null access procedure (Element : Element_Type)); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Index : Index_Type; - Process : not null access procedure (Element : in out Element_Type)); - - procedure Update_Element - (Container : in out Vector; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Vector; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Vector; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - function Constant_Reference - (Container : aliased Vector; - Index : Index_Type) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Vector; - Index : Index_Type) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Vector; Source : Vector); - - function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; - - procedure Move (Target : in out Vector; Source : in out Vector); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Vector); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Vector; - Position : out Cursor); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Prepend - (Container : in out Vector; - New_Item : Vector); - - procedure Prepend - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Append - (Container : in out Vector; - New_Item : Vector); - - procedure Append - (Container : in out Vector; - New_Item : Element_Type; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Extended_Index; - Count : Count_Type := 1); - - procedure Insert_Space - (Container : in out Vector; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - - procedure Delete - (Container : in out Vector; - Index : Extended_Index; - Count : Count_Type := 1); - - procedure Delete - (Container : in out Vector; - Position : in out Cursor; - Count : Count_Type := 1); - - procedure Delete_First - (Container : in out Vector; - Count : Count_Type := 1); - - procedure Delete_Last - (Container : in out Vector; - Count : Count_Type := 1); - - procedure Reverse_Elements (Container : in out Vector); - - procedure Swap (Container : in out Vector; I, J : Index_Type); - - procedure Swap (Container : in out Vector; I, J : Cursor); - - function First_Index (Container : Vector) return Index_Type; - - function First (Container : Vector) return Cursor; - - function First_Element (Container : Vector) return Element_Type; - - function Last_Index (Container : Vector) return Extended_Index; - - function Last (Container : Vector) return Cursor; - - function Last_Element (Container : Vector) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'First) return Extended_Index; - - function Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Reverse_Find_Index - (Container : Vector; - Item : Element_Type; - Index : Index_Type := Index_Type'Last) return Extended_Index; - - function Reverse_Find - (Container : Vector; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - - function Contains - (Container : Vector; - Item : Element_Type) return Boolean; - - procedure Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Vector; - Process : not null access procedure (Position : Cursor)); - - function Iterate (Container : Vector) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class; - - function Iterate (Container : Vector; Start : Cursor) - return Vector_Iterator_Interfaces.Reversible_Iterator'Class; - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : Vector) return Boolean; - - procedure Sort (Container : in out Vector); - - procedure Merge (Target : in out Vector; Source : in out Vector); - - end Generic_Sorting; - -private - - pragma Inline (Append); - pragma Inline (First_Index); - pragma Inline (Last_Index); - pragma Inline (Element); - pragma Inline (First_Element); - pragma Inline (Last_Element); - pragma Inline (Query_Element); - pragma Inline (Update_Element); - pragma Inline (Replace_Element); - pragma Inline (Is_Empty); - pragma Inline (Contains); - pragma Inline (Next); - pragma Inline (Previous); - - use Ada.Containers.Helpers; - package Implementation is new Generic_Implementation; - use Implementation; - - type Elements_Array is array (Index_Type range <>) of aliased Element_Type; - function "=" (L, R : Elements_Array) return Boolean is abstract; - - type Elements_Type (Last : Extended_Index) is limited record - EA : Elements_Array (Index_Type'First .. Last); - end record; - - type Elements_Access is access all Elements_Type; - - use Finalization; - use Streams; - - type Vector is new Controlled with record - Elements : Elements_Access := null; - Last : Extended_Index := No_Index; - TC : aliased Tamper_Counts; - end record; - - overriding procedure Adjust (Container : in out Vector); - overriding procedure Finalize (Container : in out Vector); - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Vector); - - for Vector'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Vector); - - for Vector'Read use Read; - - type Vector_Access is access all Vector; - for Vector_Access'Storage_Size use 0; - - type Cursor is record - Container : Vector_Access; - Index : Index_Type := Index_Type'First; - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Position : out Cursor); - - for Cursor'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Position : Cursor); - - for Cursor'Write use Write; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Vector'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - No_Element : constant Cursor := Cursor'(null, Index_Type'First); - - Empty_Vector : constant Vector := (Controlled with others => <>); - - type Iterator is new Limited_Controlled and - Vector_Iterator_Interfaces.Reversible_Iterator with - record - Container : Vector_Access; - Index : Index_Type'Base; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Vectors; diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb deleted file mode 100644 index 6083b4c..0000000 --- a/gcc/ada/a-coorma.adb +++ /dev/null @@ -1,1556 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . O R D E R E D _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Red_Black_Trees.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); - -with System; use type System.Address; - -package body Ada.Containers.Ordered_Maps is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------------- - -- Node Access Subprograms -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color (Node : Node_Access) return Color_Type; - pragma Inline (Color); - - function Left (Node : Node_Access) return Node_Access; - pragma Inline (Left); - - function Parent (Node : Node_Access) return Node_Access; - pragma Inline (Parent); - - function Right (Node : Node_Access) return Node_Access; - pragma Inline (Right); - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access); - pragma Inline (Set_Parent); - - procedure Set_Left (Node : Node_Access; Left : Node_Access); - pragma Inline (Set_Left); - - procedure Set_Right (Node : Node_Access; Right : Node_Access); - pragma Inline (Set_Right); - - procedure Set_Color (Node : Node_Access; Color : Color_Type); - pragma Inline (Set_Color); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - procedure Free (X : in out Node_Access); - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Operations (Tree_Types); - - procedure Delete_Tree is - new Tree_Operations.Generic_Delete_Tree (Free); - - function Copy_Tree is - new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); - - use Tree_Operations; - - package Key_Ops is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor of ""<"" is bad"); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor of ""<"" is bad"); - - return Left.Node.Key < Right.Node.Key; - end "<"; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor of ""<"" is bad"); - - return Left.Node.Key < Right; - end "<"; - - function "<" (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor of ""<"" is bad"); - - return Left < Right.Node.Key; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Map) return Boolean is - begin - return Is_Equal (Left.Tree, Right.Tree); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of "">"" equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of "">"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor of "">"" is bad"); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor of "">"" is bad"); - - return Right.Node.Key < Left.Node.Key; - end ">"; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor of "">"" equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "Left cursor of "">"" is bad"); - - return Right < Left.Node.Key; - end ">"; - - function ">" (Left : Key_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor of "">"" equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "Right cursor of "">"" is bad"); - - return Right.Node.Key < Left; - end ">"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust is - new Tree_Operations.Generic_Adjust (Copy_Tree); - - procedure Adjust (Container : in out Map) is - begin - Adjust (Container.Tree); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Map; Source : Map) is - procedure Insert_Item (Node : Node_Access); - pragma Inline (Insert_Item); - - procedure Insert_Items is - new Tree_Operations.Generic_Iteration (Insert_Item); - - ----------------- - -- Insert_Item -- - ----------------- - - procedure Insert_Item (Node : Node_Access) is - begin - Target.Insert (Key => Node.Key, New_Item => Node.Element); - end Insert_Item; - - -- Start of processing for Assign - - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Insert_Items (Source.Tree); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree); - - procedure Clear (Container : in out Map) is - begin - Clear (Container.Tree); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Access) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor in Constant_Reference is bad"); - - declare - T : Tree_Type renames Position.Container.all.Tree; - TC : constant Tamper_Counts_Access := - T.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - TC : constant Tamper_Counts_Access := - T.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Map; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Map) return Map is - begin - return Target : Map do - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - Target : constant Node_Access := - new Node_Type'(Color => Source.Color, - Key => Source.Key, - Element => Source.Element, - Parent => null, - Left => null, - Right => null); - begin - return Target; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Map; Position : in out Cursor) is - Tree : Tree_Type renames Container.Tree; - - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Delete equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Delete designates wrong map"; - end if; - - pragma Assert (Vet (Tree, Position.Node), - "Position cursor of Delete is bad"); - - Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node); - Free (Position.Node); - - Position.Container := null; - end Delete; - - procedure Delete (Container : in out Map; Key : Key_Type) is - X : Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then X = null then - raise Constraint_Error with "key not in map"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Map) is - X : Node_Access := Container.Tree.First; - - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Map) is - X : Node_Access := Container.Tree.Last; - - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Element equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of function Element is bad"); - - return Position.Node.Element; - end Element; - - function Element (Container : Map; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - return Node.Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Map; Key : Key_Type) is - X : Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.Tree.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Map) return Cursor is - T : Tree_Type renames Container.Tree; - begin - if T.First = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, T.First); - end if; - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Object.Container.First; - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Map) return Element_Type is - T : Tree_Type renames Container.Tree; - begin - if Checks and then T.First = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.First.Element; - end First_Element; - - --------------- - -- First_Key -- - --------------- - - function First_Key (Container : Map) return Key_Type is - T : Tree_Type renames Container.Tree; - begin - if Checks and then T.First = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.First.Key; - end First_Key; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Map; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key); - begin - if Node = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, Node); - end if; - end Floor; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X = null then - return; - end if; - - X.Parent := X; - X.Left := X; - X.Right := X; - - Deallocate (X); - end Free; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.Tree.TC); - - Position.Node.Key := Key; - Position.Node.Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return new Node_Type'(Key => Key, - Element => New_Item, - Color => Red_Black_Trees.Red, - Parent => null, - Left => null, - Right => null); - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container.Tree, - Key, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, Key, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with "key already in map"; - end if; - end Insert; - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Key_Ops.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Key_Ops.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return new Node_Type'(Key => Key, - Element => <>, - Color => Red_Black_Trees.Red, - Parent => null, - Left => null, - Right => null); - end New_Node; - - -- Start of processing for Insert - - begin - Insert_Sans_Hint - (Container.Tree, - Key, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Map) return Boolean is - begin - return Container.Tree.Length = 0; - end Is_Empty; - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node - (L, R : Node_Access) return Boolean - is - begin - if L.Key < R.Key then - return False; - elsif R.Key < L.Key then - return False; - else - return L.Element = R.Element; - end if; - end Is_Equal_Node_Node; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - -- Left > Right same as Right < Left - - return Right.Key < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Right.Key; - end Is_Less_Key_Node; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (Container.Tree); - end Iterate; - - function Iterate - (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a - -- complete iterator, meaning that the iteration starts from the - -- (logical) beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null) - do - Busy (Container.Tree.TC'Unrestricted_Access.all); - end return; - end Iterate; - - function Iterate (Container : Map; Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong map"; - end if; - - pragma Assert (Vet (Container.Tree, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this - -- is a partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this - -- is a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node) - do - Busy (Container.Tree.TC'Unrestricted_Access.all); - end return; - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of function Key equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of function Key is bad"); - - return Position.Node.Key; - end Key; - - ---------- - -- Last -- - ---------- - - function Last (Container : Map) return Cursor is - T : Tree_Type renames Container.Tree; - begin - if T.Last = null then - return No_Element; - else - return Cursor'(Container'Unrestricted_Access, T.Last); - end if; - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Object.Container.Last; - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Map) return Element_Type is - T : Tree_Type renames Container.Tree; - begin - if Checks and then T.Last = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.Last.Element; - end Last_Element; - - -------------- - -- Last_Key -- - -------------- - - function Last_Key (Container : Map) return Key_Type is - T : Tree_Type renames Container.Tree; - begin - if Checks and then T.Last = null then - raise Constraint_Error with "map is empty"; - end if; - - return T.Last.Key; - end Last_Key; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Access) return Node_Access is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Map) return Count_Type is - begin - return Container.Tree.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move is - new Tree_Operations.Generic_Move (Clear); - - procedure Move (Target : in out Map; Source : in out Map) is - begin - Move (Target => Target.Tree, Source => Source.Tree); - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of Next is bad"); - - declare - Node : constant Node_Access := Tree_Operations.Next (Position.Node); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - function Next - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong map"; - end if; - - return Next (Position); - end Next; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Access) return Node_Access is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of Previous is bad"); - - declare - Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Previous; - - function Previous - (Object : Iterator; - Position : Cursor) return Cursor - is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong map"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Query_Element equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "Position cursor of Query_Element is bad"); - - declare - T : Tree_Type renames Position.Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map) - is - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - pragma Inline (Read_Node); - - procedure Read is - new Tree_Operations.Generic_Read (Clear, Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - begin - Key_Type'Read (Stream, Node.Key); - Element_Type'Read (Stream, Node.Element); - return Node; - exception - when others => - Free (Node); - raise; - end Read_Node; - - -- Start of processing for Read - - begin - Read (Stream, Container.Tree); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------- - -- Reference -- - --------------- - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with - "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong map"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor in function Reference is bad"); - - declare - T : Tree_Type renames Position.Container.all.Tree; - TC : constant Tamper_Counts_Access := - T.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type - is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - declare - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - TC : constant Tamper_Counts_Access := - T.TC'Unrestricted_Access; - begin - return R : constant Reference_Type := - (Element => Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Reference; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in map"; - end if; - - TE_Check (Container.Tree.TC); - - Node.Key := Key; - Node.Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Replace_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Replace_Element designates wrong map"; - end if; - - TE_Check (Container.Tree.TC); - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor of Replace_Element is bad"); - - Position.Node.Element := New_Item; - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (Container.Tree); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Access) return Node_Access is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color - (Node : Node_Access; - Color : Color_Type) - is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : Node_Access; Left : Node_Access) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : Node_Access; Right : Node_Access) is - begin - Node.Right := Right; - end Set_Right; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access procedure (Key : Key_Type; - Element : in out Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor of Update_Element equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor of Update_Element designates wrong map"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "Position cursor of Update_Element is bad"); - - declare - T : Tree_Type renames Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - K : Key_Type renames Position.Node.Key; - E : Element_Type renames Position.Node.Element; - begin - Process (K, E); - end; - end Update_Element; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - procedure Write is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Key_Type'Write (Stream, Node.Key); - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write (Stream, Container.Tree); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream map cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads deleted file mode 100644 index 3034a2e..0000000 --- a/gcc/ada/a-coorma.ads +++ /dev/null @@ -1,392 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . O R D E R E D _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -private with Ada.Containers.Red_Black_Trees; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Key_Type is private; - type Element_Type is private; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Ordered_Maps is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - type Map is tagged private with - Constant_Indexing => Constant_Reference, - Variable_Indexing => Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Map : constant Map; - - No_Element : constant Cursor; - - function Has_Element (Position : Cursor) return Boolean; - - package Map_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Map) return Boolean; - - function Length (Container : Map) return Count_Type; - - function Is_Empty (Container : Map) return Boolean; - - procedure Clear (Container : in out Map); - - function Key (Position : Cursor) return Key_Type; - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Map; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : Element_Type)); - - procedure Update_Element - (Container : in out Map; - Position : Cursor; - Process : not null access - procedure (Key : Key_Type; Element : in out Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with - Implicit_Dereference => Element; - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Map; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Position : Cursor) return Reference_Type; - pragma Inline (Reference); - - function Constant_Reference - (Container : aliased Map; - Key : Key_Type) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - function Reference - (Container : aliased in out Map; - Key : Key_Type) return Reference_Type; - pragma Inline (Reference); - - procedure Assign (Target : in out Map; Source : Map); - - function Copy (Source : Map) return Map; - - procedure Move (Target : in out Map; Source : in out Map); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Include - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Replace - (Container : in out Map; - Key : Key_Type; - New_Item : Element_Type); - - procedure Exclude (Container : in out Map; Key : Key_Type); - - procedure Delete (Container : in out Map; Key : Key_Type); - - procedure Delete (Container : in out Map; Position : in out Cursor); - - procedure Delete_First (Container : in out Map); - - procedure Delete_Last (Container : in out Map); - - function First (Container : Map) return Cursor; - - function First_Element (Container : Map) return Element_Type; - - function First_Key (Container : Map) return Key_Type; - - function Last (Container : Map) return Cursor; - - function Last_Element (Container : Map) return Element_Type; - - function Last_Key (Container : Map) return Key_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find (Container : Map; Key : Key_Type) return Cursor; - - function Element (Container : Map; Key : Key_Type) return Element_Type; - - function Floor (Container : Map; Key : Key_Type) return Cursor; - - function Ceiling (Container : Map; Key : Key_Type) return Cursor; - - function Contains (Container : Map; Key : Key_Type) return Boolean; - - function "<" (Left, Right : Cursor) return Boolean; - - function ">" (Left, Right : Cursor) return Boolean; - - function "<" (Left : Cursor; Right : Key_Type) return Boolean; - - function ">" (Left : Cursor; Right : Key_Type) return Boolean; - - function "<" (Left : Key_Type; Right : Cursor) return Boolean; - - function ">" (Left : Key_Type; Right : Cursor) return Boolean; - - procedure Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Map; - Process : not null access procedure (Position : Cursor)); - - -- The map container supports iteration in both the forward and reverse - -- directions, hence these constructor functions return an object that - -- supports the Reversible_Iterator interface. - - function Iterate - (Container : Map) - return Map_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : Map; - Start : Cursor) - return Map_Iterator_Interfaces.Reversible_Iterator'class; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type; - type Node_Access is access Node_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Key : Key_Type; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Type, Node_Access); - - type Map is new Ada.Finalization.Controlled with record - Tree : Tree_Types.Tree_Type; - end record; - - overriding procedure Adjust (Container : in out Map); - - overriding procedure Finalize (Container : in out Map) renames Clear; - - use Red_Black_Trees; - use Tree_Types, Tree_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Map); - - for Map'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Map); - - for Map'Read use Read; - - type Map_Access is access all Map; - for Map_Access'Storage_Size use 0; - - type Cursor is record - Container : Map_Access; - Node : Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - type Reference_Type - (Element : not null access Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Map'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Map : constant Map := (Controlled with others => <>); - - No_Element : constant Cursor := Cursor'(null, null); - - type Iterator is new Limited_Controlled and - Map_Iterator_Interfaces.Reversible_Iterator with - record - Container : Map_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/a-coormu.adb b/gcc/ada/a-coormu.adb deleted file mode 100644 index 75969d0..0000000 --- a/gcc/ada/a-coormu.adb +++ /dev/null @@ -1,1895 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Red_Black_Trees.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); - -with System; use type System.Address; - -package body Ada.Containers.Ordered_Multisets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------------- - -- Node Access Subprograms -- - ----------------------------- - - -- These subprograms provide a functional interface to access fields - -- of a node, and a procedural interface for modifying these values. - - function Color (Node : Node_Access) return Color_Type; - pragma Inline (Color); - - function Left (Node : Node_Access) return Node_Access; - pragma Inline (Left); - - function Parent (Node : Node_Access) return Node_Access; - pragma Inline (Parent); - - function Right (Node : Node_Access) return Node_Access; - pragma Inline (Right); - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access); - pragma Inline (Set_Parent); - - procedure Set_Left (Node : Node_Access; Left : Node_Access); - pragma Inline (Set_Left); - - procedure Set_Right (Node : Node_Access; Right : Node_Access); - pragma Inline (Set_Right); - - procedure Set_Color (Node : Node_Access; Color : Color_Type); - pragma Inline (Set_Color); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - procedure Free (X : in out Node_Access); - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access); - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access); - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Less_Node_Node); - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Operations (Tree_Types); - - procedure Delete_Tree is - new Tree_Operations.Generic_Delete_Tree (Free); - - function Copy_Tree is - new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); - - use Tree_Operations; - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - package Element_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - package Set_Ops is - new Generic_Set_Operations - (Tree_Operations => Tree_Operations, - Insert_With_Hint => Insert_With_Hint, - Copy_Tree => Copy_Tree, - Delete_Tree => Delete_Tree, - Is_Less => Is_Less_Node_Node, - Free => Free); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left.Node.Element < Right.Node.Element; - end "<"; - - function "<" (Left : Cursor; Right : Element_Type) - return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - return Left.Node.Element < Right; - end "<"; - - function "<" (Left : Element_Type; Right : Cursor) - return Boolean is - begin - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left < Right.Node.Element; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - return Is_Equal (Left.Tree, Right.Tree); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - -- L > R same as R < L - - return Right.Node.Element < Left.Node.Element; - end ">"; - - function ">" (Left : Cursor; Right : Element_Type) - return Boolean is - begin - if Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - return Right < Left.Node.Element; - end ">"; - - function ">" (Left : Element_Type; Right : Cursor) - return Boolean is - begin - if Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - return Right.Node.Element < Left; - end ">"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); - - procedure Adjust (Container : in out Set) is - begin - Adjust (Container.Tree); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Target.Union (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := - Element_Keys.Ceiling (Container.Tree, Item); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear is - new Tree_Operations.Generic_Clear (Delete_Tree); - - procedure Clear (Container : in out Set) is - begin - Clear (Container.Tree); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Access) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Constant_Reference"); - - -- Note: in predefined container units, the creation of a reference - -- increments the busy bit of the container, and its finalization - -- decrements it. In the absence of control machinery, this tampering - -- protection is missing. - - declare - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - pragma Unreferenced (T); - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element'Unrestricted_Access, - Control => (Container => Container'Unrestricted_Access)) - do - null; - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Item : Element_Type) return Boolean is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set) return Set is - begin - return Target : Set do - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - Target : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Source.Color, - Element => Source.Element); - begin - return Target; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Item : Element_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Element_Keys.Ceiling (Tree, Item); - Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); - X : Node_Access; - - begin - if Node = Done then - raise Constraint_Error with - "attempt to delete element not in set"; - end if; - - loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - - exit when Node = Done; - end loop; - end Delete; - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Delete"); - - Delete_Node_Sans_Free (Container.Tree, Position.Node); - Free (Position.Node); - - Position.Container := null; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.First; - - begin - if X = null then - return; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.Last; - - begin - if X = null then - return; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Difference (Target.Tree, Source.Tree); - end Difference; - - function Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Element"); - - return Position.Node.Element; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is - begin - if L.Element < R.Element then - return False; - elsif R.Element < L.Element then - return False; - else - return True; - end if; - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Tree, Right.Tree); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Element_Keys.Ceiling (Tree, Item); - Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); - X : Node_Access; - begin - while Node /= Done loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end loop; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - Unbusy (Object.Container.Tree.TC); - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := - Element_Keys.Find (Container.Tree, Item); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - if Container.Tree.First = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Container.Tree.First); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Object.Container.First; - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - begin - if Container.Tree.First = null then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Tree.First.Element; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := - Element_Keys.Floor (Container.Tree, Item); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Floor; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - begin - if X /= null then - X.Parent := X; - X.Left := X; - X.Right := X; - - Deallocate (X); - end if; - end Free; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local_Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := - Key_Keys.Ceiling (Container.Tree, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Ceiling; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Key_Keys.Ceiling (Tree, Key); - Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); - X : Node_Access; - - begin - if Node = Done then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - - exit when Node = Done; - end loop; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - begin - if Node = null then - raise Constraint_Error with "key not in set"; - end if; - - return Node.Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - if Left < Right - or else Right < Left - then - return False; - else - return True; - end if; - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - Tree : Tree_Type renames Container.Tree; - Node : Node_Access := Key_Keys.Ceiling (Tree, Key); - Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); - X : Node_Access; - - begin - while Node /= Done loop - X := Node; - Node := Tree_Operations.Next (Node); - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end loop; - end Exclude; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); - - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Node); - end Floor; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean is - begin - return Key (Right.Element) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean is - begin - return Left < Key (Right.Element); - end Is_Less_Key_Node; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Key_Keys.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T, Key); - end Iterate; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Key"); - - return Key (Position.Node.Element); - end Key; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Key_Keys.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T, Key); - end Reverse_Iterate; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - Tree : Tree_Type renames Container.Tree; - Node : constant Node_Access := Position.Node; - - begin - if Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Tree, Node), - "bad cursor in Update_Element"); - - declare - E : Element_Type renames Node.Element; - K : constant Key_Type := Key (E); - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Process (E); - - if Equivalent_Keys (Left => K, Right => Key (E)) then - return; - end if; - end; - - -- Delete_Node checks busy-bit - - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); - - Insert_New_Item : declare - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - Node.Color := Red_Black_Trees.Red; - Node.Parent := null; - Node.Left := null; - Node.Right := null; - - return Node; - end New_Node; - - Result : Node_Access; - - -- Start of processing for Insert_New_Item - - begin - Unconditional_Insert - (Tree => Tree, - Key => Node.Element, - Node => Result); - - pragma Assert (Result = Node); - end Insert_New_Item; - end Update_Element; - - end Generic_Keys; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - pragma Unreferenced (Position); - begin - Insert (Container, New_Item, Position); - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor) - is - begin - Insert_Sans_Hint (Container.Tree, New_Item, Position.Node); - Position.Container := Container'Unrestricted_Access; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - Node : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red_Black_Trees.Red, - Element => New_Item); - begin - return Node; - end New_Node; - - -- Start of processing for Insert_Sans_Hint - - begin - Unconditional_Insert (Tree, New_Item, Node); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Unconditional_Insert_With_Hint - (Insert_Post, - Insert_Sans_Hint); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - Node : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red, - Element => Src_Node.Element); - begin - return Node; - end New_Node; - - -- Start of processing for Insert_With_Hint - - begin - Local_Insert_With_Hint - (Dst_Tree, - Dst_Hint, - Src_Node.Element, - Dst_Node); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - begin - Set_Ops.Intersection (Target.Tree, Source.Tree); - end Intersection; - - function Intersection (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Tree.Length = 0; - end Is_Empty; - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element = R.Element; - end Is_Equal_Node_Node; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - -- e > node same as node < e - - return Right.Element < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Right.Element; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element < R.Element; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - begin - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T); - end Iterate; - - procedure Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Element_Keys.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T, Item); - end Iterate; - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'Class - is - S : constant Set_Access := Container'Unrestricted_Access; - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - return It : constant Iterator := (Limited_Controlled with S, null) do - Busy (S.Tree.TC); - end return; - end Iterate; - - function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'Class - is - S : constant Set_Access := Container'Unrestricted_Access; - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this is a - -- partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this is - -- a forward or reverse iteration. - - return It : constant Iterator := - (Limited_Controlled with S, Start.Node) - do - Busy (S.Tree.TC); - end return; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - if Container.Tree.Last = null then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Object.Container.Last; - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Container.Tree.Last = null then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Tree.Last.Element; - end Last_Element; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Access) return Node_Access is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Tree.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move is - new Tree_Operations.Generic_Move (Clear); - - procedure Move (Target : in out Set; Source : in out Set) is - begin - Move (Target => Target.Tree, Source => Source.Tree); - end Move; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) - is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Next"); - - declare - Node : constant Node_Access := Tree_Operations.Next (Position.Node); - begin - if Node = null then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - begin - return Set_Ops.Overlap (Left.Tree, Right.Tree); - end Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Access) return Node_Access is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) - is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong set"; - end if; - - return Previous (Position); - end Previous; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Query_Element"); - - declare - T : Tree_Type renames Position.Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Position.Node.Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - pragma Inline (Read_Node); - - procedure Read is - new Tree_Operations.Generic_Read (Clear, Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - begin - Element_Type'Read (Stream, Node.Element); - return Node; - exception - when others => - Free (Node); -- Note that Free deallocates elem too - raise; - end Read_Node; - - -- Start of processing for Read - - begin - Read (Stream, Container.Tree); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type) - is - begin - if Item < Node.Element - or else Node.Element < Item - then - null; - else - TE_Check (Tree.TC); - - Node.Element := Item; - return; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - - Insert_New_Item : declare - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Unconditional_Insert is - new Element_Keys.Generic_Unconditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - Node.Element := Item; - Node.Color := Red_Black_Trees.Red; - Node.Parent := null; - Node.Left := null; - Node.Right := null; - - return Node; - end New_Node; - - Result : Node_Access; - - -- Start of processing for Insert_New_Item - - begin - Unconditional_Insert - (Tree => Tree, - Key => Item, - Node => Result); - - pragma Assert (Result = Node); - end Insert_New_Item; - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container.Tree, Position.Node, New_Item); - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T); - end Reverse_Iterate; - - procedure Reverse_Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Element_Keys.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T, Item); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Access) return Node_Access is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : Node_Access; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : Node_Access; Left : Node_Access) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : Node_Access; Right : Node_Access) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Tree : Tree_Type; - Node : Node_Access; - pragma Unreferenced (Node); - begin - Insert_Sans_Hint (Tree, New_Item, Node); - return Set'(Controlled with Tree); - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - begin - Set_Ops.Union (Target.Tree, Source.Tree); - end Union; - - function Union (Left, Right : Set) return Set is - Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Union; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - procedure Write is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write (Stream, Container.Tree); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; -end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coormu.ads b/gcc/ada/a-coormu.ads deleted file mode 100644 index 5fd8a81..0000000 --- a/gcc/ada/a-coormu.ads +++ /dev/null @@ -1,570 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- The ordered multiset container is similar to the ordered set, but with the --- difference that multiple equivalent elements are allowed. It also provides --- additional operations, to iterate over items that are equivalent. - -private with Ada.Containers.Red_Black_Trees; -private with Ada.Finalization; -private with Ada.Streams; -with Ada.Iterator_Interfaces; - -generic - type Element_Type is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Ordered_Multisets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean; - -- Returns False if Left is less than Right, or Right is less than Left; - -- otherwise, it returns True. - - type Set is tagged private - with Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_Set : constant Set; - -- The default value for set objects declared without an explicit - -- initialization expression. - - No_Element : constant Cursor; - -- The default value for cursor objects declared without an explicit - -- initialization expression. - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - -- If Left denotes the same set object as Right, then equality returns - -- True. If the length of Left is different from the length of Right, then - -- it returns False. Otherwise, set equality iterates over Left and Right, - -- comparing the element of Left to the element of Right using the equality - -- operator for elements. If the elements compare False, then the iteration - -- terminates and set equality returns False. Otherwise, if all elements - -- compare True, then set equality returns True. - - function Equivalent_Sets (Left, Right : Set) return Boolean; - -- Similar to set equality, but with the difference that elements are - -- compared for equivalence instead of equality. - - function To_Set (New_Item : Element_Type) return Set; - -- Constructs a set object with New_Item as its single element - - function Length (Container : Set) return Count_Type; - -- Returns the total number of elements in Container - - function Is_Empty (Container : Set) return Boolean; - -- Returns True if Container.Length is 0 - - procedure Clear (Container : in out Set); - -- Deletes all elements from Container - - function Element (Position : Cursor) return Element_Type; - -- If Position equals No_Element, then Constraint_Error is raised. - -- Otherwise, function Element returns the element designed by Position. - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - -- If Position equals No_Element, then Constraint_Error is raised. If - -- Position is associated with a set different from Container, then - -- Program_Error is raised. If New_Item is equivalent to the element - -- designated by Position, then if Container is locked (element tampering - -- has been attempted), Program_Error is raised; otherwise, the element - -- designated by Position is assigned the value of New_Item. If New_Item is - -- not equivalent to the element designated by Position, then if the - -- container is busy (cursor tampering has been attempted), Program_Error - -- is raised; otherwise, the element designed by Position is assigned the - -- value of New_Item, and the node is moved to its new position (in - -- canonical insertion order). - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - -- If Position equals No_Element, then Constraint_Error is - -- raised. Otherwise, it calls Process with the element designated by - -- Position as the parameter. This call locks the container, so attempts to - -- change the value of the element while Process is executing (to "tamper - -- with elements") will raise Program_Error. - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is private - with Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set) return Set; - - procedure Move (Target : in out Set; Source : in out Set); - -- If Target denotes the same object as Source, the operation does - -- nothing. If either Target or Source is busy (cursor tampering is - -- attempted), then it raises Program_Error. Otherwise, Target is cleared, - -- and the nodes from Source are moved (not copied) to Target (so Source - -- becomes empty). - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor); - -- Insert adds New_Item to Container, and returns cursor Position - -- designating the newly inserted node. The node is inserted after any - -- existing elements less than or equivalent to New_Item (and before any - -- elements greater than New_Item). Note that the issue of where the new - -- node is inserted relative to equivalent elements does not arise for - -- unique-key containers, since in that case the insertion would simply - -- fail. For a multiple-key container (the case here), insertion always - -- succeeds, and is defined such that the new item is positioned after any - -- equivalent elements already in the container. - - procedure Insert - (Container : in out Set; - New_Item : Element_Type); - -- Inserts New_Item in Container, but does not return a cursor designating - -- the newly-inserted node. - --- TODO: include Replace too??? --- --- procedure Replace --- (Container : in out Set; --- New_Item : Element_Type); - - procedure Exclude - (Container : in out Set; - Item : Element_Type); - -- Deletes from Container all of the elements equivalent to Item - - procedure Delete - (Container : in out Set; - Item : Element_Type); - -- Deletes from Container all of the elements equivalent to Item. If there - -- are no elements equivalent to Item, then it raises Constraint_Error. - - procedure Delete - (Container : in out Set; - Position : in out Cursor); - -- If Position equals No_Element, then Constraint_Error is raised. If - -- Position is associated with a set different from Container, then - -- Program_Error is raised. Otherwise, the node designated by Position is - -- removed from Container, and Position is set to No_Element. - - procedure Delete_First (Container : in out Set); - -- Removes the first node from Container - - procedure Delete_Last (Container : in out Set); - -- Removes the last node from Container - - procedure Union (Target : in out Set; Source : Set); - -- If Target is busy (cursor tampering is attempted), the Program_Error is - -- raised. Otherwise, it inserts each element of Source into - -- Target. Elements are inserted in the canonical order for multisets, such - -- that the elements from Source are inserted after equivalent elements - -- already in Target. - - function Union (Left, Right : Set) return Set; - -- Returns a set comprising the all elements from Left and all of the - -- elements from Right. The elements from Right follow the equivalent - -- elements from Left. - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - -- If Target denotes the same object as Source, the operation does - -- nothing. If Target is busy (cursor tampering is attempted), - -- Program_Error is raised. Otherwise, the elements in Target having no - -- equivalent element in Source are deleted from Target. - - function Intersection (Left, Right : Set) return Set; - -- If Left denotes the same object as Right, then the function returns a - -- copy of Left. Otherwise, it returns a set comprising the equivalent - -- elements from both Left and Right. Items are inserted in the result set - -- in canonical order, such that the elements from Left precede the - -- equivalent elements from Right. - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - -- If Target is busy (cursor tampering is attempted), then Program_Error is - -- raised. Otherwise, the elements in Target that are equivalent to - -- elements in Source are deleted from Target. - - function Difference (Left, Right : Set) return Set; - -- Returns a set comprising the elements from Left that have no equivalent - -- element in Right. - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - -- If Target is busy, then Program_Error is raised. Otherwise, the elements - -- in Target equivalent to elements in Source are deleted from Target, and - -- the elements in Source not equivalent to elements in Target are inserted - -- into Target. - - function Symmetric_Difference (Left, Right : Set) return Set; - -- Returns a set comprising the union of the elements from Target having no - -- equivalent in Source, and the elements of Source having no equivalent in - -- Target. - - function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - -- Returns True if Left contains an element equivalent to an element of - -- Right. - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - -- Returns True if every element in Subset has an equivalent element in - -- Of_Set. - - function First (Container : Set) return Cursor; - -- If Container is empty, the function returns No_Element. Otherwise, it - -- returns a cursor designating the smallest element. - - function First_Element (Container : Set) return Element_Type; - -- Equivalent to Element (First (Container)) - - function Last (Container : Set) return Cursor; - -- If Container is empty, the function returns No_Element. Otherwise, it - -- returns a cursor designating the largest element. - - function Last_Element (Container : Set) return Element_Type; - -- Equivalent to Element (Last (Container)) - - function Next (Position : Cursor) return Cursor; - -- If Position equals No_Element or Last (Container), the function returns - -- No_Element. Otherwise, it returns a cursor designating the node that - -- immediately follows (as per the insertion order) the node designated by - -- Position. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Previous (Position : Cursor) return Cursor; - -- If Position equals No_Element or First (Container), the function returns - -- No_Element. Otherwise, it returns a cursor designating the node that - -- immediately precedes (as per the insertion order) the node designated by - -- Position. - - procedure Previous (Position : in out Cursor); - -- Equivalent to Position := Previous (Position) - - function Find (Container : Set; Item : Element_Type) return Cursor; - -- Returns a cursor designating the first element in Container equivalent - -- to Item. If there is no equivalent element, it returns No_Element. - - function Floor (Container : Set; Item : Element_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to elements in Container, it returns a cursor designating the - -- first equivalent element. Otherwise, it returns a cursor designating the - -- largest element less than Item, or No_Element if all elements are - -- greater than Item. - - function Ceiling (Container : Set; Item : Element_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to elements of Container, it returns a cursor designating the - -- last equivalent element. Otherwise, it returns a cursor designating the - -- smallest element greater than Item, or No_Element if all elements are - -- less than Item. - - function Contains (Container : Set; Item : Element_Type) return Boolean; - -- Equivalent to Container.Find (Item) /= No_Element - - function "<" (Left, Right : Cursor) return Boolean; - -- Equivalent to Element (Left) < Element (Right) - - function ">" (Left, Right : Cursor) return Boolean; - -- Equivalent to Element (Right) < Element (Left) - - function "<" (Left : Cursor; Right : Element_Type) return Boolean; - -- Equivalent to Element (Left) < Right - - function ">" (Left : Cursor; Right : Element_Type) return Boolean; - -- Equivalent to Right < Element (Left) - - function "<" (Left : Element_Type; Right : Cursor) return Boolean; - -- Equivalent to Left < Element (Right) - - function ">" (Left : Element_Type; Right : Cursor) return Boolean; - -- Equivalent to Element (Right) < Left - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - -- Calls Process with a cursor designating each element of Container, in - -- order from Container.First to Container.Last. - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - -- Calls Process with a cursor designating each element of Container, in - -- order from Container.Last to Container.First. - - procedure Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to Item, - -- in order from Container.Floor (Item) to Container.Ceiling (Item). - - procedure Reverse_Iterate - (Container : Set; - Item : Element_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to Item, - -- in order from Container.Ceiling (Item) to Container.Floor (Item). - - function Iterate - (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : Set; - Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - -- Returns False if Left is less than Right, or Right is less than Left; - -- otherwise, it returns True. - - function Key (Position : Cursor) return Key_Type; - -- Equivalent to Key (Element (Position)) - - function Element (Container : Set; Key : Key_Type) return Element_Type; - -- Equivalent to Element (Find (Container, Key)) - - procedure Exclude (Container : in out Set; Key : Key_Type); - -- Deletes from Container any elements whose key is equivalent to Key - - procedure Delete (Container : in out Set; Key : Key_Type); - -- Deletes from Container any elements whose key is equivalent to - -- Key. If there are no such elements, then it raises Constraint_Error. - - function Find (Container : Set; Key : Key_Type) return Cursor; - -- Returns a cursor designating the first element in Container whose key - -- is equivalent to Key. If there is no equivalent element, it returns - -- No_Element. - - function Floor (Container : Set; Key : Key_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to the keys of elements in Container, it returns a cursor - -- designating the first such element. Otherwise, it returns a cursor - -- designating the largest element whose key is less than Item, or - -- No_Element if all keys are greater than Item. - - function Ceiling (Container : Set; Key : Key_Type) return Cursor; - -- If Container is empty, the function returns No_Element. If Item is - -- equivalent to the keys of elements of Container, it returns a cursor - -- designating the last such element. Otherwise, it returns a cursor - -- designating the smallest element whose key is greater than Item, or - -- No_Element if all keys are less than Item. - - function Contains (Container : Set; Key : Key_Type) return Boolean; - -- Equivalent to Find (Container, Key) /= No_Element - - procedure Update_Element -- Update_Element_Preserving_Key ??? - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - -- If Position equals No_Element, then Constraint_Error is raised. If - -- Position is associated with a set object different from Container, - -- then Program_Error is raised. Otherwise, it makes a copy of the key - -- of the element designated by Position, and then calls Process with - -- the element as the parameter. Update_Element then compares the key - -- value obtained before calling Process to the key value obtained from - -- the element after calling Process. If the keys are equivalent then - -- the operation terminates. If Container is busy (cursor tampering has - -- been attempted), then Program_Error is raised. Otherwise, the node - -- is moved to its new position (in canonical order). - - procedure Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to - -- Key, in order from Floor (Container, Key) to - -- Ceiling (Container, Key). - - procedure Reverse_Iterate - (Container : Set; - Key : Key_Type; - Process : not null access procedure (Position : Cursor)); - -- Call Process with a cursor designating each element equivalent to - -- Key, in order from Ceiling (Container, Key) to - -- Floor (Container, Key). - - end Generic_Keys; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type; - type Node_Access is access Node_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Element : Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Type, Node_Access); - - type Set is new Ada.Finalization.Controlled with record - Tree : Tree_Types.Tree_Type; - end record; - - overriding procedure Adjust (Container : in out Set); - - overriding procedure Finalize (Container : in out Set) renames Clear; - - use Red_Black_Trees; - use Tree_Types, Tree_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - -- In all predefined libraries the following type is controlled, for proper - -- management of tampering checks. For performance reason we omit this - -- machinery for multisets, which are used in a number of our tools. - - type Reference_Control_Type is record - Container : Set_Access; - end record; - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - type Cursor is record - Container : Set_Access; - Node : Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - No_Element : constant Cursor := Cursor'(null, null); - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - Empty_Set : constant Set := (Controlled with others => <>); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb deleted file mode 100644 index 78345c9..0000000 --- a/gcc/ada/a-coorse.adb +++ /dev/null @@ -1,1999 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . O R D E R E D _ S E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with Ada.Containers.Helpers; use Ada.Containers.Helpers; - -with Ada.Containers.Red_Black_Trees.Generic_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); - -with Ada.Containers.Red_Black_Trees.Generic_Keys; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); - -with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; -pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); - -with System; use type System.Address; - -package body Ada.Containers.Ordered_Sets is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ------------------------------ - -- Access to Fields of Node -- - ------------------------------ - - -- These subprograms provide functional notation for access to fields - -- of a node, and procedural notation for modifying these fields. - - function Color (Node : Node_Access) return Color_Type; - pragma Inline (Color); - - function Left (Node : Node_Access) return Node_Access; - pragma Inline (Left); - - function Parent (Node : Node_Access) return Node_Access; - pragma Inline (Parent); - - function Right (Node : Node_Access) return Node_Access; - pragma Inline (Right); - - procedure Set_Color (Node : Node_Access; Color : Color_Type); - pragma Inline (Set_Color); - - procedure Set_Left (Node : Node_Access; Left : Node_Access); - pragma Inline (Set_Left); - - procedure Set_Right (Node : Node_Access; Right : Node_Access); - pragma Inline (Set_Right); - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access); - pragma Inline (Set_Parent); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Copy_Node (Source : Node_Access) return Node_Access; - pragma Inline (Copy_Node); - - procedure Free (X : in out Node_Access); - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean); - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access); - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equal_Node_Node); - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Element_Node); - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Element_Node); - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Less_Node_Node); - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Tree_Operations is - new Red_Black_Trees.Generic_Operations (Tree_Types); - - procedure Delete_Tree is - new Tree_Operations.Generic_Delete_Tree (Free); - - function Copy_Tree is - new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); - - use Tree_Operations; - - function Is_Equal is - new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); - - package Element_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Element_Type, - Is_Less_Key_Node => Is_Less_Element_Node, - Is_Greater_Key_Node => Is_Greater_Element_Node); - - package Set_Ops is - new Generic_Set_Operations - (Tree_Operations => Tree_Operations, - Insert_With_Hint => Insert_With_Hint, - Copy_Tree => Copy_Tree, - Delete_Tree => Delete_Tree, - Is_Less => Is_Less_Node_Node, - Free => Free); - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left.Node.Element < Right.Node.Element; - end "<"; - - function "<" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in ""<"""); - - return Left.Node.Element < Right; - end "<"; - - function "<" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in ""<"""); - - return Left < Right.Node.Element; - end "<"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Set) return Boolean is - begin - return Is_Equal (Left.Tree, Right.Tree); - end "="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Cursor) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - -- L > R same as R < L - - return Right.Node.Element < Left.Node.Element; - end ">"; - - function ">" (Left : Element_Type; Right : Cursor) return Boolean is - begin - if Checks and then Right.Node = null then - raise Constraint_Error with "Right cursor equals No_Element"; - end if; - - pragma Assert (Vet (Right.Container.Tree, Right.Node), - "bad Right cursor in "">"""); - - return Right.Node.Element < Left; - end ">"; - - function ">" (Left : Cursor; Right : Element_Type) return Boolean is - begin - if Checks and then Left.Node = null then - raise Constraint_Error with "Left cursor equals No_Element"; - end if; - - pragma Assert (Vet (Left.Container.Tree, Left.Node), - "bad Left cursor in "">"""); - - return Right < Left.Node.Element; - end ">"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); - - procedure Adjust (Container : in out Set) is - begin - Adjust (Container.Tree); - end Adjust; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out Set; Source : Set) is - begin - if Target'Address = Source'Address then - return; - end if; - - Target.Clear; - Target.Union (Source); - end Assign; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := - Element_Keys.Ceiling (Container.Tree, Item); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Ceiling; - - ----------- - -- Clear -- - ----------- - - procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree); - - procedure Clear (Container : in out Set) is - begin - Clear (Container.Tree); - end Clear; - - ----------- - -- Color -- - ----------- - - function Color (Node : Node_Access) return Color_Type is - begin - return Node.Color; - end Color; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert - (Vet (Container.Tree, Position.Node), - "bad cursor in Constant_Reference"); - - declare - Tree : Tree_Type renames Position.Container.all.Tree; - TC : constant Tamper_Counts_Access := - Tree.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Position.Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : Set; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Set) return Set is - begin - return Target : Set do - Target.Assign (Source); - end return; - end Copy; - - --------------- - -- Copy_Node -- - --------------- - - function Copy_Node (Source : Node_Access) return Node_Access is - Target : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Source.Color, - Element => Source.Element); - begin - return Target; - end Copy_Node; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Position : in out Cursor) is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Delete"); - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); - Free (Position.Node); - Position.Container := null; - end Delete; - - procedure Delete (Container : in out Set; Item : Element_Type) is - X : Node_Access := Element_Keys.Find (Container.Tree, Item); - - begin - if Checks and then X = null then - raise Constraint_Error with "attempt to delete element not in set"; - end if; - - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.First; - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end if; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last (Container : in out Set) is - Tree : Tree_Type renames Container.Tree; - X : Node_Access := Tree.Last; - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end if; - end Delete_Last; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Difference (Target.Tree, Source.Tree); - end Difference; - - function Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Difference; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Element"); - - return Position.Node.Element; - end Element; - - ------------------------- - -- Equivalent_Elements -- - ------------------------- - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean is - begin - return (if Left < Right or else Right < Left then False else True); - end Equivalent_Elements; - - --------------------- - -- Equivalent_Sets -- - --------------------- - - function Equivalent_Sets (Left, Right : Set) return Boolean is - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; - pragma Inline (Is_Equivalent_Node_Node); - - function Is_Equivalent is - new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); - - ----------------------------- - -- Is_Equivalent_Node_Node -- - ----------------------------- - - function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is - begin - return (if L.Element < R.Element then False - elsif R.Element < L.Element then False - else True); - end Is_Equivalent_Node_Node; - - -- Start of processing for Equivalent_Sets - - begin - return Is_Equivalent (Left.Tree, Right.Tree); - end Equivalent_Sets; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Item : Element_Type) is - X : Node_Access := Element_Keys.Find (Container.Tree, Item); - - begin - if X /= null then - Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Iterator) is - begin - if Object.Container /= null then - Unbusy (Object.Container.Tree.TC); - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : Set) return Cursor is - begin - return - (if Container.Tree.First = null then No_Element - else Cursor'(Container'Unrestricted_Access, Container.Tree.First)); - end First; - - function First (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the First (and Last) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (forward) - -- iteration starts from the (logical) beginning of the entire sequence - -- of items (corresponding to Container.First, for a forward iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (forward) partial iteration begins. - - if Object.Node = null then - return Object.Container.First; - else - return Cursor'(Object.Container, Object.Node); - end if; - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : Set) return Element_Type is - begin - if Checks and then Container.Tree.First = null then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Tree.First.Element; - end First_Element; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Item : Element_Type) return Cursor is - Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Floor; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Node_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - begin - if X /= null then - X.Parent := X; - X.Left := X; - X.Right := X; - Deallocate (X); - end if; - end Free; - - ------------------ - -- Generic_Keys -- - ------------------ - - package body Generic_Keys is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Greater_Key_Node); - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean; - pragma Inline (Is_Less_Key_Node); - - -------------------------- - -- Local Instantiations -- - -------------------------- - - package Key_Keys is - new Red_Black_Trees.Generic_Keys - (Tree_Operations => Tree_Operations, - Key_Type => Key_Type, - Is_Less_Key_Node => Is_Less_Key_Node, - Is_Greater_Key_Node => Is_Greater_Key_Node); - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Ceiling; - - ------------------------ - -- Constant_Reference -- - ------------------------ - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type - is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in set"; - end if; - - declare - Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; - TC : constant Tamper_Counts_Access := - Tree.TC'Unrestricted_Access; - begin - return R : constant Constant_Reference_Type := - (Element => Node.Element'Access, - Control => (Controlled with TC)) - do - Lock (TC.all); - end return; - end; - end Constant_Reference; - - -------------- - -- Contains -- - -------------- - - function Contains (Container : Set; Key : Key_Type) return Boolean is - begin - return Find (Container, Key) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete (Container : in out Set; Key : Key_Type) is - X : Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then X = null then - raise Constraint_Error with "attempt to delete key not in set"; - end if; - - Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end Delete; - - ------------- - -- Element -- - ------------- - - function Element (Container : Set; Key : Key_Type) return Element_Type is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "key not in set"; - end if; - - return Node.Element; - end Element; - - --------------------- - -- Equivalent_Keys -- - --------------------- - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean is - begin - return (if Left < Right or else Right < Left then False else True); - end Equivalent_Keys; - - ------------- - -- Exclude -- - ------------- - - procedure Exclude (Container : in out Set; Key : Key_Type) is - X : Node_Access := Key_Keys.Find (Container.Tree, Key); - begin - if X /= null then - Delete_Node_Sans_Free (Container.Tree, X); - Free (X); - end if; - end Exclude; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Control : in out Reference_Control_Type) is - begin - if Control.Container /= null then - Impl.Reference_Control_Type (Control).Finalize; - - if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) - then - Delete (Control.Container.all, Key (Control.Pos)); - raise Program_Error; - end if; - - Control.Container := null; - Control.Old_Key := null; - end if; - end Finalize; - - ---------- - -- Find -- - ---------- - - function Find (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Container : Set; Key : Key_Type) return Cursor is - Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); - begin - return (if Node = null then No_Element - else Cursor'(Container'Unrestricted_Access, Node)); - end Floor; - - ------------------------- - -- Is_Greater_Key_Node -- - ------------------------- - - function Is_Greater_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - return Key (Right.Element) < Left; - end Is_Greater_Key_Node; - - ---------------------- - -- Is_Less_Key_Node -- - ---------------------- - - function Is_Less_Key_Node - (Left : Key_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Key (Right.Element); - end Is_Less_Key_Node; - - --------- - -- Key -- - --------- - - function Key (Position : Cursor) return Key_Type is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Key"); - - return Key (Position.Node.Element); - end Key; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------------------------ - -- Reference_Preserving_Key -- - ------------------------------ - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type - is - begin - if Checks and then Position.Container = null then - raise Constraint_Error with "Position cursor has no element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong container"; - end if; - - pragma Assert - (Vet (Container.Tree, Position.Node), - "bad cursor in function Reference_Preserving_Key"); - - declare - Tree : Tree_Type renames Container.Tree; - begin - return R : constant Reference_Type := - (Element => Position.Node.Element'Access, - Control => - (Controlled with - Tree.TC'Unrestricted_Access, - Container => Container'Access, - Pos => Position, - Old_Key => new Key_Type'(Key (Position)))) - do - Lock (Tree.TC); - end return; - end; - end Reference_Preserving_Key; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type - is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with "Key not in set"; - end if; - - declare - Tree : Tree_Type renames Container.Tree; - begin - return R : constant Reference_Type := - (Element => Node.Element'Access, - Control => - (Controlled with - Tree.TC'Unrestricted_Access, - Container => Container'Access, - Pos => Find (Container, Key), - Old_Key => new Key_Type'(Key))) - do - Lock (Tree.TC); - end return; - end; - end Reference_Preserving_Key; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type) - is - Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace key not in set"; - end if; - - Replace_Element (Container.Tree, Node, New_Item); - end Replace; - - ----------------------------------- - -- Update_Element_Preserving_Key -- - ----------------------------------- - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - Tree : Tree_Type renames Container.Tree; - - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Update_Element_Preserving_Key"); - - declare - E : Element_Type renames Position.Node.Element; - K : constant Key_Type := Key (E); - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Process (E); - if Equivalent_Keys (K, Key (E)) then - return; - end if; - end; - - declare - X : Node_Access := Position.Node; - begin - Tree_Operations.Delete_Node_Sans_Free (Tree, X); - Free (X); - end; - - raise Program_Error with "key was modified"; - end Update_Element_Preserving_Key; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - - end Generic_Keys; - - ------------------------ - -- Get_Element_Access -- - ------------------------ - - function Get_Element_Access - (Position : Cursor) return not null Element_Access is - begin - return Position.Node.Element'Access; - end Get_Element_Access; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - return Position /= No_Element; - end Has_Element; - - ------------- - -- Include -- - ------------- - - procedure Include (Container : in out Set; New_Item : Element_Type) is - Position : Cursor; - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if not Inserted then - TE_Check (Container.Tree.TC); - - Position.Node.Element := New_Item; - end if; - end Include; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean) - is - begin - Insert_Sans_Hint - (Container.Tree, - New_Item, - Position.Node, - Inserted); - - Position.Container := Container'Unrestricted_Access; - end Insert; - - procedure Insert - (Container : in out Set; - New_Item : Element_Type) - is - Position : Cursor; - pragma Unreferenced (Position); - - Inserted : Boolean; - - begin - Insert (Container, New_Item, Position, Inserted); - - if Checks and then not Inserted then - raise Constraint_Error with - "attempt to insert element already in set"; - end if; - end Insert; - - ---------------------- - -- Insert_Sans_Hint -- - ---------------------- - - procedure Insert_Sans_Hint - (Tree : in out Tree_Type; - New_Item : Element_Type; - Node : out Node_Access; - Inserted : out Boolean) - is - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Conditional_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - return new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red_Black_Trees.Red, - Element => New_Item); - end New_Node; - - -- Start of processing for Insert_Sans_Hint - - begin - Conditional_Insert_Sans_Hint - (Tree, - New_Item, - Node, - Inserted); - end Insert_Sans_Hint; - - ---------------------- - -- Insert_With_Hint -- - ---------------------- - - procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access) - is - Success : Boolean; - pragma Unreferenced (Success); - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Insert_Post, - Insert_Sans_Hint); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - Node : constant Node_Access := - new Node_Type'(Parent => null, - Left => null, - Right => null, - Color => Red, - Element => Src_Node.Element); - begin - return Node; - end New_Node; - - -- Start of processing for Insert_With_Hint - - begin - Local_Insert_With_Hint - (Dst_Tree, - Dst_Hint, - Src_Node.Element, - Dst_Node, - Success); - end Insert_With_Hint; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection (Target : in out Set; Source : Set) is - begin - Set_Ops.Intersection (Target.Tree, Source.Tree); - end Intersection; - - function Intersection (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Intersection (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Intersection; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : Set) return Boolean is - begin - return Container.Tree.Length = 0; - end Is_Empty; - - ------------------------ - -- Is_Equal_Node_Node -- - ------------------------ - - function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element = R.Element; - end Is_Equal_Node_Node; - - ----------------------------- - -- Is_Greater_Element_Node -- - ----------------------------- - - function Is_Greater_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - -- Compute e > node same as node < e - - return Right.Element < Left; - end Is_Greater_Element_Node; - - -------------------------- - -- Is_Less_Element_Node -- - -------------------------- - - function Is_Less_Element_Node - (Left : Element_Type; - Right : Node_Access) return Boolean - is - begin - return Left < Right.Element; - end Is_Less_Element_Node; - - ----------------------- - -- Is_Less_Node_Node -- - ----------------------- - - function Is_Less_Node_Node (L, R : Node_Access) return Boolean is - begin - return L.Element < R.Element; - end Is_Less_Node_Node; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is - begin - return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); - end Is_Subset; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Iterate is - new Tree_Operations.Generic_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container'Unrestricted_Access.all.Tree; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Iterate - - begin - Local_Iterate (T); - end Iterate; - - function Iterate (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is null (as is the case here), this means the iterator - -- object was constructed without a start expression. This is a complete - -- iterator, meaning that the iteration starts from the (logical) - -- beginning of the sequence of items. - - -- Note: For a forward iterator, Container.First is the beginning, and - -- for a reverse iterator, Container.Last is the beginning. - - Busy (Container.Tree.TC'Unrestricted_Access.all); - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => null); - end Iterate; - - function Iterate (Container : Set; Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'Class - is - begin - -- It was formerly the case that when Start = No_Element, the partial - -- iterator was defined to behave the same as for a complete iterator, - -- and iterate over the entire sequence of items. However, those - -- semantics were unintuitive and arguably error-prone (it is too easy - -- to accidentally create an endless loop), and so they were changed, - -- per the ARG meeting in Denver on 2011/11. However, there was no - -- consensus about what positive meaning this corner case should have, - -- and so it was decided to simply raise an exception. This does imply, - -- however, that it is not possible to use a partial iterator to specify - -- an empty sequence of items. - - if Checks and then Start = No_Element then - raise Constraint_Error with - "Start position for iterator equals No_Element"; - end if; - - if Checks and then Start.Container /= Container'Unrestricted_Access then - raise Program_Error with - "Start cursor of Iterate designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Start.Node), - "Start cursor of Iterate is bad"); - - -- The value of the Node component influences the behavior of the First - -- and Last selector functions of the iterator object. When the Node - -- component is non-null (as is the case here), it means that this is a - -- partial iteration, over a subset of the complete sequence of - -- items. The iterator object was constructed with a start expression, - -- indicating the position from which the iteration begins. Note that - -- the start position has the same value irrespective of whether this is - -- a forward or reverse iteration. - - Busy (Container.Tree.TC'Unrestricted_Access.all); - - return It : constant Iterator := - Iterator'(Limited_Controlled with - Container => Container'Unrestricted_Access, - Node => Start.Node); - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : Set) return Cursor is - begin - return - (if Container.Tree.Last = null then No_Element - else Cursor'(Container'Unrestricted_Access, Container.Tree.Last)); - end Last; - - function Last (Object : Iterator) return Cursor is - begin - -- The value of the iterator object's Node component influences the - -- behavior of the Last (and First) selector function. - - -- When the Node component is null, this means the iterator object was - -- constructed without a start expression, in which case the (reverse) - -- iteration starts from the (logical) beginning of the entire sequence - -- (corresponding to Container.Last, for a reverse iterator). - - -- Otherwise, this is iteration over a partial sequence of items. When - -- the Node component is non-null, the iterator object was constructed - -- with a start expression, that specifies the position from which the - -- (reverse) partial iteration begins. - - if Object.Node = null then - return Object.Container.Last; - else - return Cursor'(Object.Container, Object.Node); - end if; - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : Set) return Element_Type is - begin - if Checks and then Container.Tree.Last = null then - raise Constraint_Error with "set is empty"; - end if; - - return Container.Tree.Last.Element; - end Last_Element; - - ---------- - -- Left -- - ---------- - - function Left (Node : Node_Access) return Node_Access is - begin - return Node.Left; - end Left; - - ------------ - -- Length -- - ------------ - - function Length (Container : Set) return Count_Type is - begin - return Container.Tree.Length; - end Length; - - ---------- - -- Move -- - ---------- - - procedure Move is new Tree_Operations.Generic_Move (Clear); - - procedure Move (Target : in out Set; Source : in out Set) is - begin - Move (Target => Target.Tree, Source => Source.Tree); - end Move; - - ---------- - -- Next -- - ---------- - - function Next (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Next"); - - declare - Node : constant Node_Access := - Tree_Operations.Next (Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Next; - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Next designates wrong set"; - end if; - - return Next (Position); - end Next; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Set) return Boolean is - begin - return Set_Ops.Overlap (Left.Tree, Right.Tree); - end Overlap; - - ------------ - -- Parent -- - ------------ - - function Parent (Node : Node_Access) return Node_Access is - begin - return Node.Parent; - end Parent; - - -------------- - -- Previous -- - -------------- - - function Previous (Position : Cursor) return Cursor is - begin - if Position = No_Element then - return No_Element; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Previous"); - - declare - Node : constant Node_Access := - Tree_Operations.Previous (Position.Node); - begin - return (if Node = null then No_Element - else Cursor'(Position.Container, Node)); - end; - end Previous; - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Object : Iterator; Position : Cursor) return Cursor is - begin - if Position.Container = null then - return No_Element; - end if; - - if Checks and then Position.Container /= Object.Container then - raise Program_Error with - "Position cursor of Previous designates wrong set"; - end if; - - return Previous (Position); - end Previous; - - ---------------------- - -- Pseudo_Reference -- - ---------------------- - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type - is - TC : constant Tamper_Counts_Access := - Container.Tree.TC'Unrestricted_Access; - begin - return R : constant Reference_Control_Type := (Controlled with TC) do - Lock (TC.all); - end return; - end Pseudo_Reference; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with "Position cursor equals No_Element"; - end if; - - pragma Assert (Vet (Position.Container.Tree, Position.Node), - "bad cursor in Query_Element"); - - declare - T : Tree_Type renames Position.Container.Tree; - Lock : With_Lock (T.TC'Unrestricted_Access); - begin - Process (Position.Node.Element); - end; - end Query_Element; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set) - is - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - pragma Inline (Read_Node); - - procedure Read is - new Tree_Operations.Generic_Read (Clear, Read_Node); - - --------------- - -- Read_Node -- - --------------- - - function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access - is - Node : Node_Access := new Node_Type; - begin - Element_Type'Read (Stream, Node.Element); - return Node; - exception - when others => - Free (Node); - raise; - end Read_Node; - - -- Start of processing for Read - - begin - Read (Stream, Container.Tree); - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Read; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Read; - - ------------- - -- Replace -- - ------------- - - procedure Replace (Container : in out Set; New_Item : Element_Type) is - Node : constant Node_Access := - Element_Keys.Find (Container.Tree, New_Item); - - begin - if Checks and then Node = null then - raise Constraint_Error with - "attempt to replace element not in set"; - end if; - - TE_Check (Container.Tree.TC); - - Node.Element := New_Item; - end Replace; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Tree : in out Tree_Type; - Node : Node_Access; - Item : Element_Type) - is - pragma Assert (Node /= null); - - function New_Node return Node_Access; - pragma Inline (New_Node); - - procedure Local_Insert_Post is - new Element_Keys.Generic_Insert_Post (New_Node); - - procedure Local_Insert_Sans_Hint is - new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); - - procedure Local_Insert_With_Hint is - new Element_Keys.Generic_Conditional_Insert_With_Hint - (Local_Insert_Post, - Local_Insert_Sans_Hint); - - -------------- - -- New_Node -- - -------------- - - function New_Node return Node_Access is - begin - Node.Element := Item; - Node.Color := Red; - Node.Parent := null; - Node.Right := null; - Node.Left := null; - return Node; - end New_Node; - - Hint : Node_Access; - Result : Node_Access; - Inserted : Boolean; - Compare : Boolean; - - -- Start of processing for Replace_Element - - begin - -- Replace_Element assigns value Item to the element designated by Node, - -- per certain semantic constraints. - - -- If Item is equivalent to the element, then element is replaced and - -- there's nothing else to do. This is the easy case. - - -- If Item is not equivalent, then the node will (possibly) have to move - -- to some other place in the tree. This is slighly more complicated, - -- because we must ensure that Item is not equivalent to some other - -- element in the tree (in which case, the replacement is not allowed). - - -- Determine whether Item is equivalent to element on the specified - -- node. - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := (if Item < Node.Element then False - elsif Node.Element < Item then False - else True); - end; - - if Compare then - -- Item is equivalent to the node's element, so we will not have to - -- move the node. - - TE_Check (Tree.TC); - - Node.Element := Item; - return; - end if; - - -- The replacement Item is not equivalent to the element on the - -- specified node, which means that it will need to be re-inserted in a - -- different position in the tree. We must now determine whether Item is - -- equivalent to some other element in the tree (which would prohibit - -- the assignment and hence the move). - - -- Ceiling returns the smallest element equivalent or greater than the - -- specified Item; if there is no such element, then it returns null. - - Hint := Element_Keys.Ceiling (Tree, Item); - - if Hint /= null then - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Item < Hint.Element; - end; - - -- Item >= Hint.Element - - if Checks and then not Compare then - - -- Ceiling returns an element that is equivalent or greater - -- than Item. If Item is "not less than" the element, then - -- by elimination we know that Item is equivalent to the element. - - -- But this means that it is not possible to assign the value of - -- Item to the specified element (on Node), because a different - -- element (on Hint) equivalent to Item already exsits. (Were we - -- to change Node's element value, we would have to move Node, but - -- we would be unable to move the Node, because its new position - -- in the tree is already occupied by an equivalent element.) - - raise Program_Error with "attempt to replace existing element"; - end if; - - -- Item is not equivalent to any other element in the tree, so it is - -- safe to assign the value of Item to Node.Element. This means that - -- the node will have to move to a different position in the tree - -- (because its element will have a different value). - - -- The nearest (greater) neighbor of Item is Hint. This will be the - -- insertion position of Node (because its element will have Item as - -- its new value). - - -- If Node equals Hint, the relative position of Node does not - -- change. This allows us to perform an optimization: we need not - -- remove Node from the tree and then reinsert it with its new value, - -- because it would only be placed in the exact same position. - - if Hint = Node then - TE_Check (Tree.TC); - - Node.Element := Item; - return; - end if; - end if; - - -- If we get here, it is because Item was greater than all elements in - -- the tree (Hint = null), or because Item was less than some element at - -- a different place in the tree (Item < Hint.Element). In either case, - -- we remove Node from the tree (without actually deallocating it), and - -- then insert Item into the tree, onto the same Node (so no new node is - -- actually allocated). - - Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit - - Local_Insert_With_Hint -- use unconditional insert here instead??? - (Tree => Tree, - Position => Hint, - Key => Item, - Node => Result, - Inserted => Inserted); - - pragma Assert (Inserted); - pragma Assert (Result = Node); - end Replace_Element; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Checks and then Position.Node = null then - raise Constraint_Error with - "Position cursor equals No_Element"; - end if; - - if Checks and then Position.Container /= Container'Unrestricted_Access - then - raise Program_Error with - "Position cursor designates wrong set"; - end if; - - pragma Assert (Vet (Container.Tree, Position.Node), - "bad cursor in Replace_Element"); - - Replace_Element (Container.Tree, Position.Node, New_Item); - end Replace_Element; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)) - is - procedure Process_Node (Node : Node_Access); - pragma Inline (Process_Node); - - procedure Local_Reverse_Iterate is - new Tree_Operations.Generic_Reverse_Iteration (Process_Node); - - ------------------ - -- Process_Node -- - ------------------ - - procedure Process_Node (Node : Node_Access) is - begin - Process (Cursor'(Container'Unrestricted_Access, Node)); - end Process_Node; - - T : Tree_Type renames Container.Tree'Unrestricted_Access.all; - Busy : With_Busy (T.TC'Unrestricted_Access); - - -- Start of processing for Reverse_Iterate - - begin - Local_Reverse_Iterate (T); - end Reverse_Iterate; - - ----------- - -- Right -- - ----------- - - function Right (Node : Node_Access) return Node_Access is - begin - return Node.Right; - end Right; - - --------------- - -- Set_Color -- - --------------- - - procedure Set_Color (Node : Node_Access; Color : Color_Type) is - begin - Node.Color := Color; - end Set_Color; - - -------------- - -- Set_Left -- - -------------- - - procedure Set_Left (Node : Node_Access; Left : Node_Access) is - begin - Node.Left := Left; - end Set_Left; - - ---------------- - -- Set_Parent -- - ---------------- - - procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is - begin - Node.Parent := Parent; - end Set_Parent; - - --------------- - -- Set_Right -- - --------------- - - procedure Set_Right (Node : Node_Access; Right : Node_Access) is - begin - Node.Right := Right; - end Set_Right; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference (Target : in out Set; Source : Set) is - begin - Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Symmetric_Difference; - - ------------ - -- To_Set -- - ------------ - - function To_Set (New_Item : Element_Type) return Set is - Tree : Tree_Type; - Node : Node_Access; - Inserted : Boolean; - pragma Unreferenced (Node, Inserted); - begin - Insert_Sans_Hint (Tree, New_Item, Node, Inserted); - return Set'(Controlled with Tree); - end To_Set; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Set; Source : Set) is - begin - Set_Ops.Union (Target.Tree, Source.Tree); - end Union; - - function Union (Left, Right : Set) return Set is - Tree : constant Tree_Type := - Set_Ops.Union (Left.Tree, Right.Tree); - begin - return Set'(Controlled with Tree); - end Union; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set) - is - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - pragma Inline (Write_Node); - - procedure Write is - new Tree_Operations.Generic_Write (Write_Node); - - ---------------- - -- Write_Node -- - ---------------- - - procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access) - is - begin - Element_Type'Write (Stream, Node.Element); - end Write_Node; - - -- Start of processing for Write - - begin - Write (Stream, Container.Tree); - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor) - is - begin - raise Program_Error with "attempt to stream set cursor"; - end Write; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type) - is - begin - raise Program_Error with "attempt to stream reference"; - end Write; - -end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads deleted file mode 100644 index 1260fba..0000000 --- a/gcc/ada/a-coorse.ads +++ /dev/null @@ -1,453 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . O R D E R E D _ S E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Iterator_Interfaces; - -with Ada.Containers.Helpers; -private with Ada.Containers.Red_Black_Trees; -private with Ada.Finalization; -private with Ada.Streams; - -generic - type Element_Type is private; - - with function "<" (Left, Right : Element_Type) return Boolean is <>; - with function "=" (Left, Right : Element_Type) return Boolean is <>; - -package Ada.Containers.Ordered_Sets is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - pragma Remote_Types; - - function Equivalent_Elements (Left, Right : Element_Type) return Boolean; - - type Set is tagged private - with Constant_Indexing => Constant_Reference, - Default_Iterator => Iterate, - Iterator_Element => Element_Type; - - pragma Preelaborable_Initialization (Set); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - function Has_Element (Position : Cursor) return Boolean; - - Empty_Set : constant Set; - - No_Element : constant Cursor; - - package Set_Iterator_Interfaces is new - Ada.Iterator_Interfaces (Cursor, Has_Element); - - function "=" (Left, Right : Set) return Boolean; - - function Equivalent_Sets (Left, Right : Set) return Boolean; - - function To_Set (New_Item : Element_Type) return Set; - - function Length (Container : Set) return Count_Type; - - function Is_Empty (Container : Set) return Boolean; - - procedure Clear (Container : in out Set); - - function Element (Position : Cursor) return Element_Type; - - procedure Replace_Element - (Container : in out Set; - Position : Cursor; - New_Item : Element_Type); - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - private - with - Implicit_Dereference => Element; - - function Constant_Reference - (Container : aliased Set; - Position : Cursor) return Constant_Reference_Type; - pragma Inline (Constant_Reference); - - procedure Assign (Target : in out Set; Source : Set); - - function Copy (Source : Set) return Set; - - procedure Move (Target : in out Set; Source : in out Set); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type; - Position : out Cursor; - Inserted : out Boolean); - - procedure Insert - (Container : in out Set; - New_Item : Element_Type); - - procedure Include - (Container : in out Set; - New_Item : Element_Type); - - procedure Replace - (Container : in out Set; - New_Item : Element_Type); - - procedure Exclude - (Container : in out Set; - Item : Element_Type); - - procedure Delete - (Container : in out Set; - Item : Element_Type); - - procedure Delete - (Container : in out Set; - Position : in out Cursor); - - procedure Delete_First (Container : in out Set); - - procedure Delete_Last (Container : in out Set); - - procedure Union (Target : in out Set; Source : Set); - - function Union (Left, Right : Set) return Set; - - function "or" (Left, Right : Set) return Set renames Union; - - procedure Intersection (Target : in out Set; Source : Set); - - function Intersection (Left, Right : Set) return Set; - - function "and" (Left, Right : Set) return Set renames Intersection; - - procedure Difference (Target : in out Set; Source : Set); - - function Difference (Left, Right : Set) return Set; - - function "-" (Left, Right : Set) return Set renames Difference; - - procedure Symmetric_Difference (Target : in out Set; Source : Set); - - function Symmetric_Difference (Left, Right : Set) return Set; - - function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; - - function Overlap (Left, Right : Set) return Boolean; - - function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; - - function First (Container : Set) return Cursor; - - function First_Element (Container : Set) return Element_Type; - - function Last (Container : Set) return Cursor; - - function Last_Element (Container : Set) return Element_Type; - - function Next (Position : Cursor) return Cursor; - - procedure Next (Position : in out Cursor); - - function Previous (Position : Cursor) return Cursor; - - procedure Previous (Position : in out Cursor); - - function Find (Container : Set; Item : Element_Type) return Cursor; - - function Floor (Container : Set; Item : Element_Type) return Cursor; - - function Ceiling (Container : Set; Item : Element_Type) return Cursor; - - function Contains (Container : Set; Item : Element_Type) return Boolean; - - function "<" (Left, Right : Cursor) return Boolean; - - function ">" (Left, Right : Cursor) return Boolean; - - function "<" (Left : Cursor; Right : Element_Type) return Boolean; - - function ">" (Left : Cursor; Right : Element_Type) return Boolean; - - function "<" (Left : Element_Type; Right : Cursor) return Boolean; - - function ">" (Left : Element_Type; Right : Cursor) return Boolean; - - procedure Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - - procedure Reverse_Iterate - (Container : Set; - Process : not null access procedure (Position : Cursor)); - - function Iterate - (Container : Set) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - function Iterate - (Container : Set; - Start : Cursor) - return Set_Iterator_Interfaces.Reversible_Iterator'class; - - generic - type Key_Type (<>) is private; - - with function Key (Element : Element_Type) return Key_Type; - - with function "<" (Left, Right : Key_Type) return Boolean is <>; - - package Generic_Keys is - - function Equivalent_Keys (Left, Right : Key_Type) return Boolean; - - function Key (Position : Cursor) return Key_Type; - - function Element (Container : Set; Key : Key_Type) return Element_Type; - - procedure Replace - (Container : in out Set; - Key : Key_Type; - New_Item : Element_Type); - - procedure Exclude (Container : in out Set; Key : Key_Type); - - procedure Delete (Container : in out Set; Key : Key_Type); - - function Find (Container : Set; Key : Key_Type) return Cursor; - - function Floor (Container : Set; Key : Key_Type) return Cursor; - - function Ceiling (Container : Set; Key : Key_Type) return Cursor; - - function Contains (Container : Set; Key : Key_Type) return Boolean; - - procedure Update_Element_Preserving_Key - (Container : in out Set; - Position : Cursor; - Process : not null access - procedure (Element : in out Element_Type)); - - type Reference_Type (Element : not null access Element_Type) is private - with - Implicit_Dereference => Element; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Position : Cursor) return Reference_Type; - - function Constant_Reference - (Container : aliased Set; - Key : Key_Type) return Constant_Reference_Type; - - function Reference_Preserving_Key - (Container : aliased in out Set; - Key : Key_Type) return Reference_Type; - - private - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - type Key_Access is access all Key_Type; - - package Impl is new Helpers.Generic_Implementation; - - type Reference_Control_Type is - new Impl.Reference_Control_Type with - record - Container : Set_Access; - Pos : Cursor; - Old_Key : Key_Access; - end record; - - overriding procedure Finalize (Control : in out Reference_Control_Type); - pragma Inline (Finalize); - - type Reference_Type (Element : not null access Element_Type) is record - Control : Reference_Control_Type; - end record; - - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Reference_Type); - - for Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Reference_Type); - - for Reference_Type'Read use Read; - end Generic_Keys; - -private - - pragma Inline (Next); - pragma Inline (Previous); - - type Node_Type; - type Node_Access is access Node_Type; - - type Node_Type is limited record - Parent : Node_Access; - Left : Node_Access; - Right : Node_Access; - Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; - Element : aliased Element_Type; - end record; - - package Tree_Types is - new Red_Black_Trees.Generic_Tree_Types (Node_Type, Node_Access); - - type Set is new Ada.Finalization.Controlled with record - Tree : Tree_Types.Tree_Type; - end record; - - overriding procedure Adjust (Container : in out Set); - - overriding procedure Finalize (Container : in out Set) renames Clear; - - use Red_Black_Trees; - use Tree_Types, Tree_Types.Implementation; - use Ada.Finalization; - use Ada.Streams; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Container : Set); - - for Set'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Container : out Set); - - for Set'Read use Read; - - type Set_Access is access all Set; - for Set_Access'Storage_Size use 0; - - type Cursor is record - Container : Set_Access; - Node : Node_Access; - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Cursor); - - for Cursor'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Cursor); - - for Cursor'Read use Read; - - subtype Reference_Control_Type is Implementation.Reference_Control_Type; - -- It is necessary to rename this here, so that the compiler can find it - - type Constant_Reference_Type - (Element : not null access constant Element_Type) is - record - Control : Reference_Control_Type := - raise Program_Error with "uninitialized reference"; - -- The RM says, "The default initialization of an object of - -- type Constant_Reference_Type or Reference_Type propagates - -- Program_Error." - end record; - - procedure Write - (Stream : not null access Root_Stream_Type'Class; - Item : Constant_Reference_Type); - - for Constant_Reference_Type'Write use Write; - - procedure Read - (Stream : not null access Root_Stream_Type'Class; - Item : out Constant_Reference_Type); - - for Constant_Reference_Type'Read use Read; - - -- Three operations are used to optimize in the expansion of "for ... of" - -- loops: the Next(Cursor) procedure in the visible part, and the following - -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for - -- details. - - function Pseudo_Reference - (Container : aliased Set'Class) return Reference_Control_Type; - pragma Inline (Pseudo_Reference); - -- Creates an object of type Reference_Control_Type pointing to the - -- container, and increments the Lock. Finalization of this object will - -- decrement the Lock. - - type Element_Access is access all Element_Type with - Storage_Size => 0; - - function Get_Element_Access - (Position : Cursor) return not null Element_Access; - -- Returns a pointer to the element designated by Position. - - Empty_Set : constant Set := (Controlled with others => <>); - - No_Element : constant Cursor := Cursor'(null, null); - - type Iterator is new Limited_Controlled and - Set_Iterator_Interfaces.Reversible_Iterator with - record - Container : Set_Access; - Node : Node_Access; - end record - with Disable_Controlled => not T_Check; - - overriding procedure Finalize (Object : in out Iterator); - - overriding function First (Object : Iterator) return Cursor; - overriding function Last (Object : Iterator) return Cursor; - - overriding function Next - (Object : Iterator; - Position : Cursor) return Cursor; - - overriding function Previous - (Object : Iterator; - Position : Cursor) return Cursor; - -end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/a-coprnu.adb b/gcc/ada/a-coprnu.adb deleted file mode 100644 index 95eff8b..0000000 --- a/gcc/ada/a-coprnu.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . P R I M E _ N U M B E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Prime_Numbers is - - -------------- - -- To_Prime -- - -------------- - - function To_Prime (Length : Count_Type) return Hash_Type is - I, J, K : Integer'Base; - Index : Integer'Base; - - begin - I := Primes'Last - Primes'First; - Index := Primes'First; - while I > 0 loop - J := I / 2; - K := Index + J; - - if Primes (K) < Hash_Type (Length) then - Index := K + 1; - I := I - J - 1; - else - I := J; - end if; - end loop; - - return Primes (Index); - end To_Prime; - -end Ada.Containers.Prime_Numbers; diff --git a/gcc/ada/a-coprnu.ads b/gcc/ada/a-coprnu.ads deleted file mode 100644 index 33af3e1..0000000 --- a/gcc/ada/a-coprnu.ads +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . P R I M E _ N U M B E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- This package declares the prime numbers array used to implement hashed --- containers. Bucket arrays are always allocated with a prime-number --- length (computed using To_Prime below), as this produces better scatter --- when hash values are folded. - -package Ada.Containers.Prime_Numbers is - pragma Pure; - - type Primes_Type is array (Positive range <>) of Hash_Type; - - Primes : constant Primes_Type := - (53, 97, 193, 389, 769, - 1543, 3079, 6151, 12289, 24593, - 49157, 98317, 196613, 393241, 786433, - 1572869, 3145739, 6291469, 12582917, 25165843, - 50331653, 100663319, 201326611, 402653189, 805306457, - 1610612741, 3221225473, 4294967291); - - function To_Prime (Length : Count_Type) return Hash_Type; - -- Returns the smallest value in Primes not less than Length - -end Ada.Containers.Prime_Numbers; diff --git a/gcc/ada/a-coteio.ads b/gcc/ada/a-coteio.ads deleted file mode 100644 index abba889..0000000 --- a/gcc/ada/a-coteio.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C O M P L E X _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Ada 2005 AI-328 - -with Ada.Text_IO.Complex_IO; -with Ada.Numerics.Complex_Types; - -pragma Elaborate_All (Ada.Text_IO.Complex_IO); - -package Ada.Complex_Text_IO is - new Ada.Text_IO.Complex_IO (Ada.Numerics.Complex_Types); diff --git a/gcc/ada/a-crbltr.ads b/gcc/ada/a-crbltr.ads deleted file mode 100644 index 73ed9ae..0000000 --- a/gcc/ada/a-crbltr.ads +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- This package declares the tree type used to implement ordered containers - -with Ada.Containers.Helpers; - -package Ada.Containers.Red_Black_Trees is - pragma Pure; - - type Color_Type is (Red, Black); - - generic - type Node_Type (<>) is limited private; - type Node_Access is access Node_Type; - package Generic_Tree_Types is - - type Tree_Type is tagged record - First : Node_Access := null; - Last : Node_Access := null; - Root : Node_Access := null; - Length : Count_Type := 0; - TC : aliased Helpers.Tamper_Counts; - end record; - - package Implementation is new Helpers.Generic_Implementation; - end Generic_Tree_Types; - - generic - type Node_Type is private; - package Generic_Bounded_Tree_Types is - type Nodes_Type is array (Count_Type range <>) of Node_Type; - - -- Note that objects of type Tree_Type are logically initialized (in the - -- sense that representation invariants of type are satisfied by dint of - -- default initialization), even without the Nodes component also having - -- its own initialization expression. We only initializae the Nodes - -- component here in order to prevent spurious compiler warnings about - -- the container object not being fully initialized. - - type Tree_Type (Capacity : Count_Type) is tagged record - First : Count_Type := 0; - Last : Count_Type := 0; - Root : Count_Type := 0; - Length : Count_Type := 0; - TC : aliased Helpers.Tamper_Counts; - Free : Count_Type'Base := -1; - Nodes : Nodes_Type (1 .. Capacity) := (others => <>); - end record; - - package Implementation is new Helpers.Generic_Implementation; - end Generic_Bounded_Tree_Types; - -end Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/a-crbtgk.adb b/gcc/ada/a-crbtgk.adb deleted file mode 100644 index 10a9e92..0000000 --- a/gcc/ada/a-crbtgk.adb +++ /dev/null @@ -1,690 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Red_Black_Trees.Generic_Keys is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - package Ops renames Tree_Operations; - - ------------- - -- Ceiling -- - ------------- - - -- AKA Lower_Bound - - function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Tree.TC'Unrestricted_Access); - - Y : Node_Access; - X : Node_Access; - - begin - -- If the container is empty, return a result immediately, so that we do - -- not manipulate the tamper bits unnecessarily. - - if Tree.Root = null then - return null; - end if; - - X := Tree.Root; - while X /= null loop - if Is_Greater_Key_Node (Key, X) then - X := Ops.Right (X); - else - Y := X; - X := Ops.Left (X); - end if; - end loop; - - return Y; - end Ceiling; - - ---------- - -- Find -- - ---------- - - function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Tree.TC'Unrestricted_Access); - - Y : Node_Access; - X : Node_Access; - - begin - -- If the container is empty, return a result immediately, so that we do - -- not manipulate the tamper bits unnecessarily. - - if Tree.Root = null then - return null; - end if; - - X := Tree.Root; - while X /= null loop - if Is_Greater_Key_Node (Key, X) then - X := Ops.Right (X); - else - Y := X; - X := Ops.Left (X); - end if; - end loop; - - if Y = null or else Is_Less_Key_Node (Key, Y) then - return null; - else - return Y; - end if; - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock : With_Lock (Tree.TC'Unrestricted_Access); - - Y : Node_Access; - X : Node_Access; - - begin - -- If the container is empty, return a result immediately, so that we do - -- not manipulate the tamper bits unnecessarily. - - if Tree.Root = null then - return null; - end if; - - X := Tree.Root; - while X /= null loop - if Is_Less_Key_Node (Key, X) then - X := Ops.Left (X); - else - Y := X; - X := Ops.Right (X); - end if; - end loop; - - return Y; - end Floor; - - -------------------------------- - -- Generic_Conditional_Insert -- - -------------------------------- - - procedure Generic_Conditional_Insert - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access; - Inserted : out Boolean) - is - X : Node_Access; - Y : Node_Access; - - Compare : Boolean; - - begin - -- This is a "conditional" insertion, meaning that the insertion request - -- can "fail" in the sense that no new node is created. If the Key is - -- equivalent to an existing node, then we return the existing node and - -- Inserted is set to False. Otherwise, we allocate a new node (via - -- Insert_Post) and Inserted is set to True. - - -- Note that we are testing for equivalence here, not equality. Key must - -- be strictly less than its next neighbor, and strictly greater than - -- its previous neighbor, in order for the conditional insertion to - -- succeed. - - -- Handle insertion into an empty container as a special case, so that - -- we do not manipulate the tamper bits unnecessarily. - - if Tree.Root = null then - Insert_Post (Tree, null, True, Node); - Inserted := True; - return; - end if; - - -- We search the tree to find the nearest neighbor of Key, which is - -- either the smallest node greater than Key (Inserted is True), or the - -- largest node less or equivalent to Key (Inserted is False). - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - X := Tree.Root; - Y := null; - Inserted := True; - while X /= null loop - Y := X; - Inserted := Is_Less_Key_Node (Key, X); - X := (if Inserted then Ops.Left (X) else Ops.Right (X)); - end loop; - end; - - if Inserted then - - -- Key is less than Y. If Y is the first node in the tree, then there - -- are no other nodes that we need to search for, and we insert a new - -- node into the tree. - - if Y = Tree.First then - Insert_Post (Tree, Y, True, Node); - return; - end if; - - -- Y is the next nearest-neighbor of Key. We know that Key is not - -- equivalent to Y (because Key is strictly less than Y), so we move - -- to the previous node, the nearest-neighbor just smaller or - -- equivalent to Key. - - Node := Ops.Previous (Y); - - else - -- Y is the previous nearest-neighbor of Key. We know that Key is not - -- less than Y, which means either that Key is equivalent to Y, or - -- greater than Y. - - Node := Y; - end if; - - -- Key is equivalent to or greater than Node. We must resolve which is - -- the case, to determine whether the conditional insertion succeeds. - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Is_Greater_Key_Node (Key, Node); - end; - - if Compare then - - -- Key is strictly greater than Node, which means that Key is not - -- equivalent to Node. In this case, the insertion succeeds, and we - -- insert a new node into the tree. - - Insert_Post (Tree, Y, Inserted, Node); - Inserted := True; - return; - end if; - - -- Key is equivalent to Node. This is a conditional insertion, so we do - -- not insert a new node in this case. We return the existing node and - -- report that no insertion has occurred. - - Inserted := False; - end Generic_Conditional_Insert; - - ------------------------------------------ - -- Generic_Conditional_Insert_With_Hint -- - ------------------------------------------ - - procedure Generic_Conditional_Insert_With_Hint - (Tree : in out Tree_Type; - Position : Node_Access; - Key : Key_Type; - Node : out Node_Access; - Inserted : out Boolean) - is - Test : Node_Access; - Compare : Boolean; - - begin - -- The purpose of a hint is to avoid a search from the root of - -- tree. If we have it hint it means we only need to traverse the - -- subtree rooted at the hint to find the nearest neighbor. Note - -- that finding the neighbor means merely walking the tree; this - -- is not a search and the only comparisons that occur are with - -- the hint and its neighbor. - - -- Handle insertion into an empty container as a special case, so that - -- we do not manipulate the tamper bits unnecessarily. - - if Tree.Root = null then - Insert_Post (Tree, null, True, Node); - Inserted := True; - return; - end if; - - -- If Position is null, this is interpreted to mean that Key is large - -- relative to the nodes in the tree. If Key is greater than the last - -- node in the tree, then we're done; otherwise the hint was "wrong" and - -- we must search. - - if Position = null then -- largest - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Is_Greater_Key_Node (Key, Tree.Last); - end; - - if Compare then - Insert_Post (Tree, Tree.Last, False, Node); - Inserted := True; - else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); - end if; - - return; - end if; - - pragma Assert (Tree.Length > 0); - - -- A hint can either name the node that immediately follows Key, - -- or immediately precedes Key. We first test whether Key is - -- less than the hint, and if so we compare Key to the node that - -- precedes the hint. If Key is both less than the hint and - -- greater than the hint's preceding neighbor, then we're done; - -- otherwise we must search. - - -- Note also that a hint can either be an anterior node or a leaf - -- node. A new node is always inserted at the bottom of the tree - -- (at least prior to rebalancing), becoming the new left or - -- right child of leaf node (which prior to the insertion must - -- necessarily be null, since this is a leaf). If the hint names - -- an anterior node then its neighbor must be a leaf, and so - -- (here) we insert after the neighbor. If the hint names a leaf - -- then its neighbor must be anterior and so we insert before the - -- hint. - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Is_Less_Key_Node (Key, Position); - end; - - if Compare then - Test := Ops.Previous (Position); -- "before" - - if Test = null then -- new first node - Insert_Post (Tree, Tree.First, True, Node); - - Inserted := True; - return; - end if; - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Is_Greater_Key_Node (Key, Test); - end; - - if Compare then - if Ops.Right (Test) = null then - Insert_Post (Tree, Test, False, Node); - else - Insert_Post (Tree, Position, True, Node); - end if; - - Inserted := True; - - else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); - end if; - - return; - end if; - - -- We know that Key isn't less than the hint so we try again, this time - -- to see if it's greater than the hint. If so we compare Key to the - -- node that follows the hint. If Key is both greater than the hint and - -- less than the hint's next neighbor, then we're done; otherwise we - -- must search. - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Is_Greater_Key_Node (Key, Position); - end; - - if Compare then - Test := Ops.Next (Position); -- "after" - - if Test = null then -- new last node - Insert_Post (Tree, Tree.Last, False, Node); - - Inserted := True; - return; - end if; - - declare - Lock : With_Lock (Tree.TC'Unrestricted_Access); - begin - Compare := Is_Less_Key_Node (Key, Test); - end; - - if Compare then - if Ops.Right (Position) = null then - Insert_Post (Tree, Position, False, Node); - else - Insert_Post (Tree, Test, True, Node); - end if; - - Inserted := True; - - else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); - end if; - - return; - end if; - - -- We know that Key is neither less than the hint nor greater than the - -- hint, and that's the definition of equivalence. There's nothing else - -- we need to do, since a search would just reach the same conclusion. - - Node := Position; - Inserted := False; - end Generic_Conditional_Insert_With_Hint; - - ------------------------- - -- Generic_Insert_Post -- - ------------------------- - - procedure Generic_Insert_Post - (Tree : in out Tree_Type; - Y : Node_Access; - Before : Boolean; - Z : out Node_Access) - is - begin - if Checks and then Tree.Length = Count_Type'Last then - raise Constraint_Error with "too many elements"; - end if; - - TC_Check (Tree.TC); - - Z := New_Node; - pragma Assert (Z /= null); - pragma Assert (Ops.Color (Z) = Red); - - if Y = null then - pragma Assert (Tree.Length = 0); - pragma Assert (Tree.Root = null); - pragma Assert (Tree.First = null); - pragma Assert (Tree.Last = null); - - Tree.Root := Z; - Tree.First := Z; - Tree.Last := Z; - - elsif Before then - pragma Assert (Ops.Left (Y) = null); - - Ops.Set_Left (Y, Z); - - if Y = Tree.First then - Tree.First := Z; - end if; - - else - pragma Assert (Ops.Right (Y) = null); - - Ops.Set_Right (Y, Z); - - if Y = Tree.Last then - Tree.Last := Z; - end if; - end if; - - Ops.Set_Parent (Z, Y); - Ops.Rebalance_For_Insert (Tree, Z); - Tree.Length := Tree.Length + 1; - end Generic_Insert_Post; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration - (Tree : Tree_Type; - Key : Key_Type) - is - procedure Iterate (Node : Node_Access); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (Node : Node_Access) is - N : Node_Access; - begin - N := Node; - while N /= null loop - if Is_Less_Key_Node (Key, N) then - N := Ops.Left (N); - elsif Is_Greater_Key_Node (Key, N) then - N := Ops.Right (N); - else - Iterate (Ops.Left (N)); - Process (N); - N := Ops.Right (N); - end if; - end loop; - end Iterate; - - -- Start of processing for Generic_Iteration - - begin - Iterate (Tree.Root); - end Generic_Iteration; - - ------------------------------- - -- Generic_Reverse_Iteration -- - ------------------------------- - - procedure Generic_Reverse_Iteration - (Tree : Tree_Type; - Key : Key_Type) - is - procedure Iterate (Node : Node_Access); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (Node : Node_Access) is - N : Node_Access; - begin - N := Node; - while N /= null loop - if Is_Less_Key_Node (Key, N) then - N := Ops.Left (N); - elsif Is_Greater_Key_Node (Key, N) then - N := Ops.Right (N); - else - Iterate (Ops.Right (N)); - Process (N); - N := Ops.Left (N); - end if; - end loop; - end Iterate; - - -- Start of processing for Generic_Reverse_Iteration - - begin - Iterate (Tree.Root); - end Generic_Reverse_Iteration; - - ---------------------------------- - -- Generic_Unconditional_Insert -- - ---------------------------------- - - procedure Generic_Unconditional_Insert - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access) - is - Y : Node_Access; - X : Node_Access; - - Before : Boolean; - - begin - Y := null; - Before := False; - - X := Tree.Root; - while X /= null loop - Y := X; - Before := Is_Less_Key_Node (Key, X); - X := (if Before then Ops.Left (X) else Ops.Right (X)); - end loop; - - Insert_Post (Tree, Y, Before, Node); - end Generic_Unconditional_Insert; - - -------------------------------------------- - -- Generic_Unconditional_Insert_With_Hint -- - -------------------------------------------- - - procedure Generic_Unconditional_Insert_With_Hint - (Tree : in out Tree_Type; - Hint : Node_Access; - Key : Key_Type; - Node : out Node_Access) - is - begin - -- There are fewer constraints for an unconditional insertion - -- than for a conditional insertion, since we allow duplicate - -- keys. So instead of having to check (say) whether Key is - -- (strictly) greater than the hint's previous neighbor, here we - -- allow Key to be equal to or greater than the previous node. - - -- There is the issue of what to do if Key is equivalent to the - -- hint. Does the new node get inserted before or after the hint? - -- We decide that it gets inserted after the hint, reasoning that - -- this is consistent with behavior for non-hint insertion, which - -- inserts a new node after existing nodes with equivalent keys. - - -- First we check whether the hint is null, which is interpreted - -- to mean that Key is large relative to existing nodes. - -- Following our rule above, if Key is equal to or greater than - -- the last node, then we insert the new node immediately after - -- last. (We don't have an operation for testing whether a key is - -- "equal to or greater than" a node, so we must say instead "not - -- less than", which is equivalent.) - - if Hint = null then -- largest - if Tree.Last = null then - Insert_Post (Tree, null, False, Node); - elsif Is_Less_Key_Node (Key, Tree.Last) then - Unconditional_Insert_Sans_Hint (Tree, Key, Node); - else - Insert_Post (Tree, Tree.Last, False, Node); - end if; - - return; - end if; - - pragma Assert (Tree.Length > 0); - - -- We decide here whether to insert the new node prior to the - -- hint. Key could be equivalent to the hint, so in theory we - -- could write the following test as "not greater than" (same as - -- "less than or equal to"). If Key were equivalent to the hint, - -- that would mean that the new node gets inserted before an - -- equivalent node. That wouldn't break any container invariants, - -- but our rule above says that new nodes always get inserted - -- after equivalent nodes. So here we test whether Key is both - -- less than the hint and equal to or greater than the hint's - -- previous neighbor, and if so insert it before the hint. - - if Is_Less_Key_Node (Key, Hint) then - declare - Before : constant Node_Access := Ops.Previous (Hint); - begin - if Before = null then - Insert_Post (Tree, Hint, True, Node); - elsif Is_Less_Key_Node (Key, Before) then - Unconditional_Insert_Sans_Hint (Tree, Key, Node); - elsif Ops.Right (Before) = null then - Insert_Post (Tree, Before, False, Node); - else - Insert_Post (Tree, Hint, True, Node); - end if; - end; - - return; - end if; - - -- We know that Key isn't less than the hint, so it must be equal - -- or greater. So we just test whether Key is less than or equal - -- to (same as "not greater than") the hint's next neighbor, and - -- if so insert it after the hint. - - declare - After : constant Node_Access := Ops.Next (Hint); - begin - if After = null then - Insert_Post (Tree, Hint, False, Node); - elsif Is_Greater_Key_Node (Key, After) then - Unconditional_Insert_Sans_Hint (Tree, Key, Node); - elsif Ops.Right (Hint) = null then - Insert_Post (Tree, Hint, False, Node); - else - Insert_Post (Tree, After, True, Node); - end if; - end; - end Generic_Unconditional_Insert_With_Hint; - - ----------------- - -- Upper_Bound -- - ----------------- - - function Upper_Bound - (Tree : Tree_Type; - Key : Key_Type) return Node_Access - is - Y : Node_Access; - X : Node_Access; - - begin - X := Tree.Root; - while X /= null loop - if Is_Less_Key_Node (Key, X) then - Y := X; - X := Ops.Left (X); - else - X := Ops.Right (X); - end if; - end loop; - - return Y; - end Upper_Bound; - -end Ada.Containers.Red_Black_Trees.Generic_Keys; diff --git a/gcc/ada/a-crbtgk.ads b/gcc/ada/a-crbtgk.ads deleted file mode 100644 index c93dfe7..0000000 --- a/gcc/ada/a-crbtgk.ads +++ /dev/null @@ -1,192 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Tree_Type is used to implement ordered containers. This package declares --- the tree operations that depend on keys. - -with Ada.Containers.Red_Black_Trees.Generic_Operations; - -generic - with package Tree_Operations is new Generic_Operations (<>); - - use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; - - type Key_Type (<>) is limited private; - - with function Is_Less_Key_Node - (L : Key_Type; - R : Node_Access) return Boolean; - - with function Is_Greater_Key_Node - (L : Key_Type; - R : Node_Access) return Boolean; - -package Ada.Containers.Red_Black_Trees.Generic_Keys is - pragma Pure; - - generic - with function New_Node return Node_Access; - procedure Generic_Insert_Post - (Tree : in out Tree_Type; - Y : Node_Access; - Before : Boolean; - Z : out Node_Access); - -- Completes an insertion after the insertion position has been - -- determined. On output Z contains a pointer to the newly inserted - -- node, allocated using New_Node. If Tree is busy then - -- Program_Error is raised. If Y is null, then Tree must be empty. - -- Otherwise Y denotes the insertion position, and Before specifies - -- whether the new node is Y's left (True) or right (False) child. - - generic - with procedure Insert_Post - (T : in out Tree_Type; - Y : Node_Access; - B : Boolean; - Z : out Node_Access); - - procedure Generic_Conditional_Insert - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access; - Inserted : out Boolean); - -- Inserts a new node in Tree, but only if the tree does not already - -- contain Key. Generic_Conditional_Insert first searches for a key - -- equivalent to Key in Tree. If an equivalent key is found, then on - -- output Node designates the node with that key and Inserted is - -- False; there is no allocation and Tree is not modified. Otherwise - -- Node designates a new node allocated using Insert_Post, and - -- Inserted is True. - - generic - with procedure Insert_Post - (T : in out Tree_Type; - Y : Node_Access; - B : Boolean; - Z : out Node_Access); - - procedure Generic_Unconditional_Insert - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access); - -- Inserts a new node in Tree. On output Node designates the new - -- node, which is allocated using Insert_Post. The node is inserted - -- immediately after already-existing equivalent keys. - - generic - with procedure Insert_Post - (T : in out Tree_Type; - Y : Node_Access; - B : Boolean; - Z : out Node_Access); - - with procedure Unconditional_Insert_Sans_Hint - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access); - - procedure Generic_Unconditional_Insert_With_Hint - (Tree : in out Tree_Type; - Hint : Node_Access; - Key : Key_Type; - Node : out Node_Access); - -- Inserts a new node in Tree near position Hint, to avoid having to - -- search from the root for the insertion position. If Hint is null - -- then Generic_Unconditional_Insert_With_Hint attempts to insert - -- the new node after Tree.Last. If Hint is non-null then if Key is - -- less than Hint, it attempts to insert the new node immediately - -- prior to Hint. Otherwise it attempts to insert the node - -- immediately following Hint. We say "attempts" above to emphasize - -- that insertions always preserve invariants with respect to key - -- order, even when there's a hint. So if Key can't be inserted - -- immediately near Hint, then the new node is inserted in the - -- normal way, by searching for the correct position starting from - -- the root. - - generic - with procedure Insert_Post - (T : in out Tree_Type; - Y : Node_Access; - B : Boolean; - Z : out Node_Access); - - with procedure Conditional_Insert_Sans_Hint - (Tree : in out Tree_Type; - Key : Key_Type; - Node : out Node_Access; - Inserted : out Boolean); - - procedure Generic_Conditional_Insert_With_Hint - (Tree : in out Tree_Type; - Position : Node_Access; -- the hint - Key : Key_Type; - Node : out Node_Access; - Inserted : out Boolean); - -- Inserts a new node in Tree if the tree does not already contain - -- Key, using Position as a hint about where to insert the new node. - -- See Generic_Unconditional_Insert_With_Hint for more details about - -- hint semantics. - - function Find - (Tree : Tree_Type; - Key : Key_Type) return Node_Access; - -- Searches Tree for the smallest node equivalent to Key - - function Ceiling - (Tree : Tree_Type; - Key : Key_Type) return Node_Access; - -- Searches Tree for the smallest node equal to or greater than Key - - function Floor - (Tree : Tree_Type; - Key : Key_Type) return Node_Access; - -- Searches Tree for the largest node less than or equal to Key - - function Upper_Bound - (Tree : Tree_Type; - Key : Key_Type) return Node_Access; - -- Searches Tree for the smallest node greater than Key - - generic - with procedure Process (Node : Node_Access); - procedure Generic_Iteration - (Tree : Tree_Type; - Key : Key_Type); - -- Calls Process for each node in Tree equivalent to Key, in order - -- from earliest in range to latest. - - generic - with procedure Process (Node : Node_Access); - procedure Generic_Reverse_Iteration - (Tree : Tree_Type; - Key : Key_Type); - -- Calls Process for each node in Tree equivalent to Key, but in - -- order from largest in range to earliest. - -end Ada.Containers.Red_Black_Trees.Generic_Keys; diff --git a/gcc/ada/a-crbtgo.adb b/gcc/ada/a-crbtgo.adb deleted file mode 100644 index 53fe273..0000000 --- a/gcc/ada/a-crbtgo.adb +++ /dev/null @@ -1,1159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- The references below to "CLR" refer to the following book, from which --- several of the algorithms here were adapted: --- Introduction to Algorithms --- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest --- Publisher: The MIT Press (June 18, 1990) --- ISBN: 0262031418 - -with System; use type System.Address; - -package body Ada.Containers.Red_Black_Trees.Generic_Operations is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access); - - procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access); - - procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); - procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); - --- Why is all the following code commented out ??? - --- --------------------- --- -- Check_Invariant -- --- --------------------- - --- procedure Check_Invariant (Tree : Tree_Type) is --- Root : constant Node_Access := Tree.Root; --- --- function Check (Node : Node_Access) return Natural; --- --- ----------- --- -- Check -- --- ----------- --- --- function Check (Node : Node_Access) return Natural is --- begin --- if Node = null then --- return 0; --- end if; --- --- if Color (Node) = Red then --- declare --- L : constant Node_Access := Left (Node); --- begin --- pragma Assert (L = null or else Color (L) = Black); --- null; --- end; --- --- declare --- R : constant Node_Access := Right (Node); --- begin --- pragma Assert (R = null or else Color (R) = Black); --- null; --- end; --- --- declare --- NL : constant Natural := Check (Left (Node)); --- NR : constant Natural := Check (Right (Node)); --- begin --- pragma Assert (NL = NR); --- return NL; --- end; --- end if; --- --- declare --- NL : constant Natural := Check (Left (Node)); --- NR : constant Natural := Check (Right (Node)); --- begin --- pragma Assert (NL = NR); --- return NL + 1; --- end; --- end Check; --- --- -- Start of processing for Check_Invariant --- --- begin --- if Root = null then --- pragma Assert (Tree.First = null); --- pragma Assert (Tree.Last = null); --- pragma Assert (Tree.Length = 0); --- null; --- --- else --- pragma Assert (Color (Root) = Black); --- pragma Assert (Tree.Length > 0); --- pragma Assert (Tree.Root /= null); --- pragma Assert (Tree.First /= null); --- pragma Assert (Tree.Last /= null); --- pragma Assert (Parent (Tree.Root) = null); --- pragma Assert ((Tree.Length > 1) --- or else (Tree.First = Tree.Last --- and Tree.First = Tree.Root)); --- pragma Assert (Left (Tree.First) = null); --- pragma Assert (Right (Tree.Last) = null); --- --- declare --- L : constant Node_Access := Left (Root); --- R : constant Node_Access := Right (Root); --- NL : constant Natural := Check (L); --- NR : constant Natural := Check (R); --- begin --- pragma Assert (NL = NR); --- null; --- end; --- end if; --- end Check_Invariant; - - ------------------ - -- Delete_Fixup -- - ------------------ - - procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is - - -- CLR p274 - - X : Node_Access := Node; - W : Node_Access; - - begin - while X /= Tree.Root - and then Color (X) = Black - loop - if X = Left (Parent (X)) then - W := Right (Parent (X)); - - if Color (W) = Red then - Set_Color (W, Black); - Set_Color (Parent (X), Red); - Left_Rotate (Tree, Parent (X)); - W := Right (Parent (X)); - end if; - - if (Left (W) = null or else Color (Left (W)) = Black) - and then - (Right (W) = null or else Color (Right (W)) = Black) - then - Set_Color (W, Red); - X := Parent (X); - - else - if Right (W) = null - or else Color (Right (W)) = Black - then - -- As a condition for setting the color of the left child to - -- black, the left child access value must be non-null. A - -- truth table analysis shows that if we arrive here, that - -- condition holds, so there's no need for an explicit test. - -- The assertion is here to document what we know is true. - - pragma Assert (Left (W) /= null); - Set_Color (Left (W), Black); - - Set_Color (W, Red); - Right_Rotate (Tree, W); - W := Right (Parent (X)); - end if; - - Set_Color (W, Color (Parent (X))); - Set_Color (Parent (X), Black); - Set_Color (Right (W), Black); - Left_Rotate (Tree, Parent (X)); - X := Tree.Root; - end if; - - else - pragma Assert (X = Right (Parent (X))); - - W := Left (Parent (X)); - - if Color (W) = Red then - Set_Color (W, Black); - Set_Color (Parent (X), Red); - Right_Rotate (Tree, Parent (X)); - W := Left (Parent (X)); - end if; - - if (Left (W) = null or else Color (Left (W)) = Black) - and then - (Right (W) = null or else Color (Right (W)) = Black) - then - Set_Color (W, Red); - X := Parent (X); - - else - if Left (W) = null or else Color (Left (W)) = Black then - - -- As a condition for setting the color of the right child - -- to black, the right child access value must be non-null. - -- A truth table analysis shows that if we arrive here, that - -- condition holds, so there's no need for an explicit test. - -- The assertion is here to document what we know is true. - - pragma Assert (Right (W) /= null); - Set_Color (Right (W), Black); - - Set_Color (W, Red); - Left_Rotate (Tree, W); - W := Left (Parent (X)); - end if; - - Set_Color (W, Color (Parent (X))); - Set_Color (Parent (X), Black); - Set_Color (Left (W), Black); - Right_Rotate (Tree, Parent (X)); - X := Tree.Root; - end if; - end if; - end loop; - - Set_Color (X, Black); - end Delete_Fixup; - - --------------------------- - -- Delete_Node_Sans_Free -- - --------------------------- - - procedure Delete_Node_Sans_Free - (Tree : in out Tree_Type; - Node : Node_Access) - is - -- CLR p273 - - X, Y : Node_Access; - - Z : constant Node_Access := Node; - pragma Assert (Z /= null); - - begin - TC_Check (Tree.TC); - - -- Why are these all commented out ??? - --- pragma Assert (Tree.Length > 0); --- pragma Assert (Tree.Root /= null); --- pragma Assert (Tree.First /= null); --- pragma Assert (Tree.Last /= null); --- pragma Assert (Parent (Tree.Root) = null); --- pragma Assert ((Tree.Length > 1) --- or else (Tree.First = Tree.Last --- and then Tree.First = Tree.Root)); --- pragma Assert ((Left (Node) = null) --- or else (Parent (Left (Node)) = Node)); --- pragma Assert ((Right (Node) = null) --- or else (Parent (Right (Node)) = Node)); --- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) --- or else ((Parent (Node) /= null) and then --- ((Left (Parent (Node)) = Node) --- or else (Right (Parent (Node)) = Node)))); - - if Left (Z) = null then - if Right (Z) = null then - if Z = Tree.First then - Tree.First := Parent (Z); - end if; - - if Z = Tree.Last then - Tree.Last := Parent (Z); - end if; - - if Color (Z) = Black then - Delete_Fixup (Tree, Z); - end if; - - pragma Assert (Left (Z) = null); - pragma Assert (Right (Z) = null); - - if Z = Tree.Root then - pragma Assert (Tree.Length = 1); - pragma Assert (Parent (Z) = null); - Tree.Root := null; - elsif Z = Left (Parent (Z)) then - Set_Left (Parent (Z), null); - else - pragma Assert (Z = Right (Parent (Z))); - Set_Right (Parent (Z), null); - end if; - - else - pragma Assert (Z /= Tree.Last); - - X := Right (Z); - - if Z = Tree.First then - Tree.First := Min (X); - end if; - - if Z = Tree.Root then - Tree.Root := X; - elsif Z = Left (Parent (Z)) then - Set_Left (Parent (Z), X); - else - pragma Assert (Z = Right (Parent (Z))); - Set_Right (Parent (Z), X); - end if; - - Set_Parent (X, Parent (Z)); - - if Color (Z) = Black then - Delete_Fixup (Tree, X); - end if; - end if; - - elsif Right (Z) = null then - pragma Assert (Z /= Tree.First); - - X := Left (Z); - - if Z = Tree.Last then - Tree.Last := Max (X); - end if; - - if Z = Tree.Root then - Tree.Root := X; - elsif Z = Left (Parent (Z)) then - Set_Left (Parent (Z), X); - else - pragma Assert (Z = Right (Parent (Z))); - Set_Right (Parent (Z), X); - end if; - - Set_Parent (X, Parent (Z)); - - if Color (Z) = Black then - Delete_Fixup (Tree, X); - end if; - - else - pragma Assert (Z /= Tree.First); - pragma Assert (Z /= Tree.Last); - - Y := Next (Z); - pragma Assert (Left (Y) = null); - - X := Right (Y); - - if X = null then - if Y = Left (Parent (Y)) then - pragma Assert (Parent (Y) /= Z); - Delete_Swap (Tree, Z, Y); - Set_Left (Parent (Z), Z); - - else - pragma Assert (Y = Right (Parent (Y))); - pragma Assert (Parent (Y) = Z); - Set_Parent (Y, Parent (Z)); - - if Z = Tree.Root then - Tree.Root := Y; - elsif Z = Left (Parent (Z)) then - Set_Left (Parent (Z), Y); - else - pragma Assert (Z = Right (Parent (Z))); - Set_Right (Parent (Z), Y); - end if; - - Set_Left (Y, Left (Z)); - Set_Parent (Left (Y), Y); - Set_Right (Y, Z); - Set_Parent (Z, Y); - Set_Left (Z, null); - Set_Right (Z, null); - - declare - Y_Color : constant Color_Type := Color (Y); - begin - Set_Color (Y, Color (Z)); - Set_Color (Z, Y_Color); - end; - end if; - - if Color (Z) = Black then - Delete_Fixup (Tree, Z); - end if; - - pragma Assert (Left (Z) = null); - pragma Assert (Right (Z) = null); - - if Z = Right (Parent (Z)) then - Set_Right (Parent (Z), null); - else - pragma Assert (Z = Left (Parent (Z))); - Set_Left (Parent (Z), null); - end if; - - else - if Y = Left (Parent (Y)) then - pragma Assert (Parent (Y) /= Z); - - Delete_Swap (Tree, Z, Y); - - Set_Left (Parent (Z), X); - Set_Parent (X, Parent (Z)); - - else - pragma Assert (Y = Right (Parent (Y))); - pragma Assert (Parent (Y) = Z); - - Set_Parent (Y, Parent (Z)); - - if Z = Tree.Root then - Tree.Root := Y; - elsif Z = Left (Parent (Z)) then - Set_Left (Parent (Z), Y); - else - pragma Assert (Z = Right (Parent (Z))); - Set_Right (Parent (Z), Y); - end if; - - Set_Left (Y, Left (Z)); - Set_Parent (Left (Y), Y); - - declare - Y_Color : constant Color_Type := Color (Y); - begin - Set_Color (Y, Color (Z)); - Set_Color (Z, Y_Color); - end; - end if; - - if Color (Z) = Black then - Delete_Fixup (Tree, X); - end if; - end if; - end if; - - Tree.Length := Tree.Length - 1; - end Delete_Node_Sans_Free; - - ----------------- - -- Delete_Swap -- - ----------------- - - procedure Delete_Swap - (Tree : in out Tree_Type; - Z, Y : Node_Access) - is - pragma Assert (Z /= Y); - pragma Assert (Parent (Y) /= Z); - - Y_Parent : constant Node_Access := Parent (Y); - Y_Color : constant Color_Type := Color (Y); - - begin - Set_Parent (Y, Parent (Z)); - Set_Left (Y, Left (Z)); - Set_Right (Y, Right (Z)); - Set_Color (Y, Color (Z)); - - if Tree.Root = Z then - Tree.Root := Y; - elsif Right (Parent (Y)) = Z then - Set_Right (Parent (Y), Y); - else - pragma Assert (Left (Parent (Y)) = Z); - Set_Left (Parent (Y), Y); - end if; - - if Right (Y) /= null then - Set_Parent (Right (Y), Y); - end if; - - if Left (Y) /= null then - Set_Parent (Left (Y), Y); - end if; - - Set_Parent (Z, Y_Parent); - Set_Color (Z, Y_Color); - Set_Left (Z, null); - Set_Right (Z, null); - end Delete_Swap; - - -------------------- - -- Generic_Adjust -- - -------------------- - - procedure Generic_Adjust (Tree : in out Tree_Type) is - N : constant Count_Type := Tree.Length; - Root : constant Node_Access := Tree.Root; - - begin - -- If the counts are nonzero, execution is technically erroneous, but - -- it seems friendly to allow things like concurrent "=" on shared - -- constants. - - Zero_Counts (Tree.TC); - - if N = 0 then - pragma Assert (Root = null); - return; - end if; - - Tree.Root := null; - Tree.First := null; - Tree.Last := null; - Tree.Length := 0; - - Tree.Root := Copy_Tree (Root); - Tree.First := Min (Tree.Root); - Tree.Last := Max (Tree.Root); - Tree.Length := N; - end Generic_Adjust; - - ------------------- - -- Generic_Clear -- - ------------------- - - procedure Generic_Clear (Tree : in out Tree_Type) is - Root : Node_Access := Tree.Root; - begin - TC_Check (Tree.TC); - - Tree := (First => null, - Last => null, - Root => null, - Length => 0, - TC => <>); - - Delete_Tree (Root); - end Generic_Clear; - - ----------------------- - -- Generic_Copy_Tree -- - ----------------------- - - function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is - Target_Root : Node_Access := Copy_Node (Source_Root); - P, X : Node_Access; - - begin - if Right (Source_Root) /= null then - Set_Right - (Node => Target_Root, - Right => Generic_Copy_Tree (Right (Source_Root))); - - Set_Parent - (Node => Right (Target_Root), - Parent => Target_Root); - end if; - - P := Target_Root; - - X := Left (Source_Root); - while X /= null loop - declare - Y : constant Node_Access := Copy_Node (X); - begin - Set_Left (Node => P, Left => Y); - Set_Parent (Node => Y, Parent => P); - - if Right (X) /= null then - Set_Right - (Node => Y, - Right => Generic_Copy_Tree (Right (X))); - - Set_Parent - (Node => Right (Y), - Parent => Y); - end if; - - P := Y; - X := Left (X); - end; - end loop; - - return Target_Root; - - exception - when others => - Delete_Tree (Target_Root); - raise; - end Generic_Copy_Tree; - - ------------------------- - -- Generic_Delete_Tree -- - ------------------------- - - procedure Generic_Delete_Tree (X : in out Node_Access) is - Y : Node_Access; - pragma Warnings (Off, Y); - begin - while X /= null loop - Y := Right (X); - Generic_Delete_Tree (Y); - Y := Left (X); - Free (X); - X := Y; - end loop; - end Generic_Delete_Tree; - - ------------------- - -- Generic_Equal -- - ------------------- - - function Generic_Equal (Left, Right : Tree_Type) return Boolean is - begin - if Left.Length /= Right.Length then - return False; - end if; - - -- If the containers are empty, return a result immediately, so as to - -- not manipulate the tamper bits unnecessarily. - - if Left.Length = 0 then - return True; - end if; - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Node_Access := Left.First; - R_Node : Node_Access := Right.First; - begin - while L_Node /= null loop - if not Is_Equal (L_Node, R_Node) then - return False; - end if; - - L_Node := Next (L_Node); - R_Node := Next (R_Node); - end loop; - end; - - return True; - end Generic_Equal; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration (Tree : Tree_Type) is - procedure Iterate (P : Node_Access); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (P : Node_Access) is - X : Node_Access := P; - begin - while X /= null loop - Iterate (Left (X)); - Process (X); - X := Right (X); - end loop; - end Iterate; - - -- Start of processing for Generic_Iteration - - begin - Iterate (Tree.Root); - end Generic_Iteration; - - ------------------ - -- Generic_Move -- - ------------------ - - procedure Generic_Move (Target, Source : in out Tree_Type) is - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Source.TC); - - Clear (Target); - - Target := Source; - - Source := (First => null, - Last => null, - Root => null, - Length => 0, - TC => <>); - end Generic_Move; - - ------------------ - -- Generic_Read -- - ------------------ - - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - Tree : in out Tree_Type) - is - N : Count_Type'Base; - - Node, Last_Node : Node_Access; - - begin - Clear (Tree); - - Count_Type'Base'Read (Stream, N); - pragma Assert (N >= 0); - - if N = 0 then - return; - end if; - - Node := Read_Node (Stream); - pragma Assert (Node /= null); - pragma Assert (Color (Node) = Red); - - Set_Color (Node, Black); - - Tree.Root := Node; - Tree.First := Node; - Tree.Last := Node; - - Tree.Length := 1; - - for J in Count_Type range 2 .. N loop - Last_Node := Node; - pragma Assert (Last_Node = Tree.Last); - - Node := Read_Node (Stream); - pragma Assert (Node /= null); - pragma Assert (Color (Node) = Red); - - Set_Right (Node => Last_Node, Right => Node); - Tree.Last := Node; - Set_Parent (Node => Node, Parent => Last_Node); - Rebalance_For_Insert (Tree, Node); - Tree.Length := Tree.Length + 1; - end loop; - end Generic_Read; - - ------------------------------- - -- Generic_Reverse_Iteration -- - ------------------------------- - - procedure Generic_Reverse_Iteration (Tree : Tree_Type) - is - procedure Iterate (P : Node_Access); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (P : Node_Access) is - X : Node_Access := P; - begin - while X /= null loop - Iterate (Right (X)); - Process (X); - X := Left (X); - end loop; - end Iterate; - - -- Start of processing for Generic_Reverse_Iteration - - begin - Iterate (Tree.Root); - end Generic_Reverse_Iteration; - - ------------------- - -- Generic_Write -- - ------------------- - - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - Tree : Tree_Type) - is - procedure Process (Node : Node_Access); - pragma Inline (Process); - - procedure Iterate is - new Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Node_Access) is - begin - Write_Node (Stream, Node); - end Process; - - -- Start of processing for Generic_Write - - begin - Count_Type'Base'Write (Stream, Tree.Length); - Iterate (Tree); - end Generic_Write; - - ----------------- - -- Left_Rotate -- - ----------------- - - procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is - - -- CLR p266 - - Y : constant Node_Access := Right (X); - pragma Assert (Y /= null); - - begin - Set_Right (X, Left (Y)); - - if Left (Y) /= null then - Set_Parent (Left (Y), X); - end if; - - Set_Parent (Y, Parent (X)); - - if X = Tree.Root then - Tree.Root := Y; - elsif X = Left (Parent (X)) then - Set_Left (Parent (X), Y); - else - pragma Assert (X = Right (Parent (X))); - Set_Right (Parent (X), Y); - end if; - - Set_Left (Y, X); - Set_Parent (X, Y); - end Left_Rotate; - - --------- - -- Max -- - --------- - - function Max (Node : Node_Access) return Node_Access is - - -- CLR p248 - - X : Node_Access := Node; - Y : Node_Access; - - begin - loop - Y := Right (X); - - if Y = null then - return X; - end if; - - X := Y; - end loop; - end Max; - - --------- - -- Min -- - --------- - - function Min (Node : Node_Access) return Node_Access is - - -- CLR p248 - - X : Node_Access := Node; - Y : Node_Access; - - begin - loop - Y := Left (X); - - if Y = null then - return X; - end if; - - X := Y; - end loop; - end Min; - - ---------- - -- Next -- - ---------- - - function Next (Node : Node_Access) return Node_Access is - begin - -- CLR p249 - - if Node = null then - return null; - end if; - - if Right (Node) /= null then - return Min (Right (Node)); - end if; - - declare - X : Node_Access := Node; - Y : Node_Access := Parent (Node); - - begin - while Y /= null - and then X = Right (Y) - loop - X := Y; - Y := Parent (Y); - end loop; - - return Y; - end; - end Next; - - -------------- - -- Previous -- - -------------- - - function Previous (Node : Node_Access) return Node_Access is - begin - if Node = null then - return null; - end if; - - if Left (Node) /= null then - return Max (Left (Node)); - end if; - - declare - X : Node_Access := Node; - Y : Node_Access := Parent (Node); - - begin - while Y /= null - and then X = Left (Y) - loop - X := Y; - Y := Parent (Y); - end loop; - - return Y; - end; - end Previous; - - -------------------------- - -- Rebalance_For_Insert -- - -------------------------- - - procedure Rebalance_For_Insert - (Tree : in out Tree_Type; - Node : Node_Access) - is - -- CLR p.268 - - X : Node_Access := Node; - pragma Assert (X /= null); - pragma Assert (Color (X) = Red); - - Y : Node_Access; - - begin - while X /= Tree.Root and then Color (Parent (X)) = Red loop - if Parent (X) = Left (Parent (Parent (X))) then - Y := Right (Parent (Parent (X))); - - if Y /= null and then Color (Y) = Red then - Set_Color (Parent (X), Black); - Set_Color (Y, Black); - Set_Color (Parent (Parent (X)), Red); - X := Parent (Parent (X)); - - else - if X = Right (Parent (X)) then - X := Parent (X); - Left_Rotate (Tree, X); - end if; - - Set_Color (Parent (X), Black); - Set_Color (Parent (Parent (X)), Red); - Right_Rotate (Tree, Parent (Parent (X))); - end if; - - else - pragma Assert (Parent (X) = Right (Parent (Parent (X)))); - - Y := Left (Parent (Parent (X))); - - if Y /= null and then Color (Y) = Red then - Set_Color (Parent (X), Black); - Set_Color (Y, Black); - Set_Color (Parent (Parent (X)), Red); - X := Parent (Parent (X)); - - else - if X = Left (Parent (X)) then - X := Parent (X); - Right_Rotate (Tree, X); - end if; - - Set_Color (Parent (X), Black); - Set_Color (Parent (Parent (X)), Red); - Left_Rotate (Tree, Parent (Parent (X))); - end if; - end if; - end loop; - - Set_Color (Tree.Root, Black); - end Rebalance_For_Insert; - - ------------------ - -- Right_Rotate -- - ------------------ - - procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is - X : constant Node_Access := Left (Y); - pragma Assert (X /= null); - - begin - Set_Left (Y, Right (X)); - - if Right (X) /= null then - Set_Parent (Right (X), Y); - end if; - - Set_Parent (X, Parent (Y)); - - if Y = Tree.Root then - Tree.Root := X; - elsif Y = Left (Parent (Y)) then - Set_Left (Parent (Y), X); - else - pragma Assert (Y = Right (Parent (Y))); - Set_Right (Parent (Y), X); - end if; - - Set_Right (X, Y); - Set_Parent (Y, X); - end Right_Rotate; - - --------- - -- Vet -- - --------- - - function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is - begin - if Node = null then - return True; - end if; - - if Parent (Node) = Node - or else Left (Node) = Node - or else Right (Node) = Node - then - return False; - end if; - - if Tree.Length = 0 - or else Tree.Root = null - or else Tree.First = null - or else Tree.Last = null - then - return False; - end if; - - if Parent (Tree.Root) /= null then - return False; - end if; - - if Left (Tree.First) /= null then - return False; - end if; - - if Right (Tree.Last) /= null then - return False; - end if; - - if Tree.Length = 1 then - if Tree.First /= Tree.Last - or else Tree.First /= Tree.Root - then - return False; - end if; - - if Node /= Tree.First then - return False; - end if; - - if Parent (Node) /= null - or else Left (Node) /= null - or else Right (Node) /= null - then - return False; - end if; - - return True; - end if; - - if Tree.First = Tree.Last then - return False; - end if; - - if Tree.Length = 2 then - if Tree.First /= Tree.Root - and then Tree.Last /= Tree.Root - then - return False; - end if; - - if Tree.First /= Node - and then Tree.Last /= Node - then - return False; - end if; - end if; - - if Left (Node) /= null - and then Parent (Left (Node)) /= Node - then - return False; - end if; - - if Right (Node) /= null - and then Parent (Right (Node)) /= Node - then - return False; - end if; - - if Parent (Node) = null then - if Tree.Root /= Node then - return False; - end if; - - elsif Left (Parent (Node)) /= Node - and then Right (Parent (Node)) /= Node - then - return False; - end if; - - return True; - end Vet; - -end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/a-crbtgo.ads b/gcc/ada/a-crbtgo.ads deleted file mode 100644 index 4c19741..0000000 --- a/gcc/ada/a-crbtgo.ads +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Tree_Type is used to implement the ordered containers. This package --- declares the tree operations that do not depend on keys. - -with Ada.Streams; use Ada.Streams; - -generic - with package Tree_Types is new Generic_Tree_Types (<>); - use Tree_Types, Tree_Types.Implementation; - - with function Parent (Node : Node_Access) return Node_Access is <>; - with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>; - with function Left (Node : Node_Access) return Node_Access is <>; - with procedure Set_Left (Node : Node_Access; Left : Node_Access) is <>; - with function Right (Node : Node_Access) return Node_Access is <>; - with procedure Set_Right (Node : Node_Access; Right : Node_Access) is <>; - with function Color (Node : Node_Access) return Color_Type is <>; - with procedure Set_Color (Node : Node_Access; Color : Color_Type) is <>; - -package Ada.Containers.Red_Black_Trees.Generic_Operations is - pragma Pure; - - function Min (Node : Node_Access) return Node_Access; - -- Returns the smallest-valued node of the subtree rooted at Node - - function Max (Node : Node_Access) return Node_Access; - -- Returns the largest-valued node of the subtree rooted at Node - - -- NOTE: The Check_Invariant operation was used during early - -- development of the red-black tree. Now that the tree type - -- implementation has matured, we don't really need Check_Invariant - -- anymore. - - -- procedure Check_Invariant (Tree : Tree_Type); - - function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean; - -- Inspects Node to determine (to the extent possible) whether - -- the node is valid; used to detect if the node is dangling. - - function Next (Node : Node_Access) return Node_Access; - -- Returns the smallest node greater than Node - - function Previous (Node : Node_Access) return Node_Access; - -- Returns the largest node less than Node - - generic - with function Is_Equal (L, R : Node_Access) return Boolean; - function Generic_Equal (Left, Right : Tree_Type) return Boolean; - -- Uses Is_Equal to perform a node-by-node comparison of the - -- Left and Right trees; processing stops as soon as the first - -- non-equal node is found. - - procedure Delete_Node_Sans_Free - (Tree : in out Tree_Type; - Node : Node_Access); - -- Removes Node from Tree without deallocating the node. If Tree - -- is busy then Program_Error is raised. - - generic - with procedure Free (X : in out Node_Access); - procedure Generic_Delete_Tree (X : in out Node_Access); - -- Deallocates the tree rooted at X, calling Free on each node - - generic - with function Copy_Node (Source : Node_Access) return Node_Access; - with procedure Delete_Tree (X : in out Node_Access); - function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access; - -- Copies the tree rooted at Source_Root, using Copy_Node to copy each - -- node of the source tree. If Copy_Node propagates an exception - -- (e.g. Storage_Error), then Delete_Tree is first used to deallocate - -- the target tree, and then the exception is propagated. - - generic - with function Copy_Tree (Root : Node_Access) return Node_Access; - procedure Generic_Adjust (Tree : in out Tree_Type); - -- Used to implement controlled Adjust. On input to Generic_Adjust, Tree - -- holds a bitwise (shallow) copy of the source tree (as would be the case - -- when controlled Adjust is called). On output, Tree holds its own (deep) - -- copy of the source tree, which is constructed by calling Copy_Tree. - - generic - with procedure Delete_Tree (X : in out Node_Access); - procedure Generic_Clear (Tree : in out Tree_Type); - -- Clears Tree by deallocating all of its nodes. If Tree is busy then - -- Program_Error is raised. - - generic - with procedure Clear (Tree : in out Tree_Type); - procedure Generic_Move (Target, Source : in out Tree_Type); - -- Moves the tree belonging to Source onto Target. If Source is busy then - -- Program_Error is raised. Otherwise Target is first cleared (by calling - -- Clear, to deallocate its existing tree), then given the Source tree, and - -- then finally Source is cleared (by setting its pointers to null). - - generic - with procedure Process (Node : Node_Access) is <>; - procedure Generic_Iteration (Tree : Tree_Type); - -- Calls Process for each node in Tree, in order from smallest-valued - -- node to largest-valued node. - - generic - with procedure Process (Node : Node_Access) is <>; - procedure Generic_Reverse_Iteration (Tree : Tree_Type); - -- Calls Process for each node in Tree, in order from largest-valued - -- node to smallest-valued node. - - generic - with procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Access); - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - Tree : Tree_Type); - -- Used to implement stream attribute T'Write. Generic_Write - -- first writes the number of nodes into Stream, then calls - -- Write_Node for each node in Tree. - - generic - with procedure Clear (Tree : in out Tree_Type); - with function Read_Node - (Stream : not null access Root_Stream_Type'Class) return Node_Access; - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - Tree : in out Tree_Type); - -- Used to implement stream attribute T'Read. Generic_Read - -- first clears Tree. It then reads the number of nodes out of - -- Stream, and calls Read_Node for each node in Stream. - - procedure Rebalance_For_Insert - (Tree : in out Tree_Type; - Node : Node_Access); - -- This rebalances Tree to complete the insertion of Node (which - -- must already be linked in at its proper insertion position). - -end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/a-crdlli.adb b/gcc/ada/a-crdlli.adb deleted file mode 100644 index f228ef0..0000000 --- a/gcc/ada/a-crdlli.adb +++ /dev/null @@ -1,1503 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; use type System.Address; - -package body Ada.Containers.Restricted_Doubly_Linked_Lists is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Allocate - (Container : in out List'Class; - New_Item : Element_Type; - New_Node : out Count_Type); - - procedure Free - (Container : in out List'Class; - X : Count_Type); - - procedure Insert_Internal - (Container : in out List'Class; - Before : Count_Type; - New_Node : Count_Type); - - function Vet (Position : Cursor) return Boolean; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : List) return Boolean is - LN : Node_Array renames Left.Nodes; - RN : Node_Array renames Right.Nodes; - - LI : Count_Type := Left.First; - RI : Count_Type := Right.First; - - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Length /= Right.Length then - return False; - end if; - - for J in 1 .. Left.Length loop - if LN (LI).Element /= RN (RI).Element then - return False; - end if; - - LI := LN (LI).Next; - RI := RN (RI).Next; - end loop; - - return True; - end "="; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Container : in out List'Class; - New_Item : Element_Type; - New_Node : out Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Free >= 0 then - New_Node := Container.Free; - N (New_Node).Element := New_Item; - Container.Free := N (New_Node).Next; - - else - New_Node := abs Container.Free; - N (New_Node).Element := New_Item; - Container.Free := Container.Free - 1; - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, No_Element, New_Item, Count); - end Append; - - ------------ - -- Assign -- - ------------ - - procedure Assign (Target : in out List; Source : List) is - begin - if Target'Address = Source'Address then - return; - end if; - - if Target.Capacity < Source.Length then - raise Constraint_Error; -- ??? - end if; - - Clear (Target); - - declare - N : Node_Array renames Source.Nodes; - J : Count_Type := Source.First; - - begin - while J /= 0 loop - Append (Target, N (J).Element); - J := N (J).Next; - end loop; - end; - end Assign; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Container : in out List) is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Container.Length = 0 then - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); --- pragma Assert (Container.Busy = 0); --- pragma Assert (Container.Lock = 0); - return; - end if; - - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - while Container.Length > 1 loop - X := Container.First; - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - - X := Container.First; - - Container.First := 0; - Container.Last := 0; - Container.Length := 0; - - Free (Container, X); - end Clear; - - -------------- - -- Contains -- - -------------- - - function Contains - (Container : List; - Item : Element_Type) return Boolean - is - begin - return Find (Container, Item) /= No_Element; - end Contains; - - ------------ - -- Delete -- - ------------ - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Position.Node = 0 then - raise Constraint_Error; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - - pragma Assert (Vet (Position), "bad cursor in Delete"); - - if Position.Node = Container.First then - Delete_First (Container, Count); - Position := No_Element; - return; - end if; - - if Count = 0 then - Position := No_Element; - return; - end if; - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - pragma Assert (Container.First >= 1); - pragma Assert (Container.Last >= 1); - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - for Index in 1 .. Count loop - pragma Assert (Container.Length >= 2); - - X := Position.Node; - Container.Length := Container.Length - 1; - - if X = Container.Last then - Position := No_Element; - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Free (Container, X); - return; - end if; - - Position.Node := N (X).Next; - - N (N (X).Next).Prev := N (X).Prev; - N (N (X).Prev).Next := N (X).Next; - - Free (Container, X); - end loop; - - Position := No_Element; - end Delete; - - ------------------ - -- Delete_First -- - ------------------ - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - for I in 1 .. Count loop - X := Container.First; - pragma Assert (N (N (X).Next).Prev = Container.First); - - Container.First := N (X).Next; - N (Container.First).Prev := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_First; - - ----------------- - -- Delete_Last -- - ----------------- - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1) - is - N : Node_Array renames Container.Nodes; - X : Count_Type; - - begin - if Count >= Container.Length then - Clear (Container); - return; - end if; - - if Count = 0 then - return; - end if; - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - for I in 1 .. Count loop - X := Container.Last; - pragma Assert (N (N (X).Prev).Next = Container.Last); - - Container.Last := N (X).Prev; - N (Container.Last).Next := 0; - - Container.Length := Container.Length - 1; - - Free (Container, X); - end loop; - end Delete_Last; - - ------------- - -- Element -- - ------------- - - function Element (Position : Cursor) return Element_Type is - begin - if Position.Node = 0 then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Position), "bad cursor in Element"); - - declare - N : Node_Array renames Position.Container.Nodes; - begin - return N (Position.Node).Element; - end; - end Element; - - ---------- - -- Find -- - ---------- - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := Position.Node; - - begin - if Node = 0 then - Node := Container.First; - - else - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - - pragma Assert (Vet (Position), "bad cursor in Find"); - end if; - - while Node /= 0 loop - if Nodes (Node).Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := Nodes (Node).Next; - end loop; - - return No_Element; - end Find; - - ----------- - -- First -- - ----------- - - function First (Container : List) return Cursor is - begin - if Container.First = 0 then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Container.First); - end First; - - ------------------- - -- First_Element -- - ------------------- - - function First_Element (Container : List) return Element_Type is - N : Node_Array renames Container.Nodes; - - begin - if Container.First = 0 then - raise Constraint_Error; - end if; - - return N (Container.First).Element; - end First_Element; - - ---------- - -- Free -- - ---------- - - procedure Free - (Container : in out List'Class; - X : Count_Type) - is - pragma Assert (X > 0); - pragma Assert (X <= Container.Capacity); - - N : Node_Array renames Container.Nodes; - - begin - N (X).Prev := -1; -- Node is deallocated (not on active list) - - if Container.Free >= 0 then - N (X).Next := Container.Free; - Container.Free := X; - - elsif X + 1 = abs Container.Free then - N (X).Next := 0; -- Not strictly necessary, but marginally safer - Container.Free := Container.Free + 1; - - else - Container.Free := abs Container.Free; - - if Container.Free > Container.Capacity then - Container.Free := 0; - - else - for I in Container.Free .. Container.Capacity - 1 loop - N (I).Next := I + 1; - end loop; - - N (Container.Capacity).Next := 0; - end if; - - N (X).Next := Container.Free; - Container.Free := X; - end if; - end Free; - - --------------------- - -- Generic_Sorting -- - --------------------- - - package body Generic_Sorting is - - --------------- - -- Is_Sorted -- - --------------- - - function Is_Sorted (Container : List) return Boolean is - Nodes : Node_Array renames Container.Nodes; - Node : Count_Type := Container.First; - - begin - for I in 2 .. Container.Length loop - if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then - return False; - end if; - - Node := Nodes (Node).Next; - end loop; - - return True; - end Is_Sorted; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Container : in out List) is - N : Node_Array renames Container.Nodes; - - procedure Partition (Pivot, Back : Count_Type); - procedure Sort (Front, Back : Count_Type); - - --------------- - -- Partition -- - --------------- - - procedure Partition (Pivot, Back : Count_Type) is - Node : Count_Type := N (Pivot).Next; - - begin - while Node /= Back loop - if N (Node).Element < N (Pivot).Element then - declare - Prev : constant Count_Type := N (Node).Prev; - Next : constant Count_Type := N (Node).Next; - - begin - N (Prev).Next := Next; - - if Next = 0 then - Container.Last := Prev; - else - N (Next).Prev := Prev; - end if; - - N (Node).Next := Pivot; - N (Node).Prev := N (Pivot).Prev; - - N (Pivot).Prev := Node; - - if N (Node).Prev = 0 then - Container.First := Node; - else - N (N (Node).Prev).Next := Node; - end if; - - Node := Next; - end; - - else - Node := N (Node).Next; - end if; - end loop; - end Partition; - - ---------- - -- Sort -- - ---------- - - procedure Sort (Front, Back : Count_Type) is - Pivot : constant Count_Type := - (if Front = 0 then Container.First else N (Front).Next); - begin - if Pivot /= Back then - Partition (Pivot, Back); - Sort (Front, Pivot); - Sort (Pivot, Back); - end if; - end Sort; - - -- Start of processing for Sort - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - Sort (Front => 0, Back => 0); - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Sort; - - end Generic_Sorting; - - ----------------- - -- Has_Element -- - ----------------- - - function Has_Element (Position : Cursor) return Boolean is - begin - pragma Assert (Vet (Position), "bad cursor in Has_Element"); - return Position.Node /= 0; - end Has_Element; - - ------------ - -- Insert -- - ------------ - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1) - is - First_Node : Count_Type; - New_Node : Count_Type; - - begin - if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - - pragma Assert (Vet (Before), "bad cursor in Insert"); - end if; - - if Count = 0 then - Position := Before; - return; - end if; - - if Container.Length > Container.Capacity - Count then - raise Constraint_Error; - end if; - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - Allocate (Container, New_Item, New_Node); - First_Node := New_Node; - Insert_Internal (Container, Before.Node, New_Node); - - for Index in 2 .. Count loop - Allocate (Container, New_Item, New_Node); - Insert_Internal (Container, Before.Node, New_Node); - end loop; - - Position := Cursor'(Container'Unrestricted_Access, First_Node); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1) - is - Position : Cursor; - pragma Unreferenced (Position); - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - procedure Insert - (Container : in out List; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1) - is - New_Item : Element_Type; -- Do we need to reinit node ??? - pragma Warnings (Off, New_Item); - - begin - Insert (Container, Before, New_Item, Position, Count); - end Insert; - - --------------------- - -- Insert_Internal -- - --------------------- - - procedure Insert_Internal - (Container : in out List'Class; - Before : Count_Type; - New_Node : Count_Type) - is - N : Node_Array renames Container.Nodes; - - begin - if Container.Length = 0 then - pragma Assert (Before = 0); - pragma Assert (Container.First = 0); - pragma Assert (Container.Last = 0); - - Container.First := New_Node; - Container.Last := New_Node; - - N (Container.First).Prev := 0; - N (Container.Last).Next := 0; - - elsif Before = 0 then - pragma Assert (N (Container.Last).Next = 0); - - N (Container.Last).Next := New_Node; - N (New_Node).Prev := Container.Last; - - Container.Last := New_Node; - N (Container.Last).Next := 0; - - elsif Before = Container.First then - pragma Assert (N (Container.First).Prev = 0); - - N (Container.First).Prev := New_Node; - N (New_Node).Next := Container.First; - - Container.First := New_Node; - N (Container.First).Prev := 0; - - else - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - - N (New_Node).Next := Before; - N (New_Node).Prev := N (Before).Prev; - - N (N (Before).Prev).Next := New_Node; - N (Before).Prev := New_Node; - end if; - - Container.Length := Container.Length + 1; - end Insert_Internal; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Container : List) return Boolean is - begin - return Container.Length = 0; - end Is_Empty; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - C : List renames Container'Unrestricted_Access.all; - N : Node_Array renames C.Nodes; --- B : Natural renames C.Busy; - - Node : Count_Type := Container.First; - - Index : Count_Type := 0; - Index_Max : constant Count_Type := Container.Length; - - begin - if Index_Max = 0 then - pragma Assert (Node = 0); - return; - end if; - - loop - pragma Assert (Node /= 0); - - Process (Cursor'(C'Unchecked_Access, Node)); - pragma Assert (Container.Length = Index_Max); - pragma Assert (N (Node).Prev /= -1); - - Node := N (Node).Next; - Index := Index + 1; - - if Index = Index_Max then - pragma Assert (Node = 0); - return; - end if; - end loop; - end Iterate; - - ---------- - -- Last -- - ---------- - - function Last (Container : List) return Cursor is - begin - if Container.Last = 0 then - return No_Element; - end if; - - return Cursor'(Container'Unrestricted_Access, Container.Last); - end Last; - - ------------------ - -- Last_Element -- - ------------------ - - function Last_Element (Container : List) return Element_Type is - N : Node_Array renames Container.Nodes; - - begin - if Container.Last = 0 then - raise Constraint_Error; - end if; - - return N (Container.Last).Element; - end Last_Element; - - ------------ - -- Length -- - ------------ - - function Length (Container : List) return Count_Type is - begin - return Container.Length; - end Length; - - ---------- - -- Next -- - ---------- - - procedure Next (Position : in out Cursor) is - begin - Position := Next (Position); - end Next; - - function Next (Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Next"); - - declare - Nodes : Node_Array renames Position.Container.Nodes; - Node : constant Count_Type := Nodes (Position.Node).Next; - - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Next; - - ------------- - -- Prepend -- - ------------- - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1) - is - begin - Insert (Container, First (Container), New_Item, Count); - end Prepend; - - -------------- - -- Previous -- - -------------- - - procedure Previous (Position : in out Cursor) is - begin - Position := Previous (Position); - end Previous; - - function Previous (Position : Cursor) return Cursor is - begin - if Position.Node = 0 then - return No_Element; - end if; - - pragma Assert (Vet (Position), "bad cursor in Previous"); - - declare - Nodes : Node_Array renames Position.Container.Nodes; - Node : constant Count_Type := Nodes (Position.Node).Prev; - begin - if Node = 0 then - return No_Element; - end if; - - return Cursor'(Position.Container, Node); - end; - end Previous; - - ------------------- - -- Query_Element -- - ------------------- - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)) - is - begin - if Position.Node = 0 then - raise Constraint_Error; - end if; - - pragma Assert (Vet (Position), "bad cursor in Query_Element"); - - declare - C : List renames Position.Container.all'Unrestricted_Access.all; - N : Node_Type renames C.Nodes (Position.Node); - - begin - Process (N.Element); - pragma Assert (N.Prev >= 0); - end; - end Query_Element; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type) - is - begin - if Position.Container = null then - raise Constraint_Error; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - --- if Container.Lock > 0 then --- raise Program_Error; --- end if; - - pragma Assert (Vet (Position), "bad cursor in Replace_Element"); - - declare - N : Node_Array renames Container.Nodes; - begin - N (Position.Node).Element := New_Item; - end; - end Replace_Element; - - ---------------------- - -- Reverse_Elements -- - ---------------------- - - procedure Reverse_Elements (Container : in out List) is - N : Node_Array renames Container.Nodes; - I : Count_Type := Container.First; - J : Count_Type := Container.Last; - - procedure Swap (L, R : Count_Type); - - ---------- - -- Swap -- - ---------- - - procedure Swap (L, R : Count_Type) is - LN : constant Count_Type := N (L).Next; - LP : constant Count_Type := N (L).Prev; - - RN : constant Count_Type := N (R).Next; - RP : constant Count_Type := N (R).Prev; - - begin - if LP /= 0 then - N (LP).Next := R; - end if; - - if RN /= 0 then - N (RN).Prev := L; - end if; - - N (L).Next := RN; - N (R).Prev := LP; - - if LN = R then - pragma Assert (RP = L); - - N (L).Prev := R; - N (R).Next := L; - - else - N (L).Prev := RP; - N (RP).Next := L; - - N (R).Next := LN; - N (LN).Prev := R; - end if; - end Swap; - - -- Start of processing for Reverse_Elements - - begin - if Container.Length <= 1 then - return; - end if; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - Container.First := J; - Container.Last := I; - loop - Swap (L => I, R => J); - - J := N (J).Next; - exit when I = J; - - I := N (I).Prev; - exit when I = J; - - Swap (L => J, R => I); - - I := N (I).Next; - exit when I = J; - - J := N (J).Prev; - exit when I = J; - end loop; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Reverse_Elements; - - ------------------ - -- Reverse_Find -- - ------------------ - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor - is - N : Node_Array renames Container.Nodes; - Node : Count_Type := Position.Node; - - begin - if Node = 0 then - Node := Container.Last; - - else - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - - pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); - end if; - - while Node /= 0 loop - if N (Node).Element = Item then - return Cursor'(Container'Unrestricted_Access, Node); - end if; - - Node := N (Node).Prev; - end loop; - - return No_Element; - end Reverse_Find; - - --------------------- - -- Reverse_Iterate -- - --------------------- - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)) - is - C : List renames Container'Unrestricted_Access.all; - N : Node_Array renames C.Nodes; --- B : Natural renames C.Busy; - - Node : Count_Type := Container.Last; - - Index : Count_Type := 0; - Index_Max : constant Count_Type := Container.Length; - - begin - if Index_Max = 0 then - pragma Assert (Node = 0); - return; - end if; - - loop - pragma Assert (Node > 0); - - Process (Cursor'(C'Unchecked_Access, Node)); - pragma Assert (Container.Length = Index_Max); - pragma Assert (N (Node).Prev /= -1); - - Node := N (Node).Prev; - Index := Index + 1; - - if Index = Index_Max then - pragma Assert (Node = 0); - return; - end if; - end loop; - end Reverse_Iterate; - - ------------ - -- Splice -- - ------------ - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : in out Cursor) - is - N : Node_Array renames Container.Nodes; - - begin - if Before.Container /= null then - if Before.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - - pragma Assert (Vet (Before), "bad Before cursor in Splice"); - end if; - - if Position.Node = 0 then - raise Constraint_Error; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - - pragma Assert (Vet (Position), "bad Position cursor in Splice"); - - if Position.Node = Before.Node - or else N (Position.Node).Next = Before.Node - then - return; - end if; - - pragma Assert (Container.Length >= 2); - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - if Before.Node = 0 then - pragma Assert (Position.Node /= Container.Last); - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.Last).Next := Position.Node; - N (Position.Node).Prev := Container.Last; - - Container.Last := Position.Node; - N (Container.Last).Next := 0; - - return; - end if; - - if Before.Node = Container.First then - pragma Assert (Position.Node /= Container.First); - - if Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (Container.First).Prev := Position.Node; - N (Position.Node).Next := Container.First; - - Container.First := Position.Node; - N (Container.First).Prev := 0; - - return; - end if; - - if Position.Node = Container.First then - Container.First := N (Position.Node).Next; - N (Container.First).Prev := 0; - - elsif Position.Node = Container.Last then - Container.Last := N (Position.Node).Prev; - N (Container.Last).Next := 0; - - else - N (N (Position.Node).Prev).Next := N (Position.Node).Next; - N (N (Position.Node).Next).Prev := N (Position.Node).Prev; - end if; - - N (N (Before.Node).Prev).Next := Position.Node; - N (Position.Node).Prev := N (Before.Node).Prev; - - N (Before.Node).Prev := Position.Node; - N (Position.Node).Next := Before.Node; - - pragma Assert (N (Container.First).Prev = 0); - pragma Assert (N (Container.Last).Next = 0); - end Splice; - - ---------- - -- Swap -- - ---------- - - procedure Swap - (Container : in out List; - I, J : Cursor) - is - begin - if I.Node = 0 - or else J.Node = 0 - then - raise Constraint_Error; - end if; - - if I.Container /= Container'Unrestricted_Access - or else J.Container /= Container'Unrestricted_Access - then - raise Program_Error; - end if; - - if I.Node = J.Node then - return; - end if; - --- if Container.Lock > 0 then --- raise Program_Error; --- end if; - - pragma Assert (Vet (I), "bad I cursor in Swap"); - pragma Assert (Vet (J), "bad J cursor in Swap"); - - declare - N : Node_Array renames Container.Nodes; - - EI : Element_Type renames N (I.Node).Element; - EJ : Element_Type renames N (J.Node).Element; - - EI_Copy : constant Element_Type := EI; - - begin - EI := EJ; - EJ := EI_Copy; - end; - end Swap; - - ---------------- - -- Swap_Links -- - ---------------- - - procedure Swap_Links - (Container : in out List; - I, J : Cursor) - is - begin - if I.Node = 0 - or else J.Node = 0 - then - raise Constraint_Error; - end if; - - if I.Container /= Container'Unrestricted_Access - or else I.Container /= J.Container - then - raise Program_Error; - end if; - - if I.Node = J.Node then - return; - end if; - --- if Container.Busy > 0 then --- raise Program_Error; --- end if; - - pragma Assert (Vet (I), "bad I cursor in Swap_Links"); - pragma Assert (Vet (J), "bad J cursor in Swap_Links"); - - declare - I_Next : constant Cursor := Next (I); - - J_Copy : Cursor := J; - pragma Warnings (Off, J_Copy); - - begin - if I_Next = J then - Splice (Container, Before => I, Position => J_Copy); - - else - declare - J_Next : constant Cursor := Next (J); - - I_Copy : Cursor := I; - pragma Warnings (Off, I_Copy); - - begin - if J_Next = I then - Splice (Container, Before => J, Position => I_Copy); - - else - pragma Assert (Container.Length >= 3); - - Splice (Container, Before => I_Next, Position => J_Copy); - Splice (Container, Before => J_Next, Position => I_Copy); - end if; - end; - end if; - end; - end Swap_Links; - - -------------------- - -- Update_Element -- - -------------------- - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)) - is - begin - if Position.Node = 0 then - raise Constraint_Error; - end if; - - if Position.Container /= Container'Unrestricted_Access then - raise Program_Error; - end if; - - pragma Assert (Vet (Position), "bad cursor in Update_Element"); - - declare - N : Node_Type renames Container.Nodes (Position.Node); - - begin - Process (N.Element); - pragma Assert (N.Prev >= 0); - end; - end Update_Element; - - --------- - -- Vet -- - --------- - - function Vet (Position : Cursor) return Boolean is - begin - if Position.Node = 0 then - return Position.Container = null; - end if; - - if Position.Container = null then - return False; - end if; - - declare - L : List renames Position.Container.all; - N : Node_Array renames L.Nodes; - - begin - if L.Length = 0 then - return False; - end if; - - if L.First = 0 then - return False; - end if; - - if L.Last = 0 then - return False; - end if; - - if Position.Node > L.Capacity then - return False; - end if; - - if N (Position.Node).Prev < 0 - or else N (Position.Node).Prev > L.Capacity - then - return False; - end if; - - if N (Position.Node).Next > L.Capacity then - return False; - end if; - - if N (L.First).Prev /= 0 then - return False; - end if; - - if N (L.Last).Next /= 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 - and then Position.Node /= L.First - then - return False; - end if; - - if N (Position.Node).Next = 0 - and then Position.Node /= L.Last - then - return False; - end if; - - if L.Length = 1 then - return L.First = L.Last; - end if; - - if L.First = L.Last then - return False; - end if; - - if N (L.First).Next = 0 then - return False; - end if; - - if N (L.Last).Prev = 0 then - return False; - end if; - - if N (N (L.First).Next).Prev /= L.First then - return False; - end if; - - if N (N (L.Last).Prev).Next /= L.Last then - return False; - end if; - - if L.Length = 2 then - if N (L.First).Next /= L.Last then - return False; - end if; - - if N (L.Last).Prev /= L.First then - return False; - end if; - - return True; - end if; - - if N (L.First).Next = L.Last then - return False; - end if; - - if N (L.Last).Prev = L.First then - return False; - end if; - - if Position.Node = L.First then - return True; - end if; - - if Position.Node = L.Last then - return True; - end if; - - if N (Position.Node).Next = 0 then - return False; - end if; - - if N (Position.Node).Prev = 0 then - return False; - end if; - - if N (N (Position.Node).Next).Prev /= Position.Node then - return False; - end if; - - if N (N (Position.Node).Prev).Next /= Position.Node then - return False; - end if; - - if L.Length = 3 then - if N (L.First).Next /= Position.Node then - return False; - end if; - - if N (L.Last).Prev /= Position.Node then - return False; - end if; - end if; - - return True; - end; - end Vet; - -end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/gcc/ada/a-crdlli.ads b/gcc/ada/a-crdlli.ads deleted file mode 100644 index 151d3f9..0000000 --- a/gcc/ada/a-crdlli.ads +++ /dev/null @@ -1,337 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- The doubly-linked list container provides constant-time insertion and --- deletion at all positions, and allows iteration in both the forward and --- reverse directions. This list form allocates storage for all nodes --- statically (there is no dynamic allocation), and a discriminant is used to --- specify the capacity. This container is also "restricted", meaning that --- even though it does raise exceptions (as described below), it does not use --- internal exception handlers. No state changes are made that would need to --- be reverted (in the event of an exception), and so as a consequence, this --- container cannot detect tampering (of cursors or elements). - -generic - type Element_Type is private; - - with function "=" (Left, Right : Element_Type) - return Boolean is <>; - -package Ada.Containers.Restricted_Doubly_Linked_Lists is - pragma Pure; - - type List (Capacity : Count_Type) is tagged limited private; - pragma Preelaborable_Initialization (List); - - type Cursor is private; - pragma Preelaborable_Initialization (Cursor); - - Empty_List : constant List; - -- The default value for list objects declared without an explicit - -- initialization expression. - - No_Element : constant Cursor; - -- The default value for cursor objects declared without an explicit - -- initialization expression. - - function "=" (Left, Right : List) return Boolean; - -- If Left denotes the same list object as Right, then equality returns - -- True. If the length of Left is different from the length of Right, then - -- it returns False. Otherwise, list equality iterates over Left and Right, - -- comparing the element of Left to the corresponding element of Right - -- using the generic actual equality operator for elements. If the elements - -- compare False, then the iteration terminates and list equality returns - -- False. Otherwise, if all elements return True, then list equality - -- returns True. - - procedure Assign (Target : in out List; Source : List); - -- If Target denotes the same list object as Source, the operation does - -- nothing. If Target.Capacity is less than Source.Length, then it raises - -- Constraint_Error. Otherwise, it clears Target, and then inserts each - -- element of Source into Target. - - function Length (Container : List) return Count_Type; - -- Returns the total number of (active) elements in Container - - function Is_Empty (Container : List) return Boolean; - -- Returns True if Container.Length is 0 - - procedure Clear (Container : in out List); - -- Deletes all elements from Container. Note that this is a bounded - -- container and so the element is not "deallocated" in the same sense that - -- an unbounded form would deallocate the element. Rather, the node is - -- relinked off of the active part of the list and onto the inactive part - -- of the list (the storage from which new elements are "allocated"). - - function Element (Position : Cursor) return Element_Type; - -- If Position equals No_Element, then Constraint_Error is raised. - -- Otherwise, function Element returns the element designed by Position. - - procedure Replace_Element - (Container : in out List; - Position : Cursor; - New_Item : Element_Type); - -- If Position equals No_Element, then Constraint_Error is raised. If - -- Position is associated with a list object different from Container, - -- Program_Error is raised. Otherwise, the element designated by Position - -- is assigned the value New_Item. - - procedure Query_Element - (Position : Cursor; - Process : not null access procedure (Element : Element_Type)); - -- If Position equals No_Element, then Constraint_Error is raised. - -- Otherwise, it calls Process with (a constant view of) the element - -- designated by Position as the parameter. - - procedure Update_Element - (Container : in out List; - Position : Cursor; - Process : not null access procedure (Element : in out Element_Type)); - -- If Position equals No_Element, then Constraint_Error is raised. - -- Otherwise, it calls Process with (a variable view of) the element - -- designated by Position as the parameter. - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Count : Count_Type := 1); - -- Inserts Count new elements, all with the value New_Item, into Container, - -- immediately prior to the position specified by Before. If Before has the - -- value No_Element, this is interpreted to mean that the elements are - -- appended to the list. If Before is associated with a list object - -- different from Container, then Program_Error is raised. If there are - -- fewer than Count nodes available, then Constraint_Error is raised. - - procedure Insert - (Container : in out List; - Before : Cursor; - New_Item : Element_Type; - Position : out Cursor; - Count : Count_Type := 1); - -- Inserts elements into Container as described above, but with the - -- difference that cursor Position is returned, which designates the first - -- of the new elements inserted. If Count is 0, Position returns the value - -- Before. - - procedure Insert - (Container : in out List; - Before : Cursor; - Position : out Cursor; - Count : Count_Type := 1); - -- Inserts elements in Container as described above, but with the - -- difference that the new elements are initialized to the default value - -- for objects of type Element_Type. - - procedure Prepend - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - -- Inserts Count elements, all having the value New_Item, prior to the - -- first element of Container. - - procedure Append - (Container : in out List; - New_Item : Element_Type; - Count : Count_Type := 1); - -- Inserts Count elements, all having the value New_Item, following the - -- last element of Container. - - procedure Delete - (Container : in out List; - Position : in out Cursor; - Count : Count_Type := 1); - -- If Position equals No_Element, Constraint_Error is raised. If Position - -- is associated with a list object different from Container, then - -- Program_Error is raised. Otherwise, the Count nodes starting from - -- Position are removed from Container ("removed" meaning that the nodes - -- are unlinked from the active nodes of the list and relinked to inactive - -- storage). On return, Position is set to No_Element. - - procedure Delete_First - (Container : in out List; - Count : Count_Type := 1); - -- Removes the first Count nodes from Container - - procedure Delete_Last - (Container : in out List; - Count : Count_Type := 1); - -- Removes the last Count nodes from Container - - procedure Reverse_Elements (Container : in out List); - -- Relinks the nodes in reverse order - - procedure Swap - (Container : in out List; - I, J : Cursor); - -- If I or J equals No_Element, then Constraint_Error is raised. If I or J - -- is associated with a list object different from Container, then - -- Program_Error is raised. Otherwise, Swap exchanges (copies) the values - -- of the elements (on the nodes) designated by I and J. - - procedure Swap_Links - (Container : in out List; - I, J : Cursor); - -- If I or J equals No_Element, then Constraint_Error is raised. If I or J - -- is associated with a list object different from Container, then - -- Program_Error is raised. Otherwise, Swap exchanges (relinks) the nodes - -- designated by I and J. - - procedure Splice - (Container : in out List; - Before : Cursor; - Position : in out Cursor); - -- If Before is associated with a list object different from Container, - -- then Program_Error is raised. If Position equals No_Element, then - -- Constraint_Error is raised; if it associated with a list object - -- different from Container, then Program_Error is raised. Otherwise, the - -- node designated by Position is relinked immediately prior to Before. If - -- Before equals No_Element, this is interpreted to mean to move the node - -- designed by Position to the last end of the list. - - function First (Container : List) return Cursor; - -- If Container is empty, the function returns No_Element. Otherwise, it - -- returns a cursor designating the first element. - - function First_Element (Container : List) return Element_Type; - -- Equivalent to Element (First (Container)) - - function Last (Container : List) return Cursor; - -- If Container is empty, the function returns No_Element. Otherwise, it - -- returns a cursor designating the last element. - - function Last_Element (Container : List) return Element_Type; - -- Equivalent to Element (Last (Container)) - - function Next (Position : Cursor) return Cursor; - -- If Position equals No_Element or Last (Container), the function returns - -- No_Element. Otherwise, it returns a cursor designating the node that - -- immediately follows the node designated by Position. - - procedure Next (Position : in out Cursor); - -- Equivalent to Position := Next (Position) - - function Previous (Position : Cursor) return Cursor; - -- If Position equals No_Element or First (Container), the function returns - -- No_Element. Otherwise, it returns a cursor designating the node that - -- immediately precedes the node designated by Position. - - procedure Previous (Position : in out Cursor); - -- Equivalent to Position := Previous (Position) - - function Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - -- Searches for the node whose element is equal to Item, starting from - -- Position and continuing to the last end of the list. If Position equals - -- No_Element, the search starts from the first node. If Position is - -- associated with a list object different from Container, then - -- Program_Error is raised. If no node is found having an element equal to - -- Item, then Find returns No_Element. - - function Reverse_Find - (Container : List; - Item : Element_Type; - Position : Cursor := No_Element) return Cursor; - -- Searches in reverse for the node whose element is equal to Item, - -- starting from Position and continuing to the first end of the list. If - -- Position equals No_Element, the search starts from the last node. If - -- Position is associated with a list object different from Container, then - -- Program_Error is raised. If no node is found having an element equal to - -- Item, then Reverse_Find returns No_Element. - - function Contains - (Container : List; - Item : Element_Type) return Boolean; - -- Equivalent to Container.Find (Item) /= No_Element - - function Has_Element (Position : Cursor) return Boolean; - -- Equivalent to Position /= No_Element - - procedure Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - -- Calls Process with a cursor designating each element of Container, in - -- order from Container.First to Container.Last. - - procedure Reverse_Iterate - (Container : List; - Process : not null access procedure (Position : Cursor)); - -- Calls Process with a cursor designating each element of Container, in - -- order from Container.Last to Container.First. - - generic - with function "<" (Left, Right : Element_Type) return Boolean is <>; - package Generic_Sorting is - - function Is_Sorted (Container : List) return Boolean; - -- Returns False if there exists an element which is less than its - -- predecessor. - - procedure Sort (Container : in out List); - -- Sorts the elements of Container (by relinking nodes), according to - -- the order specified by the generic formal less-than operator, such - -- that smaller elements are first in the list. The sort is stable, - -- meaning that the relative order of elements is preserved. - - end Generic_Sorting; - -private - - type Node_Type is limited record - Prev : Count_Type'Base; - Next : Count_Type; - Element : Element_Type; - end record; - - type Node_Array is array (Count_Type range <>) of Node_Type; - - type List (Capacity : Count_Type) is tagged limited record - Nodes : Node_Array (1 .. Capacity) := (others => <>); - Free : Count_Type'Base := -1; - First : Count_Type := 0; - Last : Count_Type := 0; - Length : Count_Type := 0; - end record; - - type List_Access is access all List; - for List_Access'Storage_Size use 0; - - type Cursor is - record - Container : List_Access; - Node : Count_Type := 0; - end record; - - Empty_List : constant List := (0, others => <>); - - No_Element : constant Cursor := (null, 0); - -end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/gcc/ada/a-csquin.ads b/gcc/ada/a-csquin.ads deleted file mode 100644 index c9957a3..0000000 --- a/gcc/ada/a-csquin.ads +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.SYNCHRONIZED_QUEUE_INTERFACES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -generic - type Element_Type is private; - -package Ada.Containers.Synchronized_Queue_Interfaces is - pragma Pure; - - type Queue is synchronized interface; - - procedure Enqueue - (Container : in out Queue; - New_Item : Element_Type) is abstract - with Synchronization => By_Entry; - - procedure Dequeue - (Container : in out Queue; - Element : out Element_Type) is abstract - with Synchronization => By_Entry; - - function Current_Use (Container : Queue) return Count_Type is abstract; - - function Peak_Use (Container : Queue) return Count_Type is abstract; - -end Ada.Containers.Synchronized_Queue_Interfaces; diff --git a/gcc/ada/a-cuprqu.adb b/gcc/ada/a-cuprqu.adb deleted file mode 100644 index 5d1bbac..0000000 --- a/gcc/ada/a-cuprqu.adb +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.UNBOUNDED_PRIORITY_QUEUES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Unbounded_Priority_Queues is - - protected body Queue is - - ----------------- - -- Current_Use -- - ----------------- - - function Current_Use return Count_Type is - begin - return Q_Elems.Length; - end Current_Use; - - ------------- - -- Dequeue -- - ------------- - - entry Dequeue (Element : out Queue_Interfaces.Element_Type) - when Q_Elems.Length > 0 - is - -- Grab the first item of the set, and remove it from the set - - C : constant Cursor := First (Q_Elems); - begin - Element := Sets.Element (C).Item; - Delete_First (Q_Elems); - end Dequeue; - - -------------------------------- - -- Dequeue_Only_High_Priority -- - -------------------------------- - - procedure Dequeue_Only_High_Priority - (At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean) - is - -- Grab the first item. If it exists and has appropriate priority, - -- set Success to True, and remove that item. Otherwise, set Success - -- to False. - - C : constant Cursor := First (Q_Elems); - begin - Success := Has_Element (C) and then - not Before (At_Least, Get_Priority (Sets.Element (C).Item)); - - if Success then - Element := Sets.Element (C).Item; - Delete_First (Q_Elems); - end if; - end Dequeue_Only_High_Priority; - - ------------- - -- Enqueue -- - ------------- - - entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is - begin - Insert (Q_Elems, (Next_Sequence_Number, New_Item)); - Next_Sequence_Number := Next_Sequence_Number + 1; - - -- If we reached a new high-water mark, increase Max_Length - - if Q_Elems.Length > Max_Length then - pragma Assert (Max_Length + 1 = Q_Elems.Length); - Max_Length := Q_Elems.Length; - end if; - end Enqueue; - - -------------- - -- Peak_Use -- - -------------- - - function Peak_Use return Count_Type is - begin - return Max_Length; - end Peak_Use; - - end Queue; - -end Ada.Containers.Unbounded_Priority_Queues; diff --git a/gcc/ada/a-cuprqu.ads b/gcc/ada/a-cuprqu.ads deleted file mode 100644 index 591673e..0000000 --- a/gcc/ada/a-cuprqu.ads +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.UNBOUNDED_PRIORITY_QUEUES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; -with Ada.Containers.Ordered_Sets; -with Ada.Containers.Synchronized_Queue_Interfaces; - -generic - with package Queue_Interfaces is - new Ada.Containers.Synchronized_Queue_Interfaces (<>); - - type Queue_Priority is private; - - with function Get_Priority - (Element : Queue_Interfaces.Element_Type) return Queue_Priority is <>; - - with function Before - (Left, Right : Queue_Priority) return Boolean is <>; - - Default_Ceiling : System.Any_Priority := System.Priority'Last; - -package Ada.Containers.Unbounded_Priority_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - - package Implementation is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - -- We use an ordered set to hold the queue elements. This gives O(lg N) - -- performance in the worst case for Enqueue and Dequeue. - -- Sequence_Number is used to distinguish equivalent items. Each Enqueue - -- uses a higher Sequence_Number, so that a new item is placed after - -- already-enqueued equivalent items. - -- - -- At any time, the first set element is the one to be dequeued next (if - -- the queue is not empty). - - type Set_Elem is record - Sequence_Number : Count_Type; - Item : Queue_Interfaces.Element_Type; - end record; - - function "=" (X, Y : Queue_Interfaces.Element_Type) return Boolean is - (not Before (Get_Priority (X), Get_Priority (Y)) - and then not Before (Get_Priority (Y), Get_Priority (X))); - -- Elements are equal if neither is Before the other - - function "=" (X, Y : Set_Elem) return Boolean is - (X.Sequence_Number = Y.Sequence_Number and then X.Item = Y.Item); - -- Set_Elems are equal if the elements are equal, and the - -- Sequence_Numbers are equal. This is passed to Ordered_Sets. - - function "<" (X, Y : Set_Elem) return Boolean is - (if X.Item = Y.Item - then X.Sequence_Number < Y.Sequence_Number - else Before (Get_Priority (X.Item), Get_Priority (Y.Item))); - -- If the items are equal, Sequence_Number breaks the tie. Otherwise, - -- use Before. This is passed to Ordered_Sets. - - pragma Suppress (Container_Checks); - package Sets is new Ada.Containers.Ordered_Sets (Set_Elem); - - end Implementation; - - use Implementation, Implementation.Sets; - - protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling) - with - Priority => Ceiling - is new Queue_Interfaces.Queue with - - overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); - - overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); - - -- The priority queue operation Dequeue_Only_High_Priority had been a - -- protected entry in early drafts of AI05-0159, but it was discovered - -- that that operation as specified was not in fact implementable. The - -- operation was changed from an entry to a protected procedure per the - -- ARG meeting in Edinburgh (June 2011), with a different signature and - -- semantics. - - procedure Dequeue_Only_High_Priority - (At_Least : Queue_Priority; - Element : in out Queue_Interfaces.Element_Type; - Success : out Boolean); - - overriding function Current_Use return Count_Type; - - overriding function Peak_Use return Count_Type; - - private - Q_Elems : Set; - -- Elements of the queue - - Max_Length : Count_Type := 0; - -- The current length of the queue is the Length of Q_Elems. This is the - -- maximum value of that, so far. Updated by Enqueue. - - Next_Sequence_Number : Count_Type := 0; - -- Steadily increasing counter - end Queue; - -end Ada.Containers.Unbounded_Priority_Queues; diff --git a/gcc/ada/a-cusyqu.adb b/gcc/ada/a-cusyqu.adb deleted file mode 100644 index 4183dcb..0000000 --- a/gcc/ada/a-cusyqu.adb +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.UNBOUNDED_SYNCHRONIZED_QUEUES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -package body Ada.Containers.Unbounded_Synchronized_Queues is - - package body Implementation is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Free is - new Ada.Unchecked_Deallocation (Node_Type, Node_Access); - - ------------- - -- Dequeue -- - ------------- - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type) - is - X : Node_Access; - - begin - Element := List.First.Element; - - X := List.First; - List.First := List.First.Next; - - if List.First = null then - List.Last := null; - end if; - - List.Length := List.Length - 1; - - Free (X); - end Dequeue; - - ------------- - -- Enqueue -- - ------------- - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type) - is - Node : Node_Access; - - begin - Node := new Node_Type'(New_Item, null); - - if List.First = null then - List.First := Node; - List.Last := List.First; - - else - List.Last.Next := Node; - List.Last := Node; - end if; - - List.Length := List.Length + 1; - - if List.Length > List.Max_Length then - List.Max_Length := List.Length; - end if; - end Enqueue; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (List : in out List_Type) is - X : Node_Access; - - begin - while List.First /= null loop - X := List.First; - List.First := List.First.Next; - Free (X); - end loop; - end Finalize; - - ------------ - -- Length -- - ------------ - - function Length (List : List_Type) return Count_Type is - begin - return List.Length; - end Length; - - ---------------- - -- Max_Length -- - ---------------- - - function Max_Length (List : List_Type) return Count_Type is - begin - return List.Max_Length; - end Max_Length; - - end Implementation; - - protected body Queue is - - ----------------- - -- Current_Use -- - ----------------- - - function Current_Use return Count_Type is - begin - return List.Length; - end Current_Use; - - ------------- - -- Dequeue -- - ------------- - - entry Dequeue (Element : out Queue_Interfaces.Element_Type) - when List.Length > 0 - is - begin - List.Dequeue (Element); - end Dequeue; - - ------------- - -- Enqueue -- - ------------- - - entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is - begin - List.Enqueue (New_Item); - end Enqueue; - - -------------- - -- Peak_Use -- - -------------- - - function Peak_Use return Count_Type is - begin - return List.Max_Length; - end Peak_Use; - - end Queue; - -end Ada.Containers.Unbounded_Synchronized_Queues; diff --git a/gcc/ada/a-cusyqu.ads b/gcc/ada/a-cusyqu.ads deleted file mode 100644 index 7efdbf4..0000000 --- a/gcc/ada/a-cusyqu.ads +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.UNBOUNDED_SYNCHRONIZED_QUEUES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; -with Ada.Containers.Synchronized_Queue_Interfaces; -with Ada.Finalization; - -generic - with package Queue_Interfaces is - new Ada.Containers.Synchronized_Queue_Interfaces (<>); - - Default_Ceiling : System.Any_Priority := System.Priority'Last; - -package Ada.Containers.Unbounded_Synchronized_Queues is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Preelaborate; - - package Implementation is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - type List_Type is tagged limited private; - - procedure Enqueue - (List : in out List_Type; - New_Item : Queue_Interfaces.Element_Type); - - procedure Dequeue - (List : in out List_Type; - Element : out Queue_Interfaces.Element_Type); - - function Length (List : List_Type) return Count_Type; - - function Max_Length (List : List_Type) return Count_Type; - - private - - type Node_Type; - type Node_Access is access Node_Type; - - type Node_Type is limited record - Element : Queue_Interfaces.Element_Type; - Next : Node_Access; - end record; - - type List_Type is new Ada.Finalization.Limited_Controlled with record - First, Last : Node_Access; - Length : Count_Type := 0; - Max_Length : Count_Type := 0; - end record; - - overriding procedure Finalize (List : in out List_Type); - - end Implementation; - - protected type Queue - (Ceiling : System.Any_Priority := Default_Ceiling) - with - Priority => Ceiling - is new Queue_Interfaces.Queue with - - overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); - - overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); - - overriding function Current_Use return Count_Type; - - overriding function Peak_Use return Count_Type; - - private - List : Implementation.List_Type; - end Queue; - -end Ada.Containers.Unbounded_Synchronized_Queues; diff --git a/gcc/ada/a-cwila1.ads b/gcc/ada/a-cwila1.ads deleted file mode 100644 index 48c28b3..0000000 --- a/gcc/ada/a-cwila1.ads +++ /dev/null @@ -1,322 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides definitions analogous to those in the RM defined --- package Ada.Characters.Latin_1 except that the type of the constants --- is Wide_Character instead of Character. The provision of this package --- is in accordance with the implementation permission in RM (A.3.3(27)). - -package Ada.Characters.Wide_Latin_1 is - pragma Pure; - - ------------------------ - -- Control Characters -- - ------------------------ - - NUL : constant Wide_Character := Wide_Character'Val (0); - SOH : constant Wide_Character := Wide_Character'Val (1); - STX : constant Wide_Character := Wide_Character'Val (2); - ETX : constant Wide_Character := Wide_Character'Val (3); - EOT : constant Wide_Character := Wide_Character'Val (4); - ENQ : constant Wide_Character := Wide_Character'Val (5); - ACK : constant Wide_Character := Wide_Character'Val (6); - BEL : constant Wide_Character := Wide_Character'Val (7); - BS : constant Wide_Character := Wide_Character'Val (8); - HT : constant Wide_Character := Wide_Character'Val (9); - LF : constant Wide_Character := Wide_Character'Val (10); - VT : constant Wide_Character := Wide_Character'Val (11); - FF : constant Wide_Character := Wide_Character'Val (12); - CR : constant Wide_Character := Wide_Character'Val (13); - SO : constant Wide_Character := Wide_Character'Val (14); - SI : constant Wide_Character := Wide_Character'Val (15); - - DLE : constant Wide_Character := Wide_Character'Val (16); - DC1 : constant Wide_Character := Wide_Character'Val (17); - DC2 : constant Wide_Character := Wide_Character'Val (18); - DC3 : constant Wide_Character := Wide_Character'Val (19); - DC4 : constant Wide_Character := Wide_Character'Val (20); - NAK : constant Wide_Character := Wide_Character'Val (21); - SYN : constant Wide_Character := Wide_Character'Val (22); - ETB : constant Wide_Character := Wide_Character'Val (23); - CAN : constant Wide_Character := Wide_Character'Val (24); - EM : constant Wide_Character := Wide_Character'Val (25); - SUB : constant Wide_Character := Wide_Character'Val (26); - ESC : constant Wide_Character := Wide_Character'Val (27); - FS : constant Wide_Character := Wide_Character'Val (28); - GS : constant Wide_Character := Wide_Character'Val (29); - RS : constant Wide_Character := Wide_Character'Val (30); - US : constant Wide_Character := Wide_Character'Val (31); - - ------------------------------------- - -- ISO 646 Graphic Wide_Characters -- - ------------------------------------- - - Space : constant Wide_Character := ' '; -- WC'Val(32) - Exclamation : constant Wide_Character := '!'; -- WC'Val(33) - Quotation : constant Wide_Character := '"'; -- WC'Val(34) - Number_Sign : constant Wide_Character := '#'; -- WC'Val(35) - Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36) - Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37) - Ampersand : constant Wide_Character := '&'; -- WC'Val(38) - Apostrophe : constant Wide_Character := '''; -- WC'Val(39) - Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40) - Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41) - Asterisk : constant Wide_Character := '*'; -- WC'Val(42) - Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43) - Comma : constant Wide_Character := ','; -- WC'Val(44) - Hyphen : constant Wide_Character := '-'; -- WC'Val(45) - Minus_Sign : Wide_Character renames Hyphen; - Full_Stop : constant Wide_Character := '.'; -- WC'Val(46) - Solidus : constant Wide_Character := '/'; -- WC'Val(47) - - -- Decimal digits '0' though '9' are at positions 48 through 57 - - Colon : constant Wide_Character := ':'; -- WC'Val(58) - Semicolon : constant Wide_Character := ';'; -- WC'Val(59) - Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60) - Equals_Sign : constant Wide_Character := '='; -- WC'Val(61) - Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62) - Question : constant Wide_Character := '?'; -- WC'Val(63) - - Commercial_At : constant Wide_Character := '@'; -- WC'Val(64) - - -- Letters 'A' through 'Z' are at positions 65 through 90 - - Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91) - Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92) - Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93) - Circumflex : constant Wide_Character := '^'; -- WC'Val (94) - Low_Line : constant Wide_Character := '_'; -- WC'Val (95) - - Grave : constant Wide_Character := '`'; -- WC'Val (96) - LC_A : constant Wide_Character := 'a'; -- WC'Val (97) - LC_B : constant Wide_Character := 'b'; -- WC'Val (98) - LC_C : constant Wide_Character := 'c'; -- WC'Val (99) - LC_D : constant Wide_Character := 'd'; -- WC'Val (100) - LC_E : constant Wide_Character := 'e'; -- WC'Val (101) - LC_F : constant Wide_Character := 'f'; -- WC'Val (102) - LC_G : constant Wide_Character := 'g'; -- WC'Val (103) - LC_H : constant Wide_Character := 'h'; -- WC'Val (104) - LC_I : constant Wide_Character := 'i'; -- WC'Val (105) - LC_J : constant Wide_Character := 'j'; -- WC'Val (106) - LC_K : constant Wide_Character := 'k'; -- WC'Val (107) - LC_L : constant Wide_Character := 'l'; -- WC'Val (108) - LC_M : constant Wide_Character := 'm'; -- WC'Val (109) - LC_N : constant Wide_Character := 'n'; -- WC'Val (110) - LC_O : constant Wide_Character := 'o'; -- WC'Val (111) - LC_P : constant Wide_Character := 'p'; -- WC'Val (112) - LC_Q : constant Wide_Character := 'q'; -- WC'Val (113) - LC_R : constant Wide_Character := 'r'; -- WC'Val (114) - LC_S : constant Wide_Character := 's'; -- WC'Val (115) - LC_T : constant Wide_Character := 't'; -- WC'Val (116) - LC_U : constant Wide_Character := 'u'; -- WC'Val (117) - LC_V : constant Wide_Character := 'v'; -- WC'Val (118) - LC_W : constant Wide_Character := 'w'; -- WC'Val (119) - LC_X : constant Wide_Character := 'x'; -- WC'Val (120) - LC_Y : constant Wide_Character := 'y'; -- WC'Val (121) - LC_Z : constant Wide_Character := 'z'; -- WC'Val (122) - Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123) - Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124) - Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125) - Tilde : constant Wide_Character := '~'; -- WC'Val (126) - DEL : constant Wide_Character := Wide_Character'Val (127); - - -------------------------------------- - -- ISO 6429 Control Wide_Characters -- - -------------------------------------- - - IS4 : Wide_Character renames FS; - IS3 : Wide_Character renames GS; - IS2 : Wide_Character renames RS; - IS1 : Wide_Character renames US; - - Reserved_128 : constant Wide_Character := Wide_Character'Val (128); - Reserved_129 : constant Wide_Character := Wide_Character'Val (129); - BPH : constant Wide_Character := Wide_Character'Val (130); - NBH : constant Wide_Character := Wide_Character'Val (131); - Reserved_132 : constant Wide_Character := Wide_Character'Val (132); - NEL : constant Wide_Character := Wide_Character'Val (133); - SSA : constant Wide_Character := Wide_Character'Val (134); - ESA : constant Wide_Character := Wide_Character'Val (135); - HTS : constant Wide_Character := Wide_Character'Val (136); - HTJ : constant Wide_Character := Wide_Character'Val (137); - VTS : constant Wide_Character := Wide_Character'Val (138); - PLD : constant Wide_Character := Wide_Character'Val (139); - PLU : constant Wide_Character := Wide_Character'Val (140); - RI : constant Wide_Character := Wide_Character'Val (141); - SS2 : constant Wide_Character := Wide_Character'Val (142); - SS3 : constant Wide_Character := Wide_Character'Val (143); - - DCS : constant Wide_Character := Wide_Character'Val (144); - PU1 : constant Wide_Character := Wide_Character'Val (145); - PU2 : constant Wide_Character := Wide_Character'Val (146); - STS : constant Wide_Character := Wide_Character'Val (147); - CCH : constant Wide_Character := Wide_Character'Val (148); - MW : constant Wide_Character := Wide_Character'Val (149); - SPA : constant Wide_Character := Wide_Character'Val (150); - EPA : constant Wide_Character := Wide_Character'Val (151); - - SOS : constant Wide_Character := Wide_Character'Val (152); - Reserved_153 : constant Wide_Character := Wide_Character'Val (153); - SCI : constant Wide_Character := Wide_Character'Val (154); - CSI : constant Wide_Character := Wide_Character'Val (155); - ST : constant Wide_Character := Wide_Character'Val (156); - OSC : constant Wide_Character := Wide_Character'Val (157); - PM : constant Wide_Character := Wide_Character'Val (158); - APC : constant Wide_Character := Wide_Character'Val (159); - - ----------------------------------- - -- Other Graphic Wide_Characters -- - ----------------------------------- - - -- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) - - No_Break_Space : constant Wide_Character := Wide_Character'Val (160); - NBSP : Wide_Character renames No_Break_Space; - Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161); - Cent_Sign : constant Wide_Character := Wide_Character'Val (162); - Pound_Sign : constant Wide_Character := Wide_Character'Val (163); - Currency_Sign : constant Wide_Character := Wide_Character'Val (164); - Yen_Sign : constant Wide_Character := Wide_Character'Val (165); - Broken_Bar : constant Wide_Character := Wide_Character'Val (166); - Section_Sign : constant Wide_Character := Wide_Character'Val (167); - Diaeresis : constant Wide_Character := Wide_Character'Val (168); - Copyright_Sign : constant Wide_Character := Wide_Character'Val (169); - Feminine_Ordinal_Indicator - : constant Wide_Character := Wide_Character'Val (170); - Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171); - Not_Sign : constant Wide_Character := Wide_Character'Val (172); - Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173); - Registered_Trade_Mark_Sign - : constant Wide_Character := Wide_Character'Val (174); - Macron : constant Wide_Character := Wide_Character'Val (175); - - -- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) - - Degree_Sign : constant Wide_Character := Wide_Character'Val (176); - Ring_Above : Wide_Character renames Degree_Sign; - Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177); - Superscript_Two : constant Wide_Character := Wide_Character'Val (178); - Superscript_Three : constant Wide_Character := Wide_Character'Val (179); - Acute : constant Wide_Character := Wide_Character'Val (180); - Micro_Sign : constant Wide_Character := Wide_Character'Val (181); - Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182); - Paragraph_Sign : Wide_Character renames Pilcrow_Sign; - Middle_Dot : constant Wide_Character := Wide_Character'Val (183); - Cedilla : constant Wide_Character := Wide_Character'Val (184); - Superscript_One : constant Wide_Character := Wide_Character'Val (185); - Masculine_Ordinal_Indicator - : constant Wide_Character := Wide_Character'Val (186); - Right_Angle_Quotation - : constant Wide_Character := Wide_Character'Val (187); - Fraction_One_Quarter : constant Wide_Character := Wide_Character'Val (188); - Fraction_One_Half : constant Wide_Character := Wide_Character'Val (189); - Fraction_Three_Quarters - : constant Wide_Character := Wide_Character'Val (190); - Inverted_Question : constant Wide_Character := Wide_Character'Val (191); - - -- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) - - UC_A_Grave : constant Wide_Character := Wide_Character'Val (192); - UC_A_Acute : constant Wide_Character := Wide_Character'Val (193); - UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194); - UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195); - UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196); - UC_A_Ring : constant Wide_Character := Wide_Character'Val (197); - UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198); - UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199); - UC_E_Grave : constant Wide_Character := Wide_Character'Val (200); - UC_E_Acute : constant Wide_Character := Wide_Character'Val (201); - UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202); - UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203); - UC_I_Grave : constant Wide_Character := Wide_Character'Val (204); - UC_I_Acute : constant Wide_Character := Wide_Character'Val (205); - UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206); - UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207); - - -- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) - - UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208); - UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209); - UC_O_Grave : constant Wide_Character := Wide_Character'Val (210); - UC_O_Acute : constant Wide_Character := Wide_Character'Val (211); - UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212); - UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213); - UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214); - Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215); - UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216); - UC_U_Grave : constant Wide_Character := Wide_Character'Val (217); - UC_U_Acute : constant Wide_Character := Wide_Character'Val (218); - UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219); - UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220); - UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221); - UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222); - LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223); - - -- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) - - LC_A_Grave : constant Wide_Character := Wide_Character'Val (224); - LC_A_Acute : constant Wide_Character := Wide_Character'Val (225); - LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226); - LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227); - LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228); - LC_A_Ring : constant Wide_Character := Wide_Character'Val (229); - LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230); - LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231); - LC_E_Grave : constant Wide_Character := Wide_Character'Val (232); - LC_E_Acute : constant Wide_Character := Wide_Character'Val (233); - LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234); - LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235); - LC_I_Grave : constant Wide_Character := Wide_Character'Val (236); - LC_I_Acute : constant Wide_Character := Wide_Character'Val (237); - LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238); - LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239); - - -- Wide_Character positions 240 (16#F0#) .. 255 (16#FF) - - LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240); - LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241); - LC_O_Grave : constant Wide_Character := Wide_Character'Val (242); - LC_O_Acute : constant Wide_Character := Wide_Character'Val (243); - LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244); - LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245); - LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246); - Division_Sign : constant Wide_Character := Wide_Character'Val (247); - LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248); - LC_U_Grave : constant Wide_Character := Wide_Character'Val (249); - LC_U_Acute : constant Wide_Character := Wide_Character'Val (250); - LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251); - LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252); - LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253); - LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254); - LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255); - -end Ada.Characters.Wide_Latin_1; diff --git a/gcc/ada/a-cwila9.ads b/gcc/ada/a-cwila9.ads deleted file mode 100644 index 7170c15..0000000 --- a/gcc/ada/a-cwila9.ads +++ /dev/null @@ -1,334 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides definitions analogous to those in the GNAT --- package Ada.Characters.Latin_9 except that the type of the constants --- is Wide_Character instead of Character. The provision of this package --- is in accordance with the implementation permission in RM (A.3.3(27)). - -package Ada.Characters.Wide_Latin_9 is - pragma Pure; - - ------------------------ - -- Control Characters -- - ------------------------ - - NUL : constant Wide_Character := Wide_Character'Val (0); - SOH : constant Wide_Character := Wide_Character'Val (1); - STX : constant Wide_Character := Wide_Character'Val (2); - ETX : constant Wide_Character := Wide_Character'Val (3); - EOT : constant Wide_Character := Wide_Character'Val (4); - ENQ : constant Wide_Character := Wide_Character'Val (5); - ACK : constant Wide_Character := Wide_Character'Val (6); - BEL : constant Wide_Character := Wide_Character'Val (7); - BS : constant Wide_Character := Wide_Character'Val (8); - HT : constant Wide_Character := Wide_Character'Val (9); - LF : constant Wide_Character := Wide_Character'Val (10); - VT : constant Wide_Character := Wide_Character'Val (11); - FF : constant Wide_Character := Wide_Character'Val (12); - CR : constant Wide_Character := Wide_Character'Val (13); - SO : constant Wide_Character := Wide_Character'Val (14); - SI : constant Wide_Character := Wide_Character'Val (15); - - DLE : constant Wide_Character := Wide_Character'Val (16); - DC1 : constant Wide_Character := Wide_Character'Val (17); - DC2 : constant Wide_Character := Wide_Character'Val (18); - DC3 : constant Wide_Character := Wide_Character'Val (19); - DC4 : constant Wide_Character := Wide_Character'Val (20); - NAK : constant Wide_Character := Wide_Character'Val (21); - SYN : constant Wide_Character := Wide_Character'Val (22); - ETB : constant Wide_Character := Wide_Character'Val (23); - CAN : constant Wide_Character := Wide_Character'Val (24); - EM : constant Wide_Character := Wide_Character'Val (25); - SUB : constant Wide_Character := Wide_Character'Val (26); - ESC : constant Wide_Character := Wide_Character'Val (27); - FS : constant Wide_Character := Wide_Character'Val (28); - GS : constant Wide_Character := Wide_Character'Val (29); - RS : constant Wide_Character := Wide_Character'Val (30); - US : constant Wide_Character := Wide_Character'Val (31); - - ------------------------------------- - -- ISO 646 Graphic Wide_Characters -- - ------------------------------------- - - Space : constant Wide_Character := ' '; -- WC'Val(32) - Exclamation : constant Wide_Character := '!'; -- WC'Val(33) - Quotation : constant Wide_Character := '"'; -- WC'Val(34) - Number_Sign : constant Wide_Character := '#'; -- WC'Val(35) - Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36) - Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37) - Ampersand : constant Wide_Character := '&'; -- WC'Val(38) - Apostrophe : constant Wide_Character := '''; -- WC'Val(39) - Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40) - Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41) - Asterisk : constant Wide_Character := '*'; -- WC'Val(42) - Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43) - Comma : constant Wide_Character := ','; -- WC'Val(44) - Hyphen : constant Wide_Character := '-'; -- WC'Val(45) - Minus_Sign : Wide_Character renames Hyphen; - Full_Stop : constant Wide_Character := '.'; -- WC'Val(46) - Solidus : constant Wide_Character := '/'; -- WC'Val(47) - - -- Decimal digits '0' though '9' are at positions 48 through 57 - - Colon : constant Wide_Character := ':'; -- WC'Val(58) - Semicolon : constant Wide_Character := ';'; -- WC'Val(59) - Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60) - Equals_Sign : constant Wide_Character := '='; -- WC'Val(61) - Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62) - Question : constant Wide_Character := '?'; -- WC'Val(63) - - Commercial_At : constant Wide_Character := '@'; -- WC'Val(64) - - -- Letters 'A' through 'Z' are at positions 65 through 90 - - Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91) - Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92) - Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93) - Circumflex : constant Wide_Character := '^'; -- WC'Val (94) - Low_Line : constant Wide_Character := '_'; -- WC'Val (95) - - Grave : constant Wide_Character := '`'; -- WC'Val (96) - LC_A : constant Wide_Character := 'a'; -- WC'Val (97) - LC_B : constant Wide_Character := 'b'; -- WC'Val (98) - LC_C : constant Wide_Character := 'c'; -- WC'Val (99) - LC_D : constant Wide_Character := 'd'; -- WC'Val (100) - LC_E : constant Wide_Character := 'e'; -- WC'Val (101) - LC_F : constant Wide_Character := 'f'; -- WC'Val (102) - LC_G : constant Wide_Character := 'g'; -- WC'Val (103) - LC_H : constant Wide_Character := 'h'; -- WC'Val (104) - LC_I : constant Wide_Character := 'i'; -- WC'Val (105) - LC_J : constant Wide_Character := 'j'; -- WC'Val (106) - LC_K : constant Wide_Character := 'k'; -- WC'Val (107) - LC_L : constant Wide_Character := 'l'; -- WC'Val (108) - LC_M : constant Wide_Character := 'm'; -- WC'Val (109) - LC_N : constant Wide_Character := 'n'; -- WC'Val (110) - LC_O : constant Wide_Character := 'o'; -- WC'Val (111) - LC_P : constant Wide_Character := 'p'; -- WC'Val (112) - LC_Q : constant Wide_Character := 'q'; -- WC'Val (113) - LC_R : constant Wide_Character := 'r'; -- WC'Val (114) - LC_S : constant Wide_Character := 's'; -- WC'Val (115) - LC_T : constant Wide_Character := 't'; -- WC'Val (116) - LC_U : constant Wide_Character := 'u'; -- WC'Val (117) - LC_V : constant Wide_Character := 'v'; -- WC'Val (118) - LC_W : constant Wide_Character := 'w'; -- WC'Val (119) - LC_X : constant Wide_Character := 'x'; -- WC'Val (120) - LC_Y : constant Wide_Character := 'y'; -- WC'Val (121) - LC_Z : constant Wide_Character := 'z'; -- WC'Val (122) - Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123) - Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124) - Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125) - Tilde : constant Wide_Character := '~'; -- WC'Val (126) - DEL : constant Wide_Character := Wide_Character'Val (127); - - -------------------------------------- - -- ISO 6429 Control Wide_Characters -- - -------------------------------------- - - IS4 : Wide_Character renames FS; - IS3 : Wide_Character renames GS; - IS2 : Wide_Character renames RS; - IS1 : Wide_Character renames US; - - Reserved_128 : constant Wide_Character := Wide_Character'Val (128); - Reserved_129 : constant Wide_Character := Wide_Character'Val (129); - BPH : constant Wide_Character := Wide_Character'Val (130); - NBH : constant Wide_Character := Wide_Character'Val (131); - Reserved_132 : constant Wide_Character := Wide_Character'Val (132); - NEL : constant Wide_Character := Wide_Character'Val (133); - SSA : constant Wide_Character := Wide_Character'Val (134); - ESA : constant Wide_Character := Wide_Character'Val (135); - HTS : constant Wide_Character := Wide_Character'Val (136); - HTJ : constant Wide_Character := Wide_Character'Val (137); - VTS : constant Wide_Character := Wide_Character'Val (138); - PLD : constant Wide_Character := Wide_Character'Val (139); - PLU : constant Wide_Character := Wide_Character'Val (140); - RI : constant Wide_Character := Wide_Character'Val (141); - SS2 : constant Wide_Character := Wide_Character'Val (142); - SS3 : constant Wide_Character := Wide_Character'Val (143); - - DCS : constant Wide_Character := Wide_Character'Val (144); - PU1 : constant Wide_Character := Wide_Character'Val (145); - PU2 : constant Wide_Character := Wide_Character'Val (146); - STS : constant Wide_Character := Wide_Character'Val (147); - CCH : constant Wide_Character := Wide_Character'Val (148); - MW : constant Wide_Character := Wide_Character'Val (149); - SPA : constant Wide_Character := Wide_Character'Val (150); - EPA : constant Wide_Character := Wide_Character'Val (151); - - SOS : constant Wide_Character := Wide_Character'Val (152); - Reserved_153 : constant Wide_Character := Wide_Character'Val (153); - SCI : constant Wide_Character := Wide_Character'Val (154); - CSI : constant Wide_Character := Wide_Character'Val (155); - ST : constant Wide_Character := Wide_Character'Val (156); - OSC : constant Wide_Character := Wide_Character'Val (157); - PM : constant Wide_Character := Wide_Character'Val (158); - APC : constant Wide_Character := Wide_Character'Val (159); - - ----------------------------------- - -- Other Graphic Wide_Characters -- - ----------------------------------- - - -- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) - - No_Break_Space : constant Wide_Character := Wide_Character'Val (160); - NBSP : Wide_Character renames No_Break_Space; - Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161); - Cent_Sign : constant Wide_Character := Wide_Character'Val (162); - Pound_Sign : constant Wide_Character := Wide_Character'Val (163); - Euro_Sign : constant Wide_Character := Wide_Character'Val (164); - Yen_Sign : constant Wide_Character := Wide_Character'Val (165); - UC_S_Caron : constant Wide_Character := Wide_Character'Val (166); - Section_Sign : constant Wide_Character := Wide_Character'Val (167); - LC_S_Caron : constant Wide_Character := Wide_Character'Val (168); - Copyright_Sign : constant Wide_Character := Wide_Character'Val (169); - Feminine_Ordinal_Indicator - : constant Wide_Character := Wide_Character'Val (170); - Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171); - Not_Sign : constant Wide_Character := Wide_Character'Val (172); - Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173); - Registered_Trade_Mark_Sign - : constant Wide_Character := Wide_Character'Val (174); - Macron : constant Wide_Character := Wide_Character'Val (175); - - -- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) - - Degree_Sign : constant Wide_Character := Wide_Character'Val (176); - Ring_Above : Wide_Character renames Degree_Sign; - Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177); - Superscript_Two : constant Wide_Character := Wide_Character'Val (178); - Superscript_Three : constant Wide_Character := Wide_Character'Val (179); - UC_Z_Caron : constant Wide_Character := Wide_Character'Val (180); - Micro_Sign : constant Wide_Character := Wide_Character'Val (181); - Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182); - Paragraph_Sign : Wide_Character renames Pilcrow_Sign; - Middle_Dot : constant Wide_Character := Wide_Character'Val (183); - LC_Z_Caron : constant Wide_Character := Wide_Character'Val (184); - Superscript_One : constant Wide_Character := Wide_Character'Val (185); - Masculine_Ordinal_Indicator - : constant Wide_Character := Wide_Character'Val (186); - Right_Angle_Quotation - : constant Wide_Character := Wide_Character'Val (187); - UC_Ligature_OE : constant Wide_Character := Wide_Character'Val (188); - LC_Ligature_OE : constant Wide_Character := Wide_Character'Val (189); - UC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (190); - Inverted_Question : constant Wide_Character := Wide_Character'Val (191); - - -- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) - - UC_A_Grave : constant Wide_Character := Wide_Character'Val (192); - UC_A_Acute : constant Wide_Character := Wide_Character'Val (193); - UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194); - UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195); - UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196); - UC_A_Ring : constant Wide_Character := Wide_Character'Val (197); - UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198); - UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199); - UC_E_Grave : constant Wide_Character := Wide_Character'Val (200); - UC_E_Acute : constant Wide_Character := Wide_Character'Val (201); - UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202); - UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203); - UC_I_Grave : constant Wide_Character := Wide_Character'Val (204); - UC_I_Acute : constant Wide_Character := Wide_Character'Val (205); - UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206); - UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207); - - -- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) - - UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208); - UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209); - UC_O_Grave : constant Wide_Character := Wide_Character'Val (210); - UC_O_Acute : constant Wide_Character := Wide_Character'Val (211); - UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212); - UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213); - UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214); - Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215); - UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216); - UC_U_Grave : constant Wide_Character := Wide_Character'Val (217); - UC_U_Acute : constant Wide_Character := Wide_Character'Val (218); - UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219); - UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220); - UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221); - UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222); - LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223); - - -- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) - - LC_A_Grave : constant Wide_Character := Wide_Character'Val (224); - LC_A_Acute : constant Wide_Character := Wide_Character'Val (225); - LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226); - LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227); - LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228); - LC_A_Ring : constant Wide_Character := Wide_Character'Val (229); - LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230); - LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231); - LC_E_Grave : constant Wide_Character := Wide_Character'Val (232); - LC_E_Acute : constant Wide_Character := Wide_Character'Val (233); - LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234); - LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235); - LC_I_Grave : constant Wide_Character := Wide_Character'Val (236); - LC_I_Acute : constant Wide_Character := Wide_Character'Val (237); - LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238); - LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239); - - -- Wide_Character positions 240 (16#F0#) .. 255 (16#FF) - - LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240); - LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241); - LC_O_Grave : constant Wide_Character := Wide_Character'Val (242); - LC_O_Acute : constant Wide_Character := Wide_Character'Val (243); - LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244); - LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245); - LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246); - Division_Sign : constant Wide_Character := Wide_Character'Val (247); - LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248); - LC_U_Grave : constant Wide_Character := Wide_Character'Val (249); - LC_U_Acute : constant Wide_Character := Wide_Character'Val (250); - LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251); - LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252); - LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253); - LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254); - LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255); - - ------------------------------------------------ - -- Summary of Changes from Latin-1 => Latin-9 -- - ------------------------------------------------ - - -- 164 Currency => Euro_Sign - -- 166 Broken_Bar => UC_S_Caron - -- 168 Diaeresis => LC_S_Caron - -- 180 Acute => UC_Z_Caron - -- 184 Cedilla => LC_Z_Caron - -- 188 Fraction_One_Quarter => UC_Ligature_OE - -- 189 Fraction_One_Half => LC_Ligature_OE - -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis - -end Ada.Characters.Wide_Latin_9; diff --git a/gcc/ada/a-decima.adb b/gcc/ada/a-decima.adb deleted file mode 100644 index b9a9fe5..0000000 --- a/gcc/ada/a-decima.adb +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D E C I M A L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Decimal is - - ------------ - -- Divide -- - ------------ - - procedure Divide - (Dividend : Dividend_Type; - Divisor : Divisor_Type; - Quotient : out Quotient_Type; - Remainder : out Remainder_Type) - is - -- We have a nested procedure that is the actual intrinsic divide. - -- This is required because in the current RM, Divide itself does - -- not have convention Intrinsic. - - procedure Divide - (Dividend : Dividend_Type; - Divisor : Divisor_Type; - Quotient : out Quotient_Type; - Remainder : out Remainder_Type); - - pragma Import (Intrinsic, Divide); - - begin - Divide (Dividend, Divisor, Quotient, Remainder); - end Divide; - -end Ada.Decimal; diff --git a/gcc/ada/a-decima.ads b/gcc/ada/a-decima.ads deleted file mode 100644 index f8e47a8..0000000 --- a/gcc/ada/a-decima.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D E C I M A L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Decimal is - pragma Pure; - - -- The compiler makes a number of assumptions based on the following five - -- constants (e.g. there is an assumption that decimal values can always - -- be represented in 64-bit signed binary form), so code modifications are - -- required to increase these constants. - - Max_Scale : constant := +18; - Min_Scale : constant := -18; - - Min_Delta : constant := 1.0E-18; - Max_Delta : constant := 1.0E+18; - - Max_Decimal_Digits : constant := 18; - - generic - type Dividend_Type is delta <> digits <>; - type Divisor_Type is delta <> digits <>; - type Quotient_Type is delta <> digits <>; - type Remainder_Type is delta <> digits <>; - - procedure Divide - (Dividend : Dividend_Type; - Divisor : Divisor_Type; - Quotient : out Quotient_Type; - Remainder : out Remainder_Type); - -private - pragma Inline (Divide); - -end Ada.Decimal; diff --git a/gcc/ada/a-dhfina.ads b/gcc/ada/a-dhfina.ads deleted file mode 100644 index e34c664..0000000 --- a/gcc/ada/a-dhfina.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.DIRECTORIES.HIERARCHICAL_FILE_NAMES -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Directories.Hierarchical_File_Names is - pragma Unimplemented_Unit; - - function Is_Simple_Name (Name : String) return Boolean; - - function Is_Root_Directory_Name (Name : String) return Boolean; - - function Is_Parent_Directory_Name (Name : String) return Boolean; - - function Is_Current_Directory_Name (Name : String) return Boolean; - - function Is_Full_Name (Name : String) return Boolean; - - function Is_Relative_Name (Name : String) return Boolean; - - function Simple_Name (Name : String) return String - renames Ada.Directories.Simple_Name; - - function Containing_Directory (Name : String) return String - renames Ada.Directories.Containing_Directory; - - function Initial_Directory (Name : String) return String; - - function Relative_Name (Name : String) return String; - - function Compose - (Directory : String := ""; - Relative_Name : String; - Extension : String := "") return String; - -end Ada.Directories.Hierarchical_File_Names; diff --git a/gcc/ada/a-diocst.adb b/gcc/ada/a-diocst.adb deleted file mode 100644 index d685dc2..0000000 --- a/gcc/ada/a-diocst.adb +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T _ I O . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; -with System.Direct_IO; -with Ada.Unchecked_Conversion; - -package body Ada.Direct_IO.C_Streams is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - package DIO renames System.Direct_IO; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - - -------------- - -- C_Stream -- - -------------- - - function C_Stream (F : File_Type) return FILEs is - begin - FIO.Check_File_Open (AP (F)); - return F.Stream; - end C_Stream; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : FILEs; - Form : String := ""; - Name : String := "") - is - Dummy_File_Control_Block : DIO.Direct_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'D', - Creat => False, - Text => False, - C_Stream => C_Stream); - - File.Bytes := Bytes; - end Open; - -end Ada.Direct_IO.C_Streams; diff --git a/gcc/ada/a-diocst.ads b/gcc/ada/a-diocst.ads deleted file mode 100644 index c4fa5e1..0000000 --- a/gcc/ada/a-diocst.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T _ I O . C _ S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface between Ada.Direct_IO and the --- C streams. This allows sharing of a stream between Ada and C or C++, --- as well as allowing the Ada program to operate directly on the stream. - -with Interfaces.C_Streams; - -generic -package Ada.Direct_IO.C_Streams is - - package ICS renames Interfaces.C_Streams; - - function C_Stream (F : File_Type) return ICS.FILEs; - -- Obtain stream from existing open file - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : ICS.FILEs; - Form : String := ""; - Name : String := ""); - -- Create new file from existing stream - -end Ada.Direct_IO.C_Streams; diff --git a/gcc/ada/a-direct.adb b/gcc/ada/a-direct.adb deleted file mode 100644 index 010daf6..0000000 --- a/gcc/ada/a-direct.adb +++ /dev/null @@ -1,1344 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Calendar; use Ada.Calendar; -with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Directories.Validity; use Ada.Directories.Validity; -with Ada.Strings.Fixed; -with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Ada.Unchecked_Deallocation; - -with System; use System; -with System.CRTL; use System.CRTL; -with System.File_Attributes; use System.File_Attributes; -with System.File_IO; use System.File_IO; -with System.OS_Constants; use System.OS_Constants; -with System.OS_Lib; use System.OS_Lib; -with System.Regexp; use System.Regexp; - -package body Ada.Directories is - - type Dir_Type_Value is new Address; - -- This is the low-level address directory structure as returned by the C - -- opendir routine. - - No_Dir : constant Dir_Type_Value := Dir_Type_Value (Null_Address); - -- Null directory value - - Dir_Separator : constant Character; - pragma Import (C, Dir_Separator, "__gnat_dir_separator"); - -- Running system default directory separator - - Dir_Seps : constant Character_Set := Strings.Maps.To_Set ("/\"); - -- UNIX and DOS style directory separators - - Max_Path : Integer; - pragma Import (C, Max_Path, "__gnat_max_path_len"); - -- The maximum length of a path - - type Search_Data is record - Is_Valid : Boolean := False; - Name : Unbounded_String; - Pattern : Regexp; - Filter : Filter_Type; - Dir : Dir_Type_Value := No_Dir; - Entry_Fetched : Boolean := False; - Dir_Entry : Directory_Entry_Type; - end record; - -- The current state of a search - - Empty_String : constant String := (1 .. 0 => ASCII.NUL); - -- Empty string, returned by function Extension when there is no extension - - procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr); - - procedure Close (Dir : Dir_Type_Value); - - function File_Exists (Name : String) return Boolean; - -- Returns True if the named file exists - - procedure Fetch_Next_Entry (Search : Search_Type); - -- Get the next entry in a directory, setting Entry_Fetched if successful - -- or resetting Is_Valid if not. - - --------------- - -- Base_Name -- - --------------- - - function Base_Name (Name : String) return String is - Simple : constant String := Simple_Name (Name); - -- Simple'First is guaranteed to be 1 - - begin - -- Look for the last dot in the file name and return the part of the - -- file name preceding this last dot. If the first dot is the first - -- character of the file name, the base name is the empty string. - - for Pos in reverse Simple'Range loop - if Simple (Pos) = '.' then - return Simple (1 .. Pos - 1); - end if; - end loop; - - -- If there is no dot, return the complete file name - - return Simple; - end Base_Name; - - ----------- - -- Close -- - ----------- - - procedure Close (Dir : Dir_Type_Value) is - Discard : Integer; - pragma Warnings (Off, Discard); - - function closedir (directory : DIRs) return Integer; - pragma Import (C, closedir, "__gnat_closedir"); - - begin - Discard := closedir (DIRs (Dir)); - end Close; - - ------------- - -- Compose -- - ------------- - - function Compose - (Containing_Directory : String := ""; - Name : String; - Extension : String := "") return String - is - Result : String (1 .. Containing_Directory'Length + - Name'Length + Extension'Length + 2); - Last : Natural; - - begin - -- First, deal with the invalid cases - - if Containing_Directory /= "" - and then not Is_Valid_Path_Name (Containing_Directory) - then - raise Name_Error with - "invalid directory path name """ & Containing_Directory & '"'; - - elsif - Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) - then - raise Name_Error with - "invalid simple name """ & Name & '"'; - - elsif Extension'Length /= 0 - and then not Is_Valid_Simple_Name (Name & '.' & Extension) - then - raise Name_Error with - "invalid file name """ & Name & '.' & Extension & '"'; - - -- This is not an invalid case so build the path name - - else - Last := Containing_Directory'Length; - Result (1 .. Last) := Containing_Directory; - - -- Add a directory separator if needed - - if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then - Last := Last + 1; - Result (Last) := Dir_Separator; - end if; - - -- Add the file name - - Result (Last + 1 .. Last + Name'Length) := Name; - Last := Last + Name'Length; - - -- If extension was specified, add dot followed by this extension - - if Extension'Length /= 0 then - Last := Last + 1; - Result (Last) := '.'; - Result (Last + 1 .. Last + Extension'Length) := Extension; - Last := Last + Extension'Length; - end if; - - return Result (1 .. Last); - end if; - end Compose; - - -------------------------- - -- Containing_Directory -- - -------------------------- - - function Containing_Directory (Name : String) return String is - begin - -- First, the invalid case - - if not Is_Valid_Path_Name (Name) then - raise Name_Error with "invalid path name """ & Name & '"'; - - else - declare - Last_DS : constant Natural := - Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward); - - begin - if Last_DS = 0 then - - -- There is no directory separator, returns "." representing - -- the current working directory. - - return "."; - - -- If Name indicates a root directory, raise Use_Error, because - -- it has no containing directory. - - elsif Name = "/" - or else - (Windows - and then - (Name = "\" - or else - (Name'Length = 3 - and then Name (Name'Last - 1 .. Name'Last) = ":\" - and then (Name (Name'First) in 'a' .. 'z' - or else - Name (Name'First) in 'A' .. 'Z')))) - then - raise Use_Error with - "directory """ & Name & """ has no containing directory"; - - else - declare - Last : Positive := Last_DS - Name'First + 1; - Result : String (1 .. Last); - - begin - Result := Name (Name'First .. Last_DS); - - -- Remove any trailing directory separator, except as the - -- first character or the first character following a drive - -- number on Windows. - - while Last > 1 loop - exit when - Result (Last) /= '/' - and then - Result (Last) /= Directory_Separator; - - exit when Windows - and then Last = 3 - and then Result (2) = ':' - and then - (Result (1) in 'A' .. 'Z' - or else - Result (1) in 'a' .. 'z'); - - Last := Last - 1; - end loop; - - -- Special case of "..": the current directory may be a root - -- directory. - - if Last = 2 and then Result (1 .. 2) = ".." then - return Containing_Directory (Current_Directory); - - else - return Result (1 .. Last); - end if; - end; - end if; - end; - end if; - end Containing_Directory; - - --------------- - -- Copy_File -- - --------------- - - procedure Copy_File - (Source_Name : String; - Target_Name : String; - Form : String := "") - is - Success : Boolean; - Mode : Copy_Mode := Overwrite; - Preserve : Attribute := None; - - begin - -- First, the invalid cases - - if not Is_Valid_Path_Name (Source_Name) then - raise Name_Error with - "invalid source path name """ & Source_Name & '"'; - - elsif not Is_Valid_Path_Name (Target_Name) then - raise Name_Error with - "invalid target path name """ & Target_Name & '"'; - - elsif not Is_Regular_File (Source_Name) then - raise Name_Error with '"' & Source_Name & """ is not a file"; - - elsif Is_Directory (Target_Name) then - raise Use_Error with "target """ & Target_Name & """ is a directory"; - - else - if Form'Length > 0 then - declare - Formstr : String (1 .. Form'Length + 1); - V1, V2 : Natural; - - begin - -- Acquire form string, setting required NUL terminator - - Formstr (1 .. Form'Length) := Form; - Formstr (Formstr'Last) := ASCII.NUL; - - -- Convert form string to lower case - - for J in Formstr'Range loop - if Formstr (J) in 'A' .. 'Z' then - Formstr (J) := - Character'Val (Character'Pos (Formstr (J)) + 32); - end if; - end loop; - - -- Check Form - - Form_Parameter (Formstr, "mode", V1, V2); - - if V1 = 0 then - Mode := Overwrite; - elsif Formstr (V1 .. V2) = "copy" then - Mode := Copy; - elsif Formstr (V1 .. V2) = "overwrite" then - Mode := Overwrite; - elsif Formstr (V1 .. V2) = "append" then - Mode := Append; - else - raise Use_Error with "invalid Form"; - end if; - - Form_Parameter (Formstr, "preserve", V1, V2); - - if V1 = 0 then - Preserve := None; - elsif Formstr (V1 .. V2) = "timestamps" then - Preserve := Time_Stamps; - elsif Formstr (V1 .. V2) = "all_attributes" then - Preserve := Full; - elsif Formstr (V1 .. V2) = "no_attributes" then - Preserve := None; - else - raise Use_Error with "invalid Form"; - end if; - end; - end if; - - -- Do actual copy using System.OS_Lib.Copy_File - - Copy_File (Source_Name, Target_Name, Success, Mode, Preserve); - - if not Success then - raise Use_Error with "copy of """ & Source_Name & """ failed"; - end if; - end if; - end Copy_File; - - ---------------------- - -- Create_Directory -- - ---------------------- - - procedure Create_Directory - (New_Directory : String; - Form : String := "") - is - C_Dir_Name : constant String := New_Directory & ASCII.NUL; - - begin - -- First, the invalid case - - if not Is_Valid_Path_Name (New_Directory) then - raise Name_Error with - "invalid new directory path name """ & New_Directory & '"'; - - else - -- Acquire setting of encoding parameter - - declare - Formstr : constant String := To_Lower (Form); - - Encoding : CRTL.Filename_Encoding; - -- Filename encoding specified into the form parameter - - V1, V2 : Natural; - - begin - Form_Parameter (Formstr, "encoding", V1, V2); - - if V1 = 0 then - Encoding := CRTL.Unspecified; - elsif Formstr (V1 .. V2) = "utf8" then - Encoding := CRTL.UTF8; - elsif Formstr (V1 .. V2) = "8bits" then - Encoding := CRTL.ASCII_8bits; - else - raise Use_Error with "invalid Form"; - end if; - - if CRTL.mkdir (C_Dir_Name, Encoding) /= 0 then - raise Use_Error with - "creation of new directory """ & New_Directory & """ failed"; - end if; - end; - end if; - end Create_Directory; - - ----------------- - -- Create_Path -- - ----------------- - - procedure Create_Path - (New_Directory : String; - Form : String := "") - is - New_Dir : String (1 .. New_Directory'Length + 1); - Last : Positive := 1; - Start : Positive := 1; - - begin - -- First, the invalid case - - if not Is_Valid_Path_Name (New_Directory) then - raise Name_Error with - "invalid new directory path name """ & New_Directory & '"'; - - else - -- Build New_Dir with a directory separator at the end, so that the - -- complete path will be found in the loop below. - - New_Dir (1 .. New_Directory'Length) := New_Directory; - New_Dir (New_Dir'Last) := Directory_Separator; - - -- If host is windows, and the first two characters are directory - -- separators, we have an UNC path. Skip it. - - if Directory_Separator = '\' - and then New_Dir'Length > 2 - and then Is_In (New_Dir (1), Dir_Seps) - and then Is_In (New_Dir (2), Dir_Seps) - then - Start := 2; - loop - Start := Start + 1; - exit when Start = New_Dir'Last - or else Is_In (New_Dir (Start), Dir_Seps); - end loop; - end if; - - -- Create, if necessary, each directory in the path - - for J in Start + 1 .. New_Dir'Last loop - - -- Look for the end of an intermediate directory - - if not Is_In (New_Dir (J), Dir_Seps) then - Last := J; - - -- We have found a new intermediate directory each time we find - -- a first directory separator. - - elsif not Is_In (New_Dir (J - 1), Dir_Seps) then - - -- No need to create the directory if it already exists - - if not Is_Directory (New_Dir (1 .. Last)) then - begin - Create_Directory - (New_Directory => New_Dir (1 .. Last), Form => Form); - - exception - when Use_Error => - if File_Exists (New_Dir (1 .. Last)) then - - -- A file with such a name already exists. If it is - -- a directory, then it was apparently just created - -- by another process or thread, and all is well. - -- If it is of some other kind, report an error. - - if not Is_Directory (New_Dir (1 .. Last)) then - raise Use_Error with - "file """ & New_Dir (1 .. Last) & - """ already exists and is not a directory"; - end if; - - else - -- Create_Directory failed for some other reason: - -- propagate the exception. - - raise; - end if; - end; - end if; - end if; - end loop; - end if; - end Create_Path; - - ----------------------- - -- Current_Directory -- - ----------------------- - - function Current_Directory return String is - Path_Len : Natural := Max_Path; - Buffer : String (1 .. 1 + Max_Path + 1); - - procedure Local_Get_Current_Dir (Dir : Address; Length : Address); - pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); - - begin - Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); - - if Path_Len = 0 then - raise Use_Error with "current directory does not exist"; - end if; - - -- We need to resolve links because of RM A.16(47), which requires - -- that we not return alternative names for files. - - return Normalize_Pathname (Buffer (1 .. Path_Len)); - end Current_Directory; - - ---------------------- - -- Delete_Directory -- - ---------------------- - - procedure Delete_Directory (Directory : String) is - begin - -- First, the invalid cases - - if not Is_Valid_Path_Name (Directory) then - raise Name_Error with - "invalid directory path name """ & Directory & '"'; - - elsif not Is_Directory (Directory) then - raise Name_Error with '"' & Directory & """ not a directory"; - - -- Do the deletion, checking for error - - else - declare - C_Dir_Name : constant String := Directory & ASCII.NUL; - begin - if rmdir (C_Dir_Name) /= 0 then - raise Use_Error with - "deletion of directory """ & Directory & """ failed"; - end if; - end; - end if; - end Delete_Directory; - - ----------------- - -- Delete_File -- - ----------------- - - procedure Delete_File (Name : String) is - Success : Boolean; - - begin - -- First, the invalid cases - - if not Is_Valid_Path_Name (Name) then - raise Name_Error with "invalid path name """ & Name & '"'; - - elsif not Is_Regular_File (Name) - and then not Is_Symbolic_Link (Name) - then - raise Name_Error with "file """ & Name & """ does not exist"; - - else - -- Do actual deletion using System.OS_Lib.Delete_File - - Delete_File (Name, Success); - - if not Success then - raise Use_Error with "file """ & Name & """ could not be deleted"; - end if; - end if; - end Delete_File; - - ----------------- - -- Delete_Tree -- - ----------------- - - procedure Delete_Tree (Directory : String) is - Search : Search_Type; - Dir_Ent : Directory_Entry_Type; - begin - -- First, the invalid cases - - if not Is_Valid_Path_Name (Directory) then - raise Name_Error with - "invalid directory path name """ & Directory & '"'; - - elsif not Is_Directory (Directory) then - raise Name_Error with '"' & Directory & """ not a directory"; - - else - - -- We used to change the current directory to Directory here, - -- allowing the use of a local Simple_Name for all references. This - -- turned out unfriendly to multitasking programs, where tasks - -- running in parallel of this Delete_Tree could see their current - -- directory change unpredictably. We now resort to Full_Name - -- computations to reach files and subdirs instead. - - Start_Search (Search, Directory => Directory, Pattern => ""); - while More_Entries (Search) loop - Get_Next_Entry (Search, Dir_Ent); - - declare - Fname : constant String := Full_Name (Dir_Ent); - Sname : constant String := Simple_Name (Dir_Ent); - - begin - if OS_Lib.Is_Directory (Fname) then - if Sname /= "." and then Sname /= ".." then - Delete_Tree (Fname); - end if; - else - Delete_File (Fname); - end if; - end; - end loop; - - End_Search (Search); - - declare - C_Dir_Name : constant String := Directory & ASCII.NUL; - - begin - if rmdir (C_Dir_Name) /= 0 then - raise Use_Error with - "directory tree rooted at """ & - Directory & """ could not be deleted"; - end if; - end; - end if; - end Delete_Tree; - - ------------ - -- Exists -- - ------------ - - function Exists (Name : String) return Boolean is - begin - -- First, the invalid case - - if not Is_Valid_Path_Name (Name) then - raise Name_Error with "invalid path name """ & Name & '"'; - - else - -- The implementation is in File_Exists - - return File_Exists (Name); - end if; - end Exists; - - --------------- - -- Extension -- - --------------- - - function Extension (Name : String) return String is - begin - -- First, the invalid case - - if not Is_Valid_Path_Name (Name) then - raise Name_Error with "invalid path name """ & Name & '"'; - - else - -- Look for first dot that is not followed by a directory separator - - for Pos in reverse Name'Range loop - - -- If a directory separator is found before a dot, there is no - -- extension. - - if Is_In (Name (Pos), Dir_Seps) then - return Empty_String; - - elsif Name (Pos) = '.' then - - -- We found a dot, build the return value with lower bound 1 - - declare - subtype Result_Type is String (1 .. Name'Last - Pos); - begin - return Result_Type (Name (Pos + 1 .. Name'Last)); - end; - end if; - end loop; - - -- No dot were found, there is no extension - - return Empty_String; - end if; - end Extension; - - ---------------------- - -- Fetch_Next_Entry -- - ---------------------- - - procedure Fetch_Next_Entry (Search : Search_Type) is - Name : String (1 .. NAME_MAX); - Last : Natural; - - Kind : File_Kind := Ordinary_File; - -- Initialized to avoid a compilation warning - - Filename_Addr : Address; - Filename_Len : aliased Integer; - - Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character; - - function readdir_gnat - (Directory : Address; - Buffer : Address; - Last : not null access Integer) return Address; - pragma Import (C, readdir_gnat, "__gnat_readdir"); - - begin - -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called - - loop - Filename_Addr := - readdir_gnat - (Address (Search.Value.Dir), - Buffer'Address, - Filename_Len'Access); - - -- If no matching entry is found, set Is_Valid to False - - if Filename_Addr = Null_Address then - Search.Value.Is_Valid := False; - exit; - end if; - - if Filename_Len > Name'Length then - raise Use_Error with "file name too long"; - end if; - - declare - subtype Name_String is String (1 .. Filename_Len); - Dent_Name : Name_String; - for Dent_Name'Address use Filename_Addr; - pragma Import (Ada, Dent_Name); - - begin - Last := Filename_Len; - Name (1 .. Last) := Dent_Name; - end; - - -- Check if the entry matches the pattern - - if Match (Name (1 .. Last), Search.Value.Pattern) then - declare - C_Full_Name : constant String := - Compose (To_String (Search.Value.Name), - Name (1 .. Last)) & ASCII.NUL; - Full_Name : String renames - C_Full_Name - (C_Full_Name'First .. C_Full_Name'Last - 1); - Found : Boolean := False; - Attr : aliased File_Attributes; - Exists : Integer; - Error : Integer; - - begin - Reset_Attributes (Attr'Access); - Exists := File_Exists_Attr (C_Full_Name'Address, Attr'Access); - Error := Error_Attributes (Attr'Access); - - if Error /= 0 then - raise Use_Error - with Full_Name & ": " & Errno_Message (Err => Error); - end if; - - if Exists = 1 then - - -- Now check if the file kind matches the filter - - if Is_Regular_File_Attr - (C_Full_Name'Address, Attr'Access) = 1 - then - if Search.Value.Filter (Ordinary_File) then - Kind := Ordinary_File; - Found := True; - end if; - - elsif Is_Directory_Attr - (C_Full_Name'Address, Attr'Access) = 1 - then - if Search.Value.Filter (Directory) then - Kind := Directory; - Found := True; - end if; - - elsif Search.Value.Filter (Special_File) then - Kind := Special_File; - Found := True; - end if; - - -- If it does, update Search and return - - if Found then - Search.Value.Entry_Fetched := True; - Search.Value.Dir_Entry := - (Is_Valid => True, - Simple => To_Unbounded_String (Name (1 .. Last)), - Full => To_Unbounded_String (Full_Name), - Kind => Kind); - exit; - end if; - end if; - end; - end if; - end loop; - end Fetch_Next_Entry; - - ----------------- - -- File_Exists -- - ----------------- - - function File_Exists (Name : String) return Boolean is - function C_File_Exists (A : Address) return Integer; - pragma Import (C, C_File_Exists, "__gnat_file_exists"); - - C_Name : String (1 .. Name'Length + 1); - - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return C_File_Exists (C_Name'Address) = 1; - end File_Exists; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Search : in out Search_Type) is - begin - if Search.Value /= null then - - -- Close the directory, if one is open - - if Search.Value.Dir /= No_Dir then - Close (Search.Value.Dir); - end if; - - Free (Search.Value); - end if; - end Finalize; - - --------------- - -- Full_Name -- - --------------- - - function Full_Name (Name : String) return String is - begin - -- First, the invalid case - - if not Is_Valid_Path_Name (Name) then - raise Name_Error with "invalid path name """ & Name & '"'; - - else - -- Build the return value with lower bound 1 - - -- Use System.OS_Lib.Normalize_Pathname - - declare - -- We need to resolve links because of (RM A.16(47)), which says - -- we must not return alternative names for files. - - Value : constant String := Normalize_Pathname (Name); - subtype Result is String (1 .. Value'Length); - - begin - return Result (Value); - end; - end if; - end Full_Name; - - function Full_Name (Directory_Entry : Directory_Entry_Type) return String is - begin - -- First, the invalid case - - if not Directory_Entry.Is_Valid then - raise Status_Error with "invalid directory entry"; - - else - -- The value to return has already been computed - - return To_String (Directory_Entry.Full); - end if; - end Full_Name; - - -------------------- - -- Get_Next_Entry -- - -------------------- - - procedure Get_Next_Entry - (Search : in out Search_Type; - Directory_Entry : out Directory_Entry_Type) - is - begin - -- First, the invalid case - - if Search.Value = null or else not Search.Value.Is_Valid then - raise Status_Error with "invalid search"; - end if; - - -- Fetch the next entry, if needed - - if not Search.Value.Entry_Fetched then - Fetch_Next_Entry (Search); - end if; - - -- It is an error if no valid entry is found - - if not Search.Value.Is_Valid then - raise Status_Error with "no next entry"; - - else - -- Reset Entry_Fetched and return the entry - - Search.Value.Entry_Fetched := False; - Directory_Entry := Search.Value.Dir_Entry; - end if; - end Get_Next_Entry; - - ---------- - -- Kind -- - ---------- - - function Kind (Name : String) return File_Kind is - begin - -- First, the invalid case - - if not File_Exists (Name) then - raise Name_Error with "file """ & Name & """ does not exist"; - - -- If OK, return appropriate kind - - elsif Is_Regular_File (Name) then - return Ordinary_File; - - elsif Is_Directory (Name) then - return Directory; - - else - return Special_File; - end if; - end Kind; - - function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is - begin - -- First, the invalid case - - if not Directory_Entry.Is_Valid then - raise Status_Error with "invalid directory entry"; - - else - -- The value to return has already be computed - - return Directory_Entry.Kind; - end if; - end Kind; - - ----------------------- - -- Modification_Time -- - ----------------------- - - function Modification_Time (Name : String) return Time is - Date : OS_Time; - Year : Year_Type; - Month : Month_Type; - Day : Day_Type; - Hour : Hour_Type; - Minute : Minute_Type; - Second : Second_Type; - - begin - -- First, the invalid cases - - if not (Is_Regular_File (Name) or else Is_Directory (Name)) then - raise Name_Error with '"' & Name & """ not a file or directory"; - - else - Date := File_Time_Stamp (Name); - - -- Break down the time stamp into its constituents relative to GMT. - -- This version of Split does not recognize leap seconds or buffer - -- space for time zone processing. - - GM_Split (Date, Year, Month, Day, Hour, Minute, Second); - - -- The result must be in GMT. Ada.Calendar. - -- Formatting.Time_Of with default time zone of zero (0) is the - -- routine of choice. - - return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); - end if; - end Modification_Time; - - function Modification_Time - (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time - is - begin - -- First, the invalid case - - if not Directory_Entry.Is_Valid then - raise Status_Error with "invalid directory entry"; - - else - -- The value to return has already be computed - - return Modification_Time (To_String (Directory_Entry.Full)); - end if; - end Modification_Time; - - ------------------ - -- More_Entries -- - ------------------ - - function More_Entries (Search : Search_Type) return Boolean is - begin - if Search.Value = null then - return False; - - elsif Search.Value.Is_Valid then - - -- Fetch the next entry, if needed - - if not Search.Value.Entry_Fetched then - Fetch_Next_Entry (Search); - end if; - end if; - - return Search.Value.Is_Valid; - end More_Entries; - - ------------ - -- Rename -- - ------------ - - procedure Rename (Old_Name, New_Name : String) is - Success : Boolean; - - begin - -- First, the invalid cases - - if not Is_Valid_Path_Name (Old_Name) then - raise Name_Error with "invalid old path name """ & Old_Name & '"'; - - elsif not Is_Valid_Path_Name (New_Name) then - raise Name_Error with "invalid new path name """ & New_Name & '"'; - - elsif not Is_Regular_File (Old_Name) - and then not Is_Directory (Old_Name) - then - raise Name_Error with "old file """ & Old_Name & """ does not exist"; - - elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then - raise Use_Error with - "new name """ & New_Name - & """ designates a file that already exists"; - - -- Do actual rename using System.OS_Lib.Rename_File - - else - Rename_File (Old_Name, New_Name, Success); - - if not Success then - - -- AI05-0231-1: Name_Error should be raised in case a directory - -- component of New_Name does not exist (as in New_Name => - -- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT - -- also indicate that the Old_Name does not exist, but we already - -- checked for that above. All other errors are Use_Error. - - if Errno = ENOENT then - raise Name_Error with - "file """ & Containing_Directory (New_Name) & """ not found"; - - else - raise Use_Error with - "file """ & Old_Name & """ could not be renamed"; - end if; - end if; - end if; - end Rename; - - ------------ - -- Search -- - ------------ - - procedure Search - (Directory : String; - Pattern : String; - Filter : Filter_Type := (others => True); - Process : not null access procedure - (Directory_Entry : Directory_Entry_Type)) - is - Srch : Search_Type; - Directory_Entry : Directory_Entry_Type; - - begin - Start_Search (Srch, Directory, Pattern, Filter); - while More_Entries (Srch) loop - Get_Next_Entry (Srch, Directory_Entry); - Process (Directory_Entry); - end loop; - - End_Search (Srch); - end Search; - - ------------------- - -- Set_Directory -- - ------------------- - - procedure Set_Directory (Directory : String) is - C_Dir_Name : constant String := Directory & ASCII.NUL; - begin - if not Is_Valid_Path_Name (Directory) then - raise Name_Error with - "invalid directory path name & """ & Directory & '"'; - - elsif not Is_Directory (Directory) then - raise Name_Error with - "directory """ & Directory & """ does not exist"; - - elsif chdir (C_Dir_Name) /= 0 then - raise Name_Error with - "could not set to designated directory """ & Directory & '"'; - end if; - end Set_Directory; - - ----------------- - -- Simple_Name -- - ----------------- - - function Simple_Name (Name : String) return String is - - function Simple_Name_Internal (Path : String) return String; - -- This function does the job - - -------------------------- - -- Simple_Name_Internal -- - -------------------------- - - function Simple_Name_Internal (Path : String) return String is - Cut_Start : Natural := - Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward); - Cut_End : Natural; - - begin - -- Cut_Start pointS to the first simple name character - - Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); - - -- Cut_End point to the last simple name character - - Cut_End := Path'Last; - - Check_For_Standard_Dirs : declare - BN : constant String := Path (Cut_Start .. Cut_End); - - Has_Drive_Letter : constant Boolean := - OS_Lib.Path_Separator /= ':'; - -- If Path separator is not ':' then we are on a DOS based OS - -- where this character is used as a drive letter separator. - - begin - if BN = "." or else BN = ".." then - return ""; - - elsif Has_Drive_Letter - and then BN'Length > 2 - and then Characters.Handling.Is_Letter (BN (BN'First)) - and then BN (BN'First + 1) = ':' - then - -- We have a DOS drive letter prefix, remove it - - return BN (BN'First + 2 .. BN'Last); - - else - return BN; - end if; - end Check_For_Standard_Dirs; - end Simple_Name_Internal; - - -- Start of processing for Simple_Name - - begin - -- First, the invalid case - - if not Is_Valid_Path_Name (Name) then - raise Name_Error with "invalid path name """ & Name & '"'; - - else - -- Build the value to return with lower bound 1 - - declare - Value : constant String := Simple_Name_Internal (Name); - subtype Result is String (1 .. Value'Length); - begin - return Result (Value); - end; - end if; - end Simple_Name; - - function Simple_Name - (Directory_Entry : Directory_Entry_Type) return String is - begin - -- First, the invalid case - - if not Directory_Entry.Is_Valid then - raise Status_Error with "invalid directory entry"; - - else - -- The value to return has already be computed - - return To_String (Directory_Entry.Simple); - end if; - end Simple_Name; - - ---------- - -- Size -- - ---------- - - function Size (Name : String) return File_Size is - C_Name : String (1 .. Name'Length + 1); - - function C_Size (Name : Address) return int64; - pragma Import (C, C_Size, "__gnat_named_file_length"); - - begin - -- First, the invalid case - - if not Is_Regular_File (Name) then - raise Name_Error with "file """ & Name & """ does not exist"; - - else - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return File_Size (C_Size (C_Name'Address)); - end if; - end Size; - - function Size (Directory_Entry : Directory_Entry_Type) return File_Size is - begin - -- First, the invalid case - - if not Directory_Entry.Is_Valid then - raise Status_Error with "invalid directory entry"; - - else - -- The value to return has already be computed - - return Size (To_String (Directory_Entry.Full)); - end if; - end Size; - - ------------------ - -- Start_Search -- - ------------------ - - procedure Start_Search - (Search : in out Search_Type; - Directory : String; - Pattern : String; - Filter : Filter_Type := (others => True)) - is - function opendir (file_name : String) return DIRs; - pragma Import (C, opendir, "__gnat_opendir"); - - C_File_Name : constant String := Directory & ASCII.NUL; - Pat : Regexp; - Dir : Dir_Type_Value; - - begin - -- First, the invalid case Name_Error - - if not Is_Directory (Directory) then - raise Name_Error with - "unknown directory """ & Simple_Name (Directory) & '"'; - end if; - - -- Check the pattern - - begin - Pat := Compile - (Pattern, - Glob => True, - Case_Sensitive => Is_Path_Name_Case_Sensitive); - exception - when Error_In_Regexp => - Free (Search.Value); - raise Name_Error with "invalid pattern """ & Pattern & '"'; - end; - - Dir := Dir_Type_Value (opendir (C_File_Name)); - - if Dir = No_Dir then - raise Use_Error with - "unreadable directory """ & Simple_Name (Directory) & '"'; - end if; - - -- If needed, finalize Search - - Finalize (Search); - - -- Allocate the default data - - Search.Value := new Search_Data; - - -- Initialize some Search components - - Search.Value.Filter := Filter; - Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); - Search.Value.Pattern := Pat; - Search.Value.Dir := Dir; - Search.Value.Is_Valid := True; - end Start_Search; - -end Ada.Directories; diff --git a/gcc/ada/a-direct.ads b/gcc/ada/a-direct.ads deleted file mode 100644 index a308c00..0000000 --- a/gcc/ada/a-direct.ads +++ /dev/null @@ -1,487 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- --- -- --- This specification is derived for use with GNAT from AI-00248, which is -- --- expected to be a part of a future expected revised Ada Reference Manual. -- --- 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Ada 2005: Implementation of Ada.Directories (AI95-00248). Note that this --- unit is available without -gnat05. That seems reasonable, since you only --- get it if you explicitly ask for it. - --- External files may be classified as directories, special files, or ordinary --- files. A directory is an external file that is a container for files on --- the target system. A special file is an external file that cannot be --- created or read by a predefined Ada Input-Output package. External files --- that are not special files or directories are called ordinary files. - --- A file name is a string identifying an external file. Similarly, a --- directory name is a string identifying a directory. The interpretation of --- file names and directory names is implementation-defined. - --- The full name of an external file is a full specification of the name of --- the file. If the external environment allows alternative specifications of --- the name (for example, abbreviations), the full name should not use such --- alternatives. A full name typically will include the names of all of --- directories that contain the item. The simple name of an external file is --- the name of the item, not including any containing directory names. Unless --- otherwise specified, a file name or directory name parameter to a --- predefined Ada input-output subprogram can be a full name, a simple name, --- or any other form of name supported by the implementation. - --- The default directory is the directory that is used if a directory or --- file name is not a full name (that is, when the name does not fully --- identify all of the containing directories). - --- A directory entry is a single item in a directory, identifying a single --- external file (including directories and special files). - --- For each function that returns a string, the lower bound of the returned --- value is 1. - -with Ada.Calendar; -with Ada.Finalization; -with Ada.IO_Exceptions; -with Ada.Strings.Unbounded; - -package Ada.Directories is - - ----------------------------------- - -- Directory and File Operations -- - ----------------------------------- - - function Current_Directory return String; - -- Returns the full directory name for the current default directory. The - -- name returned must be suitable for a future call to Set_Directory. - -- The exception Use_Error is propagated if a default directory is not - -- supported by the external environment. - - procedure Set_Directory (Directory : String); - -- Sets the current default directory. The exception Name_Error is - -- propagated if the string given as Directory does not identify an - -- existing directory. The exception Use_Error is propagated if the - -- external environment does not support making Directory (in the absence - -- of Name_Error) a default directory. - - procedure Create_Directory - (New_Directory : String; - Form : String := ""); - -- Creates a directory with name New_Directory. The Form parameter can be - -- used to give system-dependent characteristics of the directory; the - -- interpretation of the Form parameter is implementation-defined. A null - -- string for Form specifies the use of the default options of the - -- implementation of the new directory. The exception Name_Error is - -- propagated if the string given as New_Directory does not allow the - -- identification of a directory. The exception Use_Error is propagated if - -- the external environment does not support the creation of a directory - -- with the given name (in the absence of Name_Error) and form. - -- - -- The Form parameter is ignored - - procedure Delete_Directory (Directory : String); - -- Deletes an existing empty directory with name Directory. The exception - -- Name_Error is propagated if the string given as Directory does not - -- identify an existing directory. The exception Use_Error is propagated - -- if the external environment does not support the deletion of the - -- directory (or some portion of its contents) with the given name (in the - -- absence of Name_Error). - - procedure Create_Path - (New_Directory : String; - Form : String := ""); - -- Creates zero or more directories with name New_Directory. Each - -- non-existent directory named by New_Directory is created. For example, - -- on a typical Unix system, Create_Path ("/usr/me/my"); would create - -- directory "me" in directory "usr", then create directory "my" - -- in directory "me". The Form can be used to give system-dependent - -- characteristics of the directory; the interpretation of the Form - -- parameter is implementation-defined. A null string for Form specifies - -- the use of the default options of the implementation of the new - -- directory. The exception Name_Error is propagated if the string given - -- as New_Directory does not allow the identification of any directory. The - -- exception Use_Error is propagated if the external environment does not - -- support the creation of any directories with the given name (in the - -- absence of Name_Error) and form. - -- - -- The Form parameter is ignored - - procedure Delete_Tree (Directory : String); - -- Deletes an existing directory with name Directory. The directory and - -- all of its contents (possibly including other directories) are deleted. - -- The exception Name_Error is propagated if the string given as Directory - -- does not identify an existing directory. The exception Use_Error is - -- propagated if the external environment does not support the deletion - -- of the directory or some portion of its contents with the given name - -- (in the absence of Name_Error). If Use_Error is propagated, it is - -- unspecified if a portion of the contents of the directory are deleted. - - procedure Delete_File (Name : String); - -- Deletes an existing ordinary or special file with Name. The exception - -- Name_Error is propagated if the string given as Name does not identify - -- an existing ordinary or special external file. The exception Use_Error - -- is propagated if the external environment does not support the deletion - -- of the file with the given name (in the absence of Name_Error). - - procedure Rename (Old_Name, New_Name : String); - -- Renames an existing external file (including directories) with Old_Name - -- to New_Name. The exception Name_Error is propagated if the string given - -- as Old_Name does not identify an existing external file. The exception - -- Use_Error is propagated if the external environment does not support the - -- renaming of the file with the given name (in the absence of Name_Error). - -- In particular, Use_Error is propagated if a file or directory already - -- exists with New_Name. - - procedure Copy_File - (Source_Name : String; - Target_Name : String; - Form : String := ""); - -- Copies the contents of the existing external file with Source_Name to - -- Target_Name. The resulting external file is a duplicate of the source - -- external file. The Form argument can be used to give system-dependent - -- characteristics of the resulting external file; the interpretation of - -- the Form parameter is implementation-defined. Exception Name_Error is - -- propagated if the string given as Source_Name does not identify an - -- existing external ordinary or special file or if the string given as - -- Target_Name does not allow the identification of an external file. The - -- exception Use_Error is propagated if the external environment does not - -- support the creating of the file with the name given by Target_Name and - -- form given by Form, or copying of the file with the name given by - -- Source_Name (in the absence of Name_Error). - -- - -- Interpretation of the Form parameter: - -- - -- The Form parameter is case-insensitive - -- - -- Two fields are recognized in the Form parameter: - -- preserve= - -- mode= - -- - -- starts immediately after the character '=' and ends with the - -- character immediately preceding the next comma (',') or with the - -- last character of the parameter. - -- - -- The allowed values for preserve= are: - -- - -- no_attributes: Do not try to preserve any file attributes. This - -- is the default if no preserve= is found in Form. - -- - -- all_attributes: Try to preserve all file attributes (timestamps, - -- access rights). - -- - -- timestamps: Preserve the timestamp of the copied file, but not - -- the other file attributes. - -- - -- The allowed values for mode= are: - -- - -- copy: Only copy if the destination file does not already - -- exist. If it already exists, Copy_File will fail. - -- - -- overwrite: Copy the file in all cases. Overwrite an already - -- existing destination file. This is the default if - -- no mode= is found in Form. - -- - -- append: Append the original file to the destination file. - -- If the destination file does not exist, the - -- destination file is a copy of the source file. - -- When mode=append, the field preserve=, if it - -- exists, is not taken into account. - -- - -- If the Form parameter includes one or both of the fields and the value - -- or values are incorrect, Copy_File fails with Use_Error. - -- - -- Examples of correct Forms: - -- Form => "preserve=no_attributes,mode=overwrite" (the default) - -- Form => "mode=append" - -- Form => "mode=copy,preserve=all_attributes" - -- - -- Examples of incorrect Forms: - -- Form => "preserve=junk" - -- Form => "mode=internal,preserve=timestamps" - - ---------------------------------------- - -- File and directory name operations -- - ---------------------------------------- - - function Full_Name (Name : String) return String; - -- Returns the full name corresponding to the file name specified by Name. - -- The exception Name_Error is propagated if the string given as Name does - -- not allow the identification of an external file (including directories - -- and special files). - - function Simple_Name (Name : String) return String; - -- Returns the simple name portion of the file name specified by Name. The - -- exception Name_Error is propagated if the string given as Name does not - -- allow the identification of an external file (including directories and - -- special files). - - function Containing_Directory (Name : String) return String; - -- Returns the name of the containing directory of the external file - -- (including directories) identified by Name. If more than one directory - -- can contain Name, the directory name returned is implementation-defined. - -- The exception Name_Error is propagated if the string given as Name does - -- not allow the identification of an external file. The exception - -- Use_Error is propagated if the external file does not have a containing - -- directory. - - function Extension (Name : String) return String; - -- Returns the extension name corresponding to Name. The extension name is - -- a portion of a simple name (not including any separator characters), - -- typically used to identify the file class. If the external environment - -- does not have extension names, then the null string is returned. - -- The exception Name_Error is propagated if the string given as Name does - -- not allow the identification of an external file. - - function Base_Name (Name : String) return String; - -- Returns the base name corresponding to Name. The base name is the - -- remainder of a simple name after removing any extension and extension - -- separators. The exception Name_Error is propagated if the string given - -- as Name does not allow the identification of an external file - -- (including directories and special files). - - function Compose - (Containing_Directory : String := ""; - Name : String; - Extension : String := "") return String; - -- Returns the name of the external file with the specified - -- Containing_Directory, Name, and Extension. If Extension is the null - -- string, then Name is interpreted as a simple name; otherwise Name is - -- interpreted as a base name. The exception Name_Error is propagated if - -- the string given as Containing_Directory is not null and does not allow - -- the identification of a directory, or if the string given as Extension - -- is not null and is not a possible extension, or if the string given as - -- Name is not a possible simple name (if Extension is null) or base name - -- (if Extension is non-null). - - -------------------------------- - -- File and directory queries -- - -------------------------------- - - type File_Kind is (Directory, Ordinary_File, Special_File); - -- The type File_Kind represents the kind of file represented by an - -- external file or directory. - - type File_Size is range 0 .. Long_Long_Integer'Last; - -- The type File_Size represents the size of an external file - - function Exists (Name : String) return Boolean; - -- Returns True if external file represented by Name exists, and False - -- otherwise. The exception Name_Error is propagated if the string given as - -- Name does not allow the identification of an external file (including - -- directories and special files). - - function Kind (Name : String) return File_Kind; - -- Returns the kind of external file represented by Name. The exception - -- Name_Error is propagated if the string given as Name does not allow the - -- identification of an existing external file. - - function Size (Name : String) return File_Size; - -- Returns the size of the external file represented by Name. The size of - -- an external file is the number of stream elements contained in the file. - -- If the external file is discontiguous (not all elements exist), the - -- result is implementation-defined. If the external file is not an - -- ordinary file, the result is implementation-defined. The exception - -- Name_Error is propagated if the string given as Name does not allow the - -- identification of an existing external file. The exception - -- Constraint_Error is propagated if the file size is not a value of type - -- File_Size. - - function Modification_Time (Name : String) return Ada.Calendar.Time; - -- Returns the time that the external file represented by Name was most - -- recently modified. If the external file is not an ordinary file, the - -- result is implementation-defined. The exception Name_Error is propagated - -- if the string given as Name does not allow the identification of an - -- existing external file. The exception Use_Error is propagated if the - -- external environment does not support the reading the modification time - -- of the file with the name given by Name (in the absence of Name_Error). - - ------------------------- - -- Directory Searching -- - ------------------------- - - type Directory_Entry_Type is limited private; - -- The type Directory_Entry_Type represents a single item in a directory. - -- These items can only be created by the Get_Next_Entry procedure in this - -- package. Information about the item can be obtained from the functions - -- declared in this package. A default initialized object of this type is - -- invalid; objects returned from Get_Next_Entry are valid. - - type Filter_Type is array (File_Kind) of Boolean; - -- The type Filter_Type specifies which directory entries are provided from - -- a search operation. If the Directory component is True, directory - -- entries representing directories are provided. If the Ordinary_File - -- component is True, directory entries representing ordinary files are - -- provided. If the Special_File component is True, directory entries - -- representing special files are provided. - - type Search_Type is limited private; - -- The type Search_Type contains the state of a directory search. A - -- default-initialized Search_Type object has no entries available - -- (More_Entries returns False). - - procedure Start_Search - (Search : in out Search_Type; - Directory : String; - Pattern : String; - Filter : Filter_Type := (others => True)); - -- Starts a search in the directory entry in the directory named by - -- Directory for entries matching Pattern. Pattern represents a file name - -- matching pattern. If Pattern is null, all items in the directory are - -- matched; otherwise, the interpretation of Pattern is implementation- - -- defined. Only items which match Filter will be returned. After a - -- successful call on Start_Search, the object Search may have entries - -- available, but it may have no entries available if no files or - -- directories match Pattern and Filter. The exception Name_Error is - -- propagated if the string given by Directory does not identify an - -- existing directory, or if Pattern does not allow the identification of - -- any possible external file or directory. The exception Use_Error is - -- propagated if the external environment does not support the searching - -- of the directory with the given name (in the absence of Name_Error). - - procedure End_Search (Search : in out Search_Type); - -- Ends the search represented by Search. After a successful call on - -- End_Search, the object Search will have no entries available. Note - -- that it is not necessary to call End_Search if the call to Start_Search - -- was unsuccessful and raised an exception (but it is harmless to make - -- the call in this case). - - function More_Entries (Search : Search_Type) return Boolean; - -- Returns True if more entries are available to be returned by a call - -- to Get_Next_Entry for the specified search object, and False otherwise. - - procedure Get_Next_Entry - (Search : in out Search_Type; - Directory_Entry : out Directory_Entry_Type); - -- Returns the next Directory_Entry for the search described by Search that - -- matches the pattern and filter. If no further matches are available, - -- Status_Error is raised. It is implementation-defined as to whether the - -- results returned by this routine are altered if the contents of the - -- directory are altered while the Search object is valid (for example, by - -- another program). The exception Use_Error is propagated if the external - -- environment does not support continued searching of the directory - -- represented by Search. - - procedure Search - (Directory : String; - Pattern : String; - Filter : Filter_Type := (others => True); - Process : not null access procedure - (Directory_Entry : Directory_Entry_Type)); - -- Searches in the directory named by Directory for entries matching - -- Pattern. The subprogram designated by Process is called with each - -- matching entry in turn. Pattern represents a pattern for matching file - -- names. If Pattern is null, all items in the directory are matched; - -- otherwise, the interpretation of Pattern is implementation-defined. - -- Only items that match Filter will be returned. The exception Name_Error - -- is propagated if the string given by Directory does not identify - -- an existing directory, or if Pattern does not allow the identification - -- of any possible external file or directory. The exception Use_Error is - -- propagated if the external environment does not support the searching - -- of the directory with the given name (in the absence of Name_Error). - - ------------------------------------- - -- Operations on Directory Entries -- - ------------------------------------- - - function Simple_Name (Directory_Entry : Directory_Entry_Type) return String; - -- Returns the simple external name of the external file (including - -- directories) represented by Directory_Entry. The format of the name - -- returned is implementation-defined. The exception Status_Error is - -- propagated if Directory_Entry is invalid. - - function Full_Name (Directory_Entry : Directory_Entry_Type) return String; - -- Returns the full external name of the external file (including - -- directories) represented by Directory_Entry. The format of the name - -- returned is implementation-defined. The exception Status_Error is - -- propagated if Directory_Entry is invalid. - - function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind; - -- Returns the kind of external file represented by Directory_Entry. The - -- exception Status_Error is propagated if Directory_Entry is invalid. - - function Size (Directory_Entry : Directory_Entry_Type) return File_Size; - -- Returns the size of the external file represented by Directory_Entry. - -- The size of an external file is the number of stream elements contained - -- in the file. If the external file is discontiguous (not all elements - -- exist), the result is implementation-defined. If the external file - -- represented by Directory_Entry is not an ordinary file, the result is - -- implementation-defined. The exception Status_Error is propagated if - -- Directory_Entry is invalid. The exception Constraint_Error is propagated - -- if the file size is not a value of type File_Size. - - function Modification_Time - (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time; - -- Returns the time that the external file represented by Directory_Entry - -- was most recently modified. If the external file represented by - -- Directory_Entry is not an ordinary file, the result is - -- implementation-defined. The exception Status_Error is propagated if - -- Directory_Entry is invalid. The exception Use_Error is propagated if - -- the external environment does not support the reading the modification - -- time of the file represented by Directory_Entry. - - ---------------- - -- Exceptions -- - ---------------- - - Status_Error : exception renames Ada.IO_Exceptions.Status_Error; - Name_Error : exception renames Ada.IO_Exceptions.Name_Error; - Use_Error : exception renames Ada.IO_Exceptions.Use_Error; - Device_Error : exception renames Ada.IO_Exceptions.Device_Error; - -private - type Directory_Entry_Type is record - Is_Valid : Boolean := False; - Simple : Ada.Strings.Unbounded.Unbounded_String; - Full : Ada.Strings.Unbounded.Unbounded_String; - Kind : File_Kind := Ordinary_File; - end record; - - -- The type Search_Data is defined in the body, so that the spec does not - -- depend on packages of the GNAT hierarchy. - - type Search_Data; - type Search_Ptr is access Search_Data; - - -- Search_Type need to be a controlled type, because it includes component - -- of type Dir_Type (in GNAT.Directory_Operations) that need to be closed - -- (if opened) during finalization. The component need to be an access - -- value, because Search_Data is not fully defined in the spec. - - type Search_Type is new Ada.Finalization.Controlled with record - Value : Search_Ptr; - end record; - - procedure Finalize (Search : in out Search_Type); - -- Close the directory, if opened, and deallocate Value - - procedure End_Search (Search : in out Search_Type) renames Finalize; - -end Ada.Directories; diff --git a/gcc/ada/a-direio.adb b/gcc/ada/a-direio.adb deleted file mode 100644 index f506314..0000000 --- a/gcc/ada/a-direio.adb +++ /dev/null @@ -1,289 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the generic template for Direct_IO, i.e. the code that gets --- duplicated. We absolutely minimize this code by either calling routines --- in System.File_IO (for common file functions), or in System.Direct_IO --- (for specialized Direct_IO functions) - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System; use System; -with System.CRTL; -with System.File_Control_Block; -with System.File_IO; -with System.Storage_Elements; -with Ada.Unchecked_Conversion; - -package body Ada.Direct_IO is - - Zeroes : constant System.Storage_Elements.Storage_Array := - (1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0); - -- Buffer used to fill out partial records - - package FCB renames System.File_Control_Block; - package FIO renames System.File_IO; - package DIO renames System.Direct_IO; - - SU : constant := System.Storage_Unit; - - subtype AP is FCB.AFCB_Ptr; - subtype FP is DIO.File_Type; - subtype DPCount is DIO.Positive_Count; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - function To_DIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); - - use type System.CRTL.size_t; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out File_Type) is - begin - FIO.Close (AP (File)'Unrestricted_Access); - end Close; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Inout_File; - Name : String := ""; - Form : String := "") - is - begin - DIO.Create (FP (File), To_FCB (Mode), Name, Form); - File.Bytes := Bytes; - end Create; - - ------------ - -- Delete -- - ------------ - - procedure Delete (File : in out File_Type) is - begin - FIO.Delete (AP (File)'Unrestricted_Access); - end Delete; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : File_Type) return Boolean is - begin - return DIO.End_Of_File (FP (File)); - end End_Of_File; - - ----------- - -- Flush -- - ----------- - - procedure Flush (File : File_Type) is - begin - FIO.Flush (AP (File)); - end Flush; - - ---------- - -- Form -- - ---------- - - function Form (File : File_Type) return String is - begin - return FIO.Form (AP (File)); - end Form; - - ----------- - -- Index -- - ----------- - - function Index (File : File_Type) return Positive_Count is - begin - return Positive_Count (DIO.Index (FP (File))); - end Index; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (File : File_Type) return Boolean is - begin - return FIO.Is_Open (AP (File)); - end Is_Open; - - ---------- - -- Mode -- - ---------- - - function Mode (File : File_Type) return File_Mode is - begin - return To_DIO (FIO.Mode (AP (File))); - end Mode; - - ---------- - -- Name -- - ---------- - - function Name (File : File_Type) return String is - begin - return FIO.Name (AP (File)); - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := "") - is - begin - DIO.Open (FP (File), To_FCB (Mode), Name, Form); - File.Bytes := Bytes; - end Open; - - ---------- - -- Read -- - ---------- - - procedure Read - (File : File_Type; - Item : out Element_Type; - From : Positive_Count) - is - begin - -- For a non-constrained variant record type, we read into an - -- intermediate buffer, since we may have the case of discriminated - -- records where a discriminant check is required, and we may need - -- to assign only part of the record buffer originally written. - - -- Note: we have to turn warnings on/off because this use of - -- the Constrained attribute is an obsolescent feature. - - pragma Warnings (Off); - if not Element_Type'Constrained then - pragma Warnings (On); - - declare - Buf : Element_Type; - - begin - DIO.Read (FP (File), Buf'Address, Bytes, DPCount (From)); - Item := Buf; - end; - - -- In the normal case, we can read straight into the buffer - - else - DIO.Read (FP (File), Item'Address, Bytes, DPCount (From)); - end if; - end Read; - - procedure Read (File : File_Type; Item : out Element_Type) is - begin - -- Same processing for unconstrained case as above - - -- Note: we have to turn warnings on/off because this use of - -- the Constrained attribute is an obsolescent feature. - - pragma Warnings (Off); - if not Element_Type'Constrained then - pragma Warnings (On); - - declare - Buf : Element_Type; - - begin - DIO.Read (FP (File), Buf'Address, Bytes); - Item := Buf; - end; - - else - DIO.Read (FP (File), Item'Address, Bytes); - end if; - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset (File : in out File_Type; Mode : File_Mode) is - begin - DIO.Reset (FP (File), To_FCB (Mode)); - end Reset; - - procedure Reset (File : in out File_Type) is - begin - DIO.Reset (FP (File)); - end Reset; - - --------------- - -- Set_Index -- - --------------- - - procedure Set_Index (File : File_Type; To : Positive_Count) is - begin - DIO.Set_Index (FP (File), DPCount (To)); - end Set_Index; - - ---------- - -- Size -- - ---------- - - function Size (File : File_Type) return Count is - begin - return Count (DIO.Size (FP (File))); - end Size; - - ----------- - -- Write -- - ----------- - - procedure Write - (File : File_Type; - Item : Element_Type; - To : Positive_Count) - is - begin - DIO.Set_Index (FP (File), DPCount (To)); - DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); - end Write; - - procedure Write (File : File_Type; Item : Element_Type) is - begin - DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); - end Write; - -end Ada.Direct_IO; diff --git a/gcc/ada/a-direio.ads b/gcc/ada/a-direio.ads deleted file mode 100644 index e53e9c1..0000000 --- a/gcc/ada/a-direio.ads +++ /dev/null @@ -1,193 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with System.Direct_IO; -with Interfaces.C_Streams; - -generic - type Element_Type is private; - -package Ada.Direct_IO is - - pragma Compile_Time_Warning - (Element_Type'Has_Access_Values, - "Element_Type for Direct_IO instance has access values"); - - pragma Compile_Time_Warning - (Element_Type'Has_Tagged_Values, - "Element_Type for Direct_IO instance has tagged values"); - - type File_Type is limited private; - - type File_Mode is (In_File, Inout_File, Out_File); - - -- The following representation clause allows the use of unchecked - -- conversion for rapid translation between the File_Mode type - -- used in this package and System.File_IO. - - for File_Mode use - (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) - Inout_File => 1, -- System.File_IO.File_Mode'Pos (Inout_File); - Out_File => 2); -- System.File_IO.File_Mode'Pos (Out_File) - - type Count is range 0 .. System.Direct_IO.Count'Last; - - subtype Positive_Count is Count range 1 .. Count'Last; - - --------------------- - -- File Management -- - --------------------- - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Inout_File; - Name : String := ""; - Form : String := ""); - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - procedure Reset (File : in out File_Type; Mode : File_Mode); - procedure Reset (File : in out File_Type); - - function Mode (File : File_Type) return File_Mode; - function Name (File : File_Type) return String; - function Form (File : File_Type) return String; - - function Is_Open (File : File_Type) return Boolean; - - procedure Flush (File : File_Type); - - --------------------------------- - -- Input and Output Operations -- - --------------------------------- - - procedure Read - (File : File_Type; - Item : out Element_Type; - From : Positive_Count); - - procedure Read - (File : File_Type; - Item : out Element_Type); - - procedure Write - (File : File_Type; - Item : Element_Type; - To : Positive_Count); - - procedure Write - (File : File_Type; - Item : Element_Type); - - procedure Set_Index (File : File_Type; To : Positive_Count); - - function Index (File : File_Type) return Positive_Count; - function Size (File : File_Type) return Count; - - function End_Of_File (File : File_Type) return Boolean; - - ---------------- - -- Exceptions -- - ---------------- - - Status_Error : exception renames IO_Exceptions.Status_Error; - Mode_Error : exception renames IO_Exceptions.Mode_Error; - Name_Error : exception renames IO_Exceptions.Name_Error; - Use_Error : exception renames IO_Exceptions.Use_Error; - Device_Error : exception renames IO_Exceptions.Device_Error; - End_Error : exception renames IO_Exceptions.End_Error; - Data_Error : exception renames IO_Exceptions.Data_Error; - -private - - -- The following procedures have a File_Type formal of mode IN OUT because - -- they may close the original file. The Close operation may raise an - -- exception, but in that case we want any assignment to the formal to - -- be effective anyway, so it must be passed by reference (or the caller - -- will be left with a dangling pointer). - - pragma Export_Procedure - (Internal => Close, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Delete, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type), - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type, File_Mode), - Mechanism => (File => Reference)); - - type File_Type is new System.Direct_IO.File_Type; - - Bytes : constant Interfaces.C_Streams.size_t := - Interfaces.C_Streams.size_t'Max - (1, Element_Type'Max_Size_In_Storage_Elements); - -- Size of an element in storage units. The Max operation here is to ensure - -- that we allocate a single byte for zero-sized elements. It's a bit weird - -- to instantiate Direct_IO with zero sized elements, but it is legal and - -- this adjustment ensures that we don't get anomalous behavior. - - pragma Inline (Close); - pragma Inline (Create); - pragma Inline (Delete); - pragma Inline (End_Of_File); - pragma Inline (Form); - pragma Inline (Index); - pragma Inline (Is_Open); - pragma Inline (Mode); - pragma Inline (Name); - pragma Inline (Open); - pragma Inline (Read); - pragma Inline (Reset); - pragma Inline (Set_Index); - pragma Inline (Size); - pragma Inline (Write); - -end Ada.Direct_IO; diff --git a/gcc/ada/a-dirval-mingw.adb b/gcc/ada/a-dirval-mingw.adb deleted file mode 100644 index b0a9cc3..0000000 --- a/gcc/ada/a-dirval-mingw.adb +++ /dev/null @@ -1,175 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- B o d y -- --- (Windows Version) -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Windows version of this package - -with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; - -package body Ada.Directories.Validity is - - Invalid_Character : constant array (Character) of Boolean := - (NUL .. US | '\' => True, - '/' | ':' | '*' | '?' => True, - '"' | '<' | '>' | '|' => True, - DEL => True, - others => False); - -- Note that a valid file-name or path-name is implementation defined. - -- To support UTF-8 file and directory names, we do not want to be too - -- restrictive here. - - --------------------------------- - -- Is_Path_Name_Case_Sensitive -- - --------------------------------- - - function Is_Path_Name_Case_Sensitive return Boolean is - begin - return False; - end Is_Path_Name_Case_Sensitive; - - ------------------------ - -- Is_Valid_Path_Name -- - ------------------------ - - function Is_Valid_Path_Name (Name : String) return Boolean is - Start : Positive := Name'First; - Last : Natural; - - begin - -- A path name cannot be empty, cannot contain more than 256 characters, - -- cannot contain invalid characters and each directory/file name need - -- to be valid. - - if Name'Length = 0 or else Name'Length > 256 then - return False; - - else - -- A drive letter may be specified at the beginning - - if Name'Length >= 2 - and then Name (Start + 1) = ':' - and then - (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z') - then - Start := Start + 2; - - -- A drive letter followed by a colon and followed by nothing or - -- by a relative path is an ambiguous path name on Windows, so we - -- don't accept it. - - if Start > Name'Last - or else (Name (Start) /= '/' and then Name (Start) /= '\') - then - return False; - end if; - end if; - - loop - -- Look for the start of the next directory or file name - - while Start <= Name'Last - and then (Name (Start) = '\' or Name (Start) = '/') - loop - Start := Start + 1; - end loop; - - -- If all directories/file names are OK, return True - - exit when Start > Name'Last; - - Last := Start; - - -- Look for the end of the directory/file name - - while Last < Name'Last loop - exit when Name (Last + 1) = '\' or Name (Last + 1) = '/'; - Last := Last + 1; - end loop; - - -- Check if the directory/file name is valid - - if not Is_Valid_Simple_Name (Name (Start .. Last)) then - return False; - end if; - - -- Move to the next name - - Start := Last + 1; - end loop; - end if; - - -- If Name follows the rules, it is valid - - return True; - end Is_Valid_Path_Name; - - -------------------------- - -- Is_Valid_Simple_Name -- - -------------------------- - - function Is_Valid_Simple_Name (Name : String) return Boolean is - Only_Spaces : Boolean; - - begin - -- A file name cannot be empty, cannot contain more than 256 characters, - -- and cannot contain invalid characters. - - if Name'Length = 0 or else Name'Length > 256 then - return False; - - -- Name length is OK - - else - Only_Spaces := True; - for J in Name'Range loop - if Invalid_Character (Name (J)) then - return False; - elsif Name (J) /= ' ' then - Only_Spaces := False; - end if; - end loop; - - -- If no invalid chars, and not all spaces, file name is valid - - return not Only_Spaces; - end if; - end Is_Valid_Simple_Name; - - ------------- - -- Windows -- - ------------- - - function Windows return Boolean is - begin - return True; - end Windows; - -end Ada.Directories.Validity; diff --git a/gcc/ada/a-dirval.adb b/gcc/ada/a-dirval.adb deleted file mode 100644 index 7a08500..0000000 --- a/gcc/ada/a-dirval.adb +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- B o d y -- --- (POSIX Version) -- --- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the POSIX version of this package - -package body Ada.Directories.Validity is - - --------------------------------- - -- Is_Path_Name_Case_Sensitive -- - --------------------------------- - - function Is_Path_Name_Case_Sensitive return Boolean is - begin - return True; - end Is_Path_Name_Case_Sensitive; - - ------------------------ - -- Is_Valid_Path_Name -- - ------------------------ - - function Is_Valid_Path_Name (Name : String) return Boolean is - begin - -- A path name cannot be empty and cannot contain any NUL character - - if Name'Length = 0 then - return False; - - else - for J in Name'Range loop - if Name (J) = ASCII.NUL then - return False; - end if; - end loop; - end if; - - -- If Name does not contain any NUL character, it is valid - - return True; - end Is_Valid_Path_Name; - - -------------------------- - -- Is_Valid_Simple_Name -- - -------------------------- - - function Is_Valid_Simple_Name (Name : String) return Boolean is - begin - -- A file name cannot be empty and cannot contain a slash ('/') or - -- the NUL character. - - if Name'Length = 0 then - return False; - - else - for J in Name'Range loop - if Name (J) = '/' or else Name (J) = ASCII.NUL then - return False; - end if; - end loop; - end if; - - -- If Name does not contain any slash or NUL, it is valid - - return True; - end Is_Valid_Simple_Name; - - ------------- - -- Windows -- - ------------- - - function Windows return Boolean is - begin - return False; - end Windows; - -end Ada.Directories.Validity; diff --git a/gcc/ada/a-dirval.ads b/gcc/ada/a-dirval.ads deleted file mode 100644 index 9505dff..0000000 --- a/gcc/ada/a-dirval.ads +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . D I R E C T O R I E S . V A L I D I T Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This private child package is used in the body of Ada.Directories. --- It has several bodies, for different platforms. - -private package Ada.Directories.Validity is - - function Is_Valid_Simple_Name (Name : String) return Boolean; - -- Returns True if Name is a valid file name - - function Is_Valid_Path_Name (Name : String) return Boolean; - -- Returns True if Name is a valid path name - - function Is_Path_Name_Case_Sensitive return Boolean; - -- Returns True if file and path names are case-sensitive - - function Windows return Boolean; - -- Return True when OS is Windows - -end Ada.Directories.Validity; diff --git a/gcc/ada/a-einuoc.adb b/gcc/ada/a-einuoc.adb deleted file mode 100644 index f70eff0..0000000 --- a/gcc/ada/a-einuoc.adb +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - ---------------------------------------- --- Ada.Exceptions.Is_Null_Occurrence -- ---------------------------------------- - -function Ada.Exceptions.Is_Null_Occurrence - (X : Exception_Occurrence) return Boolean -is -begin - -- The null exception is uniquely identified by the fact that the Id value - -- is null. No other exception occurrence can have a null Id. - - if X.Id = Null_Id then - return True; - else - return False; - end if; -end Ada.Exceptions.Is_Null_Occurrence; diff --git a/gcc/ada/a-einuoc.ads b/gcc/ada/a-einuoc.ads deleted file mode 100644 index 8d772b0..0000000 --- a/gcc/ada/a-einuoc.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a GNAT-specific child function of Ada.Exceptions. It provides --- clearly missing functionality for its parent package, and most reasonably --- would simply be an added function to that package, but this change cannot --- be made in a conforming manner. - -function Ada.Exceptions.Is_Null_Occurrence - (X : Exception_Occurrence) return Boolean; -pragma Preelaborate (Ada.Exceptions.Is_Null_Occurrence); --- This function yields True if X is Null_Occurrence, and False otherwise diff --git a/gcc/ada/a-elchha.adb b/gcc/ada/a-elchha.adb deleted file mode 100644 index 6ef2e03..0000000 --- a/gcc/ada/a-elchha.adb +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Default version for most targets - -pragma Compiler_Unit_Warning; - -with System.Standard_Library; use System.Standard_Library; -with System.Soft_Links; - -procedure Ada.Exceptions.Last_Chance_Handler - (Except : Exception_Occurrence) -is - procedure Unhandled_Terminate; - pragma No_Return (Unhandled_Terminate); - pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); - -- Perform system dependent shutdown code - - function Exception_Message_Length - (X : Exception_Occurrence) return Natural; - pragma Import (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); - - procedure Append_Info_Exception_Message - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - pragma Import - (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); - - procedure Append_Info_Untailored_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - pragma Import - (Ada, Append_Info_Untailored_Exception_Information, - "__gnat_append_info_u_e_info"); - - procedure To_Stderr (S : String); - pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); - -- Little routine to output string to stderr - - Ptr : Natural := 0; - Nobuf : String (1 .. 0); - - Nline : constant String := String'(1 => ASCII.LF); - -- Convenient shortcut - -begin - -- Do not execute any task termination code when shutting down the system. - -- The Adafinal procedure would execute the task termination routine for - -- normal termination, but we have already executed the task termination - -- procedure because of an unhandled exception. - - System.Soft_Links.Task_Termination_Handler := - System.Soft_Links.Task_Termination_NT'Access; - - -- We shutdown the runtime now. The rest of the procedure needs to be - -- careful not to use anything that would require runtime support. In - -- particular, functions returning strings are banned since the sec stack - -- is no longer functional. This is particularly important to note for the - -- Exception_Information output. We used to allow the tailored version to - -- show up here, which turned out to be a bad idea as it might involve a - -- traceback decorator the length of which we don't control. Potentially - -- heavy primary/secondary stack use or dynamic allocations right before - -- this point are not welcome, moving the output before the finalization - -- raises order of outputs concerns, and decorators are intended to only - -- be used with exception traces, which should have been issued already. - - System.Standard_Library.Adafinal; - - -- Print a message only when exception traces are not active - - if Exception_Trace /= RM_Convention then - null; - - -- Check for special case of raising _ABORT_SIGNAL, which is not - -- really an exception at all. We recognize this by the fact that - -- it is the only exception whose name starts with underscore. - - elsif To_Ptr (Except.Id.Full_Name) (1) = '_' then - To_Stderr (Nline); - To_Stderr ("Execution terminated by abort of environment task"); - To_Stderr (Nline); - - -- If no tracebacks, we print the unhandled exception in the old style - -- (i.e. the style used before ZCX was implemented). We do this to - -- retain compatibility. - - elsif Except.Num_Tracebacks = 0 then - To_Stderr (Nline); - To_Stderr ("raised "); - To_Stderr - (To_Ptr (Except.Id.Full_Name) (1 .. Except.Id.Name_Length - 1)); - - if Exception_Message_Length (Except) /= 0 then - To_Stderr (" : "); - Append_Info_Exception_Message (Except, Nobuf, Ptr); - end if; - - To_Stderr (Nline); - - -- Traceback exists - - else - To_Stderr (Nline); - To_Stderr ("Execution terminated by unhandled exception"); - To_Stderr (Nline); - - Append_Info_Untailored_Exception_Information (Except, Nobuf, Ptr); - end if; - - Unhandled_Terminate; -end Ada.Exceptions.Last_Chance_Handler; diff --git a/gcc/ada/a-elchha.ads b/gcc/ada/a-elchha.ads deleted file mode 100644 index 1e36373..0000000 --- a/gcc/ada/a-elchha.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Last chance handler. Unhandled exceptions are passed to this routine - -pragma Compiler_Unit_Warning; - -procedure Ada.Exceptions.Last_Chance_Handler - (Except : Exception_Occurrence); -pragma Export (C, - Last_Chance_Handler, - "__gnat_last_chance_handler"); -pragma No_Return (Last_Chance_Handler); diff --git a/gcc/ada/a-envvar.adb b/gcc/ada/a-envvar.adb deleted file mode 100644 index 85368f8..0000000 --- a/gcc/ada/a-envvar.adb +++ /dev/null @@ -1,228 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E N V I R O N M E N T _ V A R I A B L E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.CRTL; -with Interfaces.C.Strings; -with Ada.Unchecked_Deallocation; - -package body Ada.Environment_Variables is - - ----------- - -- Clear -- - ----------- - - procedure Clear (Name : String) is - procedure Clear_Env_Var (Name : System.Address); - pragma Import (C, Clear_Env_Var, "__gnat_unsetenv"); - - F_Name : String (1 .. Name'Length + 1); - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - - Clear_Env_Var (F_Name'Address); - end Clear; - - ----------- - -- Clear -- - ----------- - - procedure Clear is - procedure Clear_Env; - pragma Import (C, Clear_Env, "__gnat_clearenv"); - begin - Clear_Env; - end Clear; - - ------------ - -- Exists -- - ------------ - - function Exists (Name : String) return Boolean is - use System; - - procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); - pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); - - Env_Value_Ptr : aliased Address; - Env_Value_Length : aliased Integer; - F_Name : aliased String (1 .. Name'Length + 1); - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - - Get_Env_Value_Ptr - (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); - - if Env_Value_Ptr = System.Null_Address then - return False; - end if; - - return True; - end Exists; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate - (Process : not null access procedure (Name, Value : String)) - is - use Interfaces.C.Strings; - type C_String_Array is array (Natural) of aliased chars_ptr; - type C_String_Array_Access is access C_String_Array; - - function Get_Env return C_String_Array_Access; - pragma Import (C, Get_Env, "__gnat_environ"); - - type String_Access is access all String; - procedure Free is new Ada.Unchecked_Deallocation (String, String_Access); - - Env_Length : Natural := 0; - Env : constant C_String_Array_Access := Get_Env; - - begin - -- If the environment is null return directly - - if Env = null then - return; - end if; - - -- First get the number of environment variables - - loop - exit when Env (Env_Length) = Null_Ptr; - Env_Length := Env_Length + 1; - end loop; - - declare - Env_Copy : array (1 .. Env_Length) of String_Access; - - begin - -- Copy the environment - - for Iterator in 1 .. Env_Length loop - Env_Copy (Iterator) := new String'(Value (Env (Iterator - 1))); - end loop; - - -- Iterate on the environment copy - - for Iterator in 1 .. Env_Length loop - declare - Current_Var : constant String := Env_Copy (Iterator).all; - Value_Index : Natural := Env_Copy (Iterator)'First; - - begin - loop - exit when Current_Var (Value_Index) = '='; - Value_Index := Value_Index + 1; - end loop; - - Process - (Current_Var (Current_Var'First .. Value_Index - 1), - Current_Var (Value_Index + 1 .. Current_Var'Last)); - end; - end loop; - - -- Free the copy of the environment - - for Iterator in 1 .. Env_Length loop - Free (Env_Copy (Iterator)); - end loop; - end; - end Iterate; - - --------- - -- Set -- - --------- - - procedure Set (Name : String; Value : String) is - F_Name : String (1 .. Name'Length + 1); - F_Value : String (1 .. Value'Length + 1); - - procedure Set_Env_Value (Name, Value : System.Address); - pragma Import (C, Set_Env_Value, "__gnat_setenv"); - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - - F_Value (1 .. Value'Length) := Value; - F_Value (F_Value'Last) := ASCII.NUL; - - Set_Env_Value (F_Name'Address, F_Value'Address); - end Set; - - ----------- - -- Value -- - ----------- - - function Value (Name : String) return String is - use System, System.CRTL; - - procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); - pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); - - Env_Value_Ptr : aliased Address; - Env_Value_Length : aliased Integer; - F_Name : aliased String (1 .. Name'Length + 1); - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - - Get_Env_Value_Ptr - (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); - - if Env_Value_Ptr = System.Null_Address then - raise Constraint_Error; - end if; - - if Env_Value_Length > 0 then - declare - Result : aliased String (1 .. Env_Value_Length); - begin - strncpy (Result'Address, Env_Value_Ptr, size_t (Env_Value_Length)); - return Result; - end; - else - return ""; - end if; - end Value; - - function Value (Name : String; Default : String) return String is - begin - return (if Exists (Name) then Value (Name) else Default); - end Value; - -end Ada.Environment_Variables; diff --git a/gcc/ada/a-envvar.ads b/gcc/ada/a-envvar.ads deleted file mode 100644 index 406aee3..0000000 --- a/gcc/ada/a-envvar.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E N V I R O N M E N T _ V A R I A B L E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- The implementation of this package is as defined in the Ada 2012 RM, but --- it is available in Ada 95 and Ada 2005 modes as well. - -package Ada.Environment_Variables is - pragma Preelaborate (Environment_Variables); - - function Value (Name : String) return String; - -- If the external execution environment supports environment variables, - -- then Value returns the value of the environment variable with the given - -- name. If no environment variable with the given name exists, then - -- Constraint_Error is propagated. If the execution environment does not - -- support environment variables, then Program_Error is propagated. - - function Value (Name : String; Default : String) return String; - -- If the external execution environment supports environment variables and - -- an environment variable with the given name currently exists, then Value - -- returns its value; otherwise, it returns Default. - - function Exists (Name : String) return Boolean; - -- If the external execution environment supports environment variables and - -- an environment variable with the given name currently exists, then - -- Exists returns True; otherwise it returns False. - - procedure Set (Name : String; Value : String); - -- If the external execution environment supports environment variables, - -- then Set first clears any existing environment variable with the given - -- name, and then defines a single new environment variable with the given - -- name and value. Otherwise Program_Error is propagated. - -- - -- If implementation-defined circumstances prohibit the definition of an - -- environment variable with the given name and value, then exception - -- Constraint_Error is propagated. - -- - -- It is implementation defined whether there exist values for which the - -- call Set (Name, Value) has the same effect as Clear (Name). - - procedure Clear (Name : String); - -- If the external execution environment supports environment variables, - -- then Clear deletes all existing environment variables with the given - -- name. Otherwise Program_Error is propagated. - - procedure Clear; - -- If the external execution environment supports environment variables, - -- then Clear deletes all existing environment variables. Otherwise - -- Program_Error is propagated. - - procedure Iterate - (Process : not null access procedure (Name, Value : String)); - -- If the external execution environment supports environment variables, - -- then Iterate calls the subprogram designated by Process for each - -- existing environment variable, passing the name and value of that - -- environment variable. Otherwise Program_Error is propagated. - -end Ada.Environment_Variables; diff --git a/gcc/ada/a-excach.adb b/gcc/ada/a-excach.adb deleted file mode 100644 index b1cc22b..0000000 --- a/gcc/ada/a-excach.adb +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . C A L L _ C H A I N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Warnings (Off); --- Allow withing of non-Preelaborated units in Ada 2005 mode where this --- package will be categorized as Preelaborate. See AI-362 for details. --- It is safe in the context of the run-time to violate the rules. - -with System.Traceback; - -pragma Warnings (On); - -separate (Ada.Exceptions) -procedure Call_Chain (Excep : EOA) is - - Exception_Tracebacks : Integer; - pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks"); - -- Boolean indicating whether tracebacks should be stored in exception - -- occurrences. - -begin - if Exception_Tracebacks /= 0 and Excep.Num_Tracebacks = 0 then - - -- If Exception_Tracebacks = 0 then the program was not - -- compiled for storing tracebacks in exception occurrences - -- (-bargs -E switch) so that we do not generate them. - -- - -- If Excep.Num_Tracebacks /= 0 then this is a reraise, no need - -- to store a new (wrong) chain. - - -- We ask System.Traceback.Call_Chain to skip 3 frames to ensure that - -- itself, ourselves and our caller are not part of the result. Our - -- caller is always an exception propagation actor that we don't want - -- to see, and it may be part of a separate subunit which pulls it - -- outside the AAA/ZZZ range. - - System.Traceback.Call_Chain - (Traceback => Excep.Tracebacks, - Max_Len => Max_Tracebacks, - Len => Excep.Num_Tracebacks, - Exclude_Min => Code_Address_For_AAA, - Exclude_Max => Code_Address_For_ZZZ, - Skip_Frames => 3); - end if; - -end Call_Chain; diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb deleted file mode 100644 index 1b8e625..0000000 --- a/gcc/ada/a-except.adb +++ /dev/null @@ -1,1748 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . E X C E P T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- No subprogram ordering check, due to logical grouping - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with System.Exception_Tables. - -with System; use System; -with System.Exceptions; use System.Exceptions; -with System.Exceptions_Debug; use System.Exceptions_Debug; -with System.Standard_Library; use System.Standard_Library; -with System.Soft_Links; use System.Soft_Links; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_StW; use System.WCh_StW; - -pragma Warnings (Off); --- Suppress complaints about Symbolic not being referenced, and about it not --- having pragma Preelaborate. -with System.Traceback.Symbolic; --- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version, --- it will install symbolic tracebacks as the default decorator. Otherwise, --- symbolic tracebacks are not supported, and we fall back to hexadecimal --- addresses. -pragma Warnings (On); - -package body Ada.Exceptions is - - pragma Suppress (All_Checks); - -- We definitely do not want exceptions occurring within this unit, or - -- we are in big trouble. If an exceptional situation does occur, better - -- that it not be raised, since raising it can cause confusing chaos. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- Note: the exported subprograms in this package body are called directly - -- from C clients using the given external name, even though they are not - -- technically visible in the Ada sense. - - function Code_Address_For_AAA return System.Address; - function Code_Address_For_ZZZ return System.Address; - -- Return start and end of procedures in this package - -- - -- These procedures are used to provide exclusion bounds in - -- calls to Call_Chain at exception raise points from this unit. The - -- purpose is to arrange for the exception tracebacks not to include - -- frames from subprograms involved in the raise process, as these are - -- meaningless from the user's standpoint. - -- - -- For these bounds to be meaningful, we need to ensure that the object - -- code for the subprograms involved in processing a raise is located - -- after the object code Code_Address_For_AAA and before the object - -- code Code_Address_For_ZZZ. This will indeed be the case as long as - -- the following rules are respected: - -- - -- 1) The bodies of the subprograms involved in processing a raise - -- are located after the body of Code_Address_For_AAA and before the - -- body of Code_Address_For_ZZZ. - -- - -- 2) No pragma Inline applies to any of these subprograms, as this - -- could delay the corresponding assembly output until the end of - -- the unit. - - procedure Call_Chain (Excep : EOA); - -- Store up to Max_Tracebacks in Excep, corresponding to the current - -- call chain. - - function Image (Index : Integer) return String; - -- Return string image corresponding to Index - - procedure To_Stderr (S : String); - pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); - -- Little routine to output string to stderr that is also used - -- in the tasking run time. - - procedure To_Stderr (C : Character); - pragma Inline (To_Stderr); - pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char"); - -- Little routine to output a character to stderr, used by some of - -- the separate units below. - - package Exception_Data is - - ----------------------------------- - -- Exception Message Subprograms -- - ----------------------------------- - - procedure Set_Exception_C_Msg - (Excep : EOA; - Id : Exception_Id; - Msg1 : System.Address; - Line : Integer := 0; - Column : Integer := 0; - Msg2 : System.Address := System.Null_Address); - -- This routine is called to setup the exception referenced by X - -- to contain the indicated Id value and message. Msg1 is a null - -- terminated string which is generated as the exception message. If - -- line is non-zero, then a colon and the decimal representation of - -- this integer is appended to the message. Ditto for Column. When Msg2 - -- is non-null, a space and this additional null terminated string is - -- added to the message. - - procedure Set_Exception_Msg - (Excep : EOA; - Id : Exception_Id; - Message : String); - -- This routine is called to setup the exception referenced by X - -- to contain the indicated Id value and message. Message is a string - -- which is generated as the exception message. - - --------------------------------------- - -- Exception Information Subprograms -- - --------------------------------------- - - function Untailored_Exception_Information - (X : Exception_Occurrence) return String; - -- This is used by Stream_Attributes.EO_To_String to convert an - -- Exception_Occurrence to a String for the stream attributes. - -- String_To_EO understands the format, as documented here. - -- - -- The format of the string is as follows: - -- - -- raised : - -- (" : " is present only if Exception_Message is not empty) - -- PID=nnnn (only if nonzero) - -- Call stack traceback locations: (only if at least one location) - -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) - -- - -- The lines are separated by a ASCII.LF character. - -- The nnnn is the partition Id given as decimal digits. - -- The 0x... line represents traceback program counter locations, in - -- execution order with the first one being the exception location. - -- - -- The Exception_Name and Message lines are omitted in the abort - -- signal case, since this is not really an exception. - -- - -- Note: If the format of the generated string is changed, please note - -- that an equivalent modification to the routine String_To_EO must be - -- made to preserve proper functioning of the stream attributes. - - function Exception_Information (X : Exception_Occurrence) return String; - -- This is the implementation of Ada.Exceptions.Exception_Information, - -- as defined in the Ada RM. - -- - -- If no traceback decorator (see GNAT.Exception_Traces) is currently - -- in place, this is the same as Untailored_Exception_Information. - -- Otherwise, the decorator is used to produce a symbolic traceback - -- instead of hexadecimal addresses. - -- - -- Note that unlike Untailored_Exception_Information, there is no need - -- to keep the output of Exception_Information stable for streaming - -- purposes, and in fact the output differs across platforms. - - end Exception_Data; - - package Exception_Traces is - - ------------------------------------------------- - -- Run-Time Exception Notification Subprograms -- - ------------------------------------------------- - - -- These subprograms provide a common run-time interface to trigger the - -- actions required when an exception is about to be propagated (e.g. - -- user specified actions or output of exception information). They are - -- exported to be usable by the Ada exception handling personality - -- routine when the GCC 3 mechanism is used. - - procedure Notify_Handled_Exception (Excep : EOA); - pragma Export - (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); - -- This routine is called for a handled occurrence is about to be - -- propagated. - - procedure Notify_Unhandled_Exception (Excep : EOA); - pragma Export - (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); - -- This routine is called when an unhandled occurrence is about to be - -- propagated. - - procedure Unhandled_Exception_Terminate (Excep : EOA); - pragma No_Return (Unhandled_Exception_Terminate); - -- This procedure is called to terminate execution following an - -- unhandled exception. The exception information, including - -- traceback if available is output, and execution is then - -- terminated. Note that at the point where this routine is - -- called, the stack has typically been destroyed. - - end Exception_Traces; - - package Exception_Propagation is - - --------------------------------------- - -- Exception Propagation Subprograms -- - --------------------------------------- - - function Allocate_Occurrence return EOA; - -- Allocate an exception occurrence (as well as the machine occurrence) - - procedure Propagate_Exception (Excep : EOA); - pragma No_Return (Propagate_Exception); - -- This procedure propagates the exception represented by Excep - - end Exception_Propagation; - - package Stream_Attributes is - - ---------------------------------- - -- Stream Attribute Subprograms -- - ---------------------------------- - - function EId_To_String (X : Exception_Id) return String; - function String_To_EId (S : String) return Exception_Id; - -- Functions for implementing Exception_Id stream attributes - - function EO_To_String (X : Exception_Occurrence) return String; - function String_To_EO (S : String) return Exception_Occurrence; - -- Functions for implementing Exception_Occurrence stream - -- attributes - - end Stream_Attributes; - - procedure Complete_Occurrence (X : EOA); - -- Finish building the occurrence: save the call chain and notify the - -- debugger. - - procedure Complete_And_Propagate_Occurrence (X : EOA); - pragma No_Return (Complete_And_Propagate_Occurrence); - -- This is a simple wrapper to Complete_Occurrence and - -- Exception_Propagation.Propagate_Exception. - - function Create_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return EOA; - -- Create and build an exception occurrence using exception id E and - -- nul-terminated message M. - - function Create_Machine_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return System.Address; - pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler, - "__gnat_create_machine_occurrence_from_signal_handler"); - -- Create and build an exception occurrence using exception id E and - -- nul-terminated message M. Return the machine occurrence. - - procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := ""); - pragma Export - (Ada, Raise_Exception_No_Defer, - "ada__exceptions__raise_exception_no_defer"); - pragma No_Return (Raise_Exception_No_Defer); - -- Similar to Raise_Exception, but with no abort deferral - - procedure Raise_With_Msg (E : Exception_Id); - pragma No_Return (Raise_With_Msg); - pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); - -- Raises an exception with given exception id value. A message - -- is associated with the raise, and has already been stored in the - -- exception occurrence referenced by the Current_Excep in the TSD. - -- Abort is deferred before the raise call. - - procedure Raise_With_Location_And_Msg - (E : Exception_Id; - F : System.Address; - L : Integer; - C : Integer := 0; - M : System.Address := System.Null_Address); - pragma No_Return (Raise_With_Location_And_Msg); - -- Raise an exception with given exception id value. A filename and line - -- number is associated with the raise and is stored in the exception - -- occurrence and in addition a column and a string message M may be - -- appended to this (if not null/0). - - procedure Raise_Constraint_Error (File : System.Address; Line : Integer); - pragma No_Return (Raise_Constraint_Error); - pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); - -- Raise constraint error with file:line information - - procedure Raise_Constraint_Error_Msg - (File : System.Address; - Line : Integer; - Column : Integer; - Msg : System.Address); - pragma No_Return (Raise_Constraint_Error_Msg); - pragma Export - (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); - -- Raise constraint error with file:line:col + msg information - - procedure Raise_Program_Error (File : System.Address; Line : Integer); - pragma No_Return (Raise_Program_Error); - pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error"); - -- Raise program error with file:line information - - procedure Raise_Program_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address); - pragma No_Return (Raise_Program_Error_Msg); - pragma Export - (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); - -- Raise program error with file:line + msg information - - procedure Raise_Storage_Error (File : System.Address; Line : Integer); - pragma No_Return (Raise_Storage_Error); - pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error"); - -- Raise storage error with file:line information - - procedure Raise_Storage_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address); - pragma No_Return (Raise_Storage_Error_Msg); - pragma Export - (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); - -- Raise storage error with file:line + reason msg information - - -- The exception raising process and the automatic tracing mechanism rely - -- on some careful use of flags attached to the exception occurrence. The - -- graph below illustrates the relations between the Raise_ subprograms - -- and identifies the points where basic flags such as Exception_Raised - -- are initialized. - - -- (i) signs indicate the flags initialization points. R stands for Raise, - -- W for With, and E for Exception. - - -- R_No_Msg R_E R_Pe R_Ce R_Se - -- | | | | | - -- +--+ +--+ +---+ | +---+ - -- | | | | | - -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc - -- | | | | - -- +------------+ | +-----------+ +--+ - -- | | | | - -- | | | Set_E_C_Msg(i) - -- | | | - -- Complete_And_Propagate_Occurrence - - procedure Reraise; - pragma No_Return (Reraise); - pragma Export (C, Reraise, "__gnat_reraise"); - -- Reraises the exception referenced by the Current_Excep field - -- of the TSD (all fields of this exception occurrence are set). - -- Abort is deferred before the reraise operation. Called from - -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous - - procedure Transfer_Occurrence - (Target : Exception_Occurrence_Access; - Source : Exception_Occurrence); - pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); - -- Called from s-tasren.adb:Local_Complete_RendezVous and - -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from - -- Source as an exception to be propagated in the caller task. Target is - -- expected to be a pointer to the fixed TSD occurrence for this task. - - -------------------------------- - -- Run-Time Check Subprograms -- - -------------------------------- - - -- These subprograms raise a specific exception with a reason message - -- attached. The parameters are the file name and line number in each - -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. - - procedure Rcheck_CE_Access_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Access_Parameter - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Discriminant_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Divide_By_Zero - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Explicit_Raise - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Index_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Invalid_Data - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Length_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Exception_Id - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Null_Not_Allowed - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Overflow_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Partition_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Range_Check - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Tag_Check - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Access_Before_Elaboration - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Accessibility_Check - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Address_Of_Intrinsic - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Aliased_Parameters - (File : System.Address; Line : Integer); - procedure Rcheck_PE_All_Guards_Closed - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Bad_Predicated_Generic_Type - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Current_Task_In_Entry_Body - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Duplicated_Entry_Address - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Explicit_Raise - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Implicit_Return - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Misaligned_Address_Value - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Missing_Return - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Non_Transportable_Actual - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Overlaid_Controlled_Object - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Potentially_Blocking_Operation - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stubbed_Subprogram_Called - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Unchecked_Union_Restriction - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Empty_Storage_Pool - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Explicit_Raise - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Infinite_Recursion - (File : System.Address; Line : Integer); - procedure Rcheck_SE_Object_Too_Large - (File : System.Address; Line : Integer); - procedure Rcheck_PE_Stream_Operation_Not_Allowed - (File : System.Address; Line : Integer); - procedure Rcheck_CE_Access_Check_Ext - (File : System.Address; Line, Column : Integer); - procedure Rcheck_CE_Index_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer); - procedure Rcheck_CE_Invalid_Data_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer); - procedure Rcheck_CE_Range_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer); - - procedure Rcheck_PE_Finalize_Raised_Exception - (File : System.Address; Line : Integer); - -- This routine is separated out because it has quite different behavior - -- from the others. This is the "finalize/adjust raised exception". This - -- subprogram is always called with abort deferred, unlike all other - -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. - - pragma Export (C, Rcheck_CE_Access_Check, - "__gnat_rcheck_CE_Access_Check"); - pragma Export (C, Rcheck_CE_Null_Access_Parameter, - "__gnat_rcheck_CE_Null_Access_Parameter"); - pragma Export (C, Rcheck_CE_Discriminant_Check, - "__gnat_rcheck_CE_Discriminant_Check"); - pragma Export (C, Rcheck_CE_Divide_By_Zero, - "__gnat_rcheck_CE_Divide_By_Zero"); - pragma Export (C, Rcheck_CE_Explicit_Raise, - "__gnat_rcheck_CE_Explicit_Raise"); - pragma Export (C, Rcheck_CE_Index_Check, - "__gnat_rcheck_CE_Index_Check"); - pragma Export (C, Rcheck_CE_Invalid_Data, - "__gnat_rcheck_CE_Invalid_Data"); - pragma Export (C, Rcheck_CE_Length_Check, - "__gnat_rcheck_CE_Length_Check"); - pragma Export (C, Rcheck_CE_Null_Exception_Id, - "__gnat_rcheck_CE_Null_Exception_Id"); - pragma Export (C, Rcheck_CE_Null_Not_Allowed, - "__gnat_rcheck_CE_Null_Not_Allowed"); - pragma Export (C, Rcheck_CE_Overflow_Check, - "__gnat_rcheck_CE_Overflow_Check"); - pragma Export (C, Rcheck_CE_Partition_Check, - "__gnat_rcheck_CE_Partition_Check"); - pragma Export (C, Rcheck_CE_Range_Check, - "__gnat_rcheck_CE_Range_Check"); - pragma Export (C, Rcheck_CE_Tag_Check, - "__gnat_rcheck_CE_Tag_Check"); - pragma Export (C, Rcheck_PE_Access_Before_Elaboration, - "__gnat_rcheck_PE_Access_Before_Elaboration"); - pragma Export (C, Rcheck_PE_Accessibility_Check, - "__gnat_rcheck_PE_Accessibility_Check"); - pragma Export (C, Rcheck_PE_Address_Of_Intrinsic, - "__gnat_rcheck_PE_Address_Of_Intrinsic"); - pragma Export (C, Rcheck_PE_Aliased_Parameters, - "__gnat_rcheck_PE_Aliased_Parameters"); - pragma Export (C, Rcheck_PE_All_Guards_Closed, - "__gnat_rcheck_PE_All_Guards_Closed"); - pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type, - "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); - pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, - "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); - pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, - "__gnat_rcheck_PE_Duplicated_Entry_Address"); - pragma Export (C, Rcheck_PE_Explicit_Raise, - "__gnat_rcheck_PE_Explicit_Raise"); - pragma Export (C, Rcheck_PE_Finalize_Raised_Exception, - "__gnat_rcheck_PE_Finalize_Raised_Exception"); - pragma Export (C, Rcheck_PE_Implicit_Return, - "__gnat_rcheck_PE_Implicit_Return"); - pragma Export (C, Rcheck_PE_Misaligned_Address_Value, - "__gnat_rcheck_PE_Misaligned_Address_Value"); - pragma Export (C, Rcheck_PE_Missing_Return, - "__gnat_rcheck_PE_Missing_Return"); - pragma Export (C, Rcheck_PE_Non_Transportable_Actual, - "__gnat_rcheck_PE_Non_Transportable_Actual"); - pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, - "__gnat_rcheck_PE_Overlaid_Controlled_Object"); - pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, - "__gnat_rcheck_PE_Potentially_Blocking_Operation"); - pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed, - "__gnat_rcheck_PE_Stream_Operation_Not_Allowed"); - pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, - "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); - pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, - "__gnat_rcheck_PE_Unchecked_Union_Restriction"); - pragma Export (C, Rcheck_SE_Empty_Storage_Pool, - "__gnat_rcheck_SE_Empty_Storage_Pool"); - pragma Export (C, Rcheck_SE_Explicit_Raise, - "__gnat_rcheck_SE_Explicit_Raise"); - pragma Export (C, Rcheck_SE_Infinite_Recursion, - "__gnat_rcheck_SE_Infinite_Recursion"); - pragma Export (C, Rcheck_SE_Object_Too_Large, - "__gnat_rcheck_SE_Object_Too_Large"); - - pragma Export (C, Rcheck_CE_Access_Check_Ext, - "__gnat_rcheck_CE_Access_Check_ext"); - pragma Export (C, Rcheck_CE_Index_Check_Ext, - "__gnat_rcheck_CE_Index_Check_ext"); - pragma Export (C, Rcheck_CE_Invalid_Data_Ext, - "__gnat_rcheck_CE_Invalid_Data_ext"); - pragma Export (C, Rcheck_CE_Range_Check_Ext, - "__gnat_rcheck_CE_Range_Check_ext"); - - -- None of these procedures ever returns (they raise an exception). By - -- using pragma No_Return, we ensure that any junk code after the call, - -- such as normal return epilogue stuff, can be eliminated). - - pragma No_Return (Rcheck_CE_Access_Check); - pragma No_Return (Rcheck_CE_Null_Access_Parameter); - pragma No_Return (Rcheck_CE_Discriminant_Check); - pragma No_Return (Rcheck_CE_Divide_By_Zero); - pragma No_Return (Rcheck_CE_Explicit_Raise); - pragma No_Return (Rcheck_CE_Index_Check); - pragma No_Return (Rcheck_CE_Invalid_Data); - pragma No_Return (Rcheck_CE_Length_Check); - pragma No_Return (Rcheck_CE_Null_Exception_Id); - pragma No_Return (Rcheck_CE_Null_Not_Allowed); - pragma No_Return (Rcheck_CE_Overflow_Check); - pragma No_Return (Rcheck_CE_Partition_Check); - pragma No_Return (Rcheck_CE_Range_Check); - pragma No_Return (Rcheck_CE_Tag_Check); - pragma No_Return (Rcheck_PE_Access_Before_Elaboration); - pragma No_Return (Rcheck_PE_Accessibility_Check); - pragma No_Return (Rcheck_PE_Address_Of_Intrinsic); - pragma No_Return (Rcheck_PE_Aliased_Parameters); - pragma No_Return (Rcheck_PE_All_Guards_Closed); - pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type); - pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body); - pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); - pragma No_Return (Rcheck_PE_Explicit_Raise); - pragma No_Return (Rcheck_PE_Implicit_Return); - pragma No_Return (Rcheck_PE_Misaligned_Address_Value); - pragma No_Return (Rcheck_PE_Missing_Return); - pragma No_Return (Rcheck_PE_Non_Transportable_Actual); - pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); - pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); - pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); - pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); - pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); - pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); - pragma No_Return (Rcheck_SE_Empty_Storage_Pool); - pragma No_Return (Rcheck_SE_Explicit_Raise); - pragma No_Return (Rcheck_SE_Infinite_Recursion); - pragma No_Return (Rcheck_SE_Object_Too_Large); - - pragma No_Return (Rcheck_CE_Access_Check_Ext); - pragma No_Return (Rcheck_CE_Index_Check_Ext); - pragma No_Return (Rcheck_CE_Invalid_Data_Ext); - pragma No_Return (Rcheck_CE_Range_Check_Ext); - - --------------------------------------------- - -- Reason Strings for Run-Time Check Calls -- - --------------------------------------------- - - -- These strings are null-terminated and are used by Rcheck_nn. The - -- strings correspond to the definitions for Types.RT_Exception_Code. - - use ASCII; - - Rmsg_00 : constant String := "access check failed" & NUL; - Rmsg_01 : constant String := "access parameter is null" & NUL; - Rmsg_02 : constant String := "discriminant check failed" & NUL; - Rmsg_03 : constant String := "divide by zero" & NUL; - Rmsg_04 : constant String := "explicit raise" & NUL; - Rmsg_05 : constant String := "index check failed" & NUL; - Rmsg_06 : constant String := "invalid data" & NUL; - Rmsg_07 : constant String := "length check failed" & NUL; - Rmsg_08 : constant String := "null Exception_Id" & NUL; - Rmsg_09 : constant String := "null-exclusion check failed" & NUL; - Rmsg_10 : constant String := "overflow check failed" & NUL; - Rmsg_11 : constant String := "partition check failed" & NUL; - Rmsg_12 : constant String := "range check failed" & NUL; - Rmsg_13 : constant String := "tag check failed" & NUL; - Rmsg_14 : constant String := "access before elaboration" & NUL; - Rmsg_15 : constant String := "accessibility check failed" & NUL; - Rmsg_16 : constant String := "attempt to take address of" & - " intrinsic subprogram" & NUL; - Rmsg_17 : constant String := "aliased parameters" & NUL; - Rmsg_18 : constant String := "all guards closed" & NUL; - Rmsg_19 : constant String := "improper use of generic subtype" & - " with predicate" & NUL; - Rmsg_20 : constant String := "Current_Task referenced in entry" & - " body" & NUL; - Rmsg_21 : constant String := "duplicated entry address" & NUL; - Rmsg_22 : constant String := "explicit raise" & NUL; - Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL; - Rmsg_24 : constant String := "implicit return with No_Return" & NUL; - Rmsg_25 : constant String := "misaligned address value" & NUL; - Rmsg_26 : constant String := "missing return" & NUL; - Rmsg_27 : constant String := "overlaid controlled object" & NUL; - Rmsg_28 : constant String := "potentially blocking operation" & NUL; - Rmsg_29 : constant String := "stubbed subprogram called" & NUL; - Rmsg_30 : constant String := "unchecked union restriction" & NUL; - Rmsg_31 : constant String := "actual/returned class-wide" & - " value not transportable" & NUL; - Rmsg_32 : constant String := "empty storage pool" & NUL; - Rmsg_33 : constant String := "explicit raise" & NUL; - Rmsg_34 : constant String := "infinite recursion" & NUL; - Rmsg_35 : constant String := "object too large" & NUL; - Rmsg_36 : constant String := "stream operation not allowed" & NUL; - - ----------------------- - -- Polling Interface -- - ----------------------- - - type Unsigned is mod 2 ** 32; - - Counter : Unsigned := 0; - pragma Warnings (Off, Counter); - -- This counter is provided for convenience. It can be used in Poll to - -- perform periodic but not systematic operations. - - procedure Poll is separate; - -- The actual polling routine is separate, so that it can easily be - -- replaced with a target dependent version. - - -------------------------- - -- Code_Address_For_AAA -- - -------------------------- - - -- This function gives us the start of the PC range for addresses within - -- the exception unit itself. We hope that gigi/gcc keep all the procedures - -- in their original order. - - function Code_Address_For_AAA return System.Address is - begin - -- We are using a label instead of Code_Address_For_AAA'Address because - -- on some platforms the latter does not yield the address we want, but - -- the address of a stub or of a descriptor instead. This is the case at - -- least on PA-HPUX. - - <> - return Start_Of_AAA'Address; - end Code_Address_For_AAA; - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain (Excep : EOA) is separate; - -- The actual Call_Chain routine is separate, so that it can easily - -- be dummied out when no exception traceback information is needed. - - ------------------- - -- EId_To_String -- - ------------------- - - function EId_To_String (X : Exception_Id) return String - renames Stream_Attributes.EId_To_String; - - ------------------ - -- EO_To_String -- - ------------------ - - -- We use the null string to represent the null occurrence, otherwise we - -- output the Untailored_Exception_Information string for the occurrence. - - function EO_To_String (X : Exception_Occurrence) return String - renames Stream_Attributes.EO_To_String; - - ------------------------ - -- Exception_Identity -- - ------------------------ - - function Exception_Identity - (X : Exception_Occurrence) return Exception_Id - is - begin - -- Note that the following test used to be here for the original - -- Ada 95 semantics, but these were modified by AI-241 to require - -- returning Null_Id instead of raising Constraint_Error. - - -- if X.Id = Null_Id then - -- raise Constraint_Error; - -- end if; - - return X.Id; - end Exception_Identity; - - --------------------------- - -- Exception_Information -- - --------------------------- - - function Exception_Information (X : Exception_Occurrence) return String is - begin - if X.Id = Null_Id then - raise Constraint_Error; - else - return Exception_Data.Exception_Information (X); - end if; - end Exception_Information; - - ----------------------- - -- Exception_Message -- - ----------------------- - - function Exception_Message (X : Exception_Occurrence) return String is - begin - if X.Id = Null_Id then - raise Constraint_Error; - else - return X.Msg (1 .. X.Msg_Length); - end if; - end Exception_Message; - - -------------------- - -- Exception_Name -- - -------------------- - - function Exception_Name (Id : Exception_Id) return String is - begin - if Id = null then - raise Constraint_Error; - else - return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); - end if; - end Exception_Name; - - function Exception_Name (X : Exception_Occurrence) return String is - begin - return Exception_Name (X.Id); - end Exception_Name; - - --------------------------- - -- Exception_Name_Simple -- - --------------------------- - - function Exception_Name_Simple (X : Exception_Occurrence) return String is - Name : constant String := Exception_Name (X); - P : Natural; - - begin - P := Name'Length; - while P > 1 loop - exit when Name (P - 1) = '.'; - P := P - 1; - end loop; - - -- Return result making sure lower bound is 1 - - declare - subtype Rname is String (1 .. Name'Length - P + 1); - begin - return Rname (Name (P .. Name'Length)); - end; - end Exception_Name_Simple; - - -------------------- - -- Exception_Data -- - -------------------- - - package body Exception_Data is separate; - -- This package can be easily dummied out if we do not want the basic - -- support for exception messages (such as in Ada 83). - - --------------------------- - -- Exception_Propagation -- - --------------------------- - - package body Exception_Propagation is separate; - -- Depending on the actual exception mechanism used (front-end or - -- back-end based), the implementation will differ, which is why this - -- package is separated. - - ---------------------- - -- Exception_Traces -- - ---------------------- - - package body Exception_Traces is separate; - -- Depending on the underlying support for IO the implementation will - -- differ. Moreover we would like to dummy out this package in case we - -- do not want any exception tracing support. This is why this package - -- is separated. - - -------------------------------------- - -- Get_Exception_Machine_Occurrence -- - -------------------------------------- - - function Get_Exception_Machine_Occurrence - (X : Exception_Occurrence) return System.Address - is - begin - return X.Machine_Occurrence; - end Get_Exception_Machine_Occurrence; - - ----------- - -- Image -- - ----------- - - function Image (Index : Integer) return String is - Result : constant String := Integer'Image (Index); - begin - if Result (1) = ' ' then - return Result (2 .. Result'Last); - else - return Result; - end if; - end Image; - - ----------------------- - -- Stream Attributes -- - ----------------------- - - package body Stream_Attributes is separate; - -- This package can be easily dummied out if we do not want the - -- support for streaming Exception_Ids and Exception_Occurrences. - - ---------------------------- - -- Raise_Constraint_Error -- - ---------------------------- - - procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is - begin - Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line); - end Raise_Constraint_Error; - - -------------------------------- - -- Raise_Constraint_Error_Msg -- - -------------------------------- - - procedure Raise_Constraint_Error_Msg - (File : System.Address; - Line : Integer; - Column : Integer; - Msg : System.Address) - is - begin - Raise_With_Location_And_Msg - (Constraint_Error_Def'Access, File, Line, Column, Msg); - end Raise_Constraint_Error_Msg; - - ------------------------- - -- Complete_Occurrence -- - ------------------------- - - procedure Complete_Occurrence (X : EOA) is - begin - -- Compute the backtrace for this occurrence if the corresponding - -- binder option has been set. Call_Chain takes care of the reraise - -- case. - - -- ??? Using Call_Chain here means we are going to walk up the stack - -- once only for backtracing purposes before doing it again for the - -- propagation per se. - - -- The first inspection is much lighter, though, as it only requires - -- partial unwinding of each frame. Additionally, although we could use - -- the personality routine to record the addresses while propagating, - -- this method has two drawbacks: - - -- 1) the trace is incomplete if the exception is handled since we - -- don't walk past the frame with the handler, - - -- and - - -- 2) we would miss the frames for which our personality routine is not - -- called, e.g. if C or C++ calls are on the way. - - Call_Chain (X); - - -- Notify the debugger - Debug_Raise_Exception - (E => SSL.Exception_Data_Ptr (X.Id), - Message => X.Msg (1 .. X.Msg_Length)); - end Complete_Occurrence; - - --------------------------------------- - -- Complete_And_Propagate_Occurrence -- - --------------------------------------- - - procedure Complete_And_Propagate_Occurrence (X : EOA) is - begin - Complete_Occurrence (X); - Exception_Propagation.Propagate_Exception (X); - end Complete_And_Propagate_Occurrence; - - --------------------- - -- Raise_Exception -- - --------------------- - - procedure Raise_Exception - (E : Exception_Id; - Message : String := "") - is - EF : Exception_Id := E; - begin - -- Raise CE if E = Null_ID (AI-446) - - if E = null then - EF := Constraint_Error'Identity; - end if; - - -- Go ahead and raise appropriate exception - - Raise_Exception_Always (EF, Message); - end Raise_Exception; - - ---------------------------- - -- Raise_Exception_Always -- - ---------------------------- - - procedure Raise_Exception_Always - (E : Exception_Id; - Message : String := "") - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - Exception_Data.Set_Exception_Msg (X, E, Message); - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_And_Propagate_Occurrence (X); - end Raise_Exception_Always; - - ------------------------------ - -- Raise_Exception_No_Defer -- - ------------------------------ - - procedure Raise_Exception_No_Defer - (E : Exception_Id; - Message : String := "") - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - Exception_Data.Set_Exception_Msg (X, E, Message); - - -- Do not call Abort_Defer.all, as specified by the spec - - Complete_And_Propagate_Occurrence (X); - end Raise_Exception_No_Defer; - - ------------------------------------- - -- Raise_From_Controlled_Operation -- - ------------------------------------- - - procedure Raise_From_Controlled_Operation - (X : Ada.Exceptions.Exception_Occurrence) - is - Prefix : constant String := "adjust/finalize raised "; - Orig_Msg : constant String := Exception_Message (X); - Orig_Prefix_Length : constant Natural := - Integer'Min (Prefix'Length, Orig_Msg'Length); - - Orig_Prefix : String renames - Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); - - begin - -- Message already has the proper prefix, just re-raise - - if Orig_Prefix = Prefix then - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => Orig_Msg); - - else - declare - New_Msg : constant String := Prefix & Exception_Name (X); - - begin - -- No message present, just provide our own - - if Orig_Msg = "" then - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg); - - -- Message present, add informational prefix - - else - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => New_Msg & ": " & Orig_Msg); - end if; - end; - end if; - end Raise_From_Controlled_Operation; - - ------------------------------------------- - -- Create_Occurrence_From_Signal_Handler -- - ------------------------------------------- - - function Create_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return EOA - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - Exception_Data.Set_Exception_C_Msg (X, E, M); - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_Occurrence (X); - return X; - end Create_Occurrence_From_Signal_Handler; - - --------------------------------------------------- - -- Create_Machine_Occurrence_From_Signal_Handler -- - --------------------------------------------------- - - function Create_Machine_Occurrence_From_Signal_Handler - (E : Exception_Id; - M : System.Address) return System.Address - is - begin - return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence; - end Create_Machine_Occurrence_From_Signal_Handler; - - ------------------------------- - -- Raise_From_Signal_Handler -- - ------------------------------- - - procedure Raise_From_Signal_Handler - (E : Exception_Id; - M : System.Address) - is - begin - Exception_Propagation.Propagate_Exception - (Create_Occurrence_From_Signal_Handler (E, M)); - end Raise_From_Signal_Handler; - - ------------------------- - -- Raise_Program_Error -- - ------------------------- - - procedure Raise_Program_Error - (File : System.Address; - Line : Integer) - is - begin - Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line); - end Raise_Program_Error; - - ----------------------------- - -- Raise_Program_Error_Msg -- - ----------------------------- - - procedure Raise_Program_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address) - is - begin - Raise_With_Location_And_Msg - (Program_Error_Def'Access, File, Line, M => Msg); - end Raise_Program_Error_Msg; - - ------------------------- - -- Raise_Storage_Error -- - ------------------------- - - procedure Raise_Storage_Error - (File : System.Address; - Line : Integer) - is - begin - Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line); - end Raise_Storage_Error; - - ----------------------------- - -- Raise_Storage_Error_Msg -- - ----------------------------- - - procedure Raise_Storage_Error_Msg - (File : System.Address; - Line : Integer; - Msg : System.Address) - is - begin - Raise_With_Location_And_Msg - (Storage_Error_Def'Access, File, Line, M => Msg); - end Raise_Storage_Error_Msg; - - --------------------------------- - -- Raise_With_Location_And_Msg -- - --------------------------------- - - procedure Raise_With_Location_And_Msg - (E : Exception_Id; - F : System.Address; - L : Integer; - C : Integer := 0; - M : System.Address := System.Null_Address) - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - begin - Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M); - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_And_Propagate_Occurrence (X); - end Raise_With_Location_And_Msg; - - -------------------- - -- Raise_With_Msg -- - -------------------- - - procedure Raise_With_Msg (E : Exception_Id) is - Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; - Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; - begin - Excep.Exception_Raised := False; - Excep.Id := E; - Excep.Num_Tracebacks := 0; - Excep.Pid := Local_Partition_ID; - - -- Copy the message from the current exception - -- Change the interface to be called with an occurrence ??? - - Excep.Msg_Length := Ex.Msg_Length; - Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length); - - -- The following is a common pattern, should be abstracted - -- into a procedure call ??? - - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Complete_And_Propagate_Occurrence (Excep); - end Raise_With_Msg; - - ----------------------------------------- - -- Calls to Run-Time Check Subprograms -- - ----------------------------------------- - - procedure Rcheck_CE_Access_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address); - end Rcheck_CE_Access_Check; - - procedure Rcheck_CE_Null_Access_Parameter - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address); - end Rcheck_CE_Null_Access_Parameter; - - procedure Rcheck_CE_Discriminant_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address); - end Rcheck_CE_Discriminant_Check; - - procedure Rcheck_CE_Divide_By_Zero - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address); - end Rcheck_CE_Divide_By_Zero; - - procedure Rcheck_CE_Explicit_Raise - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address); - end Rcheck_CE_Explicit_Raise; - - procedure Rcheck_CE_Index_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address); - end Rcheck_CE_Index_Check; - - procedure Rcheck_CE_Invalid_Data - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address); - end Rcheck_CE_Invalid_Data; - - procedure Rcheck_CE_Length_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address); - end Rcheck_CE_Length_Check; - - procedure Rcheck_CE_Null_Exception_Id - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address); - end Rcheck_CE_Null_Exception_Id; - - procedure Rcheck_CE_Null_Not_Allowed - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address); - end Rcheck_CE_Null_Not_Allowed; - - procedure Rcheck_CE_Overflow_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address); - end Rcheck_CE_Overflow_Check; - - procedure Rcheck_CE_Partition_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address); - end Rcheck_CE_Partition_Check; - - procedure Rcheck_CE_Range_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address); - end Rcheck_CE_Range_Check; - - procedure Rcheck_CE_Tag_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address); - end Rcheck_CE_Tag_Check; - - procedure Rcheck_PE_Access_Before_Elaboration - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); - end Rcheck_PE_Access_Before_Elaboration; - - procedure Rcheck_PE_Accessibility_Check - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); - end Rcheck_PE_Accessibility_Check; - - procedure Rcheck_PE_Address_Of_Intrinsic - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); - end Rcheck_PE_Address_Of_Intrinsic; - - procedure Rcheck_PE_Aliased_Parameters - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_17'Address); - end Rcheck_PE_Aliased_Parameters; - - procedure Rcheck_PE_All_Guards_Closed - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_18'Address); - end Rcheck_PE_All_Guards_Closed; - - procedure Rcheck_PE_Bad_Predicated_Generic_Type - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); - end Rcheck_PE_Bad_Predicated_Generic_Type; - - procedure Rcheck_PE_Current_Task_In_Entry_Body - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_20'Address); - end Rcheck_PE_Current_Task_In_Entry_Body; - - procedure Rcheck_PE_Duplicated_Entry_Address - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_21'Address); - end Rcheck_PE_Duplicated_Entry_Address; - - procedure Rcheck_PE_Explicit_Raise - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_22'Address); - end Rcheck_PE_Explicit_Raise; - - procedure Rcheck_PE_Implicit_Return - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_24'Address); - end Rcheck_PE_Implicit_Return; - - procedure Rcheck_PE_Misaligned_Address_Value - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_25'Address); - end Rcheck_PE_Misaligned_Address_Value; - - procedure Rcheck_PE_Missing_Return - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); - end Rcheck_PE_Missing_Return; - - procedure Rcheck_PE_Non_Transportable_Actual - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); - end Rcheck_PE_Non_Transportable_Actual; - - procedure Rcheck_PE_Overlaid_Controlled_Object - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_27'Address); - end Rcheck_PE_Overlaid_Controlled_Object; - - procedure Rcheck_PE_Potentially_Blocking_Operation - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); - end Rcheck_PE_Potentially_Blocking_Operation; - - procedure Rcheck_PE_Stream_Operation_Not_Allowed - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); - end Rcheck_PE_Stream_Operation_Not_Allowed; - - procedure Rcheck_PE_Stubbed_Subprogram_Called - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_29'Address); - end Rcheck_PE_Stubbed_Subprogram_Called; - - procedure Rcheck_PE_Unchecked_Union_Restriction - (File : System.Address; Line : Integer) - is - begin - Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); - end Rcheck_PE_Unchecked_Union_Restriction; - - procedure Rcheck_SE_Empty_Storage_Pool - (File : System.Address; Line : Integer) - is - begin - Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address); - end Rcheck_SE_Empty_Storage_Pool; - - procedure Rcheck_SE_Explicit_Raise - (File : System.Address; Line : Integer) - is - begin - Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address); - end Rcheck_SE_Explicit_Raise; - - procedure Rcheck_SE_Infinite_Recursion - (File : System.Address; Line : Integer) - is - begin - Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address); - end Rcheck_SE_Infinite_Recursion; - - procedure Rcheck_SE_Object_Too_Large - (File : System.Address; Line : Integer) - is - begin - Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address); - end Rcheck_SE_Object_Too_Large; - - procedure Rcheck_CE_Access_Check_Ext - (File : System.Address; Line, Column : Integer) - is - begin - Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address); - end Rcheck_CE_Access_Check_Ext; - - procedure Rcheck_CE_Index_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer) - is - Msg : constant String := - Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF - & "index " & Image (Index) & " not in " & Image (First) - & ".." & Image (Last) & ASCII.NUL; - begin - Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); - end Rcheck_CE_Index_Check_Ext; - - procedure Rcheck_CE_Invalid_Data_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer) - is - Msg : constant String := - Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF - & "value " & Image (Index) & " not in " & Image (First) - & ".." & Image (Last) & ASCII.NUL; - begin - Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); - end Rcheck_CE_Invalid_Data_Ext; - - procedure Rcheck_CE_Range_Check_Ext - (File : System.Address; Line, Column, Index, First, Last : Integer) - is - Msg : constant String := - Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF - & "value " & Image (Index) & " not in " & Image (First) - & ".." & Image (Last) & ASCII.NUL; - begin - Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); - end Rcheck_CE_Range_Check_Ext; - - procedure Rcheck_PE_Finalize_Raised_Exception - (File : System.Address; Line : Integer) - is - X : constant EOA := Exception_Propagation.Allocate_Occurrence; - - begin - -- This is "finalize/adjust raised exception". This subprogram is always - -- called with abort deferred, unlike all other Rcheck_* subprograms, it - -- needs to call Raise_Exception_No_Defer. - - -- This is consistent with Raise_From_Controlled_Operation - - Exception_Data.Set_Exception_C_Msg - (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address); - Complete_And_Propagate_Occurrence (X); - end Rcheck_PE_Finalize_Raised_Exception; - - ------------- - -- Reraise -- - ------------- - - procedure Reraise is - Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; - Saved_MO : constant System.Address := Excep.Machine_Occurrence; - - begin - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Save_Occurrence (Excep.all, Get_Current_Excep.all.all); - Excep.Machine_Occurrence := Saved_MO; - Complete_And_Propagate_Occurrence (Excep); - end Reraise; - - -------------------------------------- - -- Reraise_Library_Exception_If_Any -- - -------------------------------------- - - procedure Reraise_Library_Exception_If_Any is - LE : Exception_Occurrence; - - begin - if Library_Exception_Set then - LE := Library_Exception; - - if LE.Id = Null_Id then - Raise_Exception_No_Defer - (E => Program_Error'Identity, - Message => "finalize/adjust raised exception"); - else - Raise_From_Controlled_Operation (LE); - end if; - end if; - end Reraise_Library_Exception_If_Any; - - ------------------------ - -- Reraise_Occurrence -- - ------------------------ - - procedure Reraise_Occurrence (X : Exception_Occurrence) is - begin - if X.Id = null then - return; - else - Reraise_Occurrence_Always (X); - end if; - end Reraise_Occurrence; - - ------------------------------- - -- Reraise_Occurrence_Always -- - ------------------------------- - - procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is - begin - if not ZCX_By_Default then - Abort_Defer.all; - end if; - - Reraise_Occurrence_No_Defer (X); - end Reraise_Occurrence_Always; - - --------------------------------- - -- Reraise_Occurrence_No_Defer -- - --------------------------------- - - procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is - Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; - Saved_MO : constant System.Address := Excep.Machine_Occurrence; - begin - Save_Occurrence (Excep.all, X); - Excep.Machine_Occurrence := Saved_MO; - Complete_And_Propagate_Occurrence (Excep); - end Reraise_Occurrence_No_Defer; - - --------------------- - -- Save_Occurrence -- - --------------------- - - procedure Save_Occurrence - (Target : out Exception_Occurrence; - Source : Exception_Occurrence) - is - begin - -- As the machine occurrence might be a data that must be finalized - -- (outside any Ada mechanism), do not copy it - - Target.Id := Source.Id; - Target.Machine_Occurrence := System.Null_Address; - Target.Msg_Length := Source.Msg_Length; - Target.Num_Tracebacks := Source.Num_Tracebacks; - Target.Pid := Source.Pid; - - Target.Msg (1 .. Target.Msg_Length) := - Source.Msg (1 .. Target.Msg_Length); - - Target.Tracebacks (1 .. Target.Num_Tracebacks) := - Source.Tracebacks (1 .. Target.Num_Tracebacks); - end Save_Occurrence; - - function Save_Occurrence (Source : Exception_Occurrence) return EOA is - Target : constant EOA := new Exception_Occurrence; - begin - Save_Occurrence (Target.all, Source); - return Target; - end Save_Occurrence; - - ------------------- - -- String_To_EId -- - ------------------- - - function String_To_EId (S : String) return Exception_Id - renames Stream_Attributes.String_To_EId; - - ------------------ - -- String_To_EO -- - ------------------ - - function String_To_EO (S : String) return Exception_Occurrence - renames Stream_Attributes.String_To_EO; - - --------------- - -- To_Stderr -- - --------------- - - procedure To_Stderr (C : Character) is - procedure Put_Char_Stderr (C : Character); - pragma Import (C, Put_Char_Stderr, "put_char_stderr"); - begin - Put_Char_Stderr (C); - end To_Stderr; - - procedure To_Stderr (S : String) is - begin - for J in S'Range loop - if S (J) /= ASCII.CR then - To_Stderr (S (J)); - end if; - end loop; - end To_Stderr; - - ------------------------- - -- Transfer_Occurrence -- - ------------------------- - - procedure Transfer_Occurrence - (Target : Exception_Occurrence_Access; - Source : Exception_Occurrence) - is - begin - Save_Occurrence (Target.all, Source); - end Transfer_Occurrence; - - ------------------------ - -- Triggered_By_Abort -- - ------------------------ - - function Triggered_By_Abort return Boolean is - Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; - begin - return Ex /= null - and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; - end Triggered_By_Abort; - - ------------------------- - -- Wide_Exception_Name -- - ------------------------- - - WC_Encoding : Character; - pragma Import (C, WC_Encoding, "__gl_wc_encoding"); - -- Encoding method for source, as exported by binder - - function Wide_Exception_Name - (Id : Exception_Id) return Wide_String - is - S : constant String := Exception_Name (Id); - W : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Exception_Name; - - function Wide_Exception_Name - (X : Exception_Occurrence) return Wide_String - is - S : constant String := Exception_Name (X); - W : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Exception_Name; - - ---------------------------- - -- Wide_Wide_Exception_Name -- - ----------------------------- - - function Wide_Wide_Exception_Name - (Id : Exception_Id) return Wide_Wide_String - is - S : constant String := Exception_Name (Id); - W : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Wide_Exception_Name; - - function Wide_Wide_Exception_Name - (X : Exception_Occurrence) return Wide_Wide_String - is - S : constant String := Exception_Name (X); - W : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Wide_Exception_Name; - - -------------------------- - -- Code_Address_For_ZZZ -- - -------------------------- - - -- This function gives us the end of the PC range for addresses - -- within the exception unit itself. We hope that gigi/gcc keeps all the - -- procedures in their original order. - - function Code_Address_For_ZZZ return System.Address is - begin - <> - return Start_Of_ZZZ'Address; - end Code_Address_For_ZZZ; - -end Ada.Exceptions; diff --git a/gcc/ada/a-except.ads b/gcc/ada/a-except.ads deleted file mode 100644 index ff99e35..0000000 --- a/gcc/ada/a-except.ads +++ /dev/null @@ -1,349 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of Ada.Exceptions fully supports Ada 95 and later language --- versions. It is used in all situations except for the build of the --- compiler and other basic tools. For these latter builds, we use an --- Ada 95-only version. - --- The reason for this splitting off of a separate version is to support --- older bootstrap compilers that do not support Ada 2005 features, and --- Ada.Exceptions is part of the compiler sources. - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with ourself. - -with System; -with System.Parameters; -with System.Standard_Library; -with System.Traceback_Entries; - -package Ada.Exceptions is - pragma Preelaborate; - -- In accordance with Ada 2005 AI-362. - - type Exception_Id is private; - pragma Preelaborable_Initialization (Exception_Id); - - Null_Id : constant Exception_Id; - - type Exception_Occurrence is limited private; - pragma Preelaborable_Initialization (Exception_Occurrence); - - type Exception_Occurrence_Access is access all Exception_Occurrence; - - Null_Occurrence : constant Exception_Occurrence; - - function Exception_Name (Id : Exception_Id) return String; - - function Exception_Name (X : Exception_Occurrence) return String; - - function Wide_Exception_Name - (Id : Exception_Id) return Wide_String; - pragma Ada_05 (Wide_Exception_Name); - - function Wide_Exception_Name - (X : Exception_Occurrence) return Wide_String; - pragma Ada_05 (Wide_Exception_Name); - - function Wide_Wide_Exception_Name - (Id : Exception_Id) return Wide_Wide_String; - pragma Ada_05 (Wide_Wide_Exception_Name); - - function Wide_Wide_Exception_Name - (X : Exception_Occurrence) return Wide_Wide_String; - pragma Ada_05 (Wide_Wide_Exception_Name); - - procedure Raise_Exception (E : Exception_Id; Message : String := ""); - pragma No_Return (Raise_Exception); - -- Note: In accordance with AI-466, CE is raised if E = Null_Id - - function Exception_Message (X : Exception_Occurrence) return String; - - procedure Reraise_Occurrence (X : Exception_Occurrence); - -- Note: it would be really nice to give a pragma No_Return for this - -- procedure, but it would be wrong, since Reraise_Occurrence does return - -- if the argument is the null exception occurrence. See also procedure - -- Reraise_Occurrence_Always in the private part of this package. - - function Exception_Identity (X : Exception_Occurrence) return Exception_Id; - - function Exception_Information (X : Exception_Occurrence) return String; - -- The format of the exception information is as follows: - -- - -- exception name (as in Exception_Name) - -- message (or a null line if no message) - -- PID=nnnn - -- 0xyyyyyyyy 0xyyyyyyyy ... - -- - -- The lines are separated by a ASCII.LF character - -- - -- The nnnn is the partition Id given as decimal digits - -- - -- The 0x... line represents traceback program counter locations, - -- in order with the first one being the exception location. - - -- Note on ordering: the compiler uses the Save_Occurrence procedure, but - -- not the function from Rtsfind, so it is important that the procedure - -- come first, since Rtsfind finds the first matching entity. - - procedure Save_Occurrence - (Target : out Exception_Occurrence; - Source : Exception_Occurrence); - - function Save_Occurrence - (Source : Exception_Occurrence) - return Exception_Occurrence_Access; - - -- Ada 2005 (AI-438): The language revision introduces the following - -- subprograms and attribute definitions. We do not provide them - -- explicitly. instead, the corresponding stream attributes are made - -- available through a pragma Stream_Convert in the private part. - - -- procedure Read_Exception_Occurrence - -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - -- Item : out Exception_Occurrence); - - -- procedure Write_Exception_Occurrence - -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; - -- Item : Exception_Occurrence); - - -- for Exception_Occurrence'Read use Read_Exception_Occurrence; - -- for Exception_Occurrence'Write use Write_Exception_Occurrence; - -private - package SSL renames System.Standard_Library; - package SP renames System.Parameters; - - subtype EOA is Exception_Occurrence_Access; - - Exception_Msg_Max_Length : constant := SP.Default_Exception_Msg_Max_Length; - - ------------------ - -- Exception_Id -- - ------------------ - - subtype Code_Loc is System.Address; - -- Code location used in building exception tables and for call addresses - -- when propagating an exception. Values of this type are created by using - -- Label'Address or extracted from machine states using Get_Code_Loc. - - Null_Loc : constant Code_Loc := System.Null_Address; - -- Null code location, used to flag outer level frame - - type Exception_Id is new SSL.Exception_Data_Ptr; - - function EId_To_String (X : Exception_Id) return String; - function String_To_EId (S : String) return Exception_Id; - pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String); - -- Functions for implementing Exception_Id stream attributes - - Null_Id : constant Exception_Id := null; - - ------------------------- - -- Private Subprograms -- - ------------------------- - - function Exception_Name_Simple (X : Exception_Occurrence) return String; - -- Like Exception_Name, but returns the simple non-qualified name of the - -- exception. This is used to implement the Exception_Name function in - -- Current_Exceptions (the DEC compatible unit). It is called from the - -- compiler generated code (using Rtsfind, which does not respect the - -- private barrier, so we can place this function in the private part - -- where the compiler can find it, but the spec is unchanged.) - - procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); - pragma No_Return (Raise_Exception_Always); - pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); - -- This differs from Raise_Exception only in that the caller has determined - -- that for sure the parameter E is not null, and that therefore no check - -- for Null_Id is required. The expander converts Raise_Exception calls to - -- Raise_Exception_Always if it can determine this is the case. The Export - -- allows this routine to be accessed from Pure units. - - procedure Raise_From_Signal_Handler - (E : Exception_Id; - M : System.Address); - pragma Export - (Ada, Raise_From_Signal_Handler, - "ada__exceptions__raise_from_signal_handler"); - pragma No_Return (Raise_From_Signal_Handler); - -- This routine is used to raise an exception from a signal handler. The - -- signal handler has already stored the machine state (i.e. the state that - -- corresponds to the location at which the signal was raised). E is the - -- Exception_Id specifying what exception is being raised, and M is a - -- pointer to a null-terminated string which is the message to be raised. - -- Note that this routine never returns, so it is permissible to simply - -- jump to this routine, rather than call it. This may be appropriate for - -- systems where the right way to get out of signal handler is to alter the - -- PC value in the machine state or in some other way ask the operating - -- system to return here rather than to the original location. - - procedure Raise_From_Controlled_Operation - (X : Ada.Exceptions.Exception_Occurrence); - pragma No_Return (Raise_From_Controlled_Operation); - pragma Export - (Ada, Raise_From_Controlled_Operation, - "__gnat_raise_from_controlled_operation"); - -- Raise Program_Error, providing information about X (an exception raised - -- during a controlled operation) in the exception message. - - procedure Reraise_Library_Exception_If_Any; - pragma Export - (Ada, Reraise_Library_Exception_If_Any, - "__gnat_reraise_library_exception_if_any"); - -- If there was an exception raised during library-level finalization, - -- reraise the exception. - - procedure Reraise_Occurrence_Always (X : Exception_Occurrence); - pragma No_Return (Reraise_Occurrence_Always); - -- This differs from Raise_Occurrence only in that the caller guarantees - -- that for sure the parameter X is not the null occurrence, and that - -- therefore this procedure cannot return. The expander uses this routine - -- in the translation of a raise statement with no parameter (reraise). - - procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence); - pragma No_Return (Reraise_Occurrence_No_Defer); - -- Exactly like Reraise_Occurrence, except that abort is not deferred - -- before the call and the parameter X is known not to be the null - -- occurrence. This is used in generated code when it is known that abort - -- is already deferred. - - function Triggered_By_Abort return Boolean; - -- Determine whether the current exception (if it exists) is an instance of - -- Standard'Abort_Signal. - - ----------------------- - -- Polling Interface -- - ----------------------- - - -- The GNAT compiler has an option to generate polling calls to the Poll - -- routine in this package. Specifying the -gnatP option for a compilation - -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram - -- entry and on every iteration of a loop, thus avoiding the possibility of - -- a case of unbounded time between calls. - - -- This polling interface may be used for instrumentation or debugging - -- purposes (e.g. implementing watchpoints in software or in the debugger). - - -- In the GNAT technology itself, this interface is used to implement - -- immediate asynchronous transfer of control and immediate abort on - -- targets which do not provide for one thread interrupting another. - - -- Note: this used to be in a separate unit called System.Poll, but that - -- caused horrible circular elaboration problems between System.Poll and - -- Ada.Exceptions. - - procedure Poll; - -- Check for asynchronous abort. Note that we do not inline the body. - -- This makes the interface more useful for debugging purposes. - - -------------------------- - -- Exception_Occurrence -- - -------------------------- - - package TBE renames System.Traceback_Entries; - - Max_Tracebacks : constant := 50; - -- Maximum number of trace backs stored in exception occurrence - - subtype Tracebacks_Array is TBE.Tracebacks_Array (1 .. Max_Tracebacks); - -- Traceback array stored in exception occurrence - - type Exception_Occurrence is record - Id : Exception_Id; - -- Exception_Identity for this exception occurrence - - Machine_Occurrence : System.Address; - -- The underlying machine occurrence. For GCC, this corresponds to the - -- _Unwind_Exception structure address. - - Msg_Length : Natural := 0; - -- Length of message (zero = no message) - - Msg : String (1 .. Exception_Msg_Max_Length); - -- Characters of message - - Exception_Raised : Boolean := False; - -- Set to true to indicate that this exception occurrence has actually - -- been raised. When an exception occurrence is first created, this is - -- set to False, then when it is processed by Raise_Current_Exception, - -- it is set to True. If Raise_Current_Exception is used to raise an - -- exception for which this flag is already True, then it knows that - -- it is dealing with the reraise case (which is useful to distinguish - -- for exception tracing purposes). - - Pid : Natural := 0; - -- Partition_Id for partition raising exception - - Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; - -- Number of traceback entries stored - - Tracebacks : Tracebacks_Array; - -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) - end record; - - function "=" (Left, Right : Exception_Occurrence) return Boolean - is abstract; - -- Don't allow comparison on exception occurrences, we should not need - -- this, and it would not work right, because of the Msg and Tracebacks - -- fields which have unused entries not copied by Save_Occurrence. - - function Get_Exception_Machine_Occurrence - (X : Exception_Occurrence) return System.Address; - pragma Export (Ada, Get_Exception_Machine_Occurrence, - "__gnat_get_exception_machine_occurrence"); - -- Get the machine occurrence corresponding to an exception occurrence. - -- It is Null_Address if there is no machine occurrence (in runtimes that - -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence - -- doesn't save the machine occurrence). - - function EO_To_String (X : Exception_Occurrence) return String; - function String_To_EO (S : String) return Exception_Occurrence; - pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); - -- Functions for implementing Exception_Occurrence stream attributes - - Null_Occurrence : constant Exception_Occurrence := ( - Id => null, - Machine_Occurrence => System.Null_Address, - Msg_Length => 0, - Msg => (others => ' '), - Exception_Raised => False, - Pid => 0, - Num_Tracebacks => 0, - Tracebacks => (others => TBE.Null_TB_Entry)); - -end Ada.Exceptions; diff --git a/gcc/ada/a-excpol-abort.adb b/gcc/ada/a-excpol-abort.adb deleted file mode 100644 index d4f9a07..0000000 --- a/gcc/ada/a-excpol-abort.adb +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . P O L L -- --- (version supporting asynchronous abort test) -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for targets that do not support per-thread asynchronous --- signals. On such targets, we require compilation with the -gnatP switch --- that activates periodic polling. Then in the body of the polling routine --- we test for asynchronous abort. - --- Windows and HPUX 10 currently use this file - -pragma Warnings (Off); --- Allow withing of non-Preelaborated units in Ada 2005 mode where this --- package will be categorized as Preelaborate. See AI-362 for details. --- It is safe in the context of the run-time to violate the rules. - -with System.Soft_Links; - -pragma Warnings (On); - -separate (Ada.Exceptions) - ----------- --- Poll -- ----------- - -procedure Poll is -begin - -- Test for asynchronous abort on each poll - - if System.Soft_Links.Check_Abort_Status.all /= 0 then - raise Standard'Abort_Signal; - end if; -end Poll; diff --git a/gcc/ada/a-excpol.adb b/gcc/ada/a-excpol.adb deleted file mode 100644 index 07a6e61..0000000 --- a/gcc/ada/a-excpol.adb +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . P O L L -- --- -- --- B o d y -- --- (dummy version where polling is not used) -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -separate (Ada.Exceptions) - ----------- --- Poll -- ----------- - -procedure Poll is -begin - null; -end Poll; diff --git a/gcc/ada/a-exctra.adb b/gcc/ada/a-exctra.adb deleted file mode 100644 index 03e4642..0000000 --- a/gcc/ada/a-exctra.adb +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . T R A C E B A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Exceptions.Traceback is - - ---------------- - -- Tracebacks -- - ---------------- - - function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array is - begin - return Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks)); - end Tracebacks; - -end Ada.Exceptions.Traceback; diff --git a/gcc/ada/a-exctra.ads b/gcc/ada/a-exctra.ads deleted file mode 100644 index 664bd75..0000000 --- a/gcc/ada/a-exctra.ads +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . T R A C E B A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is part of the support for tracebacks on exceptions - -with System.Traceback_Entries; - -package Ada.Exceptions.Traceback is - - package STBE renames System.Traceback_Entries; - - subtype Code_Loc is System.Address; - -- Code location in executing program - - subtype Tracebacks_Array is STBE.Tracebacks_Array; - -- A traceback array is an array of traceback entries - - function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array; - -- This function extracts the traceback information from an exception - -- occurrence, and returns it formatted in the manner required for - -- processing in GNAT.Traceback. See g-traceb.ads for further details. - - function "=" (A, B : Tracebacks_Array) return Boolean renames STBE."="; - -- Make "=" operator visible directly - - function Get_PC (TBE : STBE.Traceback_Entry) return Code_Loc - renames STBE.PC_For; - -- Returns the code address held by a given traceback entry, typically the - -- address of a call instruction. - -end Ada.Exceptions.Traceback; diff --git a/gcc/ada/a-exexda.adb b/gcc/ada/a-exexda.adb deleted file mode 100644 index 2a5ffbc..0000000 --- a/gcc/ada/a-exexda.adb +++ /dev/null @@ -1,744 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- ADA.EXCEPTIONS.EXCEPTION_DATA -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; use System.Storage_Elements; - -separate (Ada.Exceptions) -package body Exception_Data is - - -- This unit implements the Exception_Information related services for - -- both the Ada standard requirements and the GNAT.Exception_Traces - -- facility. This is also used by the implementation of the stream - -- attributes of types Exception_Id and Exception_Occurrence. - - -- There are common parts between the contents of Exception_Information - -- (the regular Ada interface) and Untailored_Exception_Information (used - -- for streaming, and when there is no symbolic traceback available) The - -- overall structure is sketched below: - - -- - -- Untailored_Exception_Information - -- | - -- +-------+--------+ - -- | | - -- Basic_Exc_Info & Untailored_Exc_Tback - -- (B_E_I) (U_E_TB) - - -- o-- - -- (B_E_I) | Exception_Name: (as in Exception_Name) - -- | Message: (or a null line if no message) - -- | PID=nnnn (if nonzero) - -- o-- - -- (U_E_TB) | Call stack traceback locations: - -- | <0xyyyyyyyy 0xyyyyyyyy ...> - -- o-- - - -- Exception_Information - -- | - -- +----------+----------+ - -- | | - -- Basic_Exc_Info & traceback - -- | - -- +-----------+------------+ - -- | | - -- Untailored_Exc_Tback Or Tback_Decorator - -- if no decorator set otherwise - - -- Functions returning String imply secondary stack use, which is a heavy - -- mechanism requiring run-time support. Besides, some of the routines we - -- provide here are to be used by the default Last_Chance_Handler, at the - -- critical point where the runtime is about to be finalized. Since most - -- of the items we have at hand are of bounded length, we also provide a - -- procedural interface able to incrementally append the necessary bits to - -- a preallocated buffer or output them straight to stderr. - - -- The procedural interface is composed of two major sections: a neutral - -- section for basic types like Address, Character, Natural or String, and - -- an exception oriented section for the exception names, messages, and - -- information. This is the Append_Info family of procedures below. - - -- Output to stderr is commanded by passing an empty buffer to update, and - -- care is taken not to overflow otherwise. - - -------------------------------------------- - -- Procedural Interface - Neutral section -- - -------------------------------------------- - - procedure Append_Info_Address - (A : Address; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Character - (C : Character; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Nat - (N : Natural; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural); - pragma Inline (Append_Info_NL); - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural); - - ------------------------------------------------------- - -- Procedural Interface - Exception oriented section -- - ------------------------------------------------------- - - procedure Append_Info_Exception_Name - (Id : Exception_Id; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Exception_Name - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Exception_Message - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Basic_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Untailored_Exception_Traceback - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - procedure Append_Info_Untailored_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural); - - -- The "functional" interface to the exception information not involving - -- a traceback decorator uses preallocated intermediate buffers to avoid - -- the use of secondary stack. Preallocation requires preliminary length - -- computation, for which a series of functions are introduced: - - --------------------------------- - -- Length evaluation utilities -- - --------------------------------- - - function Basic_Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural; - - function Untailored_Exception_Traceback_Maxlength - (X : Exception_Occurrence) return Natural; - - function Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural; - - function Exception_Name_Length - (Id : Exception_Id) return Natural; - - function Exception_Name_Length - (X : Exception_Occurrence) return Natural; - - function Exception_Message_Length - (X : Exception_Occurrence) return Natural; - - -------------------------- - -- Functional Interface -- - -------------------------- - - function Untailored_Exception_Traceback - (X : Exception_Occurrence) return String; - -- Returns an image of the complete call chain associated with an - -- exception occurrence in its most basic form, that is as a raw sequence - -- of hexadecimal addresses. - - function Tailored_Exception_Traceback - (X : Exception_Occurrence) return String; - -- Returns an image of the complete call chain associated with an - -- exception occurrence, either in its basic form if no decorator is - -- in place, or as formatted by the decorator otherwise. - - ----------------------------------------------------------------------- - -- Services for the default Last_Chance_Handler and the task wrapper -- - ----------------------------------------------------------------------- - - pragma Export - (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); - - pragma Export - (Ada, Append_Info_Untailored_Exception_Information, - "__gnat_append_info_u_e_info"); - - pragma Export - (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); - - function Get_Executable_Load_Address return System.Address; - pragma Import (C, Get_Executable_Load_Address, - "__gnat_get_executable_load_address"); - -- Get the load address of the executable, or Null_Address if not known - - ------------------------- - -- Append_Info_Address -- - ------------------------- - - procedure Append_Info_Address - (A : Address; - Info : in out String; - Ptr : in out Natural) - is - S : String (1 .. 18); - P : Natural; - N : Integer_Address; - - H : constant array (Integer range 0 .. 15) of Character := - "0123456789abcdef"; - begin - P := S'Last; - N := To_Integer (A); - loop - S (P) := H (Integer (N mod 16)); - P := P - 1; - N := N / 16; - exit when N = 0; - end loop; - - S (P - 1) := '0'; - S (P) := 'x'; - - Append_Info_String (S (P - 1 .. S'Last), Info, Ptr); - end Append_Info_Address; - - --------------------------------------------- - -- Append_Info_Basic_Exception_Information -- - --------------------------------------------- - - -- To ease the maximum length computation, we define and pull out some - -- string constants: - - BEI_Name_Header : constant String := "raised "; - BEI_Msg_Header : constant String := " : "; - BEI_PID_Header : constant String := "PID: "; - - procedure Append_Info_Basic_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - Name : String (1 .. Exception_Name_Length (X)); - -- Buffer in which to fetch the exception name, in order to check - -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. - - Name_Ptr : Natural := Name'First - 1; - - begin - -- Output exception name and message except for _ABORT_SIGNAL, where - -- these two lines are omitted. - - Append_Info_Exception_Name (X, Name, Name_Ptr); - - if Name (Name'First) /= '_' then - Append_Info_String (BEI_Name_Header, Info, Ptr); - Append_Info_String (Name, Info, Ptr); - - if Exception_Message_Length (X) /= 0 then - Append_Info_String (BEI_Msg_Header, Info, Ptr); - Append_Info_Exception_Message (X, Info, Ptr); - end if; - - Append_Info_NL (Info, Ptr); - end if; - - -- Output PID line if nonzero - - if X.Pid /= 0 then - Append_Info_String (BEI_PID_Header, Info, Ptr); - Append_Info_Nat (X.Pid, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - end Append_Info_Basic_Exception_Information; - - --------------------------- - -- Append_Info_Character -- - --------------------------- - - procedure Append_Info_Character - (C : Character; - Info : in out String; - Ptr : in out Natural) - is - begin - if Info'Length = 0 then - To_Stderr (C); - elsif Ptr < Info'Last then - Ptr := Ptr + 1; - Info (Ptr) := C; - end if; - end Append_Info_Character; - - ----------------------------------- - -- Append_Info_Exception_Message -- - ----------------------------------- - - procedure Append_Info_Exception_Message - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - if X.Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Message_Length (X); - Msg : constant String (1 .. Len) := X.Msg (1 .. Len); - begin - Append_Info_String (Msg, Info, Ptr); - end; - end Append_Info_Exception_Message; - - -------------------------------- - -- Append_Info_Exception_Name -- - -------------------------------- - - procedure Append_Info_Exception_Name - (Id : Exception_Id; - Info : in out String; - Ptr : in out Natural) - is - begin - if Id = Null_Id then - raise Constraint_Error; - end if; - - declare - Len : constant Natural := Exception_Name_Length (Id); - Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); - begin - Append_Info_String (Name, Info, Ptr); - end; - end Append_Info_Exception_Name; - - procedure Append_Info_Exception_Name - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Exception_Name (X.Id, Info, Ptr); - end Append_Info_Exception_Name; - - ------------------------------ - -- Exception_Info_Maxlength -- - ------------------------------ - - function Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural - is - begin - return - Basic_Exception_Info_Maxlength (X) - + Untailored_Exception_Traceback_Maxlength (X); - end Exception_Info_Maxlength; - - --------------------- - -- Append_Info_Nat -- - --------------------- - - procedure Append_Info_Nat - (N : Natural; - Info : in out String; - Ptr : in out Natural) - is - begin - if N > 9 then - Append_Info_Nat (N / 10, Info, Ptr); - end if; - - Append_Info_Character - (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr); - end Append_Info_Nat; - - -------------------- - -- Append_Info_NL -- - -------------------- - - procedure Append_Info_NL - (Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Character (ASCII.LF, Info, Ptr); - end Append_Info_NL; - - ------------------------ - -- Append_Info_String -- - ------------------------ - - procedure Append_Info_String - (S : String; - Info : in out String; - Ptr : in out Natural) - is - begin - if Info'Length = 0 then - To_Stderr (S); - else - declare - Last : constant Natural := - Integer'Min (Ptr + S'Length, Info'Last); - begin - Info (Ptr + 1 .. Last) := S; - Ptr := Last; - end; - end if; - end Append_Info_String; - - -------------------------------------------------- - -- Append_Info_Untailored_Exception_Information -- - -------------------------------------------------- - - procedure Append_Info_Untailored_Exception_Information - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - begin - Append_Info_Basic_Exception_Information (X, Info, Ptr); - Append_Info_Untailored_Exception_Traceback (X, Info, Ptr); - end Append_Info_Untailored_Exception_Information; - - ------------------------------------------------ - -- Append_Info_Untailored_Exception_Traceback -- - ------------------------------------------------ - - -- As for Basic_Exception_Information: - - BETB_Header : constant String := "Call stack traceback locations:"; - LDAD_Header : constant String := "Load address: "; - - procedure Append_Info_Untailored_Exception_Traceback - (X : Exception_Occurrence; - Info : in out String; - Ptr : in out Natural) - is - Load_Address : Address; - - begin - if X.Num_Tracebacks = 0 then - return; - end if; - - -- The executable load address line - - Load_Address := Get_Executable_Load_Address; - - if Load_Address /= Null_Address then - Append_Info_String (LDAD_Header, Info, Ptr); - Append_Info_Address (Load_Address, Info, Ptr); - Append_Info_NL (Info, Ptr); - end if; - - -- The traceback lines - - Append_Info_String (BETB_Header, Info, Ptr); - Append_Info_NL (Info, Ptr); - - for J in 1 .. X.Num_Tracebacks loop - Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr); - exit when J = X.Num_Tracebacks; - Append_Info_Character (' ', Info, Ptr); - end loop; - - Append_Info_NL (Info, Ptr); - end Append_Info_Untailored_Exception_Traceback; - - ------------------------------------------- - -- Basic_Exception_Information_Maxlength -- - ------------------------------------------- - - function Basic_Exception_Info_Maxlength - (X : Exception_Occurrence) return Natural - is - begin - return - BEI_Name_Header'Length + Exception_Name_Length (X) - + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 - + BEI_PID_Header'Length + 15; - end Basic_Exception_Info_Maxlength; - - --------------------------- - -- Exception_Information -- - --------------------------- - - function Exception_Information (X : Exception_Occurrence) return String is - -- The tailored exception information is the basic information - -- associated with the tailored call chain backtrace. - - Tback_Info : constant String := Tailored_Exception_Traceback (X); - Tback_Len : constant Natural := Tback_Info'Length; - - Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); - Ptr : Natural := Info'First - 1; - - begin - Append_Info_Basic_Exception_Information (X, Info, Ptr); - Append_Info_String (Tback_Info, Info, Ptr); - return Info (Info'First .. Ptr); - end Exception_Information; - - ------------------------------ - -- Exception_Message_Length -- - ------------------------------ - - function Exception_Message_Length - (X : Exception_Occurrence) return Natural - is - begin - return X.Msg_Length; - end Exception_Message_Length; - - --------------------------- - -- Exception_Name_Length -- - --------------------------- - - function Exception_Name_Length (Id : Exception_Id) return Natural is - begin - -- What is stored in the internal Name buffer includes a terminating - -- null character that we never care about. - - return Id.Name_Length - 1; - end Exception_Name_Length; - - function Exception_Name_Length (X : Exception_Occurrence) return Natural is - begin - return Exception_Name_Length (X.Id); - end Exception_Name_Length; - - ------------------------------- - -- Untailored_Exception_Traceback -- - ------------------------------- - - function Untailored_Exception_Traceback - (X : Exception_Occurrence) return String - is - Info : aliased String - (1 .. Untailored_Exception_Traceback_Maxlength (X)); - Ptr : Natural := Info'First - 1; - begin - Append_Info_Untailored_Exception_Traceback (X, Info, Ptr); - return Info (Info'First .. Ptr); - end Untailored_Exception_Traceback; - - -------------------------------------- - -- Untailored_Exception_Information -- - -------------------------------------- - - function Untailored_Exception_Information - (X : Exception_Occurrence) return String - is - Info : String (1 .. Exception_Info_Maxlength (X)); - Ptr : Natural := Info'First - 1; - begin - Append_Info_Untailored_Exception_Information (X, Info, Ptr); - return Info (Info'First .. Ptr); - end Untailored_Exception_Information; - - ------------------------- - -- Set_Exception_C_Msg -- - ------------------------- - - procedure Set_Exception_C_Msg - (Excep : EOA; - Id : Exception_Id; - Msg1 : System.Address; - Line : Integer := 0; - Column : Integer := 0; - Msg2 : System.Address := System.Null_Address) - is - Remind : Integer; - Ptr : Natural; - - procedure Append_Number (Number : Integer); - -- Append given number to Excep.Msg - - ------------------- - -- Append_Number -- - ------------------- - - procedure Append_Number (Number : Integer) is - Val : Integer; - Size : Integer; - - begin - if Number <= 0 then - return; - end if; - - -- Compute the number of needed characters - - Size := 1; - Val := Number; - while Val > 0 loop - Val := Val / 10; - Size := Size + 1; - end loop; - - -- If enough characters are available, put the line number - - if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then - Excep.Msg (Excep.Msg_Length + 1) := ':'; - Excep.Msg_Length := Excep.Msg_Length + Size; - - Val := Number; - Size := 0; - while Val > 0 loop - Remind := Val rem 10; - Val := Val / 10; - Excep.Msg (Excep.Msg_Length - Size) := - Character'Val (Remind + Character'Pos ('0')); - Size := Size + 1; - end loop; - end if; - end Append_Number; - - -- Start of processing for Set_Exception_C_Msg - - begin - Excep.Exception_Raised := False; - Excep.Id := Id; - Excep.Num_Tracebacks := 0; - Excep.Pid := Local_Partition_ID; - Excep.Msg_Length := 0; - - while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL - and then Excep.Msg_Length < Exception_Msg_Max_Length - loop - Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length); - end loop; - - Append_Number (Line); - Append_Number (Column); - - -- Append second message if present - - if Msg2 /= System.Null_Address - and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length - then - Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := ' '; - - Ptr := 1; - while To_Ptr (Msg2) (Ptr) /= ASCII.NUL - and then Excep.Msg_Length < Exception_Msg_Max_Length - loop - Excep.Msg_Length := Excep.Msg_Length + 1; - Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr); - Ptr := Ptr + 1; - end loop; - end if; - end Set_Exception_C_Msg; - - ----------------------- - -- Set_Exception_Msg -- - ----------------------- - - procedure Set_Exception_Msg - (Excep : EOA; - Id : Exception_Id; - Message : String) - is - Len : constant Natural := - Natural'Min (Message'Length, Exception_Msg_Max_Length); - First : constant Integer := Message'First; - begin - Excep.Exception_Raised := False; - Excep.Msg_Length := Len; - Excep.Msg (1 .. Len) := Message (First .. First + Len - 1); - Excep.Id := Id; - Excep.Num_Tracebacks := 0; - Excep.Pid := Local_Partition_ID; - end Set_Exception_Msg; - - ---------------------------------- - -- Tailored_Exception_Traceback -- - ---------------------------------- - - function Tailored_Exception_Traceback - (X : Exception_Occurrence) return String - is - -- We reference the decorator *wrapper* here and not the decorator - -- itself. The purpose of the local variable Wrapper is to prevent a - -- potential race condition in the code below. The atomicity of this - -- assignment is enforced by pragma Atomic in System.Soft_Links. - - -- The potential race condition here, if no local variable was used, - -- relates to the test upon the wrapper's value and the call, which - -- are not performed atomically. With the local variable, potential - -- changes of the wrapper's global value between the test and the - -- call become inoffensive. - - Wrapper : constant Traceback_Decorator_Wrapper_Call := - Traceback_Decorator_Wrapper; - - begin - if Wrapper = null then - return Untailored_Exception_Traceback (X); - else - return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); - end if; - end Tailored_Exception_Traceback; - - ---------------------------------------------- - -- Untailored_Exception_Traceback_Maxlength -- - ---------------------------------------------- - - function Untailored_Exception_Traceback_Maxlength - (X : Exception_Occurrence) return Natural - is - Space_Per_Address : constant := 2 + 16 + 1; - -- Space for "0x" + HHHHHHHHHHHHHHHH + " " - begin - return - LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 + - X.Num_Tracebacks * Space_Per_Address + 1; - end Untailored_Exception_Traceback_Maxlength; - -end Exception_Data; diff --git a/gcc/ada/a-exexpr.adb b/gcc/ada/a-exexpr.adb deleted file mode 100644 index 91fb5f5..0000000 --- a/gcc/ada/a-exexpr.adb +++ /dev/null @@ -1,439 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the version using the GCC EH mechanism - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -with System.Storage_Elements; use System.Storage_Elements; -with System.Exceptions.Machine; use System.Exceptions.Machine; - -separate (Ada.Exceptions) -package body Exception_Propagation is - - use Exception_Traces; - - Foreign_Exception : aliased System.Standard_Library.Exception_Data; - pragma Import (Ada, Foreign_Exception, - "system__exceptions__foreign_exception"); - -- Id for foreign exceptions - - -------------------------------------------------------------- - -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- - -------------------------------------------------------------- - - procedure GNAT_GCC_Exception_Cleanup - (Reason : Unwind_Reason_Code; - Excep : not null GNAT_GCC_Exception_Access); - pragma Convention (C, GNAT_GCC_Exception_Cleanup); - -- Procedure called when a GNAT GCC exception is free. - - procedure Propagate_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access); - pragma No_Return (Propagate_GCC_Exception); - -- Propagate a GCC exception - - procedure Reraise_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access); - pragma No_Return (Reraise_GCC_Exception); - pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); - -- Called to implement raise without exception, ie reraise. Called - -- directly from gigi. - - function Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access) return EOA; - pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); - -- Write Get_Current_Excep.all from GCC_Exception. Called by the - -- personality routine. - - procedure Unhandled_Except_Handler - (GCC_Exception : not null GCC_Exception_Access); - pragma No_Return (Unhandled_Except_Handler); - pragma Export (C, Unhandled_Except_Handler, - "__gnat_unhandled_except_handler"); - -- Called for handle unhandled exceptions, ie the last chance handler - -- on platforms (such as SEH) that never returns after throwing an - -- exception. Called directly by gigi. - - function CleanupUnwind_Handler - (UW_Version : Integer; - UW_Phases : Unwind_Action; - UW_Eclass : Exception_Class; - UW_Exception : not null GCC_Exception_Access; - UW_Context : System.Address; - UW_Argument : System.Address) return Unwind_Reason_Code; - pragma Import (C, CleanupUnwind_Handler, - "__gnat_cleanupunwind_handler"); - -- Hook called at each step of the forced unwinding we perform to trigger - -- cleanups found during the propagation of an unhandled exception. - - -- GCC runtime functions used. These are C non-void functions, actually, - -- but we ignore the return values. See raise.c as to why we are using - -- __gnat stubs for these. - - procedure Unwind_RaiseException - (UW_Exception : not null GCC_Exception_Access); - pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); - - procedure Unwind_ForcedUnwind - (UW_Exception : not null GCC_Exception_Access; - UW_Handler : System.Address; - UW_Argument : System.Address); - pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); - - procedure Set_Exception_Parameter - (Excep : EOA; - GCC_Exception : not null GCC_Exception_Access); - pragma Export - (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); - -- Called inserted by gigi to set the exception choice parameter from the - -- gcc occurrence. - - procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); - -- Utility routine to initialize occurrence Excep from a foreign exception - -- whose machine occurrence is Mo. The message is empty, the backtrace - -- is empty too and the exception identity is Foreign_Exception. - - -- Hooks called when entering/leaving an exception handler for a given - -- occurrence, aimed at handling the stack of active occurrences. The - -- calls are generated by gigi in tree_transform/N_Exception_Handler. - - procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); - pragma Export (C, Begin_Handler, "__gnat_begin_handler"); - - procedure End_Handler (GCC_Exception : GCC_Exception_Access); - pragma Export (C, End_Handler, "__gnat_end_handler"); - - -------------------------------------------------------------------- - -- Accessors to Basic Components of a GNAT Exception Data Pointer -- - -------------------------------------------------------------------- - - -- As of today, these are only used by the C implementation of the GCC - -- propagation personality routine to avoid having to rely on a C - -- counterpart of the whole exception_data structure, which is both - -- painful and error prone. These subprograms could be moved to a more - -- widely visible location if need be. - - function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean; - pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); - pragma Warnings (Off, Is_Handled_By_Others); - - function Language_For (E : Exception_Data_Ptr) return Character; - pragma Export (C, Language_For, "__gnat_language_for"); - - function Foreign_Data_For (E : Exception_Data_Ptr) return Address; - pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for"); - - function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) - return Exception_Id; - pragma Export (C, EID_For, "__gnat_eid_for"); - - --------------------------------------------------------------------------- - -- Objects to materialize "others" and "all others" in the GCC EH tables -- - --------------------------------------------------------------------------- - - -- Currently, these only have their address taken and compared so there is - -- no real point having whole exception data blocks allocated. Note that - -- there are corresponding declarations in gigi (trans.c) which must be - -- kept properly synchronized. - - Others_Value : constant Character := 'O'; - pragma Export (C, Others_Value, "__gnat_others_value"); - - All_Others_Value : constant Character := 'A'; - pragma Export (C, All_Others_Value, "__gnat_all_others_value"); - - Unhandled_Others_Value : constant Character := 'U'; - pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); - -- Special choice (emitted by gigi) to catch and notify unhandled - -- exceptions on targets which always handle exceptions (such as SEH). - -- The handler will simply call Unhandled_Except_Handler. - - ------------------------- - -- Allocate_Occurrence -- - ------------------------- - - function Allocate_Occurrence return EOA is - Res : GNAT_GCC_Exception_Access; - - begin - Res := New_Occurrence; - Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address; - Res.Occurrence.Machine_Occurrence := Res.all'Address; - - return Res.Occurrence'Access; - end Allocate_Occurrence; - - -------------------------------- - -- GNAT_GCC_Exception_Cleanup -- - -------------------------------- - - procedure GNAT_GCC_Exception_Cleanup - (Reason : Unwind_Reason_Code; - Excep : not null GNAT_GCC_Exception_Access) - is - pragma Unreferenced (Reason); - - procedure Free is new Unchecked_Deallocation - (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); - - Copy : GNAT_GCC_Exception_Access := Excep; - - begin - -- Simply free the memory - - Free (Copy); - end GNAT_GCC_Exception_Cleanup; - - ---------------------------- - -- Set_Foreign_Occurrence -- - ---------------------------- - - procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is - begin - Excep.all := ( - Id => Foreign_Exception'Access, - Machine_Occurrence => Mo, - Msg => <>, - Msg_Length => 0, - Exception_Raised => True, - Pid => Local_Partition_ID, - Num_Tracebacks => 0, - Tracebacks => <>); - end Set_Foreign_Occurrence; - - ------------------------- - -- Setup_Current_Excep -- - ------------------------- - - function Setup_Current_Excep - (GCC_Exception : not null GCC_Exception_Access) return EOA - is - Excep : constant EOA := Get_Current_Excep.all; - - begin - -- Setup the exception occurrence - - if GCC_Exception.Class = GNAT_Exception_Class then - - -- From the GCC exception - - declare - GNAT_Occurrence : constant GNAT_GCC_Exception_Access := - To_GNAT_GCC_Exception (GCC_Exception); - begin - Excep.all := GNAT_Occurrence.Occurrence; - return GNAT_Occurrence.Occurrence'Access; - end; - - else - -- A default one - - Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); - - return Excep; - end if; - end Setup_Current_Excep; - - ------------------- - -- Begin_Handler -- - ------------------- - - procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is - pragma Unreferenced (GCC_Exception); - begin - null; - end Begin_Handler; - - ----------------- - -- End_Handler -- - ----------------- - - procedure End_Handler (GCC_Exception : GCC_Exception_Access) is - begin - if GCC_Exception /= null then - - -- The exception might have been reraised, in this case the cleanup - -- mustn't be called. - - Unwind_DeleteException (GCC_Exception); - end if; - end End_Handler; - - ----------------------------- - -- Reraise_GCC_Exception -- - ----------------------------- - - procedure Reraise_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access) - is - begin - -- Simply propagate it - - Propagate_GCC_Exception (GCC_Exception); - end Reraise_GCC_Exception; - - ----------------------------- - -- Propagate_GCC_Exception -- - ----------------------------- - - -- Call Unwind_RaiseException to actually throw, taking care of handling - -- the two phase scheme it implements. - - procedure Propagate_GCC_Exception - (GCC_Exception : not null GCC_Exception_Access) - is - Excep : EOA; - - begin - -- Perform a standard raise first. If a regular handler is found, it - -- will be entered after all the intermediate cleanups have run. If - -- there is no regular handler, it will return. - - Unwind_RaiseException (GCC_Exception); - - -- If we get here we know the exception is not handled, as otherwise - -- Unwind_RaiseException arranges for the handler to be entered. Take - -- the necessary steps to enable the debugger to gain control while the - -- stack is still intact. - - Excep := Setup_Current_Excep (GCC_Exception); - Notify_Unhandled_Exception (Excep); - - -- Now, un a forced unwind to trigger cleanups. Control should not - -- resume there, if there are cleanups and in any cases as the - -- unwinding hook calls Unhandled_Exception_Terminate when end of - -- stack is reached. - - Unwind_ForcedUnwind - (GCC_Exception, - CleanupUnwind_Handler'Address, - System.Null_Address); - - -- We get here in case of error. The debugger has been notified before - -- the second step above. - - Unhandled_Except_Handler (GCC_Exception); - end Propagate_GCC_Exception; - - ------------------------- - -- Propagate_Exception -- - ------------------------- - - procedure Propagate_Exception (Excep : EOA) is - begin - Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); - end Propagate_Exception; - - ----------------------------- - -- Set_Exception_Parameter -- - ----------------------------- - - procedure Set_Exception_Parameter - (Excep : EOA; - GCC_Exception : not null GCC_Exception_Access) - is - begin - -- Setup the exception occurrence - - if GCC_Exception.Class = GNAT_Exception_Class then - - -- From the GCC exception - - declare - GNAT_Occurrence : constant GNAT_GCC_Exception_Access := - To_GNAT_GCC_Exception (GCC_Exception); - begin - Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence); - end; - - else - -- A default one - - Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); - end if; - end Set_Exception_Parameter; - - ------------------------------ - -- Unhandled_Except_Handler -- - ------------------------------ - - procedure Unhandled_Except_Handler - (GCC_Exception : not null GCC_Exception_Access) - is - Excep : EOA; - begin - Excep := Setup_Current_Excep (GCC_Exception); - Unhandled_Exception_Terminate (Excep); - end Unhandled_Except_Handler; - - ------------- - -- EID_For -- - ------------- - - function EID_For - (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id - is - begin - return GNAT_Exception.Occurrence.Id; - end EID_For; - - ---------------------- - -- Foreign_Data_For -- - ---------------------- - - function Foreign_Data_For - (E : SSL.Exception_Data_Ptr) return Address - is - begin - return E.Foreign_Data; - end Foreign_Data_For; - - -------------------------- - -- Is_Handled_By_Others -- - -------------------------- - - function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is - begin - return not E.all.Not_Handled_By_Others; - end Is_Handled_By_Others; - - ------------------ - -- Language_For -- - ------------------ - - function Language_For (E : SSL.Exception_Data_Ptr) return Character is - begin - return E.all.Lang; - end Language_For; - -end Exception_Propagation; diff --git a/gcc/ada/a-exextr.adb b/gcc/ada/a-exextr.adb deleted file mode 100644 index 2a6f82b..0000000 --- a/gcc/ada/a-exextr.adb +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- ADA.EXCEPTIONS.EXCEPTION_TRACES -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -pragma Warnings (Off); -with Ada.Exceptions.Last_Chance_Handler; -pragma Warnings (On); --- Bring last chance handler into closure - -separate (Ada.Exceptions) -package body Exception_Traces is - - Nline : constant String := String'(1 => ASCII.LF); - -- Convenient shortcut - - type Exception_Action is access procedure (E : Exception_Occurrence); - Global_Action : Exception_Action := null; - pragma Export - (Ada, Global_Action, "__gnat_exception_actions_global_action"); - -- Global action, executed whenever an exception is raised. Changing the - -- export name must be coordinated with code in g-excact.adb. - - Raise_Hook_Initialized : Boolean := False; - pragma Export - (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized"); - - procedure Last_Chance_Handler (Except : Exception_Occurrence); - pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler"); - pragma No_Return (Last_Chance_Handler); - -- Users can replace the default version of this routine, - -- Ada.Exceptions.Last_Chance_Handler. - - function To_Action is new Ada.Unchecked_Conversion - (Raise_Action, Exception_Action); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean); - -- Factorizes the common processing for Notify_Handled_Exception and - -- Notify_Unhandled_Exception. Is_Unhandled is set to True only in the - -- latter case because Notify_Handled_Exception may be called for an - -- actually unhandled occurrence in the Front-End-SJLJ case. - - ---------------------- - -- Notify_Exception -- - ---------------------- - - procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is - begin - -- Output the exception information required by the Exception_Trace - -- configuration. Take care not to output information about internal - -- exceptions. - - if not Excep.Id.Not_Handled_By_Others - and then - (Exception_Trace = Every_Raise - or else - (Is_Unhandled - and then - (Exception_Trace = Unhandled_Raise - or else Exception_Trace = Unhandled_Raise_In_Main))) - then - -- Exception trace messages need to be protected when several tasks - -- can issue them at the same time. - - Lock_Task.all; - To_Stderr (Nline); - - if Exception_Trace /= Unhandled_Raise_In_Main then - if Is_Unhandled then - To_Stderr ("Unhandled "); - end if; - - To_Stderr ("Exception raised"); - To_Stderr (Nline); - end if; - - To_Stderr (Exception_Information (Excep.all)); - Unlock_Task.all; - end if; - - -- Call the user-specific actions - -- ??? We should presumably look at the reraise status here. - - if Raise_Hook_Initialized - and then Exception_Data_Ptr (Excep.Id).Raise_Hook /= null - then - To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all); - end if; - - if Global_Action /= null then - Global_Action (Excep.all); - end if; - end Notify_Exception; - - ------------------------------ - -- Notify_Handled_Exception -- - ------------------------------ - - procedure Notify_Handled_Exception (Excep : EOA) is - begin - Notify_Exception (Excep, Is_Unhandled => False); - end Notify_Handled_Exception; - - -------------------------------- - -- Notify_Unhandled_Exception -- - -------------------------------- - - procedure Notify_Unhandled_Exception (Excep : EOA) is - begin - -- Check whether there is any termination handler to be executed for - -- the environment task, and execute it if needed. Here we handle both - -- the Abnormal and Unhandled_Exception task termination. Normal - -- task termination routine is executed elsewhere (either in the - -- Task_Wrapper or in the Adafinal routine for the environment task). - - Task_Termination_Handler.all (Excep.all); - - Notify_Exception (Excep, Is_Unhandled => True); - Debug_Unhandled_Exception (SSL.Exception_Data_Ptr (Excep.Id)); - end Notify_Unhandled_Exception; - - ----------------------------------- - -- Unhandled_Exception_Terminate -- - ----------------------------------- - - procedure Unhandled_Exception_Terminate (Excep : EOA) is - Occ : Exception_Occurrence; - -- This occurrence will be used to display a message after finalization. - -- It is necessary to save a copy here, or else the designated value - -- could be overwritten if an exception is raised during finalization - -- (even if that exception is caught). The occurrence is saved on the - -- stack to avoid dynamic allocation (if this exception is due to lack - -- of space in the heap, we therefore avoid a second failure). We assume - -- that there is enough room on the stack however. - - begin - Save_Occurrence (Occ, Excep.all); - Last_Chance_Handler (Occ); - end Unhandled_Exception_Terminate; - - ------------------------------------ - -- Handling GNAT.Exception_Traces -- - ------------------------------------ - - -- The bulk of exception traces output is centralized in Notify_Exception, - -- for both the Handled and Unhandled cases. Extra task specific output is - -- triggered in the task wrapper for unhandled occurrences in tasks. It is - -- not performed in this unit to avoid dependencies on the tasking units - -- here. - - -- We used to rely on the output performed by Unhanded_Exception_Terminate - -- for the case of an unhandled occurrence in the environment thread, and - -- the task wrapper was responsible for the whole output in the tasking - -- case. - - -- This initial scheme had a drawback: the output from Terminate only - -- occurs after finalization is done, which means possibly never if some - -- tasks keep hanging around. - - -- The first "presumably obvious" fix consists in moving the Terminate - -- output before the finalization. It has not been retained because it - -- introduces annoying changes in output orders when the finalization - -- itself issues outputs, this also in "regular" cases not resorting to - -- Exception_Traces. - - -- Today's solution has the advantage of simplicity and better isolates - -- the Exception_Traces machinery. - -end Exception_Traces; diff --git a/gcc/ada/a-exstat.adb b/gcc/ada/a-exstat.adb deleted file mode 100644 index 1ff9481..0000000 --- a/gcc/ada/a-exstat.adb +++ /dev/null @@ -1,266 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Warnings (Off); --- Allow withing of non-Preelaborated units in Ada 2005 mode where this --- package will be categorized as Preelaborate. See AI-362 for details. --- It is safe in the context of the run-time to violate the rules. - -with System.Exception_Table; use System.Exception_Table; -with System.Storage_Elements; use System.Storage_Elements; - -pragma Warnings (On); - -separate (Ada.Exceptions) -package body Stream_Attributes is - - ------------------- - -- EId_To_String -- - ------------------- - - function EId_To_String (X : Exception_Id) return String is - begin - if X = Null_Id then - return ""; - else - return Exception_Name (X); - end if; - end EId_To_String; - - ------------------ - -- EO_To_String -- - ------------------ - - -- We use the null string to represent the null occurrence, otherwise we - -- output the Untailored_Exception_Information string for the occurrence. - - function EO_To_String (X : Exception_Occurrence) return String is - begin - if X.Id = Null_Id then - return ""; - else - return Exception_Data.Untailored_Exception_Information (X); - end if; - end EO_To_String; - - ------------------- - -- String_To_EId -- - ------------------- - - function String_To_EId (S : String) return Exception_Id is - begin - if S = "" then - return Null_Id; - else - return Exception_Id (Internal_Exception (S)); - end if; - end String_To_EId; - - ------------------ - -- String_To_EO -- - ------------------ - - function String_To_EO (S : String) return Exception_Occurrence is - From : Natural; - To : Integer; - - X : aliased Exception_Occurrence; - -- This is the exception occurrence we will create - - procedure Bad_EO; - pragma No_Return (Bad_EO); - -- Signal bad exception occurrence string - - procedure Next_String; - -- On entry, To points to last character of previous line of the - -- message, terminated by LF. On return, From .. To are set to - -- specify the next string, or From > To if there are no more lines. - - procedure Bad_EO is - begin - Raise_Exception - (Program_Error'Identity, - "bad exception occurrence in stream input"); - - -- The following junk raise of Program_Error is required because - -- this is a No_Return procedure, and unfortunately Raise_Exception - -- can return (this particular call can't, but the back end is not - -- clever enough to know that). - - raise Program_Error; - end Bad_EO; - - procedure Next_String is - begin - From := To + 2; - - if From < S'Last then - To := From + 1; - - while To < S'Last - 1 loop - if To >= S'Last then - Bad_EO; - elsif S (To + 1) = ASCII.LF then - exit; - else - To := To + 1; - end if; - end loop; - end if; - end Next_String; - - -- Start of processing for String_To_EO - - begin - if S = "" then - return Null_Occurrence; - end if; - - To := S'First - 2; - Next_String; - - if S (From .. From + 6) /= "raised " then - Bad_EO; - end if; - - declare - Name_Start : constant Positive := From + 7; - begin - From := Name_Start + 1; - - while From < To and then S (From) /= ' ' loop - From := From + 1; - end loop; - - X.Id := - Exception_Id (Internal_Exception (S (Name_Start .. From - 1))); - end; - - if From <= To then - if S (From .. From + 2) /= " : " then - Bad_EO; - end if; - - X.Msg_Length := To - From - 2; - X.Msg (1 .. X.Msg_Length) := S (From + 3 .. To); - - else - X.Msg_Length := 0; - end if; - - Next_String; - X.Pid := 0; - - if From <= To and then S (From) = 'P' then - if S (From .. From + 3) /= "PID:" then - Bad_EO; - end if; - - From := From + 5; -- skip past PID: space - - while From <= To loop - X.Pid := X.Pid * 10 + - (Character'Pos (S (From)) - Character'Pos ('0')); - From := From + 1; - end loop; - - Next_String; - end if; - - X.Num_Tracebacks := 0; - - if From <= To then - if S (From .. To) /= "Call stack traceback locations:" then - Bad_EO; - end if; - - Next_String; - loop - exit when From > To; - - declare - Ch : Character; - C : Integer_Address; - N : Integer_Address; - - begin - if S (From) /= '0' - or else S (From + 1) /= 'x' - then - Bad_EO; - else - From := From + 2; - end if; - - C := 0; - while From <= To loop - Ch := S (From); - - if Ch in '0' .. '9' then - N := - Character'Pos (S (From)) - Character'Pos ('0'); - - elsif Ch in 'a' .. 'f' then - N := - Character'Pos (S (From)) - Character'Pos ('a') + 10; - - elsif Ch = ' ' then - From := From + 1; - exit; - - else - Bad_EO; - end if; - - C := C * 16 + N; - - From := From + 1; - end loop; - - if X.Num_Tracebacks = Max_Tracebacks then - Bad_EO; - end if; - - X.Num_Tracebacks := X.Num_Tracebacks + 1; - X.Tracebacks (X.Num_Tracebacks) := - TBE.TB_Entry_For (To_Address (C)); - end; - end loop; - end if; - - -- If an exception was converted to a string, it must have - -- already been raised, so flag it accordingly and we are done. - - X.Exception_Raised := True; - return X; - end String_To_EO; - -end Stream_Attributes; diff --git a/gcc/ada/a-finali.adb b/gcc/ada/a-finali.adb deleted file mode 100644 index 3d6e45b..0000000 --- a/gcc/ada/a-finali.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . F I N A L I Z A T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body. We provide a dummy file containing a --- No_Body pragma so that previous versions of the body (which did exist) will --- not interfere. - -pragma No_Body; diff --git a/gcc/ada/a-finali.ads b/gcc/ada/a-finali.ads deleted file mode 100644 index a1f420e..0000000 --- a/gcc/ada/a-finali.ads +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . F I N A L I Z A T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Warnings (Off); -with System.Finalization_Root; -pragma Warnings (On); - -package Ada.Finalization is - pragma Pure; - - type Controlled is abstract tagged private; - pragma Preelaborable_Initialization (Controlled); - - procedure Initialize (Object : in out Controlled) is null; - procedure Adjust (Object : in out Controlled) is null; - procedure Finalize (Object : in out Controlled) is null; - - type Limited_Controlled is abstract tagged limited private; - pragma Preelaborable_Initialization (Limited_Controlled); - - procedure Initialize (Object : in out Limited_Controlled) is null; - procedure Finalize (Object : in out Limited_Controlled) is null; - -private - package SFR renames System.Finalization_Root; - - type Controlled is abstract new SFR.Root_Controlled with null record; - - -- In order to simplify the implementation, the mechanism in Process_Full_ - -- View ensures that the full view is limited even though the parent type - -- is not. - - type Limited_Controlled is - abstract new SFR.Root_Controlled with null record; - -end Ada.Finalization; diff --git a/gcc/ada/a-flteio.ads b/gcc/ada/a-flteio.ads deleted file mode 100644 index caf4e9b..0000000 --- a/gcc/ada/a-flteio.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . F L O A T _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -pragma Elaborate_All (Ada.Text_IO); - -package Ada.Float_Text_IO is - new Ada.Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-fwteio.ads b/gcc/ada/a-fwteio.ads deleted file mode 100644 index e87e08a..0000000 --- a/gcc/ada/a-fwteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . F L O A T _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Float_Wide_Text_IO is - new Ada.Wide_Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-fzteio.ads b/gcc/ada/a-fzteio.ads deleted file mode 100644 index 81bf7b2..0000000 --- a/gcc/ada/a-fzteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . F L O A T _ W I D E _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Float_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Float_IO (Float); diff --git a/gcc/ada/a-inteio.ads b/gcc/ada/a-inteio.ads deleted file mode 100644 index b2b3867..0000000 --- a/gcc/ada/a-inteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . I N T E G E R _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Integer_Text_IO is - new Ada.Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-intnam-dragonfly.ads b/gcc/ada/a-intnam-dragonfly.ads deleted file mode 100644 index 1de9735..0000000 --- a/gcc/ada/a-intnam-dragonfly.ads +++ /dev/null @@ -1,136 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT 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-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the DragonFly BSD THREADS version of this package - -with System.OS_Interface; - -package Ada.Interrupts.Names is - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - -- 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 - - 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 - - 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 - - SIGURG : constant Interrupt_ID := - System.OS_Interface.SIGURG; -- urgent condition on IO channel - - 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 - - SIGCHLD : constant Interrupt_ID := - System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD - - SIGCLD : constant Interrupt_ID := - System.OS_Interface.SIGCLD; -- child status change - - SIGTTIN : constant Interrupt_ID := - System.OS_Interface.SIGTTIN; -- background tty read attempted - - SIGTTOU : constant Interrupt_ID := - System.OS_Interface.SIGTTOU; -- background tty write attempted - - SIGIO : constant Interrupt_ID := -- input/output possible, - System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) - - 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 - - SIGUSR1 : constant Interrupt_ID := - System.OS_Interface.SIGUSR1; -- user defined signal 1 - - SIGUSR2 : constant Interrupt_ID := - System.OS_Interface.SIGUSR2; -- user defined signal 2 - -end Ada.Interrupts.Names; diff --git a/gcc/ada/a-intnam-rtems.ads b/gcc/ada/a-intnam-rtems.ads deleted file mode 100644 index 43a5281..0000000 --- a/gcc/ada/a-intnam-rtems.ads +++ /dev/null @@ -1,114 +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-2009 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- --- The GNARL files that were developed for RTEMS are maintained by On-Line -- --- Applications Research Corporation (http://www.oarcorp.com) in coopera- -- --- tion with Ada Core Technologies Inc. and Florida State University. -- --- -- ------------------------------------------------------------------------------- - --- This is a RTEMS version of this package --- --- The following signals are reserved by the run time: --- --- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, --- SIGALRM, SIGEMT, 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) - - 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 - -end Ada.Interrupts.Names; diff --git a/gcc/ada/a-ioexce.ads b/gcc/ada/a-ioexce.ads deleted file mode 100644 index 7fec393..0000000 --- a/gcc/ada/a-ioexce.ads +++ /dev/null @@ -1,30 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . I O _ E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package Ada.IO_Exceptions is - pragma Pure; - - Status_Error : exception; - Mode_Error : exception; - Name_Error : exception; - Use_Error : exception; - Device_Error : exception; - End_Error : exception; - Data_Error : exception; - Layout_Error : exception; - -end Ada.IO_Exceptions; diff --git a/gcc/ada/a-iteint.ads b/gcc/ada/a-iteint.ads deleted file mode 100644 index 8ac9e1a..0000000 --- a/gcc/ada/a-iteint.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . I T E R A T O R . I N T E R F A C E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -generic - type Cursor; - with function Has_Element (Position : Cursor) return Boolean; - pragma Unreferenced (Has_Element); - -package Ada.Iterator_Interfaces is - pragma Pure; - - type Forward_Iterator is limited interface; - - function First - (Object : Forward_Iterator) return Cursor is abstract; - function Next - (Object : Forward_Iterator; - Position : Cursor) return Cursor is abstract; - - type Reversible_Iterator is limited interface and Forward_Iterator; - - function Last - (Object : Reversible_Iterator) return Cursor is abstract; - function Previous - (Object : Reversible_Iterator; - Position : Cursor) return Cursor is abstract; -end Ada.Iterator_Interfaces; diff --git a/gcc/ada/a-iwteio.ads b/gcc/ada/a-iwteio.ads deleted file mode 100644 index dc53046..0000000 --- a/gcc/ada/a-iwteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . I N T E G E R _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Integer_Wide_Text_IO is - new Ada.Wide_Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-izteio.ads b/gcc/ada/a-izteio.ads deleted file mode 100644 index 8eb5466..0000000 --- a/gcc/ada/a-izteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Integer_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/a-lcteio.ads b/gcc/ada/a-lcteio.ads deleted file mode 100644 index f9da97c..0000000 --- a/gcc/ada/a-lcteio.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ C O M P L E X _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Ada 2005 AI-328 - -with Ada.Text_IO.Complex_IO; -with Ada.Numerics.Long_Complex_Types; - -pragma Elaborate_All (Ada.Text_IO.Complex_IO); - -package Ada.Long_Complex_Text_IO is - new Ada.Text_IO.Complex_IO (Ada.Numerics.Long_Complex_Types); diff --git a/gcc/ada/a-lfteio.ads b/gcc/ada/a-lfteio.ads deleted file mode 100644 index 1477047..0000000 --- a/gcc/ada/a-lfteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ F L O A T _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Long_Float_Text_IO is - new Ada.Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-lfwtio.ads b/gcc/ada/a-lfwtio.ads deleted file mode 100644 index 8636141..0000000 --- a/gcc/ada/a-lfwtio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ F L O A T _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Long_Float_Wide_Text_IO is - new Ada.Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-lfztio.ads b/gcc/ada/a-lfztio.ads deleted file mode 100644 index f1719b1..0000000 --- a/gcc/ada/a-lfztio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Long_Float_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/a-liteio.ads b/gcc/ada/a-liteio.ads deleted file mode 100644 index 535f6b0..0000000 --- a/gcc/ada/a-liteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ I N T E G E R _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Long_Integer_Text_IO is - new Ada.Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-liwtio.ads b/gcc/ada/a-liwtio.ads deleted file mode 100644 index 56fad9a..0000000 --- a/gcc/ada/a-liwtio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Long_Integer_Wide_Text_IO is - new Ada.Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-liztio.ads b/gcc/ada/a-liztio.ads deleted file mode 100644 index 100ef0a..0000000 --- a/gcc/ada/a-liztio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Long_Integer_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/a-llctio.ads b/gcc/ada/a-llctio.ads deleted file mode 100644 index 3b53bf7..0000000 --- a/gcc/ada/a-llctio.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ L O N G _ C O M P L E X _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Ada 2005 AI-328 - -with Ada.Text_IO.Complex_IO; -with Ada.Numerics.Long_Long_Complex_Types; - -pragma Elaborate_All (Ada.Text_IO.Complex_IO); - -package Ada.Long_Long_Complex_Text_IO is - new Ada.Text_IO.Complex_IO (Ada.Numerics.Long_Long_Complex_Types); diff --git a/gcc/ada/a-llftio.ads b/gcc/ada/a-llftio.ads deleted file mode 100644 index 589232d..0000000 --- a/gcc/ada/a-llftio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ L O N G _ F L O A T _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Long_Long_Float_Text_IO is - new Ada.Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llfwti.ads b/gcc/ada/a-llfwti.ads deleted file mode 100644 index b26aecd..0000000 --- a/gcc/ada/a-llfwti.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ L O N G _ F L O A T _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Long_Long_Float_Wide_Text_IO is - new Ada.Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llfzti.ads b/gcc/ada/a-llfzti.ads deleted file mode 100644 index 6bc9792..0000000 --- a/gcc/ada/a-llfzti.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.LONG_LONG_FLOAT_WIDE_WIDE_TEXT_IO -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Long_Long_Float_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/a-llitio.ads b/gcc/ada/a-llitio.ads deleted file mode 100644 index e153727..0000000 --- a/gcc/ada/a-llitio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ L O N G _ I N T E G E R _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Long_Long_Integer_Text_IO is - new Ada.Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-lliwti.ads b/gcc/ada/a-lliwti.ads deleted file mode 100644 index 13a0f21..0000000 --- a/gcc/ada/a-lliwti.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Long_Long_Integer_Wide_Text_IO is - new Ada.Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-llizti.ads b/gcc/ada/a-llizti.ads deleted file mode 100644 index 09d3219..0000000 --- a/gcc/ada/a-llizti.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Long_Long_Integer_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/a-locale.adb b/gcc/ada/a-locale.adb deleted file mode 100644 index 60ad079..0000000 --- a/gcc/ada/a-locale.adb +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O C A L E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; - -package body Ada.Locales is - - type Str_4 is new String (1 .. 4); - - -------------- - -- Language -- - -------------- - - function Language return Language_Code is - procedure C_Get_Language_Code (P : Address); - pragma Import (C, C_Get_Language_Code); - F : Str_4; - begin - C_Get_Language_Code (F'Address); - return Language_Code (F (1 .. 3)); - end Language; - - ------------- - -- Country -- - ------------- - - function Country return Country_Code is - procedure C_Get_Country_Code (P : Address); - pragma Import (C, C_Get_Country_Code); - F : Str_4; - begin - C_Get_Country_Code (F'Address); - return Country_Code (F (1 .. 2)); - end Country; - -end Ada.Locales; diff --git a/gcc/ada/a-locale.ads b/gcc/ada/a-locale.ads deleted file mode 100644 index 605ce20..0000000 --- a/gcc/ada/a-locale.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . L O C A L E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Note that this package is currently not implemented on any platform and --- functions Language and Country will always return --- Language_Unknown/Country_Unknown. - -package Ada.Locales is - pragma Preelaborate (Locales); - pragma Remote_Types (Locales); - - type Language_Code is new String (1 .. 3) - with Dynamic_Predicate => - (for all E of Language_Code => E in 'a' .. 'z'); - - type Country_Code is new String (1 .. 2) - with Dynamic_Predicate => - (for all E of Country_Code => E in 'A' .. 'Z'); - - Language_Unknown : constant Language_Code := "und"; - Country_Unknown : constant Country_Code := "ZZ"; - - function Language return Language_Code; - function Country return Country_Code; - -end Ada.Locales; diff --git a/gcc/ada/a-ncelfu.ads b/gcc/ada/a-ncelfu.ads deleted file mode 100644 index e81730f..0000000 --- a/gcc/ada/a-ncelfu.ads +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_COMPLEX.ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; - -package Ada.Numerics.Complex_Elementary_Functions is - new Ada.Numerics.Generic_Complex_Elementary_Functions - (Ada.Numerics.Complex_Types); - -pragma Pure (Ada.Numerics.Complex_Elementary_Functions); diff --git a/gcc/ada/a-ngcefu.adb b/gcc/ada/a-ngcefu.adb deleted file mode 100644 index b241f27..0000000 --- a/gcc/ada/a-ngcefu.adb +++ /dev/null @@ -1,710 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Elementary_Functions; - -package body Ada.Numerics.Generic_Complex_Elementary_Functions is - - package Elementary_Functions is new - Ada.Numerics.Generic_Elementary_Functions (Real'Base); - use Elementary_Functions; - - PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971; - PI_2 : constant := PI / 2.0; - Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; - Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; - - subtype T is Real'Base; - - Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa); - Square_Root_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); - Inv_Square_Root_Epsilon : constant T := Sqrt_Two ** (T'Model_Mantissa - 1); - Root_Root_Epsilon : constant T := Sqrt_Two ** - ((1 - T'Model_Mantissa) / 2); - Log_Inverse_Epsilon_2 : constant T := T (T'Model_Mantissa - 1) / 2.0; - - Complex_Zero : constant Complex := (0.0, 0.0); - Complex_One : constant Complex := (1.0, 0.0); - Complex_I : constant Complex := (0.0, 1.0); - Half_Pi : constant Complex := (PI_2, 0.0); - - -------- - -- ** -- - -------- - - function "**" (Left : Complex; Right : Complex) return Complex is - begin - if Re (Right) = 0.0 - and then Im (Right) = 0.0 - and then Re (Left) = 0.0 - and then Im (Left) = 0.0 - then - raise Argument_Error; - - elsif Re (Left) = 0.0 - and then Im (Left) = 0.0 - and then Re (Right) < 0.0 - then - raise Constraint_Error; - - elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then - return Left; - - elsif Right = (0.0, 0.0) then - return Complex_One; - - elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then - return 1.0 + Right; - - elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then - return Left; - - else - return Exp (Right * Log (Left)); - end if; - end "**"; - - function "**" (Left : Real'Base; Right : Complex) return Complex is - begin - if Re (Right) = 0.0 and then Im (Right) = 0.0 and then Left = 0.0 then - raise Argument_Error; - - elsif Left = 0.0 and then Re (Right) < 0.0 then - raise Constraint_Error; - - elsif Left = 0.0 then - return Compose_From_Cartesian (Left, 0.0); - - elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then - return Complex_One; - - elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then - return Compose_From_Cartesian (Left, 0.0); - - else - return Exp (Log (Left) * Right); - end if; - end "**"; - - function "**" (Left : Complex; Right : Real'Base) return Complex is - begin - if Right = 0.0 - and then Re (Left) = 0.0 - and then Im (Left) = 0.0 - then - raise Argument_Error; - - elsif Re (Left) = 0.0 - and then Im (Left) = 0.0 - and then Right < 0.0 - then - raise Constraint_Error; - - elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then - return Left; - - elsif Right = 0.0 then - return Complex_One; - - elsif Right = 1.0 then - return Left; - - else - return Exp (Right * Log (Left)); - end if; - end "**"; - - ------------ - -- Arccos -- - ------------ - - function Arccos (X : Complex) return Complex is - Result : Complex; - - begin - if X = Complex_One then - return Complex_Zero; - - elsif abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return Half_Pi - X; - - elsif abs Re (X) > Inv_Square_Root_Epsilon or else - abs Im (X) > Inv_Square_Root_Epsilon - then - return -2.0 * Complex_I * Log (Sqrt ((1.0 + X) / 2.0) + - Complex_I * Sqrt ((1.0 - X) / 2.0)); - end if; - - Result := -Complex_I * Log (X + Complex_I * Sqrt (1.0 - X * X)); - - if Im (X) = 0.0 - and then abs Re (X) <= 1.00 - then - Set_Im (Result, Im (X)); - end if; - - return Result; - end Arccos; - - ------------- - -- Arccosh -- - ------------- - - function Arccosh (X : Complex) return Complex is - Result : Complex; - - begin - if X = Complex_One then - return Complex_Zero; - - elsif abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - Result := Compose_From_Cartesian (-Im (X), -PI_2 + Re (X)); - - elsif abs Re (X) > Inv_Square_Root_Epsilon or else - abs Im (X) > Inv_Square_Root_Epsilon - then - Result := Log_Two + Log (X); - - else - Result := 2.0 * Log (Sqrt ((1.0 + X) / 2.0) + - Sqrt ((X - 1.0) / 2.0)); - end if; - - if Re (Result) <= 0.0 then - Result := -Result; - end if; - - return Result; - end Arccosh; - - ------------ - -- Arccot -- - ------------ - - function Arccot (X : Complex) return Complex is - Xt : Complex; - - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return Half_Pi - X; - - elsif abs Re (X) > 1.0 / Epsilon or else - abs Im (X) > 1.0 / Epsilon - then - Xt := Complex_One / X; - - if Re (X) < 0.0 then - Set_Re (Xt, PI - Re (Xt)); - return Xt; - else - return Xt; - end if; - end if; - - Xt := Complex_I * Log ((X - Complex_I) / (X + Complex_I)) / 2.0; - - if Re (Xt) < 0.0 then - Xt := PI + Xt; - end if; - - return Xt; - end Arccot; - - -------------- - -- Arccoth -- - -------------- - - function Arccoth (X : Complex) return Complex is - R : Complex; - - begin - if X = (0.0, 0.0) then - return Compose_From_Cartesian (0.0, PI_2); - - elsif abs Re (X) < Square_Root_Epsilon - and then abs Im (X) < Square_Root_Epsilon - then - return PI_2 * Complex_I + X; - - elsif abs Re (X) > 1.0 / Epsilon or else - abs Im (X) > 1.0 / Epsilon - then - if Im (X) > 0.0 then - return (0.0, 0.0); - else - return PI * Complex_I; - end if; - - elsif Im (X) = 0.0 and then Re (X) = 1.0 then - raise Constraint_Error; - - elsif Im (X) = 0.0 and then Re (X) = -1.0 then - raise Constraint_Error; - end if; - - begin - R := Log ((1.0 + X) / (X - 1.0)) / 2.0; - - exception - when Constraint_Error => - R := (Log (1.0 + X) - Log (X - 1.0)) / 2.0; - end; - - if Im (R) < 0.0 then - Set_Im (R, PI + Im (R)); - end if; - - if Re (X) = 0.0 then - Set_Re (R, Re (X)); - end if; - - return R; - end Arccoth; - - ------------ - -- Arcsin -- - ------------ - - function Arcsin (X : Complex) return Complex is - Result : Complex; - - begin - -- For very small argument, sin (x) = x - - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return X; - - elsif abs Re (X) > Inv_Square_Root_Epsilon or else - abs Im (X) > Inv_Square_Root_Epsilon - then - Result := -Complex_I * (Log (Complex_I * X) + Log (2.0 * Complex_I)); - - if Im (Result) > PI_2 then - Set_Im (Result, PI - Im (X)); - - elsif Im (Result) < -PI_2 then - Set_Im (Result, -(PI + Im (X))); - end if; - - return Result; - end if; - - Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X)); - - if Re (X) = 0.0 then - Set_Re (Result, Re (X)); - - elsif Im (X) = 0.0 - and then abs Re (X) <= 1.00 - then - Set_Im (Result, Im (X)); - end if; - - return Result; - end Arcsin; - - ------------- - -- Arcsinh -- - ------------- - - function Arcsinh (X : Complex) return Complex is - Result : Complex; - - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return X; - - elsif abs Re (X) > Inv_Square_Root_Epsilon or else - abs Im (X) > Inv_Square_Root_Epsilon - then - Result := Log_Two + Log (X); -- may have wrong sign - - if (Re (X) < 0.0 and then Re (Result) > 0.0) - or else (Re (X) > 0.0 and then Re (Result) < 0.0) - then - Set_Re (Result, -Re (Result)); - end if; - - return Result; - end if; - - Result := Log (X + Sqrt (1.0 + X * X)); - - if Re (X) = 0.0 then - Set_Re (Result, Re (X)); - elsif Im (X) = 0.0 then - Set_Im (Result, Im (X)); - end if; - - return Result; - end Arcsinh; - - ------------ - -- Arctan -- - ------------ - - function Arctan (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return X; - - else - return -Complex_I * (Log (1.0 + Complex_I * X) - - Log (1.0 - Complex_I * X)) / 2.0; - end if; - end Arctan; - - ------------- - -- Arctanh -- - ------------- - - function Arctanh (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return X; - else - return (Log (1.0 + X) - Log (1.0 - X)) / 2.0; - end if; - end Arctanh; - - --------- - -- Cos -- - --------- - - function Cos (X : Complex) return Complex is - begin - return - Compose_From_Cartesian - (Cos (Re (X)) * Cosh (Im (X)), - -(Sin (Re (X)) * Sinh (Im (X)))); - end Cos; - - ---------- - -- Cosh -- - ---------- - - function Cosh (X : Complex) return Complex is - begin - return - Compose_From_Cartesian - (Cosh (Re (X)) * Cos (Im (X)), - Sinh (Re (X)) * Sin (Im (X))); - end Cosh; - - --------- - -- Cot -- - --------- - - function Cot (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return Complex_One / X; - - elsif Im (X) > Log_Inverse_Epsilon_2 then - return -Complex_I; - - elsif Im (X) < -Log_Inverse_Epsilon_2 then - return Complex_I; - end if; - - return Cos (X) / Sin (X); - end Cot; - - ---------- - -- Coth -- - ---------- - - function Coth (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return Complex_One / X; - - elsif Re (X) > Log_Inverse_Epsilon_2 then - return Complex_One; - - elsif Re (X) < -Log_Inverse_Epsilon_2 then - return -Complex_One; - - else - return Cosh (X) / Sinh (X); - end if; - end Coth; - - --------- - -- Exp -- - --------- - - function Exp (X : Complex) return Complex is - EXP_RE_X : constant Real'Base := Exp (Re (X)); - - begin - return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)), - EXP_RE_X * Sin (Im (X))); - end Exp; - - function Exp (X : Imaginary) return Complex is - ImX : constant Real'Base := Im (X); - - begin - return Compose_From_Cartesian (Cos (ImX), Sin (ImX)); - end Exp; - - --------- - -- Log -- - --------- - - function Log (X : Complex) return Complex is - ReX : Real'Base; - ImX : Real'Base; - Z : Complex; - - begin - if Re (X) = 0.0 and then Im (X) = 0.0 then - raise Constraint_Error; - - elsif abs (1.0 - Re (X)) < Root_Root_Epsilon - and then abs Im (X) < Root_Root_Epsilon - then - Z := X; - Set_Re (Z, Re (Z) - 1.0); - - return (1.0 - (1.0 / 2.0 - - (1.0 / 3.0 - (1.0 / 4.0) * Z) * Z) * Z) * Z; - end if; - - begin - ReX := Log (Modulus (X)); - - exception - when Constraint_Error => - ReX := Log (Modulus (X / 2.0)) - Log_Two; - end; - - ImX := Arctan (Im (X), Re (X)); - - if ImX > PI then - ImX := ImX - 2.0 * PI; - end if; - - return Compose_From_Cartesian (ReX, ImX); - end Log; - - --------- - -- Sin -- - --------- - - function Sin (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon - and then - abs Im (X) < Square_Root_Epsilon - then - return X; - end if; - - return - Compose_From_Cartesian - (Sin (Re (X)) * Cosh (Im (X)), - Cos (Re (X)) * Sinh (Im (X))); - end Sin; - - ---------- - -- Sinh -- - ---------- - - function Sinh (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return X; - - else - return Compose_From_Cartesian (Sinh (Re (X)) * Cos (Im (X)), - Cosh (Re (X)) * Sin (Im (X))); - end if; - end Sinh; - - ---------- - -- Sqrt -- - ---------- - - function Sqrt (X : Complex) return Complex is - ReX : constant Real'Base := Re (X); - ImX : constant Real'Base := Im (X); - XR : constant Real'Base := abs Re (X); - YR : constant Real'Base := abs Im (X); - R : Real'Base; - R_X : Real'Base; - R_Y : Real'Base; - - begin - -- Deal with pure real case, see (RM G.1.2(39)) - - if ImX = 0.0 then - if ReX > 0.0 then - return - Compose_From_Cartesian - (Sqrt (ReX), 0.0); - - elsif ReX = 0.0 then - return X; - - else - return - Compose_From_Cartesian - (0.0, Real'Copy_Sign (Sqrt (-ReX), ImX)); - end if; - - elsif ReX = 0.0 then - R_X := Sqrt (YR / 2.0); - - if ImX > 0.0 then - return Compose_From_Cartesian (R_X, R_X); - else - return Compose_From_Cartesian (R_X, -R_X); - end if; - - else - R := Sqrt (XR ** 2 + YR ** 2); - - -- If the square of the modulus overflows, try rescaling the - -- real and imaginary parts. We cannot depend on an exception - -- being raised on all targets. - - if R > Real'Base'Last then - raise Constraint_Error; - end if; - - -- We are solving the system - - -- XR = R_X ** 2 - Y_R ** 2 (1) - -- YR = 2.0 * R_X * R_Y (2) - -- - -- The symmetric solution involves square roots for both R_X and - -- R_Y, but it is more accurate to use the square root with the - -- larger argument for either R_X or R_Y, and equation (2) for the - -- other. - - if ReX < 0.0 then - R_Y := Sqrt (0.5 * (R - ReX)); - R_X := YR / (2.0 * R_Y); - - else - R_X := Sqrt (0.5 * (R + ReX)); - R_Y := YR / (2.0 * R_X); - end if; - end if; - - if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude - R_Y := -R_Y; - end if; - return Compose_From_Cartesian (R_X, R_Y); - - exception - when Constraint_Error => - - -- Rescale and try again - - R := Modulus (Compose_From_Cartesian (Re (X / 4.0), Im (X / 4.0))); - R_X := 2.0 * Sqrt (0.5 * R + 0.5 * Re (X / 4.0)); - R_Y := 2.0 * Sqrt (0.5 * R - 0.5 * Re (X / 4.0)); - - if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude - R_Y := -R_Y; - end if; - - return Compose_From_Cartesian (R_X, R_Y); - end Sqrt; - - --------- - -- Tan -- - --------- - - function Tan (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return X; - - elsif Im (X) > Log_Inverse_Epsilon_2 then - return Complex_I; - - elsif Im (X) < -Log_Inverse_Epsilon_2 then - return -Complex_I; - - else - return Sin (X) / Cos (X); - end if; - end Tan; - - ---------- - -- Tanh -- - ---------- - - function Tanh (X : Complex) return Complex is - begin - if abs Re (X) < Square_Root_Epsilon and then - abs Im (X) < Square_Root_Epsilon - then - return X; - - elsif Re (X) > Log_Inverse_Epsilon_2 then - return Complex_One; - - elsif Re (X) < -Log_Inverse_Epsilon_2 then - return -Complex_One; - - else - return Sinh (X) / Cosh (X); - end if; - end Tanh; - -end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/a-ngcefu.ads b/gcc/ada/a-ngcefu.ads deleted file mode 100644 index 576c84a..0000000 --- a/gcc/ada/a-ngcefu.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; -generic - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); - use Complex_Types; - -package Ada.Numerics.Generic_Complex_Elementary_Functions is - pragma Pure; - - function Sqrt (X : Complex) return Complex; - - function Log (X : Complex) return Complex; - - function Exp (X : Complex) return Complex; - function Exp (X : Imaginary) return Complex; - - function "**" (Left : Complex; Right : Complex) return Complex; - function "**" (Left : Complex; Right : Real'Base) return Complex; - function "**" (Left : Real'Base; Right : Complex) return Complex; - - function Sin (X : Complex) return Complex; - function Cos (X : Complex) return Complex; - function Tan (X : Complex) return Complex; - function Cot (X : Complex) return Complex; - - function Arcsin (X : Complex) return Complex; - function Arccos (X : Complex) return Complex; - function Arctan (X : Complex) return Complex; - function Arccot (X : Complex) return Complex; - - function Sinh (X : Complex) return Complex; - function Cosh (X : Complex) return Complex; - function Tanh (X : Complex) return Complex; - function Coth (X : Complex) return Complex; - - function Arcsinh (X : Complex) return Complex; - function Arccosh (X : Complex) return Complex; - function Arctanh (X : Complex) return Complex; - function Arccoth (X : Complex) return Complex; - -end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/a-ngcoar.adb b/gcc/ada/a-ngcoar.adb deleted file mode 100644 index bee1bc1..0000000 --- a/gcc/ada/a-ngcoar.adb +++ /dev/null @@ -1,1255 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_COMPLEX_ARRAYS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body Ada.Numerics.Generic_Complex_Arrays is - - -- Operations that are defined in terms of operations on the type Real, - -- such as addition, subtraction and scaling, are computed in the canonical - -- way looping over all elements. - - package Ops renames System.Generic_Array_Operations; - - subtype Real is Real_Arrays.Real; - -- Work around visibility bug ??? - - function Is_Non_Zero (X : Complex) return Boolean is (X /= (0.0, 0.0)); - -- Needed by Back_Substitute - - procedure Back_Substitute is new Ops.Back_Substitute - (Scalar => Complex, - Matrix => Complex_Matrix, - Is_Non_Zero => Is_Non_Zero); - - procedure Forward_Eliminate is new Ops.Forward_Eliminate - (Scalar => Complex, - Real => Real'Base, - Matrix => Complex_Matrix, - Zero => (0.0, 0.0), - One => (1.0, 0.0)); - - procedure Transpose is new Ops.Transpose - (Scalar => Complex, - Matrix => Complex_Matrix); - - -- Helper function that raises a Constraint_Error is the argument is - -- not a square matrix, and otherwise returns its length. - - function Length is new Square_Matrix_Length (Complex, Complex_Matrix); - - -- Instant a generic square root implementation here, in order to avoid - -- instantiating a complete copy of Generic_Elementary_Functions. - -- Speed of the square root is not a big concern here. - - function Sqrt is new Ops.Sqrt (Real'Base); - - -- Instantiating the following subprograms directly would lead to - -- name clashes, so use a local package. - - package Instantiations is - - --------- - -- "*" -- - --------- - - function "*" is new Vector_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "*"); - - function "*" is new Vector_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "*"); - - function "*" is new Scalar_Vector_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "*"); - - function "*" is new Scalar_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "*"); - - function "*" is new Inner_Product - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Real_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Inner_Product - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Real_Vector, - Right_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Inner_Product - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Outer_Product - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Complex_Vector, - Matrix => Complex_Matrix); - - function "*" is new Outer_Product - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Real_Vector, - Right_Vector => Complex_Vector, - Matrix => Complex_Matrix); - - function "*" is new Outer_Product - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Real_Vector, - Matrix => Complex_Matrix); - - function "*" is new Matrix_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "*"); - - function "*" is new Matrix_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "*"); - - function "*" is new Scalar_Matrix_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "*"); - - function "*" is new Scalar_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "*"); - - function "*" is new Matrix_Vector_Product - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Matrix => Real_Matrix, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Matrix_Vector_Product - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Matrix => Complex_Matrix, - Right_Vector => Real_Vector, - Result_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Matrix_Vector_Product - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Matrix => Complex_Matrix, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Vector_Matrix_Product - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Real_Vector, - Matrix => Complex_Matrix, - Result_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Vector_Matrix_Product - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Matrix => Real_Matrix, - Result_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Vector_Matrix_Product - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Matrix => Complex_Matrix, - Result_Vector => Complex_Vector, - Zero => (0.0, 0.0)); - - function "*" is new Matrix_Matrix_Product - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Zero => (0.0, 0.0)); - - function "*" is new Matrix_Matrix_Product - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Real_Matrix, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Zero => (0.0, 0.0)); - - function "*" is new Matrix_Matrix_Product - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Complex_Matrix, - Zero => (0.0, 0.0)); - - --------- - -- "+" -- - --------- - - function "+" is new Vector_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Complex, - X_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "+"); - - function "+" is new Vector_Vector_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "+"); - - function "+" is new Vector_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Real_Vector, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "+"); - - function "+" is new Vector_Vector_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Real_Vector, - Result_Vector => Complex_Vector, - Operation => "+"); - - function "+" is new Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Complex, - X_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "+"); - - function "+" is new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "+"); - - function "+" is new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Real_Matrix, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "+"); - - function "+" is new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "+"); - - --------- - -- "-" -- - --------- - - function "-" is new Vector_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Complex, - X_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "-"); - - function "-" is new Vector_Vector_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "-"); - - function "-" is new Vector_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Real_Vector, - Right_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "-"); - - function "-" is new Vector_Vector_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Right_Vector => Real_Vector, - Result_Vector => Complex_Vector, - Operation => "-"); - - function "-" is new Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Complex, - X_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "-"); - - function "-" is new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "-"); - - function "-" is new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Real_Matrix, - Right_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "-"); - - function "-" is new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "-"); - - --------- - -- "/" -- - --------- - - function "/" is new Vector_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "/"); - - function "/" is new Vector_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => "/"); - - function "/" is new Matrix_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Complex, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "/"); - - function "/" is new Matrix_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => "/"); - - ----------- - -- "abs" -- - ----------- - - function "abs" is new L2_Norm - (X_Scalar => Complex, - Result_Real => Real'Base, - X_Vector => Complex_Vector); - - -------------- - -- Argument -- - -------------- - - function Argument is new Vector_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Vector => Complex_Vector, - Result_Vector => Real_Vector, - Operation => Argument); - - function Argument is new Vector_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Complex_Vector, - Result_Vector => Real_Vector, - Operation => Argument); - - function Argument is new Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Matrix => Complex_Matrix, - Result_Matrix => Real_Matrix, - Operation => Argument); - - function Argument is new Matrix_Scalar_Elementwise_Operation - (Left_Scalar => Complex, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Matrix => Complex_Matrix, - Result_Matrix => Real_Matrix, - Operation => Argument); - - ---------------------------- - -- Compose_From_Cartesian -- - ---------------------------- - - function Compose_From_Cartesian is new Vector_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Complex, - X_Vector => Real_Vector, - Result_Vector => Complex_Vector, - Operation => Compose_From_Cartesian); - - function Compose_From_Cartesian is - new Vector_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Real_Vector, - Right_Vector => Real_Vector, - Result_Vector => Complex_Vector, - Operation => Compose_From_Cartesian); - - function Compose_From_Cartesian is new Matrix_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Complex, - X_Matrix => Real_Matrix, - Result_Matrix => Complex_Matrix, - Operation => Compose_From_Cartesian); - - function Compose_From_Cartesian is - new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Matrix => Real_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Complex_Matrix, - Operation => Compose_From_Cartesian); - - ------------------------ - -- Compose_From_Polar -- - ------------------------ - - function Compose_From_Polar is - new Vector_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Vector => Real_Vector, - Right_Vector => Real_Vector, - Result_Vector => Complex_Vector, - Operation => Compose_From_Polar); - - function Compose_From_Polar is - new Vector_Vector_Scalar_Elementwise_Operation - (X_Scalar => Real'Base, - Y_Scalar => Real'Base, - Z_Scalar => Real'Base, - Result_Scalar => Complex, - X_Vector => Real_Vector, - Y_Vector => Real_Vector, - Result_Vector => Complex_Vector, - Operation => Compose_From_Polar); - - function Compose_From_Polar is - new Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Complex, - Left_Matrix => Real_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Complex_Matrix, - Operation => Compose_From_Polar); - - function Compose_From_Polar is - new Matrix_Matrix_Scalar_Elementwise_Operation - (X_Scalar => Real'Base, - Y_Scalar => Real'Base, - Z_Scalar => Real'Base, - Result_Scalar => Complex, - X_Matrix => Real_Matrix, - Y_Matrix => Real_Matrix, - Result_Matrix => Complex_Matrix, - Operation => Compose_From_Polar); - - --------------- - -- Conjugate -- - --------------- - - function Conjugate is new Vector_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Complex, - X_Vector => Complex_Vector, - Result_Vector => Complex_Vector, - Operation => Conjugate); - - function Conjugate is new Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Complex, - X_Matrix => Complex_Matrix, - Result_Matrix => Complex_Matrix, - Operation => Conjugate); - - -------- - -- Im -- - -------- - - function Im is new Vector_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Vector => Complex_Vector, - Result_Vector => Real_Vector, - Operation => Im); - - function Im is new Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Matrix => Complex_Matrix, - Result_Matrix => Real_Matrix, - Operation => Im); - - ------------- - -- Modulus -- - ------------- - - function Modulus is new Vector_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Vector => Complex_Vector, - Result_Vector => Real_Vector, - Operation => Modulus); - - function Modulus is new Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Matrix => Complex_Matrix, - Result_Matrix => Real_Matrix, - Operation => Modulus); - - -------- - -- Re -- - -------- - - function Re is new Vector_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Vector => Complex_Vector, - Result_Vector => Real_Vector, - Operation => Re); - - function Re is new Matrix_Elementwise_Operation - (X_Scalar => Complex, - Result_Scalar => Real'Base, - X_Matrix => Complex_Matrix, - Result_Matrix => Real_Matrix, - Operation => Re); - - ------------ - -- Set_Im -- - ------------ - - procedure Set_Im is new Update_Vector_With_Vector - (X_Scalar => Complex, - Y_Scalar => Real'Base, - X_Vector => Complex_Vector, - Y_Vector => Real_Vector, - Update => Set_Im); - - procedure Set_Im is new Update_Matrix_With_Matrix - (X_Scalar => Complex, - Y_Scalar => Real'Base, - X_Matrix => Complex_Matrix, - Y_Matrix => Real_Matrix, - Update => Set_Im); - - ------------ - -- Set_Re -- - ------------ - - procedure Set_Re is new Update_Vector_With_Vector - (X_Scalar => Complex, - Y_Scalar => Real'Base, - X_Vector => Complex_Vector, - Y_Vector => Real_Vector, - Update => Set_Re); - - procedure Set_Re is new Update_Matrix_With_Matrix - (X_Scalar => Complex, - Y_Scalar => Real'Base, - X_Matrix => Complex_Matrix, - Y_Matrix => Real_Matrix, - Update => Set_Re); - - ----------- - -- Solve -- - ----------- - - function Solve is new Matrix_Vector_Solution - (Complex, (0.0, 0.0), Complex_Vector, Complex_Matrix); - - function Solve is new Matrix_Matrix_Solution - (Complex, (0.0, 0.0), Complex_Matrix); - - ----------------- - -- Unit_Matrix -- - ----------------- - - function Unit_Matrix is new System.Generic_Array_Operations.Unit_Matrix - (Scalar => Complex, - Matrix => Complex_Matrix, - Zero => (0.0, 0.0), - One => (1.0, 0.0)); - - function Unit_Vector is new System.Generic_Array_Operations.Unit_Vector - (Scalar => Complex, - Vector => Complex_Vector, - Zero => (0.0, 0.0), - One => (1.0, 0.0)); - end Instantiations; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Complex_Vector; - Right : Complex_Vector) return Complex - renames Instantiations."*"; - - function "*" - (Left : Real_Vector; - Right : Complex_Vector) return Complex - renames Instantiations."*"; - - function "*" - (Left : Complex_Vector; - Right : Real_Vector) return Complex - renames Instantiations."*"; - - function "*" - (Left : Complex; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Complex_Vector; - Right : Complex) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Real'Base; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Complex_Vector; - Right : Real'Base) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Complex_Matrix; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Complex_Vector; - Right : Complex_Vector) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Complex_Vector; - Right : Complex_Matrix) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Complex_Matrix; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Real_Matrix; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Complex_Matrix; - Right : Real_Matrix) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Real_Vector; - Right : Complex_Vector) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Complex_Vector; - Right : Real_Vector) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Real_Vector; - Right : Complex_Matrix) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Complex_Vector; - Right : Real_Matrix) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Real_Matrix; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Complex_Matrix; - Right : Real_Vector) return Complex_Vector - renames Instantiations."*"; - - function "*" - (Left : Complex; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Complex_Matrix; - Right : Complex) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Real'Base; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."*"; - - function "*" - (Left : Complex_Matrix; - Right : Real'Base) return Complex_Matrix - renames Instantiations."*"; - - --------- - -- "+" -- - --------- - - function "+" (Right : Complex_Vector) return Complex_Vector - renames Instantiations."+"; - - function "+" - (Left : Complex_Vector; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."+"; - - function "+" - (Left : Real_Vector; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."+"; - - function "+" - (Left : Complex_Vector; - Right : Real_Vector) return Complex_Vector - renames Instantiations."+"; - - function "+" (Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."+"; - - function "+" - (Left : Complex_Matrix; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."+"; - - function "+" - (Left : Real_Matrix; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."+"; - - function "+" - (Left : Complex_Matrix; - Right : Real_Matrix) return Complex_Matrix - renames Instantiations."+"; - - --------- - -- "-" -- - --------- - - function "-" - (Right : Complex_Vector) return Complex_Vector - renames Instantiations."-"; - - function "-" - (Left : Complex_Vector; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."-"; - - function "-" - (Left : Real_Vector; - Right : Complex_Vector) return Complex_Vector - renames Instantiations."-"; - - function "-" - (Left : Complex_Vector; - Right : Real_Vector) return Complex_Vector - renames Instantiations."-"; - - function "-" (Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."-"; - - function "-" - (Left : Complex_Matrix; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."-"; - - function "-" - (Left : Real_Matrix; - Right : Complex_Matrix) return Complex_Matrix - renames Instantiations."-"; - - function "-" - (Left : Complex_Matrix; - Right : Real_Matrix) return Complex_Matrix - renames Instantiations."-"; - - --------- - -- "/" -- - --------- - - function "/" - (Left : Complex_Vector; - Right : Complex) return Complex_Vector - renames Instantiations."/"; - - function "/" - (Left : Complex_Vector; - Right : Real'Base) return Complex_Vector - renames Instantiations."/"; - - function "/" - (Left : Complex_Matrix; - Right : Complex) return Complex_Matrix - renames Instantiations."/"; - - function "/" - (Left : Complex_Matrix; - Right : Real'Base) return Complex_Matrix - renames Instantiations."/"; - - ----------- - -- "abs" -- - ----------- - - function "abs" (Right : Complex_Vector) return Real'Base - renames Instantiations."abs"; - - -------------- - -- Argument -- - -------------- - - function Argument (X : Complex_Vector) return Real_Vector - renames Instantiations.Argument; - - function Argument - (X : Complex_Vector; - Cycle : Real'Base) return Real_Vector - renames Instantiations.Argument; - - function Argument (X : Complex_Matrix) return Real_Matrix - renames Instantiations.Argument; - - function Argument - (X : Complex_Matrix; - Cycle : Real'Base) return Real_Matrix - renames Instantiations.Argument; - - ---------------------------- - -- Compose_From_Cartesian -- - ---------------------------- - - function Compose_From_Cartesian (Re : Real_Vector) return Complex_Vector - renames Instantiations.Compose_From_Cartesian; - - function Compose_From_Cartesian - (Re : Real_Vector; - Im : Real_Vector) return Complex_Vector - renames Instantiations.Compose_From_Cartesian; - - function Compose_From_Cartesian (Re : Real_Matrix) return Complex_Matrix - renames Instantiations.Compose_From_Cartesian; - - function Compose_From_Cartesian - (Re : Real_Matrix; - Im : Real_Matrix) return Complex_Matrix - renames Instantiations.Compose_From_Cartesian; - - ------------------------ - -- Compose_From_Polar -- - ------------------------ - - function Compose_From_Polar - (Modulus : Real_Vector; - Argument : Real_Vector) return Complex_Vector - renames Instantiations.Compose_From_Polar; - - function Compose_From_Polar - (Modulus : Real_Vector; - Argument : Real_Vector; - Cycle : Real'Base) return Complex_Vector - renames Instantiations.Compose_From_Polar; - - function Compose_From_Polar - (Modulus : Real_Matrix; - Argument : Real_Matrix) return Complex_Matrix - renames Instantiations.Compose_From_Polar; - - function Compose_From_Polar - (Modulus : Real_Matrix; - Argument : Real_Matrix; - Cycle : Real'Base) return Complex_Matrix - renames Instantiations.Compose_From_Polar; - - --------------- - -- Conjugate -- - --------------- - - function Conjugate (X : Complex_Vector) return Complex_Vector - renames Instantiations.Conjugate; - - function Conjugate (X : Complex_Matrix) return Complex_Matrix - renames Instantiations.Conjugate; - - ----------------- - -- Determinant -- - ----------------- - - function Determinant (A : Complex_Matrix) return Complex is - M : Complex_Matrix := A; - B : Complex_Matrix (A'Range (1), 1 .. 0); - R : Complex; - begin - Forward_Eliminate (M, B, R); - return R; - end Determinant; - - ----------------- - -- Eigensystem -- - ----------------- - - procedure Eigensystem - (A : Complex_Matrix; - Values : out Real_Vector; - Vectors : out Complex_Matrix) - is - N : constant Natural := Length (A); - - -- For a Hermitian matrix C, we convert the eigenvalue problem to a - -- real symmetric one: if C = A + i * B, then the (N, N) complex - -- eigenvalue problem: - -- (A + i * B) * (u + i * v) = Lambda * (u + i * v) - -- - -- is equivalent to the (2 * N, 2 * N) real eigenvalue problem: - -- [ A, B ] [ u ] = Lambda * [ u ] - -- [ -B, A ] [ v ] [ v ] - -- - -- Note that the (2 * N, 2 * N) matrix above is symmetric, as - -- Transpose (A) = A and Transpose (B) = -B if C is Hermitian. - - -- We solve this eigensystem using the real-valued algorithms. The final - -- result will have every eigenvalue twice, so in the sorted output we - -- just pick every second value, with associated eigenvector u + i * v. - - M : Real_Matrix (1 .. 2 * N, 1 .. 2 * N); - Vals : Real_Vector (1 .. 2 * N); - Vecs : Real_Matrix (1 .. 2 * N, 1 .. 2 * N); - - begin - for J in 1 .. N loop - for K in 1 .. N loop - declare - C : constant Complex := - (A (A'First (1) + (J - 1), A'First (2) + (K - 1))); - begin - M (J, K) := Re (C); - M (J + N, K + N) := Re (C); - M (J + N, K) := Im (C); - M (J, K + N) := -Im (C); - end; - end loop; - end loop; - - Eigensystem (M, Vals, Vecs); - - for J in 1 .. N loop - declare - Col : constant Integer := Values'First + (J - 1); - begin - Values (Col) := Vals (2 * J); - - for K in 1 .. N loop - declare - Row : constant Integer := Vectors'First (2) + (K - 1); - begin - Vectors (Row, Col) - := (Vecs (J * 2, Col), Vecs (J * 2, Col + N)); - end; - end loop; - end; - end loop; - end Eigensystem; - - ----------------- - -- Eigenvalues -- - ----------------- - - function Eigenvalues (A : Complex_Matrix) return Real_Vector is - -- See Eigensystem for a description of the algorithm - - N : constant Natural := Length (A); - R : Real_Vector (A'Range (1)); - - M : Real_Matrix (1 .. 2 * N, 1 .. 2 * N); - Vals : Real_Vector (1 .. 2 * N); - begin - for J in 1 .. N loop - for K in 1 .. N loop - declare - C : constant Complex := - (A (A'First (1) + (J - 1), A'First (2) + (K - 1))); - begin - M (J, K) := Re (C); - M (J + N, K + N) := Re (C); - M (J + N, K) := Im (C); - M (J, K + N) := -Im (C); - end; - end loop; - end loop; - - Vals := Eigenvalues (M); - - for J in 1 .. N loop - R (A'First (1) + (J - 1)) := Vals (2 * J); - end loop; - - return R; - end Eigenvalues; - - -------- - -- Im -- - -------- - - function Im (X : Complex_Vector) return Real_Vector - renames Instantiations.Im; - - function Im (X : Complex_Matrix) return Real_Matrix - renames Instantiations.Im; - - ------------- - -- Inverse -- - ------------- - - function Inverse (A : Complex_Matrix) return Complex_Matrix is - (Solve (A, Unit_Matrix (Length (A), - First_1 => A'First (2), - First_2 => A'First (1)))); - - ------------- - -- Modulus -- - ------------- - - function Modulus (X : Complex_Vector) return Real_Vector - renames Instantiations.Modulus; - - function Modulus (X : Complex_Matrix) return Real_Matrix - renames Instantiations.Modulus; - - -------- - -- Re -- - -------- - - function Re (X : Complex_Vector) return Real_Vector - renames Instantiations.Re; - - function Re (X : Complex_Matrix) return Real_Matrix - renames Instantiations.Re; - - ------------ - -- Set_Im -- - ------------ - - procedure Set_Im - (X : in out Complex_Matrix; - Im : Real_Matrix) - renames Instantiations.Set_Im; - - procedure Set_Im - (X : in out Complex_Vector; - Im : Real_Vector) - renames Instantiations.Set_Im; - - ------------ - -- Set_Re -- - ------------ - - procedure Set_Re - (X : in out Complex_Matrix; - Re : Real_Matrix) - renames Instantiations.Set_Re; - - procedure Set_Re - (X : in out Complex_Vector; - Re : Real_Vector) - renames Instantiations.Set_Re; - - ----------- - -- Solve -- - ----------- - - function Solve - (A : Complex_Matrix; - X : Complex_Vector) return Complex_Vector - renames Instantiations.Solve; - - function Solve - (A : Complex_Matrix; - X : Complex_Matrix) return Complex_Matrix - renames Instantiations.Solve; - - --------------- - -- Transpose -- - --------------- - - function Transpose - (X : Complex_Matrix) return Complex_Matrix - is - R : Complex_Matrix (X'Range (2), X'Range (1)); - begin - Transpose (X, R); - return R; - end Transpose; - - ----------------- - -- Unit_Matrix -- - ----------------- - - function Unit_Matrix - (Order : Positive; - First_1 : Integer := 1; - First_2 : Integer := 1) return Complex_Matrix - renames Instantiations.Unit_Matrix; - - ----------------- - -- Unit_Vector -- - ----------------- - - function Unit_Vector - (Index : Integer; - Order : Positive; - First : Integer := 1) return Complex_Vector - renames Instantiations.Unit_Vector; - -end Ada.Numerics.Generic_Complex_Arrays; diff --git a/gcc/ada/a-ngcoar.ads b/gcc/ada/a-ngcoar.ads deleted file mode 100644 index 8f8f37a..0000000 --- a/gcc/ada/a-ngcoar.ads +++ /dev/null @@ -1,281 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_COMPLEX_ARRAYS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Real_Arrays, Ada.Numerics.Generic_Complex_Types; - -generic - with package Real_Arrays is new Ada.Numerics.Generic_Real_Arrays (<>); - use Real_Arrays; - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); - use Complex_Types; -package Ada.Numerics.Generic_Complex_Arrays is - pragma Pure (Generic_Complex_Arrays); - - -- Types - - type Complex_Vector is array (Integer range <>) of Complex; - type Complex_Matrix is - array (Integer range <>, Integer range <>) of Complex; - - -- Subprograms for Complex_Vector types - -- Complex_Vector selection, conversion and composition operations - - function Re (X : Complex_Vector) return Real_Vector; - function Im (X : Complex_Vector) return Real_Vector; - - procedure Set_Re (X : in out Complex_Vector; Re : Real_Vector); - procedure Set_Im (X : in out Complex_Vector; Im : Real_Vector); - - function Compose_From_Cartesian - (Re : Real_Vector) return Complex_Vector; - function Compose_From_Cartesian - (Re, Im : Real_Vector) return Complex_Vector; - - function Modulus (X : Complex_Vector) return Real_Vector; - function "abs" (Right : Complex_Vector) return Real_Vector renames Modulus; - function Argument (X : Complex_Vector) return Real_Vector; - - function Argument - (X : Complex_Vector; - Cycle : Real'Base) return Real_Vector; - - function Compose_From_Polar - (Modulus, Argument : Real_Vector) return Complex_Vector; - - function Compose_From_Polar - (Modulus, Argument : Real_Vector; - Cycle : Real'Base) return Complex_Vector; - - -- Complex_Vector arithmetic operations - - function "+" (Right : Complex_Vector) return Complex_Vector; - function "-" (Right : Complex_Vector) return Complex_Vector; - function Conjugate (X : Complex_Vector) return Complex_Vector; - function "+" (Left, Right : Complex_Vector) return Complex_Vector; - function "-" (Left, Right : Complex_Vector) return Complex_Vector; - function "*" (Left, Right : Complex_Vector) return Complex; - function "abs" (Right : Complex_Vector) return Real'Base; - - -- Mixed Real_Vector and Complex_Vector arithmetic operations - - function "+" - (Left : Real_Vector; - Right : Complex_Vector) return Complex_Vector; - - function "+" - (Left : Complex_Vector; - Right : Real_Vector) return Complex_Vector; - - function "-" - (Left : Real_Vector; - Right : Complex_Vector) return Complex_Vector; - - function "-" - (Left : Complex_Vector; - Right : Real_Vector) return Complex_Vector; - - function "*" (Left : Real_Vector; Right : Complex_Vector) return Complex; - function "*" (Left : Complex_Vector; Right : Real_Vector) return Complex; - - -- Complex_Vector scaling operations - - function "*" - (Left : Complex; - Right : Complex_Vector) return Complex_Vector; - - function "*" - (Left : Complex_Vector; - Right : Complex) return Complex_Vector; - - function "/" - (Left : Complex_Vector; - Right : Complex) return Complex_Vector; - - function "*" - (Left : Real'Base; - Right : Complex_Vector) return Complex_Vector; - - function "*" - (Left : Complex_Vector; - Right : Real'Base) return Complex_Vector; - - function "/" - (Left : Complex_Vector; - Right : Real'Base) return Complex_Vector; - - -- Other Complex_Vector operations - - function Unit_Vector - (Index : Integer; - Order : Positive; - First : Integer := 1) return Complex_Vector; - - -- Subprograms for Complex_Matrix types - - -- Complex_Matrix selection, conversion and composition operations - - function Re (X : Complex_Matrix) return Real_Matrix; - function Im (X : Complex_Matrix) return Real_Matrix; - - procedure Set_Re (X : in out Complex_Matrix; Re : Real_Matrix); - procedure Set_Im (X : in out Complex_Matrix; Im : Real_Matrix); - - function Compose_From_Cartesian (Re : Real_Matrix) return Complex_Matrix; - - function Compose_From_Cartesian - (Re, Im : Real_Matrix) return Complex_Matrix; - - function Modulus (X : Complex_Matrix) return Real_Matrix; - function "abs" (Right : Complex_Matrix) return Real_Matrix renames Modulus; - - function Argument (X : Complex_Matrix) return Real_Matrix; - - function Argument - (X : Complex_Matrix; - Cycle : Real'Base) return Real_Matrix; - - function Compose_From_Polar - (Modulus, Argument : Real_Matrix) return Complex_Matrix; - - function Compose_From_Polar - (Modulus : Real_Matrix; - Argument : Real_Matrix; - Cycle : Real'Base) return Complex_Matrix; - - -- Complex_Matrix arithmetic operations - - function "+" (Right : Complex_Matrix) return Complex_Matrix; - function "-" (Right : Complex_Matrix) return Complex_Matrix; - - function Conjugate (X : Complex_Matrix) return Complex_Matrix; - function Transpose (X : Complex_Matrix) return Complex_Matrix; - - function "+" (Left, Right : Complex_Matrix) return Complex_Matrix; - function "-" (Left, Right : Complex_Matrix) return Complex_Matrix; - function "*" (Left, Right : Complex_Matrix) return Complex_Matrix; - function "*" (Left, Right : Complex_Vector) return Complex_Matrix; - - function "*" - (Left : Complex_Vector; - Right : Complex_Matrix) return Complex_Vector; - - function "*" - (Left : Complex_Matrix; - Right : Complex_Vector) return Complex_Vector; - - -- Mixed Real_Matrix and Complex_Matrix arithmetic operations - - function "+" - (Left : Real_Matrix; - Right : Complex_Matrix) return Complex_Matrix; - - function "+" - (Left : Complex_Matrix; - Right : Real_Matrix) return Complex_Matrix; - - function "-" - (Left : Real_Matrix; - Right : Complex_Matrix) return Complex_Matrix; - - function "-" - (Left : Complex_Matrix; - Right : Real_Matrix) return Complex_Matrix; - - function "*" - (Left : Real_Matrix; - Right : Complex_Matrix) return Complex_Matrix; - - function "*" - (Left : Complex_Matrix; - Right : Real_Matrix) return Complex_Matrix; - - function "*" - (Left : Real_Vector; - Right : Complex_Vector) return Complex_Matrix; - - function "*" - (Left : Complex_Vector; - Right : Real_Vector) return Complex_Matrix; - - function "*" - (Left : Real_Vector; - Right : Complex_Matrix) return Complex_Vector; - - function "*" - (Left : Complex_Vector; - Right : Real_Matrix) return Complex_Vector; - - function "*" - (Left : Real_Matrix; - Right : Complex_Vector) return Complex_Vector; - - function "*" - (Left : Complex_Matrix; - Right : Real_Vector) return Complex_Vector; - - -- Complex_Matrix scaling operations - - function "*" - (Left : Complex; - Right : Complex_Matrix) return Complex_Matrix; - - function "*" - (Left : Complex_Matrix; - Right : Complex) return Complex_Matrix; - - function "/" - (Left : Complex_Matrix; - Right : Complex) return Complex_Matrix; - - function "*" - (Left : Real'Base; - Right : Complex_Matrix) return Complex_Matrix; - - function "*" - (Left : Complex_Matrix; - Right : Real'Base) return Complex_Matrix; - - function "/" - (Left : Complex_Matrix; - Right : Real'Base) return Complex_Matrix; - - -- Complex_Matrix inversion and related operations - - function Solve - (A : Complex_Matrix; - X : Complex_Vector) return Complex_Vector; - - function Solve (A, X : Complex_Matrix) return Complex_Matrix; - - function Inverse (A : Complex_Matrix) return Complex_Matrix; - - function Determinant (A : Complex_Matrix) return Complex; - - -- Eigenvalues and vectors of a Hermitian matrix - - function Eigenvalues (A : Complex_Matrix) return Real_Vector; - - procedure Eigensystem - (A : Complex_Matrix; - Values : out Real_Vector; - Vectors : out Complex_Matrix); - - -- Other Complex_Matrix operations - - function Unit_Matrix - (Order : Positive; - First_1, First_2 : Integer := 1) return Complex_Matrix; - -end Ada.Numerics.Generic_Complex_Arrays; diff --git a/gcc/ada/a-ngcoty.adb b/gcc/ada/a-ngcoty.adb deleted file mode 100644 index 7cf4871..0000000 --- a/gcc/ada/a-ngcoty.adb +++ /dev/null @@ -1,681 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Aux; use Ada.Numerics.Aux; - -package body Ada.Numerics.Generic_Complex_Types is - - subtype R is Real'Base; - - Two_Pi : constant R := R (2.0) * Pi; - Half_Pi : constant R := Pi / R (2.0); - - --------- - -- "*" -- - --------- - - function "*" (Left, Right : Complex) return Complex is - - Scale : constant R := R (R'Machine_Radix) ** ((R'Machine_Emax - 1) / 2); - -- In case of overflow, scale the operands by the largest power of the - -- radix (to avoid rounding error), so that the square of the scale does - -- not overflow itself. - - X : R; - Y : R; - - begin - X := Left.Re * Right.Re - Left.Im * Right.Im; - Y := Left.Re * Right.Im + Left.Im * Right.Re; - - -- If either component overflows, try to scale (skip in fast math mode) - - if not Standard'Fast_Math then - - -- Note that the test below is written as a negation. This is to - -- account for the fact that X and Y may be NaNs, because both of - -- their operands could overflow. Given that all operations on NaNs - -- return false, the test can only be written thus. - - if not (abs (X) <= R'Last) then - X := Scale**2 * ((Left.Re / Scale) * (Right.Re / Scale) - - (Left.Im / Scale) * (Right.Im / Scale)); - end if; - - if not (abs (Y) <= R'Last) then - Y := Scale**2 * ((Left.Re / Scale) * (Right.Im / Scale) - + (Left.Im / Scale) * (Right.Re / Scale)); - end if; - end if; - - return (X, Y); - end "*"; - - function "*" (Left, Right : Imaginary) return Real'Base is - begin - return -(R (Left) * R (Right)); - end "*"; - - function "*" (Left : Complex; Right : Real'Base) return Complex is - begin - return Complex'(Left.Re * Right, Left.Im * Right); - end "*"; - - function "*" (Left : Real'Base; Right : Complex) return Complex is - begin - return (Left * Right.Re, Left * Right.Im); - end "*"; - - function "*" (Left : Complex; Right : Imaginary) return Complex is - begin - return Complex'(-(Left.Im * R (Right)), Left.Re * R (Right)); - end "*"; - - function "*" (Left : Imaginary; Right : Complex) return Complex is - begin - return Complex'(-(R (Left) * Right.Im), R (Left) * Right.Re); - end "*"; - - function "*" (Left : Imaginary; Right : Real'Base) return Imaginary is - begin - return Left * Imaginary (Right); - end "*"; - - function "*" (Left : Real'Base; Right : Imaginary) return Imaginary is - begin - return Imaginary (Left * R (Right)); - end "*"; - - ---------- - -- "**" -- - ---------- - - function "**" (Left : Complex; Right : Integer) return Complex is - Result : Complex := (1.0, 0.0); - Factor : Complex := Left; - Exp : Integer := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. For positive exponents we - -- multiply the result by this factor, for negative exponents, we - -- divide by this factor. - - if Exp >= 0 then - - -- For a positive exponent, if we get a constraint error during - -- this loop, it is an overflow, and the constraint error will - -- simply be passed on to the caller. - - while Exp /= 0 loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Factor := Factor * Factor; - Exp := Exp / 2; - end loop; - - return Result; - - else -- Exp < 0 then - - -- For the negative exponent case, a constraint error during this - -- calculation happens if Factor gets too large, and the proper - -- response is to return 0.0, since what we essentially have is - -- 1.0 / infinity, and the closest model number will be zero. - - begin - while Exp /= 0 loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Factor := Factor * Factor; - Exp := Exp / 2; - end loop; - - return R'(1.0) / Result; - - exception - when Constraint_Error => - return (0.0, 0.0); - end; - end if; - end "**"; - - function "**" (Left : Imaginary; Right : Integer) return Complex is - M : constant R := R (Left) ** Right; - begin - case Right mod 4 is - when 0 => return (M, 0.0); - when 1 => return (0.0, M); - when 2 => return (-M, 0.0); - when 3 => return (0.0, -M); - when others => raise Program_Error; - end case; - end "**"; - - --------- - -- "+" -- - --------- - - function "+" (Right : Complex) return Complex is - begin - return Right; - end "+"; - - function "+" (Left, Right : Complex) return Complex is - begin - return Complex'(Left.Re + Right.Re, Left.Im + Right.Im); - end "+"; - - function "+" (Right : Imaginary) return Imaginary is - begin - return Right; - end "+"; - - function "+" (Left, Right : Imaginary) return Imaginary is - begin - return Imaginary (R (Left) + R (Right)); - end "+"; - - function "+" (Left : Complex; Right : Real'Base) return Complex is - begin - return Complex'(Left.Re + Right, Left.Im); - end "+"; - - function "+" (Left : Real'Base; Right : Complex) return Complex is - begin - return Complex'(Left + Right.Re, Right.Im); - end "+"; - - function "+" (Left : Complex; Right : Imaginary) return Complex is - begin - return Complex'(Left.Re, Left.Im + R (Right)); - end "+"; - - function "+" (Left : Imaginary; Right : Complex) return Complex is - begin - return Complex'(Right.Re, R (Left) + Right.Im); - end "+"; - - function "+" (Left : Imaginary; Right : Real'Base) return Complex is - begin - return Complex'(Right, R (Left)); - end "+"; - - function "+" (Left : Real'Base; Right : Imaginary) return Complex is - begin - return Complex'(Left, R (Right)); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Right : Complex) return Complex is - begin - return (-Right.Re, -Right.Im); - end "-"; - - function "-" (Left, Right : Complex) return Complex is - begin - return (Left.Re - Right.Re, Left.Im - Right.Im); - end "-"; - - function "-" (Right : Imaginary) return Imaginary is - begin - return Imaginary (-R (Right)); - end "-"; - - function "-" (Left, Right : Imaginary) return Imaginary is - begin - return Imaginary (R (Left) - R (Right)); - end "-"; - - function "-" (Left : Complex; Right : Real'Base) return Complex is - begin - return Complex'(Left.Re - Right, Left.Im); - end "-"; - - function "-" (Left : Real'Base; Right : Complex) return Complex is - begin - return Complex'(Left - Right.Re, -Right.Im); - end "-"; - - function "-" (Left : Complex; Right : Imaginary) return Complex is - begin - return Complex'(Left.Re, Left.Im - R (Right)); - end "-"; - - function "-" (Left : Imaginary; Right : Complex) return Complex is - begin - return Complex'(-Right.Re, R (Left) - Right.Im); - end "-"; - - function "-" (Left : Imaginary; Right : Real'Base) return Complex is - begin - return Complex'(-Right, R (Left)); - end "-"; - - function "-" (Left : Real'Base; Right : Imaginary) return Complex is - begin - return Complex'(Left, -R (Right)); - end "-"; - - --------- - -- "/" -- - --------- - - function "/" (Left, Right : Complex) return Complex is - a : constant R := Left.Re; - b : constant R := Left.Im; - c : constant R := Right.Re; - d : constant R := Right.Im; - - begin - if c = 0.0 and then d = 0.0 then - raise Constraint_Error; - else - return Complex'(Re => ((a * c) + (b * d)) / (c ** 2 + d ** 2), - Im => ((b * c) - (a * d)) / (c ** 2 + d ** 2)); - end if; - end "/"; - - function "/" (Left, Right : Imaginary) return Real'Base is - begin - return R (Left) / R (Right); - end "/"; - - function "/" (Left : Complex; Right : Real'Base) return Complex is - begin - return Complex'(Left.Re / Right, Left.Im / Right); - end "/"; - - function "/" (Left : Real'Base; Right : Complex) return Complex is - a : constant R := Left; - c : constant R := Right.Re; - d : constant R := Right.Im; - begin - return Complex'(Re => (a * c) / (c ** 2 + d ** 2), - Im => -((a * d) / (c ** 2 + d ** 2))); - end "/"; - - function "/" (Left : Complex; Right : Imaginary) return Complex is - a : constant R := Left.Re; - b : constant R := Left.Im; - d : constant R := R (Right); - - begin - return (b / d, -(a / d)); - end "/"; - - function "/" (Left : Imaginary; Right : Complex) return Complex is - b : constant R := R (Left); - c : constant R := Right.Re; - d : constant R := Right.Im; - - begin - return (Re => b * d / (c ** 2 + d ** 2), - Im => b * c / (c ** 2 + d ** 2)); - end "/"; - - function "/" (Left : Imaginary; Right : Real'Base) return Imaginary is - begin - return Imaginary (R (Left) / Right); - end "/"; - - function "/" (Left : Real'Base; Right : Imaginary) return Imaginary is - begin - return Imaginary (-(Left / R (Right))); - end "/"; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Imaginary) return Boolean is - begin - return R (Left) < R (Right); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (Left, Right : Imaginary) return Boolean is - begin - return R (Left) <= R (Right); - end "<="; - - --------- - -- ">" -- - --------- - - function ">" (Left, Right : Imaginary) return Boolean is - begin - return R (Left) > R (Right); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (Left, Right : Imaginary) return Boolean is - begin - return R (Left) >= R (Right); - end ">="; - - ----------- - -- "abs" -- - ----------- - - function "abs" (Right : Imaginary) return Real'Base is - begin - return abs R (Right); - end "abs"; - - -------------- - -- Argument -- - -------------- - - function Argument (X : Complex) return Real'Base is - a : constant R := X.Re; - b : constant R := X.Im; - arg : R; - - begin - if b = 0.0 then - - if a >= 0.0 then - return 0.0; - else - return R'Copy_Sign (Pi, b); - end if; - - elsif a = 0.0 then - - if b >= 0.0 then - return Half_Pi; - else - return -Half_Pi; - end if; - - else - arg := R (Atan (Double (abs (b / a)))); - - if a > 0.0 then - if b > 0.0 then - return arg; - else -- b < 0.0 - return -arg; - end if; - - else -- a < 0.0 - if b >= 0.0 then - return Pi - arg; - else -- b < 0.0 - return -(Pi - arg); - end if; - end if; - end if; - - exception - when Constraint_Error => - if b > 0.0 then - return Half_Pi; - else - return -Half_Pi; - end if; - end Argument; - - function Argument (X : Complex; Cycle : Real'Base) return Real'Base is - begin - if Cycle > 0.0 then - return Argument (X) * Cycle / Two_Pi; - else - raise Argument_Error; - end if; - end Argument; - - ---------------------------- - -- Compose_From_Cartesian -- - ---------------------------- - - function Compose_From_Cartesian (Re, Im : Real'Base) return Complex is - begin - return (Re, Im); - end Compose_From_Cartesian; - - function Compose_From_Cartesian (Re : Real'Base) return Complex is - begin - return (Re, 0.0); - end Compose_From_Cartesian; - - function Compose_From_Cartesian (Im : Imaginary) return Complex is - begin - return (0.0, R (Im)); - end Compose_From_Cartesian; - - ------------------------ - -- Compose_From_Polar -- - ------------------------ - - function Compose_From_Polar ( - Modulus, Argument : Real'Base) - return Complex - is - begin - if Modulus = 0.0 then - return (0.0, 0.0); - else - return (Modulus * R (Cos (Double (Argument))), - Modulus * R (Sin (Double (Argument)))); - end if; - end Compose_From_Polar; - - function Compose_From_Polar ( - Modulus, Argument, Cycle : Real'Base) - return Complex - is - Arg : Real'Base; - - begin - if Modulus = 0.0 then - return (0.0, 0.0); - - elsif Cycle > 0.0 then - if Argument = 0.0 then - return (Modulus, 0.0); - - elsif Argument = Cycle / 4.0 then - return (0.0, Modulus); - - elsif Argument = Cycle / 2.0 then - return (-Modulus, 0.0); - - elsif Argument = 3.0 * Cycle / R (4.0) then - return (0.0, -Modulus); - else - Arg := Two_Pi * Argument / Cycle; - return (Modulus * R (Cos (Double (Arg))), - Modulus * R (Sin (Double (Arg)))); - end if; - else - raise Argument_Error; - end if; - end Compose_From_Polar; - - --------------- - -- Conjugate -- - --------------- - - function Conjugate (X : Complex) return Complex is - begin - return Complex'(X.Re, -X.Im); - end Conjugate; - - -------- - -- Im -- - -------- - - function Im (X : Complex) return Real'Base is - begin - return X.Im; - end Im; - - function Im (X : Imaginary) return Real'Base is - begin - return R (X); - end Im; - - ------------- - -- Modulus -- - ------------- - - function Modulus (X : Complex) return Real'Base is - Re2, Im2 : R; - - begin - - begin - Re2 := X.Re ** 2; - - -- To compute (a**2 + b**2) ** (0.5) when a**2 may be out of bounds, - -- compute a * (1 + (b/a) **2) ** (0.5). On a machine where the - -- squaring does not raise constraint_error but generates infinity, - -- we can use an explicit comparison to determine whether to use - -- the scaling expression. - - -- The scaling expression is computed in double format throughout - -- in order to prevent inaccuracies on machines where not all - -- immediate expressions are rounded, such as PowerPC. - - -- ??? same weird test, why not Re2 > R'Last ??? - if not (Re2 <= R'Last) then - raise Constraint_Error; - end if; - - exception - when Constraint_Error => - return R (Double (abs (X.Re)) - * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); - end; - - begin - Im2 := X.Im ** 2; - - -- ??? same weird test - if not (Im2 <= R'Last) then - raise Constraint_Error; - end if; - - exception - when Constraint_Error => - return R (Double (abs (X.Im)) - * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); - end; - - -- Now deal with cases of underflow. If only one of the squares - -- underflows, return the modulus of the other component. If both - -- squares underflow, use scaling as above. - - if Re2 = 0.0 then - - if X.Re = 0.0 then - return abs (X.Im); - - elsif Im2 = 0.0 then - - if X.Im = 0.0 then - return abs (X.Re); - - else - if abs (X.Re) > abs (X.Im) then - return - R (Double (abs (X.Re)) - * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); - else - return - R (Double (abs (X.Im)) - * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); - end if; - end if; - - else - return abs (X.Im); - end if; - - elsif Im2 = 0.0 then - return abs (X.Re); - - -- In all other cases, the naive computation will do - - else - return R (Sqrt (Double (Re2 + Im2))); - end if; - end Modulus; - - -------- - -- Re -- - -------- - - function Re (X : Complex) return Real'Base is - begin - return X.Re; - end Re; - - ------------ - -- Set_Im -- - ------------ - - procedure Set_Im (X : in out Complex; Im : Real'Base) is - begin - X.Im := Im; - end Set_Im; - - procedure Set_Im (X : out Imaginary; Im : Real'Base) is - begin - X := Imaginary (Im); - end Set_Im; - - ------------ - -- Set_Re -- - ------------ - - procedure Set_Re (X : in out Complex; Re : Real'Base) is - begin - X.Re := Re; - end Set_Re; - -end Ada.Numerics.Generic_Complex_Types; diff --git a/gcc/ada/a-ngcoty.ads b/gcc/ada/a-ngcoty.ads deleted file mode 100644 index 0b011e1..0000000 --- a/gcc/ada/a-ngcoty.ads +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -generic - type Real is digits <>; - -package Ada.Numerics.Generic_Complex_Types is - pragma Pure; - - type Complex is record - Re, Im : Real'Base; - end record; - - pragma Complex_Representation (Complex); - - type Imaginary is private; - pragma Preelaborable_Initialization (Imaginary); - - i : constant Imaginary; - j : constant Imaginary; - - function Re (X : Complex) return Real'Base; - function Im (X : Complex) return Real'Base; - function Im (X : Imaginary) return Real'Base; - - procedure Set_Re (X : in out Complex; Re : Real'Base); - procedure Set_Im (X : in out Complex; Im : Real'Base); - procedure Set_Im (X : out Imaginary; Im : Real'Base); - - function Compose_From_Cartesian (Re, Im : Real'Base) return Complex; - function Compose_From_Cartesian (Re : Real'Base) return Complex; - function Compose_From_Cartesian (Im : Imaginary) return Complex; - - function Modulus (X : Complex) return Real'Base; - function "abs" (Right : Complex) return Real'Base renames Modulus; - - function Argument (X : Complex) return Real'Base; - function Argument (X : Complex; Cycle : Real'Base) return Real'Base; - - function Compose_From_Polar ( - Modulus, Argument : Real'Base) - return Complex; - - function Compose_From_Polar ( - Modulus, Argument, Cycle : Real'Base) - return Complex; - - function "+" (Right : Complex) return Complex; - function "-" (Right : Complex) return Complex; - function Conjugate (X : Complex) return Complex; - - function "+" (Left, Right : Complex) return Complex; - function "-" (Left, Right : Complex) return Complex; - function "*" (Left, Right : Complex) return Complex; - function "/" (Left, Right : Complex) return Complex; - - function "**" (Left : Complex; Right : Integer) return Complex; - - function "+" (Right : Imaginary) return Imaginary; - function "-" (Right : Imaginary) return Imaginary; - function Conjugate (X : Imaginary) return Imaginary renames "-"; - function "abs" (Right : Imaginary) return Real'Base; - - function "+" (Left, Right : Imaginary) return Imaginary; - function "-" (Left, Right : Imaginary) return Imaginary; - function "*" (Left, Right : Imaginary) return Real'Base; - function "/" (Left, Right : Imaginary) return Real'Base; - - function "**" (Left : Imaginary; Right : Integer) return Complex; - - function "<" (Left, Right : Imaginary) return Boolean; - function "<=" (Left, Right : Imaginary) return Boolean; - function ">" (Left, Right : Imaginary) return Boolean; - function ">=" (Left, Right : Imaginary) return Boolean; - - function "+" (Left : Complex; Right : Real'Base) return Complex; - function "+" (Left : Real'Base; Right : Complex) return Complex; - function "-" (Left : Complex; Right : Real'Base) return Complex; - function "-" (Left : Real'Base; Right : Complex) return Complex; - function "*" (Left : Complex; Right : Real'Base) return Complex; - function "*" (Left : Real'Base; Right : Complex) return Complex; - function "/" (Left : Complex; Right : Real'Base) return Complex; - function "/" (Left : Real'Base; Right : Complex) return Complex; - - function "+" (Left : Complex; Right : Imaginary) return Complex; - function "+" (Left : Imaginary; Right : Complex) return Complex; - function "-" (Left : Complex; Right : Imaginary) return Complex; - function "-" (Left : Imaginary; Right : Complex) return Complex; - function "*" (Left : Complex; Right : Imaginary) return Complex; - function "*" (Left : Imaginary; Right : Complex) return Complex; - function "/" (Left : Complex; Right : Imaginary) return Complex; - function "/" (Left : Imaginary; Right : Complex) return Complex; - - function "+" (Left : Imaginary; Right : Real'Base) return Complex; - function "+" (Left : Real'Base; Right : Imaginary) return Complex; - function "-" (Left : Imaginary; Right : Real'Base) return Complex; - function "-" (Left : Real'Base; Right : Imaginary) return Complex; - - function "*" (Left : Imaginary; Right : Real'Base) return Imaginary; - function "*" (Left : Real'Base; Right : Imaginary) return Imaginary; - function "/" (Left : Imaginary; Right : Real'Base) return Imaginary; - function "/" (Left : Real'Base; Right : Imaginary) return Imaginary; - -private - type Imaginary is new Real'Base; - - i : constant Imaginary := 1.0; - j : constant Imaginary := 1.0; - - pragma Inline ("+"); - pragma Inline ("-"); - pragma Inline ("*"); - pragma Inline ("<"); - pragma Inline ("<="); - pragma Inline (">"); - pragma Inline (">="); - pragma Inline ("abs"); - pragma Inline (Compose_From_Cartesian); - pragma Inline (Conjugate); - pragma Inline (Im); - pragma Inline (Re); - pragma Inline (Set_Im); - pragma Inline (Set_Re); - -end Ada.Numerics.Generic_Complex_Types; diff --git a/gcc/ada/a-ngelfu.adb b/gcc/ada/a-ngelfu.adb deleted file mode 100644 index e7a75ee..0000000 --- a/gcc/ada/a-ngelfu.adb +++ /dev/null @@ -1,997 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This body is specifically for using an Ada interface to C math.h to get --- the computation engine. Many special cases are handled locally to avoid --- unnecessary calls or to meet Annex G strict mode requirements. - --- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, sinh, --- cosh, tanh from C library via math.h - -with Ada.Numerics.Aux; - -package body Ada.Numerics.Generic_Elementary_Functions with - SPARK_Mode => Off -is - - use type Ada.Numerics.Aux.Double; - - Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; - Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; - - Half_Log_Two : constant := Log_Two / 2; - - subtype T is Float_Type'Base; - subtype Double is Aux.Double; - - Two_Pi : constant T := 2.0 * Pi; - Half_Pi : constant T := Pi / 2.0; - - Half_Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Half_Log_Two; - Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two; - Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Exp_Strict (X : Float_Type'Base) return Float_Type'Base; - -- Cody/Waite routine, supposedly more precise than the library version. - -- Currently only needed for Sinh/Cosh on X86 with the largest FP type. - - function Local_Atan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0) return Float_Type'Base; - -- Common code for arc tangent after cycle reduction - - ---------- - -- "**" -- - ---------- - - function "**" (Left, Right : Float_Type'Base) return Float_Type'Base is - A_Right : Float_Type'Base; - Int_Part : Integer; - Result : Float_Type'Base; - R1 : Float_Type'Base; - Rest : Float_Type'Base; - - begin - if Left = 0.0 - and then Right = 0.0 - then - raise Argument_Error; - - elsif Left < 0.0 then - raise Argument_Error; - - elsif Right = 0.0 then - return 1.0; - - elsif Left = 0.0 then - if Right < 0.0 then - raise Constraint_Error; - else - return 0.0; - end if; - - elsif Left = 1.0 then - return 1.0; - - elsif Right = 1.0 then - return Left; - - else - begin - if Right = 2.0 then - return Left * Left; - - elsif Right = 0.5 then - return Sqrt (Left); - - else - A_Right := abs (Right); - - -- If exponent is larger than one, compute integer exponen- - -- tiation if possible, and evaluate fractional part with more - -- precision. The relative error is now proportional to the - -- fractional part of the exponent only. - - if A_Right > 1.0 - and then A_Right < Float_Type'Base (Integer'Last) - then - Int_Part := Integer (Float_Type'Base'Truncation (A_Right)); - Result := Left ** Int_Part; - Rest := A_Right - Float_Type'Base (Int_Part); - - -- Compute with two leading bits of the mantissa using - -- square roots. Bound to be better than logarithms, and - -- easily extended to greater precision. - - if Rest >= 0.5 then - R1 := Sqrt (Left); - Result := Result * R1; - Rest := Rest - 0.5; - - if Rest >= 0.25 then - Result := Result * Sqrt (R1); - Rest := Rest - 0.25; - end if; - - elsif Rest >= 0.25 then - Result := Result * Sqrt (Sqrt (Left)); - Rest := Rest - 0.25; - end if; - - Result := Result * - Float_Type'Base (Aux.Pow (Double (Left), Double (Rest))); - - if Right >= 0.0 then - return Result; - else - return (1.0 / Result); - end if; - else - return - Float_Type'Base (Aux.Pow (Double (Left), Double (Right))); - end if; - end if; - - exception - when others => - raise Constraint_Error; - end; - end if; - end "**"; - - ------------ - -- Arccos -- - ------------ - - -- Natural cycle - - function Arccos (X : Float_Type'Base) return Float_Type'Base is - Temp : Float_Type'Base; - - begin - if abs X > 1.0 then - raise Argument_Error; - - elsif abs X < Sqrt_Epsilon then - return Pi / 2.0 - X; - - elsif X = 1.0 then - return 0.0; - - elsif X = -1.0 then - return Pi; - end if; - - Temp := Float_Type'Base (Aux.Acos (Double (X))); - - if Temp < 0.0 then - Temp := Pi + Temp; - end if; - - return Temp; - end Arccos; - - -- Arbitrary cycle - - function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base is - Temp : Float_Type'Base; - - begin - if Cycle <= 0.0 then - raise Argument_Error; - - elsif abs X > 1.0 then - raise Argument_Error; - - elsif abs X < Sqrt_Epsilon then - return Cycle / 4.0; - - elsif X = 1.0 then - return 0.0; - - elsif X = -1.0 then - return Cycle / 2.0; - end if; - - Temp := Arctan (Sqrt ((1.0 - X) * (1.0 + X)) / X, 1.0, Cycle); - - if Temp < 0.0 then - Temp := Cycle / 2.0 + Temp; - end if; - - return Temp; - end Arccos; - - ------------- - -- Arccosh -- - ------------- - - function Arccosh (X : Float_Type'Base) return Float_Type'Base is - begin - -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or the proper - -- approximation for X close to 1 or >> 1. - - if X < 1.0 then - raise Argument_Error; - - elsif X < 1.0 + Sqrt_Epsilon then - return Sqrt (2.0 * (X - 1.0)); - - elsif X > 1.0 / Sqrt_Epsilon then - return Log (X) + Log_Two; - - else - return Log (X + Sqrt ((X - 1.0) * (X + 1.0))); - end if; - end Arccosh; - - ------------ - -- Arccot -- - ------------ - - -- Natural cycle - - function Arccot - (X : Float_Type'Base; - Y : Float_Type'Base := 1.0) - return Float_Type'Base - is - begin - -- Just reverse arguments - - return Arctan (Y, X); - end Arccot; - - -- Arbitrary cycle - - function Arccot - (X : Float_Type'Base; - Y : Float_Type'Base := 1.0; - Cycle : Float_Type'Base) - return Float_Type'Base - is - begin - -- Just reverse arguments - - return Arctan (Y, X, Cycle); - end Arccot; - - ------------- - -- Arccoth -- - ------------- - - function Arccoth (X : Float_Type'Base) return Float_Type'Base is - begin - if abs X > 2.0 then - return Arctanh (1.0 / X); - - elsif abs X = 1.0 then - raise Constraint_Error; - - elsif abs X < 1.0 then - raise Argument_Error; - - else - -- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the other - -- has error 0 or Epsilon. - - return 0.5 * (Log (abs (X + 1.0)) - Log (abs (X - 1.0))); - end if; - end Arccoth; - - ------------ - -- Arcsin -- - ------------ - - -- Natural cycle - - function Arcsin (X : Float_Type'Base) return Float_Type'Base is - begin - if abs X > 1.0 then - raise Argument_Error; - - elsif abs X < Sqrt_Epsilon then - return X; - - elsif X = 1.0 then - return Pi / 2.0; - - elsif X = -1.0 then - return -(Pi / 2.0); - end if; - - return Float_Type'Base (Aux.Asin (Double (X))); - end Arcsin; - - -- Arbitrary cycle - - function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base is - begin - if Cycle <= 0.0 then - raise Argument_Error; - - elsif abs X > 1.0 then - raise Argument_Error; - - elsif X = 0.0 then - return X; - - elsif X = 1.0 then - return Cycle / 4.0; - - elsif X = -1.0 then - return -(Cycle / 4.0); - end if; - - return Arctan (X / Sqrt ((1.0 - X) * (1.0 + X)), 1.0, Cycle); - end Arcsin; - - ------------- - -- Arcsinh -- - ------------- - - function Arcsinh (X : Float_Type'Base) return Float_Type'Base is - begin - if abs X < Sqrt_Epsilon then - return X; - - elsif X > 1.0 / Sqrt_Epsilon then - return Log (X) + Log_Two; - - elsif X < -(1.0 / Sqrt_Epsilon) then - return -(Log (-X) + Log_Two); - - elsif X < 0.0 then - return -Log (abs X + Sqrt (X * X + 1.0)); - - else - return Log (X + Sqrt (X * X + 1.0)); - end if; - end Arcsinh; - - ------------ - -- Arctan -- - ------------ - - -- Natural cycle - - function Arctan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0) - return Float_Type'Base - is - begin - if X = 0.0 and then Y = 0.0 then - raise Argument_Error; - - elsif Y = 0.0 then - if X > 0.0 then - return 0.0; - else -- X < 0.0 - return Pi * Float_Type'Copy_Sign (1.0, Y); - end if; - - elsif X = 0.0 then - return Float_Type'Copy_Sign (Half_Pi, Y); - - else - return Local_Atan (Y, X); - end if; - end Arctan; - - -- Arbitrary cycle - - function Arctan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0; - Cycle : Float_Type'Base) - return Float_Type'Base - is - begin - if Cycle <= 0.0 then - raise Argument_Error; - - elsif X = 0.0 and then Y = 0.0 then - raise Argument_Error; - - elsif Y = 0.0 then - if X > 0.0 then - return 0.0; - else -- X < 0.0 - return Cycle / 2.0 * Float_Type'Copy_Sign (1.0, Y); - end if; - - elsif X = 0.0 then - return Float_Type'Copy_Sign (Cycle / 4.0, Y); - - else - return Local_Atan (Y, X) * Cycle / Two_Pi; - end if; - end Arctan; - - ------------- - -- Arctanh -- - ------------- - - function Arctanh (X : Float_Type'Base) return Float_Type'Base is - A, B, D, A_Plus_1, A_From_1 : Float_Type'Base; - - Mantissa : constant Integer := Float_Type'Base'Machine_Mantissa; - - begin - -- The naive formula: - - -- Arctanh (X) := (1/2) * Log (1 + X) / (1 - X) - - -- is not well-behaved numerically when X < 0.5 and when X is close - -- to one. The following is accurate but probably not optimal. - - if abs X = 1.0 then - raise Constraint_Error; - - elsif abs X >= 1.0 - 2.0 ** (-Mantissa) then - - if abs X >= 1.0 then - raise Argument_Error; - else - - -- The one case that overflows if put through the method below: - -- abs X = 1.0 - Epsilon. In this case (1/2) log (2/Epsilon) is - -- accurate. This simplifies to: - - return Float_Type'Copy_Sign ( - Half_Log_Two * Float_Type'Base (Mantissa + 1), X); - end if; - - -- elsif abs X <= 0.5 then - -- why is above line commented out ??? - - else - -- Use several piecewise linear approximations. A is close to X, - -- chosen so 1.0 + A, 1.0 - A, and X - A are exact. The two scalings - -- remove the low-order bits of X. - - A := Float_Type'Base'Scaling ( - Float_Type'Base (Long_Long_Integer - (Float_Type'Base'Scaling (X, Mantissa - 1))), 1 - Mantissa); - - B := X - A; -- This is exact; abs B <= 2**(-Mantissa). - A_Plus_1 := 1.0 + A; -- This is exact. - A_From_1 := 1.0 - A; -- Ditto. - D := A_Plus_1 * A_From_1; -- 1 - A*A. - - -- use one term of the series expansion: - - -- f (x + e) = f(x) + e * f'(x) + .. - - -- The derivative of Arctanh at A is 1/(1-A*A). Next term is - -- A*(B/D)**2 (if a quadratic approximation is ever needed). - - return 0.5 * (Log (A_Plus_1) - Log (A_From_1)) + B / D; - end if; - end Arctanh; - - --------- - -- Cos -- - --------- - - -- Natural cycle - - function Cos (X : Float_Type'Base) return Float_Type'Base is - begin - if abs X < Sqrt_Epsilon then - return 1.0; - end if; - - return Float_Type'Base (Aux.Cos (Double (X))); - end Cos; - - -- Arbitrary cycle - - function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base is - begin - -- Just reuse the code for Sin. The potential small loss of speed is - -- negligible with proper (front-end) inlining. - - return -Sin (abs X - Cycle * 0.25, Cycle); - end Cos; - - ---------- - -- Cosh -- - ---------- - - function Cosh (X : Float_Type'Base) return Float_Type'Base is - Lnv : constant Float_Type'Base := 8#0.542714#; - V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; - Y : constant Float_Type'Base := abs X; - Z : Float_Type'Base; - - begin - if Y < Sqrt_Epsilon then - return 1.0; - - elsif Y > Log_Inverse_Epsilon then - Z := Exp_Strict (Y - Lnv); - return (Z + V2minus1 * Z); - - else - Z := Exp_Strict (Y); - return 0.5 * (Z + 1.0 / Z); - end if; - - end Cosh; - - --------- - -- Cot -- - --------- - - -- Natural cycle - - function Cot (X : Float_Type'Base) return Float_Type'Base is - begin - if X = 0.0 then - raise Constraint_Error; - - elsif abs X < Sqrt_Epsilon then - return 1.0 / X; - end if; - - return 1.0 / Float_Type'Base (Aux.Tan (Double (X))); - end Cot; - - -- Arbitrary cycle - - function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base is - T : Float_Type'Base; - - begin - if Cycle <= 0.0 then - raise Argument_Error; - end if; - - T := Float_Type'Base'Remainder (X, Cycle); - - if T = 0.0 or else abs T = 0.5 * Cycle then - raise Constraint_Error; - - elsif abs T < Sqrt_Epsilon then - return 1.0 / T; - - elsif abs T = 0.25 * Cycle then - return 0.0; - - else - T := T / Cycle * Two_Pi; - return Cos (T) / Sin (T); - end if; - end Cot; - - ---------- - -- Coth -- - ---------- - - function Coth (X : Float_Type'Base) return Float_Type'Base is - begin - if X = 0.0 then - raise Constraint_Error; - - elsif X < Half_Log_Epsilon then - return -1.0; - - elsif X > -Half_Log_Epsilon then - return 1.0; - - elsif abs X < Sqrt_Epsilon then - return 1.0 / X; - end if; - - return 1.0 / Float_Type'Base (Aux.Tanh (Double (X))); - end Coth; - - --------- - -- Exp -- - --------- - - function Exp (X : Float_Type'Base) return Float_Type'Base is - Result : Float_Type'Base; - - begin - if X = 0.0 then - return 1.0; - end if; - - Result := Float_Type'Base (Aux.Exp (Double (X))); - - -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows - -- is False, then we can just leave it as an infinity (and indeed we - -- prefer to do so). But if Machine_Overflows is True, then we have - -- to raise a Constraint_Error exception as required by the RM. - - if Float_Type'Machine_Overflows and then not Result'Valid then - raise Constraint_Error; - end if; - - return Result; - end Exp; - - ---------------- - -- Exp_Strict -- - ---------------- - - function Exp_Strict (X : Float_Type'Base) return Float_Type'Base is - G : Float_Type'Base; - Z : Float_Type'Base; - - P0 : constant := 0.25000_00000_00000_00000; - P1 : constant := 0.75753_18015_94227_76666E-2; - P2 : constant := 0.31555_19276_56846_46356E-4; - - Q0 : constant := 0.5; - Q1 : constant := 0.56817_30269_85512_21787E-1; - Q2 : constant := 0.63121_89437_43985_02557E-3; - Q3 : constant := 0.75104_02839_98700_46114E-6; - - C1 : constant := 8#0.543#; - C2 : constant := -2.1219_44400_54690_58277E-4; - Le : constant := 1.4426_95040_88896_34074; - - XN : Float_Type'Base; - P, Q, R : Float_Type'Base; - - begin - if X = 0.0 then - return 1.0; - end if; - - XN := Float_Type'Base'Rounding (X * Le); - G := (X - XN * C1) - XN * C2; - Z := G * G; - P := G * ((P2 * Z + P1) * Z + P0); - Q := ((Q3 * Z + Q2) * Z + Q1) * Z + Q0; - R := 0.5 + P / (Q - P); - - R := Float_Type'Base'Scaling (R, Integer (XN) + 1); - - -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows - -- is False, then we can just leave it as an infinity (and indeed we - -- prefer to do so). But if Machine_Overflows is True, then we have to - -- raise a Constraint_Error exception as required by the RM. - - if Float_Type'Machine_Overflows and then not R'Valid then - raise Constraint_Error; - else - return R; - end if; - - end Exp_Strict; - - ---------------- - -- Local_Atan -- - ---------------- - - function Local_Atan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0) return Float_Type'Base - is - Z : Float_Type'Base; - Raw_Atan : Float_Type'Base; - - begin - Z := (if abs Y > abs X then abs (X / Y) else abs (Y / X)); - - Raw_Atan := - (if Z < Sqrt_Epsilon then Z - elsif Z = 1.0 then Pi / 4.0 - else Float_Type'Base (Aux.Atan (Double (Z)))); - - if abs Y > abs X then - Raw_Atan := Half_Pi - Raw_Atan; - end if; - - if X > 0.0 then - return Float_Type'Copy_Sign (Raw_Atan, Y); - else - return Float_Type'Copy_Sign (Pi - Raw_Atan, Y); - end if; - end Local_Atan; - - --------- - -- Log -- - --------- - - -- Natural base - - function Log (X : Float_Type'Base) return Float_Type'Base is - begin - if X < 0.0 then - raise Argument_Error; - - elsif X = 0.0 then - raise Constraint_Error; - - elsif X = 1.0 then - return 0.0; - end if; - - return Float_Type'Base (Aux.Log (Double (X))); - end Log; - - -- Arbitrary base - - function Log (X, Base : Float_Type'Base) return Float_Type'Base is - begin - if X < 0.0 then - raise Argument_Error; - - elsif Base <= 0.0 or else Base = 1.0 then - raise Argument_Error; - - elsif X = 0.0 then - raise Constraint_Error; - - elsif X = 1.0 then - return 0.0; - end if; - - return Float_Type'Base (Aux.Log (Double (X)) / Aux.Log (Double (Base))); - end Log; - - --------- - -- Sin -- - --------- - - -- Natural cycle - - function Sin (X : Float_Type'Base) return Float_Type'Base is - begin - if abs X < Sqrt_Epsilon then - return X; - end if; - - return Float_Type'Base (Aux.Sin (Double (X))); - end Sin; - - -- Arbitrary cycle - - function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base is - T : Float_Type'Base; - - begin - if Cycle <= 0.0 then - raise Argument_Error; - - -- If X is zero, return it as the result, preserving the argument sign. - -- Is this test really needed on any machine ??? - - elsif X = 0.0 then - return X; - end if; - - T := Float_Type'Base'Remainder (X, Cycle); - - -- The following two reductions reduce the argument to the interval - -- [-0.25 * Cycle, 0.25 * Cycle]. This reduction is exact and is needed - -- to prevent inaccuracy that may result if the sine function uses a - -- different (more accurate) value of Pi in its reduction than is used - -- in the multiplication with Two_Pi. - - if abs T > 0.25 * Cycle then - T := 0.5 * Float_Type'Copy_Sign (Cycle, T) - T; - end if; - - -- Could test for 12.0 * abs T = Cycle, and return an exact value in - -- those cases. It is not clear this is worth the extra test though. - - return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi))); - end Sin; - - ---------- - -- Sinh -- - ---------- - - function Sinh (X : Float_Type'Base) return Float_Type'Base is - Lnv : constant Float_Type'Base := 8#0.542714#; - V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; - Y : constant Float_Type'Base := abs X; - F : constant Float_Type'Base := Y * Y; - Z : Float_Type'Base; - - Float_Digits_1_6 : constant Boolean := Float_Type'Digits < 7; - - begin - if Y < Sqrt_Epsilon then - return X; - - elsif Y > Log_Inverse_Epsilon then - Z := Exp_Strict (Y - Lnv); - Z := Z + V2minus1 * Z; - - elsif Y < 1.0 then - - if Float_Digits_1_6 then - - -- Use expansion provided by Cody and Waite, p. 226. Note that - -- leading term of the polynomial in Q is exactly 1.0. - - declare - P0 : constant := -0.71379_3159E+1; - P1 : constant := -0.19033_3399E+0; - Q0 : constant := -0.42827_7109E+2; - - begin - Z := Y + Y * F * (P1 * F + P0) / (F + Q0); - end; - - else - declare - P0 : constant := -0.35181_28343_01771_17881E+6; - P1 : constant := -0.11563_52119_68517_68270E+5; - P2 : constant := -0.16375_79820_26307_51372E+3; - P3 : constant := -0.78966_12741_73570_99479E+0; - Q0 : constant := -0.21108_77005_81062_71242E+7; - Q1 : constant := 0.36162_72310_94218_36460E+5; - Q2 : constant := -0.27773_52311_96507_01667E+3; - - begin - Z := Y + Y * F * (((P3 * F + P2) * F + P1) * F + P0) - / (((F + Q2) * F + Q1) * F + Q0); - end; - end if; - - else - Z := Exp_Strict (Y); - Z := 0.5 * (Z - 1.0 / Z); - end if; - - if X > 0.0 then - return Z; - else - return -Z; - end if; - end Sinh; - - ---------- - -- Sqrt -- - ---------- - - function Sqrt (X : Float_Type'Base) return Float_Type'Base is - begin - if X < 0.0 then - raise Argument_Error; - - -- Special case Sqrt (0.0) to preserve possible minus sign per IEEE - - elsif X = 0.0 then - return X; - end if; - - return Float_Type'Base (Aux.Sqrt (Double (X))); - end Sqrt; - - --------- - -- Tan -- - --------- - - -- Natural cycle - - function Tan (X : Float_Type'Base) return Float_Type'Base is - begin - if abs X < Sqrt_Epsilon then - return X; - end if; - - -- Note: if X is exactly pi/2, then we should raise an exception, since - -- the result would overflow. But for all floating-point formats we deal - -- with, it is impossible for X to be exactly pi/2, and the result is - -- always in range. - - return Float_Type'Base (Aux.Tan (Double (X))); - end Tan; - - -- Arbitrary cycle - - function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base is - T : Float_Type'Base; - - begin - if Cycle <= 0.0 then - raise Argument_Error; - - elsif X = 0.0 then - return X; - end if; - - T := Float_Type'Base'Remainder (X, Cycle); - - if abs T = 0.25 * Cycle then - raise Constraint_Error; - - elsif abs T = 0.5 * Cycle then - return 0.0; - - else - T := T / Cycle * Two_Pi; - return Sin (T) / Cos (T); - end if; - - end Tan; - - ---------- - -- Tanh -- - ---------- - - function Tanh (X : Float_Type'Base) return Float_Type'Base is - P0 : constant Float_Type'Base := -0.16134_11902_39962_28053E+4; - P1 : constant Float_Type'Base := -0.99225_92967_22360_83313E+2; - P2 : constant Float_Type'Base := -0.96437_49277_72254_69787E+0; - - Q0 : constant Float_Type'Base := 0.48402_35707_19886_88686E+4; - Q1 : constant Float_Type'Base := 0.22337_72071_89623_12926E+4; - Q2 : constant Float_Type'Base := 0.11274_47438_05349_49335E+3; - Q3 : constant Float_Type'Base := 0.10000_00000_00000_00000E+1; - - Half_Ln3 : constant Float_Type'Base := 0.54930_61443_34054_84570; - - P, Q, R : Float_Type'Base; - Y : constant Float_Type'Base := abs X; - G : constant Float_Type'Base := Y * Y; - - Float_Type_Digits_15_Or_More : constant Boolean := - Float_Type'Digits > 14; - - begin - if X < Half_Log_Epsilon then - return -1.0; - - elsif X > -Half_Log_Epsilon then - return 1.0; - - elsif Y < Sqrt_Epsilon then - return X; - - elsif Y < Half_Ln3 - and then Float_Type_Digits_15_Or_More - then - P := (P2 * G + P1) * G + P0; - Q := ((Q3 * G + Q2) * G + Q1) * G + Q0; - R := G * (P / Q); - return X + X * R; - - else - return Float_Type'Base (Aux.Tanh (Double (X))); - end if; - end Tanh; - -end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/a-ngelfu.ads b/gcc/ada/a-ngelfu.ads deleted file mode 100644 index 52a00d2..0000000 --- a/gcc/ada/a-ngelfu.ads +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2012-2017, 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 Post aspects that have been added to the spec. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -generic - type Float_Type is digits <>; - -package Ada.Numerics.Generic_Elementary_Functions with - SPARK_Mode => On -is - pragma Pure; - - -- Preconditions in this unit are meant for analysis only, not for run-time - -- checking, so that the expected exceptions are raised when calling - -- Assert. This is enforced by setting the corresponding assertion policy - -- to Ignore. This is done in the generic spec so that it applies to all - -- instances. - - pragma Assertion_Policy (Pre => Ignore); - - function Sqrt (X : Float_Type'Base) return Float_Type'Base with - Pre => X >= 0.0, - Post => Sqrt'Result >= 0.0 - and then (if X = 0.0 then Sqrt'Result = 0.0) - and then (if X = 1.0 then Sqrt'Result = 1.0) - - -- Finally if X is positive, the result of Sqrt is positive (because - -- the sqrt of numbers greater than 1 is greater than or equal to 1, - -- and the sqrt of numbers less than 1 is greater than the argument). - - -- This property is useful in particular for static analysis. The - -- property that X is positive is not expressed as (X > 0.0), as - -- the value X may be held in registers that have larger range and - -- precision on some architecture (for example, on x86 using x387 - -- FPU, as opposed to SSE2). So, it might be possible for X to be - -- 2.0**(-5000) or so, which could cause the number to compare as - -- greater than 0, but Sqrt would still return a zero result. - - -- Note: we use the comparison with Succ (0.0) here because this is - -- more amenable to CodePeer analysis than the use of 'Machine. - - and then (if X >= Float_Type'Succ (0.0) then Sqrt'Result > 0.0); - - function Log (X : Float_Type'Base) return Float_Type'Base with - Pre => X > 0.0, - Post => (if X = 1.0 then Log'Result = 0.0); - - function Log (X, Base : Float_Type'Base) return Float_Type'Base with - Pre => X > 0.0 and Base > 0.0 and Base /= 1.0, - Post => (if X = 1.0 then Log'Result = 0.0); - - function Exp (X : Float_Type'Base) return Float_Type'Base with - Post => (if X = 0.0 then Exp'Result = 1.0); - - function "**" (Left, Right : Float_Type'Base) return Float_Type'Base with - Pre => (if Left = 0.0 then Right > 0.0) and Left >= 0.0, - Post => "**"'Result >= 0.0 - and then (if Right = 0.0 then "**"'Result = 1.0) - and then (if Right = 1.0 then "**"'Result = Left) - and then (if Left = 1.0 then "**"'Result = 1.0) - and then (if Left = 0.0 then "**"'Result = 0.0); - - function Sin (X : Float_Type'Base) return Float_Type'Base with - Post => Sin'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Sin'Result = 0.0); - - function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base with - Pre => Cycle > 0.0, - Post => Sin'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Sin'Result = 0.0); - - function Cos (X : Float_Type'Base) return Float_Type'Base with - Post => Cos'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Cos'Result = 1.0); - - function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base with - Pre => Cycle > 0.0, - Post => Cos'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Cos'Result = 1.0); - - function Tan (X : Float_Type'Base) return Float_Type'Base with - Post => (if X = 0.0 then Tan'Result = 0.0); - - function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base with - Pre => Cycle > 0.0 - and then abs Float_Type'Base'Remainder (X, Cycle) /= 0.25 * Cycle, - Post => (if X = 0.0 then Tan'Result = 0.0); - - function Cot (X : Float_Type'Base) return Float_Type'Base with - Pre => X /= 0.0; - - function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base with - Pre => Cycle > 0.0 - and then X /= 0.0 - and then Float_Type'Base'Remainder (X, Cycle) /= 0.0 - and then abs Float_Type'Base'Remainder (X, Cycle) = 0.5 * Cycle; - - function Arcsin (X : Float_Type'Base) return Float_Type'Base with - Pre => abs X <= 1.0, - Post => (if X = 0.0 then Arcsin'Result = 0.0); - - function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base with - Pre => Cycle > 0.0 and abs X <= 1.0, - Post => (if X = 0.0 then Arcsin'Result = 0.0); - - function Arccos (X : Float_Type'Base) return Float_Type'Base with - Pre => abs X <= 1.0, - Post => (if X = 1.0 then Arccos'Result = 0.0); - - function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base with - Pre => Cycle > 0.0 and abs X <= 1.0, - Post => (if X = 1.0 then Arccos'Result = 0.0); - - function Arctan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0) return Float_Type'Base - with - Pre => X /= 0.0 or Y /= 0.0, - Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0); - - function Arctan - (Y : Float_Type'Base; - X : Float_Type'Base := 1.0; - Cycle : Float_Type'Base) return Float_Type'Base - with - Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0), - Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0); - - function Arccot - (X : Float_Type'Base; - Y : Float_Type'Base := 1.0) return Float_Type'Base - with - Pre => X /= 0.0 or Y /= 0.0, - Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0); - - function Arccot - (X : Float_Type'Base; - Y : Float_Type'Base := 1.0; - Cycle : Float_Type'Base) return Float_Type'Base - with - Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0), - Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0); - - function Sinh (X : Float_Type'Base) return Float_Type'Base with - Post => (if X = 0.0 then Sinh'Result = 0.0); - - function Cosh (X : Float_Type'Base) return Float_Type'Base with - Post => Cosh'Result >= 1.0 - and then (if X = 0.0 then Cosh'Result = 1.0); - - function Tanh (X : Float_Type'Base) return Float_Type'Base with - Post => Tanh'Result in -1.0 .. 1.0 - and then (if X = 0.0 then Tanh'Result = 0.0); - - function Coth (X : Float_Type'Base) return Float_Type'Base with - Pre => X /= 0.0, - Post => abs Coth'Result >= 1.0; - - function Arcsinh (X : Float_Type'Base) return Float_Type'Base with - Post => (if X = 0.0 then Arcsinh'Result = 0.0); - - function Arccosh (X : Float_Type'Base) return Float_Type'Base with - Pre => X >= 1.0, - Post => Arccosh'Result >= 0.0 - and then (if X = 1.0 then Arccosh'Result = 0.0); - - function Arctanh (X : Float_Type'Base) return Float_Type'Base with - Pre => abs X /= 1.0, - Post => (if X = 0.0 then Arctanh'Result = 0.0); - - function Arccoth (X : Float_Type'Base) return Float_Type'Base with - Pre => X <= 1.0 and abs X /= 1.0; - -end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/a-ngrear.adb b/gcc/ada/a-ngrear.adb deleted file mode 100644 index 64df675..0000000 --- a/gcc/ada/a-ngrear.adb +++ /dev/null @@ -1,777 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_REAL_ARRAYS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of Generic_Real_Arrays avoids the use of BLAS and LAPACK. One --- reason for this is new Ada 2012 requirements that prohibit algorithms such --- as Strassen's algorithm, which may be used by some BLAS implementations. In --- addition, some platforms lacked suitable compilers to compile the reference --- BLAS/LAPACK implementation. Finally, on some platforms there are more --- floating point types than supported by BLAS/LAPACK. - -with Ada.Containers.Generic_Anonymous_Array_Sort; use Ada.Containers; - -with System; use System; -with System.Generic_Array_Operations; use System.Generic_Array_Operations; - -package body Ada.Numerics.Generic_Real_Arrays is - - package Ops renames System.Generic_Array_Operations; - - function Is_Non_Zero (X : Real'Base) return Boolean is (X /= 0.0); - - procedure Back_Substitute is new Ops.Back_Substitute - (Scalar => Real'Base, - Matrix => Real_Matrix, - Is_Non_Zero => Is_Non_Zero); - - function Diagonal is new Ops.Diagonal - (Scalar => Real'Base, - Vector => Real_Vector, - Matrix => Real_Matrix); - - procedure Forward_Eliminate is new Ops.Forward_Eliminate - (Scalar => Real'Base, - Real => Real'Base, - Matrix => Real_Matrix, - Zero => 0.0, - One => 1.0); - - procedure Swap_Column is new Ops.Swap_Column - (Scalar => Real'Base, - Matrix => Real_Matrix); - - procedure Transpose is new Ops.Transpose - (Scalar => Real'Base, - Matrix => Real_Matrix); - - function Is_Symmetric (A : Real_Matrix) return Boolean is - (Transpose (A) = A); - -- Return True iff A is symmetric, see RM G.3.1 (90). - - function Is_Tiny (Value, Compared_To : Real) return Boolean is - (abs Compared_To + 100.0 * abs (Value) = abs Compared_To); - -- Return True iff the Value is much smaller in magnitude than the least - -- significant digit of Compared_To. - - procedure Jacobi - (A : Real_Matrix; - Values : out Real_Vector; - Vectors : out Real_Matrix; - Compute_Vectors : Boolean := True); - -- Perform Jacobi's eigensystem algorithm on real symmetric matrix A - - function Length is new Square_Matrix_Length (Real'Base, Real_Matrix); - -- Helper function that raises a Constraint_Error is the argument is - -- not a square matrix, and otherwise returns its length. - - procedure Rotate (X, Y : in out Real; Sin, Tau : Real); - -- Perform a Givens rotation - - procedure Sort_Eigensystem - (Values : in out Real_Vector; - Vectors : in out Real_Matrix); - -- Sort Values and associated Vectors by decreasing absolute value - - procedure Swap (Left, Right : in out Real); - -- Exchange Left and Right - - function Sqrt is new Ops.Sqrt (Real); - -- Instant a generic square root implementation here, in order to avoid - -- instantiating a complete copy of Generic_Elementary_Functions. - -- Speed of the square root is not a big concern here. - - ------------ - -- Rotate -- - ------------ - - procedure Rotate (X, Y : in out Real; Sin, Tau : Real) is - Old_X : constant Real := X; - Old_Y : constant Real := Y; - begin - X := Old_X - Sin * (Old_Y + Old_X * Tau); - Y := Old_Y + Sin * (Old_X - Old_Y * Tau); - end Rotate; - - ---------- - -- Swap -- - ---------- - - procedure Swap (Left, Right : in out Real) is - Temp : constant Real := Left; - begin - Left := Right; - Right := Temp; - end Swap; - - -- Instantiating the following subprograms directly would lead to - -- name clashes, so use a local package. - - package Instantiations is - - function "+" is new - Vector_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Real'Base, - X_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "+"); - - function "+" is new - Matrix_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Real'Base, - X_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "+"); - - function "+" is new - Vector_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Real_Vector, - Right_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "+"); - - function "+" is new - Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Matrix => Real_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "+"); - - function "-" is new - Vector_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Real'Base, - X_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "-"); - - function "-" is new - Matrix_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Real'Base, - X_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "-"); - - function "-" is new - Vector_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Real_Vector, - Right_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "-"); - - function "-" is new - Matrix_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Matrix => Real_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "-"); - - function "*" is new - Scalar_Vector_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Right_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "*"); - - function "*" is new - Scalar_Matrix_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Right_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "*"); - - function "*" is new - Vector_Scalar_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "*"); - - function "*" is new - Matrix_Scalar_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "*"); - - function "*" is new - Outer_Product - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Real_Vector, - Right_Vector => Real_Vector, - Matrix => Real_Matrix); - - function "*" is new - Inner_Product - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Real_Vector, - Right_Vector => Real_Vector, - Zero => 0.0); - - function "*" is new - Matrix_Vector_Product - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Matrix => Real_Matrix, - Right_Vector => Real_Vector, - Result_Vector => Real_Vector, - Zero => 0.0); - - function "*" is new - Vector_Matrix_Product - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Real_Vector, - Matrix => Real_Matrix, - Result_Vector => Real_Vector, - Zero => 0.0); - - function "*" is new - Matrix_Matrix_Product - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Matrix => Real_Matrix, - Right_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Zero => 0.0); - - function "/" is new - Vector_Scalar_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "/"); - - function "/" is new - Matrix_Scalar_Elementwise_Operation - (Left_Scalar => Real'Base, - Right_Scalar => Real'Base, - Result_Scalar => Real'Base, - Left_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "/"); - - function "abs" is new - L2_Norm - (X_Scalar => Real'Base, - Result_Real => Real'Base, - X_Vector => Real_Vector, - "abs" => "+"); - -- While the L2_Norm by definition uses the absolute values of the - -- elements of X_Vector, for real values the subsequent squaring - -- makes this unnecessary, so we substitute the "+" identity function - -- instead. - - function "abs" is new - Vector_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Real'Base, - X_Vector => Real_Vector, - Result_Vector => Real_Vector, - Operation => "abs"); - - function "abs" is new - Matrix_Elementwise_Operation - (X_Scalar => Real'Base, - Result_Scalar => Real'Base, - X_Matrix => Real_Matrix, - Result_Matrix => Real_Matrix, - Operation => "abs"); - - function Solve is new - Matrix_Vector_Solution (Real'Base, 0.0, Real_Vector, Real_Matrix); - - function Solve is new - Matrix_Matrix_Solution (Real'Base, 0.0, Real_Matrix); - - function Unit_Matrix is new - Generic_Array_Operations.Unit_Matrix - (Scalar => Real'Base, - Matrix => Real_Matrix, - Zero => 0.0, - One => 1.0); - - function Unit_Vector is new - Generic_Array_Operations.Unit_Vector - (Scalar => Real'Base, - Vector => Real_Vector, - Zero => 0.0, - One => 1.0); - - end Instantiations; - - --------- - -- "+" -- - --------- - - function "+" (Right : Real_Vector) return Real_Vector - renames Instantiations."+"; - - function "+" (Right : Real_Matrix) return Real_Matrix - renames Instantiations."+"; - - function "+" (Left, Right : Real_Vector) return Real_Vector - renames Instantiations."+"; - - function "+" (Left, Right : Real_Matrix) return Real_Matrix - renames Instantiations."+"; - - --------- - -- "-" -- - --------- - - function "-" (Right : Real_Vector) return Real_Vector - renames Instantiations."-"; - - function "-" (Right : Real_Matrix) return Real_Matrix - renames Instantiations."-"; - - function "-" (Left, Right : Real_Vector) return Real_Vector - renames Instantiations."-"; - - function "-" (Left, Right : Real_Matrix) return Real_Matrix - renames Instantiations."-"; - - --------- - -- "*" -- - --------- - - -- Scalar multiplication - - function "*" (Left : Real'Base; Right : Real_Vector) return Real_Vector - renames Instantiations."*"; - - function "*" (Left : Real_Vector; Right : Real'Base) return Real_Vector - renames Instantiations."*"; - - function "*" (Left : Real'Base; Right : Real_Matrix) return Real_Matrix - renames Instantiations."*"; - - function "*" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix - renames Instantiations."*"; - - -- Vector multiplication - - function "*" (Left, Right : Real_Vector) return Real'Base - renames Instantiations."*"; - - function "*" (Left, Right : Real_Vector) return Real_Matrix - renames Instantiations."*"; - - function "*" (Left : Real_Vector; Right : Real_Matrix) return Real_Vector - renames Instantiations."*"; - - function "*" (Left : Real_Matrix; Right : Real_Vector) return Real_Vector - renames Instantiations."*"; - - -- Matrix Multiplication - - function "*" (Left, Right : Real_Matrix) return Real_Matrix - renames Instantiations."*"; - - --------- - -- "/" -- - --------- - - function "/" (Left : Real_Vector; Right : Real'Base) return Real_Vector - renames Instantiations."/"; - - function "/" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix - renames Instantiations."/"; - - ----------- - -- "abs" -- - ----------- - - function "abs" (Right : Real_Vector) return Real'Base - renames Instantiations."abs"; - - function "abs" (Right : Real_Vector) return Real_Vector - renames Instantiations."abs"; - - function "abs" (Right : Real_Matrix) return Real_Matrix - renames Instantiations."abs"; - - ----------------- - -- Determinant -- - ----------------- - - function Determinant (A : Real_Matrix) return Real'Base is - M : Real_Matrix := A; - B : Real_Matrix (A'Range (1), 1 .. 0); - R : Real'Base; - begin - Forward_Eliminate (M, B, R); - return R; - end Determinant; - - ----------------- - -- Eigensystem -- - ----------------- - - procedure Eigensystem - (A : Real_Matrix; - Values : out Real_Vector; - Vectors : out Real_Matrix) - is - begin - Jacobi (A, Values, Vectors, Compute_Vectors => True); - Sort_Eigensystem (Values, Vectors); - end Eigensystem; - - ----------------- - -- Eigenvalues -- - ----------------- - - function Eigenvalues (A : Real_Matrix) return Real_Vector is - begin - return Values : Real_Vector (A'Range (1)) do - declare - Vectors : Real_Matrix (1 .. 0, 1 .. 0); - begin - Jacobi (A, Values, Vectors, Compute_Vectors => False); - Sort_Eigensystem (Values, Vectors); - end; - end return; - end Eigenvalues; - - ------------- - -- Inverse -- - ------------- - - function Inverse (A : Real_Matrix) return Real_Matrix is - (Solve (A, Unit_Matrix (Length (A), - First_1 => A'First (2), - First_2 => A'First (1)))); - - ------------ - -- Jacobi -- - ------------ - - procedure Jacobi - (A : Real_Matrix; - Values : out Real_Vector; - Vectors : out Real_Matrix; - Compute_Vectors : Boolean := True) - is - -- This subprogram uses Carl Gustav Jacob Jacobi's iterative method - -- for computing eigenvalues and eigenvectors and is based on - -- Rutishauser's implementation. - - -- The given real symmetric matrix is transformed iteratively to - -- diagonal form through a sequence of appropriately chosen elementary - -- orthogonal transformations, called Jacobi rotations here. - - -- The Jacobi method produces a systematic decrease of the sum of the - -- squares of off-diagonal elements. Convergence to zero is quadratic, - -- both for this implementation, as for the classic method that doesn't - -- use row-wise scanning for pivot selection. - - -- The numerical stability and accuracy of Jacobi's method make it the - -- best choice here, even though for large matrices other methods will - -- be significantly more efficient in both time and space. - - -- While the eigensystem computations are absolutely foolproof for all - -- real symmetric matrices, in presence of invalid values, or similar - -- exceptional situations it might not. In such cases the results cannot - -- be trusted and Constraint_Error is raised. - - -- Note: this implementation needs temporary storage for 2 * N + N**2 - -- values of type Real. - - Max_Iterations : constant := 50; - N : constant Natural := Length (A); - - subtype Square_Matrix is Real_Matrix (1 .. N, 1 .. N); - - -- In order to annihilate the M (Row, Col) element, the - -- rotation parameters Cos and Sin are computed as - -- follows: - - -- Theta = Cot (2.0 * Phi) - -- = (Diag (Col) - Diag (Row)) / (2.0 * M (Row, Col)) - - -- Then Tan (Phi) as the smaller root (in modulus) of - - -- T**2 + 2 * T * Theta = 1 (or 0.5 / Theta, if Theta is large) - - function Compute_Tan (Theta : Real) return Real is - (Real'Copy_Sign (1.0 / (abs Theta + Sqrt (1.0 + Theta**2)), Theta)); - - function Compute_Tan (P, H : Real) return Real is - (if Is_Tiny (P, Compared_To => H) then P / H - else Compute_Tan (Theta => H / (2.0 * P))); - - function Sum_Strict_Upper (M : Square_Matrix) return Real; - -- Return the sum of all elements in the strict upper triangle of M - - ---------------------- - -- Sum_Strict_Upper -- - ---------------------- - - function Sum_Strict_Upper (M : Square_Matrix) return Real is - Sum : Real := 0.0; - - begin - for Row in 1 .. N - 1 loop - for Col in Row + 1 .. N loop - Sum := Sum + abs M (Row, Col); - end loop; - end loop; - - return Sum; - end Sum_Strict_Upper; - - M : Square_Matrix := A; -- Work space for solving eigensystem - Threshold : Real; - Sum : Real; - Diag : Real_Vector (1 .. N); - Diag_Adj : Real_Vector (1 .. N); - - -- The vector Diag_Adj indicates the amount of change in each value, - -- while Diag tracks the value itself and Values holds the values as - -- they were at the beginning. As the changes typically will be small - -- compared to the absolute value of Diag, at the end of each iteration - -- Diag is computed as Diag + Diag_Adj thus avoiding accumulating - -- rounding errors. This technique is due to Rutishauser. - - begin - if Compute_Vectors - and then (Vectors'Length (1) /= N or else Vectors'Length (2) /= N) - then - raise Constraint_Error with "incompatible matrix dimensions"; - - elsif Values'Length /= N then - raise Constraint_Error with "incompatible vector length"; - - elsif not Is_Symmetric (M) then - raise Constraint_Error with "matrix not symmetric"; - end if; - - -- Note: Only the locally declared matrix M and vectors (Diag, Diag_Adj) - -- have lower bound equal to 1. The Vectors matrix may have - -- different bounds, so take care indexing elements. Assignment - -- as a whole is fine as sliding is automatic in that case. - - Vectors := (if not Compute_Vectors then (1 .. 0 => (1 .. 0 => 0.0)) - else Unit_Matrix (Vectors'Length (1), Vectors'Length (2))); - Values := Diagonal (M); - - Sweep : for Iteration in 1 .. Max_Iterations loop - - -- The first three iterations, perform rotation for any non-zero - -- element. After this, rotate only for those that are not much - -- smaller than the average off-diagnal element. After the fifth - -- iteration, additionally zero out off-diagonal elements that are - -- very small compared to elements on the diagonal with the same - -- column or row index. - - Sum := Sum_Strict_Upper (M); - - exit Sweep when Sum = 0.0; - - Threshold := (if Iteration < 4 then 0.2 * Sum / Real (N**2) else 0.0); - - -- Iterate over all off-diagonal elements, rotating any that have - -- an absolute value that exceeds the threshold. - - Diag := Values; - Diag_Adj := (others => 0.0); -- Accumulates adjustments to Diag - - for Row in 1 .. N - 1 loop - for Col in Row + 1 .. N loop - - -- If, before the rotation M (Row, Col) is tiny compared to - -- Diag (Row) and Diag (Col), rotation is skipped. This is - -- meaningful, as it produces no larger error than would be - -- produced anyhow if the rotation had been performed. - -- Suppress this optimization in the first four sweeps, so - -- that this procedure can be used for computing eigenvectors - -- of perturbed diagonal matrices. - - if Iteration > 4 - and then Is_Tiny (M (Row, Col), Compared_To => Diag (Row)) - and then Is_Tiny (M (Row, Col), Compared_To => Diag (Col)) - then - M (Row, Col) := 0.0; - - elsif abs M (Row, Col) > Threshold then - Perform_Rotation : declare - Tan : constant Real := Compute_Tan (M (Row, Col), - Diag (Col) - Diag (Row)); - Cos : constant Real := 1.0 / Sqrt (1.0 + Tan**2); - Sin : constant Real := Tan * Cos; - Tau : constant Real := Sin / (1.0 + Cos); - Adj : constant Real := Tan * M (Row, Col); - - begin - Diag_Adj (Row) := Diag_Adj (Row) - Adj; - Diag_Adj (Col) := Diag_Adj (Col) + Adj; - Diag (Row) := Diag (Row) - Adj; - Diag (Col) := Diag (Col) + Adj; - - M (Row, Col) := 0.0; - - for J in 1 .. Row - 1 loop -- 1 <= J < Row - Rotate (M (J, Row), M (J, Col), Sin, Tau); - end loop; - - for J in Row + 1 .. Col - 1 loop -- Row < J < Col - Rotate (M (Row, J), M (J, Col), Sin, Tau); - end loop; - - for J in Col + 1 .. N loop -- Col < J <= N - Rotate (M (Row, J), M (Col, J), Sin, Tau); - end loop; - - for J in Vectors'Range (1) loop - Rotate (Vectors (J, Row - 1 + Vectors'First (2)), - Vectors (J, Col - 1 + Vectors'First (2)), - Sin, Tau); - end loop; - end Perform_Rotation; - end if; - end loop; - end loop; - - Values := Values + Diag_Adj; - end loop Sweep; - - -- All normal matrices with valid values should converge perfectly. - - if Sum /= 0.0 then - raise Constraint_Error with "eigensystem solution does not converge"; - end if; - end Jacobi; - - ----------- - -- Solve -- - ----------- - - function Solve (A : Real_Matrix; X : Real_Vector) return Real_Vector - renames Instantiations.Solve; - - function Solve (A, X : Real_Matrix) return Real_Matrix - renames Instantiations.Solve; - - ---------------------- - -- Sort_Eigensystem -- - ---------------------- - - procedure Sort_Eigensystem - (Values : in out Real_Vector; - Vectors : in out Real_Matrix) - is - procedure Swap (Left, Right : Integer); - -- Swap Values (Left) with Values (Right), and also swap the - -- corresponding eigenvectors. Note that lowerbounds may differ. - - function Less (Left, Right : Integer) return Boolean is - (Values (Left) > Values (Right)); - -- Sort by decreasing eigenvalue, see RM G.3.1 (76). - - procedure Sort is new Generic_Anonymous_Array_Sort (Integer); - -- Sorts eigenvalues and eigenvectors by decreasing value - - procedure Swap (Left, Right : Integer) is - begin - Swap (Values (Left), Values (Right)); - Swap_Column (Vectors, Left - Values'First + Vectors'First (2), - Right - Values'First + Vectors'First (2)); - end Swap; - - begin - Sort (Values'First, Values'Last); - end Sort_Eigensystem; - - --------------- - -- Transpose -- - --------------- - - function Transpose (X : Real_Matrix) return Real_Matrix is - begin - return R : Real_Matrix (X'Range (2), X'Range (1)) do - Transpose (X, R); - end return; - end Transpose; - - ----------------- - -- Unit_Matrix -- - ----------------- - - function Unit_Matrix - (Order : Positive; - First_1 : Integer := 1; - First_2 : Integer := 1) return Real_Matrix - renames Instantiations.Unit_Matrix; - - ----------------- - -- Unit_Vector -- - ----------------- - - function Unit_Vector - (Index : Integer; - Order : Positive; - First : Integer := 1) return Real_Vector - renames Instantiations.Unit_Vector; - -end Ada.Numerics.Generic_Real_Arrays; diff --git a/gcc/ada/a-ngrear.ads b/gcc/ada/a-ngrear.ads deleted file mode 100644 index 2f38b90..0000000 --- a/gcc/ada/a-ngrear.ads +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.GENERIC_REAL_ARRAYS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2012, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -generic - type Real is digits <>; -package Ada.Numerics.Generic_Real_Arrays is - pragma Pure (Generic_Real_Arrays); - - -- Types - - type Real_Vector is array (Integer range <>) of Real'Base; - type Real_Matrix is array (Integer range <>, Integer range <>) of Real'Base; - - -- Subprograms for Real_Vector types - - -- Real_Vector arithmetic operations - - function "+" (Right : Real_Vector) return Real_Vector; - function "-" (Right : Real_Vector) return Real_Vector; - function "abs" (Right : Real_Vector) return Real_Vector; - - function "+" (Left, Right : Real_Vector) return Real_Vector; - function "-" (Left, Right : Real_Vector) return Real_Vector; - - function "*" (Left, Right : Real_Vector) return Real'Base; - - function "abs" (Right : Real_Vector) return Real'Base; - - -- Real_Vector scaling operations - - function "*" (Left : Real'Base; Right : Real_Vector) return Real_Vector; - function "*" (Left : Real_Vector; Right : Real'Base) return Real_Vector; - function "/" (Left : Real_Vector; Right : Real'Base) return Real_Vector; - - -- Other Real_Vector operations - - function Unit_Vector - (Index : Integer; - Order : Positive; - First : Integer := 1) return Real_Vector; - - -- Subprograms for Real_Matrix types - - -- Real_Matrix arithmetic operations - - function "+" (Right : Real_Matrix) return Real_Matrix; - function "-" (Right : Real_Matrix) return Real_Matrix; - function "abs" (Right : Real_Matrix) return Real_Matrix; - function Transpose (X : Real_Matrix) return Real_Matrix; - - function "+" (Left, Right : Real_Matrix) return Real_Matrix; - function "-" (Left, Right : Real_Matrix) return Real_Matrix; - function "*" (Left, Right : Real_Matrix) return Real_Matrix; - - function "*" (Left, Right : Real_Vector) return Real_Matrix; - - function "*" (Left : Real_Vector; Right : Real_Matrix) return Real_Vector; - function "*" (Left : Real_Matrix; Right : Real_Vector) return Real_Vector; - - -- Real_Matrix scaling operations - - function "*" (Left : Real'Base; Right : Real_Matrix) return Real_Matrix; - function "*" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix; - function "/" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix; - - -- Real_Matrix inversion and related operations - - function Solve (A : Real_Matrix; X : Real_Vector) return Real_Vector; - function Solve (A, X : Real_Matrix) return Real_Matrix; - function Inverse (A : Real_Matrix) return Real_Matrix; - function Determinant (A : Real_Matrix) return Real'Base; - - -- Eigenvalues and vectors of a real symmetric matrix - - function Eigenvalues (A : Real_Matrix) return Real_Vector; - - procedure Eigensystem - (A : Real_Matrix; - Values : out Real_Vector; - Vectors : out Real_Matrix); - - -- Other Real_Matrix operations - - function Unit_Matrix - (Order : Positive; - First_1 : Integer := 1; - First_2 : Integer := 1) return Real_Matrix; - -private - -- The following operations are either relatively simple compared to the - -- expense of returning unconstrained arrays, or are just function wrappers - -- calling procedures implementing the actual operation. By having the - -- front end inline these, the expense of the unconstrained returns - -- can be avoided. - - -- Note: We use an extended return statement in their implementation to - -- allow the frontend to inline these functions. - - pragma Inline ("+"); - pragma Inline ("-"); - pragma Inline ("*"); - pragma Inline ("/"); - pragma Inline ("abs"); - pragma Inline (Eigenvalues); - pragma Inline (Inverse); - pragma Inline (Solve); - pragma Inline (Transpose); - pragma Inline (Unit_Matrix); - pragma Inline (Unit_Vector); -end Ada.Numerics.Generic_Real_Arrays; diff --git a/gcc/ada/a-nlcefu.ads b/gcc/ada/a-nlcefu.ads deleted file mode 100644 index 083f6a9..0000000 --- a/gcc/ada/a-nlcefu.ads +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Long_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; - -package Ada.Numerics.Long_Complex_Elementary_Functions is - new Ada.Numerics.Generic_Complex_Elementary_Functions - (Ada.Numerics.Long_Complex_Types); -pragma Pure (Ada.Numerics.Long_Complex_Elementary_Functions); diff --git a/gcc/ada/a-nlcoar.ads b/gcc/ada/a-nlcoar.ads deleted file mode 100644 index 35e97a5..0000000 --- a/gcc/ada/a-nlcoar.ads +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.LONG_COMPLEX_ARRAYS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Arrays; -with Ada.Numerics.Long_Real_Arrays; -with Ada.Numerics.Long_Complex_Types; - -package Ada.Numerics.Long_Complex_Arrays is new - Ada.Numerics.Generic_Complex_Arrays (Long_Real_Arrays, Long_Complex_Types); - -pragma Pure (Long_Complex_Arrays); diff --git a/gcc/ada/a-nlcoty.ads b/gcc/ada/a-nlcoty.ads deleted file mode 100644 index 6eb4fc3..0000000 --- a/gcc/ada/a-nlcoty.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . L O N G _ C O M P L E X _ T Y P E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; - -package Ada.Numerics.Long_Complex_Types is - new Ada.Numerics.Generic_Complex_Types (Long_Float); - -pragma Pure (Long_Complex_Types); diff --git a/gcc/ada/a-nlelfu.ads b/gcc/ada/a-nlelfu.ads deleted file mode 100644 index 10b33e9..0000000 --- a/gcc/ada/a-nlelfu.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.LONG_ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Elementary_Functions; - -package Ada.Numerics.Long_Elementary_Functions is - new Ada.Numerics.Generic_Elementary_Functions (Long_Float); - -pragma Pure (Long_Elementary_Functions); diff --git a/gcc/ada/a-nllcar.ads b/gcc/ada/a-nllcar.ads deleted file mode 100644 index 48fd91a..0000000 --- a/gcc/ada/a-nllcar.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.LONG_LONG_COMPLEX_ARRAYS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Arrays; -with Ada.Numerics.Long_Long_Real_Arrays; -with Ada.Numerics.Long_Long_Complex_Types; - -package Ada.Numerics.Long_Long_Complex_Arrays is - new Ada.Numerics.Generic_Complex_Arrays (Long_Long_Real_Arrays, - Long_Long_Complex_Types); - -pragma Pure (Long_Long_Complex_Arrays); diff --git a/gcc/ada/a-nllcef.ads b/gcc/ada/a-nllcef.ads deleted file mode 100644 index 7a1f4b1..0000000 --- a/gcc/ada/a-nllcef.ads +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.LONG_LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Long_Long_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; - -package Ada.Numerics.Long_Long_Complex_Elementary_Functions is - new Ada.Numerics.Generic_Complex_Elementary_Functions - (Ada.Numerics.Long_Long_Complex_Types); -pragma Pure (Ada.Numerics.Long_Long_Complex_Elementary_Functions); diff --git a/gcc/ada/a-nllcty.ads b/gcc/ada/a-nllcty.ads deleted file mode 100644 index a6081c2..0000000 --- a/gcc/ada/a-nllcty.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . L O N G _ L O N G _ C O M P L E X _ T Y P E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; - -package Ada.Numerics.Long_Long_Complex_Types is - new Ada.Numerics.Generic_Complex_Types (Long_Long_Float); - -pragma Pure (Long_Long_Complex_Types); diff --git a/gcc/ada/a-nllefu.ads b/gcc/ada/a-nllefu.ads deleted file mode 100644 index 7089fc3..0000000 --- a/gcc/ada/a-nllefu.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.LONG_LONG_ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Elementary_Functions; - -package Ada.Numerics.Long_Long_Elementary_Functions is - new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float); - -pragma Pure (Long_Long_Elementary_Functions); diff --git a/gcc/ada/a-nllrar.ads b/gcc/ada/a-nllrar.ads deleted file mode 100644 index 62a2457..0000000 --- a/gcc/ada/a-nllrar.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . L O N G _ L O N G _R E A L _ A R R A Y S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Real_Arrays; - -package Ada.Numerics.Long_Long_Real_Arrays is - new Ada.Numerics.Generic_Real_Arrays (Long_Long_Float); - -pragma Pure (Long_Long_Real_Arrays); diff --git a/gcc/ada/a-nlrear.ads b/gcc/ada/a-nlrear.ads deleted file mode 100644 index 990c39b..0000000 --- a/gcc/ada/a-nlrear.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . L O N G _ R E A L _ A R R A Y S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Real_Arrays; - -package Ada.Numerics.Long_Real_Arrays is - new Ada.Numerics.Generic_Real_Arrays (Long_Float); - -pragma Pure (Long_Real_Arrays); diff --git a/gcc/ada/a-nscefu.ads b/gcc/ada/a-nscefu.ads deleted file mode 100644 index 0d0aa15..0000000 --- a/gcc/ada/a-nscefu.ads +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.SHORT.COMPLEX.ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Short_Complex_Types; -with Ada.Numerics.Generic_Complex_Elementary_Functions; - -package Ada.Numerics.Short_Complex_Elementary_Functions is - new Ada.Numerics.Generic_Complex_Elementary_Functions - (Ada.Numerics.Short_Complex_Types); -pragma Pure (Ada.Numerics.Short_Complex_Elementary_Functions); diff --git a/gcc/ada/a-nscoty.ads b/gcc/ada/a-nscoty.ads deleted file mode 100644 index e58b0b5..0000000 --- a/gcc/ada/a-nscoty.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . S H O R T _ C O M P L E X _ T Y P E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; - -package Ada.Numerics.Short_Complex_Types is - new Ada.Numerics.Generic_Complex_Types (Short_Float); - -pragma Pure (Short_Complex_Types); diff --git a/gcc/ada/a-nselfu.ads b/gcc/ada/a-nselfu.ads deleted file mode 100644 index 10b04ac..0000000 --- a/gcc/ada/a-nselfu.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.NUMERICS.SHORT_ELEMENTARY_FUNCTIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Elementary_Functions; - -package Ada.Numerics.Short_Elementary_Functions is - new Ada.Numerics.Generic_Elementary_Functions (Short_Float); - -pragma Pure (Short_Elementary_Functions); diff --git a/gcc/ada/a-nucoar.ads b/gcc/ada/a-nucoar.ads deleted file mode 100644 index 665d02d..0000000 --- a/gcc/ada/a-nucoar.ads +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . C O M P L E X _ A R R A Y S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Arrays; -with Ada.Numerics.Real_Arrays; -with Ada.Numerics.Complex_Types; - -package Ada.Numerics.Complex_Arrays is - new Ada.Numerics.Generic_Complex_Arrays (Real_Arrays, Complex_Types); - -pragma Pure (Complex_Arrays); diff --git a/gcc/ada/a-nucoty.ads b/gcc/ada/a-nucoty.ads deleted file mode 100644 index 3b04a27..0000000 --- a/gcc/ada/a-nucoty.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . C O M P L E X _ T Y P E S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; - -package Ada.Numerics.Complex_Types is - new Ada.Numerics.Generic_Complex_Types (Float); - -pragma Pure (Complex_Types); diff --git a/gcc/ada/a-nudira.adb b/gcc/ada/a-nudira.adb deleted file mode 100644 index 2e83600..0000000 --- a/gcc/ada/a-nudira.adb +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Numerics.Discrete_Random with - SPARK_Mode => Off -is - - package SRN renames System.Random_Numbers; - use SRN; - - ----------- - -- Image -- - ----------- - - function Image (Of_State : State) return String is - begin - return Image (SRN.State (Of_State)); - end Image; - - ------------ - -- Random -- - ------------ - - function Random (Gen : Generator) return Result_Subtype is - function Random is - new SRN.Random_Discrete (Result_Subtype, Result_Subtype'First); - begin - return Random (SRN.Generator (Gen)); - end Random; - - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : Generator) is - begin - Reset (SRN.Generator (Gen)); - end Reset; - - procedure Reset (Gen : Generator; Initiator : Integer) is - begin - Reset (SRN.Generator (Gen), Initiator); - end Reset; - - procedure Reset (Gen : Generator; From_State : State) is - begin - Reset (SRN.Generator (Gen), SRN.State (From_State)); - end Reset; - - ---------- - -- Save -- - ---------- - - procedure Save (Gen : Generator; To_State : out State) is - begin - Save (SRN.Generator (Gen), SRN.State (To_State)); - end Save; - - ----------- - -- Value -- - ----------- - - function Value (Coded_State : String) return State is - begin - return State (SRN.State'(Value (Coded_State))); - end Value; - -end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nudira.ads b/gcc/ada/a-nudira.ads deleted file mode 100644 index c2a7382..0000000 --- a/gcc/ada/a-nudira.ads +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: the implementation used in this package is a version of the --- Mersenne Twister. See s-rannum.adb for details and references. - -with System.Random_Numbers; - -generic - type Result_Subtype is (<>); - -package Ada.Numerics.Discrete_Random with - SPARK_Mode => Off -is - - -- Basic facilities - - type Generator is limited private; - - function Random (Gen : Generator) return Result_Subtype; - - procedure Reset (Gen : Generator; Initiator : Integer); - procedure Reset (Gen : Generator); - - -- Advanced facilities - - type State is private; - - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); - - Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; - -private - - type Generator is new System.Random_Numbers.Generator; - - type State is new System.Random_Numbers.State; - -end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/a-nuelfu.ads b/gcc/ada/a-nuelfu.ads deleted file mode 100644 index 149939b..0000000 --- a/gcc/ada/a-nuelfu.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . E L E M E N T A R Y _ F U N C T I O N S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Elementary_Functions; - -package Ada.Numerics.Elementary_Functions is - new Ada.Numerics.Generic_Elementary_Functions (Float); - -pragma Pure (Elementary_Functions); diff --git a/gcc/ada/a-nuflra.adb b/gcc/ada/a-nuflra.adb deleted file mode 100644 index add19d4..0000000 --- a/gcc/ada/a-nuflra.adb +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . F L O A T _ R A N D O M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Numerics.Float_Random with - SPARK_Mode => Off -is - - package SRN renames System.Random_Numbers; - use SRN; - - ----------- - -- Image -- - ----------- - - function Image (Of_State : State) return String is - begin - return Image (SRN.State (Of_State)); - end Image; - - ------------ - -- Random -- - ------------ - - function Random (Gen : Generator) return Uniformly_Distributed is - begin - return Random (SRN.Generator (Gen)); - end Random; - - ----------- - -- Reset -- - ----------- - - -- Version that works from calendar - - procedure Reset (Gen : Generator) is - begin - Reset (SRN.Generator (Gen)); - end Reset; - - -- Version that works from given initiator value - - procedure Reset (Gen : Generator; Initiator : Integer) is - begin - Reset (SRN.Generator (Gen), Initiator); - end Reset; - - -- Version that works from specific saved state - - procedure Reset (Gen : Generator; From_State : State) is - begin - Reset (SRN.Generator (Gen), From_State); - end Reset; - - ---------- - -- Save -- - ---------- - - procedure Save (Gen : Generator; To_State : out State) is - begin - Save (SRN.Generator (Gen), To_State); - end Save; - - ----------- - -- Value -- - ----------- - - function Value (Coded_State : String) return State is - G : SRN.Generator; - S : SRN.State; - begin - Reset (G, Coded_State); - Save (G, S); - return State (S); - end Value; - -end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-nuflra.ads b/gcc/ada/a-nuflra.ads deleted file mode 100644 index ea4992c..0000000 --- a/gcc/ada/a-nuflra.ads +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . F L O A T _ R A N D O M -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: the implementation used in this package is a version of the --- Mersenne Twister. See s-rannum.adb for details and references. - -with System.Random_Numbers; - -package Ada.Numerics.Float_Random with - SPARK_Mode => Off -is - - -- Basic facilities - - type Generator is limited private; - - subtype Uniformly_Distributed is Float range 0.0 .. 1.0; - - function Random (Gen : Generator) return Uniformly_Distributed; - - procedure Reset (Gen : Generator); - procedure Reset (Gen : Generator; Initiator : Integer); - - -- Advanced facilities - - type State is private; - - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); - - Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; - -private - - type Generator is new System.Random_Numbers.Generator; - - type State is new System.Random_Numbers.State; - -end Ada.Numerics.Float_Random; diff --git a/gcc/ada/a-numaux-darwin.adb b/gcc/ada/a-numaux-darwin.adb deleted file mode 100644 index 3c4a101..0000000 --- a/gcc/ada/a-numaux-darwin.adb +++ /dev/null @@ -1,211 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- B o d y -- --- (Apple OS X Version) -- --- -- --- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Numerics.Aux is - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Is_Nan (X : Double) return Boolean; - -- Return True iff X is a IEEE NaN value - - procedure Reduce (X : in out Double; Q : out Natural); - -- Implement reduction of X by Pi/2. Q is the quadrant of the final - -- result in the range 0..3. The absolute value of X is at most Pi/4. - -- It is needed to avoid a loss of accuracy for sin near Pi and cos - -- near Pi/2 due to the use of an insufficiently precise value of Pi - -- in the range reduction. - - -- The following two functions implement Chebishev approximations - -- of the trigonometric functions in their reduced domain. - -- These approximations have been computed using Maple. - - function Sine_Approx (X : Double) return Double; - function Cosine_Approx (X : Double) return Double; - - pragma Inline (Reduce); - pragma Inline (Sine_Approx); - pragma Inline (Cosine_Approx); - - ------------------- - -- Cosine_Approx -- - ------------------- - - function Cosine_Approx (X : Double) return Double is - XX : constant Double := X * X; - begin - return (((((16#8.DC57FBD05F640#E-08 * XX - - 16#4.9F7D00BF25D80#E-06) * XX - + 16#1.A019F7FDEFCC2#E-04) * XX - - 16#5.B05B058F18B20#E-03) * XX - + 16#A.AAAAAAAA73FA8#E-02) * XX - - 16#7.FFFFFFFFFFDE4#E-01) * XX - - 16#3.655E64869ECCE#E-14 + 1.0; - end Cosine_Approx; - - ----------------- - -- Sine_Approx -- - ----------------- - - function Sine_Approx (X : Double) return Double is - XX : constant Double := X * X; - begin - return (((((16#A.EA2D4ABE41808#E-09 * XX - - 16#6.B974C10F9D078#E-07) * XX - + 16#2.E3BC673425B0E#E-05) * XX - - 16#D.00D00CCA7AF00#E-04) * XX - + 16#2.222222221B190#E-02) * XX - - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X; - end Sine_Approx; - - ------------ - -- Is_Nan -- - ------------ - - function Is_Nan (X : Double) return Boolean is - begin - -- The IEEE NaN values are the only ones that do not equal themselves - - return X /= X; - end Is_Nan; - - ------------ - -- Reduce -- - ------------ - - procedure Reduce (X : in out Double; Q : out Natural) is - Half_Pi : constant := Pi / 2.0; - Two_Over_Pi : constant := 2.0 / Pi; - - HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); - M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant - P1 : constant Double := Double'Leading_Part (Half_Pi, HM); - P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); - P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); - P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); - P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 - - P4, HM); - P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); - K : Double; - R : Integer; - - begin - -- For X < 2.0**HM, all products below are computed exactly. - -- Due to cancellation effects all subtractions are exact as well. - -- As no double extended floating-point number has more than 75 - -- zeros after the binary point, the result will be the correctly - -- rounded result of X - K * (Pi / 2.0). - - K := X * Two_Over_Pi; - while abs K >= 2.0**HM loop - K := K * M - (K * M - K); - X := - (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - K := X * Two_Over_Pi; - end loop; - - -- If K is not a number (because X was not finite) raise exception - - if Is_Nan (K) then - raise Constraint_Error; - end if; - - -- Go through an integer temporary so as to use machine instructions - - R := Integer (Double'Rounding (K)); - Q := R mod 4; - K := Double (R); - X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - end Reduce; - - --------- - -- Cos -- - --------- - - function Cos (X : Double) return Double is - Reduced_X : Double := abs X; - Quadrant : Natural range 0 .. 3; - - begin - if Reduced_X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - return Cosine_Approx (Reduced_X); - - when 1 => - return Sine_Approx (-Reduced_X); - - when 2 => - return -Cosine_Approx (Reduced_X); - - when 3 => - return Sine_Approx (Reduced_X); - end case; - end if; - - return Cosine_Approx (Reduced_X); - end Cos; - - --------- - -- Sin -- - --------- - - function Sin (X : Double) return Double is - Reduced_X : Double := X; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - return Sine_Approx (Reduced_X); - - when 1 => - return Cosine_Approx (Reduced_X); - - when 2 => - return Sine_Approx (-Reduced_X); - - when 3 => - return -Cosine_Approx (Reduced_X); - end case; - end if; - - return Sine_Approx (Reduced_X); - end Sin; - -end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-darwin.ads b/gcc/ada/a-numaux-darwin.ads deleted file mode 100644 index a548798..0000000 --- a/gcc/ada/a-numaux-darwin.ads +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (Apple OS X Version) -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 use on OS X. It uses the normal Unix math functions, --- except for sine/cosine which have been implemented directly in Ada to get --- the required accuracy. - -package Ada.Numerics.Aux is - pragma Pure; - - pragma Linker_Options ("-lm"); - - type Double is new Long_Float; - -- Type Double is the type used to call the C routines - - -- The following functions have been implemented in Ada, since - -- the OS X math library didn't meet accuracy requirements for - -- argument reduction. The implementation here has been tailored - -- to match Ada strict mode Numerics requirements while maintaining - -- maximum efficiency. - function Sin (X : Double) return Double; - pragma Inline (Sin); - - function Cos (X : Double) return Double; - pragma Inline (Cos); - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-libc-x86.ads b/gcc/ada/a-numaux-libc-x86.ads deleted file mode 100644 index 3f59fab..0000000 --- a/gcc/ada/a-numaux-libc-x86.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (C Library Version for x86) -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 the x86 using the 80-bit x86 long double format - -package Ada.Numerics.Aux is - pragma Pure; - - pragma Linker_Options ("-lm"); - - type Double is new Long_Long_Float; - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sinl"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cosl"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tanl"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "expl"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrtl"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "logl"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acosl"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asinl"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atanl"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinhl"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "coshl"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanhl"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "powl"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-vxworks.ads b/gcc/ada/a-numaux-vxworks.ads deleted file mode 100644 index 25fcd2d..0000000 --- a/gcc/ada/a-numaux-vxworks.ads +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (C Library Version, VxWorks) -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version for use on VxWorks (where we have no libm.a library), so the pragma --- Linker_Options ("-lm") is omitted in this version. - -package Ada.Numerics.Aux is - pragma Pure; - - type Double is new Long_Float; - -- Type Double is the type used to call the C routines - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-x86.adb b/gcc/ada/a-numaux-x86.adb deleted file mode 100644 index b6690d1..0000000 --- a/gcc/ada/a-numaux-x86.adb +++ /dev/null @@ -1,577 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- B o d y -- --- (Machine Version for x86) -- --- -- --- Copyright (C) 1998-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Machine_Code; use System.Machine_Code; - -package body Ada.Numerics.Aux is - - NL : constant String := ASCII.LF & ASCII.HT; - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Is_Nan (X : Double) return Boolean; - -- Return True iff X is a IEEE NaN value - - function Logarithmic_Pow (X, Y : Double) return Double; - -- Implementation of X**Y using Exp and Log functions (binary base) - -- to calculate the exponentiation. This is used by Pow for values - -- for values of Y in the open interval (-0.25, 0.25) - - procedure Reduce (X : in out Double; Q : out Natural); - -- Implement reduction of X by Pi/2. Q is the quadrant of the final - -- result in the range 0..3. The absolute value of X is at most Pi/4. - -- It is needed to avoid a loss of accuracy for sin near Pi and cos - -- near Pi/2 due to the use of an insufficiently precise value of Pi - -- in the range reduction. - - pragma Inline (Is_Nan); - pragma Inline (Reduce); - - -------------------------------- - -- Basic Elementary Functions -- - -------------------------------- - - -- This section implements a few elementary functions that are used to - -- build the more complex ones. This ordering enables better inlining. - - ---------- - -- Atan -- - ---------- - - function Atan (X : Double) return Double is - Result : Double; - - begin - Asm (Template => - "fld1" & NL - & "fpatan", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - - -- The result value is NaN iff input was invalid - - if not (Result = Result) then - raise Argument_Error; - end if; - - return Result; - end Atan; - - --------- - -- Exp -- - --------- - - function Exp (X : Double) return Double is - Result : Double; - begin - Asm (Template => - "fldl2e " & NL - & "fmulp %%st, %%st(1)" & NL -- X * log2 (E) - & "fld %%st(0) " & NL - & "frndint " & NL -- Integer (X * Log2 (E)) - & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E)) - & "fxch " & NL - & "f2xm1 " & NL -- 2**(...) - 1 - & "fld1 " & NL - & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E))) - & "fscale " & NL -- E ** X - & "fstp %%st(1) ", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - return Result; - end Exp; - - ------------ - -- Is_Nan -- - ------------ - - function Is_Nan (X : Double) return Boolean is - begin - -- The IEEE NaN values are the only ones that do not equal themselves - - return X /= X; - end Is_Nan; - - --------- - -- Log -- - --------- - - function Log (X : Double) return Double is - Result : Double; - - begin - Asm (Template => - "fldln2 " & NL - & "fxch " & NL - & "fyl2x " & NL, - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - return Result; - end Log; - - ------------ - -- Reduce -- - ------------ - - procedure Reduce (X : in out Double; Q : out Natural) is - Half_Pi : constant := Pi / 2.0; - Two_Over_Pi : constant := 2.0 / Pi; - - HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); - M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant - P1 : constant Double := Double'Leading_Part (Half_Pi, HM); - P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); - P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); - P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); - P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 - - P4, HM); - P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); - K : Double; - R : Integer; - - begin - -- For X < 2.0**HM, all products below are computed exactly. - -- Due to cancellation effects all subtractions are exact as well. - -- As no double extended floating-point number has more than 75 - -- zeros after the binary point, the result will be the correctly - -- rounded result of X - K * (Pi / 2.0). - - K := X * Two_Over_Pi; - while abs K >= 2.0**HM loop - K := K * M - (K * M - K); - X := - (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - K := X * Two_Over_Pi; - end loop; - - -- If K is not a number (because X was not finite) raise exception - - if Is_Nan (K) then - raise Constraint_Error; - end if; - - -- Go through an integer temporary so as to use machine instructions - - R := Integer (Double'Rounding (K)); - Q := R mod 4; - K := Double (R); - X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; - end Reduce; - - ---------- - -- Sqrt -- - ---------- - - function Sqrt (X : Double) return Double is - Result : Double; - - begin - if X < 0.0 then - raise Argument_Error; - end if; - - Asm (Template => "fsqrt", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", X)); - - return Result; - end Sqrt; - - -------------------------------- - -- Other Elementary Functions -- - -------------------------------- - - -- These are built using the previously implemented basic functions - - ---------- - -- Acos -- - ---------- - - function Acos (X : Double) return Double is - Result : Double; - - begin - Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X))); - - -- The result value is NaN iff input was invalid - - if Is_Nan (Result) then - raise Argument_Error; - end if; - - return Result; - end Acos; - - ---------- - -- Asin -- - ---------- - - function Asin (X : Double) return Double is - Result : Double; - - begin - Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X))); - - -- The result value is NaN iff input was invalid - - if Is_Nan (Result) then - raise Argument_Error; - end if; - - return Result; - end Asin; - - --------- - -- Cos -- - --------- - - function Cos (X : Double) return Double is - Reduced_X : Double := abs X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if Reduced_X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 1 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", -Reduced_X)); - - when 2 => - Asm (Template => "fcos ; fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 3 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end case; - - else - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Cos; - - --------------------- - -- Logarithmic_Pow -- - --------------------- - - function Logarithmic_Pow (X, Y : Double) return Double is - Result : Double; - begin - Asm (Template => "" -- X : Y - & "fyl2x " & NL -- Y * Log2 (X) - & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X) - & "frndint " & NL -- Int (...) : Y * Log2 (X) - & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...) - & "fxch " & NL -- Fract (...) : Int (...) - & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...) - & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...) - & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...) - & "fscale ", -- 2**(Fract (...) + Int (...)) - Outputs => Double'Asm_Output ("=t", Result), - Inputs => - (Double'Asm_Input ("0", X), - Double'Asm_Input ("u", Y))); - return Result; - end Logarithmic_Pow; - - --------- - -- Pow -- - --------- - - function Pow (X, Y : Double) return Double is - type Mantissa_Type is mod 2**Double'Machine_Mantissa; - -- Modular type that can hold all bits of the mantissa of Double - - -- For negative exponents, do divide at the end of the processing - - Negative_Y : constant Boolean := Y < 0.0; - Abs_Y : constant Double := abs Y; - - -- During this function the following invariant is kept: - -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor - - Base : Double := X; - - Exp_High : Double := Double'Floor (Abs_Y); - Exp_Mid : Double; - Exp_Low : Double; - Exp_Int : Mantissa_Type; - - Factor : Double := 1.0; - - begin - -- Select algorithm for calculating Pow (integer cases fall through) - - if Exp_High >= 2.0**Double'Machine_Mantissa then - - -- In case of Y that is IEEE infinity, just raise constraint error - - if Exp_High > Double'Safe_Last then - raise Constraint_Error; - end if; - - -- Large values of Y are even integers and will stay integer - -- after division by two. - - loop - -- Exp_Mid and Exp_Low are zero, so - -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2) - - Exp_High := Exp_High / 2.0; - Base := Base * Base; - exit when Exp_High < 2.0**Double'Machine_Mantissa; - end loop; - - elsif Exp_High /= Abs_Y then - Exp_Low := Abs_Y - Exp_High; - Factor := 1.0; - - if Exp_Low /= 0.0 then - - -- Exp_Low now is in interval (0.0, 1.0) - -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0; - - Exp_Mid := 0.0; - Exp_Low := Exp_Low - Exp_Mid; - - if Exp_Low >= 0.5 then - Factor := Sqrt (X); - Exp_Low := Exp_Low - 0.5; -- exact - - if Exp_Low >= 0.25 then - Factor := Factor * Sqrt (Factor); - Exp_Low := Exp_Low - 0.25; -- exact - end if; - - elsif Exp_Low >= 0.25 then - Factor := Sqrt (Sqrt (X)); - Exp_Low := Exp_Low - 0.25; -- exact - end if; - - -- Exp_Low now is in interval (0.0, 0.25) - - -- This means it is safe to call Logarithmic_Pow - -- for the remaining part. - - Factor := Factor * Logarithmic_Pow (X, Exp_Low); - end if; - - elsif X = 0.0 then - return 0.0; - end if; - - -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa - - Exp_Int := Mantissa_Type (Exp_High); - - -- Standard way for processing integer powers > 0 - - while Exp_Int > 1 loop - if (Exp_Int and 1) = 1 then - - -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0 - - Factor := Factor * Base; - end if; - - -- Exp_Int is even and Exp_Int > 0, so - -- Base**Y = (Base**2)**(Exp_Int / 2) - - Base := Base * Base; - Exp_Int := Exp_Int / 2; - end loop; - - -- Exp_Int = 1 or Exp_Int = 0 - - if Exp_Int = 1 then - Factor := Base * Factor; - end if; - - if Negative_Y then - Factor := 1.0 / Factor; - end if; - - return Factor; - end Pow; - - --------- - -- Sin -- - --------- - - function Sin (X : Double) return Double is - Reduced_X : Double := X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - case Quadrant is - when 0 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 1 => - Asm (Template => "fcos", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - - when 2 => - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", -Reduced_X)); - - when 3 => - Asm (Template => "fcos ; fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end case; - - else - Asm (Template => "fsin", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Sin; - - --------- - -- Tan -- - --------- - - function Tan (X : Double) return Double is - Reduced_X : Double := X; - Result : Double; - Quadrant : Natural range 0 .. 3; - - begin - if abs X > Pi / 4.0 then - Reduce (Reduced_X, Quadrant); - - if Quadrant mod 2 = 0 then - Asm (Template => "fptan" & NL - & "ffree %%st(0)" & NL - & "fincstp", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - else - Asm (Template => "fsincos" & NL - & "fdivp %%st, %%st(1)" & NL - & "fchs", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - else - Asm (Template => - "fptan " & NL - & "ffree %%st(0) " & NL - & "fincstp ", - Outputs => Double'Asm_Output ("=t", Result), - Inputs => Double'Asm_Input ("0", Reduced_X)); - end if; - - return Result; - end Tan; - - ---------- - -- Sinh -- - ---------- - - function Sinh (X : Double) return Double is - begin - -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0 - - if abs X < 25.0 then - return (Exp (X) - Exp (-X)) / 2.0; - else - return Exp (X) / 2.0; - end if; - end Sinh; - - ---------- - -- Cosh -- - ---------- - - function Cosh (X : Double) return Double is - begin - -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0 - - if abs X < 22.0 then - return (Exp (X) + Exp (-X)) / 2.0; - else - return Exp (X) / 2.0; - end if; - end Cosh; - - ---------- - -- Tanh -- - ---------- - - function Tanh (X : Double) return Double is - begin - -- Return the Hyperbolic Tangent of x - - -- x -x - -- e - e Sinh (X) - -- Tanh (X) is defined to be ----------- = -------- - -- x -x Cosh (X) - -- e + e - - if abs X > 23.0 then - return Double'Copy_Sign (1.0, X); - end if; - - return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X)); - end Tanh; - -end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux-x86.ads b/gcc/ada/a-numaux-x86.ads deleted file mode 100644 index 4c98ef1..0000000 --- a/gcc/ada/a-numaux-x86.ads +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (Machine Version for x86) -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 the x86 using the 80-bit x86 long double format with --- inline asm statements. - -package Ada.Numerics.Aux is - pragma Pure; - - type Double is new Long_Long_Float; - - function Sin (X : Double) return Double; - - function Cos (X : Double) return Double; - - function Tan (X : Double) return Double; - - function Exp (X : Double) return Double; - - function Sqrt (X : Double) return Double; - - function Log (X : Double) return Double; - - function Atan (X : Double) return Double; - - function Acos (X : Double) return Double; - - function Asin (X : Double) return Double; - - function Sinh (X : Double) return Double; - - function Cosh (X : Double) return Double; - - function Tanh (X : Double) return Double; - - function Pow (X, Y : Double) return Double; - -private - pragma Inline (Atan); - pragma Inline (Cos); - pragma Inline (Tan); - pragma Inline (Exp); - pragma Inline (Log); - pragma Inline (Sin); - pragma Inline (Sqrt); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numaux.ads b/gcc/ada/a-numaux.ads deleted file mode 100644 index 2e7d1e3..0000000 --- a/gcc/ada/a-numaux.ads +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . A U X -- --- -- --- S p e c -- --- (C Library Version, non-x86) -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the basic computational interface for the generic --- elementary functions. The C library version interfaces with the routines --- in the C mathematical library, and is thus quite portable, although it may --- not necessarily meet the requirements for accuracy in the numerics annex. --- One advantage of using this package is that it will interface directly to --- hardware instructions, such as the those provided on the Intel x86. - --- This version here is for use with normal Unix math functions. Alternative --- versions are provided for special situations: - --- a-numaux-darwin For PowerPC/Darwin (special handling of sin/cos) --- a-numaux-libc-x86 For the x86, using 80-bit long double format --- a-numaux-x86 For the x86, using 80-bit long double format with --- inline asm statements --- a-numaux-vxworks For use on VxWorks (where we have no libm.a library) - -package Ada.Numerics.Aux is - pragma Pure; - - pragma Linker_Options ("-lm"); - - type Double is new Long_Float; - -- Type Double is the type used to call the C routines - - -- We import these functions directly from C. Note that we label them - -- all as pure functions, because indeed all of them are in fact pure. - - function Sin (X : Double) return Double; - pragma Import (C, Sin, "sin"); - pragma Pure_Function (Sin); - - function Cos (X : Double) return Double; - pragma Import (C, Cos, "cos"); - pragma Pure_Function (Cos); - - function Tan (X : Double) return Double; - pragma Import (C, Tan, "tan"); - pragma Pure_Function (Tan); - - function Exp (X : Double) return Double; - pragma Import (C, Exp, "exp"); - pragma Pure_Function (Exp); - - function Sqrt (X : Double) return Double; - pragma Import (C, Sqrt, "sqrt"); - pragma Pure_Function (Sqrt); - - function Log (X : Double) return Double; - pragma Import (C, Log, "log"); - pragma Pure_Function (Log); - - function Acos (X : Double) return Double; - pragma Import (C, Acos, "acos"); - pragma Pure_Function (Acos); - - function Asin (X : Double) return Double; - pragma Import (C, Asin, "asin"); - pragma Pure_Function (Asin); - - function Atan (X : Double) return Double; - pragma Import (C, Atan, "atan"); - pragma Pure_Function (Atan); - - function Sinh (X : Double) return Double; - pragma Import (C, Sinh, "sinh"); - pragma Pure_Function (Sinh); - - function Cosh (X : Double) return Double; - pragma Import (C, Cosh, "cosh"); - pragma Pure_Function (Cosh); - - function Tanh (X : Double) return Double; - pragma Import (C, Tanh, "tanh"); - pragma Pure_Function (Tanh); - - function Pow (X, Y : Double) return Double; - pragma Import (C, Pow, "pow"); - pragma Pure_Function (Pow); - -end Ada.Numerics.Aux; diff --git a/gcc/ada/a-numeri.ads b/gcc/ada/a-numeri.ads deleted file mode 100644 index 805fa56..0000000 --- a/gcc/ada/a-numeri.ads +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Numerics is - pragma Pure; - - Argument_Error : exception; - - Pi : constant := - 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; - - ["03C0"] : constant := Pi; - -- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is - -- conforming to have this constant present even in Ada 95 mode, as there - -- is no way for a normal mode Ada 95 program to reference this identifier. - - e : constant := - 2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996; - -end Ada.Numerics; diff --git a/gcc/ada/a-nurear.ads b/gcc/ada/a-nurear.ads deleted file mode 100644 index 0197599..0000000 --- a/gcc/ada/a-nurear.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . N U M E R I C S . R E A L _ A R R A Y S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Real_Arrays; - -package Ada.Numerics.Real_Arrays is - new Ada.Numerics.Generic_Real_Arrays (Float); - -pragma Pure (Real_Arrays); diff --git a/gcc/ada/a-rbtgbk.adb b/gcc/ada/a-rbtgbk.adb deleted file mode 100644 index abf7773..0000000 --- a/gcc/ada/a-rbtgbk.adb +++ /dev/null @@ -1,627 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is - - package Ops renames Tree_Operations; - - ------------- - -- Ceiling -- - ------------- - - -- AKA Lower_Bound - - function Ceiling - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type - is - Y : Count_Type; - X : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - Y := 0; - - X := Tree.Root; - while X /= 0 loop - if Is_Greater_Key_Node (Key, N (X)) then - X := Ops.Right (N (X)); - else - Y := X; - X := Ops.Left (N (X)); - end if; - end loop; - - return Y; - end Ceiling; - - ---------- - -- Find -- - ---------- - - function Find - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type - is - Y : Count_Type; - X : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - Y := 0; - - X := Tree.Root; - while X /= 0 loop - if Is_Greater_Key_Node (Key, N (X)) then - X := Ops.Right (N (X)); - else - Y := X; - X := Ops.Left (N (X)); - end if; - end loop; - - if Y = 0 then - return 0; - end if; - - if Is_Less_Key_Node (Key, N (Y)) then - return 0; - end if; - - return Y; - end Find; - - ----------- - -- Floor -- - ----------- - - function Floor - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type - is - Y : Count_Type; - X : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - Y := 0; - - X := Tree.Root; - while X /= 0 loop - if Is_Less_Key_Node (Key, N (X)) then - X := Ops.Left (N (X)); - else - Y := X; - X := Ops.Right (N (X)); - end if; - end loop; - - return Y; - end Floor; - - -------------------------------- - -- Generic_Conditional_Insert -- - -------------------------------- - - procedure Generic_Conditional_Insert - (Tree : in out Tree_Type'Class; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - Y : Count_Type; - X : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - -- This is a "conditional" insertion, meaning that the insertion request - -- can "fail" in the sense that no new node is created. If the Key is - -- equivalent to an existing node, then we return the existing node and - -- Inserted is set to False. Otherwise, we allocate a new node (via - -- Insert_Post) and Inserted is set to True. - - -- Note that we are testing for equivalence here, not equality. Key must - -- be strictly less than its next neighbor, and strictly greater than - -- its previous neighbor, in order for the conditional insertion to - -- succeed. - - -- We search the tree to find the nearest neighbor of Key, which is - -- either the smallest node greater than Key (Inserted is True), or the - -- largest node less or equivalent to Key (Inserted is False). - - Y := 0; - X := Tree.Root; - Inserted := True; - while X /= 0 loop - Y := X; - Inserted := Is_Less_Key_Node (Key, N (X)); - X := (if Inserted then Ops.Left (N (X)) else Ops.Right (N (X))); - end loop; - - if Inserted then - - -- Either Tree is empty, or Key is less than Y. If Y is the first - -- node in the tree, then there are no other nodes that we need to - -- search for, and we insert a new node into the tree. - - if Y = Tree.First then - Insert_Post (Tree, Y, True, Node); - return; - end if; - - -- Y is the next nearest-neighbor of Key. We know that Key is not - -- equivalent to Y (because Key is strictly less than Y), so we move - -- to the previous node, the nearest-neighbor just smaller or - -- equivalent to Key. - - Node := Ops.Previous (Tree, Y); - - else - -- Y is the previous nearest-neighbor of Key. We know that Key is not - -- less than Y, which means either that Key is equivalent to Y, or - -- greater than Y. - - Node := Y; - end if; - - -- Key is equivalent to or greater than Node. We must resolve which is - -- the case, to determine whether the conditional insertion succeeds. - - if Is_Greater_Key_Node (Key, N (Node)) then - - -- Key is strictly greater than Node, which means that Key is not - -- equivalent to Node. In this case, the insertion succeeds, and we - -- insert a new node into the tree. - - Insert_Post (Tree, Y, Inserted, Node); - Inserted := True; - return; - end if; - - -- Key is equivalent to Node. This is a conditional insertion, so we do - -- not insert a new node in this case. We return the existing node and - -- report that no insertion has occurred. - - Inserted := False; - end Generic_Conditional_Insert; - - ------------------------------------------ - -- Generic_Conditional_Insert_With_Hint -- - ------------------------------------------ - - procedure Generic_Conditional_Insert_With_Hint - (Tree : in out Tree_Type'Class; - Position : Count_Type; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean) - is - N : Nodes_Type renames Tree.Nodes; - - begin - -- The purpose of a hint is to avoid a search from the root of - -- tree. If we have it hint it means we only need to traverse the - -- subtree rooted at the hint to find the nearest neighbor. Note - -- that finding the neighbor means merely walking the tree; this - -- is not a search and the only comparisons that occur are with - -- the hint and its neighbor. - - -- If Position is 0, this is interpreted to mean that Key is - -- large relative to the nodes in the tree. If the tree is empty, - -- or Key is greater than the last node in the tree, then we're - -- done; otherwise the hint was "wrong" and we must search. - - if Position = 0 then -- largest - if Tree.Last = 0 - or else Is_Greater_Key_Node (Key, N (Tree.Last)) - then - Insert_Post (Tree, Tree.Last, False, Node); - Inserted := True; - else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); - end if; - - return; - end if; - - pragma Assert (Tree.Length > 0); - - -- A hint can either name the node that immediately follows Key, - -- or immediately precedes Key. We first test whether Key is - -- less than the hint, and if so we compare Key to the node that - -- precedes the hint. If Key is both less than the hint and - -- greater than the hint's preceding neighbor, then we're done; - -- otherwise we must search. - - -- Note also that a hint can either be an anterior node or a leaf - -- node. A new node is always inserted at the bottom of the tree - -- (at least prior to rebalancing), becoming the new left or - -- right child of leaf node (which prior to the insertion must - -- necessarily be null, since this is a leaf). If the hint names - -- an anterior node then its neighbor must be a leaf, and so - -- (here) we insert after the neighbor. If the hint names a leaf - -- then its neighbor must be anterior and so we insert before the - -- hint. - - if Is_Less_Key_Node (Key, N (Position)) then - declare - Before : constant Count_Type := Ops.Previous (Tree, Position); - - begin - if Before = 0 then - Insert_Post (Tree, Tree.First, True, Node); - Inserted := True; - - elsif Is_Greater_Key_Node (Key, N (Before)) then - if Ops.Right (N (Before)) = 0 then - Insert_Post (Tree, Before, False, Node); - else - Insert_Post (Tree, Position, True, Node); - end if; - - Inserted := True; - - else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); - end if; - end; - - return; - end if; - - -- We know that Key isn't less than the hint so we try again, - -- this time to see if it's greater than the hint. If so we - -- compare Key to the node that follows the hint. If Key is both - -- greater than the hint and less than the hint's next neighbor, - -- then we're done; otherwise we must search. - - if Is_Greater_Key_Node (Key, N (Position)) then - declare - After : constant Count_Type := Ops.Next (Tree, Position); - - begin - if After = 0 then - Insert_Post (Tree, Tree.Last, False, Node); - Inserted := True; - - elsif Is_Less_Key_Node (Key, N (After)) then - if Ops.Right (N (Position)) = 0 then - Insert_Post (Tree, Position, False, Node); - else - Insert_Post (Tree, After, True, Node); - end if; - - Inserted := True; - - else - Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); - end if; - end; - - return; - end if; - - -- We know that Key is neither less than the hint nor greater - -- than the hint, and that's the definition of equivalence. - -- There's nothing else we need to do, since a search would just - -- reach the same conclusion. - - Node := Position; - Inserted := False; - end Generic_Conditional_Insert_With_Hint; - - ------------------------- - -- Generic_Insert_Post -- - ------------------------- - - procedure Generic_Insert_Post - (Tree : in out Tree_Type'Class; - Y : Count_Type; - Before : Boolean; - Z : out Count_Type) - is - N : Nodes_Type renames Tree.Nodes; - - begin - TC_Check (Tree.TC); - - if Checks and then Tree.Length >= Tree.Capacity then - raise Capacity_Error with "not enough capacity to insert new item"; - end if; - - Z := New_Node; - pragma Assert (Z /= 0); - - if Y = 0 then - pragma Assert (Tree.Length = 0); - pragma Assert (Tree.Root = 0); - pragma Assert (Tree.First = 0); - pragma Assert (Tree.Last = 0); - - Tree.Root := Z; - Tree.First := Z; - Tree.Last := Z; - - elsif Before then - pragma Assert (Ops.Left (N (Y)) = 0); - - Ops.Set_Left (N (Y), Z); - - if Y = Tree.First then - Tree.First := Z; - end if; - - else - pragma Assert (Ops.Right (N (Y)) = 0); - - Ops.Set_Right (N (Y), Z); - - if Y = Tree.Last then - Tree.Last := Z; - end if; - end if; - - Ops.Set_Color (N (Z), Red); - Ops.Set_Parent (N (Z), Y); - Ops.Rebalance_For_Insert (Tree, Z); - Tree.Length := Tree.Length + 1; - end Generic_Insert_Post; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration - (Tree : Tree_Type'Class; - Key : Key_Type) - is - procedure Iterate (Index : Count_Type); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (Index : Count_Type) is - J : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - J := Index; - while J /= 0 loop - if Is_Less_Key_Node (Key, N (J)) then - J := Ops.Left (N (J)); - elsif Is_Greater_Key_Node (Key, N (J)) then - J := Ops.Right (N (J)); - else - Iterate (Ops.Left (N (J))); - Process (J); - J := Ops.Right (N (J)); - end if; - end loop; - end Iterate; - - -- Start of processing for Generic_Iteration - - begin - Iterate (Tree.Root); - end Generic_Iteration; - - ------------------------------- - -- Generic_Reverse_Iteration -- - ------------------------------- - - procedure Generic_Reverse_Iteration - (Tree : Tree_Type'Class; - Key : Key_Type) - is - procedure Iterate (Index : Count_Type); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (Index : Count_Type) is - J : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - J := Index; - while J /= 0 loop - if Is_Less_Key_Node (Key, N (J)) then - J := Ops.Left (N (J)); - elsif Is_Greater_Key_Node (Key, N (J)) then - J := Ops.Right (N (J)); - else - Iterate (Ops.Right (N (J))); - Process (J); - J := Ops.Left (N (J)); - end if; - end loop; - end Iterate; - - -- Start of processing for Generic_Reverse_Iteration - - begin - Iterate (Tree.Root); - end Generic_Reverse_Iteration; - - ---------------------------------- - -- Generic_Unconditional_Insert -- - ---------------------------------- - - procedure Generic_Unconditional_Insert - (Tree : in out Tree_Type'Class; - Key : Key_Type; - Node : out Count_Type) - is - Y : Count_Type; - X : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - Before : Boolean; - - begin - Y := 0; - Before := False; - - X := Tree.Root; - while X /= 0 loop - Y := X; - Before := Is_Less_Key_Node (Key, N (X)); - X := (if Before then Ops.Left (N (X)) else Ops.Right (N (X))); - end loop; - - Insert_Post (Tree, Y, Before, Node); - end Generic_Unconditional_Insert; - - -------------------------------------------- - -- Generic_Unconditional_Insert_With_Hint -- - -------------------------------------------- - - procedure Generic_Unconditional_Insert_With_Hint - (Tree : in out Tree_Type'Class; - Hint : Count_Type; - Key : Key_Type; - Node : out Count_Type) - is - N : Nodes_Type renames Tree.Nodes; - - begin - -- There are fewer constraints for an unconditional insertion - -- than for a conditional insertion, since we allow duplicate - -- keys. So instead of having to check (say) whether Key is - -- (strictly) greater than the hint's previous neighbor, here we - -- allow Key to be equal to or greater than the previous node. - - -- There is the issue of what to do if Key is equivalent to the - -- hint. Does the new node get inserted before or after the hint? - -- We decide that it gets inserted after the hint, reasoning that - -- this is consistent with behavior for non-hint insertion, which - -- inserts a new node after existing nodes with equivalent keys. - - -- First we check whether the hint is null, which is interpreted - -- to mean that Key is large relative to existing nodes. - -- Following our rule above, if Key is equal to or greater than - -- the last node, then we insert the new node immediately after - -- last. (We don't have an operation for testing whether a key is - -- "equal to or greater than" a node, so we must say instead "not - -- less than", which is equivalent.) - - if Hint = 0 then -- largest - if Tree.Last = 0 then - Insert_Post (Tree, 0, False, Node); - elsif Is_Less_Key_Node (Key, N (Tree.Last)) then - Unconditional_Insert_Sans_Hint (Tree, Key, Node); - else - Insert_Post (Tree, Tree.Last, False, Node); - end if; - - return; - end if; - - pragma Assert (Tree.Length > 0); - - -- We decide here whether to insert the new node prior to the - -- hint. Key could be equivalent to the hint, so in theory we - -- could write the following test as "not greater than" (same as - -- "less than or equal to"). If Key were equivalent to the hint, - -- that would mean that the new node gets inserted before an - -- equivalent node. That wouldn't break any container invariants, - -- but our rule above says that new nodes always get inserted - -- after equivalent nodes. So here we test whether Key is both - -- less than the hint and equal to or greater than the hint's - -- previous neighbor, and if so insert it before the hint. - - if Is_Less_Key_Node (Key, N (Hint)) then - declare - Before : constant Count_Type := Ops.Previous (Tree, Hint); - begin - if Before = 0 then - Insert_Post (Tree, Hint, True, Node); - elsif Is_Less_Key_Node (Key, N (Before)) then - Unconditional_Insert_Sans_Hint (Tree, Key, Node); - elsif Ops.Right (N (Before)) = 0 then - Insert_Post (Tree, Before, False, Node); - else - Insert_Post (Tree, Hint, True, Node); - end if; - end; - - return; - end if; - - -- We know that Key isn't less than the hint, so it must be equal - -- or greater. So we just test whether Key is less than or equal - -- to (same as "not greater than") the hint's next neighbor, and - -- if so insert it after the hint. - - declare - After : constant Count_Type := Ops.Next (Tree, Hint); - begin - if After = 0 then - Insert_Post (Tree, Hint, False, Node); - elsif Is_Greater_Key_Node (Key, N (After)) then - Unconditional_Insert_Sans_Hint (Tree, Key, Node); - elsif Ops.Right (N (Hint)) = 0 then - Insert_Post (Tree, Hint, False, Node); - else - Insert_Post (Tree, After, True, Node); - end if; - end; - end Generic_Unconditional_Insert_With_Hint; - - ----------------- - -- Upper_Bound -- - ----------------- - - function Upper_Bound - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type - is - Y : Count_Type; - X : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - Y := 0; - - X := Tree.Root; - while X /= 0 loop - if Is_Less_Key_Node (Key, N (X)) then - Y := X; - X := Ops.Left (N (X)); - else - X := Ops.Right (N (X)); - end if; - end loop; - - return Y; - end Upper_Bound; - -end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; diff --git a/gcc/ada/a-rbtgbk.ads b/gcc/ada/a-rbtgbk.ads deleted file mode 100644 index 1cf1cbc..0000000 --- a/gcc/ada/a-rbtgbk.ads +++ /dev/null @@ -1,193 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Tree_Type is used to implement ordered containers. This package declares --- the tree operations that depend on keys. - -with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; - -generic - with package Tree_Operations is new Generic_Bounded_Operations (<>); - - use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; - - type Key_Type (<>) is limited private; - - with function Is_Less_Key_Node - (L : Key_Type; - R : Node_Type) return Boolean; - - with function Is_Greater_Key_Node - (L : Key_Type; - R : Node_Type) return Boolean; - -package Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is - pragma Pure; - - generic - with function New_Node return Count_Type; - - procedure Generic_Insert_Post - (Tree : in out Tree_Type'Class; - Y : Count_Type; - Before : Boolean; - Z : out Count_Type); - -- Completes an insertion after the insertion position has been - -- determined. On output Z contains the index of the newly inserted - -- node, allocated using Allocate. If Tree is busy then - -- Program_Error is raised. If Y is 0, then Tree must be empty. - -- Otherwise Y denotes the insertion position, and Before specifies - -- whether the new node is Y's left (True) or right (False) child. - - generic - with procedure Insert_Post - (T : in out Tree_Type'Class; - Y : Count_Type; - B : Boolean; - Z : out Count_Type); - - procedure Generic_Conditional_Insert - (Tree : in out Tree_Type'Class; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean); - -- Inserts a new node in Tree, but only if the tree does not already - -- contain Key. Generic_Conditional_Insert first searches for a key - -- equivalent to Key in Tree. If an equivalent key is found, then on - -- output Node designates the node with that key and Inserted is - -- False; there is no allocation and Tree is not modified. Otherwise - -- Node designates a new node allocated using Insert_Post, and - -- Inserted is True. - - generic - with procedure Insert_Post - (T : in out Tree_Type'Class; - Y : Count_Type; - B : Boolean; - Z : out Count_Type); - - procedure Generic_Unconditional_Insert - (Tree : in out Tree_Type'Class; - Key : Key_Type; - Node : out Count_Type); - -- Inserts a new node in Tree. On output Node designates the new - -- node, which is allocated using Insert_Post. The node is inserted - -- immediately after already-existing equivalent keys. - - generic - with procedure Insert_Post - (T : in out Tree_Type'Class; - Y : Count_Type; - B : Boolean; - Z : out Count_Type); - - with procedure Unconditional_Insert_Sans_Hint - (Tree : in out Tree_Type'Class; - Key : Key_Type; - Node : out Count_Type); - - procedure Generic_Unconditional_Insert_With_Hint - (Tree : in out Tree_Type'Class; - Hint : Count_Type; - Key : Key_Type; - Node : out Count_Type); - -- Inserts a new node in Tree near position Hint, to avoid having to - -- search from the root for the insertion position. If Hint is 0 - -- then Generic_Unconditional_Insert_With_Hint attempts to insert - -- the new node after Tree.Last. If Hint is non-zero then if Key is - -- less than Hint, it attempts to insert the new node immediately - -- prior to Hint. Otherwise it attempts to insert the node - -- immediately following Hint. We say "attempts" above to emphasize - -- that insertions always preserve invariants with respect to key - -- order, even when there's a hint. So if Key can't be inserted - -- immediately near Hint, then the new node is inserted in the - -- normal way, by searching for the correct position starting from - -- the root. - - generic - with procedure Insert_Post - (T : in out Tree_Type'Class; - Y : Count_Type; - B : Boolean; - Z : out Count_Type); - - with procedure Conditional_Insert_Sans_Hint - (Tree : in out Tree_Type'Class; - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean); - - procedure Generic_Conditional_Insert_With_Hint - (Tree : in out Tree_Type'Class; - Position : Count_Type; -- the hint - Key : Key_Type; - Node : out Count_Type; - Inserted : out Boolean); - -- Inserts a new node in Tree if the tree does not already contain - -- Key, using Position as a hint about where to insert the new node. - -- See Generic_Unconditional_Insert_With_Hint for more details about - -- hint semantics. - - function Find - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type; - -- Searches Tree for the smallest node equivalent to Key - - function Ceiling - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type; - -- Searches Tree for the smallest node equal to or greater than Key - - function Floor - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type; - -- Searches Tree for the largest node less than or equal to Key - - function Upper_Bound - (Tree : Tree_Type'Class; - Key : Key_Type) return Count_Type; - -- Searches Tree for the smallest node greater than Key - - generic - with procedure Process (Index : Count_Type); - procedure Generic_Iteration - (Tree : Tree_Type'Class; - Key : Key_Type); - -- Calls Process for each node in Tree equivalent to Key, in order - -- from earliest in range to latest. - - generic - with procedure Process (Index : Count_Type); - procedure Generic_Reverse_Iteration - (Tree : Tree_Type'Class; - Key : Key_Type); - -- Calls Process for each node in Tree equivalent to Key, but in - -- order from largest in range to earliest. - -end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; diff --git a/gcc/ada/a-rbtgbo.adb b/gcc/ada/a-rbtgbo.adb deleted file mode 100644 index 8306399e..0000000 --- a/gcc/ada/a-rbtgbo.adb +++ /dev/null @@ -1,1127 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- The references in this file to "CLR" refer to the following book, from --- which several of the algorithms here were adapted: - --- Introduction to Algorithms --- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest --- Publisher: The MIT Press (June 18, 1990) --- ISBN: 0262031418 - -with System; use type System.Address; - -package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type); - procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type); - - procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type); - procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type); - - ---------------- - -- Clear_Tree -- - ---------------- - - procedure Clear_Tree (Tree : in out Tree_Type'Class) is - begin - TC_Check (Tree.TC); - - Tree.First := 0; - Tree.Last := 0; - Tree.Root := 0; - Tree.Length := 0; - Tree.Free := -1; - end Clear_Tree; - - ------------------ - -- Delete_Fixup -- - ------------------ - - procedure Delete_Fixup - (Tree : in out Tree_Type'Class; - Node : Count_Type) - is - -- CLR p. 274 - - X : Count_Type; - W : Count_Type; - N : Nodes_Type renames Tree.Nodes; - - begin - X := Node; - while X /= Tree.Root and then Color (N (X)) = Black loop - if X = Left (N (Parent (N (X)))) then - W := Right (N (Parent (N (X)))); - - if Color (N (W)) = Red then - Set_Color (N (W), Black); - Set_Color (N (Parent (N (X))), Red); - Left_Rotate (Tree, Parent (N (X))); - W := Right (N (Parent (N (X)))); - end if; - - if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) - and then - (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) - then - Set_Color (N (W), Red); - X := Parent (N (X)); - - else - if Right (N (W)) = 0 - or else Color (N (Right (N (W)))) = Black - then - -- As a condition for setting the color of the left child to - -- black, the left child access value must be non-null. A - -- truth table analysis shows that if we arrive here, that - -- condition holds, so there's no need for an explicit test. - -- The assertion is here to document what we know is true. - - pragma Assert (Left (N (W)) /= 0); - Set_Color (N (Left (N (W))), Black); - - Set_Color (N (W), Red); - Right_Rotate (Tree, W); - W := Right (N (Parent (N (X)))); - end if; - - Set_Color (N (W), Color (N (Parent (N (X))))); - Set_Color (N (Parent (N (X))), Black); - Set_Color (N (Right (N (W))), Black); - Left_Rotate (Tree, Parent (N (X))); - X := Tree.Root; - end if; - - else - pragma Assert (X = Right (N (Parent (N (X))))); - - W := Left (N (Parent (N (X)))); - - if Color (N (W)) = Red then - Set_Color (N (W), Black); - Set_Color (N (Parent (N (X))), Red); - Right_Rotate (Tree, Parent (N (X))); - W := Left (N (Parent (N (X)))); - end if; - - if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) - and then - (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) - then - Set_Color (N (W), Red); - X := Parent (N (X)); - - else - if Left (N (W)) = 0 - or else Color (N (Left (N (W)))) = Black - then - -- As a condition for setting the color of the right child - -- to black, the right child access value must be non-null. - -- A truth table analysis shows that if we arrive here, that - -- condition holds, so there's no need for an explicit test. - -- The assertion is here to document what we know is true. - - pragma Assert (Right (N (W)) /= 0); - Set_Color (N (Right (N (W))), Black); - - Set_Color (N (W), Red); - Left_Rotate (Tree, W); - W := Left (N (Parent (N (X)))); - end if; - - Set_Color (N (W), Color (N (Parent (N (X))))); - Set_Color (N (Parent (N (X))), Black); - Set_Color (N (Left (N (W))), Black); - Right_Rotate (Tree, Parent (N (X))); - X := Tree.Root; - end if; - end if; - end loop; - - Set_Color (N (X), Black); - end Delete_Fixup; - - --------------------------- - -- Delete_Node_Sans_Free -- - --------------------------- - - procedure Delete_Node_Sans_Free - (Tree : in out Tree_Type'Class; - Node : Count_Type) - is - -- CLR p. 273 - - X, Y : Count_Type; - - Z : constant Count_Type := Node; - - N : Nodes_Type renames Tree.Nodes; - - begin - TC_Check (Tree.TC); - - -- If node is not present, return (exception will be raised in caller) - - if Z = 0 then - return; - end if; - - pragma Assert (Tree.Length > 0); - pragma Assert (Tree.Root /= 0); - pragma Assert (Tree.First /= 0); - pragma Assert (Tree.Last /= 0); - pragma Assert (Parent (N (Tree.Root)) = 0); - - pragma Assert ((Tree.Length > 1) - or else (Tree.First = Tree.Last - and then Tree.First = Tree.Root)); - - pragma Assert ((Left (N (Node)) = 0) - or else (Parent (N (Left (N (Node)))) = Node)); - - pragma Assert ((Right (N (Node)) = 0) - or else (Parent (N (Right (N (Node)))) = Node)); - - pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node)) - or else ((Parent (N (Node)) /= 0) and then - ((Left (N (Parent (N (Node)))) = Node) - or else - (Right (N (Parent (N (Node)))) = Node)))); - - if Left (N (Z)) = 0 then - if Right (N (Z)) = 0 then - if Z = Tree.First then - Tree.First := Parent (N (Z)); - end if; - - if Z = Tree.Last then - Tree.Last := Parent (N (Z)); - end if; - - if Color (N (Z)) = Black then - Delete_Fixup (Tree, Z); - end if; - - pragma Assert (Left (N (Z)) = 0); - pragma Assert (Right (N (Z)) = 0); - - if Z = Tree.Root then - pragma Assert (Tree.Length = 1); - pragma Assert (Parent (N (Z)) = 0); - Tree.Root := 0; - elsif Z = Left (N (Parent (N (Z)))) then - Set_Left (N (Parent (N (Z))), 0); - else - pragma Assert (Z = Right (N (Parent (N (Z))))); - Set_Right (N (Parent (N (Z))), 0); - end if; - - else - pragma Assert (Z /= Tree.Last); - - X := Right (N (Z)); - - if Z = Tree.First then - Tree.First := Min (Tree, X); - end if; - - if Z = Tree.Root then - Tree.Root := X; - elsif Z = Left (N (Parent (N (Z)))) then - Set_Left (N (Parent (N (Z))), X); - else - pragma Assert (Z = Right (N (Parent (N (Z))))); - Set_Right (N (Parent (N (Z))), X); - end if; - - Set_Parent (N (X), Parent (N (Z))); - - if Color (N (Z)) = Black then - Delete_Fixup (Tree, X); - end if; - end if; - - elsif Right (N (Z)) = 0 then - pragma Assert (Z /= Tree.First); - - X := Left (N (Z)); - - if Z = Tree.Last then - Tree.Last := Max (Tree, X); - end if; - - if Z = Tree.Root then - Tree.Root := X; - elsif Z = Left (N (Parent (N (Z)))) then - Set_Left (N (Parent (N (Z))), X); - else - pragma Assert (Z = Right (N (Parent (N (Z))))); - Set_Right (N (Parent (N (Z))), X); - end if; - - Set_Parent (N (X), Parent (N (Z))); - - if Color (N (Z)) = Black then - Delete_Fixup (Tree, X); - end if; - - else - pragma Assert (Z /= Tree.First); - pragma Assert (Z /= Tree.Last); - - Y := Next (Tree, Z); - pragma Assert (Left (N (Y)) = 0); - - X := Right (N (Y)); - - if X = 0 then - if Y = Left (N (Parent (N (Y)))) then - pragma Assert (Parent (N (Y)) /= Z); - Delete_Swap (Tree, Z, Y); - Set_Left (N (Parent (N (Z))), Z); - - else - pragma Assert (Y = Right (N (Parent (N (Y))))); - pragma Assert (Parent (N (Y)) = Z); - Set_Parent (N (Y), Parent (N (Z))); - - if Z = Tree.Root then - Tree.Root := Y; - elsif Z = Left (N (Parent (N (Z)))) then - Set_Left (N (Parent (N (Z))), Y); - else - pragma Assert (Z = Right (N (Parent (N (Z))))); - Set_Right (N (Parent (N (Z))), Y); - end if; - - Set_Left (N (Y), Left (N (Z))); - Set_Parent (N (Left (N (Y))), Y); - Set_Right (N (Y), Z); - - Set_Parent (N (Z), Y); - Set_Left (N (Z), 0); - Set_Right (N (Z), 0); - - declare - Y_Color : constant Color_Type := Color (N (Y)); - begin - Set_Color (N (Y), Color (N (Z))); - Set_Color (N (Z), Y_Color); - end; - end if; - - if Color (N (Z)) = Black then - Delete_Fixup (Tree, Z); - end if; - - pragma Assert (Left (N (Z)) = 0); - pragma Assert (Right (N (Z)) = 0); - - if Z = Right (N (Parent (N (Z)))) then - Set_Right (N (Parent (N (Z))), 0); - else - pragma Assert (Z = Left (N (Parent (N (Z))))); - Set_Left (N (Parent (N (Z))), 0); - end if; - - else - if Y = Left (N (Parent (N (Y)))) then - pragma Assert (Parent (N (Y)) /= Z); - - Delete_Swap (Tree, Z, Y); - - Set_Left (N (Parent (N (Z))), X); - Set_Parent (N (X), Parent (N (Z))); - - else - pragma Assert (Y = Right (N (Parent (N (Y))))); - pragma Assert (Parent (N (Y)) = Z); - - Set_Parent (N (Y), Parent (N (Z))); - - if Z = Tree.Root then - Tree.Root := Y; - elsif Z = Left (N (Parent (N (Z)))) then - Set_Left (N (Parent (N (Z))), Y); - else - pragma Assert (Z = Right (N (Parent (N (Z))))); - Set_Right (N (Parent (N (Z))), Y); - end if; - - Set_Left (N (Y), Left (N (Z))); - Set_Parent (N (Left (N (Y))), Y); - - declare - Y_Color : constant Color_Type := Color (N (Y)); - begin - Set_Color (N (Y), Color (N (Z))); - Set_Color (N (Z), Y_Color); - end; - end if; - - if Color (N (Z)) = Black then - Delete_Fixup (Tree, X); - end if; - end if; - end if; - - Tree.Length := Tree.Length - 1; - end Delete_Node_Sans_Free; - - ----------------- - -- Delete_Swap -- - ----------------- - - procedure Delete_Swap - (Tree : in out Tree_Type'Class; - Z, Y : Count_Type) - is - N : Nodes_Type renames Tree.Nodes; - - pragma Assert (Z /= Y); - pragma Assert (Parent (N (Y)) /= Z); - - Y_Parent : constant Count_Type := Parent (N (Y)); - Y_Color : constant Color_Type := Color (N (Y)); - - begin - Set_Parent (N (Y), Parent (N (Z))); - Set_Left (N (Y), Left (N (Z))); - Set_Right (N (Y), Right (N (Z))); - Set_Color (N (Y), Color (N (Z))); - - if Tree.Root = Z then - Tree.Root := Y; - elsif Right (N (Parent (N (Y)))) = Z then - Set_Right (N (Parent (N (Y))), Y); - else - pragma Assert (Left (N (Parent (N (Y)))) = Z); - Set_Left (N (Parent (N (Y))), Y); - end if; - - if Right (N (Y)) /= 0 then - Set_Parent (N (Right (N (Y))), Y); - end if; - - if Left (N (Y)) /= 0 then - Set_Parent (N (Left (N (Y))), Y); - end if; - - Set_Parent (N (Z), Y_Parent); - Set_Color (N (Z), Y_Color); - Set_Left (N (Z), 0); - Set_Right (N (Z), 0); - end Delete_Swap; - - ---------- - -- Free -- - ---------- - - procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is - pragma Assert (X > 0); - pragma Assert (X <= Tree.Capacity); - - N : Nodes_Type renames Tree.Nodes; - -- pragma Assert (N (X).Prev >= 0); -- node is active - -- Find a way to mark a node as active vs. inactive; we could - -- use a special value in Color_Type for this. ??? - - begin - -- The set container actually contains two data structures: a list for - -- the "active" nodes that contain elements that have been inserted - -- onto the tree, and another for the "inactive" nodes of the free - -- store. - -- - -- We desire that merely declaring an object should have only minimal - -- cost; specially, we want to avoid having to initialize the free - -- store (to fill in the links), especially if the capacity is large. - -- - -- The head of the free list is indicated by Container.Free. If its - -- value is non-negative, then the free store has been initialized - -- in the "normal" way: Container.Free points to the head of the list - -- of free (inactive) nodes, and the value 0 means the free list is - -- empty. Each node on the free list has been initialized to point - -- to the next free node (via its Parent component), and the value 0 - -- means that this is the last free node. - -- - -- If Container.Free is negative, then the links on the free store - -- have not been initialized. In this case the link values are - -- implied: the free store comprises the components of the node array - -- started with the absolute value of Container.Free, and continuing - -- until the end of the array (Nodes'Last). - -- - -- ??? - -- It might be possible to perform an optimization here. Suppose that - -- the free store can be represented as having two parts: one - -- comprising the non-contiguous inactive nodes linked together - -- in the normal way, and the other comprising the contiguous - -- inactive nodes (that are not linked together, at the end of the - -- nodes array). This would allow us to never have to initialize - -- the free store, except in a lazy way as nodes become inactive. - - -- When an element is deleted from the list container, its node - -- becomes inactive, and so we set its Prev component to a negative - -- value, to indicate that it is now inactive. This provides a useful - -- way to detect a dangling cursor reference. - - -- The comment above is incorrect; we need some other way to - -- indicate a node is inactive, for example by using a special - -- Color_Type value. ??? - -- N (X).Prev := -1; -- Node is deallocated (not on active list) - - if Tree.Free >= 0 then - -- The free store has previously been initialized. All we need to - -- do here is link the newly-free'd node onto the free list. - - Set_Parent (N (X), Tree.Free); - Tree.Free := X; - - elsif X + 1 = abs Tree.Free then - -- The free store has not been initialized, and the node becoming - -- inactive immediately precedes the start of the free store. All - -- we need to do is move the start of the free store back by one. - - Tree.Free := Tree.Free + 1; - - else - -- The free store has not been initialized, and the node becoming - -- inactive does not immediately precede the free store. Here we - -- first initialize the free store (meaning the links are given - -- values in the traditional way), and then link the newly-free'd - -- node onto the head of the free store. - - -- ??? - -- See the comments above for an optimization opportunity. If the - -- next link for a node on the free store is negative, then this - -- means the remaining nodes on the free store are physically - -- contiguous, starting as the absolute value of that index value. - - Tree.Free := abs Tree.Free; - - if Tree.Free > Tree.Capacity then - Tree.Free := 0; - - else - for I in Tree.Free .. Tree.Capacity - 1 loop - Set_Parent (N (I), I + 1); - end loop; - - Set_Parent (N (Tree.Capacity), 0); - end if; - - Set_Parent (N (X), Tree.Free); - Tree.Free := X; - end if; - end Free; - - ----------------------- - -- Generic_Allocate -- - ----------------------- - - procedure Generic_Allocate - (Tree : in out Tree_Type'Class; - Node : out Count_Type) - is - N : Nodes_Type renames Tree.Nodes; - - begin - if Tree.Free >= 0 then - Node := Tree.Free; - - -- We always perform the assignment first, before we - -- change container state, in order to defend against - -- exceptions duration assignment. - - Set_Element (N (Node)); - Tree.Free := Parent (N (Node)); - - else - -- A negative free store value means that the links of the nodes - -- in the free store have not been initialized. In this case, the - -- nodes are physically contiguous in the array, starting at the - -- index that is the absolute value of the Container.Free, and - -- continuing until the end of the array (Nodes'Last). - - Node := abs Tree.Free; - - -- As above, we perform this assignment first, before modifying - -- any container state. - - Set_Element (N (Node)); - Tree.Free := Tree.Free - 1; - end if; - - -- When a node is allocated from the free store, its pointer components - -- (the links to other nodes in the tree) must also be initialized (to - -- 0, the equivalent of null). This simplifies the post-allocation - -- handling of nodes inserted into terminal positions. - - Set_Parent (N (Node), Parent => 0); - Set_Left (N (Node), Left => 0); - Set_Right (N (Node), Right => 0); - end Generic_Allocate; - - ------------------- - -- Generic_Equal -- - ------------------- - - function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Count_Type; - R_Node : Count_Type; - - begin - if Left'Address = Right'Address then - return True; - end if; - - if Left.Length /= Right.Length then - return False; - end if; - - -- If the containers are empty, return a result immediately, so as to - -- not manipulate the tamper bits unnecessarily. - - if Left.Length = 0 then - return True; - end if; - - L_Node := Left.First; - R_Node := Right.First; - while L_Node /= 0 loop - if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then - return False; - end if; - - L_Node := Next (Left, L_Node); - R_Node := Next (Right, R_Node); - end loop; - - return True; - end Generic_Equal; - - ----------------------- - -- Generic_Iteration -- - ----------------------- - - procedure Generic_Iteration (Tree : Tree_Type'Class) is - procedure Iterate (P : Count_Type); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (P : Count_Type) is - X : Count_Type := P; - begin - while X /= 0 loop - Iterate (Left (Tree.Nodes (X))); - Process (X); - X := Right (Tree.Nodes (X)); - end loop; - end Iterate; - - -- Start of processing for Generic_Iteration - - begin - Iterate (Tree.Root); - end Generic_Iteration; - - ------------------ - -- Generic_Read -- - ------------------ - - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - Tree : in out Tree_Type'Class) - is - Len : Count_Type'Base; - - Node, Last_Node : Count_Type; - - N : Nodes_Type renames Tree.Nodes; - - begin - Clear_Tree (Tree); - Count_Type'Base'Read (Stream, Len); - - if Checks and then Len < 0 then - raise Program_Error with "bad container length (corrupt stream)"; - end if; - - if Len = 0 then - return; - end if; - - if Checks and then Len > Tree.Capacity then - raise Constraint_Error with "length exceeds capacity"; - end if; - - -- Use Unconditional_Insert_With_Hint here instead ??? - - Allocate (Tree, Node); - pragma Assert (Node /= 0); - - Set_Color (N (Node), Black); - - Tree.Root := Node; - Tree.First := Node; - Tree.Last := Node; - Tree.Length := 1; - - for J in Count_Type range 2 .. Len loop - Last_Node := Node; - pragma Assert (Last_Node = Tree.Last); - - Allocate (Tree, Node); - pragma Assert (Node /= 0); - - Set_Color (N (Node), Red); - Set_Right (N (Last_Node), Right => Node); - Tree.Last := Node; - Set_Parent (N (Node), Parent => Last_Node); - - Rebalance_For_Insert (Tree, Node); - Tree.Length := Tree.Length + 1; - end loop; - end Generic_Read; - - ------------------------------- - -- Generic_Reverse_Iteration -- - ------------------------------- - - procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is - procedure Iterate (P : Count_Type); - - ------------- - -- Iterate -- - ------------- - - procedure Iterate (P : Count_Type) is - X : Count_Type := P; - begin - while X /= 0 loop - Iterate (Right (Tree.Nodes (X))); - Process (X); - X := Left (Tree.Nodes (X)); - end loop; - end Iterate; - - -- Start of processing for Generic_Reverse_Iteration - - begin - Iterate (Tree.Root); - end Generic_Reverse_Iteration; - - ------------------- - -- Generic_Write -- - ------------------- - - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - Tree : Tree_Type'Class) - is - procedure Process (Node : Count_Type); - pragma Inline (Process); - - procedure Iterate is new Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Count_Type) is - begin - Write_Node (Stream, Tree.Nodes (Node)); - end Process; - - -- Start of processing for Generic_Write - - begin - Count_Type'Base'Write (Stream, Tree.Length); - Iterate (Tree); - end Generic_Write; - - ----------------- - -- Left_Rotate -- - ----------------- - - procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is - - -- CLR p. 266 - - N : Nodes_Type renames Tree.Nodes; - - Y : constant Count_Type := Right (N (X)); - pragma Assert (Y /= 0); - - begin - Set_Right (N (X), Left (N (Y))); - - if Left (N (Y)) /= 0 then - Set_Parent (N (Left (N (Y))), X); - end if; - - Set_Parent (N (Y), Parent (N (X))); - - if X = Tree.Root then - Tree.Root := Y; - elsif X = Left (N (Parent (N (X)))) then - Set_Left (N (Parent (N (X))), Y); - else - pragma Assert (X = Right (N (Parent (N (X))))); - Set_Right (N (Parent (N (X))), Y); - end if; - - Set_Left (N (Y), X); - Set_Parent (N (X), Y); - end Left_Rotate; - - --------- - -- Max -- - --------- - - function Max - (Tree : Tree_Type'Class; - Node : Count_Type) return Count_Type - is - -- CLR p. 248 - - X : Count_Type := Node; - Y : Count_Type; - - begin - loop - Y := Right (Tree.Nodes (X)); - - if Y = 0 then - return X; - end if; - - X := Y; - end loop; - end Max; - - --------- - -- Min -- - --------- - - function Min - (Tree : Tree_Type'Class; - Node : Count_Type) return Count_Type - is - -- CLR p. 248 - - X : Count_Type := Node; - Y : Count_Type; - - begin - loop - Y := Left (Tree.Nodes (X)); - - if Y = 0 then - return X; - end if; - - X := Y; - end loop; - end Min; - - ---------- - -- Next -- - ---------- - - function Next - (Tree : Tree_Type'Class; - Node : Count_Type) return Count_Type - is - begin - -- CLR p. 249 - - if Node = 0 then - return 0; - end if; - - if Right (Tree.Nodes (Node)) /= 0 then - return Min (Tree, Right (Tree.Nodes (Node))); - end if; - - declare - X : Count_Type := Node; - Y : Count_Type := Parent (Tree.Nodes (Node)); - - begin - while Y /= 0 and then X = Right (Tree.Nodes (Y)) loop - X := Y; - Y := Parent (Tree.Nodes (Y)); - end loop; - - return Y; - end; - end Next; - - -------------- - -- Previous -- - -------------- - - function Previous - (Tree : Tree_Type'Class; - Node : Count_Type) return Count_Type - is - begin - if Node = 0 then - return 0; - end if; - - if Left (Tree.Nodes (Node)) /= 0 then - return Max (Tree, Left (Tree.Nodes (Node))); - end if; - - declare - X : Count_Type := Node; - Y : Count_Type := Parent (Tree.Nodes (Node)); - - begin - while Y /= 0 and then X = Left (Tree.Nodes (Y)) loop - X := Y; - Y := Parent (Tree.Nodes (Y)); - end loop; - - return Y; - end; - end Previous; - - -------------------------- - -- Rebalance_For_Insert -- - -------------------------- - - procedure Rebalance_For_Insert - (Tree : in out Tree_Type'Class; - Node : Count_Type) - is - -- CLR p. 268 - - N : Nodes_Type renames Tree.Nodes; - - X : Count_Type := Node; - pragma Assert (X /= 0); - pragma Assert (Color (N (X)) = Red); - - Y : Count_Type; - - begin - while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop - if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then - Y := Right (N (Parent (N (Parent (N (X)))))); - - if Y /= 0 and then Color (N (Y)) = Red then - Set_Color (N (Parent (N (X))), Black); - Set_Color (N (Y), Black); - Set_Color (N (Parent (N (Parent (N (X))))), Red); - X := Parent (N (Parent (N (X)))); - - else - if X = Right (N (Parent (N (X)))) then - X := Parent (N (X)); - Left_Rotate (Tree, X); - end if; - - Set_Color (N (Parent (N (X))), Black); - Set_Color (N (Parent (N (Parent (N (X))))), Red); - Right_Rotate (Tree, Parent (N (Parent (N (X))))); - end if; - - else - pragma Assert (Parent (N (X)) = - Right (N (Parent (N (Parent (N (X))))))); - - Y := Left (N (Parent (N (Parent (N (X)))))); - - if Y /= 0 and then Color (N (Y)) = Red then - Set_Color (N (Parent (N (X))), Black); - Set_Color (N (Y), Black); - Set_Color (N (Parent (N (Parent (N (X))))), Red); - X := Parent (N (Parent (N (X)))); - - else - if X = Left (N (Parent (N (X)))) then - X := Parent (N (X)); - Right_Rotate (Tree, X); - end if; - - Set_Color (N (Parent (N (X))), Black); - Set_Color (N (Parent (N (Parent (N (X))))), Red); - Left_Rotate (Tree, Parent (N (Parent (N (X))))); - end if; - end if; - end loop; - - Set_Color (N (Tree.Root), Black); - end Rebalance_For_Insert; - - ------------------ - -- Right_Rotate -- - ------------------ - - procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is - N : Nodes_Type renames Tree.Nodes; - - X : constant Count_Type := Left (N (Y)); - pragma Assert (X /= 0); - - begin - Set_Left (N (Y), Right (N (X))); - - if Right (N (X)) /= 0 then - Set_Parent (N (Right (N (X))), Y); - end if; - - Set_Parent (N (X), Parent (N (Y))); - - if Y = Tree.Root then - Tree.Root := X; - elsif Y = Left (N (Parent (N (Y)))) then - Set_Left (N (Parent (N (Y))), X); - else - pragma Assert (Y = Right (N (Parent (N (Y))))); - Set_Right (N (Parent (N (Y))), X); - end if; - - Set_Right (N (X), Y); - Set_Parent (N (Y), X); - end Right_Rotate; - - --------- - -- Vet -- - --------- - - function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is - Nodes : Nodes_Type renames Tree.Nodes; - Node : Node_Type renames Nodes (Index); - - begin - if Parent (Node) = Index - or else Left (Node) = Index - or else Right (Node) = Index - then - return False; - end if; - - if Tree.Length = 0 - or else Tree.Root = 0 - or else Tree.First = 0 - or else Tree.Last = 0 - then - return False; - end if; - - if Parent (Nodes (Tree.Root)) /= 0 then - return False; - end if; - - if Left (Nodes (Tree.First)) /= 0 then - return False; - end if; - - if Right (Nodes (Tree.Last)) /= 0 then - return False; - end if; - - if Tree.Length = 1 then - if Tree.First /= Tree.Last - or else Tree.First /= Tree.Root - then - return False; - end if; - - if Index /= Tree.First then - return False; - end if; - - if Parent (Node) /= 0 - or else Left (Node) /= 0 - or else Right (Node) /= 0 - then - return False; - end if; - - return True; - end if; - - if Tree.First = Tree.Last then - return False; - end if; - - if Tree.Length = 2 then - if Tree.First /= Tree.Root and then Tree.Last /= Tree.Root then - return False; - end if; - - if Tree.First /= Index and then Tree.Last /= Index then - return False; - end if; - end if; - - if Left (Node) /= 0 and then Parent (Nodes (Left (Node))) /= Index then - return False; - end if; - - if Right (Node) /= 0 and then Parent (Nodes (Right (Node))) /= Index then - return False; - end if; - - if Parent (Node) = 0 then - if Tree.Root /= Index then - return False; - end if; - - elsif Left (Nodes (Parent (Node))) /= Index - and then Right (Nodes (Parent (Node))) /= Index - then - return False; - end if; - - return True; - end Vet; - -end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; diff --git a/gcc/ada/a-rbtgbo.ads b/gcc/ada/a-rbtgbo.ads deleted file mode 100644 index 4045182..0000000 --- a/gcc/ada/a-rbtgbo.ads +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Tree_Type is used to implement the ordered containers. This package --- declares the tree operations that do not depend on keys. - -with Ada.Streams; use Ada.Streams; - -generic - with package Tree_Types is new Generic_Bounded_Tree_Types (<>); - use Tree_Types, Tree_Types.Implementation; - - with function Parent (Node : Node_Type) return Count_Type is <>; - - with procedure Set_Parent - (Node : in out Node_Type; - Parent : Count_Type) is <>; - - with function Left (Node : Node_Type) return Count_Type is <>; - - with procedure Set_Left - (Node : in out Node_Type; - Left : Count_Type) is <>; - - with function Right (Node : Node_Type) return Count_Type is <>; - - with procedure Set_Right - (Node : in out Node_Type; - Right : Count_Type) is <>; - - with function Color (Node : Node_Type) return Color_Type is <>; - - with procedure Set_Color - (Node : in out Node_Type; - Color : Color_Type) is <>; - -package Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is - pragma Annotate (CodePeer, Skip_Analysis); - pragma Pure; - - function Min (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; - -- Returns the smallest-valued node of the subtree rooted at Node - - function Max (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; - -- Returns the largest-valued node of the subtree rooted at Node - - function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean; - -- Inspects Node to determine (to the extent possible) whether - -- the node is valid; used to detect if the node is dangling. - - function Next - (Tree : Tree_Type'Class; - Node : Count_Type) return Count_Type; - -- Returns the smallest node greater than Node - - function Previous - (Tree : Tree_Type'Class; - Node : Count_Type) return Count_Type; - -- Returns the largest node less than Node - - generic - with function Is_Equal (L, R : Node_Type) return Boolean; - function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean; - -- Uses Is_Equal to perform a node-by-node comparison of the - -- Left and Right trees; processing stops as soon as the first - -- non-equal node is found. - - procedure Delete_Node_Sans_Free - (Tree : in out Tree_Type'Class; Node : Count_Type); - -- Removes Node from Tree without deallocating the node. If Tree - -- is busy then Program_Error is raised. - - procedure Clear_Tree (Tree : in out Tree_Type'Class); - -- Clears Tree by deallocating all of its nodes. If Tree is busy then - -- Program_Error is raised. - - generic - with procedure Process (Node : Count_Type) is <>; - procedure Generic_Iteration (Tree : Tree_Type'Class); - -- Calls Process for each node in Tree, in order from smallest-valued - -- node to largest-valued node. - - generic - with procedure Process (Node : Count_Type) is <>; - procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class); - -- Calls Process for each node in Tree, in order from largest-valued - -- node to smallest-valued node. - - generic - with procedure Write_Node - (Stream : not null access Root_Stream_Type'Class; - Node : Node_Type); - procedure Generic_Write - (Stream : not null access Root_Stream_Type'Class; - Tree : Tree_Type'Class); - -- Used to implement stream attribute T'Write. Generic_Write - -- first writes the number of nodes into Stream, then calls - -- Write_Node for each node in Tree. - - generic - with procedure Allocate - (Tree : in out Tree_Type'Class; - Node : out Count_Type); - procedure Generic_Read - (Stream : not null access Root_Stream_Type'Class; - Tree : in out Tree_Type'Class); - -- Used to implement stream attribute T'Read. Generic_Read - -- first clears Tree. It then reads the number of nodes out of - -- Stream, and calls Read_Node for each node in Stream. - - procedure Rebalance_For_Insert - (Tree : in out Tree_Type'Class; - Node : Count_Type); - -- This rebalances Tree to complete the insertion of Node (which - -- must already be linked in at its proper insertion position). - - generic - with procedure Set_Element (Node : in out Node_Type); - procedure Generic_Allocate - (Tree : in out Tree_Type'Class; - Node : out Count_Type); - -- Claim a node from the free store. Generic_Allocate first - -- calls Set_Element on the potential node, and then returns - -- the node's index as the value of the Node parameter. - - procedure Free (Tree : in out Tree_Type'Class; X : Count_Type); - -- Return a node back to the free store, from where it had - -- been previously claimed via Generic_Allocate. - -end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; diff --git a/gcc/ada/a-rbtgso.adb b/gcc/ada/a-rbtgso.adb deleted file mode 100644 index f6daa90..0000000 --- a/gcc/ada/a-rbtgso.adb +++ /dev/null @@ -1,739 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System; use type System.Address; - -package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is - - pragma Warnings (Off, "variable ""Busy*"" is not referenced"); - pragma Warnings (Off, "variable ""Lock*"" is not referenced"); - -- See comment in Ada.Containers.Helpers - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Clear (Tree : in out Tree_Type); - - function Copy (Source : Tree_Type) return Tree_Type; - - ----------- - -- Clear -- - ----------- - - procedure Clear (Tree : in out Tree_Type) is - use type Helpers.Tamper_Counts; - pragma Assert (Tree.TC = (Busy => 0, Lock => 0)); - - Root : Node_Access := Tree.Root; - pragma Warnings (Off, Root); - - begin - Tree.Root := null; - Tree.First := null; - Tree.Last := null; - Tree.Length := 0; - - Delete_Tree (Root); - end Clear; - - ---------- - -- Copy -- - ---------- - - function Copy (Source : Tree_Type) return Tree_Type is - Target : Tree_Type; - - begin - if Source.Length = 0 then - return Target; - end if; - - Target.Root := Copy_Tree (Source.Root); - Target.First := Tree_Operations.Min (Target.Root); - Target.Last := Tree_Operations.Max (Target.Root); - Target.Length := Source.Length; - - return Target; - end Copy; - - ---------------- - -- Difference -- - ---------------- - - procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is - Tgt : Node_Access; - Src : Node_Access; - - Compare : Integer; - - begin - if Target'Address = Source'Address then - TC_Check (Target.TC); - - Clear (Target); - return; - end if; - - if Source.Length = 0 then - return; - end if; - - TC_Check (Target.TC); - - Tgt := Target.First; - Src := Source.First; - loop - if Tgt = null then - exit; - end if; - - if Src = null then - exit; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Tgt, Src) then - Compare := -1; - elsif Is_Less (Src, Tgt) then - Compare := 1; - else - Compare := 0; - end if; - end; - - if Compare < 0 then - Tgt := Tree_Operations.Next (Tgt); - - elsif Compare > 0 then - Src := Tree_Operations.Next (Src); - - else - declare - X : Node_Access := Tgt; - begin - Tgt := Tree_Operations.Next (Tgt); - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Free (X); - end; - - Src := Tree_Operations.Next (Src); - end if; - end loop; - end Difference; - - function Difference (Left, Right : Tree_Type) return Tree_Type is - begin - if Left'Address = Right'Address then - return Tree_Type'(others => <>); -- Empty set - end if; - - if Left.Length = 0 then - return Tree_Type'(others => <>); -- Empty set - end if; - - if Right.Length = 0 then - return Copy (Left); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - Tree : Tree_Type; - - L_Node : Node_Access; - R_Node : Node_Access; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = null then - exit; - end if; - - if R_Node = null then - while L_Node /= null loop - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (L_Node); - end loop; - - exit; - end if; - - if Is_Less (L_Node, R_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (L_Node); - - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); - - else - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; - - return Tree; - - exception - when others => - Delete_Tree (Tree.Root); - raise; - end; - end Difference; - - ------------------ - -- Intersection -- - ------------------ - - procedure Intersection - (Target : in out Tree_Type; - Source : Tree_Type) - is - Tgt : Node_Access; - Src : Node_Access; - - Compare : Integer; - - begin - if Target'Address = Source'Address then - return; - end if; - - TC_Check (Target.TC); - - if Source.Length = 0 then - Clear (Target); - return; - end if; - - Tgt := Target.First; - Src := Source.First; - while Tgt /= null - and then Src /= null - loop - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Tgt, Src) then - Compare := -1; - elsif Is_Less (Src, Tgt) then - Compare := 1; - else - Compare := 0; - end if; - end; - - if Compare < 0 then - declare - X : Node_Access := Tgt; - begin - Tgt := Tree_Operations.Next (Tgt); - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Free (X); - end; - - elsif Compare > 0 then - Src := Tree_Operations.Next (Src); - - else - Tgt := Tree_Operations.Next (Tgt); - Src := Tree_Operations.Next (Src); - end if; - end loop; - - while Tgt /= null loop - declare - X : Node_Access := Tgt; - begin - Tgt := Tree_Operations.Next (Tgt); - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Free (X); - end; - end loop; - end Intersection; - - function Intersection (Left, Right : Tree_Type) return Tree_Type is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - Tree : Tree_Type; - - L_Node : Node_Access; - R_Node : Node_Access; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = null then - exit; - end if; - - if R_Node = null then - exit; - end if; - - if Is_Less (L_Node, R_Node) then - L_Node := Tree_Operations.Next (L_Node); - - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); - - else - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; - - return Tree; - - exception - when others => - Delete_Tree (Tree.Root); - raise; - end; - end Intersection; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset - (Subset : Tree_Type; - Of_Set : Tree_Type) return Boolean - is - begin - if Subset'Address = Of_Set'Address then - return True; - end if; - - if Subset.Length > Of_Set.Length then - return False; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); - Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); - - Subset_Node : Node_Access; - Set_Node : Node_Access; - - begin - Subset_Node := Subset.First; - Set_Node := Of_Set.First; - loop - if Set_Node = null then - return Subset_Node = null; - end if; - - if Subset_Node = null then - return True; - end if; - - if Is_Less (Subset_Node, Set_Node) then - return False; - end if; - - if Is_Less (Set_Node, Subset_Node) then - Set_Node := Tree_Operations.Next (Set_Node); - else - Set_Node := Tree_Operations.Next (Set_Node); - Subset_Node := Tree_Operations.Next (Subset_Node); - end if; - end loop; - end; - end Is_Subset; - - ------------- - -- Overlap -- - ------------- - - function Overlap (Left, Right : Tree_Type) return Boolean is - begin - if Left'Address = Right'Address then - return Left.Length /= 0; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - L_Node : Node_Access; - R_Node : Node_Access; - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = null - or else R_Node = null - then - return False; - end if; - - if Is_Less (L_Node, R_Node) then - L_Node := Tree_Operations.Next (L_Node); - - elsif Is_Less (R_Node, L_Node) then - R_Node := Tree_Operations.Next (R_Node); - - else - return True; - end if; - end loop; - end; - end Overlap; - - -------------------------- - -- Symmetric_Difference -- - -------------------------- - - procedure Symmetric_Difference - (Target : in out Tree_Type; - Source : Tree_Type) - is - Tgt : Node_Access; - Src : Node_Access; - - New_Tgt_Node : Node_Access; - pragma Warnings (Off, New_Tgt_Node); - - Compare : Integer; - - begin - if Target'Address = Source'Address then - Clear (Target); - return; - end if; - - Tgt := Target.First; - Src := Source.First; - loop - if Tgt = null then - while Src /= null loop - Insert_With_Hint - (Dst_Tree => Target, - Dst_Hint => null, - Src_Node => Src, - Dst_Node => New_Tgt_Node); - - Src := Tree_Operations.Next (Src); - end loop; - - return; - end if; - - if Src = null then - return; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Target : With_Lock (Target.TC'Unrestricted_Access); - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - if Is_Less (Tgt, Src) then - Compare := -1; - elsif Is_Less (Src, Tgt) then - Compare := 1; - else - Compare := 0; - end if; - end; - - if Compare < 0 then - Tgt := Tree_Operations.Next (Tgt); - - elsif Compare > 0 then - Insert_With_Hint - (Dst_Tree => Target, - Dst_Hint => Tgt, - Src_Node => Src, - Dst_Node => New_Tgt_Node); - - Src := Tree_Operations.Next (Src); - - else - declare - X : Node_Access := Tgt; - begin - Tgt := Tree_Operations.Next (Tgt); - Tree_Operations.Delete_Node_Sans_Free (Target, X); - Free (X); - end; - - Src := Tree_Operations.Next (Src); - end if; - end loop; - end Symmetric_Difference; - - function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is - begin - if Left'Address = Right'Address then - return Tree_Type'(others => <>); -- Empty set - end if; - - if Right.Length = 0 then - return Copy (Left); - end if; - - if Left.Length = 0 then - return Copy (Right); - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - Tree : Tree_Type; - - L_Node : Node_Access; - R_Node : Node_Access; - - Dst_Node : Node_Access; - pragma Warnings (Off, Dst_Node); - - begin - L_Node := Left.First; - R_Node := Right.First; - loop - if L_Node = null then - while R_Node /= null loop - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => R_Node, - Dst_Node => Dst_Node); - R_Node := Tree_Operations.Next (R_Node); - end loop; - - exit; - end if; - - if R_Node = null then - while L_Node /= null loop - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (L_Node); - end loop; - - exit; - end if; - - if Is_Less (L_Node, R_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => L_Node, - Dst_Node => Dst_Node); - - L_Node := Tree_Operations.Next (L_Node); - - elsif Is_Less (R_Node, L_Node) then - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => null, - Src_Node => R_Node, - Dst_Node => Dst_Node); - - R_Node := Tree_Operations.Next (R_Node); - - else - L_Node := Tree_Operations.Next (L_Node); - R_Node := Tree_Operations.Next (R_Node); - end if; - end loop; - - return Tree; - - exception - when others => - Delete_Tree (Tree.Root); - raise; - end; - end Symmetric_Difference; - - ----------- - -- Union -- - ----------- - - procedure Union (Target : in out Tree_Type; Source : Tree_Type) is - Hint : Node_Access; - - procedure Process (Node : Node_Access); - pragma Inline (Process); - - procedure Iterate is new Tree_Operations.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Node_Access) is - begin - Insert_With_Hint - (Dst_Tree => Target, - Dst_Hint => Hint, -- use node most recently inserted as hint - Src_Node => Node, - Dst_Node => Hint); - end Process; - - -- Start of processing for Union - - begin - if Target'Address = Source'Address then - return; - end if; - - -- Per AI05-0022, the container implementation is required to detect - -- element tampering by a generic actual subprogram. - - declare - Lock_Source : With_Lock (Source.TC'Unrestricted_Access); - begin - Iterate (Source); - end; - end Union; - - function Union (Left, Right : Tree_Type) return Tree_Type is - begin - if Left'Address = Right'Address then - return Copy (Left); - end if; - - if Left.Length = 0 then - return Copy (Right); - end if; - - if Right.Length = 0 then - return Copy (Left); - end if; - - declare - Lock_Left : With_Lock (Left.TC'Unrestricted_Access); - Lock_Right : With_Lock (Right.TC'Unrestricted_Access); - - Tree : Tree_Type := Copy (Left); - - Hint : Node_Access; - - procedure Process (Node : Node_Access); - pragma Inline (Process); - - procedure Iterate is - new Tree_Operations.Generic_Iteration (Process); - - ------------- - -- Process -- - ------------- - - procedure Process (Node : Node_Access) is - begin - Insert_With_Hint - (Dst_Tree => Tree, - Dst_Hint => Hint, -- use node most recently inserted as hint - Src_Node => Node, - Dst_Node => Hint); - end Process; - - -- Start of processing for Union - - begin - Iterate (Right); - return Tree; - - exception - when others => - Delete_Tree (Tree.Root); - raise; - end; - end Union; - -end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/a-rbtgso.ads b/gcc/ada/a-rbtgso.ads deleted file mode 100644 index 9ad296f..0000000 --- a/gcc/ada/a-rbtgso.ads +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - --- Tree_Type is used to implement ordered containers. This package declares --- set-based tree operations. - -with Ada.Containers.Red_Black_Trees.Generic_Operations; - -generic - with package Tree_Operations is new Generic_Operations (<>); - - use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; - - with procedure Insert_With_Hint - (Dst_Tree : in out Tree_Type; - Dst_Hint : Node_Access; - Src_Node : Node_Access; - Dst_Node : out Node_Access); - - with function Copy_Tree (Source_Root : Node_Access) - return Node_Access; - - with procedure Delete_Tree (X : in out Node_Access); - - with function Is_Less (Left, Right : Node_Access) return Boolean; - - with procedure Free (X : in out Node_Access); - -package Ada.Containers.Red_Black_Trees.Generic_Set_Operations is - pragma Pure; - - procedure Union (Target : in out Tree_Type; Source : Tree_Type); - -- Attempts to insert each element of Source in Target. If Target is - -- busy then Program_Error is raised. We say "attempts" here because - -- if these are unique-element sets, then the insertion should fail - -- (not insert a new item) when the insertion item from Source is - -- equivalent to an item already in Target. If these are multisets - -- then of course the attempt should always succeed. - - function Union (Left, Right : Tree_Type) return Tree_Type; - -- Makes a copy of Left, and attempts to insert each element of - -- Right into the copy, then returns the copy. - - procedure Intersection (Target : in out Tree_Type; Source : Tree_Type); - -- Removes elements from Target that are not equivalent to items in - -- Source. If Target is busy then Program_Error is raised. - - function Intersection (Left, Right : Tree_Type) return Tree_Type; - -- Returns a set comprising all the items in Left equivalent to items in - -- Right. - - procedure Difference (Target : in out Tree_Type; Source : Tree_Type); - -- Removes elements from Target that are equivalent to items in Source. If - -- Target is busy then Program_Error is raised. - - function Difference (Left, Right : Tree_Type) return Tree_Type; - -- Returns a set comprising all the items in Left not equivalent to items - -- in Right. - - procedure Symmetric_Difference - (Target : in out Tree_Type; - Source : Tree_Type); - -- Removes from Target elements that are equivalent to items in Source, and - -- inserts into Target items from Source not equivalent elements in - -- Target. If Target is busy then Program_Error is raised. - - function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type; - -- Returns a set comprising the union of the elements in Left not - -- equivalent to items in Right, and the elements in Right not equivalent - -- to items in Left. - - function Is_Subset (Subset : Tree_Type; Of_Set : Tree_Type) return Boolean; - -- Returns False if Subset contains at least one element not equivalent to - -- any item in Of_Set; returns True otherwise. - - function Overlap (Left, Right : Tree_Type) return Boolean; - -- Returns True if at least one element of Left is equivalent to an item in - -- Right; returns False otherwise. - -end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/a-sbecin.adb b/gcc/ada/a-sbecin.adb deleted file mode 100644 index 7800017..0000000 --- a/gcc/ada/a-sbecin.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Equal_Case_Insensitive; - -function Ada.Strings.Bounded.Equal_Case_Insensitive - (Left, Right : Bounded.Bounded_String) - return Boolean -is -begin - return Ada.Strings.Equal_Case_Insensitive - (Left => Bounded.To_String (Left), - Right => Bounded.To_String (Right)); -end Ada.Strings.Bounded.Equal_Case_Insensitive; diff --git a/gcc/ada/a-sbecin.ads b/gcc/ada/a-sbecin.ads deleted file mode 100644 index 115c722..0000000 --- a/gcc/ada/a-sbecin.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -generic - with package Bounded is - new Ada.Strings.Bounded.Generic_Bounded_Length (<>); - -function Ada.Strings.Bounded.Equal_Case_Insensitive - (Left, Right : Bounded.Bounded_String) - return Boolean; - -pragma Preelaborate (Ada.Strings.Bounded.Equal_Case_Insensitive); diff --git a/gcc/ada/a-sbhcin.adb b/gcc/ada/a-sbhcin.adb deleted file mode 100644 index 8c69290..0000000 --- a/gcc/ada/a-sbhcin.adb +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Hash_Case_Insensitive; - -function Ada.Strings.Bounded.Hash_Case_Insensitive - (Key : Bounded.Bounded_String) - return Containers.Hash_Type -is -begin - return Ada.Strings.Hash_Case_Insensitive (Bounded.To_String (Key)); -end Ada.Strings.Bounded.Hash_Case_Insensitive; diff --git a/gcc/ada/a-sbhcin.ads b/gcc/ada/a-sbhcin.ads deleted file mode 100644 index c291f53..0000000 --- a/gcc/ada/a-sbhcin.ads +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -generic - with package Bounded is - new Ada.Strings.Bounded.Generic_Bounded_Length (<>); - -function Ada.Strings.Bounded.Hash_Case_Insensitive - (Key : Bounded.Bounded_String) - return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Bounded.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sblcin.adb b/gcc/ada/a-sblcin.adb deleted file mode 100644 index e2ce4d3..0000000 --- a/gcc/ada/a-sblcin.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Less_Case_Insensitive; - -function Ada.Strings.Bounded.Less_Case_Insensitive - (Left, Right : Bounded.Bounded_String) - return Boolean -is -begin - return Ada.Strings.Less_Case_Insensitive - (Left => Bounded.To_String (Left), - Right => Bounded.To_String (Right)); -end Ada.Strings.Bounded.Less_Case_Insensitive; diff --git a/gcc/ada/a-sblcin.ads b/gcc/ada/a-sblcin.ads deleted file mode 100644 index d728411..0000000 --- a/gcc/ada/a-sblcin.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -generic - with package Bounded is - new Ada.Strings.Bounded.Generic_Bounded_Length (<>); - -function Ada.Strings.Bounded.Less_Case_Insensitive - (Left, Right : Bounded.Bounded_String) - return Boolean; - -pragma Preelaborate (Ada.Strings.Bounded.Less_Case_Insensitive); diff --git a/gcc/ada/a-scteio.ads b/gcc/ada/a-scteio.ads deleted file mode 100644 index d9ceb2f..0000000 --- a/gcc/ada/a-scteio.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ C O M P L E X _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Ada 2005 AI-328 - -with Ada.Text_IO.Complex_IO; -with Ada.Numerics.Short_Complex_Types; - -pragma Elaborate_All (Ada.Text_IO.Complex_IO); - -package Ada.Short_Complex_Text_IO is - new Ada.Text_IO.Complex_IO (Ada.Numerics.Short_Complex_Types); diff --git a/gcc/ada/a-secain.adb b/gcc/ada/a-secain.adb deleted file mode 100644 index e77198e..0000000 --- a/gcc/ada/a-secain.adb +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . E Q U A L _ C A S E _ I N S E N S I T I V E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -function Ada.Strings.Equal_Case_Insensitive - (Left, Right : String) return Boolean -is - LI : Integer := Left'First; - RI : Integer := Right'First; - -begin - if Left'Length /= Right'Length then - return False; - end if; - - if Left'Length = 0 then - return True; - end if; - - loop - if To_Lower (Left (LI)) /= To_Lower (Right (RI)) then - return False; - end if; - - if LI = Left'Last then - return True; - end if; - - LI := LI + 1; - RI := RI + 1; - end loop; -end Ada.Strings.Equal_Case_Insensitive; diff --git a/gcc/ada/a-secain.ads b/gcc/ada/a-secain.ads deleted file mode 100644 index c5e747b..0000000 --- a/gcc/ada/a-secain.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . E Q U A L _ C A S E _ I N S E N S I T I V E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -function Ada.Strings.Equal_Case_Insensitive - (Left, Right : String) return Boolean; -pragma Pure (Ada.Strings.Equal_Case_Insensitive); --- Performs a case-insensitive equality test of Left and Right. This is --- useful as the generic actual equivalence operation (Equivalent_Keys) --- when instantiating a hashed container package with type String as the --- key. It is also useful as the generic actual equality operator when --- instantiating a container package with type String as the element, --- allowing case-insensitive container equality tests. diff --git a/gcc/ada/a-sequio.adb b/gcc/ada/a-sequio.adb deleted file mode 100644 index f180fd6..0000000 --- a/gcc/ada/a-sequio.adb +++ /dev/null @@ -1,314 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S E Q U E N T I A L _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the generic template for Sequential_IO, i.e. the code that gets --- duplicated. We absolutely minimize this code by either calling routines --- in System.File_IO (for common file functions), or in System.Sequential_IO --- (for specialized Sequential_IO functions) - -with Ada.Unchecked_Conversion; - -with System; -with System.Byte_Swapping; -with System.CRTL; -with System.File_Control_Block; -with System.File_IO; -with System.Storage_Elements; - -with Interfaces.C_Streams; use Interfaces.C_Streams; - -package body Ada.Sequential_IO is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - package SIO renames System.Sequential_IO; - package SSE renames System.Storage_Elements; - - SU : constant := System.Storage_Unit; - - subtype AP is FCB.AFCB_Ptr; - subtype FP is SIO.File_Type; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); - - use type System.Bit_Order; - use type System.CRTL.size_t; - - procedure Byte_Swap (Siz : in out size_t); - -- Byte swap Siz - - --------------- - -- Byte_Swap -- - --------------- - - procedure Byte_Swap (Siz : in out size_t) is - use System.Byte_Swapping; - begin - case Siz'Size is - when 32 => Siz := size_t (Bswap_32 (U32 (Siz))); - when 64 => Siz := size_t (Bswap_64 (U64 (Siz))); - when others => raise Program_Error; - end case; - end Byte_Swap; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out File_Type) is - begin - FIO.Close (AP (File)'Unrestricted_Access); - end Close; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := "") - is - begin - SIO.Create (FP (File), To_FCB (Mode), Name, Form); - end Create; - - ------------ - -- Delete -- - ------------ - - procedure Delete (File : in out File_Type) is - begin - FIO.Delete (AP (File)'Unrestricted_Access); - end Delete; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : File_Type) return Boolean is - begin - return FIO.End_Of_File (AP (File)); - end End_Of_File; - - ----------- - -- Flush -- - ----------- - - procedure Flush (File : File_Type) is - begin - FIO.Flush (AP (File)); - end Flush; - - ---------- - -- Form -- - ---------- - - function Form (File : File_Type) return String is - begin - return FIO.Form (AP (File)); - end Form; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (File : File_Type) return Boolean is - begin - return FIO.Is_Open (AP (File)); - end Is_Open; - - ---------- - -- Mode -- - ---------- - - function Mode (File : File_Type) return File_Mode is - begin - return To_SIO (FIO.Mode (AP (File))); - end Mode; - - ---------- - -- Name -- - ---------- - - function Name (File : File_Type) return String is - begin - return FIO.Name (AP (File)); - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := "") - is - begin - SIO.Open (FP (File), To_FCB (Mode), Name, Form); - end Open; - - ---------- - -- Read -- - ---------- - - procedure Read (File : File_Type; Item : out Element_Type) is - Siz : constant size_t := (Item'Size + SU - 1) / SU; - Rsiz : size_t; - - begin - FIO.Check_Read_Status (AP (File)); - - -- For non-definite type or type with discriminants, read size and - -- raise Program_Error if it is larger than the size of the item. - - if not Element_Type'Definite - or else Element_Type'Has_Discriminants - then - FIO.Read_Buf - (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit); - - -- If item read has non-default scalar storage order, then the size - -- will have been written with that same order, so byte swap it. - - if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then - Byte_Swap (Rsiz); - end if; - - -- For a type with discriminants, we have to read into a temporary - -- buffer if Item is constrained, to check that the discriminants - -- are correct. - - if Element_Type'Has_Discriminants and then Item'Constrained then - declare - RsizS : constant SSE.Storage_Offset := - SSE.Storage_Offset (Rsiz - 1); - - type SA is new SSE.Storage_Array (0 .. RsizS); - - for SA'Alignment use Standard'Maximum_Alignment; - -- We will perform an unchecked conversion of a pointer-to-SA - -- into pointer-to-Element_Type. We need to ensure that the - -- source is always at least as strictly aligned as the target. - - type SAP is access all SA; - type ItemP is access all Element_Type; - - pragma Warnings (Off); - -- We have to turn warnings off for function To_ItemP, - -- because it gets analyzed for all types, including ones - -- which can't possibly come this way, and for which the - -- size of the access types differs. - - function To_ItemP is new Ada.Unchecked_Conversion (SAP, ItemP); - - pragma Warnings (On); - - Buffer : aliased SA; - - pragma Unsuppress (Discriminant_Check); - - begin - FIO.Read_Buf (AP (File), Buffer'Address, Rsiz); - Item := To_ItemP (Buffer'Access).all; - return; - end; - end if; - - -- In the case of a non-definite type, make sure the length is OK. - -- We can't do this in the variant record case, because the size is - -- based on the current discriminant, so may be apparently wrong. - - if not Element_Type'Has_Discriminants and then Rsiz > Siz then - raise Program_Error; - end if; - - FIO.Read_Buf (AP (File), Item'Address, Rsiz); - - -- For definite type without discriminants, use actual size of item - - else - FIO.Read_Buf (AP (File), Item'Address, Siz); - end if; - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset (File : in out File_Type; Mode : File_Mode) is - begin - FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); - end Reset; - - procedure Reset (File : in out File_Type) is - begin - FIO.Reset (AP (File)'Unrestricted_Access); - end Reset; - - ----------- - -- Write -- - ----------- - - procedure Write (File : File_Type; Item : Element_Type) is - Siz : constant size_t := (Item'Size + SU - 1) / SU; - -- Size to be written, in native representation - - Swapped_Siz : size_t := Siz; - -- Same, possibly byte swapped to account for Element_Type endianness - - begin - FIO.Check_Write_Status (AP (File)); - - -- For non-definite types or types with discriminants, write the size - - if not Element_Type'Definite - or else Element_Type'Has_Discriminants - then - -- If item written has non-default scalar storage order, then the - -- size is written with that same order, so byte swap it. - - if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then - Byte_Swap (Swapped_Siz); - end if; - - FIO.Write_Buf - (AP (File), Swapped_Siz'Address, size_t'Size / System.Storage_Unit); - end if; - - FIO.Write_Buf (AP (File), Item'Address, Siz); - end Write; - -end Ada.Sequential_IO; diff --git a/gcc/ada/a-sequio.ads b/gcc/ada/a-sequio.ads deleted file mode 100644 index 8dbfb0f..0000000 --- a/gcc/ada/a-sequio.ads +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S E Q U E N T I A L _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; - -with System.Sequential_IO; - -generic - type Element_Type (<>) is private; - -package Ada.Sequential_IO is - - pragma Compile_Time_Warning - (Element_Type'Has_Access_Values, - "Element_Type for Sequential_IO instance has access values"); - - pragma Compile_Time_Warning - (Element_Type'Has_Tagged_Values, - "Element_Type for Sequential_IO instance has tagged values"); - - type File_Type is limited private; - - type File_Mode is (In_File, Out_File, Append_File); - - -- The following representation clause allows the use of unchecked - -- conversion for rapid translation between the File_Mode type - -- used in this package and System.File_IO. - - for File_Mode use - (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) - Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) - Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) - - --------------------- - -- File management -- - --------------------- - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := ""); - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - procedure Reset (File : in out File_Type; Mode : File_Mode); - procedure Reset (File : in out File_Type); - - function Mode (File : File_Type) return File_Mode; - function Name (File : File_Type) return String; - function Form (File : File_Type) return String; - - function Is_Open (File : File_Type) return Boolean; - - procedure Flush (File : File_Type); - - --------------------------------- - -- Input and output operations -- - --------------------------------- - - procedure Read (File : File_Type; Item : out Element_Type); - procedure Write (File : File_Type; Item : Element_Type); - - function End_Of_File (File : File_Type) return Boolean; - - ---------------- - -- Exceptions -- - ---------------- - - Status_Error : exception renames IO_Exceptions.Status_Error; - Mode_Error : exception renames IO_Exceptions.Mode_Error; - Name_Error : exception renames IO_Exceptions.Name_Error; - Use_Error : exception renames IO_Exceptions.Use_Error; - Device_Error : exception renames IO_Exceptions.Device_Error; - End_Error : exception renames IO_Exceptions.End_Error; - Data_Error : exception renames IO_Exceptions.Data_Error; - -private - - -- The following procedures have a File_Type formal of mode IN OUT because - -- they may close the original file. The Close operation may raise an - -- exception, but in that case we want any assignment to the formal to - -- be effective anyway, so it must be passed by reference (or the caller - -- will be left with a dangling pointer). - - pragma Export_Procedure - (Internal => Close, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Delete, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type), - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type, File_Mode), - Mechanism => (File => Reference)); - - type File_Type is new System.Sequential_IO.File_Type; - - -- All subprograms are inlined - - pragma Inline (Close); - pragma Inline (Create); - pragma Inline (Delete); - pragma Inline (End_Of_File); - pragma Inline (Form); - pragma Inline (Is_Open); - pragma Inline (Mode); - pragma Inline (Name); - pragma Inline (Open); - pragma Inline (Read); - pragma Inline (Reset); - pragma Inline (Write); - -end Ada.Sequential_IO; diff --git a/gcc/ada/a-sfecin.ads b/gcc/ada/a-sfecin.ads deleted file mode 100644 index 592b691..0000000 --- a/gcc/ada/a-sfecin.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.FIXED.EQUAL_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Equal_Case_Insensitive; - -function Ada.Strings.Fixed.Equal_Case_Insensitive - (Left, Right : String) - return Boolean renames Ada.Strings.Equal_Case_Insensitive; - -pragma Pure (Ada.Strings.Fixed.Equal_Case_Insensitive); diff --git a/gcc/ada/a-sfhcin.ads b/gcc/ada/a-sfhcin.ads deleted file mode 100644 index 86f60f6..0000000 --- a/gcc/ada/a-sfhcin.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.FIXED.HASH_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers; -with Ada.Strings.Hash_Case_Insensitive; - -function Ada.Strings.Fixed.Hash_Case_Insensitive - (Key : String) - return Containers.Hash_Type renames Ada.Strings.Hash_Case_Insensitive; - -pragma Pure (Ada.Strings.Fixed.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sflcin.ads b/gcc/ada/a-sflcin.ads deleted file mode 100644 index 8af21fe..0000000 --- a/gcc/ada/a-sflcin.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.FIXED.LESS_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Less_Case_Insensitive; - -function Ada.Strings.Fixed.Less_Case_Insensitive - (Left, Right : String) - return Boolean renames Ada.Strings.Less_Case_Insensitive; - -pragma Pure (Ada.Strings.Fixed.Less_Case_Insensitive); diff --git a/gcc/ada/a-sfteio.ads b/gcc/ada/a-sfteio.ads deleted file mode 100644 index a1f18cd..0000000 --- a/gcc/ada/a-sfteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ F L O A T _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Short_Float_Text_IO is - new Ada.Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-sfwtio.ads b/gcc/ada/a-sfwtio.ads deleted file mode 100644 index 3ac134e..0000000 --- a/gcc/ada/a-sfwtio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ F L O A T _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Short_Float_Wide_Text_IO is - new Ada.Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-sfztio.ads b/gcc/ada/a-sfztio.ads deleted file mode 100644 index bc34e5d..0000000 --- a/gcc/ada/a-sfztio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Short_Float_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/a-shcain.adb b/gcc/ada/a-shcain.adb deleted file mode 100644 index 8c7ccbe..0000000 --- a/gcc/ada/a-shcain.adb +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; use Ada.Characters.Handling; -with System.String_Hash; - -function Ada.Strings.Hash_Case_Insensitive - (Key : String) return Containers.Hash_Type -is - use Ada.Containers; - function Hash is new System.String_Hash.Hash - (Character, String, Hash_Type); -begin - return Hash (To_Lower (Key)); -end Ada.Strings.Hash_Case_Insensitive; diff --git a/gcc/ada/a-shcain.ads b/gcc/ada/a-shcain.ads deleted file mode 100644 index fa3123c..0000000 --- a/gcc/ada/a-shcain.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -function Ada.Strings.Hash_Case_Insensitive - (Key : String) return Containers.Hash_Type; -pragma Pure (Ada.Strings.Hash_Case_Insensitive); --- Computes a hash value for Key without regard for character case. This is --- useful as the generic actual Hash function when instantiating a hashed --- container package with type String as the key. diff --git a/gcc/ada/a-siocst.adb b/gcc/ada/a-siocst.adb deleted file mode 100644 index cfffa30..0000000 --- a/gcc/ada/a-siocst.adb +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; -with System.Sequential_IO; -with Ada.Unchecked_Conversion; - -package body Ada.Sequential_IO.C_Streams is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - package SIO renames System.Sequential_IO; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - - -------------- - -- C_Stream -- - -------------- - - function C_Stream (F : File_Type) return FILEs is - begin - FIO.Check_File_Open (AP (F)); - return F.Stream; - end C_Stream; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : FILEs; - Form : String := ""; - Name : String := "") - is - Dummy_File_Control_Block : SIO.Sequential_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'Q', - Creat => False, - Text => False, - C_Stream => C_Stream); - end Open; - -end Ada.Sequential_IO.C_Streams; diff --git a/gcc/ada/a-siocst.ads b/gcc/ada/a-siocst.ads deleted file mode 100644 index 85063b4..0000000 --- a/gcc/ada/a-siocst.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface between Ada.Sequential_IO and the --- C streams. This allows sharing of a stream between Ada and C or C++, --- as well as allowing the Ada program to operate directly on the stream. - -with Interfaces.C_Streams; - -generic -package Ada.Sequential_IO.C_Streams is - - package ICS renames Interfaces.C_Streams; - - function C_Stream (F : File_Type) return ICS.FILEs; - -- Obtain stream from existing open file - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : ICS.FILEs; - Form : String := ""; - Name : String := ""); - -- Create new file from existing stream - -end Ada.Sequential_IO.C_Streams; diff --git a/gcc/ada/a-siteio.ads b/gcc/ada/a-siteio.ads deleted file mode 100644 index de45c22..0000000 --- a/gcc/ada/a-siteio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ I N T E G E R _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Short_Integer_Text_IO is - new Ada.Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-siwtio.ads b/gcc/ada/a-siwtio.ads deleted file mode 100644 index aa1a2d4..0000000 --- a/gcc/ada/a-siwtio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Short_Integer_Wide_Text_IO is - new Ada.Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-siztio.ads b/gcc/ada/a-siztio.ads deleted file mode 100644 index 3d6f5cd..0000000 --- a/gcc/ada/a-siztio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Short_Integer_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/a-slcain.adb b/gcc/ada/a-slcain.adb deleted file mode 100644 index 5e3fd6b..0000000 --- a/gcc/ada/a-slcain.adb +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.LESS_CASE_INSENSITIVE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; use Ada.Characters.Handling; - -function Ada.Strings.Less_Case_Insensitive - (Left, Right : String) return Boolean -is - LI : Integer := Left'First; - RI : Integer := Right'First; - - LC, RC : Character; - -begin - if LI > Left'Last then - return RI <= Right'Last; - end if; - - if RI > Right'Last then - return False; - end if; - - loop - LC := To_Lower (Left (LI)); - RC := To_Lower (Right (RI)); - - if LC < RC then - return True; - end if; - - if LC > RC then - return False; - end if; - - if LI = Left'Last then - return RI < Right'Last; - end if; - - if RI = Right'Last then - return False; - end if; - - LI := LI + 1; - RI := RI + 1; - end loop; -end Ada.Strings.Less_Case_Insensitive; diff --git a/gcc/ada/a-slcain.ads b/gcc/ada/a-slcain.ads deleted file mode 100644 index 1327c30..0000000 --- a/gcc/ada/a-slcain.ads +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.LESS_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -function Ada.Strings.Less_Case_Insensitive - (Left, Right : String) return Boolean; -pragma Pure (Ada.Strings.Less_Case_Insensitive); --- Performs a case-insensitive lexicographic comparison of Left and --- Right. This is useful as the generic actual less-than operator when --- instantiating an ordered container package with type String as the key, --- allowing case-insensitive equivalence tests. diff --git a/gcc/ada/a-ssicst.adb b/gcc/ada/a-ssicst.adb deleted file mode 100644 index 1e5b394..0000000 --- a/gcc/ada/a-ssicst.adb +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; -with Ada.Unchecked_Conversion; - -package body Ada.Streams.Stream_IO.C_Streams is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - - -------------- - -- C_Stream -- - -------------- - - function C_Stream (F : File_Type) return FILEs is - begin - FIO.Check_File_Open (AP (F)); - return F.Stream; - end C_Stream; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : FILEs; - Form : String := ""; - Name : String := "") - is - Dummy_File_Control_Block : Stream_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'S', - Creat => False, - Text => False, - C_Stream => C_Stream); - - File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read); - -- See comment in Ada.Streams.Stream_IO.Open for the reason - end Open; - -end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/a-ssicst.ads b/gcc/ada/a-ssicst.ads deleted file mode 100644 index 733f54e..0000000 --- a/gcc/ada/a-ssicst.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface between Ada.Stream_IO and the --- C streams. This allows sharing of a stream between Ada and C or C++, --- as well as allowing the Ada program to operate directly on the stream. - -with Interfaces.C_Streams; - -package Ada.Streams.Stream_IO.C_Streams is - - package ICS renames Interfaces.C_Streams; - - function C_Stream (F : File_Type) return ICS.FILEs; - -- Obtain stream from existing open file - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : ICS.FILEs; - Form : String := ""; - Name : String := ""); - -- Create new file from existing stream - -end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/a-ssitio.ads b/gcc/ada/a-ssitio.ads deleted file mode 100644 index 98b0540..0000000 --- a/gcc/ada/a-ssitio.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ S H O R T _ I N T E G E R _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -package Ada.Short_Short_Integer_Text_IO is - new Ada.Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-ssiwti.ads b/gcc/ada/a-ssiwti.ads deleted file mode 100644 index 5f6934b..0000000 --- a/gcc/ada/a-ssiwti.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; - -package Ada.Short_Short_Integer_Wide_Text_IO is - new Ada.Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-ssizti.ads b/gcc/ada/a-ssizti.ads deleted file mode 100644 index 13bfda8..0000000 --- a/gcc/ada/a-ssizti.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; - -package Ada.Short_Short_Integer_Wide_Wide_Text_IO is - new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/a-stboha.adb b/gcc/ada/a-stboha.adb deleted file mode 100644 index 97ae526..0000000 --- a/gcc/ada/a-stboha.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . B O U N D E D . H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String) - return Containers.Hash_Type -is - use Ada.Containers; - function Hash_Fun is new System.String_Hash.Hash - (Character, String, Hash_Type); -begin - return Hash_Fun (Bounded.To_String (Key)); -end Ada.Strings.Bounded.Hash; diff --git a/gcc/ada/a-stboha.ads b/gcc/ada/a-stboha.ads deleted file mode 100644 index 876af2a..0000000 --- a/gcc/ada/a-stboha.ads +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . B O U N D E D . H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -generic - with package Bounded is - new Ada.Strings.Bounded.Generic_Bounded_Length (<>); - -function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String) - return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Bounded.Hash); diff --git a/gcc/ada/a-stfiha.ads b/gcc/ada/a-stfiha.ads deleted file mode 100644 index aba42e7..0000000 --- a/gcc/ada/a-stfiha.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . F I X E D . H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers, Ada.Strings.Hash; - -function Ada.Strings.Fixed.Hash (Key : String) return Containers.Hash_Type - renames Ada.Strings.Hash; - -pragma Pure (Ada.Strings.Fixed.Hash); diff --git a/gcc/ada/a-stmaco.ads b/gcc/ada/a-stmaco.ads deleted file mode 100644 index 92d7021..0000000 --- a/gcc/ada/a-stmaco.ads +++ /dev/null @@ -1,915 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . M A P S . C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Latin_1; - -package Ada.Strings.Maps.Constants is - pragma Pure; - -- In accordance with Ada 2005 AI-362 - - Control_Set : constant Character_Set; - Graphic_Set : constant Character_Set; - Letter_Set : constant Character_Set; - Lower_Set : constant Character_Set; - Upper_Set : constant Character_Set; - Basic_Set : constant Character_Set; - Decimal_Digit_Set : constant Character_Set; - Hexadecimal_Digit_Set : constant Character_Set; - Alphanumeric_Set : constant Character_Set; - Special_Set : constant Character_Set; - ISO_646_Set : constant Character_Set; - - Lower_Case_Map : constant Character_Mapping; - -- Maps to lower case for letters, else identity - - Upper_Case_Map : constant Character_Mapping; - -- Maps to upper case for letters, else identity - - Basic_Map : constant Character_Mapping; - -- Maps to basic letters for letters, else identity - -private - package L renames Ada.Characters.Latin_1; - - Control_Set : constant Character_Set := - (L.NUL .. L.US => True, - L.DEL .. L.APC => True, - others => False); - - Graphic_Set : constant Character_Set := - (L.Space .. L.Tilde => True, - L.No_Break_Space .. L.LC_Y_Diaeresis => True, - others => False); - - Letter_Set : constant Character_Set := - ('A' .. 'Z' => True, - L.LC_A .. L.LC_Z => True, - L.UC_A_Grave .. L.UC_O_Diaeresis => True, - L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True, - L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, - others => False); - - Lower_Set : constant Character_Set := - (L.LC_A .. L.LC_Z => True, - L.LC_German_Sharp_S .. L.LC_O_Diaeresis => True, - L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, - others => False); - - Upper_Set : constant Character_Set := - ('A' .. 'Z' => True, - L.UC_A_Grave .. L.UC_O_Diaeresis => True, - L.UC_O_Oblique_Stroke .. L.UC_Icelandic_Thorn => True, - others => False); - - Basic_Set : constant Character_Set := - ('A' .. 'Z' => True, - L.LC_A .. L.LC_Z => True, - L.UC_AE_Diphthong .. L.UC_AE_Diphthong => True, - L.LC_AE_Diphthong .. L.LC_AE_Diphthong => True, - L.LC_German_Sharp_S .. L.LC_German_Sharp_S => True, - L.UC_Icelandic_Thorn .. L.UC_Icelandic_Thorn => True, - L.LC_Icelandic_Thorn .. L.LC_Icelandic_Thorn => True, - L.UC_Icelandic_Eth .. L.UC_Icelandic_Eth => True, - L.LC_Icelandic_Eth .. L.LC_Icelandic_Eth => True, - others => False); - - Decimal_Digit_Set : constant Character_Set := - ('0' .. '9' => True, - others => False); - - Hexadecimal_Digit_Set : constant Character_Set := - ('0' .. '9' => True, - 'A' .. 'F' => True, - L.LC_A .. L.LC_F => True, - others => False); - - Alphanumeric_Set : constant Character_Set := - ('0' .. '9' => True, - 'A' .. 'Z' => True, - L.LC_A .. L.LC_Z => True, - L.UC_A_Grave .. L.UC_O_Diaeresis => True, - L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True, - L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, - others => False); - - Special_Set : constant Character_Set := - (L.Space .. L.Solidus => True, - L.Colon .. L.Commercial_At => True, - L.Left_Square_Bracket .. L.Grave => True, - L.Left_Curly_Bracket .. L.Tilde => True, - L.No_Break_Space .. L.Inverted_Question => True, - L.Multiplication_Sign .. L.Multiplication_Sign => True, - L.Division_Sign .. L.Division_Sign => True, - others => False); - - ISO_646_Set : constant Character_Set := - (L.NUL .. L.DEL => True, - others => False); - - Lower_Case_Map : constant Character_Mapping := - (L.NUL & -- NUL 0 - L.SOH & -- SOH 1 - L.STX & -- STX 2 - L.ETX & -- ETX 3 - L.EOT & -- EOT 4 - L.ENQ & -- ENQ 5 - L.ACK & -- ACK 6 - L.BEL & -- BEL 7 - L.BS & -- BS 8 - L.HT & -- HT 9 - L.LF & -- LF 10 - L.VT & -- VT 11 - L.FF & -- FF 12 - L.CR & -- CR 13 - L.SO & -- SO 14 - L.SI & -- SI 15 - L.DLE & -- DLE 16 - L.DC1 & -- DC1 17 - L.DC2 & -- DC2 18 - L.DC3 & -- DC3 19 - L.DC4 & -- DC4 20 - L.NAK & -- NAK 21 - L.SYN & -- SYN 22 - L.ETB & -- ETB 23 - L.CAN & -- CAN 24 - L.EM & -- EM 25 - L.SUB & -- SUB 26 - L.ESC & -- ESC 27 - L.FS & -- FS 28 - L.GS & -- GS 29 - L.RS & -- RS 30 - L.US & -- US 31 - L.Space & -- ' ' 32 - L.Exclamation & -- '!' 33 - L.Quotation & -- '"' 34 - L.Number_Sign & -- '#' 35 - L.Dollar_Sign & -- '$' 36 - L.Percent_Sign & -- '%' 37 - L.Ampersand & -- '&' 38 - L.Apostrophe & -- ''' 39 - L.Left_Parenthesis & -- '(' 40 - L.Right_Parenthesis & -- ')' 41 - L.Asterisk & -- '*' 42 - L.Plus_Sign & -- '+' 43 - L.Comma & -- ',' 44 - L.Hyphen & -- '-' 45 - L.Full_Stop & -- '.' 46 - L.Solidus & -- '/' 47 - '0' & -- '0' 48 - '1' & -- '1' 49 - '2' & -- '2' 50 - '3' & -- '3' 51 - '4' & -- '4' 52 - '5' & -- '5' 53 - '6' & -- '6' 54 - '7' & -- '7' 55 - '8' & -- '8' 56 - '9' & -- '9' 57 - L.Colon & -- ':' 58 - L.Semicolon & -- ';' 59 - L.Less_Than_Sign & -- '<' 60 - L.Equals_Sign & -- '=' 61 - L.Greater_Than_Sign & -- '>' 62 - L.Question & -- '?' 63 - L.Commercial_At & -- '@' 64 - L.LC_A & -- 'a' 65 - L.LC_B & -- 'b' 66 - L.LC_C & -- 'c' 67 - L.LC_D & -- 'd' 68 - L.LC_E & -- 'e' 69 - L.LC_F & -- 'f' 70 - L.LC_G & -- 'g' 71 - L.LC_H & -- 'h' 72 - L.LC_I & -- 'i' 73 - L.LC_J & -- 'j' 74 - L.LC_K & -- 'k' 75 - L.LC_L & -- 'l' 76 - L.LC_M & -- 'm' 77 - L.LC_N & -- 'n' 78 - L.LC_O & -- 'o' 79 - L.LC_P & -- 'p' 80 - L.LC_Q & -- 'q' 81 - L.LC_R & -- 'r' 82 - L.LC_S & -- 's' 83 - L.LC_T & -- 't' 84 - L.LC_U & -- 'u' 85 - L.LC_V & -- 'v' 86 - L.LC_W & -- 'w' 87 - L.LC_X & -- 'x' 88 - L.LC_Y & -- 'y' 89 - L.LC_Z & -- 'z' 90 - L.Left_Square_Bracket & -- '[' 91 - L.Reverse_Solidus & -- '\' 92 - L.Right_Square_Bracket & -- ']' 93 - L.Circumflex & -- '^' 94 - L.Low_Line & -- '_' 95 - L.Grave & -- '`' 96 - L.LC_A & -- 'a' 97 - L.LC_B & -- 'b' 98 - L.LC_C & -- 'c' 99 - L.LC_D & -- 'd' 100 - L.LC_E & -- 'e' 101 - L.LC_F & -- 'f' 102 - L.LC_G & -- 'g' 103 - L.LC_H & -- 'h' 104 - L.LC_I & -- 'i' 105 - L.LC_J & -- 'j' 106 - L.LC_K & -- 'k' 107 - L.LC_L & -- 'l' 108 - L.LC_M & -- 'm' 109 - L.LC_N & -- 'n' 110 - L.LC_O & -- 'o' 111 - L.LC_P & -- 'p' 112 - L.LC_Q & -- 'q' 113 - L.LC_R & -- 'r' 114 - L.LC_S & -- 's' 115 - L.LC_T & -- 't' 116 - L.LC_U & -- 'u' 117 - L.LC_V & -- 'v' 118 - L.LC_W & -- 'w' 119 - L.LC_X & -- 'x' 120 - L.LC_Y & -- 'y' 121 - L.LC_Z & -- 'z' 122 - L.Left_Curly_Bracket & -- '{' 123 - L.Vertical_Line & -- '|' 124 - L.Right_Curly_Bracket & -- '}' 125 - L.Tilde & -- '~' 126 - L.DEL & -- DEL 127 - L.Reserved_128 & -- Reserved_128 128 - L.Reserved_129 & -- Reserved_129 129 - L.BPH & -- BPH 130 - L.NBH & -- NBH 131 - L.Reserved_132 & -- Reserved_132 132 - L.NEL & -- NEL 133 - L.SSA & -- SSA 134 - L.ESA & -- ESA 135 - L.HTS & -- HTS 136 - L.HTJ & -- HTJ 137 - L.VTS & -- VTS 138 - L.PLD & -- PLD 139 - L.PLU & -- PLU 140 - L.RI & -- RI 141 - L.SS2 & -- SS2 142 - L.SS3 & -- SS3 143 - L.DCS & -- DCS 144 - L.PU1 & -- PU1 145 - L.PU2 & -- PU2 146 - L.STS & -- STS 147 - L.CCH & -- CCH 148 - L.MW & -- MW 149 - L.SPA & -- SPA 150 - L.EPA & -- EPA 151 - L.SOS & -- SOS 152 - L.Reserved_153 & -- Reserved_153 153 - L.SCI & -- SCI 154 - L.CSI & -- CSI 155 - L.ST & -- ST 156 - L.OSC & -- OSC 157 - L.PM & -- PM 158 - L.APC & -- APC 159 - L.No_Break_Space & -- No_Break_Space 160 - L.Inverted_Exclamation & -- Inverted_Exclamation 161 - L.Cent_Sign & -- Cent_Sign 162 - L.Pound_Sign & -- Pound_Sign 163 - L.Currency_Sign & -- Currency_Sign 164 - L.Yen_Sign & -- Yen_Sign 165 - L.Broken_Bar & -- Broken_Bar 166 - L.Section_Sign & -- Section_Sign 167 - L.Diaeresis & -- Diaeresis 168 - L.Copyright_Sign & -- Copyright_Sign 169 - L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 - L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 - L.Not_Sign & -- Not_Sign 172 - L.Soft_Hyphen & -- Soft_Hyphen 173 - L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 - L.Macron & -- Macron 175 - L.Degree_Sign & -- Degree_Sign 176 - L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 - L.Superscript_Two & -- Superscript_Two 178 - L.Superscript_Three & -- Superscript_Three 179 - L.Acute & -- Acute 180 - L.Micro_Sign & -- Micro_Sign 181 - L.Pilcrow_Sign & -- Pilcrow_Sign 182 - L.Middle_Dot & -- Middle_Dot 183 - L.Cedilla & -- Cedilla 184 - L.Superscript_One & -- Superscript_One 185 - L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 - L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 - L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 - L.Fraction_One_Half & -- Fraction_One_Half 189 - L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 - L.Inverted_Question & -- Inverted_Question 191 - L.LC_A_Grave & -- UC_A_Grave 192 - L.LC_A_Acute & -- UC_A_Acute 193 - L.LC_A_Circumflex & -- UC_A_Circumflex 194 - L.LC_A_Tilde & -- UC_A_Tilde 195 - L.LC_A_Diaeresis & -- UC_A_Diaeresis 196 - L.LC_A_Ring & -- UC_A_Ring 197 - L.LC_AE_Diphthong & -- UC_AE_Diphthong 198 - L.LC_C_Cedilla & -- UC_C_Cedilla 199 - L.LC_E_Grave & -- UC_E_Grave 200 - L.LC_E_Acute & -- UC_E_Acute 201 - L.LC_E_Circumflex & -- UC_E_Circumflex 202 - L.LC_E_Diaeresis & -- UC_E_Diaeresis 203 - L.LC_I_Grave & -- UC_I_Grave 204 - L.LC_I_Acute & -- UC_I_Acute 205 - L.LC_I_Circumflex & -- UC_I_Circumflex 206 - L.LC_I_Diaeresis & -- UC_I_Diaeresis 207 - L.LC_Icelandic_Eth & -- UC_Icelandic_Eth 208 - L.LC_N_Tilde & -- UC_N_Tilde 209 - L.LC_O_Grave & -- UC_O_Grave 210 - L.LC_O_Acute & -- UC_O_Acute 211 - L.LC_O_Circumflex & -- UC_O_Circumflex 212 - L.LC_O_Tilde & -- UC_O_Tilde 213 - L.LC_O_Diaeresis & -- UC_O_Diaeresis 214 - L.Multiplication_Sign & -- Multiplication_Sign 215 - L.LC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 - L.LC_U_Grave & -- UC_U_Grave 217 - L.LC_U_Acute & -- UC_U_Acute 218 - L.LC_U_Circumflex & -- UC_U_Circumflex 219 - L.LC_U_Diaeresis & -- UC_U_Diaeresis 220 - L.LC_Y_Acute & -- UC_Y_Acute 221 - L.LC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 - L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 - L.LC_A_Grave & -- LC_A_Grave 224 - L.LC_A_Acute & -- LC_A_Acute 225 - L.LC_A_Circumflex & -- LC_A_Circumflex 226 - L.LC_A_Tilde & -- LC_A_Tilde 227 - L.LC_A_Diaeresis & -- LC_A_Diaeresis 228 - L.LC_A_Ring & -- LC_A_Ring 229 - L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 - L.LC_C_Cedilla & -- LC_C_Cedilla 231 - L.LC_E_Grave & -- LC_E_Grave 232 - L.LC_E_Acute & -- LC_E_Acute 233 - L.LC_E_Circumflex & -- LC_E_Circumflex 234 - L.LC_E_Diaeresis & -- LC_E_Diaeresis 235 - L.LC_I_Grave & -- LC_I_Grave 236 - L.LC_I_Acute & -- LC_I_Acute 237 - L.LC_I_Circumflex & -- LC_I_Circumflex 238 - L.LC_I_Diaeresis & -- LC_I_Diaeresis 239 - L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 - L.LC_N_Tilde & -- LC_N_Tilde 241 - L.LC_O_Grave & -- LC_O_Grave 242 - L.LC_O_Acute & -- LC_O_Acute 243 - L.LC_O_Circumflex & -- LC_O_Circumflex 244 - L.LC_O_Tilde & -- LC_O_Tilde 245 - L.LC_O_Diaeresis & -- LC_O_Diaeresis 246 - L.Division_Sign & -- Division_Sign 247 - L.LC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 - L.LC_U_Grave & -- LC_U_Grave 249 - L.LC_U_Acute & -- LC_U_Acute 250 - L.LC_U_Circumflex & -- LC_U_Circumflex 251 - L.LC_U_Diaeresis & -- LC_U_Diaeresis 252 - L.LC_Y_Acute & -- LC_Y_Acute 253 - L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 - L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 - - Upper_Case_Map : constant Character_Mapping := - (L.NUL & -- NUL 0 - L.SOH & -- SOH 1 - L.STX & -- STX 2 - L.ETX & -- ETX 3 - L.EOT & -- EOT 4 - L.ENQ & -- ENQ 5 - L.ACK & -- ACK 6 - L.BEL & -- BEL 7 - L.BS & -- BS 8 - L.HT & -- HT 9 - L.LF & -- LF 10 - L.VT & -- VT 11 - L.FF & -- FF 12 - L.CR & -- CR 13 - L.SO & -- SO 14 - L.SI & -- SI 15 - L.DLE & -- DLE 16 - L.DC1 & -- DC1 17 - L.DC2 & -- DC2 18 - L.DC3 & -- DC3 19 - L.DC4 & -- DC4 20 - L.NAK & -- NAK 21 - L.SYN & -- SYN 22 - L.ETB & -- ETB 23 - L.CAN & -- CAN 24 - L.EM & -- EM 25 - L.SUB & -- SUB 26 - L.ESC & -- ESC 27 - L.FS & -- FS 28 - L.GS & -- GS 29 - L.RS & -- RS 30 - L.US & -- US 31 - L.Space & -- ' ' 32 - L.Exclamation & -- '!' 33 - L.Quotation & -- '"' 34 - L.Number_Sign & -- '#' 35 - L.Dollar_Sign & -- '$' 36 - L.Percent_Sign & -- '%' 37 - L.Ampersand & -- '&' 38 - L.Apostrophe & -- ''' 39 - L.Left_Parenthesis & -- '(' 40 - L.Right_Parenthesis & -- ')' 41 - L.Asterisk & -- '*' 42 - L.Plus_Sign & -- '+' 43 - L.Comma & -- ',' 44 - L.Hyphen & -- '-' 45 - L.Full_Stop & -- '.' 46 - L.Solidus & -- '/' 47 - '0' & -- '0' 48 - '1' & -- '1' 49 - '2' & -- '2' 50 - '3' & -- '3' 51 - '4' & -- '4' 52 - '5' & -- '5' 53 - '6' & -- '6' 54 - '7' & -- '7' 55 - '8' & -- '8' 56 - '9' & -- '9' 57 - L.Colon & -- ':' 58 - L.Semicolon & -- ';' 59 - L.Less_Than_Sign & -- '<' 60 - L.Equals_Sign & -- '=' 61 - L.Greater_Than_Sign & -- '>' 62 - L.Question & -- '?' 63 - L.Commercial_At & -- '@' 64 - 'A' & -- 'A' 65 - 'B' & -- 'B' 66 - 'C' & -- 'C' 67 - 'D' & -- 'D' 68 - 'E' & -- 'E' 69 - 'F' & -- 'F' 70 - 'G' & -- 'G' 71 - 'H' & -- 'H' 72 - 'I' & -- 'I' 73 - 'J' & -- 'J' 74 - 'K' & -- 'K' 75 - 'L' & -- 'L' 76 - 'M' & -- 'M' 77 - 'N' & -- 'N' 78 - 'O' & -- 'O' 79 - 'P' & -- 'P' 80 - 'Q' & -- 'Q' 81 - 'R' & -- 'R' 82 - 'S' & -- 'S' 83 - 'T' & -- 'T' 84 - 'U' & -- 'U' 85 - 'V' & -- 'V' 86 - 'W' & -- 'W' 87 - 'X' & -- 'X' 88 - 'Y' & -- 'Y' 89 - 'Z' & -- 'Z' 90 - L.Left_Square_Bracket & -- '[' 91 - L.Reverse_Solidus & -- '\' 92 - L.Right_Square_Bracket & -- ']' 93 - L.Circumflex & -- '^' 94 - L.Low_Line & -- '_' 95 - L.Grave & -- '`' 96 - 'A' & -- 'a' 97 - 'B' & -- 'b' 98 - 'C' & -- 'c' 99 - 'D' & -- 'd' 100 - 'E' & -- 'e' 101 - 'F' & -- 'f' 102 - 'G' & -- 'g' 103 - 'H' & -- 'h' 104 - 'I' & -- 'i' 105 - 'J' & -- 'j' 106 - 'K' & -- 'k' 107 - 'L' & -- 'l' 108 - 'M' & -- 'm' 109 - 'N' & -- 'n' 110 - 'O' & -- 'o' 111 - 'P' & -- 'p' 112 - 'Q' & -- 'q' 113 - 'R' & -- 'r' 114 - 'S' & -- 's' 115 - 'T' & -- 't' 116 - 'U' & -- 'u' 117 - 'V' & -- 'v' 118 - 'W' & -- 'w' 119 - 'X' & -- 'x' 120 - 'Y' & -- 'y' 121 - 'Z' & -- 'z' 122 - L.Left_Curly_Bracket & -- '{' 123 - L.Vertical_Line & -- '|' 124 - L.Right_Curly_Bracket & -- '}' 125 - L.Tilde & -- '~' 126 - L.DEL & -- DEL 127 - L.Reserved_128 & -- Reserved_128 128 - L.Reserved_129 & -- Reserved_129 129 - L.BPH & -- BPH 130 - L.NBH & -- NBH 131 - L.Reserved_132 & -- Reserved_132 132 - L.NEL & -- NEL 133 - L.SSA & -- SSA 134 - L.ESA & -- ESA 135 - L.HTS & -- HTS 136 - L.HTJ & -- HTJ 137 - L.VTS & -- VTS 138 - L.PLD & -- PLD 139 - L.PLU & -- PLU 140 - L.RI & -- RI 141 - L.SS2 & -- SS2 142 - L.SS3 & -- SS3 143 - L.DCS & -- DCS 144 - L.PU1 & -- PU1 145 - L.PU2 & -- PU2 146 - L.STS & -- STS 147 - L.CCH & -- CCH 148 - L.MW & -- MW 149 - L.SPA & -- SPA 150 - L.EPA & -- EPA 151 - L.SOS & -- SOS 152 - L.Reserved_153 & -- Reserved_153 153 - L.SCI & -- SCI 154 - L.CSI & -- CSI 155 - L.ST & -- ST 156 - L.OSC & -- OSC 157 - L.PM & -- PM 158 - L.APC & -- APC 159 - L.No_Break_Space & -- No_Break_Space 160 - L.Inverted_Exclamation & -- Inverted_Exclamation 161 - L.Cent_Sign & -- Cent_Sign 162 - L.Pound_Sign & -- Pound_Sign 163 - L.Currency_Sign & -- Currency_Sign 164 - L.Yen_Sign & -- Yen_Sign 165 - L.Broken_Bar & -- Broken_Bar 166 - L.Section_Sign & -- Section_Sign 167 - L.Diaeresis & -- Diaeresis 168 - L.Copyright_Sign & -- Copyright_Sign 169 - L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 - L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 - L.Not_Sign & -- Not_Sign 172 - L.Soft_Hyphen & -- Soft_Hyphen 173 - L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 - L.Macron & -- Macron 175 - L.Degree_Sign & -- Degree_Sign 176 - L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 - L.Superscript_Two & -- Superscript_Two 178 - L.Superscript_Three & -- Superscript_Three 179 - L.Acute & -- Acute 180 - L.Micro_Sign & -- Micro_Sign 181 - L.Pilcrow_Sign & -- Pilcrow_Sign 182 - L.Middle_Dot & -- Middle_Dot 183 - L.Cedilla & -- Cedilla 184 - L.Superscript_One & -- Superscript_One 185 - L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 - L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 - L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 - L.Fraction_One_Half & -- Fraction_One_Half 189 - L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 - L.Inverted_Question & -- Inverted_Question 191 - L.UC_A_Grave & -- UC_A_Grave 192 - L.UC_A_Acute & -- UC_A_Acute 193 - L.UC_A_Circumflex & -- UC_A_Circumflex 194 - L.UC_A_Tilde & -- UC_A_Tilde 195 - L.UC_A_Diaeresis & -- UC_A_Diaeresis 196 - L.UC_A_Ring & -- UC_A_Ring 197 - L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 - L.UC_C_Cedilla & -- UC_C_Cedilla 199 - L.UC_E_Grave & -- UC_E_Grave 200 - L.UC_E_Acute & -- UC_E_Acute 201 - L.UC_E_Circumflex & -- UC_E_Circumflex 202 - L.UC_E_Diaeresis & -- UC_E_Diaeresis 203 - L.UC_I_Grave & -- UC_I_Grave 204 - L.UC_I_Acute & -- UC_I_Acute 205 - L.UC_I_Circumflex & -- UC_I_Circumflex 206 - L.UC_I_Diaeresis & -- UC_I_Diaeresis 207 - L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 - L.UC_N_Tilde & -- UC_N_Tilde 209 - L.UC_O_Grave & -- UC_O_Grave 210 - L.UC_O_Acute & -- UC_O_Acute 211 - L.UC_O_Circumflex & -- UC_O_Circumflex 212 - L.UC_O_Tilde & -- UC_O_Tilde 213 - L.UC_O_Diaeresis & -- UC_O_Diaeresis 214 - L.Multiplication_Sign & -- Multiplication_Sign 215 - L.UC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 - L.UC_U_Grave & -- UC_U_Grave 217 - L.UC_U_Acute & -- UC_U_Acute 218 - L.UC_U_Circumflex & -- UC_U_Circumflex 219 - L.UC_U_Diaeresis & -- UC_U_Diaeresis 220 - L.UC_Y_Acute & -- UC_Y_Acute 221 - L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 - L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 - L.UC_A_Grave & -- LC_A_Grave 224 - L.UC_A_Acute & -- LC_A_Acute 225 - L.UC_A_Circumflex & -- LC_A_Circumflex 226 - L.UC_A_Tilde & -- LC_A_Tilde 227 - L.UC_A_Diaeresis & -- LC_A_Diaeresis 228 - L.UC_A_Ring & -- LC_A_Ring 229 - L.UC_AE_Diphthong & -- LC_AE_Diphthong 230 - L.UC_C_Cedilla & -- LC_C_Cedilla 231 - L.UC_E_Grave & -- LC_E_Grave 232 - L.UC_E_Acute & -- LC_E_Acute 233 - L.UC_E_Circumflex & -- LC_E_Circumflex 234 - L.UC_E_Diaeresis & -- LC_E_Diaeresis 235 - L.UC_I_Grave & -- LC_I_Grave 236 - L.UC_I_Acute & -- LC_I_Acute 237 - L.UC_I_Circumflex & -- LC_I_Circumflex 238 - L.UC_I_Diaeresis & -- LC_I_Diaeresis 239 - L.UC_Icelandic_Eth & -- LC_Icelandic_Eth 240 - L.UC_N_Tilde & -- LC_N_Tilde 241 - L.UC_O_Grave & -- LC_O_Grave 242 - L.UC_O_Acute & -- LC_O_Acute 243 - L.UC_O_Circumflex & -- LC_O_Circumflex 244 - L.UC_O_Tilde & -- LC_O_Tilde 245 - L.UC_O_Diaeresis & -- LC_O_Diaeresis 246 - L.Division_Sign & -- Division_Sign 247 - L.UC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 - L.UC_U_Grave & -- LC_U_Grave 249 - L.UC_U_Acute & -- LC_U_Acute 250 - L.UC_U_Circumflex & -- LC_U_Circumflex 251 - L.UC_U_Diaeresis & -- LC_U_Diaeresis 252 - L.UC_Y_Acute & -- LC_Y_Acute 253 - L.UC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 - L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 - - Basic_Map : constant Character_Mapping := - (L.NUL & -- NUL 0 - L.SOH & -- SOH 1 - L.STX & -- STX 2 - L.ETX & -- ETX 3 - L.EOT & -- EOT 4 - L.ENQ & -- ENQ 5 - L.ACK & -- ACK 6 - L.BEL & -- BEL 7 - L.BS & -- BS 8 - L.HT & -- HT 9 - L.LF & -- LF 10 - L.VT & -- VT 11 - L.FF & -- FF 12 - L.CR & -- CR 13 - L.SO & -- SO 14 - L.SI & -- SI 15 - L.DLE & -- DLE 16 - L.DC1 & -- DC1 17 - L.DC2 & -- DC2 18 - L.DC3 & -- DC3 19 - L.DC4 & -- DC4 20 - L.NAK & -- NAK 21 - L.SYN & -- SYN 22 - L.ETB & -- ETB 23 - L.CAN & -- CAN 24 - L.EM & -- EM 25 - L.SUB & -- SUB 26 - L.ESC & -- ESC 27 - L.FS & -- FS 28 - L.GS & -- GS 29 - L.RS & -- RS 30 - L.US & -- US 31 - L.Space & -- ' ' 32 - L.Exclamation & -- '!' 33 - L.Quotation & -- '"' 34 - L.Number_Sign & -- '#' 35 - L.Dollar_Sign & -- '$' 36 - L.Percent_Sign & -- '%' 37 - L.Ampersand & -- '&' 38 - L.Apostrophe & -- ''' 39 - L.Left_Parenthesis & -- '(' 40 - L.Right_Parenthesis & -- ')' 41 - L.Asterisk & -- '*' 42 - L.Plus_Sign & -- '+' 43 - L.Comma & -- ',' 44 - L.Hyphen & -- '-' 45 - L.Full_Stop & -- '.' 46 - L.Solidus & -- '/' 47 - '0' & -- '0' 48 - '1' & -- '1' 49 - '2' & -- '2' 50 - '3' & -- '3' 51 - '4' & -- '4' 52 - '5' & -- '5' 53 - '6' & -- '6' 54 - '7' & -- '7' 55 - '8' & -- '8' 56 - '9' & -- '9' 57 - L.Colon & -- ':' 58 - L.Semicolon & -- ';' 59 - L.Less_Than_Sign & -- '<' 60 - L.Equals_Sign & -- '=' 61 - L.Greater_Than_Sign & -- '>' 62 - L.Question & -- '?' 63 - L.Commercial_At & -- '@' 64 - 'A' & -- 'A' 65 - 'B' & -- 'B' 66 - 'C' & -- 'C' 67 - 'D' & -- 'D' 68 - 'E' & -- 'E' 69 - 'F' & -- 'F' 70 - 'G' & -- 'G' 71 - 'H' & -- 'H' 72 - 'I' & -- 'I' 73 - 'J' & -- 'J' 74 - 'K' & -- 'K' 75 - 'L' & -- 'L' 76 - 'M' & -- 'M' 77 - 'N' & -- 'N' 78 - 'O' & -- 'O' 79 - 'P' & -- 'P' 80 - 'Q' & -- 'Q' 81 - 'R' & -- 'R' 82 - 'S' & -- 'S' 83 - 'T' & -- 'T' 84 - 'U' & -- 'U' 85 - 'V' & -- 'V' 86 - 'W' & -- 'W' 87 - 'X' & -- 'X' 88 - 'Y' & -- 'Y' 89 - 'Z' & -- 'Z' 90 - L.Left_Square_Bracket & -- '[' 91 - L.Reverse_Solidus & -- '\' 92 - L.Right_Square_Bracket & -- ']' 93 - L.Circumflex & -- '^' 94 - L.Low_Line & -- '_' 95 - L.Grave & -- '`' 96 - L.LC_A & -- 'a' 97 - L.LC_B & -- 'b' 98 - L.LC_C & -- 'c' 99 - L.LC_D & -- 'd' 100 - L.LC_E & -- 'e' 101 - L.LC_F & -- 'f' 102 - L.LC_G & -- 'g' 103 - L.LC_H & -- 'h' 104 - L.LC_I & -- 'i' 105 - L.LC_J & -- 'j' 106 - L.LC_K & -- 'k' 107 - L.LC_L & -- 'l' 108 - L.LC_M & -- 'm' 109 - L.LC_N & -- 'n' 110 - L.LC_O & -- 'o' 111 - L.LC_P & -- 'p' 112 - L.LC_Q & -- 'q' 113 - L.LC_R & -- 'r' 114 - L.LC_S & -- 's' 115 - L.LC_T & -- 't' 116 - L.LC_U & -- 'u' 117 - L.LC_V & -- 'v' 118 - L.LC_W & -- 'w' 119 - L.LC_X & -- 'x' 120 - L.LC_Y & -- 'y' 121 - L.LC_Z & -- 'z' 122 - L.Left_Curly_Bracket & -- '{' 123 - L.Vertical_Line & -- '|' 124 - L.Right_Curly_Bracket & -- '}' 125 - L.Tilde & -- '~' 126 - L.DEL & -- DEL 127 - L.Reserved_128 & -- Reserved_128 128 - L.Reserved_129 & -- Reserved_129 129 - L.BPH & -- BPH 130 - L.NBH & -- NBH 131 - L.Reserved_132 & -- Reserved_132 132 - L.NEL & -- NEL 133 - L.SSA & -- SSA 134 - L.ESA & -- ESA 135 - L.HTS & -- HTS 136 - L.HTJ & -- HTJ 137 - L.VTS & -- VTS 138 - L.PLD & -- PLD 139 - L.PLU & -- PLU 140 - L.RI & -- RI 141 - L.SS2 & -- SS2 142 - L.SS3 & -- SS3 143 - L.DCS & -- DCS 144 - L.PU1 & -- PU1 145 - L.PU2 & -- PU2 146 - L.STS & -- STS 147 - L.CCH & -- CCH 148 - L.MW & -- MW 149 - L.SPA & -- SPA 150 - L.EPA & -- EPA 151 - L.SOS & -- SOS 152 - L.Reserved_153 & -- Reserved_153 153 - L.SCI & -- SCI 154 - L.CSI & -- CSI 155 - L.ST & -- ST 156 - L.OSC & -- OSC 157 - L.PM & -- PM 158 - L.APC & -- APC 159 - L.No_Break_Space & -- No_Break_Space 160 - L.Inverted_Exclamation & -- Inverted_Exclamation 161 - L.Cent_Sign & -- Cent_Sign 162 - L.Pound_Sign & -- Pound_Sign 163 - L.Currency_Sign & -- Currency_Sign 164 - L.Yen_Sign & -- Yen_Sign 165 - L.Broken_Bar & -- Broken_Bar 166 - L.Section_Sign & -- Section_Sign 167 - L.Diaeresis & -- Diaeresis 168 - L.Copyright_Sign & -- Copyright_Sign 169 - L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 - L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 - L.Not_Sign & -- Not_Sign 172 - L.Soft_Hyphen & -- Soft_Hyphen 173 - L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 - L.Macron & -- Macron 175 - L.Degree_Sign & -- Degree_Sign 176 - L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 - L.Superscript_Two & -- Superscript_Two 178 - L.Superscript_Three & -- Superscript_Three 179 - L.Acute & -- Acute 180 - L.Micro_Sign & -- Micro_Sign 181 - L.Pilcrow_Sign & -- Pilcrow_Sign 182 - L.Middle_Dot & -- Middle_Dot 183 - L.Cedilla & -- Cedilla 184 - L.Superscript_One & -- Superscript_One 185 - L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 - L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 - L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 - L.Fraction_One_Half & -- Fraction_One_Half 189 - L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 - L.Inverted_Question & -- Inverted_Question 191 - 'A' & -- UC_A_Grave 192 - 'A' & -- UC_A_Acute 193 - 'A' & -- UC_A_Circumflex 194 - 'A' & -- UC_A_Tilde 195 - 'A' & -- UC_A_Diaeresis 196 - 'A' & -- UC_A_Ring 197 - L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 - 'C' & -- UC_C_Cedilla 199 - 'E' & -- UC_E_Grave 200 - 'E' & -- UC_E_Acute 201 - 'E' & -- UC_E_Circumflex 202 - 'E' & -- UC_E_Diaeresis 203 - 'I' & -- UC_I_Grave 204 - 'I' & -- UC_I_Acute 205 - 'I' & -- UC_I_Circumflex 206 - 'I' & -- UC_I_Diaeresis 207 - L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 - 'N' & -- UC_N_Tilde 209 - 'O' & -- UC_O_Grave 210 - 'O' & -- UC_O_Acute 211 - 'O' & -- UC_O_Circumflex 212 - 'O' & -- UC_O_Tilde 213 - 'O' & -- UC_O_Diaeresis 214 - L.Multiplication_Sign & -- Multiplication_Sign 215 - 'O' & -- UC_O_Oblique_Stroke 216 - 'U' & -- UC_U_Grave 217 - 'U' & -- UC_U_Acute 218 - 'U' & -- UC_U_Circumflex 219 - 'U' & -- UC_U_Diaeresis 220 - 'Y' & -- UC_Y_Acute 221 - L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 - L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 - L.LC_A & -- LC_A_Grave 224 - L.LC_A & -- LC_A_Acute 225 - L.LC_A & -- LC_A_Circumflex 226 - L.LC_A & -- LC_A_Tilde 227 - L.LC_A & -- LC_A_Diaeresis 228 - L.LC_A & -- LC_A_Ring 229 - L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 - L.LC_C & -- LC_C_Cedilla 231 - L.LC_E & -- LC_E_Grave 232 - L.LC_E & -- LC_E_Acute 233 - L.LC_E & -- LC_E_Circumflex 234 - L.LC_E & -- LC_E_Diaeresis 235 - L.LC_I & -- LC_I_Grave 236 - L.LC_I & -- LC_I_Acute 237 - L.LC_I & -- LC_I_Circumflex 238 - L.LC_I & -- LC_I_Diaeresis 239 - L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 - L.LC_N & -- LC_N_Tilde 241 - L.LC_O & -- LC_O_Grave 242 - L.LC_O & -- LC_O_Acute 243 - L.LC_O & -- LC_O_Circumflex 244 - L.LC_O & -- LC_O_Tilde 245 - L.LC_O & -- LC_O_Diaeresis 246 - L.Division_Sign & -- Division_Sign 247 - L.LC_O & -- LC_O_Oblique_Stroke 248 - L.LC_U & -- LC_U_Grave 249 - L.LC_U & -- LC_U_Acute 250 - L.LC_U & -- LC_U_Circumflex 251 - L.LC_U & -- LC_U_Diaeresis 252 - L.LC_Y & -- LC_Y_Acute 253 - L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 - L.LC_Y); -- LC_Y_Diaeresis 255 - -end Ada.Strings.Maps.Constants; diff --git a/gcc/ada/a-storio.adb b/gcc/ada/a-storio.adb deleted file mode 100644 index 50b7665..0000000 --- a/gcc/ada/a-storio.adb +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T O R A G E _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body Ada.Storage_IO is - - type Buffer_Ptr is access all Buffer_Type; - type Elmt_Ptr is access all Element_Type; - - function To_Buffer_Ptr is - new Ada.Unchecked_Conversion (Elmt_Ptr, Buffer_Ptr); - - ---------- - -- Read -- - ---------- - - procedure Read (Buffer : Buffer_Type; Item : out Element_Type) is - begin - To_Buffer_Ptr (Item'Unrestricted_Access).all := Buffer; - end Read; - - ----------- - -- Write -- - ----------- - - procedure Write (Buffer : out Buffer_Type; Item : Element_Type) is - begin - Buffer := To_Buffer_Ptr (Item'Unrestricted_Access).all; - end Write; - -end Ada.Storage_IO; diff --git a/gcc/ada/a-storio.ads b/gcc/ada/a-storio.ads deleted file mode 100644 index db0a70b..0000000 --- a/gcc/ada/a-storio.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T O R A G E _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with System.Storage_Elements; - -generic - type Element_Type is private; - -package Ada.Storage_IO is - pragma Preelaborate; - - Buffer_Size : constant System.Storage_Elements.Storage_Count := - System.Storage_Elements.Storage_Count - ((Element_Type'Size + System.Storage_Unit - 1) / - System.Storage_Unit); - - subtype Buffer_Type is - System.Storage_Elements.Storage_Array (1 .. Buffer_Size); - - --------------------------------- - -- Input and Output Operations -- - --------------------------------- - - procedure Read (Buffer : Buffer_Type; Item : out Element_Type); - - procedure Write (Buffer : out Buffer_Type; Item : Element_Type); - - ---------------- - -- Exceptions -- - ---------------- - - Data_Error : exception renames IO_Exceptions.Data_Error; - -end Ada.Storage_IO; diff --git a/gcc/ada/a-strbou.adb b/gcc/ada/a-strbou.adb deleted file mode 100644 index 370371f..0000000 --- a/gcc/ada/a-strbou.adb +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Bounded is - - package body Generic_Bounded_Length is - - -- The subprograms in this body are those for which there is no - -- Bounded_String input, and hence no implicit information on the - -- maximum size. This means that the maximum size has to be passed - -- explicitly to the routine in Superbounded. - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Character) return Bounded_String - is - begin - return Times (Left, Right, Max_Length); - end "*"; - - function "*" - (Left : Natural; - Right : String) return Bounded_String - is - begin - return Times (Left, Right, Max_Length); - end "*"; - - ----------------- - -- From_String -- - ----------------- - - function From_String (Source : String) return Bounded_String is - begin - return To_Super_String (Source, Max_Length, Error); - end From_String; - - --------------- - -- Replicate -- - --------------- - - function Replicate - (Count : Natural; - Item : Character; - Drop : Strings.Truncation := Strings.Error) return Bounded_String - is - begin - return Super_Replicate (Count, Item, Drop, Max_Length); - end Replicate; - - function Replicate - (Count : Natural; - Item : String; - Drop : Strings.Truncation := Strings.Error) return Bounded_String - is - begin - return Super_Replicate (Count, Item, Drop, Max_Length); - end Replicate; - - ----------------------- - -- To_Bounded_String -- - ----------------------- - - function To_Bounded_String - (Source : String; - Drop : Strings.Truncation := Strings.Error) return Bounded_String - is - begin - return To_Super_String (Source, Max_Length, Drop); - end To_Bounded_String; - - end Generic_Bounded_Length; - -end Ada.Strings.Bounded; diff --git a/gcc/ada/a-strbou.ads b/gcc/ada/a-strbou.ads deleted file mode 100644 index 5e7a9c7..0000000 --- a/gcc/ada/a-strbou.ads +++ /dev/null @@ -1,914 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Maps; -with Ada.Strings.Superbounded; - -package Ada.Strings.Bounded is - pragma Preelaborate; - - generic - Max : Positive; - -- Maximum length of a Bounded_String - - package Generic_Bounded_Length is - - Max_Length : constant Positive := Max; - - type Bounded_String is private; - pragma Preelaborable_Initialization (Bounded_String); - - Null_Bounded_String : constant Bounded_String; - - subtype Length_Range is Natural range 0 .. Max_Length; - - function Length (Source : Bounded_String) return Length_Range; - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Bounded_String - (Source : String; - Drop : Truncation := Error) return Bounded_String; - - function To_String (Source : Bounded_String) return String; - - procedure Set_Bounded_String - (Target : out Bounded_String; - Source : String; - Drop : Truncation := Error); - pragma Ada_05 (Set_Bounded_String); - - function Append - (Left : Bounded_String; - Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String; - - function Append - (Left : Bounded_String; - Right : String; - Drop : Truncation := Error) return Bounded_String; - - function Append - (Left : String; - Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String; - - function Append - (Left : Bounded_String; - Right : Character; - Drop : Truncation := Error) return Bounded_String; - - function Append - (Left : Character; - Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String; - - procedure Append - (Source : in out Bounded_String; - New_Item : Bounded_String; - Drop : Truncation := Error); - - procedure Append - (Source : in out Bounded_String; - New_Item : String; - Drop : Truncation := Error); - - procedure Append - (Source : in out Bounded_String; - New_Item : Character; - Drop : Truncation := Error); - - function "&" - (Left : Bounded_String; - Right : Bounded_String) return Bounded_String; - - function "&" - (Left : Bounded_String; - Right : String) return Bounded_String; - - function "&" - (Left : String; - Right : Bounded_String) return Bounded_String; - - function "&" - (Left : Bounded_String; - Right : Character) return Bounded_String; - - function "&" - (Left : Character; - Right : Bounded_String) return Bounded_String; - - function Element - (Source : Bounded_String; - Index : Positive) return Character; - - procedure Replace_Element - (Source : in out Bounded_String; - Index : Positive; - By : Character); - - function Slice - (Source : Bounded_String; - Low : Positive; - High : Natural) return String; - - function Bounded_Slice - (Source : Bounded_String; - Low : Positive; - High : Natural) return Bounded_String; - pragma Ada_05 (Bounded_Slice); - - procedure Bounded_Slice - (Source : Bounded_String; - Target : out Bounded_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Bounded_Slice); - - function "=" - (Left : Bounded_String; - Right : Bounded_String) return Boolean; - - function "=" - (Left : Bounded_String; - Right : String) return Boolean; - - function "=" - (Left : String; - Right : Bounded_String) return Boolean; - - function "<" - (Left : Bounded_String; - Right : Bounded_String) return Boolean; - - function "<" - (Left : Bounded_String; - Right : String) return Boolean; - - function "<" - (Left : String; - Right : Bounded_String) return Boolean; - - function "<=" - (Left : Bounded_String; - Right : Bounded_String) return Boolean; - - function "<=" - (Left : Bounded_String; - Right : String) return Boolean; - - function "<=" - (Left : String; - Right : Bounded_String) return Boolean; - - function ">" - (Left : Bounded_String; - Right : Bounded_String) return Boolean; - - function ">" - (Left : Bounded_String; - Right : String) return Boolean; - - function ">" - (Left : String; - Right : Bounded_String) return Boolean; - - function ">=" - (Left : Bounded_String; - Right : Bounded_String) return Boolean; - - function ">=" - (Left : Bounded_String; - Right : String) return Boolean; - - function ">=" - (Left : String; - Right : Bounded_String) return Boolean; - - ---------------------- - -- Search Functions -- - ---------------------- - - function Index - (Source : Bounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Index - (Source : Bounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Index - (Source : Bounded_String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Bounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Bounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Bounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Bounded_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Bounded_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Bounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Count - (Source : Bounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Count - (Source : Bounded_String; - Set : Maps.Character_Set) return Natural; - - procedure Find_Token - (Source : Bounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Bounded_String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Bounded_String; - Mapping : Maps.Character_Mapping) return Bounded_String; - - procedure Translate - (Source : in out Bounded_String; - Mapping : Maps.Character_Mapping); - - function Translate - (Source : Bounded_String; - Mapping : Maps.Character_Mapping_Function) return Bounded_String; - - procedure Translate - (Source : in out Bounded_String; - Mapping : Maps.Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Bounded_String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error) return Bounded_String; - - procedure Replace_Slice - (Source : in out Bounded_String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error); - - function Insert - (Source : Bounded_String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error) return Bounded_String; - - procedure Insert - (Source : in out Bounded_String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error); - - function Overwrite - (Source : Bounded_String; - Position : Positive; - New_Item : String; - Drop : Truncation := Error) return Bounded_String; - - procedure Overwrite - (Source : in out Bounded_String; - Position : Positive; - New_Item : String; - Drop : Truncation := Error); - - function Delete - (Source : Bounded_String; - From : Positive; - Through : Natural) return Bounded_String; - - procedure Delete - (Source : in out Bounded_String; - From : Positive; - Through : Natural); - - --------------------------------- - -- String Selector Subprograms -- - --------------------------------- - - function Trim - (Source : Bounded_String; - Side : Trim_End) return Bounded_String; - - procedure Trim - (Source : in out Bounded_String; - Side : Trim_End); - - function Trim - (Source : Bounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Bounded_String; - - procedure Trim - (Source : in out Bounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set); - - function Head - (Source : Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) return Bounded_String; - - procedure Head - (Source : in out Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error); - - function Tail - (Source : Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) return Bounded_String; - - procedure Tail - (Source : in out Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error); - - ------------------------------------ - -- String Constructor Subprograms -- - ------------------------------------ - - function "*" - (Left : Natural; - Right : Character) return Bounded_String; - - function "*" - (Left : Natural; - Right : String) return Bounded_String; - - function "*" - (Left : Natural; - Right : Bounded_String) return Bounded_String; - - function Replicate - (Count : Natural; - Item : Character; - Drop : Truncation := Error) return Bounded_String; - - function Replicate - (Count : Natural; - Item : String; - Drop : Truncation := Error) return Bounded_String; - - function Replicate - (Count : Natural; - Item : Bounded_String; - Drop : Truncation := Error) return Bounded_String; - - private - -- Most of the implementation is in the separate non generic package - -- Ada.Strings.Superbounded. Type Bounded_String is derived from type - -- Superbounded.Super_String with the maximum length constraint. In - -- almost all cases, the routines in Superbounded can be called with - -- no requirement to pass the maximum length explicitly, since there - -- is at least one Bounded_String argument from which the maximum - -- length can be obtained. For all such routines, the implementation - -- in this private part is simply a renaming of the corresponding - -- routine in the superbounded package. - - -- The five exceptions are the * and Replicate routines operating on - -- character values. For these cases, we have a routine in the body - -- that calls the superbounded routine passing the maximum length - -- explicitly as an extra parameter. - - type Bounded_String is new Superbounded.Super_String (Max_Length); - -- Deriving Bounded_String from Superbounded.Super_String is the - -- real trick, it ensures that the type Bounded_String declared in - -- the generic instantiation is compatible with the Super_String - -- type declared in the Superbounded package. - - function From_String (Source : String) return Bounded_String; - -- Private routine used only by Stream_Convert - - pragma Stream_Convert (Bounded_String, From_String, To_String); - -- Provide stream routines without dragging in Ada.Streams - - Null_Bounded_String : constant Bounded_String := - (Max_Length => Max_Length, - Current_Length => 0, - Data => - (1 .. Max_Length => ASCII.NUL)); - - pragma Inline (To_Bounded_String); - - procedure Set_Bounded_String - (Target : out Bounded_String; - Source : String; - Drop : Truncation := Error) - renames Set_Super_String; - - function Length - (Source : Bounded_String) return Length_Range - renames Super_Length; - - function To_String - (Source : Bounded_String) return String - renames Super_To_String; - - function Append - (Left : Bounded_String; - Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String - renames Super_Append; - - function Append - (Left : Bounded_String; - Right : String; - Drop : Truncation := Error) return Bounded_String - renames Super_Append; - - function Append - (Left : String; - Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String - renames Super_Append; - - function Append - (Left : Bounded_String; - Right : Character; - Drop : Truncation := Error) return Bounded_String - renames Super_Append; - - function Append - (Left : Character; - Right : Bounded_String; - Drop : Truncation := Error) return Bounded_String - renames Super_Append; - - procedure Append - (Source : in out Bounded_String; - New_Item : Bounded_String; - Drop : Truncation := Error) - renames Super_Append; - - procedure Append - (Source : in out Bounded_String; - New_Item : String; - Drop : Truncation := Error) - renames Super_Append; - - procedure Append - (Source : in out Bounded_String; - New_Item : Character; - Drop : Truncation := Error) - renames Super_Append; - - function "&" - (Left : Bounded_String; - Right : Bounded_String) return Bounded_String - renames Concat; - - function "&" - (Left : Bounded_String; - Right : String) return Bounded_String - renames Concat; - - function "&" - (Left : String; - Right : Bounded_String) return Bounded_String - renames Concat; - - function "&" - (Left : Bounded_String; - Right : Character) return Bounded_String - renames Concat; - - function "&" - (Left : Character; - Right : Bounded_String) return Bounded_String - renames Concat; - - function Element - (Source : Bounded_String; - Index : Positive) return Character - renames Super_Element; - - procedure Replace_Element - (Source : in out Bounded_String; - Index : Positive; - By : Character) - renames Super_Replace_Element; - - function Slice - (Source : Bounded_String; - Low : Positive; - High : Natural) return String - renames Super_Slice; - - function Bounded_Slice - (Source : Bounded_String; - Low : Positive; - High : Natural) return Bounded_String - renames Super_Slice; - - procedure Bounded_Slice - (Source : Bounded_String; - Target : out Bounded_String; - Low : Positive; - High : Natural) - renames Super_Slice; - - overriding function "=" - (Left : Bounded_String; - Right : Bounded_String) return Boolean - renames Equal; - - function "=" - (Left : Bounded_String; - Right : String) return Boolean - renames Equal; - - function "=" - (Left : String; - Right : Bounded_String) return Boolean - renames Equal; - - function "<" - (Left : Bounded_String; - Right : Bounded_String) return Boolean - renames Less; - - function "<" - (Left : Bounded_String; - Right : String) return Boolean - renames Less; - - function "<" - (Left : String; - Right : Bounded_String) return Boolean - renames Less; - - function "<=" - (Left : Bounded_String; - Right : Bounded_String) return Boolean - renames Less_Or_Equal; - - function "<=" - (Left : Bounded_String; - Right : String) return Boolean - renames Less_Or_Equal; - - function "<=" - (Left : String; - Right : Bounded_String) return Boolean - renames Less_Or_Equal; - - function ">" - (Left : Bounded_String; - Right : Bounded_String) return Boolean - renames Greater; - - function ">" - (Left : Bounded_String; - Right : String) return Boolean - renames Greater; - - function ">" - (Left : String; - Right : Bounded_String) return Boolean - renames Greater; - - function ">=" - (Left : Bounded_String; - Right : Bounded_String) return Boolean - renames Greater_Or_Equal; - - function ">=" - (Left : Bounded_String; - Right : String) return Boolean - renames Greater_Or_Equal; - - function ">=" - (Left : String; - Right : Bounded_String) return Boolean - renames Greater_Or_Equal; - - function Index - (Source : Bounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - renames Super_Index; - - function Index - (Source : Bounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - renames Super_Index; - - function Index - (Source : Bounded_String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Super_Index; - - function Index - (Source : Bounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - renames Super_Index; - - function Index - (Source : Bounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - renames Super_Index; - - function Index - (Source : Bounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Super_Index; - - function Index_Non_Blank - (Source : Bounded_String; - Going : Direction := Forward) return Natural - renames Super_Index_Non_Blank; - - function Index_Non_Blank - (Source : Bounded_String; - From : Positive; - Going : Direction := Forward) return Natural - renames Super_Index_Non_Blank; - - function Count - (Source : Bounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - renames Super_Count; - - function Count - (Source : Bounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural - renames Super_Count; - - function Count - (Source : Bounded_String; - Set : Maps.Character_Set) return Natural - renames Super_Count; - - procedure Find_Token - (Source : Bounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Super_Find_Token; - - procedure Find_Token - (Source : Bounded_String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Super_Find_Token; - - function Translate - (Source : Bounded_String; - Mapping : Maps.Character_Mapping) return Bounded_String - renames Super_Translate; - - procedure Translate - (Source : in out Bounded_String; - Mapping : Maps.Character_Mapping) - renames Super_Translate; - - function Translate - (Source : Bounded_String; - Mapping : Maps.Character_Mapping_Function) return Bounded_String - renames Super_Translate; - - procedure Translate - (Source : in out Bounded_String; - Mapping : Maps.Character_Mapping_Function) - renames Super_Translate; - - function Replace_Slice - (Source : Bounded_String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error) return Bounded_String - renames Super_Replace_Slice; - - procedure Replace_Slice - (Source : in out Bounded_String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error) - renames Super_Replace_Slice; - - function Insert - (Source : Bounded_String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error) return Bounded_String - renames Super_Insert; - - procedure Insert - (Source : in out Bounded_String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error) - renames Super_Insert; - - function Overwrite - (Source : Bounded_String; - Position : Positive; - New_Item : String; - Drop : Truncation := Error) return Bounded_String - renames Super_Overwrite; - - procedure Overwrite - (Source : in out Bounded_String; - Position : Positive; - New_Item : String; - Drop : Truncation := Error) - renames Super_Overwrite; - - function Delete - (Source : Bounded_String; - From : Positive; - Through : Natural) return Bounded_String - renames Super_Delete; - - procedure Delete - (Source : in out Bounded_String; - From : Positive; - Through : Natural) - renames Super_Delete; - - function Trim - (Source : Bounded_String; - Side : Trim_End) return Bounded_String - renames Super_Trim; - - procedure Trim - (Source : in out Bounded_String; - Side : Trim_End) - renames Super_Trim; - - function Trim - (Source : Bounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Bounded_String - renames Super_Trim; - - procedure Trim - (Source : in out Bounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) - renames Super_Trim; - - function Head - (Source : Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) return Bounded_String - renames Super_Head; - - procedure Head - (Source : in out Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) - renames Super_Head; - - function Tail - (Source : Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) return Bounded_String - renames Super_Tail; - - procedure Tail - (Source : in out Bounded_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) - renames Super_Tail; - - function "*" - (Left : Natural; - Right : Bounded_String) return Bounded_String - renames Times; - - function Replicate - (Count : Natural; - Item : Bounded_String; - Drop : Truncation := Error) return Bounded_String - renames Super_Replicate; - - end Generic_Bounded_Length; - -end Ada.Strings.Bounded; diff --git a/gcc/ada/a-stream.adb b/gcc/ada/a-stream.adb deleted file mode 100644 index a22161d..0000000 --- a/gcc/ada/a-stream.adb +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; - -package body Ada.Streams is - - -------------- - -- Read_SEA -- - -------------- - - procedure Read_SEA - (S : access Root_Stream_Type'Class; - V : out Stream_Element_Array) - is - Last : Stream_Element_Offset; - - begin - Read (S.all, V, Last); - - if Last /= V'Last then - raise Ada.IO_Exceptions.End_Error; - end if; - end Read_SEA; - - --------------- - -- Write_SEA -- - --------------- - - procedure Write_SEA - (S : access Root_Stream_Type'Class; - V : Stream_Element_Array) - is - begin - Write (S.all, V); - end Write_SEA; - -end Ada.Streams; diff --git a/gcc/ada/a-stream.ads b/gcc/ada/a-stream.ads deleted file mode 100644 index f3aa008..0000000 --- a/gcc/ada/a-stream.ads +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Streams is - pragma Pure; - - type Root_Stream_Type is abstract tagged limited private; - pragma Preelaborable_Initialization (Root_Stream_Type); - - type Stream_Element is mod 2 ** Standard'Storage_Unit; - - type Stream_Element_Offset is new Long_Long_Integer; - -- Stream_Element_Offset needs 64 bits to accommodate large stream files. - -- However, rather than make this explicitly 64-bits we derive from - -- Long_Long_Integer. In normal usage this will have the same effect. - -- But in the case of CodePeer with a target configuration file with a - -- maximum integer size of 32, it allows analysis of this unit. - - subtype Stream_Element_Count is - Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; - - type Stream_Element_Array is - array (Stream_Element_Offset range <>) of aliased Stream_Element; - - procedure Read - (Stream : in out Root_Stream_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is abstract; - - procedure Write - (Stream : in out Root_Stream_Type; - Item : Stream_Element_Array) - is abstract; - -private - - type Root_Stream_Type is abstract tagged limited null record; - - -- Stream attributes for Stream_Element_Array: trivially call the - -- corresponding stream primitive for the whole array, instead of doing - -- so element by element. - - procedure Read_SEA - (S : access Root_Stream_Type'Class; - V : out Stream_Element_Array); - - procedure Write_SEA - (S : access Root_Stream_Type'Class; - V : Stream_Element_Array); - - for Stream_Element_Array'Read use Read_SEA; - for Stream_Element_Array'Write use Write_SEA; - -end Ada.Streams; diff --git a/gcc/ada/a-strfix.adb b/gcc/ada/a-strfix.adb deleted file mode 100644 index 0f24f5a..0000000 --- a/gcc/ada/a-strfix.adb +++ /dev/null @@ -1,747 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . F I X E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: This code is derived from the ADAR.CSH public domain Ada 83 versions --- of the Appendix C string handling packages. One change is to avoid the use --- of Is_In, so that we are not dependent on inlining. Note that the search --- function implementations are to be found in the auxiliary package --- Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR --- used a subunit for this procedure). The number of errors having to do with --- bounds of function return results were also fixed, and use of & removed for --- efficiency reasons. - -with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Strings.Search; - -package body Ada.Strings.Fixed is - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - renames Ada.Strings.Search.Index; - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - renames Ada.Strings.Search.Index; - - function Index - (Source : String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Ada.Strings.Search.Index; - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - renames Ada.Strings.Search.Index; - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - renames Ada.Strings.Search.Index; - - function Index - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Ada.Strings.Search.Index; - - function Index_Non_Blank - (Source : String; - Going : Direction := Forward) return Natural - renames Ada.Strings.Search.Index_Non_Blank; - - function Index_Non_Blank - (Source : String; - From : Positive; - Going : Direction := Forward) return Natural - renames Ada.Strings.Search.Index_Non_Blank; - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - renames Ada.Strings.Search.Count; - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural - renames Ada.Strings.Search.Count; - - function Count - (Source : String; - Set : Maps.Character_Set) return Natural - renames Ada.Strings.Search.Count; - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Ada.Strings.Search.Find_Token; - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Ada.Strings.Search.Find_Token; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Character) return String - is - Result : String (1 .. Left); - - begin - for J in Result'Range loop - Result (J) := Right; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : String) return String - is - Result : String (1 .. Left * Right'Length); - Ptr : Integer := 1; - - begin - for J in 1 .. Left loop - Result (Ptr .. Ptr + Right'Length - 1) := Right; - Ptr := Ptr + Right'Length; - end loop; - - return Result; - end "*"; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : String; - From : Positive; - Through : Natural) return String - is - begin - if From > Through then - declare - subtype Result_Type is String (1 .. Source'Length); - - begin - return Result_Type (Source); - end; - - elsif From not in Source'Range - or else Through > Source'Last - then - raise Index_Error; - - else - declare - Front : constant Integer := From - Source'First; - Result : String (1 .. Source'Length - (Through - From + 1)); - - begin - Result (1 .. Front) := - Source (Source'First .. From - 1); - Result (Front + 1 .. Result'Last) := - Source (Through + 1 .. Source'Last); - - return Result; - end; - end if; - end Delete; - - procedure Delete - (Source : in out String; - From : Positive; - Through : Natural; - Justify : Alignment := Left; - Pad : Character := Space) - is - begin - Move (Source => Delete (Source, From, Through), - Target => Source, - Justify => Justify, - Pad => Pad); - end Delete; - - ---------- - -- Head -- - ---------- - - function Head - (Source : String; - Count : Natural; - Pad : Character := Space) return String - is - subtype Result_Type is String (1 .. Count); - - begin - if Count < Source'Length then - return - Result_Type (Source (Source'First .. Source'First + Count - 1)); - - else - declare - Result : Result_Type; - - begin - Result (1 .. Source'Length) := Source; - - for J in Source'Length + 1 .. Count loop - Result (J) := Pad; - end loop; - - return Result; - end; - end if; - end Head; - - procedure Head - (Source : in out String; - Count : Natural; - Justify : Alignment := Left; - Pad : Character := Space) - is - begin - Move (Source => Head (Source, Count, Pad), - Target => Source, - Drop => Error, - Justify => Justify, - Pad => Pad); - end Head; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : String; - Before : Positive; - New_Item : String) return String - is - Result : String (1 .. Source'Length + New_Item'Length); - Front : constant Integer := Before - Source'First; - - begin - if Before not in Source'First .. Source'Last + 1 then - raise Index_Error; - end if; - - Result (1 .. Front) := - Source (Source'First .. Before - 1); - Result (Front + 1 .. Front + New_Item'Length) := - New_Item; - Result (Front + New_Item'Length + 1 .. Result'Last) := - Source (Before .. Source'Last); - - return Result; - end Insert; - - procedure Insert - (Source : in out String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error) - is - begin - Move (Source => Insert (Source, Before, New_Item), - Target => Source, - Drop => Drop); - end Insert; - - ---------- - -- Move -- - ---------- - - procedure Move - (Source : String; - Target : out String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Character := Space) - is - Sfirst : constant Integer := Source'First; - Slast : constant Integer := Source'Last; - Slength : constant Integer := Source'Length; - - Tfirst : constant Integer := Target'First; - Tlast : constant Integer := Target'Last; - Tlength : constant Integer := Target'Length; - - function Is_Padding (Item : String) return Boolean; - -- Check if Item is all Pad characters, return True if so, False if not - - function Is_Padding (Item : String) return Boolean is - begin - for J in Item'Range loop - if Item (J) /= Pad then - return False; - end if; - end loop; - - return True; - end Is_Padding; - - -- Start of processing for Move - - begin - if Slength = Tlength then - Target := Source; - - elsif Slength > Tlength then - case Drop is - when Left => - Target := Source (Slast - Tlength + 1 .. Slast); - - when Right => - Target := Source (Sfirst .. Sfirst + Tlength - 1); - - when Error => - case Justify is - when Left => - if Is_Padding (Source (Sfirst + Tlength .. Slast)) then - Target := - Source (Sfirst .. Sfirst + Target'Length - 1); - else - raise Length_Error; - end if; - - when Right => - if Is_Padding (Source (Sfirst .. Slast - Tlength)) then - Target := Source (Slast - Tlength + 1 .. Slast); - else - raise Length_Error; - end if; - - when Center => - raise Length_Error; - end case; - end case; - - -- Source'Length < Target'Length - - else - case Justify is - when Left => - Target (Tfirst .. Tfirst + Slength - 1) := Source; - - for I in Tfirst + Slength .. Tlast loop - Target (I) := Pad; - end loop; - - when Right => - for I in Tfirst .. Tlast - Slength loop - Target (I) := Pad; - end loop; - - Target (Tlast - Slength + 1 .. Tlast) := Source; - - when Center => - declare - Front_Pad : constant Integer := (Tlength - Slength) / 2; - Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; - - begin - for I in Tfirst .. Tfirst_Fpad - 1 loop - Target (I) := Pad; - end loop; - - Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; - - for I in Tfirst_Fpad + Slength .. Tlast loop - Target (I) := Pad; - end loop; - end; - end case; - end if; - end Move; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : String; - Position : Positive; - New_Item : String) return String - is - begin - if Position not in Source'First .. Source'Last + 1 then - raise Index_Error; - end if; - - declare - Result_Length : constant Natural := - Integer'Max - (Source'Length, - Position - Source'First + New_Item'Length); - - Result : String (1 .. Result_Length); - Front : constant Integer := Position - Source'First; - - begin - Result (1 .. Front) := - Source (Source'First .. Position - 1); - Result (Front + 1 .. Front + New_Item'Length) := - New_Item; - Result (Front + New_Item'Length + 1 .. Result'Length) := - Source (Position + New_Item'Length .. Source'Last); - return Result; - end; - end Overwrite; - - procedure Overwrite - (Source : in out String; - Position : Positive; - New_Item : String; - Drop : Truncation := Right) - is - begin - Move (Source => Overwrite (Source, Position, New_Item), - Target => Source, - Drop => Drop); - end Overwrite; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : String; - Low : Positive; - High : Natural; - By : String) return String - is - begin - if Low > Source'Last + 1 or else High < Source'First - 1 then - raise Index_Error; - end if; - - if High >= Low then - declare - Front_Len : constant Integer := - Integer'Max (0, Low - Source'First); - -- Length of prefix of Source copied to result - - Back_Len : constant Integer := - Integer'Max (0, Source'Last - High); - -- Length of suffix of Source copied to result - - Result_Length : constant Integer := - Front_Len + By'Length + Back_Len; - -- Length of result - - Result : String (1 .. Result_Length); - - begin - Result (1 .. Front_Len) := Source (Source'First .. Low - 1); - Result (Front_Len + 1 .. Front_Len + By'Length) := By; - Result (Front_Len + By'Length + 1 .. Result'Length) := - Source (High + 1 .. Source'Last); - return Result; - end; - - else - return Insert (Source, Before => Low, New_Item => By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Character := Space) - is - begin - Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); - end Replace_Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : String; - Count : Natural; - Pad : Character := Space) return String - is - subtype Result_Type is String (1 .. Count); - - begin - if Count < Source'Length then - return Result_Type (Source (Source'Last - Count + 1 .. Source'Last)); - - -- Pad on left - - else - declare - Result : Result_Type; - - begin - for J in 1 .. Count - Source'Length loop - Result (J) := Pad; - end loop; - - Result (Count - Source'Length + 1 .. Count) := Source; - return Result; - end; - end if; - end Tail; - - procedure Tail - (Source : in out String; - Count : Natural; - Justify : Alignment := Left; - Pad : Character := Space) - is - begin - Move (Source => Tail (Source, Count, Pad), - Target => Source, - Drop => Error, - Justify => Justify, - Pad => Pad); - end Tail; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : String; - Mapping : Maps.Character_Mapping) return String - is - Result : String (1 .. Source'Length); - - begin - for J in Source'Range loop - Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out String; - Mapping : Maps.Character_Mapping) - is - begin - for J in Source'Range loop - Source (J) := Value (Mapping, Source (J)); - end loop; - end Translate; - - function Translate - (Source : String; - Mapping : Maps.Character_Mapping_Function) return String - is - Result : String (1 .. Source'Length); - pragma Unsuppress (Access_Check); - - begin - for J in Source'Range loop - Result (J - (Source'First - 1)) := Mapping.all (Source (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out String; - Mapping : Maps.Character_Mapping_Function) - is - pragma Unsuppress (Access_Check); - begin - for J in Source'Range loop - Source (J) := Mapping.all (Source (J)); - end loop; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : String; - Side : Trim_End) return String - is - begin - case Side is - when Strings.Left => - declare - Low : constant Natural := Index_Non_Blank (Source, Forward); - begin - -- All blanks case - - if Low = 0 then - return ""; - end if; - - declare - subtype Result_Type is String (1 .. Source'Last - Low + 1); - begin - return Result_Type (Source (Low .. Source'Last)); - end; - end; - - when Strings.Right => - declare - High : constant Natural := Index_Non_Blank (Source, Backward); - begin - -- All blanks case - - if High = 0 then - return ""; - end if; - - declare - subtype Result_Type is String (1 .. High - Source'First + 1); - begin - return Result_Type (Source (Source'First .. High)); - end; - end; - - when Strings.Both => - declare - Low : constant Natural := Index_Non_Blank (Source, Forward); - begin - -- All blanks case - - if Low = 0 then - return ""; - end if; - - declare - High : constant Natural := - Index_Non_Blank (Source, Backward); - subtype Result_Type is String (1 .. High - Low + 1); - begin - return Result_Type (Source (Low .. High)); - end; - end; - end case; - end Trim; - - procedure Trim - (Source : in out String; - Side : Trim_End; - Justify : Alignment := Left; - Pad : Character := Space) - is - begin - Move (Trim (Source, Side), - Source, - Justify => Justify, - Pad => Pad); - end Trim; - - function Trim - (Source : String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return String - is - High, Low : Integer; - - begin - Low := Index (Source, Set => Left, Test => Outside, Going => Forward); - - -- Case where source comprises only characters in Left - - if Low = 0 then - return ""; - end if; - - High := - Index (Source, Set => Right, Test => Outside, Going => Backward); - - -- Case where source comprises only characters in Right - - if High = 0 then - return ""; - end if; - - declare - subtype Result_Type is String (1 .. High - Low + 1); - - begin - return Result_Type (Source (Low .. High)); - end; - end Trim; - - procedure Trim - (Source : in out String; - Left : Maps.Character_Set; - Right : Maps.Character_Set; - Justify : Alignment := Strings.Left; - Pad : Character := Space) - is - begin - Move (Source => Trim (Source, Left, Right), - Target => Source, - Justify => Justify, - Pad => Pad); - end Trim; - -end Ada.Strings.Fixed; diff --git a/gcc/ada/a-strfix.ads b/gcc/ada/a-strfix.ads deleted file mode 100644 index 56db8bc..0000000 --- a/gcc/ada/a-strfix.ads +++ /dev/null @@ -1,251 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . F I X E D -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Maps; - -package Ada.Strings.Fixed is - pragma Preelaborate; - - -------------------------------------------------------------- - -- Copy Procedure for Strings of Possibly Different Lengths -- - -------------------------------------------------------------- - - procedure Move - (Source : String; - Target : out String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Character := Space); - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Index - (Source : String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Count - (Source : String; - Set : Maps.Character_Set) return Natural; - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : String; - Mapping : Maps.Character_Mapping) return String; - - procedure Translate - (Source : in out String; - Mapping : Maps.Character_Mapping); - - function Translate - (Source : String; - Mapping : Maps.Character_Mapping_Function) return String; - - procedure Translate - (Source : in out String; - Mapping : Maps.Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : String; - Low : Positive; - High : Natural; - By : String) return String; - - procedure Replace_Slice - (Source : in out String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Character := Space); - - function Insert - (Source : String; - Before : Positive; - New_Item : String) return String; - - procedure Insert - (Source : in out String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error); - - function Overwrite - (Source : String; - Position : Positive; - New_Item : String) return String; - - procedure Overwrite - (Source : in out String; - Position : Positive; - New_Item : String; - Drop : Truncation := Right); - - function Delete - (Source : String; - From : Positive; - Through : Natural) return String; - - procedure Delete - (Source : in out String; - From : Positive; - Through : Natural; - Justify : Alignment := Left; - Pad : Character := Space); - - --------------------------------- - -- String Selector Subprograms -- - --------------------------------- - - function Trim - (Source : String; - Side : Trim_End) return String; - - procedure Trim - (Source : in out String; - Side : Trim_End; - Justify : Alignment := Left; - Pad : Character := Space); - - function Trim - (Source : String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return String; - - procedure Trim - (Source : in out String; - Left : Maps.Character_Set; - Right : Maps.Character_Set; - Justify : Alignment := Strings.Left; - Pad : Character := Space); - - function Head - (Source : String; - Count : Natural; - Pad : Character := Space) return String; - - procedure Head - (Source : in out String; - Count : Natural; - Justify : Alignment := Left; - Pad : Character := Space); - - function Tail - (Source : String; - Count : Natural; - Pad : Character := Space) return String; - - procedure Tail - (Source : in out String; - Count : Natural; - Justify : Alignment := Left; - Pad : Character := Space); - - ---------------------------------- - -- String Constructor Functions -- - ---------------------------------- - - function "*" - (Left : Natural; - Right : Character) return String; - - function "*" - (Left : Natural; - Right : String) return String; - -end Ada.Strings.Fixed; diff --git a/gcc/ada/a-strhas.adb b/gcc/ada/a-strhas.adb deleted file mode 100644 index f0ee060..0000000 --- a/gcc/ada/a-strhas.adb +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Hash (Key : String) return Containers.Hash_Type is - use Ada.Containers; - function Hash is new System.String_Hash.Hash - (Character, String, Hash_Type); -begin - return Hash (Key); -end Ada.Strings.Hash; diff --git a/gcc/ada/a-strhas.ads b/gcc/ada/a-strhas.ads deleted file mode 100644 index 2411a52..0000000 --- a/gcc/ada/a-strhas.ads +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Containers; - -function Ada.Strings.Hash (Key : String) return Containers.Hash_Type; --- Note: this hash function has predictable collisions and is subject to --- equivalent substring attacks. It is not suitable for construction of a --- hash table keyed on possibly malicious user input. - -pragma Pure (Ada.Strings.Hash); diff --git a/gcc/ada/a-string.ads b/gcc/ada/a-string.ads deleted file mode 100644 index 51ca102..0000000 --- a/gcc/ada/a-string.ads +++ /dev/null @@ -1,35 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Strings is - pragma Pure; - - Space : constant Character := ' '; - Wide_Space : constant Wide_Character := ' '; - - -- The following declaration is for Ada 2005 (AI-285) - - Wide_Wide_Space : constant Wide_Wide_Character := ' '; - pragma Ada_05 (Wide_Wide_Space); - - Length_Error, Pattern_Error, Index_Error, Translation_Error : exception; - - type Alignment is (Left, Right, Center); - type Truncation is (Left, Right, Error); - type Membership is (Inside, Outside); - type Direction is (Forward, Backward); - type Trim_End is (Left, Right, Both); - -end Ada.Strings; diff --git a/gcc/ada/a-strmap.adb b/gcc/ada/a-strmap.adb deleted file mode 100644 index 071c02a..0000000 --- a/gcc/ada/a-strmap.adb +++ /dev/null @@ -1,322 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: parts of this code are derived from the ADAR.CSH public domain --- Ada 83 versions of the Appendix C string handling packages. The main --- differences are that we avoid the use of the minimize function which --- is bit-by-bit or character-by-character and therefore rather slow. --- Generally for character sets we favor the full 32-byte representation. - -package body Ada.Strings.Maps is - - use Ada.Characters.Latin_1; - - --------- - -- "-" -- - --------- - - function "-" (Left, Right : Character_Set) return Character_Set is - begin - return Left and not Right; - end "-"; - - --------- - -- "=" -- - --------- - - function "=" (Left, Right : Character_Set) return Boolean is - begin - return Character_Set_Internal (Left) = Character_Set_Internal (Right); - end "="; - - ----------- - -- "and" -- - ----------- - - function "and" (Left, Right : Character_Set) return Character_Set is - begin - return Character_Set - (Character_Set_Internal (Left) and Character_Set_Internal (Right)); - end "and"; - - ----------- - -- "not" -- - ----------- - - function "not" (Right : Character_Set) return Character_Set is - begin - return Character_Set (not Character_Set_Internal (Right)); - end "not"; - - ---------- - -- "or" -- - ---------- - - function "or" (Left, Right : Character_Set) return Character_Set is - begin - return Character_Set - (Character_Set_Internal (Left) or Character_Set_Internal (Right)); - end "or"; - - ----------- - -- "xor" -- - ----------- - - function "xor" (Left, Right : Character_Set) return Character_Set is - begin - return Character_Set - (Character_Set_Internal (Left) xor Character_Set_Internal (Right)); - end "xor"; - - ----------- - -- Is_In -- - ----------- - - function Is_In - (Element : Character; - Set : Character_Set) return Boolean - is - begin - return Set (Element); - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset - (Elements : Character_Set; - Set : Character_Set) return Boolean - is - begin - return (Elements and Set) = Elements; - end Is_Subset; - - --------------- - -- To_Domain -- - --------------- - - function To_Domain (Map : Character_Mapping) return Character_Sequence - is - Result : String (1 .. Map'Length); - J : Natural; - - begin - J := 0; - for C in Map'Range loop - if Map (C) /= C then - J := J + 1; - Result (J) := C; - end if; - end loop; - - return Result (1 .. J); - end To_Domain; - - ---------------- - -- To_Mapping -- - ---------------- - - function To_Mapping - (From, To : Character_Sequence) return Character_Mapping - is - Result : Character_Mapping; - Inserted : Character_Set := Null_Set; - From_Len : constant Natural := From'Length; - To_Len : constant Natural := To'Length; - - begin - if From_Len /= To_Len then - raise Strings.Translation_Error; - end if; - - for Char in Character loop - Result (Char) := Char; - end loop; - - for J in From'Range loop - if Inserted (From (J)) then - raise Strings.Translation_Error; - end if; - - Result (From (J)) := To (J - From'First + To'First); - Inserted (From (J)) := True; - end loop; - - return Result; - end To_Mapping; - - -------------- - -- To_Range -- - -------------- - - function To_Range (Map : Character_Mapping) return Character_Sequence - is - Result : String (1 .. Map'Length); - J : Natural; - begin - J := 0; - for C in Map'Range loop - if Map (C) /= C then - J := J + 1; - Result (J) := Map (C); - end if; - end loop; - - return Result (1 .. J); - end To_Range; - - --------------- - -- To_Ranges -- - --------------- - - function To_Ranges (Set : Character_Set) return Character_Ranges is - Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1); - Range_Num : Natural; - C : Character; - - begin - C := Character'First; - Range_Num := 0; - - loop - -- Skip gap between subsets - - while not Set (C) loop - exit when C = Character'Last; - C := Character'Succ (C); - end loop; - - exit when not Set (C); - - Range_Num := Range_Num + 1; - Max_Ranges (Range_Num).Low := C; - - -- Span a subset - - loop - exit when not Set (C) or else C = Character'Last; - C := Character'Succ (C); - end loop; - - if Set (C) then - Max_Ranges (Range_Num). High := C; - exit; - else - Max_Ranges (Range_Num). High := Character'Pred (C); - end if; - end loop; - - return Max_Ranges (1 .. Range_Num); - end To_Ranges; - - ----------------- - -- To_Sequence -- - ----------------- - - function To_Sequence (Set : Character_Set) return Character_Sequence is - Result : String (1 .. Character'Pos (Character'Last) + 1); - Count : Natural := 0; - begin - for Char in Set'Range loop - if Set (Char) then - Count := Count + 1; - Result (Count) := Char; - end if; - end loop; - - return Result (1 .. Count); - end To_Sequence; - - ------------ - -- To_Set -- - ------------ - - function To_Set (Ranges : Character_Ranges) return Character_Set is - Result : Character_Set; - begin - for C in Result'Range loop - Result (C) := False; - end loop; - - for R in Ranges'Range loop - for C in Ranges (R).Low .. Ranges (R).High loop - Result (C) := True; - end loop; - end loop; - - return Result; - end To_Set; - - function To_Set (Span : Character_Range) return Character_Set is - Result : Character_Set; - begin - for C in Result'Range loop - Result (C) := False; - end loop; - - for C in Span.Low .. Span.High loop - Result (C) := True; - end loop; - - return Result; - end To_Set; - - function To_Set (Sequence : Character_Sequence) return Character_Set is - Result : Character_Set := Null_Set; - begin - for J in Sequence'Range loop - Result (Sequence (J)) := True; - end loop; - - return Result; - end To_Set; - - function To_Set (Singleton : Character) return Character_Set is - Result : Character_Set := Null_Set; - begin - Result (Singleton) := True; - return Result; - end To_Set; - - ----------- - -- Value -- - ----------- - - function Value - (Map : Character_Mapping; - Element : Character) return Character - is - begin - return Map (Element); - end Value; - -end Ada.Strings.Maps; diff --git a/gcc/ada/a-strmap.ads b/gcc/ada/a-strmap.ads deleted file mode 100644 index a882e9c..0000000 --- a/gcc/ada/a-strmap.ads +++ /dev/null @@ -1,411 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Latin_1; - -package Ada.Strings.Maps is - pragma Pure; - -- In accordance with Ada 2005 AI-362 - - -------------------------------- - -- Character Set Declarations -- - -------------------------------- - - type Character_Set is private; - pragma Preelaborable_Initialization (Character_Set); - -- Representation for a set of character values: - - Null_Set : constant Character_Set; - - --------------------------- - -- Constructors for Sets -- - --------------------------- - - type Character_Range is record - Low : Character; - High : Character; - end record; - -- Represents Character range Low .. High - - type Character_Ranges is array (Positive range <>) of Character_Range; - - function To_Set (Ranges : Character_Ranges) return Character_Set; - - function To_Set (Span : Character_Range) return Character_Set; - - function To_Ranges (Set : Character_Set) return Character_Ranges; - - ---------------------------------- - -- Operations on Character Sets -- - ---------------------------------- - - function "=" (Left, Right : Character_Set) return Boolean; - - function "not" (Right : Character_Set) return Character_Set; - function "and" (Left, Right : Character_Set) return Character_Set; - function "or" (Left, Right : Character_Set) return Character_Set; - function "xor" (Left, Right : Character_Set) return Character_Set; - function "-" (Left, Right : Character_Set) return Character_Set; - - function Is_In - (Element : Character; - Set : Character_Set) return Boolean; - - function Is_Subset - (Elements : Character_Set; - Set : Character_Set) return Boolean; - - function "<=" - (Left : Character_Set; - Right : Character_Set) return Boolean - renames Is_Subset; - - subtype Character_Sequence is String; - -- Alternative representation for a set of character values - - function To_Set (Sequence : Character_Sequence) return Character_Set; - function To_Set (Singleton : Character) return Character_Set; - - function To_Sequence (Set : Character_Set) return Character_Sequence; - - ------------------------------------ - -- Character Mapping Declarations -- - ------------------------------------ - - type Character_Mapping is private; - pragma Preelaborable_Initialization (Character_Mapping); - -- Representation for a character to character mapping: - - function Value - (Map : Character_Mapping; - Element : Character) return Character; - - Identity : constant Character_Mapping; - - ---------------------------- - -- Operations on Mappings -- - ---------------------------- - - function To_Mapping - (From, To : Character_Sequence) return Character_Mapping; - - function To_Domain - (Map : Character_Mapping) return Character_Sequence; - - function To_Range - (Map : Character_Mapping) return Character_Sequence; - - type Character_Mapping_Function is - access function (From : Character) return Character; - -private - pragma Inline (Is_In); - pragma Inline (Value); - - type Character_Set_Internal is array (Character) of Boolean; - pragma Pack (Character_Set_Internal); - - type Character_Set is new Character_Set_Internal; - -- Note: the reason for this level of derivation is to make sure - -- that the predefined logical operations on this type remain - -- accessible. The operations on Character_Set are overridden by - -- the defined operations in the spec, but the operations defined - -- on Character_Set_Internal remain visible. - - Null_Set : constant Character_Set := (others => False); - - type Character_Mapping is array (Character) of Character; - - package L renames Ada.Characters.Latin_1; - - Identity : constant Character_Mapping := - (L.NUL & -- NUL 0 - L.SOH & -- SOH 1 - L.STX & -- STX 2 - L.ETX & -- ETX 3 - L.EOT & -- EOT 4 - L.ENQ & -- ENQ 5 - L.ACK & -- ACK 6 - L.BEL & -- BEL 7 - L.BS & -- BS 8 - L.HT & -- HT 9 - L.LF & -- LF 10 - L.VT & -- VT 11 - L.FF & -- FF 12 - L.CR & -- CR 13 - L.SO & -- SO 14 - L.SI & -- SI 15 - L.DLE & -- DLE 16 - L.DC1 & -- DC1 17 - L.DC2 & -- DC2 18 - L.DC3 & -- DC3 19 - L.DC4 & -- DC4 20 - L.NAK & -- NAK 21 - L.SYN & -- SYN 22 - L.ETB & -- ETB 23 - L.CAN & -- CAN 24 - L.EM & -- EM 25 - L.SUB & -- SUB 26 - L.ESC & -- ESC 27 - L.FS & -- FS 28 - L.GS & -- GS 29 - L.RS & -- RS 30 - L.US & -- US 31 - L.Space & -- ' ' 32 - L.Exclamation & -- '!' 33 - L.Quotation & -- '"' 34 - L.Number_Sign & -- '#' 35 - L.Dollar_Sign & -- '$' 36 - L.Percent_Sign & -- '%' 37 - L.Ampersand & -- '&' 38 - L.Apostrophe & -- ''' 39 - L.Left_Parenthesis & -- '(' 40 - L.Right_Parenthesis & -- ')' 41 - L.Asterisk & -- '*' 42 - L.Plus_Sign & -- '+' 43 - L.Comma & -- ',' 44 - L.Hyphen & -- '-' 45 - L.Full_Stop & -- '.' 46 - L.Solidus & -- '/' 47 - '0' & -- '0' 48 - '1' & -- '1' 49 - '2' & -- '2' 50 - '3' & -- '3' 51 - '4' & -- '4' 52 - '5' & -- '5' 53 - '6' & -- '6' 54 - '7' & -- '7' 55 - '8' & -- '8' 56 - '9' & -- '9' 57 - L.Colon & -- ':' 58 - L.Semicolon & -- ';' 59 - L.Less_Than_Sign & -- '<' 60 - L.Equals_Sign & -- '=' 61 - L.Greater_Than_Sign & -- '>' 62 - L.Question & -- '?' 63 - L.Commercial_At & -- '@' 64 - 'A' & -- 'A' 65 - 'B' & -- 'B' 66 - 'C' & -- 'C' 67 - 'D' & -- 'D' 68 - 'E' & -- 'E' 69 - 'F' & -- 'F' 70 - 'G' & -- 'G' 71 - 'H' & -- 'H' 72 - 'I' & -- 'I' 73 - 'J' & -- 'J' 74 - 'K' & -- 'K' 75 - 'L' & -- 'L' 76 - 'M' & -- 'M' 77 - 'N' & -- 'N' 78 - 'O' & -- 'O' 79 - 'P' & -- 'P' 80 - 'Q' & -- 'Q' 81 - 'R' & -- 'R' 82 - 'S' & -- 'S' 83 - 'T' & -- 'T' 84 - 'U' & -- 'U' 85 - 'V' & -- 'V' 86 - 'W' & -- 'W' 87 - 'X' & -- 'X' 88 - 'Y' & -- 'Y' 89 - 'Z' & -- 'Z' 90 - L.Left_Square_Bracket & -- '[' 91 - L.Reverse_Solidus & -- '\' 92 - L.Right_Square_Bracket & -- ']' 93 - L.Circumflex & -- '^' 94 - L.Low_Line & -- '_' 95 - L.Grave & -- '`' 96 - L.LC_A & -- 'a' 97 - L.LC_B & -- 'b' 98 - L.LC_C & -- 'c' 99 - L.LC_D & -- 'd' 100 - L.LC_E & -- 'e' 101 - L.LC_F & -- 'f' 102 - L.LC_G & -- 'g' 103 - L.LC_H & -- 'h' 104 - L.LC_I & -- 'i' 105 - L.LC_J & -- 'j' 106 - L.LC_K & -- 'k' 107 - L.LC_L & -- 'l' 108 - L.LC_M & -- 'm' 109 - L.LC_N & -- 'n' 110 - L.LC_O & -- 'o' 111 - L.LC_P & -- 'p' 112 - L.LC_Q & -- 'q' 113 - L.LC_R & -- 'r' 114 - L.LC_S & -- 's' 115 - L.LC_T & -- 't' 116 - L.LC_U & -- 'u' 117 - L.LC_V & -- 'v' 118 - L.LC_W & -- 'w' 119 - L.LC_X & -- 'x' 120 - L.LC_Y & -- 'y' 121 - L.LC_Z & -- 'z' 122 - L.Left_Curly_Bracket & -- '{' 123 - L.Vertical_Line & -- '|' 124 - L.Right_Curly_Bracket & -- '}' 125 - L.Tilde & -- '~' 126 - L.DEL & -- DEL 127 - L.Reserved_128 & -- Reserved_128 128 - L.Reserved_129 & -- Reserved_129 129 - L.BPH & -- BPH 130 - L.NBH & -- NBH 131 - L.Reserved_132 & -- Reserved_132 132 - L.NEL & -- NEL 133 - L.SSA & -- SSA 134 - L.ESA & -- ESA 135 - L.HTS & -- HTS 136 - L.HTJ & -- HTJ 137 - L.VTS & -- VTS 138 - L.PLD & -- PLD 139 - L.PLU & -- PLU 140 - L.RI & -- RI 141 - L.SS2 & -- SS2 142 - L.SS3 & -- SS3 143 - L.DCS & -- DCS 144 - L.PU1 & -- PU1 145 - L.PU2 & -- PU2 146 - L.STS & -- STS 147 - L.CCH & -- CCH 148 - L.MW & -- MW 149 - L.SPA & -- SPA 150 - L.EPA & -- EPA 151 - L.SOS & -- SOS 152 - L.Reserved_153 & -- Reserved_153 153 - L.SCI & -- SCI 154 - L.CSI & -- CSI 155 - L.ST & -- ST 156 - L.OSC & -- OSC 157 - L.PM & -- PM 158 - L.APC & -- APC 159 - L.No_Break_Space & -- No_Break_Space 160 - L.Inverted_Exclamation & -- Inverted_Exclamation 161 - L.Cent_Sign & -- Cent_Sign 162 - L.Pound_Sign & -- Pound_Sign 163 - L.Currency_Sign & -- Currency_Sign 164 - L.Yen_Sign & -- Yen_Sign 165 - L.Broken_Bar & -- Broken_Bar 166 - L.Section_Sign & -- Section_Sign 167 - L.Diaeresis & -- Diaeresis 168 - L.Copyright_Sign & -- Copyright_Sign 169 - L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 - L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 - L.Not_Sign & -- Not_Sign 172 - L.Soft_Hyphen & -- Soft_Hyphen 173 - L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 - L.Macron & -- Macron 175 - L.Degree_Sign & -- Degree_Sign 176 - L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 - L.Superscript_Two & -- Superscript_Two 178 - L.Superscript_Three & -- Superscript_Three 179 - L.Acute & -- Acute 180 - L.Micro_Sign & -- Micro_Sign 181 - L.Pilcrow_Sign & -- Pilcrow_Sign 182 - L.Middle_Dot & -- Middle_Dot 183 - L.Cedilla & -- Cedilla 184 - L.Superscript_One & -- Superscript_One 185 - L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 - L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 - L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 - L.Fraction_One_Half & -- Fraction_One_Half 189 - L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 - L.Inverted_Question & -- Inverted_Question 191 - L.UC_A_Grave & -- UC_A_Grave 192 - L.UC_A_Acute & -- UC_A_Acute 193 - L.UC_A_Circumflex & -- UC_A_Circumflex 194 - L.UC_A_Tilde & -- UC_A_Tilde 195 - L.UC_A_Diaeresis & -- UC_A_Diaeresis 196 - L.UC_A_Ring & -- UC_A_Ring 197 - L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 - L.UC_C_Cedilla & -- UC_C_Cedilla 199 - L.UC_E_Grave & -- UC_E_Grave 200 - L.UC_E_Acute & -- UC_E_Acute 201 - L.UC_E_Circumflex & -- UC_E_Circumflex 202 - L.UC_E_Diaeresis & -- UC_E_Diaeresis 203 - L.UC_I_Grave & -- UC_I_Grave 204 - L.UC_I_Acute & -- UC_I_Acute 205 - L.UC_I_Circumflex & -- UC_I_Circumflex 206 - L.UC_I_Diaeresis & -- UC_I_Diaeresis 207 - L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 - L.UC_N_Tilde & -- UC_N_Tilde 209 - L.UC_O_Grave & -- UC_O_Grave 210 - L.UC_O_Acute & -- UC_O_Acute 211 - L.UC_O_Circumflex & -- UC_O_Circumflex 212 - L.UC_O_Tilde & -- UC_O_Tilde 213 - L.UC_O_Diaeresis & -- UC_O_Diaeresis 214 - L.Multiplication_Sign & -- Multiplication_Sign 215 - L.UC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 - L.UC_U_Grave & -- UC_U_Grave 217 - L.UC_U_Acute & -- UC_U_Acute 218 - L.UC_U_Circumflex & -- UC_U_Circumflex 219 - L.UC_U_Diaeresis & -- UC_U_Diaeresis 220 - L.UC_Y_Acute & -- UC_Y_Acute 221 - L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 - L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 - L.LC_A_Grave & -- LC_A_Grave 224 - L.LC_A_Acute & -- LC_A_Acute 225 - L.LC_A_Circumflex & -- LC_A_Circumflex 226 - L.LC_A_Tilde & -- LC_A_Tilde 227 - L.LC_A_Diaeresis & -- LC_A_Diaeresis 228 - L.LC_A_Ring & -- LC_A_Ring 229 - L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 - L.LC_C_Cedilla & -- LC_C_Cedilla 231 - L.LC_E_Grave & -- LC_E_Grave 232 - L.LC_E_Acute & -- LC_E_Acute 233 - L.LC_E_Circumflex & -- LC_E_Circumflex 234 - L.LC_E_Diaeresis & -- LC_E_Diaeresis 235 - L.LC_I_Grave & -- LC_I_Grave 236 - L.LC_I_Acute & -- LC_I_Acute 237 - L.LC_I_Circumflex & -- LC_I_Circumflex 238 - L.LC_I_Diaeresis & -- LC_I_Diaeresis 239 - L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 - L.LC_N_Tilde & -- LC_N_Tilde 241 - L.LC_O_Grave & -- LC_O_Grave 242 - L.LC_O_Acute & -- LC_O_Acute 243 - L.LC_O_Circumflex & -- LC_O_Circumflex 244 - L.LC_O_Tilde & -- LC_O_Tilde 245 - L.LC_O_Diaeresis & -- LC_O_Diaeresis 246 - L.Division_Sign & -- Division_Sign 247 - L.LC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 - L.LC_U_Grave & -- LC_U_Grave 249 - L.LC_U_Acute & -- LC_U_Acute 250 - L.LC_U_Circumflex & -- LC_U_Circumflex 251 - L.LC_U_Diaeresis & -- LC_U_Diaeresis 252 - L.LC_Y_Acute & -- LC_Y_Acute 253 - L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 - L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 - -end Ada.Strings.Maps; diff --git a/gcc/ada/a-strsea.adb b/gcc/ada/a-strsea.adb deleted file mode 100644 index df267c1..0000000 --- a/gcc/ada/a-strsea.adb +++ /dev/null @@ -1,645 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . S E A R C H -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: This code is derived from the ADAR.CSH public domain Ada 83 --- versions of the Appendix C string handling packages (code extracted --- from Ada.Strings.Fixed). A significant change is that we optimize the --- case of identity mappings for Count and Index, and also Index_Non_Blank --- is specialized (rather than using the general Index routine). - -with Ada.Strings.Maps; use Ada.Strings.Maps; -with System; use System; - -package body Ada.Strings.Search is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Belongs - (Element : Character; - Set : Maps.Character_Set; - Test : Membership) return Boolean; - pragma Inline (Belongs); - -- Determines if the given element is in (Test = Inside) or not in - -- (Test = Outside) the given character set. - - ------------- - -- Belongs -- - ------------- - - function Belongs - (Element : Character; - Set : Maps.Character_Set; - Test : Membership) return Boolean - is - begin - if Test = Inside then - return Is_In (Element, Set); - else - return not Is_In (Element, Set); - end if; - end Belongs; - - ----------- - -- Count -- - ----------- - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Num : Natural; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - Num := 0; - Ind := Source'First; - - -- Unmapped case - - if Mapping'Address = Maps.Identity'Address then - while Ind <= Source'Last - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - Num := Num + 1; - Ind := Ind + Pattern'Length; - else - Ind := Ind + 1; - end if; - end loop; - - -- Mapped case - - else - while Ind <= Source'Last - PL1 loop - Cur := Ind; - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - Ind := Ind + 1; - goto Cont; - else - Cur := Cur + 1; - end if; - end loop; - - Num := Num + 1; - Ind := Ind + Pattern'Length; - - <> - null; - end loop; - end if; - - -- Return result - - return Num; - end Count; - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Num : Natural; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Check for null pointer in case checks are off - - if Mapping = null then - raise Constraint_Error; - end if; - - Num := 0; - Ind := Source'First; - while Ind <= Source'Last - PL1 loop - Cur := Ind; - for K in Pattern'Range loop - if Pattern (K) /= Mapping (Source (Cur)) then - Ind := Ind + 1; - goto Cont; - else - Cur := Cur + 1; - end if; - end loop; - - Num := Num + 1; - Ind := Ind + Pattern'Length; - - <> - null; - end loop; - - return Num; - end Count; - - function Count - (Source : String; - Set : Maps.Character_Set) return Natural - is - N : Natural := 0; - - begin - for J in Source'Range loop - if Is_In (Source (J), Set) then - N := N + 1; - end if; - end loop; - - return N; - end Count; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - is - begin - -- AI05-031: Raise Index error if Source non-empty and From not in range - - if Source'Length /= 0 and then From not in Source'Range then - raise Index_Error; - end if; - - -- If Source is the empty string, From may still be out of its - -- range. The following ensures that in all cases there is no - -- possible erroneous access to a non-existing character. - - for J in Integer'Max (From, Source'First) .. Source'Last loop - if Belongs (Source (J), Set, Test) then - First := J; - - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; - - -- Here if J indexes first char of token, and all chars after J - -- are in the token. - - Last := Source'Last; - return; - end if; - end loop; - - -- Here if no token found - - First := From; - Last := 0; - end Find_Token; - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - is - begin - for J in Source'Range loop - if Belongs (Source (J), Set, Test) then - First := J; - - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; - - -- Here if J indexes first char of token, and all chars after J - -- are in the token. - - Last := Source'Last; - return; - end if; - end loop; - - -- Here if no token found - - -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if - -- Source'First is not positive and is assigned to First. Formulation - -- is slightly different in RM 2012, but the intent seems similar, so - -- we check explicitly for that condition. - - if Source'First not in Positive then - raise Constraint_Error; - - else - First := Source'First; - Last := 0; - end if; - end Find_Token; - - ----------- - -- Index -- - ----------- - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Cur : Natural; - - Ind : Integer; - -- Index for start of match check. This can be negative if the pattern - -- length is greater than the string length, which is why this variable - -- is Integer instead of Natural. In this case, the search loops do not - -- execute at all, so this Ind value is never used. - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Forwards case - - if Going = Forward then - Ind := Source'First; - - -- Unmapped forward case - - if Mapping'Address = Maps.Identity'Address then - for J in 1 .. Source'Length - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - return Ind; - else - Ind := Ind + 1; - end if; - end loop; - - -- Mapped forward case - - else - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - goto Cont1; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind + 1; - end loop; - end if; - - -- Backwards case - - else - -- Unmapped backward case - - Ind := Source'Last - PL1; - - if Mapping'Address = Maps.Identity'Address then - for J in reverse 1 .. Source'Length - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - return Ind; - else - Ind := Ind - 1; - end if; - end loop; - - -- Mapped backward case - - else - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - goto Cont2; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind - 1; - end loop; - end if; - end if; - - -- Fall through if no match found. Note that the loops are skipped - -- completely in the case of the pattern being longer than the source. - - return 0; - end Index; - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Check for null pointer in case checks are off - - if Mapping = null then - raise Constraint_Error; - end if; - - -- If Pattern longer than Source it can't be found - - if Pattern'Length > Source'Length then - return 0; - end if; - - -- Forwards case - - if Going = Forward then - Ind := Source'First; - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then - goto Cont1; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind + 1; - end loop; - - -- Backwards case - - else - Ind := Source'Last - PL1; - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then - goto Cont2; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind - 1; - end loop; - end if; - - -- Fall through if no match found. Note that the loops are skipped - -- completely in the case of the pattern being longer than the source. - - return 0; - end Index; - - function Index - (Source : String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - -- Forwards case - - if Going = Forward then - for J in Source'Range loop - if Belongs (Source (J), Set, Test) then - return J; - end if; - end loop; - - -- Backwards case - - else - for J in reverse Source'Range loop - if Belongs (Source (J), Set, Test) then - return J; - end if; - end loop; - end if; - - -- Fall through if no match - - return 0; - end Index; - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - begin - - -- AI05-056: If source is empty result is always zero - - if Source'Length = 0 then - return 0; - - elsif Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index (Source (From .. Source'Last), Pattern, Forward, Mapping); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index (Source (Source'First .. From), Pattern, Backward, Mapping); - end if; - end Index; - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - begin - - -- AI05-056: If source is empty result is always zero - - if Source'Length = 0 then - return 0; - - elsif Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return Index - (Source (From .. Source'Last), Pattern, Forward, Mapping); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return Index - (Source (Source'First .. From), Pattern, Backward, Mapping); - end if; - end Index; - - function Index - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - - -- AI05-056 : if source is empty result is always 0. - - if Source'Length = 0 then - return 0; - - elsif Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index (Source (From .. Source'Last), Set, Test, Forward); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index (Source (Source'First .. From), Set, Test, Backward); - end if; - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : String; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - for J in Source'Range loop - if Source (J) /= ' ' then - return J; - end if; - end loop; - - else -- Going = Backward - for J in reverse Source'Range loop - if Source (J) /= ' ' then - return J; - end if; - end loop; - end if; - - -- Fall through if no match - - return 0; - end Index_Non_Blank; - - function Index_Non_Blank - (Source : String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index_Non_Blank (Source (From .. Source'Last), Forward); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index_Non_Blank (Source (Source'First .. From), Backward); - end if; - end Index_Non_Blank; - -end Ada.Strings.Search; diff --git a/gcc/ada/a-strsea.ads b/gcc/ada/a-strsea.ads deleted file mode 100644 index 380444a..0000000 --- a/gcc/ada/a-strsea.ads +++ /dev/null @@ -1,121 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . S E A R C H -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the search functions from Ada.Strings.Fixed. They --- are separated out because they are shared by Ada.Strings.Bounded and --- Ada.Strings.Unbounded, and we don't want to drag in other irrelevant stuff --- from Ada.Strings.Fixed when using the other two packages. We make this a --- private package, since user programs should access these subprograms via --- one of the standard string packages. - -with Ada.Strings.Maps; - -private package Ada.Strings.Search is - pragma Preelaborate; - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Index - (Source : String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Index - (Source : String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Index - (Source : String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Index - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : String; - From : Positive; - Going : Direction := Forward) return Natural; - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Count - (Source : String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Count - (Source : String; - Set : Maps.Character_Set) return Natural; - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - - procedure Find_Token - (Source : String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - -end Ada.Strings.Search; diff --git a/gcc/ada/a-strsup.adb b/gcc/ada/a-strsup.adb deleted file mode 100644 index 50df7dd..0000000 --- a/gcc/ada/a-strsup.adb +++ /dev/null @@ -1,1925 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . S U P E R B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Strings.Search; - -package body Ada.Strings.Superbounded is - - ------------ - -- Concat -- - ------------ - - function Concat - (Left : Super_String; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - end if; - - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end; - end return; - end Concat; - - function Concat - (Left : Super_String; - Right : String) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - Nlen : constant Natural := Llen + Right'Length; - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - end if; - - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end; - end return; - end Concat; - - function Concat - (Left : String; - Right : Super_String) return Super_String - is - - begin - return Result : Super_String (Right.Max_Length) do - declare - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - end if; - - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end; - end return; - end Concat; - - function Concat - (Left : Super_String; - Right : Character) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - begin - if Llen = Left.Max_Length then - raise Ada.Strings.Length_Error; - end if; - - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Current_Length) := Right; - end; - end return; - end Concat; - - function Concat - (Left : Character; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Right.Max_Length) do - declare - Rlen : constant Natural := Right.Current_Length; - begin - if Rlen = Right.Max_Length then - raise Ada.Strings.Length_Error; - end if; - - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Current_Length) := - Right.Data (1 .. Rlen); - end; - end return; - end Concat; - - ----------- - -- Equal -- - ----------- - - function "=" - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Current_Length = Right.Current_Length - and then Left.Data (1 .. Left.Current_Length) = - Right.Data (1 .. Right.Current_Length); - end "="; - - function Equal - (Left : Super_String; - Right : String) return Boolean - is - begin - return Left.Current_Length = Right'Length - and then Left.Data (1 .. Left.Current_Length) = Right; - end Equal; - - function Equal - (Left : String; - Right : Super_String) return Boolean - is - begin - return Left'Length = Right.Current_Length - and then Left = Right.Data (1 .. Right.Current_Length); - end Equal; - - ------------- - -- Greater -- - ------------- - - function Greater - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) > - Right.Data (1 .. Right.Current_Length); - end Greater; - - function Greater - (Left : Super_String; - Right : String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) > Right; - end Greater; - - function Greater - (Left : String; - Right : Super_String) return Boolean - is - begin - return Left > Right.Data (1 .. Right.Current_Length); - end Greater; - - ---------------------- - -- Greater_Or_Equal -- - ---------------------- - - function Greater_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) >= - Right.Data (1 .. Right.Current_Length); - end Greater_Or_Equal; - - function Greater_Or_Equal - (Left : Super_String; - Right : String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) >= Right; - end Greater_Or_Equal; - - function Greater_Or_Equal - (Left : String; - Right : Super_String) return Boolean - is - begin - return Left >= Right.Data (1 .. Right.Current_Length); - end Greater_Or_Equal; - - ---------- - -- Less -- - ---------- - - function Less - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) < - Right.Data (1 .. Right.Current_Length); - end Less; - - function Less - (Left : Super_String; - Right : String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) < Right; - end Less; - - function Less - (Left : String; - Right : Super_String) return Boolean - is - begin - return Left < Right.Data (1 .. Right.Current_Length); - end Less; - - ------------------- - -- Less_Or_Equal -- - ------------------- - - function Less_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) <= - Right.Data (1 .. Right.Current_Length); - end Less_Or_Equal; - - function Less_Or_Equal - (Left : Super_String; - Right : String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) <= Right; - end Less_Or_Equal; - - function Less_Or_Equal - (Left : String; - Right : Super_String) return Boolean - is - begin - return Left <= Right.Data (1 .. Right.Current_Length); - end Less_Or_Equal; - - ---------------------- - -- Set_Super_String -- - ---------------------- - - procedure Set_Super_String - (Target : out Super_String; - Source : String; - Drop : Truncation := Error) - is - Slen : constant Natural := Source'Length; - Max_Length : constant Positive := Target.Max_Length; - - begin - if Slen <= Max_Length then - Target.Current_Length := Slen; - Target.Data (1 .. Slen) := Source; - - else - case Drop is - when Strings.Right => - Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); - - when Strings.Left => - Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Set_Super_String; - - ------------------ - -- Super_Append -- - ------------------ - - -- Case of Super_String and Super_String - - function Super_Append - (Left : Super_String; - Right : Super_String; - Drop : Truncation := Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Result.Data := Right.Data; - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Super_String; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - Rlen : constant Natural := New_Item.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Source.Data := New_Item.Data; - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of Super_String and String - - function Super_Append - (Left : Super_String; - Right : String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right (Right'First .. Right'First - 1 + - Max_Length - Llen); - - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right (Right'Last - (Max_Length - 1) .. Right'Last); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : String; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - Rlen : constant Natural := New_Item'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item; - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item (New_Item'First .. - New_Item'First - 1 + Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - (Max_Length - 1) .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of String and Super_String - - function Super_Append - (Left : String; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Right.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then - Result.Data (1 .. Max_Length) := - Left (Left'First .. Left'First + (Max_Length - 1)); - - else - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right.Data (Rlen - (Max_Length - 1) .. Rlen); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - -- Case of Super_String and Character - - function Super_Append - (Left : Super_String; - Right : Character; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - - begin - if Llen < Max_Length then - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1) := Right; - return Result; - - else - case Drop is - when Strings.Right => - return Left; - - when Strings.Left => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length - 1) := - Left.Data (2 .. Max_Length); - Result.Data (Max_Length) := Right; - return Result; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Character; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - - begin - if Llen < Max_Length then - Source.Current_Length := Llen + 1; - Source.Data (Llen + 1) := New_Item; - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - null; - - when Strings.Left => - Source.Data (1 .. Max_Length - 1) := - Source.Data (2 .. Max_Length); - Source.Data (Max_Length) := New_Item; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of Character and Super_String - - function Super_Append - (Left : Character; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Right.Max_Length; - Result : Super_String (Max_Length); - Rlen : constant Natural := Right.Current_Length; - - begin - if Rlen < Max_Length then - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); - return Result; - - else - case Drop is - when Strings.Right => - Result.Current_Length := Max_Length; - Result.Data (1) := Left; - Result.Data (2 .. Max_Length) := - Right.Data (1 .. Max_Length - 1); - return Result; - - when Strings.Left => - return Right; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Append; - - ----------------- - -- Super_Count -- - ----------------- - - function Super_Count - (Source : Super_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - begin - return - Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); - end Super_Count; - - function Super_Count - (Source : Super_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural - is - begin - return - Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); - end Super_Count; - - function Super_Count - (Source : Super_String; - Set : Maps.Character_Set) return Natural - is - begin - return Search.Count (Source.Data (1 .. Source.Current_Length), Set); - end Super_Count; - - ------------------ - -- Super_Delete -- - ------------------ - - function Super_Delete - (Source : Super_String; - From : Positive; - Through : Natural) return Super_String - is - Result : Super_String (Source.Max_Length); - Slen : constant Natural := Source.Current_Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return Source; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Result.Current_Length := From - 1; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - return Result; - - else - Result.Current_Length := Slen - Num_Delete; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - Result.Data (From .. Result.Current_Length) := - Source.Data (Through + 1 .. Slen); - return Result; - end if; - end Super_Delete; - - procedure Super_Delete - (Source : in out Super_String; - From : Positive; - Through : Natural) - is - Slen : constant Natural := Source.Current_Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Source.Current_Length := From - 1; - - else - Source.Current_Length := Slen - Num_Delete; - Source.Data (From .. Source.Current_Length) := - Source.Data (Through + 1 .. Slen); - end if; - end Super_Delete; - - ------------------- - -- Super_Element -- - ------------------- - - function Super_Element - (Source : Super_String; - Index : Positive) return Character - is - begin - if Index <= Source.Current_Length then - return Source.Data (Index); - else - raise Strings.Index_Error; - end if; - end Super_Element; - - ---------------------- - -- Super_Find_Token -- - ---------------------- - - procedure Super_Find_Token - (Source : Super_String; - Set : Maps.Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Search.Find_Token - (Source.Data (From .. Source.Current_Length), Set, Test, First, Last); - end Super_Find_Token; - - procedure Super_Find_Token - (Source : Super_String; - Set : Maps.Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Search.Find_Token - (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); - end Super_Find_Token; - - ---------------- - -- Super_Head -- - ---------------- - - function Super_Head - (Source : Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Current_Length := Count; - Result.Data (1 .. Count) := Source.Data (1 .. Count); - - elsif Count <= Max_Length then - Result.Current_Length := Count; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Count) := (others => Pad); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Max_Length - Npad) := - Source.Data (Count - Max_Length + 1 .. Slen); - Result.Data (Max_Length - Npad + 1 .. Max_Length) := - (others => Pad); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Head; - - procedure Super_Head - (Source : in out Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - Temp : String (1 .. Max_Length); - - begin - if Npad <= 0 then - Source.Current_Length := Count; - - elsif Count <= Max_Length then - Source.Current_Length := Count; - Source.Data (Slen + 1 .. Count) := (others => Pad); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad > Max_Length then - Source.Data := (others => Pad); - - else - Temp := Source.Data; - Source.Data (1 .. Max_Length - Npad) := - Temp (Count - Max_Length + 1 .. Slen); - - for J in Max_Length - Npad + 1 .. Max_Length loop - Source.Data (J) := Pad; - end loop; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Head; - - ----------------- - -- Super_Index -- - ----------------- - - function Super_Index - (Source : Super_String; - Pattern : String; - Going : Strings.Direction := Strings.Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Set : Maps.Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Set, Test, Going); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - return Search.Index - (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); - end Super_Index; - - --------------------------- - -- Super_Index_Non_Blank -- - --------------------------- - - function Super_Index_Non_Blank - (Source : Super_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return - Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), Going); - end Super_Index_Non_Blank; - - function Super_Index_Non_Blank - (Source : Super_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - return - Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), From, Going); - end Super_Index_Non_Blank; - - ------------------ - -- Super_Insert -- - ------------------ - - function Super_Insert - (Source : Super_String; - Before : Positive; - New_Item : String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Nlen : constant Natural := New_Item'Length; - Tlen : constant Natural := Slen + Nlen; - Blen : constant Natural := Before - 1; - Alen : constant Integer := Slen - Blen; - Droplen : constant Integer := Tlen - Max_Length; - - -- Tlen is the length of the total string before possible truncation. - -- Blen, Alen are the lengths of the before and after pieces of the - -- source string. - - begin - if Alen < 0 then - raise Ada.Strings.Index_Error; - - elsif Droplen <= 0 then - Result.Current_Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Tlen) := - Source.Data (Before .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Before .. Max_Length) := - New_Item (New_Item'First - .. New_Item'First + Max_Length - Before); - else - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Max_Length) := - Source.Data (Before .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (Before .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - New_Item (New_Item'Last - (Max_Length - Alen) + 1 - .. New_Item'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := - New_Item; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Insert; - - procedure Super_Insert - (Source : in out Super_String; - Before : Positive; - New_Item : String; - Drop : Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Super_Insert (Source, Before, New_Item, Drop); - end Super_Insert; - - ------------------ - -- Super_Length -- - ------------------ - - function Super_Length (Source : Super_String) return Natural is - begin - return Source.Current_Length; - end Super_Length; - - --------------------- - -- Super_Overwrite -- - --------------------- - - function Super_Overwrite - (Source : Super_String; - Position : Positive; - New_Item : String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Endpos : constant Natural := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Current_Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif New_Item'Length = 0 then - return Source; - - elsif Endpos <= Slen then - Result.Current_Length := Source.Current_Length; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - elsif Endpos <= Max_Length then - Result.Current_Length := Endpos; - Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - else - Result.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Position - 1) := - Source.Data (1 .. Position - 1); - - Result.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - return Result; - - when Strings.Left => - if New_Item'Length >= Max_Length then - Result.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - return Result; - - else - Result.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - Result.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - return Result; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Overwrite; - - procedure Super_Overwrite - (Source : in out Super_String; - Position : Positive; - New_Item : String; - Drop : Strings.Truncation := Strings.Error) - is - Max_Length : constant Positive := Source.Max_Length; - Endpos : constant Positive := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Current_Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Endpos <= Slen then - Source.Data (Position .. Endpos) := New_Item; - - elsif Endpos <= Max_Length then - Source.Data (Position .. Endpos) := New_Item; - Source.Current_Length := Endpos; - - else - Source.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - - when Strings.Left => - if New_Item'Length > Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - - Source.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Overwrite; - - --------------------------- - -- Super_Replace_Element -- - --------------------------- - - procedure Super_Replace_Element - (Source : in out Super_String; - Index : Positive; - By : Character) - is - begin - if Index <= Source.Current_Length then - Source.Data (Index) := By; - else - raise Ada.Strings.Index_Error; - end if; - end Super_Replace_Element; - - ------------------------- - -- Super_Replace_Slice -- - ------------------------- - - function Super_Replace_Slice - (Source : Super_String; - Low : Positive; - High : Natural; - By : String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - - begin - if Low > Slen + 1 then - raise Strings.Index_Error; - - elsif High < Low then - return Super_Insert (Source, Low, By, Drop); - - else - declare - Blen : constant Natural := Natural'Max (0, Low - 1); - Alen : constant Natural := Natural'Max (0, Slen - High); - Tlen : constant Natural := Blen + By'Length + Alen; - Droplen : constant Integer := Tlen - Max_Length; - Result : Super_String (Max_Length); - - -- Tlen is the total length of the result string before any - -- truncation. Blen and Alen are the lengths of the pieces - -- of the original string that end up in the result string - -- before and after the replaced slice. - - begin - if Droplen <= 0 then - Result.Current_Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Tlen) := - Source.Data (High + 1 .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Low .. Max_Length) := - By (By'First .. By'First + Max_Length - Low); - else - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Max_Length) := - Source.Data (High + 1 .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (High + 1 .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - By (By'Last - (Max_Length - Alen) + 1 .. By'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := By; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end; - end if; - end Super_Replace_Slice; - - procedure Super_Replace_Slice - (Source : in out Super_String; - Low : Positive; - High : Natural; - By : String; - Drop : Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Super_Replace_Slice (Source, Low, High, By, Drop); - end Super_Replace_Slice; - - --------------------- - -- Super_Replicate -- - --------------------- - - function Super_Replicate - (Count : Natural; - Item : Character; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - - begin - if Count <= Max_Length then - Result.Current_Length := Count; - - elsif Drop = Strings.Error then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Max_Length; - end if; - - Result.Data (1 .. Result.Current_Length) := (others => Item); - return Result; - end Super_Replicate; - - function Super_Replicate - (Count : Natural; - Item : String; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String - is - Length : constant Integer := Count * Item'Length; - Result : Super_String (Max_Length); - Indx : Positive; - - begin - if Length <= Max_Length then - Result.Current_Length := Length; - - if Length > 0 then - Indx := 1; - - for J in 1 .. Count loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - end if; - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Indx := 1; - - while Indx + Item'Length <= Max_Length + 1 loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - - Result.Data (Indx .. Max_Length) := - Item (Item'First .. Item'First + Max_Length - Indx); - - when Strings.Left => - Indx := Max_Length; - - while Indx - Item'Length >= 1 loop - Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; - Indx := Indx - Item'Length; - end loop; - - Result.Data (1 .. Indx) := - Item (Item'Last - Indx + 1 .. Item'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Replicate; - - function Super_Replicate - (Count : Natural; - Item : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - begin - return - Super_Replicate - (Count, - Item.Data (1 .. Item.Current_Length), - Drop, - Item.Max_Length); - end Super_Replicate; - - ----------------- - -- Super_Slice -- - ----------------- - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - return R : String (Low .. High) do - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - end if; - - -- Note: in this case, superflat bounds are not a problem, we just - -- get the null string in accordance with normal Ada slice rules. - - R := Source.Data (Low .. High); - end return; - end Super_Slice; - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Super_String - is - begin - return Result : Super_String (Source.Max_Length) do - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - end if; - - -- Note: the Max operation here deals with the superflat case - - Result.Current_Length := Integer'Max (0, High - Low + 1); - Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); - end return; - end Super_Slice; - - procedure Super_Slice - (Source : Super_String; - Target : out Super_String; - Low : Positive; - High : Natural) - is - begin - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - end if; - - -- Note: the Max operation here deals with the superflat case - - Target.Current_Length := Integer'Max (0, High - Low + 1); - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); - end Super_Slice; - - ---------------- - -- Super_Tail -- - ---------------- - - function Super_Tail - (Source : Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Current_Length := Count; - Result.Data (1 .. Count) := - Source.Data (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Result.Current_Length := Count; - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Max_Length) := - Source.Data (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - Result.Data (1 .. Max_Length - Slen) := (others => Pad); - Result.Data (Max_Length - Slen + 1 .. Max_Length) := - Source.Data (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Tail; - - procedure Super_Tail - (Source : in out Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - Temp : constant String (1 .. Max_Length) := Source.Data; - - begin - if Npad <= 0 then - Source.Current_Length := Count; - Source.Data (1 .. Count) := - Temp (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Source.Current_Length := Count; - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Source.Data := (others => Pad); - - else - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Max_Length) := - Temp (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - for J in 1 .. Max_Length - Slen loop - Source.Data (J) := Pad; - end loop; - - Source.Data (Max_Length - Slen + 1 .. Max_Length) := - Temp (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Tail; - - --------------------- - -- Super_To_String -- - --------------------- - - function Super_To_String (Source : Super_String) return String is - begin - return R : String (1 .. Source.Current_Length) do - R := Source.Data (1 .. Source.Current_Length); - end return; - end Super_To_String; - - --------------------- - -- Super_Translate -- - --------------------- - - function Super_Translate - (Source : Super_String; - Mapping : Maps.Character_Mapping) return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - Result.Current_Length := Source.Current_Length; - - for J in 1 .. Source.Current_Length loop - Result.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - - return Result; - end Super_Translate; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Maps.Character_Mapping) - is - begin - for J in 1 .. Source.Current_Length loop - Source.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - end Super_Translate; - - function Super_Translate - (Source : Super_String; - Mapping : Maps.Character_Mapping_Function) return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - Result.Current_Length := Source.Current_Length; - - for J in 1 .. Source.Current_Length loop - Result.Data (J) := Mapping.all (Source.Data (J)); - end loop; - - return Result; - end Super_Translate; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Maps.Character_Mapping_Function) - is - begin - for J in 1 .. Source.Current_Length loop - Source.Data (J) := Mapping.all (Source.Data (J)); - end loop; - end Super_Translate; - - ---------------- - -- Super_Trim -- - ---------------- - - function Super_Trim - (Source : Super_String; - Side : Trim_End) return Super_String - is - Result : Super_String (Source.Max_Length); - Last : Natural := Source.Current_Length; - First : Positive := 1; - - begin - if Side = Left or else Side = Both then - while First <= Last and then Source.Data (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Source.Data (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); - return Result; - end Super_Trim; - - procedure Super_Trim - (Source : in out Super_String; - Side : Trim_End) - is - Max_Length : constant Positive := Source.Max_Length; - Last : Natural := Source.Current_Length; - First : Positive := 1; - Temp : String (1 .. Max_Length); - - begin - Temp (1 .. Last) := Source.Data (1 .. Last); - - if Side = Left or else Side = Both then - while First <= Last and then Temp (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Temp (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); - end Super_Trim; - - function Super_Trim - (Source : Super_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := - Source.Data (First .. Last); - return Result; - end if; - end loop; - end if; - end loop; - - Result.Current_Length := 0; - return Result; - end Super_Trim; - - procedure Super_Trim - (Source : in out Super_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) - is - begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - if First = 1 then - Source.Current_Length := Last; - return; - else - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := - Source.Data (First .. Last); - return; - end if; - end if; - end loop; - - Source.Current_Length := 0; - return; - end if; - end loop; - - Source.Current_Length := 0; - end Super_Trim; - - ----------- - -- Times -- - ----------- - - function Times - (Left : Natural; - Right : Character; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - - begin - if Left > Max_Length then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Left; - - for J in 1 .. Left loop - Result.Data (J) := Right; - end loop; - end if; - - return Result; - end Times; - - function Times - (Left : Natural; - Right : String; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - Pos : Positive := 1; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Left * Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Nlen; - - if Nlen > 0 then - for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := Right; - Pos := Pos + Rlen; - end loop; - end if; - end if; - - return Result; - end Times; - - function Times - (Left : Natural; - Right : Super_String) return Super_String - is - Result : Super_String (Right.Max_Length); - Pos : Positive := 1; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Left * Rlen; - - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Nlen; - - if Nlen > 0 then - for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := - Right.Data (1 .. Rlen); - Pos := Pos + Rlen; - end loop; - end if; - end if; - - return Result; - end Times; - - --------------------- - -- To_Super_String -- - --------------------- - - function To_Super_String - (Source : String; - Max_Length : Natural; - Drop : Truncation := Error) return Super_String - is - Result : Super_String (Max_Length); - Slen : constant Natural := Source'Length; - - begin - if Slen <= Max_Length then - Result.Current_Length := Slen; - Result.Data (1 .. Slen) := Source; - - else - case Drop is - when Strings.Right => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); - - when Strings.Left => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end To_Super_String; - -end Ada.Strings.Superbounded; diff --git a/gcc/ada/a-strsup.ads b/gcc/ada/a-strsup.ads deleted file mode 100644 index d43a560..0000000 --- a/gcc/ada/a-strsup.ads +++ /dev/null @@ -1,493 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . S U P E R B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This non generic package contains most of the implementation of the --- generic package Ada.Strings.Bounded.Generic_Bounded_Length. - --- It defines type Super_String as a discriminated record with the maximum --- length as the discriminant. Individual instantiations of Strings.Bounded --- use this type with an appropriate discriminant value set. - -with Ada.Strings.Maps; - -package Ada.Strings.Superbounded is - pragma Preelaborate; - - -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is - -- derived from Super_String, with the constraint of the maximum length. - - type Super_String (Max_Length : Positive) is record - Current_Length : Natural := 0; - Data : String (1 .. Max_Length); - -- A previous version had a default initial value for Data, which is - -- no longer necessary, because we now special-case this type in the - -- compiler, so "=" composes properly for descendants of this type. - -- Leaving it out is more efficient. - end record; - - -- The subprograms defined for Super_String are similar to those - -- defined for Bounded_String, except that they have different names, so - -- that they can be renamed in Ada.Strings.Bounded.Generic_Bounded_Length. - - function Super_Length (Source : Super_String) return Natural; - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Super_String - (Source : String; - Max_Length : Natural; - Drop : Truncation := Error) return Super_String; - -- Note the additional parameter Max_Length, which specifies the maximum - -- length setting of the resulting Super_String value. - - -- The following procedures have declarations (and semantics) that are - -- exactly analogous to those declared in Ada.Strings.Bounded. - - function Super_To_String (Source : Super_String) return String; - - procedure Set_Super_String - (Target : out Super_String; - Source : String; - Drop : Truncation := Error); - - function Super_Append - (Left : Super_String; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Super_String; - Right : String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : String; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Super_String; - Right : Character; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Character; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Super_String; - Drop : Truncation := Error); - - procedure Super_Append - (Source : in out Super_String; - New_Item : String; - Drop : Truncation := Error); - - procedure Super_Append - (Source : in out Super_String; - New_Item : Character; - Drop : Truncation := Error); - - function Concat - (Left : Super_String; - Right : Super_String) return Super_String; - - function Concat - (Left : Super_String; - Right : String) return Super_String; - - function Concat - (Left : String; - Right : Super_String) return Super_String; - - function Concat - (Left : Super_String; - Right : Character) return Super_String; - - function Concat - (Left : Character; - Right : Super_String) return Super_String; - - function Super_Element - (Source : Super_String; - Index : Positive) return Character; - - procedure Super_Replace_Element - (Source : in out Super_String; - Index : Positive; - By : Character); - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return String; - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Super_String; - - procedure Super_Slice - (Source : Super_String; - Target : out Super_String; - Low : Positive; - High : Natural); - - function "=" - (Left : Super_String; - Right : Super_String) return Boolean; - - function Equal - (Left : Super_String; - Right : Super_String) return Boolean renames "="; - - function Equal - (Left : Super_String; - Right : String) return Boolean; - - function Equal - (Left : String; - Right : Super_String) return Boolean; - - function Less - (Left : Super_String; - Right : Super_String) return Boolean; - - function Less - (Left : Super_String; - Right : String) return Boolean; - - function Less - (Left : String; - Right : Super_String) return Boolean; - - function Less_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean; - - function Less_Or_Equal - (Left : Super_String; - Right : String) return Boolean; - - function Less_Or_Equal - (Left : String; - Right : Super_String) return Boolean; - - function Greater - (Left : Super_String; - Right : Super_String) return Boolean; - - function Greater - (Left : Super_String; - Right : String) return Boolean; - - function Greater - (Left : String; - Right : Super_String) return Boolean; - - function Greater_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean; - - function Greater_Or_Equal - (Left : Super_String; - Right : String) return Boolean; - - function Greater_Or_Equal - (Left : String; - Right : Super_String) return Boolean; - - ---------------------- - -- Search Functions -- - ---------------------- - - function Super_Index - (Source : Super_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Super_Index - (Source : Super_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Super_Index - (Source : Super_String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Super_Index - (Source : Super_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Super_Index - (Source : Super_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Super_Index - (Source : Super_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Super_Index_Non_Blank - (Source : Super_String; - Going : Direction := Forward) return Natural; - - function Super_Index_Non_Blank - (Source : Super_String; - From : Positive; - Going : Direction := Forward) return Natural; - - function Super_Count - (Source : Super_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Super_Count - (Source : Super_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Super_Count - (Source : Super_String; - Set : Maps.Character_Set) return Natural; - - procedure Super_Find_Token - (Source : Super_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - - procedure Super_Find_Token - (Source : Super_String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Super_Translate - (Source : Super_String; - Mapping : Maps.Character_Mapping) return Super_String; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Maps.Character_Mapping); - - function Super_Translate - (Source : Super_String; - Mapping : Maps.Character_Mapping_Function) return Super_String; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Maps.Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Super_Replace_Slice - (Source : Super_String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Replace_Slice - (Source : in out Super_String; - Low : Positive; - High : Natural; - By : String; - Drop : Truncation := Error); - - function Super_Insert - (Source : Super_String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Insert - (Source : in out Super_String; - Before : Positive; - New_Item : String; - Drop : Truncation := Error); - - function Super_Overwrite - (Source : Super_String; - Position : Positive; - New_Item : String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Overwrite - (Source : in out Super_String; - Position : Positive; - New_Item : String; - Drop : Truncation := Error); - - function Super_Delete - (Source : Super_String; - From : Positive; - Through : Natural) return Super_String; - - procedure Super_Delete - (Source : in out Super_String; - From : Positive; - Through : Natural); - - --------------------------------- - -- String Selector Subprograms -- - --------------------------------- - - function Super_Trim - (Source : Super_String; - Side : Trim_End) return Super_String; - - procedure Super_Trim - (Source : in out Super_String; - Side : Trim_End); - - function Super_Trim - (Source : Super_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Super_String; - - procedure Super_Trim - (Source : in out Super_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set); - - function Super_Head - (Source : Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) return Super_String; - - procedure Super_Head - (Source : in out Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error); - - function Super_Tail - (Source : Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error) return Super_String; - - procedure Super_Tail - (Source : in out Super_String; - Count : Natural; - Pad : Character := Space; - Drop : Truncation := Error); - - ------------------------------------ - -- String Constructor Subprograms -- - ------------------------------------ - - -- Note: in some of the following routines, there is an extra parameter - -- Max_Length which specifies the value of the maximum length for the - -- resulting Super_String value. - - function Times - (Left : Natural; - Right : Character; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Times - (Left : Natural; - Right : String; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Times - (Left : Natural; - Right : Super_String) return Super_String; - - function Super_Replicate - (Count : Natural; - Item : Character; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Super_Replicate - (Count : Natural; - Item : String; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Super_Replicate - (Count : Natural; - Item : Super_String; - Drop : Truncation := Error) return Super_String; - -private - -- Pragma Inline declarations - - pragma Inline ("="); - pragma Inline (Less); - pragma Inline (Less_Or_Equal); - pragma Inline (Greater); - pragma Inline (Greater_Or_Equal); - pragma Inline (Concat); - pragma Inline (Super_Count); - pragma Inline (Super_Element); - pragma Inline (Super_Find_Token); - pragma Inline (Super_Index); - pragma Inline (Super_Index_Non_Blank); - pragma Inline (Super_Length); - pragma Inline (Super_Replace_Element); - pragma Inline (Super_Slice); - pragma Inline (Super_To_String); - -end Ada.Strings.Superbounded; diff --git a/gcc/ada/a-strunb-shared.adb b/gcc/ada/a-strunb-shared.adb deleted file mode 100644 index 2199f64..0000000 --- a/gcc/ada/a-strunb-shared.adb +++ /dev/null @@ -1,2115 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Unbounded is - - use Ada.Strings.Maps; - - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - function Aligned_Max_Length (Max_Length : Natural) return Natural; - -- Returns recommended length of the shared string which is greater or - -- equal to specified length. Calculation take in sense alignment of the - -- allocated memory segments to use memory effectively by Append/Insert/etc - -- operations. - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := LR.Last + RR.Last; - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Left string is empty, return Right string - - elsif LR.Last = 0 then - Reference (RR); - DR := RR; - - -- Right string is empty, return Left string - - elsif RR.Last = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill data - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_String; - Right : String) return Unbounded_String - is - LR : constant Shared_String_Access := Left.Reference; - DL : constant Natural := LR.Last + Right'Length; - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Right is an empty string, return Left string - - elsif Right'Length = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := Right; - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : String; - Right : Unbounded_String) return Unbounded_String - is - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := Left'Length + RR.Last; - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared one - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Left is empty string, return Right string - - elsif Left'Length = 0 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Left'Length) := Left; - DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_String; - Right : Character) return Unbounded_String - is - LR : constant Shared_String_Access := Left.Reference; - DL : constant Natural := LR.Last + 1; - DR : Shared_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (DL) := Right; - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Character; - Right : Unbounded_String) return Unbounded_String - is - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := 1 + RR.Last; - DR : Shared_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1) := Left; - DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Character) return Unbounded_String - is - DR : Shared_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if Left = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Left); - - for J in 1 .. Left loop - DR.Data (J) := Right; - end loop; - - DR.Last := Left; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : String) return Unbounded_String - is - DL : constant Natural := Left * Right'Length; - DR : Shared_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + Right'Length - 1) := Right; - K := K + Right'Length; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_String) return Unbounded_String - is - RR : constant Shared_String_Access := Right.Reference; - DL : constant Natural := Left * RR.Last; - DR : Shared_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Coefficient is one, just return string itself - - elsif Left = 1 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); - K := K + RR.Last; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); - end "<"; - - function "<" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) < Right; - end "<"; - - function "<" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left < RR.Data (1 .. RR.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); - end "<="; - - function "<=" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) <= Right; - end "<="; - - function "<=" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left <= RR.Data (1 .. RR.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - - begin - return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); - -- LR = RR means two strings shares shared string, thus they are equal - end "="; - - function "=" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) = Right; - end "="; - - function "=" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left = RR.Data (1 .. RR.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); - end ">"; - - function ">" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) > Right; - end ">"; - - function ">" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left > RR.Data (1 .. RR.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - RR : constant Shared_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); - end ">="; - - function ">=" - (Left : Unbounded_String; - Right : String) return Boolean - is - LR : constant Shared_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) >= Right; - end ">="; - - function ">=" - (Left : String; - Right : Unbounded_String) return Boolean - is - RR : constant Shared_String_Access := Right.Reference; - begin - return Left >= RR.Data (1 .. RR.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_String) is - begin - Reference (Object.Reference); - end Adjust; - - ------------------------ - -- Aligned_Max_Length -- - ------------------------ - - function Aligned_Max_Length (Max_Length : Natural) return Natural is - Static_Size : constant Natural := - Empty_Shared_String'Size / Standard'Storage_Unit; - -- Total size of all static components - - begin - return - ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc - - Static_Size; - end Aligned_Max_Length; - - -------------- - -- Allocate -- - -------------- - - function Allocate - (Max_Length : Natural) return not null Shared_String_Access - is - begin - -- Empty string requested, return shared empty string - - if Max_Length = 0 then - Reference (Empty_Shared_String'Access); - return Empty_Shared_String'Access; - - -- Otherwise, allocate requested space (and probably some more room) - - else - return new Shared_String (Aligned_Max_Length (Max_Length)); - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_String; - New_Item : Unbounded_String) - is - SR : constant Shared_String_Access := Source.Reference; - NR : constant Shared_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_String_Access; - - begin - -- Source is an empty string, reuse New_Item data - - if SR.Last = 0 then - Reference (NR); - Source.Reference := NR; - Unreference (SR); - - -- New_Item is empty string, nothing to do - - elsif NR.Last = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_String; - New_Item : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_String_Access; - - begin - -- New_Item is an empty string, nothing to do - - if New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_String; - New_Item : Character) - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_String_Access; - - begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then - SR.Data (SR.Last + 1) := New_Item; - SR.Last := SR.Last + 1; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - ------------------- - -- Can_Be_Reused -- - ------------------- - - function Can_Be_Reused - (Item : not null Shared_String_Access; - Length : Natural) return Boolean - is - begin - return - System.Atomic_Counters.Is_One (Item.Counter) - and then Item.Max_Length >= Length - and then Item.Max_Length <= - Aligned_Max_Length (Length + Length / Growth_Factor); - end Can_Be_Reused; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Count (SR.Data (1 .. SR.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_String; - From : Positive; - Through : Natural) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Empty slice is deleted, use the same shared string - - if From > Through then - Reference (SR); - DR := SR; - - -- Index is out of range - - elsif Through > SR.Last then - raise Index_Error; - - -- Compute size of the result - - else - DL := SR.Last - (Through - From + 1); - - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Delete; - - procedure Delete - (Source : in out Unbounded_String; - From : Positive; - Through : Natural) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Nothing changed, return - - if From > Through then - null; - - -- Through is outside of the range - - elsif Through > SR.Last then - raise Index_Error; - - else - DL := SR.Last - (Through - From + 1); - - -- Result is empty, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_String; - Index : Positive) return Character - is - SR : constant Shared_String_Access := Source.Reference; - begin - if Index <= SR.Last then - return SR.Data (Index); - else - raise Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_String) is - SR : constant not null Shared_String_Access := Object.Reference; - begin - if SR /= Null_Unbounded_String.Reference then - - -- The same controlled object can be finalized several times for - -- some reason. As per 7.6.1(24) this should have no ill effect, - -- so we need to add a guard for the case of finalizing the same - -- object twice. - - -- We set the Object to the empty string so there will be no ill - -- effects if a program references an already-finalized object. - - Object.Reference := Null_Unbounded_String.Reference; - Reference (Object.Reference); - Unreference (SR); - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_String_Access := Source.Reference; - begin - Search.Find_Token (SR.Data (From .. SR.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_String_Access := Source.Reference; - begin - Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (String, String_Access); - begin - Deallocate (X); - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Result is empty, reuse shared empty string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Length of the string is the same as requested, reuse source shared - -- string. - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is more than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- contents and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Head; - - procedure Head - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Result is empty, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Result is same as source string, reuse source shared string - - elsif Count = SR.Last then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, Count) then - if Count > SR.Last then - for J in SR.Last + 1 .. Count loop - SR.Data (J) := Pad; - end loop; - end if; - - SR.Last := Count; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is greater than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- existing data and fill remaining positions with Pad characters. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - Source.Reference := DR; - Unreference (SR); - end if; - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Strings.Direction := Strings.Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Unbounded_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_String; - From : Positive; - Going : Direction := Forward) return Natural - is - SR : constant Shared_String_Access := Source.Reference; - begin - return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_String) is - begin - Reference (Object.Reference); - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_String; - Before : Positive; - New_Item : String) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_String_Access; - - begin - -- Check index first - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Inserted string is empty, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Insert; - - procedure Insert - (Source : in out Unbounded_String; - Before : Positive; - New_Item : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Inserted string is empty, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string first - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_String) return Natural is - begin - return Source.Reference.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_String; - Position : Positive; - New_Item : String) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Result is same as source string, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_String; - Position : Positive; - New_Item : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Bounds check - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- String unchanged, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Overwrite; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_String_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_String; - Index : Positive; - By : Character) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Bounds check - - if Index <= SR.Last then - - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last) then - SR.Data (Index) := By; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (Index) := By; - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - else - raise Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural; - By : String) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation when removed slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - - -- Otherwise just insert string - - else - return Insert (Source, Low, By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_String; - Low : Positive; - High : Natural; - By : String) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Bounds check - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation only when replaced slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - SR.Data (Low .. Low + By'Length - 1) := By; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - - -- Otherwise just insert item - - else - Insert (Source, Low, By); - end if; - end Replace_Slice; - - -------------------------- - -- Set_Unbounded_String -- - -------------------------- - - procedure Set_Unbounded_String - (Target : out Unbounded_String; - Source : String) - is - TR : constant Shared_String_Access := Target.Reference; - DR : Shared_String_Access; - - begin - -- In case of empty string, reuse empty shared string - - if Source'Length = 0 then - Reference (Empty_Shared_String'Access); - Target.Reference := Empty_Shared_String'Access; - - else - -- Try to reuse existing shared string - - if Can_Be_Reused (TR, Source'Length) then - Reference (TR); - DR := TR; - - -- Otherwise allocate new shared string - - else - DR := Allocate (Source'Length); - Target.Reference := DR; - end if; - - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - Unreference (TR); - end Set_Unbounded_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return String - is - SR : constant Shared_String_Access := Source.Reference; - - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - else - return SR.Data (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- For empty result reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Result is whole source string, reuse source shared string - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Tail; - - procedure Tail - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - procedure Common - (SR : Shared_String_Access; - DR : Shared_String_Access; - Count : Natural); - -- Common code of tail computation. SR/DR can point to the same object - - ------------ - -- Common -- - ------------ - - procedure Common - (SR : Shared_String_Access; - DR : Shared_String_Access; - Count : Natural) is - begin - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end Common; - - begin - -- Result is empty string, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - elsif Count = SR.Last then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, Count) then - Common (SR, SR, Count); - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - Common (SR, DR, Count); - Source.Reference := DR; - Unreference (SR); - end if; - end Tail; - - --------------- - -- To_String -- - --------------- - - function To_String (Source : Unbounded_String) return String is - begin - return Source.Reference.Data (1 .. Source.Reference.Last); - end To_String; - - ------------------------- - -- To_Unbounded_String -- - ------------------------- - - function To_Unbounded_String (Source : String) return Unbounded_String is - DR : Shared_String_Access; - - begin - if Source'Length = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - DR := Allocate (Source'Length); - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_String; - - function To_Unbounded_String (Length : Natural) return Unbounded_String is - DR : Shared_String_Access; - - begin - if Length = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - DR := Allocate (Length); - DR.Last := Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - end Translate; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - end Translate; - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - - exception - when others => - Unreference (DR); - - raise; - end Translate; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function) - is - SR : constant Shared_String_Access := Source.Reference; - DR : Shared_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - exception - when others => - if DR /= null then - Unreference (DR); - end if; - - raise; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - if DL = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_String; - Side : Trim_End) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- nothing to do. - - if DL = SR.Last then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - function Trim - (Source : Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_String'Access); - Source.Reference := Empty_Shared_String'Access; - Unreference (SR); - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return Unbounded_String - is - SR : constant Shared_String_Access := Source.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_String'Access); - DR := Empty_Shared_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DL := High - Low + 1; - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_String; - Target : out Unbounded_String; - Low : Positive; - High : Natural) - is - SR : constant Shared_String_Access := Source.Reference; - TR : constant Shared_String_Access := Target.Reference; - DL : Natural; - DR : Shared_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_String'Access); - Target.Reference := Empty_Shared_String'Access; - Unreference (TR); - - else - DL := High - Low + 1; - - -- Try to reuse existing shared string - - if Can_Be_Reused (TR, DL) then - TR.Data (1 .. DL) := SR.Data (Low .. High); - TR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Target.Reference := DR; - Unreference (TR); - end if; - end if; - end Unbounded_Slice; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_String_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); - - Aux : Shared_String_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - - -- Reference counter of Empty_Shared_String should never reach - -- zero. We check here in case it wraps around. - - if Aux /= Empty_Shared_String'Access then - Free (Aux); - end if; - end if; - end Unreference; - -end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb-shared.ads b/gcc/ada/a-strunb-shared.ads deleted file mode 100644 index c5f96b3..0000000 --- a/gcc/ada/a-strunb-shared.ads +++ /dev/null @@ -1,490 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an implementation of Ada.Strings.Unbounded that uses --- reference counts to implement copy on modification (rather than copy on --- assignment). This is significantly more efficient on many targets. - --- This version is supported on: --- - all Alpha platforms --- - all ia64 platforms --- - all PowerPC platforms --- - all SPARC V9 platforms --- - all x86 platforms --- - all x86_64 platforms - - -- This package uses several techniques to increase speed: - - -- - Implicit sharing or copy-on-write. An Unbounded_String contains only - -- the reference to the data which is shared between several instances. - -- The shared data is reallocated only when its value is changed and - -- the object mutation can't be used or it is inefficient to use it. - - -- - Object mutation. Shared data object can be reused without memory - -- reallocation when all of the following requirements are met: - -- - the shared data object is no longer used by anyone else; - -- - the size is sufficient to store the new value; - -- - the gap after reuse is less than a defined threshold. - - -- - Memory preallocation. Most of used memory allocation algorithms - -- align allocated segments on the some boundary, thus some amount of - -- additional memory can be preallocated without any impact. Such - -- preallocated memory can used later by Append/Insert operations - -- without reallocation. - - -- Reference counting uses GCC builtin atomic operations, which allows safe - -- sharing of internal data between Ada tasks. Nevertheless, this does not - -- make objects of Unbounded_String thread-safe: an instance cannot be - -- accessed by several tasks simultaneously. - -with Ada.Strings.Maps; -private with Ada.Finalization; -private with System.Atomic_Counters; - -package Ada.Strings.Unbounded is - pragma Preelaborate; - - type Unbounded_String is private; - pragma Preelaborable_Initialization (Unbounded_String); - - Null_Unbounded_String : constant Unbounded_String; - - function Length (Source : Unbounded_String) return Natural; - - type String_Access is access all String; - - procedure Free (X : in out String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_String - (Source : String) return Unbounded_String; - - function To_Unbounded_String - (Length : Natural) return Unbounded_String; - - function To_String (Source : Unbounded_String) return String; - - procedure Set_Unbounded_String - (Target : out Unbounded_String; - Source : String); - pragma Ada_05 (Set_Unbounded_String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : Unbounded_String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : Character); - - function "&" - (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String; - - function "&" - (Left : Unbounded_String; - Right : String) return Unbounded_String; - - function "&" - (Left : String; - Right : Unbounded_String) return Unbounded_String; - - function "&" - (Left : Unbounded_String; - Right : Character) return Unbounded_String; - - function "&" - (Left : Character; - Right : Unbounded_String) return Unbounded_String; - - function Element - (Source : Unbounded_String; - Index : Positive) return Character; - - procedure Replace_Element - (Source : in out Unbounded_String; - Index : Positive; - By : Character); - - function Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return String; - - function Unbounded_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return Unbounded_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_String; - Target : out Unbounded_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "=" - (Left : String; - Right : Unbounded_String) return Boolean; - - function "<" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "<" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "<" - (Left : String; - Right : Unbounded_String) return Boolean; - - function "<=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "<=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "<=" - (Left : String; - Right : Unbounded_String) return Boolean; - - function ">" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function ">" - (Left : Unbounded_String; - Right : String) return Boolean; - - function ">" - (Left : String; - Right : Unbounded_String) return Boolean; - - function ">=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function ">=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function ">=" - (Left : String; - Right : Unbounded_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Count - (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping); - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural; - By : String) return Unbounded_String; - - procedure Replace_Slice - (Source : in out Unbounded_String; - Low : Positive; - High : Natural; - By : String); - - function Insert - (Source : Unbounded_String; - Before : Positive; - New_Item : String) return Unbounded_String; - - procedure Insert - (Source : in out Unbounded_String; - Before : Positive; - New_Item : String); - - function Overwrite - (Source : Unbounded_String; - Position : Positive; - New_Item : String) return Unbounded_String; - - procedure Overwrite - (Source : in out Unbounded_String; - Position : Positive; - New_Item : String); - - function Delete - (Source : Unbounded_String; - From : Positive; - Through : Natural) return Unbounded_String; - - procedure Delete - (Source : in out Unbounded_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String; - - procedure Trim - (Source : in out Unbounded_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String; - - procedure Trim - (Source : in out Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set); - - function Head - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String; - - procedure Head - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space); - - function Tail - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String; - - procedure Tail - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space); - - function "*" - (Left : Natural; - Right : Character) return Unbounded_String; - - function "*" - (Left : Natural; - Right : String) return Unbounded_String; - - function "*" - (Left : Natural; - Right : Unbounded_String) return Unbounded_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - type Shared_String (Max_Length : Natural) is limited record - Counter : System.Atomic_Counters.Atomic_Counter; - -- Reference counter - - Last : Natural := 0; - Data : String (1 .. Max_Length); - -- Last is the index of last significant element of the Data. All - -- elements with larger indexes are currently insignificant. - end record; - - type Shared_String_Access is access all Shared_String; - - procedure Reference (Item : not null Shared_String_Access); - -- Increment reference counter - - procedure Unreference (Item : not null Shared_String_Access); - -- Decrement reference counter, deallocate Item when counter goes to zero - - function Can_Be_Reused - (Item : not null Shared_String_Access; - Length : Natural) return Boolean; - -- Returns True if Shared_String can be reused. There are two criteria when - -- Shared_String can be reused: its reference counter must be one (thus - -- Shared_String is owned exclusively) and its size is sufficient to - -- store string with specified length effectively. - - function Allocate - (Max_Length : Natural) return not null Shared_String_Access; - -- Allocates new Shared_String with at least specified maximum length. - -- Actual maximum length of the allocated Shared_String can be slightly - -- greater. Returns reference to Empty_Shared_String when requested length - -- is zero. - - Empty_Shared_String : aliased Shared_String (0); - - function To_Unbounded (S : String) return Unbounded_String - renames To_Unbounded_String; - -- This renames are here only to be used in the pragma Stream_Convert - - type Unbounded_String is new AF.Controlled with record - Reference : not null Shared_String_Access := Empty_Shared_String'Access; - end record; - - pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); - -- Provide stream routines without dragging in Ada.Streams - - pragma Finalize_Storage_Only (Unbounded_String); - -- Finalization is required only for freeing storage - - overriding procedure Initialize (Object : in out Unbounded_String); - overriding procedure Adjust (Object : in out Unbounded_String); - overriding procedure Finalize (Object : in out Unbounded_String); - - Null_Unbounded_String : constant Unbounded_String := - (AF.Controlled with - Reference => Empty_Shared_String'Access); - -end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb.adb b/gcc/ada/a-strunb.adb deleted file mode 100644 index b4c3cdd..0000000 --- a/gcc/ada/a-strunb.adb +++ /dev/null @@ -1,1073 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -with Ada.Strings.Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Unbounded is - - use Ada.Finalization; - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String - is - L_Length : constant Natural := Left.Last; - R_Length : constant Natural := Right.Last; - Result : Unbounded_String; - - begin - Result.Last := L_Length + R_Length; - - Result.Reference := new String (1 .. Result.Last); - - Result.Reference (1 .. L_Length) := - Left.Reference (1 .. Left.Last); - Result.Reference (L_Length + 1 .. Result.Last) := - Right.Reference (1 .. Right.Last); - - return Result; - end "&"; - - function "&" - (Left : Unbounded_String; - Right : String) return Unbounded_String - is - L_Length : constant Natural := Left.Last; - Result : Unbounded_String; - - begin - Result.Last := L_Length + Right'Length; - - Result.Reference := new String (1 .. Result.Last); - - Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); - Result.Reference (L_Length + 1 .. Result.Last) := Right; - - return Result; - end "&"; - - function "&" - (Left : String; - Right : Unbounded_String) return Unbounded_String - is - R_Length : constant Natural := Right.Last; - Result : Unbounded_String; - - begin - Result.Last := Left'Length + R_Length; - - Result.Reference := new String (1 .. Result.Last); - - Result.Reference (1 .. Left'Length) := Left; - Result.Reference (Left'Length + 1 .. Result.Last) := - Right.Reference (1 .. Right.Last); - - return Result; - end "&"; - - function "&" - (Left : Unbounded_String; - Right : Character) return Unbounded_String - is - Result : Unbounded_String; - - begin - Result.Last := Left.Last + 1; - - Result.Reference := new String (1 .. Result.Last); - - Result.Reference (1 .. Result.Last - 1) := - Left.Reference (1 .. Left.Last); - Result.Reference (Result.Last) := Right; - - return Result; - end "&"; - - function "&" - (Left : Character; - Right : Unbounded_String) return Unbounded_String - is - Result : Unbounded_String; - - begin - Result.Last := Right.Last + 1; - - Result.Reference := new String (1 .. Result.Last); - Result.Reference (1) := Left; - Result.Reference (2 .. Result.Last) := - Right.Reference (1 .. Right.Last); - return Result; - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Character) return Unbounded_String - is - Result : Unbounded_String; - - begin - Result.Last := Left; - - Result.Reference := new String (1 .. Left); - for J in Result.Reference'Range loop - Result.Reference (J) := Right; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : String) return Unbounded_String - is - Len : constant Natural := Right'Length; - K : Positive; - Result : Unbounded_String; - - begin - Result.Last := Left * Len; - - Result.Reference := new String (1 .. Result.Last); - - K := 1; - for J in 1 .. Left loop - Result.Reference (K .. K + Len - 1) := Right; - K := K + Len; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_String) return Unbounded_String - is - Len : constant Natural := Right.Last; - K : Positive; - Result : Unbounded_String; - - begin - Result.Last := Left * Len; - - Result.Reference := new String (1 .. Result.Last); - - K := 1; - for J in 1 .. Left loop - Result.Reference (K .. K + Len - 1) := - Right.Reference (1 .. Right.Last); - K := K + Len; - end loop; - - return Result; - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); - end "<"; - - function "<" - (Left : Unbounded_String; - Right : String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) < Right; - end "<"; - - function "<" - (Left : String; - Right : Unbounded_String) return Boolean - is - begin - return Left < Right.Reference (1 .. Right.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); - end "<="; - - function "<=" - (Left : Unbounded_String; - Right : String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) <= Right; - end "<="; - - function "<=" - (Left : String; - Right : Unbounded_String) return Boolean - is - begin - return Left <= Right.Reference (1 .. Right.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); - end "="; - - function "=" - (Left : Unbounded_String; - Right : String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) = Right; - end "="; - - function "=" - (Left : String; - Right : Unbounded_String) return Boolean - is - begin - return Left = Right.Reference (1 .. Right.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); - end ">"; - - function ">" - (Left : Unbounded_String; - Right : String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) > Right; - end ">"; - - function ">" - (Left : String; - Right : Unbounded_String) return Boolean - is - begin - return Left > Right.Reference (1 .. Right.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); - end ">="; - - function ">=" - (Left : Unbounded_String; - Right : String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) >= Right; - end ">="; - - function ">=" - (Left : String; - Right : Unbounded_String) return Boolean - is - begin - return Left >= Right.Reference (1 .. Right.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_String) is - begin - -- Copy string, except we do not copy the statically allocated null - -- string since it can never be deallocated. Note that we do not copy - -- extra string room here to avoid dragging unused allocated memory. - - if Object.Reference /= Null_String'Access then - Object.Reference := new String'(Object.Reference (1 .. Object.Last)); - end if; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_String; - New_Item : Unbounded_String) - is - begin - Realloc_For_Chunk (Source, New_Item.Last); - Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := - New_Item.Reference (1 .. New_Item.Last); - Source.Last := Source.Last + New_Item.Last; - end Append; - - procedure Append - (Source : in out Unbounded_String; - New_Item : String) - is - begin - Realloc_For_Chunk (Source, New_Item'Length); - Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := - New_Item; - Source.Last := Source.Last + New_Item'Length; - end Append; - - procedure Append - (Source : in out Unbounded_String; - New_Item : Character) - is - begin - Realloc_For_Chunk (Source, 1); - Source.Reference (Source.Last + 1) := New_Item; - Source.Last := Source.Last + 1; - end Append; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - begin - return - Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural - is - begin - return - Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural - is - begin - return Search.Count (Source.Reference (1 .. Source.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_String; - From : Positive; - Through : Natural) return Unbounded_String - is - begin - return - To_Unbounded_String - (Fixed.Delete (Source.Reference (1 .. Source.Last), From, Through)); - end Delete; - - procedure Delete - (Source : in out Unbounded_String; - From : Positive; - Through : Natural) - is - begin - if From > Through then - null; - - elsif From < Source.Reference'First or else Through > Source.Last then - raise Index_Error; - - else - declare - Len : constant Natural := Through - From + 1; - - begin - Source.Reference (From .. Source.Last - Len) := - Source.Reference (Through + 1 .. Source.Last); - Source.Last := Source.Last - Len; - end; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_String; - Index : Positive) return Character - is - begin - if Index <= Source.Last then - return Source.Reference (Index); - else - raise Strings.Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_String) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (String, String_Access); - - begin - -- Note: Don't try to free statically allocated null string - - if Object.Reference /= Null_String'Access then - Deallocate (Object.Reference); - Object.Reference := Null_Unbounded_String.Reference; - Object.Last := 0; - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Search.Find_Token - (Source.Reference (From .. Source.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Search.Find_Token - (Source.Reference (1 .. Source.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (String, String_Access); - - begin - -- Note: Do not try to free statically allocated null string - - if X /= Null_Unbounded_String.Reference then - Deallocate (X); - end if; - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); - end Head; - - procedure Head - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space) - is - Old : String_Access := Source.Reference; - begin - Source.Reference := - new String'(Fixed.Head (Source.Reference (1 .. Source.Last), - Count, Pad)); - Source.Last := Source.Reference'Length; - Free (Old); - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Strings.Direction := Strings.Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - begin - return Search.Index - (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - begin - return Search.Index - (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return Search.Index - (Source.Reference (1 .. Source.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural - is - begin - return Search.Index - (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural - is - begin - return Search.Index - (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - return Search.Index - (Source.Reference (1 .. Source.Last), Set, From, Test, Going); - end Index; - - function Index_Non_Blank - (Source : Unbounded_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return - Search.Index_Non_Blank - (Source.Reference (1 .. Source.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - return - Search.Index_Non_Blank - (Source.Reference (1 .. Source.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_String) is - begin - Object.Reference := Null_Unbounded_String.Reference; - Object.Last := 0; - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_String; - Before : Positive; - New_Item : String) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Insert (Source.Reference (1 .. Source.Last), Before, New_Item)); - end Insert; - - procedure Insert - (Source : in out Unbounded_String; - Before : Positive; - New_Item : String) - is - begin - if Before not in Source.Reference'First .. Source.Last + 1 then - raise Index_Error; - end if; - - Realloc_For_Chunk (Source, New_Item'Length); - - Source.Reference - (Before + New_Item'Length .. Source.Last + New_Item'Length) := - Source.Reference (Before .. Source.Last); - - Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; - Source.Last := Source.Last + New_Item'Length; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_String) return Natural is - begin - return Source.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_String; - Position : Positive; - New_Item : String) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Overwrite - (Source.Reference (1 .. Source.Last), Position, New_Item)); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_String; - Position : Positive; - New_Item : String) - is - NL : constant Natural := New_Item'Length; - begin - if Position <= Source.Last - NL + 1 then - Source.Reference (Position .. Position + NL - 1) := New_Item; - else - declare - Old : String_Access := Source.Reference; - begin - Source.Reference := new String' - (Fixed.Overwrite - (Source.Reference (1 .. Source.Last), Position, New_Item)); - Source.Last := Source.Reference'Length; - Free (Old); - end; - end if; - end Overwrite; - - ----------------------- - -- Realloc_For_Chunk -- - ----------------------- - - procedure Realloc_For_Chunk - (Source : in out Unbounded_String; - Chunk_Size : Natural) - is - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - S_Length : constant Natural := Source.Reference'Length; - - begin - if Chunk_Size > S_Length - Source.Last then - declare - New_Size : constant Positive := - S_Length + Chunk_Size + (S_Length / Growth_Factor); - - New_Rounded_Up_Size : constant Positive := - ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc; - - Tmp : constant String_Access := - new String (1 .. New_Rounded_Up_Size); - - begin - Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); - Free (Source.Reference); - Source.Reference := Tmp; - end; - end if; - end Realloc_For_Chunk; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_String; - Index : Positive; - By : Character) - is - begin - if Index <= Source.Last then - Source.Reference (Index) := By; - else - raise Strings.Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural; - By : String) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Replace_Slice - (Source.Reference (1 .. Source.Last), Low, High, By)); - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_String; - Low : Positive; - High : Natural; - By : String) - is - Old : String_Access := Source.Reference; - begin - Source.Reference := new String' - (Fixed.Replace_Slice - (Source.Reference (1 .. Source.Last), Low, High, By)); - Source.Last := Source.Reference'Length; - Free (Old); - end Replace_Slice; - - -------------------------- - -- Set_Unbounded_String -- - -------------------------- - - procedure Set_Unbounded_String - (Target : out Unbounded_String; - Source : String) - is - Old : String_Access := Target.Reference; - begin - Target.Last := Source'Length; - Target.Reference := new String (1 .. Source'Length); - Target.Reference.all := Source; - Free (Old); - end Set_Unbounded_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - return Source.Reference (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String is - begin - return To_Unbounded_String - (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); - end Tail; - - procedure Tail - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space) - is - Old : String_Access := Source.Reference; - begin - Source.Reference := new String' - (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); - Source.Last := Source.Reference'Length; - Free (Old); - end Tail; - - --------------- - -- To_String -- - --------------- - - function To_String (Source : Unbounded_String) return String is - begin - return Source.Reference (1 .. Source.Last); - end To_String; - - ------------------------- - -- To_Unbounded_String -- - ------------------------- - - function To_Unbounded_String (Source : String) return Unbounded_String is - Result : Unbounded_String; - begin - -- Do not allocate an empty string: keep the default - - if Source'Length > 0 then - Result.Last := Source'Length; - Result.Reference := new String (1 .. Source'Length); - Result.Reference.all := Source; - end if; - - return Result; - end To_Unbounded_String; - - function To_Unbounded_String - (Length : Natural) return Unbounded_String - is - Result : Unbounded_String; - - begin - -- Do not allocate an empty string: keep the default - - if Length > 0 then - Result.Last := Length; - Result.Reference := new String (1 .. Length); - end if; - - return Result; - end To_Unbounded_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); - end Translate; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping) - is - begin - Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); - end Translate; - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); - end Translate; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function) - is - begin - Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); - end Trim; - - procedure Trim - (Source : in out Unbounded_String; - Side : Trim_End) - is - Old : String_Access := Source.Reference; - begin - Source.Reference := new String' - (Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); - Source.Last := Source.Reference'Length; - Free (Old); - end Trim; - - function Trim - (Source : Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String - is - begin - return To_Unbounded_String - (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); - end Trim; - - procedure Trim - (Source : in out Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) - is - Old : String_Access := Source.Reference; - begin - Source.Reference := new String' - (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); - Source.Last := Source.Reference'Length; - Free (Old); - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return Unbounded_String - is - begin - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - return To_Unbounded_String (Source.Reference.all (Low .. High)); - end if; - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_String; - Target : out Unbounded_String; - Low : Positive; - High : Natural) - is - begin - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - Target := To_Unbounded_String (Source.Reference.all (Low .. High)); - end if; - end Unbounded_Slice; - -end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-strunb.ads b/gcc/ada/a-strunb.ads deleted file mode 100644 index 3341466..0000000 --- a/gcc/ada/a-strunb.ads +++ /dev/null @@ -1,437 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Maps; -with Ada.Finalization; - -package Ada.Strings.Unbounded is - pragma Preelaborate; - - type Unbounded_String is private; - pragma Preelaborable_Initialization (Unbounded_String); - - Null_Unbounded_String : constant Unbounded_String; - - function Length (Source : Unbounded_String) return Natural; - - type String_Access is access all String; - - procedure Free (X : in out String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_String - (Source : String) return Unbounded_String; - - function To_Unbounded_String - (Length : Natural) return Unbounded_String; - - function To_String (Source : Unbounded_String) return String; - - procedure Set_Unbounded_String - (Target : out Unbounded_String; - Source : String); - pragma Ada_05 (Set_Unbounded_String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : Unbounded_String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : String); - - procedure Append - (Source : in out Unbounded_String; - New_Item : Character); - - function "&" - (Left : Unbounded_String; - Right : Unbounded_String) return Unbounded_String; - - function "&" - (Left : Unbounded_String; - Right : String) return Unbounded_String; - - function "&" - (Left : String; - Right : Unbounded_String) return Unbounded_String; - - function "&" - (Left : Unbounded_String; - Right : Character) return Unbounded_String; - - function "&" - (Left : Character; - Right : Unbounded_String) return Unbounded_String; - - function Element - (Source : Unbounded_String; - Index : Positive) return Character; - - procedure Replace_Element - (Source : in out Unbounded_String; - Index : Positive; - By : Character); - - function Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return String; - - function Unbounded_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural) return Unbounded_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_String; - Target : out Unbounded_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "=" - (Left : String; - Right : Unbounded_String) return Boolean; - - function "<" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "<" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "<" - (Left : String; - Right : Unbounded_String) return Boolean; - - function "<=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function "<=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function "<=" - (Left : String; - Right : Unbounded_String) return Boolean; - - function ">" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function ">" - (Left : Unbounded_String; - Right : String) return Boolean; - - function ">" - (Left : String; - Right : Unbounded_String) return Boolean; - - function ">=" - (Left : Unbounded_String; - Right : Unbounded_String) return Boolean; - - function ">=" - (Left : Unbounded_String; - Right : String) return Boolean; - - function ">=" - (Left : String; - Right : Unbounded_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Index - (Source : Unbounded_String; - Pattern : String; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_String; - Pattern : String; - From : Positive; - Going : Direction := Forward; - Mapping : Maps.Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; - - function Count - (Source : Unbounded_String; - Pattern : String; - Mapping : Maps.Character_Mapping_Function) return Natural; - - function Count - (Source : Unbounded_String; - Set : Maps.Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_String; - Set : Maps.Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping) return Unbounded_String; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping); - - function Translate - (Source : Unbounded_String; - Mapping : Maps.Character_Mapping_Function) return Unbounded_String; - - procedure Translate - (Source : in out Unbounded_String; - Mapping : Maps.Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_String; - Low : Positive; - High : Natural; - By : String) return Unbounded_String; - - procedure Replace_Slice - (Source : in out Unbounded_String; - Low : Positive; - High : Natural; - By : String); - - function Insert - (Source : Unbounded_String; - Before : Positive; - New_Item : String) return Unbounded_String; - - procedure Insert - (Source : in out Unbounded_String; - Before : Positive; - New_Item : String); - - function Overwrite - (Source : Unbounded_String; - Position : Positive; - New_Item : String) return Unbounded_String; - - procedure Overwrite - (Source : in out Unbounded_String; - Position : Positive; - New_Item : String); - - function Delete - (Source : Unbounded_String; - From : Positive; - Through : Natural) return Unbounded_String; - - procedure Delete - (Source : in out Unbounded_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_String; - Side : Trim_End) return Unbounded_String; - - procedure Trim - (Source : in out Unbounded_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set) return Unbounded_String; - - procedure Trim - (Source : in out Unbounded_String; - Left : Maps.Character_Set; - Right : Maps.Character_Set); - - function Head - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String; - - procedure Head - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space); - - function Tail - (Source : Unbounded_String; - Count : Natural; - Pad : Character := Space) return Unbounded_String; - - procedure Tail - (Source : in out Unbounded_String; - Count : Natural; - Pad : Character := Space); - - function "*" - (Left : Natural; - Right : Character) return Unbounded_String; - - function "*" - (Left : Natural; - Right : String) return Unbounded_String; - - function "*" - (Left : Natural; - Right : Unbounded_String) return Unbounded_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - Null_String : aliased String := ""; - - function To_Unbounded (S : String) return Unbounded_String - renames To_Unbounded_String; - - type Unbounded_String is new AF.Controlled with record - Reference : String_Access := Null_String'Access; - Last : Natural := 0; - end record; - -- The Unbounded_String is using a buffered implementation to increase - -- speed of the Append/Delete/Insert procedures. The Reference string - -- pointer above contains the current string value and extra room at the - -- end to be used by the next Append routine. Last is the index of the - -- string ending character. So the current string value is really - -- Reference (1 .. Last). - - pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); - -- Provide stream routines without dragging in Ada.Streams - - pragma Finalize_Storage_Only (Unbounded_String); - -- Finalization is required only for freeing storage - - procedure Initialize (Object : in out Unbounded_String); - procedure Adjust (Object : in out Unbounded_String); - procedure Finalize (Object : in out Unbounded_String); - - procedure Realloc_For_Chunk - (Source : in out Unbounded_String; - Chunk_Size : Natural); - pragma Inline (Realloc_For_Chunk); - -- Adjust the size allocated for the string. Add at least Chunk_Size so it - -- is safe to add a string of this size at the end of the current content. - -- The real size allocated for the string is Chunk_Size + x of the current - -- string size. This buffered handling makes the Append unbounded string - -- routines very fast. This spec is in the private part so that it can be - -- accessed from children (e.g. from Unbounded.Text_IO). - - Null_Unbounded_String : constant Unbounded_String := - (AF.Controlled with - Reference => Null_String'Access, - Last => 0); -end Ada.Strings.Unbounded; diff --git a/gcc/ada/a-ststio.adb b/gcc/ada/a-ststio.adb deleted file mode 100644 index fb3b59c..0000000 --- a/gcc/ada/a-ststio.adb +++ /dev/null @@ -1,490 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R E A M S . S T R E A M _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; - -with System; use System; -with System.Communication; use System.Communication; -with System.File_IO; -with System.Soft_Links; -with System.CRTL; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body Ada.Streams.Stream_IO is - - package FIO renames System.File_IO; - package SSL renames System.Soft_Links; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); - use type FCB.File_Mode; - use type FCB.Shared_Status_Type; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Set_Position (File : File_Type); - -- Sets file position pointer according to value of current index - - ------------------- - -- AFCB_Allocate -- - ------------------- - - function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is - pragma Warnings (Off, Control_Block); - begin - return new Stream_AFCB; - end AFCB_Allocate; - - ---------------- - -- AFCB_Close -- - ---------------- - - -- No special processing required for closing Stream_IO file - - procedure AFCB_Close (File : not null access Stream_AFCB) is - pragma Warnings (Off, File); - begin - null; - end AFCB_Close; - - --------------- - -- AFCB_Free -- - --------------- - - procedure AFCB_Free (File : not null access Stream_AFCB) is - type FCB_Ptr is access all Stream_AFCB; - FT : FCB_Ptr := FCB_Ptr (File); - - procedure Free is new Ada.Unchecked_Deallocation (Stream_AFCB, FCB_Ptr); - - begin - Free (FT); - end AFCB_Free; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out File_Type) is - begin - FIO.Close (AP (File)'Unrestricted_Access); - end Close; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := "") - is - Dummy_File_Control_Block : Stream_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'S', - Creat => True, - Text => False); - File.Last_Op := Op_Write; - end Create; - - ------------ - -- Delete -- - ------------ - - procedure Delete (File : in out File_Type) is - begin - FIO.Delete (AP (File)'Unrestricted_Access); - end Delete; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : File_Type) return Boolean is - begin - FIO.Check_Read_Status (AP (File)); - return File.Index > Size (File); - end End_Of_File; - - ----------- - -- Flush -- - ----------- - - procedure Flush (File : File_Type) is - begin - FIO.Flush (AP (File)); - end Flush; - - ---------- - -- Form -- - ---------- - - function Form (File : File_Type) return String is - begin - return FIO.Form (AP (File)); - end Form; - - ----------- - -- Index -- - ----------- - - function Index (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Index; - end Index; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (File : File_Type) return Boolean is - begin - return FIO.Is_Open (AP (File)); - end Is_Open; - - ---------- - -- Mode -- - ---------- - - function Mode (File : File_Type) return File_Mode is - begin - return To_SIO (FIO.Mode (AP (File))); - end Mode; - - ---------- - -- Name -- - ---------- - - function Name (File : File_Type) return String is - begin - return FIO.Name (AP (File)); - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := "") - is - Dummy_File_Control_Block : Stream_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'S', - Creat => False, - Text => False); - - -- Ensure that the stream index is set properly (e.g., for Append_File) - - Reset (File, Mode); - - -- Set last operation. The purpose here is to ensure proper handling - -- of the initial operation. In general, a write after a read requires - -- resetting and doing a seek, so we set the last operation as Read - -- for an In_Out file, but for an Out file we set the last operation - -- to Op_Write, since in this case it is not necessary to do a seek - -- (and furthermore there are situations (such as the case of writing - -- a sequential Posix FIFO file) where the lseek would cause problems. - - File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read); - end Open; - - ---------- - -- Read -- - ---------- - - procedure Read - (File : File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset; - From : Positive_Count) - is - begin - Set_Index (File, From); - Read (File, Item, Last); - end Read; - - procedure Read - (File : File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Nread : size_t; - - begin - FIO.Check_Read_Status (AP (File)); - - -- If last operation was not a read, or if in file sharing mode, - -- then reset the physical pointer of the file to match the index - -- We lock out task access over the two operations in this case. - - if File.Last_Op /= Op_Read - or else File.Shared_Status = FCB.Yes - then - Locked_Processing : begin - SSL.Lock_Task.all; - Set_Position (File); - FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread); - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked_Processing; - - else - FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread); - end if; - - File.Index := File.Index + Count (Nread); - File.Last_Op := Op_Read; - Last := Last_Index (Item'First, Nread); - end Read; - - -- This version of Read is the primitive operation on the underlying - -- Stream type, used when a Stream_IO file is treated as a Stream - - procedure Read - (File : in out Stream_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - begin - Read (File'Unchecked_Access, Item, Last); - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset (File : in out File_Type; Mode : File_Mode) is - begin - FIO.Check_File_Open (AP (File)); - - -- Reset file index to start of file for read/write cases. For - -- the append case, the Set_Mode call repositions the index. - - File.Index := 1; - Set_Mode (File, Mode); - end Reset; - - procedure Reset (File : in out File_Type) is - begin - Reset (File, To_SIO (File.Mode)); - end Reset; - - --------------- - -- Set_Index -- - --------------- - - procedure Set_Index (File : File_Type; To : Positive_Count) is - begin - FIO.Check_File_Open (AP (File)); - File.Index := Count (To); - File.Last_Op := Op_Other; - end Set_Index; - - -------------- - -- Set_Mode -- - -------------- - - procedure Set_Mode (File : in out File_Type; Mode : File_Mode) is - begin - FIO.Check_File_Open (AP (File)); - - -- If we are switching from read to write, or vice versa, and - -- we are not already open in update mode, then reopen in update - -- mode now. Note that we can use Inout_File as the mode for the - -- call since File_IO handles all modes for all file types. - - if ((File.Mode = FCB.In_File) /= (Mode = In_File)) - and then not File.Update_Mode - then - FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File); - File.Update_Mode := True; - end if; - - -- Set required mode and position to end of file if append mode - - File.Mode := To_FCB (Mode); - FIO.Append_Set (AP (File)); - - if File.Mode = FCB.Append_File then - if Standard'Address_Size = 64 then - File.Index := Count (ftell64 (File.Stream)) + 1; - else - File.Index := Count (ftell (File.Stream)) + 1; - end if; - end if; - - File.Last_Op := Op_Other; - end Set_Mode; - - ------------------ - -- Set_Position -- - ------------------ - - procedure Set_Position (File : File_Type) is - use type System.CRTL.int64; - R : int; - begin - R := fseek64 (File.Stream, System.CRTL.int64 (File.Index) - 1, SEEK_SET); - - if R /= 0 then - raise Use_Error; - end if; - end Set_Position; - - ---------- - -- Size -- - ---------- - - function Size (File : File_Type) return Count is - begin - FIO.Check_File_Open (AP (File)); - - if File.File_Size = -1 then - File.Last_Op := Op_Other; - - if fseek64 (File.Stream, 0, SEEK_END) /= 0 then - raise Device_Error; - end if; - - File.File_Size := Stream_Element_Offset (ftell64 (File.Stream)); - - if File.File_Size = -1 then - raise Use_Error; - end if; - end if; - - return Count (File.File_Size); - end Size; - - ------------ - -- Stream -- - ------------ - - function Stream (File : File_Type) return Stream_Access is - begin - FIO.Check_File_Open (AP (File)); - return Stream_Access (File); - end Stream; - - ----------- - -- Write -- - ----------- - - procedure Write - (File : File_Type; - Item : Stream_Element_Array; - To : Positive_Count) - is - begin - Set_Index (File, To); - Write (File, Item); - end Write; - - procedure Write - (File : File_Type; - Item : Stream_Element_Array) - is - begin - FIO.Check_Write_Status (AP (File)); - - -- If last operation was not a write, or if in file sharing mode, - -- then reset the physical pointer of the file to match the index - -- We lock out task access over the two operations in this case. - - if File.Last_Op /= Op_Write - or else File.Shared_Status = FCB.Yes - then - Locked_Processing : begin - SSL.Lock_Task.all; - Set_Position (File); - FIO.Write_Buf (AP (File), Item'Address, Item'Length); - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked_Processing; - - else - FIO.Write_Buf (AP (File), Item'Address, Item'Length); - end if; - - File.Index := File.Index + Item'Length; - File.Last_Op := Op_Write; - File.File_Size := -1; - end Write; - - -- This version of Write is the primitive operation on the underlying - -- Stream type, used when a Stream_IO file is treated as a Stream - - procedure Write - (File : in out Stream_AFCB; - Item : Ada.Streams.Stream_Element_Array) - is - begin - Write (File'Unchecked_Access, Item); - end Write; - -end Ada.Streams.Stream_IO; diff --git a/gcc/ada/a-ststio.ads b/gcc/ada/a-ststio.ads deleted file mode 100644 index 4049163..0000000 --- a/gcc/ada/a-ststio.ads +++ /dev/null @@ -1,223 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R E A M S . S T R E A M _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with System.File_Control_Block; - -package Ada.Streams.Stream_IO is - pragma Preelaborate; - - type Stream_Access is access all Root_Stream_Type'Class; - - type File_Type is limited private; - - type File_Mode is (In_File, Out_File, Append_File); - - -- The following representation clause allows the use of unchecked - -- conversion for rapid translation between the File_Mode type - -- used in this package and System.File_IO. - - for File_Mode use - (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) - Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) - Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) - - type Count is new Stream_Element_Offset - range 0 .. Stream_Element_Offset'Last; - - subtype Positive_Count is Count range 1 .. Count'Last; - -- Index into file, in stream elements - - --------------------- - -- File Management -- - --------------------- - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := ""); - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - procedure Reset (File : in out File_Type; Mode : File_Mode); - procedure Reset (File : in out File_Type); - - function Mode (File : File_Type) return File_Mode; - function Name (File : File_Type) return String; - function Form (File : File_Type) return String; - - function Is_Open (File : File_Type) return Boolean; - function End_Of_File (File : File_Type) return Boolean; - - function Stream (File : File_Type) return Stream_Access; - - ----------------------------- - -- Input-Output Operations -- - ----------------------------- - - procedure Read - (File : File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset; - From : Positive_Count); - - procedure Read - (File : File_Type; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset); - - procedure Write - (File : File_Type; - Item : Stream_Element_Array; - To : Positive_Count); - - procedure Write - (File : File_Type; - Item : Stream_Element_Array); - - ---------------------------------------- - -- Operations on Position within File -- - ---------------------------------------- - - procedure Set_Index (File : File_Type; To : Positive_Count); - - function Index (File : File_Type) return Positive_Count; - function Size (File : File_Type) return Count; - - procedure Set_Mode (File : in out File_Type; Mode : File_Mode); - - -- Note: The parameter file is IN OUT in the RM, but this is clearly - -- an oversight, and was intended to be IN, see AI95-00057. - - procedure Flush (File : File_Type); - - ---------------- - -- Exceptions -- - ---------------- - - Status_Error : exception renames IO_Exceptions.Status_Error; - Mode_Error : exception renames IO_Exceptions.Mode_Error; - Name_Error : exception renames IO_Exceptions.Name_Error; - Use_Error : exception renames IO_Exceptions.Use_Error; - Device_Error : exception renames IO_Exceptions.Device_Error; - End_Error : exception renames IO_Exceptions.End_Error; - Data_Error : exception renames IO_Exceptions.Data_Error; - -private - - -- The following procedures have a File_Type formal of mode IN OUT because - -- they may close the original file. The Close operation may raise an - -- exception, but in that case we want any assignment to the formal to - -- be effective anyway, so it must be passed by reference (or the caller - -- will be left with a dangling pointer). - - pragma Export_Procedure - (Internal => Close, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Delete, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type), - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type, File_Mode), - Mechanism => (File => Reference)); - pragma Export_Procedure - (Internal => Set_Mode, - External => "", - Mechanism => (File => Reference)); - - package FCB renames System.File_Control_Block; - - ----------------------------- - -- Stream_IO Control Block -- - ----------------------------- - - type Operation is (Op_Read, Op_Write, Op_Other); - -- Type used to record last operation (to optimize sequential operations) - - type Stream_AFCB is new FCB.AFCB with record - Index : Count := 1; - -- Current Index value - - File_Size : Stream_Element_Offset := -1; - -- Cached value of File_Size, so that we do not keep recomputing it - -- when not necessary (otherwise End_Of_File becomes gruesomely slow). - -- A value of minus one means that there is no cached value. - - Last_Op : Operation := Op_Other; - -- Last operation performed on file, used to avoid unnecessary - -- repositioning between successive read or write operations. - - Update_Mode : Boolean := False; - -- Set if the mode is changed from write to read or vice versa. - -- Indicates that the file has been reopened in update mode. - - end record; - - type File_Type is access all Stream_AFCB; - - overriding function AFCB_Allocate - (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr; - - overriding procedure AFCB_Close (File : not null access Stream_AFCB); - overriding procedure AFCB_Free (File : not null access Stream_AFCB); - - overriding procedure Read - (File : in out Stream_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Read operation used when Stream_IO file is treated directly as Stream - - overriding procedure Write - (File : in out Stream_AFCB; - Item : Ada.Streams.Stream_Element_Array); - -- Write operation used when Stream_IO file is treated directly as Stream - -end Ada.Streams.Stream_IO; diff --git a/gcc/ada/a-stunau-shared.adb b/gcc/ada/a-stunau-shared.adb deleted file mode 100644 index 6ca4162..0000000 --- a/gcc/ada/a-stunau-shared.adb +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Unbounded.Aux is - - ---------------- - -- Get_String -- - ---------------- - - procedure Get_String - (U : Unbounded_String; - S : out Big_String_Access; - L : out Natural) - is - X : aliased Big_String; - for X'Address use U.Reference.Data'Address; - begin - S := X'Unchecked_Access; - L := U.Reference.Last; - end Get_String; - - ---------------- - -- Set_String -- - ---------------- - - procedure Set_String (UP : in out Unbounded_String; S : String_Access) is - X : String_Access := S; - - begin - Set_Unbounded_String (UP, S.all); - Free (X); - end Set_String; - -end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/a-stunau.adb b/gcc/ada/a-stunau.adb deleted file mode 100644 index c6d2bc4..0000000 --- a/gcc/ada/a-stunau.adb +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Unbounded.Aux is - - ---------------- - -- Get_String -- - ---------------- - - procedure Get_String - (U : Unbounded_String; - S : out Big_String_Access; - L : out Natural) - is - X : aliased Big_String; - for X'Address use U.Reference.all'Address; - - begin - S := X'Unchecked_Access; - L := U.Last; - end Get_String; - - ---------------- - -- Set_String -- - ---------------- - - procedure Set_String (UP : in out Unbounded_String; S : String_Access) is - begin - Finalize (UP); - UP.Reference := S; - UP.Last := UP.Reference'Length; - end Set_String; - -end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/a-stunau.ads b/gcc/ada/a-stunau.ads deleted file mode 100644 index 06cffc5..0000000 --- a/gcc/ada/a-stunau.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This child package of Ada.Strings.Unbounded provides some specialized --- access functions which are intended to allow more efficient use of the --- facilities of Ada.Strings.Unbounded, particularly by other layered --- utilities (such as GNAT.SPITBOL.Patterns). - -package Ada.Strings.Unbounded.Aux is - pragma Preelaborate; - - subtype Big_String is String (1 .. Positive'Last); - pragma Suppress_Initialization (Big_String); - -- Type used to obtain string access to given address. Initialization is - -- suppressed, since we never want to have variables of this type, and - -- we never want to attempt initialiazation of virtual variables of this - -- type (e.g. when pragma Normalize_Scalars is used). - - type Big_String_Access is access all Big_String; - for Big_String_Access'Storage_Size use 0; - -- We use this access type to pass a pointer to an area of storage to be - -- accessed as a string. Of course when this pointer is used, it is the - -- responsibility of the accessor to ensure proper bounds. The storage - -- size clause ensures we do not allocate variables of this type. - - procedure Get_String - (U : Unbounded_String; - S : out Big_String_Access; - L : out Natural); - pragma Inline (Get_String); - -- This procedure returns the internal string pointer used in the - -- representation of an unbounded string as well as the actual current - -- length (which may be less than S.all'Length because in general there - -- can be extra space assigned). The characters of this string may be - -- not be modified via the returned pointer, and are valid only as - -- long as the original unbounded string is not accessed or modified. - -- - -- This procedure is much more efficient than the use of To_String - -- since it avoids the need to copy the string. The lower bound of the - -- referenced string returned by this call is always one, so the actual - -- string data is always accessible as S (1 .. L). - - procedure Set_String (UP : in out Unbounded_String; S : String_Access); - pragma Inline (Set_String); - -- This version of Set_Unbounded_String takes a string access value, rather - -- than a string. The lower bound of the string value is required to be - -- one, and this requirement is not checked. - -end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/a-stunha.adb b/gcc/ada/a-stunha.adb deleted file mode 100644 index 064a342..0000000 --- a/gcc/ada/a-stunha.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Unbounded.Hash - (Key : Unbounded_String) return Containers.Hash_Type -is - use Ada.Containers; - function Hash is new System.String_Hash.Hash - (Character, String, Hash_Type); -begin - return Hash (To_String (Key)); -end Ada.Strings.Unbounded.Hash; diff --git a/gcc/ada/a-stunha.ads b/gcc/ada/a-stunha.ads deleted file mode 100644 index 1e45bdb..0000000 --- a/gcc/ada/a-stunha.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -function Ada.Strings.Unbounded.Hash - (Key : Unbounded_String) return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Unbounded.Hash); diff --git a/gcc/ada/a-stuten.adb b/gcc/ada/a-stuten.adb deleted file mode 100644 index fc669b5..0000000 --- a/gcc/ada/a-stuten.adb +++ /dev/null @@ -1,209 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U T F _ E N C O D I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.UTF_Encoding is - use Interfaces; - - -------------- - -- Encoding -- - -------------- - - function Encoding - (Item : UTF_String; - Default : Encoding_Scheme := UTF_8) return Encoding_Scheme - is - begin - if Item'Length >= 2 then - if Item (Item'First .. Item'First + 1) = BOM_16BE then - return UTF_16BE; - - elsif Item (Item'First .. Item'First + 1) = BOM_16LE then - return UTF_16LE; - - elsif Item'Length >= 3 - and then Item (Item'First .. Item'First + 2) = BOM_8 - then - return UTF_8; - end if; - end if; - - return Default; - end Encoding; - - ----------------- - -- From_UTF_16 -- - ----------------- - - function From_UTF_16 - (Item : UTF_16_Wide_String; - Output_Scheme : UTF_XE_Encoding; - Output_BOM : Boolean := False) return UTF_String - is - BSpace : constant Natural := 2 * Boolean'Pos (Output_BOM); - Result : UTF_String (1 .. 2 * Item'Length + BSpace); - Len : Natural; - C : Unsigned_16; - Iptr : Natural; - - begin - if Output_BOM then - Result (1 .. 2) := - (if Output_Scheme = UTF_16BE then BOM_16BE else BOM_16LE); - Len := 2; - else - Len := 0; - end if; - - -- Skip input BOM - - Iptr := Item'First; - - if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then - Iptr := Iptr + 1; - end if; - - -- UTF-16BE case - - if Output_Scheme = UTF_16BE then - while Iptr <= Item'Last loop - C := To_Unsigned_16 (Item (Iptr)); - Result (Len + 1) := Character'Val (Shift_Right (C, 8)); - Result (Len + 2) := Character'Val (C and 16#00_FF#); - Len := Len + 2; - Iptr := Iptr + 1; - end loop; - - -- UTF-16LE case - - else - while Iptr <= Item'Last loop - C := To_Unsigned_16 (Item (Iptr)); - Result (Len + 1) := Character'Val (C and 16#00_FF#); - Result (Len + 2) := Character'Val (Shift_Right (C, 8)); - Len := Len + 2; - Iptr := Iptr + 1; - end loop; - end if; - - return Result (1 .. Len); - end From_UTF_16; - - -------------------------- - -- Raise_Encoding_Error -- - -------------------------- - - procedure Raise_Encoding_Error (Index : Natural) is - Val : constant String := Index'Img; - begin - raise Encoding_Error with - "bad input at Item (" & Val (Val'First + 1 .. Val'Last) & ')'; - end Raise_Encoding_Error; - - --------------- - -- To_UTF_16 -- - --------------- - - function To_UTF_16 - (Item : UTF_String; - Input_Scheme : UTF_XE_Encoding; - Output_BOM : Boolean := False) return UTF_16_Wide_String - is - Result : UTF_16_Wide_String (1 .. Item'Length / 2 + 1); - Len : Natural; - Iptr : Natural; - - begin - if Item'Length mod 2 /= 0 then - raise Encoding_Error with "UTF-16BE/LE string has odd length"; - end if; - - -- Deal with input BOM, skip if OK, error if bad BOM - - Iptr := Item'First; - - if Item'Length >= 2 then - if Item (Iptr .. Iptr + 1) = BOM_16BE then - if Input_Scheme = UTF_16BE then - Iptr := Iptr + 2; - else - Raise_Encoding_Error (Iptr); - end if; - - elsif Item (Iptr .. Iptr + 1) = BOM_16LE then - if Input_Scheme = UTF_16LE then - Iptr := Iptr + 2; - else - Raise_Encoding_Error (Iptr); - end if; - - elsif Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then - Raise_Encoding_Error (Iptr); - end if; - end if; - - -- Output BOM if specified - - if Output_BOM then - Result (1) := BOM_16 (1); - Len := 1; - else - Len := 0; - end if; - - -- UTF-16BE case - - if Input_Scheme = UTF_16BE then - while Iptr < Item'Last loop - Len := Len + 1; - Result (Len) := - Wide_Character'Val - (Character'Pos (Item (Iptr)) * 256 + - Character'Pos (Item (Iptr + 1))); - Iptr := Iptr + 2; - end loop; - - -- UTF-16LE case - - else - while Iptr < Item'Last loop - Len := Len + 1; - Result (Len) := - Wide_Character'Val - (Character'Pos (Item (Iptr)) + - Character'Pos (Item (Iptr + 1)) * 256); - Iptr := Iptr + 2; - end loop; - end if; - - return Result (1 .. Len); - end To_UTF_16; - -end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stuten.ads b/gcc/ada/a-stuten.ads deleted file mode 100644 index fba30df..0000000 --- a/gcc/ada/a-stuten.ads +++ /dev/null @@ -1,144 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U T F _ E N C O D I N G -- --- -- --- S p e c -- --- -- --- 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is one of the Ada 2012 package defined in AI05-0137-1. It is a parent --- package that contains declarations used in the child packages for handling --- UTF encoded strings. Note: this package is consistent with Ada 95, and may --- be used in Ada 95 or Ada 2005 mode. - -with Interfaces; -with Unchecked_Conversion; - -package Ada.Strings.UTF_Encoding is - pragma Pure (UTF_Encoding); - - subtype UTF_String is String; - -- Used to represent a string of 8-bit values containing a sequence of - -- values encoded in one of three ways (UTF-8, UTF-16BE, or UTF-16LE). - -- Typically used in connection with a Scheme parameter indicating which - -- of the encodings applies. This is not strictly a String value in the - -- sense defined in the Ada RM, but in practice type String accommodates - -- all possible 256 codes, and can be used to hold any sequence of 8-bit - -- codes. We use String directly rather than create a new type so that - -- all existing facilities for manipulating type String (e.g. the child - -- packages of Ada.Strings) are available for manipulation of UTF_Strings. - - type Encoding_Scheme is (UTF_8, UTF_16BE, UTF_16LE); - -- Used to specify which of three possible encodings apply to a UTF_String - - subtype UTF_8_String is String; - -- Similar to UTF_String but specifically represents a UTF-8 encoded string - - subtype UTF_16_Wide_String is Wide_String; - -- This is similar to UTF_8_String but is used to represent a Wide_String - -- value which is a sequence of 16-bit values encoded using UTF-16. Again - -- this is not strictly a Wide_String in the sense of the Ada RM, but the - -- type Wide_String can be used to represent a sequence of arbitrary 16-bit - -- values, and it is more convenient to use Wide_String than a new type. - - Encoding_Error : exception; - -- This exception is raised in the following situations: - -- a) A UTF encoded string contains an invalid encoding sequence - -- b) A UTF-16BE or UTF-16LE input string has an odd length - -- c) An incorrect character value is present in the Input string - -- d) The result for a Wide_Character output exceeds 16#FFFF# - -- The exception message has the index value where the error occurred. - - -- The BOM (BYTE_ORDER_MARK) values defined here are used at the start of - -- a string to indicate the encoding. The convention in this package is - -- that on input a correct BOM is ignored and an incorrect BOM causes an - -- Encoding_Error exception. On output, the output string may or may not - -- include a BOM depending on the setting of Output_BOM. - - BOM_8 : constant UTF_8_String := - Character'Val (16#EF#) & - Character'Val (16#BB#) & - Character'Val (16#BF#); - - BOM_16BE : constant UTF_String := - Character'Val (16#FE#) & - Character'Val (16#FF#); - - BOM_16LE : constant UTF_String := - Character'Val (16#FF#) & - Character'Val (16#FE#); - - BOM_16 : constant UTF_16_Wide_String := - (1 => Wide_Character'Val (16#FEFF#)); - - function Encoding - (Item : UTF_String; - Default : Encoding_Scheme := UTF_8) return Encoding_Scheme; - -- This function inspects a UTF_String value to determine whether it - -- starts with a BOM for UTF-8, UTF-16BE, or UTF_16LE. If so, the result - -- is the scheme corresponding to the BOM. If no valid BOM is present - -- then the result is the specified Default value. - -private - function To_Unsigned_8 is new - Unchecked_Conversion (Character, Interfaces.Unsigned_8); - - function To_Unsigned_16 is new - Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); - - function To_Unsigned_32 is new - Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); - - subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE; - -- Subtype containing only UTF_16BE and UTF_16LE entries - - -- Utility routines for converting between UTF-16 and UTF-16LE/BE - - function From_UTF_16 - (Item : UTF_16_Wide_String; - Output_Scheme : UTF_XE_Encoding; - Output_BOM : Boolean := False) return UTF_String; - -- The input string Item is encoded in UTF-16. The output is encoded using - -- Output_Scheme (which is either UTF-16LE or UTF-16BE). There are no error - -- cases. The output starts with BOM_16BE/LE if Output_BOM is True. - - function To_UTF_16 - (Item : UTF_String; - Input_Scheme : UTF_XE_Encoding; - Output_BOM : Boolean := False) return UTF_16_Wide_String; - -- The input string Item is encoded using Input_Scheme which is either - -- UTF-16LE or UTF-16BE. The output is the corresponding UTF_16 wide - -- string. Encoding error is raised if the length of the input is odd. - -- The output starts with BOM_16 if Output_BOM is True. - - procedure Raise_Encoding_Error (Index : Natural); - pragma No_Return (Raise_Encoding_Error); - -- Raise Encoding_Error exception for bad encoding in input item. The - -- parameter Index is the index of the location in Item for the error. - -end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/a-stwibo.adb b/gcc/ada/a-stwibo.adb deleted file mode 100644 index 3f784f6..0000000 --- a/gcc/ada/a-stwibo.adb +++ /dev/null @@ -1,94 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Bounded is - - package body Generic_Bounded_Length is - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Character) return Bounded_Wide_String - is - begin - return Times (Left, Right, Max_Length); - end "*"; - - function "*" - (Left : Natural; - Right : Wide_String) return Bounded_Wide_String - is - begin - return Times (Left, Right, Max_Length); - end "*"; - - --------------- - -- Replicate -- - --------------- - - function Replicate - (Count : Natural; - Item : Wide_Character; - Drop : Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - begin - return Super_Replicate (Count, Item, Drop, Max_Length); - end Replicate; - - function Replicate - (Count : Natural; - Item : Wide_String; - Drop : Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - begin - return Super_Replicate (Count, Item, Drop, Max_Length); - end Replicate; - - ---------------------------- - -- To_Bounded_Wide_String -- - ---------------------------- - - function To_Bounded_Wide_String - (Source : Wide_String; - Drop : Strings.Truncation := Strings.Error) - return Bounded_Wide_String - is - begin - return To_Super_String (Source, Max_Length, Drop); - end To_Bounded_Wide_String; - - end Generic_Bounded_Length; -end Ada.Strings.Wide_Bounded; diff --git a/gcc/ada/a-stwibo.ads b/gcc/ada/a-stwibo.ads deleted file mode 100644 index 3d098b3..0000000 --- a/gcc/ada/a-stwibo.ads +++ /dev/null @@ -1,921 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Superbounded; - -package Ada.Strings.Wide_Bounded is - pragma Preelaborate; - - generic - Max : Positive; - -- Maximum length of a Bounded_Wide_String - - package Generic_Bounded_Length is - - Max_Length : constant Positive := Max; - - type Bounded_Wide_String is private; - pragma Preelaborable_Initialization (Bounded_Wide_String); - - Null_Bounded_Wide_String : constant Bounded_Wide_String; - - subtype Length_Range is Natural range 0 .. Max_Length; - - function Length (Source : Bounded_Wide_String) return Length_Range; - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Bounded_Wide_String - (Source : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - function To_Wide_String - (Source : Bounded_Wide_String) return Wide_String; - - procedure Set_Bounded_Wide_String - (Target : out Bounded_Wide_String; - Source : Wide_String; - Drop : Truncation := Error); - pragma Ada_05 (Set_Bounded_Wide_String); - - function Append - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - function Append - (Left : Bounded_Wide_String; - Right : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - function Append - (Left : Wide_String; - Right : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - function Append - (Left : Bounded_Wide_String; - Right : Wide_Character; - Drop : Truncation := Error) return Bounded_Wide_String; - - function Append - (Left : Wide_Character; - Right : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : Bounded_Wide_String; - Drop : Truncation := Error); - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : Wide_String; - Drop : Truncation := Error); - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : Wide_Character; - Drop : Truncation := Error); - - function "&" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Bounded_Wide_String; - - function "&" - (Left : Bounded_Wide_String; - Right : Wide_String) return Bounded_Wide_String; - - function "&" - (Left : Wide_String; - Right : Bounded_Wide_String) return Bounded_Wide_String; - - function "&" - (Left : Bounded_Wide_String; - Right : Wide_Character) return Bounded_Wide_String; - - function "&" - (Left : Wide_Character; - Right : Bounded_Wide_String) return Bounded_Wide_String; - - function Element - (Source : Bounded_Wide_String; - Index : Positive) return Wide_Character; - - procedure Replace_Element - (Source : in out Bounded_Wide_String; - Index : Positive; - By : Wide_Character); - - function Slice - (Source : Bounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String; - - function Bounded_Slice - (Source : Bounded_Wide_String; - Low : Positive; - High : Natural) return Bounded_Wide_String; - pragma Ada_05 (Bounded_Slice); - - procedure Bounded_Slice - (Source : Bounded_Wide_String; - Target : out Bounded_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Bounded_Slice); - - function "=" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function "=" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean; - - function "=" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function "<" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function "<" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function "<=" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function "<=" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<=" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function ">" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function ">" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function ">=" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean; - - function ">=" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">=" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean; - - ---------------------- - -- Search Functions -- - ---------------------- - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Index - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Bounded_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Bounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Count - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Count - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - return Bounded_Wide_String; - - procedure Translate - (Source : in out Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping); - - function Translate - (Source : Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Bounded_Wide_String; - - procedure Translate - (Source : in out Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Bounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - procedure Replace_Slice - (Source : in out Bounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error); - - function Insert - (Source : Bounded_Wide_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - procedure Insert - (Source : in out Bounded_Wide_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error); - - function Overwrite - (Source : Bounded_Wide_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - procedure Overwrite - (Source : in out Bounded_Wide_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Error); - - function Delete - (Source : Bounded_Wide_String; - From : Positive; - Through : Natural) return Bounded_Wide_String; - - procedure Delete - (Source : in out Bounded_Wide_String; - From : Positive; - Through : Natural); - - --------------------------------- - -- String Selector Subprograms -- - --------------------------------- - - function Trim - (Source : Bounded_Wide_String; - Side : Trim_End) return Bounded_Wide_String; - - procedure Trim - (Source : in out Bounded_Wide_String; - Side : Trim_End); - - function Trim - (Source : Bounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Bounded_Wide_String; - - procedure Trim - (Source : in out Bounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set); - - function Head - (Source : Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_String; - - procedure Head - (Source : in out Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error); - - function Tail - (Source : Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_String; - - procedure Tail - (Source : in out Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error); - - ------------------------------------ - -- String Constructor Subprograms -- - ------------------------------------ - - function "*" - (Left : Natural; - Right : Wide_Character) return Bounded_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_String) return Bounded_Wide_String; - - function "*" - (Left : Natural; - Right : Bounded_Wide_String) return Bounded_Wide_String; - - function Replicate - (Count : Natural; - Item : Wide_Character; - Drop : Truncation := Error) return Bounded_Wide_String; - - function Replicate - (Count : Natural; - Item : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - function Replicate - (Count : Natural; - Item : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String; - - private - -- Most of the implementation is in the separate non generic package - -- Ada.Strings.Wide_Superbounded. Type Bounded_Wide_String is derived - -- from type Wide_Superbounded.Super_String with the maximum length - -- constraint. In almost all cases, the routines in Wide_Superbounded - -- can be called with no requirement to pass the maximum length - -- explicitly, since there is at least one Bounded_Wide_String argument - -- from which the maximum length can be obtained. For all such - -- routines, the implementation in this private part is simply a - -- renaming of the corresponding routine in the super bouded package. - - -- The five exceptions are the * and Replicate routines operating on - -- character values. For these cases, we have a routine in the body - -- that calls the superbounded routine passing the maximum length - -- explicitly as an extra parameter. - - type Bounded_Wide_String is - new Wide_Superbounded.Super_String (Max_Length); - -- Deriving Bounded_Wide_String from Wide_Superbounded.Super_String is - -- the real trick, it ensures that the type Bounded_Wide_String - -- declared in the generic instantiation is compatible with the - -- Super_String type declared in the Wide_Superbounded package. - - Null_Bounded_Wide_String : constant Bounded_Wide_String := - (Max_Length => Max_Length, - Current_Length => 0, - Data => - (1 .. Max_Length => - Wide_Superbounded.Wide_NUL)); - - pragma Inline (To_Bounded_Wide_String); - - procedure Set_Bounded_Wide_String - (Target : out Bounded_Wide_String; - Source : Wide_String; - Drop : Truncation := Error) - renames Set_Super_String; - - function Length - (Source : Bounded_Wide_String) return Length_Range - renames Super_Length; - - function To_Wide_String - (Source : Bounded_Wide_String) return Wide_String - renames Super_To_String; - - function Append - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Append; - - function Append - (Left : Bounded_Wide_String; - Right : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Append; - - function Append - (Left : Wide_String; - Right : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Append; - - function Append - (Left : Bounded_Wide_String; - Right : Wide_Character; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Append; - - function Append - (Left : Wide_Character; - Right : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Append; - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : Bounded_Wide_String; - Drop : Truncation := Error) - renames Super_Append; - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : Wide_String; - Drop : Truncation := Error) - renames Super_Append; - - procedure Append - (Source : in out Bounded_Wide_String; - New_Item : Wide_Character; - Drop : Truncation := Error) - renames Super_Append; - - function "&" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Bounded_Wide_String - renames Concat; - - function "&" - (Left : Bounded_Wide_String; - Right : Wide_String) return Bounded_Wide_String - renames Concat; - - function "&" - (Left : Wide_String; - Right : Bounded_Wide_String) return Bounded_Wide_String - renames Concat; - - function "&" - (Left : Bounded_Wide_String; - Right : Wide_Character) return Bounded_Wide_String - renames Concat; - - function "&" - (Left : Wide_Character; - Right : Bounded_Wide_String) return Bounded_Wide_String - renames Concat; - - function Element - (Source : Bounded_Wide_String; - Index : Positive) return Wide_Character - renames Super_Element; - - procedure Replace_Element - (Source : in out Bounded_Wide_String; - Index : Positive; - By : Wide_Character) - renames Super_Replace_Element; - - function Slice - (Source : Bounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String - renames Super_Slice; - - function Bounded_Slice - (Source : Bounded_Wide_String; - Low : Positive; - High : Natural) return Bounded_Wide_String - renames Super_Slice; - - procedure Bounded_Slice - (Source : Bounded_Wide_String; - Target : out Bounded_Wide_String; - Low : Positive; - High : Natural) - renames Super_Slice; - - overriding function "=" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Equal; - - function "=" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean - renames Equal; - - function "=" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Equal; - - function "<" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Less; - - function "<" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean - renames Less; - - function "<" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Less; - - function "<=" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Less_Or_Equal; - - function "<=" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean - renames Less_Or_Equal; - - function "<=" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Less_Or_Equal; - - function ">" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Greater; - - function ">" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean - renames Greater; - - function ">" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Greater; - - function ">=" - (Left : Bounded_Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Greater_Or_Equal; - - function ">=" - (Left : Bounded_Wide_String; - Right : Wide_String) return Boolean - renames Greater_Or_Equal; - - function ">=" - (Left : Wide_String; - Right : Bounded_Wide_String) return Boolean - renames Greater_Or_Equal; - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Super_Index; - - function Index_Non_Blank - (Source : Bounded_Wide_String; - Going : Direction := Forward) return Natural - renames Super_Index_Non_Blank; - - function Index_Non_Blank - (Source : Bounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - renames Super_Index_Non_Blank; - - function Count - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - renames Super_Count; - - function Count - (Source : Bounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - renames Super_Count; - - function Count - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural - renames Super_Count; - - procedure Find_Token - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Super_Find_Token; - - procedure Find_Token - (Source : Bounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Super_Find_Token; - - function Translate - (Source : Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - return Bounded_Wide_String - renames Super_Translate; - - procedure Translate - (Source : in out Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - renames Super_Translate; - - function Translate - (Source : Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Bounded_Wide_String - renames Super_Translate; - - procedure Translate - (Source : in out Bounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - renames Super_Translate; - - function Replace_Slice - (Source : Bounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Replace_Slice; - - procedure Replace_Slice - (Source : in out Bounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error) - renames Super_Replace_Slice; - - function Insert - (Source : Bounded_Wide_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Insert; - - procedure Insert - (Source : in out Bounded_Wide_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) - renames Super_Insert; - - function Overwrite - (Source : Bounded_Wide_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Overwrite; - - procedure Overwrite - (Source : in out Bounded_Wide_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) - renames Super_Overwrite; - - function Delete - (Source : Bounded_Wide_String; - From : Positive; - Through : Natural) return Bounded_Wide_String - renames Super_Delete; - - procedure Delete - (Source : in out Bounded_Wide_String; - From : Positive; - Through : Natural) - renames Super_Delete; - - function Trim - (Source : Bounded_Wide_String; - Side : Trim_End) return Bounded_Wide_String - renames Super_Trim; - - procedure Trim - (Source : in out Bounded_Wide_String; - Side : Trim_End) - renames Super_Trim; - - function Trim - (Source : Bounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Bounded_Wide_String - renames Super_Trim; - - procedure Trim - (Source : in out Bounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) - renames Super_Trim; - - function Head - (Source : Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Head; - - procedure Head - (Source : in out Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) - renames Super_Head; - - function Tail - (Source : Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Tail; - - procedure Tail - (Source : in out Bounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) - renames Super_Tail; - - function "*" - (Left : Natural; - Right : Bounded_Wide_String) return Bounded_Wide_String - renames Times; - - function Replicate - (Count : Natural; - Item : Bounded_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_String - renames Super_Replicate; - - end Generic_Bounded_Length; - -end Ada.Strings.Wide_Bounded; diff --git a/gcc/ada/a-stwifi.adb b/gcc/ada/a-stwifi.adb deleted file mode 100644 index c586791..0000000 --- a/gcc/ada/a-stwifi.adb +++ /dev/null @@ -1,688 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ F I X E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Search; - -package body Ada.Strings.Wide_Fixed is - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - renames Ada.Strings.Wide_Search.Index; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - renames Ada.Strings.Wide_Search.Index; - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Search.Index; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - renames Ada.Strings.Wide_Search.Index; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - renames Ada.Strings.Wide_Search.Index; - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Search.Index; - - function Index_Non_Blank - (Source : Wide_String; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Search.Index_Non_Blank; - - function Index_Non_Blank - (Source : Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Search.Index_Non_Blank; - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - renames Ada.Strings.Wide_Search.Count; - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - renames Ada.Strings.Wide_Search.Count; - - function Count - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural - renames Ada.Strings.Wide_Search.Count; - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Ada.Strings.Wide_Search.Find_Token; - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Ada.Strings.Wide_Search.Find_Token; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Character) return Wide_String - is - Result : Wide_String (1 .. Left); - - begin - for J in Result'Range loop - Result (J) := Right; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : Wide_String) return Wide_String - is - Result : Wide_String (1 .. Left * Right'Length); - Ptr : Integer := 1; - - begin - for J in 1 .. Left loop - Result (Ptr .. Ptr + Right'Length - 1) := Right; - Ptr := Ptr + Right'Length; - end loop; - - return Result; - end "*"; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Wide_String; - From : Positive; - Through : Natural) return Wide_String - is - begin - if From not in Source'Range - or else Through > Source'Last - then - raise Index_Error; - - elsif From > Through then - return Source; - - else - declare - Len : constant Integer := Source'Length - (Through - From + 1); - Result : constant - Wide_String (Source'First .. Source'First + Len - 1) := - Source (Source'First .. From - 1) & - Source (Through + 1 .. Source'Last); - begin - return Result; - end; - end if; - end Delete; - - procedure Delete - (Source : in out Wide_String; - From : Positive; - Through : Natural; - Justify : Alignment := Left; - Pad : Wide_Character := Wide_Space) - is - begin - Move (Source => Delete (Source, From, Through), - Target => Source, - Justify => Justify, - Pad => Pad); - end Delete; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Wide_String - is - Result : Wide_String (1 .. Count); - - begin - if Count <= Source'Length then - Result := Source (Source'First .. Source'First + Count - 1); - - else - Result (1 .. Source'Length) := Source; - - for J in Source'Length + 1 .. Count loop - Result (J) := Pad; - end loop; - end if; - - return Result; - end Head; - - procedure Head - (Source : in out Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Character := Ada.Strings.Wide_Space) - is - begin - Move (Source => Head (Source, Count, Pad), - Target => Source, - Drop => Error, - Justify => Justify, - Pad => Pad); - end Head; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Wide_String; - Before : Positive; - New_Item : Wide_String) return Wide_String - is - Result : Wide_String (1 .. Source'Length + New_Item'Length); - - begin - if Before < Source'First or else Before > Source'Last + 1 then - raise Index_Error; - end if; - - Result := Source (Source'First .. Before - 1) & New_Item & - Source (Before .. Source'Last); - return Result; - end Insert; - - procedure Insert - (Source : in out Wide_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) - is - begin - Move (Source => Insert (Source, Before, New_Item), - Target => Source, - Drop => Drop); - end Insert; - - ---------- - -- Move -- - ---------- - - procedure Move - (Source : Wide_String; - Target : out Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Character := Wide_Space) - is - Sfirst : constant Integer := Source'First; - Slast : constant Integer := Source'Last; - Slength : constant Integer := Source'Length; - - Tfirst : constant Integer := Target'First; - Tlast : constant Integer := Target'Last; - Tlength : constant Integer := Target'Length; - - function Is_Padding (Item : Wide_String) return Boolean; - -- Determine if all characters in Item are pad characters - - ---------------- - -- Is_Padding -- - ---------------- - - function Is_Padding (Item : Wide_String) return Boolean is - begin - for J in Item'Range loop - if Item (J) /= Pad then - return False; - end if; - end loop; - - return True; - end Is_Padding; - - -- Start of processing for Move - - begin - if Slength = Tlength then - Target := Source; - - elsif Slength > Tlength then - case Drop is - when Left => - Target := Source (Slast - Tlength + 1 .. Slast); - - when Right => - Target := Source (Sfirst .. Sfirst + Tlength - 1); - - when Error => - case Justify is - when Left => - if Is_Padding (Source (Sfirst + Tlength .. Slast)) then - Target := - Source (Sfirst .. Sfirst + Target'Length - 1); - else - raise Length_Error; - end if; - - when Right => - if Is_Padding (Source (Sfirst .. Slast - Tlength)) then - Target := Source (Slast - Tlength + 1 .. Slast); - else - raise Length_Error; - end if; - - when Center => - raise Length_Error; - end case; - end case; - - -- Source'Length < Target'Length - - else - case Justify is - when Left => - Target (Tfirst .. Tfirst + Slength - 1) := Source; - - for J in Tfirst + Slength .. Tlast loop - Target (J) := Pad; - end loop; - - when Right => - for J in Tfirst .. Tlast - Slength loop - Target (J) := Pad; - end loop; - - Target (Tlast - Slength + 1 .. Tlast) := Source; - - when Center => - declare - Front_Pad : constant Integer := (Tlength - Slength) / 2; - Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; - - begin - for J in Tfirst .. Tfirst_Fpad - 1 loop - Target (J) := Pad; - end loop; - - Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; - - for J in Tfirst_Fpad + Slength .. Tlast loop - Target (J) := Pad; - end loop; - end; - end case; - end if; - end Move; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Wide_String; - Position : Positive; - New_Item : Wide_String) return Wide_String - is - begin - if Position not in Source'First .. Source'Last + 1 then - raise Index_Error; - else - declare - Result_Length : constant Natural := - Natural'Max - (Source'Length, - Position - Source'First + New_Item'Length); - - Result : Wide_String (1 .. Result_Length); - - begin - Result := Source (Source'First .. Position - 1) & New_Item & - Source (Position + New_Item'Length .. Source'Last); - return Result; - end; - end if; - end Overwrite; - - procedure Overwrite - (Source : in out Wide_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Right) - is - begin - Move (Source => Overwrite (Source, Position, New_Item), - Target => Source, - Drop => Drop); - end Overwrite; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Wide_String - is - begin - if Low > Source'Last + 1 or else High < Source'First - 1 then - raise Index_Error; - end if; - - if High >= Low then - declare - Front_Len : constant Integer := - Integer'Max (0, Low - Source'First); - -- Length of prefix of Source copied to result - - Back_Len : constant Integer := Integer'Max (0, Source'Last - High); - -- Length of suffix of Source copied to result - - Result_Length : constant Integer := - Front_Len + By'Length + Back_Len; - -- Length of result - - Result : Wide_String (1 .. Result_Length); - - begin - Result (1 .. Front_Len) := Source (Source'First .. Low - 1); - Result (Front_Len + 1 .. Front_Len + By'Length) := By; - Result (Front_Len + By'Length + 1 .. Result'Length) := - Source (High + 1 .. Source'Last); - return Result; - end; - - else - return Insert (Source, Before => Low, New_Item => By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Wide_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Character := Wide_Space) - is - begin - Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); - end Replace_Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Wide_String - is - Result : Wide_String (1 .. Count); - - begin - if Count < Source'Length then - Result := Source (Source'Last - Count + 1 .. Source'Last); - - -- Pad on left - - else - for J in 1 .. Count - Source'Length loop - Result (J) := Pad; - end loop; - - Result (Count - Source'Length + 1 .. Count) := Source; - end if; - - return Result; - end Tail; - - procedure Tail - (Source : in out Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Character := Ada.Strings.Wide_Space) - is - begin - Move (Source => Tail (Source, Count, Pad), - Target => Source, - Drop => Error, - Justify => Justify, - Pad => Pad); - end Tail; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) return Wide_String - is - Result : Wide_String (1 .. Source'Length); - - begin - for J in Source'Range loop - Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - is - begin - for J in Source'Range loop - Source (J) := Value (Mapping, Source (J)); - end loop; - end Translate; - - function Translate - (Source : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Wide_String - is - Result : Wide_String (1 .. Source'Length); - - begin - for J in Source'Range loop - Result (J - (Source'First - 1)) := Mapping (Source (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - is - begin - for J in Source'Range loop - Source (J) := Mapping (Source (J)); - end loop; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Wide_String; - Side : Trim_End) return Wide_String - is - Low : Natural := Source'First; - High : Natural := Source'Last; - - begin - if Side = Left or else Side = Both then - while Low <= High and then Source (Low) = Wide_Space loop - Low := Low + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while High >= Low and then Source (High) = Wide_Space loop - High := High - 1; - end loop; - end if; - - -- All blanks case - - if Low > High then - return ""; - - -- At least one non-blank - - else - declare - Result : constant Wide_String (1 .. High - Low + 1) := - Source (Low .. High); - - begin - return Result; - end; - end if; - end Trim; - - procedure Trim - (Source : in out Wide_String; - Side : Trim_End; - Justify : Alignment := Left; - Pad : Wide_Character := Wide_Space) - is - begin - Move (Source => Trim (Source, Side), - Target => Source, - Justify => Justify, - Pad => Pad); - end Trim; - - function Trim - (Source : Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Wide_String - is - Low : Natural := Source'First; - High : Natural := Source'Last; - - begin - while Low <= High and then Is_In (Source (Low), Left) loop - Low := Low + 1; - end loop; - - while High >= Low and then Is_In (Source (High), Right) loop - High := High - 1; - end loop; - - -- Case where source comprises only characters in the sets - - if Low > High then - return ""; - else - declare - subtype WS is Wide_String (1 .. High - Low + 1); - - begin - return WS (Source (Low .. High)); - end; - end if; - end Trim; - - procedure Trim - (Source : in out Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set; - Justify : Alignment := Strings.Left; - Pad : Wide_Character := Wide_Space) - is - begin - Move (Source => Trim (Source, Left, Right), - Target => Source, - Justify => Justify, - Pad => Pad); - end Trim; - -end Ada.Strings.Wide_Fixed; diff --git a/gcc/ada/a-stwifi.ads b/gcc/ada/a-stwifi.ads deleted file mode 100644 index 75de811..0000000 --- a/gcc/ada/a-stwifi.ads +++ /dev/null @@ -1,254 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ F I X E D -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Maps; - -package Ada.Strings.Wide_Fixed is - pragma Preelaborate; - - ------------------------------------------------------------------- - -- Copy Procedure for Wide_Strings of Possibly Different Lengths -- - ------------------------------------------------------------------- - - procedure Move - (Source : Wide_String; - Target : out Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Character := Ada.Strings.Wide_Space); - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Count - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ----------------------------------------- - -- Wide_String Translation Subprograms -- - ----------------------------------------- - - function Translate - (Source : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) return Wide_String; - - procedure Translate - (Source : in out Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping); - - function Translate - (Source : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Wide_String; - - procedure Translate - (Source : in out Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function); - - -------------------------------------------- - -- Wide_String Transformation Subprograms -- - -------------------------------------------- - - function Replace_Slice - (Source : Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Wide_String; - - procedure Replace_Slice - (Source : in out Wide_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Character := Ada.Strings.Wide_Space); - - function Insert - (Source : Wide_String; - Before : Positive; - New_Item : Wide_String) return Wide_String; - - procedure Insert - (Source : in out Wide_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error); - - function Overwrite - (Source : Wide_String; - Position : Positive; - New_Item : Wide_String) return Wide_String; - - procedure Overwrite - (Source : in out Wide_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Right); - - function Delete - (Source : Wide_String; - From : Positive; - Through : Natural) return Wide_String; - - procedure Delete - (Source : in out Wide_String; - From : Positive; - Through : Natural; - Justify : Alignment := Left; - Pad : Wide_Character := Ada.Strings.Wide_Space); - - -------------------------------------- - -- Wide_String Selector Subprograms -- - -------------------------------------- - - function Trim - (Source : Wide_String; - Side : Trim_End) return Wide_String; - - procedure Trim - (Source : in out Wide_String; - Side : Trim_End; - Justify : Alignment := Left; - Pad : Wide_Character := Wide_Space); - - function Trim - (Source : Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Wide_String; - - procedure Trim - (Source : in out Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set; - Justify : Alignment := Ada.Strings.Left; - Pad : Wide_Character := Ada.Strings.Wide_Space); - - function Head - (Source : Wide_String; - Count : Natural; - Pad : Wide_Character := Ada.Strings.Wide_Space) return Wide_String; - - procedure Head - (Source : in out Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Character := Ada.Strings.Wide_Space); - - function Tail - (Source : Wide_String; - Count : Natural; - Pad : Wide_Character := Ada.Strings.Wide_Space) return Wide_String; - - procedure Tail - (Source : in out Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Character := Ada.Strings.Wide_Space); - - --------------------------------------- - -- Wide_String Constructor Functions -- - --------------------------------------- - - function "*" - (Left : Natural; - Right : Wide_Character) return Wide_String; - - function "*" - (Left : Natural; - Right : Wide_String) return Wide_String; - -end Ada.Strings.Wide_Fixed; diff --git a/gcc/ada/a-stwiha.adb b/gcc/ada/a-stwiha.adb deleted file mode 100644 index 4c2b15d..0000000 --- a/gcc/ada/a-stwiha.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Wide_Hash - (Key : Wide_String) return Containers.Hash_Type -is - use Ada.Containers; - function Hash_Fun is new System.String_Hash.Hash - (Wide_Character, Wide_String, Hash_Type); -begin - return Hash_Fun (Key); -end Ada.Strings.Wide_Hash; diff --git a/gcc/ada/a-stwiha.ads b/gcc/ada/a-stwiha.ads deleted file mode 100644 index f8f0b52..0000000 --- a/gcc/ada/a-stwiha.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -function Ada.Strings.Wide_Hash - (Key : Wide_String) return Containers.Hash_Type; - -pragma Pure (Ada.Strings.Wide_Hash); diff --git a/gcc/ada/a-stwima.adb b/gcc/ada/a-stwima.adb deleted file mode 100644 index ed6ef60..0000000 --- a/gcc/ada/a-stwima.adb +++ /dev/null @@ -1,742 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Maps is - - --------- - -- "-" -- - --------- - - function "-" - (Left, Right : Wide_Character_Set) return Wide_Character_Set - is - LS : constant Wide_Character_Ranges_Access := Left.Set; - RS : constant Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); - -- Each range on the right can generate at least one more range in - -- the result, by splitting one of the left operand ranges. - - N : Natural := 0; - R : Natural := 1; - L : Natural := 1; - - Left_Low : Wide_Character; - -- Left_Low is lowest character of the L'th range not yet dealt with - - begin - if LS'Last = 0 or else RS'Last = 0 then - return Left; - end if; - - Left_Low := LS (L).Low; - while R <= RS'Last loop - - -- If next right range is below current left range, skip it - - if RS (R).High < Left_Low then - R := R + 1; - - -- If next right range above current left range, copy remainder - -- of the left range to the result - - elsif RS (R).Low > LS (L).High then - N := N + 1; - Result (N).Low := Left_Low; - Result (N).High := LS (L).High; - L := L + 1; - exit when L > LS'Last; - Left_Low := LS (L).Low; - - else - -- Next right range overlaps bottom of left range - - if RS (R).Low <= Left_Low then - - -- Case of right range complete overlaps left range - - if RS (R).High >= LS (L).High then - L := L + 1; - exit when L > LS'Last; - Left_Low := LS (L).Low; - - -- Case of right range eats lower part of left range - - else - Left_Low := Wide_Character'Succ (RS (R).High); - R := R + 1; - end if; - - -- Next right range overlaps some of left range, but not bottom - - else - N := N + 1; - Result (N).Low := Left_Low; - Result (N).High := Wide_Character'Pred (RS (R).Low); - - -- Case of right range splits left range - - if RS (R).High < LS (L).High then - Left_Low := Wide_Character'Succ (RS (R).High); - R := R + 1; - - -- Case of right range overlaps top of left range - - else - L := L + 1; - exit when L > LS'Last; - Left_Low := LS (L).Low; - end if; - end if; - end if; - end loop; - - -- Copy remainder of left ranges to result - - if L <= LS'Last then - N := N + 1; - Result (N).Low := Left_Low; - Result (N).High := LS (L).High; - - loop - L := L + 1; - exit when L > LS'Last; - N := N + 1; - Result (N) := LS (L); - end loop; - end if; - - return (AF.Controlled with - Set => new Wide_Character_Ranges'(Result (1 .. N))); - end "-"; - - --------- - -- "=" -- - --------- - - -- The sorted, discontiguous form is canonical, so equality can be used - - function "=" (Left, Right : Wide_Character_Set) return Boolean is - begin - return Left.Set.all = Right.Set.all; - end "="; - - ----------- - -- "and" -- - ----------- - - function "and" - (Left, Right : Wide_Character_Set) return Wide_Character_Set - is - LS : constant Wide_Character_Ranges_Access := Left.Set; - RS : constant Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); - N : Natural := 0; - L, R : Natural := 1; - - begin - -- Loop to search for overlapping character ranges - - while L <= LS'Last and then R <= RS'Last loop - - if LS (L).High < RS (R).Low then - L := L + 1; - - elsif RS (R).High < LS (L).Low then - R := R + 1; - - -- Here we have LS (L).High >= RS (R).Low - -- and RS (R).High >= LS (L).Low - -- so we have an overlapping range - - else - N := N + 1; - Result (N).Low := Wide_Character'Max (LS (L).Low, RS (R).Low); - Result (N).High := - Wide_Character'Min (LS (L).High, RS (R).High); - - if RS (R).High = LS (L).High then - L := L + 1; - R := R + 1; - elsif RS (R).High < LS (L).High then - R := R + 1; - else - L := L + 1; - end if; - end if; - end loop; - - return (AF.Controlled with - Set => new Wide_Character_Ranges'(Result (1 .. N))); - end "and"; - - ----------- - -- "not" -- - ----------- - - function "not" - (Right : Wide_Character_Set) return Wide_Character_Set - is - RS : constant Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Character_Ranges (1 .. RS'Last + 1); - N : Natural := 0; - - begin - if RS'Last = 0 then - N := 1; - Result (1) := (Low => Wide_Character'First, - High => Wide_Character'Last); - - else - if RS (1).Low /= Wide_Character'First then - N := N + 1; - Result (N).Low := Wide_Character'First; - Result (N).High := Wide_Character'Pred (RS (1).Low); - end if; - - for K in 1 .. RS'Last - 1 loop - N := N + 1; - Result (N).Low := Wide_Character'Succ (RS (K).High); - Result (N).High := Wide_Character'Pred (RS (K + 1).Low); - end loop; - - if RS (RS'Last).High /= Wide_Character'Last then - N := N + 1; - Result (N).Low := Wide_Character'Succ (RS (RS'Last).High); - Result (N).High := Wide_Character'Last; - end if; - end if; - - return (AF.Controlled with - Set => new Wide_Character_Ranges'(Result (1 .. N))); - end "not"; - - ---------- - -- "or" -- - ---------- - - function "or" - (Left, Right : Wide_Character_Set) return Wide_Character_Set - is - LS : constant Wide_Character_Ranges_Access := Left.Set; - RS : constant Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); - N : Natural; - L, R : Natural; - - begin - N := 0; - L := 1; - R := 1; - - -- Loop through ranges in output file - - loop - -- If no left ranges left, copy next right range - - if L > LS'Last then - exit when R > RS'Last; - N := N + 1; - Result (N) := RS (R); - R := R + 1; - - -- If no right ranges left, copy next left range - - elsif R > RS'Last then - N := N + 1; - Result (N) := LS (L); - L := L + 1; - - else - -- We have two ranges, choose lower one - - N := N + 1; - - if LS (L).Low <= RS (R).Low then - Result (N) := LS (L); - L := L + 1; - else - Result (N) := RS (R); - R := R + 1; - end if; - - -- Loop to collapse ranges into last range - - loop - -- Collapse next length range into current result range - -- if possible. - - if L <= LS'Last - and then LS (L).Low <= Wide_Character'Succ (Result (N).High) - then - Result (N).High := - Wide_Character'Max (Result (N).High, LS (L).High); - L := L + 1; - - -- Collapse next right range into current result range - -- if possible - - elsif R <= RS'Last - and then RS (R).Low <= - Wide_Character'Succ (Result (N).High) - then - Result (N).High := - Wide_Character'Max (Result (N).High, RS (R).High); - R := R + 1; - - -- If neither range collapses, then done with this range - - else - exit; - end if; - end loop; - end if; - end loop; - - return (AF.Controlled with - Set => new Wide_Character_Ranges'(Result (1 .. N))); - end "or"; - - ----------- - -- "xor" -- - ----------- - - function "xor" - (Left, Right : Wide_Character_Set) return Wide_Character_Set - is - begin - return (Left or Right) - (Left and Right); - end "xor"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Wide_Character_Mapping) is - begin - Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all); - end Adjust; - - procedure Adjust (Object : in out Wide_Character_Set) is - begin - Object.Set := new Wide_Character_Ranges'(Object.Set.all); - end Adjust; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Wide_Character_Mapping) is - - procedure Free is new Ada.Unchecked_Deallocation - (Wide_Character_Mapping_Values, - Wide_Character_Mapping_Values_Access); - - begin - if Object.Map /= Null_Map'Unrestricted_Access then - Free (Object.Map); - end if; - end Finalize; - - procedure Finalize (Object : in out Wide_Character_Set) is - - procedure Free is new Ada.Unchecked_Deallocation - (Wide_Character_Ranges, - Wide_Character_Ranges_Access); - - begin - if Object.Set /= Null_Range'Unrestricted_Access then - Free (Object.Set); - end if; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Wide_Character_Mapping) is - begin - Object := Identity; - end Initialize; - - procedure Initialize (Object : in out Wide_Character_Set) is - begin - Object := Null_Set; - end Initialize; - - ----------- - -- Is_In -- - ----------- - - function Is_In - (Element : Wide_Character; - Set : Wide_Character_Set) return Boolean - is - L, R, M : Natural; - SS : constant Wide_Character_Ranges_Access := Set.Set; - - begin - L := 1; - R := SS'Last; - - -- Binary search loop. The invariant is that if Element is in any of - -- of the constituent ranges it is in one between Set (L) and Set (R). - - loop - if L > R then - return False; - - else - M := (L + R) / 2; - - if Element > SS (M).High then - L := M + 1; - elsif Element < SS (M).Low then - R := M - 1; - else - return True; - end if; - end if; - end loop; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset - (Elements : Wide_Character_Set; - Set : Wide_Character_Set) return Boolean - is - ES : constant Wide_Character_Ranges_Access := Elements.Set; - SS : constant Wide_Character_Ranges_Access := Set.Set; - - S : Positive := 1; - E : Positive := 1; - - begin - loop - -- If no more element ranges, done, and result is true - - if E > ES'Last then - return True; - - -- If more element ranges, but no more set ranges, result is false - - elsif S > SS'Last then - return False; - - -- Remove irrelevant set range - - elsif SS (S).High < ES (E).Low then - S := S + 1; - - -- Get rid of element range that is properly covered by set - - elsif SS (S).Low <= ES (E).Low - and then ES (E).High <= SS (S).High - then - E := E + 1; - - -- Otherwise we have a non-covered element range, result is false - - else - return False; - end if; - end loop; - end Is_Subset; - - --------------- - -- To_Domain -- - --------------- - - function To_Domain - (Map : Wide_Character_Mapping) return Wide_Character_Sequence - is - begin - return Map.Map.Domain; - end To_Domain; - - ---------------- - -- To_Mapping -- - ---------------- - - function To_Mapping - (From, To : Wide_Character_Sequence) return Wide_Character_Mapping - is - Domain : Wide_Character_Sequence (1 .. From'Length); - Rangev : Wide_Character_Sequence (1 .. To'Length); - N : Natural := 0; - - begin - if From'Length /= To'Length then - raise Translation_Error; - - else - pragma Warnings (Off); -- apparent uninit use of Domain - - for J in From'Range loop - for M in 1 .. N loop - if From (J) = Domain (M) then - raise Translation_Error; - elsif From (J) < Domain (M) then - Domain (M + 1 .. N + 1) := Domain (M .. N); - Rangev (M + 1 .. N + 1) := Rangev (M .. N); - Domain (M) := From (J); - Rangev (M) := To (J); - goto Continue; - end if; - end loop; - - Domain (N + 1) := From (J); - Rangev (N + 1) := To (J); - - <> - N := N + 1; - end loop; - - pragma Warnings (On); - - return (AF.Controlled with - Map => new Wide_Character_Mapping_Values'( - Length => N, - Domain => Domain (1 .. N), - Rangev => Rangev (1 .. N))); - end if; - end To_Mapping; - - -------------- - -- To_Range -- - -------------- - - function To_Range - (Map : Wide_Character_Mapping) return Wide_Character_Sequence - is - begin - return Map.Map.Rangev; - end To_Range; - - --------------- - -- To_Ranges -- - --------------- - - function To_Ranges - (Set : Wide_Character_Set) return Wide_Character_Ranges - is - begin - return Set.Set.all; - end To_Ranges; - - ----------------- - -- To_Sequence -- - ----------------- - - function To_Sequence - (Set : Wide_Character_Set) return Wide_Character_Sequence - is - SS : constant Wide_Character_Ranges_Access := Set.Set; - N : Natural := 0; - Count : Natural := 0; - - begin - for J in SS'Range loop - Count := - Count + (Wide_Character'Pos (SS (J).High) - - Wide_Character'Pos (SS (J).Low) + 1); - end loop; - - return Result : Wide_String (1 .. Count) do - for J in SS'Range loop - for K in SS (J).Low .. SS (J).High loop - N := N + 1; - Result (N) := K; - end loop; - end loop; - end return; - end To_Sequence; - - ------------ - -- To_Set -- - ------------ - - -- Case of multiple range input - - function To_Set - (Ranges : Wide_Character_Ranges) return Wide_Character_Set - is - Result : Wide_Character_Ranges (Ranges'Range); - N : Natural := 0; - J : Natural; - - begin - -- The output of To_Set is required to be sorted by increasing Low - -- values, and discontiguous, so first we sort them as we enter them, - -- using a simple insertion sort. - - pragma Warnings (Off); - -- Kill bogus warning on Result being uninitialized - - for J in Ranges'Range loop - for K in 1 .. N loop - if Ranges (J).Low < Result (K).Low then - Result (K + 1 .. N + 1) := Result (K .. N); - Result (K) := Ranges (J); - goto Continue; - end if; - end loop; - - Result (N + 1) := Ranges (J); - - <> - N := N + 1; - end loop; - - pragma Warnings (On); - - -- Now collapse any contiguous or overlapping ranges - - J := 1; - while J < N loop - if Result (J).High < Result (J).Low then - N := N - 1; - Result (J .. N) := Result (J + 1 .. N + 1); - - elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then - Result (J).High := - Wide_Character'Max (Result (J).High, Result (J + 1).High); - - N := N - 1; - Result (J + 1 .. N) := Result (J + 2 .. N + 1); - - else - J := J + 1; - end if; - end loop; - - if N > 0 and then Result (N).High < Result (N).Low then - N := N - 1; - end if; - - return (AF.Controlled with - Set => new Wide_Character_Ranges'(Result (1 .. N))); - end To_Set; - - -- Case of single range input - - function To_Set - (Span : Wide_Character_Range) return Wide_Character_Set - is - begin - if Span.Low > Span.High then - return Null_Set; - -- This is safe, because there is no procedure with parameter - -- Wide_Character_Set of mode "out" or "in out". - - else - return (AF.Controlled with - Set => new Wide_Character_Ranges'(1 => Span)); - end if; - end To_Set; - - -- Case of wide string input - - function To_Set - (Sequence : Wide_Character_Sequence) return Wide_Character_Set - is - R : Wide_Character_Ranges (1 .. Sequence'Length); - - begin - for J in R'Range loop - R (J) := (Sequence (J), Sequence (J)); - end loop; - - return To_Set (R); - end To_Set; - - -- Case of single wide character input - - function To_Set - (Singleton : Wide_Character) return Wide_Character_Set - is - begin - return - (AF.Controlled with - Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton))); - end To_Set; - - ----------- - -- Value -- - ----------- - - function Value - (Map : Wide_Character_Mapping; - Element : Wide_Character) return Wide_Character - is - L, R, M : Natural; - - MV : constant Wide_Character_Mapping_Values_Access := Map.Map; - - begin - L := 1; - R := MV.Domain'Last; - - -- Binary search loop - - loop - -- If not found, identity - - if L > R then - return Element; - - -- Otherwise do binary divide - - else - M := (L + R) / 2; - - if Element < MV.Domain (M) then - R := M - 1; - - elsif Element > MV.Domain (M) then - L := M + 1; - - else -- Element = MV.Domain (M) then - return MV.Rangev (M); - end if; - end if; - end loop; - end Value; - -end Ada.Strings.Wide_Maps; diff --git a/gcc/ada/a-stwima.ads b/gcc/ada/a-stwima.ads deleted file mode 100644 index 8863a44..0000000 --- a/gcc/ada/a-stwima.ads +++ /dev/null @@ -1,240 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Finalization; - -package Ada.Strings.Wide_Maps is - pragma Preelaborate; - - ------------------------------------- - -- Wide Character Set Declarations -- - ------------------------------------- - - type Wide_Character_Set is private; - pragma Preelaborable_Initialization (Wide_Character_Set); - -- Representation for a set of Wide_Character values: - - Null_Set : constant Wide_Character_Set; - - ------------------------------------------ - -- Constructors for Wide Character Sets -- - ------------------------------------------ - - type Wide_Character_Range is record - Low : Wide_Character; - High : Wide_Character; - end record; - -- Represents Wide_Character range Low .. High - - type Wide_Character_Ranges is - array (Positive range <>) of Wide_Character_Range; - - function To_Set - (Ranges : Wide_Character_Ranges) return Wide_Character_Set; - - function To_Set - (Span : Wide_Character_Range) return Wide_Character_Set; - - function To_Ranges - (Set : Wide_Character_Set) return Wide_Character_Ranges; - - --------------------------------------- - -- Operations on Wide Character Sets -- - --------------------------------------- - - function "=" (Left, Right : Wide_Character_Set) return Boolean; - - function "not" - (Right : Wide_Character_Set) return Wide_Character_Set; - - function "and" - (Left, Right : Wide_Character_Set) return Wide_Character_Set; - - function "or" - (Left, Right : Wide_Character_Set) return Wide_Character_Set; - - function "xor" - (Left, Right : Wide_Character_Set) return Wide_Character_Set; - - function "-" - (Left, Right : Wide_Character_Set) return Wide_Character_Set; - - function Is_In - (Element : Wide_Character; - Set : Wide_Character_Set) return Boolean; - - function Is_Subset - (Elements : Wide_Character_Set; - Set : Wide_Character_Set) return Boolean; - - function "<=" - (Left : Wide_Character_Set; - Right : Wide_Character_Set) return Boolean - renames Is_Subset; - - subtype Wide_Character_Sequence is Wide_String; - -- Alternative representation for a set of character values - - function To_Set - (Sequence : Wide_Character_Sequence) return Wide_Character_Set; - - function To_Set - (Singleton : Wide_Character) return Wide_Character_Set; - - function To_Sequence - (Set : Wide_Character_Set) return Wide_Character_Sequence; - - ----------------------------------------- - -- Wide Character Mapping Declarations -- - ----------------------------------------- - - type Wide_Character_Mapping is private; - pragma Preelaborable_Initialization (Wide_Character_Mapping); - -- Representation for a wide character to wide character mapping: - - function Value - (Map : Wide_Character_Mapping; - Element : Wide_Character) return Wide_Character; - - Identity : constant Wide_Character_Mapping; - - --------------------------------- - -- Operations on Wide Mappings -- - --------------------------------- - - function To_Mapping - (From, To : Wide_Character_Sequence) return Wide_Character_Mapping; - - function To_Domain - (Map : Wide_Character_Mapping) return Wide_Character_Sequence; - - function To_Range - (Map : Wide_Character_Mapping) return Wide_Character_Sequence; - - type Wide_Character_Mapping_Function is - access function (From : Wide_Character) return Wide_Character; - -private - package AF renames Ada.Finalization; - - ------------------------------------------ - -- Representation of Wide_Character_Set -- - ------------------------------------------ - - -- A wide character set is represented as a sequence of wide character - -- ranges (i.e. an object of type Wide_Character_Ranges) in which the - -- following hold: - - -- The lower bound is 1 - -- The ranges are in order by increasing Low values - -- The ranges are non-overlapping and discontigous - - -- A character value is in the set if it is contained in one of the - -- ranges. The actual Wide_Character_Set value is a controlled pointer - -- to this Wide_Character_Ranges value. The use of a controlled type - -- is necessary to prevent storage leaks. - - type Wide_Character_Ranges_Access is access all Wide_Character_Ranges; - - type Wide_Character_Set is new AF.Controlled with record - Set : Wide_Character_Ranges_Access; - end record; - - pragma Finalize_Storage_Only (Wide_Character_Set); - -- This avoids useless finalizations, and, more importantly avoids - -- incorrect attempts to finalize constants that are statically - -- declared here and in Ada.Strings.Wide_Maps, which is incorrect. - - overriding procedure Initialize (Object : in out Wide_Character_Set); - overriding procedure Adjust (Object : in out Wide_Character_Set); - overriding procedure Finalize (Object : in out Wide_Character_Set); - - Null_Range : aliased constant Wide_Character_Ranges := - (1 .. 0 => (Low => ' ', High => ' ')); - - Null_Set : constant Wide_Character_Set := - (AF.Controlled with - Set => Null_Range'Unrestricted_Access); - - ---------------------------------------------- - -- Representation of Wide_Character_Mapping -- - ---------------------------------------------- - - -- A wide character mapping is represented as two strings of equal - -- length, where any character appearing in Domain is mapped to the - -- corresponding character in Rangev. A character not appearing in - -- Domain is mapped to itself. The characters in Domain are sorted - -- in ascending order. - - -- The actual Wide_Character_Mapping value is a controlled record - -- that contains a pointer to a discriminated record containing the - -- range and domain values. - - -- Note: this representation is canonical, and the values stored in - -- Domain and Rangev are exactly the values that are returned by the - -- functions To_Domain and To_Range. The use of a controlled type is - -- necessary to prevent storage leaks. - - type Wide_Character_Mapping_Values (Length : Natural) is record - Domain : Wide_Character_Sequence (1 .. Length); - Rangev : Wide_Character_Sequence (1 .. Length); - end record; - - type Wide_Character_Mapping_Values_Access is - access all Wide_Character_Mapping_Values; - - type Wide_Character_Mapping is new AF.Controlled with record - Map : Wide_Character_Mapping_Values_Access; - end record; - - pragma Finalize_Storage_Only (Wide_Character_Mapping); - -- This avoids useless finalizations, and, more importantly avoids - -- incorrect attempts to finalize constants that are statically - -- declared here and in Ada.Strings.Wide_Maps, which is incorrect. - - overriding procedure Initialize (Object : in out Wide_Character_Mapping); - overriding procedure Adjust (Object : in out Wide_Character_Mapping); - overriding procedure Finalize (Object : in out Wide_Character_Mapping); - - Null_Map : aliased constant Wide_Character_Mapping_Values := - (Length => 0, - Domain => "", - Rangev => ""); - - Identity : constant Wide_Character_Mapping := - (AF.Controlled with - Map => Null_Map'Unrestricted_Access); - -end Ada.Strings.Wide_Maps; diff --git a/gcc/ada/a-stwise.adb b/gcc/ada/a-stwise.adb deleted file mode 100644 index 09ac783..0000000 --- a/gcc/ada/a-stwise.adb +++ /dev/null @@ -1,614 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ S E A R C H -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; -with System; use System; - -package body Ada.Strings.Wide_Search is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Belongs - (Element : Wide_Character; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership) return Boolean; - pragma Inline (Belongs); - -- Determines if the given element is in (Test = Inside) or not in - -- (Test = Outside) the given character set. - - ------------- - -- Belongs -- - ------------- - - function Belongs - (Element : Wide_Character; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership) return Boolean - is - begin - if Test = Inside then - return Is_In (Element, Set); - else - return not Is_In (Element, Set); - end if; - end Belongs; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Num : Natural; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - Num := 0; - Ind := Source'First; - - -- Unmapped case - - if Mapping'Address = Wide_Maps.Identity'Address then - while Ind <= Source'Last - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - Num := Num + 1; - Ind := Ind + Pattern'Length; - else - Ind := Ind + 1; - end if; - end loop; - - -- Mapped case - - else - while Ind <= Source'Last - PL1 loop - Cur := Ind; - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - Ind := Ind + 1; - goto Cont; - else - Cur := Cur + 1; - end if; - end loop; - - Num := Num + 1; - Ind := Ind + Pattern'Length; - - <> - null; - end loop; - end if; - - -- Return result - - return Num; - end Count; - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Num : Natural; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Check for null pointer in case checks are off - - if Mapping = null then - raise Constraint_Error; - end if; - - Num := 0; - Ind := Source'First; - while Ind <= Source'Last - PL1 loop - Cur := Ind; - for K in Pattern'Range loop - if Pattern (K) /= Mapping (Source (Cur)) then - Ind := Ind + 1; - goto Cont; - else - Cur := Cur + 1; - end if; - end loop; - - Num := Num + 1; - Ind := Ind + Pattern'Length; - - <> - null; - end loop; - - return Num; - end Count; - - function Count - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural - is - N : Natural := 0; - - begin - for J in Source'Range loop - if Is_In (Source (J), Set) then - N := N + 1; - end if; - end loop; - - return N; - end Count; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - is - begin - for J in From .. Source'Last loop - if Belongs (Source (J), Set, Test) then - First := J; - - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; - - -- Here if J indexes first char of token, and all chars after J - -- are in the token. - - Last := Source'Last; - return; - end if; - end loop; - - -- Here if no token found - - First := From; - Last := 0; - end Find_Token; - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - is - begin - for J in Source'Range loop - if Belongs (Source (J), Set, Test) then - First := J; - - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; - - -- Here if J indexes first char of token, and all chars after J - -- are in the token. - - Last := Source'Last; - return; - end if; - end loop; - - -- Here if no token found - - -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if - -- Source'First is not positive and is assigned to First. Formulation - -- is slightly different in RM 2012, but the intent seems similar, so - -- we check explicitly for that condition. - - if Source'First not in Positive then - raise Constraint_Error; - - else - First := Source'First; - Last := 0; - end if; - end Find_Token; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Cur : Natural; - - Ind : Integer; - -- Index for start of match check. This can be negative if the pattern - -- length is greater than the string length, which is why this variable - -- is Integer instead of Natural. In this case, the search loops do not - -- execute at all, so this Ind value is never used. - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Forwards case - - if Going = Forward then - Ind := Source'First; - - -- Unmapped forward case - - if Mapping'Address = Wide_Maps.Identity'Address then - for J in 1 .. Source'Length - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - return Ind; - else - Ind := Ind + 1; - end if; - end loop; - - -- Mapped forward case - - else - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - goto Cont1; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind + 1; - end loop; - end if; - - -- Backwards case - - else - -- Unmapped backward case - - Ind := Source'Last - PL1; - - if Mapping'Address = Wide_Maps.Identity'Address then - for J in reverse 1 .. Source'Length - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - return Ind; - else - Ind := Ind - 1; - end if; - end loop; - - -- Mapped backward case - - else - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - goto Cont2; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind - 1; - end loop; - end if; - end if; - - -- Fall through if no match found. Note that the loops are skipped - -- completely in the case of the pattern being longer than the source. - - return 0; - end Index; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Check for null pointer in case checks are off - - if Mapping = null then - raise Constraint_Error; - end if; - - -- If Pattern longer than Source it can't be found - - if Pattern'Length > Source'Length then - return 0; - end if; - - -- Forwards case - - if Going = Forward then - Ind := Source'First; - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then - goto Cont1; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind + 1; - end loop; - - -- Backwards case - - else - Ind := Source'Last - PL1; - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then - goto Cont2; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind - 1; - end loop; - end if; - - -- Fall through if no match found. Note that the loops are skipped - -- completely in the case of the pattern being longer than the source. - - return 0; - end Index; - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - -- Forwards case - - if Going = Forward then - for J in Source'Range loop - if Belongs (Source (J), Set, Test) then - return J; - end if; - end loop; - - -- Backwards case - - else - for J in reverse Source'Range loop - if Belongs (Source (J), Set, Test) then - return J; - end if; - end loop; - end if; - - -- Fall through if no match - - return 0; - end Index; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index (Source (From .. Source'Last), Pattern, Forward, Mapping); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index (Source (Source'First .. From), Pattern, Backward, Mapping); - end if; - end Index; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return Index - (Source (From .. Source'Last), Pattern, Forward, Mapping); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return Index - (Source (Source'First .. From), Pattern, Backward, Mapping); - end if; - end Index; - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index (Source (From .. Source'Last), Set, Test, Forward); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index (Source (Source'First .. From), Set, Test, Backward); - end if; - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Wide_String; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - for J in Source'Range loop - if Source (J) /= Wide_Space then - return J; - end if; - end loop; - - else -- Going = Backward - for J in reverse Source'Range loop - if Source (J) /= Wide_Space then - return J; - end if; - end loop; - end if; - - -- Fall through if no match - - return 0; - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index_Non_Blank (Source (From .. Source'Last), Forward); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index_Non_Blank (Source (Source'First .. From), Backward); - end if; - end Index_Non_Blank; - -end Ada.Strings.Wide_Search; diff --git a/gcc/ada/a-stwise.ads b/gcc/ada/a-stwise.ads deleted file mode 100644 index 66d9cb2..0000000 --- a/gcc/ada/a-stwise.ads +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ S E A R C H -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the search functions from Ada.Strings.Wide_Fixed. --- They are separated out because they are shared by Ada.Strings.Wide_Bounded --- and Ada.Strings.Wide_Unbounded, and we don't want to drag in other --- irrelevant stuff from Ada.Strings.Wide_Fixed when using the other two --- packages. We make this a private package, since user programs should --- access these subprograms via one of the standard string packages. - -with Ada.Strings.Wide_Maps; - -private package Ada.Strings.Wide_Search is - pragma Preelaborate; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := - Wide_Maps.Identity) return Natural; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Index - (Source : Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Index - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Count - (Source : Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Count - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - -end Ada.Strings.Wide_Search; diff --git a/gcc/ada/a-stwisu.adb b/gcc/ada/a-stwisu.adb deleted file mode 100644 index 10c2b23..0000000 --- a/gcc/ada/a-stwisu.adb +++ /dev/null @@ -1,1933 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; -with Ada.Strings.Wide_Search; - -package body Ada.Strings.Wide_Superbounded is - - ------------ - -- Concat -- - ------------ - - function Concat - (Left : Super_String; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - end; - end return; - end Concat; - - function Concat - (Left : Super_String; - Right : Wide_String) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - Nlen : constant Natural := Llen + Right'Length; - - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end if; - end; - end return; - end Concat; - - function Concat - (Left : Wide_String; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Right.Max_Length) do - declare - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - end; - end return; - end Concat; - - function Concat - (Left : Super_String; - Right : Wide_Character) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - - begin - if Llen = Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Current_Length) := Right; - end if; - end; - end return; - end Concat; - - function Concat - (Left : Wide_Character; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Right.Max_Length) do - declare - Rlen : constant Natural := Right.Current_Length; - - begin - if Rlen = Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Current_Length) := - Right.Data (1 .. Rlen); - end if; - end; - end return; - end Concat; - - ----------- - -- Equal -- - ----------- - - function "=" - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Current_Length = Right.Current_Length - and then Left.Data (1 .. Left.Current_Length) = - Right.Data (1 .. Right.Current_Length); - end "="; - - function Equal - (Left : Super_String; - Right : Wide_String) return Boolean - is - begin - return Left.Current_Length = Right'Length - and then Left.Data (1 .. Left.Current_Length) = Right; - end Equal; - - function Equal - (Left : Wide_String; - Right : Super_String) return Boolean - is - begin - return Left'Length = Right.Current_Length - and then Left = Right.Data (1 .. Right.Current_Length); - end Equal; - - ------------- - -- Greater -- - ------------- - - function Greater - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) > - Right.Data (1 .. Right.Current_Length); - end Greater; - - function Greater - (Left : Super_String; - Right : Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) > Right; - end Greater; - - function Greater - (Left : Wide_String; - Right : Super_String) return Boolean - is - begin - return Left > Right.Data (1 .. Right.Current_Length); - end Greater; - - ---------------------- - -- Greater_Or_Equal -- - ---------------------- - - function Greater_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) >= - Right.Data (1 .. Right.Current_Length); - end Greater_Or_Equal; - - function Greater_Or_Equal - (Left : Super_String; - Right : Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) >= Right; - end Greater_Or_Equal; - - function Greater_Or_Equal - (Left : Wide_String; - Right : Super_String) return Boolean - is - begin - return Left >= Right.Data (1 .. Right.Current_Length); - end Greater_Or_Equal; - - ---------- - -- Less -- - ---------- - - function Less - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) < - Right.Data (1 .. Right.Current_Length); - end Less; - - function Less - (Left : Super_String; - Right : Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) < Right; - end Less; - - function Less - (Left : Wide_String; - Right : Super_String) return Boolean - is - begin - return Left < Right.Data (1 .. Right.Current_Length); - end Less; - - ------------------- - -- Less_Or_Equal -- - ------------------- - - function Less_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) <= - Right.Data (1 .. Right.Current_Length); - end Less_Or_Equal; - - function Less_Or_Equal - (Left : Super_String; - Right : Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) <= Right; - end Less_Or_Equal; - - function Less_Or_Equal - (Left : Wide_String; - Right : Super_String) return Boolean - is - begin - return Left <= Right.Data (1 .. Right.Current_Length); - end Less_Or_Equal; - - ---------------------- - -- Set_Super_String -- - ---------------------- - - procedure Set_Super_String - (Target : out Super_String; - Source : Wide_String; - Drop : Truncation := Error) - is - Slen : constant Natural := Source'Length; - Max_Length : constant Positive := Target.Max_Length; - - begin - if Slen <= Max_Length then - Target.Current_Length := Slen; - Target.Data (1 .. Slen) := Source; - - else - case Drop is - when Strings.Right => - Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); - - when Strings.Left => - Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Set_Super_String; - - ------------------ - -- Super_Append -- - ------------------ - - -- Case of Super_String and Super_String - - function Super_Append - (Left : Super_String; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Result.Data := Right.Data; - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Super_String; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - Rlen : constant Natural := New_Item.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Source.Data := New_Item.Data; - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of Super_String and Wide_String - - function Super_Append - (Left : Super_String; - Right : Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right (Right'First .. Right'First - 1 + - Max_Length - Llen); - - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right (Right'Last - (Max_Length - 1) .. Right'Last); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_String; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - Rlen : constant Natural := New_Item'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item; - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item (New_Item'First .. - New_Item'First - 1 + Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - (Max_Length - 1) .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of Wide_String and Super_String - - function Super_Append - (Left : Wide_String; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Right.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then - Result.Data (1 .. Max_Length) := - Left (Left'First .. Left'First + (Max_Length - 1)); - - else - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right.Data (Rlen - (Max_Length - 1) .. Rlen); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - -- Case of Super_String and Wide_Character - - function Super_Append - (Left : Super_String; - Right : Wide_Character; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - - begin - if Llen < Max_Length then - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1) := Right; - return Result; - - else - case Drop is - when Strings.Right => - return Left; - - when Strings.Left => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length - 1) := - Left.Data (2 .. Max_Length); - Result.Data (Max_Length) := Right; - return Result; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_Character; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - - begin - if Llen < Max_Length then - Source.Current_Length := Llen + 1; - Source.Data (Llen + 1) := New_Item; - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - null; - - when Strings.Left => - Source.Data (1 .. Max_Length - 1) := - Source.Data (2 .. Max_Length); - Source.Data (Max_Length) := New_Item; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of Wide_Character and Super_String - - function Super_Append - (Left : Wide_Character; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Right.Max_Length; - Result : Super_String (Max_Length); - Rlen : constant Natural := Right.Current_Length; - - begin - if Rlen < Max_Length then - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); - return Result; - - else - case Drop is - when Strings.Right => - Result.Current_Length := Max_Length; - Result.Data (1) := Left; - Result.Data (2 .. Max_Length) := - Right.Data (1 .. Max_Length - 1); - return Result; - - when Strings.Left => - return Right; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Append; - - ----------------- - -- Super_Count -- - ----------------- - - function Super_Count - (Source : Super_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return - Wide_Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); - end Super_Count; - - function Super_Count - (Source : Super_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - begin - return - Wide_Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); - end Super_Count; - - function Super_Count - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set) return Natural - is - begin - return Wide_Search.Count (Source.Data (1 .. Source.Current_Length), Set); - end Super_Count; - - ------------------ - -- Super_Delete -- - ------------------ - - function Super_Delete - (Source : Super_String; - From : Positive; - Through : Natural) return Super_String - is - Result : Super_String (Source.Max_Length); - Slen : constant Natural := Source.Current_Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return Source; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Result.Current_Length := From - 1; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - return Result; - - else - Result.Current_Length := Slen - Num_Delete; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - Result.Data (From .. Result.Current_Length) := - Source.Data (Through + 1 .. Slen); - return Result; - end if; - end Super_Delete; - - procedure Super_Delete - (Source : in out Super_String; - From : Positive; - Through : Natural) - is - Slen : constant Natural := Source.Current_Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Source.Current_Length := From - 1; - - else - Source.Current_Length := Slen - Num_Delete; - Source.Data (From .. Source.Current_Length) := - Source.Data (Through + 1 .. Slen); - end if; - end Super_Delete; - - ------------------- - -- Super_Element -- - ------------------- - - function Super_Element - (Source : Super_String; - Index : Positive) return Wide_Character - is - begin - if Index <= Source.Current_Length then - return Source.Data (Index); - else - raise Strings.Index_Error; - end if; - end Super_Element; - - ---------------------- - -- Super_Find_Token -- - ---------------------- - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Search.Find_Token - (Source.Data (From .. Source.Current_Length), Set, Test, First, Last); - end Super_Find_Token; - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Search.Find_Token - (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); - end Super_Find_Token; - - ---------------- - -- Super_Head -- - ---------------- - - function Super_Head - (Source : Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Current_Length := Count; - Result.Data (1 .. Count) := Source.Data (1 .. Count); - - elsif Count <= Max_Length then - Result.Current_Length := Count; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Count) := (others => Pad); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Max_Length - Npad) := - Source.Data (Count - Max_Length + 1 .. Slen); - Result.Data (Max_Length - Npad + 1 .. Max_Length) := - (others => Pad); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Head; - - procedure Super_Head - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - Temp : Wide_String (1 .. Max_Length); - - begin - if Npad <= 0 then - Source.Current_Length := Count; - - elsif Count <= Max_Length then - Source.Current_Length := Count; - Source.Data (Slen + 1 .. Count) := (others => Pad); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad > Max_Length then - Source.Data := (others => Pad); - - else - Temp := Source.Data; - Source.Data (1 .. Max_Length - Npad) := - Temp (Count - Max_Length + 1 .. Slen); - - for J in Max_Length - Npad + 1 .. Max_Length loop - Source.Data (J) := Pad; - end loop; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Head; - - ----------------- - -- Super_Index -- - ----------------- - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Set, Test, Going); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - return Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); - end Super_Index; - - --------------------------- - -- Super_Index_Non_Blank -- - --------------------------- - - function Super_Index_Non_Blank - (Source : Super_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return - Wide_Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), Going); - end Super_Index_Non_Blank; - - function Super_Index_Non_Blank - (Source : Super_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - return - Wide_Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), From, Going); - end Super_Index_Non_Blank; - - ------------------ - -- Super_Insert -- - ------------------ - - function Super_Insert - (Source : Super_String; - Before : Positive; - New_Item : Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Nlen : constant Natural := New_Item'Length; - Tlen : constant Natural := Slen + Nlen; - Blen : constant Natural := Before - 1; - Alen : constant Integer := Slen - Blen; - Droplen : constant Integer := Tlen - Max_Length; - - -- Tlen is the length of the total string before possible truncation. - -- Blen, Alen are the lengths of the before and after pieces of the - -- source string. - - begin - if Alen < 0 then - raise Ada.Strings.Index_Error; - - elsif Droplen <= 0 then - Result.Current_Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Tlen) := - Source.Data (Before .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Before .. Max_Length) := - New_Item (New_Item'First - .. New_Item'First + Max_Length - Before); - else - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Max_Length) := - Source.Data (Before .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (Before .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - New_Item (New_Item'Last - (Max_Length - Alen) + 1 - .. New_Item'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := - New_Item; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Insert; - - procedure Super_Insert - (Source : in out Super_String; - Before : Positive; - New_Item : Wide_String; - Drop : Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Super_Insert (Source, Before, New_Item, Drop); - end Super_Insert; - - ------------------ - -- Super_Length -- - ------------------ - - function Super_Length (Source : Super_String) return Natural is - begin - return Source.Current_Length; - end Super_Length; - - --------------------- - -- Super_Overwrite -- - --------------------- - - function Super_Overwrite - (Source : Super_String; - Position : Positive; - New_Item : Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Endpos : constant Natural := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Current_Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif New_Item'Length = 0 then - return Source; - - elsif Endpos <= Slen then - Result.Current_Length := Source.Current_Length; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - elsif Endpos <= Max_Length then - Result.Current_Length := Endpos; - Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - else - Result.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Position - 1) := - Source.Data (1 .. Position - 1); - - Result.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - return Result; - - when Strings.Left => - if New_Item'Length >= Max_Length then - Result.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - return Result; - - else - Result.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - Result.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - return Result; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Overwrite; - - procedure Super_Overwrite - (Source : in out Super_String; - Position : Positive; - New_Item : Wide_String; - Drop : Strings.Truncation := Strings.Error) - is - Max_Length : constant Positive := Source.Max_Length; - Endpos : constant Positive := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Current_Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Endpos <= Slen then - Source.Data (Position .. Endpos) := New_Item; - - elsif Endpos <= Max_Length then - Source.Data (Position .. Endpos) := New_Item; - Source.Current_Length := Endpos; - - else - Source.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - - when Strings.Left => - if New_Item'Length > Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - - Source.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Overwrite; - - --------------------------- - -- Super_Replace_Element -- - --------------------------- - - procedure Super_Replace_Element - (Source : in out Super_String; - Index : Positive; - By : Wide_Character) - is - begin - if Index <= Source.Current_Length then - Source.Data (Index) := By; - else - raise Ada.Strings.Index_Error; - end if; - end Super_Replace_Element; - - ------------------------- - -- Super_Replace_Slice -- - ------------------------- - - function Super_Replace_Slice - (Source : Super_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - - begin - if Low > Slen + 1 then - raise Strings.Index_Error; - - elsif High < Low then - return Super_Insert (Source, Low, By, Drop); - - else - declare - Blen : constant Natural := Natural'Max (0, Low - 1); - Alen : constant Natural := Natural'Max (0, Slen - High); - Tlen : constant Natural := Blen + By'Length + Alen; - Droplen : constant Integer := Tlen - Max_Length; - Result : Super_String (Max_Length); - - -- Tlen is the total length of the result string before any - -- truncation. Blen and Alen are the lengths of the pieces - -- of the original string that end up in the result string - -- before and after the replaced slice. - - begin - if Droplen <= 0 then - Result.Current_Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Tlen) := - Source.Data (High + 1 .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Low .. Max_Length) := - By (By'First .. By'First + Max_Length - Low); - else - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Max_Length) := - Source.Data (High + 1 .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (High + 1 .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - By (By'Last - (Max_Length - Alen) + 1 .. By'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := By; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end; - end if; - end Super_Replace_Slice; - - procedure Super_Replace_Slice - (Source : in out Super_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Super_Replace_Slice (Source, Low, High, By, Drop); - end Super_Replace_Slice; - - --------------------- - -- Super_Replicate -- - --------------------- - - function Super_Replicate - (Count : Natural; - Item : Wide_Character; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - - begin - if Count <= Max_Length then - Result.Current_Length := Count; - - elsif Drop = Strings.Error then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Max_Length; - end if; - - Result.Data (1 .. Result.Current_Length) := (others => Item); - return Result; - end Super_Replicate; - - function Super_Replicate - (Count : Natural; - Item : Wide_String; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String - is - Length : constant Integer := Count * Item'Length; - Result : Super_String (Max_Length); - Indx : Positive; - - begin - if Length <= Max_Length then - Result.Current_Length := Length; - - if Length > 0 then - Indx := 1; - - for J in 1 .. Count loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - end if; - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Indx := 1; - - while Indx + Item'Length <= Max_Length + 1 loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - - Result.Data (Indx .. Max_Length) := - Item (Item'First .. Item'First + Max_Length - Indx); - - when Strings.Left => - Indx := Max_Length; - - while Indx - Item'Length >= 1 loop - Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; - Indx := Indx - Item'Length; - end loop; - - Result.Data (1 .. Indx) := - Item (Item'Last - Indx + 1 .. Item'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Replicate; - - function Super_Replicate - (Count : Natural; - Item : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - begin - return - Super_Replicate - (Count, - Item.Data (1 .. Item.Current_Length), - Drop, - Item.Max_Length); - end Super_Replicate; - - ----------------- - -- Super_Slice -- - ----------------- - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Wide_String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - return R : Wide_String (Low .. High) do - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - end if; - - R := Source.Data (Low .. High); - end return; - end Super_Slice; - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Super_String - is - begin - return Result : Super_String (Source.Max_Length) do - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - end if; - - Result.Current_Length := High - Low + 1; - Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); - end return; - end Super_Slice; - - procedure Super_Slice - (Source : Super_String; - Target : out Super_String; - Low : Positive; - High : Natural) - is - begin - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else - Target.Current_Length := High - Low + 1; - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); - end if; - end Super_Slice; - - ---------------- - -- Super_Tail -- - ---------------- - - function Super_Tail - (Source : Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Current_Length := Count; - Result.Data (1 .. Count) := - Source.Data (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Result.Current_Length := Count; - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Max_Length) := - Source.Data (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - Result.Data (1 .. Max_Length - Slen) := (others => Pad); - Result.Data (Max_Length - Slen + 1 .. Max_Length) := - Source.Data (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Tail; - - procedure Super_Tail - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - Temp : constant Wide_String (1 .. Max_Length) := Source.Data; - - begin - if Npad <= 0 then - Source.Current_Length := Count; - Source.Data (1 .. Count) := - Temp (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Source.Current_Length := Count; - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Source.Data := (others => Pad); - - else - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Max_Length) := - Temp (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - for J in 1 .. Max_Length - Slen loop - Source.Data (J) := Pad; - end loop; - - Source.Data (Max_Length - Slen + 1 .. Max_Length) := - Temp (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Tail; - - --------------------- - -- Super_To_String -- - --------------------- - - function Super_To_String (Source : Super_String) return Wide_String is - begin - return R : Wide_String (1 .. Source.Current_Length) do - R := Source.Data (1 .. Source.Current_Length); - end return; - end Super_To_String; - - --------------------- - -- Super_Translate -- - --------------------- - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping) return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - Result.Current_Length := Source.Current_Length; - - for J in 1 .. Source.Current_Length loop - Result.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - - return Result; - end Super_Translate; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - is - begin - for J in 1 .. Source.Current_Length loop - Source.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - end Super_Translate; - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - Result.Current_Length := Source.Current_Length; - - for J in 1 .. Source.Current_Length loop - Result.Data (J) := Mapping.all (Source.Data (J)); - end loop; - - return Result; - end Super_Translate; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - is - begin - for J in 1 .. Source.Current_Length loop - Source.Data (J) := Mapping.all (Source.Data (J)); - end loop; - end Super_Translate; - - ---------------- - -- Super_Trim -- - ---------------- - - function Super_Trim - (Source : Super_String; - Side : Trim_End) return Super_String - is - Result : Super_String (Source.Max_Length); - Last : Natural := Source.Current_Length; - First : Positive := 1; - - begin - if Side = Left or else Side = Both then - while First <= Last and then Source.Data (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Source.Data (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); - return Result; - end Super_Trim; - - procedure Super_Trim - (Source : in out Super_String; - Side : Trim_End) - is - Max_Length : constant Positive := Source.Max_Length; - Last : Natural := Source.Current_Length; - First : Positive := 1; - Temp : Wide_String (1 .. Max_Length); - - begin - Temp (1 .. Last) := Source.Data (1 .. Last); - - if Side = Left or else Side = Both then - while First <= Last and then Temp (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Temp (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Source.Data := (others => Wide_NUL); - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); - end Super_Trim; - - function Super_Trim - (Source : Super_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := - Source.Data (First .. Last); - return Result; - end if; - end loop; - end if; - end loop; - - Result.Current_Length := 0; - return Result; - end Super_Trim; - - procedure Super_Trim - (Source : in out Super_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) - is - begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - if First = 1 then - Source.Current_Length := Last; - return; - else - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := - Source.Data (First .. Last); - - for J in Source.Current_Length + 1 .. - Source.Max_Length - loop - Source.Data (J) := Wide_NUL; - end loop; - - return; - end if; - end if; - end loop; - - Source.Current_Length := 0; - return; - end if; - end loop; - - Source.Current_Length := 0; - end Super_Trim; - - ----------- - -- Times -- - ----------- - - function Times - (Left : Natural; - Right : Wide_Character; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - - begin - if Left > Max_Length then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Left; - - for J in 1 .. Left loop - Result.Data (J) := Right; - end loop; - end if; - - return Result; - end Times; - - function Times - (Left : Natural; - Right : Wide_String; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - Pos : Positive := 1; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Left * Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Index_Error; - - else - Result.Current_Length := Nlen; - - if Nlen > 0 then - for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := Right; - Pos := Pos + Rlen; - end loop; - end if; - end if; - - return Result; - end Times; - - function Times - (Left : Natural; - Right : Super_String) return Super_String - is - Result : Super_String (Right.Max_Length); - Pos : Positive := 1; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Left * Rlen; - - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Nlen; - - if Nlen > 0 then - for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := - Right.Data (1 .. Rlen); - Pos := Pos + Rlen; - end loop; - end if; - end if; - - return Result; - end Times; - - --------------------- - -- To_Super_String -- - --------------------- - - function To_Super_String - (Source : Wide_String; - Max_Length : Natural; - Drop : Truncation := Error) return Super_String - is - Result : Super_String (Max_Length); - Slen : constant Natural := Source'Length; - - begin - if Slen <= Max_Length then - Result.Current_Length := Slen; - Result.Data (1 .. Slen) := Source; - - else - case Drop is - when Strings.Right => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); - - when Strings.Left => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end To_Super_String; - -end Ada.Strings.Wide_Superbounded; diff --git a/gcc/ada/a-stwisu.ads b/gcc/ada/a-stwisu.ads deleted file mode 100644 index e2f3c57..0000000 --- a/gcc/ada/a-stwisu.ads +++ /dev/null @@ -1,499 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This non generic package contains most of the implementation of the --- generic package Ada.Strings.Wide_Bounded.Generic_Bounded_Length. - --- It defines type Super_String as a discriminated record with the maximum --- length as the discriminant. Individual instantiations of the package --- Strings.Wide_Bounded.Generic_Bounded_Length use this type with --- an appropriate discriminant value set. - -with Ada.Strings.Wide_Maps; - -package Ada.Strings.Wide_Superbounded is - pragma Preelaborate; - - Wide_NUL : constant Wide_Character := Wide_Character'Val (0); - - -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length.Wide_Bounded_String is - -- derived from Super_String, with the constraint of the maximum length. - - type Super_String (Max_Length : Positive) is record - Current_Length : Natural := 0; - Data : Wide_String (1 .. Max_Length); - -- A previous version had a default initial value for Data, which is - -- no longer necessary, because we now special-case this type in the - -- compiler, so "=" composes properly for descendants of this type. - -- Leaving it out is more efficient. - end record; - - -- The subprograms defined for Super_String are similar to those defined - -- for Bounded_Wide_String, except that they have different names, so that - -- they can be renamed in Ada.Strings.Wide_Bounded.Generic_Bounded_Length. - - function Super_Length (Source : Super_String) return Natural; - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Super_String - (Source : Wide_String; - Max_Length : Natural; - Drop : Truncation := Error) return Super_String; - -- Note the additional parameter Max_Length, which specifies the maximum - -- length setting of the resulting Super_String value. - - -- The following procedures have declarations (and semantics) that are - -- exactly analogous to those declared in Ada.Strings.Wide_Bounded. - - function Super_To_String (Source : Super_String) return Wide_String; - - procedure Set_Super_String - (Target : out Super_String; - Source : Wide_String; - Drop : Truncation := Error); - - function Super_Append - (Left : Super_String; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Super_String; - Right : Wide_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Wide_String; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Super_String; - Right : Wide_Character; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Wide_Character; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Super_String; - Drop : Truncation := Error); - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_String; - Drop : Truncation := Error); - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_Character; - Drop : Truncation := Error); - - function Concat - (Left : Super_String; - Right : Super_String) return Super_String; - - function Concat - (Left : Super_String; - Right : Wide_String) return Super_String; - - function Concat - (Left : Wide_String; - Right : Super_String) return Super_String; - - function Concat - (Left : Super_String; - Right : Wide_Character) return Super_String; - - function Concat - (Left : Wide_Character; - Right : Super_String) return Super_String; - - function Super_Element - (Source : Super_String; - Index : Positive) return Wide_Character; - - procedure Super_Replace_Element - (Source : in out Super_String; - Index : Positive; - By : Wide_Character); - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Wide_String; - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Super_String; - - procedure Super_Slice - (Source : Super_String; - Target : out Super_String; - Low : Positive; - High : Natural); - - function "=" - (Left : Super_String; - Right : Super_String) return Boolean; - - function Equal - (Left : Super_String; - Right : Super_String) return Boolean renames "="; - - function Equal - (Left : Super_String; - Right : Wide_String) return Boolean; - - function Equal - (Left : Wide_String; - Right : Super_String) return Boolean; - - function Less - (Left : Super_String; - Right : Super_String) return Boolean; - - function Less - (Left : Super_String; - Right : Wide_String) return Boolean; - - function Less - (Left : Wide_String; - Right : Super_String) return Boolean; - - function Less_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean; - - function Less_Or_Equal - (Left : Super_String; - Right : Wide_String) return Boolean; - - function Less_Or_Equal - (Left : Wide_String; - Right : Super_String) return Boolean; - - function Greater - (Left : Super_String; - Right : Super_String) return Boolean; - - function Greater - (Left : Super_String; - Right : Wide_String) return Boolean; - - function Greater - (Left : Wide_String; - Right : Super_String) return Boolean; - - function Greater_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean; - - function Greater_Or_Equal - (Left : Super_String; - Right : Wide_String) return Boolean; - - function Greater_Or_Equal - (Left : Wide_String; - Right : Super_String) return Boolean; - - ---------------------- - -- Search Functions -- - ---------------------- - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Super_Index - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Super_Index - (Source : Super_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Super_Index - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Super_Index_Non_Blank - (Source : Super_String; - Going : Direction := Forward) return Natural; - - function Super_Index_Non_Blank - (Source : Super_String; - From : Positive; - Going : Direction := Forward) return Natural; - - function Super_Count - (Source : Super_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Super_Count - (Source : Super_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Super_Count - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set) return Natural; - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping) return Super_String; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping); - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Super_String; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Super_Replace_Slice - (Source : Super_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Replace_Slice - (Source : in out Super_String; - Low : Positive; - High : Natural; - By : Wide_String; - Drop : Truncation := Error); - - function Super_Insert - (Source : Super_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Insert - (Source : in out Super_String; - Before : Positive; - New_Item : Wide_String; - Drop : Truncation := Error); - - function Super_Overwrite - (Source : Super_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Overwrite - (Source : in out Super_String; - Position : Positive; - New_Item : Wide_String; - Drop : Truncation := Error); - - function Super_Delete - (Source : Super_String; - From : Positive; - Through : Natural) return Super_String; - - procedure Super_Delete - (Source : in out Super_String; - From : Positive; - Through : Natural); - - --------------------------------- - -- String Selector Subprograms -- - --------------------------------- - - function Super_Trim - (Source : Super_String; - Side : Trim_End) return Super_String; - - procedure Super_Trim - (Source : in out Super_String; - Side : Trim_End); - - function Super_Trim - (Source : Super_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Super_String; - - procedure Super_Trim - (Source : in out Super_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set); - - function Super_Head - (Source : Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) return Super_String; - - procedure Super_Head - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error); - - function Super_Tail - (Source : Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error) return Super_String; - - procedure Super_Tail - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Character := Wide_Space; - Drop : Truncation := Error); - - ------------------------------------ - -- String Constructor Subprograms -- - ------------------------------------ - - -- Note: in some of the following routines, there is an extra parameter - -- Max_Length which specifies the value of the maximum length for the - -- resulting Super_String value. - - function Times - (Left : Natural; - Right : Wide_Character; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Times - (Left : Natural; - Right : Wide_String; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Times - (Left : Natural; - Right : Super_String) return Super_String; - - function Super_Replicate - (Count : Natural; - Item : Wide_Character; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Super_Replicate - (Count : Natural; - Item : Wide_String; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Super_Replicate - (Count : Natural; - Item : Super_String; - Drop : Truncation := Error) return Super_String; - -private - -- Pragma Inline declarations - - pragma Inline ("="); - pragma Inline (Less); - pragma Inline (Less_Or_Equal); - pragma Inline (Greater); - pragma Inline (Greater_Or_Equal); - pragma Inline (Concat); - pragma Inline (Super_Count); - pragma Inline (Super_Element); - pragma Inline (Super_Find_Token); - pragma Inline (Super_Index); - pragma Inline (Super_Index_Non_Blank); - pragma Inline (Super_Length); - pragma Inline (Super_Replace_Element); - pragma Inline (Super_Slice); - pragma Inline (Super_To_String); - -end Ada.Strings.Wide_Superbounded; diff --git a/gcc/ada/a-stwiun-shared.adb b/gcc/ada/a-stwiun-shared.adb deleted file mode 100644 index 34811b7..0000000 --- a/gcc/ada/a-stwiun-shared.adb +++ /dev/null @@ -1,2128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Unbounded is - - use Ada.Strings.Wide_Maps; - - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - function Aligned_Max_Length (Max_Length : Natural) return Natural; - -- Returns recommended length of the shared string which is greater or - -- equal to specified length. Calculation take in sense alignment of - -- the allocated memory segments to use memory effectively by - -- Append/Insert/etc operations. - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := LR.Last + RR.Last; - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Left string is empty, return Rigth string - - elsif LR.Last = 0 then - Reference (RR); - DR := RR; - - -- Right string is empty, return Left string - - elsif RR.Last = 0 then - Reference (LR); - DR := LR; - - -- Overwise, allocate new shared string and fill data - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Unbounded_Wide_String - is - LR : constant Shared_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + Right'Length; - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Right is an empty string, return Left string - - elsif Right'Length = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := Right; - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := Left'Length + RR.Last; - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared one - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Left is empty string, return Right string - - elsif Left'Length = 0 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Left'Length) := Left; - DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_Character) return Unbounded_Wide_String - is - LR : constant Shared_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + 1; - DR : Shared_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (DL) := Right; - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_Character; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := 1 + RR.Last; - DR : Shared_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1) := Left; - DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Character) return Unbounded_Wide_String - is - DR : Shared_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if Left = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Left); - - for J in 1 .. Left loop - DR.Data (J) := Right; - end loop; - - DR.Last := Left; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Wide_String) return Unbounded_Wide_String - is - DL : constant Natural := Left * Right'Length; - DR : Shared_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + Right'Length - 1) := Right; - K := K + Right'Length; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - RR : constant Shared_Wide_String_Access := Right.Reference; - DL : constant Natural := Left * RR.Last; - DR : Shared_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Coefficient is one, just return string itself - - elsif Left = 1 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); - K := K + RR.Last; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); - end "<"; - - function "<" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) < Right; - end "<"; - - function "<" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left < RR.Data (1 .. RR.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); - end "<="; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) <= Right; - end "<="; - - function "<=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left <= RR.Data (1 .. RR.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - - begin - return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); - -- LR = RR means two strings shares shared string, thus they are equal - end "="; - - function "=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) = Right; - end "="; - - function "=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left = RR.Data (1 .. RR.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); - end ">"; - - function ">" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) > Right; - end ">"; - - function ">" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left > RR.Data (1 .. RR.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); - end ">="; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - LR : constant Shared_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) >= Right; - end ">="; - - function ">=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - RR : constant Shared_Wide_String_Access := Right.Reference; - begin - return Left >= RR.Data (1 .. RR.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_Wide_String) is - begin - Reference (Object.Reference); - end Adjust; - - ------------------------ - -- Aligned_Max_Length -- - ------------------------ - - function Aligned_Max_Length (Max_Length : Natural) return Natural is - Static_Size : constant Natural := - Empty_Shared_Wide_String'Size / Standard'Storage_Unit; - -- Total size of all static components - - Element_Size : constant Natural := - Wide_Character'Size / Standard'Storage_Unit; - - begin - return - (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) - * Min_Mul_Alloc - Static_Size) / Element_Size; - end Aligned_Max_Length; - - -------------- - -- Allocate -- - -------------- - - function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is - begin - -- Empty string requested, return shared empty string - - if Max_Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - return Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate requested space (and probably some more room) - - else - return new Shared_Wide_String (Aligned_Max_Length (Max_Length)); - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Unbounded_Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - NR : constant Shared_Wide_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_Wide_String_Access; - - begin - -- Source is an empty string, reuse New_Item data - - if SR.Last = 0 then - Reference (NR); - Source.Reference := NR; - Unreference (SR); - - -- New_Item is empty string, nothing to do - - elsif NR.Last = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_String_Access; - - begin - -- New_Item is an empty string, nothing to do - - if New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_Character) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_Wide_String_Access; - - begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then - SR.Data (SR.Last + 1) := New_Item; - SR.Last := SR.Last + 1; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - ------------------- - -- Can_Be_Reused -- - ------------------- - - function Can_Be_Reused - (Item : Shared_Wide_String_Access; - Length : Natural) return Boolean is - begin - return - System.Atomic_Counters.Is_One (Item.Counter) - and then Item.Max_Length >= Length - and then Item.Max_Length <= - Aligned_Max_Length (Length + Length / Growth_Factor); - end Can_Be_Reused; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Count (SR.Data (1 .. SR.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Empty slice is deleted, use the same shared string - - if From > Through then - Reference (SR); - DR := SR; - - -- Index is out of range - - elsif Through > SR.Last then - raise Index_Error; - - -- Compute size of the result - - else - DL := SR.Last - (Through - From + 1); - - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Delete; - - procedure Delete - (Source : in out Unbounded_Wide_String; - From : Positive; - Through : Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Nothing changed, return - - if From > Through then - null; - - -- Through is outside of the range - - elsif Through > SR.Last then - raise Index_Error; - - else - DL := SR.Last - (Through - From + 1); - - -- Result is empty, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_Wide_String; - Index : Positive) return Wide_Character - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - if Index <= SR.Last then - return SR.Data (Index); - else - raise Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_Wide_String) is - SR : constant Shared_Wide_String_Access := Object.Reference; - - begin - if SR /= null then - - -- The same controlled object can be finalized several times for - -- some reason. As per 7.6.1(24) this should have no ill effect, - -- so we need to add a guard for the case of finalizing the same - -- object twice. - - Object.Reference := null; - Unreference (SR); - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - Wide_Search.Find_Token - (SR.Data (From .. SR.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - Wide_Search.Find_Token - (SR.Data (1 .. SR.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Wide_String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); - begin - Deallocate (X); - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Result is empty, reuse shared empty string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Length of the string is the same as requested, reuse source shared - -- string. - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is more than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- contents and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Head; - - procedure Head - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Result is empty, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Result is same with source string, reuse source shared string - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - if Count > SR.Last then - for J in SR.Last + 1 .. Count loop - SR.Data (J) := Pad; - end loop; - end if; - - SR.Last := Count; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is greater than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- exists data and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - Source.Reference := DR; - Unreference (SR); - end if; - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index - (SR.Data (1 .. SR.Last), Set, From, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_String_Access := Source.Reference; - begin - return Wide_Search.Index_Non_Blank - (SR.Data (1 .. SR.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_Wide_String) is - begin - Reference (Object.Reference); - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_String_Access; - - begin - -- Check index first - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Inserted string is empty, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Insert; - - procedure Insert - (Source : in out Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Inserted string is empty, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string first - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_Wide_String) return Natural is - begin - return Source.Reference.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Result is same with source string, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Bounds check - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- String unchanged, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Overwrite; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_Wide_String_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_Wide_String; - Index : Positive; - By : Wide_Character) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Bounds check - - if Index <= SR.Last then - - -- Try to reuse existent shared string - - if Can_Be_Reused (SR, SR.Last) then - SR.Data (Index) := By; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (Index) := By; - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - else - raise Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation when removed slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - - -- Otherwise just insert string - - else - return Insert (Source, Low, By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Bounds check - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation only when replaced slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - SR.Data (Low .. Low + By'Length - 1) := By; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - - -- Otherwise just insert item - - else - Insert (Source, Low, By); - end if; - end Replace_Slice; - - ------------------------------- - -- Set_Unbounded_Wide_String -- - ------------------------------- - - procedure Set_Unbounded_Wide_String - (Target : out Unbounded_Wide_String; - Source : Wide_String) - is - TR : constant Shared_Wide_String_Access := Target.Reference; - DR : Shared_Wide_String_Access; - - begin - -- In case of empty string, reuse empty shared string - - if Source'Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_String'Access; - - else - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, Source'Length) then - Reference (TR); - DR := TR; - - -- Otherwise allocate new shared string - - else - DR := Allocate (Source'Length); - Target.Reference := DR; - end if; - - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - Unreference (TR); - end Set_Unbounded_Wide_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - else - return SR.Data (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- For empty result reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Result is hole source string, reuse source shared string - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Tail; - - procedure Tail - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - procedure Common - (SR : Shared_Wide_String_Access; - DR : Shared_Wide_String_Access; - Count : Natural); - -- Common code of tail computation. SR/DR can point to the same object - - ------------ - -- Common -- - ------------ - - procedure Common - (SR : Shared_Wide_String_Access; - DR : Shared_Wide_String_Access; - Count : Natural) is - begin - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end Common; - - begin - -- Result is empty string, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Length of the result is the same with length of the source string, - -- reuse source shared string. - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - Common (SR, SR, Count); - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - Common (SR, DR, Count); - Source.Reference := DR; - Unreference (SR); - end if; - end Tail; - - -------------------- - -- To_Wide_String -- - -------------------- - - function To_Wide_String - (Source : Unbounded_Wide_String) return Wide_String is - begin - return Source.Reference.Data (1 .. Source.Reference.Last); - end To_Wide_String; - - ------------------------------ - -- To_Unbounded_Wide_String -- - ------------------------------ - - function To_Unbounded_Wide_String - (Source : Wide_String) return Unbounded_Wide_String - is - DR : Shared_Wide_String_Access; - - begin - if Source'Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - DR := Allocate (Source'Length); - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_String; - - function To_Unbounded_Wide_String - (Length : Natural) return Unbounded_Wide_String - is - DR : Shared_Wide_String_Access; - - begin - if Length = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - DR := Allocate (Length); - DR.Last := Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - end Translate; - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - - exception - when others => - Unreference (DR); - - raise; - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DR : Shared_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - exception - when others => - if DR /= null then - Unreference (DR); - end if; - - raise; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_Wide_String; - Side : Trim_End) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - if DL = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Side : Trim_End) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- nothing to do. - - if DL = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - function Trim - (Source : Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_String - is - SR : constant Shared_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_String'Access); - DR := Empty_Shared_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DL := High - Low + 1; - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_Wide_String; - Target : out Unbounded_Wide_String; - Low : Positive; - High : Natural) - is - SR : constant Shared_Wide_String_Access := Source.Reference; - TR : constant Shared_Wide_String_Access := Target.Reference; - DL : Natural; - DR : Shared_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_String'Access; - Unreference (TR); - - else - DL := High - Low + 1; - - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, DL) then - TR.Data (1 .. DL) := SR.Data (Low .. High); - TR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Target.Reference := DR; - Unreference (TR); - end if; - end if; - end Unbounded_Slice; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_Wide_String_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation - (Shared_Wide_String, Shared_Wide_String_Access); - - Aux : Shared_Wide_String_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - - -- Reference counter of Empty_Shared_Wide_String must never reach - -- zero. - - pragma Assert (Aux /= Empty_Shared_Wide_String'Access); - - Free (Aux); - end if; - end Unreference; - -end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stwiun-shared.ads b/gcc/ada/a-stwiun-shared.ads deleted file mode 100644 index e37b1c2..0000000 --- a/gcc/ada/a-stwiun-shared.ads +++ /dev/null @@ -1,494 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is supported on: --- - all Alpha platforms --- - all ia64 platforms --- - all PowerPC platforms --- - all SPARC V9 platforms --- - all x86 platforms --- - all x86_64 platforms - -with Ada.Strings.Wide_Maps; -private with Ada.Finalization; -private with System.Atomic_Counters; - -package Ada.Strings.Wide_Unbounded is - pragma Preelaborate; - - type Unbounded_Wide_String is private; - pragma Preelaborable_Initialization (Unbounded_Wide_String); - - Null_Unbounded_Wide_String : constant Unbounded_Wide_String; - - function Length (Source : Unbounded_Wide_String) return Natural; - - type Wide_String_Access is access all Wide_String; - - procedure Free (X : in out Wide_String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_Wide_String - (Source : Wide_String) return Unbounded_Wide_String; - - function To_Unbounded_Wide_String - (Length : Natural) return Unbounded_Wide_String; - - function To_Wide_String - (Source : Unbounded_Wide_String) return Wide_String; - - procedure Set_Unbounded_Wide_String - (Target : out Unbounded_Wide_String; - Source : Wide_String); - pragma Ada_05 (Set_Unbounded_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Unbounded_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_Character); - - function "&" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_Character) return Unbounded_Wide_String; - - function "&" - (Left : Wide_Character; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function Element - (Source : Unbounded_Wide_String; - Index : Positive) return Wide_Character; - - procedure Replace_Element - (Source : in out Unbounded_Wide_String; - Index : Positive; - By : Wide_Character); - - function Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String; - - function Unbounded_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_Wide_String; - Target : out Unbounded_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Count - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - return Unbounded_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping); - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Unbounded_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Unbounded_Wide_String; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String); - - function Insert - (Source : Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) return Unbounded_Wide_String; - - procedure Insert - (Source : in out Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String); - - function Overwrite - (Source : Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) return Unbounded_Wide_String; - - procedure Overwrite - (Source : in out Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String); - - function Delete - (Source : Unbounded_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_String; - - procedure Delete - (Source : in out Unbounded_Wide_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_Wide_String; - Side : Trim_End) return Unbounded_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set); - - function Head - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; - - procedure Head - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space); - - function Tail - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; - - procedure Tail - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space); - - function "*" - (Left : Natural; - Right : Wide_Character) return Unbounded_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_String) return Unbounded_Wide_String; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - type Shared_Wide_String (Max_Length : Natural) is limited record - Counter : System.Atomic_Counters.Atomic_Counter; - -- Reference counter - - Last : Natural := 0; - Data : Wide_String (1 .. Max_Length); - -- Last is the index of last significant element of the Data. All - -- elements with larger indexes are just extra room for expansion. - end record; - - type Shared_Wide_String_Access is access all Shared_Wide_String; - - procedure Reference (Item : not null Shared_Wide_String_Access); - -- Increment reference counter. - - procedure Unreference (Item : not null Shared_Wide_String_Access); - -- Decrement reference counter. Deallocate Item when ref counter is zero - - function Can_Be_Reused - (Item : Shared_Wide_String_Access; - Length : Natural) return Boolean; - -- Returns True if Shared_Wide_String can be reused. There are two criteria - -- when Shared_Wide_String can be reused: its reference counter must be one - -- (thus Shared_Wide_String is owned exclusively) and its size is - -- sufficient to store string with specified length effectively. - - function Allocate (Max_Length : Natural) return Shared_Wide_String_Access; - -- Allocates new Shared_Wide_String with at least specified maximum length. - -- Actual maximum length of the allocated Shared_Wide_String can be - -- slightly greater. Returns reference to Empty_Shared_Wide_String when - -- requested length is zero. - - Empty_Shared_Wide_String : aliased Shared_Wide_String (0); - - function To_Unbounded (S : Wide_String) return Unbounded_Wide_String - renames To_Unbounded_Wide_String; - -- This renames are here only to be used in the pragma Stream_Convert - - type Unbounded_Wide_String is new AF.Controlled with record - Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; - end record; - - -- The Unbounded_Wide_String uses several techniques to increase speed of - -- the application: - - -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains - -- only the reference to the data which is shared between several - -- instances. The shared data is reallocated only when its value is - -- changed and the object mutation can't be used or it is inefficient to - -- use it; - - -- - object mutation. Shared data object can be reused without memory - -- reallocation when all of the following requirements are meat: - -- - shared data object don't used anywhere longer; - -- - its size is sufficient to store new value; - -- - the gap after reuse is less than some threshold. - - -- - memory preallocation. Most of used memory allocation algorithms - -- aligns allocated segment on the some boundary, thus some amount of - -- additional memory can be preallocated without any impact. Such - -- preallocated memory can used later by Append/Insert operations - -- without reallocation. - - -- Reference counting uses GCC builtin atomic operations, which allows safe - -- sharing of internal data between Ada tasks. Nevertheless, this does not - -- make objects of Unbounded_String thread-safe: an instance cannot be - -- accessed by several tasks simultaneously. - - pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); - -- Provide stream routines without dragging in Ada.Streams - - pragma Finalize_Storage_Only (Unbounded_Wide_String); - -- Finalization is required only for freeing storage - - overriding procedure Initialize (Object : in out Unbounded_Wide_String); - overriding procedure Adjust (Object : in out Unbounded_Wide_String); - overriding procedure Finalize (Object : in out Unbounded_Wide_String); - - Null_Unbounded_Wide_String : constant Unbounded_Wide_String := - (AF.Controlled with - Reference => - Empty_Shared_Wide_String'Access); - -end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stwiun.adb b/gcc/ada/a-stwiun.adb deleted file mode 100644 index 06f9d36..0000000 --- a/gcc/ada/a-stwiun.adb +++ /dev/null @@ -1,1097 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Fixed; -with Ada.Strings.Wide_Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Unbounded is - - use Ada.Finalization; - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - L_Length : constant Natural := Left.Last; - R_Length : constant Natural := Right.Last; - Result : Unbounded_Wide_String; - - begin - Result.Last := L_Length + R_Length; - - Result.Reference := new Wide_String (1 .. Result.Last); - - Result.Reference (1 .. L_Length) := - Left.Reference (1 .. Left.Last); - Result.Reference (L_Length + 1 .. Result.Last) := - Right.Reference (1 .. Right.Last); - - return Result; - end "&"; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Unbounded_Wide_String - is - L_Length : constant Natural := Left.Last; - Result : Unbounded_Wide_String; - - begin - Result.Last := L_Length + Right'Length; - - Result.Reference := new Wide_String (1 .. Result.Last); - - Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); - Result.Reference (L_Length + 1 .. Result.Last) := Right; - - return Result; - end "&"; - - function "&" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - R_Length : constant Natural := Right.Last; - Result : Unbounded_Wide_String; - - begin - Result.Last := Left'Length + R_Length; - - Result.Reference := new Wide_String (1 .. Result.Last); - - Result.Reference (1 .. Left'Length) := Left; - Result.Reference (Left'Length + 1 .. Result.Last) := - Right.Reference (1 .. Right.Last); - - return Result; - end "&"; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_Character) return Unbounded_Wide_String - is - Result : Unbounded_Wide_String; - - begin - Result.Last := Left.Last + 1; - - Result.Reference := new Wide_String (1 .. Result.Last); - - Result.Reference (1 .. Result.Last - 1) := - Left.Reference (1 .. Left.Last); - Result.Reference (Result.Last) := Right; - - return Result; - end "&"; - - function "&" - (Left : Wide_Character; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - Result : Unbounded_Wide_String; - - begin - Result.Last := Right.Last + 1; - - Result.Reference := new Wide_String (1 .. Result.Last); - Result.Reference (1) := Left; - Result.Reference (2 .. Result.Last) := - Right.Reference (1 .. Right.Last); - return Result; - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Character) return Unbounded_Wide_String - is - Result : Unbounded_Wide_String; - - begin - Result.Last := Left; - - Result.Reference := new Wide_String (1 .. Left); - for J in Result.Reference'Range loop - Result.Reference (J) := Right; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : Wide_String) return Unbounded_Wide_String - is - Len : constant Natural := Right'Length; - K : Positive; - Result : Unbounded_Wide_String; - - begin - Result.Last := Left * Len; - - Result.Reference := new Wide_String (1 .. Result.Last); - - K := 1; - for J in 1 .. Left loop - Result.Reference (K .. K + Len - 1) := Right; - K := K + Len; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_String) return Unbounded_Wide_String - is - Len : constant Natural := Right.Last; - K : Positive; - Result : Unbounded_Wide_String; - - begin - Result.Last := Left * Len; - - Result.Reference := new Wide_String (1 .. Result.Last); - - K := 1; - for J in 1 .. Left loop - Result.Reference (K .. K + Len - 1) := - Right.Reference (1 .. Right.Last); - K := K + Len; - end loop; - - return Result; - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); - end "<"; - - function "<" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) < Right; - end "<"; - - function "<" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return Left < Right.Reference (1 .. Right.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); - end "<="; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) <= Right; - end "<="; - - function "<=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return Left <= Right.Reference (1 .. Right.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); - end "="; - - function "=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) = Right; - end "="; - - function "=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return Left = Right.Reference (1 .. Right.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); - end ">"; - - function ">" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) > Right; - end ">"; - - function ">" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return Left > Right.Reference (1 .. Right.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); - end ">="; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) >= Right; - end ">="; - - function ">=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean - is - begin - return Left >= Right.Reference (1 .. Right.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_Wide_String) is - begin - -- Copy string, except we do not copy the statically allocated null - -- string, since it can never be deallocated. Note that we do not copy - -- extra string room here to avoid dragging unused allocated memory. - - if Object.Reference /= Null_Wide_String'Access then - Object.Reference := - new Wide_String'(Object.Reference (1 .. Object.Last)); - end if; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Unbounded_Wide_String) - is - begin - Realloc_For_Chunk (Source, New_Item.Last); - Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := - New_Item.Reference (1 .. New_Item.Last); - Source.Last := Source.Last + New_Item.Last; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_String) - is - begin - Realloc_For_Chunk (Source, New_Item'Length); - Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := - New_Item; - Source.Last := Source.Last + New_Item'Length; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_Character) - is - begin - Realloc_For_Chunk (Source, 1); - Source.Reference (Source.Last + 1) := New_Item; - Source.Last := Source.Last + 1; - end Append; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return - Wide_Search.Count - (Source.Reference (1 .. Source.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - begin - return - Wide_Search.Count - (Source.Reference (1 .. Source.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural - is - begin - return - Wide_Search.Count - (Source.Reference (1 .. Source.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_String - is - begin - return - To_Unbounded_Wide_String - (Wide_Fixed.Delete - (Source.Reference (1 .. Source.Last), From, Through)); - end Delete; - - procedure Delete - (Source : in out Unbounded_Wide_String; - From : Positive; - Through : Natural) - is - begin - if From > Through then - null; - - elsif From < Source.Reference'First or else Through > Source.Last then - raise Index_Error; - - else - declare - Len : constant Natural := Through - From + 1; - - begin - Source.Reference (From .. Source.Last - Len) := - Source.Reference (Through + 1 .. Source.Last); - Source.Last := Source.Last - Len; - end; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_Wide_String; - Index : Positive) return Wide_Character - is - begin - if Index <= Source.Last then - return Source.Reference (Index); - else - raise Strings.Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_Wide_String) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); - - begin - -- Note: Don't try to free statically allocated null string - - if Object.Reference /= Null_Wide_String'Access then - Deallocate (Object.Reference); - Object.Reference := Null_Unbounded_Wide_String.Reference; - Object.Last := 0; - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Search.Find_Token - (Source.Reference (From .. Source.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Search.Find_Token - (Source.Reference (1 .. Source.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Wide_String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); - - begin - -- Note: Do not try to free statically allocated null string - - if X /= Null_Unbounded_Wide_String.Reference then - Deallocate (X); - end if; - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String - is - begin - return To_Unbounded_Wide_String - (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); - end Head; - - procedure Head - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) - is - Old : Wide_String_Access := Source.Reference; - begin - Source.Reference := - new Wide_String' - (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); - Source.Last := Source.Reference'Length; - Free (Old); - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return - Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - begin - return - Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return Wide_Search.Index - (Source.Reference (1 .. Source.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural - is - begin - return - Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural - is - begin - return - Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - return - Wide_Search.Index - (Source.Reference (1 .. Source.Last), Set, From, Test, Going); - end Index; - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return - Wide_Search.Index_Non_Blank - (Source.Reference (1 .. Source.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - return - Wide_Search.Index_Non_Blank - (Source.Reference (1 .. Source.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_Wide_String) is - begin - Object.Reference := Null_Unbounded_Wide_String.Reference; - Object.Last := 0; - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) return Unbounded_Wide_String - is - begin - return - To_Unbounded_Wide_String - (Wide_Fixed.Insert - (Source.Reference (1 .. Source.Last), Before, New_Item)); - end Insert; - - procedure Insert - (Source : in out Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) - is - begin - if Before not in Source.Reference'First .. Source.Last + 1 then - raise Index_Error; - end if; - - Realloc_For_Chunk (Source, New_Item'Length); - - Source.Reference - (Before + New_Item'Length .. Source.Last + New_Item'Length) := - Source.Reference (Before .. Source.Last); - - Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; - Source.Last := Source.Last + New_Item'Length; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_Wide_String) return Natural is - begin - return Source.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) return Unbounded_Wide_String - is - begin - return - To_Unbounded_Wide_String - (Wide_Fixed.Overwrite - (Source.Reference (1 .. Source.Last), Position, New_Item)); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) - is - NL : constant Natural := New_Item'Length; - begin - if Position <= Source.Last - NL + 1 then - Source.Reference (Position .. Position + NL - 1) := New_Item; - else - declare - Old : Wide_String_Access := Source.Reference; - begin - Source.Reference := new Wide_String' - (Wide_Fixed.Overwrite - (Source.Reference (1 .. Source.Last), Position, New_Item)); - Source.Last := Source.Reference'Length; - Free (Old); - end; - end if; - end Overwrite; - - ----------------------- - -- Realloc_For_Chunk -- - ----------------------- - - procedure Realloc_For_Chunk - (Source : in out Unbounded_Wide_String; - Chunk_Size : Natural) - is - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - S_Length : constant Natural := Source.Reference'Length; - - begin - if Chunk_Size > S_Length - Source.Last then - declare - New_Size : constant Positive := - S_Length + Chunk_Size + (S_Length / Growth_Factor); - - New_Rounded_Up_Size : constant Positive := - ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc; - - Tmp : constant Wide_String_Access := - new Wide_String (1 .. New_Rounded_Up_Size); - - begin - Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); - Free (Source.Reference); - Source.Reference := Tmp; - end; - end if; - end Realloc_For_Chunk; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_Wide_String; - Index : Positive; - By : Wide_Character) - is - begin - if Index <= Source.Last then - Source.Reference (Index) := By; - else - raise Strings.Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Unbounded_Wide_String - is - begin - return To_Unbounded_Wide_String - (Wide_Fixed.Replace_Slice - (Source.Reference (1 .. Source.Last), Low, High, By)); - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) - is - Old : Wide_String_Access := Source.Reference; - begin - Source.Reference := new Wide_String' - (Wide_Fixed.Replace_Slice - (Source.Reference (1 .. Source.Last), Low, High, By)); - Source.Last := Source.Reference'Length; - Free (Old); - end Replace_Slice; - - ------------------------------- - -- Set_Unbounded_Wide_String -- - ------------------------------- - - procedure Set_Unbounded_Wide_String - (Target : out Unbounded_Wide_String; - Source : Wide_String) - is - begin - Target.Last := Source'Length; - Target.Reference := new Wide_String (1 .. Source'Length); - Target.Reference.all := Source; - end Set_Unbounded_Wide_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - return Source.Reference (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String is - begin - return To_Unbounded_Wide_String - (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); - end Tail; - - procedure Tail - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) - is - Old : Wide_String_Access := Source.Reference; - begin - Source.Reference := new Wide_String' - (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); - Source.Last := Source.Reference'Length; - Free (Old); - end Tail; - - ------------------------------ - -- To_Unbounded_Wide_String -- - ------------------------------ - - function To_Unbounded_Wide_String - (Source : Wide_String) - return Unbounded_Wide_String - is - Result : Unbounded_Wide_String; - begin - Result.Last := Source'Length; - Result.Reference := new Wide_String (1 .. Source'Length); - Result.Reference.all := Source; - return Result; - end To_Unbounded_Wide_String; - - function To_Unbounded_Wide_String - (Length : Natural) return Unbounded_Wide_String - is - Result : Unbounded_Wide_String; - begin - Result.Last := Length; - Result.Reference := new Wide_String (1 .. Length); - return Result; - end To_Unbounded_Wide_String; - - ------------------- - -- To_Wide_String -- - -------------------- - - function To_Wide_String - (Source : Unbounded_Wide_String) - return Wide_String - is - begin - return Source.Reference (1 .. Source.Last); - end To_Wide_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - return Unbounded_Wide_String - is - begin - return - To_Unbounded_Wide_String - (Wide_Fixed.Translate - (Source.Reference (1 .. Source.Last), Mapping)); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - is - begin - Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); - end Translate; - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Unbounded_Wide_String - is - begin - return - To_Unbounded_Wide_String - (Wide_Fixed.Translate - (Source.Reference (1 .. Source.Last), Mapping)); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - is - begin - Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_Wide_String; - Side : Trim_End) return Unbounded_Wide_String - is - begin - return - To_Unbounded_Wide_String - (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Side : Trim_End) - is - Old : Wide_String_Access := Source.Reference; - begin - Source.Reference := - new Wide_String' - (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); - Source.Last := Source.Reference'Length; - Free (Old); - end Trim; - - function Trim - (Source : Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) - return Unbounded_Wide_String - is - begin - return - To_Unbounded_Wide_String - (Wide_Fixed.Trim - (Source.Reference (1 .. Source.Last), Left, Right)); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) - is - Old : Wide_String_Access := Source.Reference; - begin - Source.Reference := - new Wide_String' - (Wide_Fixed.Trim - (Source.Reference (1 .. Source.Last), Left, Right)); - Source.Last := Source.Reference'Length; - Free (Old); - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_String - is - begin - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - return To_Unbounded_Wide_String (Source.Reference.all (Low .. High)); - end if; - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_Wide_String; - Target : out Unbounded_Wide_String; - Low : Positive; - High : Natural) - is - begin - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - Target := - To_Unbounded_Wide_String (Source.Reference.all (Low .. High)); - end if; - end Unbounded_Slice; - -end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stwiun.ads b/gcc/ada/a-stwiun.ads deleted file mode 100644 index dcec889..0000000 --- a/gcc/ada/a-stwiun.ads +++ /dev/null @@ -1,443 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2010, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Maps; -with Ada.Finalization; - -package Ada.Strings.Wide_Unbounded is - pragma Preelaborate; - - type Unbounded_Wide_String is private; - pragma Preelaborable_Initialization (Unbounded_Wide_String); - - Null_Unbounded_Wide_String : constant Unbounded_Wide_String; - - function Length (Source : Unbounded_Wide_String) return Natural; - - type Wide_String_Access is access all Wide_String; - - procedure Free (X : in out Wide_String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_Wide_String - (Source : Wide_String) return Unbounded_Wide_String; - - function To_Unbounded_Wide_String - (Length : Natural) return Unbounded_Wide_String; - - function To_Wide_String - (Source : Unbounded_Wide_String) - return Wide_String; - - procedure Set_Unbounded_Wide_String - (Target : out Unbounded_Wide_String; - Source : Wide_String); - pragma Ada_05 (Set_Unbounded_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Unbounded_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_String; - New_Item : Wide_Character); - - function "&" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function "&" - (Left : Unbounded_Wide_String; - Right : Wide_Character) return Unbounded_Wide_String; - - function "&" - (Left : Wide_Character; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - - function Element - (Source : Unbounded_Wide_String; - Index : Positive) return Wide_Character; - - procedure Replace_Element - (Source : in out Unbounded_Wide_String; - Index : Positive; - By : Wide_Character); - - function Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Wide_String; - - function Unbounded_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_Wide_String; - Target : out Unbounded_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function "<=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_String; - Right : Wide_String) return Boolean; - - function ">=" - (Left : Wide_String; - Right : Unbounded_Wide_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) - return Natural; - - function Count - (Source : Unbounded_Wide_String; - Pattern : Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; - - function Count - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_Wide_String; - Set : Wide_Maps.Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping) - return Unbounded_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping); - - function Translate - (Source : Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function) - return Unbounded_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_String; - Mapping : Wide_Maps.Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String) return Unbounded_Wide_String; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_String; - Low : Positive; - High : Natural; - By : Wide_String); - - function Insert - (Source : Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String) return Unbounded_Wide_String; - - procedure Insert - (Source : in out Unbounded_Wide_String; - Before : Positive; - New_Item : Wide_String); - - function Overwrite - (Source : Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String) return Unbounded_Wide_String; - - procedure Overwrite - (Source : in out Unbounded_Wide_String; - Position : Positive; - New_Item : Wide_String); - - function Delete - (Source : Unbounded_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_String; - - procedure Delete - (Source : in out Unbounded_Wide_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_Wide_String; - Side : Trim_End) return Unbounded_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_String; - Left : Wide_Maps.Wide_Character_Set; - Right : Wide_Maps.Wide_Character_Set); - - function Head - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; - - procedure Head - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space); - - function Tail - (Source : Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; - - procedure Tail - (Source : in out Unbounded_Wide_String; - Count : Natural; - Pad : Wide_Character := Wide_Space); - - function "*" - (Left : Natural; - Right : Wide_Character) return Unbounded_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_String) return Unbounded_Wide_String; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_String) return Unbounded_Wide_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - Null_Wide_String : aliased Wide_String := ""; - - function To_Unbounded_Wide (S : Wide_String) return Unbounded_Wide_String - renames To_Unbounded_Wide_String; - - type Unbounded_Wide_String is new AF.Controlled with record - Reference : Wide_String_Access := Null_Wide_String'Access; - Last : Natural := 0; - end record; - - -- The Unbounded_Wide_String is using a buffered implementation to increase - -- speed of the Append/Delete/Insert procedures. The Reference string - -- pointer above contains the current string value and extra room at the - -- end to be used by the next Append routine. Last is the index of the - -- string ending character. So the current string value is really - -- Reference (1 .. Last). - - pragma Stream_Convert - (Unbounded_Wide_String, To_Unbounded_Wide, To_Wide_String); - - pragma Finalize_Storage_Only (Unbounded_Wide_String); - -- Finalization is required only for freeing storage - - procedure Initialize (Object : in out Unbounded_Wide_String); - procedure Adjust (Object : in out Unbounded_Wide_String); - procedure Finalize (Object : in out Unbounded_Wide_String); - - procedure Realloc_For_Chunk - (Source : in out Unbounded_Wide_String; - Chunk_Size : Natural); - -- Adjust the size allocated for the string. Add at least Chunk_Size so it - -- is safe to add a string of this size at the end of the current content. - -- The real size allocated for the string is Chunk_Size + x of the current - -- string size. This buffered handling makes the Append unbounded string - -- routines very fast. - - Null_Unbounded_Wide_String : constant Unbounded_Wide_String := - (AF.Controlled with - Reference => Null_Wide_String'Access, - Last => 0); -end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/a-stzbou.adb b/gcc/ada/a-stzbou.adb deleted file mode 100644 index 76e7292..0000000 --- a/gcc/ada/a-stzbou.adb +++ /dev/null @@ -1,94 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Wide_Bounded is - - package body Generic_Bounded_Length is - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Bounded_Wide_Wide_String - is - begin - return Times (Left, Right, Max_Length); - end "*"; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Bounded_Wide_Wide_String - is - begin - return Times (Left, Right, Max_Length); - end "*"; - - --------------- - -- Replicate -- - --------------- - - function Replicate - (Count : Natural; - Item : Wide_Wide_Character; - Drop : Strings.Truncation := Strings.Error) - return Bounded_Wide_Wide_String - is - begin - return Super_Replicate (Count, Item, Drop, Max_Length); - end Replicate; - - function Replicate - (Count : Natural; - Item : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) - return Bounded_Wide_Wide_String - is - begin - return Super_Replicate (Count, Item, Drop, Max_Length); - end Replicate; - - --------------------------------- - -- To_Bounded_Wide_Wide_String -- - --------------------------------- - - function To_Bounded_Wide_Wide_String - (Source : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) - return Bounded_Wide_Wide_String - is - begin - return To_Super_String (Source, Max_Length, Drop); - end To_Bounded_Wide_Wide_String; - - end Generic_Bounded_Length; -end Ada.Strings.Wide_Wide_Bounded; diff --git a/gcc/ada/a-stzbou.ads b/gcc/ada/a-stzbou.ads deleted file mode 100644 index d7d3f52..0000000 --- a/gcc/ada/a-stzbou.ads +++ /dev/null @@ -1,937 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Maps; -with Ada.Strings.Wide_Wide_Superbounded; - -package Ada.Strings.Wide_Wide_Bounded is - pragma Preelaborate; - - generic - Max : Positive; - -- Maximum length of a Bounded_Wide_Wide_String - - package Generic_Bounded_Length is - - Max_Length : constant Positive := Max; - - type Bounded_Wide_Wide_String is private; - pragma Preelaborable_Initialization (Bounded_Wide_Wide_String); - - Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String; - - subtype Length_Range is Natural range 0 .. Max_Length; - - function Length (Source : Bounded_Wide_Wide_String) return Length_Range; - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Bounded_Wide_Wide_String - (Source : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - function To_Wide_Wide_String - (Source : Bounded_Wide_Wide_String) return Wide_Wide_String; - - procedure Set_Bounded_Wide_Wide_String - (Target : out Bounded_Wide_Wide_String; - Source : Wide_Wide_String; - Drop : Truncation := Error); - pragma Ada_05 (Set_Bounded_Wide_Wide_String); - - function Append - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - function Append - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - function Append - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - function Append - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_Character; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - function Append - (Left : Wide_Wide_Character; - Right : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - procedure Append - (Source : in out Bounded_Wide_Wide_String; - New_Item : Bounded_Wide_Wide_String; - Drop : Truncation := Error); - - procedure Append - (Source : in out Bounded_Wide_Wide_String; - New_Item : Wide_Wide_String; - Drop : Truncation := Error); - - procedure Append - (Source : in out Bounded_Wide_Wide_String; - New_Item : Wide_Wide_Character; - Drop : Truncation := Error); - - function "&" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; - - function "&" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Bounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; - - function "&" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Bounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_Character; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; - - function Element - (Source : Bounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character; - - procedure Replace_Element - (Source : in out Bounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character); - - function Slice - (Source : Bounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String; - - function Bounded_Slice - (Source : Bounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Bounded_Wide_Wide_String; - pragma Ada_05 (Bounded_Slice); - - procedure Bounded_Slice - (Source : Bounded_Wide_Wide_String; - Target : out Bounded_Wide_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Bounded_Slice); - - function "=" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function "=" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "=" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<=" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">=" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean; - - ---------------------- - -- Search Functions -- - ---------------------- - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Index - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Bounded_Wide_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Bounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Count - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Count - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Bounded_Wide_Wide_String; - - procedure Translate - (Source : in out Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); - - function Translate - (Source : Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Bounded_Wide_Wide_String; - - procedure Translate - (Source : in out Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Bounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - procedure Replace_Slice - (Source : in out Bounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error); - - function Insert - (Source : Bounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - procedure Insert - (Source : in out Bounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error); - - function Overwrite - (Source : Bounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - procedure Overwrite - (Source : in out Bounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error); - - function Delete - (Source : Bounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Bounded_Wide_Wide_String; - - procedure Delete - (Source : in out Bounded_Wide_Wide_String; - From : Positive; - Through : Natural); - - --------------------------------- - -- String Selector Subprograms -- - --------------------------------- - - function Trim - (Source : Bounded_Wide_Wide_String; - Side : Trim_End) return Bounded_Wide_Wide_String; - - procedure Trim - (Source : in out Bounded_Wide_Wide_String; - Side : Trim_End); - - function Trim - (Source : Bounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Bounded_Wide_Wide_String; - - procedure Trim - (Source : in out Bounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set); - - function Head - (Source : Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - procedure Head - (Source : in out Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error); - - function Tail - (Source : Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - procedure Tail - (Source : in out Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error); - - ------------------------------------ - -- String Constructor Subprograms -- - ------------------------------------ - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Bounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Bounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; - - function Replicate - (Count : Natural; - Item : Wide_Wide_Character; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - function Replicate - (Count : Natural; - Item : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - function Replicate - (Count : Natural; - Item : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String; - - private - -- Most of the implementation is in the separate non generic package - -- Ada.Strings.Wide_Wide_Superbounded. Type Bounded_Wide_Wide_String is - -- derived from type Wide_Wide_Superbounded.Super_String with the - -- maximum length constraint. In almost all cases, the routines in - -- Wide_Wide_Superbounded can be called with no requirement to pass the - -- maximum length explicitly, since there is at least one - -- Bounded_Wide_Wide_String argument from which the maximum length can - -- be obtained. For all such routines, the implementation in this - -- private part is simply renaming of the corresponding routine in the - -- super bouded package. - - -- The five exceptions are the * and Replicate routines operating on - -- character values. For these cases, we have a routine in the body - -- that calls the superbounded routine passing the maximum length - -- explicitly as an extra parameter. - - type Bounded_Wide_Wide_String is - new Wide_Wide_Superbounded.Super_String (Max_Length); - -- Deriving Bounded_Wide_Wide_String from - -- Wide_Wide_Superbounded.Super_String is the real trick, it ensures - -- that the type Bounded_Wide_Wide_String declared in the generic - -- instantiation is compatible with the Super_String type declared in - -- the Wide_Wide_Superbounded package. - - Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String := - (Max_Length => Max_Length, - Current_Length => 0, - Data => - (1 .. Max_Length => - Wide_Wide_Superbounded.Wide_Wide_NUL)); - - pragma Inline (To_Bounded_Wide_Wide_String); - - procedure Set_Bounded_Wide_Wide_String - (Target : out Bounded_Wide_Wide_String; - Source : Wide_Wide_String; - Drop : Truncation := Error) - renames Set_Super_String; - - function Length - (Source : Bounded_Wide_Wide_String) return Length_Range - renames Super_Length; - - function To_Wide_Wide_String - (Source : Bounded_Wide_Wide_String) return Wide_Wide_String - renames Super_To_String; - - function Append - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Append; - - function Append - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Append; - - function Append - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Append; - - function Append - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_Character; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Append; - - function Append - (Left : Wide_Wide_Character; - Right : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Append; - - procedure Append - (Source : in out Bounded_Wide_Wide_String; - New_Item : Bounded_Wide_Wide_String; - Drop : Truncation := Error) - renames Super_Append; - - procedure Append - (Source : in out Bounded_Wide_Wide_String; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) - renames Super_Append; - - procedure Append - (Source : in out Bounded_Wide_Wide_String; - New_Item : Wide_Wide_Character; - Drop : Truncation := Error) - renames Super_Append; - - function "&" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String - renames Concat; - - function "&" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Bounded_Wide_Wide_String - renames Concat; - - function "&" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String - renames Concat; - - function "&" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Bounded_Wide_Wide_String - renames Concat; - - function "&" - (Left : Wide_Wide_Character; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String - renames Concat; - - function Element - (Source : Bounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character - renames Super_Element; - - procedure Replace_Element - (Source : in out Bounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character) - renames Super_Replace_Element; - - function Slice - (Source : Bounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String - renames Super_Slice; - - function Bounded_Slice - (Source : Bounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Bounded_Wide_Wide_String - renames Super_Slice; - - procedure Bounded_Slice - (Source : Bounded_Wide_Wide_String; - Target : out Bounded_Wide_Wide_String; - Low : Positive; - High : Natural) - renames Super_Slice; - - overriding function "=" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Equal; - - function "=" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - renames Equal; - - function "=" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Equal; - - function "<" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Less; - - function "<" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - renames Less; - - function "<" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Less; - - function "<=" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Less_Or_Equal; - - function "<=" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - renames Less_Or_Equal; - - function "<=" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Less_Or_Equal; - - function ">" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Greater; - - function ">" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - renames Greater; - - function ">" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Greater; - - function ">=" - (Left : Bounded_Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Greater_Or_Equal; - - function ">=" - (Left : Bounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - renames Greater_Or_Equal; - - function ">=" - (Left : Wide_Wide_String; - Right : Bounded_Wide_Wide_String) return Boolean - renames Greater_Or_Equal; - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - renames Super_Index; - - function Index - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Super_Index; - - function Index_Non_Blank - (Source : Bounded_Wide_Wide_String; - Going : Direction := Forward) return Natural - renames Super_Index_Non_Blank; - - function Index_Non_Blank - (Source : Bounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - renames Super_Index_Non_Blank; - - function Count - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural - renames Super_Count; - - function Count - (Source : Bounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - renames Super_Count; - - function Count - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural - renames Super_Count; - - procedure Find_Token - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Super_Find_Token; - - procedure Find_Token - (Source : Bounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Super_Find_Token; - - function Translate - (Source : Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Bounded_Wide_Wide_String - renames Super_Translate; - - procedure Translate - (Source : in out Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - renames Super_Translate; - - function Translate - (Source : Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Bounded_Wide_Wide_String - renames Super_Translate; - - procedure Translate - (Source : in out Bounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - renames Super_Translate; - - function Replace_Slice - (Source : Bounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Replace_Slice; - - procedure Replace_Slice - (Source : in out Bounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error) - renames Super_Replace_Slice; - - function Insert - (Source : Bounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Insert; - - procedure Insert - (Source : in out Bounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) - renames Super_Insert; - - function Overwrite - (Source : Bounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Overwrite; - - procedure Overwrite - (Source : in out Bounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) - renames Super_Overwrite; - - function Delete - (Source : Bounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Bounded_Wide_Wide_String - renames Super_Delete; - - procedure Delete - (Source : in out Bounded_Wide_Wide_String; - From : Positive; - Through : Natural) - renames Super_Delete; - - function Trim - (Source : Bounded_Wide_Wide_String; - Side : Trim_End) return Bounded_Wide_Wide_String - renames Super_Trim; - - procedure Trim - (Source : in out Bounded_Wide_Wide_String; - Side : Trim_End) - renames Super_Trim; - - function Trim - (Source : Bounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Bounded_Wide_Wide_String - renames Super_Trim; - - procedure Trim - (Source : in out Bounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - renames Super_Trim; - - function Head - (Source : Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Head; - - procedure Head - (Source : in out Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) - renames Super_Head; - - function Tail - (Source : Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Tail; - - procedure Tail - (Source : in out Bounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) - renames Super_Tail; - - function "*" - (Left : Natural; - Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String - renames Times; - - function Replicate - (Count : Natural; - Item : Bounded_Wide_Wide_String; - Drop : Truncation := Error) return Bounded_Wide_Wide_String - renames Super_Replicate; - - end Generic_Bounded_Length; - -end Ada.Strings.Wide_Wide_Bounded; diff --git a/gcc/ada/a-stzfix.adb b/gcc/ada/a-stzfix.adb deleted file mode 100644 index b008783..0000000 --- a/gcc/ada/a-stzfix.adb +++ /dev/null @@ -1,694 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ F I X E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps; -with Ada.Strings.Wide_Wide_Search; - -package body Ada.Strings.Wide_Wide_Fixed is - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural - renames Ada.Strings.Wide_Wide_Search.Index; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - renames Ada.Strings.Wide_Wide_Search.Index; - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Wide_Search.Index; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural - renames Ada.Strings.Wide_Wide_Search.Index; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - renames Ada.Strings.Wide_Wide_Search.Index; - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Wide_Search.Index; - - function Index_Non_Blank - (Source : Wide_Wide_String; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank; - - function Index_Non_Blank - (Source : Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank; - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural - renames Ada.Strings.Wide_Wide_Search.Count; - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - renames Ada.Strings.Wide_Wide_Search.Count; - - function Count - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural - renames Ada.Strings.Wide_Wide_Search.Count; - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Ada.Strings.Wide_Wide_Search.Find_Token; - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - renames Ada.Strings.Wide_Wide_Search.Find_Token; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Left); - - begin - for J in Result'Range loop - Result (J) := Right; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Left * Right'Length); - Ptr : Integer := 1; - - begin - for J in 1 .. Left loop - Result (Ptr .. Ptr + Right'Length - 1) := Right; - Ptr := Ptr + Right'Length; - end loop; - - return Result; - end "*"; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Wide_Wide_String; - From : Positive; - Through : Natural) return Wide_Wide_String - is - begin - if From not in Source'Range - or else Through > Source'Last - then - raise Index_Error; - - elsif From > Through then - return Source; - - else - declare - Len : constant Integer := Source'Length - (Through - From + 1); - Result : constant Wide_Wide_String - (Source'First .. Source'First + Len - 1) := - Source (Source'First .. From - 1) & - Source (Through + 1 .. Source'Last); - begin - return Result; - end; - end if; - end Delete; - - procedure Delete - (Source : in out Wide_Wide_String; - From : Positive; - Through : Natural; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - begin - Move (Source => Delete (Source, From, Through), - Target => Source, - Justify => Justify, - Pad => Pad); - end Delete; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Count); - - begin - if Count <= Source'Length then - Result := Source (Source'First .. Source'First + Count - 1); - - else - Result (1 .. Source'Length) := Source; - - for J in Source'Length + 1 .. Count loop - Result (J) := Pad; - end loop; - end if; - - return Result; - end Head; - - procedure Head - (Source : in out Wide_Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) - is - begin - Move (Source => Head (Source, Count, Pad), - Target => Source, - Drop => Error, - Justify => Justify, - Pad => Pad); - end Head; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Source'Length + New_Item'Length); - - begin - if Before < Source'First or else Before > Source'Last + 1 then - raise Index_Error; - end if; - - Result := Source (Source'First .. Before - 1) & New_Item & - Source (Before .. Source'Last); - return Result; - end Insert; - - procedure Insert - (Source : in out Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) - is - begin - Move (Source => Insert (Source, Before, New_Item), - Target => Source, - Drop => Drop); - end Insert; - - ---------- - -- Move -- - ---------- - - procedure Move - (Source : Wide_Wide_String; - Target : out Wide_Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - Sfirst : constant Integer := Source'First; - Slast : constant Integer := Source'Last; - Slength : constant Integer := Source'Length; - - Tfirst : constant Integer := Target'First; - Tlast : constant Integer := Target'Last; - Tlength : constant Integer := Target'Length; - - function Is_Padding (Item : Wide_Wide_String) return Boolean; - -- Determinbe if all characters in Item are pad characters - - function Is_Padding (Item : Wide_Wide_String) return Boolean is - begin - for J in Item'Range loop - if Item (J) /= Pad then - return False; - end if; - end loop; - - return True; - end Is_Padding; - - -- Start of processing for Move - - begin - if Slength = Tlength then - Target := Source; - - elsif Slength > Tlength then - case Drop is - when Left => - Target := Source (Slast - Tlength + 1 .. Slast); - - when Right => - Target := Source (Sfirst .. Sfirst + Tlength - 1); - - when Error => - case Justify is - when Left => - if Is_Padding (Source (Sfirst + Tlength .. Slast)) then - Target := - Source (Sfirst .. Sfirst + Target'Length - 1); - else - raise Length_Error; - end if; - - when Right => - if Is_Padding (Source (Sfirst .. Slast - Tlength)) then - Target := Source (Slast - Tlength + 1 .. Slast); - else - raise Length_Error; - end if; - - when Center => - raise Length_Error; - end case; - - end case; - - -- Source'Length < Target'Length - - else - case Justify is - when Left => - Target (Tfirst .. Tfirst + Slength - 1) := Source; - - for J in Tfirst + Slength .. Tlast loop - Target (J) := Pad; - end loop; - - when Right => - for J in Tfirst .. Tlast - Slength loop - Target (J) := Pad; - end loop; - - Target (Tlast - Slength + 1 .. Tlast) := Source; - - when Center => - declare - Front_Pad : constant Integer := (Tlength - Slength) / 2; - Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; - - begin - for J in Tfirst .. Tfirst_Fpad - 1 loop - Target (J) := Pad; - end loop; - - Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; - - for J in Tfirst_Fpad + Slength .. Tlast loop - Target (J) := Pad; - end loop; - end; - end case; - end if; - end Move; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Wide_Wide_String - is - begin - if Position not in Source'First .. Source'Last + 1 then - raise Index_Error; - else - declare - Result_Length : constant Natural := - Natural'Max - (Source'Length, - Position - Source'First + New_Item'Length); - - Result : Wide_Wide_String (1 .. Result_Length); - - begin - Result := Source (Source'First .. Position - 1) & New_Item & - Source (Position + New_Item'Length .. Source'Last); - return Result; - end; - end if; - end Overwrite; - - procedure Overwrite - (Source : in out Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Right) - is - begin - Move (Source => Overwrite (Source, Position, New_Item), - Target => Source, - Drop => Drop); - end Overwrite; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Wide_Wide_String - is - begin - if Low > Source'Last + 1 or else High < Source'First - 1 then - raise Index_Error; - end if; - - if High >= Low then - declare - Front_Len : constant Integer := - Integer'Max (0, Low - Source'First); - -- Length of prefix of Source copied to result - - Back_Len : constant Integer := - Integer'Max (0, Source'Last - High); - -- Length of suffix of Source copied to result - - Result_Length : constant Integer := - Front_Len + By'Length + Back_Len; - -- Length of result - - Result : Wide_Wide_String (1 .. Result_Length); - - begin - Result (1 .. Front_Len) := Source (Source'First .. Low - 1); - Result (Front_Len + 1 .. Front_Len + By'Length) := By; - Result (Front_Len + By'Length + 1 .. Result'Length) := - Source (High + 1 .. Source'Last); - return Result; - end; - - else - return Insert (Source, Before => Low, New_Item => By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - begin - Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); - end Replace_Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Count); - - begin - if Count < Source'Length then - Result := Source (Source'Last - Count + 1 .. Source'Last); - - -- Pad on left - - else - for J in 1 .. Count - Source'Length loop - Result (J) := Pad; - end loop; - - Result (Count - Source'Length + 1 .. Count) := Source; - end if; - - return Result; - end Tail; - - procedure Tail - (Source : in out Wide_Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) - is - begin - Move (Source => Tail (Source, Count, Pad), - Target => Source, - Drop => Error, - Justify => Justify, - Pad => Pad); - end Tail; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Source'Length); - - begin - for J in Source'Range loop - Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - is - begin - for J in Source'Range loop - Source (J) := Value (Mapping, Source (J)); - end loop; - end Translate; - - function Translate - (Source : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Wide_Wide_String - is - Result : Wide_Wide_String (1 .. Source'Length); - - begin - for J in Source'Range loop - Result (J - (Source'First - 1)) := Mapping (Source (J)); - end loop; - - return Result; - end Translate; - - procedure Translate - (Source : in out Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - is - begin - for J in Source'Range loop - Source (J) := Mapping (Source (J)); - end loop; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Wide_Wide_String; - Side : Trim_End) return Wide_Wide_String - is - Low : Natural := Source'First; - High : Natural := Source'Last; - - begin - if Side = Left or else Side = Both then - while Low <= High and then Source (Low) = Wide_Wide_Space loop - Low := Low + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while High >= Low and then Source (High) = Wide_Wide_Space loop - High := High - 1; - end loop; - end if; - - -- All blanks case - - if Low > High then - return ""; - - -- At least one non-blank - - else - declare - Result : constant Wide_Wide_String (1 .. High - Low + 1) := - Source (Low .. High); - - begin - return Result; - end; - end if; - end Trim; - - procedure Trim - (Source : in out Wide_Wide_String; - Side : Trim_End; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - begin - Move (Source => Trim (Source, Side), - Target => Source, - Justify => Justify, - Pad => Pad); - end Trim; - - function Trim - (Source : Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String - is - Low : Natural := Source'First; - High : Natural := Source'Last; - - begin - while Low <= High and then Is_In (Source (Low), Left) loop - Low := Low + 1; - end loop; - - while High >= Low and then Is_In (Source (High), Right) loop - High := High - 1; - end loop; - - -- Case where source comprises only characters in the sets - - if Low > High then - return ""; - else - declare - subtype WS is Wide_Wide_String (1 .. High - Low + 1); - - begin - return WS (Source (Low .. High)); - end; - end if; - end Trim; - - procedure Trim - (Source : in out Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set; - Justify : Alignment := Strings.Left; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - begin - Move (Source => Trim (Source, Left, Right), - Target => Source, - Justify => Justify, - Pad => Pad); - end Trim; - -end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/a-stzfix.ads b/gcc/ada/a-stzfix.ads deleted file mode 100644 index bee7658..0000000 --- a/gcc/ada/a-stzfix.ads +++ /dev/null @@ -1,264 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Maps; - -package Ada.Strings.Wide_Wide_Fixed is - pragma Preelaborate; - - ------------------------------------------------------------------------ - -- Copy Procedure for Wide_Wide_Strings of Possibly Different Lengths -- - ------------------------------------------------------------------------ - - procedure Move - (Source : Wide_Wide_String; - Target : out Wide_Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Wide_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Count - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ---------------------------------------------- - -- Wide_Wide_String Translation Subprograms -- - ---------------------------------------------- - - function Translate - (Source : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Wide_Wide_String; - - procedure Translate - (Source : in out Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); - - function Translate - (Source : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Wide_Wide_String; - - procedure Translate - (Source : in out Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); - - ------------------------------------------------- - -- Wide_Wide_String Transformation Subprograms -- - ------------------------------------------------- - - function Replace_Slice - (Source : Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Wide_Wide_String; - - procedure Replace_Slice - (Source : in out Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); - - function Insert - (Source : Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Wide_Wide_String; - - procedure Insert - (Source : in out Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error); - - function Overwrite - (Source : Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Wide_Wide_String; - - procedure Overwrite - (Source : in out Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Right); - - function Delete - (Source : Wide_Wide_String; - From : Positive; - Through : Natural) return Wide_Wide_String; - - procedure Delete - (Source : in out Wide_Wide_String; - From : Positive; - Through : Natural; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); - - ------------------------------------------- - -- Wide_Wide_String Selector Subprograms -- - ------------------------------------------- - - function Trim - (Source : Wide_Wide_String; - Side : Trim_End) return Wide_Wide_String; - - procedure Trim - (Source : in out Wide_Wide_String; - Side : Trim_End; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Wide_Wide_Space); - - function Trim - (Source : Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Wide_Wide_String; - - procedure Trim - (Source : in out Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set; - Justify : Alignment := Ada.Strings.Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); - - function Head - (Source : Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) - return Wide_Wide_String; - - procedure Head - (Source : in out Wide_Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); - - function Tail - (Source : Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) - return Wide_Wide_String; - - procedure Tail - (Source : in out Wide_Wide_String; - Count : Natural; - Justify : Alignment := Left; - Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); - - -------------------------------------------- - -- Wide_Wide_String Constructor Functions -- - -------------------------------------------- - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Wide_Wide_String; - -end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/a-stzhas.adb b/gcc/ada/a-stzhas.adb deleted file mode 100644 index a48fd03..0000000 --- a/gcc/ada/a-stzhas.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is an instantiation. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/a-stzhas.ads b/gcc/ada/a-stzhas.ads deleted file mode 100644 index 0c87672..0000000 --- a/gcc/ada/a-stzhas.ads +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Is this really an RM unit? Doc needed??? - -with Ada.Containers; -with System.String_Hash; - -function Ada.Strings.Wide_Wide_Hash -is new System.String_Hash.Hash - (Wide_Wide_Character, Wide_Wide_String, Containers.Hash_Type); - -pragma Pure (Ada.Strings.Wide_Wide_Hash); diff --git a/gcc/ada/a-stzmap.adb b/gcc/ada/a-stzmap.adb deleted file mode 100644 index b331a0f..0000000 --- a/gcc/ada/a-stzmap.adb +++ /dev/null @@ -1,747 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ M A P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Wide_Maps is - - --------- - -- "-" -- - --------- - - function "-" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set - is - LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; - RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); - -- Each range on the right can generate at least one more range in - -- the result, by splitting one of the left operand ranges. - - N : Natural := 0; - R : Natural := 1; - L : Natural := 1; - - Left_Low : Wide_Wide_Character; - -- Left_Low is lowest character of the L'th range not yet dealt with - - begin - if LS'Last = 0 or else RS'Last = 0 then - return Left; - end if; - - Left_Low := LS (L).Low; - while R <= RS'Last loop - - -- If next right range is below current left range, skip it - - if RS (R).High < Left_Low then - R := R + 1; - - -- If next right range above current left range, copy remainder of - -- the left range to the result - - elsif RS (R).Low > LS (L).High then - N := N + 1; - Result (N).Low := Left_Low; - Result (N).High := LS (L).High; - L := L + 1; - exit when L > LS'Last; - Left_Low := LS (L).Low; - - else - -- Next right range overlaps bottom of left range - - if RS (R).Low <= Left_Low then - - -- Case of right range complete overlaps left range - - if RS (R).High >= LS (L).High then - L := L + 1; - exit when L > LS'Last; - Left_Low := LS (L).Low; - - -- Case of right range eats lower part of left range - - else - Left_Low := Wide_Wide_Character'Succ (RS (R).High); - R := R + 1; - end if; - - -- Next right range overlaps some of left range, but not bottom - - else - N := N + 1; - Result (N).Low := Left_Low; - Result (N).High := Wide_Wide_Character'Pred (RS (R).Low); - - -- Case of right range splits left range - - if RS (R).High < LS (L).High then - Left_Low := Wide_Wide_Character'Succ (RS (R).High); - R := R + 1; - - -- Case of right range overlaps top of left range - - else - L := L + 1; - exit when L > LS'Last; - Left_Low := LS (L).Low; - end if; - end if; - end if; - end loop; - - -- Copy remainder of left ranges to result - - if L <= LS'Last then - N := N + 1; - Result (N).Low := Left_Low; - Result (N).High := LS (L).High; - - loop - L := L + 1; - exit when L > LS'Last; - N := N + 1; - Result (N) := LS (L); - end loop; - end if; - - return (AF.Controlled with - Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); - end "-"; - - --------- - -- "=" -- - --------- - - -- The sorted, discontiguous form is canonical, so equality can be used - - function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean is - begin - return Left.Set.all = Right.Set.all; - end "="; - - ----------- - -- "and" -- - ----------- - - function "and" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set - is - LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; - RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); - N : Natural := 0; - L, R : Natural := 1; - - begin - -- Loop to search for overlapping character ranges - - while L <= LS'Last and then R <= RS'Last loop - - if LS (L).High < RS (R).Low then - L := L + 1; - - elsif RS (R).High < LS (L).Low then - R := R + 1; - - -- Here we have LS (L).High >= RS (R).Low - -- and RS (R).High >= LS (L).Low - -- so we have an overlapping range - - else - N := N + 1; - Result (N).Low := - Wide_Wide_Character'Max (LS (L).Low, RS (R).Low); - Result (N).High := - Wide_Wide_Character'Min (LS (L).High, RS (R).High); - - if RS (R).High = LS (L).High then - L := L + 1; - R := R + 1; - elsif RS (R).High < LS (L).High then - R := R + 1; - else - L := L + 1; - end if; - end if; - end loop; - - return (AF.Controlled with - Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); - end "and"; - - ----------- - -- "not" -- - ----------- - - function "not" - (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set - is - RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1); - N : Natural := 0; - - begin - if RS'Last = 0 then - N := 1; - Result (1) := (Low => Wide_Wide_Character'First, - High => Wide_Wide_Character'Last); - - else - if RS (1).Low /= Wide_Wide_Character'First then - N := N + 1; - Result (N).Low := Wide_Wide_Character'First; - Result (N).High := Wide_Wide_Character'Pred (RS (1).Low); - end if; - - for K in 1 .. RS'Last - 1 loop - N := N + 1; - Result (N).Low := Wide_Wide_Character'Succ (RS (K).High); - Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low); - end loop; - - if RS (RS'Last).High /= Wide_Wide_Character'Last then - N := N + 1; - Result (N).Low := Wide_Wide_Character'Succ (RS (RS'Last).High); - Result (N).High := Wide_Wide_Character'Last; - end if; - end if; - - return (AF.Controlled with - Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); - end "not"; - - ---------- - -- "or" -- - ---------- - - function "or" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set - is - LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; - RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; - - Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); - N : Natural; - L, R : Natural; - - begin - N := 0; - L := 1; - R := 1; - - -- Loop through ranges in output file - - loop - -- If no left ranges left, copy next right range - - if L > LS'Last then - exit when R > RS'Last; - N := N + 1; - Result (N) := RS (R); - R := R + 1; - - -- If no right ranges left, copy next left range - - elsif R > RS'Last then - N := N + 1; - Result (N) := LS (L); - L := L + 1; - - else - -- We have two ranges, choose lower one - - N := N + 1; - - if LS (L).Low <= RS (R).Low then - Result (N) := LS (L); - L := L + 1; - else - Result (N) := RS (R); - R := R + 1; - end if; - - -- Loop to collapse ranges into last range - - loop - -- Collapse next length range into current result range - -- if possible. - - if L <= LS'Last - and then LS (L).Low <= - Wide_Wide_Character'Succ (Result (N).High) - then - Result (N).High := - Wide_Wide_Character'Max (Result (N).High, LS (L).High); - L := L + 1; - - -- Collapse next right range into current result range - -- if possible - - elsif R <= RS'Last - and then RS (R).Low <= - Wide_Wide_Character'Succ (Result (N).High) - then - Result (N).High := - Wide_Wide_Character'Max (Result (N).High, RS (R).High); - R := R + 1; - - -- If neither range collapses, then done with this range - - else - exit; - end if; - end loop; - end if; - end loop; - - return (AF.Controlled with - Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); - end "or"; - - ----------- - -- "xor" -- - ----------- - - function "xor" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set - is - begin - return (Left or Right) - (Left and Right); - end "xor"; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is - begin - Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all); - end Adjust; - - procedure Adjust (Object : in out Wide_Wide_Character_Set) is - begin - Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all); - end Adjust; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is - - procedure Free is new Ada.Unchecked_Deallocation - (Wide_Wide_Character_Mapping_Values, - Wide_Wide_Character_Mapping_Values_Access); - - begin - if Object.Map /= Null_Map'Unrestricted_Access then - Free (Object.Map); - end if; - end Finalize; - - procedure Finalize (Object : in out Wide_Wide_Character_Set) is - - procedure Free is new Ada.Unchecked_Deallocation - (Wide_Wide_Character_Ranges, - Wide_Wide_Character_Ranges_Access); - - begin - if Object.Set /= Null_Range'Unrestricted_Access then - Free (Object.Set); - end if; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is - begin - Object := Identity; - end Initialize; - - procedure Initialize (Object : in out Wide_Wide_Character_Set) is - begin - Object := Null_Set; - end Initialize; - - ----------- - -- Is_In -- - ----------- - - function Is_In - (Element : Wide_Wide_Character; - Set : Wide_Wide_Character_Set) return Boolean - is - L, R, M : Natural; - SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; - - begin - L := 1; - R := SS'Last; - - -- Binary search loop. The invariant is that if Element is in any of - -- of the constituent ranges it is in one between Set (L) and Set (R). - - loop - if L > R then - return False; - - else - M := (L + R) / 2; - - if Element > SS (M).High then - L := M + 1; - elsif Element < SS (M).Low then - R := M - 1; - else - return True; - end if; - end if; - end loop; - end Is_In; - - --------------- - -- Is_Subset -- - --------------- - - function Is_Subset - (Elements : Wide_Wide_Character_Set; - Set : Wide_Wide_Character_Set) return Boolean - is - ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set; - SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; - - S : Positive := 1; - E : Positive := 1; - - begin - loop - -- If no more element ranges, done, and result is true - - if E > ES'Last then - return True; - - -- If more element ranges, but no more set ranges, result is false - - elsif S > SS'Last then - return False; - - -- Remove irrelevant set range - - elsif SS (S).High < ES (E).Low then - S := S + 1; - - -- Get rid of element range that is properly covered by set - - elsif SS (S).Low <= ES (E).Low - and then ES (E).High <= SS (S).High - then - E := E + 1; - - -- Otherwise we have a non-covered element range, result is false - - else - return False; - end if; - end loop; - end Is_Subset; - - --------------- - -- To_Domain -- - --------------- - - function To_Domain - (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence - is - begin - return Map.Map.Domain; - end To_Domain; - - ---------------- - -- To_Mapping -- - ---------------- - - function To_Mapping - (From, To : Wide_Wide_Character_Sequence) - return Wide_Wide_Character_Mapping - is - Domain : Wide_Wide_Character_Sequence (1 .. From'Length); - Rangev : Wide_Wide_Character_Sequence (1 .. To'Length); - N : Natural := 0; - - begin - if From'Length /= To'Length then - raise Translation_Error; - - else - pragma Warnings (Off); -- apparent uninit use of Domain - - for J in From'Range loop - for M in 1 .. N loop - if From (J) = Domain (M) then - raise Translation_Error; - elsif From (J) < Domain (M) then - Domain (M + 1 .. N + 1) := Domain (M .. N); - Rangev (M + 1 .. N + 1) := Rangev (M .. N); - Domain (M) := From (J); - Rangev (M) := To (J); - goto Continue; - end if; - end loop; - - Domain (N + 1) := From (J); - Rangev (N + 1) := To (J); - - <> - N := N + 1; - end loop; - - pragma Warnings (On); - - return (AF.Controlled with - Map => new Wide_Wide_Character_Mapping_Values'( - Length => N, - Domain => Domain (1 .. N), - Rangev => Rangev (1 .. N))); - end if; - end To_Mapping; - - -------------- - -- To_Range -- - -------------- - - function To_Range - (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence - is - begin - return Map.Map.Rangev; - end To_Range; - - --------------- - -- To_Ranges -- - --------------- - - function To_Ranges - (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges - is - begin - return Set.Set.all; - end To_Ranges; - - ----------------- - -- To_Sequence -- - ----------------- - - function To_Sequence - (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence - is - SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; - N : Natural := 0; - Count : Natural := 0; - - begin - for J in SS'Range loop - Count := - Count + (Wide_Wide_Character'Pos (SS (J).High) - - Wide_Wide_Character'Pos (SS (J).Low) + 1); - end loop; - - return Result : Wide_Wide_String (1 .. Count) do - for J in SS'Range loop - for K in SS (J).Low .. SS (J).High loop - N := N + 1; - Result (N) := K; - end loop; - end loop; - end return; - end To_Sequence; - - ------------ - -- To_Set -- - ------------ - - -- Case of multiple range input - - function To_Set - (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set - is - Result : Wide_Wide_Character_Ranges (Ranges'Range); - N : Natural := 0; - J : Natural; - - begin - -- The output of To_Set is required to be sorted by increasing Low - -- values, and discontiguous, so first we sort them as we enter them, - -- using a simple insertion sort. - - pragma Warnings (Off); - -- Kill bogus warning on Result being uninitialized - - for J in Ranges'Range loop - for K in 1 .. N loop - if Ranges (J).Low < Result (K).Low then - Result (K + 1 .. N + 1) := Result (K .. N); - Result (K) := Ranges (J); - goto Continue; - end if; - end loop; - - Result (N + 1) := Ranges (J); - - <> - N := N + 1; - end loop; - - pragma Warnings (On); - - -- Now collapse any contiguous or overlapping ranges - - J := 1; - while J < N loop - if Result (J).High < Result (J).Low then - N := N - 1; - Result (J .. N) := Result (J + 1 .. N + 1); - - elsif Wide_Wide_Character'Succ (Result (J).High) >= - Result (J + 1).Low - then - Result (J).High := - Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High); - - N := N - 1; - Result (J + 1 .. N) := Result (J + 2 .. N + 1); - - else - J := J + 1; - end if; - end loop; - - if Result (N).High < Result (N).Low then - N := N - 1; - end if; - - return (AF.Controlled with - Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); - end To_Set; - - -- Case of single range input - - function To_Set - (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set - is - begin - if Span.Low > Span.High then - return Null_Set; - -- This is safe, because there is no procedure with parameter - -- Wide_Wide_Character_Set of mode "out" or "in out". - - else - return (AF.Controlled with - Set => new Wide_Wide_Character_Ranges'(1 => Span)); - end if; - end To_Set; - - -- Case of wide string input - - function To_Set - (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set - is - R : Wide_Wide_Character_Ranges (1 .. Sequence'Length); - - begin - for J in R'Range loop - R (J) := (Sequence (J), Sequence (J)); - end loop; - - return To_Set (R); - end To_Set; - - -- Case of single wide character input - - function To_Set - (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set - is - begin - return - (AF.Controlled with - Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton))); - end To_Set; - - ----------- - -- Value -- - ----------- - - function Value - (Map : Wide_Wide_Character_Mapping; - Element : Wide_Wide_Character) return Wide_Wide_Character - is - L, R, M : Natural; - - MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map; - - begin - L := 1; - R := MV.Domain'Last; - - -- Binary search loop - - loop - -- If not found, identity - - if L > R then - return Element; - - -- Otherwise do binary divide - - else - M := (L + R) / 2; - - if Element < MV.Domain (M) then - R := M - 1; - - elsif Element > MV.Domain (M) then - L := M + 1; - - else -- Element = MV.Domain (M) then - return MV.Rangev (M); - end if; - end if; - end loop; - end Value; - -end Ada.Strings.Wide_Wide_Maps; diff --git a/gcc/ada/a-stzmap.ads b/gcc/ada/a-stzmap.ads deleted file mode 100644 index bd63fdd..0000000 --- a/gcc/ada/a-stzmap.ads +++ /dev/null @@ -1,242 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ M A P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Finalization; - -package Ada.Strings.Wide_Wide_Maps is - pragma Preelaborate; - - ------------------------------------------ - -- Wide_Wide_Character Set Declarations -- - ------------------------------------------ - - type Wide_Wide_Character_Set is private; - pragma Preelaborable_Initialization (Wide_Wide_Character_Set); - -- Representation for a set of Wide_Wide_Character values: - - Null_Set : constant Wide_Wide_Character_Set; - - ----------------------------------------------- - -- Constructors for Wide_Wide_Character Sets -- - ----------------------------------------------- - - type Wide_Wide_Character_Range is record - Low : Wide_Wide_Character; - High : Wide_Wide_Character; - end record; - -- Represents Wide_Wide_Character range Low .. High - - type Wide_Wide_Character_Ranges is - array (Positive range <>) of Wide_Wide_Character_Range; - - function To_Set - (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set; - - function To_Set - (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set; - - function To_Ranges - (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges; - - --------------------------------------- - -- Operations on Wide Character Sets -- - --------------------------------------- - - function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean; - - function "not" - (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; - - function "and" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; - - function "or" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; - - function "xor" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; - - function "-" - (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; - - function Is_In - (Element : Wide_Wide_Character; - Set : Wide_Wide_Character_Set) return Boolean; - - function Is_Subset - (Elements : Wide_Wide_Character_Set; - Set : Wide_Wide_Character_Set) return Boolean; - - function "<=" - (Left : Wide_Wide_Character_Set; - Right : Wide_Wide_Character_Set) return Boolean - renames Is_Subset; - - subtype Wide_Wide_Character_Sequence is Wide_Wide_String; - -- Alternative representation for a set of character values - - function To_Set - (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set; - - function To_Set - (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set; - - function To_Sequence - (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence; - - ---------------------------------------------- - -- Wide_Wide_Character Mapping Declarations -- - ---------------------------------------------- - - type Wide_Wide_Character_Mapping is private; - pragma Preelaborable_Initialization (Wide_Wide_Character_Mapping); - -- Representation for a wide character to wide character mapping: - - function Value - (Map : Wide_Wide_Character_Mapping; - Element : Wide_Wide_Character) return Wide_Wide_Character; - - Identity : constant Wide_Wide_Character_Mapping; - - -------------------------------------- - -- Operations on Wide Wide Mappings -- - --------------------------------------- - - function To_Mapping - (From, To : Wide_Wide_Character_Sequence) - return Wide_Wide_Character_Mapping; - - function To_Domain - (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence; - - function To_Range - (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence; - - type Wide_Wide_Character_Mapping_Function is - access function (From : Wide_Wide_Character) return Wide_Wide_Character; - -private - package AF renames Ada.Finalization; - - ----------------------------------------------- - -- Representation of Wide_Wide_Character_Set -- - ----------------------------------------------- - - -- A wide character set is represented as a sequence of wide character - -- ranges (i.e. an object of type Wide_Wide_Character_Ranges) in which the - -- following hold: - - -- The lower bound is 1 - -- The ranges are in order by increasing Low values - -- The ranges are non-overlapping and discontigous - - -- A character value is in the set if it is contained in one of the - -- ranges. The actual Wide_Wide_Character_Set value is a controlled pointer - -- to this Wide_Wide_Character_Ranges value. The use of a controlled type - -- is necessary to prevent storage leaks. - - type Wide_Wide_Character_Ranges_Access is - access all Wide_Wide_Character_Ranges; - - type Wide_Wide_Character_Set is new AF.Controlled with record - Set : Wide_Wide_Character_Ranges_Access; - end record; - - pragma Finalize_Storage_Only (Wide_Wide_Character_Set); - -- This avoids useless finalizations, and, more importantly avoids - -- incorrect attempts to finalize constants that are statically - -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect. - - procedure Initialize (Object : in out Wide_Wide_Character_Set); - procedure Adjust (Object : in out Wide_Wide_Character_Set); - procedure Finalize (Object : in out Wide_Wide_Character_Set); - - Null_Range : aliased constant Wide_Wide_Character_Ranges := - (1 .. 0 => (Low => ' ', High => ' ')); - - Null_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Set => Null_Range'Unrestricted_Access); - - --------------------------------------------------- - -- Representation of Wide_Wide_Character_Mapping -- - --------------------------------------------------- - - -- A wide character mapping is represented as two strings of equal - -- length, where any character appearing in Domain is mapped to the - -- corresponding character in Rangev. A character not appearing in - -- Domain is mapped to itself. The characters in Domain are sorted - -- in ascending order. - - -- The actual Wide_Wide_Character_Mapping value is a controlled record - -- that contains a pointer to a discriminated record containing the - -- range and domain values. - - -- Note: this representation is canonical, and the values stored in - -- Domain and Rangev are exactly the values that are returned by the - -- functions To_Domain and To_Range. The use of a controlled type is - -- necessary to prevent storage leaks. - - type Wide_Wide_Character_Mapping_Values (Length : Natural) is record - Domain : Wide_Wide_Character_Sequence (1 .. Length); - Rangev : Wide_Wide_Character_Sequence (1 .. Length); - end record; - - type Wide_Wide_Character_Mapping_Values_Access is - access all Wide_Wide_Character_Mapping_Values; - - type Wide_Wide_Character_Mapping is new AF.Controlled with record - Map : Wide_Wide_Character_Mapping_Values_Access; - end record; - - pragma Finalize_Storage_Only (Wide_Wide_Character_Mapping); - -- This avoids useless finalizations, and, more importantly avoids - -- incorrect attempts to finalize constants that are statically - -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect. - - procedure Initialize (Object : in out Wide_Wide_Character_Mapping); - procedure Adjust (Object : in out Wide_Wide_Character_Mapping); - procedure Finalize (Object : in out Wide_Wide_Character_Mapping); - - Null_Map : aliased constant Wide_Wide_Character_Mapping_Values := - (Length => 0, - Domain => "", - Rangev => ""); - - Identity : constant Wide_Wide_Character_Mapping := - (AF.Controlled with - Map => Null_Map'Unrestricted_Access); - -end Ada.Strings.Wide_Wide_Maps; diff --git a/gcc/ada/a-stzsea.adb b/gcc/ada/a-stzsea.adb deleted file mode 100644 index 7b4f635..0000000 --- a/gcc/ada/a-stzsea.adb +++ /dev/null @@ -1,617 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps; -with System; use System; - -package body Ada.Strings.Wide_Wide_Search is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Belongs - (Element : Wide_Wide_Character; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership) return Boolean; - pragma Inline (Belongs); - -- Determines if the given element is in (Test = Inside) or not in - -- (Test = Outside) the given character set. - - ------------- - -- Belongs -- - ------------- - - function Belongs - (Element : Wide_Wide_Character; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership) return Boolean - is - begin - if Test = Inside then - return Is_In (Element, Set); - else - return not Is_In (Element, Set); - end if; - end Belongs; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Num : Natural; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - Num := 0; - Ind := Source'First; - - -- Unmapped case - - if Mapping'Address = Wide_Wide_Maps.Identity'Address then - while Ind <= Source'Last - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - Num := Num + 1; - Ind := Ind + Pattern'Length; - else - Ind := Ind + 1; - end if; - end loop; - - -- Mapped case - - else - while Ind <= Source'Last - PL1 loop - Cur := Ind; - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - Ind := Ind + 1; - goto Cont; - else - Cur := Cur + 1; - end if; - end loop; - - Num := Num + 1; - Ind := Ind + Pattern'Length; - - <> - null; - end loop; - end if; - - -- Return result - - return Num; - end Count; - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Num : Natural; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Check for null pointer in case checks are off - - if Mapping = null then - raise Constraint_Error; - end if; - - Num := 0; - Ind := Source'First; - while Ind <= Source'Last - PL1 loop - Cur := Ind; - for K in Pattern'Range loop - if Pattern (K) /= Mapping (Source (Cur)) then - Ind := Ind + 1; - goto Cont; - else - Cur := Cur + 1; - end if; - end loop; - - Num := Num + 1; - Ind := Ind + Pattern'Length; - - <> - null; - end loop; - - return Num; - end Count; - - function Count - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural - is - N : Natural := 0; - - begin - for J in Source'Range loop - if Is_In (Source (J), Set) then - N := N + 1; - end if; - end loop; - - return N; - end Count; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural) - is - begin - for J in From .. Source'Last loop - if Belongs (Source (J), Set, Test) then - First := J; - - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; - - -- Here if J indexes first char of token, and all chars after J - -- are in the token. - - Last := Source'Last; - return; - end if; - end loop; - - -- Here if no token found - - First := From; - Last := 0; - end Find_Token; - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural) - is - begin - for J in Source'Range loop - if Belongs (Source (J), Set, Test) then - First := J; - - for K in J + 1 .. Source'Last loop - if not Belongs (Source (K), Set, Test) then - Last := K - 1; - return; - end if; - end loop; - - -- Here if J indexes first char of token, and all chars after J - -- are in the token. - - Last := Source'Last; - return; - end if; - end loop; - - -- Here if no token found - - -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if - -- Source'First is not positive and is assigned to First. Formulation - -- is slightly different in RM 2012, but the intent seems similar, so - -- we check explicitly for that condition. - - if Source'First not in Positive then - raise Constraint_Error; - - else - First := Source'First; - Last := 0; - end if; - end Find_Token; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Cur : Natural; - - Ind : Integer; - -- Index for start of match check. This can be negative if the pattern - -- length is greater than the string length, which is why this variable - -- is Integer instead of Natural. In this case, the search loops do not - -- execute at all, so this Ind value is never used. - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Forwards case - - if Going = Forward then - Ind := Source'First; - - -- Unmapped forward case - - if Mapping'Address = Wide_Wide_Maps.Identity'Address then - for J in 1 .. Source'Length - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - return Ind; - else - Ind := Ind + 1; - end if; - end loop; - - -- Mapped forward case - - else - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - goto Cont1; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind + 1; - end loop; - end if; - - -- Backwards case - - else - -- Unmapped backward case - - Ind := Source'Last - PL1; - - if Mapping'Address = Wide_Wide_Maps.Identity'Address then - for J in reverse 1 .. Source'Length - PL1 loop - if Pattern = Source (Ind .. Ind + PL1) then - return Ind; - else - Ind := Ind - 1; - end if; - end loop; - - -- Mapped backward case - - else - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Value (Mapping, Source (Cur)) then - goto Cont2; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind - 1; - end loop; - end if; - end if; - - -- Fall through if no match found. Note that the loops are skipped - -- completely in the case of the pattern being longer than the source. - - return 0; - end Index; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - PL1 : constant Integer := Pattern'Length - 1; - Ind : Natural; - Cur : Natural; - - begin - if Pattern = "" then - raise Pattern_Error; - end if; - - -- Check for null pointer in case checks are off - - if Mapping = null then - raise Constraint_Error; - end if; - - -- If Pattern longer than Source it can't be found - - if Pattern'Length > Source'Length then - return 0; - end if; - - -- Forwards case - - if Going = Forward then - Ind := Source'First; - for J in 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then - goto Cont1; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind + 1; - end loop; - - -- Backwards case - - else - Ind := Source'Last - PL1; - for J in reverse 1 .. Source'Length - PL1 loop - Cur := Ind; - - for K in Pattern'Range loop - if Pattern (K) /= Mapping.all (Source (Cur)) then - goto Cont2; - else - Cur := Cur + 1; - end if; - end loop; - - return Ind; - - <> - Ind := Ind - 1; - end loop; - end if; - - -- Fall through if no match found. Note that the loops are skipped - -- completely in the case of the pattern being longer than the source. - - return 0; - end Index; - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - -- Forwards case - - if Going = Forward then - for J in Source'Range loop - if Belongs (Source (J), Set, Test) then - return J; - end if; - end loop; - - -- Backwards case - - else - for J in reverse Source'Range loop - if Belongs (Source (J), Set, Test) then - return J; - end if; - end loop; - end if; - - -- Fall through if no match - - return 0; - end Index; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index (Source (From .. Source'Last), Pattern, Forward, Mapping); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index (Source (Source'First .. From), Pattern, Backward, Mapping); - end if; - end Index; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return Index - (Source (From .. Source'Last), Pattern, Forward, Mapping); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return Index - (Source (Source'First .. From), Pattern, Backward, Mapping); - end if; - end Index; - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index (Source (From .. Source'Last), Set, Test, Forward); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index (Source (Source'First .. From), Set, Test, Backward); - end if; - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Wide_Wide_String; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - for J in Source'Range loop - if Source (J) /= Wide_Wide_Space then - return J; - end if; - end loop; - - else -- Going = Backward - for J in reverse Source'Range loop - if Source (J) /= Wide_Wide_Space then - return J; - end if; - end loop; - end if; - - -- Fall through if no match - - return 0; - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - if Going = Forward then - if From < Source'First then - raise Index_Error; - end if; - - return - Index_Non_Blank (Source (From .. Source'Last), Forward); - - else - if From > Source'Last then - raise Index_Error; - end if; - - return - Index_Non_Blank (Source (Source'First .. From), Backward); - end if; - end Index_Non_Blank; - -end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/a-stzsea.ads b/gcc/ada/a-stzsea.ads deleted file mode 100644 index 1875af7..0000000 --- a/gcc/ada/a-stzsea.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains search functions from Ada.Strings.Wide_Wide_Fixed. --- They are separated because Ada.Strings.Wide_Wide_Bounded shares these --- search functions with Ada.Strings.Wide_Wide_Unbounded, and we don't want to --- drag in other irrelevant stuff from Ada.Strings.Wide_Wide_Fixed when using --- the other two packages. We make this a private package, since user programs --- should access these subprograms via one of the standard string packages. - -with Ada.Strings.Wide_Wide_Maps; - -private package Ada.Strings.Wide_Wide_Search is - pragma Preelaborate; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Index - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Index - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Wide_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Count - (Source : Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Count - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - - procedure Find_Token - (Source : Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - -end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/a-stzsup.adb b/gcc/ada/a-stzsup.adb deleted file mode 100644 index acd0035..0000000 --- a/gcc/ada/a-stzsup.adb +++ /dev/null @@ -1,1941 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps; -with Ada.Strings.Wide_Wide_Search; - -package body Ada.Strings.Wide_Wide_Superbounded is - - ------------ - -- Concat -- - ------------ - - function Concat - (Left : Super_String; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - end; - end return; - end Concat; - - function Concat - (Left : Super_String; - Right : Wide_Wide_String) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - Nlen : constant Natural := Llen + Right'Length; - - begin - if Nlen > Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - end if; - end; - end return; - end Concat; - - function Concat - (Left : Wide_Wide_String; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Right.Max_Length) do - declare - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - end if; - end; - end return; - end Concat; - - function Concat - (Left : Super_String; - Right : Wide_Wide_Character) return Super_String - is - begin - return Result : Super_String (Left.Max_Length) do - declare - Llen : constant Natural := Left.Current_Length; - - begin - if Llen = Left.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Result.Current_Length) := Right; - end if; - end; - end return; - end Concat; - - function Concat - (Left : Wide_Wide_Character; - Right : Super_String) return Super_String - is - begin - return Result : Super_String (Right.Max_Length) do - declare - Rlen : constant Natural := Right.Current_Length; - - begin - if Rlen = Right.Max_Length then - raise Ada.Strings.Length_Error; - else - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Result.Current_Length) := - Right.Data (1 .. Rlen); - end if; - end; - end return; - end Concat; - - ----------- - -- Equal -- - ----------- - - function "=" - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Current_Length = Right.Current_Length - and then Left.Data (1 .. Left.Current_Length) = - Right.Data (1 .. Right.Current_Length); - end "="; - - function Equal - (Left : Super_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Current_Length = Right'Length - and then Left.Data (1 .. Left.Current_Length) = Right; - end Equal; - - function Equal - (Left : Wide_Wide_String; - Right : Super_String) return Boolean - is - begin - return Left'Length = Right.Current_Length - and then Left = Right.Data (1 .. Right.Current_Length); - end Equal; - - ------------- - -- Greater -- - ------------- - - function Greater - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) > - Right.Data (1 .. Right.Current_Length); - end Greater; - - function Greater - (Left : Super_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) > Right; - end Greater; - - function Greater - (Left : Wide_Wide_String; - Right : Super_String) return Boolean - is - begin - return Left > Right.Data (1 .. Right.Current_Length); - end Greater; - - ---------------------- - -- Greater_Or_Equal -- - ---------------------- - - function Greater_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) >= - Right.Data (1 .. Right.Current_Length); - end Greater_Or_Equal; - - function Greater_Or_Equal - (Left : Super_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) >= Right; - end Greater_Or_Equal; - - function Greater_Or_Equal - (Left : Wide_Wide_String; - Right : Super_String) return Boolean - is - begin - return Left >= Right.Data (1 .. Right.Current_Length); - end Greater_Or_Equal; - - ---------- - -- Less -- - ---------- - - function Less - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) < - Right.Data (1 .. Right.Current_Length); - end Less; - - function Less - (Left : Super_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) < Right; - end Less; - - function Less - (Left : Wide_Wide_String; - Right : Super_String) return Boolean - is - begin - return Left < Right.Data (1 .. Right.Current_Length); - end Less; - - ------------------- - -- Less_Or_Equal -- - ------------------- - - function Less_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) <= - Right.Data (1 .. Right.Current_Length); - end Less_Or_Equal; - - function Less_Or_Equal - (Left : Super_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Data (1 .. Left.Current_Length) <= Right; - end Less_Or_Equal; - - function Less_Or_Equal - (Left : Wide_Wide_String; - Right : Super_String) return Boolean - is - begin - return Left <= Right.Data (1 .. Right.Current_Length); - end Less_Or_Equal; - - ---------------------- - -- Set_Super_String -- - ---------------------- - - procedure Set_Super_String - (Target : out Super_String; - Source : Wide_Wide_String; - Drop : Truncation := Error) - is - Slen : constant Natural := Source'Length; - Max_Length : constant Positive := Target.Max_Length; - - begin - if Slen <= Max_Length then - Target.Current_Length := Slen; - Target.Data (1 .. Slen) := Source; - - else - case Drop is - when Strings.Right => - Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); - - when Strings.Left => - Target.Current_Length := Max_Length; - Target.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Set_Super_String; - - ------------------ - -- Super_Append -- - ------------------ - - -- Case of Super_String and Super_String - - function Super_Append - (Left : Super_String; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Result.Data := Right.Data; - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Super_String; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - Rlen : constant Natural := New_Item.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then -- only case is Rlen = Max_Length - Source.Data := New_Item.Data; - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of Super_String and Wide_Wide_String - - function Super_Append - (Left : Super_String; - Right : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Nlen) := Right; - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then -- only case is Llen = Max_Length - Result.Data := Left.Data; - - else - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1 .. Max_Length) := - Right (Right'First .. Right'First - 1 + - Max_Length - Llen); - - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right (Right'Last - (Max_Length - 1) .. Right'Last); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - Rlen : constant Natural := New_Item'Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Source.Current_Length := Nlen; - Source.Data (Llen + 1 .. Nlen) := New_Item; - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen < Max_Length then - Source.Data (Llen + 1 .. Max_Length) := - New_Item (New_Item'First .. - New_Item'First - 1 + Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - (Max_Length - 1) .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - Rlen) := - Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); - Source.Data (Max_Length - Rlen + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Append; - - -- Case of Wide_Wide_String and Super_String - - function Super_Append - (Left : Wide_Wide_String; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Right.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left'Length; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Llen + Rlen; - - begin - if Nlen <= Max_Length then - Result.Current_Length := Nlen; - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Llen >= Max_Length then - Result.Data (1 .. Max_Length) := - Left (Left'First .. Left'First + (Max_Length - 1)); - - else - Result.Data (1 .. Llen) := Left; - Result.Data (Llen + 1 .. Max_Length) := - Right.Data (1 .. Max_Length - Llen); - end if; - - when Strings.Left => - if Rlen >= Max_Length then - Result.Data (1 .. Max_Length) := - Right.Data (Rlen - (Max_Length - 1) .. Rlen); - - else - Result.Data (1 .. Max_Length - Rlen) := - Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); - Result.Data (Max_Length - Rlen + 1 .. Max_Length) := - Right.Data (1 .. Rlen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Append; - - -- Case of Super_String and Wide_Wide_Character - - function Super_Append - (Left : Super_String; - Right : Wide_Wide_Character; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Left.Max_Length; - Result : Super_String (Max_Length); - Llen : constant Natural := Left.Current_Length; - - begin - if Llen < Max_Length then - Result.Current_Length := Llen + 1; - Result.Data (1 .. Llen) := Left.Data (1 .. Llen); - Result.Data (Llen + 1) := Right; - return Result; - - else - case Drop is - when Strings.Right => - return Left; - - when Strings.Left => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length - 1) := - Left.Data (2 .. Max_Length); - Result.Data (Max_Length) := Right; - return Result; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Append; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_Wide_Character; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Llen : constant Natural := Source.Current_Length; - - begin - if Llen < Max_Length then - Source.Current_Length := Llen + 1; - Source.Data (Llen + 1) := New_Item; - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - null; - - when Strings.Left => - Source.Data (1 .. Max_Length - 1) := - Source.Data (2 .. Max_Length); - Source.Data (Max_Length) := New_Item; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - end Super_Append; - - -- Case of Wide_Wide_Character and Super_String - - function Super_Append - (Left : Wide_Wide_Character; - Right : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Right.Max_Length; - Result : Super_String (Max_Length); - Rlen : constant Natural := Right.Current_Length; - - begin - if Rlen < Max_Length then - Result.Current_Length := Rlen + 1; - Result.Data (1) := Left; - Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); - return Result; - - else - case Drop is - when Strings.Right => - Result.Current_Length := Max_Length; - Result.Data (1) := Left; - Result.Data (2 .. Max_Length) := - Right.Data (1 .. Max_Length - 1); - return Result; - - when Strings.Left => - return Right; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Append; - - ----------------- - -- Super_Count -- - ----------------- - - function Super_Count - (Source : Super_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - begin - return - Wide_Wide_Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); - end Super_Count; - - function Super_Count - (Source : Super_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - begin - return - Wide_Wide_Search.Count - (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); - end Super_Count; - - function Super_Count - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural - is - begin - return Wide_Wide_Search.Count - (Source.Data (1 .. Source.Current_Length), Set); - end Super_Count; - - ------------------ - -- Super_Delete -- - ------------------ - - function Super_Delete - (Source : Super_String; - From : Positive; - Through : Natural) return Super_String - is - Result : Super_String (Source.Max_Length); - Slen : constant Natural := Source.Current_Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return Source; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Result.Current_Length := From - 1; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - return Result; - - else - Result.Current_Length := Slen - Num_Delete; - Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); - Result.Data (From .. Result.Current_Length) := - Source.Data (Through + 1 .. Slen); - return Result; - end if; - end Super_Delete; - - procedure Super_Delete - (Source : in out Super_String; - From : Positive; - Through : Natural) - is - Slen : constant Natural := Source.Current_Length; - Num_Delete : constant Integer := Through - From + 1; - - begin - if Num_Delete <= 0 then - return; - - elsif From > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Through >= Slen then - Source.Current_Length := From - 1; - - else - Source.Current_Length := Slen - Num_Delete; - Source.Data (From .. Source.Current_Length) := - Source.Data (Through + 1 .. Slen); - end if; - end Super_Delete; - - ------------------- - -- Super_Element -- - ------------------- - - function Super_Element - (Source : Super_String; - Index : Positive) return Wide_Wide_Character - is - begin - if Index <= Source.Current_Length then - return Source.Data (Index); - else - raise Strings.Index_Error; - end if; - end Super_Element; - - ---------------------- - -- Super_Find_Token -- - ---------------------- - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Wide_Search.Find_Token - (Source.Data (From .. Source.Current_Length), Set, Test, First, Last); - end Super_Find_Token; - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Wide_Search.Find_Token - (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); - end Super_Find_Token; - - ---------------- - -- Super_Head -- - ---------------- - - function Super_Head - (Source : Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Current_Length := Count; - Result.Data (1 .. Count) := Source.Data (1 .. Count); - - elsif Count <= Max_Length then - Result.Current_Length := Count; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Count) := (others => Pad); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Max_Length - Npad) := - Source.Data (Count - Max_Length + 1 .. Slen); - Result.Data (Max_Length - Npad + 1 .. Max_Length) := - (others => Pad); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Head; - - procedure Super_Head - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - Temp : Wide_Wide_String (1 .. Max_Length); - - begin - if Npad <= 0 then - Source.Current_Length := Count; - - elsif Count <= Max_Length then - Source.Current_Length := Count; - Source.Data (Slen + 1 .. Count) := (others => Pad); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Slen + 1 .. Max_Length) := (others => Pad); - - when Strings.Left => - if Npad > Max_Length then - Source.Data := (others => Pad); - - else - Temp := Source.Data; - Source.Data (1 .. Max_Length - Npad) := - Temp (Count - Max_Length + 1 .. Slen); - - for J in Max_Length - Npad + 1 .. Max_Length loop - Source.Data (J) := Pad; - end loop; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Head; - - ----------------- - -- Super_Index -- - ----------------- - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - begin - return Wide_Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - begin - return Wide_Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return Wide_Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Set, Test, Going); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - begin - return Wide_Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - begin - return Wide_Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), - Pattern, From, Going, Mapping); - end Super_Index; - - function Super_Index - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - return Wide_Wide_Search.Index - (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); - end Super_Index; - - --------------------------- - -- Super_Index_Non_Blank -- - --------------------------- - - function Super_Index_Non_Blank - (Source : Super_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return - Wide_Wide_Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), Going); - end Super_Index_Non_Blank; - - function Super_Index_Non_Blank - (Source : Super_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - return - Wide_Wide_Search.Index_Non_Blank - (Source.Data (1 .. Source.Current_Length), From, Going); - end Super_Index_Non_Blank; - - ------------------ - -- Super_Insert -- - ------------------ - - function Super_Insert - (Source : Super_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Nlen : constant Natural := New_Item'Length; - Tlen : constant Natural := Slen + Nlen; - Blen : constant Natural := Before - 1; - Alen : constant Integer := Slen - Blen; - Droplen : constant Integer := Tlen - Max_Length; - - -- Tlen is the length of the total string before possible truncation. - -- Blen, Alen are the lengths of the before and after pieces of the - -- source string. - - begin - if Alen < 0 then - raise Ada.Strings.Index_Error; - - elsif Droplen <= 0 then - Result.Current_Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Tlen) := - Source.Data (Before .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Before .. Max_Length) := - New_Item (New_Item'First - .. New_Item'First + Max_Length - Before); - else - Result.Data (Before .. Before + Nlen - 1) := New_Item; - Result.Data (Before + Nlen .. Max_Length) := - Source.Data (Before .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (Before .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - New_Item (New_Item'Last - (Max_Length - Alen) + 1 - .. New_Item'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := - New_Item; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Insert; - - procedure Super_Insert - (Source : in out Super_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Super_Insert (Source, Before, New_Item, Drop); - end Super_Insert; - - ------------------ - -- Super_Length -- - ------------------ - - function Super_Length (Source : Super_String) return Natural is - begin - return Source.Current_Length; - end Super_Length; - - --------------------- - -- Super_Overwrite -- - --------------------- - - function Super_Overwrite - (Source : Super_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Endpos : constant Natural := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Current_Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif New_Item'Length = 0 then - return Source; - - elsif Endpos <= Slen then - Result.Current_Length := Source.Current_Length; - Result.Data (1 .. Slen) := Source.Data (1 .. Slen); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - elsif Endpos <= Max_Length then - Result.Current_Length := Endpos; - Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); - Result.Data (Position .. Endpos) := New_Item; - return Result; - - else - Result.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Position - 1) := - Source.Data (1 .. Position - 1); - - Result.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - return Result; - - when Strings.Left => - if New_Item'Length >= Max_Length then - Result.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - return Result; - - else - Result.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - Result.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - return Result; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Overwrite; - - procedure Super_Overwrite - (Source : in out Super_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) - is - Max_Length : constant Positive := Source.Max_Length; - Endpos : constant Positive := Position + New_Item'Length - 1; - Slen : constant Natural := Source.Current_Length; - Droplen : Natural; - - begin - if Position > Slen + 1 then - raise Ada.Strings.Index_Error; - - elsif Endpos <= Slen then - Source.Data (Position .. Endpos) := New_Item; - - elsif Endpos <= Max_Length then - Source.Data (Position .. Endpos) := New_Item; - Source.Current_Length := Endpos; - - else - Source.Current_Length := Max_Length; - Droplen := Endpos - Max_Length; - - case Drop is - when Strings.Right => - Source.Data (Position .. Max_Length) := - New_Item (New_Item'First .. New_Item'Last - Droplen); - - when Strings.Left => - if New_Item'Length > Max_Length then - Source.Data (1 .. Max_Length) := - New_Item (New_Item'Last - Max_Length + 1 .. - New_Item'Last); - - else - Source.Data (1 .. Max_Length - New_Item'Length) := - Source.Data (Droplen + 1 .. Position - 1); - - Source.Data - (Max_Length - New_Item'Length + 1 .. Max_Length) := - New_Item; - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Overwrite; - - --------------------------- - -- Super_Replace_Element -- - --------------------------- - - procedure Super_Replace_Element - (Source : in out Super_String; - Index : Positive; - By : Wide_Wide_Character) - is - begin - if Index <= Source.Current_Length then - Source.Data (Index) := By; - else - raise Ada.Strings.Index_Error; - end if; - end Super_Replace_Element; - - ------------------------- - -- Super_Replace_Slice -- - ------------------------- - - function Super_Replace_Slice - (Source : Super_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - - begin - if Low > Slen + 1 then - raise Strings.Index_Error; - - elsif High < Low then - return Super_Insert (Source, Low, By, Drop); - - else - declare - Blen : constant Natural := Natural'Max (0, Low - 1); - Alen : constant Natural := Natural'Max (0, Slen - High); - Tlen : constant Natural := Blen + By'Length + Alen; - Droplen : constant Integer := Tlen - Max_Length; - Result : Super_String (Max_Length); - - -- Tlen is the total length of the result string before any - -- truncation. Blen and Alen are the lengths of the pieces - -- of the original string that end up in the result string - -- before and after the replaced slice. - - begin - if Droplen <= 0 then - Result.Current_Length := Tlen; - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Tlen) := - Source.Data (High + 1 .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Result.Data (1 .. Blen) := Source.Data (1 .. Blen); - - if Droplen > Alen then - Result.Data (Low .. Max_Length) := - By (By'First .. By'First + Max_Length - Low); - else - Result.Data (Low .. Low + By'Length - 1) := By; - Result.Data (Low + By'Length .. Max_Length) := - Source.Data (High + 1 .. Slen - Droplen); - end if; - - when Strings.Left => - Result.Data (Max_Length - (Alen - 1) .. Max_Length) := - Source.Data (High + 1 .. Slen); - - if Droplen >= Blen then - Result.Data (1 .. Max_Length - Alen) := - By (By'Last - (Max_Length - Alen) + 1 .. By'Last); - else - Result.Data - (Blen - Droplen + 1 .. Max_Length - Alen) := By; - Result.Data (1 .. Blen - Droplen) := - Source.Data (Droplen + 1 .. Blen); - end if; - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end; - end if; - end Super_Replace_Slice; - - procedure Super_Replace_Slice - (Source : in out Super_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Strings.Truncation := Strings.Error) - is - begin - -- We do a double copy here because this is one of the situations - -- in which we move data to the right, and at least at the moment, - -- GNAT is not handling such cases correctly ??? - - Source := Super_Replace_Slice (Source, Low, High, By, Drop); - end Super_Replace_Slice; - - --------------------- - -- Super_Replicate -- - --------------------- - - function Super_Replicate - (Count : Natural; - Item : Wide_Wide_Character; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - - begin - if Count <= Max_Length then - Result.Current_Length := Count; - - elsif Drop = Strings.Error then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Max_Length; - end if; - - Result.Data (1 .. Result.Current_Length) := (others => Item); - return Result; - end Super_Replicate; - - function Super_Replicate - (Count : Natural; - Item : Wide_Wide_String; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String - is - Length : constant Integer := Count * Item'Length; - Result : Super_String (Max_Length); - Indx : Positive; - - begin - if Length <= Max_Length then - Result.Current_Length := Length; - - if Length > 0 then - Indx := 1; - - for J in 1 .. Count loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - end if; - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - Indx := 1; - - while Indx + Item'Length <= Max_Length + 1 loop - Result.Data (Indx .. Indx + Item'Length - 1) := Item; - Indx := Indx + Item'Length; - end loop; - - Result.Data (Indx .. Max_Length) := - Item (Item'First .. Item'First + Max_Length - Indx); - - when Strings.Left => - Indx := Max_Length; - - while Indx - Item'Length >= 1 loop - Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; - Indx := Indx - Item'Length; - end loop; - - Result.Data (1 .. Indx) := - Item (Item'Last - Indx + 1 .. Item'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Replicate; - - function Super_Replicate - (Count : Natural; - Item : Super_String; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - begin - return - Super_Replicate - (Count, - Item.Data (1 .. Item.Current_Length), - Drop, - Item.Max_Length); - end Super_Replicate; - - ----------------- - -- Super_Slice -- - ----------------- - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Wide_Wide_String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - return R : Wide_Wide_String (Low .. High) do - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - end if; - - R := Source.Data (Low .. High); - end return; - end Super_Slice; - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Super_String - is - begin - return Result : Super_String (Source.Max_Length) do - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else - Result.Current_Length := High - Low + 1; - Result.Data (1 .. Result.Current_Length) := - Source.Data (Low .. High); - end if; - end return; - end Super_Slice; - - procedure Super_Slice - (Source : Super_String; - Target : out Super_String; - Low : Positive; - High : Natural) - is - begin - if Low > Source.Current_Length + 1 - or else High > Source.Current_Length - then - raise Index_Error; - else - Target.Current_Length := High - Low + 1; - Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); - end if; - end Super_Slice; - - ---------------- - -- Super_Tail -- - ---------------- - - function Super_Tail - (Source : Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Strings.Truncation := Strings.Error) return Super_String - is - Max_Length : constant Positive := Source.Max_Length; - Result : Super_String (Max_Length); - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - begin - if Npad <= 0 then - Result.Current_Length := Count; - Result.Data (1 .. Count) := - Source.Data (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Result.Current_Length := Count; - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); - - else - Result.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Result.Data := (others => Pad); - - else - Result.Data (1 .. Npad) := (others => Pad); - Result.Data (Npad + 1 .. Max_Length) := - Source.Data (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - Result.Data (1 .. Max_Length - Slen) := (others => Pad); - Result.Data (Max_Length - Slen + 1 .. Max_Length) := - Source.Data (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end Super_Tail; - - procedure Super_Tail - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) - is - Max_Length : constant Positive := Source.Max_Length; - Slen : constant Natural := Source.Current_Length; - Npad : constant Integer := Count - Slen; - - Temp : constant Wide_Wide_String (1 .. Max_Length) := Source.Data; - - begin - if Npad <= 0 then - Source.Current_Length := Count; - Source.Data (1 .. Count) := - Temp (Slen - (Count - 1) .. Slen); - - elsif Count <= Max_Length then - Source.Current_Length := Count; - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); - - else - Source.Current_Length := Max_Length; - - case Drop is - when Strings.Right => - if Npad >= Max_Length then - Source.Data := (others => Pad); - - else - Source.Data (1 .. Npad) := (others => Pad); - Source.Data (Npad + 1 .. Max_Length) := - Temp (1 .. Max_Length - Npad); - end if; - - when Strings.Left => - for J in 1 .. Max_Length - Slen loop - Source.Data (J) := Pad; - end loop; - - Source.Data (Max_Length - Slen + 1 .. Max_Length) := - Temp (1 .. Slen); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - end Super_Tail; - - --------------------- - -- Super_To_String -- - --------------------- - - function Super_To_String - (Source : Super_String) return Wide_Wide_String - is - begin - return R : Wide_Wide_String (1 .. Source.Current_Length) do - R := Source.Data (1 .. Source.Current_Length); - end return; - end Super_To_String; - - --------------------- - -- Super_Translate -- - --------------------- - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - Result.Current_Length := Source.Current_Length; - - for J in 1 .. Source.Current_Length loop - Result.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - - return Result; - end Super_Translate; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - is - begin - for J in 1 .. Source.Current_Length loop - Source.Data (J) := Value (Mapping, Source.Data (J)); - end loop; - end Super_Translate; - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - Result.Current_Length := Source.Current_Length; - - for J in 1 .. Source.Current_Length loop - Result.Data (J) := Mapping.all (Source.Data (J)); - end loop; - - return Result; - end Super_Translate; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - is - begin - for J in 1 .. Source.Current_Length loop - Source.Data (J) := Mapping.all (Source.Data (J)); - end loop; - end Super_Translate; - - ---------------- - -- Super_Trim -- - ---------------- - - function Super_Trim - (Source : Super_String; - Side : Trim_End) return Super_String - is - Result : Super_String (Source.Max_Length); - Last : Natural := Source.Current_Length; - First : Positive := 1; - - begin - if Side = Left or else Side = Both then - while First <= Last and then Source.Data (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Source.Data (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); - return Result; - end Super_Trim; - - procedure Super_Trim - (Source : in out Super_String; - Side : Trim_End) - is - Max_Length : constant Positive := Source.Max_Length; - Last : Natural := Source.Current_Length; - First : Positive := 1; - Temp : Wide_Wide_String (1 .. Max_Length); - - begin - Temp (1 .. Last) := Source.Data (1 .. Last); - - if Side = Left or else Side = Both then - while First <= Last and then Temp (First) = ' ' loop - First := First + 1; - end loop; - end if; - - if Side = Right or else Side = Both then - while Last >= First and then Temp (Last) = ' ' loop - Last := Last - 1; - end loop; - end if; - - Source.Data := (others => Wide_Wide_NUL); - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); - end Super_Trim; - - function Super_Trim - (Source : Super_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String - is - Result : Super_String (Source.Max_Length); - - begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - Result.Current_Length := Last - First + 1; - Result.Data (1 .. Result.Current_Length) := - Source.Data (First .. Last); - return Result; - end if; - end loop; - end if; - end loop; - - Result.Current_Length := 0; - return Result; - end Super_Trim; - - procedure Super_Trim - (Source : in out Super_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - is - begin - for First in 1 .. Source.Current_Length loop - if not Is_In (Source.Data (First), Left) then - for Last in reverse First .. Source.Current_Length loop - if not Is_In (Source.Data (Last), Right) then - if First = 1 then - Source.Current_Length := Last; - return; - else - Source.Current_Length := Last - First + 1; - Source.Data (1 .. Source.Current_Length) := - Source.Data (First .. Last); - - for J in Source.Current_Length + 1 .. - Source.Max_Length - loop - Source.Data (J) := Wide_Wide_NUL; - end loop; - - return; - end if; - end if; - end loop; - - Source.Current_Length := 0; - return; - end if; - end loop; - - Source.Current_Length := 0; - end Super_Trim; - - ----------- - -- Times -- - ----------- - - function Times - (Left : Natural; - Right : Wide_Wide_Character; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - - begin - if Left > Max_Length then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Left; - - for J in 1 .. Left loop - Result.Data (J) := Right; - end loop; - end if; - - return Result; - end Times; - - function Times - (Left : Natural; - Right : Wide_Wide_String; - Max_Length : Positive) return Super_String - is - Result : Super_String (Max_Length); - Pos : Positive := 1; - Rlen : constant Natural := Right'Length; - Nlen : constant Natural := Left * Rlen; - - begin - if Nlen > Max_Length then - raise Ada.Strings.Index_Error; - - else - Result.Current_Length := Nlen; - - if Nlen > 0 then - for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := Right; - Pos := Pos + Rlen; - end loop; - end if; - end if; - - return Result; - end Times; - - function Times - (Left : Natural; - Right : Super_String) return Super_String - is - Result : Super_String (Right.Max_Length); - Pos : Positive := 1; - Rlen : constant Natural := Right.Current_Length; - Nlen : constant Natural := Left * Rlen; - - begin - if Nlen > Right.Max_Length then - raise Ada.Strings.Length_Error; - - else - Result.Current_Length := Nlen; - - if Nlen > 0 then - for J in 1 .. Left loop - Result.Data (Pos .. Pos + Rlen - 1) := - Right.Data (1 .. Rlen); - Pos := Pos + Rlen; - end loop; - end if; - end if; - - return Result; - end Times; - - --------------------- - -- To_Super_String -- - --------------------- - - function To_Super_String - (Source : Wide_Wide_String; - Max_Length : Natural; - Drop : Truncation := Error) return Super_String - is - Result : Super_String (Max_Length); - Slen : constant Natural := Source'Length; - - begin - if Slen <= Max_Length then - Result.Current_Length := Slen; - Result.Data (1 .. Slen) := Source; - - else - case Drop is - when Strings.Right => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'First .. Source'First - 1 + Max_Length); - - when Strings.Left => - Result.Current_Length := Max_Length; - Result.Data (1 .. Max_Length) := - Source (Source'Last - (Max_Length - 1) .. Source'Last); - - when Strings.Error => - raise Ada.Strings.Length_Error; - end case; - end if; - - return Result; - end To_Super_String; - -end Ada.Strings.Wide_Wide_Superbounded; diff --git a/gcc/ada/a-stzsup.ads b/gcc/ada/a-stzsup.ads deleted file mode 100644 index 728b0bc..0000000 --- a/gcc/ada/a-stzsup.ads +++ /dev/null @@ -1,508 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This non generic package contains most of the implementation of the --- generic package Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length. - --- It defines type Super_String as a discriminated record with the maximum --- length as the discriminant. Individual instantiations of the package --- Strings.Wide_Wide_Bounded.Generic_Bounded_Length use this type with --- an appropriate discriminant value set. - -with Ada.Strings.Wide_Wide_Maps; - -package Ada.Strings.Wide_Wide_Superbounded is - pragma Preelaborate; - - Wide_Wide_NUL : constant Wide_Wide_Character := - Wide_Wide_Character'Val (0); - - -- Wide_Wide_Bounded.Generic_Bounded_Length.Wide_Wide_Bounded_String is - -- derived from Super_String, with the constraint of the maximum length. - - type Super_String (Max_Length : Positive) is record - Current_Length : Natural := 0; - Data : Wide_Wide_String (1 .. Max_Length); - -- A previous version had a default initial value for Data, which is - -- no longer necessary, because we now special-case this type in the - -- compiler, so "=" composes properly for descendants of this type. - -- Leaving it out is more efficient. - end record; - - -- The subprograms defined for Super_String are similar to those defined - -- for Bounded_Wide_Wide_String, except that they have different names, so - -- that they can be renamed in Wide_Wide_Bounded.Generic_Bounded_Length. - - function Super_Length (Source : Super_String) return Natural; - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Super_String - (Source : Wide_Wide_String; - Max_Length : Natural; - Drop : Truncation := Error) return Super_String; - -- Note the additional parameter Max_Length, which specifies the maximum - -- length setting of the resulting Super_String value. - - -- The following procedures have declarations (and semantics) that are - -- exactly analogous to those declared in Ada.Strings.Wide_Wide_Bounded. - - function Super_To_String (Source : Super_String) return Wide_Wide_String; - - procedure Set_Super_String - (Target : out Super_String; - Source : Wide_Wide_String; - Drop : Truncation := Error); - - function Super_Append - (Left : Super_String; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Super_String; - Right : Wide_Wide_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Wide_Wide_String; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Super_String; - Right : Wide_Wide_Character; - Drop : Truncation := Error) return Super_String; - - function Super_Append - (Left : Wide_Wide_Character; - Right : Super_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Append - (Source : in out Super_String; - New_Item : Super_String; - Drop : Truncation := Error); - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_Wide_String; - Drop : Truncation := Error); - - procedure Super_Append - (Source : in out Super_String; - New_Item : Wide_Wide_Character; - Drop : Truncation := Error); - - function Concat - (Left : Super_String; - Right : Super_String) return Super_String; - - function Concat - (Left : Super_String; - Right : Wide_Wide_String) return Super_String; - - function Concat - (Left : Wide_Wide_String; - Right : Super_String) return Super_String; - - function Concat - (Left : Super_String; - Right : Wide_Wide_Character) return Super_String; - - function Concat - (Left : Wide_Wide_Character; - Right : Super_String) return Super_String; - - function Super_Element - (Source : Super_String; - Index : Positive) return Wide_Wide_Character; - - procedure Super_Replace_Element - (Source : in out Super_String; - Index : Positive; - By : Wide_Wide_Character); - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Wide_Wide_String; - - function Super_Slice - (Source : Super_String; - Low : Positive; - High : Natural) return Super_String; - - procedure Super_Slice - (Source : Super_String; - Target : out Super_String; - Low : Positive; - High : Natural); - - function "=" - (Left : Super_String; - Right : Super_String) return Boolean; - - function Equal - (Left : Super_String; - Right : Super_String) return Boolean renames "="; - - function Equal - (Left : Super_String; - Right : Wide_Wide_String) return Boolean; - - function Equal - (Left : Wide_Wide_String; - Right : Super_String) return Boolean; - - function Less - (Left : Super_String; - Right : Super_String) return Boolean; - - function Less - (Left : Super_String; - Right : Wide_Wide_String) return Boolean; - - function Less - (Left : Wide_Wide_String; - Right : Super_String) return Boolean; - - function Less_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean; - - function Less_Or_Equal - (Left : Super_String; - Right : Wide_Wide_String) return Boolean; - - function Less_Or_Equal - (Left : Wide_Wide_String; - Right : Super_String) return Boolean; - - function Greater - (Left : Super_String; - Right : Super_String) return Boolean; - - function Greater - (Left : Super_String; - Right : Wide_Wide_String) return Boolean; - - function Greater - (Left : Wide_Wide_String; - Right : Super_String) return Boolean; - - function Greater_Or_Equal - (Left : Super_String; - Right : Super_String) return Boolean; - - function Greater_Or_Equal - (Left : Super_String; - Right : Wide_Wide_String) return Boolean; - - function Greater_Or_Equal - (Left : Wide_Wide_String; - Right : Super_String) return Boolean; - - ---------------------- - -- Search Functions -- - ---------------------- - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Super_Index - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Super_Index - (Source : Super_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Super_Index - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Super_Index_Non_Blank - (Source : Super_String; - Going : Direction := Forward) return Natural; - - function Super_Index_Non_Blank - (Source : Super_String; - From : Positive; - Going : Direction := Forward) return Natural; - - function Super_Count - (Source : Super_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Super_Count - (Source : Super_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Super_Count - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - - procedure Super_Find_Token - (Source : Super_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Super_String; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); - - function Super_Translate - (Source : Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Super_String; - - procedure Super_Translate - (Source : in out Super_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Super_Replace_Slice - (Source : Super_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Replace_Slice - (Source : in out Super_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String; - Drop : Truncation := Error); - - function Super_Insert - (Source : Super_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Insert - (Source : in out Super_String; - Before : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error); - - function Super_Overwrite - (Source : Super_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error) return Super_String; - - procedure Super_Overwrite - (Source : in out Super_String; - Position : Positive; - New_Item : Wide_Wide_String; - Drop : Truncation := Error); - - function Super_Delete - (Source : Super_String; - From : Positive; - Through : Natural) return Super_String; - - procedure Super_Delete - (Source : in out Super_String; - From : Positive; - Through : Natural); - - --------------------------------- - -- String Selector Subprograms -- - --------------------------------- - - function Super_Trim - (Source : Super_String; - Side : Trim_End) return Super_String; - - procedure Super_Trim - (Source : in out Super_String; - Side : Trim_End); - - function Super_Trim - (Source : Super_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String; - - procedure Super_Trim - (Source : in out Super_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set); - - function Super_Head - (Source : Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) return Super_String; - - procedure Super_Head - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error); - - function Super_Tail - (Source : Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error) return Super_String; - - procedure Super_Tail - (Source : in out Super_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space; - Drop : Truncation := Error); - - ------------------------------------ - -- String Constructor Subprograms -- - ------------------------------------ - - -- Note: in some of the following routines, there is an extra parameter - -- Max_Length which specifies the value of the maximum length for the - -- resulting Super_String value. - - function Times - (Left : Natural; - Right : Wide_Wide_Character; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Times - (Left : Natural; - Right : Wide_Wide_String; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Times - (Left : Natural; - Right : Super_String) return Super_String; - - function Super_Replicate - (Count : Natural; - Item : Wide_Wide_Character; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Super_Replicate - (Count : Natural; - Item : Wide_Wide_String; - Drop : Truncation := Error; - Max_Length : Positive) return Super_String; - -- Note the additional parameter Max_Length - - function Super_Replicate - (Count : Natural; - Item : Super_String; - Drop : Truncation := Error) return Super_String; - -private - -- Pragma Inline declarations - - pragma Inline ("="); - pragma Inline (Less); - pragma Inline (Less_Or_Equal); - pragma Inline (Greater); - pragma Inline (Greater_Or_Equal); - pragma Inline (Concat); - pragma Inline (Super_Count); - pragma Inline (Super_Element); - pragma Inline (Super_Find_Token); - pragma Inline (Super_Index); - pragma Inline (Super_Index_Non_Blank); - pragma Inline (Super_Length); - pragma Inline (Super_Replace_Element); - pragma Inline (Super_Slice); - pragma Inline (Super_To_String); - -end Ada.Strings.Wide_Wide_Superbounded; diff --git a/gcc/ada/a-stzunb-shared.adb b/gcc/ada/a-stzunb-shared.adb deleted file mode 100644 index bf2ed25..0000000 --- a/gcc/ada/a-stzunb-shared.adb +++ /dev/null @@ -1,2137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Wide_Unbounded is - - use Ada.Strings.Wide_Wide_Maps; - - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - function Aligned_Max_Length (Max_Length : Natural) return Natural; - -- Returns recommended length of the shared string which is greater or - -- equal to specified length. Calculation take in sense alignment of - -- the allocated memory segments to use memory effectively by - -- Append/Insert/etc operations. - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := LR.Last + RR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Left string is empty, return Rigth string - - elsif LR.Last = 0 then - Reference (RR); - DR := RR; - - -- Right string is empty, return Left string - - elsif RR.Last = 0 then - Reference (LR); - DR := LR; - - -- Overwise, allocate new shared string and fill data - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + Right'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Right is an empty string, return Left string - - elsif Right'Length = 0 then - Reference (LR); - DR := LR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (LR.Last + 1 .. DL) := Right; - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := Left'Length + RR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared one - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Left is empty string, return Right string - - elsif Left'Length = 0 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Left'Length) := Left; - DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - DL : constant Natural := LR.Last + 1; - DR : Shared_Wide_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); - DR.Data (DL) := Right; - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - function "&" - (Left : Wide_Wide_Character; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := 1 + RR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - DR := Allocate (DL); - DR.Data (1) := Left; - DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); - DR.Last := DL; - - return (AF.Controlled with Reference => DR); - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String - is - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is an empty string, reuse shared empty string - - if Left = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Left); - - for J in 1 .. Left loop - DR.Data (J) := Right; - end loop; - - DR.Last := Left; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - DL : constant Natural := Left * Right'Length; - DR : Shared_Wide_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + Right'Length - 1) := Right; - K := K + Right'Length; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - DL : constant Natural := Left * RR.Last; - DR : Shared_Wide_Wide_String_Access; - K : Positive; - - begin - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Coefficient is one, just return string itself - - elsif Left = 1 then - Reference (RR); - DR := RR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - K := 1; - - for J in 1 .. Left loop - DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); - K := K + RR.Last; - end loop; - - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); - end "<"; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) < Right; - end "<"; - - function "<" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left < RR.Data (1 .. RR.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); - end "<="; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) <= Right; - end "<="; - - function "<=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left <= RR.Data (1 .. RR.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - - begin - return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); - -- LR = RR means two strings shares shared string, thus they are equal - end "="; - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) = Right; - end "="; - - function "=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left = RR.Data (1 .. RR.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); - end ">"; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) > Right; - end ">"; - - function ">" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left > RR.Data (1 .. RR.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - - begin - -- LR = RR means two strings shares shared string, thus they are equal - - return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); - end ">="; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - LR : constant Shared_Wide_Wide_String_Access := Left.Reference; - begin - return LR.Data (1 .. LR.Last) >= Right; - end ">="; - - function ">=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - RR : constant Shared_Wide_Wide_String_Access := Right.Reference; - begin - return Left >= RR.Data (1 .. RR.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is - begin - Reference (Object.Reference); - end Adjust; - - ------------------------ - -- Aligned_Max_Length -- - ------------------------ - - function Aligned_Max_Length (Max_Length : Natural) return Natural is - Static_Size : constant Natural := - Empty_Shared_Wide_Wide_String'Size / Standard'Storage_Unit; - -- Total size of all static components - - Element_Size : constant Natural := - Wide_Wide_Character'Size / Standard'Storage_Unit; - - begin - return - (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) - * Min_Mul_Alloc - Static_Size) / Element_Size; - end Aligned_Max_Length; - - -------------- - -- Allocate -- - -------------- - - function Allocate - (Max_Length : Natural) return Shared_Wide_Wide_String_Access is - begin - -- Empty string requested, return shared empty string - - if Max_Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - return Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate requested space (and probably some more room) - - else - return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length)); - end if; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Unbounded_Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; - DL : constant Natural := SR.Last + NR.Last; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Source is an empty string, reuse New_Item data - - if SR.Last = 0 then - Reference (NR); - Source.Reference := NR; - Unreference (SR); - - -- New_Item is empty string, nothing to do - - elsif NR.Last = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- New_Item is an empty string, nothing to do - - if New_Item'Length = 0 then - null; - - -- Try to reuse existing shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (SR.Last + 1 .. DL) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (SR.Last + 1 .. DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_Character) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + 1; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Try to reuse existing shared string - - if Can_Be_Reused (SR, SR.Last + 1) then - SR.Data (SR.Last + 1) := New_Item; - SR.Last := SR.Last + 1; - - -- Otherwise, allocate new one and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (DL) := New_Item; - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Append; - - ------------------- - -- Can_Be_Reused -- - ------------------- - - function Can_Be_Reused - (Item : Shared_Wide_Wide_String_Access; - Length : Natural) return Boolean is - begin - return - System.Atomic_Counters.Is_One (Item.Counter) - and then Item.Max_Length >= Length - and then Item.Max_Length <= - Aligned_Max_Length (Length + Length / Growth_Factor); - end Can_Be_Reused; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Empty slice is deleted, use the same shared string - - if From > Through then - Reference (SR); - DR := SR; - - -- Index is out of range - - elsif Through > SR.Last then - raise Index_Error; - - -- Compute size of the result - - else - DL := SR.Last - (Through - From + 1); - - -- Result is an empty string, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Delete; - - procedure Delete - (Source : in out Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing changed, return - - if From > Through then - null; - - -- Through is outside of the range - - elsif Through > SR.Last then - raise Index_Error; - - else - DL := SR.Last - (Through - From + 1); - - -- Result is empty, reuse shared empty string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); - DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - if Index <= SR.Last then - return SR.Data (Index); - else - raise Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is - SR : constant Shared_Wide_Wide_String_Access := Object.Reference; - - begin - if SR /= null then - - -- The same controlled object can be finalized several times for - -- some reason. As per 7.6.1(24) this should have no ill effect, - -- so we need to add a guard for the case of finalizing the same - -- object twice. - - Object.Reference := null; - Unreference (SR); - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - Wide_Wide_Search.Find_Token - (SR.Data (From .. SR.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - Wide_Wide_Search.Find_Token - (SR.Data (1 .. SR.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Wide_Wide_String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation - (Wide_Wide_String, Wide_Wide_String_Access); - begin - Deallocate (X); - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is empty, reuse shared empty string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Length of the string is the same as requested, reuse source shared - -- string. - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is more than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- contents and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Head; - - procedure Head - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Result is empty, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Result is same with source string, reuse source shared string - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - if Count > SR.Last then - for J in SR.Last + 1 .. Count loop - SR.Data (J) := Pad; - end loop; - end if; - - SR.Last := Count; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (Count); - - -- Length of the source string is greater than requested, copy - -- corresponding slice. - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (1 .. Count); - - -- Length of the source string is less than requested, copy all - -- exists data and fill others by Pad character. - - else - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - - for J in SR.Last + 1 .. Count loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - Source.Reference := DR; - Unreference (SR); - end if; - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index - (SR.Data (1 .. SR.Last), Set, From, Test, Going); - end Index; - - --------------------- - -- Index_Non_Blank -- - --------------------- - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - begin - return Wide_Wide_Search.Index_Non_Blank - (SR.Data (1 .. SR.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is - begin - Reference (Object.Reference); - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check index first - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Inserted string is empty, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Insert; - - procedure Insert - (Source : in out Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : constant Natural := SR.Last + New_Item'Length; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Before > SR.Last + 1 then - raise Index_Error; - end if; - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Inserted string is empty, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string first - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL + DL / Growth_Factor); - DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); - DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; - DR.Data (Before + New_Item'Length .. DL) := - SR.Data (Before .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_Wide_Wide_String) return Natural is - begin - return Source.Reference.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Result is same with source string, reuse source shared string - - elsif New_Item'Length = 0 then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Bounds check - - if Position > SR.Last + 1 then - raise Index_Error; - end if; - - DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- String unchanged, nothing to do - - elsif New_Item'Length = 0 then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); - DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; - DR.Data (Position + New_Item'Length .. DL) := - SR.Data (Position + New_Item'Length .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end Overwrite; - - --------------- - -- Reference -- - --------------- - - procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is - begin - System.Atomic_Counters.Increment (Item.Counter); - end Reference; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Bounds check - - if Index <= SR.Last then - - -- Try to reuse existent shared string - - if Can_Be_Reused (SR, SR.Last) then - SR.Data (Index) := By; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); - DR.Data (Index) := By; - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - else - raise Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation when removed slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - - -- Otherwise just insert string - - else - return Insert (Source, Low, By); - end if; - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Bounds check - - if Low > SR.Last + 1 then - raise Index_Error; - end if; - - -- Do replace operation only when replaced slice is not empty - - if High >= Low then - DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; - -- This is the number of characters remaining in the string after - -- replacing the slice. - - -- Result is empty string, reuse empty shared string - - if DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - SR.Data (Low .. Low + By'Length - 1) := By; - SR.Last := DL; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); - DR.Data (Low .. Low + By'Length - 1) := By; - DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - - -- Otherwise just insert item - - else - Insert (Source, Low, By); - end if; - end Replace_Slice; - - ------------------------------- - -- Set_Unbounded_Wide_Wide_String -- - ------------------------------- - - procedure Set_Unbounded_Wide_Wide_String - (Target : out Unbounded_Wide_Wide_String; - Source : Wide_Wide_String) - is - TR : constant Shared_Wide_Wide_String_Access := Target.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- In case of empty string, reuse empty shared string - - if Source'Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_Wide_String'Access; - - else - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, Source'Length) then - Reference (TR); - DR := TR; - - -- Otherwise allocate new shared string - - else - DR := Allocate (Source'Length); - Target.Reference := DR; - end if; - - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - Unreference (TR); - end Set_Unbounded_Wide_Wide_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - else - return SR.Data (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- For empty result reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Result is hole source string, reuse source shared string - - elsif Count = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - end if; - - DR.Last := Count; - end if; - - return (AF.Controlled with Reference => DR); - end Tail; - - procedure Tail - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - procedure Common - (SR : Shared_Wide_Wide_String_Access; - DR : Shared_Wide_Wide_String_Access; - Count : Natural); - -- Common code of tail computation. SR/DR can point to the same object - - ------------ - -- Common -- - ------------ - - procedure Common - (SR : Shared_Wide_Wide_String_Access; - DR : Shared_Wide_Wide_String_Access; - Count : Natural) is - begin - if Count < SR.Last then - DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); - - else - DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); - - for J in 1 .. Count - SR.Last loop - DR.Data (J) := Pad; - end loop; - end if; - - DR.Last := Count; - end Common; - - begin - -- Result is empty string, reuse empty shared string - - if Count = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Length of the result is the same with length of the source string, - -- reuse source shared string. - - elsif Count = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, Count) then - Common (SR, SR, Count); - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (Count); - Common (SR, DR, Count); - Source.Reference := DR; - Unreference (SR); - end if; - end Tail; - - ------------------------- - -- To_Wide_Wide_String -- - ------------------------- - - function To_Wide_Wide_String - (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is - begin - return Source.Reference.Data (1 .. Source.Reference.Last); - end To_Wide_Wide_String; - - ----------------------------------- - -- To_Unbounded_Wide_Wide_String -- - ----------------------------------- - - function To_Unbounded_Wide_Wide_String - (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - DR : Shared_Wide_Wide_String_Access; - - begin - if Source'Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - DR := Allocate (Source'Length); - DR.Data (1 .. Source'Length) := Source; - DR.Last := Source'Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_Wide_String; - - function To_Unbounded_Wide_Wide_String - (Length : Natural) return Unbounded_Wide_Wide_String - is - DR : Shared_Wide_Wide_String_Access; - - begin - if Length = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - DR := Allocate (Length); - DR.Last := Length; - end if; - - return (AF.Controlled with Reference => DR); - end To_Unbounded_Wide_Wide_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Value (Mapping, SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - end Translate; - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate, reuse empty shared string - - if SR.Last = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - end if; - - return (AF.Controlled with Reference => DR); - - exception - when others => - Unreference (DR); - - raise; - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Nothing to translate - - if SR.Last = 0 then - null; - - -- Try to reuse shared string - - elsif Can_Be_Reused (SR, SR.Last) then - for J in 1 .. SR.Last loop - SR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - -- Otherwise allocate new shared string and fill it - - else - DR := Allocate (SR.Last); - - for J in 1 .. SR.Last loop - DR.Data (J) := Mapping.all (SR.Data (J)); - end loop; - - DR.Last := SR.Last; - Source.Reference := DR; - Unreference (SR); - end if; - - exception - when others => - if DR /= null then - Unreference (DR); - end if; - - raise; - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_Wide_Wide_String; - Side : Trim_End) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- reuse source shared string. - - if DL = SR.Last then - Reference (SR); - DR := SR; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Side : Trim_End) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index_Non_Blank (Source, Forward); - - -- All blanks, reuse empty shared string - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - else - case Side is - when Left => - High := SR.Last; - DL := SR.Last - Low + 1; - - when Right => - Low := 1; - High := Index_Non_Blank (Source, Backward); - DL := High; - - when Both => - High := Index_Non_Blank (Source, Backward); - DL := High - Low + 1; - end case; - - -- Length of the result is the same as length of the source string, - -- nothing to do. - - if DL = SR.Last then - null; - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - function Trim - (Source : Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - end if; - - return (AF.Controlled with Reference => DR); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - Low : Natural; - High : Natural; - - begin - Low := Index (Source, Left, Outside, Forward); - - -- Source includes only characters from Left set, reuse empty shared - -- string. - - if Low = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - else - High := Index (Source, Right, Outside, Backward); - DL := Integer'Max (0, High - Low + 1); - - -- Source includes only characters from Right set or result string - -- is empty, reuse empty shared string. - - if High = 0 or else DL = 0 then - Reference (Empty_Shared_Wide_Wide_String'Access); - Source.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (SR); - - -- Try to reuse existent shared string - - elsif Can_Be_Reused (SR, DL) then - SR.Data (1 .. DL) := SR.Data (Low .. High); - SR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Source.Reference := DR; - Unreference (SR); - end if; - end if; - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_Wide_String - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_Wide_String'Access); - DR := Empty_Shared_Wide_Wide_String'Access; - - -- Otherwise, allocate new shared string and fill it - - else - DL := High - Low + 1; - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - end if; - - return (AF.Controlled with Reference => DR); - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Target : out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) - is - SR : constant Shared_Wide_Wide_String_Access := Source.Reference; - TR : constant Shared_Wide_Wide_String_Access := Target.Reference; - DL : Natural; - DR : Shared_Wide_Wide_String_Access; - - begin - -- Check bounds - - if Low > SR.Last + 1 or else High > SR.Last then - raise Index_Error; - - -- Result is empty slice, reuse empty shared string - - elsif Low > High then - Reference (Empty_Shared_Wide_Wide_String'Access); - Target.Reference := Empty_Shared_Wide_Wide_String'Access; - Unreference (TR); - - else - DL := High - Low + 1; - - -- Try to reuse existent shared string - - if Can_Be_Reused (TR, DL) then - TR.Data (1 .. DL) := SR.Data (Low .. High); - TR.Last := DL; - - -- Otherwise, allocate new shared string and fill it - - else - DR := Allocate (DL); - DR.Data (1 .. DL) := SR.Data (Low .. High); - DR.Last := DL; - Target.Reference := DR; - Unreference (TR); - end if; - end if; - end Unbounded_Slice; - - ----------------- - -- Unreference -- - ----------------- - - procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is - - procedure Free is - new Ada.Unchecked_Deallocation - (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access); - - Aux : Shared_Wide_Wide_String_Access := Item; - - begin - if System.Atomic_Counters.Decrement (Aux.Counter) then - - -- Reference counter of Empty_Shared_Wide_Wide_String must never - -- reach zero. - - pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access); - - Free (Aux); - end if; - end Unreference; - -end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-stzunb-shared.ads b/gcc/ada/a-stzunb-shared.ads deleted file mode 100644 index d84c86b..0000000 --- a/gcc/ada/a-stzunb-shared.ads +++ /dev/null @@ -1,513 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is supported on: --- - all Alpha platforms --- - all ia64 platforms --- - all PowerPC platforms --- - all SPARC V9 platforms --- - all x86 platforms --- - all x86_64 platforms - -with Ada.Strings.Wide_Wide_Maps; -private with Ada.Finalization; -private with System.Atomic_Counters; - -package Ada.Strings.Wide_Wide_Unbounded is - pragma Preelaborate; - - type Unbounded_Wide_Wide_String is private; - pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); - - Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; - - function Length (Source : Unbounded_Wide_Wide_String) return Natural; - - type Wide_Wide_String_Access is access all Wide_Wide_String; - - procedure Free (X : in out Wide_Wide_String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_Wide_Wide_String - (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function To_Unbounded_Wide_Wide_String - (Length : Natural) return Unbounded_Wide_Wide_String; - - function To_Wide_Wide_String - (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; - - procedure Set_Unbounded_Wide_Wide_String - (Target : out Unbounded_Wide_Wide_String; - Source : Wide_Wide_String); - pragma Ada_05 (Set_Unbounded_Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Unbounded_Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_Character); - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_Character; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function Element - (Source : Unbounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character; - - procedure Replace_Element - (Source : in out Unbounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character); - - function Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String; - - function Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_Wide_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Target : out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Count - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Unbounded_Wide_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Unbounded_Wide_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String); - - function Insert - (Source : Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Insert - (Source : in out Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String); - - function Overwrite - (Source : Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Overwrite - (Source : in out Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String); - - function Delete - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_Wide_String; - - procedure Delete - (Source : in out Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_Wide_Wide_String; - Side : Trim_End) return Unbounded_Wide_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Unbounded_Wide_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set); - - function Head - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String; - - procedure Head - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space); - - function Tail - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String; - - procedure Tail - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space); - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - type Shared_Wide_Wide_String (Max_Length : Natural) is limited record - Counter : System.Atomic_Counters.Atomic_Counter; - -- Reference counter - - Last : Natural := 0; - Data : Wide_Wide_String (1 .. Max_Length); - -- Last is the index of last significant element of the Data. All - -- elements with larger indexes are just extra room for expansion. - end record; - - type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String; - - procedure Reference (Item : not null Shared_Wide_Wide_String_Access); - -- Increment reference counter. - - procedure Unreference (Item : not null Shared_Wide_Wide_String_Access); - -- Decrement reference counter. Deallocate Item when reference counter is - -- zero. - - function Can_Be_Reused - (Item : Shared_Wide_Wide_String_Access; - Length : Natural) return Boolean; - -- Returns True if Shared_Wide_Wide_String can be reused. There are two - -- criteria when Shared_Wide_Wide_String can be reused: its reference - -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively) - -- and its size is sufficient to store string with specified length - -- effectively. - - function Allocate - (Max_Length : Natural) return Shared_Wide_Wide_String_Access; - -- Allocates new Shared_Wide_Wide_String with at least specified maximum - -- length. Actual maximum length of the allocated Shared_Wide_Wide_String - -- can be slightly greater. Returns reference to - -- Empty_Shared_Wide_Wide_String when requested length is zero. - - Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0); - - function To_Unbounded - (S : Wide_Wide_String) return Unbounded_Wide_Wide_String - renames To_Unbounded_Wide_Wide_String; - -- This renames are here only to be used in the pragma Stream_Convert. - - type Unbounded_Wide_Wide_String is new AF.Controlled with record - Reference : Shared_Wide_Wide_String_Access := - Empty_Shared_Wide_Wide_String'Access; - end record; - - -- The Unbounded_Wide_Wide_String uses several techniques to increase speed - -- of the application: - - -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String - -- contains only the reference to the data which is shared between - -- several instances. The shared data is reallocated only when its value - -- is changed and the object mutation can't be used or it is inefficient - -- to use it; - - -- - object mutation. Shared data object can be reused without memory - -- reallocation when all of the following requirements are meat: - -- - shared data object don't used anywhere longer; - -- - its size is sufficient to store new value; - -- - the gap after reuse is less than some threshold. - - -- - memory preallocation. Most of used memory allocation algorithms - -- aligns allocated segment on the some boundary, thus some amount of - -- additional memory can be preallocated without any impact. Such - -- preallocated memory can used later by Append/Insert operations - -- without reallocation. - - -- Reference counting uses GCC builtin atomic operations, which allows safe - -- sharing of internal data between Ada tasks. Nevertheless, this does not - -- make objects of Unbounded_String thread-safe: an instance cannot be - -- accessed by several tasks simultaneously. - - pragma Stream_Convert - (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); - -- Provide stream routines without dragging in Ada.Streams - - pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); - -- Finalization is required only for freeing storage - - overriding procedure Initialize - (Object : in out Unbounded_Wide_Wide_String); - overriding procedure Adjust - (Object : in out Unbounded_Wide_Wide_String); - overriding procedure Finalize - (Object : in out Unbounded_Wide_Wide_String); - - Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := - (AF.Controlled with - Reference => - Empty_Shared_Wide_Wide_String' - Access); - -end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-stzunb.adb b/gcc/ada/a-stzunb.adb deleted file mode 100644 index 267df9e..0000000 --- a/gcc/ada/a-stzunb.adb +++ /dev/null @@ -1,1107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Fixed; -with Ada.Strings.Wide_Wide_Search; -with Ada.Unchecked_Deallocation; - -package body Ada.Strings.Wide_Wide_Unbounded is - - use Ada.Finalization; - - --------- - -- "&" -- - --------- - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - L_Length : constant Natural := Left.Last; - R_Length : constant Natural := Right.Last; - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := L_Length + R_Length; - - Result.Reference := new Wide_Wide_String (1 .. Result.Last); - - Result.Reference (1 .. L_Length) := - Left.Reference (1 .. Left.Last); - Result.Reference (L_Length + 1 .. Result.Last) := - Right.Reference (1 .. Right.Last); - - return Result; - end "&"; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - L_Length : constant Natural := Left.Last; - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := L_Length + Right'Length; - - Result.Reference := new Wide_Wide_String (1 .. Result.Last); - - Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); - Result.Reference (L_Length + 1 .. Result.Last) := Right; - - return Result; - end "&"; - - function "&" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - R_Length : constant Natural := Right.Last; - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := Left'Length + R_Length; - - Result.Reference := new Wide_Wide_String (1 .. Result.Last); - - Result.Reference (1 .. Left'Length) := Left; - Result.Reference (Left'Length + 1 .. Result.Last) := - Right.Reference (1 .. Right.Last); - - return Result; - end "&"; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String - is - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := Left.Last + 1; - - Result.Reference := new Wide_Wide_String (1 .. Result.Last); - - Result.Reference (1 .. Result.Last - 1) := - Left.Reference (1 .. Left.Last); - Result.Reference (Result.Last) := Right; - - return Result; - end "&"; - - function "&" - (Left : Wide_Wide_Character; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := Right.Last + 1; - - Result.Reference := new Wide_Wide_String (1 .. Result.Last); - Result.Reference (1) := Left; - Result.Reference (2 .. Result.Last) := - Right.Reference (1 .. Right.Last); - return Result; - end "&"; - - --------- - -- "*" -- - --------- - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String - is - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := Left; - - Result.Reference := new Wide_Wide_String (1 .. Left); - for J in Result.Reference'Range loop - Result.Reference (J) := Right; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - Len : constant Natural := Right'Length; - K : Positive; - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := Left * Len; - - Result.Reference := new Wide_Wide_String (1 .. Result.Last); - - K := 1; - for J in 1 .. Left loop - Result.Reference (K .. K + Len - 1) := Right; - K := K + Len; - end loop; - - return Result; - end "*"; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String - is - Len : constant Natural := Right.Last; - K : Positive; - Result : Unbounded_Wide_Wide_String; - - begin - Result.Last := Left * Len; - - Result.Reference := new Wide_Wide_String (1 .. Result.Last); - - K := 1; - for J in 1 .. Left loop - Result.Reference (K .. K + Len - 1) := - Right.Reference (1 .. Right.Last); - K := K + Len; - end loop; - - return Result; - end "*"; - - --------- - -- "<" -- - --------- - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); - end "<"; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) < Right; - end "<"; - - function "<" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return Left < Right.Reference (1 .. Right.Last); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); - end "<="; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) <= Right; - end "<="; - - function "<=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return Left <= Right.Reference (1 .. Right.Last); - end "<="; - - --------- - -- "=" -- - --------- - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); - end "="; - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) = Right; - end "="; - - function "=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return Left = Right.Reference (1 .. Right.Last); - end "="; - - --------- - -- ">" -- - --------- - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); - end ">"; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) > Right; - end ">"; - - function ">" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return Left > Right.Reference (1 .. Right.Last); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return - Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); - end ">="; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean - is - begin - return Left.Reference (1 .. Left.Last) >= Right; - end ">="; - - function ">=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean - is - begin - return Left >= Right.Reference (1 .. Right.Last); - end ">="; - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is - begin - -- Copy string, except we do not copy the statically allocated null - -- string, since it can never be deallocated. Note that we do not copy - -- extra string room here to avoid dragging unused allocated memory. - - if Object.Reference /= Null_Wide_Wide_String'Access then - Object.Reference := - new Wide_Wide_String'(Object.Reference (1 .. Object.Last)); - end if; - end Adjust; - - ------------ - -- Append -- - ------------ - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Unbounded_Wide_Wide_String) - is - begin - Realloc_For_Chunk (Source, New_Item.Last); - Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := - New_Item.Reference (1 .. New_Item.Last); - Source.Last := Source.Last + New_Item.Last; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_String) - is - begin - Realloc_For_Chunk (Source, New_Item'Length); - Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := - New_Item; - Source.Last := Source.Last + New_Item'Length; - end Append; - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_Character) - is - begin - Realloc_For_Chunk (Source, 1); - Source.Reference (Source.Last + 1) := New_Item; - Source.Last := Source.Last + 1; - end Append; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - begin - return - Wide_Wide_Search.Count - (Source.Reference (1 .. Source.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - begin - return - Wide_Wide_Search.Count - (Source.Reference (1 .. Source.Last), Pattern, Mapping); - end Count; - - function Count - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural - is - begin - return - Wide_Wide_Search.Count - (Source.Reference (1 .. Source.Last), Set); - end Count; - - ------------ - -- Delete -- - ------------ - - function Delete - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_Wide_String - is - begin - return - To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Delete - (Source.Reference (1 .. Source.Last), From, Through)); - end Delete; - - procedure Delete - (Source : in out Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) - is - begin - if From > Through then - null; - - elsif From < Source.Reference'First or else Through > Source.Last then - raise Index_Error; - - else - declare - Len : constant Natural := Through - From + 1; - - begin - Source.Reference (From .. Source.Last - Len) := - Source.Reference (Through + 1 .. Source.Last); - Source.Last := Source.Last - Len; - end; - end if; - end Delete; - - ------------- - -- Element -- - ------------- - - function Element - (Source : Unbounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character - is - begin - if Index <= Source.Last then - return Source.Reference (Index); - else - raise Strings.Index_Error; - end if; - end Element; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is - procedure Deallocate is - new Ada.Unchecked_Deallocation - (Wide_Wide_String, Wide_Wide_String_Access); - - begin - -- Note: Don't try to free statically allocated null string - - if Object.Reference /= Null_Wide_Wide_String'Access then - Deallocate (Object.Reference); - Object.Reference := Null_Unbounded_Wide_Wide_String.Reference; - Object.Last := 0; - end if; - end Finalize; - - ---------------- - -- Find_Token -- - ---------------- - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Wide_Search.Find_Token - (Source.Reference (From .. Source.Last), Set, Test, First, Last); - end Find_Token; - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership; - First : out Positive; - Last : out Natural) - is - begin - Wide_Wide_Search.Find_Token - (Source.Reference (1 .. Source.Last), Set, Test, First, Last); - end Find_Token; - - ---------- - -- Free -- - ---------- - - procedure Free (X : in out Wide_Wide_String_Access) is - procedure Deallocate is - new Ada.Unchecked_Deallocation - (Wide_Wide_String, Wide_Wide_String_Access); - - begin - -- Note: Do not try to free statically allocated null string - - if X /= Null_Unbounded_Wide_Wide_String.Reference then - Deallocate (X); - end if; - end Free; - - ---------- - -- Head -- - ---------- - - function Head - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String - is - begin - return To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Head - (Source.Reference (1 .. Source.Last), Count, Pad)); - end Head; - - procedure Head - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - Old : Wide_Wide_String_Access := Source.Reference; - begin - Source.Reference := - new Wide_Wide_String' - (Wide_Wide_Fixed.Head - (Source.Reference (1 .. Source.Last), Count, Pad)); - Source.Last := Source.Reference'Length; - Free (Old); - end Head; - - ----------- - -- Index -- - ----------- - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Strings.Direction := Strings.Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - begin - return - Wide_Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - begin - return - Wide_Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Strings.Membership := Strings.Inside; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return Wide_Wide_Search.Index - (Source.Reference (1 .. Source.Last), Set, Test, Going); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) return Natural - is - begin - return - Wide_Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural - is - begin - return - Wide_Wide_Search.Index - (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); - end Index; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural - is - begin - return - Wide_Wide_Search.Index - (Source.Reference (1 .. Source.Last), Set, From, Test, Going); - end Index; - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - Going : Strings.Direction := Strings.Forward) return Natural - is - begin - return - Wide_Wide_Search.Index_Non_Blank - (Source.Reference (1 .. Source.Last), Going); - end Index_Non_Blank; - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural - is - begin - return - Wide_Wide_Search.Index_Non_Blank - (Source.Reference (1 .. Source.Last), From, Going); - end Index_Non_Blank; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is - begin - Object.Reference := Null_Unbounded_Wide_Wide_String.Reference; - Object.Last := 0; - end Initialize; - - ------------ - -- Insert -- - ------------ - - function Insert - (Source : Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - begin - return - To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Insert - (Source.Reference (1 .. Source.Last), Before, New_Item)); - end Insert; - - procedure Insert - (Source : in out Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) - is - begin - if Before not in Source.Reference'First .. Source.Last + 1 then - raise Index_Error; - end if; - - Realloc_For_Chunk (Source, New_Item'Length); - - Source.Reference - (Before + New_Item'Length .. Source.Last + New_Item'Length) := - Source.Reference (Before .. Source.Last); - - Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; - Source.Last := Source.Last + New_Item'Length; - end Insert; - - ------------ - -- Length -- - ------------ - - function Length (Source : Unbounded_Wide_Wide_String) return Natural is - begin - return Source.Last; - end Length; - - --------------- - -- Overwrite -- - --------------- - - function Overwrite - (Source : Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - begin - return - To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Overwrite - (Source.Reference (1 .. Source.Last), Position, New_Item)); - end Overwrite; - - procedure Overwrite - (Source : in out Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) - is - NL : constant Natural := New_Item'Length; - begin - if Position <= Source.Last - NL + 1 then - Source.Reference (Position .. Position + NL - 1) := New_Item; - else - declare - Old : Wide_Wide_String_Access := Source.Reference; - begin - Source.Reference := new Wide_Wide_String' - (Wide_Wide_Fixed.Overwrite - (Source.Reference (1 .. Source.Last), Position, New_Item)); - Source.Last := Source.Reference'Length; - Free (Old); - end; - end if; - end Overwrite; - - ----------------------- - -- Realloc_For_Chunk -- - ----------------------- - - procedure Realloc_For_Chunk - (Source : in out Unbounded_Wide_Wide_String; - Chunk_Size : Natural) - is - Growth_Factor : constant := 32; - -- The growth factor controls how much extra space is allocated when - -- we have to increase the size of an allocated unbounded string. By - -- allocating extra space, we avoid the need to reallocate on every - -- append, particularly important when a string is built up by repeated - -- append operations of small pieces. This is expressed as a factor so - -- 32 means add 1/32 of the length of the string as growth space. - - Min_Mul_Alloc : constant := Standard'Maximum_Alignment; - -- Allocation will be done by a multiple of Min_Mul_Alloc This causes - -- no memory loss as most (all?) malloc implementations are obliged to - -- align the returned memory on the maximum alignment as malloc does not - -- know the target alignment. - - S_Length : constant Natural := Source.Reference'Length; - - begin - if Chunk_Size > S_Length - Source.Last then - declare - New_Size : constant Positive := - S_Length + Chunk_Size + (S_Length / Growth_Factor); - - New_Rounded_Up_Size : constant Positive := - ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc; - - Tmp : constant Wide_Wide_String_Access := - new Wide_Wide_String (1 .. New_Rounded_Up_Size); - - begin - Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); - Free (Source.Reference); - Source.Reference := Tmp; - end; - end if; - end Realloc_For_Chunk; - - --------------------- - -- Replace_Element -- - --------------------- - - procedure Replace_Element - (Source : in out Unbounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character) - is - begin - if Index <= Source.Last then - Source.Reference (Index) := By; - else - raise Strings.Index_Error; - end if; - end Replace_Element; - - ------------------- - -- Replace_Slice -- - ------------------- - - function Replace_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - begin - return To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Replace_Slice - (Source.Reference (1 .. Source.Last), Low, High, By)); - end Replace_Slice; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) - is - Old : Wide_Wide_String_Access := Source.Reference; - begin - Source.Reference := new Wide_Wide_String' - (Wide_Wide_Fixed.Replace_Slice - (Source.Reference (1 .. Source.Last), Low, High, By)); - Source.Last := Source.Reference'Length; - Free (Old); - end Replace_Slice; - - ------------------------------------ - -- Set_Unbounded_Wide_Wide_String -- - ------------------------------------ - - procedure Set_Unbounded_Wide_Wide_String - (Target : out Unbounded_Wide_Wide_String; - Source : Wide_Wide_String) - is - begin - Target.Last := Source'Length; - Target.Reference := new Wide_Wide_String (1 .. Source'Length); - Target.Reference.all := Source; - end Set_Unbounded_Wide_Wide_String; - - ----------- - -- Slice -- - ----------- - - function Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String - is - begin - -- Note: test of High > Length is in accordance with AI95-00128 - - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - return Source.Reference (Low .. High); - end if; - end Slice; - - ---------- - -- Tail -- - ---------- - - function Tail - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String is - begin - return To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Tail - (Source.Reference (1 .. Source.Last), Count, Pad)); - end Tail; - - procedure Tail - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - is - Old : Wide_Wide_String_Access := Source.Reference; - begin - Source.Reference := new Wide_Wide_String' - (Wide_Wide_Fixed.Tail - (Source.Reference (1 .. Source.Last), Count, Pad)); - Source.Last := Source.Reference'Length; - Free (Old); - end Tail; - - ----------------------------------- - -- To_Unbounded_Wide_Wide_String -- - ----------------------------------- - - function To_Unbounded_Wide_Wide_String - (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String - is - Result : Unbounded_Wide_Wide_String; - begin - Result.Last := Source'Length; - Result.Reference := new Wide_Wide_String (1 .. Source'Length); - Result.Reference.all := Source; - return Result; - end To_Unbounded_Wide_Wide_String; - - function To_Unbounded_Wide_Wide_String - (Length : Natural) return Unbounded_Wide_Wide_String - is - Result : Unbounded_Wide_Wide_String; - begin - Result.Last := Length; - Result.Reference := new Wide_Wide_String (1 .. Length); - return Result; - end To_Unbounded_Wide_Wide_String; - - ------------------------- - -- To_Wide_Wide_String -- - ------------------------- - - function To_Wide_Wide_String - (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String - is - begin - return Source.Reference (1 .. Source.Last); - end To_Wide_Wide_String; - - --------------- - -- Translate -- - --------------- - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Unbounded_Wide_Wide_String - is - begin - return - To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Translate - (Source.Reference (1 .. Source.Last), Mapping)); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - is - begin - Wide_Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); - end Translate; - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Unbounded_Wide_Wide_String - is - begin - return - To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Translate - (Source.Reference (1 .. Source.Last), Mapping)); - end Translate; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - is - begin - Wide_Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); - end Translate; - - ---------- - -- Trim -- - ---------- - - function Trim - (Source : Unbounded_Wide_Wide_String; - Side : Trim_End) return Unbounded_Wide_Wide_String - is - begin - return - To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Side : Trim_End) - is - Old : Wide_Wide_String_Access := Source.Reference; - begin - Source.Reference := - new Wide_Wide_String' - (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); - Source.Last := Source.Reference'Length; - Free (Old); - end Trim; - - function Trim - (Source : Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Unbounded_Wide_Wide_String - is - begin - return - To_Unbounded_Wide_Wide_String - (Wide_Wide_Fixed.Trim - (Source.Reference (1 .. Source.Last), Left, Right)); - end Trim; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - is - Old : Wide_Wide_String_Access := Source.Reference; - begin - Source.Reference := - new Wide_Wide_String' - (Wide_Wide_Fixed.Trim - (Source.Reference (1 .. Source.Last), Left, Right)); - Source.Last := Source.Reference'Length; - Free (Old); - end Trim; - - --------------------- - -- Unbounded_Slice -- - --------------------- - - function Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_Wide_String - is - begin - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - return - To_Unbounded_Wide_Wide_String (Source.Reference.all (Low .. High)); - end if; - end Unbounded_Slice; - - procedure Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Target : out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) - is - begin - if Low > Source.Last + 1 or else High > Source.Last then - raise Index_Error; - else - Target := - To_Unbounded_Wide_Wide_String (Source.Reference.all (Low .. High)); - end if; - end Unbounded_Slice; - -end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-stzunb.ads b/gcc/ada/a-stzunb.ads deleted file mode 100644 index fa7bc17..0000000 --- a/gcc/ada/a-stzunb.ads +++ /dev/null @@ -1,452 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2010, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Maps; -with Ada.Finalization; - -package Ada.Strings.Wide_Wide_Unbounded is - pragma Preelaborate; - - type Unbounded_Wide_Wide_String is private; - pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); - - Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; - - function Length (Source : Unbounded_Wide_Wide_String) return Natural; - - type Wide_Wide_String_Access is access all Wide_Wide_String; - - procedure Free (X : in out Wide_Wide_String_Access); - - -------------------------------------------------------- - -- Conversion, Concatenation, and Selection Functions -- - -------------------------------------------------------- - - function To_Unbounded_Wide_Wide_String - (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function To_Unbounded_Wide_Wide_String - (Length : Natural) return Unbounded_Wide_Wide_String; - - function To_Wide_Wide_String - (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; - - procedure Set_Unbounded_Wide_Wide_String - (Target : out Unbounded_Wide_Wide_String; - Source : Wide_Wide_String); - pragma Ada_05 (Set_Unbounded_Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Unbounded_Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_String); - - procedure Append - (Source : in out Unbounded_Wide_Wide_String; - New_Item : Wide_Wide_Character); - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; - - function "&" - (Left : Wide_Wide_Character; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function Element - (Source : Unbounded_Wide_Wide_String; - Index : Positive) return Wide_Wide_Character; - - procedure Replace_Element - (Source : in out Unbounded_Wide_Wide_String; - Index : Positive; - By : Wide_Wide_Character); - - function Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Wide_Wide_String; - - function Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural) return Unbounded_Wide_Wide_String; - pragma Ada_05 (Unbounded_Slice); - - procedure Unbounded_Slice - (Source : Unbounded_Wide_Wide_String; - Target : out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural); - pragma Ada_05 (Unbounded_Slice); - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function "<=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function "<=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - function ">=" - (Left : Unbounded_Wide_Wide_String; - Right : Wide_Wide_String) return Boolean; - - function ">=" - (Left : Wide_Wide_String; - Right : Unbounded_Wide_Wide_String) return Boolean; - - ------------------------ - -- Search Subprograms -- - ------------------------ - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - From : Positive; - Going : Direction := Forward; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - pragma Ada_05 (Index); - - function Index - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership := Inside; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index); - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - Going : Direction := Forward) return Natural; - - function Index_Non_Blank - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Going : Direction := Forward) return Natural; - pragma Ada_05 (Index_Non_Blank); - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := - Wide_Wide_Maps.Identity) - return Natural; - - function Count - (Source : Unbounded_Wide_Wide_String; - Pattern : Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Natural; - - function Count - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - From : Positive; - Test : Membership; - First : out Positive; - Last : out Natural); - pragma Ada_2012 (Find_Token); - - procedure Find_Token - (Source : Unbounded_Wide_Wide_String; - Set : Wide_Wide_Maps.Wide_Wide_Character_Set; - Test : Membership; - First : out Positive; - Last : out Natural); - - ------------------------------------ - -- String Translation Subprograms -- - ------------------------------------ - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) - return Unbounded_Wide_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); - - function Translate - (Source : Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) - return Unbounded_Wide_Wide_String; - - procedure Translate - (Source : in out Unbounded_Wide_Wide_String; - Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); - - --------------------------------------- - -- String Transformation Subprograms -- - --------------------------------------- - - function Replace_Slice - (Source : Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Replace_Slice - (Source : in out Unbounded_Wide_Wide_String; - Low : Positive; - High : Natural; - By : Wide_Wide_String); - - function Insert - (Source : Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Insert - (Source : in out Unbounded_Wide_Wide_String; - Before : Positive; - New_Item : Wide_Wide_String); - - function Overwrite - (Source : Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - procedure Overwrite - (Source : in out Unbounded_Wide_Wide_String; - Position : Positive; - New_Item : Wide_Wide_String); - - function Delete - (Source : Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural) return Unbounded_Wide_Wide_String; - - procedure Delete - (Source : in out Unbounded_Wide_Wide_String; - From : Positive; - Through : Natural); - - function Trim - (Source : Unbounded_Wide_Wide_String; - Side : Trim_End) return Unbounded_Wide_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Side : Trim_End); - - function Trim - (Source : Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set) - return Unbounded_Wide_Wide_String; - - procedure Trim - (Source : in out Unbounded_Wide_Wide_String; - Left : Wide_Wide_Maps.Wide_Wide_Character_Set; - Right : Wide_Wide_Maps.Wide_Wide_Character_Set); - - function Head - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String; - - procedure Head - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space); - - function Tail - (Source : Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space) - return Unbounded_Wide_Wide_String; - - procedure Tail - (Source : in out Unbounded_Wide_Wide_String; - Count : Natural; - Pad : Wide_Wide_Character := Wide_Wide_Space); - - function "*" - (Left : Natural; - Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; - - function "*" - (Left : Natural; - Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; - -private - pragma Inline (Length); - - package AF renames Ada.Finalization; - - Null_Wide_Wide_String : aliased Wide_Wide_String := ""; - - function To_Unbounded_Wide - (S : Wide_Wide_String) return Unbounded_Wide_Wide_String - renames To_Unbounded_Wide_Wide_String; - - type Unbounded_Wide_Wide_String is new AF.Controlled with record - Reference : Wide_Wide_String_Access := Null_Wide_Wide_String'Access; - Last : Natural := 0; - end record; - - -- The Unbounded_Wide_Wide_String is using a buffered implementation to - -- increase speed of the Append/Delete/Insert procedures. The Reference - -- string pointer above contains the current string value and extra room - -- at the end to be used by the next Append routine. Last is the index of - -- the string ending character. So the current string value is really - -- Reference (1 .. Last). - - pragma Stream_Convert - (Unbounded_Wide_Wide_String, To_Unbounded_Wide, To_Wide_Wide_String); - - pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); - -- Finalization is required only for freeing storage - - procedure Initialize (Object : in out Unbounded_Wide_Wide_String); - procedure Adjust (Object : in out Unbounded_Wide_Wide_String); - procedure Finalize (Object : in out Unbounded_Wide_Wide_String); - procedure Realloc_For_Chunk - (Source : in out Unbounded_Wide_Wide_String; - Chunk_Size : Natural); - -- Adjust the size allocated for the string. Add at least Chunk_Size so it - -- is safe to add a string of this size at the end of the current content. - -- The real size allocated for the string is Chunk_Size + x of the current - -- string size. This buffered handling makes the Append unbounded string - -- routines very fast. - - Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := - (AF.Controlled with - Reference => - Null_Wide_Wide_String'Access, - Last => 0); -end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/a-suecin.adb b/gcc/ada/a-suecin.adb deleted file mode 100644 index 73ebae5..0000000 --- a/gcc/ada/a-suecin.adb +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Unbounded.Aux; -with Ada.Strings.Equal_Case_Insensitive; - -function Ada.Strings.Unbounded.Equal_Case_Insensitive - (Left, Right : Unbounded.Unbounded_String) - return Boolean -is - SL, SR : Aux.Big_String_Access; - LL, LR : Natural; - -begin - Aux.Get_String (Left, SL, LL); - Aux.Get_String (Right, SR, LR); - - return Ada.Strings.Equal_Case_Insensitive - (Left => SL (1 .. LL), - Right => SR (1 .. LR)); -end Ada.Strings.Unbounded.Equal_Case_Insensitive; diff --git a/gcc/ada/a-suecin.ads b/gcc/ada/a-suecin.ads deleted file mode 100644 index 0896024..0000000 --- a/gcc/ada/a-suecin.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -function Ada.Strings.Unbounded.Equal_Case_Insensitive - (Left, Right : Unbounded.Unbounded_String) - return Boolean; - -pragma Preelaborate (Ada.Strings.Unbounded.Equal_Case_Insensitive); diff --git a/gcc/ada/a-suenco.adb b/gcc/ada/a-suenco.adb deleted file mode 100644 index 54d142d..0000000 --- a/gcc/ada/a-suenco.adb +++ /dev/null @@ -1,418 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.UTF_Encoding.Conversions is - use Interfaces; - - -- Convert from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE - - function Convert - (Item : UTF_String; - Input_Scheme : Encoding_Scheme; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String - is - begin - -- Nothing to do if identical schemes, but for UTF_8 we need to - -- handle overlong encodings, so need to do the full conversion. - - if Input_Scheme = Output_Scheme - and then Input_Scheme /= UTF_8 - then - return Item; - - -- For remaining cases, one or other of the operands is UTF-16BE/LE - -- encoded, or we have the UTF-8 to UTF-8 case where we must handle - -- overlong encodings. In all cases, go through UTF-16 intermediate. - - else - return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)), - Output_Scheme, Output_BOM); - end if; - end Convert; - - -- Convert from UTF-8/UTF-16BE/LE to UTF-16 - - function Convert - (Item : UTF_String; - Input_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_16_Wide_String - is - begin - if Input_Scheme = UTF_8 then - return Convert (Item, Output_BOM); - else - return To_UTF_16 (Item, Input_Scheme, Output_BOM); - end if; - end Convert; - - -- Convert from UTF-8 to UTF-16 - - function Convert - (Item : UTF_8_String; - Output_BOM : Boolean := False) return UTF_16_Wide_String - is - Result : UTF_16_Wide_String (1 .. Item'Length + 1); - -- Maximum length of result, including possible BOM - - Len : Natural := 0; - -- Number of characters stored so far in Result - - Iptr : Natural; - -- Next character to process in Item - - C : Unsigned_8; - -- Input UTF-8 code - - R : Unsigned_16; - -- Output UTF-16 code - - procedure Get_Continuation; - -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6 - -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr - -- is incremented. Raises exception if continuation byte does not exist - -- or is invalid. - - ---------------------- - -- Get_Continuation -- - ---------------------- - - procedure Get_Continuation is - begin - if Iptr > Item'Last then - Raise_Encoding_Error (Iptr - 1); - - else - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - if C < 2#10_000000# or else C > 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - - else - R := - Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); - end if; - end if; - end Get_Continuation; - - -- Start of processing for Convert - - begin - -- Output BOM if required - - if Output_BOM then - Len := Len + 1; - Result (Len) := BOM_16 (1); - end if; - - -- Skip OK BOM - - Iptr := Item'First; - - if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then - Iptr := Iptr + 3; - - -- Error if bad BOM - - elsif Item'Length >= 2 - and then (Item (Iptr .. Iptr + 1) = BOM_16BE - or else - Item (Iptr .. Iptr + 1) = BOM_16LE) - then - Raise_Encoding_Error (Iptr); - - -- No BOM present - - else - Iptr := Item'First; - end if; - - while Iptr <= Item'Last loop - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#00# .. 16#7F# - -- UTF-8: 0xxxxxxx - -- UTF-16: 00000000_0xxxxxxx - - if C <= 16#7F# then - Len := Len + 1; - Result (Len) := Wide_Character'Val (C); - - -- No initial code can be of the form 10xxxxxx. Such codes are used - -- only for continuations. - - elsif C <= 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - - -- Codes in the range 16#80# .. 16#7FF# - -- UTF-8: 110yyyxx 10xxxxxx - -- UTF-16: 00000yyy_xxxxxxxx - - elsif C <= 2#110_11111# then - R := Unsigned_16 (C and 2#000_11111#); - Get_Continuation; - Len := Len + 1; - Result (Len) := Wide_Character'Val (R); - - -- Codes in the range 16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF# - -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx - -- UTF-16: yyyyyyyy_xxxxxxxx - - elsif C <= 2#1110_1111# then - R := Unsigned_16 (C and 2#0000_1111#); - Get_Continuation; - Get_Continuation; - Len := Len + 1; - Result (Len) := Wide_Character'Val (R); - - -- Make sure that we don't have a result in the forbidden range - -- reserved for UTF-16 surrogate characters. - - if R in 16#D800# .. 16#DF00# then - Raise_Encoding_Error (Iptr - 3); - end if; - - -- Codes in the range 16#10000# .. 16#10FFFF# - -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - -- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx - -- Note: zzzz in the output is input zzzzz - 1 - - elsif C <= 2#11110_111# then - R := Unsigned_16 (C and 2#00000_111#); - Get_Continuation; - - -- R now has zzzzzyyyy - - -- At this stage, we check for the case where we have an overlong - -- encoding, and the encoded value in fact lies in the single word - -- range (16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF#). This means - -- that the result fits in a single result word. - - if R <= 2#1111# then - Get_Continuation; - Get_Continuation; - - -- Make sure we are not in the forbidden surrogate range - - if R in 16#D800# .. 16#DF00# then - Raise_Encoding_Error (Iptr - 3); - end if; - - -- Otherwise output a single UTF-16 value - - Len := Len + 1; - Result (Len) := Wide_Character'Val (R); - - -- Here for normal case (code value > 16#FFFF and zzzzz non-zero) - - else - -- Subtract 1 from input zzzzz value to get output zzzz value - - R := R - 2#0000_1_0000#; - - -- R now has zzzzyyyy (zzzz minus one for the output) - - Get_Continuation; - - -- R now has zzzzyy_yyyyyyxx - - Len := Len + 1; - Result (Len) := - Wide_Character'Val - (2#110110_00_0000_0000# or Shift_Right (R, 4)); - - R := R and 2#1111#; - Get_Continuation; - Len := Len + 1; - Result (Len) := - Wide_Character'Val (2#110111_00_0000_0000# or R); - end if; - - -- Any other code is an error - - else - Raise_Encoding_Error (Iptr - 1); - end if; - end loop; - - return Result (1 .. Len); - end Convert; - - -- Convert from UTF-16 to UTF-8/UTF-16-BE/LE - - function Convert - (Item : UTF_16_Wide_String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String - is - begin - if Output_Scheme = UTF_8 then - return Convert (Item, Output_BOM); - else - return From_UTF_16 (Item, Output_Scheme, Output_BOM); - end if; - end Convert; - - -- Convert from UTF-16 to UTF-8 - - function Convert - (Item : UTF_16_Wide_String; - Output_BOM : Boolean := False) return UTF_8_String - is - Result : UTF_8_String (1 .. 3 * Item'Length + 3); - -- Worst case is 3 output codes for each input code + BOM space - - Len : Natural; - -- Number of result codes stored - - Iptr : Natural; - -- Pointer to next input character - - C1, C2 : Unsigned_16; - - zzzzz : Unsigned_16; - yyyyyyyy : Unsigned_16; - xxxxxxxx : Unsigned_16; - -- Components of double length case - - begin - Iptr := Item'First; - - -- Skip BOM at start of input - - if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then - Iptr := Iptr + 1; - end if; - - -- Generate output BOM if required - - if Output_BOM then - Result (1 .. 3) := BOM_8; - Len := 3; - else - Len := 0; - end if; - - -- Loop through input - - while Iptr <= Item'Last loop - C1 := To_Unsigned_16 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#0000# - 16#007F# - -- UTF-16: 000000000xxxxxxx - -- UTF-8: 0xxxxxxx - - if C1 <= 16#007F# then - Result (Len + 1) := Character'Val (C1); - Len := Len + 1; - - -- Codes in the range 16#80# - 16#7FF# - -- UTF-16: 00000yyyxxxxxxxx - -- UTF-8: 110yyyxx 10xxxxxx - - elsif C1 <= 16#07FF# then - Result (Len + 1) := - Character'Val - (2#110_00000# or Shift_Right (C1, 6)); - Result (Len + 2) := - Character'Val - (2#10_000000# or (C1 and 2#00_111111#)); - Len := Len + 2; - - -- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF# - -- UTF-16: yyyyyyyyxxxxxxxx - -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx - - elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then - Result (Len + 1) := - Character'Val - (2#1110_0000# or Shift_Right (C1, 12)); - Result (Len + 2) := - Character'Val - (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#)); - Result (Len + 3) := - Character'Val - (2#10_000000# or (C1 and 2#00_111111#)); - Len := Len + 3; - - -- Codes in the range 16#10000# - 16#10FFFF# - -- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx - -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - -- Note: zzzzz in the output is input zzzz + 1 - - elsif C1 <= 2#110110_11_11111111# then - if Iptr > Item'Last then - Raise_Encoding_Error (Iptr - 1); - else - C2 := To_Unsigned_16 (Item (Iptr)); - Iptr := Iptr + 1; - end if; - - if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then - Raise_Encoding_Error (Iptr - 1); - end if; - - zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1; - yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#) - or - (Shift_Right (C2, 8) and 2#000000_11#)); - xxxxxxxx := C2 and 2#11111111#; - - Result (Len + 1) := - Character'Val - (2#11110_000# or (Shift_Right (zzzzz, 2))); - Result (Len + 2) := - Character'Val - (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) - or Shift_Right (yyyyyyyy, 4)); - Result (Len + 3) := - Character'Val - (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) - or Shift_Right (xxxxxxxx, 6)); - Result (Len + 4) := - Character'Val - (2#10_000000# or (xxxxxxxx and 2#00_111111#)); - Len := Len + 4; - - -- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st) - - else - Raise_Encoding_Error (Iptr - 2); - end if; - end loop; - - return Result (1 .. Len); - end Convert; - -end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suenco.ads b/gcc/ada/a-suenco.ads deleted file mode 100644 index 0aa4f88..0000000 --- a/gcc/ada/a-suenco.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This is an Ada 2012 package defined in AI05-0137-1. It provides conversions --- from one UTF encoding method to another. Note: this package is consistent --- with Ada 95, and may be used in Ada 95 or Ada 2005 mode. - -package Ada.Strings.UTF_Encoding.Conversions is - pragma Pure (Conversions); - - -- In the following conversion routines, a BOM in the input that matches - -- the encoding scheme is ignored, an incorrect BOM causes Encoding_Error - -- to be raised. A BOM is present in the output if the Output_BOM parameter - -- is set to True. - - function Convert - (Item : UTF_String; - Input_Scheme : Encoding_Scheme; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String; - -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified - -- by the Input_Scheme argument, and generate an output encoded in one of - -- these three schemes as specified by the Output_Scheme argument. - - function Convert - (Item : UTF_String; - Input_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_16_Wide_String; - -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified - -- by the Input_Scheme argument, and generate an output encoded in UTF-16. - - function Convert - (Item : UTF_8_String; - Output_BOM : Boolean := False) return UTF_16_Wide_String; - -- Convert from UTF-8 to UTF-16 - - function Convert - (Item : UTF_16_Wide_String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String; - -- Convert from UTF-16 to UTF-8, UTF-16LE, or UTF-16BE as specified by - -- the Output_Scheme argument. - - function Convert - (Item : UTF_16_Wide_String; - Output_BOM : Boolean := False) return UTF_8_String; - -- Convert from UTF-16 to UTF-8 - -end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/a-suenst.adb b/gcc/ada/a-suenst.adb deleted file mode 100644 index 2ed5c2c..0000000 --- a/gcc/ada/a-suenst.adb +++ /dev/null @@ -1,350 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.STRINGS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.UTF_Encoding.Strings is - use Interfaces; - - ------------ - -- Decode -- - ------------ - - -- Decode UTF-8/UTF-16BE/UTF-16LE input to String - - function Decode - (Item : UTF_String; - Input_Scheme : Encoding_Scheme) return String - is - begin - if Input_Scheme = UTF_8 then - return Decode (Item); - else - return Decode (To_UTF_16 (Item, Input_Scheme)); - end if; - end Decode; - - -- Decode UTF-8 input to String - - function Decode (Item : UTF_8_String) return String is - Result : String (1 .. Item'Length); - -- Result string (worst case is same length as input) - - Len : Natural := 0; - -- Length of result stored so far - - Iptr : Natural; - -- Input Item pointer - - C : Unsigned_8; - R : Unsigned_16; - - procedure Get_Continuation; - -- Reads a continuation byte of the form 10xxxxxx, shifts R left - -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On - -- return Ptr is incremented. Raises exception if continuation - -- byte does not exist or is invalid. - - ---------------------- - -- Get_Continuation -- - ---------------------- - - procedure Get_Continuation is - begin - if Iptr > Item'Last then - Raise_Encoding_Error (Iptr - 1); - - else - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - if C not in 2#10_000000# .. 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - else - R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); - end if; - end if; - end Get_Continuation; - - -- Start of processing for Decode - - begin - Iptr := Item'First; - - -- Skip BOM at start - - if Item'Length >= 3 - and then Item (Iptr .. Iptr + 2) = BOM_8 - then - Iptr := Iptr + 3; - - -- Error if bad BOM - - elsif Item'Length >= 2 - and then (Item (Iptr .. Iptr + 1) = BOM_16BE - or else - Item (Iptr .. Iptr + 1) = BOM_16LE) - then - Raise_Encoding_Error (Iptr); - end if; - - while Iptr <= Item'Last loop - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - R := Unsigned_16 (C); - - -- No initial code can be of the form 10xxxxxx. Such codes are used - -- only for continuations. - - elsif C <= 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 2#110_11111# then - R := Unsigned_16 (C and 2#000_11111#); - Get_Continuation; - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - -- Such codes are out of range for type Character - - -- Codes in the range 16#10000# - 16#10FFFF# are represented as - -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - - -- Such codes are out of range for Wide_String output - - -- Thus all remaining cases raise Encoding_Error - - else - Raise_Encoding_Error (Iptr - 1); - end if; - - Len := Len + 1; - - -- The value may still be out of range of Standard.Character. We make - -- the check explicit because the library is typically compiled with - -- range checks disabled. - - if R > Character'Pos (Character'Last) then - Raise_Encoding_Error (Iptr - 1); - end if; - - Result (Len) := Character'Val (R); - end loop; - - return Result (1 .. Len); - end Decode; - - -- Decode UTF-16 input to String - - function Decode (Item : UTF_16_Wide_String) return String is - Result : String (1 .. Item'Length); - -- Result is same length as input (possibly minus 1 if BOM present) - - Len : Natural := 0; - -- Length of result - - Iptr : Natural; - -- Index of next Item element - - C : Unsigned_16; - - begin - -- Skip UTF-16 BOM at start - - Iptr := Item'First; - - if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then - Iptr := Iptr + 1; - end if; - - -- Loop through input characters - - while Iptr <= Item'Last loop - C := To_Unsigned_16 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#0000#..16#00FF# represent their own value - - if C <= 16#00FF# then - Len := Len + 1; - Result (Len) := Character'Val (C); - - -- All other codes are invalid, either they are invalid UTF-16 - -- encoding sequences, or they represent values that are out of - -- range for type Character. - - else - Raise_Encoding_Error (Iptr - 1); - end if; - end loop; - - return Result (1 .. Len); - end Decode; - - ------------ - -- Encode -- - ------------ - - -- Encode String in UTF-8, UTF-16BE or UTF-16LE - - function Encode - (Item : String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String - is - begin - -- Case of UTF_8 - - if Output_Scheme = UTF_8 then - return Encode (Item, Output_BOM); - - -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary - - else - return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), - Output_Scheme, Output_BOM); - end if; - end Encode; - - -- Encode String in UTF-8 - - function Encode - (Item : String; - Output_BOM : Boolean := False) return UTF_8_String - is - Result : UTF_8_String (1 .. 3 * Item'Length + 3); - -- Worst case is three bytes per input byte + space for BOM - - Len : Natural; - -- Number of output codes stored in Result - - C : Unsigned_8; - -- Single input character - - procedure Store (C : Unsigned_8); - pragma Inline (Store); - -- Store one output code, C is in the range 0 .. 255 - - ----------- - -- Store -- - ----------- - - procedure Store (C : Unsigned_8) is - begin - Len := Len + 1; - Result (Len) := Character'Val (C); - end Store; - - -- Start of processing for UTF8_Encode - - begin - -- Output BOM if required - - if Output_BOM then - Result (1 .. 3) := BOM_8; - Len := 3; - else - Len := 0; - end if; - - -- Loop through characters of input - - for J in Item'Range loop - C := To_Unsigned_8 (Item (J)); - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - Store (C); - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - -- For type character of course, the limit is 16#FF# in any case - - else - Store (2#110_00000# or Shift_Right (C, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - end if; - end loop; - - return Result (1 .. Len); - end Encode; - - -- Encode String in UTF-16 - - function Encode - (Item : String; - Output_BOM : Boolean := False) return UTF_16_Wide_String - is - Result : UTF_16_Wide_String - (1 .. Item'Length + Boolean'Pos (Output_BOM)); - -- Output is same length as input + possible BOM - - Len : Integer; - -- Length of output string - - C : Unsigned_8; - - begin - -- Output BOM if required - - if Output_BOM then - Result (1) := BOM_16 (1); - Len := 1; - else - Len := 0; - end if; - - -- Loop through input characters encoding them - - for Iptr in Item'Range loop - C := To_Unsigned_8 (Item (Iptr)); - - -- Codes in the range 16#0000#..16#00FF# are output unchanged. This - -- includes all possible cases of Character values. - - Len := Len + 1; - Result (Len) := Wide_Character'Val (C); - end loop; - - return Result; - end Encode; - -end Ada.Strings.UTF_Encoding.Strings; diff --git a/gcc/ada/a-suenst.ads b/gcc/ada/a-suenst.ads deleted file mode 100644 index 1706cd6..0000000 --- a/gcc/ada/a-suenst.ads +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.STRINGS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding --- and decoding String values using UTF encodings. Note: this package is --- consistent with Ada 95, and may be included in Ada 95 implementations. - -package Ada.Strings.UTF_Encoding.Strings is - pragma Pure (Strings); - - -- The encoding routines take a String as input and encode the result - -- using the specified UTF encoding method. The result includes a BOM if - -- the Output_BOM argument is set to True. All 256 values of type Character - -- are valid, so Encoding_Error cannot be raised for string input data. - - function Encode - (Item : String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String; - -- Encode String using UTF-8, UTF-16LE or UTF-16BE encoding as specified by - -- the Output_Scheme parameter. - - function Encode - (Item : String; - Output_BOM : Boolean := False) return UTF_8_String; - -- Encode String using UTF-8 encoding - - function Encode - (Item : String; - Output_BOM : Boolean := False) return UTF_16_Wide_String; - -- Encode String using UTF_16 encoding - - -- The decoding routines take a UTF String as input, and return a decoded - -- Wide_String. If the UTF String starts with a BOM that matches the - -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error, - -- as does a code out of range of type Character. - - function Decode - (Item : UTF_String; - Input_Scheme : Encoding_Scheme) return String; - -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the - -- Input_Scheme parameter. It is decoded and returned as a String value. - -- Note: a convenient form for scheme may be Encoding (UTF_String). - - function Decode - (Item : UTF_8_String) return String; - -- The input is encoded in UTF-8 and returned as a String value - - function Decode - (Item : UTF_16_Wide_String) return String; - -- The input is encoded in UTF-16 and returned as a String value - -end Ada.Strings.UTF_Encoding.Strings; diff --git a/gcc/ada/a-suewst.adb b/gcc/ada/a-suewst.adb deleted file mode 100644 index c0855d3..0000000 --- a/gcc/ada/a-suewst.adb +++ /dev/null @@ -1,370 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.WIDE_STRINGS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.UTF_Encoding.Wide_Strings is - use Interfaces; - - ------------ - -- Decode -- - ------------ - - -- Decode UTF-8/UTF-16BE/UTF-16LE input to Wide_String - - function Decode - (Item : UTF_String; - Input_Scheme : Encoding_Scheme) return Wide_String - is - begin - if Input_Scheme = UTF_8 then - return Decode (Item); - else - return Decode (To_UTF_16 (Item, Input_Scheme)); - end if; - end Decode; - - -- Decode UTF-8 input to Wide_String - - function Decode (Item : UTF_8_String) return Wide_String is - Result : Wide_String (1 .. Item'Length); - -- Result string (worst case is same length as input) - - Len : Natural := 0; - -- Length of result stored so far - - Iptr : Natural; - -- Input Item pointer - - C : Unsigned_8; - R : Unsigned_16; - - procedure Get_Continuation; - -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6 - -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr - -- is incremented. Raises exception if continuation byte does not exist - -- or is invalid. - - ---------------------- - -- Get_Continuation -- - ---------------------- - - procedure Get_Continuation is - begin - if Iptr > Item'Last then - Raise_Encoding_Error (Iptr - 1); - - else - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - if C not in 2#10_000000# .. 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - else - R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); - end if; - end if; - end Get_Continuation; - - -- Start of processing for Decode - - begin - Iptr := Item'First; - - -- Skip BOM at start - - if Item'Length >= 3 - and then Item (Iptr .. Iptr + 2) = BOM_8 - then - Iptr := Iptr + 3; - - -- Error if bad BOM - - elsif Item'Length >= 2 - and then (Item (Iptr .. Iptr + 1) = BOM_16BE - or else - Item (Iptr .. Iptr + 1) = BOM_16LE) - then - Raise_Encoding_Error (Iptr); - end if; - - while Iptr <= Item'Last loop - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - R := Unsigned_16 (C); - - -- No initial code can be of the form 10xxxxxx. Such codes are used - -- only for continuations. - - elsif C <= 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 2#110_11111# then - R := Unsigned_16 (C and 2#000_11111#); - Get_Continuation; - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - elsif C <= 2#1110_1111# then - R := Unsigned_16 (C and 2#0000_1111#); - Get_Continuation; - Get_Continuation; - - -- Codes in the range 16#10000# - 16#10FFFF# are represented as - -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - - -- Such codes are out of range for Wide_String output - - else - Raise_Encoding_Error (Iptr - 1); - end if; - - Len := Len + 1; - Result (Len) := Wide_Character'Val (R); - end loop; - - return Result (1 .. Len); - end Decode; - - -- Decode UTF-16 input to Wide_String - - function Decode (Item : UTF_16_Wide_String) return Wide_String is - Result : Wide_String (1 .. Item'Length); - -- Result is same length as input (possibly minus 1 if BOM present) - - Len : Natural := 0; - -- Length of result - - Iptr : Natural; - -- Index of next Item element - - C : Unsigned_16; - - begin - -- Skip UTF-16 BOM at start - - Iptr := Item'First; - - if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then - Iptr := Iptr + 1; - end if; - - -- Loop through input characters - - while Iptr <= Item'Last loop - C := To_Unsigned_16 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# - -- represent their own value. - - if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then - Len := Len + 1; - Result (Len) := Wide_Character'Val (C); - - -- Codes in the range 16#D800#..16#DBFF# represent the first of the - -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". - -- Such codes are out of range for 16-bit output. - - -- The case of input in the range 16#DC00#..16#DFFF# must never - -- occur, since it means we have a second surrogate character with - -- no corresponding first surrogate. - - -- Codes in the range 16#FFFE# .. 16#FFFF# are also invalid since - -- they conflict with codes used for BOM values. - - -- Thus all remaining codes are invalid - - else - Raise_Encoding_Error (Iptr - 1); - end if; - end loop; - - return Result (1 .. Len); - end Decode; - - ------------ - -- Encode -- - ------------ - - -- Encode Wide_String in UTF-8, UTF-16BE or UTF-16LE - - function Encode - (Item : Wide_String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String - is - begin - -- Case of UTF_8 - - if Output_Scheme = UTF_8 then - return Encode (Item, Output_BOM); - - -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary - - else - return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), - Output_Scheme, Output_BOM); - end if; - end Encode; - - -- Encode Wide_String in UTF-8 - - function Encode - (Item : Wide_String; - Output_BOM : Boolean := False) return UTF_8_String - is - Result : UTF_8_String (1 .. 3 * Item'Length + 3); - -- Worst case is three bytes per input byte + space for BOM - - Len : Natural; - -- Number of output codes stored in Result - - C : Unsigned_16; - -- Single input character - - procedure Store (C : Unsigned_16); - pragma Inline (Store); - -- Store one output code, C is in the range 0 .. 255 - - ----------- - -- Store -- - ----------- - - procedure Store (C : Unsigned_16) is - begin - Len := Len + 1; - Result (Len) := Character'Val (C); - end Store; - - -- Start of processing for UTF8_Encode - - begin - -- Output BOM if required - - if Output_BOM then - Result (1 .. 3) := BOM_8; - Len := 3; - else - Len := 0; - end if; - - -- Loop through characters of input - - for J in Item'Range loop - C := To_Unsigned_16 (Item (J)); - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - Store (C); - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 16#7FF# then - Store (2#110_00000# or Shift_Right (C, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - else - Store (2#1110_0000# or Shift_Right (C, 12)); - Store (2#10_000000# or - Shift_Right (C and 2#111111_000000#, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - end if; - end loop; - - return Result (1 .. Len); - end Encode; - - -- Encode Wide_String in UTF-16 - - function Encode - (Item : Wide_String; - Output_BOM : Boolean := False) return UTF_16_Wide_String - is - Result : UTF_16_Wide_String - (1 .. Item'Length + Boolean'Pos (Output_BOM)); - -- Output is same length as input + possible BOM - - Len : Integer; - -- Length of output string - - C : Unsigned_16; - - begin - -- Output BOM if required - - if Output_BOM then - Result (1) := BOM_16 (1); - Len := 1; - else - Len := 0; - end if; - - -- Loop through input characters encoding them - - for Iptr in Item'Range loop - C := To_Unsigned_16 (Item (Iptr)); - - -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# are - -- output unchanged. - - if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then - Len := Len + 1; - Result (Len) := Wide_Character'Val (C); - - -- Codes in the range 16#D800#..16#DFFF# should never appear in the - -- input, since no valid Unicode characters are in this range (which - -- would conflict with the UTF-16 surrogate encodings). Similarly - -- codes in the range 16#FFFE#..16#FFFF conflict with BOM codes. - -- Thus all remaining codes are illegal. - - else - Raise_Encoding_Error (Iptr); - end if; - end loop; - - return Result; - end Encode; - -end Ada.Strings.UTF_Encoding.Wide_Strings; diff --git a/gcc/ada/a-suewst.ads b/gcc/ada/a-suewst.ads deleted file mode 100644 index e0f8d4c..0000000 --- a/gcc/ada/a-suewst.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.WIDE_STRINGS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding --- and decoding Wide_String values using UTF encodings. Note: this package is --- consistent with Ada 95, and may be included in Ada 95 implementations. - -package Ada.Strings.UTF_Encoding.Wide_Strings is - pragma Pure (Wide_Strings); - - -- The encoding routines take a Wide_String as input and encode the result - -- using the specified UTF encoding method. The result includes a BOM if - -- the Output_BOM argument is set to True. Encoding_Error is raised if an - -- invalid character appears in the input. In particular the characters - -- in the range 16#D800# .. 16#DFFF# are invalid because they conflict - -- with UTF-16 surrogate encodings, and the characters 16#FFFE# and - -- 16#FFFF# are also invalid because they conflict with BOM codes. - - function Encode - (Item : Wide_String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String; - -- Encode Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as - -- specified by the Output_Scheme parameter. - - function Encode - (Item : Wide_String; - Output_BOM : Boolean := False) return UTF_8_String; - -- Encode Wide_String using UTF-8 encoding - - function Encode - (Item : Wide_String; - Output_BOM : Boolean := False) return UTF_16_Wide_String; - -- Encode Wide_String using UTF_16 encoding - - -- The decoding routines take a UTF String as input, and return a decoded - -- Wide_String. If the UTF String starts with a BOM that matches the - -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. - - function Decode - (Item : UTF_String; - Input_Scheme : Encoding_Scheme) return Wide_String; - -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the - -- Input_Scheme parameter. It is decoded and returned as a Wide_String - -- value. Note: a convenient form for scheme may be Encoding (UTF_String). - - function Decode - (Item : UTF_8_String) return Wide_String; - -- The input is encoded in UTF-8 and returned as a Wide_String value - - function Decode - (Item : UTF_16_Wide_String) return Wide_String; - -- The input is encoded in UTF-16 and returned as a Wide_String value - -end Ada.Strings.UTF_Encoding.Wide_Strings; diff --git a/gcc/ada/a-suezst.adb b/gcc/ada/a-suezst.adb deleted file mode 100644 index 81d0f67..0000000 --- a/gcc/ada/a-suezst.adb +++ /dev/null @@ -1,429 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_STRINGS -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.UTF_Encoding.Wide_Wide_Strings is - use Interfaces; - - ------------ - -- Decode -- - ------------ - - -- Decode UTF-8/UTF-16BE/UTF-16LE input to Wide_Wide_String - - function Decode - (Item : UTF_String; - Input_Scheme : Encoding_Scheme) return Wide_Wide_String - is - begin - if Input_Scheme = UTF_8 then - return Decode (Item); - else - return Decode (To_UTF_16 (Item, Input_Scheme)); - end if; - end Decode; - - -- Decode UTF-8 input to Wide_Wide_String - - function Decode (Item : UTF_8_String) return Wide_Wide_String is - Result : Wide_Wide_String (1 .. Item'Length); - -- Result string (worst case is same length as input) - - Len : Natural := 0; - -- Length of result stored so far - - Iptr : Natural; - -- Input string pointer - - C : Unsigned_8; - R : Unsigned_32; - - procedure Get_Continuation; - -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6 - -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr - -- is incremented. Raises exception if continuation byte does not exist - -- or is invalid. - - ---------------------- - -- Get_Continuation -- - ---------------------- - - procedure Get_Continuation is - begin - if Iptr > Item'Last then - Raise_Encoding_Error (Iptr - 1); - - else - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - if C not in 2#10_000000# .. 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - else - R := Shift_Left (R, 6) or Unsigned_32 (C and 2#00_111111#); - end if; - end if; - end Get_Continuation; - - -- Start of processing for Decode - - begin - Iptr := Item'First; - - -- Skip BOM at start - - if Item'Length >= 3 - and then Item (Iptr .. Iptr + 2) = BOM_8 - then - Iptr := Iptr + 3; - - -- Error if bad BOM - - elsif Item'Length >= 2 - and then (Item (Iptr .. Iptr + 1) = BOM_16BE - or else - Item (Iptr .. Iptr + 1) = BOM_16LE) - then - Raise_Encoding_Error (Iptr); - end if; - - -- Loop through input characters - - while Iptr <= Item'Last loop - C := To_Unsigned_8 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#00# - 16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - R := Unsigned_32 (C); - - -- No initial code can be of the form 10xxxxxx. Such codes are used - -- only for continuations. - - elsif C <= 2#10_111111# then - Raise_Encoding_Error (Iptr - 1); - - -- Codes in the range 16#80# - 16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 2#110_11111# then - R := Unsigned_32 (C and 2#000_11111#); - Get_Continuation; - - -- Codes in the range 16#800# - 16#FFFF# are represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - elsif C <= 2#1110_1111# then - R := Unsigned_32 (C and 2#0000_1111#); - Get_Continuation; - Get_Continuation; - - -- Codes in the range 16#10000# - 16#10FFFF# are represented as - -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - - elsif C <= 2#11110_111# then - R := Unsigned_32 (C and 2#00000_111#); - Get_Continuation; - Get_Continuation; - Get_Continuation; - - -- Any other code is an error - - else - Raise_Encoding_Error (Iptr - 1); - end if; - - Len := Len + 1; - Result (Len) := Wide_Wide_Character'Val (R); - end loop; - - return Result (1 .. Len); - end Decode; - - -- Decode UTF-16 input to Wide_Wide_String - - function Decode (Item : UTF_16_Wide_String) return Wide_Wide_String is - Result : Wide_Wide_String (1 .. Item'Length); - -- Result cannot be longer than the input string - - Len : Natural := 0; - -- Length of result - - Iptr : Natural; - -- Pointer to next element in Item - - C : Unsigned_16; - R : Unsigned_32; - - begin - -- Skip UTF-16 BOM at start - - Iptr := Item'First; - - if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then - Iptr := Iptr + 1; - end if; - - -- Loop through input characters - - while Iptr <= Item'Last loop - C := To_Unsigned_16 (Item (Iptr)); - Iptr := Iptr + 1; - - -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# - -- represent their own value. - - if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then - Len := Len + 1; - Result (Len) := Wide_Wide_Character'Val (C); - - -- Codes in the range 16#D800#..16#DBFF# represent the first of the - -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". - -- The first surrogate provides 10 high order bits of the result. - - elsif C <= 16#DBFF# then - R := Shift_Left ((Unsigned_32 (C) - 16#D800#), 10); - - -- Error if at end of string - - if Iptr > Item'Last then - Raise_Encoding_Error (Iptr - 1); - - -- Otherwise next character must be valid low order surrogate - -- which provides the low 10 order bits of the result. - - else - C := To_Unsigned_16 (Item (Iptr)); - Iptr := Iptr + 1; - - if C not in 16#DC00# .. 16#DFFF# then - Raise_Encoding_Error (Iptr - 1); - - else - R := R or (Unsigned_32 (C) mod 2 ** 10); - - -- The final adjustment is to add 16#01_0000 to get the - -- result back in the required 21 bit range. - - R := R + 16#01_0000#; - Len := Len + 1; - Result (Len) := Wide_Wide_Character'Val (R); - end if; - end if; - - -- Remaining codes are invalid - - else - Raise_Encoding_Error (Iptr - 1); - end if; - end loop; - - return Result (1 .. Len); - end Decode; - - ------------ - -- Encode -- - ------------ - - -- Encode Wide_Wide_String in UTF-8, UTF-16BE or UTF-16LE - - function Encode - (Item : Wide_Wide_String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String - is - begin - if Output_Scheme = UTF_8 then - return Encode (Item, Output_BOM); - else - return From_UTF_16 (Encode (Item), Output_Scheme, Output_BOM); - end if; - end Encode; - - -- Encode Wide_Wide_String in UTF-8 - - function Encode - (Item : Wide_Wide_String; - Output_BOM : Boolean := False) return UTF_8_String - is - Result : String (1 .. 4 * Item'Length + 3); - -- Worst case is four bytes per input byte + space for BOM - - Len : Natural; - -- Number of output codes stored in Result - - C : Unsigned_32; - -- Single input character - - procedure Store (C : Unsigned_32); - pragma Inline (Store); - -- Store one output code (input is in range 0 .. 255) - - ----------- - -- Store -- - ----------- - - procedure Store (C : Unsigned_32) is - begin - Len := Len + 1; - Result (Len) := Character'Val (C); - end Store; - - -- Start of processing for Encode - - begin - -- Output BOM if required - - if Output_BOM then - Result (1 .. 3) := BOM_8; - Len := 3; - else - Len := 0; - end if; - - -- Loop through characters of input - - for Iptr in Item'Range loop - C := To_Unsigned_32 (Item (Iptr)); - - -- Codes in the range 16#00#..16#7F# are represented as - -- 0xxxxxxx - - if C <= 16#7F# then - Store (C); - - -- Codes in the range 16#80#..16#7FF# are represented as - -- 110yyyxx 10xxxxxx - - elsif C <= 16#7FF# then - Store (2#110_00000# or Shift_Right (C, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - - -- Codes in the range 16#800#..16#D7FF# or 16#E000#..16#FFFD# are - -- represented as - -- 1110yyyy 10yyyyxx 10xxxxxx - - elsif C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then - Store (2#1110_0000# or Shift_Right (C, 12)); - Store (2#10_000000# or - Shift_Right (C and 2#111111_000000#, 6)); - Store (2#10_000000# or (C and 2#00_111111#)); - - -- Codes in the range 16#10000# - 16#10FFFF# are represented as - -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx - - elsif C in 16#1_0000# .. 16#10_FFFF# then - Store (2#11110_000# or - Shift_Right (C, 18)); - Store (2#10_000000# or - Shift_Right (C and 2#111111_000000_000000#, 12)); - Store (2#10_000000# or - Shift_Right (C and 2#111111_000000#, 6)); - Store (2#10_000000# or - (C and 2#00_111111#)); - - -- All other codes are invalid - - else - Raise_Encoding_Error (Iptr); - end if; - end loop; - - return Result (1 .. Len); - end Encode; - - -- Encode Wide_Wide_String in UTF-16 - - function Encode - (Item : Wide_Wide_String; - Output_BOM : Boolean := False) return UTF_16_Wide_String - is - Result : UTF_16_Wide_String (1 .. 2 * Item'Length + 1); - -- Worst case is each input character generates two output characters - -- plus one for possible BOM. - - Len : Integer; - -- Length of output string - - C : Unsigned_32; - - begin - -- Output BOM if needed - - if Output_BOM then - Result (1) := BOM_16 (1); - Len := 1; - else - Len := 0; - end if; - - -- Loop through input characters encoding them - - for Iptr in Item'Range loop - C := To_Unsigned_32 (Item (Iptr)); - - -- Codes in the range 16#00_0000#..16#00_D7FF# or 16#E000#..16#FFFD# - -- are output unchanged - - if C <= 16#00_D7FF# or else C in 16#E000# .. 16#FFFD# then - Len := Len + 1; - Result (Len) := Wide_Character'Val (C); - - -- Codes in the range 16#01_0000#..16#10_FFFF# are output using two - -- surrogate characters. First 16#1_0000# is subtracted from the code - -- point to give a 20-bit value. This is then split into two separate - -- 10-bit values each of which is represented as a surrogate with the - -- most significant half placed in the first surrogate. The ranges of - -- values used for the two surrogates are 16#D800#-16#DBFF# for the - -- first, most significant surrogate and 16#DC00#-16#DFFF# for the - -- second, least significant surrogate. - - elsif C in 16#1_0000# .. 16#10_FFFF# then - C := C - 16#1_0000#; - - Len := Len + 1; - Result (Len) := Wide_Character'Val (16#D800# + C / 2 ** 10); - - Len := Len + 1; - Result (Len) := Wide_Character'Val (16#DC00# + C mod 2 ** 10); - - -- All other codes are invalid - - else - Raise_Encoding_Error (Iptr); - end if; - end loop; - - return Result (1 .. Len); - end Encode; - -end Ada.Strings.UTF_Encoding.Wide_Wide_Strings; diff --git a/gcc/ada/a-suezst.ads b/gcc/ada/a-suezst.ads deleted file mode 100644 index 86d344d..0000000 --- a/gcc/ada/a-suezst.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_STRINGS -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding --- and decoding Wide_String values using UTF encodings. Note: this package is --- consistent with Ada 2005, and may be used in Ada 2005 mode, but cannot be --- used in Ada 95 mode, since Wide_Wide_Character is an Ada 2005 feature. - -package Ada.Strings.UTF_Encoding.Wide_Wide_Strings is - pragma Pure (Wide_Wide_Strings); - - -- The encoding routines take a Wide_Wide_String as input and encode the - -- result using the specified UTF encoding method. The result includes a - -- BOM if the Output_BOM parameter is set to True. - - function Encode - (Item : Wide_Wide_String; - Output_Scheme : Encoding_Scheme; - Output_BOM : Boolean := False) return UTF_String; - -- Encode Wide_Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as - -- specified by the Output_Scheme parameter. - - function Encode - (Item : Wide_Wide_String; - Output_BOM : Boolean := False) return UTF_8_String; - -- Encode Wide_Wide_String using UTF-8 encoding - - function Encode - (Item : Wide_Wide_String; - Output_BOM : Boolean := False) return UTF_16_Wide_String; - -- Encode Wide_Wide_String using UTF_16 encoding - - -- The decoding routines take a UTF String as input, and return a decoded - -- Wide_String. If the UTF String starts with a BOM that matches the - -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. - - function Decode - (Item : UTF_String; - Input_Scheme : Encoding_Scheme) return Wide_Wide_String; - -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the - -- Input_Scheme parameter. It is decoded and returned as a Wide_Wide_String - -- value. Note: a convenient form for Scheme may be Encoding (UTF_String). - - function Decode - (Item : UTF_8_String) return Wide_Wide_String; - -- The input is encoded in UTF-8 and returned as a Wide_Wide_String value - - function Decode - (Item : UTF_16_Wide_String) return Wide_Wide_String; - -- The input is encoded in UTF-16 and returned as a Wide_String value - -end Ada.Strings.UTF_Encoding.Wide_Wide_Strings; diff --git a/gcc/ada/a-suhcin.adb b/gcc/ada/a-suhcin.adb deleted file mode 100644 index 0417c15..0000000 --- a/gcc/ada/a-suhcin.adb +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Unbounded.Aux; -with Ada.Strings.Hash_Case_Insensitive; - -function Ada.Strings.Unbounded.Hash_Case_Insensitive - (Key : Unbounded.Unbounded_String) - return Containers.Hash_Type -is - S : Aux.Big_String_Access; - L : Natural; - -begin - Aux.Get_String (Key, S, L); - return Ada.Strings.Hash_Case_Insensitive (S (1 .. L)); -end Ada.Strings.Unbounded.Hash_Case_Insensitive; diff --git a/gcc/ada/a-suhcin.ads b/gcc/ada/a-suhcin.ads deleted file mode 100644 index 180d4a4..0000000 --- a/gcc/ada/a-suhcin.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -function Ada.Strings.Unbounded.Hash_Case_Insensitive - (Key : Unbounded.Unbounded_String) - return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Unbounded.Hash_Case_Insensitive); diff --git a/gcc/ada/a-sulcin.adb b/gcc/ada/a-sulcin.adb deleted file mode 100644 index 9f1f3c4..0000000 --- a/gcc/ada/a-sulcin.adb +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with Ada.Strings.Unbounded.Aux; -with Ada.Strings.Less_Case_Insensitive; - -function Ada.Strings.Unbounded.Less_Case_Insensitive - (Left, Right : Unbounded.Unbounded_String) - return Boolean -is - SL, SR : Aux.Big_String_Access; - LL, LR : Natural; - -begin - Aux.Get_String (Left, SL, LL); - Aux.Get_String (Right, SR, LR); - - return Ada.Strings.Less_Case_Insensitive - (Left => SL (1 .. LL), - Right => SR (1 .. LR)); -end Ada.Strings.Unbounded.Less_Case_Insensitive; diff --git a/gcc/ada/a-sulcin.ads b/gcc/ada/a-sulcin.ads deleted file mode 100644 index fafb546..0000000 --- a/gcc/ada/a-sulcin.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -function Ada.Strings.Unbounded.Less_Case_Insensitive - (Left, Right : Unbounded.Unbounded_String) - return Boolean; - -pragma Preelaborate (Ada.Strings.Unbounded.Less_Case_Insensitive); diff --git a/gcc/ada/a-suteio-shared.adb b/gcc/ada/a-suteio-shared.adb deleted file mode 100644 index d50ed77..0000000 --- a/gcc/ada/a-suteio-shared.adb +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; use Ada.Text_IO; - -package body Ada.Strings.Unbounded.Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_String is - Buffer : String (1 .. 1000); - Last : Natural; - Result : Unbounded_String; - - begin - Get_Line (Buffer, Last); - Set_Unbounded_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is - Buffer : String (1 .. 1000); - Last : Natural; - Result : Unbounded_String; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Text_IO.File_Type; - Item : out Unbounded_String) - is - Buffer : String (1 .. 1000); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_String (Item, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Item, Buffer (1 .. Last)); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put (UR.Data (1 .. UR.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put (File, UR.Data (1 .. UR.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put_Line (UR.Data (1 .. UR.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_String) is - UR : constant Shared_String_Access := U.Reference; - - begin - Put_Line (File, UR.Data (1 .. UR.Last)); - end Put_Line; - -end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/a-suteio.adb b/gcc/ada/a-suteio.adb deleted file mode 100644 index 0a67067..0000000 --- a/gcc/ada/a-suteio.adb +++ /dev/null @@ -1,159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; use Ada.Text_IO; - -package body Ada.Strings.Unbounded.Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_String is - Buffer : String (1 .. 1000); - Last : Natural; - Str1 : String_Access; - Str2 : String_Access; - Result : Unbounded_String; - - begin - Get_Line (Buffer, Last); - Str1 := new String'(Buffer (1 .. Last)); - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Str2 := new String (1 .. Str1'Last + Last); - Str2 (Str1'Range) := Str1.all; - Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); - Free (Str1); - Str1 := Str2; - end loop; - - Result.Reference := Str1; - Result.Last := Str1'Length; - return Result; - end Get_Line; - - function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is - Buffer : String (1 .. 1000); - Last : Natural; - Str1 : String_Access; - Str2 : String_Access; - Result : Unbounded_String; - - begin - Get_Line (File, Buffer, Last); - Str1 := new String'(Buffer (1 .. Last)); - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Str2 := new String (1 .. Str1'Last + Last); - Str2 (Str1'Range) := Str1.all; - Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); - Free (Str1); - Str1 := Str2; - end loop; - - Result.Reference := Str1; - Result.Last := Str1'Length; - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Text_IO.File_Type; - Item : out Unbounded_String) - is - begin - -- We are going to read into the string that is already there and - -- allocated. Hopefully it is big enough now, if not, we will extend - -- it in the usual manner using Realloc_For_Chunk. - - -- Make sure we start with at least 80 characters - - if Item.Reference'Last < 80 then - Realloc_For_Chunk (Item, 80); - end if; - - -- Loop to read data, filling current string as far as possible. - -- Item.Last holds the number of characters read so far. - - Item.Last := 0; - loop - Get_Line - (File, - Item.Reference (Item.Last + 1 .. Item.Reference'Last), - Item.Last); - - -- If we hit the end of the line before the end of the buffer, then - -- we are all done, and the result length is properly set. - - if Item.Last < Item.Reference'Last then - return; - end if; - - -- If not enough room, double it and keep reading - - Realloc_For_Chunk (Item, Item.Last); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_String) is - begin - Put (U.Reference (1 .. U.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_String) is - begin - Put (File, U.Reference (1 .. U.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_String) is - begin - Put_Line (U.Reference (1 .. U.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_String) is - begin - Put_Line (File, U.Reference (1 .. U.Last)); - end Put_Line; - -end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/a-suteio.ads b/gcc/ada/a-suteio.ads deleted file mode 100644 index 2b48407..0000000 --- a/gcc/ada/a-suteio.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This child package of Ada.Strings.Unbounded provides some specialized --- Text_IO routines that work directly with unbounded strings, avoiding the --- inefficiencies of access via the standard interface, and also taking --- direct advantage of the variable length semantics of these strings. - -with Ada.Text_IO; - -package Ada.Strings.Unbounded.Text_IO is - - function Get_Line return Unbounded_String; - function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String; - -- Reads up to the end of the current line, returning the result - -- as an unbounded string of appropriate length. If no File parameter - -- is present, input is from Current_Input. - - procedure Get_Line - (File : Ada.Text_IO.File_Type; - Item : out Unbounded_String); - procedure Get_Line (Item : out Unbounded_String); - -- Similar to the above, but in procedure form with an out parameter - - procedure Put (U : Unbounded_String); - procedure Put (File : Ada.Text_IO.File_Type; U : Unbounded_String); - procedure Put_Line (U : Unbounded_String); - procedure Put_Line (File : Ada.Text_IO.File_Type; U : Unbounded_String); - -- These are equivalent to the standard Text_IO routines passed the - -- value To_String (U), but operate more efficiently, because the extra - -- copy of the argument is avoided. - -end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/a-swbwha.adb b/gcc/ada/a-swbwha.adb deleted file mode 100644 index 643b5b0..0000000 --- a/gcc/ada/a-swbwha.adb +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ B O U N D E D . W I D E _ H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Wide_Bounded.Wide_Hash - (Key : Bounded.Bounded_Wide_String) - return Containers.Hash_Type -is - use Ada.Containers; - function Hash is new System.String_Hash.Hash - (Wide_Character, Wide_String, Hash_Type); -begin - return Hash (Bounded.To_Wide_String (Key)); -end Ada.Strings.Wide_Bounded.Wide_Hash; diff --git a/gcc/ada/a-swbwha.ads b/gcc/ada/a-swbwha.ads deleted file mode 100644 index 6a4fba7..0000000 --- a/gcc/ada/a-swbwha.ads +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ B O U N D E D . W I D E _ H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -generic - with package Bounded is - new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (<>); - -function Ada.Strings.Wide_Bounded.Wide_Hash (Key : Bounded.Bounded_Wide_String) - return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Wide_Bounded.Wide_Hash); diff --git a/gcc/ada/a-swfwha.ads b/gcc/ada/a-swfwha.ads deleted file mode 100644 index c42d54c..0000000 --- a/gcc/ada/a-swfwha.ads +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ F I X E D . W I D E _ H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers, Ada.Strings.Wide_Hash; - -function Ada.Strings.Wide_Fixed.Wide_Hash - (Key : Wide_String) return Containers.Hash_Type - renames Ada.Strings.Wide_Hash; - -pragma Pure (Ada.Strings.Wide_Fixed.Wide_Hash); diff --git a/gcc/ada/a-swmwco.ads b/gcc/ada/a-swmwco.ads deleted file mode 100644 index af46e34..0000000 --- a/gcc/ada/a-swmwco.ads +++ /dev/null @@ -1,450 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ M A P S . W I D E _ C O N S T A N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Wide_Latin_1; - -package Ada.Strings.Wide_Maps.Wide_Constants is - pragma Preelaborate; - - Control_Set : constant Wide_Maps.Wide_Character_Set; - Graphic_Set : constant Wide_Maps.Wide_Character_Set; - Letter_Set : constant Wide_Maps.Wide_Character_Set; - Lower_Set : constant Wide_Maps.Wide_Character_Set; - Upper_Set : constant Wide_Maps.Wide_Character_Set; - Basic_Set : constant Wide_Maps.Wide_Character_Set; - Decimal_Digit_Set : constant Wide_Maps.Wide_Character_Set; - Hexadecimal_Digit_Set : constant Wide_Maps.Wide_Character_Set; - Alphanumeric_Set : constant Wide_Maps.Wide_Character_Set; - Special_Graphic_Set : constant Wide_Maps.Wide_Character_Set; - ISO_646_Set : constant Wide_Maps.Wide_Character_Set; - Character_Set : constant Wide_Maps.Wide_Character_Set; - - Lower_Case_Map : constant Wide_Maps.Wide_Character_Mapping; - -- Maps to lower case for letters, else identity - - Upper_Case_Map : constant Wide_Maps.Wide_Character_Mapping; - -- Maps to upper case for letters, else identity - - Basic_Map : constant Wide_Maps.Wide_Character_Mapping; - -- Maps to basic letter for letters, else identity - -private - package W renames Ada.Characters.Wide_Latin_1; - - subtype WC is Wide_Character; - - Control_Ranges : aliased constant Wide_Character_Ranges := - ((W.NUL, W.US), - (W.DEL, W.APC)); - - Control_Set : constant Wide_Character_Set := - (AF.Controlled with - Control_Ranges'Unrestricted_Access); - - Graphic_Ranges : aliased constant Wide_Character_Ranges := - ((W.Space, W.Tilde), - (WC'Val (256), WC'Last)); - - Graphic_Set : constant Wide_Character_Set := - (AF.Controlled with - Graphic_Ranges'Unrestricted_Access); - - Letter_Ranges : aliased constant Wide_Character_Ranges := - (('A', 'Z'), - (W.LC_A, W.LC_Z), - (W.UC_A_Grave, W.UC_O_Diaeresis), - (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), - (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); - - Letter_Set : constant Wide_Character_Set := - (AF.Controlled with - Letter_Ranges'Unrestricted_Access); - - Lower_Ranges : aliased constant Wide_Character_Ranges := - (1 => (W.LC_A, W.LC_Z), - 2 => (W.LC_German_Sharp_S, W.LC_O_Diaeresis), - 3 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); - - Lower_Set : constant Wide_Character_Set := - (AF.Controlled with - Lower_Ranges'Unrestricted_Access); - - Upper_Ranges : aliased constant Wide_Character_Ranges := - (1 => ('A', 'Z'), - 2 => (W.UC_A_Grave, W.UC_O_Diaeresis), - 3 => (W.UC_O_Oblique_Stroke, W.UC_Icelandic_Thorn)); - - Upper_Set : constant Wide_Character_Set := - (AF.Controlled with - Upper_Ranges'Unrestricted_Access); - - Basic_Ranges : aliased constant Wide_Character_Ranges := - (1 => ('A', 'Z'), - 2 => (W.LC_A, W.LC_Z), - 3 => (W.UC_AE_Diphthong, W.UC_AE_Diphthong), - 4 => (W.LC_AE_Diphthong, W.LC_AE_Diphthong), - 5 => (W.LC_German_Sharp_S, W.LC_German_Sharp_S), - 6 => (W.UC_Icelandic_Thorn, W.UC_Icelandic_Thorn), - 7 => (W.LC_Icelandic_Thorn, W.LC_Icelandic_Thorn), - 8 => (W.UC_Icelandic_Eth, W.UC_Icelandic_Eth), - 9 => (W.LC_Icelandic_Eth, W.LC_Icelandic_Eth)); - - Basic_Set : constant Wide_Character_Set := - (AF.Controlled with - Basic_Ranges'Unrestricted_Access); - - Decimal_Digit_Ranges : aliased constant Wide_Character_Ranges := - (1 => ('0', '9')); - - Decimal_Digit_Set : constant Wide_Character_Set := - (AF.Controlled with - Decimal_Digit_Ranges'Unrestricted_Access); - - Hexadecimal_Digit_Ranges : aliased constant Wide_Character_Ranges := - (1 => ('0', '9'), - 2 => ('A', 'F'), - 3 => (W.LC_A, W.LC_F)); - - Hexadecimal_Digit_Set : constant Wide_Character_Set := - (AF.Controlled with - Hexadecimal_Digit_Ranges'Unrestricted_Access); - - Alphanumeric_Ranges : aliased constant Wide_Character_Ranges := - (1 => ('0', '9'), - 2 => ('A', 'Z'), - 3 => (W.LC_A, W.LC_Z), - 4 => (W.UC_A_Grave, W.UC_O_Diaeresis), - 5 => (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), - 6 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); - - Alphanumeric_Set : constant Wide_Character_Set := - (AF.Controlled with - Alphanumeric_Ranges'Unrestricted_Access); - - Special_Graphic_Ranges : aliased constant Wide_Character_Ranges := - (1 => (Wide_Space, W.Solidus), - 2 => (W.Colon, W.Commercial_At), - 3 => (W.Left_Square_Bracket, W.Grave), - 4 => (W.Left_Curly_Bracket, W.Tilde), - 5 => (W.No_Break_Space, W.Inverted_Question), - 6 => (W.Multiplication_Sign, W.Multiplication_Sign), - 7 => (W.Division_Sign, W.Division_Sign)); - - Special_Graphic_Set : constant Wide_Character_Set := - (AF.Controlled with - Special_Graphic_Ranges'Unrestricted_Access); - - ISO_646_Ranges : aliased constant Wide_Character_Ranges := - (1 => (W.NUL, W.DEL)); - - ISO_646_Set : constant Wide_Character_Set := - (AF.Controlled with - ISO_646_Ranges'Unrestricted_Access); - - Character_Ranges : aliased constant Wide_Character_Ranges := - (1 => (W.NUL, WC'Val (255))); - - Character_Set : constant Wide_Character_Set := - (AF.Controlled with - Character_Ranges'Unrestricted_Access); - - Lower_Case_Mapping : aliased constant Wide_Character_Mapping_Values := - (Length => 56, - - Domain => - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & - W.UC_A_Grave & - W.UC_A_Acute & - W.UC_A_Circumflex & - W.UC_A_Tilde & - W.UC_A_Diaeresis & - W.UC_A_Ring & - W.UC_AE_Diphthong & - W.UC_C_Cedilla & - W.UC_E_Grave & - W.UC_E_Acute & - W.UC_E_Circumflex & - W.UC_E_Diaeresis & - W.UC_I_Grave & - W.UC_I_Acute & - W.UC_I_Circumflex & - W.UC_I_Diaeresis & - W.UC_Icelandic_Eth & - W.UC_N_Tilde & - W.UC_O_Grave & - W.UC_O_Acute & - W.UC_O_Circumflex & - W.UC_O_Tilde & - W.UC_O_Diaeresis & - W.UC_O_Oblique_Stroke & - W.UC_U_Grave & - W.UC_U_Acute & - W.UC_U_Circumflex & - W.UC_U_Diaeresis & - W.UC_Y_Acute & - W.UC_Icelandic_Thorn, - - Rangev => - "abcdefghijklmnopqrstuvwxyz" & - W.LC_A_Grave & - W.LC_A_Acute & - W.LC_A_Circumflex & - W.LC_A_Tilde & - W.LC_A_Diaeresis & - W.LC_A_Ring & - W.LC_AE_Diphthong & - W.LC_C_Cedilla & - W.LC_E_Grave & - W.LC_E_Acute & - W.LC_E_Circumflex & - W.LC_E_Diaeresis & - W.LC_I_Grave & - W.LC_I_Acute & - W.LC_I_Circumflex & - W.LC_I_Diaeresis & - W.LC_Icelandic_Eth & - W.LC_N_Tilde & - W.LC_O_Grave & - W.LC_O_Acute & - W.LC_O_Circumflex & - W.LC_O_Tilde & - W.LC_O_Diaeresis & - W.LC_O_Oblique_Stroke & - W.LC_U_Grave & - W.LC_U_Acute & - W.LC_U_Circumflex & - W.LC_U_Diaeresis & - W.LC_Y_Acute & - W.LC_Icelandic_Thorn); - - Lower_Case_Map : constant Wide_Character_Mapping := - (AF.Controlled with - Map => Lower_Case_Mapping'Unrestricted_Access); - - Upper_Case_Mapping : aliased constant Wide_Character_Mapping_Values := - (Length => 56, - - Domain => - "abcdefghijklmnopqrstuvwxyz" & - W.LC_A_Grave & - W.LC_A_Acute & - W.LC_A_Circumflex & - W.LC_A_Tilde & - W.LC_A_Diaeresis & - W.LC_A_Ring & - W.LC_AE_Diphthong & - W.LC_C_Cedilla & - W.LC_E_Grave & - W.LC_E_Acute & - W.LC_E_Circumflex & - W.LC_E_Diaeresis & - W.LC_I_Grave & - W.LC_I_Acute & - W.LC_I_Circumflex & - W.LC_I_Diaeresis & - W.LC_Icelandic_Eth & - W.LC_N_Tilde & - W.LC_O_Grave & - W.LC_O_Acute & - W.LC_O_Circumflex & - W.LC_O_Tilde & - W.LC_O_Diaeresis & - W.LC_O_Oblique_Stroke & - W.LC_U_Grave & - W.LC_U_Acute & - W.LC_U_Circumflex & - W.LC_U_Diaeresis & - W.LC_Y_Acute & - W.LC_Icelandic_Thorn, - - Rangev => - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & - W.UC_A_Grave & - W.UC_A_Acute & - W.UC_A_Circumflex & - W.UC_A_Tilde & - W.UC_A_Diaeresis & - W.UC_A_Ring & - W.UC_AE_Diphthong & - W.UC_C_Cedilla & - W.UC_E_Grave & - W.UC_E_Acute & - W.UC_E_Circumflex & - W.UC_E_Diaeresis & - W.UC_I_Grave & - W.UC_I_Acute & - W.UC_I_Circumflex & - W.UC_I_Diaeresis & - W.UC_Icelandic_Eth & - W.UC_N_Tilde & - W.UC_O_Grave & - W.UC_O_Acute & - W.UC_O_Circumflex & - W.UC_O_Tilde & - W.UC_O_Diaeresis & - W.UC_O_Oblique_Stroke & - W.UC_U_Grave & - W.UC_U_Acute & - W.UC_U_Circumflex & - W.UC_U_Diaeresis & - W.UC_Y_Acute & - W.UC_Icelandic_Thorn); - - Upper_Case_Map : constant Wide_Character_Mapping := - (AF.Controlled with - Upper_Case_Mapping'Unrestricted_Access); - - Basic_Mapping : aliased constant Wide_Character_Mapping_Values := - (Length => 55, - - Domain => - W.UC_A_Grave & - W.UC_A_Acute & - W.UC_A_Circumflex & - W.UC_A_Tilde & - W.UC_A_Diaeresis & - W.UC_A_Ring & - W.UC_C_Cedilla & - W.UC_E_Grave & - W.UC_E_Acute & - W.UC_E_Circumflex & - W.UC_E_Diaeresis & - W.UC_I_Grave & - W.UC_I_Acute & - W.UC_I_Circumflex & - W.UC_I_Diaeresis & - W.UC_N_Tilde & - W.UC_O_Grave & - W.UC_O_Acute & - W.UC_O_Circumflex & - W.UC_O_Tilde & - W.UC_O_Diaeresis & - W.UC_O_Oblique_Stroke & - W.UC_U_Grave & - W.UC_U_Acute & - W.UC_U_Circumflex & - W.UC_U_Diaeresis & - W.UC_Y_Acute & - W.LC_A_Grave & - W.LC_A_Acute & - W.LC_A_Circumflex & - W.LC_A_Tilde & - W.LC_A_Diaeresis & - W.LC_A_Ring & - W.LC_C_Cedilla & - W.LC_E_Grave & - W.LC_E_Acute & - W.LC_E_Circumflex & - W.LC_E_Diaeresis & - W.LC_I_Grave & - W.LC_I_Acute & - W.LC_I_Circumflex & - W.LC_I_Diaeresis & - W.LC_N_Tilde & - W.LC_O_Grave & - W.LC_O_Acute & - W.LC_O_Circumflex & - W.LC_O_Tilde & - W.LC_O_Diaeresis & - W.LC_O_Oblique_Stroke & - W.LC_U_Grave & - W.LC_U_Acute & - W.LC_U_Circumflex & - W.LC_U_Diaeresis & - W.LC_Y_Acute & - W.LC_Y_Diaeresis, - - Rangev => - 'A' & -- UC_A_Grave - 'A' & -- UC_A_Acute - 'A' & -- UC_A_Circumflex - 'A' & -- UC_A_Tilde - 'A' & -- UC_A_Diaeresis - 'A' & -- UC_A_Ring - 'C' & -- UC_C_Cedilla - 'E' & -- UC_E_Grave - 'E' & -- UC_E_Acute - 'E' & -- UC_E_Circumflex - 'E' & -- UC_E_Diaeresis - 'I' & -- UC_I_Grave - 'I' & -- UC_I_Acute - 'I' & -- UC_I_Circumflex - 'I' & -- UC_I_Diaeresis - 'N' & -- UC_N_Tilde - 'O' & -- UC_O_Grave - 'O' & -- UC_O_Acute - 'O' & -- UC_O_Circumflex - 'O' & -- UC_O_Tilde - 'O' & -- UC_O_Diaeresis - 'O' & -- UC_O_Oblique_Stroke - 'U' & -- UC_U_Grave - 'U' & -- UC_U_Acute - 'U' & -- UC_U_Circumflex - 'U' & -- UC_U_Diaeresis - 'Y' & -- UC_Y_Acute - 'a' & -- LC_A_Grave - 'a' & -- LC_A_Acute - 'a' & -- LC_A_Circumflex - 'a' & -- LC_A_Tilde - 'a' & -- LC_A_Diaeresis - 'a' & -- LC_A_Ring - 'c' & -- LC_C_Cedilla - 'e' & -- LC_E_Grave - 'e' & -- LC_E_Acute - 'e' & -- LC_E_Circumflex - 'e' & -- LC_E_Diaeresis - 'i' & -- LC_I_Grave - 'i' & -- LC_I_Acute - 'i' & -- LC_I_Circumflex - 'i' & -- LC_I_Diaeresis - 'n' & -- LC_N_Tilde - 'o' & -- LC_O_Grave - 'o' & -- LC_O_Acute - 'o' & -- LC_O_Circumflex - 'o' & -- LC_O_Tilde - 'o' & -- LC_O_Diaeresis - 'o' & -- LC_O_Oblique_Stroke - 'u' & -- LC_U_Grave - 'u' & -- LC_U_Acute - 'u' & -- LC_U_Circumflex - 'u' & -- LC_U_Diaeresis - 'y' & -- LC_Y_Acute - 'y'); -- LC_Y_Diaeresis - - Basic_Map : constant Wide_Character_Mapping := - (AF.Controlled with - Basic_Mapping'Unrestricted_Access); - -end Ada.Strings.Wide_Maps.Wide_Constants; diff --git a/gcc/ada/a-swunau-shared.adb b/gcc/ada/a-swunau-shared.adb deleted file mode 100644 index ad397b8..0000000 --- a/gcc/ada/a-swunau-shared.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Unbounded.Aux is - - --------------------- - -- Get_Wide_String -- - --------------------- - - procedure Get_Wide_String - (U : Unbounded_Wide_String; - S : out Big_Wide_String_Access; - L : out Natural) - is - X : aliased Big_Wide_String; - for X'Address use U.Reference.Data'Address; - begin - S := X'Unchecked_Access; - L := U.Reference.Last; - end Get_Wide_String; - - --------------------- - -- Set_Wide_String -- - --------------------- - - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; - S : Wide_String_Access) - is - X : Wide_String_Access := S; - - begin - Set_Unbounded_Wide_String (UP, S.all); - Free (X); - end Set_Wide_String; - -end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swunau.adb b/gcc/ada/a-swunau.adb deleted file mode 100644 index 004a5d4..0000000 --- a/gcc/ada/a-swunau.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Unbounded.Aux is - - -------------------- - -- Get_Wide_String -- - --------------------- - - procedure Get_Wide_String - (U : Unbounded_Wide_String; - S : out Big_Wide_String_Access; - L : out Natural) - is - X : aliased Big_Wide_String; - for X'Address use U.Reference.all'Address; - - begin - S := X'Unchecked_Access; - L := U.Last; - end Get_Wide_String; - - --------------------- - -- Set_Wide_String -- - --------------------- - - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; - S : Wide_String_Access) - is - begin - Finalize (UP); - UP.Reference := S; - UP.Last := UP.Reference'Length; - end Set_Wide_String; - -end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swunau.ads b/gcc/ada/a-swunau.ads deleted file mode 100644 index 78fa5db..0000000 --- a/gcc/ada/a-swunau.ads +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This child package of Ada.Strings.Wide_Unbounded provides some specialized --- access functions which are intended to allow more efficient use of the --- facilities of Ada.Strings.Wide_Unbounded, particularly by other layered --- utilities. - -package Ada.Strings.Wide_Unbounded.Aux is - pragma Preelaborate; - - subtype Big_Wide_String is Wide_String (Positive'Range); - type Big_Wide_String_Access is access all Big_Wide_String; - - procedure Get_Wide_String - (U : Unbounded_Wide_String; - S : out Big_Wide_String_Access; - L : out Natural); - pragma Inline (Get_Wide_String); - -- This procedure returns the internal string pointer used in the - -- representation of an unbounded string as well as the actual current - -- length (which may be less than S.all'Length because in general there - -- can be extra space assigned). The characters of this string may be - -- not be modified via the returned pointer, and are valid only as - -- long as the original unbounded string is not accessed or modified. - -- - -- This procedure is much more efficient than the use of To_Wide_String - -- since it avoids the need to copy the string. The lower bound of the - -- referenced string returned by this call is always one, so the actual - -- string data is always accessible as S (1 .. L). - - procedure Set_Wide_String (UP : out Unbounded_Wide_String; S : Wide_String) - renames Set_Unbounded_Wide_String; - -- This function sets the string contents of the referenced unbounded - -- string to the given string value. It is significantly more efficient - -- than the use of To_Unbounded_Wide_String with an assignment, since it - -- avoids the necessity of messing with finalization chains. The lower - -- bound of the string S is not required to be one. - - procedure Set_Wide_String - (UP : in out Unbounded_Wide_String; - S : Wide_String_Access); - pragma Inline (Set_Wide_String); - -- This version of Set_Wide_String takes a string access value, rather - -- than string. The lower bound of the string value is required to be one, - -- and this requirement is not checked. - -end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/a-swuwha.adb b/gcc/ada/a-swuwha.adb deleted file mode 100644 index e367447..0000000 --- a/gcc/ada/a-swuwha.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Wide_Unbounded.Wide_Hash - (Key : Unbounded_Wide_String) return Containers.Hash_Type -is - use Ada.Containers; - function Hash is new System.String_Hash.Hash - (Wide_Character, Wide_String, Hash_Type); -begin - return Hash (To_Wide_String (Key)); -end Ada.Strings.Wide_Unbounded.Wide_Hash; diff --git a/gcc/ada/a-swuwha.ads b/gcc/ada/a-swuwha.ads deleted file mode 100644 index 8da567a..0000000 --- a/gcc/ada/a-swuwha.ads +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Is this really an RM unit? Doc needed ??? - -with Ada.Containers; - -function Ada.Strings.Wide_Unbounded.Wide_Hash - (Key : Unbounded_Wide_String) return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Wide_Unbounded.Wide_Hash); diff --git a/gcc/ada/a-swuwti-shared.adb b/gcc/ada/a-swuwti-shared.adb deleted file mode 100644 index 9cf7c0a..0000000 --- a/gcc/ada/a-swuwti-shared.adb +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; - -package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_Wide_String is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_String; - - begin - Get_Line (Buffer, Last); - Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - function Get_Line - (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String - is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_String; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_Wide_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_String) - is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_String (Item, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Item, Buffer (1 .. Last)); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put (UR.Data (1 .. UR.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put (File, UR.Data (1 .. UR.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put_Line (UR.Data (1 .. UR.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is - UR : constant Shared_Wide_String_Access := U.Reference; - - begin - Put_Line (File, UR.Data (1 .. UR.Last)); - end Put_Line; - -end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/a-swuwti.adb b/gcc/ada/a-swuwti.adb deleted file mode 100644 index 65f26cd..0000000 --- a/gcc/ada/a-swuwti.adb +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; - -package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_Wide_String is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_String_Access; - Str2 : Wide_String_Access; - Result : Unbounded_Wide_String; - - begin - Get_Line (Buffer, Last); - Str1 := new Wide_String'(Buffer (1 .. Last)); - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Str2 := new Wide_String (1 .. Str1'Last + Last); - Str2 (Str1'Range) := Str1.all; - Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); - Free (Str1); - Str1 := Str2; - end loop; - - Result.Reference := Str1; - Result.Last := Str1'Length; - return Result; - end Get_Line; - - function Get_Line - (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String - is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_String_Access; - Str2 : Wide_String_Access; - Result : Unbounded_Wide_String; - - begin - Get_Line (File, Buffer, Last); - Str1 := new Wide_String'(Buffer (1 .. Last)); - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Str2 := new Wide_String (1 .. Str1'Last + Last); - Str2 (Str1'Range) := Str1.all; - Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); - Free (Str1); - Str1 := Str2; - end loop; - - Result.Reference := Str1; - Result.Last := Str1'Length; - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_Wide_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_String) - is - begin - -- We are going to read into the string that is already there and - -- allocated. Hopefully it is big enough now, if not, we will extend - -- it in the usual manner using Realloc_For_Chunk. - - -- Make sure we start with at least 80 characters - - if Item.Reference'Last < 80 then - Realloc_For_Chunk (Item, 80); - end if; - - -- Loop to read data, filling current string as far as possible. - -- Item.Last holds the number of characters read so far. - - Item.Last := 0; - loop - Get_Line - (File, - Item.Reference (Item.Last + 1 .. Item.Reference'Last), - Item.Last); - - -- If we hit the end of the line before the end of the buffer, then - -- we are all done, and the result length is properly set. - - if Item.Last < Item.Reference'Last then - return; - end if; - - -- If not enough room, double it and keep reading - - Realloc_For_Chunk (Item, Item.Last); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_Wide_String) is - begin - Put (U.Reference (1 .. U.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_Wide_String) is - begin - Put (File, U.Reference (1 .. U.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_Wide_String) is - begin - Put_Line (U.Reference (1 .. U.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is - begin - Put_Line (File, U.Reference (1 .. U.Last)); - end Put_Line; - -end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/a-swuwti.ads b/gcc/ada/a-swuwti.ads deleted file mode 100644 index a3b742e..0000000 --- a/gcc/ada/a-swuwti.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This child package of Ada.Strings.Wide_Unbounded provides specialized --- Wide_Text_IO routines that work directly with unbounded wide strings, --- avoiding the inefficiencies of access via the standard interface, and also --- taking direct advantage of the variable length semantics of these strings. - -with Ada.Wide_Text_IO; - -package Ada.Strings.Wide_Unbounded.Wide_Text_IO is - - function Get_Line - return Unbounded_Wide_String; - function Get_Line - (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String; - -- Reads up to the end of the current line, returning the result - -- as an unbounded string of appropriate length. If no File parameter - -- is present, input is from Current_Input. - - procedure Get_Line - (File : Ada.Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_String); - procedure Get_Line (Item : out Unbounded_Wide_String); - -- Similar to the above, but in procedure form with an out parameter - - procedure Put - (U : Unbounded_Wide_String); - procedure Put - (File : Ada.Wide_Text_IO.File_Type; - U : Unbounded_Wide_String); - procedure Put_Line - (U : Unbounded_Wide_String); - procedure Put_Line - (File : Ada.Wide_Text_IO.File_Type; - U : Unbounded_Wide_String); - -- These are equivalent to the standard Wide_Text_IO routines passed the - -- value To_Wide_String (U), but operate more efficiently, because the - -- extra copy of the argument is avoided. - -end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/a-szbzha.adb b/gcc/ada/a-szbzha.adb deleted file mode 100644 index 9ee1e91..0000000 --- a/gcc/ada/a-szbzha.adb +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_WIDE_BOUNDED.WIDE_WIDE_HASH -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash - (Key : Bounded.Bounded_Wide_Wide_String) - return Containers.Hash_Type -is - use Ada.Containers; - function Hash is new System.String_Hash.Hash - (Wide_Wide_Character, Wide_Wide_String, Hash_Type); -begin - return Hash (Bounded.To_Wide_Wide_String (Key)); -end Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash; diff --git a/gcc/ada/a-szbzha.ads b/gcc/ada/a-szbzha.ads deleted file mode 100644 index d7911de..0000000 --- a/gcc/ada/a-szbzha.ads +++ /dev/null @@ -1,28 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_WIDE_BOUNDED.WIDE_WIDE_HASH -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Is this really an RM unit? doc needed ??? - -with Ada.Containers; - -generic - with package Bounded is - new Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length (<>); - -function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash - (Key : Bounded.Bounded_Wide_Wide_String) - return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash); diff --git a/gcc/ada/a-szfzha.ads b/gcc/ada/a-szfzha.ads deleted file mode 100644 index 5deb5d7..0000000 --- a/gcc/ada/a-szfzha.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D . -- --- W I D E _ W I D E _ H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers; -with Ada.Strings.Wide_Wide_Hash; - -function Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash - (Key : Wide_Wide_String) return Containers.Hash_Type - renames Ada.Strings.Wide_Wide_Hash; - -pragma Pure (Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash); diff --git a/gcc/ada/a-szmzco.ads b/gcc/ada/a-szmzco.ads deleted file mode 100644 index 6fbb7bf..0000000 --- a/gcc/ada/a-szmzco.ads +++ /dev/null @@ -1,450 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_WIDE_MAPS.WIDE_WIDE_CONSTANTS -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Wide_Wide_Latin_1; - -package Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants is - pragma Preelaborate; - - Control_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Letter_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Lower_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Upper_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Basic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Decimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Hexadecimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Alphanumeric_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Special_Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - ISO_646_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - Character_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; - - Lower_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; - -- Maps to lower case for letters, else identity - - Upper_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; - -- Maps to upper case for letters, else identity - - Basic_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; - -- Maps to basic letter for letters, else identity - -private - package W renames Ada.Characters.Wide_Wide_Latin_1; - - subtype WC is Wide_Wide_Character; - - Control_Ranges : aliased constant Wide_Wide_Character_Ranges := - ((W.NUL, W.US), - (W.DEL, W.APC)); - - Control_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Control_Ranges'Unrestricted_Access); - - Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges := - ((W.Space, W.Tilde), - (WC'Val (256), WC'Last)); - - Graphic_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Graphic_Ranges'Unrestricted_Access); - - Letter_Ranges : aliased constant Wide_Wide_Character_Ranges := - (('A', 'Z'), - (W.LC_A, W.LC_Z), - (W.UC_A_Grave, W.UC_O_Diaeresis), - (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), - (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); - - Letter_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Letter_Ranges'Unrestricted_Access); - - Lower_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => (W.LC_A, W.LC_Z), - 2 => (W.LC_German_Sharp_S, W.LC_O_Diaeresis), - 3 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); - - Lower_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Lower_Ranges'Unrestricted_Access); - - Upper_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => ('A', 'Z'), - 2 => (W.UC_A_Grave, W.UC_O_Diaeresis), - 3 => (W.UC_O_Oblique_Stroke, W.UC_Icelandic_Thorn)); - - Upper_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Upper_Ranges'Unrestricted_Access); - - Basic_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => ('A', 'Z'), - 2 => (W.LC_A, W.LC_Z), - 3 => (W.UC_AE_Diphthong, W.UC_AE_Diphthong), - 4 => (W.LC_AE_Diphthong, W.LC_AE_Diphthong), - 5 => (W.LC_German_Sharp_S, W.LC_German_Sharp_S), - 6 => (W.UC_Icelandic_Thorn, W.UC_Icelandic_Thorn), - 7 => (W.LC_Icelandic_Thorn, W.LC_Icelandic_Thorn), - 8 => (W.UC_Icelandic_Eth, W.UC_Icelandic_Eth), - 9 => (W.LC_Icelandic_Eth, W.LC_Icelandic_Eth)); - - Basic_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Basic_Ranges'Unrestricted_Access); - - Decimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => ('0', '9')); - - Decimal_Digit_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Decimal_Digit_Ranges'Unrestricted_Access); - - Hexadecimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => ('0', '9'), - 2 => ('A', 'F'), - 3 => (W.LC_A, W.LC_F)); - - Hexadecimal_Digit_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Hexadecimal_Digit_Ranges'Unrestricted_Access); - - Alphanumeric_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => ('0', '9'), - 2 => ('A', 'Z'), - 3 => (W.LC_A, W.LC_Z), - 4 => (W.UC_A_Grave, W.UC_O_Diaeresis), - 5 => (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), - 6 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); - - Alphanumeric_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Alphanumeric_Ranges'Unrestricted_Access); - - Special_Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => (Wide_Wide_Space, W.Solidus), - 2 => (W.Colon, W.Commercial_At), - 3 => (W.Left_Square_Bracket, W.Grave), - 4 => (W.Left_Curly_Bracket, W.Tilde), - 5 => (W.No_Break_Space, W.Inverted_Question), - 6 => (W.Multiplication_Sign, W.Multiplication_Sign), - 7 => (W.Division_Sign, W.Division_Sign)); - - Special_Graphic_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Special_Graphic_Ranges'Unrestricted_Access); - - ISO_646_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => (W.NUL, W.DEL)); - - ISO_646_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - ISO_646_Ranges'Unrestricted_Access); - - Character_Ranges : aliased constant Wide_Wide_Character_Ranges := - (1 => (W.NUL, WC'Val (255))); - - Character_Set : constant Wide_Wide_Character_Set := - (AF.Controlled with - Character_Ranges'Unrestricted_Access); - - Lower_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := - (Length => 56, - - Domain => - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & - W.UC_A_Grave & - W.UC_A_Acute & - W.UC_A_Circumflex & - W.UC_A_Tilde & - W.UC_A_Diaeresis & - W.UC_A_Ring & - W.UC_AE_Diphthong & - W.UC_C_Cedilla & - W.UC_E_Grave & - W.UC_E_Acute & - W.UC_E_Circumflex & - W.UC_E_Diaeresis & - W.UC_I_Grave & - W.UC_I_Acute & - W.UC_I_Circumflex & - W.UC_I_Diaeresis & - W.UC_Icelandic_Eth & - W.UC_N_Tilde & - W.UC_O_Grave & - W.UC_O_Acute & - W.UC_O_Circumflex & - W.UC_O_Tilde & - W.UC_O_Diaeresis & - W.UC_O_Oblique_Stroke & - W.UC_U_Grave & - W.UC_U_Acute & - W.UC_U_Circumflex & - W.UC_U_Diaeresis & - W.UC_Y_Acute & - W.UC_Icelandic_Thorn, - - Rangev => - "abcdefghijklmnopqrstuvwxyz" & - W.LC_A_Grave & - W.LC_A_Acute & - W.LC_A_Circumflex & - W.LC_A_Tilde & - W.LC_A_Diaeresis & - W.LC_A_Ring & - W.LC_AE_Diphthong & - W.LC_C_Cedilla & - W.LC_E_Grave & - W.LC_E_Acute & - W.LC_E_Circumflex & - W.LC_E_Diaeresis & - W.LC_I_Grave & - W.LC_I_Acute & - W.LC_I_Circumflex & - W.LC_I_Diaeresis & - W.LC_Icelandic_Eth & - W.LC_N_Tilde & - W.LC_O_Grave & - W.LC_O_Acute & - W.LC_O_Circumflex & - W.LC_O_Tilde & - W.LC_O_Diaeresis & - W.LC_O_Oblique_Stroke & - W.LC_U_Grave & - W.LC_U_Acute & - W.LC_U_Circumflex & - W.LC_U_Diaeresis & - W.LC_Y_Acute & - W.LC_Icelandic_Thorn); - - Lower_Case_Map : constant Wide_Wide_Character_Mapping := - (AF.Controlled with - Map => Lower_Case_Mapping'Unrestricted_Access); - - Upper_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := - (Length => 56, - - Domain => - "abcdefghijklmnopqrstuvwxyz" & - W.LC_A_Grave & - W.LC_A_Acute & - W.LC_A_Circumflex & - W.LC_A_Tilde & - W.LC_A_Diaeresis & - W.LC_A_Ring & - W.LC_AE_Diphthong & - W.LC_C_Cedilla & - W.LC_E_Grave & - W.LC_E_Acute & - W.LC_E_Circumflex & - W.LC_E_Diaeresis & - W.LC_I_Grave & - W.LC_I_Acute & - W.LC_I_Circumflex & - W.LC_I_Diaeresis & - W.LC_Icelandic_Eth & - W.LC_N_Tilde & - W.LC_O_Grave & - W.LC_O_Acute & - W.LC_O_Circumflex & - W.LC_O_Tilde & - W.LC_O_Diaeresis & - W.LC_O_Oblique_Stroke & - W.LC_U_Grave & - W.LC_U_Acute & - W.LC_U_Circumflex & - W.LC_U_Diaeresis & - W.LC_Y_Acute & - W.LC_Icelandic_Thorn, - - Rangev => - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & - W.UC_A_Grave & - W.UC_A_Acute & - W.UC_A_Circumflex & - W.UC_A_Tilde & - W.UC_A_Diaeresis & - W.UC_A_Ring & - W.UC_AE_Diphthong & - W.UC_C_Cedilla & - W.UC_E_Grave & - W.UC_E_Acute & - W.UC_E_Circumflex & - W.UC_E_Diaeresis & - W.UC_I_Grave & - W.UC_I_Acute & - W.UC_I_Circumflex & - W.UC_I_Diaeresis & - W.UC_Icelandic_Eth & - W.UC_N_Tilde & - W.UC_O_Grave & - W.UC_O_Acute & - W.UC_O_Circumflex & - W.UC_O_Tilde & - W.UC_O_Diaeresis & - W.UC_O_Oblique_Stroke & - W.UC_U_Grave & - W.UC_U_Acute & - W.UC_U_Circumflex & - W.UC_U_Diaeresis & - W.UC_Y_Acute & - W.UC_Icelandic_Thorn); - - Upper_Case_Map : constant Wide_Wide_Character_Mapping := - (AF.Controlled with - Upper_Case_Mapping'Unrestricted_Access); - - Basic_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := - (Length => 55, - - Domain => - W.UC_A_Grave & - W.UC_A_Acute & - W.UC_A_Circumflex & - W.UC_A_Tilde & - W.UC_A_Diaeresis & - W.UC_A_Ring & - W.UC_C_Cedilla & - W.UC_E_Grave & - W.UC_E_Acute & - W.UC_E_Circumflex & - W.UC_E_Diaeresis & - W.UC_I_Grave & - W.UC_I_Acute & - W.UC_I_Circumflex & - W.UC_I_Diaeresis & - W.UC_N_Tilde & - W.UC_O_Grave & - W.UC_O_Acute & - W.UC_O_Circumflex & - W.UC_O_Tilde & - W.UC_O_Diaeresis & - W.UC_O_Oblique_Stroke & - W.UC_U_Grave & - W.UC_U_Acute & - W.UC_U_Circumflex & - W.UC_U_Diaeresis & - W.UC_Y_Acute & - W.LC_A_Grave & - W.LC_A_Acute & - W.LC_A_Circumflex & - W.LC_A_Tilde & - W.LC_A_Diaeresis & - W.LC_A_Ring & - W.LC_C_Cedilla & - W.LC_E_Grave & - W.LC_E_Acute & - W.LC_E_Circumflex & - W.LC_E_Diaeresis & - W.LC_I_Grave & - W.LC_I_Acute & - W.LC_I_Circumflex & - W.LC_I_Diaeresis & - W.LC_N_Tilde & - W.LC_O_Grave & - W.LC_O_Acute & - W.LC_O_Circumflex & - W.LC_O_Tilde & - W.LC_O_Diaeresis & - W.LC_O_Oblique_Stroke & - W.LC_U_Grave & - W.LC_U_Acute & - W.LC_U_Circumflex & - W.LC_U_Diaeresis & - W.LC_Y_Acute & - W.LC_Y_Diaeresis, - - Rangev => - 'A' & -- UC_A_Grave - 'A' & -- UC_A_Acute - 'A' & -- UC_A_Circumflex - 'A' & -- UC_A_Tilde - 'A' & -- UC_A_Diaeresis - 'A' & -- UC_A_Ring - 'C' & -- UC_C_Cedilla - 'E' & -- UC_E_Grave - 'E' & -- UC_E_Acute - 'E' & -- UC_E_Circumflex - 'E' & -- UC_E_Diaeresis - 'I' & -- UC_I_Grave - 'I' & -- UC_I_Acute - 'I' & -- UC_I_Circumflex - 'I' & -- UC_I_Diaeresis - 'N' & -- UC_N_Tilde - 'O' & -- UC_O_Grave - 'O' & -- UC_O_Acute - 'O' & -- UC_O_Circumflex - 'O' & -- UC_O_Tilde - 'O' & -- UC_O_Diaeresis - 'O' & -- UC_O_Oblique_Stroke - 'U' & -- UC_U_Grave - 'U' & -- UC_U_Acute - 'U' & -- UC_U_Circumflex - 'U' & -- UC_U_Diaeresis - 'Y' & -- UC_Y_Acute - 'a' & -- LC_A_Grave - 'a' & -- LC_A_Acute - 'a' & -- LC_A_Circumflex - 'a' & -- LC_A_Tilde - 'a' & -- LC_A_Diaeresis - 'a' & -- LC_A_Ring - 'c' & -- LC_C_Cedilla - 'e' & -- LC_E_Grave - 'e' & -- LC_E_Acute - 'e' & -- LC_E_Circumflex - 'e' & -- LC_E_Diaeresis - 'i' & -- LC_I_Grave - 'i' & -- LC_I_Acute - 'i' & -- LC_I_Circumflex - 'i' & -- LC_I_Diaeresis - 'n' & -- LC_N_Tilde - 'o' & -- LC_O_Grave - 'o' & -- LC_O_Acute - 'o' & -- LC_O_Circumflex - 'o' & -- LC_O_Tilde - 'o' & -- LC_O_Diaeresis - 'o' & -- LC_O_Oblique_Stroke - 'u' & -- LC_U_Grave - 'u' & -- LC_U_Acute - 'u' & -- LC_U_Circumflex - 'u' & -- LC_U_Diaeresis - 'y' & -- LC_Y_Acute - 'y'); -- LC_Y_Diaeresis - - Basic_Map : constant Wide_Wide_Character_Mapping := - (AF.Controlled with - Basic_Mapping'Unrestricted_Access); - -end Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants; diff --git a/gcc/ada/a-szunau-shared.adb b/gcc/ada/a-szunau-shared.adb deleted file mode 100644 index 87b2cb4..0000000 --- a/gcc/ada/a-szunau-shared.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Wide_Unbounded.Aux is - - -------------------------- - -- Get_Wide_Wide_String -- - -------------------------- - - procedure Get_Wide_Wide_String - (U : Unbounded_Wide_Wide_String; - S : out Big_Wide_Wide_String_Access; - L : out Natural) - is - X : aliased Big_Wide_Wide_String; - for X'Address use U.Reference.Data'Address; - begin - S := X'Unchecked_Access; - L := U.Reference.Last; - end Get_Wide_Wide_String; - - -------------------------- - -- Set_Wide_Wide_String -- - -------------------------- - - procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String_Access) - is - X : Wide_Wide_String_Access := S; - - begin - Set_Unbounded_Wide_Wide_String (UP, S.all); - Free (X); - end Set_Wide_Wide_String; - -end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szunau.adb b/gcc/ada/a-szunau.adb deleted file mode 100644 index 7ab9cc5..0000000 --- a/gcc/ada/a-szunau.adb +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Strings.Wide_Wide_Unbounded.Aux is - - -------------------------- - -- Get_Wide_Wide_String -- - -------------------------- - - procedure Get_Wide_Wide_String - (U : Unbounded_Wide_Wide_String; - S : out Big_Wide_Wide_String_Access; - L : out Natural) - is - X : aliased Big_Wide_Wide_String; - for X'Address use U.Reference.all'Address; - - begin - S := X'Unchecked_Access; - L := U.Last; - end Get_Wide_Wide_String; - - -------------------------- - -- Set_Wide_Wide_String -- - -------------------------- - - procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String_Access) - is - begin - Finalize (UP); - UP.Reference := S; - UP.Last := UP.Reference'Length; - end Set_Wide_Wide_String; - -end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szunau.ads b/gcc/ada/a-szunau.ads deleted file mode 100644 index 6115330..0000000 --- a/gcc/ada/a-szunau.ads +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This child package of Ada.Strings.Wide_Wide_Unbounded provides some --- specialized access functions which are intended to allow more efficient --- use of the facilities of Ada.Strings.Wide_Wide_Unbounded, particularly by --- other layered utilities. - -package Ada.Strings.Wide_Wide_Unbounded.Aux is - pragma Preelaborate; - - subtype Big_Wide_Wide_String is Wide_Wide_String (Positive); - type Big_Wide_Wide_String_Access is access all Big_Wide_Wide_String; - - procedure Get_Wide_Wide_String - (U : Unbounded_Wide_Wide_String; - S : out Big_Wide_Wide_String_Access; - L : out Natural); - pragma Inline (Get_Wide_Wide_String); - -- This procedure returns the internal string pointer used in the - -- representation of an unbounded string as well as the actual current - -- length (which may be less than S.all'Length because in general there - -- can be extra space assigned). The characters of this string may be - -- not be modified via the returned pointer, and are valid only as - -- long as the original unbounded string is not accessed or modified. - -- - -- This procedure is more efficient than the use of To_Wide_Wide_String - -- since it avoids the need to copy the string. The lower bound of the - -- referenced string returned by this call is always one, so the actual - -- string data is always accessible as S (1 .. L). - - procedure Set_Wide_Wide_String - (UP : out Unbounded_Wide_Wide_String; - S : Wide_Wide_String) - renames Set_Unbounded_Wide_Wide_String; - -- This function sets the string contents of the referenced unbounded - -- string to the given string value. It is significantly more efficient - -- than the use of To_Unbounded_Wide_Wide_String with an assignment, since - -- it avoids the necessity of messing with finalization chains. The lower - -- bound of the string S is not required to be one. - - procedure Set_Wide_Wide_String - (UP : in out Unbounded_Wide_Wide_String; - S : Wide_Wide_String_Access); - pragma Inline (Set_Wide_Wide_String); - -- This version of Set_Wide_Wide_String takes a string access value, rather - -- than string. The lower bound of the string value is required to be one, - -- and this requirement is not checked. - -end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/a-szuzha.adb b/gcc/ada/a-szuzha.adb deleted file mode 100644 index 13cb19b..0000000 --- a/gcc/ada/a-szuzha.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- This unit was originally developed by Matthew J Heaney. -- ------------------------------------------------------------------------------- - -with System.String_Hash; - -function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash - (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type -is - use Ada.Containers; - function Hash is new System.String_Hash.Hash - (Wide_Wide_Character, Wide_Wide_String, Hash_Type); -begin - return Hash (To_Wide_Wide_String (Key)); -end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash; diff --git a/gcc/ada/a-szuzha.ads b/gcc/ada/a-szuzha.ads deleted file mode 100644 index 94bed28..0000000 --- a/gcc/ada/a-szuzha.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Containers; - -function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash - (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type; - -pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash); diff --git a/gcc/ada/a-szuzti-shared.adb b/gcc/ada/a-szuzti-shared.adb deleted file mode 100644 index 247ccb2..0000000 --- a/gcc/ada/a-szuzti-shared.adb +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; - -package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_Wide_Wide_String is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_Wide_String; - - begin - Get_Line (Buffer, Last); - Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - function Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type) - return Unbounded_Wide_Wide_String - is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Result : Unbounded_Wide_Wide_String; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Result, Buffer (1 .. Last)); - end loop; - - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_Wide_String) - is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Append (Item, Buffer (1 .. Last)); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put (UR.Data (1 .. UR.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put (File, UR.Data (1 .. UR.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put_Line (UR.Data (1 .. UR.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is - UR : constant Shared_Wide_Wide_String_Access := U.Reference; - - begin - Put_Line (File, UR.Data (1 .. UR.Last)); - end Put_Line; - -end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-szuzti.adb b/gcc/ada/a-szuzti.adb deleted file mode 100644 index 25feb20..0000000 --- a/gcc/ada/a-szuzti.adb +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; - -package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Unbounded_Wide_Wide_String is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_Wide_String_Access; - Str2 : Wide_Wide_String_Access; - Result : Unbounded_Wide_Wide_String; - - begin - Get_Line (Buffer, Last); - Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Str2 := new Wide_Wide_String (1 .. Str1'Last + Last); - Str2 (Str1'Range) := Str1.all; - Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); - Free (Str1); - Str1 := Str2; - end loop; - - Result.Reference := Str1; - Result.Last := Str1'Length; - return Result; - end Get_Line; - - function Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type) return Unbounded_Wide_Wide_String - is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_Wide_String_Access; - Str2 : Wide_Wide_String_Access; - Result : Unbounded_Wide_Wide_String; - - begin - Get_Line (File, Buffer, Last); - Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Str2 := new Wide_Wide_String (1 .. Str1'Last + Last); - Str2 (Str1'Range) := Str1.all; - Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); - Free (Str1); - Str1 := Str2; - end loop; - - Result.Reference := Str1; - Result.Last := Str1'Length; - return Result; - end Get_Line; - - procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is - begin - Get_Line (Current_Input, Item); - end Get_Line; - - procedure Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_Wide_String) - is - begin - -- We are going to read into the string that is already there and - -- allocated. Hopefully it is big enough now, if not, we will extend - -- it in the usual manner using Realloc_For_Chunk. - - -- Make sure we start with at least 80 characters - - if Item.Reference'Last < 80 then - Realloc_For_Chunk (Item, 80); - end if; - - -- Loop to read data, filling current string as far as possible. - -- Item.Last holds the number of characters read so far. - - Item.Last := 0; - loop - Get_Line - (File, - Item.Reference (Item.Last + 1 .. Item.Reference'Last), - Item.Last); - - -- If we hit the end of the line before the end of the buffer, then - -- we are all done, and the result length is properly set. - - if Item.Last < Item.Reference'Last then - return; - end if; - - -- If not enough room, double it and keep reading - - Realloc_For_Chunk (Item, Item.Last); - end loop; - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put (U : Unbounded_Wide_Wide_String) is - begin - Put (U.Reference (1 .. U.Last)); - end Put; - - procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is - begin - Put (File, U.Reference (1 .. U.Last)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (U : Unbounded_Wide_Wide_String) is - begin - Put_Line (U.Reference (1 .. U.Last)); - end Put_Line; - - procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is - begin - Put_Line (File, U.Reference (1 .. U.Last)); - end Put_Line; - -end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-szuzti.ads b/gcc/ada/a-szuzti.ads deleted file mode 100644 index f84a34e..0000000 --- a/gcc/ada/a-szuzti.ads +++ /dev/null @@ -1,71 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This child package of Ada.Strings.Wide_Wide_Unbounded provides specialized --- Wide_Wide_Text_IO routines that work directly with unbounded wide wide --- strings, avoiding the inefficiencies of access via the standard interface, --- and also taking direct advantage of the variable length semantics of these --- strings. - -with Ada.Wide_Wide_Text_IO; - -package Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is - - function Get_Line - return Unbounded_Wide_Wide_String; - function Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type) - return Unbounded_Wide_Wide_String; - -- Reads up to the end of the current line, returning the result - -- as an unbounded string of appropriate length. If no File parameter - -- is present, input is from Current_Input. - - procedure Get_Line - (File : Ada.Wide_Wide_Text_IO.File_Type; - Item : out Unbounded_Wide_Wide_String); - procedure Get_Line (Item : out Unbounded_Wide_Wide_String); - -- Similar to the above, but in procedure form with an out parameter - - procedure Put - (U : Unbounded_Wide_Wide_String); - procedure Put - (File : Ada.Wide_Wide_Text_IO.File_Type; - U : Unbounded_Wide_Wide_String); - procedure Put_Line - (U : Unbounded_Wide_Wide_String); - procedure Put_Line - (File : Ada.Wide_Wide_Text_IO.File_Type; - U : Unbounded_Wide_Wide_String); - -- These are equivalent to the standard Wide_Wide_Text_IO routines passed - -- the value To_Wide_Wide_String (U), but operate more efficiently, - -- because the extra copy of the argument is avoided. - -end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-tags.adb b/gcc/ada/a-tags.adb deleted file mode 100644 index 322f991..0000000 --- a/gcc/ada/a-tags.adb +++ /dev/null @@ -1,1100 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A G S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Unchecked_Conversion; - -with System.HTable; -with System.Storage_Elements; use System.Storage_Elements; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_StW; use System.WCh_StW; - -pragma Elaborate (System.HTable); --- Elaborate needed instead of Elaborate_All to avoid elaboration cycles --- when polling is turned on. This is safe because HTable doesn't do anything --- at elaboration time; it just contains a generic package we want to --- instantiate. - -package body Ada.Tags is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; - -- Given the tag of an object and the tag associated to a type, return - -- true if Obj is in Typ'Class. - - function Get_External_Tag (T : Tag) return System.Address; - -- Returns address of a null terminated string containing the external name - - function Is_Primary_DT (T : Tag) return Boolean; - -- Given a tag returns True if it has the signature of a primary dispatch - -- table. This is Inline_Always since it is called from other Inline_ - -- Always subprograms where we want no out of line code to be generated. - - function IW_Membership - (Descendant_TSD : Type_Specific_Data_Ptr; - T : Tag) return Boolean; - -- Subsidiary function of IW_Membership and CW_Membership which factorizes - -- the functionality needed to check if a given descendant implements an - -- interface tag T. - - function Length (Str : Cstring_Ptr) return Natural; - -- Length of string represented by the given pointer (treating the string - -- as a C-style string, which is Nul terminated). See comment in body - -- explaining why we cannot use the normal strlen built-in. - - function OSD (T : Tag) return Object_Specific_Data_Ptr; - -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, - -- retrieve the address of the record containing the Object Specific - -- Data table. - - function SSD (T : Tag) return Select_Specific_Data_Ptr; - -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the - -- address of the record containing the Select Specific Data in T's TSD. - - pragma Inline_Always (CW_Membership); - pragma Inline_Always (Get_External_Tag); - pragma Inline_Always (Is_Primary_DT); - pragma Inline_Always (OSD); - pragma Inline_Always (SSD); - - -- Unchecked conversions - - function To_Address is - new Unchecked_Conversion (Cstring_Ptr, System.Address); - - function To_Cstring_Ptr is - new Unchecked_Conversion (System.Address, Cstring_Ptr); - - -- Disable warnings on possible aliasing problem - - function To_Tag is - new Unchecked_Conversion (Integer_Address, Tag); - - function To_Addr_Ptr is - new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); - - function To_Address is - new Ada.Unchecked_Conversion (Tag, System.Address); - - function To_Dispatch_Table_Ptr is - new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); - - function To_Dispatch_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); - - function To_Object_Specific_Data_Ptr is - new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); - - function To_Tag_Ptr is - new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); - - function To_Type_Specific_Data_Ptr is - new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); - - ------------------------------- - -- Inline_Always Subprograms -- - ------------------------------- - - -- Inline_always subprograms must be placed before their first call to - -- avoid defeating the frontend inlining mechanism and thus ensure the - -- generation of their correct debug info. - - ------------------- - -- CW_Membership -- - ------------------- - - -- Canonical implementation of Classwide Membership corresponding to: - - -- Obj in Typ'Class - - -- Each dispatch table contains a reference to a table of ancestors (stored - -- in the first part of the Tags_Table) and a count of the level of - -- inheritance "Idepth". - - -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are - -- contained in the dispatch table referenced by Obj'Tag . Knowing the - -- level of inheritance of both types, this can be computed in constant - -- time by the formula: - - -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) - -- = Typ'tag - - function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is - Obj_TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size); - Typ_TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size); - Obj_TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all); - Typ_TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all); - Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth; - begin - return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag; - end CW_Membership; - - ---------------------- - -- Get_External_Tag -- - ---------------------- - - function Get_External_Tag (T : Tag) return System.Address is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - begin - return To_Address (TSD.External_Tag); - end Get_External_Tag; - - ----------------- - -- Is_Abstract -- - ----------------- - - function Is_Abstract (T : Tag) return Boolean is - TSD_Ptr : Addr_Ptr; - TSD : Type_Specific_Data_Ptr; - - begin - if T = No_Tag then - raise Tag_Error; - end if; - - TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); - return TSD.Is_Abstract; - end Is_Abstract; - - ------------------- - -- Is_Primary_DT -- - ------------------- - - function Is_Primary_DT (T : Tag) return Boolean is - begin - return DT (T).Signature = Primary_DT; - end Is_Primary_DT; - - --------- - -- OSD -- - --------- - - function OSD (T : Tag) return Object_Specific_Data_Ptr is - OSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - begin - return To_Object_Specific_Data_Ptr (OSD_Ptr.all); - end OSD; - - --------- - -- SSD -- - --------- - - function SSD (T : Tag) return Select_Specific_Data_Ptr is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - begin - return TSD.SSD; - end SSD; - - ------------------------- - -- External_Tag_HTable -- - ------------------------- - - type HTable_Headers is range 1 .. 64; - - -- The following internal package defines the routines used for the - -- instantiation of a new System.HTable.Static_HTable (see below). See - -- spec in g-htable.ads for details of usage. - - package HTable_Subprograms is - procedure Set_HT_Link (T : Tag; Next : Tag); - function Get_HT_Link (T : Tag) return Tag; - function Hash (F : System.Address) return HTable_Headers; - function Equal (A, B : System.Address) return Boolean; - end HTable_Subprograms; - - package External_Tag_HTable is new System.HTable.Static_HTable ( - Header_Num => HTable_Headers, - Element => Dispatch_Table, - Elmt_Ptr => Tag, - Null_Ptr => null, - Set_Next => HTable_Subprograms.Set_HT_Link, - Next => HTable_Subprograms.Get_HT_Link, - Key => System.Address, - Get_Key => Get_External_Tag, - Hash => HTable_Subprograms.Hash, - Equal => HTable_Subprograms.Equal); - - ------------------------ - -- HTable_Subprograms -- - ------------------------ - - -- Bodies of routines for hash table instantiation - - package body HTable_Subprograms is - - ----------- - -- Equal -- - ----------- - - function Equal (A, B : System.Address) return Boolean is - Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); - Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); - J : Integer; - begin - J := 1; - loop - if Str1 (J) /= Str2 (J) then - return False; - elsif Str1 (J) = ASCII.NUL then - return True; - else - J := J + 1; - end if; - end loop; - end Equal; - - ----------------- - -- Get_HT_Link -- - ----------------- - - function Get_HT_Link (T : Tag) return Tag is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - begin - return TSD.HT_Link.all; - end Get_HT_Link; - - ---------- - -- Hash -- - ---------- - - function Hash (F : System.Address) return HTable_Headers is - function H is new System.HTable.Hash (HTable_Headers); - Str : constant Cstring_Ptr := To_Cstring_Ptr (F); - Res : constant HTable_Headers := H (Str (1 .. Length (Str))); - begin - return Res; - end Hash; - - ----------------- - -- Set_HT_Link -- - ----------------- - - procedure Set_HT_Link (T : Tag; Next : Tag) is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - begin - TSD.HT_Link.all := Next; - end Set_HT_Link; - - end HTable_Subprograms; - - ------------------ - -- Base_Address -- - ------------------ - - function Base_Address (This : System.Address) return System.Address is - begin - return This - Offset_To_Top (This); - end Base_Address; - - --------------- - -- Check_TSD -- - --------------- - - procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is - T : Tag; - - E_Tag_Len : constant Integer := Length (TSD.External_Tag); - E_Tag : String (1 .. E_Tag_Len); - for E_Tag'Address use TSD.External_Tag.all'Address; - pragma Import (Ada, E_Tag); - - Dup_Ext_Tag : constant String := "duplicated external tag """; - - begin - -- Verify that the external tag of this TSD is not registered in the - -- runtime hash table. - - T := External_Tag_HTable.Get (To_Address (TSD.External_Tag)); - - if T /= null then - - -- Avoid concatenation, as it is not allowed in no run time mode - - declare - Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1); - begin - Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag; - Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) := - E_Tag; - Msg (Msg'Last) := '"'; - raise Program_Error with Msg; - end; - end if; - end Check_TSD; - - -------------------- - -- Descendant_Tag -- - -------------------- - - function Descendant_Tag (External : String; Ancestor : Tag) return Tag is - Int_Tag : constant Tag := Internal_Tag (External); - begin - if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then - raise Tag_Error; - else - return Int_Tag; - end if; - end Descendant_Tag; - - -------------- - -- Displace -- - -------------- - - function Displace (This : System.Address; T : Tag) return System.Address is - Iface_Table : Interface_Data_Ptr; - Obj_Base : System.Address; - Obj_DT : Dispatch_Table_Ptr; - Obj_DT_Tag : Tag; - - begin - if System."=" (This, System.Null_Address) then - return System.Null_Address; - end if; - - Obj_Base := Base_Address (This); - Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all; - Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); - Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; - - if Iface_Table /= null then - for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then - - -- Case of Static value of Offset_To_Top - - if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then - Obj_Base := Obj_Base + - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value; - - -- Otherwise call the function generated by the expander to - -- provide the value. - - else - Obj_Base := Obj_Base + - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all - (Obj_Base); - end if; - - return Obj_Base; - end if; - end loop; - end if; - - -- Check if T is an immediate ancestor. This is required to handle - -- conversion of class-wide interfaces to tagged types. - - if CW_Membership (Obj_DT_Tag, T) then - return Obj_Base; - end if; - - -- If the object does not implement the interface we must raise CE - - raise Constraint_Error with "invalid interface conversion"; - end Displace; - - -------- - -- DT -- - -------- - - function DT (T : Tag) return Dispatch_Table_Ptr is - Offset : constant SSE.Storage_Offset := - To_Dispatch_Table_Ptr (T).Prims_Ptr'Position; - begin - return To_Dispatch_Table_Ptr (To_Address (T) - Offset); - end DT; - - ------------------- - -- IW_Membership -- - ------------------- - - function IW_Membership - (Descendant_TSD : Type_Specific_Data_Ptr; - T : Tag) return Boolean - is - Iface_Table : Interface_Data_Ptr; - - begin - Iface_Table := Descendant_TSD.Interfaces_Table; - - if Iface_Table /= null then - for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then - return True; - end if; - end loop; - end if; - - -- Look for the tag in the ancestor tags table. This is required for: - -- Iface_CW in Typ'Class - - for Id in 0 .. Descendant_TSD.Idepth loop - if Descendant_TSD.Tags_Table (Id) = T then - return True; - end if; - end loop; - - return False; - end IW_Membership; - - ------------------- - -- IW_Membership -- - ------------------- - - -- Canonical implementation of Classwide Membership corresponding to: - - -- Obj in Iface'Class - - -- Each dispatch table contains a table with the tags of all the - -- implemented interfaces. - - -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces - -- that are contained in the dispatch table referenced by Obj'Tag. - - function IW_Membership (This : System.Address; T : Tag) return Boolean is - Obj_Base : System.Address; - Obj_DT : Dispatch_Table_Ptr; - Obj_TSD : Type_Specific_Data_Ptr; - - begin - Obj_Base := Base_Address (This); - Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); - Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD); - - return IW_Membership (Obj_TSD, T); - end IW_Membership; - - ------------------- - -- Expanded_Name -- - ------------------- - - function Expanded_Name (T : Tag) return String is - Result : Cstring_Ptr; - TSD_Ptr : Addr_Ptr; - TSD : Type_Specific_Data_Ptr; - - begin - if T = No_Tag then - raise Tag_Error; - end if; - - TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); - Result := TSD.Expanded_Name; - return Result (1 .. Length (Result)); - end Expanded_Name; - - ------------------ - -- External_Tag -- - ------------------ - - function External_Tag (T : Tag) return String is - Result : Cstring_Ptr; - TSD_Ptr : Addr_Ptr; - TSD : Type_Specific_Data_Ptr; - - begin - if T = No_Tag then - raise Tag_Error; - end if; - - TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); - Result := TSD.External_Tag; - return Result (1 .. Length (Result)); - end External_Tag; - - --------------------- - -- Get_Entry_Index -- - --------------------- - - function Get_Entry_Index (T : Tag; Position : Positive) return Positive is - begin - return SSD (T).SSD_Table (Position).Index; - end Get_Entry_Index; - - ---------------------- - -- Get_Prim_Op_Kind -- - ---------------------- - - function Get_Prim_Op_Kind - (T : Tag; - Position : Positive) return Prim_Op_Kind - is - begin - return SSD (T).SSD_Table (Position).Kind; - end Get_Prim_Op_Kind; - - ---------------------- - -- Get_Offset_Index -- - ---------------------- - - function Get_Offset_Index - (T : Tag; - Position : Positive) return Positive - is - begin - if Is_Primary_DT (T) then - return Position; - else - return OSD (T).OSD_Table (Position); - end if; - end Get_Offset_Index; - - --------------------- - -- Get_Tagged_Kind -- - --------------------- - - function Get_Tagged_Kind (T : Tag) return Tagged_Kind is - begin - return DT (T).Tag_Kind; - end Get_Tagged_Kind; - - ----------------------------- - -- Interface_Ancestor_Tags -- - ----------------------------- - - function Interface_Ancestor_Tags (T : Tag) return Tag_Array is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; - - begin - if Iface_Table = null then - declare - Table : Tag_Array (1 .. 0); - begin - return Table; - end; - - else - declare - Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); - begin - for J in 1 .. Iface_Table.Nb_Ifaces loop - Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; - end loop; - - return Table; - end; - end if; - end Interface_Ancestor_Tags; - - ------------------ - -- Internal_Tag -- - ------------------ - - -- Internal tags have the following format: - -- "Internal tag at 16#ADDRESS#: " - - Internal_Tag_Header : constant String := "Internal tag at "; - Header_Separator : constant Character := '#'; - - function Internal_Tag (External : String) return Tag is - pragma Unsuppress (All_Checks); - -- To make T'Class'Input robust in the case of bad data - - Res : Tag := null; - - begin - -- Raise Tag_Error for empty strings and very long strings. This makes - -- T'Class'Input robust in the case of bad data, for example - -- - -- String (123456789..1234) - -- - -- The limit of 10,000 characters is arbitrary, but is unlikely to be - -- exceeded by legitimate external tag names. - - if External'Length not in 1 .. 10_000 then - raise Tag_Error; - end if; - - -- Handle locally defined tagged types - - if External'Length > Internal_Tag_Header'Length - and then - External (External'First .. - External'First + Internal_Tag_Header'Length - 1) = - Internal_Tag_Header - then - declare - Addr_First : constant Natural := - External'First + Internal_Tag_Header'Length; - Addr_Last : Natural; - Addr : Integer_Address; - - begin - -- Search the second separator (#) to identify the address - - Addr_Last := Addr_First; - - for J in 1 .. 2 loop - while Addr_Last <= External'Last - and then External (Addr_Last) /= Header_Separator - loop - Addr_Last := Addr_Last + 1; - end loop; - - -- Skip the first separator - - if J = 1 then - Addr_Last := Addr_Last + 1; - end if; - end loop; - - if Addr_Last <= External'Last then - - -- Protect the run-time against wrong internal tags. We - -- cannot use exception handlers here because it would - -- disable the use of this run-time compiling with - -- restriction No_Exception_Handler. - - declare - C : Character; - Wrong_Tag : Boolean := False; - - begin - if External (Addr_First) /= '1' - or else External (Addr_First + 1) /= '6' - or else External (Addr_First + 2) /= '#' - then - Wrong_Tag := True; - - else - for J in Addr_First + 3 .. Addr_Last - 1 loop - C := External (J); - - if not (C in '0' .. '9') - and then not (C in 'A' .. 'F') - and then not (C in 'a' .. 'f') - then - Wrong_Tag := True; - exit; - end if; - end loop; - end if; - - -- Convert the numeric value into a tag - - if not Wrong_Tag then - Addr := Integer_Address'Value - (External (Addr_First .. Addr_Last)); - - -- Internal tags never have value 0 - - if Addr /= 0 then - return To_Tag (Addr); - end if; - end if; - end; - end if; - end; - - -- Handle library-level tagged types - - else - -- Make NUL-terminated copy of external tag string - - declare - Ext_Copy : aliased String (External'First .. External'Last + 1); - pragma Assert (Ext_Copy'Length > 1); -- See Length check at top - begin - Ext_Copy (External'Range) := External; - Ext_Copy (Ext_Copy'Last) := ASCII.NUL; - Res := External_Tag_HTable.Get (Ext_Copy'Address); - end; - end if; - - if Res = null then - declare - Msg1 : constant String := "unknown tagged type: "; - Msg2 : String (1 .. Msg1'Length + External'Length); - - begin - Msg2 (1 .. Msg1'Length) := Msg1; - Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := - External; - Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2); - end; - end if; - - return Res; - end Internal_Tag; - - --------------------------------- - -- Is_Descendant_At_Same_Level -- - --------------------------------- - - function Is_Descendant_At_Same_Level - (Descendant : Tag; - Ancestor : Tag) return Boolean - is - begin - if Descendant = Ancestor then - return True; - - else - declare - D_TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size); - A_TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size); - D_TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (D_TSD_Ptr.all); - A_TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (A_TSD_Ptr.all); - begin - return - D_TSD.Access_Level = A_TSD.Access_Level - and then (CW_Membership (Descendant, Ancestor) - or else IW_Membership (D_TSD, Ancestor)); - end; - end if; - end Is_Descendant_At_Same_Level; - - ------------ - -- Length -- - ------------ - - -- Note: This unit is used in the Ravenscar runtime library, so it cannot - -- depend on System.CTRL. Furthermore, this happens on CPUs where the GCC - -- intrinsic strlen may not be available, so we need to recode our own Ada - -- version here. - - function Length (Str : Cstring_Ptr) return Natural is - Len : Integer; - - begin - Len := 1; - while Str (Len) /= ASCII.NUL loop - Len := Len + 1; - end loop; - - return Len - 1; - end Length; - - ------------------- - -- Offset_To_Top -- - ------------------- - - function Offset_To_Top - (This : System.Address) return SSE.Storage_Offset - is - Tag_Size : constant SSE.Storage_Count := - SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); - - type Storage_Offset_Ptr is access SSE.Storage_Offset; - function To_Storage_Offset_Ptr is - new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); - - Curr_DT : Dispatch_Table_Ptr; - - begin - Curr_DT := DT (To_Tag_Ptr (This).all); - - if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then - return To_Storage_Offset_Ptr (This + Tag_Size).all; - else - return Curr_DT.Offset_To_Top; - end if; - end Offset_To_Top; - - ------------------------ - -- Needs_Finalization -- - ------------------------ - - function Needs_Finalization (T : Tag) return Boolean is - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - begin - return TSD.Needs_Finalization; - end Needs_Finalization; - - ----------------- - -- Parent_Size -- - ----------------- - - function Parent_Size - (Obj : System.Address; - T : Tag) return SSE.Storage_Count - is - Parent_Slot : constant Positive := 1; - -- The tag of the parent is always in the first slot of the table of - -- ancestor tags. - - TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (TSD_Ptr.all); - -- Pointer to the TSD - - Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); - Parent_TSD_Ptr : constant Addr_Ptr := - To_Addr_Ptr (To_Address (Parent_Tag) - DT_Typeinfo_Ptr_Size); - Parent_TSD : constant Type_Specific_Data_Ptr := - To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); - - begin - -- Here we compute the size of the _parent field of the object - - return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); - end Parent_Size; - - ---------------- - -- Parent_Tag -- - ---------------- - - function Parent_Tag (T : Tag) return Tag is - TSD_Ptr : Addr_Ptr; - TSD : Type_Specific_Data_Ptr; - - begin - if T = No_Tag then - raise Tag_Error; - end if; - - TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); - TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); - - -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. - -- The first entry in the Ancestors_Tags array will be null for such - -- a type, but it's better to be explicit about returning No_Tag in - -- this case. - - if TSD.Idepth = 0 then - return No_Tag; - else - return TSD.Tags_Table (1); - end if; - end Parent_Tag; - - ------------------------------- - -- Register_Interface_Offset -- - ------------------------------- - - procedure Register_Interface_Offset - (Prim_T : Tag; - Interface_T : Tag; - Is_Static : Boolean; - Offset_Value : SSE.Storage_Offset; - Offset_Func : Offset_To_Top_Function_Ptr) - is - Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T); - Iface_Table : constant Interface_Data_Ptr := - To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; - - begin - -- Save Offset_Value in the table of interfaces of the primary DT. - -- This data will be used by the subprogram "Displace" to give support - -- to backward abstract interface type conversions. - - -- Register the offset in the table of interfaces - - if Iface_Table /= null then - for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then - if Is_Static or else Offset_Value = 0 then - Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := - Offset_Value; - else - Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; - Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := - Offset_Func; - end if; - - return; - end if; - end loop; - end if; - - -- If we arrive here there is some error in the run-time data structure - - raise Program_Error; - end Register_Interface_Offset; - - ------------------ - -- Register_Tag -- - ------------------ - - procedure Register_Tag (T : Tag) is - begin - External_Tag_HTable.Set (T); - end Register_Tag; - - ------------------- - -- Secondary_Tag -- - ------------------- - - function Secondary_Tag (T, Iface : Tag) return Tag is - Iface_Table : Interface_Data_Ptr; - Obj_DT : Dispatch_Table_Ptr; - - begin - if not Is_Primary_DT (T) then - raise Program_Error; - end if; - - Obj_DT := DT (T); - Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; - - if Iface_Table /= null then - for Id in 1 .. Iface_Table.Nb_Ifaces loop - if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then - return Iface_Table.Ifaces_Table (Id).Secondary_DT; - end if; - end loop; - end if; - - -- If the object does not implement the interface we must raise CE - - raise Constraint_Error with "invalid interface conversion"; - end Secondary_Tag; - - --------------------- - -- Set_Entry_Index -- - --------------------- - - procedure Set_Entry_Index - (T : Tag; - Position : Positive; - Value : Positive) - is - begin - SSD (T).SSD_Table (Position).Index := Value; - end Set_Entry_Index; - - ----------------------- - -- Set_Offset_To_Top -- - ----------------------- - - procedure Set_Dynamic_Offset_To_Top - (This : System.Address; - Prim_T : Tag; - Interface_T : Tag; - Offset_Value : SSE.Storage_Offset; - Offset_Func : Offset_To_Top_Function_Ptr) - is - Sec_Base : System.Address; - Sec_DT : Dispatch_Table_Ptr; - - begin - -- Save the offset to top field in the secondary dispatch table - - if Offset_Value /= 0 then - Sec_Base := This + Offset_Value; - Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); - Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; - end if; - - Register_Interface_Offset - (Prim_T, Interface_T, False, Offset_Value, Offset_Func); - end Set_Dynamic_Offset_To_Top; - - ---------------------- - -- Set_Prim_Op_Kind -- - ---------------------- - - procedure Set_Prim_Op_Kind - (T : Tag; - Position : Positive; - Value : Prim_Op_Kind) - is - begin - SSD (T).SSD_Table (Position).Kind := Value; - end Set_Prim_Op_Kind; - - -------------------- - -- Unregister_Tag -- - -------------------- - - procedure Unregister_Tag (T : Tag) is - begin - External_Tag_HTable.Remove (Get_External_Tag (T)); - end Unregister_Tag; - - ------------------------ - -- Wide_Expanded_Name -- - ------------------------ - - WC_Encoding : Character; - pragma Import (C, WC_Encoding, "__gl_wc_encoding"); - -- Encoding method for source, as exported by binder - - function Wide_Expanded_Name (T : Tag) return Wide_String is - S : constant String := Expanded_Name (T); - W : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Expanded_Name; - - ----------------------------- - -- Wide_Wide_Expanded_Name -- - ----------------------------- - - function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is - S : constant String := Expanded_Name (T); - W : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String - (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); - return W (1 .. L); - end Wide_Wide_Expanded_Name; - -end Ada.Tags; diff --git a/gcc/ada/a-tags.ads b/gcc/ada/a-tags.ads deleted file mode 100644 index 564ce20..0000000 --- a/gcc/ada/a-tags.ads +++ /dev/null @@ -1,612 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T A G S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- For performance analysis, take into account that the operations in this --- package provide the guarantee that all dispatching calls on primitive --- operations of tagged types and interfaces take constant time (in terms --- of source lines executed), that is to say, the cost of these calls is --- independent of the number of primitives of the type or interface, and --- independent of the number of ancestors or interface progenitors that a --- tagged type may have. - --- The following subprograms of the public part of this package take constant --- time (in terms of source lines executed): - --- Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag, --- Is_Abstract, Is_Descendant_At_Same_Level, Parent_Tag, --- Descendant_Tag (when used with a library-level tagged type), --- Internal_Tag (when used with a library-level tagged type). - --- The following subprograms of the public part of this package execute in --- time that is not constant (in terms of sources line executed): - --- Internal_Tag (when used with a locally defined tagged type), because in --- such cases this routine processes the external tag, extracts from it an --- address available there, and converts it into the tag value returned by --- this function. The number of instructions executed is not constant since --- it depends on the length of the external tag string. - --- Descendant_Tag (when used with a locally defined tagged type), because --- it relies on the subprogram Internal_Tag() to provide its functionality. - --- Interface_Ancestor_Tags, because this function returns a table whose --- length depends on the number of interfaces covered by a tagged type. - -with System.Storage_Elements; - -package Ada.Tags is - pragma Preelaborate; - -- In accordance with Ada 2005 AI-362 - - type Tag is private; - pragma Preelaborable_Initialization (Tag); - - No_Tag : constant Tag; - - function Expanded_Name (T : Tag) return String; - - function Wide_Expanded_Name (T : Tag) return Wide_String; - pragma Ada_05 (Wide_Expanded_Name); - - function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String; - pragma Ada_05 (Wide_Wide_Expanded_Name); - - function External_Tag (T : Tag) return String; - - function Internal_Tag (External : String) return Tag; - - function Descendant_Tag - (External : String; - Ancestor : Tag) return Tag; - pragma Ada_05 (Descendant_Tag); - - function Is_Descendant_At_Same_Level - (Descendant : Tag; - Ancestor : Tag) return Boolean; - pragma Ada_05 (Is_Descendant_At_Same_Level); - - function Parent_Tag (T : Tag) return Tag; - pragma Ada_05 (Parent_Tag); - - type Tag_Array is array (Positive range <>) of Tag; - - function Interface_Ancestor_Tags (T : Tag) return Tag_Array; - pragma Ada_05 (Interface_Ancestor_Tags); - - function Is_Abstract (T : Tag) return Boolean; - pragma Ada_2012 (Is_Abstract); - - Tag_Error : exception; - -private - -- Structure of the GNAT Primary Dispatch Table - - -- +--------------------+ - -- | Signature | - -- +--------------------+ - -- | Tagged_Kind | - -- +--------------------+ Predef Prims - -- | Predef_Prims -----------------------------> +------------+ - -- +--------------------+ | table of | - -- | Offset_To_Top | | predefined | - -- +--------------------+ | primitives | - -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+ - -- Tag ---> +--------------------+ +-------------------+ - -- | table of | | inheritance depth | - -- : primitive ops : +-------------------+ - -- | pointers | | access level | - -- +--------------------+ +-------------------+ - -- | alignment | - -- +-------------------+ - -- | expanded name | - -- +-------------------+ - -- | external tag | - -- +-------------------+ - -- | hash table link | - -- +-------------------+ - -- | transportable | - -- +-------------------+ - -- | is_abstract | - -- +-------------------+ - -- | needs finalization| - -- +-------------------+ - -- | Ifaces_Table ---> Interface Data - -- +-------------------+ +------------+ - -- Select Specific Data <---- SSD | | Nb_Ifaces | - -- +------------------+ +-------------------+ +------------+ - -- |table of primitive| | table of | | table | - -- : operation : : ancestor : : of : - -- | kinds | | tags | | interfaces | - -- +------------------+ +-------------------+ +------------+ - -- |table of | - -- : entry : - -- | indexes | - -- +------------------+ - - -- Structure of the GNAT Secondary Dispatch Table - - -- +--------------------+ - -- | Signature | - -- +--------------------+ - -- | Tagged_Kind | - -- +--------------------+ Predef Prims - -- | Predef_Prims -----------------------------> +------------+ - -- +--------------------+ | table of | - -- | Offset_To_Top | | predefined | - -- +--------------------+ | primitives | - -- | OSD_Ptr |---> Object Specific Data | thunks | - -- Tag ---> +--------------------+ +---------------+ +------------+ - -- | table of | | num prim ops | - -- : primitive op : +---------------+ - -- | thunk pointers | | table of | - -- +--------------------+ + primitive | - -- | op offsets | - -- +---------------+ - - -- The runtime information kept for each tagged type is separated into two - -- objects: the Dispatch Table and the Type Specific Data record. - - package SSE renames System.Storage_Elements; - - subtype Cstring is String (Positive); - type Cstring_Ptr is access all Cstring; - pragma No_Strict_Aliasing (Cstring_Ptr); - - -- Declarations for the table of interfaces - - type Offset_To_Top_Function_Ptr is - access function (This : System.Address) return SSE.Storage_Offset; - -- Type definition used to call the function that is generated by the - -- expander in case of tagged types with discriminants that have secondary - -- dispatch tables. This function provides the Offset_To_Top value in this - -- specific case. - - type Interface_Data_Element is record - Iface_Tag : Tag; - Static_Offset_To_Top : Boolean; - Offset_To_Top_Value : SSE.Storage_Offset; - Offset_To_Top_Func : Offset_To_Top_Function_Ptr; - Secondary_DT : Tag; - end record; - -- If some ancestor of the tagged type has discriminants the field - -- Static_Offset_To_Top is False and the field Offset_To_Top_Func - -- is used to store the access to the function generated by the - -- expander which provides this value; otherwise Static_Offset_To_Top - -- is True and such value is stored in the Offset_To_Top_Value field. - -- Secondary_DT references a secondary dispatch table whose contents - -- are pointers to the primitives of the tagged type that cover the - -- interface primitives. Secondary_DT gives support to dispatching - -- calls through interface types associated with Generic Dispatching - -- Constructors. - - type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; - - type Interface_Data (Nb_Ifaces : Positive) is record - Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); - end record; - - type Interface_Data_Ptr is access all Interface_Data; - -- Table of abstract interfaces used to give support to backward interface - -- conversions and also to IW_Membership. - - -- Primitive operation kinds. These values differentiate the kinds of - -- callable entities stored in the dispatch table. Certain kinds may - -- not be used, but are added for completeness. - - type Prim_Op_Kind is - (POK_Function, - POK_Procedure, - POK_Protected_Entry, - POK_Protected_Function, - POK_Protected_Procedure, - POK_Task_Entry, - POK_Task_Function, - POK_Task_Procedure); - - -- Select specific data types - - type Select_Specific_Data_Element is record - Index : Positive; - Kind : Prim_Op_Kind; - end record; - - type Select_Specific_Data_Array is - array (Positive range <>) of Select_Specific_Data_Element; - - type Select_Specific_Data (Nb_Prim : Positive) is record - SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); - -- NOTE: Nb_Prim is the number of non-predefined primitive operations - end record; - - type Select_Specific_Data_Ptr is access all Select_Specific_Data; - -- A table used to store the primitive operation kind and entry index of - -- primitive subprograms of a type that implements a limited interface. - -- The Select Specific Data table resides in the Type Specific Data of a - -- type. This construct is used in the handling of dispatching triggers - -- in select statements. - - type Prim_Ptr is access procedure; - type Address_Array is array (Positive range <>) of Prim_Ptr; - - subtype Dispatch_Table is Address_Array (1 .. 1); - -- Used by GDB to identify the _tags and traverse the run-time structure - -- associated with tagged types. For compatibility with older versions of - -- gdb, its name must not be changed. - - type Tag is access all Dispatch_Table; - pragma No_Strict_Aliasing (Tag); - - type Interface_Tag is access all Dispatch_Table; - - No_Tag : constant Tag := null; - - -- The expander ensures that Tag objects reference the Prims_Ptr component - -- of the wrapper. - - type Tag_Ptr is access all Tag; - pragma No_Strict_Aliasing (Tag_Ptr); - - type Offset_To_Top_Ptr is access all SSE.Storage_Offset; - pragma No_Strict_Aliasing (Offset_To_Top_Ptr); - - type Tag_Table is array (Natural range <>) of Tag; - - type Size_Ptr is - access function (A : System.Address) return Long_Long_Integer; - - type Type_Specific_Data (Idepth : Natural) is record - -- The discriminant Idepth is the Inheritance Depth Level: Used to - -- implement the membership test associated with single inheritance of - -- tagged types in constant-time. It also indicates the size of the - -- Tags_Table component. - - Access_Level : Natural; - -- Accessibility level required to give support to Ada 2005 nested type - -- extensions. This feature allows safe nested type extensions by - -- shifting the accessibility checks to certain operations, rather than - -- being enforced at the type declaration. In particular, by performing - -- run-time accessibility checks on class-wide allocators, class-wide - -- function return, and class-wide stream I/O, the danger of objects - -- outliving their type declaration can be eliminated (Ada 2005: AI-344) - - Alignment : Natural; - Expanded_Name : Cstring_Ptr; - External_Tag : Cstring_Ptr; - HT_Link : Tag_Ptr; - -- Components used to support to the Ada.Tags subprograms in RM 3.9 - - -- Note: Expanded_Name is referenced by GDB to determine the actual name - -- of the tagged type. Its requirements are: 1) it must have this exact - -- name, and 2) its contents must point to a C-style Nul terminated - -- string containing its expanded name. GDB has no requirement on a - -- given position inside the record. - - Transportable : Boolean; - -- Used to check RM E.4(18), set for types that satisfy the requirements - -- for being used in remote calls as actuals for classwide formals or as - -- return values for classwide functions. - - Is_Abstract : Boolean; - -- True if the type is abstract (Ada 2012: AI05-0173) - - Needs_Finalization : Boolean; - -- Used to dynamically check whether an object is controlled or not - - Size_Func : Size_Ptr; - -- Pointer to the subprogram computing the _size of the object. Used by - -- the run-time whenever a call to the 'size primitive is required. We - -- cannot assume that the contents of dispatch tables are addresses - -- because in some architectures the ABI allows descriptors. - - Interfaces_Table : Interface_Data_Ptr; - -- Pointer to the table of interface tags. It is used to implement the - -- membership test associated with interfaces and also for backward - -- abstract interface type conversions (Ada 2005:AI-251) - - SSD : Select_Specific_Data_Ptr; - -- Pointer to a table of records used in dispatching selects. This field - -- has a meaningful value for all tagged types that implement a limited, - -- protected, synchronized or task interfaces and have non-predefined - -- primitive operations. - - Tags_Table : Tag_Table (0 .. Idepth); - -- Table of ancestor tags. Its size actually depends on the inheritance - -- depth level of the tagged type. - end record; - - type Type_Specific_Data_Ptr is access all Type_Specific_Data; - pragma No_Strict_Aliasing (Type_Specific_Data_Ptr); - - -- Declarations for the dispatch table record - - type Signature_Kind is - (Unknown, - Primary_DT, - Secondary_DT); - - -- Tagged type kinds with respect to concurrency and limitedness - - type Tagged_Kind is - (TK_Abstract_Limited_Tagged, - TK_Abstract_Tagged, - TK_Limited_Tagged, - TK_Protected, - TK_Tagged, - TK_Task); - - type Dispatch_Table_Wrapper (Num_Prims : Natural) is record - Signature : Signature_Kind; - Tag_Kind : Tagged_Kind; - Predef_Prims : System.Address; - -- Pointer to the dispatch table of predefined Ada primitives - - -- According to the C++ ABI the components Offset_To_Top and TSD are - -- stored just "before" the dispatch table, and they are referenced with - -- negative offsets referring to the base of the dispatch table. The - -- _Tag (or the VTable_Ptr in C++ terminology) must point to the base - -- of the virtual table, just after these components, to point to the - -- Prims_Ptr table. - - Offset_To_Top : SSE.Storage_Offset; - TSD : System.Address; - - Prims_Ptr : aliased Address_Array (1 .. Num_Prims); - -- The size of the Prims_Ptr array actually depends on the tagged type - -- to which it applies. For each tagged type, the expander computes the - -- actual array size, allocates the Dispatch_Table record accordingly. - end record; - - type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; - pragma No_Strict_Aliasing (Dispatch_Table_Ptr); - - -- The following type declaration is used by the compiler when the program - -- is compiled with restriction No_Dispatching_Calls. It is also used with - -- interface types to generate the tag and run-time information associated - -- with them. - - type No_Dispatch_Table_Wrapper is record - NDT_TSD : System.Address; - NDT_Prims_Ptr : Natural; - end record; - - DT_Predef_Prims_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / - System.Storage_Unit)); - -- Size of the Predef_Prims field of the Dispatch_Table - - DT_Offset_To_Top_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / - System.Storage_Unit)); - -- Size of the Offset_To_Top field of the Dispatch Table - - DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := - SSE.Storage_Count - (1 * (Standard'Address_Size / - System.Storage_Unit)); - -- Size of the Typeinfo_Ptr field of the Dispatch Table - - use type System.Storage_Elements.Storage_Offset; - - DT_Offset_To_Top_Offset : constant SSE.Storage_Count := - DT_Typeinfo_Ptr_Size - + DT_Offset_To_Top_Size; - - DT_Predef_Prims_Offset : constant SSE.Storage_Count := - DT_Typeinfo_Ptr_Size - + DT_Offset_To_Top_Size - + DT_Predef_Prims_Size; - -- Offset from Prims_Ptr to Predef_Prims component - - -- Object Specific Data record of secondary dispatch tables - - type Object_Specific_Data_Array is array (Positive range <>) of Positive; - - type Object_Specific_Data (OSD_Num_Prims : Positive) is record - OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims); - -- Table used in secondary DT to reference their counterpart in the - -- select specific data (in the TSD of the primary DT). This construct - -- is used in the handling of dispatching triggers in select statements. - -- Nb_Prim is the number of non-predefined primitive operations. - end record; - - type Object_Specific_Data_Ptr is access all Object_Specific_Data; - pragma No_Strict_Aliasing (Object_Specific_Data_Ptr); - - -- The following subprogram specifications are placed here instead of the - -- package body to see them from the frontend through rtsfind. - - function Base_Address (This : System.Address) return System.Address; - -- Ada 2005 (AI-251): Displace "This" to point to the base address of the - -- object (that is, the address of the primary tag of the object). - - procedure Check_TSD (TSD : Type_Specific_Data_Ptr); - -- Ada 2012 (AI-113): Raise Program_Error if the external tag of this TSD - -- is the same as the external tag for some other tagged type declaration. - - function Displace (This : System.Address; T : Tag) return System.Address; - -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch - -- table of T. - - function Secondary_Tag (T, Iface : Tag) return Tag; - -- Ada 2005 (AI-251): Given a primary tag T associated with a tagged type - -- Typ, search for the secondary tag of the interface type Iface covered - -- by Typ. - - function DT (T : Tag) return Dispatch_Table_Ptr; - -- Return the pointer to the TSD record associated with T - - function Get_Entry_Index (T : Tag; Position : Positive) return Positive; - -- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry) - -- given a dispatch table T and a position of a primitive operation in T. - - function Get_Offset_Index - (T : Tag; - Position : Positive) return Positive; - -- Ada 2005 (AI-251): Given a pointer to a secondary dispatch table (T) - -- and a position of an operation in the DT, retrieve the corresponding - -- operation's position in the primary dispatch table from the Offset - -- Specific Data table of T. - - function Get_Prim_Op_Kind - (T : Tag; - Position : Positive) return Prim_Op_Kind; - -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch - -- table T and a position of a primitive operation in T. - - function Get_Tagged_Kind (T : Tag) return Tagged_Kind; - -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary - -- dispatch table, return the tagged kind of a type in the context of - -- concurrency and limitedness. - - function IW_Membership (This : System.Address; T : Tag) return Boolean; - -- Ada 2005 (AI-251): General routine that checks if a given object - -- implements a tagged type. Its common usage is to check if Obj is in - -- Iface'Class, but it is also used to check if a class-wide interface - -- implements a given type (Iface_CW_Typ in T'Class). For example: - -- - -- type I is interface; - -- type T is tagged ... - -- - -- function Test (O : I'Class) is - -- begin - -- return O in T'Class. - -- end Test; - - function Offset_To_Top - (This : System.Address) return SSE.Storage_Offset; - -- Ada 2005 (AI-251): Returns the current value of the Offset_To_Top - -- component available in the prologue of the dispatch table. If the parent - -- of the tagged type has discriminants this value is stored in a record - -- component just immediately after the tag component. - - function Needs_Finalization (T : Tag) return Boolean; - -- A helper routine used in conjunction with finalization collections which - -- service class-wide types. The function dynamically determines whether an - -- object is controlled or has controlled components. - - function Parent_Size - (Obj : System.Address; - T : Tag) return SSE.Storage_Count; - -- Computes the size the ancestor part of a tagged extension object whose - -- address is 'obj' by calling indirectly the ancestor _size function. The - -- ancestor is the parent of the type represented by tag T. This function - -- assumes that _size is always in slot one of the dispatch table. - - procedure Register_Interface_Offset - (Prim_T : Tag; - Interface_T : Tag; - Is_Static : Boolean; - Offset_Value : SSE.Storage_Offset; - Offset_Func : Offset_To_Top_Function_Ptr); - -- Register in the table of interfaces of the tagged type associated with - -- Prim_T the offset of the record component associated with the progenitor - -- Interface_T (that is, the distance from "This" to the object component - -- containing the tag of the secondary dispatch table). In case of constant - -- offset, Is_Static is true and Offset_Value has such value. In case of - -- variable offset, Is_Static is false and Offset_Func is an access to - -- function that must be called to evaluate the offset. - - procedure Register_Tag (T : Tag); - -- Insert the Tag and its associated external_tag in a table for the sake - -- of Internal_Tag. - - procedure Set_Dynamic_Offset_To_Top - (This : System.Address; - Prim_T : Tag; - Interface_T : Tag; - Offset_Value : SSE.Storage_Offset; - Offset_Func : Offset_To_Top_Function_Ptr); - -- Ada 2005 (AI-251): The compiler generates calls to this routine only - -- when initializing the Offset_To_Top field of dispatch tables of tagged - -- types that cover interface types whose parent type has variable size - -- components. - -- - -- "This" is the object whose dispatch table is being initialized. Prim_T - -- is the primary tag of such object. Interface_T is the interface tag for - -- which the secondary dispatch table is being initialized. Offset_Value - -- is the distance from "This" to the object component containing the tag - -- of the secondary dispatch table (a zero value means that this interface - -- shares the primary dispatch table). Offset_Func references a function - -- that must be called to evaluate the offset at run time. This routine - -- also takes care of registering these values in the table of interfaces - -- of the type. - - procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); - -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's - -- TSD table indexed by Position. - - procedure Set_Prim_Op_Kind - (T : Tag; - Position : Positive; - Value : Prim_Op_Kind); - -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD - -- table indexed by Position. - - procedure Unregister_Tag (T : Tag); - -- Remove a particular tag from the external tag hash table - - Max_Predef_Prims : constant Positive := 15; - -- Number of reserved slots for the following predefined ada primitives: - -- - -- 1. Size - -- 2. Read - -- 3. Write - -- 4. Input - -- 5. Output - -- 6. "=" - -- 7. assignment - -- 8. deep adjust - -- 9. deep finalize - -- 10. async select - -- 11. conditional select - -- 12. prim_op kind - -- 13. task_id - -- 14. dispatching requeue - -- 15. timed select - -- - -- The compiler checks that the value here is correct - - subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims); - type Predef_Prims_Table_Ptr is access Predef_Prims_Table; - pragma No_Strict_Aliasing (Predef_Prims_Table_Ptr); - - type Addr_Ptr is access System.Address; - pragma No_Strict_Aliasing (Addr_Ptr); - -- This type is used by the frontend to generate the code that handles - -- dispatch table slots of types declared at the local level. - -end Ada.Tags; diff --git a/gcc/ada/a-teioed.adb b/gcc/ada/a-teioed.adb deleted file mode 100644 index 3c3e874..0000000 --- a/gcc/ada/a-teioed.adb +++ /dev/null @@ -1,2860 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . E D I T I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -package body Ada.Text_IO.Editing is - - package Strings renames Ada.Strings; - package Strings_Fixed renames Ada.Strings.Fixed; - package Text_IO renames Ada.Text_IO; - - --------------------- - -- Blank_When_Zero -- - --------------------- - - function Blank_When_Zero (Pic : Picture) return Boolean is - begin - return Pic.Contents.Original_BWZ; - end Blank_When_Zero; - - ------------ - -- Expand -- - ------------ - - function Expand (Picture : String) return String is - Result : String (1 .. MAX_PICSIZE); - Picture_Index : Integer := Picture'First; - Result_Index : Integer := Result'First; - Count : Natural; - Last : Integer; - - package Int_IO is new Ada.Text_IO.Integer_IO (Integer); - - begin - if Picture'Length < 1 then - raise Picture_Error; - end if; - - if Picture (Picture'First) = '(' then - raise Picture_Error; - end if; - - loop - case Picture (Picture_Index) is - when '(' => - Int_IO.Get - (Picture (Picture_Index + 1 .. Picture'Last), Count, Last); - - if Picture (Last + 1) /= ')' then - raise Picture_Error; - end if; - - -- In what follows note that one copy of the repeated character - -- has already been made, so a count of one is a no-op, and a - -- count of zero erases a character. - - if Result_Index + Count - 2 > Result'Last then - raise Picture_Error; - end if; - - for J in 2 .. Count loop - Result (Result_Index + J - 2) := Picture (Picture_Index - 1); - end loop; - - Result_Index := Result_Index + Count - 1; - - -- Last + 1 was a ')' throw it away too - - Picture_Index := Last + 2; - - when ')' => - raise Picture_Error; - - when others => - if Result_Index > Result'Last then - raise Picture_Error; - end if; - - Result (Result_Index) := Picture (Picture_Index); - Picture_Index := Picture_Index + 1; - Result_Index := Result_Index + 1; - end case; - - exit when Picture_Index > Picture'Last; - end loop; - - return Result (1 .. Result_Index - 1); - - exception - when others => - raise Picture_Error; - end Expand; - - ------------------- - -- Format_Number -- - ------------------- - - function Format_Number - (Pic : Format_Record; - Number : String; - Currency_Symbol : String; - Fill_Character : Character; - Separator_Character : Character; - Radix_Point : Character) return String - is - Attrs : Number_Attributes := Parse_Number_String (Number); - Position : Integer; - Rounded : String := Number; - - Sign_Position : Integer := Pic.Sign_Position; -- may float. - - Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded; - Last : Integer; - Currency_Pos : Integer := Pic.Start_Currency; - In_Currency : Boolean := False; - - Dollar : Boolean := False; - -- Overridden immediately if necessary - - Zero : Boolean := True; - -- Set to False when a non-zero digit is output - - begin - - -- If the picture has fewer decimal places than the number, the image - -- must be rounded according to the usual rules. - - if Attrs.Has_Fraction then - declare - R : constant Integer := - (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) - - Pic.Max_Trailing_Digits; - R_Pos : Integer; - - begin - if R > 0 then - R_Pos := Attrs.End_Of_Fraction - R; - - if Rounded (R_Pos + 1) > '4' then - - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - - while R_Pos > 1 loop - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - exit; - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - end if; - end loop; - - -- The rounding may add a digit in front. Either the - -- leading blank or the sign (already captured) can - -- be overwritten. - - if R_Pos = 1 then - Rounded (R_Pos) := '1'; - Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; - end if; - end if; - end if; - end if; - end; - end if; - - if Pic.Start_Currency /= Invalid_Position then - Dollar := Answer (Pic.Start_Currency) = '$'; - end if; - - -- Fix up "direct inserts" outside the playing field. Set up as one - -- loop to do the beginning, one (reverse) loop to do the end. - - Last := 1; - loop - exit when Last = Pic.Start_Float; - exit when Last = Pic.Radix_Position; - exit when Answer (Last) = '9'; - - case Answer (Last) is - when '_' => - Answer (Last) := Separator_Character; - - when 'b' => - Answer (Last) := ' '; - - when others => - null; - end case; - - exit when Last = Answer'Last; - - Last := Last + 1; - end loop; - - -- Now for the end... - - for J in reverse Last .. Answer'Last loop - exit when J = Pic.Radix_Position; - - -- Do this test First, Separator_Character can equal Pic.Floater - - if Answer (J) = Pic.Floater then - exit; - end if; - - case Answer (J) is - when '_' => - Answer (J) := Separator_Character; - - when 'b' => - Answer (J) := ' '; - - when '9' => - exit; - - when others => - null; - end case; - end loop; - - -- Non-floating sign - - if Pic.Start_Currency /= -1 - and then Answer (Pic.Start_Currency) = '#' - and then Pic.Floater /= '#' - then - if Currency_Symbol'Length > - Pic.End_Currency - Pic.Start_Currency + 1 - then - raise Picture_Error; - - elsif Currency_Symbol'Length = - Pic.End_Currency - Pic.Start_Currency + 1 - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - Currency_Symbol; - - elsif Pic.Radix_Position = Invalid_Position - or else Pic.Start_Currency < Pic.Radix_Position - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. - Pic.End_Currency) := Currency_Symbol; - - else - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.Start_Currency .. - Pic.Start_Currency + Currency_Symbol'Length - 1) := - Currency_Symbol; - end if; - end if; - - -- Fill in leading digits - - if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > - Pic.Max_Leading_Digits - then - raise Ada.Text_IO.Layout_Error; - end if; - - Position := - (if Pic.Radix_Position = Invalid_Position - then Answer'Last - else Pic.Radix_Position - 1); - - for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop - while Answer (Position) /= '9' - and then - Answer (Position) /= Pic.Floater - loop - if Answer (Position) = '_' then - Answer (Position) := Separator_Character; - - elsif Answer (Position) = 'b' then - Answer (Position) := ' '; - end if; - - Position := Position - 1; - end loop; - - Answer (Position) := Rounded (J); - - if Rounded (J) /= '0' then - Zero := False; - end if; - - Position := Position - 1; - end loop; - - -- Do lead float - - if Pic.Start_Float = Invalid_Position then - - -- No leading floats, but need to change '9' to '0', '_' to - -- Separator_Character and 'b' to ' '. - - for J in Last .. Position loop - - -- Last set when fixing the "uninteresting" leaders above. - -- Don't duplicate the work. - - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - elsif Pic.Floater = '<' - or else - Pic.Floater = '+' - or else - Pic.Floater = '-' - then - for J in Pic.End_Float .. Position loop -- May be null range. - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Sign_Position := Position; - - elsif Pic.Floater = '$' then - - for J in Pic.End_Float .. Position loop -- May be null range. - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := ' '; -- no separators before leftmost digit. - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Currency_Pos := Position; - - elsif Pic.Floater = '*' then - - for J in Pic.End_Float .. Position loop -- May be null range. - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := Fill_Character; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position loop - Answer (J) := Fill_Character; - end loop; - - else - if Pic.Floater = '#' then - Currency_Pos := Currency_Symbol'Length; - In_Currency := True; - end if; - - for J in reverse Pic.Start_Float .. Position loop - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'b' | '/' => - if In_Currency and then Currency_Pos > 0 then - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - else - Answer (J) := ' '; - end if; - - when 'Z' | '0' => - Answer (J) := ' '; - - when '9' => - Answer (J) := '0'; - - when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => - null; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when '_' => - case Pic.Floater is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'b' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when others => - null; - end case; - - when others => - null; - end case; - end loop; - - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Ada.Text_IO.Layout_Error; - end if; - end if; - - -- Do sign - - if Sign_Position = Invalid_Position then - if Attrs.Negative then - raise Ada.Text_IO.Layout_Error; - end if; - - else - if Attrs.Negative then - case Answer (Sign_Position) is - when 'C' | 'D' | '-' => - null; - - when '+' => - Answer (Sign_Position) := '-'; - - when '<' => - Answer (Sign_Position) := '('; - Answer (Pic.Second_Sign) := ')'; - - when others => - raise Picture_Error; - end case; - - else -- positive - - case Answer (Sign_Position) is - when '-' => - Answer (Sign_Position) := ' '; - - when '<' | 'C' | 'D' => - Answer (Sign_Position) := ' '; - Answer (Pic.Second_Sign) := ' '; - - when '+' => - null; - - when others => - raise Picture_Error; - end case; - end if; - end if; - - -- Fill in trailing digits - - if Pic.Max_Trailing_Digits > 0 then - - if Attrs.Has_Fraction then - Position := Attrs.Start_Of_Fraction; - Last := Pic.Radix_Position + 1; - - for J in Last .. Answer'Last loop - if Answer (J) = '9' or else Answer (J) = Pic.Floater then - Answer (J) := Rounded (Position); - - if Rounded (Position) /= '0' then - Zero := False; - end if; - - Position := Position + 1; - Last := J + 1; - - -- Used up fraction but remember place in Answer - - exit when Position > Attrs.End_Of_Fraction; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - end if; - - Last := J + 1; - end loop; - - Position := Last; - - else - Position := Pic.Radix_Position + 1; - end if; - - -- Now fill remaining 9's with zeros and _ with separators - - Last := Answer'Last; - - for J in Position .. Last loop - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = Pic.Floater then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - end loop; - - Position := Last + 1; - - else - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Ada.Text_IO.Layout_Error; - end if; - - -- No trailing digits, but now J may need to stick in a currency - -- symbol or sign. - - Position := - (if Pic.Start_Currency = Invalid_Position - then Answer'Last + 1 - else Pic.Start_Currency); - end if; - - for J in Position .. Answer'Last loop - if Pic.Start_Currency /= Invalid_Position - and then Answer (Pic.Start_Currency) = '#' - then - Currency_Pos := 1; - end if; - - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'b' => - if In_Currency then - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - - if Currency_Pos > Currency_Symbol'Length then - In_Currency := False; - end if; - end if; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - - else - In_Currency := True; - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - - if Currency_Pos > Currency_Symbol'Length then - In_Currency := False; - end if; - end if; - - when '_' => - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - - case Pic.Floater is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'z' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - end if; - - when others => - null; - end case; - - when others => - exit; - end case; - end loop; - - -- Now get rid of Blank_when_Zero and complete Star fill - - if Zero and then Pic.Blank_When_Zero then - - -- Value is zero, and blank it - - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position - and then Answer (Pic.Radix_Position) = 'V' - then - Last := Last - 1; - end if; - - return String'(1 .. Last => ' '); - - elsif Zero and then Pic.Star_Fill then - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position then - - if Answer (Pic.Radix_Position) = 'V' then - Last := Last - 1; - - elsif Dollar then - if Pic.Radix_Position > Pic.Start_Currency then - return String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - String'(Pic.Radix_Position + 1 .. Last => '*'); - - else - return - String' - (1 .. - Pic.Radix_Position + Currency_Symbol'Length - 2 => - '*') & Radix_Point & - String' - (Pic.Radix_Position + Currency_Symbol'Length .. Last - => '*'); - end if; - - else - return String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - String'(Pic.Radix_Position + 1 .. Last => '*'); - end if; - end if; - - return String'(1 .. Last => '*'); - end if; - - -- This was once a simple return statement, now there are nine different - -- return cases. Not to mention the five above to deal with zeros. Why - -- not split things out? - - -- Processing the radix and sign expansion separately would require - -- lots of copying--the string and some of its indexes--without - -- really simplifying the logic. The cases are: - - -- 1) Expand $, replace '.' with Radix_Point - -- 2) No currency expansion, replace '.' with Radix_Point - -- 3) Expand $, radix blanked - -- 4) No currency expansion, radix blanked - -- 5) Elide V - -- 6) Expand $, Elide V - -- 7) Elide V, Expand $ (Two cases depending on order.) - -- 8) No radix, expand $ - -- 9) No radix, no currency expansion - - if Pic.Radix_Position /= Invalid_Position then - - if Answer (Pic.Radix_Position) = '.' then - Answer (Pic.Radix_Position) := Radix_Point; - - if Dollar then - - -- 1) Expand $, replace '.' with Radix_Point - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 2) No currency expansion, replace '.' with Radix_Point - - return Answer; - end if; - - elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. - if Dollar then - - -- 3) Expand $, radix blanked - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 4) No expansion, radix blanked - - return Answer; - end if; - - -- V cases - - else - if not Dollar then - - -- 5) Elide V - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - elsif Currency_Pos < Pic.Radix_Position then - - -- 6) Expand $, Elide V - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - else - -- 7) Elide V, Expand $ - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & - Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - end if; - end if; - - elsif Dollar then - - -- 8) No radix, expand $ - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 9) No radix, no currency expansion - - return Answer; - end if; - end Format_Number; - - ------------------------- - -- Parse_Number_String -- - ------------------------- - - function Parse_Number_String (Str : String) return Number_Attributes is - Answer : Number_Attributes; - - begin - for J in Str'Range loop - case Str (J) is - when ' ' => - null; -- ignore - - when '1' .. '9' => - - -- Decide if this is the start of a number. - -- If so, figure out which one... - - if Answer.Has_Fraction then - Answer.End_Of_Fraction := J; - else - if Answer.Start_Of_Int = Invalid_Position then - -- start integer - Answer.Start_Of_Int := J; - end if; - Answer.End_Of_Int := J; - end if; - - when '0' => - - -- Only count a zero before the decimal point if it follows a - -- non-zero digit. After the decimal point, zeros will be - -- counted if followed by a non-zero digit. - - if not Answer.Has_Fraction then - if Answer.Start_Of_Int /= Invalid_Position then - Answer.End_Of_Int := J; - end if; - end if; - - when '-' => - - -- Set negative - - Answer.Negative := True; - - when '.' => - - -- Close integer, start fraction - - if Answer.Has_Fraction then - raise Picture_Error; - end if; - - -- Two decimal points is a no-no - - Answer.Has_Fraction := True; - Answer.End_Of_Fraction := J; - - -- Could leave this at Invalid_Position, but this seems the - -- right way to indicate a null range... - - Answer.Start_Of_Fraction := J + 1; - Answer.End_Of_Int := J - 1; - - when others => - raise Picture_Error; -- can this happen? probably not - end case; - end loop; - - if Answer.Start_Of_Int = Invalid_Position then - Answer.Start_Of_Int := Answer.End_Of_Int + 1; - end if; - - -- No significant (integer) digits needs a null range - - return Answer; - end Parse_Number_String; - - ---------------- - -- Pic_String -- - ---------------- - - -- The following ensures that we return B and not b being careful not - -- to break things which expect lower case b for blank. See CXF3A02. - - function Pic_String (Pic : Picture) return String is - Temp : String (1 .. Pic.Contents.Picture.Length) := - Pic.Contents.Picture.Expanded; - begin - for J in Temp'Range loop - if Temp (J) = 'b' then - Temp (J) := 'B'; - end if; - end loop; - - return Temp; - end Pic_String; - - ------------------ - -- Precalculate -- - ------------------ - - procedure Precalculate (Pic : in out Format_Record) is - Debug : constant Boolean := False; - -- Set True to generate debug output - - Computed_BWZ : Boolean := True; - - type Legality is (Okay, Reject); - - State : Legality := Reject; - -- Start in reject, which will reject null strings - - Index : Pic_Index := Pic.Picture.Expanded'First; - - function At_End return Boolean; - pragma Inline (At_End); - - procedure Set_State (L : Legality); - pragma Inline (Set_State); - - function Look return Character; - pragma Inline (Look); - - function Is_Insert return Boolean; - pragma Inline (Is_Insert); - - procedure Skip; - pragma Inline (Skip); - - procedure Debug_Start (Name : String); - pragma Inline (Debug_Start); - - procedure Debug_Integer (Value : Integer; S : String); - pragma Inline (Debug_Integer); - - procedure Trailing_Currency; - procedure Trailing_Bracket; - procedure Number_Fraction; - procedure Number_Completion; - procedure Number_Fraction_Or_Bracket; - procedure Number_Fraction_Or_Z_Fill; - procedure Zero_Suppression; - procedure Floating_Bracket; - procedure Number_Fraction_Or_Star_Fill; - procedure Star_Suppression; - procedure Number_Fraction_Or_Dollar; - procedure Leading_Dollar; - procedure Number_Fraction_Or_Pound; - procedure Leading_Pound; - procedure Picture; - procedure Floating_Plus; - procedure Floating_Minus; - procedure Picture_Plus; - procedure Picture_Minus; - procedure Picture_Bracket; - procedure Number; - procedure Optional_RHS_Sign; - procedure Picture_String; - procedure Set_Debug; - - ------------ - -- At_End -- - ------------ - - function At_End return Boolean is - begin - Debug_Start ("At_End"); - return Index > Pic.Picture.Length; - end At_End; - - -------------- - -- Set_Debug-- - -------------- - - -- Needed to have a procedure to pass to pragma Debug - - procedure Set_Debug is - begin - -- Uncomment this line and make Debug a variable to enable debug - - -- Debug := True; - - null; - end Set_Debug; - - ------------------- - -- Debug_Integer -- - ------------------- - - procedure Debug_Integer (Value : Integer; S : String) is - use Ada.Text_IO; -- needed for > - - begin - if Debug and then Value > 0 then - if Ada.Text_IO.Col > 70 - S'Length then - Ada.Text_IO.New_Line; - end if; - - Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ','); - end if; - end Debug_Integer; - - ----------------- - -- Debug_Start -- - ----------------- - - procedure Debug_Start (Name : String) is - begin - if Debug then - Ada.Text_IO.Put_Line (" In " & Name & '.'); - end if; - end Debug_Start; - - ---------------------- - -- Floating_Bracket -- - ---------------------- - - -- Note that Floating_Bracket is only called with an acceptable - -- prefix. But we don't set Okay, because we must end with a '>'. - - procedure Floating_Bracket is - begin - Debug_Start ("Floating_Bracket"); - - -- Two different floats not allowed - - if Pic.Floater /= '!' and then Pic.Floater /= '<' then - raise Picture_Error; - - else - Pic.Floater := '<'; - end if; - - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - - -- First bracket wasn't counted... - - Skip; -- known '<' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when '9' => - Number_Completion; - - when '$' => - Leading_Dollar; - - when '#' => - Leading_Pound; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Bracket; - return; - - when others => - return; - end case; - end loop; - end Floating_Bracket; - - -------------------- - -- Floating_Minus -- - -------------------- - - procedure Floating_Minus is - begin - Debug_Start ("Floating_Minus"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '-' then - loop - if At_End then - return; - end if; - - case Look is - when '-' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Minus; - - ------------------- - -- Floating_Plus -- - ------------------- - - procedure Floating_Plus is - begin - Debug_Start ("Floating_Plus"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '+' then - loop - if At_End then - return; - end if; - - case Look is - when '+' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Plus; - - --------------- - -- Is_Insert -- - --------------- - - function Is_Insert return Boolean is - begin - if At_End then - return False; - end if; - - case Pic.Picture.Expanded (Index) is - when '_' | '0' | '/' => - return True; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; -- canonical - return True; - - when others => - return False; - end case; - end Is_Insert; - - -------------------- - -- Leading_Dollar -- - -------------------- - - -- Note that Leading_Dollar can be called in either State. It will set - -- state to Okay only if a 9 or (second) $ is encountered. - - -- Also notice the tricky bit with State and Zero_Suppression. - -- Zero_Suppression is Picture_Error if a '$' or a '9' has been - -- encountered, exactly the cases where State has been set. - - procedure Leading_Dollar is - begin - Debug_Start ("Leading_Dollar"); - - -- Treat as a floating dollar, and unwind otherwise - - if Pic.Floater /= '!' and then Pic.Floater /= '$' then - - -- Two floats not allowed - - raise Picture_Error; - - else - Pic.Floater := '$'; - end if; - - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Skip; -- known '$' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - -- A trailing insertion character is not part of the - -- floating currency, so need to look ahead. - - if Look /= '$' then - Pic.End_Float := Pic.End_Float - 1; - end if; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if State = Okay then - raise Picture_Error; - else - -- Overwrite Floater and Start_Float - - Pic.Floater := 'Z'; - Pic.Start_Float := Index; - Zero_Suppression; - end if; - - when '*' => - if State = Okay then - raise Picture_Error; - else - -- Overwrite Floater and Start_Float - - Pic.Floater := '*'; - Pic.Start_Float := Index; - Star_Suppression; - end if; - - when '$' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); Skip; - - when '9' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- A single dollar does not a floating make - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one dollar before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Dollar; - return; - - when others => - return; - end case; - end loop; - end Leading_Dollar; - - ------------------- - -- Leading_Pound -- - ------------------- - - -- This one is complex. A Leading_Pound can be fixed or floating, - -- but in some cases the decision has to be deferred until we leave - -- this procedure. Also note that Leading_Pound can be called in - -- either State. - - -- It will set state to Okay only if a 9 or (second) # is encountered - - -- One Last note: In ambiguous cases, the currency is treated as - -- floating unless there is only one '#'. - - procedure Leading_Pound is - - Inserts : Boolean := False; - -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered - - Must_Float : Boolean := False; - -- Set to true if a '#' occurs after an insert - - begin - Debug_Start ("Leading_Pound"); - - -- Treat as a floating currency. If it isn't, this will be - -- overwritten later. - - if Pic.Floater /= '!' and then Pic.Floater /= '#' then - - -- Two floats not allowed - - raise Picture_Error; - - else - Pic.Floater := '#'; - end if; - - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Pic.Max_Currency_Digits := 1; -- we've seen one. - - Skip; -- known '#' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Overwrite Floater and Start_Float - - Pic.Floater := 'Z'; - Pic.Start_Float := Index; - Zero_Suppression; - end if; - - when '*' => - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Overwrite Floater and Start_Float - Pic.Floater := '*'; - Pic.Start_Float := Index; - Star_Suppression; - end if; - - when '#' => - if Inserts then - Must_Float := True; - end if; - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); - Skip; - - when '9' => - if State /= Okay then - - -- A single '#' doesn't float - - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one pound before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Pound; - return; - - when others => - return; - end case; - end loop; - end Leading_Pound; - - ---------- - -- Look -- - ---------- - - function Look return Character is - begin - if At_End then - raise Picture_Error; - end if; - - return Pic.Picture.Expanded (Index); - end Look; - - ------------ - -- Number -- - ------------ - - procedure Number is - begin - Debug_Start ("Number"); - - loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - end case; - - if At_End then - return; - end if; - - -- Will return in Okay state if a '9' was seen - - end loop; - end Number; - - ----------------------- - -- Number_Completion -- - ----------------------- - - procedure Number_Completion is - begin - Debug_Start ("Number_Completion"); - - while not At_End loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - end case; - end loop; - end Number_Completion; - - --------------------- - -- Number_Fraction -- - --------------------- - - procedure Number_Fraction is - begin - -- Note that number fraction can be called in either State. - -- It will set state to Valid only if a 9 is encountered. - - Debug_Start ("Number_Fraction"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Set_State (Okay); Skip; - - when others => - return; - end case; - end loop; - end Number_Fraction; - - -------------------------------- - -- Number_Fraction_Or_Bracket -- - -------------------------------- - - procedure Number_Fraction_Or_Bracket is - begin - Debug_Start ("Number_Fraction_Or_Bracket"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Bracket; - - ------------------------------- - -- Number_Fraction_Or_Dollar -- - ------------------------------- - - procedure Number_Fraction_Or_Dollar is - begin - Debug_Start ("Number_Fraction_Or_Dollar"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Dollar; - - ------------------------------ - -- Number_Fraction_Or_Pound -- - ------------------------------ - - procedure Number_Fraction_Or_Pound is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Pound; - - ---------------------------------- - -- Number_Fraction_Or_Star_Fill -- - ---------------------------------- - - procedure Number_Fraction_Or_Star_Fill is - begin - Debug_Start ("Number_Fraction_Or_Star_Fill"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Star_Fill; - - ------------------------------- - -- Number_Fraction_Or_Z_Fill -- - ------------------------------- - - procedure Number_Fraction_Or_Z_Fill is - begin - Debug_Start ("Number_Fraction_Or_Z_Fill"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Z_Fill; - - ----------------------- - -- Optional_RHS_Sign -- - ----------------------- - - procedure Optional_RHS_Sign is - begin - Debug_Start ("Optional_RHS_Sign"); - - if At_End then - return; - end if; - - case Look is - when '+' | '-' => - Pic.Sign_Position := Index; - Skip; - return; - - when 'C' | 'c' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'C'; - Skip; - - if Look = 'R' or else Look = 'r' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'R'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when 'D' | 'd' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'D'; - Skip; - - if Look = 'B' or else Look = 'b' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'B'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when '>' => - if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then - Pic.Second_Sign := Index; - Skip; - - else - raise Picture_Error; - end if; - - when others => - return; - end case; - end Optional_RHS_Sign; - - ------------- - -- Picture -- - ------------- - - -- Note that Picture can be called in either State - - -- It will set state to Valid only if a 9 is encountered or floating - -- currency is called. - - procedure Picture is - begin - Debug_Start ("Picture"); - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Leading_Dollar; - return; - - when '#' => - Leading_Pound; - return; - - when '9' => - Computed_BWZ := False; - Set_State (Okay); - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - Trailing_Currency; - return; - - when others => - return; - end case; - end loop; - end Picture; - - --------------------- - -- Picture_Bracket -- - --------------------- - - procedure Picture_Bracket is - begin - Pic.Sign_Position := Index; - Debug_Start ("Picture_Bracket"); - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '<'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Bracket - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Set_State (Okay); -- "<<>" is enough. - Floating_Bracket; - Trailing_Currency; - Trailing_Bracket; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Trailing_Bracket; - Set_State (Okay); - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - Trailing_Bracket; - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Picture_Bracket; - - ------------------- - -- Picture_Minus -- - ------------------- - - procedure Picture_Minus is - begin - Debug_Start ("Picture_Minus"); - - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '-'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Minus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "-- " is enough. - Floating_Minus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - - -- Can't have Z and a floating sign - - if State = Okay then - Set_State (Reject); - end if; - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Minus; - - ------------------ - -- Picture_Plus -- - ------------------ - - procedure Picture_Plus is - begin - Debug_Start ("Picture_Plus"); - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '+'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Plus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "++" is enough - Floating_Plus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - if State = Okay then - Set_State (Reject); - end if; - - -- Can't have Z and a floating sign - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - -- '+Z' is acceptable - - Set_State (Okay); - - -- Overwrite Floater and Start_Float - - Pic.Floater := 'Z'; - Pic.Start_Float := Index; - - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Plus; - - -------------------- - -- Picture_String -- - -------------------- - - procedure Picture_String is - begin - Debug_Start ("Picture_String"); - - while Is_Insert loop - Skip; - end loop; - - case Look is - when '$' | '#' => - Picture; - Optional_RHS_Sign; - - when '+' => - Picture_Plus; - - when '-' => - Picture_Minus; - - when '<' => - Picture_Bracket; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '*' => - Star_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '9' | '.' | 'V' | 'v' => - Number; - Trailing_Currency; - Optional_RHS_Sign; - - when others => - raise Picture_Error; - end case; - - -- Blank when zero either if the PIC does not contain a '9' or if - -- requested by the user and no '*'. - - Pic.Blank_When_Zero := - (Computed_BWZ or else Pic.Blank_When_Zero) - and then not Pic.Star_Fill; - - -- Star fill if '*' and no '9' - - Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; - - if not At_End then - Set_State (Reject); - end if; - end Picture_String; - - --------------- - -- Set_State -- - --------------- - - procedure Set_State (L : Legality) is - begin - if Debug then - Ada.Text_IO.Put_Line - (" Set state from " & Legality'Image (State) - & " to " & Legality'Image (L)); - end if; - - State := L; - end Set_State; - - ---------- - -- Skip -- - ---------- - - procedure Skip is - begin - if Debug then - Ada.Text_IO.Put_Line (" Skip " & Pic.Picture.Expanded (Index)); - end if; - - Index := Index + 1; - end Skip; - - ---------------------- - -- Star_Suppression -- - ---------------------- - - procedure Star_Suppression is - begin - Debug_Start ("Star_Suppression"); - - if Pic.Floater /= '!' and then Pic.Floater /= '*' then - - -- Two floats not allowed - - raise Picture_Error; - - else - Pic.Floater := '*'; - end if; - - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - - -- Even a single * is a valid picture - - Pic.Star_Fill := True; - Skip; -- Known * - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Star_Fill; - return; - - when '#' | '$' => - if Pic.Max_Currency_Digits > 0 then - raise Picture_Error; - end if; - - -- Cannot have leading and trailing currency - - Trailing_Currency; - Set_State (Okay); - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Star_Suppression; - - ---------------------- - -- Trailing_Bracket -- - ---------------------- - - procedure Trailing_Bracket is - begin - Debug_Start ("Trailing_Bracket"); - - if Look = '>' then - Pic.Second_Sign := Index; - Skip; - else - raise Picture_Error; - end if; - end Trailing_Bracket; - - ----------------------- - -- Trailing_Currency -- - ----------------------- - - procedure Trailing_Currency is - begin - Debug_Start ("Trailing_Currency"); - - if At_End then - return; - end if; - - if Look = '$' then - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Skip; - - else - while not At_End and then Look = '#' loop - if Pic.Start_Currency = Invalid_Position then - Pic.Start_Currency := Index; - end if; - - Pic.End_Currency := Index; - Skip; - end loop; - end if; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - end Trailing_Currency; - - ---------------------- - -- Zero_Suppression -- - ---------------------- - - procedure Zero_Suppression is - begin - Debug_Start ("Zero_Suppression"); - - Pic.Floater := 'Z'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; -- Known Z - - loop - -- Even a single Z is a valid picture - - if At_End then - Set_State (Okay); - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Set_State (Okay); - Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Z_Fill; - return; - - when '#' | '$' => - Trailing_Currency; - Set_State (Okay); - return; - - when others => - return; - end case; - end loop; - end Zero_Suppression; - - -- Start of processing for Precalculate - - begin - pragma Debug (Set_Debug); - - Picture_String; - - if Debug then - Ada.Text_IO.New_Line; - Ada.Text_IO.Put (" Picture : """ & - Pic.Picture.Expanded (1 .. Pic.Picture.Length) & ""","); - Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',"); - end if; - - if State = Reject then - raise Picture_Error; - end if; - - Debug_Integer (Pic.Radix_Position, "Radix Positon : "); - Debug_Integer (Pic.Sign_Position, "Sign Positon : "); - Debug_Integer (Pic.Second_Sign, "Second Sign : "); - Debug_Integer (Pic.Start_Float, "Start Float : "); - Debug_Integer (Pic.End_Float, "End Float : "); - Debug_Integer (Pic.Start_Currency, "Start Currency : "); - Debug_Integer (Pic.End_Currency, "End Currency : "); - Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : "); - Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : "); - - if Debug then - Ada.Text_IO.New_Line; - end if; - - exception - - when Constraint_Error => - - -- To deal with special cases like null strings - - raise Picture_Error; - end Precalculate; - - ---------------- - -- To_Picture -- - ---------------- - - function To_Picture - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Picture - is - Result : Picture; - - begin - declare - Item : constant String := Expand (Pic_String); - - begin - Result.Contents.Picture := (Item'Length, Item); - Result.Contents.Original_BWZ := Blank_When_Zero; - Result.Contents.Blank_When_Zero := Blank_When_Zero; - Precalculate (Result.Contents); - return Result; - end; - - exception - when others => - raise Picture_Error; - end To_Picture; - - ----------- - -- Valid -- - ----------- - - function Valid - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Boolean - is - begin - declare - Expanded_Pic : constant String := Expand (Pic_String); - -- Raises Picture_Error if Item not well-formed - - Format_Rec : Format_Record; - - begin - Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); - Format_Rec.Blank_When_Zero := Blank_When_Zero; - Format_Rec.Original_BWZ := Blank_When_Zero; - Precalculate (Format_Rec); - - -- False only if Blank_When_Zero is True but the pic string has a '*' - - return not Blank_When_Zero - or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; - end; - - exception - when others => return False; - end Valid; - - -------------------- - -- Decimal_Output -- - -------------------- - - package body Decimal_Output is - - ----------- - -- Image -- - ----------- - - function Image - (Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark) return String - is - begin - return Format_Number - (Pic.Contents, Num'Image (Item), - Currency, Fill, Separator, Radix_Mark); - end Image; - - ------------ - -- Length -- - ------------ - - function Length - (Pic : Picture; - Currency : String := Default_Currency) return Natural - is - Picstr : constant String := Pic_String (Pic); - V_Adjust : Integer := 0; - Cur_Adjust : Integer := 0; - - begin - -- Check if Picstr has 'V' or '$' - - -- If 'V', then length is 1 less than otherwise - - -- If '$', then length is Currency'Length-1 more than otherwise - - -- This should use the string handling package ??? - - for J in Picstr'Range loop - if Picstr (J) = 'V' then - V_Adjust := -1; - - elsif Picstr (J) = '$' then - Cur_Adjust := Currency'Length - 1; - end if; - end loop; - - return Picstr'Length - V_Adjust + Cur_Adjust; - end Length; - - --------- - -- Put -- - --------- - - procedure Put - (File : Text_IO.File_Type; - Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark) - is - begin - Text_IO.Put (File, Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark) - is - begin - Text_IO.Put (Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (To : out String; - Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark) - is - Result : constant String := - Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); - - begin - if Result'Length > To'Length then - raise Ada.Text_IO.Layout_Error; - else - Strings_Fixed.Move (Source => Result, Target => To, - Justify => Strings.Right); - end if; - end Put; - - ----------- - -- Valid -- - ----------- - - function Valid - (Item : Num; - Pic : Picture; - Currency : String := Default_Currency) return Boolean - is - begin - declare - Temp : constant String := Image (Item, Pic, Currency); - pragma Warnings (Off, Temp); - begin - return True; - end; - - exception - when Ada.Text_IO.Layout_Error => return False; - - end Valid; - end Decimal_Output; - -end Ada.Text_IO.Editing; diff --git a/gcc/ada/a-teioed.ads b/gcc/ada/a-teioed.ads deleted file mode 100644 index bc2842a..0000000 --- a/gcc/ada/a-teioed.ads +++ /dev/null @@ -1,194 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . E D I T I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Text_IO.Editing is - - type Picture is private; - - function Valid - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Boolean; - - function To_Picture - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Picture; - - function Pic_String (Pic : Picture) return String; - function Blank_When_Zero (Pic : Picture) return Boolean; - - Max_Picture_Length : constant := 64; - - Picture_Error : exception; - - Default_Currency : constant String := "$"; - Default_Fill : constant Character := '*'; - Default_Separator : constant Character := ','; - Default_Radix_Mark : constant Character := '.'; - - generic - type Num is delta <> digits <>; - Default_Currency : String := Editing.Default_Currency; - Default_Fill : Character := Editing.Default_Fill; - Default_Separator : Character := Editing.Default_Separator; - Default_Radix_Mark : Character := Editing.Default_Radix_Mark; - - package Decimal_Output is - - function Length - (Pic : Picture; - Currency : String := Default_Currency) return Natural; - - function Valid - (Item : Num; - Pic : Picture; - Currency : String := Default_Currency) return Boolean; - - function Image - (Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark) return String; - - procedure Put - (File : Ada.Text_IO.File_Type; - Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark); - - procedure Put - (Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark); - - procedure Put - (To : out String; - Item : Num; - Pic : Picture; - Currency : String := Default_Currency; - Fill : Character := Default_Fill; - Separator : Character := Default_Separator; - Radix_Mark : Character := Default_Radix_Mark); - - end Decimal_Output; - -private - - MAX_PICSIZE : constant := 50; - MAX_MONEYSIZE : constant := 10; - Invalid_Position : constant := -1; - - subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; - - type Picture_Record (Length : Pic_Index := 0) is record - Expanded : String (1 .. Length); - end record; - - type Format_Record is record - Picture : Picture_Record; - -- Read only - - Blank_When_Zero : Boolean; - -- Read/write - - Original_BWZ : Boolean; - - -- The following components get written - - Star_Fill : Boolean := False; - - Radix_Position : Integer := Invalid_Position; - - Sign_Position, - Second_Sign : Integer := Invalid_Position; - - Start_Float, - End_Float : Integer := Invalid_Position; - - Start_Currency, - End_Currency : Integer := Invalid_Position; - - Max_Leading_Digits : Integer := 0; - - Max_Trailing_Digits : Integer := 0; - - Max_Currency_Digits : Integer := 0; - - Floater : Character := '!'; - -- Initialized to illegal value - - end record; - - type Picture is record - Contents : Format_Record; - end record; - - type Number_Attributes is record - Negative : Boolean := False; - - Has_Fraction : Boolean := False; - - Start_Of_Int, - End_Of_Int, - Start_Of_Fraction, - End_Of_Fraction : Integer := Invalid_Position; -- invalid value - end record; - - function Parse_Number_String (Str : String) return Number_Attributes; - -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no - -- trailing blanks...) - - procedure Precalculate (Pic : in out Format_Record); - -- Precalculates fields from the user supplied data - - function Format_Number - (Pic : Format_Record; - Number : String; - Currency_Symbol : String; - Fill_Character : Character; - Separator_Character : Character; - Radix_Point : Character) return String; - -- Formats number according to Pic - - function Expand (Picture : String) return String; - -end Ada.Text_IO.Editing; diff --git a/gcc/ada/a-textio.adb b/gcc/ada/a-textio.adb deleted file mode 100644 index 0f842a0..0000000 --- a/gcc/ada/a-textio.adb +++ /dev/null @@ -1,2182 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Streams; use Ada.Streams; -with Interfaces.C_Streams; use Interfaces.C_Streams; - -with System.File_IO; -with System.CRTL; -with System.WCh_Cnv; use System.WCh_Cnv; -with System.WCh_Con; use System.WCh_Con; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -pragma Elaborate_All (System.File_IO); --- Needed because of calls to Chain_File in package body elaboration - -package body Ada.Text_IO is - - package FIO renames System.File_IO; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); - use type FCB.File_Mode; - - use type System.CRTL.size_t; - - WC_Encoding : Character; - pragma Import (C, WC_Encoding, "__gl_wc_encoding"); - -- Default wide character encoding - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - -- Names of standard files - -- - -- Use "preallocated" strings to avoid calling "new" during the elaboration - -- of the run time. This is needed in the tasking case to avoid calling - -- Task_Lock too early. A filename is expected to end with a null character - -- in the runtime, here the null characters are added just to have a - -- correct filename length. - -- - -- Note: the names for these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC tests insist. - -- We use names that are bound to fail in open etc. - - Null_Str : aliased constant String := ""; - -- Used as form string for standard files - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Get_Upper_Half_Char - (C : Character; - File : File_Type) return Character; - -- This function is shared by Get and Get_Immediate to extract an encoded - -- upper half character value from the given File. The first byte has - -- already been read and is passed in C. The character value is returned as - -- the result, and the file pointer is bumped past the character. - -- Constraint_Error is raised if the encoded value is outside the bounds of - -- type Character. - - function Get_Upper_Half_Char_Immed - (C : Character; - File : File_Type) return Character; - -- This routine is identical to Get_Upper_Half_Char, except that the reads - -- are done in Get_Immediate mode (i.e. without waiting for a line return). - - function Getc (File : File_Type) return int; - -- Gets next character from file, which has already been checked for being - -- in read status, and returns the character read if no error occurs. The - -- result is EOF if the end of file was read. - - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - - function Has_Upper_Half_Character (Item : String) return Boolean; - -- Returns True if any of the characters is in the range 16#80#-16#FF# - - function Nextc (File : File_Type) return int; - -- Returns next character from file without skipping past it (i.e. it is a - -- combination of Getc followed by an Ungetc). - - procedure Put_Encoded (File : File_Type; Char : Character); - -- Called to output a character Char to the given File, when the encoding - -- method for the file is other than brackets, and Char is upper half. - - procedure Putc (ch : int; File : File_Type); - -- Outputs the given character to the file, which has already been checked - -- for being in output status. Device_Error is raised if the character - -- cannot be written. - - procedure Set_WCEM (File : in out File_Type); - -- Called by Open and Create to set the wide character encoding method for - -- the file, processing a WCEM form parameter if one is present. File is - -- IN OUT because it may be closed in case of an error. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current line - -- is not terminated, then a line terminator is written using New_Line. - -- Note that there is no Terminate_Page routine, because the page mark at - -- the end of the file is implied if necessary. - - procedure Ungetc (ch : int; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has checked - -- that the file is in read status. Device_Error is raised if the character - -- cannot be pushed back. An attempt to push back and end of file character - -- (EOF) is ignored. - - ------------------- - -- AFCB_Allocate -- - ------------------- - - function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is - pragma Unreferenced (Control_Block); - begin - return new Text_AFCB; - end AFCB_Allocate; - - ---------------- - -- AFCB_Close -- - ---------------- - - procedure AFCB_Close (File : not null access Text_AFCB) is - begin - -- If the file being closed is one of the current files, then close - -- the corresponding current file. It is not clear that this action - -- is required (RM A.10.3(23)) but it seems reasonable, and besides - -- ACVC test CE3208A expects this behavior. - - if File_Type (File) = Current_In then - Current_In := null; - elsif File_Type (File) = Current_Out then - Current_Out := null; - elsif File_Type (File) = Current_Err then - Current_Err := null; - end if; - - Terminate_Line (File_Type (File)); - end AFCB_Close; - - --------------- - -- AFCB_Free -- - --------------- - - procedure AFCB_Free (File : not null access Text_AFCB) is - type FCB_Ptr is access all Text_AFCB; - FT : FCB_Ptr := FCB_Ptr (File); - - procedure Free is new Ada.Unchecked_Deallocation (Text_AFCB, FCB_Ptr); - - begin - Free (FT); - end AFCB_Free; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out File_Type) is - begin - FIO.Close (AP (File)'Unrestricted_Access); - end Close; - - --------- - -- Col -- - --------- - - -- Note: we assume that it is impossible in practice for the column - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Col (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Col; - end Col; - - function Col return Positive_Count is - begin - return Col (Current_Out); - end Col; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := "") - is - Dummy_File_Control_Block : Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'T', - Creat => True, - Text => True); - - File.Self := File; - Set_WCEM (File); - end Create; - - ------------------- - -- Current_Error -- - ------------------- - - function Current_Error return File_Type is - begin - return Current_Err; - end Current_Error; - - function Current_Error return File_Access is - begin - return Current_Err.Self'Access; - end Current_Error; - - ------------------- - -- Current_Input -- - ------------------- - - function Current_Input return File_Type is - begin - return Current_In; - end Current_Input; - - function Current_Input return File_Access is - begin - return Current_In.Self'Access; - end Current_Input; - - -------------------- - -- Current_Output -- - -------------------- - - function Current_Output return File_Type is - begin - return Current_Out; - end Current_Output; - - function Current_Output return File_Access is - begin - return Current_Out.Self'Access; - end Current_Output; - - ------------ - -- Delete -- - ------------ - - procedure Delete (File : in out File_Type) is - begin - FIO.Delete (AP (File)'Unrestricted_Access); - end Delete; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Upper_Half_Character then - return False; - - elsif File.Before_LM then - if File.Before_LM_PM then - return Nextc (File) = EOF; - end if; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch /= LM then - Ungetc (ch, File); - return False; - - else -- ch = LM - File.Before_LM := True; - end if; - end if; - - -- Here we are just past the line mark with Before_LM set so that we - -- do not have to try to back up past the LM, thus avoiding the need - -- to back up more than one character. - - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch = PM and then File.Is_Regular_File then - File.Before_LM_PM := True; - return Nextc (File) = EOF; - - -- Here if neither EOF nor PM followed end of line - - else - Ungetc (ch, File); - return False; - end if; - - end End_Of_File; - - function End_Of_File return Boolean is - begin - return End_Of_File (Current_In); - end End_Of_File; - - ----------------- - -- End_Of_Line -- - ----------------- - - function End_Of_Line (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Upper_Half_Character then - return False; - - elsif File.Before_LM then - return True; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - else - Ungetc (ch, File); - return (ch = LM); - end if; - end if; - end End_Of_Line; - - function End_Of_Line return Boolean is - begin - return End_Of_Line (Current_In); - end End_Of_Line; - - ----------------- - -- End_Of_Page -- - ----------------- - - function End_Of_Page (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if not File.Is_Regular_File then - return False; - - elsif File.Before_Upper_Half_Character then - return False; - - elsif File.Before_LM then - if File.Before_LM_PM then - return True; - end if; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch /= LM then - Ungetc (ch, File); - return False; - - else -- ch = LM - File.Before_LM := True; - end if; - end if; - - -- Here we are just past the line mark with Before_LM set so that we - -- do not have to try to back up past the LM, thus avoiding the need - -- to back up more than one character. - - ch := Nextc (File); - - return ch = PM or else ch = EOF; - end End_Of_Page; - - function End_Of_Page return Boolean is - begin - return End_Of_Page (Current_In); - end End_Of_Page; - - -------------- - -- EOF_Char -- - -------------- - - function EOF_Char return Integer is - begin - return EOF; - end EOF_Char; - - ----------- - -- Flush -- - ----------- - - procedure Flush (File : File_Type) is - begin - FIO.Flush (AP (File)); - end Flush; - - procedure Flush is - begin - Flush (Current_Out); - end Flush; - - ---------- - -- Form -- - ---------- - - function Form (File : File_Type) return String is - begin - return FIO.Form (AP (File)); - end Form; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Character) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Upper_Half_Character then - File.Before_Upper_Half_Character := False; - Item := File.Saved_Upper_Half_Character; - - elsif File.Before_LM then - File.Before_LM := False; - File.Col := 1; - - if File.Before_LM_PM then - File.Line := 1; - File.Page := File.Page + 1; - File.Before_LM_PM := False; - else - File.Line := File.Line + 1; - end if; - end if; - - loop - ch := Getc (File); - - if ch = EOF then - raise End_Error; - - elsif ch = LM then - File.Line := File.Line + 1; - File.Col := 1; - - elsif ch = PM and then File.Is_Regular_File then - File.Page := File.Page + 1; - File.Line := 1; - - else - Item := Character'Val (ch); - File.Col := File.Col + 1; - return; - end if; - end loop; - end Get; - - procedure Get (Item : out Character) is - begin - Get (Current_In, Item); - end Get; - - procedure Get - (File : File_Type; - Item : out String) - is - ch : int; - J : Natural; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - File.Col := 1; - - if File.Before_LM_PM then - File.Line := 1; - File.Page := File.Page + 1; - File.Before_LM_PM := False; - - else - File.Line := File.Line + 1; - end if; - end if; - - J := Item'First; - while J <= Item'Last loop - ch := Getc (File); - - if ch = EOF then - raise End_Error; - - elsif ch = LM then - File.Line := File.Line + 1; - File.Col := 1; - - elsif ch = PM and then File.Is_Regular_File then - File.Page := File.Page + 1; - File.Line := 1; - - else - Item (J) := Character'Val (ch); - J := J + 1; - File.Col := File.Col + 1; - end if; - end loop; - end Get; - - procedure Get (Item : out String) is - begin - Get (Current_In, Item); - end Get; - - ------------------- - -- Get_Immediate -- - ------------------- - - procedure Get_Immediate - (File : File_Type; - Item : out Character) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Upper_Half_Character then - File.Before_Upper_Half_Character := False; - Item := File.Saved_Upper_Half_Character; - - elsif File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - Item := Character'Val (LM); - - else - ch := Getc_Immed (File); - - if ch = EOF then - raise End_Error; - else - Item := - (if not Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method) - then Character'Val (ch) - else Get_Upper_Half_Char_Immed (Character'Val (ch), File)); - end if; - end if; - end Get_Immediate; - - procedure Get_Immediate - (Item : out Character) - is - begin - Get_Immediate (Current_In, Item); - end Get_Immediate; - - procedure Get_Immediate - (File : File_Type; - Item : out Character; - Available : out Boolean) - is - ch : int; - end_of_file : int; - avail : int; - - procedure getc_immediate_nowait - (stream : FILEs; - ch : out int; - end_of_file : out int; - avail : out int); - pragma Import (C, getc_immediate_nowait, "getc_immediate_nowait"); - - begin - FIO.Check_Read_Status (AP (File)); - Available := True; - - if File.Before_Upper_Half_Character then - File.Before_Upper_Half_Character := False; - Item := File.Saved_Upper_Half_Character; - - elsif File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - Item := Character'Val (LM); - - else - getc_immediate_nowait (File.Stream, ch, end_of_file, avail); - - if ferror (File.Stream) /= 0 then - raise Device_Error; - - elsif end_of_file /= 0 then - raise End_Error; - - elsif avail = 0 then - Available := False; - Item := ASCII.NUL; - - else - Available := True; - - Item := - (if not Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method) - then Character'Val (ch) - else Get_Upper_Half_Char_Immed (Character'Val (ch), File)); - end if; - end if; - - end Get_Immediate; - - procedure Get_Immediate - (Item : out Character; - Available : out Boolean) - is - begin - Get_Immediate (Current_In, Item, Available); - end Get_Immediate; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (File : File_Type; - Item : out String; - Last : out Natural) is separate; - -- The implementation of Ada.Text_IO.Get_Line is split into a subunit so - -- that different implementations can be used on different systems. - - procedure Get_Line - (Item : out String; - Last : out Natural) - is - begin - Get_Line (Current_In, Item, Last); - end Get_Line; - - function Get_Line (File : File_Type) return String is - function Get_Rest (S : String) return String; - -- This is a recursive function that reads the rest of the line and - -- returns it. S is the part read so far. - - -------------- - -- Get_Rest -- - -------------- - - function Get_Rest (S : String) return String is - - -- The first time we allocate a buffer of size 500. Each following - -- time we allocate a buffer the same size as what we have read so - -- far. This limits us to a logarithmic number of calls to Get_Rest - -- and also ensures only a linear use of stack space. - - Buffer : String (1 .. Integer'Max (500, S'Length)); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - - declare - R : constant String := S & Buffer (1 .. Last); - begin - if Last < Buffer'Last then - return R; - - else - pragma Assert (Last = Buffer'Last); - - -- If the String has the same length as the buffer, and there - -- is no end of line, check whether we are at the end of file, - -- in which case we have the full String in the buffer. - - if End_Of_File (File) then - return R; - - else - return Get_Rest (R); - end if; - end if; - end; - end Get_Rest; - - -- Start of processing for Get_Line - - begin - return Get_Rest (""); - end Get_Line; - - function Get_Line return String is - begin - return Get_Line (Current_In); - end Get_Line; - - ------------------------- - -- Get_Upper_Half_Char -- - ------------------------- - - function Get_Upper_Half_Char - (C : Character; - File : File_Type) return Character - is - Result : Wide_Character; - - function In_Char return Character; - -- Function used to obtain additional characters it the wide character - -- sequence is more than one character long. - - function WC_In is new Char_Sequence_To_Wide_Char (In_Char); - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - ch : constant Integer := Getc (File); - begin - if ch = EOF then - raise End_Error; - else - return Character'Val (ch); - end if; - end In_Char; - - -- Start of processing for Get_Upper_Half_Char - - begin - Result := WC_In (C, File.WC_Method); - - if Wide_Character'Pos (Result) > 16#FF# then - raise Constraint_Error with - "invalid wide character in Text_'I'O input"; - else - return Character'Val (Wide_Character'Pos (Result)); - end if; - end Get_Upper_Half_Char; - - ------------------------------- - -- Get_Upper_Half_Char_Immed -- - ------------------------------- - - function Get_Upper_Half_Char_Immed - (C : Character; - File : File_Type) return Character - is - Result : Wide_Character; - - function In_Char return Character; - -- Function used to obtain additional characters it the wide character - -- sequence is more than one character long. - - function WC_In is new Char_Sequence_To_Wide_Char (In_Char); - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - ch : constant Integer := Getc_Immed (File); - begin - if ch = EOF then - raise End_Error; - else - return Character'Val (ch); - end if; - end In_Char; - - -- Start of processing for Get_Upper_Half_Char_Immed - - begin - Result := WC_In (C, File.WC_Method); - - if Wide_Character'Pos (Result) > 16#FF# then - raise Constraint_Error with - "invalid wide character in Text_'I'O input"; - else - return Character'Val (Wide_Character'Pos (Result)); - end if; - end Get_Upper_Half_Char_Immed; - - ---------- - -- Getc -- - ---------- - - function Getc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF and then ferror (File.Stream) /= 0 then - raise Device_Error; - else - return ch; - end if; - end Getc; - - ---------------- - -- Getc_Immed -- - ---------------- - - function Getc_Immed (File : File_Type) return int is - ch : int; - end_of_file : int; - - procedure getc_immediate - (stream : FILEs; ch : out int; end_of_file : out int); - pragma Import (C, getc_immediate, "getc_immediate"); - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - ch := LM; - - else - getc_immediate (File.Stream, ch, end_of_file); - - if ferror (File.Stream) /= 0 then - raise Device_Error; - elsif end_of_file /= 0 then - return EOF; - end if; - end if; - - return ch; - end Getc_Immed; - - ------------------------------ - -- Has_Upper_Half_Character -- - ------------------------------ - - function Has_Upper_Half_Character (Item : String) return Boolean is - begin - for J in Item'Range loop - if Character'Pos (Item (J)) >= 16#80# then - return True; - end if; - end loop; - - return False; - end Has_Upper_Half_Character; - - ------------------------------- - -- Initialize_Standard_Files -- - ------------------------------- - - procedure Initialize_Standard_Files is - begin - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Text_Encoding := Default_Text; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Text_Encoding := Default_Text; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Text_Encoding := Default_Text; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; - - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Initialize_Standard_Files; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (File : File_Type) return Boolean is - begin - return FIO.Is_Open (AP (File)); - end Is_Open; - - ---------- - -- Line -- - ---------- - - -- Note: we assume that it is impossible in practice for the line - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Line (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Line; - end Line; - - function Line return Positive_Count is - begin - return Line (Current_Out); - end Line; - - ----------------- - -- Line_Length -- - ----------------- - - function Line_Length (File : File_Type) return Count is - begin - FIO.Check_Write_Status (AP (File)); - return File.Line_Length; - end Line_Length; - - function Line_Length return Count is - begin - return Line_Length (Current_Out); - end Line_Length; - - ---------------- - -- Look_Ahead -- - ---------------- - - procedure Look_Ahead - (File : File_Type; - Item : out Character; - End_Of_Line : out Boolean) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - -- If we are logically before a line mark, we can return immediately - - if File.Before_LM then - End_Of_Line := True; - Item := ASCII.NUL; - - -- If we are before an upper half character just return it (this can - -- happen if there are two calls to Look_Ahead in a row). - - elsif File.Before_Upper_Half_Character then - End_Of_Line := False; - Item := File.Saved_Upper_Half_Character; - - -- Otherwise we must read a character from the input stream - - else - ch := Getc (File); - - if ch = LM - or else ch = EOF - or else (ch = PM and then File.Is_Regular_File) - then - End_Of_Line := True; - Ungetc (ch, File); - Item := ASCII.NUL; - - -- Case where character obtained does not represent the start of an - -- encoded sequence so it stands for itself and we can unget it with - -- no difficulty. - - elsif not Is_Start_Of_Encoding - (Character'Val (ch), File.WC_Method) - then - End_Of_Line := False; - Ungetc (ch, File); - Item := Character'Val (ch); - - -- For the start of an encoding, we read the character using the - -- Get_Upper_Half_Char routine. It will occupy more than one byte - -- so we can't put it back with ungetc. Instead we save it in the - -- control block, setting a flag that everyone interested in reading - -- characters must test before reading the stream. - - else - Item := Get_Upper_Half_Char (Character'Val (ch), File); - End_Of_Line := False; - File.Saved_Upper_Half_Character := Item; - File.Before_Upper_Half_Character := True; - end if; - end if; - end Look_Ahead; - - procedure Look_Ahead - (Item : out Character; - End_Of_Line : out Boolean) - is - begin - Look_Ahead (Current_In, Item, End_Of_Line); - end Look_Ahead; - - ---------- - -- Mode -- - ---------- - - function Mode (File : File_Type) return File_Mode is - begin - return To_TIO (FIO.Mode (AP (File))); - end Mode; - - ---------- - -- Name -- - ---------- - - function Name (File : File_Type) return String is - begin - return FIO.Name (AP (File)); - end Name; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line - (File : File_Type; - Spacing : Positive_Count := 1) - is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not Spacing'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - - for K in 1 .. Spacing loop - Putc (LM, File); - File.Line := File.Line + 1; - - if File.Page_Length /= 0 - and then File.Line > File.Page_Length - then - Putc (PM, File); - File.Line := 1; - File.Page := File.Page + 1; - end if; - end loop; - - File.Col := 1; - end New_Line; - - procedure New_Line (Spacing : Positive_Count := 1) is - begin - New_Line (Current_Out, Spacing); - end New_Line; - - -------------- - -- New_Page -- - -------------- - - procedure New_Page (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - - if File.Col /= 1 or else File.Line = 1 then - Putc (LM, File); - end if; - - Putc (PM, File); - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - end New_Page; - - procedure New_Page is - begin - New_Page (Current_Out); - end New_Page; - - ----------- - -- Nextc -- - ----------- - - function Nextc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF then - if ferror (File.Stream) /= 0 then - raise Device_Error; - end if; - - else - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - - return ch; - end Nextc; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := "") - is - Dummy_File_Control_Block : Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'T', - Creat => False, - Text => True); - - File.Self := File; - Set_WCEM (File); - end Open; - - ---------- - -- Page -- - ---------- - - -- Note: we assume that it is impossible in practice for the page - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Page (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Page; - end Page; - - function Page return Positive_Count is - begin - return Page (Current_Out); - end Page; - - ----------------- - -- Page_Length -- - ----------------- - - function Page_Length (File : File_Type) return Count is - begin - FIO.Check_Write_Status (AP (File)); - return File.Page_Length; - end Page_Length; - - function Page_Length return Count is - begin - return Page_Length (Current_Out); - end Page_Length; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Character) - is - begin - FIO.Check_Write_Status (AP (File)); - - if File.Line_Length /= 0 and then File.Col > File.Line_Length then - New_Line (File); - end if; - - -- If lower half character, or brackets encoding, output directly - - if Character'Pos (Item) < 16#80# - or else File.WC_Method = WCEM_Brackets - then - if fputc (Character'Pos (Item), File.Stream) = EOF then - raise Device_Error; - end if; - - -- Case of upper half character with non-brackets encoding - - else - Put_Encoded (File, Item); - end if; - - File.Col := File.Col + 1; - end Put; - - procedure Put (Item : Character) is - begin - Put (Current_Out, Item); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : String) - is - begin - FIO.Check_Write_Status (AP (File)); - - -- Only have something to do if string is non-null - - if Item'Length > 0 then - - -- If we have bounded lines, or if the file encoding is other than - -- Brackets and the string has at least one upper half character, - -- then output the string character by character. - - if File.Line_Length /= 0 - or else (File.WC_Method /= WCEM_Brackets - and then Has_Upper_Half_Character (Item)) - then - for J in Item'Range loop - Put (File, Item (J)); - end loop; - - -- Otherwise we can output the entire string at once. Note that if - -- there are LF or FF characters in the string, we do not bother to - -- count them as line or page terminators. - - else - FIO.Write_Buf (AP (File), Item'Address, Item'Length); - File.Col := File.Col + Item'Length; - end if; - end if; - end Put; - - procedure Put (Item : String) is - begin - Put (Current_Out, Item); - end Put; - - ----------------- - -- Put_Encoded -- - ----------------- - - procedure Put_Encoded (File : File_Type; Char : Character) is - procedure Out_Char (C : Character); - -- Procedure to output one character of an upper half encoded sequence - - procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); - - -------------- - -- Out_Char -- - -------------- - - procedure Out_Char (C : Character) is - begin - Putc (Character'Pos (C), File); - end Out_Char; - - -- Start of processing for Put_Encoded - - begin - WC_Out (Wide_Character'Val (Character'Pos (Char)), File.WC_Method); - end Put_Encoded; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (File : File_Type; - Item : String) - is - Ilen : Natural := Item'Length; - Istart : Natural := Item'First; - - begin - FIO.Check_Write_Status (AP (File)); - - -- If we have bounded lines, or if the file encoding is other than - -- Brackets and the string has at least one upper half character, then - -- output the string character by character. - - if File.Line_Length /= 0 - or else (File.WC_Method /= WCEM_Brackets - and then Has_Upper_Half_Character (Item)) - then - for J in Item'Range loop - Put (File, Item (J)); - end loop; - - New_Line (File); - return; - end if; - - -- Normal case where we do not need to output character by character - - -- We setup a single string that has the necessary terminators and - -- then write it with a single call. The reason for doing this is - -- that it gives better behavior for the use of Put_Line in multi- - -- tasking programs, since often the OS will treat the entire put - -- operation as an atomic operation. - - -- We only do this if the message is 512 characters or less in length, - -- since otherwise Put_Line would use an unbounded amount of stack - -- space and could cause undetected stack overflow. If we have a - -- longer string, then output the first part separately to avoid this. - - if Ilen > 512 then - FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512)); - Istart := Istart + Ilen - 512; - Ilen := 512; - end if; - - -- Now prepare the string with its terminator - - declare - Buffer : String (1 .. Ilen + 2); - Plen : size_t; - - begin - Buffer (1 .. Ilen) := Item (Istart .. Item'Last); - Buffer (Ilen + 1) := Character'Val (LM); - - if File.Page_Length /= 0 - and then File.Line > File.Page_Length - then - Buffer (Ilen + 2) := Character'Val (PM); - Plen := size_t (Ilen) + 2; - File.Line := 1; - File.Page := File.Page + 1; - - else - Plen := size_t (Ilen) + 1; - File.Line := File.Line + 1; - end if; - - FIO.Write_Buf (AP (File), Buffer'Address, Plen); - - File.Col := 1; - end; - end Put_Line; - - procedure Put_Line (Item : String) is - begin - Put_Line (Current_Out, Item); - end Put_Line; - - ---------- - -- Putc -- - ---------- - - procedure Putc (ch : int; File : File_Type) is - begin - if fputc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end Putc; - - ---------- - -- Read -- - ---------- - - -- This is the primitive Stream Read routine, used when a Text_IO file - -- is treated directly as a stream using Text_IO.Streams.Stream. - - procedure Read - (File : in out Text_AFCB; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Discard_ch : int; - pragma Warnings (Off, Discard_ch); - - begin - -- Need to deal with Before_Upper_Half_Character ??? - - if File.Mode /= FCB.In_File then - raise Mode_Error; - end if; - - -- Deal with case where our logical and physical position do not match - -- because of being after an LM or LM-PM sequence when in fact we are - -- logically positioned before it. - - if File.Before_LM then - - -- If we are before a PM, then it is possible for a stream read - -- to leave us after the LM and before the PM, which is a bit - -- odd. The easiest way to deal with this is to unget the PM, - -- so we are indeed positioned between the characters. This way - -- further stream read operations will work correctly, and the - -- effect on text processing is a little weird, but what can - -- be expected if stream and text input are mixed this way? - - if File.Before_LM_PM then - Discard_ch := ungetc (PM, File.Stream); - File.Before_LM_PM := False; - end if; - - File.Before_LM := False; - - Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); - - if Item'Length = 1 then - Last := Item'Last; - - else - Last := - Item'First + - Stream_Element_Offset - (fread (buffer => Item'Address, - index => size_t (Item'First + 1), - size => 1, - count => Item'Length - 1, - stream => File.Stream)); - end if; - - return; - end if; - - -- Now we do the read. Since this is a text file, it is normally in - -- text mode, but stream data must be read in binary mode, so we - -- temporarily set binary mode for the read, resetting it after. - -- These calls have no effect in a system (like Unix) where there is - -- no distinction between text and binary files. - - set_binary_mode (fileno (File.Stream)); - - Last := - Item'First + - Stream_Element_Offset - (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; - - if Last < Item'Last then - if ferror (File.Stream) /= 0 then - raise Device_Error; - end if; - end if; - - set_text_mode (fileno (File.Stream)); - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset - (File : in out File_Type; - Mode : File_Mode) - is - begin - -- Don't allow change of mode for current file (RM A.10.2(5)) - - if (File = Current_In or else - File = Current_Out or else - File = Current_Error) - and then To_FCB (Mode) /= File.Mode - then - raise Mode_Error; - end if; - - Terminate_Line (File); - FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); - File.Page := 1; - File.Line := 1; - File.Col := 1; - File.Line_Length := 0; - File.Page_Length := 0; - File.Before_LM := False; - File.Before_LM_PM := False; - end Reset; - - procedure Reset (File : in out File_Type) is - begin - Terminate_Line (File); - FIO.Reset (AP (File)'Unrestricted_Access); - File.Page := 1; - File.Line := 1; - File.Col := 1; - File.Line_Length := 0; - File.Page_Length := 0; - File.Before_LM := False; - File.Before_LM_PM := False; - end Reset; - - ------------- - -- Set_Col -- - ------------- - - procedure Set_Col - (File : File_Type; - To : Positive_Count) - is - ch : int; - - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_File_Open (AP (File)); - - -- Output case - - if Mode (File) >= Out_File then - - -- Error if we attempt to set Col to a value greater than the - -- maximum permissible line length. - - if File.Line_Length /= 0 and then To > File.Line_Length then - raise Layout_Error; - end if; - - -- If we are behind current position, then go to start of new line - - if To < File.Col then - New_Line (File); - end if; - - -- Loop to output blanks till we are at the required column - - while File.Col < To loop - Put (File, ' '); - end loop; - - -- Input case - - else - -- If we are logically before a LM, but physically after it, the - -- file position still reflects the position before the LM, so eat - -- it now and adjust the file position appropriately. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - File.Line := File.Line + 1; - File.Col := 1; - end if; - - -- Loop reading characters till we get one at the required Col value - - loop - -- Read next character. The reason we have to read ahead is to - -- skip formatting characters, the effect of Set_Col is to set - -- us to a real character with the right Col value, and format - -- characters don't count. - - ch := Getc (File); - - -- Error if we hit an end of file - - if ch = EOF then - raise End_Error; - - -- If line mark, eat it and adjust file position - - elsif ch = LM then - File.Line := File.Line + 1; - File.Col := 1; - - -- If recognized page mark, eat it, and adjust file position - - elsif ch = PM and then File.Is_Regular_File then - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - - -- Otherwise this is the character we are looking for, so put it - -- back in the input stream (we have not adjusted the file - -- position yet, so everything is set right after this ungetc). - - elsif To = File.Col then - Ungetc (ch, File); - return; - - -- Keep skipping characters if we are not there yet, updating the - -- file position past the skipped character. - - else - File.Col := File.Col + 1; - end if; - end loop; - end if; - end Set_Col; - - procedure Set_Col (To : Positive_Count) is - begin - Set_Col (Current_Out, To); - end Set_Col; - - --------------- - -- Set_Error -- - --------------- - - procedure Set_Error (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - Current_Err := File; - end Set_Error; - - --------------- - -- Set_Input -- - --------------- - - procedure Set_Input (File : File_Type) is - begin - FIO.Check_Read_Status (AP (File)); - Current_In := File; - end Set_Input; - - -------------- - -- Set_Line -- - -------------- - - procedure Set_Line - (File : File_Type; - To : Positive_Count) - is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_File_Open (AP (File)); - - if To = File.Line then - return; - end if; - - if Mode (File) >= Out_File then - if File.Page_Length /= 0 and then To > File.Page_Length then - raise Layout_Error; - end if; - - if To < File.Line then - New_Page (File); - end if; - - while File.Line < To loop - New_Line (File); - end loop; - - else - while To /= File.Line loop - Skip_Line (File); - end loop; - end if; - end Set_Line; - - procedure Set_Line (To : Positive_Count) is - begin - Set_Line (Current_Out, To); - end Set_Line; - - --------------------- - -- Set_Line_Length -- - --------------------- - - procedure Set_Line_Length (File : File_Type; To : Count) is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - File.Line_Length := To; - end Set_Line_Length; - - procedure Set_Line_Length (To : Count) is - begin - Set_Line_Length (Current_Out, To); - end Set_Line_Length; - - ---------------- - -- Set_Output -- - ---------------- - - procedure Set_Output (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - Current_Out := File; - end Set_Output; - - --------------------- - -- Set_Page_Length -- - --------------------- - - procedure Set_Page_Length (File : File_Type; To : Count) is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - File.Page_Length := To; - end Set_Page_Length; - - procedure Set_Page_Length (To : Count) is - begin - Set_Page_Length (Current_Out, To); - end Set_Page_Length; - - -------------- - -- Set_WCEM -- - -------------- - - procedure Set_WCEM (File : in out File_Type) is - Start : Natural; - Stop : Natural; - - begin - FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); - - if Start = 0 then - File.WC_Method := Default_WCEM; - - else - if Stop = Start then - for J in WC_Encoding_Letters'Range loop - if File.Form (Start) = WC_Encoding_Letters (J) then - File.WC_Method := J; - return; - end if; - end loop; - end if; - - Close (File); - raise Use_Error with "invalid WCEM form parameter"; - end if; - end Set_WCEM; - - --------------- - -- Skip_Line -- - --------------- - - procedure Skip_Line - (File : File_Type; - Spacing : Positive_Count := 1) - is - ch : int; - - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not Spacing'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Read_Status (AP (File)); - - for L in 1 .. Spacing loop - if File.Before_LM then - File.Before_LM := False; - - -- Note that if File.Before_LM_PM is currently set, we also have - -- to reset it (because it makes sense for Before_LM_PM to be set - -- only when Before_LM is also set). This is done later on in this - -- subprogram, as soon as Before_LM_PM has been taken into account - -- for the purpose of page and line counts. - - else - ch := Getc (File); - - -- If at end of file now, then immediately raise End_Error. Note - -- that we can never be positioned between a line mark and a page - -- mark, so if we are at the end of file, we cannot logically be - -- before the implicit page mark that is at the end of the file. - - -- For the same reason, we do not need an explicit check for a - -- page mark. If there is a FF in the middle of a line, the file - -- is not in canonical format and we do not care about the page - -- numbers for files other than ones in canonical format. - - if ch = EOF then - raise End_Error; - end if; - - -- If not at end of file, then loop till we get to an LM or EOF. - -- The latter case happens only in non-canonical files where the - -- last line is not terminated by LM, but we don't want to blow - -- up for such files, so we assume an implicit LM in this case. - - loop - exit when ch = LM or else ch = EOF; - ch := Getc (File); - end loop; - end if; - - -- We have got past a line mark, now, for a regular file only, - -- see if a page mark immediately follows this line mark and - -- if so, skip past the page mark as well. We do not do this - -- for non-regular files, since it would cause an undesirable - -- wait for an additional character. - - File.Col := 1; - File.Line := File.Line + 1; - - if File.Before_LM_PM then - File.Page := File.Page + 1; - File.Line := 1; - File.Before_LM_PM := False; - - elsif File.Is_Regular_File then - ch := Getc (File); - - -- Page mark can be explicit, or implied at the end of the file - - if (ch = PM or else ch = EOF) - and then File.Is_Regular_File - then - File.Page := File.Page + 1; - File.Line := 1; - else - Ungetc (ch, File); - end if; - end if; - end loop; - - File.Before_Upper_Half_Character := False; - end Skip_Line; - - procedure Skip_Line (Spacing : Positive_Count := 1) is - begin - Skip_Line (Current_In, Spacing); - end Skip_Line; - - --------------- - -- Skip_Page -- - --------------- - - procedure Skip_Page (File : File_Type) is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - -- If at page mark already, just skip it - - if File.Before_LM_PM then - File.Before_LM := False; - File.Before_LM_PM := False; - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - return; - end if; - - -- This is a bit tricky, if we are logically before an LM then - -- it is not an error if we are at an end of file now, since we - -- are not really at it. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - ch := Getc (File); - - -- Otherwise we do raise End_Error if we are at the end of file now - - else - ch := Getc (File); - - if ch = EOF then - raise End_Error; - end if; - end if; - - -- Now we can just rumble along to the next page mark, or to the - -- end of file, if that comes first. The latter case happens when - -- the page mark is implied at the end of file. - - loop - exit when ch = EOF - or else (ch = PM and then File.Is_Regular_File); - ch := Getc (File); - end loop; - - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - File.Before_Upper_Half_Character := False; - end Skip_Page; - - procedure Skip_Page is - begin - Skip_Page (Current_In); - end Skip_Page; - - -------------------- - -- Standard_Error -- - -------------------- - - function Standard_Error return File_Type is - begin - return Standard_Err; - end Standard_Error; - - function Standard_Error return File_Access is - begin - return Standard_Err'Access; - end Standard_Error; - - -------------------- - -- Standard_Input -- - -------------------- - - function Standard_Input return File_Type is - begin - return Standard_In; - end Standard_Input; - - function Standard_Input return File_Access is - begin - return Standard_In'Access; - end Standard_Input; - - --------------------- - -- Standard_Output -- - --------------------- - - function Standard_Output return File_Type is - begin - return Standard_Out; - end Standard_Output; - - function Standard_Output return File_Access is - begin - return Standard_Out'Access; - end Standard_Output; - - -------------------- - -- Terminate_Line -- - -------------------- - - procedure Terminate_Line (File : File_Type) is - begin - FIO.Check_File_Open (AP (File)); - - -- For file other than In_File, test for needing to terminate last line - - if Mode (File) /= In_File then - - -- If not at start of line definition need new line - - if File.Col /= 1 then - New_Line (File); - - -- For files other than standard error and standard output, we - -- make sure that an empty file has a single line feed, so that - -- it is properly formatted. We avoid this for the standard files - -- because it is too much of a nuisance to have these odd line - -- feeds when nothing has been written to the file. - - -- We also avoid this for files opened in append mode, in - -- accordance with (RM A.8.2(10)) - - elsif (File /= Standard_Err and then File /= Standard_Out) - and then (File.Line = 1 and then File.Page = 1) - and then Mode (File) = Out_File - then - New_Line (File); - end if; - end if; - end Terminate_Line; - - ------------ - -- Ungetc -- - ------------ - - procedure Ungetc (ch : int; File : File_Type) is - begin - if ch /= EOF then - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - end Ungetc; - - ----------- - -- Write -- - ----------- - - -- This is the primitive Stream Write routine, used when a Text_IO file - -- is treated directly as a stream using Text_IO.Streams.Stream. - - procedure Write - (File : in out Text_AFCB; - Item : Stream_Element_Array) - is - pragma Warnings (Off, File); - -- Because in this implementation we don't need IN OUT, we only read - - function Has_Translated_Characters return Boolean; - -- return True if Item array contains a character which will be - -- translated under the text file mode. There is only one such - -- character under DOS based systems which is character 10. - - text_translation_required : Boolean; - for text_translation_required'Size use Character'Size; - pragma Import (C, text_translation_required, - "__gnat_text_translation_required"); - - Siz : constant size_t := Item'Length; - - ------------------------------- - -- Has_Translated_Characters -- - ------------------------------- - - function Has_Translated_Characters return Boolean is - begin - for K in Item'Range loop - if Item (K) = 10 then - return True; - end if; - end loop; - return False; - end Has_Translated_Characters; - - Needs_Binary_Write : constant Boolean := - text_translation_required and then Has_Translated_Characters; - - -- Start of processing for Write - - begin - if File.Mode = FCB.In_File then - raise Mode_Error; - end if; - - -- Now we do the write. Since this is a text file, it is normally in - -- text mode, but stream data must be written in binary mode, so we - -- temporarily set binary mode for the write, resetting it after. This - -- is done only if needed (i.e. there is some characters in Item which - -- needs to be written using the binary mode). - -- These calls have no effect in a system (like Unix) where there is - -- no distinction between text and binary files. - - -- Since the character translation is done at the time the buffer is - -- written (this is true under Windows) we first flush current buffer - -- with text mode if needed. - - if Needs_Binary_Write then - if fflush (File.Stream) = -1 then - raise Device_Error; - end if; - - set_binary_mode (fileno (File.Stream)); - end if; - - if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then - raise Device_Error; - end if; - - -- At this point we need to flush the buffer using the binary mode then - -- we reset to text mode. - - if Needs_Binary_Write then - if fflush (File.Stream) = -1 then - raise Device_Error; - end if; - - set_text_mode (fileno (File.Stream)); - end if; - end Write; - -begin - -- Initialize Standard Files - - for J in WC_Encoding_Method loop - if WC_Encoding = WC_Encoding_Letters (J) then - Default_WCEM := J; - end if; - end loop; - - Initialize_Standard_Files; - - FIO.Chain_File (AP (Standard_In)); - FIO.Chain_File (AP (Standard_Out)); - FIO.Chain_File (AP (Standard_Err)); - -end Ada.Text_IO; diff --git a/gcc/ada/a-textio.ads b/gcc/ada/a-textio.ads deleted file mode 100644 index d04b2e9..0000000 --- a/gcc/ada/a-textio.ads +++ /dev/null @@ -1,471 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: the generic subpackages of Text_IO (Integer_IO, Float_IO, Fixed_IO, --- Modular_IO, Decimal_IO and Enumeration_IO) appear as private children in --- GNAT. These children are with'ed automatically if they are referenced, so --- this rearrangement is invisible to user programs, but has the advantage --- that only the needed parts of Text_IO are processed and loaded. - -with Ada.IO_Exceptions; -with Ada.Streams; - -with System; -with System.File_Control_Block; -with System.WCh_Con; - -package Ada.Text_IO is - pragma Elaborate_Body; - - type File_Type is limited private; - type File_Mode is (In_File, Out_File, Append_File); - - -- The following representation clause allows the use of unchecked - -- conversion for rapid translation between the File_Mode type - -- used in this package and System.File_IO. - - for File_Mode use - (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) - Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) - Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) - - type Count is range 0 .. Natural'Last; - -- The value of Count'Last must be large enough so that the assumption that - -- the Line, Column and Page counts can never exceed this value is valid. - - subtype Positive_Count is Count range 1 .. Count'Last; - - Unbounded : constant Count := 0; - -- Line and page length - - subtype Field is Integer range 0 .. 255; - -- Note: if for any reason, there is a need to increase this value, then it - -- will be necessary to change the corresponding value in System.Img_Real - -- in file s-imgrea.adb. - - subtype Number_Base is Integer range 2 .. 16; - - type Type_Set is (Lower_Case, Upper_Case); - - --------------------- - -- File Management -- - --------------------- - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := ""); - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - procedure Reset (File : in out File_Type; Mode : File_Mode); - procedure Reset (File : in out File_Type); - - function Mode (File : File_Type) return File_Mode; - function Name (File : File_Type) return String; - function Form (File : File_Type) return String; - - function Is_Open (File : File_Type) return Boolean; - - ------------------------------------------------------ - -- Control of default input, output and error files -- - ------------------------------------------------------ - - procedure Set_Input (File : File_Type); - procedure Set_Output (File : File_Type); - procedure Set_Error (File : File_Type); - - function Standard_Input return File_Type; - function Standard_Output return File_Type; - function Standard_Error return File_Type; - - function Current_Input return File_Type; - function Current_Output return File_Type; - function Current_Error return File_Type; - - type File_Access is access constant File_Type; - - function Standard_Input return File_Access; - function Standard_Output return File_Access; - function Standard_Error return File_Access; - - function Current_Input return File_Access; - function Current_Output return File_Access; - function Current_Error return File_Access; - - -------------------- - -- Buffer control -- - -------------------- - - -- Note: The parameter file is IN OUT in the RM, but this is clearly - -- an oversight, and was intended to be IN, see AI95-00057. - - procedure Flush (File : File_Type); - procedure Flush; - - -------------------------------------------- - -- Specification of line and page lengths -- - -------------------------------------------- - - procedure Set_Line_Length (File : File_Type; To : Count); - procedure Set_Line_Length (To : Count); - - procedure Set_Page_Length (File : File_Type; To : Count); - procedure Set_Page_Length (To : Count); - - function Line_Length (File : File_Type) return Count; - function Line_Length return Count; - - function Page_Length (File : File_Type) return Count; - function Page_Length return Count; - - ------------------------------------ - -- Column, Line, and Page Control -- - ------------------------------------ - - procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure New_Line (Spacing : Positive_Count := 1); - - procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure Skip_Line (Spacing : Positive_Count := 1); - - function End_Of_Line (File : File_Type) return Boolean; - function End_Of_Line return Boolean; - - procedure New_Page (File : File_Type); - procedure New_Page; - - procedure Skip_Page (File : File_Type); - procedure Skip_Page; - - function End_Of_Page (File : File_Type) return Boolean; - function End_Of_Page return Boolean; - - function End_Of_File (File : File_Type) return Boolean; - function End_Of_File return Boolean; - - procedure Set_Col (File : File_Type; To : Positive_Count); - procedure Set_Col (To : Positive_Count); - - procedure Set_Line (File : File_Type; To : Positive_Count); - procedure Set_Line (To : Positive_Count); - - function Col (File : File_Type) return Positive_Count; - function Col return Positive_Count; - - function Line (File : File_Type) return Positive_Count; - function Line return Positive_Count; - - function Page (File : File_Type) return Positive_Count; - function Page return Positive_Count; - - ---------------------------- - -- Character Input-Output -- - ---------------------------- - - procedure Get (File : File_Type; Item : out Character); - procedure Get (Item : out Character); - procedure Put (File : File_Type; Item : Character); - procedure Put (Item : Character); - - procedure Look_Ahead - (File : File_Type; - Item : out Character; - End_Of_Line : out Boolean); - - procedure Look_Ahead - (Item : out Character; - End_Of_Line : out Boolean); - - procedure Get_Immediate - (File : File_Type; - Item : out Character); - - procedure Get_Immediate - (Item : out Character); - - procedure Get_Immediate - (File : File_Type; - Item : out Character; - Available : out Boolean); - - procedure Get_Immediate - (Item : out Character; - Available : out Boolean); - - ------------------------- - -- String Input-Output -- - ------------------------- - - procedure Get (File : File_Type; Item : out String); - procedure Get (Item : out String); - procedure Put (File : File_Type; Item : String); - procedure Put (Item : String); - - procedure Get_Line - (File : File_Type; - Item : out String; - Last : out Natural); - - procedure Get_Line - (Item : out String; - Last : out Natural); - - function Get_Line (File : File_Type) return String; - pragma Ada_05 (Get_Line); - - function Get_Line return String; - pragma Ada_05 (Get_Line); - - procedure Put_Line - (File : File_Type; - Item : String); - - procedure Put_Line - (Item : String); - - --------------------------------------- - -- Generic packages for Input-Output -- - --------------------------------------- - - -- The generic packages: - - -- Ada.Text_IO.Integer_IO - -- Ada.Text_IO.Modular_IO - -- Ada.Text_IO.Float_IO - -- Ada.Text_IO.Fixed_IO - -- Ada.Text_IO.Decimal_IO - -- Ada.Text_IO.Enumeration_IO - - -- are implemented as separate child packages in GNAT, so the - -- spec and body of these packages are to be found in separate - -- child units. This implementation detail is hidden from the - -- Ada programmer by special circuitry in the compiler that - -- treats these child packages as though they were nested in - -- Text_IO. The advantage of this special processing is that - -- the subsidiary routines needed if these generics are used - -- are not loaded when they are not used. - - ---------------- - -- Exceptions -- - ---------------- - - Status_Error : exception renames IO_Exceptions.Status_Error; - Mode_Error : exception renames IO_Exceptions.Mode_Error; - Name_Error : exception renames IO_Exceptions.Name_Error; - Use_Error : exception renames IO_Exceptions.Use_Error; - Device_Error : exception renames IO_Exceptions.Device_Error; - End_Error : exception renames IO_Exceptions.End_Error; - Data_Error : exception renames IO_Exceptions.Data_Error; - Layout_Error : exception renames IO_Exceptions.Layout_Error; - -private - - -- The following procedures have a File_Type formal of mode IN OUT because - -- they may close the original file. The Close operation may raise an - -- exception, but in that case we want any assignment to the formal to - -- be effective anyway, so it must be passed by reference (or the caller - -- will be left with a dangling pointer). - - pragma Export_Procedure - (Internal => Close, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Delete, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type), - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type, File_Mode), - Mechanism => (File => Reference)); - - ----------------------------------- - -- Handling of Format Characters -- - ----------------------------------- - - -- Line marks are represented by the single character ASCII.LF (16#0A#). - -- In DOS and similar systems, underlying file translation takes care - -- of translating this to and from the standard CR/LF sequences used in - -- these operating systems to mark the end of a line. On output there is - -- always a line mark at the end of the last line, but on input, this - -- line mark can be omitted, and is implied by the end of file. - - -- Page marks are represented by the single character ASCII.FF (16#0C#), - -- The page mark at the end of the file may be omitted, and is normally - -- omitted on output unless an explicit New_Page call is made before - -- closing the file. No page mark is added when a file is appended to, - -- so, in accordance with the permission in (RM A.10.2(4)), there may - -- or may not be a page mark separating preexisting text in the file - -- from the new text to be written. - - -- A file mark is marked by the physical end of file. In DOS translation - -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the - -- physical end of file, so in effect this character is recognized as - -- marking the end of file in DOS and similar systems. - - LM : constant := Character'Pos (ASCII.LF); - -- Used as line mark - - PM : constant := Character'Pos (ASCII.FF); - -- Used as page mark, except at end of file where it is implied - - -------------------------------- - -- Text_IO File Control Block -- - -------------------------------- - - Default_WCEM : System.WCh_Con.WC_Encoding_Method := - System.WCh_Con.WCEM_UTF8; - -- This gets modified during initialization (see body) using - -- the default value established in the call to Set_Globals. - - package FCB renames System.File_Control_Block; - - type Text_AFCB; - type File_Type is access all Text_AFCB; - - type Text_AFCB is new FCB.AFCB with record - Page : Count := 1; - Line : Count := 1; - Col : Count := 1; - Line_Length : Count := 0; - Page_Length : Count := 0; - - Self : aliased File_Type; - -- Set to point to the containing Text_AFCB block. This is used to - -- implement the Current_{Error,Input,Output} functions which return - -- a File_Access, the file access value returned is a pointer to - -- the Self field of the corresponding file. - - Before_LM : Boolean := False; - -- This flag is used to deal with the anomalies introduced by the - -- peculiar definition of End_Of_File and End_Of_Page in Ada. These - -- functions require looking ahead more than one character. Since - -- there is no convenient way of backing up more than one character, - -- what we do is to leave ourselves positioned past the LM, but set - -- this flag, so that we know that from an Ada point of view we are - -- in front of the LM, not after it. A little odd, but it works. - - Before_LM_PM : Boolean := False; - -- This flag similarly handles the case of being physically positioned - -- after a LM-PM sequence when logically we are before the LM-PM. This - -- flag can only be set if Before_LM is also set. - - WC_Method : System.WCh_Con.WC_Encoding_Method := Default_WCEM; - -- Encoding method to be used for this file. Text_IO does not deal with - -- wide characters, but it does deal with upper half characters in the - -- range 16#80#-16#FF# which may need encoding, e.g. in UTF-8 mode. - - Before_Upper_Half_Character : Boolean := False; - -- This flag is set to indicate that an encoded upper half character has - -- been read by Text_IO.Look_Ahead. If it is set to True, then it means - -- that the stream is logically positioned before the character but is - -- physically positioned after it. The character involved must be in - -- the range 16#80#-16#FF#, i.e. if the flag is set, then we know the - -- next character has a code greater than 16#7F#, and the value of this - -- character is saved in Saved_Upper_Half_Character. - - Saved_Upper_Half_Character : Character; - -- This field is valid only if Before_Upper_Half_Character is set. It - -- contains an upper-half character read by Look_Ahead. If Look_Ahead - -- reads a character in the range 16#00# to 16#7F#, then it can use - -- ungetc to put it back, but ungetc cannot be called more than once, - -- so for characters above this range, we don't try to back up the - -- file. Instead we save the character in this field and set the flag - -- Before_Upper_Half_Character to True to indicate that we are logically - -- positioned before this character even though the stream is physically - -- positioned after it. - - end record; - - function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr; - - procedure AFCB_Close (File : not null access Text_AFCB); - procedure AFCB_Free (File : not null access Text_AFCB); - - procedure Read - (File : in out Text_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Read operation used when Text_IO file is treated directly as Stream - - procedure Write - (File : in out Text_AFCB; - Item : Ada.Streams.Stream_Element_Array); - -- Write operation used when Text_IO file is treated directly as Stream - - ------------------------ - -- The Standard Files -- - ------------------------ - - Standard_In_AFCB : aliased Text_AFCB; - Standard_Out_AFCB : aliased Text_AFCB; - Standard_Err_AFCB : aliased Text_AFCB; - - Standard_In : aliased File_Type := Standard_In_AFCB'Access; - Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; - Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; - -- Standard files - - Current_In : aliased File_Type := Standard_In; - Current_Out : aliased File_Type := Standard_Out; - Current_Err : aliased File_Type := Standard_Err; - -- Current files - - function EOF_Char return Integer; - -- Returns the system-specific character indicating the end of a text file. - -- This is exported for use by child packages such as Enumeration_Aux to - -- eliminate their needing to depend directly on Interfaces.C_Streams, - -- which is not available in certain target environments (such as AAMP). - - procedure Initialize_Standard_Files; - -- Initializes the file control blocks for the standard files. Called from - -- the elaboration routine for this package, and from Reset_Standard_Files - -- in package Ada.Text_IO.Reset_Standard_Files. - -end Ada.Text_IO; diff --git a/gcc/ada/a-tgdico.ads b/gcc/ada/a-tgdico.ads deleted file mode 100644 index 3aae768..0000000 --- a/gcc/ada/a-tgdico.ads +++ /dev/null @@ -1,29 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- ADA.TAGS.GENERIC_DISPATCHING_CONSTRUCTOR -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Warnings (Off); --- Turn off categorization warnings - -generic - type T (<>) is abstract tagged limited private; - type Parameters (<>) is limited private; - with function Constructor (Params : not null access Parameters) return T - is abstract; - -function Ada.Tags.Generic_Dispatching_Constructor - (The_Tag : Tag; - Params : not null access Parameters) return T'Class; -pragma Preelaborate (Generic_Dispatching_Constructor); -pragma Import (Intrinsic, Generic_Dispatching_Constructor); diff --git a/gcc/ada/a-tiboio.adb b/gcc/ada/a-tiboio.adb deleted file mode 100644 index dcc91be..0000000 --- a/gcc/ada/a-tiboio.adb +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . B O U N D E D _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Unchecked_Deallocation; - -package body Ada.Text_IO.Bounded_IO is - - type String_Access is access all String; - - procedure Free (SA : in out String_Access); - -- Perform an unchecked deallocation of a non-null string - - ---------- - -- Free -- - ---------- - - procedure Free (SA : in out String_Access) is - Null_String : constant String := ""; - - procedure Deallocate is - new Ada.Unchecked_Deallocation (String, String_Access); - - begin - -- Do not try to free statically allocated null string - - if SA.all /= Null_String then - Deallocate (SA); - end if; - end Free; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Bounded.Bounded_String is - begin - return Bounded.To_Bounded_String (Get_Line); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line - (File : File_Type) return Bounded.Bounded_String - is - begin - return Bounded.To_Bounded_String (Get_Line (File)); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (Item : out Bounded.Bounded_String) - is - Buffer : String (1 .. 1000); - Last : Natural; - Str1 : String_Access; - Str2 : String_Access; - - begin - Get_Line (Buffer, Last); - Str1 := new String'(Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Str2 := new String'(Str1.all & Buffer (1 .. Last)); - Free (Str1); - Str1 := Str2; - end loop; - - Item := Bounded.To_Bounded_String (Str1.all); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (File : File_Type; - Item : out Bounded.Bounded_String) - is - Buffer : String (1 .. 1000); - Last : Natural; - Str1 : String_Access; - Str2 : String_Access; - - begin - Get_Line (File, Buffer, Last); - Str1 := new String'(Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Str2 := new String'(Str1.all & Buffer (1 .. Last)); - Free (Str1); - Str1 := Str2; - end loop; - - Item := Bounded.To_Bounded_String (Str1.all); - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put - (Item : Bounded.Bounded_String) - is - begin - Put (Bounded.To_String (Item)); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Bounded.Bounded_String) - is - begin - Put (File, Bounded.To_String (Item)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (Item : Bounded.Bounded_String) - is - begin - Put_Line (Bounded.To_String (Item)); - end Put_Line; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (File : File_Type; - Item : Bounded.Bounded_String) - is - begin - Put_Line (File, Bounded.To_String (Item)); - end Put_Line; - -end Ada.Text_IO.Bounded_IO; diff --git a/gcc/ada/a-tiboio.ads b/gcc/ada/a-tiboio.ads deleted file mode 100644 index 1824c1d2..0000000 --- a/gcc/ada/a-tiboio.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . B O U N D E D _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Bounded; - -generic - with package Bounded is - new Ada.Strings.Bounded.Generic_Bounded_Length (<>); - -package Ada.Text_IO.Bounded_IO is - - function Get_Line return Bounded.Bounded_String; - - function Get_Line - (File : File_Type) return Bounded.Bounded_String; - - procedure Get_Line - (Item : out Bounded.Bounded_String); - - procedure Get_Line - (File : File_Type; - Item : out Bounded.Bounded_String); - - procedure Put - (Item : Bounded.Bounded_String); - - procedure Put - (File : File_Type; - Item : Bounded.Bounded_String); - - procedure Put_Line - (Item : Bounded.Bounded_String); - - procedure Put_Line - (File : File_Type; - Item : Bounded.Bounded_String); - -end Ada.Text_IO.Bounded_IO; diff --git a/gcc/ada/a-ticoau.adb b/gcc/ada/a-ticoau.adb deleted file mode 100644 index 0601ef0..0000000 --- a/gcc/ada/a-ticoau.adb +++ /dev/null @@ -1,202 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . C O M P L E X _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; -with Ada.Text_IO.Float_Aux; - -with System.Img_Real; use System.Img_Real; - -package body Ada.Text_IO.Complex_Aux is - - package Aux renames Ada.Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer; - Paren : Boolean := False; - - begin - -- General note for following code, exceptions from the calls to - -- Get for components of the complex value are propagated. - - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); - - for J in Ptr + 1 .. Stop loop - if not Is_Blank (Buf (J)) then - raise Data_Error; - end if; - end loop; - - -- Case of width = 0 - - else - Load_Skip (File); - Ptr := 0; - Load (File, Buf, Ptr, '(', Paren); - Aux.Get (File, ItemR, 0); - Load_Skip (File); - Load (File, Buf, Ptr, ','); - Aux.Get (File, ItemI, 0); - - if Paren then - Load_Skip (File); - Load (File, Buf, Ptr, ')', Paren); - - if not Paren then - raise Data_Error; - end if; - end if; - end if; - end Get; - - ---------- - -- Gets -- - ---------- - - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive) - is - Paren : Boolean; - Pos : Integer; - - begin - String_Skip (From, Pos); - - if From (Pos) = '(' then - Pos := Pos + 1; - Paren := True; - else - Paren := False; - end if; - - Aux.Gets (From (Pos .. From'Last), ItemR, Pos); - - String_Skip (From (Pos + 1 .. From'Last), Pos); - - if From (Pos) = ',' then - Pos := Pos + 1; - end if; - - Aux.Gets (From (Pos .. From'Last), ItemI, Pos); - - if Paren then - String_Skip (From (Pos + 1 .. From'Last), Pos); - - if From (Pos) /= ')' then - raise Data_Error; - end if; - end if; - - Last := Pos; - end Gets; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field) - is - begin - Put (File, '('); - Aux.Put (File, ItemR, Fore, Aft, Exp); - Put (File, ','); - Aux.Put (File, ItemI, Fore, Aft, Exp); - Put (File, ')'); - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Aft : Field; - Exp : Field) - is - I_String : String (1 .. 3 * Field'Last); - R_String : String (1 .. 3 * Field'Last); - - Iptr : Natural; - Rptr : Natural; - - begin - -- Both parts are initially converted with a Fore of 0 - - Rptr := 0; - Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); - Iptr := 0; - Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); - - -- Check room for both parts plus parens plus comma (RM G.1.3(34)) - - if Rptr + Iptr + 3 > To'Length then - raise Layout_Error; - end if; - - -- If there is room, layout result according to (RM G.1.3(31-33)) - - To (To'First) := '('; - To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); - To (To'First + Rptr + 1) := ','; - - To (To'Last) := ')'; - To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); - - for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop - To (J) := ' '; - end loop; - - end Puts; - -end Ada.Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ticoau.ads b/gcc/ada/a-ticoau.ads deleted file mode 100644 index b8fe9df..0000000 --- a/gcc/ada/a-ticoau.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . C O M P L E X _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Text_IO.Complex_IO that are --- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Complex_IO itself, --- except that the generic parameter Complex has been replaced by separate --- real and imaginary values of type Long_Long_Float, and default parameters --- have been removed because they are supplied explicitly by the calls from --- within the generic template. - -package Ada.Text_IO.Complex_Aux is - - procedure Get - (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Width : Field); - - procedure Put - (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field); - - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive); - - procedure Puts - (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Aft : Field; - Exp : Field); - -end Ada.Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ticoio.adb b/gcc/ada/a-ticoio.adb deleted file mode 100644 index f06f847..0000000 --- a/gcc/ada/a-ticoio.adb +++ /dev/null @@ -1,140 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . C O M P L E X _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; - -with Ada.Text_IO.Complex_Aux; - -package body Ada.Text_IO.Complex_IO is - - use Complex_Types; - - package Aux renames Ada.Text_IO.Complex_Aux; - - subtype LLF is Long_Long_Float; - -- Type used for calls to routines in Aux - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Complex_Types.Complex; - Width : Field := 0) - is - Real_Item : Real'Base; - Imag_Item : Real'Base; - - begin - Aux.Get (File, LLF (Real_Item), LLF (Imag_Item), Width); - Item := (Real_Item, Imag_Item); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Get -- - --------- - - procedure Get - (Item : out Complex_Types.Complex; - Width : Field := 0) - is - begin - Get (Current_In, Item, Width); - end Get; - - --------- - -- Get -- - --------- - - procedure Get - (From : String; - Item : out Complex_Types.Complex; - Last : out Positive) - is - Real_Item : Real'Base; - Imag_Item : Real'Base; - - begin - Aux.Gets (From, LLF (Real_Item), LLF (Imag_Item), Last); - Item := (Real_Item, Imag_Item); - - exception - when Data_Error => raise Constraint_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Complex_Types.Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (File, LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (Item : Complex_Types.Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Out, Item, Fore, Aft, Exp); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (To : out String; - Item : Complex_Types.Complex; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Puts (To, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); - end Put; - -end Ada.Text_IO.Complex_IO; diff --git a/gcc/ada/a-ticoio.ads b/gcc/ada/a-ticoio.ads deleted file mode 100644 index 9b71b97..0000000 --- a/gcc/ada/a-ticoio.ads +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . C O M P L E X _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; - -generic - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); - -package Ada.Text_IO.Complex_IO is - - Default_Fore : Field := 2; - Default_Aft : Field := Complex_Types.Real'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Complex_Types.Complex; - Width : Field := 0); - - procedure Get - (Item : out Complex_Types.Complex; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Complex_Types.Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Complex_Types.Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : String; - Item : out Complex_Types.Complex; - Last : out Positive); - - procedure Put - (To : out String; - Item : Complex_Types.Complex; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -private - pragma Inline (Get); - pragma Inline (Put); - -end Ada.Text_IO.Complex_IO; diff --git a/gcc/ada/a-tideau.adb b/gcc/ada/a-tideau.adb deleted file mode 100644 index 2790bed..0000000 --- a/gcc/ada/a-tideau.adb +++ /dev/null @@ -1,261 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . D E C I M A L _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; -with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux; - -with System.Img_Dec; use System.Img_Dec; -with System.Img_LLD; use System.Img_LLD; -with System.Val_Dec; use System.Val_Dec; -with System.Val_LLD; use System.Val_LLD; - -package body Ada.Text_IO.Decimal_Aux is - - ------------- - -- Get_Dec -- - ------------- - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_Dec; - - ------------- - -- Get_LLD -- - ------------- - - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Long_Long_Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_LLD; - - -------------- - -- Gets_Dec -- - -------------- - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer - is - Pos : aliased Integer; - Item : Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; - - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - end Gets_Dec; - - -------------- - -- Gets_LLD -- - -------------- - - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer - is - Pos : aliased Integer; - Item : Long_Long_Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; - - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - end Gets_LLD; - - ------------- - -- Put_Dec -- - ------------- - - procedure Put_Dec - (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_Dec; - - ------------- - -- Put_LLD -- - ------------- - - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLD; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - -- Compute Fore, allowing for Aft digits and the decimal dot - - Fore := To'Length - Field'Max (1, Aft) - 1; - - -- Allow for Exp and two more for E+ or E- if exponent present - - if Exp /= 0 then - Fore := Fore - 2 - Exp; - end if; - - -- Make sure we have enough room - - if Fore < 1 then - raise Layout_Error; - end if; - - -- Do the conversion and check length of result - - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_Dec; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - Fore := - (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); - - if Fore < 1 then - raise Layout_Error; - end if; - - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_LLD; - -end Ada.Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-tideau.ads b/gcc/ada/a-tideau.ads deleted file mode 100644 index ae75fc1..0000000 --- a/gcc/ada/a-tideau.ads +++ /dev/null @@ -1,92 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . D E C I M A L _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Text_IO.Decimal_IO that are --- shared among separate instantiations of this package. The routines in --- the package are identical semantically to those declared in Text_IO, --- except that default values have been supplied by the generic, and the --- Num parameter has been replaced by Integer or Long_Long_Integer, with --- an additional Scale parameter giving the value of Num'Scale. In addition --- the Get routines return the value rather than store it in an Out parameter. - -private package Ada.Text_IO.Decimal_Aux is - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer; - - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer; - - procedure Put_Dec - (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer; - - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer; - - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer); - -end Ada.Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-tideio.adb b/gcc/ada/a-tideio.adb deleted file mode 100644 index 5dceb12..0000000 --- a/gcc/ada/a-tideio.adb +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . D E C I M A L _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Decimal_Aux; - -package body Ada.Text_IO.Decimal_IO is - - package Aux renames Ada.Text_IO.Decimal_Aux; - - Scale : constant Integer := Num'Scale; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - pragma Unsuppress (Range_Check); - - begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale)); - else - Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale)); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_In, Item, Width); - end Get; - - procedure Get - (From : String; - Item : out Num; - Last : out Positive) - is - pragma Unsuppress (Range_Check); - - begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value - (Aux.Gets_LLD (From, Last'Unrestricted_Access, Scale)); - else - Item := Num'Fixed_Value - (Aux.Gets_Dec (From, Last'Unrestricted_Access, Scale)); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - if Num'Size > Integer'Size then - Aux.Put_LLD - (File, Long_Long_Integer'Integer_Value (Item), - Fore, Aft, Exp, Scale); - else - Aux.Put_Dec - (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); - end if; - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Out, Item, Fore, Aft, Exp); - end Put; - - procedure Put - (To : out String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - if Num'Size > Integer'Size then - Aux.Puts_LLD - (To, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); - else - Aux.Puts_Dec (To, Integer'Integer_Value (Item), Aft, Exp, Scale); - end if; - end Put; - -end Ada.Text_IO.Decimal_IO; diff --git a/gcc/ada/a-tideio.ads b/gcc/ada/a-tideio.ads deleted file mode 100644 index 47acdd6..0000000 --- a/gcc/ada/a-tideio.ads +++ /dev/null @@ -1,89 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . D E C I M A L _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Text_IO.Decimal_IO is a subpackage of Text_IO. --- This is for compatibility with Ada 83. In GNAT we make it a child package --- to avoid loading the necessary code if Decimal_IO is not instantiated. --- See routine Rtsfind.Check_Text_IO_Special_Unit for a description of how --- we patch up the difference in semantics so that it is invisible to the --- Ada programmer. - -private generic - type Num is delta <> digits <>; - -package Ada.Text_IO.Decimal_IO is - - Default_Fore : Field := Num'Fore; - Default_Aft : Field := Num'Aft; - Default_Exp : Field := 0; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -private - pragma Inline (Get); - pragma Inline (Put); - -end Ada.Text_IO.Decimal_IO; diff --git a/gcc/ada/a-tienau.adb b/gcc/ada/a-tienau.adb deleted file mode 100644 index 6ee9bba..0000000 --- a/gcc/ada/a-tienau.adb +++ /dev/null @@ -1,283 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . E N U M E R A T I O N _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; -with Ada.Characters.Handling; use Ada.Characters.Handling; - --- Note: this package does not yet deal properly with wide characters ??? - -package body Ada.Text_IO.Enumeration_Aux is - - ------------------ - -- Get_Enum_Lit -- - ------------------ - - procedure Get_Enum_Lit - (File : File_Type; - Buf : out String; - Buflen : out Natural) - is - ch : Integer; - C : Character; - - begin - Buflen := 0; - Load_Skip (File); - ch := Getc (File); - C := Character'Val (ch); - - -- Character literal case. If the initial character is a quote, then - -- we read as far as we can without backup (see ACVC test CE3905L) - - if C = ''' then - Store_Char (File, ch, Buf, Buflen); - - ch := Getc (File); - - if ch in 16#20# .. 16#7E# or else ch >= 16#80# then - Store_Char (File, ch, Buf, Buflen); - - ch := Getc (File); - - if ch = Character'Pos (''') then - Store_Char (File, ch, Buf, Buflen); - else - Ungetc (ch, File); - end if; - - else - Ungetc (ch, File); - end if; - - -- Similarly for identifiers, read as far as we can, in particular, - -- do read a trailing underscore (again see ACVC test CE3905L to - -- understand why we do this, although it seems somewhat peculiar). - - else - -- Identifier must start with a letter - - if not Is_Letter (C) then - Ungetc (ch, File); - return; - end if; - - -- If we do have a letter, loop through the characters quitting on - -- the first non-identifier character (note that this includes the - -- cases of hitting a line mark or page mark). - - loop - C := Character'Val (ch); - Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen); - - ch := Getc (File); - exit when ch = EOF_Char; - C := Character'Val (ch); - - exit when not Is_Letter (C) - and then not Is_Digit (C) - and then C /= '_'; - - exit when C = '_' - and then Buf (Buflen) = '_'; - end loop; - - Ungetc (ch, File); - end if; - end Get_Enum_Lit; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : String; - Width : Field; - Set : Type_Set) - is - Actual_Width : constant Count := Count'Max (Count (Width), Item'Length); - - begin - -- Deal with limited line length of output file - - if Line_Length (File) /= 0 then - - -- If actual width exceeds line length, raise Layout_Error - - if Actual_Width > Line_Length (File) then - raise Layout_Error; - end if; - - -- If full width cannot fit on current line move to new line - - if Actual_Width + (Col (File) - 1) > Line_Length (File) then - New_Line (File); - end if; - end if; - - -- Output in lower case if necessary - - if Set = Lower_Case and then Item (Item'First) /= ''' then - declare - Iteml : String (Item'First .. Item'Last); - - begin - for J in Item'Range loop - Iteml (J) := To_Lower (Item (J)); - end loop; - - Put_Item (File, Iteml); - end; - - -- Otherwise output in upper case - - else - Put_Item (File, Item); - end if; - - -- Fill out item with spaces to width - - for J in 1 .. Actual_Width - Item'Length loop - Put (File, ' '); - end loop; - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out String; - Item : String; - Set : Type_Set) - is - Ptr : Natural; - - begin - if Item'Length > To'Length then - raise Layout_Error; - - else - Ptr := To'First; - for J in Item'Range loop - if Set = Lower_Case and then Item (Item'First) /= ''' then - To (Ptr) := To_Lower (Item (J)); - else - To (Ptr) := Item (J); - end if; - - Ptr := Ptr + 1; - end loop; - - while Ptr <= To'Last loop - To (Ptr) := ' '; - Ptr := Ptr + 1; - end loop; - end if; - end Puts; - - ------------------- - -- Scan_Enum_Lit -- - ------------------- - - procedure Scan_Enum_Lit - (From : String; - Start : out Natural; - Stop : out Natural) - is - C : Character; - - -- Processing for Scan_Enum_Lit - - begin - String_Skip (From, Start); - - -- Character literal case. If the initial character is a quote, then - -- we read as far as we can without backup (see ACVC test CE3905L - -- which is for the analogous case for reading from a file). - - if From (Start) = ''' then - Stop := Start; - - if Stop = From'Last then - raise Data_Error; - else - Stop := Stop + 1; - end if; - - if From (Stop) in ' ' .. '~' - or else From (Stop) >= Character'Val (16#80#) - then - if Stop = From'Last then - raise Data_Error; - else - Stop := Stop + 1; - - if From (Stop) = ''' then - return; - end if; - end if; - end if; - - raise Data_Error; - - -- Similarly for identifiers, read as far as we can, in particular, - -- do read a trailing underscore (again see ACVC test CE3905L to - -- understand why we do this, although it seems somewhat peculiar). - - else - -- Identifier must start with a letter - - if not Is_Letter (From (Start)) then - raise Data_Error; - end if; - - -- If we do have a letter, loop through the characters quitting on - -- the first non-identifier character (note that this includes the - -- cases of hitting a line mark or page mark). - - Stop := Start; - while Stop < From'Last loop - C := From (Stop + 1); - - exit when not Is_Letter (C) - and then not Is_Digit (C) - and then C /= '_'; - - exit when C = '_' - and then From (Stop) = '_'; - - Stop := Stop + 1; - end loop; - end if; - end Scan_Enum_Lit; - -end Ada.Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-tienau.ads b/gcc/ada/a-tienau.ads deleted file mode 100644 index 525c223..0000000 --- a/gcc/ada/a-tienau.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . E N U M E R A T I O N _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Text_IO.Enumeration_IO --- that are shared among separate instantiations of this package. - -private package Ada.Text_IO.Enumeration_Aux is - - procedure Get_Enum_Lit - (File : File_Type; - Buf : out String; - Buflen : out Natural); - -- Reads an enumeration literal value from the file, folds to upper case, - -- and stores the result in Buf, setting Buflen to the number of stored - -- characters (Buf has a lower bound of 1). If more than Buflen characters - -- are present in the literal, Data_Error is raised. - - procedure Scan_Enum_Lit - (From : String; - Start : out Natural; - Stop : out Natural); - -- Scans an enumeration literal at the start of From, skipping any leading - -- spaces. Sets Start to the first character, Stop to the last character. - -- Raises End_Error if no enumeration literal is found. - - procedure Put - (File : File_Type; - Item : String; - Width : Field; - Set : Type_Set); - -- Outputs the enumeration literal image stored in Item to the given File, - -- using the given Width and Set parameters (Item is always in upper case). - - procedure Puts - (To : out String; - Item : String; - Set : Type_Set); - -- Stores the enumeration literal image stored in Item to the string To, - -- padding with trailing spaces if necessary to fill To. Set is used to - -end Ada.Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-tienio.adb b/gcc/ada/a-tienio.adb deleted file mode 100644 index e98f410..0000000 --- a/gcc/ada/a-tienio.adb +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . E N U M E R A T I O N _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Enumeration_Aux; - -package body Ada.Text_IO.Enumeration_IO is - - package Aux renames Ada.Text_IO.Enumeration_Aux; - - --------- - -- Get -- - --------- - - procedure Get (File : File_Type; Item : out Enum) is - Buf : String (1 .. Enum'Width + 1); - Buflen : Natural; - - begin - Aux.Get_Enum_Lit (File, Buf, Buflen); - - declare - Buf_Str : String renames Buf (1 .. Buflen); - pragma Unsuppress (Range_Check); - begin - Item := Enum'Value (Buf_Str); - end; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get (Item : out Enum) is - pragma Unsuppress (Range_Check); - begin - Get (Current_In, Item); - end Get; - - procedure Get - (From : String; - Item : out Enum; - Last : out Positive) - is - Start : Natural; - - begin - Aux.Scan_Enum_Lit (From, Start, Last); - - declare - From_Str : String renames From (Start .. Last); - pragma Unsuppress (Range_Check); - begin - Item := Enum'Value (From_Str); - end; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting) - is - begin - -- Ensure that Item is valid before attempting to retrieve the Image, to - -- prevent the possibility of out-of-bounds addressing of index or image - -- tables. Units in the run-time library are normally compiled with - -- checks suppressed, which includes instantiated generics. - - if not Item'Valid then - raise Constraint_Error with "invalid enumeration value"; - end if; - - Aux.Put (File, Enum'Image (Item), Width, Set); - end Put; - - procedure Put - (Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting) - is - begin - Put (Current_Out, Item, Width, Set); - end Put; - - procedure Put - (To : out String; - Item : Enum; - Set : Type_Set := Default_Setting) - is - begin - -- Ensure that Item is valid before attempting to retrieve the Image, to - -- prevent the possibility of out-of-bounds addressing of index or image - -- tables. Units in the run-time library are normally compiled with - -- checks suppressed, which includes instantiated generics. - - if not Item'Valid then - raise Constraint_Error with "invalid enumeration value"; - end if; - - Aux.Puts (To, Enum'Image (Item), Set); - end Put; - -end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-tienio.ads b/gcc/ada/a-tienio.ads deleted file mode 100644 index 68f4694..0000000 --- a/gcc/ada/a-tienio.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . E N U M E R A T I O N _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Text_IO.Enumeration_IO is a subpackage of --- Text_IO. This is for compatibility with Ada 83. In GNAT we make it a --- child package to avoid loading the necessary code if Enumeration_IO is --- not instantiated. See routine Rtsfind.Check_Text_IO_Special_Unit for a --- description of how we patch up the difference in semantics so that it --- is invisible to the Ada programmer. - -private generic - type Enum is (<>); - -package Ada.Text_IO.Enumeration_IO is - - Default_Width : Field := 0; - Default_Setting : Type_Set := Upper_Case; - - procedure Get (File : File_Type; Item : out Enum); - procedure Get (Item : out Enum); - - procedure Put - (File : File_Type; - Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting); - - procedure Put - (Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting); - - procedure Get - (From : String; - Item : out Enum; - Last : out Positive); - - procedure Put - (To : out String; - Item : Enum; - Set : Type_Set := Default_Setting); - -end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-tifiio.adb b/gcc/ada/a-tifiio.adb deleted file mode 100644 index 2fd8b54..0000000 --- a/gcc/ada/a-tifiio.adb +++ /dev/null @@ -1,716 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . F I X E D _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Fixed point I/O --- --------------- - --- The following documents implementation details of the fixed point --- input/output routines in the GNAT run time. The first part describes --- general properties of fixed point types as defined by the Ada 95 standard, --- including the Information Systems Annex. - --- Subsequently these are reduced to implementation constraints and the impact --- of these constraints on a few possible approaches to I/O are given. --- Based on this analysis, a specific implementation is selected for use in --- the GNAT run time. Finally, the chosen algorithm is analyzed numerically in --- order to provide user-level documentation on limits for range and precision --- of fixed point types as well as accuracy of input/output conversions. - --- ------------------------------------------- --- - General Properties of Fixed Point Types - --- ------------------------------------------- - --- Operations on fixed point values, other than input and output, are not --- important for the purposes of this document. Only the set of values that a --- fixed point type can represent and the input and output operations are --- significant. - --- Values --- ------ - --- Set set of values of a fixed point type comprise the integral --- multiples of a number called the small of the type. The small can --- either be a power of ten, a power of two or (if the implementation --- allows) an arbitrary strictly positive real value. - --- Implementations need to support fixed-point types with a precision --- of at least 24 bits, and (in order to comply with the Information --- Systems Annex) decimal types need to support at least digits 18. --- For the rest, however, no requirements exist for the minimal small --- and range that need to be supported. - --- Operations --- ---------- - --- 'Image and 'Wide_Image (see RM 3.5(34)) - --- These attributes return a decimal real literal best approximating --- the value (rounded away from zero if halfway between) with a --- single leading character that is either a minus sign or a space, --- one or more digits before the decimal point (with no redundant --- leading zeros), a decimal point, and N digits after the decimal --- point. For a subtype S, the value of N is S'Aft, the smallest --- positive integer such that (10**N)*S'Delta is greater or equal to --- one, see RM 3.5.10(5). - --- For an arbitrary small, this means large number arithmetic needs --- to be performed. - --- Put (see RM A.10.9(22-26)) - --- The requirements for Put add no extra constraints over the image --- attributes, although it would be nice to be able to output more --- than S'Aft digits after the decimal point for values of subtype S. - --- 'Value and 'Wide_Value attribute (RM 3.5(40-55)) - --- Since the input can be given in any base in the range 2..16, --- accurate conversion to a fixed point number may require --- arbitrary precision arithmetic if there is no limit on the --- magnitude of the small of the fixed point type. - --- Get (see RM A.10.9(12-21)) - --- The requirements for Get are identical to those of the Value --- attribute. - --- ------------------------------ --- - Implementation Constraints - --- ------------------------------ - --- The requirements listed above for the input/output operations lead to --- significant complexity, if no constraints are put on supported smalls. - --- Implementation Strategies --- ------------------------- - --- * Float arithmetic --- * Arbitrary-precision integer arithmetic --- * Fixed-precision integer arithmetic - --- Although it seems convenient to convert fixed point numbers to floating- --- point and then print them, this leads to a number of restrictions. --- The first one is precision. The widest floating-point type generally --- available has 53 bits of mantissa. This means that Fine_Delta cannot --- be less than 2.0**(-53). - --- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a --- 64-bit type. It would still be possible to use multi-precision --- floating-point to perform calculations using longer mantissas, --- but this is a much harder approach. - --- The base conversions needed for input and output of (non-decimal) --- fixed point types can be seen as pairs of integer multiplications --- and divisions. - --- Arbitrary-precision integer arithmetic would be suitable for the job --- at hand, but has the draw-back that it is very heavy implementation-wise. --- Especially in embedded systems, where fixed point types are often used, --- it may not be desirable to require large amounts of storage and time --- for fixed I/O operations. - --- Fixed-precision integer arithmetic has the advantage of simplicity and --- speed. For the most common fixed point types this would be a perfect --- solution. The downside however may be a too limited set of acceptable --- fixed point types. - --- Extra Precision --- --------------- - --- Using a scaled divide which truncates and returns a remainder R, --- another E trailing digits can be calculated by computing the value --- (R * (10.0**E)) / Z using another scaled divide. This procedure --- can be repeated to compute an arbitrary number of digits in linear --- time and storage. The last scaled divide should be rounded, with --- a possible carry propagating to the more significant digits, to --- ensure correct rounding of the unit in the last place. - --- An extension of this technique is to limit the value of Q to 9 decimal --- digits, since 32-bit integers can be much more efficient than 64-bit --- integers to output. - -with Interfaces; use Interfaces; -with System.Arith_64; use System.Arith_64; -with System.Img_Real; use System.Img_Real; -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Text_IO.Float_Aux; -with Ada.Text_IO.Generic_Aux; - -package body Ada.Text_IO.Fixed_IO is - - -- Note: we still use the floating-point I/O routines for input of - -- ordinary fixed-point and output using exponent format. This will - -- result in inaccuracies for fixed point types with a small that is - -- not a power of two, and for types that require more precision than - -- is available in Long_Long_Float. - - package Aux renames Ada.Text_IO.Float_Aux; - - Extra_Layout_Space : constant Field := 5 + Num'Fore; - -- Extra space that may be needed for output of sign, decimal point, - -- exponent indication and mandatory decimals after and before the - -- decimal point. A string with length - - -- Fore + Aft + Exp + Extra_Layout_Space - - -- is always long enough for formatting any fixed point number - - -- Implementation of Put routines - - -- The following section describes a specific implementation choice for - -- performing base conversions needed for output of values of a fixed - -- point type T with small T'Small. The goal is to be able to output - -- all values of types with a precision of 64 bits and a delta of at - -- least 2.0**(-63), as these are current GNAT limitations already. - - -- The chosen algorithm uses fixed precision integer arithmetic for - -- reasons of simplicity and efficiency. It is important to understand - -- in what ways the most simple and accurate approach to fixed point I/O - -- is limiting, before considering more complicated schemes. - - -- Without loss of generality assume T has a range (-2.0**63) * T'Small - -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the - -- decimal point and T'Fore - 1 before. If T'Small is integer, or - -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small, - -- let S and E be integers such that S / 10**E best approximates T'Small - -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling - -- factor 10**E can be trivially handled during final output, by adjusting - -- the decimal point or exponent. - - -- Convert a value X * S of type T to a 64-bit integer value Q equal - -- to 10.0**D * (X * S) rounded to the nearest integer. - -- This conversion is a scaled integer divide of the form - - -- Q := (X * Y) / Z, - - -- where all variables are 64-bit signed integers using 2's complement, - -- and both the multiplication and division are done using full - -- intermediate precision. The final decimal value to be output is - - -- Q * 10**(E-D) - - -- This value can be written to the output file or to the result string - -- according to the format described in RM A.3.10. The details of this - -- operation are omitted here. - - -- A 64-bit value can contain all integers with 18 decimal digits, but - -- not all with 19 decimal digits. If the total number of requested output - -- digits (Fore - 1) + Aft is greater than 18, for purposes of the - -- conversion Aft is adjusted to 18 - (Fore - 1). In that case, or - -- when Fore > 19, trailing zeros can complete the output after writing - -- the first 18 significant digits, or the technique described in the - -- next section can be used. - - -- The final expression for D is - - -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); - - -- For Y and Z the following expressions can be derived: - - -- Q / (10.0**D) = X * S - - -- Q = X * S * (10.0**D) = (X * Y) / Z - - -- S * 10.0**D = Y / Z; - - -- If S is an integer greater than or equal to one, then Fore must be at - -- least 20 in order to print T'First, which is at most -2.0**63. - -- This means D < 0, so use - - -- (1) Y = -S and Z = -10**(-D) - - -- If 1.0 / S is an integer greater than one, use - - -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0 - - -- or - - -- (3) Y = 1 and Z = (1.0 / S) * 10**(-D), for D < 0 - - -- Negative values are used for nominator Y and denominator Z, so that S - -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). - -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as - -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room - -- in the denominator for the extra decimal scaling required, so case (3) - -- will not overflow. - - pragma Assert (System.Fine_Delta >= 2.0**(-63)); - pragma Assert (Num'Small in 2.0**(-63) .. 2.0**63); - pragma Assert (Num'Fore <= 37); - -- These assertions need to be relaxed to allow for a Small of - -- 2.0**(-64) at least, since there is an ACATS test for this ??? - - Max_Digits : constant := 18; - -- Maximum number of decimal digits that can be represented in a - -- 64-bit signed number, see above - - -- The constants E0 .. E5 implement a binary search for the appropriate - -- power of ten to scale the small so that it has one digit before the - -- decimal point. - - subtype Int is Integer; - E0 : constant Int := -(20 * Boolean'Pos (Num'Small >= 1.0E1)); - E1 : constant Int := E0 + 10 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-10); - E2 : constant Int := E1 + 5 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-5); - E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3); - E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1); - E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0); - - Scale : constant Integer := E5; - - pragma Assert (Num'Small * 10.0**Scale >= 1.0 - and then Num'Small * 10.0**Scale < 10.0); - - Exact : constant Boolean := - Float'Floor (Num'Small) = Float'Ceiling (Num'Small) - or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small) - or else Num'Small >= 10.0**Max_Digits; - -- True iff a numerator and denominator can be calculated such that - -- their ratio exactly represents the small of Num. - - procedure Put - (To : out String; - Last : out Natural; - Item : Num; - Fore : Integer; - Aft : Field; - Exp : Field); - -- Actual output function, used internally by all other Put routines. - -- The formal Fore is an Integer, not a Field, because the routine is - -- also called from the version of Put that performs I/O to a string, - -- where the starting position depends on the size of the String, and - -- bears no relation to the bounds of Field. - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - pragma Unsuppress (Range_Check); - begin - Aux.Get (File, Long_Long_Float (Item), Width); - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - pragma Unsuppress (Range_Check); - begin - Aux.Get (Current_In, Long_Long_Float (Item), Width); - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (From : String; - Item : out Num; - Last : out Positive) - is - pragma Unsuppress (Range_Check); - begin - Aux.Gets (From, Long_Long_Float (Item), Last); - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); - Last : Natural; - begin - Put (S, Last, Item, Fore, Aft, Exp); - Generic_Aux.Put_Item (File, S (1 .. Last)); - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); - Last : Natural; - begin - Put (S, Last, Item, Fore, Aft, Exp); - Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last)); - end Put; - - procedure Put - (To : out String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - Fore : constant Integer := - To'Length - - 1 -- Decimal point - - Field'Max (1, Aft) -- Decimal part - - Boolean'Pos (Exp /= 0) -- Exponent indicator - - Exp; -- Exponent - - Last : Natural; - - begin - if Fore - Boolean'Pos (Item < 0.0) < 1 then - raise Layout_Error; - end if; - - Put (To, Last, Item, Fore, Aft, Exp); - - if Last /= To'Last then - raise Layout_Error; - end if; - end Put; - - procedure Put - (To : out String; - Last : out Natural; - Item : Num; - Fore : Integer; - Aft : Field; - Exp : Field) - is - subtype Digit is Int64 range 0 .. 9; - - X : constant Int64 := Int64'Integer_Value (Item); - A : constant Field := Field'Max (Aft, 1); - Neg : constant Boolean := (Item < 0.0); - Pos : Integer := 0; -- Next digit X has value X * 10.0**Pos; - - procedure Put_Character (C : Character); - pragma Inline (Put_Character); - -- Add C to the output string To, updating Last - - procedure Put_Digit (X : Digit); - -- Add digit X to the output string (going from left to right), updating - -- Last and Pos, and inserting the sign, leading zeros or a decimal - -- point when necessary. After outputting the first digit, Pos must not - -- be changed outside Put_Digit anymore. - - procedure Put_Int64 (X : Int64; Scale : Integer); - -- Output the decimal number abs X * 10**Scale - - procedure Put_Scaled - (X, Y, Z : Int64; - A : Field; - E : Integer); - -- Output the decimal number (X * Y / Z) * 10**E, producing A digits - -- after the decimal point and rounding the final digit. The value - -- X * Y / Z is computed with full precision, but must be in the - -- range of Int64. - - ------------------- - -- Put_Character -- - ------------------- - - procedure Put_Character (C : Character) is - begin - Last := Last + 1; - - -- Never put a character outside of string To. Exception Layout_Error - -- will be raised later if Last is greater than To'Last. - - if Last <= To'Last then - To (Last) := C; - end if; - end Put_Character; - - --------------- - -- Put_Digit -- - --------------- - - procedure Put_Digit (X : Digit) is - Digs : constant array (Digit) of Character := "0123456789"; - - begin - if Last = To'First - 1 then - if X /= 0 or else Pos <= 0 then - - -- Before outputting first digit, include leading space, - -- possible minus sign and, if the first digit is fractional, - -- decimal seperator and leading zeros. - - -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters, - -- if Pos >= 0 and otherwise has a single zero digit plus minus - -- sign if negative. Add leading space if necessary. - - for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore - loop - Put_Character (' '); - end loop; - - -- Output minus sign, if number is negative - - if Neg then - Put_Character ('-'); - end if; - - -- If starting with fractional digit, output leading zeros - - if Pos < 0 then - Put_Character ('0'); - Put_Character ('.'); - - for J in Pos .. -2 loop - Put_Character ('0'); - end loop; - end if; - - Put_Character (Digs (X)); - end if; - - else - -- This is not the first digit to be output, so the only - -- special handling is that for the decimal point - - if Pos = -1 then - Put_Character ('.'); - end if; - - Put_Character (Digs (X)); - end if; - - Pos := Pos - 1; - end Put_Digit; - - --------------- - -- Put_Int64 -- - --------------- - - procedure Put_Int64 (X : Int64; Scale : Integer) is - begin - if X = 0 then - return; - end if; - - if X not in -9 .. 9 then - Put_Int64 (X / 10, Scale + 1); - end if; - - -- Use Put_Digit to advance Pos. This fixes a case where the second - -- or later Scaled_Divide would omit leading zeroes, resulting in - -- too few digits produced and a Layout_Error as result. - - while Pos > Scale loop - Put_Digit (0); - end loop; - - -- If and only if more than one digit is output before the decimal - -- point, pos will be unequal to scale when outputting the first - -- digit. - - pragma Assert (Pos = Scale or else Last = To'First - 1); - - Pos := Scale; - - Put_Digit (abs (X rem 10)); - end Put_Int64; - - ---------------- - -- Put_Scaled -- - ---------------- - - procedure Put_Scaled - (X, Y, Z : Int64; - A : Field; - E : Integer) - is - pragma Assert (E >= -Max_Digits); - AA : constant Field := E + A; - N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1; - - Q : array (0 .. N - 1) of Int64 := (others => 0); - -- Each element of Q has Max_Digits decimal digits, except the - -- last, which has eAA rem Max_Digits. Only Q (Q'First) may have an - -- absolute value equal to or larger than 10**Max_Digits. Only the - -- absolute value of the elements is not significant, not the sign. - - XX : Int64 := X; - YY : Int64 := Y; - - begin - for J in Q'Range loop - exit when XX = 0; - - if J > 0 then - YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits)); - end if; - - Scaled_Divide (XX, YY, Z, Q (J), R => XX, Round => False); - end loop; - - if -E > A then - pragma Assert (N = 1); - - Discard_Extra_Digits : declare - Factor : constant Int64 := 10**(-E - A); - - begin - -- The scaling factors were such that the first division - -- produced more digits than requested. So divide away extra - -- digits and compute new remainder for later rounding. - - if abs (Q (0) rem Factor) >= Factor / 2 then - Q (0) := abs (Q (0) / Factor) + 1; - else - Q (0) := Q (0) / Factor; - end if; - - XX := 0; - end Discard_Extra_Digits; - end if; - - -- At this point XX is a remainder and we need to determine if the - -- quotient in Q must be rounded away from zero. - - -- As XX is less than the divisor, it is safe to take its absolute - -- without chance of overflow. The check to see if XX is at least - -- half the absolute value of the divisor must be done carefully to - -- avoid overflow or lose precision. - - XX := abs XX; - - if XX >= 2**62 - or else (Z < 0 and then (-XX) * 2 <= Z) - or else (Z >= 0 and then XX * 2 >= Z) - then - -- OK, rounding is necessary. As the sign is not significant, - -- take advantage of the fact that an extra negative value will - -- always be available when propagating the carry. - - Q (Q'Last) := -abs Q (Q'Last) - 1; - - Propagate_Carry : - for J in reverse 1 .. Q'Last loop - if Q (J) = YY or else Q (J) = -YY then - Q (J) := 0; - Q (J - 1) := -abs Q (J - 1) - 1; - - else - exit Propagate_Carry; - end if; - end loop Propagate_Carry; - end if; - - for J in Q'First .. Q'Last - 1 loop - Put_Int64 (Q (J), E - J * Max_Digits); - end loop; - - Put_Int64 (Q (Q'Last), -A); - end Put_Scaled; - - -- Start of processing for Put - - begin - Last := To'First - 1; - - if Exp /= 0 then - - -- With the Exp format, it is not known how many output digits to - -- generate, as leading zeros must be ignored. Computing too many - -- digits and then truncating the output will not give the closest - -- output, it is necessary to round at the correct digit. - - -- The general approach is as follows: as long as no digits have - -- been generated, compute the Aft next digits (without rounding). - -- Once a non-zero digit is generated, determine the exact number - -- of digits remaining and compute them with rounding. - - -- Since a large number of iterations might be necessary in case - -- of Aft = 1, the following optimization would be desirable. - - -- Count the number Z of leading zero bits in the integer - -- representation of X, and start with producing Aft + Z * 1000 / - -- 3322 digits in the first scaled division. - - -- However, the floating-point routines are still used now ??? - - System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last, - Fore, Aft, Exp); - return; - end if; - - if Exact then - declare - D : constant Integer := Integer'Min (A, Max_Digits - - (Num'Fore - 1)); - Y : constant Int64 := Int64'Min (Int64 (-Num'Small), -1) - * 10**Integer'Max (0, D); - Z : constant Int64 := Int64'Min (Int64 (-(1.0 / Num'Small)), -1) - * 10**Integer'Max (0, -D); - begin - Put_Scaled (X, Y, Z, A, -D); - end; - - else -- not Exact - declare - E : constant Integer := Max_Digits - 1 + Scale; - D : constant Integer := Scale - 1; - Y : constant Int64 := Int64 (-Num'Small * 10.0**E); - Z : constant Int64 := -10**Max_Digits; - begin - Put_Scaled (X, Y, Z, A, -D); - end; - end if; - - -- If only zero digits encountered, unit digit has not been output yet - - if Last < To'First then - Pos := 0; - - elsif Last > To'Last then - raise Layout_Error; -- Not enough room in the output variable - end if; - - -- Always output digits up to the first one after the decimal point - - while Pos >= -A loop - Put_Digit (0); - end loop; - end Put; - -end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/a-tifiio.ads b/gcc/ada/a-tifiio.ads deleted file mode 100644 index 265600db..0000000 --- a/gcc/ada/a-tifiio.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . F I X E D _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Text_IO.Fixed_IO is a subpackage of Text_IO. --- This is for compatibility with Ada 83. In GNAT we make it a child package --- to avoid loading the necessary code if Fixed_IO is not instantiated. See --- routine Rtsfind.Check_Text_IO_Special_Unit for a description of how we --- patch up the difference in semantics so that it is invisible to the Ada --- programmer. - -private generic - type Num is delta <>; - -package Ada.Text_IO.Fixed_IO is - - Default_Fore : Field := Num'Fore; - Default_Aft : Field := Num'Aft; - Default_Exp : Field := 0; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -private - pragma Inline (Get); - pragma Inline (Put); - -end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/a-tiflau.adb b/gcc/ada/a-tiflau.adb deleted file mode 100644 index c7115f6..0000000 --- a/gcc/ada/a-tiflau.adb +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . F L O A T _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; - -with System.Img_Real; use System.Img_Real; -with System.Val_Real; use System.Val_Real; - -package body Ada.Text_IO.Float_Aux is - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Long_Long_Float; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - end if; - - Item := Scan_Real (Buf, Ptr'Access, Stop); - - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get; - - ---------- - -- Gets -- - ---------- - - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Real (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets; - - --------------- - -- Load_Real -- - --------------- - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Loaded : Boolean; - - begin - -- Skip initial blanks, and load possible sign - - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - -- Case of .nnnn - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Otherwise must have digits to start - - else - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Based cases. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - - -- Case of nnn#.xxx# - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '#', ':'); - - -- Case of nnn#xxx.[xxx]# or nnn#xxx# - - else - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - end if; - - -- As usual, it seems strange to allow mixed base characters, - -- but that is what ACVC tests expect, see CE3804M, case (3). - - Load (File, Buf, Ptr, '#', ':'); - end if; - - -- Case of nnn.[nnn] or nnn - - else - -- Prevent the potential processing of '.' in cases where the - -- initial digits have a trailing underscore. - - if Buf (Ptr) = '_' then - return; - end if; - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr); - end if; - end if; - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end Load_Real; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field) - is - Buf : String (1 .. 3 * Field'Last + 2); - Ptr : Natural := 0; - - begin - Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out String; - Item : Long_Long_Float; - Aft : Field; - Exp : Field) - is - Buf : String (1 .. 3 * Field'Last + 2); - Ptr : Natural := 0; - - begin - Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); - - if Ptr > To'Length then - raise Layout_Error; - - else - for J in 1 .. Ptr loop - To (To'Last - Ptr + J) := Buf (J); - end loop; - - for J in To'First .. To'Last - Ptr loop - To (J) := ' '; - end loop; - end if; - end Puts; - -end Ada.Text_IO.Float_Aux; diff --git a/gcc/ada/a-tiflau.ads b/gcc/ada/a-tiflau.ads deleted file mode 100644 index 4be1758..0000000 --- a/gcc/ada/a-tiflau.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . F L O A T _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Text_IO.Float_IO that are --- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Float_IO itself, --- except that generic parameter Num has been replaced by Long_Long_Float, --- and the default parameters have been removed because they are supplied --- explicitly by the calls from within the generic template. This package --- is also used by Ada.Text_IO.Fixed_IO, and Ada.Text_IO.Decimal_IO. - -private package Ada.Text_IO.Float_Aux is - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- real literal value from the input file into Buf, starting at Ptr + 1. - - procedure Get - (File : File_Type; - Item : out Long_Long_Float; - Width : Field); - - procedure Put - (File : File_Type; - Item : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field); - - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive); - - procedure Puts - (To : out String; - Item : Long_Long_Float; - Aft : Field; - Exp : Field); - -end Ada.Text_IO.Float_Aux; diff --git a/gcc/ada/a-tiflio.adb b/gcc/ada/a-tiflio.adb deleted file mode 100644 index af0f1ab..0000000 --- a/gcc/ada/a-tiflio.adb +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . F L O A T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Float_Aux; - -package body Ada.Text_IO.Float_IO is - - package Aux renames Ada.Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - pragma Unsuppress (Range_Check); - - begin - Aux.Get (File, Long_Long_Float (Item), Width); - - -- In the case where the type is unconstrained (e.g. Standard'Float), - -- the above conversion may result in an infinite value, which is - -- normally fine for a conversion, but in this case, we want to treat - -- that as a data error. - - if not Item'Valid then - raise Data_Error; - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - pragma Unsuppress (Range_Check); - - begin - Aux.Get (Current_In, Long_Long_Float (Item), Width); - - -- In the case where the type is unconstrained (e.g. Standard'Float), - -- the above conversion may result in an infinite value, which is - -- normally fine for a conversion, but in this case, we want to treat - -- that as a data error. - - if not Item'Valid then - raise Data_Error; - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (From : String; - Item : out Num; - Last : out Positive) - is - pragma Unsuppress (Range_Check); - - begin - Aux.Gets (From, Long_Long_Float (Item), Last); - - -- In the case where the type is unconstrained (e.g. Standard'Float), - -- the above conversion may result in an infinite value, which is - -- normally fine for a conversion, but in this case, we want to treat - -- that as a data error. - - if not Item'Valid then - raise Data_Error; - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp); - end Put; - - procedure Put - (To : out String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); - end Put; - -end Ada.Text_IO.Float_IO; diff --git a/gcc/ada/a-tiflio.ads b/gcc/ada/a-tiflio.ads deleted file mode 100644 index 89eec99..0000000 --- a/gcc/ada/a-tiflio.ads +++ /dev/null @@ -1,89 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . F L O A T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Text_IO.Float_IO is a subpackage of Text_IO. --- This is for compatibility with Ada 83. In GNAT we make it a child package --- to avoid loading the necessary code if Float_IO is not instantiated. See --- routine Rtsfind.Check_Text_IO_Special_Unit for a description of how we --- patch up the difference in semantics so that it is invisible to the Ada --- programmer. - -private generic - type Num is digits <>; - -package Ada.Text_IO.Float_IO is - - Default_Fore : Field := 2; - Default_Aft : Field := Num'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -private - pragma Inline (Get); - pragma Inline (Put); - -end Ada.Text_IO.Float_IO; diff --git a/gcc/ada/a-tigeau.adb b/gcc/ada/a-tigeau.adb deleted file mode 100644 index 218aec8..0000000 --- a/gcc/ada/a-tigeau.adb +++ /dev/null @@ -1,487 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . G E N E R I C _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; - -package body Ada.Text_IO.Generic_Aux is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - subtype AP is FCB.AFCB_Ptr; - - ------------------------ - -- Check_End_Of_Field -- - ------------------------ - - procedure Check_End_Of_Field - (Buf : String; - Stop : Integer; - Ptr : Integer; - Width : Field) - is - begin - if Ptr > Stop then - return; - - elsif Width = 0 then - raise Data_Error; - - else - for J in Ptr .. Stop loop - if not Is_Blank (Buf (J)) then - raise Data_Error; - end if; - end loop; - end if; - end Check_End_Of_Field; - - ----------------------- - -- Check_On_One_Line -- - ----------------------- - - procedure Check_On_One_Line - (File : File_Type; - Length : Integer) - is - begin - FIO.Check_Write_Status (AP (File)); - - if File.Line_Length /= 0 then - if Count (Length) > File.Line_Length then - raise Layout_Error; - elsif File.Col + Count (Length) > File.Line_Length + 1 then - New_Line (File); - end if; - end if; - end Check_On_One_Line; - - ---------- - -- Getc -- - ---------- - - function Getc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF and then ferror (File.Stream) /= 0 then - raise Device_Error; - else - return ch; - end if; - end Getc; - - -------------- - -- Is_Blank -- - -------------- - - function Is_Blank (C : Character) return Boolean is - begin - return C = ' ' or else C = ASCII.HT; - end Is_Blank; - - ---------- - -- Load -- - ---------- - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character; - Loaded : out Boolean) - is - ch : int; - - begin - ch := Getc (File); - - if ch = Character'Pos (Char) then - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - else - Ungetc (ch, File); - Loaded := False; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character) - is - ch : int; - - begin - ch := Getc (File); - - if ch = Character'Pos (Char) then - Store_Char (File, ch, Buf, Ptr); - else - Ungetc (ch, File); - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character; - Loaded : out Boolean) - is - ch : int; - - begin - ch := Getc (File); - - if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - else - Ungetc (ch, File); - Loaded := False; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character) - is - ch : int; - - begin - ch := Getc (File); - - if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then - Store_Char (File, ch, Buf, Ptr); - else - Ungetc (ch, File); - end if; - end Load; - - ----------------- - -- Load_Digits -- - ----------------- - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean) - is - ch : int; - After_Digit : Boolean; - - begin - ch := Getc (File); - - if ch not in Character'Pos ('0') .. Character'Pos ('9') then - Loaded := False; - - else - Loaded := True; - After_Digit := True; - - loop - Store_Char (File, ch, Buf, Ptr); - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - end loop; - end if; - - Ungetc (ch, File); - end Load_Digits; - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer) - is - ch : int; - After_Digit : Boolean; - - begin - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - loop - Store_Char (File, ch, Buf, Ptr); - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - end loop; - end if; - - Ungetc (ch, File); - end Load_Digits; - - -------------------------- - -- Load_Extended_Digits -- - -------------------------- - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean) - is - ch : int; - After_Digit : Boolean := False; - - begin - Loaded := False; - - loop - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') - or else - ch in Character'Pos ('a') .. Character'Pos ('f') - or else - ch in Character'Pos ('A') .. Character'Pos ('F') - then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - end loop; - - Ungetc (ch, File); - end Load_Extended_Digits; - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer) - is - Junk : Boolean; - pragma Unreferenced (Junk); - begin - Load_Extended_Digits (File, Buf, Ptr, Junk); - end Load_Extended_Digits; - - --------------- - -- Load_Skip -- - --------------- - - procedure Load_Skip (File : File_Type) is - C : Character; - - begin - FIO.Check_Read_Status (AP (File)); - - -- Loop till we find a non-blank character (note that as usual in - -- Text_IO, blank includes horizontal tab). Note that Get deals with - -- the Before_LM and Before_LM_PM flags appropriately. - - loop - Get (File, C); - exit when not Is_Blank (C); - end loop; - - Ungetc (Character'Pos (C), File); - File.Col := File.Col - 1; - end Load_Skip; - - ---------------- - -- Load_Width -- - ---------------- - - procedure Load_Width - (File : File_Type; - Width : Field; - Buf : out String; - Ptr : in out Integer) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - -- If we are immediately before a line mark, then we have no characters. - -- This is always a data error, so we may as well raise it right away. - - if File.Before_LM then - raise Data_Error; - - else - for J in 1 .. Width loop - ch := Getc (File); - - if ch = EOF then - return; - - elsif ch = LM then - Ungetc (ch, File); - return; - - else - Store_Char (File, ch, Buf, Ptr); - end if; - end loop; - end if; - end Load_Width; - - ----------- - -- Nextc -- - ----------- - - function Nextc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF then - if ferror (File.Stream) /= 0 then - raise Device_Error; - else - return EOF; - end if; - - else - Ungetc (ch, File); - return ch; - end if; - end Nextc; - - -------------- - -- Put_Item -- - -------------- - - procedure Put_Item (File : File_Type; Str : String) is - begin - Check_On_One_Line (File, Str'Length); - Put (File, Str); - end Put_Item; - - ---------------- - -- Store_Char -- - ---------------- - - procedure Store_Char - (File : File_Type; - ch : int; - Buf : in out String; - Ptr : in out Integer) - is - begin - File.Col := File.Col + 1; - - if Ptr < Buf'Last then - Ptr := Ptr + 1; - end if; - - Buf (Ptr) := Character'Val (ch); - end Store_Char; - - ----------------- - -- String_Skip -- - ----------------- - - procedure String_Skip (Str : String; Ptr : out Integer) is - begin - -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. - -- It's too much trouble to make this silly case work, so we just raise - -- Program_Error with an appropriate message. We raise Program_Error - -- rather than Constraint_Error because we don't want this case to be - -- converted to Data_Error. - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - -- Normal case where Str'Last < Positive'Last - - Ptr := Str'First; - - loop - if Ptr > Str'Last then - raise End_Error; - - elsif not Is_Blank (Str (Ptr)) then - return; - - else - Ptr := Ptr + 1; - end if; - end loop; - end String_Skip; - - ------------ - -- Ungetc -- - ------------ - - procedure Ungetc (ch : int; File : File_Type) is - begin - if ch /= EOF then - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - end Ungetc; - -end Ada.Text_IO.Generic_Aux; diff --git a/gcc/ada/a-tigeau.ads b/gcc/ada/a-tigeau.ads deleted file mode 100644 index 4de4739..0000000 --- a/gcc/ada/a-tigeau.ads +++ /dev/null @@ -1,191 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . G E N E R I C _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a set of auxiliary routines used by the Text_IO --- generic children, including for reading and writing numeric strings. - -private package Ada.Text_IO.Generic_Aux is - - -- Note: for all the Load routines, File indicates the file to be read, - -- Buf is the string into which data is stored, Ptr is the index of the - -- last character stored so far, and is updated if additional characters - -- are stored. Data_Error is raised if the input overflows Buf. The only - -- Load routines that do a file status check are Load_Skip and Load_Width - -- so one of these two routines must be called first. - - procedure Check_End_Of_Field - (Buf : String; - Stop : Integer; - Ptr : Integer; - Width : Field); - -- This routine is used after doing a get operations on a numeric value. - -- Buf is the string being scanned, and Stop is the last character of - -- the field being scanned. Ptr is as set by the call to the scan routine - -- that scanned out the numeric value, i.e. it points one past the last - -- character scanned, and Width is the width parameter from the Get call. - -- - -- There are two cases, if Width is non-zero, then a check is made that - -- the remainder of the field is all blanks. If Width is zero, then it - -- means that the scan routine scanned out only part of the field. We - -- have already scanned out the field that the ACVC tests seem to expect - -- us to read (even if it does not follow the syntax of the type being - -- scanned, e.g. allowing negative exponents in integers, and underscores - -- at the end of the string), so we just raise Data_Error. - - procedure Check_On_One_Line (File : File_Type; Length : Integer); - -- Check to see if item of length Integer characters can fit on - -- current line. Call New_Line if not, first checking that the - -- line length can accommodate Length characters, raise Layout_Error - -- if item is too large for a single line. - - function Getc (File : File_Type) return Integer; - -- Gets next character from file, which has already been checked for - -- being in read status, and returns the character read if no error - -- occurs. The result is EOF if the end of file was read. Note that - -- the Col value is not bumped, so it is the caller's responsibility - -- to bump it if necessary. - - function Is_Blank (C : Character) return Boolean; - -- Determines if C is a blank (space or tab) - - procedure Load_Width - (File : File_Type; - Width : Field; - Buf : out String; - Ptr : in out Integer); - -- Loads exactly Width characters, unless a line mark is encountered first - - procedure Load_Skip (File : File_Type); - -- Skips leading blanks and line and page marks, if the end of file is - -- read without finding a non-blank character, then End_Error is raised. - -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character; - Loaded : out Boolean); - -- If next character is Char, loads it, otherwise no characters are loaded - -- Loaded is set to indicate whether or not the character was found. - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character); - -- Same as above, but no indication if character is loaded - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character; - Loaded : out Boolean); - -- If next character is Char1 or Char2, loads it, otherwise no characters - -- are loaded. Loaded is set to indicate whether or not one of the two - -- characters was found. - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character); - -- Same as above, but no indication if character is loaded - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean); - -- Loads a sequence of zero or more decimal digits. Loaded is set if - -- at least one digit is loaded. - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer); - -- Same as above, but no indication if character is loaded - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean); - -- Like Load_Digits, but also allows extended digits a-f and A-F - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer); - -- Same as above, but no indication if character is loaded - - function Nextc (File : File_Type) return Integer; - -- Like Getc, but includes a call to Ungetc, so that the file - -- pointer is not moved by the call. - - procedure Put_Item (File : File_Type; Str : String); - -- This routine is like Text_IO.Put, except that it checks for overflow - -- of bounded lines, as described in (RM A.10.6(8)). It is used for - -- all output of numeric values and of enumeration values. - - procedure Store_Char - (File : File_Type; - ch : Integer; - Buf : in out String; - Ptr : in out Integer); - -- Store a single character in buffer, checking for overflow and - -- adjusting the column number in the file to reflect the fact - -- that a character has been acquired from the input stream. If - -- the character will not fit in the buffer it is stored in the - -- last character position of the buffer and Ptr is unchanged. - -- No exception is raised in this case, it is the caller's job - -- to raise Data_Error if the buffer fills up, so typically the - -- caller will make the buffer one character longer than needed. - - procedure String_Skip (Str : String; Ptr : out Integer); - -- Used in the Get from string procedures to skip leading blanks in the - -- string. Ptr is set to the index of the first non-blank. If the string - -- is all blanks, then the exception End_Error is raised, Note that blank - -- is defined as a space or horizontal tab (RM A.10.6(5)). - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- an end of file (EOF) is ignored. - -private - pragma Inline (Is_Blank); - -end Ada.Text_IO.Generic_Aux; diff --git a/gcc/ada/a-tigeli.adb b/gcc/ada/a-tigeli.adb deleted file mode 100644 index 77b2179..0000000 --- a/gcc/ada/a-tigeli.adb +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . G E T _ L I N E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The implementation of Ada.Text_IO.Get_Line is split into a subunit so that --- different implementations can be used on different systems. This is the --- standard implementation (it uses low level features not suitable for use --- on virtual machines). - -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; - -separate (Ada.Text_IO) -procedure Get_Line - (File : File_Type; - Item : out String; - Last : out Natural) -is - Chunk_Size : constant := 80; - -- We read into a fixed size auxiliary buffer. Because this buffer - -- needs to be pre-initialized, there is a trade-off between size and - -- speed. Experiments find returns are diminishing after 50 and this - -- size allows most lines to be processed with a single read. - - ch : int; - N : Natural; - - procedure memcpy (s1, s2 : chars; n : size_t); - pragma Import (C, memcpy); - - function memchr (s : chars; ch : int; n : size_t) return chars; - pragma Import (C, memchr); - - procedure memset (b : chars; ch : int; n : size_t); - pragma Import (C, memset); - - function Get_Chunk (N : Positive) return Natural; - -- Reads at most N - 1 characters into Item (Last + 1 .. Item'Last), - -- updating Last. Raises End_Error if nothing was read (End_Of_File). - -- Returns number of characters still to read (either 0 or 1) in - -- case of success. - - --------------- - -- Get_Chunk -- - --------------- - - function Get_Chunk (N : Positive) return Natural is - Buf : String (1 .. Chunk_Size); - S : constant chars := Buf (1)'Address; - P : chars; - - begin - if N = 1 then - return N; - end if; - - memset (S, 10, size_t (N)); - - if fgets (S, N, File.Stream) = Null_Address then - if ferror (File.Stream) /= 0 then - raise Device_Error; - - -- If incomplete last line, pretend we found a LM - - elsif Last >= Item'First then - return 0; - - else - raise End_Error; - end if; - end if; - - P := memchr (S, LM, size_t (N)); - - -- If no LM is found, the buffer got filled without reading a new - -- line. Otherwise, the LM is either one from the input, or else one - -- from the initialization, which means an incomplete end-of-line was - -- encountered. Only in first case the LM will be followed by a 0. - - if P = Null_Address then - pragma Assert (Buf (N) = ASCII.NUL); - memcpy (Item (Last + 1)'Address, - Buf (1)'Address, size_t (N - 1)); - Last := Last + N - 1; - - return 1; - - else - -- P points to the LM character. Set K so Buf (K) is the character - -- right before. - - declare - K : Natural := Natural (P - S); - - begin - -- If K + 2 is greater than N, then Buf (K + 1) cannot be a LM - -- character from the source file, as the call to fgets copied at - -- most N - 1 characters. Otherwise, either LM is a character from - -- the source file and then Buf (K + 2) should be 0, or LM is a - -- character put in Buf by memset and then Buf (K) is the 0 put in - -- by fgets. In both cases where LM does not come from the source - -- file, compensate. - - if K + 2 > N or else Buf (K + 2) /= ASCII.NUL then - - -- Incomplete last line, so remove the extra 0 - - pragma Assert (Buf (K) = ASCII.NUL); - K := K - 1; - end if; - - memcpy (Item (Last + 1)'Address, - Buf (1)'Address, size_t (K)); - Last := Last + K; - end; - - return 0; - end if; - end Get_Chunk; - --- Start of processing for Get_Line - -begin - FIO.Check_Read_Status (AP (File)); - - -- Set Last to Item'First - 1 when no characters are read, as mandated by - -- Ada RM. In the case where Item'First is negative or null, this results - -- in Constraint_Error being raised. - - Last := Item'First - 1; - - -- Immediate exit for null string, this is a case in which we do not - -- need to test for end of file and we do not skip a line mark under - -- any circumstances. - - if Item'First > Item'Last then - return; - end if; - - N := Item'Last - Item'First + 1; - - -- Here we have at least one character, if we are immediately before - -- a line mark, then we will just skip past it storing no characters. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - - -- Otherwise we need to read some characters - - else - while N >= Chunk_Size loop - if Get_Chunk (Chunk_Size) = 0 then - N := 0; - else - N := N - Chunk_Size + 1; - end if; - end loop; - - if N > 1 then - N := Get_Chunk (N); - end if; - - -- Almost there, only a little bit more to read - - if N = 1 then - ch := Getc (File); - - -- If we get EOF after already reading data, this is an incomplete - -- last line, in which case no End_Error should be raised. - - if ch = EOF then - if Last < Item'First then - raise End_Error; - - else -- All done - return; - end if; - - elsif ch /= LM then - - -- Buffer really is full without having seen LM, update col - - Last := Last + 1; - Item (Last) := Character'Val (ch); - File.Col := File.Col + Count (Last - Item'First + 1); - return; - end if; - end if; - end if; - - -- We have skipped past, but not stored, a line mark. Skip following - -- page mark if one follows, but do not do this for a non-regular file - -- (since otherwise we get annoying wait for an extra character) - - File.Line := File.Line + 1; - File.Col := 1; - - if File.Before_LM_PM then - File.Line := 1; - File.Before_LM_PM := False; - File.Page := File.Page + 1; - - elsif File.Is_Regular_File then - ch := Getc (File); - - if ch = PM and then File.Is_Regular_File then - File.Line := 1; - File.Page := File.Page + 1; - else - Ungetc (ch, File); - end if; - end if; -end Get_Line; diff --git a/gcc/ada/a-tiinau.adb b/gcc/ada/a-tiinau.adb deleted file mode 100644 index 5d08dc0..0000000 --- a/gcc/ada/a-tiinau.adb +++ /dev/null @@ -1,297 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . I N T E G E R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Int; use System.Img_Int; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLI; use System.Img_LLI; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Int; use System.Val_Int; -with System.Val_LLI; use System.Val_LLI; - -package body Ada.Text_IO.Integer_Aux is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- integer literal value from the input file into Buf, starting at Ptr + 1. - -- On return, Ptr is set to the last character stored. - - ------------- - -- Get_Int -- - ------------- - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Int; - - ------------- - -- Get_LLI -- - ------------- - - procedure Get_LLI - (File : File_Type; - Item : out Long_Long_Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLI; - - -------------- - -- Gets_Int -- - -------------- - - procedure Gets_Int - (From : String; - Item : out Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Int; - - -------------- - -- Gets_LLI -- - -------------- - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLI; - - ------------------ - -- Load_Integer -- - ------------------ - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based literal. We recognize either the standard '#' or - -- the allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Integer; - - ------------- - -- Put_Int -- - ------------- - - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Integer'Max (Field'Last, Width)); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Int; - - ------------- - -- Put_LLI -- - ------------- - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Integer'Max (Field'Last, Width)); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLI; - - -------------- - -- Puts_Int -- - -------------- - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base) - is - Buf : String (1 .. Integer'Max (Field'Last, To'Length)); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Int; - - -------------- - -- Puts_LLI -- - -------------- - - procedure Puts_LLI - (To : out String; - Item : Long_Long_Integer; - Base : Number_Base) - is - Buf : String (1 .. Integer'Max (Field'Last, To'Length)); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLI; - -end Ada.Text_IO.Integer_Aux; diff --git a/gcc/ada/a-tiinau.ads b/gcc/ada/a-tiinau.ads deleted file mode 100644 index ee2ca23..0000000 --- a/gcc/ada/a-tiinau.ads +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . I N T E G E R _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Text_IO.Integer_IO that are --- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Integer_IO itself, --- except that the generic parameter Num has been replaced by Integer or --- Long_Long_Integer, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. - -private package Ada.Text_IO.Integer_Aux is - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field); - - procedure Get_LLI - (File : File_Type; - Item : out Long_Long_Integer; - Width : Field); - - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base); - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base); - - procedure Gets_Int - (From : String; - Item : out Integer; - Last : out Positive); - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive); - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base); - - procedure Puts_LLI - (To : out String; - Item : Long_Long_Integer; - Base : Number_Base); - -end Ada.Text_IO.Integer_Aux; diff --git a/gcc/ada/a-tiinio.adb b/gcc/ada/a-tiinio.adb deleted file mode 100644 index f477dbf..0000000 --- a/gcc/ada/a-tiinio.adb +++ /dev/null @@ -1,154 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . I N T E G E R _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Integer_Aux; - -package body Ada.Text_IO.Integer_IO is - - package Aux renames Ada.Text_IO.Integer_Aux; - - Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; - -- Throughout this generic body, we distinguish between the case where type - -- Integer is acceptable, and where a Long_Long_Integer is needed. This - -- Boolean is used to test for these cases and since it is a constant, only - -- code for the relevant case will be included in the instance. - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - -- We depend on a range check to get Data_Error - - pragma Unsuppress (Range_Check); - pragma Unsuppress (Overflow_Check); - - begin - if Need_LLI then - Aux.Get_LLI (File, Long_Long_Integer (Item), Width); - else - Aux.Get_Int (File, Integer (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - -- We depend on a range check to get Data_Error - - pragma Unsuppress (Range_Check); - pragma Unsuppress (Overflow_Check); - - begin - if Need_LLI then - Aux.Get_LLI (Current_In, Long_Long_Integer (Item), Width); - else - Aux.Get_Int (Current_In, Integer (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (From : String; - Item : out Num; - Last : out Positive) - is - -- We depend on a range check to get Data_Error - - pragma Unsuppress (Range_Check); - pragma Unsuppress (Overflow_Check); - - begin - if Need_LLI then - Aux.Gets_LLI (From, Long_Long_Integer (Item), Last); - else - Aux.Gets_Int (From, Integer (Item), Last); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Need_LLI then - Aux.Put_LLI (File, Long_Long_Integer (Item), Width, Base); - else - Aux.Put_Int (File, Integer (Item), Width, Base); - end if; - end Put; - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Need_LLI then - Aux.Put_LLI (Current_Out, Long_Long_Integer (Item), Width, Base); - else - Aux.Put_Int (Current_Out, Integer (Item), Width, Base); - end if; - end Put; - - procedure Put - (To : out String; - Item : Num; - Base : Number_Base := Default_Base) - is - begin - if Need_LLI then - Aux.Puts_LLI (To, Long_Long_Integer (Item), Base); - else - Aux.Puts_Int (To, Integer (Item), Base); - end if; - end Put; - -end Ada.Text_IO.Integer_IO; diff --git a/gcc/ada/a-tiinio.ads b/gcc/ada/a-tiinio.ads deleted file mode 100644 index 459d6fe..0000000 --- a/gcc/ada/a-tiinio.ads +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . I N T E G E R _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Text_IO.Integer_IO is a subpackage of Text_IO. --- This is for compatibility with Ada 83. In GNAT we make it a child package --- to avoid loading the necessary code if Integer_IO is not instantiated. --- See routine Rtsfind.Check_Text_IO_Special_Unit for a description of how --- we patch up the difference in semantics so that it is invisible to the --- Ada programmer. - -private generic - type Num is range <>; - -package Ada.Text_IO.Integer_IO is - - Default_Width : Field := Num'Width; - Default_Base : Number_Base := 10; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Get - (From : String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out String; - Item : Num; - Base : Number_Base := Default_Base); - -private - pragma Inline (Get); - pragma Inline (Put); - -end Ada.Text_IO.Integer_IO; diff --git a/gcc/ada/a-timoau.adb b/gcc/ada/a-timoau.adb deleted file mode 100644 index 2fceb8a..0000000 --- a/gcc/ada/a-timoau.adb +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . M O D U L A R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Uns; use System.Img_Uns; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLU; use System.Img_LLU; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Uns; use System.Val_Uns; -with System.Val_LLU; use System.Val_LLU; - -package body Ada.Text_IO.Modular_Aux is - - use System.Unsigned_Types; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- modular literal value from the input file into Buf, starting at Ptr + 1. - -- Ptr is left set to the last character stored. - - ------------- - -- Get_LLU -- - ------------- - - procedure Get_LLU - (File : File_Type; - Item : out Long_Long_Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLU; - - ------------- - -- Get_Uns -- - ------------- - - procedure Get_Uns - (File : File_Type; - Item : out Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Uns; - - -------------- - -- Gets_LLU -- - -------------- - - procedure Gets_LLU - (From : String; - Item : out Long_Long_Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLU; - - -------------- - -- Gets_Uns -- - -------------- - - procedure Gets_Uns - (From : String; - Item : out Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Uns; - - ------------------ - -- Load_Modular -- - ------------------ - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - - -- Note: it is a bit strange to allow a minus sign here, but it seems - -- consistent with the general behavior expected by the ACVC tests - -- which is to scan past junk and then signal data error, see ACVC - -- test CE3704F, case (6), which is for signed integer exponents, - -- which seems a similar case. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants - -- for the signed case, and there seems no good reason to treat - -- exponents differently for the signed and unsigned cases. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Modular; - - ------------- - -- Put_LLU -- - ------------- - - procedure Put_LLU - (File : File_Type; - Item : Long_Long_Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLU; - - ------------- - -- Put_Uns -- - ------------- - - procedure Put_Uns - (File : File_Type; - Item : Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Uns; - - -------------- - -- Puts_LLU -- - -------------- - - procedure Puts_LLU - (To : out String; - Item : Long_Long_Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLU; - - -------------- - -- Puts_Uns -- - -------------- - - procedure Puts_Uns - (To : out String; - Item : Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Uns; - -end Ada.Text_IO.Modular_Aux; diff --git a/gcc/ada/a-timoau.ads b/gcc/ada/a-timoau.ads deleted file mode 100644 index 3520b56..0000000 --- a/gcc/ada/a-timoau.ads +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . M O D U L A R _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Text_IO.Modular_IO that are --- shared among separate instantiations of this package. The routines in --- this package are identical semantically to those in Modular_IO itself, --- except that the generic parameter Num has been replaced by Unsigned or --- Long_Long_Unsigned, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. - -with System.Unsigned_Types; - -private package Ada.Text_IO.Modular_Aux is - - package U renames System.Unsigned_Types; - - procedure Get_Uns - (File : File_Type; - Item : out U.Unsigned; - Width : Field); - - procedure Get_LLU - (File : File_Type; - Item : out U.Long_Long_Unsigned; - Width : Field); - - procedure Put_Uns - (File : File_Type; - Item : U.Unsigned; - Width : Field; - Base : Number_Base); - - procedure Put_LLU - (File : File_Type; - Item : U.Long_Long_Unsigned; - Width : Field; - Base : Number_Base); - - procedure Gets_Uns - (From : String; - Item : out U.Unsigned; - Last : out Positive); - - procedure Gets_LLU - (From : String; - Item : out U.Long_Long_Unsigned; - Last : out Positive); - - procedure Puts_Uns - (To : out String; - Item : U.Unsigned; - Base : Number_Base); - - procedure Puts_LLU - (To : out String; - Item : U.Long_Long_Unsigned; - Base : Number_Base); - -end Ada.Text_IO.Modular_Aux; diff --git a/gcc/ada/a-timoio.adb b/gcc/ada/a-timoio.adb deleted file mode 100644 index b000cd5..0000000 --- a/gcc/ada/a-timoio.adb +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . M O D U L A R _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO.Modular_Aux; - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body Ada.Text_IO.Modular_IO is - - package Aux renames Ada.Text_IO.Modular_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - pragma Unsuppress (Range_Check); - - begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (File, Long_Long_Unsigned (Item), Width); - else - Aux.Get_Uns (File, Unsigned (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - pragma Unsuppress (Range_Check); - - begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (Current_In, Long_Long_Unsigned (Item), Width); - else - Aux.Get_Uns (Current_In, Unsigned (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (From : String; - Item : out Num; - Last : out Positive) - is - pragma Unsuppress (Range_Check); - - begin - if Num'Size > Unsigned'Size then - Aux.Gets_LLU (From, Long_Long_Unsigned (Item), Last); - else - Aux.Gets_Uns (From, Unsigned (Item), Last); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (File, Long_Long_Unsigned (Item), Width, Base); - else - Aux.Put_Uns (File, Unsigned (Item), Width, Base); - end if; - end Put; - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (Current_Out, Long_Long_Unsigned (Item), Width, Base); - else - Aux.Put_Uns (Current_Out, Unsigned (Item), Width, Base); - end if; - end Put; - - procedure Put - (To : out String; - Item : Num; - Base : Number_Base := Default_Base) - is - begin - if Num'Size > Unsigned'Size then - Aux.Puts_LLU (To, Long_Long_Unsigned (Item), Base); - else - Aux.Puts_Uns (To, Unsigned (Item), Base); - end if; - end Put; - -end Ada.Text_IO.Modular_IO; diff --git a/gcc/ada/a-timoio.ads b/gcc/ada/a-timoio.ads deleted file mode 100644 index 112adf4..0000000 --- a/gcc/ada/a-timoio.ads +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . M O D U L A R _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1993-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Text_IO.Modular_IO is a subpackage of Text_IO. --- This is for compatibility with Ada 83. In GNAT we make it a child package --- to avoid loading the necessary code if Modular_IO is not instantiated. --- See routine Rtsfind.Check_Text_IO_Special_Unit for a description of how --- we patch up the difference in semantics so that it is invisible to the --- Ada programmer. - -private generic - type Num is mod <>; - -package Ada.Text_IO.Modular_IO is - - Default_Width : Field := Num'Width; - Default_Base : Number_Base := 10; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Get - (From : String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out String; - Item : Num; - Base : Number_Base := Default_Base); - -private - pragma Inline (Get); - pragma Inline (Put); - -end Ada.Text_IO.Modular_IO; diff --git a/gcc/ada/a-tiocst.adb b/gcc/ada/a-tiocst.adb deleted file mode 100644 index 3015f31..0000000 --- a/gcc/ada/a-tiocst.adb +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; -with Ada.Unchecked_Conversion; - -package body Ada.Text_IO.C_Streams is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - - -------------- - -- C_Stream -- - -------------- - - function C_Stream (F : File_Type) return FILEs is - begin - FIO.Check_File_Open (AP (F)); - return F.Stream; - end C_Stream; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : FILEs; - Form : String := ""; - Name : String := "") - is - Dummy_File_Control_Block : Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'T', - Creat => False, - Text => True, - C_Stream => C_Stream); - end Open; - -end Ada.Text_IO.C_Streams; diff --git a/gcc/ada/a-tiocst.ads b/gcc/ada/a-tiocst.ads deleted file mode 100644 index bb6c5b1..0000000 --- a/gcc/ada/a-tiocst.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . C _ S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface between Ada.Text_IO and the --- C streams. This allows sharing of a stream between Ada and C or C++, --- as well as allowing the Ada program to operate directly on the stream. - -with Interfaces.C_Streams; - -package Ada.Text_IO.C_Streams is - - package ICS renames Interfaces.C_Streams; - - function C_Stream (F : File_Type) return ICS.FILEs; - -- Obtain stream from existing open file - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : ICS.FILEs; - Form : String := ""; - Name : String := ""); - -- Create new file from existing stream - -end Ada.Text_IO.C_Streams; diff --git a/gcc/ada/a-tirsfi.adb b/gcc/ada/a-tirsfi.adb deleted file mode 100644 index a61e2b9..0000000 --- a/gcc/ada/a-tirsfi.adb +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --------------------------------------- --- Ada.Text_IO.Reset_Standard_Files -- --------------------------------------- - -procedure Ada.Text_IO.Reset_Standard_Files is -begin - Ada.Text_IO.Initialize_Standard_Files; -end Ada.Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-tirsfi.ads b/gcc/ada/a-tirsfi.ads deleted file mode 100644 index 066df9f..0000000 --- a/gcc/ada/a-tirsfi.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 reset routine that resets the standard files used --- by Text_IO. This is useful in systems such as VxWorks where Ada.Text_IO is --- elaborated at the program start, but a system restart may alter the status --- of these files, resulting in incorrect operation of Text_IO (in particular --- if the standard input file is changed to be interactive, then Get_Line may --- hang looking for an extra character after the end of the line. - -procedure Ada.Text_IO.Reset_Standard_Files; --- Reset standard Text_IO files as described above diff --git a/gcc/ada/a-titest.adb b/gcc/ada/a-titest.adb deleted file mode 100644 index 3b8f9ce..0000000 --- a/gcc/ada/a-titest.adb +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . T E X T _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.File_IO; - -package body Ada.Text_IO.Text_Streams is - - ------------ - -- Stream -- - ------------ - - function Stream (File : File_Type) return Stream_Access is - begin - System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); - return Stream_Access (File); - end Stream; - -end Ada.Text_IO.Text_Streams; diff --git a/gcc/ada/a-titest.ads b/gcc/ada/a-titest.ads deleted file mode 100644 index 93cf47a..0000000 --- a/gcc/ada/a-titest.ads +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . T E X T _ S T R E A M S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Streams; -package Ada.Text_IO.Text_Streams is - - type Stream_Access is access all Streams.Root_Stream_Type'Class; - - function Stream (File : File_Type) return Stream_Access; - -end Ada.Text_IO.Text_Streams; diff --git a/gcc/ada/a-tiunio.ads b/gcc/ada/a-tiunio.ads deleted file mode 100644 index ea5caec..0000000 --- a/gcc/ada/a-tiunio.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . U N B O U N D E D _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Note: historically GNAT provided these subprograms as a child of the --- package Ada.Strings.Unbounded. So we implement this new Ada 2005 package --- by renaming the subprograms in that child. This is a more straightforward --- implementation anyway, since we need access to the internal representation --- of Ada.Strings.Unbounded.Unbounded_String. - -with Ada.Strings.Unbounded; -with Ada.Strings.Unbounded.Text_IO; - -package Ada.Text_IO.Unbounded_IO is - - procedure Put - (File : File_Type; - Item : Strings.Unbounded.Unbounded_String) - renames Ada.Strings.Unbounded.Text_IO.Put; - - procedure Put - (Item : Strings.Unbounded.Unbounded_String) - renames Ada.Strings.Unbounded.Text_IO.Put; - - procedure Put_Line - (File : Text_IO.File_Type; - Item : Strings.Unbounded.Unbounded_String) - renames Ada.Strings.Unbounded.Text_IO.Put_Line; - - procedure Put_Line - (Item : Strings.Unbounded.Unbounded_String) - renames Ada.Strings.Unbounded.Text_IO.Put_Line; - - function Get_Line - (File : File_Type) return Strings.Unbounded.Unbounded_String - renames Ada.Strings.Unbounded.Text_IO.Get_Line; - - function Get_Line return Strings.Unbounded.Unbounded_String - renames Ada.Strings.Unbounded.Text_IO.Get_Line; - - procedure Get_Line - (File : File_Type; - Item : out Strings.Unbounded.Unbounded_String) - renames Ada.Strings.Unbounded.Text_IO.Get_Line; - - procedure Get_Line - (Item : out Strings.Unbounded.Unbounded_String) - renames Ada.Strings.Unbounded.Text_IO.Get_Line; - -end Ada.Text_IO.Unbounded_IO; diff --git a/gcc/ada/a-unccon.ads b/gcc/ada/a-unccon.ads deleted file mode 100644 index a8429c1..0000000 --- a/gcc/ada/a-unccon.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . U N C H E C K E D _ C O N V E R S I O N -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -generic - type Source (<>) is limited private; - type Target (<>) is limited private; - -function Ada.Unchecked_Conversion (S : Source) return Target; - -pragma No_Elaboration_Code_All (Ada.Unchecked_Conversion); -pragma Pure (Ada.Unchecked_Conversion); -pragma Import (Intrinsic, Ada.Unchecked_Conversion); diff --git a/gcc/ada/a-uncdea.ads b/gcc/ada/a-uncdea.ads deleted file mode 100644 index a61cd50..0000000 --- a/gcc/ada/a-uncdea.ads +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . U N C H E C K E D _ D E A L L O C A T I O N -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -generic - type Object (<>) is limited private; - type Name is access Object; - -procedure Ada.Unchecked_Deallocation (X : in out Name); -pragma Preelaborate (Unchecked_Deallocation); - -pragma Import (Intrinsic, Ada.Unchecked_Deallocation); diff --git a/gcc/ada/a-undesu.adb b/gcc/ada/a-undesu.adb deleted file mode 100644 index d2bd292..0000000 --- a/gcc/ada/a-undesu.adb +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Pools.Subpools, - System.Storage_Pools.Subpools.Finalization; - -use System.Storage_Pools.Subpools, - System.Storage_Pools.Subpools.Finalization; - -procedure Ada.Unchecked_Deallocate_Subpool - (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle) -is -begin - Finalize_And_Deallocate (Subpool); -end Ada.Unchecked_Deallocate_Subpool; diff --git a/gcc/ada/a-undesu.ads b/gcc/ada/a-undesu.ads deleted file mode 100644 index 6665725..0000000 --- a/gcc/ada/a-undesu.ads +++ /dev/null @@ -1,19 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Pools.Subpools; - -procedure Ada.Unchecked_Deallocate_Subpool - (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle); diff --git a/gcc/ada/a-wichha.adb b/gcc/ada/a-wichha.adb deleted file mode 100644 index 8d022361..0000000 --- a/gcc/ada/a-wichha.adb +++ /dev/null @@ -1,195 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ C H A R A C T E R S . H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Characters.Unicode; use Ada.Wide_Characters.Unicode; - -package body Ada.Wide_Characters.Handling is - - --------------------------- - -- Character_Set_Version -- - --------------------------- - - function Character_Set_Version return String is - begin - return "Unicode 4.0"; - end Character_Set_Version; - - --------------------- - -- Is_Alphanumeric -- - --------------------- - - function Is_Alphanumeric (Item : Wide_Character) return Boolean is - begin - return Is_Letter (Item) or else Is_Digit (Item); - end Is_Alphanumeric; - - ---------------- - -- Is_Control -- - ---------------- - - function Is_Control (Item : Wide_Character) return Boolean is - begin - return Get_Category (Item) = Cc; - end Is_Control; - - -------------- - -- Is_Digit -- - -------------- - - function Is_Digit (Item : Wide_Character) return Boolean - renames Ada.Wide_Characters.Unicode.Is_Digit; - - ---------------- - -- Is_Graphic -- - ---------------- - - function Is_Graphic (Item : Wide_Character) return Boolean is - begin - return not Is_Non_Graphic (Item); - end Is_Graphic; - - -------------------------- - -- Is_Hexadecimal_Digit -- - -------------------------- - - function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean is - begin - return Is_Digit (Item) - or else Item in 'A' .. 'F' - or else Item in 'a' .. 'f'; - end Is_Hexadecimal_Digit; - - --------------- - -- Is_Letter -- - --------------- - - function Is_Letter (Item : Wide_Character) return Boolean - renames Ada.Wide_Characters.Unicode.Is_Letter; - - ------------------------ - -- Is_Line_Terminator -- - ------------------------ - - function Is_Line_Terminator (Item : Wide_Character) return Boolean - renames Ada.Wide_Characters.Unicode.Is_Line_Terminator; - - -------------- - -- Is_Lower -- - -------------- - - function Is_Lower (Item : Wide_Character) return Boolean is - begin - return Get_Category (Item) = Ll; - end Is_Lower; - - ------------- - -- Is_Mark -- - ------------- - - function Is_Mark (Item : Wide_Character) return Boolean - renames Ada.Wide_Characters.Unicode.Is_Mark; - - --------------------- - -- Is_Other_Format -- - --------------------- - - function Is_Other_Format (Item : Wide_Character) return Boolean - renames Ada.Wide_Characters.Unicode.Is_Other; - - ------------------------------ - -- Is_Punctuation_Connector -- - ------------------------------ - - function Is_Punctuation_Connector (Item : Wide_Character) return Boolean - renames Ada.Wide_Characters.Unicode.Is_Punctuation; - - -------------- - -- Is_Space -- - -------------- - - function Is_Space (Item : Wide_Character) return Boolean - renames Ada.Wide_Characters.Unicode.Is_Space; - - ---------------- - -- Is_Special -- - ---------------- - - function Is_Special (Item : Wide_Character) return Boolean is - begin - return Is_Graphic (Item) and then not Is_Alphanumeric (Item); - end Is_Special; - - -------------- - -- Is_Upper -- - -------------- - - function Is_Upper (Item : Wide_Character) return Boolean is - begin - return Get_Category (Item) = Lu; - end Is_Upper; - - -------------- - -- To_Lower -- - -------------- - - function To_Lower (Item : Wide_Character) return Wide_Character - renames Ada.Wide_Characters.Unicode.To_Lower_Case; - - function To_Lower (Item : Wide_String) return Wide_String is - Result : Wide_String (Item'Range); - - begin - for J in Result'Range loop - Result (J) := To_Lower (Item (J)); - end loop; - - return Result; - end To_Lower; - - -------------- - -- To_Upper -- - -------------- - - function To_Upper (Item : Wide_Character) return Wide_Character - renames Ada.Wide_Characters.Unicode.To_Upper_Case; - - function To_Upper (Item : Wide_String) return Wide_String is - Result : Wide_String (Item'Range); - - begin - for J in Result'Range loop - Result (J) := To_Upper (Item (J)); - end loop; - - return Result; - end To_Upper; - -end Ada.Wide_Characters.Handling; diff --git a/gcc/ada/a-wichha.ads b/gcc/ada/a-wichha.ads deleted file mode 100644 index 583308e..0000000 --- a/gcc/ada/a-wichha.ads +++ /dev/null @@ -1,127 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ C H A R A C T E R S . H A N D L I N G -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Wide_Characters.Handling is - pragma Pure; - - function Character_Set_Version return String; - pragma Inline (Character_Set_Version); - -- Returns an implementation-defined identifier that identifies the version - -- of the character set standard that is used for categorizing characters - -- by the implementation. For GNAT this is "Unicode v.v". - - function Is_Control (Item : Wide_Character) return Boolean; - pragma Inline (Is_Control); - -- Returns True if the Wide_Character designated by Item is categorized as - -- other_control, otherwise returns false. - - function Is_Letter (Item : Wide_Character) return Boolean; - pragma Inline (Is_Letter); - -- Returns True if the Wide_Character designated by Item is categorized as - -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, - -- letter_other, or number_letter. Otherwise returns false. - - function Is_Lower (Item : Wide_Character) return Boolean; - pragma Inline (Is_Lower); - -- Returns True if the Wide_Character designated by Item is categorized as - -- letter_lowercase, otherwise returns false. - - function Is_Upper (Item : Wide_Character) return Boolean; - pragma Inline (Is_Upper); - -- Returns True if the Wide_Character designated by Item is categorized as - -- letter_uppercase, otherwise returns false. - - function Is_Digit (Item : Wide_Character) return Boolean; - pragma Inline (Is_Digit); - -- Returns True if the Wide_Character designated by Item is categorized as - -- number_decimal, otherwise returns false. - - function Is_Decimal_Digit (Item : Wide_Character) return Boolean - renames Is_Digit; - - function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean; - -- Returns True if the Wide_Character designated by Item is categorized as - -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise - -- returns false. - - function Is_Alphanumeric (Item : Wide_Character) return Boolean; - pragma Inline (Is_Alphanumeric); - -- Returns True if the Wide_Character designated by Item is categorized as - -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise - -- returns false. - - function Is_Special (Item : Wide_Character) return Boolean; - pragma Inline (Is_Special); - -- Returns True if the Wide_Character designated by Item is categorized - -- as graphic_character, but not categorized as letter_uppercase, - -- letter_lowercase, letter_titlecase, letter_modifier, letter_other, - -- number_letter, or number_decimal. Otherwise returns false. - - function Is_Line_Terminator (Item : Wide_Character) return Boolean; - pragma Inline (Is_Line_Terminator); - -- Returns True if the Wide_Character designated by Item is categorized as - -- separator_line or separator_paragraph, or if Item is a conventional line - -- terminator character (CR, LF, VT, or FF). Otherwise returns false. - - function Is_Mark (Item : Wide_Character) return Boolean; - pragma Inline (Is_Mark); - -- Returns True if the Wide_Character designated by Item is categorized as - -- mark_non_spacing or mark_spacing_combining, otherwise returns false. - - function Is_Other_Format (Item : Wide_Character) return Boolean; - pragma Inline (Is_Other_Format); - -- Returns True if the Wide_Character designated by Item is categorized as - -- other_format, otherwise returns false. - - function Is_Punctuation_Connector (Item : Wide_Character) return Boolean; - pragma Inline (Is_Punctuation_Connector); - -- Returns True if the Wide_Character designated by Item is categorized as - -- punctuation_connector, otherwise returns false. - - function Is_Space (Item : Wide_Character) return Boolean; - pragma Inline (Is_Space); - -- Returns True if the Wide_Character designated by Item is categorized as - -- separator_space, otherwise returns false. - - function Is_Graphic (Item : Wide_Character) return Boolean; - pragma Inline (Is_Graphic); - -- Returns True if the Wide_Character designated by Item is categorized as - -- graphic_character, otherwise returns false. - - function To_Lower (Item : Wide_Character) return Wide_Character; - pragma Inline (To_Lower); - -- Returns the Simple Lowercase Mapping of the Wide_Character designated by - -- Item. If the Simple Lowercase Mapping does not exist for the - -- Wide_Character designated by Item, then the value of Item is returned. - - function To_Lower (Item : Wide_String) return Wide_String; - -- Returns the result of applying the To_Lower Wide_Character to - -- Wide_Character conversion to each element of the Wide_String designated - -- by Item. The result is the null Wide_String if the value of the formal - -- parameter is the null Wide_String. - - function To_Upper (Item : Wide_Character) return Wide_Character; - pragma Inline (To_Upper); - -- Returns the Simple Uppercase Mapping of the Wide_Character designated by - -- Item. If the Simple Uppercase Mapping does not exist for the - -- Wide_Character designated by Item, then the value of Item is returned. - - function To_Upper (Item : Wide_String) return Wide_String; - -- Returns the result of applying the To_Upper Wide_Character to - -- Wide_Character conversion to each element of the Wide_String designated - -- by Item. The result is the null Wide_String if the value of the formal - -- parameter is the null Wide_String. - -end Ada.Wide_Characters.Handling; diff --git a/gcc/ada/a-wichun.adb b/gcc/ada/a-wichun.adb deleted file mode 100644 index b36d4a4..0000000 --- a/gcc/ada/a-wichun.adb +++ /dev/null @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ C H A R A C T E R T S . U N I C O D E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Wide_Characters.Unicode is - - package G renames System.UTF_32; - - ------------------ - -- Get_Category -- - ------------------ - - function Get_Category (U : Wide_Character) return Category is - begin - return Category (G.Get_Category (Wide_Character'Pos (U))); - end Get_Category; - - -------------- - -- Is_Digit -- - -------------- - - function Is_Digit (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Digit (Wide_Character'Pos (U)); - end Is_Digit; - - function Is_Digit (C : Category) return Boolean is - begin - return G.Is_UTF_32_Digit (G.Category (C)); - end Is_Digit; - - --------------- - -- Is_Letter -- - --------------- - - function Is_Letter (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Letter (Wide_Character'Pos (U)); - end Is_Letter; - - function Is_Letter (C : Category) return Boolean is - begin - return G.Is_UTF_32_Letter (G.Category (C)); - end Is_Letter; - - ------------------------ - -- Is_Line_Terminator -- - ------------------------ - - function Is_Line_Terminator (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Line_Terminator (Wide_Character'Pos (U)); - end Is_Line_Terminator; - - ------------- - -- Is_Mark -- - ------------- - - function Is_Mark (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Mark (Wide_Character'Pos (U)); - end Is_Mark; - - function Is_Mark (C : Category) return Boolean is - begin - return G.Is_UTF_32_Mark (G.Category (C)); - end Is_Mark; - - -------------------- - -- Is_Non_Graphic -- - -------------------- - - function Is_Non_Graphic (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Non_Graphic (Wide_Character'Pos (U)); - end Is_Non_Graphic; - - function Is_Non_Graphic (C : Category) return Boolean is - begin - return G.Is_UTF_32_Non_Graphic (G.Category (C)); - end Is_Non_Graphic; - - -------------- - -- Is_Other -- - -------------- - - function Is_Other (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Other (Wide_Character'Pos (U)); - end Is_Other; - - function Is_Other (C : Category) return Boolean is - begin - return G.Is_UTF_32_Other (G.Category (C)); - end Is_Other; - - -------------------- - -- Is_Punctuation -- - -------------------- - - function Is_Punctuation (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Punctuation (Wide_Character'Pos (U)); - end Is_Punctuation; - - function Is_Punctuation (C : Category) return Boolean is - begin - return G.Is_UTF_32_Punctuation (G.Category (C)); - end Is_Punctuation; - - -------------- - -- Is_Space -- - -------------- - - function Is_Space (U : Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Space (Wide_Character'Pos (U)); - end Is_Space; - - function Is_Space (C : Category) return Boolean is - begin - return G.Is_UTF_32_Space (G.Category (C)); - end Is_Space; - - ------------------- - -- To_Lower_Case -- - ------------------- - - function To_Lower_Case - (U : Wide_Character) return Wide_Character - is - begin - return - Wide_Character'Val - (G.UTF_32_To_Lower_Case (Wide_Character'Pos (U))); - end To_Lower_Case; - - ------------------- - -- To_Upper_Case -- - ------------------- - - function To_Upper_Case - (U : Wide_Character) return Wide_Character - is - begin - return - Wide_Character'Val - (G.UTF_32_To_Upper_Case (Wide_Character'Pos (U))); - end To_Upper_Case; - -end Ada.Wide_Characters.Unicode; diff --git a/gcc/ada/a-wichun.ads b/gcc/ada/a-wichun.ads deleted file mode 100644 index bf7e08f..0000000 --- a/gcc/ada/a-wichun.ads +++ /dev/null @@ -1,197 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ C H A R A C T E R S . U N I C O D E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Unicode categorization routines for Wide_Character. Note that this --- package is strictly speaking Ada 2005 (since it is a child of an --- Ada 2005 unit), but we make it available in Ada 95 mode, since it --- only deals with wide characters. - -with System.UTF_32; - -package Ada.Wide_Characters.Unicode is - pragma Pure; - - -- The following type defines the categories from the unicode definitions. - -- The one addition we make is Fe, which represents the characters FFFE - -- and FFFF in any of the planes. - - type Category is new System.UTF_32.Category; - -- Cc Other, Control - -- Cf Other, Format - -- Cn Other, Not Assigned - -- Co Other, Private Use - -- Cs Other, Surrogate - -- Ll Letter, Lowercase - -- Lm Letter, Modifier - -- Lo Letter, Other - -- Lt Letter, Titlecase - -- Lu Letter, Uppercase - -- Mc Mark, Spacing Combining - -- Me Mark, Enclosing - -- Mn Mark, Nonspacing - -- Nd Number, Decimal Digit - -- Nl Number, Letter - -- No Number, Other - -- Pc Punctuation, Connector - -- Pd Punctuation, Dash - -- Pe Punctuation, Close - -- Pf Punctuation, Final quote - -- Pi Punctuation, Initial quote - -- Po Punctuation, Other - -- Ps Punctuation, Open - -- Sc Symbol, Currency - -- Sk Symbol, Modifier - -- Sm Symbol, Math - -- So Symbol, Other - -- Zl Separator, Line - -- Zp Separator, Paragraph - -- Zs Separator, Space - -- Fe relative position FFFE/FFFF in plane - - function Get_Category (U : Wide_Character) return Category; - pragma Inline (Get_Category); - -- Given a Wide_Character, returns corresponding Category, or Cn if the - -- code does not have an assigned unicode category. - - -- The following functions perform category tests corresponding to lexical - -- classes defined in the Ada standard. There are two interfaces for each - -- function. The second takes a Category (e.g. returned by Get_Category). - -- The first takes a Wide_Character. The form taking the Wide_Character is - -- typically more efficient than calling Get_Category, but if several - -- different tests are to be performed on the same code, it is more - -- efficient to use Get_Category to get the category, then test the - -- resulting category. - - function Is_Letter (U : Wide_Character) return Boolean; - function Is_Letter (C : Category) return Boolean; - pragma Inline (Is_Letter); - -- Returns true iff U is a letter that can be used to start an identifier, - -- or if C is one of the corresponding categories, which are the following: - -- Letter, Uppercase (Lu) - -- Letter, Lowercase (Ll) - -- Letter, Titlecase (Lt) - -- Letter, Modifier (Lm) - -- Letter, Other (Lo) - -- Number, Letter (Nl) - - function Is_Digit (U : Wide_Character) return Boolean; - function Is_Digit (C : Category) return Boolean; - pragma Inline (Is_Digit); - -- Returns true iff U is a digit that can be used to extend an identifer, - -- or if C is one of the corresponding categories, which are the following: - -- Number, Decimal_Digit (Nd) - - function Is_Line_Terminator (U : Wide_Character) return Boolean; - pragma Inline (Is_Line_Terminator); - -- Returns true iff U is an allowed line terminator for source programs, - -- if U is in the category Zp (Separator, Paragaph), or Zs (Separator, - -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). - -- There is no category version for this function, since the set of - -- characters does not correspond to a set of Unicode categories. - - function Is_Mark (U : Wide_Character) return Boolean; - function Is_Mark (C : Category) return Boolean; - pragma Inline (Is_Mark); - -- Returns true iff U is a mark character which can be used to extend an - -- identifier, or if C is one of the corresponding categories, which are - -- the following: - -- Mark, Non-Spacing (Mn) - -- Mark, Spacing Combining (Mc) - - function Is_Other (U : Wide_Character) return Boolean; - function Is_Other (C : Category) return Boolean; - pragma Inline (Is_Other); - -- Returns true iff U is an other format character, which means that it - -- can be used to extend an identifier, but is ignored for the purposes of - -- matching of identiers, or if C is one of the corresponding categories, - -- which are the following: - -- Other, Format (Cf) - - function Is_Punctuation (U : Wide_Character) return Boolean; - function Is_Punctuation (C : Category) return Boolean; - pragma Inline (Is_Punctuation); - -- Returns true iff U is a punctuation character that can be used to - -- separate pices of an identifier, or if C is one of the corresponding - -- categories, which are the following: - -- Punctuation, Connector (Pc) - - function Is_Space (U : Wide_Character) return Boolean; - function Is_Space (C : Category) return Boolean; - pragma Inline (Is_Space); - -- Returns true iff U is considered a space to be ignored, or if C is one - -- of the corresponding categories, which are the following: - -- Separator, Space (Zs) - - function Is_Non_Graphic (U : Wide_Character) return Boolean; - function Is_Non_Graphic (C : Category) return Boolean; - pragma Inline (Is_Non_Graphic); - -- Returns true iff U is considered to be a non-graphic character, or if C - -- is one of the corresponding categories, which are the following: - -- Other, Control (Cc) - -- Other, Private Use (Co) - -- Other, Surrogate (Cs) - -- Separator, Line (Zl) - -- Separator, Paragraph (Zp) - -- FFFE or FFFF positions in any plane (Fe) - -- - -- Note that the Ada category format effector is subsumed by the above - -- list of Unicode categories. - -- - -- Note that Other, Unassiged (Cn) is quite deliberately not included - -- in the list of categories above. This means that should any of these - -- code positions be defined in future with graphic characters they will - -- be allowed without a need to change implementations or the standard. - -- - -- Note that Other, Format (Cf) is also quite deliberately not included - -- in the list of categories above. This means that these characters can - -- be included in character and string literals. - - -- The following function is used to fold to upper case, as required by - -- the Ada 2005 standard rules for identifier case folding. Two - -- identifiers are equivalent if they are identical after folding all - -- letters to upper case using this routine. A corresponding function to - -- fold to lower case is also provided. - - function To_Lower_Case (U : Wide_Character) return Wide_Character; - pragma Inline (To_Lower_Case); - -- If U represents an upper case letter, returns the corresponding lower - -- case letter, otherwise U is returned unchanged. The folding is locale - -- independent as defined by documents referenced in the note in section - -- 1 of ISO/IEC 10646:2003 - - function To_Upper_Case (U : Wide_Character) return Wide_Character; - pragma Inline (To_Upper_Case); - -- If U represents a lower case letter, returns the corresponding upper - -- case letter, otherwise U is returned unchanged. The folding is locale - -- independent as defined by documents referenced in the note in section - -- 1 of ISO/IEC 10646:2003 - -end Ada.Wide_Characters.Unicode; diff --git a/gcc/ada/a-widcha.ads b/gcc/ada/a-widcha.ads deleted file mode 100644 index a5dde73..0000000 --- a/gcc/ada/a-widcha.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ C H A R A C T E R S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Note: strictly this is an Ada 2005 package, but we make it freely --- available in Ada 95 mode, since it deals only with wide characters. - -package Ada.Wide_Characters is - pragma Pure; -end Ada.Wide_Characters; diff --git a/gcc/ada/a-witeio.adb b/gcc/ada/a-witeio.adb deleted file mode 100644 index aadc5ee..0000000 --- a/gcc/ada/a-witeio.adb +++ /dev/null @@ -1,1965 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Streams; use Ada.Streams; -with Interfaces.C_Streams; use Interfaces.C_Streams; - -with System.CRTL; -with System.File_IO; -with System.WCh_Cnv; use System.WCh_Cnv; -with System.WCh_Con; use System.WCh_Con; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -pragma Elaborate_All (System.File_IO); --- Needed because of calls to Chain_File in package body elaboration - -package body Ada.Wide_Text_IO is - - package FIO renames System.File_IO; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); - use type FCB.File_Mode; - - use type System.CRTL.size_t; - - WC_Encoding : Character; - pragma Import (C, WC_Encoding, "__gl_wc_encoding"); - -- Default wide character encoding - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - -- Names of standard files - -- - -- Use "preallocated" strings to avoid calling "new" during the elaboration - -- of the run time. This is needed in the tasking case to avoid calling - -- Task_Lock too early. A filename is expected to end with a null character - -- in the runtime, here the null characters are added just to have a - -- correct filename length. - -- - -- Note: the names for these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC tests insist. - -- We use names that are bound to fail in open etc. - - Null_Str : aliased constant String := ""; - -- Used as form string for standard files - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Get_Wide_Char_Immed - (C : Character; - File : File_Type) return Wide_Character; - -- This routine is identical to Get_Wide_Char, except that the reads are - -- done in Get_Immediate mode (i.e. without waiting for a line return). - - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - - procedure Putc (ch : int; File : File_Type); - -- Outputs the given character to the file, which has already been checked - -- for being in output status. Device_Error is raised if the character - -- cannot be written. - - procedure Set_WCEM (File : in out File_Type); - -- Called by Open and Create to set the wide character encoding method for - -- the file, processing a WCEM form parameter if one is present. File is - -- IN OUT because it may be closed in case of an error. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current line - -- is not terminated, then a line terminator is written using New_Line. - -- Note that there is no Terminate_Page routine, because the page mark at - -- the end of the file is implied if necessary. - - procedure Ungetc (ch : int; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has checked - -- that the file is in read status. Device_Error is raised if the character - -- cannot be pushed back. An attempt to push back and end of file character - -- (EOF) is ignored. - - ------------------- - -- AFCB_Allocate -- - ------------------- - - function AFCB_Allocate - (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr - is - pragma Unreferenced (Control_Block); - begin - return new Wide_Text_AFCB; - end AFCB_Allocate; - - ---------------- - -- AFCB_Close -- - ---------------- - - procedure AFCB_Close (File : not null access Wide_Text_AFCB) is - begin - -- If the file being closed is one of the current files, then close - -- the corresponding current file. It is not clear that this action - -- is required (RM A.10.3(23)) but it seems reasonable, and besides - -- ACVC test CE3208A expects this behavior. - - if File_Type (File) = Current_In then - Current_In := null; - elsif File_Type (File) = Current_Out then - Current_Out := null; - elsif File_Type (File) = Current_Err then - Current_Err := null; - end if; - - Terminate_Line (File_Type (File)); - end AFCB_Close; - - --------------- - -- AFCB_Free -- - --------------- - - procedure AFCB_Free (File : not null access Wide_Text_AFCB) is - type FCB_Ptr is access all Wide_Text_AFCB; - FT : FCB_Ptr := FCB_Ptr (File); - - procedure Free is - new Ada.Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr); - - begin - Free (FT); - end AFCB_Free; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out File_Type) is - begin - FIO.Close (AP (File)'Unrestricted_Access); - end Close; - - --------- - -- Col -- - --------- - - -- Note: we assume that it is impossible in practice for the column - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Col (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Col; - end Col; - - function Col return Positive_Count is - begin - return Col (Current_Out); - end Col; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := "") - is - Dummy_File_Control_Block : Wide_Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'W', - Creat => True, - Text => True); - - File.Self := File; - Set_WCEM (File); - end Create; - - ------------------- - -- Current_Error -- - ------------------- - - function Current_Error return File_Type is - begin - return Current_Err; - end Current_Error; - - function Current_Error return File_Access is - begin - return Current_Err.Self'Access; - end Current_Error; - - ------------------- - -- Current_Input -- - ------------------- - - function Current_Input return File_Type is - begin - return Current_In; - end Current_Input; - - function Current_Input return File_Access is - begin - return Current_In.Self'Access; - end Current_Input; - - -------------------- - -- Current_Output -- - -------------------- - - function Current_Output return File_Type is - begin - return Current_Out; - end Current_Output; - - function Current_Output return File_Access is - begin - return Current_Out.Self'Access; - end Current_Output; - - ------------ - -- Delete -- - ------------ - - procedure Delete (File : in out File_Type) is - begin - FIO.Delete (AP (File)'Unrestricted_Access); - end Delete; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Character then - return False; - - elsif File.Before_LM then - if File.Before_LM_PM then - return Nextc (File) = EOF; - end if; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch /= LM then - Ungetc (ch, File); - return False; - - else -- ch = LM - File.Before_LM := True; - end if; - end if; - - -- Here we are just past the line mark with Before_LM set so that we - -- do not have to try to back up past the LM, thus avoiding the need - -- to back up more than one character. - - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch = PM and then File.Is_Regular_File then - File.Before_LM_PM := True; - return Nextc (File) = EOF; - - -- Here if neither EOF nor PM followed end of line - - else - Ungetc (ch, File); - return False; - end if; - - end End_Of_File; - - function End_Of_File return Boolean is - begin - return End_Of_File (Current_In); - end End_Of_File; - - ----------------- - -- End_Of_Line -- - ----------------- - - function End_Of_Line (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Character then - return False; - - elsif File.Before_LM then - return True; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - else - Ungetc (ch, File); - return (ch = LM); - end if; - end if; - end End_Of_Line; - - function End_Of_Line return Boolean is - begin - return End_Of_Line (Current_In); - end End_Of_Line; - - ----------------- - -- End_Of_Page -- - ----------------- - - function End_Of_Page (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if not File.Is_Regular_File then - return False; - - elsif File.Before_Wide_Character then - return False; - - elsif File.Before_LM then - if File.Before_LM_PM then - return True; - end if; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch /= LM then - Ungetc (ch, File); - return False; - - else -- ch = LM - File.Before_LM := True; - end if; - end if; - - -- Here we are just past the line mark with Before_LM set so that we - -- do not have to try to back up past the LM, thus avoiding the need - -- to back up more than one character. - - ch := Nextc (File); - - return ch = PM or else ch = EOF; - end End_Of_Page; - - function End_Of_Page return Boolean is - begin - return End_Of_Page (Current_In); - end End_Of_Page; - - ----------- - -- Flush -- - ----------- - - procedure Flush (File : File_Type) is - begin - FIO.Flush (AP (File)); - end Flush; - - procedure Flush is - begin - Flush (Current_Out); - end Flush; - - ---------- - -- Form -- - ---------- - - function Form (File : File_Type) return String is - begin - return FIO.Form (AP (File)); - end Form; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Wide_Character) - is - C : Character; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Character then - File.Before_Wide_Character := False; - Item := File.Saved_Wide_Character; - - -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same??? - - else - Get_Character (File, C); - Item := Get_Wide_Char (C, File); - end if; - end Get; - - procedure Get (Item : out Wide_Character) is - begin - Get (Current_In, Item); - end Get; - - procedure Get - (File : File_Type; - Item : out Wide_String) - is - begin - for J in Item'Range loop - Get (File, Item (J)); - end loop; - end Get; - - procedure Get (Item : out Wide_String) is - begin - Get (Current_In, Item); - end Get; - - ------------------- - -- Get_Character -- - ------------------- - - procedure Get_Character - (File : File_Type; - Item : out Character) - is - ch : int; - - begin - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - File.Col := 1; - - if File.Before_LM_PM then - File.Line := 1; - File.Page := File.Page + 1; - File.Before_LM_PM := False; - - else - File.Line := File.Line + 1; - end if; - end if; - - loop - ch := Getc (File); - - if ch = EOF then - raise End_Error; - - elsif ch = LM then - File.Line := File.Line + 1; - File.Col := 1; - - elsif ch = PM and then File.Is_Regular_File then - File.Page := File.Page + 1; - File.Line := 1; - - else - Item := Character'Val (ch); - File.Col := File.Col + 1; - return; - end if; - end loop; - end Get_Character; - - ------------------- - -- Get_Immediate -- - ------------------- - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Character) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Character then - File.Before_Wide_Character := False; - Item := File.Saved_Wide_Character; - - elsif File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - Item := Wide_Character'Val (LM); - - else - ch := Getc_Immed (File); - - if ch = EOF then - raise End_Error; - else - Item := Get_Wide_Char_Immed (Character'Val (ch), File); - end if; - end if; - end Get_Immediate; - - procedure Get_Immediate - (Item : out Wide_Character) - is - begin - Get_Immediate (Current_In, Item); - end Get_Immediate; - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Character; - Available : out Boolean) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - Available := True; - - if File.Before_Wide_Character then - File.Before_Wide_Character := False; - Item := File.Saved_Wide_Character; - - elsif File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - Item := Wide_Character'Val (LM); - - else - -- Shouldn't we use getc_immediate_nowait here, like Text_IO??? - - ch := Getc_Immed (File); - - if ch = EOF then - raise End_Error; - else - Item := Get_Wide_Char_Immed (Character'Val (ch), File); - end if; - end if; - end Get_Immediate; - - procedure Get_Immediate - (Item : out Wide_Character; - Available : out Boolean) - is - begin - Get_Immediate (Current_In, Item, Available); - end Get_Immediate; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (File : File_Type; - Item : out Wide_String; - Last : out Natural) - is - begin - FIO.Check_Read_Status (AP (File)); - Last := Item'First - 1; - - -- Immediate exit for null string, this is a case in which we do not - -- need to test for end of file and we do not skip a line mark under - -- any circumstances. - - if Last >= Item'Last then - return; - end if; - - -- Here we have at least one character, if we are immediately before - -- a line mark, then we will just skip past it storing no characters. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - - -- Otherwise we need to read some characters - - else - -- If we are at the end of file now, it means we are trying to - -- skip a file terminator and we raise End_Error (RM A.10.7(20)) - - if Nextc (File) = EOF then - raise End_Error; - end if; - - -- Loop through characters in string - - loop - -- Exit the loop if read is terminated by encountering line mark - -- Note that the use of Skip_Line here ensures we properly deal - -- with setting the page and line numbers. - - if End_Of_Line (File) then - Skip_Line (File); - return; - end if; - - -- Otherwise store the character, note that we know that ch is - -- something other than LM or EOF. It could possibly be a page - -- mark if there is a stray page mark in the middle of a line, but - -- this is not an official page mark in any case, since official - -- page marks can only follow a line mark. The whole page business - -- is pretty much nonsense anyway, so we do not want to waste - -- time trying to make sense out of non-standard page marks in - -- the file. This means that the behavior of Get_Line is different - -- from repeated Get of a character, but that's too bad. We - -- only promise that page numbers etc make sense if the file - -- is formatted in a standard manner. - - -- Note: we do not adjust the column number because it is quicker - -- to adjust it once at the end of the operation than incrementing - -- it each time around the loop. - - Last := Last + 1; - Get (File, Item (Last)); - - -- All done if the string is full, this is the case in which - -- we do not skip the following line mark. We need to adjust - -- the column number in this case. - - if Last = Item'Last then - File.Col := File.Col + Count (Item'Length); - return; - end if; - - -- Exit from the loop if we are at the end of file. This happens - -- if we have a last line that is not terminated with a line mark. - -- In this case we consider that there is an implied line mark; - -- this is a non-standard file, but we will treat it nicely. - - exit when Nextc (File) = EOF; - end loop; - end if; - end Get_Line; - - procedure Get_Line - (Item : out Wide_String; - Last : out Natural) - is - begin - Get_Line (Current_In, Item, Last); - end Get_Line; - - function Get_Line (File : File_Type) return Wide_String is - Buffer : Wide_String (1 .. 500); - Last : Natural; - - function Get_Rest (S : Wide_String) return Wide_String; - -- This is a recursive function that reads the rest of the line and - -- returns it. S is the part read so far. - - -------------- - -- Get_Rest -- - -------------- - - function Get_Rest (S : Wide_String) return Wide_String is - - -- Each time we allocate a buffer the same size as what we have - -- read so far. This limits us to a logarithmic number of calls - -- to Get_Rest and also ensures only a linear use of stack space. - - Buffer : Wide_String (1 .. S'Length); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - - declare - R : constant Wide_String := S & Buffer (1 .. Last); - begin - if Last < Buffer'Last then - return R; - else - return Get_Rest (R); - end if; - end; - end Get_Rest; - - -- Start of processing for Get_Line - - begin - Get_Line (File, Buffer, Last); - - if Last < Buffer'Last then - return Buffer (1 .. Last); - else - return Get_Rest (Buffer (1 .. Last)); - end if; - end Get_Line; - - function Get_Line return Wide_String is - begin - return Get_Line (Current_In); - end Get_Line; - - ------------------- - -- Get_Wide_Char -- - ------------------- - - function Get_Wide_Char - (C : Character; - File : File_Type) return Wide_Character - is - function In_Char return Character; - -- Function used to obtain additional characters it the wide character - -- sequence is more than one character long. - - function WC_In is new Char_Sequence_To_Wide_Char (In_Char); - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - ch : constant Integer := Getc (File); - begin - if ch = EOF then - raise End_Error; - else - return Character'Val (ch); - end if; - end In_Char; - - -- Start of processing for Get_Wide_Char - - begin - FIO.Check_Read_Status (AP (File)); - return WC_In (C, File.WC_Method); - end Get_Wide_Char; - - ------------------------- - -- Get_Wide_Char_Immed -- - ------------------------- - - function Get_Wide_Char_Immed - (C : Character; - File : File_Type) return Wide_Character - is - function In_Char return Character; - -- Function used to obtain additional characters it the wide character - -- sequence is more than one character long. - - function WC_In is new Char_Sequence_To_Wide_Char (In_Char); - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - ch : constant Integer := Getc_Immed (File); - begin - if ch = EOF then - raise End_Error; - else - return Character'Val (ch); - end if; - end In_Char; - - -- Start of processing for Get_Wide_Char_Immed - - begin - FIO.Check_Read_Status (AP (File)); - return WC_In (C, File.WC_Method); - end Get_Wide_Char_Immed; - - ---------- - -- Getc -- - ---------- - - function Getc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF and then ferror (File.Stream) /= 0 then - raise Device_Error; - else - return ch; - end if; - end Getc; - - ---------------- - -- Getc_Immed -- - ---------------- - - function Getc_Immed (File : File_Type) return int is - ch : int; - end_of_file : int; - - procedure getc_immediate - (stream : FILEs; ch : out int; end_of_file : out int); - pragma Import (C, getc_immediate, "getc_immediate"); - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - ch := LM; - - else - getc_immediate (File.Stream, ch, end_of_file); - - if ferror (File.Stream) /= 0 then - raise Device_Error; - elsif end_of_file /= 0 then - return EOF; - end if; - end if; - - return ch; - end Getc_Immed; - - ------------------------------- - -- Initialize_Standard_Files -- - ------------------------------- - - procedure Initialize_Standard_Files is - begin - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Text_Encoding := Default_Text; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Text_Encoding := Default_Text; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Text_Encoding := Default_Text; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; - - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Initialize_Standard_Files; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (File : File_Type) return Boolean is - begin - return FIO.Is_Open (AP (File)); - end Is_Open; - - ---------- - -- Line -- - ---------- - - -- Note: we assume that it is impossible in practice for the line to exceed - -- the value of Count'Last, i.e. no check is required for overflow raising - -- layout error. - - function Line (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Line; - end Line; - - function Line return Positive_Count is - begin - return Line (Current_Out); - end Line; - - ----------------- - -- Line_Length -- - ----------------- - - function Line_Length (File : File_Type) return Count is - begin - FIO.Check_Write_Status (AP (File)); - return File.Line_Length; - end Line_Length; - - function Line_Length return Count is - begin - return Line_Length (Current_Out); - end Line_Length; - - ---------------- - -- Look_Ahead -- - ---------------- - - procedure Look_Ahead - (File : File_Type; - Item : out Wide_Character; - End_Of_Line : out Boolean) - is - ch : int; - - -- Start of processing for Look_Ahead - - begin - FIO.Check_Read_Status (AP (File)); - - -- If we are logically before a line mark, we can return immediately - - if File.Before_LM then - End_Of_Line := True; - Item := Wide_Character'Val (0); - - -- If we are before a wide character, just return it (this can happen - -- if there are two calls to Look_Ahead in a row). - - elsif File.Before_Wide_Character then - End_Of_Line := False; - Item := File.Saved_Wide_Character; - - -- otherwise we must read a character from the input stream - - else - ch := Getc (File); - - if ch = LM - or else ch = EOF - or else (ch = EOF and then File.Is_Regular_File) - then - End_Of_Line := True; - Ungetc (ch, File); - Item := Wide_Character'Val (0); - - -- Case where character obtained does not represent the start of an - -- encoded sequence so it stands for itself and we can unget it with - -- no difficulty. - - elsif not Is_Start_Of_Encoding - (Character'Val (ch), File.WC_Method) - then - End_Of_Line := False; - Ungetc (ch, File); - Item := Wide_Character'Val (ch); - - -- For the start of an encoding, we read the character using the - -- Get_Wide_Char routine. It will occupy more than one byte so we - -- can't put it back with ungetc. Instead we save it in the control - -- block, setting a flag that everyone interested in reading - -- characters must test before reading the stream. - - else - Item := Get_Wide_Char (Character'Val (ch), File); - End_Of_Line := False; - File.Saved_Wide_Character := Item; - File.Before_Wide_Character := True; - end if; - end if; - end Look_Ahead; - - procedure Look_Ahead - (Item : out Wide_Character; - End_Of_Line : out Boolean) - is - begin - Look_Ahead (Current_In, Item, End_Of_Line); - end Look_Ahead; - - ---------- - -- Mode -- - ---------- - - function Mode (File : File_Type) return File_Mode is - begin - return To_TIO (FIO.Mode (AP (File))); - end Mode; - - ---------- - -- Name -- - ---------- - - function Name (File : File_Type) return String is - begin - return FIO.Name (AP (File)); - end Name; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line - (File : File_Type; - Spacing : Positive_Count := 1) - is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not Spacing'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - - for K in 1 .. Spacing loop - - -- We use Put here (rather than Putc) so that we get the proper - -- behavior on windows for output of Wide_String to the console. - - Put (File, Wide_Character'Val (LM)); - - File.Line := File.Line + 1; - - if File.Page_Length /= 0 and then File.Line > File.Page_Length then - - -- Same situation as above, use Put instead of Putc - - Put (File, Wide_Character'Val (PM)); - - File.Line := 1; - File.Page := File.Page + 1; - end if; - end loop; - - File.Col := 1; - end New_Line; - - procedure New_Line (Spacing : Positive_Count := 1) is - begin - New_Line (Current_Out, Spacing); - end New_Line; - - -------------- - -- New_Page -- - -------------- - - procedure New_Page (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - - if File.Col /= 1 or else File.Line = 1 then - Putc (LM, File); - end if; - - Putc (PM, File); - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - end New_Page; - - procedure New_Page is - begin - New_Page (Current_Out); - end New_Page; - - ----------- - -- Nextc -- - ----------- - - function Nextc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF then - if ferror (File.Stream) /= 0 then - raise Device_Error; - end if; - - else - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - - return ch; - end Nextc; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := "") - is - Dummy_File_Control_Block : Wide_Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'W', - Creat => False, - Text => True); - - File.Self := File; - Set_WCEM (File); - end Open; - - ---------- - -- Page -- - ---------- - - -- Note: we assume that it is impossible in practice for the page - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Page (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Page; - end Page; - - function Page return Positive_Count is - begin - return Page (Current_Out); - end Page; - - ----------------- - -- Page_Length -- - ----------------- - - function Page_Length (File : File_Type) return Count is - begin - FIO.Check_Write_Status (AP (File)); - return File.Page_Length; - end Page_Length; - - function Page_Length return Count is - begin - return Page_Length (Current_Out); - end Page_Length; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_Character) - is - wide_text_translation_required : Integer; - pragma Import - (C, wide_text_translation_required, - "__gnat_wide_text_translation_required"); - -- Text translation is required on Windows only. This means that the - -- console is doing translation and we do not want to do any encoding - -- here. If this variable is not 0 we output the character via fputwc. - - procedure Out_Char (C : Character); - -- Procedure to output one character of a wide character sequence - - procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); - - -------------- - -- Out_Char -- - -------------- - - procedure Out_Char (C : Character) is - begin - Putc (Character'Pos (C), File); - end Out_Char; - - Discard : int; - - -- Start of processing for Put - - begin - FIO.Check_Write_Status (AP (File)); - - if wide_text_translation_required /= 0 - or else File.Text_Encoding in Non_Default_Text_Content_Encoding - then - set_mode (fileno (File.Stream), File.Text_Encoding); - Discard := fputwc (Wide_Character'Pos (Item), File.Stream); - else - WC_Out (Item, File.WC_Method); - end if; - - File.Col := File.Col + 1; - end Put; - - procedure Put (Item : Wide_Character) is - begin - Put (Current_Out, Item); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_String) - is - begin - for J in Item'Range loop - Put (File, Item (J)); - end loop; - end Put; - - procedure Put (Item : Wide_String) is - begin - Put (Current_Out, Item); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (File : File_Type; - Item : Wide_String) - is - begin - Put (File, Item); - New_Line (File); - end Put_Line; - - procedure Put_Line (Item : Wide_String) is - begin - Put (Current_Out, Item); - New_Line (Current_Out); - end Put_Line; - - ---------- - -- Putc -- - ---------- - - procedure Putc (ch : int; File : File_Type) is - begin - if fputc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end Putc; - - ---------- - -- Read -- - ---------- - - -- This is the primitive Stream Read routine, used when a Text_IO file - -- is treated directly as a stream using Text_IO.Streams.Stream. - - procedure Read - (File : in out Wide_Text_AFCB; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Discard_ch : int; - pragma Unreferenced (Discard_ch); - - begin - -- Need to deal with Before_Wide_Character ??? - - if File.Mode /= FCB.In_File then - raise Mode_Error; - end if; - - -- Deal with case where our logical and physical position do not match - -- because of being after an LM or LM-PM sequence when in fact we are - -- logically positioned before it. - - if File.Before_LM then - - -- If we are before a PM, then it is possible for a stream read - -- to leave us after the LM and before the PM, which is a bit - -- odd. The easiest way to deal with this is to unget the PM, - -- so we are indeed positioned between the characters. This way - -- further stream read operations will work correctly, and the - -- effect on text processing is a little weird, but what can - -- be expected if stream and text input are mixed this way? - - if File.Before_LM_PM then - Discard_ch := ungetc (PM, File.Stream); - File.Before_LM_PM := False; - end if; - - File.Before_LM := False; - - Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); - - if Item'Length = 1 then - Last := Item'Last; - - else - Last := - Item'First + - Stream_Element_Offset - (fread (buffer => Item'Address, - index => size_t (Item'First + 1), - size => 1, - count => Item'Length - 1, - stream => File.Stream)); - end if; - - return; - end if; - - -- Now we do the read. Since this is a text file, it is normally in - -- text mode, but stream data must be read in binary mode, so we - -- temporarily set binary mode for the read, resetting it after. - -- These calls have no effect in a system (like Unix) where there is - -- no distinction between text and binary files. - - set_binary_mode (fileno (File.Stream)); - - Last := - Item'First + - Stream_Element_Offset - (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; - - if Last < Item'Last then - if ferror (File.Stream) /= 0 then - raise Device_Error; - end if; - end if; - - set_text_mode (fileno (File.Stream)); - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset - (File : in out File_Type; - Mode : File_Mode) - is - begin - -- Don't allow change of mode for current file (RM A.10.2(5)) - - if (File = Current_In or else - File = Current_Out or else - File = Current_Error) - and then To_FCB (Mode) /= File.Mode - then - raise Mode_Error; - end if; - - Terminate_Line (File); - FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); - File.Page := 1; - File.Line := 1; - File.Col := 1; - File.Line_Length := 0; - File.Page_Length := 0; - File.Before_LM := False; - File.Before_LM_PM := False; - end Reset; - - procedure Reset (File : in out File_Type) is - begin - Terminate_Line (File); - FIO.Reset (AP (File)'Unrestricted_Access); - File.Page := 1; - File.Line := 1; - File.Col := 1; - File.Line_Length := 0; - File.Page_Length := 0; - File.Before_LM := False; - File.Before_LM_PM := False; - end Reset; - - ------------- - -- Set_Col -- - ------------- - - procedure Set_Col - (File : File_Type; - To : Positive_Count) - is - ch : int; - - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_File_Open (AP (File)); - - if To = File.Col then - return; - end if; - - if Mode (File) >= Out_File then - if File.Line_Length /= 0 and then To > File.Line_Length then - raise Layout_Error; - end if; - - if To < File.Col then - New_Line (File); - end if; - - while File.Col < To loop - Put (File, ' '); - end loop; - - else - loop - ch := Getc (File); - - if ch = EOF then - raise End_Error; - - elsif ch = LM then - File.Line := File.Line + 1; - File.Col := 1; - - elsif ch = PM and then File.Is_Regular_File then - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - - elsif To = File.Col then - Ungetc (ch, File); - return; - - else - File.Col := File.Col + 1; - end if; - end loop; - end if; - end Set_Col; - - procedure Set_Col (To : Positive_Count) is - begin - Set_Col (Current_Out, To); - end Set_Col; - - --------------- - -- Set_Error -- - --------------- - - procedure Set_Error (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - Current_Err := File; - end Set_Error; - - --------------- - -- Set_Input -- - --------------- - - procedure Set_Input (File : File_Type) is - begin - FIO.Check_Read_Status (AP (File)); - Current_In := File; - end Set_Input; - - -------------- - -- Set_Line -- - -------------- - - procedure Set_Line - (File : File_Type; - To : Positive_Count) - is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_File_Open (AP (File)); - - if To = File.Line then - return; - end if; - - if Mode (File) >= Out_File then - if File.Page_Length /= 0 and then To > File.Page_Length then - raise Layout_Error; - end if; - - if To < File.Line then - New_Page (File); - end if; - - while File.Line < To loop - New_Line (File); - end loop; - - else - while To /= File.Line loop - Skip_Line (File); - end loop; - end if; - end Set_Line; - - procedure Set_Line (To : Positive_Count) is - begin - Set_Line (Current_Out, To); - end Set_Line; - - --------------------- - -- Set_Line_Length -- - --------------------- - - procedure Set_Line_Length (File : File_Type; To : Count) is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - File.Line_Length := To; - end Set_Line_Length; - - procedure Set_Line_Length (To : Count) is - begin - Set_Line_Length (Current_Out, To); - end Set_Line_Length; - - ---------------- - -- Set_Output -- - ---------------- - - procedure Set_Output (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - Current_Out := File; - end Set_Output; - - --------------------- - -- Set_Page_Length -- - --------------------- - - procedure Set_Page_Length (File : File_Type; To : Count) is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - File.Page_Length := To; - end Set_Page_Length; - - procedure Set_Page_Length (To : Count) is - begin - Set_Page_Length (Current_Out, To); - end Set_Page_Length; - - -------------- - -- Set_WCEM -- - -------------- - - procedure Set_WCEM (File : in out File_Type) is - Start : Natural; - Stop : Natural; - - begin - FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); - - if Start = 0 then - File.WC_Method := Default_WCEM; - - else - if Stop = Start then - for J in WC_Encoding_Letters'Range loop - if File.Form (Start) = WC_Encoding_Letters (J) then - File.WC_Method := J; - return; - end if; - end loop; - end if; - - Close (File); - raise Use_Error with "invalid WCEM form parameter"; - end if; - end Set_WCEM; - - --------------- - -- Skip_Line -- - --------------- - - procedure Skip_Line - (File : File_Type; - Spacing : Positive_Count := 1) - is - ch : int; - - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not Spacing'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Read_Status (AP (File)); - - for L in 1 .. Spacing loop - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - - else - ch := Getc (File); - - -- If at end of file now, then immediately raise End_Error. Note - -- that we can never be positioned between a line mark and a page - -- mark, so if we are at the end of file, we cannot logically be - -- before the implicit page mark that is at the end of the file. - - -- For the same reason, we do not need an explicit check for a - -- page mark. If there is a FF in the middle of a line, the file - -- is not in canonical format and we do not care about the page - -- numbers for files other than ones in canonical format. - - if ch = EOF then - raise End_Error; - end if; - - -- If not at end of file, then loop till we get to an LM or EOF. - -- The latter case happens only in non-canonical files where the - -- last line is not terminated by LM, but we don't want to blow - -- up for such files, so we assume an implicit LM in this case. - - loop - exit when ch = LM or else ch = EOF; - ch := Getc (File); - end loop; - end if; - - -- We have got past a line mark, now, for a regular file only, - -- see if a page mark immediately follows this line mark and - -- if so, skip past the page mark as well. We do not do this - -- for non-regular files, since it would cause an undesirable - -- wait for an additional character. - - File.Col := 1; - File.Line := File.Line + 1; - - if File.Before_LM_PM then - File.Page := File.Page + 1; - File.Line := 1; - File.Before_LM_PM := False; - - elsif File.Is_Regular_File then - ch := Getc (File); - - -- Page mark can be explicit, or implied at the end of the file - - if (ch = PM or else ch = EOF) - and then File.Is_Regular_File - then - File.Page := File.Page + 1; - File.Line := 1; - else - Ungetc (ch, File); - end if; - end if; - end loop; - - File.Before_Wide_Character := False; - end Skip_Line; - - procedure Skip_Line (Spacing : Positive_Count := 1) is - begin - Skip_Line (Current_In, Spacing); - end Skip_Line; - - --------------- - -- Skip_Page -- - --------------- - - procedure Skip_Page (File : File_Type) is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - -- If at page mark already, just skip it - - if File.Before_LM_PM then - File.Before_LM := False; - File.Before_LM_PM := False; - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - return; - end if; - - -- This is a bit tricky, if we are logically before an LM then - -- it is not an error if we are at an end of file now, since we - -- are not really at it. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - ch := Getc (File); - - -- Otherwise we do raise End_Error if we are at the end of file now - - else - ch := Getc (File); - - if ch = EOF then - raise End_Error; - end if; - end if; - - -- Now we can just rumble along to the next page mark, or to the - -- end of file, if that comes first. The latter case happens when - -- the page mark is implied at the end of file. - - loop - exit when ch = EOF - or else (ch = PM and then File.Is_Regular_File); - ch := Getc (File); - end loop; - - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - File.Before_Wide_Character := False; - end Skip_Page; - - procedure Skip_Page is - begin - Skip_Page (Current_In); - end Skip_Page; - - -------------------- - -- Standard_Error -- - -------------------- - - function Standard_Error return File_Type is - begin - return Standard_Err; - end Standard_Error; - - function Standard_Error return File_Access is - begin - return Standard_Err'Access; - end Standard_Error; - - -------------------- - -- Standard_Input -- - -------------------- - - function Standard_Input return File_Type is - begin - return Standard_In; - end Standard_Input; - - function Standard_Input return File_Access is - begin - return Standard_In'Access; - end Standard_Input; - - --------------------- - -- Standard_Output -- - --------------------- - - function Standard_Output return File_Type is - begin - return Standard_Out; - end Standard_Output; - - function Standard_Output return File_Access is - begin - return Standard_Out'Access; - end Standard_Output; - - -------------------- - -- Terminate_Line -- - -------------------- - - procedure Terminate_Line (File : File_Type) is - begin - FIO.Check_File_Open (AP (File)); - - -- For file other than In_File, test for needing to terminate last line - - if Mode (File) /= In_File then - - -- If not at start of line definition need new line - - if File.Col /= 1 then - New_Line (File); - - -- For files other than standard error and standard output, we - -- make sure that an empty file has a single line feed, so that - -- it is properly formatted. We avoid this for the standard files - -- because it is too much of a nuisance to have these odd line - -- feeds when nothing has been written to the file. - - elsif (File /= Standard_Err and then File /= Standard_Out) - and then (File.Line = 1 and then File.Page = 1) - then - New_Line (File); - end if; - end if; - end Terminate_Line; - - ------------ - -- Ungetc -- - ------------ - - procedure Ungetc (ch : int; File : File_Type) is - begin - if ch /= EOF then - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - end Ungetc; - - ----------- - -- Write -- - ----------- - - -- This is the primitive Stream Write routine, used when a Text_IO file - -- is treated directly as a stream using Text_IO.Streams.Stream. - - procedure Write - (File : in out Wide_Text_AFCB; - Item : Stream_Element_Array) - is - pragma Warnings (Off, File); - -- Because in this implementation we don't need IN OUT, we only read - - Siz : constant size_t := Item'Length; - - begin - if File.Mode = FCB.In_File then - raise Mode_Error; - end if; - - -- Now we do the write. Since this is a text file, it is normally in - -- text mode, but stream data must be written in binary mode, so we - -- temporarily set binary mode for the write, resetting it after. - -- These calls have no effect in a system (like Unix) where there is - -- no distinction between text and binary files. - - set_binary_mode (fileno (File.Stream)); - - if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then - raise Device_Error; - end if; - - set_text_mode (fileno (File.Stream)); - end Write; - -begin - -- Initialize Standard Files - - for J in WC_Encoding_Method loop - if WC_Encoding = WC_Encoding_Letters (J) then - Default_WCEM := J; - end if; - end loop; - - Initialize_Standard_Files; - - FIO.Chain_File (AP (Standard_In)); - FIO.Chain_File (AP (Standard_Out)); - FIO.Chain_File (AP (Standard_Err)); - -end Ada.Wide_Text_IO; diff --git a/gcc/ada/a-witeio.ads b/gcc/ada/a-witeio.ads deleted file mode 100644 index 70375f2..0000000 --- a/gcc/ada/a-witeio.ads +++ /dev/null @@ -1,495 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: the generic subpackages of Wide_Text_IO (Integer_IO, Float_IO, --- Fixed_IO, Modular_IO, Decimal_IO and Enumeration_IO) appear as private --- children in GNAT. These children are with'ed automatically if they are --- referenced, so this rearrangement is invisible to user programs, but has --- the advantage that only the needed parts of Wide_Text_IO are processed --- and loaded. - -with Ada.IO_Exceptions; -with Ada.Streams; - -with Interfaces.C_Streams; - -with System; -with System.File_Control_Block; -with System.WCh_Con; - -package Ada.Wide_Text_IO is - - type File_Type is limited private; - type File_Mode is (In_File, Out_File, Append_File); - - -- The following representation clause allows the use of unchecked - -- conversion for rapid translation between the File_Mode type - -- used in this package and System.File_IO. - - for File_Mode use - (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) - Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) - Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) - - type Count is range 0 .. Natural'Last; - -- The value of Count'Last must be large enough so that the assumption that - -- the Line, Column and Page counts can never exceed this value is valid. - - subtype Positive_Count is Count range 1 .. Count'Last; - - Unbounded : constant Count := 0; - -- Line and page length - - subtype Field is Integer range 0 .. 255; - -- Note: if for any reason, there is a need to increase this value, then it - -- will be necessary to change the corresponding value in System.Img_Real - -- in file s-imgrea.adb. - - subtype Number_Base is Integer range 2 .. 16; - - type Type_Set is (Lower_Case, Upper_Case); - - --------------------- - -- File Management -- - --------------------- - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := ""); - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - procedure Reset (File : in out File_Type; Mode : File_Mode); - procedure Reset (File : in out File_Type); - - function Mode (File : File_Type) return File_Mode; - function Name (File : File_Type) return String; - function Form (File : File_Type) return String; - - function Is_Open (File : File_Type) return Boolean; - - ------------------------------------------------------ - -- Control of default input, output and error files -- - ------------------------------------------------------ - - procedure Set_Input (File : File_Type); - procedure Set_Output (File : File_Type); - procedure Set_Error (File : File_Type); - - function Standard_Input return File_Type; - function Standard_Output return File_Type; - function Standard_Error return File_Type; - - function Current_Input return File_Type; - function Current_Output return File_Type; - function Current_Error return File_Type; - - type File_Access is access constant File_Type; - - function Standard_Input return File_Access; - function Standard_Output return File_Access; - function Standard_Error return File_Access; - - function Current_Input return File_Access; - function Current_Output return File_Access; - function Current_Error return File_Access; - - -------------------- - -- Buffer control -- - -------------------- - - -- Note: The parameter file is in out in the RM, but as pointed out - -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. - - procedure Flush (File : File_Type); - procedure Flush; - - -------------------------------------------- - -- Specification of line and page lengths -- - -------------------------------------------- - - procedure Set_Line_Length (File : File_Type; To : Count); - procedure Set_Line_Length (To : Count); - - procedure Set_Page_Length (File : File_Type; To : Count); - procedure Set_Page_Length (To : Count); - - function Line_Length (File : File_Type) return Count; - function Line_Length return Count; - - function Page_Length (File : File_Type) return Count; - function Page_Length return Count; - - ------------------------------------ - -- Column, Line, and Page Control -- - ------------------------------------ - - procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure New_Line (Spacing : Positive_Count := 1); - - procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure Skip_Line (Spacing : Positive_Count := 1); - - function End_Of_Line (File : File_Type) return Boolean; - function End_Of_Line return Boolean; - - procedure New_Page (File : File_Type); - procedure New_Page; - - procedure Skip_Page (File : File_Type); - procedure Skip_Page; - - function End_Of_Page (File : File_Type) return Boolean; - function End_Of_Page return Boolean; - - function End_Of_File (File : File_Type) return Boolean; - function End_Of_File return Boolean; - - procedure Set_Col (File : File_Type; To : Positive_Count); - procedure Set_Col (To : Positive_Count); - - procedure Set_Line (File : File_Type; To : Positive_Count); - procedure Set_Line (To : Positive_Count); - - function Col (File : File_Type) return Positive_Count; - function Col return Positive_Count; - - function Line (File : File_Type) return Positive_Count; - function Line return Positive_Count; - - function Page (File : File_Type) return Positive_Count; - function Page return Positive_Count; - - ---------------------------- - -- Character Input-Output -- - ---------------------------- - - procedure Get (File : File_Type; Item : out Wide_Character); - procedure Get (Item : out Wide_Character); - procedure Put (File : File_Type; Item : Wide_Character); - procedure Put (Item : Wide_Character); - - procedure Look_Ahead - (File : File_Type; - Item : out Wide_Character; - End_Of_Line : out Boolean); - - procedure Look_Ahead - (Item : out Wide_Character; - End_Of_Line : out Boolean); - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Character); - - procedure Get_Immediate - (Item : out Wide_Character); - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Character; - Available : out Boolean); - - procedure Get_Immediate - (Item : out Wide_Character; - Available : out Boolean); - - ------------------------- - -- String Input-Output -- - ------------------------- - - procedure Get (File : File_Type; Item : out Wide_String); - procedure Get (Item : out Wide_String); - procedure Put (File : File_Type; Item : Wide_String); - procedure Put (Item : Wide_String); - - procedure Get_Line - (File : File_Type; - Item : out Wide_String; - Last : out Natural); - - procedure Get_Line - (Item : out Wide_String; - Last : out Natural); - - function Get_Line (File : File_Type) return Wide_String; - pragma Ada_05 (Get_Line); - - function Get_Line return Wide_String; - pragma Ada_05 (Get_Line); - - procedure Put_Line - (File : File_Type; - Item : Wide_String); - - procedure Put_Line - (Item : Wide_String); - - --------------------------------------- - -- Generic packages for Input-Output -- - --------------------------------------- - - -- The generic packages: - - -- Ada.Wide_Text_IO.Integer_IO - -- Ada.Wide_Text_IO.Modular_IO - -- Ada.Wide_Text_IO.Float_IO - -- Ada.Wide_Text_IO.Fixed_IO - -- Ada.Wide_Text_IO.Decimal_IO - -- Ada.Wide_Text_IO.Enumeration_IO - - -- are implemented as separate child packages in GNAT, so the - -- spec and body of these packages are to be found in separate - -- child units. This implementation detail is hidden from the - -- Ada programmer by special circuitry in the compiler that - -- treats these child packages as though they were nested in - -- Text_IO. The advantage of this special processing is that - -- the subsidiary routines needed if these generics are used - -- are not loaded when they are not used. - - ---------------- - -- Exceptions -- - ---------------- - - Status_Error : exception renames IO_Exceptions.Status_Error; - Mode_Error : exception renames IO_Exceptions.Mode_Error; - Name_Error : exception renames IO_Exceptions.Name_Error; - Use_Error : exception renames IO_Exceptions.Use_Error; - Device_Error : exception renames IO_Exceptions.Device_Error; - End_Error : exception renames IO_Exceptions.End_Error; - Data_Error : exception renames IO_Exceptions.Data_Error; - Layout_Error : exception renames IO_Exceptions.Layout_Error; - -private - - -- The following procedures have a File_Type formal of mode IN OUT because - -- they may close the original file. The Close operation may raise an - -- exception, but in that case we want any assignment to the formal to - -- be effective anyway, so it must be passed by reference (or the caller - -- will be left with a dangling pointer). - - pragma Export_Procedure - (Internal => Close, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Delete, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type), - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type, File_Mode), - Mechanism => (File => Reference)); - - package WCh_Con renames System.WCh_Con; - - ----------------------------------- - -- Handling of Format Characters -- - ----------------------------------- - - -- Line marks are represented by the single character ASCII.LF (16#0A#). - -- In DOS and similar systems, underlying file translation takes care - -- of translating this to and from the standard CR/LF sequences used in - -- these operating systems to mark the end of a line. On output there is - -- always a line mark at the end of the last line, but on input, this - -- line mark can be omitted, and is implied by the end of file. - - -- Page marks are represented by the single character ASCII.FF (16#0C#), - -- The page mark at the end of the file may be omitted, and is normally - -- omitted on output unless an explicit New_Page call is made before - -- closing the file. No page mark is added when a file is appended to, - -- so, in accordance with the permission in (RM A.10.2(4)), there may - -- or may not be a page mark separating preexisting text in the file - -- from the new text to be written. - - -- A file mark is marked by the physical end of file. In DOS translation - -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the - -- physical end of file, so in effect this character is recognized as - -- marking the end of file in DOS and similar systems. - - LM : constant := Character'Pos (ASCII.LF); - -- Used as line mark - - PM : constant := Character'Pos (ASCII.FF); - -- Used as page mark, except at end of file where it is implied - - ------------------------------------- - -- Wide_Text_IO File Control Block -- - ------------------------------------- - - Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8; - -- This gets modified during initialization (see body) using - -- the default value established in the call to Set_Globals. - - package FCB renames System.File_Control_Block; - - type Wide_Text_AFCB is new FCB.AFCB with record - Page : Count := 1; - Line : Count := 1; - Col : Count := 1; - Line_Length : Count := 0; - Page_Length : Count := 0; - - Self : aliased File_Type; - -- Set to point to the containing Text_AFCB block. This is used to - -- implement the Current_{Error,Input,Output} functions which return - -- a File_Access, the file access value returned is a pointer to - -- the Self field of the corresponding file. - - Before_LM : Boolean := False; - -- This flag is used to deal with the anomalies introduced by the - -- peculiar definition of End_Of_File and End_Of_Page in Ada. These - -- functions require looking ahead more than one character. Since - -- there is no convenient way of backing up more than one character, - -- what we do is to leave ourselves positioned past the LM, but set - -- this flag, so that we know that from an Ada point of view we are - -- in front of the LM, not after it. A bit odd, but it works. - - Before_LM_PM : Boolean := False; - -- This flag similarly handles the case of being physically positioned - -- after a LM-PM sequence when logically we are before the LM-PM. This - -- flag can only be set if Before_LM is also set. - - WC_Method : WCh_Con.WC_Encoding_Method := Default_WCEM; - -- Encoding method to be used for this file - - Before_Wide_Character : Boolean := False; - -- This flag is set to indicate that a wide character in the input has - -- been read by Wide_Text_IO.Look_Ahead. If it is set to True, then it - -- means that the stream is logically positioned before the character - -- but is physically positioned after it. The character involved must - -- not be in the range 16#00#-16#7F#, i.e. if the flag is set, then - -- we know the next character has a code greater than 16#7F#, and the - -- value of this character is saved in Saved_Wide_Character. - - Saved_Wide_Character : Wide_Character; - -- This field is valid only if Before_Wide_Character is set. It - -- contains a wide character read by Look_Ahead. If Look_Ahead - -- reads a character in the range 16#0000# to 16#007F#, then it - -- can use ungetc to put it back, but ungetc cannot be called - -- more than once, so for characters above this range, we don't - -- try to back up the file. Instead we save the character in this - -- field and set the flag Before_Wide_Character to indicate that - -- we are logically positioned before this character even though - -- the stream is physically positioned after it. - - end record; - - type File_Type is access all Wide_Text_AFCB; - - function AFCB_Allocate (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr; - - procedure AFCB_Close (File : not null access Wide_Text_AFCB); - procedure AFCB_Free (File : not null access Wide_Text_AFCB); - - procedure Read - (File : in out Wide_Text_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Read operation used when Wide_Text_IO file is treated as a Stream - - procedure Write - (File : in out Wide_Text_AFCB; - Item : Ada.Streams.Stream_Element_Array); - -- Write operation used when Wide_Text_IO file is treated as a Stream - - ------------------------ - -- The Standard Files -- - ------------------------ - - Standard_Err_AFCB : aliased Wide_Text_AFCB; - Standard_In_AFCB : aliased Wide_Text_AFCB; - Standard_Out_AFCB : aliased Wide_Text_AFCB; - - Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; - Standard_In : aliased File_Type := Standard_In_AFCB'Access; - Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; - -- Standard files - - Current_In : aliased File_Type := Standard_In; - Current_Out : aliased File_Type := Standard_Out; - Current_Err : aliased File_Type := Standard_Err; - -- Current files - - procedure Initialize_Standard_Files; - -- Initializes the file control blocks for the standard files. Called from - -- the elaboration routine for this package, and from Reset_Standard_Files - -- in package Ada.Wide_Text_IO.Reset_Standard_Files. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- These subprograms are in the private part of the spec so that they can - -- be shared by the children of Ada.Wide_Text_IO. - - function Getc (File : File_Type) return Interfaces.C_Streams.int; - -- Gets next character from file, which has already been checked for being - -- in read status, and returns the character read if no error occurs. The - -- result is EOF if the end of file was read. - - procedure Get_Character (File : File_Type; Item : out Character); - -- This is essentially a copy of the normal Get routine from Text_IO. It - -- obtains a single character from the input file File, and places it in - -- Item. This character may be the leading character of a Wide_Character - -- sequence, but that is up to the caller to deal with. - - function Get_Wide_Char - (C : Character; - File : File_Type) return Wide_Character; - -- This function is shared by Get and Get_Immediate to extract a wide - -- character value from the given File. The first byte has already been - -- read and is passed in C. The wide character value is returned as the - -- result, and the file pointer is bumped past the character. - - function Nextc (File : File_Type) return Interfaces.C_Streams.int; - -- Returns next character from file without skipping past it (i.e. it is a - -- combination of Getc followed by an Ungetc). - -end Ada.Wide_Text_IO; diff --git a/gcc/ada/a-wrstfi.adb b/gcc/ada/a-wrstfi.adb deleted file mode 100644 index 6b3f656..0000000 --- a/gcc/ada/a-wrstfi.adb +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -------------------------------------------- --- Ada.Wide_Text_IO.Reset_Standard_Files -- -------------------------------------------- - -procedure Ada.Wide_Text_IO.Reset_Standard_Files is -begin - Ada.Wide_Text_IO.Initialize_Standard_Files; -end Ada.Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-wrstfi.ads b/gcc/ada/a-wrstfi.ads deleted file mode 100644 index 5d6548e..0000000 --- a/gcc/ada/a-wrstfi.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 reset routine that resets the standard files used --- by Ada.Wide_Text_IO. This is useful in systems such as VxWorks where --- Ada.Wide_Text_IO is elaborated at the program start, but a system restart --- may alter the status of these files, resulting in incorrect operation of --- Wide_Text_IO (in particular if the standard input file is changed to be --- interactive, then Get_Line may hang looking for an extra character after --- the end of the line. - -procedure Ada.Wide_Text_IO.Reset_Standard_Files; --- Reset standard Wide_Text_IO files as described above diff --git a/gcc/ada/a-wtcoau.adb b/gcc/ada/a-wtcoau.adb deleted file mode 100644 index 5a7f438..0000000 --- a/gcc/ada/a-wtcoau.adb +++ /dev/null @@ -1,202 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . C O M P L E X _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; -with Ada.Wide_Text_IO.Float_Aux; - -with System.Img_Real; use System.Img_Real; - -package body Ada.Wide_Text_IO.Complex_Aux is - - package Aux renames Ada.Wide_Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer; - Paren : Boolean := False; - - begin - -- General note for following code, exceptions from the calls - -- to Get for components of the complex value are propagated. - - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); - - for J in Ptr + 1 .. Stop loop - if not Is_Blank (Buf (J)) then - raise Data_Error; - end if; - end loop; - - -- Case of width = 0 - - else - Load_Skip (File); - Ptr := 0; - Load (File, Buf, Ptr, '(', Paren); - Aux.Get (File, ItemR, 0); - Load_Skip (File); - Load (File, Buf, Ptr, ','); - Aux.Get (File, ItemI, 0); - - if Paren then - Load_Skip (File); - Load (File, Buf, Ptr, ')', Paren); - - if not Paren then - raise Data_Error; - end if; - end if; - end if; - end Get; - - ---------- - -- Gets -- - ---------- - - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive) - is - Paren : Boolean; - Pos : Integer; - - begin - String_Skip (From, Pos); - - if From (Pos) = '(' then - Pos := Pos + 1; - Paren := True; - else - Paren := False; - end if; - - Aux.Gets (From (Pos .. From'Last), ItemR, Pos); - - String_Skip (From (Pos + 1 .. From'Last), Pos); - - if From (Pos) = ',' then - Pos := Pos + 1; - end if; - - Aux.Gets (From (Pos .. From'Last), ItemI, Pos); - - if Paren then - String_Skip (From (Pos + 1 .. From'Last), Pos); - - if From (Pos) /= ')' then - raise Data_Error; - end if; - end if; - - Last := Pos; - end Gets; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field) - is - begin - Put (File, '('); - Aux.Put (File, ItemR, Fore, Aft, Exp); - Put (File, ','); - Aux.Put (File, ItemI, Fore, Aft, Exp); - Put (File, ')'); - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Aft : Field; - Exp : Field) - is - I_String : String (1 .. 3 * Field'Last); - R_String : String (1 .. 3 * Field'Last); - - Iptr : Natural; - Rptr : Natural; - - begin - -- Both parts are initially converted with a Fore of 0 - - Rptr := 0; - Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); - Iptr := 0; - Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); - - -- Check room for both parts plus parens plus comma (RM G.1.3(34)) - - if Rptr + Iptr + 3 > To'Length then - raise Layout_Error; - end if; - - -- If there is room, layout result according to (RM G.1.3(31-33)) - - To (To'First) := '('; - To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); - To (To'First + Rptr + 1) := ','; - - To (To'Last) := ')'; - - To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); - - for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop - To (J) := ' '; - end loop; - end Puts; - -end Ada.Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-wtcoau.ads b/gcc/ada/a-wtcoau.ads deleted file mode 100644 index f5fa1e2..0000000 --- a/gcc/ada/a-wtcoau.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . C O M P L E X _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Text_IO.Complex_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Complex_IO itself, --- except that the generic parameter Complex has been replaced by separate --- real and imaginary values of type Long_Long_Float, and default parameters --- have been removed because they are supplied explicitly by the calls from --- within the generic template. - -package Ada.Wide_Text_IO.Complex_Aux is - - procedure Get - (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Width : Field); - - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive); - - procedure Put - (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field); - - procedure Puts - (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Aft : Field; - Exp : Field); - -end Ada.Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-wtcoio.adb b/gcc/ada/a-wtcoio.adb deleted file mode 100644 index 06f5da5..0000000 --- a/gcc/ada/a-wtcoio.adb +++ /dev/null @@ -1,159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ IO . C O M P L E X _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Complex_Aux; - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -with Ada.Unchecked_Conversion; - -package body Ada.Wide_Text_IO.Complex_IO is - - package Aux renames Ada.Wide_Text_IO.Complex_Aux; - - subtype LLF is Long_Long_Float; - -- Type used for calls to routines in Aux - - function TFT is new - Ada.Unchecked_Conversion (File_Type, Ada.Wide_Text_IO.File_Type); - -- This unchecked conversion is to get around a visibility bug in - -- GNAT version 2.04w. It should be possible to simply use the - -- subtype declared above and do normal checked conversions. - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Complex; - Width : Field := 0) - is - Real_Item : Real'Base; - Imag_Item : Real'Base; - - begin - Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); - Item := (Real_Item, Imag_Item); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Get -- - --------- - - procedure Get - (Item : out Complex; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - --------- - -- Get -- - --------- - - procedure Get - (From : Wide_String; - Item : out Complex; - Last : out Positive) - is - Real_Item : Real'Base; - Imag_Item : Real'Base; - - S : constant String := Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); - Item := (Real_Item, Imag_Item); - - exception - when Data_Error => raise Constraint_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (To : out Wide_String; - Item : Complex; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); - - for J in S'Range loop - To (J) := Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-wtcoio.ads b/gcc/ada/a-wtcoio.ads deleted file mode 100644 index 31fab2b..0000000 --- a/gcc/ada/a-wtcoio.ads +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ IO . C O M P L E X _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; - -generic - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); - -package Ada.Wide_Text_IO.Complex_IO is - - use Complex_Types; - - Default_Fore : Field := 2; - Default_Aft : Field := Real'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Complex; - Width : Field := 0); - - procedure Get - (Item : out Complex; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_String; - Item : out Complex; - Last : out Positive); - - procedure Put - (To : out Wide_String; - Item : Complex; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-wtcstr.adb b/gcc/ada/a-wtcstr.adb deleted file mode 100644 index 4be744a..0000000 --- a/gcc/ada/a-wtcstr.adb +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; -with Ada.Unchecked_Conversion; - -package body Ada.Wide_Text_IO.C_Streams is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - - -------------- - -- C_Stream -- - -------------- - - function C_Stream (F : File_Type) return FILEs is - begin - FIO.Check_File_Open (AP (F)); - return F.Stream; - end C_Stream; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : FILEs; - Form : String := ""; - Name : String := "") - is - Dummy_File_Control_Block : Wide_Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'W', - Creat => False, - Text => True, - C_Stream => C_Stream); - - end Open; - -end Ada.Wide_Text_IO.C_Streams; diff --git a/gcc/ada/a-wtcstr.ads b/gcc/ada/a-wtcstr.ads deleted file mode 100644 index af2d37a..0000000 --- a/gcc/ada/a-wtcstr.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . C _ S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface between Ada.Wide_Text_IO and the --- C streams. This allows sharing of a stream between Ada and C or C++, --- as well as allowing the Ada program to operate directly on the stream. - -with Interfaces.C_Streams; - -package Ada.Wide_Text_IO.C_Streams is - - package ICS renames Interfaces.C_Streams; - - function C_Stream (F : File_Type) return ICS.FILEs; - -- Obtain stream from existing open file - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : ICS.FILEs; - Form : String := ""; - Name : String := ""); - -- Create new file from existing stream - -end Ada.Wide_Text_IO.C_Streams; diff --git a/gcc/ada/a-wtdeau.adb b/gcc/ada/a-wtdeau.adb deleted file mode 100644 index 78b1029..0000000 --- a/gcc/ada/a-wtdeau.adb +++ /dev/null @@ -1,265 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . D E C I M A L _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; -with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux; - -with System.Img_Dec; use System.Img_Dec; -with System.Img_LLD; use System.Img_LLD; -with System.Val_Dec; use System.Val_Dec; -with System.Val_LLD; use System.Val_LLD; - -package body Ada.Wide_Text_IO.Decimal_Aux is - - ------------- - -- Get_Dec -- - ------------- - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_Dec; - - ------------- - -- Get_LLD -- - ------------- - - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Long_Long_Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_LLD; - - -------------- - -- Gets_Dec -- - -------------- - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer - is - Pos : aliased Integer; - Item : Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; - - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - - end Gets_Dec; - - -------------- - -- Gets_LLD -- - -------------- - - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer - is - Pos : aliased Integer; - Item : Long_Long_Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; - - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - - end Gets_LLD; - - ------------- - -- Put_Dec -- - ------------- - - procedure Put_Dec - (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_Dec; - - ------------- - -- Put_LLD -- - ------------- - - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLD; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - -- Compute Fore, allowing for Aft digits and the decimal dot - - Fore := To'Length - Field'Max (1, Aft) - 1; - - -- Allow for Exp and two more for E+ or E- if exponent present - - if Exp /= 0 then - Fore := Fore - 2 - Exp; - end if; - - -- Make sure we have enough room - - if Fore < 1 then - raise Layout_Error; - end if; - - -- Do the conversion and check length of result - - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_Dec; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - Fore := - (if Exp = 0 - then To'Length - 1 - Aft - else To'Length - 2 - Aft - Exp); - - if Fore < 1 then - raise Layout_Error; - end if; - - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_LLD; - -end Ada.Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-wtdeau.ads b/gcc/ada/a-wtdeau.ads deleted file mode 100644 index 4308889..0000000 --- a/gcc/ada/a-wtdeau.ads +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . D E C I M A L _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Text_IO.Decimal_IO --- that are shared among separate instantiations of this package. The --- routines in the package are identical semantically to those declared --- in Wide_Text_IO, except that default values have been supplied by the --- generic, and the Num parameter has been replaced by Integer or --- Long_Long_Integer, with an additional Scale parameter giving the --- value of Num'Scale. In addition the Get routines return the value --- rather than store it in an Out parameter. - -private package Ada.Wide_Text_IO.Decimal_Aux is - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer; - - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer; - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer; - - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer; - - procedure Put_Dec - (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer); - -end Ada.Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-wtdeio.adb b/gcc/ada/a-wtdeio.adb deleted file mode 100644 index 1c13f9a..0000000 --- a/gcc/ada/a-wtdeio.adb +++ /dev/null @@ -1,155 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Decimal_Aux; - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Text_IO.Decimal_IO is - - subtype TFT is Ada.Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Text_IO.Decimal_Aux; - - Scale : constant Integer := Num'Scale; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); - else - Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); - end if; - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - if Num'Size > Integer'Size then - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); - else - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - if Num'Size > Integer'Size then - Aux.Put_LLD - (TFT (File), Long_Long_Integer'Integer_Value (Item), - Fore, Aft, Exp, Scale); - else - Aux.Put_Dec - (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); - end if; - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - procedure Put - (To : out Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - if Num'Size > Integer'Size then - Aux.Puts_LLD - (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); - - else - Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); - end if; - - for J in S'Range loop - To (J) := Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-wtdeio.ads b/gcc/ada/a-wtdeio.ads deleted file mode 100644 index dbeb80a..0000000 --- a/gcc/ada/a-wtdeio.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Text_IO.Decimal_IO is a subpackage --- of Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Decimal_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is delta <> digits <>; - -package Ada.Wide_Text_IO.Decimal_IO is - - Default_Fore : Field := 2; - Default_Aft : Field := Num'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-wtedit.adb b/gcc/ada/a-wtedit.adb deleted file mode 100644 index 32d62b9..0000000 --- a/gcc/ada/a-wtedit.adb +++ /dev/null @@ -1,2716 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . E D I T I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -with Ada.Strings.Wide_Fixed; - -package body Ada.Wide_Text_IO.Editing is - - package Strings renames Ada.Strings; - package Strings_Fixed renames Ada.Strings.Fixed; - package Strings_Wide_Fixed renames Ada.Strings.Wide_Fixed; - package Wide_Text_IO renames Ada.Wide_Text_IO; - - ----------------------- - -- Local_Subprograms -- - ----------------------- - - function To_Wide (C : Character) return Wide_Character; - pragma Inline (To_Wide); - -- Convert Character to corresponding Wide_Character - - --------------------- - -- Blank_When_Zero -- - --------------------- - - function Blank_When_Zero (Pic : Picture) return Boolean is - begin - return Pic.Contents.Original_BWZ; - end Blank_When_Zero; - - -------------------- - -- Decimal_Output -- - -------------------- - - package body Decimal_Output is - - ----------- - -- Image -- - ----------- - - function Image - (Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark) return Wide_String - is - begin - return Format_Number - (Pic.Contents, Num'Image (Item), - Currency, Fill, Separator, Radix_Mark); - end Image; - - ------------ - -- Length -- - ------------ - - function Length - (Pic : Picture; - Currency : Wide_String := Default_Currency) return Natural - is - Picstr : constant String := Pic_String (Pic); - V_Adjust : Integer := 0; - Cur_Adjust : Integer := 0; - - begin - -- Check if Picstr has 'V' or '$' - - -- If 'V', then length is 1 less than otherwise - - -- If '$', then length is Currency'Length-1 more than otherwise - - -- This should use the string handling package ??? - - for J in Picstr'Range loop - if Picstr (J) = 'V' then - V_Adjust := -1; - - elsif Picstr (J) = '$' then - Cur_Adjust := Currency'Length - 1; - end if; - end loop; - - return Picstr'Length - V_Adjust + Cur_Adjust; - end Length; - - --------- - -- Put -- - --------- - - procedure Put - (File : Wide_Text_IO.File_Type; - Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark) - is - begin - Wide_Text_IO.Put (File, Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark) - is - begin - Wide_Text_IO.Put (Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (To : out Wide_String; - Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark) - is - Result : constant Wide_String := - Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); - - begin - if Result'Length > To'Length then - raise Wide_Text_IO.Layout_Error; - else - Strings_Wide_Fixed.Move (Source => Result, Target => To, - Justify => Strings.Right); - end if; - end Put; - - ----------- - -- Valid -- - ----------- - - function Valid - (Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency) return Boolean - is - begin - declare - Temp : constant Wide_String := Image (Item, Pic, Currency); - pragma Warnings (Off, Temp); - begin - return True; - end; - - exception - when Layout_Error => return False; - - end Valid; - end Decimal_Output; - - ------------ - -- Expand -- - ------------ - - function Expand (Picture : String) return String is - Result : String (1 .. MAX_PICSIZE); - Picture_Index : Integer := Picture'First; - Result_Index : Integer := Result'First; - Count : Natural; - Last : Integer; - - begin - if Picture'Length < 1 then - raise Picture_Error; - end if; - - if Picture (Picture'First) = '(' then - raise Picture_Error; - end if; - - loop - case Picture (Picture_Index) is - when '(' => - - -- We now need to scan out the count after a left paren. In - -- the non-wide version we used Integer_IO.Get, but that is - -- not convenient here, since we don't want to drag in normal - -- Text_IO just for this purpose. So we do the scan ourselves, - -- with the normal validity checks. - - Last := Picture_Index + 1; - Count := 0; - - if Picture (Last) not in '0' .. '9' then - raise Picture_Error; - end if; - - Count := Character'Pos (Picture (Last)) - Character'Pos ('0'); - Last := Last + 1; - - loop - if Last > Picture'Last then - raise Picture_Error; - end if; - - if Picture (Last) = '_' then - if Picture (Last - 1) = '_' then - raise Picture_Error; - end if; - - elsif Picture (Last) = ')' then - exit; - - elsif Picture (Last) not in '0' .. '9' then - raise Picture_Error; - - else - Count := Count * 10 - + Character'Pos (Picture (Last)) - - Character'Pos ('0'); - end if; - - Last := Last + 1; - end loop; - - -- In what follows note that one copy of the repeated - -- character has already been made, so a count of one is - -- no-op, and a count of zero erases a character. - - for J in 2 .. Count loop - Result (Result_Index + J - 2) := Picture (Picture_Index - 1); - end loop; - - Result_Index := Result_Index + Count - 1; - - -- Last was a ')' throw it away too - - Picture_Index := Last + 1; - - when ')' => - raise Picture_Error; - - when others => - Result (Result_Index) := Picture (Picture_Index); - Picture_Index := Picture_Index + 1; - Result_Index := Result_Index + 1; - end case; - - exit when Picture_Index > Picture'Last; - end loop; - - return Result (1 .. Result_Index - 1); - - exception - when others => - raise Picture_Error; - end Expand; - - ------------------- - -- Format_Number -- - ------------------- - - function Format_Number - (Pic : Format_Record; - Number : String; - Currency_Symbol : Wide_String; - Fill_Character : Wide_Character; - Separator_Character : Wide_Character; - Radix_Point : Wide_Character) return Wide_String - is - Attrs : Number_Attributes := Parse_Number_String (Number); - Position : Integer; - Rounded : String := Number; - - Sign_Position : Integer := Pic.Sign_Position; -- may float. - - Answer : Wide_String (1 .. Pic.Picture.Length); - Last : Integer; - Currency_Pos : Integer := Pic.Start_Currency; - - Dollar : Boolean := False; - -- Overridden immediately if necessary - - Zero : Boolean := True; - -- Set to False when a non-zero digit is output - - begin - - -- If the picture has fewer decimal places than the number, the image - -- must be rounded according to the usual rules. - - if Attrs.Has_Fraction then - declare - R : constant Integer := - (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) - - Pic.Max_Trailing_Digits; - R_Pos : Integer; - - begin - if R > 0 then - R_Pos := Rounded'Length - R; - - if Rounded (R_Pos + 1) > '4' then - - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - - while R_Pos > 1 loop - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - exit; - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - end if; - end loop; - - -- The rounding may add a digit in front. Either the - -- leading blank or the sign (already captured) can be - -- overwritten. - - if R_Pos = 1 then - Rounded (R_Pos) := '1'; - Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; - end if; - end if; - end if; - end if; - end; - end if; - - for J in Answer'Range loop - Answer (J) := To_Wide (Pic.Picture.Expanded (J)); - end loop; - - if Pic.Start_Currency /= Invalid_Position then - Dollar := Answer (Pic.Start_Currency) = '$'; - end if; - - -- Fix up "direct inserts" outside the playing field. Set up as one - -- loop to do the beginning, one (reverse) loop to do the end. - - Last := 1; - loop - exit when Last = Pic.Start_Float; - exit when Last = Pic.Radix_Position; - exit when Answer (Last) = '9'; - - case Answer (Last) is - when '_' => - Answer (Last) := Separator_Character; - - when 'b' => - Answer (Last) := ' '; - - when others => - null; - end case; - - exit when Last = Answer'Last; - - Last := Last + 1; - end loop; - - -- Now for the end... - - for J in reverse Last .. Answer'Last loop - exit when J = Pic.Radix_Position; - - -- Do this test First, Separator_Character can equal Pic.Floater - - if Answer (J) = Pic.Floater then - exit; - end if; - - case Answer (J) is - when '_' => - Answer (J) := Separator_Character; - - when 'b' => - Answer (J) := ' '; - - when '9' => - exit; - - when others => - null; - end case; - end loop; - - -- Non-floating sign - - if Pic.Start_Currency /= -1 - and then Answer (Pic.Start_Currency) = '#' - and then Pic.Floater /= '#' - then - if Currency_Symbol'Length > - Pic.End_Currency - Pic.Start_Currency + 1 - then - raise Picture_Error; - - elsif Currency_Symbol'Length = - Pic.End_Currency - Pic.Start_Currency + 1 - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - Currency_Symbol; - - elsif Pic.Radix_Position = Invalid_Position - or else Pic.Start_Currency < Pic.Radix_Position - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. - Pic.End_Currency) := Currency_Symbol; - - else - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.Start_Currency .. - Pic.Start_Currency + Currency_Symbol'Length - 1) := - Currency_Symbol; - end if; - end if; - - -- Fill in leading digits - - if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > - Pic.Max_Leading_Digits - then - raise Layout_Error; - end if; - - Position := - (if Pic.Radix_Position = Invalid_Position then Answer'Last - else Pic.Radix_Position - 1); - - for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop - while Answer (Position) /= '9' - and then - Answer (Position) /= Pic.Floater - loop - if Answer (Position) = '_' then - Answer (Position) := Separator_Character; - elsif Answer (Position) = 'b' then - Answer (Position) := ' '; - end if; - - Position := Position - 1; - end loop; - - Answer (Position) := To_Wide (Rounded (J)); - - if Rounded (J) /= '0' then - Zero := False; - end if; - - Position := Position - 1; - end loop; - - -- Do lead float - - if Pic.Start_Float = Invalid_Position then - - -- No leading floats, but need to change '9' to '0', '_' to - -- Separator_Character and 'b' to ' '. - - for J in Last .. Position loop - - -- Last set when fixing the "uninteresting" leaders above. - -- Don't duplicate the work. - - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - - end loop; - - elsif Pic.Floater = '<' - or else - Pic.Floater = '+' - or else - Pic.Floater = '-' - then - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Sign_Position := Position; - - elsif Pic.Floater = '$' then - - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := ' '; -- no separator before leftmost digit - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Currency_Pos := Position; - - elsif Pic.Floater = '*' then - - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := '*'; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position loop - Answer (J) := '*'; - end loop; - - else - if Pic.Floater = '#' then - Currency_Pos := Currency_Symbol'Length; - end if; - - for J in reverse Pic.Start_Float .. Position loop - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'b' | '/' | '0' => - Answer (J) := ' '; - - when '9' => - Answer (J) := '0'; - - when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => - null; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when '_' => - case Pic.Floater is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'b' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when others => - null; - end case; - - when others => - null; - end case; - end loop; - - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Layout_Error; - end if; - end if; - - -- Do sign - - if Sign_Position = Invalid_Position then - if Attrs.Negative then - raise Layout_Error; - end if; - - else - if Attrs.Negative then - case Answer (Sign_Position) is - when 'C' | 'D' | '-' => - null; - - when '+' => - Answer (Sign_Position) := '-'; - - when '<' => - Answer (Sign_Position) := '('; - Answer (Pic.Second_Sign) := ')'; - - when others => - raise Picture_Error; - end case; - - else -- positive - - case Answer (Sign_Position) is - when '-' => - Answer (Sign_Position) := ' '; - - when '<' | 'C' | 'D' => - Answer (Sign_Position) := ' '; - Answer (Pic.Second_Sign) := ' '; - - when '+' => - null; - - when others => - raise Picture_Error; - end case; - end if; - end if; - - -- Fill in trailing digits - - if Pic.Max_Trailing_Digits > 0 then - - if Attrs.Has_Fraction then - Position := Attrs.Start_Of_Fraction; - Last := Pic.Radix_Position + 1; - - for J in Last .. Answer'Last loop - if Answer (J) = '9' or else Answer (J) = Pic.Floater then - Answer (J) := To_Wide (Rounded (Position)); - - if Rounded (Position) /= '0' then - Zero := False; - end if; - - Position := Position + 1; - Last := J + 1; - - -- Used up fraction but remember place in Answer - - exit when Position > Attrs.End_Of_Fraction; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - end if; - - Last := J + 1; - end loop; - - Position := Last; - - else - Position := Pic.Radix_Position + 1; - end if; - - -- Now fill remaining 9's with zeros and _ with separators - - Last := Answer'Last; - - for J in Position .. Last loop - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = Pic.Floater then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - end loop; - - Position := Last + 1; - - else - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Layout_Error; - end if; - - -- No trailing digits, but now J may need to stick in a currency - -- symbol or sign. - - Position := - (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1 - else Pic.Start_Currency); - end if; - - for J in Position .. Answer'Last loop - if Pic.Start_Currency /= Invalid_Position - and then Answer (Pic.Start_Currency) = '#' - then - Currency_Pos := 1; - end if; - - -- Note: There are some weird cases J can imagine with 'b' or '#' in - -- currency strings where the following code will cause glitches. The - -- trick is to tell when the character in the answer should be - -- checked, and when to look at the original string. Some other time. - -- RIE 11/26/96 ??? - - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'b' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - end if; - - when '_' => - case Pic.Floater is - - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'z' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - end if; - - when others => - null; - end case; - - when others => - exit; - end case; - end loop; - - -- Now get rid of Blank_when_Zero and complete Star fill - - if Zero and then Pic.Blank_When_Zero then - - -- Value is zero, and blank it - - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position - and then Answer (Pic.Radix_Position) = 'V' - then - Last := Last - 1; - end if; - - return Wide_String'(1 .. Last => ' '); - - elsif Zero and then Pic.Star_Fill then - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position then - - if Answer (Pic.Radix_Position) = 'V' then - Last := Last - 1; - - elsif Dollar then - if Pic.Radix_Position > Pic.Start_Currency then - return Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); - - else - return - Wide_String' - (1 .. - Pic.Radix_Position + Currency_Symbol'Length - 2 - => '*') & - Radix_Point & - Wide_String' - (Pic.Radix_Position + Currency_Symbol'Length .. Last - => '*'); - end if; - - else - return - Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); - end if; - end if; - - return Wide_String'(1 .. Last => '*'); - end if; - - -- This was once a simple return statement, now there are nine - -- different return cases. Not to mention the five above to deal - -- with zeros. Why not split things out? - - -- Processing the radix and sign expansion separately would require - -- lots of copying--the string and some of its indexes--without - -- really simplifying the logic. The cases are: - - -- 1) Expand $, replace '.' with Radix_Point - -- 2) No currency expansion, replace '.' with Radix_Point - -- 3) Expand $, radix blanked - -- 4) No currency expansion, radix blanked - -- 5) Elide V - -- 6) Expand $, Elide V - -- 7) Elide V, Expand $ (Two cases depending on order.) - -- 8) No radix, expand $ - -- 9) No radix, no currency expansion - - if Pic.Radix_Position /= Invalid_Position then - - if Answer (Pic.Radix_Position) = '.' then - Answer (Pic.Radix_Position) := Radix_Point; - - if Dollar then - - -- 1) Expand $, replace '.' with Radix_Point - - return - Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 2) No currency expansion, replace '.' with Radix_Point - - return Answer; - end if; - - elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. - if Dollar then - - -- 3) Expand $, radix blanked - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 4) No expansion, radix blanked - - return Answer; - end if; - - -- V cases - - else - if not Dollar then - - -- 5) Elide V - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - elsif Currency_Pos < Pic.Radix_Position then - - -- 6) Expand $, Elide V - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - else - -- 7) Elide V, Expand $ - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & - Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - end if; - end if; - - elsif Dollar then - - -- 8) No radix, expand $ - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 9) No radix, no currency expansion - - return Answer; - end if; - end Format_Number; - - ------------------------- - -- Parse_Number_String -- - ------------------------- - - function Parse_Number_String (Str : String) return Number_Attributes is - Answer : Number_Attributes; - - begin - for J in Str'Range loop - case Str (J) is - when ' ' => - null; -- ignore - - when '1' .. '9' => - - -- Decide if this is the start of a number. - -- If so, figure out which one... - - if Answer.Has_Fraction then - Answer.End_Of_Fraction := J; - else - if Answer.Start_Of_Int = Invalid_Position then - -- start integer - Answer.Start_Of_Int := J; - end if; - Answer.End_Of_Int := J; - end if; - - when '0' => - - -- Only count a zero before the decimal point if it follows a - -- non-zero digit. After the decimal point, zeros will be - -- counted if followed by a non-zero digit. - - if not Answer.Has_Fraction then - if Answer.Start_Of_Int /= Invalid_Position then - Answer.End_Of_Int := J; - end if; - end if; - - when '-' => - - -- Set negative - - Answer.Negative := True; - - when '.' => - - -- Close integer, start fraction - - if Answer.Has_Fraction then - raise Picture_Error; - end if; - - -- Two decimal points is a no-no - - Answer.Has_Fraction := True; - Answer.End_Of_Fraction := J; - - -- Could leave this at Invalid_Position, but this seems the - -- right way to indicate a null range... - - Answer.Start_Of_Fraction := J + 1; - Answer.End_Of_Int := J - 1; - - when others => - raise Picture_Error; -- can this happen? probably not - end case; - end loop; - - if Answer.Start_Of_Int = Invalid_Position then - Answer.Start_Of_Int := Answer.End_Of_Int + 1; - end if; - - -- No significant (intger) digits needs a null range - - return Answer; - end Parse_Number_String; - - ---------------- - -- Pic_String -- - ---------------- - - -- The following ensures that we return B and not b being careful not - -- to break things which expect lower case b for blank. See CXF3A02. - - function Pic_String (Pic : Picture) return String is - Temp : String (1 .. Pic.Contents.Picture.Length) := - Pic.Contents.Picture.Expanded; - begin - for J in Temp'Range loop - if Temp (J) = 'b' then - Temp (J) := 'B'; - end if; - end loop; - - return Temp; - end Pic_String; - - ------------------ - -- Precalculate -- - ------------------ - - procedure Precalculate (Pic : in out Format_Record) is - - Computed_BWZ : Boolean := True; - - type Legality is (Okay, Reject); - State : Legality := Reject; - -- Start in reject, which will reject null strings - - Index : Pic_Index := Pic.Picture.Expanded'First; - - function At_End return Boolean; - pragma Inline (At_End); - - procedure Set_State (L : Legality); - pragma Inline (Set_State); - - function Look return Character; - pragma Inline (Look); - - function Is_Insert return Boolean; - pragma Inline (Is_Insert); - - procedure Skip; - pragma Inline (Skip); - - procedure Trailing_Currency; - procedure Trailing_Bracket; - procedure Number_Fraction; - procedure Number_Completion; - procedure Number_Fraction_Or_Bracket; - procedure Number_Fraction_Or_Z_Fill; - procedure Zero_Suppression; - procedure Floating_Bracket; - procedure Number_Fraction_Or_Star_Fill; - procedure Star_Suppression; - procedure Number_Fraction_Or_Dollar; - procedure Leading_Dollar; - procedure Number_Fraction_Or_Pound; - procedure Leading_Pound; - procedure Picture; - procedure Floating_Plus; - procedure Floating_Minus; - procedure Picture_Plus; - procedure Picture_Minus; - procedure Picture_Bracket; - procedure Number; - procedure Optional_RHS_Sign; - procedure Picture_String; - - ------------ - -- At_End -- - ------------ - - function At_End return Boolean is - begin - return Index > Pic.Picture.Length; - end At_End; - - ---------------------- - -- Floating_Bracket -- - ---------------------- - - -- Note that Floating_Bracket is only called with an acceptable - -- prefix. But we don't set Okay, because we must end with a '>'. - - procedure Floating_Bracket is - begin - Pic.Floater := '<'; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - - -- First bracket wasn't counted... - - Skip; -- known '<' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when '9' => - Number_Completion; - - when '$' => - Leading_Dollar; - - when '#' => - Leading_Pound; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Bracket; - return; - - when others => - return; - end case; - end loop; - end Floating_Bracket; - - -------------------- - -- Floating_Minus -- - -------------------- - - procedure Floating_Minus is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '-' then - loop - if At_End then - return; - end if; - - case Look is - when '-' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Minus; - - ------------------- - -- Floating_Plus -- - ------------------- - - procedure Floating_Plus is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '+' then - loop - if At_End then - return; - end if; - - case Look is - when '+' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Plus; - - --------------- - -- Is_Insert -- - --------------- - - function Is_Insert return Boolean is - begin - if At_End then - return False; - end if; - - case Pic.Picture.Expanded (Index) is - when '_' | '0' | '/' => - return True; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; -- canonical - return True; - - when others => - return False; - end case; - end Is_Insert; - - -------------------- - -- Leading_Dollar -- - -------------------- - - -- Note that Leading_Dollar can be called in either State. - -- It will set state to Okay only if a 9 or (second) $ is encountered. - - -- Also notice the tricky bit with State and Zero_Suppression. - -- Zero_Suppression is Picture_Error if a '$' or a '9' has been - -- encountered, exactly the cases where State has been set. - - procedure Leading_Dollar is - begin - -- Treat as a floating dollar, and unwind otherwise - - Pic.Floater := '$'; - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Skip; -- known '$' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - -- A trailing insertion character is not part of the - -- floating currency, so need to look ahead. - - if Look /= '$' then - Pic.End_Float := Pic.End_Float - 1; - end if; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if State = Okay then - raise Picture_Error; - else - -- Will overwrite Floater and Start_Float - - Zero_Suppression; - end if; - - when '*' => - if State = Okay then - raise Picture_Error; - else - -- Will overwrite Floater and Start_Float - - Star_Suppression; - end if; - - when '$' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); Skip; - - when '9' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- A single dollar does not a floating make - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one dollar before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Dollar; - return; - - when others => - return; - end case; - end loop; - end Leading_Dollar; - - ------------------- - -- Leading_Pound -- - ------------------- - - -- This one is complex. A Leading_Pound can be fixed or floating, - -- but in some cases the decision has to be deferred until we leave - -- this procedure. Also note that Leading_Pound can be called in - -- either State. - - -- It will set state to Okay only if a 9 or (second) # is - -- encountered. - - -- One Last note: In ambiguous cases, the currency is treated as - -- floating unless there is only one '#'. - - procedure Leading_Pound is - - Inserts : Boolean := False; - -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered - - Must_Float : Boolean := False; - -- Set to true if a '#' occurs after an insert - - begin - -- Treat as a floating currency. If it isn't, this will be - -- overwritten later. - - Pic.Floater := '#'; - - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Pic.Max_Currency_Digits := 1; -- we've seen one. - - Skip; -- known '#' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Will overwrite Floater and Start_Float - - Zero_Suppression; - end if; - - when '*' => - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Will overwrite Floater and Start_Float - - Star_Suppression; - end if; - - when '#' => - if Inserts then - Must_Float := True; - end if; - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); - Skip; - - when '9' => - if State /= Okay then - - -- A single '#' doesn't float - - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one pound before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Pound; - return; - - when others => - return; - end case; - end loop; - end Leading_Pound; - - ---------- - -- Look -- - ---------- - - function Look return Character is - begin - if At_End then - raise Picture_Error; - end if; - - return Pic.Picture.Expanded (Index); - end Look; - - ------------ - -- Number -- - ------------ - - procedure Number is - begin - loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - end case; - - if At_End then - return; - end if; - - -- Will return in Okay state if a '9' was seen - - end loop; - end Number; - - ----------------------- - -- Number_Completion -- - ----------------------- - - procedure Number_Completion is - begin - while not At_End loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - end case; - end loop; - end Number_Completion; - - --------------------- - -- Number_Fraction -- - --------------------- - - procedure Number_Fraction is - begin - -- Note that number fraction can be called in either State. - -- It will set state to Valid only if a 9 is encountered. - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Set_State (Okay); Skip; - - when others => - return; - end case; - end loop; - end Number_Fraction; - - -------------------------------- - -- Number_Fraction_Or_Bracket -- - -------------------------------- - - procedure Number_Fraction_Or_Bracket is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Bracket; - - ------------------------------- - -- Number_Fraction_Or_Dollar -- - ------------------------------- - - procedure Number_Fraction_Or_Dollar is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Dollar; - - ------------------------------ - -- Number_Fraction_Or_Pound -- - ------------------------------ - - procedure Number_Fraction_Or_Pound is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Pound; - - ---------------------------------- - -- Number_Fraction_Or_Star_Fill -- - ---------------------------------- - - procedure Number_Fraction_Or_Star_Fill is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Star_Fill; - - ------------------------------- - -- Number_Fraction_Or_Z_Fill -- - ------------------------------- - - procedure Number_Fraction_Or_Z_Fill is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Z_Fill; - - ----------------------- - -- Optional_RHS_Sign -- - ----------------------- - - procedure Optional_RHS_Sign is - begin - if At_End then - return; - end if; - - case Look is - when '+' | '-' => - Pic.Sign_Position := Index; - Skip; - return; - - when 'C' | 'c' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'C'; - Skip; - - if Look = 'R' or else Look = 'r' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'R'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when 'D' | 'd' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'D'; - Skip; - - if Look = 'B' or else Look = 'b' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'B'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when '>' => - if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then - Pic.Second_Sign := Index; - Skip; - - else - raise Picture_Error; - end if; - - when others => - return; - end case; - end Optional_RHS_Sign; - - ------------- - -- Picture -- - ------------- - - -- Note that Picture can be called in either State - - -- It will set state to Valid only if a 9 is encountered or floating - -- currency is called. - - procedure Picture is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Leading_Dollar; - return; - - when '#' => - Leading_Pound; - return; - - when '9' => - Computed_BWZ := False; - Set_State (Okay); - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - Trailing_Currency; - return; - - when others => - return; - end case; - end loop; - end Picture; - - --------------------- - -- Picture_Bracket -- - --------------------- - - procedure Picture_Bracket is - begin - Pic.Sign_Position := Index; - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '<'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Bracket - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Set_State (Okay); -- "<<>" is enough. - Floating_Bracket; - Trailing_Currency; - Trailing_Bracket; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Trailing_Bracket; - Set_State (Okay); - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - Trailing_Bracket; - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Picture_Bracket; - - ------------------- - -- Picture_Minus -- - ------------------- - - procedure Picture_Minus is - begin - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '-'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Minus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "-- " is enough - Floating_Minus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - - -- Can't have Z and a floating sign - - if State = Okay then - Set_State (Reject); - end if; - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Minus; - - ------------------ - -- Picture_Plus -- - ------------------ - - procedure Picture_Plus is - begin - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '+'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Plus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "++" is enough - Floating_Plus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - if State = Okay then - Set_State (Reject); - end if; - - -- Can't have Z and a floating sign - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - -- '+Z' is acceptable - - Set_State (Okay); - - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Plus; - - -------------------- - -- Picture_String -- - -------------------- - - procedure Picture_String is - begin - while Is_Insert loop - Skip; - end loop; - - case Look is - when '$' | '#' => - Picture; - Optional_RHS_Sign; - - when '+' => - Picture_Plus; - - when '-' => - Picture_Minus; - - when '<' => - Picture_Bracket; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '*' => - Star_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '9' | '.' | 'V' | 'v' => - Number; - Trailing_Currency; - Optional_RHS_Sign; - - when others => - raise Picture_Error; - end case; - - -- Blank when zero either if the PIC does not contain a '9' or if - -- requested by the user and no '*'. - - Pic.Blank_When_Zero := - (Computed_BWZ or else Pic.Blank_When_Zero) - and then not Pic.Star_Fill; - - -- Star fill if '*' and no '9' - - Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; - - if not At_End then - Set_State (Reject); - end if; - end Picture_String; - - --------------- - -- Set_State -- - --------------- - - procedure Set_State (L : Legality) is - begin - State := L; - end Set_State; - - ---------- - -- Skip -- - ---------- - - procedure Skip is - begin - Index := Index + 1; - end Skip; - - ---------------------- - -- Star_Suppression -- - ---------------------- - - procedure Star_Suppression is - begin - Pic.Floater := '*'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - - -- Even a single * is a valid picture - - Pic.Star_Fill := True; - Skip; -- Known * - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Star_Fill; - return; - - when '#' | '$' => - Trailing_Currency; - Set_State (Okay); - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Star_Suppression; - - ---------------------- - -- Trailing_Bracket -- - ---------------------- - - procedure Trailing_Bracket is - begin - if Look = '>' then - Pic.Second_Sign := Index; - Skip; - else - raise Picture_Error; - end if; - end Trailing_Bracket; - - ----------------------- - -- Trailing_Currency -- - ----------------------- - - procedure Trailing_Currency is - begin - if At_End then - return; - end if; - - if Look = '$' then - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Skip; - - else - while not At_End and then Look = '#' loop - if Pic.Start_Currency = Invalid_Position then - Pic.Start_Currency := Index; - end if; - - Pic.End_Currency := Index; - Skip; - end loop; - end if; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - end Trailing_Currency; - - ---------------------- - -- Zero_Suppression -- - ---------------------- - - procedure Zero_Suppression is - begin - Pic.Floater := 'Z'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; -- Known Z - - loop - -- Even a single Z is a valid picture - - if At_End then - Set_State (Okay); - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Set_State (Okay); - Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Z_Fill; - return; - - when '#' | '$' => - Trailing_Currency; - Set_State (Okay); - return; - - when others => - return; - end case; - end loop; - end Zero_Suppression; - - -- Start of processing for Precalculate - - begin - Picture_String; - - if State = Reject then - raise Picture_Error; - end if; - - exception - - when Constraint_Error => - - -- To deal with special cases like null strings - - raise Picture_Error; - end Precalculate; - - ---------------- - -- To_Picture -- - ---------------- - - function To_Picture - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Picture - is - Result : Picture; - - begin - declare - Item : constant String := Expand (Pic_String); - - begin - Result.Contents.Picture := (Item'Length, Item); - Result.Contents.Original_BWZ := Blank_When_Zero; - Result.Contents.Blank_When_Zero := Blank_When_Zero; - Precalculate (Result.Contents); - return Result; - end; - - exception - when others => - raise Picture_Error; - - end To_Picture; - - ------------- - -- To_Wide -- - ------------- - - function To_Wide (C : Character) return Wide_Character is - begin - return Wide_Character'Val (Character'Pos (C)); - end To_Wide; - - ----------- - -- Valid -- - ----------- - - function Valid - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Boolean - is - begin - declare - Expanded_Pic : constant String := Expand (Pic_String); - -- Raises Picture_Error if Item not well-formed - - Format_Rec : Format_Record; - - begin - Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); - Format_Rec.Blank_When_Zero := Blank_When_Zero; - Format_Rec.Original_BWZ := Blank_When_Zero; - Precalculate (Format_Rec); - - -- False only if Blank_When_0 is True but the pic string has a '*' - - return not Blank_When_Zero - or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; - end; - - exception - when others => return False; - end Valid; - -end Ada.Wide_Text_IO.Editing; diff --git a/gcc/ada/a-wtedit.ads b/gcc/ada/a-wtedit.ads deleted file mode 100644 index edc17c5..0000000 --- a/gcc/ada/a-wtedit.ads +++ /dev/null @@ -1,197 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . E D I T I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Wide_Text_IO.Editing is - - type Picture is private; - - function Valid - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Boolean; - - function To_Picture - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Picture; - - function Pic_String (Pic : Picture) return String; - function Blank_When_Zero (Pic : Picture) return Boolean; - - Max_Picture_Length : constant := 64; - - Picture_Error : exception; - - Default_Currency : constant Wide_String := "$"; - Default_Fill : constant Wide_Character := ' '; - Default_Separator : constant Wide_Character := ','; - Default_Radix_Mark : constant Wide_Character := '.'; - - generic - type Num is delta <> digits <>; - Default_Currency : Wide_String := - Wide_Text_IO.Editing.Default_Currency; - Default_Fill : Wide_Character := - Wide_Text_IO.Editing.Default_Fill; - Default_Separator : Wide_Character := - Wide_Text_IO.Editing.Default_Separator; - Default_Radix_Mark : Wide_Character := - Wide_Text_IO.Editing.Default_Radix_Mark; - - package Decimal_Output is - - function Length - (Pic : Picture; - Currency : Wide_String := Default_Currency) return Natural; - - function Valid - (Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency) return Boolean; - - function Image - (Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark) return Wide_String; - - procedure Put - (File : File_Type; - Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark); - - procedure Put - (Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark); - - procedure Put - (To : out Wide_String; - Item : Num; - Pic : Picture; - Currency : Wide_String := Default_Currency; - Fill : Wide_Character := Default_Fill; - Separator : Wide_Character := Default_Separator; - Radix_Mark : Wide_Character := Default_Radix_Mark); - - end Decimal_Output; - -private - MAX_PICSIZE : constant := 50; - MAX_MONEYSIZE : constant := 10; - Invalid_Position : constant := -1; - - subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; - - type Picture_Record (Length : Pic_Index := 0) is record - Expanded : String (1 .. Length); - end record; - - type Format_Record is record - Picture : Picture_Record; - -- Read only - - Blank_When_Zero : Boolean; - -- Read/write - - Original_BWZ : Boolean; - - -- The following components get written - - Star_Fill : Boolean := False; - - Radix_Position : Integer := Invalid_Position; - - Sign_Position, - Second_Sign : Integer := Invalid_Position; - - Start_Float, - End_Float : Integer := Invalid_Position; - - Start_Currency, - End_Currency : Integer := Invalid_Position; - - Max_Leading_Digits : Integer := 0; - - Max_Trailing_Digits : Integer := 0; - - Max_Currency_Digits : Integer := 0; - - Floater : Wide_Character := '!'; - -- Initialized to illegal value - - end record; - - type Picture is record - Contents : Format_Record; - end record; - - type Number_Attributes is record - Negative : Boolean := False; - - Has_Fraction : Boolean := False; - - Start_Of_Int, - End_Of_Int, - Start_Of_Fraction, - End_Of_Fraction : Integer := Invalid_Position; -- invalid value - end record; - - function Parse_Number_String (Str : String) return Number_Attributes; - -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no - -- trailing blanks...) - - procedure Precalculate (Pic : in out Format_Record); - -- Precalculates fields from the user supplied data - - function Format_Number - (Pic : Format_Record; - Number : String; - Currency_Symbol : Wide_String; - Fill_Character : Wide_Character; - Separator_Character : Wide_Character; - Radix_Point : Wide_Character) return Wide_String; - -- Formats number according to Pic - - function Expand (Picture : String) return String; - -end Ada.Wide_Text_IO.Editing; diff --git a/gcc/ada/a-wtenau.adb b/gcc/ada/a-wtenau.adb deleted file mode 100644 index 709703e..0000000 --- a/gcc/ada/a-wtenau.adb +++ /dev/null @@ -1,349 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.WCh_Con; use System.WCh_Con; - -package body Ada.Wide_Text_IO.Enumeration_Aux is - - subtype TFT is Ada.Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Store_Char - (WC : Wide_Character; - Buf : out Wide_String; - Ptr : in out Integer); - -- Store a single character in buffer, checking for overflow - - -- These definitions replace the ones in Ada.Characters.Handling, which - -- do not seem to work for some strange not understood reason ??? at - -- least in the OS/2 version. - - function To_Lower (C : Character) return Character; - - ------------------ - -- Get_Enum_Lit -- - ------------------ - - procedure Get_Enum_Lit - (File : File_Type; - Buf : out Wide_String; - Buflen : out Natural) - is - ch : int; - WC : Wide_Character; - - begin - Buflen := 0; - Load_Skip (TFT (File)); - ch := Nextc (TFT (File)); - - -- Character literal case. If the initial character is a quote, then - -- we read as far as we can without backup (see ACVC test CE3905L) - - if ch = Character'Pos (''') then - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - ch := Nextc (TFT (File)); - - if ch = LM or else ch = EOF then - return; - end if; - - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - ch := Nextc (TFT (File)); - - if ch /= Character'Pos (''') then - return; - end if; - - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - -- Similarly for identifiers, read as far as we can, in particular, - -- do read a trailing underscore (again see ACVC test CE3905L to - -- understand why we do this, although it seems somewhat peculiar). - - else - -- Identifier must start with a letter. Any wide character value - -- outside the normal Latin-1 range counts as a letter for this. - - if ch < 255 and then not Is_Letter (Character'Val (ch)) then - return; - end if; - - -- If we do have a letter, loop through the characters quitting on - -- the first non-identifier character (note that this includes the - -- cases of hitting a line mark or page mark). - - loop - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - ch := Nextc (TFT (File)); - - exit when ch = EOF; - - if ch = Character'Pos ('_') then - exit when Buf (Buflen) = '_'; - - elsif ch = Character'Pos (ASCII.ESC) then - null; - - elsif File.WC_Method in WC_Upper_Half_Encoding_Method - and then ch > 127 - then - null; - - else - exit when not Is_Letter (Character'Val (ch)) - and then - not Is_Digit (Character'Val (ch)); - end if; - end loop; - end if; - end Get_Enum_Lit; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_String; - Width : Field; - Set : Type_Set) - is - Actual_Width : constant Integer := - Integer'Max (Integer (Width), Item'Length); - - begin - Check_On_One_Line (TFT (File), Actual_Width); - - if Set = Lower_Case and then Item (Item'First) /= ''' then - declare - Iteml : Wide_String (Item'First .. Item'Last); - - begin - for J in Item'Range loop - if Is_Character (Item (J)) then - Iteml (J) := - To_Wide_Character (To_Lower (To_Character (Item (J)))); - else - Iteml (J) := Item (J); - end if; - end loop; - - Put (File, Iteml); - end; - - else - Put (File, Item); - end if; - - for J in 1 .. Actual_Width - Item'Length loop - Put (File, ' '); - end loop; - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out Wide_String; - Item : Wide_String; - Set : Type_Set) - is - Ptr : Natural; - - begin - if Item'Length > To'Length then - raise Layout_Error; - - else - Ptr := To'First; - for J in Item'Range loop - if Set = Lower_Case - and then Item (Item'First) /= ''' - and then Is_Character (Item (J)) - then - To (Ptr) := - To_Wide_Character (To_Lower (To_Character (Item (J)))); - else - To (Ptr) := Item (J); - end if; - - Ptr := Ptr + 1; - end loop; - - while Ptr <= To'Last loop - To (Ptr) := ' '; - Ptr := Ptr + 1; - end loop; - end if; - end Puts; - - ------------------- - -- Scan_Enum_Lit -- - ------------------- - - procedure Scan_Enum_Lit - (From : Wide_String; - Start : out Natural; - Stop : out Natural) - is - WC : Wide_Character; - - -- Processing for Scan_Enum_Lit - - begin - Start := From'First; - - loop - if Start > From'Last then - raise End_Error; - - elsif Is_Character (From (Start)) - and then not Is_Blank (To_Character (From (Start))) - then - exit; - - else - Start := Start + 1; - end if; - end loop; - - -- Character literal case. If the initial character is a quote, then - -- we read as far as we can without backup (see ACVC test CE3905L - -- which is for the analogous case for reading from a file). - - if From (Start) = ''' then - Stop := Start; - - if Stop = From'Last then - raise Data_Error; - else - Stop := Stop + 1; - end if; - - if From (Stop) in ' ' .. '~' - or else From (Stop) >= Wide_Character'Val (16#80#) - then - if Stop = From'Last then - raise Data_Error; - else - Stop := Stop + 1; - - if From (Stop) = ''' then - return; - end if; - end if; - end if; - - raise Data_Error; - - -- Similarly for identifiers, read as far as we can, in particular, - -- do read a trailing underscore (again see ACVC test CE3905L to - -- understand why we do this, although it seems somewhat peculiar). - - else - -- Identifier must start with a letter, any wide character outside - -- the normal Latin-1 range is considered a letter for this test. - - if Is_Character (From (Start)) - and then not Is_Letter (To_Character (From (Start))) - then - raise Data_Error; - end if; - - -- If we do have a letter, loop through the characters quitting on - -- the first non-identifier character (note that this includes the - -- cases of hitting a line mark or page mark). - - Stop := Start + 1; - while Stop < From'Last loop - WC := From (Stop + 1); - - exit when - Is_Character (WC) - and then - not Is_Letter (To_Character (WC)) - and then - (WC /= '_' or else From (Stop - 1) = '_'); - - Stop := Stop + 1; - end loop; - end if; - - end Scan_Enum_Lit; - - ---------------- - -- Store_Char -- - ---------------- - - procedure Store_Char - (WC : Wide_Character; - Buf : out Wide_String; - Ptr : in out Integer) - is - begin - if Ptr = Buf'Last then - raise Data_Error; - else - Ptr := Ptr + 1; - Buf (Ptr) := WC; - end if; - end Store_Char; - - -------------- - -- To_Lower -- - -------------- - - function To_Lower (C : Character) return Character is - begin - if C in 'A' .. 'Z' then - return Character'Val (Character'Pos (C) + 32); - else - return C; - end if; - end To_Lower; - -end Ada.Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-wtenau.ads b/gcc/ada/a-wtenau.ads deleted file mode 100644 index 05fc9d7..0000000 --- a/gcc/ada/a-wtenau.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Text_IO.Enumeration_IO --- that are shared among separate instantiations. - -private package Ada.Wide_Text_IO.Enumeration_Aux is - - procedure Get_Enum_Lit - (File : File_Type; - Buf : out Wide_String; - Buflen : out Natural); - -- Reads an enumeration literal value from the file, folds to upper case, - -- and stores the result in Buf, setting Buflen to the number of stored - -- characters (Buf has a lower bound of 1). If more than Buflen characters - -- are present in the literal, Data_Error is raised. - - procedure Scan_Enum_Lit - (From : Wide_String; - Start : out Natural; - Stop : out Natural); - -- Scans an enumeration literal at the start of From, skipping any leading - -- spaces. Sets Start to the first character, Stop to the last character. - -- Raises End_Error if no enumeration literal is found. - - procedure Put - (File : File_Type; - Item : Wide_String; - Width : Field; - Set : Type_Set); - -- Outputs the enumeration literal image stored in Item to the given File, - -- using the given Width and Set parameters (Item is always in upper case). - - procedure Puts - (To : out Wide_String; - Item : Wide_String; - Set : Type_Set); - -- Stores the enumeration literal image stored in Item to the string To, - -- padding with trailing spaces if necessary to fill To. Set is used to - -end Ada.Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-wtenio.adb b/gcc/ada/a-wtenio.adb deleted file mode 100644 index c5dea39..0000000 --- a/gcc/ada/a-wtenio.adb +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Enumeration_Aux; - -package body Ada.Wide_Text_IO.Enumeration_IO is - - package Aux renames Ada.Wide_Text_IO.Enumeration_Aux; - - --------- - -- Get -- - --------- - - procedure Get (File : File_Type; Item : out Enum) is - Buf : Wide_String (1 .. Enum'Width); - Buflen : Natural; - begin - Aux.Get_Enum_Lit (File, Buf, Buflen); - Item := Enum'Wide_Value (Buf (1 .. Buflen)); - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get (Item : out Enum) is - begin - Get (Current_Input, Item); - end Get; - - procedure Get - (From : Wide_String; - Item : out Enum; - Last : out Positive) - is - Start : Natural; - begin - Aux.Scan_Enum_Lit (From, Start, Last); - Item := Enum'Wide_Value (From (Start .. Last)); - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting) - is - Image : constant Wide_String := Enum'Wide_Image (Item); - begin - Aux.Put (File, Image, Width, Set); - end Put; - - procedure Put - (Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting) - is - begin - Put (Current_Output, Item, Width, Set); - end Put; - - procedure Put - (To : out Wide_String; - Item : Enum; - Set : Type_Set := Default_Setting) - is - Image : constant Wide_String := Enum'Wide_Image (Item); - begin - Aux.Puts (To, Image, Set); - end Put; - -end Ada.Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-wtenio.ads b/gcc/ada/a-wtenio.ads deleted file mode 100644 index f0a1c0b..0000000 --- a/gcc/ada/a-wtenio.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Text_IO.Enumeration_IO is a subpackage --- of Wide_Text_IO. In GNAT we make it a child package to avoid loading the --- necessary code if Enumeration_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Enum is (<>); - -package Ada.Wide_Text_IO.Enumeration_IO is - - Default_Width : Field := 0; - Default_Setting : Type_Set := Upper_Case; - - procedure Get (File : File_Type; Item : out Enum); - procedure Get (Item : out Enum); - - procedure Put - (File : File_Type; - Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting); - - procedure Put - (Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting); - - procedure Get - (From : Wide_String; - Item : out Enum; - Last : out Positive); - - procedure Put - (To : out Wide_String; - Item : Enum; - Set : Type_Set := Default_Setting); - -end Ada.Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-wtfiio.adb b/gcc/ada/a-wtfiio.adb deleted file mode 100644 index c8f5473..0000000 --- a/gcc/ada/a-wtfiio.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Float_Aux; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Text_IO.Fixed_IO is - - subtype TFT is Ada.Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - Aux.Get (TFT (File), Long_Long_Float (Item), Width); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - Aux.Gets (S, Long_Long_Float (Item), Last); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - procedure Put - (To : out Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); - - for J in S'Range loop - To (J) := Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-wtfiio.ads b/gcc/ada/a-wtfiio.ads deleted file mode 100644 index 939229e..0000000 --- a/gcc/ada/a-wtfiio.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Text_IO.Fixed_IO is a subpackage of --- Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Fixed_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is delta <>; - -package Ada.Wide_Text_IO.Fixed_IO is - - Default_Fore : Field := Num'Fore; - Default_Aft : Field := Num'Aft; - Default_Exp : Field := 0; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-wtflau.adb b/gcc/ada/a-wtflau.adb deleted file mode 100644 index 718ec66..0000000 --- a/gcc/ada/a-wtflau.adb +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . F L O A T _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; - -with System.Img_Real; use System.Img_Real; -with System.Val_Real; use System.Val_Real; - -package body Ada.Wide_Text_IO.Float_Aux is - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Long_Long_Float; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - end if; - - Item := Scan_Real (Buf, Ptr'Access, Stop); - - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get; - - ---------- - -- Gets -- - ---------- - - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Real (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets; - - --------------- - -- Load_Real -- - --------------- - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Loaded : Boolean; - - begin - -- Skip initial blanks and load possible sign - - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - -- Case of .nnnn - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Otherwise must have digits to start - - else - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - - -- Case of nnn#.xxx# - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '#', ':'); - - -- Case of nnn#xxx.[xxx]# or nnn#xxx# - - else - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - end if; - - -- As usual, it seems strange to allow mixed base characters, - -- but that is what ACVC tests expect, see CE3804M, case (3). - - Load (File, Buf, Ptr, '#', ':'); - end if; - - -- Case of nnn.[nnn] or nnn - - else - -- Prevent the potential processing of '.' in cases where the - -- initial digits have a trailing underscore. - - if Buf (Ptr) = '_' then - return; - end if; - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr); - end if; - end if; - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end Load_Real; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out String; - Item : Long_Long_Float; - Aft : Field; - Exp : Field) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); - - if Ptr > To'Length then - raise Layout_Error; - - else - for J in 1 .. Ptr loop - To (To'Last - Ptr + J) := Buf (J); - end loop; - - for J in To'First .. To'Last - Ptr loop - To (J) := ' '; - end loop; - end if; - end Puts; - -end Ada.Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/a-wtflau.ads b/gcc/ada/a-wtflau.ads deleted file mode 100644 index 96d03d3..0000000 --- a/gcc/ada/a-wtflau.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . F L O A T _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Text_IO.Float_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Float_IO itself, --- except that generic parameter Num has been replaced by Long_Long_Float, --- and the default parameters have been removed because they are supplied --- explicitly by the calls from within the generic template. This package --- is also used by Ada.Wide_Text_IO.Fixed_IO, Ada.Wide_Text_IO.Decimal_IO. - -private package Ada.Wide_Text_IO.Float_Aux is - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- real literal value from the input file into Buf, starting at Ptr + 1. - - procedure Get - (File : File_Type; - Item : out Long_Long_Float; - Width : Field); - - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive); - - procedure Put - (File : File_Type; - Item : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field); - - procedure Puts - (To : out String; - Item : Long_Long_Float; - Aft : Field; - Exp : Field); - -end Ada.Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/a-wtflio.adb b/gcc/ada/a-wtflio.adb deleted file mode 100644 index af34e94..0000000 --- a/gcc/ada/a-wtflio.adb +++ /dev/null @@ -1,127 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . F L O A T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Float_Aux; - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Text_IO.Float_IO is - - subtype TFT is Ada.Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - Aux.Get (TFT (File), Long_Long_Float (Item), Width); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - Aux.Gets (S, Long_Long_Float (Item), Last); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - procedure Put - (To : out Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); - - for J in S'Range loop - To (J) := Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-wtflio.ads b/gcc/ada/a-wtflio.ads deleted file mode 100644 index 445ad26..0000000 --- a/gcc/ada/a-wtflio.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . F L O A T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Text_IO.Float_IO is a subpackage of --- Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Float_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is digits <>; - -package Ada.Wide_Text_IO.Float_IO is - - Default_Fore : Field := 2; - Default_Aft : Field := Num'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-wtgeau.adb b/gcc/ada/a-wtgeau.adb deleted file mode 100644 index 7e27773..0000000 --- a/gcc/ada/a-wtgeau.adb +++ /dev/null @@ -1,528 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . G E N E R I C _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; - -package body Ada.Wide_Text_IO.Generic_Aux is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - subtype AP is FCB.AFCB_Ptr; - - ------------------------ - -- Check_End_Of_Field -- - ------------------------ - - procedure Check_End_Of_Field - (Buf : String; - Stop : Integer; - Ptr : Integer; - Width : Field) - is - begin - if Ptr > Stop then - return; - - elsif Width = 0 then - raise Data_Error; - - else - for J in Ptr .. Stop loop - if not Is_Blank (Buf (J)) then - raise Data_Error; - end if; - end loop; - end if; - end Check_End_Of_Field; - - ----------------------- - -- Check_On_One_Line -- - ----------------------- - - procedure Check_On_One_Line - (File : File_Type; - Length : Integer) - is - begin - FIO.Check_Write_Status (AP (File)); - - if File.Line_Length /= 0 then - if Count (Length) > File.Line_Length then - raise Layout_Error; - elsif File.Col + Count (Length) > File.Line_Length + 1 then - New_Line (File); - end if; - end if; - end Check_On_One_Line; - - -------------- - -- Is_Blank -- - -------------- - - function Is_Blank (C : Character) return Boolean is - begin - return C = ' ' or else C = ASCII.HT; - end Is_Blank; - - ---------- - -- Load -- - ---------- - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character; - Loaded : out Boolean) - is - ch : int; - - begin - if File.Before_Wide_Character then - Loaded := False; - return; - - else - ch := Getc (File); - - if ch = Character'Pos (Char) then - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - else - Ungetc (ch, File); - Loaded := False; - end if; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character) - is - ch : int; - - begin - if File.Before_Wide_Character then - null; - - else - ch := Getc (File); - - if ch = Character'Pos (Char) then - Store_Char (File, ch, Buf, Ptr); - else - Ungetc (ch, File); - end if; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character; - Loaded : out Boolean) - is - ch : int; - - begin - if File.Before_Wide_Character then - Loaded := False; - return; - - else - ch := Getc (File); - - if ch = Character'Pos (Char1) - or else ch = Character'Pos (Char2) - then - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - else - Ungetc (ch, File); - Loaded := False; - end if; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character) - is - ch : int; - - begin - if File.Before_Wide_Character then - null; - - else - ch := Getc (File); - - if ch = Character'Pos (Char1) - or else ch = Character'Pos (Char2) - then - Store_Char (File, ch, Buf, Ptr); - else - Ungetc (ch, File); - end if; - end if; - end Load; - - ----------------- - -- Load_Digits -- - ----------------- - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean) - is - ch : int; - After_Digit : Boolean; - - begin - if File.Before_Wide_Character then - Loaded := False; - return; - - else - ch := Getc (File); - - if ch not in Character'Pos ('0') .. Character'Pos ('9') then - Loaded := False; - - else - Loaded := True; - After_Digit := True; - - loop - Store_Char (File, ch, Buf, Ptr); - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - end loop; - end if; - - Ungetc (ch, File); - end if; - end Load_Digits; - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer) - is - ch : int; - After_Digit : Boolean; - - begin - if File.Before_Wide_Character then - return; - - else - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - loop - Store_Char (File, ch, Buf, Ptr); - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - end loop; - end if; - - Ungetc (ch, File); - end if; - end Load_Digits; - - -------------------------- - -- Load_Extended_Digits -- - -------------------------- - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean) - is - ch : int; - After_Digit : Boolean := False; - - begin - if File.Before_Wide_Character then - Loaded := False; - return; - - else - Loaded := False; - - loop - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') - or else - ch in Character'Pos ('a') .. Character'Pos ('f') - or else - ch in Character'Pos ('A') .. Character'Pos ('F') - then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - end loop; - - Ungetc (ch, File); - end if; - end Load_Extended_Digits; - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer) - is - Junk : Boolean; - pragma Unreferenced (Junk); - begin - Load_Extended_Digits (File, Buf, Ptr, Junk); - end Load_Extended_Digits; - - --------------- - -- Load_Skip -- - --------------- - - procedure Load_Skip (File : File_Type) is - C : Character; - - begin - FIO.Check_Read_Status (AP (File)); - - -- We need to explicitly test for the case of being before a wide - -- character (greater than 16#7F#). Since no such character can - -- ever legitimately be a valid numeric character, we can - -- immediately signal Data_Error. - - if File.Before_Wide_Character then - raise Data_Error; - end if; - - -- Otherwise loop till we find a non-blank character (note that as - -- usual in Wide_Text_IO, blank includes horizontal tab). Note that - -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately. - - loop - Get_Character (File, C); - exit when not Is_Blank (C); - end loop; - - Ungetc (Character'Pos (C), File); - File.Col := File.Col - 1; - end Load_Skip; - - ---------------- - -- Load_Width -- - ---------------- - - procedure Load_Width - (File : File_Type; - Width : Field; - Buf : out String; - Ptr : in out Integer) - is - ch : int; - WC : Wide_Character; - - Bad_Wide_C : Boolean := False; - -- Set True if one of the characters read is not in range of type - -- Character. This is always a Data_Error, but we do not signal it - -- right away, since we have to read the full number of characters. - - begin - FIO.Check_Read_Status (AP (File)); - - -- If we are immediately before a line mark, then we have no characters. - -- This is always a data error, so we may as well raise it right away. - - if File.Before_LM then - raise Data_Error; - - else - for J in 1 .. Width loop - if File.Before_Wide_Character then - Bad_Wide_C := True; - Store_Char (File, 0, Buf, Ptr); - File.Before_Wide_Character := False; - - else - ch := Getc (File); - - if ch = EOF then - exit; - - elsif ch = LM then - Ungetc (ch, File); - exit; - - else - WC := Get_Wide_Char (Character'Val (ch), File); - ch := Wide_Character'Pos (WC); - - if ch > 255 then - Bad_Wide_C := True; - ch := 0; - end if; - - Store_Char (File, ch, Buf, Ptr); - end if; - end if; - end loop; - - if Bad_Wide_C then - raise Data_Error; - end if; - end if; - end Load_Width; - - -------------- - -- Put_Item -- - -------------- - - procedure Put_Item (File : File_Type; Str : String) is - begin - Check_On_One_Line (File, Str'Length); - - for J in Str'Range loop - Put (File, Wide_Character'Val (Character'Pos (Str (J)))); - end loop; - end Put_Item; - - ---------------- - -- Store_Char -- - ---------------- - - procedure Store_Char - (File : File_Type; - ch : Integer; - Buf : out String; - Ptr : in out Integer) - is - begin - File.Col := File.Col + 1; - - if Ptr = Buf'Last then - raise Data_Error; - else - Ptr := Ptr + 1; - Buf (Ptr) := Character'Val (ch); - end if; - end Store_Char; - - ----------------- - -- String_Skip -- - ----------------- - - procedure String_Skip (Str : String; Ptr : out Integer) is - begin - -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. - -- It's too much trouble to make this silly case work, so we just raise - -- Program_Error with an appropriate message. We raise Program_Error - -- rather than Constraint_Error because we don't want this case to be - -- converted to Data_Error. - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - -- Normal case where Str'Last < Positive'Last - - Ptr := Str'First; - - loop - if Ptr > Str'Last then - raise End_Error; - - elsif not Is_Blank (Str (Ptr)) then - return; - - else - Ptr := Ptr + 1; - end if; - end loop; - end String_Skip; - - ------------ - -- Ungetc -- - ------------ - - procedure Ungetc (ch : int; File : File_Type) is - begin - if ch /= EOF then - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - end Ungetc; - -end Ada.Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/a-wtgeau.ads b/gcc/ada/a-wtgeau.ads deleted file mode 100644 index fabd543..0000000 --- a/gcc/ada/a-wtgeau.ads +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . G E N E R I C _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a set of auxiliary routines used by Wide_Text_IO --- generic children, including for reading and writing numeric strings. - --- Note: although this is the Wide version of the package, the interface --- here is still in terms of Character and String rather than Wide_Character --- and Wide_String, since all numeric strings are composed entirely of --- characters in the range of type Standard.Character, and the basic --- conversion routines work with Character rather than Wide_Character. - -package Ada.Wide_Text_IO.Generic_Aux is - - -- Note: for all the Load routines, File indicates the file to be read, - -- Buf is the string into which data is stored, Ptr is the index of the - -- last character stored so far, and is updated if additional characters - -- are stored. Data_Error is raised if the input overflows Buf. The only - -- Load routines that do a file status check are Load_Skip and Load_Width - -- so one of these two routines must be called first. - - procedure Check_End_Of_Field - (Buf : String; - Stop : Integer; - Ptr : Integer; - Width : Field); - -- This routine is used after doing a get operations on a numeric value. - -- Buf is the string being scanned, and Stop is the last character of - -- the field being scanned. Ptr is as set by the call to the scan routine - -- that scanned out the numeric value, i.e. it points one past the last - -- character scanned, and Width is the width parameter from the Get call. - -- - -- There are two cases, if Width is non-zero, then a check is made that - -- the remainder of the field is all blanks. If Width is zero, then it - -- means that the scan routine scanned out only part of the field. We - -- have already scanned out the field that the ACVC tests seem to expect - -- us to read (even if it does not follow the syntax of the type being - -- scanned, e.g. allowing negative exponents in integers, and underscores - -- at the end of the string), so we just raise Data_Error. - - procedure Check_On_One_Line (File : File_Type; Length : Integer); - -- Check to see if item of length Integer characters can fit on - -- current line. Call New_Line if not, first checking that the - -- line length can accommodate Length characters, raise Layout_Error - -- if item is too large for a single line. - - function Is_Blank (C : Character) return Boolean; - -- Determines if C is a blank (space or tab) - - procedure Load_Width - (File : File_Type; - Width : Field; - Buf : out String; - Ptr : in out Integer); - -- Loads exactly Width characters, unless a line mark is encountered first - - procedure Load_Skip (File : File_Type); - -- Skips leading blanks and line and page marks, if the end of file is - -- read without finding a non-blank character, then End_Error is raised. - -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character; - Loaded : out Boolean); - -- If next character is Char, loads it, otherwise no characters are loaded - -- Loaded is set to indicate whether or not the character was found. - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character); - -- Same as above, but no indication if character is loaded - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character; - Loaded : out Boolean); - -- If next character is Char1 or Char2, loads it, otherwise no characters - -- are loaded. Loaded is set to indicate whether or not one of the two - -- characters was found. - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character); - -- Same as above, but no indication if character is loaded - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean); - -- Loads a sequence of zero or more decimal digits. Loaded is set if - -- at least one digit is loaded. - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer); - -- Same as above, but no indication if character is loaded - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean); - -- Like Load_Digits, but also allows extended digits a-f and A-F - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer); - -- Same as above, but no indication if character is loaded - - procedure Put_Item (File : File_Type; Str : String); - -- This routine is like Wide_Text_IO.Put, except that it checks for - -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used - -- for all output of numeric values and of enumeration values. Note that - -- the buffer is of type String. Put_Item deals with converting this to - -- Wide_Characters as required. - - procedure Store_Char - (File : File_Type; - ch : Integer; - Buf : out String; - Ptr : in out Integer); - -- Store a single character in buffer, checking for overflow and - -- adjusting the column number in the file to reflect the fact - -- that a character has been acquired from the input stream. - -- The pos value of the character to store is in ch on entry. - - procedure String_Skip (Str : String; Ptr : out Integer); - -- Used in the Get from string procedures to skip leading blanks in the - -- string. Ptr is set to the index of the first non-blank. If the string - -- is all blanks, then the excption End_Error is raised, Note that blank - -- is defined as a space or horizontal tab (RM A.10.6(5)). - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- an end of file (EOF) is ignored. - -private - pragma Inline (Is_Blank); - -end Ada.Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/a-wtinau.adb b/gcc/ada/a-wtinau.adb deleted file mode 100644 index 8b4b1e6..0000000 --- a/gcc/ada/a-wtinau.adb +++ /dev/null @@ -1,295 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Int; use System.Img_Int; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLI; use System.Img_LLI; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Int; use System.Val_Int; -with System.Val_LLI; use System.Val_LLI; - -package body Ada.Wide_Text_IO.Integer_Aux is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- integer literal value from the input file into Buf, starting at Ptr + 1. - -- On return, Ptr is set to the last character stored. - - ------------- - -- Get_Int -- - ------------- - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Int; - - ------------- - -- Get_LLI -- - ------------- - - procedure Get_LLI - (File : File_Type; - Item : out Long_Long_Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLI; - - -------------- - -- Gets_Int -- - -------------- - - procedure Gets_Int - (From : String; - Item : out Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Int; - - -------------- - -- Gets_LLI -- - -------------- - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLI; - - ------------------ - -- Load_Integer -- - ------------------ - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Integer; - - ------------- - -- Put_Int -- - ------------- - - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Int; - - ------------- - -- Put_LLI -- - ------------- - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLI; - - -------------- - -- Puts_Int -- - -------------- - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Int; - - -------------- - -- Puts_LLI -- - -------------- - - procedure Puts_LLI - (To : out String; - Item : Long_Long_Integer; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLI; - -end Ada.Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/a-wtinau.ads b/gcc/ada/a-wtinau.ads deleted file mode 100644 index 7c7927d..0000000 --- a/gcc/ada/a-wtinau.ads +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Text_IO.Integer_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Integer_IO itself, --- except that the generic parameter Num has been replaced by Integer or --- Long_Long_Integer, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. - -private package Ada.Wide_Text_IO.Integer_Aux is - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field); - - procedure Get_LLI - (File : File_Type; - Item : out Long_Long_Integer; - Width : Field); - - procedure Gets_Int - (From : String; - Item : out Integer; - Last : out Positive); - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive); - - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base); - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base); - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base); - - procedure Puts_LLI - (To : out String; - Item : Long_Long_Integer; - Base : Number_Base); - -end Ada.Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/a-wtinio.adb b/gcc/ada/a-wtinio.adb deleted file mode 100644 index 507145f..0000000 --- a/gcc/ada/a-wtinio.adb +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Integer_Aux; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Text_IO.Integer_IO is - - Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; - -- Throughout this generic body, we distinguish between the case where type - -- Integer is acceptable, and where a Long_Long_Integer is needed. This - -- Boolean is used to test for these cases and since it is a constant, only - -- code for the relevant case will be included in the instance. - - subtype TFT is Ada.Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Text_IO.Integer_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - if Need_LLI then - Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); - else - Aux.Get_Int (TFT (File), Integer (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - if Need_LLI then - Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); - else - Aux.Gets_Int (S, Integer (Item), Last); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Need_LLI then - Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); - else - Aux.Put_Int (TFT (File), Integer (Item), Width, Base); - end if; - end Put; - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - Put (Current_Output, Item, Width, Base); - end Put; - - procedure Put - (To : out Wide_String; - Item : Num; - Base : Number_Base := Default_Base) - is - S : String (To'First .. To'Last); - - begin - if Need_LLI then - Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); - else - Aux.Puts_Int (S, Integer (Item), Base); - end if; - - for J in S'Range loop - To (J) := Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-wtinio.ads b/gcc/ada/a-wtinio.ads deleted file mode 100644 index c2821db..0000000 --- a/gcc/ada/a-wtinio.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Text_IO.Integer_IO is a subpackage --- of Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Integer_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is range <>; - -package Ada.Wide_Text_IO.Integer_IO is - - Default_Width : Field := Num'Width; - Default_Base : Number_Base := 10; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_String; - Item : Num; - Base : Number_Base := Default_Base); - -end Ada.Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-wtmoau.adb b/gcc/ada/a-wtmoau.adb deleted file mode 100644 index 25c72ec..0000000 --- a/gcc/ada/a-wtmoau.adb +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Uns; use System.Img_Uns; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLU; use System.Img_LLU; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Uns; use System.Val_Uns; -with System.Val_LLU; use System.Val_LLU; - -package body Ada.Wide_Text_IO.Modular_Aux is - - use System.Unsigned_Types; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- modular literal value from the input file into Buf, starting at Ptr + 1. - -- Ptr is left set to the last character stored. - - ------------- - -- Get_LLU -- - ------------- - - procedure Get_LLU - (File : File_Type; - Item : out Long_Long_Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLU; - - ------------- - -- Get_Uns -- - ------------- - - procedure Get_Uns - (File : File_Type; - Item : out Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Uns; - - -------------- - -- Gets_LLU -- - -------------- - - procedure Gets_LLU - (From : String; - Item : out Long_Long_Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLU; - - -------------- - -- Gets_Uns -- - -------------- - - procedure Gets_Uns - (From : String; - Item : out Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Uns; - - ------------------ - -- Load_Modular -- - ------------------ - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - - -- Note: it is a bit strange to allow a minus sign here, but it seems - -- consistent with the general behavior expected by the ACVC tests - -- which is to scan past junk and then signal data error, see ACVC - -- test CE3704F, case (6), which is for signed integer exponents, - -- which seems a similar case. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants - -- for the signed case, and there seems no good reason to treat - -- exponents differently for the signed and unsigned cases. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Modular; - - ------------- - -- Put_LLU -- - ------------- - - procedure Put_LLU - (File : File_Type; - Item : Long_Long_Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLU; - - ------------- - -- Put_Uns -- - ------------- - - procedure Put_Uns - (File : File_Type; - Item : Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Uns; - - -------------- - -- Puts_LLU -- - -------------- - - procedure Puts_LLU - (To : out String; - Item : Long_Long_Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLU; - - -------------- - -- Puts_Uns -- - -------------- - - procedure Puts_Uns - (To : out String; - Item : Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Uns; - -end Ada.Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/a-wtmoau.ads b/gcc/ada/a-wtmoau.ads deleted file mode 100644 index a9c2bdc..0000000 --- a/gcc/ada/a-wtmoau.ads +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Text_IO.Modular_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Modular_IO itself, --- except that the generic parameter Num has been replaced by Unsigned or --- Long_Long_Unsigned, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. - -with System.Unsigned_Types; - -private package Ada.Wide_Text_IO.Modular_Aux is - - package U renames System.Unsigned_Types; - - procedure Get_Uns - (File : File_Type; - Item : out U.Unsigned; - Width : Field); - - procedure Get_LLU - (File : File_Type; - Item : out U.Long_Long_Unsigned; - Width : Field); - - procedure Gets_Uns - (From : String; - Item : out U.Unsigned; - Last : out Positive); - - procedure Gets_LLU - (From : String; - Item : out U.Long_Long_Unsigned; - Last : out Positive); - - procedure Put_Uns - (File : File_Type; - Item : U.Unsigned; - Width : Field; - Base : Number_Base); - - procedure Put_LLU - (File : File_Type; - Item : U.Long_Long_Unsigned; - Width : Field; - Base : Number_Base); - - procedure Puts_Uns - (To : out String; - Item : U.Unsigned; - Base : Number_Base); - - procedure Puts_LLU - (To : out String; - Item : U.Long_Long_Unsigned; - Base : Number_Base); - -end Ada.Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/a-wtmoio.adb b/gcc/ada/a-wtmoio.adb deleted file mode 100644 index ce31ed5..0000000 --- a/gcc/ada/a-wtmoio.adb +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO.Modular_Aux; - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Text_IO.Modular_IO is - - subtype TFT is Ada.Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Text_IO.Modular_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); - else - Aux.Get_Uns (TFT (File), Unsigned (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - if Num'Size > Unsigned'Size then - Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); - else - Aux.Gets_Uns (S, Unsigned (Item), Last); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); - else - Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); - end if; - end Put; - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - Put (Current_Output, Item, Width, Base); - end Put; - - procedure Put - (To : out Wide_String; - Item : Num; - Base : Number_Base := Default_Base) - is - S : String (To'First .. To'Last); - - begin - if Num'Size > Unsigned'Size then - Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); - else - Aux.Puts_Uns (S, Unsigned (Item), Base); - end if; - - for J in S'Range loop - To (J) := Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-wtmoio.ads b/gcc/ada/a-wtmoio.ads deleted file mode 100644 index 9ea1620..0000000 --- a/gcc/ada/a-wtmoio.ads +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Text_IO.Modular_IO is a subpackage --- of Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Modular_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is mod <>; - -package Ada.Wide_Text_IO.Modular_IO is - - Default_Width : Field := Num'Width; - Default_Base : Number_Base := 10; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Get - (From : Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_String; - Item : Num; - Base : Number_Base := Default_Base); - -end Ada.Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-wttest.adb b/gcc/ada/a-wttest.adb deleted file mode 100644 index ed64bdd..0000000 --- a/gcc/ada/a-wttest.adb +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.File_IO; - -package body Ada.Wide_Text_IO.Text_Streams is - - ------------ - -- Stream -- - ------------ - - function Stream (File : File_Type) return Stream_Access is - begin - System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); - return Stream_Access (File); - end Stream; - -end Ada.Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-wttest.ads b/gcc/ada/a-wttest.ads deleted file mode 100644 index 7c180ff..0000000 --- a/gcc/ada/a-wttest.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Streams; - -package Ada.Wide_Text_IO.Text_Streams is - - type Stream_Access is access all Streams.Root_Stream_Type'Class; - - function Stream (File : File_Type) return Stream_Access; - -end Ada.Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-wwboio.adb b/gcc/ada/a-wwboio.adb deleted file mode 100644 index 37a101d..0000000 --- a/gcc/ada/a-wwboio.adb +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . W I D E _ B O U N D E D _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; -with Ada.Unchecked_Deallocation; - -package body Ada.Wide_Text_IO.Wide_Bounded_IO is - - type Wide_String_Access is access all Wide_String; - - procedure Free (WSA : in out Wide_String_Access); - -- Perform an unchecked deallocation of a non-null string - - ---------- - -- Free -- - ---------- - - procedure Free (WSA : in out Wide_String_Access) is - Null_Wide_String : constant Wide_String := ""; - - procedure Deallocate is - new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); - - begin - -- Do not try to free statically allocated null string - - if WSA.all /= Null_Wide_String then - Deallocate (WSA); - end if; - end Free; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Wide_Bounded.Bounded_Wide_String is - begin - return Wide_Bounded.To_Bounded_Wide_String (Get_Line); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line - (File : File_Type) return Wide_Bounded.Bounded_Wide_String - is - begin - return Wide_Bounded.To_Bounded_Wide_String (Get_Line (File)); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (Item : out Wide_Bounded.Bounded_Wide_String) - is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_String_Access; - Str2 : Wide_String_Access; - - begin - Get_Line (Buffer, Last); - Str1 := new Wide_String'(Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); - Free (Str1); - Str1 := Str2; - end loop; - - Item := Wide_Bounded.To_Bounded_Wide_String (Str1.all); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (File : File_Type; - Item : out Wide_Bounded.Bounded_Wide_String) - is - Buffer : Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_String_Access; - Str2 : Wide_String_Access; - - begin - Get_Line (File, Buffer, Last); - Str1 := new Wide_String'(Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); - Free (Str1); - Str1 := Str2; - end loop; - - Item := Wide_Bounded.To_Bounded_Wide_String (Str1.all); - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put - (Item : Wide_Bounded.Bounded_Wide_String) - is - begin - Put (Wide_Bounded.To_Wide_String (Item)); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_Bounded.Bounded_Wide_String) - is - begin - Put (File, Wide_Bounded.To_Wide_String (Item)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (Item : Wide_Bounded.Bounded_Wide_String) - is - begin - Put_Line (Wide_Bounded.To_Wide_String (Item)); - end Put_Line; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (File : File_Type; - Item : Wide_Bounded.Bounded_Wide_String) - is - begin - Put_Line (File, Wide_Bounded.To_Wide_String (Item)); - end Put_Line; - -end Ada.Wide_Text_IO.Wide_Bounded_IO; diff --git a/gcc/ada/a-wwboio.ads b/gcc/ada/a-wwboio.ads deleted file mode 100644 index 2b8dd2a..0000000 --- a/gcc/ada/a-wwboio.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . W I D E _ B O U N D E D _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Bounded; - -generic - with package Wide_Bounded is - new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (<>); - -package Ada.Wide_Text_IO.Wide_Bounded_IO is - - function Get_Line return Wide_Bounded.Bounded_Wide_String; - - function Get_Line - (File : File_Type) return Wide_Bounded.Bounded_Wide_String; - - procedure Get_Line - (Item : out Wide_Bounded.Bounded_Wide_String); - - procedure Get_Line - (File : File_Type; - Item : out Wide_Bounded.Bounded_Wide_String); - - procedure Put - (Item : Wide_Bounded.Bounded_Wide_String); - - procedure Put - (File : File_Type; - Item : Wide_Bounded.Bounded_Wide_String); - - procedure Put_Line - (Item : Wide_Bounded.Bounded_Wide_String); - - procedure Put_Line - (File : File_Type; - Item : Wide_Bounded.Bounded_Wide_String); - -end Ada.Wide_Text_IO.Wide_Bounded_IO; diff --git a/gcc/ada/a-wwunio.ads b/gcc/ada/a-wwunio.ads deleted file mode 100644 index de044c5..0000000 --- a/gcc/ada/a-wwunio.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ T E X T _ I O . W I D E _ U N B O U N D E D _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Note: historically GNAT provided these subprograms as a child of the --- package Ada.Strings.Wide_Unbounded. So we implement this new Ada 2005 --- package by renaming the subprograms in that child. This is a more --- straightforward implementation anyway, since we need access to the --- internal representation of Unbounded_Wide_String. - -with Ada.Strings.Wide_Unbounded; -with Ada.Strings.Wide_Unbounded.Wide_Text_IO; - -package Ada.Wide_Text_IO.Wide_Unbounded_IO is - - procedure Put - (File : File_Type; - Item : Strings.Wide_Unbounded.Unbounded_Wide_String) - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; - - procedure Put - (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; - - procedure Put_Line - (File : Wide_Text_IO.File_Type; - Item : Strings.Wide_Unbounded.Unbounded_Wide_String) - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; - - procedure Put_Line - (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; - - function Get_Line - (File : File_Type) return Strings.Wide_Unbounded.Unbounded_Wide_String - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; - - function Get_Line return Strings.Wide_Unbounded.Unbounded_Wide_String - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; - - procedure Get_Line - (File : File_Type; - Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; - - procedure Get_Line - (Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) - renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; - -end Ada.Wide_Text_IO.Wide_Unbounded_IO; diff --git a/gcc/ada/a-zchara.ads b/gcc/ada/a-zchara.ads deleted file mode 100644 index d8d5f9f..0000000 --- a/gcc/ada/a-zchara.ads +++ /dev/null @@ -1,18 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ C H A R A C T E R S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Wide_Wide_Characters is - pragma Pure; -end Ada.Wide_Wide_Characters; diff --git a/gcc/ada/a-zchhan.adb b/gcc/ada/a-zchhan.adb deleted file mode 100644 index 54db3ba..0000000 --- a/gcc/ada/a-zchhan.adb +++ /dev/null @@ -1,187 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ C H A R A C T E R S . H A N D L I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Characters.Unicode; use Ada.Wide_Wide_Characters.Unicode; - -package body Ada.Wide_Wide_Characters.Handling is - - --------------------- - -- Is_Alphanumeric -- - --------------------- - - function Is_Alphanumeric (Item : Wide_Wide_Character) return Boolean is - begin - return Is_Letter (Item) or else Is_Digit (Item); - end Is_Alphanumeric; - - ---------------- - -- Is_Control -- - ---------------- - - function Is_Control (Item : Wide_Wide_Character) return Boolean is - begin - return Get_Category (Item) = Cc; - end Is_Control; - - -------------- - -- Is_Digit -- - -------------- - - function Is_Digit (Item : Wide_Wide_Character) return Boolean - renames Ada.Wide_Wide_Characters.Unicode.Is_Digit; - - ---------------- - -- Is_Graphic -- - ---------------- - - function Is_Graphic (Item : Wide_Wide_Character) return Boolean is - begin - return not Is_Non_Graphic (Item); - end Is_Graphic; - - -------------------------- - -- Is_Hexadecimal_Digit -- - -------------------------- - - function Is_Hexadecimal_Digit (Item : Wide_Wide_Character) return Boolean is - begin - return Is_Digit (Item) - or else Item in 'A' .. 'F' - or else Item in 'a' .. 'f'; - end Is_Hexadecimal_Digit; - - --------------- - -- Is_Letter -- - --------------- - - function Is_Letter (Item : Wide_Wide_Character) return Boolean - renames Ada.Wide_Wide_Characters.Unicode.Is_Letter; - - ------------------------ - -- Is_Line_Terminator -- - ------------------------ - - function Is_Line_Terminator (Item : Wide_Wide_Character) return Boolean - renames Ada.Wide_Wide_Characters.Unicode.Is_Line_Terminator; - - -------------- - -- Is_Lower -- - -------------- - - function Is_Lower (Item : Wide_Wide_Character) return Boolean is - begin - return Get_Category (Item) = Ll; - end Is_Lower; - - ------------- - -- Is_Mark -- - ------------- - - function Is_Mark (Item : Wide_Wide_Character) return Boolean - renames Ada.Wide_Wide_Characters.Unicode.Is_Mark; - - --------------------- - -- Is_Other_Format -- - --------------------- - - function Is_Other_Format (Item : Wide_Wide_Character) return Boolean - renames Ada.Wide_Wide_Characters.Unicode.Is_Other; - - ------------------------------ - -- Is_Punctuation_Connector -- - ------------------------------ - - function Is_Punctuation_Connector - (Item : Wide_Wide_Character) return Boolean - renames Ada.Wide_Wide_Characters.Unicode.Is_Punctuation; - - -------------- - -- Is_Space -- - -------------- - - function Is_Space (Item : Wide_Wide_Character) return Boolean - renames Ada.Wide_Wide_Characters.Unicode.Is_Space; - - ---------------- - -- Is_Special -- - ---------------- - - function Is_Special (Item : Wide_Wide_Character) return Boolean is - begin - return Is_Graphic (Item) and then not Is_Alphanumeric (Item); - end Is_Special; - - -------------- - -- Is_Upper -- - -------------- - - function Is_Upper (Item : Wide_Wide_Character) return Boolean is - begin - return Get_Category (Item) = Lu; - end Is_Upper; - - -------------- - -- To_Lower -- - -------------- - - function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character - renames Ada.Wide_Wide_Characters.Unicode.To_Lower_Case; - - function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String is - Result : Wide_Wide_String (Item'Range); - - begin - for J in Result'Range loop - Result (J) := To_Lower (Item (J)); - end loop; - - return Result; - end To_Lower; - - -------------- - -- To_Upper -- - -------------- - - function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character - renames Ada.Wide_Wide_Characters.Unicode.To_Upper_Case; - - function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String is - Result : Wide_Wide_String (Item'Range); - - begin - for J in Result'Range loop - Result (J) := To_Upper (Item (J)); - end loop; - - return Result; - end To_Upper; - -end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/a-zchhan.ads b/gcc/ada/a-zchhan.ads deleted file mode 100644 index 354452b..0000000 --- a/gcc/ada/a-zchhan.ads +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ C H A R A C T E R S . H A N D L I N G -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Wide_Wide_Characters.Handling is - pragma Pure; - -- This package is clearly intended to be Pure, by analogy with the - -- base Ada.Characters.Handling package. The version in the RM does - -- not yet have this pragma, but that is a clear omission. This will - -- be fixed in a future version of AI05-0266-1. - - function Is_Control (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Control); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as other_control, otherwise returns false. - - function Is_Letter (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Letter); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as letter_uppercase, letter_lowercase, letter_titlecase, - -- letter_modifier, letter_other, or number_letter. Otherwise returns - -- false. - - function Is_Lower (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Lower); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as letter_lowercase, otherwise returns false. - - function Is_Upper (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Upper); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as letter_uppercase, otherwise returns false. - - function Is_Digit (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Digit); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as number_decimal, otherwise returns false. - - function Is_Decimal_Digit (Item : Wide_Wide_Character) return Boolean - renames Is_Digit; - - function Is_Hexadecimal_Digit (Item : Wide_Wide_Character) return Boolean; - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as number_decimal, or is in the range 'A' .. 'F' or - -- 'a' .. 'f', otherwise returns false. - - function Is_Alphanumeric (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Alphanumeric); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as letter_uppercase, letter_lowercase, letter_titlecase, - -- letter_modifier, letter_other, number_letter, or number_decimal. - -- Otherwise returns false. - - function Is_Special (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Special); - -- Returns True if the Wide_Wide_Character designated by Item - -- is categorized as graphic_character, but not categorized as - -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, - -- letter_other, number_letter, or number_decimal. Otherwise returns false. - - function Is_Line_Terminator (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Line_Terminator); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as separator_line or separator_paragraph, or if Item is a - -- conventional line terminator character (CR, LF, VT, or FF). Otherwise - -- returns false. - - function Is_Mark (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Mark); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as mark_non_spacing or mark_spacing_combining, otherwise - -- returns false. - - function Is_Other_Format (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Other_Format); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as other_format, otherwise returns false. - - function Is_Punctuation_Connector - (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Punctuation_Connector); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as punctuation_connector, otherwise returns false. - - function Is_Space (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Space); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as separator_space, otherwise returns false. - - function Is_Graphic (Item : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Graphic); - -- Returns True if the Wide_Wide_Character designated by Item is - -- categorized as graphic_character, otherwise returns false. - - function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character; - pragma Inline (To_Lower); - -- Returns the Simple Lowercase Mapping of the Wide_Wide_Character - -- designated by Item. If the Simple Lowercase Mapping does not exist for - -- the Wide_Wide_Character designated by Item, then the value of Item is - -- returned. - - function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String; - -- Returns the result of applying the To_Lower Wide_Wide_Character to - -- Wide_Wide_Character conversion to each element of the Wide_Wide_String - -- designated by Item. The result is the null Wide_Wide_String if the value - -- of the formal parameter is the null Wide_Wide_String. - - function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character; - pragma Inline (To_Upper); - -- Returns the Simple Uppercase Mapping of the Wide_Wide_Character - -- designated by Item. If the Simple Uppercase Mapping does not exist for - -- the Wide_Wide_Character designated by Item, then the value of Item is - -- returned. - - function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String; - -- Returns the result of applying the To_Upper Wide_Wide_Character to - -- Wide_Wide_Character conversion to each element of the Wide_Wide_String - -- designated by Item. The result is the null Wide_Wide_String if the value - -- of the formal parameter is the null Wide_Wide_String. - -end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/a-zchuni.adb b/gcc/ada/a-zchuni.adb deleted file mode 100644 index faa5c10..0000000 --- a/gcc/ada/a-zchuni.adb +++ /dev/null @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ C H A R A C T E R T S . U N I C O D E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Ada.Wide_Wide_Characters.Unicode is - - package G renames System.UTF_32; - - ------------------ - -- Get_Category -- - ------------------ - - function Get_Category (U : Wide_Wide_Character) return Category is - begin - return Category (G.Get_Category (Wide_Wide_Character'Pos (U))); - end Get_Category; - - -------------- - -- Is_Digit -- - -------------- - - function Is_Digit (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Digit (Wide_Wide_Character'Pos (U)); - end Is_Digit; - - function Is_Digit (C : Category) return Boolean is - begin - return G.Is_UTF_32_Digit (G.Category (C)); - end Is_Digit; - - --------------- - -- Is_Letter -- - --------------- - - function Is_Letter (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Letter (Wide_Wide_Character'Pos (U)); - end Is_Letter; - - function Is_Letter (C : Category) return Boolean is - begin - return G.Is_UTF_32_Letter (G.Category (C)); - end Is_Letter; - - ------------------------ - -- Is_Line_Terminator -- - ------------------------ - - function Is_Line_Terminator (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Line_Terminator (Wide_Wide_Character'Pos (U)); - end Is_Line_Terminator; - - ------------- - -- Is_Mark -- - ------------- - - function Is_Mark (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Mark (Wide_Wide_Character'Pos (U)); - end Is_Mark; - - function Is_Mark (C : Category) return Boolean is - begin - return G.Is_UTF_32_Mark (G.Category (C)); - end Is_Mark; - - -------------------- - -- Is_Non_Graphic -- - -------------------- - - function Is_Non_Graphic (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Non_Graphic (Wide_Wide_Character'Pos (U)); - end Is_Non_Graphic; - - function Is_Non_Graphic (C : Category) return Boolean is - begin - return G.Is_UTF_32_Non_Graphic (G.Category (C)); - end Is_Non_Graphic; - - -------------- - -- Is_Other -- - -------------- - - function Is_Other (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Other (Wide_Wide_Character'Pos (U)); - end Is_Other; - - function Is_Other (C : Category) return Boolean is - begin - return G.Is_UTF_32_Other (G.Category (C)); - end Is_Other; - - -------------------- - -- Is_Punctuation -- - -------------------- - - function Is_Punctuation (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Punctuation (Wide_Wide_Character'Pos (U)); - end Is_Punctuation; - - function Is_Punctuation (C : Category) return Boolean is - begin - return G.Is_UTF_32_Punctuation (G.Category (C)); - end Is_Punctuation; - - -------------- - -- Is_Space -- - -------------- - - function Is_Space (U : Wide_Wide_Character) return Boolean is - begin - return G.Is_UTF_32_Space (Wide_Wide_Character'Pos (U)); - end Is_Space; - - function Is_Space (C : Category) return Boolean is - begin - return G.Is_UTF_32_Space (G.Category (C)); - end Is_Space; - - ------------------- - -- To_Lower_Case -- - ------------------- - - function To_Lower_Case - (U : Wide_Wide_Character) return Wide_Wide_Character - is - begin - return - Wide_Wide_Character'Val - (G.UTF_32_To_Lower_Case (Wide_Wide_Character'Pos (U))); - end To_Lower_Case; - - ------------------- - -- To_Upper_Case -- - ------------------- - - function To_Upper_Case - (U : Wide_Wide_Character) return Wide_Wide_Character - is - begin - return - Wide_Wide_Character'Val - (G.UTF_32_To_Upper_Case (Wide_Wide_Character'Pos (U))); - end To_Upper_Case; - -end Ada.Wide_Wide_Characters.Unicode; diff --git a/gcc/ada/a-zchuni.ads b/gcc/ada/a-zchuni.ads deleted file mode 100644 index 98989d6..0000000 --- a/gcc/ada/a-zchuni.ads +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ C H A R A C T E R T S . U N I C O D E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Unicode categorization routines for Wide_Wide_Character - -with System.UTF_32; - -package Ada.Wide_Wide_Characters.Unicode is - pragma Pure; - - -- The following type defines the categories from the unicode definitions. - -- The one addition we make is Fe, which represents the characters FFFE - -- and FFFF in any of the planes. - - type Category is new System.UTF_32.Category; - -- Cc Other, Control - -- Cf Other, Format - -- Cn Other, Not Assigned - -- Co Other, Private Use - -- Cs Other, Surrogate - -- Ll Letter, Lowercase - -- Lm Letter, Modifier - -- Lo Letter, Other - -- Lt Letter, Titlecase - -- Lu Letter, Uppercase - -- Mc Mark, Spacing Combining - -- Me Mark, Enclosing - -- Mn Mark, Nonspacing - -- Nd Number, Decimal Digit - -- Nl Number, Letter - -- No Number, Other - -- Pc Punctuation, Connector - -- Pd Punctuation, Dash - -- Pe Punctuation, Close - -- Pf Punctuation, Final quote - -- Pi Punctuation, Initial quote - -- Po Punctuation, Other - -- Ps Punctuation, Open - -- Sc Symbol, Currency - -- Sk Symbol, Modifier - -- Sm Symbol, Math - -- So Symbol, Other - -- Zl Separator, Line - -- Zp Separator, Paragraph - -- Zs Separator, Space - -- Fe relative position FFFE/FFFF in plane - - function Get_Category (U : Wide_Wide_Character) return Category; - pragma Inline (Get_Category); - -- Given a Wide_Wide_Character, returns corresponding Category, or Cn if - -- the code does not have an assigned unicode category. - - -- The following functions perform category tests corresponding to lexical - -- classes defined in the Ada standard. There are two interfaces for each - -- function. The second takes a Category (e.g. returned by Get_Category). - -- The first takes a Wide_Wide_Character. The form taking the - -- Wide_Wide_Character is typically more efficient than calling - -- Get_Category, but if several different tests are to be performed on the - -- same code, it is more efficient to use Get_Category to get the category, - -- then test the resulting category. - - function Is_Letter (U : Wide_Wide_Character) return Boolean; - function Is_Letter (C : Category) return Boolean; - pragma Inline (Is_Letter); - -- Returns true iff U is a letter that can be used to start an identifier, - -- or if C is one of the corresponding categories, which are the following: - -- Letter, Uppercase (Lu) - -- Letter, Lowercase (Ll) - -- Letter, Titlecase (Lt) - -- Letter, Modifier (Lm) - -- Letter, Other (Lo) - -- Number, Letter (Nl) - - function Is_Digit (U : Wide_Wide_Character) return Boolean; - function Is_Digit (C : Category) return Boolean; - pragma Inline (Is_Digit); - -- Returns true iff U is a digit that can be used to extend an identifer, - -- or if C is one of the corresponding categories, which are the following: - -- Number, Decimal_Digit (Nd) - - function Is_Line_Terminator (U : Wide_Wide_Character) return Boolean; - pragma Inline (Is_Line_Terminator); - -- Returns true iff U is an allowed line terminator for source programs, - -- if U is in the category Zp (Separator, Paragaph), or Zs (Separator, - -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). - -- There is no category version for this function, since the set of - -- characters does not correspond to a set of Unicode categories. - - function Is_Mark (U : Wide_Wide_Character) return Boolean; - function Is_Mark (C : Category) return Boolean; - pragma Inline (Is_Mark); - -- Returns true iff U is a mark character which can be used to extend an - -- identifier, or if C is one of the corresponding categories, which are - -- the following: - -- Mark, Non-Spacing (Mn) - -- Mark, Spacing Combining (Mc) - - function Is_Other (U : Wide_Wide_Character) return Boolean; - function Is_Other (C : Category) return Boolean; - pragma Inline (Is_Other); - -- Returns true iff U is an other format character, which means that it - -- can be used to extend an identifier, but is ignored for the purposes of - -- matching of identiers, or if C is one of the corresponding categories, - -- which are the following: - -- Other, Format (Cf) - - function Is_Punctuation (U : Wide_Wide_Character) return Boolean; - function Is_Punctuation (C : Category) return Boolean; - pragma Inline (Is_Punctuation); - -- Returns true iff U is a punctuation character that can be used to - -- separate pices of an identifier, or if C is one of the corresponding - -- categories, which are the following: - -- Punctuation, Connector (Pc) - - function Is_Space (U : Wide_Wide_Character) return Boolean; - function Is_Space (C : Category) return Boolean; - pragma Inline (Is_Space); - -- Returns true iff U is considered a space to be ignored, or if C is one - -- of the corresponding categories, which are the following: - -- Separator, Space (Zs) - - function Is_Non_Graphic (U : Wide_Wide_Character) return Boolean; - function Is_Non_Graphic (C : Category) return Boolean; - pragma Inline (Is_Non_Graphic); - -- Returns true iff U is considered to be a non-graphic character, or if C - -- is one of the corresponding categories, which are the following: - -- Other, Control (Cc) - -- Other, Private Use (Co) - -- Other, Surrogate (Cs) - -- Separator, Line (Zl) - -- Separator, Paragraph (Zp) - -- FFFE or FFFF positions in any plane (Fe) - -- - -- Note that the Ada category format effector is subsumed by the above - -- list of Unicode categories. - -- - -- Note that Other, Unassiged (Cn) is quite deliberately not included - -- in the list of categories above. This means that should any of these - -- code positions be defined in future with graphic characters they will - -- be allowed without a need to change implementations or the standard. - -- - -- Note that Other, Format (Cf) is also quite deliberately not included - -- in the list of categories above. This means that these characters can - -- be included in character and string literals. - - -- The following function is used to fold to upper case, as required by - -- the Ada 2005 standard rules for identifier case folding. Two - -- identifiers are equivalent if they are identical after folding all - -- letters to upper case using this routine. A fold to lower routine is - -- also provided. - - function To_Lower_Case - (U : Wide_Wide_Character) return Wide_Wide_Character; - pragma Inline (To_Lower_Case); - -- If U represents an upper case letter, returns the corresponding lower - -- case letter, otherwise U is returned unchanged. The folding is locale - -- independent as defined by documents referenced in the note in section - -- 1 of ISO/IEC 10646:2003 - - function To_Upper_Case - (U : Wide_Wide_Character) return Wide_Wide_Character; - pragma Inline (To_Upper_Case); - -- If U represents a lower case letter, returns the corresponding upper - -- case letter, otherwise U is returned unchanged. The folding is locale - -- independent as defined by documents referenced in the note in section - -- 1 of ISO/IEC 10646:2003 - -end Ada.Wide_Wide_Characters.Unicode; diff --git a/gcc/ada/a-zrstfi.adb b/gcc/ada/a-zrstfi.adb deleted file mode 100644 index 77dbc8b..0000000 --- a/gcc/ada/a-zrstfi.adb +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - ------------------------------------------------- --- Ada.Wide_Wide_Text_IO.Reset_Standard_Files -- ------------------------------------------------- - -procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files is -begin - Ada.Wide_Wide_Text_IO.Initialize_Standard_Files; -end Ada.Wide_Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/a-zrstfi.ads b/gcc/ada/a-zrstfi.ads deleted file mode 100644 index ae6592d..0000000 --- a/gcc/ada/a-zrstfi.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 reset routine that resets the standard files used --- by Ada.Wide_Wide_Text_IO. This is useful in systems such as VxWorks where --- Ada.Wide_Wide_Text_IO is elaborated at the program start, but a system --- restart may alter the status of these files, resulting in incorrect --- operation of Wide_Wide_Text_IO (in particular if the standard input file --- is changed to be interactive, then Get_Line may hang looking for an extra --- character after the end of the line. - -procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files; --- Reset standard Wide_Wide_Text_IO files as described above diff --git a/gcc/ada/a-ztcoau.adb b/gcc/ada/a-ztcoau.adb deleted file mode 100644 index d9c365c..0000000 --- a/gcc/ada/a-ztcoau.adb +++ /dev/null @@ -1,202 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; -with Ada.Wide_Wide_Text_IO.Float_Aux; - -with System.Img_Real; use System.Img_Real; - -package body Ada.Wide_Wide_Text_IO.Complex_Aux is - - package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer; - Paren : Boolean := False; - - begin - -- General note for following code, exceptions from the calls - -- to Get for components of the complex value are propagated. - - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); - - for J in Ptr + 1 .. Stop loop - if not Is_Blank (Buf (J)) then - raise Data_Error; - end if; - end loop; - - -- Case of width = 0 - - else - Load_Skip (File); - Ptr := 0; - Load (File, Buf, Ptr, '(', Paren); - Aux.Get (File, ItemR, 0); - Load_Skip (File); - Load (File, Buf, Ptr, ','); - Aux.Get (File, ItemI, 0); - - if Paren then - Load_Skip (File); - Load (File, Buf, Ptr, ')', Paren); - - if not Paren then - raise Data_Error; - end if; - end if; - end if; - end Get; - - ---------- - -- Gets -- - ---------- - - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive) - is - Paren : Boolean; - Pos : Integer; - - begin - String_Skip (From, Pos); - - if From (Pos) = '(' then - Pos := Pos + 1; - Paren := True; - else - Paren := False; - end if; - - Aux.Gets (From (Pos .. From'Last), ItemR, Pos); - - String_Skip (From (Pos + 1 .. From'Last), Pos); - - if From (Pos) = ',' then - Pos := Pos + 1; - end if; - - Aux.Gets (From (Pos .. From'Last), ItemI, Pos); - - if Paren then - String_Skip (From (Pos + 1 .. From'Last), Pos); - - if From (Pos) /= ')' then - raise Data_Error; - end if; - end if; - - Last := Pos; - end Gets; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field) - is - begin - Put (File, '('); - Aux.Put (File, ItemR, Fore, Aft, Exp); - Put (File, ','); - Aux.Put (File, ItemI, Fore, Aft, Exp); - Put (File, ')'); - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Aft : Field; - Exp : Field) - is - I_String : String (1 .. 3 * Field'Last); - R_String : String (1 .. 3 * Field'Last); - - Iptr : Natural; - Rptr : Natural; - - begin - -- Both parts are initially converted with a Fore of 0 - - Rptr := 0; - Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); - Iptr := 0; - Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); - - -- Check room for both parts plus parens plus comma (RM G.1.3(34)) - - if Rptr + Iptr + 3 > To'Length then - raise Layout_Error; - end if; - - -- If there is room, layout result according to (RM G.1.3(31-33)) - - To (To'First) := '('; - To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); - To (To'First + Rptr + 1) := ','; - - To (To'Last) := ')'; - - To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); - - for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop - To (J) := ' '; - end loop; - end Puts; - -end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ztcoau.ads b/gcc/ada/a-ztcoau.ads deleted file mode 100644 index b68c38b..0000000 --- a/gcc/ada/a-ztcoau.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Wide_Text_IO.Complex_IO --- that are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Complex_IO itself, --- except that the generic parameter Complex has been replaced by separate --- real and imaginary values of type Long_Long_Float, and default parameters --- have been removed because they are supplied explicitly by the calls from --- within the generic template. - -package Ada.Wide_Wide_Text_IO.Complex_Aux is - - procedure Get - (File : File_Type; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Width : Field); - - procedure Gets - (From : String; - ItemR : out Long_Long_Float; - ItemI : out Long_Long_Float; - Last : out Positive); - - procedure Put - (File : File_Type; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field); - - procedure Puts - (To : out String; - ItemR : Long_Long_Float; - ItemI : Long_Long_Float; - Aft : Field; - Exp : Field); - -end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/a-ztcoio.adb b/gcc/ada/a-ztcoio.adb deleted file mode 100644 index c5d21a1..0000000 --- a/gcc/ada/a-ztcoio.adb +++ /dev/null @@ -1,159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Complex_Aux; - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -with Ada.Unchecked_Conversion; - -package body Ada.Wide_Wide_Text_IO.Complex_IO is - - package Aux renames Ada.Wide_Wide_Text_IO.Complex_Aux; - - subtype LLF is Long_Long_Float; - -- Type used for calls to routines in Aux - - function TFT is new - Ada.Unchecked_Conversion (File_Type, Ada.Wide_Wide_Text_IO.File_Type); - -- This unchecked conversion is to get around a visibility bug in - -- GNAT version 2.04w. It should be possible to simply use the - -- subtype declared above and do normal checked conversions. - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Complex; - Width : Field := 0) - is - Real_Item : Real'Base; - Imag_Item : Real'Base; - - begin - Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); - Item := (Real_Item, Imag_Item); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Get -- - --------- - - procedure Get - (Item : out Complex; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - --------- - -- Get -- - --------- - - procedure Get - (From : Wide_Wide_String; - Item : out Complex; - Last : out Positive) - is - Real_Item : Real'Base; - Imag_Item : Real'Base; - - S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); - Item := (Real_Item, Imag_Item); - - exception - when Data_Error => raise Constraint_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (To : out Wide_Wide_String; - Item : Complex; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); - - for J in S'Range loop - To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-ztcoio.ads b/gcc/ada/a-ztcoio.ads deleted file mode 100644 index 866fd87..0000000 --- a/gcc/ada/a-ztcoio.ads +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; - -generic - with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); - -package Ada.Wide_Wide_Text_IO.Complex_IO is - - use Complex_Types; - - Default_Fore : Field := 2; - Default_Aft : Field := Real'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Complex; - Width : Field := 0); - - procedure Get - (Item : out Complex; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Complex; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_Wide_String; - Item : out Complex; - Last : out Positive); - - procedure Put - (To : out Wide_Wide_String; - Item : Complex; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/a-ztcstr.adb b/gcc/ada/a-ztcstr.adb deleted file mode 100644 index 7d61d71..0000000 --- a/gcc/ada/a-ztcstr.adb +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; -with Ada.Unchecked_Conversion; - -package body Ada.Wide_Wide_Text_IO.C_Streams is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - - -------------- - -- C_Stream -- - -------------- - - function C_Stream (F : File_Type) return FILEs is - begin - FIO.Check_File_Open (AP (F)); - return F.Stream; - end C_Stream; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : FILEs; - Form : String := ""; - Name : String := "") - is - Dummy_File_Control_Block : Wide_Wide_Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'W', - Creat => False, - Text => True, - C_Stream => C_Stream); - - end Open; - -end Ada.Wide_Wide_Text_IO.C_Streams; diff --git a/gcc/ada/a-ztcstr.ads b/gcc/ada/a-ztcstr.ads deleted file mode 100644 index 75dc89b..0000000 --- a/gcc/ada/a-ztcstr.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface between Ada.Wide_Wide_Text_IO and the --- C streams. This allows sharing of a stream between Ada and C or C++, --- as well as allowing the Ada program to operate directly on the stream. - -with Interfaces.C_Streams; - -package Ada.Wide_Wide_Text_IO.C_Streams is - - package ICS renames Interfaces.C_Streams; - - function C_Stream (F : File_Type) return ICS.FILEs; - -- Obtain stream from existing open file - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - C_Stream : ICS.FILEs; - Form : String := ""; - Name : String := ""); - -- Create new file from existing stream - -end Ada.Wide_Wide_Text_IO.C_Streams; diff --git a/gcc/ada/a-ztdeau.adb b/gcc/ada/a-ztdeau.adb deleted file mode 100644 index 38450fc..0000000 --- a/gcc/ada/a-ztdeau.adb +++ /dev/null @@ -1,263 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; -with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux; - -with System.Img_Dec; use System.Img_Dec; -with System.Img_LLD; use System.Img_LLD; -with System.Val_Dec; use System.Val_Dec; -with System.Val_LLD; use System.Val_LLD; - -package body Ada.Wide_Wide_Text_IO.Decimal_Aux is - - ------------- - -- Get_Dec -- - ------------- - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_Dec; - - ------------- - -- Get_LLD -- - ------------- - - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer; - Stop : Integer := 0; - Item : Long_Long_Integer; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - Ptr := 1; - end if; - - Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - return Item; - end Get_LLD; - - -------------- - -- Gets_Dec -- - -------------- - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer - is - Pos : aliased Integer; - Item : Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; - - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - - end Gets_Dec; - - -------------- - -- Gets_LLD -- - -------------- - - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer - is - Pos : aliased Integer; - Item : Long_Long_Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); - Last.all := Pos - 1; - return Item; - - exception - when Constraint_Error => - Last.all := Pos - 1; - raise Data_Error; - - end Gets_LLD; - - ------------- - -- Put_Dec -- - ------------- - - procedure Put_Dec - (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_Dec; - - ------------- - -- Put_LLD -- - ------------- - - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLD; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - -- Compute Fore, allowing for Aft digits and the decimal dot - - Fore := To'Length - Field'Max (1, Aft) - 1; - - -- Allow for Exp and two more for E+ or E- if exponent present - - if Exp /= 0 then - Fore := Fore - 2 - Exp; - end if; - - -- Make sure we have enough room - - if Fore < 1 then - raise Layout_Error; - end if; - - -- Do the conversion and check length of result - - Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_Dec; - - -------------- - -- Puts_Dec -- - -------------- - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer) - is - Buf : String (1 .. Field'Last); - Fore : Integer; - Ptr : Natural := 0; - - begin - Fore := - (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); - - if Fore < 1 then - raise Layout_Error; - end if; - - Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); - - if Ptr > To'Length then - raise Layout_Error; - else - To := Buf (1 .. Ptr); - end if; - end Puts_LLD; - -end Ada.Wide_Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-ztdeau.ads b/gcc/ada/a-ztdeau.ads deleted file mode 100644 index 9672592..0000000 --- a/gcc/ada/a-ztdeau.ads +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Wide_Text_IO.Decimal_IO --- that are shared among separate instantiations of this package. The --- routines in the package are identical semantically to those declared --- in Wide_Wide_Text_IO, except that default values have been supplied by the --- generic, and the Num parameter has been replaced by Integer or --- Long_Long_Integer, with an additional Scale parameter giving the --- value of Num'Scale. In addition the Get routines return the value --- rather than store it in an Out parameter. - -private package Ada.Wide_Wide_Text_IO.Decimal_Aux is - - function Get_Dec - (File : File_Type; - Width : Field; - Scale : Integer) return Integer; - - function Get_LLD - (File : File_Type; - Width : Field; - Scale : Integer) return Long_Long_Integer; - - function Gets_Dec - (From : String; - Last : not null access Positive; - Scale : Integer) return Integer; - - function Gets_LLD - (From : String; - Last : not null access Positive; - Scale : Integer) return Long_Long_Integer; - - procedure Put_Dec - (File : File_Type; - Item : Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Put_LLD - (File : File_Type; - Item : Long_Long_Integer; - Fore : Field; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Puts_Dec - (To : out String; - Item : Integer; - Aft : Field; - Exp : Field; - Scale : Integer); - - procedure Puts_LLD - (To : out String; - Item : Long_Long_Integer; - Aft : Field; - Exp : Field; - Scale : Integer); - -end Ada.Wide_Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/a-ztdeio.adb b/gcc/ada/a-ztdeio.adb deleted file mode 100644 index 52f8820..0000000 --- a/gcc/ada/a-ztdeio.adb +++ /dev/null @@ -1,164 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Decimal_Aux; - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Wide_Text_IO.Decimal_IO is - - subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux; - - Scale : constant Integer := Num'Scale; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - if Num'Size > Integer'Size then - Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); - else - Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); - end if; - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - if Num'Size > Integer'Size then - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); - else - -- Item := Num'Fixed_Value - -- should write above, but gets assert error ??? - Item := Num - (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - if Num'Size > Integer'Size then - Aux.Put_LLD --- (TFT (File), Long_Long_Integer'Integer_Value (Item), --- ??? - (TFT (File), Long_Long_Integer (Item), - Fore, Aft, Exp, Scale); - else - Aux.Put_Dec --- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); --- ??? - (TFT (File), Integer (Item), Fore, Aft, Exp, Scale); - - end if; - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - if Num'Size > Integer'Size then --- Aux.Puts_LLD --- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); --- ??? - Aux.Puts_LLD - (S, Long_Long_Integer (Item), Aft, Exp, Scale); - else --- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); --- ??? - Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale); - end if; - - for J in S'Range loop - To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-ztdeio.ads b/gcc/ada/a-ztdeio.ads deleted file mode 100644 index efe24da..0000000 --- a/gcc/ada/a-ztdeio.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Wide_Text_IO.Decimal_IO is a subpackage --- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Decimal_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is delta <> digits <>; - -package Ada.Wide_Wide_Text_IO.Decimal_IO is - - Default_Fore : Field := 2; - Default_Aft : Field := Num'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/a-ztedit.adb b/gcc/ada/a-ztedit.adb deleted file mode 100644 index bc759e0..0000000 --- a/gcc/ada/a-ztedit.adb +++ /dev/null @@ -1,2712 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -with Ada.Strings.Wide_Wide_Fixed; - -package body Ada.Wide_Wide_Text_IO.Editing is - - package Strings renames Ada.Strings; - package Strings_Fixed renames Ada.Strings.Fixed; - package Strings_Wide_Wide_Fixed renames Ada.Strings.Wide_Wide_Fixed; - package Wide_Wide_Text_IO renames Ada.Wide_Wide_Text_IO; - - ----------------------- - -- Local_Subprograms -- - ----------------------- - - function To_Wide (C : Character) return Wide_Wide_Character; - pragma Inline (To_Wide); - -- Convert Character to corresponding Wide_Wide_Character - - --------------------- - -- Blank_When_Zero -- - --------------------- - - function Blank_When_Zero (Pic : Picture) return Boolean is - begin - return Pic.Contents.Original_BWZ; - end Blank_When_Zero; - - -------------------- - -- Decimal_Output -- - -------------------- - - package body Decimal_Output is - - ----------- - -- Image -- - ----------- - - function Image - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - return Wide_Wide_String - is - begin - return Format_Number - (Pic.Contents, Num'Image (Item), - Currency, Fill, Separator, Radix_Mark); - end Image; - - ------------ - -- Length -- - ------------ - - function Length - (Pic : Picture; - Currency : Wide_Wide_String := Default_Currency) return Natural - is - Picstr : constant String := Pic_String (Pic); - V_Adjust : Integer := 0; - Cur_Adjust : Integer := 0; - - begin - -- Check if Picstr has 'V' or '$' - - -- If 'V', then length is 1 less than otherwise - - -- If '$', then length is Currency'Length-1 more than otherwise - - -- This should use the string handling package ??? - - for J in Picstr'Range loop - if Picstr (J) = 'V' then - V_Adjust := -1; - - elsif Picstr (J) = '$' then - Cur_Adjust := Currency'Length - 1; - end if; - end loop; - - return Picstr'Length - V_Adjust + Cur_Adjust; - end Length; - - --------- - -- Put -- - --------- - - procedure Put - (File : Wide_Wide_Text_IO.File_Type; - Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - is - begin - Wide_Wide_Text_IO.Put (File, Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - is - begin - Wide_Wide_Text_IO.Put (Image (Item, Pic, - Currency, Fill, Separator, Radix_Mark)); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - is - Result : constant Wide_Wide_String := - Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); - - begin - if Result'Length > To'Length then - raise Wide_Wide_Text_IO.Layout_Error; - else - Strings_Wide_Wide_Fixed.Move (Source => Result, Target => To, - Justify => Strings.Right); - end if; - end Put; - - ----------- - -- Valid -- - ----------- - - function Valid - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency) return Boolean - is - begin - declare - Temp : constant Wide_Wide_String := Image (Item, Pic, Currency); - pragma Warnings (Off, Temp); - begin - return True; - end; - - exception - when Layout_Error => return False; - - end Valid; - end Decimal_Output; - - ------------ - -- Expand -- - ------------ - - function Expand (Picture : String) return String is - Result : String (1 .. MAX_PICSIZE); - Picture_Index : Integer := Picture'First; - Result_Index : Integer := Result'First; - Count : Natural; - Last : Integer; - - begin - if Picture'Length < 1 then - raise Picture_Error; - end if; - - if Picture (Picture'First) = '(' then - raise Picture_Error; - end if; - - loop - case Picture (Picture_Index) is - when '(' => - - -- We now need to scan out the count after a left paren. In - -- the non-wide version we used Integer_IO.Get, but that is - -- not convenient here, since we don't want to drag in normal - -- Text_IO just for this purpose. So we do the scan ourselves, - -- with the normal validity checks. - - Last := Picture_Index + 1; - Count := 0; - - if Picture (Last) not in '0' .. '9' then - raise Picture_Error; - end if; - - Count := Character'Pos (Picture (Last)) - Character'Pos ('0'); - Last := Last + 1; - - loop - if Last > Picture'Last then - raise Picture_Error; - end if; - - if Picture (Last) = '_' then - if Picture (Last - 1) = '_' then - raise Picture_Error; - end if; - - elsif Picture (Last) = ')' then - exit; - - elsif Picture (Last) not in '0' .. '9' then - raise Picture_Error; - - else - Count := Count * 10 - + Character'Pos (Picture (Last)) - - Character'Pos ('0'); - end if; - - Last := Last + 1; - end loop; - - -- In what follows note that one copy of the repeated - -- character has already been made, so a count of one is - -- no-op, and a count of zero erases a character. - - for J in 2 .. Count loop - Result (Result_Index + J - 2) := Picture (Picture_Index - 1); - end loop; - - Result_Index := Result_Index + Count - 1; - - -- Last was a ')' throw it away too - - Picture_Index := Last + 1; - - when ')' => - raise Picture_Error; - - when others => - Result (Result_Index) := Picture (Picture_Index); - Picture_Index := Picture_Index + 1; - Result_Index := Result_Index + 1; - end case; - - exit when Picture_Index > Picture'Last; - end loop; - - return Result (1 .. Result_Index - 1); - - exception - when others => - raise Picture_Error; - end Expand; - - ------------------- - -- Format_Number -- - ------------------- - - function Format_Number - (Pic : Format_Record; - Number : String; - Currency_Symbol : Wide_Wide_String; - Fill_Character : Wide_Wide_Character; - Separator_Character : Wide_Wide_Character; - Radix_Point : Wide_Wide_Character) return Wide_Wide_String - is - Attrs : Number_Attributes := Parse_Number_String (Number); - Position : Integer; - Rounded : String := Number; - - Sign_Position : Integer := Pic.Sign_Position; -- may float. - - Answer : Wide_Wide_String (1 .. Pic.Picture.Length); - Last : Integer; - Currency_Pos : Integer := Pic.Start_Currency; - - Dollar : Boolean := False; - -- Overridden immediately if necessary - - Zero : Boolean := True; - -- Set to False when a non-zero digit is output - - begin - - -- If the picture has fewer decimal places than the number, the image - -- must be rounded according to the usual rules. - - if Attrs.Has_Fraction then - declare - R : constant Integer := - (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) - - Pic.Max_Trailing_Digits; - R_Pos : Integer; - - begin - if R > 0 then - R_Pos := Rounded'Length - R; - - if Rounded (R_Pos + 1) > '4' then - - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - - while R_Pos > 1 loop - if Rounded (R_Pos) = '.' then - R_Pos := R_Pos - 1; - end if; - - if Rounded (R_Pos) /= '9' then - Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); - exit; - else - Rounded (R_Pos) := '0'; - R_Pos := R_Pos - 1; - end if; - end loop; - - -- The rounding may add a digit in front. Either the - -- leading blank or the sign (already captured) can be - -- overwritten. - - if R_Pos = 1 then - Rounded (R_Pos) := '1'; - Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; - end if; - end if; - end if; - end if; - end; - end if; - - for J in Answer'Range loop - Answer (J) := To_Wide (Pic.Picture.Expanded (J)); - end loop; - - if Pic.Start_Currency /= Invalid_Position then - Dollar := Answer (Pic.Start_Currency) = '$'; - end if; - - -- Fix up "direct inserts" outside the playing field. Set up as one - -- loop to do the beginning, one (reverse) loop to do the end. - - Last := 1; - loop - exit when Last = Pic.Start_Float; - exit when Last = Pic.Radix_Position; - exit when Answer (Last) = '9'; - - case Answer (Last) is - when '_' => - Answer (Last) := Separator_Character; - - when 'b' => - Answer (Last) := ' '; - - when others => - null; - end case; - - exit when Last = Answer'Last; - - Last := Last + 1; - end loop; - - -- Now for the end... - - for J in reverse Last .. Answer'Last loop - exit when J = Pic.Radix_Position; - - -- Do this test First, Separator_Character can equal Pic.Floater - - if Answer (J) = Pic.Floater then - exit; - end if; - - case Answer (J) is - when '_' => - Answer (J) := Separator_Character; - - when 'b' => - Answer (J) := ' '; - - when '9' => - exit; - - when others => - null; - end case; - end loop; - - -- Non-floating sign - - if Pic.Start_Currency /= -1 - and then Answer (Pic.Start_Currency) = '#' - and then Pic.Floater /= '#' - then - if Currency_Symbol'Length > - Pic.End_Currency - Pic.Start_Currency + 1 - then - raise Picture_Error; - - elsif Currency_Symbol'Length = - Pic.End_Currency - Pic.Start_Currency + 1 - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - Currency_Symbol; - - elsif Pic.Radix_Position = Invalid_Position - or else Pic.Start_Currency < Pic.Radix_Position - then - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. - Pic.End_Currency) := Currency_Symbol; - - else - Answer (Pic.Start_Currency .. Pic.End_Currency) := - (others => ' '); - Answer (Pic.Start_Currency .. - Pic.Start_Currency + Currency_Symbol'Length - 1) := - Currency_Symbol; - end if; - end if; - - -- Fill in leading digits - - if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > - Pic.Max_Leading_Digits - then - raise Layout_Error; - end if; - - Position := - (if Pic.Radix_Position = Invalid_Position then Answer'Last - else Pic.Radix_Position - 1); - - for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop - while Answer (Position) /= '9' - and then - Answer (Position) /= Pic.Floater - loop - if Answer (Position) = '_' then - Answer (Position) := Separator_Character; - elsif Answer (Position) = 'b' then - Answer (Position) := ' '; - end if; - - Position := Position - 1; - end loop; - - Answer (Position) := To_Wide (Rounded (J)); - - if Rounded (J) /= '0' then - Zero := False; - end if; - - Position := Position - 1; - end loop; - - -- Do lead float - - if Pic.Start_Float = Invalid_Position then - - -- No leading floats, but need to change '9' to '0', '_' to - -- Separator_Character and 'b' to ' '. - - for J in Last .. Position loop - - -- Last set when fixing the "uninteresting" leaders above. - -- Don't duplicate the work. - - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - - end loop; - - elsif Pic.Floater = '<' - or else - Pic.Floater = '+' - or else - Pic.Floater = '-' - then - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Sign_Position := Position; - - elsif Pic.Floater = '$' then - - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := ' '; -- no separator before leftmost digit - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position - 1 loop - Answer (J) := ' '; - end loop; - - Answer (Position) := Pic.Floater; - Currency_Pos := Position; - - elsif Pic.Floater = '*' then - - for J in Pic.End_Float .. Position loop -- May be null range - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := '*'; - end if; - end loop; - - if Position > Pic.End_Float then - Position := Pic.End_Float; - end if; - - for J in Pic.Start_Float .. Position loop - Answer (J) := '*'; - end loop; - - else - if Pic.Floater = '#' then - Currency_Pos := Currency_Symbol'Length; - end if; - - for J in reverse Pic.Start_Float .. Position loop - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'b' | '/' | '0' => - Answer (J) := ' '; - - when '9' => - Answer (J) := '0'; - - when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => - null; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when '_' => - case Pic.Floater is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'b' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos = 0 then - Answer (J) := ' '; - - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos - 1; - end if; - - when others => - null; - end case; - - when others => - null; - end case; - end loop; - - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Layout_Error; - end if; - end if; - - -- Do sign - - if Sign_Position = Invalid_Position then - if Attrs.Negative then - raise Layout_Error; - end if; - - else - if Attrs.Negative then - case Answer (Sign_Position) is - when 'C' | 'D' | '-' => - null; - - when '+' => - Answer (Sign_Position) := '-'; - - when '<' => - Answer (Sign_Position) := '('; - Answer (Pic.Second_Sign) := ')'; - - when others => - raise Picture_Error; - end case; - - else -- positive - - case Answer (Sign_Position) is - when '-' => - Answer (Sign_Position) := ' '; - - when '<' | 'C' | 'D' => - Answer (Sign_Position) := ' '; - Answer (Pic.Second_Sign) := ' '; - - when '+' => - null; - - when others => - raise Picture_Error; - end case; - end if; - end if; - - -- Fill in trailing digits - - if Pic.Max_Trailing_Digits > 0 then - if Attrs.Has_Fraction then - Position := Attrs.Start_Of_Fraction; - Last := Pic.Radix_Position + 1; - - for J in Last .. Answer'Last loop - if Answer (J) = '9' or else Answer (J) = Pic.Floater then - Answer (J) := To_Wide (Rounded (Position)); - - if Rounded (Position) /= '0' then - Zero := False; - end if; - - Position := Position + 1; - Last := J + 1; - - -- Used up fraction but remember place in Answer - - exit when Position > Attrs.End_Of_Fraction; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - end if; - - Last := J + 1; - end loop; - - Position := Last; - - else - Position := Pic.Radix_Position + 1; - end if; - - -- Now fill remaining 9's with zeros and _ with separators - - Last := Answer'Last; - - for J in Position .. Last loop - if Answer (J) = '9' then - Answer (J) := '0'; - - elsif Answer (J) = Pic.Floater then - Answer (J) := '0'; - - elsif Answer (J) = '_' then - Answer (J) := Separator_Character; - - elsif Answer (J) = 'b' then - Answer (J) := ' '; - end if; - end loop; - - Position := Last + 1; - - else - if Pic.Floater = '#' and then Currency_Pos /= 0 then - raise Layout_Error; - end if; - - -- No trailing digits, but now J may need to stick in a currency - -- symbol or sign. - - Position := - (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1 - else Pic.Start_Currency); - end if; - - for J in Position .. Answer'Last loop - if Pic.Start_Currency /= Invalid_Position - and then Answer (Pic.Start_Currency) = '#' - then - Currency_Pos := 1; - end if; - - -- Note: There are some weird cases J can imagine with 'b' or '#' - -- in currency strings where the following code will cause - -- glitches. The trick is to tell when the character in the - -- answer should be checked, and when to look at the original - -- string. Some other time. RIE 11/26/96 ??? - - case Answer (J) is - when '*' => - Answer (J) := Fill_Character; - - when 'b' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - end if; - - when '_' => - case Pic.Floater is - when '*' => - Answer (J) := Fill_Character; - - when 'Z' | 'z' => - Answer (J) := ' '; - - when '#' => - if Currency_Pos > Currency_Symbol'Length then - Answer (J) := ' '; - else - Answer (J) := Currency_Symbol (Currency_Pos); - Currency_Pos := Currency_Pos + 1; - end if; - - when others => - null; - end case; - - when others => - exit; - end case; - end loop; - - -- Now get rid of Blank_when_Zero and complete Star fill - - if Zero and then Pic.Blank_When_Zero then - - -- Value is zero, and blank it - - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position - and then Answer (Pic.Radix_Position) = 'V' - then - Last := Last - 1; - end if; - - return Wide_Wide_String'(1 .. Last => ' '); - - elsif Zero and then Pic.Star_Fill then - Last := Answer'Last; - - if Dollar then - Last := Last - 1 + Currency_Symbol'Length; - end if; - - if Pic.Radix_Position /= Invalid_Position then - - if Answer (Pic.Radix_Position) = 'V' then - Last := Last - 1; - - elsif Dollar then - if Pic.Radix_Position > Pic.Start_Currency then - return - Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); - - else - return - Wide_Wide_String' - (1 .. - Pic.Radix_Position + Currency_Symbol'Length - 2 - => '*') & - Radix_Point & - Wide_Wide_String' - (Pic.Radix_Position + Currency_Symbol'Length .. Last - => '*'); - end if; - - else - return - Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & - Radix_Point & - Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); - end if; - end if; - - return Wide_Wide_String'(1 .. Last => '*'); - end if; - - -- This was once a simple return statement, now there are nine different - -- return cases. Not to mention the five above to deal with zeros. Why - -- not split things out? - - -- Processing the radix and sign expansion separately would require - -- lots of copying--the string and some of its indexes--without - -- really simplifying the logic. The cases are: - - -- 1) Expand $, replace '.' with Radix_Point - -- 2) No currency expansion, replace '.' with Radix_Point - -- 3) Expand $, radix blanked - -- 4) No currency expansion, radix blanked - -- 5) Elide V - -- 6) Expand $, Elide V - -- 7) Elide V, Expand $ (Two cases depending on order.) - -- 8) No radix, expand $ - -- 9) No radix, no currency expansion - - if Pic.Radix_Position /= Invalid_Position then - if Answer (Pic.Radix_Position) = '.' then - Answer (Pic.Radix_Position) := Radix_Point; - - if Dollar then - - -- 1) Expand $, replace '.' with Radix_Point - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 2) No currency expansion, replace '.' with Radix_Point - - return Answer; - end if; - - elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. - if Dollar then - - -- 3) Expand $, radix blanked - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 4) No expansion, radix blanked - - return Answer; - end if; - - -- V cases - - else - if not Dollar then - - -- 5) Elide V - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - elsif Currency_Pos < Pic.Radix_Position then - - -- 6) Expand $, Elide V - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Answer'Last); - - else - -- 7) Elide V, Expand $ - - return Answer (1 .. Pic.Radix_Position - 1) & - Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & - Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - end if; - end if; - - elsif Dollar then - - -- 8) No radix, expand $ - - return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & - Answer (Currency_Pos + 1 .. Answer'Last); - - else - -- 9) No radix, no currency expansion - - return Answer; - end if; - end Format_Number; - - ------------------------- - -- Parse_Number_String -- - ------------------------- - - function Parse_Number_String (Str : String) return Number_Attributes is - Answer : Number_Attributes; - - begin - for J in Str'Range loop - case Str (J) is - when ' ' => - null; -- ignore - - when '1' .. '9' => - - -- Decide if this is the start of a number. - -- If so, figure out which one... - - if Answer.Has_Fraction then - Answer.End_Of_Fraction := J; - else - if Answer.Start_Of_Int = Invalid_Position then - -- start integer - Answer.Start_Of_Int := J; - end if; - Answer.End_Of_Int := J; - end if; - - when '0' => - - -- Only count a zero before the decimal point if it follows a - -- non-zero digit. After the decimal point, zeros will be - -- counted if followed by a non-zero digit. - - if not Answer.Has_Fraction then - if Answer.Start_Of_Int /= Invalid_Position then - Answer.End_Of_Int := J; - end if; - end if; - - when '-' => - - -- Set negative - - Answer.Negative := True; - - when '.' => - - -- Close integer, start fraction - - if Answer.Has_Fraction then - raise Picture_Error; - end if; - - -- Two decimal points is a no-no - - Answer.Has_Fraction := True; - Answer.End_Of_Fraction := J; - - -- Could leave this at Invalid_Position, but this seems the - -- right way to indicate a null range... - - Answer.Start_Of_Fraction := J + 1; - Answer.End_Of_Int := J - 1; - - when others => - raise Picture_Error; -- can this happen? probably not - end case; - end loop; - - if Answer.Start_Of_Int = Invalid_Position then - Answer.Start_Of_Int := Answer.End_Of_Int + 1; - end if; - - -- No significant (intger) digits needs a null range - - return Answer; - end Parse_Number_String; - - ---------------- - -- Pic_String -- - ---------------- - - -- The following ensures that we return B and not b being careful not - -- to break things which expect lower case b for blank. See CXF3A02. - - function Pic_String (Pic : Picture) return String is - Temp : String (1 .. Pic.Contents.Picture.Length) := - Pic.Contents.Picture.Expanded; - begin - for J in Temp'Range loop - if Temp (J) = 'b' then - Temp (J) := 'B'; - end if; - end loop; - - return Temp; - end Pic_String; - - ------------------ - -- Precalculate -- - ------------------ - - procedure Precalculate (Pic : in out Format_Record) is - - Computed_BWZ : Boolean := True; - - type Legality is (Okay, Reject); - State : Legality := Reject; - -- Start in reject, which will reject null strings - - Index : Pic_Index := Pic.Picture.Expanded'First; - - function At_End return Boolean; - pragma Inline (At_End); - - procedure Set_State (L : Legality); - pragma Inline (Set_State); - - function Look return Character; - pragma Inline (Look); - - function Is_Insert return Boolean; - pragma Inline (Is_Insert); - - procedure Skip; - pragma Inline (Skip); - - procedure Trailing_Currency; - procedure Trailing_Bracket; - procedure Number_Fraction; - procedure Number_Completion; - procedure Number_Fraction_Or_Bracket; - procedure Number_Fraction_Or_Z_Fill; - procedure Zero_Suppression; - procedure Floating_Bracket; - procedure Number_Fraction_Or_Star_Fill; - procedure Star_Suppression; - procedure Number_Fraction_Or_Dollar; - procedure Leading_Dollar; - procedure Number_Fraction_Or_Pound; - procedure Leading_Pound; - procedure Picture; - procedure Floating_Plus; - procedure Floating_Minus; - procedure Picture_Plus; - procedure Picture_Minus; - procedure Picture_Bracket; - procedure Number; - procedure Optional_RHS_Sign; - procedure Picture_String; - - ------------ - -- At_End -- - ------------ - - function At_End return Boolean is - begin - return Index > Pic.Picture.Length; - end At_End; - - ---------------------- - -- Floating_Bracket -- - ---------------------- - - -- Note that Floating_Bracket is only called with an acceptable - -- prefix. But we don't set Okay, because we must end with a '>'. - - procedure Floating_Bracket is - begin - Pic.Floater := '<'; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - - -- First bracket wasn't counted... - - Skip; -- known '<' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when '9' => - Number_Completion; - - when '$' => - Leading_Dollar; - - when '#' => - Leading_Pound; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Bracket; - return; - - when others => - return; - end case; - end loop; - end Floating_Bracket; - - -------------------- - -- Floating_Minus -- - -------------------- - - procedure Floating_Minus is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '-' then - loop - if At_End then - return; - end if; - - case Look is - when '-' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Minus; - - ------------------- - -- Floating_Plus -- - ------------------- - - procedure Floating_Plus is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '9' => - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; -- Radix - - while Is_Insert loop - Skip; - end loop; - - if At_End then - return; - end if; - - if Look = '+' then - loop - if At_End then - return; - end if; - - case Look is - when '+' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - - else - Number_Completion; - end if; - - return; - - when others => - return; - end case; - end loop; - end Floating_Plus; - - --------------- - -- Is_Insert -- - --------------- - - function Is_Insert return Boolean is - begin - if At_End then - return False; - end if; - - case Pic.Picture.Expanded (Index) is - when '_' | '0' | '/' => - return True; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; -- canonical - return True; - - when others => - return False; - end case; - end Is_Insert; - - -------------------- - -- Leading_Dollar -- - -------------------- - - -- Note that Leading_Dollar can be called in either State. It will set - -- state to Okay only if a 9 or (second) is encountered. - - -- Also notice the tricky bit with State and Zero_Suppression. - -- Zero_Suppression is Picture_Error if a '$' or a '9' has been - -- encountered, exactly the cases where State has been set. - - procedure Leading_Dollar is - begin - -- Treat as a floating dollar, and unwind otherwise - - Pic.Floater := '$'; - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Skip; -- known '$' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - -- A trailing insertion character is not part of the - -- floating currency, so need to look ahead. - - if Look /= '$' then - Pic.End_Float := Pic.End_Float - 1; - end if; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if State = Okay then - raise Picture_Error; - else - -- Will overwrite Floater and Start_Float - - Zero_Suppression; - end if; - - when '*' => - if State = Okay then - raise Picture_Error; - else - -- Will overwrite Floater and Start_Float - - Star_Suppression; - end if; - - when '$' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); Skip; - - when '9' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- A single dollar does not a floating make - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one dollar before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Dollar; - return; - - when others => - return; - end case; - end loop; - end Leading_Dollar; - - ------------------- - -- Leading_Pound -- - ------------------- - - -- This one is complex. A Leading_Pound can be fixed or floating, but - -- in some cases the decision has to be deferred until we leave this - -- procedure. Also note that Leading_Pound can be called in either - -- State. - - -- It will set state to Okay only if a 9 or (second) # is encountered - - -- One Last note: In ambiguous cases, the currency is treated as - -- floating unless there is only one '#'. - - procedure Leading_Pound is - Inserts : Boolean := False; - -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered - - Must_Float : Boolean := False; - -- Set to true if a '#' occurs after an insert - - begin - -- Treat as a floating currency. If it isn't, this will be - -- overwritten later. - - Pic.Floater := '#'; - - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- currency place. - - Pic.Max_Currency_Digits := 1; -- we've seen one. - - Skip; -- known '#' - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Pic.End_Float := Index; - Inserts := True; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Will overwrite Floater and Start_Float - - Zero_Suppression; - end if; - - when '*' => - if Must_Float then - raise Picture_Error; - else - Pic.Max_Leading_Digits := 0; - - -- Will overwrite Floater and Start_Float - - Star_Suppression; - end if; - - when '#' => - if Inserts then - Must_Float := True; - end if; - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Pic.End_Currency := Index; - Set_State (Okay); - Skip; - - when '9' => - if State /= Okay then - - -- A single '#' doesn't float - - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Number_Completion; - return; - - when 'V' | 'v' | '.' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Only one pound before the sign is okay, but doesn't - -- float. - - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Pound; - return; - - when others => - return; - end case; - end loop; - end Leading_Pound; - - ---------- - -- Look -- - ---------- - - function Look return Character is - begin - if At_End then - raise Picture_Error; - end if; - - return Pic.Picture.Expanded (Index); - end Look; - - ------------ - -- Number -- - ------------ - - procedure Number is - begin - loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - - end case; - - if At_End then - return; - end if; - - -- Will return in Okay state if a '9' was seen - - end loop; - end Number; - - ----------------------- - -- Number_Completion -- - ----------------------- - - procedure Number_Completion is - begin - while not At_End loop - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - return; - - when others => - return; - end case; - end loop; - end Number_Completion; - - --------------------- - -- Number_Fraction -- - --------------------- - - procedure Number_Fraction is - begin - -- Note that number fraction can be called in either State. - -- It will set state to Valid only if a 9 is encountered. - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '9' => - Computed_BWZ := False; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Set_State (Okay); Skip; - - when others => - return; - end case; - end loop; - end Number_Fraction; - - -------------------------------- - -- Number_Fraction_Or_Bracket -- - -------------------------------- - - procedure Number_Fraction_Or_Bracket is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Bracket; - - ------------------------------- - -- Number_Fraction_Or_Dollar -- - ------------------------------- - - procedure Number_Fraction_Or_Dollar is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Dollar; - - ------------------------------ - -- Number_Fraction_Or_Pound -- - ------------------------------ - - procedure Number_Fraction_Or_Pound is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '#' => - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Pound; - - ---------------------------------- - -- Number_Fraction_Or_Star_Fill -- - ---------------------------------- - - procedure Number_Fraction_Or_Star_Fill is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.Star_Fill := True; - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Star_Fill; - - ------------------------------- - -- Number_Fraction_Or_Z_Fill -- - ------------------------------- - - procedure Number_Fraction_Or_Z_Fill is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Trailing_Digits := - Pic.Max_Trailing_Digits + 1; - Pic.End_Float := Index; - Skip; - - when others => - return; - end case; - end loop; - - when others => - Number_Fraction; - return; - end case; - end loop; - end Number_Fraction_Or_Z_Fill; - - ----------------------- - -- Optional_RHS_Sign -- - ----------------------- - - procedure Optional_RHS_Sign is - begin - if At_End then - return; - end if; - - case Look is - when '+' | '-' => - Pic.Sign_Position := Index; - Skip; - return; - - when 'C' | 'c' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'C'; - Skip; - - if Look = 'R' or else Look = 'r' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'R'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when 'D' | 'd' => - Pic.Sign_Position := Index; - Pic.Picture.Expanded (Index) := 'D'; - Skip; - - if Look = 'B' or else Look = 'b' then - Pic.Second_Sign := Index; - Pic.Picture.Expanded (Index) := 'B'; - Skip; - - else - raise Picture_Error; - end if; - - return; - - when '>' => - if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then - Pic.Second_Sign := Index; - Skip; - - else - raise Picture_Error; - end if; - - when others => - return; - end case; - end Optional_RHS_Sign; - - ------------- - -- Picture -- - ------------- - - -- Note that Picture can be called in either State - - -- It will set state to Valid only if a 9 is encountered or floating - -- currency is called. - - procedure Picture is - begin - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '$' => - Leading_Dollar; - return; - - when '#' => - Leading_Pound; - return; - - when '9' => - Computed_BWZ := False; - Set_State (Okay); - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Skip; - - when 'V' | 'v' | '.' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction; - Trailing_Currency; - return; - - when others => - return; - end case; - end loop; - end Picture; - - --------------------- - -- Picture_Bracket -- - --------------------- - - procedure Picture_Bracket is - begin - Pic.Sign_Position := Index; - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '<'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Bracket - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '<' => - Set_State (Okay); -- "<<>" is enough. - Floating_Bracket; - Trailing_Currency; - Trailing_Bracket; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Trailing_Bracket; - Set_State (Okay); - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - Trailing_Bracket; - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Picture_Bracket; - - ------------------- - -- Picture_Minus -- - ------------------- - - procedure Picture_Minus is - begin - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '-'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Minus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '-' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "-- " is enough. - Floating_Minus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - - -- Can't have Z and a floating sign - - if State = Okay then - Set_State (Reject); - end if; - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Minus; - - ------------------ - -- Picture_Plus -- - ------------------ - - procedure Picture_Plus is - begin - Pic.Sign_Position := Index; - - -- Treat as a floating sign, and unwind otherwise - - Pic.Floater := '+'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - - -- Don't increment Pic.Max_Leading_Digits, we need one "real" - -- sign place. - - Skip; -- Known Plus - - loop - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '+' => - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Skip; - Set_State (Okay); -- "++" is enough - Floating_Plus; - Trailing_Currency; - return; - - when '$' | '#' | '9' | '*' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - Picture; - Set_State (Okay); - return; - - when 'Z' | 'z' => - if State = Okay then - Set_State (Reject); - end if; - - -- Can't have Z and a floating sign - - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - -- '+Z' is acceptable - - Set_State (Okay); - - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - return; - - when '.' | 'V' | 'v' => - if State /= Okay then - Pic.Floater := '!'; - Pic.Start_Float := Invalid_Position; - Pic.End_Float := Invalid_Position; - end if; - - -- Don't assume that state is okay, haven't seen a digit - - Picture; - return; - - when others => - return; - end case; - end loop; - end Picture_Plus; - - -------------------- - -- Picture_String -- - -------------------- - - procedure Picture_String is - begin - while Is_Insert loop - Skip; - end loop; - - case Look is - when '$' | '#' => - Picture; - Optional_RHS_Sign; - - when '+' => - Picture_Plus; - - when '-' => - Picture_Minus; - - when '<' => - Picture_Bracket; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - Zero_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '*' => - Star_Suppression; - Trailing_Currency; - Optional_RHS_Sign; - - when '9' | '.' | 'V' | 'v' => - Number; - Trailing_Currency; - Optional_RHS_Sign; - - when others => - raise Picture_Error; - end case; - - -- Blank when zero either if the PIC does not contain a '9' or if - -- requested by the user and no '*'. - - Pic.Blank_When_Zero := - (Computed_BWZ or else Pic.Blank_When_Zero) - and then not Pic.Star_Fill; - - -- Star fill if '*' and no '9' - - Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; - - if not At_End then - Set_State (Reject); - end if; - end Picture_String; - - --------------- - -- Set_State -- - --------------- - - procedure Set_State (L : Legality) is - begin - State := L; - end Set_State; - - ---------- - -- Skip -- - ---------- - - procedure Skip is - begin - Index := Index + 1; - end Skip; - - ---------------------- - -- Star_Suppression -- - ---------------------- - - procedure Star_Suppression is - begin - Pic.Floater := '*'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); - - -- Even a single * is a valid picture - - Pic.Star_Fill := True; - Skip; -- Known * - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when '*' => - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Set_State (Okay); Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Star_Fill; - return; - - when '#' | '$' => - Trailing_Currency; - Set_State (Okay); - return; - - when others => - raise Picture_Error; - end case; - end loop; - end Star_Suppression; - - ---------------------- - -- Trailing_Bracket -- - ---------------------- - - procedure Trailing_Bracket is - begin - if Look = '>' then - Pic.Second_Sign := Index; - Skip; - else - raise Picture_Error; - end if; - end Trailing_Bracket; - - ----------------------- - -- Trailing_Currency -- - ----------------------- - - procedure Trailing_Currency is - begin - if At_End then - return; - end if; - - if Look = '$' then - Pic.Start_Currency := Index; - Pic.End_Currency := Index; - Skip; - - else - while not At_End and then Look = '#' loop - if Pic.Start_Currency = Invalid_Position then - Pic.Start_Currency := Index; - end if; - - Pic.End_Currency := Index; - Skip; - end loop; - end if; - - loop - if At_End then - return; - end if; - - case Look is - when '_' | '0' | '/' => - Skip; - - when 'B' | 'b' => - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when others => - return; - end case; - end loop; - end Trailing_Currency; - - ---------------------- - -- Zero_Suppression -- - ---------------------- - - procedure Zero_Suppression is - begin - Pic.Floater := 'Z'; - Pic.Start_Float := Index; - Pic.End_Float := Index; - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Skip; -- Known Z - - loop - -- Even a single Z is a valid picture - - if At_End then - Set_State (Okay); - return; - end if; - - case Look is - when '_' | '0' | '/' => - Pic.End_Float := Index; - Skip; - - when 'B' | 'b' => - Pic.End_Float := Index; - Pic.Picture.Expanded (Index) := 'b'; - Skip; - - when 'Z' | 'z' => - Pic.Picture.Expanded (Index) := 'Z'; -- consistency - - Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; - Pic.End_Float := Index; - Set_State (Okay); - Skip; - - when '9' => - Set_State (Okay); - Number_Completion; - return; - - when '.' | 'V' | 'v' => - Pic.Radix_Position := Index; - Skip; - Number_Fraction_Or_Z_Fill; - return; - - when '#' | '$' => - Trailing_Currency; - Set_State (Okay); - return; - - when others => - return; - end case; - end loop; - end Zero_Suppression; - - -- Start of processing for Precalculate - - begin - Picture_String; - - if State = Reject then - raise Picture_Error; - end if; - - exception - - when Constraint_Error => - - -- To deal with special cases like null strings - - raise Picture_Error; - - end Precalculate; - - ---------------- - -- To_Picture -- - ---------------- - - function To_Picture - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Picture - is - Result : Picture; - - begin - declare - Item : constant String := Expand (Pic_String); - - begin - Result.Contents.Picture := (Item'Length, Item); - Result.Contents.Original_BWZ := Blank_When_Zero; - Result.Contents.Blank_When_Zero := Blank_When_Zero; - Precalculate (Result.Contents); - return Result; - end; - - exception - when others => - raise Picture_Error; - - end To_Picture; - - ------------- - -- To_Wide -- - ------------- - - function To_Wide (C : Character) return Wide_Wide_Character is - begin - return Wide_Wide_Character'Val (Character'Pos (C)); - end To_Wide; - - ----------- - -- Valid -- - ----------- - - function Valid - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Boolean - is - begin - declare - Expanded_Pic : constant String := Expand (Pic_String); - -- Raises Picture_Error if Item not well-formed - - Format_Rec : Format_Record; - - begin - Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); - Format_Rec.Blank_When_Zero := Blank_When_Zero; - Format_Rec.Original_BWZ := Blank_When_Zero; - Precalculate (Format_Rec); - - -- False only if Blank_When_0 is True but the pic string has a '*' - - return not Blank_When_Zero - or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; - end; - - exception - when others => return False; - end Valid; - -end Ada.Wide_Wide_Text_IO.Editing; diff --git a/gcc/ada/a-ztedit.ads b/gcc/ada/a-ztedit.ads deleted file mode 100644 index db840d0..0000000 --- a/gcc/ada/a-ztedit.ads +++ /dev/null @@ -1,198 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Ada.Wide_Wide_Text_IO.Editing is - - type Picture is private; - - function Valid - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Boolean; - - function To_Picture - (Pic_String : String; - Blank_When_Zero : Boolean := False) return Picture; - - function Pic_String (Pic : Picture) return String; - function Blank_When_Zero (Pic : Picture) return Boolean; - - Max_Picture_Length : constant := 64; - - Picture_Error : exception; - - Default_Currency : constant Wide_Wide_String := "$"; - Default_Fill : constant Wide_Wide_Character := ' '; - Default_Separator : constant Wide_Wide_Character := ','; - Default_Radix_Mark : constant Wide_Wide_Character := '.'; - - generic - type Num is delta <> digits <>; - Default_Currency : Wide_Wide_String := - Wide_Wide_Text_IO.Editing.Default_Currency; - Default_Fill : Wide_Wide_Character := - Wide_Wide_Text_IO.Editing.Default_Fill; - Default_Separator : Wide_Wide_Character := - Wide_Wide_Text_IO.Editing.Default_Separator; - Default_Radix_Mark : Wide_Wide_Character := - Wide_Wide_Text_IO.Editing.Default_Radix_Mark; - - package Decimal_Output is - - function Length - (Pic : Picture; - Currency : Wide_Wide_String := Default_Currency) return Natural; - - function Valid - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency) return Boolean; - - function Image - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) - return Wide_Wide_String; - - procedure Put - (File : File_Type; - Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); - - procedure Put - (Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Pic : Picture; - Currency : Wide_Wide_String := Default_Currency; - Fill : Wide_Wide_Character := Default_Fill; - Separator : Wide_Wide_Character := Default_Separator; - Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); - - end Decimal_Output; - -private - MAX_PICSIZE : constant := 50; - MAX_MONEYSIZE : constant := 10; - Invalid_Position : constant := -1; - - subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; - - type Picture_Record (Length : Pic_Index := 0) is record - Expanded : String (1 .. Length); - end record; - - type Format_Record is record - Picture : Picture_Record; - -- Read only - - Blank_When_Zero : Boolean; - -- Read/write - - Original_BWZ : Boolean; - - -- The following components get written - - Star_Fill : Boolean := False; - - Radix_Position : Integer := Invalid_Position; - - Sign_Position, - Second_Sign : Integer := Invalid_Position; - - Start_Float, - End_Float : Integer := Invalid_Position; - - Start_Currency, - End_Currency : Integer := Invalid_Position; - - Max_Leading_Digits : Integer := 0; - - Max_Trailing_Digits : Integer := 0; - - Max_Currency_Digits : Integer := 0; - - Floater : Wide_Wide_Character := '!'; - -- Initialized to illegal value - - end record; - - type Picture is record - Contents : Format_Record; - end record; - - type Number_Attributes is record - Negative : Boolean := False; - - Has_Fraction : Boolean := False; - - Start_Of_Int, - End_Of_Int, - Start_Of_Fraction, - End_Of_Fraction : Integer := Invalid_Position; -- invalid value - end record; - - function Parse_Number_String (Str : String) return Number_Attributes; - -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no - -- trailing blanks...) - - procedure Precalculate (Pic : in out Format_Record); - -- Precalculates fields from the user supplied data - - function Format_Number - (Pic : Format_Record; - Number : String; - Currency_Symbol : Wide_Wide_String; - Fill_Character : Wide_Wide_Character; - Separator_Character : Wide_Wide_Character; - Radix_Point : Wide_Wide_Character) return Wide_Wide_String; - -- Formats number according to Pic - - function Expand (Picture : String) return String; - -end Ada.Wide_Wide_Text_IO.Editing; diff --git a/gcc/ada/a-ztenau.adb b/gcc/ada/a-ztenau.adb deleted file mode 100644 index 8df795e..0000000 --- a/gcc/ada/a-ztenau.adb +++ /dev/null @@ -1,353 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; -with Ada.Characters.Conversions; use Ada.Characters.Conversions; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.WCh_Con; use System.WCh_Con; - -package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is - - subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Store_Char - (WC : Wide_Wide_Character; - Buf : out Wide_Wide_String; - Ptr : in out Integer); - -- Store a single character in buffer, checking for overflow - - -- These definitions replace the ones in Ada.Characters.Handling, which - -- do not seem to work for some strange not understood reason ??? at - -- least in the OS/2 version. - - function To_Lower (C : Character) return Character; - - ------------------ - -- Get_Enum_Lit -- - ------------------ - - procedure Get_Enum_Lit - (File : File_Type; - Buf : out Wide_Wide_String; - Buflen : out Natural) - is - ch : int; - WC : Wide_Wide_Character; - - begin - Buflen := 0; - Load_Skip (TFT (File)); - ch := Nextc (TFT (File)); - - -- Character literal case. If the initial character is a quote, then - -- we read as far as we can without backup (see ACVC test CE3905L) - - if ch = Character'Pos (''') then - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - ch := Nextc (TFT (File)); - - if ch = LM or else ch = EOF then - return; - end if; - - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - ch := Nextc (TFT (File)); - - if ch /= Character'Pos (''') then - return; - end if; - - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - -- Similarly for identifiers, read as far as we can, in particular, - -- do read a trailing underscore (again see ACVC test CE3905L to - -- understand why we do this, although it seems somewhat peculiar). - - else - -- Identifier must start with a letter. Any wide character value - -- outside the normal Latin-1 range counts as a letter for this. - - if ch < 255 and then not Is_Letter (Character'Val (ch)) then - return; - end if; - - -- If we do have a letter, loop through the characters quitting on - -- the first non-identifier character (note that this includes the - -- cases of hitting a line mark or page mark). - - loop - Get (File, WC); - Store_Char (WC, Buf, Buflen); - - ch := Nextc (TFT (File)); - - exit when ch = EOF; - - if ch = Character'Pos ('_') then - exit when Buf (Buflen) = '_'; - - elsif ch = Character'Pos (ASCII.ESC) then - null; - - elsif File.WC_Method in WC_Upper_Half_Encoding_Method - and then ch > 127 - then - null; - - else - exit when not Is_Letter (Character'Val (ch)) - and then - not Is_Digit (Character'Val (ch)); - end if; - end loop; - end if; - end Get_Enum_Lit; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_Wide_String; - Width : Field; - Set : Type_Set) - is - Actual_Width : constant Integer := - Integer'Max (Integer (Width), Item'Length); - - begin - Check_On_One_Line (TFT (File), Actual_Width); - - if Set = Lower_Case and then Item (Item'First) /= ''' then - declare - Iteml : Wide_Wide_String (Item'First .. Item'Last); - - begin - for J in Item'Range loop - if Is_Character (Item (J)) then - Iteml (J) := - To_Wide_Wide_Character - (To_Lower (To_Character (Item (J)))); - else - Iteml (J) := Item (J); - end if; - end loop; - - Put (File, Iteml); - end; - - else - Put (File, Item); - end if; - - for J in 1 .. Actual_Width - Item'Length loop - Put (File, ' '); - end loop; - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out Wide_Wide_String; - Item : Wide_Wide_String; - Set : Type_Set) - is - Ptr : Natural; - - begin - if Item'Length > To'Length then - raise Layout_Error; - - else - Ptr := To'First; - for J in Item'Range loop - if Set = Lower_Case - and then Item (Item'First) /= ''' - and then Is_Character (Item (J)) - then - To (Ptr) := - To_Wide_Wide_Character (To_Lower (To_Character (Item (J)))); - else - To (Ptr) := Item (J); - end if; - - Ptr := Ptr + 1; - end loop; - - while Ptr <= To'Last loop - To (Ptr) := ' '; - Ptr := Ptr + 1; - end loop; - end if; - end Puts; - - ------------------- - -- Scan_Enum_Lit -- - ------------------- - - procedure Scan_Enum_Lit - (From : Wide_Wide_String; - Start : out Natural; - Stop : out Natural) - is - WC : Wide_Wide_Character; - - -- Processing for Scan_Enum_Lit - - begin - Start := From'First; - - loop - if Start > From'Last then - raise End_Error; - - elsif Is_Character (From (Start)) - and then not Is_Blank (To_Character (From (Start))) - then - exit; - - else - Start := Start + 1; - end if; - end loop; - - -- Character literal case. If the initial character is a quote, then - -- we read as far as we can without backup (see ACVC test CE3905L - -- which is for the analogous case for reading from a file). - - if From (Start) = ''' then - Stop := Start; - - if Stop = From'Last then - raise Data_Error; - else - Stop := Stop + 1; - end if; - - if From (Stop) in ' ' .. '~' - or else From (Stop) >= Wide_Wide_Character'Val (16#80#) - then - if Stop = From'Last then - raise Data_Error; - else - Stop := Stop + 1; - - if From (Stop) = ''' then - return; - end if; - end if; - end if; - - raise Data_Error; - - -- Similarly for identifiers, read as far as we can, in particular, - -- do read a trailing underscore (again see ACVC test CE3905L to - -- understand why we do this, although it seems somewhat peculiar). - - else - -- Identifier must start with a letter, any wide character outside - -- the normal Latin-1 range is considered a letter for this test. - - if Is_Character (From (Start)) - and then not Is_Letter (To_Character (From (Start))) - then - raise Data_Error; - end if; - - -- If we do have a letter, loop through the characters quitting on - -- the first non-identifier character (note that this includes the - -- cases of hitting a line mark or page mark). - - Stop := Start + 1; - while Stop < From'Last loop - WC := From (Stop + 1); - - exit when - Is_Character (WC) - and then - not Is_Letter (To_Character (WC)) - and then - not Is_Letter (To_Character (WC)) - and then - (WC /= '_' or else From (Stop - 1) = '_'); - - Stop := Stop + 1; - end loop; - end if; - - end Scan_Enum_Lit; - - ---------------- - -- Store_Char -- - ---------------- - - procedure Store_Char - (WC : Wide_Wide_Character; - Buf : out Wide_Wide_String; - Ptr : in out Integer) - is - begin - if Ptr = Buf'Last then - raise Data_Error; - else - Ptr := Ptr + 1; - Buf (Ptr) := WC; - end if; - end Store_Char; - - -------------- - -- To_Lower -- - -------------- - - function To_Lower (C : Character) return Character is - begin - if C in 'A' .. 'Z' then - return Character'Val (Character'Pos (C) + 32); - else - return C; - end if; - end To_Lower; - -end Ada.Wide_Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-ztenau.ads b/gcc/ada/a-ztenau.ads deleted file mode 100644 index 5e12712..0000000 --- a/gcc/ada/a-ztenau.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Wide_Text_IO.Enumeration_IO --- that are shared among separate instantiations. - -private package Ada.Wide_Wide_Text_IO.Enumeration_Aux is - - procedure Get_Enum_Lit - (File : File_Type; - Buf : out Wide_Wide_String; - Buflen : out Natural); - -- Reads an enumeration literal value from the file, folds to upper case, - -- and stores the result in Buf, setting Buflen to the number of stored - -- characters (Buf has a lower bound of 1). If more than Buflen characters - -- are present in the literal, Data_Error is raised. - - procedure Scan_Enum_Lit - (From : Wide_Wide_String; - Start : out Natural; - Stop : out Natural); - -- Scans an enumeration literal at the start of From, skipping any leading - -- spaces. Sets Start to the first character, Stop to the last character. - -- Raises End_Error if no enumeration literal is found. - - procedure Put - (File : File_Type; - Item : Wide_Wide_String; - Width : Field; - Set : Type_Set); - -- Outputs the enumeration literal image stored in Item to the given File, - -- using the given Width and Set parameters (Item is always in upper case). - - procedure Puts - (To : out Wide_Wide_String; - Item : Wide_Wide_String; - Set : Type_Set); - -- Stores the enumeration literal image stored in Item to the string To, - -- padding with trailing spaces if necessary to fill To. Set is used to - -end Ada.Wide_Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/a-ztenio.adb b/gcc/ada/a-ztenio.adb deleted file mode 100644 index 74b0ec9..0000000 --- a/gcc/ada/a-ztenio.adb +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Enumeration_Aux; - -package body Ada.Wide_Wide_Text_IO.Enumeration_IO is - - package Aux renames Ada.Wide_Wide_Text_IO.Enumeration_Aux; - - --------- - -- Get -- - --------- - - procedure Get (File : File_Type; Item : out Enum) is - Buf : Wide_Wide_String (1 .. Enum'Width); - Buflen : Natural; - begin - Aux.Get_Enum_Lit (File, Buf, Buflen); - Item := Enum'Wide_Wide_Value (Buf (1 .. Buflen)); - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get (Item : out Enum) is - begin - Get (Current_Input, Item); - end Get; - - procedure Get - (From : Wide_Wide_String; - Item : out Enum; - Last : out Positive) - is - Start : Natural; - begin - Aux.Scan_Enum_Lit (From, Start, Last); - Item := Enum'Wide_Wide_Value (From (Start .. Last)); - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting) - is - Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); - begin - Aux.Put (File, Image, Width, Set); - end Put; - - procedure Put - (Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting) - is - begin - Put (Current_Output, Item, Width, Set); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Enum; - Set : Type_Set := Default_Setting) - is - Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); - begin - Aux.Puts (To, Image, Set); - end Put; - -end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-ztenio.ads b/gcc/ada/a-ztenio.ads deleted file mode 100644 index 5a00351..0000000 --- a/gcc/ada/a-ztenio.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Wide_Text_IO.Enumeration_IO is a subpackage --- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Enumeration_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up the --- difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Enum is (<>); - -package Ada.Wide_Wide_Text_IO.Enumeration_IO is - - Default_Width : Field := 0; - Default_Setting : Type_Set := Upper_Case; - - procedure Get (File : File_Type; Item : out Enum); - procedure Get (Item : out Enum); - - procedure Put - (File : File_Type; - Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting); - - procedure Put - (Item : Enum; - Width : Field := Default_Width; - Set : Type_Set := Default_Setting); - - procedure Get - (From : Wide_Wide_String; - Item : out Enum; - Last : out Positive); - - procedure Put - (To : out Wide_Wide_String; - Item : Enum; - Set : Type_Set := Default_Setting); - -end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/a-ztexio.adb b/gcc/ada/a-ztexio.adb deleted file mode 100644 index 39fd38a..0000000 --- a/gcc/ada/a-ztexio.adb +++ /dev/null @@ -1,1939 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Streams; use Ada.Streams; -with Interfaces.C_Streams; use Interfaces.C_Streams; - -with System.CRTL; -with System.File_IO; -with System.WCh_Cnv; use System.WCh_Cnv; -with System.WCh_Con; use System.WCh_Con; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -pragma Elaborate_All (System.File_IO); --- Needed because of calls to Chain_File in package body elaboration - -package body Ada.Wide_Wide_Text_IO is - - package FIO renames System.File_IO; - - subtype AP is FCB.AFCB_Ptr; - - function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); - function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); - use type FCB.File_Mode; - - use type System.CRTL.size_t; - - WC_Encoding : Character; - pragma Import (C, WC_Encoding, "__gl_wc_encoding"); - -- Default wide character encoding - - Err_Name : aliased String := "*stderr" & ASCII.NUL; - In_Name : aliased String := "*stdin" & ASCII.NUL; - Out_Name : aliased String := "*stdout" & ASCII.NUL; - -- Names of standard files - -- - -- Use "preallocated" strings to avoid calling "new" during the elaboration - -- of the run time. This is needed in the tasking case to avoid calling - -- Task_Lock too early. A filename is expected to end with a null character - -- in the runtime, here the null characters are added just to have a - -- correct filename length. - -- - -- Note: the names for these files are bogus, and probably it would be - -- better for these files to have no names, but the ACVC tests insist. - -- We use names that are bound to fail in open etc. - - Null_Str : aliased constant String := ""; - -- Used as form string for standard files - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Get_Wide_Wide_Char_Immed - (C : Character; - File : File_Type) return Wide_Wide_Character; - -- This routine is identical to Get_Wide_Wide_Char, except that the reads - -- are done in Get_Immediate mode (i.e. without waiting for a line return). - - function Getc_Immed (File : File_Type) return int; - -- This routine is identical to Getc, except that the read is done in - -- Get_Immediate mode (i.e. without waiting for a line return). - - procedure Putc (ch : int; File : File_Type); - -- Outputs the given character to the file, which has already been checked - -- for being in output status. Device_Error is raised if the character - -- cannot be written. - - procedure Set_WCEM (File : in out File_Type); - -- Called by Open and Create to set the wide character encoding method for - -- the file, processing a WCEM form parameter if one is present. File is - -- IN OUT because it may be closed in case of an error. - - procedure Terminate_Line (File : File_Type); - -- If the file is in Write_File or Append_File mode, and the current line - -- is not terminated, then a line terminator is written using New_Line. - -- Note that there is no Terminate_Page routine, because the page mark at - -- the end of the file is implied if necessary. - - procedure Ungetc (ch : int; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has checked - -- that the file is in read status. Device_Error is raised if the character - -- cannot be pushed back. An attempt to push back and end of file character - -- (EOF) is ignored. - - ------------------- - -- AFCB_Allocate -- - ------------------- - - function AFCB_Allocate - (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr - is - pragma Unreferenced (Control_Block); - begin - return new Wide_Wide_Text_AFCB; - end AFCB_Allocate; - - ---------------- - -- AFCB_Close -- - ---------------- - - procedure AFCB_Close (File : not null access Wide_Wide_Text_AFCB) is - begin - -- If the file being closed is one of the current files, then close - -- the corresponding current file. It is not clear that this action - -- is required (RM A.10.3(23)) but it seems reasonable, and besides - -- ACVC test CE3208A expects this behavior. - - if File_Type (File) = Current_In then - Current_In := null; - elsif File_Type (File) = Current_Out then - Current_Out := null; - elsif File_Type (File) = Current_Err then - Current_Err := null; - end if; - - Terminate_Line (File_Type (File)); - end AFCB_Close; - - --------------- - -- AFCB_Free -- - --------------- - - procedure AFCB_Free (File : not null access Wide_Wide_Text_AFCB) is - type FCB_Ptr is access all Wide_Wide_Text_AFCB; - FT : FCB_Ptr := FCB_Ptr (File); - - procedure Free is new - Ada.Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr); - - begin - Free (FT); - end AFCB_Free; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out File_Type) is - begin - FIO.Close (AP (File)'Unrestricted_Access); - end Close; - - --------- - -- Col -- - --------- - - -- Note: we assume that it is impossible in practice for the column - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Col (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Col; - end Col; - - function Col return Positive_Count is - begin - return Col (Current_Out); - end Col; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := "") - is - Dummy_File_Control_Block : Wide_Wide_Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'W', - Creat => True, - Text => True); - - File.Self := File; - Set_WCEM (File); - end Create; - - ------------------- - -- Current_Error -- - ------------------- - - function Current_Error return File_Type is - begin - return Current_Err; - end Current_Error; - - function Current_Error return File_Access is - begin - return Current_Err.Self'Access; - end Current_Error; - - ------------------- - -- Current_Input -- - ------------------- - - function Current_Input return File_Type is - begin - return Current_In; - end Current_Input; - - function Current_Input return File_Access is - begin - return Current_In.Self'Access; - end Current_Input; - - -------------------- - -- Current_Output -- - -------------------- - - function Current_Output return File_Type is - begin - return Current_Out; - end Current_Output; - - function Current_Output return File_Access is - begin - return Current_Out.Self'Access; - end Current_Output; - - ------------ - -- Delete -- - ------------ - - procedure Delete (File : in out File_Type) is - begin - FIO.Delete (AP (File)'Unrestricted_Access); - end Delete; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Wide_Character then - return False; - - elsif File.Before_LM then - if File.Before_LM_PM then - return Nextc (File) = EOF; - end if; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch /= LM then - Ungetc (ch, File); - return False; - - else -- ch = LM - File.Before_LM := True; - end if; - end if; - - -- Here we are just past the line mark with Before_LM set so that we - -- do not have to try to back up past the LM, thus avoiding the need - -- to back up more than one character. - - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch = PM and then File.Is_Regular_File then - File.Before_LM_PM := True; - return Nextc (File) = EOF; - - -- Here if neither EOF nor PM followed end of line - - else - Ungetc (ch, File); - return False; - end if; - - end End_Of_File; - - function End_Of_File return Boolean is - begin - return End_Of_File (Current_In); - end End_Of_File; - - ----------------- - -- End_Of_Line -- - ----------------- - - function End_Of_Line (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Wide_Character then - return False; - - elsif File.Before_LM then - return True; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - else - Ungetc (ch, File); - return (ch = LM); - end if; - end if; - end End_Of_Line; - - function End_Of_Line return Boolean is - begin - return End_Of_Line (Current_In); - end End_Of_Line; - - ----------------- - -- End_Of_Page -- - ----------------- - - function End_Of_Page (File : File_Type) return Boolean is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if not File.Is_Regular_File then - return False; - - elsif File.Before_Wide_Wide_Character then - return False; - - elsif File.Before_LM then - if File.Before_LM_PM then - return True; - end if; - - else - ch := Getc (File); - - if ch = EOF then - return True; - - elsif ch /= LM then - Ungetc (ch, File); - return False; - - else -- ch = LM - File.Before_LM := True; - end if; - end if; - - -- Here we are just past the line mark with Before_LM set so that we - -- do not have to try to back up past the LM, thus avoiding the need - -- to back up more than one character. - - ch := Nextc (File); - - return ch = PM or else ch = EOF; - end End_Of_Page; - - function End_Of_Page return Boolean is - begin - return End_Of_Page (Current_In); - end End_Of_Page; - - ----------- - -- Flush -- - ----------- - - procedure Flush (File : File_Type) is - begin - FIO.Flush (AP (File)); - end Flush; - - procedure Flush is - begin - Flush (Current_Out); - end Flush; - - ---------- - -- Form -- - ---------- - - function Form (File : File_Type) return String is - begin - return FIO.Form (AP (File)); - end Form; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Wide_Wide_Character) - is - C : Character; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Wide_Character then - File.Before_Wide_Wide_Character := False; - Item := File.Saved_Wide_Wide_Character; - - -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same??? - - else - Get_Character (File, C); - Item := Get_Wide_Wide_Char (C, File); - end if; - end Get; - - procedure Get (Item : out Wide_Wide_Character) is - begin - Get (Current_In, Item); - end Get; - - procedure Get - (File : File_Type; - Item : out Wide_Wide_String) - is - begin - for J in Item'Range loop - Get (File, Item (J)); - end loop; - end Get; - - procedure Get (Item : out Wide_Wide_String) is - begin - Get (Current_In, Item); - end Get; - - ------------------- - -- Get_Character -- - ------------------- - - procedure Get_Character - (File : File_Type; - Item : out Character) - is - ch : int; - - begin - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - File.Col := 1; - - if File.Before_LM_PM then - File.Line := 1; - File.Page := File.Page + 1; - File.Before_LM_PM := False; - - else - File.Line := File.Line + 1; - end if; - end if; - - loop - ch := Getc (File); - - if ch = EOF then - raise End_Error; - - elsif ch = LM then - File.Line := File.Line + 1; - File.Col := 1; - - elsif ch = PM and then File.Is_Regular_File then - File.Page := File.Page + 1; - File.Line := 1; - - else - Item := Character'Val (ch); - File.Col := File.Col + 1; - return; - end if; - end loop; - end Get_Character; - - ------------------- - -- Get_Immediate -- - ------------------- - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Wide_Character) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_Wide_Wide_Character then - File.Before_Wide_Wide_Character := False; - Item := File.Saved_Wide_Wide_Character; - - elsif File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - Item := Wide_Wide_Character'Val (LM); - - else - ch := Getc_Immed (File); - - if ch = EOF then - raise End_Error; - else - Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); - end if; - end if; - end Get_Immediate; - - procedure Get_Immediate - (Item : out Wide_Wide_Character) - is - begin - Get_Immediate (Current_In, Item); - end Get_Immediate; - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Wide_Character; - Available : out Boolean) - is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - Available := True; - - if File.Before_Wide_Wide_Character then - File.Before_Wide_Wide_Character := False; - Item := File.Saved_Wide_Wide_Character; - - elsif File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - Item := Wide_Wide_Character'Val (LM); - - else - -- Shouldn't we use getc_immediate_nowait here, like Text_IO??? - - ch := Getc_Immed (File); - - if ch = EOF then - raise End_Error; - else - Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); - end if; - end if; - end Get_Immediate; - - procedure Get_Immediate - (Item : out Wide_Wide_Character; - Available : out Boolean) - is - begin - Get_Immediate (Current_In, Item, Available); - end Get_Immediate; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (File : File_Type; - Item : out Wide_Wide_String; - Last : out Natural) - is - begin - FIO.Check_Read_Status (AP (File)); - Last := Item'First - 1; - - -- Immediate exit for null string, this is a case in which we do not - -- need to test for end of file and we do not skip a line mark under - -- any circumstances. - - if Last >= Item'Last then - return; - end if; - - -- Here we have at least one character, if we are immediately before - -- a line mark, then we will just skip past it storing no characters. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - - -- Otherwise we need to read some characters - - else - -- If we are at the end of file now, it means we are trying to - -- skip a file terminator and we raise End_Error (RM A.10.7(20)) - - if Nextc (File) = EOF then - raise End_Error; - end if; - - -- Loop through characters in string - - loop - -- Exit the loop if read is terminated by encountering line mark - -- Note that the use of Skip_Line here ensures we properly deal - -- with setting the page and line numbers. - - if End_Of_Line (File) then - Skip_Line (File); - return; - end if; - - -- Otherwise store the character, note that we know that ch is - -- something other than LM or EOF. It could possibly be a page - -- mark if there is a stray page mark in the middle of a line, - -- but this is not an official page mark in any case, since - -- official page marks can only follow a line mark. The whole - -- page business is pretty much nonsense anyway, so we do not - -- want to waste time trying to make sense out of non-standard - -- page marks in the file. This means that the behavior of - -- Get_Line is different from repeated Get of a character, but - -- that's too bad. We only promise that page numbers etc make - -- sense if the file is formatted in a standard manner. - - -- Note: we do not adjust the column number because it is quicker - -- to adjust it once at the end of the operation than incrementing - -- it each time around the loop. - - Last := Last + 1; - Get (File, Item (Last)); - - -- All done if the string is full, this is the case in which - -- we do not skip the following line mark. We need to adjust - -- the column number in this case. - - if Last = Item'Last then - File.Col := File.Col + Count (Item'Length); - return; - end if; - - -- Exit from the loop if we are at the end of file. This happens - -- if we have a last line that is not terminated with a line mark. - -- In this case we consider that there is an implied line mark; - -- this is a non-standard file, but we will treat it nicely. - - exit when Nextc (File) = EOF; - end loop; - end if; - end Get_Line; - - procedure Get_Line - (Item : out Wide_Wide_String; - Last : out Natural) - is - begin - Get_Line (Current_In, Item, Last); - end Get_Line; - - function Get_Line (File : File_Type) return Wide_Wide_String is - Buffer : Wide_Wide_String (1 .. 500); - Last : Natural; - - function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String; - -- This is a recursive function that reads the rest of the line and - -- returns it. S is the part read so far. - - -------------- - -- Get_Rest -- - -------------- - - function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String is - - -- Each time we allocate a buffer the same size as what we have - -- read so far. This limits us to a logarithmic number of calls - -- to Get_Rest and also ensures only a linear use of stack space. - - Buffer : Wide_Wide_String (1 .. S'Length); - Last : Natural; - - begin - Get_Line (File, Buffer, Last); - - declare - R : constant Wide_Wide_String := S & Buffer (1 .. Last); - begin - if Last < Buffer'Last then - return R; - else - return Get_Rest (R); - end if; - end; - end Get_Rest; - - -- Start of processing for Get_Line - - begin - Get_Line (File, Buffer, Last); - - if Last < Buffer'Last then - return Buffer (1 .. Last); - else - return Get_Rest (Buffer (1 .. Last)); - end if; - end Get_Line; - - function Get_Line return Wide_Wide_String is - begin - return Get_Line (Current_In); - end Get_Line; - - ------------------------ - -- Get_Wide_Wide_Char -- - ------------------------ - - function Get_Wide_Wide_Char - (C : Character; - File : File_Type) return Wide_Wide_Character - is - function In_Char return Character; - -- Function used to obtain additional characters it the wide character - -- sequence is more than one character long. - - function WC_In is new Char_Sequence_To_UTF_32 (In_Char); - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - ch : constant Integer := Getc (File); - begin - if ch = EOF then - raise End_Error; - else - return Character'Val (ch); - end if; - end In_Char; - - -- Start of processing for Get_Wide_Wide_Char - - begin - FIO.Check_Read_Status (AP (File)); - return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); - end Get_Wide_Wide_Char; - - ------------------------------ - -- Get_Wide_Wide_Char_Immed -- - ------------------------------ - - function Get_Wide_Wide_Char_Immed - (C : Character; - File : File_Type) return Wide_Wide_Character - is - function In_Char return Character; - -- Function used to obtain additional characters it the wide character - -- sequence is more than one character long. - - function WC_In is new Char_Sequence_To_UTF_32 (In_Char); - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - ch : constant Integer := Getc_Immed (File); - begin - if ch = EOF then - raise End_Error; - else - return Character'Val (ch); - end if; - end In_Char; - - -- Start of processing for Get_Wide_Wide_Char_Immed - - begin - FIO.Check_Read_Status (AP (File)); - return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); - end Get_Wide_Wide_Char_Immed; - - ---------- - -- Getc -- - ---------- - - function Getc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF and then ferror (File.Stream) /= 0 then - raise Device_Error; - else - return ch; - end if; - end Getc; - - ---------------- - -- Getc_Immed -- - ---------------- - - function Getc_Immed (File : File_Type) return int is - ch : int; - end_of_file : int; - - procedure getc_immediate - (stream : FILEs; ch : out int; end_of_file : out int); - pragma Import (C, getc_immediate, "getc_immediate"); - - begin - FIO.Check_Read_Status (AP (File)); - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - ch := LM; - - else - getc_immediate (File.Stream, ch, end_of_file); - - if ferror (File.Stream) /= 0 then - raise Device_Error; - elsif end_of_file /= 0 then - return EOF; - end if; - end if; - - return ch; - end Getc_Immed; - - ------------------------------- - -- Initialize_Standard_Files -- - ------------------------------- - - procedure Initialize_Standard_Files is - begin - Standard_Err.Stream := stderr; - Standard_Err.Name := Err_Name'Access; - Standard_Err.Form := Null_Str'Unrestricted_Access; - Standard_Err.Mode := FCB.Out_File; - Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; - Standard_Err.Is_Temporary_File := False; - Standard_Err.Is_System_File := True; - Standard_Err.Text_Encoding := Default_Text; - Standard_Err.Access_Method := 'T'; - Standard_Err.Self := Standard_Err; - Standard_Err.WC_Method := Default_WCEM; - - Standard_In.Stream := stdin; - Standard_In.Name := In_Name'Access; - Standard_In.Form := Null_Str'Unrestricted_Access; - Standard_In.Mode := FCB.In_File; - Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; - Standard_In.Is_Temporary_File := False; - Standard_In.Is_System_File := True; - Standard_In.Text_Encoding := Default_Text; - Standard_In.Access_Method := 'T'; - Standard_In.Self := Standard_In; - Standard_In.WC_Method := Default_WCEM; - - Standard_Out.Stream := stdout; - Standard_Out.Name := Out_Name'Access; - Standard_Out.Form := Null_Str'Unrestricted_Access; - Standard_Out.Mode := FCB.Out_File; - Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; - Standard_Out.Is_Temporary_File := False; - Standard_Out.Is_System_File := True; - Standard_Out.Text_Encoding := Default_Text; - Standard_Out.Access_Method := 'T'; - Standard_Out.Self := Standard_Out; - Standard_Out.WC_Method := Default_WCEM; - - FIO.Make_Unbuffered (AP (Standard_Out)); - FIO.Make_Unbuffered (AP (Standard_Err)); - end Initialize_Standard_Files; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (File : File_Type) return Boolean is - begin - return FIO.Is_Open (AP (File)); - end Is_Open; - - ---------- - -- Line -- - ---------- - - -- Note: we assume that it is impossible in practice for the line - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Line (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Line; - end Line; - - function Line return Positive_Count is - begin - return Line (Current_Out); - end Line; - - ----------------- - -- Line_Length -- - ----------------- - - function Line_Length (File : File_Type) return Count is - begin - FIO.Check_Write_Status (AP (File)); - return File.Line_Length; - end Line_Length; - - function Line_Length return Count is - begin - return Line_Length (Current_Out); - end Line_Length; - - ---------------- - -- Look_Ahead -- - ---------------- - - procedure Look_Ahead - (File : File_Type; - Item : out Wide_Wide_Character; - End_Of_Line : out Boolean) - is - ch : int; - - -- Start of processing for Look_Ahead - - begin - FIO.Check_Read_Status (AP (File)); - - -- If we are logically before a line mark, we can return immediately - - if File.Before_LM then - End_Of_Line := True; - Item := Wide_Wide_Character'Val (0); - - -- If we are before a wide character, just return it (this can happen - -- if there are two calls to Look_Ahead in a row). - - elsif File.Before_Wide_Wide_Character then - End_Of_Line := False; - Item := File.Saved_Wide_Wide_Character; - - -- otherwise we must read a character from the input stream - - else - ch := Getc (File); - - if ch = LM - or else ch = EOF - or else (ch = EOF and then File.Is_Regular_File) - then - End_Of_Line := True; - Ungetc (ch, File); - Item := Wide_Wide_Character'Val (0); - - -- Case where character obtained does not represent the start of an - -- encoded sequence so it stands for itself and we can unget it with - -- no difficulty. - - elsif not Is_Start_Of_Encoding - (Character'Val (ch), File.WC_Method) - then - End_Of_Line := False; - Ungetc (ch, File); - Item := Wide_Wide_Character'Val (ch); - - -- For the start of an encoding, we read the character using the - -- Get_Wide_Wide_Char routine. It will occupy more than one byte so - -- we can't put it back with ungetc. Instead we save it in the - -- control block, setting a flag that everyone interested in reading - -- characters must test before reading the stream. - - else - Item := Get_Wide_Wide_Char (Character'Val (ch), File); - End_Of_Line := False; - File.Saved_Wide_Wide_Character := Item; - File.Before_Wide_Wide_Character := True; - end if; - end if; - end Look_Ahead; - - procedure Look_Ahead - (Item : out Wide_Wide_Character; - End_Of_Line : out Boolean) - is - begin - Look_Ahead (Current_In, Item, End_Of_Line); - end Look_Ahead; - - ---------- - -- Mode -- - ---------- - - function Mode (File : File_Type) return File_Mode is - begin - return To_TIO (FIO.Mode (AP (File))); - end Mode; - - ---------- - -- Name -- - ---------- - - function Name (File : File_Type) return String is - begin - return FIO.Name (AP (File)); - end Name; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line - (File : File_Type; - Spacing : Positive_Count := 1) - is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not Spacing'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - - for K in 1 .. Spacing loop - Putc (LM, File); - File.Line := File.Line + 1; - - if File.Page_Length /= 0 - and then File.Line > File.Page_Length - then - Putc (PM, File); - File.Line := 1; - File.Page := File.Page + 1; - end if; - end loop; - - File.Col := 1; - end New_Line; - - procedure New_Line (Spacing : Positive_Count := 1) is - begin - New_Line (Current_Out, Spacing); - end New_Line; - - -------------- - -- New_Page -- - -------------- - - procedure New_Page (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - - if File.Col /= 1 or else File.Line = 1 then - Putc (LM, File); - end if; - - Putc (PM, File); - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - end New_Page; - - procedure New_Page is - begin - New_Page (Current_Out); - end New_Page; - - ----------- - -- Nextc -- - ----------- - - function Nextc (File : File_Type) return int is - ch : int; - - begin - ch := fgetc (File.Stream); - - if ch = EOF then - if ferror (File.Stream) /= 0 then - raise Device_Error; - end if; - - else - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - - return ch; - end Nextc; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := "") - is - Dummy_File_Control_Block : Wide_Wide_Text_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => To_FCB (Mode), - Name => Name, - Form => Form, - Amethod => 'W', - Creat => False, - Text => True); - - File.Self := File; - Set_WCEM (File); - end Open; - - ---------- - -- Page -- - ---------- - - -- Note: we assume that it is impossible in practice for the page - -- to exceed the value of Count'Last, i.e. no check is required for - -- overflow raising layout error. - - function Page (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Page; - end Page; - - function Page return Positive_Count is - begin - return Page (Current_Out); - end Page; - - ----------------- - -- Page_Length -- - ----------------- - - function Page_Length (File : File_Type) return Count is - begin - FIO.Check_Write_Status (AP (File)); - return File.Page_Length; - end Page_Length; - - function Page_Length return Count is - begin - return Page_Length (Current_Out); - end Page_Length; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_Wide_Character) - is - procedure Out_Char (C : Character); - -- Procedure to output one character of a wide character sequence - - procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char); - - -------------- - -- Out_Char -- - -------------- - - procedure Out_Char (C : Character) is - begin - Putc (Character'Pos (C), File); - end Out_Char; - - -- Start of processing for Put - - begin - FIO.Check_Write_Status (AP (File)); - WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method); - File.Col := File.Col + 1; - end Put; - - procedure Put (Item : Wide_Wide_Character) is - begin - Put (Current_Out, Item); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_Wide_String) - is - begin - for J in Item'Range loop - Put (File, Item (J)); - end loop; - end Put; - - procedure Put (Item : Wide_Wide_String) is - begin - Put (Current_Out, Item); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (File : File_Type; - Item : Wide_Wide_String) - is - begin - Put (File, Item); - New_Line (File); - end Put_Line; - - procedure Put_Line (Item : Wide_Wide_String) is - begin - Put (Current_Out, Item); - New_Line (Current_Out); - end Put_Line; - - ---------- - -- Putc -- - ---------- - - procedure Putc (ch : int; File : File_Type) is - begin - if fputc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end Putc; - - ---------- - -- Read -- - ---------- - - -- This is the primitive Stream Read routine, used when a Text_IO file - -- is treated directly as a stream using Text_IO.Streams.Stream. - - procedure Read - (File : in out Wide_Wide_Text_AFCB; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Discard_ch : int; - pragma Unreferenced (Discard_ch); - - begin - -- Need to deal with Before_Wide_Wide_Character ??? - - if File.Mode /= FCB.In_File then - raise Mode_Error; - end if; - - -- Deal with case where our logical and physical position do not match - -- because of being after an LM or LM-PM sequence when in fact we are - -- logically positioned before it. - - if File.Before_LM then - - -- If we are before a PM, then it is possible for a stream read - -- to leave us after the LM and before the PM, which is a bit - -- odd. The easiest way to deal with this is to unget the PM, - -- so we are indeed positioned between the characters. This way - -- further stream read operations will work correctly, and the - -- effect on text processing is a little weird, but what can - -- be expected if stream and text input are mixed this way? - - if File.Before_LM_PM then - Discard_ch := ungetc (PM, File.Stream); - File.Before_LM_PM := False; - end if; - - File.Before_LM := False; - - Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); - - if Item'Length = 1 then - Last := Item'Last; - - else - Last := - Item'First + - Stream_Element_Offset - (fread (buffer => Item'Address, - index => size_t (Item'First + 1), - size => 1, - count => Item'Length - 1, - stream => File.Stream)); - end if; - - return; - end if; - - -- Now we do the read. Since this is a text file, it is normally in - -- text mode, but stream data must be read in binary mode, so we - -- temporarily set binary mode for the read, resetting it after. - -- These calls have no effect in a system (like Unix) where there is - -- no distinction between text and binary files. - - set_binary_mode (fileno (File.Stream)); - - Last := - Item'First + - Stream_Element_Offset - (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; - - if Last < Item'Last then - if ferror (File.Stream) /= 0 then - raise Device_Error; - end if; - end if; - - set_text_mode (fileno (File.Stream)); - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset - (File : in out File_Type; - Mode : File_Mode) - is - begin - -- Don't allow change of mode for current file (RM A.10.2(5)) - - if (File = Current_In or else - File = Current_Out or else - File = Current_Error) - and then To_FCB (Mode) /= File.Mode - then - raise Mode_Error; - end if; - - Terminate_Line (File); - FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); - File.Page := 1; - File.Line := 1; - File.Col := 1; - File.Line_Length := 0; - File.Page_Length := 0; - File.Before_LM := False; - File.Before_LM_PM := False; - end Reset; - - procedure Reset (File : in out File_Type) is - begin - Terminate_Line (File); - FIO.Reset (AP (File)'Unrestricted_Access); - File.Page := 1; - File.Line := 1; - File.Col := 1; - File.Line_Length := 0; - File.Page_Length := 0; - File.Before_LM := False; - File.Before_LM_PM := False; - end Reset; - - ------------- - -- Set_Col -- - ------------- - - procedure Set_Col - (File : File_Type; - To : Positive_Count) - is - ch : int; - - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_File_Open (AP (File)); - - if To = File.Col then - return; - end if; - - if Mode (File) >= Out_File then - if File.Line_Length /= 0 and then To > File.Line_Length then - raise Layout_Error; - end if; - - if To < File.Col then - New_Line (File); - end if; - - while File.Col < To loop - Put (File, ' '); - end loop; - - else - loop - ch := Getc (File); - - if ch = EOF then - raise End_Error; - - elsif ch = LM then - File.Line := File.Line + 1; - File.Col := 1; - - elsif ch = PM and then File.Is_Regular_File then - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - - elsif To = File.Col then - Ungetc (ch, File); - return; - - else - File.Col := File.Col + 1; - end if; - end loop; - end if; - end Set_Col; - - procedure Set_Col (To : Positive_Count) is - begin - Set_Col (Current_Out, To); - end Set_Col; - - --------------- - -- Set_Error -- - --------------- - - procedure Set_Error (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - Current_Err := File; - end Set_Error; - - --------------- - -- Set_Input -- - --------------- - - procedure Set_Input (File : File_Type) is - begin - FIO.Check_Read_Status (AP (File)); - Current_In := File; - end Set_Input; - - -------------- - -- Set_Line -- - -------------- - - procedure Set_Line - (File : File_Type; - To : Positive_Count) - is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_File_Open (AP (File)); - - if To = File.Line then - return; - end if; - - if Mode (File) >= Out_File then - if File.Page_Length /= 0 and then To > File.Page_Length then - raise Layout_Error; - end if; - - if To < File.Line then - New_Page (File); - end if; - - while File.Line < To loop - New_Line (File); - end loop; - - else - while To /= File.Line loop - Skip_Line (File); - end loop; - end if; - end Set_Line; - - procedure Set_Line (To : Positive_Count) is - begin - Set_Line (Current_Out, To); - end Set_Line; - - --------------------- - -- Set_Line_Length -- - --------------------- - - procedure Set_Line_Length (File : File_Type; To : Count) is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - File.Line_Length := To; - end Set_Line_Length; - - procedure Set_Line_Length (To : Count) is - begin - Set_Line_Length (Current_Out, To); - end Set_Line_Length; - - ---------------- - -- Set_Output -- - ---------------- - - procedure Set_Output (File : File_Type) is - begin - FIO.Check_Write_Status (AP (File)); - Current_Out := File; - end Set_Output; - - --------------------- - -- Set_Page_Length -- - --------------------- - - procedure Set_Page_Length (File : File_Type; To : Count) is - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not To'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Write_Status (AP (File)); - File.Page_Length := To; - end Set_Page_Length; - - procedure Set_Page_Length (To : Count) is - begin - Set_Page_Length (Current_Out, To); - end Set_Page_Length; - - -------------- - -- Set_WCEM -- - -------------- - - procedure Set_WCEM (File : in out File_Type) is - Start : Natural; - Stop : Natural; - - begin - FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); - - if Start = 0 then - File.WC_Method := Default_WCEM; - - else - if Stop = Start then - for J in WC_Encoding_Letters'Range loop - if File.Form (Start) = WC_Encoding_Letters (J) then - File.WC_Method := J; - return; - end if; - end loop; - end if; - - Close (File); - raise Use_Error with "invalid WCEM form parameter"; - end if; - end Set_WCEM; - - --------------- - -- Skip_Line -- - --------------- - - procedure Skip_Line - (File : File_Type; - Spacing : Positive_Count := 1) - is - ch : int; - - begin - -- Raise Constraint_Error if out of range value. The reason for this - -- explicit test is that we don't want junk values around, even if - -- checks are off in the caller. - - if not Spacing'Valid then - raise Constraint_Error; - end if; - - FIO.Check_Read_Status (AP (File)); - - for L in 1 .. Spacing loop - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - - else - ch := Getc (File); - - -- If at end of file now, then immediately raise End_Error. Note - -- that we can never be positioned between a line mark and a page - -- mark, so if we are at the end of file, we cannot logically be - -- before the implicit page mark that is at the end of the file. - - -- For the same reason, we do not need an explicit check for a - -- page mark. If there is a FF in the middle of a line, the file - -- is not in canonical format and we do not care about the page - -- numbers for files other than ones in canonical format. - - if ch = EOF then - raise End_Error; - end if; - - -- If not at end of file, then loop till we get to an LM or EOF. - -- The latter case happens only in non-canonical files where the - -- last line is not terminated by LM, but we don't want to blow - -- up for such files, so we assume an implicit LM in this case. - - loop - exit when ch = LM or else ch = EOF; - ch := Getc (File); - end loop; - end if; - - -- We have got past a line mark, now, for a regular file only, - -- see if a page mark immediately follows this line mark and - -- if so, skip past the page mark as well. We do not do this - -- for non-regular files, since it would cause an undesirable - -- wait for an additional character. - - File.Col := 1; - File.Line := File.Line + 1; - - if File.Before_LM_PM then - File.Page := File.Page + 1; - File.Line := 1; - File.Before_LM_PM := False; - - elsif File.Is_Regular_File then - ch := Getc (File); - - -- Page mark can be explicit, or implied at the end of the file - - if (ch = PM or else ch = EOF) - and then File.Is_Regular_File - then - File.Page := File.Page + 1; - File.Line := 1; - else - Ungetc (ch, File); - end if; - end if; - end loop; - - File.Before_Wide_Wide_Character := False; - end Skip_Line; - - procedure Skip_Line (Spacing : Positive_Count := 1) is - begin - Skip_Line (Current_In, Spacing); - end Skip_Line; - - --------------- - -- Skip_Page -- - --------------- - - procedure Skip_Page (File : File_Type) is - ch : int; - - begin - FIO.Check_Read_Status (AP (File)); - - -- If at page mark already, just skip it - - if File.Before_LM_PM then - File.Before_LM := False; - File.Before_LM_PM := False; - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - return; - end if; - - -- This is a bit tricky, if we are logically before an LM then - -- it is not an error if we are at an end of file now, since we - -- are not really at it. - - if File.Before_LM then - File.Before_LM := False; - File.Before_LM_PM := False; - ch := Getc (File); - - -- Otherwise we do raise End_Error if we are at the end of file now - - else - ch := Getc (File); - - if ch = EOF then - raise End_Error; - end if; - end if; - - -- Now we can just rumble along to the next page mark, or to the - -- end of file, if that comes first. The latter case happens when - -- the page mark is implied at the end of file. - - loop - exit when ch = EOF - or else (ch = PM and then File.Is_Regular_File); - ch := Getc (File); - end loop; - - File.Page := File.Page + 1; - File.Line := 1; - File.Col := 1; - File.Before_Wide_Wide_Character := False; - end Skip_Page; - - procedure Skip_Page is - begin - Skip_Page (Current_In); - end Skip_Page; - - -------------------- - -- Standard_Error -- - -------------------- - - function Standard_Error return File_Type is - begin - return Standard_Err; - end Standard_Error; - - function Standard_Error return File_Access is - begin - return Standard_Err'Access; - end Standard_Error; - - -------------------- - -- Standard_Input -- - -------------------- - - function Standard_Input return File_Type is - begin - return Standard_In; - end Standard_Input; - - function Standard_Input return File_Access is - begin - return Standard_In'Access; - end Standard_Input; - - --------------------- - -- Standard_Output -- - --------------------- - - function Standard_Output return File_Type is - begin - return Standard_Out; - end Standard_Output; - - function Standard_Output return File_Access is - begin - return Standard_Out'Access; - end Standard_Output; - - -------------------- - -- Terminate_Line -- - -------------------- - - procedure Terminate_Line (File : File_Type) is - begin - FIO.Check_File_Open (AP (File)); - - -- For file other than In_File, test for needing to terminate last line - - if Mode (File) /= In_File then - - -- If not at start of line definition need new line - - if File.Col /= 1 then - New_Line (File); - - -- For files other than standard error and standard output, we - -- make sure that an empty file has a single line feed, so that - -- it is properly formatted. We avoid this for the standard files - -- because it is too much of a nuisance to have these odd line - -- feeds when nothing has been written to the file. - - elsif (File /= Standard_Err and then File /= Standard_Out) - and then (File.Line = 1 and then File.Page = 1) - then - New_Line (File); - end if; - end if; - end Terminate_Line; - - ------------ - -- Ungetc -- - ------------ - - procedure Ungetc (ch : int; File : File_Type) is - begin - if ch /= EOF then - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - end Ungetc; - - ----------- - -- Write -- - ----------- - - -- This is the primitive Stream Write routine, used when a Text_IO file - -- is treated directly as a stream using Text_IO.Streams.Stream. - - procedure Write - (File : in out Wide_Wide_Text_AFCB; - Item : Stream_Element_Array) - is - pragma Warnings (Off, File); - -- Because in this implementation we don't need IN OUT, we only read - - Siz : constant size_t := Item'Length; - - begin - if File.Mode = FCB.In_File then - raise Mode_Error; - end if; - - -- Now we do the write. Since this is a text file, it is normally in - -- text mode, but stream data must be written in binary mode, so we - -- temporarily set binary mode for the write, resetting it after. - -- These calls have no effect in a system (like Unix) where there is - -- no distinction between text and binary files. - - set_binary_mode (fileno (File.Stream)); - - if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then - raise Device_Error; - end if; - - set_text_mode (fileno (File.Stream)); - end Write; - -begin - -- Initialize Standard Files - - for J in WC_Encoding_Method loop - if WC_Encoding = WC_Encoding_Letters (J) then - Default_WCEM := J; - end if; - end loop; - - Initialize_Standard_Files; - - FIO.Chain_File (AP (Standard_In)); - FIO.Chain_File (AP (Standard_Out)); - FIO.Chain_File (AP (Standard_Err)); - -end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-ztexio.ads b/gcc/ada/a-ztexio.ads deleted file mode 100644 index ef90c92..0000000 --- a/gcc/ada/a-ztexio.ads +++ /dev/null @@ -1,497 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: the generic subpackages of Wide_Wide_Text_IO (Integer_IO, Float_IO, --- Fixed_IO, Modular_IO, Decimal_IO and Enumeration_IO) appear as private --- children in GNAT. These children are with'ed automatically if they are --- referenced, so this rearrangement is invisible to user programs, but has --- the advantage that only the needed parts of Wide_Wide_Text_IO are processed --- and loaded. - -with Ada.IO_Exceptions; -with Ada.Streams; - -with Interfaces.C_Streams; - -with System; -with System.File_Control_Block; -with System.WCh_Con; - -package Ada.Wide_Wide_Text_IO is - - type File_Type is limited private; - type File_Mode is (In_File, Out_File, Append_File); - - -- The following representation clause allows the use of unchecked - -- conversion for rapid translation between the File_Mode type - -- used in this package and System.File_IO. - - for File_Mode use - (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) - Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) - Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) - - type Count is range 0 .. Natural'Last; - -- The value of Count'Last must be large enough so that the assumption that - -- the Line, Column and Page counts can never exceed this value is valid. - - subtype Positive_Count is Count range 1 .. Count'Last; - - Unbounded : constant Count := 0; - -- Line and page length - - subtype Field is Integer range 0 .. 255; - -- Note: if for any reason, there is a need to increase this value, then it - -- will be necessary to change the corresponding value in System.Img_Real - -- in file s-imgrea.adb. - - subtype Number_Base is Integer range 2 .. 16; - - type Type_Set is (Lower_Case, Upper_Case); - - --------------------- - -- File Management -- - --------------------- - - procedure Create - (File : in out File_Type; - Mode : File_Mode := Out_File; - Name : String := ""; - Form : String := ""); - - procedure Open - (File : in out File_Type; - Mode : File_Mode; - Name : String; - Form : String := ""); - - procedure Close (File : in out File_Type); - procedure Delete (File : in out File_Type); - procedure Reset (File : in out File_Type; Mode : File_Mode); - procedure Reset (File : in out File_Type); - - function Mode (File : File_Type) return File_Mode; - function Name (File : File_Type) return String; - function Form (File : File_Type) return String; - - function Is_Open (File : File_Type) return Boolean; - - ------------------------------------------------------ - -- Control of default input, output and error files -- - ------------------------------------------------------ - - procedure Set_Input (File : File_Type); - procedure Set_Output (File : File_Type); - procedure Set_Error (File : File_Type); - - function Standard_Input return File_Type; - function Standard_Output return File_Type; - function Standard_Error return File_Type; - - function Current_Input return File_Type; - function Current_Output return File_Type; - function Current_Error return File_Type; - - type File_Access is access constant File_Type; - - function Standard_Input return File_Access; - function Standard_Output return File_Access; - function Standard_Error return File_Access; - - function Current_Input return File_Access; - function Current_Output return File_Access; - function Current_Error return File_Access; - - -------------------- - -- Buffer control -- - -------------------- - - -- Note: The parameter file is in out in the RM, but as pointed out - -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. - - procedure Flush (File : File_Type); - procedure Flush; - - -------------------------------------------- - -- Specification of line and page lengths -- - -------------------------------------------- - - procedure Set_Line_Length (File : File_Type; To : Count); - procedure Set_Line_Length (To : Count); - - procedure Set_Page_Length (File : File_Type; To : Count); - procedure Set_Page_Length (To : Count); - - function Line_Length (File : File_Type) return Count; - function Line_Length return Count; - - function Page_Length (File : File_Type) return Count; - function Page_Length return Count; - - ------------------------------------ - -- Column, Line, and Page Control -- - ------------------------------------ - - procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure New_Line (Spacing : Positive_Count := 1); - - procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); - procedure Skip_Line (Spacing : Positive_Count := 1); - - function End_Of_Line (File : File_Type) return Boolean; - function End_Of_Line return Boolean; - - procedure New_Page (File : File_Type); - procedure New_Page; - - procedure Skip_Page (File : File_Type); - procedure Skip_Page; - - function End_Of_Page (File : File_Type) return Boolean; - function End_Of_Page return Boolean; - - function End_Of_File (File : File_Type) return Boolean; - function End_Of_File return Boolean; - - procedure Set_Col (File : File_Type; To : Positive_Count); - procedure Set_Col (To : Positive_Count); - - procedure Set_Line (File : File_Type; To : Positive_Count); - procedure Set_Line (To : Positive_Count); - - function Col (File : File_Type) return Positive_Count; - function Col return Positive_Count; - - function Line (File : File_Type) return Positive_Count; - function Line return Positive_Count; - - function Page (File : File_Type) return Positive_Count; - function Page return Positive_Count; - - ---------------------------- - -- Character Input-Output -- - ---------------------------- - - procedure Get (File : File_Type; Item : out Wide_Wide_Character); - procedure Get (Item : out Wide_Wide_Character); - procedure Put (File : File_Type; Item : Wide_Wide_Character); - procedure Put (Item : Wide_Wide_Character); - - procedure Look_Ahead - (File : File_Type; - Item : out Wide_Wide_Character; - End_Of_Line : out Boolean); - - procedure Look_Ahead - (Item : out Wide_Wide_Character; - End_Of_Line : out Boolean); - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Wide_Character); - - procedure Get_Immediate - (Item : out Wide_Wide_Character); - - procedure Get_Immediate - (File : File_Type; - Item : out Wide_Wide_Character; - Available : out Boolean); - - procedure Get_Immediate - (Item : out Wide_Wide_Character; - Available : out Boolean); - - ------------------------- - -- String Input-Output -- - ------------------------- - - procedure Get (File : File_Type; Item : out Wide_Wide_String); - procedure Get (Item : out Wide_Wide_String); - procedure Put (File : File_Type; Item : Wide_Wide_String); - procedure Put (Item : Wide_Wide_String); - - procedure Get_Line - (File : File_Type; - Item : out Wide_Wide_String; - Last : out Natural); - - function Get_Line (File : File_Type) return Wide_Wide_String; - pragma Ada_05 (Get_Line); - - function Get_Line return Wide_Wide_String; - pragma Ada_05 (Get_Line); - - procedure Get_Line - (Item : out Wide_Wide_String; - Last : out Natural); - - procedure Put_Line - (File : File_Type; - Item : Wide_Wide_String); - - procedure Put_Line - (Item : Wide_Wide_String); - - --------------------------------------- - -- Generic packages for Input-Output -- - --------------------------------------- - - -- The generic packages: - - -- Ada.Wide_Wide_Text_IO.Integer_IO - -- Ada.Wide_Wide_Text_IO.Modular_IO - -- Ada.Wide_Wide_Text_IO.Float_IO - -- Ada.Wide_Wide_Text_IO.Fixed_IO - -- Ada.Wide_Wide_Text_IO.Decimal_IO - -- Ada.Wide_Wide_Text_IO.Enumeration_IO - - -- are implemented as separate child packages in GNAT, so the - -- spec and body of these packages are to be found in separate - -- child units. This implementation detail is hidden from the - -- Ada programmer by special circuitry in the compiler that - -- treats these child packages as though they were nested in - -- Text_IO. The advantage of this special processing is that - -- the subsidiary routines needed if these generics are used - -- are not loaded when they are not used. - - ---------------- - -- Exceptions -- - ---------------- - - Status_Error : exception renames IO_Exceptions.Status_Error; - Mode_Error : exception renames IO_Exceptions.Mode_Error; - Name_Error : exception renames IO_Exceptions.Name_Error; - Use_Error : exception renames IO_Exceptions.Use_Error; - Device_Error : exception renames IO_Exceptions.Device_Error; - End_Error : exception renames IO_Exceptions.End_Error; - Data_Error : exception renames IO_Exceptions.Data_Error; - Layout_Error : exception renames IO_Exceptions.Layout_Error; - -private - - -- The following procedures have a File_Type formal of mode IN OUT because - -- they may close the original file. The Close operation may raise an - -- exception, but in that case we want any assignment to the formal to - -- be effective anyway, so it must be passed by reference (or the caller - -- will be left with a dangling pointer). - - pragma Export_Procedure - (Internal => Close, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Delete, - External => "", - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type), - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type, File_Mode), - Mechanism => (File => Reference)); - - package WCh_Con renames System.WCh_Con; - - ----------------------------------- - -- Handling of Format Characters -- - ----------------------------------- - - -- Line marks are represented by the single character ASCII.LF (16#0A#). - -- In DOS and similar systems, underlying file translation takes care - -- of translating this to and from the standard CR/LF sequences used in - -- these operating systems to mark the end of a line. On output there is - -- always a line mark at the end of the last line, but on input, this - -- line mark can be omitted, and is implied by the end of file. - - -- Page marks are represented by the single character ASCII.FF (16#0C#), - -- The page mark at the end of the file may be omitted, and is normally - -- omitted on output unless an explicit New_Page call is made before - -- closing the file. No page mark is added when a file is appended to, - -- so, in accordance with the permission in (RM A.10.2(4)), there may - -- or may not be a page mark separating preexisting text in the file - -- from the new text to be written. - - -- A file mark is marked by the physical end of file. In DOS translation - -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the - -- physical end of file, so in effect this character is recognized as - -- marking the end of file in DOS and similar systems. - - LM : constant := Character'Pos (ASCII.LF); - -- Used as line mark - - PM : constant := Character'Pos (ASCII.FF); - -- Used as page mark, except at end of file where it is implied - - ------------------------------------------ - -- Wide_Wide_Text_IO File Control Block -- - ------------------------------------------ - - Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8; - -- This gets modified during initialization (see body) using the default - -- value established in the call to Set_Globals. - - package FCB renames System.File_Control_Block; - - type Wide_Wide_Text_AFCB is new FCB.AFCB with record - Page : Count := 1; - Line : Count := 1; - Col : Count := 1; - Line_Length : Count := 0; - Page_Length : Count := 0; - - Self : aliased File_Type; - -- Set to point to the containing Text_AFCB block. This is used to - -- implement the Current_{Error,Input,Output} functions which return - -- a File_Access, the file access value returned is a pointer to - -- the Self field of the corresponding file. - - Before_LM : Boolean := False; - -- This flag is used to deal with the anomalies introduced by the - -- peculiar definition of End_Of_File and End_Of_Page in Ada. These - -- functions require looking ahead more than one character. Since - -- there is no convenient way of backing up more than one character, - -- what we do is to leave ourselves positioned past the LM, but set - -- this flag, so that we know that from an Ada point of view we are - -- in front of the LM, not after it. A bit odd, but it works. - - Before_LM_PM : Boolean := False; - -- This flag similarly handles the case of being physically positioned - -- after a LM-PM sequence when logically we are before the LM-PM. This - -- flag can only be set if Before_LM is also set. - - WC_Method : WCh_Con.WC_Encoding_Method := Default_WCEM; - -- Encoding method to be used for this file - - Before_Wide_Wide_Character : Boolean := False; - -- This flag is set to indicate that a wide character in the input has - -- been read by Wide_Wide_Text_IO.Look_Ahead. If it is set to True, - -- then it means that the stream is logically positioned before the - -- character but is physically positioned after it. The character - -- involved must not be in the range 16#00#-16#7F#, i.e. if the flag is - -- set, then we know the next character has a code greater than 16#7F#, - -- and the value of this character is saved in - -- Saved_Wide_Wide_Character. - - Saved_Wide_Wide_Character : Wide_Wide_Character; - -- This field is valid only if Before_Wide_Wide_Character is set. It - -- contains a wide character read by Look_Ahead. If Look_Ahead - -- reads a character in the range 16#0000# to 16#007F#, then it - -- can use ungetc to put it back, but ungetc cannot be called - -- more than once, so for characters above this range, we don't - -- try to back up the file. Instead we save the character in this - -- field and set the flag Before_Wide_Wide_Character to indicate that - -- we are logically positioned before this character even though - -- the stream is physically positioned after it. - - end record; - - type File_Type is access all Wide_Wide_Text_AFCB; - - function AFCB_Allocate - (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr; - - procedure AFCB_Close (File : not null access Wide_Wide_Text_AFCB); - procedure AFCB_Free (File : not null access Wide_Wide_Text_AFCB); - - procedure Read - (File : in out Wide_Wide_Text_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Read operation used when Wide_Wide_Text_IO file is treated as a Stream - - procedure Write - (File : in out Wide_Wide_Text_AFCB; - Item : Ada.Streams.Stream_Element_Array); - -- Write operation used when Wide_Wide_Text_IO file is treated as a Stream - - ------------------------ - -- The Standard Files -- - ------------------------ - - Standard_Err_AFCB : aliased Wide_Wide_Text_AFCB; - Standard_In_AFCB : aliased Wide_Wide_Text_AFCB; - Standard_Out_AFCB : aliased Wide_Wide_Text_AFCB; - - Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; - Standard_In : aliased File_Type := Standard_In_AFCB'Access; - Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; - -- Standard files - - Current_In : aliased File_Type := Standard_In; - Current_Out : aliased File_Type := Standard_Out; - Current_Err : aliased File_Type := Standard_Err; - -- Current files - - procedure Initialize_Standard_Files; - -- Initializes the file control blocks for the standard files. Called from - -- the elaboration routine for this package, and from Reset_Standard_Files - -- in package Ada.Wide_Wide_Text_IO.Reset_Standard_Files. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- These subprograms are in the private part of the spec so that they can - -- be shared by the children of Ada.Text_IO.Wide_Wide_Text_IO. - - function Getc (File : File_Type) return Interfaces.C_Streams.int; - -- Gets next character from file, which has already been checked for being - -- in read status, and returns the character read if no error occurs. The - -- result is EOF if the end of file was read. - - procedure Get_Character (File : File_Type; Item : out Character); - -- This is essentially copy of Wide_Wide_Text_IO.Get. It obtains a single - -- obtains a single character from the input file File, and places it in - -- Item. This result may be the leading character of a Wide_Wide_Character - -- sequence, but that is up to the caller to deal with. - - function Get_Wide_Wide_Char - (C : Character; - File : File_Type) return Wide_Wide_Character; - -- This function is shared by Get and Get_Immediate to extract a wide - -- character value from the given File. The first byte has already been - -- read and is passed in C. The wide character value is returned as the - -- result, and the file pointer is bumped past the character. - - function Nextc (File : File_Type) return Interfaces.C_Streams.int; - -- Returns next character from file without skipping past it (i.e. it is a - -- combination of Getc followed by an Ungetc). - -end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/a-ztfiio.adb b/gcc/ada/a-ztfiio.adb deleted file mode 100644 index a4eaed9..0000000 --- a/gcc/ada/a-ztfiio.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Float_Aux; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Wide_Text_IO.Fixed_IO is - - subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - Aux.Get (TFT (File), Long_Long_Float (Item), Width); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - Aux.Gets (S, Long_Long_Float (Item), Last); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); - - for J in S'Range loop - To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-ztfiio.ads b/gcc/ada/a-ztfiio.ads deleted file mode 100644 index 498565c..0000000 --- a/gcc/ada/a-ztfiio.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Wide_Text_IO.Fixed_IO is a subpackage of --- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Fixed_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is delta <>; - -package Ada.Wide_Wide_Text_IO.Fixed_IO is - - Default_Fore : Field := Num'Fore; - Default_Aft : Field := Num'Aft; - Default_Exp : Field := 0; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/a-ztflau.adb b/gcc/ada/a-ztflau.adb deleted file mode 100644 index 55dd2da..0000000 --- a/gcc/ada/a-ztflau.adb +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; - -with System.Img_Real; use System.Img_Real; -with System.Val_Real; use System.Val_Real; - -package body Ada.Wide_Wide_Text_IO.Float_Aux is - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Long_Long_Float; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Real (File, Buf, Stop); - end if; - - Item := Scan_Real (Buf, Ptr'Access, Stop); - - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get; - - ---------- - -- Gets -- - ---------- - - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Real (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets; - - --------------- - -- Load_Real -- - --------------- - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Loaded : Boolean; - - begin - -- Skip initial blanks and load possible sign - - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - -- Case of .nnnn - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Otherwise must have digits to start - - else - Load_Digits (File, Buf, Ptr, Loaded); - - -- Hopeless junk if no digits loaded - - if not Loaded then - return; - end if; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - - -- Case of nnn#.xxx# - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '#', ':'); - - -- Case of nnn#xxx.[xxx]# or nnn#xxx# - - else - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Extended_Digits (File, Buf, Ptr); - end if; - - -- As usual, it seems strange to allow mixed base characters, - -- but that is what ACVC tests expect, see CE3804M, case (3). - - Load (File, Buf, Ptr, '#', ':'); - end if; - - -- Case of nnn.[nnn] or nnn - - else - -- Prevent the potential processing of '.' in cases where the - -- initial digits have a trailing underscore. - - if Buf (Ptr) = '_' then - return; - end if; - - Load (File, Buf, Ptr, '.', Loaded); - - if Loaded then - Load_Digits (File, Buf, Ptr); - end if; - end if; - end if; - - -- Deal with exponent - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end Load_Real; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); - Put_Item (File, Buf (1 .. Ptr)); - end Put; - - ---------- - -- Puts -- - ---------- - - procedure Puts - (To : out String; - Item : Long_Long_Float; - Aft : Field; - Exp : Field) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); - - if Ptr > To'Length then - raise Layout_Error; - - else - for J in 1 .. Ptr loop - To (To'Last - Ptr + J) := Buf (J); - end loop; - - for J in To'First .. To'Last - Ptr loop - To (J) := ' '; - end loop; - end if; - end Puts; - -end Ada.Wide_Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/a-ztflau.ads b/gcc/ada/a-ztflau.ads deleted file mode 100644 index 4323c49..0000000 --- a/gcc/ada/a-ztflau.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Wide_Text_IO.Float_IO that --- are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Float_IO itself, --- except that generic parameter Num has been replaced by Long_Long_Float, --- and the default parameters have been removed because they are supplied --- explicitly by the calls from within the generic template. Also used by --- Ada.Wide_Wide_Text_IO.Fixed_IO, and by Ada.Wide_Wide_Text_IO.Decimal_IO. - -private package Ada.Wide_Wide_Text_IO.Float_Aux is - - procedure Load_Real - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load a possibly signed - -- real literal value from the input file into Buf, starting at Ptr + 1. - - procedure Get - (File : File_Type; - Item : out Long_Long_Float; - Width : Field); - - procedure Gets - (From : String; - Item : out Long_Long_Float; - Last : out Positive); - - procedure Put - (File : File_Type; - Item : Long_Long_Float; - Fore : Field; - Aft : Field; - Exp : Field); - - procedure Puts - (To : out String; - Item : Long_Long_Float; - Aft : Field; - Exp : Field); - -end Ada.Wide_Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/a-ztflio.adb b/gcc/ada/a-ztflio.adb deleted file mode 100644 index 1530bcb..0000000 --- a/gcc/ada/a-ztflio.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Float_Aux; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Wide_Text_IO.Float_IO is - - subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - Aux.Get (TFT (File), Long_Long_Float (Item), Width); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - Aux.Gets (S, Long_Long_Float (Item), Last); - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); - end Put; - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - begin - Put (Current_Output, Item, Fore, Aft, Exp); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp) - is - S : String (To'First .. To'Last); - - begin - Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); - - for J in S'Range loop - To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-ztflio.ads b/gcc/ada/a-ztflio.ads deleted file mode 100644 index ca3f86b..0000000 --- a/gcc/ada/a-ztflio.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Wide_Text_IO.Float_IO is a subpackage of --- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Float_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is digits <>; - -package Ada.Wide_Wide_Text_IO.Float_IO is - - Default_Fore : Field := 2; - Default_Aft : Field := Num'Digits - 1; - Default_Exp : Field := 3; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Put - (Item : Num; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp); - -end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/a-ztgeau.adb b/gcc/ada/a-ztgeau.adb deleted file mode 100644 index 7f182a1..0000000 --- a/gcc/ada/a-ztgeau.adb +++ /dev/null @@ -1,528 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System.File_IO; -with System.File_Control_Block; - -package body Ada.Wide_Wide_Text_IO.Generic_Aux is - - package FIO renames System.File_IO; - package FCB renames System.File_Control_Block; - subtype AP is FCB.AFCB_Ptr; - - ------------------------ - -- Check_End_Of_Field -- - ------------------------ - - procedure Check_End_Of_Field - (Buf : String; - Stop : Integer; - Ptr : Integer; - Width : Field) - is - begin - if Ptr > Stop then - return; - - elsif Width = 0 then - raise Data_Error; - - else - for J in Ptr .. Stop loop - if not Is_Blank (Buf (J)) then - raise Data_Error; - end if; - end loop; - end if; - end Check_End_Of_Field; - - ----------------------- - -- Check_On_One_Line -- - ----------------------- - - procedure Check_On_One_Line - (File : File_Type; - Length : Integer) - is - begin - FIO.Check_Write_Status (AP (File)); - - if File.Line_Length /= 0 then - if Count (Length) > File.Line_Length then - raise Layout_Error; - elsif File.Col + Count (Length) > File.Line_Length + 1 then - New_Line (File); - end if; - end if; - end Check_On_One_Line; - - -------------- - -- Is_Blank -- - -------------- - - function Is_Blank (C : Character) return Boolean is - begin - return C = ' ' or else C = ASCII.HT; - end Is_Blank; - - ---------- - -- Load -- - ---------- - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character; - Loaded : out Boolean) - is - ch : int; - - begin - if File.Before_Wide_Wide_Character then - Loaded := False; - return; - - else - ch := Getc (File); - - if ch = Character'Pos (Char) then - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - else - Ungetc (ch, File); - Loaded := False; - end if; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character) - is - ch : int; - - begin - if File.Before_Wide_Wide_Character then - null; - - else - ch := Getc (File); - - if ch = Character'Pos (Char) then - Store_Char (File, ch, Buf, Ptr); - else - Ungetc (ch, File); - end if; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character; - Loaded : out Boolean) - is - ch : int; - - begin - if File.Before_Wide_Wide_Character then - Loaded := False; - return; - - else - ch := Getc (File); - - if ch = Character'Pos (Char1) - or else ch = Character'Pos (Char2) - then - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - else - Ungetc (ch, File); - Loaded := False; - end if; - end if; - end Load; - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character) - is - ch : int; - - begin - if File.Before_Wide_Wide_Character then - null; - - else - ch := Getc (File); - - if ch = Character'Pos (Char1) - or else ch = Character'Pos (Char2) - then - Store_Char (File, ch, Buf, Ptr); - else - Ungetc (ch, File); - end if; - end if; - end Load; - - ----------------- - -- Load_Digits -- - ----------------- - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean) - is - ch : int; - After_Digit : Boolean; - - begin - if File.Before_Wide_Wide_Character then - Loaded := False; - return; - - else - ch := Getc (File); - - if ch not in Character'Pos ('0') .. Character'Pos ('9') then - Loaded := False; - - else - Loaded := True; - After_Digit := True; - - loop - Store_Char (File, ch, Buf, Ptr); - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - end loop; - end if; - - Ungetc (ch, File); - end if; - end Load_Digits; - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer) - is - ch : int; - After_Digit : Boolean; - - begin - if File.Before_Wide_Wide_Character then - return; - - else - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - loop - Store_Char (File, ch, Buf, Ptr); - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - end loop; - end if; - - Ungetc (ch, File); - end if; - end Load_Digits; - - -------------------------- - -- Load_Extended_Digits -- - -------------------------- - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean) - is - ch : int; - After_Digit : Boolean := False; - - begin - if File.Before_Wide_Wide_Character then - Loaded := False; - return; - - else - Loaded := False; - - loop - ch := Getc (File); - - if ch in Character'Pos ('0') .. Character'Pos ('9') - or else - ch in Character'Pos ('a') .. Character'Pos ('f') - or else - ch in Character'Pos ('A') .. Character'Pos ('F') - then - After_Digit := True; - - elsif ch = Character'Pos ('_') and then After_Digit then - After_Digit := False; - - else - exit; - end if; - - Store_Char (File, ch, Buf, Ptr); - Loaded := True; - end loop; - - Ungetc (ch, File); - end if; - end Load_Extended_Digits; - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer) - is - Junk : Boolean; - pragma Unreferenced (Junk); - begin - Load_Extended_Digits (File, Buf, Ptr, Junk); - end Load_Extended_Digits; - - --------------- - -- Load_Skip -- - --------------- - - procedure Load_Skip (File : File_Type) is - C : Character; - - begin - FIO.Check_Read_Status (AP (File)); - - -- We need to explicitly test for the case of being before a wide - -- character (greater than 16#7F#). Since no such character can - -- ever legitimately be a valid numeric character, we can - -- immediately signal Data_Error. - - if File.Before_Wide_Wide_Character then - raise Data_Error; - end if; - - -- Otherwise loop till we find a non-blank character (note that as - -- usual in Wide_Wide_Text_IO, blank includes horizontal tab). Note that - -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately. - - loop - Get_Character (File, C); - exit when not Is_Blank (C); - end loop; - - Ungetc (Character'Pos (C), File); - File.Col := File.Col - 1; - end Load_Skip; - - ---------------- - -- Load_Width -- - ---------------- - - procedure Load_Width - (File : File_Type; - Width : Field; - Buf : out String; - Ptr : in out Integer) - is - ch : int; - WC : Wide_Wide_Character; - - Bad_Wide_Wide_C : Boolean := False; - -- Set True if one of the characters read is not in range of type - -- Character. This is always a Data_Error, but we do not signal it - -- right away, since we have to read the full number of characters. - - begin - FIO.Check_Read_Status (AP (File)); - - -- If we are immediately before a line mark, then we have no characters. - -- This is always a data error, so we may as well raise it right away. - - if File.Before_LM then - raise Data_Error; - - else - for J in 1 .. Width loop - if File.Before_Wide_Wide_Character then - Bad_Wide_Wide_C := True; - Store_Char (File, 0, Buf, Ptr); - File.Before_Wide_Wide_Character := False; - - else - ch := Getc (File); - - if ch = EOF then - exit; - - elsif ch = LM then - Ungetc (ch, File); - exit; - - else - WC := Get_Wide_Wide_Char (Character'Val (ch), File); - ch := Wide_Wide_Character'Pos (WC); - - if ch > 255 then - Bad_Wide_Wide_C := True; - ch := 0; - end if; - - Store_Char (File, ch, Buf, Ptr); - end if; - end if; - end loop; - - if Bad_Wide_Wide_C then - raise Data_Error; - end if; - end if; - end Load_Width; - - -------------- - -- Put_Item -- - -------------- - - procedure Put_Item (File : File_Type; Str : String) is - begin - Check_On_One_Line (File, Str'Length); - - for J in Str'Range loop - Put (File, Wide_Wide_Character'Val (Character'Pos (Str (J)))); - end loop; - end Put_Item; - - ---------------- - -- Store_Char -- - ---------------- - - procedure Store_Char - (File : File_Type; - ch : Integer; - Buf : out String; - Ptr : in out Integer) - is - begin - File.Col := File.Col + 1; - - if Ptr = Buf'Last then - raise Data_Error; - else - Ptr := Ptr + 1; - Buf (Ptr) := Character'Val (ch); - end if; - end Store_Char; - - ----------------- - -- String_Skip -- - ----------------- - - procedure String_Skip (Str : String; Ptr : out Integer) is - begin - -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. - -- It's too much trouble to make this silly case work, so we just raise - -- Program_Error with an appropriate message. We raise Program_Error - -- rather than Constraint_Error because we don't want this case to be - -- converted to Data_Error. - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - -- Normal case where Str'Last < Positive'Last - - Ptr := Str'First; - - loop - if Ptr > Str'Last then - raise End_Error; - - elsif not Is_Blank (Str (Ptr)) then - return; - - else - Ptr := Ptr + 1; - end if; - end loop; - end String_Skip; - - ------------ - -- Ungetc -- - ------------ - - procedure Ungetc (ch : int; File : File_Type) is - begin - if ch /= EOF then - if ungetc (ch, File.Stream) = EOF then - raise Device_Error; - end if; - end if; - end Ungetc; - -end Ada.Wide_Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/a-ztgeau.ads b/gcc/ada/a-ztgeau.ads deleted file mode 100644 index 26ca68e..0000000 --- a/gcc/ada/a-ztgeau.ads +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a set of auxiliary routines used by Wide_Wide_Text_IO --- generic children, including for reading and writing numeric strings. - --- Note: although this is the Wide version of the package, the interface here --- is still in terms of Character and String rather than Wide_Wide_Character --- and Wide_Wide_String, since all numeric strings are composed entirely of --- characters in the range of type Standard.Character, and the basic --- conversion routines work with Character rather than Wide_Wide_Character. - -package Ada.Wide_Wide_Text_IO.Generic_Aux is - - -- Note: for all the Load routines, File indicates the file to be read, - -- Buf is the string into which data is stored, Ptr is the index of the - -- last character stored so far, and is updated if additional characters - -- are stored. Data_Error is raised if the input overflows Buf. The only - -- Load routines that do a file status check are Load_Skip and Load_Width - -- so one of these two routines must be called first. - - procedure Check_End_Of_Field - (Buf : String; - Stop : Integer; - Ptr : Integer; - Width : Field); - -- This routine is used after doing a get operations on a numeric value. - -- Buf is the string being scanned, and Stop is the last character of - -- the field being scanned. Ptr is as set by the call to the scan routine - -- that scanned out the numeric value, i.e. it points one past the last - -- character scanned, and Width is the width parameter from the Get call. - -- - -- There are two cases, if Width is non-zero, then a check is made that - -- the remainder of the field is all blanks. If Width is zero, then it - -- means that the scan routine scanned out only part of the field. We - -- have already scanned out the field that the ACVC tests seem to expect - -- us to read (even if it does not follow the syntax of the type being - -- scanned, e.g. allowing negative exponents in integers, and underscores - -- at the end of the string), so we just raise Data_Error. - - procedure Check_On_One_Line (File : File_Type; Length : Integer); - -- Check to see if item of length Integer characters can fit on - -- current line. Call New_Line if not, first checking that the - -- line length can accommodate Length characters, raise Layout_Error - -- if item is too large for a single line. - - function Is_Blank (C : Character) return Boolean; - -- Determines if C is a blank (space or tab) - - procedure Load_Width - (File : File_Type; - Width : Field; - Buf : out String; - Ptr : in out Integer); - -- Loads exactly Width characters, unless a line mark is encountered first - - procedure Load_Skip (File : File_Type); - -- Skips leading blanks and line and page marks, if the end of file is - -- read without finding a non-blank character, then End_Error is raised. - -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character; - Loaded : out Boolean); - -- If next character is Char, loads it, otherwise no characters are loaded - -- Loaded is set to indicate whether or not the character was found. - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char : Character); - -- Same as above, but no indication if character is loaded - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character; - Loaded : out Boolean); - -- If next character is Char1 or Char2, loads it, otherwise no characters - -- are loaded. Loaded is set to indicate whether or not one of the two - -- characters was found. - - procedure Load - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Char1 : Character; - Char2 : Character); - -- Same as above, but no indication if character is loaded - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean); - -- Loads a sequence of zero or more decimal digits. Loaded is set if - -- at least one digit is loaded. - - procedure Load_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer); - -- Same as above, but no indication if character is loaded - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer; - Loaded : out Boolean); - -- Like Load_Digits, but also allows extended digits a-f and A-F - - procedure Load_Extended_Digits - (File : File_Type; - Buf : out String; - Ptr : in out Integer); - -- Same as above, but no indication if character is loaded - - procedure Put_Item (File : File_Type; Str : String); - -- This routine is like Wide_Wide_Text_IO.Put, except that it checks for - -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used - -- for all output of numeric values and of enumeration values. Note that - -- the buffer is of type String. Put_Item deals with converting this to - -- Wide_Wide_Characters as required. - - procedure Store_Char - (File : File_Type; - ch : Integer; - Buf : out String; - Ptr : in out Integer); - -- Store a single character in buffer, checking for overflow and - -- adjusting the column number in the file to reflect the fact - -- that a character has been acquired from the input stream. - -- The pos value of the character to store is in ch on entry. - - procedure String_Skip (Str : String; Ptr : out Integer); - -- Used in the Get from string procedures to skip leading blanks in the - -- string. Ptr is set to the index of the first non-blank. If the string - -- is all blanks, then the excption End_Error is raised, Note that blank - -- is defined as a space or horizontal tab (RM A.10.6(5)). - - procedure Ungetc (ch : Integer; File : File_Type); - -- Pushes back character into stream, using ungetc. The caller has - -- checked that the file is in read status. Device_Error is raised - -- if the character cannot be pushed back. An attempt to push back - -- an end of file (EOF) is ignored. - -private - pragma Inline (Is_Blank); - -end Ada.Wide_Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/a-ztinau.adb b/gcc/ada/a-ztinau.adb deleted file mode 100644 index 735e51f..0000000 --- a/gcc/ada/a-ztinau.adb +++ /dev/null @@ -1,295 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Int; use System.Img_Int; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLI; use System.Img_LLI; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Int; use System.Val_Int; -with System.Val_LLI; use System.Val_LLI; - -package body Ada.Wide_Wide_Text_IO.Integer_Aux is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- integer literal value from the input file into Buf, starting at Ptr + 1. - -- On return, Ptr is set to the last character stored. - - ------------- - -- Get_Int -- - ------------- - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Int; - - ------------- - -- Get_LLI -- - ------------- - - procedure Get_LLI - (File : File_Type; - Item : out Long_Long_Integer; - Width : Field) - is - Buf : String (1 .. Field'Last); - Ptr : aliased Integer := 1; - Stop : Integer := 0; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Integer (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLI; - - -------------- - -- Gets_Int -- - -------------- - - procedure Gets_Int - (From : String; - Item : out Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Int; - - -------------- - -- Gets_LLI -- - -------------- - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLI; - - ------------------ - -- Load_Integer -- - ------------------ - - procedure Load_Integer - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - Load (File, Buf, Ptr, '+', '-'); - - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Integer; - - ------------- - -- Put_Int -- - ------------- - - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Int; - - ------------- - -- Put_LLI -- - ------------- - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Integer (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLI; - - -------------- - -- Puts_Int -- - -------------- - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Int; - - -------------- - -- Puts_LLI -- - -------------- - - procedure Puts_LLI - (To : out String; - Item : Long_Long_Integer; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLI; - -end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/a-ztinau.ads b/gcc/ada/a-ztinau.ads deleted file mode 100644 index 8c041bf..0000000 --- a/gcc/ada/a-ztinau.ads +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO --- that are shared among separate instantiations of this package. The routines --- in this package are identical semantically to those in Integer_IO itself, --- except that the generic parameter Num has been replaced by Integer or --- Long_Long_Integer, and the default parameters have been removed because --- they are supplied explicitly by the calls from within the generic template. - -private package Ada.Wide_Wide_Text_IO.Integer_Aux is - - procedure Get_Int - (File : File_Type; - Item : out Integer; - Width : Field); - - procedure Get_LLI - (File : File_Type; - Item : out Long_Long_Integer; - Width : Field); - - procedure Gets_Int - (From : String; - Item : out Integer; - Last : out Positive); - - procedure Gets_LLI - (From : String; - Item : out Long_Long_Integer; - Last : out Positive); - - procedure Put_Int - (File : File_Type; - Item : Integer; - Width : Field; - Base : Number_Base); - - procedure Put_LLI - (File : File_Type; - Item : Long_Long_Integer; - Width : Field; - Base : Number_Base); - - procedure Puts_Int - (To : out String; - Item : Integer; - Base : Number_Base); - - procedure Puts_LLI - (To : out String; - Item : Long_Long_Integer; - Base : Number_Base); - -end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/a-ztinio.adb b/gcc/ada/a-ztinio.adb deleted file mode 100644 index 93e4d28..0000000 --- a/gcc/ada/a-ztinio.adb +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Integer_Aux; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Wide_Text_IO.Integer_IO is - - Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; - -- Throughout this generic body, we distinguish between the case where type - -- Integer is acceptable, and where a Long_Long_Integer is needed. This - -- Boolean is used to test for these cases and since it is a constant, only - -- code for the relevant case will be included in the instance. - - subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Wide_Text_IO.Integer_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - if Need_LLI then - Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); - else - Aux.Get_Int (TFT (File), Integer (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - if Need_LLI then - Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); - else - Aux.Gets_Int (S, Integer (Item), Last); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Need_LLI then - Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); - else - Aux.Put_Int (TFT (File), Integer (Item), Width, Base); - end if; - end Put; - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - Put (Current_Output, Item, Width, Base); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Base : Number_Base := Default_Base) - is - S : String (To'First .. To'Last); - - begin - if Need_LLI then - Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); - else - Aux.Puts_Int (S, Integer (Item), Base); - end if; - - for J in S'Range loop - To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-ztinio.ads b/gcc/ada/a-ztinio.ads deleted file mode 100644 index 2434f8b3..0000000 --- a/gcc/ada/a-ztinio.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Wide_Text_IO.Integer_IO is a subpackage --- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Integer_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is range <>; - -package Ada.Wide_Wide_Text_IO.Integer_IO is - - Default_Width : Field := Num'Width; - Default_Base : Number_Base := 10; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Base : Number_Base := Default_Base); - -end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/a-ztmoau.adb b/gcc/ada/a-ztmoau.adb deleted file mode 100644 index dbcf378..0000000 --- a/gcc/ada/a-ztmoau.adb +++ /dev/null @@ -1,305 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; - -with System.Img_BIU; use System.Img_BIU; -with System.Img_Uns; use System.Img_Uns; -with System.Img_LLB; use System.Img_LLB; -with System.Img_LLU; use System.Img_LLU; -with System.Img_LLW; use System.Img_LLW; -with System.Img_WIU; use System.Img_WIU; -with System.Val_Uns; use System.Val_Uns; -with System.Val_LLU; use System.Val_LLU; - -package body Ada.Wide_Wide_Text_IO.Modular_Aux is - - use System.Unsigned_Types; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural); - -- This is an auxiliary routine that is used to load an possibly signed - -- modular literal value from the input file into Buf, starting at Ptr + 1. - -- Ptr is left set to the last character stored. - - ------------- - -- Get_LLU -- - ------------- - - procedure Get_LLU - (File : File_Type; - Item : out Long_Long_Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_LLU; - - ------------- - -- Get_Uns -- - ------------- - - procedure Get_Uns - (File : File_Type; - Item : out Unsigned; - Width : Field) - is - Buf : String (1 .. Field'Last); - Stop : Integer := 0; - Ptr : aliased Integer := 1; - - begin - if Width /= 0 then - Load_Width (File, Width, Buf, Stop); - String_Skip (Buf, Ptr); - else - Load_Modular (File, Buf, Stop); - end if; - - Item := Scan_Unsigned (Buf, Ptr'Access, Stop); - Check_End_Of_Field (Buf, Stop, Ptr, Width); - end Get_Uns; - - -------------- - -- Gets_LLU -- - -------------- - - procedure Gets_LLU - (From : String; - Item : out Long_Long_Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_LLU; - - -------------- - -- Gets_Uns -- - -------------- - - procedure Gets_Uns - (From : String; - Item : out Unsigned; - Last : out Positive) - is - Pos : aliased Integer; - - begin - String_Skip (From, Pos); - Item := Scan_Unsigned (From, Pos'Access, From'Last); - Last := Pos - 1; - - exception - when Constraint_Error => - raise Data_Error; - end Gets_Uns; - - ------------------ - -- Load_Modular -- - ------------------ - - procedure Load_Modular - (File : File_Type; - Buf : out String; - Ptr : in out Natural) - is - Hash_Loc : Natural; - Loaded : Boolean; - - begin - Load_Skip (File); - - -- Note: it is a bit strange to allow a minus sign here, but it seems - -- consistent with the general behavior expected by the ACVC tests - -- which is to scan past junk and then signal data error, see ACVC - -- test CE3704F, case (6), which is for signed integer exponents, - -- which seems a similar case. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr, Loaded); - - if Loaded then - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - Load (File, Buf, Ptr, '#', ':', Loaded); - - if Loaded then - Hash_Loc := Ptr; - Load_Extended_Digits (File, Buf, Ptr); - Load (File, Buf, Ptr, Buf (Hash_Loc)); - end if; - - Load (File, Buf, Ptr, 'E', 'e', Loaded); - - if Loaded then - - -- Note: it is strange to allow a minus sign, since the syntax - -- does not, but that is what ACVC test CE3704F, case (6) wants - -- for the signed case, and there seems no good reason to treat - -- exponents differently for the signed and unsigned cases. - - Load (File, Buf, Ptr, '+', '-'); - Load_Digits (File, Buf, Ptr); - end if; - end if; - end Load_Modular; - - ------------- - -- Put_LLU -- - ------------- - - procedure Put_LLU - (File : File_Type; - Item : Long_Long_Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_LLU; - - ------------- - -- Put_Uns -- - ------------- - - procedure Put_Uns - (File : File_Type; - Item : Unsigned; - Width : Field; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 and then Width = 0 then - Set_Image_Unsigned (Item, Buf, Ptr); - elsif Base = 10 then - Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); - end if; - - Put_Item (File, Buf (1 .. Ptr)); - end Put_Uns; - - -------------- - -- Puts_LLU -- - -------------- - - procedure Puts_LLU - (To : out String; - Item : Long_Long_Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_LLU; - - -------------- - -- Puts_Uns -- - -------------- - - procedure Puts_Uns - (To : out String; - Item : Unsigned; - Base : Number_Base) - is - Buf : String (1 .. Field'Last); - Ptr : Natural := 0; - - begin - if Base = 10 then - Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); - else - Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); - end if; - - if Ptr > To'Length then - raise Layout_Error; - else - To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); - end if; - end Puts_Uns; - -end Ada.Wide_Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/a-ztmoau.ads b/gcc/ada/a-ztmoau.ads deleted file mode 100644 index 0caffa0..0000000 --- a/gcc/ada/a-ztmoau.ads +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for Ada.Wide_Wide_Text_IO.Modular_IO --- that are shared among separate instantiations of this package. The --- routines in this package are identical semantically to those in Modular_IO --- itself, except that the generic parameter Num has been replaced by --- Unsigned or Long_Long_Unsigned, and the default parameters have been --- removed because they are supplied explicitly by the calls from within the --- generic template. - -with System.Unsigned_Types; - -private package Ada.Wide_Wide_Text_IO.Modular_Aux is - - package U renames System.Unsigned_Types; - - procedure Get_Uns - (File : File_Type; - Item : out U.Unsigned; - Width : Field); - - procedure Get_LLU - (File : File_Type; - Item : out U.Long_Long_Unsigned; - Width : Field); - - procedure Gets_Uns - (From : String; - Item : out U.Unsigned; - Last : out Positive); - - procedure Gets_LLU - (From : String; - Item : out U.Long_Long_Unsigned; - Last : out Positive); - - procedure Put_Uns - (File : File_Type; - Item : U.Unsigned; - Width : Field; - Base : Number_Base); - - procedure Put_LLU - (File : File_Type; - Item : U.Long_Long_Unsigned; - Width : Field; - Base : Number_Base); - - procedure Puts_Uns - (To : out String; - Item : U.Unsigned; - Base : Number_Base); - - procedure Puts_LLU - (To : out String; - Item : U.Long_Long_Unsigned; - Base : Number_Base); - -end Ada.Wide_Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/a-ztmoio.adb b/gcc/ada/a-ztmoio.adb deleted file mode 100644 index 041f8dc..0000000 --- a/gcc/ada/a-ztmoio.adb +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO.Modular_Aux; - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_WtS; use System.WCh_WtS; - -package body Ada.Wide_Wide_Text_IO.Modular_IO is - - subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; - -- File type required for calls to routines in Aux - - package Aux renames Ada.Wide_Wide_Text_IO.Modular_Aux; - - --------- - -- Get -- - --------- - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0) - is - begin - if Num'Size > Unsigned'Size then - Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); - else - Aux.Get_Uns (TFT (File), Unsigned (Item), Width); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - procedure Get - (Item : out Num; - Width : Field := 0) - is - begin - Get (Current_Input, Item, Width); - end Get; - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive) - is - S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); - -- String on which we do the actual conversion. Note that the method - -- used for wide character encoding is irrelevant, since if there is - -- a character outside the Standard.Character range then the call to - -- Aux.Gets will raise Data_Error in any case. - - begin - if Num'Size > Unsigned'Size then - Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); - else - Aux.Gets_Uns (S, Unsigned (Item), Last); - end if; - - exception - when Constraint_Error => raise Data_Error; - end Get; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - if Num'Size > Unsigned'Size then - Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); - else - Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); - end if; - end Put; - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base) - is - begin - Put (Current_Output, Item, Width, Base); - end Put; - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Base : Number_Base := Default_Base) - is - S : String (To'First .. To'Last); - - begin - if Num'Size > Unsigned'Size then - Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); - else - Aux.Puts_Uns (S, Unsigned (Item), Base); - end if; - - for J in S'Range loop - To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); - end loop; - end Put; - -end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-ztmoio.ads b/gcc/ada/a-ztmoio.ads deleted file mode 100644 index 11aeaef..0000000 --- a/gcc/ada/a-ztmoio.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- In Ada 95, the package Ada.Wide_Wide_Text_IO.Modular_IO is a subpackage --- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading --- the necessary code if Modular_IO is not instantiated. See the routine --- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up --- the difference in semantics so that it is invisible to the Ada programmer. - -private generic - type Num is mod <>; - -package Ada.Wide_Wide_Text_IO.Modular_IO is - - Default_Width : Field := Num'Width; - Default_Base : Number_Base := 10; - - procedure Get - (File : File_Type; - Item : out Num; - Width : Field := 0); - - procedure Get - (Item : out Num; - Width : Field := 0); - - procedure Put - (File : File_Type; - Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Put - (Item : Num; - Width : Field := Default_Width; - Base : Number_Base := Default_Base); - - procedure Get - (From : Wide_Wide_String; - Item : out Num; - Last : out Positive); - - procedure Put - (To : out Wide_Wide_String; - Item : Num; - Base : Number_Base := Default_Base); - -end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/a-zttest.adb b/gcc/ada/a-zttest.adb deleted file mode 100644 index c4626a8..0000000 --- a/gcc/ada/a-zttest.adb +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.File_IO; - -package body Ada.Wide_Wide_Text_IO.Text_Streams is - - ------------ - -- Stream -- - ------------ - - function Stream (File : File_Type) return Stream_Access is - begin - System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); - return Stream_Access (File); - end Stream; - -end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-zttest.ads b/gcc/ada/a-zttest.ads deleted file mode 100644 index 1599253..0000000 --- a/gcc/ada/a-zttest.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Streams; - -package Ada.Wide_Wide_Text_IO.Text_Streams is - - type Stream_Access is access all Streams.Root_Stream_Type'Class; - - function Stream (File : File_Type) return Stream_Access; - -end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/a-zzboio.adb b/gcc/ada/a-zzboio.adb deleted file mode 100644 index c1efb2f..0000000 --- a/gcc/ada/a-zzboio.adb +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_BOUNDED_IO -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; -with Ada.Unchecked_Deallocation; - -package body Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO is - - type Wide_Wide_String_Access is access all Wide_Wide_String; - - procedure Free (WWSA : in out Wide_Wide_String_Access); - -- Perform an unchecked deallocation of a non-null string - - ---------- - -- Free -- - ---------- - - procedure Free (WWSA : in out Wide_Wide_String_Access) is - Null_Wide_Wide_String : constant Wide_Wide_String := ""; - - procedure Deallocate is - new Ada.Unchecked_Deallocation ( - Wide_Wide_String, Wide_Wide_String_Access); - - begin - -- Do not try to free statically allocated null string - - if WWSA.all /= Null_Wide_Wide_String then - Deallocate (WWSA); - end if; - end Free; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line return Wide_Wide_Bounded.Bounded_Wide_Wide_String is - begin - return Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Get_Line); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - function Get_Line - (File : File_Type) return Wide_Wide_Bounded.Bounded_Wide_Wide_String - is - begin - return Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Get_Line (File)); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String) - is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_Wide_String_Access; - Str2 : Wide_Wide_String_Access; - - begin - Get_Line (Buffer, Last); - Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (Buffer, Last); - Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); - Free (Str1); - Str1 := Str2; - end loop; - - Item := Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Str1.all); - end Get_Line; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (File : File_Type; - Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String) - is - Buffer : Wide_Wide_String (1 .. 1000); - Last : Natural; - Str1 : Wide_Wide_String_Access; - Str2 : Wide_Wide_String_Access; - - begin - Get_Line (File, Buffer, Last); - Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); - - while Last = Buffer'Last loop - Get_Line (File, Buffer, Last); - Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); - Free (Str1); - Str1 := Str2; - end loop; - - Item := Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Str1.all); - end Get_Line; - - --------- - -- Put -- - --------- - - procedure Put - (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) - is - begin - Put (Wide_Wide_Bounded.To_Wide_Wide_String (Item)); - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) - is - begin - Put (File, Wide_Wide_Bounded.To_Wide_Wide_String (Item)); - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) - is - begin - Put_Line (Wide_Wide_Bounded.To_Wide_Wide_String (Item)); - end Put_Line; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (File : File_Type; - Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) - is - begin - Put_Line (File, Wide_Wide_Bounded.To_Wide_Wide_String (Item)); - end Put_Line; - -end Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO; diff --git a/gcc/ada/a-zzboio.ads b/gcc/ada/a-zzboio.ads deleted file mode 100644 index 68157e9..0000000 --- a/gcc/ada/a-zzboio.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_BOUNDED_IO -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Wide_Wide_Bounded; - -generic - with package Wide_Wide_Bounded is - new Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length (<>); - -package Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO is - - function Get_Line return Wide_Wide_Bounded.Bounded_Wide_Wide_String; - - function Get_Line - (File : File_Type) return Wide_Wide_Bounded.Bounded_Wide_Wide_String; - - procedure Get_Line - (Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String); - - procedure Get_Line - (File : File_Type; - Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String); - - procedure Put - (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); - - procedure Put - (File : File_Type; - Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); - - procedure Put_Line - (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); - - procedure Put_Line - (File : File_Type; - Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); - -end Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO; diff --git a/gcc/ada/a-zzunio.ads b/gcc/ada/a-zzunio.ads deleted file mode 100644 index 1695b06..0000000 --- a/gcc/ada/a-zzunio.ads +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_UNBOUNDED_IO -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - --- Note: historically GNAT provided these subprograms as a child of the --- package Ada.Strings.Wide_Wide_Unbounded. So we implement this new Ada 2005 --- package by renaming the subprograms in that child. This is a more --- straightforward implementation anyway, since we need access to the --- internal representation of Unbounded_Wide_Wide_String. - -with Ada.Strings.Wide_Wide_Unbounded; -with Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; - -package Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO is - - procedure Put - (File : File_Type; - Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; - - procedure Put - (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; - - procedure Put_Line - (File : Wide_Wide_Text_IO.File_Type; - Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; - - procedure Put_Line - (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; - - function Get_Line - (File : File_Type) - return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; - - function Get_Line - return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; - - procedure Get_Line - (File : File_Type; - Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; - - procedure Get_Line - (Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) - renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; - -end Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO; diff --git a/gcc/ada/ada.ads b/gcc/ada/ada.ads deleted file mode 100644 index 4c2a3d0..0000000 --- a/gcc/ada/ada.ads +++ /dev/null @@ -1,20 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- A D A -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package Ada is - pragma No_Elaboration_Code_All; - pragma Pure; - -end Ada; diff --git a/gcc/ada/calendar.ads b/gcc/ada/calendar.ads deleted file mode 100644 index 7b13a6f..0000000 --- a/gcc/ada/calendar.ads +++ /dev/null @@ -1,18 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- C A L E N D A R -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Calendar; - -package Calendar renames Ada.Calendar; diff --git a/gcc/ada/directio.ads b/gcc/ada/directio.ads deleted file mode 100644 index 6c0f9f5..0000000 --- a/gcc/ada/directio.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- D I R E C T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Ada_2012; --- Explicit setting of Ada 2012 mode is required here, since we want to with a --- child unit (not possible in Ada 83 mode), and Direct_IO is not considered --- to be an internal unit that is automatically compiled in Ada 2012 mode --- (since a user is allowed to redeclare Direct_IO). - -with Ada.Direct_IO; - -generic package Direct_IO renames Ada.Direct_IO; diff --git a/gcc/ada/g-allein.ads b/gcc/ada/g-allein.ads deleted file mode 100644 index bbadf8e..0000000 --- a/gcc/ada/g-allein.ads +++ /dev/null @@ -1,304 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . L O W _ L E V E L _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit provides entities to be used internally by the units common to --- both bindings (Hard or Soft), and relevant to the interfacing with the --- underlying Low Level support. - -with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; -with GNAT.Altivec.Low_Level_Vectors; use GNAT.Altivec.Low_Level_Vectors; - -with Ada.Unchecked_Conversion; - -package GNAT.Altivec.Low_Level_Interface is - - ----------------------------------------- - -- Conversions between low level types -- - ----------------------------------------- - - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBC, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUC, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSC, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBS, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUS, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSS, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBI, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUI, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSI, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VF, LL_VBC); - function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VP, LL_VBC); - - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBC, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUC, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSC, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBS, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUS, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSS, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBI, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUI, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSI, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VF, LL_VUC); - function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VP, LL_VUC); - - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBC, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUC, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSC, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBS, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUS, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSS, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBI, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUI, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSI, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VF, LL_VSC); - function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VP, LL_VSC); - - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBC, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUC, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSC, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBS, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUS, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSS, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBI, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUI, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSI, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VF, LL_VBS); - function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VP, LL_VBS); - - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBC, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUC, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSC, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBS, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUS, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSS, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBI, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUI, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSI, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VF, LL_VUS); - function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VP, LL_VUS); - - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBC, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUC, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSC, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBS, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUS, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSS, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBI, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUI, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSI, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VF, LL_VSS); - function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VP, LL_VSS); - - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBC, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUC, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSC, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBS, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUS, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSS, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBI, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUI, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSI, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VF, LL_VBI); - function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VP, LL_VBI); - - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBC, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUC, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSC, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBS, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUS, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSS, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBI, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUI, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSI, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VF, LL_VUI); - function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VP, LL_VUI); - - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBC, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUC, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSC, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBS, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUS, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSS, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBI, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUI, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSI, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VF, LL_VSI); - function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VP, LL_VSI); - - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBC, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUC, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSC, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBS, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUS, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSS, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBI, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUI, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSI, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VF, LL_VF); - function To_LL_VF is new Ada.Unchecked_Conversion (LL_VP, LL_VF); - - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBC, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUC, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSC, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBS, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUS, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSS, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBI, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUI, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSI, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VF, LL_VP); - function To_LL_VP is new Ada.Unchecked_Conversion (LL_VP, LL_VP); - - ---------------------------------------------- - -- Conversions Between Pointer/Access Types -- - ---------------------------------------------- - - function To_PTR is - new Ada.Unchecked_Conversion (vector_unsigned_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_signed_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_bool_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_unsigned_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_signed_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_bool_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_unsigned_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_signed_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_bool_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_float_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (vector_pixel_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_bool_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_signed_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_unsigned_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_bool_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_signed_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_unsigned_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_bool_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_signed_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_unsigned_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_float_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_vector_pixel_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (c_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (signed_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (unsigned_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (signed_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (unsigned_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (signed_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (unsigned_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (signed_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (unsigned_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (float_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_signed_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_unsigned_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_signed_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_unsigned_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_signed_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_unsigned_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_signed_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_unsigned_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (const_float_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_signed_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_unsigned_char_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_signed_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_unsigned_short_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_signed_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_unsigned_int_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_signed_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_unsigned_long_ptr, c_ptr); - function To_PTR is - new Ada.Unchecked_Conversion (constv_float_ptr, c_ptr); - -end GNAT.Altivec.Low_Level_Interface; diff --git a/gcc/ada/g-alleve.adb b/gcc/ada/g-alleve.adb deleted file mode 100644 index 962401d..0000000 --- a/gcc/ada/g-alleve.adb +++ /dev/null @@ -1,4956 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- --- -- --- B o d y -- --- (Soft Binding Version) -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- ??? What is exactly needed for the soft case is still a bit unclear on --- some accounts. The expected functional equivalence with the Hard binding --- might require tricky things to be done on some targets. - --- Examples that come to mind are endianness variations or differences in the --- base FP model while we need the operation results to be the same as what --- the real AltiVec instructions would do on a PowerPC. - -with Ada.Numerics.Generic_Elementary_Functions; -with Interfaces; use Interfaces; -with System.Storage_Elements; use System.Storage_Elements; - -with GNAT.Altivec.Conversions; use GNAT.Altivec.Conversions; -with GNAT.Altivec.Low_Level_Interface; use GNAT.Altivec.Low_Level_Interface; - -package body GNAT.Altivec.Low_Level_Vectors is - - -- Pixel types. As defined in [PIM-2.1 Data types]: - -- A 16-bit pixel is 1/5/5/5; - -- A 32-bit pixel is 8/8/8/8. - -- We use the following records as an intermediate representation, to - -- ease computation. - - type Unsigned_1 is mod 2 ** 1; - type Unsigned_5 is mod 2 ** 5; - - type Pixel_16 is record - T : Unsigned_1; - R : Unsigned_5; - G : Unsigned_5; - B : Unsigned_5; - end record; - - type Pixel_32 is record - T : unsigned_char; - R : unsigned_char; - G : unsigned_char; - B : unsigned_char; - end record; - - -- Conversions to/from the pixel records to the integer types that are - -- actually stored into the pixel vectors: - - function To_Pixel (Source : unsigned_short) return Pixel_16; - function To_unsigned_short (Source : Pixel_16) return unsigned_short; - function To_Pixel (Source : unsigned_int) return Pixel_32; - function To_unsigned_int (Source : Pixel_32) return unsigned_int; - - package C_float_Operations is - new Ada.Numerics.Generic_Elementary_Functions (C_float); - - -- Model of the Vector Status and Control Register (VSCR), as - -- defined in [PIM-4.1 Vector Status and Control Register]: - - VSCR : unsigned_int; - - -- Positions of the flags in VSCR(0 .. 31): - - NJ_POS : constant := 15; - SAT_POS : constant := 31; - - -- To control overflows, integer operations are done on 64-bit types: - - SINT64_MIN : constant := -2 ** 63; - SINT64_MAX : constant := 2 ** 63 - 1; - UINT64_MAX : constant := 2 ** 64 - 1; - - type SI64 is range SINT64_MIN .. SINT64_MAX; - type UI64 is mod UINT64_MAX + 1; - - type F64 is digits 15 - range -16#0.FFFF_FFFF_FFFF_F8#E+256 .. 16#0.FFFF_FFFF_FFFF_F8#E+256; - - function Bits - (X : unsigned_int; - Low : Natural; - High : Natural) return unsigned_int; - - function Bits - (X : unsigned_short; - Low : Natural; - High : Natural) return unsigned_short; - - function Bits - (X : unsigned_char; - Low : Natural; - High : Natural) return unsigned_char; - - function Write_Bit - (X : unsigned_int; - Where : Natural; - Value : Unsigned_1) return unsigned_int; - - function Write_Bit - (X : unsigned_short; - Where : Natural; - Value : Unsigned_1) return unsigned_short; - - function Write_Bit - (X : unsigned_char; - Where : Natural; - Value : Unsigned_1) return unsigned_char; - - function NJ_Truncate (X : C_float) return C_float; - -- If NJ and A is a denormalized number, return zero - - function Bound_Align - (X : Integer_Address; - Y : Integer_Address) return Integer_Address; - -- [PIM-4.3 Notations and Conventions] - -- Align X in a y-byte boundary and return the result - - function Rnd_To_FP_Nearest (X : F64) return C_float; - -- [PIM-4.3 Notations and Conventions] - - function Rnd_To_FPI_Near (X : F64) return F64; - - function Rnd_To_FPI_Trunc (X : F64) return F64; - - function FP_Recip_Est (X : C_float) return C_float; - -- [PIM-4.3 Notations and Conventions] - -- 12-bit accurate floating-point estimate of 1/x - - function ROTL - (Value : unsigned_char; - Amount : Natural) return unsigned_char; - -- [PIM-4.3 Notations and Conventions] - -- Rotate left - - function ROTL - (Value : unsigned_short; - Amount : Natural) return unsigned_short; - - function ROTL - (Value : unsigned_int; - Amount : Natural) return unsigned_int; - - function Recip_SQRT_Est (X : C_float) return C_float; - - function Shift_Left - (Value : unsigned_char; - Amount : Natural) return unsigned_char; - -- [PIM-4.3 Notations and Conventions] - -- Shift left - - function Shift_Left - (Value : unsigned_short; - Amount : Natural) return unsigned_short; - - function Shift_Left - (Value : unsigned_int; - Amount : Natural) return unsigned_int; - - function Shift_Right - (Value : unsigned_char; - Amount : Natural) return unsigned_char; - -- [PIM-4.3 Notations and Conventions] - -- Shift Right - - function Shift_Right - (Value : unsigned_short; - Amount : Natural) return unsigned_short; - - function Shift_Right - (Value : unsigned_int; - Amount : Natural) return unsigned_int; - - Signed_Bool_False : constant := 0; - Signed_Bool_True : constant := -1; - - ------------------------------ - -- Signed_Operations (spec) -- - ------------------------------ - - generic - type Component_Type is range <>; - type Index_Type is range <>; - type Varray_Type is array (Index_Type) of Component_Type; - - package Signed_Operations is - - function Modular_Result (X : SI64) return Component_Type; - - function Saturate (X : SI64) return Component_Type; - - function Saturate (X : F64) return Component_Type; - - function Sign_Extend (X : c_int) return Component_Type; - -- [PIM-4.3 Notations and Conventions] - -- Sign-extend X - - function abs_vxi (A : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, abs_vxi); - - function abss_vxi (A : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, abss_vxi); - - function vaddsxs (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vaddsxs); - - function vavgsx (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vavgsx); - - function vcmpgtsx (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vcmpgtsx); - - function lvexx (A : c_long; B : c_ptr) return Varray_Type; - pragma Convention (LL_Altivec, lvexx); - - function vmaxsx (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vmaxsx); - - function vmrghx (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vmrghx); - - function vmrglx (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vmrglx); - - function vminsx (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vminsx); - - function vspltx (A : Varray_Type; B : c_int) return Varray_Type; - pragma Convention (LL_Altivec, vspltx); - - function vspltisx (A : c_int) return Varray_Type; - pragma Convention (LL_Altivec, vspltisx); - - type Bit_Operation is - access function - (Value : Component_Type; - Amount : Natural) return Component_Type; - - function vsrax - (A : Varray_Type; - B : Varray_Type; - Shift_Func : Bit_Operation) return Varray_Type; - - procedure stvexx (A : Varray_Type; B : c_int; C : c_ptr); - pragma Convention (LL_Altivec, stvexx); - - function vsubsxs (A : Varray_Type; B : Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vsubsxs); - - function Check_CR6 (A : c_int; D : Varray_Type) return c_int; - -- If D is the result of a vcmp operation and A the flag for - -- the kind of operation (e.g CR6_LT), check the predicate - -- that corresponds to this flag. - - end Signed_Operations; - - ------------------------------ - -- Signed_Operations (body) -- - ------------------------------ - - package body Signed_Operations is - - Bool_True : constant Component_Type := Signed_Bool_True; - Bool_False : constant Component_Type := Signed_Bool_False; - - Number_Of_Elements : constant Integer := - VECTOR_BIT / Component_Type'Size; - - -------------------- - -- Modular_Result -- - -------------------- - - function Modular_Result (X : SI64) return Component_Type is - D : Component_Type; - - begin - if X > 0 then - D := Component_Type (UI64 (X) - mod (UI64 (Component_Type'Last) + 1)); - else - D := Component_Type ((-(UI64 (-X) - mod (UI64 (Component_Type'Last) + 1)))); - end if; - - return D; - end Modular_Result; - - -------------- - -- Saturate -- - -------------- - - function Saturate (X : SI64) return Component_Type is - D : Component_Type; - - begin - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - D := Component_Type (SI64'Max - (SI64 (Component_Type'First), - SI64'Min - (SI64 (Component_Type'Last), - X))); - - if SI64 (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - function Saturate (X : F64) return Component_Type is - D : Component_Type; - - begin - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - D := Component_Type (F64'Max - (F64 (Component_Type'First), - F64'Min - (F64 (Component_Type'Last), - X))); - - if F64 (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - ----------------- - -- Sign_Extend -- - ----------------- - - function Sign_Extend (X : c_int) return Component_Type is - begin - -- X is usually a 5-bits literal. In the case of the simulator, - -- it is an integral parameter, so sign extension is straightforward. - - return Component_Type (X); - end Sign_Extend; - - ------------- - -- abs_vxi -- - ------------- - - function abs_vxi (A : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for K in Varray_Type'Range loop - D (K) := (if A (K) /= Component_Type'First - then abs (A (K)) else Component_Type'First); - end loop; - - return D; - end abs_vxi; - - -------------- - -- abss_vxi -- - -------------- - - function abss_vxi (A : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for K in Varray_Type'Range loop - D (K) := Saturate (abs (SI64 (A (K)))); - end loop; - - return D; - end abss_vxi; - - ------------- - -- vaddsxs -- - ------------- - - function vaddsxs (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := Saturate (SI64 (A (J)) + SI64 (B (J))); - end loop; - - return D; - end vaddsxs; - - ------------ - -- vavgsx -- - ------------ - - function vavgsx (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := Component_Type ((SI64 (A (J)) + SI64 (B (J)) + 1) / 2); - end loop; - - return D; - end vavgsx; - - -------------- - -- vcmpgtsx -- - -------------- - - function vcmpgtsx - (A : Varray_Type; - B : Varray_Type) return Varray_Type - is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := (if A (J) > B (J) then Bool_True else Bool_False); - end loop; - - return D; - end vcmpgtsx; - - ----------- - -- lvexx -- - ----------- - - function lvexx (A : c_long; B : c_ptr) return Varray_Type is - D : Varray_Type; - S : Integer; - EA : Integer_Address; - J : Index_Type; - - begin - S := 16 / Number_Of_Elements; - EA := Bound_Align (Integer_Address (A) + To_Integer (B), - Integer_Address (S)); - J := Index_Type (((EA mod 16) / Integer_Address (S)) - + Integer_Address (Index_Type'First)); - - declare - Component : Component_Type; - for Component'Address use To_Address (EA); - begin - D (J) := Component; - end; - - return D; - end lvexx; - - ------------ - -- vmaxsx -- - ------------ - - function vmaxsx (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := (if A (J) > B (J) then A (J) else B (J)); - end loop; - - return D; - end vmaxsx; - - ------------ - -- vmrghx -- - ------------ - - function vmrghx (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - Offset : constant Integer := Integer (Index_Type'First); - M : constant Integer := Number_Of_Elements / 2; - - begin - for J in 0 .. M - 1 loop - D (Index_Type (2 * J + Offset)) := A (Index_Type (J + Offset)); - D (Index_Type (2 * J + Offset + 1)) := B (Index_Type (J + Offset)); - end loop; - - return D; - end vmrghx; - - ------------ - -- vmrglx -- - ------------ - - function vmrglx (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - Offset : constant Integer := Integer (Index_Type'First); - M : constant Integer := Number_Of_Elements / 2; - - begin - for J in 0 .. M - 1 loop - D (Index_Type (2 * J + Offset)) := A (Index_Type (J + Offset + M)); - D (Index_Type (2 * J + Offset + 1)) := - B (Index_Type (J + Offset + M)); - end loop; - - return D; - end vmrglx; - - ------------ - -- vminsx -- - ------------ - - function vminsx (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := (if A (J) < B (J) then A (J) else B (J)); - end loop; - - return D; - end vminsx; - - ------------ - -- vspltx -- - ------------ - - function vspltx (A : Varray_Type; B : c_int) return Varray_Type is - J : constant Integer := - Integer (B) mod Number_Of_Elements - + Integer (Varray_Type'First); - D : Varray_Type; - - begin - for K in Varray_Type'Range loop - D (K) := A (Index_Type (J)); - end loop; - - return D; - end vspltx; - - -------------- - -- vspltisx -- - -------------- - - function vspltisx (A : c_int) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := Sign_Extend (A); - end loop; - - return D; - end vspltisx; - - ----------- - -- vsrax -- - ----------- - - function vsrax - (A : Varray_Type; - B : Varray_Type; - Shift_Func : Bit_Operation) return Varray_Type - is - D : Varray_Type; - S : constant Component_Type := - Component_Type (128 / Number_Of_Elements); - - begin - for J in Varray_Type'Range loop - D (J) := Shift_Func (A (J), Natural (B (J) mod S)); - end loop; - - return D; - end vsrax; - - ------------ - -- stvexx -- - ------------ - - procedure stvexx (A : Varray_Type; B : c_int; C : c_ptr) is - S : Integer; - EA : Integer_Address; - J : Index_Type; - - begin - S := 16 / Number_Of_Elements; - EA := Bound_Align (Integer_Address (B) + To_Integer (C), - Integer_Address (S)); - J := Index_Type ((EA mod 16) / Integer_Address (S) - + Integer_Address (Index_Type'First)); - - declare - Component : Component_Type; - for Component'Address use To_Address (EA); - begin - Component := A (J); - end; - end stvexx; - - ------------- - -- vsubsxs -- - ------------- - - function vsubsxs (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := Saturate (SI64 (A (J)) - SI64 (B (J))); - end loop; - - return D; - end vsubsxs; - - --------------- - -- Check_CR6 -- - --------------- - - function Check_CR6 (A : c_int; D : Varray_Type) return c_int is - All_Element : Boolean := True; - Any_Element : Boolean := False; - - begin - for J in Varray_Type'Range loop - All_Element := All_Element and then (D (J) = Bool_True); - Any_Element := Any_Element or else (D (J) = Bool_True); - end loop; - - if A = CR6_LT then - if All_Element then - return 1; - else - return 0; - end if; - - elsif A = CR6_EQ then - if not Any_Element then - return 1; - else - return 0; - end if; - - elsif A = CR6_EQ_REV then - if Any_Element then - return 1; - else - return 0; - end if; - - elsif A = CR6_LT_REV then - if not All_Element then - return 1; - else - return 0; - end if; - end if; - - return 0; - end Check_CR6; - - end Signed_Operations; - - -------------------------------- - -- Unsigned_Operations (spec) -- - -------------------------------- - - generic - type Component_Type is mod <>; - type Index_Type is range <>; - type Varray_Type is array (Index_Type) of Component_Type; - - package Unsigned_Operations is - - function Bits - (X : Component_Type; - Low : Natural; - High : Natural) return Component_Type; - -- Return X [Low:High] as defined in [PIM-4.3 Notations and Conventions] - -- using big endian bit ordering. - - function Write_Bit - (X : Component_Type; - Where : Natural; - Value : Unsigned_1) return Component_Type; - -- Write Value into X[Where:Where] (if it fits in) and return the result - -- (big endian bit ordering). - - function Modular_Result (X : UI64) return Component_Type; - - function Saturate (X : UI64) return Component_Type; - - function Saturate (X : F64) return Component_Type; - - function Saturate (X : SI64) return Component_Type; - - function vadduxm (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function vadduxs (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function vavgux (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function vcmpequx (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function vcmpgtux (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function vmaxux (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function vminux (A : Varray_Type; B : Varray_Type) return Varray_Type; - - type Bit_Operation is - access function - (Value : Component_Type; - Amount : Natural) return Component_Type; - - function vrlx - (A : Varray_Type; - B : Varray_Type; - ROTL : Bit_Operation) return Varray_Type; - - function vsxx - (A : Varray_Type; - B : Varray_Type; - Shift_Func : Bit_Operation) return Varray_Type; - -- Vector shift (left or right, depending on Shift_Func) - - function vsubuxm (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function vsubuxs (A : Varray_Type; B : Varray_Type) return Varray_Type; - - function Check_CR6 (A : c_int; D : Varray_Type) return c_int; - -- If D is the result of a vcmp operation and A the flag for - -- the kind of operation (e.g CR6_LT), check the predicate - -- that corresponds to this flag. - - end Unsigned_Operations; - - -------------------------------- - -- Unsigned_Operations (body) -- - -------------------------------- - - package body Unsigned_Operations is - - Number_Of_Elements : constant Integer := - VECTOR_BIT / Component_Type'Size; - - Bool_True : constant Component_Type := Component_Type'Last; - Bool_False : constant Component_Type := 0; - - -------------------- - -- Modular_Result -- - -------------------- - - function Modular_Result (X : UI64) return Component_Type is - D : Component_Type; - begin - D := Component_Type (X mod (UI64 (Component_Type'Last) + 1)); - return D; - end Modular_Result; - - -------------- - -- Saturate -- - -------------- - - function Saturate (X : UI64) return Component_Type is - D : Component_Type; - - begin - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - D := Component_Type (UI64'Max - (UI64 (Component_Type'First), - UI64'Min - (UI64 (Component_Type'Last), - X))); - - if UI64 (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - function Saturate (X : SI64) return Component_Type is - D : Component_Type; - - begin - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - D := Component_Type (SI64'Max - (SI64 (Component_Type'First), - SI64'Min - (SI64 (Component_Type'Last), - X))); - - if SI64 (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - function Saturate (X : F64) return Component_Type is - D : Component_Type; - - begin - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - D := Component_Type (F64'Max - (F64 (Component_Type'First), - F64'Min - (F64 (Component_Type'Last), - X))); - - if F64 (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - ---------- - -- Bits -- - ---------- - - function Bits - (X : Component_Type; - Low : Natural; - High : Natural) return Component_Type - is - Mask : Component_Type := 0; - - -- The Altivec ABI uses a big endian bit ordering, and we are - -- using little endian bit ordering for extracting bits: - - Low_LE : constant Natural := Component_Type'Size - 1 - High; - High_LE : constant Natural := Component_Type'Size - 1 - Low; - - begin - pragma Assert (Low <= Component_Type'Size); - pragma Assert (High <= Component_Type'Size); - - for J in Low_LE .. High_LE loop - Mask := Mask or 2 ** J; - end loop; - - return (X and Mask) / 2 ** Low_LE; - end Bits; - - --------------- - -- Write_Bit -- - --------------- - - function Write_Bit - (X : Component_Type; - Where : Natural; - Value : Unsigned_1) return Component_Type - is - Result : Component_Type := 0; - - -- The Altivec ABI uses a big endian bit ordering, and we are - -- using little endian bit ordering for extracting bits: - - Where_LE : constant Natural := Component_Type'Size - 1 - Where; - - begin - pragma Assert (Where < Component_Type'Size); - - case Value is - when 1 => - Result := X or 2 ** Where_LE; - when 0 => - Result := X and not (2 ** Where_LE); - end case; - - return Result; - end Write_Bit; - - ------------- - -- vadduxm -- - ------------- - - function vadduxm (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := A (J) + B (J); - end loop; - - return D; - end vadduxm; - - ------------- - -- vadduxs -- - ------------- - - function vadduxs (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := Saturate (UI64 (A (J)) + UI64 (B (J))); - end loop; - - return D; - end vadduxs; - - ------------ - -- vavgux -- - ------------ - - function vavgux (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := Component_Type ((UI64 (A (J)) + UI64 (B (J)) + 1) / 2); - end loop; - - return D; - end vavgux; - - -------------- - -- vcmpequx -- - -------------- - - function vcmpequx - (A : Varray_Type; - B : Varray_Type) return Varray_Type - is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := (if A (J) = B (J) then Bool_True else Bool_False); - end loop; - - return D; - end vcmpequx; - - -------------- - -- vcmpgtux -- - -------------- - - function vcmpgtux - (A : Varray_Type; - B : Varray_Type) return Varray_Type - is - D : Varray_Type; - begin - for J in Varray_Type'Range loop - D (J) := (if A (J) > B (J) then Bool_True else Bool_False); - end loop; - - return D; - end vcmpgtux; - - ------------ - -- vmaxux -- - ------------ - - function vmaxux (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := (if A (J) > B (J) then A (J) else B (J)); - end loop; - - return D; - end vmaxux; - - ------------ - -- vminux -- - ------------ - - function vminux (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := (if A (J) < B (J) then A (J) else B (J)); - end loop; - - return D; - end vminux; - - ---------- - -- vrlx -- - ---------- - - function vrlx - (A : Varray_Type; - B : Varray_Type; - ROTL : Bit_Operation) return Varray_Type - is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := ROTL (A (J), Natural (B (J))); - end loop; - - return D; - end vrlx; - - ---------- - -- vsxx -- - ---------- - - function vsxx - (A : Varray_Type; - B : Varray_Type; - Shift_Func : Bit_Operation) return Varray_Type - is - D : Varray_Type; - S : constant Component_Type := - Component_Type (128 / Number_Of_Elements); - - begin - for J in Varray_Type'Range loop - D (J) := Shift_Func (A (J), Natural (B (J) mod S)); - end loop; - - return D; - end vsxx; - - ------------- - -- vsubuxm -- - ------------- - - function vsubuxm (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := A (J) - B (J); - end loop; - - return D; - end vsubuxm; - - ------------- - -- vsubuxs -- - ------------- - - function vsubuxs (A : Varray_Type; B : Varray_Type) return Varray_Type is - D : Varray_Type; - - begin - for J in Varray_Type'Range loop - D (J) := Saturate (SI64 (A (J)) - SI64 (B (J))); - end loop; - - return D; - end vsubuxs; - - --------------- - -- Check_CR6 -- - --------------- - - function Check_CR6 (A : c_int; D : Varray_Type) return c_int is - All_Element : Boolean := True; - Any_Element : Boolean := False; - - begin - for J in Varray_Type'Range loop - All_Element := All_Element and then (D (J) = Bool_True); - Any_Element := Any_Element or else (D (J) = Bool_True); - end loop; - - if A = CR6_LT then - if All_Element then - return 1; - else - return 0; - end if; - - elsif A = CR6_EQ then - if not Any_Element then - return 1; - else - return 0; - end if; - - elsif A = CR6_EQ_REV then - if Any_Element then - return 1; - else - return 0; - end if; - - elsif A = CR6_LT_REV then - if not All_Element then - return 1; - else - return 0; - end if; - end if; - - return 0; - end Check_CR6; - - end Unsigned_Operations; - - -------------------------------------- - -- Signed_Merging_Operations (spec) -- - -------------------------------------- - - generic - type Component_Type is range <>; - type Index_Type is range <>; - type Varray_Type is array (Index_Type) of Component_Type; - type Double_Component_Type is range <>; - type Double_Index_Type is range <>; - type Double_Varray_Type is array (Double_Index_Type) - of Double_Component_Type; - - package Signed_Merging_Operations is - - pragma Assert (Integer (Varray_Type'First) - = Integer (Double_Varray_Type'First)); - pragma Assert (Varray_Type'Length = 2 * Double_Varray_Type'Length); - pragma Assert (2 * Component_Type'Size = Double_Component_Type'Size); - - function Saturate - (X : Double_Component_Type) return Component_Type; - - function vmulxsx - (Use_Even_Components : Boolean; - A : Varray_Type; - B : Varray_Type) return Double_Varray_Type; - - function vpksxss - (A : Double_Varray_Type; - B : Double_Varray_Type) return Varray_Type; - pragma Convention (LL_Altivec, vpksxss); - - function vupkxsx - (A : Varray_Type; - Offset : Natural) return Double_Varray_Type; - - end Signed_Merging_Operations; - - -------------------------------------- - -- Signed_Merging_Operations (body) -- - -------------------------------------- - - package body Signed_Merging_Operations is - - -------------- - -- Saturate -- - -------------- - - function Saturate - (X : Double_Component_Type) return Component_Type - is - D : Component_Type; - - begin - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - D := Component_Type (Double_Component_Type'Max - (Double_Component_Type (Component_Type'First), - Double_Component_Type'Min - (Double_Component_Type (Component_Type'Last), - X))); - - if Double_Component_Type (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - ------------- - -- vmulsxs -- - ------------- - - function vmulxsx - (Use_Even_Components : Boolean; - A : Varray_Type; - B : Varray_Type) return Double_Varray_Type - is - Double_Offset : Double_Index_Type; - Offset : Index_Type; - D : Double_Varray_Type; - N : constant Integer := - Integer (Double_Index_Type'Last) - - Integer (Double_Index_Type'First) + 1; - - begin - - for J in 0 .. N - 1 loop - Offset := - Index_Type ((if Use_Even_Components then 2 * J else 2 * J + 1) + - Integer (Index_Type'First)); - - Double_Offset := - Double_Index_Type (J + Integer (Double_Index_Type'First)); - D (Double_Offset) := - Double_Component_Type (A (Offset)) * - Double_Component_Type (B (Offset)); - end loop; - - return D; - end vmulxsx; - - ------------- - -- vpksxss -- - ------------- - - function vpksxss - (A : Double_Varray_Type; - B : Double_Varray_Type) return Varray_Type - is - N : constant Index_Type := - Index_Type (Double_Index_Type'Last); - D : Varray_Type; - Offset : Index_Type; - Double_Offset : Double_Index_Type; - - begin - for J in 0 .. N - 1 loop - Offset := Index_Type (Integer (J) + Integer (Index_Type'First)); - Double_Offset := - Double_Index_Type (Integer (J) - + Integer (Double_Index_Type'First)); - D (Offset) := Saturate (A (Double_Offset)); - D (Offset + N) := Saturate (B (Double_Offset)); - end loop; - - return D; - end vpksxss; - - ------------- - -- vupkxsx -- - ------------- - - function vupkxsx - (A : Varray_Type; - Offset : Natural) return Double_Varray_Type - is - K : Index_Type; - D : Double_Varray_Type; - - begin - for J in Double_Varray_Type'Range loop - K := Index_Type (Integer (J) - - Integer (Double_Index_Type'First) - + Integer (Index_Type'First) - + Offset); - D (J) := Double_Component_Type (A (K)); - end loop; - - return D; - end vupkxsx; - - end Signed_Merging_Operations; - - ---------------------------------------- - -- Unsigned_Merging_Operations (spec) -- - ---------------------------------------- - - generic - type Component_Type is mod <>; - type Index_Type is range <>; - type Varray_Type is array (Index_Type) of Component_Type; - type Double_Component_Type is mod <>; - type Double_Index_Type is range <>; - type Double_Varray_Type is array (Double_Index_Type) - of Double_Component_Type; - - package Unsigned_Merging_Operations is - - pragma Assert (Integer (Varray_Type'First) - = Integer (Double_Varray_Type'First)); - pragma Assert (Varray_Type'Length = 2 * Double_Varray_Type'Length); - pragma Assert (2 * Component_Type'Size = Double_Component_Type'Size); - - function UI_To_UI_Mod - (X : Double_Component_Type; - Y : Natural) return Component_Type; - - function Saturate (X : Double_Component_Type) return Component_Type; - - function vmulxux - (Use_Even_Components : Boolean; - A : Varray_Type; - B : Varray_Type) return Double_Varray_Type; - - function vpkuxum - (A : Double_Varray_Type; - B : Double_Varray_Type) return Varray_Type; - - function vpkuxus - (A : Double_Varray_Type; - B : Double_Varray_Type) return Varray_Type; - - end Unsigned_Merging_Operations; - - ---------------------------------------- - -- Unsigned_Merging_Operations (body) -- - ---------------------------------------- - - package body Unsigned_Merging_Operations is - - ------------------ - -- UI_To_UI_Mod -- - ------------------ - - function UI_To_UI_Mod - (X : Double_Component_Type; - Y : Natural) return Component_Type is - Z : Component_Type; - begin - Z := Component_Type (X mod 2 ** Y); - return Z; - end UI_To_UI_Mod; - - -------------- - -- Saturate -- - -------------- - - function Saturate (X : Double_Component_Type) return Component_Type is - D : Component_Type; - - begin - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - D := Component_Type (Double_Component_Type'Max - (Double_Component_Type (Component_Type'First), - Double_Component_Type'Min - (Double_Component_Type (Component_Type'Last), - X))); - - if Double_Component_Type (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - ------------- - -- vmulxux -- - ------------- - - function vmulxux - (Use_Even_Components : Boolean; - A : Varray_Type; - B : Varray_Type) return Double_Varray_Type - is - Double_Offset : Double_Index_Type; - Offset : Index_Type; - D : Double_Varray_Type; - N : constant Integer := - Integer (Double_Index_Type'Last) - - Integer (Double_Index_Type'First) + 1; - - begin - for J in 0 .. N - 1 loop - Offset := - Index_Type ((if Use_Even_Components then 2 * J else 2 * J + 1) + - Integer (Index_Type'First)); - - Double_Offset := - Double_Index_Type (J + Integer (Double_Index_Type'First)); - D (Double_Offset) := - Double_Component_Type (A (Offset)) * - Double_Component_Type (B (Offset)); - end loop; - - return D; - end vmulxux; - - ------------- - -- vpkuxum -- - ------------- - - function vpkuxum - (A : Double_Varray_Type; - B : Double_Varray_Type) return Varray_Type - is - S : constant Natural := - Double_Component_Type'Size / 2; - N : constant Index_Type := - Index_Type (Double_Index_Type'Last); - D : Varray_Type; - Offset : Index_Type; - Double_Offset : Double_Index_Type; - - begin - for J in 0 .. N - 1 loop - Offset := Index_Type (Integer (J) + Integer (Index_Type'First)); - Double_Offset := - Double_Index_Type (Integer (J) - + Integer (Double_Index_Type'First)); - D (Offset) := UI_To_UI_Mod (A (Double_Offset), S); - D (Offset + N) := UI_To_UI_Mod (B (Double_Offset), S); - end loop; - - return D; - end vpkuxum; - - ------------- - -- vpkuxus -- - ------------- - - function vpkuxus - (A : Double_Varray_Type; - B : Double_Varray_Type) return Varray_Type - is - N : constant Index_Type := - Index_Type (Double_Index_Type'Last); - D : Varray_Type; - Offset : Index_Type; - Double_Offset : Double_Index_Type; - - begin - for J in 0 .. N - 1 loop - Offset := Index_Type (Integer (J) + Integer (Index_Type'First)); - Double_Offset := - Double_Index_Type (Integer (J) - + Integer (Double_Index_Type'First)); - D (Offset) := Saturate (A (Double_Offset)); - D (Offset + N) := Saturate (B (Double_Offset)); - end loop; - - return D; - end vpkuxus; - - end Unsigned_Merging_Operations; - - package LL_VSC_Operations is - new Signed_Operations (signed_char, - Vchar_Range, - Varray_signed_char); - - package LL_VSS_Operations is - new Signed_Operations (signed_short, - Vshort_Range, - Varray_signed_short); - - package LL_VSI_Operations is - new Signed_Operations (signed_int, - Vint_Range, - Varray_signed_int); - - package LL_VUC_Operations is - new Unsigned_Operations (unsigned_char, - Vchar_Range, - Varray_unsigned_char); - - package LL_VUS_Operations is - new Unsigned_Operations (unsigned_short, - Vshort_Range, - Varray_unsigned_short); - - package LL_VUI_Operations is - new Unsigned_Operations (unsigned_int, - Vint_Range, - Varray_unsigned_int); - - package LL_VSC_LL_VSS_Operations is - new Signed_Merging_Operations (signed_char, - Vchar_Range, - Varray_signed_char, - signed_short, - Vshort_Range, - Varray_signed_short); - - package LL_VSS_LL_VSI_Operations is - new Signed_Merging_Operations (signed_short, - Vshort_Range, - Varray_signed_short, - signed_int, - Vint_Range, - Varray_signed_int); - - package LL_VUC_LL_VUS_Operations is - new Unsigned_Merging_Operations (unsigned_char, - Vchar_Range, - Varray_unsigned_char, - unsigned_short, - Vshort_Range, - Varray_unsigned_short); - - package LL_VUS_LL_VUI_Operations is - new Unsigned_Merging_Operations (unsigned_short, - Vshort_Range, - Varray_unsigned_short, - unsigned_int, - Vint_Range, - Varray_unsigned_int); - - ---------- - -- Bits -- - ---------- - - function Bits - (X : unsigned_int; - Low : Natural; - High : Natural) return unsigned_int renames LL_VUI_Operations.Bits; - - function Bits - (X : unsigned_short; - Low : Natural; - High : Natural) return unsigned_short renames LL_VUS_Operations.Bits; - - function Bits - (X : unsigned_char; - Low : Natural; - High : Natural) return unsigned_char renames LL_VUC_Operations.Bits; - - --------------- - -- Write_Bit -- - --------------- - - function Write_Bit - (X : unsigned_int; - Where : Natural; - Value : Unsigned_1) return unsigned_int - renames LL_VUI_Operations.Write_Bit; - - function Write_Bit - (X : unsigned_short; - Where : Natural; - Value : Unsigned_1) return unsigned_short - renames LL_VUS_Operations.Write_Bit; - - function Write_Bit - (X : unsigned_char; - Where : Natural; - Value : Unsigned_1) return unsigned_char - renames LL_VUC_Operations.Write_Bit; - - ----------------- - -- Bound_Align -- - ----------------- - - function Bound_Align - (X : Integer_Address; - Y : Integer_Address) return Integer_Address - is - D : Integer_Address; - begin - D := X - X mod Y; - return D; - end Bound_Align; - - ----------------- - -- NJ_Truncate -- - ----------------- - - function NJ_Truncate (X : C_float) return C_float is - D : C_float; - - begin - if (Bits (VSCR, NJ_POS, NJ_POS) = 1) - and then abs (X) < 2.0 ** (-126) - then - D := (if X < 0.0 then -0.0 else +0.0); - else - D := X; - end if; - - return D; - end NJ_Truncate; - - ----------------------- - -- Rnd_To_FP_Nearest -- - ----------------------- - - function Rnd_To_FP_Nearest (X : F64) return C_float is - begin - return C_float (X); - end Rnd_To_FP_Nearest; - - --------------------- - -- Rnd_To_FPI_Near -- - --------------------- - - function Rnd_To_FPI_Near (X : F64) return F64 is - Result : F64; - Ceiling : F64; - - begin - Result := F64 (SI64 (X)); - - if (F64'Ceiling (X) - X) = (X + 1.0 - F64'Ceiling (X)) then - - -- Round to even - - Ceiling := F64'Ceiling (X); - Result := - (if Rnd_To_FPI_Trunc (Ceiling / 2.0) * 2.0 = Ceiling - then Ceiling else Ceiling - 1.0); - end if; - - return Result; - end Rnd_To_FPI_Near; - - ---------------------- - -- Rnd_To_FPI_Trunc -- - ---------------------- - - function Rnd_To_FPI_Trunc (X : F64) return F64 is - Result : F64; - - begin - Result := F64'Ceiling (X); - - -- Rnd_To_FPI_Trunc rounds toward 0, 'Ceiling rounds toward - -- +Infinity - - if X > 0.0 - and then Result /= X - then - Result := Result - 1.0; - end if; - - return Result; - end Rnd_To_FPI_Trunc; - - ------------------ - -- FP_Recip_Est -- - ------------------ - - function FP_Recip_Est (X : C_float) return C_float is - begin - -- ??? [PIM-4.4 vec_re] "For result that are not +0, -0, +Inf, - -- -Inf, or QNaN, the estimate has a relative error no greater - -- than one part in 4096, that is: - -- Abs ((estimate - 1 / x) / (1 / x)) < = 1/4096" - - return NJ_Truncate (1.0 / NJ_Truncate (X)); - end FP_Recip_Est; - - ---------- - -- ROTL -- - ---------- - - function ROTL - (Value : unsigned_char; - Amount : Natural) return unsigned_char - is - Result : Unsigned_8; - begin - Result := Rotate_Left (Unsigned_8 (Value), Amount); - return unsigned_char (Result); - end ROTL; - - function ROTL - (Value : unsigned_short; - Amount : Natural) return unsigned_short - is - Result : Unsigned_16; - begin - Result := Rotate_Left (Unsigned_16 (Value), Amount); - return unsigned_short (Result); - end ROTL; - - function ROTL - (Value : unsigned_int; - Amount : Natural) return unsigned_int - is - Result : Unsigned_32; - begin - Result := Rotate_Left (Unsigned_32 (Value), Amount); - return unsigned_int (Result); - end ROTL; - - -------------------- - -- Recip_SQRT_Est -- - -------------------- - - function Recip_SQRT_Est (X : C_float) return C_float is - Result : C_float; - - begin - -- ??? - -- [PIM-4.4 vec_rsqrte] the estimate has a relative error in precision - -- no greater than one part in 4096, that is: - -- abs ((estimate - 1 / sqrt (x)) / (1 / sqrt (x)) <= 1 / 4096" - - Result := 1.0 / NJ_Truncate (C_float_Operations.Sqrt (NJ_Truncate (X))); - return NJ_Truncate (Result); - end Recip_SQRT_Est; - - ---------------- - -- Shift_Left -- - ---------------- - - function Shift_Left - (Value : unsigned_char; - Amount : Natural) return unsigned_char - is - Result : Unsigned_8; - begin - Result := Shift_Left (Unsigned_8 (Value), Amount); - return unsigned_char (Result); - end Shift_Left; - - function Shift_Left - (Value : unsigned_short; - Amount : Natural) return unsigned_short - is - Result : Unsigned_16; - begin - Result := Shift_Left (Unsigned_16 (Value), Amount); - return unsigned_short (Result); - end Shift_Left; - - function Shift_Left - (Value : unsigned_int; - Amount : Natural) return unsigned_int - is - Result : Unsigned_32; - begin - Result := Shift_Left (Unsigned_32 (Value), Amount); - return unsigned_int (Result); - end Shift_Left; - - ----------------- - -- Shift_Right -- - ----------------- - - function Shift_Right - (Value : unsigned_char; - Amount : Natural) return unsigned_char - is - Result : Unsigned_8; - begin - Result := Shift_Right (Unsigned_8 (Value), Amount); - return unsigned_char (Result); - end Shift_Right; - - function Shift_Right - (Value : unsigned_short; - Amount : Natural) return unsigned_short - is - Result : Unsigned_16; - begin - Result := Shift_Right (Unsigned_16 (Value), Amount); - return unsigned_short (Result); - end Shift_Right; - - function Shift_Right - (Value : unsigned_int; - Amount : Natural) return unsigned_int - is - Result : Unsigned_32; - begin - Result := Shift_Right (Unsigned_32 (Value), Amount); - return unsigned_int (Result); - end Shift_Right; - - ------------------- - -- Shift_Right_A -- - ------------------- - - generic - type Signed_Type is range <>; - type Unsigned_Type is mod <>; - with function Shift_Right (Value : Unsigned_Type; Amount : Natural) - return Unsigned_Type; - function Shift_Right_Arithmetic - (Value : Signed_Type; - Amount : Natural) return Signed_Type; - - function Shift_Right_Arithmetic - (Value : Signed_Type; - Amount : Natural) return Signed_Type - is - begin - if Value > 0 then - return Signed_Type (Shift_Right (Unsigned_Type (Value), Amount)); - else - return -Signed_Type (Shift_Right (Unsigned_Type (-Value - 1), Amount) - + 1); - end if; - end Shift_Right_Arithmetic; - - function Shift_Right_A is new Shift_Right_Arithmetic (signed_int, - Unsigned_32, - Shift_Right); - - function Shift_Right_A is new Shift_Right_Arithmetic (signed_short, - Unsigned_16, - Shift_Right); - - function Shift_Right_A is new Shift_Right_Arithmetic (signed_char, - Unsigned_8, - Shift_Right); - -------------- - -- To_Pixel -- - -------------- - - function To_Pixel (Source : unsigned_short) return Pixel_16 is - - -- This conversion should not depend on the host endianness; - -- therefore, we cannot use an unchecked conversion. - - Target : Pixel_16; - - begin - Target.T := Unsigned_1 (Bits (Source, 0, 0) mod 2 ** 1); - Target.R := Unsigned_5 (Bits (Source, 1, 5) mod 2 ** 5); - Target.G := Unsigned_5 (Bits (Source, 6, 10) mod 2 ** 5); - Target.B := Unsigned_5 (Bits (Source, 11, 15) mod 2 ** 5); - return Target; - end To_Pixel; - - function To_Pixel (Source : unsigned_int) return Pixel_32 is - - -- This conversion should not depend on the host endianness; - -- therefore, we cannot use an unchecked conversion. - - Target : Pixel_32; - - begin - Target.T := unsigned_char (Bits (Source, 0, 7)); - Target.R := unsigned_char (Bits (Source, 8, 15)); - Target.G := unsigned_char (Bits (Source, 16, 23)); - Target.B := unsigned_char (Bits (Source, 24, 31)); - return Target; - end To_Pixel; - - --------------------- - -- To_unsigned_int -- - --------------------- - - function To_unsigned_int (Source : Pixel_32) return unsigned_int is - - -- This conversion should not depend on the host endianness; - -- therefore, we cannot use an unchecked conversion. - -- It should also be the same result, value-wise, on two hosts - -- with the same endianness. - - Target : unsigned_int := 0; - - begin - -- In big endian bit ordering, Pixel_32 looks like: - -- ------------------------------------- - -- | T | R | G | B | - -- ------------------------------------- - -- 0 (MSB) 7 15 23 32 - -- - -- Sizes of the components: (8/8/8/8) - -- - Target := Target or unsigned_int (Source.T); - Target := Shift_Left (Target, 8); - Target := Target or unsigned_int (Source.R); - Target := Shift_Left (Target, 8); - Target := Target or unsigned_int (Source.G); - Target := Shift_Left (Target, 8); - Target := Target or unsigned_int (Source.B); - return Target; - end To_unsigned_int; - - ----------------------- - -- To_unsigned_short -- - ----------------------- - - function To_unsigned_short (Source : Pixel_16) return unsigned_short is - - -- This conversion should not depend on the host endianness; - -- therefore, we cannot use an unchecked conversion. - -- It should also be the same result, value-wise, on two hosts - -- with the same endianness. - - Target : unsigned_short := 0; - - begin - -- In big endian bit ordering, Pixel_16 looks like: - -- ------------------------------------- - -- | T | R | G | B | - -- ------------------------------------- - -- 0 (MSB) 1 5 11 15 - -- - -- Sizes of the components: (1/5/5/5) - -- - Target := Target or unsigned_short (Source.T); - Target := Shift_Left (Target, 5); - Target := Target or unsigned_short (Source.R); - Target := Shift_Left (Target, 5); - Target := Target or unsigned_short (Source.G); - Target := Shift_Left (Target, 5); - Target := Target or unsigned_short (Source.B); - return Target; - end To_unsigned_short; - - --------------- - -- abs_v16qi -- - --------------- - - function abs_v16qi (A : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - begin - return To_Vector ((Values => - LL_VSC_Operations.abs_vxi (VA.Values))); - end abs_v16qi; - - -------------- - -- abs_v8hi -- - -------------- - - function abs_v8hi (A : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - begin - return To_Vector ((Values => - LL_VSS_Operations.abs_vxi (VA.Values))); - end abs_v8hi; - - -------------- - -- abs_v4si -- - -------------- - - function abs_v4si (A : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - begin - return To_Vector ((Values => - LL_VSI_Operations.abs_vxi (VA.Values))); - end abs_v4si; - - -------------- - -- abs_v4sf -- - -------------- - - function abs_v4sf (A : LL_VF) return LL_VF is - D : Varray_float; - VA : constant VF_View := To_View (A); - - begin - for J in Varray_float'Range loop - D (J) := abs (VA.Values (J)); - end loop; - - return To_Vector ((Values => D)); - end abs_v4sf; - - ---------------- - -- abss_v16qi -- - ---------------- - - function abss_v16qi (A : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - begin - return To_Vector ((Values => - LL_VSC_Operations.abss_vxi (VA.Values))); - end abss_v16qi; - - --------------- - -- abss_v8hi -- - --------------- - - function abss_v8hi (A : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - begin - return To_Vector ((Values => - LL_VSS_Operations.abss_vxi (VA.Values))); - end abss_v8hi; - - --------------- - -- abss_v4si -- - --------------- - - function abss_v4si (A : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - begin - return To_Vector ((Values => - LL_VSI_Operations.abss_vxi (VA.Values))); - end abss_v4si; - - ------------- - -- vaddubm -- - ------------- - - function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC is - UC : constant GNAT.Altivec.Low_Level_Vectors.LL_VUC := - To_LL_VUC (A); - VA : constant VUC_View := - To_View (UC); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : Varray_unsigned_char; - - begin - D := LL_VUC_Operations.vadduxm (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (VUC_View'(Values => D))); - end vaddubm; - - ------------- - -- vadduhm -- - ------------- - - function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : Varray_unsigned_short; - - begin - D := LL_VUS_Operations.vadduxm (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (VUS_View'(Values => D))); - end vadduhm; - - ------------- - -- vadduwm -- - ------------- - - function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : Varray_unsigned_int; - - begin - D := LL_VUI_Operations.vadduxm (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (VUI_View'(Values => D))); - end vadduwm; - - ------------ - -- vaddfp -- - ------------ - - function vaddfp (A : LL_VF; B : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : Varray_float; - - begin - for J in Varray_float'Range loop - D (J) := NJ_Truncate (NJ_Truncate (VA.Values (J)) - + NJ_Truncate (VB.Values (J))); - end loop; - - return To_Vector (VF_View'(Values => D)); - end vaddfp; - - ------------- - -- vaddcuw -- - ------------- - - function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI is - Addition_Result : UI64; - D : VUI_View; - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - - begin - for J in Varray_unsigned_int'Range loop - Addition_Result := UI64 (VA.Values (J)) + UI64 (VB.Values (J)); - D.Values (J) := - (if Addition_Result > UI64 (unsigned_int'Last) then 1 else 0); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vaddcuw; - - ------------- - -- vaddubs -- - ------------- - - function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - - begin - return To_LL_VSC (To_Vector - (VUC_View'(Values => - (LL_VUC_Operations.vadduxs - (VA.Values, - VB.Values))))); - end vaddubs; - - ------------- - -- vaddsbs -- - ------------- - - function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - - begin - D.Values := LL_VSC_Operations.vaddsxs (VA.Values, VB.Values); - return To_Vector (D); - end vaddsbs; - - ------------- - -- vadduhs -- - ------------- - - function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - - begin - D.Values := LL_VUS_Operations.vadduxs (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vadduhs; - - ------------- - -- vaddshs -- - ------------- - - function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - - begin - D.Values := LL_VSS_Operations.vaddsxs (VA.Values, VB.Values); - return To_Vector (D); - end vaddshs; - - ------------- - -- vadduws -- - ------------- - - function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - D.Values := LL_VUI_Operations.vadduxs (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vadduws; - - ------------- - -- vaddsws -- - ------------- - - function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - - begin - D.Values := LL_VSI_Operations.vaddsxs (VA.Values, VB.Values); - return To_Vector (D); - end vaddsws; - - ---------- - -- vand -- - ---------- - - function vand (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - for J in Varray_unsigned_int'Range loop - D.Values (J) := VA.Values (J) and VB.Values (J); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vand; - - ----------- - -- vandc -- - ----------- - - function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - for J in Varray_unsigned_int'Range loop - D.Values (J) := VA.Values (J) and not VB.Values (J); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vandc; - - ------------ - -- vavgub -- - ------------ - - function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - - begin - D.Values := LL_VUC_Operations.vavgux (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vavgub; - - ------------ - -- vavgsb -- - ------------ - - function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - - begin - D.Values := LL_VSC_Operations.vavgsx (VA.Values, VB.Values); - return To_Vector (D); - end vavgsb; - - ------------ - -- vavguh -- - ------------ - - function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - - begin - D.Values := LL_VUS_Operations.vavgux (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vavguh; - - ------------ - -- vavgsh -- - ------------ - - function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - - begin - D.Values := LL_VSS_Operations.vavgsx (VA.Values, VB.Values); - return To_Vector (D); - end vavgsh; - - ------------ - -- vavguw -- - ------------ - - function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - D.Values := LL_VUI_Operations.vavgux (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vavguw; - - ------------ - -- vavgsw -- - ------------ - - function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - - begin - D.Values := LL_VSI_Operations.vavgsx (VA.Values, VB.Values); - return To_Vector (D); - end vavgsw; - - ----------- - -- vrfip -- - ----------- - - function vrfip (A : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - D : VF_View; - - begin - for J in Varray_float'Range loop - - -- If A (J) is infinite, D (J) should be infinite; With - -- IEEE floating points, we can use 'Ceiling for that purpose. - - D.Values (J) := C_float'Ceiling (NJ_Truncate (VA.Values (J))); - - end loop; - - return To_Vector (D); - end vrfip; - - ------------- - -- vcmpbfp -- - ------------- - - function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : VUI_View; - K : Vint_Range; - - begin - for J in Varray_float'Range loop - K := Vint_Range (J); - D.Values (K) := 0; - - if NJ_Truncate (VB.Values (J)) < 0.0 then - - -- [PIM-4.4 vec_cmpb] "If any single-precision floating-point - -- word element in B is negative; the corresponding element in A - -- is out of bounds. - - D.Values (K) := Write_Bit (D.Values (K), 0, 1); - D.Values (K) := Write_Bit (D.Values (K), 1, 1); - - else - D.Values (K) := - (if NJ_Truncate (VA.Values (J)) <= NJ_Truncate (VB.Values (J)) - then Write_Bit (D.Values (K), 0, 0) - else Write_Bit (D.Values (K), 0, 1)); - - D.Values (K) := - (if NJ_Truncate (VA.Values (J)) >= -NJ_Truncate (VB.Values (J)) - then Write_Bit (D.Values (K), 1, 0) - else Write_Bit (D.Values (K), 1, 1)); - end if; - end loop; - - return To_LL_VSI (To_Vector (D)); - end vcmpbfp; - - -------------- - -- vcmpequb -- - -------------- - - function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - - begin - D.Values := LL_VUC_Operations.vcmpequx (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vcmpequb; - - -------------- - -- vcmpequh -- - -------------- - - function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := LL_VUS_Operations.vcmpequx (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vcmpequh; - - -------------- - -- vcmpequw -- - -------------- - - function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := LL_VUI_Operations.vcmpequx (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vcmpequw; - - -------------- - -- vcmpeqfp -- - -------------- - - function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VSI is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : VUI_View; - - begin - for J in Varray_float'Range loop - D.Values (Vint_Range (J)) := - (if VA.Values (J) = VB.Values (J) then unsigned_int'Last else 0); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vcmpeqfp; - - -------------- - -- vcmpgefp -- - -------------- - - function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VSI is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : VSI_View; - - begin - for J in Varray_float'Range loop - D.Values (Vint_Range (J)) := - (if VA.Values (J) >= VB.Values (J) then Signed_Bool_True - else Signed_Bool_False); - end loop; - - return To_Vector (D); - end vcmpgefp; - - -------------- - -- vcmpgtub -- - -------------- - - function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := LL_VUC_Operations.vcmpgtux (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vcmpgtub; - - -------------- - -- vcmpgtsb -- - -------------- - - function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vcmpgtsx (VA.Values, VB.Values); - return To_Vector (D); - end vcmpgtsb; - - -------------- - -- vcmpgtuh -- - -------------- - - function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := LL_VUS_Operations.vcmpgtux (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vcmpgtuh; - - -------------- - -- vcmpgtsh -- - -------------- - - function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vcmpgtsx (VA.Values, VB.Values); - return To_Vector (D); - end vcmpgtsh; - - -------------- - -- vcmpgtuw -- - -------------- - - function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := LL_VUI_Operations.vcmpgtux (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vcmpgtuw; - - -------------- - -- vcmpgtsw -- - -------------- - - function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vcmpgtsx (VA.Values, VB.Values); - return To_Vector (D); - end vcmpgtsw; - - -------------- - -- vcmpgtfp -- - -------------- - - function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VSI is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : VSI_View; - - begin - for J in Varray_float'Range loop - D.Values (Vint_Range (J)) := - (if NJ_Truncate (VA.Values (J)) > NJ_Truncate (VB.Values (J)) - then Signed_Bool_True else Signed_Bool_False); - end loop; - - return To_Vector (D); - end vcmpgtfp; - - ----------- - -- vcfux -- - ----------- - - function vcfux (A : LL_VUI; B : c_int) return LL_VF is - VA : constant VUI_View := To_View (A); - D : VF_View; - K : Vfloat_Range; - - begin - for J in Varray_signed_int'Range loop - K := Vfloat_Range (J); - - -- Note: The conversion to Integer is safe, as Integers are required - -- to include the range -2 ** 15 + 1 .. 2 ** 15 + 1 and therefore - -- include the range of B (should be 0 .. 255). - - D.Values (K) := - C_float (VA.Values (J)) / (2.0 ** Integer (B)); - end loop; - - return To_Vector (D); - end vcfux; - - ----------- - -- vcfsx -- - ----------- - - function vcfsx (A : LL_VSI; B : c_int) return LL_VF is - VA : constant VSI_View := To_View (A); - D : VF_View; - K : Vfloat_Range; - - begin - for J in Varray_signed_int'Range loop - K := Vfloat_Range (J); - D.Values (K) := C_float (VA.Values (J)) - / (2.0 ** Integer (B)); - end loop; - - return To_Vector (D); - end vcfsx; - - ------------ - -- vctsxs -- - ------------ - - function vctsxs (A : LL_VF; B : c_int) return LL_VSI is - VA : constant VF_View := To_View (A); - D : VSI_View; - K : Vfloat_Range; - - begin - for J in Varray_signed_int'Range loop - K := Vfloat_Range (J); - D.Values (J) := - LL_VSI_Operations.Saturate - (F64 (NJ_Truncate (VA.Values (K))) - * F64 (2.0 ** Integer (B))); - end loop; - - return To_Vector (D); - end vctsxs; - - ------------ - -- vctuxs -- - ------------ - - function vctuxs (A : LL_VF; B : c_int) return LL_VUI is - VA : constant VF_View := To_View (A); - D : VUI_View; - K : Vfloat_Range; - - begin - for J in Varray_unsigned_int'Range loop - K := Vfloat_Range (J); - D.Values (J) := - LL_VUI_Operations.Saturate - (F64 (NJ_Truncate (VA.Values (K))) - * F64 (2.0 ** Integer (B))); - end loop; - - return To_Vector (D); - end vctuxs; - - --------- - -- dss -- - --------- - - -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: - - procedure dss (A : c_int) is - pragma Unreferenced (A); - begin - null; - end dss; - - ------------ - -- dssall -- - ------------ - - -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: - - procedure dssall is - begin - null; - end dssall; - - --------- - -- dst -- - --------- - - -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: - - procedure dst (A : c_ptr; B : c_int; C : c_int) is - pragma Unreferenced (A); - pragma Unreferenced (B); - pragma Unreferenced (C); - begin - null; - end dst; - - ----------- - -- dstst -- - ----------- - - -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: - - procedure dstst (A : c_ptr; B : c_int; C : c_int) is - pragma Unreferenced (A); - pragma Unreferenced (B); - pragma Unreferenced (C); - begin - null; - end dstst; - - ------------ - -- dststt -- - ------------ - - -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: - - procedure dststt (A : c_ptr; B : c_int; C : c_int) is - pragma Unreferenced (A); - pragma Unreferenced (B); - pragma Unreferenced (C); - begin - null; - end dststt; - - ---------- - -- dstt -- - ---------- - - -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: - - procedure dstt (A : c_ptr; B : c_int; C : c_int) is - pragma Unreferenced (A); - pragma Unreferenced (B); - pragma Unreferenced (C); - begin - null; - end dstt; - - -------------- - -- vexptefp -- - -------------- - - function vexptefp (A : LL_VF) return LL_VF is - use C_float_Operations; - - VA : constant VF_View := To_View (A); - D : VF_View; - - begin - for J in Varray_float'Range loop - - -- ??? Check the precision of the operation. - -- As described in [PEM-6 vexptefp]: - -- If theoretical_result is equal to 2 at the power of A (J) with - -- infinite precision, we should have: - -- abs ((D (J) - theoretical_result) / theoretical_result) <= 1/16 - - D.Values (J) := 2.0 ** NJ_Truncate (VA.Values (J)); - end loop; - - return To_Vector (D); - end vexptefp; - - ----------- - -- vrfim -- - ----------- - - function vrfim (A : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - D : VF_View; - - begin - for J in Varray_float'Range loop - - -- If A (J) is infinite, D (J) should be infinite; With - -- IEEE floating point, we can use 'Ceiling for that purpose. - - D.Values (J) := C_float'Ceiling (NJ_Truncate (VA.Values (J))); - - -- Vrfim rounds toward -Infinity, whereas 'Ceiling rounds toward - -- +Infinity: - - if D.Values (J) /= VA.Values (J) then - D.Values (J) := D.Values (J) - 1.0; - end if; - end loop; - - return To_Vector (D); - end vrfim; - - --------- - -- lvx -- - --------- - - function lvx (A : c_long; B : c_ptr) return LL_VSI is - - -- Simulate the altivec unit behavior regarding what Effective Address - -- is accessed, stripping off the input address least significant bits - -- wrt to vector alignment. - - -- On targets where VECTOR_ALIGNMENT is less than the vector size (16), - -- an address within a vector is not necessarily rounded back at the - -- vector start address. Besides, rounding on 16 makes no sense on such - -- targets because the address of a properly aligned vector (that is, - -- a proper multiple of VECTOR_ALIGNMENT) could be affected, which we - -- want never to happen. - - EA : constant System.Address := - To_Address - (Bound_Align - (Integer_Address (A) + To_Integer (B), VECTOR_ALIGNMENT)); - - D : LL_VSI; - for D'Address use EA; - - begin - return D; - end lvx; - - ----------- - -- lvebx -- - ----------- - - function lvebx (A : c_long; B : c_ptr) return LL_VSC is - D : VSC_View; - begin - D.Values := LL_VSC_Operations.lvexx (A, B); - return To_Vector (D); - end lvebx; - - ----------- - -- lvehx -- - ----------- - - function lvehx (A : c_long; B : c_ptr) return LL_VSS is - D : VSS_View; - begin - D.Values := LL_VSS_Operations.lvexx (A, B); - return To_Vector (D); - end lvehx; - - ----------- - -- lvewx -- - ----------- - - function lvewx (A : c_long; B : c_ptr) return LL_VSI is - D : VSI_View; - begin - D.Values := LL_VSI_Operations.lvexx (A, B); - return To_Vector (D); - end lvewx; - - ---------- - -- lvxl -- - ---------- - - function lvxl (A : c_long; B : c_ptr) return LL_VSI renames - lvx; - - ------------- - -- vlogefp -- - ------------- - - function vlogefp (A : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - D : VF_View; - - begin - for J in Varray_float'Range loop - - -- ??? Check the precision of the operation. - -- As described in [PEM-6 vlogefp]: - -- If theorical_result is equal to the log2 of A (J) with - -- infinite precision, we should have: - -- abs (D (J) - theorical_result) <= 1/32, - -- unless abs(D(J) - 1) <= 1/8. - - D.Values (J) := - C_float_Operations.Log (NJ_Truncate (VA.Values (J)), 2.0); - end loop; - - return To_Vector (D); - end vlogefp; - - ---------- - -- lvsl -- - ---------- - - function lvsl (A : c_long; B : c_ptr) return LL_VSC is - type bit4_type is mod 16#F# + 1; - for bit4_type'Alignment use 1; - EA : Integer_Address; - D : VUC_View; - SH : bit4_type; - - begin - EA := Integer_Address (A) + To_Integer (B); - SH := bit4_type (EA mod 2 ** 4); - - for J in D.Values'Range loop - D.Values (J) := unsigned_char (SH) + unsigned_char (J) - - unsigned_char (D.Values'First); - end loop; - - return To_LL_VSC (To_Vector (D)); - end lvsl; - - ---------- - -- lvsr -- - ---------- - - function lvsr (A : c_long; B : c_ptr) return LL_VSC is - type bit4_type is mod 16#F# + 1; - for bit4_type'Alignment use 1; - EA : Integer_Address; - D : VUC_View; - SH : bit4_type; - - begin - EA := Integer_Address (A) + To_Integer (B); - SH := bit4_type (EA mod 2 ** 4); - - for J in D.Values'Range loop - D.Values (J) := (16#F# - unsigned_char (SH)) + unsigned_char (J); - end loop; - - return To_LL_VSC (To_Vector (D)); - end lvsr; - - ------------- - -- vmaddfp -- - ------------- - - function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - VC : constant VF_View := To_View (C); - D : VF_View; - - begin - for J in Varray_float'Range loop - D.Values (J) := - Rnd_To_FP_Nearest (F64 (VA.Values (J)) - * F64 (VB.Values (J)) - + F64 (VC.Values (J))); - end loop; - - return To_Vector (D); - end vmaddfp; - - --------------- - -- vmhaddshs -- - --------------- - - function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - VC : constant VSS_View := To_View (C); - D : VSS_View; - - begin - for J in Varray_signed_short'Range loop - D.Values (J) := LL_VSS_Operations.Saturate - ((SI64 (VA.Values (J)) * SI64 (VB.Values (J))) - / SI64 (2 ** 15) + SI64 (VC.Values (J))); - end loop; - - return To_Vector (D); - end vmhaddshs; - - ------------ - -- vmaxub -- - ------------ - - function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := LL_VUC_Operations.vmaxux (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vmaxub; - - ------------ - -- vmaxsb -- - ------------ - - function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vmaxsx (VA.Values, VB.Values); - return To_Vector (D); - end vmaxsb; - - ------------ - -- vmaxuh -- - ------------ - - function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := LL_VUS_Operations.vmaxux (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vmaxuh; - - ------------ - -- vmaxsh -- - ------------ - - function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vmaxsx (VA.Values, VB.Values); - return To_Vector (D); - end vmaxsh; - - ------------ - -- vmaxuw -- - ------------ - - function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := LL_VUI_Operations.vmaxux (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vmaxuw; - - ------------ - -- vmaxsw -- - ------------ - - function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vmaxsx (VA.Values, VB.Values); - return To_Vector (D); - end vmaxsw; - - -------------- - -- vmaxsxfp -- - -------------- - - function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : VF_View; - - begin - for J in Varray_float'Range loop - D.Values (J) := (if VA.Values (J) > VB.Values (J) then VA.Values (J) - else VB.Values (J)); - end loop; - - return To_Vector (D); - end vmaxfp; - - ------------ - -- vmrghb -- - ------------ - - function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vmrghx (VA.Values, VB.Values); - return To_Vector (D); - end vmrghb; - - ------------ - -- vmrghh -- - ------------ - - function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vmrghx (VA.Values, VB.Values); - return To_Vector (D); - end vmrghh; - - ------------ - -- vmrghw -- - ------------ - - function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vmrghx (VA.Values, VB.Values); - return To_Vector (D); - end vmrghw; - - ------------ - -- vmrglb -- - ------------ - - function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vmrglx (VA.Values, VB.Values); - return To_Vector (D); - end vmrglb; - - ------------ - -- vmrglh -- - ------------ - - function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vmrglx (VA.Values, VB.Values); - return To_Vector (D); - end vmrglh; - - ------------ - -- vmrglw -- - ------------ - - function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vmrglx (VA.Values, VB.Values); - return To_Vector (D); - end vmrglw; - - ------------ - -- mfvscr -- - ------------ - - function mfvscr return LL_VSS is - D : VUS_View; - begin - for J in Varray_unsigned_short'Range loop - D.Values (J) := 0; - end loop; - - D.Values (Varray_unsigned_short'Last) := - unsigned_short (VSCR mod 2 ** unsigned_short'Size); - D.Values (Varray_unsigned_short'Last - 1) := - unsigned_short (VSCR / 2 ** unsigned_short'Size); - return To_LL_VSS (To_Vector (D)); - end mfvscr; - - ------------ - -- vminfp -- - ------------ - - function vminfp (A : LL_VF; B : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : VF_View; - - begin - for J in Varray_float'Range loop - D.Values (J) := (if VA.Values (J) < VB.Values (J) then VA.Values (J) - else VB.Values (J)); - end loop; - - return To_Vector (D); - end vminfp; - - ------------ - -- vminsb -- - ------------ - - function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vminsx (VA.Values, VB.Values); - return To_Vector (D); - end vminsb; - - ------------ - -- vminub -- - ------------ - - function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := LL_VUC_Operations.vminux (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vminub; - - ------------ - -- vminsh -- - ------------ - - function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vminsx (VA.Values, VB.Values); - return To_Vector (D); - end vminsh; - - ------------ - -- vminuh -- - ------------ - - function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := LL_VUS_Operations.vminux (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vminuh; - - ------------ - -- vminsw -- - ------------ - - function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vminsx (VA.Values, VB.Values); - return To_Vector (D); - end vminsw; - - ------------ - -- vminuw -- - ------------ - - function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := LL_VUI_Operations.vminux (VA.Values, - VB.Values); - return To_LL_VSI (To_Vector (D)); - end vminuw; - - --------------- - -- vmladduhm -- - --------------- - - function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - VC : constant VUS_View := To_View (To_LL_VUS (C)); - D : VUS_View; - - begin - for J in Varray_unsigned_short'Range loop - D.Values (J) := VA.Values (J) * VB.Values (J) - + VC.Values (J); - end loop; - - return To_LL_VSS (To_Vector (D)); - end vmladduhm; - - ---------------- - -- vmhraddshs -- - ---------------- - - function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - VC : constant VSS_View := To_View (C); - D : VSS_View; - - begin - for J in Varray_signed_short'Range loop - D.Values (J) := - LL_VSS_Operations.Saturate (((SI64 (VA.Values (J)) - * SI64 (VB.Values (J)) - + 2 ** 14) - / 2 ** 15 - + SI64 (VC.Values (J)))); - end loop; - - return To_Vector (D); - end vmhraddshs; - - -------------- - -- vmsumubm -- - -------------- - - function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI is - Offset : Vchar_Range; - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - VC : constant VUI_View := To_View (To_LL_VUI (C)); - D : VUI_View; - - begin - for J in 0 .. 3 loop - Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); - D.Values (Vint_Range - (J + Integer (Vint_Range'First))) := - (unsigned_int (VA.Values (Offset)) - * unsigned_int (VB.Values (Offset))) - + (unsigned_int (VA.Values (Offset + 1)) - * unsigned_int (VB.Values (1 + Offset))) - + (unsigned_int (VA.Values (2 + Offset)) - * unsigned_int (VB.Values (2 + Offset))) - + (unsigned_int (VA.Values (3 + Offset)) - * unsigned_int (VB.Values (3 + Offset))) - + VC.Values (Vint_Range - (J + Integer (Varray_unsigned_int'First))); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vmsumubm; - - -------------- - -- vmsumumbm -- - -------------- - - function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI is - Offset : Vchar_Range; - VA : constant VSC_View := To_View (A); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - VC : constant VSI_View := To_View (C); - D : VSI_View; - - begin - for J in 0 .. 3 loop - Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); - D.Values (Vint_Range - (J + Integer (Varray_unsigned_int'First))) := 0 - + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset)) - * SI64 (VB.Values (Offset))) - + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset + 1)) - * SI64 (VB.Values - (1 + Offset))) - + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (2 + Offset)) - * SI64 (VB.Values - (2 + Offset))) - + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (3 + Offset)) - * SI64 (VB.Values - (3 + Offset))) - + VC.Values (Vint_Range - (J + Integer (Varray_unsigned_int'First))); - end loop; - - return To_Vector (D); - end vmsummbm; - - -------------- - -- vmsumuhm -- - -------------- - - function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is - Offset : Vshort_Range; - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - VC : constant VUI_View := To_View (To_LL_VUI (C)); - D : VUI_View; - - begin - for J in 0 .. 3 loop - Offset := - Vshort_Range (2 * J + Integer (Vshort_Range'First)); - D.Values (Vint_Range - (J + Integer (Varray_unsigned_int'First))) := - (unsigned_int (VA.Values (Offset)) - * unsigned_int (VB.Values (Offset))) - + (unsigned_int (VA.Values (Offset + 1)) - * unsigned_int (VB.Values (1 + Offset))) - + VC.Values (Vint_Range - (J + Integer (Vint_Range'First))); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vmsumuhm; - - -------------- - -- vmsumshm -- - -------------- - - function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - VC : constant VSI_View := To_View (C); - Offset : Vshort_Range; - D : VSI_View; - - begin - for J in 0 .. 3 loop - Offset := - Vshort_Range (2 * J + Integer (Varray_signed_char'First)); - D.Values (Vint_Range - (J + Integer (Varray_unsigned_int'First))) := 0 - + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset)) - * SI64 (VB.Values (Offset))) - + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset + 1)) - * SI64 (VB.Values - (1 + Offset))) - + VC.Values (Vint_Range - (J + Integer (Varray_unsigned_int'First))); - end loop; - - return To_Vector (D); - end vmsumshm; - - -------------- - -- vmsumuhs -- - -------------- - - function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is - Offset : Vshort_Range; - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - VC : constant VUI_View := To_View (To_LL_VUI (C)); - D : VUI_View; - - begin - for J in 0 .. 3 loop - Offset := - Vshort_Range (2 * J + Integer (Varray_signed_short'First)); - D.Values (Vint_Range - (J + Integer (Varray_unsigned_int'First))) := - LL_VUI_Operations.Saturate - (UI64 (VA.Values (Offset)) - * UI64 (VB.Values (Offset)) - + UI64 (VA.Values (Offset + 1)) - * UI64 (VB.Values (1 + Offset)) - + UI64 (VC.Values - (Vint_Range - (J + Integer (Varray_unsigned_int'First))))); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vmsumuhs; - - -------------- - -- vmsumshs -- - -------------- - - function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - VC : constant VSI_View := To_View (C); - Offset : Vshort_Range; - D : VSI_View; - - begin - for J in 0 .. 3 loop - Offset := - Vshort_Range (2 * J + Integer (Varray_signed_short'First)); - D.Values (Vint_Range - (J + Integer (Varray_signed_int'First))) := - LL_VSI_Operations.Saturate - (SI64 (VA.Values (Offset)) - * SI64 (VB.Values (Offset)) - + SI64 (VA.Values (Offset + 1)) - * SI64 (VB.Values (1 + Offset)) - + SI64 (VC.Values - (Vint_Range - (J + Integer (Varray_signed_int'First))))); - end loop; - - return To_Vector (D); - end vmsumshs; - - ------------ - -- mtvscr -- - ------------ - - procedure mtvscr (A : LL_VSI) is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - begin - VSCR := VA.Values (Varray_unsigned_int'Last); - end mtvscr; - - ------------- - -- vmuleub -- - ------------- - - function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUS_View; - begin - D.Values := LL_VUC_LL_VUS_Operations.vmulxux (True, - VA.Values, - VB.Values); - return To_LL_VSS (To_Vector (D)); - end vmuleub; - - ------------- - -- vmuleuh -- - ------------- - - function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUI_View; - begin - D.Values := LL_VUS_LL_VUI_Operations.vmulxux (True, - VA.Values, - VB.Values); - return To_LL_VSI (To_Vector (D)); - end vmuleuh; - - ------------- - -- vmulesb -- - ------------- - - function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSC_LL_VSS_Operations.vmulxsx (True, - VA.Values, - VB.Values); - return To_Vector (D); - end vmulesb; - - ------------- - -- vmulesh -- - ------------- - - function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSS_LL_VSI_Operations.vmulxsx (True, - VA.Values, - VB.Values); - return To_Vector (D); - end vmulesh; - - ------------- - -- vmuloub -- - ------------- - - function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUS_View; - begin - D.Values := LL_VUC_LL_VUS_Operations.vmulxux (False, - VA.Values, - VB.Values); - return To_LL_VSS (To_Vector (D)); - end vmuloub; - - ------------- - -- vmulouh -- - ------------- - - function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUI_View; - begin - D.Values := - LL_VUS_LL_VUI_Operations.vmulxux (False, VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vmulouh; - - ------------- - -- vmulosb -- - ------------- - - function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSC_LL_VSS_Operations.vmulxsx (False, - VA.Values, - VB.Values); - return To_Vector (D); - end vmulosb; - - ------------- - -- vmulosh -- - ------------- - - function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSS_LL_VSI_Operations.vmulxsx (False, - VA.Values, - VB.Values); - return To_Vector (D); - end vmulosh; - - -------------- - -- vnmsubfp -- - -------------- - - function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - VC : constant VF_View := To_View (C); - D : VF_View; - - begin - for J in Vfloat_Range'Range loop - D.Values (J) := - -Rnd_To_FP_Nearest (F64 (VA.Values (J)) - * F64 (VB.Values (J)) - - F64 (VC.Values (J))); - end loop; - - return To_Vector (D); - end vnmsubfp; - - ---------- - -- vnor -- - ---------- - - function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - for J in Vint_Range'Range loop - D.Values (J) := not (VA.Values (J) or VB.Values (J)); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vnor; - - ---------- - -- vor -- - ---------- - - function vor (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - for J in Vint_Range'Range loop - D.Values (J) := VA.Values (J) or VB.Values (J); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vor; - - ------------- - -- vpkuhum -- - ------------- - - function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUC_View; - begin - D.Values := LL_VUC_LL_VUS_Operations.vpkuxum (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vpkuhum; - - ------------- - -- vpkuwum -- - ------------- - - function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUS_View; - begin - D.Values := LL_VUS_LL_VUI_Operations.vpkuxum (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vpkuwum; - - ----------- - -- vpkpx -- - ----------- - - function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUS_View; - Offset : Vint_Range; - P16 : Pixel_16; - P32 : Pixel_32; - - begin - for J in 0 .. 3 loop - Offset := Vint_Range (J + Integer (Vshort_Range'First)); - P32 := To_Pixel (VA.Values (Offset)); - P16.T := Unsigned_1 (P32.T mod 2 ** 1); - P16.R := Unsigned_5 (Shift_Right (P32.R, 3) mod 2 ** 5); - P16.G := Unsigned_5 (Shift_Right (P32.G, 3) mod 2 ** 5); - P16.B := Unsigned_5 (Shift_Right (P32.B, 3) mod 2 ** 5); - D.Values (Vshort_Range (Offset)) := To_unsigned_short (P16); - P32 := To_Pixel (VB.Values (Offset)); - P16.T := Unsigned_1 (P32.T mod 2 ** 1); - P16.R := Unsigned_5 (Shift_Right (P32.R, 3) mod 2 ** 5); - P16.G := Unsigned_5 (Shift_Right (P32.G, 3) mod 2 ** 5); - P16.B := Unsigned_5 (Shift_Right (P32.B, 3) mod 2 ** 5); - D.Values (Vshort_Range (Offset) + 4) := To_unsigned_short (P16); - end loop; - - return To_LL_VSS (To_Vector (D)); - end vpkpx; - - ------------- - -- vpkuhus -- - ------------- - - function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUC_View; - begin - D.Values := LL_VUC_LL_VUS_Operations.vpkuxus (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vpkuhus; - - ------------- - -- vpkuwus -- - ------------- - - function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUS_View; - begin - D.Values := LL_VUS_LL_VUI_Operations.vpkuxus (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vpkuwus; - - ------------- - -- vpkshss -- - ------------- - - function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSC_View; - begin - D.Values := LL_VSC_LL_VSS_Operations.vpksxss (VA.Values, VB.Values); - return To_Vector (D); - end vpkshss; - - ------------- - -- vpkswss -- - ------------- - - function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSS_LL_VSI_Operations.vpksxss (VA.Values, VB.Values); - return To_Vector (D); - end vpkswss; - - ------------- - -- vpksxus -- - ------------- - - generic - type Signed_Component_Type is range <>; - type Signed_Index_Type is range <>; - type Signed_Varray_Type is - array (Signed_Index_Type) of Signed_Component_Type; - type Unsigned_Component_Type is mod <>; - type Unsigned_Index_Type is range <>; - type Unsigned_Varray_Type is - array (Unsigned_Index_Type) of Unsigned_Component_Type; - - function vpksxus - (A : Signed_Varray_Type; - B : Signed_Varray_Type) return Unsigned_Varray_Type; - - function vpksxus - (A : Signed_Varray_Type; - B : Signed_Varray_Type) return Unsigned_Varray_Type - is - N : constant Unsigned_Index_Type := - Unsigned_Index_Type (Signed_Index_Type'Last); - Offset : Unsigned_Index_Type; - Signed_Offset : Signed_Index_Type; - D : Unsigned_Varray_Type; - - function Saturate - (X : Signed_Component_Type) return Unsigned_Component_Type; - -- Saturation, as defined in - -- [PIM-4.1 Vector Status and Control Register] - - -------------- - -- Saturate -- - -------------- - - function Saturate - (X : Signed_Component_Type) return Unsigned_Component_Type - is - D : Unsigned_Component_Type; - - begin - D := Unsigned_Component_Type - (Signed_Component_Type'Max - (Signed_Component_Type (Unsigned_Component_Type'First), - Signed_Component_Type'Min - (Signed_Component_Type (Unsigned_Component_Type'Last), - X))); - if Signed_Component_Type (D) /= X then - VSCR := Write_Bit (VSCR, SAT_POS, 1); - end if; - - return D; - end Saturate; - - -- Start of processing for vpksxus - - begin - for J in 0 .. N - 1 loop - Offset := - Unsigned_Index_Type (Integer (J) - + Integer (Unsigned_Index_Type'First)); - Signed_Offset := - Signed_Index_Type (Integer (J) - + Integer (Signed_Index_Type'First)); - D (Offset) := Saturate (A (Signed_Offset)); - D (Offset + N) := Saturate (B (Signed_Offset)); - end loop; - - return D; - end vpksxus; - - ------------- - -- vpkshus -- - ------------- - - function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC is - function vpkshus_Instance is - new vpksxus (signed_short, - Vshort_Range, - Varray_signed_short, - unsigned_char, - Vchar_Range, - Varray_unsigned_char); - - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VUC_View; - - begin - D.Values := vpkshus_Instance (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vpkshus; - - ------------- - -- vpkswus -- - ------------- - - function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS is - function vpkswus_Instance is - new vpksxus (signed_int, - Vint_Range, - Varray_signed_int, - unsigned_short, - Vshort_Range, - Varray_unsigned_short); - - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VUS_View; - begin - D.Values := vpkswus_Instance (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vpkswus; - - --------------- - -- vperm_4si -- - --------------- - - function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - VC : constant VUC_View := To_View (To_LL_VUC (C)); - J : Vchar_Range; - D : VUC_View; - - begin - for N in Vchar_Range'Range loop - J := Vchar_Range (Integer (Bits (VC.Values (N), 4, 7)) - + Integer (Vchar_Range'First)); - D.Values (N) := - (if Bits (VC.Values (N), 3, 3) = 0 then VA.Values (J) - else VB.Values (J)); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vperm_4si; - - ----------- - -- vrefp -- - ----------- - - function vrefp (A : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - D : VF_View; - - begin - for J in Vfloat_Range'Range loop - D.Values (J) := FP_Recip_Est (VA.Values (J)); - end loop; - - return To_Vector (D); - end vrefp; - - ---------- - -- vrlb -- - ---------- - - function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := LL_VUC_Operations.vrlx (VA.Values, VB.Values, ROTL'Access); - return To_LL_VSC (To_Vector (D)); - end vrlb; - - ---------- - -- vrlh -- - ---------- - - function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := LL_VUS_Operations.vrlx (VA.Values, VB.Values, ROTL'Access); - return To_LL_VSS (To_Vector (D)); - end vrlh; - - ---------- - -- vrlw -- - ---------- - - function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := LL_VUI_Operations.vrlx (VA.Values, VB.Values, ROTL'Access); - return To_LL_VSI (To_Vector (D)); - end vrlw; - - ----------- - -- vrfin -- - ----------- - - function vrfin (A : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - D : VF_View; - - begin - for J in Vfloat_Range'Range loop - D.Values (J) := C_float (Rnd_To_FPI_Near (F64 (VA.Values (J)))); - end loop; - - return To_Vector (D); - end vrfin; - - --------------- - -- vrsqrtefp -- - --------------- - - function vrsqrtefp (A : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - D : VF_View; - - begin - for J in Vfloat_Range'Range loop - D.Values (J) := Recip_SQRT_Est (VA.Values (J)); - end loop; - - return To_Vector (D); - end vrsqrtefp; - - -------------- - -- vsel_4si -- - -------------- - - function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - VC : constant VUI_View := To_View (To_LL_VUI (C)); - D : VUI_View; - - begin - for J in Vint_Range'Range loop - D.Values (J) := ((not VC.Values (J)) and VA.Values (J)) - or (VC.Values (J) and VB.Values (J)); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vsel_4si; - - ---------- - -- vslb -- - ---------- - - function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := - LL_VUC_Operations.vsxx (VA.Values, VB.Values, Shift_Left'Access); - return To_LL_VSC (To_Vector (D)); - end vslb; - - ---------- - -- vslh -- - ---------- - - function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := - LL_VUS_Operations.vsxx (VA.Values, VB.Values, Shift_Left'Access); - return To_LL_VSS (To_Vector (D)); - end vslh; - - ---------- - -- vslw -- - ---------- - - function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := - LL_VUI_Operations.vsxx (VA.Values, VB.Values, Shift_Left'Access); - return To_LL_VSI (To_Vector (D)); - end vslw; - - ---------------- - -- vsldoi_4si -- - ---------------- - - function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - Offset : c_int; - Bound : c_int; - D : VUC_View; - - begin - for J in Vchar_Range'Range loop - Offset := c_int (J) + C; - Bound := c_int (Vchar_Range'First) - + c_int (Varray_unsigned_char'Length); - - if Offset < Bound then - D.Values (J) := VA.Values (Vchar_Range (Offset)); - else - D.Values (J) := - VB.Values (Vchar_Range (Offset - Bound - + c_int (Vchar_Range'First))); - end if; - end loop; - - return To_LL_VSI (To_Vector (D)); - end vsldoi_4si; - - ---------------- - -- vsldoi_8hi -- - ---------------- - - function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS is - begin - return To_LL_VSS (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); - end vsldoi_8hi; - - ----------------- - -- vsldoi_16qi -- - ----------------- - - function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC is - begin - return To_LL_VSC (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); - end vsldoi_16qi; - - ---------------- - -- vsldoi_4sf -- - ---------------- - - function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF is - begin - return To_LL_VF (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); - end vsldoi_4sf; - - --------- - -- vsl -- - --------- - - function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - M : constant Natural := - Natural (Bits (VB.Values (Vint_Range'Last), 29, 31)); - - -- [PIM-4.4 vec_sll] "Note that the three low-order byte elements in B - -- must be the same. Otherwise the value placed into D is undefined." - -- ??? Shall we add a optional check for B? - - begin - for J in Vint_Range'Range loop - D.Values (J) := 0; - D.Values (J) := D.Values (J) + Shift_Left (VA.Values (J), M); - - if J /= Vint_Range'Last then - D.Values (J) := - D.Values (J) + Shift_Right (VA.Values (J + 1), - signed_int'Size - M); - end if; - end loop; - - return To_LL_VSI (To_Vector (D)); - end vsl; - - ---------- - -- vslo -- - ---------- - - function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - M : constant Natural := - Natural (Bits (VB.Values (Vchar_Range'Last), 1, 4)); - J : Natural; - - begin - for N in Vchar_Range'Range loop - J := Natural (N) + M; - D.Values (N) := - (if J <= Natural (Vchar_Range'Last) then VA.Values (Vchar_Range (J)) - else 0); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vslo; - - ------------ - -- vspltb -- - ------------ - - function vspltb (A : LL_VSC; B : c_int) return LL_VSC is - VA : constant VSC_View := To_View (A); - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vspltx (VA.Values, B); - return To_Vector (D); - end vspltb; - - ------------ - -- vsplth -- - ------------ - - function vsplth (A : LL_VSS; B : c_int) return LL_VSS is - VA : constant VSS_View := To_View (A); - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vspltx (VA.Values, B); - return To_Vector (D); - end vsplth; - - ------------ - -- vspltw -- - ------------ - - function vspltw (A : LL_VSI; B : c_int) return LL_VSI is - VA : constant VSI_View := To_View (A); - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vspltx (VA.Values, B); - return To_Vector (D); - end vspltw; - - -------------- - -- vspltisb -- - -------------- - - function vspltisb (A : c_int) return LL_VSC is - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vspltisx (A); - return To_Vector (D); - end vspltisb; - - -------------- - -- vspltish -- - -------------- - - function vspltish (A : c_int) return LL_VSS is - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vspltisx (A); - return To_Vector (D); - end vspltish; - - -------------- - -- vspltisw -- - -------------- - - function vspltisw (A : c_int) return LL_VSI is - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vspltisx (A); - return To_Vector (D); - end vspltisw; - - ---------- - -- vsrb -- - ---------- - - function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := - LL_VUC_Operations.vsxx (VA.Values, VB.Values, Shift_Right'Access); - return To_LL_VSC (To_Vector (D)); - end vsrb; - - ---------- - -- vsrh -- - ---------- - - function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := - LL_VUS_Operations.vsxx (VA.Values, VB.Values, Shift_Right'Access); - return To_LL_VSS (To_Vector (D)); - end vsrh; - - ---------- - -- vsrw -- - ---------- - - function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := - LL_VUI_Operations.vsxx (VA.Values, VB.Values, Shift_Right'Access); - return To_LL_VSI (To_Vector (D)); - end vsrw; - - ----------- - -- vsrab -- - ----------- - - function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - begin - D.Values := - LL_VSC_Operations.vsrax (VA.Values, VB.Values, Shift_Right_A'Access); - return To_Vector (D); - end vsrab; - - ----------- - -- vsrah -- - ----------- - - function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - begin - D.Values := - LL_VSS_Operations.vsrax (VA.Values, VB.Values, Shift_Right_A'Access); - return To_Vector (D); - end vsrah; - - ----------- - -- vsraw -- - ----------- - - function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - begin - D.Values := - LL_VSI_Operations.vsrax (VA.Values, VB.Values, Shift_Right_A'Access); - return To_Vector (D); - end vsraw; - - --------- - -- vsr -- - --------- - - function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - M : constant Natural := - Natural (Bits (VB.Values (Vint_Range'Last), 29, 31)); - D : VUI_View; - - begin - for J in Vint_Range'Range loop - D.Values (J) := 0; - D.Values (J) := D.Values (J) + Shift_Right (VA.Values (J), M); - - if J /= Vint_Range'First then - D.Values (J) := - D.Values (J) - + Shift_Left (VA.Values (J - 1), signed_int'Size - M); - end if; - end loop; - - return To_LL_VSI (To_Vector (D)); - end vsr; - - ---------- - -- vsro -- - ---------- - - function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - M : constant Natural := - Natural (Bits (VB.Values (Vchar_Range'Last), 1, 4)); - J : Natural; - D : VUC_View; - - begin - for N in Vchar_Range'Range loop - J := Natural (N) - M; - - if J >= Natural (Vchar_Range'First) then - D.Values (N) := VA.Values (Vchar_Range (J)); - else - D.Values (N) := 0; - end if; - end loop; - - return To_LL_VSI (To_Vector (D)); - end vsro; - - ---------- - -- stvx -- - ---------- - - procedure stvx (A : LL_VSI; B : c_int; C : c_ptr) is - - -- Simulate the altivec unit behavior regarding what Effective Address - -- is accessed, stripping off the input address least significant bits - -- wrt to vector alignment (see comment in lvx for further details). - - EA : constant System.Address := - To_Address - (Bound_Align - (Integer_Address (B) + To_Integer (C), VECTOR_ALIGNMENT)); - - D : LL_VSI; - for D'Address use EA; - - begin - D := A; - end stvx; - - ------------ - -- stvewx -- - ------------ - - procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr) is - VA : constant VSC_View := To_View (A); - begin - LL_VSC_Operations.stvexx (VA.Values, B, C); - end stvebx; - - ------------ - -- stvehx -- - ------------ - - procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr) is - VA : constant VSS_View := To_View (A); - begin - LL_VSS_Operations.stvexx (VA.Values, B, C); - end stvehx; - - ------------ - -- stvewx -- - ------------ - - procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr) is - VA : constant VSI_View := To_View (A); - begin - LL_VSI_Operations.stvexx (VA.Values, B, C); - end stvewx; - - ----------- - -- stvxl -- - ----------- - - procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr) renames stvx; - - ------------- - -- vsububm -- - ------------- - - function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := LL_VUC_Operations.vsubuxm (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vsububm; - - ------------- - -- vsubuhm -- - ------------- - - function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := LL_VUS_Operations.vsubuxm (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vsubuhm; - - ------------- - -- vsubuwm -- - ------------- - - function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := LL_VUI_Operations.vsubuxm (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vsubuwm; - - ------------ - -- vsubfp -- - ------------ - - function vsubfp (A : LL_VF; B : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - VB : constant VF_View := To_View (B); - D : VF_View; - - begin - for J in Vfloat_Range'Range loop - D.Values (J) := - NJ_Truncate (NJ_Truncate (VA.Values (J)) - - NJ_Truncate (VB.Values (J))); - end loop; - - return To_Vector (D); - end vsubfp; - - ------------- - -- vsubcuw -- - ------------- - - function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI is - Subst_Result : SI64; - - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - for J in Vint_Range'Range loop - Subst_Result := SI64 (VA.Values (J)) - SI64 (VB.Values (J)); - D.Values (J) := - (if Subst_Result < SI64 (unsigned_int'First) then 0 else 1); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vsubcuw; - - ------------- - -- vsububs -- - ------------- - - function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUC_View := To_View (To_LL_VUC (B)); - D : VUC_View; - begin - D.Values := LL_VUC_Operations.vsubuxs (VA.Values, VB.Values); - return To_LL_VSC (To_Vector (D)); - end vsububs; - - ------------- - -- vsubsbs -- - ------------- - - function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC is - VA : constant VSC_View := To_View (A); - VB : constant VSC_View := To_View (B); - D : VSC_View; - begin - D.Values := LL_VSC_Operations.vsubsxs (VA.Values, VB.Values); - return To_Vector (D); - end vsubsbs; - - ------------- - -- vsubuhs -- - ------------- - - function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - VB : constant VUS_View := To_View (To_LL_VUS (B)); - D : VUS_View; - begin - D.Values := LL_VUS_Operations.vsubuxs (VA.Values, VB.Values); - return To_LL_VSS (To_Vector (D)); - end vsubuhs; - - ------------- - -- vsubshs -- - ------------- - - function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS is - VA : constant VSS_View := To_View (A); - VB : constant VSS_View := To_View (B); - D : VSS_View; - begin - D.Values := LL_VSS_Operations.vsubsxs (VA.Values, VB.Values); - return To_Vector (D); - end vsubshs; - - ------------- - -- vsubuws -- - ------------- - - function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - begin - D.Values := LL_VUI_Operations.vsubuxs (VA.Values, VB.Values); - return To_LL_VSI (To_Vector (D)); - end vsubuws; - - ------------- - -- vsubsws -- - ------------- - - function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - begin - D.Values := LL_VSI_Operations.vsubsxs (VA.Values, VB.Values); - return To_Vector (D); - end vsubsws; - - -------------- - -- vsum4ubs -- - -------------- - - function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI is - VA : constant VUC_View := To_View (To_LL_VUC (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - Offset : Vchar_Range; - D : VUI_View; - - begin - for J in 0 .. 3 loop - Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); - D.Values (Vint_Range (J + Integer (Vint_Range'First))) := - LL_VUI_Operations.Saturate - (UI64 (VA.Values (Offset)) - + UI64 (VA.Values (Offset + 1)) - + UI64 (VA.Values (Offset + 2)) - + UI64 (VA.Values (Offset + 3)) - + UI64 (VB.Values (Vint_Range (J + Integer (Vint_Range'First))))); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vsum4ubs; - - -------------- - -- vsum4sbs -- - -------------- - - function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI is - VA : constant VSC_View := To_View (A); - VB : constant VSI_View := To_View (B); - Offset : Vchar_Range; - D : VSI_View; - - begin - for J in 0 .. 3 loop - Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); - D.Values (Vint_Range (J + Integer (Vint_Range'First))) := - LL_VSI_Operations.Saturate - (SI64 (VA.Values (Offset)) - + SI64 (VA.Values (Offset + 1)) - + SI64 (VA.Values (Offset + 2)) - + SI64 (VA.Values (Offset + 3)) - + SI64 (VB.Values (Vint_Range (J + Integer (Vint_Range'First))))); - end loop; - - return To_Vector (D); - end vsum4sbs; - - -------------- - -- vsum4shs -- - -------------- - - function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI is - VA : constant VSS_View := To_View (A); - VB : constant VSI_View := To_View (B); - Offset : Vshort_Range; - D : VSI_View; - - begin - for J in 0 .. 3 loop - Offset := Vshort_Range (2 * J + Integer (Vchar_Range'First)); - D.Values (Vint_Range (J + Integer (Vint_Range'First))) := - LL_VSI_Operations.Saturate - (SI64 (VA.Values (Offset)) - + SI64 (VA.Values (Offset + 1)) - + SI64 (VB.Values (Vint_Range (J + Integer (Vint_Range'First))))); - end loop; - - return To_Vector (D); - end vsum4shs; - - -------------- - -- vsum2sws -- - -------------- - - function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - Offset : Vint_Range; - D : VSI_View; - - begin - for J in 0 .. 1 loop - Offset := Vint_Range (2 * J + Integer (Vchar_Range'First)); - D.Values (Offset) := 0; - D.Values (Offset + 1) := - LL_VSI_Operations.Saturate - (SI64 (VA.Values (Offset)) - + SI64 (VA.Values (Offset + 1)) - + SI64 (VB.Values (Vint_Range (Offset + 1)))); - end loop; - - return To_Vector (D); - end vsum2sws; - - ------------- - -- vsumsws -- - ------------- - - function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VSI_View := To_View (A); - VB : constant VSI_View := To_View (B); - D : VSI_View; - Sum_Buffer : SI64 := 0; - - begin - for J in Vint_Range'Range loop - D.Values (J) := 0; - Sum_Buffer := Sum_Buffer + SI64 (VA.Values (J)); - end loop; - - Sum_Buffer := Sum_Buffer + SI64 (VB.Values (Vint_Range'Last)); - D.Values (Vint_Range'Last) := LL_VSI_Operations.Saturate (Sum_Buffer); - return To_Vector (D); - end vsumsws; - - ----------- - -- vrfiz -- - ----------- - - function vrfiz (A : LL_VF) return LL_VF is - VA : constant VF_View := To_View (A); - D : VF_View; - begin - for J in Vfloat_Range'Range loop - D.Values (J) := C_float (Rnd_To_FPI_Trunc (F64 (VA.Values (J)))); - end loop; - - return To_Vector (D); - end vrfiz; - - ------------- - -- vupkhsb -- - ------------- - - function vupkhsb (A : LL_VSC) return LL_VSS is - VA : constant VSC_View := To_View (A); - D : VSS_View; - begin - D.Values := LL_VSC_LL_VSS_Operations.vupkxsx (VA.Values, 0); - return To_Vector (D); - end vupkhsb; - - ------------- - -- vupkhsh -- - ------------- - - function vupkhsh (A : LL_VSS) return LL_VSI is - VA : constant VSS_View := To_View (A); - D : VSI_View; - begin - D.Values := LL_VSS_LL_VSI_Operations.vupkxsx (VA.Values, 0); - return To_Vector (D); - end vupkhsh; - - ------------- - -- vupkxpx -- - ------------- - - function vupkxpx (A : LL_VSS; Offset : Natural) return LL_VSI; - -- For vupkhpx and vupklpx (depending on Offset) - - function vupkxpx (A : LL_VSS; Offset : Natural) return LL_VSI is - VA : constant VUS_View := To_View (To_LL_VUS (A)); - K : Vshort_Range; - D : VUI_View; - P16 : Pixel_16; - P32 : Pixel_32; - - function Sign_Extend (X : Unsigned_1) return unsigned_char; - - function Sign_Extend (X : Unsigned_1) return unsigned_char is - begin - if X = 1 then - return 16#FF#; - else - return 16#00#; - end if; - end Sign_Extend; - - begin - for J in Vint_Range'Range loop - K := Vshort_Range (Integer (J) - - Integer (Vint_Range'First) - + Integer (Vshort_Range'First) - + Offset); - P16 := To_Pixel (VA.Values (K)); - P32.T := Sign_Extend (P16.T); - P32.R := unsigned_char (P16.R); - P32.G := unsigned_char (P16.G); - P32.B := unsigned_char (P16.B); - D.Values (J) := To_unsigned_int (P32); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vupkxpx; - - ------------- - -- vupkhpx -- - ------------- - - function vupkhpx (A : LL_VSS) return LL_VSI is - begin - return vupkxpx (A, 0); - end vupkhpx; - - ------------- - -- vupklsb -- - ------------- - - function vupklsb (A : LL_VSC) return LL_VSS is - VA : constant VSC_View := To_View (A); - D : VSS_View; - begin - D.Values := - LL_VSC_LL_VSS_Operations.vupkxsx (VA.Values, - Varray_signed_short'Length); - return To_Vector (D); - end vupklsb; - - ------------- - -- vupklsh -- - ------------- - - function vupklsh (A : LL_VSS) return LL_VSI is - VA : constant VSS_View := To_View (A); - D : VSI_View; - begin - D.Values := - LL_VSS_LL_VSI_Operations.vupkxsx (VA.Values, - Varray_signed_int'Length); - return To_Vector (D); - end vupklsh; - - ------------- - -- vupklpx -- - ------------- - - function vupklpx (A : LL_VSS) return LL_VSI is - begin - return vupkxpx (A, Varray_signed_int'Length); - end vupklpx; - - ---------- - -- vxor -- - ---------- - - function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI is - VA : constant VUI_View := To_View (To_LL_VUI (A)); - VB : constant VUI_View := To_View (To_LL_VUI (B)); - D : VUI_View; - - begin - for J in Vint_Range'Range loop - D.Values (J) := VA.Values (J) xor VB.Values (J); - end loop; - - return To_LL_VSI (To_Vector (D)); - end vxor; - - ---------------- - -- vcmpequb_p -- - ---------------- - - function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int is - D : LL_VSC; - begin - D := vcmpequb (B, C); - return LL_VSC_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpequb_p; - - ---------------- - -- vcmpequh_p -- - ---------------- - - function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int is - D : LL_VSS; - begin - D := vcmpequh (B, C); - return LL_VSS_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpequh_p; - - ---------------- - -- vcmpequw_p -- - ---------------- - - function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int is - D : LL_VSI; - begin - D := vcmpequw (B, C); - return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpequw_p; - - ---------------- - -- vcmpeqfp_p -- - ---------------- - - function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is - D : LL_VSI; - begin - D := vcmpeqfp (B, C); - return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpeqfp_p; - - ---------------- - -- vcmpgtub_p -- - ---------------- - - function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int is - D : LL_VSC; - begin - D := vcmpgtub (B, C); - return LL_VSC_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgtub_p; - - ---------------- - -- vcmpgtuh_p -- - ---------------- - - function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int is - D : LL_VSS; - begin - D := vcmpgtuh (B, C); - return LL_VSS_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgtuh_p; - - ---------------- - -- vcmpgtuw_p -- - ---------------- - - function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int is - D : LL_VSI; - begin - D := vcmpgtuw (B, C); - return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgtuw_p; - - ---------------- - -- vcmpgtsb_p -- - ---------------- - - function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int is - D : LL_VSC; - begin - D := vcmpgtsb (B, C); - return LL_VSC_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgtsb_p; - - ---------------- - -- vcmpgtsh_p -- - ---------------- - - function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int is - D : LL_VSS; - begin - D := vcmpgtsh (B, C); - return LL_VSS_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgtsh_p; - - ---------------- - -- vcmpgtsw_p -- - ---------------- - - function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int is - D : LL_VSI; - begin - D := vcmpgtsw (B, C); - return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgtsw_p; - - ---------------- - -- vcmpgefp_p -- - ---------------- - - function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is - D : LL_VSI; - begin - D := vcmpgefp (B, C); - return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgefp_p; - - ---------------- - -- vcmpgtfp_p -- - ---------------- - - function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is - D : LL_VSI; - begin - D := vcmpgtfp (B, C); - return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); - end vcmpgtfp_p; - - ---------------- - -- vcmpbfp_p -- - ---------------- - - function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is - D : VSI_View; - begin - D := To_View (vcmpbfp (B, C)); - - for J in Vint_Range'Range loop - - -- vcmpbfp is not returning the usual bool vector; do the conversion - - D.Values (J) := - (if D.Values (J) = 0 then Signed_Bool_False else Signed_Bool_True); - end loop; - - return LL_VSI_Operations.Check_CR6 (A, D.Values); - end vcmpbfp_p; - -end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/g-alleve.ads b/gcc/ada/g-alleve.ads deleted file mode 100644 index 66718c1..0000000 --- a/gcc/ada/g-alleve.ads +++ /dev/null @@ -1,525 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- --- -- --- S p e c -- --- (Soft Binding Version) -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit exposes the low level vector support for the Soft binding, --- intended for non AltiVec capable targets. See Altivec.Design for a --- description of what is expected to be exposed. - -with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; - -package GNAT.Altivec.Low_Level_Vectors is - - ---------------------------------------- - -- Low level vector type declarations -- - ---------------------------------------- - - type LL_VUC is private; - type LL_VSC is private; - type LL_VBC is private; - - type LL_VUS is private; - type LL_VSS is private; - type LL_VBS is private; - - type LL_VUI is private; - type LL_VSI is private; - type LL_VBI is private; - - type LL_VF is private; - type LL_VP is private; - - ------------------------------------ - -- Low level functional interface -- - ------------------------------------ - - function abs_v16qi (A : LL_VSC) return LL_VSC; - function abs_v8hi (A : LL_VSS) return LL_VSS; - function abs_v4si (A : LL_VSI) return LL_VSI; - function abs_v4sf (A : LL_VF) return LL_VF; - - function abss_v16qi (A : LL_VSC) return LL_VSC; - function abss_v8hi (A : LL_VSS) return LL_VSS; - function abss_v4si (A : LL_VSI) return LL_VSI; - - function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vaddfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vand (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI; - - function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VSI; - - function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VSI; - - function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VSI; - - function vcfux (A : LL_VUI; B : c_int) return LL_VF; - function vcfsx (A : LL_VSI; B : c_int) return LL_VF; - - function vctsxs (A : LL_VF; B : c_int) return LL_VSI; - function vctuxs (A : LL_VF; B : c_int) return LL_VUI; - - procedure dss (A : c_int); - procedure dssall; - - procedure dst (A : c_ptr; B : c_int; C : c_int); - procedure dstst (A : c_ptr; B : c_int; C : c_int); - procedure dststt (A : c_ptr; B : c_int; C : c_int); - procedure dstt (A : c_ptr; B : c_int; C : c_int); - - function vexptefp (A : LL_VF) return LL_VF; - - function vrfim (A : LL_VF) return LL_VF; - - function lvx (A : c_long; B : c_ptr) return LL_VSI; - function lvebx (A : c_long; B : c_ptr) return LL_VSC; - function lvehx (A : c_long; B : c_ptr) return LL_VSS; - function lvewx (A : c_long; B : c_ptr) return LL_VSI; - function lvxl (A : c_long; B : c_ptr) return LL_VSI; - - function vlogefp (A : LL_VF) return LL_VF; - - function lvsl (A : c_long; B : c_ptr) return LL_VSC; - function lvsr (A : c_long; B : c_ptr) return LL_VSC; - - function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; - - function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; - - function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function mfvscr return LL_VSS; - - function vminfp (A : LL_VF; B : LL_VF) return LL_VF; - function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; - - function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; - - function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; - function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; - function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; - - procedure mtvscr (A : LL_VSI); - - function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI; - function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI; - - function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI; - function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS; - function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI; - - function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; - - function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vor (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS; - function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC; - function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS; - - function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI; - - function vrefp (A : LL_VF) return LL_VF; - - function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vrfin (A : LL_VF) return LL_VF; - function vrfip (A : LL_VF) return LL_VF; - function vrfiz (A : LL_VF) return LL_VF; - - function vrsqrtefp (A : LL_VF) return LL_VF; - - function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI; - - function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI; - function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS; - function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC; - function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF; - - function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vspltb (A : LL_VSC; B : c_int) return LL_VSC; - function vsplth (A : LL_VSS; B : c_int) return LL_VSS; - function vspltw (A : LL_VSI; B : c_int) return LL_VSI; - - function vspltisb (A : c_int) return LL_VSC; - function vspltish (A : c_int) return LL_VSS; - function vspltisw (A : c_int) return LL_VSI; - - function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI; - - procedure stvx (A : LL_VSI; B : c_int; C : c_ptr); - procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr); - procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr); - procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr); - procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr); - - function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsubfp (A : LL_VF; B : LL_VF) return LL_VF; - - function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; - function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS; - function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI; - function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI; - function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI; - - function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI; - function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI; - - function vupkhsb (A : LL_VSC) return LL_VSS; - function vupkhsh (A : LL_VSS) return LL_VSI; - function vupkhpx (A : LL_VSS) return LL_VSI; - - function vupklsb (A : LL_VSC) return LL_VSS; - function vupklsh (A : LL_VSS) return LL_VSI; - function vupklpx (A : LL_VSS) return LL_VSI; - - function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; - function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; - function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; - function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - - function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; - function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; - function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; - function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; - function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; - function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; - function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - - function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; - -private - - --------------------------------------- - -- Low level vector type definitions -- - --------------------------------------- - - -- We simply use the natural array definitions corresponding to each - -- user-level vector type. - - type LL_VUI is new VUI_View; - type LL_VSI is new VSI_View; - type LL_VBI is new VBI_View; - - type LL_VUS is new VUS_View; - type LL_VSS is new VSS_View; - type LL_VBS is new VBS_View; - - type LL_VUC is new VUC_View; - type LL_VSC is new VSC_View; - type LL_VBC is new VBC_View; - - type LL_VF is new VF_View; - type LL_VP is new VP_View; - - ------------------------------------ - -- Low level functional interface -- - ------------------------------------ - - pragma Convention_Identifier (LL_Altivec, C); - - pragma Export (LL_Altivec, dss, "__builtin_altivec_dss"); - pragma Export (LL_Altivec, dssall, "__builtin_altivec_dssall"); - pragma Export (LL_Altivec, dst, "__builtin_altivec_dst"); - pragma Export (LL_Altivec, dstst, "__builtin_altivec_dstst"); - pragma Export (LL_Altivec, dststt, "__builtin_altivec_dststt"); - pragma Export (LL_Altivec, dstt, "__builtin_altivec_dstt"); - pragma Export (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr"); - pragma Export (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr"); - pragma Export (LL_Altivec, stvebx, "__builtin_altivec_stvebx"); - pragma Export (LL_Altivec, stvehx, "__builtin_altivec_stvehx"); - pragma Export (LL_Altivec, stvewx, "__builtin_altivec_stvewx"); - pragma Export (LL_Altivec, stvx, "__builtin_altivec_stvx"); - pragma Export (LL_Altivec, stvxl, "__builtin_altivec_stvxl"); - pragma Export (LL_Altivec, lvebx, "__builtin_altivec_lvebx"); - pragma Export (LL_Altivec, lvehx, "__builtin_altivec_lvehx"); - pragma Export (LL_Altivec, lvewx, "__builtin_altivec_lvewx"); - pragma Export (LL_Altivec, lvx, "__builtin_altivec_lvx"); - pragma Export (LL_Altivec, lvxl, "__builtin_altivec_lvxl"); - pragma Export (LL_Altivec, lvsl, "__builtin_altivec_lvsl"); - pragma Export (LL_Altivec, lvsr, "__builtin_altivec_lvsr"); - pragma Export (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi"); - pragma Export (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi"); - pragma Export (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si"); - pragma Export (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf"); - pragma Export (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi"); - pragma Export (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi"); - pragma Export (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si"); - pragma Export (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw"); - pragma Export (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp"); - pragma Export (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs"); - pragma Export (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs"); - pragma Export (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws"); - pragma Export (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm"); - pragma Export (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs"); - pragma Export (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm"); - pragma Export (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs"); - pragma Export (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm"); - pragma Export (LL_Altivec, vadduws, "__builtin_altivec_vadduws"); - pragma Export (LL_Altivec, vand, "__builtin_altivec_vand"); - pragma Export (LL_Altivec, vandc, "__builtin_altivec_vandc"); - pragma Export (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb"); - pragma Export (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh"); - pragma Export (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw"); - pragma Export (LL_Altivec, vavgub, "__builtin_altivec_vavgub"); - pragma Export (LL_Altivec, vavguh, "__builtin_altivec_vavguh"); - pragma Export (LL_Altivec, vavguw, "__builtin_altivec_vavguw"); - pragma Export (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx"); - pragma Export (LL_Altivec, vcfux, "__builtin_altivec_vcfux"); - pragma Export (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp"); - pragma Export (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp"); - pragma Export (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb"); - pragma Export (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh"); - pragma Export (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw"); - pragma Export (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp"); - pragma Export (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp"); - pragma Export (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb"); - pragma Export (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh"); - pragma Export (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw"); - pragma Export (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub"); - pragma Export (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh"); - pragma Export (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw"); - pragma Export (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs"); - pragma Export (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs"); - pragma Export (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp"); - pragma Export (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp"); - pragma Export (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp"); - pragma Export (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp"); - pragma Export (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb"); - pragma Export (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh"); - pragma Export (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw"); - pragma Export (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub"); - pragma Export (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh"); - pragma Export (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw"); - pragma Export (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs"); - pragma Export (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs"); - pragma Export (LL_Altivec, vminfp, "__builtin_altivec_vminfp"); - pragma Export (LL_Altivec, vminsb, "__builtin_altivec_vminsb"); - pragma Export (LL_Altivec, vminsh, "__builtin_altivec_vminsh"); - pragma Export (LL_Altivec, vminsw, "__builtin_altivec_vminsw"); - pragma Export (LL_Altivec, vminub, "__builtin_altivec_vminub"); - pragma Export (LL_Altivec, vminuh, "__builtin_altivec_vminuh"); - pragma Export (LL_Altivec, vminuw, "__builtin_altivec_vminuw"); - pragma Export (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm"); - pragma Export (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb"); - pragma Export (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh"); - pragma Export (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw"); - pragma Export (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb"); - pragma Export (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh"); - pragma Export (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw"); - pragma Export (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm"); - pragma Export (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm"); - pragma Export (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs"); - pragma Export (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm"); - pragma Export (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm"); - pragma Export (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs"); - pragma Export (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb"); - pragma Export (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh"); - pragma Export (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub"); - pragma Export (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh"); - pragma Export (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb"); - pragma Export (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh"); - pragma Export (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub"); - pragma Export (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh"); - pragma Export (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp"); - pragma Export (LL_Altivec, vnor, "__builtin_altivec_vnor"); - pragma Export (LL_Altivec, vxor, "__builtin_altivec_vxor"); - pragma Export (LL_Altivec, vor, "__builtin_altivec_vor"); - pragma Export (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si"); - pragma Export (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx"); - pragma Export (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss"); - pragma Export (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus"); - pragma Export (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss"); - pragma Export (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus"); - pragma Export (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum"); - pragma Export (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus"); - pragma Export (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum"); - pragma Export (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus"); - pragma Export (LL_Altivec, vrefp, "__builtin_altivec_vrefp"); - pragma Export (LL_Altivec, vrfim, "__builtin_altivec_vrfim"); - pragma Export (LL_Altivec, vrfin, "__builtin_altivec_vrfin"); - pragma Export (LL_Altivec, vrfip, "__builtin_altivec_vrfip"); - pragma Export (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz"); - pragma Export (LL_Altivec, vrlb, "__builtin_altivec_vrlb"); - pragma Export (LL_Altivec, vrlh, "__builtin_altivec_vrlh"); - pragma Export (LL_Altivec, vrlw, "__builtin_altivec_vrlw"); - pragma Export (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp"); - pragma Export (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si"); - pragma Export (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si"); - pragma Export (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi"); - pragma Export (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi"); - pragma Export (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf"); - pragma Export (LL_Altivec, vsl, "__builtin_altivec_vsl"); - pragma Export (LL_Altivec, vslb, "__builtin_altivec_vslb"); - pragma Export (LL_Altivec, vslh, "__builtin_altivec_vslh"); - pragma Export (LL_Altivec, vslo, "__builtin_altivec_vslo"); - pragma Export (LL_Altivec, vslw, "__builtin_altivec_vslw"); - pragma Export (LL_Altivec, vspltb, "__builtin_altivec_vspltb"); - pragma Export (LL_Altivec, vsplth, "__builtin_altivec_vsplth"); - pragma Export (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb"); - pragma Export (LL_Altivec, vspltish, "__builtin_altivec_vspltish"); - pragma Export (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw"); - pragma Export (LL_Altivec, vspltw, "__builtin_altivec_vspltw"); - pragma Export (LL_Altivec, vsr, "__builtin_altivec_vsr"); - pragma Export (LL_Altivec, vsrab, "__builtin_altivec_vsrab"); - pragma Export (LL_Altivec, vsrah, "__builtin_altivec_vsrah"); - pragma Export (LL_Altivec, vsraw, "__builtin_altivec_vsraw"); - pragma Export (LL_Altivec, vsrb, "__builtin_altivec_vsrb"); - pragma Export (LL_Altivec, vsrh, "__builtin_altivec_vsrh"); - pragma Export (LL_Altivec, vsro, "__builtin_altivec_vsro"); - pragma Export (LL_Altivec, vsrw, "__builtin_altivec_vsrw"); - pragma Export (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw"); - pragma Export (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp"); - pragma Export (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs"); - pragma Export (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs"); - pragma Export (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws"); - pragma Export (LL_Altivec, vsububm, "__builtin_altivec_vsububm"); - pragma Export (LL_Altivec, vsububs, "__builtin_altivec_vsububs"); - pragma Export (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm"); - pragma Export (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs"); - pragma Export (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm"); - pragma Export (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws"); - pragma Export (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws"); - pragma Export (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs"); - pragma Export (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs"); - pragma Export (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs"); - pragma Export (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws"); - pragma Export (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx"); - pragma Export (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb"); - pragma Export (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh"); - pragma Export (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx"); - pragma Export (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb"); - pragma Export (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh"); - pragma Export (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p"); - pragma Export (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p"); - pragma Export (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p"); - pragma Export (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p"); - pragma Export (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p"); - pragma Export (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p"); - pragma Export (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p"); - pragma Export (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p"); - pragma Export (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p"); - pragma Export (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p"); - pragma Export (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p"); - pragma Export (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p"); - pragma Export (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p"); - -end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/g-altcon.adb b/gcc/ada/g-altcon.adb deleted file mode 100644 index edd6c98..0000000 --- a/gcc/ada/g-altcon.adb +++ /dev/null @@ -1,514 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . C O N V E R S I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -with System; use System; - -package body GNAT.Altivec.Conversions is - - -- All the vector/view conversions operate similarly: bare unchecked - -- conversion on big endian targets, and elements permutation on little - -- endian targets. We call "Mirroring" the elements permutation process. - - -- We would like to provide a generic version of the conversion routines - -- and just have a set of "renaming as body" declarations to satisfy the - -- public interface. This unfortunately prevents inlining, which we must - -- preserve at least for the hard binding. - - -- We instead provide a generic version of facilities needed by all the - -- conversion routines and use them repeatedly. - - generic - type Vitem_Type is private; - - type Varray_Index_Type is range <>; - type Varray_Type is array (Varray_Index_Type) of Vitem_Type; - - type Vector_Type is private; - type View_Type is private; - - package Generic_Conversions is - - subtype Varray is Varray_Type; - -- This provides an easy common way to refer to the type parameter - -- in contexts where a specific instance of this package is "use"d. - - procedure Mirror (A : Varray_Type; Into : out Varray_Type); - pragma Inline (Mirror); - -- Mirror the elements of A into INTO, not touching the per-element - -- internal ordering. - - -- A procedure with an out parameter is a bit heavier to use than a - -- function but reduces the amount of temporary creations around the - -- call. Instances are typically not front-end inlined. They can still - -- be back-end inlined on request with the proper command-line option. - - -- Below are Unchecked Conversion routines for various purposes, - -- relying on internal knowledge about the bits layout in the different - -- types (all 128 value bits blocks). - - -- View<->Vector straight bitwise conversions on BE targets - - function UNC_To_Vector is - new Ada.Unchecked_Conversion (View_Type, Vector_Type); - - function UNC_To_View is - new Ada.Unchecked_Conversion (Vector_Type, View_Type); - - -- Varray->Vector/View for returning mirrored results on LE targets - - function UNC_To_Vector is - new Ada.Unchecked_Conversion (Varray_Type, Vector_Type); - - function UNC_To_View is - new Ada.Unchecked_Conversion (Varray_Type, View_Type); - - -- Vector/View->Varray for to-be-permuted source on LE targets - - function UNC_To_Varray is - new Ada.Unchecked_Conversion (Vector_Type, Varray_Type); - - function UNC_To_Varray is - new Ada.Unchecked_Conversion (View_Type, Varray_Type); - - end Generic_Conversions; - - package body Generic_Conversions is - - procedure Mirror (A : Varray_Type; Into : out Varray_Type) is - begin - for J in A'Range loop - Into (J) := A (A'Last - J + A'First); - end loop; - end Mirror; - - end Generic_Conversions; - - -- Now we declare the instances and implement the interface function - -- bodies simply calling the instantiated routines. - - --------------------- - -- Char components -- - --------------------- - - package SC_Conversions is new Generic_Conversions - (signed_char, Vchar_Range, Varray_signed_char, VSC, VSC_View); - - function To_Vector (S : VSC_View) return VSC is - use SC_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VSC) return VSC_View is - use SC_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - -- - - package UC_Conversions is new Generic_Conversions - (unsigned_char, Vchar_Range, Varray_unsigned_char, VUC, VUC_View); - - function To_Vector (S : VUC_View) return VUC is - use UC_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VUC) return VUC_View is - use UC_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - -- - - package BC_Conversions is new Generic_Conversions - (bool_char, Vchar_Range, Varray_bool_char, VBC, VBC_View); - - function To_Vector (S : VBC_View) return VBC is - use BC_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VBC) return VBC_View is - use BC_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - ---------------------- - -- Short components -- - ---------------------- - - package SS_Conversions is new Generic_Conversions - (signed_short, Vshort_Range, Varray_signed_short, VSS, VSS_View); - - function To_Vector (S : VSS_View) return VSS is - use SS_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VSS) return VSS_View is - use SS_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - -- - - package US_Conversions is new Generic_Conversions - (unsigned_short, Vshort_Range, Varray_unsigned_short, VUS, VUS_View); - - function To_Vector (S : VUS_View) return VUS is - use US_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VUS) return VUS_View is - use US_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - -- - - package BS_Conversions is new Generic_Conversions - (bool_short, Vshort_Range, Varray_bool_short, VBS, VBS_View); - - function To_Vector (S : VBS_View) return VBS is - use BS_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VBS) return VBS_View is - use BS_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - -------------------- - -- Int components -- - -------------------- - - package SI_Conversions is new Generic_Conversions - (signed_int, Vint_Range, Varray_signed_int, VSI, VSI_View); - - function To_Vector (S : VSI_View) return VSI is - use SI_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VSI) return VSI_View is - use SI_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - -- - - package UI_Conversions is new Generic_Conversions - (unsigned_int, Vint_Range, Varray_unsigned_int, VUI, VUI_View); - - function To_Vector (S : VUI_View) return VUI is - use UI_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VUI) return VUI_View is - use UI_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - -- - - package BI_Conversions is new Generic_Conversions - (bool_int, Vint_Range, Varray_bool_int, VBI, VBI_View); - - function To_Vector (S : VBI_View) return VBI is - use BI_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VBI) return VBI_View is - use BI_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - ---------------------- - -- Float components -- - ---------------------- - - package F_Conversions is new Generic_Conversions - (C_float, Vfloat_Range, Varray_float, VF, VF_View); - - function To_Vector (S : VF_View) return VF is - use F_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VF) return VF_View is - use F_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - - ---------------------- - -- Pixel components -- - ---------------------- - - package P_Conversions is new Generic_Conversions - (pixel, Vpixel_Range, Varray_pixel, VP, VP_View); - - function To_Vector (S : VP_View) return VP is - use P_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_Vector (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_Vector (M); - end; - end if; - end To_Vector; - - function To_View (S : VP) return VP_View is - use P_Conversions; - begin - if Default_Bit_Order = High_Order_First then - return UNC_To_View (S); - else - declare - M : Varray; - begin - Mirror (UNC_To_Varray (S), Into => M); - return UNC_To_View (M); - end; - end if; - end To_View; - -end GNAT.Altivec.Conversions; diff --git a/gcc/ada/g-altcon.ads b/gcc/ada/g-altcon.ads deleted file mode 100644 index 93d291e..0000000 --- a/gcc/ada/g-altcon.ads +++ /dev/null @@ -1,101 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . C O N V E R S I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit provides the Vector/Views conversions - -with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; -with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; - -package GNAT.Altivec.Conversions is - - --------------------- - -- char components -- - --------------------- - - function To_Vector (S : VUC_View) return VUC; - function To_Vector (S : VSC_View) return VSC; - function To_Vector (S : VBC_View) return VBC; - - function To_View (S : VUC) return VUC_View; - function To_View (S : VSC) return VSC_View; - function To_View (S : VBC) return VBC_View; - - ---------------------- - -- short components -- - ---------------------- - - function To_Vector (S : VUS_View) return VUS; - function To_Vector (S : VSS_View) return VSS; - function To_Vector (S : VBS_View) return VBS; - - function To_View (S : VUS) return VUS_View; - function To_View (S : VSS) return VSS_View; - function To_View (S : VBS) return VBS_View; - - -------------------- - -- int components -- - -------------------- - - function To_Vector (S : VUI_View) return VUI; - function To_Vector (S : VSI_View) return VSI; - function To_Vector (S : VBI_View) return VBI; - - function To_View (S : VUI) return VUI_View; - function To_View (S : VSI) return VSI_View; - function To_View (S : VBI) return VBI_View; - - ---------------------- - -- float components -- - ---------------------- - - function To_Vector (S : VF_View) return VF; - - function To_View (S : VF) return VF_View; - - ---------------------- - -- pixel components -- - ---------------------- - - function To_Vector (S : VP_View) return VP; - - function To_View (S : VP) return VP_View; - -private - - -- We want the above subprograms to always be inlined in the case of the - -- hard PowerPC AltiVec support in order to avoid the unnecessary function - -- call. On the other hand there is no problem with inlining these - -- subprograms on little-endian targets. - - pragma Inline_Always (To_Vector); - pragma Inline_Always (To_View); - -end GNAT.Altivec.Conversions; diff --git a/gcc/ada/g-altive.ads b/gcc/ada/g-altive.ads deleted file mode 100644 index 1e247b3..0000000 --- a/gcc/ada/g-altive.ads +++ /dev/null @@ -1,766 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -------------------------- --- General description -- -------------------------- - --- This is the root of a package hierarchy offering an Ada binding to the --- PowerPC AltiVec extensions, a set of 128bit vector types together with a --- set of subprograms operating on them. Relevant documents are: - --- o AltiVec Technology, Programming Interface Manual (1999-06) --- to which we will refer as [PIM], describes the data types, the --- functional interface and the ABI conventions. - --- o AltiVec Technology, Programming Environments Manual (2002-02) --- to which we will refer as [PEM], describes the hardware architecture --- and instruction set. - --- These documents, as well as a number of others of general interest on the --- AltiVec technology, are available from the Motorola/AltiVec Web site at: - --- http://www.freescale.com/altivec - --- The binding interface is structured to allow alternate implementations: --- for real AltiVec capable targets, and for other targets. In the latter --- case, everything is emulated in software. The two versions are referred --- to as: - --- o The Hard binding for AltiVec capable targets (with the appropriate --- hardware support and corresponding instruction set) - --- o The Soft binding for other targets (with the low level primitives --- emulated in software). - --- In addition, interfaces that are not strictly part of the base AltiVec API --- are provided, such as vector conversions to and from array representations, --- which are of interest for client applications (e.g. for vector --- initialization purposes). - --- Only the soft binding is available today - ------------------------------------------ --- General package architecture survey -- ------------------------------------------ - --- The various vector representations are all "containers" of elementary --- values, the possible types of which are declared in this root package to --- be generally accessible. - --- From the user standpoint, the binding materializes as a consistent --- hierarchy of units: - --- GNAT.Altivec --- (component types) --- | --- o----------------o----------------o-------------o --- | | | | --- Vector_Types Vector_Operations Vector_Views Conversions - --- Users can manipulate vectors through two families of types: Vector --- types and View types. - --- Vector types are available through the Vector_Types and Vector_Operations --- packages, which implement the core binding to the AltiVec API, as --- described in [PIM-2.1 data types] and [PIM-4 AltiVec operations and --- predicates]. - --- The layout of Vector objects is dependant on the target machine --- endianness, and View types were devised to offer a higher level user --- interface. With Views, a vector of 4 uints (1, 2, 3, 4) is always declared --- with a VUI_View := (Values => (1, 2, 3, 4)), element 1 first, natural --- notation to denote the element values, and indexed notation is available --- to access individual elements. - --- View types do not represent Altivec vectors per se, in the sense that the --- Altivec_Operations are not available for them. They are intended to allow --- Vector initializations as well as access to the Vector component values. - --- The GNAT.Altivec.Conversions package is provided to convert a View to the --- corresponding Vector and vice-versa. - ---------------------------- --- Underlying principles -- ---------------------------- - --- Internally, the binding relies on an abstraction of the Altivec API, a --- rich set of functions around a core of low level primitives mapping to --- AltiVec instructions. See for instance "vec_add" in [PIM-4.4 Generic and --- Specific AltiVec operations], with no less than six result/arguments --- combinations of byte vector types that map to "vaddubm". - --- The "soft" version is a software emulation of the low level primitives. - --- The "hard" version would map to real AltiVec instructions via GCC builtins --- and inlining. - --- See the "Design Notes" section below for additional details on the --- internals. - -------------------- --- Example usage -- -------------------- - --- Here is a sample program declaring and initializing two vectors, 'add'ing --- them and displaying the result components: - --- with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; --- with GNAT.Altivec.Vector_Operations; use GNAT.Altivec.Vector_Operations; --- with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; --- with GNAT.Altivec.Conversions; use GNAT.Altivec.Conversions; - --- use GNAT.Altivec; - --- with Ada.Text_IO; use Ada.Text_IO; - --- procedure Sample is --- Va : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4))); --- Vb : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4))); - --- Vs : Vector_Unsigned_Int; --- Vs_View : VUI_View; --- begin --- Vs := Vec_Add (Va, Vb); --- Vs_View := To_View (Vs); - --- for I in Vs_View.Values'Range loop --- Put_Line (Unsigned_Int'Image (Vs_View.Values (I))); --- end loop; --- end; - --- $ gnatmake sample.adb --- [...] --- $ ./sample --- 2 --- 4 --- 6 --- 8 - ------------------------------------------------------------------------------- - -with System; - -package GNAT.Altivec is - - -- Definitions of constants and vector/array component types common to all - -- the versions of the binding. - - -- All the vector types are 128bits - - VECTOR_BIT : constant := 128; - - ------------------------------------------- - -- [PIM-2.3.1 Alignment of vector types] -- - ------------------------------------------- - - -- "A defined data item of any vector data type in memory is always - -- aligned on a 16-byte boundary. A pointer to any vector data type always - -- points to a 16-byte boundary. The compiler is responsible for aligning - -- vector data types on 16-byte boundaries." - - VECTOR_ALIGNMENT : constant := Natural'Min (16, Standard'Maximum_Alignment); - -- This value is used to set the alignment of vector datatypes in both the - -- hard and the soft binding implementations. - -- - -- We want this value to never be greater than 16, because none of the - -- binding implementations requires larger alignments and such a value - -- would cause useless space to be allocated/wasted for vector objects. - -- Furthermore, the alignment of 16 matches the hard binding leading to - -- a more faithful emulation. - -- - -- It needs to be exactly 16 for the hard binding, and the initializing - -- expression is just right for this purpose since Maximum_Alignment is - -- expected to be 16 for the real Altivec ABI. - -- - -- The soft binding doesn't rely on strict 16byte alignment, and we want - -- the value to be no greater than Standard'Maximum_Alignment in this case - -- to ensure it is supported on every possible target. - - ------------------------------------------------------- - -- [PIM-2.1] Data Types - Interpretation of contents -- - ------------------------------------------------------- - - --------------------- - -- char components -- - --------------------- - - CHAR_BIT : constant := 8; - SCHAR_MIN : constant := -2 ** (CHAR_BIT - 1); - SCHAR_MAX : constant := 2 ** (CHAR_BIT - 1) - 1; - UCHAR_MAX : constant := 2 ** CHAR_BIT - 1; - - type unsigned_char is mod UCHAR_MAX + 1; - for unsigned_char'Size use CHAR_BIT; - - type signed_char is range SCHAR_MIN .. SCHAR_MAX; - for signed_char'Size use CHAR_BIT; - - subtype bool_char is unsigned_char; - -- ??? There is a difference here between what the Altivec Technology - -- Programming Interface Manual says and what GCC says. In the manual, - -- vector_bool_char is a vector_unsigned_char, while in altivec.h it - -- is a vector_signed_char. - - bool_char_True : constant bool_char := bool_char'Last; - bool_char_False : constant bool_char := 0; - - ---------------------- - -- short components -- - ---------------------- - - SHORT_BIT : constant := 16; - SSHORT_MIN : constant := -2 ** (SHORT_BIT - 1); - SSHORT_MAX : constant := 2 ** (SHORT_BIT - 1) - 1; - USHORT_MAX : constant := 2 ** SHORT_BIT - 1; - - type unsigned_short is mod USHORT_MAX + 1; - for unsigned_short'Size use SHORT_BIT; - - subtype unsigned_short_int is unsigned_short; - - type signed_short is range SSHORT_MIN .. SSHORT_MAX; - for signed_short'Size use SHORT_BIT; - - subtype signed_short_int is signed_short; - - subtype bool_short is unsigned_short; - -- ??? See bool_char - - bool_short_True : constant bool_short := bool_short'Last; - bool_short_False : constant bool_short := 0; - - subtype bool_short_int is bool_short; - - -------------------- - -- int components -- - -------------------- - - INT_BIT : constant := 32; - SINT_MIN : constant := -2 ** (INT_BIT - 1); - SINT_MAX : constant := 2 ** (INT_BIT - 1) - 1; - UINT_MAX : constant := 2 ** INT_BIT - 1; - - type unsigned_int is mod UINT_MAX + 1; - for unsigned_int'Size use INT_BIT; - - type signed_int is range SINT_MIN .. SINT_MAX; - for signed_int'Size use INT_BIT; - - subtype bool_int is unsigned_int; - -- ??? See bool_char - - bool_int_True : constant bool_int := bool_int'Last; - bool_int_False : constant bool_int := 0; - - ---------------------- - -- float components -- - ---------------------- - - FLOAT_BIT : constant := 32; - FLOAT_DIGIT : constant := 6; - FLOAT_MIN : constant := -16#0.FFFF_FF#E+32; - FLOAT_MAX : constant := 16#0.FFFF_FF#E+32; - - type C_float is digits FLOAT_DIGIT range FLOAT_MIN .. FLOAT_MAX; - for C_float'Size use FLOAT_BIT; - -- Altivec operations always use the standard native floating-point - -- support of the target. Note that this means that there may be - -- minor differences in results between targets when the floating- - -- point implementations are slightly different, as would happen - -- with normal non-Altivec floating-point operations. In particular - -- the Altivec simulations may yield slightly different results - -- from those obtained on a true hardware Altivec target if the - -- floating-point implementation is not 100% compatible. - - ---------------------- - -- pixel components -- - ---------------------- - - subtype pixel is unsigned_short; - - ----------------------------------------------------------- - -- Subtypes for variants found in the GCC implementation -- - ----------------------------------------------------------- - - subtype c_int is signed_int; - subtype c_short is c_int; - - LONG_BIT : constant := 32; - -- Some of the GCC builtins are built with "long" arguments and - -- expect SImode to come in. - - SLONG_MIN : constant := -2 ** (LONG_BIT - 1); - SLONG_MAX : constant := 2 ** (LONG_BIT - 1) - 1; - ULONG_MAX : constant := 2 ** LONG_BIT - 1; - - type signed_long is range SLONG_MIN .. SLONG_MAX; - type unsigned_long is mod ULONG_MAX + 1; - - subtype c_long is signed_long; - - subtype c_ptr is System.Address; - - --------------------------------------------------------- - -- Access types, for the sake of some argument passing -- - --------------------------------------------------------- - - type signed_char_ptr is access all signed_char; - type unsigned_char_ptr is access all unsigned_char; - - type short_ptr is access all c_short; - type signed_short_ptr is access all signed_short; - type unsigned_short_ptr is access all unsigned_short; - - type int_ptr is access all c_int; - type signed_int_ptr is access all signed_int; - type unsigned_int_ptr is access all unsigned_int; - - type long_ptr is access all c_long; - type signed_long_ptr is access all signed_long; - type unsigned_long_ptr is access all unsigned_long; - - type float_ptr is access all Float; - - -- - - type const_signed_char_ptr is access constant signed_char; - type const_unsigned_char_ptr is access constant unsigned_char; - - type const_short_ptr is access constant c_short; - type const_signed_short_ptr is access constant signed_short; - type const_unsigned_short_ptr is access constant unsigned_short; - - type const_int_ptr is access constant c_int; - type const_signed_int_ptr is access constant signed_int; - type const_unsigned_int_ptr is access constant unsigned_int; - - type const_long_ptr is access constant c_long; - type const_signed_long_ptr is access constant signed_long; - type const_unsigned_long_ptr is access constant unsigned_long; - - type const_float_ptr is access constant Float; - - -- Access to const volatile arguments need specialized types - - type volatile_float is new Float; - pragma Volatile (volatile_float); - - type volatile_signed_char is new signed_char; - pragma Volatile (volatile_signed_char); - - type volatile_unsigned_char is new unsigned_char; - pragma Volatile (volatile_unsigned_char); - - type volatile_signed_short is new signed_short; - pragma Volatile (volatile_signed_short); - - type volatile_unsigned_short is new unsigned_short; - pragma Volatile (volatile_unsigned_short); - - type volatile_signed_int is new signed_int; - pragma Volatile (volatile_signed_int); - - type volatile_unsigned_int is new unsigned_int; - pragma Volatile (volatile_unsigned_int); - - type volatile_signed_long is new signed_long; - pragma Volatile (volatile_signed_long); - - type volatile_unsigned_long is new unsigned_long; - pragma Volatile (volatile_unsigned_long); - - type constv_char_ptr is access constant volatile_signed_char; - type constv_signed_char_ptr is access constant volatile_signed_char; - type constv_unsigned_char_ptr is access constant volatile_unsigned_char; - - type constv_short_ptr is access constant volatile_signed_short; - type constv_signed_short_ptr is access constant volatile_signed_short; - type constv_unsigned_short_ptr is access constant volatile_unsigned_short; - - type constv_int_ptr is access constant volatile_signed_int; - type constv_signed_int_ptr is access constant volatile_signed_int; - type constv_unsigned_int_ptr is access constant volatile_unsigned_int; - - type constv_long_ptr is access constant volatile_signed_long; - type constv_signed_long_ptr is access constant volatile_signed_long; - type constv_unsigned_long_ptr is access constant volatile_unsigned_long; - - type constv_float_ptr is access constant volatile_float; - -private - - ----------------------- - -- Various constants -- - ----------------------- - - CR6_EQ : constant := 0; - CR6_EQ_REV : constant := 1; - CR6_LT : constant := 2; - CR6_LT_REV : constant := 3; - -end GNAT.Altivec; - --------------------- --- Design Notes -- --------------------- - ------------------------- --- General principles -- ------------------------- - --- The internal organization has been devised from a number of driving ideas: - --- o From the clients standpoint, the two versions of the binding should be --- as easily exchangable as possible, - --- o From the maintenance standpoint, we want to avoid as much code --- duplication as possible. - --- o From both standpoints above, we want to maintain a clear interface --- separation between the base bindings to the Motorola API and the --- additional facilities. - --- The identification of the low level interface is directly inspired by the --- the base API organization, basically consisting of a rich set of functions --- around a core of low level primitives mapping to AltiVec instructions. - --- See for instance "vec_add" in [PIM-4.4 Generic and Specific AltiVec --- operations]: no less than six result/arguments combinations of byte vector --- types map to "vaddubm". - --- The "hard" version of the low level primitives map to real AltiVec --- instructions via the corresponding GCC builtins. The "soft" version is --- a software emulation of those. - ---------------------------------------- --- The Low_Level_Vectors abstraction -- ---------------------------------------- - --- The AltiVec C interface spirit is to map a large set of C functions down --- to a much smaller set of AltiVec instructions, most of them operating on a --- set of vector data types in a transparent manner. See for instance the --- case of vec_add, which maps six combinations of result/argument types to --- vaddubm for signed/unsigned/bool variants of 'char' components. - --- The GCC implementation of this idiom for C/C++ is to setup builtins --- corresponding to the instructions and to expose the C user function as --- wrappers around those builtins with no-op type conversions as required. --- Typically, for the vec_add case mentioned above, we have (altivec.h): --- --- inline __vector signed char --- vec_add (__vector signed char a1, __vector signed char a2) --- { --- return (__vector signed char) --- __builtin_altivec_vaddubm ((__vector signed char) a1, --- (__vector signed char) a2); --- } - --- inline __vector unsigned char --- vec_add (__vector __bool char a1, __vector unsigned char a2) --- { --- return (__vector unsigned char) --- __builtin_altivec_vaddubm ((__vector signed char) a1, --- (__vector signed char) a2); --- } - --- The central idea for the Ada bindings is to leverage on the existing GCC --- architecture, with the introduction of a Low_Level_Vectors abstraction. --- This abstaction acts as a representative of the vector-types and builtins --- compiler interface for either the Hard or the Soft case. - --- For the Hard binding, Low_Level_Vectors exposes data types with a GCC --- internal translation identical to the "vector ..." C types, and a set of --- subprograms mapping straight to the internal GCC builtins. - --- For the Soft binding, Low_Level_Vectors exposes the same set of types --- and subprograms, with bodies simulating the instructions behavior. - --- Vector_Types/Operations "simply" bind the user types and operations to --- some Low_Level_Vectors implementation, selected in accordance with the --- target - --- To achieve a complete Hard/Soft independence in the Vector_Types and --- Vector_Operations implementations, both versions of the low level support --- are expected to expose a number of facilities: - --- o Private data type declarations for base vector representations embedded --- in the user visible vector types, that is: - --- LL_VBC, LL_VUC and LL_VSC --- for vector_bool_char, vector_unsigned_char and vector_signed_char - --- LL_VBS, LL_VUS and LL_VSS --- for vector_bool_short, vector_unsigned_short and vector_signed_short - --- LL_VBI, LL_VUI and LL_VSI --- for vector_bool_int, vector_unsigned_int and vector_signed_int - --- as well as: - --- LL_VP for vector_pixel and LL_VF for vector_float - --- o Primitive operations corresponding to the AltiVec hardware instruction --- names, like "vaddubm". The whole set is not described here. The actual --- sets are inspired from the GCC builtins which are invoked from GCC's --- "altivec.h". - --- o An LL_Altivec convention identifier, specifying the calling convention --- to be used to access the aforementioned primitive operations. - --- Besides: - --- o Unchecked_Conversion are expected to be allowed between any pair of --- exposed data types, and are expected to have no effect on the value --- bit patterns. - -------------------------- --- Vector views layout -- -------------------------- - --- Vector Views combine intuitive user level ordering for both elements --- within a vector and bytes within each element. They basically map to an --- array representation where array(i) always represents element (i), in the --- natural target representation. This way, a user vector (1, 2, 3, 4) is --- represented as: - --- Increasing Addresses --- -------------------------------------------------------------------------> - --- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | --- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | - --- on a big endian target, and as: - --- | 0x1 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x4 0x0 0x0 0x0 | --- | V (0), LE | V (1), LE | V (2), LE | V (3), LE | - --- on a little-endian target - -------------------------- --- Vector types layout -- -------------------------- - --- In the case of the hard binding, the layout of the vector type in --- memory is documented by the Altivec documentation. In the case of the --- soft binding, the simplest solution is to represent a vector as an --- array of components. This representation can depend on the endianness. --- We can consider three possibilities: - --- * First component at the lowest address, components in big endian format. --- It is the natural way to represent an array in big endian, and it would --- also be the natural way to represent a quad-word integer in big endian. - --- Example: - --- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is --- represented as: - --- Addresses growing --- -------------------------------------------------------------------------> --- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | --- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | - --- * First component at the lowest address, components in little endian --- format. It is the natural way to represent an array in little endian. - --- Example: - --- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is --- represented as: - --- Addresses growing --- -------------------------------------------------------------------------> --- | 0x1 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x4 0x0 0x0 0x0 | --- | V (0), LE | V (1), LE | V (2), LE | V (3), LE | - --- * Last component at the lowest address, components in little endian format. --- It is the natural way to represent a quad-word integer in little endian. - --- Example: - --- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is --- represented as: - --- Addresses growing --- -------------------------------------------------------------------------> --- | 0x4 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x1 0x0 0x0 0x0 | --- | V (3), LE | V (2), LE | V (1), LE | V (0), LE | - --- There is actually a fourth case (components in big endian, first --- component at the lowest address), but it does not have any interesting --- properties: it is neither the natural way to represent a quad-word on any --- machine, nor the natural way to represent an array on any machine. - --- Example: - --- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is --- represented as: - --- Addresses growing --- -------------------------------------------------------------------------> --- | 0x0 0x0 0x0 0x4 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x1 | --- | V (3), BE | V (2), BE | V (1), BE | V (0), BE | - --- Most of the Altivec operations are specific to a component size, and --- can be implemented with any of these three formats. But some operations --- are defined by the same Altivec primitive operation for different type --- sizes: - --- * operations doing arithmetics on a complete vector, seen as a quad-word; --- * operations dealing with memory. - --- Operations on a complete vector: --- -------------------------------- - --- Examples: - --- vec_sll/vsl : shift left on the entire vector. --- vec_slo/vslo: shift left on the entire vector, by octet. - --- Those operations works on vectors seens as a quad-word. --- Let us suppose that we have a conversion operation named To_Quad_Word --- for converting vector types to a quad-word. - --- Let A be a Altivec vector of 16 components: --- A = (A(0), A(1), A(2), A(3), ... , A(14), A(15)) --- Let B be a Altivec vector of 8 components verifying: --- B = (A(0) |8| A(1), A(2) |8| A(3), ... , A(14) |8| A(15)) --- Let C be a Altivec vector of 4 components verifying: --- C = (A(0) |8| A(1) |8| A(2) |8| A(3), ... , --- A(12) |8| A(13) |8| A(14) |8| A(15)) - --- (definition: |8| is the concatenation operation between two bytes; --- i.e. 0x1 |8| 0x2 = 0x0102) - --- According to [PIM - 4.2 byte ordering], we have the following property: --- To_Quad_Word (A) = To_Quad_Word (B) = To_Quad_Word (C) - --- Let To_Type_Of_A be a conversion operation from the type of B to the --- type of A. The quad-word operations are only implemented by one --- Altivec primitive operation. That means that, if QW_Operation is a --- quad-word operation, we should have: --- QW_Operation (To_Type_of_A (B)) = QW_Operation (A) - --- That is true iff: --- To_Quad_Word (To_Type_of_A (B)) = To_Quad_Word (A) - --- As To_Quad_Word is a bijection. we have: --- To_Type_of_A (B) = A - --- resp. any combination of A, B, C: --- To_Type_of_A (C) = A --- To_Type_of_B (A) = B --- To_Type_of_C (B) = C --- ... - --- Making sure that the properties described above are verified by the --- conversion operations between vector types has different implications --- depending on the layout of the vector types: --- * with format 1 and 3: only a unchecked conversion is needed; --- * with format 2 and 4: some reorganisation is needed for conversions --- between vector types with different component sizes; that has a cost on the --- efficiency, plus the complexity of having different memory pattern for --- the same quad-word value, depending on the type. - --- Operation dealing with memory: --- ------------------------------ - --- These operations are either load operation (vec_ld and the --- corresponding primitive operation: vlx) or store operation (vec_st --- and the corresponding primitive operation: vstx). - --- According to [PIM 4.4 - vec_ld], those operations take in input --- either an access to a vector (e.g. a const_vector_unsigned_int_ptr) --- or an access to a flow of components (e.g. a const_unsigned_int_ptr), --- relying on the same Altivec primitive operations. That means that both --- should have the same representation in memory. - --- For the stream, it is easier to adopt the format of the target. That --- means that, in memory, the components of the vector should also have the --- format of the target. meaning that we will prefer: --- * On a big endian target: format 1 or 4 --- * On a little endian target: format 2 or 3 - --- Conclusion: --- ----------- - --- To take into consideration the constraint brought about by the routines --- operating on quad-words and the routines operating on memory, the best --- choice seems to be: - --- * On a big endian target: format 1; --- * On a little endian target: format 3. - --- Those layout choices are enforced by GNAT.Altivec.Low_Level_Conversions, --- which is the endianness-dependant unit providing conversions between --- vector views and vector types. - ----------------------- --- Layouts summary -- ----------------------- - --- For a user abstract vector of 4 uints (1, 2, 3, 4), increasing --- addresses from left to right: - --- ========================================================================= --- BIG ENDIAN TARGET MEMORY LAYOUT for (1, 2, 3, 4) --- ========================================================================= - --- View --- ------------------------------------------------------------------------- --- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | --- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | --- ------------------------------------------------------------------------- - --- Vector --- ------------------------------------------------------------------------- --- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | --- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | --- ------------------------------------------------------------------------- - --- ========================================================================= --- LITTLE ENDIAN TARGET MEMORY LAYOUT for (1, 2, 3, 4) --- ========================================================================= - --- View --- ------------------------------------------------------------------------- --- | 0x1 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x4 0x0 0x0 0x0 | --- | V (0), LE | V (1), LE | V (2), LE | V (3), LE | - --- Vector --- ------------------------------------------------------------------------- --- | 0x4 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x1 0x0 0x0 0x0 | --- | V (3), LE | V (2), LE | V (1), LE | V (0), LE | --- ------------------------------------------------------------------------- - --- These layouts are common to both the soft and hard implementations on --- Altivec capable targets. diff --git a/gcc/ada/g-alveop.adb b/gcc/ada/g-alveop.adb deleted file mode 100644 index 0a7b1d3..0000000 --- a/gcc/ada/g-alveop.adb +++ /dev/null @@ -1,11008 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . V E C T O R _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.Altivec.Low_Level_Interface; use GNAT.Altivec.Low_Level_Interface; - -package body GNAT.Altivec.Vector_Operations is - - -------------------------------------------------------- - -- Bodies for generic and specific Altivec operations -- - -------------------------------------------------------- - - ------------- - -- vec_abs -- - ------------- - - function vec_abs - (A : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (abs_v16qi (A)); - end vec_abs; - - function vec_abs - (A : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (abs_v8hi (A)); - end vec_abs; - - function vec_abs - (A : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (abs_v4si (A)); - end vec_abs; - - function vec_abs - (A : vector_float) return vector_float - is - begin - return To_LL_VF (abs_v4sf (A)); - end vec_abs; - - -------------- - -- vec_abss -- - -------------- - - function vec_abss - (A : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (abss_v16qi (A)); - end vec_abss; - - function vec_abss - (A : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (abss_v8hi (A)); - end vec_abss; - - function vec_abss - (A : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (abss_v4si (A)); - end vec_abss; - - ------------- - -- vec_add -- - ------------- - - function vec_add - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_add; - - function vec_add - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_add; - - function vec_add - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_add; - - function vec_add - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_add; - - function vec_add - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_add; - - function vec_add - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_add; - - function vec_add - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_add; - - function vec_add - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_add; - - function vec_add - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_add; - - function vec_add - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_add; - - function vec_add - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_add; - - function vec_add - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_add; - - function vec_add - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_add; - - function vec_add - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_add; - - function vec_add - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_add; - - function vec_add - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_add; - - function vec_add - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_add; - - function vec_add - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_add; - - function vec_add - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vaddfp (To_LL_VF (A), To_LL_VF (B))); - end vec_add; - - ---------------- - -- vec_vaddfp -- - ---------------- - - function vec_vaddfp - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vaddfp (To_LL_VF (A), To_LL_VF (B))); - end vec_vaddfp; - - ----------------- - -- vec_vadduwm -- - ----------------- - - function vec_vadduwm - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduwm; - - function vec_vadduwm - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduwm; - - function vec_vadduwm - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduwm; - - function vec_vadduwm - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduwm; - - function vec_vadduwm - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduwm; - - function vec_vadduwm - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduwm; - - ----------------- - -- vec_vadduhm -- - ----------------- - - function vec_vadduhm - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhm; - - function vec_vadduhm - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhm; - - function vec_vadduhm - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhm; - - function vec_vadduhm - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhm; - - function vec_vadduhm - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhm; - - function vec_vadduhm - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhm; - - ----------------- - -- vec_vaddubm -- - ----------------- - - function vec_vaddubm - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubm; - - function vec_vaddubm - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubm; - - function vec_vaddubm - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubm; - - function vec_vaddubm - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubm; - - function vec_vaddubm - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubm; - - function vec_vaddubm - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubm; - - -------------- - -- vec_addc -- - -------------- - - function vec_addc - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vaddcuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_addc; - - -------------- - -- vec_adds -- - -------------- - - function vec_adds - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_adds; - - function vec_adds - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_adds; - - function vec_adds - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_adds; - - function vec_adds - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_adds; - - function vec_adds - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_adds; - - function vec_adds - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_adds; - - function vec_adds - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_adds; - - function vec_adds - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_adds; - - function vec_adds - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_adds; - - function vec_adds - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_adds; - - function vec_adds - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_adds; - - function vec_adds - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_adds; - - function vec_adds - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_adds; - - function vec_adds - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_adds; - - function vec_adds - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_adds; - - function vec_adds - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_adds; - - function vec_adds - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_adds; - - function vec_adds - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_adds; - - ----------------- - -- vec_vaddsws -- - ----------------- - - function vec_vaddsws - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vaddsws; - - function vec_vaddsws - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vaddsws; - - function vec_vaddsws - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vaddsws; - - ----------------- - -- vec_vadduws -- - ----------------- - - function vec_vadduws - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduws; - - function vec_vadduws - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduws; - - function vec_vadduws - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vadduws; - - ----------------- - -- vec_vaddshs -- - ----------------- - - function vec_vaddshs - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vaddshs; - - function vec_vaddshs - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vaddshs; - - function vec_vaddshs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vaddshs; - - ----------------- - -- vec_vadduhs -- - ----------------- - - function vec_vadduhs - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhs; - - function vec_vadduhs - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhs; - - function vec_vadduhs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vadduhs; - - ----------------- - -- vec_vaddsbs -- - ----------------- - - function vec_vaddsbs - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddsbs; - - function vec_vaddsbs - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddsbs; - - function vec_vaddsbs - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddsbs; - - ----------------- - -- vec_vaddubs -- - ----------------- - - function vec_vaddubs - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubs; - - function vec_vaddubs - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubs; - - function vec_vaddubs - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vaddubs; - - ------------- - -- vec_and -- - ------------- - - function vec_and - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_float; - B : vector_bool_int) return vector_float - is - begin - return To_LL_VF (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_int; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - function vec_and - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vand (To_LL_VSI (A), To_LL_VSI (B))); - end vec_and; - - -------------- - -- vec_andc -- - -------------- - - function vec_andc - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_float; - B : vector_bool_int) return vector_float - is - begin - return To_LL_VF (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_int; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - function vec_andc - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vandc (To_LL_VSI (A), To_LL_VSI (B))); - end vec_andc; - - ------------- - -- vec_avg -- - ------------- - - function vec_avg - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vavgub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_avg; - - function vec_avg - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vavgsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_avg; - - function vec_avg - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vavguh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_avg; - - function vec_avg - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vavgsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_avg; - - function vec_avg - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vavguw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_avg; - - function vec_avg - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vavgsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_avg; - - ---------------- - -- vec_vavgsw -- - ---------------- - - function vec_vavgsw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vavgsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vavgsw; - - ---------------- - -- vec_vavguw -- - ---------------- - - function vec_vavguw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vavguw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vavguw; - - ---------------- - -- vec_vavgsh -- - ---------------- - - function vec_vavgsh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vavgsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vavgsh; - - ---------------- - -- vec_vavguh -- - ---------------- - - function vec_vavguh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vavguh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vavguh; - - ---------------- - -- vec_vavgsb -- - ---------------- - - function vec_vavgsb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vavgsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vavgsb; - - ---------------- - -- vec_vavgub -- - ---------------- - - function vec_vavgub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vavgub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vavgub; - - -------------- - -- vec_ceil -- - -------------- - - function vec_ceil - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vrfip (To_LL_VF (A))); - end vec_ceil; - - -------------- - -- vec_cmpb -- - -------------- - - function vec_cmpb - (A : vector_float; - B : vector_float) return vector_signed_int - is - begin - return To_LL_VSI (vcmpbfp (To_LL_VF (A), To_LL_VF (B))); - end vec_cmpb; - - --------------- - -- vec_cmpeq -- - --------------- - - function vec_cmpeq - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_cmpeq; - - function vec_cmpeq - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_cmpeq; - - function vec_cmpeq - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_cmpeq; - - function vec_cmpeq - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_cmpeq; - - function vec_cmpeq - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_cmpeq; - - function vec_cmpeq - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_cmpeq; - - function vec_cmpeq - (A : vector_float; - B : vector_float) return vector_bool_int - is - begin - return To_LL_VBI (vcmpeqfp (To_LL_VF (A), To_LL_VF (B))); - end vec_cmpeq; - - ------------------ - -- vec_vcmpeqfp -- - ------------------ - - function vec_vcmpeqfp - (A : vector_float; - B : vector_float) return vector_bool_int - is - begin - return To_LL_VBI (vcmpeqfp (To_LL_VF (A), To_LL_VF (B))); - end vec_vcmpeqfp; - - ------------------ - -- vec_vcmpequw -- - ------------------ - - function vec_vcmpequw - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vcmpequw; - - function vec_vcmpequw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vcmpequw; - - ------------------ - -- vec_vcmpequh -- - ------------------ - - function vec_vcmpequh - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vcmpequh; - - function vec_vcmpequh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vcmpequh; - - ------------------ - -- vec_vcmpequb -- - ------------------ - - function vec_vcmpequb - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vcmpequb; - - function vec_vcmpequb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vcmpequb; - - --------------- - -- vec_cmpge -- - --------------- - - function vec_cmpge - (A : vector_float; - B : vector_float) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgefp (To_LL_VF (A), To_LL_VF (B))); - end vec_cmpge; - - --------------- - -- vec_cmpgt -- - --------------- - - function vec_cmpgt - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpgtub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_cmpgt; - - function vec_cmpgt - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpgtsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_cmpgt; - - function vec_cmpgt - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpgtuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_cmpgt; - - function vec_cmpgt - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpgtsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_cmpgt; - - function vec_cmpgt - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_cmpgt; - - function vec_cmpgt - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_cmpgt; - - function vec_cmpgt - (A : vector_float; - B : vector_float) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtfp (To_LL_VF (A), To_LL_VF (B))); - end vec_cmpgt; - - ------------------ - -- vec_vcmpgtfp -- - ------------------ - - function vec_vcmpgtfp - (A : vector_float; - B : vector_float) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtfp (To_LL_VF (A), To_LL_VF (B))); - end vec_vcmpgtfp; - - ------------------ - -- vec_vcmpgtsw -- - ------------------ - - function vec_vcmpgtsw - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vcmpgtsw; - - ------------------ - -- vec_vcmpgtuw -- - ------------------ - - function vec_vcmpgtuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vcmpgtuw; - - ------------------ - -- vec_vcmpgtsh -- - ------------------ - - function vec_vcmpgtsh - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpgtsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vcmpgtsh; - - ------------------ - -- vec_vcmpgtuh -- - ------------------ - - function vec_vcmpgtuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpgtuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vcmpgtuh; - - ------------------ - -- vec_vcmpgtsb -- - ------------------ - - function vec_vcmpgtsb - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpgtsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vcmpgtsb; - - ------------------ - -- vec_vcmpgtub -- - ------------------ - - function vec_vcmpgtub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpgtub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vcmpgtub; - - --------------- - -- vec_cmple -- - --------------- - - function vec_cmple - (A : vector_float; - B : vector_float) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgefp (To_LL_VF (B), To_LL_VF (A))); - end vec_cmple; - - --------------- - -- vec_cmplt -- - --------------- - - function vec_cmplt - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpgtub (To_LL_VSC (B), To_LL_VSC (A))); - end vec_cmplt; - - function vec_cmplt - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char - is - begin - return To_LL_VBC (vcmpgtsb (To_LL_VSC (B), To_LL_VSC (A))); - end vec_cmplt; - - function vec_cmplt - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpgtuh (To_LL_VSS (B), To_LL_VSS (A))); - end vec_cmplt; - - function vec_cmplt - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short - is - begin - return To_LL_VBS (vcmpgtsh (To_LL_VSS (B), To_LL_VSS (A))); - end vec_cmplt; - - function vec_cmplt - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtuw (To_LL_VSI (B), To_LL_VSI (A))); - end vec_cmplt; - - function vec_cmplt - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtsw (To_LL_VSI (B), To_LL_VSI (A))); - end vec_cmplt; - - function vec_cmplt - (A : vector_float; - B : vector_float) return vector_bool_int - is - begin - return To_LL_VBI (vcmpgtfp (To_LL_VF (B), To_LL_VF (A))); - end vec_cmplt; - - --------------- - -- vec_expte -- - --------------- - - function vec_expte - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vexptefp (To_LL_VF (A))); - end vec_expte; - - --------------- - -- vec_floor -- - --------------- - - function vec_floor - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vrfim (To_LL_VF (A))); - end vec_floor; - - ------------ - -- vec_ld -- - ------------ - - function vec_ld - (A : c_long; - B : const_vector_float_ptr) return vector_float - is - begin - return To_LL_VF (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_float_ptr) return vector_float - is - begin - return To_LL_VF (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_bool_int_ptr) return vector_bool_int - is - begin - return To_LL_VBI (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_signed_int_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_int_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_long_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_unsigned_int_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_bool_short_ptr) return vector_bool_short - is - begin - return To_LL_VBS (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_pixel_ptr) return vector_pixel - is - begin - return To_LL_VP (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_signed_short_ptr) return vector_signed_short - is - begin - return To_LL_VSS (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_short_ptr) return vector_signed_short - is - begin - return To_LL_VSS (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_unsigned_short_ptr) return vector_unsigned_short - is - begin - return To_LL_VUS (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short - is - begin - return To_LL_VUS (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_bool_char_ptr) return vector_bool_char - is - begin - return To_LL_VBC (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_signed_char_ptr) return vector_signed_char - is - begin - return To_LL_VSC (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char - is - begin - return To_LL_VSC (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_vector_unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvx (A, To_PTR (B))); - end vec_ld; - - function vec_ld - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvx (A, To_PTR (B))); - end vec_ld; - - ------------- - -- vec_lde -- - ------------- - - function vec_lde - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char - is - begin - return To_LL_VSC (lvebx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvebx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_short_ptr) return vector_signed_short - is - begin - return To_LL_VSS (lvehx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short - is - begin - return To_LL_VUS (lvehx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_float_ptr) return vector_float - is - begin - return To_LL_VF (lvewx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_int_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvewx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvewx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_long_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvewx (A, To_PTR (B))); - end vec_lde; - - function vec_lde - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvewx (A, To_PTR (B))); - end vec_lde; - - --------------- - -- vec_lvewx -- - --------------- - - function vec_lvewx - (A : c_long; - B : float_ptr) return vector_float - is - begin - return To_LL_VF (lvewx (A, To_PTR (B))); - end vec_lvewx; - - function vec_lvewx - (A : c_long; - B : int_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvewx (A, To_PTR (B))); - end vec_lvewx; - - function vec_lvewx - (A : c_long; - B : unsigned_int_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvewx (A, To_PTR (B))); - end vec_lvewx; - - function vec_lvewx - (A : c_long; - B : long_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvewx (A, To_PTR (B))); - end vec_lvewx; - - function vec_lvewx - (A : c_long; - B : unsigned_long_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvewx (A, To_PTR (B))); - end vec_lvewx; - - --------------- - -- vec_lvehx -- - --------------- - - function vec_lvehx - (A : c_long; - B : short_ptr) return vector_signed_short - is - begin - return To_LL_VSS (lvehx (A, To_PTR (B))); - end vec_lvehx; - - function vec_lvehx - (A : c_long; - B : unsigned_short_ptr) return vector_unsigned_short - is - begin - return To_LL_VUS (lvehx (A, To_PTR (B))); - end vec_lvehx; - - --------------- - -- vec_lvebx -- - --------------- - - function vec_lvebx - (A : c_long; - B : signed_char_ptr) return vector_signed_char - is - begin - return To_LL_VSC (lvebx (A, To_PTR (B))); - end vec_lvebx; - - function vec_lvebx - (A : c_long; - B : unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvebx (A, To_PTR (B))); - end vec_lvebx; - - ------------- - -- vec_ldl -- - ------------- - - function vec_ldl - (A : c_long; - B : const_vector_float_ptr) return vector_float - is - begin - return To_LL_VF (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_float_ptr) return vector_float - is - begin - return To_LL_VF (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_bool_int_ptr) return vector_bool_int - is - begin - return To_LL_VBI (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_signed_int_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_int_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_long_ptr) return vector_signed_int - is - begin - return To_LL_VSI (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_unsigned_int_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int - is - begin - return To_LL_VUI (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_bool_short_ptr) return vector_bool_short - is - begin - return To_LL_VBS (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_pixel_ptr) return vector_pixel - is - begin - return To_LL_VP (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_signed_short_ptr) return vector_signed_short - is - begin - return To_LL_VSS (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_short_ptr) return vector_signed_short - is - begin - return To_LL_VSS (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_unsigned_short_ptr) return vector_unsigned_short - is - begin - return To_LL_VUS (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short - is - begin - return To_LL_VUS (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_bool_char_ptr) return vector_bool_char - is - begin - return To_LL_VBC (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_signed_char_ptr) return vector_signed_char - is - begin - return To_LL_VSC (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char - is - begin - return To_LL_VSC (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_vector_unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvxl (A, To_PTR (B))); - end vec_ldl; - - function vec_ldl - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvxl (A, To_PTR (B))); - end vec_ldl; - - -------------- - -- vec_loge -- - -------------- - - function vec_loge - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vlogefp (To_LL_VF (A))); - end vec_loge; - - -------------- - -- vec_lvsl -- - -------------- - - function vec_lvsl - (A : c_long; - B : constv_unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_signed_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_unsigned_short_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_short_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_unsigned_int_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_int_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_unsigned_long_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_long_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - function vec_lvsl - (A : c_long; - B : constv_float_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsl (A, To_PTR (B))); - end vec_lvsl; - - -------------- - -- vec_lvsr -- - -------------- - - function vec_lvsr - (A : c_long; - B : constv_unsigned_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_signed_char_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_unsigned_short_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_short_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_unsigned_int_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_int_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_unsigned_long_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_long_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - function vec_lvsr - (A : c_long; - B : constv_float_ptr) return vector_unsigned_char - is - begin - return To_LL_VUC (lvsr (A, To_PTR (B))); - end vec_lvsr; - - -------------- - -- vec_madd -- - -------------- - - function vec_madd - (A : vector_float; - B : vector_float; - C : vector_float) return vector_float - is - begin - return vmaddfp (A, B, C); - end vec_madd; - - --------------- - -- vec_madds -- - --------------- - - function vec_madds - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - is - begin - return vmhaddshs (A, B, C); - end vec_madds; - - ------------- - -- vec_max -- - ------------- - - function vec_max - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_max; - - function vec_max - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_max; - - function vec_max - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_max; - - function vec_max - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_max; - - function vec_max - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_max; - - function vec_max - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_max; - - function vec_max - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_max; - - function vec_max - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_max; - - function vec_max - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_max; - - function vec_max - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_max; - - function vec_max - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_max; - - function vec_max - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_max; - - function vec_max - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_max; - - function vec_max - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_max; - - function vec_max - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_max; - - function vec_max - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_max; - - function vec_max - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_max; - - function vec_max - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_max; - - function vec_max - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vmaxfp (To_LL_VF (A), To_LL_VF (B))); - end vec_max; - - ---------------- - -- vec_vmaxfp -- - ---------------- - - function vec_vmaxfp - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vmaxfp (To_LL_VF (A), To_LL_VF (B))); - end vec_vmaxfp; - - ---------------- - -- vec_vmaxsw -- - ---------------- - - function vec_vmaxsw - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmaxsw; - - function vec_vmaxsw - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmaxsw; - - function vec_vmaxsw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmaxsw; - - ---------------- - -- vec_vmaxuw -- - ---------------- - - function vec_vmaxuw - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmaxuw; - - function vec_vmaxuw - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmaxuw; - - function vec_vmaxuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmaxuw; - - ---------------- - -- vec_vmaxsh -- - ---------------- - - function vec_vmaxsh - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmaxsh; - - function vec_vmaxsh - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmaxsh; - - function vec_vmaxsh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmaxsh; - - ---------------- - -- vec_vmaxuh -- - ---------------- - - function vec_vmaxuh - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmaxuh; - - function vec_vmaxuh - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmaxuh; - - function vec_vmaxuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmaxuh; - - ---------------- - -- vec_vmaxsb -- - ---------------- - - function vec_vmaxsb - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmaxsb; - - function vec_vmaxsb - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmaxsb; - - function vec_vmaxsb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmaxsb; - - ---------------- - -- vec_vmaxub -- - ---------------- - - function vec_vmaxub - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmaxub; - - function vec_vmaxub - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmaxub; - - function vec_vmaxub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmaxub; - - ---------------- - -- vec_mergeh -- - ---------------- - - function vec_mergeh - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_pixel; - B : vector_pixel) return vector_pixel - is - begin - return To_LL_VP (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergeh; - - function vec_mergeh - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergeh; - - ---------------- - -- vec_vmrghw -- - ---------------- - - function vec_vmrghw - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrghw; - - function vec_vmrghw - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrghw; - - function vec_vmrghw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrghw; - - function vec_vmrghw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrghw; - - ---------------- - -- vec_vmrghh -- - ---------------- - - function vec_vmrghh - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrghh; - - function vec_vmrghh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrghh; - - function vec_vmrghh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrghh; - - function vec_vmrghh - (A : vector_pixel; - B : vector_pixel) return vector_pixel - is - begin - return To_LL_VP (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrghh; - - ---------------- - -- vec_vmrghb -- - ---------------- - - function vec_vmrghb - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmrghb; - - function vec_vmrghb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmrghb; - - function vec_vmrghb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmrghb; - - ---------------- - -- vec_mergel -- - ---------------- - - function vec_mergel - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mergel; - - function vec_mergel - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mergel; - - function vec_mergel - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mergel; - - function vec_mergel - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergel; - - function vec_mergel - (A : vector_pixel; - B : vector_pixel) return vector_pixel - is - begin - return To_LL_VP (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergel; - - function vec_mergel - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergel; - - function vec_mergel - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mergel; - - function vec_mergel - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergel; - - function vec_mergel - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergel; - - function vec_mergel - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergel; - - function vec_mergel - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_mergel; - - ---------------- - -- vec_vmrglw -- - ---------------- - - function vec_vmrglw - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrglw; - - function vec_vmrglw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrglw; - - function vec_vmrglw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrglw; - - function vec_vmrglw - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vmrglw; - - ---------------- - -- vec_vmrglh -- - ---------------- - - function vec_vmrglh - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrglh; - - function vec_vmrglh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrglh; - - function vec_vmrglh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrglh; - - function vec_vmrglh - (A : vector_pixel; - B : vector_pixel) return vector_pixel - is - begin - return To_LL_VP (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmrglh; - - ---------------- - -- vec_vmrglb -- - ---------------- - - function vec_vmrglb - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmrglb; - - function vec_vmrglb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmrglb; - - function vec_vmrglb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmrglb; - - ---------------- - -- vec_mfvscr -- - ---------------- - - function vec_mfvscr return vector_unsigned_short - is - begin - return To_LL_VUS (mfvscr); - end vec_mfvscr; - - ------------- - -- vec_min -- - ------------- - - function vec_min - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_min; - - function vec_min - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_min; - - function vec_min - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_min; - - function vec_min - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_min; - - function vec_min - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_min; - - function vec_min - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_min; - - function vec_min - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_min; - - function vec_min - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_min; - - function vec_min - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_min; - - function vec_min - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_min; - - function vec_min - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_min; - - function vec_min - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_min; - - function vec_min - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_min; - - function vec_min - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_min; - - function vec_min - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_min; - - function vec_min - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_min; - - function vec_min - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_min; - - function vec_min - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_min; - - function vec_min - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vminfp (To_LL_VF (A), To_LL_VF (B))); - end vec_min; - - -- vec_vminfp -- - - function vec_vminfp - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vminfp (To_LL_VF (A), To_LL_VF (B))); - end vec_vminfp; - - -- vec_vminsw -- - - function vec_vminsw - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vminsw; - - function vec_vminsw - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vminsw; - - function vec_vminsw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vminsw; - - -- vec_vminuw -- - - function vec_vminuw - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vminuw; - - function vec_vminuw - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vminuw; - - function vec_vminuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vminuw; - - -- vec_vminsh -- - - function vec_vminsh - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vminsh; - - function vec_vminsh - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vminsh; - - function vec_vminsh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vminsh; - - ---------------- - -- vec_vminuh -- - ---------------- - - function vec_vminuh - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vminuh; - - function vec_vminuh - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vminuh; - - function vec_vminuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vminuh; - - ---------------- - -- vec_vminsb -- - ---------------- - - function vec_vminsb - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vminsb; - - function vec_vminsb - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vminsb; - - function vec_vminsb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vminsb; - - ---------------- - -- vec_vminub -- - ---------------- - - function vec_vminub - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vminub; - - function vec_vminub - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vminub; - - function vec_vminub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vminub; - - --------------- - -- vec_mladd -- - --------------- - - function vec_mladd - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - is - begin - return vmladduhm (A, B, C); - end vec_mladd; - - function vec_mladd - (A : vector_signed_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_signed_short - is - begin - return vmladduhm (A, To_LL_VSS (B), To_LL_VSS (C)); - end vec_mladd; - - function vec_mladd - (A : vector_unsigned_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - is - begin - return vmladduhm (To_LL_VSS (A), B, C); - end vec_mladd; - - function vec_mladd - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_unsigned_short - is - begin - return - To_LL_VUS (vmladduhm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSS (C))); - end vec_mladd; - - ---------------- - -- vec_mradds -- - ---------------- - - function vec_mradds - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - is - begin - return vmhraddshs (A, B, C); - end vec_mradds; - - -------------- - -- vec_msum -- - -------------- - - function vec_msum - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vmsumubm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); - end vec_msum; - - function vec_msum - (A : vector_signed_char; - B : vector_unsigned_char; - C : vector_signed_int) return vector_signed_int - is - begin - return - To_LL_VSI (vmsummbm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); - end vec_msum; - - function vec_msum - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vmsumuhm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_msum; - - function vec_msum - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int - is - begin - return - To_LL_VSI (vmsumshm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_msum; - - ------------------ - -- vec_vmsumshm -- - ------------------ - - function vec_vmsumshm - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int - is - begin - return - To_LL_VSI (vmsumshm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_vmsumshm; - - ------------------ - -- vec_vmsumuhm -- - ------------------ - - function vec_vmsumuhm - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vmsumuhm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_vmsumuhm; - - ------------------ - -- vec_vmsummbm -- - ------------------ - - function vec_vmsummbm - (A : vector_signed_char; - B : vector_unsigned_char; - C : vector_signed_int) return vector_signed_int - is - begin - return - To_LL_VSI (vmsummbm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); - end vec_vmsummbm; - - ------------------ - -- vec_vmsumubm -- - ------------------ - - function vec_vmsumubm - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vmsumubm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); - end vec_vmsumubm; - - --------------- - -- vec_msums -- - --------------- - - function vec_msums - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vmsumuhs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_msums; - - function vec_msums - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int - is - begin - return - To_LL_VSI (vmsumshs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_msums; - - ------------------ - -- vec_vmsumshs -- - ------------------ - - function vec_vmsumshs - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int - is - begin - return - To_LL_VSI (vmsumshs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_vmsumshs; - - ------------------ - -- vec_vmsumuhs -- - ------------------ - - function vec_vmsumuhs - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vmsumuhs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); - end vec_vmsumuhs; - - ---------------- - -- vec_mtvscr -- - ---------------- - - procedure vec_mtvscr - (A : vector_signed_int) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_unsigned_int) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_bool_int) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_signed_short) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_unsigned_short) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_bool_short) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_pixel) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_signed_char) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_unsigned_char) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - procedure vec_mtvscr - (A : vector_bool_char) - is - begin - mtvscr (To_LL_VSI (A)); - end vec_mtvscr; - - -------------- - -- vec_mule -- - -------------- - - function vec_mule - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vmuleub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mule; - - function vec_mule - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vmulesb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mule; - - function vec_mule - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int - is - begin - return To_LL_VUI (vmuleuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mule; - - function vec_mule - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vmulesh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mule; - - ----------------- - -- vec_vmulesh -- - ----------------- - - function vec_vmulesh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vmulesh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmulesh; - - ----------------- - -- vec_vmuleuh -- - ----------------- - - function vec_vmuleuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int - is - begin - return To_LL_VUI (vmuleuh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmuleuh; - - ----------------- - -- vec_vmulesb -- - ----------------- - - function vec_vmulesb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vmuleub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmulesb; - - ----------------- - -- vec_vmuleub -- - ----------------- - - function vec_vmuleub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vmuleub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmuleub; - - -------------- - -- vec_mulo -- - -------------- - - function vec_mulo - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vmuloub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mulo; - - function vec_mulo - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vmulosb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_mulo; - - function vec_mulo - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int - is - begin - return To_LL_VUI (vmulouh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mulo; - - function vec_mulo - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vmulosh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_mulo; - - ----------------- - -- vec_vmulosh -- - ----------------- - - function vec_vmulosh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vmulosh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmulosh; - - ----------------- - -- vec_vmulouh -- - ----------------- - - function vec_vmulouh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int - is - begin - return To_LL_VUI (vmulouh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vmulouh; - - ----------------- - -- vec_vmulosb -- - ----------------- - - function vec_vmulosb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vmulosb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmulosb; - - ----------------- - -- vec_vmuloub -- - ----------------- - - function vec_vmuloub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vmuloub (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vmuloub; - - --------------- - -- vec_nmsub -- - --------------- - - function vec_nmsub - (A : vector_float; - B : vector_float; - C : vector_float) return vector_float - is - begin - return To_LL_VF (vnmsubfp (To_LL_VF (A), To_LL_VF (B), To_LL_VF (C))); - end vec_nmsub; - - ------------- - -- vec_nor -- - ------------- - - function vec_nor - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - function vec_nor - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vnor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_nor; - - ------------ - -- vec_or -- - ------------ - - function vec_or - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_float; - B : vector_bool_int) return vector_float - is - begin - return To_LL_VF (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_int; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - function vec_or - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_or; - - -------------- - -- vec_pack -- - -------------- - - function vec_pack - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char - is - begin - return To_LL_VSC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); - end vec_pack; - - function vec_pack - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); - end vec_pack; - - function vec_pack - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_char - is - begin - return To_LL_VBC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); - end vec_pack; - - function vec_pack - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short - is - begin - return To_LL_VSS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); - end vec_pack; - - function vec_pack - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); - end vec_pack; - - function vec_pack - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_short - is - begin - return To_LL_VBS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); - end vec_pack; - - ----------------- - -- vec_vpkuwum -- - ----------------- - - function vec_vpkuwum - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_short - is - begin - return To_LL_VBS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vpkuwum; - - function vec_vpkuwum - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short - is - begin - return To_LL_VSS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vpkuwum; - - function vec_vpkuwum - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vpkuwum; - - ----------------- - -- vec_vpkuhum -- - ----------------- - - function vec_vpkuhum - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_char - is - begin - return To_LL_VBC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vpkuhum; - - function vec_vpkuhum - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char - is - begin - return To_LL_VSC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vpkuhum; - - function vec_vpkuhum - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vpkuhum; - - ---------------- - -- vec_packpx -- - ---------------- - - function vec_packpx - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_pixel - is - begin - return To_LL_VP (vpkpx (To_LL_VSI (A), To_LL_VSI (B))); - end vec_packpx; - - --------------- - -- vec_packs -- - --------------- - - function vec_packs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vpkuhus (To_LL_VSS (A), To_LL_VSS (B))); - end vec_packs; - - function vec_packs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char - is - begin - return To_LL_VSC (vpkshss (To_LL_VSS (A), To_LL_VSS (B))); - end vec_packs; - - function vec_packs - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vpkuwus (To_LL_VSI (A), To_LL_VSI (B))); - end vec_packs; - - function vec_packs - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short - is - begin - return To_LL_VSS (vpkswss (To_LL_VSI (A), To_LL_VSI (B))); - end vec_packs; - - ----------------- - -- vec_vpkswss -- - ----------------- - - function vec_vpkswss - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short - is - begin - return To_LL_VSS (vpkswss (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vpkswss; - - ----------------- - -- vec_vpkuwus -- - ----------------- - - function vec_vpkuwus - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vpkuwus (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vpkuwus; - - ----------------- - -- vec_vpkshss -- - ----------------- - - function vec_vpkshss - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char - is - begin - return To_LL_VSC (vpkshss (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vpkshss; - - ----------------- - -- vec_vpkuhus -- - ----------------- - - function vec_vpkuhus - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vpkuhus (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vpkuhus; - - ---------------- - -- vec_packsu -- - ---------------- - - function vec_packsu - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vpkuhus (To_LL_VSS (A), To_LL_VSS (B))); - end vec_packsu; - - function vec_packsu - (A : vector_signed_short; - B : vector_signed_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vpkshus (To_LL_VSS (A), To_LL_VSS (B))); - end vec_packsu; - - function vec_packsu - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vpkuwus (To_LL_VSI (A), To_LL_VSI (B))); - end vec_packsu; - - function vec_packsu - (A : vector_signed_int; - B : vector_signed_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vpkswus (To_LL_VSI (A), To_LL_VSI (B))); - end vec_packsu; - - ----------------- - -- vec_vpkswus -- - ----------------- - - function vec_vpkswus - (A : vector_signed_int; - B : vector_signed_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vpkswus (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vpkswus; - - ----------------- - -- vec_vpkshus -- - ----------------- - - function vec_vpkshus - (A : vector_signed_short; - B : vector_signed_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vpkshus (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vpkshus; - - -------------- - -- vec_perm -- - -------------- - - function vec_perm - (A : vector_float; - B : vector_float; - C : vector_unsigned_char) return vector_float - is - begin - return - To_LL_VF (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_signed_int; - B : vector_signed_int; - C : vector_unsigned_char) return vector_signed_int - is - begin - return - To_LL_VSI (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_unsigned_char) return vector_unsigned_int - is - begin - return - To_LL_VUI (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_bool_int; - B : vector_bool_int; - C : vector_unsigned_char) return vector_bool_int - is - begin - return - To_LL_VBI (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_signed_short; - B : vector_signed_short; - C : vector_unsigned_char) return vector_signed_short - is - begin - return - To_LL_VSS (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_char) return vector_unsigned_short - is - begin - return - To_LL_VUS (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_bool_short; - B : vector_bool_short; - C : vector_unsigned_char) return vector_bool_short - is - begin - return - To_LL_VBS (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_pixel; - B : vector_pixel; - C : vector_unsigned_char) return vector_pixel - is - begin - return To_LL_VP - (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_signed_char; - B : vector_signed_char; - C : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC - (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_char) return vector_unsigned_char - is - begin - return - To_LL_VUC (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - function vec_perm - (A : vector_bool_char; - B : vector_bool_char; - C : vector_unsigned_char) return vector_bool_char - is - begin - return - To_LL_VBC (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); - end vec_perm; - - ------------ - -- vec_re -- - ------------ - - function vec_re - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vrefp (To_LL_VF (A))); - end vec_re; - - ------------ - -- vec_rl -- - ------------ - - function vec_rl - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_rl; - - function vec_rl - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_rl; - - function vec_rl - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_rl; - - function vec_rl - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_rl; - - function vec_rl - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_rl; - - function vec_rl - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_rl; - - -------------- - -- vec_vrlw -- - -------------- - - function vec_vrlw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vrlw; - - function vec_vrlw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vrlw; - - -------------- - -- vec_vrlh -- - -------------- - - function vec_vrlh - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vrlh; - - function vec_vrlh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vrlh; - - -------------- - -- vec_vrlb -- - -------------- - - function vec_vrlb - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vrlb; - - function vec_vrlb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vrlb; - - --------------- - -- vec_round -- - --------------- - - function vec_round - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vrfin (To_LL_VF (A))); - end vec_round; - - ---------------- - -- vec_rsqrte -- - ---------------- - - function vec_rsqrte - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vrsqrtefp (To_LL_VF (A))); - end vec_rsqrte; - - ------------- - -- vec_sel -- - ------------- - - function vec_sel - (A : vector_float; - B : vector_float; - C : vector_bool_int) return vector_float - is - begin - return To_LL_VF (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_float; - B : vector_float; - C : vector_unsigned_int) return vector_float - is - begin - return To_LL_VF (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_signed_int; - B : vector_signed_int; - C : vector_bool_int) return vector_signed_int - is - begin - return - To_LL_VSI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_signed_int; - B : vector_signed_int; - C : vector_unsigned_int) return vector_signed_int - is - begin - return - To_LL_VSI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_bool_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_unsigned_int) return vector_unsigned_int - is - begin - return - To_LL_VUI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_bool_int; - B : vector_bool_int; - C : vector_bool_int) return vector_bool_int - is - begin - return - To_LL_VBI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_bool_int; - B : vector_bool_int; - C : vector_unsigned_int) return vector_bool_int - is - begin - return - To_LL_VBI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_signed_short; - B : vector_signed_short; - C : vector_bool_short) return vector_signed_short - is - begin - return - To_LL_VSS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_signed_short; - B : vector_signed_short; - C : vector_unsigned_short) return vector_signed_short - is - begin - return - To_LL_VSS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_bool_short) return vector_unsigned_short - is - begin - return - To_LL_VUS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_unsigned_short - is - begin - return - To_LL_VUS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_bool_short; - B : vector_bool_short; - C : vector_bool_short) return vector_bool_short - is - begin - return - To_LL_VBS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_bool_short; - B : vector_bool_short; - C : vector_unsigned_short) return vector_bool_short - is - begin - return - To_LL_VBS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_signed_char; - B : vector_signed_char; - C : vector_bool_char) return vector_signed_char - is - begin - return - To_LL_VSC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_signed_char; - B : vector_signed_char; - C : vector_unsigned_char) return vector_signed_char - is - begin - return - To_LL_VSC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_bool_char) return vector_unsigned_char - is - begin - return - To_LL_VUC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_char) return vector_unsigned_char - is - begin - return - To_LL_VUC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_bool_char; - B : vector_bool_char; - C : vector_bool_char) return vector_bool_char - is - begin - return - To_LL_VBC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - function vec_sel - (A : vector_bool_char; - B : vector_bool_char; - C : vector_unsigned_char) return vector_bool_char - is - begin - return - To_LL_VBC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); - end vec_sel; - - ------------ - -- vec_sl -- - ------------ - - function vec_sl - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vslb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sl; - - function vec_sl - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vslb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sl; - - function vec_sl - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vslh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sl; - - function vec_sl - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vslh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sl; - - function vec_sl - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vslw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sl; - - function vec_sl - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vslw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sl; - - -------------- - -- vec_vslw -- - -------------- - - function vec_vslw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vslw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vslw; - - function vec_vslw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vslw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vslw; - - -------------- - -- vec_vslh -- - -------------- - - function vec_vslh - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vslh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vslh; - - function vec_vslh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vslh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vslh; - - -------------- - -- vec_vslb -- - -------------- - - function vec_vslb - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vslb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vslb; - - function vec_vslb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vslb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vslb; - - ------------- - -- vec_sll -- - ------------- - - function vec_sll - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_int; - B : vector_unsigned_short) return vector_signed_int - is - begin - return To_LL_VSI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - is - begin - return To_LL_VSI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_int; - B : vector_unsigned_short) return vector_unsigned_int - is - begin - return To_LL_VUI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - is - begin - return To_LL_VUI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_int; - B : vector_unsigned_int) return vector_bool_int - is - begin - return To_LL_VBI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_int; - B : vector_unsigned_short) return vector_bool_int - is - begin - return To_LL_VBI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_int; - B : vector_unsigned_char) return vector_bool_int - is - begin - return To_LL_VBI (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_short; - B : vector_unsigned_int) return vector_signed_short - is - begin - return To_LL_VSS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - is - begin - return To_LL_VSS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_short; - B : vector_unsigned_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_short; - B : vector_unsigned_int) return vector_bool_short - is - begin - return To_LL_VBS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_short; - B : vector_unsigned_short) return vector_bool_short - is - begin - return To_LL_VBS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_short; - B : vector_unsigned_char) return vector_bool_short - is - begin - return To_LL_VBS (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_pixel; - B : vector_unsigned_int) return vector_pixel - is - begin - return To_LL_VP (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_pixel; - B : vector_unsigned_short) return vector_pixel - is - begin - return To_LL_VP (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - is - begin - return To_LL_VP (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_char; - B : vector_unsigned_int) return vector_signed_char - is - begin - return To_LL_VSC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_char; - B : vector_unsigned_short) return vector_signed_char - is - begin - return To_LL_VSC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_char - is - begin - return To_LL_VUC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_char; - B : vector_unsigned_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_char; - B : vector_unsigned_int) return vector_bool_char - is - begin - return To_LL_VBC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_char; - B : vector_unsigned_short) return vector_bool_char - is - begin - return To_LL_VBC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - function vec_sll - (A : vector_bool_char; - B : vector_unsigned_char) return vector_bool_char - is - begin - return To_LL_VBC (vsl (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sll; - - ------------- - -- vec_slo -- - ------------- - - function vec_slo - (A : vector_float; - B : vector_signed_char) return vector_float - is - begin - return To_LL_VF (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_float; - B : vector_unsigned_char) return vector_float - is - begin - return To_LL_VF (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_signed_int; - B : vector_signed_char) return vector_signed_int - is - begin - return To_LL_VSI (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - is - begin - return To_LL_VSI (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_unsigned_int; - B : vector_signed_char) return vector_unsigned_int - is - begin - return To_LL_VUI (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - is - begin - return To_LL_VUI (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_signed_short; - B : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - is - begin - return To_LL_VSS (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_unsigned_short; - B : vector_signed_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_pixel; - B : vector_signed_char) return vector_pixel - is - begin - return To_LL_VP (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - is - begin - return To_LL_VP (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_unsigned_char; - B : vector_signed_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - function vec_slo - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vslo (To_LL_VSI (A), To_LL_VSI (B))); - end vec_slo; - - ------------ - -- vec_sr -- - ------------ - - function vec_sr - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sr; - - function vec_sr - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sr; - - function vec_sr - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sr; - - function vec_sr - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sr; - - function vec_sr - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sr; - - function vec_sr - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sr; - - -------------- - -- vec_vsrw -- - -------------- - - function vec_vsrw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsrw; - - function vec_vsrw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsrw; - - -------------- - -- vec_vsrh -- - -------------- - - function vec_vsrh - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsrh; - - function vec_vsrh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsrh; - - -------------- - -- vec_vsrb -- - -------------- - - function vec_vsrb - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsrb; - - function vec_vsrb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsrb; - - ------------- - -- vec_sra -- - ------------- - - function vec_sra - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sra; - - function vec_sra - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sra; - - function vec_sra - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sra; - - function vec_sra - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sra; - - function vec_sra - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sra; - - function vec_sra - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sra; - - --------------- - -- vec_vsraw -- - --------------- - - function vec_vsraw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsraw; - - function vec_vsraw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsraw; - - --------------- - -- vec_vsrah -- - --------------- - - function vec_vsrah - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsrah; - - function vec_vsrah - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsrah; - - --------------- - -- vec_vsrab -- - --------------- - - function vec_vsrab - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsrab; - - function vec_vsrab - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsrab; - - ------------- - -- vec_srl -- - ------------- - - function vec_srl - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - is - begin - return To_LL_VSI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_int; - B : vector_unsigned_short) return vector_signed_int - is - begin - return To_LL_VSI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - is - begin - return To_LL_VSI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_int; - B : vector_unsigned_short) return vector_unsigned_int - is - begin - return To_LL_VUI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - is - begin - return To_LL_VUI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_int; - B : vector_unsigned_int) return vector_bool_int - is - begin - return To_LL_VBI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_int; - B : vector_unsigned_short) return vector_bool_int - is - begin - return To_LL_VBI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_int; - B : vector_unsigned_char) return vector_bool_int - is - begin - return To_LL_VBI (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_short; - B : vector_unsigned_int) return vector_signed_short - is - begin - return To_LL_VSS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - is - begin - return To_LL_VSS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - is - begin - return To_LL_VSS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_short; - B : vector_unsigned_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_short; - B : vector_unsigned_int) return vector_bool_short - is - begin - return To_LL_VBS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_short; - B : vector_unsigned_short) return vector_bool_short - is - begin - return To_LL_VBS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_short; - B : vector_unsigned_char) return vector_bool_short - is - begin - return To_LL_VBS (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_pixel; - B : vector_unsigned_int) return vector_pixel - is - begin - return To_LL_VP (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_pixel; - B : vector_unsigned_short) return vector_pixel - is - begin - return To_LL_VP (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - is - begin - return To_LL_VP (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_char; - B : vector_unsigned_int) return vector_signed_char - is - begin - return To_LL_VSC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_char; - B : vector_unsigned_short) return vector_signed_char - is - begin - return To_LL_VSC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_char - is - begin - return To_LL_VUC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_char; - B : vector_unsigned_short) return vector_unsigned_char - is - begin - return To_LL_VUC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_char; - B : vector_unsigned_int) return vector_bool_char - is - begin - return To_LL_VBC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_char; - B : vector_unsigned_short) return vector_bool_char - is - begin - return To_LL_VBC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - function vec_srl - (A : vector_bool_char; - B : vector_unsigned_char) return vector_bool_char - is - begin - return To_LL_VBC (vsr (To_LL_VSI (A), To_LL_VSI (B))); - end vec_srl; - - ------------- - -- vec_sro -- - ------------- - - function vec_sro - (A : vector_float; - B : vector_signed_char) return vector_float - is - begin - return To_LL_VF (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_float; - B : vector_unsigned_char) return vector_float - is - begin - return To_LL_VF (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_signed_int; - B : vector_signed_char) return vector_signed_int - is - begin - return To_LL_VSI (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - is - begin - return To_LL_VSI (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_unsigned_int; - B : vector_signed_char) return vector_unsigned_int - is - begin - return To_LL_VUI (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - is - begin - return To_LL_VUI (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_signed_short; - B : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - is - begin - return To_LL_VSS (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_unsigned_short; - B : vector_signed_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - is - begin - return To_LL_VUS (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_pixel; - B : vector_signed_char) return vector_pixel - is - begin - return To_LL_VP (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - is - begin - return To_LL_VP (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - is - begin - return To_LL_VSC (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_unsigned_char; - B : vector_signed_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - function vec_sro - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsro (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sro; - - ------------ - -- vec_st -- - ------------ - - procedure vec_st - (A : vector_float; - B : c_int; - C : vector_float_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_float; - B : c_int; - C : float_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_signed_int; - B : c_int; - C : vector_signed_int_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_signed_int; - B : c_int; - C : int_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_unsigned_int; - B : c_int; - C : vector_unsigned_int_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_int; - B : c_int; - C : vector_bool_int_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_int; - B : c_int; - C : int_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_signed_short; - B : c_int; - C : vector_signed_short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_signed_short; - B : c_int; - C : short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_unsigned_short; - B : c_int; - C : vector_unsigned_short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_short; - B : c_int; - C : vector_bool_short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_pixel; - B : c_int; - C : vector_pixel_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_pixel; - B : c_int; - C : short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_short; - B : c_int; - C : short_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_signed_char; - B : c_int; - C : vector_signed_char_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_unsigned_char; - B : c_int; - C : vector_unsigned_char_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_char; - B : c_int; - C : vector_bool_char_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - procedure vec_st - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvx (To_LL_VSI (A), B, To_PTR (C)); - end vec_st; - - ------------- - -- vec_ste -- - ------------- - - procedure vec_ste - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_signed_short; - B : c_int; - C : short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_bool_short; - B : c_int; - C : short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_pixel; - B : c_int; - C : short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_float; - B : c_int; - C : float_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_signed_int; - B : c_int; - C : int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_bool_int; - B : c_int; - C : int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_ste; - - procedure vec_ste - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_ste; - - ---------------- - -- vec_stvewx -- - ---------------- - - procedure vec_stvewx - (A : vector_float; - B : c_int; - C : float_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_stvewx; - - procedure vec_stvewx - (A : vector_signed_int; - B : c_int; - C : int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_stvewx; - - procedure vec_stvewx - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_stvewx; - - procedure vec_stvewx - (A : vector_bool_int; - B : c_int; - C : int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_stvewx; - - procedure vec_stvewx - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvewx (To_LL_VSI (A), B, To_PTR (C)); - end vec_stvewx; - - ---------------- - -- vec_stvehx -- - ---------------- - - procedure vec_stvehx - (A : vector_signed_short; - B : c_int; - C : short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_stvehx; - - procedure vec_stvehx - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_stvehx; - - procedure vec_stvehx - (A : vector_bool_short; - B : c_int; - C : short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_stvehx; - - procedure vec_stvehx - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_stvehx; - - procedure vec_stvehx - (A : vector_pixel; - B : c_int; - C : short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_stvehx; - - procedure vec_stvehx - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvehx (To_LL_VSS (A), B, To_PTR (C)); - end vec_stvehx; - - ---------------- - -- vec_stvebx -- - ---------------- - - procedure vec_stvebx - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_stvebx; - - procedure vec_stvebx - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_stvebx; - - procedure vec_stvebx - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_stvebx; - - procedure vec_stvebx - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvebx (To_LL_VSC (A), B, To_PTR (C)); - end vec_stvebx; - - ------------- - -- vec_stl -- - ------------- - - procedure vec_stl - (A : vector_float; - B : c_int; - C : vector_float_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_float; - B : c_int; - C : float_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_signed_int; - B : c_int; - C : vector_signed_int_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_signed_int; - B : c_int; - C : int_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_unsigned_int; - B : c_int; - C : vector_unsigned_int_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_int; - B : c_int; - C : vector_bool_int_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_int; - B : c_int; - C : int_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_signed_short; - B : c_int; - C : vector_signed_short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_signed_short; - B : c_int; - C : short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_unsigned_short; - B : c_int; - C : vector_unsigned_short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_short; - B : c_int; - C : vector_bool_short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_short; - B : c_int; - C : short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_pixel; - B : c_int; - C : vector_pixel_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_pixel; - B : c_int; - C : short_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_signed_char; - B : c_int; - C : vector_signed_char_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_unsigned_char; - B : c_int; - C : vector_unsigned_char_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_char; - B : c_int; - C : vector_bool_char_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - procedure vec_stl - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr) - is - begin - stvxl (To_LL_VSI (A), B, To_PTR (C)); - end vec_stl; - - ------------- - -- vec_sub -- - ------------- - - function vec_sub - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sub; - - function vec_sub - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sub; - - function vec_sub - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sub; - - function vec_sub - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sub; - - function vec_sub - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sub; - - function vec_sub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_sub; - - function vec_sub - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sub; - - function vec_sub - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sub; - - function vec_sub - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sub; - - function vec_sub - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sub; - - function vec_sub - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sub; - - function vec_sub - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_sub; - - function vec_sub - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sub; - - function vec_sub - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sub; - - function vec_sub - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sub; - - function vec_sub - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sub; - - function vec_sub - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sub; - - function vec_sub - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sub; - - function vec_sub - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vsubfp (To_LL_VF (A), To_LL_VF (B))); - end vec_sub; - - ---------------- - -- vec_vsubfp -- - ---------------- - - function vec_vsubfp - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vsubfp (To_LL_VF (A), To_LL_VF (B))); - end vec_vsubfp; - - ----------------- - -- vec_vsubuwm -- - ----------------- - - function vec_vsubuwm - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuwm; - - function vec_vsubuwm - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuwm; - - function vec_vsubuwm - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuwm; - - function vec_vsubuwm - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuwm; - - function vec_vsubuwm - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuwm; - - function vec_vsubuwm - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuwm; - - ----------------- - -- vec_vsubuhm -- - ----------------- - - function vec_vsubuhm - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhm; - - function vec_vsubuhm - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhm; - - function vec_vsubuhm - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhm; - - function vec_vsubuhm - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhm; - - function vec_vsubuhm - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhm; - - function vec_vsubuhm - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhm; - - ----------------- - -- vec_vsububm -- - ----------------- - - function vec_vsububm - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububm; - - function vec_vsububm - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububm; - - function vec_vsububm - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububm; - - function vec_vsububm - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububm; - - function vec_vsububm - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububm; - - function vec_vsububm - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububm; - - -------------- - -- vec_subc -- - -------------- - - function vec_subc - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubcuw (To_LL_VSI (A), To_LL_VSI (B))); - end vec_subc; - - -------------- - -- vec_subs -- - -------------- - - function vec_subs - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_subs; - - function vec_subs - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_subs; - - function vec_subs - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_subs; - - function vec_subs - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_subs; - - function vec_subs - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_subs; - - function vec_subs - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_subs; - - function vec_subs - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_subs; - - function vec_subs - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_subs; - - function vec_subs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_subs; - - function vec_subs - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_subs; - - function vec_subs - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_subs; - - function vec_subs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_subs; - - function vec_subs - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_subs; - - function vec_subs - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_subs; - - function vec_subs - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_subs; - - function vec_subs - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_subs; - - function vec_subs - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_subs; - - function vec_subs - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_subs; - - ----------------- - -- vec_vsubsws -- - ----------------- - - function vec_vsubsws - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubsws; - - function vec_vsubsws - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubsws; - - function vec_vsubsws - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubsws; - - ----------------- - -- vec_vsubuws -- - ----------------- - - function vec_vsubuws - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuws; - - function vec_vsubuws - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuws; - - function vec_vsubuws - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_vsubuws; - - ----------------- - -- vec_vsubshs -- - ----------------- - - function vec_vsubshs - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubshs; - - function vec_vsubshs - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubshs; - - function vec_vsubshs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubshs; - - ----------------- - -- vec_vsubuhs -- - ----------------- - - function vec_vsubuhs - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhs; - - function vec_vsubuhs - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhs; - - function vec_vsubuhs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); - end vec_vsubuhs; - - ----------------- - -- vec_vsubsbs -- - ----------------- - - function vec_vsubsbs - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsubsbs; - - function vec_vsubsbs - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsubsbs; - - function vec_vsubsbs - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsubsbs; - - ----------------- - -- vec_vsububs -- - ----------------- - - function vec_vsububs - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububs; - - function vec_vsububs - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububs; - - function vec_vsububs - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); - end vec_vsububs; - - --------------- - -- vec_sum4s -- - --------------- - - function vec_sum4s - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsum4ubs (To_LL_VSC (A), To_LL_VSI (B))); - end vec_sum4s; - - function vec_sum4s - (A : vector_signed_char; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsum4sbs (To_LL_VSC (A), To_LL_VSI (B))); - end vec_sum4s; - - function vec_sum4s - (A : vector_signed_short; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsum4shs (To_LL_VSS (A), To_LL_VSI (B))); - end vec_sum4s; - - ------------------ - -- vec_vsum4shs -- - ------------------ - - function vec_vsum4shs - (A : vector_signed_short; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsum4shs (To_LL_VSS (A), To_LL_VSI (B))); - end vec_vsum4shs; - - ------------------ - -- vec_vsum4sbs -- - ------------------ - - function vec_vsum4sbs - (A : vector_signed_char; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsum4sbs (To_LL_VSC (A), To_LL_VSI (B))); - end vec_vsum4sbs; - - ------------------ - -- vec_vsum4ubs -- - ------------------ - - function vec_vsum4ubs - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsum4ubs (To_LL_VSC (A), To_LL_VSI (B))); - end vec_vsum4ubs; - - --------------- - -- vec_sum2s -- - --------------- - - function vec_sum2s - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsum2sws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sum2s; - - -------------- - -- vec_sums -- - -------------- - - function vec_sums - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vsumsws (To_LL_VSI (A), To_LL_VSI (B))); - end vec_sums; - - --------------- - -- vec_trunc -- - --------------- - - function vec_trunc - (A : vector_float) return vector_float - is - begin - return To_LL_VF (vrfiz (To_LL_VF (A))); - end vec_trunc; - - ----------------- - -- vec_unpackh -- - ----------------- - - function vec_unpackh - (A : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vupkhsb (To_LL_VSC (A))); - end vec_unpackh; - - function vec_unpackh - (A : vector_bool_char) return vector_bool_short - is - begin - return To_LL_VBS (vupkhsb (To_LL_VSC (A))); - end vec_unpackh; - - function vec_unpackh - (A : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vupkhsh (To_LL_VSS (A))); - end vec_unpackh; - - function vec_unpackh - (A : vector_bool_short) return vector_bool_int - is - begin - return To_LL_VBI (vupkhsh (To_LL_VSS (A))); - end vec_unpackh; - - function vec_unpackh - (A : vector_pixel) return vector_unsigned_int - is - begin - return To_LL_VUI (vupkhpx (To_LL_VSS (A))); - end vec_unpackh; - - ----------------- - -- vec_vupkhsh -- - ----------------- - - function vec_vupkhsh - (A : vector_bool_short) return vector_bool_int - is - begin - return To_LL_VBI (vupkhsh (To_LL_VSS (A))); - end vec_vupkhsh; - - function vec_vupkhsh - (A : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vupkhsh (To_LL_VSS (A))); - end vec_vupkhsh; - - ----------------- - -- vec_vupkhpx -- - ----------------- - - function vec_vupkhpx - (A : vector_pixel) return vector_unsigned_int - is - begin - return To_LL_VUI (vupkhpx (To_LL_VSS (A))); - end vec_vupkhpx; - - ----------------- - -- vec_vupkhsb -- - ----------------- - - function vec_vupkhsb - (A : vector_bool_char) return vector_bool_short - is - begin - return To_LL_VBS (vupkhsb (To_LL_VSC (A))); - end vec_vupkhsb; - - function vec_vupkhsb - (A : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vupkhsb (To_LL_VSC (A))); - end vec_vupkhsb; - - ----------------- - -- vec_unpackl -- - ----------------- - - function vec_unpackl - (A : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vupklsb (To_LL_VSC (A))); - end vec_unpackl; - - function vec_unpackl - (A : vector_bool_char) return vector_bool_short - is - begin - return To_LL_VBS (vupklsb (To_LL_VSC (A))); - end vec_unpackl; - - function vec_unpackl - (A : vector_pixel) return vector_unsigned_int - is - begin - return To_LL_VUI (vupklpx (To_LL_VSS (A))); - end vec_unpackl; - - function vec_unpackl - (A : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vupklsh (To_LL_VSS (A))); - end vec_unpackl; - - function vec_unpackl - (A : vector_bool_short) return vector_bool_int - is - begin - return To_LL_VBI (vupklsh (To_LL_VSS (A))); - end vec_unpackl; - - ----------------- - -- vec_vupklpx -- - ----------------- - - function vec_vupklpx - (A : vector_pixel) return vector_unsigned_int - is - begin - return To_LL_VUI (vupklpx (To_LL_VSS (A))); - end vec_vupklpx; - - ----------------- - -- vec_vupklsh -- - ----------------- - - function vec_vupklsh - (A : vector_bool_short) return vector_bool_int - is - begin - return To_LL_VBI (vupklsh (To_LL_VSS (A))); - end vec_vupklsh; - - function vec_vupklsh - (A : vector_signed_short) return vector_signed_int - is - begin - return To_LL_VSI (vupklsh (To_LL_VSS (A))); - end vec_vupklsh; - - ----------------- - -- vec_vupklsb -- - ----------------- - - function vec_vupklsb - (A : vector_bool_char) return vector_bool_short - is - begin - return To_LL_VBS (vupklsb (To_LL_VSC (A))); - end vec_vupklsb; - - function vec_vupklsb - (A : vector_signed_char) return vector_signed_short - is - begin - return To_LL_VSS (vupklsb (To_LL_VSC (A))); - end vec_vupklsb; - - ------------- - -- vec_xor -- - ------------- - - function vec_xor - (A : vector_float; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_float; - B : vector_bool_int) return vector_float - is - begin - return To_LL_VF (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_int; - B : vector_float) return vector_float - is - begin - return To_LL_VF (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - is - begin - return To_LL_VBI (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - is - begin - return To_LL_VSI (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - is - begin - return To_LL_VSI (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - is - begin - return To_LL_VBS (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - is - begin - return To_LL_VSS (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - is - begin - return To_LL_VSS (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - is - begin - return To_LL_VUS (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - is - begin - return To_LL_VBC (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - is - begin - return To_LL_VSC (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - is - begin - return To_LL_VSC (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - function vec_xor - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - is - begin - return To_LL_VUC (vxor (To_LL_VSI (A), To_LL_VSI (B))); - end vec_xor; - - ------------- - -- vec_dst -- - ------------- - - procedure vec_dst - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_vector_float_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_short_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_int_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_long_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - procedure vec_dst - (A : const_float_ptr; - B : c_int; - C : c_int) - is - begin - dst (To_PTR (A), B, C); - end vec_dst; - - -------------- - -- vec_dstt -- - -------------- - - procedure vec_dstt - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_vector_float_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_short_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_int_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_long_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - procedure vec_dstt - (A : const_float_ptr; - B : c_int; - C : c_int) - is - begin - dstt (To_PTR (A), B, C); - end vec_dstt; - - --------------- - -- vec_dstst -- - --------------- - - procedure vec_dstst - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_vector_float_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_short_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_int_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_long_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - procedure vec_dstst - (A : const_float_ptr; - B : c_int; - C : c_int) - is - begin - dstst (To_PTR (A), B, C); - end vec_dstst; - - ---------------- - -- vec_dststt -- - ---------------- - - procedure vec_dststt - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_vector_float_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_signed_char_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_short_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_int_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_long_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - procedure vec_dststt - (A : const_float_ptr; - B : c_int; - C : c_int) - is - begin - dststt (To_PTR (A), B, C); - end vec_dststt; - - ---------------- - -- vec_vspltw -- - ---------------- - - function vec_vspltw - (A : vector_float; - B : c_int) return vector_float - is - begin - return To_LL_VF (vspltw (To_LL_VSI (A), B)); - end vec_vspltw; - - function vec_vspltw - (A : vector_unsigned_int; - B : c_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vspltw (To_LL_VSI (A), B)); - end vec_vspltw; - - function vec_vspltw - (A : vector_bool_int; - B : c_int) return vector_bool_int - is - begin - return To_LL_VBI (vspltw (To_LL_VSI (A), B)); - end vec_vspltw; - - ---------------- - -- vec_vsplth -- - ---------------- - - function vec_vsplth - (A : vector_bool_short; - B : c_int) return vector_bool_short - is - begin - return To_LL_VBS (vsplth (To_LL_VSS (A), B)); - end vec_vsplth; - - function vec_vsplth - (A : vector_unsigned_short; - B : c_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vsplth (To_LL_VSS (A), B)); - end vec_vsplth; - - function vec_vsplth - (A : vector_pixel; - B : c_int) return vector_pixel - is - begin - return To_LL_VP (vsplth (To_LL_VSS (A), B)); - end vec_vsplth; - - ---------------- - -- vec_vspltb -- - ---------------- - - function vec_vspltb - (A : vector_unsigned_char; - B : c_int) return vector_unsigned_char - is - begin - return To_LL_VUC (vspltb (To_LL_VSC (A), B)); - end vec_vspltb; - - function vec_vspltb - (A : vector_bool_char; - B : c_int) return vector_bool_char - is - begin - return To_LL_VBC (vspltb (To_LL_VSC (A), B)); - end vec_vspltb; - - ------------------ - -- vec_splat_u8 -- - ------------------ - - function vec_splat_u8 - (A : c_int) return vector_unsigned_char - is - begin - return To_LL_VUC (vspltisb (A)); - end vec_splat_u8; - - ------------------- - -- vec_splat_u16 -- - ------------------- - - function vec_splat_u16 - (A : c_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vspltish (A)); - end vec_splat_u16; - - ------------------- - -- vec_splat_u32 -- - ------------------- - - function vec_splat_u32 - (A : c_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vspltisw (A)); - end vec_splat_u32; - - ------------- - -- vec_sld -- - ------------- - - function vec_sld - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : c_int) return vector_unsigned_int - is - begin - return To_LL_VUI (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); - end vec_sld; - - function vec_sld - (A : vector_bool_int; - B : vector_bool_int; - C : c_int) return vector_bool_int - is - begin - return To_LL_VBI (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); - end vec_sld; - - function vec_sld - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : c_int) return vector_unsigned_short - is - begin - return To_LL_VUS (vsldoi_8hi (To_LL_VSS (A), To_LL_VSS (B), C)); - end vec_sld; - - function vec_sld - (A : vector_bool_short; - B : vector_bool_short; - C : c_int) return vector_bool_short - is - begin - return To_LL_VBS (vsldoi_8hi (To_LL_VSS (A), To_LL_VSS (B), C)); - end vec_sld; - - function vec_sld - (A : vector_pixel; - B : vector_pixel; - C : c_int) return vector_pixel - is - begin - return To_LL_VP (vsldoi_8hi (To_LL_VSS (A), To_LL_VSS (B), C)); - end vec_sld; - - function vec_sld - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : c_int) return vector_unsigned_char - is - begin - return To_LL_VUC (vsldoi_16qi (To_LL_VSC (A), To_LL_VSC (B), C)); - end vec_sld; - - function vec_sld - (A : vector_bool_char; - B : vector_bool_char; - C : c_int) return vector_bool_char - is - begin - return To_LL_VBC (vsldoi_16qi (To_LL_VSC (A), To_LL_VSC (B), C)); - end vec_sld; - - ---------------- - -- vec_all_eq -- - ---------------- - - function vec_all_eq - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_pixel; - B : vector_pixel) return c_int - is - begin - return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_eq; - - function vec_all_eq - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_LT, To_LL_VF (A), To_LL_VF (B)); - end vec_all_eq; - - ---------------- - -- vec_all_ge -- - ---------------- - - function vec_all_ge - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_ge; - - function vec_all_ge - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_LT, To_LL_VF (A), To_LL_VF (B)); - end vec_all_ge; - - ---------------- - -- vec_all_gt -- - ---------------- - - function vec_all_gt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_gt; - - function vec_all_gt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_LT, To_LL_VF (A), To_LL_VF (B)); - end vec_all_gt; - - ---------------- - -- vec_all_in -- - ---------------- - - function vec_all_in - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpbfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); - end vec_all_in; - - ---------------- - -- vec_all_le -- - ---------------- - - function vec_all_le - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_le; - - function vec_all_le - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_le; - - function vec_all_le - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_le; - - function vec_all_le - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_le; - - function vec_all_le - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_le; - - function vec_all_le - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_le; - - function vec_all_le - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_le; - - function vec_all_le - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_le; - - function vec_all_le - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_le; - - function vec_all_le - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_le; - - function vec_all_le - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_le; - - function vec_all_le - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_le; - - function vec_all_le - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_le; - - function vec_all_le - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_le; - - function vec_all_le - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_le; - - function vec_all_le - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_le; - - function vec_all_le - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_le; - - function vec_all_le - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_le; - - function vec_all_le - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_LT, To_LL_VF (B), To_LL_VF (A)); - end vec_all_le; - - ---------------- - -- vec_all_lt -- - ---------------- - - function vec_all_lt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); - end vec_all_lt; - - function vec_all_lt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_LT, To_LL_VF (B), To_LL_VF (A)); - end vec_all_lt; - - ----------------- - -- vec_all_nan -- - ----------------- - - function vec_all_nan - (A : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (A)); - end vec_all_nan; - - ---------------- - -- vec_all_ne -- - ---------------- - - function vec_all_ne - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_pixel; - B : vector_pixel) return c_int - is - begin - return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); - end vec_all_ne; - - function vec_all_ne - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); - end vec_all_ne; - - ----------------- - -- vec_all_nge -- - ----------------- - - function vec_all_nge - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); - end vec_all_nge; - - ----------------- - -- vec_all_ngt -- - ----------------- - - function vec_all_ngt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); - end vec_all_ngt; - - ----------------- - -- vec_all_nle -- - ----------------- - - function vec_all_nle - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_EQ, To_LL_VF (B), To_LL_VF (A)); - end vec_all_nle; - - ----------------- - -- vec_all_nlt -- - ----------------- - - function vec_all_nlt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_EQ, To_LL_VF (B), To_LL_VF (A)); - end vec_all_nlt; - - --------------------- - -- vec_all_numeric -- - --------------------- - - function vec_all_numeric - (A : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_LT, To_LL_VF (A), To_LL_VF (A)); - end vec_all_numeric; - - ---------------- - -- vec_any_eq -- - ---------------- - - function vec_any_eq - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_pixel; - B : vector_pixel) return c_int - is - begin - return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_eq; - - function vec_any_eq - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); - end vec_any_eq; - - ---------------- - -- vec_any_ge -- - ---------------- - - function vec_any_ge - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_ge; - - function vec_any_ge - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); - end vec_any_ge; - - ---------------- - -- vec_any_gt -- - ---------------- - - function vec_any_gt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_gt; - - function vec_any_gt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); - end vec_any_gt; - - ---------------- - -- vec_any_le -- - ---------------- - - function vec_any_le - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_le; - - function vec_any_le - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_le; - - function vec_any_le - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_le; - - function vec_any_le - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_le; - - function vec_any_le - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_le; - - function vec_any_le - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_le; - - function vec_any_le - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_le; - - function vec_any_le - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_le; - - function vec_any_le - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_le; - - function vec_any_le - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_le; - - function vec_any_le - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_le; - - function vec_any_le - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_le; - - function vec_any_le - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_le; - - function vec_any_le - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_le; - - function vec_any_le - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_le; - - function vec_any_le - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_le; - - function vec_any_le - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_le; - - function vec_any_le - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_le; - - function vec_any_le - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_EQ_REV, To_LL_VF (B), To_LL_VF (A)); - end vec_any_le; - - ---------------- - -- vec_any_lt -- - ---------------- - - function vec_any_lt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); - end vec_any_lt; - - function vec_any_lt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_EQ_REV, To_LL_VF (B), To_LL_VF (A)); - end vec_any_lt; - - ----------------- - -- vec_any_nan -- - ----------------- - - function vec_any_nan - (A : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (A)); - end vec_any_nan; - - ---------------- - -- vec_any_ne -- - ---------------- - - function vec_any_ne - (A : vector_signed_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_signed_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_unsigned_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_char; - B : vector_bool_char) return c_int - is - begin - return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_char; - B : vector_unsigned_char) return c_int - is - begin - return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_char; - B : vector_signed_char) return c_int - is - begin - return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_signed_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_signed_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_unsigned_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_short; - B : vector_bool_short) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_short; - B : vector_unsigned_short) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_short; - B : vector_signed_short) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_pixel; - B : vector_pixel) return c_int - is - begin - return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_signed_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_signed_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_unsigned_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_int; - B : vector_bool_int) return c_int - is - begin - return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_int; - B : vector_unsigned_int) return c_int - is - begin - return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_bool_int; - B : vector_signed_int) return c_int - is - begin - return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); - end vec_any_ne; - - function vec_any_ne - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (B)); - end vec_any_ne; - - ----------------- - -- vec_any_nge -- - ----------------- - - function vec_any_nge - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (B)); - end vec_any_nge; - - ----------------- - -- vec_any_ngt -- - ----------------- - - function vec_any_ngt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (B)); - end vec_any_ngt; - - ----------------- - -- vec_any_nle -- - ----------------- - - function vec_any_nle - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgefp_p (CR6_LT_REV, To_LL_VF (B), To_LL_VF (A)); - end vec_any_nle; - - ----------------- - -- vec_any_nlt -- - ----------------- - - function vec_any_nlt - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpgtfp_p (CR6_LT_REV, To_LL_VF (B), To_LL_VF (A)); - end vec_any_nlt; - - --------------------- - -- vec_any_numeric -- - --------------------- - - function vec_any_numeric - (A : vector_float) return c_int - is - begin - return vcmpeqfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (A)); - end vec_any_numeric; - - ----------------- - -- vec_any_out -- - ----------------- - - function vec_any_out - (A : vector_float; - B : vector_float) return c_int - is - begin - return vcmpbfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); - end vec_any_out; - - -------------- - -- vec_step -- - -------------- - - function vec_step - (V : vector_unsigned_char) return Integer - is - pragma Unreferenced (V); - begin - return 16; - end vec_step; - - function vec_step - (V : vector_signed_char) return Integer - is - pragma Unreferenced (V); - begin - return 16; - end vec_step; - - function vec_step - (V : vector_bool_char) return Integer - is - pragma Unreferenced (V); - begin - return 16; - end vec_step; - - function vec_step - (V : vector_unsigned_short) return Integer - is - pragma Unreferenced (V); - begin - return 8; - end vec_step; - - function vec_step - (V : vector_signed_short) return Integer - is - pragma Unreferenced (V); - begin - return 8; - end vec_step; - - function vec_step - (V : vector_bool_short) return Integer - is - pragma Unreferenced (V); - begin - return 8; - end vec_step; - - function vec_step - (V : vector_unsigned_int) return Integer - is - pragma Unreferenced (V); - begin - return 4; - end vec_step; - - function vec_step - (V : vector_signed_int) return Integer - is - pragma Unreferenced (V); - begin - return 4; - end vec_step; - - function vec_step - (V : vector_bool_int) return Integer - is - pragma Unreferenced (V); - begin - return 4; - end vec_step; - - function vec_step - (V : vector_float) return Integer - is - pragma Unreferenced (V); - begin - return 4; - end vec_step; - - function vec_step - (V : vector_pixel) return Integer - is - pragma Unreferenced (V); - begin - return 4; - end vec_step; - -end GNAT.Altivec.Vector_Operations; diff --git a/gcc/ada/g-alveop.ads b/gcc/ada/g-alveop.ads deleted file mode 100644 index 82bc5f4..0000000 --- a/gcc/ada/g-alveop.ads +++ /dev/null @@ -1,8362 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . V E C T O R _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit is the user-level Ada interface to AltiVec operations on vector --- objects. It is common to both the Soft and the Hard bindings. - -with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; -with GNAT.Altivec.Low_Level_Vectors; use GNAT.Altivec.Low_Level_Vectors; - ------------------------------------- --- GNAT.Altivec.Vector_Operations -- ------------------------------------- - ------------------------------------- --- GNAT.Altivec.Vector_Operations -- ------------------------------------- - -package GNAT.Altivec.Vector_Operations is - - ------------------------------------- - -- Different Flavors of Interfaces -- - ------------------------------------- - - -- The vast majority of the user visible functions are just neutral type - -- conversion wrappers around calls to low level primitives. For instance: - - -- function vec_sll - -- (A : vector_signed_int; - -- B : vector_unsigned_char) return vector_signed_int is - -- begin - -- return To_VSI (vsl (To_VSI (A), To_VSI (B))); - -- end vec_sll; - - -- We actually don't always need an explicit wrapper and can bind directly - -- with a straight Import of the low level routine, or a renaming of such - -- instead. - - -- A direct binding is not possible (that is, a wrapper is mandatory) in - -- a number of cases: - - -- o When the high-level/low-level types don't match, in which case a - -- straight import would risk wrong code generation or compiler blowups in - -- the Hard binding case. This is the case for 'B' in the example above. - - -- o When the high-level/low-level argument lists differ, as is the case - -- for most of the AltiVec predicates, relying on a low-level primitive - -- which expects a control code argument, like: - - -- function vec_any_ne - -- (A : vector_signed_int; - -- B : vector_signed_int) return c_int is - -- begin - -- return vcmpequw_p (CR6_LT_REV, To_VSI (A), To_VSI (B)); - -- end vec_any_ne; - - -- o When the high-level/low-level arguments order don't match, as in: - - -- function vec_cmplt - -- (A : vector_unsigned_char; - -- B : vector_unsigned_char) return vector_bool_char is - -- begin - -- return To_VBC (vcmpgtub (To_VSC (B), To_VSC (A))); - -- end vec_cmplt; - - ----------------------------- - -- Inlining Considerations -- - ----------------------------- - - -- The intent in the hard binding case is to eventually map operations to - -- hardware instructions. Needless to say, intermediate function calls do - -- not fit this purpose, so all user visible subprograms need to be marked - -- Inline_Always. Some of the builtins we eventually bind to expect literal - -- arguments. Wrappers to such builtins are made Convention Intrinsic as - -- well so we don't attempt to compile the bodies on their own. - - -- In the soft case, the bulk of the work is performed by the low level - -- routines, and those exported by this unit are short enough for the - -- inlining to make sense and even be beneficial. - - ------------------------------------------------------- - -- [PIM-4.4 Generic and Specific AltiVec operations] -- - ------------------------------------------------------- - - ------------- - -- vec_abs -- - ------------- - - function vec_abs - (A : vector_signed_char) return vector_signed_char; - - function vec_abs - (A : vector_signed_short) return vector_signed_short; - - function vec_abs - (A : vector_signed_int) return vector_signed_int; - - function vec_abs - (A : vector_float) return vector_float; - - -------------- - -- vec_abss -- - -------------- - - function vec_abss - (A : vector_signed_char) return vector_signed_char; - - function vec_abss - (A : vector_signed_short) return vector_signed_short; - - function vec_abss - (A : vector_signed_int) return vector_signed_int; - - ------------- - -- vec_add -- - ------------- - - function vec_add - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_add - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_add - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_add - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_add - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_add - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_add - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_add - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_add - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_add - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_add - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_add - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_add - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_add - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_add - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_add - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_add - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_add - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_add - (A : vector_float; - B : vector_float) return vector_float; - - ---------------- - -- vec_vaddfp -- - ---------------- - - function vec_vaddfp - (A : vector_float; - B : vector_float) return vector_float; - - ----------------- - -- vec_vadduwm -- - ----------------- - - function vec_vadduwm - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vadduwm - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_vadduwm - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vadduwm - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vadduwm - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_vadduwm - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ----------------- - -- vec_vadduhm -- - ----------------- - - function vec_vadduhm - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vadduhm - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_vadduhm - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vadduhm - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vadduhm - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_vadduhm - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - ----------------- - -- vec_vaddubm -- - ----------------- - - function vec_vaddubm - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vaddubm - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_vaddubm - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vaddubm - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_vaddubm - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_vaddubm - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - -------------- - -- vec_addc -- - -------------- - - function vec_addc - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_adds -- - -------------- - - function vec_adds - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_adds - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_adds - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_adds - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_adds - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_adds - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_adds - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_adds - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_adds - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_adds - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_adds - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_adds - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_adds - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_adds - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_adds - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_adds - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_adds - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_adds - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ----------------- - -- vec_vaddsws -- - ----------------- - - function vec_vaddsws - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vaddsws - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_vaddsws - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ----------------- - -- vec_vadduws -- - ----------------- - - function vec_vadduws - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vadduws - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_vadduws - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ----------------- - -- vec_vaddshs -- - ----------------- - - function vec_vaddshs - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vaddshs - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_vaddshs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - ----------------- - -- vec_vadduhs -- - ----------------- - - function vec_vadduhs - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vadduhs - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_vadduhs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - ----------------- - -- vec_vaddsbs -- - ----------------- - - function vec_vaddsbs - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vaddsbs - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_vaddsbs - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - ----------------- - -- vec_vaddubs -- - ----------------- - - function vec_vaddubs - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_vaddubs - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_vaddubs - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ------------- - -- vec_and -- - ------------- - - function vec_and - (A : vector_float; - B : vector_float) return vector_float; - - function vec_and - (A : vector_float; - B : vector_bool_int) return vector_float; - - function vec_and - (A : vector_bool_int; - B : vector_float) return vector_float; - - function vec_and - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_and - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_and - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_and - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_and - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_and - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_and - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_and - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_and - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_and - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_and - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_and - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_and - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_and - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_and - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_and - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_and - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_and - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_and - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_and - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_and - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - -------------- - -- vec_andc -- - -------------- - - function vec_andc - (A : vector_float; - B : vector_float) return vector_float; - - function vec_andc - (A : vector_float; - B : vector_bool_int) return vector_float; - - function vec_andc - (A : vector_bool_int; - B : vector_float) return vector_float; - - function vec_andc - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_andc - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_andc - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_andc - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_andc - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_andc - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_andc - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_andc - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_andc - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_andc - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_andc - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_andc - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_andc - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_andc - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_andc - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_andc - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_andc - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_andc - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_andc - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_andc - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_andc - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ------------- - -- vec_avg -- - ------------- - - function vec_avg - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_avg - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_avg - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_avg - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_avg - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_avg - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ---------------- - -- vec_vavgsw -- - ---------------- - - function vec_vavgsw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ---------------- - -- vec_vavguw -- - ---------------- - - function vec_vavguw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ---------------- - -- vec_vavgsh -- - ---------------- - - function vec_vavgsh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - ---------------- - -- vec_vavguh -- - ---------------- - - function vec_vavguh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - ---------------- - -- vec_vavgsb -- - ---------------- - - function vec_vavgsb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - ---------------- - -- vec_vavgub -- - ---------------- - - function vec_vavgub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - -------------- - -- vec_ceil -- - -------------- - - function vec_ceil - (A : vector_float) return vector_float; - - -------------- - -- vec_cmpb -- - -------------- - - function vec_cmpb - (A : vector_float; - B : vector_float) return vector_signed_int; - - function vec_cmpeq - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char; - - function vec_cmpeq - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char; - - function vec_cmpeq - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short; - - function vec_cmpeq - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short; - - function vec_cmpeq - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int; - - function vec_cmpeq - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int; - - function vec_cmpeq - (A : vector_float; - B : vector_float) return vector_bool_int; - - ------------------ - -- vec_vcmpeqfp -- - ------------------ - - function vec_vcmpeqfp - (A : vector_float; - B : vector_float) return vector_bool_int; - - ------------------ - -- vec_vcmpequw -- - ------------------ - - function vec_vcmpequw - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int; - - function vec_vcmpequw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int; - - ------------------ - -- vec_vcmpequh -- - ------------------ - - function vec_vcmpequh - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short; - - function vec_vcmpequh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short; - - ------------------ - -- vec_vcmpequb -- - ------------------ - - function vec_vcmpequb - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char; - - function vec_vcmpequb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char; - - --------------- - -- vec_cmpge -- - --------------- - - function vec_cmpge - (A : vector_float; - B : vector_float) return vector_bool_int; - - --------------- - -- vec_cmpgt -- - --------------- - - function vec_cmpgt - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char; - - function vec_cmpgt - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char; - - function vec_cmpgt - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short; - - function vec_cmpgt - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short; - - function vec_cmpgt - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int; - - function vec_cmpgt - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int; - - function vec_cmpgt - (A : vector_float; - B : vector_float) return vector_bool_int; - - ------------------ - -- vec_vcmpgtfp -- - ------------------ - - function vec_vcmpgtfp - (A : vector_float; - B : vector_float) return vector_bool_int; - - ------------------ - -- vec_vcmpgtsw -- - ------------------ - - function vec_vcmpgtsw - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int; - - ------------------ - -- vec_vcmpgtuw -- - ------------------ - - function vec_vcmpgtuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int; - - ------------------ - -- vec_vcmpgtsh -- - ------------------ - - function vec_vcmpgtsh - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short; - - ------------------ - -- vec_vcmpgtuh -- - ------------------ - - function vec_vcmpgtuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short; - - ------------------ - -- vec_vcmpgtsb -- - ------------------ - - function vec_vcmpgtsb - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char; - - ------------------ - -- vec_vcmpgtub -- - ------------------ - - function vec_vcmpgtub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char; - - --------------- - -- vec_cmple -- - --------------- - - function vec_cmple - (A : vector_float; - B : vector_float) return vector_bool_int; - - --------------- - -- vec_cmplt -- - --------------- - - function vec_cmplt - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_bool_char; - - function vec_cmplt - (A : vector_signed_char; - B : vector_signed_char) return vector_bool_char; - - function vec_cmplt - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_bool_short; - - function vec_cmplt - (A : vector_signed_short; - B : vector_signed_short) return vector_bool_short; - - function vec_cmplt - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_bool_int; - - function vec_cmplt - (A : vector_signed_int; - B : vector_signed_int) return vector_bool_int; - - function vec_cmplt - (A : vector_float; - B : vector_float) return vector_bool_int; - - --------------- - -- vec_vcfsx -- - --------------- - - function vec_vcfsx - (A : vector_signed_int; - B : c_int) return vector_float - renames Low_Level_Vectors.vcfsx; - - --------------- - -- vec_vcfux -- - --------------- - - function vec_vcfux - (A : vector_unsigned_int; - B : c_int) return vector_float - renames Low_Level_Vectors.vcfux; - - ---------------- - -- vec_vctsxs -- - ---------------- - - function vec_vctsxs - (A : vector_float; - B : c_int) return vector_signed_int - renames Low_Level_Vectors.vctsxs; - - ---------------- - -- vec_vctuxs -- - ---------------- - - function vec_vctuxs - (A : vector_float; - B : c_int) return vector_unsigned_int - renames Low_Level_Vectors.vctuxs; - - ------------- - -- vec_dss -- - ------------- - - procedure vec_dss - (A : c_int) - renames Low_Level_Vectors.dss; - - ---------------- - -- vec_dssall -- - ---------------- - - procedure vec_dssall - renames Low_Level_Vectors.dssall; - - ------------- - -- vec_dst -- - ------------- - - procedure vec_dst - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_vector_float_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dst - (A : const_float_ptr; - B : c_int; - C : c_int); - pragma Inline_Always (vec_dst); - pragma Convention (Intrinsic, vec_dst); - - --------------- - -- vec_dstst -- - --------------- - - procedure vec_dstst - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_vector_float_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dstst - (A : const_float_ptr; - B : c_int; - C : c_int); - pragma Inline_Always (vec_dstst); - pragma Convention (Intrinsic, vec_dstst); - - ---------------- - -- vec_dststt -- - ---------------- - - procedure vec_dststt - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_vector_float_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dststt - (A : const_float_ptr; - B : c_int; - C : c_int); - pragma Inline_Always (vec_dststt); - pragma Convention (Intrinsic, vec_dststt); - - -------------- - -- vec_dstt -- - -------------- - - procedure vec_dstt - (A : const_vector_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_bool_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_signed_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_bool_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_pixel_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_signed_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_bool_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_vector_float_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_unsigned_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_signed_char_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_unsigned_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_short_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_unsigned_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_int_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_unsigned_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_long_ptr; - B : c_int; - C : c_int); - - procedure vec_dstt - (A : const_float_ptr; - B : c_int; - C : c_int); - pragma Inline_Always (vec_dstt); - pragma Convention (Intrinsic, vec_dstt); - - --------------- - -- vec_expte -- - --------------- - - function vec_expte - (A : vector_float) return vector_float; - - --------------- - -- vec_floor -- - --------------- - - function vec_floor - (A : vector_float) return vector_float; - - ------------ - -- vec_ld -- - ------------ - - function vec_ld - (A : c_long; - B : const_vector_float_ptr) return vector_float; - - function vec_ld - (A : c_long; - B : const_float_ptr) return vector_float; - - function vec_ld - (A : c_long; - B : const_vector_bool_int_ptr) return vector_bool_int; - - function vec_ld - (A : c_long; - B : const_vector_signed_int_ptr) return vector_signed_int; - - function vec_ld - (A : c_long; - B : const_int_ptr) return vector_signed_int; - - function vec_ld - (A : c_long; - B : const_long_ptr) return vector_signed_int; - - function vec_ld - (A : c_long; - B : const_vector_unsigned_int_ptr) return vector_unsigned_int; - - function vec_ld - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int; - - function vec_ld - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int; - - function vec_ld - (A : c_long; - B : const_vector_bool_short_ptr) return vector_bool_short; - - function vec_ld - (A : c_long; - B : const_vector_pixel_ptr) return vector_pixel; - - function vec_ld - (A : c_long; - B : const_vector_signed_short_ptr) return vector_signed_short; - - function vec_ld - (A : c_long; - B : const_short_ptr) return vector_signed_short; - - function vec_ld - (A : c_long; - B : const_vector_unsigned_short_ptr) return vector_unsigned_short; - - function vec_ld - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short; - - function vec_ld - (A : c_long; - B : const_vector_bool_char_ptr) return vector_bool_char; - - function vec_ld - (A : c_long; - B : const_vector_signed_char_ptr) return vector_signed_char; - - function vec_ld - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char; - - function vec_ld - (A : c_long; - B : const_vector_unsigned_char_ptr) return vector_unsigned_char; - - function vec_ld - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char; - - ------------- - -- vec_lde -- - ------------- - - function vec_lde - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char; - - function vec_lde - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char; - - function vec_lde - (A : c_long; - B : const_short_ptr) return vector_signed_short; - - function vec_lde - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short; - - function vec_lde - (A : c_long; - B : const_float_ptr) return vector_float; - - function vec_lde - (A : c_long; - B : const_int_ptr) return vector_signed_int; - - function vec_lde - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int; - - function vec_lde - (A : c_long; - B : const_long_ptr) return vector_signed_int; - - function vec_lde - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int; - - --------------- - -- vec_lvewx -- - --------------- - - function vec_lvewx - (A : c_long; - B : float_ptr) return vector_float; - - function vec_lvewx - (A : c_long; - B : int_ptr) return vector_signed_int; - - function vec_lvewx - (A : c_long; - B : unsigned_int_ptr) return vector_unsigned_int; - - function vec_lvewx - (A : c_long; - B : long_ptr) return vector_signed_int; - - function vec_lvewx - (A : c_long; - B : unsigned_long_ptr) return vector_unsigned_int; - - --------------- - -- vec_lvehx -- - --------------- - - function vec_lvehx - (A : c_long; - B : short_ptr) return vector_signed_short; - - function vec_lvehx - (A : c_long; - B : unsigned_short_ptr) return vector_unsigned_short; - - --------------- - -- vec_lvebx -- - --------------- - - function vec_lvebx - (A : c_long; - B : signed_char_ptr) return vector_signed_char; - - function vec_lvebx - (A : c_long; - B : unsigned_char_ptr) return vector_unsigned_char; - - ------------- - -- vec_ldl -- - ------------- - - function vec_ldl - (A : c_long; - B : const_vector_float_ptr) return vector_float; - - function vec_ldl - (A : c_long; - B : const_float_ptr) return vector_float; - - function vec_ldl - (A : c_long; - B : const_vector_bool_int_ptr) return vector_bool_int; - - function vec_ldl - (A : c_long; - B : const_vector_signed_int_ptr) return vector_signed_int; - - function vec_ldl - (A : c_long; - B : const_int_ptr) return vector_signed_int; - - function vec_ldl - (A : c_long; - B : const_long_ptr) return vector_signed_int; - - function vec_ldl - (A : c_long; - B : const_vector_unsigned_int_ptr) return vector_unsigned_int; - - function vec_ldl - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int; - - function vec_ldl - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int; - - function vec_ldl - (A : c_long; - B : const_vector_bool_short_ptr) return vector_bool_short; - - function vec_ldl - (A : c_long; - B : const_vector_pixel_ptr) return vector_pixel; - - function vec_ldl - (A : c_long; - B : const_vector_signed_short_ptr) return vector_signed_short; - - function vec_ldl - (A : c_long; - B : const_short_ptr) return vector_signed_short; - - function vec_ldl - (A : c_long; - B : const_vector_unsigned_short_ptr) return vector_unsigned_short; - - function vec_ldl - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short; - - function vec_ldl - (A : c_long; - B : const_vector_bool_char_ptr) return vector_bool_char; - - function vec_ldl - (A : c_long; - B : const_vector_signed_char_ptr) return vector_signed_char; - - function vec_ldl - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char; - - function vec_ldl - (A : c_long; - B : const_vector_unsigned_char_ptr) return vector_unsigned_char; - - function vec_ldl - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char; - - -------------- - -- vec_loge -- - -------------- - - function vec_loge - (A : vector_float) return vector_float; - - -------------- - -- vec_lvsl -- - -------------- - - function vec_lvsl - (A : c_long; - B : constv_unsigned_char_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_signed_char_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_unsigned_short_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_short_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_unsigned_int_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_int_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_unsigned_long_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_long_ptr) return vector_unsigned_char; - - function vec_lvsl - (A : c_long; - B : constv_float_ptr) return vector_unsigned_char; - - -------------- - -- vec_lvsr -- - -------------- - - function vec_lvsr - (A : c_long; - B : constv_unsigned_char_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_signed_char_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_unsigned_short_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_short_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_unsigned_int_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_int_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_unsigned_long_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_long_ptr) return vector_unsigned_char; - - function vec_lvsr - (A : c_long; - B : constv_float_ptr) return vector_unsigned_char; - - -------------- - -- vec_madd -- - -------------- - - function vec_madd - (A : vector_float; - B : vector_float; - C : vector_float) return vector_float; - - --------------- - -- vec_madds -- - --------------- - - function vec_madds - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short; - - ------------- - -- vec_max -- - ------------- - - function vec_max - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_max - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_max - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_max - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_max - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_max - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_max - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_max - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_max - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_max - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_max - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_max - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_max - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_max - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_max - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_max - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_max - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_max - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_max - (A : vector_float; - B : vector_float) return vector_float; - - ---------------- - -- vec_vmaxfp -- - ---------------- - - function vec_vmaxfp - (A : vector_float; - B : vector_float) return vector_float; - - ---------------- - -- vec_vmaxsw -- - ---------------- - - function vec_vmaxsw - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vmaxsw - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_vmaxsw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ---------------- - -- vec_vmaxuw -- - ---------------- - - function vec_vmaxuw - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vmaxuw - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_vmaxuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ---------------- - -- vec_vmaxsh -- - ---------------- - - function vec_vmaxsh - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vmaxsh - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_vmaxsh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - ---------------- - -- vec_vmaxuh -- - ---------------- - - function vec_vmaxuh - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vmaxuh - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_vmaxuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - ---------------- - -- vec_vmaxsb -- - ---------------- - - function vec_vmaxsb - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vmaxsb - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_vmaxsb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - ---------------- - -- vec_vmaxub -- - ---------------- - - function vec_vmaxub - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_vmaxub - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_vmaxub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ---------------- - -- vec_mergeh -- - ---------------- - - function vec_mergeh - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_mergeh - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_mergeh - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_mergeh - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_mergeh - (A : vector_pixel; - B : vector_pixel) return vector_pixel; - - function vec_mergeh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_mergeh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_mergeh - (A : vector_float; - B : vector_float) return vector_float; - - function vec_mergeh - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_mergeh - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_mergeh - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ---------------- - -- vec_vmrghw -- - ---------------- - - function vec_vmrghw - (A : vector_float; - B : vector_float) return vector_float; - - function vec_vmrghw - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_vmrghw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vmrghw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ---------------- - -- vec_vmrghh -- - ---------------- - - function vec_vmrghh - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_vmrghh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vmrghh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vmrghh - (A : vector_pixel; - B : vector_pixel) return vector_pixel; - - ---------------- - -- vec_vmrghb -- - ---------------- - - function vec_vmrghb - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_vmrghb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vmrghb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ---------------- - -- vec_mergel -- - ---------------- - - function vec_mergel - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_mergel - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_mergel - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_mergel - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_mergel - (A : vector_pixel; - B : vector_pixel) return vector_pixel; - - function vec_mergel - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_mergel - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_mergel - (A : vector_float; - B : vector_float) return vector_float; - - function vec_mergel - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_mergel - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_mergel - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ---------------- - -- vec_vmrglw -- - ---------------- - - function vec_vmrglw - (A : vector_float; - B : vector_float) return vector_float; - - function vec_vmrglw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vmrglw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vmrglw - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - ---------------- - -- vec_vmrglh -- - ---------------- - - function vec_vmrglh - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_vmrglh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vmrglh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vmrglh - (A : vector_pixel; - B : vector_pixel) return vector_pixel; - - ---------------- - -- vec_vmrglb -- - ---------------- - - function vec_vmrglb - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_vmrglb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vmrglb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ---------------- - -- vec_mfvscr -- - ---------------- - - function vec_mfvscr return vector_unsigned_short; - - ------------- - -- vec_min -- - ------------- - - function vec_min - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_min - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_min - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_min - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_min - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_min - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_min - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_min - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_min - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_min - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_min - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_min - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_min - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_min - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_min - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_min - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_min - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_min - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_min - (A : vector_float; - B : vector_float) return vector_float; - - ---------------- - -- vec_vminfp -- - ---------------- - - function vec_vminfp - (A : vector_float; - B : vector_float) return vector_float; - - ---------------- - -- vec_vminsw -- - ---------------- - - function vec_vminsw - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vminsw - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_vminsw - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ---------------- - -- vec_vminuw -- - ---------------- - - function vec_vminuw - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vminuw - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_vminuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ---------------- - -- vec_vminsh -- - ---------------- - - function vec_vminsh - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vminsh - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_vminsh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - ---------------- - -- vec_vminuh -- - ---------------- - - function vec_vminuh - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vminuh - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_vminuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - ---------------- - -- vec_vminsb -- - ---------------- - - function vec_vminsb - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vminsb - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_vminsb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - ---------------- - -- vec_vminub -- - ---------------- - - function vec_vminub - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_vminub - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_vminub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - --------------- - -- vec_mladd -- - --------------- - - function vec_mladd - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short; - - function vec_mladd - (A : vector_signed_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_signed_short; - - function vec_mladd - (A : vector_unsigned_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short; - - function vec_mladd - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_unsigned_short; - - ---------------- - -- vec_mradds -- - ---------------- - - function vec_mradds - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short; - - -------------- - -- vec_msum -- - -------------- - - function vec_msum - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_int) return vector_unsigned_int; - - function vec_msum - (A : vector_signed_char; - B : vector_unsigned_char; - C : vector_signed_int) return vector_signed_int; - - function vec_msum - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int; - - function vec_msum - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int; - - ------------------ - -- vec_vmsumshm -- - ------------------ - - function vec_vmsumshm - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int; - - ------------------ - -- vec_vmsumuhm -- - ------------------ - - function vec_vmsumuhm - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int; - - ------------------ - -- vec_vmsummbm -- - ------------------ - - function vec_vmsummbm - (A : vector_signed_char; - B : vector_unsigned_char; - C : vector_signed_int) return vector_signed_int; - - ------------------ - -- vec_vmsumubm -- - ------------------ - - function vec_vmsumubm - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_int) return vector_unsigned_int; - - --------------- - -- vec_msums -- - --------------- - - function vec_msums - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int; - - function vec_msums - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int; - - function vec_vmsumshs - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_int) return vector_signed_int; - - ------------------ - -- vec_vmsumuhs -- - ------------------ - - function vec_vmsumuhs - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_int) return vector_unsigned_int; - - ---------------- - -- vec_mtvscr -- - ---------------- - - procedure vec_mtvscr - (A : vector_signed_int); - - procedure vec_mtvscr - (A : vector_unsigned_int); - - procedure vec_mtvscr - (A : vector_bool_int); - - procedure vec_mtvscr - (A : vector_signed_short); - - procedure vec_mtvscr - (A : vector_unsigned_short); - - procedure vec_mtvscr - (A : vector_bool_short); - - procedure vec_mtvscr - (A : vector_pixel); - - procedure vec_mtvscr - (A : vector_signed_char); - - procedure vec_mtvscr - (A : vector_unsigned_char); - - procedure vec_mtvscr - (A : vector_bool_char); - - -------------- - -- vec_mule -- - -------------- - - function vec_mule - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short; - - function vec_mule - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short; - - function vec_mule - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int; - - function vec_mule - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int; - - ----------------- - -- vec_vmulesh -- - ----------------- - - function vec_vmulesh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int; - - ----------------- - -- vec_vmuleuh -- - ----------------- - - function vec_vmuleuh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int; - - ----------------- - -- vec_vmulesb -- - ----------------- - - function vec_vmulesb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short; - - ----------------- - -- vec_vmuleub -- - ----------------- - - function vec_vmuleub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short; - - -------------- - -- vec_mulo -- - -------------- - - function vec_mulo - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short; - - function vec_mulo - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short; - - function vec_mulo - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int; - - function vec_mulo - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int; - - ----------------- - -- vec_vmulosh -- - ----------------- - - function vec_vmulosh - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_int; - - ----------------- - -- vec_vmulouh -- - ----------------- - - function vec_vmulouh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_int; - - ----------------- - -- vec_vmulosb -- - ----------------- - - function vec_vmulosb - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_short; - - ----------------- - -- vec_vmuloub -- - ----------------- - - function vec_vmuloub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_short; - - --------------- - -- vec_nmsub -- - --------------- - - function vec_nmsub - (A : vector_float; - B : vector_float; - C : vector_float) return vector_float; - - ------------- - -- vec_nor -- - ------------- - - function vec_nor - (A : vector_float; - B : vector_float) return vector_float; - - function vec_nor - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_nor - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_nor - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_nor - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_nor - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_nor - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_nor - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_nor - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_nor - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - ------------ - -- vec_or -- - ------------ - - function vec_or - (A : vector_float; - B : vector_float) return vector_float; - - function vec_or - (A : vector_float; - B : vector_bool_int) return vector_float; - - function vec_or - (A : vector_bool_int; - B : vector_float) return vector_float; - - function vec_or - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_or - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_or - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_or - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_or - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_or - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_or - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_or - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_or - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_or - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_or - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_or - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_or - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_or - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_or - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_or - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_or - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_or - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_or - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_or - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_or - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - -------------- - -- vec_pack -- - -------------- - - function vec_pack - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char; - - function vec_pack - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char; - - function vec_pack - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_char; - - function vec_pack - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short; - - function vec_pack - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short; - - function vec_pack - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_short; - - ----------------- - -- vec_vpkuwum -- - ----------------- - - function vec_vpkuwum - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_short; - - function vec_vpkuwum - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short; - - function vec_vpkuwum - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short; - - ----------------- - -- vec_vpkuhum -- - ----------------- - - function vec_vpkuhum - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_char; - - function vec_vpkuhum - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char; - - function vec_vpkuhum - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char; - - ---------------- - -- vec_packpx -- - ---------------- - - function vec_packpx - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_pixel; - - --------------- - -- vec_packs -- - --------------- - - function vec_packs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char; - - function vec_packs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char; - - function vec_packs - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short; - - function vec_packs - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short; - - ----------------- - -- vec_vpkswss -- - ----------------- - - function vec_vpkswss - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_short; - - ----------------- - -- vec_vpkuwus -- - ----------------- - - function vec_vpkuwus - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short; - - ----------------- - -- vec_vpkshss -- - ----------------- - - function vec_vpkshss - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_char; - - ----------------- - -- vec_vpkuhus -- - ----------------- - - function vec_vpkuhus - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char; - - ---------------- - -- vec_packsu -- - ---------------- - - function vec_packsu - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_char; - - function vec_packsu - (A : vector_signed_short; - B : vector_signed_short) return vector_unsigned_char; - - function vec_packsu - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_short; - - function vec_packsu - (A : vector_signed_int; - B : vector_signed_int) return vector_unsigned_short; - - ----------------- - -- vec_vpkswus -- - ----------------- - - function vec_vpkswus - (A : vector_signed_int; - B : vector_signed_int) return vector_unsigned_short; - - ----------------- - -- vec_vpkshus -- - ----------------- - - function vec_vpkshus - (A : vector_signed_short; - B : vector_signed_short) return vector_unsigned_char; - - -------------- - -- vec_perm -- - -------------- - - function vec_perm - (A : vector_float; - B : vector_float; - C : vector_unsigned_char) return vector_float; - - function vec_perm - (A : vector_signed_int; - B : vector_signed_int; - C : vector_unsigned_char) return vector_signed_int; - - function vec_perm - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_unsigned_char) return vector_unsigned_int; - - function vec_perm - (A : vector_bool_int; - B : vector_bool_int; - C : vector_unsigned_char) return vector_bool_int; - - function vec_perm - (A : vector_signed_short; - B : vector_signed_short; - C : vector_unsigned_char) return vector_signed_short; - - function vec_perm - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_char) return vector_unsigned_short; - - function vec_perm - (A : vector_bool_short; - B : vector_bool_short; - C : vector_unsigned_char) return vector_bool_short; - - function vec_perm - (A : vector_pixel; - B : vector_pixel; - C : vector_unsigned_char) return vector_pixel; - - function vec_perm - (A : vector_signed_char; - B : vector_signed_char; - C : vector_unsigned_char) return vector_signed_char; - - function vec_perm - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_char) return vector_unsigned_char; - - function vec_perm - (A : vector_bool_char; - B : vector_bool_char; - C : vector_unsigned_char) return vector_bool_char; - - ------------ - -- vec_re -- - ------------ - - function vec_re - (A : vector_float) return vector_float; - - ------------ - -- vec_rl -- - ------------ - - function vec_rl - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_rl - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_rl - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_rl - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_rl - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_rl - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_vrlw -- - -------------- - - function vec_vrlw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_vrlw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_vrlh -- - -------------- - - function vec_vrlh - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_vrlh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - -------------- - -- vec_vrlb -- - -------------- - - function vec_vrlb - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_vrlb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - --------------- - -- vec_round -- - --------------- - - function vec_round - (A : vector_float) return vector_float; - - ---------------- - -- vec_rsqrte -- - ---------------- - - function vec_rsqrte - (A : vector_float) return vector_float; - - ------------- - -- vec_sel -- - ------------- - - function vec_sel - (A : vector_float; - B : vector_float; - C : vector_bool_int) return vector_float; - - function vec_sel - (A : vector_float; - B : vector_float; - C : vector_unsigned_int) return vector_float; - - function vec_sel - (A : vector_signed_int; - B : vector_signed_int; - C : vector_bool_int) return vector_signed_int; - - function vec_sel - (A : vector_signed_int; - B : vector_signed_int; - C : vector_unsigned_int) return vector_signed_int; - - function vec_sel - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_bool_int) return vector_unsigned_int; - - function vec_sel - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_unsigned_int) return vector_unsigned_int; - - function vec_sel - (A : vector_bool_int; - B : vector_bool_int; - C : vector_bool_int) return vector_bool_int; - - function vec_sel - (A : vector_bool_int; - B : vector_bool_int; - C : vector_unsigned_int) return vector_bool_int; - - function vec_sel - (A : vector_signed_short; - B : vector_signed_short; - C : vector_bool_short) return vector_signed_short; - - function vec_sel - (A : vector_signed_short; - B : vector_signed_short; - C : vector_unsigned_short) return vector_signed_short; - - function vec_sel - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_bool_short) return vector_unsigned_short; - - function vec_sel - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_unsigned_short; - - function vec_sel - (A : vector_bool_short; - B : vector_bool_short; - C : vector_bool_short) return vector_bool_short; - - function vec_sel - (A : vector_bool_short; - B : vector_bool_short; - C : vector_unsigned_short) return vector_bool_short; - - function vec_sel - (A : vector_signed_char; - B : vector_signed_char; - C : vector_bool_char) return vector_signed_char; - - function vec_sel - (A : vector_signed_char; - B : vector_signed_char; - C : vector_unsigned_char) return vector_signed_char; - - function vec_sel - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_bool_char) return vector_unsigned_char; - - function vec_sel - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_char) return vector_unsigned_char; - - function vec_sel - (A : vector_bool_char; - B : vector_bool_char; - C : vector_bool_char) return vector_bool_char; - - function vec_sel - (A : vector_bool_char; - B : vector_bool_char; - C : vector_unsigned_char) return vector_bool_char; - - ------------ - -- vec_sl -- - ------------ - - function vec_sl - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_sl - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_sl - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_sl - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_sl - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_sl - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_vslw -- - -------------- - - function vec_vslw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_vslw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_vslh -- - -------------- - - function vec_vslh - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_vslh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - -------------- - -- vec_vslb -- - -------------- - - function vec_vslb - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_vslb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ------------- - -- vec_sld -- - ------------- - - function vec_sld - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : c_int) return vector_unsigned_int; - - function vec_sld - (A : vector_bool_int; - B : vector_bool_int; - C : c_int) return vector_bool_int; - - function vec_sld - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : c_int) return vector_unsigned_short; - - function vec_sld - (A : vector_bool_short; - B : vector_bool_short; - C : c_int) return vector_bool_short; - - function vec_sld - (A : vector_pixel; - B : vector_pixel; - C : c_int) return vector_pixel; - - function vec_sld - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : c_int) return vector_unsigned_char; - - function vec_sld - (A : vector_bool_char; - B : vector_bool_char; - C : c_int) return vector_bool_char; - pragma Inline_Always (vec_sld); - pragma Convention (Intrinsic, vec_sld); - - function vec_sld - (A : vector_float; - B : vector_float; - C : c_int) return vector_float - renames Low_Level_Vectors.vsldoi_4sf; - - function vec_sld - (A : vector_signed_int; - B : vector_signed_int; - C : c_int) return vector_signed_int - renames Low_Level_Vectors.vsldoi_4si; - - function vec_sld - (A : vector_signed_short; - B : vector_signed_short; - C : c_int) return vector_signed_short - renames Low_Level_Vectors.vsldoi_8hi; - - function vec_sld - (A : vector_signed_char; - B : vector_signed_char; - C : c_int) return vector_signed_char - renames Low_Level_Vectors.vsldoi_16qi; - - ------------- - -- vec_sll -- - ------------- - - function vec_sll - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_sll - (A : vector_signed_int; - B : vector_unsigned_short) return vector_signed_int; - - function vec_sll - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int; - - function vec_sll - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_sll - (A : vector_unsigned_int; - B : vector_unsigned_short) return vector_unsigned_int; - - function vec_sll - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int; - - function vec_sll - (A : vector_bool_int; - B : vector_unsigned_int) return vector_bool_int; - - function vec_sll - (A : vector_bool_int; - B : vector_unsigned_short) return vector_bool_int; - - function vec_sll - (A : vector_bool_int; - B : vector_unsigned_char) return vector_bool_int; - - function vec_sll - (A : vector_signed_short; - B : vector_unsigned_int) return vector_signed_short; - - function vec_sll - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_sll - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short; - - function vec_sll - (A : vector_unsigned_short; - B : vector_unsigned_int) return vector_unsigned_short; - - function vec_sll - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_sll - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short; - - function vec_sll - (A : vector_bool_short; - B : vector_unsigned_int) return vector_bool_short; - - function vec_sll - (A : vector_bool_short; - B : vector_unsigned_short) return vector_bool_short; - - function vec_sll - (A : vector_bool_short; - B : vector_unsigned_char) return vector_bool_short; - - function vec_sll - (A : vector_pixel; - B : vector_unsigned_int) return vector_pixel; - - function vec_sll - (A : vector_pixel; - B : vector_unsigned_short) return vector_pixel; - - function vec_sll - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel; - - function vec_sll - (A : vector_signed_char; - B : vector_unsigned_int) return vector_signed_char; - - function vec_sll - (A : vector_signed_char; - B : vector_unsigned_short) return vector_signed_char; - - function vec_sll - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_sll - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_char; - - function vec_sll - (A : vector_unsigned_char; - B : vector_unsigned_short) return vector_unsigned_char; - - function vec_sll - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_sll - (A : vector_bool_char; - B : vector_unsigned_int) return vector_bool_char; - - function vec_sll - (A : vector_bool_char; - B : vector_unsigned_short) return vector_bool_char; - - function vec_sll - (A : vector_bool_char; - B : vector_unsigned_char) return vector_bool_char; - - ------------- - -- vec_slo -- - ------------- - - function vec_slo - (A : vector_float; - B : vector_signed_char) return vector_float; - - function vec_slo - (A : vector_float; - B : vector_unsigned_char) return vector_float; - - function vec_slo - (A : vector_signed_int; - B : vector_signed_char) return vector_signed_int; - - function vec_slo - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int; - - function vec_slo - (A : vector_unsigned_int; - B : vector_signed_char) return vector_unsigned_int; - - function vec_slo - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int; - - function vec_slo - (A : vector_signed_short; - B : vector_signed_char) return vector_signed_short; - - function vec_slo - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short; - - function vec_slo - (A : vector_unsigned_short; - B : vector_signed_char) return vector_unsigned_short; - - function vec_slo - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short; - - function vec_slo - (A : vector_pixel; - B : vector_signed_char) return vector_pixel; - - function vec_slo - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel; - - function vec_slo - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_slo - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_slo - (A : vector_unsigned_char; - B : vector_signed_char) return vector_unsigned_char; - - function vec_slo - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ---------------- - -- vec_vspltw -- - ---------------- - - function vec_vspltw - (A : vector_float; - B : c_int) return vector_float; - - function vec_vspltw - (A : vector_unsigned_int; - B : c_int) return vector_unsigned_int; - - function vec_vspltw - (A : vector_bool_int; - B : c_int) return vector_bool_int; - pragma Inline_Always (vec_vspltw); - pragma Convention (Intrinsic, vec_vspltw); - - function vec_vspltw - (A : vector_signed_int; - B : c_int) return vector_signed_int - renames Low_Level_Vectors.vspltw; - - ---------------- - -- vec_vsplth -- - ---------------- - - function vec_vsplth - (A : vector_bool_short; - B : c_int) return vector_bool_short; - - function vec_vsplth - (A : vector_unsigned_short; - B : c_int) return vector_unsigned_short; - - function vec_vsplth - (A : vector_pixel; - B : c_int) return vector_pixel; - pragma Inline_Always (vec_vsplth); - pragma Convention (Intrinsic, vec_vsplth); - - function vec_vsplth - (A : vector_signed_short; - B : c_int) return vector_signed_short - renames Low_Level_Vectors.vsplth; - - ---------------- - -- vec_vspltb -- - ---------------- - - function vec_vspltb - (A : vector_unsigned_char; - B : c_int) return vector_unsigned_char; - - function vec_vspltb - (A : vector_bool_char; - B : c_int) return vector_bool_char; - pragma Inline_Always (vec_vspltb); - pragma Convention (Intrinsic, vec_vspltb); - - function vec_vspltb - (A : vector_signed_char; - B : c_int) return vector_signed_char - renames Low_Level_Vectors.vspltb; - - ------------------ - -- vec_vspltisb -- - ------------------ - - function vec_vspltisb - (A : c_int) return vector_signed_char - renames Low_Level_Vectors.vspltisb; - - ------------------ - -- vec_vspltish -- - ------------------ - - function vec_vspltish - (A : c_int) return vector_signed_short - renames Low_Level_Vectors.vspltish; - - ------------------ - -- vec_vspltisw -- - ------------------ - - function vec_vspltisw - (A : c_int) return vector_signed_int - renames Low_Level_Vectors.vspltisw; - - ------------ - -- vec_sr -- - ------------ - - function vec_sr - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_sr - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_sr - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_sr - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_sr - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_sr - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_vsrw -- - -------------- - - function vec_vsrw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_vsrw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_vsrh -- - -------------- - - function vec_vsrh - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_vsrh - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - -------------- - -- vec_vsrb -- - -------------- - - function vec_vsrb - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_vsrb - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ------------- - -- vec_sra -- - ------------- - - function vec_sra - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_sra - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_sra - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_sra - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_sra - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_sra - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - --------------- - -- vec_vsraw -- - --------------- - - function vec_vsraw - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_vsraw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vsrah - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_vsrah - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vsrab - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_vsrab - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - ------------- - -- vec_srl -- - ------------- - - function vec_srl - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int; - - function vec_srl - (A : vector_signed_int; - B : vector_unsigned_short) return vector_signed_int; - - function vec_srl - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int; - - function vec_srl - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_srl - (A : vector_unsigned_int; - B : vector_unsigned_short) return vector_unsigned_int; - - function vec_srl - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int; - - function vec_srl - (A : vector_bool_int; - B : vector_unsigned_int) return vector_bool_int; - - function vec_srl - (A : vector_bool_int; - B : vector_unsigned_short) return vector_bool_int; - - function vec_srl - (A : vector_bool_int; - B : vector_unsigned_char) return vector_bool_int; - - function vec_srl - (A : vector_signed_short; - B : vector_unsigned_int) return vector_signed_short; - - function vec_srl - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short; - - function vec_srl - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short; - - function vec_srl - (A : vector_unsigned_short; - B : vector_unsigned_int) return vector_unsigned_short; - - function vec_srl - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_srl - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short; - - function vec_srl - (A : vector_bool_short; - B : vector_unsigned_int) return vector_bool_short; - - function vec_srl - (A : vector_bool_short; - B : vector_unsigned_short) return vector_bool_short; - - function vec_srl - (A : vector_bool_short; - B : vector_unsigned_char) return vector_bool_short; - - function vec_srl - (A : vector_pixel; - B : vector_unsigned_int) return vector_pixel; - - function vec_srl - (A : vector_pixel; - B : vector_unsigned_short) return vector_pixel; - - function vec_srl - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel; - - function vec_srl - (A : vector_signed_char; - B : vector_unsigned_int) return vector_signed_char; - - function vec_srl - (A : vector_signed_char; - B : vector_unsigned_short) return vector_signed_char; - - function vec_srl - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_srl - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_char; - - function vec_srl - (A : vector_unsigned_char; - B : vector_unsigned_short) return vector_unsigned_char; - - function vec_srl - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_srl - (A : vector_bool_char; - B : vector_unsigned_int) return vector_bool_char; - - function vec_srl - (A : vector_bool_char; - B : vector_unsigned_short) return vector_bool_char; - - function vec_srl - (A : vector_bool_char; - B : vector_unsigned_char) return vector_bool_char; - - function vec_sro - (A : vector_float; - B : vector_signed_char) return vector_float; - - function vec_sro - (A : vector_float; - B : vector_unsigned_char) return vector_float; - - function vec_sro - (A : vector_signed_int; - B : vector_signed_char) return vector_signed_int; - - function vec_sro - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int; - - function vec_sro - (A : vector_unsigned_int; - B : vector_signed_char) return vector_unsigned_int; - - function vec_sro - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int; - - function vec_sro - (A : vector_signed_short; - B : vector_signed_char) return vector_signed_short; - - function vec_sro - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short; - - function vec_sro - (A : vector_unsigned_short; - B : vector_signed_char) return vector_unsigned_short; - - function vec_sro - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short; - - function vec_sro - (A : vector_pixel; - B : vector_signed_char) return vector_pixel; - - function vec_sro - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel; - - function vec_sro - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_sro - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char; - - function vec_sro - (A : vector_unsigned_char; - B : vector_signed_char) return vector_unsigned_char; - - function vec_sro - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - procedure vec_st - (A : vector_float; - B : c_int; - C : vector_float_ptr); - - procedure vec_st - (A : vector_float; - B : c_int; - C : float_ptr); - - procedure vec_st - (A : vector_signed_int; - B : c_int; - C : vector_signed_int_ptr); - - procedure vec_st - (A : vector_signed_int; - B : c_int; - C : int_ptr); - - procedure vec_st - (A : vector_unsigned_int; - B : c_int; - C : vector_unsigned_int_ptr); - - procedure vec_st - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr); - - procedure vec_st - (A : vector_bool_int; - B : c_int; - C : vector_bool_int_ptr); - - procedure vec_st - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr); - - procedure vec_st - (A : vector_bool_int; - B : c_int; - C : int_ptr); - - procedure vec_st - (A : vector_signed_short; - B : c_int; - C : vector_signed_short_ptr); - - procedure vec_st - (A : vector_signed_short; - B : c_int; - C : short_ptr); - - procedure vec_st - (A : vector_unsigned_short; - B : c_int; - C : vector_unsigned_short_ptr); - - procedure vec_st - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_st - (A : vector_bool_short; - B : c_int; - C : vector_bool_short_ptr); - - procedure vec_st - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_st - (A : vector_pixel; - B : c_int; - C : vector_pixel_ptr); - - procedure vec_st - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_st - (A : vector_pixel; - B : c_int; - C : short_ptr); - - procedure vec_st - (A : vector_bool_short; - B : c_int; - C : short_ptr); - - procedure vec_st - (A : vector_signed_char; - B : c_int; - C : vector_signed_char_ptr); - - procedure vec_st - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr); - - procedure vec_st - (A : vector_unsigned_char; - B : c_int; - C : vector_unsigned_char_ptr); - - procedure vec_st - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_st - (A : vector_bool_char; - B : c_int; - C : vector_bool_char_ptr); - - procedure vec_st - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_st - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr); - - ------------- - -- vec_ste -- - ------------- - - procedure vec_ste - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr); - - procedure vec_ste - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_ste - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr); - - procedure vec_ste - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_ste - (A : vector_signed_short; - B : c_int; - C : short_ptr); - - procedure vec_ste - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_ste - (A : vector_bool_short; - B : c_int; - C : short_ptr); - - procedure vec_ste - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_ste - (A : vector_pixel; - B : c_int; - C : short_ptr); - - procedure vec_ste - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_ste - (A : vector_float; - B : c_int; - C : float_ptr); - - procedure vec_ste - (A : vector_signed_int; - B : c_int; - C : int_ptr); - - procedure vec_ste - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr); - - procedure vec_ste - (A : vector_bool_int; - B : c_int; - C : int_ptr); - - procedure vec_ste - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr); - - ---------------- - -- vec_stvewx -- - ---------------- - - procedure vec_stvewx - (A : vector_float; - B : c_int; - C : float_ptr); - - procedure vec_stvewx - (A : vector_signed_int; - B : c_int; - C : int_ptr); - - procedure vec_stvewx - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr); - - procedure vec_stvewx - (A : vector_bool_int; - B : c_int; - C : int_ptr); - - procedure vec_stvewx - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr); - - procedure vec_stvehx - (A : vector_signed_short; - B : c_int; - C : short_ptr); - - procedure vec_stvehx - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_stvehx - (A : vector_bool_short; - B : c_int; - C : short_ptr); - - procedure vec_stvehx - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_stvehx - (A : vector_pixel; - B : c_int; - C : short_ptr); - - procedure vec_stvehx - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_stvebx - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr); - - procedure vec_stvebx - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_stvebx - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr); - - procedure vec_stvebx - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_stl - (A : vector_float; - B : c_int; - C : vector_float_ptr); - - procedure vec_stl - (A : vector_float; - B : c_int; - C : float_ptr); - - procedure vec_stl - (A : vector_signed_int; - B : c_int; - C : vector_signed_int_ptr); - - procedure vec_stl - (A : vector_signed_int; - B : c_int; - C : int_ptr); - - procedure vec_stl - (A : vector_unsigned_int; - B : c_int; - C : vector_unsigned_int_ptr); - - procedure vec_stl - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr); - - procedure vec_stl - (A : vector_bool_int; - B : c_int; - C : vector_bool_int_ptr); - - procedure vec_stl - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr); - - procedure vec_stl - (A : vector_bool_int; - B : c_int; - C : int_ptr); - - procedure vec_stl - (A : vector_signed_short; - B : c_int; - C : vector_signed_short_ptr); - - procedure vec_stl - (A : vector_signed_short; - B : c_int; - C : short_ptr); - - procedure vec_stl - (A : vector_unsigned_short; - B : c_int; - C : vector_unsigned_short_ptr); - - procedure vec_stl - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_stl - (A : vector_bool_short; - B : c_int; - C : vector_bool_short_ptr); - - procedure vec_stl - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_stl - (A : vector_bool_short; - B : c_int; - C : short_ptr); - - procedure vec_stl - (A : vector_pixel; - B : c_int; - C : vector_pixel_ptr); - - procedure vec_stl - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr); - - procedure vec_stl - (A : vector_pixel; - B : c_int; - C : short_ptr); - - procedure vec_stl - (A : vector_signed_char; - B : c_int; - C : vector_signed_char_ptr); - - procedure vec_stl - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr); - - procedure vec_stl - (A : vector_unsigned_char; - B : c_int; - C : vector_unsigned_char_ptr); - - procedure vec_stl - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_stl - (A : vector_bool_char; - B : c_int; - C : vector_bool_char_ptr); - - procedure vec_stl - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr); - - procedure vec_stl - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr); - - ------------- - -- vec_sub -- - ------------- - - function vec_sub - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_sub - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_sub - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_sub - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_sub - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_sub - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_sub - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_sub - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_sub - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_sub - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_sub - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_sub - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_sub - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_sub - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_sub - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_sub - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_sub - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_sub - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_sub - (A : vector_float; - B : vector_float) return vector_float; - - ---------------- - -- vec_vsubfp -- - ---------------- - - function vec_vsubfp - (A : vector_float; - B : vector_float) return vector_float; - - ----------------- - -- vec_vsubuwm -- - ----------------- - - function vec_vsubuwm - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vsubuwm - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_vsubuwm - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vsubuwm - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vsubuwm - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_vsubuwm - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ----------------- - -- vec_vsubuhm -- - ----------------- - - function vec_vsubuhm - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vsubuhm - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_vsubuhm - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vsubuhm - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vsubuhm - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_vsubuhm - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - ----------------- - -- vec_vsububm -- - ----------------- - - function vec_vsububm - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vsububm - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_vsububm - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vsububm - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_vsububm - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_vsububm - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - -------------- - -- vec_subc -- - -------------- - - function vec_subc - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - -------------- - -- vec_subs -- - -------------- - - function vec_subs - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_subs - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_subs - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_subs - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_subs - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_subs - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_subs - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_subs - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_subs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_subs - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_subs - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_subs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_subs - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_subs - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_subs - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_subs - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_subs - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_subs - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ----------------- - -- vec_vsubsws -- - ----------------- - - function vec_vsubsws - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_vsubsws - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_vsubsws - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - ----------------- - -- vec_vsubuws -- - ----------------- - - function vec_vsubuws - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_vsubuws - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_vsubuws - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - ----------------- - -- vec_vsubshs -- - ----------------- - - function vec_vsubshs - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_vsubshs - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_vsubshs - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - ----------------- - -- vec_vsubuhs -- - ----------------- - - function vec_vsubuhs - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_vsubuhs - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_vsubuhs - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - ----------------- - -- vec_vsubsbs -- - ----------------- - - function vec_vsubsbs - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_vsubsbs - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_vsubsbs - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - ----------------- - -- vec_vsububs -- - ----------------- - - function vec_vsububs - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_vsububs - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_vsububs - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - --------------- - -- vec_sum4s -- - --------------- - - function vec_sum4s - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_sum4s - (A : vector_signed_char; - B : vector_signed_int) return vector_signed_int; - - function vec_sum4s - (A : vector_signed_short; - B : vector_signed_int) return vector_signed_int; - - ------------------ - -- vec_vsum4shs -- - ------------------ - - function vec_vsum4shs - (A : vector_signed_short; - B : vector_signed_int) return vector_signed_int; - - ------------------ - -- vec_vsum4sbs -- - ------------------ - - function vec_vsum4sbs - (A : vector_signed_char; - B : vector_signed_int) return vector_signed_int; - - ------------------ - -- vec_vsum4ubs -- - ------------------ - - function vec_vsum4ubs - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_int; - - --------------- - -- vec_sum2s -- - --------------- - - function vec_sum2s - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - -------------- - -- vec_sums -- - -------------- - - function vec_sums - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_trunc - (A : vector_float) return vector_float; - - function vec_unpackh - (A : vector_signed_char) return vector_signed_short; - - function vec_unpackh - (A : vector_bool_char) return vector_bool_short; - - function vec_unpackh - (A : vector_signed_short) return vector_signed_int; - - function vec_unpackh - (A : vector_bool_short) return vector_bool_int; - - function vec_unpackh - (A : vector_pixel) return vector_unsigned_int; - - function vec_vupkhsh - (A : vector_bool_short) return vector_bool_int; - - function vec_vupkhsh - (A : vector_signed_short) return vector_signed_int; - - function vec_vupkhpx - (A : vector_pixel) return vector_unsigned_int; - - function vec_vupkhsb - (A : vector_bool_char) return vector_bool_short; - - function vec_vupkhsb - (A : vector_signed_char) return vector_signed_short; - - function vec_unpackl - (A : vector_signed_char) return vector_signed_short; - - function vec_unpackl - (A : vector_bool_char) return vector_bool_short; - - function vec_unpackl - (A : vector_pixel) return vector_unsigned_int; - - function vec_unpackl - (A : vector_signed_short) return vector_signed_int; - - function vec_unpackl - (A : vector_bool_short) return vector_bool_int; - - function vec_vupklpx - (A : vector_pixel) return vector_unsigned_int; - - ----------------- - -- vec_vupklsh -- - ----------------- - - function vec_vupklsh - (A : vector_bool_short) return vector_bool_int; - - function vec_vupklsh - (A : vector_signed_short) return vector_signed_int; - - ----------------- - -- vec_vupklsb -- - ----------------- - - function vec_vupklsb - (A : vector_bool_char) return vector_bool_short; - - function vec_vupklsb - (A : vector_signed_char) return vector_signed_short; - - ------------- - -- vec_xor -- - ------------- - - function vec_xor - (A : vector_float; - B : vector_float) return vector_float; - - function vec_xor - (A : vector_float; - B : vector_bool_int) return vector_float; - - function vec_xor - (A : vector_bool_int; - B : vector_float) return vector_float; - - function vec_xor - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int; - - function vec_xor - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int; - - function vec_xor - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int; - - function vec_xor - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int; - - function vec_xor - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_xor - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int; - - function vec_xor - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int; - - function vec_xor - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short; - - function vec_xor - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short; - - function vec_xor - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short; - - function vec_xor - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short; - - function vec_xor - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_xor - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short; - - function vec_xor - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short; - - function vec_xor - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char; - - function vec_xor - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char; - - function vec_xor - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char; - - function vec_xor - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char; - - function vec_xor - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char; - - function vec_xor - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char; - - function vec_xor - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char; - - -- vec_all_eq -- - - function vec_all_eq - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_all_eq - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_all_eq - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_all_eq - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_all_eq - (A : vector_bool_char; - B : vector_bool_char) return c_int; - - function vec_all_eq - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_all_eq - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_all_eq - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_all_eq - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_all_eq - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_all_eq - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_all_eq - (A : vector_bool_short; - B : vector_bool_short) return c_int; - - function vec_all_eq - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_all_eq - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_all_eq - (A : vector_pixel; - B : vector_pixel) return c_int; - - function vec_all_eq - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_all_eq - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_all_eq - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_all_eq - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_all_eq - (A : vector_bool_int; - B : vector_bool_int) return c_int; - - function vec_all_eq - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_all_eq - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_all_eq - (A : vector_float; - B : vector_float) return c_int; - - ---------------- - -- vec_all_ge -- - ---------------- - - function vec_all_ge - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_all_ge - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_all_ge - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_all_ge - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_all_ge - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_all_ge - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_all_ge - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_all_ge - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_all_ge - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_all_ge - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_all_ge - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_all_ge - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_all_ge - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_all_ge - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_all_ge - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_all_ge - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_all_ge - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_all_ge - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_all_ge - (A : vector_float; - B : vector_float) return c_int; - - ---------------- - -- vec_all_gt -- - ---------------- - - function vec_all_gt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_all_gt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_all_gt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_all_gt - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_all_gt - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_all_gt - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_all_gt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_all_gt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_all_gt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_all_gt - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_all_gt - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_all_gt - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_all_gt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_all_gt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_all_gt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_all_gt - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_all_gt - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_all_gt - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_all_gt - (A : vector_float; - B : vector_float) return c_int; - - ---------------- - -- vec_all_in -- - ---------------- - - function vec_all_in - (A : vector_float; - B : vector_float) return c_int; - - ---------------- - -- vec_all_le -- - ---------------- - - function vec_all_le - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_all_le - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_all_le - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_all_le - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_all_le - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_all_le - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_all_le - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_all_le - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_all_le - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_all_le - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_all_le - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_all_le - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_all_le - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_all_le - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_all_le - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_all_le - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_all_le - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_all_le - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_all_le - (A : vector_float; - B : vector_float) return c_int; - - ---------------- - -- vec_all_lt -- - ---------------- - - function vec_all_lt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_all_lt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_all_lt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_all_lt - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_all_lt - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_all_lt - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_all_lt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_all_lt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_all_lt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_all_lt - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_all_lt - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_all_lt - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_all_lt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_all_lt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_all_lt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_all_lt - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_all_lt - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_all_lt - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_all_lt - (A : vector_float; - B : vector_float) return c_int; - - ----------------- - -- vec_all_nan -- - ----------------- - - function vec_all_nan - (A : vector_float) return c_int; - - ---------------- - -- vec_all_ne -- - ---------------- - - function vec_all_ne - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_all_ne - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_all_ne - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_all_ne - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_all_ne - (A : vector_bool_char; - B : vector_bool_char) return c_int; - - function vec_all_ne - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_all_ne - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_all_ne - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_all_ne - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_all_ne - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_all_ne - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_all_ne - (A : vector_bool_short; - B : vector_bool_short) return c_int; - - function vec_all_ne - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_all_ne - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_all_ne - (A : vector_pixel; - B : vector_pixel) return c_int; - - function vec_all_ne - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_all_ne - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_all_ne - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_all_ne - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_all_ne - (A : vector_bool_int; - B : vector_bool_int) return c_int; - - function vec_all_ne - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_all_ne - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_all_ne - (A : vector_float; - B : vector_float) return c_int; - - ----------------- - -- vec_all_nge -- - ----------------- - - function vec_all_nge - (A : vector_float; - B : vector_float) return c_int; - - ----------------- - -- vec_all_ngt -- - ----------------- - - function vec_all_ngt - (A : vector_float; - B : vector_float) return c_int; - - ----------------- - -- vec_all_nle -- - ----------------- - - function vec_all_nle - (A : vector_float; - B : vector_float) return c_int; - - ----------------- - -- vec_all_nlt -- - ----------------- - - function vec_all_nlt - (A : vector_float; - B : vector_float) return c_int; - - --------------------- - -- vec_all_numeric -- - --------------------- - - function vec_all_numeric - (A : vector_float) return c_int; - - ---------------- - -- vec_any_eq -- - ---------------- - - function vec_any_eq - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_any_eq - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_any_eq - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_any_eq - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_any_eq - (A : vector_bool_char; - B : vector_bool_char) return c_int; - - function vec_any_eq - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_any_eq - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_any_eq - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_any_eq - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_any_eq - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_any_eq - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_any_eq - (A : vector_bool_short; - B : vector_bool_short) return c_int; - - function vec_any_eq - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_any_eq - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_any_eq - (A : vector_pixel; - B : vector_pixel) return c_int; - - function vec_any_eq - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_any_eq - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_any_eq - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_any_eq - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_any_eq - (A : vector_bool_int; - B : vector_bool_int) return c_int; - - function vec_any_eq - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_any_eq - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_any_eq - (A : vector_float; - B : vector_float) return c_int; - - ---------------- - -- vec_any_ge -- - ---------------- - - function vec_any_ge - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_any_ge - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_any_ge - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_any_ge - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_any_ge - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_any_ge - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_any_ge - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_any_ge - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_any_ge - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_any_ge - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_any_ge - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_any_ge - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_any_ge - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_any_ge - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_any_ge - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_any_ge - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_any_ge - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_any_ge - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_any_ge - (A : vector_float; - B : vector_float) return c_int; - - ---------------- - -- vec_any_gt -- - ---------------- - - function vec_any_gt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_any_gt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_any_gt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_any_gt - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_any_gt - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_any_gt - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_any_gt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_any_gt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_any_gt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_any_gt - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_any_gt - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_any_gt - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_any_gt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_any_gt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_any_gt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_any_gt - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_any_gt - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_any_gt - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_any_gt - (A : vector_float; - B : vector_float) return c_int; - - function vec_any_le - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_any_le - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_any_le - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_any_le - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_any_le - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_any_le - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_any_le - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_any_le - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_any_le - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_any_le - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_any_le - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_any_le - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_any_le - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_any_le - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_any_le - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_any_le - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_any_le - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_any_le - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_any_le - (A : vector_float; - B : vector_float) return c_int; - - function vec_any_lt - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_any_lt - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_any_lt - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_any_lt - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_any_lt - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_any_lt - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_any_lt - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_any_lt - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_any_lt - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_any_lt - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_any_lt - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_any_lt - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_any_lt - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_any_lt - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_any_lt - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_any_lt - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_any_lt - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_any_lt - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_any_lt - (A : vector_float; - B : vector_float) return c_int; - - function vec_any_nan - (A : vector_float) return c_int; - - function vec_any_ne - (A : vector_signed_char; - B : vector_bool_char) return c_int; - - function vec_any_ne - (A : vector_signed_char; - B : vector_signed_char) return c_int; - - function vec_any_ne - (A : vector_unsigned_char; - B : vector_bool_char) return c_int; - - function vec_any_ne - (A : vector_unsigned_char; - B : vector_unsigned_char) return c_int; - - function vec_any_ne - (A : vector_bool_char; - B : vector_bool_char) return c_int; - - function vec_any_ne - (A : vector_bool_char; - B : vector_unsigned_char) return c_int; - - function vec_any_ne - (A : vector_bool_char; - B : vector_signed_char) return c_int; - - function vec_any_ne - (A : vector_signed_short; - B : vector_bool_short) return c_int; - - function vec_any_ne - (A : vector_signed_short; - B : vector_signed_short) return c_int; - - function vec_any_ne - (A : vector_unsigned_short; - B : vector_bool_short) return c_int; - - function vec_any_ne - (A : vector_unsigned_short; - B : vector_unsigned_short) return c_int; - - function vec_any_ne - (A : vector_bool_short; - B : vector_bool_short) return c_int; - - function vec_any_ne - (A : vector_bool_short; - B : vector_unsigned_short) return c_int; - - function vec_any_ne - (A : vector_bool_short; - B : vector_signed_short) return c_int; - - function vec_any_ne - (A : vector_pixel; - B : vector_pixel) return c_int; - - function vec_any_ne - (A : vector_signed_int; - B : vector_bool_int) return c_int; - - function vec_any_ne - (A : vector_signed_int; - B : vector_signed_int) return c_int; - - function vec_any_ne - (A : vector_unsigned_int; - B : vector_bool_int) return c_int; - - function vec_any_ne - (A : vector_unsigned_int; - B : vector_unsigned_int) return c_int; - - function vec_any_ne - (A : vector_bool_int; - B : vector_bool_int) return c_int; - - function vec_any_ne - (A : vector_bool_int; - B : vector_unsigned_int) return c_int; - - function vec_any_ne - (A : vector_bool_int; - B : vector_signed_int) return c_int; - - function vec_any_ne - (A : vector_float; - B : vector_float) return c_int; - - ----------------- - -- vec_any_nge -- - ----------------- - - function vec_any_nge - (A : vector_float; - B : vector_float) return c_int; - - function vec_any_ngt - (A : vector_float; - B : vector_float) return c_int; - - function vec_any_nle - (A : vector_float; - B : vector_float) return c_int; - - function vec_any_nlt - (A : vector_float; - B : vector_float) return c_int; - - function vec_any_numeric - (A : vector_float) return c_int; - - function vec_any_out - (A : vector_float; - B : vector_float) return c_int; - - function vec_splat_s8 - (A : c_int) return vector_signed_char - renames vec_vspltisb; - - ------------------- - -- vec_splat_s16 -- - ------------------- - - function vec_splat_s16 - (A : c_int) return vector_signed_short - renames vec_vspltish; - - ------------------- - -- vec_splat_s32 -- - ------------------- - - function vec_splat_s32 - (A : c_int) return vector_signed_int - renames vec_vspltisw; - - function vec_splat - (A : vector_signed_char; - B : c_int) return vector_signed_char - renames vec_vspltb; - - function vec_splat - (A : vector_unsigned_char; - B : c_int) return vector_unsigned_char - renames vec_vspltb; - - function vec_splat - (A : vector_bool_char; - B : c_int) return vector_bool_char - renames vec_vspltb; - - function vec_splat - (A : vector_signed_short; - B : c_int) return vector_signed_short - renames vec_vsplth; - - function vec_splat - (A : vector_unsigned_short; - B : c_int) return vector_unsigned_short - renames vec_vsplth; - - function vec_splat - (A : vector_bool_short; - B : c_int) return vector_bool_short - renames vec_vsplth; - - function vec_splat - (A : vector_pixel; - B : c_int) return vector_pixel - renames vec_vsplth; - - function vec_splat - (A : vector_float; - B : c_int) return vector_float - renames vec_vspltw; - - function vec_splat - (A : vector_signed_int; - B : c_int) return vector_signed_int - renames vec_vspltw; - - function vec_splat - (A : vector_unsigned_int; - B : c_int) return vector_unsigned_int - renames vec_vspltw; - - function vec_splat - (A : vector_bool_int; - B : c_int) return vector_bool_int - renames vec_vspltw; - - ------------------ - -- vec_splat_u8 -- - ------------------ - - function vec_splat_u8 - (A : c_int) return vector_unsigned_char; - pragma Inline_Always (vec_splat_u8); - pragma Convention (Intrinsic, vec_splat_u8); - - ------------------- - -- vec_splat_u16 -- - ------------------- - - function vec_splat_u16 - (A : c_int) return vector_unsigned_short; - pragma Inline_Always (vec_splat_u16); - pragma Convention (Intrinsic, vec_splat_u16); - - ------------------- - -- vec_splat_u32 -- - ------------------- - - function vec_splat_u32 - (A : c_int) return vector_unsigned_int; - pragma Inline_Always (vec_splat_u32); - pragma Convention (Intrinsic, vec_splat_u32); - - ------------- - -- vec_ctf -- - ------------- - - function vec_ctf - (A : vector_unsigned_int; - B : c_int) return vector_float - renames vec_vcfux; - - function vec_ctf - (A : vector_signed_int; - B : c_int) return vector_float - renames vec_vcfsx; - - ------------- - -- vec_cts -- - ------------- - - function vec_cts - (A : vector_float; - B : c_int) return vector_signed_int - renames vec_vctsxs; - - function vec_ctu - (A : vector_float; - B : c_int) return vector_unsigned_int - renames vec_vctuxs; - - function vec_vaddcuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_addc; - - function vec_vand - (A : vector_float; - B : vector_float) return vector_float - renames vec_and; - - function vec_vand - (A : vector_float; - B : vector_bool_int) return vector_float - renames vec_and; - - function vec_vand - (A : vector_bool_int; - B : vector_float) return vector_float - renames vec_and; - - function vec_vand - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - renames vec_and; - - function vec_vand - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - renames vec_and; - - function vec_vand - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - renames vec_and; - - function vec_vand - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - renames vec_and; - - function vec_vand - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_and; - - function vec_vand - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - renames vec_and; - - function vec_vand - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_and; - - function vec_vand - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - renames vec_and; - - function vec_vand - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - renames vec_and; - - function vec_vand - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - renames vec_and; - - function vec_vand - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - renames vec_and; - - function vec_vand - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_and; - - function vec_vand - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - renames vec_and; - - function vec_vand - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_and; - - function vec_vand - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - renames vec_and; - - function vec_vand - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - renames vec_and; - - function vec_vand - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - renames vec_and; - - function vec_vand - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - renames vec_and; - - function vec_vand - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_and; - - function vec_vand - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - renames vec_and; - - function vec_vand - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_and; - - --------------- - -- vec_vandc -- - --------------- - - function vec_vandc - (A : vector_float; - B : vector_float) return vector_float - renames vec_andc; - - function vec_vandc - (A : vector_float; - B : vector_bool_int) return vector_float - renames vec_andc; - - function vec_vandc - (A : vector_bool_int; - B : vector_float) return vector_float - renames vec_andc; - - function vec_vandc - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - renames vec_andc; - - function vec_vandc - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - renames vec_andc; - - function vec_vandc - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - renames vec_andc; - - function vec_vandc - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - renames vec_andc; - - function vec_vandc - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_andc; - - function vec_vandc - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - renames vec_andc; - - function vec_vandc - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_andc; - - function vec_vandc - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - renames vec_andc; - - function vec_vandc - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - renames vec_andc; - - function vec_vandc - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - renames vec_andc; - - function vec_vandc - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - renames vec_andc; - - function vec_vandc - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_andc; - - function vec_vandc - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - renames vec_andc; - - function vec_vandc - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_andc; - - function vec_vandc - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - renames vec_andc; - - function vec_vandc - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - renames vec_andc; - - function vec_vandc - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - renames vec_andc; - - function vec_vandc - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - renames vec_andc; - - function vec_vandc - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_andc; - - function vec_vandc - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - renames vec_andc; - - function vec_vandc - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_andc; - - --------------- - -- vec_vrfip -- - --------------- - - function vec_vrfip - (A : vector_float) return vector_float - renames vec_ceil; - - ----------------- - -- vec_vcmpbfp -- - ----------------- - - function vec_vcmpbfp - (A : vector_float; - B : vector_float) return vector_signed_int - renames vec_cmpb; - - function vec_vcmpgefp - (A : vector_float; - B : vector_float) return vector_bool_int - renames vec_cmpge; - - function vec_vexptefp - (A : vector_float) return vector_float - renames vec_expte; - - --------------- - -- vec_vrfim -- - --------------- - - function vec_vrfim - (A : vector_float) return vector_float - renames vec_floor; - - function vec_lvx - (A : c_long; - B : const_vector_float_ptr) return vector_float - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_float_ptr) return vector_float - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_bool_int_ptr) return vector_bool_int - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_signed_int_ptr) return vector_signed_int - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_int_ptr) return vector_signed_int - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_long_ptr) return vector_signed_int - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_unsigned_int_ptr) return vector_unsigned_int - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_bool_short_ptr) return vector_bool_short - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_pixel_ptr) return vector_pixel - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_signed_short_ptr) return vector_signed_short - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_short_ptr) return vector_signed_short - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_unsigned_short_ptr) return vector_unsigned_short - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_bool_char_ptr) return vector_bool_char - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_signed_char_ptr) return vector_signed_char - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_vector_unsigned_char_ptr) return vector_unsigned_char - renames vec_ld; - - function vec_lvx - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char - renames vec_ld; - - function vec_lvxl - (A : c_long; - B : const_vector_float_ptr) return vector_float - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_float_ptr) return vector_float - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_bool_int_ptr) return vector_bool_int - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_signed_int_ptr) return vector_signed_int - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_int_ptr) return vector_signed_int - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_long_ptr) return vector_signed_int - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_unsigned_int_ptr) return vector_unsigned_int - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_unsigned_int_ptr) return vector_unsigned_int - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_unsigned_long_ptr) return vector_unsigned_int - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_bool_short_ptr) return vector_bool_short - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_pixel_ptr) return vector_pixel - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_signed_short_ptr) return vector_signed_short - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_short_ptr) return vector_signed_short - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_unsigned_short_ptr) return vector_unsigned_short - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_unsigned_short_ptr) return vector_unsigned_short - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_bool_char_ptr) return vector_bool_char - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_signed_char_ptr) return vector_signed_char - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_signed_char_ptr) return vector_signed_char - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_vector_unsigned_char_ptr) return vector_unsigned_char - renames vec_ldl; - - function vec_lvxl - (A : c_long; - B : const_unsigned_char_ptr) return vector_unsigned_char - renames vec_ldl; - - function vec_vlogefp - (A : vector_float) return vector_float - renames vec_loge; - - ----------------- - -- vec_vmaddfp -- - ----------------- - - function vec_vmaddfp - (A : vector_float; - B : vector_float; - C : vector_float) return vector_float - renames vec_madd; - - ------------------- - -- vec_vmhaddshs -- - ------------------- - - function vec_vmhaddshs - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - renames vec_madds; - - ------------------- - -- vec_vmladduhm -- - ------------------- - - function vec_vmladduhm - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - renames vec_mladd; - - function vec_vmladduhm - (A : vector_signed_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_signed_short - renames vec_mladd; - - function vec_vmladduhm - (A : vector_unsigned_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - renames vec_mladd; - - function vec_vmladduhm - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_unsigned_short - renames vec_mladd; - - -------------------- - -- vec_vmhraddshs -- - -------------------- - - function vec_vmhraddshs - (A : vector_signed_short; - B : vector_signed_short; - C : vector_signed_short) return vector_signed_short - renames vec_mradds; - - ------------------ - -- vec_vnmsubfp -- - ------------------ - - function vec_vnmsubfp - (A : vector_float; - B : vector_float; - C : vector_float) return vector_float - renames vec_nmsub; - - -------------- - -- vec_vnor -- - -------------- - - function vec_vnor - (A : vector_float; - B : vector_float) return vector_float - renames vec_nor; - - function vec_vnor - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - renames vec_nor; - - function vec_vnor - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_nor; - - function vec_vnor - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - renames vec_nor; - - function vec_vnor - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - renames vec_nor; - - function vec_vnor - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_nor; - - function vec_vnor - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - renames vec_nor; - - function vec_vnor - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - renames vec_nor; - - function vec_vnor - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_nor; - - function vec_vnor - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - renames vec_nor; - - ------------- - -- vec_vor -- - ------------- - - function vec_vor - (A : vector_float; - B : vector_float) return vector_float - renames vec_or; - - function vec_vor - (A : vector_float; - B : vector_bool_int) return vector_float - renames vec_or; - - function vec_vor - (A : vector_bool_int; - B : vector_float) return vector_float - renames vec_or; - - function vec_vor - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - renames vec_or; - - function vec_vor - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - renames vec_or; - - function vec_vor - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - renames vec_or; - - function vec_vor - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - renames vec_or; - - function vec_vor - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_or; - - function vec_vor - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - renames vec_or; - - function vec_vor - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_or; - - function vec_vor - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - renames vec_or; - - function vec_vor - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - renames vec_or; - - function vec_vor - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - renames vec_or; - - function vec_vor - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - renames vec_or; - - function vec_vor - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_or; - - function vec_vor - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - renames vec_or; - - function vec_vor - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_or; - - function vec_vor - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - renames vec_or; - - function vec_vor - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - renames vec_or; - - function vec_vor - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - renames vec_or; - - function vec_vor - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - renames vec_or; - - function vec_vor - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_or; - - function vec_vor - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - renames vec_or; - - function vec_vor - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_or; - - --------------- - -- vec_vpkpx -- - --------------- - - function vec_vpkpx - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_pixel - renames vec_packpx; - - --------------- - -- vec_vperm -- - --------------- - - function vec_vperm - (A : vector_float; - B : vector_float; - C : vector_unsigned_char) return vector_float - renames vec_perm; - - function vec_vperm - (A : vector_signed_int; - B : vector_signed_int; - C : vector_unsigned_char) return vector_signed_int - renames vec_perm; - - function vec_vperm - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_unsigned_char) return vector_unsigned_int - renames vec_perm; - - function vec_vperm - (A : vector_bool_int; - B : vector_bool_int; - C : vector_unsigned_char) return vector_bool_int - renames vec_perm; - - function vec_vperm - (A : vector_signed_short; - B : vector_signed_short; - C : vector_unsigned_char) return vector_signed_short - renames vec_perm; - - function vec_vperm - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_char) return vector_unsigned_short - renames vec_perm; - - function vec_vperm - (A : vector_bool_short; - B : vector_bool_short; - C : vector_unsigned_char) return vector_bool_short - renames vec_perm; - - function vec_vperm - (A : vector_pixel; - B : vector_pixel; - C : vector_unsigned_char) return vector_pixel - renames vec_perm; - - function vec_vperm - (A : vector_signed_char; - B : vector_signed_char; - C : vector_unsigned_char) return vector_signed_char - renames vec_perm; - - function vec_vperm - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_char) return vector_unsigned_char - renames vec_perm; - - function vec_vperm - (A : vector_bool_char; - B : vector_bool_char; - C : vector_unsigned_char) return vector_bool_char - renames vec_perm; - - --------------- - -- vec_vrefp -- - --------------- - - function vec_vrefp - (A : vector_float) return vector_float - renames vec_re; - - --------------- - -- vec_vrfin -- - --------------- - - function vec_vrfin - (A : vector_float) return vector_float - renames vec_round; - - function vec_vrsqrtefp - (A : vector_float) return vector_float - renames vec_rsqrte; - - function vec_vsel - (A : vector_float; - B : vector_float; - C : vector_bool_int) return vector_float - renames vec_sel; - - function vec_vsel - (A : vector_float; - B : vector_float; - C : vector_unsigned_int) return vector_float - renames vec_sel; - - function vec_vsel - (A : vector_signed_int; - B : vector_signed_int; - C : vector_bool_int) return vector_signed_int - renames vec_sel; - - function vec_vsel - (A : vector_signed_int; - B : vector_signed_int; - C : vector_unsigned_int) return vector_signed_int - renames vec_sel; - - function vec_vsel - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_bool_int) return vector_unsigned_int - renames vec_sel; - - function vec_vsel - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : vector_unsigned_int) return vector_unsigned_int - renames vec_sel; - - function vec_vsel - (A : vector_bool_int; - B : vector_bool_int; - C : vector_bool_int) return vector_bool_int - renames vec_sel; - - function vec_vsel - (A : vector_bool_int; - B : vector_bool_int; - C : vector_unsigned_int) return vector_bool_int - renames vec_sel; - - function vec_vsel - (A : vector_signed_short; - B : vector_signed_short; - C : vector_bool_short) return vector_signed_short - renames vec_sel; - - function vec_vsel - (A : vector_signed_short; - B : vector_signed_short; - C : vector_unsigned_short) return vector_signed_short - renames vec_sel; - - function vec_vsel - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_bool_short) return vector_unsigned_short - renames vec_sel; - - function vec_vsel - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : vector_unsigned_short) return vector_unsigned_short - renames vec_sel; - - function vec_vsel - (A : vector_bool_short; - B : vector_bool_short; - C : vector_bool_short) return vector_bool_short - renames vec_sel; - - function vec_vsel - (A : vector_bool_short; - B : vector_bool_short; - C : vector_unsigned_short) return vector_bool_short - renames vec_sel; - - function vec_vsel - (A : vector_signed_char; - B : vector_signed_char; - C : vector_bool_char) return vector_signed_char - renames vec_sel; - - function vec_vsel - (A : vector_signed_char; - B : vector_signed_char; - C : vector_unsigned_char) return vector_signed_char - renames vec_sel; - - function vec_vsel - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_bool_char) return vector_unsigned_char - renames vec_sel; - - function vec_vsel - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : vector_unsigned_char) return vector_unsigned_char - renames vec_sel; - - function vec_vsel - (A : vector_bool_char; - B : vector_bool_char; - C : vector_bool_char) return vector_bool_char - renames vec_sel; - - function vec_vsel - (A : vector_bool_char; - B : vector_bool_char; - C : vector_unsigned_char) return vector_bool_char - renames vec_sel; - - ---------------- - -- vec_vsldoi -- - ---------------- - - function vec_vsldoi - (A : vector_float; - B : vector_float; - C : c_int) return vector_float - renames vec_sld; - - function vec_vsldoi - (A : vector_signed_int; - B : vector_signed_int; - C : c_int) return vector_signed_int - renames vec_sld; - - function vec_vsldoi - (A : vector_unsigned_int; - B : vector_unsigned_int; - C : c_int) return vector_unsigned_int - renames vec_sld; - - function vec_vsldoi - (A : vector_bool_int; - B : vector_bool_int; - C : c_int) return vector_bool_int - renames vec_sld; - - function vec_vsldoi - (A : vector_signed_short; - B : vector_signed_short; - C : c_int) return vector_signed_short - renames vec_sld; - - function vec_vsldoi - (A : vector_unsigned_short; - B : vector_unsigned_short; - C : c_int) return vector_unsigned_short - renames vec_sld; - - function vec_vsldoi - (A : vector_bool_short; - B : vector_bool_short; - C : c_int) return vector_bool_short - renames vec_sld; - - function vec_vsldoi - (A : vector_pixel; - B : vector_pixel; - C : c_int) return vector_pixel - renames vec_sld; - - function vec_vsldoi - (A : vector_signed_char; - B : vector_signed_char; - C : c_int) return vector_signed_char - renames vec_sld; - - function vec_vsldoi - (A : vector_unsigned_char; - B : vector_unsigned_char; - C : c_int) return vector_unsigned_char - renames vec_sld; - - function vec_vsldoi - (A : vector_bool_char; - B : vector_bool_char; - C : c_int) return vector_bool_char - renames vec_sld; - - ------------- - -- vec_vsl -- - ------------- - - function vec_vsl - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - renames vec_sll; - - function vec_vsl - (A : vector_signed_int; - B : vector_unsigned_short) return vector_signed_int - renames vec_sll; - - function vec_vsl - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_int; - B : vector_unsigned_short) return vector_unsigned_int - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - renames vec_sll; - - function vec_vsl - (A : vector_bool_int; - B : vector_unsigned_int) return vector_bool_int - renames vec_sll; - - function vec_vsl - (A : vector_bool_int; - B : vector_unsigned_short) return vector_bool_int - renames vec_sll; - - function vec_vsl - (A : vector_bool_int; - B : vector_unsigned_char) return vector_bool_int - renames vec_sll; - - function vec_vsl - (A : vector_signed_short; - B : vector_unsigned_int) return vector_signed_short - renames vec_sll; - - function vec_vsl - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - renames vec_sll; - - function vec_vsl - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_short; - B : vector_unsigned_int) return vector_unsigned_short - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - renames vec_sll; - - function vec_vsl - (A : vector_bool_short; - B : vector_unsigned_int) return vector_bool_short - renames vec_sll; - - function vec_vsl - (A : vector_bool_short; - B : vector_unsigned_short) return vector_bool_short - renames vec_sll; - - function vec_vsl - (A : vector_bool_short; - B : vector_unsigned_char) return vector_bool_short - renames vec_sll; - - function vec_vsl - (A : vector_pixel; - B : vector_unsigned_int) return vector_pixel - renames vec_sll; - - function vec_vsl - (A : vector_pixel; - B : vector_unsigned_short) return vector_pixel - renames vec_sll; - - function vec_vsl - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - renames vec_sll; - - function vec_vsl - (A : vector_signed_char; - B : vector_unsigned_int) return vector_signed_char - renames vec_sll; - - function vec_vsl - (A : vector_signed_char; - B : vector_unsigned_short) return vector_signed_char - renames vec_sll; - - function vec_vsl - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_char - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_char; - B : vector_unsigned_short) return vector_unsigned_char - renames vec_sll; - - function vec_vsl - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_sll; - - function vec_vsl - (A : vector_bool_char; - B : vector_unsigned_int) return vector_bool_char - renames vec_sll; - - function vec_vsl - (A : vector_bool_char; - B : vector_unsigned_short) return vector_bool_char - renames vec_sll; - - function vec_vsl - (A : vector_bool_char; - B : vector_unsigned_char) return vector_bool_char - renames vec_sll; - - -------------- - -- vec_vslo -- - -------------- - - function vec_vslo - (A : vector_float; - B : vector_signed_char) return vector_float - renames vec_slo; - - function vec_vslo - (A : vector_float; - B : vector_unsigned_char) return vector_float - renames vec_slo; - - function vec_vslo - (A : vector_signed_int; - B : vector_signed_char) return vector_signed_int - renames vec_slo; - - function vec_vslo - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - renames vec_slo; - - function vec_vslo - (A : vector_unsigned_int; - B : vector_signed_char) return vector_unsigned_int - renames vec_slo; - - function vec_vslo - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - renames vec_slo; - - function vec_vslo - (A : vector_signed_short; - B : vector_signed_char) return vector_signed_short - renames vec_slo; - - function vec_vslo - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - renames vec_slo; - - function vec_vslo - (A : vector_unsigned_short; - B : vector_signed_char) return vector_unsigned_short - renames vec_slo; - - function vec_vslo - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - renames vec_slo; - - function vec_vslo - (A : vector_pixel; - B : vector_signed_char) return vector_pixel - renames vec_slo; - - function vec_vslo - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - renames vec_slo; - - function vec_vslo - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - renames vec_slo; - - function vec_vslo - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - renames vec_slo; - - function vec_vslo - (A : vector_unsigned_char; - B : vector_signed_char) return vector_unsigned_char - renames vec_slo; - - function vec_vslo - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_slo; - - function vec_vsr - (A : vector_signed_int; - B : vector_unsigned_int) return vector_signed_int - renames vec_srl; - - function vec_vsr - (A : vector_signed_int; - B : vector_unsigned_short) return vector_signed_int - renames vec_srl; - - function vec_vsr - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_int; - B : vector_unsigned_short) return vector_unsigned_int - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - renames vec_srl; - - function vec_vsr - (A : vector_bool_int; - B : vector_unsigned_int) return vector_bool_int - renames vec_srl; - - function vec_vsr - (A : vector_bool_int; - B : vector_unsigned_short) return vector_bool_int - renames vec_srl; - - function vec_vsr - (A : vector_bool_int; - B : vector_unsigned_char) return vector_bool_int - renames vec_srl; - - function vec_vsr - (A : vector_signed_short; - B : vector_unsigned_int) return vector_signed_short - renames vec_srl; - - function vec_vsr - (A : vector_signed_short; - B : vector_unsigned_short) return vector_signed_short - renames vec_srl; - - function vec_vsr - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_short; - B : vector_unsigned_int) return vector_unsigned_short - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - renames vec_srl; - - function vec_vsr - (A : vector_bool_short; - B : vector_unsigned_int) return vector_bool_short - renames vec_srl; - - function vec_vsr - (A : vector_bool_short; - B : vector_unsigned_short) return vector_bool_short - renames vec_srl; - - function vec_vsr - (A : vector_bool_short; - B : vector_unsigned_char) return vector_bool_short - renames vec_srl; - - function vec_vsr - (A : vector_pixel; - B : vector_unsigned_int) return vector_pixel - renames vec_srl; - - function vec_vsr - (A : vector_pixel; - B : vector_unsigned_short) return vector_pixel - renames vec_srl; - - function vec_vsr - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - renames vec_srl; - - function vec_vsr - (A : vector_signed_char; - B : vector_unsigned_int) return vector_signed_char - renames vec_srl; - - function vec_vsr - (A : vector_signed_char; - B : vector_unsigned_short) return vector_signed_char - renames vec_srl; - - function vec_vsr - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_char; - B : vector_unsigned_int) return vector_unsigned_char - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_char; - B : vector_unsigned_short) return vector_unsigned_char - renames vec_srl; - - function vec_vsr - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_srl; - - function vec_vsr - (A : vector_bool_char; - B : vector_unsigned_int) return vector_bool_char - renames vec_srl; - - function vec_vsr - (A : vector_bool_char; - B : vector_unsigned_short) return vector_bool_char - renames vec_srl; - - function vec_vsr - (A : vector_bool_char; - B : vector_unsigned_char) return vector_bool_char - renames vec_srl; - - function vec_vsro - (A : vector_float; - B : vector_signed_char) return vector_float - renames vec_sro; - - function vec_vsro - (A : vector_float; - B : vector_unsigned_char) return vector_float - renames vec_sro; - - function vec_vsro - (A : vector_signed_int; - B : vector_signed_char) return vector_signed_int - renames vec_sro; - - function vec_vsro - (A : vector_signed_int; - B : vector_unsigned_char) return vector_signed_int - renames vec_sro; - - function vec_vsro - (A : vector_unsigned_int; - B : vector_signed_char) return vector_unsigned_int - renames vec_sro; - - function vec_vsro - (A : vector_unsigned_int; - B : vector_unsigned_char) return vector_unsigned_int - renames vec_sro; - - function vec_vsro - (A : vector_signed_short; - B : vector_signed_char) return vector_signed_short - renames vec_sro; - - function vec_vsro - (A : vector_signed_short; - B : vector_unsigned_char) return vector_signed_short - renames vec_sro; - - function vec_vsro - (A : vector_unsigned_short; - B : vector_signed_char) return vector_unsigned_short - renames vec_sro; - - function vec_vsro - (A : vector_unsigned_short; - B : vector_unsigned_char) return vector_unsigned_short - renames vec_sro; - - function vec_vsro - (A : vector_pixel; - B : vector_signed_char) return vector_pixel - renames vec_sro; - - function vec_vsro - (A : vector_pixel; - B : vector_unsigned_char) return vector_pixel - renames vec_sro; - - function vec_vsro - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - renames vec_sro; - - function vec_vsro - (A : vector_signed_char; - B : vector_unsigned_char) return vector_signed_char - renames vec_sro; - - function vec_vsro - (A : vector_unsigned_char; - B : vector_signed_char) return vector_unsigned_char - renames vec_sro; - - function vec_vsro - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_sro; - - -------------- - -- vec_stvx -- - -------------- - - procedure vec_stvx - (A : vector_float; - B : c_int; - C : vector_float_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_float; - B : c_int; - C : float_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_signed_int; - B : c_int; - C : vector_signed_int_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_signed_int; - B : c_int; - C : int_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_unsigned_int; - B : c_int; - C : vector_unsigned_int_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_int; - B : c_int; - C : vector_bool_int_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_int; - B : c_int; - C : int_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_signed_short; - B : c_int; - C : vector_signed_short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_signed_short; - B : c_int; - C : short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_unsigned_short; - B : c_int; - C : vector_unsigned_short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_short; - B : c_int; - C : vector_bool_short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_pixel; - B : c_int; - C : vector_pixel_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_pixel; - B : c_int; - C : short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_short; - B : c_int; - C : short_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_signed_char; - B : c_int; - C : vector_signed_char_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_unsigned_char; - B : c_int; - C : vector_unsigned_char_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_char; - B : c_int; - C : vector_bool_char_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr) - renames vec_st; - - procedure vec_stvx - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr) - renames vec_st; - - --------------- - -- vec_stvxl -- - --------------- - - procedure vec_stvxl - (A : vector_float; - B : c_int; - C : vector_float_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_float; - B : c_int; - C : float_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_signed_int; - B : c_int; - C : vector_signed_int_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_signed_int; - B : c_int; - C : int_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_unsigned_int; - B : c_int; - C : vector_unsigned_int_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_unsigned_int; - B : c_int; - C : unsigned_int_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_int; - B : c_int; - C : vector_bool_int_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_int; - B : c_int; - C : unsigned_int_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_int; - B : c_int; - C : int_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_signed_short; - B : c_int; - C : vector_signed_short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_signed_short; - B : c_int; - C : short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_unsigned_short; - B : c_int; - C : vector_unsigned_short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_unsigned_short; - B : c_int; - C : unsigned_short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_short; - B : c_int; - C : vector_bool_short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_short; - B : c_int; - C : unsigned_short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_short; - B : c_int; - C : short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_pixel; - B : c_int; - C : vector_pixel_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_pixel; - B : c_int; - C : unsigned_short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_pixel; - B : c_int; - C : short_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_signed_char; - B : c_int; - C : vector_signed_char_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_signed_char; - B : c_int; - C : signed_char_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_unsigned_char; - B : c_int; - C : vector_unsigned_char_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_unsigned_char; - B : c_int; - C : unsigned_char_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_char; - B : c_int; - C : vector_bool_char_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_char; - B : c_int; - C : unsigned_char_ptr) - renames vec_stl; - - procedure vec_stvxl - (A : vector_bool_char; - B : c_int; - C : signed_char_ptr) - renames vec_stl; - - function vec_vsubcuw - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_subc; - - ------------------ - -- vec_vsum2sws -- - ------------------ - - function vec_vsum2sws - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - renames vec_sum2s; - - function vec_vsumsws - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - renames vec_sums; - - function vec_vrfiz - (A : vector_float) return vector_float - renames vec_trunc; - - -------------- - -- vec_vxor -- - -------------- - - function vec_vxor - (A : vector_float; - B : vector_float) return vector_float - renames vec_xor; - - function vec_vxor - (A : vector_float; - B : vector_bool_int) return vector_float - renames vec_xor; - - function vec_vxor - (A : vector_bool_int; - B : vector_float) return vector_float - renames vec_xor; - - function vec_vxor - (A : vector_bool_int; - B : vector_bool_int) return vector_bool_int - renames vec_xor; - - function vec_vxor - (A : vector_bool_int; - B : vector_signed_int) return vector_signed_int - renames vec_xor; - - function vec_vxor - (A : vector_signed_int; - B : vector_bool_int) return vector_signed_int - renames vec_xor; - - function vec_vxor - (A : vector_signed_int; - B : vector_signed_int) return vector_signed_int - renames vec_xor; - - function vec_vxor - (A : vector_bool_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_xor; - - function vec_vxor - (A : vector_unsigned_int; - B : vector_bool_int) return vector_unsigned_int - renames vec_xor; - - function vec_vxor - (A : vector_unsigned_int; - B : vector_unsigned_int) return vector_unsigned_int - renames vec_xor; - - function vec_vxor - (A : vector_bool_short; - B : vector_bool_short) return vector_bool_short - renames vec_xor; - - function vec_vxor - (A : vector_bool_short; - B : vector_signed_short) return vector_signed_short - renames vec_xor; - - function vec_vxor - (A : vector_signed_short; - B : vector_bool_short) return vector_signed_short - renames vec_xor; - - function vec_vxor - (A : vector_signed_short; - B : vector_signed_short) return vector_signed_short - renames vec_xor; - - function vec_vxor - (A : vector_bool_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_xor; - - function vec_vxor - (A : vector_unsigned_short; - B : vector_bool_short) return vector_unsigned_short - renames vec_xor; - - function vec_vxor - (A : vector_unsigned_short; - B : vector_unsigned_short) return vector_unsigned_short - renames vec_xor; - - function vec_vxor - (A : vector_bool_char; - B : vector_signed_char) return vector_signed_char - renames vec_xor; - - function vec_vxor - (A : vector_bool_char; - B : vector_bool_char) return vector_bool_char - renames vec_xor; - - function vec_vxor - (A : vector_signed_char; - B : vector_bool_char) return vector_signed_char - renames vec_xor; - - function vec_vxor - (A : vector_signed_char; - B : vector_signed_char) return vector_signed_char - renames vec_xor; - - function vec_vxor - (A : vector_bool_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_xor; - - function vec_vxor - (A : vector_unsigned_char; - B : vector_bool_char) return vector_unsigned_char - renames vec_xor; - - function vec_vxor - (A : vector_unsigned_char; - B : vector_unsigned_char) return vector_unsigned_char - renames vec_xor; - - -------------- - -- vec_step -- - -------------- - - function vec_step (V : vector_unsigned_char) return Integer; - function vec_step (V : vector_signed_char) return Integer; - function vec_step (V : vector_bool_char) return Integer; - - function vec_step (V : vector_unsigned_short) return Integer; - function vec_step (V : vector_signed_short) return Integer; - function vec_step (V : vector_bool_short) return Integer; - - function vec_step (V : vector_unsigned_int) return Integer; - function vec_step (V : vector_signed_int) return Integer; - function vec_step (V : vector_bool_int) return Integer; - - function vec_step (V : vector_float) return Integer; - function vec_step (V : vector_pixel) return Integer; - -private - - pragma Inline_Always (vec_abs); - pragma Inline_Always (vec_abss); - pragma Inline_Always (vec_add); - pragma Inline_Always (vec_vaddfp); - pragma Inline_Always (vec_vadduwm); - pragma Inline_Always (vec_vadduhm); - pragma Inline_Always (vec_vaddubm); - pragma Inline_Always (vec_addc); - pragma Inline_Always (vec_adds); - pragma Inline_Always (vec_vaddsws); - pragma Inline_Always (vec_vadduws); - pragma Inline_Always (vec_vaddshs); - pragma Inline_Always (vec_vadduhs); - pragma Inline_Always (vec_vaddsbs); - pragma Inline_Always (vec_vaddubs); - pragma Inline_Always (vec_and); - pragma Inline_Always (vec_andc); - pragma Inline_Always (vec_avg); - pragma Inline_Always (vec_vavgsw); - pragma Inline_Always (vec_vavguw); - pragma Inline_Always (vec_vavgsh); - pragma Inline_Always (vec_vavguh); - pragma Inline_Always (vec_vavgsb); - pragma Inline_Always (vec_vavgub); - pragma Inline_Always (vec_ceil); - pragma Inline_Always (vec_cmpb); - pragma Inline_Always (vec_cmpeq); - pragma Inline_Always (vec_vcmpeqfp); - pragma Inline_Always (vec_vcmpequw); - pragma Inline_Always (vec_vcmpequh); - pragma Inline_Always (vec_vcmpequb); - pragma Inline_Always (vec_cmpge); - pragma Inline_Always (vec_cmpgt); - pragma Inline_Always (vec_vcmpgtfp); - pragma Inline_Always (vec_vcmpgtsw); - pragma Inline_Always (vec_vcmpgtuw); - pragma Inline_Always (vec_vcmpgtsh); - pragma Inline_Always (vec_vcmpgtuh); - pragma Inline_Always (vec_vcmpgtsb); - pragma Inline_Always (vec_vcmpgtub); - pragma Inline_Always (vec_cmple); - pragma Inline_Always (vec_cmplt); - pragma Inline_Always (vec_expte); - pragma Inline_Always (vec_floor); - pragma Inline_Always (vec_ld); - pragma Inline_Always (vec_lde); - pragma Inline_Always (vec_lvewx); - pragma Inline_Always (vec_lvehx); - pragma Inline_Always (vec_lvebx); - pragma Inline_Always (vec_ldl); - pragma Inline_Always (vec_loge); - pragma Inline_Always (vec_lvsl); - pragma Inline_Always (vec_lvsr); - pragma Inline_Always (vec_madd); - pragma Inline_Always (vec_madds); - pragma Inline_Always (vec_max); - pragma Inline_Always (vec_vmaxfp); - pragma Inline_Always (vec_vmaxsw); - pragma Inline_Always (vec_vmaxuw); - pragma Inline_Always (vec_vmaxsh); - pragma Inline_Always (vec_vmaxuh); - pragma Inline_Always (vec_vmaxsb); - pragma Inline_Always (vec_vmaxub); - pragma Inline_Always (vec_mergeh); - pragma Inline_Always (vec_vmrghw); - pragma Inline_Always (vec_vmrghh); - pragma Inline_Always (vec_vmrghb); - pragma Inline_Always (vec_mergel); - pragma Inline_Always (vec_vmrglw); - pragma Inline_Always (vec_vmrglh); - pragma Inline_Always (vec_vmrglb); - pragma Inline_Always (vec_mfvscr); - pragma Inline_Always (vec_min); - pragma Inline_Always (vec_vminfp); - pragma Inline_Always (vec_vminsw); - pragma Inline_Always (vec_vminuw); - pragma Inline_Always (vec_vminsh); - pragma Inline_Always (vec_vminuh); - pragma Inline_Always (vec_vminsb); - pragma Inline_Always (vec_vminub); - pragma Inline_Always (vec_mladd); - pragma Inline_Always (vec_mradds); - pragma Inline_Always (vec_msum); - pragma Inline_Always (vec_vmsumshm); - pragma Inline_Always (vec_vmsumuhm); - pragma Inline_Always (vec_vmsummbm); - pragma Inline_Always (vec_vmsumubm); - pragma Inline_Always (vec_msums); - pragma Inline_Always (vec_vmsumshs); - pragma Inline_Always (vec_vmsumuhs); - pragma Inline_Always (vec_mtvscr); - pragma Inline_Always (vec_mule); - pragma Inline_Always (vec_vmulesh); - pragma Inline_Always (vec_vmuleuh); - pragma Inline_Always (vec_vmulesb); - pragma Inline_Always (vec_vmuleub); - pragma Inline_Always (vec_mulo); - pragma Inline_Always (vec_vmulosh); - pragma Inline_Always (vec_vmulouh); - pragma Inline_Always (vec_vmulosb); - pragma Inline_Always (vec_vmuloub); - pragma Inline_Always (vec_nmsub); - pragma Inline_Always (vec_nor); - pragma Inline_Always (vec_or); - pragma Inline_Always (vec_pack); - pragma Inline_Always (vec_vpkuwum); - pragma Inline_Always (vec_vpkuhum); - pragma Inline_Always (vec_packpx); - pragma Inline_Always (vec_packs); - pragma Inline_Always (vec_vpkswss); - pragma Inline_Always (vec_vpkuwus); - pragma Inline_Always (vec_vpkshss); - pragma Inline_Always (vec_vpkuhus); - pragma Inline_Always (vec_packsu); - pragma Inline_Always (vec_vpkswus); - pragma Inline_Always (vec_vpkshus); - pragma Inline_Always (vec_perm); - pragma Inline_Always (vec_re); - pragma Inline_Always (vec_rl); - pragma Inline_Always (vec_vrlw); - pragma Inline_Always (vec_vrlh); - pragma Inline_Always (vec_vrlb); - pragma Inline_Always (vec_round); - pragma Inline_Always (vec_rsqrte); - pragma Inline_Always (vec_sel); - pragma Inline_Always (vec_sl); - pragma Inline_Always (vec_vslw); - pragma Inline_Always (vec_vslh); - pragma Inline_Always (vec_vslb); - pragma Inline_Always (vec_sll); - pragma Inline_Always (vec_slo); - pragma Inline_Always (vec_sr); - pragma Inline_Always (vec_vsrw); - pragma Inline_Always (vec_vsrh); - pragma Inline_Always (vec_vsrb); - pragma Inline_Always (vec_sra); - pragma Inline_Always (vec_vsraw); - pragma Inline_Always (vec_vsrah); - pragma Inline_Always (vec_vsrab); - pragma Inline_Always (vec_srl); - pragma Inline_Always (vec_sro); - pragma Inline_Always (vec_st); - pragma Inline_Always (vec_ste); - pragma Inline_Always (vec_stvewx); - pragma Inline_Always (vec_stvehx); - pragma Inline_Always (vec_stvebx); - pragma Inline_Always (vec_stl); - pragma Inline_Always (vec_sub); - pragma Inline_Always (vec_vsubfp); - pragma Inline_Always (vec_vsubuwm); - pragma Inline_Always (vec_vsubuhm); - pragma Inline_Always (vec_vsububm); - pragma Inline_Always (vec_subc); - pragma Inline_Always (vec_subs); - pragma Inline_Always (vec_vsubsws); - pragma Inline_Always (vec_vsubuws); - pragma Inline_Always (vec_vsubshs); - pragma Inline_Always (vec_vsubuhs); - pragma Inline_Always (vec_vsubsbs); - pragma Inline_Always (vec_vsububs); - pragma Inline_Always (vec_sum4s); - pragma Inline_Always (vec_vsum4shs); - pragma Inline_Always (vec_vsum4sbs); - pragma Inline_Always (vec_vsum4ubs); - pragma Inline_Always (vec_sum2s); - pragma Inline_Always (vec_sums); - pragma Inline_Always (vec_trunc); - pragma Inline_Always (vec_unpackh); - pragma Inline_Always (vec_vupkhsh); - pragma Inline_Always (vec_vupkhpx); - pragma Inline_Always (vec_vupkhsb); - pragma Inline_Always (vec_unpackl); - pragma Inline_Always (vec_vupklpx); - pragma Inline_Always (vec_vupklsh); - pragma Inline_Always (vec_vupklsb); - pragma Inline_Always (vec_xor); - - pragma Inline_Always (vec_all_eq); - pragma Inline_Always (vec_all_ge); - pragma Inline_Always (vec_all_gt); - pragma Inline_Always (vec_all_in); - pragma Inline_Always (vec_all_le); - pragma Inline_Always (vec_all_lt); - pragma Inline_Always (vec_all_nan); - pragma Inline_Always (vec_all_ne); - pragma Inline_Always (vec_all_nge); - pragma Inline_Always (vec_all_ngt); - pragma Inline_Always (vec_all_nle); - pragma Inline_Always (vec_all_nlt); - pragma Inline_Always (vec_all_numeric); - pragma Inline_Always (vec_any_eq); - pragma Inline_Always (vec_any_ge); - pragma Inline_Always (vec_any_gt); - pragma Inline_Always (vec_any_le); - pragma Inline_Always (vec_any_lt); - pragma Inline_Always (vec_any_nan); - pragma Inline_Always (vec_any_ne); - pragma Inline_Always (vec_any_nge); - pragma Inline_Always (vec_any_ngt); - pragma Inline_Always (vec_any_nle); - pragma Inline_Always (vec_any_nlt); - pragma Inline_Always (vec_any_numeric); - pragma Inline_Always (vec_any_out); - pragma Inline_Always (vec_step); - -end GNAT.Altivec.Vector_Operations; diff --git a/gcc/ada/g-alvety.ads b/gcc/ada/g-alvety.ads deleted file mode 100644 index 06e824e..0000000 --- a/gcc/ada/g-alvety.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . V E C T O R _ T Y P E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit exposes the various vector types part of the Ada binding to --- Altivec facilities. - -with GNAT.Altivec.Low_Level_Vectors; - -package GNAT.Altivec.Vector_Types is - - use GNAT.Altivec.Low_Level_Vectors; - - --------------------------------------------------- - -- Vector type declarations [PIM-2.1 Data Types] -- - --------------------------------------------------- - - -- Except for assignments and pointer creation/dereference, operations - -- on vectors are only performed via subprograms. The vector types are - -- then private, and non-limited since assignments are allowed. - - -- The Hard/Soft binding type-structure differentiation is achieved in - -- Low_Level_Vectors. Each version only exposes private vector types, that - -- we just sub-type here. This is fine from the design standpoint and - -- reduces the amount of explicit conversion required in various places - -- internally. - - subtype vector_unsigned_char is Low_Level_Vectors.LL_VUC; - subtype vector_signed_char is Low_Level_Vectors.LL_VSC; - subtype vector_bool_char is Low_Level_Vectors.LL_VBC; - - subtype vector_unsigned_short is Low_Level_Vectors.LL_VUS; - subtype vector_signed_short is Low_Level_Vectors.LL_VSS; - subtype vector_bool_short is Low_Level_Vectors.LL_VBS; - - subtype vector_unsigned_int is Low_Level_Vectors.LL_VUI; - subtype vector_signed_int is Low_Level_Vectors.LL_VSI; - subtype vector_bool_int is Low_Level_Vectors.LL_VBI; - - subtype vector_float is Low_Level_Vectors.LL_VF; - subtype vector_pixel is Low_Level_Vectors.LL_VP; - - -- [PIM-2.1] shows groups of declarations with exact same component types, - -- e.g. vector unsigned short together with vector unsigned short int. It - -- so appears tempting to define subtypes for those matches here. - -- - -- [PIM-2.1] does not qualify items in those groups as "the same types", - -- though, and [PIM-2.4.2 Assignments] reads: "if either the left hand - -- side or the right hand side of an expression has a vector type, then - -- both sides of the expression must be of the same vector type". - -- - -- Not so clear what is exactly right, then. We go with subtypes for now - -- and can adjust later if need be. - - subtype vector_unsigned_short_int is vector_unsigned_short; - subtype vector_signed_short_int is vector_signed_short; - - subtype vector_char is vector_signed_char; - subtype vector_short is vector_signed_short; - subtype vector_int is vector_signed_int; - - -------------------------------- - -- Corresponding access types -- - -------------------------------- - - type vector_unsigned_char_ptr is access all vector_unsigned_char; - type vector_signed_char_ptr is access all vector_signed_char; - type vector_bool_char_ptr is access all vector_bool_char; - - type vector_unsigned_short_ptr is access all vector_unsigned_short; - type vector_signed_short_ptr is access all vector_signed_short; - type vector_bool_short_ptr is access all vector_bool_short; - - type vector_unsigned_int_ptr is access all vector_unsigned_int; - type vector_signed_int_ptr is access all vector_signed_int; - type vector_bool_int_ptr is access all vector_bool_int; - - type vector_float_ptr is access all vector_float; - type vector_pixel_ptr is access all vector_pixel; - - -------------------------------------------------------------------- - -- Additional access types, for the sake of some argument passing -- - -------------------------------------------------------------------- - - -- ... because some of the operations expect pointers to possibly - -- constant objects. - - type const_vector_bool_char_ptr is access constant vector_bool_char; - type const_vector_signed_char_ptr is access constant vector_signed_char; - type const_vector_unsigned_char_ptr is access constant vector_unsigned_char; - - type const_vector_bool_short_ptr is access constant vector_bool_short; - type const_vector_signed_short_ptr is access constant vector_signed_short; - type const_vector_unsigned_short_ptr is access - constant vector_unsigned_short; - - type const_vector_bool_int_ptr is access constant vector_bool_int; - type const_vector_signed_int_ptr is access constant vector_signed_int; - type const_vector_unsigned_int_ptr is access constant vector_unsigned_int; - - type const_vector_float_ptr is access constant vector_float; - type const_vector_pixel_ptr is access constant vector_pixel; - - ---------------------- - -- Useful shortcuts -- - ---------------------- - - subtype VUC is vector_unsigned_char; - subtype VSC is vector_signed_char; - subtype VBC is vector_bool_char; - - subtype VUS is vector_unsigned_short; - subtype VSS is vector_signed_short; - subtype VBS is vector_bool_short; - - subtype VUI is vector_unsigned_int; - subtype VSI is vector_signed_int; - subtype VBI is vector_bool_int; - - subtype VP is vector_pixel; - subtype VF is vector_float; - -end GNAT.Altivec.Vector_Types; diff --git a/gcc/ada/g-alvevi.ads b/gcc/ada/g-alvevi.ads deleted file mode 100644 index 8d8d856..0000000 --- a/gcc/ada/g-alvevi.ads +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A L T I V E C . V E C T O R _ V I E W S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit provides public 'View' data types from/to which private vector --- representations can be converted via Altivec.Conversions. This allows --- convenient access to individual vector elements and provides a simple way --- to initialize vector objects. - --- Accessing vector contents with direct memory overlays should be avoided --- because actual vector representations may vary across configurations, for --- instance to accommodate different target endianness. - --- The natural representation of a vector is an array indexed by vector --- component number, which is materialized by the Varray type definitions --- below. The 16byte alignment constraint is unfortunately sometimes not --- properly honored for constant array aggregates, so the View types are --- actually records enclosing such arrays. - -package GNAT.Altivec.Vector_Views is - - --------------------- - -- char components -- - --------------------- - - type Vchar_Range is range 1 .. 16; - - type Varray_unsigned_char is array (Vchar_Range) of unsigned_char; - for Varray_unsigned_char'Alignment use VECTOR_ALIGNMENT; - - type VUC_View is record - Values : Varray_unsigned_char; - end record; - - type Varray_signed_char is array (Vchar_Range) of signed_char; - for Varray_signed_char'Alignment use VECTOR_ALIGNMENT; - - type VSC_View is record - Values : Varray_signed_char; - end record; - - type Varray_bool_char is array (Vchar_Range) of bool_char; - for Varray_bool_char'Alignment use VECTOR_ALIGNMENT; - - type VBC_View is record - Values : Varray_bool_char; - end record; - - ---------------------- - -- short components -- - ---------------------- - - type Vshort_Range is range 1 .. 8; - - type Varray_unsigned_short is array (Vshort_Range) of unsigned_short; - for Varray_unsigned_short'Alignment use VECTOR_ALIGNMENT; - - type VUS_View is record - Values : Varray_unsigned_short; - end record; - - type Varray_signed_short is array (Vshort_Range) of signed_short; - for Varray_signed_short'Alignment use VECTOR_ALIGNMENT; - - type VSS_View is record - Values : Varray_signed_short; - end record; - - type Varray_bool_short is array (Vshort_Range) of bool_short; - for Varray_bool_short'Alignment use VECTOR_ALIGNMENT; - - type VBS_View is record - Values : Varray_bool_short; - end record; - - -------------------- - -- int components -- - -------------------- - - type Vint_Range is range 1 .. 4; - - type Varray_unsigned_int is array (Vint_Range) of unsigned_int; - for Varray_unsigned_int'Alignment use VECTOR_ALIGNMENT; - - type VUI_View is record - Values : Varray_unsigned_int; - end record; - - type Varray_signed_int is array (Vint_Range) of signed_int; - for Varray_signed_int'Alignment use VECTOR_ALIGNMENT; - - type VSI_View is record - Values : Varray_signed_int; - end record; - - type Varray_bool_int is array (Vint_Range) of bool_int; - for Varray_bool_int'Alignment use VECTOR_ALIGNMENT; - - type VBI_View is record - Values : Varray_bool_int; - end record; - - ---------------------- - -- float components -- - ---------------------- - - type Vfloat_Range is range 1 .. 4; - - type Varray_float is array (Vfloat_Range) of C_float; - for Varray_float'Alignment use VECTOR_ALIGNMENT; - - type VF_View is record - Values : Varray_float; - end record; - - ---------------------- - -- pixel components -- - ---------------------- - - type Vpixel_Range is range 1 .. 8; - - type Varray_pixel is array (Vpixel_Range) of pixel; - for Varray_pixel'Alignment use VECTOR_ALIGNMENT; - - type VP_View is record - Values : Varray_pixel; - end record; - -end GNAT.Altivec.Vector_Views; diff --git a/gcc/ada/g-arrspl.adb b/gcc/ada/g-arrspl.adb deleted file mode 100644 index f3eaf80..0000000 --- a/gcc/ada/g-arrspl.adb +++ /dev/null @@ -1,352 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A R R A Y _ S P L I T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -package body GNAT.Array_Split is - - procedure Free is - new Ada.Unchecked_Deallocation (Slices_Indexes, Slices_Access); - - procedure Free is - new Ada.Unchecked_Deallocation (Separators_Indexes, Indexes_Access); - - function Count - (Source : Element_Sequence; - Pattern : Element_Set) return Natural; - -- Returns the number of occurrences of Pattern elements in Source, 0 is - -- returned if no occurrence is found in Source. - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (S : in out Slice_Set) is - begin - S.D.Ref_Counter := S.D.Ref_Counter + 1; - end Adjust; - - ------------ - -- Create -- - ------------ - - procedure Create - (S : out Slice_Set; - From : Element_Sequence; - Separators : Element_Sequence; - Mode : Separator_Mode := Single) - is - begin - Create (S, From, To_Set (Separators), Mode); - end Create; - - ------------ - -- Create -- - ------------ - - procedure Create - (S : out Slice_Set; - From : Element_Sequence; - Separators : Element_Set; - Mode : Separator_Mode := Single) - is - Result : Slice_Set; - begin - Result.D.Source := new Element_Sequence'(From); - Set (Result, Separators, Mode); - S := Result; - end Create; - - ----------- - -- Count -- - ----------- - - function Count - (Source : Element_Sequence; - Pattern : Element_Set) return Natural - is - C : Natural := 0; - begin - for K in Source'Range loop - if Is_In (Source (K), Pattern) then - C := C + 1; - end if; - end loop; - - return C; - end Count; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (S : in out Slice_Set) is - - procedure Free is - new Ada.Unchecked_Deallocation (Element_Sequence, Element_Access); - - procedure Free is - new Ada.Unchecked_Deallocation (Data, Data_Access); - - D : Data_Access := S.D; - - begin - -- Ensure call is idempotent - - S.D := null; - - if D /= null then - D.Ref_Counter := D.Ref_Counter - 1; - - if D.Ref_Counter = 0 then - Free (D.Source); - Free (D.Indexes); - Free (D.Slices); - Free (D); - end if; - end if; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (S : in out Slice_Set) is - begin - S.D := new Data'(1, null, 0, null, null); - end Initialize; - - ---------------- - -- Separators -- - ---------------- - - function Separators - (S : Slice_Set; - Index : Slice_Number) return Slice_Separators - is - begin - if Index > S.D.N_Slice then - raise Index_Error; - - elsif Index = 0 - or else (Index = 1 and then S.D.N_Slice = 1) - then - -- Whole string, or no separator used - - return (Before => Array_End, - After => Array_End); - - elsif Index = 1 then - return (Before => Array_End, - After => S.D.Source (S.D.Slices (Index).Stop + 1)); - - elsif Index = S.D.N_Slice then - return (Before => S.D.Source (S.D.Slices (Index).Start - 1), - After => Array_End); - - else - return (Before => S.D.Source (S.D.Slices (Index).Start - 1), - After => S.D.Source (S.D.Slices (Index).Stop + 1)); - end if; - end Separators; - - ---------------- - -- Separators -- - ---------------- - - function Separators (S : Slice_Set) return Separators_Indexes is - begin - return S.D.Indexes.all; - end Separators; - - --------- - -- Set -- - --------- - - procedure Set - (S : in out Slice_Set; - Separators : Element_Sequence; - Mode : Separator_Mode := Single) - is - begin - Set (S, To_Set (Separators), Mode); - end Set; - - --------- - -- Set -- - --------- - - procedure Set - (S : in out Slice_Set; - Separators : Element_Set; - Mode : Separator_Mode := Single) - is - - procedure Copy_On_Write (S : in out Slice_Set); - -- Make a copy of S if shared with another variable - - ------------------- - -- Copy_On_Write -- - ------------------- - - procedure Copy_On_Write (S : in out Slice_Set) is - begin - if S.D.Ref_Counter > 1 then - -- First let's remove our count from the current data - - S.D.Ref_Counter := S.D.Ref_Counter - 1; - - -- Then duplicate the data - - S.D := new Data'(S.D.all); - S.D.Ref_Counter := 1; - - if S.D.Source /= null then - S.D.Source := new Element_Sequence'(S.D.Source.all); - S.D.Indexes := null; - S.D.Slices := null; - end if; - - else - -- If there is a single reference to this variable, free it now - -- as it will be redefined below. - - Free (S.D.Indexes); - Free (S.D.Slices); - end if; - end Copy_On_Write; - - Count_Sep : constant Natural := Count (S.D.Source.all, Separators); - J : Positive; - - begin - Copy_On_Write (S); - - -- Compute all separator's indexes - - S.D.Indexes := new Separators_Indexes (1 .. Count_Sep); - J := S.D.Indexes'First; - - for K in S.D.Source'Range loop - if Is_In (S.D.Source (K), Separators) then - S.D.Indexes (J) := K; - J := J + 1; - end if; - end loop; - - -- Compute slice info for fast slice access - - declare - S_Info : Slices_Indexes (1 .. Slice_Number (Count_Sep) + 1); - K : Natural := 1; - Start, Stop : Natural; - - begin - S.D.N_Slice := 0; - - Start := S.D.Source'First; - Stop := 0; - - loop - if K > Count_Sep then - - -- No more separators, last slice ends at end of source string - - Stop := S.D.Source'Last; - - else - Stop := S.D.Indexes (K) - 1; - end if; - - -- Add slice to the table - - S.D.N_Slice := S.D.N_Slice + 1; - S_Info (S.D.N_Slice) := (Start, Stop); - - exit when K > Count_Sep; - - case Mode is - when Single => - - -- In this mode just set start to character next to the - -- current separator, advance the separator index. - - Start := S.D.Indexes (K) + 1; - K := K + 1; - - when Multiple => - - -- In this mode skip separators following each other - - loop - Start := S.D.Indexes (K) + 1; - K := K + 1; - exit when K > Count_Sep - or else S.D.Indexes (K) > S.D.Indexes (K - 1) + 1; - end loop; - end case; - end loop; - - S.D.Slices := new Slices_Indexes'(S_Info (1 .. S.D.N_Slice)); - end; - end Set; - - ----------- - -- Slice -- - ----------- - - function Slice - (S : Slice_Set; - Index : Slice_Number) return Element_Sequence - is - begin - if Index = 0 then - return S.D.Source.all; - - elsif Index > S.D.N_Slice then - raise Index_Error; - - else - return - S.D.Source (S.D.Slices (Index).Start .. S.D.Slices (Index).Stop); - end if; - end Slice; - - ----------------- - -- Slice_Count -- - ----------------- - - function Slice_Count (S : Slice_Set) return Slice_Number is - begin - return S.D.N_Slice; - end Slice_Count; - -end GNAT.Array_Split; diff --git a/gcc/ada/g-arrspl.ads b/gcc/ada/g-arrspl.ads deleted file mode 100644 index ce3158c..0000000 --- a/gcc/ada/g-arrspl.ads +++ /dev/null @@ -1,190 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A R R A Y _ S P L I T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Useful array-manipulation routines: given a set of separators, split --- an array wherever the separators appear, and provide direct access --- to the resulting slices. - -with Ada.Finalization; - -generic - type Element is (<>); - -- Element of the array, this must be a discrete type - - type Element_Sequence is array (Positive range <>) of Element; - -- The array which is a sequence of element - - type Element_Set is private; - -- This type represent a set of elements. This set does not define a - -- specific order of the elements. The conversion of a sequence to a - -- set and membership tests in the set is performed using the routines - -- To_Set and Is_In defined below. - - with function To_Set (Sequence : Element_Sequence) return Element_Set; - -- Returns an Element_Set given an Element_Sequence. Duplicate elements - -- can be ignored during this conversion. - - with function Is_In (Item : Element; Set : Element_Set) return Boolean; - -- Returns True if Item is found in Set, False otherwise - -package GNAT.Array_Split is - - Index_Error : exception; - -- Raised by all operations below if Index > Field_Count (S) - - type Separator_Mode is - (Single, - -- In this mode the array is cut at each element in the separator - -- set. If two separators are contiguous the result at that position - -- is an empty slice. - - Multiple - -- In this mode contiguous separators are handled as a single - -- separator and no empty slice is created. - ); - - type Slice_Set is private; - -- This type uses by-reference semantics. This is a set of slices as - -- returned by Create or Set routines below. The abstraction represents - -- a set of items. Each item is a part of the original array named a - -- Slice. It is possible to access individual slices by using the Slice - -- routine below. The first slice in the Set is at the position/index - -- 1. The total number of slices in the set is returned by Slice_Count. - - procedure Create - (S : out Slice_Set; - From : Element_Sequence; - Separators : Element_Sequence; - Mode : Separator_Mode := Single); - -- Create a cut array object. From is the source array, and Separators - -- is a sequence of Element along which to split the array. The source - -- array is sliced at separator boundaries. The separators are not - -- included as part of the resulting slices. - -- - -- Note that if From is terminated by a separator an extra empty element - -- is added to the slice set. If From only contains a separator the slice - -- set contains two empty elements. - - procedure Create - (S : out Slice_Set; - From : Element_Sequence; - Separators : Element_Set; - Mode : Separator_Mode := Single); - -- Same as above but using a Element_Set - - procedure Set - (S : in out Slice_Set; - Separators : Element_Sequence; - Mode : Separator_Mode := Single); - -- Change the set of separators. The source array will be split according - -- to this new set of separators. - - procedure Set - (S : in out Slice_Set; - Separators : Element_Set; - Mode : Separator_Mode := Single); - -- Same as above but using a Element_Set - - type Slice_Number is new Natural; - -- Type used to count number of slices - - function Slice_Count (S : Slice_Set) return Slice_Number; - pragma Inline (Slice_Count); - -- Returns the number of slices (fields) in S - - function Slice - (S : Slice_Set; - Index : Slice_Number) return Element_Sequence; - pragma Inline (Slice); - -- Returns the slice at position Index. First slice is 1. If Index is 0 - -- the whole array is returned including the separators (this is the - -- original source array). - - type Position is (Before, After); - -- Used to designate position of separator - - type Slice_Separators is array (Position) of Element; - -- Separators found before and after the slice - - Array_End : constant Element; - -- This is the separator returned for the start or the end of the array - - function Separators - (S : Slice_Set; - Index : Slice_Number) return Slice_Separators; - -- Returns the separators used to slice (front and back) the slice at - -- position Index. For slices at start and end of the original array, the - -- Array_End value is returned for the corresponding outer bound. In - -- Multiple mode only the element closest to the slice is returned. - -- if Index = 0, returns (Array_End, Array_End). - - type Separators_Indexes is array (Positive range <>) of Positive; - - function Separators (S : Slice_Set) return Separators_Indexes; - -- Returns indexes of all separators used to slice original source array S - -private - - Array_End : constant Element := Element'First; - - type Element_Access is access Element_Sequence; - - type Indexes_Access is access Separators_Indexes; - - type Slice_Info is record - Start : Positive; - Stop : Natural; - end record; - -- Starting/Ending position of a slice. This does not include separators - - type Slices_Indexes is array (Slice_Number range <>) of Slice_Info; - type Slices_Access is access Slices_Indexes; - -- All indexes for fast access to slices. In the Slice_Set we keep only - -- the original array and the indexes where each slice start and stop. - - type Data is record - Ref_Counter : Natural; -- Reference counter, by-address sem - Source : Element_Access; - N_Slice : Slice_Number := 0; -- Number of slices found - Indexes : Indexes_Access; - Slices : Slices_Access; - end record; - type Data_Access is access all Data; - - type Slice_Set is new Ada.Finalization.Controlled with record - D : Data_Access; - end record; - - procedure Initialize (S : in out Slice_Set); - procedure Adjust (S : in out Slice_Set); - procedure Finalize (S : in out Slice_Set); - -end GNAT.Array_Split; diff --git a/gcc/ada/g-awk.adb b/gcc/ada/g-awk.adb deleted file mode 100644 index 5771100..0000000 --- a/gcc/ada/g-awk.adb +++ /dev/null @@ -1,1488 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A W K -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; -with Ada.Text_IO; -with Ada.Strings.Unbounded; -with Ada.Strings.Fixed; -with Ada.Strings.Maps; -with Ada.Unchecked_Deallocation; - -with GNAT.Directory_Operations; -with GNAT.Dynamic_Tables; -with GNAT.OS_Lib; - -package body GNAT.AWK is - - use Ada; - use Ada.Strings.Unbounded; - - ----------------------- - -- Local subprograms -- - ----------------------- - - -- The following two subprograms provide a functional interface to the - -- two special session variables, that are manipulated explicitly by - -- Finalize, but must be declared after Finalize to prevent static - -- elaboration warnings. - - function Get_Def return Session_Data_Access; - procedure Set_Cur; - - ---------------- - -- Split mode -- - ---------------- - - package Split is - - type Mode is abstract tagged null record; - -- This is the main type which is declared abstract. This type must be - -- derived for each split style. - - type Mode_Access is access Mode'Class; - - procedure Current_Line (S : Mode; Session : Session_Type) - is abstract; - -- Split current line of Session using split mode S - - ------------------------ - -- Split on separator -- - ------------------------ - - type Separator (Size : Positive) is new Mode with record - Separators : String (1 .. Size); - end record; - - procedure Current_Line - (S : Separator; - Session : Session_Type); - - --------------------- - -- Split on column -- - --------------------- - - type Column (Size : Positive) is new Mode with record - Columns : Widths_Set (1 .. Size); - end record; - - procedure Current_Line (S : Column; Session : Session_Type); - - end Split; - - procedure Free is new Unchecked_Deallocation - (Split.Mode'Class, Split.Mode_Access); - - ---------------- - -- File_Table -- - ---------------- - - type AWK_File is access String; - - package File_Table is - new Dynamic_Tables (AWK_File, Natural, 1, 5, 50); - -- List of file names associated with a Session - - procedure Free is new Unchecked_Deallocation (String, AWK_File); - - ----------------- - -- Field_Table -- - ----------------- - - type Field_Slice is record - First : Positive; - Last : Natural; - end record; - -- This is a field slice (First .. Last) in session's current line - - package Field_Table is - new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100); - -- List of fields for the current line - - -------------- - -- Patterns -- - -------------- - - -- Define all patterns style: exact string, regular expression, boolean - -- function. - - package Patterns is - - type Pattern is abstract tagged null record; - -- This is the main type which is declared abstract. This type must be - -- derived for each patterns style. - - type Pattern_Access is access Pattern'Class; - - function Match - (P : Pattern; - Session : Session_Type) return Boolean - is abstract; - -- Returns True if P match for the current session and False otherwise - - procedure Release (P : in out Pattern); - -- Release memory used by the pattern structure - - -------------------------- - -- Exact string pattern -- - -------------------------- - - type String_Pattern is new Pattern with record - Str : Unbounded_String; - Rank : Count; - end record; - - function Match - (P : String_Pattern; - Session : Session_Type) return Boolean; - - -------------------------------- - -- Regular expression pattern -- - -------------------------------- - - type Pattern_Matcher_Access is access Regpat.Pattern_Matcher; - - type Regexp_Pattern is new Pattern with record - Regx : Pattern_Matcher_Access; - Rank : Count; - end record; - - function Match - (P : Regexp_Pattern; - Session : Session_Type) return Boolean; - - procedure Release (P : in out Regexp_Pattern); - - ------------------------------ - -- Boolean function pattern -- - ------------------------------ - - type Callback_Pattern is new Pattern with record - Pattern : Pattern_Callback; - end record; - - function Match - (P : Callback_Pattern; - Session : Session_Type) return Boolean; - - end Patterns; - - procedure Free is new Unchecked_Deallocation - (Patterns.Pattern'Class, Patterns.Pattern_Access); - - ------------- - -- Actions -- - ------------- - - -- Define all action style : simple call, call with matches - - package Actions is - - type Action is abstract tagged null record; - -- This is the main type which is declared abstract. This type must be - -- derived for each action style. - - type Action_Access is access Action'Class; - - procedure Call - (A : Action; - Session : Session_Type) is abstract; - -- Call action A as required - - ------------------- - -- Simple action -- - ------------------- - - type Simple_Action is new Action with record - Proc : Action_Callback; - end record; - - procedure Call - (A : Simple_Action; - Session : Session_Type); - - ------------------------- - -- Action with matches -- - ------------------------- - - type Match_Action is new Action with record - Proc : Match_Action_Callback; - end record; - - procedure Call - (A : Match_Action; - Session : Session_Type); - - end Actions; - - procedure Free is new Unchecked_Deallocation - (Actions.Action'Class, Actions.Action_Access); - - -------------------------- - -- Pattern/Action table -- - -------------------------- - - type Pattern_Action is record - Pattern : Patterns.Pattern_Access; -- If Pattern is True - Action : Actions.Action_Access; -- Action will be called - end record; - - package Pattern_Action_Table is - new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50); - - ------------------ - -- Session Data -- - ------------------ - - type Session_Data is record - Current_File : Text_IO.File_Type; - Current_Line : Unbounded_String; - Separators : Split.Mode_Access; - Files : File_Table.Instance; - File_Index : Natural := 0; - Fields : Field_Table.Instance; - Filters : Pattern_Action_Table.Instance; - NR : Natural := 0; - FNR : Natural := 0; - Matches : Regpat.Match_Array (0 .. 100); - -- Latest matches for the regexp pattern - end record; - - procedure Free is - new Unchecked_Deallocation (Session_Data, Session_Data_Access); - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Session : in out Session_Type) is - begin - -- We release the session data only if it is not the default session - - if Session.Data /= Get_Def then - -- Release separators - - Free (Session.Data.Separators); - - Free (Session.Data); - - -- Since we have closed the current session, set it to point now to - -- the default session. - - Set_Cur; - end if; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Session : in out Session_Type) is - begin - Session.Data := new Session_Data; - - -- Initialize separators - - Session.Data.Separators := - new Split.Separator'(Default_Separators'Length, Default_Separators); - - -- Initialize all tables - - File_Table.Init (Session.Data.Files); - Field_Table.Init (Session.Data.Fields); - Pattern_Action_Table.Init (Session.Data.Filters); - end Initialize; - - ----------------------- - -- Session Variables -- - ----------------------- - - Def_Session : Session_Type; - Cur_Session : Session_Type; - - ---------------------- - -- Private Services -- - ---------------------- - - function Always_True return Boolean; - -- A function that always returns True - - function Apply_Filters - (Session : Session_Type) return Boolean; - -- Apply any filters for which the Pattern is True for Session. It returns - -- True if a least one filters has been applied (i.e. associated action - -- callback has been called). - - procedure Open_Next_File - (Session : Session_Type); - pragma Inline (Open_Next_File); - -- Open next file for Session closing current file if needed. It raises - -- End_Error if there is no more file in the table. - - procedure Raise_With_Info - (E : Exceptions.Exception_Id; - Message : String; - Session : Session_Type); - pragma No_Return (Raise_With_Info); - -- Raises exception E with the message prepended with the current line - -- number and the filename if possible. - - procedure Read_Line (Session : Session_Type); - -- Read a line for the Session and set Current_Line - - procedure Split_Line (Session : Session_Type); - -- Split session's Current_Line according to the session separators and - -- set the Fields table. This procedure can be called at any time. - - ---------------------- - -- Private Packages -- - ---------------------- - - ------------- - -- Actions -- - ------------- - - package body Actions is - - ---------- - -- Call -- - ---------- - - procedure Call - (A : Simple_Action; - Session : Session_Type) - is - pragma Unreferenced (Session); - begin - A.Proc.all; - end Call; - - ---------- - -- Call -- - ---------- - - procedure Call - (A : Match_Action; - Session : Session_Type) - is - begin - A.Proc (Session.Data.Matches); - end Call; - - end Actions; - - -------------- - -- Patterns -- - -------------- - - package body Patterns is - - ----------- - -- Match -- - ----------- - - function Match - (P : String_Pattern; - Session : Session_Type) return Boolean - is - begin - return P.Str = Field (P.Rank, Session); - end Match; - - ----------- - -- Match -- - ----------- - - function Match - (P : Regexp_Pattern; - Session : Session_Type) return Boolean - is - use type Regpat.Match_Location; - begin - Regpat.Match - (P.Regx.all, Field (P.Rank, Session), Session.Data.Matches); - return Session.Data.Matches (0) /= Regpat.No_Match; - end Match; - - ----------- - -- Match -- - ----------- - - function Match - (P : Callback_Pattern; - Session : Session_Type) return Boolean - is - pragma Unreferenced (Session); - begin - return P.Pattern.all; - end Match; - - ------------- - -- Release -- - ------------- - - procedure Release (P : in out Pattern) is - pragma Unreferenced (P); - begin - null; - end Release; - - ------------- - -- Release -- - ------------- - - procedure Release (P : in out Regexp_Pattern) is - procedure Free is new Unchecked_Deallocation - (Regpat.Pattern_Matcher, Pattern_Matcher_Access); - begin - Free (P.Regx); - end Release; - - end Patterns; - - ----------- - -- Split -- - ----------- - - package body Split is - - use Ada.Strings; - - ------------------ - -- Current_Line -- - ------------------ - - procedure Current_Line (S : Separator; Session : Session_Type) is - Line : constant String := To_String (Session.Data.Current_Line); - Fields : Field_Table.Instance renames Session.Data.Fields; - Seps : constant Maps.Character_Set := Maps.To_Set (S.Separators); - - Start : Natural; - Stop : Natural; - - begin - -- First field start here - - Start := Line'First; - - -- Record the first field start position which is the first character - -- in the line. - - Field_Table.Increment_Last (Fields); - Fields.Table (Field_Table.Last (Fields)).First := Start; - - loop - -- Look for next separator - - Stop := Fixed.Index - (Source => Line (Start .. Line'Last), - Set => Seps); - - exit when Stop = 0; - - Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1; - - -- If separators are set to the default (space and tab) we skip - -- all spaces and tabs following current field. - - if S.Separators = Default_Separators then - Start := Fixed.Index - (Line (Stop + 1 .. Line'Last), - Maps.To_Set (Default_Separators), - Outside, - Strings.Forward); - - if Start = 0 then - Start := Stop + 1; - end if; - - else - Start := Stop + 1; - end if; - - -- Record in the field table the start of this new field - - Field_Table.Increment_Last (Fields); - Fields.Table (Field_Table.Last (Fields)).First := Start; - - end loop; - - Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; - end Current_Line; - - ------------------ - -- Current_Line -- - ------------------ - - procedure Current_Line (S : Column; Session : Session_Type) is - Line : constant String := To_String (Session.Data.Current_Line); - Fields : Field_Table.Instance renames Session.Data.Fields; - Start : Positive := Line'First; - - begin - -- Record the first field start position which is the first character - -- in the line. - - for C in 1 .. S.Columns'Length loop - - Field_Table.Increment_Last (Fields); - - Fields.Table (Field_Table.Last (Fields)).First := Start; - - Start := Start + S.Columns (C); - - Fields.Table (Field_Table.Last (Fields)).Last := Start - 1; - - end loop; - - -- If there is some remaining character on the line, add them in a - -- new field. - - if Start - 1 < Line'Length then - - Field_Table.Increment_Last (Fields); - - Fields.Table (Field_Table.Last (Fields)).First := Start; - - Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; - end if; - end Current_Line; - - end Split; - - -------------- - -- Add_File -- - -------------- - - procedure Add_File - (Filename : String; - Session : Session_Type) - is - Files : File_Table.Instance renames Session.Data.Files; - - begin - if OS_Lib.Is_Regular_File (Filename) then - File_Table.Increment_Last (Files); - Files.Table (File_Table.Last (Files)) := new String'(Filename); - else - Raise_With_Info - (File_Error'Identity, - "File " & Filename & " not found.", - Session); - end if; - end Add_File; - - procedure Add_File - (Filename : String) - is - - begin - Add_File (Filename, Cur_Session); - end Add_File; - - --------------- - -- Add_Files -- - --------------- - - procedure Add_Files - (Directory : String; - Filenames : String; - Number_Of_Files_Added : out Natural; - Session : Session_Type) - is - use Directory_Operations; - - Dir : Dir_Type; - Filename : String (1 .. 200); - Last : Natural; - - begin - Number_Of_Files_Added := 0; - - Open (Dir, Directory); - - loop - Read (Dir, Filename, Last); - exit when Last = 0; - - Add_File (Filename (1 .. Last), Session); - Number_Of_Files_Added := Number_Of_Files_Added + 1; - end loop; - - Close (Dir); - - exception - when others => - Raise_With_Info - (File_Error'Identity, - "Error scanning directory " & Directory - & " for files " & Filenames & '.', - Session); - end Add_Files; - - procedure Add_Files - (Directory : String; - Filenames : String; - Number_Of_Files_Added : out Natural) - is - - begin - Add_Files (Directory, Filenames, Number_Of_Files_Added, Cur_Session); - end Add_Files; - - ----------------- - -- Always_True -- - ----------------- - - function Always_True return Boolean is - begin - return True; - end Always_True; - - ------------------- - -- Apply_Filters -- - ------------------- - - function Apply_Filters - (Session : Session_Type) return Boolean - is - Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; - Results : Boolean := False; - - begin - -- Iterate through the filters table, if pattern match call action - - for F in 1 .. Pattern_Action_Table.Last (Filters) loop - if Patterns.Match (Filters.Table (F).Pattern.all, Session) then - Results := True; - Actions.Call (Filters.Table (F).Action.all, Session); - end if; - end loop; - - return Results; - end Apply_Filters; - - ----------- - -- Close -- - ----------- - - procedure Close (Session : Session_Type) is - Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; - Files : File_Table.Instance renames Session.Data.Files; - - begin - -- Close current file if needed - - if Text_IO.Is_Open (Session.Data.Current_File) then - Text_IO.Close (Session.Data.Current_File); - end if; - - -- Release Filters table - - for F in 1 .. Pattern_Action_Table.Last (Filters) loop - Patterns.Release (Filters.Table (F).Pattern.all); - Free (Filters.Table (F).Pattern); - Free (Filters.Table (F).Action); - end loop; - - for F in 1 .. File_Table.Last (Files) loop - Free (Files.Table (F)); - end loop; - - File_Table.Set_Last (Session.Data.Files, 0); - Field_Table.Set_Last (Session.Data.Fields, 0); - Pattern_Action_Table.Set_Last (Session.Data.Filters, 0); - - Session.Data.NR := 0; - Session.Data.FNR := 0; - Session.Data.File_Index := 0; - Session.Data.Current_Line := Null_Unbounded_String; - end Close; - - --------------------- - -- Current_Session -- - --------------------- - - function Current_Session return not null access Session_Type is - begin - return Cur_Session.Self; - end Current_Session; - - --------------------- - -- Default_Session -- - --------------------- - - function Default_Session return not null access Session_Type is - begin - return Def_Session.Self; - end Default_Session; - - -------------------- - -- Discrete_Field -- - -------------------- - - function Discrete_Field - (Rank : Count; - Session : Session_Type) return Discrete - is - begin - return Discrete'Value (Field (Rank, Session)); - end Discrete_Field; - - function Discrete_Field_Current_Session - (Rank : Count) return Discrete is - function Do_It is new Discrete_Field (Discrete); - begin - return Do_It (Rank, Cur_Session); - end Discrete_Field_Current_Session; - - ----------------- - -- End_Of_Data -- - ----------------- - - function End_Of_Data - (Session : Session_Type) return Boolean - is - begin - return Session.Data.File_Index = File_Table.Last (Session.Data.Files) - and then End_Of_File (Session); - end End_Of_Data; - - function End_Of_Data - return Boolean - is - begin - return End_Of_Data (Cur_Session); - end End_Of_Data; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File - (Session : Session_Type) return Boolean - is - begin - return Text_IO.End_Of_File (Session.Data.Current_File); - end End_Of_File; - - function End_Of_File - return Boolean - is - begin - return End_Of_File (Cur_Session); - end End_Of_File; - - ----------- - -- Field -- - ----------- - - function Field - (Rank : Count; - Session : Session_Type) return String - is - Fields : Field_Table.Instance renames Session.Data.Fields; - - begin - if Rank > Number_Of_Fields (Session) then - Raise_With_Info - (Field_Error'Identity, - "Field number" & Count'Image (Rank) & " does not exist.", - Session); - - elsif Rank = 0 then - - -- Returns the whole line, this is what $0 does under Session_Type - - return To_String (Session.Data.Current_Line); - - else - return Slice (Session.Data.Current_Line, - Fields.Table (Positive (Rank)).First, - Fields.Table (Positive (Rank)).Last); - end if; - end Field; - - function Field - (Rank : Count) return String - is - begin - return Field (Rank, Cur_Session); - end Field; - - function Field - (Rank : Count; - Session : Session_Type) return Integer - is - begin - return Integer'Value (Field (Rank, Session)); - - exception - when Constraint_Error => - Raise_With_Info - (Field_Error'Identity, - "Field number" & Count'Image (Rank) - & " cannot be converted to an integer.", - Session); - end Field; - - function Field - (Rank : Count) return Integer - is - begin - return Field (Rank, Cur_Session); - end Field; - - function Field - (Rank : Count; - Session : Session_Type) return Float - is - begin - return Float'Value (Field (Rank, Session)); - - exception - when Constraint_Error => - Raise_With_Info - (Field_Error'Identity, - "Field number" & Count'Image (Rank) - & " cannot be converted to a float.", - Session); - end Field; - - function Field - (Rank : Count) return Float - is - begin - return Field (Rank, Cur_Session); - end Field; - - ---------- - -- File -- - ---------- - - function File - (Session : Session_Type) return String - is - Files : File_Table.Instance renames Session.Data.Files; - - begin - if Session.Data.File_Index = 0 then - return "??"; - else - return Files.Table (Session.Data.File_Index).all; - end if; - end File; - - function File - return String - is - begin - return File (Cur_Session); - end File; - - -------------------- - -- For_Every_Line -- - -------------------- - - procedure For_Every_Line - (Separators : String := Use_Current; - Filename : String := Use_Current; - Callbacks : Callback_Mode := None; - Session : Session_Type) - is - Quit : Boolean; - - begin - Open (Separators, Filename, Session); - - while not End_Of_Data (Session) loop - Read_Line (Session); - Split_Line (Session); - - if Callbacks in Only .. Pass_Through then - declare - Discard : Boolean; - begin - Discard := Apply_Filters (Session); - end; - end if; - - if Callbacks /= Only then - Quit := False; - Action (Quit); - exit when Quit; - end if; - end loop; - - Close (Session); - end For_Every_Line; - - procedure For_Every_Line_Current_Session - (Separators : String := Use_Current; - Filename : String := Use_Current; - Callbacks : Callback_Mode := None) - is - procedure Do_It is new For_Every_Line (Action); - begin - Do_It (Separators, Filename, Callbacks, Cur_Session); - end For_Every_Line_Current_Session; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line - (Callbacks : Callback_Mode := None; - Session : Session_Type) - is - Filter_Active : Boolean; - - begin - if not Text_IO.Is_Open (Session.Data.Current_File) then - raise File_Error; - end if; - - loop - Read_Line (Session); - Split_Line (Session); - - case Callbacks is - when None => - exit; - - when Only => - Filter_Active := Apply_Filters (Session); - exit when not Filter_Active; - - when Pass_Through => - Filter_Active := Apply_Filters (Session); - exit; - end case; - end loop; - end Get_Line; - - procedure Get_Line - (Callbacks : Callback_Mode := None) - is - begin - Get_Line (Callbacks, Cur_Session); - end Get_Line; - - ---------------------- - -- Number_Of_Fields -- - ---------------------- - - function Number_Of_Fields - (Session : Session_Type) return Count - is - begin - return Count (Field_Table.Last (Session.Data.Fields)); - end Number_Of_Fields; - - function Number_Of_Fields - return Count - is - begin - return Number_Of_Fields (Cur_Session); - end Number_Of_Fields; - - -------------------------- - -- Number_Of_File_Lines -- - -------------------------- - - function Number_Of_File_Lines - (Session : Session_Type) return Count - is - begin - return Count (Session.Data.FNR); - end Number_Of_File_Lines; - - function Number_Of_File_Lines - return Count - is - begin - return Number_Of_File_Lines (Cur_Session); - end Number_Of_File_Lines; - - --------------------- - -- Number_Of_Files -- - --------------------- - - function Number_Of_Files - (Session : Session_Type) return Natural - is - Files : File_Table.Instance renames Session.Data.Files; - begin - return File_Table.Last (Files); - end Number_Of_Files; - - function Number_Of_Files - return Natural - is - begin - return Number_Of_Files (Cur_Session); - end Number_Of_Files; - - --------------------- - -- Number_Of_Lines -- - --------------------- - - function Number_Of_Lines - (Session : Session_Type) return Count - is - begin - return Count (Session.Data.NR); - end Number_Of_Lines; - - function Number_Of_Lines - return Count - is - begin - return Number_Of_Lines (Cur_Session); - end Number_Of_Lines; - - ---------- - -- Open -- - ---------- - - procedure Open - (Separators : String := Use_Current; - Filename : String := Use_Current; - Session : Session_Type) - is - begin - if Text_IO.Is_Open (Session.Data.Current_File) then - raise Session_Error; - end if; - - if Filename /= Use_Current then - File_Table.Init (Session.Data.Files); - Add_File (Filename, Session); - end if; - - if Separators /= Use_Current then - Set_Field_Separators (Separators, Session); - end if; - - Open_Next_File (Session); - - exception - when End_Error => - raise File_Error; - end Open; - - procedure Open - (Separators : String := Use_Current; - Filename : String := Use_Current) - is - begin - Open (Separators, Filename, Cur_Session); - end Open; - - -------------------- - -- Open_Next_File -- - -------------------- - - procedure Open_Next_File - (Session : Session_Type) - is - Files : File_Table.Instance renames Session.Data.Files; - - begin - if Text_IO.Is_Open (Session.Data.Current_File) then - Text_IO.Close (Session.Data.Current_File); - end if; - - Session.Data.File_Index := Session.Data.File_Index + 1; - - -- If there are no mores file in the table, raise End_Error - - if Session.Data.File_Index > File_Table.Last (Files) then - raise End_Error; - end if; - - Text_IO.Open - (File => Session.Data.Current_File, - Name => Files.Table (Session.Data.File_Index).all, - Mode => Text_IO.In_File); - end Open_Next_File; - - ----------- - -- Parse -- - ----------- - - procedure Parse - (Separators : String := Use_Current; - Filename : String := Use_Current; - Session : Session_Type) - is - Filter_Active : Boolean; - pragma Unreferenced (Filter_Active); - - begin - Open (Separators, Filename, Session); - - while not End_Of_Data (Session) loop - Get_Line (None, Session); - Filter_Active := Apply_Filters (Session); - end loop; - - Close (Session); - end Parse; - - procedure Parse - (Separators : String := Use_Current; - Filename : String := Use_Current) - is - begin - Parse (Separators, Filename, Cur_Session); - end Parse; - - --------------------- - -- Raise_With_Info -- - --------------------- - - procedure Raise_With_Info - (E : Exceptions.Exception_Id; - Message : String; - Session : Session_Type) - is - function Filename return String; - -- Returns current filename and "??" if this information is not - -- available. - - function Line return String; - -- Returns current line number without the leading space - - -------------- - -- Filename -- - -------------- - - function Filename return String is - File : constant String := AWK.File (Session); - begin - if File = "" then - return "??"; - else - return File; - end if; - end Filename; - - ---------- - -- Line -- - ---------- - - function Line return String is - L : constant String := Natural'Image (Session.Data.FNR); - begin - return L (2 .. L'Last); - end Line; - - -- Start of processing for Raise_With_Info - - begin - Exceptions.Raise_Exception - (E, - '[' & Filename & ':' & Line & "] " & Message); - raise Constraint_Error; -- to please GNAT as this is a No_Return proc - end Raise_With_Info; - - --------------- - -- Read_Line -- - --------------- - - procedure Read_Line (Session : Session_Type) is - - function Read_Line return String; - -- Read a line in the current file. This implementation is recursive - -- and does not have a limitation on the line length. - - NR : Natural renames Session.Data.NR; - FNR : Natural renames Session.Data.FNR; - - --------------- - -- Read_Line -- - --------------- - - function Read_Line return String is - Buffer : String (1 .. 1_024); - Last : Natural; - - begin - Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last); - - if Last = Buffer'Last then - return Buffer & Read_Line; - else - return Buffer (1 .. Last); - end if; - end Read_Line; - - -- Start of processing for Read_Line - - begin - if End_Of_File (Session) then - Open_Next_File (Session); - FNR := 0; - end if; - - Session.Data.Current_Line := To_Unbounded_String (Read_Line); - - NR := NR + 1; - FNR := FNR + 1; - end Read_Line; - - -------------- - -- Register -- - -------------- - - procedure Register - (Field : Count; - Pattern : String; - Action : Action_Callback; - Session : Session_Type) - is - Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; - U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern); - - begin - Pattern_Action_Table.Increment_Last (Filters); - - Filters.Table (Pattern_Action_Table.Last (Filters)) := - (Pattern => new Patterns.String_Pattern'(U_Pattern, Field), - Action => new Actions.Simple_Action'(Proc => Action)); - end Register; - - procedure Register - (Field : Count; - Pattern : String; - Action : Action_Callback) - is - begin - Register (Field, Pattern, Action, Cur_Session); - end Register; - - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Action_Callback; - Session : Session_Type) - is - Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; - - A_Pattern : constant Patterns.Pattern_Matcher_Access := - new Regpat.Pattern_Matcher'(Pattern); - begin - Pattern_Action_Table.Increment_Last (Filters); - - Filters.Table (Pattern_Action_Table.Last (Filters)) := - (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), - Action => new Actions.Simple_Action'(Proc => Action)); - end Register; - - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Action_Callback) - is - begin - Register (Field, Pattern, Action, Cur_Session); - end Register; - - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Match_Action_Callback; - Session : Session_Type) - is - Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; - - A_Pattern : constant Patterns.Pattern_Matcher_Access := - new Regpat.Pattern_Matcher'(Pattern); - begin - Pattern_Action_Table.Increment_Last (Filters); - - Filters.Table (Pattern_Action_Table.Last (Filters)) := - (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), - Action => new Actions.Match_Action'(Proc => Action)); - end Register; - - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Match_Action_Callback) - is - begin - Register (Field, Pattern, Action, Cur_Session); - end Register; - - procedure Register - (Pattern : Pattern_Callback; - Action : Action_Callback; - Session : Session_Type) - is - Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; - - begin - Pattern_Action_Table.Increment_Last (Filters); - - Filters.Table (Pattern_Action_Table.Last (Filters)) := - (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern), - Action => new Actions.Simple_Action'(Proc => Action)); - end Register; - - procedure Register - (Pattern : Pattern_Callback; - Action : Action_Callback) - is - begin - Register (Pattern, Action, Cur_Session); - end Register; - - procedure Register - (Action : Action_Callback; - Session : Session_Type) - is - begin - Register (Always_True'Access, Action, Session); - end Register; - - procedure Register - (Action : Action_Callback) - is - begin - Register (Action, Cur_Session); - end Register; - - ----------------- - -- Set_Current -- - ----------------- - - procedure Set_Current (Session : Session_Type) is - begin - Cur_Session.Data := Session.Data; - end Set_Current; - - -------------------------- - -- Set_Field_Separators -- - -------------------------- - - procedure Set_Field_Separators - (Separators : String := Default_Separators; - Session : Session_Type) - is - begin - Free (Session.Data.Separators); - - Session.Data.Separators := - new Split.Separator'(Separators'Length, Separators); - - -- If there is a current line read, split it according to the new - -- separators. - - if Session.Data.Current_Line /= Null_Unbounded_String then - Split_Line (Session); - end if; - end Set_Field_Separators; - - procedure Set_Field_Separators - (Separators : String := Default_Separators) - is - begin - Set_Field_Separators (Separators, Cur_Session); - end Set_Field_Separators; - - ---------------------- - -- Set_Field_Widths -- - ---------------------- - - procedure Set_Field_Widths - (Field_Widths : Widths_Set; - Session : Session_Type) - is - begin - Free (Session.Data.Separators); - - Session.Data.Separators := - new Split.Column'(Field_Widths'Length, Field_Widths); - - -- If there is a current line read, split it according to - -- the new separators. - - if Session.Data.Current_Line /= Null_Unbounded_String then - Split_Line (Session); - end if; - end Set_Field_Widths; - - procedure Set_Field_Widths - (Field_Widths : Widths_Set) - is - begin - Set_Field_Widths (Field_Widths, Cur_Session); - end Set_Field_Widths; - - ---------------- - -- Split_Line -- - ---------------- - - procedure Split_Line (Session : Session_Type) is - Fields : Field_Table.Instance renames Session.Data.Fields; - begin - Field_Table.Init (Fields); - Split.Current_Line (Session.Data.Separators.all, Session); - end Split_Line; - - ------------- - -- Get_Def -- - ------------- - - function Get_Def return Session_Data_Access is - begin - return Def_Session.Data; - end Get_Def; - - ------------- - -- Set_Cur -- - ------------- - - procedure Set_Cur is - begin - Cur_Session.Data := Def_Session.Data; - end Set_Cur; - -begin - -- We have declared two sessions but both should share the same data. - -- The current session must point to the default session as its initial - -- value. So first we release the session data then we set current - -- session data to point to default session data. - - Free (Cur_Session.Data); - Cur_Session.Data := Def_Session.Data; -end GNAT.AWK; diff --git a/gcc/ada/g-awk.ads b/gcc/ada/g-awk.ads deleted file mode 100644 index c52403e..0000000 --- a/gcc/ada/g-awk.ads +++ /dev/null @@ -1,642 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . A W K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2015, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is an AWK-like unit. It provides an easy interface for parsing one --- or more files containing formatted data. The file can be viewed seen as --- a database where each record is a line and a field is a data element in --- this line. In this implementation an AWK record is a line. This means --- that a record cannot span multiple lines. The operating procedure is to --- read files line by line, with each line being presented to the user of --- the package. The interface provides services to access specific fields --- in the line. Thus it is possible to control actions taken on a line based --- on values of some fields. This can be achieved directly or by registering --- callbacks triggered on programmed conditions. --- --- The state of an AWK run is recorded in an object of type session. --- The following is the procedure for using a session to control an --- AWK run: --- --- 1) Specify which session is to be used. It is possible to use the --- default session or to create a new one by declaring an object of --- type Session_Type. For example: --- --- Computers : Session_Type; --- --- 2) Specify how to cut a line into fields. There are two modes: using --- character fields separators or column width. This is done by using --- Set_Fields_Separators or Set_Fields_Width. For example by: --- --- AWK.Set_Field_Separators (";,", Computers); --- --- or by using iterators' Separators parameter. --- --- 3) Specify which files to parse. This is done with Add_File/Add_Files --- services, or by using the iterators' Filename parameter. For --- example: --- --- AWK.Add_File ("myfile.db", Computers); --- --- 4) Run the AWK session using one of the provided iterators. --- --- Parse --- This is the most automated iterator. You can gain control on --- the session only by registering one or more callbacks (see --- Register). --- --- Get_Line/End_Of_Data --- This is a manual iterator to be used with a loop. You have --- complete control on the session. You can use callbacks but --- this is not required. --- --- For_Every_Line --- This provides a mixture of manual/automated iterator action. --- --- Examples of these three approaches appear below --- --- There are many ways to use this package. The following discussion shows --- three approaches to using this package, using the three iterator forms. --- All examples will use the following file (computer.db): --- --- Pluton;Windows-NT;Pentium III --- Mars;Linux;Pentium Pro --- Venus;Solaris;Sparc --- Saturn;OS/2;i486 --- Jupiter;MacOS;PPC --- --- 1) Using Parse iterator --- --- Here the first step is to register some action associated to a pattern --- and then to call the Parse iterator (this is the simplest way to use --- this unit). The default session is used here. For example to output the --- second field (the OS) of computer "Saturn". --- --- procedure Action is --- begin --- Put_Line (AWK.Field (2)); --- end Action; --- --- begin --- AWK.Register (1, "Saturn", Action'Access); --- AWK.Parse (";", "computer.db"); --- --- --- 2) Using the Get_Line/End_Of_Data iterator --- --- Here you have full control. For example to do the same as --- above but using a specific session, you could write: --- --- Computer_File : Session_Type; --- --- begin --- AWK.Set_Current (Computer_File); --- AWK.Open (Separators => ";", --- Filename => "computer.db"); --- --- -- Display Saturn OS --- --- while not AWK.End_Of_File loop --- AWK.Get_Line; --- --- if AWK.Field (1) = "Saturn" then --- Put_Line (AWK.Field (2)); --- end if; --- end loop; --- --- AWK.Close (Computer_File); --- --- --- 3) Using For_Every_Line iterator --- --- In this case you use a provided iterator and you pass the procedure --- that must be called for each record. You could code the previous --- example could be coded as follows (using the iterator quick interface --- but without using the current session): --- --- Computer_File : Session_Type; --- --- procedure Action (Quit : in out Boolean) is --- begin --- if AWK.Field (1, Computer_File) = "Saturn" then --- Put_Line (AWK.Field (2, Computer_File)); --- end if; --- end Action; --- --- procedure Look_For_Saturn is --- new AWK.For_Every_Line (Action); --- --- begin --- Look_For_Saturn (Separators => ";", --- Filename => "computer.db", --- Session => Computer_File); --- --- Integer_Text_IO.Put --- (Integer (AWK.NR (Session => Computer_File))); --- Put_Line (" line(s) have been processed."); --- --- You can also use a regular expression for the pattern. Let us output --- the computer name for all computer for which the OS has a character --- O in its name. --- --- Regexp : String := ".*O.*"; --- --- Matcher : Regpat.Pattern_Matcher := Regpat.Compile (Regexp); --- --- procedure Action is --- begin --- Text_IO.Put_Line (AWK.Field (2)); --- end Action; --- --- begin --- AWK.Register (2, Matcher, Action'Unrestricted_Access); --- AWK.Parse (";", "computer.db"); --- - -with Ada.Finalization; -with GNAT.Regpat; - -package GNAT.AWK is - - Session_Error : exception; - -- Raised when a Session is reused but is not closed - - File_Error : exception; - -- Raised when there is a file problem (see below) - - End_Error : exception; - -- Raised when an attempt is made to read beyond the end of the last - -- file of a session. - - Field_Error : exception; - -- Raised when accessing a field value which does not exist - - Data_Error : exception; - -- Raised when it is impossible to convert a field value to a specific type - - type Count is new Natural; - - type Widths_Set is array (Positive range <>) of Positive; - -- Used to store a set of columns widths - - Default_Separators : constant String := " " & ASCII.HT; - - Use_Current : constant String := ""; - -- Value used when no separator or filename is specified in iterators - - type Session_Type is limited private; - -- This is the main exported type. A session is used to keep the state of - -- a full AWK run. The state comprises a list of files, the current file, - -- the number of line processed, the current line, the number of fields in - -- the current line... A default session is provided (see Set_Current, - -- Current_Session and Default_Session below). - - ---------------------------- - -- Package initialization -- - ---------------------------- - - -- To be thread safe it is not possible to use the default provided - -- session. Each task must used a specific session and specify it - -- explicitly for every services. - - procedure Set_Current (Session : Session_Type); - -- Set the session to be used by default. This file will be used when the - -- Session parameter in following services is not specified. - - function Current_Session return not null access Session_Type; - -- Returns the session used by default by all services. This is the - -- latest session specified by Set_Current service or the session - -- provided by default with this implementation. - - function Default_Session return not null access Session_Type; - -- Returns the default session provided by this package. Note that this is - -- the session return by Current_Session if Set_Current has not been used. - - procedure Set_Field_Separators - (Separators : String := Default_Separators; - Session : Session_Type); - procedure Set_Field_Separators - (Separators : String := Default_Separators); - -- Set the field separators. Each character in the string is a field - -- separator. When a line is read it will be split by field using the - -- separators set here. Separators can be changed at any point and in this - -- case the current line is split according to the new separators. In the - -- special case that Separators is a space and a tabulation - -- (Default_Separators), fields are separated by runs of spaces and/or - -- tabs. - - procedure Set_FS - (Separators : String := Default_Separators; - Session : Session_Type) - renames Set_Field_Separators; - procedure Set_FS - (Separators : String := Default_Separators) - renames Set_Field_Separators; - -- FS is the AWK abbreviation for above service - - procedure Set_Field_Widths - (Field_Widths : Widths_Set; - Session : Session_Type); - procedure Set_Field_Widths - (Field_Widths : Widths_Set); - -- This is another way to split a line by giving the length (in number of - -- characters) of each field in a line. Field widths can be changed at any - -- point and in this case the current line is split according to the new - -- field lengths. A line split with this method must have a length equal or - -- greater to the total of the field widths. All characters remaining on - -- the line after the latest field are added to a new automatically - -- created field. - - procedure Add_File - (Filename : String; - Session : Session_Type); - procedure Add_File - (Filename : String); - -- Add Filename to the list of file to be processed. There is no limit on - -- the number of files that can be added. Files are processed in the order - -- they have been added (i.e. the filename list is FIFO). If Filename does - -- not exist or if it is not readable, File_Error is raised. - - procedure Add_Files - (Directory : String; - Filenames : String; - Number_Of_Files_Added : out Natural; - Session : Session_Type); - procedure Add_Files - (Directory : String; - Filenames : String; - Number_Of_Files_Added : out Natural); - -- Add all files matching the regular expression Filenames in the specified - -- directory to the list of file to be processed. There is no limit on - -- the number of files that can be added. Each file is processed in - -- the same order they have been added (i.e. the filename list is FIFO). - -- The number of files (possibly 0) added is returned in - -- Number_Of_Files_Added. - - ------------------------------------- - -- Information about current state -- - ------------------------------------- - - function Number_Of_Fields - (Session : Session_Type) return Count; - function Number_Of_Fields - return Count; - pragma Inline (Number_Of_Fields); - -- Returns the number of fields in the current record. It returns 0 when - -- no file is being processed. - - function NF - (Session : Session_Type) return Count - renames Number_Of_Fields; - function NF - return Count - renames Number_Of_Fields; - -- AWK abbreviation for above service - - function Number_Of_File_Lines - (Session : Session_Type) return Count; - function Number_Of_File_Lines - return Count; - pragma Inline (Number_Of_File_Lines); - -- Returns the current line number in the processed file. It returns 0 when - -- no file is being processed. - - function FNR (Session : Session_Type) return Count - renames Number_Of_File_Lines; - function FNR return Count - renames Number_Of_File_Lines; - -- AWK abbreviation for above service - - function Number_Of_Lines - (Session : Session_Type) return Count; - function Number_Of_Lines - return Count; - pragma Inline (Number_Of_Lines); - -- Returns the number of line processed until now. This is equal to number - -- of line in each already processed file plus FNR. It returns 0 when - -- no file is being processed. - - function NR (Session : Session_Type) return Count - renames Number_Of_Lines; - function NR return Count - renames Number_Of_Lines; - -- AWK abbreviation for above service - - function Number_Of_Files - (Session : Session_Type) return Natural; - function Number_Of_Files - return Natural; - pragma Inline (Number_Of_Files); - -- Returns the number of files associated with Session. This is the total - -- number of files added with Add_File and Add_Files services. - - function File (Session : Session_Type) return String; - function File return String; - -- Returns the name of the file being processed. It returns the empty - -- string when no file is being processed. - - --------------------- - -- Field accessors -- - --------------------- - - function Field - (Rank : Count; - Session : Session_Type) return String; - function Field - (Rank : Count) return String; - -- Returns field number Rank value of the current record. If Rank = 0 it - -- returns the current record (i.e. the line as read in the file). It - -- raises Field_Error if Rank > NF or if Session is not open. - - function Field - (Rank : Count; - Session : Session_Type) return Integer; - function Field - (Rank : Count) return Integer; - -- Returns field number Rank value of the current record as an integer. It - -- raises Field_Error if Rank > NF or if Session is not open. It - -- raises Data_Error if the field value cannot be converted to an integer. - - function Field - (Rank : Count; - Session : Session_Type) return Float; - function Field - (Rank : Count) return Float; - -- Returns field number Rank value of the current record as a float. It - -- raises Field_Error if Rank > NF or if Session is not open. It - -- raises Data_Error if the field value cannot be converted to a float. - - generic - type Discrete is (<>); - function Discrete_Field - (Rank : Count; - Session : Session_Type) return Discrete; - generic - type Discrete is (<>); - function Discrete_Field_Current_Session - (Rank : Count) return Discrete; - -- Returns field number Rank value of the current record as a type - -- Discrete. It raises Field_Error if Rank > NF. It raises Data_Error if - -- the field value cannot be converted to type Discrete. - - -------------------- - -- Pattern/Action -- - -------------------- - - -- AWK defines rules like "PATTERN { ACTION }". Which means that ACTION - -- will be executed if PATTERN match. A pattern in this implementation can - -- be a simple string (match function is equality), a regular expression, - -- a function returning a boolean. An action is associated to a pattern - -- using the Register services. - -- - -- Each procedure Register will add a rule to the set of rules for the - -- session. Rules are examined in the order they have been added. - - type Pattern_Callback is access function return Boolean; - -- This is a pattern function pointer. When it returns True the associated - -- action will be called. - - type Action_Callback is access procedure; - -- A simple action pointer - - type Match_Action_Callback is - access procedure (Matches : GNAT.Regpat.Match_Array); - -- An advanced action pointer used with a regular expression pattern. It - -- returns an array of all the matches. See GNAT.Regpat for further - -- information. - - procedure Register - (Field : Count; - Pattern : String; - Action : Action_Callback; - Session : Session_Type); - procedure Register - (Field : Count; - Pattern : String; - Action : Action_Callback); - -- Register an Action associated with a Pattern. The pattern here is a - -- simple string that must match exactly the field number specified. - - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Action_Callback; - Session : Session_Type); - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Action_Callback); - -- Register an Action associated with a Pattern. The pattern here is a - -- simple regular expression which must match the field number specified. - - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Match_Action_Callback; - Session : Session_Type); - procedure Register - (Field : Count; - Pattern : GNAT.Regpat.Pattern_Matcher; - Action : Match_Action_Callback); - -- Same as above but it pass the set of matches to the action - -- procedure. This is useful to analyze further why and where a regular - -- expression did match. - - procedure Register - (Pattern : Pattern_Callback; - Action : Action_Callback; - Session : Session_Type); - procedure Register - (Pattern : Pattern_Callback; - Action : Action_Callback); - -- Register an Action associated with a Pattern. The pattern here is a - -- function that must return a boolean. Action callback will be called if - -- the pattern callback returns True and nothing will happen if it is - -- False. This version is more general, the two other register services - -- trigger an action based on the value of a single field only. - - procedure Register - (Action : Action_Callback; - Session : Session_Type); - procedure Register - (Action : Action_Callback); - -- Register an Action that will be called for every line. This is - -- equivalent to a Pattern_Callback function always returning True. - - -------------------- - -- Parse iterator -- - -------------------- - - procedure Parse - (Separators : String := Use_Current; - Filename : String := Use_Current; - Session : Session_Type); - procedure Parse - (Separators : String := Use_Current; - Filename : String := Use_Current); - -- Launch the iterator, it will read every line in all specified - -- session's files. Registered callbacks are then called if the associated - -- pattern match. It is possible to specify a filename and a set of - -- separators directly. This offer a quick way to parse a single - -- file. These parameters will override those specified by Set_FS and - -- Add_File. The Session will be opened and closed automatically. - -- File_Error is raised if there is no file associated with Session, or if - -- a file associated with Session is not longer readable. It raises - -- Session_Error is Session is already open. - - ----------------------------------- - -- Get_Line/End_Of_Data Iterator -- - ----------------------------------- - - type Callback_Mode is (None, Only, Pass_Through); - -- These mode are used for Get_Line/End_Of_Data and For_Every_Line - -- iterators. The associated semantic is: - -- - -- None - -- callbacks are not active. This is the default mode for - -- Get_Line/End_Of_Data and For_Every_Line iterators. - -- - -- Only - -- callbacks are active, if at least one pattern match, the associated - -- action is called and this line will not be passed to the user. In - -- the Get_Line case the next line will be read (if there is some - -- line remaining), in the For_Every_Line case Action will - -- not be called for this line. - -- - -- Pass_Through - -- callbacks are active, for patterns which match the associated - -- action is called. Then the line is passed to the user. It means - -- that Action procedure is called in the For_Every_Line case and - -- that Get_Line returns with the current line active. - -- - - procedure Open - (Separators : String := Use_Current; - Filename : String := Use_Current; - Session : Session_Type); - procedure Open - (Separators : String := Use_Current; - Filename : String := Use_Current); - -- Open the first file and initialize the unit. This must be called once - -- before using Get_Line. It is possible to specify a filename and a set of - -- separators directly. This offer a quick way to parse a single file. - -- These parameters will override those specified by Set_FS and Add_File. - -- File_Error is raised if there is no file associated with Session, or if - -- the first file associated with Session is no longer readable. It raises - -- Session_Error is Session is already open. - - procedure Get_Line - (Callbacks : Callback_Mode := None; - Session : Session_Type); - procedure Get_Line - (Callbacks : Callback_Mode := None); - -- Read a line from the current input file. If the file index is at the - -- end of the current input file (i.e. End_Of_File is True) then the - -- following file is opened. If there is no more file to be processed, - -- exception End_Error will be raised. File_Error will be raised if Open - -- has not been called. Next call to Get_Line will return the following - -- line in the file. By default the registered callbacks are not called by - -- Get_Line, this can activated by setting Callbacks (see Callback_Mode - -- description above). File_Error may be raised if a file associated with - -- Session is not readable. - -- - -- When Callbacks is not None, it is possible to exhaust all the lines - -- of all the files associated with Session. In this case, File_Error - -- is not raised. - -- - -- This procedure can be used from a subprogram called by procedure Parse - -- or by an instantiation of For_Every_Line (see below). - - function End_Of_Data - (Session : Session_Type) return Boolean; - function End_Of_Data - return Boolean; - pragma Inline (End_Of_Data); - -- Returns True if there is no more data to be processed in Session. It - -- means that the latest session's file is being processed and that - -- there is no more data to be read in this file (End_Of_File is True). - - function End_Of_File - (Session : Session_Type) return Boolean; - function End_Of_File - return Boolean; - pragma Inline (End_Of_File); - -- Returns True when there is no more data to be processed on the current - -- session's file. - - procedure Close (Session : Session_Type); - -- Release all associated data with Session. All memory allocated will - -- be freed, the current file will be closed if needed, the callbacks - -- will be unregistered. Close is convenient in reestablishing a session - -- for new use. Get_Line is no longer usable (will raise File_Error) - -- except after a successful call to Open, Parse or an instantiation - -- of For_Every_Line. - - ----------------------------- - -- For_Every_Line iterator -- - ----------------------------- - - generic - with procedure Action (Quit : in out Boolean); - procedure For_Every_Line - (Separators : String := Use_Current; - Filename : String := Use_Current; - Callbacks : Callback_Mode := None; - Session : Session_Type); - generic - with procedure Action (Quit : in out Boolean); - procedure For_Every_Line_Current_Session - (Separators : String := Use_Current; - Filename : String := Use_Current; - Callbacks : Callback_Mode := None); - -- This is another iterator. Action will be called for each new - -- record. The iterator's termination can be controlled by setting Quit - -- to True. It is by default set to False. It is possible to specify a - -- filename and a set of separators directly. This offer a quick way to - -- parse a single file. These parameters will override those specified by - -- Set_FS and Add_File. By default the registered callbacks are not called - -- by For_Every_Line, this can activated by setting Callbacks (see - -- Callback_Mode description above). The Session will be opened and - -- closed automatically. File_Error is raised if there is no file - -- associated with Session. It raises Session_Error is Session is already - -- open. - -private - type Session_Data; - type Session_Data_Access is access Session_Data; - - type Session_Type is new Ada.Finalization.Limited_Controlled with record - Data : Session_Data_Access; - Self : not null access Session_Type := Session_Type'Unchecked_Access; - end record; - - procedure Initialize (Session : in out Session_Type); - procedure Finalize (Session : in out Session_Type); - -end GNAT.AWK; diff --git a/gcc/ada/g-binenv.adb b/gcc/ada/g-binenv.adb deleted file mode 100644 index 13e414d4..0000000 --- a/gcc/ada/g-binenv.adb +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- G N A T . B I N D _ E N V I R O N M E N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by AdaCore. -- --- -- ------------------------------------------------------------------------------- - -with System; - -package body GNAT.Bind_Environment is - - --------- - -- Get -- - --------- - - function Get (Key : String) return String is - use type System.Address; - - Bind_Env_Addr : System.Address; - pragma Import (C, Bind_Env_Addr, "__gl_bind_env_addr"); - -- Variable provided by init.c/s-init.ads, and initialized by - -- the binder generated file. - - Bind_Env : String (Positive); - for Bind_Env'Address use Bind_Env_Addr; - pragma Import (Ada, Bind_Env); - -- Import Bind_Env string from binder file. Note that we import - -- it here as a string with maximum boundaries. The "real" end - -- of the string is indicated by a NUL byte. - - Index, KLen, VLen : Integer; - - begin - if Bind_Env_Addr = System.Null_Address then - return ""; - end if; - - Index := Bind_Env'First; - loop - -- Index points to key length - - VLen := 0; - KLen := Character'Pos (Bind_Env (Index)); - exit when KLen = 0; - - Index := Index + KLen + 1; - - -- Index points to value length - - VLen := Character'Pos (Bind_Env (Index)); - exit when Bind_Env (Index - KLen .. Index - 1) = Key; - - Index := Index + VLen + 1; - end loop; - - return Bind_Env (Index + 1 .. Index + VLen); - end Get; - -end GNAT.Bind_Environment; diff --git a/gcc/ada/g-binenv.ads b/gcc/ada/g-binenv.ads deleted file mode 100644 index e3c181f..0000000 --- a/gcc/ada/g-binenv.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- G N A T . B I N D _ E N V I R O N M E N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by AdaCore. -- --- -- ------------------------------------------------------------------------------- - -package GNAT.Bind_Environment is - - pragma Pure; - - function Get (Key : String) return String; - -- Return the value associated with Key at bind time, - -- or an empty string if not found. - -end GNAT.Bind_Environment; diff --git a/gcc/ada/g-bubsor.adb b/gcc/ada/g-bubsor.adb deleted file mode 100644 index de2c389..0000000 --- a/gcc/ada/g-bubsor.adb +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B U B B L E _ S O R T _ A -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Bubble_Sort is - - ---------- - -- Sort -- - ---------- - - procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function) is - Switched : Boolean; - - begin - loop - Switched := False; - - for J in 1 .. N - 1 loop - if Lt (J + 1, J) then - Xchg (J, J + 1); - Switched := True; - end if; - end loop; - - exit when not Switched; - end loop; - end Sort; - -end GNAT.Bubble_Sort; diff --git a/gcc/ada/g-bubsor.ads b/gcc/ada/g-bubsor.ads deleted file mode 100644 index b91d8e1..0000000 --- a/gcc/ada/g-bubsor.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B U B B L E _ S O R T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Sort Utility (Using Bubblesort Algorithm) - --- This package provides a bubblesort routine that works with access to --- subprogram parameters, so that it can be used with different types with --- shared sorting code. - --- See also GNAT.Bubble_Sort_G and GNAT.Bubble_Sort_A. These are older --- versions of this routine. In some cases GNAT.Bubble_Sort_G may be a --- little faster than GNAT.Bubble_Sort, at the expense of generic code --- duplication and a less convenient interface. The generic version also --- has the advantage of being Pure, while this unit can only be Preelaborate. - -package GNAT.Bubble_Sort is - pragma Pure; - - -- The data to be sorted is assumed to be indexed by integer values from - -- 1 to N, where N is the number of items to be sorted. - - type Xchg_Procedure is access procedure (Op1, Op2 : Natural); - -- A pointer to a procedure that exchanges the two data items whose - -- index values are Op1 and Op2. - - type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; - -- A pointer to a function that compares two items and returns True if - -- the item with index value Op1 is less than the item with Index value - -- Op2, and False if the Op1 item is greater than or equal to the Op2 - -- item. - - procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function); - -- This procedures sorts items in the range from 1 to N into ascending - -- order making calls to Lt to do required comparisons, and calls to - -- Xchg to exchange items. The sort is stable, that is the order of - -- equal items in the input is preserved. - -end GNAT.Bubble_Sort; diff --git a/gcc/ada/g-busora.adb b/gcc/ada/g-busora.adb deleted file mode 100644 index ca44d6b..0000000 --- a/gcc/ada/g-busora.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B U B B L E _ S O R T _ A -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Bubble_Sort_A is - - ---------- - -- Sort -- - ---------- - - procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is - Switched : Boolean; - - begin - loop - Switched := False; - - for J in 1 .. N - 1 loop - if Lt (J + 1, J) then - Move (J, 0); - Move (J + 1, J); - Move (0, J + 1); - Switched := True; - end if; - end loop; - - exit when not Switched; - end loop; - end Sort; - -end GNAT.Bubble_Sort_A; diff --git a/gcc/ada/g-busora.ads b/gcc/ada/g-busora.ads deleted file mode 100644 index 919f6ab..0000000 --- a/gcc/ada/g-busora.ads +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B U B B L E _ S O R T _ A -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Bubblesort using access to procedure parameters - --- This package provides a bubble sort routine that works with access to --- subprogram parameters, so that it can be used with different types with --- shared sorting code. It is considered obsoleted by GNAT.Bubble_Sort which --- offers a similar routine with a more convenient interface. - -package GNAT.Bubble_Sort_A is - pragma Preelaborate; - - -- The data to be sorted is assumed to be indexed by integer values from - -- 1 to N, where N is the number of items to be sorted. In addition, the - -- index value zero is used for a temporary location used during the sort. - - type Move_Procedure is access procedure (From : Natural; To : Natural); - -- A pointer to a procedure that moves the data item with index From to - -- the data item with index To. An index value of zero is used for moves - -- from and to the single temporary location used by the sort. - - type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; - -- A pointer to a function that compares two items and returns True if - -- the item with index Op1 is less than the item with index Op2, and False - -- if the Op2 item is greater than or equal to the Op1 item. - - procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function); - -- This procedures sorts items in the range from 1 to N into ascending - -- order making calls to Lt to do required comparisons, and Move to move - -- items around. Note that, as described above, both Move and Lt use a - -- single temporary location with index value zero. This sort is not - -- stable, i.e. the order of equal elements in the input is not preserved. - -end GNAT.Bubble_Sort_A; diff --git a/gcc/ada/g-busorg.adb b/gcc/ada/g-busorg.adb deleted file mode 100644 index 677c642..0000000 --- a/gcc/ada/g-busorg.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B U B B L E _ S O R T _ G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Bubble_Sort_G is - - ---------- - -- Sort -- - ---------- - - procedure Sort (N : Natural) is - Switched : Boolean; - - begin - loop - Switched := False; - - for J in 1 .. N - 1 loop - if Lt (J + 1, J) then - Move (J, 0); - Move (J + 1, J); - Move (0, J + 1); - Switched := True; - end if; - end loop; - - exit when not Switched; - end loop; - end Sort; - -end GNAT.Bubble_Sort_G; diff --git a/gcc/ada/g-busorg.ads b/gcc/ada/g-busorg.ads deleted file mode 100644 index 5b7d102..0000000 --- a/gcc/ada/g-busorg.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B U B B L E _ S O R T _ G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Bubblesort generic package using formal procedures - --- This package provides a generic bubble sort routine that can be used with --- different types of data. - --- See also GNAT.Bubble_Sort, a version that works with subprogram access --- parameters, allowing code sharing. The generic version is slightly more --- efficient but does not allow code sharing and has an interface that is --- more awkward to use. - --- There is also GNAT.Bubble_Sort_A, which is now considered obsolete, but --- was an older version working with subprogram parameters. This version --- is retained for backwards compatibility with old versions of GNAT. - -generic - -- The data to be sorted is assumed to be indexed by integer values from - -- 1 to N, where N is the number of items to be sorted. In addition, the - -- index value zero is used for a temporary location used during the sort. - - with procedure Move (From : Natural; To : Natural); - -- A procedure that moves the data item with index value From to the data - -- item with index value To (the old value in To being lost). An index - -- value of zero is used for moves from and to a single temporary location - -- used by the sort. - - with function Lt (Op1, Op2 : Natural) return Boolean; - -- A function that compares two items and returns True if the item with - -- index Op1 is less than the item with Index Op2, and False if the Op2 - -- item is greater than or equal to the Op1 item. - -package GNAT.Bubble_Sort_G is - pragma Pure; - - procedure Sort (N : Natural); - -- This procedures sorts items in the range from 1 to N into ascending - -- order making calls to Lt to do required comparisons, and Move to move - -- items around. Note that, as described above, both Move and Lt use a - -- single temporary location with index value zero. This sort is stable, - -- that is the order of equal elements in the input is preserved. - -end GNAT.Bubble_Sort_G; diff --git a/gcc/ada/g-byorma.adb b/gcc/ada/g-byorma.adb deleted file mode 100644 index 0b389f5..0000000 --- a/gcc/ada/g-byorma.adb +++ /dev/null @@ -1,195 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . B Y T E _ O R D E R _ M A R K -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body GNAT.Byte_Order_Mark is - - -------------- - -- Read_BOM -- - -------------- - - procedure Read_BOM - (Str : String; - Len : out Natural; - BOM : out BOM_Kind; - XML_Support : Boolean := False) - is - begin - -- Note: the order of these tests is important, because in some cases - -- one sequence is a prefix of a longer sequence, and we must test for - -- the longer sequence first - - -- UTF-32 (big-endian) - - if Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#00#) - and then Str (Str'First + 1) = Character'Val (16#00#) - and then Str (Str'First + 2) = Character'Val (16#FE#) - and then Str (Str'First + 3) = Character'Val (16#FF#) - then - Len := 4; - BOM := UTF32_BE; - - -- UTF-32 (little-endian) - - elsif Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#FF#) - and then Str (Str'First + 1) = Character'Val (16#FE#) - and then Str (Str'First + 2) = Character'Val (16#00#) - and then Str (Str'First + 3) = Character'Val (16#00#) - then - Len := 4; - BOM := UTF32_LE; - - -- UTF-16 (big-endian) - - elsif Str'Length >= 2 - and then Str (Str'First) = Character'Val (16#FE#) - and then Str (Str'First + 1) = Character'Val (16#FF#) - then - Len := 2; - BOM := UTF16_BE; - - -- UTF-16 (little-endian) - - elsif Str'Length >= 2 - and then Str (Str'First) = Character'Val (16#FF#) - and then Str (Str'First + 1) = Character'Val (16#FE#) - then - Len := 2; - BOM := UTF16_LE; - - -- UTF-8 (endian-independent) - - elsif Str'Length >= 3 - and then Str (Str'First) = Character'Val (16#EF#) - and then Str (Str'First + 1) = Character'Val (16#BB#) - and then Str (Str'First + 2) = Character'Val (16#BF#) - then - Len := 3; - BOM := UTF8_All; - - -- UCS-4 (big-endian) XML only - - elsif XML_Support - and then Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#00#) - and then Str (Str'First + 1) = Character'Val (16#00#) - and then Str (Str'First + 2) = Character'Val (16#00#) - and then Str (Str'First + 3) = Character'Val (16#3C#) - then - Len := 0; - BOM := UCS4_BE; - - -- UCS-4 (little-endian) XML case - - elsif XML_Support - and then Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#3C#) - and then Str (Str'First + 1) = Character'Val (16#00#) - and then Str (Str'First + 2) = Character'Val (16#00#) - and then Str (Str'First + 3) = Character'Val (16#00#) - then - Len := 0; - BOM := UCS4_LE; - - -- UCS-4 (unusual byte order 2143) XML case - - elsif XML_Support - and then Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#00#) - and then Str (Str'First + 1) = Character'Val (16#00#) - and then Str (Str'First + 2) = Character'Val (16#3C#) - and then Str (Str'First + 3) = Character'Val (16#00#) - then - Len := 0; - BOM := UCS4_2143; - - -- UCS-4 (unusual byte order 3412) XML case - - elsif XML_Support - and then Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#00#) - and then Str (Str'First + 1) = Character'Val (16#3C#) - and then Str (Str'First + 2) = Character'Val (16#00#) - and then Str (Str'First + 3) = Character'Val (16#00#) - then - Len := 0; - BOM := UCS4_3412; - - -- UTF-16 (big-endian) XML case - - elsif XML_Support - and then Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#00#) - and then Str (Str'First + 1) = Character'Val (16#3C#) - and then Str (Str'First + 2) = Character'Val (16#00#) - and then Str (Str'First + 3) = Character'Val (16#3F#) - then - Len := 0; - BOM := UTF16_BE; - - -- UTF-32 (little-endian) XML case - - elsif XML_Support - and then Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#3C#) - and then Str (Str'First + 1) = Character'Val (16#00#) - and then Str (Str'First + 2) = Character'Val (16#3F#) - and then Str (Str'First + 3) = Character'Val (16#00#) - then - Len := 0; - BOM := UTF16_LE; - - -- Unrecognized special encodings XML only - - elsif XML_Support - and then Str'Length >= 4 - and then Str (Str'First) = Character'Val (16#3C#) - and then Str (Str'First + 1) = Character'Val (16#3F#) - and then Str (Str'First + 2) = Character'Val (16#78#) - and then Str (Str'First + 3) = Character'Val (16#6D#) - then - -- UTF-8, ASCII, some part of ISO8859, Shift-JIS, EUC,... - - Len := 0; - BOM := Unknown; - - -- No BOM recognized - - else - Len := 0; - BOM := Unknown; - end if; - end Read_BOM; - -end GNAT.Byte_Order_Mark; diff --git a/gcc/ada/g-byorma.ads b/gcc/ada/g-byorma.ads deleted file mode 100644 index a58006e..0000000 --- a/gcc/ada/g-byorma.ads +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . B Y T E _ O R D E R _ M A R K -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 procedure for reading and interpreting the BOM --- (byte order mark) used to publish the encoding method for a string (for --- example, a UTF-8 encoded file in windows will start with the appropriate --- BOM sequence to signal UTF-8 encoding). - --- There are two cases - --- Case 1. UTF encodings for Unicode files - --- Here the convention is to have the first character of the file be a --- non-breaking zero width space character (16#0000_FEFF#). For the UTF --- encodings, the representation of this character can be used to uniquely --- determine the encoding. Furthermore, the possibility of any confusion --- with unencoded files is minimal, since for example the UTF-8 encoding --- of this character looks like the sequence: - --- LC_I_Diaeresis --- Right_Angle_Quotation --- Fraction_One_Half - --- which is so unlikely to occur legitimately in normal use that it can --- safely be ignored in most cases (for example, no legitimate Ada source --- file could start with this sequence of characters). - --- Case 2. Specialized XML encodings - --- The XML standard defines a number of other possible encodings and also --- defines standardized sequences for marking these encodings. This package --- can also optionally handle these XML defined BOM sequences. These XML --- cases depend on the first character of the XML file being < so that the --- encoding of this character can be recognized. - -pragma Compiler_Unit_Warning; - -package GNAT.Byte_Order_Mark is - - type BOM_Kind is - (UTF8_All, -- UTF8-encoding - UTF16_LE, -- UTF16 little-endian encoding - UTF16_BE, -- UTF16 big-endian encoding - UTF32_LE, -- UTF32 little-endian encoding - UTF32_BE, -- UTF32 big-endian encoding - - -- The following cases are for XML only - - UCS4_BE, -- UCS-4, big endian machine (1234 order) - UCS4_LE, -- UCS-4, little endian machine (4321 order) - UCS4_2143, -- UCS-4, unusual byte order (2143 order) - UCS4_3412, -- UCS-4, unusual byte order (3412 order) - - -- Value returned if no BOM recognized - - Unknown); -- Unknown, assumed to be ASCII compatible - - procedure Read_BOM - (Str : String; - Len : out Natural; - BOM : out BOM_Kind; - XML_Support : Boolean := False); - -- This is the routine to read the BOM from the start of the given string - -- Str. On return BOM is set to the appropriate BOM_Kind and Len is set to - -- its length. The caller will typically skip the first Len characters in - -- the string to ignore the BOM sequence. The special XML possibilities are - -- recognized only if flag XML_Support is set to True. Note that for the - -- XML cases, Len is always set to zero on return (not to the length of the - -- relevant sequence) since in the XML cases, the sequence recognized is - -- for the first real character in the file (<) which is not to be skipped. - -end GNAT.Byte_Order_Mark; diff --git a/gcc/ada/g-bytswa.adb b/gcc/ada/g-bytswa.adb deleted file mode 100644 index 9628bbc..0000000 --- a/gcc/ada/g-bytswa.adb +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B Y T E _ S W A P P I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2012, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a general implementation that uses GCC intrinsics to take --- advantage of any machine-specific instructions. - -with Ada.Unchecked_Conversion; use Ada; - -with System.Byte_Swapping; use System.Byte_Swapping; - -package body GNAT.Byte_Swapping is - - -------------- - -- Swapped2 -- - -------------- - - function Swapped2 (Input : Item) return Item is - function As_U16 is new Unchecked_Conversion (Item, U16); - function As_Item is new Unchecked_Conversion (U16, Item); - pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 2, - "storage size must be 2 bytes"); - begin - return As_Item (Bswap_16 (As_U16 (Input))); - end Swapped2; - - -------------- - -- Swapped4 -- - -------------- - - function Swapped4 (Input : Item) return Item is - function As_U32 is new Unchecked_Conversion (Item, U32); - function As_Item is new Unchecked_Conversion (U32, Item); - pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 4, - "storage size must be 4 bytes"); - begin - return As_Item (Bswap_32 (As_U32 (Input))); - end Swapped4; - - -------------- - -- Swapped8 -- - -------------- - - function Swapped8 (Input : Item) return Item is - function As_U64 is new Unchecked_Conversion (Item, U64); - function As_Item is new Unchecked_Conversion (U64, Item); - pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 8, - "storage size must be 8 bytes"); - begin - return As_Item (Bswap_64 (As_U64 (Input))); - end Swapped8; - - ----------- - -- Swap2 -- - ----------- - - procedure Swap2 (Location : System.Address) is - X : U16; - for X'Address use Location; - begin - X := Bswap_16 (X); - end Swap2; - - ----------- - -- Swap4 -- - ----------- - - procedure Swap4 (Location : System.Address) is - X : U32; - for X'Address use Location; - begin - X := Bswap_32 (X); - end Swap4; - - ----------- - -- Swap8 -- - ----------- - - procedure Swap8 (Location : System.Address) is - X : U64; - for X'Address use Location; - begin - X := Bswap_64 (X); - end Swap8; - -end GNAT.Byte_Swapping; diff --git a/gcc/ada/g-bytswa.ads b/gcc/ada/g-bytswa.ads deleted file mode 100644 index 35656fc..0000000 --- a/gcc/ada/g-bytswa.ads +++ /dev/null @@ -1,206 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . B Y T E _ S W A P P I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2012, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Simple routines for swapping the bytes of 16-, 32-, and 64-bit objects - --- The generic functions should be instantiated with types that are of a size --- in bytes corresponding to the name of the generic. For example, a 2-byte --- integer type would be compatible with Swapped2, 4-byte integer with --- Swapped4, and so on. Failure to do so will result in a warning when --- compiling the instantiation; this warning should be heeded. Ignoring this --- warning can result in unexpected results. - --- An example of proper usage follows: - --- declare --- type Short_Integer is range -32768 .. 32767; --- for Short_Integer'Size use 16; -- for confirmation - --- X : Short_Integer := 16#7FFF#; - --- function Swapped is new Byte_Swapping.Swapped2 (Short_Integer); - --- begin --- Put_Line (X'Img); --- X := Swapped (X); --- Put_Line (X'Img); --- end; - --- Note that the generic actual types need not be scalars, but must be --- 'definite' types. They can, for example, be constrained subtypes of --- unconstrained array types as long as the size is correct. For instance, --- a subtype of String with length of 4 would be compatible with the --- Swapped4 generic: - --- declare --- subtype String4 is String (1 .. 4); --- function Swapped is new Byte_Swapping.Swapped4 (String4); --- S : String4 := "ABCD"; --- for S'Alignment use 4; --- begin --- Put_Line (S); --- S := Swapped (S); --- Put_Line (S); --- end; - --- Similarly, a constrained array type is also acceptable: - --- declare --- type Mask is array (0 .. 15) of Boolean; --- for Mask'Alignment use 2; --- for Mask'Component_Size use Boolean'Size; --- X : Mask := (0 .. 7 => True, others => False); --- function Swapped is new Byte_Swapping.Swapped2 (Mask); --- begin --- ... --- X := Swapped (X); --- ... --- end; - --- A properly-sized record type will also be acceptable, and so forth - --- However, as described, a size mismatch must be avoided. In the following we --- instantiate one of the generics with a type that is too large. The result --- of the function call is undefined, such that assignment to an object can --- result in garbage values. - --- Wrong: declare --- subtype String16 is String (1 .. 16); - --- function Swapped is new Byte_Swapping.Swapped8 (String16); --- -- Instantiation generates a compiler warning about --- -- mismatched sizes - --- S : String16; - --- begin --- S := "ABCDEFGHDEADBEEF"; --- --- Put_Line (S); --- --- -- the following assignment results in garbage in S after the --- -- first 8 bytes --- --- S := Swapped (S); --- --- Put_Line (S); --- end Wrong; - --- When the size of the type is larger than 8 bytes, the use of the non- --- generic procedures is an alternative because no function result is --- involved; manipulation of the object is direct. - --- The procedures are passed the address of an object to manipulate. They will --- swap the first N bytes of that object corresponding to the name of the --- procedure. For example: - --- declare --- S2 : String := "AB"; --- for S2'Alignment use 2; --- S4 : String := "ABCD"; --- for S4'Alignment use 4; --- S8 : String := "ABCDEFGH"; --- for S8'Alignment use 8; - --- begin --- Swap2 (S2'Address); --- Put_Line (S2); - --- Swap4 (S4'Address); --- Put_Line (S4); - --- Swap8 (S8'Address); --- Put_Line (S8); --- end; - --- If an object of a type larger than N is passed, the remaining bytes of the --- object are undisturbed. For example: - --- declare --- subtype String16 is String (1 .. 16); - --- S : String16; --- for S'Alignment use 8; - --- begin --- S := "ABCDEFGHDEADBEEF"; --- Put_Line (S); --- Swap8 (S'Address); --- Put_Line (S); --- end; - -with System; - -package GNAT.Byte_Swapping is - pragma Pure; - - -- NB: all the routines in this package treat the application objects as - -- unsigned (modular) types of a size in bytes corresponding to the routine - -- name. For example, the generic function Swapped2 manipulates the object - -- passed to the formal parameter Input as a value of an unsigned type that - -- is 2 bytes long. Therefore clients are responsible for the compatibility - -- of application types manipulated by these routines and these modular - -- types, in terms of both size and alignment. This requirement applies to - -- the generic actual type passed to the generic formal type Item in the - -- generic functions, as well as to the type of the object implicitly - -- designated by the address passed to the non-generic procedures. Use of - -- incompatible types can result in implementation- defined effects. - - generic - type Item is limited private; - function Swapped2 (Input : Item) return Item; - -- Return the 2-byte value of Input with the bytes swapped - - generic - type Item is limited private; - function Swapped4 (Input : Item) return Item; - -- Return the 4-byte value of Input with the bytes swapped - - generic - type Item is limited private; - function Swapped8 (Input : Item) return Item; - -- Return the 8-byte value of Input with the bytes swapped - - procedure Swap2 (Location : System.Address); - -- Swap the first 2 bytes of the object starting at the address specified - -- by Location. - - procedure Swap4 (Location : System.Address); - -- Swap the first 4 bytes of the object starting at the address specified - -- by Location. - - procedure Swap8 (Location : System.Address); - -- Swap the first 8 bytes of the object starting at the address specified - -- by Location. - - pragma Inline (Swap2, Swap4, Swap8, Swapped2, Swapped4, Swapped8); - -end GNAT.Byte_Swapping; diff --git a/gcc/ada/g-calend.adb b/gcc/ada/g-calend.adb deleted file mode 100644 index 8f309de..0000000 --- a/gcc/ada/g-calend.adb +++ /dev/null @@ -1,652 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C A L E N D A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C.Extensions; - -package body GNAT.Calendar is - use Ada.Calendar; - use Interfaces; - - ----------------- - -- Day_In_Year -- - ----------------- - - function Day_In_Year (Date : Time) return Day_In_Year_Number is - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - pragma Unreferenced (Day_Secs); - begin - Split (Date, Year, Month, Day, Day_Secs); - return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1; - end Day_In_Year; - - ----------------- - -- Day_Of_Week -- - ----------------- - - function Day_Of_Week (Date : Time) return Day_Name is - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - pragma Unreferenced (Day_Secs); - begin - Split (Date, Year, Month, Day, Day_Secs); - return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7); - end Day_Of_Week; - - ---------- - -- Hour -- - ---------- - - function Hour (Date : Time) return Hour_Number is - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration; - pragma Unreferenced (Year, Month, Day, Minute, Second, Sub_Second); - begin - Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); - return Hour; - end Hour; - - ---------------- - -- Julian_Day -- - ---------------- - - -- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this - -- implementation is not expensive. - - function Julian_Day - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number) return Integer - is - Internal_Year : Integer; - Internal_Month : Integer; - Internal_Day : Integer; - Julian_Date : Integer; - C : Integer; - Ya : Integer; - - begin - Internal_Year := Integer (Year); - Internal_Month := Integer (Month); - Internal_Day := Integer (Day); - - if Internal_Month > 2 then - Internal_Month := Internal_Month - 3; - else - Internal_Month := Internal_Month + 9; - Internal_Year := Internal_Year - 1; - end if; - - C := Internal_Year / 100; - Ya := Internal_Year - (100 * C); - - Julian_Date := (146_097 * C) / 4 + - (1_461 * Ya) / 4 + - (153 * Internal_Month + 2) / 5 + - Internal_Day + 1_721_119; - - return Julian_Date; - end Julian_Day; - - ------------ - -- Minute -- - ------------ - - function Minute (Date : Time) return Minute_Number is - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration; - pragma Unreferenced (Year, Month, Day, Hour, Second, Sub_Second); - begin - Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); - return Minute; - end Minute; - - ------------ - -- Second -- - ------------ - - function Second (Date : Time) return Second_Number is - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration; - pragma Unreferenced (Year, Month, Day, Hour, Minute, Sub_Second); - begin - Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); - return Second; - end Second; - - ----------- - -- Split -- - ----------- - - procedure Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration) - is - Day_Secs : Day_Duration; - Secs : Natural; - - begin - Split (Date, Year, Month, Day, Day_Secs); - - Secs := (if Day_Secs = 0.0 then 0 else Natural (Day_Secs - 0.5)); - Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs)); - Hour := Hour_Number (Secs / 3_600); - Secs := Secs mod 3_600; - Minute := Minute_Number (Secs / 60); - Second := Second_Number (Secs mod 60); - end Split; - - --------------------- - -- Split_At_Locale -- - --------------------- - - procedure Split_At_Locale - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration) - is - procedure Ada_Calendar_Split - (Date : Time; - Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Day_Secs : out Day_Duration; - Hour : out Integer; - Minute : out Integer; - Second : out Integer; - Sub_Sec : out Duration; - Leap_Sec : out Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer); - pragma Import (Ada, Ada_Calendar_Split, "__gnat_split"); - - Ds : Day_Duration; - Le : Boolean; - - pragma Unreferenced (Ds, Le); - - begin - -- Even though the input time zone is UTC (0), the flag Use_TZ will - -- ensure that Split picks up the local time zone. - - Ada_Calendar_Split - (Date => Date, - Year => Year, - Month => Month, - Day => Day, - Day_Secs => Ds, - Hour => Hour, - Minute => Minute, - Second => Second, - Sub_Sec => Sub_Second, - Leap_Sec => Le, - Use_TZ => False, - Is_Historic => False, - Time_Zone => 0); - end Split_At_Locale; - - ---------------- - -- Sub_Second -- - ---------------- - - function Sub_Second (Date : Time) return Second_Duration is - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration; - pragma Unreferenced (Year, Month, Day, Hour, Minute, Second); - begin - Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); - return Sub_Second; - end Sub_Second; - - ------------- - -- Time_Of -- - ------------- - - function Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0) return Time - is - Day_Secs : constant Day_Duration := - Day_Duration (Hour * 3_600) + - Day_Duration (Minute * 60) + - Day_Duration (Second) + - Sub_Second; - begin - return Time_Of (Year, Month, Day, Day_Secs); - end Time_Of; - - ----------------------- - -- Time_Of_At_Locale -- - ----------------------- - - function Time_Of_At_Locale - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0) return Time - is - function Ada_Calendar_Time_Of - (Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Day_Secs : Day_Duration; - Hour : Integer; - Minute : Integer; - Second : Integer; - Sub_Sec : Duration; - Leap_Sec : Boolean; - Use_Day_Secs : Boolean; - Use_TZ : Boolean; - Is_Historic : Boolean; - Time_Zone : Long_Integer) return Time; - pragma Import (Ada, Ada_Calendar_Time_Of, "__gnat_time_of"); - - begin - -- Even though the input time zone is UTC (0), the flag Use_TZ will - -- ensure that Split picks up the local time zone. - - return - Ada_Calendar_Time_Of - (Year => Year, - Month => Month, - Day => Day, - Day_Secs => 0.0, - Hour => Hour, - Minute => Minute, - Second => Second, - Sub_Sec => Sub_Second, - Leap_Sec => False, - Use_Day_Secs => False, - Use_TZ => False, - Is_Historic => False, - Time_Zone => 0); - end Time_Of_At_Locale; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (T : not null access timeval) return Duration is - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access C.Extensions.long_long; - usec : not null access C.long); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased C.Extensions.long_long; - usec : aliased C.long; - - begin - timeval_to_duration (T, sec'Access, usec'Access); - return Duration (sec) + Duration (usec) / Micro; - end To_Duration; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (D : Duration) return timeval is - - procedure duration_to_timeval - (Sec : C.Extensions.long_long; - Usec : C.long; - T : not null access timeval); - pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval"); - - Micro : constant := 10**6; - Result : aliased timeval; - sec : C.Extensions.long_long; - usec : C.long; - - begin - if D = 0.0 then - sec := 0; - usec := 0; - else - sec := C.Extensions.long_long (D - 0.5); - usec := C.long ((D - Duration (sec)) * Micro - 0.5); - end if; - - duration_to_timeval (sec, usec, Result'Access); - - return Result; - end To_Timeval; - - ------------------ - -- Week_In_Year -- - ------------------ - - function Week_In_Year (Date : Time) return Week_In_Year_Number is - Year : Year_Number; - Week : Week_In_Year_Number; - pragma Unreferenced (Year); - begin - Year_Week_In_Year (Date, Year, Week); - return Week; - end Week_In_Year; - - ----------------------- - -- Year_Week_In_Year -- - ----------------------- - - procedure Year_Week_In_Year - (Date : Time; - Year : out Year_Number; - Week : out Week_In_Year_Number) - is - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration; - Jan_1 : Day_Name; - Shift : Week_In_Year_Number; - Start_Week : Week_In_Year_Number; - - pragma Unreferenced (Hour, Minute, Second, Sub_Second); - - function Is_Leap (Year : Year_Number) return Boolean; - -- Return True if Year denotes a leap year. Leap centennial years are - -- properly handled. - - function Jan_1_Day_Of_Week - (Jan_1 : Day_Name; - Year : Year_Number; - Last_Year : Boolean := False; - Next_Year : Boolean := False) return Day_Name; - -- Given the weekday of January 1 in Year, determine the weekday on - -- which January 1 fell last year or will fall next year as set by - -- the two flags. This routine does not call Time_Of or Split. - - function Last_Year_Has_53_Weeks - (Jan_1 : Day_Name; - Year : Year_Number) return Boolean; - -- Given the weekday of January 1 in Year, determine whether last year - -- has 53 weeks. A False value implies that the year has 52 weeks. - - ------------- - -- Is_Leap -- - ------------- - - function Is_Leap (Year : Year_Number) return Boolean is - begin - if Year mod 400 = 0 then - return True; - elsif Year mod 100 = 0 then - return False; - else - return Year mod 4 = 0; - end if; - end Is_Leap; - - ----------------------- - -- Jan_1_Day_Of_Week -- - ----------------------- - - function Jan_1_Day_Of_Week - (Jan_1 : Day_Name; - Year : Year_Number; - Last_Year : Boolean := False; - Next_Year : Boolean := False) return Day_Name - is - Shift : Integer := 0; - - begin - if Last_Year then - Shift := (if Is_Leap (Year - 1) then -2 else -1); - elsif Next_Year then - Shift := (if Is_Leap (Year) then 2 else 1); - end if; - - return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7); - end Jan_1_Day_Of_Week; - - ---------------------------- - -- Last_Year_Has_53_Weeks -- - ---------------------------- - - function Last_Year_Has_53_Weeks - (Jan_1 : Day_Name; - Year : Year_Number) return Boolean - is - Last_Jan_1 : constant Day_Name := - Jan_1_Day_Of_Week (Jan_1, Year, Last_Year => True); - - begin - -- These two cases are illustrated in the table below - - return - Last_Jan_1 = Thursday - or else (Last_Jan_1 = Wednesday and then Is_Leap (Year - 1)); - end Last_Year_Has_53_Weeks; - - -- Start of processing for Week_In_Year - - begin - Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); - - -- According to ISO 8601, the first week of year Y is the week that - -- contains the first Thursday in year Y. The following table contains - -- all possible combinations of years and weekdays along with examples. - - -- +-------+------+-------+---------+ - -- | Jan 1 | Leap | Weeks | Example | - -- +-------+------+-------+---------+ - -- | Mon | No | 52 | 2007 | - -- +-------+------+-------+---------+ - -- | Mon | Yes | 52 | 1996 | - -- +-------+------+-------+---------+ - -- | Tue | No | 52 | 2002 | - -- +-------+------+-------+---------+ - -- | Tue | Yes | 52 | 1980 | - -- +-------+------+-------+---------+ - -- | Wed | No | 52 | 2003 | - -- +-------+------#########---------+ - -- | Wed | Yes # 53 # 1992 | - -- +-------+------#-------#---------+ - -- | Thu | No # 53 # 1998 | - -- +-------+------#-------#---------+ - -- | Thu | Yes # 53 # 2004 | - -- +-------+------#########---------+ - -- | Fri | No | 52 | 1999 | - -- +-------+------+-------+---------+ - -- | Fri | Yes | 52 | 1988 | - -- +-------+------+-------+---------+ - -- | Sat | No | 52 | 1994 | - -- +-------+------+-------+---------+ - -- | Sat | Yes | 52 | 1972 | - -- +-------+------+-------+---------+ - -- | Sun | No | 52 | 1995 | - -- +-------+------+-------+---------+ - -- | Sun | Yes | 52 | 1956 | - -- +-------+------+-------+---------+ - - -- A small optimization, the input date is January 1. Note that this - -- is a key day since it determines the number of weeks and is used - -- when special casing the first week of January and the last week of - -- December. - - Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1 - then Date - else (Time_Of (Year, 1, 1, 0.0))); - - -- Special cases for January - - if Month = 1 then - - -- Special case 1: January 1, 2 and 3. These three days may belong - -- to last year's last week which can be week number 52 or 53. - - -- +-----+-----+-----+=====+-----+-----+-----+ - -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 26 | 27 | 28 # 29 # 30 | 31 | 1 | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 27 | 28 | 29 # 30 # 31 | 1 | 2 | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 28 | 29 | 30 # 31 # 1 | 2 | 3 | - -- +-----+-----+-----+=====+-----+-----+-----+ - - if (Day = 1 and then Jan_1 in Friday .. Sunday) - or else - (Day = 2 and then Jan_1 in Friday .. Saturday) - or else - (Day = 3 and then Jan_1 = Friday) - then - Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52); - - -- January 1, 2 and 3 belong to the previous year - - Year := Year - 1; - return; - - -- Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week - - -- +-----+-----+-----+=====+-----+-----+-----+ - -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 1 | 2 | 3 # 4 # 5 | 6 | 7 | - -- +-----+-----+-----+=====+-----+-----+-----+ - - elsif (Day <= 4 and then Jan_1 in Monday .. Thursday) - or else - (Day = 5 and then Jan_1 in Monday .. Wednesday) - or else - (Day = 6 and then Jan_1 in Monday .. Tuesday) - or else - (Day = 7 and then Jan_1 = Monday) - then - Week := 1; - return; - end if; - - -- Month other than 1 - - -- Special case 3: December 29, 30 and 31. These days may belong to - -- next year's first week. - - -- +-----+-----+-----+=====+-----+-----+-----+ - -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | - -- +-----+-----+-----+-----+-----+-----+-----+ - -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | - -- +-----+-----+-----+=====+-----+-----+-----+ - - elsif Month = 12 and then Day > 28 then - declare - Next_Jan_1 : constant Day_Name := - Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True); - begin - if (Day = 29 and then Next_Jan_1 = Thursday) - or else - (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday) - or else - (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday) - then - Year := Year + 1; - Week := 1; - return; - end if; - end; - end if; - - -- Determine the week from which to start counting. If January 1 does - -- not belong to the first week of the input year, then the next week - -- is the first week. - - Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2); - - -- At this point all special combinations have been accounted for and - -- the proper start week has been found. Since January 1 may not fall - -- on a Monday, shift 7 - Day_Name'Pos (Jan_1). This action ensures an - -- origin which falls on Monday. - - Shift := 7 - Day_Name'Pos (Jan_1); - Week := Start_Week + (Day_In_Year (Date) - Shift - 1) / 7; - end Year_Week_In_Year; - -end GNAT.Calendar; diff --git a/gcc/ada/g-calend.ads b/gcc/ada/g-calend.ads deleted file mode 100644 index 3559130..0000000 --- a/gcc/ada/g-calend.ads +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C A L E N D A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package extends Ada.Calendar to handle Hour, Minute, Second, --- Second_Duration and Day_Of_Week and Day_In_Year from Calendar.Time. --- Second_Duration precision depends on the target clock precision. --- --- GNAT.Calendar provides the same kind of abstraction found in Ada.Calendar. --- It provides Split and Time_Of to build and split a Time data. And it --- provides accessor functions to get only one of Hour, Minute, Second, --- Second_Duration. Other functions are to access more advanced values like --- Day_Of_Week, Day_In_Year and Week_In_Year. - -with Ada.Calendar.Formatting; -with Interfaces.C; - -package GNAT.Calendar is - - type Day_Name is - (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); - pragma Ordered (Day_Name); - - subtype Hour_Number is Natural range 0 .. 23; - subtype Minute_Number is Natural range 0 .. 59; - subtype Second_Number is Natural range 0 .. 59; - subtype Second_Duration is Ada.Calendar.Day_Duration range 0.0 .. 1.0; - subtype Day_In_Year_Number is Positive range 1 .. 366; - subtype Week_In_Year_Number is Positive range 1 .. 53; - - No_Time : constant Ada.Calendar.Time; - -- A constant set to the first date that can be represented by the type - -- Time. It can be used to indicate an uninitialized date. - - function Hour (Date : Ada.Calendar.Time) return Hour_Number; - function Minute (Date : Ada.Calendar.Time) return Minute_Number; - function Second (Date : Ada.Calendar.Time) return Second_Number; - function Sub_Second (Date : Ada.Calendar.Time) return Second_Duration; - -- Hour, Minute, Second and Sub_Second returns the complete time data for - -- the Date (H:M:S.SS). See Ada.Calendar for Year, Month, Day accessors. - -- Second_Duration precision depends on the target clock precision. - - function Day_Of_Week (Date : Ada.Calendar.Time) return Day_Name; - -- Return the day name - - function Day_In_Year (Date : Ada.Calendar.Time) return Day_In_Year_Number; - -- Return the day number in the year. (1st January is day 1 and 31st - -- December is day 365 or 366 for leap year). - - procedure Split - (Date : Ada.Calendar.Time; - Year : out Ada.Calendar.Year_Number; - Month : out Ada.Calendar.Month_Number; - Day : out Ada.Calendar.Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration); - -- Split a standard Ada.Calendar.Time value in date data (Year, Month, Day) - -- and Time data (Hour, Minute, Second, Sub_Second). - - procedure Split_At_Locale - (Date : Ada.Calendar.Time; - Year : out Ada.Calendar.Year_Number; - Month : out Ada.Calendar.Month_Number; - Day : out Ada.Calendar.Day_Number; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Sub_Second : out Second_Duration); - -- Split a standard Ada.Calendar.Time value in date data (Year, Month, Day) - -- and Time data (Hour, Minute, Second, Sub_Second). This version of Split - -- utilizes the time zone and DST bias of the locale (equivalent to Clock). - -- Due to this simplified behavior, the implementation does not require - -- expensive system calls on targets such as Windows. - -- WARNING: Split_At_Locale is no longer aware of historic events and may - -- produce inaccurate results over DST changes which occurred in the past. - - function Time_Of - (Year : Ada.Calendar.Year_Number; - Month : Ada.Calendar.Month_Number; - Day : Ada.Calendar.Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0) return Ada.Calendar.Time; - -- Return an Ada.Calendar.Time data built from the date and time values - - function Time_Of_At_Locale - (Year : Ada.Calendar.Year_Number; - Month : Ada.Calendar.Month_Number; - Day : Ada.Calendar.Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration := 0.0) return Ada.Calendar.Time; - -- Return an Ada.Calendar.Time data built from the date and time values. - -- This version of Time_Of utilizes the time zone and DST bias of the - -- locale (equivalent to Clock). Due to this simplified behavior, the - -- implementation does not require expensive system calls on targets such - -- as Windows. - -- WARNING: Split_At_Locale is no longer aware of historic events and may - -- produce inaccurate results over DST changes which occurred in the past. - - function Week_In_Year (Date : Ada.Calendar.Time) return Week_In_Year_Number; - -- Return the week number as defined in ISO 8601. A week always starts on - -- a Monday and the first week of a particular year is the one containing - -- the first Thursday. A year may have 53 weeks when January 1st is a - -- Wednesday and the year is leap or January 1st is a Thursday. Note that - -- the last days of December may belong to the first week on the next year - -- and conversely, the first days of January may belong to the last week - -- of the last year. - - procedure Year_Week_In_Year - (Date : Ada.Calendar.Time; - Year : out Ada.Calendar.Year_Number; - Week : out Week_In_Year_Number); - -- Return the week number as defined in ISO 8601 along with the year in - -- which the week occurs. - - -- C timeval conversion - - -- C timeval represent a duration (used in Select for example). This - -- structure is composed of a number of seconds and a number of micro - -- seconds. The timeval structure is not exposed here because its - -- definition is target dependent. Interface to C programs is done via a - -- pointer to timeval structure. - - type timeval is private; - - function To_Duration (T : not null access timeval) return Duration; - function To_Timeval (D : Duration) return timeval; - -private - -- This is a dummy declaration that should be the largest possible timeval - -- structure of all supported targets. - - type timeval is array (1 .. 3) of Interfaces.C.long; - - function Julian_Day - (Year : Ada.Calendar.Year_Number; - Month : Ada.Calendar.Month_Number; - Day : Ada.Calendar.Day_Number) return Integer; - -- Compute Julian day number - -- - -- The code of this function is a modified version of algorithm 199 from - -- the Collected Algorithms of the ACM. The author of algorithm 199 is - -- Robert G. Tantzen. - - No_Time : constant Ada.Calendar.Time := - Ada.Calendar.Formatting.Time_Of - (Ada.Calendar.Year_Number'First, - Ada.Calendar.Month_Number'First, - Ada.Calendar.Day_Number'First, - Time_Zone => 0); - -- Use Time_Zone => 0 to be the same binary representation in any timezone - -end GNAT.Calendar; diff --git a/gcc/ada/g-casuti.adb b/gcc/ada/g-casuti.adb deleted file mode 100644 index 2fc825d..0000000 --- a/gcc/ada/g-casuti.adb +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C A S E _ U T I L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a dummy body, required because if we remove the body we have --- bootstrap path problems (this unit used to have a body, and if we do not --- supply a dummy body, the old incorrect body is picked up during the --- bootstrap process. - -package body GNAT.Case_Util is -end GNAT.Case_Util; diff --git a/gcc/ada/g-casuti.ads b/gcc/ada/g-casuti.ads deleted file mode 100644 index 18c46cb..0000000 --- a/gcc/ada/g-casuti.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C A S E _ U T I L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Simple casing functions - --- This package provides simple casing functions that do not require the --- overhead of the full casing tables found in Ada.Characters.Handling. - --- Note: actual code is found in System.Case_Util, which is used internally --- by the GNAT run time. Applications programs should always use this package --- rather than using System.Case_Util directly. - -with System.Case_Util; - -package GNAT.Case_Util is - pragma Pure; - pragma Elaborate_Body; - -- The elaborate body is because we have a dummy body to deal with - -- bootstrap path problems (we used to have a real body, and now we don't - -- need it any more, but the bootstrap requires that we have a dummy body, - -- since otherwise the old body gets picked up. - - -- Note: all the following functions handle the full Latin-1 set - - function To_Upper (A : Character) return Character - renames System.Case_Util.To_Upper; - -- Converts A to upper case if it is a lower case letter, otherwise - -- returns the input argument unchanged. - - procedure To_Upper (A : in out String) - renames System.Case_Util.To_Upper; - -- Folds all characters of string A to upper case - - function To_Lower (A : Character) return Character - renames System.Case_Util.To_Lower; - -- Converts A to lower case if it is an upper case letter, otherwise - -- returns the input argument unchanged. - - procedure To_Lower (A : in out String) - renames System.Case_Util.To_Lower; - -- Folds all characters of string A to lower case - - procedure To_Mixed (A : in out String) - renames System.Case_Util.To_Mixed; - -- Converts A to mixed case (i.e. lower case, except for initial - -- character and any character after an underscore, which are - -- converted to upper case. - -end GNAT.Case_Util; diff --git a/gcc/ada/g-catiio.adb b/gcc/ada/g-catiio.adb deleted file mode 100644 index 6677a9b..0000000 --- a/gcc/ada/g-catiio.adb +++ /dev/null @@ -1,1242 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C A L E N D A R . T I M E _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Calendar; use Ada.Calendar; -with Ada.Characters.Handling; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Ada.Text_IO; - -with GNAT.Case_Util; - -package body GNAT.Calendar.Time_IO is - - type Month_Name is - (January, - February, - March, - April, - May, - June, - July, - August, - September, - October, - November, - December); - - function Month_Name_To_Number - (Str : String) return Ada.Calendar.Month_Number; - -- Converts a string that contains an abbreviated month name to a month - -- number. Constraint_Error is raised if Str is not a valid month name. - -- Comparison is case insensitive - - type Padding_Mode is (None, Zero, Space); - - type Sec_Number is mod 2 ** 64; - -- Type used to compute the number of seconds since 01/01/1970. A 32 bit - -- number will cover only a period of 136 years. This means that for date - -- past 2106 the computation is not possible. A 64 bits number should be - -- enough for a very large period of time. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Am_Pm (H : Natural) return String; - -- Return AM or PM depending on the hour H - - function Hour_12 (H : Natural) return Positive; - -- Convert a 1-24h format to a 0-12 hour format - - function Image (Str : String; Length : Natural := 0) return String; - -- Return Str capitalized and cut to length number of characters. If - -- length is 0, then no cut operation is performed. - - function Image - (N : Sec_Number; - Padding : Padding_Mode := Zero; - Length : Natural := 0) return String; - -- Return image of N. This number is eventually padded with zeros or spaces - -- depending of the length required. If length is 0 then no padding occurs. - - function Image - (N : Natural; - Padding : Padding_Mode := Zero; - Length : Natural := 0) return String; - -- As above with N provided in Integer format - - procedure Parse_ISO_8861_UTC - (Date : String; - Time : out Ada.Calendar.Time; - Success : out Boolean); - -- Subsidiary of function Value. It parses the string Date, interpreted as - -- an ISO 8861 time representation, and returns corresponding Time value. - -- Success is set to False when the string is not a supported ISO 8861 - -- date. The following regular expression defines the supported format: - -- - -- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss) - -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ] - -- - -- Trailing characters (in particular spaces) are not allowed. - -- - -- Examples: - -- - -- 2017-04-14T14:47:06 20170414T14:47:06 20170414T144706 - -- 2017-04-14T14:47:06,12 20170414T14:47:06.12 - -- 2017-04-14T19:47:06+05 20170414T09:00:06-05:47 - - ----------- - -- Am_Pm -- - ----------- - - function Am_Pm (H : Natural) return String is - begin - if H = 0 or else H > 12 then - return "PM"; - else - return "AM"; - end if; - end Am_Pm; - - ------------- - -- Hour_12 -- - ------------- - - function Hour_12 (H : Natural) return Positive is - begin - if H = 0 then - return 12; - elsif H <= 12 then - return H; - else -- H > 12 - return H - 12; - end if; - end Hour_12; - - ----------- - -- Image -- - ----------- - - function Image - (Str : String; - Length : Natural := 0) return String - is - use Ada.Characters.Handling; - Local : constant String := - To_Upper (Str (Str'First)) & - To_Lower (Str (Str'First + 1 .. Str'Last)); - begin - if Length = 0 then - return Local; - else - return Local (1 .. Length); - end if; - end Image; - - ----------- - -- Image -- - ----------- - - function Image - (N : Natural; - Padding : Padding_Mode := Zero; - Length : Natural := 0) return String - is - begin - return Image (Sec_Number (N), Padding, Length); - end Image; - - function Image - (N : Sec_Number; - Padding : Padding_Mode := Zero; - Length : Natural := 0) return String - is - function Pad_Char return String; - - -------------- - -- Pad_Char -- - -------------- - - function Pad_Char return String is - begin - case Padding is - when None => return ""; - when Zero => return "00"; - when Space => return " "; - end case; - end Pad_Char; - - -- Local Declarations - - NI : constant String := Sec_Number'Image (N); - NIP : constant String := Pad_Char & NI (2 .. NI'Last); - - -- Start of processing for Image - - begin - if Length = 0 or else Padding = None then - return NI (2 .. NI'Last); - else - return NIP (NIP'Last - Length + 1 .. NIP'Last); - end if; - end Image; - - ----------- - -- Image -- - ----------- - - function Image - (Date : Ada.Calendar.Time; - Picture : Picture_String) return String - is - Padding : Padding_Mode := Zero; - -- Padding is set for one directive - - Result : Unbounded_String; - - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - Sub_Second : Second_Duration; - - P : Positive; - - begin - -- Get current time in split format - - Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); - - -- Null picture string is error - - if Picture = "" then - raise Picture_Error with "null picture string"; - end if; - - -- Loop through characters of picture string, building result - - Result := Null_Unbounded_String; - P := Picture'First; - while P <= Picture'Last loop - - -- A directive has the following format "%[-_]." - - if Picture (P) = '%' then - Padding := Zero; - - if P = Picture'Last then - raise Picture_Error with "picture string ends with '%"; - end if; - - -- Check for GNU extension to change the padding - - if Picture (P + 1) = '-' then - Padding := None; - P := P + 1; - - elsif Picture (P + 1) = '_' then - Padding := Space; - P := P + 1; - end if; - - if P = Picture'Last then - raise Picture_Error with "picture string ends with '- or '_"; - end if; - - case Picture (P + 1) is - - -- Literal % - - when '%' => - Result := Result & '%'; - - -- A newline - - when 'n' => - Result := Result & ASCII.LF; - - -- A horizontal tab - - when 't' => - Result := Result & ASCII.HT; - - -- Hour (00..23) - - when 'H' => - Result := Result & Image (Hour, Padding, 2); - - -- Hour (01..12) - - when 'I' => - Result := Result & Image (Hour_12 (Hour), Padding, 2); - - -- Hour ( 0..23) - - when 'k' => - Result := Result & Image (Hour, Space, 2); - - -- Hour ( 1..12) - - when 'l' => - Result := Result & Image (Hour_12 (Hour), Space, 2); - - -- Minute (00..59) - - when 'M' => - Result := Result & Image (Minute, Padding, 2); - - -- AM/PM - - when 'p' => - Result := Result & Am_Pm (Hour); - - -- Time, 12-hour (hh:mm:ss [AP]M) - - when 'r' => - Result := Result & - Image (Hour_12 (Hour), Padding, Length => 2) & ':' & - Image (Minute, Padding, Length => 2) & ':' & - Image (Second, Padding, Length => 2) & ' ' & - Am_Pm (Hour); - - -- Seconds since 1970-01-01 00:00:00 UTC - -- (a nonstandard extension) - - when 's' => - declare - -- Compute the number of seconds using Ada.Calendar.Time - -- values rather than Julian days to account for Daylight - -- Savings Time. - - Neg : Boolean := False; - Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0); - - begin - -- Avoid rounding errors and perform special processing - -- for dates earlier than the Unix Epoc. - - if Sec > 0.0 then - Sec := Sec - 0.5; - elsif Sec < 0.0 then - Neg := True; - Sec := abs (Sec + 0.5); - end if; - - -- Prepend a minus sign to the result since Sec_Number - -- cannot handle negative numbers. - - if Neg then - Result := - Result & "-" & Image (Sec_Number (Sec), None); - else - Result := Result & Image (Sec_Number (Sec), None); - end if; - end; - - -- Second (00..59) - - when 'S' => - Result := Result & Image (Second, Padding, Length => 2); - - -- Milliseconds (3 digits) - -- Microseconds (6 digits) - -- Nanoseconds (9 digits) - - when 'i' | 'e' | 'o' => - declare - Sub_Sec : constant Long_Integer := - Long_Integer (Sub_Second * 1_000_000_000); - - Img1 : constant String := Sub_Sec'Img; - Img2 : constant String := - "00000000" & Img1 (Img1'First + 1 .. Img1'Last); - Nanos : constant String := - Img2 (Img2'Last - 8 .. Img2'Last); - - begin - case Picture (P + 1) is - when 'i' => - Result := Result & - Nanos (Nanos'First .. Nanos'First + 2); - - when 'e' => - Result := Result & - Nanos (Nanos'First .. Nanos'First + 5); - - when 'o' => - Result := Result & Nanos; - - when others => - null; - end case; - end; - - -- Time, 24-hour (hh:mm:ss) - - when 'T' => - Result := Result & - Image (Hour, Padding, Length => 2) & ':' & - Image (Minute, Padding, Length => 2) & ':' & - Image (Second, Padding, Length => 2); - - -- Locale's abbreviated weekday name (Sun..Sat) - - when 'a' => - Result := Result & - Image (Day_Name'Image (Day_Of_Week (Date)), 3); - - -- Locale's full weekday name, variable length - -- (Sunday..Saturday) - - when 'A' => - Result := Result & - Image (Day_Name'Image (Day_Of_Week (Date))); - - -- Locale's abbreviated month name (Jan..Dec) - - when 'b' | 'h' => - Result := Result & - Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3); - - -- Locale's full month name, variable length - -- (January..December). - - when 'B' => - Result := Result & - Image (Month_Name'Image (Month_Name'Val (Month - 1))); - - -- Locale's date and time (Sat Nov 04 12:02:33 EST 1989) - - when 'c' => - case Padding is - when Zero => - Result := Result & Image (Date, "%a %b %d %T %Y"); - when Space => - Result := Result & Image (Date, "%a %b %_d %_T %Y"); - when None => - Result := Result & Image (Date, "%a %b %-d %-T %Y"); - end case; - - -- Day of month (01..31) - - when 'd' => - Result := Result & Image (Day, Padding, 2); - - -- Date (mm/dd/yy) - - when 'D' | 'x' => - Result := Result & - Image (Month, Padding, 2) & '/' & - Image (Day, Padding, 2) & '/' & - Image (Year, Padding, 2); - - -- Day of year (001..366) - - when 'j' => - Result := Result & Image (Day_In_Year (Date), Padding, 3); - - -- Month (01..12) - - when 'm' => - Result := Result & Image (Month, Padding, 2); - - -- Week number of year with Sunday as first day of week - -- (00..53) - - when 'U' => - declare - Offset : constant Natural := - (Julian_Day (Year, 1, 1) + 1) mod 7; - - Week : constant Natural := - 1 + ((Day_In_Year (Date) - 1) + Offset) / 7; - - begin - Result := Result & Image (Week, Padding, 2); - end; - - -- Day of week (0..6) with 0 corresponding to Sunday - - when 'w' => - declare - DOW : constant Natural range 0 .. 6 := - (if Day_Of_Week (Date) = Sunday - then 0 - else Day_Name'Pos (Day_Of_Week (Date))); - begin - Result := Result & Image (DOW, Length => 1); - end; - - -- Week number of year with Monday as first day of week - -- (00..53) - - when 'W' => - Result := Result & Image (Week_In_Year (Date), Padding, 2); - - -- Last two digits of year (00..99) - - when 'y' => - declare - Y : constant Natural := Year - (Year / 100) * 100; - begin - Result := Result & Image (Y, Padding, 2); - end; - - -- Year (1970...) - - when 'Y' => - Result := Result & Image (Year, None, 4); - - when others => - raise Picture_Error with - "unknown format character in picture string"; - end case; - - -- Skip past % and format character - - P := P + 2; - - -- Character other than % is copied into the result - - else - Result := Result & Picture (P); - P := P + 1; - end if; - end loop; - - return To_String (Result); - end Image; - - -------------------------- - -- Month_Name_To_Number -- - -------------------------- - - function Month_Name_To_Number - (Str : String) return Ada.Calendar.Month_Number - is - subtype String3 is String (1 .. 3); - Abbrev_Upper_Month_Names : - constant array (Ada.Calendar.Month_Number) of String3 := - ("JAN", "FEB", "MAR", "APR", "MAY", "JUN", - "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); - -- Short version of the month names, used when parsing date strings - - S : String := Str; - - begin - GNAT.Case_Util.To_Upper (S); - - for J in Abbrev_Upper_Month_Names'Range loop - if Abbrev_Upper_Month_Names (J) = S then - return J; - end if; - end loop; - - return Abbrev_Upper_Month_Names'First; - end Month_Name_To_Number; - - ------------------------ - -- Parse_ISO_8861_UTC -- - ------------------------ - - procedure Parse_ISO_8861_UTC - (Date : String; - Time : out Ada.Calendar.Time; - Success : out Boolean) - is - Index : Positive := Date'First; - -- The current character scan index. After a call to Advance, Index - -- points to the next character. - - End_Of_Source_Reached : exception; - -- An exception used to signal that the scan pointer has reached the - -- end of the source string. - - Wrong_Syntax : exception; - -- An exception used to signal that the scan pointer has reached an - -- unexpected character in the source string. - - procedure Advance; - pragma Inline (Advance); - -- Past the current character of Date - - procedure Advance_Digits (Num_Digits : Positive); - pragma Inline (Advance_Digits); - -- Past the given number of digit characters - - function Scan_Day return Day_Number; - pragma Inline (Scan_Day); - -- Scan the two digits of a day number and return its value - - function Scan_Hour return Hour_Number; - pragma Inline (Scan_Hour); - -- Scan the two digits of an hour number and return its value - - function Scan_Minute return Minute_Number; - pragma Inline (Scan_Minute); - -- Scan the two digits of a minute number and return its value - - function Scan_Month return Month_Number; - pragma Inline (Scan_Month); - -- Scan the two digits of a month number and return its value - - function Scan_Second return Second_Number; - pragma Inline (Scan_Second); - -- Scan the two digits of a second number and return its value - - function Scan_Separator (Expected_Symbol : Character) return Boolean; - pragma Inline (Scan_Separator); - -- If the current symbol matches the Expected_Symbol then advance the - -- scanner index and return True; otherwise do nothing and return False - - procedure Scan_Separator (Required : Boolean; Separator : Character); - pragma Inline (Scan_Separator); - -- If Required then check that the current character matches Separator - -- and advance the scanner index; if not Required then do nothing. - - function Scan_Subsecond return Second_Duration; - pragma Inline (Scan_Subsecond); - -- Scan all the digits of a subsecond number and return its value - - function Scan_Year return Year_Number; - pragma Inline (Scan_Year); - -- Scan the four digits of a year number and return its value - - function Symbol return Character; - pragma Inline (Symbol); - -- Return the current character being scanned - - ------------- - -- Advance -- - ------------- - - procedure Advance is - begin - -- Signal the end of the source string. This stops a complex scan by - -- bottoming up any recursive calls till control reaches routine Scan - -- which handles the exception. Certain scanning scenarios may handle - -- this exception on their own. - - if Index > Date'Last then - raise End_Of_Source_Reached; - - -- Advance the scan pointer as long as there are characters to scan, - -- in other words, the scan pointer has not passed the end of the - -- source string. - - else - Index := Index + 1; - end if; - end Advance; - - -------------------- - -- Advance_Digits -- - -------------------- - - procedure Advance_Digits (Num_Digits : Positive) is - begin - for J in 1 .. Num_Digits loop - if Symbol not in '0' .. '9' then - raise Wrong_Syntax; - end if; - - Advance; -- past digit - end loop; - end Advance_Digits; - - -------------- - -- Scan_Day -- - -------------- - - function Scan_Day return Day_Number is - From : constant Positive := Index; - begin - Advance_Digits (Num_Digits => 2); - return Day_Number'Value (Date (From .. Index - 1)); - end Scan_Day; - - --------------- - -- Scan_Hour -- - --------------- - - function Scan_Hour return Hour_Number is - From : constant Positive := Index; - begin - Advance_Digits (Num_Digits => 2); - return Hour_Number'Value (Date (From .. Index - 1)); - end Scan_Hour; - - ----------------- - -- Scan_Minute -- - ----------------- - - function Scan_Minute return Minute_Number is - From : constant Positive := Index; - begin - Advance_Digits (Num_Digits => 2); - return Minute_Number'Value (Date (From .. Index - 1)); - end Scan_Minute; - - ---------------- - -- Scan_Month -- - ---------------- - - function Scan_Month return Month_Number is - From : constant Positive := Index; - begin - Advance_Digits (Num_Digits => 2); - return Month_Number'Value (Date (From .. Index - 1)); - end Scan_Month; - - ----------------- - -- Scan_Second -- - ----------------- - - function Scan_Second return Second_Number is - From : constant Positive := Index; - begin - Advance_Digits (Num_Digits => 2); - return Second_Number'Value (Date (From .. Index - 1)); - end Scan_Second; - - -------------------- - -- Scan_Separator -- - -------------------- - - function Scan_Separator (Expected_Symbol : Character) return Boolean is - begin - if Symbol = Expected_Symbol then - Advance; - return True; - else - return False; - end if; - end Scan_Separator; - - -------------------- - -- Scan_Separator -- - -------------------- - - procedure Scan_Separator (Required : Boolean; Separator : Character) is - begin - if Required then - if Symbol /= Separator then - raise Wrong_Syntax; - end if; - - Advance; -- Past the separator - end if; - end Scan_Separator; - - -------------------- - -- Scan_Subsecond -- - -------------------- - - function Scan_Subsecond return Second_Duration is - From : constant Positive := Index; - begin - Advance_Digits (Num_Digits => 1); - - while Symbol in '0' .. '9' - and then Index < Date'Length - loop - Advance; - end loop; - - if Symbol not in '0' .. '9' then - raise Wrong_Syntax; - end if; - - Advance; - return Second_Duration'Value ("0." & Date (From .. Index - 1)); - end Scan_Subsecond; - - --------------- - -- Scan_Year -- - --------------- - - function Scan_Year return Year_Number is - From : constant Positive := Index; - begin - Advance_Digits (Num_Digits => 4); - return Year_Number'Value (Date (From .. Index - 1)); - end Scan_Year; - - ------------ - -- Symbol -- - ------------ - - function Symbol return Character is - begin - -- Signal the end of the source string. This stops a complex scan by - -- bottoming up any recursive calls till control reaches routine Scan - -- which handles the exception. Certain scanning scenarios may handle - -- this exception on their own. - - if Index > Date'Last then - raise End_Of_Source_Reached; - - else - return Date (Index); - end if; - end Symbol; - - -- Local variables - - Date_Separator : constant Character := '-'; - Hour_Separator : constant Character := ':'; - - Day : Day_Number; - Month : Month_Number; - Year : Year_Number; - Hour : Hour_Number := 0; - Minute : Minute_Number := 0; - Second : Second_Number := 0; - Subsec : Second_Duration := 0.0; - - Local_Hour : Hour_Number := 0; - Local_Minute : Minute_Number := 0; - Local_Sign : Character := ' '; - Local_Disp : Duration; - - Sep_Required : Boolean := False; - -- True if a separator is seen (and therefore required after it!) - - begin - -- Parse date - - Year := Scan_Year; - Sep_Required := Scan_Separator (Date_Separator); - - Month := Scan_Month; - Scan_Separator (Sep_Required, Date_Separator); - - Day := Scan_Day; - - if Index < Date'Last and then Symbol = 'T' then - Advance; - - -- Parse time - - Hour := Scan_Hour; - Sep_Required := Scan_Separator (Hour_Separator); - - Minute := Scan_Minute; - Scan_Separator (Sep_Required, Hour_Separator); - - Second := Scan_Second; - - -- [('Z' | ('.' | ',') s{s} | ('+'|'-')hh:mm)] - - if Index <= Date'Last then - - -- Suffix 'Z' just confirms that this is an UTC time. No further - -- action needed. - - if Symbol = 'Z' then - Advance; - - -- A decimal fraction shall have at least one digit, and has as - -- many digits as supported by the underlying implementation. - -- The valid decimal separators are those specified in ISO 31-0, - -- i.e. the comma [,] or full stop [.]. Of these, the comma is - -- the preferred separator of ISO-8861. - - elsif Symbol = ',' or else Symbol = '.' then - Advance; -- past decimal separator - Subsec := Scan_Subsecond; - - -- Difference between local time and UTC: It shall be expressed - -- as positive (i.e. with the leading plus sign [+]) if the local - -- time is ahead of or equal to UTC of day and as negative (i.e. - -- with the leading minus sign [-]) if it is behind UTC of day. - -- The minutes time element of the difference may only be omitted - -- if the difference between the time scales is exactly an - -- integral number of hours. - - elsif Symbol = '+' or else Symbol = '-' then - Local_Sign := Symbol; - Advance; - Local_Hour := Scan_Hour; - - -- Past ':' - - if Index < Date'Last and then Symbol = Hour_Separator then - Advance; - Local_Minute := Scan_Minute; - end if; - - -- Compute local displacement - - Local_Disp := Local_Hour * 3600.0 + Local_Minute * 60.0; - else - raise Wrong_Syntax; - end if; - end if; - end if; - - -- Sanity checks. The check on Index ensures that there are no trailing - -- characters. - - if Index /= Date'Length + 1 - or else not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - or else not Subsec'Valid - or else not Local_Hour'Valid - or else not Local_Minute'Valid - then - raise Wrong_Syntax; - end if; - - -- Compute time without local displacement - - if Local_Sign = ' ' then - Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec); - - -- Compute time with positive local displacement - - elsif Local_Sign = '+' then - Time := - Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) - - Local_Disp; - - -- Compute time with negative local displacement - - elsif Local_Sign = '-' then - Time := - Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) + - Local_Disp; - end if; - - -- Notify that the input string was successfully parsed - - Success := True; - - exception - when End_Of_Source_Reached - | Wrong_Syntax - => - Success := False; - end Parse_ISO_8861_UTC; - - ----------- - -- Value -- - ----------- - - function Value (Date : String) return Ada.Calendar.Time is - D : String (1 .. 21); - D_Length : constant Natural := Date'Length; - - Year : Year_Number; - Month : Month_Number; - Day : Day_Number; - Hour : Hour_Number; - Minute : Minute_Number; - Second : Second_Number; - - procedure Extract_Date - (Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Time_Start : out Natural); - -- Try and extract a date value from string D. Time_Start is set to the - -- first character that could be the start of time data. - - procedure Extract_Time - (Index : Positive; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Check_Space : Boolean := False); - -- Try and extract a time value from string D starting from position - -- Index. Set Check_Space to True to check whether the character at - -- Index - 1 is a space. Raise Constraint_Error if the portion of D - -- corresponding to the date is not well formatted. - - ------------------ - -- Extract_Date -- - ------------------ - - procedure Extract_Date - (Year : out Year_Number; - Month : out Month_Number; - Day : out Day_Number; - Time_Start : out Natural) - is - begin - if D (3) = '-' or else D (3) = '/' then - if D_Length = 8 or else D_Length = 17 then - - -- Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss" - - if D (6) /= D (3) then - raise Constraint_Error; - end if; - - Year := Year_Number'Value ("20" & D (1 .. 2)); - Month := Month_Number'Value (D (4 .. 5)); - Day := Day_Number'Value (D (7 .. 8)); - Time_Start := 10; - - elsif D_Length = 10 or else D_Length = 19 then - - -- Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss" - - if D (6) /= D (3) then - raise Constraint_Error; - end if; - - Year := Year_Number'Value (D (7 .. 10)); - Month := Month_Number'Value (D (1 .. 2)); - Day := Day_Number'Value (D (4 .. 5)); - Time_Start := 12; - - elsif D_Length = 11 or else D_Length = 20 then - - -- Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss" - - if D (7) /= D (3) then - raise Constraint_Error; - end if; - - Year := Year_Number'Value (D (8 .. 11)); - Month := Month_Name_To_Number (D (4 .. 6)); - Day := Day_Number'Value (D (1 .. 2)); - Time_Start := 13; - - else - raise Constraint_Error; - end if; - - elsif D (3) = ' ' then - if D_Length = 11 or else D_Length = 20 then - - -- Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss" - - if D (7) /= ' ' then - raise Constraint_Error; - end if; - - Year := Year_Number'Value (D (8 .. 11)); - Month := Month_Name_To_Number (D (4 .. 6)); - Day := Day_Number'Value (D (1 .. 2)); - Time_Start := 13; - - else - raise Constraint_Error; - end if; - - else - if D_Length = 8 or else D_Length = 17 then - - -- Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss" - - Year := Year_Number'Value (D (1 .. 4)); - Month := Month_Number'Value (D (5 .. 6)); - Day := Day_Number'Value (D (7 .. 8)); - Time_Start := 10; - - elsif D_Length = 10 or else D_Length = 19 then - - -- Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss" - - if (D (5) /= '-' and then D (5) /= '/') - or else D (8) /= D (5) - then - raise Constraint_Error; - end if; - - Year := Year_Number'Value (D (1 .. 4)); - Month := Month_Number'Value (D (6 .. 7)); - Day := Day_Number'Value (D (9 .. 10)); - Time_Start := 12; - - elsif D_Length = 11 or else D_Length = 20 then - - -- Possible formats are "yyyy*mmm*dd" - - if (D (5) /= '-' and then D (5) /= '/') - or else D (9) /= D (5) - then - raise Constraint_Error; - end if; - - Year := Year_Number'Value (D (1 .. 4)); - Month := Month_Name_To_Number (D (6 .. 8)); - Day := Day_Number'Value (D (10 .. 11)); - Time_Start := 13; - - elsif D_Length = 12 or else D_Length = 21 then - - -- Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss" - - if D (4) /= ' ' - or else D (7) /= ',' - or else D (8) /= ' ' - then - raise Constraint_Error; - end if; - - Year := Year_Number'Value (D (9 .. 12)); - Month := Month_Name_To_Number (D (1 .. 3)); - Day := Day_Number'Value (D (5 .. 6)); - Time_Start := 14; - - else - raise Constraint_Error; - end if; - end if; - end Extract_Date; - - ------------------ - -- Extract_Time -- - ------------------ - - procedure Extract_Time - (Index : Positive; - Hour : out Hour_Number; - Minute : out Minute_Number; - Second : out Second_Number; - Check_Space : Boolean := False) - is - begin - -- If no time was specified in the string (do not allow trailing - -- character either) - - if Index = D_Length + 2 then - Hour := 0; - Minute := 0; - Second := 0; - - else - -- Not enough characters left ? - - if Index /= D_Length - 7 then - raise Constraint_Error; - end if; - - if Check_Space and then D (Index - 1) /= ' ' then - raise Constraint_Error; - end if; - - if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then - raise Constraint_Error; - end if; - - Hour := Hour_Number'Value (D (Index .. Index + 1)); - Minute := Minute_Number'Value (D (Index + 3 .. Index + 4)); - Second := Second_Number'Value (D (Index + 6 .. Index + 7)); - end if; - end Extract_Time; - - -- Local Declarations - - Success : Boolean; - Time_Start : Natural := 1; - Time : Ada.Calendar.Time; - - -- Start of processing for Value - - begin - -- Let's try parsing Date as a supported ISO-8861 format. If we do not - -- succeed, then retry using all the other GNAT supported formats. - - Parse_ISO_8861_UTC (Date, Time, Success); - - if Success then - return Time; - end if; - - -- Length checks - - if D_Length /= 8 - and then D_Length /= 10 - and then D_Length /= 11 - and then D_Length /= 12 - and then D_Length /= 17 - and then D_Length /= 19 - and then D_Length /= 20 - and then D_Length /= 21 - then - raise Constraint_Error; - end if; - - -- After the correct length has been determined, it is safe to create - -- a local string copy in order to avoid String'First N arithmetic. - - D (1 .. D_Length) := Date; - - if D_Length /= 8 or else D (3) /= ':' then - Extract_Date (Year, Month, Day, Time_Start); - Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); - - else - declare - Discard : Second_Duration; - begin - Split (Clock, Year, Month, Day, Hour, Minute, Second, - Sub_Second => Discard); - end; - - Extract_Time (1, Hour, Minute, Second, Check_Space => False); - end if; - - -- Sanity checks - - if not Year'Valid - or else not Month'Valid - or else not Day'Valid - or else not Hour'Valid - or else not Minute'Valid - or else not Second'Valid - then - raise Constraint_Error; - end if; - - return Time_Of (Year, Month, Day, Hour, Minute, Second); - end Value; - - -------------- - -- Put_Time -- - -------------- - - procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is - begin - Ada.Text_IO.Put (Image (Date, Picture)); - end Put_Time; - -end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/g-catiio.ads b/gcc/ada/g-catiio.ads deleted file mode 100644 index 8b93518..0000000 --- a/gcc/ada/g-catiio.ads +++ /dev/null @@ -1,168 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C A L E N D A R . T I M E _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package augments standard Ada.Text_IO with facilities for input --- and output of time values in standardized format. - -package GNAT.Calendar.Time_IO is - - Picture_Error : exception; - -- Exception raised for incorrect picture - - type Picture_String is new String; - -- This is a string to describe date and time output format. The string is - -- a set of standard character and special tag that are replaced by the - -- corresponding values. It follows the GNU Date specification. Here are - -- the recognized directives : - -- - -- % a literal % - -- n a newline - -- t a horizontal tab - -- - -- Time fields: - -- - -- %H hour (00..23) - -- %I hour (01..12) - -- %k hour ( 0..23) - -- %l hour ( 1..12) - -- %M minute (00..59) - -- %p locale's AM or PM - -- %r time, 12-hour (hh:mm:ss [AP]M) - -- %s seconds since 1970-01-01 00:00:00 UTC - -- (a nonstandard extension) - -- %S second (00..59) - -- %T time, 24-hour (hh:mm:ss) - -- - -- Date fields: - -- - -- %a locale's abbreviated weekday name (Sun..Sat) - -- %A locale's full weekday name, variable length - -- (Sunday..Saturday) - -- %b locale's abbreviated month name (Jan..Dec) - -- %B locale's full month name, variable length - -- (January..December) - -- %c locale's date and time (Sat Nov 04 12:02:33 EST 1989) - -- %d day of month (01..31) - -- %D date (mm/dd/yy) - -- %h same as %b - -- %j day of year (001..366) - -- %m month (01..12) - -- %U week number of year with Sunday as first day of week - -- (00..53) - -- %w day of week (0..6) with 0 corresponding to Sunday - -- %W week number of year with Monday as first day of week - -- (00..53) - -- %x locale's date representation (mm/dd/yy) - -- %y last two digits of year (00..99) - -- %Y year (1970...) - -- - -- By default, date pads numeric fields with zeroes. GNU date - -- recognizes the following nonstandard numeric modifiers: - -- - -- - (hyphen) do not pad the field - -- _ (underscore) pad the field with spaces - -- - -- Here are some GNAT extensions to the GNU Date specification: - -- - -- %i milliseconds (3 digits) - -- %e microseconds (6 digits) - -- %o nanoseconds (9 digits) - - ISO_Date : constant Picture_String; - -- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD", - -- four digits year, month and day number separated by minus. - - US_Date : constant Picture_String; - -- This format is the common US date format: "MM/DD/YY", - -- month and day number, two digits year separated by slashes. - - European_Date : constant Picture_String; - -- This format is the common European date format: "DD/MM/YY", - -- day and month number, two digits year separated by slashes. - - function Image - (Date : Ada.Calendar.Time; - Picture : Picture_String) return String; - -- Return Date, as interpreted in the current local time zone, as a string - -- with format Picture. Raise Picture_Error if picture string is null or - -- has an incorrect format. - - function Value (Date : String) return Ada.Calendar.Time; - -- Parse the string Date, interpreted as a time representation in the - -- current local time zone, and return the corresponding Time value. The - -- following time format is supported: - -- - -- hh:mm:ss - Date is the current date - -- - -- The following formats are also supported. They all accept an optional - -- time with the format "hh:mm:ss". The time is separated from the date by - -- exactly one space character. - -- - -- When the time is not specified, it is set to 00:00:00. The delimiter '*' - -- must be either '-' and '/' and both occurrences must use the same - -- character. - -- - -- Trailing characters (in particular spaces) are not allowed - -- - -- yyyy*mm*dd - ISO format - -- yy*mm*dd - Year is assumed to be 20yy - -- mm*dd*yyyy - (US date format) - -- dd*mmm*yyyy - month spelled out - -- yyyy*mmm*dd - month spelled out - -- yyyymmdd - Iso format, no separator - -- mmm dd, yyyy - month spelled out - -- dd mmm yyyy - month spelled out - -- - -- The following ISO-8861 format expressed as a regular expression is also - -- supported: - -- - -- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss) - -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ] - -- - -- Examples: - -- - -- 2017-04-14T14:47:06 20170414T14:47:06 20170414T144706 - -- 2017-04-14T14:47:06,1234 20170414T14:47:06.1234 - -- 2017-04-14T19:47:06+05 20170414T09:00:06-05:47 - - -- Constraint_Error is raised if the input string is malformed (does not - -- conform to one of the above dates, or has an invalid time string), or - -- the resulting time is not valid. - - procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String); - -- Put Date with format Picture. Raise Picture_Error if bad picture string - -private - ISO_Date : constant Picture_String := "%Y-%m-%d"; - US_Date : constant Picture_String := "%m/%d/%y"; - European_Date : constant Picture_String := "%d/%m/%y"; - -end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/g-cgi.adb b/gcc/ada/g-cgi.adb deleted file mode 100644 index 9d658e6..0000000 --- a/gcc/ada/g-cgi.adb +++ /dev/null @@ -1,494 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Text_IO; -with Ada.Strings.Fixed; -with Ada.Characters.Handling; -with Ada.Strings.Maps; - -with GNAT.OS_Lib; -with GNAT.Table; - -package body GNAT.CGI is - - use Ada; - - Valid_Environment : Boolean := True; - -- This boolean will be set to False if the initialization was not - -- completed correctly. It must be set to true there because the - -- Initialize routine (called during elaboration) will use some of the - -- services exported by this unit. - - Current_Method : Method_Type; - -- This is the current method used to pass CGI parameters - - Header_Sent : Boolean := False; - -- Will be set to True when the header will be sent - - -- Key/Value table declaration - - type String_Access is access String; - - type Key_Value is record - Key : String_Access; - Value : String_Access; - end record; - - package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); - - ----------------------- - -- Local subprograms -- - ----------------------- - - procedure Check_Environment; - pragma Inline (Check_Environment); - -- This procedure will raise Data_Error if Valid_Environment is False - - procedure Initialize; - -- Initialize CGI package by reading the runtime environment. This - -- procedure is called during elaboration. All exceptions raised during - -- this procedure are deferred. - - -------------------- - -- Argument_Count -- - -------------------- - - function Argument_Count return Natural is - begin - Check_Environment; - return Key_Value_Table.Last; - end Argument_Count; - - ----------------------- - -- Check_Environment -- - ----------------------- - - procedure Check_Environment is - begin - if not Valid_Environment then - raise Data_Error; - end if; - end Check_Environment; - - ------------ - -- Decode -- - ------------ - - function Decode (S : String) return String is - Result : String (S'Range); - K : Positive := S'First; - J : Positive := Result'First; - - begin - while K <= S'Last loop - if K + 2 <= S'Last - and then S (K) = '%' - and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1)) - and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2)) - then - -- Here we have '%HH' which is an encoded character where 'HH' is - -- the character number in hexadecimal. - - Result (J) := Character'Val - (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#')); - K := K + 3; - - -- Plus sign is decoded as a space - - elsif S (K) = '+' then - Result (J) := ' '; - K := K + 1; - - else - Result (J) := S (K); - K := K + 1; - end if; - - J := J + 1; - end loop; - - return Result (Result'First .. J - 1); - end Decode; - - ------------------------- - -- For_Every_Parameter -- - ------------------------- - - procedure For_Every_Parameter is - Quit : Boolean; - - begin - Check_Environment; - - for K in 1 .. Key_Value_Table.Last loop - - Quit := False; - - Action (Key_Value_Table.Table (K).Key.all, - Key_Value_Table.Table (K).Value.all, - K, - Quit); - - exit when Quit; - - end loop; - end For_Every_Parameter; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - - Request_Method : constant String := - Characters.Handling.To_Upper - (Metavariable (CGI.Request_Method)); - - procedure Initialize_GET; - -- Read CGI parameters for a GET method. In this case the parameters - -- are passed into QUERY_STRING environment variable. - - procedure Initialize_POST; - -- Read CGI parameters for a POST method. In this case the parameters - -- are passed with the standard input. The total number of characters - -- for the data is passed in CONTENT_LENGTH environment variable. - - procedure Set_Parameter_Table (Data : String); - -- Parse the parameter data and set the parameter table - - -------------------- - -- Initialize_GET -- - -------------------- - - procedure Initialize_GET is - Data : constant String := Metavariable (Query_String); - begin - Current_Method := Get; - - if Data /= "" then - Set_Parameter_Table (Data); - end if; - end Initialize_GET; - - --------------------- - -- Initialize_POST -- - --------------------- - - procedure Initialize_POST is - Content_Length : constant Natural := - Natural'Value (Metavariable (CGI.Content_Length)); - Data : String (1 .. Content_Length); - - begin - Current_Method := Post; - - if Content_Length /= 0 then - Text_IO.Get (Data); - Set_Parameter_Table (Data); - end if; - end Initialize_POST; - - ------------------------- - -- Set_Parameter_Table -- - ------------------------- - - procedure Set_Parameter_Table (Data : String) is - - procedure Add_Parameter (K : Positive; P : String); - -- Add a single parameter into the table at index K. The parameter - -- format is "key=value". - - Count : constant Positive := - 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&")); - -- Count is the number of parameters in the string. Parameters are - -- separated by ampersand character. - - Index : Positive := Data'First; - Amp : Natural; - - ------------------- - -- Add_Parameter -- - ------------------- - - procedure Add_Parameter (K : Positive; P : String) is - Equal : constant Natural := Strings.Fixed.Index (P, "="); - - begin - if Equal = 0 then - raise Data_Error; - - else - Key_Value_Table.Table (K) := - Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), - new String'(Decode (P (Equal + 1 .. P'Last)))); - end if; - end Add_Parameter; - - -- Start of processing for Set_Parameter_Table - - begin - Key_Value_Table.Set_Last (Count); - - for K in 1 .. Count - 1 loop - Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&"); - - Add_Parameter (K, Data (Index .. Amp - 1)); - - Index := Amp + 1; - end loop; - - -- add last parameter - - Add_Parameter (Count, Data (Index .. Data'Last)); - end Set_Parameter_Table; - - -- Start of processing for Initialize - - begin - if Request_Method = "GET" then - Initialize_GET; - - elsif Request_Method = "POST" then - Initialize_POST; - - else - Valid_Environment := False; - end if; - - exception - when others => - - -- If we have an exception during initialization of this unit we - -- just declare it invalid. - - Valid_Environment := False; - end Initialize; - - --------- - -- Key -- - --------- - - function Key (Position : Positive) return String is - begin - Check_Environment; - - if Position <= Key_Value_Table.Last then - return Key_Value_Table.Table (Position).Key.all; - else - raise Parameter_Not_Found; - end if; - end Key; - - ---------------- - -- Key_Exists -- - ---------------- - - function Key_Exists (Key : String) return Boolean is - begin - Check_Environment; - - for K in 1 .. Key_Value_Table.Last loop - if Key_Value_Table.Table (K).Key.all = Key then - return True; - end if; - end loop; - - return False; - end Key_Exists; - - ------------------ - -- Metavariable -- - ------------------ - - function Metavariable - (Name : Metavariable_Name; - Required : Boolean := False) return String - is - function Get_Environment (Variable_Name : String) return String; - -- Returns the environment variable content - - --------------------- - -- Get_Environment -- - --------------------- - - function Get_Environment (Variable_Name : String) return String is - Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name); - Result : constant String := Value.all; - begin - OS_Lib.Free (Value); - return Result; - end Get_Environment; - - Result : constant String := - Get_Environment (Metavariable_Name'Image (Name)); - - -- Start of processing for Metavariable - - begin - Check_Environment; - - if Result = "" and then Required then - raise Parameter_Not_Found; - else - return Result; - end if; - end Metavariable; - - ------------------------- - -- Metavariable_Exists -- - ------------------------- - - function Metavariable_Exists (Name : Metavariable_Name) return Boolean is - begin - Check_Environment; - - if Metavariable (Name) = "" then - return False; - else - return True; - end if; - end Metavariable_Exists; - - ------------ - -- Method -- - ------------ - - function Method return Method_Type is - begin - Check_Environment; - return Current_Method; - end Method; - - -------- - -- Ok -- - -------- - - function Ok return Boolean is - begin - return Valid_Environment; - end Ok; - - ---------------- - -- Put_Header -- - ---------------- - - procedure Put_Header - (Header : String := Default_Header; - Force : Boolean := False) - is - begin - if Header_Sent = False or else Force then - Check_Environment; - Text_IO.Put_Line (Header); - Text_IO.New_Line; - Header_Sent := True; - end if; - end Put_Header; - - --------- - -- URL -- - --------- - - function URL return String is - - function Exists_And_Not_80 (Server_Port : String) return String; - -- Returns ':' & Server_Port if Server_Port is not "80" and the empty - -- string otherwise (80 is the default sever port). - - ----------------------- - -- Exists_And_Not_80 -- - ----------------------- - - function Exists_And_Not_80 (Server_Port : String) return String is - begin - if Server_Port = "80" then - return ""; - else - return ':' & Server_Port; - end if; - end Exists_And_Not_80; - - -- Start of processing for URL - - begin - Check_Environment; - - return "http://" - & Metavariable (Server_Name) - & Exists_And_Not_80 (Metavariable (Server_Port)) - & Metavariable (Script_Name); - end URL; - - ----------- - -- Value -- - ----------- - - function Value - (Key : String; - Required : Boolean := False) - return String - is - begin - Check_Environment; - - for K in 1 .. Key_Value_Table.Last loop - if Key_Value_Table.Table (K).Key.all = Key then - return Key_Value_Table.Table (K).Value.all; - end if; - end loop; - - if Required then - raise Parameter_Not_Found; - else - return ""; - end if; - end Value; - - ----------- - -- Value -- - ----------- - - function Value (Position : Positive) return String is - begin - Check_Environment; - - if Position <= Key_Value_Table.Last then - return Key_Value_Table.Table (Position).Value.all; - else - raise Parameter_Not_Found; - end if; - end Value; - -begin - - Initialize; - -end GNAT.CGI; diff --git a/gcc/ada/g-cgi.ads b/gcc/ada/g-cgi.ads deleted file mode 100644 index faaa16b..0000000 --- a/gcc/ada/g-cgi.ads +++ /dev/null @@ -1,255 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a package to interface a GNAT program with a Web server via the --- Common Gateway Interface (CGI). - --- Other related packages are: - --- GNAT.CGI.Cookie which deal with Web HTTP Cookies. --- GNAT.CGI.Debug which output complete CGI runtime environment - --- Basically this package parse the CGI parameter which are a set of key/value --- pairs. It builds a table whose index is the key and provides some services --- to deal with this table. - --- Example: - --- Consider the following simple HTML form to capture a client name: - --- --- --- --- My Web Page --- - --- ---
--- --- ---
--- --- - --- The following program will retrieve the client's name: - --- with GNAT.CGI; - --- procedure New_Client is --- use GNAT; - --- procedure Add_Client_To_Database (Name : String) is --- begin --- ... --- end Add_Client_To_Database; - --- begin --- -- Check that we have 2 arguments (there is two inputs tag in --- -- the HTML form) and that one of them is called "client_name". - --- if CGI.Argument_Count = 2 --- and then CGI.Key_Exists ("client_name") --- then --- Add_Client_To_Database (CGI.Value ("client_name")); --- end if; - --- ... - --- CGI.Put_Header; --- Text_IO.Put_Line ("< ... Ok ... >"); - --- exception --- when CGI.Data_Error => --- CGI.Put_Header ("Location: /htdocs/error.html"); --- -- This returns the address of a Web page to be displayed --- -- using a "Location:" header style. --- end New_Client; - --- Note that the names in this package interface have been designed so that --- they read nicely with the CGI prefix. The recommended style is to avoid --- a use clause for GNAT.CGI, but to include a use clause for GNAT. - --- This package builds up a table of CGI parameters whose memory is not --- released. A CGI program is expected to be a short lived program and --- so it is adequate to have the underlying OS free the program on exit. - -package GNAT.CGI is - - Data_Error : exception; - -- This is raised when there is a problem with the CGI protocol. Either - -- the data could not be retrieved or the CGI environment is invalid. - -- - -- The package will initialize itself by parsing the runtime CGI - -- environment during elaboration but we do not want to raise an - -- exception at this time, so the exception Data_Error is deferred - -- and will be raised when calling any services below (except for Ok). - - Parameter_Not_Found : exception; - -- This exception is raised when a specific parameter is not found - - Default_Header : constant String := "Content-type: text/html"; - -- This is the default header returned by Put_Header. If the CGI program - -- returned data is not an HTML page, this header must be change to a - -- valid MIME type. - - type Method_Type is (Get, Post); - -- The method used to pass parameter from the Web client to the - -- server. With the GET method parameters are passed via the command - -- line, with the POST method parameters are passed via environment - -- variables. Others methods are not supported by this implementation. - - type Metavariable_Name is - (Auth_Type, - Content_Length, - Content_Type, - Document_Root, -- Web server dependent - Gateway_Interface, - HTTP_Accept, - HTTP_Accept_Encoding, - HTTP_Accept_Language, - HTTP_Connection, - HTTP_Cookie, - HTTP_Extension, - HTTP_From, - HTTP_Host, - HTTP_Referer, - HTTP_User_Agent, - Path, - Path_Info, - Path_Translated, - Query_String, - Remote_Addr, - Remote_Host, - Remote_Port, -- Web server dependent - Remote_Ident, - Remote_User, - Request_Method, - Request_URI, -- Web server dependent - Script_Filename, -- Web server dependent - Script_Name, - Server_Addr, -- Web server dependent - Server_Admin, -- Web server dependent - Server_Name, - Server_Port, - Server_Protocol, - Server_Signature, -- Web server dependent - Server_Software); - -- CGI metavariables that are set by the Web server during program - -- execution. All these variables are part of the restricted CGI runtime - -- environment and can be read using Metavariable service. The detailed - -- meanings of these metavariables are out of the scope of this - -- description. Please refer to http://www.w3.org/CGI/ for a description - -- of the CGI specification. Some metavariables are Web server dependent - -- and are not described in the cited document. - - procedure Put_Header - (Header : String := Default_Header; - Force : Boolean := False); - -- Output standard CGI header by default. The header string is followed by - -- an empty line. This header must be the first answer sent back to the - -- server. Do nothing if this function has already been called and Force - -- is False. - - function Ok return Boolean; - -- Returns True if the CGI environment is valid and False otherwise. - -- Every service used when the CGI environment is not valid will raise - -- the exception Data_Error. - - function Method return Method_Type; - -- Returns the method used to call the CGI - - function Metavariable - (Name : Metavariable_Name; - Required : Boolean := False) return String; - -- Returns parameter Name value. Returns the null string if Name - -- environment variable is not defined or raises Data_Error if - -- Required is set to True. - - function Metavariable_Exists (Name : Metavariable_Name) return Boolean; - -- Returns True if the environment variable Name is defined in - -- the CGI runtime environment and False otherwise. - - function URL return String; - -- Returns the URL used to call this script without the parameters. - -- The URL form is: http://[:] - - function Argument_Count return Natural; - -- Returns the number of parameters passed to the client. This is the - -- number of input tags in a form or the number of parameters passed to - -- the CGI via the command line. - - --------------------------------------------------- - -- Services to retrieve key/value CGI parameters -- - --------------------------------------------------- - - function Value - (Key : String; - Required : Boolean := False) return String; - -- Returns the parameter value associated to the parameter named Key. - -- If parameter does not exist, returns an empty string if Required - -- is False and raises the exception Parameter_Not_Found otherwise. - - function Value (Position : Positive) return String; - -- Returns the parameter value associated with the CGI parameter number - -- Position. Raises Parameter_Not_Found if there is no such parameter - -- (i.e. Position > Argument_Count) - - function Key_Exists (Key : String) return Boolean; - -- Returns True if the parameter named Key exists and False otherwise - - function Key (Position : Positive) return String; - -- Returns the parameter key associated with the CGI parameter number - -- Position. Raises the exception Parameter_Not_Found if there is no - -- such parameter (i.e. Position > Argument_Count) - - generic - with procedure - Action - (Key : String; - Value : String; - Position : Positive; - Quit : in out Boolean); - procedure For_Every_Parameter; - -- Iterate through all existing key/value pairs and call the Action - -- supplied procedure. The Key and Value are set appropriately, Position - -- is the parameter order in the list, Quit is set to True by default. - -- Quit can be set to False to control the iterator termination. - -private - - function Decode (S : String) return String; - -- Decode Web string S. A string when passed to a CGI is encoded, - -- this function will decode the string to return the original - -- string's content. Every triplet of the form %HH (where H is an - -- hexadecimal number) is translated into the character such that: - -- Hex (Character'Pos (C)) = HH. - -end GNAT.CGI; diff --git a/gcc/ada/g-cgicoo.adb b/gcc/ada/g-cgicoo.adb deleted file mode 100644 index f0d4225..0000000 --- a/gcc/ada/g-cgicoo.adb +++ /dev/null @@ -1,405 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I . C O O K I E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Fixed; -with Ada.Strings.Maps; -with Ada.Text_IO; -with Ada.Integer_Text_IO; - -with GNAT.Table; - -package body GNAT.CGI.Cookie is - - use Ada; - - Valid_Environment : Boolean := False; - -- This boolean will be set to True if the initialization was fine - - Header_Sent : Boolean := False; - -- Will be set to True when the header will be sent - - -- Cookie data that has been added - - type String_Access is access String; - - type Cookie_Data is record - Key : String_Access; - Value : String_Access; - Comment : String_Access; - Domain : String_Access; - Max_Age : Natural; - Path : String_Access; - Secure : Boolean := False; - end record; - - type Key_Value is record - Key, Value : String_Access; - end record; - - package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50); - -- This is the table to keep all cookies to be sent back to the server - - package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); - -- This is the table to keep all cookies received from the server - - procedure Check_Environment; - pragma Inline (Check_Environment); - -- This procedure will raise Data_Error if Valid_Environment is False - - procedure Initialize; - -- Initialize CGI package by reading the runtime environment. This - -- procedure is called during elaboration. All exceptions raised during - -- this procedure are deferred. - - ----------------------- - -- Check_Environment -- - ----------------------- - - procedure Check_Environment is - begin - if not Valid_Environment then - raise Data_Error; - end if; - end Check_Environment; - - ----------- - -- Count -- - ----------- - - function Count return Natural is - begin - return Key_Value_Table.Last; - end Count; - - ------------ - -- Exists -- - ------------ - - function Exists (Key : String) return Boolean is - begin - Check_Environment; - - for K in 1 .. Key_Value_Table.Last loop - if Key_Value_Table.Table (K).Key.all = Key then - return True; - end if; - end loop; - - return False; - end Exists; - - ---------------------- - -- For_Every_Cookie -- - ---------------------- - - procedure For_Every_Cookie is - Quit : Boolean; - - begin - Check_Environment; - - for K in 1 .. Key_Value_Table.Last loop - Quit := False; - - Action (Key_Value_Table.Table (K).Key.all, - Key_Value_Table.Table (K).Value.all, - K, - Quit); - - exit when Quit; - end loop; - end For_Every_Cookie; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - - HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie); - - procedure Set_Parameter_Table (Data : String); - -- Parse Data and insert information in Key_Value_Table - - ------------------------- - -- Set_Parameter_Table -- - ------------------------- - - procedure Set_Parameter_Table (Data : String) is - - procedure Add_Parameter (K : Positive; P : String); - -- Add a single parameter into the table at index K. The parameter - -- format is "key=value". - - Count : constant Positive := - 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";")); - -- Count is the number of parameters in the string. Parameters are - -- separated by ampersand character. - - Index : Positive := Data'First; - Sep : Natural; - - ------------------- - -- Add_Parameter -- - ------------------- - - procedure Add_Parameter (K : Positive; P : String) is - Equal : constant Natural := Strings.Fixed.Index (P, "="); - begin - if Equal = 0 then - raise Data_Error; - else - Key_Value_Table.Table (K) := - Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), - new String'(Decode (P (Equal + 1 .. P'Last)))); - end if; - end Add_Parameter; - - -- Start of processing for Set_Parameter_Table - - begin - Key_Value_Table.Set_Last (Count); - - for K in 1 .. Count - 1 loop - Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";"); - - Add_Parameter (K, Data (Index .. Sep - 1)); - - Index := Sep + 2; - end loop; - - -- Add last parameter - - Add_Parameter (Count, Data (Index .. Data'Last)); - end Set_Parameter_Table; - - -- Start of processing for Initialize - - begin - if HTTP_COOKIE /= "" then - Set_Parameter_Table (HTTP_COOKIE); - end if; - - Valid_Environment := True; - - exception - when others => - Valid_Environment := False; - end Initialize; - - --------- - -- Key -- - --------- - - function Key (Position : Positive) return String is - begin - Check_Environment; - - if Position <= Key_Value_Table.Last then - return Key_Value_Table.Table (Position).Key.all; - else - raise Cookie_Not_Found; - end if; - end Key; - - -------- - -- Ok -- - -------- - - function Ok return Boolean is - begin - return Valid_Environment; - end Ok; - - ---------------- - -- Put_Header -- - ---------------- - - procedure Put_Header - (Header : String := Default_Header; - Force : Boolean := False) - is - procedure Output_Cookies; - -- Iterate through the list of cookies to be sent to the server - -- and output them. - - -------------------- - -- Output_Cookies -- - -------------------- - - procedure Output_Cookies is - - procedure Output_One_Cookie - (Key : String; - Value : String; - Comment : String; - Domain : String; - Max_Age : Natural; - Path : String; - Secure : Boolean); - -- Output one cookie in the CGI header - - ----------------------- - -- Output_One_Cookie -- - ----------------------- - - procedure Output_One_Cookie - (Key : String; - Value : String; - Comment : String; - Domain : String; - Max_Age : Natural; - Path : String; - Secure : Boolean) - is - begin - Text_IO.Put ("Set-Cookie: "); - Text_IO.Put (Key & '=' & Value); - - if Comment /= "" then - Text_IO.Put ("; Comment=" & Comment); - end if; - - if Domain /= "" then - Text_IO.Put ("; Domain=" & Domain); - end if; - - if Max_Age /= Natural'Last then - Text_IO.Put ("; Max-Age="); - Integer_Text_IO.Put (Max_Age, Width => 0); - end if; - - if Path /= "" then - Text_IO.Put ("; Path=" & Path); - end if; - - if Secure then - Text_IO.Put ("; Secure"); - end if; - - Text_IO.New_Line; - end Output_One_Cookie; - - -- Start of processing for Output_Cookies - - begin - for C in 1 .. Cookie_Table.Last loop - Output_One_Cookie (Cookie_Table.Table (C).Key.all, - Cookie_Table.Table (C).Value.all, - Cookie_Table.Table (C).Comment.all, - Cookie_Table.Table (C).Domain.all, - Cookie_Table.Table (C).Max_Age, - Cookie_Table.Table (C).Path.all, - Cookie_Table.Table (C).Secure); - end loop; - end Output_Cookies; - - -- Start of processing for Put_Header - - begin - if Header_Sent = False or else Force then - Check_Environment; - Text_IO.Put_Line (Header); - Output_Cookies; - Text_IO.New_Line; - Header_Sent := True; - end if; - end Put_Header; - - --------- - -- Set -- - --------- - - procedure Set - (Key : String; - Value : String; - Comment : String := ""; - Domain : String := ""; - Max_Age : Natural := Natural'Last; - Path : String := "/"; - Secure : Boolean := False) - is - begin - Cookie_Table.Increment_Last; - - Cookie_Table.Table (Cookie_Table.Last) := - Cookie_Data'(new String'(Key), - new String'(Value), - new String'(Comment), - new String'(Domain), - Max_Age, - new String'(Path), - Secure); - end Set; - - ----------- - -- Value -- - ----------- - - function Value - (Key : String; - Required : Boolean := False) return String - is - begin - Check_Environment; - - for K in 1 .. Key_Value_Table.Last loop - if Key_Value_Table.Table (K).Key.all = Key then - return Key_Value_Table.Table (K).Value.all; - end if; - end loop; - - if Required then - raise Cookie_Not_Found; - else - return ""; - end if; - end Value; - - function Value (Position : Positive) return String is - begin - Check_Environment; - - if Position <= Key_Value_Table.Last then - return Key_Value_Table.Table (Position).Value.all; - else - raise Cookie_Not_Found; - end if; - end Value; - --- Elaboration code for package - -begin - -- Initialize unit by reading the HTTP_COOKIE metavariable and fill - -- Key_Value_Table structure. - - Initialize; -end GNAT.CGI.Cookie; diff --git a/gcc/ada/g-cgicoo.ads b/gcc/ada/g-cgicoo.ads deleted file mode 100644 index e6657a2..0000000 --- a/gcc/ada/g-cgicoo.ads +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I . C O O K I E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a package to interface a GNAT program with a Web server via the --- Common Gateway Interface (CGI). It exports services to deal with Web --- cookies (piece of information kept in the Web client software). - --- The complete CGI Cookie specification can be found in the RFC2109 at: --- http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt - --- This package builds up data tables whose memory is not released. A CGI --- program is expected to be a short lived program and so it is adequate to --- have the underlying OS free the program on exit. - -package GNAT.CGI.Cookie is - - -- The package will initialize itself by parsing the HTTP_Cookie runtime - -- CGI environment variable during elaboration but we do not want to raise - -- an exception at this time, so the exception Data_Error is deferred and - -- will be raised when calling any services below (except for Ok). - - Cookie_Not_Found : exception; - -- This exception is raised when a specific parameter is not found - - procedure Put_Header - (Header : String := Default_Header; - Force : Boolean := False); - -- Output standard CGI header by default. This header must be returned - -- back to the server at the very beginning and will be output only for - -- the first call to Put_Header if Force is set to False. This procedure - -- also outputs the Cookies that have been defined. If the program uses - -- the GNAT.CGI.Put_Header service, cookies will not be set. - -- - -- Cookies are passed back to the server in the header, the format is: - -- - -- Set-Cookie: =; comment=; domain=; - -- max_age=; path=[; secured] - - function Ok return Boolean; - -- Returns True if the CGI cookie environment is valid and False otherwise. - -- Every service used when the CGI environment is not valid will raise the - -- exception Data_Error. - - function Count return Natural; - -- Returns the number of cookies received by the CGI - - function Value - (Key : String; - Required : Boolean := False) return String; - -- Returns the cookie value associated with the cookie named Key. If cookie - -- does not exist, returns an empty string if Required is False and raises - -- the exception Cookie_Not_Found otherwise. - - function Value (Position : Positive) return String; - -- Returns the value associated with the cookie number Position of the CGI. - -- It raises Cookie_Not_Found if there is no such cookie (i.e. Position > - -- Count) - - function Exists (Key : String) return Boolean; - -- Returns True if the cookie named Key exist and False otherwise - - function Key (Position : Positive) return String; - -- Returns the key associated with the cookie number Position of the CGI. - -- It raises Cookie_Not_Found if there is no such cookie (i.e. Position > - -- Count) - - procedure Set - (Key : String; - Value : String; - Comment : String := ""; - Domain : String := ""; - Max_Age : Natural := Natural'Last; - Path : String := "/"; - Secure : Boolean := False); - -- Add a cookie to the list of cookies. This will be sent back to the - -- server by the Put_Header service above. - - generic - with procedure - Action - (Key : String; - Value : String; - Position : Positive; - Quit : in out Boolean); - procedure For_Every_Cookie; - -- Iterate through all cookies received from the server and call - -- the Action supplied procedure. The Key, Value parameters are set - -- appropriately, Position is the cookie order in the list, Quit is set to - -- True by default. Quit can be set to False to control the iterator - -- termination. - -end GNAT.CGI.Cookie; diff --git a/gcc/ada/g-cgideb.adb b/gcc/ada/g-cgideb.adb deleted file mode 100644 index 6cc45e9..0000000 --- a/gcc/ada/g-cgideb.adb +++ /dev/null @@ -1,314 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I . D E B U G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings.Unbounded; - -package body GNAT.CGI.Debug is - - use Ada.Strings.Unbounded; - - -- Define the abstract type which act as a template for all debug IO modes. - -- To create a new IO mode you must: - -- 1. create a new package spec - -- 2. create a new type derived from IO.Format - -- 3. implement all the abstract routines in IO - - package IO is - - type Format is abstract tagged null record; - - function Output (Mode : Format'Class) return String; - - function Variable - (Mode : Format; - Name : String; - Value : String) return String is abstract; - -- Returns variable Name and its associated value - - function New_Line (Mode : Format) return String is abstract; - -- Returns a new line such as this concatenated between two strings - -- will display the strings on two lines. - - function Title (Mode : Format; Str : String) return String is abstract; - -- Returns Str as a Title. A title must be alone and centered on a - -- line. Next output will be on the following line. - - function Header - (Mode : Format; - Str : String) return String is abstract; - -- Returns Str as an Header. An header must be alone on its line. Next - -- output will be on the following line. - - end IO; - - ---------------------- - -- IO for HTML Mode -- - ---------------------- - - package HTML_IO is - - -- See IO for comments about these routines - - type Format is new IO.Format with null record; - - function Variable - (IO : Format; - Name : String; - Value : String) return String; - - function New_Line (IO : Format) return String; - - function Title (IO : Format; Str : String) return String; - - function Header (IO : Format; Str : String) return String; - - end HTML_IO; - - ---------------------------- - -- IO for Plain Text Mode -- - ---------------------------- - - package Text_IO is - - -- See IO for comments about these routines - - type Format is new IO.Format with null record; - - function Variable - (IO : Format; - Name : String; - Value : String) return String; - - function New_Line (IO : Format) return String; - - function Title (IO : Format; Str : String) return String; - - function Header (IO : Format; Str : String) return String; - - end Text_IO; - - -------------- - -- Debug_IO -- - -------------- - - package body IO is - - ------------ - -- Output -- - ------------ - - function Output (Mode : Format'Class) return String is - Result : Unbounded_String; - - begin - Result := - To_Unbounded_String - (Title (Mode, "CGI complete runtime environment") - & Header (Mode, "CGI parameters:") - & New_Line (Mode)); - - for K in 1 .. Argument_Count loop - Result := Result - & Variable (Mode, Key (K), Value (K)) - & New_Line (Mode); - end loop; - - Result := Result - & New_Line (Mode) - & Header (Mode, "CGI environment variables (Metavariables):") - & New_Line (Mode); - - for P in Metavariable_Name'Range loop - if Metavariable_Exists (P) then - Result := Result - & Variable (Mode, - Metavariable_Name'Image (P), - Metavariable (P)) - & New_Line (Mode); - end if; - end loop; - - return To_String (Result); - end Output; - - end IO; - - ------------- - -- HTML_IO -- - ------------- - - package body HTML_IO is - - NL : constant String := (1 => ASCII.LF); - - function Bold (S : String) return String; - -- Returns S as an HTML bold string - - function Italic (S : String) return String; - -- Returns S as an HTML italic string - - ---------- - -- Bold -- - ---------- - - function Bold (S : String) return String is - begin - return "" & S & ""; - end Bold; - - ------------ - -- Header -- - ------------ - - function Header (IO : Format; Str : String) return String is - pragma Unreferenced (IO); - begin - return "

" & Str & "

" & NL; - end Header; - - ------------ - -- Italic -- - ------------ - - function Italic (S : String) return String is - begin - return "" & S & ""; - end Italic; - - -------------- - -- New_Line -- - -------------- - - function New_Line (IO : Format) return String is - pragma Unreferenced (IO); - begin - return "
" & NL; - end New_Line; - - ----------- - -- Title -- - ----------- - - function Title (IO : Format; Str : String) return String is - pragma Unreferenced (IO); - begin - return "

" & Str & "

" & NL; - end Title; - - -------------- - -- Variable -- - -------------- - - function Variable - (IO : Format; - Name : String; - Value : String) return String - is - pragma Unreferenced (IO); - begin - return Bold (Name) & " = " & Italic (Value); - end Variable; - - end HTML_IO; - - ------------- - -- Text_IO -- - ------------- - - package body Text_IO is - - ------------ - -- Header -- - ------------ - - function Header (IO : Format; Str : String) return String is - begin - return "*** " & Str & New_Line (IO); - end Header; - - -------------- - -- New_Line -- - -------------- - - function New_Line (IO : Format) return String is - pragma Unreferenced (IO); - begin - return String'(1 => ASCII.LF); - end New_Line; - - ----------- - -- Title -- - ----------- - - function Title (IO : Format; Str : String) return String is - Spaces : constant Natural := (80 - Str'Length) / 2; - Indent : constant String (1 .. Spaces) := (others => ' '); - begin - return Indent & Str & New_Line (IO); - end Title; - - -------------- - -- Variable -- - -------------- - - function Variable - (IO : Format; - Name : String; - Value : String) return String - is - pragma Unreferenced (IO); - begin - return " " & Name & " = " & Value; - end Variable; - - end Text_IO; - - ----------------- - -- HTML_Output -- - ----------------- - - function HTML_Output return String is - HTML : HTML_IO.Format; - begin - return IO.Output (Mode => HTML); - end HTML_Output; - - ----------------- - -- Text_Output -- - ----------------- - - function Text_Output return String is - Text : Text_IO.Format; - begin - return IO.Output (Mode => Text); - end Text_Output; - -end GNAT.CGI.Debug; diff --git a/gcc/ada/g-cgideb.ads b/gcc/ada/g-cgideb.ads deleted file mode 100644 index 7a1e979..0000000 --- a/gcc/ada/g-cgideb.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C G I . D E B U G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a package to help debugging CGI (Common Gateway Interface) --- programs written in Ada. - -package GNAT.CGI.Debug is - - -- Both functions below output all possible CGI parameters set. These are - -- the form field and all CGI environment variables which make the CGI - -- environment at runtime. - - function Text_Output return String; - -- Returns a plain text version of the CGI runtime environment - - function HTML_Output return String; - -- Returns an HTML version of the CGI runtime environment - -end GNAT.CGI.Debug; diff --git a/gcc/ada/g-comlin.adb b/gcc/ada/g-comlin.adb deleted file mode 100644 index 2fd90df..0000000 --- a/gcc/ada/g-comlin.adb +++ /dev/null @@ -1,3613 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C O M M A N D _ L I N E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Strings.Unbounded; -with Ada.Text_IO; use Ada.Text_IO; -with Ada.Unchecked_Deallocation; - -with GNAT.Directory_Operations; use GNAT.Directory_Operations; -with GNAT.OS_Lib; use GNAT.OS_Lib; - -package body GNAT.Command_Line is - - -- General note: this entire body could use much more commenting. There - -- are large sections of uncommented code throughout, and many formal - -- parameters of local subprograms are not documented at all ??? - - package CL renames Ada.Command_Line; - - type Switch_Parameter_Type is - (Parameter_None, - Parameter_With_Optional_Space, -- ':' in getopt - Parameter_With_Space_Or_Equal, -- '=' in getopt - Parameter_No_Space, -- '!' in getopt - Parameter_Optional); -- '?' in getopt - - procedure Set_Parameter - (Variable : out Parameter_Type; - Arg_Num : Positive; - First : Positive; - Last : Natural; - Extra : Character := ASCII.NUL); - pragma Inline (Set_Parameter); - -- Set the parameter that will be returned by Parameter below - -- - -- Extra is a character that needs to be added when reporting Full_Switch. - -- (it will in general be the switch character, for instance '-'). - -- Otherwise, Full_Switch will report 'f' instead of '-f'. In particular, - -- it needs to be set when reporting an invalid switch or handling '*'. - -- - -- Parameters need to be defined ??? - - function Goto_Next_Argument_In_Section (Parser : Opt_Parser) return Boolean; - -- Go to the next argument on the command line. If we are at the end of - -- the current section, we want to make sure there is no other identical - -- section on the command line (there might be multiple instances of - -- -largs). Returns True iff there is another argument. - - function Get_File_Names_Case_Sensitive return Integer; - pragma Import (C, Get_File_Names_Case_Sensitive, - "__gnat_get_file_names_case_sensitive"); - - File_Names_Case_Sensitive : constant Boolean := - Get_File_Names_Case_Sensitive /= 0; - - procedure Canonical_Case_File_Name (S : in out String); - -- Given a file name, converts it to canonical case form. For systems where - -- file names are case sensitive, this procedure has no effect. If file - -- names are not case sensitive (i.e. for example if you have the file - -- "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then this call - -- converts the given string to canonical all lower case form, so that two - -- file names compare equal if they refer to the same file. - - procedure Internal_Initialize_Option_Scan - (Parser : Opt_Parser; - Switch_Char : Character; - Stop_At_First_Non_Switch : Boolean; - Section_Delimiters : String); - -- Initialize Parser, which must have been allocated already - - function Argument (Parser : Opt_Parser; Index : Integer) return String; - -- Return the index-th command line argument - - procedure Find_Longest_Matching_Switch - (Switches : String; - Arg : String; - Index_In_Switches : out Integer; - Switch_Length : out Integer; - Param : out Switch_Parameter_Type); - -- Return the Longest switch from Switches that at least partially matches - -- Arg. Index_In_Switches is set to 0 if none matches. What are other - -- parameters??? in particular Param is not always set??? - - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Argument_List, Argument_List_Access); - - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Command_Line_Configuration_Record, Command_Line_Configuration); - - procedure Remove (Line : in out Argument_List_Access; Index : Integer); - -- Remove a specific element from Line - - procedure Add - (Line : in out Argument_List_Access; - Str : String_Access; - Before : Boolean := False); - -- Add a new element to Line. If Before is True, the item is inserted at - -- the beginning, else it is appended. - - procedure Add - (Config : in out Command_Line_Configuration; - Switch : Switch_Definition); - procedure Add - (Def : in out Alias_Definitions_List; - Alias : Alias_Definition); - -- Add a new element to Def - - procedure Initialize_Switch_Def - (Def : out Switch_Definition; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Argument : String := "ARG"); - -- Initialize [Def] with the contents of the other parameters. - -- This also checks consistency of the switch parameters, and will raise - -- Invalid_Switch if they do not match. - - procedure Decompose_Switch - (Switch : String; - Parameter_Type : out Switch_Parameter_Type; - Switch_Last : out Integer); - -- Given a switch definition ("name:" for instance), extracts the type of - -- parameter that is expected, and the name of the switch - - function Can_Have_Parameter (S : String) return Boolean; - -- True if S can have a parameter - - function Require_Parameter (S : String) return Boolean; - -- True if S requires a parameter - - function Actual_Switch (S : String) return String; - -- Remove any possible trailing '!', ':', '?' and '=' - - generic - with procedure Callback - (Simple_Switch : String; - Separator : String; - Parameter : String; - Index : Integer); -- Index in Config.Switches, or -1 - procedure For_Each_Simple_Switch - (Config : Command_Line_Configuration; - Section : String; - Switch : String; - Parameter : String := ""; - Unalias : Boolean := True); - -- Breaks Switch into as simple switches as possible (expanding aliases and - -- ungrouping common prefixes when possible), and call Callback for each of - -- these. - - procedure Sort_Sections - (Line : not null GNAT.OS_Lib.Argument_List_Access; - Sections : GNAT.OS_Lib.Argument_List_Access; - Params : GNAT.OS_Lib.Argument_List_Access); - -- Reorder the command line switches so that the switches belonging to a - -- section are grouped together. - - procedure Group_Switches - (Cmd : Command_Line; - Result : Argument_List_Access; - Sections : Argument_List_Access; - Params : Argument_List_Access); - -- Group switches with common prefixes whenever possible. Once they have - -- been grouped, we also check items for possible aliasing. - - procedure Alias_Switches - (Cmd : Command_Line; - Result : Argument_List_Access; - Params : Argument_List_Access); - -- When possible, replace one or more switches by an alias, i.e. a shorter - -- version. - - function Looking_At - (Type_Str : String; - Index : Natural; - Substring : String) return Boolean; - -- Return True if the characters starting at Index in Type_Str are - -- equivalent to Substring. - - generic - with function Callback (S : String; Index : Integer) return Boolean; - procedure Foreach_Switch - (Config : Command_Line_Configuration; - Section : String); - -- Iterate over all switches defined in Config, for a specific section. - -- Index is set to the index in Config.Switches. Stop iterating when - -- Callback returns False. - - -------------- - -- Argument -- - -------------- - - function Argument (Parser : Opt_Parser; Index : Integer) return String is - begin - if Parser.Arguments /= null then - return Parser.Arguments (Index + Parser.Arguments'First - 1).all; - else - return CL.Argument (Index); - end if; - end Argument; - - ------------------------------ - -- Canonical_Case_File_Name -- - ------------------------------ - - procedure Canonical_Case_File_Name (S : in out String) is - begin - if not File_Names_Case_Sensitive then - for J in S'Range loop - if S (J) in 'A' .. 'Z' then - S (J) := Character'Val - (Character'Pos (S (J)) + - (Character'Pos ('a') - Character'Pos ('A'))); - end if; - end loop; - end if; - end Canonical_Case_File_Name; - - --------------- - -- Expansion -- - --------------- - - function Expansion (Iterator : Expansion_Iterator) return String is - type Pointer is access all Expansion_Iterator; - - It : constant Pointer := Iterator'Unrestricted_Access; - S : String (1 .. 1024); - Last : Natural; - - Current : Depth := It.Current_Depth; - NL : Positive; - - begin - -- It is assumed that a directory is opened at the current level. - -- Otherwise GNAT.Directory_Operations.Directory_Error will be raised - -- at the first call to Read. - - loop - Read (It.Levels (Current).Dir, S, Last); - - -- If we have exhausted the directory, close it and go back one level - - if Last = 0 then - Close (It.Levels (Current).Dir); - - -- If we are at level 1, we are finished; return an empty string - - if Current = 1 then - return String'(1 .. 0 => ' '); - - -- Otherwise continue with the directory at the previous level - - else - Current := Current - 1; - It.Current_Depth := Current; - end if; - - -- If this is a directory, that is neither "." or "..", attempt to - -- go to the next level. - - elsif Is_Directory - (It.Dir_Name (1 .. It.Levels (Current).Name_Last) & - S (1 .. Last)) - and then S (1 .. Last) /= "." - and then S (1 .. Last) /= ".." - then - -- We can go to the next level only if we have not reached the - -- maximum depth, - - if Current < It.Maximum_Depth then - NL := It.Levels (Current).Name_Last; - - -- And if relative path of this new directory is not too long - - if NL + Last + 1 < Max_Path_Length then - Current := Current + 1; - It.Current_Depth := Current; - It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last); - NL := NL + Last + 1; - It.Dir_Name (NL) := Directory_Separator; - It.Levels (Current).Name_Last := NL; - Canonical_Case_File_Name (It.Dir_Name (1 .. NL)); - - -- Open the new directory, and read from it - - GNAT.Directory_Operations.Open - (It.Levels (Current).Dir, It.Dir_Name (1 .. NL)); - end if; - end if; - end if; - - -- Check the relative path against the pattern - - -- Note that we try to match also against directory names, since - -- clients of this function may expect to retrieve directories. - - declare - Name : String := - It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) - & S (1 .. Last); - - begin - Canonical_Case_File_Name (Name); - - -- If it matches return the relative path - - if GNAT.Regexp.Match (Name, Iterator.Regexp) then - return Name; - end if; - end; - end loop; - end Expansion; - - --------------------- - -- Current_Section -- - --------------------- - - function Current_Section - (Parser : Opt_Parser := Command_Line_Parser) return String - is - begin - if Parser.Current_Section = 1 then - return ""; - end if; - - for Index in reverse 1 .. Integer'Min (Parser.Current_Argument - 1, - Parser.Section'Last) - loop - if Parser.Section (Index) = 0 then - return Argument (Parser, Index); - end if; - end loop; - - return ""; - end Current_Section; - - ----------------- - -- Full_Switch -- - ----------------- - - function Full_Switch - (Parser : Opt_Parser := Command_Line_Parser) return String - is - begin - if Parser.The_Switch.Extra = ASCII.NUL then - return Argument (Parser, Parser.The_Switch.Arg_Num) - (Parser.The_Switch.First .. Parser.The_Switch.Last); - else - return Parser.The_Switch.Extra - & Argument (Parser, Parser.The_Switch.Arg_Num) - (Parser.The_Switch.First .. Parser.The_Switch.Last); - end if; - end Full_Switch; - - ------------------ - -- Get_Argument -- - ------------------ - - function Get_Argument - (Do_Expansion : Boolean := False; - Parser : Opt_Parser := Command_Line_Parser) return String - is - begin - if Parser.In_Expansion then - declare - S : constant String := Expansion (Parser.Expansion_It); - begin - if S'Length /= 0 then - return S; - else - Parser.In_Expansion := False; - end if; - end; - end if; - - if Parser.Current_Argument > Parser.Arg_Count then - - -- If this is the first time this function is called - - if Parser.Current_Index = 1 then - Parser.Current_Argument := 1; - while Parser.Current_Argument <= Parser.Arg_Count - and then Parser.Section (Parser.Current_Argument) /= - Parser.Current_Section - loop - Parser.Current_Argument := Parser.Current_Argument + 1; - end loop; - - else - return String'(1 .. 0 => ' '); - end if; - - elsif Parser.Section (Parser.Current_Argument) = 0 then - while Parser.Current_Argument <= Parser.Arg_Count - and then Parser.Section (Parser.Current_Argument) /= - Parser.Current_Section - loop - Parser.Current_Argument := Parser.Current_Argument + 1; - end loop; - end if; - - Parser.Current_Index := Integer'Last; - - while Parser.Current_Argument <= Parser.Arg_Count - and then Parser.Is_Switch (Parser.Current_Argument) - loop - Parser.Current_Argument := Parser.Current_Argument + 1; - end loop; - - if Parser.Current_Argument > Parser.Arg_Count then - return String'(1 .. 0 => ' '); - elsif Parser.Section (Parser.Current_Argument) = 0 then - return Get_Argument (Do_Expansion); - end if; - - Parser.Current_Argument := Parser.Current_Argument + 1; - - -- Could it be a file name with wild cards to expand? - - if Do_Expansion then - declare - Arg : constant String := - Argument (Parser, Parser.Current_Argument - 1); - begin - for Index in Arg'Range loop - if Arg (Index) = '*' - or else Arg (Index) = '?' - or else Arg (Index) = '[' - then - Parser.In_Expansion := True; - Start_Expansion (Parser.Expansion_It, Arg); - return Get_Argument (Do_Expansion, Parser); - end if; - end loop; - end; - end if; - - return Argument (Parser, Parser.Current_Argument - 1); - end Get_Argument; - - ---------------------- - -- Decompose_Switch -- - ---------------------- - - procedure Decompose_Switch - (Switch : String; - Parameter_Type : out Switch_Parameter_Type; - Switch_Last : out Integer) - is - begin - if Switch = "" then - Parameter_Type := Parameter_None; - Switch_Last := Switch'Last; - return; - end if; - - case Switch (Switch'Last) is - when ':' => - Parameter_Type := Parameter_With_Optional_Space; - Switch_Last := Switch'Last - 1; - - when '=' => - Parameter_Type := Parameter_With_Space_Or_Equal; - Switch_Last := Switch'Last - 1; - - when '!' => - Parameter_Type := Parameter_No_Space; - Switch_Last := Switch'Last - 1; - - when '?' => - Parameter_Type := Parameter_Optional; - Switch_Last := Switch'Last - 1; - - when others => - Parameter_Type := Parameter_None; - Switch_Last := Switch'Last; - end case; - end Decompose_Switch; - - ---------------------------------- - -- Find_Longest_Matching_Switch -- - ---------------------------------- - - procedure Find_Longest_Matching_Switch - (Switches : String; - Arg : String; - Index_In_Switches : out Integer; - Switch_Length : out Integer; - Param : out Switch_Parameter_Type) - is - Index : Natural; - Length : Natural := 1; - Last : Natural; - P : Switch_Parameter_Type; - - begin - Index_In_Switches := 0; - Switch_Length := 0; - - -- Remove all leading spaces first to make sure that Index points - -- at the start of the first switch. - - Index := Switches'First; - while Index <= Switches'Last and then Switches (Index) = ' ' loop - Index := Index + 1; - end loop; - - while Index <= Switches'Last loop - - -- Search the length of the parameter at this position in Switches - - Length := Index; - while Length <= Switches'Last - and then Switches (Length) /= ' ' - loop - Length := Length + 1; - end loop; - - -- Length now marks the separator after the current switch. Last will - -- mark the last character of the name of the switch. - - if Length = Index + 1 then - P := Parameter_None; - Last := Index; - else - Decompose_Switch (Switches (Index .. Length - 1), P, Last); - end if; - - -- If it is the one we searched, it may be a candidate - - if Arg'First + Last - Index <= Arg'Last - and then Switches (Index .. Last) = - Arg (Arg'First .. Arg'First + Last - Index) - and then Last - Index + 1 > Switch_Length - and then - (P /= Parameter_With_Space_Or_Equal - or else Arg'Last = Arg'First + Last - Index - or else Arg (Arg'First + Last - Index + 1) = '=') - then - Param := P; - Index_In_Switches := Index; - Switch_Length := Last - Index + 1; - end if; - - -- Look for the next switch in Switches - - while Index <= Switches'Last - and then Switches (Index) /= ' ' - loop - Index := Index + 1; - end loop; - - Index := Index + 1; - end loop; - end Find_Longest_Matching_Switch; - - ------------ - -- Getopt -- - ------------ - - function Getopt - (Switches : String; - Concatenate : Boolean := True; - Parser : Opt_Parser := Command_Line_Parser) return Character - is - Dummy : Boolean; - - begin - <> - - -- If we have finished parsing the current command line item (there - -- might be multiple switches in a single item), then go to the next - -- element. - - if Parser.Current_Argument > Parser.Arg_Count - or else (Parser.Current_Index > - Argument (Parser, Parser.Current_Argument)'Last - and then not Goto_Next_Argument_In_Section (Parser)) - then - return ASCII.NUL; - end if; - - -- By default, the switch will not have a parameter - - Parser.The_Parameter := - (Integer'Last, Integer'Last, Integer'Last - 1, ASCII.NUL); - Parser.The_Separator := ASCII.NUL; - - declare - Arg : constant String := - Argument (Parser, Parser.Current_Argument); - Index_Switches : Natural := 0; - Max_Length : Natural := 0; - End_Index : Natural; - Param : Switch_Parameter_Type; - begin - -- If we are on a new item, test if this might be a switch - - if Parser.Current_Index = Arg'First then - if Arg = "" or else Arg (Arg'First) /= Parser.Switch_Character then - - -- If it isn't a switch, return it immediately. We also know it - -- isn't the parameter to a previous switch, since that has - -- already been handled. - - if Switches (Switches'First) = '*' then - Set_Parameter - (Parser.The_Switch, - Arg_Num => Parser.Current_Argument, - First => Arg'First, - Last => Arg'Last); - Parser.Is_Switch (Parser.Current_Argument) := True; - Dummy := Goto_Next_Argument_In_Section (Parser); - return '*'; - end if; - - if Parser.Stop_At_First then - Parser.Current_Argument := Positive'Last; - return ASCII.NUL; - - elsif not Goto_Next_Argument_In_Section (Parser) then - return ASCII.NUL; - - else - -- Recurse to get the next switch on the command line - - goto Restart; - end if; - end if; - - -- We are on the first character of a new command line argument, - -- which starts with Switch_Character. Further analysis is needed. - - Parser.Current_Index := Parser.Current_Index + 1; - Parser.Is_Switch (Parser.Current_Argument) := True; - end if; - - Find_Longest_Matching_Switch - (Switches => Switches, - Arg => Arg (Parser.Current_Index .. Arg'Last), - Index_In_Switches => Index_Switches, - Switch_Length => Max_Length, - Param => Param); - - -- If switch is not accepted, it is either invalid or is returned - -- in the context of '*'. - - if Index_Switches = 0 then - - -- Find the current switch that we did not recognize. This is in - -- fact difficult because Getopt does not know explicitly about - -- short and long switches. Ideally, we would want the following - -- behavior: - - -- * for short switches, with Concatenate: - -- if -a is not recognized, and the command line has -daf - -- we should report the invalid switch as "-a". - - -- * for short switches, wihtout Concatenate: - -- we should report the invalid switch as "-daf". - - -- * for long switches: - -- if the commadn line is "--long" we should report --long - -- as unrecongized. - - -- Unfortunately, the fact that long switches start with a - -- duplicate switch character is just a convention (so we could - -- have a long switch "-long" for instance). We'll still rely on - -- this convention here to try and get as helpful an error message - -- as possible. - - -- Long switch case (starting with double switch character) - - if Arg (Arg'First + 1) = Parser.Switch_Character then - End_Index := Arg'Last; - - -- Short switch case - - else - End_Index := - (if Concatenate then Parser.Current_Index else Arg'Last); - end if; - - if Switches /= "" and then Switches (Switches'First) = '*' then - - -- Always prepend the switch character, so that users know - -- that this comes from a switch on the command line. This - -- is especially important when Concatenate is False, since - -- otherwise the current argument first character is lost. - - if Parser.Section (Parser.Current_Argument) = 0 then - - -- A section transition should not be returned to the user - - Dummy := Goto_Next_Argument_In_Section (Parser); - goto Restart; - - else - Set_Parameter - (Parser.The_Switch, - Arg_Num => Parser.Current_Argument, - First => Parser.Current_Index, - Last => Arg'Last, - Extra => Parser.Switch_Character); - Parser.Is_Switch (Parser.Current_Argument) := True; - Dummy := Goto_Next_Argument_In_Section (Parser); - return '*'; - end if; - end if; - - if Parser.Current_Index = Arg'First then - Set_Parameter - (Parser.The_Switch, - Arg_Num => Parser.Current_Argument, - First => Parser.Current_Index, - Last => End_Index); - else - Set_Parameter - (Parser.The_Switch, - Arg_Num => Parser.Current_Argument, - First => Parser.Current_Index, - Last => End_Index, - Extra => Parser.Switch_Character); - end if; - - Parser.Current_Index := End_Index + 1; - - raise Invalid_Switch; - end if; - - End_Index := Parser.Current_Index + Max_Length - 1; - Set_Parameter - (Parser.The_Switch, - Arg_Num => Parser.Current_Argument, - First => Parser.Current_Index, - Last => End_Index); - - case Param is - when Parameter_With_Optional_Space => - if End_Index < Arg'Last then - Set_Parameter - (Parser.The_Parameter, - Arg_Num => Parser.Current_Argument, - First => End_Index + 1, - Last => Arg'Last); - Dummy := Goto_Next_Argument_In_Section (Parser); - - elsif Parser.Current_Argument < Parser.Arg_Count - and then Parser.Section (Parser.Current_Argument + 1) /= 0 - then - Parser.Current_Argument := Parser.Current_Argument + 1; - Parser.The_Separator := ' '; - Set_Parameter - (Parser.The_Parameter, - Arg_Num => Parser.Current_Argument, - First => Argument (Parser, Parser.Current_Argument)'First, - Last => Argument (Parser, Parser.Current_Argument)'Last); - Parser.Is_Switch (Parser.Current_Argument) := True; - Dummy := Goto_Next_Argument_In_Section (Parser); - - else - Parser.Current_Index := End_Index + 1; - raise Invalid_Parameter; - end if; - - when Parameter_With_Space_Or_Equal => - - -- If the switch is of the form =xxx - - if End_Index < Arg'Last then - if Arg (End_Index + 1) = '=' - and then End_Index + 1 < Arg'Last - then - Parser.The_Separator := '='; - Set_Parameter - (Parser.The_Parameter, - Arg_Num => Parser.Current_Argument, - First => End_Index + 2, - Last => Arg'Last); - Dummy := Goto_Next_Argument_In_Section (Parser); - - else - Parser.Current_Index := End_Index + 1; - raise Invalid_Parameter; - end if; - - -- Case of switch of the form xxx - - elsif Parser.Current_Argument < Parser.Arg_Count - and then Parser.Section (Parser.Current_Argument + 1) /= 0 - then - Parser.Current_Argument := Parser.Current_Argument + 1; - Parser.The_Separator := ' '; - Set_Parameter - (Parser.The_Parameter, - Arg_Num => Parser.Current_Argument, - First => Argument (Parser, Parser.Current_Argument)'First, - Last => Argument (Parser, Parser.Current_Argument)'Last); - Parser.Is_Switch (Parser.Current_Argument) := True; - Dummy := Goto_Next_Argument_In_Section (Parser); - - else - Parser.Current_Index := End_Index + 1; - raise Invalid_Parameter; - end if; - - when Parameter_No_Space => - if End_Index < Arg'Last then - Set_Parameter - (Parser.The_Parameter, - Arg_Num => Parser.Current_Argument, - First => End_Index + 1, - Last => Arg'Last); - Dummy := Goto_Next_Argument_In_Section (Parser); - - else - Parser.Current_Index := End_Index + 1; - raise Invalid_Parameter; - end if; - - when Parameter_Optional => - if End_Index < Arg'Last then - Set_Parameter - (Parser.The_Parameter, - Arg_Num => Parser.Current_Argument, - First => End_Index + 1, - Last => Arg'Last); - end if; - - Dummy := Goto_Next_Argument_In_Section (Parser); - - when Parameter_None => - if Concatenate or else End_Index = Arg'Last then - Parser.Current_Index := End_Index + 1; - - else - -- If Concatenate is False and the full argument is not - -- recognized as a switch, this is an invalid switch. - - if Switches (Switches'First) = '*' then - Set_Parameter - (Parser.The_Switch, - Arg_Num => Parser.Current_Argument, - First => Arg'First, - Last => Arg'Last); - Parser.Is_Switch (Parser.Current_Argument) := True; - Dummy := Goto_Next_Argument_In_Section (Parser); - return '*'; - end if; - - Set_Parameter - (Parser.The_Switch, - Arg_Num => Parser.Current_Argument, - First => Parser.Current_Index, - Last => Arg'Last, - Extra => Parser.Switch_Character); - Parser.Current_Index := Arg'Last + 1; - raise Invalid_Switch; - end if; - end case; - - return Switches (Index_Switches); - end; - end Getopt; - - ----------------------------------- - -- Goto_Next_Argument_In_Section -- - ----------------------------------- - - function Goto_Next_Argument_In_Section - (Parser : Opt_Parser) return Boolean - is - begin - Parser.Current_Argument := Parser.Current_Argument + 1; - - if Parser.Current_Argument > Parser.Arg_Count - or else Parser.Section (Parser.Current_Argument) = 0 - then - loop - Parser.Current_Argument := Parser.Current_Argument + 1; - - if Parser.Current_Argument > Parser.Arg_Count then - Parser.Current_Index := 1; - return False; - end if; - - exit when Parser.Section (Parser.Current_Argument) = - Parser.Current_Section; - end loop; - end if; - - Parser.Current_Index := - Argument (Parser, Parser.Current_Argument)'First; - - return True; - end Goto_Next_Argument_In_Section; - - ------------------ - -- Goto_Section -- - ------------------ - - procedure Goto_Section - (Name : String := ""; - Parser : Opt_Parser := Command_Line_Parser) - is - Index : Integer; - - begin - Parser.In_Expansion := False; - - if Name = "" then - Parser.Current_Argument := 1; - Parser.Current_Index := 1; - Parser.Current_Section := 1; - return; - end if; - - Index := 1; - while Index <= Parser.Arg_Count loop - if Parser.Section (Index) = 0 - and then Argument (Parser, Index) = Parser.Switch_Character & Name - then - Parser.Current_Argument := Index + 1; - Parser.Current_Index := 1; - - if Parser.Current_Argument <= Parser.Arg_Count then - Parser.Current_Section := - Parser.Section (Parser.Current_Argument); - end if; - - -- Exit from loop if we have the start of another section - - if Index = Parser.Section'Last - or else Parser.Section (Index + 1) /= 0 - then - return; - end if; - end if; - - Index := Index + 1; - end loop; - - Parser.Current_Argument := Positive'Last; - Parser.Current_Index := 2; -- so that Get_Argument returns nothing - end Goto_Section; - - ---------------------------- - -- Initialize_Option_Scan -- - ---------------------------- - - procedure Initialize_Option_Scan - (Switch_Char : Character := '-'; - Stop_At_First_Non_Switch : Boolean := False; - Section_Delimiters : String := "") - is - begin - Internal_Initialize_Option_Scan - (Parser => Command_Line_Parser, - Switch_Char => Switch_Char, - Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, - Section_Delimiters => Section_Delimiters); - end Initialize_Option_Scan; - - ---------------------------- - -- Initialize_Option_Scan -- - ---------------------------- - - procedure Initialize_Option_Scan - (Parser : out Opt_Parser; - Command_Line : GNAT.OS_Lib.Argument_List_Access; - Switch_Char : Character := '-'; - Stop_At_First_Non_Switch : Boolean := False; - Section_Delimiters : String := "") - is - begin - Free (Parser); - - if Command_Line = null then - Parser := new Opt_Parser_Data (CL.Argument_Count); - Internal_Initialize_Option_Scan - (Parser => Parser, - Switch_Char => Switch_Char, - Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, - Section_Delimiters => Section_Delimiters); - else - Parser := new Opt_Parser_Data (Command_Line'Length); - Parser.Arguments := Command_Line; - Internal_Initialize_Option_Scan - (Parser => Parser, - Switch_Char => Switch_Char, - Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, - Section_Delimiters => Section_Delimiters); - end if; - end Initialize_Option_Scan; - - ------------------------------------- - -- Internal_Initialize_Option_Scan -- - ------------------------------------- - - procedure Internal_Initialize_Option_Scan - (Parser : Opt_Parser; - Switch_Char : Character; - Stop_At_First_Non_Switch : Boolean; - Section_Delimiters : String) - is - Section_Num : Section_Number; - Section_Index : Integer; - Last : Integer; - Delimiter_Found : Boolean; - - Discard : Boolean; - pragma Warnings (Off, Discard); - - begin - Parser.Current_Argument := 0; - Parser.Current_Index := 0; - Parser.In_Expansion := False; - Parser.Switch_Character := Switch_Char; - Parser.Stop_At_First := Stop_At_First_Non_Switch; - Parser.Section := (others => 1); - - -- If we are using sections, we have to preprocess the command line to - -- delimit them. A section can be repeated, so we just give each item - -- on the command line a section number - - Section_Num := 1; - Section_Index := Section_Delimiters'First; - while Section_Index <= Section_Delimiters'Last loop - Last := Section_Index; - while Last <= Section_Delimiters'Last - and then Section_Delimiters (Last) /= ' ' - loop - Last := Last + 1; - end loop; - - Delimiter_Found := False; - Section_Num := Section_Num + 1; - - for Index in 1 .. Parser.Arg_Count loop - pragma Assert (Argument (Parser, Index)'First = 1); - if Argument (Parser, Index) /= "" - and then Argument (Parser, Index)(1) = Parser.Switch_Character - and then - Argument (Parser, Index) = Parser.Switch_Character & - Section_Delimiters - (Section_Index .. Last - 1) - then - Parser.Section (Index) := 0; - Delimiter_Found := True; - - elsif Parser.Section (Index) = 0 then - - -- A previous section delimiter - - Delimiter_Found := False; - - elsif Delimiter_Found then - Parser.Section (Index) := Section_Num; - end if; - end loop; - - Section_Index := Last + 1; - while Section_Index <= Section_Delimiters'Last - and then Section_Delimiters (Section_Index) = ' ' - loop - Section_Index := Section_Index + 1; - end loop; - end loop; - - Discard := Goto_Next_Argument_In_Section (Parser); - end Internal_Initialize_Option_Scan; - - --------------- - -- Parameter -- - --------------- - - function Parameter - (Parser : Opt_Parser := Command_Line_Parser) return String - is - begin - if Parser.The_Parameter.First > Parser.The_Parameter.Last then - return String'(1 .. 0 => ' '); - else - return Argument (Parser, Parser.The_Parameter.Arg_Num) - (Parser.The_Parameter.First .. Parser.The_Parameter.Last); - end if; - end Parameter; - - --------------- - -- Separator -- - --------------- - - function Separator - (Parser : Opt_Parser := Command_Line_Parser) return Character - is - begin - return Parser.The_Separator; - end Separator; - - ------------------- - -- Set_Parameter -- - ------------------- - - procedure Set_Parameter - (Variable : out Parameter_Type; - Arg_Num : Positive; - First : Positive; - Last : Natural; - Extra : Character := ASCII.NUL) - is - begin - Variable.Arg_Num := Arg_Num; - Variable.First := First; - Variable.Last := Last; - Variable.Extra := Extra; - end Set_Parameter; - - --------------------- - -- Start_Expansion -- - --------------------- - - procedure Start_Expansion - (Iterator : out Expansion_Iterator; - Pattern : String; - Directory : String := ""; - Basic_Regexp : Boolean := True) - is - Directory_Separator : Character; - pragma Import (C, Directory_Separator, "__gnat_dir_separator"); - - First : Positive := Pattern'First; - Pat : String := Pattern; - - begin - Canonical_Case_File_Name (Pat); - Iterator.Current_Depth := 1; - - -- If Directory is unspecified, use the current directory ("./" or ".\") - - if Directory = "" then - Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator; - Iterator.Start := 3; - - else - Iterator.Dir_Name (1 .. Directory'Length) := Directory; - Iterator.Start := Directory'Length + 1; - Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length)); - - -- Make sure that the last character is a directory separator - - if Directory (Directory'Last) /= Directory_Separator then - Iterator.Dir_Name (Iterator.Start) := Directory_Separator; - Iterator.Start := Iterator.Start + 1; - end if; - end if; - - Iterator.Levels (1).Name_Last := Iterator.Start - 1; - - -- Open the initial Directory, at depth 1 - - GNAT.Directory_Operations.Open - (Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1)); - - -- If in the current directory and the pattern starts with "./" or ".\", - -- drop the "./" or ".\" from the pattern. - - if Directory = "" and then Pat'Length > 2 - and then Pat (Pat'First) = '.' - and then Pat (Pat'First + 1) = Directory_Separator - then - First := Pat'First + 2; - end if; - - Iterator.Regexp := - GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True); - - Iterator.Maximum_Depth := 1; - - -- Maximum_Depth is equal to 1 plus the number of directory separators - -- in the pattern. - - for Index in First .. Pat'Last loop - if Pat (Index) = Directory_Separator then - Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1; - exit when Iterator.Maximum_Depth = Max_Depth; - end if; - end loop; - end Start_Expansion; - - ---------- - -- Free -- - ---------- - - procedure Free (Parser : in out Opt_Parser) is - procedure Unchecked_Free is new - Ada.Unchecked_Deallocation (Opt_Parser_Data, Opt_Parser); - begin - if Parser /= null and then Parser /= Command_Line_Parser then - Free (Parser.Arguments); - Unchecked_Free (Parser); - end if; - end Free; - - ------------------ - -- Define_Alias -- - ------------------ - - procedure Define_Alias - (Config : in out Command_Line_Configuration; - Switch : String; - Expanded : String; - Section : String := "") - is - Def : Alias_Definition; - - begin - if Config = null then - Config := new Command_Line_Configuration_Record; - end if; - - Def.Alias := new String'(Switch); - Def.Expansion := new String'(Expanded); - Def.Section := new String'(Section); - Add (Config.Aliases, Def); - end Define_Alias; - - ------------------- - -- Define_Prefix -- - ------------------- - - procedure Define_Prefix - (Config : in out Command_Line_Configuration; - Prefix : String) - is - begin - if Config = null then - Config := new Command_Line_Configuration_Record; - end if; - - Add (Config.Prefixes, new String'(Prefix)); - end Define_Prefix; - - --------- - -- Add -- - --------- - - procedure Add - (Config : in out Command_Line_Configuration; - Switch : Switch_Definition) - is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Switch_Definitions, Switch_Definitions_List); - - Tmp : Switch_Definitions_List; - - begin - if Config = null then - Config := new Command_Line_Configuration_Record; - end if; - - Tmp := Config.Switches; - - if Tmp = null then - Config.Switches := new Switch_Definitions (1 .. 1); - else - Config.Switches := new Switch_Definitions (1 .. Tmp'Length + 1); - Config.Switches (1 .. Tmp'Length) := Tmp.all; - Unchecked_Free (Tmp); - end if; - - if Switch.Switch /= null and then Switch.Switch.all = "*" then - Config.Star_Switch := True; - end if; - - Config.Switches (Config.Switches'Last) := Switch; - end Add; - - --------- - -- Add -- - --------- - - procedure Add - (Def : in out Alias_Definitions_List; - Alias : Alias_Definition) - is - procedure Unchecked_Free is new - Ada.Unchecked_Deallocation - (Alias_Definitions, Alias_Definitions_List); - - Tmp : Alias_Definitions_List := Def; - - begin - if Tmp = null then - Def := new Alias_Definitions (1 .. 1); - else - Def := new Alias_Definitions (1 .. Tmp'Length + 1); - Def (1 .. Tmp'Length) := Tmp.all; - Unchecked_Free (Tmp); - end if; - - Def (Def'Last) := Alias; - end Add; - - --------------------------- - -- Initialize_Switch_Def -- - --------------------------- - - procedure Initialize_Switch_Def - (Def : out Switch_Definition; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Argument : String := "ARG") - is - P1, P2 : Switch_Parameter_Type := Parameter_None; - Last1, Last2 : Integer; - - begin - if Switch /= "" then - Def.Switch := new String'(Switch); - Decompose_Switch (Switch, P1, Last1); - end if; - - if Long_Switch /= "" then - Def.Long_Switch := new String'(Long_Switch); - Decompose_Switch (Long_Switch, P2, Last2); - end if; - - if Switch /= "" and then Long_Switch /= "" then - if (P1 = Parameter_None and then P2 /= P1) - or else (P2 = Parameter_None and then P1 /= P2) - or else (P1 = Parameter_Optional and then P2 /= P1) - or else (P2 = Parameter_Optional and then P2 /= P1) - then - raise Invalid_Switch - with "Inconsistent parameter types for " - & Switch & " and " & Long_Switch; - end if; - end if; - - if Section /= "" then - Def.Section := new String'(Section); - end if; - - if Argument /= "ARG" then - Def.Argument := new String'(Argument); - end if; - - if Help /= "" then - Def.Help := new String'(Help); - end if; - end Initialize_Switch_Def; - - ------------------- - -- Define_Switch -- - ------------------- - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Argument : String := "ARG") - is - Def : Switch_Definition; - begin - if Switch /= "" or else Long_Switch /= "" then - Initialize_Switch_Def - (Def, Switch, Long_Switch, Help, Section, Argument); - Add (Config, Def); - end if; - end Define_Switch; - - ------------------- - -- Define_Switch -- - ------------------- - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Output : access Boolean; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Value : Boolean := True) - is - Def : Switch_Definition (Switch_Boolean); - begin - if Switch /= "" or else Long_Switch /= "" then - Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section); - Def.Boolean_Output := Output.all'Unchecked_Access; - Def.Boolean_Value := Value; - Add (Config, Def); - end if; - end Define_Switch; - - ------------------- - -- Define_Switch -- - ------------------- - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Output : access Integer; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Initial : Integer := 0; - Default : Integer := 1; - Argument : String := "ARG") - is - Def : Switch_Definition (Switch_Integer); - begin - if Switch /= "" or else Long_Switch /= "" then - Initialize_Switch_Def - (Def, Switch, Long_Switch, Help, Section, Argument); - Def.Integer_Output := Output.all'Unchecked_Access; - Def.Integer_Default := Default; - Def.Integer_Initial := Initial; - Add (Config, Def); - end if; - end Define_Switch; - - ------------------- - -- Define_Switch -- - ------------------- - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Output : access GNAT.Strings.String_Access; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Argument : String := "ARG") - is - Def : Switch_Definition (Switch_String); - begin - if Switch /= "" or else Long_Switch /= "" then - Initialize_Switch_Def - (Def, Switch, Long_Switch, Help, Section, Argument); - Def.String_Output := Output.all'Unchecked_Access; - Add (Config, Def); - end if; - end Define_Switch; - - -------------------- - -- Define_Section -- - -------------------- - - procedure Define_Section - (Config : in out Command_Line_Configuration; - Section : String) - is - begin - if Config = null then - Config := new Command_Line_Configuration_Record; - end if; - - Add (Config.Sections, new String'(Section)); - end Define_Section; - - -------------------- - -- Foreach_Switch -- - -------------------- - - procedure Foreach_Switch - (Config : Command_Line_Configuration; - Section : String) - is - begin - if Config /= null and then Config.Switches /= null then - for J in Config.Switches'Range loop - if (Section = "" and then Config.Switches (J).Section = null) - or else - (Config.Switches (J).Section /= null - and then Config.Switches (J).Section.all = Section) - then - exit when Config.Switches (J).Switch /= null - and then not Callback (Config.Switches (J).Switch.all, J); - - exit when Config.Switches (J).Long_Switch /= null - and then - not Callback (Config.Switches (J).Long_Switch.all, J); - end if; - end loop; - end if; - end Foreach_Switch; - - ------------------ - -- Get_Switches -- - ------------------ - - function Get_Switches - (Config : Command_Line_Configuration; - Switch_Char : Character := '-'; - Section : String := "") return String - is - Ret : Ada.Strings.Unbounded.Unbounded_String; - use Ada.Strings.Unbounded; - - function Add_Switch (S : String; Index : Integer) return Boolean; - -- Add a switch to Ret - - ---------------- - -- Add_Switch -- - ---------------- - - function Add_Switch (S : String; Index : Integer) return Boolean is - pragma Unreferenced (Index); - begin - if S = "*" then - Ret := "*" & Ret; -- Always first - elsif S (S'First) = Switch_Char then - Append (Ret, " " & S (S'First + 1 .. S'Last)); - else - Append (Ret, " " & S); - end if; - - return True; - end Add_Switch; - - Tmp : Boolean; - pragma Unreferenced (Tmp); - - procedure Foreach is new Foreach_Switch (Add_Switch); - - -- Start of processing for Get_Switches - - begin - if Config = null then - return ""; - end if; - - Foreach (Config, Section => Section); - - -- Add relevant aliases - - if Config.Aliases /= null then - for A in Config.Aliases'Range loop - if Config.Aliases (A).Section.all = Section then - Tmp := Add_Switch (Config.Aliases (A).Alias.all, -1); - end if; - end loop; - end if; - - return To_String (Ret); - end Get_Switches; - - ------------------------ - -- Section_Delimiters -- - ------------------------ - - function Section_Delimiters - (Config : Command_Line_Configuration) return String - is - use Ada.Strings.Unbounded; - Result : Unbounded_String; - - begin - if Config /= null and then Config.Sections /= null then - for S in Config.Sections'Range loop - Append (Result, " " & Config.Sections (S).all); - end loop; - end if; - - return To_String (Result); - end Section_Delimiters; - - ----------------------- - -- Set_Configuration -- - ----------------------- - - procedure Set_Configuration - (Cmd : in out Command_Line; - Config : Command_Line_Configuration) - is - begin - Cmd.Config := Config; - end Set_Configuration; - - ----------------------- - -- Get_Configuration -- - ----------------------- - - function Get_Configuration - (Cmd : Command_Line) return Command_Line_Configuration - is - begin - return Cmd.Config; - end Get_Configuration; - - ---------------------- - -- Set_Command_Line -- - ---------------------- - - procedure Set_Command_Line - (Cmd : in out Command_Line; - Switches : String; - Getopt_Description : String := ""; - Switch_Char : Character := '-') - is - Tmp : Argument_List_Access; - Parser : Opt_Parser; - S : Character; - Section : String_Access := null; - - function Real_Full_Switch - (S : Character; - Parser : Opt_Parser) return String; - -- Ensure that the returned switch value contains the Switch_Char prefix - -- if needed. - - ---------------------- - -- Real_Full_Switch -- - ---------------------- - - function Real_Full_Switch - (S : Character; - Parser : Opt_Parser) return String - is - begin - if S = '*' then - return Full_Switch (Parser); - else - return Switch_Char & Full_Switch (Parser); - end if; - end Real_Full_Switch; - - -- Start of processing for Set_Command_Line - - begin - Free (Cmd.Expanded); - Free (Cmd.Params); - - if Switches /= "" then - Tmp := Argument_String_To_List (Switches); - Initialize_Option_Scan (Parser, Tmp, Switch_Char); - - loop - begin - if Cmd.Config /= null then - - -- Do not use Getopt_Description in this case. Otherwise, - -- if we have defined a prefix -gnaty, and two switches - -- -gnatya and -gnatyL!, we would have a different behavior - -- depending on the order of switches: - - -- -gnatyL1a => -gnatyL with argument "1a" - -- -gnatyaL1 => -gnatya and -gnatyL with argument "1" - - -- This is because the call to Getopt below knows nothing - -- about prefixes, and in the first case finds a valid - -- switch with arguments, so returns it without analyzing - -- the argument. In the second case, the switch matches "*", - -- and is then decomposed below. - - -- Note: When a Command_Line object is associated with a - -- Command_Line_Config (which is mostly the case for tools - -- that let users choose the command line before spawning - -- other tools, for instance IDEs), the configuration of - -- the switches must be taken from the Command_Line_Config. - - S := Getopt (Switches => "* " & Get_Switches (Cmd.Config), - Concatenate => False, - Parser => Parser); - - else - S := Getopt (Switches => "* " & Getopt_Description, - Concatenate => False, - Parser => Parser); - end if; - - exit when S = ASCII.NUL; - - declare - Sw : constant String := Real_Full_Switch (S, Parser); - Is_Section : Boolean := False; - - begin - if Cmd.Config /= null - and then Cmd.Config.Sections /= null - then - Section_Search : - for S in Cmd.Config.Sections'Range loop - if Sw = Cmd.Config.Sections (S).all then - Section := Cmd.Config.Sections (S); - Is_Section := True; - - exit Section_Search; - end if; - end loop Section_Search; - end if; - - if not Is_Section then - if Section = null then - Add_Switch (Cmd, Sw, Parameter (Parser)); - else - Add_Switch - (Cmd, Sw, Parameter (Parser), - Section => Section.all); - end if; - end if; - end; - - exception - when Invalid_Parameter => - - -- Add it with no parameter, if that's the way the user - -- wants it. - - -- Specify the separator in all cases, as the switch might - -- need to be unaliased, and the alias might contain - -- switches with parameters. - - if Section = null then - Add_Switch - (Cmd, Switch_Char & Full_Switch (Parser)); - else - Add_Switch - (Cmd, Switch_Char & Full_Switch (Parser), - Section => Section.all); - end if; - end; - end loop; - - Free (Parser); - end if; - end Set_Command_Line; - - ---------------- - -- Looking_At -- - ---------------- - - function Looking_At - (Type_Str : String; - Index : Natural; - Substring : String) return Boolean - is - begin - return Index + Substring'Length - 1 <= Type_Str'Last - and then Type_Str (Index .. Index + Substring'Length - 1) = Substring; - end Looking_At; - - ------------------------ - -- Can_Have_Parameter -- - ------------------------ - - function Can_Have_Parameter (S : String) return Boolean is - begin - if S'Length <= 1 then - return False; - end if; - - case S (S'Last) is - when '!' | ':' | '?' | '=' => - return True; - when others => - return False; - end case; - end Can_Have_Parameter; - - ----------------------- - -- Require_Parameter -- - ----------------------- - - function Require_Parameter (S : String) return Boolean is - begin - if S'Length <= 1 then - return False; - end if; - - case S (S'Last) is - when '!' | ':' | '=' => - return True; - when others => - return False; - end case; - end Require_Parameter; - - ------------------- - -- Actual_Switch -- - ------------------- - - function Actual_Switch (S : String) return String is - begin - if S'Length <= 1 then - return S; - end if; - - case S (S'Last) is - when '!' | ':' | '?' | '=' => - return S (S'First .. S'Last - 1); - when others => - return S; - end case; - end Actual_Switch; - - ---------------------------- - -- For_Each_Simple_Switch -- - ---------------------------- - - procedure For_Each_Simple_Switch - (Config : Command_Line_Configuration; - Section : String; - Switch : String; - Parameter : String := ""; - Unalias : Boolean := True) - is - function Group_Analysis - (Prefix : String; - Group : String) return Boolean; - -- Perform the analysis of a group of switches - - Found_In_Config : Boolean := False; - function Is_In_Config - (Config_Switch : String; Index : Integer) return Boolean; - -- If Switch is the same as Config_Switch, run the callback and sets - -- Found_In_Config to True. - - function Starts_With - (Config_Switch : String; Index : Integer) return Boolean; - -- if Switch starts with Config_Switch, sets Found_In_Config to True. - -- The return value is for the Foreach_Switch iterator. - - -------------------- - -- Group_Analysis -- - -------------------- - - function Group_Analysis - (Prefix : String; - Group : String) return Boolean - is - Idx : Natural; - Found : Boolean; - - function Analyze_Simple_Switch - (Switch : String; Index : Integer) return Boolean; - -- "Switches" is one of the switch definitions passed to the - -- configuration, not one of the switches found on the command line. - - --------------------------- - -- Analyze_Simple_Switch -- - --------------------------- - - function Analyze_Simple_Switch - (Switch : String; Index : Integer) return Boolean - is - pragma Unreferenced (Index); - - Full : constant String := Prefix & Group (Idx .. Group'Last); - - Sw : constant String := Actual_Switch (Switch); - -- Switches definition minus argument definition - - Last : Natural; - Param : Natural; - - begin - -- Verify that sw starts with Prefix - - if Looking_At (Sw, Sw'First, Prefix) - - -- Verify that the group starts with sw - - and then Looking_At (Full, Full'First, Sw) - then - Last := Idx + Sw'Length - Prefix'Length - 1; - Param := Last + 1; - - if Can_Have_Parameter (Switch) then - - -- Include potential parameter to the recursive call. Only - -- numbers are allowed. - - while Last < Group'Last - and then Group (Last + 1) in '0' .. '9' - loop - Last := Last + 1; - end loop; - end if; - - if not Require_Parameter (Switch) or else Last >= Param then - if Idx = Group'First - and then Last = Group'Last - and then Last < Param - then - -- The group only concerns a single switch. Do not - -- perform recursive call. - - -- Note that we still perform a recursive call if - -- a parameter is detected in the switch, as this - -- is a way to correctly identify such a parameter - -- in aliases. - - return False; - end if; - - Found := True; - - -- Recursive call, using the detected parameter if any - - if Last >= Param then - For_Each_Simple_Switch - (Config, - Section, - Prefix & Group (Idx .. Param - 1), - Group (Param .. Last)); - - else - For_Each_Simple_Switch - (Config, Section, Prefix & Group (Idx .. Last), ""); - end if; - - Idx := Last + 1; - return False; - end if; - end if; - - return True; - end Analyze_Simple_Switch; - - procedure Foreach is new Foreach_Switch (Analyze_Simple_Switch); - - -- Start of processing for Group_Analysis - - begin - Idx := Group'First; - while Idx <= Group'Last loop - Found := False; - Foreach (Config, Section); - - if not Found then - For_Each_Simple_Switch - (Config, Section, Prefix & Group (Idx), ""); - Idx := Idx + 1; - end if; - end loop; - - return True; - end Group_Analysis; - - ------------------ - -- Is_In_Config -- - ------------------ - - function Is_In_Config - (Config_Switch : String; Index : Integer) return Boolean - is - Last : Natural; - P : Switch_Parameter_Type; - - begin - Decompose_Switch (Config_Switch, P, Last); - - if Config_Switch (Config_Switch'First .. Last) = Switch then - case P is - when Parameter_None => - if Parameter = "" then - Callback (Switch, "", "", Index => Index); - Found_In_Config := True; - return False; - end if; - - when Parameter_With_Optional_Space => - Callback (Switch, " ", Parameter, Index => Index); - Found_In_Config := True; - return False; - - when Parameter_With_Space_Or_Equal => - Callback (Switch, "=", Parameter, Index => Index); - Found_In_Config := True; - return False; - - when Parameter_No_Space - | Parameter_Optional - => - Callback (Switch, "", Parameter, Index); - Found_In_Config := True; - return False; - end case; - end if; - - return True; - end Is_In_Config; - - ----------------- - -- Starts_With -- - ----------------- - - function Starts_With - (Config_Switch : String; Index : Integer) return Boolean - is - Last : Natural; - Param : Natural; - P : Switch_Parameter_Type; - - begin - -- This function is called when we believe the parameter was - -- specified as part of the switch, instead of separately. Thus we - -- look in the config to find all possible switches. - - Decompose_Switch (Config_Switch, P, Last); - - if Looking_At - (Switch, Switch'First, - Config_Switch (Config_Switch'First .. Last)) - then - -- Set first char of Param, and last char of Switch - - Param := Switch'First + Last; - Last := Switch'First + Last - Config_Switch'First; - - case P is - - -- None is already handled in Is_In_Config - - when Parameter_None => - null; - - when Parameter_With_Space_Or_Equal => - if Param <= Switch'Last - and then - (Switch (Param) = ' ' or else Switch (Param) = '=') - then - Callback (Switch (Switch'First .. Last), - "=", Switch (Param + 1 .. Switch'Last), Index); - Found_In_Config := True; - return False; - end if; - - when Parameter_With_Optional_Space => - if Param <= Switch'Last and then Switch (Param) = ' ' then - Param := Param + 1; - end if; - - Callback (Switch (Switch'First .. Last), - " ", Switch (Param .. Switch'Last), Index); - Found_In_Config := True; - return False; - - when Parameter_No_Space - | Parameter_Optional - => - Callback (Switch (Switch'First .. Last), - "", Switch (Param .. Switch'Last), Index); - Found_In_Config := True; - return False; - end case; - end if; - return True; - end Starts_With; - - procedure Foreach_In_Config is new Foreach_Switch (Is_In_Config); - procedure Foreach_Starts_With is new Foreach_Switch (Starts_With); - - -- Start of processing for For_Each_Simple_Switch - - begin - -- First determine if the switch corresponds to one belonging to the - -- configuration. If so, run callback and exit. - - -- ??? Is this necessary. On simple tests, we seem to have the same - -- results with or without this call. - - Foreach_In_Config (Config, Section); - - if Found_In_Config then - return; - end if; - - -- If adding a switch that can in fact be expanded through aliases, - -- add separately each of its expansions. - - -- This takes care of expansions like "-T" -> "-gnatwrs", where the - -- alias and its expansion do not have the same prefix. Given the order - -- in which we do things here, the expansion of the alias will itself - -- be checked for a common prefix and split into simple switches. - - if Unalias - and then Config /= null - and then Config.Aliases /= null - then - for A in Config.Aliases'Range loop - if Config.Aliases (A).Section.all = Section - and then Config.Aliases (A).Alias.all = Switch - and then Parameter = "" - then - For_Each_Simple_Switch - (Config, Section, Config.Aliases (A).Expansion.all, ""); - return; - end if; - end loop; - end if; - - -- If adding a switch grouping several switches, add each of the simple - -- switches instead. - - if Config /= null and then Config.Prefixes /= null then - for P in Config.Prefixes'Range loop - if Switch'Length > Config.Prefixes (P)'Length + 1 - and then - Looking_At (Switch, Switch'First, Config.Prefixes (P).all) - then - -- Alias expansion will be done recursively - - if Config.Switches = null then - for S in Switch'First + Config.Prefixes (P)'Length - .. Switch'Last - loop - For_Each_Simple_Switch - (Config, Section, - Config.Prefixes (P).all & Switch (S), ""); - end loop; - - return; - - elsif Group_Analysis - (Config.Prefixes (P).all, - Switch - (Switch'First + Config.Prefixes (P)'Length .. Switch'Last)) - then - -- Recursive calls already done on each switch of the group: - -- Return without executing Callback. - - return; - end if; - end if; - end loop; - end if; - - -- Test if added switch is a known switch with parameter attached - -- instead of being specified separately - - if Parameter = "" - and then Config /= null - and then Config.Switches /= null - then - Found_In_Config := False; - Foreach_Starts_With (Config, Section); - - if Found_In_Config then - return; - end if; - end if; - - -- The switch is invalid in the config, but we still want to report it. - -- The config could, for instance, include "*" to specify it accepts - -- all switches. - - Callback (Switch, " ", Parameter, Index => -1); - end For_Each_Simple_Switch; - - ---------------- - -- Add_Switch -- - ---------------- - - procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ASCII.NUL; - Section : String := ""; - Add_Before : Boolean := False) - is - Success : Boolean; - pragma Unreferenced (Success); - begin - Add_Switch (Cmd, Switch, Parameter, Separator, - Section, Add_Before, Success); - end Add_Switch; - - ---------------- - -- Add_Switch -- - ---------------- - - procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ASCII.NUL; - Section : String := ""; - Add_Before : Boolean := False; - Success : out Boolean) - is - procedure Add_Simple_Switch - (Simple : String; - Sepa : String; - Param : String; - Index : Integer); - -- Add a new switch that has had all its aliases expanded, and switches - -- ungrouped. We know there are no more aliases in Switches. - - ----------------------- - -- Add_Simple_Switch -- - ----------------------- - - procedure Add_Simple_Switch - (Simple : String; - Sepa : String; - Param : String; - Index : Integer) - is - Sep : Character; - - begin - if Index = -1 - and then Cmd.Config /= null - and then not Cmd.Config.Star_Switch - then - raise Invalid_Switch - with "Invalid switch " & Simple; - end if; - - if Separator /= ASCII.NUL then - Sep := Separator; - - elsif Sepa = "" then - Sep := ASCII.NUL; - else - Sep := Sepa (Sepa'First); - end if; - - if Cmd.Expanded = null then - Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple)); - - if Param /= "" then - Cmd.Params := - new Argument_List'(1 .. 1 => new String'(Sep & Param)); - else - Cmd.Params := new Argument_List'(1 .. 1 => null); - end if; - - if Section = "" then - Cmd.Sections := new Argument_List'(1 .. 1 => null); - else - Cmd.Sections := - new Argument_List'(1 .. 1 => new String'(Section)); - end if; - - else - -- Do we already have this switch? - - for C in Cmd.Expanded'Range loop - if Cmd.Expanded (C).all = Simple - and then - ((Cmd.Params (C) = null and then Param = "") - or else - (Cmd.Params (C) /= null - and then Cmd.Params (C).all = Sep & Param)) - and then - ((Cmd.Sections (C) = null and then Section = "") - or else - (Cmd.Sections (C) /= null - and then Cmd.Sections (C).all = Section)) - then - return; - end if; - end loop; - - -- Inserting at least one switch - - Success := True; - Add (Cmd.Expanded, new String'(Simple), Add_Before); - - if Param /= "" then - Add - (Cmd.Params, - new String'(Sep & Param), - Add_Before); - else - Add - (Cmd.Params, - null, - Add_Before); - end if; - - if Section = "" then - Add - (Cmd.Sections, - null, - Add_Before); - else - Add - (Cmd.Sections, - new String'(Section), - Add_Before); - end if; - end if; - end Add_Simple_Switch; - - procedure Add_Simple_Switches is - new For_Each_Simple_Switch (Add_Simple_Switch); - - -- Local Variables - - Section_Valid : Boolean := False; - - -- Start of processing for Add_Switch - - begin - if Section /= "" and then Cmd.Config /= null then - for S in Cmd.Config.Sections'Range loop - if Section = Cmd.Config.Sections (S).all then - Section_Valid := True; - exit; - end if; - end loop; - - if not Section_Valid then - raise Invalid_Section; - end if; - end if; - - Success := False; - Add_Simple_Switches (Cmd.Config, Section, Switch, Parameter); - Free (Cmd.Coalesce); - end Add_Switch; - - ------------ - -- Remove -- - ------------ - - procedure Remove (Line : in out Argument_List_Access; Index : Integer) is - Tmp : Argument_List_Access := Line; - - begin - Line := new Argument_List (Tmp'First .. Tmp'Last - 1); - - if Index /= Tmp'First then - Line (Tmp'First .. Index - 1) := Tmp (Tmp'First .. Index - 1); - end if; - - Free (Tmp (Index)); - - if Index /= Tmp'Last then - Line (Index .. Tmp'Last - 1) := Tmp (Index + 1 .. Tmp'Last); - end if; - - Unchecked_Free (Tmp); - end Remove; - - --------- - -- Add -- - --------- - - procedure Add - (Line : in out Argument_List_Access; - Str : String_Access; - Before : Boolean := False) - is - Tmp : Argument_List_Access := Line; - - begin - if Tmp /= null then - Line := new Argument_List (Tmp'First .. Tmp'Last + 1); - - if Before then - Line (Tmp'First) := Str; - Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all; - else - Line (Tmp'Range) := Tmp.all; - Line (Tmp'Last + 1) := Str; - end if; - - Unchecked_Free (Tmp); - - else - Line := new Argument_List'(1 .. 1 => Str); - end if; - end Add; - - ------------------- - -- Remove_Switch -- - ------------------- - - procedure Remove_Switch - (Cmd : in out Command_Line; - Switch : String; - Remove_All : Boolean := False; - Has_Parameter : Boolean := False; - Section : String := "") - is - Success : Boolean; - pragma Unreferenced (Success); - begin - Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success); - end Remove_Switch; - - ------------------- - -- Remove_Switch -- - ------------------- - - procedure Remove_Switch - (Cmd : in out Command_Line; - Switch : String; - Remove_All : Boolean := False; - Has_Parameter : Boolean := False; - Section : String := ""; - Success : out Boolean) - is - procedure Remove_Simple_Switch - (Simple, Separator, Param : String; Index : Integer); - -- Removes a simple switch, with no aliasing or grouping - - -------------------------- - -- Remove_Simple_Switch -- - -------------------------- - - procedure Remove_Simple_Switch - (Simple, Separator, Param : String; Index : Integer) - is - C : Integer; - pragma Unreferenced (Param, Separator, Index); - - begin - if Cmd.Expanded /= null then - C := Cmd.Expanded'First; - while C <= Cmd.Expanded'Last loop - if Cmd.Expanded (C).all = Simple - and then - (Remove_All - or else (Cmd.Sections (C) = null - and then Section = "") - or else (Cmd.Sections (C) /= null - and then Section = Cmd.Sections (C).all)) - and then (not Has_Parameter or else Cmd.Params (C) /= null) - then - Remove (Cmd.Expanded, C); - Remove (Cmd.Params, C); - Remove (Cmd.Sections, C); - Success := True; - - if not Remove_All then - return; - end if; - - else - C := C + 1; - end if; - end loop; - end if; - end Remove_Simple_Switch; - - procedure Remove_Simple_Switches is - new For_Each_Simple_Switch (Remove_Simple_Switch); - - -- Start of processing for Remove_Switch - - begin - Success := False; - Remove_Simple_Switches - (Cmd.Config, Section, Switch, "", Unalias => not Has_Parameter); - Free (Cmd.Coalesce); - end Remove_Switch; - - ------------------- - -- Remove_Switch -- - ------------------- - - procedure Remove_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String; - Section : String := "") - is - procedure Remove_Simple_Switch - (Simple, Separator, Param : String; Index : Integer); - -- Removes a simple switch, with no aliasing or grouping - - -------------------------- - -- Remove_Simple_Switch -- - -------------------------- - - procedure Remove_Simple_Switch - (Simple, Separator, Param : String; Index : Integer) - is - pragma Unreferenced (Separator, Index); - C : Integer; - - begin - if Cmd.Expanded /= null then - C := Cmd.Expanded'First; - while C <= Cmd.Expanded'Last loop - if Cmd.Expanded (C).all = Simple - and then - ((Cmd.Sections (C) = null - and then Section = "") - or else - (Cmd.Sections (C) /= null - and then Section = Cmd.Sections (C).all)) - and then - ((Cmd.Params (C) = null and then Param = "") - or else - (Cmd.Params (C) /= null - - -- Ignore the separator stored in Parameter - - and then - Cmd.Params (C) (Cmd.Params (C)'First + 1 - .. Cmd.Params (C)'Last) = Param)) - then - Remove (Cmd.Expanded, C); - Remove (Cmd.Params, C); - Remove (Cmd.Sections, C); - - -- The switch is necessarily unique by construction of - -- Add_Switch. - - return; - - else - C := C + 1; - end if; - end loop; - end if; - end Remove_Simple_Switch; - - procedure Remove_Simple_Switches is - new For_Each_Simple_Switch (Remove_Simple_Switch); - - -- Start of processing for Remove_Switch - - begin - Remove_Simple_Switches (Cmd.Config, Section, Switch, Parameter); - Free (Cmd.Coalesce); - end Remove_Switch; - - -------------------- - -- Group_Switches -- - -------------------- - - procedure Group_Switches - (Cmd : Command_Line; - Result : Argument_List_Access; - Sections : Argument_List_Access; - Params : Argument_List_Access) - is - function Compatible_Parameter (Param : String_Access) return Boolean; - -- True when the parameter can be part of a group - - -------------------------- - -- Compatible_Parameter -- - -------------------------- - - function Compatible_Parameter (Param : String_Access) return Boolean is - begin - -- No parameter OK - - if Param = null then - return True; - - -- We need parameters without separators - - elsif Param (Param'First) /= ASCII.NUL then - return False; - - -- Parameters must be all digits - - else - for J in Param'First + 1 .. Param'Last loop - if Param (J) not in '0' .. '9' then - return False; - end if; - end loop; - - return True; - end if; - end Compatible_Parameter; - - -- Local declarations - - Group : Ada.Strings.Unbounded.Unbounded_String; - First : Natural; - use type Ada.Strings.Unbounded.Unbounded_String; - - -- Start of processing for Group_Switches - - begin - if Cmd.Config = null or else Cmd.Config.Prefixes = null then - return; - end if; - - for P in Cmd.Config.Prefixes'Range loop - Group := Ada.Strings.Unbounded.Null_Unbounded_String; - First := 0; - - for C in Result'Range loop - if Result (C) /= null - and then Compatible_Parameter (Params (C)) - and then Looking_At - (Result (C).all, - Result (C)'First, - Cmd.Config.Prefixes (P).all) - then - -- If we are still in the same section, group the switches - - if First = 0 - or else - (Sections (C) = null - and then Sections (First) = null) - or else - (Sections (C) /= null - and then Sections (First) /= null - and then Sections (C).all = Sections (First).all) - then - Group := - Group & - Result (C) - (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. - Result (C)'Last); - - if Params (C) /= null then - Group := - Group & - Params (C) (Params (C)'First + 1 .. Params (C)'Last); - Free (Params (C)); - end if; - - if First = 0 then - First := C; - end if; - - Free (Result (C)); - - -- We changed section: we put the grouped switches to the first - -- place, on continue with the new section. - - else - Result (First) := - new String' - (Cmd.Config.Prefixes (P).all & - Ada.Strings.Unbounded.To_String (Group)); - Group := - Ada.Strings.Unbounded.To_Unbounded_String - (Result (C) - (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. - Result (C)'Last)); - First := C; - end if; - end if; - end loop; - - if First > 0 then - Result (First) := - new String' - (Cmd.Config.Prefixes (P).all & - Ada.Strings.Unbounded.To_String (Group)); - end if; - end loop; - end Group_Switches; - - -------------------- - -- Alias_Switches -- - -------------------- - - procedure Alias_Switches - (Cmd : Command_Line; - Result : Argument_List_Access; - Params : Argument_List_Access) - is - Found : Boolean; - First : Natural; - - procedure Check_Cb (Switch, Separator, Param : String; Index : Integer); - -- Checks whether the command line contains [Switch]. Sets the global - -- variable [Found] appropriately. This is called for each simple switch - -- that make up an alias, to know whether the alias should be applied. - - procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer); - -- Remove the simple switch [Switch] from the command line, since it is - -- part of a simpler alias - - -------------- - -- Check_Cb -- - -------------- - - procedure Check_Cb - (Switch, Separator, Param : String; Index : Integer) - is - pragma Unreferenced (Separator, Index); - - begin - if Found then - for E in Result'Range loop - if Result (E) /= null - and then - (Params (E) = null - or else Params (E) (Params (E)'First + 1 .. - Params (E)'Last) = Param) - and then Result (E).all = Switch - then - return; - end if; - end loop; - - Found := False; - end if; - end Check_Cb; - - --------------- - -- Remove_Cb -- - --------------- - - procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer) - is - pragma Unreferenced (Separator, Index); - - begin - for E in Result'Range loop - if Result (E) /= null - and then - (Params (E) = null - or else Params (E) (Params (E)'First + 1 - .. Params (E)'Last) = Param) - and then Result (E).all = Switch - then - if First > E then - First := E; - end if; - - Free (Result (E)); - Free (Params (E)); - return; - end if; - end loop; - end Remove_Cb; - - procedure Check_All is new For_Each_Simple_Switch (Check_Cb); - procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb); - - -- Start of processing for Alias_Switches - - begin - if Cmd.Config = null or else Cmd.Config.Aliases = null then - return; - end if; - - for A in Cmd.Config.Aliases'Range loop - - -- Compute the various simple switches that make up the alias. We - -- split the expansion into as many simple switches as possible, and - -- then check whether the expanded command line has all of them. - - Found := True; - Check_All (Cmd.Config, - Switch => Cmd.Config.Aliases (A).Expansion.all, - Section => Cmd.Config.Aliases (A).Section.all); - - if Found then - First := Integer'Last; - Remove_All (Cmd.Config, - Switch => Cmd.Config.Aliases (A).Expansion.all, - Section => Cmd.Config.Aliases (A).Section.all); - Result (First) := new String'(Cmd.Config.Aliases (A).Alias.all); - end if; - end loop; - end Alias_Switches; - - ------------------- - -- Sort_Sections -- - ------------------- - - procedure Sort_Sections - (Line : not null GNAT.OS_Lib.Argument_List_Access; - Sections : GNAT.OS_Lib.Argument_List_Access; - Params : GNAT.OS_Lib.Argument_List_Access) - is - Sections_List : Argument_List_Access := - new Argument_List'(1 .. 1 => null); - Found : Boolean; - Old_Line : constant Argument_List := Line.all; - Old_Sections : constant Argument_List := Sections.all; - Old_Params : constant Argument_List := Params.all; - Index : Natural; - - begin - -- First construct a list of all sections - - for E in Line'Range loop - if Sections (E) /= null then - Found := False; - for S in Sections_List'Range loop - if (Sections_List (S) = null and then Sections (E) = null) - or else - (Sections_List (S) /= null - and then Sections (E) /= null - and then Sections_List (S).all = Sections (E).all) - then - Found := True; - exit; - end if; - end loop; - - if not Found then - Add (Sections_List, Sections (E)); - end if; - end if; - end loop; - - Index := Line'First; - - for S in Sections_List'Range loop - for E in Old_Line'Range loop - if (Sections_List (S) = null and then Old_Sections (E) = null) - or else - (Sections_List (S) /= null - and then Old_Sections (E) /= null - and then Sections_List (S).all = Old_Sections (E).all) - then - Line (Index) := Old_Line (E); - Sections (Index) := Old_Sections (E); - Params (Index) := Old_Params (E); - Index := Index + 1; - end if; - end loop; - end loop; - - Unchecked_Free (Sections_List); - end Sort_Sections; - - ----------- - -- Start -- - ----------- - - procedure Start - (Cmd : in out Command_Line; - Iter : in out Command_Line_Iterator; - Expanded : Boolean := False) - is - begin - if Cmd.Expanded = null then - Iter.List := null; - return; - end if; - - -- Reorder the expanded line so that sections are grouped - - Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params); - - -- Coalesce the switches as much as possible - - if not Expanded - and then Cmd.Coalesce = null - then - Cmd.Coalesce := new Argument_List (Cmd.Expanded'Range); - for E in Cmd.Expanded'Range loop - Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all); - end loop; - - Free (Cmd.Coalesce_Sections); - Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range); - for E in Cmd.Sections'Range loop - Cmd.Coalesce_Sections (E) := - (if Cmd.Sections (E) = null then null - else new String'(Cmd.Sections (E).all)); - end loop; - - Free (Cmd.Coalesce_Params); - Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range); - for E in Cmd.Params'Range loop - Cmd.Coalesce_Params (E) := - (if Cmd.Params (E) = null then null - else new String'(Cmd.Params (E).all)); - end loop; - - -- Not a clone, since we will not modify the parameters anyway - - Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params); - Group_Switches - (Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params); - end if; - - if Expanded then - Iter.List := Cmd.Expanded; - Iter.Params := Cmd.Params; - Iter.Sections := Cmd.Sections; - else - Iter.List := Cmd.Coalesce; - Iter.Params := Cmd.Coalesce_Params; - Iter.Sections := Cmd.Coalesce_Sections; - end if; - - if Iter.List = null then - Iter.Current := Integer'Last; - else - Iter.Current := Iter.List'First - 1; - Next (Iter); - end if; - end Start; - - -------------------- - -- Current_Switch -- - -------------------- - - function Current_Switch (Iter : Command_Line_Iterator) return String is - begin - return Iter.List (Iter.Current).all; - end Current_Switch; - - -------------------- - -- Is_New_Section -- - -------------------- - - function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is - Section : constant String := Current_Section (Iter); - - begin - if Iter.Sections = null then - return False; - - elsif Iter.Current = Iter.Sections'First - or else Iter.Sections (Iter.Current - 1) = null - then - return Section /= ""; - - else - return Section /= Iter.Sections (Iter.Current - 1).all; - end if; - end Is_New_Section; - - --------------------- - -- Current_Section -- - --------------------- - - function Current_Section (Iter : Command_Line_Iterator) return String is - begin - if Iter.Sections = null - or else Iter.Current > Iter.Sections'Last - or else Iter.Sections (Iter.Current) = null - then - return ""; - end if; - - return Iter.Sections (Iter.Current).all; - end Current_Section; - - ----------------------- - -- Current_Separator -- - ----------------------- - - function Current_Separator (Iter : Command_Line_Iterator) return String is - begin - if Iter.Params = null - or else Iter.Current > Iter.Params'Last - or else Iter.Params (Iter.Current) = null - then - return ""; - - else - declare - Sep : constant Character := - Iter.Params (Iter.Current) (Iter.Params (Iter.Current)'First); - begin - if Sep = ASCII.NUL then - return ""; - else - return "" & Sep; - end if; - end; - end if; - end Current_Separator; - - ----------------------- - -- Current_Parameter -- - ----------------------- - - function Current_Parameter (Iter : Command_Line_Iterator) return String is - begin - if Iter.Params = null - or else Iter.Current > Iter.Params'Last - or else Iter.Params (Iter.Current) = null - then - return ""; - - else - -- Return result, skipping separator - - declare - P : constant String := Iter.Params (Iter.Current).all; - begin - return P (P'First + 1 .. P'Last); - end; - end if; - end Current_Parameter; - - -------------- - -- Has_More -- - -------------- - - function Has_More (Iter : Command_Line_Iterator) return Boolean is - begin - return Iter.List /= null and then Iter.Current <= Iter.List'Last; - end Has_More; - - ---------- - -- Next -- - ---------- - - procedure Next (Iter : in out Command_Line_Iterator) is - begin - Iter.Current := Iter.Current + 1; - while Iter.Current <= Iter.List'Last - and then Iter.List (Iter.Current) = null - loop - Iter.Current := Iter.Current + 1; - end loop; - end Next; - - ---------- - -- Free -- - ---------- - - procedure Free (Config : in out Command_Line_Configuration) is - procedure Unchecked_Free is new - Ada.Unchecked_Deallocation - (Switch_Definitions, Switch_Definitions_List); - - procedure Unchecked_Free is new - Ada.Unchecked_Deallocation - (Alias_Definitions, Alias_Definitions_List); - - begin - if Config /= null then - Free (Config.Prefixes); - Free (Config.Sections); - Free (Config.Usage); - Free (Config.Help); - Free (Config.Help_Msg); - - if Config.Aliases /= null then - for A in Config.Aliases'Range loop - Free (Config.Aliases (A).Alias); - Free (Config.Aliases (A).Expansion); - Free (Config.Aliases (A).Section); - end loop; - - Unchecked_Free (Config.Aliases); - end if; - - if Config.Switches /= null then - for S in Config.Switches'Range loop - Free (Config.Switches (S).Switch); - Free (Config.Switches (S).Long_Switch); - Free (Config.Switches (S).Help); - Free (Config.Switches (S).Section); - Free (Config.Switches (S).Argument); - end loop; - - Unchecked_Free (Config.Switches); - end if; - - Unchecked_Free (Config); - end if; - end Free; - - ---------- - -- Free -- - ---------- - - procedure Free (Cmd : in out Command_Line) is - begin - Free (Cmd.Expanded); - Free (Cmd.Coalesce); - Free (Cmd.Coalesce_Sections); - Free (Cmd.Coalesce_Params); - Free (Cmd.Params); - Free (Cmd.Sections); - end Free; - - --------------- - -- Set_Usage -- - --------------- - - procedure Set_Usage - (Config : in out Command_Line_Configuration; - Usage : String := "[switches] [arguments]"; - Help : String := ""; - Help_Msg : String := "") - is - begin - if Config = null then - Config := new Command_Line_Configuration_Record; - end if; - - Free (Config.Usage); - Free (Config.Help); - Free (Config.Help_Msg); - - Config.Usage := new String'(Usage); - Config.Help := new String'(Help); - Config.Help_Msg := new String'(Help_Msg); - end Set_Usage; - - ------------------ - -- Display_Help -- - ------------------ - - procedure Display_Help (Config : Command_Line_Configuration) is - function Switch_Name - (Def : Switch_Definition; - Section : String) return String; - -- Return the "-short, --long=ARG" string for Def. - -- Returns "" if the switch is not in the section. - - function Param_Name - (P : Switch_Parameter_Type; - Name : String := "ARG") return String; - -- Return the display for a switch parameter - - procedure Display_Section_Help (Section : String); - -- Display the help for a specific section ("" is the default section) - - -------------------------- - -- Display_Section_Help -- - -------------------------- - - procedure Display_Section_Help (Section : String) is - Max_Len : Natural := 0; - - begin - -- ??? Special display for "*" - - New_Line; - - if Section /= "" and then Config.Switches /= null then - Put_Line ("Switches after " & Section); - end if; - - -- Compute size of the switches column - - if Config.Switches /= null then - for S in Config.Switches'Range loop - Max_Len := Natural'Max - (Max_Len, Switch_Name (Config.Switches (S), Section)'Length); - end loop; - end if; - - if Config.Aliases /= null then - for A in Config.Aliases'Range loop - if Config.Aliases (A).Section.all = Section then - Max_Len := Natural'Max - (Max_Len, Config.Aliases (A).Alias'Length); - end if; - end loop; - end if; - - -- Display the switches - - if Config.Switches /= null then - for S in Config.Switches'Range loop - declare - N : constant String := - Switch_Name (Config.Switches (S), Section); - - begin - if N /= "" then - Put (" "); - Put (N); - Put ((1 .. Max_Len - N'Length + 1 => ' ')); - - if Config.Switches (S).Help /= null then - Put (Config.Switches (S).Help.all); - end if; - - New_Line; - end if; - end; - end loop; - end if; - - -- Display the aliases - - if Config.Aliases /= null then - for A in Config.Aliases'Range loop - if Config.Aliases (A).Section.all = Section then - Put (" "); - Put (Config.Aliases (A).Alias.all); - Put ((1 .. Max_Len - Config.Aliases (A).Alias'Length + 1 - => ' ')); - Put ("Equivalent to " & Config.Aliases (A).Expansion.all); - New_Line; - end if; - end loop; - end if; - end Display_Section_Help; - - ---------------- - -- Param_Name -- - ---------------- - - function Param_Name - (P : Switch_Parameter_Type; - Name : String := "ARG") return String - is - begin - case P is - when Parameter_None => - return ""; - - when Parameter_With_Optional_Space => - return " " & To_Upper (Name); - - when Parameter_With_Space_Or_Equal => - return "=" & To_Upper (Name); - - when Parameter_No_Space => - return To_Upper (Name); - - when Parameter_Optional => - return '[' & To_Upper (Name) & ']'; - end case; - end Param_Name; - - ----------------- - -- Switch_Name -- - ----------------- - - function Switch_Name - (Def : Switch_Definition; - Section : String) return String - is - use Ada.Strings.Unbounded; - Result : Unbounded_String; - P1, P2 : Switch_Parameter_Type; - Last1, Last2 : Integer := 0; - - begin - if (Section = "" and then Def.Section = null) - or else (Def.Section /= null and then Def.Section.all = Section) - then - if Def.Switch /= null and then Def.Switch.all = "*" then - return "[any switch]"; - end if; - - if Def.Switch /= null then - Decompose_Switch (Def.Switch.all, P1, Last1); - Append (Result, Def.Switch (Def.Switch'First .. Last1)); - - if Def.Long_Switch /= null then - Decompose_Switch (Def.Long_Switch.all, P2, Last2); - Append (Result, ", " - & Def.Long_Switch (Def.Long_Switch'First .. Last2)); - - if Def.Argument = null then - Append (Result, Param_Name (P2, "ARG")); - else - Append (Result, Param_Name (P2, Def.Argument.all)); - end if; - - else - if Def.Argument = null then - Append (Result, Param_Name (P1, "ARG")); - else - Append (Result, Param_Name (P1, Def.Argument.all)); - end if; - end if; - - -- Def.Switch is null (Long_Switch must be non-null) - - else - Decompose_Switch (Def.Long_Switch.all, P2, Last2); - Append (Result, - Def.Long_Switch (Def.Long_Switch'First .. Last2)); - - if Def.Argument = null then - Append (Result, Param_Name (P2, "ARG")); - else - Append (Result, Param_Name (P2, Def.Argument.all)); - end if; - end if; - end if; - - return To_String (Result); - end Switch_Name; - - -- Start of processing for Display_Help - - begin - if Config = null then - return; - end if; - - if Config.Help /= null and then Config.Help.all /= "" then - Put_Line (Config.Help.all); - end if; - - if Config.Usage /= null then - Put_Line ("Usage: " - & Base_Name - (Ada.Command_Line.Command_Name) & " " & Config.Usage.all); - else - Put_Line ("Usage: " & Base_Name (Ada.Command_Line.Command_Name) - & " [switches] [arguments]"); - end if; - - if Config.Help_Msg /= null and then Config.Help_Msg.all /= "" then - Put_Line (Config.Help_Msg.all); - - else - Display_Section_Help (""); - - if Config.Sections /= null and then Config.Switches /= null then - for S in Config.Sections'Range loop - Display_Section_Help (Config.Sections (S).all); - end loop; - end if; - end if; - end Display_Help; - - ------------ - -- Getopt -- - ------------ - - procedure Getopt - (Config : Command_Line_Configuration; - Callback : Switch_Handler := null; - Parser : Opt_Parser := Command_Line_Parser; - Concatenate : Boolean := True) - is - Getopt_Switches : String_Access; - C : Character := ASCII.NUL; - - Empty_Name : aliased constant String := ""; - Current_Section : Integer := -1; - Section_Name : not null access constant String := Empty_Name'Access; - - procedure Simple_Callback - (Simple_Switch : String; - Separator : String; - Parameter : String; - Index : Integer); - -- Needs comments ??? - - procedure Do_Callback (Switch, Parameter : String; Index : Integer); - - ----------------- - -- Do_Callback -- - ----------------- - - procedure Do_Callback (Switch, Parameter : String; Index : Integer) is - begin - -- Do automatic handling when possible - - if Index /= -1 then - case Config.Switches (Index).Typ is - when Switch_Untyped => - null; -- no automatic handling - - when Switch_Boolean => - Config.Switches (Index).Boolean_Output.all := - Config.Switches (Index).Boolean_Value; - return; - - when Switch_Integer => - begin - if Parameter = "" then - Config.Switches (Index).Integer_Output.all := - Config.Switches (Index).Integer_Default; - else - Config.Switches (Index).Integer_Output.all := - Integer'Value (Parameter); - end if; - - exception - when Constraint_Error => - raise Invalid_Parameter - with "Expected integer parameter for '" - & Switch & "'"; - end; - - return; - - when Switch_String => - Free (Config.Switches (Index).String_Output.all); - Config.Switches (Index).String_Output.all := - new String'(Parameter); - return; - end case; - end if; - - -- Otherwise calls the user callback if one was defined - - if Callback /= null then - Callback (Switch => Switch, - Parameter => Parameter, - Section => Section_Name.all); - end if; - end Do_Callback; - - procedure For_Each_Simple - is new For_Each_Simple_Switch (Simple_Callback); - - --------------------- - -- Simple_Callback -- - --------------------- - - procedure Simple_Callback - (Simple_Switch : String; - Separator : String; - Parameter : String; - Index : Integer) - is - pragma Unreferenced (Separator); - begin - Do_Callback (Switch => Simple_Switch, - Parameter => Parameter, - Index => Index); - end Simple_Callback; - - -- Start of processing for Getopt - - begin - -- Initialize sections - - if Config.Sections = null then - Config.Sections := new Argument_List'(1 .. 0 => null); - end if; - - Internal_Initialize_Option_Scan - (Parser => Parser, - Switch_Char => Parser.Switch_Character, - Stop_At_First_Non_Switch => Parser.Stop_At_First, - Section_Delimiters => Section_Delimiters (Config)); - - Getopt_Switches := new String' - (Get_Switches (Config, Parser.Switch_Character, Section_Name.all) - & " h -help"); - - -- Initialize output values for automatically handled switches - - if Config.Switches /= null then - for S in Config.Switches'Range loop - case Config.Switches (S).Typ is - when Switch_Untyped => - null; -- Nothing to do - - when Switch_Boolean => - Config.Switches (S).Boolean_Output.all := - not Config.Switches (S).Boolean_Value; - - when Switch_Integer => - Config.Switches (S).Integer_Output.all := - Config.Switches (S).Integer_Initial; - - when Switch_String => - if Config.Switches (S).String_Output.all = null then - Config.Switches (S).String_Output.all := new String'(""); - end if; - end case; - end loop; - end if; - - -- For all sections, and all switches within those sections - - loop - C := Getopt (Switches => Getopt_Switches.all, - Concatenate => Concatenate, - Parser => Parser); - - if C = '*' then - -- Full_Switch already includes the leading '-' - - Do_Callback (Switch => Full_Switch (Parser), - Parameter => Parameter (Parser), - Index => -1); - - elsif C /= ASCII.NUL then - if Full_Switch (Parser) = "h" - or else - Full_Switch (Parser) = "-help" - then - Display_Help (Config); - raise Exit_From_Command_Line; - end if; - - -- Do switch expansion if needed - - For_Each_Simple - (Config, - Section => Section_Name.all, - Switch => Parser.Switch_Character & Full_Switch (Parser), - Parameter => Parameter (Parser)); - - else - if Current_Section = -1 then - Current_Section := Config.Sections'First; - else - Current_Section := Current_Section + 1; - end if; - - exit when Current_Section > Config.Sections'Last; - - Section_Name := Config.Sections (Current_Section); - Goto_Section (Section_Name.all, Parser); - - Free (Getopt_Switches); - Getopt_Switches := new String' - (Get_Switches - (Config, Parser.Switch_Character, Section_Name.all)); - end if; - end loop; - - Free (Getopt_Switches); - - exception - when Invalid_Switch => - Free (Getopt_Switches); - - -- Message inspired by "ls" on Unix - - Put_Line (Standard_Error, - Base_Name (Ada.Command_Line.Command_Name) - & ": unrecognized option '" - & Full_Switch (Parser) - & "'"); - Try_Help; - - raise; - - when others => - Free (Getopt_Switches); - raise; - end Getopt; - - ----------- - -- Build -- - ----------- - - procedure Build - (Line : in out Command_Line; - Args : out GNAT.OS_Lib.Argument_List_Access; - Expanded : Boolean := False; - Switch_Char : Character := '-') - is - Iter : Command_Line_Iterator; - Count : Natural := 0; - - begin - Start (Line, Iter, Expanded => Expanded); - while Has_More (Iter) loop - if Is_New_Section (Iter) then - Count := Count + 1; - end if; - - Count := Count + 1; - Next (Iter); - end loop; - - Args := new Argument_List (1 .. Count); - Count := Args'First; - - Start (Line, Iter, Expanded => Expanded); - while Has_More (Iter) loop - if Is_New_Section (Iter) then - Args (Count) := new String'(Switch_Char & Current_Section (Iter)); - Count := Count + 1; - end if; - - Args (Count) := new String'(Current_Switch (Iter) - & Current_Separator (Iter) - & Current_Parameter (Iter)); - Count := Count + 1; - Next (Iter); - end loop; - end Build; - - -------------- - -- Try_Help -- - -------------- - - -- Note: Any change to the message displayed should also be done in - -- gnatbind.adb that does not use this interface. - - procedure Try_Help is - begin - Put_Line - (Standard_Error, - "try """ & Base_Name (Ada.Command_Line.Command_Name, Suffix => ".exe") - & " --help"" for more information."); - end Try_Help; - -end GNAT.Command_Line; diff --git a/gcc/ada/g-comlin.ads b/gcc/ada/g-comlin.ads deleted file mode 100644 index f758508..0000000 --- a/gcc/ada/g-comlin.ads +++ /dev/null @@ -1,1201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C O M M A N D _ L I N E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- High level package for command line parsing and manipulation - ----------------------------------------- --- Simple Parsing of the Command Line -- ----------------------------------------- - --- This package provides an interface for parsing command line arguments, --- when they are either read from Ada.Command_Line or read from a string list. --- As shown in the example below, one should first retrieve the switches --- (special command line arguments starting with '-' by default) and their --- parameters, and then the rest of the command line arguments. --- --- While it may appear easy to parse the command line arguments with --- Ada.Command_Line, there are in fact lots of special cases to handle in some --- applications. Those are fully managed by GNAT.Command_Line. Among these are --- switches with optional parameters, grouping switches (for instance "-ab" --- might mean the same as "-a -b"), various characters to separate a switch --- and its parameter (or none: "-a 1" and "-a1" are generally the same, which --- can introduce confusion with grouped switches),... --- --- begin --- loop --- case Getopt ("a b: ad") is -- Accepts '-a', '-ad', or '-b argument' --- when ASCII.NUL => exit; - --- when 'a' => --- if Full_Switch = "a" then --- Put_Line ("Got a"); --- else --- Put_Line ("Got ad"); --- end if; - --- when 'b' => Put_Line ("Got b + " & Parameter); - --- when others => --- raise Program_Error; -- cannot occur --- end case; --- end loop; - --- loop --- declare --- S : constant String := Get_Argument (Do_Expansion => True); --- begin --- exit when S'Length = 0; --- Put_Line ("Got " & S); --- end; --- end loop; - --- exception --- when Invalid_Switch => Put_Line ("Invalid Switch " & Full_Switch); --- when Invalid_Parameter => Put_Line ("No parameter for " & Full_Switch); --- end; - --------------- --- Sections -- --------------- - --- A more complicated example would involve the use of sections for the --- switches, as for instance in gnatmake. The same command line is used to --- provide switches for several tools. Each tool recognizes its switches by --- separating them with special switches that act as section separators. --- Each section acts as a command line of its own. - --- begin --- Initialize_Option_Scan ('-', False, "largs bargs cargs"); --- loop --- -- Same loop as above to get switches and arguments --- end loop; - --- Goto_Section ("bargs"); --- loop --- -- Same loop as above to get switches and arguments --- -- The supported switches in Getopt might be different --- end loop; - --- Goto_Section ("cargs"); --- loop --- -- Same loop as above to get switches and arguments --- -- The supported switches in Getopt might be different --- end loop; --- end; - -------------------------------- --- Parsing a List of Strings -- -------------------------------- - --- The examples above show how to parse the command line when the arguments --- are read directly from Ada.Command_Line. However, these arguments can also --- be read from a list of strings. This can be useful in several contexts, --- either because your system does not support Ada.Command_Line, or because --- you are manipulating other tools and creating their command lines by hand, --- or for any other reason. - --- To create the list of strings, it is recommended to use --- GNAT.OS_Lib.Argument_String_To_List. - --- The example below shows how to get the parameters from such a list. Note --- also the use of '*' to get all the switches, and not report errors when an --- unexpected switch was used by the user - --- declare --- Parser : Opt_Parser; --- Args : constant Argument_List_Access := --- GNAT.OS_Lib.Argument_String_To_List ("-g -O1 -Ipath"); --- begin --- Initialize_Option_Scan (Parser, Args); --- while Getopt ("* g O! I=", Parser) /= ASCII.NUL loop --- Put_Line ("Switch " & Full_Switch (Parser) --- & " param=" & Parameter (Parser)); --- end loop; --- Free (Parser); --- end; - -------------------------------------------- --- High-Level Command Line Configuration -- -------------------------------------------- - --- As shown above, the code is still relatively low-level. For instance, there --- is no way to indicate which switches are related (thus if "-l" and "--long" --- should have the same effect, your code will need to test for both cases). --- Likewise, it is difficult to handle more advanced constructs, like: - --- * Specifying -gnatwa is the same as specifying -gnatwu -gnatwv, but --- shorter and more readable - --- * All switches starting with -gnatw can be grouped, for instance one --- can write -gnatwcd instead of -gnatwc -gnatwd. --- Of course, this can be combined with the above and -gnatwacd is the --- same as -gnatwc -gnatwd -gnatwu -gnatwv - --- * The switch -T is the same as -gnatwAB (same as -gnatwA -gnatwB) - --- With the above form of Getopt, you would receive "-gnatwa", "-T" or --- "-gnatwcd" in the examples above, and thus you require additional manual --- parsing of the switch. - --- Instead, this package provides the type Command_Line_Configuration, which --- stores all the knowledge above. For instance: - --- Config : Command_Line_Configuration; --- Define_Alias (Config, "-gnatwa", "-gnatwu -gnatwv"); --- Define_Prefix (Config, "-gnatw"); --- Define_Alias (Config, "-T", "-gnatwAB"); - --- You then need to specify all possible switches in your application by --- calling Define_Switch, for instance: - --- Define_Switch (Config, "-gnatwu", Help => "warn on unused entities"); --- Define_Switch (Config, "-gnatwv", Help => "warn on unassigned var"); --- ... - --- Specifying the help message is optional, but makes it easy to then call --- the function: - --- Display_Help (Config); - --- that will display a properly formatted help message for your application, --- listing all possible switches. That way you have a single place in which --- to maintain the list of switches and their meaning, rather than maintaining --- both the string to pass to Getopt and a subprogram to display the help. --- Both will properly stay synchronized. - --- Once you have this Config, you just have to call: - --- Getopt (Config, Callback'Access); - --- to parse the command line. The Callback will be called for each switch --- found on the command line (in the case of our example, that is "-gnatwu" --- and then "-gnatwv", not "-gnatwa" itself). This simplifies command line --- parsing a lot. - --- In fact, this can be further automated for the most command case where the --- parameter passed to a switch is stored in a variable in the application. --- When a switch is defined, you only have to indicate where to store the --- value, and let Getopt do the rest. For instance: - --- Optimization : aliased Integer; --- Verbose : aliased Boolean; - --- Define_Switch (Config, Verbose'Access, --- "-v", Long_Switch => "--verbose", --- Help => "Output extra verbose information"); --- Define_Switch (Config, Optimization'Access, --- "-O?", Help => "Optimization level"); - --- Getopt (Config); -- No callback - --- Since all switches are handled automatically, we don't even need to pass --- a callback to Getopt. Once getopt has been called, the two variables --- Optimization and Verbose have been properly initialized, either to the --- default value or to the value found on the command line. - ------------------------------------------------- --- Creating and Manipulating the Command Line -- ------------------------------------------------- - --- This package provides mechanisms to create and modify command lines by --- adding or removing arguments from them. The resulting command line is kept --- as short as possible by coalescing arguments whenever possible. - --- Complex command lines can thus be constructed, for example from a GUI --- (although this package does not by itself depend upon any specific GUI --- toolkit). - --- Using the configuration defined earlier, one can then construct a command --- line for the tool with: - --- Cmd : Command_Line; --- Set_Configuration (Cmd, Config); -- Config created earlier --- Add_Switch (Cmd, "-bar"); --- Add_Switch (Cmd, "-gnatwu"); --- Add_Switch (Cmd, "-gnatwv"); -- will be grouped with the above --- Add_Switch (Cmd, "-T"); - --- The resulting command line can be iterated over to get all its switches, --- There are two modes for this iteration: either you want to get the --- shortest possible command line, which would be: - --- -bar -gnatwaAB - --- or on the other hand you want each individual switch (so that your own --- tool does not have to do further complex processing), which would be: - --- -bar -gnatwu -gnatwv -gnatwA -gnatwB - --- Of course, we can assume that the tool you want to spawn would understand --- both of these, since they are both compatible with the description we gave --- above. However, the first result is useful if you want to show the user --- what you are spawning (since that keeps the output shorter), and the second --- output is more useful for a tool that would check whether -gnatwu was --- passed (which isn't obvious in the first output). Likewise, the second --- output is more useful if you have a graphical interface since each switch --- can be associated with a widget, and you immediately know whether -gnatwu --- was selected. --- --- Some command line arguments can have parameters, which on a command line --- appear as a separate argument that must immediately follow the switch. --- Since the subprograms in this package will reorganize the switches to group --- them, you need to indicate what is a command line parameter, and what is a --- switch argument. - --- This is done by passing an extra argument to Add_Switch, as in: - --- Add_Switch (Cmd, "-foo", Parameter => "arg1"); - --- This ensures that "arg1" will always be treated as the argument to -foo, --- and will not be grouped with other parts of the command line. - -with Ada.Command_Line; - -with GNAT.Directory_Operations; -with GNAT.OS_Lib; -with GNAT.Regexp; -with GNAT.Strings; - -package GNAT.Command_Line is - - ------------- - -- Parsing -- - ------------- - - type Opt_Parser is private; - Command_Line_Parser : constant Opt_Parser; - -- This object is responsible for parsing a list of arguments, which by - -- default are the standard command line arguments from Ada.Command_Line. - -- This is really a pointer to actual data, which must therefore be - -- initialized through a call to Initialize_Option_Scan, and must be freed - -- with a call to Free. - -- - -- As a special case, Command_Line_Parser does not need to be either - -- initialized or free-ed. - - procedure Initialize_Option_Scan - (Switch_Char : Character := '-'; - Stop_At_First_Non_Switch : Boolean := False; - Section_Delimiters : String := ""); - procedure Initialize_Option_Scan - (Parser : out Opt_Parser; - Command_Line : GNAT.OS_Lib.Argument_List_Access; - Switch_Char : Character := '-'; - Stop_At_First_Non_Switch : Boolean := False; - Section_Delimiters : String := ""); - -- The first procedure resets the internal state of the package to prepare - -- to rescan the parameters. It does not need to be called before the - -- first use of Getopt (but it could be), but it must be called if you - -- want to start rescanning the command line parameters from the start. - -- The optional parameter Switch_Char can be used to reset the switch - -- character, e.g. to '/' for use in DOS-like systems. - -- - -- The second subprogram initializes a parser that takes its arguments - -- from an array of strings rather than directly from the command line. In - -- this case, the parser is responsible for freeing the strings stored in - -- Command_Line. If you pass null to Command_Line, this will in fact create - -- a second parser for Ada.Command_Line, which doesn't share any data with - -- the default parser. This parser must be free'ed. - -- - -- The optional parameter Stop_At_First_Non_Switch indicates if Getopt is - -- to look for switches on the whole command line, or if it has to stop as - -- soon as a non-switch argument is found. - -- - -- Example: - -- - -- Arguments: my_application file1 -c - -- - -- If Stop_At_First_Non_Switch is False, then -c will be considered - -- as a switch (returned by getopt), otherwise it will be considered - -- as a normal argument (returned by Get_Argument). - -- - -- If Section_Delimiters is set, then every following subprogram - -- (Getopt and Get_Argument) will only operate within a section, which - -- is delimited by any of these delimiters or the end of the command line. - -- - -- Example: - -- Initialize_Option_Scan (Section_Delimiters => "largs bargs cargs"); - -- - -- Arguments on command line : my_application -c -bargs -d -e -largs -f - -- This line contains three sections, the first one is the default one - -- and includes only the '-c' switch, the second one is between -bargs - -- and -largs and includes '-d -e' and the last one includes '-f'. - - procedure Free (Parser : in out Opt_Parser); - -- Free the memory used by the parser. Calling this is not mandatory for - -- the Command_Line_Parser - - procedure Goto_Section - (Name : String := ""; - Parser : Opt_Parser := Command_Line_Parser); - -- Change the current section. The next Getopt or Get_Argument will start - -- looking at the beginning of the section. An empty name ("") refers to - -- the first section between the program name and the first section - -- delimiter. If the section does not exist in Section_Delimiters, then - -- Invalid_Section is raised. If the section does not appear on the command - -- line, then it is treated as an empty section. - - function Full_Switch - (Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the full name of the last switch found (Getopt only returns the - -- first character). Does not include the Switch_Char ('-' by default), - -- unless the "*" option of Getopt is used (see below). - - function Current_Section - (Parser : Opt_Parser := Command_Line_Parser) return String; - -- Return the name of the current section. - -- The list of valid sections is defined through Initialize_Option_Scan - - function Getopt - (Switches : String; - Concatenate : Boolean := True; - Parser : Opt_Parser := Command_Line_Parser) return Character; - -- This function moves to the next switch on the command line (defined as - -- switch character followed by a character within Switches, casing being - -- significant). The result returned is the first character of the switch - -- that is located. If there are no more switches in the current section, - -- returns ASCII.NUL. If Concatenate is True (the default), the switches do - -- not need to be separated by spaces (they can be concatenated if they do - -- not require an argument, e.g. -ab is the same as two separate arguments - -- -a -b). - -- - -- Switches is a string of all the possible switches, separated by - -- spaces. A switch can be followed by one of the following characters: - -- - -- ':' The switch requires a parameter. There can optionally be a space - -- on the command line between the switch and its parameter. - -- - -- '=' The switch requires a parameter. There can either be a '=' or a - -- space on the command line between the switch and its parameter. - -- - -- '!' The switch requires a parameter, but there can be no space on the - -- command line between the switch and its parameter. - -- - -- '?' The switch may have an optional parameter. There can be no space - -- between the switch and its argument. - -- - -- e.g. if Switches has the following value : "a? b", - -- The command line can be: - -- - -- -afoo : -a switch with 'foo' parameter - -- -a foo : -a switch and another element on the - -- command line 'foo', returned by Get_Argument - -- - -- Example: if Switches is "-a: -aO:", you can have the following - -- command lines: - -- - -- -aarg : 'a' switch with 'arg' parameter - -- -a arg : 'a' switch with 'arg' parameter - -- -aOarg : 'aO' switch with 'arg' parameter - -- -aO arg : 'aO' switch with 'arg' parameter - -- - -- Example: - -- - -- Getopt ("a b: ac ad?") - -- - -- accept either 'a' or 'ac' with no argument, - -- accept 'b' with a required argument - -- accept 'ad' with an optional argument - -- - -- If the first item in switches is '*', then Getopt will catch - -- every element on the command line that was not caught by any other - -- switch. The character returned by GetOpt is '*', but Full_Switch - -- contains the full command line argument, including leading '-' if there - -- is one. If this character was not returned, there would be no way of - -- knowing whether it is there or not. - -- - -- Example - -- Getopt ("* a b") - -- If the command line is '-a -c toto.o -b', Getopt will return - -- successively 'a', '*', '*' and 'b', with Full_Switch returning - -- "a", "-c", "toto.o", and "b". - -- - -- When Getopt encounters an invalid switch, it raises the exception - -- Invalid_Switch and sets Full_Switch to return the invalid switch. - -- When Getopt cannot find the parameter associated with a switch, it - -- raises Invalid_Parameter, and sets Full_Switch to return the invalid - -- switch. - -- - -- Note: in case of ambiguity, e.g. switches a ab abc, then the longest - -- matching switch is returned. - -- - -- Arbitrary characters are allowed for switches, although it is - -- strongly recommended to use only letters and digits for portability - -- reasons. - -- - -- When Concatenate is False, individual switches need to be separated by - -- spaces. - -- - -- Example - -- Getopt ("a b", Concatenate => False) - -- If the command line is '-ab', exception Invalid_Switch will be - -- raised and Full_Switch will return "ab". - - function Get_Argument - (Do_Expansion : Boolean := False; - Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns the next element on the command line that is not a switch. This - -- function should not be called before Getopt has returned ASCII.NUL. - -- - -- If Do_Expansion is True, then the parameter on the command line will - -- be considered as a filename with wild cards, and will be expanded. The - -- matching file names will be returned one at a time. This is useful in - -- non-Unix systems for obtaining normal expansion of wild card references. - -- When there are no more arguments on the command line, this function - -- returns an empty string. - - function Parameter - (Parser : Opt_Parser := Command_Line_Parser) return String; - -- Returns parameter associated with the last switch returned by Getopt. - -- If no parameter was associated with the last switch, or no previous call - -- has been made to Get_Argument, raises Invalid_Parameter. If the last - -- switch was associated with an optional argument and this argument was - -- not found on the command line, Parameter returns an empty string. - - function Separator - (Parser : Opt_Parser := Command_Line_Parser) return Character; - -- The separator that was between the switch and its parameter. This is - -- useful if you want to know exactly what was on the command line. This - -- is in general a single character, set to ASCII.NUL if the switch and - -- the parameter were concatenated. A space is returned if the switch and - -- its argument were in two separate arguments. - - Invalid_Section : exception; - -- Raised when an invalid section is selected by Goto_Section - - Invalid_Switch : exception; - -- Raised when an invalid switch is detected in the command line - - Invalid_Parameter : exception; - -- Raised when a parameter is missing, or an attempt is made to obtain a - -- parameter for a switch that does not allow a parameter. - - ----------------------------------------- - -- Expansion of command line arguments -- - ----------------------------------------- - - -- These subprograms take care of expanding globbing patterns on the - -- command line. On Unix, such expansion is done by the shell before your - -- application is called. But on Windows you must do this expansion - -- yourself. - - type Expansion_Iterator is limited private; - -- Type used during expansion of file names - - procedure Start_Expansion - (Iterator : out Expansion_Iterator; - Pattern : String; - Directory : String := ""; - Basic_Regexp : Boolean := True); - -- Initialize a wild card expansion. The next calls to Expansion will - -- return the next file name in Directory which match Pattern (Pattern - -- is a regular expression, using only the Unix shell and DOS syntax if - -- Basic_Regexp is True). When Directory is an empty string, the current - -- directory is searched. - -- - -- Pattern may contain directory separators (as in "src/*/*.ada"). - -- Subdirectories of Directory will also be searched, up to one - -- hundred levels deep. - -- - -- When Start_Expansion has been called, function Expansion should - -- be called repeatedly until it returns an empty string, before - -- Start_Expansion can be called again with the same Expansion_Iterator - -- variable. - - function Expansion (Iterator : Expansion_Iterator) return String; - -- Returns the next file in the directory matching the parameters given - -- to Start_Expansion and updates Iterator to point to the next entry. - -- Returns an empty string when there are no more files. - -- - -- If Expansion is called again after an empty string has been returned, - -- then the exception GNAT.Directory_Operations.Directory_Error is raised. - - ----------------- - -- Configuring -- - ----------------- - - -- The following subprograms are used to manipulate a command line - -- represented as a string (for instance "-g -O2"), as well as parsing - -- the switches from such a string. They provide high-level configurations - -- to define aliases (a switch is equivalent to one or more other switches) - -- or grouping of switches ("-gnatyac" is equivalent to "-gnatya" and - -- "-gnatyc"). - - -- See the top of this file for examples on how to use these subprograms - - type Command_Line_Configuration is private; - - procedure Define_Section - (Config : in out Command_Line_Configuration; - Section : String); - -- Indicates a new switch section. All switches belonging to the same - -- section are ordered together, preceded by the section. They are placed - -- at the end of the command line (as in "gnatmake somefile.adb -cargs -g") - -- - -- The section name should not include the leading '-'. So for instance in - -- the case of gnatmake we would use: - -- - -- Define_Section (Config, "cargs"); - -- Define_Section (Config, "bargs"); - - procedure Define_Alias - (Config : in out Command_Line_Configuration; - Switch : String; - Expanded : String; - Section : String := ""); - -- Indicates that whenever Switch appears on the command line, it should - -- be expanded as Expanded. For instance, for the GNAT compiler switches, - -- we would define "-gnatwa" as an alias for "-gnatwcfijkmopruvz", ie some - -- default warnings to be activated. - -- - -- This expansion is only done within the specified section, which must - -- have been defined first through a call to [Define_Section]. - - procedure Define_Prefix - (Config : in out Command_Line_Configuration; - Prefix : String); - -- Indicates that all switches starting with the given prefix should be - -- grouped. For instance, for the GNAT compiler we would define "-gnatw" as - -- a prefix, so that "-gnatwu -gnatwv" can be grouped into "-gnatwuv" It is - -- assumed that the remainder of the switch ("uv") is a set of characters - -- whose order is irrelevant. In fact, this package will sort them - -- alphabetically. - -- - -- When grouping switches that accept arguments (for instance "-gnatyL!" - -- as the definition, and "-gnatyaL12b" as the command line), only - -- numerical arguments are accepted. The above is equivalent to - -- "-gnatya -gnatyL12 -gnatyb". - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Argument : String := "ARG"); - -- Indicates a new switch. The format of this switch follows the getopt - -- format (trailing ':', '?', etc for defining a switch with parameters). - -- - -- Switch should also start with the leading '-' (or any other characters). - -- If this character is not '-', you need to call Initialize_Option_Scan to - -- set the proper character for the parser. - -- - -- The switches defined in the command_line_configuration object are used - -- when ungrouping switches with more that one character after the prefix. - -- - -- Switch and Long_Switch (when specified) are aliases and can be used - -- interchangeably. There is no check that they both take an argument or - -- both take no argument. Switch can be set to "*" to indicate that any - -- switch is supported (in which case Getopt will return '*', see its - -- documentation). - -- - -- Help is used by the Display_Help procedure to describe the supported - -- switches. - -- - -- In_Section indicates in which section the switch is valid (you need to - -- first define the section through a call to Define_Section). - -- - -- Argument is the name of the argument, as displayed in the automatic - -- help message. It is always capitalized for consistency. - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Output : access Boolean; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Value : Boolean := True); - -- See Define_Switch for a description of the parameters. - -- When the switch is found on the command line, Getopt will set - -- Output.all to Value. - -- - -- Output is always initially set to "not Value", so that if the switch is - -- not found on the command line, Output still has a valid value. - -- The switch must not take any parameter. - -- - -- Output must exist at least as long as Config, otherwise an erroneous - -- memory access may occur. - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Output : access Integer; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Initial : Integer := 0; - Default : Integer := 1; - Argument : String := "ARG"); - -- See Define_Switch for a description of the parameters. When the - -- switch is found on the command line, Getopt will set Output.all to the - -- value of the switch's parameter. If the parameter is not an integer, - -- Invalid_Parameter is raised. - - -- Output is always initialized to Initial. If the switch has an optional - -- argument which isn't specified by the user, then Output will be set to - -- Default. The switch must accept an argument. - - procedure Define_Switch - (Config : in out Command_Line_Configuration; - Output : access GNAT.Strings.String_Access; - Switch : String := ""; - Long_Switch : String := ""; - Help : String := ""; - Section : String := ""; - Argument : String := "ARG"); - -- Set Output to the value of the switch's parameter when the switch is - -- found on the command line. Output is always initialized to the empty - -- string if it does not have a value already (otherwise it is left as is - -- so that you can specify the default value directly in the declaration - -- of the variable). The switch must accept an argument. - - procedure Set_Usage - (Config : in out Command_Line_Configuration; - Usage : String := "[switches] [arguments]"; - Help : String := ""; - Help_Msg : String := ""); - -- Defines the general format of the call to the application, and a short - -- help text. These are both displayed by Display_Help. When a non-empty - -- Help_Msg is given, it is used by Display_Help instead of the - -- automatically generated list of supported switches. - - procedure Display_Help (Config : Command_Line_Configuration); - -- Display the help for the tool (ie its usage, and its supported switches) - - function Get_Switches - (Config : Command_Line_Configuration; - Switch_Char : Character := '-'; - Section : String := "") return String; - -- Get the switches list as expected by Getopt, for a specific section of - -- the command line. This list is built using all switches defined - -- previously via Define_Switch above. - - function Section_Delimiters - (Config : Command_Line_Configuration) return String; - -- Return a string suitable for use in Initialize_Option_Scan - - procedure Free (Config : in out Command_Line_Configuration); - -- Free the memory used by Config - - type Switch_Handler is access procedure - (Switch : String; - Parameter : String; - Section : String); - -- Called when a switch is found on the command line. Switch includes - -- any leading '-' that was specified in Define_Switch. This is slightly - -- different from the functional version of Getopt above, for which - -- Full_Switch omits the first leading '-'. - - Exit_From_Command_Line : exception; - -- Emitted when the program should exit. This is called when Getopt below - -- has seen -h, --help or an invalid switch. - - procedure Getopt - (Config : Command_Line_Configuration; - Callback : Switch_Handler := null; - Parser : Opt_Parser := Command_Line_Parser; - Concatenate : Boolean := True); - -- Similar to the standard Getopt function. For each switch found on the - -- command line, this calls Callback, if the switch is not handled - -- automatically. - -- - -- The list of valid switches are the ones from the configuration. The - -- switches that were declared through Define_Switch with an Output - -- parameter are never returned (and result in a modification of the Output - -- variable). This function will in fact never call [Callback] if all - -- switches were handled automatically and there is nothing left to do. - -- - -- The option Concatenate is identical to the one of the standard Getopt - -- function. - -- - -- This procedure automatically adds -h and --help to the valid switches, - -- to display the help message and raises Exit_From_Command_Line. - -- If an invalid switch is specified on the command line, this procedure - -- will display an error message and raises Invalid_Switch again. - -- - -- This function automatically expands switches: - -- - -- If Define_Prefix was called (for instance "-gnaty") and the user - -- specifies "-gnatycb" on the command line, then Getopt returns - -- "-gnatyc" and "-gnatyb" separately. - -- - -- If Define_Alias was called (for instance "-gnatya = -gnatycb") then - -- the latter is returned (in this case it also expands -gnaty as per - -- the above. - -- - -- The goal is to make handling as easy as possible by leaving as much - -- work as possible to this package. - -- - -- As opposed to the standard Getopt, this one will analyze all sections - -- as defined by Define_Section, and automatically jump from one section to - -- the next. - - ------------------------------ - -- Generating command lines -- - ------------------------------ - - -- Once the command line configuration has been created, you can build your - -- own command line. This will be done in general because you need to spawn - -- external tools from your application. - - -- Although it could be done by concatenating strings, the following - -- subprograms will properly take care of grouping switches when possible, - -- so as to keep the command line as short as possible. They also provide a - -- way to remove a switch from an existing command line. - - -- For instance: - - -- declare - -- Config : Command_Line_Configuration; - -- Line : Command_Line; - -- Args : Argument_List_Access; - - -- begin - -- Define_Switch (Config, "-gnatyc"); - -- Define_Switch (Config, ...); -- for all valid switches - -- Define_Prefix (Config, "-gnaty"); - - -- Set_Configuration (Line, Config); - -- Add_Switch (Line, "-O2"); - -- Add_Switch (Line, "-gnatyc"); - -- Add_Switch (Line, "-gnatyd"); - -- - -- Build (Line, Args); - -- -- Args is now ["-O2", "-gnatycd"] - -- end; - - type Command_Line is private; - - procedure Set_Configuration - (Cmd : in out Command_Line; - Config : Command_Line_Configuration); - function Get_Configuration - (Cmd : Command_Line) return Command_Line_Configuration; - -- Set or retrieve the configuration used for that command line. The Config - -- must have been initialized first, by calling one of the Define_Switches - -- subprograms. - - procedure Set_Command_Line - (Cmd : in out Command_Line; - Switches : String; - Getopt_Description : String := ""; - Switch_Char : Character := '-'); - -- Set the new content of the command line, by replacing the current - -- version with Switches. - -- - -- The parsing of Switches is done through calls to Getopt, by passing - -- Getopt_Description as an argument. (A "*" is automatically prepended so - -- that all switches and command line arguments are accepted). If a config - -- was defined via Set_Configuration, the Getopt_Description parameter will - -- be ignored. - -- - -- To properly handle switches that take parameters, you should document - -- them in Getopt_Description. Otherwise, the switch and its parameter will - -- be recorded as two separate command line arguments as returned by a - -- Command_Line_Iterator (which might be fine depending on your - -- application). - -- - -- If the command line has sections (such as -bargs -cargs), then they - -- should be listed in the Sections parameter (as "-bargs -cargs"). - -- - -- This function can be used to reset Cmd by passing an empty string - -- - -- If an invalid switch is found on the command line (ie wasn't defined in - -- the configuration via Define_Switch), and the configuration wasn't set - -- to accept all switches (by defining "*" as a valid switch), then an - -- exception Invalid_Switch is raised. The exception message indicates the - -- invalid switch. - - procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ASCII.NUL; - Section : String := ""; - Add_Before : Boolean := False); - -- Add a new switch to the command line, and combine/group it with existing - -- switches if possible. Nothing is done if the switch already exists with - -- the same parameter. - -- - -- If the Switch takes a parameter, the latter should be specified - -- separately, so that the association between the two is always correctly - -- recognized even if the order of switches on the command line changes. - -- For instance, you should pass "--check=full" as ("--check", "full") so - -- that Remove_Switch below can simply take "--check" in parameter. That - -- will automatically remove "full" as well. The value of the parameter is - -- never modified by this package. - -- - -- On the other hand, you could decide to simply pass "--check=full" as - -- the Switch above, and then pass no parameter. This means that you need - -- to pass "--check=full" to Remove_Switch as well. - -- - -- A Switch with a parameter will never be grouped with another switch to - -- avoid ambiguities as to what the parameter applies to. - -- - -- If the switch is part of a section, then it should be specified so that - -- the switch is correctly placed in the command line, and the section - -- added if not already present. For example, to add the -g switch into the - -- -cargs section, you need to call (Cmd, "-g", Section => "-cargs"). - -- - -- [Separator], if specified, overrides the separator that was defined - -- through Define_Switch. For instance, if the switch was defined as - -- "-from:", the separator defaults to a space. But if your application - -- uses unusual separators not supported by GNAT.Command_Line (for instance - -- it requires ":"), you can specify this separator here. - -- - -- For instance, - -- Add_Switch(Cmd, "-from", "bar", ':') - -- - -- results in - -- -from:bar - -- - -- rather than the default - -- -from bar - -- - -- Note however that Getopt doesn't know how to handle ":" as a separator. - -- So the recommendation is to declare the switch as "-from!" (ie no - -- space between the switch and its parameter). Then Getopt will return - -- ":bar" as the parameter, and you can trim the ":" in your application. - -- - -- Invalid_Section is raised if Section was not defined in the - -- configuration of the command line. - -- - -- Add_Before allows insertion of the switch at the beginning of the - -- command line. - - procedure Add_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String := ""; - Separator : Character := ASCII.NUL; - Section : String := ""; - Add_Before : Boolean := False; - Success : out Boolean); - -- Same as above, returning the status of the operation - - procedure Remove_Switch - (Cmd : in out Command_Line; - Switch : String; - Remove_All : Boolean := False; - Has_Parameter : Boolean := False; - Section : String := ""); - -- Remove Switch from the command line, and ungroup existing switches if - -- necessary. - -- - -- The actual parameter to the switches are ignored. If for instance - -- you are removing "-foo", then "-foo param1" and "-foo param2" can - -- be removed. - -- - -- If Remove_All is True, then all matching switches are removed, otherwise - -- only the first matching one is removed. - -- - -- If Has_Parameter is set to True, then only switches having a parameter - -- are removed. - -- - -- If the switch belongs to a section, then this section should be - -- specified: Remove_Switch (Cmd_Line, "-g", Section => "-cargs") called - -- on the command line "-g -cargs -g" will result in "-g", while if - -- called with (Cmd_Line, "-g") this will result in "-cargs -g". - -- If Remove_All is set, then both "-g" will be removed. - - procedure Remove_Switch - (Cmd : in out Command_Line; - Switch : String; - Remove_All : Boolean := False; - Has_Parameter : Boolean := False; - Section : String := ""; - Success : out Boolean); - -- Same as above, reporting the success of the operation (Success is False - -- if no switch was removed). - - procedure Remove_Switch - (Cmd : in out Command_Line; - Switch : String; - Parameter : String; - Section : String := ""); - -- Remove a switch with a specific parameter. If Parameter is the empty - -- string, then only a switch with no parameter will be removed. - - procedure Free (Cmd : in out Command_Line); - -- Free the memory used by Cmd - - --------------- - -- Iteration -- - --------------- - - -- When a command line was created with the above, you can then iterate - -- over its contents using the following iterator. - - type Command_Line_Iterator is private; - - procedure Start - (Cmd : in out Command_Line; - Iter : in out Command_Line_Iterator; - Expanded : Boolean := False); - -- Start iterating over the command line arguments. If Expanded is true, - -- then the arguments are not grouped and no alias is used. For instance, - -- "-gnatwv" and "-gnatwu" would be returned instead of "-gnatwuv". - -- - -- The iterator becomes invalid if the command line is changed through a - -- call to Add_Switch, Remove_Switch or Set_Command_Line. - - function Current_Switch (Iter : Command_Line_Iterator) return String; - function Is_New_Section (Iter : Command_Line_Iterator) return Boolean; - function Current_Section (Iter : Command_Line_Iterator) return String; - function Current_Separator (Iter : Command_Line_Iterator) return String; - function Current_Parameter (Iter : Command_Line_Iterator) return String; - -- Return the current switch and its parameter (or the empty string if - -- there is no parameter or the switch was added through Add_Switch - -- without specifying the parameter. - -- - -- Separator is the string that goes between the switch and its separator. - -- It could be the empty string if they should be concatenated, or a space - -- for instance. When printing, you should not add any other character. - - function Has_More (Iter : Command_Line_Iterator) return Boolean; - -- Return True if there are more switches to be returned - - procedure Next (Iter : in out Command_Line_Iterator); - -- Move to the next switch - - procedure Build - (Line : in out Command_Line; - Args : out GNAT.OS_Lib.Argument_List_Access; - Expanded : Boolean := False; - Switch_Char : Character := '-'); - -- This is a wrapper using the Command_Line_Iterator. It provides a simple - -- way to get all switches (grouped as much as possible), and possibly - -- create an Opt_Parser. - -- - -- Args must be freed by the caller. - -- - -- Expanded has the same meaning as in Start. - - procedure Try_Help; - -- Output a message on standard error to indicate how to get the usage for - -- the executable. This procedure should only be called when the executable - -- accepts switch --help. When this procedure is called by executable xxx, - -- the following message is displayed on standard error: - -- try "xxx --help" for more information. - -private - - Max_Depth : constant := 100; - -- Maximum depth of subdirectories - - Max_Path_Length : constant := 1024; - -- Maximum length of relative path - - type Depth is range 1 .. Max_Depth; - - type Level is record - Name_Last : Natural := 0; - Dir : GNAT.Directory_Operations.Dir_Type; - end record; - - type Level_Array is array (Depth) of Level; - - type Section_Number is new Natural range 0 .. 65534; - for Section_Number'Size use 16; - - type Parameter_Type is record - Arg_Num : Positive; - First : Positive; - Last : Natural; - Extra : Character; - end record; - - type Is_Switch_Type is array (Natural range <>) of Boolean; - pragma Pack (Is_Switch_Type); - - type Section_Type is array (Natural range <>) of Section_Number; - pragma Pack (Section_Type); - - type Expansion_Iterator is limited record - Start : Positive := 1; - -- Position of the first character of the relative path to check against - -- the pattern. - - Dir_Name : String (1 .. Max_Path_Length); - - Current_Depth : Depth := 1; - - Levels : Level_Array; - - Regexp : GNAT.Regexp.Regexp; - -- Regular expression built with the pattern - - Maximum_Depth : Depth := 1; - -- The maximum depth of directories, reflecting the number of directory - -- separators in the pattern. - end record; - - type Opt_Parser_Data (Arg_Count : Natural) is record - Arguments : GNAT.OS_Lib.Argument_List_Access; - -- null if reading from the command line - - The_Parameter : Parameter_Type; - The_Separator : Character; - The_Switch : Parameter_Type; - -- This type and this variable are provided to store the current switch - -- and parameter. - - Is_Switch : Is_Switch_Type (1 .. Arg_Count) := (others => False); - -- Indicates wich arguments on the command line are considered not be - -- switches or parameters to switches (leaving e.g. filenames,...) - - Section : Section_Type (1 .. Arg_Count) := (others => 1); - -- Contains the number of the section associated with the current - -- switch. If this number is 0, then it is a section delimiter, which is - -- never returned by GetOpt. - - Current_Argument : Natural := 1; - -- Number of the current argument parsed on the command line - - Current_Index : Natural := 1; - -- Index in the current argument of the character to be processed - - Current_Section : Section_Number := 1; - - Expansion_It : aliased Expansion_Iterator; - -- When Get_Argument is expanding a file name, this is the iterator used - - In_Expansion : Boolean := False; - -- True if we are expanding a file - - Switch_Character : Character := '-'; - -- The character at the beginning of the command line arguments, - -- indicating the beginning of a switch. - - Stop_At_First : Boolean := False; - -- If it is True then Getopt stops at the first non-switch argument - end record; - - Command_Line_Parser_Data : aliased Opt_Parser_Data - (Ada.Command_Line.Argument_Count); - -- The internal data used when parsing the command line - - type Opt_Parser is access all Opt_Parser_Data; - Command_Line_Parser : constant Opt_Parser := - Command_Line_Parser_Data'Access; - - type Switch_Type is (Switch_Untyped, - Switch_Boolean, - Switch_Integer, - Switch_String); - - type Switch_Definition (Typ : Switch_Type := Switch_Untyped) is record - Switch : GNAT.OS_Lib.String_Access; - Long_Switch : GNAT.OS_Lib.String_Access; - Section : GNAT.OS_Lib.String_Access; - Help : GNAT.OS_Lib.String_Access; - - Argument : GNAT.OS_Lib.String_Access; - -- null if "ARG". - -- Name of the argument for this switch. - - case Typ is - when Switch_Untyped => - null; - when Switch_Boolean => - Boolean_Output : access Boolean; - Boolean_Value : Boolean; -- will set Output to that value - when Switch_Integer => - Integer_Output : access Integer; - Integer_Initial : Integer; - Integer_Default : Integer; - when Switch_String => - String_Output : access GNAT.Strings.String_Access; - end case; - end record; - type Switch_Definitions is array (Natural range <>) of Switch_Definition; - type Switch_Definitions_List is access all Switch_Definitions; - -- [Switch] includes the leading '-' - - type Alias_Definition is record - Alias : GNAT.OS_Lib.String_Access; - Expansion : GNAT.OS_Lib.String_Access; - Section : GNAT.OS_Lib.String_Access; - end record; - type Alias_Definitions is array (Natural range <>) of Alias_Definition; - type Alias_Definitions_List is access all Alias_Definitions; - - type Command_Line_Configuration_Record is record - Prefixes : GNAT.OS_Lib.Argument_List_Access; - -- The list of prefixes - - Sections : GNAT.OS_Lib.Argument_List_Access; - -- The list of sections - - Star_Switch : Boolean := False; - -- Whether switches not described in this configuration should be - -- returned to the user (True). If False, an exception Invalid_Switch - -- is raised. - - Aliases : Alias_Definitions_List; - Usage : GNAT.OS_Lib.String_Access; - Help : GNAT.OS_Lib.String_Access; - Help_Msg : GNAT.OS_Lib.String_Access; - Switches : Switch_Definitions_List; - -- List of expected switches (Used when expanding switch groups) - end record; - type Command_Line_Configuration is access Command_Line_Configuration_Record; - - type Command_Line is record - Config : Command_Line_Configuration; - Expanded : GNAT.OS_Lib.Argument_List_Access; - - Params : GNAT.OS_Lib.Argument_List_Access; - -- Parameter for the corresponding switch in Expanded. The first - -- character is the separator (or ASCII.NUL if there is no separator). - - Sections : GNAT.OS_Lib.Argument_List_Access; - -- The list of sections - - Coalesce : GNAT.OS_Lib.Argument_List_Access; - Coalesce_Params : GNAT.OS_Lib.Argument_List_Access; - Coalesce_Sections : GNAT.OS_Lib.Argument_List_Access; - -- Cached version of the command line. This is recomputed every time - -- the command line changes. Switches are grouped as much as possible, - -- and aliases are used to reduce the length of the command line. The - -- parameters are not allocated, they point into Params, so they must - -- not be freed. - end record; - - type Command_Line_Iterator is record - List : GNAT.OS_Lib.Argument_List_Access; - Sections : GNAT.OS_Lib.Argument_List_Access; - Params : GNAT.OS_Lib.Argument_List_Access; - Current : Natural; - end record; - -end GNAT.Command_Line; diff --git a/gcc/ada/g-comver.adb b/gcc/ada/g-comver.adb deleted file mode 100644 index 61ca4d6..0000000 --- a/gcc/ada/g-comver.adb +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C O M P I L E R _ V E R S I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a routine for obtaining the version number of the --- GNAT compiler used to compile the program. It relies on the generated --- constant in the binder generated package that records this information. - -package body GNAT.Compiler_Version is - - Ver_Len_Max : constant := 256; - -- This is logically a reference to Gnatvsn.Ver_Len_Max but we cannot - -- import this directly since run-time units cannot WITH compiler units. - - Ver_Prefix : constant String := "GNAT Version: "; - -- This is logically a reference to Gnatvsn.Ver_Prefix but we cannot - -- import this directly since run-time units cannot WITH compiler units. - - GNAT_Version : constant String (1 .. Ver_Len_Max + Ver_Prefix'Length); - pragma Import (C, GNAT_Version, "__gnat_version"); - - ------------- - -- Version -- - ------------- - - function Version return String is - begin - -- Search for terminating right paren or NUL ending the string - - for J in Ver_Prefix'Length + 1 .. GNAT_Version'Last loop - if GNAT_Version (J) = ')' then - return GNAT_Version (Ver_Prefix'Length + 1 .. J); - end if; - - if GNAT_Version (J) = Character'Val (0) then - return GNAT_Version (Ver_Prefix'Length + 1 .. J - 1); - end if; - end loop; - - -- This should not happen (no right paren or NUL found) - - return GNAT_Version; - end Version; - -end GNAT.Compiler_Version; diff --git a/gcc/ada/g-comver.ads b/gcc/ada/g-comver.ads deleted file mode 100644 index 037a21a..0000000 --- a/gcc/ada/g-comver.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . C O M P I L E R _ V E R S I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a routine for obtaining the version number of the --- GNAT compiler used to compile the program. It relies on the generated --- constant in the binder generated package that records this information. - --- Note: to use this package you must first instantiate it, for example: - --- package CVer is new GNAT.Compiler_Version; - --- and then you use the function in the instantiated package (Cver.Version). --- The reason that this unit is generic is that otherwise the direct attempt --- to import the necessary variable from the binder file causes trouble when --- building a shared library, since the symbol is not available. - --- Note: this unit is only useable if the main program is written in Ada. --- It cannot be used if the main program is written in foreign language. - -generic -package GNAT.Compiler_Version is - pragma Pure; - - function Version return String; - -- This function returns the version in the form "v.vvx (yyyyddmm)". - -- Here v.vv is the main version number (e.g. 3.16), x is the version - -- designator (e.g. a1 in 3.16a1), and yyyyddmm is the date in ISO form. - -- An example of the returned value would be "3.16w (20021029)". The - -- version is actually that of the binder used to bind the program, - -- which will be the same as the compiler version if a consistent - -- set of tools is used to build the program. - -end GNAT.Compiler_Version; diff --git a/gcc/ada/g-cppexc.adb b/gcc/ada/g-cppexc.adb deleted file mode 100644 index d89cf0c..0000000 --- a/gcc/ada/g-cppexc.adb +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C P P _ E X C E P T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; -with System.Storage_Elements; -with Interfaces.C; use Interfaces.C; -with Ada.Unchecked_Conversion; -with System.Standard_Library; use System.Standard_Library; - -package body GNAT.CPP_Exceptions is - - -- Note: all functions prefixed by __cxa are part of the c++ ABI for - -- exception handling. As they are provided by the c++ library, there - -- must be no dependencies on it in the compiled code of this unit, but - -- there can be dependencies in instances. This is required to be able - -- to build the shared library without the c++ library. - - function To_Exception_Data_Ptr is new - Ada.Unchecked_Conversion - (Exception_Id, Exception_Data_Ptr); - -- Convert an Exception_Id to its non-private type. This is used to get - -- the RTTI of a C++ exception - - function Get_Exception_Machine_Occurrence - (X : Exception_Occurrence) return System.Address; - pragma Import (Ada, Get_Exception_Machine_Occurrence, - "__gnat_get_exception_machine_occurrence"); - -- Imported function (from Ada.Exceptions) that returns the machine - -- occurrence from an exception occurrence. - - ------------------------- - -- Raise_Cpp_Exception -- - ------------------------- - - procedure Raise_Cpp_Exception (Id : Exception_Id; Value : T) - is - Id_Data : constant Exception_Data_Ptr := To_Exception_Data_Ptr (Id); - -- Get a non-private view on the exception - - type T_Acc is access all T; - pragma Convention (C, T_Acc); - -- Access type to the object compatible with C - - Occ : T_Acc; - -- The occurrence to propagate - - function cxa_allocate_exception (Size : size_t) return T_Acc; - pragma Import (C, cxa_allocate_exception, "__cxa_allocate_exception"); - -- The C++ function to allocate an occurrence - - procedure cxa_throw (Obj : T_Acc; Tinfo : System.Address; - Dest : System.Address); - pragma Import (C, cxa_throw, "__cxa_throw"); - pragma No_Return (cxa_throw); - -- The C++ function to raise an exception - begin - -- Check the exception was imported from C++ - - if Id_Data.Lang /= 'C' then - raise Constraint_Error; - end if; - - -- Allocate the C++ occurrence - - Occ := cxa_allocate_exception (T'Size / System.Storage_Unit); - - -- Set the object - - Occ.all := Value; - - -- Throw the exception - - cxa_throw (Occ, Id_Data.Foreign_Data, System.Null_Address); - end Raise_Cpp_Exception; - - ---------------- - -- Get_Object -- - ---------------- - - function Get_Object (X : Exception_Occurrence) return T - is - use System; - use System.Storage_Elements; - - Unwind_Exception_Size : Natural; - pragma Import (C, Unwind_Exception_Size, "__gnat_unwind_exception_size"); - -- Size in bytes of _Unwind_Exception - - Exception_Addr : constant Address := - Get_Exception_Machine_Occurrence (X); - -- Machine occurrence of X - - begin - -- Check the machine occurrence exists - - if Exception_Addr = Null_Address then - raise Constraint_Error; - end if; - - declare - -- Import the object from the occurrence - Result : T; - pragma Import (Ada, Result); - for Result'Address use - Exception_Addr + Storage_Offset (Unwind_Exception_Size); - begin - -- And return it - return Result; - end; - end Get_Object; -end GNAT.CPP_Exceptions; diff --git a/gcc/ada/g-cppexc.ads b/gcc/ada/g-cppexc.ads deleted file mode 100644 index 60105e6..0000000 --- a/gcc/ada/g-cppexc.ads +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C P P _ E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface for raising and handling C++ exceptions - -with Ada.Exceptions; use Ada.Exceptions; - -package GNAT.CPP_Exceptions is - generic - type T is private; - procedure Raise_Cpp_Exception (Id : Exception_Id; Value : T); - -- Raise a C++ exception identified by Id. Associate Value with this - -- occurrence. Id must refer to an exception that has the Cpp convention. - - generic - type T is private; - function Get_Object (X : Exception_Occurrence) return T; - -- Extract the object associated with X. The exception of the occurrence - -- X must have a Cpp Convention. -end GNAT.CPP_Exceptions; diff --git a/gcc/ada/g-crc32.adb b/gcc/ada/g-crc32.adb deleted file mode 100644 index 14d592a..0000000 --- a/gcc/ada/g-crc32.adb +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . C R C 3 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body GNAT.CRC32 is - - ------------ - -- Update -- - ------------ - - procedure Update (C : in out CRC32; Value : String) is - begin - for K in Value'Range loop - Update (C, Value (K)); - end loop; - end Update; - - procedure Update (C : in out CRC32; Value : Ada.Streams.Stream_Element) is - function To_Char is new Ada.Unchecked_Conversion - (Ada.Streams.Stream_Element, Character); - V : constant Character := To_Char (Value); - begin - Update (C, V); - end Update; - - procedure Update - (C : in out CRC32; - Value : Ada.Streams.Stream_Element_Array) - is - begin - for K in Value'Range loop - Update (C, Value (K)); - end loop; - end Update; - - ----------------- - -- Wide_Update -- - ----------------- - - procedure Wide_Update (C : in out CRC32; Value : Wide_Character) is - subtype S2 is String (1 .. 2); - function To_S2 is new Ada.Unchecked_Conversion (Wide_Character, S2); - VS : constant S2 := To_S2 (Value); - begin - Update (C, VS (1)); - Update (C, VS (2)); - end Wide_Update; - - procedure Wide_Update (C : in out CRC32; Value : Wide_String) is - begin - for K in Value'Range loop - Wide_Update (C, Value (K)); - end loop; - end Wide_Update; - -end GNAT.CRC32; diff --git a/gcc/ada/g-crc32.ads b/gcc/ada/g-crc32.ads deleted file mode 100644 index 61d37a3..0000000 --- a/gcc/ada/g-crc32.ads +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . C R C 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides routines for computing a commonly used checksum --- called CRC-32. This is a checksum based on treating the binary data --- as a polynomial over a binary field, and the exact specifications of --- the CRC-32 algorithm are as follows: - --- Name : "CRC-32" --- Width : 32 --- Poly : 04C11DB7 --- Init : FFFFFFFF --- RefIn : True --- RefOut : True --- XorOut : FFFFFFFF --- Check : CBF43926 - --- Note that this is the algorithm used by PKZip, Ethernet and FDDI - --- For more information about this algorithm see: - --- ftp://ftp.rocksoft.com/papers/crc_v3.txt - --- "A Painless Guide to CRC Error Detection Algorithms", Ross N. Williams - --- "Computation of Cyclic Redundancy Checks via Table Look-Up", Communications --- of the ACM, Vol. 31 No. 8, pp.1008-1013 Aug. 1988. Sarwate, D.V. - -with Ada.Streams; -with Interfaces; -with System.CRC32; - -package GNAT.CRC32 is - - subtype CRC32 is System.CRC32.CRC32; - -- Used to represent CRC32 values, which are 32 bit bit-strings - - procedure Initialize (C : out CRC32) - renames System.CRC32.Initialize; - -- Initialize CRC value by assigning the standard Init value (16#FFFF_FFFF) - - procedure Update - (C : in out CRC32; - Value : Character) - renames System.CRC32.Update; - -- Evolve CRC by including the contribution from Character'Pos (Value) - - procedure Update - (C : in out CRC32; - Value : String); - -- For each character in the Value string call above routine - - procedure Wide_Update - (C : in out CRC32; - Value : Wide_Character); - -- Evolve CRC by including the contribution from Wide_Character'Pos (Value) - -- with the bytes being included in the natural memory order. - - procedure Wide_Update - (C : in out CRC32; - Value : Wide_String); - -- For each character in the Value string call above routine - - procedure Update - (C : in out CRC32; - Value : Ada.Streams.Stream_Element); - -- Evolve CRC by including the contribution from Value - - procedure Update - (C : in out CRC32; - Value : Ada.Streams.Stream_Element_Array); - -- For each element in the Value array call above routine - - function Get_Value (C : CRC32) return Interfaces.Unsigned_32 - renames System.CRC32.Get_Value; - -- Get_Value computes the CRC32 value by performing an XOR with the - -- standard XorOut value (16#FFFF_FFFF). Note that this does not - -- change the value of C, so it may be used to retrieve intermediate - -- values of the CRC32 value during a sequence of Update calls. - - pragma Inline (Update); - pragma Inline (Wide_Update); -end GNAT.CRC32; diff --git a/gcc/ada/g-ctrl_c.adb b/gcc/ada/g-ctrl_c.adb deleted file mode 100644 index edd7dc6..0000000 --- a/gcc/ada/g-ctrl_c.adb +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C T R L _ C -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2015, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Ctrl_C is - - type C_Handler_Type is access procedure; - pragma Convention (C, C_Handler_Type); - - Ada_Handler : Handler_Type; - - procedure C_Handler; - pragma Convention (C, C_Handler); - - --------------- - -- C_Handler -- - --------------- - - procedure C_Handler is - begin - Ada_Handler.all; - end C_Handler; - - --------------------- - -- Install_Handler -- - --------------------- - - procedure Install_Handler (Handler : Handler_Type) is - procedure Internal (Handler : C_Handler_Type); - pragma Import (C, Internal, "__gnat_install_int_handler"); - begin - Ada_Handler := Handler; - Internal (C_Handler'Access); - end Install_Handler; - -end GNAT.Ctrl_C; diff --git a/gcc/ada/g-ctrl_c.ads b/gcc/ada/g-ctrl_c.ads deleted file mode 100644 index 0f068c2..0000000 --- a/gcc/ada/g-ctrl_c.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . C T R L _ C -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package may be used to intercept the interruption of a running --- program by the operator typing Control-C, without having to use an Ada --- interrupt handler protected object. - --- This package is currently implemented under Windows and Unix platforms - --- Note concerning Unix systems: - --- The behavior of this package when using tasking depends on the interaction --- between sigaction() and the thread library. - -package GNAT.Ctrl_C is - - type Handler_Type is access procedure; - -- Any parameterless library level procedure can be used as a handler. - -- Handler_Type should not propagate exceptions. - - procedure Install_Handler (Handler : Handler_Type); - -- Set up Handler to be called if the operator hits Ctrl-C, instead of the - -- standard Control-C handler. - - procedure Uninstall_Handler; - -- Reinstall the standard Control-C handler. - -- If Install_Handler has never been called, this procedure has no effect. - -private - pragma Import (C, Uninstall_Handler, "__gnat_uninstall_int_handler"); -end GNAT.Ctrl_C; diff --git a/gcc/ada/g-curexc.ads b/gcc/ada/g-curexc.ads deleted file mode 100644 index 47fffab..0000000 --- a/gcc/ada/g-curexc.ads +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . C U R R E N T _ E X C E P T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides routines for obtaining the current exception --- information in Ada 83 style. In Ada 83, there was no official method --- for obtaining exception information, but a number of vendors supplied --- routines for this purpose, and this package closely approximates the --- interfaces supplied by DEC Ada 83 and VADS Ada. - --- The routines in this package are associated with a particular exception --- handler, and can only be called from within an exception handler. See --- also the package GNAT.Most_Recent_Exception, which provides access to --- the most recently raised exception, and is not limited to static calls --- from an exception handler. - -package GNAT.Current_Exception is - pragma Pure; - - ----------------- - -- Subprograms -- - ----------------- - - -- Note: the lower bound of returned String values is always one - - function Exception_Information return String; - -- Returns the result of calling Ada.Exceptions.Exception_Information - -- with an argument that is the Exception_Occurrence corresponding to - -- the current exception. Returns the null string if called from outside - -- an exception handler. - - function Exception_Message return String; - -- Returns the result of calling Ada.Exceptions.Exception_Message with - -- an argument that is the Exception_Occurrence corresponding to the - -- current exception. Returns the null string if called from outside an - -- exception handler. - - function Exception_Name return String; - -- Returns the result of calling Ada.Exceptions.Exception_Name with - -- an argument that is the Exception_Occurrence corresponding to the - -- current exception. Returns the null string if called from outside - -- an exception handler. - - -- Note: all these functions return useful information only if - -- called statically from within an exception handler, and they - -- return information about the exception corresponding to the - -- handler in which they appear. This is NOT the same as the most - -- recently raised exception. Consider the example: - - -- exception - -- when Constraint_Error => - -- begin - -- ... - -- exception - -- when Tasking_Error => ... - -- end; - -- - -- -- Exception_xxx at this point returns the information about - -- -- the constraint error, not about any exception raised within - -- -- the nested block since it is the static nesting that counts. - - ----------------------------------- - -- Use of Library Level Renaming -- - ----------------------------------- - - -- For greater compatibility with existing legacy software, library - -- level renaming may be used to create a function with a name matching - -- one that is in use. For example, some versions of VADS Ada provided - -- a function called Current_Exception whose semantics was identical to - -- that of GNAT. The following library level renaming declaration: - - -- with GNAT.Current_Exception; - -- function Current_Exception - -- renames GNAT.Current_Exception.Exception_Name; - - -- placed in a file called current_exception.ads and compiled into the - -- application compilation environment, will make the function available - -- in a manner exactly compatible with that in VADS Ada 83. - -private - pragma Import (Intrinsic, Exception_Information); - pragma Import (intrinsic, Exception_Message); - pragma Import (Intrinsic, Exception_Name); - -end GNAT.Current_Exception; diff --git a/gcc/ada/g-debpoo.adb b/gcc/ada/g-debpoo.adb deleted file mode 100644 index 9934e61..0000000 --- a/gcc/ada/g-debpoo.adb +++ /dev/null @@ -1,2520 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D E B U G _ P O O L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.IO; use GNAT.IO; - -with System.CRTL; -with System.Memory; use System.Memory; -with System.Soft_Links; use System.Soft_Links; - -with System.Traceback_Entries; - -with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; -with GNAT.HTable; -with GNAT.Traceback; use GNAT.Traceback; - -with Ada.Finalization; -with Ada.Unchecked_Conversion; - -package body GNAT.Debug_Pools is - - Storage_Alignment : constant := Standard'Maximum_Alignment; - -- Alignment enforced for all the memory chunks returned by Allocate, - -- maximized to make sure that it will be compatible with all types. - -- - -- The addresses returned by the underlying low-level allocator (be it - -- 'new' or a straight 'malloc') aren't guaranteed to be that much aligned - -- on some targets, so we manage the needed alignment padding ourselves - -- systematically. Use of a common value for every allocation allows - -- significant simplifications in the code, nevertheless, for improved - -- robustness and efficiency overall. - - -- We combine a few internal devices to offer the pool services: - -- - -- * A management header attached to each allocated memory block, located - -- right ahead of it, like so: - -- - -- Storage Address returned by the pool, - -- aligned on Storage_Alignment - -- v - -- +------+--------+--------------------- - -- | ~~~~ | HEADER | USER DATA ... | - -- +------+--------+--------------------- - -- <----> - -- alignment - -- padding - -- - -- The alignment padding is required - -- - -- * A validity bitmap, which holds a validity bit for blocks managed by - -- the pool. Enforcing Storage_Alignment on those blocks allows efficient - -- validity management. - -- - -- * A list of currently used blocks. - - 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. - - Disable : Boolean := False; - -- This variable is used to avoid infinite loops, where this package would - -- itself allocate memory and then call itself recursively, forever. Useful - -- when System_Memory_Debug_Pool_Enabled is True. - - System_Memory_Debug_Pool_Enabled : Boolean := False; - -- If True, System.Memory allocation uses Debug_Pool - - Allow_Unhandled_Memory : Boolean := False; - -- If True, protects Deallocate against releasing memory allocated before - -- System_Memory_Debug_Pool_Enabled was set. - - Traceback_Count : Byte_Count := 0; - -- Total number of traceback elements - - --------------------------- - -- Back Trace Hash Table -- - --------------------------- - - -- 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; - -- Number of elements in the hash-table - - type Tracebacks_Array_Access is access 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; - -- Size of the memory allocated/freed at Traceback since last Reset call - - Total : Byte_Count; - -- Number of chunk of memory allocated/freed at Traceback since last - -- Reset call. - - Frees : Natural; - -- Number of chunk of memory allocated at Traceback, currently freed - -- since last Reset call. (only for Alloc & Indirect_Alloc elements) - - Total_Frees : Byte_Count; - -- Size of the memory allocated at Traceback, currently freed since last - -- Reset call. (only for Alloc & Indirect_Alloc elements) - - Next : Traceback_Htable_Elem_Ptr; - end record; - - -- Subprograms used for the Backtrace_Htable instantiation - - procedure Set_Next - (E : Traceback_Htable_Elem_Ptr; - Next : Traceback_Htable_Elem_Ptr); - pragma Inline (Set_Next); - - function Next - (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr; - pragma Inline (Next); - - function Get_Key - (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access; - pragma Inline (Get_Key); - - function Hash (T : Tracebacks_Array_Access) return Header; - pragma Inline (Hash); - - function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean; - -- Why is this not inlined??? - - -- The hash table for back traces - - 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; - - 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. - - -- The following record stores extra information that needs to be - -- memorized for each block allocated with the special debug pool. - - type Allocation_Header is record - Allocation_Address : System.Address; - -- Address of the block returned by malloc, possibly unaligned - - 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; - -- ??? comment required - - Dealloc_Traceback : Traceback_Ptr_Or_Address; - -- Pointer to the traceback for the allocation (if the memory chunk 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); - - Header_Offset : constant Storage_Count := - (Allocation_Header'Object_Size / System.Storage_Unit); - -- Offset, in bytes, from start of allocation Header to start of User - -- data. The start of user data is assumed to be aligned at least as much - -- as what the header type requires, so applying this offset yields a - -- suitably aligned address as well. - - Extra_Allocation : constant Storage_Count := - (Storage_Alignment - 1 + Header_Offset); - -- Amount we need to secure in addition to the user data for a given - -- allocation request: room for the allocation header plus worst-case - -- alignment padding. - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Align (Addr : Integer_Address) return Integer_Address; - pragma Inline (Align); - -- Return the next address aligned on Storage_Alignment from Addr. - - 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. - - function Output_File (Pool : Debug_Pool) return File_Type; - pragma Inline (Output_File); - -- Returns file_type on which error messages have to be generated for Pool - - procedure Put_Line - (File : File_Type; - 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 File. 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 - - procedure Stdout_Put (S : String); - -- Wrapper for Put that ensures we always write to stdout instead of the - -- current output file defined in GNAT.IO. - - procedure Stdout_Put_Line (S : String); - -- Wrapper for Put_Line that ensures we always write to stdout instead of - -- the current output file defined in GNAT.IO. - - procedure Print_Traceback - (Output_File : File_Type; - Prefix : String; - Traceback : Traceback_Htable_Elem_Ptr); - -- Output Prefix & Traceback & EOL. Print nothing if Traceback is null. - - procedure Print_Address (File : File_Type; Addr : Address); - -- Output System.Address without using secondary stack. - -- When System.Memory uses Debug_Pool, secondary stack cannot be used - -- during Allocate calls, as some Allocate calls are done to - -- register/initialize a secondary stack for a foreign thread. - -- During these calls, the secondary stack is not available yet. - - package Validity is - function Is_Handled (Storage : System.Address) return Boolean; - pragma Inline (Is_Handled); - -- Return True if Storage is the address of a block that the debug pool - -- already had under its control. Used to allow System.Memory to use - -- Debug_Pools - - function Is_Valid (Storage : System.Address) return Boolean; - pragma Inline (Is_Valid); - -- Return True if Storage is the address of a block that the debug pool - -- has under its control, in which case Header_Of may be used to access - -- the associated allocation header. - - 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). - - Validity_Count : Byte_Count := 0; - -- Total number of validity elements - - end Validity; - - use Validity; - - 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 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 excludes 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. - - package STBE renames System.Traceback_Entries; - - function PC_For (TB_Entry : STBE.Traceback_Entry) return System.Address - renames STBE.PC_For; - - type Scope_Lock is - new Ada.Finalization.Limited_Controlled with null record; - -- Used to handle Lock_Task/Unlock_Task calls - - overriding procedure Initialize (This : in out Scope_Lock); - -- Lock task on initialization - - overriding procedure Finalize (This : in out Scope_Lock); - -- Unlock task on finalization - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (This : in out Scope_Lock) is - pragma Unreferenced (This); - begin - Lock_Task.all; - end Initialize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (This : in out Scope_Lock) is - pragma Unreferenced (This); - begin - Unlock_Task.all; - end Finalize; - - ----------- - -- Align -- - ----------- - - function Align (Addr : Integer_Address) return Integer_Address is - Factor : constant Integer_Address := Storage_Alignment; - begin - return ((Addr + Factor - 1) / Factor) * Factor; - end Align; - - --------------- - -- 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 - Header_Offset); - 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 type Tracebacks_Array; - 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 -- - ---------- - - 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; - - ----------------- - -- Output_File -- - ----------------- - - function Output_File (Pool : Debug_Pool) return File_Type is - begin - if Pool.Errors_To_Stdout then - return Standard_Output; - else - return Standard_Error; - end if; - end Output_File; - - ------------------- - -- Print_Address -- - ------------------- - - procedure Print_Address (File : File_Type; Addr : Address) is - begin - -- Warning: secondary stack cannot be used here. When System.Memory - -- implementation uses Debug_Pool, Print_Address can be called during - -- secondary stack creation for foreign threads. - - Put (File, Image_C (Addr)); - end Print_Address; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line - (File : File_Type; - 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 - Print_Address (File, PC_For (Tr (J))); - Put (File, ' '); - end loop; - Put (File, ASCII.LF); - end Print; - - -- Start of processing for Put_Line - - begin - if Traceback = null then - declare - Len : Natural; - Start : Natural; - Trace : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels); - - begin - Call_Chain (Trace, Len); - Skip_Levels - (Depth => Depth, - Trace => Trace, - Start => Start, - Len => Len, - Ignored_Frame_Start => Ignored_Frame_Start, - Ignored_Frame_End => Ignored_Frame_End); - Print (Trace (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 - Disable_Exit_Value : constant Boolean := Disable; - - Elem : Traceback_Htable_Elem_Ptr; - Len : Natural; - Start : Natural; - Trace : aliased Tracebacks_Array - (1 .. Integer (Pool.Stack_Trace_Depth) + - Max_Ignored_Levels); - - begin - Disable := True; - Call_Chain (Trace, Len); - Skip_Levels - (Depth => Pool.Stack_Trace_Depth, - Trace => Trace, - Start => Start, - Len => Len, - Ignored_Frame_Start => Ignored_Frame_Start, - Ignored_Frame_End => 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), - Frees => 0, - Total_Frees => 0, - Next => null); - Traceback_Count := Traceback_Count + 1; - Backtrace_Htable.Set (Elem); - - else - Elem.Count := Elem.Count + 1; - Elem.Total := Elem.Total + Byte_Count (Size); - end if; - - Disable := Disable_Exit_Value; - return Elem; - exception - when others => - Disable := Disable_Exit_Value; - raise; - end; - end Find_Or_Create_Traceback; - - -------------- - -- Validity -- - -------------- - - package body Validity is - - -- The validity bits of the allocated blocks are kept in a has table. - -- Each component of the hash table contains the validity bits for a - -- 16 Mbyte memory chunk. - - -- The reason the validity bits are kept for chunks of memory rather - -- than in a big array is that on some 64 bit platforms, it may happen - -- that two chunk of allocated data are very far from each other. - - Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB - Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit; - - Max_Validity_Byte_Index : constant := - Memory_Chunk_Size / Validity_Divisor; - - subtype Validity_Byte_Index is - Integer_Address range 0 .. Max_Validity_Byte_Index - 1; - - type Byte is mod 2 ** System.Storage_Unit; - - type Validity_Bits_Part is array (Validity_Byte_Index) of Byte; - type Validity_Bits_Part_Ref is access all Validity_Bits_Part; - No_Validity_Bits_Part : constant Validity_Bits_Part_Ref := null; - - type Validity_Bits is record - Valid : Validity_Bits_Part_Ref := No_Validity_Bits_Part; - -- True if chunk of memory at this address is currently allocated - - Handled : Validity_Bits_Part_Ref := No_Validity_Bits_Part; - -- True if chunk of memory at this address was allocated once after - -- Allow_Unhandled_Memory was set to True. Used to know on Deallocate - -- if chunk of memory should be handled a block allocated by this - -- package. - - end record; - - type Validity_Bits_Ref is access all Validity_Bits; - No_Validity_Bits : constant Validity_Bits_Ref := null; - - Max_Header_Num : constant := 1023; - - type Header_Num is range 0 .. Max_Header_Num - 1; - - function Hash (F : Integer_Address) return Header_Num; - - function Is_Valid_Or_Handled - (Storage : System.Address; - Valid : Boolean) return Boolean; - pragma Inline (Is_Valid_Or_Handled); - -- Internal implementation of Is_Valid and Is_Handled. - -- Valid is used to select Valid or Handled arrays. - - package Validy_Htable is new GNAT.HTable.Simple_HTable - (Header_Num => Header_Num, - Element => Validity_Bits_Ref, - No_Element => No_Validity_Bits, - Key => Integer_Address, - Hash => Hash, - Equal => "="); - -- Table to keep the validity and handled bit blocks for the allocated - -- data. - - function To_Pointer is new Ada.Unchecked_Conversion - (System.Address, Validity_Bits_Part_Ref); - - procedure Memset (A : Address; C : Integer; N : size_t); - pragma Import (C, Memset, "memset"); - - ---------- - -- Hash -- - ---------- - - function Hash (F : Integer_Address) return Header_Num is - begin - return Header_Num (F mod Max_Header_Num); - end Hash; - - ------------------------- - -- Is_Valid_Or_Handled -- - ------------------------- - - function Is_Valid_Or_Handled - (Storage : System.Address; - Valid : Boolean) return Boolean is - Int_Storage : constant Integer_Address := To_Integer (Storage); - - begin - -- The pool only returns addresses aligned on Storage_Alignment so - -- anything off cannot be a valid block address and we can return - -- early in this case. We actually have to since our data structures - -- map validity bits for such aligned addresses only. - - if Int_Storage mod Storage_Alignment /= 0 then - return False; - end if; - - declare - Block_Number : constant Integer_Address := - Int_Storage / Memory_Chunk_Size; - Ptr : constant Validity_Bits_Ref := - Validy_Htable.Get (Block_Number); - Offset : constant Integer_Address := - (Int_Storage - - (Block_Number * Memory_Chunk_Size)) / - Storage_Alignment; - Bit : constant Byte := - 2 ** Natural (Offset mod System.Storage_Unit); - begin - if Ptr = No_Validity_Bits then - return False; - else - if Valid then - return (Ptr.Valid (Offset / System.Storage_Unit) - and Bit) /= 0; - else - if Ptr.Handled = No_Validity_Bits_Part then - return False; - else - return (Ptr.Handled (Offset / System.Storage_Unit) - and Bit) /= 0; - end if; - end if; - end if; - end; - end Is_Valid_Or_Handled; - - -------------- - -- Is_Valid -- - -------------- - - function Is_Valid (Storage : System.Address) return Boolean is - begin - return Is_Valid_Or_Handled (Storage => Storage, Valid => True); - end Is_Valid; - - ----------------- - -- Is_Handled -- - ----------------- - - function Is_Handled (Storage : System.Address) return Boolean is - begin - return Is_Valid_Or_Handled (Storage => Storage, Valid => False); - end Is_Handled; - - --------------- - -- Set_Valid -- - --------------- - - procedure Set_Valid (Storage : System.Address; Value : Boolean) is - Int_Storage : constant Integer_Address := To_Integer (Storage); - Block_Number : constant Integer_Address := - Int_Storage / Memory_Chunk_Size; - Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number); - Offset : constant Integer_Address := - (Int_Storage - (Block_Number * Memory_Chunk_Size)) / - Storage_Alignment; - Bit : constant Byte := - 2 ** Natural (Offset mod System.Storage_Unit); - - procedure Set_Handled; - pragma Inline (Set_Handled); - -- if Allow_Unhandled_Memory set Handled bit in table. - - ----------------- - -- Set_Handled -- - ----------------- - - procedure Set_Handled is - begin - if Allow_Unhandled_Memory then - if Ptr.Handled = No_Validity_Bits_Part then - Ptr.Handled := - To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); - Memset - (A => Ptr.Handled.all'Address, - C => 0, - N => size_t (Max_Validity_Byte_Index)); - end if; - - Ptr.Handled (Offset / System.Storage_Unit) := - Ptr.Handled (Offset / System.Storage_Unit) or Bit; - end if; - end Set_Handled; - - -- Start of processing for Set_Valid - - begin - if Ptr = No_Validity_Bits then - - -- First time in this memory area: allocate a new block and put - -- it in the table. - - if Value then - Ptr := new Validity_Bits; - Validity_Count := Validity_Count + 1; - Ptr.Valid := - To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); - Validy_Htable.Set (Block_Number, Ptr); - Memset - (A => Ptr.Valid.all'Address, - C => 0, - N => size_t (Max_Validity_Byte_Index)); - Ptr.Valid (Offset / System.Storage_Unit) := Bit; - Set_Handled; - end if; - - else - if Value then - Ptr.Valid (Offset / System.Storage_Unit) := - Ptr.Valid (Offset / System.Storage_Unit) or Bit; - Set_Handled; - else - Ptr.Valid (Offset / System.Storage_Unit) := - Ptr.Valid (Offset / System.Storage_Unit) and (not Bit); - end if; - end if; - end Set_Valid; - end Validity; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Pool : in out Debug_Pool; - Storage_Address : out Address; - Size_In_Storage_Elements : Storage_Count; - Alignment : Storage_Count) - is - pragma Unreferenced (Alignment); - -- Ignored, we always force Storage_Alignment - - type Local_Storage_Array is new Storage_Array - (1 .. Size_In_Storage_Elements + Extra_Allocation); - - 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(). - - Current : Byte_Count; - P : Ptr; - Trace : Traceback_Htable_Elem_Ptr; - - Reset_Disable_At_Exit : Boolean := False; - - Lock : Scope_Lock; - pragma Unreferenced (Lock); - - begin - <> - - if Disable then - Storage_Address := - System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); - return; - end if; - - Reset_Disable_At_Exit := True; - Disable := True; - - Pool.Alloc_Count := Pool.Alloc_Count + 1; - - -- 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 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.Logically_Deallocated > - Byte_Count (Pool.Maximum_Logically_Freed_Memory) - then - Free_Physically (Pool); - end if; - - -- Use standard (i.e. 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. Note that we do not initialize the storage array since it - -- is not necessary to do so (however this will cause bogus valgrind - -- warnings, which should simply be ignored). - - begin - P := new Local_Storage_Array; - - exception - when Storage_Error => - Free_Physically (Pool); - P := new Local_Storage_Array; - end; - - -- Compute Storage_Address, aimed at receiving user data. We need room - -- for the allocation header just ahead of the user data space plus - -- alignment padding so Storage_Address is aligned on Storage_Alignment, - -- like so: - -- - -- Storage_Address, aligned - -- on Storage_Alignment - -- v - -- | ~~~~ | Header | User data ... | - -- ^........^ - -- Header_Offset - -- - -- Header_Offset is fixed so moving back and forth between user data - -- and allocation header is straightforward. The value is also such - -- that the header type alignment is honored when starting from - -- Default_alignment. - - -- For the purpose of computing Storage_Address, we just do as if the - -- header was located first, followed by the alignment padding: - - Storage_Address := - To_Address (Align (To_Integer (P.all'Address) + - Integer_Address (Header_Offset))); - -- Computation is done in Integer_Address, not Storage_Offset, because - -- the range of Storage_Offset may not be large enough. - - pragma Assert ((Storage_Address - System.Null_Address) - mod Storage_Alignment = 0); - pragma Assert (Storage_Address + Size_In_Storage_Elements - <= P.all'Address + P'Length); - - Trace := - Find_Or_Create_Traceback - (Pool => Pool, - Kind => Alloc, - Size => Size_In_Storage_Elements, - Ignored_Frame_Start => Allocate_Label'Address, - Ignored_Frame_End => 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 - -- Storage_Alignment. - - Header_Of (Storage_Address).all := - (Allocation_Address => P.all'Address, - 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); - - if Pool.Low_Level_Traces then - Put (Output_File (Pool), - "info: Allocated" - & Storage_Count'Image (Size_In_Storage_Elements) - & " bytes at "); - Print_Address (Output_File (Pool), Storage_Address); - Put (Output_File (Pool), - " (physically:" - & Storage_Count'Image (Local_Storage_Array'Length) - & " bytes at "); - Print_Address (Output_File (Pool), P.all'Address); - Put (Output_File (Pool), - "), at "); - Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Allocate_Label'Address, - Code_Address_For_Deallocate_End); - end if; - - -- Update internal data - - Pool.Allocated := - Pool.Allocated + Byte_Count (Size_In_Storage_Elements); - - Current := Pool.Current_Water_Mark; - - if Current > Pool.High_Water then - Pool.High_Water := Current; - end if; - - Disable := False; - - exception - when others => - if Reset_Disable_At_Exit then - Disable := False; - end if; - raise; - 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 - <> - 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 - not (Total_Freed > Pool.Minimum_To_Free - and Pool.Logically_Deallocated < - Byte_Count (Pool.Maximum_Logically_Freed_Memory)) - loop - Header := Header_Of (Tmp); - - -- If we know, or at least assume, the block is no longer - -- referenced 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; - - if Pool.Low_Level_Traces then - Put - (Output_File (Pool), - "info: Freeing physical memory " - & Storage_Count'Image - ((abs Header.Block_Size) + Extra_Allocation) - & " bytes at "); - Print_Address (Output_File (Pool), - Header.Allocation_Address); - Put_Line (Output_File (Pool), ""); - end if; - - if System_Memory_Debug_Pool_Enabled then - System.CRTL.free (Header.Allocation_Address); - else - System.Memory.Free (Header.Allocation_Address); - end if; - - 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 - To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark); - 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; - - Lock : Scope_Lock; - pragma Unreferenced (Lock); - - -- Start of processing for Free_Physically - - begin - if Pool.Advanced_Scanning then - - -- Reset the mark for each freed block - - Reset_Marks; - - 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; - end Free_Physically; - - -------------- - -- Get_Size -- - -------------- - - procedure Get_Size - (Storage_Address : Address; - Size_In_Storage_Elements : out Storage_Count; - Valid : out Boolean) - is - Lock : Scope_Lock; - pragma Unreferenced (Lock); - - begin - Valid := Is_Valid (Storage_Address); - - if Is_Valid (Storage_Address) then - declare - Header : constant Allocation_Header_Access := - Header_Of (Storage_Address); - - begin - if Header.Block_Size >= 0 then - Valid := True; - Size_In_Storage_Elements := Header.Block_Size; - else - Valid := False; - end if; - end; - else - Valid := False; - end if; - end Get_Size; - - --------------------- - -- Print_Traceback -- - --------------------- - - procedure Print_Traceback - (Output_File : File_Type; - Prefix : String; - Traceback : Traceback_Htable_Elem_Ptr) - is - begin - if Traceback /= null then - Put (Output_File, Prefix); - Put_Line (Output_File, 0, Traceback.Traceback); - end if; - end Print_Traceback; - - ---------------- - -- Deallocate -- - ---------------- - - procedure Deallocate - (Pool : in out Debug_Pool; - Storage_Address : Address; - Size_In_Storage_Elements : Storage_Count; - Alignment : Storage_Count) - is - pragma Unreferenced (Alignment); - - Header : constant Allocation_Header_Access := - Header_Of (Storage_Address); - Previous : System.Address; - Valid : Boolean; - - Header_Block_Size_Was_Less_Than_0 : Boolean := True; - - begin - <> - - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - - begin - Valid := Is_Valid (Storage_Address); - - if Valid and then not (Header.Block_Size < 0) then - Header_Block_Size_Was_Less_Than_0 := False; - - -- Some sort of codegen problem or heap corruption caused the - -- Size_In_Storage_Elements to be wrongly computed. The code - -- below is all based on the assumption that Header.all is not - -- corrupted, such that the error is non-fatal. - - if Header.Block_Size /= Size_In_Storage_Elements and then - Size_In_Storage_Elements /= Storage_Count'Last - then - Put_Line (Output_File (Pool), - "error: Deallocate size " - & Storage_Count'Image (Size_In_Storage_Elements) - & " does not match allocate size " - & Storage_Count'Image (Header.Block_Size)); - end if; - - if Pool.Low_Level_Traces then - Put (Output_File (Pool), - "info: Deallocated" - & Storage_Count'Image (Header.Block_Size) - & " bytes at "); - Print_Address (Output_File (Pool), Storage_Address); - Put (Output_File (Pool), - " (physically" - & Storage_Count'Image - (Header.Block_Size + Extra_Allocation) - & " bytes at "); - Print_Address (Output_File (Pool), Header.Allocation_Address); - Put (Output_File (Pool), "), at "); - - Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); - Print_Traceback (Output_File (Pool), - " Memory was allocated at ", - Header.Alloc_Traceback); - end if; - - -- Remove this block from the list of used blocks - - Previous := - To_Address (Header.Dealloc_Traceback); - - if Previous = System.Null_Address then - Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; - - if Pool.First_Used_Block /= System.Null_Address then - Header_Of (Pool.First_Used_Block).Dealloc_Traceback := - To_Traceback (null); - end if; - - else - Header_Of (Previous).Next := Header.Next; - - if Header.Next /= System.Null_Address then - Header_Of - (Header.Next).Dealloc_Traceback := To_Address (Previous); - end if; - end if; - - -- Update the Alloc_Traceback Frees/Total_Frees members - -- (if present) - - if Header.Alloc_Traceback /= null then - Header.Alloc_Traceback.Frees := - Header.Alloc_Traceback.Frees + 1; - Header.Alloc_Traceback.Total_Frees := - Header.Alloc_Traceback.Total_Frees + - Byte_Count (Header.Block_Size); - end if; - - Pool.Free_Count := Pool.Free_Count + 1; - - -- Update the header - - Header.all := - (Allocation_Address => Header.Allocation_Address, - Alloc_Traceback => Header.Alloc_Traceback, - Dealloc_Traceback => To_Traceback - (Find_Or_Create_Traceback - (Pool, Dealloc, - Header.Block_Size, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End)), - Next => System.Null_Address, - Block_Size => -Header.Block_Size); - - if Pool.Reset_Content_On_Free then - Set_Dead_Beef (Storage_Address, -Header.Block_Size); - end if; - - Pool.Logically_Deallocated := - Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); - - -- 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. - end if; - end; - - if not Valid then - if Storage_Address = System.Null_Address then - if Pool.Raise_Exceptions and then - Size_In_Storage_Elements /= Storage_Count'Last - then - raise Freeing_Not_Allocated_Storage; - else - Put (Output_File (Pool), - "error: Freeing Null_Address, at "); - Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); - return; - end if; - end if; - - if Allow_Unhandled_Memory - and then not Is_Handled (Storage_Address) - then - System.CRTL.free (Storage_Address); - return; - end if; - - if Pool.Raise_Exceptions - and then Size_In_Storage_Elements /= Storage_Count'Last - then - raise Freeing_Not_Allocated_Storage; - else - Put (Output_File (Pool), - "error: Freeing not allocated storage, at "); - Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); - end if; - - elsif Header_Block_Size_Was_Less_Than_0 then - if Pool.Raise_Exceptions then - raise Freeing_Deallocated_Storage; - else - Put (Output_File (Pool), - "error: Freeing already deallocated storage, at "); - Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Deallocate_Label'Address, - Code_Address_For_Deallocate_End); - Print_Traceback (Output_File (Pool), - " Memory already deallocated at ", - To_Traceback (Header.Dealloc_Traceback)); - Print_Traceback (Output_File (Pool), " Memory was allocated at ", - Header.Alloc_Traceback); - end if; - end if; - end Deallocate; - - -------------------- - -- Deallocate_End -- - -------------------- - - -- DO NOT MOVE, this must be right after Deallocate - - -- See Allocate_End - - -- This is making assumptions about code order that may be invalid ??? - - procedure Deallocate_End is - begin - <> - Code_Address_For_Deallocate_End := Deallocate_End_Label'Address; - end Deallocate_End; - - ----------------- - -- Dereference -- - ----------------- - - procedure Dereference - (Pool : in out Debug_Pool; - Storage_Address : Address; - Size_In_Storage_Elements : Storage_Count; - Alignment : Storage_Count) - is - pragma Unreferenced (Alignment, Size_In_Storage_Elements); - - 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 not Valid then - if Pool.Raise_Exceptions then - raise Accessing_Not_Allocated_Storage; - else - Put (Output_File (Pool), - "error: Accessing not allocated storage, at "); - Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Dereference_Label'Address, - Code_Address_For_Dereference_End); - end if; - - else - Header := Header_Of (Storage_Address); - - if Header.Block_Size < 0 then - if Pool.Raise_Exceptions then - raise Accessing_Deallocated_Storage; - else - Put (Output_File (Pool), - "error: Accessing deallocated storage, at "); - Put_Line - (Output_File (Pool), Pool.Stack_Trace_Depth, null, - Dereference_Label'Address, - Code_Address_For_Dereference_End); - Print_Traceback (Output_File (Pool), " First deallocation at ", - To_Traceback (Header.Dealloc_Traceback)); - Print_Traceback (Output_File (Pool), " Initial allocation at ", - Header.Alloc_Traceback); - end if; - end if; - end if; - end Dereference; - - --------------------- - -- Dereference_End -- - --------------------- - - -- DO NOT MOVE: this must be right after Dereference - - -- See Allocate_End - - -- This is making assumptions about code order that may be invalid ??? - - procedure Dereference_End is - begin - <> - Code_Address_For_Dereference_End := Dereference_End_Label'Address; - end Dereference_End; - - ---------------- - -- Print_Info -- - ---------------- - - procedure Print_Info - (Pool : Debug_Pool; - Cumulate : Boolean := False; - Display_Slots : Boolean := False; - Display_Leaks : Boolean := False) - is - 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??? - - Current : System.Address; - Data : Traceback_Htable_Elem_Ptr; - Elem : Traceback_Htable_Elem_Ptr; - Header : Allocation_Header_Access; - K : Traceback_Kind; - - begin - Put_Line - ("Total allocated bytes : " & - Byte_Count'Image (Pool.Allocated)); - - Put_Line - ("Total logically deallocated bytes : " & - Byte_Count'Image (Pool.Logically_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 dangerous, 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.Current_Water_Mark)); - - Put_Line - ("High Water Mark: " & - Byte_Count'Image (Pool.High_Water)); - - Put_Line (""); - - if Display_Slots then - 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, - Frees => Data.Frees, - Total_Frees => Data.Total_Frees, - Next => null); - Backtrace_Htable_Cumulate.Set (Elem); - - if Cumulate then - K := (if Data.Kind = Alloc then Indirect_Alloc - else Indirect_Dealloc); - - -- 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, - Frees => Data.Frees, - Total_Frees => Data.Total_Frees, - 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; - - 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 (Image_C (PC_For (Data.Traceback (T))) & ' '); - end loop; - - Put_Line (""); - - Data := Backtrace_Htable_Cumulate.Get_Next; - end loop; - - Backtrace_Htable_Cumulate.Reset; - 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: "); - - if Header.Alloc_Traceback /= null then - for T in Header.Alloc_Traceback.Traceback'Range loop - Put (Image_C - (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); - end loop; - end if; - - Put_Line (""); - Current := Header.Next; - end loop; - end if; - end Print_Info; - - ---------- - -- Dump -- - ---------- - - procedure Dump - (Pool : Debug_Pool; - Size : Positive; - Report : Report_Type := All_Reports) - is - procedure Do_Report (Sort : Report_Type); - -- Do a specific type of report - - --------------- - -- Do_Report -- - --------------- - - procedure Do_Report (Sort : Report_Type) is - Elem : Traceback_Htable_Elem_Ptr; - Bigger : Boolean; - Grand_Total : Float; - - Max : array (1 .. Size) of Traceback_Htable_Elem_Ptr := - (others => null); - -- Sorted array for the biggest memory users - - Allocated_In_Pool : Byte_Count; - -- safe thread Pool.Allocated - - Elem_Safe : Traceback_Htable_Elem; - -- safe thread current elem.all; - - Max_M_Safe : Traceback_Htable_Elem; - -- safe thread Max(M).all - - begin - Put_Line (""); - - case Sort is - when All_Reports - | Memory_Usage - => - Put_Line (Size'Img & " biggest memory users at this time:"); - Put_Line ("Results include bytes and chunks still allocated"); - Grand_Total := Float (Pool.Current_Water_Mark); - - when Allocations_Count => - Put_Line (Size'Img & " biggest number of live allocations:"); - Put_Line ("Results include bytes and chunks still allocated"); - Grand_Total := Float (Pool.Current_Water_Mark); - - when Sort_Total_Allocs => - Put_Line (Size'Img & " biggest number of allocations:"); - Put_Line ("Results include total bytes and chunks allocated,"); - Put_Line ("even if no longer allocated - Deallocations are" - & " ignored"); - - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Allocated_In_Pool := Pool.Allocated; - end; - - Grand_Total := Float (Allocated_In_Pool); - - when Marked_Blocks => - Put_Line ("Special blocks marked by Mark_Traceback"); - Grand_Total := 0.0; - end case; - - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Elem := Backtrace_Htable.Get_First; - end; - - while Elem /= null loop - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Elem_Safe := Elem.all; - end; - - -- Handle only alloc elememts - if Elem_Safe.Kind = Alloc then - -- Ignore small blocks (depending on the sorting criteria) to - -- gain speed. - - if (Sort = Memory_Usage - and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) - or else (Sort = Allocations_Count - and then Elem_Safe.Count - Elem_Safe.Frees >= 1) - or else (Sort = Sort_Total_Allocs - and then Elem_Safe.Count > 1) - or else (Sort = Marked_Blocks - and then Elem_Safe.Total = 0) - then - if Sort = Marked_Blocks then - Grand_Total := Grand_Total + Float (Elem_Safe.Count); - end if; - - for M in Max'Range loop - Bigger := Max (M) = null; - if not Bigger then - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Max_M_Safe := Max (M).all; - end; - - case Sort is - when All_Reports - | Memory_Usage - => - Bigger := - Max_M_Safe.Total - Max_M_Safe.Total_Frees - < Elem_Safe.Total - Elem_Safe.Total_Frees; - - when Allocations_Count => - Bigger := - Max_M_Safe.Count - Max_M_Safe.Frees - < Elem_Safe.Count - Elem_Safe.Frees; - - when Marked_Blocks - | Sort_Total_Allocs - => - Bigger := Max_M_Safe.Count < Elem_Safe.Count; - end case; - end if; - - if Bigger then - Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1); - Max (M) := Elem; - exit; - end if; - end loop; - end if; - end if; - - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Elem := Backtrace_Htable.Get_Next; - end; - end loop; - - if Grand_Total = 0.0 then - Grand_Total := 1.0; - end if; - - for M in Max'Range loop - exit when Max (M) = null; - declare - type Percent is delta 0.1 range 0.0 .. 100.0; - - P : Percent; - Total : Byte_Count; - - begin - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Max_M_Safe := Max (M).all; - end; - - case Sort is - when All_Reports - | Allocations_Count - | Memory_Usage - => - Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees; - - when Sort_Total_Allocs => - Total := Max_M_Safe.Total; - - when Marked_Blocks => - Total := Byte_Count (Max_M_Safe.Count); - end case; - - declare - Normalized_Total : constant Float := Float (Total); - -- In multi tasking configuration, memory deallocations - -- during Do_Report processing can lead to Total > - -- Grand_Total. As Percent requires Total <= Grand_Total - - begin - if Normalized_Total > Grand_Total then - P := 100.0; - else - P := Percent (100.0 * Normalized_Total / Grand_Total); - end if; - end; - - case Sort is - when All_Reports - | Allocations_Count - | Memory_Usage - => - declare - Count : constant Natural := - Max_M_Safe.Count - Max_M_Safe.Frees; - begin - Put (P'Img & "%:" & Total'Img & " bytes in" - & Count'Img & " chunks at"); - end; - - when Sort_Total_Allocs => - Put (P'Img & "%:" & Total'Img & " bytes in" - & Max_M_Safe.Count'Img & " chunks at"); - - when Marked_Blocks => - Put (P'Img & "%:" - & Max_M_Safe.Count'Img & " chunks /" - & Integer (Grand_Total)'Img & " at"); - end case; - end; - - for J in Max (M).Traceback'Range loop - Put (" " & Image_C (PC_For (Max (M).Traceback (J)))); - end loop; - - Put_Line (""); - end loop; - end Do_Report; - - -- Local variables - - Total_Freed : Byte_Count; - -- safe thread pool logically & physically deallocated - - Traceback_Elements_Allocated : Byte_Count; - -- safe thread Traceback_Count - - Validity_Elements_Allocated : Byte_Count; - -- safe thread Validity_Count - - Ada_Allocs_Bytes : Byte_Count; - -- safe thread pool Allocated - - Ada_Allocs_Chunks : Byte_Count; - -- safe thread pool Alloc_Count - - Ada_Free_Chunks : Byte_Count; - -- safe thread pool Free_Count - - -- Start of processing for Dump - - begin - declare - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Total_Freed := - Pool.Logically_Deallocated + Pool.Physically_Deallocated; - Traceback_Elements_Allocated := Traceback_Count; - Validity_Elements_Allocated := Validity_Count; - Ada_Allocs_Bytes := Pool.Allocated; - Ada_Allocs_Chunks := Pool.Alloc_Count; - Ada_Free_Chunks := Pool.Free_Count; - end; - - Put_Line - ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img); - Put_Line - ("Validity elements allocated: " & Validity_Elements_Allocated'Img); - Put_Line (""); - - Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img - & " bytes in" & Ada_Allocs_Chunks'Img & " chunks"); - Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & - Ada_Free_Chunks'Img - & " chunks"); - Put_Line ("Ada Current watermark: " - & Byte_Count'Image (Pool.Current_Water_Mark) - & " in" & Byte_Count'Image (Ada_Allocs_Chunks - - Ada_Free_Chunks) & " chunks"); - Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); - - case Report is - when All_Reports => - for Sort in Report_Type loop - if Sort /= All_Reports then - Do_Report (Sort); - end if; - end loop; - - when others => - Do_Report (Report); - end case; - end Dump; - - ----------------- - -- Dump_Stdout -- - ----------------- - - procedure Dump_Stdout - (Pool : Debug_Pool; - Size : Positive; - Report : Report_Type := All_Reports) - is - procedure Internal is new Dump - (Put_Line => Stdout_Put_Line, - Put => Stdout_Put); - - -- Start of processing for Dump_Stdout - - begin - Internal (Pool, Size, Report); - end Dump_Stdout; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - Elem : Traceback_Htable_Elem_Ptr; - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - Elem := Backtrace_Htable.Get_First; - while Elem /= null loop - Elem.Count := 0; - Elem.Frees := 0; - Elem.Total := 0; - Elem.Total_Frees := 0; - Elem := Backtrace_Htable.Get_Next; - end loop; - end Reset; - - ------------------ - -- Storage_Size -- - ------------------ - - function Storage_Size (Pool : Debug_Pool) return Storage_Count is - pragma Unreferenced (Pool); - begin - return Storage_Count'Last; - end Storage_Size; - - --------------------- - -- High_Water_Mark -- - --------------------- - - function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - return Pool.High_Water; - end High_Water_Mark; - - ------------------------ - -- Current_Water_Mark -- - ------------------------ - - function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - return Pool.Allocated - Pool.Logically_Deallocated - - Pool.Physically_Deallocated; - end Current_Water_Mark; - - ------------------------------ - -- System_Memory_Debug_Pool -- - ------------------------------ - - procedure System_Memory_Debug_Pool - (Has_Unhandled_Memory : Boolean := True) - is - Lock : Scope_Lock; - pragma Unreferenced (Lock); - begin - System_Memory_Debug_Pool_Enabled := True; - Allow_Unhandled_Memory := Has_Unhandled_Memory; - end System_Memory_Debug_Pool; - - --------------- - -- 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; - Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; - Low_Level_Traces : Boolean := Default_Low_Level_Traces) - is - Lock : Scope_Lock; - pragma Unreferenced (Lock); - 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; - Pool.Errors_To_Stdout := Errors_To_Stdout; - Pool.Low_Level_Traces := Low_Level_Traces; - 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 - (Standard_Output, "Memory not under control of the storage pool"); - return; - end if; - - if not Valid then - Put_Line - (Standard_Output, "Memory not under control of the storage pool"); - - else - Header := Header_Of (Storage); - Print_Address (Standard_Output, A); - Put_Line (Standard_Output, " allocated at:"); - Print_Traceback (Standard_Output, "", Header.Alloc_Traceback); - - if To_Traceback (Header.Dealloc_Traceback) /= null then - Print_Address (Standard_Output, A); - Put_Line (Standard_Output, - " logically freed memory, deallocated at:"); - Print_Traceback (Standard_Output, "", - To_Traceback (Header.Dealloc_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 => Stdout_Put_Line, - Put => Stdout_Put); - - -- Start of processing for Print_Info_Stdout - - 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; - Dummy_Time : Duration := 1.0; - - begin - File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); - fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); - - fwrite - (Ptr => Dummy_Time'Address, - Size => Duration'Max_Size_In_Storage_Elements, - Nmemb => 1, - Stream => 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); - - if Header.Alloc_Traceback /= null then - Tracebk := Header.Alloc_Traceback.Traceback; - Num_Calls := Tracebk'Length; - - -- (Code taken from memtrack.adb in GNAT's sources) - - -- Logs allocation call using the format: - - -- 'A' ... - - fputc (Character'Pos ('A'), File); - fwrite (Current'Address, Address_Size, 1, File); - - fwrite - (Ptr => Actual_Size'Address, - Size => size_t'Max_Size_In_Storage_Elements, - Nmemb => 1, - Stream => File); - - fwrite - (Ptr => Dummy_Time'Address, - Size => Duration'Max_Size_In_Storage_Elements, - Nmemb => 1, - Stream => File); - - fwrite - (Ptr => Num_Calls'Address, - Size => Integer'Max_Size_In_Storage_Elements, - Nmemb => 1, - Stream => 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; - end if; - - Current := Header.Next; - end loop; - - fclose (File); - end Dump_Gnatmem; - - ---------------- - -- Stdout_Put -- - ---------------- - - procedure Stdout_Put (S : String) is - begin - Put (Standard_Output, S); - end Stdout_Put; - - --------------------- - -- Stdout_Put_Line -- - --------------------- - - procedure Stdout_Put_Line (S : String) is - begin - Put_Line (Standard_Output, S); - end Stdout_Put_Line; - --- Package initialization - -begin - Allocate_End; - Deallocate_End; - Dereference_End; -end GNAT.Debug_Pools; diff --git a/gcc/ada/g-debpoo.ads b/gcc/ada/g-debpoo.ads deleted file mode 100644 index 108422a..0000000 --- a/gcc/ada/g-debpoo.ads +++ /dev/null @@ -1,409 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D E B U G _ P O O L S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This packages provides a special implementation of the Ada 95 storage pools - --- The goal of this debug pool is to detect incorrect uses of memory --- (multiple deallocations, access to invalid memory,...). Errors are reported --- in one of two ways: either by immediately raising an exception, or by --- printing a message on standard output or standard error. - --- You need to instrument your code to use this package: for each access type --- you want to monitor, you need to add a clause similar to: - --- type Integer_Access is access Integer; --- for Integer_Access'Storage_Pool use Pool; - --- where Pool is a tagged object declared with --- --- Pool : GNAT.Debug_Pools.Debug_Pool; - --- This package was designed to be as efficient as possible, but still has an --- impact on the performance of your code, which depends on the number of --- allocations, deallocations and, somewhat less, dereferences that your --- application performs. - --- For each faulty memory use, this debug pool will print several lines --- of information, including things like the location where the memory --- was initially allocated, the location where it was freed etc. - --- Physical allocations and deallocations are done through the usual system --- calls. However, in order to provide proper checks, the debug pool will not --- release the memory immediately. It keeps released memory around (the amount --- kept around is configurable) so that it can distinguish between memory that --- has not been allocated and memory that has been allocated but freed. This --- also means that this memory cannot be reallocated, preventing what would --- otherwise be a false indication that freed memory is now allocated. - --- In addition, this package presents several subprograms that help analyze --- the behavior of your program, by reporting memory leaks, the total amount --- of memory that was allocated. The pool is also designed to work correctly --- in conjunction with gnatmem. - --- Finally, a subprogram Print_Pool is provided for use from the debugger - --- Limitations --- =========== - --- Current limitation of this debug pool: if you use this debug pool for a --- general access type ("access all"), the pool might report invalid --- dereferences if the access object is pointing to another object on the --- stack which was not allocated through a call to "new". - --- This debug pool will respect all alignments specified in your code, but --- it does that by aligning all objects using Standard'Maximum_Alignment. --- This allows faster checks, and limits the performance impact of using --- this pool. - -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; -with System.Checked_Pools; - -package GNAT.Debug_Pools is - - type Debug_Pool is new System.Checked_Pools.Checked_Pool with private; - -- The new debug pool - - subtype SSC is System.Storage_Elements.Storage_Count; - - Default_Max_Freed : constant SSC := 50_000_000; - Default_Stack_Trace_Depth : constant Natural := 20; - Default_Reset_Content : constant Boolean := False; - Default_Raise_Exceptions : constant Boolean := True; - Default_Advanced_Scanning : constant Boolean := False; - Default_Min_Freed : constant SSC := 0; - Default_Errors_To_Stdout : constant Boolean := True; - Default_Low_Level_Traces : constant Boolean := False; - -- The above values are constants used for the parameters to Configure - -- if not overridden in the call. See description of Configure for full - -- details on these parameters. If these defaults are not satisfactory, - -- then you need to call Configure to change the default values. - - 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; - Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; - Low_Level_Traces : Boolean := Default_Low_Level_Traces); - -- Subprogram used to configure the debug pool. - -- - -- Stack_Trace_Depth. This parameter controls the maximum depth of stack - -- traces that are output to indicate locations of actions for error - -- conditions such as bad allocations. If set to zero, the debug pool - -- will not try to compute backtraces. This is more efficient but gives - -- less information on problem locations - -- - -- Maximum_Logically_Freed_Memory: maximum amount of memory (bytes) - -- that should be kept before starting to physically deallocate some. - -- This value should be non-zero, since having memory that is logically - -- but not physically freed helps to detect invalid memory accesses. - -- - -- Minimum_To_Free is the minimum amount of memory that should be freed - -- every time the pool starts physically releasing memory. The algorithm - -- to compute which block should be physically released needs some - -- expensive initialization (see Advanced_Scanning below), and this - -- parameter can be used to limit the performance impact by ensuring - -- that a reasonable amount of memory is freed each time. Even in the - -- advanced scanning mode, marked blocks may be released to match this - -- Minimum_To_Free parameter. - -- - -- Reset_Content_On_Free: If true, then the contents of the freed memory - -- is reset to the pattern 16#DEADBEEF#, following an old IBM convention. - -- This helps in detecting invalid memory references from the debugger. - -- - -- Raise_Exceptions: If true, the exceptions below will be raised every - -- time an error is detected. If you set this to False, then the action - -- is to generate output on standard error or standard output, depending - -- on Errors_To_Stdout, noting the errors, but to - -- keep running if possible (of course if storage is badly damaged, this - -- attempt may fail. This helps to detect more than one error in a run. - -- - -- Advanced_Scanning: If true, the pool will check the contents of all - -- allocated blocks before physically releasing memory. Any possible - -- reference to a logically free block will prevent its deallocation. - -- Note that this algorithm is approximate, and it is recommended - -- that you set Minimum_To_Free to a non-zero value to save time. - -- - -- Errors_To_Stdout: Errors messages will be displayed on stdout if - -- this parameter is True, or to stderr otherwise. - -- - -- Low_Level_Traces: Traces all allocation and deallocations on the - -- stream specified by Errors_To_Stdout. This can be used for - -- post-processing by your own application, or to debug the - -- debug_pool itself. The output indicates the size of the allocated - -- block both as requested by the application and as physically - -- allocated to fit the additional information needed by the debug - -- pool. - -- - -- All instantiations of this pool use the same internal tables. However, - -- they do not store the same amount of information for the tracebacks, - -- and they have different counters for maximum logically freed memory. - - Accessing_Not_Allocated_Storage : exception; - -- Exception raised if Raise_Exception is True, and an attempt is made - -- to access storage that was never allocated. - - Accessing_Deallocated_Storage : exception; - -- Exception raised if Raise_Exception is True, and an attempt is made - -- to access storage that was allocated but has been deallocated. - - Freeing_Not_Allocated_Storage : exception; - -- Exception raised if Raise_Exception is True, and an attempt is made - -- to free storage that had not been previously allocated. - - Freeing_Deallocated_Storage : exception; - -- Exception raised if Raise_Exception is True, and an attempt is made - -- to free storage that had already been freed. - - -- Note on the above exceptions. The distinction between not allocated - -- and deallocated storage is not guaranteed to be accurate in the case - -- where storage is allocated, and then physically freed. Larger values - -- of the parameter Maximum_Logically_Freed_Memory will help to guarantee - -- that this distinction is made more accurately. - - generic - with procedure Put_Line (S : String) is <>; - with procedure Put (S : String) is <>; - procedure Print_Info - (Pool : Debug_Pool; - Cumulate : Boolean := False; - Display_Slots : Boolean := False; - Display_Leaks : Boolean := False); - -- Print out information about the High Water Mark, the current and - -- total number of bytes allocated and the total number of bytes - -- deallocated. - -- - -- If Display_Slots is true, this subprogram prints a list of all the - -- locations in the application that have done at least one allocation or - -- deallocation. The result might be used to detect places in the program - -- where lots of allocations are taking place. This output is not in any - -- defined order. - -- - -- If Cumulate if True, then each stack trace will display the number of - -- allocations that were done either directly, or by the subprograms called - -- at that location (e.g: if there were two physical allocations at a->b->c - -- and a->b->d, then a->b would be reported as performing two allocations). - -- - -- If Display_Leaks is true, then each block that has not been deallocated - -- (often called a "memory leak") will be listed, along with the traceback - -- showing where it was allocated. Not that no grouping of the blocks is - -- done, you should use the Dump_Gnatmem procedure below in conjunction - -- with the gnatmem utility. - - procedure Print_Info_Stdout - (Pool : Debug_Pool; - Cumulate : Boolean := False; - Display_Slots : Boolean := False; - Display_Leaks : Boolean := False); - -- Standard instantiation of Print_Info to print on standard_output. More - -- convenient to use where this is the intended location, and in particular - -- easier to use from the debugger. - - procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String); - -- Create an external file on the disk, which can be processed by gnatmem - -- to display the location of memory leaks. - -- - -- This provides a nicer output that Print_Info above, and groups similar - -- stack traces together. This also provides an easy way to save the memory - -- status of your program for post-mortem analysis. - -- - -- To use this file, use the following command line: - -- gnatmem 5 -i - -- If you want all the stack traces to be displayed with 5 levels. - - procedure Print_Pool (A : System.Address); - pragma Export (C, Print_Pool, "print_pool"); - -- This subprogram is meant to be used from a debugger. Given an address in - -- memory, it will print on standard output the known information about - -- this address (provided, of course, the matching pointer is handled by - -- the Debug_Pool). - -- - -- The information includes the stacktrace for the allocation or - -- deallocation of that memory chunk, its current status (allocated or - -- logically freed), etc. - - type Report_Type is - (All_Reports, - Memory_Usage, - Allocations_Count, - Sort_Total_Allocs, - Marked_Blocks); - for Report_Type use - (All_Reports => 0, - Memory_Usage => 1, - Allocations_Count => 2, - Sort_Total_Allocs => 3, - Marked_Blocks => 4); - - generic - with procedure Put_Line (S : String) is <>; - with procedure Put (S : String) is <>; - procedure Dump - (Pool : Debug_Pool; - Size : Positive; - Report : Report_Type := All_Reports); - -- Dump information about memory usage. - -- Size is the number of the biggest memory users we want to show. Report - -- indicates which sorting order is used in the report. - - procedure Dump_Stdout - (Pool : Debug_Pool; - Size : Positive; - Report : Report_Type := All_Reports); - -- Standard instantiation of Dump to print on standard_output. More - -- convenient to use where this is the intended location, and in particular - -- easier to use from the debugger. - - procedure Reset; - -- Reset all internal data. This is in general not needed, unless you want - -- to know what memory is used by specific parts of your application - - procedure Get_Size - (Storage_Address : Address; - Size_In_Storage_Elements : out Storage_Count; - Valid : out Boolean); - -- Set Valid if Storage_Address is the address of a chunk of memory - -- currently allocated by any pool. - -- If Valid is True, Size_In_Storage_Elements is set to the size of this - -- chunk of memory. - - type Byte_Count is mod System.Max_Binary_Modulus; - -- Type used for maintaining byte counts, needs to be large enough to - -- to accommodate counts allowing for repeated use of the same memory. - - function High_Water_Mark - (Pool : Debug_Pool) return Byte_Count; - -- Return the highest size of the memory allocated by the pool. - -- Memory used internally by the pool is not taken into account. - - function Current_Water_Mark - (Pool : Debug_Pool) return Byte_Count; - -- Return the size of the memory currently allocated by the pool. - -- Memory used internally by the pool is not taken into account. - - procedure System_Memory_Debug_Pool - (Has_Unhandled_Memory : Boolean := True); - -- Let the package know the System.Memory is using it. - -- If Has_Unhandled_Memory is true, some deallocation can be done for - -- memory not allocated with Allocate. - -private - -- The following are the standard primitive subprograms for a pool - - procedure Allocate - (Pool : in out Debug_Pool; - Storage_Address : out Address; - Size_In_Storage_Elements : Storage_Count; - Alignment : Storage_Count); - -- Allocate a new chunk of memory, and set it up so that the debug pool - -- can check accesses to its data, and report incorrect access later on. - -- The parameters have the same semantics as defined in the ARM95. - - procedure Deallocate - (Pool : in out Debug_Pool; - Storage_Address : Address; - Size_In_Storage_Elements : Storage_Count; - Alignment : Storage_Count); - -- Mark a block of memory as invalid. It might not be physically removed - -- immediately, depending on the setup of the debug pool, so that checks - -- are still possible. The parameters have the same semantics as defined - -- in the RM. - - function Storage_Size (Pool : Debug_Pool) return SSC; - -- Return the maximal size of data that can be allocated through Pool. - -- Since Pool uses the malloc() system call, all the memory is accessible - -- through the pool - - procedure Dereference - (Pool : in out Debug_Pool; - Storage_Address : System.Address; - Size_In_Storage_Elements : Storage_Count; - Alignment : Storage_Count); - -- Check whether a dereference statement is valid, i.e. whether the pointer - -- was allocated through Pool. As documented above, errors will be - -- reported either by a special error message or an exception, depending - -- on the setup of the storage pool. - -- The parameters have the same semantics as defined in the ARM95. - - type Debug_Pool is new System.Checked_Pools.Checked_Pool with record - Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; - Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; - Reset_Content_On_Free : Boolean := Default_Reset_Content; - Raise_Exceptions : Boolean := Default_Raise_Exceptions; - Minimum_To_Free : SSC := Default_Min_Freed; - Advanced_Scanning : Boolean := Default_Advanced_Scanning; - Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; - Low_Level_Traces : Boolean := Default_Low_Level_Traces; - - Alloc_Count : Byte_Count := 0; - -- Total number of allocation - - Free_Count : Byte_Count := 0; - -- Total number of deallocation - - Allocated : Byte_Count := 0; - -- Total number of bytes allocated in this pool - - Logically_Deallocated : Byte_Count := 0; - -- Total number of bytes logically deallocated in this pool. This is the - -- memory that the application has released, but that the pool has not - -- yet physically released through a call to free(), to detect later - -- accessed to deallocated memory. - - Physically_Deallocated : Byte_Count := 0; - -- Total number of bytes that were free()-ed - - Marked_Blocks_Deallocated : Boolean := False; - -- Set to true if some mark blocks had to be deallocated in the advanced - -- scanning scheme. Since this is potentially dangerous, this is - -- reported to the user, who might want to rerun his program with a - -- lower Minimum_To_Free value. - - High_Water : Byte_Count := 0; - -- Maximum of Allocated - Logically_Deallocated - Physically_Deallocated - - First_Free_Block : System.Address := System.Null_Address; - Last_Free_Block : System.Address := System.Null_Address; - -- Pointers to the first and last logically freed blocks - - First_Used_Block : System.Address := System.Null_Address; - -- Pointer to the list of currently allocated blocks. This list is - -- used to list the memory leaks in the application on exit, as well as - -- for the advanced freeing algorithms that needs to traverse all these - -- blocks to find possible references to the block being physically - -- freed. - - end record; -end GNAT.Debug_Pools; diff --git a/gcc/ada/g-debuti.adb b/gcc/ada/g-debuti.adb deleted file mode 100644 index 8a40e99..0000000 --- a/gcc/ada/g-debuti.adb +++ /dev/null @@ -1,188 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . D E B U G _ U T I L I T I E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; - -package body GNAT.Debug_Utilities is - - H : constant array (0 .. 15) of Character := "0123456789ABCDEF"; - -- Table of hex digits - - ----------- - -- Image -- - ----------- - - -- Address case - - function Image (A : Address) return Image_String is - S : Image_String; - P : Natural; - N : Integer_Address; - U : Natural := 0; - - begin - S (S'Last) := '#'; - P := Address_Image_Length - 1; - N := To_Integer (A); - while P > 3 loop - if U = 4 then - S (P) := '_'; - P := P - 1; - U := 1; - - else - U := U + 1; - end if; - - S (P) := H (Integer (N mod 16)); - P := P - 1; - N := N / 16; - end loop; - - S (1 .. 3) := "16#"; - return S; - end Image; - - ----------- - -- Image -- - ----------- - - -- String case - - function Image (S : String) return String is - W : String (1 .. 2 * S'Length + 2); - P : Positive := 1; - - begin - W (1) := '"'; - - for J in S'Range loop - if S (J) = '"' then - P := P + 1; - W (P) := '"'; - end if; - - P := P + 1; - W (P) := S (J); - end loop; - - P := P + 1; - W (P) := '"'; - return W (1 .. P); - end Image; - - ------------- - -- Image_C -- - ------------- - - function Image_C (A : Address) return Image_C_String is - S : Image_C_String; - N : Integer_Address := To_Integer (A); - - begin - for P in reverse 3 .. S'Last loop - S (P) := H (Integer (N mod 16)); - N := N / 16; - end loop; - - S (1 .. 2) := "0x"; - return S; - end Image_C; - - ----------- - -- Value -- - ----------- - - function Value (S : String) return System.Address is - Base : Integer_Address := 10; - Res : Integer_Address := 0; - Last : Natural := S'Last; - C : Character; - N : Integer_Address; - - begin - -- Skip final Ada 95 base character - - if S (Last) = '#' or else S (Last) = ':' then - Last := Last - 1; - end if; - - -- Loop through characters - - for J in S'First .. Last loop - C := S (J); - - -- C format hex constant - - if C = 'x' then - if Res /= 0 then - raise Constraint_Error; - end if; - - Base := 16; - - -- Ada form based literal - - elsif C = '#' or else C = ':' then - Base := Res; - Res := 0; - - -- Ignore all underlines - - elsif C = '_' then - null; - - -- Otherwise must have digit - - else - if C in '0' .. '9' then - N := Character'Pos (C) - Character'Pos ('0'); - elsif C in 'A' .. 'F' then - N := Character'Pos (C) - (Character'Pos ('A') - 10); - elsif C in 'a' .. 'f' then - N := Character'Pos (C) - (Character'Pos ('a') - 10); - else - raise Constraint_Error; - end if; - - if N >= Base then - raise Constraint_Error; - else - Res := Res * Base + N; - end if; - end if; - end loop; - - return To_Address (Res); - end Value; - -end GNAT.Debug_Utilities; diff --git a/gcc/ada/g-debuti.ads b/gcc/ada/g-debuti.ads deleted file mode 100644 index dd860a7..0000000 --- a/gcc/ada/g-debuti.ads +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . D E B U G _ U T I L I T I E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Debugging utilities - --- This package provides some useful utility subprograms for use in writing --- routines that generate debugging output. - -with System; - -package GNAT.Debug_Utilities is - pragma Pure; - - Address_64 : constant Boolean := Standard'Address_Size = 64; - -- Set true if 64 bit addresses (assumes only 32 and 64 are possible) - - Address_Image_Length : constant := 13 + 10 * Boolean'Pos (Address_64); - -- Length of string returned by Image function for an address - - subtype Image_String is String (1 .. Address_Image_Length); - -- Subtype returned by Image function for an address - - Address_Image_C_Length : constant := 10 + 8 * Boolean'Pos (Address_64); - -- Length of string returned by Image_C function - - subtype Image_C_String is String (1 .. Address_Image_C_Length); - -- Subtype returned by Image_C function - - function Image (S : String) return String; - -- Returns a string image of S, obtained by prepending and appending - -- quote (") characters and doubling any quote characters in the string. - -- The maximum length of the result is thus 2 ** S'Length + 2. - - function Image (A : System.Address) return Image_String; - -- Returns a string of the form 16#hhhh_hhhh# for 32-bit addresses - -- or 16#hhhh_hhhh_hhhh_hhhh# for 64-bit addresses. Hex characters - -- are in upper case. - - function Image_C (A : System.Address) return Image_C_String; - -- Returns a string of the form 0xhhhhhhhh for 32 bit addresses or - -- 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are in - -- upper case. - - function Value (S : String) return System.Address; - -- Given a valid integer literal in any form, including the form returned - -- by the Image function in this package, yields the corresponding address. - -- Note that this routine will handle any Ada integer format, and will - -- also handle hex constants in C format (0xhh..hhh). Constraint_Error - -- may be raised for obviously incorrect data, but the routine is fairly - -- permissive, and in particular, all underscores in whatever position - -- are simply ignored completely. - -end GNAT.Debug_Utilities; diff --git a/gcc/ada/g-decstr.adb b/gcc/ada/g-decstr.adb deleted file mode 100644 index ab8d06c..0000000 --- a/gcc/ada/g-decstr.adb +++ /dev/null @@ -1,796 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . D E C O D E _ S T R I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 utility routine for converting from an encoded --- string to a corresponding Wide_String or Wide_Wide_String value. - -with Interfaces; use Interfaces; - -with System.WCh_Cnv; use System.WCh_Cnv; -with System.WCh_Con; use System.WCh_Con; - -package body GNAT.Decode_String is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Bad; - pragma No_Return (Bad); - -- Raise error for bad encoding - - procedure Past_End; - pragma No_Return (Past_End); - -- Raise error for off end of string - - --------- - -- Bad -- - --------- - - procedure Bad is - begin - raise Constraint_Error with - "bad encoding or character out of range"; - end Bad; - - --------------------------- - -- Decode_Wide_Character -- - --------------------------- - - procedure Decode_Wide_Character - (Input : String; - Ptr : in out Natural; - Result : out Wide_Character) - is - Char : Wide_Wide_Character; - begin - Decode_Wide_Wide_Character (Input, Ptr, Char); - - if Wide_Wide_Character'Pos (Char) > 16#FFFF# then - Bad; - else - Result := Wide_Character'Val (Wide_Wide_Character'Pos (Char)); - end if; - end Decode_Wide_Character; - - ------------------------ - -- Decode_Wide_String -- - ------------------------ - - function Decode_Wide_String (S : String) return Wide_String is - Result : Wide_String (1 .. S'Length); - Length : Natural; - begin - Decode_Wide_String (S, Result, Length); - return Result (1 .. Length); - end Decode_Wide_String; - - procedure Decode_Wide_String - (S : String; - Result : out Wide_String; - Length : out Natural) - is - Ptr : Natural; - - begin - Ptr := S'First; - Length := 0; - while Ptr <= S'Last loop - if Length >= Result'Last then - Past_End; - end if; - - Length := Length + 1; - Decode_Wide_Character (S, Ptr, Result (Length)); - end loop; - end Decode_Wide_String; - - -------------------------------- - -- Decode_Wide_Wide_Character -- - -------------------------------- - - procedure Decode_Wide_Wide_Character - (Input : String; - Ptr : in out Natural; - Result : out Wide_Wide_Character) - is - C : Character; - - function In_Char return Character; - pragma Inline (In_Char); - -- Function to get one input character - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - begin - if Ptr <= Input'Last then - Ptr := Ptr + 1; - return Input (Ptr - 1); - else - Past_End; - end if; - end In_Char; - - -- Start of processing for Decode_Wide_Wide_Character - - begin - C := In_Char; - - -- Special fast processing for UTF-8 case - - if Encoding_Method = WCEM_UTF8 then - UTF8 : declare - U : Unsigned_32; - W : Unsigned_32; - - procedure Get_UTF_Byte; - pragma Inline (Get_UTF_Byte); - -- Used to interpret 2#10xxxxxx# continuation byte in UTF-8 mode. - -- Reads a byte, and raises CE if the first two bits are not 10. - -- Otherwise shifts W 6 bits left and or's in the 6 xxxxxx bits. - - ------------------ - -- Get_UTF_Byte -- - ------------------ - - procedure Get_UTF_Byte is - begin - U := Unsigned_32 (Character'Pos (In_Char)); - - if (U and 2#11000000#) /= 2#10_000000# then - Bad; - end if; - - W := Shift_Left (W, 6) or (U and 2#00111111#); - end Get_UTF_Byte; - - -- Start of processing for UTF8 case - - begin - -- Note: for details of UTF8 encoding see RFC 3629 - - U := Unsigned_32 (Character'Pos (C)); - - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - if (U and 2#10000000#) = 2#00000000# then - Result := Wide_Wide_Character'Val (Character'Pos (C)); - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - elsif (U and 2#11100000#) = 2#110_00000# then - W := U and 2#00011111#; - Get_UTF_Byte; - - if W not in 16#00_0080# .. 16#00_07FF# then - Bad; - end if; - - Result := Wide_Wide_Character'Val (W); - - -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11110000#) = 2#1110_0000# then - W := U and 2#00001111#; - Get_UTF_Byte; - Get_UTF_Byte; - - if W not in 16#00_0800# .. 16#00_FFFF# then - Bad; - end if; - - Result := Wide_Wide_Character'Val (W); - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11111000#) = 2#11110_000# then - W := U and 2#00000111#; - - for K in 1 .. 3 loop - Get_UTF_Byte; - end loop; - - if W not in 16#01_0000# .. 16#10_FFFF# then - Bad; - end if; - - Result := Wide_Wide_Character'Val (W); - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - elsif (U and 2#11111100#) = 2#111110_00# then - W := U and 2#00000011#; - - for K in 1 .. 4 loop - Get_UTF_Byte; - end loop; - - if W not in 16#0020_0000# .. 16#03FF_FFFF# then - Bad; - end if; - - Result := Wide_Wide_Character'Val (W); - - -- All other cases are invalid, note that this includes: - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx 10xxxxxx - - -- since Wide_Wide_Character does not include code values - -- greater than 16#03FF_FFFF#. - - else - Bad; - end if; - end UTF8; - - -- All encoding functions other than UTF-8 - - else - Non_UTF8 : declare - function Char_Sequence_To_UTF is - new Char_Sequence_To_UTF_32 (In_Char); - - begin - -- For brackets, must test for specific case of [ not followed by - -- quotation, where we must not call Char_Sequence_To_UTF, but - -- instead just return the bracket unchanged. - - if Encoding_Method = WCEM_Brackets - and then C = '[' - and then (Ptr > Input'Last or else Input (Ptr) /= '"') - then - Result := '['; - - -- All other cases including [" with Brackets - - else - Result := - Wide_Wide_Character'Val - (Char_Sequence_To_UTF (C, Encoding_Method)); - end if; - end Non_UTF8; - end if; - end Decode_Wide_Wide_Character; - - ----------------------------- - -- Decode_Wide_Wide_String -- - ----------------------------- - - function Decode_Wide_Wide_String (S : String) return Wide_Wide_String is - Result : Wide_Wide_String (1 .. S'Length); - Length : Natural; - begin - Decode_Wide_Wide_String (S, Result, Length); - return Result (1 .. Length); - end Decode_Wide_Wide_String; - - procedure Decode_Wide_Wide_String - (S : String; - Result : out Wide_Wide_String; - Length : out Natural) - is - Ptr : Natural; - - begin - Ptr := S'First; - Length := 0; - while Ptr <= S'Last loop - if Length >= Result'Last then - Past_End; - end if; - - Length := Length + 1; - Decode_Wide_Wide_Character (S, Ptr, Result (Length)); - end loop; - end Decode_Wide_Wide_String; - - ------------------------- - -- Next_Wide_Character -- - ------------------------- - - procedure Next_Wide_Character (Input : String; Ptr : in out Natural) is - Discard : Wide_Character; - begin - Decode_Wide_Character (Input, Ptr, Discard); - end Next_Wide_Character; - - ------------------------------ - -- Next_Wide_Wide_Character -- - ------------------------------ - - procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural) is - Discard : Wide_Wide_Character; - begin - Decode_Wide_Wide_Character (Input, Ptr, Discard); - end Next_Wide_Wide_Character; - - -------------- - -- Past_End -- - -------------- - - procedure Past_End is - begin - raise Constraint_Error with "past end of string"; - end Past_End; - - ------------------------- - -- Prev_Wide_Character -- - ------------------------- - - procedure Prev_Wide_Character (Input : String; Ptr : in out Natural) is - begin - if Ptr > Input'Last + 1 then - Past_End; - end if; - - -- Special efficient encoding for UTF-8 case - - if Encoding_Method = WCEM_UTF8 then - UTF8 : declare - U : Unsigned_32; - - procedure Getc; - pragma Inline (Getc); - -- Gets the character at Input (Ptr - 1) and returns code in U as - -- Unsigned_32 value. On return Ptr is decremented by one. - - procedure Skip_UTF_Byte; - pragma Inline (Skip_UTF_Byte); - -- Checks that U is 2#10xxxxxx# and then calls Get - - ---------- - -- Getc -- - ---------- - - procedure Getc is - begin - if Ptr <= Input'First then - Past_End; - else - Ptr := Ptr - 1; - U := Unsigned_32 (Character'Pos (Input (Ptr))); - end if; - end Getc; - - ------------------- - -- Skip_UTF_Byte -- - ------------------- - - procedure Skip_UTF_Byte is - begin - if (U and 2#11000000#) = 2#10_000000# then - Getc; - else - Bad; - end if; - end Skip_UTF_Byte; - - -- Start of processing for UTF-8 case - - begin - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - Getc; - - if (U and 2#10000000#) = 2#00000000# then - return; - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - else - Skip_UTF_Byte; - - if (U and 2#11100000#) = 2#110_00000# then - return; - - -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx - - else - Skip_UTF_Byte; - - if (U and 2#11110000#) = 2#1110_0000# then - return; - - -- Any other code is invalid, note that this includes: - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx - -- 10xxxxxx - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx - -- 10xxxxxx 10xxxxxx - -- 10xxxxxx - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx - -- 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - -- since Wide_Character does not allow codes > 16#FFFF# - - else - Bad; - end if; - end if; - end if; - end UTF8; - - -- Special efficient encoding for brackets case - - elsif Encoding_Method = WCEM_Brackets then - Brackets : declare - P : Natural; - S : Natural; - - begin - -- See if we have "] at end positions - - if Ptr > Input'First + 1 - and then Input (Ptr - 1) = ']' - and then Input (Ptr - 2) = '"' - then - P := Ptr - 2; - - -- Loop back looking for [" at start - - while P >= Ptr - 10 loop - if P <= Input'First + 1 then - Bad; - - elsif Input (P - 1) = '"' - and then Input (P - 2) = '[' - then - -- Found ["..."], scan forward to check it - - S := P - 2; - P := S; - Next_Wide_Character (Input, P); - - -- OK if at original pointer, else error - - if P = Ptr then - Ptr := S; - return; - else - Bad; - end if; - end if; - - P := P - 1; - end loop; - - -- Falling through loop means more than 8 chars between the - -- enclosing brackets (or simply a missing left bracket) - - Bad; - - -- Here if no bracket sequence present - - else - if Ptr = Input'First then - Past_End; - else - Ptr := Ptr - 1; - end if; - end if; - end Brackets; - - -- Non-UTF-8/Brackets. These are the inefficient cases where we have to - -- go to the start of the string and skip forwards till Ptr matches. - - else - Non_UTF_Brackets : declare - Discard : Wide_Character; - PtrS : Natural; - PtrP : Natural; - - begin - PtrS := Input'First; - - if Ptr <= PtrS then - Past_End; - end if; - - loop - PtrP := PtrS; - Decode_Wide_Character (Input, PtrS, Discard); - - if PtrS = Ptr then - Ptr := PtrP; - return; - - elsif PtrS > Ptr then - Bad; - end if; - end loop; - - exception - when Constraint_Error => - Bad; - end Non_UTF_Brackets; - end if; - end Prev_Wide_Character; - - ------------------------------ - -- Prev_Wide_Wide_Character -- - ------------------------------ - - procedure Prev_Wide_Wide_Character (Input : String; Ptr : in out Natural) is - begin - if Ptr > Input'Last + 1 then - Past_End; - end if; - - -- Special efficient encoding for UTF-8 case - - if Encoding_Method = WCEM_UTF8 then - UTF8 : declare - U : Unsigned_32; - - procedure Getc; - pragma Inline (Getc); - -- Gets the character at Input (Ptr - 1) and returns code in U as - -- Unsigned_32 value. On return Ptr is decremented by one. - - procedure Skip_UTF_Byte; - pragma Inline (Skip_UTF_Byte); - -- Checks that U is 2#10xxxxxx# and then calls Get - - ---------- - -- Getc -- - ---------- - - procedure Getc is - begin - if Ptr <= Input'First then - Past_End; - else - Ptr := Ptr - 1; - U := Unsigned_32 (Character'Pos (Input (Ptr))); - end if; - end Getc; - - ------------------- - -- Skip_UTF_Byte -- - ------------------- - - procedure Skip_UTF_Byte is - begin - if (U and 2#11000000#) = 2#10_000000# then - Getc; - else - Bad; - end if; - end Skip_UTF_Byte; - - -- Start of processing for UTF-8 case - - begin - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - Getc; - - if (U and 2#10000000#) = 2#00000000# then - return; - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - else - Skip_UTF_Byte; - - if (U and 2#11100000#) = 2#110_00000# then - return; - - -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx - - else - Skip_UTF_Byte; - - if (U and 2#11110000#) = 2#1110_0000# then - return; - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx - -- 10xxxxxx - - else - Skip_UTF_Byte; - - if (U and 2#11111000#) = 2#11110_000# then - return; - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx - -- 10xxxxxx 10xxxxxx - -- 10xxxxxx - - else - Skip_UTF_Byte; - - if (U and 2#11111100#) = 2#111110_00# then - return; - - -- Any other code is invalid, note that this includes: - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx - -- 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - -- since Wide_Wide_Character does not allow codes - -- greater than 16#03FF_FFFF# - - else - Bad; - end if; - end if; - end if; - end if; - end if; - end UTF8; - - -- Special efficient encoding for brackets case - - elsif Encoding_Method = WCEM_Brackets then - Brackets : declare - P : Natural; - S : Natural; - - begin - -- See if we have "] at end positions - - if Ptr > Input'First + 1 - and then Input (Ptr - 1) = ']' - and then Input (Ptr - 2) = '"' - then - P := Ptr - 2; - - -- Loop back looking for [" at start - - while P >= Ptr - 10 loop - if P <= Input'First + 1 then - Bad; - - elsif Input (P - 1) = '"' - and then Input (P - 2) = '[' - then - -- Found ["..."], scan forward to check it - - S := P - 2; - P := S; - Next_Wide_Wide_Character (Input, P); - - -- OK if at original pointer, else error - - if P = Ptr then - Ptr := S; - return; - else - Bad; - end if; - end if; - - P := P - 1; - end loop; - - -- Falling through loop means more than 8 chars between the - -- enclosing brackets (or simply a missing left bracket) - - Bad; - - -- Here if no bracket sequence present - - else - if Ptr = Input'First then - Past_End; - else - Ptr := Ptr - 1; - end if; - end if; - end Brackets; - - -- Non-UTF-8/Brackets. These are the inefficient cases where we have to - -- go to the start of the string and skip forwards till Ptr matches. - - else - Non_UTF8_Brackets : declare - Discard : Wide_Wide_Character; - PtrS : Natural; - PtrP : Natural; - - begin - PtrS := Input'First; - - if Ptr <= PtrS then - Past_End; - end if; - - loop - PtrP := PtrS; - Decode_Wide_Wide_Character (Input, PtrS, Discard); - - if PtrS = Ptr then - Ptr := PtrP; - return; - - elsif PtrS > Ptr then - Bad; - end if; - end loop; - - exception - when Constraint_Error => - Bad; - end Non_UTF8_Brackets; - end if; - end Prev_Wide_Wide_Character; - - -------------------------- - -- Validate_Wide_String -- - -------------------------- - - function Validate_Wide_String (S : String) return Boolean is - Ptr : Natural; - - begin - Ptr := S'First; - while Ptr <= S'Last loop - Next_Wide_Character (S, Ptr); - end loop; - - return True; - - exception - when Constraint_Error => - return False; - end Validate_Wide_String; - - ------------------------------- - -- Validate_Wide_Wide_String -- - ------------------------------- - - function Validate_Wide_Wide_String (S : String) return Boolean is - Ptr : Natural; - - begin - Ptr := S'First; - while Ptr <= S'Last loop - Next_Wide_Wide_Character (S, Ptr); - end loop; - - return True; - - exception - when Constraint_Error => - return False; - end Validate_Wide_Wide_String; - -end GNAT.Decode_String; diff --git a/gcc/ada/g-decstr.ads b/gcc/ada/g-decstr.ads deleted file mode 100644 index d59f10d..0000000 --- a/gcc/ada/g-decstr.ads +++ /dev/null @@ -1,176 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . D E C O D E _ S T R I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This generic package provides utility routines for converting from an --- encoded string to a corresponding Wide_String or Wide_Wide_String value --- using a specified encoding convention, which is supplied as the generic --- parameter. UTF-8 is handled especially efficiently, and if the encoding --- method is known at compile time to be WCEM_UTF8, then the instantiation --- is specialized to handle only the UTF-8 case and exclude code for the --- other encoding methods. The package also provides positioning routines --- for skipping encoded characters in either direction, and for validating --- strings for correct encodings. - --- Note: this package is only about decoding sequences of 8-bit characters --- into corresponding 16-bit Wide_String or 32-bit Wide_Wide_String values. --- It knows nothing at all about the character encodings being used for the --- resulting Wide_Character and Wide_Wide_Character values. Most often this --- will be Unicode/ISO-10646 as specified by the Ada RM, but this package --- does not make any assumptions about the character coding. See also the --- packages Ada.Wide_[Wide_]Characters.Unicode for unicode specific functions. - --- In particular, in the case of UTF-8, all valid UTF-8 encodings, as listed --- in table 3.6 of the Unicode Standard, version 6.2.0, are recognized as --- legitimate. This includes the full range 16#0000_0000# .. 16#03FF_FFFF#. --- This includes codes in the range 16#D800# - 16#DFFF#. These codes all --- have UTF-8 encoding sequences that are well-defined (e.g. the encoding for --- 16#D800# is ED A0 80). But these codes do not correspond to defined Unicode --- characters and are thus considered to be "not well-formed" (see table 3.7 --- of the Unicode Standard). If you need to exclude these codes, you must do --- that manually, e.g. use Decode_Wide_Character/Decode_Wide_String and check --- that the resulting code(s) are not in this range. - --- Note on the use of brackets encoding (WCEM_Brackets). The brackets encoding --- method is ambiguous in the context of this package, since there is no way --- to tell if ["1234"] is eight unencoded characters or one encoded character. --- In the context of Ada sources, any sequence starting [" must be the start --- of an encoding (since that sequence is not valid in Ada source otherwise). --- The routines in this package use the same approach. If the input string --- contains the sequence [" then this is assumed to be the start of a brackets --- encoding sequence, and if it does not match the syntax, an error is raised. --- In the case of the Prev functions, a sequence ending with "] is assumed to --- be a valid brackets sequence, and an error is raised if it is not. - -with System.WCh_Con; - -generic - Encoding_Method : System.WCh_Con.WC_Encoding_Method; - -package GNAT.Decode_String is - pragma Pure; - - function Decode_Wide_String (S : String) return Wide_String; - pragma Inline (Decode_Wide_String); - -- Decode the given String, which is encoded using the indicated coding - -- method, returning the corresponding decoded Wide_String value. If S - -- contains a character code that cannot be represented with the given - -- encoding, then Constraint_Error is raised. - - procedure Decode_Wide_String - (S : String; - Result : out Wide_String; - Length : out Natural); - -- Similar to the above function except that the result is stored in the - -- given Wide_String variable Result, starting at Result (Result'First). On - -- return, Length is set to the number of characters stored in Result. The - -- caller must ensure that Result is long enough (an easy choice is to set - -- the length equal to the S'Length, since decoding can never increase the - -- string length). If the length of Result is insufficient Constraint_Error - -- will be raised. - - function Decode_Wide_Wide_String (S : String) return Wide_Wide_String; - -- Same as above function but for Wide_Wide_String output - - procedure Decode_Wide_Wide_String - (S : String; - Result : out Wide_Wide_String; - Length : out Natural); - -- Same as above procedure, but for Wide_Wide_String output - - function Validate_Wide_String (S : String) return Boolean; - -- This function inspects the string S to determine if it contains only - -- valid encodings corresponding to Wide_Character values using the - -- given encoding. If a call to Decode_Wide_String (S) would return - -- without raising Constraint_Error, then Validate_Wide_String will - -- return True. If the call would have raised Constraint_Error, then - -- Validate_Wide_String will return False. - - function Validate_Wide_Wide_String (S : String) return Boolean; - -- Similar to Validate_Wide_String, except that it succeeds if the string - -- contains only encodings corresponding to Wide_Wide_Character values. - - procedure Decode_Wide_Character - (Input : String; - Ptr : in out Natural; - Result : out Wide_Character); - pragma Inline (Decode_Wide_Character); - -- This is a lower level procedure that decodes a single character using - -- the given encoding method. The encoded character is stored in Input, - -- starting at Input (Ptr). The resulting output character is stored in - -- Result, and on return Ptr is updated past the input character or - -- encoding sequence. Constraint_Error will be raised if the input has - -- has a character that cannot be represented using the given encoding, - -- or if Ptr is outside the bounds of the Input string. - - procedure Decode_Wide_Wide_Character - (Input : String; - Ptr : in out Natural; - Result : out Wide_Wide_Character); - pragma Inline (Decode_Wide_Wide_Character); - -- Same as above procedure but with Wide_Wide_Character input - - procedure Next_Wide_Character (Input : String; Ptr : in out Natural); - pragma Inline (Next_Wide_Character); - -- This procedure examines the input string starting at Input (Ptr), and - -- advances Ptr past one character in the encoded string, so that on return - -- Ptr points to the next encoded character. Constraint_Error is raised if - -- an invalid encoding is encountered, or the end of the string is reached - -- or if Ptr is less than String'First on entry, or if the character - -- skipped is not a valid Wide_Character code. - - procedure Prev_Wide_Character (Input : String; Ptr : in out Natural); - -- This procedure is similar to Next_Encoded_Character except that it moves - -- backwards in the string, so that on return, Ptr is set to point to the - -- previous encoded character. Constraint_Error is raised if the start of - -- the string is encountered. It is valid for Ptr to be one past the end - -- of the string for this call (in which case on return it will point to - -- the last encoded character). - -- - -- Note: it is not generally possible to do this function efficiently with - -- all encodings, the current implementation is only efficient for the case - -- of UTF-8 (Encoding_Method = WCEM_UTF8) and Brackets (Encoding_Method = - -- WCEM_Brackets). For all other encodings, we work by starting at the - -- beginning of the string and moving forward till Ptr is reached, which - -- is correct but slow. - -- - -- Note: this routine assumes that the sequence prior to Ptr is correctly - -- encoded, it does not have a defined behavior if this is not the case. - - procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural); - pragma Inline (Next_Wide_Wide_Character); - -- Similar to Next_Wide_Character except that codes skipped must be valid - -- Wide_Wide_Character codes. - - procedure Prev_Wide_Wide_Character (Input : String; Ptr : in out Natural); - -- Similar to Prev_Wide_Character except that codes skipped must be valid - -- Wide_Wide_Character codes. - -end GNAT.Decode_String; diff --git a/gcc/ada/g-deutst.ads b/gcc/ada/g-deutst.ads deleted file mode 100644 index 5e0cb4d..0000000 --- a/gcc/ada/g-deutst.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . D E C O D E _ U T F 8 _ S T R I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 pre-instantiation of GNAT.Decode_String for the --- common case of UTF-8 encoding. As noted in the documentation of that --- package, this UTF-8 instantiation is efficient and specialized so that --- it has only the code for the UTF-8 case. See g-decstr.ads for full --- documentation on this package. - -with GNAT.Decode_String; - -with System.WCh_Con; - -package GNAT.Decode_UTF8_String is - new GNAT.Decode_String (System.WCh_Con.WCEM_UTF8); diff --git a/gcc/ada/g-diopit.adb b/gcc/ada/g-diopit.adb deleted file mode 100644 index 65bd65c..0000000 --- a/gcc/ada/g-diopit.adb +++ /dev/null @@ -1,396 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D I R E C T O R Y _ O P E R A T I O N S . I T E R A T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; -with Ada.Strings.Fixed; -with Ada.Strings.Maps; -with GNAT.OS_Lib; -with GNAT.Regexp; - -package body GNAT.Directory_Operations.Iteration is - - use Ada; - - ---------- - -- Find -- - ---------- - - procedure Find - (Root_Directory : Dir_Name_Str; - File_Pattern : String) - is - File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern); - Index : Natural := 0; - Quit : Boolean; - - procedure Read_Directory (Directory : Dir_Name_Str); - -- Open Directory and read all entries. This routine is called - -- recursively for each sub-directories. - - function Make_Pathname (Dir, File : String) return String; - -- Returns the pathname for File by adding Dir as prefix - - ------------------- - -- Make_Pathname -- - ------------------- - - function Make_Pathname (Dir, File : String) return String is - begin - if Dir (Dir'Last) = '/' or else Dir (Dir'Last) = '\' then - return Dir & File; - else - return Dir & Dir_Separator & File; - end if; - end Make_Pathname; - - -------------------- - -- Read_Directory -- - -------------------- - - procedure Read_Directory (Directory : Dir_Name_Str) is - Buffer : String (1 .. 2_048); - Last : Natural; - - Dir : Dir_Type; - pragma Warnings (Off, Dir); - - begin - Open (Dir, Directory); - - loop - Read (Dir, Buffer, Last); - exit when Last = 0; - - declare - Dir_Entry : constant String := Buffer (1 .. Last); - Pathname : constant String := - Make_Pathname (Directory, Dir_Entry); - - begin - if Regexp.Match (Dir_Entry, File_Regexp) then - Index := Index + 1; - - begin - Action (Pathname, Index, Quit); - exception - when others => - Close (Dir); - raise; - end; - - exit when Quit; - end if; - - -- Recursively call for sub-directories, except for . and .. - - if not (Dir_Entry = "." or else Dir_Entry = "..") - and then OS_Lib.Is_Directory (Pathname) - then - Read_Directory (Pathname); - exit when Quit; - end if; - end; - end loop; - - Close (Dir); - end Read_Directory; - - begin - Quit := False; - Read_Directory (Root_Directory); - end Find; - - ----------------------- - -- Wildcard_Iterator -- - ----------------------- - - procedure Wildcard_Iterator (Path : Path_Name) is - - Index : Natural := 0; - - procedure Read - (Directory : String; - File_Pattern : String; - Suffix_Pattern : String); - -- Read entries in Directory and call user's callback if the entry match - -- File_Pattern and Suffix_Pattern is empty; otherwise go down one more - -- directory level by calling Next_Level routine below. - - procedure Next_Level - (Current_Path : String; - Suffix_Path : String); - -- Extract next File_Pattern from Suffix_Path and call Read routine - -- above. - - ---------------- - -- Next_Level -- - ---------------- - - procedure Next_Level - (Current_Path : String; - Suffix_Path : String) - is - DS : Natural; - SP : String renames Suffix_Path; - - begin - if SP'Length > 2 - and then SP (SP'First) = '.' - and then Strings.Maps.Is_In (SP (SP'First + 1), Dir_Seps) - then - -- Starting with "./" - - DS := Strings.Fixed.Index - (SP (SP'First + 2 .. SP'Last), - Dir_Seps); - - if DS = 0 then - - -- We have "./" - - Read (Current_Path & ".", "*", ""); - - else - -- We have "./dir" - - Read (Current_Path & ".", - SP (SP'First + 2 .. DS - 1), - SP (DS .. SP'Last)); - end if; - - elsif SP'Length > 3 - and then SP (SP'First .. SP'First + 1) = ".." - and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps) - then - -- Starting with "../" - - DS := Strings.Fixed.Index - (SP (SP'First + 3 .. SP'Last), Dir_Seps); - - if DS = 0 then - - -- We have "../" - - Read (Current_Path & "..", "*", ""); - - else - -- We have "../dir" - - Read (Current_Path & "..", - SP (SP'First + 3 .. DS - 1), - SP (DS .. SP'Last)); - end if; - - elsif Current_Path = "" - and then SP'Length > 1 - and then Characters.Handling.Is_Letter (SP (SP'First)) - and then SP (SP'First + 1) = ':' - then - -- Starting with ":" - - if SP'Length > 2 - and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps) - then - -- Starting with ":\" - - DS := Strings.Fixed.Index - (SP (SP'First + 3 .. SP'Last), Dir_Seps); - - if DS = 0 then - - -- We have ":\dir" - - Read (SP (SP'First .. SP'First + 2), - SP (SP'First + 3 .. SP'Last), - ""); - - else - -- We have ":\dir\kkk" - - Read (SP (SP'First .. SP'First + 2), - SP (SP'First + 3 .. DS - 1), - SP (DS .. SP'Last)); - end if; - - else - -- Starting with ":" and the drive letter not followed - -- by a directory separator. The proper semantic on Windows is - -- to read the content of the current selected directory on - -- this drive. For example, if drive C current selected - -- directory is c:\temp the suffix pattern "c:m*" is - -- equivalent to c:\temp\m*. - - DS := Strings.Fixed.Index - (SP (SP'First + 2 .. SP'Last), Dir_Seps); - - if DS = 0 then - - -- We have ":dir" - - Read (SP, "", ""); - - else - -- We have ":dir/kkk" - - Read (SP (SP'First .. DS - 1), "", SP (DS .. SP'Last)); - end if; - end if; - - elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then - - -- Starting with a / - - DS := Strings.Fixed.Index - (SP (SP'First + 1 .. SP'Last), Dir_Seps); - - if DS = 0 then - - -- We have "/dir" - - Read (Current_Path, SP (SP'First + 1 .. SP'Last), ""); - else - -- We have "/dir/kkk" - - Read (Current_Path, - SP (SP'First + 1 .. DS - 1), - SP (DS .. SP'Last)); - end if; - - else - -- Starting with a name - - DS := Strings.Fixed.Index (SP, Dir_Seps); - - if DS = 0 then - - -- We have "dir" - - Read (Current_Path & '.', SP, ""); - else - -- We have "dir/kkk" - - Read (Current_Path & '.', - SP (SP'First .. DS - 1), - SP (DS .. SP'Last)); - end if; - - end if; - end Next_Level; - - ---------- - -- Read -- - ---------- - - Quit : Boolean := False; - -- Global state to be able to exit all recursive calls - - procedure Read - (Directory : String; - File_Pattern : String; - Suffix_Pattern : String) - is - File_Regexp : constant Regexp.Regexp := - Regexp.Compile (File_Pattern, Glob => True); - - Dir : Dir_Type; - pragma Warnings (Off, Dir); - - Buffer : String (1 .. 2_048); - Last : Natural; - - begin - if OS_Lib.Is_Directory (Directory & Dir_Separator) then - Open (Dir, Directory & Dir_Separator); - - Dir_Iterator : loop - Read (Dir, Buffer, Last); - exit Dir_Iterator when Last = 0; - - declare - Dir_Entry : constant String := Buffer (1 .. Last); - Pathname : constant String := - Directory & Dir_Separator & Dir_Entry; - begin - -- Handle "." and ".." only if explicit use in the - -- File_Pattern. - - if not - ((Dir_Entry = "." and then File_Pattern /= ".") - or else - (Dir_Entry = ".." and then File_Pattern /= "..")) - then - if Regexp.Match (Dir_Entry, File_Regexp) then - if Suffix_Pattern = "" then - - -- No more matching needed, call user's callback - - Index := Index + 1; - - begin - Action (Pathname, Index, Quit); - exception - when others => - Close (Dir); - raise; - end; - - else - -- Down one level - - Next_Level - (Directory & Dir_Separator & Dir_Entry, - Suffix_Pattern); - end if; - end if; - end if; - end; - - -- Exit if Quit set by call to Action, either at this level - -- or at some lower recursive call to Next_Level. - - exit Dir_Iterator when Quit; - end loop Dir_Iterator; - - Close (Dir); - end if; - end Read; - - -- Start of processing for Wildcard_Iterator - - begin - if Path = "" then - return; - end if; - - Next_Level ("", Path); - end Wildcard_Iterator; - -end GNAT.Directory_Operations.Iteration; diff --git a/gcc/ada/g-diopit.ads b/gcc/ada/g-diopit.ads deleted file mode 100644 index aac30b9..0000000 --- a/gcc/ada/g-diopit.ads +++ /dev/null @@ -1,92 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D I R E C T O R Y _ O P E R A T I O N S . I T E R A T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Iterators among files - -package GNAT.Directory_Operations.Iteration is - - generic - with procedure Action - (Item : String; - Index : Positive; - Quit : in out Boolean); - procedure Find - (Root_Directory : Dir_Name_Str; - File_Pattern : String); - -- Recursively searches the directory structure rooted at Root_Directory. - -- This provides functionality similar to the UNIX 'find' command. - -- Action will be called for every item matching the regular expression - -- File_Pattern (see GNAT.Regexp). Item is the full pathname to the file - -- starting with Root_Directory that has been matched. Index is set to one - -- for the first call and is incremented by one at each call. The iterator - -- will pass in the value False on each call to Action. The iterator will - -- terminate after passing the last matched path to Action or after - -- returning from a call to Action which sets Quit to True. - -- Raises GNAT.Regexp.Error_In_Regexp if File_Pattern is ill formed. - - generic - with procedure Action - (Item : String; - Index : Positive; - Quit : in out Boolean); - procedure Wildcard_Iterator (Path : Path_Name); - -- Calls Action for each path matching Path. Path can include wildcards '*' - -- and '?' and [...]. The rules are: - -- - -- * can be replaced by any sequence of characters - -- ? can be replaced by a single character - -- [a-z] match one character in the range 'a' through 'z' - -- [abc] match either character 'a', 'b' or 'c' - -- - -- Item is the filename that has been matched. Index is set to one for the - -- first call and is incremented by one at each call. The iterator's - -- termination can be controlled by setting Quit to True. It is by default - -- set to False. - -- - -- For example, if we have the following directory structure: - -- /boo/ - -- foo.ads - -- /sed/ - -- foo.ads - -- file/ - -- foo.ads - -- /sid/ - -- foo.ads - -- file/ - -- foo.ads - -- /life/ - -- - -- A call with expression "/s*/file/*" will call Action for the following - -- items: - -- /sed/file/foo.ads - -- /sid/file/foo.ads - -end GNAT.Directory_Operations.Iteration; diff --git a/gcc/ada/g-dirope.adb b/gcc/ada/g-dirope.adb deleted file mode 100644 index bc342029..0000000 --- a/gcc/ada/g-dirope.adb +++ /dev/null @@ -1,775 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with Ada.Characters.Handling; -with Ada.Strings.Fixed; - -with Ada.Unchecked_Deallocation; -with Ada.Unchecked_Conversion; - -with System; use System; -with System.CRTL; use System.CRTL; - -with GNAT.OS_Lib; - -package body GNAT.Directory_Operations is - - use Ada; - - Filename_Max : constant Integer := 1024; - -- 1024 is the value of FILENAME_MAX in stdio.h - - procedure Free is new - Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type); - - On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; - -- An indication that we are on Windows. Used in Get_Current_Dir, to - -- deal with drive letters in the beginning of absolute paths. - - --------------- - -- Base_Name -- - --------------- - - function Base_Name - (Path : Path_Name; - Suffix : String := "") return String - is - function Get_File_Names_Case_Sensitive return Integer; - pragma Import - (C, Get_File_Names_Case_Sensitive, - "__gnat_get_file_names_case_sensitive"); - - Case_Sensitive_File_Name : constant Boolean := - Get_File_Names_Case_Sensitive = 1; - - function Basename - (Path : Path_Name; - Suffix : String := "") return String; - -- This function does the job. The only difference between Basename - -- and Base_Name (the parent function) is that the former is case - -- sensitive, while the latter is not. Path and Suffix are adjusted - -- appropriately before calling Basename under platforms where the - -- file system is not case sensitive. - - -------------- - -- Basename -- - -------------- - - function Basename - (Path : Path_Name; - Suffix : String := "") return String - is - Cut_Start : Natural := - Strings.Fixed.Index - (Path, Dir_Seps, Going => Strings.Backward); - Cut_End : Natural; - - begin - -- Cut_Start point to the first basename character - - Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); - - -- Cut_End point to the last basename character - - Cut_End := Path'Last; - - -- If basename ends with Suffix, adjust Cut_End - - if Suffix /= "" - and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix - then - Cut_End := Path'Last - Suffix'Length; - end if; - - Check_For_Standard_Dirs : declare - Offset : constant Integer := Path'First - Base_Name.Path'First; - BN : constant String := - Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset); - -- Here we use Base_Name.Path to keep the original casing - - Has_Drive_Letter : constant Boolean := - OS_Lib.Path_Separator /= ':'; - -- If Path separator is not ':' then we are on a DOS based OS - -- where this character is used as a drive letter separator. - - begin - if BN = "." or else BN = ".." then - return ""; - - elsif Has_Drive_Letter - and then BN'Length > 2 - and then Characters.Handling.Is_Letter (BN (BN'First)) - and then BN (BN'First + 1) = ':' - then - -- We have a DOS drive letter prefix, remove it - - return BN (BN'First + 2 .. BN'Last); - - else - return BN; - end if; - end Check_For_Standard_Dirs; - end Basename; - - -- Start of processing for Base_Name - - begin - if Path'Length <= Suffix'Length then - return Path; - end if; - - if Case_Sensitive_File_Name then - return Basename (Path, Suffix); - else - return Basename - (Characters.Handling.To_Lower (Path), - Characters.Handling.To_Lower (Suffix)); - end if; - end Base_Name; - - ---------------- - -- Change_Dir -- - ---------------- - - procedure Change_Dir (Dir_Name : Dir_Name_Str) is - C_Dir_Name : constant String := Dir_Name & ASCII.NUL; - begin - if chdir (C_Dir_Name) /= 0 then - raise Directory_Error; - end if; - end Change_Dir; - - ----------- - -- Close -- - ----------- - - procedure Close (Dir : in out Dir_Type) is - Discard : Integer; - pragma Warnings (Off, Discard); - - function closedir (directory : DIRs) return Integer; - pragma Import (C, closedir, "__gnat_closedir"); - - begin - if not Is_Open (Dir) then - raise Directory_Error; - end if; - - Discard := closedir (DIRs (Dir.all)); - Free (Dir); - end Close; - - -------------- - -- Dir_Name -- - -------------- - - function Dir_Name (Path : Path_Name) return Dir_Name_Str is - Last_DS : constant Natural := - Strings.Fixed.Index - (Path, Dir_Seps, Going => Strings.Backward); - - begin - if Last_DS = 0 then - - -- There is no directory separator, returns current working directory - - return "." & Dir_Separator; - - else - return Path (Path'First .. Last_DS); - end if; - end Dir_Name; - - ----------------- - -- Expand_Path -- - ----------------- - - function Expand_Path - (Path : Path_Name; - Mode : Environment_Style := System_Default) return Path_Name - is - Environment_Variable_Char : Character; - pragma Import (C, Environment_Variable_Char, "__gnat_environment_char"); - - Result : OS_Lib.String_Access := new String (1 .. 200); - Result_Last : Natural := 0; - - procedure Append (C : Character); - procedure Append (S : String); - -- Append to Result - - procedure Double_Result_Size; - -- Reallocate Result, doubling its size - - function Is_Var_Prefix (C : Character) return Boolean; - pragma Inline (Is_Var_Prefix); - - procedure Read (K : in out Positive); - -- Update Result while reading current Path starting at position K. If - -- a variable is found, call Var below. - - procedure Var (K : in out Positive); - -- Translate variable name starting at position K with the associated - -- environment value. - - ------------ - -- Append -- - ------------ - - procedure Append (C : Character) is - begin - if Result_Last = Result'Last then - Double_Result_Size; - end if; - - Result_Last := Result_Last + 1; - Result (Result_Last) := C; - end Append; - - procedure Append (S : String) is - begin - while Result_Last + S'Length - 1 > Result'Last loop - Double_Result_Size; - end loop; - - Result (Result_Last + 1 .. Result_Last + S'Length) := S; - Result_Last := Result_Last + S'Length; - end Append; - - ------------------------ - -- Double_Result_Size -- - ------------------------ - - procedure Double_Result_Size is - New_Result : constant OS_Lib.String_Access := - new String (1 .. 2 * Result'Last); - begin - New_Result (1 .. Result_Last) := Result (1 .. Result_Last); - OS_Lib.Free (Result); - Result := New_Result; - end Double_Result_Size; - - ------------------- - -- Is_Var_Prefix -- - ------------------- - - function Is_Var_Prefix (C : Character) return Boolean is - begin - return (C = Environment_Variable_Char and then Mode = System_Default) - or else - (C = '$' and then (Mode = UNIX or else Mode = Both)) - or else - (C = '%' and then (Mode = DOS or else Mode = Both)); - end Is_Var_Prefix; - - ---------- - -- Read -- - ---------- - - procedure Read (K : in out Positive) is - P : Character; - - begin - For_All_Characters : loop - if Is_Var_Prefix (Path (K)) then - P := Path (K); - - -- Could be a variable - - if K < Path'Last then - if Path (K + 1) = P then - - -- Not a variable after all, this is a double $ or %, - -- just insert one in the result string. - - Append (P); - K := K + 1; - - else - -- Let's parse the variable - - Var (K); - end if; - - else - -- We have an ending $ or % sign - - Append (P); - end if; - - else - -- This is a standard character, just add it to the result - - Append (Path (K)); - end if; - - -- Skip to next character - - K := K + 1; - - exit For_All_Characters when K > Path'Last; - end loop For_All_Characters; - end Read; - - --------- - -- Var -- - --------- - - procedure Var (K : in out Positive) is - P : constant Character := Path (K); - T : Character; - E : Positive; - - begin - K := K + 1; - - if P = '%' or else Path (K) = '{' then - - -- Set terminator character - - if P = '%' then - T := '%'; - else - T := '}'; - K := K + 1; - end if; - - -- Look for terminator character, k point to the first character - -- for the variable name. - - E := K; - - loop - E := E + 1; - exit when Path (E) = T or else E = Path'Last; - end loop; - - if Path (E) = T then - - -- OK found, translate with environment value - - declare - Env : OS_Lib.String_Access := - OS_Lib.Getenv (Path (K .. E - 1)); - - begin - Append (Env.all); - OS_Lib.Free (Env); - end; - - else - -- No terminator character, not a variable after all or a - -- syntax error, ignore it, insert string as-is. - - Append (P); -- Add prefix character - - if T = '}' then -- If we were looking for curly bracket - Append ('{'); -- terminator, add the curly bracket - end if; - - Append (Path (K .. E)); - end if; - - else - -- The variable name is everything from current position to first - -- non letter/digit character. - - E := K; - - -- Check that first character is a letter - - if Characters.Handling.Is_Letter (Path (E)) then - E := E + 1; - - Var_Name : loop - exit Var_Name when E > Path'Last; - - if Characters.Handling.Is_Letter (Path (E)) - or else Characters.Handling.Is_Digit (Path (E)) - then - E := E + 1; - else - exit Var_Name; - end if; - end loop Var_Name; - - E := E - 1; - - declare - Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E)); - - begin - Append (Env.all); - OS_Lib.Free (Env); - end; - - else - -- This is not a variable after all - - Append ('$'); - Append (Path (E)); - end if; - - end if; - - K := E; - end Var; - - -- Start of processing for Expand_Path - - begin - declare - K : Positive := Path'First; - - begin - Read (K); - - declare - Returned_Value : constant String := Result (1 .. Result_Last); - - begin - OS_Lib.Free (Result); - return Returned_Value; - end; - end; - end Expand_Path; - - -------------------- - -- File_Extension -- - -------------------- - - function File_Extension (Path : Path_Name) return String is - First : Natural := - Strings.Fixed.Index - (Path, Dir_Seps, Going => Strings.Backward); - - Dot : Natural; - - begin - if First = 0 then - First := Path'First; - end if; - - Dot := Strings.Fixed.Index (Path (First .. Path'Last), - ".", - Going => Strings.Backward); - - if Dot = 0 or else Dot = Path'Last then - return ""; - else - return Path (Dot .. Path'Last); - end if; - end File_Extension; - - --------------- - -- File_Name -- - --------------- - - function File_Name (Path : Path_Name) return String is - begin - return Base_Name (Path); - end File_Name; - - --------------------- - -- Format_Pathname -- - --------------------- - - function Format_Pathname - (Path : Path_Name; - Style : Path_Style := System_Default) return String - is - N_Path : String := Path; - K : Positive := N_Path'First; - Prev_Dirsep : Boolean := False; - - begin - if Dir_Separator = '\' - and then Path'Length > 1 - and then Path (K .. K + 1) = "\\" - then - if Style = UNIX then - N_Path (K .. K + 1) := "//"; - end if; - - K := K + 2; - end if; - - for J in K .. Path'Last loop - if Strings.Maps.Is_In (Path (J), Dir_Seps) then - if not Prev_Dirsep then - case Style is - when UNIX => N_Path (K) := '/'; - when DOS => N_Path (K) := '\'; - when System_Default => N_Path (K) := Dir_Separator; - end case; - - K := K + 1; - end if; - - Prev_Dirsep := True; - - else - N_Path (K) := Path (J); - K := K + 1; - Prev_Dirsep := False; - end if; - end loop; - - return N_Path (N_Path'First .. K - 1); - end Format_Pathname; - - --------------------- - -- Get_Current_Dir -- - --------------------- - - Max_Path : Integer; - pragma Import (C, Max_Path, "__gnat_max_path_len"); - - function Get_Current_Dir return Dir_Name_Str is - Current_Dir : String (1 .. Max_Path + 1); - Last : Natural; - begin - Get_Current_Dir (Current_Dir, Last); - return Current_Dir (1 .. Last); - end Get_Current_Dir; - - procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is - Path_Len : Natural := Max_Path; - Buffer : String (Dir'First .. Dir'First + Max_Path + 1); - - procedure Local_Get_Current_Dir - (Dir : System.Address; - Length : System.Address); - pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); - - begin - Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); - - if Path_Len = 0 then - raise Ada.IO_Exceptions.Use_Error - with "current directory does not exist"; - end if; - - Last := - (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last); - - Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); - - -- By default, the drive letter on Windows is in upper case - - if On_Windows and then Last > Dir'First and then - Dir (Dir'First + 1) = ':' - then - Dir (Dir'First) := - Ada.Characters.Handling.To_Upper (Dir (Dir'First)); - end if; - end Get_Current_Dir; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (Dir : Dir_Type) return Boolean is - begin - return Dir /= Null_Dir - and then System.Address (Dir.all) /= System.Null_Address; - end Is_Open; - - -------------- - -- Make_Dir -- - -------------- - - procedure Make_Dir (Dir_Name : Dir_Name_Str) is - C_Dir_Name : constant String := Dir_Name & ASCII.NUL; - begin - if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then - raise Directory_Error; - end if; - end Make_Dir; - - ---------- - -- Open -- - ---------- - - procedure Open - (Dir : out Dir_Type; - Dir_Name : Dir_Name_Str) - is - function opendir (file_name : String) return DIRs; - pragma Import (C, opendir, "__gnat_opendir"); - - C_File_Name : constant String := Dir_Name & ASCII.NUL; - - begin - Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name))); - - if not Is_Open (Dir) then - Free (Dir); - Dir := Null_Dir; - raise Directory_Error; - end if; - end Open; - - ---------- - -- Read -- - ---------- - - procedure Read - (Dir : Dir_Type; - Str : out String; - Last : out Natural) - is - Filename_Addr : Address; - Filename_Len : aliased Integer; - - Buffer : array (0 .. Filename_Max + 12) of Character; - -- 12 is the size of the dirent structure (see dirent.h), without the - -- field for the filename. - - function readdir_gnat - (Directory : System.Address; - Buffer : System.Address; - Last : not null access Integer) return System.Address; - pragma Import (C, readdir_gnat, "__gnat_readdir"); - - begin - if not Is_Open (Dir) then - raise Directory_Error; - end if; - - Filename_Addr := - readdir_gnat - (System.Address (Dir.all), Buffer'Address, Filename_Len'Access); - - if Filename_Addr = System.Null_Address then - Last := 0; - return; - end if; - - Last := - (if Str'Length > Filename_Len then Str'First + Filename_Len - 1 - else Str'Last); - - declare - subtype Path_String is String (1 .. Filename_Len); - type Path_String_Access is access Path_String; - - function Address_To_Access is new - Ada.Unchecked_Conversion - (Source => Address, - Target => Path_String_Access); - - Path_Access : constant Path_String_Access := - Address_To_Access (Filename_Addr); - - begin - for J in Str'First .. Last loop - Str (J) := Path_Access (J - Str'First + 1); - end loop; - end; - end Read; - - ------------------------- - -- Read_Is_Thread_Safe -- - ------------------------- - - function Read_Is_Thread_Safe return Boolean is - function readdir_is_thread_safe return Integer; - pragma Import - (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe"); - begin - return (readdir_is_thread_safe /= 0); - end Read_Is_Thread_Safe; - - ---------------- - -- Remove_Dir -- - ---------------- - - procedure Remove_Dir - (Dir_Name : Dir_Name_Str; - Recursive : Boolean := False) - is - C_Dir_Name : constant String := Dir_Name & ASCII.NUL; - Last : Integer; - Str : String (1 .. Filename_Max); - Success : Boolean; - Current_Dir : Dir_Type; - - begin - -- Remove the directory only if it is empty - - if not Recursive then - if rmdir (C_Dir_Name) /= 0 then - raise Directory_Error; - end if; - - -- Remove directory and all files and directories that it may contain - - else - Open (Current_Dir, Dir_Name); - - loop - Read (Current_Dir, Str, Last); - exit when Last = 0; - - if GNAT.OS_Lib.Is_Directory - (Dir_Name & Dir_Separator & Str (1 .. Last)) - then - if Str (1 .. Last) /= "." - and then - Str (1 .. Last) /= ".." - then - -- Recursive call to remove a subdirectory and all its - -- files. - - Remove_Dir - (Dir_Name & Dir_Separator & Str (1 .. Last), - True); - end if; - - else - GNAT.OS_Lib.Delete_File - (Dir_Name & Dir_Separator & Str (1 .. Last), - Success); - - if not Success then - raise Directory_Error; - end if; - end if; - end loop; - - Close (Current_Dir); - Remove_Dir (Dir_Name); - end if; - end Remove_Dir; - -end GNAT.Directory_Operations; diff --git a/gcc/ada/g-dirope.ads b/gcc/ada/g-dirope.ads deleted file mode 100644 index 1b04b94..0000000 --- a/gcc/ada/g-dirope.ads +++ /dev/null @@ -1,262 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2015, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Directory operations - --- This package provides routines for manipulating directories. A directory --- can be treated as a file, using open and close routines, and a scanning --- routine is provided for iterating through the entries in a directory. - --- See also child package GNAT.Directory_Operations.Iteration - -with System; -with Ada.Strings.Maps; - -package GNAT.Directory_Operations is - - subtype Dir_Name_Str is String; - -- A subtype used in this package to represent string values that are - -- directory names. A directory name is a prefix for files that appear - -- with in the directory. This means that for UNIX systems, the string - -- includes a final '/', and for DOS-like systems, it includes a final - -- '\' character. It can also include drive letters if the operating - -- system provides for this. The final '/' or '\' in a Dir_Name_Str is - -- optional when passed as a procedure or function in parameter. - - type Dir_Type is limited private; - -- A value used to reference a directory. Conceptually this value includes - -- the identity of the directory, and a sequential position within it. - - Null_Dir : constant Dir_Type; - -- Represent the value for an uninitialized or closed directory - - Directory_Error : exception; - -- Exception raised if the directory cannot be opened, read, closed, - -- created or if it is not possible to change the current execution - -- environment directory. - - Dir_Separator : constant Character; - -- Running system default directory separator - - -------------------------------- - -- Basic Directory operations -- - -------------------------------- - - procedure Change_Dir (Dir_Name : Dir_Name_Str); - -- Changes the working directory of the current execution environment - -- to the directory named by Dir_Name. Raises Directory_Error if Dir_Name - -- does not exist. - - procedure Make_Dir (Dir_Name : Dir_Name_Str); - -- Create a new directory named Dir_Name. Raises Directory_Error if - -- Dir_Name cannot be created. - - procedure Remove_Dir - (Dir_Name : Dir_Name_Str; - Recursive : Boolean := False); - -- Remove the directory named Dir_Name. If Recursive is set to True, then - -- Remove_Dir removes all the subdirectories and files that are in - -- Dir_Name. Raises Directory_Error if Dir_Name cannot be removed. - - function Get_Current_Dir return Dir_Name_Str; - -- Returns the current working directory for the execution environment - - procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural); - -- Returns the current working directory for the execution environment - -- The name is returned in Dir_Name. Last is the index in Dir_Name such - -- that Dir_Name (Last) is the last character written. If Dir_Name is - -- too small for the directory name, the name will be truncated before - -- being copied to Dir_Name. - - ------------------------- - -- Pathname Operations -- - ------------------------- - - subtype Path_Name is String; - -- All routines using Path_Name handle both styles (UNIX and DOS) of - -- directory separators (either slash or back slash). - - function Dir_Name (Path : Path_Name) return Dir_Name_Str; - -- Returns directory name for Path. This is similar to the UNIX dirname - -- command. Everything after the last directory separator is removed. If - -- there is no directory separator the current working directory is - -- returned. Note that the contents of Path is case-sensitive on - -- systems that have case-sensitive file names (like Unix), and - -- non-case-sensitive on systems where the file system is also non- - -- case-sensitive (such as Windows). - - function Base_Name - (Path : Path_Name; - Suffix : String := "") return String; - -- Any directory prefix is removed. A directory prefix is defined as - -- text up to and including the last directory separator character in - -- the input string. In addition if Path ends with the string given for - -- Suffix, then it is also removed. Note that Suffix here can be an - -- arbitrary string (it is not required to be a file extension). This - -- is equivalent to the UNIX basename command. The following rule is - -- always true: - -- - -- 'Path' and 'Dir_Name (Path) & Dir_Separator & Base_Name (Path)' - -- represent the same file. - -- - -- The comparison of Suffix is case-insensitive on systems like Windows - -- where the file search is case-insensitive (e.g. on such systems, - -- Base_Name ("/Users/AdaCore/BB12.patch", ".Patch") returns "BB12"). - -- - -- Note that the index bounds of the result match the corresponding indexes - -- in the Path string (you cannot assume that the lower bound of the - -- returned string is one). - - function File_Extension (Path : Path_Name) return String; - -- Return the file extension. This is defined as the string after the - -- last dot, including the dot itself. For example, if the file name - -- is "file1.xyz.adq", then the returned value would be ".adq". If no - -- dot is present in the file name, or the last character of the file - -- name is a dot, then the null string is returned. - - function File_Name (Path : Path_Name) return String; - -- Returns the file name and the file extension if present. It removes all - -- path information. This is equivalent to Base_Name with default Extension - -- value. - - type Path_Style is (UNIX, DOS, System_Default); - function Format_Pathname - (Path : Path_Name; - Style : Path_Style := System_Default) return Path_Name; - -- Removes all double directory separator and converts all '\' to '/' if - -- Style is UNIX and converts all '/' to '\' if Style is set to DOS. This - -- function will help to provide a consistent naming scheme running for - -- different environments. If style is set to System_Default the routine - -- will use the default directory separator on the running environment. - -- - -- The Style argument indicates the syntax to be used for path names: - -- - -- DOS - -- Use '\' as the directory separator (default on Windows) - -- - -- UNIX - -- Use '/' as the directory separator (default on all other systems) - -- - -- System_Default - -- Use the default style for the current system - - type Environment_Style is (UNIX, DOS, Both, System_Default); - function Expand_Path - (Path : Path_Name; - Mode : Environment_Style := System_Default) return Path_Name; - -- Returns Path with environment variables replaced by the current - -- environment variable value. For example, $HOME/mydir will be replaced - -- by /home/joe/mydir if $HOME environment variable is set to /home/joe and - -- Mode is UNIX. If an environment variable does not exist the variable - -- will be replaced by the empty string. Two dollar or percent signs are - -- replaced by a single dollar/percent sign. Note that a variable must - -- start with a letter. - -- - -- The Mode argument indicates the recognized syntax for environment - -- variables as follows: - -- - -- UNIX - -- Environment variables use $ as prefix and can use curly brackets - -- as in ${HOME}/mydir. If there is no closing curly bracket for an - -- opening one then no translation is done, so for example ${VAR/toto - -- is returned as ${VAR/toto. The use of {} brackets is required if - -- the environment variable name contains other than alphanumeric - -- characters. - -- - -- DOS - -- Environment variables uses % as prefix and suffix (e.g. %HOME%/dir). - -- The name DOS refer to "DOS-like" environment. This includes all - -- Windows systems. - -- - -- Both - -- Recognize both forms described above. - -- - -- System_Default - -- Uses either DOS on Windows, and UNIX on all other systems, depending - -- on the running environment. - - --------------- - -- Iterators -- - --------------- - - procedure Open (Dir : out Dir_Type; Dir_Name : Dir_Name_Str); - -- Opens the directory named by Dir_Name and returns a Dir_Type value - -- that refers to this directory, and is positioned at the first entry. - -- Raises Directory_Error if Dir_Name cannot be accessed. In that case - -- Dir will be set to Null_Dir. - - procedure Close (Dir : in out Dir_Type); - -- Closes the directory stream referred to by Dir. After calling Close - -- Is_Open will return False. Dir will be set to Null_Dir. - -- Raises Directory_Error if Dir has not be opened (Dir = Null_Dir). - - function Is_Open (Dir : Dir_Type) return Boolean; - -- Returns True if Dir is open, or False otherwise - - procedure Read - (Dir : Dir_Type; - Str : out String; - Last : out Natural); - -- Reads the next entry from the directory and sets Str to the name - -- of that entry. Last is the index in Str such that Str (Last) is the - -- last character written. Last is 0 when there are no more files in the - -- directory. If Str is too small for the file name, the file name will - -- be truncated before being copied to Str. The list of files returned - -- includes directories in systems providing a hierarchical directory - -- structure, including . (the current directory) and .. (the parent - -- directory) in systems providing these entries. The directory is - -- returned in target-OS form. Raises Directory_Error if Dir has not - -- be opened (Dir = Null_Dir). - - function Read_Is_Thread_Safe return Boolean; - -- Indicates if procedure Read is thread safe. On systems where the - -- target system supports this functionality, Read is thread safe, - -- and this function returns True (e.g. this will be the case on any - -- UNIX or UNIX-like system providing a correct implementation of the - -- function readdir_r). If the system cannot provide a thread safe - -- implementation of Read, then this function returns False. - -private - - type Dir_Type_Value is new System.Address; - -- Low-level address directory structure as returned by opendir in C - - type Dir_Type is access Dir_Type_Value; - - Null_Dir : constant Dir_Type := null; - - pragma Import (C, Dir_Separator, "__gnat_dir_separator"); - - Dir_Seps : constant Ada.Strings.Maps.Character_Set := - Ada.Strings.Maps.To_Set ("/\"); - -- UNIX and DOS style directory separators - -end GNAT.Directory_Operations; diff --git a/gcc/ada/g-dynhta.adb b/gcc/ada/g-dynhta.adb deleted file mode 100644 index afa9e80..0000000 --- a/gcc/ada/g-dynhta.adb +++ /dev/null @@ -1,369 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . D Y N A M I C _ H T A B L E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -package body GNAT.Dynamic_HTables is - - ------------------- - -- Static_HTable -- - ------------------- - - package body Static_HTable is - - function Get_Non_Null (T : Instance) return Elmt_Ptr; - -- Returns Null_Ptr if Iterator_Started is False or if the Table is - -- empty. Returns Iterator_Ptr if non null, or the next non null - -- element in table if any. - - --------- - -- Get -- - --------- - - function Get (T : Instance; K : Key) return Elmt_Ptr is - Elmt : Elmt_Ptr; - - begin - if T = null then - return Null_Ptr; - end if; - - Elmt := T.Table (Hash (K)); - - loop - if Elmt = Null_Ptr then - return Null_Ptr; - - elsif Equal (Get_Key (Elmt), K) then - return Elmt; - - else - Elmt := Next (Elmt); - end if; - end loop; - end Get; - - --------------- - -- Get_First -- - --------------- - - function Get_First (T : Instance) return Elmt_Ptr is - begin - if T = null then - return Null_Ptr; - end if; - - T.Iterator_Started := True; - T.Iterator_Index := T.Table'First; - T.Iterator_Ptr := T.Table (T.Iterator_Index); - return Get_Non_Null (T); - end Get_First; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next (T : Instance) return Elmt_Ptr is - begin - if T = null or else not T.Iterator_Started then - return Null_Ptr; - end if; - - T.Iterator_Ptr := Next (T.Iterator_Ptr); - return Get_Non_Null (T); - end Get_Next; - - ------------------ - -- Get_Non_Null -- - ------------------ - - function Get_Non_Null (T : Instance) return Elmt_Ptr is - begin - if T = null then - return Null_Ptr; - end if; - - while T.Iterator_Ptr = Null_Ptr loop - if T.Iterator_Index = T.Table'Last then - T.Iterator_Started := False; - return Null_Ptr; - end if; - - T.Iterator_Index := T.Iterator_Index + 1; - T.Iterator_Ptr := T.Table (T.Iterator_Index); - end loop; - - return T.Iterator_Ptr; - end Get_Non_Null; - - ------------ - -- Remove -- - ------------ - - procedure Remove (T : Instance; K : Key) is - Index : constant Header_Num := Hash (K); - Elmt : Elmt_Ptr; - Next_Elmt : Elmt_Ptr; - - begin - if T = null then - return; - end if; - - Elmt := T.Table (Index); - - if Elmt = Null_Ptr then - return; - - elsif Equal (Get_Key (Elmt), K) then - T.Table (Index) := Next (Elmt); - - else - loop - Next_Elmt := Next (Elmt); - - if Next_Elmt = Null_Ptr then - return; - - elsif Equal (Get_Key (Next_Elmt), K) then - Set_Next (Elmt, Next (Next_Elmt)); - return; - - else - Elmt := Next_Elmt; - end if; - end loop; - end if; - end Remove; - - ----------- - -- Reset -- - ----------- - - procedure Reset (T : in out Instance) is - procedure Free is - new Ada.Unchecked_Deallocation (Instance_Data, Instance); - - begin - if T = null then - return; - end if; - - for J in T.Table'Range loop - T.Table (J) := Null_Ptr; - end loop; - - Free (T); - end Reset; - - --------- - -- Set -- - --------- - - procedure Set (T : in out Instance; E : Elmt_Ptr) is - Index : Header_Num; - - begin - if T = null then - T := new Instance_Data; - end if; - - Index := Hash (Get_Key (E)); - Set_Next (E, T.Table (Index)); - T.Table (Index) := E; - end Set; - - end Static_HTable; - - ------------------- - -- Simple_HTable -- - ------------------- - - package body Simple_HTable is - procedure Free is new - Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); - - --------- - -- Get -- - --------- - - function Get (T : Instance; K : Key) return Element is - Tmp : Elmt_Ptr; - - begin - if T = Nil then - return No_Element; - end if; - - Tmp := Tab.Get (Tab.Instance (T), K); - - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get; - - --------------- - -- Get_First -- - --------------- - - function Get_First (T : Instance) return Element is - Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); - - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get_First; - - ------------------- - -- Get_First_Key -- - ------------------- - - function Get_First_Key (T : Instance) return Key_Option is - Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); - begin - if Tmp = null then - return Key_Option'(Present => False); - else - return Key_Option'(Present => True, K => Tmp.all.K); - end if; - end Get_First_Key; - - ------------- - -- Get_Key -- - ------------- - - function Get_Key (E : Elmt_Ptr) return Key is - begin - return E.K; - end Get_Key; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next (T : Instance) return Element is - Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get_Next; - - ------------------ - -- Get_Next_Key -- - ------------------ - - function Get_Next_Key (T : Instance) return Key_Option is - Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); - begin - if Tmp = null then - return Key_Option'(Present => False); - else - return Key_Option'(Present => True, K => Tmp.all.K); - end if; - end Get_Next_Key; - - ---------- - -- Next -- - ---------- - - function Next (E : Elmt_Ptr) return Elmt_Ptr is - begin - return E.Next; - end Next; - - ------------ - -- Remove -- - ------------ - - procedure Remove (T : Instance; K : Key) is - Tmp : Elmt_Ptr; - - begin - Tmp := Tab.Get (Tab.Instance (T), K); - - if Tmp /= null then - Tab.Remove (Tab.Instance (T), K); - Free (Tmp); - end if; - end Remove; - - ----------- - -- Reset -- - ----------- - - procedure Reset (T : in out Instance) is - E1, E2 : Elmt_Ptr; - - begin - E1 := Tab.Get_First (Tab.Instance (T)); - while E1 /= null loop - E2 := Tab.Get_Next (Tab.Instance (T)); - Free (E1); - E1 := E2; - end loop; - - Tab.Reset (Tab.Instance (T)); - end Reset; - - --------- - -- Set -- - --------- - - procedure Set (T : in out Instance; K : Key; E : Element) is - Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K); - begin - if Tmp = null then - Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null)); - else - Tmp.E := E; - end if; - end Set; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is - begin - E.Next := Next; - end Set_Next; - - end Simple_HTable; - -end GNAT.Dynamic_HTables; diff --git a/gcc/ada/g-dynhta.ads b/gcc/ada/g-dynhta.ads deleted file mode 100644 index 85a0427..0000000 --- a/gcc/ada/g-dynhta.ads +++ /dev/null @@ -1,266 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . D Y N A M I C _ H T A B L E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Hash table searching routines - --- This package contains three separate packages. The Simple_HTable package --- provides a very simple abstraction that associates one element to one key --- value and takes care of all allocations automatically using the heap. The --- Static_HTable package provides a more complex interface that allows full --- control over allocation. The Load_Factor_HTable package provides a more --- complex abstraction where collisions are resolved by chaining, and the --- table grows by a percentage after the load factor has been exceeded. - --- This package provides a facility similar to that of GNAT.HTable, except --- that this package declares types that can be used to define dynamic --- instances of hash tables, while instantiations in GNAT.HTable creates a --- single instance of the hash table. - --- Note that this interface should remain synchronized with those in --- GNAT.HTable to keep as much coherency as possible between these two --- related units. - -package GNAT.Dynamic_HTables is - - ------------------- - -- Static_HTable -- - ------------------- - - -- A low-level Hash-Table abstraction, not as easy to instantiate as - -- Simple_HTable. This mirrors the interface of GNAT.HTable.Static_HTable, - -- but does require dynamic allocation (since we allow multiple instances - -- of the table). The model is that each Element contains its own Key that - -- can be retrieved by Get_Key. Furthermore, Element provides a link that - -- can be used by the HTable for linking elements with same hash codes: - - -- Element - - -- +-------------------+ - -- | Key | - -- +-------------------+ - -- : other data : - -- +-------------------+ - -- | Next Elmt | - -- +-------------------+ - - generic - type Header_Num is range <>; - -- An integer type indicating the number and range of hash headers - - type Element (<>) is limited private; - -- The type of element to be stored - - type Elmt_Ptr is private; - -- The type used to reference an element (will usually be an access - -- type, but could be some other form of type such as an integer type). - - Null_Ptr : Elmt_Ptr; - -- The null value of the Elmt_Ptr type - - with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - with function Next (E : Elmt_Ptr) return Elmt_Ptr; - -- The type must provide an internal link for the sake of the - -- staticness of the HTable. - - type Key is limited private; - with function Get_Key (E : Elmt_Ptr) return Key; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; - - package Static_HTable is - - type Instance is private; - Nil : constant Instance; - - procedure Reset (T : in out Instance); - -- Resets the hash table by releasing all memory associated with - -- it. The hash table can safely be reused after this call. For the - -- most common case where Elmt_Ptr is an access type, and Null_Ptr is - -- null, this is only needed if the same table is reused in a new - -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is - -- other than null, then Reset must be called before the first use of - -- the hash table. - - procedure Set (T : in out Instance; E : Elmt_Ptr); - -- Insert the element pointer in the HTable - - function Get (T : Instance; K : Key) return Elmt_Ptr; - -- Returns the latest inserted element pointer with the given Key - -- or null if none. - - procedure Remove (T : Instance; K : Key); - -- Removes the latest inserted element pointer associated with the - -- given key if any, does nothing if none. - - function Get_First (T : Instance) return Elmt_Ptr; - -- Returns Null_Ptr if the Htable is empty, otherwise returns one - -- unspecified element. There is no guarantee that 2 calls to this - -- function will return the same element. - - function Get_Next (T : Instance) return Elmt_Ptr; - -- Returns an unspecified element that has not been returned by the - -- same function since the last call to Get_First or Null_Ptr if - -- there is no such element or Get_First has never been called. If - -- there is no call to 'Set' in between Get_Next calls, all the - -- elements of the Htable will be traversed. - - private - type Table_Type is array (Header_Num) of Elmt_Ptr; - - type Instance_Data is record - Table : Table_Type; - Iterator_Index : Header_Num; - Iterator_Ptr : Elmt_Ptr; - Iterator_Started : Boolean := False; - end record; - - type Instance is access all Instance_Data; - - Nil : constant Instance := null; - end Static_HTable; - - ------------------- - -- Simple_HTable -- - ------------------- - - -- A simple hash table abstraction, easy to instantiate, easy to use. - -- The table associates one element to one key with the procedure Set. - -- Get retrieves the Element stored for a given Key. The efficiency of - -- retrieval is function of the size of the Table parameterized by - -- Header_Num and the hashing function Hash. - - generic - type Header_Num is range <>; - -- An integer type indicating the number and range of hash headers - - type Element is private; - -- The type of element to be stored - - No_Element : Element; - -- The object that is returned by Get when no element has been set for - -- a given key - - type Key is private; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; - - package Simple_HTable is - - type Instance is private; - Nil : constant Instance; - - type Key_Option (Present : Boolean := False) is record - case Present is - when True => K : Key; - when False => null; - end case; - end record; - - procedure Set (T : in out Instance; K : Key; E : Element); - -- Associates an element with a given key. Overrides any previously - -- associated element. - - procedure Reset (T : in out Instance); - -- Releases all memory associated with the table. The table can be - -- reused after this call (it is automatically allocated on the first - -- access to the table). - - function Get (T : Instance; K : Key) return Element; - -- Returns the Element associated with a key or No_Element if the given - -- key has not associated element - - procedure Remove (T : Instance; K : Key); - -- Removes the latest inserted element pointer associated with the given - -- key if any, does nothing if none. - - function Get_First (T : Instance) return Element; - -- Returns No_Element if the Htable is empty, otherwise returns one - -- unspecified element. There is no guarantee that two calls to this - -- function will return the same element, if the Htable has been - -- modified between the two calls. - - function Get_First_Key (T : Instance) return Key_Option; - -- Returns an option type giving an unspecified key. If the Htable - -- is empty, the discriminant will have field Present set to False, - -- otherwise its Present field is set to True and the field K contains - -- the key. There is no guarantee that two calls to this function will - -- return the same key, if the Htable has been modified between the two - -- calls. - - function Get_Next (T : Instance) return Element; - -- Returns an unspecified element that has not been returned by the - -- same function since the last call to Get_First or No_Element if - -- there is no such element. If there is no call to 'Set' in between - -- Get_Next calls, all the elements of the Htable will be traversed. - -- To guarantee that all the elements of the Htable will be traversed, - -- no modification of the Htable (Set, Reset, Remove) should occur - -- between a call to Get_First and subsequent consecutive calls to - -- Get_Next, until one of these calls returns No_Element. - - function Get_Next_Key (T : Instance) return Key_Option; - -- Same as Get_Next except that this returns an option type having field - -- Present set either to False if there no key never returned before by - -- either Get_First_Key or this very same function, or to True if there - -- is one, with the field K containing the key specified as before. The - -- same restrictions apply as Get_Next. - - private - - type Element_Wrapper; - type Elmt_Ptr is access all Element_Wrapper; - type Element_Wrapper is record - K : Key; - E : Element; - Next : Elmt_Ptr; - end record; - - procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - function Next (E : Elmt_Ptr) return Elmt_Ptr; - function Get_Key (E : Elmt_Ptr) return Key; - - package Tab is new Static_HTable - (Header_Num => Header_Num, - Element => Element_Wrapper, - Elmt_Ptr => Elmt_Ptr, - Null_Ptr => null, - Set_Next => Set_Next, - Next => Next, - Key => Key, - Get_Key => Get_Key, - Hash => Hash, - Equal => Equal); - - type Instance is new Tab.Instance; - Nil : constant Instance := Instance (Tab.Nil); - - end Simple_HTable; - -end GNAT.Dynamic_HTables; diff --git a/gcc/ada/g-dyntab.adb b/gcc/ada/g-dyntab.adb deleted file mode 100644 index ff27f07..0000000 --- a/gcc/ada/g-dyntab.adb +++ /dev/null @@ -1,497 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D Y N A M I C _ T A B L E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with GNAT.Heap_Sort_G; - -with Ada.Unchecked_Deallocation; -with System; - -package body GNAT.Dynamic_Tables is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Last_Allocated (T : Instance) return Table_Last_Type; - pragma Inline (Last_Allocated); - -- Return the index of the last allocated element - - procedure Grow (T : in out Instance; New_Last : Table_Last_Type); - -- This is called when we are about to set the value of Last to a value - -- that is larger than Last_Allocated. This reallocates the table to the - -- larger size, as indicated by New_Last. At the time this is called, - -- Last (T) is still the old value, and this does not modify it. - - -------------- - -- Allocate -- - -------------- - - procedure Allocate (T : in out Instance; Num : Integer := 1) is - begin - -- Note that Num can be negative - - pragma Assert (not T.Locked); - Set_Last (T, Last (T) + Table_Index_Type'Base (Num)); - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append (T : in out Instance; New_Val : Table_Component_Type) is - pragma Assert (not T.Locked); - New_Last : constant Table_Last_Type := Last (T) + 1; - - begin - if New_Last <= Last_Allocated (T) then - - -- Fast path - - T.P.Last := New_Last; - T.Table (New_Last) := New_Val; - - else - Set_Item (T, New_Last, New_Val); - end if; - end Append; - - ---------------- - -- Append_All -- - ---------------- - - procedure Append_All (T : in out Instance; New_Vals : Table_Type) is - begin - for J in New_Vals'Range loop - Append (T, New_Vals (J)); - end loop; - end Append_All; - - -------------------- - -- Decrement_Last -- - -------------------- - - procedure Decrement_Last (T : in out Instance) is - begin - pragma Assert (not T.Locked); - Allocate (T, -1); - end Decrement_Last; - - ----------- - -- First -- - ----------- - - function First return Table_Index_Type is - begin - return Table_Low_Bound; - end First; - - -------------- - -- For_Each -- - -------------- - - procedure For_Each (Table : Instance) is - Quit : Boolean := False; - begin - for Index in First .. Last (Table) loop - Action (Index, Table.Table (Index), Quit); - exit when Quit; - end loop; - end For_Each; - - ---------- - -- Grow -- - ---------- - - procedure Grow (T : in out Instance; New_Last : Table_Last_Type) is - - -- Note: Type Alloc_Ptr below needs to be declared locally so we know - -- the bounds. That means that the collection is local, so is finalized - -- when leaving Grow. That's why this package doesn't support controlled - -- types; the table elements would be finalized prematurely. An Ada - -- implementation would also be within its rights to reclaim the - -- storage. Fortunately, GNAT doesn't do that. - - pragma Assert (not T.Locked); - pragma Assert (New_Last > Last_Allocated (T)); - - subtype Table_Length_Type is Table_Index_Type'Base - range 0 .. Table_Index_Type'Base'Last; - - Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); - Old_Allocated_Length : constant Table_Length_Type := - Old_Last_Allocated - First + 1; - - New_Length : constant Table_Length_Type := New_Last - First + 1; - New_Allocated_Length : Table_Length_Type; - - begin - if T.Table = Empty_Table_Ptr then - New_Allocated_Length := Table_Length_Type (Table_Initial); - else - New_Allocated_Length := - Table_Length_Type - (Long_Long_Integer (Old_Allocated_Length) * - (100 + Long_Long_Integer (Table_Increment)) / 100); - end if; - - -- Make sure it really did grow - - if New_Allocated_Length <= Old_Allocated_Length then - New_Allocated_Length := Old_Allocated_Length + 10; - end if; - - if New_Allocated_Length <= New_Length then - New_Allocated_Length := New_Length + 10; - end if; - - pragma Assert (New_Allocated_Length > Old_Allocated_Length); - pragma Assert (New_Allocated_Length > New_Length); - - T.P.Last_Allocated := First + New_Allocated_Length - 1; - - declare - subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); - type Old_Alloc_Ptr is access all Old_Alloc_Type; - - procedure Free is - new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); - function To_Old_Alloc_Ptr is - new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); - - subtype Alloc_Type is - Table_Type (First .. First + New_Allocated_Length - 1); - type Alloc_Ptr is access all Alloc_Type; - - function To_Table_Ptr is - new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); - - Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); - New_Table : constant Alloc_Ptr := new Alloc_Type; - - begin - if T.Table /= Empty_Table_Ptr then - New_Table (First .. Last (T)) := Old_Table (First .. Last (T)); - Free (Old_Table); - end if; - - T.Table := To_Table_Ptr (New_Table); - end; - - pragma Assert (New_Last <= Last_Allocated (T)); - pragma Assert (T.Table /= null); - pragma Assert (T.Table /= Empty_Table_Ptr); - end Grow; - - -------------------- - -- Increment_Last -- - -------------------- - - procedure Increment_Last (T : in out Instance) is - begin - pragma Assert (not T.Locked); - Allocate (T, 1); - end Increment_Last; - - ---------- - -- Init -- - ---------- - - procedure Init (T : in out Instance) is - pragma Assert (not T.Locked); - subtype Alloc_Type is Table_Type (First .. Last_Allocated (T)); - type Alloc_Ptr is access all Alloc_Type; - - procedure Free is new Ada.Unchecked_Deallocation (Alloc_Type, Alloc_Ptr); - function To_Alloc_Ptr is - new Ada.Unchecked_Conversion (Table_Ptr, Alloc_Ptr); - - Temp : Alloc_Ptr := To_Alloc_Ptr (T.Table); - - begin - if T.Table = Empty_Table_Ptr then - pragma Assert (T.P = (Last_Allocated | Last => First - 1)); - null; - else - Free (Temp); - T.Table := Empty_Table_Ptr; - T.P := (Last_Allocated | Last => First - 1); - end if; - end Init; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (T : Instance) return Boolean is - begin - return Last (T) = First - 1; - end Is_Empty; - - ---------- - -- Last -- - ---------- - - function Last (T : Instance) return Table_Last_Type is - begin - return T.P.Last; - end Last; - - -------------------- - -- Last_Allocated -- - -------------------- - - function Last_Allocated (T : Instance) return Table_Last_Type is - begin - return T.P.Last_Allocated; - end Last_Allocated; - - ---------- - -- Move -- - ---------- - - procedure Move (From, To : in out Instance) is - begin - pragma Assert (not From.Locked); - pragma Assert (not To.Locked); - pragma Assert (Is_Empty (To)); - To := From; - - From.Table := Empty_Table_Ptr; - From.Locked := False; - From.P.Last_Allocated := First - 1; - From.P.Last := First - 1; - pragma Assert (Is_Empty (From)); - end Move; - - ------------- - -- Release -- - ------------- - - procedure Release (T : in out Instance) is - pragma Assert (not T.Locked); - Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); - - function New_Last_Allocated return Table_Last_Type; - -- Compute the new value of Last_Allocated. This is normally equal to - -- Last, but if Release_Threshold /= 0, then we need to take that into - -- account. - - ------------------------ - -- New_Last_Allocated -- - ------------------------ - - function New_Last_Allocated return Table_Last_Type is - subtype Table_Length_Type is Table_Index_Type'Base - range 0 .. Table_Index_Type'Base'Last; - - Length : constant Table_Length_Type := Last (T) - First + 1; - - Comp_Size_In_Bytes : constant Table_Length_Type := - Table_Type'Component_Size / System.Storage_Unit; - - Length_Threshold : constant Table_Length_Type := - Table_Length_Type (Release_Threshold) / Comp_Size_In_Bytes; - - begin - if Release_Threshold = 0 or else Length < Length_Threshold then - return Last (T); - else - declare - Extra_Length : constant Table_Length_Type := Length / 1000; - begin - return (Length + Extra_Length) - 1 + First; - end; - end if; - end New_Last_Allocated; - - -- Local variables - - New_Last_Alloc : constant Table_Last_Type := New_Last_Allocated; - - -- Start of processing for Release - - begin - if New_Last_Alloc < Last_Allocated (T) then - pragma Assert (Last (T) < Last_Allocated (T)); - pragma Assert (T.Table /= Empty_Table_Ptr); - - declare - subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); - type Old_Alloc_Ptr is access all Old_Alloc_Type; - - procedure Free is - new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); - function To_Old_Alloc_Ptr is - new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); - - subtype Alloc_Type is Table_Type (First .. New_Last_Alloc); - type Alloc_Ptr is access all Alloc_Type; - - function To_Table_Ptr is - new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); - - Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); - New_Table : constant Alloc_Ptr := new Alloc_Type; - - begin - New_Table (First .. Last (T)) := Old_Table (First .. Last (T)); - T.P.Last_Allocated := New_Last_Alloc; - Free (Old_Table); - T.Table := To_Table_Ptr (New_Table); - end; - end if; - end Release; - - -------------- - -- Set_Item -- - -------------- - - procedure Set_Item - (T : in out Instance; - Index : Valid_Table_Index_Type; - Item : Table_Component_Type) - is - begin - pragma Assert (not T.Locked); - - -- If Set_Last is going to reallocate the table, we make a copy of Item, - -- in case the call was "Set_Item (T, X, T.Table (Y));", and Item is - -- passed by reference. Without the copy, we would deallocate the array - -- containing Item, leaving a dangling pointer. - - if Index > Last_Allocated (T) then - declare - Item_Copy : constant Table_Component_Type := Item; - begin - Set_Last (T, Index); - T.Table (Index) := Item_Copy; - end; - - else - if Index > Last (T) then - Set_Last (T, Index); - end if; - - T.Table (Index) := Item; - end if; - end Set_Item; - - -------------- - -- Set_Last -- - -------------- - - procedure Set_Last (T : in out Instance; New_Val : Table_Last_Type) is - begin - pragma Assert (not T.Locked); - if New_Val > Last_Allocated (T) then - Grow (T, New_Val); - end if; - - T.P.Last := New_Val; - end Set_Last; - - ---------------- - -- Sort_Table -- - ---------------- - - procedure Sort_Table (Table : in out Instance) is - Temp : Table_Component_Type; - -- A temporary position to simulate index 0 - - -- Local subprograms - - function Index_Of (Idx : Natural) return Table_Index_Type'Base; - -- Return index of Idx'th element of table - - function Lower_Than (Op1, Op2 : Natural) return Boolean; - -- Compare two components - - procedure Move (From : Natural; To : Natural); - -- Move one component - - package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than); - - -------------- - -- Index_Of -- - -------------- - - function Index_Of (Idx : Natural) return Table_Index_Type'Base is - J : constant Integer'Base := - Table_Index_Type'Base'Pos (First) + Idx - 1; - begin - return Table_Index_Type'Base'Val (J); - end Index_Of; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - begin - if From = 0 then - Table.Table (Index_Of (To)) := Temp; - - elsif To = 0 then - Temp := Table.Table (Index_Of (From)); - - else - Table.Table (Index_Of (To)) := - Table.Table (Index_Of (From)); - end if; - end Move; - - ---------------- - -- Lower_Than -- - ---------------- - - function Lower_Than (Op1, Op2 : Natural) return Boolean is - begin - if Op1 = 0 then - return Lt (Temp, Table.Table (Index_Of (Op2))); - - elsif Op2 = 0 then - return Lt (Table.Table (Index_Of (Op1)), Temp); - - else - return - Lt (Table.Table (Index_Of (Op1)), Table.Table (Index_Of (Op2))); - end if; - end Lower_Than; - - -- Start of processing for Sort_Table - - begin - Heap_Sort.Sort (Natural (Last (Table) - First) + 1); - end Sort_Table; - -end GNAT.Dynamic_Tables; diff --git a/gcc/ada/g-dyntab.ads b/gcc/ada/g-dyntab.ads deleted file mode 100644 index cb4b741..0000000 --- a/gcc/ada/g-dyntab.ads +++ /dev/null @@ -1,293 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . D Y N A M I C _ T A B L E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Resizable one dimensional array support - --- This package provides an implementation of dynamically resizable one --- dimensional arrays. The idea is to mimic the normal Ada semantics for --- arrays as closely as possible with the one additional capability of --- dynamically modifying the value of the Last attribute. - --- This package provides a facility similar to that of Ada.Containers.Vectors. - --- Note that these three interfaces should remain synchronized to keep as much --- coherency as possible among these related units: --- --- GNAT.Dynamic_Tables --- GNAT.Table --- Table (the compiler unit) - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; - -generic - type Table_Component_Type is private; - type Table_Index_Type is range <>; - - Table_Low_Bound : Table_Index_Type := Table_Index_Type'First; - Table_Initial : Positive := 8; - Table_Increment : Natural := 100; - Release_Threshold : Natural := 0; -- size in bytes - -package GNAT.Dynamic_Tables is - - -- Table_Component_Type and Table_Index_Type specify the type of the array, - -- Table_Low_Bound is the lower bound. The effect is roughly to declare: - - -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; - - -- The lower bound of Table_Index_Type is ignored. - - -- Table_Component_Type must not be a type with controlled parts. - - -- The Table_Initial value controls the allocation of the table when it is - -- first allocated. - - -- The Table_Increment value controls the amount of increase, if the table - -- has to be increased in size. The value given is a percentage value (e.g. - -- 100 = increase table size by 100%, i.e. double it). - - -- The Last and Set_Last subprograms provide control over the current - -- logical allocation. They are quite efficient, so they can be used - -- freely (expensive reallocation occurs only at major granularity - -- chunks controlled by the allocation parameters). - - -- Note: we do not make the table components aliased, since this would - -- restrict the use of table for discriminated types. If it is necessary - -- to take the access of a table element, use Unrestricted_Access. - - -- WARNING: On HPPA, the virtual addressing approach used in this unit is - -- incompatible with the indexing instructions on the HPPA. So when using - -- this unit, compile your application with -mdisable-indexing. - - -- WARNING: If the table is reallocated, then the address of all its - -- components will change. So do not capture the address of an element - -- and then use the address later after the table may be reallocated. One - -- tricky case of this is passing an element of the table to a subprogram - -- by reference where the table gets reallocated during the execution of - -- the subprogram. The best rule to follow is never to pass a table element - -- as a parameter except for the case of IN mode parameters with scalar - -- values. - - pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First); - - subtype Valid_Table_Index_Type is Table_Index_Type'Base - range Table_Low_Bound .. Table_Index_Type'Base'Last; - subtype Table_Last_Type is Table_Index_Type'Base - range Table_Low_Bound - 1 .. Table_Index_Type'Base'Last; - - -- Table_Component_Type must not be a type with controlled parts. - - -- The Table_Initial value controls the allocation of the table when it is - -- first allocated. - - -- The Table_Increment value controls the amount of increase, if the table - -- has to be increased in size. The value given is a percentage value (e.g. - -- 100 = increase table size by 100%, i.e. double it). - - -- The Last and Set_Last subprograms provide control over the current - -- logical allocation. They are quite efficient, so they can be used - -- freely (expensive reallocation occurs only at major granularity - -- chunks controlled by the allocation parameters). - - -- Note: we do not make the table components aliased, since this would - -- restrict the use of table for discriminated types. If it is necessary - -- to take the access of a table element, use Unrestricted_Access. - - type Table_Type is - array (Valid_Table_Index_Type range <>) of Table_Component_Type; - subtype Big_Table_Type is - Table_Type (Table_Low_Bound .. Valid_Table_Index_Type'Last); - -- We work with pointers to a bogus array type that is constrained with - -- the maximum possible range bound. This means that the pointer is a thin - -- pointer, which is more efficient. Since subscript checks in any case - -- must be on the logical, rather than physical bounds, safety is not - -- compromised by this approach. - - -- To get subscript checking, rename a slice of the Table, like this: - - -- Table : Table_Type renames T.Table (First .. Last (T)); - - -- and then refer to components of Table. - - type Table_Ptr is access all Big_Table_Type; - for Table_Ptr'Storage_Size use 0; - -- The table is actually represented as a pointer to allow reallocation - - type Table_Private is private; - -- Table private data that is not exported in Instance - - -- Private use only: - subtype Empty_Table_Array_Type is - Table_Type (Table_Low_Bound .. Table_Low_Bound - 1); - type Empty_Table_Array_Ptr is access all Empty_Table_Array_Type; - Empty_Table_Array : aliased Empty_Table_Array_Type; - function Empty_Table_Array_Ptr_To_Table_Ptr is - new Ada.Unchecked_Conversion (Empty_Table_Array_Ptr, Table_Ptr); - Empty_Table_Ptr : constant Table_Ptr := - Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access); - -- End private use only. The above are used to initialize Table to point to - -- an empty array. - - type Instance is record - Table : Table_Ptr := Empty_Table_Ptr; - -- The table itself. The lower bound is the value of First. Logically - -- the upper bound is the current value of Last (although the actual - -- size of the allocated table may be larger than this). The program may - -- only access and modify Table entries in the range First .. Last. - -- - -- It's a good idea to access this via a renaming of a slice, in order - -- to ensure bounds checking, as in: - -- - -- Tab : Table_Type renames X.Table (First .. X.Last); - -- - -- Note: The Table component must come first. See declarations of - -- SCO_Unit_Table and SCO_Table in scos.h. - - Locked : Boolean := False; - -- Table reallocation is permitted only if this is False. A client may - -- set Locked to True, in which case any operation that might expand or - -- shrink the table will cause an assertion failure. While a table is - -- locked, its address in memory remains fixed and unchanging. - - P : Table_Private; - end record; - - function Is_Empty (T : Instance) return Boolean; - pragma Inline (Is_Empty); - - procedure Init (T : in out Instance); - -- Reinitializes the table to empty. There is no need to call this before - -- using a table; tables default to empty. - - procedure Free (T : in out Instance) renames Init; - - function First return Table_Index_Type; - pragma Inline (First); - -- Export First as synonym for Table_Low_Bound (parallel with use of Last) - - function Last (T : Instance) return Table_Last_Type; - pragma Inline (Last); - -- Returns the current value of the last used entry in the table, which can - -- then be used as a subscript for Table. - - procedure Release (T : in out Instance); - -- Storage is allocated in chunks according to the values given in the - -- Table_Initial and Table_Increment parameters. If Release_Threshold is - -- 0 or the length of the table does not exceed this threshold then a call - -- to Release releases all storage that is allocated, but is not logically - -- part of the current array value; otherwise the call to Release leaves - -- the current array value plus 0.1% of the current table length free - -- elements located at the end of the table. This parameter facilitates - -- reopening large tables and adding a few elements without allocating a - -- chunk of memory. In both cases current array values are not affected by - -- this call. - - procedure Set_Last (T : in out Instance; New_Val : Table_Last_Type); - pragma Inline (Set_Last); - -- This procedure sets Last to the indicated value. If necessary the table - -- is reallocated to accommodate the new value (i.e. on return the - -- allocated table has an upper bound of at least Last). If Set_Last - -- reduces the size of the table, then logically entries are removed from - -- the table. If Set_Last increases the size of the table, then new entries - -- are logically added to the table. - - procedure Increment_Last (T : in out Instance); - pragma Inline (Increment_Last); - -- Adds 1 to Last (same as Set_Last (Last + 1)) - - procedure Decrement_Last (T : in out Instance); - pragma Inline (Decrement_Last); - -- Subtracts 1 from Last (same as Set_Last (Last - 1)) - - procedure Append (T : in out Instance; New_Val : Table_Component_Type); - pragma Inline (Append); - -- Appends New_Val onto the end of the table - -- Equivalent to: - -- Increment_Last (T); - -- T.Table (T.Last) := New_Val; - - procedure Append_All (T : in out Instance; New_Vals : Table_Type); - -- Appends all components of New_Vals - - procedure Set_Item - (T : in out Instance; - Index : Valid_Table_Index_Type; - Item : Table_Component_Type); - pragma Inline (Set_Item); - -- Put Item in the table at position Index. If Index points to an existing - -- item (i.e. it is in the range First .. Last (T)), the item is replaced. - -- Otherwise (i.e. Index > Last (T)), the table is expanded, and Last is - -- set to Index. - - procedure Move (From, To : in out Instance); - -- Moves from From to To, and sets From to empty - - procedure Allocate (T : in out Instance; Num : Integer := 1); - pragma Inline (Allocate); - -- Adds Num to Last - - generic - with procedure Action - (Index : Valid_Table_Index_Type; - Item : Table_Component_Type; - Quit : in out Boolean) is <>; - procedure For_Each (Table : Instance); - -- Calls procedure Action for each component of the table, or until one of - -- these calls set Quit to True. - - generic - with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; - procedure Sort_Table (Table : in out Instance); - -- This procedure sorts the components of the table into ascending order - -- making calls to Lt to do required comparisons, and using assignments - -- to move components around. The Lt function returns True if Comp1 is - -- less than Comp2 (in the sense of the desired sort), and False if Comp1 - -- is greater than Comp2. For equal objects it does not matter if True or - -- False is returned (it is slightly more efficient to return False). The - -- sort is not stable (the order of equal items in the table is not - -- preserved). - -private - - type Table_Private is record - Last_Allocated : Table_Last_Type := Table_Low_Bound - 1; - -- Subscript of the maximum entry in the currently allocated table. - -- Initial value ensures that we initially allocate the table. - - Last : Table_Last_Type := Table_Low_Bound - 1; - -- Current value of Last function - - -- Invariant: Last <= Last_Allocated - end record; - -end GNAT.Dynamic_Tables; diff --git a/gcc/ada/g-eacodu.adb b/gcc/ada/g-eacodu.adb deleted file mode 100644 index f622552..0000000 --- a/gcc/ada/g-eacodu.adb +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default (Unix) version - -separate (GNAT.Exception_Actions) -procedure Core_Dump (Occurrence : Exception_Occurrence) is - pragma Unreferenced (Occurrence); - SIG_ABORT : constant := 6; - procedure C_Abort; - pragma Import (C, C_Abort, "abort"); - procedure Signal (Signum : Integer; Handler : System.Address); - pragma Import (C, Signal, "signal"); - -begin - -- Unregister the default handler for SIGABRT, since otherwise we would - -- simply get a standard Ada exception, which is not what we want. - - Signal (SIG_ABORT, System.Null_Address); - C_Abort; -end Core_Dump; diff --git a/gcc/ada/g-encstr.adb b/gcc/ada/g-encstr.adb deleted file mode 100644 index 80ca6d0..0000000 --- a/gcc/ada/g-encstr.adb +++ /dev/null @@ -1,258 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . E N C O D E _ S T R I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces; use Interfaces; - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_Cnv; use System.WCh_Cnv; - -package body GNAT.Encode_String is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Bad; - pragma No_Return (Bad); - -- Raise error for bad character code - - procedure Past_End; - pragma No_Return (Past_End); - -- Raise error for off end of string - - --------- - -- Bad -- - --------- - - procedure Bad is - begin - raise Constraint_Error with - "character cannot be encoded with given Encoding_Method"; - end Bad; - - ------------------------ - -- Encode_Wide_String -- - ------------------------ - - function Encode_Wide_String (S : Wide_String) return String is - Long : constant Natural := WC_Longest_Sequences (Encoding_Method); - Result : String (1 .. S'Length * Long); - Length : Natural; - begin - Encode_Wide_String (S, Result, Length); - return Result (1 .. Length); - end Encode_Wide_String; - - procedure Encode_Wide_String - (S : Wide_String; - Result : out String; - Length : out Natural) - is - Ptr : Natural; - - begin - Ptr := S'First; - for J in S'Range loop - Encode_Wide_Character (S (J), Result, Ptr); - end loop; - - Length := Ptr - S'First; - end Encode_Wide_String; - - ----------------------------- - -- Encode_Wide_Wide_String -- - ----------------------------- - - function Encode_Wide_Wide_String (S : Wide_Wide_String) return String is - Long : constant Natural := WC_Longest_Sequences (Encoding_Method); - Result : String (1 .. S'Length * Long); - Length : Natural; - begin - Encode_Wide_Wide_String (S, Result, Length); - return Result (1 .. Length); - end Encode_Wide_Wide_String; - - procedure Encode_Wide_Wide_String - (S : Wide_Wide_String; - Result : out String; - Length : out Natural) - is - Ptr : Natural; - - begin - Ptr := S'First; - for J in S'Range loop - Encode_Wide_Wide_Character (S (J), Result, Ptr); - end loop; - - Length := Ptr - S'First; - end Encode_Wide_Wide_String; - - --------------------------- - -- Encode_Wide_Character -- - --------------------------- - - procedure Encode_Wide_Character - (Char : Wide_Character; - Result : in out String; - Ptr : in out Natural) - is - begin - Encode_Wide_Wide_Character - (Wide_Wide_Character'Val (Wide_Character'Pos (Char)), Result, Ptr); - - exception - when Constraint_Error => - Bad; - end Encode_Wide_Character; - - -------------------------------- - -- Encode_Wide_Wide_Character -- - -------------------------------- - - procedure Encode_Wide_Wide_Character - (Char : Wide_Wide_Character; - Result : in out String; - Ptr : in out Natural) - is - U : Unsigned_32; - - procedure Out_Char (C : Character); - pragma Inline (Out_Char); - -- Procedure to store one character for instantiation below - - -------------- - -- Out_Char -- - -------------- - - procedure Out_Char (C : Character) is - begin - if Ptr > Result'Last then - Past_End; - else - Result (Ptr) := C; - Ptr := Ptr + 1; - end if; - end Out_Char; - - -- Start of processing for Encode_Wide_Wide_Character; - - begin - -- Efficient code for UTF-8 case - - if Encoding_Method = WCEM_UTF8 then - - -- Note: for details of UTF8 encoding see RFC 3629 - - U := Unsigned_32 (Wide_Wide_Character'Pos (Char)); - - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - if U <= 16#00_007F# then - Out_Char (Character'Val (U)); - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - elsif U <= 16#00_07FF# then - Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- 16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx - - elsif U <= 16#00_FFFF# then - Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - - elsif U <= 16#10_FFFF# then - Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - elsif U <= 16#03FF_FFFF# then - Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- All other cases are invalid character codes, not this includes: - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx 10xxxxxx - - -- since Wide_Wide_Character values cannot exceed 16#3F_FFFF# - - else - Bad; - end if; - - -- All encoding methods other than UTF-8 - - else - Non_UTF8 : declare - procedure UTF_32_To_String is - new UTF_32_To_Char_Sequence (Out_Char); - -- Instantiate conversion procedure with above Out_Char routine - - begin - UTF_32_To_String - (UTF_32_Code (Wide_Wide_Character'Pos (Char)), Encoding_Method); - - exception - when Constraint_Error => - Bad; - end Non_UTF8; - end if; - end Encode_Wide_Wide_Character; - - -------------- - -- Past_End -- - -------------- - - procedure Past_End is - begin - raise Constraint_Error with "past end of string"; - end Past_End; - -end GNAT.Encode_String; diff --git a/gcc/ada/g-encstr.ads b/gcc/ada/g-encstr.ads deleted file mode 100644 index af98276..0000000 --- a/gcc/ada/g-encstr.ads +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . E N C O D E _ S T R I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This generic package provides utility routines for converting from --- Wide_String or Wide_Wide_String to encoded String using a specified --- encoding convention, which is supplied as the generic parameter. If --- this parameter is a known at compile time constant (e.g. a constant --- defined in System.WCh_Con), the instantiation is specialized so that --- it applies only to this specified coding. - --- Note: this package is only about encoding sequences of 16- or 32-bit --- characters into a sequence of 8-bit codes. It knows nothing at all about --- the character encodings being used for the input Wide_Character and --- Wide_Wide_Character values, although some of the encoding methods (notably --- JIS and EUC) have built in assumptions about the range of possible input --- code values. Most often the input will be Unicode/ISO-10646 as specified by --- the Ada RM, but this package does not make any assumptions about the --- character coding, and in the case of UTF-8 all possible code values can be --- encoded. See also the packages Ada.Wide_[Wide_]Characters.Unicode for --- unicode specific functions. - --- Note on brackets encoding (WCEM_Brackets). On input, upper half characters --- can be represented as ["hh"] but the routines in this package will only use --- brackets encodings for codes higher than 16#FF#, so upper half characters --- will be output as single Character values. - -with System.WCh_Con; - -generic - Encoding_Method : System.WCh_Con.WC_Encoding_Method; - -package GNAT.Encode_String is - pragma Pure; - - function Encode_Wide_String (S : Wide_String) return String; - pragma Inline (Encode_Wide_String); - -- Encode the given Wide_String, returning a String encoded using the - -- given encoding method. Constraint_Error will be raised if the encoding - -- method cannot accommodate the input data. - - procedure Encode_Wide_String - (S : Wide_String; - Result : out String; - Length : out Natural); - -- Encode the given Wide_String, storing the encoded string in Result, - -- with Length being set to the length of the encoded string. The caller - -- must ensure that Result is long enough (see useful constants defined - -- in System.WCh_Con: WC_Longest_Sequence, WC_Longest_Sequences). If the - -- length of Result is insufficient Constraint_Error will be raised. - -- Constraint_Error will also be raised if the encoding method cannot - -- accommodate the input data. - - function Encode_Wide_Wide_String (S : Wide_Wide_String) return String; - pragma Inline (Encode_Wide_Wide_String); - -- Same as above function but for Wide_Wide_String input - - procedure Encode_Wide_Wide_String - (S : Wide_Wide_String; - Result : out String; - Length : out Natural); - -- Same as above procedure, but for Wide_Wide_String input - - procedure Encode_Wide_Character - (Char : Wide_Character; - Result : in out String; - Ptr : in out Natural); - pragma Inline (Encode_Wide_Character); - -- This is a lower level procedure that encodes the single character Char. - -- The output is stored in Result starting at Result (Ptr), and Ptr is - -- updated past the stored value. Constraint_Error is raised if Result - -- is not long enough to accommodate the result, or if the encoding method - -- specified does not accommodate the input character value, or if Ptr is - -- outside the bounds of the Result string. - - procedure Encode_Wide_Wide_Character - (Char : Wide_Wide_Character; - Result : in out String; - Ptr : in out Natural); - -- Same as above procedure but with Wide_Wide_Character input - -end GNAT.Encode_String; diff --git a/gcc/ada/g-enutst.ads b/gcc/ada/g-enutst.ads deleted file mode 100644 index 2422a2d..0000000 --- a/gcc/ada/g-enutst.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . E N C O D E _ U T F 8 _ S T R I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 pre-instantiation of GNAT.Encode_String for the --- common case of UTF-8 encoding. As noted in the documentation of that --- package, this UTF-8 instantiation is efficient and specialized so that --- it has only the code for the UTF-8 case. See g-encstr.ads for full --- documentation on this package. - -with GNAT.Encode_String; - -with System.WCh_Con; - -package GNAT.Encode_UTF8_String is - new GNAT.Encode_String (System.WCh_Con.WCEM_UTF8); diff --git a/gcc/ada/g-excact.adb b/gcc/ada/g-excact.adb deleted file mode 100644 index ed454ce..0000000 --- a/gcc/ada/g-excact.adb +++ /dev/null @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X C E P T I O N _ A C T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; -with System; -with System.Soft_Links; use System.Soft_Links; -with System.Standard_Library; use System.Standard_Library; -with System.Exception_Table; use System.Exception_Table; - -package body GNAT.Exception_Actions is - - Global_Action : Exception_Action; - pragma Import (C, Global_Action, "__gnat_exception_actions_global_action"); - -- Imported from Ada.Exceptions. Any change in the external name needs to - -- be coordinated with a-except.adb - - Raise_Hook_Initialized : Boolean; - pragma Import - (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized"); - - function To_Raise_Action is new Ada.Unchecked_Conversion - (Exception_Action, Raise_Action); - - -- ??? Would be nice to have this in System.Standard_Library - function To_Data is new Ada.Unchecked_Conversion - (Exception_Id, Exception_Data_Ptr); - function To_Id is new Ada.Unchecked_Conversion - (Exception_Data_Ptr, Exception_Id); - - ---------------------------- - -- Register_Global_Action -- - ---------------------------- - - procedure Register_Global_Action (Action : Exception_Action) is - begin - Lock_Task.all; - Global_Action := Action; - Unlock_Task.all; - end Register_Global_Action; - - ------------------------ - -- Register_Id_Action -- - ------------------------ - - procedure Register_Id_Action - (Id : Exception_Id; - Action : Exception_Action) - is - begin - if Id = Null_Id then - raise Program_Error; - end if; - - Lock_Task.all; - To_Data (Id).Raise_Hook := To_Raise_Action (Action); - Raise_Hook_Initialized := True; - Unlock_Task.all; - end Register_Id_Action; - - --------------- - -- Core_Dump -- - --------------- - - procedure Core_Dump (Occurrence : Exception_Occurrence) is separate; - - ---------------- - -- Name_To_Id -- - ---------------- - - function Name_To_Id (Name : String) return Exception_Id is - begin - return To_Id (Internal_Exception (Name, Create_If_Not_Exist => False)); - end Name_To_Id; - - --------------------------------- - -- Registered_Exceptions_Count -- - --------------------------------- - - function Registered_Exceptions_Count return Natural renames - System.Exception_Table.Registered_Exceptions_Count; - - ------------------------------- - -- Get_Registered_Exceptions -- - ------------------------------- - -- This subprogram isn't an iterator to avoid concurrency problems, - -- since the exceptions are registered dynamically. Since we have to lock - -- the runtime while computing this array, this means that any callback in - -- an active iterator would be unable to access the runtime. - - procedure Get_Registered_Exceptions - (List : out Exception_Id_Array; - Last : out Integer) - is - Ids : Exception_Data_Array (List'Range); - begin - Get_Registered_Exceptions (Ids, Last); - - for L in List'First .. Last loop - List (L) := To_Id (Ids (L)); - end loop; - end Get_Registered_Exceptions; - -end GNAT.Exception_Actions; diff --git a/gcc/ada/g-excact.ads b/gcc/ada/g-excact.ads deleted file mode 100644 index 44f067d..0000000 --- a/gcc/ada/g-excact.ads +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . E X C E P T I O N _ A C T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides support for callbacks on exceptions - --- These callbacks are called immediately when either a specific exception, --- or any exception, is raised, before any other actions taken by raise, in --- particular before any unwinding of the stack occurs. - --- Callbacks for specific exceptions are registered through calls to --- Register_Id_Action. Here is an example of code that uses this package to --- automatically core dump when the exception Constraint_Error is raised. - --- Register_Id_Action (Constraint_Error'Identity, Core_Dump'Access); - --- Subprograms are also provided to list the currently registered exceptions, --- or to convert from a string to an exception id. - --- This package can easily be extended, for instance to provide a callback --- whenever an exception matching a regular expression is raised. The idea --- is to register a global action, called whenever any exception is raised. --- Dispatching can then be done directly in this global action callback. - -with Ada.Exceptions; use Ada.Exceptions; - -package GNAT.Exception_Actions is - - type Exception_Action is access - procedure (Occurrence : Exception_Occurrence); - -- General callback type whenever an exception is raised. The callback - -- procedure must not propagate an exception (execution of the program - -- is erroneous if such an exception is propagated). - - procedure Register_Global_Action (Action : Exception_Action); - -- Action will be called whenever an exception is raised. Only one such - -- action can be registered at any given time, and registering a new action - -- will override any previous action that might have been registered. - -- - -- Action is called before the exception is propagated to user's code. - -- If Action is null, this will in effect cancel all exception actions. - - procedure Register_Id_Action - (Id : Exception_Id; - Action : Exception_Action); - -- Action will be called whenever an exception of type Id is raised. Only - -- one such action can be registered for each exception id, and registering - -- a new action will override any previous action registered for this - -- Exception_Id. Program_Error is raised if Id is Null_Id. - - function Name_To_Id (Name : String) return Exception_Id; - -- Convert an exception name to an exception id. Null_Id is returned - -- if no such exception exists. Name must be an all upper-case string, - -- or the exception will not be found. The exception name must be fully - -- qualified (but not including Standard). It is not possible to convert - -- an exception that is declared within an unlabeled block. - -- - -- Note: All non-predefined exceptions will return Null_Id for programs - -- compiled with pragma Restriction (No_Exception_Registration) - - function Registered_Exceptions_Count return Natural; - -- Return the number of exceptions that have been registered so far. - -- Exceptions declared locally will not appear in this list until their - -- block has been executed at least once. - -- - -- Note: The count includes only predefined exceptions for programs - -- compiled with pragma Restrictions (No_Exception_Registration). - - type Exception_Id_Array is array (Natural range <>) of Exception_Id; - - procedure Get_Registered_Exceptions - (List : out Exception_Id_Array; - Last : out Integer); - -- Return the list of registered exceptions. - -- Last is the index in List of the last exception returned. - -- - -- An exception is registered the first time the block containing its - -- declaration is elaborated. Exceptions defined at library-level are - -- therefore immediately visible, whereas exceptions declared in local - -- blocks will not be visible until the block is executed at least once. - -- - -- Note: The list contains only the predefined exceptions if the program - -- is compiled with pragma Restrictions (No_Exception_Registration); - - procedure Core_Dump (Occurrence : Exception_Occurrence); - -- Dump memory (called a core dump in some systems) if supported by the - -- OS (most unix systems), and abort execution of the application. Under - -- Windows this procedure will not dump the memory, it will only abort - -- execution. - -end GNAT.Exception_Actions; diff --git a/gcc/ada/g-except.ads b/gcc/ada/g-except.ads deleted file mode 100644 index 69ae928..0000000 --- a/gcc/ada/g-except.ads +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface for raising predefined exceptions --- with an exception message. It can be used from Pure units. - --- There is no prohibition in Ada that prevents exceptions being raised --- from within pure units. The raise statement is perfectly acceptable. - --- However, it is not normally possible to raise an exception with a --- message because the routine Ada.Exceptions.Raise_Exception is not in --- a Pure unit. This is an annoying and unnecessary restriction and this --- package allows for raising the standard predefined exceptions at least. - -package GNAT.Exceptions is - pragma Pure; - - type Exception_Type is limited null record; - -- Type used to specify which exception to raise - - -- Really Exception_Type is Exception_Id, but Exception_Id can't be - -- used directly since it is declared in the non-pure unit Ada.Exceptions, - - -- Exception_Id is in fact simply a pointer to the type Exception_Data - -- declared in System.Standard_Library (which is also non-pure). So what - -- we do is to define it here as a by reference type (any by reference - -- type would do), and then Import the definitions from Standard_Library. - -- Since this is a by reference type, these will be passed by reference, - -- which has the same effect as passing a pointer. - - -- This type is not private because keeping it by reference would require - -- defining it in a way (e.g. using a tagged type) that would drag in other - -- run-time files, which is unwanted in the case of e.g. Ravenscar where we - -- want to minimize the number of run-time files needed by default. - - CE : constant Exception_Type; -- Constraint_Error - PE : constant Exception_Type; -- Program_Error - SE : constant Exception_Type; -- Storage_Error - TE : constant Exception_Type; -- Tasking_Error - -- One of these constants is used in the call to specify the exception - - procedure Raise_Exception (E : Exception_Type; Message : String); - pragma Import (Ada, Raise_Exception, "__gnat_raise_exception"); - pragma No_Return (Raise_Exception); - -- Raise specified exception with specified message - -private - pragma Import (C, CE, "constraint_error"); - pragma Import (C, PE, "program_error"); - pragma Import (C, SE, "storage_error"); - pragma Import (C, TE, "tasking_error"); - -- References to the exception structures in the standard library - -end GNAT.Exceptions; diff --git a/gcc/ada/g-exctra.adb b/gcc/ada/g-exctra.adb deleted file mode 100644 index 8844fcf..0000000 --- a/gcc/ada/g-exctra.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . E X C E P T I O N _ T R A C E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-exctra.ads b/gcc/ada/g-exctra.ads deleted file mode 100644 index aa264ba..0000000 --- a/gcc/ada/g-exctra.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . E X C E P T I O N _ T R A C E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface allowing to control *automatic* output --- to standard error upon exception occurrences (as opposed to explicit --- generation of traceback information using System.Traceback). - --- See file s-exctra.ads for full documentation of the interface - -with System.Exception_Traces; -package GNAT.Exception_Traces renames System.Exception_Traces; diff --git a/gcc/ada/g-expect.adb b/gcc/ada/g-expect.adb deleted file mode 100644 index d7bb2dd..0000000 --- a/gcc/ada/g-expect.adb +++ /dev/null @@ -1,1488 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . E X P E C T -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; -with System.OS_Constants; use System.OS_Constants; -with Ada.Calendar; use Ada.Calendar; - -with GNAT.IO; use GNAT.IO; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Regpat; use GNAT.Regpat; - -with Ada.Unchecked_Deallocation; - -package body GNAT.Expect is - - type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; - - Expect_Process_Died : constant Expect_Match := -100; - Expect_Internal_Error : constant Expect_Match := -101; - -- Additional possible outputs of Expect_Internal. These are not visible in - -- the spec because the user will never see them. - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean); - -- Internal function used to read from the process Descriptor. - -- - -- Several outputs are possible: - -- Result=Expect_Timeout, if no output was available before the timeout - -- expired. - -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters - -- had to be discarded from the internal buffer of Descriptor. - -- Result=Express_Process_Died if one of the processes was terminated. - -- That process's Input_Fd is set to Invalid_FD - -- Result=Express_Internal_Error - -- Result=, indicates how many characters were added to the - -- internal buffer. These characters are from indexes - -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index - -- Process_Died is raised if the process is no longer valid. - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class); - -- Reinitialize the internal buffer. - -- The buffer is deleted up to the end of the last match. - - procedure Free is new Ada.Unchecked_Deallocation - (Pattern_Matcher, Pattern_Matcher_Access); - - procedure Free is new Ada.Unchecked_Deallocation - (Filter_List_Elem, Filter_List); - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type); - -- Call all the filters that have the appropriate type. - -- This function does nothing if the filters are locked - - ------------------------------ - -- Target dependent section -- - ------------------------------ - - function Dup (Fd : File_Descriptor) return File_Descriptor; - pragma Import (C, Dup); - - procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); - pragma Import (C, Dup2); - - procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); - pragma Import (C, Kill, "__gnat_kill"); - -- if Close is set to 1 all OS resources used by the Pid must be freed - - function Create_Pipe (Pipe : not null access Pipe_Type) return Integer; - pragma Import (C, Create_Pipe, "__gnat_pipe"); - - function Poll - (Fds : System.Address; - Num_Fds : Integer; - Timeout : Integer; - Dead_Process : access Integer; - Is_Set : System.Address) return Integer; - pragma Import (C, Poll, "__gnat_expect_poll"); - -- Check whether there is any data waiting on the file descriptors - -- Fds, and wait if there is none, at most Timeout milliseconds - -- Returns -1 in case of error, 0 if the timeout expired before - -- data became available. - -- - -- Is_Set is an array of the same size as FDs and elements are set to 1 if - -- data is available for the corresponding File Descriptor, 0 otherwise. - -- - -- If a process dies, then Dead_Process is set to the index of the - -- corresponding file descriptor. - - function Waitpid (Pid : Process_Id) return Integer; - pragma Import (C, Waitpid, "__gnat_waitpid"); - -- Wait for a specific process id, and return its exit code - - --------- - -- "+" -- - --------- - - function "+" (S : String) return GNAT.OS_Lib.String_Access is - begin - return new String'(S); - end "+"; - - --------- - -- "+" -- - --------- - - function "+" - (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access - is - begin - return new GNAT.Regpat.Pattern_Matcher'(P); - end "+"; - - ---------------- - -- Add_Filter -- - ---------------- - - procedure Add_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function; - Filter_On : Filter_Type := Output; - User_Data : System.Address := System.Null_Address; - After : Boolean := False) - is - Current : Filter_List := Descriptor.Filters; - - begin - if After then - while Current /= null and then Current.Next /= null loop - Current := Current.Next; - end loop; - - if Current = null then - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - else - Current.Next := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => null); - end if; - - else - Descriptor.Filters := - new Filter_List_Elem' - (Filter => Filter, Filter_On => Filter_On, - User_Data => User_Data, Next => Descriptor.Filters); - end if; - end Add_Filter; - - ------------------ - -- Call_Filters -- - ------------------ - - procedure Call_Filters - (Pid : Process_Descriptor'Class; - Str : String; - Filter_On : Filter_Type) - is - Current_Filter : Filter_List; - - begin - if Pid.Filters_Lock = 0 then - Current_Filter := Pid.Filters; - - while Current_Filter /= null loop - if Current_Filter.Filter_On = Filter_On then - Current_Filter.Filter - (Pid, Str, Current_Filter.User_Data); - end if; - - Current_Filter := Current_Filter.Next; - end loop; - end if; - end Call_Filters; - - ----------- - -- Close -- - ----------- - - procedure Close - (Descriptor : in out Process_Descriptor; - Status : out Integer) - is - Current_Filter : Filter_List; - Next_Filter : Filter_List; - - begin - if Descriptor.Input_Fd /= Invalid_FD then - Close (Descriptor.Input_Fd); - end if; - - if Descriptor.Error_Fd /= Descriptor.Output_Fd then - Close (Descriptor.Error_Fd); - end if; - - Close (Descriptor.Output_Fd); - - -- ??? Should have timeouts for different signals - - if Descriptor.Pid > 0 then -- see comment in Send_Signal - Kill (Descriptor.Pid, Sig_Num => 9, Close => 0); - end if; - - GNAT.OS_Lib.Free (Descriptor.Buffer); - Descriptor.Buffer_Size := 0; - - Current_Filter := Descriptor.Filters; - - while Current_Filter /= null loop - Next_Filter := Current_Filter.Next; - Free (Current_Filter); - Current_Filter := Next_Filter; - end loop; - - Descriptor.Filters := null; - - -- Check process id (see comment in Send_Signal) - - if Descriptor.Pid > 0 then - Status := Waitpid (Descriptor.Pid); - else - raise Invalid_Process; - end if; - end Close; - - procedure Close (Descriptor : in out Process_Descriptor) is - Status : Integer; - pragma Unreferenced (Status); - begin - Close (Descriptor, Status); - end Close; - - ------------ - -- Expect -- - ------------ - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - begin - if Regexp = "" then - Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); - else - Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - begin - pragma Assert (Matched'First = 0); - if Regexp = "" then - Expect - (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); - else - Expect - (Descriptor, Result, Compile (Regexp), Matched, Timeout, - Full_Buffer); - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - pragma Warnings (Off, Matched); - begin - Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; - Timeout_Tmp : Integer := Timeout; - - begin - pragma Assert (Matched'First = 0); - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - - -- Else try to read new input - - Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); - - case N is - when Expect_Internal_Error - | Expect_Process_Died - => - raise Process_Died; - - when Expect_Full_Buffer - | Expect_Timeout - => - Result := N; - return; - - when others => - null; -- See below - end case; - - -- Calculate the timeout for the next turn - - -- Note that Timeout is, from the caller's perspective, the maximum - -- time until a match, not the maximum time until some output is - -- read, and thus cannot be reused as is for Expect_Internal. - - if Timeout /= -1 then - Timeout_Tmp := Integer (Try_Until - Clock) * 1000; - - if Timeout_Tmp < 0 then - Result := Expect_Timeout; - exit; - end if; - end if; - end loop; - - -- Even if we had the general timeout above, we have to test that the - -- last test we read from the external process didn't match. - - Match - (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); - - if Matched (0).First /= 0 then - Result := 1; - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - - Matched : GNAT.Regpat.Match_Array (0 .. 0); - pragma Warnings (Off, Matched); - - begin - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - pragma Warnings (Off, Matched); - begin - Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Matched : GNAT.Regpat.Match_Array (0 .. 0); - pragma Warnings (Off, Matched); - begin - Expect (Result, Regexps, Matched, Timeout, Full_Buffer); - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - Patterns : Compiled_Regexp_Array (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Regexps'Range loop - Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); - end loop; - - Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); - - for J in Regexps'Range loop - Free (Patterns (J)); - end loop; - end Expect; - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - begin - pragma Assert (Matched'First = 0); - - Reinitialize_Buffer (Descriptor); - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - if Descriptor.Buffer /= null then - for J in Regexps'Range loop - Match - (Regexps (J).all, - Descriptor.Buffer (1 .. Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Descriptor.Last_Match_Start := Matched (0).First; - Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end loop; - end if; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - case N is - when Expect_Internal_Error - | Expect_Process_Died - => - raise Process_Died; - - when Expect_Full_Buffer - | Expect_Timeout - => - Result := N; - return; - - when others => - null; -- Continue - end case; - end loop; - end Expect; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False) - is - N : Expect_Match; - Descriptors : Array_Of_Pd (Regexps'Range); - - begin - pragma Assert (Matched'First = 0); - - for J in Descriptors'Range loop - Descriptors (J) := Regexps (J).Descriptor; - - if Descriptors (J) /= null then - Reinitialize_Buffer (Regexps (J).Descriptor.all); - end if; - end loop; - - loop - -- First, test if what is already in the buffer matches (This is - -- required if this package is used in multi-task mode, since one of - -- the tasks might have added something in the buffer, and we don't - -- want other tasks to wait for new input to be available before - -- checking the regexps). - - for J in Regexps'Range loop - if Regexps (J).Regexp /= null - and then Regexps (J).Descriptor /= null - then - Match (Regexps (J).Regexp.all, - Regexps (J).Descriptor.Buffer - (1 .. Regexps (J).Descriptor.Buffer_Index), - Matched); - - if Matched (0) /= No_Match then - Result := Expect_Match (J); - Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; - Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; - return; - end if; - end if; - end loop; - - Expect_Internal (Descriptors, N, Timeout, Full_Buffer); - - case N is - when Expect_Internal_Error - | Expect_Process_Died - => - raise Process_Died; - - when Expect_Full_Buffer - | Expect_Timeout - => - Result := N; - return; - - when others => - null; -- Continue - end case; - end loop; - end Expect; - - --------------------- - -- Expect_Internal -- - --------------------- - - procedure Expect_Internal - (Descriptors : in out Array_Of_Pd; - Result : out Expect_Match; - Timeout : Integer; - Full_Buffer : Boolean) - is - Num_Descriptors : Integer; - Buffer_Size : Integer := 0; - - N : Integer; - - type File_Descriptor_Array is - array (0 .. Descriptors'Length - 1) of File_Descriptor; - Fds : aliased File_Descriptor_Array; - Fds_Count : Natural := 0; - - Fds_To_Descriptor : array (Fds'Range) of Integer; - -- Maps file descriptor entries from Fds to entries in Descriptors. - -- They do not have the same index when entries in Descriptors are null. - - type Integer_Array is array (Fds'Range) of Integer; - Is_Set : aliased Integer_Array; - - begin - for J in Descriptors'Range loop - if Descriptors (J) /= null then - Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; - Fds_To_Descriptor (Fds'First + Fds_Count) := J; - Fds_Count := Fds_Count + 1; - - if Descriptors (J).Buffer_Size = 0 then - Buffer_Size := Integer'Max (Buffer_Size, 4096); - else - Buffer_Size := - Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); - end if; - end if; - end loop; - - declare - Buffer : aliased String (1 .. Buffer_Size); - -- Buffer used for input. This is allocated only once, not for - -- every iteration of the loop - - D : aliased Integer; - -- Index in Descriptors - - begin - -- Loop until we match or we have a timeout - - loop - Num_Descriptors := - Poll (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address); - - case Num_Descriptors is - - -- Error? - - when -1 => - Result := Expect_Internal_Error; - - if D /= 0 then - Close (Descriptors (D).Input_Fd); - Descriptors (D).Input_Fd := Invalid_FD; - end if; - - return; - - -- Timeout? - - when 0 => - Result := Expect_Timeout; - return; - - -- Some input - - when others => - for F in Fds'Range loop - if Is_Set (F) = 1 then - D := Fds_To_Descriptor (F); - - Buffer_Size := Descriptors (D).Buffer_Size; - - if Buffer_Size = 0 then - Buffer_Size := 4096; - end if; - - N := Read (Descriptors (D).Output_Fd, Buffer'Address, - Buffer_Size); - - -- Error or End of file - - if N <= 0 then - -- ??? Note that ddd tries again up to three times - -- in that case. See LiterateA.C:174 - - Close (Descriptors (D).Input_Fd); - Descriptors (D).Input_Fd := Invalid_FD; - Result := Expect_Process_Died; - return; - - else - -- If there is no limit to the buffer size - - if Descriptors (D).Buffer_Size = 0 then - declare - Tmp : String_Access := Descriptors (D).Buffer; - - begin - if Tmp /= null then - Descriptors (D).Buffer := - new String (1 .. Tmp'Length + N); - Descriptors (D).Buffer (1 .. Tmp'Length) := - Tmp.all; - Descriptors (D).Buffer - (Tmp'Length + 1 .. Tmp'Length + N) := - Buffer (1 .. N); - Free (Tmp); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer'Last; - - else - Descriptors (D).Buffer := - new String (1 .. N); - Descriptors (D).Buffer.all := - Buffer (1 .. N); - Descriptors (D).Buffer_Index := N; - end if; - end; - - else - -- Add what we read to the buffer - - if Descriptors (D).Buffer_Index + N > - Descriptors (D).Buffer_Size - then - -- If the user wants to know when we have - -- read more than the buffer can contain. - - if Full_Buffer then - Result := Expect_Full_Buffer; - return; - end if; - - -- Keep as much as possible from the buffer, - -- and forget old characters. - - Descriptors (D).Buffer - (1 .. Descriptors (D).Buffer_Size - N) := - Descriptors (D).Buffer - (N - Descriptors (D).Buffer_Size + - Descriptors (D).Buffer_Index + 1 .. - Descriptors (D).Buffer_Index); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer_Size - N; - end if; - - -- Keep what we read in the buffer - - Descriptors (D).Buffer - (Descriptors (D).Buffer_Index + 1 .. - Descriptors (D).Buffer_Index + N) := - Buffer (1 .. N); - Descriptors (D).Buffer_Index := - Descriptors (D).Buffer_Index + N; - end if; - - -- Call each of the output filter with what we - -- read. - - Call_Filters - (Descriptors (D).all, Buffer (1 .. N), Output); - - Result := Expect_Match (D); - return; - end if; - end if; - end loop; - end case; - end loop; - end; - end Expect_Internal; - - ---------------- - -- Expect_Out -- - ---------------- - - function Expect_Out (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); - end Expect_Out; - - ---------------------- - -- Expect_Out_Match -- - ---------------------- - - function Expect_Out_Match (Descriptor : Process_Descriptor) return String is - begin - return Descriptor.Buffer - (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); - end Expect_Out_Match; - - ------------------------ - -- First_Dead_Process -- - ------------------------ - - function First_Dead_Process - (Regexp : Multiprocess_Regexp_Array) return Natural is - begin - for R in Regexp'Range loop - if Regexp (R).Descriptor /= null - and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD - then - return R; - end if; - end loop; - - return 0; - end First_Dead_Process; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (Descriptor : in out Process_Descriptor; - Timeout : Integer := 0) - is - Buffer_Size : constant Integer := 8192; - Num_Descriptors : Integer; - N : aliased Integer; - Is_Set : aliased Integer; - Buffer : aliased String (1 .. Buffer_Size); - - begin - -- Empty the current buffer - - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - Reinitialize_Buffer (Descriptor); - - -- Read everything from the process to flush its output - - loop - Num_Descriptors := - Poll (Descriptor.Output_Fd'Address, - 1, - Timeout, - N'Access, - Is_Set'Address); - - case Num_Descriptors is - - -- Error ? - - when -1 => - raise Process_Died; - - -- Timeout => End of flush - - when 0 => - return; - - -- Some input - - when others => - if Is_Set = 1 then - N := Read (Descriptor.Output_Fd, Buffer'Address, - Buffer_Size); - - if N = -1 then - raise Process_Died; - elsif N = 0 then - return; - end if; - end if; - end case; - end loop; - end Flush; - - ---------- - -- Free -- - ---------- - - procedure Free (Regexp : in out Multiprocess_Regexp) is - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Process_Descriptor'Class, Process_Descriptor_Access); - begin - Unchecked_Free (Regexp.Descriptor); - Free (Regexp.Regexp); - end Free; - - ------------------------ - -- Get_Command_Output -- - ------------------------ - - function Get_Command_Output - (Command : String; - Arguments : GNAT.OS_Lib.Argument_List; - Input : String; - Status : not null access Integer; - Err_To_Out : Boolean := False) return String - is - use GNAT.Expect; - - Process : Process_Descriptor; - - Output : String_Access := new String (1 .. 1024); - -- Buffer used to accumulate standard output from the launched - -- command, expanded as necessary during execution. - - Last : Integer := 0; - -- Index of the last used character within Output - - begin - Non_Blocking_Spawn - (Process, Command, Arguments, Err_To_Out => Err_To_Out, - Buffer_Size => 0); - - if Input'Length > 0 then - Send (Process, Input); - end if; - - Close (Process.Input_Fd); - Process.Input_Fd := Invalid_FD; - - declare - Result : Expect_Match; - pragma Unreferenced (Result); - - begin - -- This loop runs until the call to Expect raises Process_Died - - loop - Expect (Process, Result, ".+", Timeout => -1); - - declare - NOutput : String_Access; - S : constant String := Expect_Out (Process); - pragma Assert (S'Length > 0); - - begin - -- Expand buffer if we need more space. Note here that we add - -- S'Length to ensure that S will fit in the new buffer size. - - if Last + S'Length > Output'Last then - NOutput := new String (1 .. 2 * Output'Last + S'Length); - NOutput (Output'Range) := Output.all; - Free (Output); - - -- Here if current buffer size is OK - - else - NOutput := Output; - end if; - - NOutput (Last + 1 .. Last + S'Length) := S; - Last := Last + S'Length; - Output := NOutput; - end; - end loop; - - exception - when Process_Died => - Close (Process, Status.all); - end; - - if Last = 0 then - Free (Output); - return ""; - end if; - - declare - S : constant String := Output (1 .. Last); - begin - Free (Output); - return S; - end; - end Get_Command_Output; - - ------------------ - -- Get_Error_Fd -- - ------------------ - - function Get_Error_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Error_Fd; - end Get_Error_Fd; - - ------------------ - -- Get_Input_Fd -- - ------------------ - - function Get_Input_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Input_Fd; - end Get_Input_Fd; - - ------------------- - -- Get_Output_Fd -- - ------------------- - - function Get_Output_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor - is - begin - return Descriptor.Output_Fd; - end Get_Output_Fd; - - ------------- - -- Get_Pid -- - ------------- - - function Get_Pid - (Descriptor : Process_Descriptor) return Process_Id - is - begin - return Descriptor.Pid; - end Get_Pid; - - ----------------- - -- Has_Process -- - ----------------- - - function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is - begin - return Regexp /= (Regexp'Range => (null, null)); - end Has_Process; - - --------------- - -- Interrupt -- - --------------- - - procedure Interrupt (Descriptor : in out Process_Descriptor) is - SIGINT : constant := 2; - begin - Send_Signal (Descriptor, SIGINT); - end Interrupt; - - ------------------ - -- Lock_Filters -- - ------------------ - - procedure Lock_Filters (Descriptor : in out Process_Descriptor) is - begin - Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; - end Lock_Filters; - - ------------------------ - -- Non_Blocking_Spawn -- - ------------------------ - - procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False) - is - function Fork return Process_Id; - pragma Import (C, Fork, "__gnat_expect_fork"); - -- Starts a new process if possible. See the Unix command fork for more - -- information. On systems that do not support this capability (such as - -- Windows...), this command does nothing, and Fork will return - -- Null_Pid. - - Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; - - Arg : String_Access; - Arg_List : String_List (1 .. Args'Length + 2); - C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; - - Command_With_Path : String_Access; - - begin - Command_With_Path := Locate_Exec_On_Path (Command); - - if Command_With_Path = null then - raise Invalid_Process; - end if; - - -- Create the rest of the pipes once we know we will be able to - -- execute the process. - - Set_Up_Communications - (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); - - -- Fork a new process - - Descriptor.Pid := Fork; - - -- Are we now in the child (or, for Windows, still in the common - -- process). - - if Descriptor.Pid = Null_Pid then - -- Prepare an array of arguments to pass to C - - Arg := new String (1 .. Command_With_Path'Length + 1); - Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (1) := Arg; - - for J in Args'Range loop - Arg := new String (1 .. Args (J)'Length + 1); - Arg (1 .. Args (J)'Length) := Args (J).all; - Arg (Arg'Last) := ASCII.NUL; - Arg_List (J + 2 - Args'First) := Arg.all'Access; - end loop; - - Arg_List (Arg_List'Last) := null; - - -- Make sure all arguments are compatible with OS conventions - - Normalize_Arguments (Arg_List); - - -- Prepare low-level argument list from the normalized arguments - - for K in Arg_List'Range loop - C_Arg_List (K) := - (if Arg_List (K) /= null - then Arg_List (K).all'Address - else System.Null_Address); - end loop; - - -- This does not return on Unix systems - - Set_Up_Child_Communications - (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, - C_Arg_List'Address); - end if; - - Free (Command_With_Path); - - -- Did we have an error when spawning the child ? - - if Descriptor.Pid < Null_Pid then - raise Invalid_Process; - else - -- We are now in the parent process - - Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); - end if; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; - - -- Initialize the filters - - Descriptor.Filters := null; - end Non_Blocking_Spawn; - - ------------------------- - -- Reinitialize_Buffer -- - ------------------------- - - procedure Reinitialize_Buffer - (Descriptor : in out Process_Descriptor'Class) - is - begin - if Descriptor.Buffer_Size = 0 then - declare - Tmp : String_Access := Descriptor.Buffer; - - begin - Descriptor.Buffer := - new String - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); - - if Tmp /= null then - Descriptor.Buffer.all := Tmp - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - Free (Tmp); - end if; - end; - - Descriptor.Buffer_Index := Descriptor.Buffer'Last; - - else - Descriptor.Buffer - (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := - Descriptor.Buffer - (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); - - if Descriptor.Buffer_Index > Descriptor.Last_Match_End then - Descriptor.Buffer_Index := - Descriptor.Buffer_Index - Descriptor.Last_Match_End; - else - Descriptor.Buffer_Index := 0; - end if; - end if; - - Descriptor.Last_Match_Start := 0; - Descriptor.Last_Match_End := 0; - end Reinitialize_Buffer; - - ------------------- - -- Remove_Filter -- - ------------------- - - procedure Remove_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function) - is - Previous : Filter_List := null; - Current : Filter_List := Descriptor.Filters; - - begin - while Current /= null loop - if Current.Filter = Filter then - if Previous = null then - Descriptor.Filters := Current.Next; - else - Previous.Next := Current.Next; - end if; - end if; - - Previous := Current; - Current := Current.Next; - end loop; - end Remove_Filter; - - ---------- - -- Send -- - ---------- - - procedure Send - (Descriptor : in out Process_Descriptor; - Str : String; - Add_LF : Boolean := True; - Empty_Buffer : Boolean := False) - is - Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF); - Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); - - Result : Expect_Match; - Discard : Natural; - pragma Warnings (Off, Result); - pragma Warnings (Off, Discard); - - begin - if Empty_Buffer then - - -- Force a read on the process if there is anything waiting - - Expect_Internal - (Descriptors, Result, Timeout => 0, Full_Buffer => False); - - if Result = Expect_Internal_Error - or else Result = Expect_Process_Died - then - raise Process_Died; - end if; - - Descriptor.Last_Match_End := Descriptor.Buffer_Index; - - -- Empty the buffer - - Reinitialize_Buffer (Descriptor); - end if; - - Call_Filters (Descriptor, Str, Input); - Discard := - Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1); - - if Add_LF then - Call_Filters (Descriptor, Line_Feed, Input); - Discard := - Write (Descriptor.Input_Fd, Line_Feed'Address, 1); - end if; - end Send; - - ----------------- - -- Send_Signal -- - ----------------- - - procedure Send_Signal - (Descriptor : Process_Descriptor; - Signal : Integer) - is - begin - -- A nonpositive process id passed to kill has special meanings. For - -- example, -1 means kill all processes in sight, including self, in - -- POSIX and Windows (and something slightly different in Linux). See - -- man pages for details. In any case, we don't want to do that. Note - -- that Descriptor.Pid will be -1 if the process was not successfully - -- started; we don't want to kill ourself in that case. - - if Descriptor.Pid > 0 then - Kill (Descriptor.Pid, Signal, Close => 1); - -- ??? Need to check process status here - else - raise Invalid_Process; - end if; - end Send_Signal; - - --------------------------------- - -- Set_Up_Child_Communications -- - --------------------------------- - - procedure Set_Up_Child_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type; - Cmd : String; - Args : System.Address) - is - pragma Warnings (Off, Pid); - pragma Warnings (Off, Pipe1); - pragma Warnings (Off, Pipe2); - pragma Warnings (Off, Pipe3); - - Input : File_Descriptor; - Output : File_Descriptor; - Error : File_Descriptor; - - No_Fork_On_Target : constant Boolean := Target_OS = Windows; - - begin - if No_Fork_On_Target then - - -- Since Windows does not have a separate fork/exec, we need to - -- perform the following actions: - - -- - save stdin, stdout, stderr - -- - replace them by our pipes - -- - create the child with process handle inheritance - -- - revert to the previous stdin, stdout and stderr. - - Input := Dup (GNAT.OS_Lib.Standin); - Output := Dup (GNAT.OS_Lib.Standout); - Error := Dup (GNAT.OS_Lib.Standerr); - end if; - - -- Since we are still called from the parent process, there is no way - -- currently we can cleanly close the unneeded ends of the pipes, but - -- this doesn't really matter. - - -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input - - Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); - Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); - Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); - - Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args); - - -- The following lines are only required for Windows systems and will - -- not be executed on Unix systems, but we use the same condition as - -- above to avoid warnings on uninitialized variables on Unix systems. - -- We are now in the parent process. - - if No_Fork_On_Target then - - -- Restore the old descriptors - - Dup2 (Input, GNAT.OS_Lib.Standin); - Dup2 (Output, GNAT.OS_Lib.Standout); - Dup2 (Error, GNAT.OS_Lib.Standerr); - Close (Input); - Close (Output); - Close (Error); - end if; - end Set_Up_Child_Communications; - - --------------------------- - -- Set_Up_Communications -- - --------------------------- - - procedure Set_Up_Communications - (Pid : in out Process_Descriptor; - Err_To_Out : Boolean; - Pipe1 : not null access Pipe_Type; - Pipe2 : not null access Pipe_Type; - Pipe3 : not null access Pipe_Type) - is - Status : Boolean; - pragma Unreferenced (Status); - - begin - -- Create the pipes - - if Create_Pipe (Pipe1) /= 0 then - return; - end if; - - if Create_Pipe (Pipe2) /= 0 then - Close (Pipe1.Input); - Close (Pipe1.Output); - return; - end if; - - -- Record the 'parent' end of the two pipes in Pid: - -- Child stdin is connected to the 'write' end of Pipe1; - -- Child stdout is connected to the 'read' end of Pipe2. - -- We do not want these descriptors to remain open in the child - -- process, so we mark them close-on-exec/non-inheritable. - - Pid.Input_Fd := Pipe1.Output; - Set_Close_On_Exec (Pipe1.Output, True, Status); - Pid.Output_Fd := Pipe2.Input; - Set_Close_On_Exec (Pipe2.Input, True, Status); - - if Err_To_Out then - - -- Reuse the standard output pipe for standard error - - Pipe3.all := Pipe2.all; - - else - -- Create a separate pipe for standard error - - if Create_Pipe (Pipe3) /= 0 then - Pipe3.all := Pipe2.all; - end if; - end if; - - -- As above, record the proper fd for the child's standard error stream - - Pid.Error_Fd := Pipe3.Input; - Set_Close_On_Exec (Pipe3.Input, True, Status); - end Set_Up_Communications; - - ---------------------------------- - -- Set_Up_Parent_Communications -- - ---------------------------------- - - procedure Set_Up_Parent_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type) - is - pragma Warnings (Off, Pid); - pragma Warnings (Off, Pipe1); - pragma Warnings (Off, Pipe2); - pragma Warnings (Off, Pipe3); - - begin - Close (Pipe1.Input); - Close (Pipe2.Output); - - if Pipe3.Output /= Pipe2.Output then - Close (Pipe3.Output); - end if; - end Set_Up_Parent_Communications; - - ------------------ - -- Trace_Filter -- - ------------------ - - procedure Trace_Filter - (Descriptor : Process_Descriptor'Class; - Str : String; - User_Data : System.Address := System.Null_Address) - is - pragma Warnings (Off, Descriptor); - pragma Warnings (Off, User_Data); - begin - GNAT.IO.Put (Str); - end Trace_Filter; - - -------------------- - -- Unlock_Filters -- - -------------------- - - procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is - begin - if Descriptor.Filters_Lock > 0 then - Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; - end if; - end Unlock_Filters; - -end GNAT.Expect; diff --git a/gcc/ada/g-expect.ads b/gcc/ada/g-expect.ads deleted file mode 100644 index 0dc6341..0000000 --- a/gcc/ada/g-expect.ads +++ /dev/null @@ -1,647 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . E X P E C T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Currently this package is implemented on all native GNAT ports. It is not --- yet implemented for any of the cross-ports (e.g. it is not available for --- VxWorks or LynxOS). - --- ----------- --- -- Usage -- --- ----------- - --- This package provides a set of subprograms similar to what is available --- with the standard Tcl Expect tool. - --- It allows you to easily spawn and communicate with an external process. --- You can send commands or inputs to the process, and compare the output --- with some expected regular expression. - --- Usage example: - --- Non_Blocking_Spawn --- (Fd, "ftp", --- (1 => new String' ("machine@domain"))); --- Timeout := 10_000; -- 10 seconds --- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"), --- Timeout); --- case Result is --- when 1 => Send (Fd, "my_name"); -- matched "user" --- when 2 => Send (Fd, "my_passwd"); -- matched "passwd" --- when Expect_Timeout => null; -- timeout --- when others => null; --- end case; --- Close (Fd); - --- You can also combine multiple regular expressions together, and get the --- specific string matching a parenthesis pair by doing something like this: --- If you expect either "lang=optional ada" or "lang=ada" from the external --- process, you can group the two together, which is more efficient, and --- simply get the name of the language by doing: - --- declare --- Matched : Match_Array (0 .. 2); --- begin --- Expect (Fd, Result, "lang=(optional)? ([a-z]+)", Matched); --- Put_Line ("Seen: " & --- Expect_Out (Fd) (Matched (2).First .. Matched (2).Last)); --- end; - --- Alternatively, you might choose to use a lower-level interface to the --- processes, where you can give your own input and output filters every --- time characters are read from or written to the process. - --- procedure My_Filter --- (Descriptor : Process_Descriptor'Class; --- Str : String; --- User_Data : System.Address) --- is --- begin --- Put_Line (Str); --- end; - --- Non_Blocking_Spawn --- (Fd, "tail", --- (new String' ("-f"), new String' ("a_file"))); --- Add_Filter (Fd, My_Filter'Access, Output); --- Expect (Fd, Result, "", 0); -- wait forever - --- The above example should probably be run in a separate task, since it is --- blocking on the call to Expect. - --- Both examples can be combined, for instance to systematically print the --- output seen by expect, even though you still want to let Expect do the --- filtering. You can use the Trace_Filter subprogram for such a filter. - --- If you want to get the output of a simple command, and ignore any previous --- existing output, it is recommended to do something like: - --- Expect (Fd, Result, ".*", Timeout => 0); --- -- Empty the buffer, by matching everything (after checking --- -- if there was any input). - --- Send (Fd, "command"); --- Expect (Fd, Result, ".."); -- match only on the output of command - --- ----------------- --- -- Task Safety -- --- ----------------- - --- This package is not task-safe: there should not be concurrent calls to the --- functions defined in this package. In other words, separate tasks must not --- access the facilities of this package without synchronization that --- serializes access. - -with System; -with GNAT.OS_Lib; -with GNAT.Regpat; - -package GNAT.Expect is - - type Process_Id is new Integer; - Invalid_Pid : constant Process_Id := -1; - Null_Pid : constant Process_Id := 0; - - type Filter_Type is (Output, Input, Died); - -- The signals that are emitted by the Process_Descriptor upon state change - -- in the child. One can connect to any of these signals through the - -- Add_Filter subprograms. - -- - -- Output => Every time new characters are read from the process - -- associated with Descriptor, the filter is called with - -- these new characters in the argument. - -- - -- Note that output is generated only when the program is - -- blocked in a call to Expect. - -- - -- Input => Every time new characters are written to the process - -- associated with Descriptor, the filter is called with - -- these new characters in the argument. - -- Note that input is generated only by calls to Send. - -- - -- Died => The child process has died, or was explicitly killed - - type Process_Descriptor is tagged private; - -- Contains all the components needed to describe a process handled - -- in this package, including a process identifier, file descriptors - -- associated with the standard input, output and error, and the buffer - -- needed to handle the expect calls. - - type Process_Descriptor_Access is access Process_Descriptor'Class; - - ------------------------ - -- Spawning a process -- - ------------------------ - - procedure Non_Blocking_Spawn - (Descriptor : out Process_Descriptor'Class; - Command : String; - Args : GNAT.OS_Lib.Argument_List; - Buffer_Size : Natural := 4096; - Err_To_Out : Boolean := False); - -- This call spawns a new process and allows sending commands to - -- the process and/or automatic parsing of the output. - -- - -- The expect buffer associated with that process can contain at most - -- Buffer_Size characters. Older characters are simply discarded when this - -- buffer is full. Beware that if the buffer is too big, this could slow - -- down the Expect calls if the output not is matched, since Expect has to - -- match all the regexp against all the characters in the buffer. If - -- Buffer_Size is 0, there is no limit (i.e. all the characters are kept - -- till Expect matches), but this is slower. - -- - -- If Err_To_Out is True, then the standard error of the spawned process is - -- connected to the standard output. This is the only way to get the Expect - -- subprograms to also match on output on standard error. - -- - -- Invalid_Process is raised if the process could not be spawned. - -- - -- For information about spawning processes from tasking programs, see the - -- "NOTE: Spawn in tasking programs" in System.OS_Lib (s-os_lib.ads). - - procedure Close (Descriptor : in out Process_Descriptor); - -- Terminate the process and close the pipes to it. It implicitly does the - -- 'wait' command required to clean up the process table. This also frees - -- the buffer associated with the process id. Raise Invalid_Process if the - -- process id is invalid. - - procedure Close - (Descriptor : in out Process_Descriptor; - Status : out Integer); - -- Same as above, but also returns the exit status of the process, as set - -- for example by the procedure GNAT.OS_Lib.OS_Exit. - - procedure Send_Signal - (Descriptor : Process_Descriptor; - Signal : Integer); - -- Send a given signal to the process. Raise Invalid_Process if the process - -- id is invalid. - - procedure Interrupt (Descriptor : in out Process_Descriptor); - -- Interrupt the process (the equivalent of Ctrl-C on unix and windows) - -- and call close if the process dies. - - function Get_Input_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor; - -- Return the input file descriptor associated with Descriptor - - function Get_Output_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor; - -- Return the output file descriptor associated with Descriptor - - function Get_Error_Fd - (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor; - -- Return the error output file descriptor associated with Descriptor - - function Get_Pid - (Descriptor : Process_Descriptor) return Process_Id; - -- Return the process id associated with a given process descriptor - - function Get_Command_Output - (Command : String; - Arguments : GNAT.OS_Lib.Argument_List; - Input : String; - Status : not null access Integer; - Err_To_Out : Boolean := False) return String; - -- Execute Command with the specified Arguments and Input, and return the - -- generated standard output data as a single string. If Err_To_Out is - -- True, generated standard error output is included as well. On return, - -- Status is set to the command's exit status. - - -------------------- - -- Adding filters -- - -------------------- - - -- This is a rather low-level interface to subprocesses, since basically - -- the filtering is left entirely to the user. See the Expect subprograms - -- below for higher level functions. - - type Filter_Function is access - procedure - (Descriptor : Process_Descriptor'Class; - Str : String; - User_Data : System.Address := System.Null_Address); - -- Function called every time new characters are read from or written to - -- the process. - -- - -- Str is a string of all these characters. - -- - -- User_Data, if specified, is user specific data that will be passed to - -- the filter. Note that no checks are done on this parameter, so it should - -- be used with caution. - - procedure Add_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function; - Filter_On : Filter_Type := Output; - User_Data : System.Address := System.Null_Address; - After : Boolean := False); - -- Add a new filter for one of the filter types. This filter will be run - -- before all the existing filters, unless After is set True, in which case - -- it will be run after existing filters. User_Data is passed as is to the - -- filter procedure. - - procedure Remove_Filter - (Descriptor : in out Process_Descriptor; - Filter : Filter_Function); - -- Remove a filter from the list of filters (whatever the type of the - -- filter). - - procedure Trace_Filter - (Descriptor : Process_Descriptor'Class; - Str : String; - User_Data : System.Address := System.Null_Address); - -- Function that can be used as a filter and that simply outputs Str on - -- Standard_Output. This is mainly used for debugging purposes. - -- User_Data is ignored. - - procedure Lock_Filters (Descriptor : in out Process_Descriptor); - -- Temporarily disables all output and input filters. They will be - -- reactivated only when Unlock_Filters has been called as many times as - -- Lock_Filters. - - procedure Unlock_Filters (Descriptor : in out Process_Descriptor); - -- Unlocks the filters. They are reactivated only if Unlock_Filters - -- has been called as many times as Lock_Filters. - - ------------------ - -- Sending data -- - ------------------ - - procedure Send - (Descriptor : in out Process_Descriptor; - Str : String; - Add_LF : Boolean := True; - Empty_Buffer : Boolean := False); - -- Send a string to the file descriptor. - -- - -- The string is not formatted in any way, except if Add_LF is True, in - -- which case an ASCII.LF is added at the end, so that Str is recognized - -- as a command by the external process. - -- - -- If Empty_Buffer is True, any input waiting from the process (or in the - -- buffer) is first discarded before the command is sent. The output - -- filters are of course called as usual. - - ----------------------------------------------------------- - -- Working on the output (single process, simple regexp) -- - ----------------------------------------------------------- - - type Expect_Match is new Integer; - Expect_Full_Buffer : constant Expect_Match := -1; - -- If the buffer was full and some characters were discarded - - Expect_Timeout : constant Expect_Match := -2; - -- If no output matching the regexps was found before the timeout - - function "+" (S : String) return GNAT.OS_Lib.String_Access; - -- Allocate some memory for the string. This is merely a convenience - -- function to help create the array of regexps in the call to Expect. - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Wait till a string matching Fd can be read from Fd, and return 1 if a - -- match was found. - -- - -- It consumes all the characters read from Fd until a match found, and - -- then sets the return values for the subprograms Expect_Out and - -- Expect_Out_Match. - -- - -- The empty string "" will never match, and can be used if you only want - -- to match after a specific timeout. Beware that if Timeout is -1 at the - -- time, the current task will be blocked forever. - -- - -- This command times out after Timeout milliseconds (or never if Timeout - -- is -1). In that case, Expect_Timeout is returned. The value returned by - -- Expect_Out and Expect_Out_Match are meaningless in that case. - -- - -- Note that using a timeout of 0ms leads to unpredictable behavior, since - -- the result depends on whether the process has already sent some output - -- the first time Expect checks, and this depends on the operating system. - -- - -- The regular expression must obey the syntax described in GNAT.Regpat. - -- - -- If Full_Buffer is True, then Expect will match if the buffer was too - -- small and some characters were about to be discarded. In that case, - -- Expect_Full_Buffer is returned. - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as the previous one, but with a precompiled regular expression. - -- This is more efficient however, especially if you are using this - -- expression multiple times, since this package won't need to recompile - -- the regexp every time. - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : String; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as above, but it is now possible to get the indexes of the - -- substrings for the parentheses in the regexp (see the example at the - -- top of this package, as well as the documentation in the package - -- GNAT.Regpat). - -- - -- Matched'First should be 0, and this index will contain the indexes for - -- the whole string that was matched. The index 1 will contain the indexes - -- for the first parentheses-pair, and so on. - - ------------ - -- Expect -- - ------------ - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexp : GNAT.Regpat.Pattern_Matcher; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as above, but with a precompiled regular expression - - ------------------------------------------------------------- - -- Working on the output (single process, multiple regexp) -- - ------------------------------------------------------------- - - type Regexp_Array is array (Positive range <>) of GNAT.OS_Lib.String_Access; - - type Pattern_Matcher_Access is access all GNAT.Regpat.Pattern_Matcher; - type Compiled_Regexp_Array is - array (Positive range <>) of Pattern_Matcher_Access; - - function "+" - (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access; - -- Allocate some memory for the pattern matcher. This is only a convenience - -- function to help create the array of compiled regular expressions. - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Wait till a string matching one of the regular expressions in Regexps - -- is found. This function returns the index of the regexp that matched. - -- This command is blocking, but will timeout after Timeout milliseconds. - -- In that case, Timeout is returned. - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as the previous one, but with precompiled regular expressions. - -- This can be much faster if you are using them multiple times. - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as above, except that you can also access the parenthesis - -- groups inside the matching regular expression. - -- - -- The first index in Matched must be 0, or Constraint_Error will be - -- raised. The index 0 contains the indexes for the whole string that was - -- matched, the index 1 contains the indexes for the first parentheses - -- pair, and so on. - - procedure Expect - (Descriptor : in out Process_Descriptor; - Result : out Expect_Match; - Regexps : Compiled_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as above, but with precompiled regular expressions. The first index - -- in Matched must be 0, or Constraint_Error will be raised. - - ------------------------------------------- - -- Working on the output (multi-process) -- - ------------------------------------------- - - type Multiprocess_Regexp is record - Descriptor : Process_Descriptor_Access; - Regexp : Pattern_Matcher_Access; - end record; - - type Multiprocess_Regexp_Array is - array (Positive range <>) of Multiprocess_Regexp; - - procedure Free (Regexp : in out Multiprocess_Regexp); - -- Free the memory occupied by Regexp - - function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean; - -- Return True if at least one entry in Regexp is non-null, ie there is - -- still at least one process to monitor - - function First_Dead_Process - (Regexp : Multiprocess_Regexp_Array) return Natural; - -- Find the first entry in Regexp that corresponds to a dead process that - -- wasn't Free-d yet. This function is called in general when Expect - -- (below) raises the exception Process_Died. This returns 0 if no process - -- has died yet. - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Matched : out GNAT.Regpat.Match_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as above, but for multi processes. Any of the entries in - -- Regexps can have a null Descriptor or Regexp. Such entries will - -- simply be ignored. Therefore when a process terminates, you can - -- simply reset its entry. - -- - -- The expect loop would therefore look like: - -- - -- Processes : Multiprocess_Regexp_Array (...) := ...; - -- R : Natural; - -- - -- while Has_Process (Processes) loop - -- begin - -- Expect (Result, Processes, Timeout => -1); - -- ... process output of process Result (output, full buffer,...) - -- - -- exception - -- when Process_Died => - -- -- Free memory - -- R := First_Dead_Process (Processes); - -- Close (Processes (R).Descriptor.all, Status); - -- Free (Processes (R)); - -- end; - -- end loop; - - procedure Expect - (Result : out Expect_Match; - Regexps : Multiprocess_Regexp_Array; - Timeout : Integer := 10_000; - Full_Buffer : Boolean := False); - -- Same as the previous one, but for multiple processes. This procedure - -- finds the first regexp that match the associated process. - - ------------------------ - -- Getting the output -- - ------------------------ - - procedure Flush - (Descriptor : in out Process_Descriptor; - Timeout : Integer := 0); - -- Discard all output waiting from the process. - -- - -- This output is simply discarded, and no filter is called. This output - -- will also not be visible by the next call to Expect, nor will any output - -- currently buffered. - -- - -- Timeout is the delay for which we wait for output to be available from - -- the process. If 0, we only get what is immediately available. - - function Expect_Out (Descriptor : Process_Descriptor) return String; - -- Return the string matched by the last Expect call. - -- - -- The returned string is in fact the concatenation of all the strings read - -- from the file descriptor up to, and including, the characters that - -- matched the regular expression. - -- - -- For instance, with an input "philosophic", and a regular expression "hi" - -- in the call to expect, the strings returned the first and second time - -- would be respectively "phi" and "losophi". - - function Expect_Out_Match (Descriptor : Process_Descriptor) return String; - -- Return the string matched by the last Expect call. - -- - -- The returned string includes only the character that matched the - -- specific regular expression. All the characters that came before are - -- simply discarded. - -- - -- For instance, with an input "philosophic", and a regular expression - -- "hi" in the call to expect, the strings returned the first and second - -- time would both be "hi". - - ---------------- - -- Exceptions -- - ---------------- - - Invalid_Process : exception; - -- Raised by most subprograms above when the parameter Descriptor is not a - -- valid process or is a closed process. - - Process_Died : exception; - -- Raised by all the expect subprograms if Descriptor was originally a - -- valid process that died while Expect was executing. It is also raised - -- when Expect receives an end-of-file. - -private - type Filter_List_Elem; - type Filter_List is access Filter_List_Elem; - type Filter_List_Elem is record - Filter : Filter_Function; - User_Data : System.Address; - Filter_On : Filter_Type; - Next : Filter_List; - end record; - - type Pipe_Type is record - Input, Output : GNAT.OS_Lib.File_Descriptor; - end record; - -- This type represents a pipe, used to communicate between two processes - - procedure Set_Up_Communications - (Pid : in out Process_Descriptor; - Err_To_Out : Boolean; - Pipe1 : not null access Pipe_Type; - Pipe2 : not null access Pipe_Type; - Pipe3 : not null access Pipe_Type); - -- Set up all the communication pipes and file descriptors prior to - -- spawning the child process. - - procedure Set_Up_Parent_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type); - -- Finish the set up of the pipes while in the parent process - - procedure Set_Up_Child_Communications - (Pid : in out Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type; - Cmd : String; - Args : System.Address); - -- Finish the set up of the pipes while in the child process This also - -- spawns the child process (based on Cmd). On systems that support fork, - -- this procedure is executed inside the newly created process. - - type Process_Descriptor is tagged record - Pid : aliased Process_Id := Invalid_Pid; - Input_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; - Output_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; - Error_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; - Filters_Lock : Integer := 0; - - Filters : Filter_List := null; - - Buffer : GNAT.OS_Lib.String_Access := null; - Buffer_Size : Natural := 0; - Buffer_Index : Natural := 0; - - Last_Match_Start : Natural := 0; - Last_Match_End : Natural := 0; - end record; - - -- The following subprogram is provided for use in the body, and also - -- possibly in future child units providing extensions to this package. - - procedure Portable_Execvp - (Pid : not null access Process_Id; - Cmd : String; - Args : System.Address); - pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp"); - -- Executes, in a portable way, the command Cmd (full path must be - -- specified), with the given Args, which must be an array of string - -- pointers. Note that the first element in Args must be the executable - -- name, and the last element must be a null pointer. The returned value - -- in Pid is the process ID, or zero if not supported on the platform. - -end GNAT.Expect; diff --git a/gcc/ada/g-exptty.adb b/gcc/ada/g-exptty.adb deleted file mode 100644 index 00615f9..0000000 --- a/gcc/ada/g-exptty.adb +++ /dev/null @@ -1,324 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . E X P E C T . T T Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.OS_Lib; use GNAT.OS_Lib; - -with System; use System; - -package body GNAT.Expect.TTY is - - On_Windows : constant Boolean := Directory_Separator = '\'; - -- True when on Windows - - ----------- - -- Close -- - ----------- - - overriding procedure Close - (Descriptor : in out TTY_Process_Descriptor; - Status : out Integer) - is - procedure Terminate_Process (Process : System.Address); - pragma Import (C, Terminate_Process, "__gnat_terminate_process"); - - function Waitpid (Process : System.Address) return Integer; - pragma Import (C, Waitpid, "__gnat_tty_waitpid"); - -- Wait for a specific process id, and return its exit code - - procedure Free_Process (Process : System.Address); - pragma Import (C, Free_Process, "__gnat_free_process"); - - procedure Close_TTY (Process : System.Address); - pragma Import (C, Close_TTY, "__gnat_close_tty"); - - begin - -- If we haven't already closed the process - - if Descriptor.Process = System.Null_Address then - Status := -1; - - else - -- Send a Ctrl-C to the process first. This way, if the launched - -- process is a "sh" or "cmd", the child processes will get - -- terminated as well. Otherwise, terminating the main process - -- brutally will leave the children running. - - -- Note: special characters are sent to the terminal to generate the - -- signal, so this needs to be done while the file descriptors are - -- still open (it used to be after the closes and that was wrong). - - Interrupt (Descriptor); - delay (0.05); - - if Descriptor.Input_Fd /= Invalid_FD then - Close (Descriptor.Input_Fd); - end if; - - if Descriptor.Error_Fd /= Descriptor.Output_Fd - and then Descriptor.Error_Fd /= Invalid_FD - then - Close (Descriptor.Error_Fd); - end if; - - if Descriptor.Output_Fd /= Invalid_FD then - Close (Descriptor.Output_Fd); - end if; - - Terminate_Process (Descriptor.Process); - Status := Waitpid (Descriptor.Process); - - if not On_Windows then - Close_TTY (Descriptor.Process); - end if; - - Free_Process (Descriptor.Process'Address); - Descriptor.Process := System.Null_Address; - - GNAT.OS_Lib.Free (Descriptor.Buffer); - Descriptor.Buffer_Size := 0; - end if; - end Close; - - overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is - Status : Integer; - begin - Close (Descriptor, Status); - end Close; - - ----------------------------- - -- Close_Pseudo_Descriptor -- - ----------------------------- - - procedure Close_Pseudo_Descriptor - (Descriptor : in out TTY_Process_Descriptor) - is - begin - Descriptor.Buffer_Size := 0; - GNAT.OS_Lib.Free (Descriptor.Buffer); - end Close_Pseudo_Descriptor; - - --------------- - -- Interrupt -- - --------------- - - overriding procedure Interrupt - (Descriptor : in out TTY_Process_Descriptor) - is - procedure Internal (Process : System.Address); - pragma Import (C, Internal, "__gnat_interrupt_process"); - begin - if Descriptor.Process /= System.Null_Address then - Internal (Descriptor.Process); - end if; - end Interrupt; - - procedure Interrupt (Pid : Integer) is - procedure Internal (Pid : Integer); - pragma Import (C, Internal, "__gnat_interrupt_pid"); - begin - Internal (Pid); - end Interrupt; - - ----------------------- - -- Terminate_Process -- - ----------------------- - - procedure Terminate_Process (Pid : Integer) is - procedure Internal (Pid : Integer); - pragma Import (C, Internal, "__gnat_terminate_pid"); - begin - Internal (Pid); - end Terminate_Process; - - ----------------------- - -- Pseudo_Descriptor -- - ----------------------- - - procedure Pseudo_Descriptor - (Descriptor : out TTY_Process_Descriptor'Class; - TTY : GNAT.TTY.TTY_Handle; - Buffer_Size : Natural := 4096) is - begin - Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY); - Descriptor.Output_Fd := Descriptor.Input_Fd; - - -- Create the buffer - - Descriptor.Buffer_Size := Buffer_Size; - - if Buffer_Size /= 0 then - Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); - end if; - end Pseudo_Descriptor; - - ---------- - -- Send -- - ---------- - - overriding procedure Send - (Descriptor : in out TTY_Process_Descriptor; - Str : String; - Add_LF : Boolean := True; - Empty_Buffer : Boolean := False) - is - Header : String (1 .. 5); - Length : Natural; - Ret : Natural; - - procedure Internal - (Process : System.Address; - S : in out String; - Length : Natural; - Ret : out Natural); - pragma Import (C, Internal, "__gnat_send_header"); - - begin - Length := Str'Length; - - if Add_LF then - Length := Length + 1; - end if; - - Internal (Descriptor.Process, Header, Length, Ret); - - if Ret = 1 then - - -- Need to use the header - - GNAT.Expect.Send - (Process_Descriptor (Descriptor), - Header & Str, Add_LF, Empty_Buffer); - - else - GNAT.Expect.Send - (Process_Descriptor (Descriptor), - Str, Add_LF, Empty_Buffer); - end if; - end Send; - - -------------- - -- Set_Size -- - -------------- - - procedure Set_Size - (Descriptor : in out TTY_Process_Descriptor'Class; - Rows : Natural; - Columns : Natural) - is - procedure Internal (Process : System.Address; R, C : Integer); - pragma Import (C, Internal, "__gnat_setup_winsize"); - begin - if Descriptor.Process /= System.Null_Address then - Internal (Descriptor.Process, Rows, Columns); - end if; - end Set_Size; - - --------------------------- - -- Set_Up_Communications -- - --------------------------- - - overriding procedure Set_Up_Communications - (Pid : in out TTY_Process_Descriptor; - Err_To_Out : Boolean; - Pipe1 : access Pipe_Type; - Pipe2 : access Pipe_Type; - Pipe3 : access Pipe_Type) - is - pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3); - - function Internal (Process : System.Address) return Integer; - pragma Import (C, Internal, "__gnat_setup_communication"); - - begin - if Internal (Pid.Process'Address) /= 0 then - raise Invalid_Process with "cannot setup communication."; - end if; - end Set_Up_Communications; - - --------------------------------- - -- Set_Up_Child_Communications -- - --------------------------------- - - overriding procedure Set_Up_Child_Communications - (Pid : in out TTY_Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type; - Cmd : String; - Args : System.Address) - is - pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd); - function Internal - (Process : System.Address; Argv : System.Address; Use_Pipes : Integer) - return Process_Id; - pragma Import (C, Internal, "__gnat_setup_child_communication"); - - begin - Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes)); - end Set_Up_Child_Communications; - - ---------------------------------- - -- Set_Up_Parent_Communications -- - ---------------------------------- - - overriding procedure Set_Up_Parent_Communications - (Pid : in out TTY_Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type) - is - pragma Unreferenced (Pipe1, Pipe2, Pipe3); - - procedure Internal - (Process : System.Address; - Inputfp : out File_Descriptor; - Outputfp : out File_Descriptor; - Errorfp : out File_Descriptor; - Pid : out Process_Id); - pragma Import (C, Internal, "__gnat_setup_parent_communication"); - - begin - Internal - (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid); - end Set_Up_Parent_Communications; - - ------------------- - -- Set_Use_Pipes -- - ------------------- - - procedure Set_Use_Pipes - (Descriptor : in out TTY_Process_Descriptor; - Use_Pipes : Boolean) is - begin - Descriptor.Use_Pipes := Use_Pipes; - end Set_Use_Pipes; - -end GNAT.Expect.TTY; diff --git a/gcc/ada/g-exptty.ads b/gcc/ada/g-exptty.ads deleted file mode 100644 index 10e0f81..0000000 --- a/gcc/ada/g-exptty.ads +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . E X P E C T . T T Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.TTY; - -with System; -with System.OS_Constants; - -package GNAT.Expect.TTY is - - pragma Linker_Options (System.OS_Constants.PTY_Library); - - ------------------ - -- TTY_Process -- - ------------------ - - type TTY_Process_Descriptor is new Process_Descriptor with private; - -- Similar to Process_Descriptor, with the parent set up as a full terminal - -- (Unix sense, see tty(4)). - - procedure Pseudo_Descriptor - (Descriptor : out TTY_Process_Descriptor'Class; - TTY : GNAT.TTY.TTY_Handle; - Buffer_Size : Natural := 4096); - -- Given a terminal descriptor (TTY), create a pseudo process descriptor - -- to be used with GNAT.Expect. - -- - -- Note that it is invalid to call Close, Interrupt, Send_Signal on the - -- resulting descriptor. To deallocate memory associated with Process, - -- call Close_Pseudo_Descriptor instead. - - procedure Close_Pseudo_Descriptor - (Descriptor : in out TTY_Process_Descriptor); - -- Free memory and ressources associated with Descriptor. Will *not* - -- close the associated TTY, it is the caller's responsibility to call - -- GNAT.TTY.Close_TTY. - - procedure Interrupt (Pid : Integer); - -- Interrupt a process given its pid. - -- This is equivalent to sending a ctrl-c event, or kill -SIGINT. - - procedure Terminate_Process (Pid : Integer); - -- Terminate abruptly a process given its pid. - -- This is equivalent to kill -SIGKILL under unix, or TerminateProcess - -- under Windows. - - overriding procedure Send - (Descriptor : in out TTY_Process_Descriptor; - Str : String; - Add_LF : Boolean := True; - Empty_Buffer : Boolean := False); - -- See parent - -- What does that comment mean??? what is "parent" here - - procedure Set_Use_Pipes - (Descriptor : in out TTY_Process_Descriptor; - Use_Pipes : Boolean); - -- Tell Expect.TTY whether to use Pipes or Console (on windows). Needs to - -- be set before spawning the process. Default is to use Pipes. - - procedure Set_Size - (Descriptor : in out TTY_Process_Descriptor'Class; - Rows : Natural; - Columns : Natural); - -- Sets up the size of the terminal as reported to the spawned process - -private - - -- All declarations in the private part must be fully commented ??? - - overriding procedure Close - (Descriptor : in out TTY_Process_Descriptor; - Status : out Integer); - - overriding procedure Close - (Descriptor : in out TTY_Process_Descriptor); - - overriding procedure Interrupt (Descriptor : in out TTY_Process_Descriptor); - -- When we use pseudo-terminals, we do not need to use signals to - -- interrupt the debugger, we can simply send the appropriate character. - -- This provides a better support for remote debugging for instance. - - procedure Set_Up_Communications - (Pid : in out TTY_Process_Descriptor; - Err_To_Out : Boolean; - Pipe1 : access Pipe_Type; - Pipe2 : access Pipe_Type; - Pipe3 : access Pipe_Type); - - procedure Set_Up_Parent_Communications - (Pid : in out TTY_Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type); - - procedure Set_Up_Child_Communications - (Pid : in out TTY_Process_Descriptor; - Pipe1 : in out Pipe_Type; - Pipe2 : in out Pipe_Type; - Pipe3 : in out Pipe_Type; - Cmd : String; - Args : System.Address); - - type TTY_Process_Descriptor is new Process_Descriptor with record - Process : System.Address; -- Underlying structure used in C - Use_Pipes : Boolean := True; - end record; - -end GNAT.Expect.TTY; diff --git a/gcc/ada/g-flocon.ads b/gcc/ada/g-flocon.ads deleted file mode 100644 index a7ab7f6..0000000 --- a/gcc/ada/g-flocon.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . F L O A T _ C O N T R O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2011, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Control functions for floating-point unit - --- See file s-flocon.ads for full documentation of the interface - -with System.Float_Control; - -package GNAT.Float_Control renames System.Float_Control; diff --git a/gcc/ada/g-forstr.adb b/gcc/ada/g-forstr.adb deleted file mode 100644 index 21ed66e..0000000 --- a/gcc/ada/g-forstr.adb +++ /dev/null @@ -1,984 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . F O R M A T T E D _ S T R I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Characters.Handling; -with Ada.Float_Text_IO; -with Ada.Integer_Text_IO; -with Ada.Long_Float_Text_IO; -with Ada.Long_Integer_Text_IO; -with Ada.Strings.Fixed; -with Ada.Unchecked_Deallocation; - -with System.Address_Image; - -package body GNAT.Formatted_String is - - type F_Kind is (Decimal_Int, -- %d %i - Unsigned_Decimal_Int, -- %u - Unsigned_Octal, -- %o - Unsigned_Hexadecimal_Int, -- %x - Unsigned_Hexadecimal_Int_Up, -- %X - Decimal_Float, -- %f %F - Decimal_Scientific_Float, -- %e - Decimal_Scientific_Float_Up, -- %E - Shortest_Decimal_Float, -- %g - Shortest_Decimal_Float_Up, -- %G - Char, -- %c - Str, -- %s - Pointer -- %p - ); - - type Sign_Kind is (Neg, Zero, Pos); - - subtype Is_Number is F_Kind range Decimal_Int .. Decimal_Float; - - type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg; - - type F_Base is (None, C_Style, Ada_Style) with Default_Value => None; - - Unset : constant Integer := -1; - - type F_Data is record - Kind : F_Kind; - Width : Natural := 0; - Precision : Integer := Unset; - Left_Justify : Boolean := False; - Sign : F_Sign; - Base : F_Base; - Zero_Pad : Boolean := False; - Value_Needed : Natural range 0 .. 2 := 0; - end record; - - procedure Next_Format - (Format : Formatted_String; - F_Spec : out F_Data; - Start : out Positive); - -- Parse the next format specifier, a format specifier has the following - -- syntax: %[flags][width][.precision][length]specifier - - function Get_Formatted - (F_Spec : F_Data; - Value : String; - Len : Positive) return String; - -- Returns Value formatted given the information in F_Spec - - procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return; - -- Raise the Format_Error exception which information about the context - - generic - type Flt is private; - - with procedure Put - (To : out String; - Item : Flt; - Aft : Text_IO.Field; - Exp : Text_IO.Field); - function P_Flt_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String; - -- Generic routine which handles all floating point numbers - - generic - type Int is private; - - with function To_Integer (Item : Int) return Integer; - - with function Sign (Item : Int) return Sign_Kind; - - with procedure Put - (To : out String; - Item : Int; - Base : Text_IO.Number_Base); - function P_Int_Format - (Format : Formatted_String; - Var : Int) return Formatted_String; - -- Generic routine which handles all the integer numbers - - --------- - -- "+" -- - --------- - - function "+" (Format : String) return Formatted_String is - begin - return Formatted_String' - (Finalization.Controlled with - D => new Data'(Format'Length, 1, 1, - Null_Unbounded_String, 0, 0, (0, 0), Format)); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Format : Formatted_String) return String is - F : String renames Format.D.Format; - J : Natural renames Format.D.Index; - R : Unbounded_String := Format.D.Result; - - begin - -- Make sure we get the remaining character up to the next unhandled - -- format specifier. - - while (J <= F'Length and then F (J) /= '%') - or else (J < F'Length - 1 and then F (J + 1) = '%') - loop - Append (R, F (J)); - - -- If we have two consecutive %, skip the second one - - if F (J) = '%' and then J < F'Length - 1 and then F (J + 1) = '%' then - J := J + 1; - end if; - - J := J + 1; - end loop; - - return To_String (R); - end "-"; - - --------- - -- "&" -- - --------- - - function "&" - (Format : Formatted_String; - Var : Character) return Formatted_String - is - F : F_Data; - Start : Positive; - - begin - Next_Format (Format, F, Start); - - if F.Value_Needed > 0 then - Raise_Wrong_Format (Format); - end if; - - case F.Kind is - when Char => - Append (Format.D.Result, Get_Formatted (F, String'(1 => Var), 1)); - when others => - Raise_Wrong_Format (Format); - end case; - - return Format; - end "&"; - - function "&" - (Format : Formatted_String; - Var : String) return Formatted_String - is - F : F_Data; - Start : Positive; - - begin - Next_Format (Format, F, Start); - - if F.Value_Needed > 0 then - Raise_Wrong_Format (Format); - end if; - - case F.Kind is - when Str => - declare - S : constant String := Get_Formatted (F, Var, Var'Length); - begin - if F.Precision = Unset then - Append (Format.D.Result, S); - else - Append - (Format.D.Result, - S (S'First .. S'First + F.Precision - 1)); - end if; - end; - - when others => - Raise_Wrong_Format (Format); - end case; - - return Format; - end "&"; - - function "&" - (Format : Formatted_String; - Var : Boolean) return Formatted_String is - begin - return Format & Boolean'Image (Var); - end "&"; - - function "&" - (Format : Formatted_String; - Var : Float) return Formatted_String - is - function Float_Format is new Flt_Format (Float, Float_Text_IO.Put); - begin - return Float_Format (Format, Var); - end "&"; - - function "&" - (Format : Formatted_String; - Var : Long_Float) return Formatted_String - is - function Float_Format is - new Flt_Format (Long_Float, Long_Float_Text_IO.Put); - begin - return Float_Format (Format, Var); - end "&"; - - function "&" - (Format : Formatted_String; - Var : Duration) return Formatted_String - is - package Duration_Text_IO is new Text_IO.Fixed_IO (Duration); - function Duration_Format is - new P_Flt_Format (Duration, Duration_Text_IO.Put); - begin - return Duration_Format (Format, Var); - end "&"; - - function "&" - (Format : Formatted_String; - Var : Integer) return Formatted_String - is - function Integer_Format is - new Int_Format (Integer, Integer_Text_IO.Put); - begin - return Integer_Format (Format, Var); - end "&"; - - function "&" - (Format : Formatted_String; - Var : Long_Integer) return Formatted_String - is - function Integer_Format is - new Int_Format (Long_Integer, Long_Integer_Text_IO.Put); - begin - return Integer_Format (Format, Var); - end "&"; - - function "&" - (Format : Formatted_String; - Var : System.Address) return Formatted_String - is - A_Img : constant String := System.Address_Image (Var); - F : F_Data; - Start : Positive; - - begin - Next_Format (Format, F, Start); - - if F.Value_Needed > 0 then - Raise_Wrong_Format (Format); - end if; - - case F.Kind is - when Pointer => - Append (Format.D.Result, Get_Formatted (F, A_Img, A_Img'Length)); - when others => - Raise_Wrong_Format (Format); - end case; - - return Format; - end "&"; - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (F : in out Formatted_String) is - begin - F.D.Ref_Count := F.D.Ref_Count + 1; - end Adjust; - - -------------------- - -- Decimal_Format -- - -------------------- - - function Decimal_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String - is - function Flt_Format is new P_Flt_Format (Flt, Put); - begin - return Flt_Format (Format, Var); - end Decimal_Format; - - ----------------- - -- Enum_Format -- - ----------------- - - function Enum_Format - (Format : Formatted_String; - Var : Enum) return Formatted_String is - begin - return Format & Enum'Image (Var); - end Enum_Format; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (F : in out Formatted_String) is - procedure Unchecked_Free is - new Unchecked_Deallocation (Data, Data_Access); - - D : Data_Access := F.D; - - begin - F.D := null; - - D.Ref_Count := D.Ref_Count - 1; - - if D.Ref_Count = 0 then - Unchecked_Free (D); - end if; - end Finalize; - - ------------------ - -- Fixed_Format -- - ------------------ - - function Fixed_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String - is - function Flt_Format is new P_Flt_Format (Flt, Put); - begin - return Flt_Format (Format, Var); - end Fixed_Format; - - ---------------- - -- Flt_Format -- - ---------------- - - function Flt_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String - is - function Flt_Format is new P_Flt_Format (Flt, Put); - begin - return Flt_Format (Format, Var); - end Flt_Format; - - ------------------- - -- Get_Formatted -- - ------------------- - - function Get_Formatted - (F_Spec : F_Data; - Value : String; - Len : Positive) return String - is - use Ada.Strings.Fixed; - - Res : Unbounded_String; - S : Positive := Value'First; - - begin - -- Handle the flags - - if F_Spec.Kind in Is_Number then - if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then - Append (Res, "+"); - elsif F_Spec.Sign = Space and then Value (Value'First) /= '-' then - Append (Res, " "); - end if; - - if Value (Value'First) = '-' then - Append (Res, "-"); - S := S + 1; - end if; - end if; - - -- Zero padding if required and possible - - if F_Spec.Left_Justify = False - and then F_Spec.Zero_Pad - and then F_Spec.Width > Len + Value'First - S - then - Append (Res, String'((F_Spec.Width - Len + Value'First - S) * '0')); - end if; - - -- Add the value now - - Append (Res, Value (S .. Value'Last)); - - declare - R : String (1 .. Natural'Max (Natural'Max (F_Spec.Width, Len), - Length (Res))) := (others => ' '); - begin - if F_Spec.Left_Justify then - R (1 .. Length (Res)) := To_String (Res); - else - R (R'Last - Length (Res) + 1 .. R'Last) := To_String (Res); - end if; - - return R; - end; - end Get_Formatted; - - ---------------- - -- Int_Format -- - ---------------- - - function Int_Format - (Format : Formatted_String; - Var : Int) return Formatted_String - is - function Sign (Var : Int) return Sign_Kind is - (if Var < 0 then Neg elsif Var = 0 then Zero else Pos); - - function To_Integer (Var : Int) return Integer is - (Integer (Var)); - - function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put); - - begin - return Int_Format (Format, Var); - end Int_Format; - - ---------------- - -- Mod_Format -- - ---------------- - - function Mod_Format - (Format : Formatted_String; - Var : Int) return Formatted_String - is - function Sign (Var : Int) return Sign_Kind is - (if Var < 0 then Neg elsif Var = 0 then Zero else Pos); - - function To_Integer (Var : Int) return Integer is - (Integer (Var)); - - function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put); - - begin - return Int_Format (Format, Var); - end Mod_Format; - - ----------------- - -- Next_Format -- - ----------------- - - procedure Next_Format - (Format : Formatted_String; - F_Spec : out F_Data; - Start : out Positive) - is - F : String renames Format.D.Format; - J : Natural renames Format.D.Index; - S : Natural; - Width_From_Var : Boolean := False; - - begin - Format.D.Current := Format.D.Current + 1; - F_Spec.Value_Needed := 0; - - -- Got to next % - - while (J <= F'Last and then F (J) /= '%') - or else (J < F'Last - 1 and then F (J + 1) = '%') - loop - Append (Format.D.Result, F (J)); - - -- If we have two consecutive %, skip the second one - - if F (J) = '%' and then J < F'Last - 1 and then F (J + 1) = '%' then - J := J + 1; - end if; - - J := J + 1; - end loop; - - if F (J) /= '%' or else J = F'Last then - raise Format_Error with "no format specifier found for parameter" - & Positive'Image (Format.D.Current); - end if; - - Start := J; - - J := J + 1; - - -- Check for any flags - - Flags_Check : while J < F'Last loop - if F (J) = '-' then - F_Spec.Left_Justify := True; - elsif F (J) = '+' then - F_Spec.Sign := Forced; - elsif F (J) = ' ' then - F_Spec.Sign := Space; - elsif F (J) = '#' then - F_Spec.Base := C_Style; - elsif F (J) = '~' then - F_Spec.Base := Ada_Style; - elsif F (J) = '0' then - F_Spec.Zero_Pad := True; - else - exit Flags_Check; - end if; - - J := J + 1; - end loop Flags_Check; - - -- Check width if any - - if F (J) in '0' .. '9' then - - -- We have a width parameter - - S := J; - - while J < F'Last and then F (J + 1) in '0' .. '9' loop - J := J + 1; - end loop; - - F_Spec.Width := Natural'Value (F (S .. J)); - - J := J + 1; - - elsif F (J) = '*' then - - -- The width will be taken from the integer parameter - - F_Spec.Value_Needed := 1; - Width_From_Var := True; - - J := J + 1; - end if; - - if F (J) = '.' then - - -- We have a precision parameter - - J := J + 1; - - if F (J) in '0' .. '9' then - S := J; - - while J < F'Length and then F (J + 1) in '0' .. '9' loop - J := J + 1; - end loop; - - if F (J) = '.' then - - -- No precision, 0 is assumed - - F_Spec.Precision := 0; - - else - F_Spec.Precision := Natural'Value (F (S .. J)); - end if; - - J := J + 1; - - elsif F (J) = '*' then - - -- The prevision will be taken from the integer parameter - - F_Spec.Value_Needed := F_Spec.Value_Needed + 1; - J := J + 1; - end if; - end if; - - -- Skip the length specifier, this is not needed for this implementation - -- but yet for compatibility reason it is handled. - - Length_Check : - while J <= F'Last - and then F (J) in 'h' | 'l' | 'j' | 'z' | 't' | 'L' - loop - J := J + 1; - end loop Length_Check; - - if J > F'Last then - Raise_Wrong_Format (Format); - end if; - - -- Read next character which should be the expected type - - case F (J) is - when 'c' => F_Spec.Kind := Char; - when 's' => F_Spec.Kind := Str; - when 'd' | 'i' => F_Spec.Kind := Decimal_Int; - when 'u' => F_Spec.Kind := Unsigned_Decimal_Int; - when 'f' | 'F' => F_Spec.Kind := Decimal_Float; - when 'e' => F_Spec.Kind := Decimal_Scientific_Float; - when 'E' => F_Spec.Kind := Decimal_Scientific_Float_Up; - when 'g' => F_Spec.Kind := Shortest_Decimal_Float; - when 'G' => F_Spec.Kind := Shortest_Decimal_Float_Up; - when 'o' => F_Spec.Kind := Unsigned_Octal; - when 'x' => F_Spec.Kind := Unsigned_Hexadecimal_Int; - when 'X' => F_Spec.Kind := Unsigned_Hexadecimal_Int_Up; - - when others => - raise Format_Error with "unknown format specified for parameter" - & Positive'Image (Format.D.Current); - end case; - - J := J + 1; - - if F_Spec.Value_Needed > 0 - and then F_Spec.Value_Needed = Format.D.Stored_Value - then - if F_Spec.Value_Needed = 1 then - if Width_From_Var then - F_Spec.Width := Format.D.Stack (1); - else - F_Spec.Precision := Format.D.Stack (1); - end if; - - else - F_Spec.Width := Format.D.Stack (1); - F_Spec.Precision := Format.D.Stack (2); - end if; - end if; - end Next_Format; - - ------------------ - -- P_Flt_Format -- - ------------------ - - function P_Flt_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String - is - F : F_Data; - Buffer : String (1 .. 50); - S, E : Positive := 1; - Start : Positive; - Aft : Text_IO.Field; - - begin - Next_Format (Format, F, Start); - - if F.Value_Needed > 0 then - Raise_Wrong_Format (Format); - end if; - - if F.Precision = Unset then - Aft := 6; - else - Aft := F.Precision; - end if; - - case F.Kind is - when Decimal_Float => - - Put (Buffer, Var, Aft, Exp => 0); - S := Strings.Fixed.Index_Non_Blank (Buffer); - E := Buffer'Last; - - when Decimal_Scientific_Float - | Decimal_Scientific_Float_Up - => - Put (Buffer, Var, Aft, Exp => 3); - S := Strings.Fixed.Index_Non_Blank (Buffer); - E := Buffer'Last; - - if F.Kind = Decimal_Scientific_Float then - Buffer (S .. E) := - Characters.Handling.To_Lower (Buffer (S .. E)); - end if; - - when Shortest_Decimal_Float - | Shortest_Decimal_Float_Up - => - -- Without exponent - - Put (Buffer, Var, Aft, Exp => 0); - S := Strings.Fixed.Index_Non_Blank (Buffer); - E := Buffer'Last; - - -- Check with exponent - - declare - Buffer2 : String (1 .. 50); - S2, E2 : Positive; - - begin - Put (Buffer2, Var, Aft, Exp => 3); - S2 := Strings.Fixed.Index_Non_Blank (Buffer2); - E2 := Buffer2'Last; - - -- If with exponent it is shorter, use it - - if (E2 - S2) < (E - S) then - Buffer := Buffer2; - S := S2; - E := E2; - end if; - end; - - if F.Kind = Shortest_Decimal_Float then - Buffer (S .. E) := - Characters.Handling.To_Lower (Buffer (S .. E)); - end if; - - when others => - Raise_Wrong_Format (Format); - end case; - - Append (Format.D.Result, - Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length)); - - return Format; - end P_Flt_Format; - - ------------------ - -- P_Int_Format -- - ------------------ - - function P_Int_Format - (Format : Formatted_String; - Var : Int) return Formatted_String - is - function Handle_Precision return Boolean; - -- Return True if nothing else to do - - F : F_Data; - Buffer : String (1 .. 50); - S, E : Positive := 1; - Len : Natural := 0; - Start : Positive; - - ---------------------- - -- Handle_Precision -- - ---------------------- - - function Handle_Precision return Boolean is - begin - if F.Precision = 0 and then Sign (Var) = Zero then - return True; - - elsif F.Precision = Natural'Last then - null; - - elsif F.Precision > E - S + 1 then - Len := F.Precision - (E - S + 1); - Buffer (S - Len .. S - 1) := (others => '0'); - S := S - Len; - end if; - - return False; - end Handle_Precision; - - -- Start of processing for P_Int_Format - - begin - Next_Format (Format, F, Start); - - if Format.D.Stored_Value < F.Value_Needed then - Format.D.Stored_Value := Format.D.Stored_Value + 1; - Format.D.Stack (Format.D.Stored_Value) := To_Integer (Var); - Format.D.Index := Start; - return Format; - end if; - - case F.Kind is - when Unsigned_Octal => - if Sign (Var) = Neg then - Raise_Wrong_Format (Format); - end if; - - Put (Buffer, Var, Base => 8); - S := Strings.Fixed.Index (Buffer, "8#") + 2; - E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; - - if Handle_Precision then - return Format; - end if; - - case F.Base is - when None => null; - when C_Style => Len := 1; - when Ada_Style => Len := 3; - end case; - - when Unsigned_Hexadecimal_Int => - if Sign (Var) = Neg then - Raise_Wrong_Format (Format); - end if; - - Put (Buffer, Var, Base => 16); - S := Strings.Fixed.Index (Buffer, "16#") + 3; - E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; - Buffer (S .. E) := Characters.Handling.To_Lower (Buffer (S .. E)); - - if Handle_Precision then - return Format; - end if; - - case F.Base is - when None => null; - when C_Style => Len := 2; - when Ada_Style => Len := 4; - end case; - - when Unsigned_Hexadecimal_Int_Up => - if Sign (Var) = Neg then - Raise_Wrong_Format (Format); - end if; - - Put (Buffer, Var, Base => 16); - S := Strings.Fixed.Index (Buffer, "16#") + 3; - E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; - - if Handle_Precision then - return Format; - end if; - - case F.Base is - when None => null; - when C_Style => Len := 2; - when Ada_Style => Len := 4; - end case; - - when Unsigned_Decimal_Int => - if Sign (Var) = Neg then - Raise_Wrong_Format (Format); - end if; - - Put (Buffer, Var, Base => 10); - S := Strings.Fixed.Index_Non_Blank (Buffer); - E := Buffer'Last; - - if Handle_Precision then - return Format; - end if; - - when Decimal_Int => - Put (Buffer, Var, Base => 10); - S := Strings.Fixed.Index_Non_Blank (Buffer); - E := Buffer'Last; - - if Handle_Precision then - return Format; - end if; - - when Char => - S := Buffer'First; - E := Buffer'First; - Buffer (S) := Character'Val (To_Integer (Var)); - - if Handle_Precision then - return Format; - end if; - - when others => - Raise_Wrong_Format (Format); - end case; - - -- Then add base if needed - - declare - N : String := Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len); - P : constant Positive := - (if F.Left_Justify - then N'First - else Natural'Max (Strings.Fixed.Index_Non_Blank (N) - 1, - N'First)); - begin - case F.Base is - when None => - null; - - when C_Style => - case F.Kind is - when Unsigned_Octal => - N (P) := 'O'; - - when Unsigned_Hexadecimal_Int => - if F.Left_Justify then - N (P .. P + 1) := "Ox"; - else - N (P - 1 .. P) := "0x"; - end if; - - when Unsigned_Hexadecimal_Int_Up => - if F.Left_Justify then - N (P .. P + 1) := "OX"; - else - N (P - 1 .. P) := "0X"; - end if; - - when others => - null; - end case; - - when Ada_Style => - case F.Kind is - when Unsigned_Octal => - if F.Left_Justify then - N (N'First + 2 .. N'Last) := N (N'First .. N'Last - 2); - else - N (P .. N'Last - 1) := N (P + 1 .. N'Last); - end if; - - N (N'First .. N'First + 1) := "8#"; - N (N'Last) := '#'; - - when Unsigned_Hexadecimal_Int - | Unsigned_Hexadecimal_Int_Up - => - if F.Left_Justify then - N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3); - else - N (P .. N'Last - 1) := N (P + 1 .. N'Last); - end if; - - N (N'First .. N'First + 2) := "16#"; - N (N'Last) := '#'; - - when others => - null; - end case; - end case; - - Append (Format.D.Result, N); - end; - - return Format; - end P_Int_Format; - - ------------------------ - -- Raise_Wrong_Format -- - ------------------------ - - procedure Raise_Wrong_Format (Format : Formatted_String) is - begin - raise Format_Error with - "wrong format specified for parameter" - & Positive'Image (Format.D.Current); - end Raise_Wrong_Format; - -end GNAT.Formatted_String; diff --git a/gcc/ada/g-forstr.ads b/gcc/ada/g-forstr.ads deleted file mode 100644 index 165440c..0000000 --- a/gcc/ada/g-forstr.ads +++ /dev/null @@ -1,311 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . F O R M A T T E D _ S T R I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package add support for formatted string as supported by C printf() - --- A simple usage is: --- --- Put_Line (-(+"%s" & "a string")); --- --- or with a constant for the format: --- --- declare --- Format : constant Formatted_String := +"%s"; --- begin --- Put_Line (-(Format & "a string")); --- end; --- --- Finally a more complex example: --- --- declare --- F : Formatted_String := +"['%c' ; %10d]"; --- C : Character := 'v'; --- I : Integer := 98; --- begin --- F := F & C & I; --- Put_Line (-F); --- end; - --- Which will display: - --- ['v' ; 98] - --- Each format specifier is: %[flags][width][.precision][length]specifier - --- Specifiers: --- d or i Signed decimal integer --- u Unsigned decimal integer --- o Unsigned octal --- x Unsigned hexadecimal integer --- X Unsigned hexadecimal integer (uppercase) --- f Decimal floating point, lowercase --- F Decimal floating point, uppercase --- e Scientific notation (mantissa/exponent), lowercase --- E Scientific notation (mantissa/exponent), uppercase --- g Use the shortest representation: %e or %f --- G Use the shortest representation: %E or %F --- c Character --- s String of characters --- p Pointer address --- % A % followed by another % character will write a single % - --- Flags: - --- - Left-justify within the given field width; --- Right justification is the default. - --- + Forces to preceed the result with a plus or minus sign (+ or -) --- even for positive numbers. By default, only negative numbers --- are preceded with a - sign. - --- (space) If no sign is going to be written, a blank space is inserted --- before the value. - --- # Used with o, x or X specifiers the value is preceeded with --- 0, 0x or 0X respectively for values different than zero. --- Used with a, A, e, E, f, F, g or G it forces the written --- output to contain a decimal point even if no more digits --- follow. By default, if no digits follow, no decimal point is --- written. - --- ~ As above, but using Ada style based ## - --- 0 Left-pads the number with zeroes (0) instead of spaces when --- padding is specified. - --- Width: --- number Minimum number of characters to be printed. If the value to --- be printed is shorter than this number, the result is padded --- with blank spaces. The value is not truncated even if the --- result is larger. - --- * The width is not specified in the format string, but as an --- additional integer value argument preceding the argument that --- has to be formatted. --- Precision: --- number For integer specifiers (d, i, o, u, x, X): precision specifies --- the minimum number of digits to be written. If the value to be --- written is shorter than this number, the result is padded with --- leading zeros. The value is not truncated even if the result --- is longer. A precision of 0 means that no character is written --- for the value 0. - --- For e, E, f and F specifiers: this is the number of digits to --- be printed after the decimal point (by default, this is 6). --- For g and G specifiers: This is the maximum number of --- significant digits to be printed. - --- For s: this is the maximum number of characters to be printed. --- By default all characters are printed until the ending null --- character is encountered. - --- If the period is specified without an explicit value for --- precision, 0 is assumed. - --- .* The precision is not specified in the format string, but as an --- additional integer value argument preceding the argument that --- has to be formatted. - -with Ada.Text_IO; -with System; - -private with Ada.Finalization; -private with Ada.Strings.Unbounded; - -package GNAT.Formatted_String is - use Ada; - - type Formatted_String (<>) is private; - -- A format string as defined for printf routine. This string is the - -- actual format for all the parameters added with the "&" routines below. - -- Note that a Formatted_String object can't be reused as it serves as - -- recipient for the final result. That is, each use of "&" will build - -- incrementally the final result string which can be retrieved with - -- the "-" routine below. - - Format_Error : exception; - -- Raised for every mismatch between the parameter and the expected format - -- and for malformed format. - - function "+" (Format : String) return Formatted_String; - -- Create the format string - - function "-" (Format : Formatted_String) return String; - -- Get the result of the formatted string corresponding to the current - -- rendering (up to the last parameter formated). - - function "&" - (Format : Formatted_String; - Var : Character) return Formatted_String; - -- A character, expect a %c - - function "&" - (Format : Formatted_String; - Var : String) return Formatted_String; - -- A string, expect a %s - - function "&" - (Format : Formatted_String; - Var : Boolean) return Formatted_String; - -- A boolean image, expect a %s - - function "&" - (Format : Formatted_String; - Var : Integer) return Formatted_String; - -- An integer, expect a %d, %o, %x, %X - - function "&" - (Format : Formatted_String; - Var : Long_Integer) return Formatted_String; - -- As above - - function "&" - (Format : Formatted_String; - Var : System.Address) return Formatted_String; - -- An address, expect a %p - - function "&" - (Format : Formatted_String; - Var : Float) return Formatted_String; - -- A float, expect %f, %e, %F, %E, %g, %G - - function "&" - (Format : Formatted_String; - Var : Long_Float) return Formatted_String; - -- As above - - function "&" - (Format : Formatted_String; - Var : Duration) return Formatted_String; - -- As above - - -- Some generics - - generic - type Int is range <>; - - with procedure Put - (To : out String; - Item : Int; - Base : Text_IO.Number_Base); - function Int_Format - (Format : Formatted_String; - Var : Int) return Formatted_String; - -- As for Integer above - - generic - type Int is mod <>; - - with procedure Put - (To : out String; - Item : Int; - Base : Text_IO.Number_Base); - function Mod_Format - (Format : Formatted_String; - Var : Int) return Formatted_String; - -- As for Integer above - - generic - type Flt is digits <>; - - with procedure Put - (To : out String; - Item : Flt; - Aft : Text_IO.Field; - Exp : Text_IO.Field); - function Flt_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String; - -- As for Float above - - generic - type Flt is delta <>; - - with procedure Put - (To : out String; - Item : Flt; - Aft : Text_IO.Field; - Exp : Text_IO.Field); - function Fixed_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String; - -- As for Float above - - generic - type Flt is delta <> digits <>; - - with procedure Put - (To : out String; - Item : Flt; - Aft : Text_IO.Field; - Exp : Text_IO.Field); - function Decimal_Format - (Format : Formatted_String; - Var : Flt) return Formatted_String; - -- As for Float above - - generic - type Enum is (<>); - function Enum_Format - (Format : Formatted_String; - Var : Enum) return Formatted_String; - -- As for String above, output the string representation of the enumeration - -private - use Ada.Strings.Unbounded; - - type I_Vars is array (Positive range 1 .. 2) of Integer; - -- Used to keep 2 numbers for the possible * for the width and precision - - type Data (Size : Natural) is record - Ref_Count : Natural := 1; - Index : Positive := 1; -- format index for next value - Result : Unbounded_String; -- current value - Current : Natural; -- the current format number - Stored_Value : Natural := 0; -- number of stored values in Stack - Stack : I_Vars; - Format : String (1 .. Size); -- the format string - end record; - - type Data_Access is access Data; - - -- The formatted string record is controlled and do not need an initialize - -- as it requires an explit initial value. This is given with "+" and - -- properly initialize the record at this point. - - type Formatted_String is new Finalization.Controlled with record - D : Data_Access; - end record; - - overriding procedure Adjust (F : in out Formatted_String); - overriding procedure Finalize (F : in out Formatted_String); - -end GNAT.Formatted_String; diff --git a/gcc/ada/g-heasor.adb b/gcc/ada/g-heasor.adb deleted file mode 100644 index ec91515..0000000 --- a/gcc/ada/g-heasor.adb +++ /dev/null @@ -1,130 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H E A P _ S O R T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Heap_Sort is - - ---------- - -- Sort -- - ---------- - - -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) - -- as described by Knuth ("The Art of Programming", Volume III, first - -- edition, section 5.2.3, p. 145-147) with the modification that is - -- mentioned in exercise 18. For more details on this algorithm, see - -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray - -- Phase Problem". University of Chicago, 1968, which was the first - -- publication of the modification, which reduces the number of compares - -- from 2NlogN to NlogN. - - procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function) is - Max : Natural := N; - -- Current Max index in tree being sifted. Note that we make Max - -- Natural rather than Positive so that the case of sorting zero - -- elements is correctly handled (i.e. does nothing at all). - - procedure Sift (S : Positive); - -- This procedure sifts up node S, i.e. converts the subtree rooted - -- at node S into a heap, given the precondition that any sons of - -- S are already heaps. - - ---------- - -- Sift -- - ---------- - - procedure Sift (S : Positive) is - C : Positive := S; - Son : Positive; - Father : Positive; - - begin - -- This is where the optimization is done, normally we would do a - -- comparison at each stage between the current node and the larger - -- of the two sons, and continue the sift only if the current node - -- was less than this maximum. In this modified optimized version, - -- we assume that the current node will be less than the larger - -- son, and unconditionally sift up. Then when we get to the bottom - -- of the tree, we check parents to make sure that we did not make - -- a mistake. This roughly cuts the number of comparisons in half, - -- since it is almost always the case that our assumption is correct. - - -- Loop to pull up larger sons - - loop - Son := C + C; - - if Son < Max then - if Lt (Son, Son + 1) then - Son := Son + 1; - end if; - elsif Son > Max then - exit; - end if; - - Xchg (Son, C); - C := Son; - end loop; - - -- Loop to check fathers - - while C /= S loop - Father := C / 2; - - if Lt (Father, C) then - Xchg (Father, C); - C := Father; - else - exit; - end if; - end loop; - end Sift; - - -- Start of processing for Sort - - begin - -- Phase one of heapsort is to build the heap. This is done by - -- sifting nodes N/2 .. 1 in sequence. - - for J in reverse 1 .. N / 2 loop - Sift (J); - end loop; - - -- In phase 2, the largest node is moved to end, reducing the size - -- of the tree by one, and the displaced node is sifted down from - -- the top, so that the largest node is again at the top. - - while Max > 1 loop - Xchg (1, Max); - Max := Max - 1; - Sift (1); - end loop; - end Sort; - -end GNAT.Heap_Sort; diff --git a/gcc/ada/g-heasor.ads b/gcc/ada/g-heasor.ads deleted file mode 100644 index edc9294..0000000 --- a/gcc/ada/g-heasor.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H E A P _ S O R T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Sort utility (Using Heapsort Algorithm) - --- This package provides a heapsort routine that works with access to --- subprogram parameters, so that it can be used with different types with --- shared sorting code. - --- This heapsort algorithm uses approximately N*log(N) compares in the --- worst case and is in place with no additional storage required. See --- the body for exact details of the algorithm used. - --- See also GNAT.Heap_Sort_G which is a generic version that will be faster --- since the overhead of the indirect calls is avoided, at the expense of --- generic code duplication and less convenient interface. - --- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is --- retained in the GNAT library for backwards compatibility. - -package GNAT.Heap_Sort is - pragma Pure; - - -- The data to be sorted is assumed to be indexed by integer values - -- from 1 to N, where N is the number of items to be sorted. - - type Xchg_Procedure is access procedure (Op1, Op2 : Natural); - -- A pointer to a procedure that exchanges the two data items whose - -- index values are Op1 and Op2. - - type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; - -- A pointer to a function that compares two items and returns True if - -- the item with index value Op1 is less than the item with Index value - -- Op2, and False if the Op1 item is greater than the Op2 item. If - -- the items are equal, then it does not matter if True or False is - -- returned (but it is slightly more efficient to return False). - - procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function); - -- This procedures sorts items in the range from 1 to N into ascending - -- order making calls to Lt to do required comparisons, and calls to - -- Xchg to exchange items. The sort is not stable, that is the order - -- of equal items in the input data set is not preserved. - -end GNAT.Heap_Sort; diff --git a/gcc/ada/g-hesora.adb b/gcc/ada/g-hesora.adb deleted file mode 100644 index cf7202d..0000000 --- a/gcc/ada/g-hesora.adb +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H E A P _ S O R T _ A -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body GNAT.Heap_Sort_A is - - ---------- - -- Sort -- - ---------- - - -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) - -- as described by Knuth ("The Art of Programming", Volume III, first - -- edition, section 5.2.3, p. 145-147) with the modification that is - -- mentioned in exercise 18. For more details on this algorithm, see - -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray - -- Phase Problem". University of Chicago, 1968, which was the first - -- publication of the modification, which reduces the number of compares - -- from 2NlogN to NlogN. - - procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is - - Max : Natural := N; - -- Current Max index in tree being sifted - - procedure Sift (S : Positive); - -- This procedure sifts up node S, i.e. converts the subtree rooted - -- at node S into a heap, given the precondition that any sons of - -- S are already heaps. On entry, the contents of node S is found - -- in the temporary (index 0), the actual contents of node S on - -- entry are irrelevant. This is just a minor optimization to avoid - -- what would otherwise be two junk moves in phase two of the sort. - - procedure Sift (S : Positive) is - C : Positive := S; - Son : Positive; - Father : Positive; - - begin - -- This is where the optimization is done, normally we would do a - -- comparison at each stage between the current node and the larger - -- of the two sons, and continue the sift only if the current node - -- was less than this maximum. In this modified optimized version, - -- we assume that the current node will be less than the larger - -- son, and unconditionally sift up. Then when we get to the bottom - -- of the tree, we check parents to make sure that we did not make - -- a mistake. This roughly cuts the number of comparisons in half, - -- since it is almost always the case that our assumption is correct. - - -- Loop to pull up larger sons - - loop - Son := 2 * C; - exit when Son > Max; - - if Son < Max and then Lt (Son, Son + 1) then - Son := Son + 1; - end if; - - Move (Son, C); - C := Son; - end loop; - - -- Loop to check fathers - - while C /= S loop - Father := C / 2; - - if Lt (Father, 0) then - Move (Father, C); - C := Father; - else - exit; - end if; - end loop; - - -- Last step is to pop the sifted node into place - - Move (0, C); - end Sift; - - -- Start of processing for Sort - - begin - -- Phase one of heapsort is to build the heap. This is done by - -- sifting nodes N/2 .. 1 in sequence. - - for J in reverse 1 .. N / 2 loop - Move (J, 0); - Sift (J); - end loop; - - -- In phase 2, the largest node is moved to end, reducing the size - -- of the tree by one, and the displaced node is sifted down from - -- the top, so that the largest node is again at the top. - - while Max > 1 loop - Move (Max, 0); - Move (1, Max); - Max := Max - 1; - Sift (1); - end loop; - - end Sort; - -end GNAT.Heap_Sort_A; diff --git a/gcc/ada/g-hesora.ads b/gcc/ada/g-hesora.ads deleted file mode 100644 index e270172..0000000 --- a/gcc/ada/g-hesora.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H E A P _ S O R T _ A -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Heapsort using access to procedure parameters - --- This package provides a heap sort routine that works with access to --- subprogram parameters, so that it can be used with different types with --- shared sorting code. It is considered obsoleted by GNAT.Heap_Sort which --- offers a similar routine with a more convenient interface. - --- This heapsort algorithm uses approximately N*log(N) compares in the --- worst case and is in place with no additional storage required. See --- the body for exact details of the algorithm used. - -pragma Compiler_Unit_Warning; - -package GNAT.Heap_Sort_A is - pragma Preelaborate; - - -- The data to be sorted is assumed to be indexed by integer values from - -- 1 to N, where N is the number of items to be sorted. In addition, the - -- index value zero is used for a temporary location used during the sort. - - type Move_Procedure is access procedure (From : Natural; To : Natural); - -- A pointer to a procedure that moves the data item with index From to - -- the data item with index To. An index value of zero is used for moves - -- from and to the single temporary location used by the sort. - - type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; - -- A pointer to a function that compares two items and returns True if - -- the item with index Op1 is less than the item with index Op2, and False - -- if the Op1 item is greater than or equal to the Op2 item. - - procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function); - -- This procedures sorts items in the range from 1 to N into ascending - -- order making calls to Lt to do required comparisons, and Move to move - -- items around. Note that, as described above, both Move and Lt use a - -- single temporary location with index value zero. This sort is not - -- stable, i.e. the order of equal elements in the input is not preserved. - -end GNAT.Heap_Sort_A; diff --git a/gcc/ada/g-hesorg.adb b/gcc/ada/g-hesorg.adb deleted file mode 100644 index ae8b6f1..0000000 --- a/gcc/ada/g-hesorg.adb +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H E A P _ S O R T _ G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Heap_Sort_G is - - ---------- - -- Sort -- - ---------- - - -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) - -- as described by Knuth ("The Art of Programming", Volume III, first - -- edition, section 5.2.3, p. 145-147) with the modification that is - -- mentioned in exercise 18. For more details on this algorithm, see - -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray - -- Phase Problem". University of Chicago, 1968, which was the first - -- publication of the modification, which reduces the number of compares - -- from 2NlogN to NlogN. - - procedure Sort (N : Natural) is - - Max : Natural := N; - -- Current Max index in tree being sifted - - procedure Sift (S : Positive); - -- This procedure sifts up node S, i.e. converts the subtree rooted - -- at node S into a heap, given the precondition that any sons of - -- S are already heaps. On entry, the contents of node S is found - -- in the temporary (index 0), the actual contents of node S on - -- entry are irrelevant. This is just a minor optimization to avoid - -- what would otherwise be two junk moves in phase two of the sort. - - ---------- - -- Sift -- - ---------- - - procedure Sift (S : Positive) is - C : Positive := S; - Son : Positive; - Father : Positive; - -- Note: by making the above all Positive, we ensure that a test - -- against zero for the temporary location can be resolved on the - -- basis of types when the routines are inlined. - - begin - -- This is where the optimization is done, normally we would do a - -- comparison at each stage between the current node and the larger - -- of the two sons, and continue the sift only if the current node - -- was less than this maximum. In this modified optimized version, - -- we assume that the current node will be less than the larger - -- son, and unconditionally sift up. Then when we get to the bottom - -- of the tree, we check parents to make sure that we did not make - -- a mistake. This roughly cuts the number of comparisons in half, - -- since it is almost always the case that our assumption is correct. - - -- Loop to pull up larger sons - - loop - Son := 2 * C; - - if Son < Max then - if Lt (Son, Son + 1) then - Son := Son + 1; - end if; - elsif Son > Max then - exit; - end if; - - Move (Son, C); - C := Son; - end loop; - - -- Loop to check fathers - - while C /= S loop - Father := C / 2; - - if Lt (Father, 0) then - Move (Father, C); - C := Father; - else - exit; - end if; - end loop; - - -- Last step is to pop the sifted node into place - - Move (0, C); - end Sift; - - -- Start of processing for Sort - - begin - -- Phase one of heapsort is to build the heap. This is done by - -- sifting nodes N/2 .. 1 in sequence. - - for J in reverse 1 .. N / 2 loop - Move (J, 0); - Sift (J); - end loop; - - -- In phase 2, the largest node is moved to end, reducing the size - -- of the tree by one, and the displaced node is sifted down from - -- the top, so that the largest node is again at the top. - - while Max > 1 loop - Move (Max, 0); - Move (1, Max); - Max := Max - 1; - Sift (1); - end loop; - - end Sort; - -end GNAT.Heap_Sort_G; diff --git a/gcc/ada/g-hesorg.ads b/gcc/ada/g-hesorg.ads deleted file mode 100644 index 57b9912..0000000 --- a/gcc/ada/g-hesorg.ads +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H E A P _ S O R T _ G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Heapsort generic package using formal procedures - --- This package provides a generic heapsort routine that can be used with --- different types of data. - --- See also GNAT.Heap_Sort, a version that works with subprogram access --- parameters, allowing code sharing. The generic version is slightly more --- efficient but does not allow code sharing and has an interface that is --- more awkward to use. - --- There is also GNAT.Heap_Sort_A, which is now considered obsolete, but --- was an older version working with subprogram parameters. This version --- is retained for backwards compatibility with old versions of GNAT. - --- This heapsort algorithm uses approximately N*log(N) compares in the --- worst case and is in place with no additional storage required. See --- the body for exact details of the algorithm used. - -generic - -- The data to be sorted is assumed to be indexed by integer values from - -- 1 to N, where N is the number of items to be sorted. In addition, the - -- index value zero is used for a temporary location used during the sort. - - with procedure Move (From : Natural; To : Natural); - -- A procedure that moves the data item with index value From to the data - -- item with index value To (the old value in To being lost). An index - -- value of zero is used for moves from and to a single temporary location. - -- For best efficiency, this routine should be marked as inlined. - - with function Lt (Op1, Op2 : Natural) return Boolean; - -- A function that compares two items and returns True if the item with - -- index Op1 is less than the item with Index Op2, and False if the Op1 - -- item is greater than the Op2 item. If the two items are equal, then - -- it does not matter whether True or False is returned (it is slightly - -- more efficient to return False). For best efficiency, this routine - -- should be marked as inlined. - - -- Note on use of temporary location - - -- There are two ways of providing for the index value zero to represent - -- a temporary value. Either an extra location can be allocated at the - -- start of the array, or alternatively the Move and Lt subprograms can - -- test for the case of zero and treat it specially. In any case it is - -- desirable to specify the two subprograms as inlined and the tests for - -- zero will in this case be resolved at instantiation time. - -package GNAT.Heap_Sort_G is - pragma Pure; - - procedure Sort (N : Natural); - -- This procedures sorts items in the range from 1 to N into ascending - -- order making calls to Lt to do required comparisons, and Move to move - -- items around. Note that, as described above, both Move and Lt use a - -- single temporary location with index value zero. This sort is not - -- stable, i.e. the order of equal elements in the input is not preserved. - -end GNAT.Heap_Sort_G; diff --git a/gcc/ada/g-htable.adb b/gcc/ada/g-htable.adb deleted file mode 100644 index 309de17..0000000 --- a/gcc/ada/g-htable.adb +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H T A B L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a dummy body, required because if we remove the body we have --- bootstrap path problems (this unit used to have a body, and if we do not --- supply a dummy body, the old incorrect body is picked up during the --- bootstrap process). - -pragma Compiler_Unit_Warning; - -package body GNAT.HTable is -end GNAT.HTable; diff --git a/gcc/ada/g-htable.ads b/gcc/ada/g-htable.ads deleted file mode 100644 index 0007560..0000000 --- a/gcc/ada/g-htable.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . H T A B L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Hash table searching routines - --- This package contains two separate packages. The Simple_HTable package --- provides a very simple abstraction that associates one element to one --- key value and takes care of all allocations automatically using the heap. --- The Static_HTable package provides a more complex interface that allows --- complete control over allocation. - --- See file s-htable.ads for full documentation of the interface - -pragma Compiler_Unit_Warning; - -with System.HTable; - -package GNAT.HTable is - pragma Preelaborate; - pragma Elaborate_Body; - -- The elaborate body is because we have a dummy body to deal with - -- bootstrap path problems (we used to have a real body, and now we don't - -- need it any more, but the bootstrap requires that we have a dummy body, - -- since otherwise the old body gets picked up; also, we can't use pragma - -- No_Body because older bootstrap compilers don't support that). - - generic package Simple_HTable renames System.HTable.Simple_HTable; - generic package Static_HTable renames System.HTable.Static_HTable; - - generic function Hash renames System.HTable.Hash; - -end GNAT.HTable; diff --git a/gcc/ada/g-io-put-vxworks.adb b/gcc/ada/g-io-put-vxworks.adb deleted file mode 100644 index 8a08f24..0000000 --- a/gcc/ada/g-io-put-vxworks.adb +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- vxworks zfp version of Put (C : Character) - -with Interfaces.C; use Interfaces.C; - -separate (GNAT.IO) -procedure Put (C : Character) is - - function ioGlobalStdGet - (File : int) return int; - pragma Import (C, ioGlobalStdGet, "ioGlobalStdGet"); - - procedure fdprintf - (File : int; - Format : String; - Value : Character); - pragma Import (C, fdprintf, "fdprintf"); - - Stdout_ID : constant int := 1; - -begin - fdprintf (ioGlobalStdGet (Stdout_ID), "%c" & ASCII.NUL, C); -end Put; diff --git a/gcc/ada/g-io.adb b/gcc/ada/g-io.adb deleted file mode 100644 index b7383cf..0000000 --- a/gcc/ada/g-io.adb +++ /dev/null @@ -1,191 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.IO is - - Current_Out : File_Type := Stdout; - pragma Atomic (Current_Out); - -- Current output file (modified by Set_Output) - - --------- - -- Get -- - --------- - - procedure Get (X : out Integer) is - function Get_Int return Integer; - pragma Import (C, Get_Int, "get_int"); - begin - X := Get_Int; - end Get; - - procedure Get (C : out Character) is - function Get_Char return Character; - pragma Import (C, Get_Char, "get_char"); - begin - C := Get_Char; - end Get; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line (Item : out String; Last : out Natural) is - C : Character; - - begin - for Nstore in Item'Range loop - Get (C); - - if C = ASCII.LF then - Last := Nstore - 1; - return; - - else - Item (Nstore) := C; - end if; - end loop; - - Last := Item'Last; - end Get_Line; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line (File : File_Type; Spacing : Positive := 1) is - begin - for J in 1 .. Spacing loop - Put (File, ASCII.LF); - end loop; - end New_Line; - - procedure New_Line (Spacing : Positive := 1) is - begin - New_Line (Current_Out, Spacing); - end New_Line; - - --------- - -- Put -- - --------- - - procedure Put (X : Integer) is - begin - Put (Current_Out, X); - end Put; - - procedure Put (File : File_Type; X : Integer) is - procedure Put_Int (X : Integer); - pragma Import (C, Put_Int, "put_int"); - - procedure Put_Int_Stderr (X : Integer); - pragma Import (C, Put_Int_Stderr, "put_int_stderr"); - - begin - case File is - when Stdout => Put_Int (X); - when Stderr => Put_Int_Stderr (X); - end case; - end Put; - - procedure Put (C : Character) is - begin - Put (Current_Out, C); - end Put; - - procedure Put (File : File_Type; C : Character) is - procedure Put_Char (C : Character); - pragma Import (C, Put_Char, "put_char"); - - procedure Put_Char_Stderr (C : Character); - pragma Import (C, Put_Char_Stderr, "put_char_stderr"); - - begin - case File is - when Stdout => Put_Char (C); - when Stderr => Put_Char_Stderr (C); - end case; - end Put; - - procedure Put (S : String) is - begin - Put (Current_Out, S); - end Put; - - procedure Put (File : File_Type; S : String) is - begin - for J in S'Range loop - Put (File, S (J)); - end loop; - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (S : String) is - begin - Put_Line (Current_Out, S); - end Put_Line; - - procedure Put_Line (File : File_Type; S : String) is - begin - Put (File, S); - New_Line (File); - end Put_Line; - - ---------------- - -- Set_Output -- - ---------------- - - procedure Set_Output (File : File_Type) is - begin - Current_Out := File; - end Set_Output; - - --------------------- - -- Standard_Output -- - --------------------- - - function Standard_Output return File_Type is - begin - return Stdout; - end Standard_Output; - - -------------------- - -- Standard_Error -- - -------------------- - - function Standard_Error return File_Type is - begin - return Stderr; - end Standard_Error; - -end GNAT.IO; diff --git a/gcc/ada/g-io.ads b/gcc/ada/g-io.ads deleted file mode 100644 index 6891921..0000000 --- a/gcc/ada/g-io.ads +++ /dev/null @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- A simple preelaborable subset of Text_IO capabilities - --- A simple text I/O package that can be used for simple I/O functions in --- user programs as required. This package is also preelaborated, unlike --- Text_IO, and can thus be with'ed by preelaborated library units. - --- Note that Data_Error is not raised by these subprograms for bad data. --- If such checks are needed then the regular Text_IO package must be used. - -package GNAT.IO is - pragma Preelaborate; - - type File_Type is limited private; - -- Specifies file to be used (the only possibilities are Standard_Output - -- and Standard_Error). There is no Create or Open facility that would - -- allow more general use of file names. - - function Standard_Output return File_Type; - function Standard_Error return File_Type; - -- These functions are the only way to get File_Type values - - procedure Get (X : out Integer); - procedure Get (C : out Character); - procedure Get_Line (Item : out String; Last : out Natural); - -- These routines always read from Standard_Input - - procedure Put (File : File_Type; X : Integer); - procedure Put (X : Integer); - -- Output integer to specified file, or to current output file, same - -- output as if Ada.Text_IO.Integer_IO had been instantiated for Integer. - - procedure Put (File : File_Type; C : Character); - procedure Put (C : Character); - -- Output character to specified file, or to current output file - - procedure Put (File : File_Type; S : String); - procedure Put (S : String); - -- Output string to specified file, or to current output file - - procedure Put_Line (File : File_Type; S : String); - procedure Put_Line (S : String); - -- Output string followed by new line to specified file, or to - -- current output file. - - procedure New_Line (File : File_Type; Spacing : Positive := 1); - procedure New_Line (Spacing : Positive := 1); - -- Output new line character to specified file, or to current output file - - procedure Set_Output (File : File_Type); - -- Set current output file, default is Standard_Output if no call to - -- Set_Output is made. - -private - type File_Type is (Stdout, Stderr); - -- Stdout = Standard_Output, Stderr = Standard_Error - - pragma Inline (Standard_Error); - pragma Inline (Standard_Output); - -end GNAT.IO; diff --git a/gcc/ada/g-io_aux.adb b/gcc/ada/g-io_aux.adb deleted file mode 100644 index 2e0b0ca..0000000 --- a/gcc/ada/g-io_aux.adb +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . I O _ A U X -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C_Streams; use Interfaces.C_Streams; - -package body GNAT.IO_Aux is - - Buflen : constant := 2000; - -- Buffer length. Works for any non-zero value, larger values take - -- more stack space, smaller values require more recursion. - - ----------------- - -- File_Exists -- - ----------------- - - function File_Exists (Name : String) return Boolean - is - Namestr : aliased String (1 .. Name'Length + 1); - -- Name as given with ASCII.NUL appended - - begin - Namestr (1 .. Name'Length) := Name; - Namestr (Name'Length + 1) := ASCII.NUL; - return file_exists (Namestr'Address) /= 0; - end File_Exists; - - -------------- - -- Get_Line -- - -------------- - - -- Current_Input case - - function Get_Line return String is - Buffer : String (1 .. Buflen); - -- Buffer to read in chunks of remaining line. Will work with any - -- size buffer. We choose a length so that most of the time no - -- recursion will be required. - - Last : Natural; - - begin - Ada.Text_IO.Get_Line (Buffer, Last); - - -- If the buffer is not full, then we are all done - - if Last < Buffer'Last then - return Buffer (1 .. Last); - - -- Otherwise, we still have characters left on the line. Note that - -- as specified by (RM A.10.7(19)) the end of line is not skipped - -- in this case, even if we are right at it now. - - else - return Buffer & GNAT.IO_Aux.Get_Line; - end if; - end Get_Line; - - -- Case of reading from a specified file. Note that we could certainly - -- share code between these two versions, but these are very short - -- routines, and we may as well aim for maximum speed, cutting out an - -- intermediate call (calls returning string may be somewhat slow) - - function Get_Line (File : Ada.Text_IO.File_Type) return String is - Buffer : String (1 .. Buflen); - Last : Natural; - - begin - Ada.Text_IO.Get_Line (File, Buffer, Last); - - if Last < Buffer'Last then - return Buffer (1 .. Last); - else - return Buffer & Get_Line (File); - end if; - end Get_Line; - -end GNAT.IO_Aux; diff --git a/gcc/ada/g-io_aux.ads b/gcc/ada/g-io_aux.ads deleted file mode 100644 index 3726ac6..0000000 --- a/gcc/ada/g-io_aux.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . I O _ A U X -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Auxiliary functions or use with Text_IO - --- This package provides some auxiliary functions for use with Text_IO, --- including a test for an existing file, and a Get_Line function which --- returns a string. - -with Ada.Text_IO; - -package GNAT.IO_Aux is - - function File_Exists (Name : String) return Boolean; - -- Test for existence of a file named Name - - function Get_Line return String; - -- Read Ada.Text_IO.Current_Input and return string that includes all - -- characters from the current character up to the end of the line, - -- with no limit on its length. Raises Ada.IO_Exceptions.End_Error if - -- at end of file. - - function Get_Line (File : Ada.Text_IO.File_Type) return String; - -- Same, but reads from specified file - -end GNAT.IO_Aux; diff --git a/gcc/ada/g-locfil.adb b/gcc/ada/g-locfil.adb deleted file mode 100644 index 5449dc6e..0000000 --- a/gcc/ada/g-locfil.adb +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . L O C K _ F I L E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; - -package body GNAT.Lock_Files is - - Dir_Separator : Character; - pragma Import (C, Dir_Separator, "__gnat_dir_separator"); - - --------------- - -- Lock_File -- - --------------- - - procedure Lock_File - (Directory : Path_Name; - Lock_File_Name : Path_Name; - Wait : Duration := 1.0; - Retries : Natural := Natural'Last) - is - Dir : aliased String := Directory & ASCII.NUL; - File : aliased String := Lock_File_Name & ASCII.NUL; - - function Try_Lock (Dir, File : System.Address) return Integer; - pragma Import (C, Try_Lock, "__gnat_try_lock"); - - begin - -- If a directory separator was provided, just remove the one we have - -- added above. - - if Directory (Directory'Last) = Dir_Separator - or else Directory (Directory'Last) = '/' - then - Dir (Dir'Last - 1) := ASCII.NUL; - end if; - - -- Try to lock the file Retries times - - for I in 0 .. Retries loop - if Try_Lock (Dir'Address, File'Address) = 1 then - return; - end if; - - exit when I = Retries; - delay Wait; - end loop; - - raise Lock_Error; - end Lock_File; - - --------------- - -- Lock_File -- - --------------- - - procedure Lock_File - (Lock_File_Name : Path_Name; - Wait : Duration := 1.0; - Retries : Natural := Natural'Last) - is - begin - for J in reverse Lock_File_Name'Range loop - if Lock_File_Name (J) = Dir_Separator - or else Lock_File_Name (J) = '/' - then - Lock_File - (Lock_File_Name (Lock_File_Name'First .. J - 1), - Lock_File_Name (J + 1 .. Lock_File_Name'Last), - Wait, - Retries); - return; - end if; - end loop; - - Lock_File (".", Lock_File_Name, Wait, Retries); - end Lock_File; - - ----------------- - -- Unlock_File -- - ----------------- - - procedure Unlock_File (Lock_File_Name : Path_Name) is - S : aliased String := Lock_File_Name & ASCII.NUL; - - procedure unlink (A : System.Address); - pragma Import (C, unlink, "unlink"); - - begin - unlink (S'Address); - end Unlock_File; - - ----------------- - -- Unlock_File -- - ----------------- - - procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name) is - begin - if Directory (Directory'Last) = Dir_Separator - or else Directory (Directory'Last) = '/' - then - Unlock_File (Directory & Lock_File_Name); - else - Unlock_File (Directory & Dir_Separator & Lock_File_Name); - end if; - end Unlock_File; - -end GNAT.Lock_Files; diff --git a/gcc/ada/g-locfil.ads b/gcc/ada/g-locfil.ads deleted file mode 100644 index 3e52cc0..0000000 --- a/gcc/ada/g-locfil.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . L O C K _ F I L E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the necessary routines for using files for the --- purpose of providing reliable system wide locking capability. - -package GNAT.Lock_Files is - pragma Preelaborate; - - Lock_Error : exception; - -- Exception raised if file cannot be locked - - subtype Path_Name is String; - -- Pathname is used by all services provided in this unit to specify - -- directory name and file name. On DOS based systems both directory - -- separators are handled (i.e. slash and backslash). - - procedure Lock_File - (Directory : Path_Name; - Lock_File_Name : Path_Name; - Wait : Duration := 1.0; - Retries : Natural := Natural'Last); - -- Create a lock file Lock_File_Name in directory Directory. If the file - -- cannot be locked because someone already owns the lock, this procedure - -- waits Wait seconds and retries at most Retries times. If the file - -- still cannot be locked, Lock_Error is raised. The default is to try - -- every second, almost forever (Natural'Last times). The full path of - -- the file is constructed by concatenating Directory and Lock_File_Name. - -- Directory can optionally terminate with a directory separator. - - procedure Lock_File - (Lock_File_Name : Path_Name; - Wait : Duration := 1.0; - Retries : Natural := Natural'Last); - -- See above. The full lock file path is given as one string - - procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name); - -- Unlock a file. Directory can optionally terminate with a directory - -- separator. - - procedure Unlock_File (Lock_File_Name : Path_Name); - -- Unlock a file whose full path is given in Lock_File_Name - -end GNAT.Lock_Files; diff --git a/gcc/ada/g-mbdira.adb b/gcc/ada/g-mbdira.adb deleted file mode 100644 index c5d8c8b..0000000 --- a/gcc/ada/g-mbdira.adb +++ /dev/null @@ -1,282 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Calendar; - -with Interfaces; use Interfaces; - -package body GNAT.MBBS_Discrete_Random is - - package Calendar renames Ada.Calendar; - - Fits_In_32_Bits : constant Boolean := - Rst'Size < 31 - or else (Rst'Size = 31 - and then Rst'Pos (Rst'First) < 0); - -- This is set True if we do not need more than 32 bits in the result. If - -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit - -- number generated, since if more than 48 bits are required, we split the - -- computation into two separate parts, since the algorithm does not behave - -- above 48 bits. - - -- The way this expression works is that obviously if the size is 31 bits, - -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the - -- range has negative values. It is too conservative in the case that the - -- programmer has set a size greater than the default, e.g. a size of 33 - -- for an integer type with a range of 1..10, but an over-conservative - -- result is OK. The important thing is that the value is only True if - -- we know the result will fit in 32-bits signed. If the value is False - -- when it could be True, the behavior will be correct, just a bit less - -- efficient than it could have been in some unusual cases. - -- - -- One might assume that we could get a more accurate result by testing - -- the lower and upper bounds of the type Rst against the bounds of 32-bit - -- Integer. However, there is no easy way to do that. Why? Because in the - -- relatively rare case where this expression has to be evaluated at run - -- time rather than compile time (when the bounds are dynamic), we need a - -- type to use for the computation. But the possible range of upper bound - -- values for Rst (remembering the possibility of 64-bit modular types) is - -- from -2**63 to 2**64-1, and no run-time type has a big enough range. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Square_Mod_N (X, N : Int) return Int; - pragma Inline (Square_Mod_N); - -- Computes X**2 mod N avoiding intermediate overflow - - ----------- - -- Image -- - ----------- - - function Image (Of_State : State) return String is - begin - return Int'Image (Of_State.X1) & - ',' & - Int'Image (Of_State.X2) & - ',' & - Int'Image (Of_State.Q); - end Image; - - ------------ - -- Random -- - ------------ - - function Random (Gen : Generator) return Rst is - S : State renames Gen.Writable.Self.Gen_State; - Temp : Int; - TF : Flt; - - begin - -- Check for flat range here, since we are typically run with checks - -- off, note that in practice, this condition will usually be static - -- so we will not actually generate any code for the normal case. - - if Rst'Last < Rst'First then - raise Constraint_Error; - end if; - - -- Continue with computation if non-flat range - - S.X1 := Square_Mod_N (S.X1, S.P); - S.X2 := Square_Mod_N (S.X2, S.Q); - Temp := S.X2 - S.X1; - - -- Following duplication is not an error, it is a loop unwinding - - if Temp < 0 then - Temp := Temp + S.Q; - end if; - - if Temp < 0 then - Temp := Temp + S.Q; - end if; - - TF := Offs + (Flt (Temp) * Flt (S.P) + Flt (S.X1)) * S.Scl; - - -- Pathological, but there do exist cases where the rounding implicit - -- in calculating the scale factor will cause rounding to 'Last + 1. - -- In those cases, returning 'First results in the least bias. - - if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then - return Rst'First; - - elsif not Fits_In_32_Bits then - return Rst'Val (Interfaces.Integer_64 (TF)); - - else - return Rst'Val (Int (TF)); - end if; - end Random; - - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : Generator; Initiator : Integer) is - S : State renames Gen.Writable.Self.Gen_State; - X1, X2 : Int; - - begin - X1 := 2 + Int (Initiator) mod (K1 - 3); - X2 := 2 + Int (Initiator) mod (K2 - 3); - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - -- Eliminate effects of small Initiators - - S := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - FP => K1F, - Scl => Scal); - end Reset; - - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : Generator) is - S : State renames Gen.Writable.Self.Gen_State; - Now : constant Calendar.Time := Calendar.Clock; - X1 : Int; - X2 : Int; - - begin - X1 := Int (Calendar.Year (Now)) * 12 * 31 + - Int (Calendar.Month (Now) * 31) + - Int (Calendar.Day (Now)); - - X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); - - X1 := 2 + X1 mod (K1 - 3); - X2 := 2 + X2 mod (K2 - 3); - - -- Eliminate visible effects of same day starts - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - S := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - FP => K1F, - Scl => Scal); - - end Reset; - - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : Generator; From_State : State) is - begin - Gen.Writable.Self.Gen_State := From_State; - end Reset; - - ---------- - -- Save -- - ---------- - - procedure Save (Gen : Generator; To_State : out State) is - begin - To_State := Gen.Gen_State; - end Save; - - ------------------ - -- Square_Mod_N -- - ------------------ - - function Square_Mod_N (X, N : Int) return Int is - begin - return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N))); - end Square_Mod_N; - - ----------- - -- Value -- - ----------- - - function Value (Coded_State : String) return State is - Last : constant Natural := Coded_State'Last; - Start : Positive := Coded_State'First; - Stop : Positive := Coded_State'First; - Outs : State; - - begin - while Stop <= Last and then Coded_State (Stop) /= ',' loop - Stop := Stop + 1; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); - Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); - Outs.P := Outs.Q * 2 + 1; - Outs.FP := Flt (Outs.P); - Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q)); - - -- Now do *some* sanity checks - - if Outs.Q < 31 - or else Outs.X1 not in 2 .. Outs.P - 1 - or else Outs.X2 not in 2 .. Outs.Q - 1 - then - raise Constraint_Error; - end if; - - return Outs; - end Value; - -end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/g-mbdira.ads b/gcc/ada/g-mbdira.ads deleted file mode 100644 index c415a24..0000000 --- a/gcc/ada/g-mbdira.ads +++ /dev/null @@ -1,123 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2010, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The implementation used in this package was contributed by Robert --- Eachus. It is based on the work of L. Blum, M. Blum, and M. Shub, SIAM --- Journal of Computing, Vol 15. No 2, May 1986. The particular choices for P --- and Q chosen here guarantee a period of 562,085,314,430,582 (about 2**49), --- and the generated sequence has excellent randomness properties. For further --- details, see the paper "Fast Generation of Trustworthy Random Numbers", by --- Robert Eachus, which describes both the algorithm and the efficient --- implementation approach used here. - --- Formerly, this package was Ada.Numerics.Discrete_Random. It is retained --- here in part to allow users to reconstruct number sequences generated --- by previous versions. - -with Interfaces; - -generic - type Result_Subtype is (<>); - -package GNAT.MBBS_Discrete_Random is - - -- The algorithm used here is reliable from a required statistical point of - -- view only up to 48 bits. We try to behave reasonably in the case of - -- larger types, but we can't guarantee the required properties. So - -- generate a warning for these (slightly) dubious cases. - - pragma Compile_Time_Warning - (Result_Subtype'Size > 48, - "statistical properties not guaranteed for size > 48"); - - -- Basic facilities - - type Generator is limited private; - - function Random (Gen : Generator) return Result_Subtype; - - procedure Reset (Gen : Generator); - procedure Reset (Gen : Generator; Initiator : Integer); - - -- Advanced facilities - - type State is private; - - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); - - Max_Image_Width : constant := 80; - - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; - -private - subtype Int is Interfaces.Integer_32; - subtype Rst is Result_Subtype; - - -- We prefer to use 14 digits for Flt, but some targets are more limited - - type Flt is digits Positive'Min (14, Long_Long_Float'Digits); - - RstF : constant Flt := Flt (Rst'Pos (Rst'First)); - RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); - - Offs : constant Flt := RstF - 0.5; - - K1 : constant := 94_833_359; - K1F : constant := 94_833_359.0; - K2 : constant := 47_416_679; - K2F : constant := 47_416_679.0; - Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F); - - type State is record - X1 : Int := Int (2999 ** 2); - X2 : Int := Int (1439 ** 2); - P : Int := K1; - Q : Int := K2; - FP : Flt := K1F; - Scl : Flt := Scal; - end record; - - type Writable_Access (Self : access Generator) is limited null record; - -- Auxiliary type to make Generator a self-referential type - - type Generator is limited record - Writable : Writable_Access (Generator'Access); - -- This self reference allows functions to modify Generator arguments - Gen_State : State; - end record; - -end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/g-mbflra.adb b/gcc/ada/g-mbflra.adb deleted file mode 100644 index 1d59069..0000000 --- a/gcc/ada/g-mbflra.adb +++ /dev/null @@ -1,314 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . M B B S _ F L O A T _ R A N D O M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Calendar; - -package body GNAT.MBBS_Float_Random is - - ------------------------- - -- Implementation Note -- - ------------------------- - - -- The design of this spec is a bit awkward, as a result of Ada 95 not - -- permitting in-out parameters for function formals (most naturally - -- Generator values would be passed this way). In pure Ada 95, the only - -- solution would be to add a self-referential component to the generator - -- allowing access to the generator object from inside the function. This - -- would work because the generator is limited, which prevents any copy. - - -- This is a bit heavy, so what we do is to use Unrestricted_Access to - -- get a pointer to the state in the passed Generator. This works because - -- Generator is a limited type and will thus always be passed by reference. - - package Calendar renames Ada.Calendar; - - type Pointer is access all State; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int); - - function Euclid (P, Q : Int) return Int; - - function Square_Mod_N (X, N : Int) return Int; - - ------------ - -- Euclid -- - ------------ - - procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is - - XT : Int := 1; - YT : Int := 0; - - procedure Recur - (P, Q : Int; -- a (i-1), a (i) - X, Y : Int; -- x (i), y (i) - XP, YP : in out Int; -- x (i-1), y (i-1) - GCD : out Int); - - procedure Recur - (P, Q : Int; - X, Y : Int; - XP, YP : in out Int; - GCD : out Int) - is - Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _| - XT : Int := X; -- x (i) - YT : Int := Y; -- y (i) - - begin - if P rem Q = 0 then -- while does not divide - GCD := Q; - XP := X; - YP := Y; - else - Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo); - - -- a (i) <== a (i) - -- a (i+1) <-- a (i-1) - q*a (i) - -- x (i+1) <-- x (i-1) - q*x (i) - -- y (i+1) <-- y (i-1) - q*y (i) - -- x (i) <== x (i) - -- y (i) <== y (i) - - XP := XT; - YP := YT; - GCD := Quo; - end if; - end Recur; - - -- Start of processing for Euclid - - begin - Recur (P, Q, 0, 1, XT, YT, GCD); - X := XT; - Y := YT; - end Euclid; - - function Euclid (P, Q : Int) return Int is - X, Y, GCD : Int; - pragma Unreferenced (Y, GCD); - begin - Euclid (P, Q, X, Y, GCD); - return X; - end Euclid; - - ----------- - -- Image -- - ----------- - - function Image (Of_State : State) return String is - begin - return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2) - & ',' & - Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q); - end Image; - - ------------ - -- Random -- - ------------ - - function Random (Gen : Generator) return Uniformly_Distributed is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - - begin - Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); - Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); - return - Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X) - mod Genp.Q) * Flt (Genp.P) - + Flt (Genp.X1)) * Genp.Scl); - end Random; - - ----------- - -- Reset -- - ----------- - - -- Version that works from given initiator value - - procedure Reset (Gen : Generator; Initiator : Integer) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - X1, X2 : Int; - - begin - X1 := 2 + Int (Initiator) mod (K1 - 3); - X2 := 2 + Int (Initiator) mod (K2 - 3); - - -- Eliminate effects of small initiators - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - X => 1, - Scl => Scal); - end Reset; - - -- Version that works from specific saved state - - procedure Reset (Gen : Generator; From_State : State) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - - begin - Genp.all := From_State; - end Reset; - - -- Version that works from calendar - - procedure Reset (Gen : Generator) is - Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; - Now : constant Calendar.Time := Calendar.Clock; - X1, X2 : Int; - - begin - X1 := Int (Calendar.Year (Now)) * 12 * 31 + - Int (Calendar.Month (Now)) * 31 + - Int (Calendar.Day (Now)); - - X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); - - X1 := 2 + X1 mod (K1 - 3); - X2 := 2 + X2 mod (K2 - 3); - - -- Eliminate visible effects of same day starts - - for J in 1 .. 5 loop - X1 := Square_Mod_N (X1, K1); - X2 := Square_Mod_N (X2, K2); - end loop; - - Genp.all := - (X1 => X1, - X2 => X2, - P => K1, - Q => K2, - X => 1, - Scl => Scal); - - end Reset; - - ---------- - -- Save -- - ---------- - - procedure Save (Gen : Generator; To_State : out State) is - begin - To_State := Gen.Gen_State; - end Save; - - ------------------ - -- Square_Mod_N -- - ------------------ - - function Square_Mod_N (X, N : Int) return Int is - Temp : constant Flt := Flt (X) * Flt (X); - Div : Int; - - begin - Div := Int (Temp / Flt (N)); - Div := Int (Temp - Flt (Div) * Flt (N)); - - if Div < 0 then - return Div + N; - else - return Div; - end if; - end Square_Mod_N; - - ----------- - -- Value -- - ----------- - - function Value (Coded_State : String) return State is - Last : constant Natural := Coded_State'Last; - Start : Positive := Coded_State'First; - Stop : Positive := Coded_State'First; - Outs : State; - - begin - while Stop <= Last and then Coded_State (Stop) /= ',' loop - Stop := Stop + 1; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); - Start := Stop + 1; - - loop - Stop := Stop + 1; - exit when Stop > Last or else Coded_State (Stop) = ','; - end loop; - - if Stop > Last then - raise Constraint_Error; - end if; - - Outs.P := Int'Value (Coded_State (Start .. Stop - 1)); - Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); - Outs.X := Euclid (Outs.P, Outs.Q); - Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q)); - - -- Now do *some* sanity checks - - if Outs.Q < 31 or else Outs.P < 31 - or else Outs.X1 not in 2 .. Outs.P - 1 - or else Outs.X2 not in 2 .. Outs.Q - 1 - then - raise Constraint_Error; - end if; - - return Outs; - end Value; -end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/g-mbflra.ads b/gcc/ada/g-mbflra.ads deleted file mode 100644 index 4deac48..0000000 --- a/gcc/ada/g-mbflra.ads +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . M B B S _ F L O A T _ R A N D O M -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2010, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The implementation used in this package was contributed by --- Robert Eachus. It is based on the work of L. Blum, M. Blum, and --- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The --- particular choices for P and Q chosen here guarantee a period of --- 562,085,314,430,582 (about 2**49), and the generated sequence has --- excellent randomness properties. For further details, see the --- paper "Fast Generation of Trustworthy Random Numbers", by Robert --- Eachus, which describes both the algorithm and the efficient --- implementation approach used here. - --- Formerly, this package was Ada.Numerics.Float_Random. It is retained --- here in part to allow users to reconstruct number sequences generated --- by previous versions. - -with Interfaces; - -package GNAT.MBBS_Float_Random is - - -- Basic facilities - - type Generator is limited private; - - subtype Uniformly_Distributed is Float range 0.0 .. 1.0; - - function Random (Gen : Generator) return Uniformly_Distributed; - - procedure Reset (Gen : Generator); - procedure Reset (Gen : Generator; Initiator : Integer); - - -- Advanced facilities - - type State is private; - - procedure Save (Gen : Generator; To_State : out State); - procedure Reset (Gen : Generator; From_State : State); - - Max_Image_Width : constant := 80; - - function Image (Of_State : State) return String; - function Value (Coded_State : String) return State; - -private - type Int is new Interfaces.Integer_32; - - -- We prefer to use 14 digits for Flt, but some targets are more limited - - type Flt is digits Positive'Min (14, Long_Long_Float'Digits); - - K1 : constant := 94_833_359; - K1F : constant := 94_833_359.0; - K2 : constant := 47_416_679; - K2F : constant := 47_416_679.0; - Scal : constant := 1.0 / (K1F * K2F); - - type State is record - X1 : Int := 2999 ** 2; -- Square mod p - X2 : Int := 1439 ** 2; -- Square mod q - P : Int := K1; - Q : Int := K2; - X : Int := 1; - Scl : Flt := Scal; - end record; - - type Generator is limited record - Gen_State : State; - end record; - -end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/g-md5.adb b/gcc/ada/g-md5.adb deleted file mode 100644 index 28d20c9..0000000 --- a/gcc/ada/g-md5.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . M D 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-md5.ads b/gcc/ada/g-md5.ads deleted file mode 100644 index 81fd6b0..0000000 --- a/gcc/ada/g-md5.ads +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . M D 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements the MD5 Message-Digest Algorithm as described in --- RFC 1321. The complete text of RFC 1321 can be found at: --- http://www.ietf.org/rfc/rfc1321.txt - --- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete --- documentation. - -with GNAT.Secure_Hashes.MD5; -with System; - -package GNAT.MD5 is new GNAT.Secure_Hashes.H - (Block_Words => GNAT.Secure_Hashes.MD5.Block_Words, - State_Words => 4, - Hash_Words => 4, - Hash_Bit_Order => System.Low_Order_First, - Hash_State => GNAT.Secure_Hashes.MD5.Hash_State, - Initial_State => GNAT.Secure_Hashes.MD5.Initial_State, - Transform => GNAT.Secure_Hashes.MD5.Transform); diff --git a/gcc/ada/g-memdum.adb b/gcc/ada/g-memdum.adb deleted file mode 100644 index bee7991..0000000 --- a/gcc/ada/g-memdum.adb +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . M E M O R Y _ D U M P -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; -with System.Img_BIU; use System.Img_BIU; -with System.Storage_Elements; use System.Storage_Elements; - -with GNAT.IO; use GNAT.IO; -with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; - -with Ada.Unchecked_Conversion; - -package body GNAT.Memory_Dump is - - ---------- - -- Dump -- - ---------- - - procedure Dump - (Addr : Address; - Count : Natural) - is - begin - Dump (Addr, Count, Prefix => Absolute_Address); - end Dump; - - procedure Dump - (Addr : Address; - Count : Natural; - Prefix : Prefix_Type) - is - Ctr : Natural := Count; - -- Count of bytes left to output - - Offset_Buf : String (1 .. Standard'Address_Size / 4 + 4); - Offset_Last : Natural; - -- Buffer for prefix in Offset mode - - Adr : Address := Addr; - -- Current address - - N : Natural := 0; - -- Number of bytes output on current line - - C : Character; - -- Character at current storage address - - AIL : Natural; - -- Number of chars in prefix (including colon and space) - - Line_Len : Natural; - -- Line length for entire line - - Hex : constant array (0 .. 15) of Character := "0123456789ABCDEF"; - - type Char_Ptr is access all Character; - - function To_Char_Ptr is new Ada.Unchecked_Conversion (Address, Char_Ptr); - - begin - case Prefix is - when Absolute_Address => - AIL := Address_Image_Length - 4 + 2; - - when Offset => - Offset_Last := Offset_Buf'First - 1; - Set_Image_Based_Integer (Ctr, 16, 0, Offset_Buf, Offset_Last); - AIL := Offset_Last - 4 + 2; - - when None => - AIL := 0; - end case; - - Line_Len := AIL + 3 * 16 + 2 + 16; - - declare - Line_Buf : String (1 .. Line_Len); - - begin - while Ctr /= 0 loop - - -- Start of line processing - - if N = 0 then - case Prefix is - when Absolute_Address => - declare - S : constant String := Image (Adr); - begin - Line_Buf (1 .. AIL) := S (4 .. S'Length - 1) & ": "; - end; - - when Offset => - declare - Last : Natural := 0; - Len : Natural; - - begin - Set_Image_Based_Integer - (Count - Ctr, 16, 0, Offset_Buf, Last); - Len := Last - 4; - - Line_Buf (1 .. AIL - Len - 2) := (others => '0'); - Line_Buf (AIL - Len - 1 .. AIL - 2) := - Offset_Buf (4 .. Last - 1); - Line_Buf (AIL - 1 .. AIL) := ": "; - end; - - when None => - null; - end case; - - Line_Buf (AIL + 1 .. Line_Buf'Last) := (others => ' '); - Line_Buf (AIL + 3 * 16 + 1) := '"'; - end if; - - -- Add one character to current line - - C := To_Char_Ptr (Adr).all; - Adr := Adr + 1; - Ctr := Ctr - 1; - - Line_Buf (AIL + 3 * N + 1) := Hex (Character'Pos (C) / 16); - Line_Buf (AIL + 3 * N + 2) := Hex (Character'Pos (C) mod 16); - - if C < ' ' or else C = Character'Val (16#7F#) then - C := '?'; - end if; - - Line_Buf (AIL + 3 * 16 + 2 + N) := C; - N := N + 1; - - -- End of line processing - - if N = 16 then - Line_Buf (Line_Buf'Last) := '"'; - GNAT.IO.Put_Line (Line_Buf); - N := 0; - end if; - end loop; - - -- Deal with possible last partial line - - if N /= 0 then - Line_Buf (AIL + 3 * 16 + 2 + N) := '"'; - GNAT.IO.Put_Line (Line_Buf (1 .. AIL + 3 * 16 + 2 + N)); - end if; - end; - end Dump; - -end GNAT.Memory_Dump; diff --git a/gcc/ada/g-memdum.ads b/gcc/ada/g-memdum.ads deleted file mode 100644 index 0d56e21..0000000 --- a/gcc/ada/g-memdum.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . M E M O R Y _ D U M P -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- A routine for dumping memory to either standard output or standard error. --- Uses GNAT.IO for actual output (use the controls in GNAT.IO to specify --- the destination of the output, which by default is Standard_Output). - -with System; - -package GNAT.Memory_Dump is - pragma Preelaborate; - - type Prefix_Type is (Absolute_Address, Offset, None); - - procedure Dump - (Addr : System.Address; - Count : Natural); - -- Dumps indicated number (Count) of bytes, starting at the address given - -- by Addr. The coding of this routine in its current form assumes the case - -- of a byte addressable machine (and is therefore inapplicable to machines - -- like the AAMP, where the storage unit is not 8 bits). The output is one - -- or more lines in the following format, which is for the case of 32-bit - -- addresses (64-bit addresses are handled appropriately): - -- - -- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" - -- - -- All but the last line have 16 bytes. A question mark is used in the - -- string data to indicate a non-printable character. - - procedure Dump - (Addr : System.Address; - Count : Natural; - Prefix : Prefix_Type); - -- Same as above, but allows the selection of different line formats. - -- If Prefix is set to Absolute_Address, the output is identical to the - -- above version, each line starting with the absolute address of the - -- first dumped storage element. - -- - -- If Prefix is set to Offset, then instead each line starts with the - -- indication of the offset relative to Addr: - -- - -- 00: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" - -- - -- Finally if Prefix is set to None, the prefix is suppressed altogether, - -- and only the memory contents are displayed: - -- - -- 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" - -end GNAT.Memory_Dump; diff --git a/gcc/ada/g-moreex.adb b/gcc/ada/g-moreex.adb deleted file mode 100644 index 822b760..0000000 --- a/gcc/ada/g-moreex.adb +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . M O S T _ R E C E N T _ E X C E P T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions.Is_Null_Occurrence; -with System.Soft_Links; - -package body GNAT.Most_Recent_Exception is - - ---------------- - -- Occurrence -- - ---------------- - - function Occurrence return Ada.Exceptions.Exception_Occurrence is - EOA : constant Ada.Exceptions.Exception_Occurrence_Access := - GNAT.Most_Recent_Exception.Occurrence_Access; - - use type Ada.Exceptions.Exception_Occurrence_Access; - - begin - return Result : Ada.Exceptions.Exception_Occurrence do - if EOA = null then - Ada.Exceptions.Save_Occurrence - (Target => Result, - Source => Ada.Exceptions.Null_Occurrence); - else - Ada.Exceptions.Save_Occurrence - (Target => Result, - Source => EOA.all); - end if; - end return; - end Occurrence; - - ----------------------- - -- Occurrence_Access -- - ----------------------- - - function Occurrence_Access - return Ada.Exceptions.Exception_Occurrence_Access - is - use Ada.Exceptions; - - EOA : constant Exception_Occurrence_Access := - System.Soft_Links.Get_Current_Excep.all; - - begin - if EOA = null then - return null; - - elsif Is_Null_Occurrence (EOA.all) then - return null; - - else - return EOA; - end if; - end Occurrence_Access; - -end GNAT.Most_Recent_Exception; diff --git a/gcc/ada/g-moreex.ads b/gcc/ada/g-moreex.ads deleted file mode 100644 index 5d26109..0000000 --- a/gcc/ada/g-moreex.ads +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . M O S T _ R E C E N T _ E X C E P T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides routines for accessing the most recently raised --- exception. This may be useful for certain logging activities. It may --- also be useful for mimicking implementation dependent capabilities in --- Ada 83 compilers, but see also GNAT.Current_Exceptions for this usage. - -with Ada.Exceptions; -package GNAT.Most_Recent_Exception is - - ----------------- - -- Subprograms -- - ----------------- - - function Occurrence - return Ada.Exceptions.Exception_Occurrence; - -- Returns the Exception_Occurrence for the most recently raised exception - -- in the current task. If no exception has been raised in the current task - -- prior to the call, returns Null_Occurrence. - - function Occurrence_Access - return Ada.Exceptions.Exception_Occurrence_Access; - -- Similar to the above, but returns an access to the occurrence value. - -- This value is in a task specific location, and may be validly accessed - -- as long as no further exception is raised in the calling task. - - -- Note: unlike the routines in GNAT.Current_Exception, these functions - -- access the most recently raised exception, regardless of where they - -- are called. Consider the following example: - - -- exception - -- when Constraint_Error => - -- begin - -- ... - -- exception - -- when Tasking_Error => ... - -- end; - -- - -- -- Assuming a Tasking_Error was raised in the inner block, - -- -- a call to GNAT.Most_Recent_Exception.Occurrence will - -- -- return information about this Tasking_Error exception, - -- -- not about the Constraint_Error exception being handled - -- -- by the current handler code. - -end GNAT.Most_Recent_Exception; diff --git a/gcc/ada/g-os_lib.adb b/gcc/ada/g-os_lib.adb deleted file mode 100644 index ab9a0a0..0000000 --- a/gcc/ada/g-os_lib.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . O S _ L I B -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-os_lib.ads b/gcc/ada/g-os_lib.ads deleted file mode 100644 index dafd090..0000000 --- a/gcc/ada/g-os_lib.ads +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . O S _ L I B -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Operating system interface facilities - --- This package contains types and procedures for interfacing to the --- underlying OS. It is used by the GNAT compiler and by tools associated --- with the GNAT compiler, and therefore works for the various operating --- systems to which GNAT has been ported. This package will undoubtedly grow --- as new services are needed by various tools. - --- This package tends to use fairly low-level Ada in order to not bring in --- large portions of the RTL. For example, functions return access to string --- as part of avoiding functions returning unconstrained types. - --- Except where specifically noted, these routines are portable across all --- GNAT implementations on all supported operating systems. - --- See file s-os_lib.ads for full documentation of the interface - -with System.OS_Lib; - -package GNAT.OS_Lib renames System.OS_Lib; diff --git a/gcc/ada/g-pehage.adb b/gcc/ada/g-pehage.adb deleted file mode 100644 index 76ecb02..0000000 --- a/gcc/ada/g-pehage.adb +++ /dev/null @@ -1,2600 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; use Ada.IO_Exceptions; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Directories; - -with GNAT.Heap_Sort_G; -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Table; - -package body GNAT.Perfect_Hash_Generators is - - -- We are using the algorithm of J. Czech as described in Zbigniew J. - -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for - -- Generating Minimal Perfect Hash Functions'', Information Processing - -- Letters, 43(1992) pp.257-264, Oct.1992 - - -- This minimal perfect hash function generator is based on random graphs - -- and produces a hash function of the form: - - -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m - - -- where f1 and f2 are functions that map strings into integers, and g is - -- a function that maps integers into [0, m-1]. h can be order preserving. - -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined - -- such that h (w_i) = i. - - -- This algorithm defines two possible constructions of f1 and f2. Method - -- b) stores the hash function in less memory space at the expense of - -- greater CPU time. - - -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n - - -- size (Tk) = max (for w in W) (length (w)) * size (used char set) - - -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n - - -- size (Tk) = max (for w in W) (length (w)) but the table lookups are - -- replaced by multiplications. - - -- where Tk values are randomly generated. n is defined later on but the - -- algorithm recommends to use a value a little bit greater than 2m. Note - -- that for large values of m, the main memory space requirements comes - -- from the memory space for storing function g (>= 2m entries). - - -- Random graphs are frequently used to solve difficult problems that do - -- not have polynomial solutions. This algorithm is based on a weighted - -- undirected graph. It comprises two steps: mapping and assignment. - - -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1, - -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the - -- assignment step to be successful, G has to be acyclic. To have a high - -- probability of generating an acyclic graph, n >= 2m. If it is not - -- acyclic, Tk have to be regenerated. - - -- In the assignment step, the algorithm builds function g. As G is - -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be - -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by - -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n). - -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - - -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no - -- neighbor, then another vertex is selected. The algorithm traverses G to - -- assign values to all the vertices. It cannot assign a value to an - -- already assigned vertex as G is acyclic. - - subtype Word_Id is Integer; - subtype Key_Id is Integer; - subtype Vertex_Id is Integer; - subtype Edge_Id is Integer; - subtype Table_Id is Integer; - - No_Vertex : constant Vertex_Id := -1; - No_Edge : constant Edge_Id := -1; - No_Table : constant Table_Id := -1; - - type Word_Type is new String_Access; - procedure Free_Word (W : in out Word_Type) renames Free; - function New_Word (S : String) return Word_Type; - - procedure Resize_Word (W : in out Word_Type; Len : Natural); - -- Resize string W to have a length Len - - type Key_Type is record - Edge : Edge_Id; - end record; - -- A key corresponds to an edge in the algorithm graph - - type Vertex_Type is record - First : Edge_Id; - Last : Edge_Id; - end record; - -- A vertex can be involved in several edges. First and Last are the bounds - -- of an array of edges stored in a global edge table. - - type Edge_Type is record - X : Vertex_Id; - Y : Vertex_Id; - Key : Key_Id; - end record; - -- An edge is a peer of vertices. In the algorithm, a key is associated to - -- an edge. - - package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); - package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); - -- The two main tables. WT is used to store the words in their initial - -- version and in their reduced version (that is words reduced to their - -- significant characters). As an instance of GNAT.Table, WT does not - -- initialize string pointers to null. This initialization has to be done - -- manually when the table is allocated. IT is used to store several - -- tables of components containing only integers. - - function Image (Int : Integer; W : Natural := 0) return String; - function Image (Str : String; W : Natural := 0) return String; - -- Return a string which includes string Str or integer Int preceded by - -- leading spaces if required by width W. - - function Trim_Trailing_Nuls (Str : String) return String; - -- Return Str with trailing NUL characters removed - - Output : File_Descriptor renames GNAT.OS_Lib.Standout; - -- Shortcuts - - EOL : constant Character := ASCII.LF; - - Max : constant := 78; - Last : Natural := 0; - Line : String (1 .. Max); - -- Use this line to provide buffered IO - - procedure Add (C : Character); - procedure Add (S : String); - -- Add a character or a string in Line and update Last - - procedure Put - (F : File_Descriptor; - S : String; - F1 : Natural; - L1 : Natural; - C1 : Natural; - F2 : Natural; - L2 : Natural; - C2 : Natural); - -- Write string S into file F as a element of an array of one or two - -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and - -- current) index in the k-th dimension. If F1 = L1 the array is considered - -- as a one dimension array. This dimension is described by F2 and L2. This - -- routine takes care of all the parenthesis, spaces and commas needed to - -- format correctly the array. Moreover, the array is well indented and is - -- wrapped to fit in a 80 col line. When the line is full, the routine - -- writes it into file F. When the array is completed, the routine adds - -- semi-colon and writes the line into file F. - - procedure New_Line (File : File_Descriptor); - -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib - - procedure Put (File : File_Descriptor; Str : String); - -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib - - procedure Put_Used_Char_Set (File : File_Descriptor; Title : String); - -- Output a title and a used character set - - procedure Put_Int_Vector - (File : File_Descriptor; - Title : String; - Vector : Integer; - Length : Natural); - -- Output a title and a vector - - procedure Put_Int_Matrix - (File : File_Descriptor; - Title : String; - Table : Table_Id; - Len_1 : Natural; - Len_2 : Natural); - -- Output a title and a matrix. When the matrix has only one non-empty - -- dimension (Len_2 = 0), output a vector. - - procedure Put_Edges (File : File_Descriptor; Title : String); - -- Output a title and an edge table - - procedure Put_Initial_Keys (File : File_Descriptor; Title : String); - -- Output a title and a key table - - procedure Put_Reduced_Keys (File : File_Descriptor; Title : String); - -- Output a title and a key table - - procedure Put_Vertex_Table (File : File_Descriptor; Title : String); - -- Output a title and a vertex table - - function Ada_File_Base_Name (Pkg_Name : String) return String; - -- Return the base file name (i.e. without .ads/.adb extension) for an - -- Ada source file containing the named package, using the standard GNAT - -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we - -- return "parent-child". - - ---------------------------------- - -- Character Position Selection -- - ---------------------------------- - - -- We reduce the maximum key size by selecting representative positions - -- in these keys. We build a matrix with one word per line. We fill the - -- remaining space of a line with ASCII.NUL. The heuristic selects the - -- position that induces the minimum number of collisions. If there are - -- collisions, select another position on the reduced key set responsible - -- of the collisions. Apply the heuristic until there is no more collision. - - procedure Apply_Position_Selection; - -- Apply Position selection and build the reduced key table - - procedure Parse_Position_Selection (Argument : String); - -- Parse Argument and compute the position set. Argument is list of - -- substrings separated by commas. Each substring represents a position - -- or a range of positions (like x-y). - - procedure Select_Character_Set; - -- Define an optimized used character set like Character'Pos in order not - -- to allocate tables of 256 entries. - - procedure Select_Char_Position; - -- Find a min char position set in order to reduce the max key length. The - -- heuristic selects the position that induces the minimum number of - -- collisions. If there are collisions, select another position on the - -- reduced key set responsible of the collisions. Apply the heuristic until - -- there is no collision. - - ----------------------------- - -- Random Graph Generation -- - ----------------------------- - - procedure Random (Seed : in out Natural); - -- Simulate Ada.Discrete_Numerics.Random - - procedure Generate_Mapping_Table - (Tab : Table_Id; - L1 : Natural; - L2 : Natural; - Seed : in out Natural); - -- Random generation of the tables below. T is already allocated - - procedure Generate_Mapping_Tables - (Opt : Optimization; - Seed : in out Natural); - -- Generate the mapping tables T1 and T2. They are used to define fk (w) = - -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars - -- are used to compute the matrix size. - - --------------------------- - -- Algorithm Computation -- - --------------------------- - - procedure Compute_Edges_And_Vertices (Opt : Optimization); - -- Compute the edge and vertex tables. These are empty when a self loop is - -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then - -- Y value. Keys is the key table and NK the number of keys. Chars is the - -- set of characters really used in Keys. NV is the number of vertices - -- recommended by the algorithm. T1 and T2 are the mapping tables needed to - -- compute f1 (w) and f2 (w). - - function Acyclic return Boolean; - -- Return True when the graph is acyclic. Vertices is the current vertex - -- table and Edges the current edge table. - - procedure Assign_Values_To_Vertices; - -- Execute the assignment step of the algorithm. Keys is the current key - -- table. Vertices and Edges represent the random graph. G is the result of - -- the assignment step such that: - -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m - - function Sum - (Word : Word_Type; - Table : Table_Id; - Opt : Optimization) return Natural; - -- For an optimization of CPU_Time return - -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n - -- For an optimization of Memory_Space return - -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n - -- Here NV = n - - ------------------------------- - -- Internal Table Management -- - ------------------------------- - - function Allocate (N : Natural; S : Natural := 1) return Table_Id; - -- Allocate N * S ints from IT table - - ---------- - -- Keys -- - ---------- - - Keys : Table_Id := No_Table; - NK : Natural := 0; - -- NK : Number of Keys - - function Initial (K : Key_Id) return Word_Id; - pragma Inline (Initial); - - function Reduced (K : Key_Id) return Word_Id; - pragma Inline (Reduced); - - function Get_Key (N : Key_Id) return Key_Type; - procedure Set_Key (N : Key_Id; Item : Key_Type); - -- Get or Set Nth element of Keys table - - ------------------ - -- Char_Pos_Set -- - ------------------ - - Char_Pos_Set : Table_Id := No_Table; - Char_Pos_Set_Len : Natural; - -- Character Selected Position Set - - function Get_Char_Pos (P : Natural) return Natural; - procedure Set_Char_Pos (P : Natural; Item : Natural); - -- Get or Set the string position of the Pth selected character - - ------------------- - -- Used_Char_Set -- - ------------------- - - Used_Char_Set : Table_Id := No_Table; - Used_Char_Set_Len : Natural; - -- Used Character Set : Define a new character mapping. When all the - -- characters are not present in the keys, in order to reduce the size - -- of some tables, we redefine the character mapping. - - function Get_Used_Char (C : Character) return Natural; - procedure Set_Used_Char (C : Character; Item : Natural); - - ------------ - -- Tables -- - ------------ - - T1 : Table_Id := No_Table; - T2 : Table_Id := No_Table; - T1_Len : Natural; - T2_Len : Natural; - -- T1 : Values table to compute F1 - -- T2 : Values table to compute F2 - - function Get_Table (T : Integer; X, Y : Natural) return Natural; - procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural); - - ----------- - -- Graph -- - ----------- - - G : Table_Id := No_Table; - G_Len : Natural; - -- Values table to compute G - - NT : Natural := Default_Tries; - -- Number of tries running the algorithm before raising an error - - function Get_Graph (N : Natural) return Integer; - procedure Set_Graph (N : Natural; Item : Integer); - -- Get or Set Nth element of graph - - ----------- - -- Edges -- - ----------- - - Edge_Size : constant := 3; - Edges : Table_Id := No_Table; - Edges_Len : Natural; - -- Edges : Edge table of the random graph G - - function Get_Edges (F : Natural) return Edge_Type; - procedure Set_Edges (F : Natural; Item : Edge_Type); - - -------------- - -- Vertices -- - -------------- - - Vertex_Size : constant := 2; - - Vertices : Table_Id := No_Table; - -- Vertex table of the random graph G - - NV : Natural; - -- Number of Vertices - - function Get_Vertices (F : Natural) return Vertex_Type; - procedure Set_Vertices (F : Natural; Item : Vertex_Type); - -- Comments needed ??? - - K2V : Float; - -- Ratio between Keys and Vertices (parameter of Czech's algorithm) - - Opt : Optimization; - -- Optimization mode (memory vs CPU) - - Max_Key_Len : Natural := 0; - Min_Key_Len : Natural := 0; - -- Maximum and minimum of all the word length - - S : Natural; - -- Seed - - function Type_Size (L : Natural) return Natural; - -- Given the last L of an unsigned integer type T, return its size - - ------------- - -- Acyclic -- - ------------- - - function Acyclic return Boolean is - Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex); - - function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean; - -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate - -- it to the edges of Y except the one representing the same key. Return - -- False when Y is marked with Mark. - - -------------- - -- Traverse -- - -------------- - - function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is - E : constant Edge_Type := Get_Edges (Edge); - K : constant Key_Id := E.Key; - Y : constant Vertex_Id := E.Y; - M : constant Vertex_Id := Marks (E.Y); - V : Vertex_Type; - - begin - if M = Mark then - return False; - - elsif M = No_Vertex then - Marks (Y) := Mark; - V := Get_Vertices (Y); - - for J in V.First .. V.Last loop - - -- Do not propagate to the edge representing the same key - - if Get_Edges (J).Key /= K - and then not Traverse (J, Mark) - then - return False; - end if; - end loop; - end if; - - return True; - end Traverse; - - Edge : Edge_Type; - - -- Start of processing for Acyclic - - begin - -- Edges valid range is - - for J in 1 .. Edges_Len - 1 loop - - Edge := Get_Edges (J); - - -- Mark X of E when it has not been already done - - if Marks (Edge.X) = No_Vertex then - Marks (Edge.X) := Edge.X; - end if; - - -- Traverse E when this has not already been done - - if Marks (Edge.Y) = No_Vertex - and then not Traverse (J, Edge.X) - then - return False; - end if; - end loop; - - return True; - end Acyclic; - - ------------------------ - -- Ada_File_Base_Name -- - ------------------------ - - function Ada_File_Base_Name (Pkg_Name : String) return String is - begin - -- Convert to lower case, then replace '.' with '-' - - return Result : String := To_Lower (Pkg_Name) do - for J in Result'Range loop - if Result (J) = '.' then - Result (J) := '-'; - end if; - end loop; - end return; - end Ada_File_Base_Name; - - --------- - -- Add -- - --------- - - procedure Add (C : Character) is - pragma Assert (C /= ASCII.NUL); - begin - Line (Last + 1) := C; - Last := Last + 1; - end Add; - - --------- - -- Add -- - --------- - - procedure Add (S : String) is - Len : constant Natural := S'Length; - begin - for J in S'Range loop - pragma Assert (S (J) /= ASCII.NUL); - null; - end loop; - - Line (Last + 1 .. Last + Len) := S; - Last := Last + Len; - end Add; - - -------------- - -- Allocate -- - -------------- - - function Allocate (N : Natural; S : Natural := 1) return Table_Id is - L : constant Integer := IT.Last; - begin - IT.Set_Last (L + N * S); - - -- Initialize, so debugging printouts don't trip over uninitialized - -- components. - - for J in L + 1 .. IT.Last loop - IT.Table (J) := -1; - end loop; - - return L + 1; - end Allocate; - - ------------------------------ - -- Apply_Position_Selection -- - ------------------------------ - - procedure Apply_Position_Selection is - begin - for J in 0 .. NK - 1 loop - declare - IW : constant String := WT.Table (Initial (J)).all; - RW : String (1 .. IW'Length) := (others => ASCII.NUL); - N : Natural := IW'First - 1; - - begin - -- Select the characters of Word included in the position - -- selection. - - for C in 0 .. Char_Pos_Set_Len - 1 loop - exit when IW (Get_Char_Pos (C)) = ASCII.NUL; - N := N + 1; - RW (N) := IW (Get_Char_Pos (C)); - end loop; - - -- Build the new table with the reduced word. Be careful - -- to deallocate the old version to avoid memory leaks. - - Free_Word (WT.Table (Reduced (J))); - WT.Table (Reduced (J)) := New_Word (RW); - Set_Key (J, (Edge => No_Edge)); - end; - end loop; - end Apply_Position_Selection; - - ------------------------------- - -- Assign_Values_To_Vertices -- - ------------------------------- - - procedure Assign_Values_To_Vertices is - X : Vertex_Id; - - procedure Assign (X : Vertex_Id); - -- Execute assignment on X's neighbors except the vertex that we are - -- coming from which is already assigned. - - ------------ - -- Assign -- - ------------ - - procedure Assign (X : Vertex_Id) is - E : Edge_Type; - V : constant Vertex_Type := Get_Vertices (X); - - begin - for J in V.First .. V.Last loop - E := Get_Edges (J); - - if Get_Graph (E.Y) = -1 then - Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK); - Assign (E.Y); - end if; - end loop; - end Assign; - - -- Start of processing for Assign_Values_To_Vertices - - begin - -- Value -1 denotes an uninitialized value as it is supposed to - -- be in the range 0 .. NK. - - if G = No_Table then - G_Len := NV; - G := Allocate (G_Len, 1); - end if; - - for J in 0 .. G_Len - 1 loop - Set_Graph (J, -1); - end loop; - - for K in 0 .. NK - 1 loop - X := Get_Edges (Get_Key (K).Edge).X; - - if Get_Graph (X) = -1 then - Set_Graph (X, 0); - Assign (X); - end if; - end loop; - - for J in 0 .. G_Len - 1 loop - if Get_Graph (J) = -1 then - Set_Graph (J, 0); - end if; - end loop; - - if Verbose then - Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len); - end if; - end Assign_Values_To_Vertices; - - ------------- - -- Compute -- - ------------- - - procedure Compute (Position : String := Default_Position) is - Success : Boolean := False; - - begin - if NK = 0 then - raise Program_Error with "keywords set cannot be empty"; - end if; - - if Verbose then - Put_Initial_Keys (Output, "Initial Key Table"); - end if; - - if Position'Length /= 0 then - Parse_Position_Selection (Position); - else - Select_Char_Position; - end if; - - if Verbose then - Put_Int_Vector - (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len); - end if; - - Apply_Position_Selection; - - if Verbose then - Put_Reduced_Keys (Output, "Reduced Keys Table"); - end if; - - Select_Character_Set; - - if Verbose then - Put_Used_Char_Set (Output, "Character Position Table"); - end if; - - -- Perform Czech's algorithm - - for J in 1 .. NT loop - Generate_Mapping_Tables (Opt, S); - Compute_Edges_And_Vertices (Opt); - - -- When graph is not empty (no self-loop from previous operation) and - -- not acyclic. - - if 0 < Edges_Len and then Acyclic then - Success := True; - exit; - end if; - end loop; - - if not Success then - raise Too_Many_Tries; - end if; - - Assign_Values_To_Vertices; - end Compute; - - -------------------------------- - -- Compute_Edges_And_Vertices -- - -------------------------------- - - procedure Compute_Edges_And_Vertices (Opt : Optimization) is - X : Natural; - Y : Natural; - Key : Key_Type; - Edge : Edge_Type; - Vertex : Vertex_Type; - Not_Acyclic : Boolean := False; - - procedure Move (From : Natural; To : Natural); - function Lt (L, R : Natural) return Boolean; - -- Subprograms needed for GNAT.Heap_Sort_G - - -------- - -- Lt -- - -------- - - function Lt (L, R : Natural) return Boolean is - EL : constant Edge_Type := Get_Edges (L); - ER : constant Edge_Type := Get_Edges (R); - begin - return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y); - end Lt; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - begin - Set_Edges (To, Get_Edges (From)); - end Move; - - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - - -- Start of processing for Compute_Edges_And_Vertices - - begin - -- We store edges from 1 to 2 * NK and leave zero alone in order to use - -- GNAT.Heap_Sort_G. - - Edges_Len := 2 * NK + 1; - - if Edges = No_Table then - Edges := Allocate (Edges_Len, Edge_Size); - end if; - - if Vertices = No_Table then - Vertices := Allocate (NV, Vertex_Size); - end if; - - for J in 0 .. NV - 1 loop - Set_Vertices (J, (No_Vertex, No_Vertex - 1)); - end loop; - - -- For each w, X = f1 (w) and Y = f2 (w) - - for J in 0 .. NK - 1 loop - Key := Get_Key (J); - Key.Edge := No_Edge; - Set_Key (J, Key); - - X := Sum (WT.Table (Reduced (J)), T1, Opt); - Y := Sum (WT.Table (Reduced (J)), T2, Opt); - - -- Discard T1 and T2 as soon as we discover a self loop - - if X = Y then - Not_Acyclic := True; - exit; - end if; - - -- We store (X, Y) and (Y, X) to ease assignment step - - Set_Edges (2 * J + 1, (X, Y, J)); - Set_Edges (2 * J + 2, (Y, X, J)); - end loop; - - -- Return an empty graph when self loop detected - - if Not_Acyclic then - Edges_Len := 0; - - else - if Verbose then - Put_Edges (Output, "Unsorted Edge Table"); - Put_Int_Matrix (Output, "Function Table 1", T1, - T1_Len, T2_Len); - Put_Int_Matrix (Output, "Function Table 2", T2, - T1_Len, T2_Len); - end if; - - -- Enforce consistency between edges and keys. Construct Vertices and - -- compute the list of neighbors of a vertex First .. Last as Edges - -- is sorted by X and then Y. To compute the neighbor list, sort the - -- edges. - - Sorting.Sort (Edges_Len - 1); - - if Verbose then - Put_Edges (Output, "Sorted Edge Table"); - Put_Int_Matrix (Output, "Function Table 1", T1, - T1_Len, T2_Len); - Put_Int_Matrix (Output, "Function Table 2", T2, - T1_Len, T2_Len); - end if; - - -- Edges valid range is 1 .. 2 * NK - - for E in 1 .. Edges_Len - 1 loop - Edge := Get_Edges (E); - Key := Get_Key (Edge.Key); - - if Key.Edge = No_Edge then - Key.Edge := E; - Set_Key (Edge.Key, Key); - end if; - - Vertex := Get_Vertices (Edge.X); - - if Vertex.First = No_Edge then - Vertex.First := E; - end if; - - Vertex.Last := E; - Set_Vertices (Edge.X, Vertex); - end loop; - - if Verbose then - Put_Reduced_Keys (Output, "Key Table"); - Put_Edges (Output, "Edge Table"); - Put_Vertex_Table (Output, "Vertex Table"); - end if; - end if; - end Compute_Edges_And_Vertices; - - ------------ - -- Define -- - ------------ - - procedure Define - (Name : Table_Name; - Item_Size : out Natural; - Length_1 : out Natural; - Length_2 : out Natural) - is - begin - case Name is - when Character_Position => - Item_Size := 8; - Length_1 := Char_Pos_Set_Len; - Length_2 := 0; - - when Used_Character_Set => - Item_Size := 8; - Length_1 := 256; - Length_2 := 0; - - when Function_Table_1 - | Function_Table_2 - => - Item_Size := Type_Size (NV); - Length_1 := T1_Len; - Length_2 := T2_Len; - - when Graph_Table => - Item_Size := Type_Size (NK); - Length_1 := NV; - Length_2 := 0; - end case; - end Define; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - if Verbose then - Put (Output, "Finalize"); - New_Line (Output); - end if; - - -- Deallocate all the WT components (both initial and reduced ones) to - -- avoid memory leaks. - - for W in 0 .. WT.Last loop - - -- Note: WT.Table (NK) is a temporary variable, do not free it since - -- this would cause a double free. - - if W /= NK then - Free_Word (WT.Table (W)); - end if; - end loop; - - WT.Release; - IT.Release; - - -- Reset all variables for next usage - - Keys := No_Table; - - Char_Pos_Set := No_Table; - Char_Pos_Set_Len := 0; - - Used_Char_Set := No_Table; - Used_Char_Set_Len := 0; - - T1 := No_Table; - T2 := No_Table; - - T1_Len := 0; - T2_Len := 0; - - G := No_Table; - G_Len := 0; - - Edges := No_Table; - Edges_Len := 0; - - Vertices := No_Table; - NV := 0; - - NK := 0; - Max_Key_Len := 0; - Min_Key_Len := 0; - end Finalize; - - ---------------------------- - -- Generate_Mapping_Table -- - ---------------------------- - - procedure Generate_Mapping_Table - (Tab : Integer; - L1 : Natural; - L2 : Natural; - Seed : in out Natural) - is - begin - for J in 0 .. L1 - 1 loop - for K in 0 .. L2 - 1 loop - Random (Seed); - Set_Table (Tab, J, K, Seed mod NV); - end loop; - end loop; - end Generate_Mapping_Table; - - ----------------------------- - -- Generate_Mapping_Tables -- - ----------------------------- - - procedure Generate_Mapping_Tables - (Opt : Optimization; - Seed : in out Natural) - is - begin - -- If T1 and T2 are already allocated no need to do it twice. Reuse them - -- as their size has not changed. - - if T1 = No_Table and then T2 = No_Table then - declare - Used_Char_Last : Natural := 0; - Used_Char : Natural; - - begin - if Opt = CPU_Time then - for P in reverse Character'Range loop - Used_Char := Get_Used_Char (P); - if Used_Char /= 0 then - Used_Char_Last := Used_Char; - exit; - end if; - end loop; - end if; - - T1_Len := Char_Pos_Set_Len; - T2_Len := Used_Char_Last + 1; - T1 := Allocate (T1_Len * T2_Len); - T2 := Allocate (T1_Len * T2_Len); - end; - end if; - - Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed); - Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed); - - if Verbose then - Put_Used_Char_Set (Output, "Used Character Set"); - Put_Int_Matrix (Output, "Function Table 1", T1, - T1_Len, T2_Len); - Put_Int_Matrix (Output, "Function Table 2", T2, - T1_Len, T2_Len); - end if; - end Generate_Mapping_Tables; - - ------------------ - -- Get_Char_Pos -- - ------------------ - - function Get_Char_Pos (P : Natural) return Natural is - N : constant Natural := Char_Pos_Set + P; - begin - return IT.Table (N); - end Get_Char_Pos; - - --------------- - -- Get_Edges -- - --------------- - - function Get_Edges (F : Natural) return Edge_Type is - N : constant Natural := Edges + (F * Edge_Size); - E : Edge_Type; - begin - E.X := IT.Table (N); - E.Y := IT.Table (N + 1); - E.Key := IT.Table (N + 2); - return E; - end Get_Edges; - - --------------- - -- Get_Graph -- - --------------- - - function Get_Graph (N : Natural) return Integer is - begin - return IT.Table (G + N); - end Get_Graph; - - ------------- - -- Get_Key -- - ------------- - - function Get_Key (N : Key_Id) return Key_Type is - K : Key_Type; - begin - K.Edge := IT.Table (Keys + N); - return K; - end Get_Key; - - --------------- - -- Get_Table -- - --------------- - - function Get_Table (T : Integer; X, Y : Natural) return Natural is - N : constant Natural := T + (Y * T1_Len) + X; - begin - return IT.Table (N); - end Get_Table; - - ------------------- - -- Get_Used_Char -- - ------------------- - - function Get_Used_Char (C : Character) return Natural is - N : constant Natural := Used_Char_Set + Character'Pos (C); - begin - return IT.Table (N); - end Get_Used_Char; - - ------------------ - -- Get_Vertices -- - ------------------ - - function Get_Vertices (F : Natural) return Vertex_Type is - N : constant Natural := Vertices + (F * Vertex_Size); - V : Vertex_Type; - begin - V.First := IT.Table (N); - V.Last := IT.Table (N + 1); - return V; - end Get_Vertices; - - ----------- - -- Image -- - ----------- - - function Image (Int : Integer; W : Natural := 0) return String is - B : String (1 .. 32); - L : Natural := 0; - - procedure Img (V : Natural); - -- Compute image of V into B, starting at B (L), incrementing L - - --------- - -- Img -- - --------- - - procedure Img (V : Natural) is - begin - if V > 9 then - Img (V / 10); - end if; - - L := L + 1; - B (L) := Character'Val ((V mod 10) + Character'Pos ('0')); - end Img; - - -- Start of processing for Image - - begin - if Int < 0 then - L := L + 1; - B (L) := '-'; - Img (-Int); - else - Img (Int); - end if; - - return Image (B (1 .. L), W); - end Image; - - ----------- - -- Image -- - ----------- - - function Image (Str : String; W : Natural := 0) return String is - Len : constant Natural := Str'Length; - Max : Natural := Len; - - begin - if Max < W then - Max := W; - end if; - - declare - Buf : String (1 .. Max) := (1 .. Max => ' '); - - begin - for J in 0 .. Len - 1 loop - Buf (Max - Len + 1 + J) := Str (Str'First + J); - end loop; - - return Buf; - end; - end Image; - - ------------- - -- Initial -- - ------------- - - function Initial (K : Key_Id) return Word_Id is - begin - return K; - end Initial; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize - (Seed : Natural; - K_To_V : Float := Default_K_To_V; - Optim : Optimization := Memory_Space; - Tries : Positive := Default_Tries) - is - begin - if Verbose then - Put (Output, "Initialize"); - New_Line (Output); - end if; - - -- Deallocate the part of the table concerning the reduced words. - -- Initial words are already present in the table. We may have reduced - -- words already there because a previous computation failed. We are - -- currently retrying and the reduced words have to be deallocated. - - for W in Reduced (0) .. WT.Last loop - Free_Word (WT.Table (W)); - end loop; - - IT.Init; - - -- Initialize of computation variables - - Keys := No_Table; - - Char_Pos_Set := No_Table; - Char_Pos_Set_Len := 0; - - Used_Char_Set := No_Table; - Used_Char_Set_Len := 0; - - T1 := No_Table; - T2 := No_Table; - - T1_Len := 0; - T2_Len := 0; - - G := No_Table; - G_Len := 0; - - Edges := No_Table; - Edges_Len := 0; - - Vertices := No_Table; - NV := 0; - - S := Seed; - K2V := K_To_V; - Opt := Optim; - NT := Tries; - - if K2V <= 2.0 then - raise Program_Error with "K to V ratio cannot be lower than 2.0"; - end if; - - -- Do not accept a value of K2V too close to 2.0 such that once - -- rounded up, NV = 2 * NK because the algorithm would not converge. - - NV := Natural (Float (NK) * K2V); - if NV <= 2 * NK then - NV := 2 * NK + 1; - end if; - - Keys := Allocate (NK); - - -- Resize initial words to have all of them at the same size - -- (so the size of the largest one). - - for K in 0 .. NK - 1 loop - Resize_Word (WT.Table (Initial (K)), Max_Key_Len); - end loop; - - -- Allocated the table to store the reduced words. As WT is a - -- GNAT.Table (using C memory management), pointers have to be - -- explicitly initialized to null. - - WT.Set_Last (Reduced (NK - 1)); - - -- Note: Reduced (0) = NK + 1 - - WT.Table (NK) := null; - - for W in 0 .. NK - 1 loop - WT.Table (Reduced (W)) := null; - end loop; - end Initialize; - - ------------ - -- Insert -- - ------------ - - procedure Insert (Value : String) is - Len : constant Natural := Value'Length; - - begin - if Verbose then - Put (Output, "Inserting """ & Value & """"); - New_Line (Output); - end if; - - for J in Value'Range loop - pragma Assert (Value (J) /= ASCII.NUL); - null; - end loop; - - WT.Set_Last (NK); - WT.Table (NK) := New_Word (Value); - NK := NK + 1; - - if Max_Key_Len < Len then - Max_Key_Len := Len; - end if; - - if Min_Key_Len = 0 or else Len < Min_Key_Len then - Min_Key_Len := Len; - end if; - end Insert; - - -------------- - -- New_Line -- - -------------- - - procedure New_Line (File : File_Descriptor) is - begin - if Write (File, EOL'Address, 1) /= 1 then - raise Program_Error; - end if; - end New_Line; - - -------------- - -- New_Word -- - -------------- - - function New_Word (S : String) return Word_Type is - begin - return new String'(S); - end New_Word; - - ------------------------------ - -- Parse_Position_Selection -- - ------------------------------ - - procedure Parse_Position_Selection (Argument : String) is - N : Natural := Argument'First; - L : constant Natural := Argument'Last; - M : constant Natural := Max_Key_Len; - - T : array (1 .. M) of Boolean := (others => False); - - function Parse_Index return Natural; - -- Parse argument starting at index N to find an index - - ----------------- - -- Parse_Index -- - ----------------- - - function Parse_Index return Natural is - C : Character := Argument (N); - V : Natural := 0; - - begin - if C = '$' then - N := N + 1; - return M; - end if; - - if C not in '0' .. '9' then - raise Program_Error with "cannot read position argument"; - end if; - - while C in '0' .. '9' loop - V := V * 10 + (Character'Pos (C) - Character'Pos ('0')); - N := N + 1; - exit when L < N; - C := Argument (N); - end loop; - - return V; - end Parse_Index; - - -- Start of processing for Parse_Position_Selection - - begin - -- Empty specification means all the positions - - if L < N then - Char_Pos_Set_Len := M; - Char_Pos_Set := Allocate (Char_Pos_Set_Len); - - for C in 0 .. Char_Pos_Set_Len - 1 loop - Set_Char_Pos (C, C + 1); - end loop; - - else - loop - declare - First, Last : Natural; - - begin - First := Parse_Index; - Last := First; - - -- Detect a range - - if N <= L and then Argument (N) = '-' then - N := N + 1; - Last := Parse_Index; - end if; - - -- Include the positions in the selection - - for J in First .. Last loop - T (J) := True; - end loop; - end; - - exit when L < N; - - if Argument (N) /= ',' then - raise Program_Error with "cannot read position argument"; - end if; - - N := N + 1; - end loop; - - -- Compute position selection length - - N := 0; - for J in T'Range loop - if T (J) then - N := N + 1; - end if; - end loop; - - -- Fill position selection - - Char_Pos_Set_Len := N; - Char_Pos_Set := Allocate (Char_Pos_Set_Len); - - N := 0; - for J in T'Range loop - if T (J) then - Set_Char_Pos (N, J); - N := N + 1; - end if; - end loop; - end if; - end Parse_Position_Selection; - - ------------- - -- Produce -- - ------------- - - procedure Produce - (Pkg_Name : String := Default_Pkg_Name; - Use_Stdout : Boolean := False) - is - File : File_Descriptor := Standout; - - Status : Boolean; - -- For call to Close - - function Array_Img (N, T, R1 : String; R2 : String := "") return String; - -- Return string "N : constant array (R1[, R2]) of T;" - - function Range_Img (F, L : Natural; T : String := "") return String; - -- Return string "[T range ]F .. L" - - function Type_Img (L : Natural) return String; - -- Return the larger unsigned type T such that T'Last < L - - --------------- - -- Array_Img -- - --------------- - - function Array_Img - (N, T, R1 : String; - R2 : String := "") return String - is - begin - Last := 0; - Add (" "); - Add (N); - Add (" : constant array ("); - Add (R1); - - if R2 /= "" then - Add (", "); - Add (R2); - end if; - - Add (") of "); - Add (T); - Add (" :="); - return Line (1 .. Last); - end Array_Img; - - --------------- - -- Range_Img -- - --------------- - - function Range_Img (F, L : Natural; T : String := "") return String is - FI : constant String := Image (F); - FL : constant Natural := FI'Length; - LI : constant String := Image (L); - LL : constant Natural := LI'Length; - TL : constant Natural := T'Length; - RI : String (1 .. TL + 7 + FL + 4 + LL); - Len : Natural := 0; - - begin - if TL /= 0 then - RI (Len + 1 .. Len + TL) := T; - Len := Len + TL; - RI (Len + 1 .. Len + 7) := " range "; - Len := Len + 7; - end if; - - RI (Len + 1 .. Len + FL) := FI; - Len := Len + FL; - RI (Len + 1 .. Len + 4) := " .. "; - Len := Len + 4; - RI (Len + 1 .. Len + LL) := LI; - Len := Len + LL; - return RI (1 .. Len); - end Range_Img; - - -------------- - -- Type_Img -- - -------------- - - function Type_Img (L : Natural) return String is - S : constant String := Image (Type_Size (L)); - U : String := "Unsigned_ "; - N : Natural := 9; - - begin - for J in S'Range loop - N := N + 1; - U (N) := S (J); - end loop; - - return U (1 .. N); - end Type_Img; - - F : Natural; - L : Natural; - P : Natural; - - FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads"; - -- Initially, the name of the spec file, then modified to be the name of - -- the body file. Not used if Use_Stdout is True. - - -- Start of processing for Produce - - begin - - if Verbose and then not Use_Stdout then - Put (Output, - "Producing " & Ada.Directories.Current_Directory & "/" & FName); - New_Line (Output); - end if; - - if not Use_Stdout then - File := Create_File (FName, Binary); - - if File = Invalid_FD then - raise Program_Error with "cannot create: " & FName; - end if; - end if; - - Put (File, "package "); - Put (File, Pkg_Name); - Put (File, " is"); - New_Line (File); - Put (File, " function Hash (S : String) return Natural;"); - New_Line (File); - Put (File, "end "); - Put (File, Pkg_Name); - Put (File, ";"); - New_Line (File); - - if not Use_Stdout then - Close (File, Status); - - if not Status then - raise Device_Error; - end if; - end if; - - if not Use_Stdout then - - -- Set to body file name - - FName (FName'Last) := 'b'; - - File := Create_File (FName, Binary); - - if File = Invalid_FD then - raise Program_Error with "cannot create: " & FName; - end if; - end if; - - Put (File, "with Interfaces; use Interfaces;"); - New_Line (File); - New_Line (File); - Put (File, "package body "); - Put (File, Pkg_Name); - Put (File, " is"); - New_Line (File); - New_Line (File); - - if Opt = CPU_Time then - Put (File, Array_Img ("C", Type_Img (256), "Character")); - New_Line (File); - - F := Character'Pos (Character'First); - L := Character'Pos (Character'Last); - - for J in Character'Range loop - P := Get_Used_Char (J); - Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J)); - end loop; - - New_Line (File); - end if; - - F := 0; - L := Char_Pos_Set_Len - 1; - - Put (File, Array_Img ("P", "Natural", Range_Img (F, L))); - New_Line (File); - - for J in F .. L loop - Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J); - end loop; - - New_Line (File); - - case Opt is - when CPU_Time => - Put_Int_Matrix - (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T1, T1_Len, T2_Len); - - when Memory_Space => - Put_Int_Matrix - (File, - Array_Img ("T1", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T1, T1_Len, 0); - end case; - - New_Line (File); - - case Opt is - when CPU_Time => - Put_Int_Matrix - (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1), - Range_Img (0, T2_Len - 1, Type_Img (256))), - T2, T1_Len, T2_Len); - - when Memory_Space => - Put_Int_Matrix - (File, - Array_Img ("T2", Type_Img (NV), - Range_Img (0, T1_Len - 1)), - T2, T1_Len, 0); - end case; - - New_Line (File); - - Put_Int_Vector - (File, - Array_Img ("G", Type_Img (NK), - Range_Img (0, G_Len - 1)), - G, G_Len); - New_Line (File); - - Put (File, " function Hash (S : String) return Natural is"); - New_Line (File); - Put (File, " F : constant Natural := S'First - 1;"); - New_Line (File); - Put (File, " L : constant Natural := S'Length;"); - New_Line (File); - Put (File, " F1, F2 : Natural := 0;"); - New_Line (File); - - Put (File, " J : "); - - case Opt is - when CPU_Time => - Put (File, Type_Img (256)); - - when Memory_Space => - Put (File, "Natural"); - end case; - - Put (File, ";"); - New_Line (File); - - Put (File, " begin"); - New_Line (File); - Put (File, " for K in P'Range loop"); - New_Line (File); - Put (File, " exit when L < P (K);"); - New_Line (File); - Put (File, " J := "); - - case Opt is - when CPU_Time => - Put (File, "C"); - - when Memory_Space => - Put (File, "Character'Pos"); - end case; - - Put (File, " (S (P (K) + F));"); - New_Line (File); - - Put (File, " F1 := (F1 + Natural (T1 (K"); - - if Opt = CPU_Time then - Put (File, ", J"); - end if; - - Put (File, "))"); - - if Opt = Memory_Space then - Put (File, " * J"); - end if; - - Put (File, ") mod "); - Put (File, Image (NV)); - Put (File, ";"); - New_Line (File); - - Put (File, " F2 := (F2 + Natural (T2 (K"); - - if Opt = CPU_Time then - Put (File, ", J"); - end if; - - Put (File, "))"); - - if Opt = Memory_Space then - Put (File, " * J"); - end if; - - Put (File, ") mod "); - Put (File, Image (NV)); - Put (File, ";"); - New_Line (File); - - Put (File, " end loop;"); - New_Line (File); - - Put (File, - " return (Natural (G (F1)) + Natural (G (F2))) mod "); - - Put (File, Image (NK)); - Put (File, ";"); - New_Line (File); - Put (File, " end Hash;"); - New_Line (File); - New_Line (File); - Put (File, "end "); - Put (File, Pkg_Name); - Put (File, ";"); - New_Line (File); - - if not Use_Stdout then - Close (File, Status); - - if not Status then - raise Device_Error; - end if; - end if; - end Produce; - - --------- - -- Put -- - --------- - - procedure Put (File : File_Descriptor; Str : String) is - Len : constant Natural := Str'Length; - begin - for J in Str'Range loop - pragma Assert (Str (J) /= ASCII.NUL); - null; - end loop; - - if Write (File, Str'Address, Len) /= Len then - raise Program_Error; - end if; - end Put; - - --------- - -- Put -- - --------- - - procedure Put - (F : File_Descriptor; - S : String; - F1 : Natural; - L1 : Natural; - C1 : Natural; - F2 : Natural; - L2 : Natural; - C2 : Natural) - is - Len : constant Natural := S'Length; - - procedure Flush; - -- Write current line, followed by LF - - ----------- - -- Flush -- - ----------- - - procedure Flush is - begin - Put (F, Line (1 .. Last)); - New_Line (F); - Last := 0; - end Flush; - - -- Start of processing for Put - - begin - if C1 = F1 and then C2 = F2 then - Last := 0; - end if; - - if Last + Len + 3 >= Max then - Flush; - end if; - - if Last = 0 then - Add (" "); - - if F1 <= L1 then - if C1 = F1 and then C2 = F2 then - Add ('('); - - if F1 = L1 then - Add ("0 .. 0 => "); - end if; - - else - Add (' '); - end if; - end if; - end if; - - if C2 = F2 then - Add ('('); - - if F2 = L2 then - Add ("0 .. 0 => "); - end if; - - else - Add (' '); - end if; - - Add (S); - - if C2 = L2 then - Add (')'); - - if F1 > L1 then - Add (';'); - Flush; - - elsif C1 /= L1 then - Add (','); - Flush; - - else - Add (')'); - Add (';'); - Flush; - end if; - - else - Add (','); - end if; - end Put; - - --------------- - -- Put_Edges -- - --------------- - - procedure Put_Edges (File : File_Descriptor; Title : String) is - E : Edge_Type; - F1 : constant Natural := 1; - L1 : constant Natural := Edges_Len - 1; - M : constant Natural := Max / 5; - - begin - Put (File, Title); - New_Line (File); - - -- Edges valid range is 1 .. Edge_Len - 1 - - for J in F1 .. L1 loop - E := Get_Edges (J); - Put (File, Image (J, M), F1, L1, J, 1, 4, 1); - Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2); - Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3); - Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4); - end loop; - end Put_Edges; - - ---------------------- - -- Put_Initial_Keys -- - ---------------------- - - procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is - F1 : constant Natural := 0; - L1 : constant Natural := NK - 1; - M : constant Natural := Max / 5; - K : Key_Type; - - begin - Put (File, Title); - New_Line (File); - - for J in F1 .. L1 loop - K := Get_Key (J); - Put (File, Image (J, M), F1, L1, J, 1, 3, 1); - Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), - F1, L1, J, 1, 3, 3); - end loop; - end Put_Initial_Keys; - - -------------------- - -- Put_Int_Matrix -- - -------------------- - - procedure Put_Int_Matrix - (File : File_Descriptor; - Title : String; - Table : Integer; - Len_1 : Natural; - Len_2 : Natural) - is - F1 : constant Integer := 0; - L1 : constant Integer := Len_1 - 1; - F2 : constant Integer := 0; - L2 : constant Integer := Len_2 - 1; - Ix : Natural; - - begin - Put (File, Title); - New_Line (File); - - if Len_2 = 0 then - for J in F1 .. L1 loop - Ix := IT.Table (Table + J); - Put (File, Image (Ix), 1, 0, 1, F1, L1, J); - end loop; - - else - for J in F1 .. L1 loop - for K in F2 .. L2 loop - Ix := IT.Table (Table + J + K * Len_1); - Put (File, Image (Ix), F1, L1, J, F2, L2, K); - end loop; - end loop; - end if; - end Put_Int_Matrix; - - -------------------- - -- Put_Int_Vector -- - -------------------- - - procedure Put_Int_Vector - (File : File_Descriptor; - Title : String; - Vector : Integer; - Length : Natural) - is - F2 : constant Natural := 0; - L2 : constant Natural := Length - 1; - - begin - Put (File, Title); - New_Line (File); - - for J in F2 .. L2 loop - Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J); - end loop; - end Put_Int_Vector; - - ---------------------- - -- Put_Reduced_Keys -- - ---------------------- - - procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is - F1 : constant Natural := 0; - L1 : constant Natural := NK - 1; - M : constant Natural := Max / 5; - K : Key_Type; - - begin - Put (File, Title); - New_Line (File); - - for J in F1 .. L1 loop - K := Get_Key (J); - Put (File, Image (J, M), F1, L1, J, 1, 3, 1); - Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); - Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), - F1, L1, J, 1, 3, 3); - end loop; - end Put_Reduced_Keys; - - ----------------------- - -- Put_Used_Char_Set -- - ----------------------- - - procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is - F : constant Natural := Character'Pos (Character'First); - L : constant Natural := Character'Pos (Character'Last); - - begin - Put (File, Title); - New_Line (File); - - for J in Character'Range loop - Put - (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J)); - end loop; - end Put_Used_Char_Set; - - ---------------------- - -- Put_Vertex_Table -- - ---------------------- - - procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is - F1 : constant Natural := 0; - L1 : constant Natural := NV - 1; - M : constant Natural := Max / 4; - V : Vertex_Type; - - begin - Put (File, Title); - New_Line (File); - - for J in F1 .. L1 loop - V := Get_Vertices (J); - Put (File, Image (J, M), F1, L1, J, 1, 3, 1); - Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2); - Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3); - end loop; - end Put_Vertex_Table; - - ------------ - -- Random -- - ------------ - - procedure Random (Seed : in out Natural) is - - -- Park & Miller Standard Minimal using Schrage's algorithm to avoid - -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1) - - R : Natural; - Q : Natural; - X : Integer; - - begin - R := Seed mod 127773; - Q := Seed / 127773; - X := 16807 * R - 2836 * Q; - - Seed := (if X < 0 then X + 2147483647 else X); - end Random; - - ------------- - -- Reduced -- - ------------- - - function Reduced (K : Key_Id) return Word_Id is - begin - return K + NK + 1; - end Reduced; - - ----------------- - -- Resize_Word -- - ----------------- - - procedure Resize_Word (W : in out Word_Type; Len : Natural) is - S1 : constant String := W.all; - S2 : String (1 .. Len) := (others => ASCII.NUL); - L : constant Natural := S1'Length; - begin - if L /= Len then - Free_Word (W); - S2 (1 .. L) := S1; - W := New_Word (S2); - end if; - end Resize_Word; - - -------------------------- - -- Select_Char_Position -- - -------------------------- - - procedure Select_Char_Position is - - type Vertex_Table_Type is array (Natural range <>) of Vertex_Type; - - procedure Build_Identical_Keys_Sets - (Table : in out Vertex_Table_Type; - Last : in out Natural; - Pos : Natural); - -- Build a list of keys subsets that are identical with the current - -- position selection plus Pos. Once this routine is called, reduced - -- words are sorted by subsets and each item (First, Last) in Sets - -- defines the range of identical keys. - -- Need comment saying exactly what Last is ??? - - function Count_Different_Keys - (Table : Vertex_Table_Type; - Last : Natural; - Pos : Natural) return Natural; - -- For each subset in Sets, count the number of different keys if we add - -- Pos to the current position selection. - - Sel_Position : IT.Table_Type (1 .. Max_Key_Len); - Last_Sel_Pos : Natural := 0; - Max_Sel_Pos : Natural := 0; - - ------------------------------- - -- Build_Identical_Keys_Sets -- - ------------------------------- - - procedure Build_Identical_Keys_Sets - (Table : in out Vertex_Table_Type; - Last : in out Natural; - Pos : Natural) - is - S : constant Vertex_Table_Type := Table (Table'First .. Last); - C : constant Natural := Pos; - -- Shortcuts (why are these not renames ???) - - F : Integer; - L : Integer; - -- First and last words of a subset - - Offset : Natural; - -- GNAT.Heap_Sort assumes that the first array index is 1. Offset - -- defines the translation to operate. - - function Lt (L, R : Natural) return Boolean; - procedure Move (From : Natural; To : Natural); - -- Subprograms needed by GNAT.Heap_Sort_G - - -------- - -- Lt -- - -------- - - function Lt (L, R : Natural) return Boolean is - C : constant Natural := Pos; - Left : Natural; - Right : Natural; - - begin - if L = 0 then - Left := NK; - Right := Offset + R; - elsif R = 0 then - Left := Offset + L; - Right := NK; - else - Left := Offset + L; - Right := Offset + R; - end if; - - return WT.Table (Left)(C) < WT.Table (Right)(C); - end Lt; - - ---------- - -- Move -- - ---------- - - procedure Move (From : Natural; To : Natural) is - Target, Source : Natural; - - begin - if From = 0 then - Source := NK; - Target := Offset + To; - elsif To = 0 then - Source := Offset + From; - Target := NK; - else - Source := Offset + From; - Target := Offset + To; - end if; - - WT.Table (Target) := WT.Table (Source); - WT.Table (Source) := null; - end Move; - - package Sorting is new GNAT.Heap_Sort_G (Move, Lt); - - -- Start of processing for Build_Identical_Key_Sets - - begin - Last := 0; - - -- For each subset in S, extract the new subsets we have by adding C - -- in the position selection. - - for J in S'Range loop - if S (J).First = S (J).Last then - F := S (J).First; - L := S (J).Last; - Last := Last + 1; - Table (Last) := (F, L); - - else - Offset := Reduced (S (J).First) - 1; - Sorting.Sort (S (J).Last - S (J).First + 1); - - F := S (J).First; - L := F; - for N in S (J).First .. S (J).Last loop - - -- For the last item, close the last subset - - if N = S (J).Last then - Last := Last + 1; - Table (Last) := (F, N); - - -- Two contiguous words are identical when they have the - -- same Cth character. - - elsif WT.Table (Reduced (N))(C) = - WT.Table (Reduced (N + 1))(C) - then - L := N + 1; - - -- Find a new subset of identical keys. Store the current - -- one and create a new subset. - - else - Last := Last + 1; - Table (Last) := (F, L); - F := N + 1; - L := F; - end if; - end loop; - end if; - end loop; - end Build_Identical_Keys_Sets; - - -------------------------- - -- Count_Different_Keys -- - -------------------------- - - function Count_Different_Keys - (Table : Vertex_Table_Type; - Last : Natural; - Pos : Natural) return Natural - is - N : array (Character) of Natural; - C : Character; - T : Natural := 0; - - begin - -- For each subset, count the number of words that are still - -- different when we include Pos in the position selection. Only - -- focus on this position as the other positions already produce - -- identical keys. - - for S in 1 .. Last loop - - -- Count the occurrences of the different characters - - N := (others => 0); - for K in Table (S).First .. Table (S).Last loop - C := WT.Table (Reduced (K))(Pos); - N (C) := N (C) + 1; - end loop; - - -- Update the number of different keys. Each character used - -- denotes a different key. - - for J in N'Range loop - if N (J) > 0 then - T := T + 1; - end if; - end loop; - end loop; - - return T; - end Count_Different_Keys; - - -- Start of processing for Select_Char_Position - - begin - -- Initialize the reduced words set - - for K in 0 .. NK - 1 loop - WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all); - end loop; - - declare - Differences : Natural; - Max_Differences : Natural := 0; - Old_Differences : Natural; - Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning - Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning - Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK); - Same_Keys_Sets_Last : Natural := 1; - - begin - for C in Sel_Position'Range loop - Sel_Position (C) := C; - end loop; - - Same_Keys_Sets_Table (1) := (0, NK - 1); - - loop - -- Preserve maximum number of different keys and check later on - -- that this value is strictly incrementing. Otherwise, it means - -- that two keys are strictly identical. - - Old_Differences := Max_Differences; - - -- The first position should not exceed the minimum key length. - -- Otherwise, we may end up with an empty word once reduced. - - Max_Sel_Pos := - (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len); - - -- Find which position increases more the number of differences - - for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop - Differences := Count_Different_Keys - (Same_Keys_Sets_Table, - Same_Keys_Sets_Last, - Sel_Position (J)); - - if Verbose then - Put (Output, - "Selecting position" & Sel_Position (J)'Img & - " results in" & Differences'Img & - " differences"); - New_Line (Output); - end if; - - if Differences > Max_Differences then - Max_Differences := Differences; - Max_Diff_Sel_Pos := Sel_Position (J); - Max_Diff_Sel_Pos_Idx := J; - end if; - end loop; - - if Old_Differences = Max_Differences then - raise Program_Error with "some keys are identical"; - end if; - - -- Insert selected position and sort Sel_Position table - - Last_Sel_Pos := Last_Sel_Pos + 1; - Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) := - Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1); - Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos; - - for P in 1 .. Last_Sel_Pos - 1 loop - if Max_Diff_Sel_Pos < Sel_Position (P) then - Sel_Position (P + 1 .. Last_Sel_Pos) := - Sel_Position (P .. Last_Sel_Pos - 1); - Sel_Position (P) := Max_Diff_Sel_Pos; - exit; - end if; - end loop; - - exit when Max_Differences = NK; - - Build_Identical_Keys_Sets - (Same_Keys_Sets_Table, - Same_Keys_Sets_Last, - Max_Diff_Sel_Pos); - - if Verbose then - Put (Output, - "Selecting position" & Max_Diff_Sel_Pos'Img & - " results in" & Max_Differences'Img & - " differences"); - New_Line (Output); - Put (Output, "--"); - New_Line (Output); - for J in 1 .. Same_Keys_Sets_Last loop - for K in - Same_Keys_Sets_Table (J).First .. - Same_Keys_Sets_Table (J).Last - loop - Put (Output, - Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); - New_Line (Output); - end loop; - Put (Output, "--"); - New_Line (Output); - end loop; - end if; - end loop; - end; - - Char_Pos_Set_Len := Last_Sel_Pos; - Char_Pos_Set := Allocate (Char_Pos_Set_Len); - - for C in 1 .. Last_Sel_Pos loop - Set_Char_Pos (C - 1, Sel_Position (C)); - end loop; - end Select_Char_Position; - - -------------------------- - -- Select_Character_Set -- - -------------------------- - - procedure Select_Character_Set is - Last : Natural := 0; - Used : array (Character) of Boolean := (others => False); - Char : Character; - - begin - for J in 0 .. NK - 1 loop - for K in 0 .. Char_Pos_Set_Len - 1 loop - Char := WT.Table (Initial (J))(Get_Char_Pos (K)); - exit when Char = ASCII.NUL; - Used (Char) := True; - end loop; - end loop; - - Used_Char_Set_Len := 256; - Used_Char_Set := Allocate (Used_Char_Set_Len); - - for J in Used'Range loop - if Used (J) then - Set_Used_Char (J, Last); - Last := Last + 1; - else - Set_Used_Char (J, 0); - end if; - end loop; - end Select_Character_Set; - - ------------------ - -- Set_Char_Pos -- - ------------------ - - procedure Set_Char_Pos (P : Natural; Item : Natural) is - N : constant Natural := Char_Pos_Set + P; - begin - IT.Table (N) := Item; - end Set_Char_Pos; - - --------------- - -- Set_Edges -- - --------------- - - procedure Set_Edges (F : Natural; Item : Edge_Type) is - N : constant Natural := Edges + (F * Edge_Size); - begin - IT.Table (N) := Item.X; - IT.Table (N + 1) := Item.Y; - IT.Table (N + 2) := Item.Key; - end Set_Edges; - - --------------- - -- Set_Graph -- - --------------- - - procedure Set_Graph (N : Natural; Item : Integer) is - begin - IT.Table (G + N) := Item; - end Set_Graph; - - ------------- - -- Set_Key -- - ------------- - - procedure Set_Key (N : Key_Id; Item : Key_Type) is - begin - IT.Table (Keys + N) := Item.Edge; - end Set_Key; - - --------------- - -- Set_Table -- - --------------- - - procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is - N : constant Natural := T + ((Y * T1_Len) + X); - begin - IT.Table (N) := Item; - end Set_Table; - - ------------------- - -- Set_Used_Char -- - ------------------- - - procedure Set_Used_Char (C : Character; Item : Natural) is - N : constant Natural := Used_Char_Set + Character'Pos (C); - begin - IT.Table (N) := Item; - end Set_Used_Char; - - ------------------ - -- Set_Vertices -- - ------------------ - - procedure Set_Vertices (F : Natural; Item : Vertex_Type) is - N : constant Natural := Vertices + (F * Vertex_Size); - begin - IT.Table (N) := Item.First; - IT.Table (N + 1) := Item.Last; - end Set_Vertices; - - --------- - -- Sum -- - --------- - - function Sum - (Word : Word_Type; - Table : Table_Id; - Opt : Optimization) return Natural - is - S : Natural := 0; - R : Natural; - - begin - case Opt is - when CPU_Time => - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); - S := (S + R) mod NV; - end loop; - - when Memory_Space => - for J in 0 .. T1_Len - 1 loop - exit when Word (J + 1) = ASCII.NUL; - R := Get_Table (Table, J, 0); - S := (S + R * Character'Pos (Word (J + 1))) mod NV; - end loop; - end case; - - return S; - end Sum; - - ------------------------ - -- Trim_Trailing_Nuls -- - ------------------------ - - function Trim_Trailing_Nuls (Str : String) return String is - begin - for J in reverse Str'Range loop - if Str (J) /= ASCII.NUL then - return Str (Str'First .. J); - end if; - end loop; - - return Str; - end Trim_Trailing_Nuls; - - --------------- - -- Type_Size -- - --------------- - - function Type_Size (L : Natural) return Natural is - begin - if L <= 2 ** 8 then - return 8; - elsif L <= 2 ** 16 then - return 16; - else - return 32; - end if; - end Type_Size; - - ----------- - -- Value -- - ----------- - - function Value - (Name : Table_Name; - J : Natural; - K : Natural := 0) return Natural - is - begin - case Name is - when Character_Position => - return Get_Char_Pos (J); - - when Used_Character_Set => - return Get_Used_Char (Character'Val (J)); - - when Function_Table_1 => - return Get_Table (T1, J, K); - - when Function_Table_2 => - return Get_Table (T2, J, K); - - when Graph_Table => - return Get_Graph (J); - end case; - end Value; - -end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/g-pehage.ads b/gcc/ada/g-pehage.ads deleted file mode 100644 index 67875a6..0000000 --- a/gcc/ada/g-pehage.ads +++ /dev/null @@ -1,238 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 generator of static minimal perfect hash functions. --- To understand what a perfect hash function is, we define several notions. --- These definitions are inspired from the following paper: - --- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal --- Algorithm for Generating Minimal Perfect Hash Functions'', Information --- Processing Letters, 43(1992) pp.257-264, Oct.1992 - --- Let W be a set of m words. A hash function h is a function that maps the --- set of words W into some given interval I of integers [0, k-1], where k is --- an integer, usually k >= m. h (w) where w is a word in W computes an --- address or an integer from I for the storage or the retrieval of that --- item. The storage area used to store items is known as a hash table. Words --- for which the same address is computed are called synonyms. Due to the --- existence of synonyms a situation called collision may arise in which two --- items w1 and w2 have the same address. Several schemes for resolving --- collisions are known. A perfect hash function is an injection from the word --- set W to the integer interval I with k >= m. If k = m, then h is a minimal --- perfect hash function. A hash function is order preserving if it puts --- entries into the hash table in a prespecified order. - --- A minimal perfect hash function is defined by two properties: - --- Since no collisions occur each item can be retrieved from the table in --- *one* probe. This represents the "perfect" property. - --- The hash table size corresponds to the exact size of W and *no larger*. --- This represents the "minimal" property. - --- The functions generated by this package require the words to be known in --- advance (they are "static" hash functions). The hash functions are also --- order preserving. If w2 is inserted after w1 in the generator, then h (w1) --- < h (w2). These hashing functions are convenient for use with realtime --- applications. - -package GNAT.Perfect_Hash_Generators is - - Default_K_To_V : constant Float := 2.05; - -- Default ratio for the algorithm. When K is the number of keys, V = - -- (K_To_V) * K is the size of the main table of the hash function. To - -- converge, the algorithm requires K_To_V to be strictly greater than 2.0. - - Default_Pkg_Name : constant String := "Perfect_Hash"; - -- Default package name in which the hash function is defined - - Default_Position : constant String := ""; - -- The generator allows selection of the character positions used in the - -- hash function. By default, all positions are selected. - - Default_Tries : constant Positive := 20; - -- This algorithm may not succeed to find a possible mapping on the first - -- try and may have to iterate a number of times. This constant bounds the - -- number of tries. - - type Optimization is (Memory_Space, CPU_Time); - -- Optimize either the memory space or the execution time. Note: in - -- practice, the optimization mode has little effect on speed. The tables - -- are somewhat smaller with Memory_Space. - - Verbose : Boolean := False; - -- Output the status of the algorithm. For instance, the tables, the random - -- graph (edges, vertices) and selected char positions are output between - -- two iterations. - - procedure Initialize - (Seed : Natural; - K_To_V : Float := Default_K_To_V; - Optim : Optimization := Memory_Space; - Tries : Positive := Default_Tries); - -- Initialize the generator and its internal structures. Set the ratio of - -- vertices over keys in the random graphs. This value has to be greater - -- than 2.0 in order for the algorithm to succeed. The word set is not - -- modified (in particular when it is already set). For instance, it is - -- possible to run several times the generator with different settings on - -- the same words. - -- - -- A classical way of doing is to Insert all the words and then to invoke - -- Initialize and Compute. If Compute fails to find a perfect hash - -- function, invoke Initialize another time with other configuration - -- parameters (probably with a greater K_To_V ratio). Once successful, - -- invoke Produce and Finalize. - - procedure Finalize; - -- Deallocate the internal structures and the words table - - procedure Insert (Value : String); - -- Insert a new word into the table. ASCII.NUL characters are not allowed. - - Too_Many_Tries : exception; - -- Raised after Tries unsuccessful runs - - procedure Compute (Position : String := Default_Position); - -- Compute the hash function. Position allows the definition of selection - -- of character positions used in the word hash function. Positions can be - -- separated by commas and ranges like x-y may be used. Character '$' - -- represents the final character of a word. With an empty position, the - -- generator automatically produces positions to reduce the memory usage. - -- Raise Too_Many_Tries if the algorithm does not succeed within Tries - -- attempts (see Initialize). - - procedure Produce - (Pkg_Name : String := Default_Pkg_Name; - Use_Stdout : Boolean := False); - -- Generate the hash function package Pkg_Name. This package includes the - -- minimal perfect Hash function. The output is normally placed in the - -- current directory, in files X.ads and X.adb, where X is the standard - -- GNAT file name for a package named Pkg_Name. If Use_Stdout is True, the - -- output goes to standard output, and no files are written. - - ---------------------------------------------------------------- - - -- The routines and structures defined below allow producing the hash - -- function using a different way from the procedure above. The procedure - -- Define returns the lengths of an internal table and its item type size. - -- The function Value returns the value of each item in the table. - - -- The hash function has the following form: - - -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m - - -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the - -- number of keys. n is an internally computed value and it can be obtained - -- as the length of vector G. - - -- F1 and F2 are two functions based on two function tables T1 and T2. - -- Their definition depends on the chosen optimization mode. - - -- Only some character positions are used in the words because they are - -- significant. They are listed in a character position table (P in the - -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun", - -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are - -- significant (the first character can be ignored). In this example, P = - -- {2, 3} - - -- When Optimization is CPU_Time, the first dimension of T1 and T2 - -- corresponds to the character position in the word and the second to the - -- character set. As all the character set is not used, we define a used - -- character table which associates a distinct index to each used character - -- (unused characters are mapped to zero). In this case, the second - -- dimension of T1 and T2 is reduced to the used character set (C in the - -- pseudo-code below). Therefore, the hash function has the following: - - -- function Hash (S : String) return Natural is - -- F : constant Natural := S'First - 1; - -- L : constant Natural := S'Length; - -- F1, F2 : Natural := 0; - -- J : ; - - -- begin - -- for K in P'Range loop - -- exit when L < P (K); - -- J := C (S (P (K) + F)); - -- F1 := (F1 + Natural (T1 (K, J))) mod ; - -- F2 := (F2 + Natural (T2 (K, J))) mod ; - -- end loop; - - -- return (Natural (G (F1)) + Natural (G (F2))) mod ; - -- end Hash; - - -- When Optimization is Memory_Space, the first dimension of T1 and T2 - -- corresponds to the character position in the word and the second - -- dimension is ignored. T1 and T2 are no longer matrices but vectors. - -- Therefore, the used character table is not available. The hash function - -- has the following form: - - -- function Hash (S : String) return Natural is - -- F : constant Natural := S'First - 1; - -- L : constant Natural := S'Length; - -- F1, F2 : Natural := 0; - -- J : ; - - -- begin - -- for K in P'Range loop - -- exit when L < P (K); - -- J := Character'Pos (S (P (K) + F)); - -- F1 := (F1 + Natural (T1 (K) * J)) mod ; - -- F2 := (F2 + Natural (T2 (K) * J)) mod ; - -- end loop; - - -- return (Natural (G (F1)) + Natural (G (F2))) mod ; - -- end Hash; - - type Table_Name is - (Character_Position, - Used_Character_Set, - Function_Table_1, - Function_Table_2, - Graph_Table); - - procedure Define - (Name : Table_Name; - Item_Size : out Natural; - Length_1 : out Natural; - Length_2 : out Natural); - -- Return the definition of the table Name. This includes the length of - -- dimensions 1 and 2 and the size of an unsigned integer item. When - -- Length_2 is zero, the table has only one dimension. All the ranges - -- start from zero. - - function Value - (Name : Table_Name; - J : Natural; - K : Natural := 0) return Natural; - -- Return the value of the component (I, J) of the table Name. When the - -- table has only one dimension, J is ignored. - -end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/g-rannum.adb b/gcc/ada/g-rannum.adb deleted file mode 100644 index 3e802ee..0000000 --- a/gcc/ada/g-rannum.adb +++ /dev/null @@ -1,344 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . R A N D O M _ N U M B E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Long_Elementary_Functions; -use Ada.Numerics.Long_Elementary_Functions; -with Ada.Unchecked_Conversion; - -with System.Random_Numbers; use System.Random_Numbers; - -package body GNAT.Random_Numbers with - SPARK_Mode => Off -is - Sys_Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; - - subtype Image_String is String (1 .. Max_Image_Width); - - -- Utility function declarations - - procedure Insert_Image - (S : in out Image_String; - Index : Integer; - V : Integer_64); - -- Insert string representation of V in S starting at position Index - - --------------- - -- To_Signed -- - --------------- - - function To_Signed is - new Ada.Unchecked_Conversion (Unsigned_32, Integer_32); - function To_Signed is - new Ada.Unchecked_Conversion (Unsigned_64, Integer_64); - - ------------------ - -- Insert_Image -- - ------------------ - - procedure Insert_Image - (S : in out Image_String; - Index : Integer; - V : Integer_64) - is - Image : constant String := Integer_64'Image (V); - begin - S (Index .. Index + Image'Length - 1) := Image; - end Insert_Image; - - --------------------- - -- Random_Discrete -- - --------------------- - - function Random_Discrete - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype - is - function F is - new System.Random_Numbers.Random_Discrete - (Result_Subtype, Default_Min); - begin - return F (Gen.Rep, Min, Max); - end Random_Discrete; - - -------------------------- - -- Random_Decimal_Fixed -- - -------------------------- - - function Random_Decimal_Fixed - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype - is - subtype IntV is Integer_64 range - Integer_64'Integer_Value (Min) .. - Integer_64'Integer_Value (Max); - function R is new Random_Discrete (Integer_64, IntV'First); - begin - return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); - end Random_Decimal_Fixed; - - --------------------------- - -- Random_Ordinary_Fixed -- - --------------------------- - - function Random_Ordinary_Fixed - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype - is - subtype IntV is Integer_64 range - Integer_64'Integer_Value (Min) .. - Integer_64'Integer_Value (Max); - function R is new Random_Discrete (Integer_64, IntV'First); - begin - return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); - end Random_Ordinary_Fixed; - - ------------ - -- Random -- - ------------ - - function Random (Gen : Generator) return Float is - begin - return Random (Gen.Rep); - end Random; - - function Random (Gen : Generator) return Long_Float is - begin - return Random (Gen.Rep); - end Random; - - function Random (Gen : Generator) return Interfaces.Unsigned_32 is - begin - return Random (Gen.Rep); - end Random; - - function Random (Gen : Generator) return Interfaces.Unsigned_64 is - begin - return Random (Gen.Rep); - end Random; - - function Random (Gen : Generator) return Integer_64 is - begin - return To_Signed (Unsigned_64'(Random (Gen))); - end Random; - - function Random (Gen : Generator) return Integer_32 is - begin - return To_Signed (Unsigned_32'(Random (Gen))); - end Random; - - function Random (Gen : Generator) return Long_Integer is - function Random_Long_Integer is new Random_Discrete (Long_Integer); - begin - return Random_Long_Integer (Gen); - end Random; - - function Random (Gen : Generator) return Integer is - function Random_Integer is new Random_Discrete (Integer); - begin - return Random_Integer (Gen); - end Random; - - ------------------ - -- Random_Float -- - ------------------ - - function Random_Float (Gen : Generator) return Result_Subtype is - function F is new System.Random_Numbers.Random_Float (Result_Subtype); - begin - return F (Gen.Rep); - end Random_Float; - - --------------------- - -- Random_Gaussian -- - --------------------- - - -- Generates pairs of normally distributed values using the polar method of - -- G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The - -- Art of Computer Programming, Vol 2: Seminumerical Algorithms, section - -- 3.4.1, subsection C, algorithm P. Returns half of the pair on each call, - -- using the Next_Gaussian field of Gen to hold the second member on - -- even-numbered calls. - - function Random_Gaussian (Gen : Generator) return Long_Float is - G : Generator renames Gen'Unrestricted_Access.all; - - V1, V2, Rad2, Mult : Long_Float; - - begin - if G.Have_Gaussian then - G.Have_Gaussian := False; - return G.Next_Gaussian; - - else - loop - V1 := 2.0 * Random (G) - 1.0; - V2 := 2.0 * Random (G) - 1.0; - Rad2 := V1 ** 2 + V2 ** 2; - exit when Rad2 < 1.0 and then Rad2 /= 0.0; - end loop; - - -- Now V1 and V2 are coordinates in the unit circle - - Mult := Sqrt (-2.0 * Log (Rad2) / Rad2); - G.Next_Gaussian := V2 * Mult; - G.Have_Gaussian := True; - return Long_Float'Machine (V1 * Mult); - end if; - end Random_Gaussian; - - function Random_Gaussian (Gen : Generator) return Float is - V : constant Long_Float := Random_Gaussian (Gen); - begin - return Float'Machine (Float (V)); - end Random_Gaussian; - - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : out Generator) is - begin - Reset (Gen.Rep); - Gen.Have_Gaussian := False; - end Reset; - - procedure Reset - (Gen : out Generator; - Initiator : Initialization_Vector) - is - begin - Reset (Gen.Rep, Initiator); - Gen.Have_Gaussian := False; - end Reset; - - procedure Reset - (Gen : out Generator; - Initiator : Interfaces.Integer_32) - is - begin - Reset (Gen.Rep, Initiator); - Gen.Have_Gaussian := False; - end Reset; - - procedure Reset - (Gen : out Generator; - Initiator : Interfaces.Unsigned_32) - is - begin - Reset (Gen.Rep, Initiator); - Gen.Have_Gaussian := False; - end Reset; - - procedure Reset - (Gen : out Generator; - Initiator : Integer) - is - begin - Reset (Gen.Rep, Initiator); - Gen.Have_Gaussian := False; - end Reset; - - procedure Reset - (Gen : out Generator; - From_State : Generator) - is - begin - Reset (Gen.Rep, From_State.Rep); - Gen.Have_Gaussian := From_State.Have_Gaussian; - Gen.Next_Gaussian := From_State.Next_Gaussian; - end Reset; - - Frac_Scale : constant Long_Float := - Long_Float - (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa; - - function Val64 (Image : String) return Integer_64; - -- Renames Integer64'Value - -- We cannot use a 'renames Integer64'Value' since for some strange - -- reason, this requires a dependency on s-auxdec.ads which not all - -- run-times support ??? - - function Val64 (Image : String) return Integer_64 is - begin - return Integer_64'Value (Image); - end Val64; - - procedure Reset - (Gen : out Generator; - From_Image : String) - is - F0 : constant Integer := From_Image'First; - T0 : constant Integer := From_Image'First + Sys_Max_Image_Width; - - begin - Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width)); - - if From_Image (T0 + 1) = '1' then - Gen.Have_Gaussian := True; - Gen.Next_Gaussian := - Long_Float (Val64 (From_Image (T0 + 3 .. T0 + 23))) / Frac_Scale - * Long_Float (Long_Float'Machine_Radix) - ** Integer (Val64 (From_Image (T0 + 25 .. From_Image'Last))); - else - Gen.Have_Gaussian := False; - end if; - end Reset; - - ----------- - -- Image -- - ----------- - - function Image (Gen : Generator) return String is - Result : Image_String; - - begin - Result := (others => ' '); - Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep); - - if Gen.Have_Gaussian then - Result (Sys_Max_Image_Width + 2) := '1'; - Insert_Image (Result, Sys_Max_Image_Width + 4, - Integer_64 (Long_Float'Fraction (Gen.Next_Gaussian) - * Frac_Scale)); - Insert_Image (Result, Sys_Max_Image_Width + 24, - Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian))); - - else - Result (Sys_Max_Image_Width + 2) := '0'; - end if; - - return Result; - end Image; - -end GNAT.Random_Numbers; diff --git a/gcc/ada/g-rannum.ads b/gcc/ada/g-rannum.ads deleted file mode 100644 index cf2889c..0000000 --- a/gcc/ada/g-rannum.ads +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . R A N D O M _ N U M B E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Extended pseudo-random number generation - --- This package provides a type representing pseudo-random number generators, --- and subprograms to extract various distributions of numbers from them. It --- also provides types for representing initialization values and snapshots of --- internal generator state, which permit reproducible pseudo-random streams. - --- The generator currently provided by this package has an extremely long --- period (at least 2**19937-1), and passes the Big Crush test suite, with the --- exception of the two linear complexity tests. Therefore, it is suitable for --- simulations, but should not be used as a cryptographic pseudo-random source --- without additional processing. - --- The design of this package effects is simplified compared to the design --- of standard Ada.Numerics packages. There is no separate State type; the --- Generator type itself suffices for this purpose. The parameter modes on --- Reset procedures better reflect the effect of these routines. - --- Note: this package is marked SPARK_Mode Off, because functions Random work --- by side-effect to change the value of the generator, hence they should not --- be called from SPARK code. - -with System.Random_Numbers; -with Interfaces; use Interfaces; - -package GNAT.Random_Numbers with - SPARK_Mode => Off -is - type Generator is limited private; - subtype Initialization_Vector is - System.Random_Numbers.Initialization_Vector; - - function Random (Gen : Generator) return Float; - function Random (Gen : Generator) return Long_Float; - -- Return pseudo-random numbers uniformly distributed on [0 .. 1) - - function Random (Gen : Generator) return Interfaces.Integer_32; - function Random (Gen : Generator) return Interfaces.Unsigned_32; - function Random (Gen : Generator) return Interfaces.Integer_64; - function Random (Gen : Generator) return Interfaces.Unsigned_64; - function Random (Gen : Generator) return Integer; - function Random (Gen : Generator) return Long_Integer; - -- Return pseudo-random numbers uniformly distributed on T'First .. T'Last - -- for various builtin integer types. - - generic - type Result_Subtype is (<>); - Default_Min : Result_Subtype := Result_Subtype'Val (0); - function Random_Discrete - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; - -- Returns pseudo-random numbers uniformly distributed on Min .. Max - - generic - type Result_Subtype is delta <>; - Default_Min : Result_Subtype := 0.0; - function Random_Ordinary_Fixed - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; - -- Returns pseudo-random numbers uniformly distributed on Min .. Max - - generic - type Result_Subtype is delta <> digits <>; - Default_Min : Result_Subtype := 0.0; - function Random_Decimal_Fixed - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; - -- Returns pseudo-random numbers uniformly distributed on Min .. Max - - generic - type Result_Subtype is digits <>; - function Random_Float (Gen : Generator) return Result_Subtype; - -- Returns pseudo-random numbers uniformly distributed on [0.0 .. 1.0) - - function Random_Gaussian (Gen : Generator) return Long_Float; - function Random_Gaussian (Gen : Generator) return Float; - -- Returns pseudo-random numbers normally distributed value with mean 0 - -- and standard deviation 1.0. - - procedure Reset (Gen : out Generator); - -- Re-initialize the state of Gen from the time of day - - procedure Reset - (Gen : out Generator; - Initiator : Initialization_Vector); - procedure Reset - (Gen : out Generator; - Initiator : Interfaces.Integer_32); - procedure Reset - (Gen : out Generator; - Initiator : Interfaces.Unsigned_32); - procedure Reset - (Gen : out Generator; - Initiator : Integer); - -- Re-initialize Gen based on the Initiator in various ways. Identical - -- values of Initiator cause identical sequences of values. - - procedure Reset (Gen : out Generator; From_State : Generator); - -- Causes the state of Gen to be identical to that of From_State; Gen - -- and From_State will produce identical sequences of values subsequently. - - procedure Reset (Gen : out Generator; From_Image : String); - function Image (Gen : Generator) return String; - -- The call - -- Reset (Gen2, Image (Gen1)) - -- has the same effect as Reset (Gen2, Gen1); - - Max_Image_Width : constant := - System.Random_Numbers.Max_Image_Width + 2 + 20 + 5; - -- Maximum possible length of result of Image (...) - -private - - type Generator is limited record - Rep : System.Random_Numbers.Generator; - - Have_Gaussian : Boolean; - -- The algorithm used for Random_Gaussian produces deviates in - -- pairs. Have_Gaussian is true iff Random_Gaussian has returned one - -- member of the pair and Next_Gaussian contains the other. - - Next_Gaussian : Long_Float; - -- Next random deviate to be produced by Random_Gaussian, if - -- Have_Gaussian. - end record; - -end GNAT.Random_Numbers; diff --git a/gcc/ada/g-regexp.adb b/gcc/ada/g-regexp.adb deleted file mode 100644 index af24236..0000000 --- a/gcc/ada/g-regexp.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . R E G E X P -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-regexp.ads b/gcc/ada/g-regexp.ads deleted file mode 100644 index 6d5b7df..0000000 --- a/gcc/ada/g-regexp.ads +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . R E G E X P -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Simple Regular expression matching - --- This package provides a simple implementation of a regular expression --- pattern matching algorithm, using a subset of the syntax of regular --- expressions copied from familiar Unix style utilities. - --- See file s-regexp.ads for full documentation of the interface - ------------------------------------------------------------- --- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------- - --- There are three related packages that perform pattern matching functions. --- the following is an outline of these packages, to help you determine --- which is best for your needs. - --- GNAT.Regexp (files g-regexp.ads/s-regexp.ads/s-regexp.adb) --- This is a simple package providing Unix-style regular expression --- matching with the restriction that it matches entire strings. It --- is particularly useful for file name matching, and in particular --- it provides "globbing patterns" that are useful in implementing --- unix or DOS style wild card matching for file names. - --- GNAT.Regpat (files g-regpat.ads/s-regpat.ads/g-regpat.adb) --- This is a more complete implementation of Unix-style regular --- expressions, copied from the original V7 style regular expression --- library written in C by Henry Spencer. It is functionally the --- same as this library, and uses the same internal data structures --- stored in a binary compatible manner. - --- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) --- This is a completely general pattern matching package based on the --- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern --- language is modeled on context free grammars, with context sensitive --- extensions that provide full (type 0) computational capabilities. - -with System.Regexp; - -package GNAT.Regexp renames System.Regexp; diff --git a/gcc/ada/g-regist.adb b/gcc/ada/g-regist.adb deleted file mode 100644 index 4d98963..0000000 --- a/gcc/ada/g-regist.adb +++ /dev/null @@ -1,553 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . R E G I S T R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C; -with System; -with GNAT.Directory_Operations; - -package body GNAT.Registry is - - use System; - - ------------------------------ - -- Binding to the Win32 API -- - ------------------------------ - - subtype LONG is Interfaces.C.long; - subtype ULONG is Interfaces.C.unsigned_long; - subtype DWORD is ULONG; - - type PULONG is access all ULONG; - subtype PDWORD is PULONG; - subtype LPDWORD is PDWORD; - - subtype Error_Code is LONG; - - subtype REGSAM is LONG; - - type PHKEY is access all HKEY; - - ERROR_SUCCESS : constant Error_Code := 0; - - REG_SZ : constant := 1; - REG_EXPAND_SZ : constant := 2; - - function RegCloseKey (Key : HKEY) return LONG; - pragma Import (Stdcall, RegCloseKey, "RegCloseKey"); - - function RegCreateKeyEx - (Key : HKEY; - lpSubKey : Address; - Reserved : DWORD; - lpClass : Address; - dwOptions : DWORD; - samDesired : REGSAM; - lpSecurityAttributes : Address; - phkResult : PHKEY; - lpdwDisposition : LPDWORD) - return LONG; - pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA"); - - function RegDeleteKey - (Key : HKEY; - lpSubKey : Address) return LONG; - pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA"); - - function RegDeleteValue - (Key : HKEY; - lpValueName : Address) return LONG; - pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA"); - - function RegEnumValue - (Key : HKEY; - dwIndex : DWORD; - lpValueName : Address; - lpcbValueName : LPDWORD; - lpReserved : LPDWORD; - lpType : LPDWORD; - lpData : Address; - lpcbData : LPDWORD) return LONG; - pragma Import (Stdcall, RegEnumValue, "RegEnumValueA"); - - function RegOpenKeyEx - (Key : HKEY; - lpSubKey : Address; - ulOptions : DWORD; - samDesired : REGSAM; - phkResult : PHKEY) return LONG; - pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA"); - - function RegQueryValueEx - (Key : HKEY; - lpValueName : Address; - lpReserved : LPDWORD; - lpType : LPDWORD; - lpData : Address; - lpcbData : LPDWORD) return LONG; - pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA"); - - function RegSetValueEx - (Key : HKEY; - lpValueName : Address; - Reserved : DWORD; - dwType : DWORD; - lpData : Address; - cbData : DWORD) return LONG; - pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA"); - - function RegEnumKey - (Key : HKEY; - dwIndex : DWORD; - lpName : Address; - cchName : DWORD) return LONG; - pragma Import (Stdcall, RegEnumKey, "RegEnumKeyA"); - - --------------------- - -- Local Constants -- - --------------------- - - Max_Key_Size : constant := 1_024; - -- Maximum number of characters for a registry key - - Max_Value_Size : constant := 2_048; - -- Maximum number of characters for a key's value - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function To_C_Mode (Mode : Key_Mode) return REGSAM; - -- Returns the Win32 mode value for the Key_Mode value - - procedure Check_Result (Result : LONG; Message : String); - -- Checks value Result and raise the exception Registry_Error if it is not - -- equal to ERROR_SUCCESS. Message and the error value (Result) is added - -- to the exception message. - - ------------------ - -- Check_Result -- - ------------------ - - procedure Check_Result (Result : LONG; Message : String) is - use type LONG; - begin - if Result /= ERROR_SUCCESS then - raise Registry_Error with - Message & " (" & LONG'Image (Result) & ')'; - end if; - end Check_Result; - - --------------- - -- Close_Key -- - --------------- - - procedure Close_Key (Key : HKEY) is - Result : LONG; - begin - Result := RegCloseKey (Key); - Check_Result (Result, "Close_Key"); - end Close_Key; - - ---------------- - -- Create_Key -- - ---------------- - - function Create_Key - (From_Key : HKEY; - Sub_Key : String; - Mode : Key_Mode := Read_Write) return HKEY - is - use type REGSAM; - use type DWORD; - - REG_OPTION_NON_VOLATILE : constant := 16#0#; - - C_Sub_Key : constant String := Sub_Key & ASCII.NUL; - C_Class : constant String := "" & ASCII.NUL; - C_Mode : constant REGSAM := To_C_Mode (Mode); - - New_Key : aliased HKEY; - Result : LONG; - Dispos : aliased DWORD; - - begin - Result := - RegCreateKeyEx - (From_Key, - C_Sub_Key (C_Sub_Key'First)'Address, - 0, - C_Class (C_Class'First)'Address, - REG_OPTION_NON_VOLATILE, - C_Mode, - Null_Address, - New_Key'Unchecked_Access, - Dispos'Unchecked_Access); - - Check_Result (Result, "Create_Key " & Sub_Key); - return New_Key; - end Create_Key; - - ---------------- - -- Delete_Key -- - ---------------- - - procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is - C_Sub_Key : constant String := Sub_Key & ASCII.NUL; - Result : LONG; - begin - Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); - Check_Result (Result, "Delete_Key " & Sub_Key); - end Delete_Key; - - ------------------ - -- Delete_Value -- - ------------------ - - procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is - C_Sub_Key : constant String := Sub_Key & ASCII.NUL; - Result : LONG; - begin - Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); - Check_Result (Result, "Delete_Value " & Sub_Key); - end Delete_Value; - - ------------------- - -- For_Every_Key -- - ------------------- - - procedure For_Every_Key - (From_Key : HKEY; - Recursive : Boolean := False) - is - procedure Recursive_For_Every_Key - (From_Key : HKEY; - Recursive : Boolean := False; - Quit : in out Boolean); - - ----------------------------- - -- Recursive_For_Every_Key -- - ----------------------------- - - procedure Recursive_For_Every_Key - (From_Key : HKEY; - Recursive : Boolean := False; - Quit : in out Boolean) - is - use type LONG; - use type ULONG; - - Index : ULONG := 0; - Result : LONG; - - Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size); - pragma Warnings (Off, Sub_Key); - - Size_Sub_Key : aliased ULONG; - Sub_Hkey : HKEY; - - function Current_Name return String; - - ------------------ - -- Current_Name -- - ------------------ - - function Current_Name return String is - begin - return Interfaces.C.To_Ada (Sub_Key); - end Current_Name; - - -- Start of processing for Recursive_For_Every_Key - - begin - loop - Size_Sub_Key := Sub_Key'Length; - - Result := - RegEnumKey - (From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key); - - exit when not (Result = ERROR_SUCCESS); - - Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key)); - - Action (Natural (Index) + 1, Sub_Hkey, Current_Name, Quit); - - if not Quit and then Recursive then - Recursive_For_Every_Key (Sub_Hkey, True, Quit); - end if; - - Close_Key (Sub_Hkey); - - exit when Quit; - - Index := Index + 1; - end loop; - end Recursive_For_Every_Key; - - -- Local Variables - - Quit : Boolean := False; - - -- Start of processing for For_Every_Key - - begin - Recursive_For_Every_Key (From_Key, Recursive, Quit); - end For_Every_Key; - - ------------------------- - -- For_Every_Key_Value -- - ------------------------- - - procedure For_Every_Key_Value - (From_Key : HKEY; - Expand : Boolean := False) - is - use GNAT.Directory_Operations; - use type LONG; - use type ULONG; - - Index : ULONG := 0; - Result : LONG; - - Sub_Key : String (1 .. Max_Key_Size); - pragma Warnings (Off, Sub_Key); - - Value : String (1 .. Max_Value_Size); - pragma Warnings (Off, Value); - - Size_Sub_Key : aliased ULONG; - Size_Value : aliased ULONG; - Type_Sub_Key : aliased DWORD; - - Quit : Boolean; - - begin - loop - Size_Sub_Key := Sub_Key'Length; - Size_Value := Value'Length; - - Result := - RegEnumValue - (From_Key, Index, - Sub_Key (1)'Address, - Size_Sub_Key'Unchecked_Access, - null, - Type_Sub_Key'Unchecked_Access, - Value (1)'Address, - Size_Value'Unchecked_Access); - - exit when not (Result = ERROR_SUCCESS); - - Quit := False; - - if Type_Sub_Key = REG_EXPAND_SZ and then Expand then - Action - (Natural (Index) + 1, - Sub_Key (1 .. Integer (Size_Sub_Key)), - Directory_Operations.Expand_Path - (Value (1 .. Integer (Size_Value) - 1), - Directory_Operations.DOS), - Quit); - - elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then - Action - (Natural (Index) + 1, - Sub_Key (1 .. Integer (Size_Sub_Key)), - Value (1 .. Integer (Size_Value) - 1), - Quit); - end if; - - exit when Quit; - - Index := Index + 1; - end loop; - end For_Every_Key_Value; - - ---------------- - -- Key_Exists -- - ---------------- - - function Key_Exists - (From_Key : HKEY; - Sub_Key : String) return Boolean - is - New_Key : HKEY; - - begin - New_Key := Open_Key (From_Key, Sub_Key); - Close_Key (New_Key); - - -- We have been able to open the key so it exists - - return True; - - exception - when Registry_Error => - - -- An error occurred, the key was not found - - return False; - end Key_Exists; - - -------------- - -- Open_Key -- - -------------- - - function Open_Key - (From_Key : HKEY; - Sub_Key : String; - Mode : Key_Mode := Read_Only) return HKEY - is - use type REGSAM; - - C_Sub_Key : constant String := Sub_Key & ASCII.NUL; - C_Mode : constant REGSAM := To_C_Mode (Mode); - - New_Key : aliased HKEY; - Result : LONG; - - begin - Result := - RegOpenKeyEx - (From_Key, - C_Sub_Key (C_Sub_Key'First)'Address, - 0, - C_Mode, - New_Key'Unchecked_Access); - - Check_Result (Result, "Open_Key " & Sub_Key); - return New_Key; - end Open_Key; - - ----------------- - -- Query_Value -- - ----------------- - - function Query_Value - (From_Key : HKEY; - Sub_Key : String; - Expand : Boolean := False) return String - is - use GNAT.Directory_Operations; - use type LONG; - use type ULONG; - - Value : String (1 .. Max_Value_Size); - pragma Warnings (Off, Value); - - Size_Value : aliased ULONG; - Type_Value : aliased DWORD; - - C_Sub_Key : constant String := Sub_Key & ASCII.NUL; - Result : LONG; - - begin - Size_Value := Value'Length; - - Result := - RegQueryValueEx - (From_Key, - C_Sub_Key (C_Sub_Key'First)'Address, - null, - Type_Value'Unchecked_Access, - Value (Value'First)'Address, - Size_Value'Unchecked_Access); - - Check_Result (Result, "Query_Value " & Sub_Key & " key"); - - if Type_Value = REG_EXPAND_SZ and then Expand then - return Directory_Operations.Expand_Path - (Value (1 .. Integer (Size_Value - 1)), - Directory_Operations.DOS); - else - return Value (1 .. Integer (Size_Value - 1)); - end if; - end Query_Value; - - --------------- - -- Set_Value -- - --------------- - - procedure Set_Value - (From_Key : HKEY; - Sub_Key : String; - Value : String; - Expand : Boolean := False) - is - C_Sub_Key : constant String := Sub_Key & ASCII.NUL; - C_Value : constant String := Value & ASCII.NUL; - - Value_Type : DWORD; - Result : LONG; - - begin - Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ); - - Result := - RegSetValueEx - (From_Key, - C_Sub_Key (C_Sub_Key'First)'Address, - 0, - Value_Type, - C_Value (C_Value'First)'Address, - C_Value'Length); - - Check_Result (Result, "Set_Value " & Sub_Key & " key"); - end Set_Value; - - --------------- - -- To_C_Mode -- - --------------- - - function To_C_Mode (Mode : Key_Mode) return REGSAM is - use type REGSAM; - - KEY_READ : constant := 16#20019#; - KEY_WRITE : constant := 16#20006#; - KEY_WOW64_64KEY : constant := 16#00100#; - KEY_WOW64_32KEY : constant := 16#00200#; - - begin - case Mode is - when Read_Only => - return KEY_READ + KEY_WOW64_32KEY; - - when Read_Write => - return KEY_READ + KEY_WRITE + KEY_WOW64_32KEY; - - when Read_Only_64 => - return KEY_READ + KEY_WOW64_64KEY; - - when Read_Write_64 => - return KEY_READ + KEY_WRITE + KEY_WOW64_64KEY; - end case; - end To_C_Mode; - -end GNAT.Registry; diff --git a/gcc/ada/g-regist.ads b/gcc/ada/g-regist.ads deleted file mode 100644 index 0222a10..0000000 --- a/gcc/ada/g-regist.ads +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . R E G I S T R Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The registry is a Windows database to store key/value pair. It is used --- to keep Windows operation system and applications configuration options. --- The database is a hierarchal set of key and for each key a value can --- be associated. This package provides high level routines to deal with --- the Windows registry. For full registry API, but at a lower level of --- abstraction, refer to the Win32.Winreg package provided with the --- Win32Ada binding. For example this binding handle only key values of --- type Standard.String. - --- This package is specific to the NT version of GNAT, and is not available --- on any other platforms. - -package GNAT.Registry is - - type HKEY is private; - -- HKEY is a handle to a registry key, including standard registry keys: - -- HKEY_CLASSES_ROOT, HKEY_CURRENT_CONFIG, HKEY_CURRENT_USER, - -- HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA. - - HKEY_CLASSES_ROOT : constant HKEY; - HKEY_CURRENT_USER : constant HKEY; - HKEY_CURRENT_CONFIG : constant HKEY; - HKEY_LOCAL_MACHINE : constant HKEY; - HKEY_USERS : constant HKEY; - HKEY_PERFORMANCE_DATA : constant HKEY; - - type Key_Mode is - (Read_Only, Read_Write, -- operates on 32bit view of the registry - Read_Only_64, Read_Write_64); -- operates on 64bit view of the registry - -- Access mode for the registry key. The *_64 are only meaningful on - -- Windows 64bit and ignored on Windows 32bit where _64 are equivalent to - -- the non 64bit versions. - - Registry_Error : exception; - -- Registry_Error is raises by all routines below if a problem occurs - -- (key cannot be opened, key cannot be found etc). - - function Create_Key - (From_Key : HKEY; - Sub_Key : String; - Mode : Key_Mode := Read_Write) return HKEY; - -- Open or create a key (named Sub_Key) in the Windows registry database. - -- The key will be created under key From_Key. It returns the key handle. - -- From_Key must be a valid handle to an already opened key or one of - -- the standard keys identified by HKEY declarations above. - - function Open_Key - (From_Key : HKEY; - Sub_Key : String; - Mode : Key_Mode := Read_Only) return HKEY; - -- Return a registry key handle for key named Sub_Key opened under key - -- From_Key. It is possible to open a key at any level in the registry - -- tree in a single call to Open_Key. - - procedure Close_Key (Key : HKEY); - -- Close registry key handle. All resources used by Key are released - - function Key_Exists (From_Key : HKEY; Sub_Key : String) return Boolean; - -- Returns True if Sub_Key is defined under From_Key in the registry - - function Query_Value - (From_Key : HKEY; - Sub_Key : String; - Expand : Boolean := False) return String; - -- Returns the registry key's value associated with Sub_Key in From_Key - -- registry key. If Expand is set to True and the Sub_Key is a - -- REG_EXPAND_SZ the returned value will have the %name% variables - -- replaced by the corresponding environment variable value. - - procedure Set_Value - (From_Key : HKEY; - Sub_Key : String; - Value : String; - Expand : Boolean := False); - -- Add the pair (Sub_Key, Value) into From_Key registry key. - -- By default the value created is of type REG_SZ, unless - -- Expand is True in which case it is of type REG_EXPAND_SZ - - procedure Delete_Key (From_Key : HKEY; Sub_Key : String); - -- Remove Sub_Key from the registry key From_Key - - procedure Delete_Value (From_Key : HKEY; Sub_Key : String); - -- Remove the named value Sub_Key from the registry key From_Key - - generic - with procedure Action - (Index : Positive; - Key : HKEY; - Key_Name : String; - Quit : in out Boolean); - procedure For_Every_Key (From_Key : HKEY; Recursive : Boolean := False); - -- Iterates over all the keys registered under From_Key, recursively if - -- Recursive is set to True. Index will be set to 1 for the first key and - -- will be incremented by one in each iteration. The current key of an - -- iteration is set in Key, and its name - in Key_Name. Quit can be set - -- to True to stop iteration; its initial value is False. - - generic - with procedure Action - (Index : Positive; - Sub_Key : String; - Value : String; - Quit : in out Boolean); - procedure For_Every_Key_Value (From_Key : HKEY; Expand : Boolean := False); - -- Iterates over all the pairs (Sub_Key, Value) registered under - -- From_Key. Index will be set to 1 for the first key and will be - -- incremented by one in each iteration. Quit can be set to True to - -- stop iteration; its initial value is False. - -- - -- Key value that are not of type string (i.e. not REG_SZ / REG_EXPAND_SZ) - -- are skipped. In this case, the iterator behaves exactly as if the key - -- were not present. Note that you must use the Win32.Winreg API to deal - -- with this case. Furthermore, if Expand is set to True and the Sub_Key - -- is a REG_EXPAND_SZ the returned value will have the %name% variables - -- replaced by the corresponding environment variable value. - -- - -- This iterator can be used in conjunction with For_Every_Key in - -- order to analyze all subkeys and values of a given registry key. - -private - - type HKEY is mod 2 ** Standard'Address_Size; - - HKEY_CLASSES_ROOT : constant HKEY := 16#80000000#; - HKEY_CURRENT_USER : constant HKEY := 16#80000001#; - HKEY_LOCAL_MACHINE : constant HKEY := 16#80000002#; - HKEY_USERS : constant HKEY := 16#80000003#; - HKEY_PERFORMANCE_DATA : constant HKEY := 16#80000004#; - HKEY_CURRENT_CONFIG : constant HKEY := 16#80000005#; - -end GNAT.Registry; diff --git a/gcc/ada/g-regpat.adb b/gcc/ada/g-regpat.adb deleted file mode 100644 index 5e7dc76..0000000 --- a/gcc/ada/g-regpat.adb +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . R E G P A T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-regpat.ads b/gcc/ada/g-regpat.ads deleted file mode 100644 index 388dbda..0000000 --- a/gcc/ada/g-regpat.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . R E G P A T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1996-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements roughly the same set of regular expressions as --- are available in the Perl or Python programming languages. - --- This is an extension of the original V7 style regular expression library --- written in C by Henry Spencer. Apart from the translation to Ada, the --- interface has been considerably changed to use the Ada String type --- instead of C-style nul-terminated strings. - --- See file s-regpat.ads for full documentation of the interface - ------------------------------------------------------------- --- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------- - --- There are three related packages that perform pattern matching functions. --- the following is an outline of these packages, to help you determine --- which is best for your needs. - --- GNAT.Regexp (files g-regexp.ads/s-regexp.ads/s-regexp.adb) --- This is a simple package providing Unix-style regular expression --- matching with the restriction that it matches entire strings. It --- is particularly useful for file name matching, and in particular --- it provides "globbing patterns" that are useful in implementing --- unix or DOS style wild card matching for file names. - --- GNAT.Regpat (files g-regpat.ads/s-regpat.ads/s-regpat.adb) --- This is a more complete implementation of Unix-style regular --- expressions, copied from the Perl regular expression engine, --- written originally in C by Henry Spencer. It is functionally the --- same as that library. - --- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) --- This is a completely general pattern matching package based on the --- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern --- language is modeled on context free grammars, with context sensitive --- extensions that provide full (type 0) computational capabilities. - -with System.Regpat; - -package GNAT.Regpat renames System.Regpat; diff --git a/gcc/ada/g-rewdat.adb b/gcc/ada/g-rewdat.adb deleted file mode 100644 index 855f787..0000000 --- a/gcc/ada/g-rewdat.adb +++ /dev/null @@ -1,253 +0,0 @@ ------------------------------------------------------------------------------ --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . R E W R I T E _ D A T A -- --- -- --- B o d y -- --- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body GNAT.Rewrite_Data is - - use Ada; - - subtype SEO is Stream_Element_Offset; - - procedure Do_Output - (B : in out Buffer; - Data : Stream_Element_Array; - Output : not null access procedure (Data : Stream_Element_Array)); - -- Do the actual output. This ensures that we properly send the data - -- through linked rewrite buffers if any. - - ------------ - -- Create -- - ------------ - - function Create - (Pattern, Value : String; - Size : Stream_Element_Offset := 1_024) return Buffer - is - - subtype SP is String (1 .. Pattern'Length); - subtype SEAP is Stream_Element_Array (1 .. Pattern'Length); - - subtype SV is String (1 .. Value'Length); - subtype SEAV is Stream_Element_Array (1 .. Value'Length); - - function To_SEAP is new Unchecked_Conversion (SP, SEAP); - function To_SEAV is new Unchecked_Conversion (SV, SEAV); - - begin - -- Return result (can't be smaller than pattern) - - return B : Buffer - (SEO'Max (Size, SEO (Pattern'Length)), - SEO (Pattern'Length), - SEO (Value'Length)) - do - B.Pattern := To_SEAP (Pattern); - B.Value := To_SEAV (Value); - B.Pos_C := 0; - B.Pos_B := 0; - end return; - end Create; - - --------------- - -- Do_Output -- - --------------- - - procedure Do_Output - (B : in out Buffer; - Data : Stream_Element_Array; - Output : not null access procedure (Data : Stream_Element_Array)) - is - begin - if B.Next = null then - Output (Data); - else - Write (B.Next.all, Data, Output); - end if; - end Do_Output; - - ----------- - -- Flush -- - ----------- - - procedure Flush - (B : in out Buffer; - Output : not null access procedure (Data : Stream_Element_Array)) - is - begin - -- Flush output buffer - - if B.Pos_B > 0 then - Do_Output (B, B.Buffer (1 .. B.Pos_B), Output); - end if; - - -- Flush current buffer - - if B.Pos_C > 0 then - Do_Output (B, B.Current (1 .. B.Pos_C), Output); - end if; - - -- Flush linked buffer if any - - if B.Next /= null then - Flush (B.Next.all, Output); - end if; - - Reset (B); - end Flush; - - ---------- - -- Link -- - ---------- - - procedure Link (From : in out Buffer; To : Buffer_Ref) is - begin - From.Next := To; - end Link; - - ----------- - -- Reset -- - ----------- - - procedure Reset (B : in out Buffer) is - begin - B.Pos_B := 0; - B.Pos_C := 0; - - if B.Next /= null then - Reset (B.Next.all); - end if; - end Reset; - - ------------- - -- Rewrite -- - ------------- - - procedure Rewrite - (B : in out Buffer; - Input : not null access procedure - (Buffer : out Stream_Element_Array; - Last : out Stream_Element_Offset); - Output : not null access procedure (Data : Stream_Element_Array)) - is - Buffer : Stream_Element_Array (1 .. B.Size); - Last : Stream_Element_Offset; - - begin - Rewrite_All : loop - Input (Buffer, Last); - exit Rewrite_All when Last = 0; - Write (B, Buffer (1 .. Last), Output); - end loop Rewrite_All; - - Flush (B, Output); - end Rewrite; - - ---------- - -- Size -- - ---------- - - function Size (B : Buffer) return Natural is - begin - return Natural (B.Pos_B + B.Pos_C); - end Size; - - ----------- - -- Write -- - ----------- - - procedure Write - (B : in out Buffer; - Data : Stream_Element_Array; - Output : not null access procedure (Data : Stream_Element_Array)) - is - procedure Need_Space (Size : Stream_Element_Offset); - pragma Inline (Need_Space); - - ---------------- - -- Need_Space -- - ---------------- - - procedure Need_Space (Size : Stream_Element_Offset) is - begin - if B.Pos_B + Size > B.Size then - Do_Output (B, B.Buffer (1 .. B.Pos_B), Output); - B.Pos_B := 0; - end if; - end Need_Space; - - -- Start of processing for Write - - begin - if B.Size_Pattern = 0 then - Do_Output (B, Data, Output); - - else - for K in Data'Range loop - if Data (K) = B.Pattern (B.Pos_C + 1) then - - -- Store possible start of a match - - B.Pos_C := B.Pos_C + 1; - B.Current (B.Pos_C) := Data (K); - - else - -- Not part of pattern, if a start of a match was found, - -- remove it. - - if B.Pos_C /= 0 then - Need_Space (B.Pos_C); - - B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Pos_C) := - B.Current (1 .. B.Pos_C); - B.Pos_B := B.Pos_B + B.Pos_C; - B.Pos_C := 0; - end if; - - Need_Space (1); - B.Pos_B := B.Pos_B + 1; - B.Buffer (B.Pos_B) := Data (K); - end if; - - if B.Pos_C = B.Size_Pattern then - - -- The pattern is found - - Need_Space (B.Size_Value); - - B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Size_Value) := B.Value; - B.Pos_C := 0; - B.Pos_B := B.Pos_B + B.Size_Value; - end if; - end loop; - end if; - end Write; - -end GNAT.Rewrite_Data; diff --git a/gcc/ada/g-rewdat.ads b/gcc/ada/g-rewdat.ads deleted file mode 100644 index 994b3ee..0000000 --- a/gcc/ada/g-rewdat.ads +++ /dev/null @@ -1,152 +0,0 @@ ------------------------------------------------------------------------------- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . R E W R I T E _ D A T A -- --- -- --- S p e c -- --- -- --- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package can be used to rewrite data on the fly. All occurrences of a --- string (named pattern) will be replaced by another string. - --- It is not necessary to load all data in memory and so this package can be --- used for large data chunks like disk files for example. The pattern is --- a standard string and not a regular expression. - --- There is no dynamic allocation in the implementation. - --- For example, to replace all occurrences of "Gnat" with "GNAT": - --- Rewriter : Buffer := Create (Pattern => "Gnat", Value => "GNAT"); - --- The output procedure that will receive the rewritten data: - --- procedure Do (Data : Stream_Element_Array) is --- begin --- --- end Do; - --- Then: - --- Write (Rewriter, "Let's talk about Gnat compiler", Do'Access); --- Write (Rewriter, "Gnat is an Ada compiler", Do'Access); --- Flush (Rewriter, Do'Access); - --- Another possible usage is to specify a method to get the input data: - --- procedure Get --- (Buffer : out Stream_Element_Array; --- Last : out Stream_Element_Offset) --- is --- begin --- --- Last := ... --- Buffer := ... --- end Get; - --- Then we can rewrite the whole file with: - --- Rewrite (Rewriter, Input => Get'Access, Output => Do'Access); - -with Ada.Streams; use Ada.Streams; - -package GNAT.Rewrite_Data is - - type Buffer (<>) is limited private; - type Buffer_Ref is access all Buffer; - - function Create - (Pattern, Value : String; - Size : Stream_Element_Offset := 1_024) return Buffer; - -- Create a rewrite buffer. Pattern is the string to be rewritten as Value. - -- Size represents the size of the internal buffer used to store the data - -- ready to be output. A larger buffer may improve the performance, as the - -- Output routine (see Write, Rewrite below) will be called only when this - -- buffer is full. Note that Size cannot be lower than Pattern'Length, and - -- if this is the case, then Size value is set to Pattern'Length. - - function Size (B : Buffer) return Natural; - -- Returns the current size of the buffer (count of Stream_Array_Element) - - procedure Flush - (B : in out Buffer; - Output : not null access procedure (Data : Stream_Element_Array)); - -- Call Output for all remaining data in the buffer. The buffer is - -- reset and ready for another use after this call. - - procedure Reset (B : in out Buffer); - pragma Inline (Reset); - -- Clear all data in buffer, B is ready for another use. Note that this is - -- not needed after a Flush. Note: all data remaining in Buffer is lost. - - procedure Write - (B : in out Buffer; - Data : Stream_Element_Array; - Output : not null access procedure (Data : Stream_Element_Array)); - -- Write Data into the buffer, call Output for any prepared data. Flush - -- must be called when the last piece of Data as been sent in the Buffer. - - procedure Rewrite - (B : in out Buffer; - Input : not null access procedure - (Buffer : out Stream_Element_Array; - Last : out Stream_Element_Offset); - Output : not null access procedure (Data : Stream_Element_Array)); - -- Read data from Input, rewrite it, and then call Output. When there is - -- no more data to be read from Input, Last must be set to 0. Before - -- leaving this routine, call Flush above to send all remaining data to - -- Output. - - procedure Link (From : in out Buffer; To : Buffer_Ref); - -- Link two rewrite buffers. That is, all data sent to From buffer will be - -- rewritten and then passed to the To rewrite buffer. - -private - - type Buffer - (Size, Size_Pattern, Size_Value : Stream_Element_Offset) is - limited record - Pos_C : Stream_Element_Offset; -- last valid element in Current - Pos_B : Stream_Element_Offset; -- last valid element in Buffer - - Next : Buffer_Ref; - -- A link to another rewriter if any - - Buffer : Stream_Element_Array (1 .. Size); - -- Fully prepared/rewritten data waiting to be output - - Current : Stream_Element_Array (1 .. Size_Pattern); - -- Current data checked, this buffer contains every piece of data - -- starting with the pattern. It means that at any point: - -- Current (1 .. Pos_C) = Pattern (1 .. Pos_C). - - Pattern : Stream_Element_Array (1 .. Size_Pattern); - -- The pattern to look for - - Value : Stream_Element_Array (1 .. Size_Value); - -- The value the pattern is replaced by - end record; - -end GNAT.Rewrite_Data; diff --git a/gcc/ada/g-sechas.adb b/gcc/ada/g-sechas.adb deleted file mode 100644 index 59a598d..0000000 --- a/gcc/ada/g-sechas.adb +++ /dev/null @@ -1,486 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; -with Interfaces; use Interfaces; - -package body GNAT.Secure_Hashes is - - Hex_Digit : constant array (Stream_Element range 0 .. 15) of Character := - "0123456789abcdef"; - - type Fill_Buffer_Access is - access procedure - (M : in out Message_State; - S : String; - First : Natural; - Last : out Natural); - -- A procedure to transfer data from S, starting at First, into M's block - -- buffer until either the block buffer is full or all data from S has been - -- consumed. - - procedure Fill_Buffer_Copy - (M : in out Message_State; - S : String; - First : Natural; - Last : out Natural); - -- Transfer procedure which just copies data from S to M - - procedure Fill_Buffer_Swap - (M : in out Message_State; - S : String; - First : Natural; - Last : out Natural); - -- Transfer procedure which swaps bytes from S when copying into M. S must - -- have even length. Note that the swapping is performed considering pairs - -- starting at S'First, even if S'First /= First (that is, if - -- First = S'First then the first copied byte is always S (S'First + 1), - -- and if First = S'First + 1 then the first copied byte is always - -- S (S'First). - - procedure To_String (SEA : Stream_Element_Array; S : out String); - -- Return the hexadecimal representation of SEA - - ---------------------- - -- Fill_Buffer_Copy -- - ---------------------- - - procedure Fill_Buffer_Copy - (M : in out Message_State; - S : String; - First : Natural; - Last : out Natural) - is - Buf_String : String (M.Buffer'Range); - for Buf_String'Address use M.Buffer'Address; - pragma Import (Ada, Buf_String); - - Length : constant Natural := - Natural'Min (M.Block_Length - M.Last, S'Last - First + 1); - - begin - pragma Assert (Length > 0); - - Buf_String (M.Last + 1 .. M.Last + Length) := - S (First .. First + Length - 1); - M.Last := M.Last + Length; - Last := First + Length - 1; - end Fill_Buffer_Copy; - - ---------------------- - -- Fill_Buffer_Swap -- - ---------------------- - - procedure Fill_Buffer_Swap - (M : in out Message_State; - S : String; - First : Natural; - Last : out Natural) - is - pragma Assert (S'Length mod 2 = 0); - Length : constant Natural := - Natural'Min (M.Block_Length - M.Last, S'Last - First + 1); - begin - Last := First; - while Last - First < Length loop - M.Buffer (M.Last + 1 + Last - First) := - (if (Last - S'First) mod 2 = 0 - then S (Last + 1) - else S (Last - 1)); - Last := Last + 1; - end loop; - M.Last := M.Last + Length; - Last := First + Length - 1; - end Fill_Buffer_Swap; - - --------------- - -- To_String -- - --------------- - - procedure To_String (SEA : Stream_Element_Array; S : out String) is - pragma Assert (S'Length = 2 * SEA'Length); - begin - for J in SEA'Range loop - declare - S_J : constant Natural := 1 + Natural (J - SEA'First) * 2; - begin - S (S_J) := Hex_Digit (SEA (J) / 16); - S (S_J + 1) := Hex_Digit (SEA (J) mod 16); - end; - end loop; - end To_String; - - ------- - -- H -- - ------- - - package body H is - - procedure Update - (C : in out Context; - S : String; - Fill_Buffer : Fill_Buffer_Access); - -- Internal common routine for all Update procedures - - procedure Final - (C : Context; - Hash_Bits : out Ada.Streams.Stream_Element_Array); - -- Perform final hashing operations (data padding) and extract the - -- (possibly truncated) state of C into Hash_Bits. - - ------------ - -- Digest -- - ------------ - - function Digest (C : Context) return Message_Digest is - Hash_Bits : Stream_Element_Array - (1 .. Stream_Element_Offset (Hash_Length)); - begin - Final (C, Hash_Bits); - return MD : Message_Digest do - To_String (Hash_Bits, MD); - end return; - end Digest; - - function Digest (S : String) return Message_Digest is - C : Context; - begin - Update (C, S); - return Digest (C); - end Digest; - - function Digest (A : Stream_Element_Array) return Message_Digest is - C : Context; - begin - Update (C, A); - return Digest (C); - end Digest; - - function Digest (C : Context) return Binary_Message_Digest is - Hash_Bits : Stream_Element_Array - (1 .. Stream_Element_Offset (Hash_Length)); - begin - Final (C, Hash_Bits); - return Hash_Bits; - end Digest; - - function Digest (S : String) return Binary_Message_Digest is - C : Context; - begin - Update (C, S); - return Digest (C); - end Digest; - - function Digest - (A : Stream_Element_Array) return Binary_Message_Digest - is - C : Context; - begin - Update (C, A); - return Digest (C); - end Digest; - - ----------- - -- Final -- - ----------- - - -- Once a complete message has been processed, it is padded with one 1 - -- bit followed by enough 0 bits so that the last block is 2 * Word'Size - -- bits short of being completed. The last 2 * Word'Size bits are set to - -- the message size in bits (excluding padding). - - procedure Final - (C : Context; - Hash_Bits : out Stream_Element_Array) - is - FC : Context := C; - - Zeroes : Natural; - -- Number of 0 bytes in padding - - Message_Length : Unsigned_64 := FC.M_State.Length; - -- Message length in bytes - - Size_Length : constant Natural := - 2 * Hash_State.Word'Size / 8; - -- Length in bytes of the size representation - - begin - Zeroes := (Block_Length - 1 - Size_Length - FC.M_State.Last) - mod FC.M_State.Block_Length; - declare - Pad : String (1 .. 1 + Zeroes + Size_Length) := - (1 => Character'Val (128), others => ASCII.NUL); - - Index : Natural; - First_Index : Natural; - - begin - First_Index := (if Hash_Bit_Order = Low_Order_First - then Pad'Last - Size_Length + 1 - else Pad'Last); - - Index := First_Index; - while Message_Length > 0 loop - if Index = First_Index then - - -- Message_Length is in bytes, but we need to store it as - -- a bit count. - - Pad (Index) := Character'Val - (Shift_Left (Message_Length and 16#1f#, 3)); - Message_Length := Shift_Right (Message_Length, 5); - - else - Pad (Index) := Character'Val (Message_Length and 16#ff#); - Message_Length := Shift_Right (Message_Length, 8); - end if; - - Index := Index + - (if Hash_Bit_Order = Low_Order_First then 1 else -1); - end loop; - - Update (FC, Pad); - end; - - pragma Assert (FC.M_State.Last = 0); - - Hash_State.To_Hash (FC.H_State, Hash_Bits); - - -- HMAC case: hash outer pad - - if C.KL /= 0 then - declare - Outer_C : Context; - Opad : Stream_Element_Array := - (1 .. Stream_Element_Offset (Block_Length) => 16#5c#); - - begin - for J in C.Key'Range loop - Opad (J) := Opad (J) xor C.Key (J); - end loop; - - Update (Outer_C, Opad); - Update (Outer_C, Hash_Bits); - - Final (Outer_C, Hash_Bits); - end; - end if; - end Final; - - -------------------------- - -- HMAC_Initial_Context -- - -------------------------- - - function HMAC_Initial_Context (Key : String) return Context is - begin - if Key'Length = 0 then - raise Constraint_Error with "null key"; - end if; - - return C : Context (KL => (if Key'Length <= Key_Length'Last - then Key'Length - else Stream_Element_Offset (Hash_Length))) - do - -- Set Key (if longer than block length, first hash it) - - if C.KL = Key'Length then - declare - SK : String (1 .. Key'Length); - for SK'Address use C.Key'Address; - pragma Import (Ada, SK); - begin - SK := Key; - end; - - else - C.Key := Digest (Key); - end if; - - -- Hash inner pad - - declare - Ipad : Stream_Element_Array := - (1 .. Stream_Element_Offset (Block_Length) => 16#36#); - - begin - for J in C.Key'Range loop - Ipad (J) := Ipad (J) xor C.Key (J); - end loop; - - Update (C, Ipad); - end; - end return; - end HMAC_Initial_Context; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : in out Hash_Stream; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - pragma Unreferenced (Stream, Item, Last); - begin - raise Program_Error with "Hash_Stream is write-only"; - end Read; - - ------------ - -- Update -- - ------------ - - procedure Update - (C : in out Context; - S : String; - Fill_Buffer : Fill_Buffer_Access) - is - Last : Natural; - - begin - C.M_State.Length := C.M_State.Length + S'Length; - - Last := S'First - 1; - while Last < S'Last loop - Fill_Buffer (C.M_State, S, Last + 1, Last); - - if C.M_State.Last = Block_Length then - Transform (C.H_State, C.M_State); - C.M_State.Last := 0; - end if; - end loop; - end Update; - - ------------ - -- Update -- - ------------ - - procedure Update (C : in out Context; Input : String) is - begin - Update (C, Input, Fill_Buffer_Copy'Access); - end Update; - - ------------ - -- Update -- - ------------ - - procedure Update (C : in out Context; Input : Stream_Element_Array) is - S : String (1 .. Input'Length); - for S'Address use Input'Address; - pragma Import (Ada, S); - begin - Update (C, S, Fill_Buffer_Copy'Access); - end Update; - - ----------------- - -- Wide_Update -- - ----------------- - - procedure Wide_Update (C : in out Context; Input : Wide_String) is - S : String (1 .. 2 * Input'Length); - for S'Address use Input'Address; - pragma Import (Ada, S); - begin - Update - (C, S, - (if System.Default_Bit_Order /= Low_Order_First - then Fill_Buffer_Swap'Access - else Fill_Buffer_Copy'Access)); - end Wide_Update; - - ----------------- - -- Wide_Digest -- - ----------------- - - function Wide_Digest (W : Wide_String) return Message_Digest is - C : Context; - begin - Wide_Update (C, W); - return Digest (C); - end Wide_Digest; - - function Wide_Digest (W : Wide_String) return Binary_Message_Digest is - C : Context; - begin - Wide_Update (C, W); - return Digest (C); - end Wide_Digest; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : in out Hash_Stream; - Item : Stream_Element_Array) - is - begin - Update (Stream.C.all, Item); - end Write; - - end H; - - ------------------------- - -- Hash_Function_State -- - ------------------------- - - package body Hash_Function_State is - - ------------- - -- To_Hash -- - ------------- - - procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is - Hash_Words : constant Natural := H'Size / Word'Size; - Result : State (1 .. Hash_Words) := - H (H'Last - Hash_Words + 1 .. H'Last); - - R_SEA : Stream_Element_Array (1 .. Result'Size / 8); - for R_SEA'Address use Result'Address; - pragma Import (Ada, R_SEA); - - begin - if System.Default_Bit_Order /= Hash_Bit_Order then - for J in Result'Range loop - Swap (Result (J)'Address); - end loop; - end if; - - -- Return truncated hash - - pragma Assert (H_Bits'Length <= R_SEA'Length); - H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1); - end To_Hash; - - end Hash_Function_State; - -end GNAT.Secure_Hashes; diff --git a/gcc/ada/g-sechas.ads b/gcc/ada/g-sechas.ads deleted file mode 100644 index 99e48e6..0000000 --- a/gcc/ada/g-sechas.ads +++ /dev/null @@ -1,240 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides common supporting code for a family of secure --- hash functions (including MD5 and the FIPS PUB 180-3 functions SHA-1, --- SHA-224, SHA-256, SHA-384 and SHA-512). - --- This is an internal unit and should be not used directly in applications. --- Use GNAT.MD5 and GNAT.SHA* instead. - -with Ada.Streams; use Ada.Streams; - -with Interfaces; - -with System; - -package GNAT.Secure_Hashes is - - type Buffer_Type is new String; - for Buffer_Type'Alignment use 8; - -- Secure hash functions use a string buffer that is also accessed as an - -- array of words, which may require up to 64 bit alignment. - - -- The function-independent part of processing state: A buffer of data - -- being accumulated until a complete block is ready for hashing. - - type Message_State (Block_Length : Natural) is record - Last : Natural := 0; - -- Index of last used element in Buffer - - Length : Interfaces.Unsigned_64 := 0; - -- Total length of processed data - - Buffer : Buffer_Type (1 .. Block_Length); - -- Data buffer - end record; - - -- The function-specific part of processing state: - - -- Each hash function maintains an internal state as an array of words, - -- which is ultimately converted to a stream representation with the - -- appropriate bit order. - - generic - type Word is mod <>; - -- Either 32 or 64 bits - - with procedure Swap (X : System.Address); - -- Byte swapping function for a Word at X - - Hash_Bit_Order : System.Bit_Order; - -- Bit order of the produced hash - - package Hash_Function_State is - - type State is array (Natural range <>) of Word; - -- Used to store a hash function's internal state - - procedure To_Hash - (H : State; - H_Bits : out Stream_Element_Array); - -- Convert H to stream representation with the given bit order. If - -- H_Bits is smaller than the internal hash state, then the state - -- is truncated. - - end Hash_Function_State; - - -- Generic hashing framework: The user interface for each implemented - -- secure hash function is an instance of this generic package. - - generic - Block_Words : Natural; - -- Number of words in each block - - State_Words : Natural; - -- Number of words in internal state - - Hash_Words : Natural; - -- Number of words in the final hash (must be no greater than - -- State_Words). - - Hash_Bit_Order : System.Bit_Order; - -- Bit order used for conversion between bit representation and word - -- representation. - - with package Hash_State is new Hash_Function_State (<>); - -- Hash function state package - - Initial_State : Hash_State.State; - -- Initial value of the hash function state - - with procedure Transform - (H : in out Hash_State.State; - M : in out Message_State); - -- Transformation function updating H by processing a complete data - -- block from M. - - package H is - - -- The visible part of H is the interface to secure hashing functions - -- that is exposed to user applications, and is intended to remain - -- a stable interface. - - pragma Assert (Hash_Words <= State_Words); - - type Context is private; - -- The internal processing state of the hashing function - - function "=" (L, R : Context) return Boolean is abstract; - -- Context is the internal, implementation defined intermediate state - -- in a hash computation, and no specific semantics can be expected on - -- equality of context values. Only equality of final hash values (as - -- returned by the [Wide_]Digest functions below) is meaningful. - - Initial_Context : constant Context; - -- Initial value of a Context object. May be used to reinitialize - -- a Context value by simple assignment of this value to the object. - - function HMAC_Initial_Context (Key : String) return Context; - -- Initial Context for HMAC computation with the given Key - - procedure Update (C : in out Context; Input : String); - procedure Wide_Update (C : in out Context; Input : Wide_String); - procedure Update - (C : in out Context; - Input : Stream_Element_Array); - -- Update C to process the given input. Successive calls to Update are - -- equivalent to a single call with the concatenation of the inputs. For - -- the Wide_String version, each Wide_Character is processed low order - -- byte first. - - Word_Length : constant Natural := Hash_State.Word'Size / 8; - Hash_Length : constant Natural := Hash_Words * Word_Length; - - subtype Binary_Message_Digest is - Stream_Element_Array (1 .. Stream_Element_Offset (Hash_Length)); - -- The fixed-length byte array returned by Digest, providing - -- the hash in binary representation. - - function Digest (C : Context) return Binary_Message_Digest; - -- Return hash or HMAC for the data accumulated with C - - function Digest (S : String) return Binary_Message_Digest; - function Wide_Digest (W : Wide_String) return Binary_Message_Digest; - function Digest - (A : Stream_Element_Array) return Binary_Message_Digest; - -- These functions are equivalent to the corresponding Update (or - -- Wide_Update) on a default initialized Context, followed by Digest - -- on the resulting Context. - - subtype Message_Digest is String (1 .. 2 * Hash_Length); - -- The fixed-length string returned by Digest, providing the hash in - -- hexadecimal representation. - - function Digest (C : Context) return Message_Digest; - -- Return hash or HMAC for the data accumulated with C in hexadecimal - -- representation. - - function Digest (S : String) return Message_Digest; - function Wide_Digest (W : Wide_String) return Message_Digest; - function Digest (A : Stream_Element_Array) return Message_Digest; - -- These functions are equivalent to the corresponding Update (or - -- Wide_Update) on a default initialized Context, followed by Digest - -- on the resulting Context. - - type Hash_Stream (C : access Context) is - new Root_Stream_Type with private; - -- Stream wrapper converting Write calls to Update calls on C. - -- Arbitrary data structures can thus be conveniently hashed using - -- their stream attributes. - - private - - Block_Length : constant Natural := Block_Words * Word_Length; - -- Length in bytes of a data block - - subtype Key_Length is - Stream_Element_Offset range 0 .. Stream_Element_Offset (Block_Length); - - -- KL is 0 for a normal hash context, > 0 for HMAC - - type Context (KL : Key_Length := 0) is record - H_State : Hash_State.State (0 .. State_Words - 1) := Initial_State; - -- Function-specific state - - M_State : Message_State (Block_Length); - -- Function-independent state (block buffer) - - Key : Stream_Element_Array (1 .. KL); - -- HMAC key - end record; - - Initial_Context : constant Context (KL => 0) := (others => <>); - -- Initial values are provided by default initialization of Context - - type Hash_Stream (C : access Context) is - new Root_Stream_Type with null record; - - procedure Read - (Stream : in out Hash_Stream; - Item : out Stream_Element_Array; - Last : out Stream_Element_Offset); - -- Raise Program_Error: hash streams are write-only - - procedure Write - (Stream : in out Hash_Stream; - Item : Stream_Element_Array); - -- Call Update - - end H; - -end GNAT.Secure_Hashes; diff --git a/gcc/ada/g-sehamd.adb b/gcc/ada/g-sehamd.adb deleted file mode 100644 index cd8a1f5..0000000 --- a/gcc/ada/g-sehamd.adb +++ /dev/null @@ -1,342 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . M D 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.Byte_Swapping; use GNAT.Byte_Swapping; - -package body GNAT.Secure_Hashes.MD5 is - - use Interfaces; - - -- The sixteen values used to rotate the context words. Four for each - -- rounds. Used in procedure Transform. - - -- Round 1 - - S11 : constant := 7; - S12 : constant := 12; - S13 : constant := 17; - S14 : constant := 22; - - -- Round 2 - - S21 : constant := 5; - S22 : constant := 9; - S23 : constant := 14; - S24 : constant := 20; - - -- Round 3 - - S31 : constant := 4; - S32 : constant := 11; - S33 : constant := 16; - S34 : constant := 23; - - -- Round 4 - - S41 : constant := 6; - S42 : constant := 10; - S43 : constant := 15; - S44 : constant := 21; - - -- The following functions (F, FF, G, GG, H, HH, I and II) are the - -- equivalent of the macros of the same name in the example C - -- implementation in the annex of RFC 1321. - - function F (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (F); - - procedure FF - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (FF); - - function G (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (G); - - procedure GG - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (GG); - - function H (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (H); - - procedure HH - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (HH); - - function I (X, Y, Z : Unsigned_32) return Unsigned_32; - pragma Inline (I); - - procedure II - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive); - pragma Inline (II); - - ------- - -- F -- - ------- - - function F (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return (X and Y) or ((not X) and Z); - end F; - - -------- - -- FF -- - -------- - - procedure FF - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + F (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end FF; - - ------- - -- G -- - ------- - - function G (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return (X and Z) or (Y and (not Z)); - end G; - - -------- - -- GG -- - -------- - - procedure GG - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + G (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end GG; - - ------- - -- H -- - ------- - - function H (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return X xor Y xor Z; - end H; - - -------- - -- HH -- - -------- - - procedure HH - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + H (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end HH; - - ------- - -- I -- - ------- - - function I (X, Y, Z : Unsigned_32) return Unsigned_32 is - begin - return Y xor (X or (not Z)); - end I; - - -------- - -- II -- - -------- - - procedure II - (A : in out Unsigned_32; - B, C, D : Unsigned_32; - X : Unsigned_32; - AC : Unsigned_32; - S : Positive) - is - begin - A := A + I (B, C, D) + X + AC; - A := Rotate_Left (A, S); - A := A + B; - end II; - - --------------- - -- Transform -- - --------------- - - procedure Transform - (H : in out Hash_State.State; - M : in out Message_State) - is - use System; - - X : array (0 .. 15) of Interfaces.Unsigned_32; - for X'Address use M.Buffer'Address; - pragma Import (Ada, X); - - AA : Unsigned_32 := H (0); - BB : Unsigned_32 := H (1); - CC : Unsigned_32 := H (2); - DD : Unsigned_32 := H (3); - - begin - if Default_Bit_Order /= Low_Order_First then - for J in X'Range loop - Swap4 (X (J)'Address); - end loop; - end if; - - -- Round 1 - - FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); -- 1 - FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); -- 2 - FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); -- 3 - FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); -- 4 - - FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); -- 5 - FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); -- 6 - FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); -- 7 - FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); -- 8 - - FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); -- 9 - FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); -- 10 - FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); -- 11 - FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); -- 12 - - FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); -- 13 - FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); -- 14 - FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); -- 15 - FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); -- 16 - - -- Round 2 - - GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); -- 17 - GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); -- 18 - GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); -- 19 - GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); -- 20 - - GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); -- 21 - GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); -- 22 - GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); -- 23 - GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); -- 24 - - GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); -- 25 - GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); -- 26 - GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); -- 27 - GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); -- 28 - - GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); -- 29 - GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); -- 30 - GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); -- 31 - GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); -- 32 - - -- Round 3 - - HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); -- 33 - HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); -- 34 - HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); -- 35 - HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); -- 36 - - HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); -- 37 - HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); -- 38 - HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); -- 39 - HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); -- 40 - - HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); -- 41 - HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); -- 42 - HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); -- 43 - HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); -- 44 - - HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); -- 45 - HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); -- 46 - HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); -- 47 - HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); -- 48 - - -- Round 4 - - II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); -- 49 - II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); -- 50 - II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); -- 51 - II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); -- 52 - - II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); -- 53 - II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); -- 54 - II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); -- 55 - II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); -- 56 - - II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); -- 57 - II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); -- 58 - II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); -- 59 - II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); -- 60 - - II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); -- 61 - II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); -- 62 - II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); -- 63 - II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); -- 64 - - H (0) := H (0) + AA; - H (1) := H (1) + BB; - H (2) := H (2) + CC; - H (3) := H (3) + DD; - - end Transform; - -end GNAT.Secure_Hashes.MD5; diff --git a/gcc/ada/g-sehamd.ads b/gcc/ada/g-sehamd.ads deleted file mode 100644 index 2340636..0000000 --- a/gcc/ada/g-sehamd.ads +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . M D 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides supporting code for implementation of the MD5 --- Message-Digest Algorithm as described in RFC 1321. The complete text of --- RFC 1321 can be found at: --- http://www.ietf.org/rfc/rfc1321.txt - --- This is an internal unit and should not be used directly in applications. --- Use GNAT.MD5 instead. - -with GNAT.Byte_Swapping; -with Interfaces; - -package GNAT.Secure_Hashes.MD5 is - - package Hash_State is - new GNAT.Secure_Hashes.Hash_Function_State - (Word => Interfaces.Unsigned_32, - Swap => GNAT.Byte_Swapping.Swap4, - Hash_Bit_Order => System.Low_Order_First); - -- MD5 operates on 32-bit little endian words - - Block_Words : constant := 16; - -- Messages are processed in chunks of 16 words - - procedure Transform - (H : in out Hash_State.State; - M : in out Message_State); - -- Transformation function applied for each block - - Initial_State : constant Hash_State.State; - -- Initialization vector - -private - - Initial_A : constant := 16#67452301#; - Initial_B : constant := 16#EFCDAB89#; - Initial_C : constant := 16#98BADCFE#; - Initial_D : constant := 16#10325476#; - - Initial_State : constant Hash_State.State := - (Initial_A, Initial_B, Initial_C, Initial_D); - -- Initialization vector from RFC 1321 - -end GNAT.Secure_Hashes.MD5; diff --git a/gcc/ada/g-sehash.adb b/gcc/ada/g-sehash.adb deleted file mode 100644 index b5e9689..0000000 --- a/gcc/ada/g-sehash.adb +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Secure_Hashes.SHA1 is - - use Interfaces; - use GNAT.Byte_Swapping; - - -- The following functions are the four elementary components of each - -- of the four round groups (0 .. 19, 20 .. 39, 40 .. 59, and 60 .. 79) - -- defined in RFC 3174. - - function F0 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F0); - - function F1 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F1); - - function F2 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F2); - - function F3 (B, C, D : Unsigned_32) return Unsigned_32; - pragma Inline (F3); - - -------- - -- F0 -- - -------- - - function F0 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - is - begin - return (B and C) or ((not B) and D); - end F0; - - -------- - -- F1 -- - -------- - - function F1 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - is - begin - return B xor C xor D; - end F1; - - -------- - -- F2 -- - -------- - - function F2 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - is - begin - return (B and C) or (B and D) or (C and D); - end F2; - - -------- - -- F3 -- - -------- - - function F3 - (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 - renames F1; - - --------------- - -- Transform -- - --------------- - - procedure Transform - (H : in out Hash_State.State; - M : in out Message_State) - is - use System; - - type Words is array (Natural range <>) of Interfaces.Unsigned_32; - - X : Words (0 .. 15); - for X'Address use M.Buffer'Address; - pragma Import (Ada, X); - - W : Words (0 .. 79); - - A, B, C, D, E, Temp : Interfaces.Unsigned_32; - - begin - if Default_Bit_Order /= High_Order_First then - for J in X'Range loop - Swap4 (X (J)'Address); - end loop; - end if; - - -- a. Divide data block into sixteen words - - W (0 .. 15) := X; - - -- b. Prepare working block of 80 words - - for T in 16 .. 79 loop - - -- W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) - - W (T) := Rotate_Left - (W (T - 3) xor W (T - 8) xor W (T - 14) xor W (T - 16), 1); - - end loop; - - -- c. Set up transformation variables - - A := H (0); - B := H (1); - C := H (2); - D := H (3); - E := H (4); - - -- d. For each of the 80 rounds, compute: - - -- TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t); - -- E = D; D = C; C = S^30(B); B = A; A = TEMP; - - for T in 0 .. 19 loop - Temp := Rotate_Left (A, 5) + F0 (B, C, D) + E + W (T) + 16#5A827999#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - for T in 20 .. 39 loop - Temp := Rotate_Left (A, 5) + F1 (B, C, D) + E + W (T) + 16#6ED9EBA1#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - for T in 40 .. 59 loop - Temp := Rotate_Left (A, 5) + F2 (B, C, D) + E + W (T) + 16#8F1BBCDC#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - for T in 60 .. 79 loop - Temp := Rotate_Left (A, 5) + F3 (B, C, D) + E + W (T) + 16#CA62C1D6#; - E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; - end loop; - - -- e. Update context: - -- H0 = H0 + A, H1 = H1 + B, H2 = H2 + C, H3 = H3 + D, H4 = H4 + E - - H (0) := H (0) + A; - H (1) := H (1) + B; - H (2) := H (2) + C; - H (3) := H (3) + D; - H (4) := H (4) + E; - end Transform; - -end GNAT.Secure_Hashes.SHA1; diff --git a/gcc/ada/g-sehash.ads b/gcc/ada/g-sehash.ads deleted file mode 100644 index c3bbce1..0000000 --- a/gcc/ada/g-sehash.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides supporting code for implementation of the SHA-1 --- secure hash function as described in FIPS PUB 180-3. The complete text --- of FIPS PUB 180-3 can be found at: --- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf - --- This is an internal unit and should not be used directly in applications. --- Use GNAT.SHA1 instead. - -with GNAT.Byte_Swapping; -with Interfaces; - -package GNAT.Secure_Hashes.SHA1 is - - package Hash_State is new Hash_Function_State - (Word => Interfaces.Unsigned_32, - Swap => GNAT.Byte_Swapping.Swap4, - Hash_Bit_Order => System.High_Order_First); - -- SHA-1 operates on 32-bit big endian words - - Block_Words : constant := 16; - -- Messages are processed in chunks of 16 words - - procedure Transform - (H : in out Hash_State.State; - M : in out Message_State); - -- Transformation function applied for each block - - Initial_State : constant Hash_State.State; - -- Initialization vector - -private - - Initial_State : constant Hash_State.State := - (0 => 16#67452301#, - 1 => 16#EFCDAB89#, - 2 => 16#98BADCFE#, - 3 => 16#10325476#, - 4 => 16#C3D2E1F0#); - -- Initialization vector from FIPS PUB 180-3 - -end GNAT.Secure_Hashes.SHA1; diff --git a/gcc/ada/g-sercom-linux.adb b/gcc/ada/g-sercom-linux.adb deleted file mode 100644 index 4140106..0000000 --- a/gcc/ada/g-sercom-linux.adb +++ /dev/null @@ -1,314 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the GNU/Linux implementation of this package - -with Ada.Streams; use Ada.Streams; -with Ada; use Ada; -with Ada.Unchecked_Deallocation; - -with System; use System; -with System.Communication; use System.Communication; -with System.CRTL; use System.CRTL; -with System.OS_Constants; - -with GNAT.OS_Lib; use GNAT.OS_Lib; - -package body GNAT.Serial_Communications is - - package OSC renames System.OS_Constants; - - use type Interfaces.C.unsigned; - - type Port_Data is new int; - - subtype unsigned is Interfaces.C.unsigned; - subtype char is Interfaces.C.char; - subtype unsigned_char is Interfaces.C.unsigned_char; - - function fcntl (fd : int; cmd : int; value : int) return int; - pragma Import (C, fcntl, "fcntl"); - - C_Data_Rate : constant array (Data_Rate) of unsigned := - (B75 => OSC.B75, - B110 => OSC.B110, - B150 => OSC.B150, - B300 => OSC.B300, - B600 => OSC.B600, - B1200 => OSC.B1200, - B2400 => OSC.B2400, - B4800 => OSC.B4800, - B9600 => OSC.B9600, - B19200 => OSC.B19200, - B38400 => OSC.B38400, - B57600 => OSC.B57600, - B115200 => OSC.B115200); - - C_Bits : constant array (Data_Bits) of unsigned := - (CS7 => OSC.CS7, CS8 => OSC.CS8); - - C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := - (One => 0, Two => OSC.CSTOPB); - - C_Parity : constant array (Parity_Check) of unsigned := - (None => 0, - Odd => OSC.PARENB or OSC.PARODD, - Even => OSC.PARENB); - - procedure Raise_Error (Message : String; Error : Integer := Errno); - pragma No_Return (Raise_Error); - - ---------- - -- Name -- - ---------- - - function Name (Number : Positive) return Port_Name is - N : constant Natural := Number - 1; - N_Img : constant String := Natural'Image (N); - begin - return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (Port : out Serial_Port; - Name : Port_Name) - is - use OSC; - - C_Name : constant String := String (Name) & ASCII.NUL; - Res : int; - - begin - if Port.H = null then - Port.H := new Port_Data; - end if; - - Port.H.all := Port_Data (open - (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); - - if Port.H.all = -1 then - Raise_Error ("open: open failed"); - end if; - - -- By default we are in blocking mode - - Res := fcntl (int (Port.H.all), F_SETFL, 0); - - if Res = -1 then - Raise_Error ("open: fcntl failed"); - end if; - end Open; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error (Message : String; Error : Integer := Errno) is - begin - raise Serial_Error with Message - & (if Error /= 0 - then " (" & Errno_Message (Err => Error) & ')' - else ""); - end Raise_Error; - - ---------- - -- Read -- - ---------- - - overriding procedure Read - (Port : in out Serial_Port; - Buffer : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Len : constant size_t := Buffer'Length; - Res : ssize_t; - - begin - if Port.H = null then - Raise_Error ("read: port not opened", 0); - end if; - - Res := read (Integer (Port.H.all), Buffer'Address, Len); - - if Res = -1 then - Raise_Error ("read failed"); - end if; - - Last := Last_Index (Buffer'First, size_t (Res)); - end Read; - - --------- - -- Set -- - --------- - - procedure Set - (Port : Serial_Port; - Rate : Data_Rate := B9600; - Bits : Data_Bits := CS8; - Stop_Bits : Stop_Bits_Number := One; - Parity : Parity_Check := None; - Block : Boolean := True; - Local : Boolean := True; - Flow : Flow_Control := None; - Timeout : Duration := 10.0) - is - use OSC; - - type termios is record - c_iflag : unsigned; - c_oflag : unsigned; - c_cflag : unsigned; - c_lflag : unsigned; - c_line : unsigned_char; - c_cc : Interfaces.C.char_array (0 .. 31); - c_ispeed : unsigned; - c_ospeed : unsigned; - end record; - pragma Convention (C, termios); - - function tcgetattr (fd : int; termios_p : Address) return int; - pragma Import (C, tcgetattr, "tcgetattr"); - - function tcsetattr - (fd : int; action : int; termios_p : Address) return int; - pragma Import (C, tcsetattr, "tcsetattr"); - - function tcflush (fd : int; queue_selector : int) return int; - pragma Import (C, tcflush, "tcflush"); - - Current : termios; - - Res : int; - pragma Warnings (Off, Res); - -- Warnings off, since we don't always test the result - - begin - if Port.H = null then - Raise_Error ("set: port not opened", 0); - end if; - - -- Get current port settings - - Res := tcgetattr (int (Port.H.all), Current'Address); - - -- Change settings now - - Current.c_cflag := C_Data_Rate (Rate) - or C_Bits (Bits) - or C_Stop_Bits (Stop_Bits) - or C_Parity (Parity) - or CREAD; - Current.c_iflag := 0; - Current.c_lflag := 0; - Current.c_oflag := 0; - - if Local then - Current.c_cflag := Current.c_cflag or CLOCAL; - end if; - - case Flow is - when None => - null; - - when RTS_CTS => - Current.c_cflag := Current.c_cflag or CRTSCTS; - - when Xon_Xoff => - Current.c_iflag := Current.c_iflag or IXON; - end case; - - Current.c_ispeed := Data_Rate_Value (Rate); - Current.c_ospeed := Data_Rate_Value (Rate); - Current.c_cc (VMIN) := char'Val (0); - Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); - - -- Set port settings - - Res := tcflush (int (Port.H.all), TCIFLUSH); - Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); - - -- Block - - Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); - - if Res = -1 then - Raise_Error ("set: fcntl failed"); - end if; - end Set; - - ----------- - -- Write -- - ----------- - - overriding procedure Write - (Port : in out Serial_Port; - Buffer : Stream_Element_Array) - is - Len : constant size_t := Buffer'Length; - Res : ssize_t; - - begin - if Port.H = null then - Raise_Error ("write: port not opened", 0); - end if; - - Res := write (int (Port.H.all), Buffer'Address, Len); - - if Res = -1 then - Raise_Error ("write failed"); - end if; - - pragma Assert (size_t (Res) = Len); - end Write; - - ----------- - -- Close -- - ----------- - - procedure Close (Port : in out Serial_Port) is - procedure Unchecked_Free is - new Unchecked_Deallocation (Port_Data, Port_Data_Access); - - Res : int; - pragma Unreferenced (Res); - - begin - if Port.H /= null then - Res := close (int (Port.H.all)); - Unchecked_Free (Port.H); - end if; - end Close; - -end GNAT.Serial_Communications; diff --git a/gcc/ada/g-sercom-mingw.adb b/gcc/ada/g-sercom-mingw.adb deleted file mode 100644 index dabbfcf..0000000 --- a/gcc/ada/g-sercom-mingw.adb +++ /dev/null @@ -1,316 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Windows implementation of this package - -with Ada.Streams; use Ada.Streams; -with Ada.Unchecked_Deallocation; use Ada; - -with System; use System; -with System.Communication; use System.Communication; -with System.CRTL; use System.CRTL; -with System.OS_Constants; -with System.Win32; use System.Win32; -with System.Win32.Ext; use System.Win32.Ext; - -with GNAT.OS_Lib; - -package body GNAT.Serial_Communications is - - package OSC renames System.OS_Constants; - - -- Common types - - type Port_Data is new HANDLE; - - C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7); - C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned := - (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY); - C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned := - (One => ONESTOPBIT, Two => TWOSTOPBITS); - - ----------- - -- Files -- - ----------- - - procedure Raise_Error (Message : String; Error : DWORD := GetLastError); - pragma No_Return (Raise_Error); - - ----------- - -- Close -- - ----------- - - procedure Close (Port : in out Serial_Port) is - procedure Unchecked_Free is - new Unchecked_Deallocation (Port_Data, Port_Data_Access); - - Success : BOOL; - - begin - if Port.H /= null then - Success := CloseHandle (HANDLE (Port.H.all)); - Unchecked_Free (Port.H); - - if Success = Win32.FALSE then - Raise_Error ("error closing the port"); - end if; - end if; - end Close; - - ---------- - -- Name -- - ---------- - - function Name (Number : Positive) return Port_Name is - N_Img : constant String := Positive'Image (Number); - begin - if Number > 9 then - return - Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last)); - else - return - Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); - end if; - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (Port : out Serial_Port; - Name : Port_Name) - is - C_Name : constant String := String (Name) & ASCII.NUL; - Success : BOOL; - pragma Unreferenced (Success); - - begin - if Port.H = null then - Port.H := new Port_Data; - else - Success := CloseHandle (HANDLE (Port.H.all)); - end if; - - Port.H.all := CreateFileA - (lpFileName => C_Name (C_Name'First)'Address, - dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, - dwShareMode => 0, - lpSecurityAttributes => null, - dwCreationDisposition => OPEN_EXISTING, - dwFlagsAndAttributes => 0, - hTemplateFile => 0); - - if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then - Raise_Error ("cannot open com port"); - end if; - end Open; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is - begin - raise Serial_Error with Message - & (if Error /= 0 - then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')' - else ""); - end Raise_Error; - - ---------- - -- Read -- - ---------- - - overriding procedure Read - (Port : in out Serial_Port; - Buffer : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - Success : BOOL; - Read_Last : aliased DWORD; - - begin - if Port.H = null then - Raise_Error ("read: port not opened", 0); - end if; - - Success := - ReadFile - (hFile => HANDLE (Port.H.all), - lpBuffer => Buffer (Buffer'First)'Address, - nNumberOfBytesToRead => DWORD (Buffer'Length), - lpNumberOfBytesRead => Read_Last'Access, - lpOverlapped => null); - - if Success = Win32.FALSE then - Raise_Error ("read error"); - end if; - - Last := Last_Index (Buffer'First, size_t (Read_Last)); - end Read; - - --------- - -- Set -- - --------- - - procedure Set - (Port : Serial_Port; - Rate : Data_Rate := B9600; - Bits : Data_Bits := CS8; - Stop_Bits : Stop_Bits_Number := One; - Parity : Parity_Check := None; - Block : Boolean := True; - Local : Boolean := True; - Flow : Flow_Control := None; - Timeout : Duration := 10.0) - is - pragma Unreferenced (Local); - - Success : BOOL; - Com_Time_Out : aliased COMMTIMEOUTS; - Com_Settings : aliased DCB; - - begin - if Port.H = null then - Raise_Error ("set: port not opened", 0); - end if; - - Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); - - if Success = Win32.FALSE then - Success := CloseHandle (HANDLE (Port.H.all)); - Port.H.all := 0; - Raise_Error ("set: cannot get comm state"); - end if; - - Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); - Com_Settings.fParity := 1; - Com_Settings.fBinary := Bits1 (System.Win32.TRUE); - Com_Settings.fOutxDsrFlow := 0; - Com_Settings.fDsrSensitivity := 0; - Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE; - Com_Settings.fInX := 0; - Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE; - - case Flow is - when None => - Com_Settings.fOutX := 0; - Com_Settings.fOutxCtsFlow := 0; - - when RTS_CTS => - Com_Settings.fOutX := 0; - Com_Settings.fOutxCtsFlow := 1; - - when Xon_Xoff => - Com_Settings.fOutX := 1; - Com_Settings.fOutxCtsFlow := 0; - end case; - - Com_Settings.fAbortOnError := 0; - Com_Settings.ByteSize := BYTE (C_Bits (Bits)); - Com_Settings.Parity := BYTE (C_Parity (Parity)); - Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits)); - - Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); - - if Success = Win32.FALSE then - Success := CloseHandle (HANDLE (Port.H.all)); - Port.H.all := 0; - Raise_Error ("cannot set comm state"); - end if; - - -- Set the timeout status, to honor our spec with respect to read - -- timeouts. Always disconnect write timeouts. - - -- Blocking reads - no timeout at all - - if Block then - Com_Time_Out := (others => 0); - - -- Non-blocking reads and null timeout - immediate return with what we - -- have - set ReadIntervalTimeout to MAXDWORD. - - elsif Timeout = 0.0 then - Com_Time_Out := - (ReadIntervalTimeout => DWORD'Last, - others => 0); - - -- Non-blocking reads with timeout - set total read timeout accordingly - - else - Com_Time_Out := - (ReadTotalTimeoutConstant => DWORD (1000 * Timeout), - others => 0); - end if; - - Success := - SetCommTimeouts - (hFile => HANDLE (Port.H.all), - lpCommTimeouts => Com_Time_Out'Access); - - if Success = Win32.FALSE then - Raise_Error ("cannot set the timeout"); - end if; - end Set; - - ----------- - -- Write -- - ----------- - - overriding procedure Write - (Port : in out Serial_Port; - Buffer : Stream_Element_Array) - is - Success : BOOL; - Temp_Last : aliased DWORD; - - begin - if Port.H = null then - Raise_Error ("write: port not opened", 0); - end if; - - Success := - WriteFile - (hFile => HANDLE (Port.H.all), - lpBuffer => Buffer'Address, - nNumberOfBytesToWrite => DWORD (Buffer'Length), - lpNumberOfBytesWritten => Temp_Last'Access, - lpOverlapped => null); - - if Success = Win32.FALSE - or else Stream_Element_Offset (Temp_Last) /= Buffer'Length - then - Raise_Error ("failed to write data"); - end if; - end Write; - -end GNAT.Serial_Communications; diff --git a/gcc/ada/g-sercom.adb b/gcc/ada/g-sercom.adb deleted file mode 100644 index c2b511c..0000000 --- a/gcc/ada/g-sercom.adb +++ /dev/null @@ -1,136 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2012, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Default version of this package - -with Ada.Streams; use Ada.Streams; - -package body GNAT.Serial_Communications is - - pragma Warnings (Off); - -- Kill warnings on unreferenced formals - - type Port_Data is new Integer; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Unimplemented; - pragma No_Return (Unimplemented); - -- This procedure raises a Program_Error with an appropriate message - -- indicating that an unimplemented feature has been used. - - ---------- - -- Name -- - ---------- - - function Name (Number : Positive) return Port_Name is - begin - Unimplemented; - return ""; - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (Port : out Serial_Port; - Name : Port_Name) - is - begin - Unimplemented; - end Open; - - --------- - -- Set -- - --------- - - procedure Set - (Port : Serial_Port; - Rate : Data_Rate := B9600; - Bits : Data_Bits := CS8; - Stop_Bits : Stop_Bits_Number := One; - Parity : Parity_Check := None; - Block : Boolean := True; - Local : Boolean := True; - Flow : Flow_Control := None; - Timeout : Duration := 10.0) - is - begin - Unimplemented; - end Set; - - ---------- - -- Read -- - ---------- - - overriding procedure Read - (Port : in out Serial_Port; - Buffer : out Stream_Element_Array; - Last : out Stream_Element_Offset) - is - begin - Unimplemented; - end Read; - - ----------- - -- Write -- - ----------- - - overriding procedure Write - (Port : in out Serial_Port; - Buffer : Stream_Element_Array) - is - begin - Unimplemented; - end Write; - - ----------- - -- Close -- - ----------- - - procedure Close (Port : in out Serial_Port) is - begin - Unimplemented; - end Close; - - ------------------- - -- Unimplemented; -- - ------------------- - - procedure Unimplemented is - begin - raise Program_Error with "Serial_Communications not implemented"; - end Unimplemented; - -end GNAT.Serial_Communications; diff --git a/gcc/ada/g-sercom.ads b/gcc/ada/g-sercom.ads deleted file mode 100644 index f185a77..0000000 --- a/gcc/ada/g-sercom.ads +++ /dev/null @@ -1,190 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Serial communications package, implemented on Windows and GNU/Linux - -with Ada.Streams; -with Interfaces.C; - -package GNAT.Serial_Communications is - - -- Following is a simple example of using GNAT.Serial_Communications. - -- - -- with Ada.Streams; - -- with GNAT.Serial_Communications; - -- - -- procedure Serial is - -- use Ada.Streams; - -- use GNAT; - -- - -- subtype Message is Stream_Element_Array (1 .. 20); - -- - -- Data : constant String (1 .. 20) := "ABCDEFGHIJLKMNOPQRST"; - -- Buffer : Message; - -- - -- S_Port : constant Natural := 5; - -- -- Serial port number - -- - -- begin - -- -- Convert message (String -> Stream_Element_Array) - -- - -- for K in Data'Range loop - -- Buffer (Stream_Element_Offset (K)) := Character'Pos (Data (K)); - -- end loop; - -- - -- declare - -- Port_Name : constant Serial_Communications.Port_Name := - -- Serial_Communications.Name (Number => S_Port); - -- Port : Serial_Communications.Serial_Port; - -- - -- begin - -- Serial_Communications.Open - -- (Port => Port, - -- Name => Port_Name); - -- - -- Serial_Communications.Set - -- (Port => Port, - -- Rate => Serial_Communications.B9600, - -- Bits => Serial_Communications.CS8, - -- Stop_Bits => Serial_Communications.One, - -- Parity => Serial_Communications.Even); - -- - -- Serial_Communications.Write - -- (Port => Port, - -- Buffer => Buffer); - -- - -- Serial_Communications.Close - -- (Port => Port); - -- end; - -- end Serial; - - Serial_Error : exception; - -- Raised when a communication problem occurs - - type Port_Name is new String; - -- A serial com port name - - function Name (Number : Positive) return Port_Name; - -- Returns a possible port name for the given legacy PC architecture serial - -- port number (COM: on Windows, ttyS on Linux). - -- Note that this function does not support other kinds of serial ports - -- nor operating systems other than Windows and Linux. For all other - -- cases, an explicit port name can be passed directly to Open. - - type Data_Rate is - (B75, B110, B150, B300, B600, B1200, B2400, B4800, B9600, - B19200, B38400, B57600, B115200); - -- Speed of the communication - - type Data_Bits is (CS8, CS7); - -- Communication bits - - type Stop_Bits_Number is (One, Two); - -- One or two stop bits - - type Parity_Check is (None, Even, Odd); - -- Either no parity check or an even or odd parity - - type Flow_Control is (None, RTS_CTS, Xon_Xoff); - -- No flow control, hardware flow control, software flow control - - type Serial_Port is new Ada.Streams.Root_Stream_Type with private; - - procedure Open - (Port : out Serial_Port; - Name : Port_Name); - -- Open the given port name. Raises Serial_Error if the port cannot be - -- opened. - - procedure Set - (Port : Serial_Port; - Rate : Data_Rate := B9600; - Bits : Data_Bits := CS8; - Stop_Bits : Stop_Bits_Number := One; - Parity : Parity_Check := None; - Block : Boolean := True; - Local : Boolean := True; - Flow : Flow_Control := None; - Timeout : Duration := 10.0); - -- The communication port settings. If Block is set then a read call - -- will wait for the whole buffer to be filed. If Block is not set then - -- the given Timeout (in seconds) is used. If Local is set then modem - -- control lines (in particular DCD) are ignored (not supported on - -- Windows). Flow indicates the flow control type as defined above. - - -- Note: the timeout precision may be limited on some implementation - -- (e.g. on GNU/Linux the maximum precision is a tenth of seconds). - - -- Note: calling this procedure may reinitialize the serial port hardware - -- and thus cause loss of some buffered data if used during communication. - - overriding procedure Read - (Port : in out Serial_Port; - Buffer : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Read a set of bytes, put result into Buffer and set Last accordingly. - -- Last is set to Buffer'First - 1 if no byte has been read, unless - -- Buffer'First = Stream_Element_Offset'First, in which case the exception - -- Constraint_Error is raised instead. - - overriding procedure Write - (Port : in out Serial_Port; - Buffer : Ada.Streams.Stream_Element_Array); - -- Write buffer into the port - - procedure Close (Port : in out Serial_Port); - -- Close port - -private - - type Port_Data; - type Port_Data_Access is access Port_Data; - - type Serial_Port is new Ada.Streams.Root_Stream_Type with record - H : Port_Data_Access; - end record; - - Data_Rate_Value : constant array (Data_Rate) of Interfaces.C.unsigned := - (B75 => 75, - B110 => 110, - B150 => 150, - B300 => 300, - B600 => 600, - B1200 => 1_200, - B2400 => 2_400, - B4800 => 4_800, - B9600 => 9_600, - B19200 => 19_200, - B38400 => 38_400, - B57600 => 57_600, - B115200 => 115_200); - -end GNAT.Serial_Communications; diff --git a/gcc/ada/g-sestin.ads b/gcc/ada/g-sestin.ads deleted file mode 100644 index a1658b3..0000000 --- a/gcc/ada/g-sestin.ads +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S E C O N D A R Y _ S T A C K _ I N F O -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides facilities for obtaining information on secondary --- stack usage. - -with System.Secondary_Stack; - -package GNAT.Secondary_Stack_Info is - - function SS_Get_Max return Long_Long_Integer - renames System.Secondary_Stack.SS_Get_Max; - -- Return maximum used space in storage units for the current secondary - -- stack. For a dynamically allocated secondary stack, the returned - -- result is always -1. For a statically allocated secondary stack, - -- the returned value shows the largest amount of space allocated so - -- far during execution of the program to the current secondary stack, - -- i.e. the secondary stack for the current task. - -end GNAT.Secondary_Stack_Info; diff --git a/gcc/ada/g-sha1.adb b/gcc/ada/g-sha1.adb deleted file mode 100644 index edc6b43..0000000 --- a/gcc/ada/g-sha1.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S H A 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-sha1.ads b/gcc/ada/g-sha1.ads deleted file mode 100644 index 2a1c0e1..0000000 --- a/gcc/ada/g-sha1.ads +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S H A 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements the SHA-1 secure hash function as described in --- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: --- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf - --- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete --- documentation. - -with GNAT.Secure_Hashes.SHA1; -with System; - -package GNAT.SHA1 is new GNAT.Secure_Hashes.H - (Block_Words => GNAT.Secure_Hashes.SHA1.Block_Words, - State_Words => 5, - Hash_Words => 5, - Hash_Bit_Order => System.High_Order_First, - Hash_State => GNAT.Secure_Hashes.SHA1.Hash_State, - Initial_State => GNAT.Secure_Hashes.SHA1.Initial_State, - Transform => GNAT.Secure_Hashes.SHA1.Transform); diff --git a/gcc/ada/g-sha224.ads b/gcc/ada/g-sha224.ads deleted file mode 100644 index 0520a5e..0000000 --- a/gcc/ada/g-sha224.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S H A 2 2 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements the SHA-224 secure hash function as described in --- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: --- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf - --- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete --- documentation. - -with GNAT.Secure_Hashes.SHA2_Common; -with GNAT.Secure_Hashes.SHA2_32; -with System; - -package GNAT.SHA224 is new GNAT.Secure_Hashes.H - (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, - State_Words => 8, - Hash_Words => 7, - Hash_Bit_Order => System.High_Order_First, - Hash_State => GNAT.Secure_Hashes.SHA2_32.Hash_State, - Initial_State => GNAT.Secure_Hashes.SHA2_32.SHA224_Init_State, - Transform => GNAT.Secure_Hashes.SHA2_32.Transform); diff --git a/gcc/ada/g-sha256.ads b/gcc/ada/g-sha256.ads deleted file mode 100644 index 9108843..0000000 --- a/gcc/ada/g-sha256.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S H A 2 5 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements the SHA-256 secure hash function as described in --- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: --- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf - --- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete --- documentation. - -with GNAT.Secure_Hashes.SHA2_Common; -with GNAT.Secure_Hashes.SHA2_32; -with System; - -package GNAT.SHA256 is new GNAT.Secure_Hashes.H - (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, - State_Words => 8, - Hash_Words => 8, - Hash_Bit_Order => System.High_Order_First, - Hash_State => GNAT.Secure_Hashes.SHA2_32.Hash_State, - Initial_State => GNAT.Secure_Hashes.SHA2_32.SHA256_Init_State, - Transform => GNAT.Secure_Hashes.SHA2_32.Transform); diff --git a/gcc/ada/g-sha384.ads b/gcc/ada/g-sha384.ads deleted file mode 100644 index 0047da0..0000000 --- a/gcc/ada/g-sha384.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S H A 3 8 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements the SHA-384 secure hash function as described in --- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: --- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf - --- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete --- documentation. - -with GNAT.Secure_Hashes.SHA2_Common; -with GNAT.Secure_Hashes.SHA2_64; -with System; - -package GNAT.SHA384 is new GNAT.Secure_Hashes.H - (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, - State_Words => 8, - Hash_Words => 6, - Hash_Bit_Order => System.High_Order_First, - Hash_State => GNAT.Secure_Hashes.SHA2_64.Hash_State, - Initial_State => GNAT.Secure_Hashes.SHA2_64.SHA384_Init_State, - Transform => GNAT.Secure_Hashes.SHA2_64.Transform); diff --git a/gcc/ada/g-sha512.ads b/gcc/ada/g-sha512.ads deleted file mode 100644 index e75d949..0000000 --- a/gcc/ada/g-sha512.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S H A 5 1 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements the SHA-512 secure hash function as described in --- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: --- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf - --- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete --- documentation. - -with GNAT.Secure_Hashes.SHA2_Common; -with GNAT.Secure_Hashes.SHA2_64; -with System; - -package GNAT.SHA512 is new GNAT.Secure_Hashes.H - (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, - State_Words => 8, - Hash_Words => 8, - Hash_Bit_Order => System.High_Order_First, - Hash_State => GNAT.Secure_Hashes.SHA2_64.Hash_State, - Initial_State => GNAT.Secure_Hashes.SHA2_64.SHA512_Init_State, - Transform => GNAT.Secure_Hashes.SHA2_64.Transform); diff --git a/gcc/ada/g-shsh32.adb b/gcc/ada/g-shsh32.adb deleted file mode 100644 index c9845f1..0000000 --- a/gcc/ada/g-shsh32.adb +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 3 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Secure_Hashes.SHA2_32 is - - use Interfaces; - - ------------ - -- Sigma0 -- - ------------ - - function Sigma0 (X : Word) return Word is - begin - return Rotate_Right (X, 2) - xor Rotate_Right (X, 13) - xor Rotate_Right (X, 22); - end Sigma0; - - ------------ - -- Sigma1 -- - ------------ - - function Sigma1 (X : Word) return Word is - begin - return Rotate_Right (X, 6) - xor Rotate_Right (X, 11) - xor Rotate_Right (X, 25); - end Sigma1; - - -------- - -- S0 -- - -------- - - function S0 (X : Word) return Word is - begin - return Rotate_Right (X, 7) - xor Rotate_Right (X, 18) - xor Shift_Right (X, 3); - end S0; - - -------- - -- S1 -- - -------- - - function S1 (X : Word) return Word is - begin - return Rotate_Right (X, 17) - xor Rotate_Right (X, 19) - xor Shift_Right (X, 10); - end S1; - -end GNAT.Secure_Hashes.SHA2_32; diff --git a/gcc/ada/g-shsh32.ads b/gcc/ada/g-shsh32.ads deleted file mode 100644 index 4495a15..0000000 --- a/gcc/ada/g-shsh32.ads +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides support for the 32-bit FIPS PUB 180-3 functions --- SHA-224 and SHA-256. - --- This is an internal unit and should not be used directly in applications. --- Use GNAT.SHA224 and GNAT.SHA256 instead. - -with Interfaces; -with GNAT.Byte_Swapping; -with GNAT.Secure_Hashes.SHA2_Common; - -package GNAT.Secure_Hashes.SHA2_32 is - - subtype Word is Interfaces.Unsigned_32; - - package Hash_State is new Hash_Function_State - (Word => Word, - Swap => GNAT.Byte_Swapping.Swap4, - Hash_Bit_Order => System.High_Order_First); - -- SHA-224 and SHA-256 operate on 32-bit big endian words - - K : constant Hash_State.State (0 .. 63) := - (16#428a2f98#, 16#71374491#, 16#b5c0fbcf#, 16#e9b5dba5#, - 16#3956c25b#, 16#59f111f1#, 16#923f82a4#, 16#ab1c5ed5#, - 16#d807aa98#, 16#12835b01#, 16#243185be#, 16#550c7dc3#, - 16#72be5d74#, 16#80deb1fe#, 16#9bdc06a7#, 16#c19bf174#, - 16#e49b69c1#, 16#efbe4786#, 16#0fc19dc6#, 16#240ca1cc#, - 16#2de92c6f#, 16#4a7484aa#, 16#5cb0a9dc#, 16#76f988da#, - 16#983e5152#, 16#a831c66d#, 16#b00327c8#, 16#bf597fc7#, - 16#c6e00bf3#, 16#d5a79147#, 16#06ca6351#, 16#14292967#, - 16#27b70a85#, 16#2e1b2138#, 16#4d2c6dfc#, 16#53380d13#, - 16#650a7354#, 16#766a0abb#, 16#81c2c92e#, 16#92722c85#, - 16#a2bfe8a1#, 16#a81a664b#, 16#c24b8b70#, 16#c76c51a3#, - 16#d192e819#, 16#d6990624#, 16#f40e3585#, 16#106aa070#, - 16#19a4c116#, 16#1e376c08#, 16#2748774c#, 16#34b0bcb5#, - 16#391c0cb3#, 16#4ed8aa4a#, 16#5b9cca4f#, 16#682e6ff3#, - 16#748f82ee#, 16#78a5636f#, 16#84c87814#, 16#8cc70208#, - 16#90befffa#, 16#a4506ceb#, 16#bef9a3f7#, 16#c67178f2#); - -- Constants from FIPS PUB 180-3 - - function Sigma0 (X : Word) return Word; - function Sigma1 (X : Word) return Word; - function S0 (X : Word) return Word; - function S1 (X : Word) return Word; - pragma Inline (Sigma0, Sigma1, S0, S1); - -- Elementary functions Sigma^256_0, Sigma^256_1, sigma^256_0, sigma^256_1 - -- from FIPS PUB 180-3. - - procedure Transform is new SHA2_Common.Transform - (Hash_State => Hash_State, - K => K, - Rounds => 64, - Sigma0 => Sigma0, - Sigma1 => Sigma1, - S0 => S0, - S1 => S1); - - SHA224_Init_State : constant Hash_State.State (0 .. 7) := - (0 => 16#c1059ed8#, - 1 => 16#367cd507#, - 2 => 16#3070dd17#, - 3 => 16#f70e5939#, - 4 => 16#ffc00b31#, - 5 => 16#68581511#, - 6 => 16#64f98fa7#, - 7 => 16#befa4fa4#); - SHA256_Init_State : constant Hash_State.State (0 .. 7) := - (0 => 16#6a09e667#, - 1 => 16#bb67ae85#, - 2 => 16#3c6ef372#, - 3 => 16#a54ff53a#, - 4 => 16#510e527f#, - 5 => 16#9b05688c#, - 6 => 16#1f83d9ab#, - 7 => 16#5be0cd19#); - -- Initialization vectors from FIPS PUB 180-3 - -end GNAT.Secure_Hashes.SHA2_32; diff --git a/gcc/ada/g-shsh64.adb b/gcc/ada/g-shsh64.adb deleted file mode 100644 index 330337c..0000000 --- a/gcc/ada/g-shsh64.adb +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 6 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Secure_Hashes.SHA2_64 is - - use Interfaces; - - ------------ - -- Sigma0 -- - ------------ - - function Sigma0 (X : Word) return Word is - begin - return Rotate_Right (X, 28) - xor Rotate_Right (X, 34) - xor Rotate_Right (X, 39); - end Sigma0; - - ------------ - -- Sigma1 -- - ------------ - - function Sigma1 (X : Word) return Word is - begin - return Rotate_Right (X, 14) - xor Rotate_Right (X, 18) - xor Rotate_Right (X, 41); - end Sigma1; - - -------- - -- S0 -- - -------- - - function S0 (X : Word) return Word is - begin - return Rotate_Right (X, 1) - xor Rotate_Right (X, 8) - xor Shift_Right (X, 7); - end S0; - - -------- - -- S1 -- - -------- - - function S1 (X : Word) return Word is - begin - return Rotate_Right (X, 19) - xor Rotate_Right (X, 61) - xor Shift_Right (X, 6); - end S1; - -end GNAT.Secure_Hashes.SHA2_64; diff --git a/gcc/ada/g-shsh64.ads b/gcc/ada/g-shsh64.ads deleted file mode 100644 index 4b27c7d..0000000 --- a/gcc/ada/g-shsh64.ads +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 6 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides support for the 64-bit FIPS PUB 180-3 functions --- SHA-384 and SHA-512. - --- This is an internal unit and should not be used directly in applications. --- Use GNAT.SHA384 and GNAT.SHA512 instead. - -with Interfaces; -with GNAT.Byte_Swapping; - -with GNAT.Secure_Hashes.SHA2_Common; - -package GNAT.Secure_Hashes.SHA2_64 is - subtype Word is Interfaces.Unsigned_64; - - package Hash_State is new Hash_Function_State - (Word => Word, - Swap => GNAT.Byte_Swapping.Swap8, - Hash_Bit_Order => System.High_Order_First); - -- SHA-384 and SHA-512 operate on 64-bit big endian words - - K : Hash_State.State (0 .. 79) := - (16#428a2f98d728ae22#, 16#7137449123ef65cd#, - 16#b5c0fbcfec4d3b2f#, 16#e9b5dba58189dbbc#, - 16#3956c25bf348b538#, 16#59f111f1b605d019#, - 16#923f82a4af194f9b#, 16#ab1c5ed5da6d8118#, - 16#d807aa98a3030242#, 16#12835b0145706fbe#, - 16#243185be4ee4b28c#, 16#550c7dc3d5ffb4e2#, - 16#72be5d74f27b896f#, 16#80deb1fe3b1696b1#, - 16#9bdc06a725c71235#, 16#c19bf174cf692694#, - 16#e49b69c19ef14ad2#, 16#efbe4786384f25e3#, - 16#0fc19dc68b8cd5b5#, 16#240ca1cc77ac9c65#, - 16#2de92c6f592b0275#, 16#4a7484aa6ea6e483#, - 16#5cb0a9dcbd41fbd4#, 16#76f988da831153b5#, - 16#983e5152ee66dfab#, 16#a831c66d2db43210#, - 16#b00327c898fb213f#, 16#bf597fc7beef0ee4#, - 16#c6e00bf33da88fc2#, 16#d5a79147930aa725#, - 16#06ca6351e003826f#, 16#142929670a0e6e70#, - 16#27b70a8546d22ffc#, 16#2e1b21385c26c926#, - 16#4d2c6dfc5ac42aed#, 16#53380d139d95b3df#, - 16#650a73548baf63de#, 16#766a0abb3c77b2a8#, - 16#81c2c92e47edaee6#, 16#92722c851482353b#, - 16#a2bfe8a14cf10364#, 16#a81a664bbc423001#, - 16#c24b8b70d0f89791#, 16#c76c51a30654be30#, - 16#d192e819d6ef5218#, 16#d69906245565a910#, - 16#f40e35855771202a#, 16#106aa07032bbd1b8#, - 16#19a4c116b8d2d0c8#, 16#1e376c085141ab53#, - 16#2748774cdf8eeb99#, 16#34b0bcb5e19b48a8#, - 16#391c0cb3c5c95a63#, 16#4ed8aa4ae3418acb#, - 16#5b9cca4f7763e373#, 16#682e6ff3d6b2b8a3#, - 16#748f82ee5defb2fc#, 16#78a5636f43172f60#, - 16#84c87814a1f0ab72#, 16#8cc702081a6439ec#, - 16#90befffa23631e28#, 16#a4506cebde82bde9#, - 16#bef9a3f7b2c67915#, 16#c67178f2e372532b#, - 16#ca273eceea26619c#, 16#d186b8c721c0c207#, - 16#eada7dd6cde0eb1e#, 16#f57d4f7fee6ed178#, - 16#06f067aa72176fba#, 16#0a637dc5a2c898a6#, - 16#113f9804bef90dae#, 16#1b710b35131c471b#, - 16#28db77f523047d84#, 16#32caab7b40c72493#, - 16#3c9ebe0a15c9bebc#, 16#431d67c49c100d4c#, - 16#4cc5d4becb3e42b6#, 16#597f299cfc657e2a#, - 16#5fcb6fab3ad6faec#, 16#6c44198c4a475817#); - -- Constants from FIPS PUB 180-3 - - function Sigma0 (X : Word) return Word; - function Sigma1 (X : Word) return Word; - function S0 (X : Word) return Word; - function S1 (X : Word) return Word; - pragma Inline (Sigma0, Sigma1, S0, S1); - -- Elementary functions Sigma^512_0, Sigma^512_1, sigma^512_0, sigma^512_1 - -- from FIPS PUB 180-3. - - procedure Transform is new SHA2_Common.Transform - (Hash_State => Hash_State, - K => K, - Rounds => 80, - Sigma0 => Sigma0, - Sigma1 => Sigma1, - S0 => S0, - S1 => S1); - - SHA384_Init_State : constant Hash_State.State := - (0 => 16#cbbb9d5dc1059ed8#, - 1 => 16#629a292a367cd507#, - 2 => 16#9159015a3070dd17#, - 3 => 16#152fecd8f70e5939#, - 4 => 16#67332667ffc00b31#, - 5 => 16#8eb44a8768581511#, - 6 => 16#db0c2e0d64f98fa7#, - 7 => 16#47b5481dbefa4fa4#); - SHA512_Init_State : constant Hash_State.State := - (0 => 16#6a09e667f3bcc908#, - 1 => 16#bb67ae8584caa73b#, - 2 => 16#3c6ef372fe94f82b#, - 3 => 16#a54ff53a5f1d36f1#, - 4 => 16#510e527fade682d1#, - 5 => 16#9b05688c2b3e6c1f#, - 6 => 16#1f83d9abfb41bd6b#, - 7 => 16#5be0cd19137e2179#); - -- Initialization vectors from FIPS PUB 180-3 - -end GNAT.Secure_Hashes.SHA2_64; diff --git a/gcc/ada/g-shshco.adb b/gcc/ada/g-shshco.adb deleted file mode 100644 index dcdb236..0000000 --- a/gcc/ada/g-shshco.adb +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 2 _ C O M M O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Secure_Hashes.SHA2_Common is - - --------------- - -- Transform -- - --------------- - - procedure Transform - (H_St : in out Hash_State.State; - M_St : in out Message_State) - is - use System; - - subtype Word is Hash_State.Word; - use type Hash_State.Word; - - function Ch (X, Y, Z : Word) return Word; - function Maj (X, Y, Z : Word) return Word; - pragma Inline (Ch, Maj); - -- Elementary functions from FIPS PUB 180-3 - - -------- - -- Ch -- - -------- - - function Ch (X, Y, Z : Word) return Word is - begin - return (X and Y) xor ((not X) and Z); - end Ch; - - --------- - -- Maj -- - --------- - - function Maj (X, Y, Z : Word) return Word is - begin - return (X and Y) xor (X and Z) xor (Y and Z); - end Maj; - - type Words is array (Natural range <>) of Word; - - X : Words (0 .. 15); - for X'Address use M_St.Buffer'Address; - pragma Import (Ada, X); - - W : Words (0 .. Rounds - 1); - - A, B, C, D, E, F, G, H, T1, T2 : Word; - - -- Start of processing for Transform - - begin - if Default_Bit_Order /= High_Order_First then - for J in X'Range loop - Hash_State.Swap (X (J)'Address); - end loop; - end if; - - -- 1. Prepare message schedule - - W (0 .. 15) := X; - - for T in 16 .. Rounds - 1 loop - W (T) := S1 (W (T - 2)) + W (T - 7) + S0 (W (T - 15)) + W (T - 16); - end loop; - - -- 2. Initialize working variables - - A := H_St (0); - B := H_St (1); - C := H_St (2); - D := H_St (3); - E := H_St (4); - F := H_St (5); - G := H_St (6); - H := H_St (7); - - -- 3. Perform transformation rounds - - for T in 0 .. Rounds - 1 loop - T1 := H + Sigma1 (E) + Ch (E, F, G) + K (T) + W (T); - T2 := Sigma0 (A) + Maj (A, B, C); - H := G; - G := F; - F := E; - E := D + T1; - D := C; - C := B; - B := A; - A := T1 + T2; - end loop; - - -- 4. Update hash state - - H_St (0) := A + H_St (0); - H_St (1) := B + H_St (1); - H_St (2) := C + H_St (2); - H_St (3) := D + H_St (3); - H_St (4) := E + H_St (4); - H_St (5) := F + H_St (5); - H_St (6) := G + H_St (6); - H_St (7) := H + H_St (7); - end Transform; - -end GNAT.Secure_Hashes.SHA2_Common; diff --git a/gcc/ada/g-shshco.ads b/gcc/ada/g-shshco.ads deleted file mode 100644 index e2f9f91..0000000 --- a/gcc/ada/g-shshco.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S E C U R E _ H A S H E S . S H A 2 _ C O M M O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides supporting code for implementation of the following --- secure hash functions described in FIPS PUB 180-3: SHA-224, SHA-256, --- SHA-384, SHA-512. It contains the generic transform operation that is --- common to the above four functions. The complete text of FIPS PUB 180-3 --- can be found at: --- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf - --- This is an internal unit and should not be used directly in applications. --- Use GNAT.SHA* instead. - -package GNAT.Secure_Hashes.SHA2_Common is - - Block_Words : constant := 16; - -- All functions operate on blocks of 16 words - - generic - with package Hash_State is new Hash_Function_State (<>); - - Rounds : Natural; - -- Number of transformation rounds - - K : Hash_State.State; - -- Constants used in the transform operation - - with function Sigma0 (X : Hash_State.Word) return Hash_State.Word is <>; - with function Sigma1 (X : Hash_State.Word) return Hash_State.Word is <>; - with function S0 (X : Hash_State.Word) return Hash_State.Word is <>; - with function S1 (X : Hash_State.Word) return Hash_State.Word is <>; - -- FIPS PUB 180-3 elementary functions - - procedure Transform - (H_St : in out Hash_State.State; - M_St : in out Message_State); - -end GNAT.Secure_Hashes.SHA2_Common; diff --git a/gcc/ada/g-soccon.ads b/gcc/ada/g-soccon.ads deleted file mode 100644 index 4b904d9..0000000 --- a/gcc/ada/g-soccon.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 temporary compatibility renaming for deprecated --- internal package GNAT.Sockets.Constants. - --- This package should not be directly used by an applications program. --- It is a compatibility artefact to help building legacy code with newer --- compilers, and will be removed at some point in the future. - -with System.OS_Constants; -package GNAT.Sockets.Constants renames System.OS_Constants; diff --git a/gcc/ada/g-socket-dummy.adb b/gcc/ada/g-socket-dummy.adb deleted file mode 100644 index b4a5622..0000000 --- a/gcc/ada/g-socket-dummy.adb +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma No_Body; diff --git a/gcc/ada/g-socket-dummy.ads b/gcc/ada/g-socket-dummy.ads deleted file mode 100644 index 5a24317..0000000 --- a/gcc/ada/g-socket-dummy.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a placeholder for the sockets binding for platforms where --- it is not implemented. - -package GNAT.Sockets is - pragma Unimplemented_Unit; -end GNAT.Sockets; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb deleted file mode 100644 index 9b2ad7f..0000000 --- a/gcc/ada/g-socket.adb +++ /dev/null @@ -1,2786 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Streams; use Ada.Streams; -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Finalization; -with Ada.Unchecked_Conversion; - -with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; -with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; - -with GNAT.Sockets.Linker_Options; -pragma Warnings (Off, GNAT.Sockets.Linker_Options); --- Need to include pragma Linker_Options which is platform dependent - -with System; use System; -with System.Communication; use System.Communication; -with System.CRTL; use System.CRTL; -with System.Task_Lock; - -package body GNAT.Sockets is - - package C renames Interfaces.C; - - ENOERROR : constant := 0; - - Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; - Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0; - -- The network database functions gethostbyname, gethostbyaddr, - -- getservbyname and getservbyport can either be guaranteed task safe by - -- the operating system, or else return data through a user-provided buffer - -- to ensure concurrent uses do not interfere. - - -- Correspondence tables - - Levels : constant array (Level_Type) of C.int := - (Socket_Level => SOSC.SOL_SOCKET, - IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP, - IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP, - IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP); - - Modes : constant array (Mode_Type) of C.int := - (Socket_Stream => SOSC.SOCK_STREAM, - Socket_Datagram => SOSC.SOCK_DGRAM); - - Shutmodes : constant array (Shutmode_Type) of C.int := - (Shut_Read => SOSC.SHUT_RD, - Shut_Write => SOSC.SHUT_WR, - Shut_Read_Write => SOSC.SHUT_RDWR); - - Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T := - (Non_Blocking_IO => SOSC.FIONBIO, - N_Bytes_To_Read => SOSC.FIONREAD); - - Options : constant array (Specific_Option_Name) of C.int := - (Keep_Alive => SOSC.SO_KEEPALIVE, - Reuse_Address => SOSC.SO_REUSEADDR, - Broadcast => SOSC.SO_BROADCAST, - Send_Buffer => SOSC.SO_SNDBUF, - Receive_Buffer => SOSC.SO_RCVBUF, - Linger => SOSC.SO_LINGER, - Error => SOSC.SO_ERROR, - No_Delay => SOSC.TCP_NODELAY, - Add_Membership => SOSC.IP_ADD_MEMBERSHIP, - Drop_Membership => SOSC.IP_DROP_MEMBERSHIP, - Multicast_If => SOSC.IP_MULTICAST_IF, - Multicast_TTL => SOSC.IP_MULTICAST_TTL, - Multicast_Loop => SOSC.IP_MULTICAST_LOOP, - Receive_Packet_Info => SOSC.IP_PKTINFO, - Send_Timeout => SOSC.SO_SNDTIMEO, - Receive_Timeout => SOSC.SO_RCVTIMEO, - Busy_Polling => SOSC.SO_BUSY_POLL); - -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO, - -- but for Linux compatibility this constant is the same as IP_PKTINFO. - - Flags : constant array (0 .. 3) of C.int := - (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data - 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data - 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception - 3 => SOSC.MSG_EOR); -- Send_End_Of_Record - - Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; - Host_Error_Id : constant Exception_Id := Host_Error'Identity; - - Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; - -- Use to print in hexadecimal format - - ----------------------- - -- Local subprograms -- - ----------------------- - - function Resolve_Error - (Error_Value : Integer; - From_Errno : Boolean := True) return Error_Type; - -- Associate an enumeration value (error_type) to an error value (errno). - -- From_Errno prevents from mixing h_errno with errno. - - function To_Name (N : String) return Name_Type; - function To_String (HN : Name_Type) return String; - -- Conversion functions - - function To_Int (F : Request_Flag_Type) return C.int; - -- Return the int value corresponding to the specified flags combination - - function Set_Forced_Flags (F : C.int) return C.int; - -- Return F with the bits from SOSC.MSG_Forced_Flags forced set - - function Short_To_Network - (S : C.unsigned_short) return C.unsigned_short; - pragma Inline (Short_To_Network); - -- Convert a port number into a network port number - - function Network_To_Short - (S : C.unsigned_short) return C.unsigned_short - renames Short_To_Network; - -- Symmetric operation - - function Image - (Val : Inet_Addr_VN_Type; - Hex : Boolean := False) return String; - -- Output an array of inet address components in hex or decimal mode - - function Is_IP_Address (Name : String) return Boolean; - -- Return true when Name is an IPv4 address in dotted quad notation - - procedure Netdb_Lock; - pragma Inline (Netdb_Lock); - procedure Netdb_Unlock; - pragma Inline (Netdb_Unlock); - -- Lock/unlock operation used to protect netdb access for platforms that - -- require such protection. - - function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr; - procedure To_Inet_Addr - (Addr : In_Addr; - Result : out Inet_Addr_Type); - -- Conversion functions - - function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type; - -- Conversion function - - function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; - -- Conversion function - - function Value (S : System.Address) return String; - -- Same as Interfaces.C.Strings.Value but taking a System.Address - - function To_Timeval (Val : Timeval_Duration) return Timeval; - -- Separate Val in seconds and microseconds - - function To_Duration (Val : Timeval) return Timeval_Duration; - -- Reconstruct a Duration value from a Timeval record (seconds and - -- microseconds). - - procedure Raise_Socket_Error (Error : Integer); - -- Raise Socket_Error with an exception message describing the error code - -- from errno. - - procedure Raise_Host_Error (H_Error : Integer; Name : String); - -- Raise Host_Error exception with message describing error code (note - -- hstrerror seems to be obsolete) from h_errno. Name is the name - -- or address that was being looked up. - - procedure Narrow (Item : in out Socket_Set_Type); - -- Update Last as it may be greater than the real last socket - - procedure Check_For_Fd_Set (Fd : Socket_Type); - pragma Inline (Check_For_Fd_Set); - -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to - -- FD_SETSIZE, on platforms where fd_set is a bitmap. - - function Connect_Socket - (Socket : Socket_Type; - Server : Sock_Addr_Type) return C.int; - pragma Inline (Connect_Socket); - -- Underlying implementation for the Connect_Socket procedures - - -- Types needed for Datagram_Socket_Stream_Type - - type Datagram_Socket_Stream_Type is new Root_Stream_Type with record - Socket : Socket_Type; - To : Sock_Addr_Type; - From : Sock_Addr_Type; - end record; - - type Datagram_Socket_Stream_Access is - access all Datagram_Socket_Stream_Type; - - procedure Read - (Stream : in out Datagram_Socket_Stream_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - procedure Write - (Stream : in out Datagram_Socket_Stream_Type; - Item : Ada.Streams.Stream_Element_Array); - - -- Types needed for Stream_Socket_Stream_Type - - type Stream_Socket_Stream_Type is new Root_Stream_Type with record - Socket : Socket_Type; - end record; - - type Stream_Socket_Stream_Access is - access all Stream_Socket_Stream_Type; - - procedure Read - (Stream : in out Stream_Socket_Stream_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - procedure Write - (Stream : in out Stream_Socket_Stream_Type; - Item : Ada.Streams.Stream_Element_Array); - - procedure Wait_On_Socket - (Socket : Socket_Type; - For_Read : Boolean; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status); - -- Common code for variants of socket operations supporting a timeout: - -- block in Check_Selector on Socket for at most the indicated timeout. - -- If For_Read is True, Socket is added to the read set for this call, else - -- it is added to the write set. If no selector is provided, a local one is - -- created for this call and destroyed prior to returning. - - type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled - with null record; - -- This type is used to generate automatic calls to Initialize and Finalize - -- during the elaboration and finalization of this package. A single object - -- of this type must exist at library level. - - function Err_Code_Image (E : Integer) return String; - -- Return the value of E surrounded with brackets - - procedure Initialize (X : in out Sockets_Library_Controller); - procedure Finalize (X : in out Sockets_Library_Controller); - - procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type); - -- If S is the empty set (detected by Last = No_Socket), make sure its - -- fd_set component is actually cleared. Note that the case where it is - -- not can occur for an uninitialized Socket_Set_Type object. - - function Is_Open (S : Selector_Type) return Boolean; - -- Return True for an "open" Selector_Type object, i.e. one for which - -- Create_Selector has been called and Close_Selector has not been called, - -- or the null selector. - - --------- - -- "+" -- - --------- - - function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is - begin - return L or R; - end "+"; - - -------------------- - -- Abort_Selector -- - -------------------- - - procedure Abort_Selector (Selector : Selector_Type) is - Res : C.int; - - begin - if not Is_Open (Selector) then - raise Program_Error with "closed selector"; - - elsif Selector.Is_Null then - raise Program_Error with "null selector"; - - end if; - - -- Send one byte to unblock select system call - - Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket)); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - end Abort_Selector; - - ------------------- - -- Accept_Socket -- - ------------------- - - procedure Accept_Socket - (Server : Socket_Type; - Socket : out Socket_Type; - Address : out Sock_Addr_Type) - is - Res : C.int; - Sin : aliased Sockaddr_In; - Len : aliased C.int := Sin'Size / 8; - - begin - Res := C_Accept (C.int (Server), Sin'Address, Len'Access); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - Socket := Socket_Type (Res); - - To_Inet_Addr (Sin.Sin_Addr, Address.Addr); - Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); - end Accept_Socket; - - ------------------- - -- Accept_Socket -- - ------------------- - - procedure Accept_Socket - (Server : Socket_Type; - Socket : out Socket_Type; - Address : out Sock_Addr_Type; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status) - is - begin - if Selector /= null and then not Is_Open (Selector.all) then - raise Program_Error with "closed selector"; - end if; - - -- Wait for socket to become available for reading - - Wait_On_Socket - (Socket => Server, - For_Read => True, - Timeout => Timeout, - Selector => Selector, - Status => Status); - - -- Accept connection if available - - if Status = Completed then - Accept_Socket (Server, Socket, Address); - else - Socket := No_Socket; - end if; - end Accept_Socket; - - --------------- - -- Addresses -- - --------------- - - function Addresses - (E : Host_Entry_Type; - N : Positive := 1) return Inet_Addr_Type - is - begin - return E.Addresses (N); - end Addresses; - - ---------------------- - -- Addresses_Length -- - ---------------------- - - function Addresses_Length (E : Host_Entry_Type) return Natural is - begin - return E.Addresses_Length; - end Addresses_Length; - - ------------- - -- Aliases -- - ------------- - - function Aliases - (E : Host_Entry_Type; - N : Positive := 1) return String - is - begin - return To_String (E.Aliases (N)); - end Aliases; - - ------------- - -- Aliases -- - ------------- - - function Aliases - (S : Service_Entry_Type; - N : Positive := 1) return String - is - begin - return To_String (S.Aliases (N)); - end Aliases; - - -------------------- - -- Aliases_Length -- - -------------------- - - function Aliases_Length (E : Host_Entry_Type) return Natural is - begin - return E.Aliases_Length; - end Aliases_Length; - - -------------------- - -- Aliases_Length -- - -------------------- - - function Aliases_Length (S : Service_Entry_Type) return Natural is - begin - return S.Aliases_Length; - end Aliases_Length; - - ----------------- - -- Bind_Socket -- - ----------------- - - procedure Bind_Socket - (Socket : Socket_Type; - Address : Sock_Addr_Type) - is - Res : C.int; - Sin : aliased Sockaddr_In; - Len : constant C.int := Sin'Size / 8; - -- This assumes that Address.Family = Family_Inet??? - - begin - if Address.Family = Family_Inet6 then - raise Socket_Error with "IPv6 not supported"; - end if; - - Set_Family (Sin.Sin_Family, Address.Family); - Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); - Set_Port - (Sin'Unchecked_Access, - Short_To_Network (C.unsigned_short (Address.Port))); - - Res := C_Bind (C.int (Socket), Sin'Address, Len); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - end Bind_Socket; - - ---------------------- - -- Check_For_Fd_Set -- - ---------------------- - - procedure Check_For_Fd_Set (Fd : Socket_Type) is - use SOSC; - - begin - -- On Windows, fd_set is a FD_SETSIZE array of socket ids: - -- no check required. Warnings suppressed because condition - -- is known at compile time. - - if Target_OS = Windows then - - return; - - -- On other platforms, fd_set is an FD_SETSIZE bitmap: check - -- that Fd is within range (otherwise behavior is undefined). - - elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then - raise Constraint_Error - with "invalid value for socket set: " & Image (Fd); - end if; - end Check_For_Fd_Set; - - -------------------- - -- Check_Selector -- - -------------------- - - procedure Check_Selector - (Selector : Selector_Type; - R_Socket_Set : in out Socket_Set_Type; - W_Socket_Set : in out Socket_Set_Type; - Status : out Selector_Status; - Timeout : Selector_Duration := Forever) - is - E_Socket_Set : Socket_Set_Type; - begin - Check_Selector - (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); - end Check_Selector; - - procedure Check_Selector - (Selector : Selector_Type; - R_Socket_Set : in out Socket_Set_Type; - W_Socket_Set : in out Socket_Set_Type; - E_Socket_Set : in out Socket_Set_Type; - Status : out Selector_Status; - Timeout : Selector_Duration := Forever) - is - Res : C.int; - Last : C.int; - RSig : Socket_Type := No_Socket; - TVal : aliased Timeval; - TPtr : Timeval_Access; - - begin - if not Is_Open (Selector) then - raise Program_Error with "closed selector"; - end if; - - Status := Completed; - - -- No timeout or Forever is indicated by a null timeval pointer - - if Timeout = Forever then - TPtr := null; - else - TVal := To_Timeval (Timeout); - TPtr := TVal'Unchecked_Access; - end if; - - -- Add read signalling socket, if present - - if not Selector.Is_Null then - RSig := Selector.R_Sig_Socket; - Set (R_Socket_Set, RSig); - end if; - - Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last), - C.int (W_Socket_Set.Last)), - C.int (E_Socket_Set.Last)); - - -- Zero out fd_set for empty Socket_Set_Type objects - - Normalize_Empty_Socket_Set (R_Socket_Set); - Normalize_Empty_Socket_Set (W_Socket_Set); - Normalize_Empty_Socket_Set (E_Socket_Set); - - Res := - C_Select - (Last + 1, - R_Socket_Set.Set'Access, - W_Socket_Set.Set'Access, - E_Socket_Set.Set'Access, - TPtr); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - -- If Select was resumed because of read signalling socket, read this - -- data and remove socket from set. - - if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then - Clear (R_Socket_Set, RSig); - - Res := Signalling_Fds.Read (C.int (RSig)); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - Status := Aborted; - - elsif Res = 0 then - Status := Expired; - end if; - - -- Update socket sets in regard to their new contents - - Narrow (R_Socket_Set); - Narrow (W_Socket_Set); - Narrow (E_Socket_Set); - end Check_Selector; - - ----------- - -- Clear -- - ----------- - - procedure Clear - (Item : in out Socket_Set_Type; - Socket : Socket_Type) - is - Last : aliased C.int := C.int (Item.Last); - - begin - Check_For_Fd_Set (Socket); - - if Item.Last /= No_Socket then - Remove_Socket_From_Set (Item.Set'Access, C.int (Socket)); - Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); - Item.Last := Socket_Type (Last); - end if; - end Clear; - - -------------------- - -- Close_Selector -- - -------------------- - - procedure Close_Selector (Selector : in out Selector_Type) is - begin - -- Nothing to do if selector already in closed state - - if Selector.Is_Null or else not Is_Open (Selector) then - return; - end if; - - -- Close the signalling file descriptors used internally for the - -- implementation of Abort_Selector. - - Signalling_Fds.Close (C.int (Selector.R_Sig_Socket)); - Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); - - -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any - -- (erroneous) subsequent attempt to use this selector properly fails. - - Selector.R_Sig_Socket := No_Socket; - Selector.W_Sig_Socket := No_Socket; - end Close_Selector; - - ------------------ - -- Close_Socket -- - ------------------ - - procedure Close_Socket (Socket : Socket_Type) is - Res : C.int; - - begin - Res := C_Close (C.int (Socket)); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - end Close_Socket; - - -------------------- - -- Connect_Socket -- - -------------------- - - function Connect_Socket - (Socket : Socket_Type; - Server : Sock_Addr_Type) return C.int - is - Sin : aliased Sockaddr_In; - Len : constant C.int := Sin'Size / 8; - - begin - if Server.Family = Family_Inet6 then - raise Socket_Error with "IPv6 not supported"; - end if; - - Set_Family (Sin.Sin_Family, Server.Family); - Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr)); - Set_Port - (Sin'Unchecked_Access, - Short_To_Network (C.unsigned_short (Server.Port))); - - return C_Connect (C.int (Socket), Sin'Address, Len); - end Connect_Socket; - - procedure Connect_Socket - (Socket : Socket_Type; - Server : Sock_Addr_Type) - is - begin - if Connect_Socket (Socket, Server) = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - end Connect_Socket; - - procedure Connect_Socket - (Socket : Socket_Type; - Server : Sock_Addr_Type; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status) - is - Req : Request_Type; - -- Used to set Socket to non-blocking I/O - - Conn_Err : aliased Integer; - -- Error status of the socket after completion of select(2) - - Res : C.int; - Conn_Err_Size : aliased C.int := Conn_Err'Size / 8; - -- For getsockopt(2) call - - begin - if Selector /= null and then not Is_Open (Selector.all) then - raise Program_Error with "closed selector"; - end if; - - -- Set the socket to non-blocking I/O - - Req := (Name => Non_Blocking_IO, Enabled => True); - Control_Socket (Socket, Request => Req); - - -- Start operation (non-blocking), will return Failure with errno set - -- to EINPROGRESS. - - Res := Connect_Socket (Socket, Server); - if Res = Failure then - Conn_Err := Socket_Errno; - if Conn_Err /= SOSC.EINPROGRESS then - Raise_Socket_Error (Conn_Err); - end if; - end if; - - -- Wait for socket to become available for writing (unless the Timeout - -- is zero, in which case we consider that it has already expired, and - -- we do not need to wait at all). - - if Timeout = 0.0 then - Status := Expired; - - else - Wait_On_Socket - (Socket => Socket, - For_Read => False, - Timeout => Timeout, - Selector => Selector, - Status => Status); - end if; - - -- Check error condition (the asynchronous connect may have terminated - -- with an error, e.g. ECONNREFUSED) if select(2) completed. - - if Status = Completed then - Res := C_Getsockopt - (C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR, - Conn_Err'Address, Conn_Err_Size'Access); - - if Res /= 0 then - Conn_Err := Socket_Errno; - end if; - - else - Conn_Err := 0; - end if; - - -- Reset the socket to blocking I/O - - Req := (Name => Non_Blocking_IO, Enabled => False); - Control_Socket (Socket, Request => Req); - - -- Report error condition if any - - if Conn_Err /= 0 then - Raise_Socket_Error (Conn_Err); - end if; - end Connect_Socket; - - -------------------- - -- Control_Socket -- - -------------------- - - procedure Control_Socket - (Socket : Socket_Type; - Request : in out Request_Type) - is - Arg : aliased C.int; - Res : C.int; - - begin - case Request.Name is - when Non_Blocking_IO => - Arg := C.int (Boolean'Pos (Request.Enabled)); - - when N_Bytes_To_Read => - null; - end case; - - Res := Socket_Ioctl - (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - case Request.Name is - when Non_Blocking_IO => - null; - - when N_Bytes_To_Read => - Request.Size := Natural (Arg); - end case; - end Control_Socket; - - ---------- - -- Copy -- - ---------- - - procedure Copy - (Source : Socket_Set_Type; - Target : out Socket_Set_Type) - is - begin - Target := Source; - end Copy; - - --------------------- - -- Create_Selector -- - --------------------- - - procedure Create_Selector (Selector : out Selector_Type) is - Two_Fds : aliased Fd_Pair; - Res : C.int; - - begin - if Is_Open (Selector) then - -- Raise exception to prevent socket descriptor leak - - raise Program_Error with "selector already open"; - end if; - - -- We open two signalling file descriptors. One of them is used to send - -- data to the other, which is included in a C_Select socket set. The - -- communication is used to force a call to C_Select to complete, and - -- the waiting task to resume its execution. - - Res := Signalling_Fds.Create (Two_Fds'Access); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End)); - Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End)); - end Create_Selector; - - ------------------- - -- Create_Socket -- - ------------------- - - procedure Create_Socket - (Socket : out Socket_Type; - Family : Family_Type := Family_Inet; - Mode : Mode_Type := Socket_Stream) - is - Res : C.int; - - begin - Res := C_Socket (Families (Family), Modes (Mode), 0); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - Socket := Socket_Type (Res); - end Create_Socket; - - ----------- - -- Empty -- - ----------- - - procedure Empty (Item : out Socket_Set_Type) is - begin - Reset_Socket_Set (Item.Set'Access); - Item.Last := No_Socket; - end Empty; - - -------------------- - -- Err_Code_Image -- - -------------------- - - function Err_Code_Image (E : Integer) return String is - Msg : String := E'Img & "] "; - begin - Msg (Msg'First) := '['; - return Msg; - end Err_Code_Image; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (X : in out Sockets_Library_Controller) is - pragma Unreferenced (X); - - begin - -- Finalization operation for the GNAT.Sockets package - - Thin.Finalize; - end Finalize; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - -- This is a dummy placeholder for an obsolete API. - -- The real finalization actions are in Initialize primitive operation - -- of Sockets_Library_Controller. - - null; - end Finalize; - - --------- - -- Get -- - --------- - - procedure Get - (Item : in out Socket_Set_Type; - Socket : out Socket_Type) - is - S : aliased C.int; - L : aliased C.int := C.int (Item.Last); - - begin - if Item.Last /= No_Socket then - Get_Socket_From_Set - (Item.Set'Access, Last => L'Access, Socket => S'Access); - Item.Last := Socket_Type (L); - Socket := Socket_Type (S); - else - Socket := No_Socket; - end if; - end Get; - - ----------------- - -- Get_Address -- - ----------------- - - function Get_Address - (Stream : not null Stream_Access) return Sock_Addr_Type - is - begin - if Stream.all in Datagram_Socket_Stream_Type then - return Datagram_Socket_Stream_Type (Stream.all).From; - else - return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); - end if; - end Get_Address; - - ------------------------- - -- Get_Host_By_Address -- - ------------------------- - - function Get_Host_By_Address - (Address : Inet_Addr_Type; - Family : Family_Type := Family_Inet) return Host_Entry_Type - is - pragma Unreferenced (Family); - - HA : aliased In_Addr := To_In_Addr (Address); - Buflen : constant C.int := Netdb_Buffer_Size; - Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); - Res : aliased Hostent; - Err : aliased C.int; - - begin - Netdb_Lock; - - if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, - Res'Access, Buf'Address, Buflen, Err'Access) /= 0 - then - Netdb_Unlock; - Raise_Host_Error (Integer (Err), Image (Address)); - end if; - - begin - return H : constant Host_Entry_Type := - To_Host_Entry (Res'Unchecked_Access) - do - Netdb_Unlock; - end return; - exception - when others => - Netdb_Unlock; - raise; - end; - end Get_Host_By_Address; - - ---------------------- - -- Get_Host_By_Name -- - ---------------------- - - function Get_Host_By_Name (Name : String) return Host_Entry_Type is - begin - -- If the given name actually is the string representation of - -- an IP address, use Get_Host_By_Address instead. - - if Is_IP_Address (Name) then - return Get_Host_By_Address (Inet_Addr (Name)); - end if; - - declare - HN : constant C.char_array := C.To_C (Name); - Buflen : constant C.int := Netdb_Buffer_Size; - Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); - Res : aliased Hostent; - Err : aliased C.int; - - begin - Netdb_Lock; - - if C_Gethostbyname - (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 - then - Netdb_Unlock; - Raise_Host_Error (Integer (Err), Name); - end if; - - return H : constant Host_Entry_Type := - To_Host_Entry (Res'Unchecked_Access) - do - Netdb_Unlock; - end return; - end; - end Get_Host_By_Name; - - ------------------- - -- Get_Peer_Name -- - ------------------- - - function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is - Sin : aliased Sockaddr_In; - Len : aliased C.int := Sin'Size / 8; - Res : Sock_Addr_Type (Family_Inet); - - begin - if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - To_Inet_Addr (Sin.Sin_Addr, Res.Addr); - Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); - - return Res; - end Get_Peer_Name; - - ------------------------- - -- Get_Service_By_Name -- - ------------------------- - - function Get_Service_By_Name - (Name : String; - Protocol : String) return Service_Entry_Type - is - SN : constant C.char_array := C.To_C (Name); - SP : constant C.char_array := C.To_C (Protocol); - Buflen : constant C.int := Netdb_Buffer_Size; - Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); - Res : aliased Servent; - - begin - Netdb_Lock; - - if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then - Netdb_Unlock; - raise Service_Error with "Service not found"; - end if; - - -- Translate from the C format to the API format - - return S : constant Service_Entry_Type := - To_Service_Entry (Res'Unchecked_Access) - do - Netdb_Unlock; - end return; - end Get_Service_By_Name; - - ------------------------- - -- Get_Service_By_Port -- - ------------------------- - - function Get_Service_By_Port - (Port : Port_Type; - Protocol : String) return Service_Entry_Type - is - SP : constant C.char_array := C.To_C (Protocol); - Buflen : constant C.int := Netdb_Buffer_Size; - Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); - Res : aliased Servent; - - begin - Netdb_Lock; - - if C_Getservbyport - (C.int (Short_To_Network (C.unsigned_short (Port))), SP, - Res'Access, Buf'Address, Buflen) /= 0 - then - Netdb_Unlock; - raise Service_Error with "Service not found"; - end if; - - -- Translate from the C format to the API format - - return S : constant Service_Entry_Type := - To_Service_Entry (Res'Unchecked_Access) - do - Netdb_Unlock; - end return; - end Get_Service_By_Port; - - --------------------- - -- Get_Socket_Name -- - --------------------- - - function Get_Socket_Name - (Socket : Socket_Type) return Sock_Addr_Type - is - Sin : aliased Sockaddr_In; - Len : aliased C.int := Sin'Size / 8; - Res : C.int; - Addr : Sock_Addr_Type := No_Sock_Addr; - - begin - Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access); - - if Res /= Failure then - To_Inet_Addr (Sin.Sin_Addr, Addr.Addr); - Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); - end if; - - return Addr; - end Get_Socket_Name; - - ----------------------- - -- Get_Socket_Option -- - ----------------------- - - function Get_Socket_Option - (Socket : Socket_Type; - Level : Level_Type := Socket_Level; - Name : Option_Name; - Optname : Interfaces.C.int := -1) return Option_Type - is - use SOSC; - use type C.unsigned_char; - - V8 : aliased Two_Ints; - V4 : aliased C.int; - V1 : aliased C.unsigned_char; - VT : aliased Timeval; - Len : aliased C.int; - Add : System.Address; - Res : C.int; - Opt : Option_Type (Name); - Onm : Interfaces.C.int; - - begin - if Name in Specific_Option_Name then - Onm := Options (Name); - - elsif Optname = -1 then - raise Socket_Error with "optname must be specified"; - - else - Onm := Optname; - end if; - - case Name is - when Multicast_Loop - | Multicast_TTL - | Receive_Packet_Info - => - Len := V1'Size / 8; - Add := V1'Address; - - when Broadcast - | Busy_Polling - | Error - | Generic_Option - | Keep_Alive - | Multicast_If - | No_Delay - | Receive_Buffer - | Reuse_Address - | Send_Buffer - => - Len := V4'Size / 8; - Add := V4'Address; - - when Receive_Timeout - | Send_Timeout - => - -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a - -- struct timeval, but on Windows it is a milliseconds count in - -- a DWORD. - - if Target_OS = Windows then - Len := V4'Size / 8; - Add := V4'Address; - - else - Len := VT'Size / 8; - Add := VT'Address; - end if; - - when Add_Membership - | Drop_Membership - | Linger - => - Len := V8'Size / 8; - Add := V8'Address; - end case; - - Res := - C_Getsockopt - (C.int (Socket), - Levels (Level), - Onm, - Add, Len'Access); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - case Name is - when Generic_Option => - Opt.Optname := Onm; - Opt.Optval := V4; - - when Broadcast - | Keep_Alive - | No_Delay - | Reuse_Address - => - Opt.Enabled := (V4 /= 0); - - when Busy_Polling => - Opt.Microseconds := Natural (V4); - - when Linger => - Opt.Enabled := (V8 (V8'First) /= 0); - Opt.Seconds := Natural (V8 (V8'Last)); - - when Receive_Buffer - | Send_Buffer - => - Opt.Size := Natural (V4); - - when Error => - Opt.Error := Resolve_Error (Integer (V4)); - - when Add_Membership - | Drop_Membership - => - To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address); - To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface); - - when Multicast_If => - To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If); - - when Multicast_TTL => - Opt.Time_To_Live := Integer (V1); - - when Multicast_Loop - | Receive_Packet_Info - => - Opt.Enabled := (V1 /= 0); - - when Receive_Timeout - | Send_Timeout - => - if Target_OS = Windows then - - -- Timeout is in milliseconds, actual value is 500 ms + - -- returned value (unless it is 0). - - if V4 = 0 then - Opt.Timeout := 0.0; - else - Opt.Timeout := Natural (V4) * 0.001 + 0.500; - end if; - - else - Opt.Timeout := To_Duration (VT); - end if; - end case; - - return Opt; - end Get_Socket_Option; - - --------------- - -- Host_Name -- - --------------- - - function Host_Name return String is - Name : aliased C.char_array (1 .. 64); - Res : C.int; - - begin - Res := C_Gethostname (Name'Address, Name'Length); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - return C.To_Ada (Name); - end Host_Name; - - ----------- - -- Image -- - ----------- - - function Image - (Val : Inet_Addr_VN_Type; - Hex : Boolean := False) return String - is - -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It - -- has at most a length of 3 plus one '.' character. - - Buffer : String (1 .. 4 * Val'Length); - Length : Natural := 1; - Separator : Character; - - procedure Img10 (V : Inet_Addr_Comp_Type); - -- Append to Buffer image of V in decimal format - - procedure Img16 (V : Inet_Addr_Comp_Type); - -- Append to Buffer image of V in hexadecimal format - - ----------- - -- Img10 -- - ----------- - - procedure Img10 (V : Inet_Addr_Comp_Type) is - Img : constant String := V'Img; - Len : constant Natural := Img'Length - 1; - begin - Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last); - Length := Length + Len; - end Img10; - - ----------- - -- Img16 -- - ----------- - - procedure Img16 (V : Inet_Addr_Comp_Type) is - begin - Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1); - Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1); - Length := Length + 2; - end Img16; - - -- Start of processing for Image - - begin - Separator := (if Hex then ':' else '.'); - - for J in Val'Range loop - if Hex then - Img16 (Val (J)); - else - Img10 (Val (J)); - end if; - - if J /= Val'Last then - Buffer (Length) := Separator; - Length := Length + 1; - end if; - end loop; - - return Buffer (1 .. Length - 1); - end Image; - - ----------- - -- Image -- - ----------- - - function Image (Value : Inet_Addr_Type) return String is - begin - if Value.Family = Family_Inet then - return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); - else - return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); - end if; - end Image; - - ----------- - -- Image -- - ----------- - - function Image (Value : Sock_Addr_Type) return String is - Port : constant String := Value.Port'Img; - begin - return Image (Value.Addr) & ':' & Port (2 .. Port'Last); - end Image; - - ----------- - -- Image -- - ----------- - - function Image (Socket : Socket_Type) return String is - begin - return Socket'Img; - end Image; - - ----------- - -- Image -- - ----------- - - function Image (Item : Socket_Set_Type) return String is - Socket_Set : Socket_Set_Type := Item; - - begin - declare - Last_Img : constant String := Socket_Set.Last'Img; - Buffer : String - (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length); - Index : Positive := 1; - Socket : Socket_Type; - - begin - while not Is_Empty (Socket_Set) loop - Get (Socket_Set, Socket); - - declare - Socket_Img : constant String := Socket'Img; - begin - Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img; - Index := Index + Socket_Img'Length; - end; - end loop; - - return "[" & Last_Img & "]" & Buffer (1 .. Index - 1); - end; - end Image; - - --------------- - -- Inet_Addr -- - --------------- - - function Inet_Addr (Image : String) return Inet_Addr_Type is - use Interfaces.C; - - Img : aliased char_array := To_C (Image); - Addr : aliased C.int; - Res : C.int; - Result : Inet_Addr_Type; - - begin - -- Special case for an empty Image as on some platforms (e.g. Windows) - -- calling Inet_Addr("") will not return an error. - - if Image = "" then - Raise_Socket_Error (SOSC.EINVAL); - end if; - - Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address); - - if Res < 0 then - Raise_Socket_Error (Socket_Errno); - - elsif Res = 0 then - Raise_Socket_Error (SOSC.EINVAL); - end if; - - To_Inet_Addr (To_In_Addr (Addr), Result); - return Result; - end Inet_Addr; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (X : in out Sockets_Library_Controller) is - pragma Unreferenced (X); - - begin - Thin.Initialize; - end Initialize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Process_Blocking_IO : Boolean) is - Expected : constant Boolean := not SOSC.Thread_Blocking_IO; - - begin - if Process_Blocking_IO /= Expected then - raise Socket_Error with - "incorrect Process_Blocking_IO setting, expected " & Expected'Img; - end if; - - -- This is a dummy placeholder for an obsolete API - - -- Real initialization actions are in Initialize primitive operation - -- of Sockets_Library_Controller. - - null; - end Initialize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - -- This is a dummy placeholder for an obsolete API - - -- Real initialization actions are in Initialize primitive operation - -- of Sockets_Library_Controller. - - null; - end Initialize; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty (Item : Socket_Set_Type) return Boolean is - begin - return Item.Last = No_Socket; - end Is_Empty; - - ------------------- - -- Is_IP_Address -- - ------------------- - - function Is_IP_Address (Name : String) return Boolean is - Dots : Natural := 0; - - begin - -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots, - -- and there must be at least one digit around each. - - for J in Name'Range loop - if Name (J) = '.' then - - -- Check that the dot is not in first or last position, and that - -- it is followed by a digit. Note that we already know that it is - -- preceded by a digit, or we would have returned earlier on. - - if J in Name'First + 1 .. Name'Last - 1 - and then Name (J + 1) in '0' .. '9' - then - Dots := Dots + 1; - - -- Definitely not a proper dotted quad - - else - return False; - end if; - - elsif Name (J) not in '0' .. '9' then - return False; - end if; - end loop; - - return Dots in 1 .. 3; - end Is_IP_Address; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (S : Selector_Type) return Boolean is - begin - if S.Is_Null then - return True; - - else - -- Either both controlling socket descriptors are valid (case of an - -- open selector) or neither (case of a closed selector). - - pragma Assert ((S.R_Sig_Socket /= No_Socket) - = - (S.W_Sig_Socket /= No_Socket)); - - return S.R_Sig_Socket /= No_Socket; - end if; - end Is_Open; - - ------------ - -- Is_Set -- - ------------ - - function Is_Set - (Item : Socket_Set_Type; - Socket : Socket_Type) return Boolean - is - begin - Check_For_Fd_Set (Socket); - - return Item.Last /= No_Socket - and then Socket <= Item.Last - and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0; - end Is_Set; - - ------------------- - -- Listen_Socket -- - ------------------- - - procedure Listen_Socket - (Socket : Socket_Type; - Length : Natural := 15) - is - Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); - begin - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - end Listen_Socket; - - ------------ - -- Narrow -- - ------------ - - procedure Narrow (Item : in out Socket_Set_Type) is - Last : aliased C.int := C.int (Item.Last); - begin - if Item.Last /= No_Socket then - Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); - Item.Last := Socket_Type (Last); - end if; - end Narrow; - - ---------------- - -- Netdb_Lock -- - ---------------- - - procedure Netdb_Lock is - begin - if Need_Netdb_Lock then - System.Task_Lock.Lock; - end if; - end Netdb_Lock; - - ------------------ - -- Netdb_Unlock -- - ------------------ - - procedure Netdb_Unlock is - begin - if Need_Netdb_Lock then - System.Task_Lock.Unlock; - end if; - end Netdb_Unlock; - - -------------------------------- - -- Normalize_Empty_Socket_Set -- - -------------------------------- - - procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is - begin - if S.Last = No_Socket then - Reset_Socket_Set (S.Set'Access); - end if; - end Normalize_Empty_Socket_Set; - - ------------------- - -- Official_Name -- - ------------------- - - function Official_Name (E : Host_Entry_Type) return String is - begin - return To_String (E.Official); - end Official_Name; - - ------------------- - -- Official_Name -- - ------------------- - - function Official_Name (S : Service_Entry_Type) return String is - begin - return To_String (S.Official); - end Official_Name; - - -------------------- - -- Wait_On_Socket -- - -------------------- - - procedure Wait_On_Socket - (Socket : Socket_Type; - For_Read : Boolean; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status) - is - type Local_Selector_Access is access Selector_Type; - for Local_Selector_Access'Storage_Size use Selector_Type'Size; - - S : Selector_Access; - -- Selector to use for waiting - - R_Fd_Set : Socket_Set_Type; - W_Fd_Set : Socket_Set_Type; - - begin - -- Create selector if not provided by the user - - if Selector = null then - declare - Local_S : constant Local_Selector_Access := new Selector_Type; - begin - S := Local_S.all'Unchecked_Access; - Create_Selector (S.all); - end; - - else - S := Selector.all'Access; - end if; - - if For_Read then - Set (R_Fd_Set, Socket); - else - Set (W_Fd_Set, Socket); - end if; - - Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); - - if Selector = null then - Close_Selector (S.all); - end if; - end Wait_On_Socket; - - ----------------- - -- Port_Number -- - ----------------- - - function Port_Number (S : Service_Entry_Type) return Port_Type is - begin - return S.Port; - end Port_Number; - - ------------------- - -- Protocol_Name -- - ------------------- - - function Protocol_Name (S : Service_Entry_Type) return String is - begin - return To_String (S.Protocol); - end Protocol_Name; - - ---------------------- - -- Raise_Host_Error -- - ---------------------- - - procedure Raise_Host_Error (H_Error : Integer; Name : String) is - function Dedot (Value : String) return String is - (if Value /= "" and then Value (Value'Last) = '.' then - Value (Value'First .. Value'Last - 1) - else - Value); - -- Removes dot at the end of error message - - begin - raise Host_Error with - Err_Code_Image (H_Error) - & Dedot (Host_Error_Messages.Host_Error_Message (H_Error)) - & ": " & Name; - end Raise_Host_Error; - - ------------------------ - -- Raise_Socket_Error -- - ------------------------ - - procedure Raise_Socket_Error (Error : Integer) is - begin - raise Socket_Error with - Err_Code_Image (Error) & Socket_Error_Message (Error); - end Raise_Socket_Error; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : in out Datagram_Socket_Stream_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - begin - Receive_Socket - (Stream.Socket, - Item, - Last, - Stream.From); - end Read; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : in out Stream_Socket_Stream_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - First : Ada.Streams.Stream_Element_Offset := Item'First; - Index : Ada.Streams.Stream_Element_Offset := First - 1; - Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; - - begin - loop - Receive_Socket (Stream.Socket, Item (First .. Max), Index); - Last := Index; - - -- Exit when all or zero data received. Zero means that the socket - -- peer is closed. - - exit when Index < First or else Index = Max; - - First := Index + 1; - end loop; - end Read; - - -------------------- - -- Receive_Socket -- - -------------------- - - procedure Receive_Socket - (Socket : Socket_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Flags : Request_Flag_Type := No_Request_Flag) - is - Res : C.int; - - begin - Res := - C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags)); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - Last := Last_Index (First => Item'First, Count => size_t (Res)); - end Receive_Socket; - - -------------------- - -- Receive_Socket -- - -------------------- - - procedure Receive_Socket - (Socket : Socket_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - From : out Sock_Addr_Type; - Flags : Request_Flag_Type := No_Request_Flag) - is - Res : C.int; - Sin : aliased Sockaddr_In; - Len : aliased C.int := Sin'Size / 8; - - begin - Res := - C_Recvfrom - (C.int (Socket), - Item'Address, - Item'Length, - To_Int (Flags), - Sin'Address, - Len'Access); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - Last := Last_Index (First => Item'First, Count => size_t (Res)); - - To_Inet_Addr (Sin.Sin_Addr, From.Addr); - From.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); - end Receive_Socket; - - -------------------- - -- Receive_Vector -- - -------------------- - - procedure Receive_Vector - (Socket : Socket_Type; - Vector : Vector_Type; - Count : out Ada.Streams.Stream_Element_Count; - Flags : Request_Flag_Type := No_Request_Flag) - is - Res : ssize_t; - - Msg : Msghdr := - (Msg_Name => System.Null_Address, - Msg_Namelen => 0, - Msg_Iov => Vector'Address, - - -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other - -- platforms) when the supplied vector is longer than IOV_MAX, - -- so use minimum of the two lengths. - - Msg_Iovlen => SOSC.Msg_Iovlen_T'Min - (Vector'Length, SOSC.IOV_MAX), - - Msg_Control => System.Null_Address, - Msg_Controllen => 0, - Msg_Flags => 0); - - begin - Res := - C_Recvmsg - (C.int (Socket), - Msg'Address, - To_Int (Flags)); - - if Res = ssize_t (Failure) then - Raise_Socket_Error (Socket_Errno); - end if; - - Count := Ada.Streams.Stream_Element_Count (Res); - end Receive_Vector; - - ------------------- - -- Resolve_Error -- - ------------------- - - function Resolve_Error - (Error_Value : Integer; - From_Errno : Boolean := True) return Error_Type - is - use GNAT.Sockets.SOSC; - - begin - if not From_Errno then - case Error_Value is - when SOSC.HOST_NOT_FOUND => return Unknown_Host; - when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure; - when SOSC.NO_RECOVERY => return Non_Recoverable_Error; - when SOSC.NO_DATA => return Unknown_Server_Error; - when others => return Cannot_Resolve_Error; - end case; - end if; - - -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we - -- can't include it in the case statement below. - - pragma Warnings (Off); - -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time - - if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then - return Resource_Temporarily_Unavailable; - end if; - - -- This is not a case statement because if a particular error - -- number constant is not defined, s-oscons-tmplt.c defines - -- it to -1. If multiple constants are not defined, they - -- would each be -1 and result in a "duplicate value in case" error. - -- - -- But we have to leave warnings off because the compiler is also - -- smart enough to note that when two errnos have the same value, - -- the second if condition is useless. - if Error_Value = ENOERROR then - return Success; - elsif Error_Value = EACCES then - return Permission_Denied; - elsif Error_Value = EADDRINUSE then - return Address_Already_In_Use; - elsif Error_Value = EADDRNOTAVAIL then - return Cannot_Assign_Requested_Address; - elsif Error_Value = EAFNOSUPPORT then - return Address_Family_Not_Supported_By_Protocol; - elsif Error_Value = EALREADY then - return Operation_Already_In_Progress; - elsif Error_Value = EBADF then - return Bad_File_Descriptor; - elsif Error_Value = ECONNABORTED then - return Software_Caused_Connection_Abort; - elsif Error_Value = ECONNREFUSED then - return Connection_Refused; - elsif Error_Value = ECONNRESET then - return Connection_Reset_By_Peer; - elsif Error_Value = EDESTADDRREQ then - return Destination_Address_Required; - elsif Error_Value = EFAULT then - return Bad_Address; - elsif Error_Value = EHOSTDOWN then - return Host_Is_Down; - elsif Error_Value = EHOSTUNREACH then - return No_Route_To_Host; - elsif Error_Value = EINPROGRESS then - return Operation_Now_In_Progress; - elsif Error_Value = EINTR then - return Interrupted_System_Call; - elsif Error_Value = EINVAL then - return Invalid_Argument; - elsif Error_Value = EIO then - return Input_Output_Error; - elsif Error_Value = EISCONN then - return Transport_Endpoint_Already_Connected; - elsif Error_Value = ELOOP then - return Too_Many_Symbolic_Links; - elsif Error_Value = EMFILE then - return Too_Many_Open_Files; - elsif Error_Value = EMSGSIZE then - return Message_Too_Long; - elsif Error_Value = ENAMETOOLONG then - return File_Name_Too_Long; - elsif Error_Value = ENETDOWN then - return Network_Is_Down; - elsif Error_Value = ENETRESET then - return Network_Dropped_Connection_Because_Of_Reset; - elsif Error_Value = ENETUNREACH then - return Network_Is_Unreachable; - elsif Error_Value = ENOBUFS then - return No_Buffer_Space_Available; - elsif Error_Value = ENOPROTOOPT then - return Protocol_Not_Available; - elsif Error_Value = ENOTCONN then - return Transport_Endpoint_Not_Connected; - elsif Error_Value = ENOTSOCK then - return Socket_Operation_On_Non_Socket; - elsif Error_Value = EOPNOTSUPP then - return Operation_Not_Supported; - elsif Error_Value = EPFNOSUPPORT then - return Protocol_Family_Not_Supported; - elsif Error_Value = EPIPE then - return Broken_Pipe; - elsif Error_Value = EPROTONOSUPPORT then - return Protocol_Not_Supported; - elsif Error_Value = EPROTOTYPE then - return Protocol_Wrong_Type_For_Socket; - elsif Error_Value = ESHUTDOWN then - return Cannot_Send_After_Transport_Endpoint_Shutdown; - elsif Error_Value = ESOCKTNOSUPPORT then - return Socket_Type_Not_Supported; - elsif Error_Value = ETIMEDOUT then - return Connection_Timed_Out; - elsif Error_Value = ETOOMANYREFS then - return Too_Many_References; - elsif Error_Value = EWOULDBLOCK then - return Resource_Temporarily_Unavailable; - else - return Cannot_Resolve_Error; - end if; - pragma Warnings (On); - - end Resolve_Error; - - ----------------------- - -- Resolve_Exception -- - ----------------------- - - function Resolve_Exception - (Occurrence : Exception_Occurrence) return Error_Type - is - Id : constant Exception_Id := Exception_Identity (Occurrence); - Msg : constant String := Exception_Message (Occurrence); - First : Natural; - Last : Natural; - Val : Integer; - - begin - First := Msg'First; - while First <= Msg'Last - and then Msg (First) not in '0' .. '9' - loop - First := First + 1; - end loop; - - if First > Msg'Last then - return Cannot_Resolve_Error; - end if; - - Last := First; - while Last < Msg'Last - and then Msg (Last + 1) in '0' .. '9' - loop - Last := Last + 1; - end loop; - - Val := Integer'Value (Msg (First .. Last)); - - if Id = Socket_Error_Id then - return Resolve_Error (Val); - - elsif Id = Host_Error_Id then - return Resolve_Error (Val, False); - - else - return Cannot_Resolve_Error; - end if; - end Resolve_Exception; - - ----------------- - -- Send_Socket -- - ----------------- - - procedure Send_Socket - (Socket : Socket_Type; - Item : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Flags : Request_Flag_Type := No_Request_Flag) - is - begin - Send_Socket (Socket, Item, Last, To => null, Flags => Flags); - end Send_Socket; - - ----------------- - -- Send_Socket -- - ----------------- - - procedure Send_Socket - (Socket : Socket_Type; - Item : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - To : Sock_Addr_Type; - Flags : Request_Flag_Type := No_Request_Flag) - is - begin - Send_Socket - (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags); - end Send_Socket; - - ----------------- - -- Send_Socket -- - ----------------- - - procedure Send_Socket - (Socket : Socket_Type; - Item : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - To : access Sock_Addr_Type; - Flags : Request_Flag_Type := No_Request_Flag) - is - Res : C.int; - - Sin : aliased Sockaddr_In; - C_To : System.Address; - Len : C.int; - - begin - if To /= null then - Set_Family (Sin.Sin_Family, To.Family); - Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr)); - Set_Port - (Sin'Unchecked_Access, - Short_To_Network (C.unsigned_short (To.Port))); - C_To := Sin'Address; - Len := Sin'Size / 8; - - else - C_To := System.Null_Address; - Len := 0; - end if; - - Res := C_Sendto - (C.int (Socket), - Item'Address, - Item'Length, - Set_Forced_Flags (To_Int (Flags)), - C_To, - Len); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - - Last := Last_Index (First => Item'First, Count => size_t (Res)); - end Send_Socket; - - ----------------- - -- Send_Vector -- - ----------------- - - procedure Send_Vector - (Socket : Socket_Type; - Vector : Vector_Type; - Count : out Ada.Streams.Stream_Element_Count; - Flags : Request_Flag_Type := No_Request_Flag) - is - use SOSC; - use Interfaces.C; - - Res : ssize_t; - Iov_Count : SOSC.Msg_Iovlen_T; - This_Iov_Count : SOSC.Msg_Iovlen_T; - Msg : Msghdr; - - begin - Count := 0; - Iov_Count := 0; - while Iov_Count < Vector'Length loop - - pragma Warnings (Off); - -- Following test may be compile time known on some targets - - This_Iov_Count := - (if Vector'Length - Iov_Count > SOSC.IOV_MAX - then SOSC.IOV_MAX - else Vector'Length - Iov_Count); - - pragma Warnings (On); - - Msg := - (Msg_Name => System.Null_Address, - Msg_Namelen => 0, - Msg_Iov => Vector - (Vector'First + Integer (Iov_Count))'Address, - Msg_Iovlen => This_Iov_Count, - Msg_Control => System.Null_Address, - Msg_Controllen => 0, - Msg_Flags => 0); - - Res := - C_Sendmsg - (C.int (Socket), - Msg'Address, - Set_Forced_Flags (To_Int (Flags))); - - if Res = ssize_t (Failure) then - Raise_Socket_Error (Socket_Errno); - end if; - - Count := Count + Ada.Streams.Stream_Element_Count (Res); - Iov_Count := Iov_Count + This_Iov_Count; - end loop; - end Send_Vector; - - --------- - -- Set -- - --------- - - procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is - begin - Check_For_Fd_Set (Socket); - - if Item.Last = No_Socket then - - -- Uninitialized socket set, make sure it is properly zeroed out - - Reset_Socket_Set (Item.Set'Access); - Item.Last := Socket; - - elsif Item.Last < Socket then - Item.Last := Socket; - end if; - - Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); - end Set; - - ----------------------- - -- Set_Close_On_Exec -- - ----------------------- - - procedure Set_Close_On_Exec - (Socket : Socket_Type; - Close_On_Exec : Boolean; - Status : out Boolean) - is - function C_Set_Close_On_Exec - (Socket : Socket_Type; Close_On_Exec : C.int) return C.int; - pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); - begin - Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0; - end Set_Close_On_Exec; - - ---------------------- - -- Set_Forced_Flags -- - ---------------------- - - function Set_Forced_Flags (F : C.int) return C.int is - use type C.unsigned; - function To_unsigned is - new Ada.Unchecked_Conversion (C.int, C.unsigned); - function To_int is - new Ada.Unchecked_Conversion (C.unsigned, C.int); - begin - return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags); - end Set_Forced_Flags; - - ----------------------- - -- Set_Socket_Option -- - ----------------------- - - procedure Set_Socket_Option - (Socket : Socket_Type; - Level : Level_Type := Socket_Level; - Option : Option_Type) - is - use SOSC; - - V8 : aliased Two_Ints; - V4 : aliased C.int; - V1 : aliased C.unsigned_char; - VT : aliased Timeval; - Len : C.int; - Add : System.Address := Null_Address; - Res : C.int; - Onm : C.int; - - begin - case Option.Name is - when Generic_Option => - V4 := Option.Optval; - Len := V4'Size / 8; - Add := V4'Address; - - when Broadcast - | Keep_Alive - | No_Delay - | Reuse_Address - => - V4 := C.int (Boolean'Pos (Option.Enabled)); - Len := V4'Size / 8; - Add := V4'Address; - - when Busy_Polling => - V4 := C.int (Option.Microseconds); - Len := V4'Size / 8; - Add := V4'Address; - - when Linger => - V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); - V8 (V8'Last) := C.int (Option.Seconds); - Len := V8'Size / 8; - Add := V8'Address; - - when Receive_Buffer - | Send_Buffer - => - V4 := C.int (Option.Size); - Len := V4'Size / 8; - Add := V4'Address; - - when Error => - V4 := C.int (Boolean'Pos (True)); - Len := V4'Size / 8; - Add := V4'Address; - - when Add_Membership - | Drop_Membership - => - V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address)); - V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface)); - Len := V8'Size / 8; - Add := V8'Address; - - when Multicast_If => - V4 := To_Int (To_In_Addr (Option.Outgoing_If)); - Len := V4'Size / 8; - Add := V4'Address; - - when Multicast_TTL => - V1 := C.unsigned_char (Option.Time_To_Live); - Len := V1'Size / 8; - Add := V1'Address; - - when Multicast_Loop - | Receive_Packet_Info - => - V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); - Len := V1'Size / 8; - Add := V1'Address; - - when Receive_Timeout - | Send_Timeout - => - if Target_OS = Windows then - - -- On Windows, the timeout is a DWORD in milliseconds, and - -- the actual timeout is 500 ms + the given value (unless it - -- is 0). - - V4 := C.int (Option.Timeout / 0.001); - - if V4 > 500 then - V4 := V4 - 500; - - elsif V4 > 0 then - V4 := 1; - end if; - - Len := V4'Size / 8; - Add := V4'Address; - - else - VT := To_Timeval (Option.Timeout); - Len := VT'Size / 8; - Add := VT'Address; - end if; - end case; - - if Option.Name in Specific_Option_Name then - Onm := Options (Option.Name); - - elsif Option.Optname = -1 then - raise Socket_Error with "optname must be specified"; - - else - Onm := Option.Optname; - end if; - - Res := C_Setsockopt - (C.int (Socket), - Levels (Level), - Onm, - Add, Len); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - end Set_Socket_Option; - - ---------------------- - -- Short_To_Network -- - ---------------------- - - function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is - use type C.unsigned_short; - - begin - -- Big-endian case. No conversion needed. On these platforms, htons() - -- defaults to a null procedure. - - if Default_Bit_Order = High_Order_First then - return S; - - -- Little-endian case. We must swap the high and low bytes of this - -- short to make the port number network compliant. - - else - return (S / 256) + (S mod 256) * 256; - end if; - end Short_To_Network; - - --------------------- - -- Shutdown_Socket -- - --------------------- - - procedure Shutdown_Socket - (Socket : Socket_Type; - How : Shutmode_Type := Shut_Read_Write) - is - Res : C.int; - - begin - Res := C_Shutdown (C.int (Socket), Shutmodes (How)); - - if Res = Failure then - Raise_Socket_Error (Socket_Errno); - end if; - end Shutdown_Socket; - - ------------ - -- Stream -- - ------------ - - function Stream - (Socket : Socket_Type; - Send_To : Sock_Addr_Type) return Stream_Access - is - S : Datagram_Socket_Stream_Access; - - begin - S := new Datagram_Socket_Stream_Type; - S.Socket := Socket; - S.To := Send_To; - S.From := Get_Socket_Name (Socket); - return Stream_Access (S); - end Stream; - - ------------ - -- Stream -- - ------------ - - function Stream (Socket : Socket_Type) return Stream_Access is - S : Stream_Socket_Stream_Access; - begin - S := new Stream_Socket_Stream_Type; - S.Socket := Socket; - return Stream_Access (S); - end Stream; - - ------------ - -- To_Ada -- - ------------ - - function To_Ada (Fd : Integer) return Socket_Type is - begin - return Socket_Type (Fd); - end To_Ada; - - ---------- - -- To_C -- - ---------- - - function To_C (Socket : Socket_Type) return Integer is - begin - return Integer (Socket); - end To_C; - - ----------------- - -- To_Duration -- - ----------------- - - function To_Duration (Val : Timeval) return Timeval_Duration is - begin - return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6; - end To_Duration; - - ------------------- - -- To_Host_Entry -- - ------------------- - - function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is - use type C.size_t; - - Aliases_Count, Addresses_Count : Natural; - - -- H_Length is not used because it is currently only ever set to 4, as - -- we only handle the case of H_Addrtype being AF_INET. - - begin - if Hostent_H_Addrtype (E) /= SOSC.AF_INET then - Raise_Socket_Error (SOSC.EPFNOSUPPORT); - end if; - - Aliases_Count := 0; - while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop - Aliases_Count := Aliases_Count + 1; - end loop; - - Addresses_Count := 0; - while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop - Addresses_Count := Addresses_Count + 1; - end loop; - - return Result : Host_Entry_Type - (Aliases_Length => Aliases_Count, - Addresses_Length => Addresses_Count) - do - Result.Official := To_Name (Value (Hostent_H_Name (E))); - - for J in Result.Aliases'Range loop - Result.Aliases (J) := - To_Name (Value (Hostent_H_Alias - (E, C.int (J - Result.Aliases'First)))); - end loop; - - for J in Result.Addresses'Range loop - declare - Addr : In_Addr; - - -- Hostent_H_Addr (E, ) may return an address that is - -- not correctly aligned for In_Addr, so we need to use - -- an intermediate copy operation on a type with an alignment - -- of 1 to recover the value. - - subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8); - Unaligned_Addr : Addr_Buf_T; - for Unaligned_Addr'Address - use Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); - pragma Import (Ada, Unaligned_Addr); - - Aligned_Addr : Addr_Buf_T; - for Aligned_Addr'Address use Addr'Address; - pragma Import (Ada, Aligned_Addr); - - begin - Aligned_Addr := Unaligned_Addr; - To_Inet_Addr (Addr, Result.Addresses (J)); - end; - end loop; - end return; - end To_Host_Entry; - - ---------------- - -- To_In_Addr -- - ---------------- - - function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is - begin - if Addr.Family = Family_Inet then - return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), - S_B2 => C.unsigned_char (Addr.Sin_V4 (2)), - S_B3 => C.unsigned_char (Addr.Sin_V4 (3)), - S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); - end if; - - raise Socket_Error with "IPv6 not supported"; - end To_In_Addr; - - ------------------ - -- To_Inet_Addr -- - ------------------ - - procedure To_Inet_Addr - (Addr : In_Addr; - Result : out Inet_Addr_Type) is - begin - Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1); - Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2); - Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3); - Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4); - end To_Inet_Addr; - - ------------ - -- To_Int -- - ------------ - - function To_Int (F : Request_Flag_Type) return C.int - is - Current : Request_Flag_Type := F; - Result : C.int := 0; - - begin - for J in Flags'Range loop - exit when Current = 0; - - if Current mod 2 /= 0 then - if Flags (J) = -1 then - Raise_Socket_Error (SOSC.EOPNOTSUPP); - end if; - - Result := Result + Flags (J); - end if; - - Current := Current / 2; - end loop; - - return Result; - end To_Int; - - ------------- - -- To_Name -- - ------------- - - function To_Name (N : String) return Name_Type is - begin - return Name_Type'(N'Length, N); - end To_Name; - - ---------------------- - -- To_Service_Entry -- - ---------------------- - - function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is - Aliases_Count : Natural; - - begin - Aliases_Count := 0; - while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop - Aliases_Count := Aliases_Count + 1; - end loop; - - return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do - Result.Official := To_Name (Value (Servent_S_Name (E))); - - for J in Result.Aliases'Range loop - Result.Aliases (J) := - To_Name (Value (Servent_S_Alias - (E, C.int (J - Result.Aliases'First)))); - end loop; - - Result.Protocol := To_Name (Value (Servent_S_Proto (E))); - Result.Port := - Port_Type (Network_To_Short (Servent_S_Port (E))); - end return; - end To_Service_Entry; - - --------------- - -- To_String -- - --------------- - - function To_String (HN : Name_Type) return String is - begin - return HN.Name (1 .. HN.Length); - end To_String; - - ---------------- - -- To_Timeval -- - ---------------- - - function To_Timeval (Val : Timeval_Duration) return Timeval is - S : time_t; - uS : suseconds_t; - - begin - -- If zero, set result as zero (otherwise it gets rounded down to -1) - - if Val = 0.0 then - S := 0; - uS := 0; - - -- Normal case where we do round down - - else - S := time_t (Val - 0.5); - uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S))); - end if; - - return (S, uS); - end To_Timeval; - - ----------- - -- Value -- - ----------- - - function Value (S : System.Address) return String is - Str : String (1 .. Positive'Last); - for Str'Address use S; - pragma Import (Ada, Str); - - Terminator : Positive := Str'First; - - begin - while Str (Terminator) /= ASCII.NUL loop - Terminator := Terminator + 1; - end loop; - - return Str (1 .. Terminator - 1); - end Value; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : in out Datagram_Socket_Stream_Type; - Item : Ada.Streams.Stream_Element_Array) - is - Last : Stream_Element_Offset; - - begin - Send_Socket - (Stream.Socket, - Item, - Last, - Stream.To); - - -- It is an error if not all of the data has been sent - - if Last /= Item'Last then - Raise_Socket_Error (Socket_Errno); - end if; - end Write; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : in out Stream_Socket_Stream_Type; - Item : Ada.Streams.Stream_Element_Array) - is - First : Ada.Streams.Stream_Element_Offset; - Index : Ada.Streams.Stream_Element_Offset; - Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; - - begin - First := Item'First; - Index := First - 1; - while First <= Max loop - Send_Socket (Stream.Socket, Item (First .. Max), Index, null); - - -- Exit when all or zero data sent. Zero means that the socket has - -- been closed by peer. - - exit when Index < First or else Index = Max; - - First := Index + 1; - end loop; - - -- For an empty array, we have First > Max, and hence Index >= Max (no - -- error, the loop above is never executed). After a successful send, - -- Index = Max. The only remaining case, Index < Max, is therefore - -- always an actual send failure. - - if Index < Max then - Raise_Socket_Error (Socket_Errno); - end if; - end Write; - - Sockets_Library_Controller_Object : Sockets_Library_Controller; - pragma Unreferenced (Sockets_Library_Controller_Object); - -- The elaboration and finalization of this object perform the required - -- initialization and cleanup actions for the sockets library. - -end GNAT.Sockets; diff --git a/gcc/ada/g-socket.ads b/gcc/ada/g-socket.ads deleted file mode 100644 index 06d7a85..0000000 --- a/gcc/ada/g-socket.ads +++ /dev/null @@ -1,1288 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface to the sockets communication facility --- provided on many operating systems. This is implemented on the following --- platforms: - --- All native ports, with restrictions as follows - --- Multicast is available only on systems which provide support for this --- feature, so it is not available if Multicast is not supported, or not --- installed. - --- VxWorks cross ports fully implement this package - --- This package is not yet implemented on LynxOS or other cross ports - -with Ada.Exceptions; -with Ada.Streams; -with Ada.Unchecked_Deallocation; - -with Interfaces.C; - -with System.OS_Constants; -with System.Storage_Elements; - -package GNAT.Sockets is - - -- Sockets are designed to provide a consistent communication facility - -- between applications. This package provides an Ada binding to the - -- de-facto standard BSD sockets API. The documentation below covers - -- only the specific binding provided by this package. It assumes that - -- the reader is already familiar with general network programming and - -- sockets usage. A useful reference on this matter is W. Richard Stevens' - -- "UNIX Network Programming: The Sockets Networking API" - -- (ISBN: 0131411551). - - -- GNAT.Sockets has been designed with several ideas in mind - - -- This is a system independent interface. Therefore, we try as much as - -- possible to mask system incompatibilities. Some functionalities are not - -- available because there are not fully supported on some systems. - - -- This is a thick binding. For instance, a major effort has been done to - -- avoid using memory addresses or untyped ints. We preferred to define - -- streams and enumeration types. Errors are not returned as returned - -- values but as exceptions. - - -- This package provides a POSIX-compliant interface (between two - -- different implementations of the same routine, we adopt the one closest - -- to the POSIX specification). For instance, using select(), the - -- notification of an asynchronous connect failure is delivered in the - -- write socket set (POSIX) instead of the exception socket set (NT). - - -- The example below demonstrates various features of GNAT.Sockets: - - -- with GNAT.Sockets; use GNAT.Sockets; - - -- with Ada.Text_IO; - -- with Ada.Exceptions; use Ada.Exceptions; - - -- procedure PingPong is - - -- Group : constant String := "239.255.128.128"; - -- -- Multicast group: administratively scoped IP address - - -- task Pong is - -- entry Start; - -- entry Stop; - -- end Pong; - - -- task body Pong is - -- Address : Sock_Addr_Type; - -- Server : Socket_Type; - -- Socket : Socket_Type; - -- Channel : Stream_Access; - - -- begin - -- -- Get an Internet address of a host (here the local host name). - -- -- Note that a host can have several addresses. Here we get - -- -- the first one which is supposed to be the official one. - - -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); - - -- -- Get a socket address that is an Internet address and a port - - -- Address.Port := 5876; - - -- -- The first step is to create a socket. Once created, this - -- -- socket must be associated to with an address. Usually only a - -- -- server (Pong here) needs to bind an address explicitly. Most - -- -- of the time clients can skip this step because the socket - -- -- routines will bind an arbitrary address to an unbound socket. - - -- Create_Socket (Server); - - -- -- Allow reuse of local addresses - - -- Set_Socket_Option - -- (Server, - -- Socket_Level, - -- (Reuse_Address, True)); - - -- Bind_Socket (Server, Address); - - -- -- A server marks a socket as willing to receive connect events - - -- Listen_Socket (Server); - - -- -- Once a server calls Listen_Socket, incoming connects events - -- -- can be accepted. The returned Socket is a new socket that - -- -- represents the server side of the connection. Server remains - -- -- available to receive further connections. - - -- accept Start; - - -- Accept_Socket (Server, Socket, Address); - - -- -- Return a stream associated to the connected socket - - -- Channel := Stream (Socket); - - -- -- Force Pong to block - - -- delay 0.2; - - -- -- Receive and print message from client Ping - - -- declare - -- Message : String := String'Input (Channel); - - -- begin - -- Ada.Text_IO.Put_Line (Message); - - -- -- Send same message back to client Ping - - -- String'Output (Channel, Message); - -- end; - - -- Close_Socket (Server); - -- Close_Socket (Socket); - - -- -- Part of the multicast example - - -- -- Create a datagram socket to send connectionless, unreliable - -- -- messages of a fixed maximum length. - - -- Create_Socket (Socket, Family_Inet, Socket_Datagram); - - -- -- Allow reuse of local addresses - - -- Set_Socket_Option - -- (Socket, - -- Socket_Level, - -- (Reuse_Address, True)); - - -- -- Controls the live time of the datagram to avoid it being - -- -- looped forever due to routing errors. Routers decrement - -- -- the TTL of every datagram as it traverses from one network - -- -- to another and when its value reaches 0 the packet is - -- -- dropped. Default is 1. - - -- Set_Socket_Option - -- (Socket, - -- IP_Protocol_For_IP_Level, - -- (Multicast_TTL, 1)); - - -- -- Want the data you send to be looped back to your host - - -- Set_Socket_Option - -- (Socket, - -- IP_Protocol_For_IP_Level, - -- (Multicast_Loop, True)); - - -- -- If this socket is intended to receive messages, bind it - -- -- to a given socket address. - - -- Address.Addr := Any_Inet_Addr; - -- Address.Port := 55505; - - -- Bind_Socket (Socket, Address); - - -- -- Join a multicast group - - -- -- Portability note: On Windows, this option may be set only - -- -- on a bound socket. - - -- Set_Socket_Option - -- (Socket, - -- IP_Protocol_For_IP_Level, - -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); - - -- -- If this socket is intended to send messages, provide the - -- -- receiver socket address. - - -- Address.Addr := Inet_Addr (Group); - -- Address.Port := 55506; - - -- Channel := Stream (Socket, Address); - - -- -- Receive and print message from client Ping - - -- declare - -- Message : String := String'Input (Channel); - - -- begin - -- -- Get the address of the sender - - -- Address := Get_Address (Channel); - -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); - - -- -- Send same message back to client Ping - - -- String'Output (Channel, Message); - -- end; - - -- Close_Socket (Socket); - - -- accept Stop; - - -- exception when E : others => - -- Ada.Text_IO.Put_Line - -- (Exception_Name (E) & ": " & Exception_Message (E)); - -- end Pong; - - -- task Ping is - -- entry Start; - -- entry Stop; - -- end Ping; - - -- task body Ping is - -- Address : Sock_Addr_Type; - -- Socket : Socket_Type; - -- Channel : Stream_Access; - - -- begin - -- accept Start; - - -- -- See comments in Ping section for the first steps - - -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); - -- Address.Port := 5876; - -- Create_Socket (Socket); - - -- Set_Socket_Option - -- (Socket, - -- Socket_Level, - -- (Reuse_Address, True)); - - -- -- Force Ping to block - - -- delay 0.2; - - -- -- If the client's socket is not bound, Connect_Socket will - -- -- bind to an unused address. The client uses Connect_Socket to - -- -- create a logical connection between the client's socket and - -- -- a server's socket returned by Accept_Socket. - - -- Connect_Socket (Socket, Address); - - -- Channel := Stream (Socket); - - -- -- Send message to server Pong - - -- String'Output (Channel, "Hello world"); - - -- -- Force Ping to block - - -- delay 0.2; - - -- -- Receive and print message from server Pong - - -- Ada.Text_IO.Put_Line (String'Input (Channel)); - -- Close_Socket (Socket); - - -- -- Part of multicast example. Code similar to Pong's one - - -- Create_Socket (Socket, Family_Inet, Socket_Datagram); - - -- Set_Socket_Option - -- (Socket, - -- Socket_Level, - -- (Reuse_Address, True)); - - -- Set_Socket_Option - -- (Socket, - -- IP_Protocol_For_IP_Level, - -- (Multicast_TTL, 1)); - - -- Set_Socket_Option - -- (Socket, - -- IP_Protocol_For_IP_Level, - -- (Multicast_Loop, True)); - - -- Address.Addr := Any_Inet_Addr; - -- Address.Port := 55506; - - -- Bind_Socket (Socket, Address); - - -- Set_Socket_Option - -- (Socket, - -- IP_Protocol_For_IP_Level, - -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); - - -- Address.Addr := Inet_Addr (Group); - -- Address.Port := 55505; - - -- Channel := Stream (Socket, Address); - - -- -- Send message to server Pong - - -- String'Output (Channel, "Hello world"); - - -- -- Receive and print message from server Pong - - -- declare - -- Message : String := String'Input (Channel); - - -- begin - -- Address := Get_Address (Channel); - -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); - -- end; - - -- Close_Socket (Socket); - - -- accept Stop; - - -- exception when E : others => - -- Ada.Text_IO.Put_Line - -- (Exception_Name (E) & ": " & Exception_Message (E)); - -- end Ping; - - -- begin - -- Initialize; - -- Ping.Start; - -- Pong.Start; - -- Ping.Stop; - -- Pong.Stop; - -- Finalize; - -- end PingPong; - - package SOSC renames System.OS_Constants; - -- Renaming used to provide short-hand notations throughout the sockets - -- binding. Note that System.OS_Constants is an internal unit, and the - -- entities declared therein are not meant for direct access by users, - -- including through this renaming. - - use type Interfaces.C.int; - -- Need visibility on "-" operator so that we can write -1 - - procedure Initialize; - pragma Obsolescent - (Entity => Initialize, - Message => "explicit initialization is no longer required"); - -- Initialize must be called before using any other socket routines. - -- Note that this operation is a no-op on UNIX platforms, but applications - -- should make sure to call it if portability is expected: some platforms - -- (such as Windows) require initialization before any socket operation. - -- This is now a no-op (initialization and finalization are done - -- automatically). - - procedure Initialize (Process_Blocking_IO : Boolean); - pragma Obsolescent - (Entity => Initialize, - Message => "passing a parameter to Initialize is no longer supported"); - -- Previous versions of GNAT.Sockets used to require the user to indicate - -- whether socket I/O was process- or thread-blocking on the platform. - -- This property is now determined automatically when the run-time library - -- is built. The old version of Initialize, taking a parameter, is kept - -- for compatibility reasons, but this interface is obsolete (and if the - -- value given is wrong, an exception will be raised at run time). - -- This is now a no-op (initialization and finalization are done - -- automatically). - - procedure Finalize; - pragma Obsolescent - (Entity => Finalize, - Message => "explicit finalization is no longer required"); - -- After Finalize is called it is not possible to use any routines - -- exported in by this package. This procedure is idempotent. - -- This is now a no-op (initialization and finalization are done - -- automatically). - - type Socket_Type is private; - -- Sockets are used to implement a reliable bi-directional point-to-point, - -- stream-based connections between hosts. No_Socket provides a special - -- value to denote uninitialized sockets. - - No_Socket : constant Socket_Type; - - type Selector_Type is limited private; - type Selector_Access is access all Selector_Type; - -- Selector objects are used to wait for i/o events to occur on sockets - - Null_Selector : constant Selector_Type; - -- The Null_Selector can be used in place of a normal selector without - -- having to call Create_Selector if the use of Abort_Selector is not - -- required. - - -- Timeval_Duration is a subtype of Standard.Duration because the full - -- range of Standard.Duration cannot be represented in the equivalent C - -- structure (struct timeval). Moreover, negative values are not allowed - -- to avoid system incompatibilities. - - Immediate : constant Duration := 0.0; - - Forever : constant Duration := - Duration'Min (Duration'Last, 1.0 * SOSC.MAX_tv_sec); - -- Largest possible Duration that is also a valid value for struct timeval - - subtype Timeval_Duration is Duration range Immediate .. Forever; - - subtype Selector_Duration is Timeval_Duration; - -- Timeout value for selector operations - - type Selector_Status is (Completed, Expired, Aborted); - -- Completion status of a selector operation, indicated as follows: - -- Complete: one of the expected events occurred - -- Expired: no event occurred before the expiration of the timeout - -- Aborted: an external action cancelled the wait operation before - -- any event occurred. - - Socket_Error : exception; - -- There is only one exception in this package to deal with an error during - -- a socket routine. Once raised, its message contains a string describing - -- the error code. - - function Image (Socket : Socket_Type) return String; - -- Return a printable string for Socket - - function To_Ada (Fd : Integer) return Socket_Type with Inline; - -- Convert a file descriptor to Socket_Type. This is useful when a socket - -- file descriptor is obtained from an external library call. - - function To_C (Socket : Socket_Type) return Integer with Inline; - -- Return a file descriptor to be used by external subprograms. This is - -- useful for C functions that are not yet interfaced in this package. - - type Family_Type is (Family_Inet, Family_Inet6); - -- Address family (or protocol family) identifies the communication domain - -- and groups protocols with similar address formats. - - type Mode_Type is (Socket_Stream, Socket_Datagram); - -- Stream sockets provide connection-oriented byte streams. Datagram - -- sockets support unreliable connectionless message based communication. - - type Shutmode_Type is (Shut_Read, Shut_Write, Shut_Read_Write); - -- When a process closes a socket, the policy is to retain any data queued - -- until either a delivery or a timeout expiration (in this case, the data - -- are discarded). A finer control is available through shutdown. With - -- Shut_Read, no more data can be received from the socket. With_Write, no - -- more data can be transmitted. Neither transmission nor reception can be - -- performed with Shut_Read_Write. - - type Port_Type is range 0 .. 16#ffff#; - -- TCP/UDP port number - - Any_Port : constant Port_Type; - -- All ports - - No_Port : constant Port_Type; - -- Uninitialized port number - - type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; - -- An Internet address depends on an address family (IPv4 contains 4 octets - -- and IPv6 contains 16 octets). Any_Inet_Addr is a special value treated - -- like a wildcard enabling all addresses. No_Inet_Addr provides a special - -- value to denote uninitialized inet addresses. - - Any_Inet_Addr : constant Inet_Addr_Type; - No_Inet_Addr : constant Inet_Addr_Type; - Broadcast_Inet_Addr : constant Inet_Addr_Type; - Loopback_Inet_Addr : constant Inet_Addr_Type; - - -- Useful constants for IPv4 multicast addresses - - Unspecified_Group_Inet_Addr : constant Inet_Addr_Type; - All_Hosts_Group_Inet_Addr : constant Inet_Addr_Type; - All_Routers_Group_Inet_Addr : constant Inet_Addr_Type; - - type Sock_Addr_Type (Family : Family_Type := Family_Inet) is record - Addr : Inet_Addr_Type (Family); - Port : Port_Type; - end record; - pragma No_Component_Reordering (Sock_Addr_Type); - -- Socket addresses fully define a socket connection with protocol family, - -- an Internet address and a port. No_Sock_Addr provides a special value - -- for uninitialized socket addresses. - - No_Sock_Addr : constant Sock_Addr_Type; - - function Image (Value : Inet_Addr_Type) return String; - -- Return an image of an Internet address. IPv4 notation consists in 4 - -- octets in decimal format separated by dots. IPv6 notation consists in - -- 16 octets in hexadecimal format separated by colons (and possibly - -- dots). - - function Image (Value : Sock_Addr_Type) return String; - -- Return inet address image and port image separated by a colon - - function Inet_Addr (Image : String) return Inet_Addr_Type; - -- Convert address image from numbers-and-dots notation into an - -- inet address. - - -- Host entries provide complete information on a given host: the official - -- name, an array of alternative names or aliases and array of network - -- addresses. - - type Host_Entry_Type - (Aliases_Length, Addresses_Length : Natural) is private; - - function Official_Name (E : Host_Entry_Type) return String; - -- Return official name in host entry - - function Aliases_Length (E : Host_Entry_Type) return Natural; - -- Return number of aliases in host entry - - function Addresses_Length (E : Host_Entry_Type) return Natural; - -- Return number of addresses in host entry - - function Aliases - (E : Host_Entry_Type; - N : Positive := 1) return String; - -- Return N'th aliases in host entry. The first index is 1 - - function Addresses - (E : Host_Entry_Type; - N : Positive := 1) return Inet_Addr_Type; - -- Return N'th addresses in host entry. The first index is 1 - - Host_Error : exception; - -- Exception raised by the two following procedures. Once raised, its - -- message contains a string describing the error code. This exception is - -- raised when an host entry cannot be retrieved. - - function Get_Host_By_Address - (Address : Inet_Addr_Type; - Family : Family_Type := Family_Inet) return Host_Entry_Type; - -- Return host entry structure for the given Inet address. Note that no - -- result will be returned if there is no mapping of this IP address to a - -- host name in the system tables (host database, DNS or otherwise). - - function Get_Host_By_Name - (Name : String) return Host_Entry_Type; - -- Return host entry structure for the given host name. Here name is - -- either a host name, or an IP address. If Name is an IP address, this - -- is equivalent to Get_Host_By_Address (Inet_Addr (Name)). - - function Host_Name return String; - -- Return the name of the current host - - type Service_Entry_Type (Aliases_Length : Natural) is private; - -- Service entries provide complete information on a given service: the - -- official name, an array of alternative names or aliases and the port - -- number. - - function Official_Name (S : Service_Entry_Type) return String; - -- Return official name in service entry - - function Port_Number (S : Service_Entry_Type) return Port_Type; - -- Return port number in service entry - - function Protocol_Name (S : Service_Entry_Type) return String; - -- Return Protocol in service entry (usually UDP or TCP) - - function Aliases_Length (S : Service_Entry_Type) return Natural; - -- Return number of aliases in service entry - - function Aliases - (S : Service_Entry_Type; - N : Positive := 1) return String; - -- Return N'th aliases in service entry (the first index is 1) - - function Get_Service_By_Name - (Name : String; - Protocol : String) return Service_Entry_Type; - -- Return service entry structure for the given service name - - function Get_Service_By_Port - (Port : Port_Type; - Protocol : String) return Service_Entry_Type; - -- Return service entry structure for the given service port number - - Service_Error : exception; - -- Comment required ??? - - -- Errors are described by an enumeration type. There is only one exception - -- Socket_Error in this package to deal with an error during a socket - -- routine. Once raised, its message contains the error code between - -- brackets and a string describing the error code. - - -- The name of the enumeration constant documents the error condition - -- Note that on some platforms, a single error value is used for both - -- EWOULDBLOCK and EAGAIN. Both errors are therefore always reported as - -- Resource_Temporarily_Unavailable. - - type Error_Type is - (Success, - Permission_Denied, - Address_Already_In_Use, - Cannot_Assign_Requested_Address, - Address_Family_Not_Supported_By_Protocol, - Operation_Already_In_Progress, - Bad_File_Descriptor, - Software_Caused_Connection_Abort, - Connection_Refused, - Connection_Reset_By_Peer, - Destination_Address_Required, - Bad_Address, - Host_Is_Down, - No_Route_To_Host, - Operation_Now_In_Progress, - Interrupted_System_Call, - Invalid_Argument, - Input_Output_Error, - Transport_Endpoint_Already_Connected, - Too_Many_Symbolic_Links, - Too_Many_Open_Files, - Message_Too_Long, - File_Name_Too_Long, - Network_Is_Down, - Network_Dropped_Connection_Because_Of_Reset, - Network_Is_Unreachable, - No_Buffer_Space_Available, - Protocol_Not_Available, - Transport_Endpoint_Not_Connected, - Socket_Operation_On_Non_Socket, - Operation_Not_Supported, - Protocol_Family_Not_Supported, - Protocol_Not_Supported, - Protocol_Wrong_Type_For_Socket, - Cannot_Send_After_Transport_Endpoint_Shutdown, - Socket_Type_Not_Supported, - Connection_Timed_Out, - Too_Many_References, - Resource_Temporarily_Unavailable, - Broken_Pipe, - Unknown_Host, - Host_Name_Lookup_Failure, - Non_Recoverable_Error, - Unknown_Server_Error, - Cannot_Resolve_Error); - - -- Get_Socket_Options and Set_Socket_Options manipulate options associated - -- with a socket. Options may exist at multiple protocol levels in the - -- communication stack. Socket_Level is the uppermost socket level. - - type Level_Type is - (Socket_Level, - IP_Protocol_For_IP_Level, - IP_Protocol_For_UDP_Level, - IP_Protocol_For_TCP_Level); - - -- There are several options available to manipulate sockets. Each option - -- has a name and several values available. Most of the time, the value is - -- a boolean to enable or disable this option. - - type Option_Name is - (Generic_Option, - Keep_Alive, -- Enable sending of keep-alive messages - Reuse_Address, -- Allow bind to reuse local address - Broadcast, -- Enable datagram sockets to recv/send broadcasts - Send_Buffer, -- Set/get the maximum socket send buffer in bytes - Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes - Linger, -- Shutdown wait for msg to be sent or timeout occur - Error, -- Get and clear the pending socket error - No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) - Add_Membership, -- Join a multicast group - Drop_Membership, -- Leave a multicast group - Multicast_If, -- Set default out interface for multicast packets - Multicast_TTL, -- Set the time-to-live of sent multicast packets - Multicast_Loop, -- Sent multicast packets are looped to local socket - Receive_Packet_Info, -- Receive low level packet info as ancillary data - Send_Timeout, -- Set timeout value for output - Receive_Timeout, -- Set timeout value for input - Busy_Polling); -- Set busy polling mode - subtype Specific_Option_Name is - Option_Name range Keep_Alive .. Option_Name'Last; - - type Option_Type (Name : Option_Name := Keep_Alive) is record - case Name is - when Generic_Option => - Optname : Interfaces.C.int := -1; - Optval : Interfaces.C.int; - - when Keep_Alive | - Reuse_Address | - Broadcast | - Linger | - No_Delay | - Receive_Packet_Info | - Multicast_Loop => - Enabled : Boolean; - - case Name is - when Linger => - Seconds : Natural; - when others => - null; - end case; - - when Busy_Polling => - Microseconds : Natural; - - when Send_Buffer | - Receive_Buffer => - Size : Natural; - - when Error => - Error : Error_Type; - - when Add_Membership | - Drop_Membership => - Multicast_Address : Inet_Addr_Type; - Local_Interface : Inet_Addr_Type; - - when Multicast_If => - Outgoing_If : Inet_Addr_Type; - - when Multicast_TTL => - Time_To_Live : Natural; - - when Send_Timeout | - Receive_Timeout => - Timeout : Timeval_Duration; - - end case; - end record; - - -- There are several controls available to manipulate sockets. Each option - -- has a name and several values available. These controls differ from the - -- socket options in that they are not specific to sockets but are - -- available for any device. - - type Request_Name is - (Non_Blocking_IO, -- Cause a caller not to wait on blocking operations - N_Bytes_To_Read); -- Return the number of bytes available to read - - type Request_Type (Name : Request_Name := Non_Blocking_IO) is record - case Name is - when Non_Blocking_IO => - Enabled : Boolean; - - when N_Bytes_To_Read => - Size : Natural; - - end case; - end record; - - -- A request flag allows specification of the type of message transmissions - -- or receptions. A request flag can be combination of zero or more - -- predefined request flags. - - type Request_Flag_Type is private; - - No_Request_Flag : constant Request_Flag_Type; - -- This flag corresponds to the normal execution of an operation - - Process_Out_Of_Band_Data : constant Request_Flag_Type; - -- This flag requests that the receive or send function operates on - -- out-of-band data when the socket supports this notion (e.g. - -- Socket_Stream). - - Peek_At_Incoming_Data : constant Request_Flag_Type; - -- This flag causes the receive operation to return data from the beginning - -- of the receive queue without removing that data from the queue. A - -- subsequent receive call will return the same data. - - Wait_For_A_Full_Reception : constant Request_Flag_Type; - -- This flag requests that the operation block until the full request is - -- satisfied. However, the call may still return less data than requested - -- if a signal is caught, an error or disconnect occurs, or the next data - -- to be received is of a different type than that returned. Note that - -- this flag depends on support in the underlying sockets implementation, - -- and is not supported under Windows. - - Send_End_Of_Record : constant Request_Flag_Type; - -- This flag indicates that the entire message has been sent and so this - -- terminates the record. - - function "+" (L, R : Request_Flag_Type) return Request_Flag_Type; - -- Combine flag L with flag R - - type Stream_Element_Reference is access all Ada.Streams.Stream_Element; - - type Vector_Element is record - Base : Stream_Element_Reference; - Length : Interfaces.C.size_t; - end record; - - type Vector_Type is array (Integer range <>) of Vector_Element; - - procedure Create_Socket - (Socket : out Socket_Type; - Family : Family_Type := Family_Inet; - Mode : Mode_Type := Socket_Stream); - -- Create an endpoint for communication. Raises Socket_Error on error - - procedure Accept_Socket - (Server : Socket_Type; - Socket : out Socket_Type; - Address : out Sock_Addr_Type); - -- Extracts the first connection request on the queue of pending - -- connections, creates a new connected socket with mostly the same - -- properties as Server, and allocates a new socket. The returned Address - -- is filled in with the address of the connection. Raises Socket_Error on - -- error. Note: if Server is a non-blocking socket, whether or not this - -- aspect is inherited by Socket is platform-dependent. - - procedure Accept_Socket - (Server : Socket_Type; - Socket : out Socket_Type; - Address : out Sock_Addr_Type; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status); - -- Accept a new connection on Server using Accept_Socket, waiting no longer - -- than the given timeout duration. Status is set to indicate whether the - -- operation completed successfully, timed out, or was aborted. If Selector - -- is not null, the designated selector is used to wait for the socket to - -- become available, else a private selector object is created by this - -- procedure and destroyed before it returns. - - procedure Bind_Socket - (Socket : Socket_Type; - Address : Sock_Addr_Type); - -- Once a socket is created, assign a local address to it. Raise - -- Socket_Error on error. - - procedure Close_Socket (Socket : Socket_Type); - -- Close a socket and more specifically a non-connected socket - - procedure Connect_Socket - (Socket : Socket_Type; - Server : Sock_Addr_Type); - -- Make a connection to another socket which has the address of Server. - -- Raises Socket_Error on error. - - procedure Connect_Socket - (Socket : Socket_Type; - Server : Sock_Addr_Type; - Timeout : Selector_Duration; - Selector : access Selector_Type := null; - Status : out Selector_Status); - -- Connect Socket to the given Server address using Connect_Socket, waiting - -- no longer than the given timeout duration. Status is set to indicate - -- whether the operation completed successfully, timed out, or was aborted. - -- If Selector is not null, the designated selector is used to wait for the - -- socket to become available, else a private selector object is created - -- by this procedure and destroyed before it returns. If Timeout is 0.0, - -- no attempt is made to detect whether the connection has succeeded; it - -- is up to the user to determine this using Check_Selector later on. - - procedure Control_Socket - (Socket : Socket_Type; - Request : in out Request_Type); - -- Obtain or set parameter values that control the socket. This control - -- differs from the socket options in that they are not specific to sockets - -- but are available for any device. - - function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type; - -- Return the peer or remote socket address of a socket. Raise - -- Socket_Error on error. - - function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type; - -- Return the local or current socket address of a socket. Return - -- No_Sock_Addr on error (e.g. socket closed or not locally bound). - - function Get_Socket_Option - (Socket : Socket_Type; - Level : Level_Type := Socket_Level; - Name : Option_Name; - Optname : Interfaces.C.int := -1) return Option_Type; - -- Get the options associated with a socket. Raises Socket_Error on error. - -- Optname identifies specific option when Name is Generic_Option. - - procedure Listen_Socket - (Socket : Socket_Type; - Length : Natural := 15); - -- To accept connections, a socket is first created with Create_Socket, - -- a willingness to accept incoming connections and a queue Length for - -- incoming connections are specified. Raise Socket_Error on error. - -- The queue length of 15 is an example value that should be appropriate - -- in usual cases. It can be adjusted according to each application's - -- particular requirements. - - procedure Receive_Socket - (Socket : Socket_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Flags : Request_Flag_Type := No_Request_Flag); - -- Receive message from Socket. Last is the index value such that Item - -- (Last) is the last character assigned. Note that Last is set to - -- Item'First - 1 when the socket has been closed by peer. This is not - -- an error, and no exception is raised in this case unless Item'First - -- is Stream_Element_Offset'First, in which case Constraint_Error is - -- raised. Flags allows control of the reception. Raise Socket_Error on - -- error. - - procedure Receive_Socket - (Socket : Socket_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - From : out Sock_Addr_Type; - Flags : Request_Flag_Type := No_Request_Flag); - -- Receive message from Socket. If Socket is not connection-oriented, the - -- source address From of the message is filled in. Last is the index - -- value such that Item (Last) is the last character assigned. Flags - -- allows control of the reception. Raises Socket_Error on error. - - procedure Receive_Vector - (Socket : Socket_Type; - Vector : Vector_Type; - Count : out Ada.Streams.Stream_Element_Count; - Flags : Request_Flag_Type := No_Request_Flag); - -- Receive data from a socket and scatter it into the set of vector - -- elements Vector. Count is set to the count of received stream elements. - -- Flags allow control over reception. - - function Resolve_Exception - (Occurrence : Ada.Exceptions.Exception_Occurrence) return Error_Type; - -- When Socket_Error or Host_Error are raised, the exception message - -- contains the error code between brackets and a string describing the - -- error code. Resolve_Error extracts the error code from an exception - -- message and translate it into an enumeration value. - - procedure Send_Socket - (Socket : Socket_Type; - Item : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - To : access Sock_Addr_Type; - Flags : Request_Flag_Type := No_Request_Flag); - pragma Inline (Send_Socket); - -- Transmit a message over a socket. For a datagram socket, the address - -- is given by To.all. For a stream socket, To must be null. Last - -- is the index value such that Item (Last) is the last character - -- sent. Note that Last is set to Item'First - 1 if the socket has been - -- closed by the peer (unless Item'First is Stream_Element_Offset'First, - -- in which case Constraint_Error is raised instead). This is not an error, - -- and Socket_Error is not raised in that case. Flags allows control of the - -- transmission. Raises exception Socket_Error on error. Note: this - -- subprogram is inlined because it is also used to implement the two - -- variants below. - - procedure Send_Socket - (Socket : Socket_Type; - Item : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - Flags : Request_Flag_Type := No_Request_Flag); - -- Transmit a message over a socket. Upon return, Last is set to the index - -- within Item of the last element transmitted. Flags allows control of - -- the transmission. Raises Socket_Error on any detected error condition. - - procedure Send_Socket - (Socket : Socket_Type; - Item : Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset; - To : Sock_Addr_Type; - Flags : Request_Flag_Type := No_Request_Flag); - -- Transmit a message over a datagram socket. The destination address is - -- To. Flags allows control of the transmission. Raises Socket_Error on - -- error. - - procedure Send_Vector - (Socket : Socket_Type; - Vector : Vector_Type; - Count : out Ada.Streams.Stream_Element_Count; - Flags : Request_Flag_Type := No_Request_Flag); - -- Transmit data gathered from the set of vector elements Vector to a - -- socket. Count is set to the count of transmitted stream elements. Flags - -- allow control over transmission. - - procedure Set_Close_On_Exec - (Socket : Socket_Type; - Close_On_Exec : Boolean; - Status : out Boolean); - -- When Close_On_Exec is True, mark Socket to be closed automatically when - -- a new program is executed by the calling process (i.e. prevent Socket - -- from being inherited by child processes). When Close_On_Exec is False, - -- mark Socket to not be closed on exec (i.e. allow it to be inherited). - -- Status is False if the operation could not be performed, or is not - -- supported on the target platform. - - procedure Set_Socket_Option - (Socket : Socket_Type; - Level : Level_Type := Socket_Level; - Option : Option_Type); - -- Manipulate socket options. Raises Socket_Error on error - - procedure Shutdown_Socket - (Socket : Socket_Type; - How : Shutmode_Type := Shut_Read_Write); - -- Shutdown a connected socket. If How is Shut_Read further receives will - -- be disallowed. If How is Shut_Write further sends will be disallowed. - -- If How is Shut_Read_Write further sends and receives will be disallowed. - - type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class; - -- Same interface as Ada.Streams.Stream_IO - - function Stream (Socket : Socket_Type) return Stream_Access; - -- Create a stream associated with a connected stream-based socket. - -- Note: keep in mind that the default stream attributes for composite - -- types perform separate Read/Write operations for each component, - -- recursively. If performance is an issue, you may want to consider - -- introducing a buffering stage. - - function Stream - (Socket : Socket_Type; - Send_To : Sock_Addr_Type) return Stream_Access; - -- Create a stream associated with an already bound datagram-based socket. - -- Send_To is the destination address to which messages are being sent. - - function Get_Address - (Stream : not null Stream_Access) return Sock_Addr_Type; - -- Return the socket address from which the last message was received - - procedure Free is new Ada.Unchecked_Deallocation - (Ada.Streams.Root_Stream_Type'Class, Stream_Access); - -- Destroy a stream created by one of the Stream functions above, releasing - -- the corresponding resources. The user is responsible for calling this - -- subprogram when the stream is not needed anymore. - - type Socket_Set_Type is limited private; - -- This type allows manipulation of sets of sockets. It allows waiting - -- for events on multiple endpoints at one time. This type has default - -- initialization, and the default value is the empty set. - -- - -- Note: This type used to contain a pointer to dynamically allocated - -- storage, but this is not the case anymore, and no special precautions - -- are required to avoid memory leaks. - - procedure Clear (Item : in out Socket_Set_Type; Socket : Socket_Type); - -- Remove Socket from Item - - procedure Copy (Source : Socket_Set_Type; Target : out Socket_Set_Type); - -- Copy Source into Target as Socket_Set_Type is limited private - - procedure Empty (Item : out Socket_Set_Type); - -- Remove all Sockets from Item - - procedure Get (Item : in out Socket_Set_Type; Socket : out Socket_Type); - -- Extract a Socket from socket set Item. Socket is set to - -- No_Socket when the set is empty. - - function Is_Empty (Item : Socket_Set_Type) return Boolean; - -- Return True iff Item is empty - - function Is_Set - (Item : Socket_Set_Type; - Socket : Socket_Type) return Boolean; - -- Return True iff Socket is present in Item - - procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type); - -- Insert Socket into Item - - function Image (Item : Socket_Set_Type) return String; - -- Return a printable image of Item, for debugging purposes - - -- The select(2) system call waits for events to occur on any of a set of - -- file descriptors. Usually, three independent sets of descriptors are - -- watched (read, write and exception). A timeout gives an upper bound - -- on the amount of time elapsed before select returns. This function - -- blocks until an event occurs. On some platforms, the select(2) system - -- can block the full process (not just the calling thread). - -- - -- Check_Selector provides the very same behavior. The only difference is - -- that it does not watch for exception events. Note that on some platforms - -- it is kept process blocking on purpose. The timeout parameter allows the - -- user to have the behavior he wants. Abort_Selector allows the safe - -- abort of a blocked Check_Selector call. A special socket is opened by - -- Create_Selector and included in each call to Check_Selector. - -- - -- Abort_Selector causes an event to occur on this descriptor in order to - -- unblock Check_Selector. Note that each call to Abort_Selector will cause - -- exactly one call to Check_Selector to return with Aborted status. The - -- special socket created by Create_Selector is closed when Close_Selector - -- is called. - -- - -- A typical case where it is useful to abort a Check_Selector operation is - -- the situation where a change to the monitored sockets set must be made. - - procedure Create_Selector (Selector : out Selector_Type); - -- Initialize (open) a new selector - - procedure Close_Selector (Selector : in out Selector_Type); - -- Close Selector and all internal descriptors associated; deallocate any - -- associated resources. This subprogram may be called only when there is - -- no other task still using Selector (i.e. still executing Check_Selector - -- or Abort_Selector on this Selector). Has no effect if Selector is - -- already closed. - - procedure Check_Selector - (Selector : Selector_Type; - R_Socket_Set : in out Socket_Set_Type; - W_Socket_Set : in out Socket_Set_Type; - Status : out Selector_Status; - Timeout : Selector_Duration := Forever); - -- Return when one Socket in R_Socket_Set has some data to be read or if - -- one Socket in W_Socket_Set is ready to transmit some data. In these - -- cases Status is set to Completed and sockets that are ready are set in - -- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was - -- ready after a Timeout expiration. Status is set to Aborted if an abort - -- signal has been received while checking socket status. - -- - -- Note that two different Socket_Set_Type objects must be passed as - -- R_Socket_Set and W_Socket_Set (even if they denote the same set of - -- Sockets), or some event may be lost. Also keep in mind that this - -- procedure modifies the passed socket sets to indicate which sockets - -- actually had events upon return. The socket set therefore has to - -- be reset by the caller for further calls. - -- - -- Socket_Error is raised when the select(2) system call returns an error - -- condition, or when a read error occurs on the signalling socket used for - -- the implementation of Abort_Selector. - - procedure Check_Selector - (Selector : Selector_Type; - R_Socket_Set : in out Socket_Set_Type; - W_Socket_Set : in out Socket_Set_Type; - E_Socket_Set : in out Socket_Set_Type; - Status : out Selector_Status; - Timeout : Selector_Duration := Forever); - -- This refined version of Check_Selector allows watching for exception - -- events (i.e. notifications of out-of-band transmission and reception). - -- As above, all of R_Socket_Set, W_Socket_Set and E_Socket_Set must be - -- different objects. - - procedure Abort_Selector (Selector : Selector_Type); - -- Send an abort signal to the selector. The Selector may not be the - -- Null_Selector. - - type Fd_Set is private; - -- ??? This type must not be used directly, it needs to be visible because - -- it is used in the visible part of GNAT.Sockets.Thin_Common. This is - -- really an inversion of abstraction. The private part of GNAT.Sockets - -- needs to have visibility on this type, but since Thin_Common is a child - -- of Sockets, the type can't be declared there. The correct fix would - -- be to move the thin sockets binding outside of GNAT.Sockets altogether, - -- e.g. by renaming it to GNAT.Sockets_Thin. - -private - - type Socket_Type is new Integer; - No_Socket : constant Socket_Type := -1; - - -- A selector is either a null selector, which is always "open" and can - -- never be aborted, or a regular selector, which is created "closed", - -- becomes "open" when Create_Selector is called, and "closed" again when - -- Close_Selector is called. - - type Selector_Type (Is_Null : Boolean := False) is limited record - case Is_Null is - when True => - null; - - when False => - R_Sig_Socket : Socket_Type := No_Socket; - W_Sig_Socket : Socket_Type := No_Socket; - -- Signalling sockets used to abort a select operation - end case; - end record; - - pragma Volatile (Selector_Type); - - Null_Selector : constant Selector_Type := (Is_Null => True); - - type Fd_Set is - new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_fd_set); - for Fd_Set'Alignment use Interfaces.C.long'Alignment; - -- Set conservative alignment so that our Fd_Sets are always adequately - -- aligned for the underlying data type (which is implementation defined - -- and may be an array of C long integers). - - type Fd_Set_Access is access all Fd_Set; - pragma Convention (C, Fd_Set_Access); - No_Fd_Set_Access : constant Fd_Set_Access := null; - - type Socket_Set_Type is record - Last : Socket_Type := No_Socket; - -- Highest socket in set. Last = No_Socket denotes an empty set (which - -- is the default initial value). - - Set : aliased Fd_Set; - -- Underlying socket set. Note that the contents of this component is - -- undefined if Last = No_Socket. - end record; - - subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; - -- Octet for Internet address - - type Inet_Addr_VN_Type is array (Natural range <>) of Inet_Addr_Comp_Type; - - subtype Inet_Addr_V4_Type is Inet_Addr_VN_Type (1 .. 4); - subtype Inet_Addr_V6_Type is Inet_Addr_VN_Type (1 .. 16); - - type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record - case Family is - when Family_Inet => - Sin_V4 : Inet_Addr_V4_Type := (others => 0); - - when Family_Inet6 => - Sin_V6 : Inet_Addr_V6_Type := (others => 0); - end case; - end record; - - Any_Port : constant Port_Type := 0; - No_Port : constant Port_Type := 0; - - Any_Inet_Addr : constant Inet_Addr_Type := - (Family_Inet, (others => 0)); - No_Inet_Addr : constant Inet_Addr_Type := - (Family_Inet, (others => 0)); - Broadcast_Inet_Addr : constant Inet_Addr_Type := - (Family_Inet, (others => 255)); - Loopback_Inet_Addr : constant Inet_Addr_Type := - (Family_Inet, (127, 0, 0, 1)); - - Unspecified_Group_Inet_Addr : constant Inet_Addr_Type := - (Family_Inet, (224, 0, 0, 0)); - All_Hosts_Group_Inet_Addr : constant Inet_Addr_Type := - (Family_Inet, (224, 0, 0, 1)); - All_Routers_Group_Inet_Addr : constant Inet_Addr_Type := - (Family_Inet, (224, 0, 0, 2)); - - No_Sock_Addr : constant Sock_Addr_Type := (Family_Inet, No_Inet_Addr, 0); - - Max_Name_Length : constant := 64; - -- The constant MAXHOSTNAMELEN is usually set to 64 - - subtype Name_Index is Natural range 1 .. Max_Name_Length; - - type Name_Type (Length : Name_Index := Max_Name_Length) is record - Name : String (1 .. Length); - end record; - -- We need fixed strings to avoid access types in host entry type - - type Name_Array is array (Natural range <>) of Name_Type; - type Inet_Addr_Array is array (Natural range <>) of Inet_Addr_Type; - - type Host_Entry_Type (Aliases_Length, Addresses_Length : Natural) is record - Official : Name_Type; - Aliases : Name_Array (1 .. Aliases_Length); - Addresses : Inet_Addr_Array (1 .. Addresses_Length); - end record; - - type Service_Entry_Type (Aliases_Length : Natural) is record - Official : Name_Type; - Port : Port_Type; - Protocol : Name_Type; - Aliases : Name_Array (1 .. Aliases_Length); - end record; - - type Request_Flag_Type is mod 2 ** 8; - No_Request_Flag : constant Request_Flag_Type := 0; - Process_Out_Of_Band_Data : constant Request_Flag_Type := 1; - Peek_At_Incoming_Data : constant Request_Flag_Type := 2; - Wait_For_A_Full_Reception : constant Request_Flag_Type := 4; - Send_End_Of_Record : constant Request_Flag_Type := 8; - -end GNAT.Sockets; diff --git a/gcc/ada/g-socthi-dummy.adb b/gcc/ada/g-socthi-dummy.adb deleted file mode 100644 index 625eb82..0000000 --- a/gcc/ada/g-socthi-dummy.adb +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma No_Body; diff --git a/gcc/ada/g-socthi-dummy.ads b/gcc/ada/g-socthi-dummy.ads deleted file mode 100644 index 47b5e6c..0000000 --- a/gcc/ada/g-socthi-dummy.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a placeholder for the sockets binding for platforms where --- it is not implemented. - -package GNAT.Sockets.Thin is - pragma Unimplemented_Unit; -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-mingw.adb b/gcc/ada/g-socthi-mingw.adb deleted file mode 100644 index 6ce2fb6..0000000 --- a/gcc/ada/g-socthi-mingw.adb +++ /dev/null @@ -1,631 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 Ada.Unchecked_Conversion; -with Interfaces.C.Strings; use Interfaces.C.Strings; -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; - -package body GNAT.Sockets.Thin is - - use type C.unsigned; - - WSAData_Dummy : array (1 .. 512) of C.int; - - WS_Version : constant := 16#0202#; - -- Winsock 2.2 - - Initialized : Boolean := False; - - 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 : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - pragma Import (Stdcall, Standard_Select, "select"); - - type Error_Type is - (N_EINTR, - N_EBADF, - N_EACCES, - N_EFAULT, - N_EINVAL, - N_EMFILE, - N_EWOULDBLOCK, - N_EINPROGRESS, - N_EALREADY, - N_ENOTSOCK, - N_EDESTADDRREQ, - N_EMSGSIZE, - N_EPROTOTYPE, - N_ENOPROTOOPT, - N_EPROTONOSUPPORT, - N_ESOCKTNOSUPPORT, - N_EOPNOTSUPP, - N_EPFNOSUPPORT, - N_EAFNOSUPPORT, - N_EADDRINUSE, - N_EADDRNOTAVAIL, - N_ENETDOWN, - N_ENETUNREACH, - N_ENETRESET, - N_ECONNABORTED, - N_ECONNRESET, - N_ENOBUFS, - N_EISCONN, - N_ENOTCONN, - N_ESHUTDOWN, - N_ETOOMANYREFS, - N_ETIMEDOUT, - N_ECONNREFUSED, - N_ELOOP, - N_ENAMETOOLONG, - N_EHOSTDOWN, - N_EHOSTUNREACH, - N_WSASYSNOTREADY, - N_WSAVERNOTSUPPORTED, - N_WSANOTINITIALISED, - N_WSAEDISCON, - N_HOST_NOT_FOUND, - N_TRY_AGAIN, - N_NO_RECOVERY, - N_NO_DATA, - N_OTHERS); - - Error_Messages : constant array (Error_Type) of chars_ptr := - (N_EINTR => - New_String ("Interrupted system call"), - N_EBADF => - New_String ("Bad file number"), - N_EACCES => - New_String ("Permission denied"), - N_EFAULT => - New_String ("Bad address"), - N_EINVAL => - New_String ("Invalid argument"), - N_EMFILE => - New_String ("Too many open files"), - N_EWOULDBLOCK => - New_String ("Operation would block"), - N_EINPROGRESS => - New_String ("Operation now in progress. This error is " - & "returned if any Windows Sockets API " - & "function is called while a blocking " - & "function is in progress"), - N_EALREADY => - New_String ("Operation already in progress"), - N_ENOTSOCK => - New_String ("Socket operation on nonsocket"), - N_EDESTADDRREQ => - New_String ("Destination address required"), - N_EMSGSIZE => - New_String ("Message too long"), - N_EPROTOTYPE => - New_String ("Protocol wrong type for socket"), - N_ENOPROTOOPT => - New_String ("Protocol not available"), - N_EPROTONOSUPPORT => - New_String ("Protocol not supported"), - N_ESOCKTNOSUPPORT => - New_String ("Socket type not supported"), - N_EOPNOTSUPP => - New_String ("Operation not supported on socket"), - N_EPFNOSUPPORT => - New_String ("Protocol family not supported"), - N_EAFNOSUPPORT => - New_String ("Address family not supported by protocol family"), - N_EADDRINUSE => - New_String ("Address already in use"), - N_EADDRNOTAVAIL => - New_String ("Cannot assign requested address"), - N_ENETDOWN => - New_String ("Network is down. This error may be " - & "reported at any time if the Windows " - & "Sockets implementation detects an " - & "underlying failure"), - N_ENETUNREACH => - New_String ("Network is unreachable"), - N_ENETRESET => - New_String ("Network dropped connection on reset"), - N_ECONNABORTED => - New_String ("Software caused connection abort"), - N_ECONNRESET => - New_String ("Connection reset by peer"), - N_ENOBUFS => - New_String ("No buffer space available"), - N_EISCONN => - New_String ("Socket is already connected"), - N_ENOTCONN => - New_String ("Socket is not connected"), - N_ESHUTDOWN => - New_String ("Cannot send after socket shutdown"), - N_ETOOMANYREFS => - New_String ("Too many references: cannot splice"), - N_ETIMEDOUT => - New_String ("Connection timed out"), - N_ECONNREFUSED => - New_String ("Connection refused"), - N_ELOOP => - New_String ("Too many levels of symbolic links"), - N_ENAMETOOLONG => - New_String ("File name too long"), - N_EHOSTDOWN => - New_String ("Host is down"), - N_EHOSTUNREACH => - New_String ("No route to host"), - N_WSASYSNOTREADY => - New_String ("Returned by WSAStartup(), indicating that " - & "the network subsystem is unusable"), - N_WSAVERNOTSUPPORTED => - New_String ("Returned by WSAStartup(), indicating that " - & "the Windows Sockets DLL cannot support " - & "this application"), - N_WSANOTINITIALISED => - New_String ("Winsock not initialized. This message is " - & "returned by any function except WSAStartup(), " - & "indicating that a successful WSAStartup() has " - & "not yet been performed"), - N_WSAEDISCON => - New_String ("Disconnected"), - N_HOST_NOT_FOUND => - New_String ("Host not found. This message indicates " - & "that the key (name, address, and so on) was not found"), - N_TRY_AGAIN => - New_String ("Nonauthoritative host not found. This error may " - & "suggest that the name service itself is not " - & "functioning"), - N_NO_RECOVERY => - New_String ("Nonrecoverable error. This error may suggest that the " - & "name service itself is not functioning"), - N_NO_DATA => - New_String ("Valid name, no data record of requested type. " - & "This error indicates that the key (name, address, " - & "and so on) was not found."), - N_OTHERS => - New_String ("Unknown system error")); - - --------------- - -- C_Connect -- - --------------- - - function C_Connect - (S : C.int; - Name : System.Address; - Namelen : C.int) return C.int - is - Res : C.int; - - begin - Res := Standard_Connect (S, Name, Namelen); - - if Res = -1 then - if Socket_Errno = SOSC.EWOULDBLOCK then - Set_Socket_Errno (SOSC.EINPROGRESS); - end if; - end if; - - return Res; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - return C_Ioctl (S, Req, Arg); - end Socket_Ioctl; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - use type C.size_t; - - Fill : constant Boolean := - SOSC.MSG_WAITALL /= -1 - and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; - -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors - - Res : C.int; - Count : C.int := 0; - - MH : Msghdr; - for MH'Address use Msg; - - Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov; - pragma Import (Ada, Iovec); - - Iov_Index : Integer; - Current_Iovec : Vector_Element; - - function To_Access is new Ada.Unchecked_Conversion - (System.Address, Stream_Element_Reference); - pragma Warnings (Off, Stream_Element_Reference); - - Req : Request_Type (Name => N_Bytes_To_Read); - - begin - -- Windows does not provide an implementation of recvmsg(). The spec for - -- WSARecvMsg() is incompatible with the data types we define, and is - -- available starting with Windows Vista and Server 2008 only. So, - -- we use C_Recv instead. - - -- Check how much data are available - - Control_Socket (Socket_Type (S), Req); - - -- Fill the vectors - - Iov_Index := -1; - Current_Iovec := (Base => null, Length => 0); - - loop - if Current_Iovec.Length = 0 then - Iov_Index := Iov_Index + 1; - exit when Iov_Index > Integer (Iovec'Last); - Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); - end if; - - Res := - C_Recv - (S, - Current_Iovec.Base.all'Address, - C.int (Current_Iovec.Length), - Flags); - - if Res < 0 then - return System.CRTL.ssize_t (Res); - - elsif Res = 0 and then not Fill then - exit; - - else - pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length); - - Count := Count + Res; - Current_Iovec.Length := - Current_Iovec.Length - Interfaces.C.size_t (Res); - Current_Iovec.Base := - To_Access (Current_Iovec.Base.all'Address - + Storage_Offset (Res)); - - -- If all the data that was initially available read, do not - -- attempt to receive more, since this might block, or merge data - -- from successive datagrams for a datagram-oriented socket. We - -- still try to receive more if we need to fill all vectors - -- (MSG_WAITALL flag is set). - - exit when Natural (Count) >= Req.Size - and then - - -- Either we are not in fill mode - - (not Fill - - -- Or else last vector filled - - or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last - and then Current_Iovec.Length = 0)); - end if; - end loop; - - return System.CRTL.ssize_t (Count); - end C_Recvmsg; - - -------------- - -- C_Select -- - -------------- - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int - is - pragma Warnings (Off, Exceptfds); - - Original_WFS : aliased constant Fd_Set := Writefds.all; - - Res : C.int; - S : aliased C.int; - Last : aliased C.int; - - begin - -- Asynchronous connection failures are notified in the exception fd - -- set instead of the write fd set. To ensure POSIX compatibility, 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 successful, and 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 Writefds /= No_Fd_Set_Access then - - -- Add any socket present in write fd set into exception fd set - - declare - WFS : aliased Fd_Set := Writefds.all; - begin - Last := Nfds - 1; - loop - Get_Socket_From_Set - (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access); - exit when S = -1; - Insert_Socket_In_Set (Exceptfds, S); - end loop; - end; - end if; - - Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout); - - if Exceptfds /= No_Fd_Set_Access then - declare - EFSC : aliased Fd_Set := Exceptfds.all; - Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; - Buffer : Character; - Length : C.int; - Fromlen : aliased C.int; - - begin - Last := Nfds - 1; - loop - Get_Socket_From_Set - (EFSC'Access, 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, - From => System.Null_Address, - Fromlen => Fromlen'Unchecked_Access); - -- Is Fromlen necessary if From is Null_Address??? - - -- 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 (Exceptfds, 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 Writefds /= No_Fd_Set_Access - and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0) - then - Insert_Socket_In_Set (Writefds, S); - end if; - end if; - end loop; - end; - end if; - return Res; - end C_Select; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - use type C.size_t; - - Res : C.int; - Count : C.int := 0; - - MH : Msghdr; - for MH'Address use Msg; - - Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; - for Iovec'Address use MH.Msg_Iov; - pragma Import (Ada, Iovec); - - begin - -- Windows does not provide an implementation of sendmsg(). The spec for - -- WSASendMsg() is incompatible with the data types we define, and is - -- available starting with Windows Vista and Server 2008 only. So - -- use C_Sendto instead. - - for J in Iovec'Range loop - Res := - C_Sendto - (S, - Iovec (J).Base.all'Address, - C.int (Iovec (J).Length), - Flags => Flags, - To => MH.Msg_Name, - Tolen => C.int (MH.Msg_Namelen)); - - if Res < 0 then - return System.CRTL.ssize_t (Res); - else - Count := Count + Res; - end if; - - -- Exit now if the buffer is not fully transmitted - - exit when Interfaces.C.size_t (Res) < Iovec (J).Length; - end loop; - - return System.CRTL.ssize_t (Count); - end C_Sendmsg; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - if Initialized then - WSACleanup; - Initialized := False; - end if; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is - - -- On Windows, socket and host errors share the same code space, and - -- error messages are provided by Socket_Error_Message, so the default - -- separate body for Host_Error_Messages is not used in this case. - - function Host_Error_Message (H_Errno : Integer) return String - renames Socket_Error_Message; - - end Host_Error_Messages; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - Return_Value : Interfaces.C.int; - begin - if not Initialized then - Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); - pragma Assert (Return_Value = 0); - Initialized := True; - end if; - end Initialize; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is separate; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is - use GNAT.Sockets.SOSC; - - Errm : C.Strings.chars_ptr; - - begin - case Errno is - when EINTR => Errm := Error_Messages (N_EINTR); - when EBADF => Errm := Error_Messages (N_EBADF); - when EACCES => Errm := Error_Messages (N_EACCES); - when EFAULT => Errm := Error_Messages (N_EFAULT); - when EINVAL => Errm := Error_Messages (N_EINVAL); - when EMFILE => Errm := Error_Messages (N_EMFILE); - when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK); - when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS); - when EALREADY => Errm := Error_Messages (N_EALREADY); - when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK); - when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ); - when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE); - when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE); - when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT); - when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT); - when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT); - when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP); - when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT); - when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT); - when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE); - when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL); - when ENETDOWN => Errm := Error_Messages (N_ENETDOWN); - when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH); - when ENETRESET => Errm := Error_Messages (N_ENETRESET); - when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED); - when ECONNRESET => Errm := Error_Messages (N_ECONNRESET); - when ENOBUFS => Errm := Error_Messages (N_ENOBUFS); - when EISCONN => Errm := Error_Messages (N_EISCONN); - when ENOTCONN => Errm := Error_Messages (N_ENOTCONN); - when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN); - when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS); - when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT); - when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED); - when ELOOP => Errm := Error_Messages (N_ELOOP); - when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG); - when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN); - when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH); - - -- Windows-specific error codes - - when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY); - when WSAVERNOTSUPPORTED => - Errm := Error_Messages (N_WSAVERNOTSUPPORTED); - when WSANOTINITIALISED => - Errm := Error_Messages (N_WSANOTINITIALISED); - when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON); - - -- h_errno values - - when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND); - when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN); - when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY); - when NO_DATA => Errm := Error_Messages (N_NO_DATA); - when others => Errm := Error_Messages (N_OTHERS); - end case; - - return Value (Errm); - end Socket_Error_Message; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-mingw.ads b/gcc/ada/g-socthi-mingw.ads deleted file mode 100644 index 202297d..0000000 --- a/gcc/ada/g-socthi-mingw.ads +++ /dev/null @@ -1,242 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 Interfaces.C; - -with GNAT.Sockets.Thin_Common; - -with System; -with System.CRTL; - -package GNAT.Sockets.Thin is - - use Thin_Common; - - package C renames Interfaces.C; - - use type System.CRTL.ssize_t; - - 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, returns "Unknown system error". - - function Host_Errno return Integer; - pragma Import (C, Host_Errno, "__gnat_get_h_errno"); - -- Returns last host error number - - package Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String; - -- Returns the error message string for the host error number H_Errno. - -- If H_Errno is not known, returns "Unknown system error". - - end Host_Error_Messages; - - -------------------------------- - -- Standard library functions -- - -------------------------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null 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_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : not null access C.int) return C.int; - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - - function C_Listen - (S : C.int; - Backlog : 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 : System.Address; - Fromlen : not null access C.int) return C.int; - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - 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_System - (Command : System.Address) return C.int; - - function WSAStartup - (WS_Version : Interfaces.C.unsigned_short; - WSADataAddress : System.Address) return Interfaces.C.int; - - ------------------------------------------------------- - -- Signalling file descriptors for selector abortion -- - ------------------------------------------------------- - - package Signalling_Fds is - - function Create (Fds : not null access Fd_Pair) return C.int; - pragma Convention (C, Create); - -- Create a pair of connected descriptors suitable for use with C_Select - -- (used for signalling in Selector objects). - - function Read (Rsig : C.int) return C.int; - pragma Convention (C, Read); - -- Read one byte of data from rsig, the read end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - function Write (Wsig : C.int) return C.int; - pragma Convention (C, Write); - -- Write one byte of data to wsig, the write end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - procedure Close (Sig : C.int); - pragma Convention (C, Close); - -- Close one end of a pair of signalling fds (ignoring any error) - - end Signalling_Fds; - - procedure WSACleanup; - - procedure Initialize; - procedure Finalize; - -private - pragma Import (Stdcall, C_Accept, "accept"); - pragma Import (Stdcall, C_Bind, "bind"); - pragma Import (Stdcall, C_Close, "closesocket"); - pragma Import (Stdcall, C_Gethostname, "gethostname"); - pragma Import (Stdcall, C_Getpeername, "getpeername"); - pragma Import (Stdcall, C_Getsockname, "getsockname"); - pragma Import (Stdcall, C_Getsockopt, "getsockopt"); - pragma Import (Stdcall, C_Listen, "listen"); - pragma Import (Stdcall, C_Recv, "recv"); - pragma Import (Stdcall, C_Recvfrom, "recvfrom"); - pragma Import (Stdcall, C_Sendto, "sendto"); - pragma Import (Stdcall, C_Setsockopt, "setsockopt"); - pragma Import (Stdcall, C_Shutdown, "shutdown"); - pragma Import (Stdcall, C_Socket, "socket"); - pragma Import (C, C_System, "_system"); - pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); - pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); - pragma Import (Stdcall, WSAStartup, "WSAStartup"); - pragma Import (Stdcall, WSACleanup, "WSACleanup"); - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.adb b/gcc/ada/g-socthi-vxworks.adb deleted file mode 100644 index 0e3f7d7..0000000 --- a/gcc/ada/g-socthi-vxworks.adb +++ /dev/null @@ -1,487 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -package body GNAT.Sockets.Thin is - - Non_Blocking_Sockets : aliased Fd_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 SOSC.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. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - -- All these require comments ??? - - function Syscall_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null 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_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 : System.Address; - Fromlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Recvfrom, "recvfrom"); - - function Syscall_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Recvmsg, "recvmsg"); - - function Syscall_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return C.int; - pragma Import (C, Syscall_Sendmsg, "sendmsg"); - - 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 : System.Address; - 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 : not null access C.int) return C.int - is - R : C.int; - Val : aliased C.int := 1; - - Res : C.int; - pragma Unreferenced (Res); - - begin - loop - R := Syscall_Accept (S, Addr, Addrlen); - exit when SOSC.Thread_Blocking_IO - or else R /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- A socket inherits the properties of its server especially - -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram - -- tracks sockets set in non-blocking mode by user. - - Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); - Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - -- Is it OK to ignore result ??? - 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 SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EINPROGRESS - then - return Res; - end if; - - declare - WSet : aliased Fd_Set; - Now : aliased Timeval; - begin - Reset_Socket_Set (WSet'Access); - loop - Insert_Socket_In_Set (WSet'Access, S); - Now := Immediat; - Res := C_Select - (S + 1, - No_Fd_Set_Access, - WSet'Access, - No_Fd_Set_Access, - Now'Unchecked_Access); - - exit when Res > 0; - - if Res = Failure then - return Res; - end if; - - delay Quantum; - end loop; - end; - - Res := Syscall_Connect (S, Name, Namelen); - - if Res = Failure - and then Errno = SOSC.EISCONN - then - return Thin_Common.Success; - else - return Res; - end if; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then - if Arg.all /= 0 then - Set_Non_Blocking_Socket (S, True); - end if; - end if; - - return C_Ioctl (S, Req, Arg); - end Socket_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 SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.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 : System.Address; - Fromlen : not null access C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvfrom; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - begin - loop - Res := Syscall_Recvmsg (S, Msg, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return System.CRTL.ssize_t (Res); - end C_Recvmsg; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : C.int; - - begin - loop - Res := Syscall_Sendmsg (S, Msg, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return System.CRTL.ssize_t (Res); - end C_Sendmsg; - - -------------- - -- C_Sendto -- - -------------- - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int - is - use System; - - Res : C.int; - - begin - loop - if To = Null_Address then - - -- In violation of the standard sockets API, VxWorks does not - -- support sendto(2) calls on connected sockets with a null - -- destination address, so use send(2) instead in that case. - - Res := Syscall_Send (S, Msg, Len, Flags); - - -- Normal case where destination address is non-null - - else - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - end if; - - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.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; - pragma Unreferenced (Res); - - begin - R := Syscall_Socket (Domain, Typ, Protocol); - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- Do not use Socket_Ioctl as this subprogram tracks sockets set - -- in non-blocking mode by user. - - Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - -- Is it OK to ignore result ??? - Set_Non_Blocking_Socket (R, False); - end if; - - return R; - end C_Socket; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - null; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is separate; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Reset_Socket_Set (Non_Blocking_Sockets'Access); - 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'Access, S) /= 0); - Task_Lock.Unlock; - return R; - end Non_Blocking_Socket; - - ----------------------------- - -- 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'Access, S); - else - Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); - end if; - - Task_Lock.Unlock; - end Set_Non_Blocking_Socket; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is separate; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is separate; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi-vxworks.ads b/gcc/ada/g-socthi-vxworks.ads deleted file mode 100644 index 8fe96ce..0000000 --- a/gcc/ada/g-socthi-vxworks.ads +++ /dev/null @@ -1,228 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -with GNAT.OS_Lib; -with GNAT.Sockets.Thin_Common; - -with System; -with System.CRTL; - -package GNAT.Sockets.Thin is - - use Thin_Common; - - package C renames Interfaces.C; - - use type System.CRTL.ssize_t; - - function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; - -- Returns last socket error number - - procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno; - -- 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, returns "Unknown system error". - - function Host_Errno return Integer; - pragma Import (C, Host_Errno, "__gnat_get_h_errno"); - -- Returns last host error number - - package Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String; - -- Returns the error message string for the host error number H_Errno. - -- If H_Errno is not known, returns "Unknown system error". - - end Host_Error_Messages; - - -------------------------------- - -- Standard library functions -- - -------------------------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null 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_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : not null access C.int) return C.int; - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - - function C_Listen - (S : C.int; - Backlog : 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 : System.Address; - Fromlen : not null access C.int) return C.int; - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - 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_System - (Command : System.Address) return C.int; - - ------------------------------------------------------- - -- Signalling file descriptors for selector abortion -- - ------------------------------------------------------- - - package Signalling_Fds is - - function Create (Fds : not null access Fd_Pair) return C.int; - pragma Convention (C, Create); - -- Create a pair of connected descriptors suitable for use with C_Select - -- (used for signalling in Selector objects). - - function Read (Rsig : C.int) return C.int; - pragma Convention (C, Read); - -- Read one byte of data from rsig, the read end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - function Write (Wsig : C.int) return C.int; - pragma Convention (C, Write); - -- Write one byte of data to wsig, the write end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - procedure Close (Sig : C.int); - pragma Convention (C, Close); - -- Close one end of a pair of signalling fds (ignoring any error) - - end Signalling_Fds; - - procedure Initialize; - procedure Finalize; - -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_Listen, "listen"); - pragma Import (C, C_Select, "select"); - pragma Import (C, C_Setsockopt, "setsockopt"); - pragma Import (C, C_Shutdown, "shutdown"); - pragma Import (C, C_System, "system"); -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi.adb b/gcc/ada/g-socthi.adb deleted file mode 100644 index 6f6fd37..0000000 --- a/gcc/ada/g-socthi.adb +++ /dev/null @@ -1,491 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This is the default version - -with GNAT.OS_Lib; use GNAT.OS_Lib; -with GNAT.Task_Lock; - -with Interfaces.C; use Interfaces.C; - -package body GNAT.Sockets.Thin is - - Non_Blocking_Sockets : aliased Fd_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 SOSC.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. - - -- Comments required for following functions ??? - - function Syscall_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null 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_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 : System.Address; - Fromlen : not null access C.int) return C.int; - pragma Import (C, Syscall_Recvfrom, "recvfrom"); - - function Syscall_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - pragma Import (C, Syscall_Recvmsg, "recvmsg"); - - function Syscall_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - pragma Import (C, Syscall_Sendmsg, "sendmsg"); - - function Syscall_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - 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"); - - procedure Disable_SIGPIPE (S : C.int); - pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe"); - - procedure Disable_All_SIGPIPEs; - pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes"); - -- Sets the process to ignore all SIGPIPE signals on platforms that - -- don't support Disable_SIGPIPE for particular streams. - - 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 : not null 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 SOSC.Thread_Blocking_IO - or else R /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- A socket inherits the properties ot its server especially - -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram - -- tracks sockets set in non-blocking mode by user. - - Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); - Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - end if; - - Disable_SIGPIPE (R); - 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 SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EINPROGRESS - then - return Res; - end if; - - declare - WSet : aliased Fd_Set; - Now : aliased Timeval; - - begin - Reset_Socket_Set (WSet'Access); - loop - Insert_Socket_In_Set (WSet'Access, S); - Now := Immediat; - Res := C_Select - (S + 1, - No_Fd_Set_Access, - WSet'Access, - No_Fd_Set_Access, - Now'Unchecked_Access); - - exit when Res > 0; - - if Res = Failure then - return Res; - end if; - - delay Quantum; - end loop; - end; - - Res := Syscall_Connect (S, Name, Namelen); - - if Res = Failure - and then Errno = SOSC.EISCONN - then - return Thin_Common.Success; - else - return Res; - end if; - end C_Connect; - - ------------------ - -- Socket_Ioctl -- - ------------------ - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int - is - begin - if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then - if Arg.all /= 0 then - Set_Non_Blocking_Socket (S, True); - end if; - end if; - - return C_Ioctl (S, Req, Arg); - end Socket_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 SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.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 : System.Address; - Fromlen : not null access C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvfrom; - - --------------- - -- C_Recvmsg -- - --------------- - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : System.CRTL.ssize_t; - - begin - loop - Res := Syscall_Recvmsg (S, Msg, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= System.CRTL.ssize_t (Failure) - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Recvmsg; - - --------------- - -- C_Sendmsg -- - --------------- - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t - is - Res : System.CRTL.ssize_t; - - begin - loop - Res := Syscall_Sendmsg (S, Msg, Flags); - exit when SOSC.Thread_Blocking_IO - or else Res /= System.CRTL.ssize_t (Failure) - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.EWOULDBLOCK; - delay Quantum; - end loop; - - return Res; - end C_Sendmsg; - - -------------- - -- C_Sendto -- - -------------- - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - Tolen : C.int) return C.int - is - Res : C.int; - - begin - loop - Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); - exit when SOSC.Thread_Blocking_IO - or else Res /= Failure - or else Non_Blocking_Socket (S) - or else Errno /= SOSC.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; - - begin - R := Syscall_Socket (Domain, Typ, Protocol); - - if not SOSC.Thread_Blocking_IO - and then R /= Failure - then - -- Do not use Socket_Ioctl as this subprogram tracks sockets set - -- in non-blocking mode by user. - - Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); - Set_Non_Blocking_Socket (R, False); - end if; - Disable_SIGPIPE (R); - return R; - end C_Socket; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - null; - end Finalize; - - ------------------------- - -- Host_Error_Messages -- - ------------------------- - - package body Host_Error_Messages is separate; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - Disable_All_SIGPIPEs; - Reset_Socket_Set (Non_Blocking_Sockets'Access); - 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'Access, S) /= 0); - Task_Lock.Unlock; - return R; - end Non_Blocking_Socket; - - ----------------------------- - -- 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'Access, S); - else - Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); - end if; - - Task_Lock.Unlock; - end Set_Non_Blocking_Socket; - - -------------------- - -- Signalling_Fds -- - -------------------- - - package body Signalling_Fds is - - -- In this default implementation, we use a C version of these - -- subprograms provided by socket.c. - - function C_Create (Fds : not null access Fd_Pair) return C.int; - function C_Read (Rsig : C.int) return C.int; - function C_Write (Wsig : C.int) return C.int; - procedure C_Close (Sig : C.int); - - pragma Import (C, C_Create, "__gnat_create_signalling_fds"); - pragma Import (C, C_Read, "__gnat_read_signalling_fd"); - pragma Import (C, C_Write, "__gnat_write_signalling_fd"); - pragma Import (C, C_Close, "__gnat_close_signalling_fd"); - - function Create - (Fds : not null access Fd_Pair) return C.int renames C_Create; - function Read (Rsig : C.int) return C.int renames C_Read; - function Write (Wsig : C.int) return C.int renames C_Write; - procedure Close (Sig : C.int) renames C_Close; - - end Signalling_Fds; - - -------------------------- - -- Socket_Error_Message -- - -------------------------- - - function Socket_Error_Message (Errno : Integer) return String is separate; - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-socthi.ads b/gcc/ada/g-socthi.ads deleted file mode 100644 index 062ad18..0000000 --- a/gcc/ada/g-socthi.ads +++ /dev/null @@ -1,259 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a target dependent thin interface to the sockets --- layer for use by the GNAT.Sockets package (g-socket.ads). This package --- should not be directly with'ed by an applications program. - --- This is the default version - -with Interfaces.C; - -with GNAT.OS_Lib; -with GNAT.Sockets.Thin_Common; - -with System; -with System.CRTL; - -package GNAT.Sockets.Thin is - - -- This package is intended for hosts implementing BSD sockets with a - -- standard interface. It will be used as a default for all the platforms - -- that do not have a specific version of this file. - - use Thin_Common; - - package C renames Interfaces.C; - - use type System.CRTL.ssize_t; - - 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, returns "Unknown system error". - - function Host_Errno return Integer; - pragma Import (C, Host_Errno, "__gnat_get_h_errno"); - -- Returns last host error number - - package Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String; - -- Returns the error message string for the host error number H_Errno. - -- If H_Errno is not known, returns "Unknown system error". - - end Host_Error_Messages; - - -------------------------------- - -- Standard library functions -- - -------------------------------- - - function C_Accept - (S : C.int; - Addr : System.Address; - Addrlen : not null 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_Gethostname - (Name : System.Address; - Namelen : C.int) return C.int; - - function C_Getpeername - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockname - (S : C.int; - Name : System.Address; - Namelen : not null access C.int) return C.int; - - function C_Getsockopt - (S : C.int; - Level : C.int; - Optname : C.int; - Optval : System.Address; - Optlen : not null access C.int) return C.int; - - function Socket_Ioctl - (S : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - - function C_Listen - (S : C.int; - Backlog : 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 : System.Address; - Fromlen : not null access C.int) return C.int; - - function C_Recvmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Select - (Nfds : C.int; - Readfds : access Fd_Set; - Writefds : access Fd_Set; - Exceptfds : access Fd_Set; - Timeout : Timeval_Access) return C.int; - - function C_Sendmsg - (S : C.int; - Msg : System.Address; - Flags : C.int) return System.CRTL.ssize_t; - - function C_Sendto - (S : C.int; - Msg : System.Address; - Len : C.int; - Flags : C.int; - To : System.Address; - 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_System - (Command : System.Address) return C.int; - - ------------------------------------------------------- - -- Signalling file descriptors for selector abortion -- - ------------------------------------------------------- - - package Signalling_Fds is - - function Create (Fds : not null access Fd_Pair) return C.int; - pragma Convention (C, Create); - -- Create a pair of connected descriptors suitable for use with C_Select - -- (used for signalling in Selector objects). - - function Read (Rsig : C.int) return C.int; - pragma Convention (C, Read); - -- Read one byte of data from rsig, the read end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - function Write (Wsig : C.int) return C.int; - pragma Convention (C, Write); - -- Write one byte of data to wsig, the write end of a pair of signalling - -- fds created by Create_Signalling_Fds. - - procedure Close (Sig : C.int); - pragma Convention (C, Close); - -- Close one end of a pair of signalling fds (ignoring any error) - - end Signalling_Fds; - - ------------------------------------------- - -- Nonreentrant network databases access -- - ------------------------------------------- - - -- The following are used only on systems that have nonreentrant - -- getXXXbyYYY functions, and do NOT have corresponding getXXXbyYYY_ - -- functions. Currently, LynxOS is the only such system. - - function Nonreentrant_Gethostbyname - (Name : C.char_array) return Hostent_Access; - - function Nonreentrant_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int) return Hostent_Access; - - function Nonreentrant_Getservbyname - (Name : C.char_array; - Proto : C.char_array) return Servent_Access; - - function Nonreentrant_Getservbyport - (Port : C.int; - Proto : C.char_array) return Servent_Access; - - procedure Initialize; - procedure Finalize; - -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_Listen, "listen"); - pragma Import (C, C_Select, "select"); - pragma Import (C, C_Setsockopt, "setsockopt"); - pragma Import (C, C_Shutdown, "shutdown"); - pragma Import (C, C_System, "system"); - - pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname"); - pragma Import (C, Nonreentrant_Gethostbyaddr, "gethostbyaddr"); - pragma Import (C, Nonreentrant_Getservbyname, "getservbyname"); - pragma Import (C, Nonreentrant_Getservbyport, "getservbyport"); - -end GNAT.Sockets.Thin; diff --git a/gcc/ada/g-soliop-mingw.ads b/gcc/ada/g-soliop-mingw.ads deleted file mode 100644 index 33c63fd..0000000 --- a/gcc/ada/g-soliop-mingw.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 sockets as required by the package GNAT.Sockets. - --- This is the Windows/NT version of this package - --- This package should not be directly with'ed by an application program - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lws2_32"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/g-soliop-solaris.ads b/gcc/ada/g-soliop-solaris.ads deleted file mode 100644 index cd7e3bb..0000000 --- a/gcc/ada/g-soliop-solaris.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 sockets as required by the package GNAT.Sockets. - --- This is the Solaris version of this package - --- This package should not be directly with'ed by an application program - -package GNAT.Sockets.Linker_Options is -private - pragma Linker_Options ("-lnsl"); - pragma Linker_Options ("-lsocket"); -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/g-soliop.ads b/gcc/ada/g-soliop.ads deleted file mode 100644 index 3b39858..0000000 --- a/gcc/ada/g-soliop.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 sockets as required by the package GNAT.Sockets. - --- This is an empty version for default use where no additional libraries --- are required. On some targets a target specific version of this unit --- ensures linking with required libraries for proper sockets operation. - --- This package should not be directly with'ed by an application program - -package GNAT.Sockets.Linker_Options is -end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/g-sothco-dummy.adb b/gcc/ada/g-sothco-dummy.adb deleted file mode 100644 index 4dd2b3f..0000000 --- a/gcc/ada/g-sothco-dummy.adb +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N _ C O M M O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma No_Body; diff --git a/gcc/ada/g-sothco-dummy.ads b/gcc/ada/g-sothco-dummy.ads deleted file mode 100644 index 473a068..0000000 --- a/gcc/ada/g-sothco-dummy.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N _ C O M M O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a placeholder for the sockets binding for platforms where --- it is not implemented. - -package GNAT.Sockets.Thin_Common is - pragma Unimplemented_Unit; -end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/g-sothco.adb b/gcc/ada/g-sothco.adb deleted file mode 100644 index 4e8fbde..0000000 --- a/gcc/ada/g-sothco.adb +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N _ C O M M O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body GNAT.Sockets.Thin_Common is - - ----------------- - -- 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 - (Length_And_Family : out Sockaddr_Length_And_Family; - Family : Family_Type) - is - C_Family : C.int renames Families (Family); - Has_Sockaddr_Len : constant Boolean := SOSC.Has_Sockaddr_Len /= 0; - begin - if Has_Sockaddr_Len then - Length_And_Family.Length := Lengths (Family); - Length_And_Family.Char_Family := C.unsigned_char (C_Family); - else - Length_And_Family.Short_Family := C.unsigned_short (C_Family); - end if; - end Set_Family; - - -------------- - -- Set_Port -- - -------------- - - procedure Set_Port - (Sin : Sockaddr_In_Access; - Port : C.unsigned_short) - is - begin - Sin.Sin_Port := Port; - end Set_Port; - -end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/g-sothco.ads b/gcc/ada/g-sothco.ads deleted file mode 100644 index c25f4ed..0000000 --- a/gcc/ada/g-sothco.ads +++ /dev/null @@ -1,409 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N _ C O M M O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the target-independent part of the thin sockets mapping. --- This package should not be directly with'ed by an applications program. - -with Ada.Unchecked_Conversion; - -with Interfaces.C; -with Interfaces.C.Pointers; - -package GNAT.Sockets.Thin_Common is - - package C renames Interfaces.C; - - Success : constant C.int := 0; - Failure : constant C.int := -1; - - type time_t is - range -2 ** (8 * SOSC.SIZEOF_tv_sec - 1) - .. 2 ** (8 * SOSC.SIZEOF_tv_sec - 1) - 1; - for time_t'Size use 8 * SOSC.SIZEOF_tv_sec; - pragma Convention (C, time_t); - - type suseconds_t is - range -2 ** (8 * SOSC.SIZEOF_tv_usec - 1) - .. 2 ** (8 * SOSC.SIZEOF_tv_usec - 1) - 1; - for suseconds_t'Size use 8 * SOSC.SIZEOF_tv_usec; - pragma Convention (C, suseconds_t); - - type Timeval is record - Tv_Sec : time_t; - Tv_Usec : suseconds_t; - end record; - pragma Convention (C, Timeval); - - type Timeval_Access is access all Timeval; - pragma Convention (C, Timeval_Access); - - Immediat : constant Timeval := (0, 0); - - ------------------------------------------- - -- Mapping tables to low level constants -- - ------------------------------------------- - - Families : constant array (Family_Type) of C.int := - (Family_Inet => SOSC.AF_INET, - Family_Inet6 => SOSC.AF_INET6); - - Lengths : constant array (Family_Type) of C.unsigned_char := - (Family_Inet => SOSC.SIZEOF_sockaddr_in, - Family_Inet6 => SOSC.SIZEOF_sockaddr_in6); - - ---------------------------- - -- Generic socket address -- - ---------------------------- - - -- Common header - - -- All socket address types (struct sockaddr, struct sockaddr_storage, - -- and protocol specific address types) start with the same 2-byte header, - -- which is either a length and a family (one byte each) or just a two-byte - -- family. The following unchecked union describes the two possible layouts - -- and is meant to be constrained with SOSC.Have_Sockaddr_Len. - - type Sockaddr_Length_And_Family - (Has_Sockaddr_Len : Boolean := False) - is record - case Has_Sockaddr_Len is - when True => - Length : C.unsigned_char; - Char_Family : C.unsigned_char; - - when False => - Short_Family : C.unsigned_short; - end case; - end record; - pragma Unchecked_Union (Sockaddr_Length_And_Family); - pragma Convention (C, Sockaddr_Length_And_Family); - - procedure Set_Family - (Length_And_Family : out Sockaddr_Length_And_Family; - Family : Family_Type); - -- Set the family component to the appropriate value for Family, and also - -- set Length accordingly if applicable on this platform. - - type Sockaddr is record - Sa_Family : Sockaddr_Length_And_Family; - -- Address family (and address length on some platforms) - - Sa_Data : C.char_array (1 .. 14) := (others => C.nul); - -- Family-specific data - -- Note that some platforms require that all unused (reserved) bytes - -- in addresses be initialized to 0 (e.g. VxWorks). - end record; - pragma Convention (C, Sockaddr); - -- Generic socket address - - type Sockaddr_Access is access all Sockaddr; - pragma Convention (C, Sockaddr_Access); - -- Access to socket address - - ---------------------------- - -- AF_INET socket address -- - ---------------------------- - - type In_Addr is record - S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; - end record; - for In_Addr'Alignment use C.int'Alignment; - pragma Convention (C, In_Addr); - -- IPv4 address, represented as a network-order C.int. Note that the - -- underlying operating system may assume that values of this type have - -- C.int alignment, so we need to provide a suitable alignment clause here. - - function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); - function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); - - 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_In is record - Sin_Family : Sockaddr_Length_And_Family; - -- Address family (and address length on some platforms) - - Sin_Port : C.unsigned_short; - -- Port in network byte order - - Sin_Addr : In_Addr; - -- IPv4 address - - Sin_Zero : C.char_array (1 .. 8) := (others => C.nul); - -- Padding - -- - -- Note that some platforms require that all unused (reserved) bytes - -- in addresses be initialized to 0 (e.g. VxWorks). - 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_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 - - ------------------ - -- Host entries -- - ------------------ - - type Hostent is new - System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_hostent); - for Hostent'Alignment use 8; - -- Host entry. This is an opaque type used only via the following - -- accessor functions, because 'struct hostent' has different layouts on - -- different platforms. - - type Hostent_Access is access all Hostent; - pragma Convention (C, Hostent_Access); - -- Access to host entry - - function Hostent_H_Name - (E : Hostent_Access) return System.Address; - - function Hostent_H_Alias - (E : Hostent_Access; I : C.int) return System.Address; - - function Hostent_H_Addrtype - (E : Hostent_Access) return C.int; - - function Hostent_H_Length - (E : Hostent_Access) return C.int; - - function Hostent_H_Addr - (E : Hostent_Access; Index : C.int) return System.Address; - - --------------------- - -- Service entries -- - --------------------- - - type Servent is new - System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_servent); - for Servent'Alignment use 8; - -- Service entry. This is an opaque type used only via the following - -- accessor functions, because 'struct servent' has different layouts on - -- different platforms. - - type Servent_Access is access all Servent; - pragma Convention (C, Servent_Access); - -- Access to service entry - - function Servent_S_Name - (E : Servent_Access) return System.Address; - - function Servent_S_Alias - (E : Servent_Access; Index : C.int) return System.Address; - - function Servent_S_Port - (E : Servent_Access) return C.unsigned_short; - - function Servent_S_Proto - (E : Servent_Access) return System.Address; - - ------------------ - -- NetDB access -- - ------------------ - - -- There are three possible situations for the following NetDB access - -- functions: - -- - inherently thread safe (case of data returned in a thread specific - -- buffer); - -- - thread safe using user-provided buffer; - -- - thread unsafe. - -- - -- In the first and third cases, the Buf and Buflen are ignored. In the - -- second case, the caller must provide a buffer large enough to - -- accommodate the returned data. In the third case, the caller must ensure - -- that these functions are called within a critical section. - - function C_Gethostbyname - (Name : C.char_array; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int; - - function C_Gethostbyaddr - (Addr : System.Address; - Addr_Len : C.int; - Addr_Type : C.int; - Ret : not null access Hostent; - Buf : System.Address; - Buflen : C.int; - H_Errnop : not null access C.int) return C.int; - - function C_Getservbyname - (Name : C.char_array; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; - - function C_Getservbyport - (Port : C.int; - Proto : C.char_array; - Ret : not null access Servent; - Buf : System.Address; - Buflen : C.int) return C.int; - - ------------------------------------ - -- Scatter/gather vector handling -- - ------------------------------------ - - type Msghdr is record - Msg_Name : System.Address; - Msg_Namelen : C.unsigned; - Msg_Iov : System.Address; - Msg_Iovlen : SOSC.Msg_Iovlen_T; - Msg_Control : System.Address; - Msg_Controllen : C.size_t; - Msg_Flags : C.int; - end record; - pragma Convention (C, Msghdr); - - ---------------------------- - -- Socket sets management -- - ---------------------------- - - procedure Get_Socket_From_Set - (Set : access Fd_Set; - Last : access C.int; - Socket : access C.int); - -- 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 : access Fd_Set; - Socket : C.int); - -- Insert socket in the socket set - - function Is_Socket_In_Set - (Set : access constant Fd_Set; - Socket : C.int) return C.int; - -- Check whether Socket is in the socket set, return a non-zero - -- value if it is, zero if it is not. - - procedure Last_Socket_In_Set - (Set : access Fd_Set; - Last : access C.int); - -- 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. - - procedure Remove_Socket_From_Set (Set : access Fd_Set; Socket : C.int); - -- Remove socket from the socket set - - procedure Reset_Socket_Set (Set : access Fd_Set); - -- Make Set empty - - ------------------------------------------ - -- Pairs of signalling file descriptors -- - ------------------------------------------ - - type Two_Ints is array (0 .. 1) of C.int; - pragma Convention (C, Two_Ints); - -- Container for two int values - - subtype Fd_Pair is Two_Ints; - -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file - -- descriptors, one of which (the "read end" of the connection) being used - -- for reading, the other one (the "write end") being used for writing. - - Read_End : constant := 0; - Write_End : constant := 1; - -- Indexes into an Fd_Pair value providing access to each of the connected - -- file descriptors. - - function Inet_Pton - (Af : C.int; - Cp : System.Address; - Inp : System.Address) return C.int; - - function C_Ioctl - (Fd : C.int; - Req : SOSC.IOCTL_Req_T; - Arg : access C.int) return C.int; - -private - 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, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); - pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); - pragma Import (C, Reset_Socket_Set, "__gnat_reset_socket_set"); - pragma Import (C, C_Ioctl, "__gnat_socket_ioctl"); - pragma Import (C, Inet_Pton, SOSC.Inet_Pton_Linkname); - - pragma Import (C, C_Gethostbyname, "__gnat_gethostbyname"); - pragma Import (C, C_Gethostbyaddr, "__gnat_gethostbyaddr"); - pragma Import (C, C_Getservbyname, "__gnat_getservbyname"); - pragma Import (C, C_Getservbyport, "__gnat_getservbyport"); - - pragma Import (C, Servent_S_Name, "__gnat_servent_s_name"); - pragma Import (C, Servent_S_Alias, "__gnat_servent_s_alias"); - pragma Import (C, Servent_S_Port, "__gnat_servent_s_port"); - pragma Import (C, Servent_S_Proto, "__gnat_servent_s_proto"); - - pragma Import (C, Hostent_H_Name, "__gnat_hostent_h_name"); - pragma Import (C, Hostent_H_Alias, "__gnat_hostent_h_alias"); - pragma Import (C, Hostent_H_Addrtype, "__gnat_hostent_h_addrtype"); - pragma Import (C, Hostent_H_Length, "__gnat_hostent_h_length"); - pragma Import (C, Hostent_H_Addr, "__gnat_hostent_h_addr"); - -end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/g-souinf.ads b/gcc/ada/g-souinf.ads deleted file mode 100644 index 83d23d4..0000000 --- a/gcc/ada/g-souinf.ads +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S O U R C E _ I N F O -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides some useful utility subprograms that provide access --- to source code information known at compile time. These subprograms are --- intrinsic operations that provide information known to the compiler in --- a form that can be embedded into the source program for identification --- and logging purposes. For example, an exception handler can print out --- the name of the source file in which the exception is handled. - -package GNAT.Source_Info is - pragma Preelaborate; - -- Note that this unit is Preelaborate, but not Pure, that's because the - -- functions here such as Line are clearly not pure functions, and normally - -- we mark intrinsic functions in a Pure unit as Pure, even though they are - -- imported. - -- - -- Historical note: this used to be Pure, but that was when we marked all - -- intrinsics as not Pure, even in Pure units, so no problems arose. - - function File return String with - Import, Convention => Intrinsic; - -- Return the name of the current file, not including the path information. - -- The result is considered to be a static string constant. - - function Line return Positive with - Import, Convention => Intrinsic; - -- Return the current input line number. The result is considered to be a - -- static expression. - - function Source_Location return String with - Import, Convention => Intrinsic; - -- Return a string literal of the form "name:line", where name is the - -- current source file name without path information, and line is the - -- current line number. In the event that instantiations are involved, - -- additional suffixes of the same form are appended after the separating - -- string " instantiated at ". The result is considered to be a static - -- string constant. - - function Enclosing_Entity return String with - Import, Convention => Intrinsic; - -- Return the name of the current subprogram, package, task, entry or - -- protected subprogram. The string is in exactly the form used for the - -- declaration of the entity (casing and encoding conventions), and is - -- considered to be a static string constant. The name is fully qualified - -- using periods where possible (this is not always possible, notably in - -- the case of entities appearing in unnamed block statements.) - -- - -- Note: if this function is used at the outer level of a generic package, - -- the string returned will be the name of the instance, not the generic - -- package itself. This is useful in identifying and logging information - -- from within generic templates. - - function Compilation_ISO_Date return String with - Import, Convention => Intrinsic; - -- Returns date of compilation as a static string "yyyy-mm-dd". - - function Compilation_Date return String with - Import, Convention => Intrinsic; - -- Returns date of compilation as a static string "mmm dd yyyy". This is - -- in local time form, and is exactly compatible with C macro __DATE__. - - function Compilation_Time return String with - Import, Convention => Intrinsic; - -- Returns GMT time of compilation as a static string "hh:mm:ss". This is - -- in local time form, and is exactly compatible with C macro __TIME__. - -end GNAT.Source_Info; diff --git a/gcc/ada/g-spchge.adb b/gcc/ada/g-spchge.adb deleted file mode 100644 index bdc3854..0000000 --- a/gcc/ada/g-spchge.adb +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S P E L L I N G _ C H E C K E R _ G E N E R I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body GNAT.Spelling_Checker_Generic is - - ------------------------ - -- Is_Bad_Spelling_Of -- - ------------------------ - - function Is_Bad_Spelling_Of - (Found : String_Type; - Expect : String_Type) return Boolean - is - FN : constant Natural := Found'Length; - FF : constant Natural := Found'First; - FL : constant Natural := Found'Last; - - EN : constant Natural := Expect'Length; - EF : constant Natural := Expect'First; - EL : constant Natural := Expect'Last; - - Letter_o : constant Char_Type := Char_Type'Val (Character'Pos ('o')); - Digit_0 : constant Char_Type := Char_Type'Val (Character'Pos ('0')); - Digit_9 : constant Char_Type := Char_Type'Val (Character'Pos ('9')); - - begin - -- If both strings null, then we consider this a match, but if one - -- is null and the other is not, then we definitely do not match - - if FN = 0 then - return (EN = 0); - - elsif EN = 0 then - return False; - - -- If first character does not match, then we consider that this is - -- definitely not a misspelling. An exception is when we expect a - -- letter O and found a zero. - - elsif Found (FF) /= Expect (EF) - and then (Found (FF) /= Digit_0 or else Expect (EF) /= Letter_o) - then - return False; - - -- Not a bad spelling if both strings are 1-2 characters long - - elsif FN < 3 and then EN < 3 then - return False; - - -- Lengths match. Execute loop to check for a single error, single - -- transposition or exact match (we only fall through this loop if - -- one of these three conditions is found). - - elsif FN = EN then - for J in 1 .. FN - 2 loop - if Expect (EF + J) /= Found (FF + J) then - - -- If both mismatched characters are digits, then we do - -- not consider it a misspelling (e.g. B345 is not a - -- misspelling of B346, it is something quite different) - - if Expect (EF + J) in Digit_0 .. Digit_9 - and then Found (FF + J) in Digit_0 .. Digit_9 - then - return False; - - elsif Expect (EF + J + 1) = Found (FF + J + 1) - and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL) - then - return True; - - elsif Expect (EF + J) = Found (FF + J + 1) - and then Expect (EF + J + 1) = Found (FF + J) - and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL) - then - return True; - - else - return False; - end if; - end if; - end loop; - - -- At last character. Test digit case as above, otherwise we - -- have a match since at most this last character fails to match. - - if Expect (EL) in Digit_0 .. Digit_9 - and then Found (FL) in Digit_0 .. Digit_9 - and then Expect (EL) /= Found (FL) - then - return False; - else - return True; - end if; - - -- Length is 1 too short. Execute loop to check for single deletion - - elsif FN = EN - 1 then - for J in 1 .. FN - 1 loop - if Found (FF + J) /= Expect (EF + J) then - return Found (FF + J .. FL) = Expect (EF + J + 1 .. EL); - end if; - end loop; - - -- If we fall through then the last character was missing, which - -- we consider to be a match (e.g. found xyz, expected xyza). - - return True; - - -- Length is 1 too long. Execute loop to check for single insertion - - elsif FN = EN + 1 then - for J in 1 .. EN - 1 loop - if Found (FF + J) /= Expect (EF + J) then - return Found (FF + J + 1 .. FL) = Expect (EF + J .. EL); - end if; - end loop; - - -- If we fall through then the last character was an additional - -- character, which is a match (e.g. found xyza, expected xyz). - - return True; - - -- Length is completely wrong - - else - return False; - end if; - end Is_Bad_Spelling_Of; - -end GNAT.Spelling_Checker_Generic; diff --git a/gcc/ada/g-spchge.ads b/gcc/ada/g-spchge.ads deleted file mode 100644 index 908250d..0000000 --- a/gcc/ada/g-spchge.ads +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S P E L L I N G _ C H E C K E R _ G E N E R I C -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Spelling checker - --- This package provides a utility generic routine for checking for bad --- spellings. This routine must be instantiated with an appropriate array --- element type, which must represent a character encoding in which the --- codes for ASCII characters in the range 16#20#..16#7F# have their normal --- expected encoding values (e.g. the Pos value 16#31# must be digit 1). - -pragma Compiler_Unit_Warning; - -package GNAT.Spelling_Checker_Generic is - pragma Pure; - - generic - type Char_Type is (<>); - -- See above for restrictions on what types can be used here - - type String_Type is array (Positive range <>) of Char_Type; - - function Is_Bad_Spelling_Of - (Found : String_Type; - Expect : String_Type) return Boolean; - -- Determines if the string Found is a plausible misspelling of the string - -- Expect. Returns True for an exact match or a probably misspelling, False - -- if no near match is detected. This routine is case sensitive, so the - -- caller should fold both strings to get a case insensitive match if the - -- character encoding represents upper/lower case. - -- - -- Note: the spec of this routine is deliberately rather vague. This - -- routine is the one used by GNAT itself to detect misspelled keywords - -- and identifiers, and is heuristically adjusted to be appropriate to - -- this usage. It will work well in any similar case of named entities. - -end GNAT.Spelling_Checker_Generic; diff --git a/gcc/ada/g-speche.adb b/gcc/ada/g-speche.adb deleted file mode 100644 index 0e8c7c4..0000000 --- a/gcc/ada/g-speche.adb +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S P E L L I N G _ C H E C K E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with GNAT.Spelling_Checker_Generic; - -package body GNAT.Spelling_Checker is - - function IBS is new - GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of - (Character, String); - - ------------------------ - -- Is_Bad_Spelling_Of -- - ------------------------ - - function Is_Bad_Spelling_Of - (Found : String; - Expect : String) return Boolean - renames IBS; - -end GNAT.Spelling_Checker; diff --git a/gcc/ada/g-speche.ads b/gcc/ada/g-speche.ads deleted file mode 100644 index 7b4da4a..0000000 --- a/gcc/ada/g-speche.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . S P E L L I N G _ C H E C K E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Spelling checker - --- This package provides a utility routine for checking for bad spellings --- for the case of String arguments. - -pragma Compiler_Unit_Warning; - -package GNAT.Spelling_Checker is - pragma Pure; - - function Is_Bad_Spelling_Of - (Found : String; - Expect : String) return Boolean; - -- Determines if the string Found is a plausible misspelling of the string - -- Expect. Returns True for an exact match or a probably misspelling, False - -- if no near match is detected. This routine is case sensitive, so the - -- caller should fold both strings to get a case insensitive match. - -- - -- Note: the spec of this routine is deliberately rather vague. It is used - -- by GNAT itself to detect misspelled keywords and identifiers, and is - -- heuristically adjusted to be appropriate to this usage. It will work - -- well in any similar case of named entities. - -end GNAT.Spelling_Checker; diff --git a/gcc/ada/g-spipat.adb b/gcc/ada/g-spipat.adb deleted file mode 100644 index 194a335..0000000 --- a/gcc/ada/g-spipat.adb +++ /dev/null @@ -1,6489 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L . P A T T E R N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: the data structures and general approach used in this implementation --- are derived from the original MINIMAL sources for SPITBOL. The code is not --- a direct translation, but the approach is followed closely. In particular, --- we use the one stack approach developed in the SPITBOL implementation. - -with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; - -with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; - -with System; use System; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body GNAT.Spitbol.Patterns is - - ------------------------ - -- Internal Debugging -- - ------------------------ - - Internal_Debug : constant Boolean := False; - -- Set this flag to True to activate some built-in debugging traceback - -- These are all lines output with PutD and Put_LineD. - - procedure New_LineD; - pragma Inline (New_LineD); - -- Output new blank line with New_Line if Internal_Debug is True - - procedure PutD (Str : String); - pragma Inline (PutD); - -- Output string with Put if Internal_Debug is True - - procedure Put_LineD (Str : String); - pragma Inline (Put_LineD); - -- Output string with Put_Line if Internal_Debug is True - - ----------------------------- - -- Local Type Declarations -- - ----------------------------- - - subtype String_Ptr is Ada.Strings.Unbounded.String_Access; - subtype File_Ptr is Ada.Text_IO.File_Access; - - function To_Address is new Ada.Unchecked_Conversion (PE_Ptr, Address); - -- Used only for debugging output purposes - - subtype AFC is Ada.Finalization.Controlled; - - N : constant PE_Ptr := null; - -- Shorthand used to initialize Copy fields to null - - type Natural_Ptr is access all Natural; - type Pattern_Ptr is access all Pattern; - - -------------------------------------------------- - -- Description of Algorithm and Data Structures -- - -------------------------------------------------- - - -- A pattern structure is represented as a linked graph of nodes - -- with the following structure: - - -- +------------------------------------+ - -- I Pcode I - -- +------------------------------------+ - -- I Index I - -- +------------------------------------+ - -- I Pthen I - -- +------------------------------------+ - -- I parameter(s) I - -- +------------------------------------+ - - -- Pcode is a code value indicating the type of the pattern node. This - -- code is used both as the discriminant value for the record, and as - -- the case index in the main match routine that branches to the proper - -- match code for the given element. - - -- Index is a serial index number. The use of these serial index - -- numbers is described in a separate section. - - -- Pthen is a pointer to the successor node, i.e the node to be matched - -- if the attempt to match the node succeeds. If this is the last node - -- of the pattern to be matched, then Pthen points to a dummy node - -- of kind PC_EOP (end of pattern), which initializes pattern exit. - - -- The parameter or parameters are present for certain node types, - -- and the type varies with the pattern code. - - type Pattern_Code is ( - PC_Arb_Y, - PC_Assign, - PC_Bal, - PC_BreakX_X, - PC_Cancel, - PC_EOP, - PC_Fail, - PC_Fence, - PC_Fence_X, - PC_Fence_Y, - PC_R_Enter, - PC_R_Remove, - PC_R_Restore, - PC_Rest, - PC_Succeed, - PC_Unanchored, - - PC_Alt, - PC_Arb_X, - PC_Arbno_S, - PC_Arbno_X, - - PC_Rpat, - - PC_Pred_Func, - - PC_Assign_Imm, - PC_Assign_OnM, - PC_Any_VP, - PC_Break_VP, - PC_BreakX_VP, - PC_NotAny_VP, - PC_NSpan_VP, - PC_Span_VP, - PC_String_VP, - - PC_Write_Imm, - PC_Write_OnM, - - PC_Null, - PC_String, - - PC_String_2, - PC_String_3, - PC_String_4, - PC_String_5, - PC_String_6, - - PC_Setcur, - - PC_Any_CH, - PC_Break_CH, - PC_BreakX_CH, - PC_Char, - PC_NotAny_CH, - PC_NSpan_CH, - PC_Span_CH, - - PC_Any_CS, - PC_Break_CS, - PC_BreakX_CS, - PC_NotAny_CS, - PC_NSpan_CS, - PC_Span_CS, - - PC_Arbno_Y, - PC_Len_Nat, - PC_Pos_Nat, - PC_RPos_Nat, - PC_RTab_Nat, - PC_Tab_Nat, - - PC_Pos_NF, - PC_Len_NF, - PC_RPos_NF, - PC_RTab_NF, - PC_Tab_NF, - - PC_Pos_NP, - PC_Len_NP, - PC_RPos_NP, - PC_RTab_NP, - PC_Tab_NP, - - PC_Any_VF, - PC_Break_VF, - PC_BreakX_VF, - PC_NotAny_VF, - PC_NSpan_VF, - PC_Span_VF, - PC_String_VF); - - type IndexT is range 0 .. +(2 **15 - 1); - - type PE (Pcode : Pattern_Code) is record - - Index : IndexT; - -- Serial index number of pattern element within pattern - - Pthen : PE_Ptr; - -- Successor element, to be matched after this one - - case Pcode is - when PC_Arb_Y - | PC_Assign - | PC_Bal - | PC_BreakX_X - | PC_Cancel - | PC_EOP - | PC_Fail - | PC_Fence - | PC_Fence_X - | PC_Fence_Y - | PC_Null - | PC_R_Enter - | PC_R_Remove - | PC_R_Restore - | PC_Rest - | PC_Succeed - | PC_Unanchored - => - null; - - when PC_Alt - | PC_Arb_X - | PC_Arbno_S - | PC_Arbno_X - => - Alt : PE_Ptr; - - when PC_Rpat => - PP : Pattern_Ptr; - - when PC_Pred_Func => - BF : Boolean_Func; - - when PC_Assign_Imm - | PC_Assign_OnM - | PC_Any_VP - | PC_Break_VP - | PC_BreakX_VP - | PC_NotAny_VP - | PC_NSpan_VP - | PC_Span_VP - | PC_String_VP - => - VP : VString_Ptr; - - when PC_Write_Imm - | PC_Write_OnM - => - FP : File_Ptr; - - when PC_String => - Str : String_Ptr; - - when PC_String_2 => - Str2 : String (1 .. 2); - - when PC_String_3 => - Str3 : String (1 .. 3); - - when PC_String_4 => - Str4 : String (1 .. 4); - - when PC_String_5 => - Str5 : String (1 .. 5); - - when PC_String_6 => - Str6 : String (1 .. 6); - - when PC_Setcur => - Var : Natural_Ptr; - - when PC_Any_CH - | PC_Break_CH - | PC_BreakX_CH - | PC_Char - | PC_NotAny_CH - | PC_NSpan_CH - | PC_Span_CH - => - Char : Character; - - when PC_Any_CS - | PC_Break_CS - | PC_BreakX_CS - | PC_NotAny_CS - | PC_NSpan_CS - | PC_Span_CS - => - CS : Character_Set; - - when PC_Arbno_Y - | PC_Len_Nat - | PC_Pos_Nat - | PC_RPos_Nat - | PC_RTab_Nat - | PC_Tab_Nat - => - Nat : Natural; - - when PC_Pos_NF - | PC_Len_NF - | PC_RPos_NF - | PC_RTab_NF - | PC_Tab_NF - => - NF : Natural_Func; - - when PC_Pos_NP - | PC_Len_NP - | PC_RPos_NP - | PC_RTab_NP - | PC_Tab_NP - => - NP : Natural_Ptr; - - when PC_Any_VF - | PC_Break_VF - | PC_BreakX_VF - | PC_NotAny_VF - | PC_NSpan_VF - | PC_Span_VF - | PC_String_VF - => - VF : VString_Func; - end case; - end record; - - subtype PC_Has_Alt is Pattern_Code range PC_Alt .. PC_Arbno_X; - -- Range of pattern codes that has an Alt field. This is used in the - -- recursive traversals, since these links must be followed. - - EOP_Element : aliased constant PE := (PC_EOP, 0, N); - -- This is the end of pattern element, and is thus the representation of - -- a null pattern. It has a zero index element since it is never placed - -- inside a pattern. Furthermore it does not need a successor, since it - -- marks the end of the pattern, so that no more successors are needed. - - EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access; - -- This is the end of pattern pointer, that is used in the Pthen pointer - -- of other nodes to signal end of pattern. - - -- The following array is used to determine if a pattern used as an - -- argument for Arbno is eligible for treatment using the simple Arbno - -- structure (i.e. it is a pattern that is guaranteed to match at least - -- one character on success, and not to make any entries on the stack. - - OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean := - (PC_Any_CS | - PC_Any_CH | - PC_Any_VF | - PC_Any_VP | - PC_Char | - PC_Len_Nat | - PC_NotAny_CS | - PC_NotAny_CH | - PC_NotAny_VF | - PC_NotAny_VP | - PC_Span_CS | - PC_Span_CH | - PC_Span_VF | - PC_Span_VP | - PC_String | - PC_String_2 | - PC_String_3 | - PC_String_4 | - PC_String_5 | - PC_String_6 => True, - others => False); - - ------------------------------- - -- The Pattern History Stack -- - ------------------------------- - - -- The pattern history stack is used for controlling backtracking when - -- a match fails. The idea is to stack entries that give a cursor value - -- to be restored, and a node to be reestablished as the current node to - -- attempt an appropriate rematch operation. The processing for a pattern - -- element that has rematch alternatives pushes an appropriate entry or - -- entry on to the stack, and the proceeds. If a match fails at any point, - -- the top element of the stack is popped off, resetting the cursor and - -- the match continues by accessing the node stored with this entry. - - type Stack_Entry is record - - Cursor : Integer; - -- Saved cursor value that is restored when this entry is popped - -- from the stack if a match attempt fails. Occasionally, this - -- field is used to store a history stack pointer instead of a - -- cursor. Such cases are noted in the documentation and the value - -- stored is negative since stack pointer values are always negative. - - Node : PE_Ptr; - -- This pattern element reference is reestablished as the current - -- Node to be matched (which will attempt an appropriate rematch). - - end record; - - subtype Stack_Range is Integer range -Stack_Size .. -1; - - type Stack_Type is array (Stack_Range) of Stack_Entry; - -- The type used for a history stack. The actual instance of the stack - -- is declared as a local variable in the Match routine, to properly - -- handle recursive calls to Match. All stack pointer values are negative - -- to distinguish them from normal cursor values. - - -- Note: the pattern matching stack is used only to handle backtracking. - -- If no backtracking occurs, its entries are never accessed, and never - -- popped off, and in particular it is normal for a successful match - -- to terminate with entries on the stack that are simply discarded. - - -- Note: in subsequent diagrams of the stack, we always place element - -- zero (the deepest element) at the top of the page, then build the - -- stack down on the page with the most recent (top of stack) element - -- being the bottom-most entry on the page. - - -- Stack checking is handled by labeling every pattern with the maximum - -- number of stack entries that are required, so a single check at the - -- start of matching the pattern suffices. There are two exceptions. - - -- First, the count does not include entries for recursive pattern - -- references. Such recursions must therefore perform a specific - -- stack check with respect to the number of stack entries required - -- by the recursive pattern that is accessed and the amount of stack - -- that remains unused. - - -- Second, the count includes only one iteration of an Arbno pattern, - -- so a specific check must be made on subsequent iterations that there - -- is still enough stack space left. The Arbno node has a field that - -- records the number of stack entries required by its argument for - -- this purpose. - - --------------------------------------------------- - -- Use of Serial Index Field in Pattern Elements -- - --------------------------------------------------- - - -- The serial index numbers for the pattern elements are assigned as - -- a pattern is constructed from its constituent elements. Note that there - -- is never any sharing of pattern elements between patterns (copies are - -- always made), so the serial index numbers are unique to a particular - -- pattern as referenced from the P field of a value of type Pattern. - - -- The index numbers meet three separate invariants, which are used for - -- various purposes as described in this section. - - -- First, the numbers uniquely identify the pattern elements within a - -- pattern. If Num is the number of elements in a given pattern, then - -- the serial index numbers for the elements of this pattern will range - -- from 1 .. Num, so that each element has a separate value. - - -- The purpose of this assignment is to provide a convenient auxiliary - -- data structure mechanism during operations which must traverse a - -- pattern (e.g. copy and finalization processing). Once constructed - -- patterns are strictly read only. This is necessary to allow sharing - -- of patterns between tasks. This means that we cannot go marking the - -- pattern (e.g. with a visited bit). Instead we construct a separate - -- vector that contains the necessary information indexed by the Index - -- values in the pattern elements. For this purpose the only requirement - -- is that they be uniquely assigned. - - -- Second, the pattern element referenced directly, i.e. the leading - -- pattern element, is always the maximum numbered element and therefore - -- indicates the total number of elements in the pattern. More precisely, - -- the element referenced by the P field of a pattern value, or the - -- element returned by any of the internal pattern construction routines - -- in the body (that return a value of type PE_Ptr) always is this - -- maximum element, - - -- The purpose of this requirement is to allow an immediate determination - -- of the number of pattern elements within a pattern. This is used to - -- properly size the vectors used to contain auxiliary information for - -- traversal as described above. - - -- Third, as compound pattern structures are constructed, the way in which - -- constituent parts of the pattern are constructed is stylized. This is - -- an automatic consequence of the way that these compound structures - -- are constructed, and basically what we are doing is simply documenting - -- and specifying the natural result of the pattern construction. The - -- section describing compound pattern structures gives details of the - -- numbering of each compound pattern structure. - - -- The purpose of specifying the stylized numbering structures for the - -- compound patterns is to help simplify the processing in the Image - -- function, since it eases the task of retrieving the original recursive - -- structure of the pattern from the flat graph structure of elements. - -- This use in the Image function is the only point at which the code - -- makes use of the stylized structures. - - type Ref_Array is array (IndexT range <>) of PE_Ptr; - -- This type is used to build an array whose N'th entry references the - -- element in a pattern whose Index value is N. See Build_Ref_Array. - - procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array); - -- Given a pattern element which is the leading element of a pattern - -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the - -- Ref_Array so that its N'th entry references the element of the - -- referenced pattern whose Index value is N. - - ------------------------------- - -- Recursive Pattern Matches -- - ------------------------------- - - -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func - -- causes a recursive pattern match. This cannot be handled by an actual - -- recursive call to the outer level Match routine, since this would not - -- allow for possible backtracking into the region matched by the inner - -- pattern. Indeed this is the classical clash between recursion and - -- backtracking, and a simple recursive stack structure does not suffice. - - -- This section describes how this recursion and the possible associated - -- backtracking is handled. We still use a single stack, but we establish - -- the concept of nested regions on this stack, each of which has a stack - -- base value pointing to the deepest stack entry of the region. The base - -- value for the outer level is zero. - - -- When a recursive match is established, two special stack entries are - -- made. The first entry is used to save the original node that starts - -- the recursive match. This is saved so that the successor field of - -- this node is accessible at the end of the match, but it is never - -- popped and executed. - - -- The second entry corresponds to a standard new region action. A - -- PC_R_Remove node is stacked, whose cursor field is used to store - -- the outer stack base, and the stack base is reset to point to - -- this PC_R_Remove node. Then the recursive pattern is matched and - -- it can make history stack entries in the normal matter, so now - -- the stack looks like: - - -- (stack entries made by outer level) - - -- (Special entry, node is (+P) successor - -- cursor entry is not used) - - -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base - -- saved base value for the enclosing region) - - -- (stack entries made by inner level) - - -- If a subsequent failure occurs and pops the PC_R_Remove node, it - -- removes itself and the special entry immediately underneath it, - -- restores the stack base value for the enclosing region, and then - -- again signals failure to look for alternatives that were stacked - -- before the recursion was initiated. - - -- Now we need to consider what happens if the inner pattern succeeds, as - -- signalled by accessing the special PC_EOP pattern primitive. First we - -- recognize the nested case by looking at the Base value. If this Base - -- value is Stack'First, then the entire match has succeeded, but if the - -- base value is greater than Stack'First, then we have successfully - -- matched an inner pattern, and processing continues at the outer level. - - -- There are two cases. The simple case is when the inner pattern has made - -- no stack entries, as recognized by the fact that the current stack - -- pointer is equal to the current base value. In this case it is fine to - -- remove all trace of the recursion by restoring the outer base value and - -- using the special entry to find the appropriate successor node. - - -- The more complex case arises when the inner match does make stack - -- entries. In this case, the PC_EOP processing stacks a special entry - -- whose cursor value saves the saved inner base value (the one that - -- references the corresponding PC_R_Remove value), and whose node - -- pointer references a PC_R_Restore node, so the stack looks like: - - -- (stack entries made by outer level) - - -- (Special entry, node is (+P) successor, - -- cursor entry is not used) - - -- (PC_R_Remove entry, "cursor" value is (negative) - -- saved base value for the enclosing region) - - -- (stack entries made by inner level) - - -- (PC_Region_Replace entry, "cursor" value is (negative) - -- stack pointer value referencing the PC_R_Remove entry). - - -- If the entire match succeeds, then these stack entries are, as usual, - -- ignored and abandoned. If on the other hand a subsequent failure - -- causes the PC_Region_Replace entry to be popped, it restores the - -- inner base value from its saved "cursor" value and then fails again. - -- Note that it is OK that the cursor is temporarily clobbered by this - -- pop, since the second failure will reestablish a proper cursor value. - - --------------------------------- - -- Compound Pattern Structures -- - --------------------------------- - - -- This section discusses the compound structures used to represent - -- constructed patterns. It shows the graph structures of pattern - -- elements that are constructed, and in the case of patterns that - -- provide backtracking possibilities, describes how the history - -- stack is used to control the backtracking. Finally, it notes the - -- way in which the Index numbers are assigned to the structure. - - -- In all diagrams, solid lines (built with minus signs or vertical - -- bars, represent successor pointers (Pthen fields) with > or V used - -- to indicate the direction of the pointer. The initial node of the - -- structure is in the upper left of the diagram. A dotted line is an - -- alternative pointer from the element above it to the element below - -- it. See individual sections for details on how alternatives are used. - - ------------------- - -- Concatenation -- - ------------------- - - -- In the pattern structures listed in this section, a line that looks - -- like ----> with nothing to the right indicates an end of pattern - -- (EOP) pointer that represents the end of the match. - - -- When a pattern concatenation (L & R) occurs, the resulting structure - -- is obtained by finding all such EOP pointers in L, and replacing - -- them to point to R. This is the most important flattening that - -- occurs in constructing a pattern, and it means that the pattern - -- matching circuitry does not have to keep track of the structure - -- of a pattern with respect to concatenation, since the appropriate - -- successor is always at hand. - - -- Concatenation itself generates no additional possibilities for - -- backtracking, but the constituent patterns of the concatenated - -- structure will make stack entries as usual. The maximum amount - -- of stack required by the structure is thus simply the sum of the - -- maximums required by L and R. - - -- The index numbering of a concatenation structure works by leaving - -- the numbering of the right hand pattern, R, unchanged and adjusting - -- the numbers in the left hand pattern, L up by the count of elements - -- in R. This ensures that the maximum numbered element is the leading - -- element as required (given that it was the leading element in L). - - ----------------- - -- Alternation -- - ----------------- - - -- A pattern (L or R) constructs the structure: - - -- +---+ +---+ - -- | A |---->| L |----> - -- +---+ +---+ - -- . - -- . - -- +---+ - -- | R |----> - -- +---+ - - -- The A element here is a PC_Alt node, and the dotted line represents - -- the contents of the Alt field. When the PC_Alt element is matched, - -- it stacks a pointer to the leading element of R on the history stack - -- so that on subsequent failure, a match of R is attempted. - - -- The A node is the highest numbered element in the pattern. The - -- original index numbers of R are unchanged, but the index numbers - -- of the L pattern are adjusted up by the count of elements in R. - - -- Note that the difference between the index of the L leading element - -- the index of the R leading element (after building the alt structure) - -- indicates the number of nodes in L, and this is true even after the - -- structure is incorporated into some larger structure. For example, - -- if the A node has index 16, and L has index 15 and R has index - -- 5, then we know that L has 10 (15-5) elements in it. - - -- Suppose that we now concatenate this structure to another pattern - -- with 9 elements in it. We will now have the A node with an index - -- of 25, L with an index of 24 and R with an index of 14. We still - -- know that L has 10 (24-14) elements in it, numbered 15-24, and - -- consequently the successor of the alternation structure has an - -- index with a value less than 15. This is used in Image to figure - -- out the original recursive structure of a pattern. - - -- To clarify the interaction of the alternation and concatenation - -- structures, here is a more complex example of the structure built - -- for the pattern: - - -- (V or W or X) (Y or Z) - - -- where A,B,C,D,E are all single element patterns: - - -- +---+ +---+ +---+ +---+ - -- I A I---->I V I---+-->I A I---->I Y I----> - -- +---+ +---+ I +---+ +---+ - -- . I . - -- . I . - -- +---+ +---+ I +---+ - -- I A I---->I W I-->I I Z I----> - -- +---+ +---+ I +---+ - -- . I - -- . I - -- +---+ I - -- I X I------------>+ - -- +---+ - - -- The numbering of the nodes would be as follows: - - -- +---+ +---+ +---+ +---+ - -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I----> - -- +---+ +---+ I +---+ +---+ - -- . I . - -- . I . - -- +---+ +---+ I +---+ - -- I 6 I---->I 5 I-->I I 1 I----> - -- +---+ +---+ I +---+ - -- . I - -- . I - -- +---+ I - -- I 4 I------------>+ - -- +---+ - - -- Note: The above structure actually corresponds to - - -- (A or (B or C)) (D or E) - - -- rather than - - -- ((A or B) or C) (D or E) - - -- which is the more natural interpretation, but in fact alternation - -- is associative, and the construction of an alternative changes the - -- left grouped pattern to the right grouped pattern in any case, so - -- that the Image function produces a more natural looking output. - - --------- - -- Arb -- - --------- - - -- An Arb pattern builds the structure - - -- +---+ - -- | X |----> - -- +---+ - -- . - -- . - -- +---+ - -- | Y |----> - -- +---+ - - -- The X node is a PC_Arb_X node, which matches null, and stacks a - -- pointer to Y node, which is the PC_Arb_Y node that matches one - -- extra character and restacks itself. - - -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1 - - ------------------------- - -- Arbno (simple case) -- - ------------------------- - - -- The simple form of Arbno can be used where the pattern always - -- matches at least one character if it succeeds, and it is known - -- not to make any history stack entries. In this case, Arbno (P) - -- can construct the following structure: - - -- +-------------+ - -- | ^ - -- V | - -- +---+ | - -- | S |----> | - -- +---+ | - -- . | - -- . | - -- +---+ | - -- | P |---------->+ - -- +---+ - - -- The S (PC_Arbno_S) node matches null stacking a pointer to the - -- pattern P. If a subsequent failure causes P to be matched and - -- this match succeeds, then node A gets restacked to try another - -- instance if needed by a subsequent failure. - - -- The node numbering of the constituent pattern P is not affected. - -- The S node has a node number of P.Index + 1. - - -------------------------- - -- Arbno (complex case) -- - -------------------------- - - -- A call to Arbno (P), where P can match null (or at least is not - -- known to require a non-null string) and/or P requires pattern stack - -- entries, constructs the following structure: - - -- +--------------------------+ - -- | ^ - -- V | - -- +---+ | - -- | X |----> | - -- +---+ | - -- . | - -- . | - -- +---+ +---+ +---+ | - -- | E |---->| P |---->| Y |--->+ - -- +---+ +---+ +---+ - - -- The node X (PC_Arbno_X) matches null, stacking a pointer to the - -- E-P-X structure used to match one Arbno instance. - - -- Here E is the PC_R_Enter node which matches null and creates two - -- stack entries. The first is a special entry whose node field is - -- not used at all, and whose cursor field has the initial cursor. - - -- The second entry corresponds to a standard new region action. A - -- PC_R_Remove node is stacked, whose cursor field is used to store - -- the outer stack base, and the stack base is reset to point to - -- this PC_R_Remove node. Then the pattern P is matched, and it can - -- make history stack entries in the normal manner, so now the stack - -- looks like: - - -- (stack entries made before assign pattern) - - -- (Special entry, node field not used, - -- used only to save initial cursor) - - -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base - -- saved base value for the enclosing region) - - -- (stack entries made by matching P) - - -- If the match of P fails, then the PC_R_Remove entry is popped and - -- it removes both itself and the special entry underneath it, - -- restores the outer stack base, and signals failure. - - -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops - -- the inner region. There are two possibilities. If matching P left - -- no stack entries, then all traces of the inner region can be removed. - -- If there are stack entries, then we push an PC_Region_Replace stack - -- entry whose "cursor" value is the inner stack base value, and then - -- restore the outer stack base value, so the stack looks like: - - -- (stack entries made before assign pattern) - - -- (Special entry, node field not used, - -- used only to save initial cursor) - - -- (PC_R_Remove entry, "cursor" value is (negative) - -- saved base value for the enclosing region) - - -- (stack entries made by matching P) - - -- (PC_Region_Replace entry, "cursor" value is (negative) - -- stack pointer value referencing the PC_R_Remove entry). - - -- Now that we have matched another instance of the Arbno pattern, - -- we need to move to the successor. There are two cases. If the - -- Arbno pattern matched null, then there is no point in seeking - -- alternatives, since we would just match a whole bunch of nulls. - -- In this case we look through the alternative node, and move - -- directly to its successor (i.e. the successor of the Arbno - -- pattern). If on the other hand a non-null string was matched, - -- we simply follow the successor to the alternative node, which - -- sets up for another possible match of the Arbno pattern. - - -- As noted in the section on stack checking, the stack count (and - -- hence the stack check) for a pattern includes only one iteration - -- of the Arbno pattern. To make sure that multiple iterations do not - -- overflow the stack, the Arbno node saves the stack count required - -- by a single iteration, and the Concat function increments this to - -- include stack entries required by any successor. The PC_Arbno_Y - -- node uses this count to ensure that sufficient stack remains - -- before proceeding after matching each new instance. - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the Y node is numbered N + 1, - -- the E node is N + 2, and the X node is N + 3. - - ---------------------- - -- Assign Immediate -- - ---------------------- - - -- Immediate assignment (P * V) constructs the following structure - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| A |----> - -- +---+ +---+ +---+ - - -- Here E is the PC_R_Enter node which matches null and creates two - -- stack entries. The first is a special entry whose node field is - -- not used at all, and whose cursor field has the initial cursor. - - -- The second entry corresponds to a standard new region action. A - -- PC_R_Remove node is stacked, whose cursor field is used to store - -- the outer stack base, and the stack base is reset to point to - -- this PC_R_Remove node. Then the pattern P is matched, and it can - -- make history stack entries in the normal manner, so now the stack - -- looks like: - - -- (stack entries made before assign pattern) - - -- (Special entry, node field not used, - -- used only to save initial cursor) - - -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base - -- saved base value for the enclosing region) - - -- (stack entries made by matching P) - - -- If the match of P fails, then the PC_R_Remove entry is popped - -- and it removes both itself and the special entry underneath it, - -- restores the outer stack base, and signals failure. - - -- If the match of P succeeds, then node A, which is the actual - -- PC_Assign_Imm node, executes the assignment (using the stack - -- base to locate the entry with the saved starting cursor value), - -- and the pops the inner region. There are two possibilities, if - -- matching P left no stack entries, then all traces of the inner - -- region can be removed. If there are stack entries, then we push - -- an PC_Region_Replace stack entry whose "cursor" value is the - -- inner stack base value, and then restore the outer stack base - -- value, so the stack looks like: - - -- (stack entries made before assign pattern) - - -- (Special entry, node field not used, - -- used only to save initial cursor) - - -- (PC_R_Remove entry, "cursor" value is (negative) - -- saved base value for the enclosing region) - - -- (stack entries made by matching P) - - -- (PC_Region_Replace entry, "cursor" value is the (negative) - -- stack pointer value referencing the PC_R_Remove entry). - - -- If a subsequent failure occurs, the PC_Region_Replace node restores - -- the inner stack base value and signals failure to explore rematches - -- of the pattern P. - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the A node is numbered N + 1, - -- and the E node is N + 2. - - --------------------- - -- Assign On Match -- - --------------------- - - -- The assign on match (**) pattern is quite similar to the assign - -- immediate pattern, except that the actual assignment has to be - -- delayed. The following structure is constructed: - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| A |----> - -- +---+ +---+ +---+ - - -- The operation of this pattern is identical to that described above - -- for deferred assignment, up to the point where P has been matched. - - -- The A node, which is the PC_Assign_OnM node first pushes a - -- PC_Assign node onto the history stack. This node saves the ending - -- cursor and acts as a flag for the final assignment, as further - -- described below. - - -- It then stores a pointer to itself in the special entry node field. - -- This was otherwise unused, and is now used to retrieve the address - -- of the variable to be assigned at the end of the pattern. - - -- After that the inner region is terminated in the usual manner, - -- by stacking a PC_R_Restore entry as described for the assign - -- immediate case. Note that the optimization of completely - -- removing the inner region does not happen in this case, since - -- we have at least one stack entry (the PC_Assign one we just made). - -- The stack now looks like: - - -- (stack entries made before assign pattern) - - -- (Special entry, node points to copy of - -- the PC_Assign_OnM node, and the - -- cursor field saves the initial cursor). - - -- (PC_R_Remove entry, "cursor" value is (negative) - -- saved base value for the enclosing region) - - -- (stack entries made by matching P) - - -- (PC_Assign entry, saves final cursor) - - -- (PC_Region_Replace entry, "cursor" value is (negative) - -- stack pointer value referencing the PC_R_Remove entry). - - -- If a subsequent failure causes the PC_Assign node to execute it - -- simply removes itself and propagates the failure. - - -- If the match succeeds, then the history stack is scanned for - -- PC_Assign nodes, and the assignments are executed (examination - -- of the above diagram will show that all the necessary data is - -- at hand for the assignment). - - -- To optimize the common case where no assign-on-match operations - -- are present, a global flag Assign_OnM is maintained which is - -- initialize to False, and gets set True as part of the execution - -- of the PC_Assign_OnM node. The scan of the history stack for - -- PC_Assign entries is done only if this flag is set. - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the A node is numbered N + 1, - -- and the E node is N + 2. - - --------- - -- Bal -- - --------- - - -- Bal builds a single node: - - -- +---+ - -- | B |----> - -- +---+ - - -- The node B is the PC_Bal node which matches a parentheses balanced - -- string, starting at the current cursor position. It then updates - -- the cursor past this matched string, and stacks a pointer to itself - -- with this updated cursor value on the history stack, to extend the - -- matched string on a subsequent failure. - - -- Since this is a single node it is numbered 1 (the reason we include - -- it in the compound patterns section is that it backtracks). - - ------------ - -- BreakX -- - ------------ - - -- BreakX builds the structure - - -- +---+ +---+ - -- | B |---->| A |----> - -- +---+ +---+ - -- ^ . - -- | . - -- | +---+ - -- +<------| X | - -- +---+ - - -- Here the B node is the BreakX_xx node that performs a normal Break - -- function. The A node is an alternative (PC_Alt) node that matches - -- null, but stacks a pointer to node X (the PC_BreakX_X node) which - -- extends the match one character (to eat up the previously detected - -- break character), and then rematches the break. - - -- The B node is numbered 3, the alternative node is 1, and the X - -- node is 2. - - ----------- - -- Fence -- - ----------- - - -- Fence builds a single node: - - -- +---+ - -- | F |----> - -- +---+ - - -- The element F, PC_Fence, matches null, and stacks a pointer to a - -- PC_Cancel element which will abort the match on a subsequent failure. - - -- Since this is a single element it is numbered 1 (the reason we - -- include it in the compound patterns section is that it backtracks). - - -------------------- - -- Fence Function -- - -------------------- - - -- A call to the Fence function builds the structure: - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| X |----> - -- +---+ +---+ +---+ - - -- Here E is the PC_R_Enter node which matches null and creates two - -- stack entries. The first is a special entry which is not used at - -- all in the fence case (it is present merely for uniformity with - -- other cases of region enter operations). - - -- The second entry corresponds to a standard new region action. A - -- PC_R_Remove node is stacked, whose cursor field is used to store - -- the outer stack base, and the stack base is reset to point to - -- this PC_R_Remove node. Then the pattern P is matched, and it can - -- make history stack entries in the normal manner, so now the stack - -- looks like: - - -- (stack entries made before fence pattern) - - -- (Special entry, not used at all) - - -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base - -- saved base value for the enclosing region) - - -- (stack entries made by matching P) - - -- If the match of P fails, then the PC_R_Remove entry is popped - -- and it removes both itself and the special entry underneath it, - -- restores the outer stack base, and signals failure. - - -- If the match of P succeeds, then node X, the PC_Fence_X node, gets - -- control. One might be tempted to think that at this point, the - -- history stack entries made by matching P can just be removed since - -- they certainly are not going to be used for rematching (that is - -- whole point of Fence after all). However, this is wrong, because - -- it would result in the loss of possible assign-on-match entries - -- for deferred pattern assignments. - - -- Instead what we do is to make a special entry whose node references - -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e. - -- the pointer to the PC_R_Remove entry. Then the outer stack base - -- pointer is restored, so the stack looks like: - - -- (stack entries made before assign pattern) - - -- (Special entry, not used at all) - - -- (PC_R_Remove entry, "cursor" value is (negative) - -- saved base value for the enclosing region) - - -- (stack entries made by matching P) - - -- (PC_Fence_Y entry, "cursor" value is (negative) stack - -- pointer value referencing the PC_R_Remove entry). - - -- If a subsequent failure occurs, then the PC_Fence_Y entry removes - -- the entire inner region, including all entries made by matching P, - -- and alternatives prior to the Fence pattern are sought. - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the X node is numbered N + 1, - -- and the E node is N + 2. - - ------------- - -- Succeed -- - ------------- - - -- Succeed builds a single node: - - -- +---+ - -- | S |----> - -- +---+ - - -- The node S is the PC_Succeed node which matches null, and stacks - -- a pointer to itself on the history stack, so that a subsequent - -- failure repeats the same match. - - -- Since this is a single node it is numbered 1 (the reason we include - -- it in the compound patterns section is that it backtracks). - - --------------------- - -- Write Immediate -- - --------------------- - - -- The structure built for a write immediate operation (P * F, where - -- F is a file access value) is: - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| W |----> - -- +---+ +---+ +---+ - - -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The - -- handling is identical to that described above for Assign Immediate, - -- except that at the point where a successful match occurs, the matched - -- substring is written to the referenced file. - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the W node is numbered N + 1, - -- and the E node is N + 2. - - -------------------- - -- Write On Match -- - -------------------- - - -- The structure built for a write on match operation (P ** F, where - -- F is a file access value) is: - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| W |----> - -- +---+ +---+ +---+ - - -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The - -- handling is identical to that described above for Assign On Match, - -- except that at the point where a successful match has completed, - -- the matched substring is written to the referenced file. - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the W node is numbered N + 1, - -- and the E node is N + 2. - ----------------------- - -- Constant Patterns -- - ----------------------- - - -- The following pattern elements are referenced only from the pattern - -- history stack. In each case the processing for the pattern element - -- results in pattern match abort, or further failure, so there is no - -- need for a successor and no need for a node number - - CP_Assign : aliased PE := (PC_Assign, 0, N); - CP_Cancel : aliased PE := (PC_Cancel, 0, N); - CP_Fence_Y : aliased PE := (PC_Fence_Y, 0, N); - CP_R_Remove : aliased PE := (PC_R_Remove, 0, N); - CP_R_Restore : aliased PE := (PC_R_Restore, 0, N); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Alternate (L, R : PE_Ptr) return PE_Ptr; - function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate; - -- Build pattern structure corresponding to the alternation of L, R. - -- (i.e. try to match L, and if that fails, try to match R). - - function Arbno_Simple (P : PE_Ptr) return PE_Ptr; - -- Build simple Arbno pattern, P is a pattern that is guaranteed to - -- match at least one character if it succeeds and to require no - -- stack entries under all circumstances. The result returned is - -- a simple Arbno structure as previously described. - - function Bracket (E, P, A : PE_Ptr) return PE_Ptr; - -- Given two single node pattern elements E and A, and a (possible - -- complex) pattern P, construct the concatenation E-->P-->A and - -- return a pointer to E. The concatenation does not affect the - -- node numbering in P. A has a number one higher than the maximum - -- number in P, and E has a number two higher than the maximum - -- number in P (see for example the Assign_Immediate structure to - -- understand a typical use of this function). - - function BreakX_Make (B : PE_Ptr) return Pattern; - -- Given a pattern element for a Break pattern, returns the - -- corresponding BreakX compound pattern structure. - - function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr; - -- Creates a pattern element that represents a concatenation of the - -- two given pattern elements (i.e. the pattern L followed by R). - -- The result returned is always the same as L, but the pattern - -- referenced by L is modified to have R as a successor. This - -- procedure does not copy L or R, so if a copy is required, it - -- is the responsibility of the caller. The Incr parameter is an - -- amount to be added to the Nat field of any P_Arbno_Y node that is - -- in the left operand, it represents the additional stack space - -- required by the right operand. - - function C_To_PE (C : PChar) return PE_Ptr; - -- Given a character, constructs a pattern element that matches - -- the single character. - - function Copy (P : PE_Ptr) return PE_Ptr; - -- Creates a copy of the pattern element referenced by the given - -- pattern element reference. This is a deep copy, which means that - -- it follows the Next and Alt pointers. - - function Image (P : PE_Ptr) return String; - -- Returns the image of the address of the referenced pattern element. - -- This is equivalent to Image (To_Address (P)); - - function Is_In (C : Character; Str : String) return Boolean; - pragma Inline (Is_In); - -- Determines if the character C is in string Str - - procedure Logic_Error; - -- Called to raise Program_Error with an appropriate message if an - -- internal logic error is detected. - - function Str_BF (A : Boolean_Func) return String; - function Str_FP (A : File_Ptr) return String; - function Str_NF (A : Natural_Func) return String; - function Str_NP (A : Natural_Ptr) return String; - function Str_PP (A : Pattern_Ptr) return String; - function Str_VF (A : VString_Func) return String; - function Str_VP (A : VString_Ptr) return String; - -- These are debugging routines, which return a representation of the - -- given access value (they are called only by Image and Dump) - - procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr); - -- Adjusts all EOP pointers in Pat to point to Succ. No other changes - -- are made. In particular, Succ is unchanged, and no index numbers - -- are modified. Note that Pat may not be equal to EOP on entry. - - function S_To_PE (Str : PString) return PE_Ptr; - -- Given a string, constructs a pattern element that matches the string - - procedure Uninitialized_Pattern; - pragma No_Return (Uninitialized_Pattern); - -- Called to raise Program_Error with an appropriate error message if - -- an uninitialized pattern is used in any pattern construction or - -- pattern matching operation. - - procedure XMatch - (Subject : String; - Pat_P : PE_Ptr; - Pat_S : Natural; - Start : out Natural; - Stop : out Natural); - -- This is the common pattern match routine. It is passed a string and - -- a pattern, and it indicates success or failure, and on success the - -- section of the string matched. It does not perform any assignments - -- to the subject string, so pattern replacement is for the caller. - -- - -- Subject The subject string. The lower bound is always one. In the - -- Match procedures, it is fine to use strings whose lower bound - -- is not one, but we perform a one time conversion before the - -- call to XMatch, so that XMatch does not have to be bothered - -- with strange lower bounds. - -- - -- Pat_P Points to initial pattern element of pattern to be matched - -- - -- Pat_S Maximum required stack entries for pattern to be matched - -- - -- Start If match is successful, starting index of matched section. - -- This value is always non-zero. A value of zero is used to - -- indicate a failed match. - -- - -- Stop If match is successful, ending index of matched section. - -- This can be zero if we match the null string at the start, - -- in which case Start is set to zero, and Stop to one. If the - -- Match fails, then the contents of Stop is undefined. - - procedure XMatchD - (Subject : String; - Pat_P : PE_Ptr; - Pat_S : Natural; - Start : out Natural; - Stop : out Natural); - -- Identical in all respects to XMatch, except that trace information is - -- output on Standard_Output during execution of the match. This is the - -- version that is called if the original Match call has Debug => True. - - --------- - -- "&" -- - --------- - - function "&" (L : PString; R : Pattern) return Pattern is - begin - return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk)); - end "&"; - - function "&" (L : Pattern; R : PString) return Pattern is - begin - return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0)); - end "&"; - - function "&" (L : PChar; R : Pattern) return Pattern is - begin - return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk)); - end "&"; - - function "&" (L : Pattern; R : PChar) return Pattern is - begin - return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0)); - end "&"; - - function "&" (L : Pattern; R : Pattern) return Pattern is - begin - return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk)); - end "&"; - - --------- - -- "*" -- - --------- - - -- Assign immediate - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| A |----> - -- +---+ +---+ +---+ - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the A node is numbered N + 1, - -- and the E node is N + 2. - - function "*" (P : Pattern; Var : VString_Var) return Pattern is - Pat : constant PE_Ptr := Copy (P.P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - A : constant PE_Ptr := - new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); - begin - return (AFC with P.Stk + 3, Bracket (E, Pat, A)); - end "*"; - - function "*" (P : PString; Var : VString_Var) return Pattern is - Pat : constant PE_Ptr := S_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - A : constant PE_Ptr := - new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); - begin - return (AFC with 3, Bracket (E, Pat, A)); - end "*"; - - function "*" (P : PChar; Var : VString_Var) return Pattern is - Pat : constant PE_Ptr := C_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - A : constant PE_Ptr := - new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); - begin - return (AFC with 3, Bracket (E, Pat, A)); - end "*"; - - -- Write immediate - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| W |----> - -- +---+ +---+ +---+ - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the W node is numbered N + 1, - -- and the E node is N + 2. - - function "*" (P : Pattern; Fil : File_Access) return Pattern is - Pat : constant PE_Ptr := Copy (P.P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); - begin - return (AFC with 3, Bracket (E, Pat, W)); - end "*"; - - function "*" (P : PString; Fil : File_Access) return Pattern is - Pat : constant PE_Ptr := S_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); - begin - return (AFC with 3, Bracket (E, Pat, W)); - end "*"; - - function "*" (P : PChar; Fil : File_Access) return Pattern is - Pat : constant PE_Ptr := C_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); - begin - return (AFC with 3, Bracket (E, Pat, W)); - end "*"; - - ---------- - -- "**" -- - ---------- - - -- Assign on match - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| A |----> - -- +---+ +---+ +---+ - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the A node is numbered N + 1, - -- and the E node is N + 2. - - function "**" (P : Pattern; Var : VString_Var) return Pattern is - Pat : constant PE_Ptr := Copy (P.P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - A : constant PE_Ptr := - new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); - begin - return (AFC with P.Stk + 3, Bracket (E, Pat, A)); - end "**"; - - function "**" (P : PString; Var : VString_Var) return Pattern is - Pat : constant PE_Ptr := S_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - A : constant PE_Ptr := - new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); - begin - return (AFC with 3, Bracket (E, Pat, A)); - end "**"; - - function "**" (P : PChar; Var : VString_Var) return Pattern is - Pat : constant PE_Ptr := C_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - A : constant PE_Ptr := - new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); - begin - return (AFC with 3, Bracket (E, Pat, A)); - end "**"; - - -- Write on match - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| W |----> - -- +---+ +---+ +---+ - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the W node is numbered N + 1, - -- and the E node is N + 2. - - function "**" (P : Pattern; Fil : File_Access) return Pattern is - Pat : constant PE_Ptr := Copy (P.P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); - begin - return (AFC with P.Stk + 3, Bracket (E, Pat, W)); - end "**"; - - function "**" (P : PString; Fil : File_Access) return Pattern is - Pat : constant PE_Ptr := S_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); - begin - return (AFC with 3, Bracket (E, Pat, W)); - end "**"; - - function "**" (P : PChar; Fil : File_Access) return Pattern is - Pat : constant PE_Ptr := C_To_PE (P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); - begin - return (AFC with 3, Bracket (E, Pat, W)); - end "**"; - - --------- - -- "+" -- - --------- - - function "+" (Str : VString_Var) return Pattern is - begin - return - (AFC with 0, - new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access)); - end "+"; - - function "+" (Str : VString_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str)); - end "+"; - - function "+" (P : Pattern_Var) return Pattern is - begin - return - (AFC with 3, - new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access)); - end "+"; - - function "+" (P : Boolean_Func) return Pattern is - begin - return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P)); - end "+"; - - ---------- - -- "or" -- - ---------- - - function "or" (L : PString; R : Pattern) return Pattern is - begin - return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P)); - end "or"; - - function "or" (L : Pattern; R : PString) return Pattern is - begin - return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R)); - end "or"; - - function "or" (L : PString; R : PString) return Pattern is - begin - return (AFC with 1, S_To_PE (L) or S_To_PE (R)); - end "or"; - - function "or" (L : Pattern; R : Pattern) return Pattern is - begin - return (AFC with - Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P)); - end "or"; - - function "or" (L : PChar; R : Pattern) return Pattern is - begin - return (AFC with 1, C_To_PE (L) or Copy (R.P)); - end "or"; - - function "or" (L : Pattern; R : PChar) return Pattern is - begin - return (AFC with 1, Copy (L.P) or C_To_PE (R)); - end "or"; - - function "or" (L : PChar; R : PChar) return Pattern is - begin - return (AFC with 1, C_To_PE (L) or C_To_PE (R)); - end "or"; - - function "or" (L : PString; R : PChar) return Pattern is - begin - return (AFC with 1, S_To_PE (L) or C_To_PE (R)); - end "or"; - - function "or" (L : PChar; R : PString) return Pattern is - begin - return (AFC with 1, C_To_PE (L) or S_To_PE (R)); - end "or"; - - ------------ - -- Adjust -- - ------------ - - -- No two patterns share the same pattern elements, so the adjust - -- procedure for a Pattern assignment must do a deep copy of the - -- pattern element structure. - - procedure Adjust (Object : in out Pattern) is - begin - Object.P := Copy (Object.P); - end Adjust; - - --------------- - -- Alternate -- - --------------- - - function Alternate (L, R : PE_Ptr) return PE_Ptr is - begin - -- If the left pattern is null, then we just add the alternation - -- node with an index one greater than the right hand pattern. - - if L = EOP then - return new PE'(PC_Alt, R.Index + 1, EOP, R); - - -- If the left pattern is non-null, then build a reference vector - -- for its elements, and adjust their index values to accommodate - -- the right hand elements. Then add the alternation node. - - else - declare - Refs : Ref_Array (1 .. L.Index); - - begin - Build_Ref_Array (L, Refs); - - for J in Refs'Range loop - Refs (J).Index := Refs (J).Index + R.Index; - end loop; - end; - - return new PE'(PC_Alt, L.Index + 1, L, R); - end if; - end Alternate; - - --------- - -- Any -- - --------- - - function Any (Str : String) return Pattern is - begin - return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str))); - end Any; - - function Any (Str : VString) return Pattern is - begin - return Any (S (Str)); - end Any; - - function Any (Str : Character) return Pattern is - begin - return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str)); - end Any; - - function Any (Str : Character_Set) return Pattern is - begin - return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str)); - end Any; - - function Any (Str : not null access VString) return Pattern is - begin - return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str))); - end Any; - - function Any (Str : VString_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str)); - end Any; - - --------- - -- Arb -- - --------- - - -- +---+ - -- | X |----> - -- +---+ - -- . - -- . - -- +---+ - -- | Y |----> - -- +---+ - - -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1 - - function Arb return Pattern is - Y : constant PE_Ptr := new PE'(PC_Arb_Y, 1, EOP); - X : constant PE_Ptr := new PE'(PC_Arb_X, 2, EOP, Y); - begin - return (AFC with 1, X); - end Arb; - - ----------- - -- Arbno -- - ----------- - - function Arbno (P : PString) return Pattern is - begin - if P'Length = 0 then - return (AFC with 0, EOP); - else - return (AFC with 0, Arbno_Simple (S_To_PE (P))); - end if; - end Arbno; - - function Arbno (P : PChar) return Pattern is - begin - return (AFC with 0, Arbno_Simple (C_To_PE (P))); - end Arbno; - - function Arbno (P : Pattern) return Pattern is - Pat : constant PE_Ptr := Copy (P.P); - - begin - if P.Stk = 0 - and then OK_For_Simple_Arbno (Pat.Pcode) - then - return (AFC with 0, Arbno_Simple (Pat)); - end if; - - -- This is the complex case, either the pattern makes stack entries - -- or it is possible for the pattern to match the null string (more - -- accurately, we don't know that this is not the case). - - -- +--------------------------+ - -- | ^ - -- V | - -- +---+ | - -- | X |----> | - -- +---+ | - -- . | - -- . | - -- +---+ +---+ +---+ | - -- | E |---->| P |---->| Y |--->+ - -- +---+ +---+ +---+ - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the Y node is numbered N + 1, - -- the E node is N + 2, and the X node is N + 3. - - declare - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - X : constant PE_Ptr := new PE'(PC_Arbno_X, 0, EOP, E); - Y : constant PE_Ptr := new PE'(PC_Arbno_Y, 0, X, P.Stk + 3); - EPY : constant PE_Ptr := Bracket (E, Pat, Y); - begin - X.Alt := EPY; - X.Index := EPY.Index + 1; - return (AFC with P.Stk + 3, X); - end; - end Arbno; - - ------------------ - -- Arbno_Simple -- - ------------------ - - -- +-------------+ - -- | ^ - -- V | - -- +---+ | - -- | S |----> | - -- +---+ | - -- . | - -- . | - -- +---+ | - -- | P |---------->+ - -- +---+ - - -- The node numbering of the constituent pattern P is not affected. - -- The S node has a node number of P.Index + 1. - - -- Note that we know that P cannot be EOP, because a null pattern - -- does not meet the requirements for simple Arbno. - - function Arbno_Simple (P : PE_Ptr) return PE_Ptr is - S : constant PE_Ptr := new PE'(PC_Arbno_S, P.Index + 1, EOP, P); - begin - Set_Successor (P, S); - return S; - end Arbno_Simple; - - --------- - -- Bal -- - --------- - - function Bal return Pattern is - begin - return (AFC with 1, new PE'(PC_Bal, 1, EOP)); - end Bal; - - ------------- - -- Bracket -- - ------------- - - function Bracket (E, P, A : PE_Ptr) return PE_Ptr is - begin - if P = EOP then - E.Pthen := A; - E.Index := 2; - A.Index := 1; - - else - E.Pthen := P; - Set_Successor (P, A); - E.Index := P.Index + 2; - A.Index := P.Index + 1; - end if; - - return E; - end Bracket; - - ----------- - -- Break -- - ----------- - - function Break (Str : String) return Pattern is - begin - return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str))); - end Break; - - function Break (Str : VString) return Pattern is - begin - return Break (S (Str)); - end Break; - - function Break (Str : Character) return Pattern is - begin - return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str)); - end Break; - - function Break (Str : Character_Set) return Pattern is - begin - return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str)); - end Break; - - function Break (Str : not null access VString) return Pattern is - begin - return (AFC with 0, - new PE'(PC_Break_VP, 1, EOP, Str.all'Unchecked_Access)); - end Break; - - function Break (Str : VString_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str)); - end Break; - - ------------ - -- BreakX -- - ------------ - - function BreakX (Str : String) return Pattern is - begin - return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str))); - end BreakX; - - function BreakX (Str : VString) return Pattern is - begin - return BreakX (S (Str)); - end BreakX; - - function BreakX (Str : Character) return Pattern is - begin - return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str)); - end BreakX; - - function BreakX (Str : Character_Set) return Pattern is - begin - return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str)); - end BreakX; - - function BreakX (Str : not null access VString) return Pattern is - begin - return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str))); - end BreakX; - - function BreakX (Str : VString_Func) return Pattern is - begin - return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str)); - end BreakX; - - ----------------- - -- BreakX_Make -- - ----------------- - - -- +---+ +---+ - -- | B |---->| A |----> - -- +---+ +---+ - -- ^ . - -- | . - -- | +---+ - -- +<------| X | - -- +---+ - - -- The B node is numbered 3, the alternative node is 1, and the X - -- node is 2. - - function BreakX_Make (B : PE_Ptr) return Pattern is - X : constant PE_Ptr := new PE'(PC_BreakX_X, 2, B); - A : constant PE_Ptr := new PE'(PC_Alt, 1, EOP, X); - begin - B.Pthen := A; - return (AFC with 2, B); - end BreakX_Make; - - --------------------- - -- Build_Ref_Array -- - --------------------- - - procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is - - procedure Record_PE (E : PE_Ptr); - -- Record given pattern element if not already recorded in RA, - -- and also record any referenced pattern elements recursively. - - --------------- - -- Record_PE -- - --------------- - - procedure Record_PE (E : PE_Ptr) is - begin - PutD (" Record_PE called with PE_Ptr = " & Image (E)); - - if E = EOP or else RA (E.Index) /= null then - Put_LineD (", nothing to do"); - return; - - else - Put_LineD (", recording" & IndexT'Image (E.Index)); - RA (E.Index) := E; - Record_PE (E.Pthen); - - if E.Pcode in PC_Has_Alt then - Record_PE (E.Alt); - end if; - end if; - end Record_PE; - - -- Start of processing for Build_Ref_Array - - begin - New_LineD; - Put_LineD ("Entering Build_Ref_Array"); - Record_PE (E); - New_LineD; - end Build_Ref_Array; - - ------------- - -- C_To_PE -- - ------------- - - function C_To_PE (C : PChar) return PE_Ptr is - begin - return new PE'(PC_Char, 1, EOP, C); - end C_To_PE; - - ------------ - -- Cancel -- - ------------ - - function Cancel return Pattern is - begin - return (AFC with 0, new PE'(PC_Cancel, 1, EOP)); - end Cancel; - - ------------ - -- Concat -- - ------------ - - -- Concat needs to traverse the left operand performing the following - -- set of fixups: - - -- a) Any successor pointers (Pthen fields) that are set to EOP are - -- reset to point to the second operand. - - -- b) Any PC_Arbno_Y node has its stack count field incremented - -- by the parameter Incr provided for this purpose. - - -- d) Num fields of all pattern elements in the left operand are - -- adjusted to include the elements of the right operand. - - -- Note: we do not use Set_Successor in the processing for Concat, since - -- there is no point in doing two traversals, we may as well do everything - -- at the same time. - - function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr is - begin - if L = EOP then - return R; - - elsif R = EOP then - return L; - - else - declare - Refs : Ref_Array (1 .. L.Index); - -- We build a reference array for L whose N'th element points to - -- the pattern element of L whose original Index value is N. - - P : PE_Ptr; - - begin - Build_Ref_Array (L, Refs); - - for J in Refs'Range loop - P := Refs (J); - - P.Index := P.Index + R.Index; - - if P.Pcode = PC_Arbno_Y then - P.Nat := P.Nat + Incr; - end if; - - if P.Pthen = EOP then - P.Pthen := R; - end if; - - if P.Pcode in PC_Has_Alt and then P.Alt = EOP then - P.Alt := R; - end if; - end loop; - end; - - return L; - end if; - end Concat; - - ---------- - -- Copy -- - ---------- - - function Copy (P : PE_Ptr) return PE_Ptr is - begin - if P = null then - Uninitialized_Pattern; - - else - declare - Refs : Ref_Array (1 .. P.Index); - -- References to elements in P, indexed by Index field - - Copy : Ref_Array (1 .. P.Index); - -- Holds copies of elements of P, indexed by Index field - - E : PE_Ptr; - - begin - Build_Ref_Array (P, Refs); - - -- Now copy all nodes - - for J in Refs'Range loop - Copy (J) := new PE'(Refs (J).all); - end loop; - - -- Adjust all internal references - - for J in Copy'Range loop - E := Copy (J); - - -- Adjust successor pointer to point to copy - - if E.Pthen /= EOP then - E.Pthen := Copy (E.Pthen.Index); - end if; - - -- Adjust Alt pointer if there is one to point to copy - - if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then - E.Alt := Copy (E.Alt.Index); - end if; - - -- Copy referenced string - - if E.Pcode = PC_String then - E.Str := new String'(E.Str.all); - end if; - end loop; - - return Copy (P.Index); - end; - end if; - end Copy; - - ---------- - -- Dump -- - ---------- - - procedure Dump (P : Pattern) is - procedure Write_Node_Id (E : PE_Ptr; Cols : Natural); - -- Writes out a string identifying the given pattern element. Cols is - -- the column indentation level. - - ------------------- - -- Write_Node_Id -- - ------------------- - - procedure Write_Node_Id (E : PE_Ptr; Cols : Natural) is - begin - if E = EOP then - Put ("EOP"); - - for J in 4 .. Cols loop - Put (' '); - end loop; - - else - declare - Str : String (1 .. Cols); - N : Natural := Natural (E.Index); - - begin - Put ("#"); - - for J in reverse Str'Range loop - Str (J) := Character'Val (48 + N mod 10); - N := N / 10; - end loop; - - Put (Str); - end; - end if; - end Write_Node_Id; - - -- Local variables - - Cols : Natural := 2; - -- Number of columns used for pattern numbers, minimum is 2 - - E : PE_Ptr; - - subtype Count is Ada.Text_IO.Count; - Scol : Count; - -- Used to keep track of column in dump output - - -- Start of processing for Dump - - begin - New_Line; - Put - ("Pattern Dump Output (pattern at " - & Image (P'Address) - & ", S = " - & Natural'Image (P.Stk) & ')'); - New_Line; - - Scol := Col; - - while Col < Scol loop - Put ('-'); - end loop; - - New_Line; - - -- If uninitialized pattern, dump line and we are done - - if P.P = null then - Put_Line ("Uninitialized pattern value"); - return; - end if; - - -- If null pattern, just dump it and we are all done - - if P.P = EOP then - Put_Line ("EOP (null pattern)"); - return; - end if; - - declare - Refs : Ref_Array (1 .. P.P.Index); - -- We build a reference array whose N'th element points to the - -- pattern element whose Index value is N. - - begin - Build_Ref_Array (P.P, Refs); - - -- Set number of columns required for node numbers - - while 10 ** Cols - 1 < Integer (P.P.Index) loop - Cols := Cols + 1; - end loop; - - -- Now dump the nodes in reverse sequence. We output them in reverse - -- sequence since this corresponds to the natural order used to - -- construct the patterns. - - for J in reverse Refs'Range loop - E := Refs (J); - Write_Node_Id (E, Cols); - Set_Col (Count (Cols) + 4); - Put (Image (E)); - Put (" "); - Put (Pattern_Code'Image (E.Pcode)); - Put (" "); - Set_Col (21 + Count (Cols) + Address_Image_Length); - Write_Node_Id (E.Pthen, Cols); - Set_Col (24 + 2 * Count (Cols) + Address_Image_Length); - - case E.Pcode is - when PC_Alt - | PC_Arb_X - | PC_Arbno_S - | PC_Arbno_X - => - Write_Node_Id (E.Alt, Cols); - - when PC_Rpat => - Put (Str_PP (E.PP)); - - when PC_Pred_Func => - Put (Str_BF (E.BF)); - - when PC_Assign_Imm - | PC_Assign_OnM - | PC_Any_VP - | PC_Break_VP - | PC_BreakX_VP - | PC_NotAny_VP - | PC_NSpan_VP - | PC_Span_VP - | PC_String_VP - => - Put (Str_VP (E.VP)); - - when PC_Write_Imm - | PC_Write_OnM - => - Put (Str_FP (E.FP)); - - when PC_String => - Put (Image (E.Str.all)); - - when PC_String_2 => - Put (Image (E.Str2)); - - when PC_String_3 => - Put (Image (E.Str3)); - - when PC_String_4 => - Put (Image (E.Str4)); - - when PC_String_5 => - Put (Image (E.Str5)); - - when PC_String_6 => - Put (Image (E.Str6)); - - when PC_Setcur => - Put (Str_NP (E.Var)); - - when PC_Any_CH - | PC_Break_CH - | PC_BreakX_CH - | PC_Char - | PC_NotAny_CH - | PC_NSpan_CH - | PC_Span_CH - => - Put (''' & E.Char & '''); - - when PC_Any_CS - | PC_Break_CS - | PC_BreakX_CS - | PC_NotAny_CS - | PC_NSpan_CS - | PC_Span_CS - => - Put ('"' & To_Sequence (E.CS) & '"'); - - when PC_Arbno_Y - | PC_Len_Nat - | PC_Pos_Nat - | PC_RPos_Nat - | PC_RTab_Nat - | PC_Tab_Nat - => - Put (S (E.Nat)); - - when PC_Pos_NF - | PC_Len_NF - | PC_RPos_NF - | PC_RTab_NF - | PC_Tab_NF - => - Put (Str_NF (E.NF)); - - when PC_Pos_NP - | PC_Len_NP - | PC_RPos_NP - | PC_RTab_NP - | PC_Tab_NP - => - Put (Str_NP (E.NP)); - - when PC_Any_VF - | PC_Break_VF - | PC_BreakX_VF - | PC_NotAny_VF - | PC_NSpan_VF - | PC_Span_VF - | PC_String_VF - => - Put (Str_VF (E.VF)); - - when others => - null; - end case; - - New_Line; - end loop; - - New_Line; - end; - end Dump; - - ---------- - -- Fail -- - ---------- - - function Fail return Pattern is - begin - return (AFC with 0, new PE'(PC_Fail, 1, EOP)); - end Fail; - - ----------- - -- Fence -- - ----------- - - -- Simple case - - function Fence return Pattern is - begin - return (AFC with 1, new PE'(PC_Fence, 1, EOP)); - end Fence; - - -- Function case - - -- +---+ +---+ +---+ - -- | E |---->| P |---->| X |----> - -- +---+ +---+ +---+ - - -- The node numbering of the constituent pattern P is not affected. - -- Where N is the number of nodes in P, the X node is numbered N + 1, - -- and the E node is N + 2. - - function Fence (P : Pattern) return Pattern is - Pat : constant PE_Ptr := Copy (P.P); - E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); - X : constant PE_Ptr := new PE'(PC_Fence_X, 0, EOP); - begin - return (AFC with P.Stk + 1, Bracket (E, Pat, X)); - end Fence; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Pattern) is - - procedure Free is new Ada.Unchecked_Deallocation (PE, PE_Ptr); - procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); - - begin - -- Nothing to do if already freed - - if Object.P = null then - return; - - -- Otherwise we must free all elements - - else - declare - Refs : Ref_Array (1 .. Object.P.Index); - -- References to elements in pattern to be finalized - - begin - Build_Ref_Array (Object.P, Refs); - - for J in Refs'Range loop - if Refs (J).Pcode = PC_String then - Free (Refs (J).Str); - end if; - - Free (Refs (J)); - end loop; - - Object.P := null; - end; - end if; - end Finalize; - - ----------- - -- Image -- - ----------- - - function Image (P : PE_Ptr) return String is - begin - return Image (To_Address (P)); - end Image; - - function Image (P : Pattern) return String is - begin - return S (Image (P)); - end Image; - - function Image (P : Pattern) return VString is - - Kill_Ampersand : Boolean := False; - -- Set True to delete next & to be output to Result - - Result : VString := Nul; - -- The result is accumulated here, using Append - - Refs : Ref_Array (1 .. P.P.Index); - -- We build a reference array whose N'th element points to the - -- pattern element whose Index value is N. - - procedure Delete_Ampersand; - -- Deletes the ampersand at the end of Result - - procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean); - -- E refers to a pattern structure whose successor is given by Succ. - -- This procedure appends to Result a representation of this pattern. - -- The Paren parameter indicates whether parentheses are required if - -- the output is more than one element. - - procedure Image_One (E : in out PE_Ptr); - -- E refers to a pattern structure. This procedure appends to Result - -- a representation of the single simple or compound pattern structure - -- at the start of E and updates E to point to its successor. - - ---------------------- - -- Delete_Ampersand -- - ---------------------- - - procedure Delete_Ampersand is - L : constant Natural := Length (Result); - begin - if L > 2 then - Delete (Result, L - 1, L); - end if; - end Delete_Ampersand; - - --------------- - -- Image_One -- - --------------- - - procedure Image_One (E : in out PE_Ptr) is - - ER : PE_Ptr := E.Pthen; - -- Successor set as result in E unless reset - - begin - case E.Pcode is - when PC_Cancel => - Append (Result, "Cancel"); - - when PC_Alt => Alt : declare - - Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index; - -- Number of elements in left pattern of alternation - - Lowest_In_L : constant IndexT := E.Index - Elmts_In_L; - -- Number of lowest index in elements of left pattern - - E1 : PE_Ptr; - - begin - -- The successor of the alternation node must have a lower - -- index than any node that is in the left pattern or a - -- higher index than the alternation node itself. - - while ER /= EOP - and then ER.Index >= Lowest_In_L - and then ER.Index < E.Index - loop - ER := ER.Pthen; - end loop; - - Append (Result, '('); - - E1 := E; - loop - Image_Seq (E1.Pthen, ER, False); - Append (Result, " or "); - E1 := E1.Alt; - exit when E1.Pcode /= PC_Alt; - end loop; - - Image_Seq (E1, ER, False); - Append (Result, ')'); - end Alt; - - when PC_Any_CS => - Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')'); - - when PC_Any_VF => - Append (Result, "Any (" & Str_VF (E.VF) & ')'); - - when PC_Any_VP => - Append (Result, "Any (" & Str_VP (E.VP) & ')'); - - when PC_Arb_X => - Append (Result, "Arb"); - - when PC_Arbno_S => - Append (Result, "Arbno ("); - Image_Seq (E.Alt, E, False); - Append (Result, ')'); - - when PC_Arbno_X => - Append (Result, "Arbno ("); - Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False); - Append (Result, ')'); - - when PC_Assign_Imm => - Delete_Ampersand; - Append (Result, "* " & Str_VP (Refs (E.Index).VP)); - - when PC_Assign_OnM => - Delete_Ampersand; - Append (Result, "** " & Str_VP (Refs (E.Index).VP)); - - when PC_Any_CH => - Append (Result, "Any ('" & E.Char & "')"); - - when PC_Bal => - Append (Result, "Bal"); - - when PC_Break_CH => - Append (Result, "Break ('" & E.Char & "')"); - - when PC_Break_CS => - Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')'); - - when PC_Break_VF => - Append (Result, "Break (" & Str_VF (E.VF) & ')'); - - when PC_Break_VP => - Append (Result, "Break (" & Str_VP (E.VP) & ')'); - - when PC_BreakX_CH => - Append (Result, "BreakX ('" & E.Char & "')"); - ER := ER.Pthen; - - when PC_BreakX_CS => - Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')'); - ER := ER.Pthen; - - when PC_BreakX_VF => - Append (Result, "BreakX (" & Str_VF (E.VF) & ')'); - ER := ER.Pthen; - - when PC_BreakX_VP => - Append (Result, "BreakX (" & Str_VP (E.VP) & ')'); - ER := ER.Pthen; - - when PC_Char => - Append (Result, ''' & E.Char & '''); - - when PC_Fail => - Append (Result, "Fail"); - - when PC_Fence => - Append (Result, "Fence"); - - when PC_Fence_X => - Append (Result, "Fence ("); - Image_Seq (E.Pthen, Refs (E.Index - 1), False); - Append (Result, ")"); - ER := Refs (E.Index - 1).Pthen; - - when PC_Len_Nat => - Append (Result, "Len (" & E.Nat & ')'); - - when PC_Len_NF => - Append (Result, "Len (" & Str_NF (E.NF) & ')'); - - when PC_Len_NP => - Append (Result, "Len (" & Str_NP (E.NP) & ')'); - - when PC_NotAny_CH => - Append (Result, "NotAny ('" & E.Char & "')"); - - when PC_NotAny_CS => - Append (Result, "NotAny (" & Image (To_Sequence (E.CS)) & ')'); - - when PC_NotAny_VF => - Append (Result, "NotAny (" & Str_VF (E.VF) & ')'); - - when PC_NotAny_VP => - Append (Result, "NotAny (" & Str_VP (E.VP) & ')'); - - when PC_NSpan_CH => - Append (Result, "NSpan ('" & E.Char & "')"); - - when PC_NSpan_CS => - Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')'); - - when PC_NSpan_VF => - Append (Result, "NSpan (" & Str_VF (E.VF) & ')'); - - when PC_NSpan_VP => - Append (Result, "NSpan (" & Str_VP (E.VP) & ')'); - - when PC_Null => - Append (Result, """"""); - - when PC_Pos_Nat => - Append (Result, "Pos (" & E.Nat & ')'); - - when PC_Pos_NF => - Append (Result, "Pos (" & Str_NF (E.NF) & ')'); - - when PC_Pos_NP => - Append (Result, "Pos (" & Str_NP (E.NP) & ')'); - - when PC_R_Enter => - Kill_Ampersand := True; - - when PC_Rest => - Append (Result, "Rest"); - - when PC_Rpat => - Append (Result, "(+ " & Str_PP (E.PP) & ')'); - - when PC_Pred_Func => - Append (Result, "(+ " & Str_BF (E.BF) & ')'); - - when PC_RPos_Nat => - Append (Result, "RPos (" & E.Nat & ')'); - - when PC_RPos_NF => - Append (Result, "RPos (" & Str_NF (E.NF) & ')'); - - when PC_RPos_NP => - Append (Result, "RPos (" & Str_NP (E.NP) & ')'); - - when PC_RTab_Nat => - Append (Result, "RTab (" & E.Nat & ')'); - - when PC_RTab_NF => - Append (Result, "RTab (" & Str_NF (E.NF) & ')'); - - when PC_RTab_NP => - Append (Result, "RTab (" & Str_NP (E.NP) & ')'); - - when PC_Setcur => - Append (Result, "Setcur (" & Str_NP (E.Var) & ')'); - - when PC_Span_CH => - Append (Result, "Span ('" & E.Char & "')"); - - when PC_Span_CS => - Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')'); - - when PC_Span_VF => - Append (Result, "Span (" & Str_VF (E.VF) & ')'); - - when PC_Span_VP => - Append (Result, "Span (" & Str_VP (E.VP) & ')'); - - when PC_String => - Append (Result, Image (E.Str.all)); - - when PC_String_2 => - Append (Result, Image (E.Str2)); - - when PC_String_3 => - Append (Result, Image (E.Str3)); - - when PC_String_4 => - Append (Result, Image (E.Str4)); - - when PC_String_5 => - Append (Result, Image (E.Str5)); - - when PC_String_6 => - Append (Result, Image (E.Str6)); - - when PC_String_VF => - Append (Result, "(+" & Str_VF (E.VF) & ')'); - - when PC_String_VP => - Append (Result, "(+" & Str_VP (E.VP) & ')'); - - when PC_Succeed => - Append (Result, "Succeed"); - - when PC_Tab_Nat => - Append (Result, "Tab (" & E.Nat & ')'); - - when PC_Tab_NF => - Append (Result, "Tab (" & Str_NF (E.NF) & ')'); - - when PC_Tab_NP => - Append (Result, "Tab (" & Str_NP (E.NP) & ')'); - - when PC_Write_Imm => - Append (Result, '('); - Image_Seq (E, Refs (E.Index - 1), True); - Append (Result, " * " & Str_FP (Refs (E.Index - 1).FP)); - ER := Refs (E.Index - 1).Pthen; - - when PC_Write_OnM => - Append (Result, '('); - Image_Seq (E.Pthen, Refs (E.Index - 1), True); - Append (Result, " ** " & Str_FP (Refs (E.Index - 1).FP)); - ER := Refs (E.Index - 1).Pthen; - - -- Other pattern codes should not appear as leading elements - - when PC_Arb_Y - | PC_Arbno_Y - | PC_Assign - | PC_BreakX_X - | PC_EOP - | PC_Fence_Y - | PC_R_Remove - | PC_R_Restore - | PC_Unanchored - => - Append (Result, "???"); - end case; - - E := ER; - end Image_One; - - --------------- - -- Image_Seq -- - --------------- - - procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is - Indx : constant Natural := Length (Result); - E1 : PE_Ptr := E; - Mult : Boolean := False; - - begin - -- The image of EOP is "" (the null string) - - if E = EOP then - Append (Result, """"""); - - -- Else generate appropriate concatenation sequence - - else - loop - Image_One (E1); - exit when E1 = Succ; - exit when E1 = EOP; - Mult := True; - - if Kill_Ampersand then - Kill_Ampersand := False; - else - Append (Result, " & "); - end if; - end loop; - end if; - - if Mult and Paren then - Insert (Result, Indx + 1, "("); - Append (Result, ")"); - end if; - end Image_Seq; - - -- Start of processing for Image - - begin - Build_Ref_Array (P.P, Refs); - Image_Seq (P.P, EOP, False); - return Result; - end Image; - - ----------- - -- Is_In -- - ----------- - - function Is_In (C : Character; Str : String) return Boolean is - begin - for J in Str'Range loop - if Str (J) = C then - return True; - end if; - end loop; - - return False; - end Is_In; - - --------- - -- Len -- - --------- - - function Len (Count : Natural) return Pattern is - begin - -- Note, the following is not just an optimization, it is needed - -- to ensure that Arbno (Len (0)) does not generate an infinite - -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno). - - if Count = 0 then - return (AFC with 0, new PE'(PC_Null, 1, EOP)); - - else - return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count)); - end if; - end Len; - - function Len (Count : Natural_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count)); - end Len; - - function Len (Count : not null access Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count))); - end Len; - - ----------------- - -- Logic_Error -- - ----------------- - - procedure Logic_Error is - begin - raise Program_Error with - "Internal logic error in GNAT.Spitbol.Patterns"; - end Logic_Error; - - ----------- - -- Match -- - ----------- - - function Match - (Subject : VString; - Pat : Pattern) return Boolean - is - S : Big_String_Access; - L : Natural; - Start : Natural; - Stop : Natural; - pragma Unreferenced (Stop); - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - - return Start /= 0; - end Match; - - function Match - (Subject : String; - Pat : Pattern) return Boolean - is - Start, Stop : Natural; - pragma Unreferenced (Stop); - - subtype String1 is String (1 .. Subject'Length); - - begin - if Debug_Mode then - XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); - end if; - - return Start /= 0; - end Match; - - function Match - (Subject : VString_Var; - Pat : Pattern; - Replace : VString) return Boolean - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - - if Start = 0 then - return False; - else - Get_String (Replace, S, L); - Replace_Slice - (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L)); - return True; - end if; - end Match; - - function Match - (Subject : VString_Var; - Pat : Pattern; - Replace : String) return Boolean - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - - if Start = 0 then - return False; - else - Replace_Slice - (Subject'Unrestricted_Access.all, Start, Stop, Replace); - return True; - end if; - end Match; - - procedure Match - (Subject : VString; - Pat : Pattern) - is - S : Big_String_Access; - L : Natural; - - Start : Natural; - Stop : Natural; - pragma Unreferenced (Start, Stop); - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - end Match; - - procedure Match - (Subject : String; - Pat : Pattern) - is - Start, Stop : Natural; - pragma Unreferenced (Start, Stop); - - subtype String1 is String (1 .. Subject'Length); - - begin - if Debug_Mode then - XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); - end if; - end Match; - - procedure Match - (Subject : in out VString; - Pat : Pattern; - Replace : VString) - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - - if Start /= 0 then - Get_String (Replace, S, L); - Replace_Slice (Subject, Start, Stop, S (1 .. L)); - end if; - end Match; - - procedure Match - (Subject : in out VString; - Pat : Pattern; - Replace : String) - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - - if Start /= 0 then - Replace_Slice (Subject, Start, Stop, Replace); - end if; - end Match; - - function Match - (Subject : VString; - Pat : PString) return Boolean - is - Pat_Len : constant Natural := Pat'Length; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Anchored_Mode then - if Pat_Len > L then - return False; - else - return Pat = S (1 .. Pat_Len); - end if; - - else - for J in 1 .. L - Pat_Len + 1 loop - if Pat = S (J .. J + (Pat_Len - 1)) then - return True; - end if; - end loop; - - return False; - end if; - end Match; - - function Match - (Subject : String; - Pat : PString) return Boolean - is - Pat_Len : constant Natural := Pat'Length; - Sub_Len : constant Natural := Subject'Length; - SFirst : constant Natural := Subject'First; - - begin - if Anchored_Mode then - if Pat_Len > Sub_Len then - return False; - else - return Pat = Subject (SFirst .. SFirst + Pat_Len - 1); - end if; - - else - for J in SFirst .. SFirst + Sub_Len - Pat_Len loop - if Pat = Subject (J .. J + (Pat_Len - 1)) then - return True; - end if; - end loop; - - return False; - end if; - end Match; - - function Match - (Subject : VString_Var; - Pat : PString; - Replace : VString) return Boolean - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - else - XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - end if; - - if Start = 0 then - return False; - else - Get_String (Replace, S, L); - Replace_Slice - (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L)); - return True; - end if; - end Match; - - function Match - (Subject : VString_Var; - Pat : PString; - Replace : String) return Boolean - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - else - XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - end if; - - if Start = 0 then - return False; - else - Replace_Slice - (Subject'Unrestricted_Access.all, Start, Stop, Replace); - return True; - end if; - end Match; - - procedure Match - (Subject : VString; - Pat : PString) - is - S : Big_String_Access; - L : Natural; - - Start : Natural; - Stop : Natural; - pragma Unreferenced (Start, Stop); - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - else - XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - end if; - end Match; - - procedure Match - (Subject : String; - Pat : PString) - is - Start, Stop : Natural; - pragma Unreferenced (Start, Stop); - - subtype String1 is String (1 .. Subject'Length); - - begin - if Debug_Mode then - XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); - else - XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); - end if; - end Match; - - procedure Match - (Subject : in out VString; - Pat : PString; - Replace : VString) - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - else - XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - end if; - - if Start /= 0 then - Get_String (Replace, S, L); - Replace_Slice (Subject, Start, Stop, S (1 .. L)); - end if; - end Match; - - procedure Match - (Subject : in out VString; - Pat : PString; - Replace : String) - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - else - XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); - end if; - - if Start /= 0 then - Replace_Slice (Subject, Start, Stop, Replace); - end if; - end Match; - - function Match - (Subject : VString_Var; - Pat : Pattern; - Result : Match_Result_Var) return Boolean - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - - if Start = 0 then - Result'Unrestricted_Access.all.Var := null; - return False; - - else - Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access; - Result'Unrestricted_Access.all.Start := Start; - Result'Unrestricted_Access.all.Stop := Stop; - return True; - end if; - end Match; - - procedure Match - (Subject : in out VString; - Pat : Pattern; - Result : out Match_Result) - is - Start : Natural; - Stop : Natural; - S : Big_String_Access; - L : Natural; - - begin - Get_String (Subject, S, L); - - if Debug_Mode then - XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - else - XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); - end if; - - if Start = 0 then - Result.Var := null; - else - Result.Var := Subject'Unrestricted_Access; - Result.Start := Start; - Result.Stop := Stop; - end if; - end Match; - - --------------- - -- New_LineD -- - --------------- - - procedure New_LineD is - begin - if Internal_Debug then - New_Line; - end if; - end New_LineD; - - ------------ - -- NotAny -- - ------------ - - function NotAny (Str : String) return Pattern is - begin - return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str))); - end NotAny; - - function NotAny (Str : VString) return Pattern is - begin - return NotAny (S (Str)); - end NotAny; - - function NotAny (Str : Character) return Pattern is - begin - return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str)); - end NotAny; - - function NotAny (Str : Character_Set) return Pattern is - begin - return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str)); - end NotAny; - - function NotAny (Str : not null access VString) return Pattern is - begin - return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str))); - end NotAny; - - function NotAny (Str : VString_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str)); - end NotAny; - - ----------- - -- NSpan -- - ----------- - - function NSpan (Str : String) return Pattern is - begin - return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str))); - end NSpan; - - function NSpan (Str : VString) return Pattern is - begin - return NSpan (S (Str)); - end NSpan; - - function NSpan (Str : Character) return Pattern is - begin - return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str)); - end NSpan; - - function NSpan (Str : Character_Set) return Pattern is - begin - return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str)); - end NSpan; - - function NSpan (Str : not null access VString) return Pattern is - begin - return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str))); - end NSpan; - - function NSpan (Str : VString_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str)); - end NSpan; - - --------- - -- Pos -- - --------- - - function Pos (Count : Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count)); - end Pos; - - function Pos (Count : Natural_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count)); - end Pos; - - function Pos (Count : not null access Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count))); - end Pos; - - ---------- - -- PutD -- - ---------- - - procedure PutD (Str : String) is - begin - if Internal_Debug then - Put (Str); - end if; - end PutD; - - --------------- - -- Put_LineD -- - --------------- - - procedure Put_LineD (Str : String) is - begin - if Internal_Debug then - Put_Line (Str); - end if; - end Put_LineD; - - ------------- - -- Replace -- - ------------- - - procedure Replace - (Result : in out Match_Result; - Replace : VString) - is - S : Big_String_Access; - L : Natural; - - begin - Get_String (Replace, S, L); - - if Result.Var /= null then - Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L)); - Result.Var := null; - end if; - end Replace; - - ---------- - -- Rest -- - ---------- - - function Rest return Pattern is - begin - return (AFC with 0, new PE'(PC_Rest, 1, EOP)); - end Rest; - - ---------- - -- Rpos -- - ---------- - - function Rpos (Count : Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count)); - end Rpos; - - function Rpos (Count : Natural_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count)); - end Rpos; - - function Rpos (Count : not null access Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count))); - end Rpos; - - ---------- - -- Rtab -- - ---------- - - function Rtab (Count : Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count)); - end Rtab; - - function Rtab (Count : Natural_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count)); - end Rtab; - - function Rtab (Count : not null access Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count))); - end Rtab; - - ------------- - -- S_To_PE -- - ------------- - - function S_To_PE (Str : PString) return PE_Ptr is - Len : constant Natural := Str'Length; - - begin - case Len is - when 0 => - return new PE'(PC_Null, 1, EOP); - - when 1 => - return new PE'(PC_Char, 1, EOP, Str (Str'First)); - - when 2 => - return new PE'(PC_String_2, 1, EOP, Str); - - when 3 => - return new PE'(PC_String_3, 1, EOP, Str); - - when 4 => - return new PE'(PC_String_4, 1, EOP, Str); - - when 5 => - return new PE'(PC_String_5, 1, EOP, Str); - - when 6 => - return new PE'(PC_String_6, 1, EOP, Str); - - when others => - return new PE'(PC_String, 1, EOP, new String'(Str)); - end case; - end S_To_PE; - - ------------------- - -- Set_Successor -- - ------------------- - - -- Note: this procedure is not used by the normal concatenation circuit, - -- since other fixups are required on the left operand in this case, and - -- they might as well be done all together. - - procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is - begin - if Pat = null then - Uninitialized_Pattern; - - elsif Pat = EOP then - Logic_Error; - - else - declare - Refs : Ref_Array (1 .. Pat.Index); - -- We build a reference array for L whose N'th element points to - -- the pattern element of L whose original Index value is N. - - P : PE_Ptr; - - begin - Build_Ref_Array (Pat, Refs); - - for J in Refs'Range loop - P := Refs (J); - - if P.Pthen = EOP then - P.Pthen := Succ; - end if; - - if P.Pcode in PC_Has_Alt and then P.Alt = EOP then - P.Alt := Succ; - end if; - end loop; - end; - end if; - end Set_Successor; - - ------------ - -- Setcur -- - ------------ - - function Setcur (Var : not null access Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var))); - end Setcur; - - ---------- - -- Span -- - ---------- - - function Span (Str : String) return Pattern is - begin - return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str))); - end Span; - - function Span (Str : VString) return Pattern is - begin - return Span (S (Str)); - end Span; - - function Span (Str : Character) return Pattern is - begin - return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str)); - end Span; - - function Span (Str : Character_Set) return Pattern is - begin - return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str)); - end Span; - - function Span (Str : not null access VString) return Pattern is - begin - return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str))); - end Span; - - function Span (Str : VString_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str)); - end Span; - - ------------ - -- Str_BF -- - ------------ - - function Str_BF (A : Boolean_Func) return String is - function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address); - begin - return "BF(" & Image (To_A (A)) & ')'; - end Str_BF; - - ------------ - -- Str_FP -- - ------------ - - function Str_FP (A : File_Ptr) return String is - begin - return "FP(" & Image (A.all'Address) & ')'; - end Str_FP; - - ------------ - -- Str_NF -- - ------------ - - function Str_NF (A : Natural_Func) return String is - function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address); - begin - return "NF(" & Image (To_A (A)) & ')'; - end Str_NF; - - ------------ - -- Str_NP -- - ------------ - - function Str_NP (A : Natural_Ptr) return String is - begin - return "NP(" & Image (A.all'Address) & ')'; - end Str_NP; - - ------------ - -- Str_PP -- - ------------ - - function Str_PP (A : Pattern_Ptr) return String is - begin - return "PP(" & Image (A.all'Address) & ')'; - end Str_PP; - - ------------ - -- Str_VF -- - ------------ - - function Str_VF (A : VString_Func) return String is - function To_A is new Ada.Unchecked_Conversion (VString_Func, Address); - begin - return "VF(" & Image (To_A (A)) & ')'; - end Str_VF; - - ------------ - -- Str_VP -- - ------------ - - function Str_VP (A : VString_Ptr) return String is - begin - return "VP(" & Image (A.all'Address) & ')'; - end Str_VP; - - ------------- - -- Succeed -- - ------------- - - function Succeed return Pattern is - begin - return (AFC with 1, new PE'(PC_Succeed, 1, EOP)); - end Succeed; - - --------- - -- Tab -- - --------- - - function Tab (Count : Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count)); - end Tab; - - function Tab (Count : Natural_Func) return Pattern is - begin - return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count)); - end Tab; - - function Tab (Count : not null access Natural) return Pattern is - begin - return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count))); - end Tab; - - --------------------------- - -- Uninitialized_Pattern -- - --------------------------- - - procedure Uninitialized_Pattern is - begin - raise Program_Error with - "uninitialized value of type GNAT.Spitbol.Patterns.Pattern"; - end Uninitialized_Pattern; - - ------------ - -- XMatch -- - ------------ - - procedure XMatch - (Subject : String; - Pat_P : PE_Ptr; - Pat_S : Natural; - Start : out Natural; - Stop : out Natural) - is - Node : PE_Ptr; - -- Pointer to current pattern node. Initialized from Pat_P, and then - -- updated as the match proceeds through its constituent elements. - - Length : constant Natural := Subject'Length; - -- Length of string (= Subject'Last, since Subject'First is always 1) - - Cursor : Integer := 0; - -- If the value is non-negative, then this value is the index showing - -- the current position of the match in the subject string. The next - -- character to be matched is at Subject (Cursor + 1). Note that since - -- our view of the subject string in XMatch always has a lower bound - -- of one, regardless of original bounds, that this definition exactly - -- corresponds to the cursor value as referenced by functions like Pos. - -- - -- If the value is negative, then this is a saved stack pointer, - -- typically a base pointer of an inner or outer region. Cursor - -- temporarily holds such a value when it is popped from the stack - -- by Fail. In all cases, Cursor is reset to a proper non-negative - -- cursor value before the match proceeds (e.g. by propagating the - -- failure and popping a "real" cursor value from the stack. - - PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); - -- Dummy pattern element used in the unanchored case - - Stack : Stack_Type; - -- The pattern matching failure stack for this call to Match - - Stack_Ptr : Stack_Range; - -- Current stack pointer. This points to the top element of the stack - -- that is currently in use. At the outer level this is the special - -- entry placed on the stack according to the anchor mode. - - Stack_Init : constant Stack_Range := Stack'First + 1; - -- This is the initial value of the Stack_Ptr and Stack_Base. The - -- initial (Stack'First) element of the stack is not used so that - -- when we pop the last element off, Stack_Ptr is still in range. - - Stack_Base : Stack_Range; - -- This value is the stack base value, i.e. the stack pointer for the - -- first history stack entry in the current stack region. See separate - -- section on handling of recursive pattern matches. - - Assign_OnM : Boolean := False; - -- Set True if assign-on-match or write-on-match operations may be - -- present in the history stack, which must then be scanned on a - -- successful match. - - procedure Pop_Region; - pragma Inline (Pop_Region); - -- Used at the end of processing of an inner region. If the inner - -- region left no stack entries, then all trace of it is removed. - -- Otherwise a PC_Restore_Region entry is pushed to ensure proper - -- handling of alternatives in the inner region. - - procedure Push (Node : PE_Ptr); - pragma Inline (Push); - -- Make entry in pattern matching stack with current cursor value - - procedure Push_Region; - pragma Inline (Push_Region); - -- This procedure makes a new region on the history stack. The - -- caller first establishes the special entry on the stack, but - -- does not push the stack pointer. Then this call stacks a - -- PC_Remove_Region node, on top of this entry, using the cursor - -- field of the PC_Remove_Region entry to save the outer level - -- stack base value, and resets the stack base to point to this - -- PC_Remove_Region node. - - ---------------- - -- Pop_Region -- - ---------------- - - procedure Pop_Region is - begin - -- If nothing was pushed in the inner region, we can just get - -- rid of it entirely, leaving no traces that it was ever there - - if Stack_Ptr = Stack_Base then - Stack_Ptr := Stack_Base - 2; - Stack_Base := Stack (Stack_Ptr + 2).Cursor; - - -- If stuff was pushed in the inner region, then we have to - -- push a PC_R_Restore node so that we properly handle possible - -- rematches within the region. - - else - Stack_Ptr := Stack_Ptr + 1; - Stack (Stack_Ptr).Cursor := Stack_Base; - Stack (Stack_Ptr).Node := CP_R_Restore'Access; - Stack_Base := Stack (Stack_Base).Cursor; - end if; - end Pop_Region; - - ---------- - -- Push -- - ---------- - - procedure Push (Node : PE_Ptr) is - begin - Stack_Ptr := Stack_Ptr + 1; - Stack (Stack_Ptr).Cursor := Cursor; - Stack (Stack_Ptr).Node := Node; - end Push; - - ----------------- - -- Push_Region -- - ----------------- - - procedure Push_Region is - begin - Stack_Ptr := Stack_Ptr + 2; - Stack (Stack_Ptr).Cursor := Stack_Base; - Stack (Stack_Ptr).Node := CP_R_Remove'Access; - Stack_Base := Stack_Ptr; - end Push_Region; - - -- Start of processing for XMatch - - begin - if Pat_P = null then - Uninitialized_Pattern; - end if; - - -- Check we have enough stack for this pattern. This check deals with - -- every possibility except a match of a recursive pattern, where we - -- make a check at each recursion level. - - if Pat_S >= Stack_Size - 1 then - raise Pattern_Stack_Overflow; - end if; - - -- In anchored mode, the bottom entry on the stack is an abort entry - - if Anchored_Mode then - Stack (Stack_Init).Node := CP_Cancel'Access; - Stack (Stack_Init).Cursor := 0; - - -- In unanchored more, the bottom entry on the stack references - -- the special pattern element PE_Unanchored, whose Pthen field - -- points to the initial pattern element. The cursor value in this - -- entry is the number of anchor moves so far. - - else - Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; - Stack (Stack_Init).Cursor := 0; - end if; - - Stack_Ptr := Stack_Init; - Stack_Base := Stack_Ptr; - Cursor := 0; - Node := Pat_P; - goto Match; - - ----------------------------------------- - -- Main Pattern Matching State Control -- - ----------------------------------------- - - -- This is a state machine which uses gotos to change state. The - -- initial state is Match, to initiate the matching of the first - -- element, so the goto Match above starts the match. In the - -- following descriptions, we indicate the global values that - -- are relevant for the state transition. - - -- Come here if entire match fails - - <> - Start := 0; - Stop := 0; - return; - - -- Come here if entire match succeeds - - -- Cursor current position in subject string - - <> - Start := Stack (Stack_Init).Cursor + 1; - Stop := Cursor; - - -- Scan history stack for deferred assignments or writes - - if Assign_OnM then - for S in Stack_Init .. Stack_Ptr loop - if Stack (S).Node = CP_Assign'Access then - declare - Inner_Base : constant Stack_Range := - Stack (S + 1).Cursor; - Special_Entry : constant Stack_Range := - Inner_Base - 1; - Node_OnM : constant PE_Ptr := - Stack (Special_Entry).Node; - Start : constant Natural := - Stack (Special_Entry).Cursor + 1; - Stop : constant Natural := Stack (S).Cursor; - - begin - if Node_OnM.Pcode = PC_Assign_OnM then - Set_Unbounded_String - (Node_OnM.VP.all, Subject (Start .. Stop)); - - elsif Node_OnM.Pcode = PC_Write_OnM then - Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); - - else - Logic_Error; - end if; - end; - end if; - end loop; - end if; - - return; - - -- Come here if attempt to match current element fails - - -- Stack_Base current stack base - -- Stack_Ptr current stack pointer - - <> - Cursor := Stack (Stack_Ptr).Cursor; - Node := Stack (Stack_Ptr).Node; - Stack_Ptr := Stack_Ptr - 1; - goto Match; - - -- Come here if attempt to match current element succeeds - - -- Cursor current position in subject string - -- Node pointer to node successfully matched - -- Stack_Base current stack base - -- Stack_Ptr current stack pointer - - <> - Node := Node.Pthen; - - -- Come here to match the next pattern element - - -- Cursor current position in subject string - -- Node pointer to node to be matched - -- Stack_Base current stack base - -- Stack_Ptr current stack pointer - - <> - - -------------------------------------------------- - -- Main Pattern Match Element Matching Routines -- - -------------------------------------------------- - - -- Here is the case statement that processes the current node. The - -- processing for each element does one of five things: - - -- goto Succeed to move to the successor - -- goto Match_Succeed if the entire match succeeds - -- goto Match_Fail if the entire match fails - -- goto Fail to signal failure of current match - - -- Processing is NOT allowed to fall through - - case Node.Pcode is - - -- Cancel - - when PC_Cancel => - goto Match_Fail; - - -- Alternation - - when PC_Alt => - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Any (one character case) - - when PC_Any_CH => - if Cursor < Length - and then Subject (Cursor + 1) = Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- Any (character set case) - - when PC_Any_CS => - if Cursor < Length - and then Is_In (Subject (Cursor + 1), Node.CS) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- Any (string function case) - - when PC_Any_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - if Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Any (string pointer case) - - when PC_Any_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - if Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Arb (initial match) - - when PC_Arb_X => - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arb (extension) - - when PC_Arb_Y => - if Cursor < Length then - Cursor := Cursor + 1; - Push (Node); - goto Succeed; - else - goto Fail; - end if; - - -- Arbno_S (simple Arbno initialize). This is the node that - -- initiates the match of a simple Arbno structure. - - when PC_Arbno_S => - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arbno_X (Arbno initialize). This is the node that initiates - -- the match of a complex Arbno structure. - - when PC_Arbno_X => - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arbno_Y (Arbno rematch). This is the node that is executed - -- following successful matching of one instance of a complex - -- Arbno pattern. - - when PC_Arbno_Y => declare - Null_Match : constant Boolean := - Cursor = Stack (Stack_Base - 1).Cursor; - - begin - Pop_Region; - - -- If arbno extension matched null, then immediately fail - - if Null_Match then - goto Fail; - end if; - - -- Here we must do a stack check to make sure enough stack - -- is left. This check will happen once for each instance of - -- the Arbno pattern that is matched. The Nat field of a - -- PC_Arbno pattern contains the maximum stack entries needed - -- for the Arbno with one instance and the successor pattern - - if Stack_Ptr + Node.Nat >= Stack'Last then - raise Pattern_Stack_Overflow; - end if; - - goto Succeed; - end; - - -- Assign. If this node is executed, it means the assign-on-match - -- or write-on-match operation will not happen after all, so we - -- is propagate the failure, removing the PC_Assign node. - - when PC_Assign => - goto Fail; - - -- Assign immediate. This node performs the actual assignment - - when PC_Assign_Imm => - Set_Unbounded_String - (Node.VP.all, - Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); - Pop_Region; - goto Succeed; - - -- Assign on match. This node sets up for the eventual assignment - - when PC_Assign_OnM => - Stack (Stack_Base - 1).Node := Node; - Push (CP_Assign'Access); - Pop_Region; - Assign_OnM := True; - goto Succeed; - - -- Bal - - when PC_Bal => - if Cursor >= Length or else Subject (Cursor + 1) = ')' then - goto Fail; - - elsif Subject (Cursor + 1) = '(' then - declare - Paren_Count : Natural := 1; - - begin - loop - Cursor := Cursor + 1; - - if Cursor >= Length then - goto Fail; - - elsif Subject (Cursor + 1) = '(' then - Paren_Count := Paren_Count + 1; - - elsif Subject (Cursor + 1) = ')' then - Paren_Count := Paren_Count - 1; - exit when Paren_Count = 0; - end if; - end loop; - end; - end if; - - Cursor := Cursor + 1; - Push (Node); - goto Succeed; - - -- Break (one character case) - - when PC_Break_CH => - while Cursor < Length loop - if Subject (Cursor + 1) = Node.Char then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- Break (character set case) - - when PC_Break_CS => - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), Node.CS) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- Break (string function case) - - when PC_Break_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- Break (string pointer case) - - when PC_Break_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (one character case) - - when PC_BreakX_CH => - while Cursor < Length loop - if Subject (Cursor + 1) = Node.Char then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (character set case) - - when PC_BreakX_CS => - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), Node.CS) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (string function case) - - when PC_BreakX_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (string pointer case) - - when PC_BreakX_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX_X (BreakX extension). See section on "Compound Pattern - -- Structures". This node is the alternative that is stacked to - -- skip past the break character and extend the break. - - when PC_BreakX_X => - Cursor := Cursor + 1; - goto Succeed; - - -- Character (one character string) - - when PC_Char => - if Cursor < Length - and then Subject (Cursor + 1) = Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- End of Pattern - - when PC_EOP => - if Stack_Base = Stack_Init then - goto Match_Succeed; - - -- End of recursive inner match. See separate section on - -- handing of recursive pattern matches for details. - - else - Node := Stack (Stack_Base - 1).Node; - Pop_Region; - goto Match; - end if; - - -- Fail - - when PC_Fail => - goto Fail; - - -- Fence (built in pattern) - - when PC_Fence => - Push (CP_Cancel'Access); - goto Succeed; - - -- Fence function node X. This is the node that gets control - -- after a successful match of the fenced pattern. - - when PC_Fence_X => - Stack_Ptr := Stack_Ptr + 1; - Stack (Stack_Ptr).Cursor := Stack_Base; - Stack (Stack_Ptr).Node := CP_Fence_Y'Access; - Stack_Base := Stack (Stack_Base).Cursor; - goto Succeed; - - -- Fence function node Y. This is the node that gets control on - -- a failure that occurs after the fenced pattern has matched. - - -- Note: the Cursor at this stage is actually the inner stack - -- base value. We don't reset this, but we do use it to strip - -- off all the entries made by the fenced pattern. - - when PC_Fence_Y => - Stack_Ptr := Cursor - 2; - goto Fail; - - -- Len (integer case) - - when PC_Len_Nat => - if Cursor + Node.Nat > Length then - goto Fail; - else - Cursor := Cursor + Node.Nat; - goto Succeed; - end if; - - -- Len (Integer function case) - - when PC_Len_NF => declare - N : constant Natural := Node.NF.all; - begin - if Cursor + N > Length then - goto Fail; - else - Cursor := Cursor + N; - goto Succeed; - end if; - end; - - -- Len (integer pointer case) - - when PC_Len_NP => - if Cursor + Node.NP.all > Length then - goto Fail; - else - Cursor := Cursor + Node.NP.all; - goto Succeed; - end if; - - -- NotAny (one character case) - - when PC_NotAny_CH => - if Cursor < Length - and then Subject (Cursor + 1) /= Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- NotAny (character set case) - - when PC_NotAny_CS => - if Cursor < Length - and then not Is_In (Subject (Cursor + 1), Node.CS) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- NotAny (string function case) - - when PC_NotAny_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - if Cursor < Length - and then - not Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- NotAny (string pointer case) - - when PC_NotAny_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - if Cursor < Length - and then - not Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- NSpan (one character case) - - when PC_NSpan_CH => - while Cursor < Length - and then Subject (Cursor + 1) = Node.Char - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - - -- NSpan (character set case) - - when PC_NSpan_CS => - while Cursor < Length - and then Is_In (Subject (Cursor + 1), Node.CS) - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - - -- NSpan (string function case) - - when PC_NSpan_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - end; - - -- NSpan (string pointer case) - - when PC_NSpan_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - while Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - end; - - -- Null string - - when PC_Null => - goto Succeed; - - -- Pos (integer case) - - when PC_Pos_Nat => - if Cursor = Node.Nat then - goto Succeed; - else - goto Fail; - end if; - - -- Pos (Integer function case) - - when PC_Pos_NF => declare - N : constant Natural := Node.NF.all; - begin - if Cursor = N then - goto Succeed; - else - goto Fail; - end if; - end; - - -- Pos (integer pointer case) - - when PC_Pos_NP => - if Cursor = Node.NP.all then - goto Succeed; - else - goto Fail; - end if; - - -- Predicate function - - when PC_Pred_Func => - if Node.BF.all then - goto Succeed; - else - goto Fail; - end if; - - -- Region Enter. Initiate new pattern history stack region - - when PC_R_Enter => - Stack (Stack_Ptr + 1).Cursor := Cursor; - Push_Region; - goto Succeed; - - -- Region Remove node. This is the node stacked by an R_Enter. - -- It removes the special format stack entry right underneath, and - -- then restores the outer level stack base and signals failure. - - -- Note: the cursor value at this stage is actually the (negative) - -- stack base value for the outer level. - - when PC_R_Remove => - Stack_Base := Cursor; - Stack_Ptr := Stack_Ptr - 1; - goto Fail; - - -- Region restore node. This is the node stacked at the end of an - -- inner level match. Its function is to restore the inner level - -- region, so that alternatives in this region can be sought. - - -- Note: the Cursor at this stage is actually the negative of the - -- inner stack base value, which we use to restore the inner region. - - when PC_R_Restore => - Stack_Base := Cursor; - goto Fail; - - -- Rest - - when PC_Rest => - Cursor := Length; - goto Succeed; - - -- Initiate recursive match (pattern pointer case) - - when PC_Rpat => - Stack (Stack_Ptr + 1).Node := Node.Pthen; - Push_Region; - - if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then - raise Pattern_Stack_Overflow; - else - Node := Node.PP.all.P; - goto Match; - end if; - - -- RPos (integer case) - - when PC_RPos_Nat => - if Cursor = (Length - Node.Nat) then - goto Succeed; - else - goto Fail; - end if; - - -- RPos (integer function case) - - when PC_RPos_NF => declare - N : constant Natural := Node.NF.all; - begin - if Length - Cursor = N then - goto Succeed; - else - goto Fail; - end if; - end; - - -- RPos (integer pointer case) - - when PC_RPos_NP => - if Cursor = (Length - Node.NP.all) then - goto Succeed; - else - goto Fail; - end if; - - -- RTab (integer case) - - when PC_RTab_Nat => - if Cursor <= (Length - Node.Nat) then - Cursor := Length - Node.Nat; - goto Succeed; - else - goto Fail; - end if; - - -- RTab (integer function case) - - when PC_RTab_NF => declare - N : constant Natural := Node.NF.all; - begin - if Length - Cursor >= N then - Cursor := Length - N; - goto Succeed; - else - goto Fail; - end if; - end; - - -- RTab (integer pointer case) - - when PC_RTab_NP => - if Cursor <= (Length - Node.NP.all) then - Cursor := Length - Node.NP.all; - goto Succeed; - else - goto Fail; - end if; - - -- Cursor assignment - - when PC_Setcur => - Node.Var.all := Cursor; - goto Succeed; - - -- Span (one character case) - - when PC_Span_CH => declare - P : Natural; - - begin - P := Cursor; - while P < Length - and then Subject (P + 1) = Node.Char - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Span (character set case) - - when PC_Span_CS => declare - P : Natural; - - begin - P := Cursor; - while P < Length - and then Is_In (Subject (P + 1), Node.CS) - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Span (string function case) - - when PC_Span_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - P : Natural; - - begin - Get_String (U, S, L); - - P := Cursor; - while P < Length - and then Is_In (Subject (P + 1), S (1 .. L)) - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Span (string pointer case) - - when PC_Span_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - P : Natural; - - begin - Get_String (U, S, L); - - P := Cursor; - while P < Length - and then Is_In (Subject (P + 1), S (1 .. L)) - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- String (two character case) - - when PC_String_2 => - if (Length - Cursor) >= 2 - and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 - then - Cursor := Cursor + 2; - goto Succeed; - else - goto Fail; - end if; - - -- String (three character case) - - when PC_String_3 => - if (Length - Cursor) >= 3 - and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 - then - Cursor := Cursor + 3; - goto Succeed; - else - goto Fail; - end if; - - -- String (four character case) - - when PC_String_4 => - if (Length - Cursor) >= 4 - and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 - then - Cursor := Cursor + 4; - goto Succeed; - else - goto Fail; - end if; - - -- String (five character case) - - when PC_String_5 => - if (Length - Cursor) >= 5 - and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 - then - Cursor := Cursor + 5; - goto Succeed; - else - goto Fail; - end if; - - -- String (six character case) - - when PC_String_6 => - if (Length - Cursor) >= 6 - and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 - then - Cursor := Cursor + 6; - goto Succeed; - else - goto Fail; - end if; - - -- String (case of more than six characters) - - when PC_String => declare - Len : constant Natural := Node.Str'Length; - begin - if (Length - Cursor) >= Len - and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) - then - Cursor := Cursor + Len; - goto Succeed; - else - goto Fail; - end if; - end; - - -- String (function case) - - when PC_String_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - if (Length - Cursor) >= L - and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) - then - Cursor := Cursor + L; - goto Succeed; - else - goto Fail; - end if; - end; - - -- String (pointer case) - - when PC_String_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - if (Length - Cursor) >= L - and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) - then - Cursor := Cursor + L; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Succeed - - when PC_Succeed => - Push (Node); - goto Succeed; - - -- Tab (integer case) - - when PC_Tab_Nat => - if Cursor <= Node.Nat then - Cursor := Node.Nat; - goto Succeed; - else - goto Fail; - end if; - - -- Tab (integer function case) - - when PC_Tab_NF => declare - N : constant Natural := Node.NF.all; - begin - if Cursor <= N then - Cursor := N; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Tab (integer pointer case) - - when PC_Tab_NP => - if Cursor <= Node.NP.all then - Cursor := Node.NP.all; - goto Succeed; - else - goto Fail; - end if; - - -- Unanchored movement - - when PC_Unanchored => - - -- All done if we tried every position - - if Cursor > Length then - goto Match_Fail; - - -- Otherwise extend the anchor point, and restack ourself - - else - Cursor := Cursor + 1; - Push (Node); - goto Succeed; - end if; - - -- Write immediate. This node performs the actual write - - when PC_Write_Imm => - Put_Line - (Node.FP.all, - Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); - Pop_Region; - goto Succeed; - - -- Write on match. This node sets up for the eventual write - - when PC_Write_OnM => - Stack (Stack_Base - 1).Node := Node; - Push (CP_Assign'Access); - Pop_Region; - Assign_OnM := True; - goto Succeed; - end case; - - -- We are NOT allowed to fall though this case statement, since every - -- match routine must end by executing a goto to the appropriate point - -- in the finite state machine model. - - pragma Warnings (Off); - Logic_Error; - pragma Warnings (On); - end XMatch; - - ------------- - -- XMatchD -- - ------------- - - -- Maintenance note: There is a LOT of code duplication between XMatch - -- and XMatchD. This is quite intentional, the point is to avoid any - -- unnecessary debugging overhead in the XMatch case, but this does mean - -- that any changes to XMatchD must be mirrored in XMatch. In case of - -- any major changes, the proper approach is to delete XMatch, make the - -- changes to XMatchD, and then make a copy of XMatchD, removing all - -- calls to Dout, and all Put and Put_Line operations. This copy becomes - -- the new XMatch. - - procedure XMatchD - (Subject : String; - Pat_P : PE_Ptr; - Pat_S : Natural; - Start : out Natural; - Stop : out Natural) - is - Node : PE_Ptr; - -- Pointer to current pattern node. Initialized from Pat_P, and then - -- updated as the match proceeds through its constituent elements. - - Length : constant Natural := Subject'Length; - -- Length of string (= Subject'Last, since Subject'First is always 1) - - Cursor : Integer := 0; - -- If the value is non-negative, then this value is the index showing - -- the current position of the match in the subject string. The next - -- character to be matched is at Subject (Cursor + 1). Note that since - -- our view of the subject string in XMatch always has a lower bound - -- of one, regardless of original bounds, that this definition exactly - -- corresponds to the cursor value as referenced by functions like Pos. - -- - -- If the value is negative, then this is a saved stack pointer, - -- typically a base pointer of an inner or outer region. Cursor - -- temporarily holds such a value when it is popped from the stack - -- by Fail. In all cases, Cursor is reset to a proper non-negative - -- cursor value before the match proceeds (e.g. by propagating the - -- failure and popping a "real" cursor value from the stack. - - PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); - -- Dummy pattern element used in the unanchored case - - Region_Level : Natural := 0; - -- Keeps track of recursive region level. This is used only for - -- debugging, it is the number of saved history stack base values. - - Stack : Stack_Type; - -- The pattern matching failure stack for this call to Match - - Stack_Ptr : Stack_Range; - -- Current stack pointer. This points to the top element of the stack - -- that is currently in use. At the outer level this is the special - -- entry placed on the stack according to the anchor mode. - - Stack_Init : constant Stack_Range := Stack'First + 1; - -- This is the initial value of the Stack_Ptr and Stack_Base. The - -- initial (Stack'First) element of the stack is not used so that - -- when we pop the last element off, Stack_Ptr is still in range. - - Stack_Base : Stack_Range; - -- This value is the stack base value, i.e. the stack pointer for the - -- first history stack entry in the current stack region. See separate - -- section on handling of recursive pattern matches. - - Assign_OnM : Boolean := False; - -- Set True if assign-on-match or write-on-match operations may be - -- present in the history stack, which must then be scanned on a - -- successful match. - - procedure Dout (Str : String); - -- Output string to standard error with bars indicating region level - - procedure Dout (Str : String; A : Character); - -- Calls Dout with the string S ('A') - - procedure Dout (Str : String; A : Character_Set); - -- Calls Dout with the string S ("A") - - procedure Dout (Str : String; A : Natural); - -- Calls Dout with the string S (A) - - procedure Dout (Str : String; A : String); - -- Calls Dout with the string S ("A") - - function Img (P : PE_Ptr) return String; - -- Returns a string of the form #nnn where nnn is P.Index - - procedure Pop_Region; - pragma Inline (Pop_Region); - -- Used at the end of processing of an inner region. If the inner - -- region left no stack entries, then all trace of it is removed. - -- Otherwise a PC_Restore_Region entry is pushed to ensure proper - -- handling of alternatives in the inner region. - - procedure Push (Node : PE_Ptr); - pragma Inline (Push); - -- Make entry in pattern matching stack with current cursor value - - procedure Push_Region; - pragma Inline (Push_Region); - -- This procedure makes a new region on the history stack. The - -- caller first establishes the special entry on the stack, but - -- does not push the stack pointer. Then this call stacks a - -- PC_Remove_Region node, on top of this entry, using the cursor - -- field of the PC_Remove_Region entry to save the outer level - -- stack base value, and resets the stack base to point to this - -- PC_Remove_Region node. - - ---------- - -- Dout -- - ---------- - - procedure Dout (Str : String) is - begin - for J in 1 .. Region_Level loop - Put ("| "); - end loop; - - Put_Line (Str); - end Dout; - - procedure Dout (Str : String; A : Character) is - begin - Dout (Str & " ('" & A & "')"); - end Dout; - - procedure Dout (Str : String; A : Character_Set) is - begin - Dout (Str & " (" & Image (To_Sequence (A)) & ')'); - end Dout; - - procedure Dout (Str : String; A : Natural) is - begin - Dout (Str & " (" & A & ')'); - end Dout; - - procedure Dout (Str : String; A : String) is - begin - Dout (Str & " (" & Image (A) & ')'); - end Dout; - - --------- - -- Img -- - --------- - - function Img (P : PE_Ptr) return String is - begin - return "#" & Integer (P.Index) & " "; - end Img; - - ---------------- - -- Pop_Region -- - ---------------- - - procedure Pop_Region is - begin - Region_Level := Region_Level - 1; - - -- If nothing was pushed in the inner region, we can just get - -- rid of it entirely, leaving no traces that it was ever there - - if Stack_Ptr = Stack_Base then - Stack_Ptr := Stack_Base - 2; - Stack_Base := Stack (Stack_Ptr + 2).Cursor; - - -- If stuff was pushed in the inner region, then we have to - -- push a PC_R_Restore node so that we properly handle possible - -- rematches within the region. - - else - Stack_Ptr := Stack_Ptr + 1; - Stack (Stack_Ptr).Cursor := Stack_Base; - Stack (Stack_Ptr).Node := CP_R_Restore'Access; - Stack_Base := Stack (Stack_Base).Cursor; - end if; - end Pop_Region; - - ---------- - -- Push -- - ---------- - - procedure Push (Node : PE_Ptr) is - begin - Stack_Ptr := Stack_Ptr + 1; - Stack (Stack_Ptr).Cursor := Cursor; - Stack (Stack_Ptr).Node := Node; - end Push; - - ----------------- - -- Push_Region -- - ----------------- - - procedure Push_Region is - begin - Region_Level := Region_Level + 1; - Stack_Ptr := Stack_Ptr + 2; - Stack (Stack_Ptr).Cursor := Stack_Base; - Stack (Stack_Ptr).Node := CP_R_Remove'Access; - Stack_Base := Stack_Ptr; - end Push_Region; - - -- Start of processing for XMatchD - - begin - New_Line; - Put_Line ("Initiating pattern match, subject = " & Image (Subject)); - Put ("--------------------------------------"); - - for J in 1 .. Length loop - Put ('-'); - end loop; - - New_Line; - Put_Line ("subject length = " & Length); - - if Pat_P = null then - Uninitialized_Pattern; - end if; - - -- Check we have enough stack for this pattern. This check deals with - -- every possibility except a match of a recursive pattern, where we - -- make a check at each recursion level. - - if Pat_S >= Stack_Size - 1 then - raise Pattern_Stack_Overflow; - end if; - - -- In anchored mode, the bottom entry on the stack is an abort entry - - if Anchored_Mode then - Stack (Stack_Init).Node := CP_Cancel'Access; - Stack (Stack_Init).Cursor := 0; - - -- In unanchored more, the bottom entry on the stack references - -- the special pattern element PE_Unanchored, whose Pthen field - -- points to the initial pattern element. The cursor value in this - -- entry is the number of anchor moves so far. - - else - Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; - Stack (Stack_Init).Cursor := 0; - end if; - - Stack_Ptr := Stack_Init; - Stack_Base := Stack_Ptr; - Cursor := 0; - Node := Pat_P; - goto Match; - - ----------------------------------------- - -- Main Pattern Matching State Control -- - ----------------------------------------- - - -- This is a state machine which uses gotos to change state. The - -- initial state is Match, to initiate the matching of the first - -- element, so the goto Match above starts the match. In the - -- following descriptions, we indicate the global values that - -- are relevant for the state transition. - - -- Come here if entire match fails - - <> - Dout ("match fails"); - New_Line; - Start := 0; - Stop := 0; - return; - - -- Come here if entire match succeeds - - -- Cursor current position in subject string - - <> - Dout ("match succeeds"); - Start := Stack (Stack_Init).Cursor + 1; - Stop := Cursor; - Dout ("first matched character index = " & Start); - Dout ("last matched character index = " & Stop); - Dout ("matched substring = " & Image (Subject (Start .. Stop))); - - -- Scan history stack for deferred assignments or writes - - if Assign_OnM then - for S in Stack'First .. Stack_Ptr loop - if Stack (S).Node = CP_Assign'Access then - declare - Inner_Base : constant Stack_Range := - Stack (S + 1).Cursor; - Special_Entry : constant Stack_Range := - Inner_Base - 1; - Node_OnM : constant PE_Ptr := - Stack (Special_Entry).Node; - Start : constant Natural := - Stack (Special_Entry).Cursor + 1; - Stop : constant Natural := Stack (S).Cursor; - - begin - if Node_OnM.Pcode = PC_Assign_OnM then - Set_Unbounded_String - (Node_OnM.VP.all, Subject (Start .. Stop)); - Dout - (Img (Stack (S).Node) & - "deferred assignment of " & - Image (Subject (Start .. Stop))); - - elsif Node_OnM.Pcode = PC_Write_OnM then - Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); - Dout - (Img (Stack (S).Node) & - "deferred write of " & - Image (Subject (Start .. Stop))); - - else - Logic_Error; - end if; - end; - end if; - end loop; - end if; - - New_Line; - return; - - -- Come here if attempt to match current element fails - - -- Stack_Base current stack base - -- Stack_Ptr current stack pointer - - <> - Cursor := Stack (Stack_Ptr).Cursor; - Node := Stack (Stack_Ptr).Node; - Stack_Ptr := Stack_Ptr - 1; - - if Cursor >= 0 then - Dout ("failure, cursor reset to " & Cursor); - end if; - - goto Match; - - -- Come here if attempt to match current element succeeds - - -- Cursor current position in subject string - -- Node pointer to node successfully matched - -- Stack_Base current stack base - -- Stack_Ptr current stack pointer - - <> - Dout ("success, cursor = " & Cursor); - Node := Node.Pthen; - - -- Come here to match the next pattern element - - -- Cursor current position in subject string - -- Node pointer to node to be matched - -- Stack_Base current stack base - -- Stack_Ptr current stack pointer - - <> - - -------------------------------------------------- - -- Main Pattern Match Element Matching Routines -- - -------------------------------------------------- - - -- Here is the case statement that processes the current node. The - -- processing for each element does one of five things: - - -- goto Succeed to move to the successor - -- goto Match_Succeed if the entire match succeeds - -- goto Match_Fail if the entire match fails - -- goto Fail to signal failure of current match - - -- Processing is NOT allowed to fall through - - case Node.Pcode is - - -- Cancel - - when PC_Cancel => - Dout (Img (Node) & "matching Cancel"); - goto Match_Fail; - - -- Alternation - - when PC_Alt => - Dout (Img (Node) & "setting up alternative " & Img (Node.Alt)); - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Any (one character case) - - when PC_Any_CH => - Dout (Img (Node) & "matching Any", Node.Char); - - if Cursor < Length - and then Subject (Cursor + 1) = Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- Any (character set case) - - when PC_Any_CS => - Dout (Img (Node) & "matching Any", Node.CS); - - if Cursor < Length - and then Is_In (Subject (Cursor + 1), Node.CS) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- Any (string function case) - - when PC_Any_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - - Dout (Img (Node) & "matching Any", S (1 .. L)); - - if Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Any (string pointer case) - - when PC_Any_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching Any", S (1 .. L)); - - if Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Arb (initial match) - - when PC_Arb_X => - Dout (Img (Node) & "matching Arb"); - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arb (extension) - - when PC_Arb_Y => - Dout (Img (Node) & "extending Arb"); - - if Cursor < Length then - Cursor := Cursor + 1; - Push (Node); - goto Succeed; - else - goto Fail; - end if; - - -- Arbno_S (simple Arbno initialize). This is the node that - -- initiates the match of a simple Arbno structure. - - when PC_Arbno_S => - Dout (Img (Node) & - "setting up Arbno alternative " & Img (Node.Alt)); - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arbno_X (Arbno initialize). This is the node that initiates - -- the match of a complex Arbno structure. - - when PC_Arbno_X => - Dout (Img (Node) & - "setting up Arbno alternative " & Img (Node.Alt)); - Push (Node.Alt); - Node := Node.Pthen; - goto Match; - - -- Arbno_Y (Arbno rematch). This is the node that is executed - -- following successful matching of one instance of a complex - -- Arbno pattern. - - when PC_Arbno_Y => declare - Null_Match : constant Boolean := - Cursor = Stack (Stack_Base - 1).Cursor; - - begin - Dout (Img (Node) & "extending Arbno"); - Pop_Region; - - -- If arbno extension matched null, then immediately fail - - if Null_Match then - Dout ("Arbno extension matched null, so fails"); - goto Fail; - end if; - - -- Here we must do a stack check to make sure enough stack - -- is left. This check will happen once for each instance of - -- the Arbno pattern that is matched. The Nat field of a - -- PC_Arbno pattern contains the maximum stack entries needed - -- for the Arbno with one instance and the successor pattern - - if Stack_Ptr + Node.Nat >= Stack'Last then - raise Pattern_Stack_Overflow; - end if; - - goto Succeed; - end; - - -- Assign. If this node is executed, it means the assign-on-match - -- or write-on-match operation will not happen after all, so we - -- is propagate the failure, removing the PC_Assign node. - - when PC_Assign => - Dout (Img (Node) & "deferred assign/write cancelled"); - goto Fail; - - -- Assign immediate. This node performs the actual assignment - - when PC_Assign_Imm => - Dout - (Img (Node) & "executing immediate assignment of " & - Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor))); - Set_Unbounded_String - (Node.VP.all, - Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); - Pop_Region; - goto Succeed; - - -- Assign on match. This node sets up for the eventual assignment - - when PC_Assign_OnM => - Dout (Img (Node) & "registering deferred assignment"); - Stack (Stack_Base - 1).Node := Node; - Push (CP_Assign'Access); - Pop_Region; - Assign_OnM := True; - goto Succeed; - - -- Bal - - when PC_Bal => - Dout (Img (Node) & "matching or extending Bal"); - if Cursor >= Length or else Subject (Cursor + 1) = ')' then - goto Fail; - - elsif Subject (Cursor + 1) = '(' then - declare - Paren_Count : Natural := 1; - - begin - loop - Cursor := Cursor + 1; - - if Cursor >= Length then - goto Fail; - - elsif Subject (Cursor + 1) = '(' then - Paren_Count := Paren_Count + 1; - - elsif Subject (Cursor + 1) = ')' then - Paren_Count := Paren_Count - 1; - exit when Paren_Count = 0; - end if; - end loop; - end; - end if; - - Cursor := Cursor + 1; - Push (Node); - goto Succeed; - - -- Break (one character case) - - when PC_Break_CH => - Dout (Img (Node) & "matching Break", Node.Char); - - while Cursor < Length loop - if Subject (Cursor + 1) = Node.Char then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- Break (character set case) - - when PC_Break_CS => - Dout (Img (Node) & "matching Break", Node.CS); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), Node.CS) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- Break (string function case) - - when PC_Break_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching Break", S (1 .. L)); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- Break (string pointer case) - - when PC_Break_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching Break", S (1 .. L)); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (one character case) - - when PC_BreakX_CH => - Dout (Img (Node) & "matching BreakX", Node.Char); - - while Cursor < Length loop - if Subject (Cursor + 1) = Node.Char then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (character set case) - - when PC_BreakX_CS => - Dout (Img (Node) & "matching BreakX", Node.CS); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), Node.CS) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - - -- BreakX (string function case) - - when PC_BreakX_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching BreakX", S (1 .. L)); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX (string pointer case) - - when PC_BreakX_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching BreakX", S (1 .. L)); - - while Cursor < Length loop - if Is_In (Subject (Cursor + 1), S (1 .. L)) then - goto Succeed; - else - Cursor := Cursor + 1; - end if; - end loop; - - goto Fail; - end; - - -- BreakX_X (BreakX extension). See section on "Compound Pattern - -- Structures". This node is the alternative that is stacked - -- to skip past the break character and extend the break. - - when PC_BreakX_X => - Dout (Img (Node) & "extending BreakX"); - Cursor := Cursor + 1; - goto Succeed; - - -- Character (one character string) - - when PC_Char => - Dout (Img (Node) & "matching '" & Node.Char & '''); - - if Cursor < Length - and then Subject (Cursor + 1) = Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- End of Pattern - - when PC_EOP => - if Stack_Base = Stack_Init then - Dout ("end of pattern"); - goto Match_Succeed; - - -- End of recursive inner match. See separate section on - -- handing of recursive pattern matches for details. - - else - Dout ("terminating recursive match"); - Node := Stack (Stack_Base - 1).Node; - Pop_Region; - goto Match; - end if; - - -- Fail - - when PC_Fail => - Dout (Img (Node) & "matching Fail"); - goto Fail; - - -- Fence (built in pattern) - - when PC_Fence => - Dout (Img (Node) & "matching Fence"); - Push (CP_Cancel'Access); - goto Succeed; - - -- Fence function node X. This is the node that gets control - -- after a successful match of the fenced pattern. - - when PC_Fence_X => - Dout (Img (Node) & "matching Fence function"); - Stack_Ptr := Stack_Ptr + 1; - Stack (Stack_Ptr).Cursor := Stack_Base; - Stack (Stack_Ptr).Node := CP_Fence_Y'Access; - Stack_Base := Stack (Stack_Base).Cursor; - Region_Level := Region_Level - 1; - goto Succeed; - - -- Fence function node Y. This is the node that gets control on - -- a failure that occurs after the fenced pattern has matched. - - -- Note: the Cursor at this stage is actually the inner stack - -- base value. We don't reset this, but we do use it to strip - -- off all the entries made by the fenced pattern. - - when PC_Fence_Y => - Dout (Img (Node) & "pattern matched by Fence caused failure"); - Stack_Ptr := Cursor - 2; - goto Fail; - - -- Len (integer case) - - when PC_Len_Nat => - Dout (Img (Node) & "matching Len", Node.Nat); - - if Cursor + Node.Nat > Length then - goto Fail; - else - Cursor := Cursor + Node.Nat; - goto Succeed; - end if; - - -- Len (Integer function case) - - when PC_Len_NF => declare - N : constant Natural := Node.NF.all; - - begin - Dout (Img (Node) & "matching Len", N); - - if Cursor + N > Length then - goto Fail; - else - Cursor := Cursor + N; - goto Succeed; - end if; - end; - - -- Len (integer pointer case) - - when PC_Len_NP => - Dout (Img (Node) & "matching Len", Node.NP.all); - - if Cursor + Node.NP.all > Length then - goto Fail; - else - Cursor := Cursor + Node.NP.all; - goto Succeed; - end if; - - -- NotAny (one character case) - - when PC_NotAny_CH => - Dout (Img (Node) & "matching NotAny", Node.Char); - - if Cursor < Length - and then Subject (Cursor + 1) /= Node.Char - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- NotAny (character set case) - - when PC_NotAny_CS => - Dout (Img (Node) & "matching NotAny", Node.CS); - - if Cursor < Length - and then not Is_In (Subject (Cursor + 1), Node.CS) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - - -- NotAny (string function case) - - when PC_NotAny_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching NotAny", S (1 .. L)); - - if Cursor < Length - and then - not Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- NotAny (string pointer case) - - when PC_NotAny_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching NotAny", S (1 .. L)); - - if Cursor < Length - and then - not Is_In (Subject (Cursor + 1), S (1 .. L)) - then - Cursor := Cursor + 1; - goto Succeed; - else - goto Fail; - end if; - end; - - -- NSpan (one character case) - - when PC_NSpan_CH => - Dout (Img (Node) & "matching NSpan", Node.Char); - - while Cursor < Length - and then Subject (Cursor + 1) = Node.Char - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - - -- NSpan (character set case) - - when PC_NSpan_CS => - Dout (Img (Node) & "matching NSpan", Node.CS); - - while Cursor < Length - and then Is_In (Subject (Cursor + 1), Node.CS) - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - - -- NSpan (string function case) - - when PC_NSpan_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching NSpan", S (1 .. L)); - - while Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - end; - - -- NSpan (string pointer case) - - when PC_NSpan_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching NSpan", S (1 .. L)); - - while Cursor < Length - and then Is_In (Subject (Cursor + 1), S (1 .. L)) - loop - Cursor := Cursor + 1; - end loop; - - goto Succeed; - end; - - when PC_Null => - Dout (Img (Node) & "matching null"); - goto Succeed; - - -- Pos (integer case) - - when PC_Pos_Nat => - Dout (Img (Node) & "matching Pos", Node.Nat); - - if Cursor = Node.Nat then - goto Succeed; - else - goto Fail; - end if; - - -- Pos (Integer function case) - - when PC_Pos_NF => declare - N : constant Natural := Node.NF.all; - - begin - Dout (Img (Node) & "matching Pos", N); - - if Cursor = N then - goto Succeed; - else - goto Fail; - end if; - end; - - -- Pos (integer pointer case) - - when PC_Pos_NP => - Dout (Img (Node) & "matching Pos", Node.NP.all); - - if Cursor = Node.NP.all then - goto Succeed; - else - goto Fail; - end if; - - -- Predicate function - - when PC_Pred_Func => - Dout (Img (Node) & "matching predicate function"); - - if Node.BF.all then - goto Succeed; - else - goto Fail; - end if; - - -- Region Enter. Initiate new pattern history stack region - - when PC_R_Enter => - Dout (Img (Node) & "starting match of nested pattern"); - Stack (Stack_Ptr + 1).Cursor := Cursor; - Push_Region; - goto Succeed; - - -- Region Remove node. This is the node stacked by an R_Enter. - -- It removes the special format stack entry right underneath, and - -- then restores the outer level stack base and signals failure. - - -- Note: the cursor value at this stage is actually the (negative) - -- stack base value for the outer level. - - when PC_R_Remove => - Dout ("failure, match of nested pattern terminated"); - Stack_Base := Cursor; - Region_Level := Region_Level - 1; - Stack_Ptr := Stack_Ptr - 1; - goto Fail; - - -- Region restore node. This is the node stacked at the end of an - -- inner level match. Its function is to restore the inner level - -- region, so that alternatives in this region can be sought. - - -- Note: the Cursor at this stage is actually the negative of the - -- inner stack base value, which we use to restore the inner region. - - when PC_R_Restore => - Dout ("failure, search for alternatives in nested pattern"); - Region_Level := Region_Level + 1; - Stack_Base := Cursor; - goto Fail; - - -- Rest - - when PC_Rest => - Dout (Img (Node) & "matching Rest"); - Cursor := Length; - goto Succeed; - - -- Initiate recursive match (pattern pointer case) - - when PC_Rpat => - Stack (Stack_Ptr + 1).Node := Node.Pthen; - Push_Region; - Dout (Img (Node) & "initiating recursive match"); - - if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then - raise Pattern_Stack_Overflow; - else - Node := Node.PP.all.P; - goto Match; - end if; - - -- RPos (integer case) - - when PC_RPos_Nat => - Dout (Img (Node) & "matching RPos", Node.Nat); - - if Cursor = (Length - Node.Nat) then - goto Succeed; - else - goto Fail; - end if; - - -- RPos (integer function case) - - when PC_RPos_NF => declare - N : constant Natural := Node.NF.all; - - begin - Dout (Img (Node) & "matching RPos", N); - - if Length - Cursor = N then - goto Succeed; - else - goto Fail; - end if; - end; - - -- RPos (integer pointer case) - - when PC_RPos_NP => - Dout (Img (Node) & "matching RPos", Node.NP.all); - - if Cursor = (Length - Node.NP.all) then - goto Succeed; - else - goto Fail; - end if; - - -- RTab (integer case) - - when PC_RTab_Nat => - Dout (Img (Node) & "matching RTab", Node.Nat); - - if Cursor <= (Length - Node.Nat) then - Cursor := Length - Node.Nat; - goto Succeed; - else - goto Fail; - end if; - - -- RTab (integer function case) - - when PC_RTab_NF => declare - N : constant Natural := Node.NF.all; - - begin - Dout (Img (Node) & "matching RPos", N); - - if Length - Cursor >= N then - Cursor := Length - N; - goto Succeed; - else - goto Fail; - end if; - end; - - -- RTab (integer pointer case) - - when PC_RTab_NP => - Dout (Img (Node) & "matching RPos", Node.NP.all); - - if Cursor <= (Length - Node.NP.all) then - Cursor := Length - Node.NP.all; - goto Succeed; - else - goto Fail; - end if; - - -- Cursor assignment - - when PC_Setcur => - Dout (Img (Node) & "matching Setcur"); - Node.Var.all := Cursor; - goto Succeed; - - -- Span (one character case) - - when PC_Span_CH => declare - P : Natural := Cursor; - - begin - Dout (Img (Node) & "matching Span", Node.Char); - - while P < Length - and then Subject (P + 1) = Node.Char - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Span (character set case) - - when PC_Span_CS => declare - P : Natural := Cursor; - - begin - Dout (Img (Node) & "matching Span", Node.CS); - - while P < Length - and then Is_In (Subject (P + 1), Node.CS) - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Span (string function case) - - when PC_Span_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - P : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching Span", S (1 .. L)); - - P := Cursor; - while P < Length - and then Is_In (Subject (P + 1), S (1 .. L)) - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Span (string pointer case) - - when PC_Span_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - P : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching Span", S (1 .. L)); - - P := Cursor; - while P < Length - and then Is_In (Subject (P + 1), S (1 .. L)) - loop - P := P + 1; - end loop; - - if P /= Cursor then - Cursor := P; - goto Succeed; - else - goto Fail; - end if; - end; - - -- String (two character case) - - when PC_String_2 => - Dout (Img (Node) & "matching " & Image (Node.Str2)); - - if (Length - Cursor) >= 2 - and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 - then - Cursor := Cursor + 2; - goto Succeed; - else - goto Fail; - end if; - - -- String (three character case) - - when PC_String_3 => - Dout (Img (Node) & "matching " & Image (Node.Str3)); - - if (Length - Cursor) >= 3 - and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 - then - Cursor := Cursor + 3; - goto Succeed; - else - goto Fail; - end if; - - -- String (four character case) - - when PC_String_4 => - Dout (Img (Node) & "matching " & Image (Node.Str4)); - - if (Length - Cursor) >= 4 - and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 - then - Cursor := Cursor + 4; - goto Succeed; - else - goto Fail; - end if; - - -- String (five character case) - - when PC_String_5 => - Dout (Img (Node) & "matching " & Image (Node.Str5)); - - if (Length - Cursor) >= 5 - and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 - then - Cursor := Cursor + 5; - goto Succeed; - else - goto Fail; - end if; - - -- String (six character case) - - when PC_String_6 => - Dout (Img (Node) & "matching " & Image (Node.Str6)); - - if (Length - Cursor) >= 6 - and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 - then - Cursor := Cursor + 6; - goto Succeed; - else - goto Fail; - end if; - - -- String (case of more than six characters) - - when PC_String => declare - Len : constant Natural := Node.Str'Length; - - begin - Dout (Img (Node) & "matching " & Image (Node.Str.all)); - - if (Length - Cursor) >= Len - and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) - then - Cursor := Cursor + Len; - goto Succeed; - else - goto Fail; - end if; - end; - - -- String (function case) - - when PC_String_VF => declare - U : constant VString := Node.VF.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching " & Image (S (1 .. L))); - - if (Length - Cursor) >= L - and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) - then - Cursor := Cursor + L; - goto Succeed; - else - goto Fail; - end if; - end; - - -- String (vstring pointer case) - - when PC_String_VP => declare - U : constant VString := Node.VP.all; - S : Big_String_Access; - L : Natural; - - begin - Get_String (U, S, L); - Dout (Img (Node) & "matching " & Image (S (1 .. L))); - - if (Length - Cursor) >= L - and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) - then - Cursor := Cursor + L; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Succeed - - when PC_Succeed => - Dout (Img (Node) & "matching Succeed"); - Push (Node); - goto Succeed; - - -- Tab (integer case) - - when PC_Tab_Nat => - Dout (Img (Node) & "matching Tab", Node.Nat); - - if Cursor <= Node.Nat then - Cursor := Node.Nat; - goto Succeed; - else - goto Fail; - end if; - - -- Tab (integer function case) - - when PC_Tab_NF => declare - N : constant Natural := Node.NF.all; - - begin - Dout (Img (Node) & "matching Tab ", N); - - if Cursor <= N then - Cursor := N; - goto Succeed; - else - goto Fail; - end if; - end; - - -- Tab (integer pointer case) - - when PC_Tab_NP => - Dout (Img (Node) & "matching Tab ", Node.NP.all); - - if Cursor <= Node.NP.all then - Cursor := Node.NP.all; - goto Succeed; - else - goto Fail; - end if; - - -- Unanchored movement - - when PC_Unanchored => - Dout ("attempting to move anchor point"); - - -- All done if we tried every position - - if Cursor > Length then - goto Match_Fail; - - -- Otherwise extend the anchor point, and restack ourself - - else - Cursor := Cursor + 1; - Push (Node); - goto Succeed; - end if; - - -- Write immediate. This node performs the actual write - - when PC_Write_Imm => - Dout (Img (Node) & "executing immediate write of " & - Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); - - Put_Line - (Node.FP.all, - Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); - Pop_Region; - goto Succeed; - - -- Write on match. This node sets up for the eventual write - - when PC_Write_OnM => - Dout (Img (Node) & "registering deferred write"); - Stack (Stack_Base - 1).Node := Node; - Push (CP_Assign'Access); - Pop_Region; - Assign_OnM := True; - goto Succeed; - end case; - - -- We are NOT allowed to fall though this case statement, since every - -- match routine must end by executing a goto to the appropriate point - -- in the finite state machine model. - - pragma Warnings (Off); - Logic_Error; - pragma Warnings (On); - end XMatchD; - -end GNAT.Spitbol.Patterns; diff --git a/gcc/ada/g-spipat.ads b/gcc/ada/g-spipat.ads deleted file mode 100644 index fe10fed..0000000 --- a/gcc/ada/g-spipat.ads +++ /dev/null @@ -1,1187 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L . P A T T E R N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2015, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- SPITBOL-like pattern construction and matching - --- This child package of GNAT.SPITBOL provides a complete implementation --- of the SPITBOL-like pattern construction and matching operations. This --- package is based on Macro-SPITBOL created by Robert Dewar. - ------------------------------------------------------------- --- Summary of Pattern Matching Packages in GNAT Hierarchy -- ------------------------------------------------------------- - --- There are three related packages that perform pattern matching functions. --- the following is an outline of these packages, to help you determine --- which is best for your needs. - --- GNAT.Regexp (files g-regexp.ads/g-regexp.adb) --- This is a simple package providing Unix-style regular expression --- matching with the restriction that it matches entire strings. It --- is particularly useful for file name matching, and in particular --- it provides "globbing patterns" that are useful in implementing --- unix or DOS style wild card matching for file names. - --- GNAT.Regpat (files g-regpat.ads/g-regpat.adb) --- This is a more complete implementation of Unix-style regular --- expressions, copied from the original V7 style regular expression --- library written in C by Henry Spencer. It is functionally the --- same as this library, and uses the same internal data structures --- stored in a binary compatible manner. - --- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) --- This is a completely general patterm matching package based on the --- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern --- language is modeled on context free grammars, with context sensitive --- extensions that provide full (type 0) computational capabilities. - -with Ada.Strings.Maps; use Ada.Strings.Maps; -with Ada.Text_IO; use Ada.Text_IO; - -package GNAT.Spitbol.Patterns is - pragma Elaborate_Body; - - ------------------------------- - -- Pattern Matching Tutorial -- - ------------------------------- - - -- A pattern matching operation (a call to one of the Match subprograms) - -- takes a subject string and a pattern, and optionally a replacement - -- string. The replacement string option is only allowed if the subject - -- is a variable. - - -- The pattern is matched against the subject string, and either the - -- match fails, or it succeeds matching a contiguous substring. If a - -- replacement string is specified, then the subject string is modified - -- by replacing the matched substring with the given replacement. - - -- Concatenation and Alternation - -- ============================= - - -- A pattern consists of a series of pattern elements. The pattern is - -- built up using either the concatenation operator: - - -- A & B - - -- which means match A followed immediately by matching B, or the - -- alternation operator: - - -- A or B - - -- which means first attempt to match A, and then if that does not - -- succeed, match B. - - -- There is full backtracking, which means that if a given pattern - -- element fails to match, then previous alternatives are matched. - -- For example if we have the pattern: - - -- (A or B) & (C or D) & (E or F) - - -- First we attempt to match A, if that succeeds, then we go on to try - -- to match C, and if that succeeds, we go on to try to match E. If E - -- fails, then we try F. If F fails, then we go back and try matching - -- D instead of C. Let's make this explicit using a specific example, - -- and introducing the simplest kind of pattern element, which is a - -- literal string. The meaning of this pattern element is simply to - -- match the characters that correspond to the string characters. Now - -- let's rewrite the above pattern form with specific string literals - -- as the pattern elements: - - -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") - - -- The following strings will be attempted in sequence: - - -- ABC . DEF . GH - -- ABC . DEF . IJ - -- ABC . CDE . GH - -- ABC . CDE . IJ - -- AB . DEF . GH - -- AB . DEF . IJ - -- AB . CDE . GH - -- AB . CDE . IJ - - -- Here we use the dot simply to separate the pieces of the string - -- matched by the three separate elements. - - -- Moving the Start Point - -- ====================== - - -- A pattern is not required to match starting at the first character - -- of the string, and is not required to match to the end of the string. - -- The first attempt does indeed attempt to match starting at the first - -- character of the string, trying all the possible alternatives. But - -- if all alternatives fail, then the starting point of the match is - -- moved one character, and all possible alternatives are attempted at - -- the new anchor point. - - -- The entire match fails only when every possible starting point has - -- been attempted. As an example, suppose that we had the subject - -- string - - -- "ABABCDEIJKL" - - -- matched using the pattern in the previous example: - - -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") - - -- would succeed, after two anchor point moves: - - -- "ABABCDEIJKL" - -- ^^^^^^^ - -- matched - -- section - - -- This mode of pattern matching is called the unanchored mode. It is - -- also possible to put the pattern matcher into anchored mode by - -- setting the global variable Anchored_Mode to True. This will cause - -- all subsequent matches to be performed in anchored mode, where the - -- match is required to start at the first character. - - -- We will also see later how the effect of an anchored match can be - -- obtained for a single specified anchor point if this is desired. - - -- Other Pattern Elements - -- ====================== - - -- In addition to strings (or single characters), there are many special - -- pattern elements that correspond to special predefined alternations: - - -- Arb Matches any string. First it matches the null string, and - -- then on a subsequent failure, matches one character, and - -- then two characters, and so on. It only fails if the - -- entire remaining string is matched. - - -- Bal Matches a non-empty string that is parentheses balanced - -- with respect to ordinary () characters. Examples of - -- balanced strings are "ABC", "A((B)C)", and "A(B)C(D)E". - -- Bal matches the shortest possible balanced string on the - -- first attempt, and if there is a subsequent failure, - -- attempts to extend the string. - - -- Cancel Immediately aborts the entire pattern match, signalling - -- failure. This is a specialized pattern element, which is - -- useful in conjunction with some of the special pattern - -- elements that have side effects. - - -- Fail The null alternation. Matches no possible strings, so it - -- always signals failure. This is a specialized pattern - -- element, which is useful in conjunction with some of the - -- special pattern elements that have side effects. - - -- Fence Matches the null string at first, and then if a failure - -- causes alternatives to be sought, aborts the match (like - -- a Cancel). Note that using Fence at the start of a pattern - -- has the same effect as matching in anchored mode. - - -- Rest Matches from the current point to the last character in - -- the string. This is a specialized pattern element, which - -- is useful in conjunction with some of the special pattern - -- elements that have side effects. - - -- Succeed Repeatedly matches the null string (it is equivalent to - -- the alternation ("" or "" or "" ....). This is a special - -- pattern element, which is useful in conjunction with some - -- of the special pattern elements that have side effects. - - -- Pattern Construction Functions - -- ============================== - - -- The following functions construct additional pattern elements - - -- Any(S) Where S is a string, matches a single character that is - -- any one of the characters in S. Fails if the current - -- character is not one of the given set of characters. - - -- Arbno(P) Where P is any pattern, matches any number of instances - -- of the pattern, starting with zero occurrences. It is - -- thus equivalent to ("" or (P & ("" or (P & ("" ....)))). - -- The pattern P may contain any number of pattern elements - -- including the use of alternation and concatenation. - - -- Break(S) Where S is a string, matches a string of zero or more - -- characters up to but not including a break character - -- that is one of the characters given in the string S. - -- Can match the null string, but cannot match the last - -- character in the string, since a break character is - -- required to be present. - - -- BreakX(S) Where S is a string, behaves exactly like Break(S) when - -- it first matches, but if a string is successfully matched, - -- then a subsequent failure causes an attempt to extend the - -- matched string. - - -- Fence(P) Where P is a pattern, attempts to match the pattern P - -- including trying all possible alternatives of P. If none - -- of these alternatives succeeds, then the Fence pattern - -- fails. If one alternative succeeds, then the pattern - -- match proceeds, but on a subsequent failure, no attempt - -- is made to search for alternative matches of P. The - -- pattern P may contain any number of pattern elements - -- including the use of alternation and concatenation. - - -- Len(N) Where N is a natural number, matches the given number of - -- characters. For example, Len(10) matches any string that - -- is exactly ten characters long. - - -- NotAny(S) Where S is a string, matches a single character that is - -- not one of the characters of S. Fails if the current - -- character is one of the given set of characters. - - -- NSpan(S) Where S is a string, matches a string of zero or more - -- characters that is among the characters given in the - -- string. Always matches the longest possible such string. - -- Always succeeds, since it can match the null string. - - -- Pos(N) Where N is a natural number, matches the null string - -- if exactly N characters have been matched so far, and - -- otherwise fails. - - -- Rpos(N) Where N is a natural number, matches the null string - -- if exactly N characters remain to be matched, and - -- otherwise fails. - - -- Rtab(N) Where N is a natural number, matches characters from - -- the current position until exactly N characters remain - -- to be matched in the string. Fails if fewer than N - -- unmatched characters remain in the string. - - -- Tab(N) Where N is a natural number, matches characters from - -- the current position until exactly N characters have - -- been matched in all. Fails if more than N characters - -- have already been matched. - - -- Span(S) Where S is a string, matches a string of one or more - -- characters that is among the characters given in the - -- string. Always matches the longest possible such string. - -- Fails if the current character is not one of the given - -- set of characters. - - -- Recursive Pattern Matching - -- ========================== - - -- The plus operator (+P) where P is a pattern variable, creates - -- a recursive pattern that will, at pattern matching time, follow - -- the pointer to obtain the referenced pattern, and then match this - -- pattern. This may be used to construct recursive patterns. Consider - -- for example: - - -- P := ("A" or ("B" & (+P))) - - -- On the first attempt, this pattern attempts to match the string "A". - -- If this fails, then the alternative matches a "B", followed by an - -- attempt to match P again. This second attempt first attempts to - -- match "A", and so on. The result is a pattern that will match a - -- string of B's followed by a single A. - - -- This particular example could simply be written as NSpan('B') & 'A', - -- but the use of recursive patterns in the general case can construct - -- complex patterns which could not otherwise be built. - - -- Pattern Assignment Operations - -- ============================= - - -- In addition to the overall result of a pattern match, which indicates - -- success or failure, it is often useful to be able to keep track of - -- the pieces of the subject string that are matched by individual - -- pattern elements, or subsections of the pattern. - - -- The pattern assignment operators allow this capability. The first - -- form is the immediate assignment: - - -- P * S - - -- Here P is an arbitrary pattern, and S is a variable of type VString - -- that will be set to the substring matched by P. This assignment - -- happens during pattern matching, so if P matches more than once, - -- then the assignment happens more than once. - - -- The deferred assignment operation: - - -- P ** S - - -- avoids these multiple assignments by deferring the assignment to the - -- end of the match. If the entire match is successful, and if the - -- pattern P was part of the successful match, then at the end of the - -- matching operation the assignment to S of the string matching P is - -- performed. - - -- The cursor assignment operation: - - -- Setcur(N'Access) - - -- assigns the current cursor position to the natural variable N. The - -- cursor position is defined as the count of characters that have been - -- matched so far (including any start point moves). - - -- Finally the operations * and ** may be used with values of type - -- Text_IO.File_Access. The effect is to do a Put_Line operation of - -- the matched substring. These are particularly useful in debugging - -- pattern matches. - - -- Deferred Matching - -- ================= - - -- The pattern construction functions (such as Len and Any) all permit - -- the use of pointers to natural or string values, or functions that - -- return natural or string values. These forms cause the actual value - -- to be obtained at pattern matching time. This allows interesting - -- possibilities for constructing dynamic patterns as illustrated in - -- the examples section. - - -- In addition the (+S) operator may be used where S is a pointer to - -- string or function returning string, with a similar deferred effect. - - -- A special use of deferred matching is the construction of predicate - -- functions. The element (+P) where P is an access to a function that - -- returns a Boolean value, causes the function to be called at the - -- time the element is matched. If the function returns True, then the - -- null string is matched, if the function returns False, then failure - -- is signalled and previous alternatives are sought. - - -- Deferred Replacement - -- ==================== - - -- The simple model given for pattern replacement (where the matched - -- substring is replaced by the string given as the third argument to - -- Match) works fine in simple cases, but this approach does not work - -- in the case where the expression used as the replacement string is - -- dependent on values set by the match. - - -- For example, suppose we want to find an instance of a parenthesized - -- character, and replace the parentheses with square brackets. At first - -- glance it would seem that: - - -- Match (Subject, '(' & Len (1) * Char & ')', '[' & Char & ']'); - - -- would do the trick, but that does not work, because the third - -- argument to Match gets evaluated too early, before the call to - -- Match, and before the pattern match has had a chance to set Char. - - -- To solve this problem we provide the deferred replacement capability. - -- With this approach, which of course is only needed if the pattern - -- involved has side effects, is to do the match in two stages. The - -- call to Match sets a pattern result in a variable of the private - -- type Match_Result, and then a subsequent Replace operation uses - -- this Match_Result object to perform the required replacement. - - -- Using this approach, we can now write the above operation properly - -- in a manner that will work: - - -- M : Match_Result; - -- ... - -- Match (Subject, '(' & Len (1) * Char & ')', M); - -- Replace (M, '[' & Char & ']'); - - -- As with other Match cases, there is a function and procedure form - -- of this match call. A call to Replace after a failed match has no - -- effect. Note that Subject should not be modified between the calls. - - -- Examples of Pattern Matching - -- ============================ - - -- First a simple example of the use of pattern replacement to remove - -- a line number from the start of a string. We assume that the line - -- number has the form of a string of decimal digits followed by a - -- period, followed by one or more spaces. - - -- Digs : constant Pattern := Span("0123456789"); - - -- Lnum : constant Pattern := Pos(0) & Digs & '.' & Span(' '); - - -- Now to use this pattern we simply do a match with a replacement: - - -- Match (Line, Lnum, ""); - - -- which replaces the line number by the null string. Note that it is - -- also possible to use an Ada.Strings.Maps.Character_Set value as an - -- argument to Span and similar functions, and in particular all the - -- useful constants 'in Ada.Strings.Maps.Constants are available. This - -- means that we could define Digs as: - - -- Digs : constant Pattern := Span(Decimal_Digit_Set); - - -- The style we use here, of defining constant patterns and then using - -- them is typical. It is possible to build up patterns dynamically, - -- but it is usually more efficient to build them in pieces in advance - -- using constant declarations. Note in particular that although it is - -- possible to construct a pattern directly as an argument for the - -- Match routine, it is much more efficient to preconstruct the pattern - -- as we did in this example. - - -- Now let's look at the use of pattern assignment to break a - -- string into sections. Suppose that the input string has two - -- unsigned decimal integers, separated by spaces or a comma, - -- with spaces allowed anywhere. Then we can isolate the two - -- numbers with the following pattern: - - -- Num1, Num2 : aliased VString; - - -- B : constant Pattern := NSpan(' '); - - -- N : constant Pattern := Span("0123456789"); - - -- T : constant Pattern := - -- NSpan(' ') & N * Num1 & Span(" ,") & N * Num2; - - -- The match operation Match (" 124, 257 ", T) would assign the - -- string 124 to Num1 and the string 257 to Num2. - - -- Now let's see how more complex elements can be built from the - -- set of primitive elements. The following pattern matches strings - -- that have the syntax of Ada 95 based literals: - - -- Digs : constant Pattern := Span(Decimal_Digit_Set); - -- UDigs : constant Pattern := Digs & Arbno('_' & Digs); - - -- Edig : constant Pattern := Span(Hexadecimal_Digit_Set); - -- UEdig : constant Pattern := Edig & Arbno('_' & Edig); - - -- Bnum : constant Pattern := Udigs & '#' & UEdig & '#'; - - -- A match against Bnum will now match the desired strings, e.g. - -- it will match 16#123_abc#, but not a#b#. However, this pattern - -- is not quite complete, since it does not allow colons to replace - -- the pound signs. The following is more complete: - - -- Bchar : constant Pattern := Any("#:"); - -- Bnum : constant Pattern := Udigs & Bchar & UEdig & Bchar; - - -- but that is still not quite right, since it allows # and : to be - -- mixed, and they are supposed to be used consistently. We solve - -- this by using a deferred match. - - -- Temp : aliased VString; - - -- Bnum : constant Pattern := - -- Udigs & Bchar * Temp & UEdig & (+Temp) - - -- Here the first instance of the base character is stored in Temp, and - -- then later in the pattern we rematch the value that was assigned. - - -- For an example of a recursive pattern, let's define a pattern - -- that is like the built in Bal, but the string matched is balanced - -- with respect to square brackets or curly brackets. - - -- The language for such strings might be defined in extended BNF as - - -- ELEMENT ::= - -- | '[' BALANCED_STRING ']' - -- | '{' BALANCED_STRING '}' - - -- BALANCED_STRING ::= ELEMENT {ELEMENT} - - -- Here we use {} to indicate zero or more occurrences of a term, as - -- is common practice in extended BNF. Now we can translate the above - -- BNF into recursive patterns as follows: - - -- Element, Balanced_String : aliased Pattern; - -- . - -- . - -- . - -- Element := NotAny ("[]{}") - -- or - -- ('[' & (+Balanced_String) & ']') - -- or - -- ('{' & (+Balanced_String) & '}'); - - -- Balanced_String := Element & Arbno (Element); - - -- Note the important use of + here to refer to a pattern not yet - -- defined. Note also that we use assignments precisely because we - -- cannot refer to as yet undeclared variables in initializations. - - -- Now that this pattern is constructed, we can use it as though it - -- were a new primitive pattern element, and for example, the match: - - -- Match ("xy[ab{cd}]", Balanced_String * Current_Output & Fail); - - -- will generate the output: - - -- x - -- xy - -- xy[ab{cd}] - -- y - -- y[ab{cd}] - -- [ab{cd}] - -- a - -- ab - -- ab{cd} - -- b - -- b{cd} - -- {cd} - -- c - -- cd - -- d - - -- Note that the function of the fail here is simply to force the - -- pattern Balanced_String to match all possible alternatives. Studying - -- the operation of this pattern in detail is highly instructive. - - -- Finally we give a rather elaborate example of the use of deferred - -- matching. The following declarations build up a pattern which will - -- find the longest string of decimal digits in the subject string. - - -- Max, Cur : VString; - -- Loc : Natural; - - -- function GtS return Boolean is - -- begin - -- return Length (Cur) > Length (Max); - -- end GtS; - - -- Digit : constant Character_Set := Decimal_Digit_Set; - - -- Digs : constant Pattern := Span(Digit); - - -- Find : constant Pattern := - -- "" * Max & Fence & -- initialize Max to null - -- BreakX (Digit) & -- scan looking for digits - -- ((Span(Digit) * Cur & -- assign next string to Cur - -- (+GtS'Unrestricted_Access) & -- check size(Cur) > Size(Max) - -- Setcur(Loc'Access)) -- if so, save location - -- * Max) & -- and assign to Max - -- Fail; -- seek all alternatives - - -- As we see from the comments here, complex patterns like this take - -- on aspects of sequential programs. In fact they are sequential - -- programs with general backtracking. In this pattern, we first use - -- a pattern assignment that matches null and assigns it to Max, so - -- that it is initialized for the new match. Now BreakX scans to the - -- next digit. Arb would do here, but BreakX will be more efficient. - -- Once we have found a digit, we scan out the longest string of - -- digits with Span, and assign it to Cur. The deferred call to GtS - -- tests if the string we assigned to Cur is the longest so far. If - -- not, then failure is signalled, and we seek alternatives (this - -- means that BreakX will extend and look for the next digit string). - -- If the call to GtS succeeds then the matched string is assigned - -- as the largest string so far into Max and its location is saved - -- in Loc. Finally Fail forces the match to fail and seek alternatives, - -- so that the entire string is searched. - - -- If the pattern Find is matched against a string, the variable Max - -- at the end of the pattern will have the longest string of digits, - -- and Loc will be the starting character location of the string. For - -- example, Match("ab123cd4657ef23", Find) will assign "4657" to Max - -- and 11 to Loc (indicating that the string ends with the eleventh - -- character of the string). - - -- Note: the use of Unrestricted_Access to reference GtS will not - -- be needed if GtS is defined at the outer level, but definitely - -- will be necessary if GtS is a nested function (in which case of - -- course the scope of the pattern Find will be restricted to this - -- nested scope, and this cannot be checked, i.e. use of the pattern - -- outside this scope is erroneous). Generally it is a good idea to - -- define patterns and the functions they call at the outer level - -- where possible, to avoid such problems. - - -- Correspondence with Pattern Matching in SPITBOL - -- =============================================== - - -- Generally the Ada syntax and names correspond closely to SPITBOL - -- syntax for pattern matching construction. - - -- The basic pattern construction operators are renamed as follows: - - -- Spitbol Ada - - -- (space) & - -- | or - -- $ * - -- . ** - - -- The Ada operators were chosen so that the relative precedences of - -- these operators corresponds to that of the Spitbol operators, but - -- as always, the use of parentheses is advisable to clarify. - - -- The pattern construction operators all have similar names except for - - -- Spitbol Ada - - -- Abort Cancel - -- Rem Rest - - -- where we have clashes with Ada reserved names - - -- Ada requires the use of 'Access to refer to functions used in the - -- pattern match, and often the use of 'Unrestricted_Access may be - -- necessary to get around the scope restrictions if the functions - -- are not declared at the outer level. - - -- The actual pattern matching syntax is modified in Ada as follows: - - -- Spitbol Ada - - -- X Y Match (X, Y); - -- X Y = Z Match (X, Y, Z); - - -- and pattern failure is indicated by returning a Boolean result from - -- the Match function (True for success, False for failure). - - ----------------------- - -- Type Declarations -- - ----------------------- - - type Pattern is private; - -- Type representing a pattern. This package provides a complete set of - -- operations for constructing patterns that can be used in the pattern - -- matching operations provided. - - type Boolean_Func is access function return Boolean; - -- General Boolean function type. When this type is used as a formal - -- parameter type in this package, it indicates a deferred predicate - -- pattern. The function will be called when the pattern element is - -- matched and failure signalled if False is returned. - - type Natural_Func is access function return Natural; - -- General Natural function type. When this type is used as a formal - -- parameter type in this package, it indicates a deferred pattern. - -- The function will be called when the pattern element is matched - -- to obtain the currently referenced Natural value. - - type VString_Func is access function return VString; - -- General VString function type. When this type is used as a formal - -- parameter type in this package, it indicates a deferred pattern. - -- The function will be called when the pattern element is matched - -- to obtain the currently referenced string value. - - subtype PString is String; - -- This subtype is used in the remainder of the package to indicate a - -- formal parameter that is converted to its corresponding pattern, - -- i.e. a pattern that matches the characters of the string. - - subtype PChar is Character; - -- Similarly, this subtype is used in the remainder of the package to - -- indicate a formal parameter that is converted to its corresponding - -- pattern, i.e. a pattern that matches this one character. - - subtype VString_Var is VString; - subtype Pattern_Var is Pattern; - -- These synonyms are used as formal parameter types to a function where, - -- if the language allowed, we would use in out parameters, but we are - -- not allowed to have in out parameters for functions. Instead we pass - -- actuals which must be variables, and with a bit of trickery in the - -- body, manage to interpret them properly as though they were indeed - -- in out parameters. - - pragma Warnings (Off, VString_Var); - pragma Warnings (Off, Pattern_Var); - -- We turn off warnings for these two types so that when variables are used - -- as arguments in this context, warnings about them not being assigned in - -- the source program will be suppressed. - - -------------------------------- - -- Basic Pattern Construction -- - -------------------------------- - - function "&" (L : Pattern; R : Pattern) return Pattern; - function "&" (L : PString; R : Pattern) return Pattern; - function "&" (L : Pattern; R : PString) return Pattern; - function "&" (L : PChar; R : Pattern) return Pattern; - function "&" (L : Pattern; R : PChar) return Pattern; - - -- Pattern concatenation. Matches L followed by R - - function "or" (L : Pattern; R : Pattern) return Pattern; - function "or" (L : PString; R : Pattern) return Pattern; - function "or" (L : Pattern; R : PString) return Pattern; - function "or" (L : PString; R : PString) return Pattern; - function "or" (L : PChar; R : Pattern) return Pattern; - function "or" (L : Pattern; R : PChar) return Pattern; - function "or" (L : PChar; R : PChar) return Pattern; - function "or" (L : PString; R : PChar) return Pattern; - function "or" (L : PChar; R : PString) return Pattern; - -- Pattern alternation. Creates a pattern that will first try to match - -- L and then on a subsequent failure, attempts to match R instead. - - ---------------------------------- - -- Pattern Assignment Functions -- - ---------------------------------- - - function "*" (P : Pattern; Var : VString_Var) return Pattern; - function "*" (P : PString; Var : VString_Var) return Pattern; - function "*" (P : PChar; Var : VString_Var) return Pattern; - -- Matches P, and if the match succeeds, assigns the matched substring - -- to the given VString variable Var. This assignment happens as soon as - -- the substring is matched, and if the pattern P1 is matched more than - -- once during the course of the match, then the assignment will occur - -- more than once. - - function "**" (P : Pattern; Var : VString_Var) return Pattern; - function "**" (P : PString; Var : VString_Var) return Pattern; - function "**" (P : PChar; Var : VString_Var) return Pattern; - -- Like "*" above, except that the assignment happens at most once - -- after the entire match is completed successfully. If the match - -- fails, then no assignment takes place. - - ---------------------------------- - -- Deferred Matching Operations -- - ---------------------------------- - - function "+" (Str : VString_Var) return Pattern; - -- Here Str must be a VString variable. This function constructs a - -- pattern which at pattern matching time will access the current - -- value of this variable, and match against these characters. - - function "+" (Str : VString_Func) return Pattern; - -- Constructs a pattern which at pattern matching time calls the given - -- function, and then matches against the string or character value - -- that is returned by the call. - - function "+" (P : Pattern_Var) return Pattern; - -- Here P must be a Pattern variable. This function constructs a - -- pattern which at pattern matching time will access the current - -- value of this variable, and match against the pattern value. - - function "+" (P : Boolean_Func) return Pattern; - -- Constructs a predicate pattern function that at pattern matching time - -- calls the given function. If True is returned, then the pattern matches. - -- If False is returned, then failure is signalled. - - -------------------------------- - -- Pattern Building Functions -- - -------------------------------- - - function Arb return Pattern; - -- Constructs a pattern that will match any string. On the first attempt, - -- the pattern matches a null string, then on each successive failure, it - -- matches one more character, and only fails if matching the entire rest - -- of the string. - - function Arbno (P : Pattern) return Pattern; - function Arbno (P : PString) return Pattern; - function Arbno (P : PChar) return Pattern; - -- Pattern repetition. First matches null, then on a subsequent failure - -- attempts to match an additional instance of the given pattern. - -- Equivalent to (but more efficient than) P & ("" or (P & ("" or ... - - function Any (Str : String) return Pattern; - function Any (Str : VString) return Pattern; - function Any (Str : Character) return Pattern; - function Any (Str : Character_Set) return Pattern; - function Any (Str : not null access VString) return Pattern; - function Any (Str : VString_Func) return Pattern; - -- Constructs a pattern that matches a single character that is one of - -- the characters in the given argument. The pattern fails if the current - -- character is not in Str. - - function Bal return Pattern; - -- Constructs a pattern that will match any non-empty string that is - -- parentheses balanced with respect to the normal parentheses characters. - -- Attempts to extend the string if a subsequent failure occurs. - - function Break (Str : String) return Pattern; - function Break (Str : VString) return Pattern; - function Break (Str : Character) return Pattern; - function Break (Str : Character_Set) return Pattern; - function Break (Str : not null access VString) return Pattern; - function Break (Str : VString_Func) return Pattern; - -- Constructs a pattern that matches a (possibly null) string which - -- is immediately followed by a character in the given argument. This - -- character is not part of the matched string. The pattern fails if - -- the remaining characters to be matched do not include any of the - -- characters in Str. - - function BreakX (Str : String) return Pattern; - function BreakX (Str : VString) return Pattern; - function BreakX (Str : Character) return Pattern; - function BreakX (Str : Character_Set) return Pattern; - function BreakX (Str : not null access VString) return Pattern; - function BreakX (Str : VString_Func) return Pattern; - -- Like Break, but the pattern attempts to extend on a failure to find - -- the next occurrence of a character in Str, and only fails when the - -- last such instance causes a failure. - - function Cancel return Pattern; - -- Constructs a pattern that immediately aborts the entire match - - function Fail return Pattern; - -- Constructs a pattern that always fails - - function Fence return Pattern; - -- Constructs a pattern that matches null on the first attempt, and then - -- causes the entire match to be aborted if a subsequent failure occurs. - - function Fence (P : Pattern) return Pattern; - -- Constructs a pattern that first matches P. If P fails, then the - -- constructed pattern fails. If P succeeds, then the match proceeds, - -- but if subsequent failure occurs, alternatives in P are not sought. - -- The idea of Fence is that each time the pattern is matched, just - -- one attempt is made to match P, without trying alternatives. - - function Len (Count : Natural) return Pattern; - function Len (Count : not null access Natural) return Pattern; - function Len (Count : Natural_Func) return Pattern; - -- Constructs a pattern that matches exactly the given number of - -- characters. The pattern fails if fewer than this number of characters - -- remain to be matched in the string. - - function NotAny (Str : String) return Pattern; - function NotAny (Str : VString) return Pattern; - function NotAny (Str : Character) return Pattern; - function NotAny (Str : Character_Set) return Pattern; - function NotAny (Str : not null access VString) return Pattern; - function NotAny (Str : VString_Func) return Pattern; - -- Constructs a pattern that matches a single character that is not - -- one of the characters in the given argument. The pattern Fails if - -- the current character is in Str. - - function NSpan (Str : String) return Pattern; - function NSpan (Str : VString) return Pattern; - function NSpan (Str : Character) return Pattern; - function NSpan (Str : Character_Set) return Pattern; - function NSpan (Str : not null access VString) return Pattern; - function NSpan (Str : VString_Func) return Pattern; - -- Constructs a pattern that matches the longest possible string - -- consisting entirely of characters from the given argument. The - -- string may be empty, so this pattern always succeeds. - - function Pos (Count : Natural) return Pattern; - function Pos (Count : not null access Natural) return Pattern; - function Pos (Count : Natural_Func) return Pattern; - -- Constructs a pattern that matches the null string if exactly Count - -- characters have already been matched, and otherwise fails. - - function Rest return Pattern; - -- Constructs a pattern that always succeeds, matching the remaining - -- unmatched characters in the pattern. - - function Rpos (Count : Natural) return Pattern; - function Rpos (Count : not null access Natural) return Pattern; - function Rpos (Count : Natural_Func) return Pattern; - -- Constructs a pattern that matches the null string if exactly Count - -- characters remain to be matched in the string, and otherwise fails. - - function Rtab (Count : Natural) return Pattern; - function Rtab (Count : not null access Natural) return Pattern; - function Rtab (Count : Natural_Func) return Pattern; - -- Constructs a pattern that matches from the current location until - -- exactly Count characters remain to be matched in the string. The - -- pattern fails if fewer than Count characters remain to be matched. - - function Setcur (Var : not null access Natural) return Pattern; - -- Constructs a pattern that matches the null string, and assigns the - -- current cursor position in the string. This value is the number of - -- characters matched so far. So it is zero at the start of the match. - - function Span (Str : String) return Pattern; - function Span (Str : VString) return Pattern; - function Span (Str : Character) return Pattern; - function Span (Str : Character_Set) return Pattern; - function Span (Str : not null access VString) return Pattern; - function Span (Str : VString_Func) return Pattern; - -- Constructs a pattern that matches the longest possible string - -- consisting entirely of characters from the given argument. The - -- string cannot be empty, so the pattern fails if the current - -- character is not one of the characters in Str. - - function Succeed return Pattern; - -- Constructs a pattern that succeeds matching null, both on the first - -- attempt, and on any rematch attempt, i.e. it is equivalent to an - -- infinite alternation of null strings. - - function Tab (Count : Natural) return Pattern; - function Tab (Count : not null access Natural) return Pattern; - function Tab (Count : Natural_Func) return Pattern; - -- Constructs a pattern that from the current location until Count - -- characters have been matched. The pattern fails if more than Count - -- characters have already been matched. - - --------------------------------- - -- Pattern Matching Operations -- - --------------------------------- - - -- The Match function performs an actual pattern matching operation. - -- The versions with three parameters perform a match without modifying - -- the subject string and return a Boolean result indicating if the - -- match is successful or not. The Anchor parameter is set to True to - -- obtain an anchored match in which the pattern is required to match - -- the first character of the string. In an unanchored match, which is - - -- the default, successive attempts are made to match the given pattern - -- at each character of the subject string until a match succeeds, or - -- until all possibilities have failed. - - -- Note that pattern assignment functions in the pattern may generate - -- side effects, so these functions are not necessarily pure. - - Anchored_Mode : Boolean := False; - -- This global variable can be set True to cause all subsequent pattern - -- matches to operate in anchored mode. In anchored mode, no attempt is - -- made to move the anchor point, so that if the match succeeds it must - -- succeed starting at the first character. Note that the effect of - -- anchored mode may be achieved in individual pattern matches by using - -- Fence or Pos(0) at the start of the pattern. - - Pattern_Stack_Overflow : exception; - -- Exception raised if internal pattern matching stack overflows. This - -- is typically the result of runaway pattern recursion. If there is a - -- genuine case of stack overflow, then either the match must be broken - -- down into simpler steps, or the stack limit must be reset. - - Stack_Size : constant Positive := 2000; - -- Size used for internal pattern matching stack. Increase this size if - -- complex patterns cause Pattern_Stack_Overflow to be raised. - - -- Simple match functions. The subject is matched against the pattern. - -- Any immediate or deferred assignments or writes are executed, and - -- the returned value indicates whether or not the match succeeded. - - function Match - (Subject : VString; - Pat : Pattern) return Boolean; - - function Match - (Subject : VString; - Pat : PString) return Boolean; - - function Match - (Subject : String; - Pat : Pattern) return Boolean; - - function Match - (Subject : String; - Pat : PString) return Boolean; - - -- Replacement functions. The subject is matched against the pattern. - -- Any immediate or deferred assignments or writes are executed, and - -- the returned value indicates whether or not the match succeeded. - -- If the match succeeds, then the matched part of the subject string - -- is replaced by the given Replace string. - - function Match - (Subject : VString_Var; - Pat : Pattern; - Replace : VString) return Boolean; - - function Match - (Subject : VString_Var; - Pat : PString; - Replace : VString) return Boolean; - - function Match - (Subject : VString_Var; - Pat : Pattern; - Replace : String) return Boolean; - - function Match - (Subject : VString_Var; - Pat : PString; - Replace : String) return Boolean; - - -- Simple match procedures. The subject is matched against the pattern. - -- Any immediate or deferred assignments or writes are executed. No - -- indication of success or failure is returned. - - procedure Match - (Subject : VString; - Pat : Pattern); - - procedure Match - (Subject : VString; - Pat : PString); - - procedure Match - (Subject : String; - Pat : Pattern); - - procedure Match - (Subject : String; - Pat : PString); - - -- Replacement procedures. The subject is matched against the pattern. - -- Any immediate or deferred assignments or writes are executed. No - -- indication of success or failure is returned. If the match succeeds, - -- then the matched part of the subject string is replaced by the given - -- Replace string. - - procedure Match - (Subject : in out VString; - Pat : Pattern; - Replace : VString); - - procedure Match - (Subject : in out VString; - Pat : PString; - Replace : VString); - - procedure Match - (Subject : in out VString; - Pat : Pattern; - Replace : String); - - procedure Match - (Subject : in out VString; - Pat : PString; - Replace : String); - - -- Deferred Replacement - - type Match_Result is private; - -- Type used to record result of pattern match - - subtype Match_Result_Var is Match_Result; - -- This synonyms is used as a formal parameter type to a function where, - -- if the language allowed, we would use an in out parameter, but we are - -- not allowed to have in out parameters for functions. Instead we pass - -- actuals which must be variables, and with a bit of trickery in the - -- body, manage to interpret them properly as though they were indeed - -- in out parameters. - - function Match - (Subject : VString_Var; - Pat : Pattern; - Result : Match_Result_Var) return Boolean; - - procedure Match - (Subject : in out VString; - Pat : Pattern; - Result : out Match_Result); - - procedure Replace - (Result : in out Match_Result; - Replace : VString); - -- Given a previous call to Match which set Result, performs a pattern - -- replacement if the match was successful. Has no effect if the match - -- failed. This call should immediately follow the Match call. - - ------------------------ - -- Debugging Routines -- - ------------------------ - - -- Debugging pattern matching operations can often be quite complex, - -- since there is no obvious way to trace the progress of the match. - -- The declarations in this section provide some debugging assistance. - - Debug_Mode : Boolean := False; - -- This global variable can be set True to generate debugging on all - -- subsequent calls to Match. The debugging output is a full trace of - -- the actions of the pattern matcher, written to Standard_Output. The - -- level of this information is intended to be comprehensible at the - -- abstract level of this package declaration. However, note that the - -- use of this switch often generates large amounts of output. - - function "*" (P : Pattern; Fil : File_Access) return Pattern; - function "*" (P : PString; Fil : File_Access) return Pattern; - function "*" (P : PChar; Fil : File_Access) return Pattern; - function "**" (P : Pattern; Fil : File_Access) return Pattern; - function "**" (P : PString; Fil : File_Access) return Pattern; - function "**" (P : PChar; Fil : File_Access) return Pattern; - -- These are similar to the corresponding pattern assignment operations - -- except that instead of setting the value of a variable, the matched - -- substring is written to the appropriate file. This can be useful in - -- following the progress of a match without generating the full amount - -- of information obtained by setting Debug_Mode to True. - - Terminal : constant File_Access := Standard_Error; - Output : constant File_Access := Standard_Output; - -- Two handy synonyms for use with the above pattern write operations - - -- Finally we have some routines that are useful for determining what - -- patterns are in use, particularly if they are constructed dynamically. - - function Image (P : Pattern) return String; - function Image (P : Pattern) return VString; - -- This procedures yield strings that corresponds to the syntax needed - -- to create the given pattern using the functions in this package. The - -- form of this string is such that it could actually be compiled and - -- evaluated to yield the required pattern except for references to - -- variables and functions, which are output using one of the following - -- forms: - -- - -- access Natural NP(16#...#) - -- access Pattern PP(16#...#) - -- access VString VP(16#...#) - -- - -- Natural_Func NF(16#...#) - -- VString_Func VF(16#...#) - -- - -- where 16#...# is the hex representation of the integer address that - -- corresponds to the given access value - - procedure Dump (P : Pattern); - -- This procedure writes information about the pattern to Standard_Out. - -- The format of this information is keyed to the internal data structures - -- used to implement patterns. The information provided by Dump is thus - -- more precise than that yielded by Image, but is also a bit more obscure - -- (i.e. it cannot be interpreted solely in terms of this spec, you have - -- to know something about the data structures). - - ------------------ - -- Private Part -- - ------------------ - -private - type PE; - -- Pattern element, a pattern is a complex structure of PE's. This type - -- is defined and described in the body of this package. - - type PE_Ptr is access all PE; - -- Pattern reference. PE's use PE_Ptr values to reference other PE's - - type Pattern is new Controlled with record - Stk : Natural := 0; - -- Maximum number of stack entries required for matching this - -- pattern. See description of pattern history stack in body. - - P : PE_Ptr := null; - -- Pointer to initial pattern element for pattern - end record; - - pragma Finalize_Storage_Only (Pattern); - - procedure Adjust (Object : in out Pattern); - -- Adjust routine used to copy pattern objects - - procedure Finalize (Object : in out Pattern); - -- Finalization routine used to release storage allocated for a pattern - - type VString_Ptr is access all VString; - - type Match_Result is record - Var : VString_Ptr; - -- Pointer to subject string. Set to null if match failed - - Start : Natural := 1; - -- Starting index position (1's origin) of matched section of - -- subject string. Only valid if Var is non-null. - - Stop : Natural := 0; - -- Ending index position (1's origin) of matched section of - -- subject string. Only valid if Var is non-null. - - end record; - - pragma Volatile (Match_Result); - -- This ensures that the Result parameter is passed by reference, so - -- that we can play our games with the bogus Match_Result_Var parameter - -- in the function case to treat it as though it were an in out parameter. - -end GNAT.Spitbol.Patterns; diff --git a/gcc/ada/g-spitbo.adb b/gcc/ada/g-spitbo.adb deleted file mode 100644 index 26753bd..0000000 --- a/gcc/ada/g-spitbo.adb +++ /dev/null @@ -1,769 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Strings; use Ada.Strings; -with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; - -with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; -with GNAT.IO; use GNAT.IO; - -with System.String_Hash; - -with Ada.Unchecked_Deallocation; - -package body GNAT.Spitbol is - - --------- - -- "&" -- - --------- - - function "&" (Num : Integer; Str : String) return String is - begin - return S (Num) & Str; - end "&"; - - function "&" (Str : String; Num : Integer) return String is - begin - return Str & S (Num); - end "&"; - - function "&" (Num : Integer; Str : VString) return VString is - begin - return S (Num) & Str; - end "&"; - - function "&" (Str : VString; Num : Integer) return VString is - begin - return Str & S (Num); - end "&"; - - ---------- - -- Char -- - ---------- - - function Char (Num : Natural) return Character is - begin - return Character'Val (Num); - end Char; - - ---------- - -- Lpad -- - ---------- - - function Lpad - (Str : VString; - Len : Natural; - Pad : Character := ' ') return VString - is - begin - if Length (Str) >= Len then - return Str; - else - return Tail (Str, Len, Pad); - end if; - end Lpad; - - function Lpad - (Str : String; - Len : Natural; - Pad : Character := ' ') return VString - is - begin - if Str'Length >= Len then - return V (Str); - - else - declare - R : String (1 .. Len); - - begin - for J in 1 .. Len - Str'Length loop - R (J) := Pad; - end loop; - - R (Len - Str'Length + 1 .. Len) := Str; - return V (R); - end; - end if; - end Lpad; - - procedure Lpad - (Str : in out VString; - Len : Natural; - Pad : Character := ' ') - is - begin - if Length (Str) >= Len then - return; - else - Tail (Str, Len, Pad); - end if; - end Lpad; - - ------- - -- N -- - ------- - - function N (Str : VString) return Integer is - S : Big_String_Access; - L : Natural; - begin - Get_String (Str, S, L); - return Integer'Value (S (1 .. L)); - end N; - - -------------------- - -- Reverse_String -- - -------------------- - - function Reverse_String (Str : VString) return VString is - S : Big_String_Access; - L : Natural; - - begin - Get_String (Str, S, L); - - declare - Result : String (1 .. L); - - begin - for J in 1 .. L loop - Result (J) := S (L + 1 - J); - end loop; - - return V (Result); - end; - end Reverse_String; - - function Reverse_String (Str : String) return VString is - Result : String (1 .. Str'Length); - - begin - for J in 1 .. Str'Length loop - Result (J) := Str (Str'Last + 1 - J); - end loop; - - return V (Result); - end Reverse_String; - - procedure Reverse_String (Str : in out VString) is - S : Big_String_Access; - L : Natural; - - begin - Get_String (Str, S, L); - - declare - Result : String (1 .. L); - - begin - for J in 1 .. L loop - Result (J) := S (L + 1 - J); - end loop; - - Set_Unbounded_String (Str, Result); - end; - end Reverse_String; - - ---------- - -- Rpad -- - ---------- - - function Rpad - (Str : VString; - Len : Natural; - Pad : Character := ' ') return VString - is - begin - if Length (Str) >= Len then - return Str; - else - return Head (Str, Len, Pad); - end if; - end Rpad; - - function Rpad - (Str : String; - Len : Natural; - Pad : Character := ' ') return VString - is - begin - if Str'Length >= Len then - return V (Str); - - else - declare - R : String (1 .. Len); - - begin - for J in Str'Length + 1 .. Len loop - R (J) := Pad; - end loop; - - R (1 .. Str'Length) := Str; - return V (R); - end; - end if; - end Rpad; - - procedure Rpad - (Str : in out VString; - Len : Natural; - Pad : Character := ' ') - is - begin - if Length (Str) >= Len then - return; - - else - Head (Str, Len, Pad); - end if; - end Rpad; - - ------- - -- S -- - ------- - - function S (Num : Integer) return String is - Buf : String (1 .. 30); - Ptr : Natural := Buf'Last + 1; - Val : Natural := abs (Num); - - begin - loop - Ptr := Ptr - 1; - Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0')); - Val := Val / 10; - exit when Val = 0; - end loop; - - if Num < 0 then - Ptr := Ptr - 1; - Buf (Ptr) := '-'; - end if; - - return Buf (Ptr .. Buf'Last); - end S; - - ------------ - -- Substr -- - ------------ - - function Substr - (Str : VString; - Start : Positive; - Len : Natural) return VString - is - S : Big_String_Access; - L : Natural; - - begin - Get_String (Str, S, L); - - if Start > L then - raise Index_Error; - elsif Start + Len - 1 > L then - raise Length_Error; - else - return V (S (Start .. Start + Len - 1)); - end if; - end Substr; - - function Substr - (Str : String; - Start : Positive; - Len : Natural) return VString - is - begin - if Start > Str'Length then - raise Index_Error; - elsif Start + Len - 1 > Str'Length then - raise Length_Error; - else - return - V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2)); - end if; - end Substr; - - ----------- - -- Table -- - ----------- - - package body Table is - - procedure Free is new - Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Hash is new System.String_Hash.Hash - (Character, String, Unsigned_32); - - ------------ - -- Adjust -- - ------------ - - overriding procedure Adjust (Object : in out Table) is - Ptr1 : Hash_Element_Ptr; - Ptr2 : Hash_Element_Ptr; - - begin - for J in Object.Elmts'Range loop - Ptr1 := Object.Elmts (J)'Unrestricted_Access; - - if Ptr1.Name /= null then - loop - Ptr1.Name := new String'(Ptr1.Name.all); - exit when Ptr1.Next = null; - Ptr2 := Ptr1.Next; - Ptr1.Next := new Hash_Element'(Ptr2.all); - Ptr1 := Ptr1.Next; - end loop; - end if; - end loop; - end Adjust; - - ----------- - -- Clear -- - ----------- - - procedure Clear (T : in out Table) is - Ptr1 : Hash_Element_Ptr; - Ptr2 : Hash_Element_Ptr; - - begin - for J in T.Elmts'Range loop - if T.Elmts (J).Name /= null then - Free (T.Elmts (J).Name); - T.Elmts (J).Value := Null_Value; - - Ptr1 := T.Elmts (J).Next; - T.Elmts (J).Next := null; - - while Ptr1 /= null loop - Ptr2 := Ptr1.Next; - Free (Ptr1.Name); - Free (Ptr1); - Ptr1 := Ptr2; - end loop; - end if; - end loop; - end Clear; - - ---------------------- - -- Convert_To_Array -- - ---------------------- - - function Convert_To_Array (T : Table) return Table_Array is - Num_Elmts : Natural := 0; - Elmt : Hash_Element_Ptr; - - begin - for J in T.Elmts'Range loop - Elmt := T.Elmts (J)'Unrestricted_Access; - - if Elmt.Name /= null then - loop - Num_Elmts := Num_Elmts + 1; - Elmt := Elmt.Next; - exit when Elmt = null; - end loop; - end if; - end loop; - - declare - TA : Table_Array (1 .. Num_Elmts); - P : Natural := 1; - - begin - for J in T.Elmts'Range loop - Elmt := T.Elmts (J)'Unrestricted_Access; - - if Elmt.Name /= null then - loop - Set_Unbounded_String (TA (P).Name, Elmt.Name.all); - TA (P).Value := Elmt.Value; - P := P + 1; - Elmt := Elmt.Next; - exit when Elmt = null; - end loop; - end if; - end loop; - - return TA; - end; - end Convert_To_Array; - - ---------- - -- Copy -- - ---------- - - procedure Copy (From : Table; To : in out Table) is - Elmt : Hash_Element_Ptr; - - begin - Clear (To); - - for J in From.Elmts'Range loop - Elmt := From.Elmts (J)'Unrestricted_Access; - if Elmt.Name /= null then - loop - Set (To, Elmt.Name.all, Elmt.Value); - Elmt := Elmt.Next; - exit when Elmt = null; - end loop; - end if; - end loop; - end Copy; - - ------------ - -- Delete -- - ------------ - - procedure Delete (T : in out Table; Name : Character) is - begin - Delete (T, String'(1 => Name)); - end Delete; - - procedure Delete (T : in out Table; Name : VString) is - S : Big_String_Access; - L : Natural; - begin - Get_String (Name, S, L); - Delete (T, S (1 .. L)); - end Delete; - - procedure Delete (T : in out Table; Name : String) is - Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; - Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; - Next : Hash_Element_Ptr; - - begin - if Elmt.Name = null then - null; - - elsif Elmt.Name.all = Name then - Free (Elmt.Name); - - if Elmt.Next = null then - Elmt.Value := Null_Value; - return; - - else - Next := Elmt.Next; - Elmt.Name := Next.Name; - Elmt.Value := Next.Value; - Elmt.Next := Next.Next; - Free (Next); - return; - end if; - - else - loop - Next := Elmt.Next; - - if Next = null then - return; - - elsif Next.Name.all = Name then - Free (Next.Name); - Elmt.Next := Next.Next; - Free (Next); - return; - - else - Elmt := Next; - end if; - end loop; - end if; - end Delete; - - ---------- - -- Dump -- - ---------- - - procedure Dump (T : Table; Str : String := "Table") is - Num_Elmts : Natural := 0; - Elmt : Hash_Element_Ptr; - - begin - for J in T.Elmts'Range loop - Elmt := T.Elmts (J)'Unrestricted_Access; - - if Elmt.Name /= null then - loop - Num_Elmts := Num_Elmts + 1; - Put_Line - (Str & '<' & Image (Elmt.Name.all) & "> = " & - Img (Elmt.Value)); - Elmt := Elmt.Next; - exit when Elmt = null; - end loop; - end if; - end loop; - - if Num_Elmts = 0 then - Put_Line (Str & " is empty"); - end if; - end Dump; - - procedure Dump (T : Table_Array; Str : String := "Table_Array") is - begin - if T'Length = 0 then - Put_Line (Str & " is empty"); - - else - for J in T'Range loop - Put_Line - (Str & '(' & Image (To_String (T (J).Name)) & ") = " & - Img (T (J).Value)); - end loop; - end if; - end Dump; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Object : in out Table) is - Ptr1 : Hash_Element_Ptr; - Ptr2 : Hash_Element_Ptr; - - begin - for J in Object.Elmts'Range loop - Ptr1 := Object.Elmts (J).Next; - Free (Object.Elmts (J).Name); - while Ptr1 /= null loop - Ptr2 := Ptr1.Next; - Free (Ptr1.Name); - Free (Ptr1); - Ptr1 := Ptr2; - end loop; - end loop; - end Finalize; - - --------- - -- Get -- - --------- - - function Get (T : Table; Name : Character) return Value_Type is - begin - return Get (T, String'(1 => Name)); - end Get; - - function Get (T : Table; Name : VString) return Value_Type is - S : Big_String_Access; - L : Natural; - begin - Get_String (Name, S, L); - return Get (T, S (1 .. L)); - end Get; - - function Get (T : Table; Name : String) return Value_Type is - Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; - Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; - - begin - if Elmt.Name = null then - return Null_Value; - - else - loop - if Name = Elmt.Name.all then - return Elmt.Value; - - else - Elmt := Elmt.Next; - - if Elmt = null then - return Null_Value; - end if; - end if; - end loop; - end if; - end Get; - - ------------- - -- Present -- - ------------- - - function Present (T : Table; Name : Character) return Boolean is - begin - return Present (T, String'(1 => Name)); - end Present; - - function Present (T : Table; Name : VString) return Boolean is - S : Big_String_Access; - L : Natural; - begin - Get_String (Name, S, L); - return Present (T, S (1 .. L)); - end Present; - - function Present (T : Table; Name : String) return Boolean is - Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; - Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; - - begin - if Elmt.Name = null then - return False; - - else - loop - if Name = Elmt.Name.all then - return True; - - else - Elmt := Elmt.Next; - - if Elmt = null then - return False; - end if; - end if; - end loop; - end if; - end Present; - - --------- - -- Set -- - --------- - - procedure Set (T : in out Table; Name : VString; Value : Value_Type) is - S : Big_String_Access; - L : Natural; - begin - Get_String (Name, S, L); - Set (T, S (1 .. L), Value); - end Set; - - procedure Set (T : in out Table; Name : Character; Value : Value_Type) is - begin - Set (T, String'(1 => Name), Value); - end Set; - - procedure Set - (T : in out Table; - Name : String; - Value : Value_Type) - is - begin - if Value = Null_Value then - Delete (T, Name); - - else - declare - Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; - Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; - - subtype String1 is String (1 .. Name'Length); - - begin - if Elmt.Name = null then - Elmt.Name := new String'(String1 (Name)); - Elmt.Value := Value; - return; - - else - loop - if Name = Elmt.Name.all then - Elmt.Value := Value; - return; - - elsif Elmt.Next = null then - Elmt.Next := new Hash_Element'( - Name => new String'(String1 (Name)), - Value => Value, - Next => null); - return; - - else - Elmt := Elmt.Next; - end if; - end loop; - end if; - end; - end if; - end Set; - end Table; - - ---------- - -- Trim -- - ---------- - - function Trim (Str : VString) return VString is - begin - return Trim (Str, Right); - end Trim; - - function Trim (Str : String) return VString is - begin - for J in reverse Str'Range loop - if Str (J) /= ' ' then - return V (Str (Str'First .. J)); - end if; - end loop; - - return Nul; - end Trim; - - procedure Trim (Str : in out VString) is - begin - Trim (Str, Right); - end Trim; - - ------- - -- V -- - ------- - - function V (Num : Integer) return VString is - Buf : String (1 .. 30); - Ptr : Natural := Buf'Last + 1; - Val : Natural := abs (Num); - - begin - loop - Ptr := Ptr - 1; - Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0')); - Val := Val / 10; - exit when Val = 0; - end loop; - - if Num < 0 then - Ptr := Ptr - 1; - Buf (Ptr) := '-'; - end if; - - return V (Buf (Ptr .. Buf'Last)); - end V; - -end GNAT.Spitbol; diff --git a/gcc/ada/g-spitbo.ads b/gcc/ada/g-spitbo.ads deleted file mode 100644 index b07a214..0000000 --- a/gcc/ada/g-spitbo.ads +++ /dev/null @@ -1,394 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- SPITBOL-like interface facilities - --- This package provides a set of interfaces to semantic operations copied --- from SPITBOL, including a complete implementation of SPITBOL pattern --- matching. The code is derived from the original SPITBOL MINIMAL sources, --- created by Robert Dewar. The translation is not exact, but the --- algorithmic approaches are similar. - -with Ada.Finalization; use Ada.Finalization; -with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; -with Interfaces; use Interfaces; - -package GNAT.Spitbol is - pragma Preelaborate; - - -- The Spitbol package relies heavily on the Unbounded_String package, - -- using the synonym VString for variable length string. The following - -- declarations define this type and other useful abbreviations. - - subtype VString is Ada.Strings.Unbounded.Unbounded_String; - - function V (Source : String) return VString - renames Ada.Strings.Unbounded.To_Unbounded_String; - - function S (Source : VString) return String - renames Ada.Strings.Unbounded.To_String; - - Nul : VString renames Ada.Strings.Unbounded.Null_Unbounded_String; - - ------------------------- - -- Facilities Provided -- - ------------------------- - - -- The SPITBOL support in GNAT consists of this package together with - -- several child packages. In this package, we have first a set of - -- useful string functions, copied exactly from the corresponding - -- SPITBOL functions, except that we had to rename REVERSE because - -- reverse is a reserved word (it is now Reverse_String). - - -- The second element of the parent package is a generic implementation - -- of a table facility. In SPITBOL, the TABLE function allows general - -- mappings from any datatype to any other datatype, and of course, as - -- always, we can freely mix multiple types in the same table. - - -- The Ada version of tables is strongly typed, so the indexing type and - -- the range type are always of a consistent type. In this implementation - -- we only provide VString as an indexing type, since this is by far the - -- most common case. The generic instantiation specifies the range type - -- to be used. - - -- Three child packages provide standard instantiations of this table - -- package for three common datatypes: - - -- GNAT.Spitbol.Table_Boolean (file g-sptabo.ads) - - -- The range type is Boolean. The default value is False. This - -- means that this table is essentially a representation of a set. - - -- GNAT.Spitbol.Table_Integer (file g-sptain.ads) - - -- The range type is Integer. The default value is Integer'First. - -- This provides a general mapping from strings to integers. - - -- GNAT.Spitbol.Table_VString (file g-sptavs.ads) - - -- The range type is VString. The default value is the null string. - -- This provides a general mapping from strings to strings. - - -- Finally there is another child package: - - -- GNAT.Spitbol.Patterns (file g-spipat.ads) - - -- This child package provides a complete implementation of SPITBOL - -- pattern matching. The spec contains a complete tutorial on the - -- use of pattern matching. - - --------------------------------- - -- Standard String Subprograms -- - --------------------------------- - - -- This section contains some operations on unbounded strings that are - -- closely related to those in the package Unbounded.Strings, but they - -- correspond to the SPITBOL semantics for these operations. - - function Char (Num : Natural) return Character; - pragma Inline (Char); - -- Equivalent to Character'Val (Num) - - function Lpad - (Str : VString; - Len : Natural; - Pad : Character := ' ') return VString; - function Lpad - (Str : String; - Len : Natural; - Pad : Character := ' ') return VString; - -- If the length of Str is greater than or equal to Len, then Str is - -- returned unchanged. Otherwise, The value returned is obtained by - -- concatenating Length (Str) - Len instances of the Pad character to - -- the left hand side. - - procedure Lpad - (Str : in out VString; - Len : Natural; - Pad : Character := ' '); - -- The procedure form is identical to the function form, except that - -- the result overwrites the input argument Str. - - function Reverse_String (Str : VString) return VString; - function Reverse_String (Str : String) return VString; - -- Returns result of reversing the string Str, i.e. the result returned - -- is a mirror image (end-for-end reversal) of the input string. - - procedure Reverse_String (Str : in out VString); - -- The procedure form is identical to the function form, except that the - -- result overwrites the input argument Str. - - function Rpad - (Str : VString; - Len : Natural; - Pad : Character := ' ') return VString; - function Rpad - (Str : String; - Len : Natural; - Pad : Character := ' ') return VString; - -- If the length of Str is greater than or equal to Len, then Str is - -- returned unchanged. Otherwise, The value returned is obtained by - -- concatenating Length (Str) - Len instances of the Pad character to - -- the right hand side. - - procedure Rpad - (Str : in out VString; - Len : Natural; - Pad : Character := ' '); - -- The procedure form is identical to the function form, except that the - -- result overwrites the input argument Str. - - function Size (Source : VString) return Natural - renames Ada.Strings.Unbounded.Length; - - function Substr - (Str : VString; - Start : Positive; - Len : Natural) return VString; - function Substr - (Str : String; - Start : Positive; - Len : Natural) return VString; - -- Returns the substring starting at the given character position (which - -- is always counted from the start of the string, regardless of bounds, - -- e.g. 2 means starting with the second character of the string), and - -- with the length (Len) given. Index_Error is raised if the starting - -- position is out of range, and Length_Error is raised if Len is too long. - - function Trim (Str : VString) return VString; - function Trim (Str : String) return VString; - -- Returns the string obtained by removing all spaces from the right - -- hand side of the string Str. - - procedure Trim (Str : in out VString); - -- The procedure form is identical to the function form, except that the - -- result overwrites the input argument Str. - - ----------------------- - -- Utility Functions -- - ----------------------- - - -- In SPITBOL, integer values can be freely treated as strings. The - -- following definitions help provide some of this capability in - -- some common cases. - - function "&" (Num : Integer; Str : String) return String; - function "&" (Str : String; Num : Integer) return String; - function "&" (Num : Integer; Str : VString) return VString; - function "&" (Str : VString; Num : Integer) return VString; - -- In all these concatenation operations, the integer is converted to - -- its corresponding decimal string form, with no leading blank. - - function S (Num : Integer) return String; - function V (Num : Integer) return VString; - -- These operators return the given integer converted to its decimal - -- string form with no leading blank. - - function N (Str : VString) return Integer; - -- Converts string to number (same as Integer'Value (S (Str))) - - ------------------- - -- Table Support -- - ------------------- - - -- So far, we only provide support for tables whose indexing data values - -- are strings (or unbounded strings). The values stored may be of any - -- type, as supplied by the generic formal parameter. - - generic - - type Value_Type is private; - -- Any non-limited type can be used as the value type in the table - - Null_Value : Value_Type; - -- Value used to represent a value that is not present in the table - - with function Img (A : Value_Type) return String; - -- Used to provide image of value in Dump procedure - - with function "=" (A, B : Value_Type) return Boolean is <>; - -- This allows a user-defined equality function to override the - -- predefined equality function. - - package Table is - - ------------------------ - -- Table Declarations -- - ------------------------ - - type Table (N : Unsigned_32) is private; - -- This is the table type itself. A table is a mapping from string - -- values to values of Value_Type. The discriminant is an estimate of - -- the number of values in the table. If the estimate is much too - -- high, some space is wasted, if the estimate is too low, access to - -- table elements is slowed down. The type Table has copy semantics, - -- not reference semantics. This means that if a table is copied - -- using simple assignment, then the two copies refer to entirely - -- separate tables. - - ----------------------------- - -- Table Access Operations -- - ----------------------------- - - function Get (T : Table; Name : VString) return Value_Type; - function Get (T : Table; Name : Character) return Value_Type; - pragma Inline (Get); - function Get (T : Table; Name : String) return Value_Type; - - -- If an entry with the given name exists in the table, then the - -- corresponding Value_Type value is returned. Otherwise Null_Value - -- is returned. - - function Present (T : Table; Name : VString) return Boolean; - function Present (T : Table; Name : Character) return Boolean; - pragma Inline (Present); - function Present (T : Table; Name : String) return Boolean; - -- Determines if an entry with the given name is present in the table. - -- A returned value of True means that it is in the table, otherwise - -- False indicates that it is not in the table. - - procedure Delete (T : in out Table; Name : VString); - procedure Delete (T : in out Table; Name : Character); - pragma Inline (Delete); - procedure Delete (T : in out Table; Name : String); - -- Deletes the table element with the given name from the table. If - -- no element in the table has this name, then the call has no effect. - - procedure Set (T : in out Table; Name : VString; Value : Value_Type); - procedure Set (T : in out Table; Name : Character; Value : Value_Type); - pragma Inline (Set); - procedure Set (T : in out Table; Name : String; Value : Value_Type); - -- Sets the value of the element with the given name to the given - -- value. If Value is equal to Null_Value, the effect is to remove - -- the entry from the table. If no element with the given name is - -- currently in the table, then a new element with the given value - -- is created. - - ---------------------------- - -- Allocation and Copying -- - ---------------------------- - - -- Table is a controlled type, so that all storage associated with - -- tables is properly reclaimed when a Table value is abandoned. - -- Tables have value semantics rather than reference semantics as - -- in Spitbol, i.e. when you assign a copy you end up with two - -- distinct copies of the table, as though COPY had been used in - -- Spitbol. It seems clearly more appropriate in Ada to require - -- the use of explicit pointers for reference semantics. - - procedure Clear (T : in out Table); - -- Clears all the elements of the given table, freeing associated - -- storage. On return T is an empty table with no elements. - - procedure Copy (From : Table; To : in out Table); - -- First all the elements of table To are cleared (as described for - -- the Clear procedure above), then all the elements of table From - -- are copied into To. In the case where the tables From and To have - -- the same declared size (i.e. the same discriminant), the call to - -- Copy has the same effect as the assignment of From to To. The - -- difference is that, unlike the assignment statement, which will - -- cause a Constraint_Error if the source and target are of different - -- sizes, Copy works fine with different sized tables. - - ---------------- - -- Conversion -- - ---------------- - - type Table_Entry is record - Name : VString; - Value : Value_Type; - end record; - - type Table_Array is array (Positive range <>) of Table_Entry; - - function Convert_To_Array (T : Table) return Table_Array; - -- Returns a Table_Array value with a low bound of 1, and a length - -- corresponding to the number of elements in the table. The elements - -- of the array give the elements of the table in unsorted order. - - --------------- - -- Debugging -- - --------------- - - procedure Dump (T : Table; Str : String := "Table"); - -- Dump contents of given table to the standard output file. The - -- string value Str is used as the name of the table in the dump. - - procedure Dump (T : Table_Array; Str : String := "Table_Array"); - -- Dump contents of given table array to the current output file. The - -- string value Str is used as the name of the table array in the dump. - - private - - ------------------ - -- Private Part -- - ------------------ - - -- A Table is a pointer to a hash table which contains the indicated - -- number of hash elements (the number is forced to the next odd value - -- if it is even to improve hashing performance). If more than one - -- of the entries in a table hashes to the same slot, the Next field - -- is used to chain entries from the header. The chains are not kept - -- ordered. A chain is terminated by a null pointer in Next. An unused - -- chain is marked by an element whose Name is null and whose value - -- is Null_Value. - - type Hash_Element; - type Hash_Element_Ptr is access all Hash_Element; - - type Hash_Element is record - Name : String_Access := null; - Value : Value_Type := Null_Value; - Next : Hash_Element_Ptr := null; - end record; - - type Hash_Table is - array (Unsigned_32 range <>) of aliased Hash_Element; - - type Table (N : Unsigned_32) is new Controlled with record - Elmts : Hash_Table (1 .. N); - end record; - - pragma Finalize_Storage_Only (Table); - - overriding procedure Adjust (Object : in out Table); - -- The Adjust procedure does a deep copy of the table structure - -- so that the effect of assignment is, like other assignments - -- in Ada, value-oriented. - - overriding procedure Finalize (Object : in out Table); - -- This is the finalization routine that ensures that all storage - -- associated with a table is properly released when a table object - -- is abandoned and finalized. - - end Table; - -end GNAT.Spitbol; diff --git a/gcc/ada/g-sptabo.ads b/gcc/ada/g-sptabo.ads deleted file mode 100644 index 7d5b826..0000000 --- a/gcc/ada/g-sptabo.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L . T A B L E _ B O O L E A N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- SPITBOL tables with boolean values (sets) - --- This package provides a predefined instantiation of the table abstraction --- for type Standard.Boolean. The null value is False, so the only non-null --- value is True, i.e. this table acts essentially as a set representation. --- This package is based on Macro-SPITBOL created by Robert Dewar. - -package GNAT.Spitbol.Table_Boolean is new - GNAT.Spitbol.Table (Boolean, False, Boolean'Image); -pragma Preelaborate (Table_Boolean); diff --git a/gcc/ada/g-sptain.ads b/gcc/ada/g-sptain.ads deleted file mode 100644 index 1cc06de..0000000 --- a/gcc/ada/g-sptain.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L . T A B L E _ I N T E G E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- SPITBOL tables with integer values - --- This package provides a predefined instantiation of the table abstraction --- for type Standard.Integer. The largest negative integer is used as the --- null value for the table. This package is based on Macro-SPITBOL created --- by Robert Dewar. - -package GNAT.Spitbol.Table_Integer is - new GNAT.Spitbol.Table (Integer, Integer'First, Integer'Image); -pragma Preelaborate (Table_Integer); diff --git a/gcc/ada/g-sptavs.ads b/gcc/ada/g-sptavs.ads deleted file mode 100644 index 7bbc854..0000000 --- a/gcc/ada/g-sptavs.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . S P I T B O L . T A B L E _ V S T R I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1997-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- SPITBOL tables with vstring (unbounded string) values - --- This package provides a predefined instantiation of the table abstraction --- for type VString (Ada.Strings.Unbounded.Unbounded_String). This package --- is based on Macro-SPITBOL created by Robert Dewar. - -package GNAT.Spitbol.Table_VString is new - GNAT.Spitbol.Table (VString, Nul, To_String); -pragma Preelaborate (Table_VString); diff --git a/gcc/ada/g-sse.ads b/gcc/ada/g-sse.ads deleted file mode 100644 index 60d3577..0000000 --- a/gcc/ada/g-sse.ads +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S S E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is the root of a set aimed at offering Ada bindings to a --- subset of the Intel(r) Streaming SIMD Extensions with GNAT. The purpose --- is to allow access from Ada to the SSE facilities defined in the Intel(r) --- compiler manuals, in particular in the Intrinsics Reference of the C++ --- Compiler User's Guide, available from http://www.intel.com. - --- Assuming actual hardware support is available, this capability is --- currently supported on the following set of targets: - --- GNU/Linux x86 and x86_64 --- Windows XP/Vista x86 and x86_64 --- Solaris x86 --- Darwin x86_64 - --- This unit exposes vector _component_ types together with general comments --- on the binding contents. - --- One other unit is offered as of today: GNAT.SSE.Vector_Types, which --- exposes Ada types corresponding to the reference types (__m128 and the --- like) over which a binding to the SSE GCC builtins may operate. - --- The exposed Ada types are private. Object initializations or value --- observations may be performed with unchecked conversions or address --- overlays, for example: - --- with Ada.Unchecked_Conversion; --- with GNAT.SSE.Vector_Types; use GNAT.SSE, GNAT.SSE.Vector_Types; - --- procedure SSE_Base is - --- -- Core operations - --- function ia32_addps (A, B : m128) return m128; --- pragma Import (Intrinsic, ia32_addps, "__builtin_ia32_addps"); - --- -- User views & conversions - --- type Vf32_View is array (1 .. 4) of GNAT.SSE.Float32; --- for Vf32_View'Alignment use VECTOR_ALIGN; - --- function To_m128 is new Ada.Unchecked_Conversion (Vf32_View, m128); - --- Xf32 : constant Vf32_View := (1.0, 1.0, 2.0, 2.0); --- Yf32 : constant Vf32_View := (2.0, 2.0, 1.0, 1.0); - --- X128 : constant m128 := To_m128 (Xf32); --- Y128 : constant m128 := To_m128 (Yf32); - --- begin --- -- Operations & overlays - --- declare --- Z128 : m128; --- Zf32 : Vf32_View; --- for Zf32'Address use Z128'Address; --- begin --- Z128 := ia32_addps (X128, Y128); --- if Zf32 /= (3.0, 3.0, 3.0, 3.0) then --- raise Program_Error; --- end if; --- end; - --- declare --- type m128_View_Kind is (SSE, F32); --- type m128_Object (View : m128_View_Kind := F32) is record --- case View is --- when SSE => V128 : m128; --- when F32 => Vf32 : Vf32_View; --- end case; --- end record; --- pragma Unchecked_Union (m128_Object); - --- O1 : constant m128_Object := (View => SSE, V128 => X128); --- begin --- if O1.Vf32 /= Xf32 then --- raise Program_Error; --- end if; --- end; --- end SSE_Base; - -package GNAT.SSE is - - ----------------------------------- - -- Common vector characteristics -- - ----------------------------------- - - VECTOR_BYTES : constant := 16; - -- Common size of all the SSE vector types, in bytes. - - VECTOR_ALIGN : constant := 16; - -- Common alignment of all the SSE vector types, in bytes. - - -- Alignment-wise, the reference document reads: - -- << The compiler aligns __m128d and _m128i local and global data to - -- 16-byte boundaries on the stack. >> - -- - -- We apply that consistently to all the Ada vector types, as GCC does - -- for the corresponding C types. - - ---------------------------- - -- Vector component types -- - ---------------------------- - - type Float32 is new Float; - type Float64 is new Long_Float; - type Integer64 is new Long_Long_Integer; - -end GNAT.SSE; diff --git a/gcc/ada/g-ssvety.ads b/gcc/ada/g-ssvety.ads deleted file mode 100644 index c407064..0000000 --- a/gcc/ada/g-ssvety.ads +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S S E . V E C T O R _ T Y P E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit exposes the Ada __m128 like data types to represent the contents --- of SSE registers, for use by bindings to the SSE intrinsic operations. - --- See GNAT.SSE for the list of targets where this facility is supported - -package GNAT.SSE.Vector_Types is - - -- The reference guide states a few usage guidelines for the C types: - - -- Since these new data types are not basic ANSI C data types, you - -- must observe the following usage restrictions: - -- - -- * Use new data types only on either side of an assignment, as a - -- return value, or as a parameter. You cannot use it with other - -- arithmetic expressions ("+", "-", and so on). - -- - -- * Use new data types as objects in aggregates, such as unions to - -- access the byte elements and structures. - -- - -- * Use new data types only with the respective intrinsics described - -- in this documentation. - - type m128 is private; -- SSE >= 1 - type m128d is private; -- SSE >= 2 - type m128i is private; -- SSE >= 2 - -private - -- Each of the m128 types maps to a specific vector_type with an extra - -- "may_alias" attribute as in GCC's definitions for C, for instance in - -- xmmintrin.h: - - -- /* The Intel API is flexible enough that we must allow aliasing - -- with other vector types, and their scalar components. */ - -- typedef float __m128 - -- __attribute__ ((__vector_size__ (16), __may_alias__)); - - -- /* Internal data types for implementing the intrinsics. */ - -- typedef float __v4sf __attribute__ ((__vector_size__ (16))); - - ------------ - -- m128 -- - ------------ - - -- The __m128 data type can hold four 32-bit floating-point values - - type m128 is array (1 .. 4) of Float32; - for m128'Alignment use VECTOR_ALIGN; - pragma Machine_Attribute (m128, "vector_type"); - pragma Machine_Attribute (m128, "may_alias"); - - ------------- - -- m128d -- - ------------- - - -- The __m128d data type can hold two 64-bit floating-point values - - type m128d is array (1 .. 2) of Float64; - for m128d'Alignment use VECTOR_ALIGN; - pragma Machine_Attribute (m128d, "vector_type"); - pragma Machine_Attribute (m128d, "may_alias"); - - ------------- - -- m128i -- - ------------- - - -- The __m128i data type can hold sixteen 8-bit, eight 16-bit, four 32-bit, - -- or two 64-bit integer values. - - type m128i is array (1 .. 2) of Integer64; - for m128i'Alignment use VECTOR_ALIGN; - pragma Machine_Attribute (m128i, "vector_type"); - pragma Machine_Attribute (m128i, "may_alias"); - -end GNAT.SSE.Vector_Types; diff --git a/gcc/ada/g-stheme.adb b/gcc/ada/g-stheme.adb deleted file mode 100644 index ceccba0..0000000 --- a/gcc/ada/g-stheme.adb +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- GNAT.SOCKETS.THIN.HOST_ERROR_MESSAGES -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default implementation of this unit, providing explicit --- literal messages (we do not use hstrerror from the standard C library, --- as this function is obsolete). - -separate (GNAT.Sockets.Thin) -package body Host_Error_Messages is - - function Host_Error_Message (H_Errno : Integer) return String is - begin - case H_Errno is - when SOSC.HOST_NOT_FOUND => - return "Host not found"; - when SOSC.TRY_AGAIN => - return "Try again"; - when SOSC.NO_RECOVERY => - return "No recovery"; - when SOSC.NO_DATA => - return "No address"; - when others => - return "Unknown error"; - end case; - end Host_Error_Message; - -end Host_Error_Messages; diff --git a/gcc/ada/g-strhas.ads b/gcc/ada/g-strhas.ads deleted file mode 100644 index c20b678..0000000 --- a/gcc/ada/g-strhas.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S T R I N G _ H A S H -- --- -- --- S p e c -- --- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 generic hashing function over strings, suitable for --- use with a string keyed hash table. In particular, it is the basis for the --- string hash functions in Ada.Containers. --- --- The algorithm used here is not appropriate for applications that require --- cryptographically strong hashes, or for applications that wish to use very --- wide hash values as pseudo unique identifiers. In such cases please refer --- to GNAT.SHA1 and GNAT.MD5. - -with System.String_Hash; - -package GNAT.String_Hash renames System.String_Hash; diff --git a/gcc/ada/g-string.adb b/gcc/ada/g-string.adb deleted file mode 100644 index 970ef2c..0000000 --- a/gcc/ada/g-string.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S T R I N G S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-string.ads b/gcc/ada/g-string.ads deleted file mode 100644 index a25938e..0000000 --- a/gcc/ada/g-string.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S T R I N G S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Common String access types and related subprograms - --- See file s-string.ads for full documentation of the interface - -with System.Strings; - -package GNAT.Strings renames System.Strings; diff --git a/gcc/ada/g-strspl.ads b/gcc/ada/g-strspl.ads deleted file mode 100644 index 31851b3..0000000 --- a/gcc/ada/g-strspl.ads +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S T R I N G _ S P L I T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Useful string-manipulation routines: given a set of separators, split --- a string wherever the separators appear, and provide direct access --- to the resulting slices. See GNAT.Array_Split for full documentation. - -with Ada.Strings.Maps; use Ada.Strings; -with GNAT.Array_Split; - -package GNAT.String_Split is new GNAT.Array_Split - (Element => Character, - Element_Sequence => String, - Element_Set => Maps.Character_Set, - To_Set => Maps.To_Set, - Is_In => Maps.Is_In); diff --git a/gcc/ada/g-stseme.adb b/gcc/ada/g-stseme.adb deleted file mode 100644 index 2b6aeeb..0000000 --- a/gcc/ada/g-stseme.adb +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- GNAT.SOCKETS.THIN.SOCKET_ERROR_MESSAGE -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default implementation of this unit, using the standard C --- library's strerror(3) function. It is used on all platforms except Windows, --- since on that platform socket errno values are distinct from the system --- ones: there is a specific variant of this function in g-socthi-mingw.adb. - -separate (GNAT.Sockets.Thin) - --------------------------- --- Socket_Error_Message -- --------------------------- - -function Socket_Error_Message - (Errno : Integer) return String -is -begin - return Errno_Message (Errno, Default => "Unknown system error"); -end Socket_Error_Message; diff --git a/gcc/ada/g-stsifd-sockets.adb b/gcc/ada/g-stsifd-sockets.adb deleted file mode 100644 index 87e887f..0000000 --- a/gcc/ada/g-stsifd-sockets.adb +++ /dev/null @@ -1,234 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds --- used for platforms that do not support UNIX pipes. - --- Note: this code used to be in GNAT.Sockets, but has been moved to a --- platform-specific file. It is now used only for non-UNIX platforms. - -separate (GNAT.Sockets.Thin) -package body Signalling_Fds is - - ----------- - -- Close -- - ----------- - - procedure Close (Sig : C.int) is - Res : C.int; - pragma Unreferenced (Res); - -- Res is assigned but never read, because we purposefully ignore - -- any error returned by the C_Close system call, as per the spec - -- of this procedure. - begin - Res := C_Close (Sig); - end Close; - - ------------ - -- Create -- - ------------ - - function Create (Fds : not null access Fd_Pair) return C.int is - L_Sock, R_Sock, W_Sock : C.int := Failure; - -- Listening socket, read socket and write socket - - Sin : aliased Sockaddr_In; - Len : aliased C.int; - -- Address of listening socket - - Res : C.int; - pragma Warnings (Off, Res); - -- Return status of system calls (usually ignored, hence warnings off) - - begin - Fds.all := (Read_End | Write_End => Failure); - - -- We open two signalling sockets. One of them is used to send data - -- to the other, which is included in a C_Select socket set. The - -- communication is used to force the call to C_Select to complete, - -- and the waiting task to resume its execution. - - loop - -- Retry loop, in case the C_Connect below fails - - -- Create a listening socket - - L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); - - if L_Sock = Failure then - goto Fail; - end if; - - -- Bind the socket to an available port on localhost - - Set_Family (Sin.Sin_Family, Family_Inet); - Sin.Sin_Addr.S_B1 := 127; - Sin.Sin_Addr.S_B2 := 0; - Sin.Sin_Addr.S_B3 := 0; - Sin.Sin_Addr.S_B4 := 1; - Sin.Sin_Port := 0; - - Len := C.int (Lengths (Family_Inet)); - Res := C_Bind (L_Sock, Sin'Address, Len); - - if Res = Failure then - goto Fail; - end if; - - -- Get assigned port - - Res := C_Getsockname (L_Sock, Sin'Address, Len'Access); - if Res = Failure then - goto Fail; - end if; - - -- Set socket to listen mode, with a backlog of 1 to guarantee that - -- exactly one call to connect(2) succeeds. - - Res := C_Listen (L_Sock, 1); - - if Res = Failure then - goto Fail; - end if; - - -- Create read end (client) socket - - R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); - - if R_Sock = Failure then - goto Fail; - end if; - - -- Connect listening socket - - Res := C_Connect (R_Sock, Sin'Address, Len); - - exit when Res /= Failure; - - if Socket_Errno /= SOSC.EADDRINUSE then - goto Fail; - end if; - - -- In rare cases, the above C_Bind chooses a port that is still - -- marked "in use", even though it has been closed (perhaps by some - -- other process that has already exited). This causes the above - -- C_Connect to fail with EADDRINUSE. In this case, we close the - -- ports, and loop back to try again. This mysterious Windows - -- behavior is documented. See, for example: - -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx - -- In an experiment with 2000 calls, 21 required exactly one retry, 7 - -- required two, and none required three or more. Note that no delay - -- is needed between retries; retrying C_Bind will typically produce - -- a different port. - - pragma Assert (Res = Failure - and then - Socket_Errno = SOSC.EADDRINUSE); - Res := C_Close (W_Sock); - W_Sock := Failure; - Res := C_Close (R_Sock); - R_Sock := Failure; - end loop; - - -- Since the call to connect(2) has succeeded and the backlog limit on - -- the listening socket is 1, we know that there is now exactly one - -- pending connection on L_Sock, which is the one from R_Sock. - - W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access); - - if W_Sock = Failure then - goto Fail; - end if; - - -- Set TCP_NODELAY on W_Sock, since we always want to send the data out - -- immediately. - - Set_Socket_Option - (Socket => Socket_Type (W_Sock), - Level => IP_Protocol_For_TCP_Level, - Option => (Name => No_Delay, Enabled => True)); - - -- Close listening socket (ignore exit status) - - Res := C_Close (L_Sock); - - Fds.all := (Read_End => R_Sock, Write_End => W_Sock); - - return Thin_Common.Success; - - <> - declare - Saved_Errno : constant Integer := Socket_Errno; - - begin - if W_Sock /= Failure then - Res := C_Close (W_Sock); - end if; - - if R_Sock /= Failure then - Res := C_Close (R_Sock); - end if; - - if L_Sock /= Failure then - Res := C_Close (L_Sock); - end if; - - Set_Socket_Errno (Saved_Errno); - end; - - return Failure; - end Create; - - ---------- - -- Read -- - ---------- - - function Read (Rsig : C.int) return C.int is - Buf : aliased Character; - begin - return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags); - end Read; - - ----------- - -- Write -- - ----------- - - function Write (Wsig : C.int) return C.int is - Buf : aliased Character := ASCII.NUL; - begin - return C_Sendto - (Wsig, Buf'Address, 1, - Flags => SOSC.MSG_Forced_Flags, - To => System.Null_Address, - Tolen => 0); - end Write; - -end Signalling_Fds; diff --git a/gcc/ada/g-table.adb b/gcc/ada/g-table.adb deleted file mode 100644 index ac33bc3..0000000 --- a/gcc/ada/g-table.adb +++ /dev/null @@ -1,205 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T A B L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; -with System.Memory; use System.Memory; - -package body GNAT.Table is - - -------------- - -- Allocate -- - -------------- - - procedure Allocate (Num : Integer := 1) is - begin - Tab.Allocate (The_Instance, Num); - end Allocate; - - function Allocate (Num : Integer := 1) return Valid_Table_Index_Type is - Result : constant Valid_Table_Index_Type := Last + 1; - begin - Allocate (Num); - return Result; - end Allocate; - - ------------ - -- Append -- - ------------ - - procedure Append (New_Val : Table_Component_Type) is - begin - Tab.Append (The_Instance, New_Val); - end Append; - - ---------------- - -- Append_All -- - ---------------- - - procedure Append_All (New_Vals : Table_Type) is - begin - Tab.Append_All (The_Instance, New_Vals); - end Append_All; - - -------------------- - -- Decrement_Last -- - -------------------- - - procedure Decrement_Last is - begin - Tab.Decrement_Last (The_Instance); - end Decrement_Last; - - ----------- - -- First -- - ----------- - - function First return Table_Index_Type is - begin - return Tab.First; - end First; - - -------------- - -- For_Each -- - -------------- - - procedure For_Each is - procedure For_Each is new Tab.For_Each (Action); - begin - For_Each (The_Instance); - end For_Each; - - ---------- - -- Free -- - ---------- - - procedure Free is - begin - Tab.Free (The_Instance); - end Free; - - -------------------- - -- Increment_Last -- - -------------------- - - procedure Increment_Last is - begin - Tab.Increment_Last (The_Instance); - end Increment_Last; - - -------------- - -- Is_Empty -- - -------------- - - function Is_Empty return Boolean is - begin - return Tab.Is_Empty (The_Instance); - end Is_Empty; - - ---------- - -- Init -- - ---------- - - procedure Init is - begin - Tab.Init (The_Instance); - end Init; - - ---------- - -- Last -- - ---------- - - function Last return Table_Last_Type is - begin - return Tab.Last (The_Instance); - end Last; - - ------------- - -- Release -- - ------------- - - procedure Release is - begin - Tab.Release (The_Instance); - end Release; - - ------------- - -- Restore -- - ------------- - - procedure Restore (T : in out Saved_Table) is - begin - Init; - Tab.Move (From => T, To => The_Instance); - end Restore; - - ---------- - -- Save -- - ---------- - - function Save return Saved_Table is - Result : Saved_Table; - begin - Tab.Move (From => The_Instance, To => Result); - return Result; - end Save; - - -------------- - -- Set_Item -- - -------------- - - procedure Set_Item - (Index : Valid_Table_Index_Type; - Item : Table_Component_Type) - is - begin - Tab.Set_Item (The_Instance, Index, Item); - end Set_Item; - - -------------- - -- Set_Last -- - -------------- - - procedure Set_Last (New_Val : Table_Last_Type) is - begin - Tab.Set_Last (The_Instance, New_Val); - end Set_Last; - - ---------------- - -- Sort_Table -- - ---------------- - - procedure Sort_Table is - procedure Sort_Table is new Tab.Sort_Table (Lt); - begin - Sort_Table (The_Instance); - end Sort_Table; - -end GNAT.Table; diff --git a/gcc/ada/g-table.ads b/gcc/ada/g-table.ads deleted file mode 100644 index ccda39b..0000000 --- a/gcc/ada/g-table.ads +++ /dev/null @@ -1,150 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T A B L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 singleton version of GNAT.Dynamic_Tables --- (g-dyntab.ads). See that package for documentation. This package just --- declares a single instance of GNAT.Dynamic_Tables.Instance, and provides --- wrappers for all the subprograms, passing that single instance. - --- Note that these three interfaces should remain synchronized to keep as much --- coherency as possible among these related units: --- --- GNAT.Dynamic_Tables --- GNAT.Table --- Table (the compiler unit) - -with GNAT.Dynamic_Tables; - -generic - type Table_Component_Type is private; - type Table_Index_Type is range <>; - - Table_Low_Bound : Table_Index_Type := Table_Index_Type'First; - Table_Initial : Positive := 8; - Table_Increment : Natural := 100; - Table_Name : String := ""; -- for debugging printouts - pragma Unreferenced (Table_Name); - Release_Threshold : Natural := 0; - -package GNAT.Table is - pragma Elaborate_Body; - - package Tab is new GNAT.Dynamic_Tables - (Table_Component_Type, - Table_Index_Type, - Table_Low_Bound, - Table_Initial, - Table_Increment, - Release_Threshold); - - subtype Valid_Table_Index_Type is Tab.Valid_Table_Index_Type; - subtype Table_Last_Type is Tab.Table_Last_Type; - subtype Table_Type is Tab.Table_Type; - function "=" (X, Y : Table_Type) return Boolean renames Tab."="; - - subtype Table_Ptr is Tab.Table_Ptr; - - The_Instance : Tab.Instance; - Table : Table_Ptr renames The_Instance.Table; - Locked : Boolean renames The_Instance.Locked; - - function Is_Empty return Boolean; - - procedure Init; - pragma Inline (Init); - procedure Free; - pragma Inline (Free); - - function First return Table_Index_Type; - pragma Inline (First); - - function Last return Table_Last_Type; - pragma Inline (Last); - - procedure Release; - pragma Inline (Release); - - procedure Set_Last (New_Val : Table_Last_Type); - pragma Inline (Set_Last); - - procedure Increment_Last; - pragma Inline (Increment_Last); - - procedure Decrement_Last; - pragma Inline (Decrement_Last); - - procedure Append (New_Val : Table_Component_Type); - pragma Inline (Append); - - procedure Append_All (New_Vals : Table_Type); - pragma Inline (Append_All); - - procedure Set_Item - (Index : Valid_Table_Index_Type; - Item : Table_Component_Type); - pragma Inline (Set_Item); - - subtype Saved_Table is Tab.Instance; - -- Type used for Save/Restore subprograms - - function Save return Saved_Table; - pragma Inline (Save); - -- Resets table to empty, but saves old contents of table in returned - -- value, for possible later restoration by a call to Restore. - - procedure Restore (T : in out Saved_Table); - pragma Inline (Restore); - -- Given a Saved_Table value returned by a prior call to Save, restores - -- the table to the state it was in at the time of the Save call. - - procedure Allocate (Num : Integer := 1); - function Allocate (Num : Integer := 1) return Valid_Table_Index_Type; - pragma Inline (Allocate); - -- Adds Num to Last. The function version also returns the old value of - -- Last + 1. Note that this function has the possible side effect of - -- reallocating the table. This means that a reference X.Table (X.Allocate) - -- is incorrect, since the call to X.Allocate may modify the results of - -- calling X.Table. - - generic - with procedure Action - (Index : Valid_Table_Index_Type; - Item : Table_Component_Type; - Quit : in out Boolean) is <>; - procedure For_Each; - pragma Inline (For_Each); - - generic - with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; - procedure Sort_Table; - pragma Inline (Sort_Table); - -end GNAT.Table; diff --git a/gcc/ada/g-tasloc.adb b/gcc/ada/g-tasloc.adb deleted file mode 100644 index 3df8b7f..0000000 --- a/gcc/ada/g-tasloc.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T A S K _ L O C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-tasloc.ads b/gcc/ada/g-tasloc.ads deleted file mode 100644 index 4bb8227..0000000 --- a/gcc/ada/g-tasloc.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T A S K _ L O C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Simple task lock and unlock routines - --- A small package containing a task lock and unlock routines for creating --- a critical region. The lock involved is a global lock, shared by all --- tasks, and by all calls to these routines, so these routines should be --- used with care to avoid unnecessary reduction of concurrency. - --- These routines may be used in a non-tasking program, and in that case --- they have no effect (they do NOT cause the tasking runtime to be loaded). - --- See file s-tasloc.ads for full documentation of the interface - -with System.Task_Lock; - -package GNAT.Task_Lock renames System.Task_Lock; diff --git a/gcc/ada/g-timsta.adb b/gcc/ada/g-timsta.adb deleted file mode 100644 index 50d4f70..0000000 --- a/gcc/ada/g-timsta.adb +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T I M E _ S T A M P -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C; use Interfaces.C; - -package body GNAT.Time_Stamp is - - subtype time_stamp is char_array (0 .. 22); - type time_stamp_ptr is access all time_stamp; - -- The desired ISO 8601 string format has exactly 22 characters. We add - -- one additional character for '\0'. The indexing starts from zero to - -- accommodate the C layout. - - procedure gnat_current_time_string (Value : time_stamp_ptr); - pragma Import (C, gnat_current_time_string, "__gnat_current_time_string"); - - ------------------ - -- Current_Time -- - ------------------ - - function Current_Time return String is - Result : aliased time_stamp; - - begin - gnat_current_time_string (Result'Unchecked_Access); - Result (22) := nul; - - return To_Ada (Result); - end Current_Time; - -end GNAT.Time_Stamp; diff --git a/gcc/ada/g-timsta.ads b/gcc/ada/g-timsta.ads deleted file mode 100644 index 8f35e7b..0000000 --- a/gcc/ada/g-timsta.ads +++ /dev/null @@ -1,40 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T I M E _ S T A M P -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 lightweight mechanism for obtaining time stamps - -package GNAT.Time_Stamp is - - function Current_Time return String; - -- Return the current local time in the following ISO 8601 string format: - -- YYYY-MM-DD HH:MM:SS.SS - -end GNAT.Time_Stamp; diff --git a/gcc/ada/g-traceb.adb b/gcc/ada/g-traceb.adb deleted file mode 100644 index 157d8b6..0000000 --- a/gcc/ada/g-traceb.adb +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time non-symbolic traceback support - -with System.Traceback; - -package body GNAT.Traceback is - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain - (Traceback : out Tracebacks_Array; - Len : out Natural) - is - begin - System.Traceback.Call_Chain (Traceback, Traceback'Length, Len); - end Call_Chain; - -end GNAT.Traceback; diff --git a/gcc/ada/g-traceb.ads b/gcc/ada/g-traceb.ads deleted file mode 100644 index e71a055..0000000 --- a/gcc/ada/g-traceb.ads +++ /dev/null @@ -1,101 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . T R A C E B A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time non-symbolic traceback support - --- This package provides a method for generating a traceback of the --- current execution location. The traceback shows the locations of --- calls in the call chain, up to either the top or a designated --- number of levels. - --- The traceback information is in the form of absolute code locations. --- These code locations may be converted to corresponding source locations --- using the external addr2line utility, or from within GDB. - --- In order to use this facility, in some cases the binder must be invoked --- with -E switch (store the backtrace with exception occurrence). Please --- refer to gnatbind documentation for more information. - --- To analyze the code locations later using addr2line or gdb, the necessary --- units must be compiled with the debugging switch -g in the usual manner. --- Note that it is not necessary to compile with -g to use Call_Chain. In --- other words, the following sequence of steps can be used: - --- Compile without -g --- Run the program, and call Call_Chain --- Recompile with -g --- Use addr2line to interpret the absolute call locations (note that --- addr2line expects addresses in hexadecimal format). - --- This capability is currently supported on the following targets: - --- AiX PowerPC --- GNU/Linux x86 --- GNU/Linux PowerPC --- LynxOS x86 --- LynxOS 178 xcoff PowerPC --- LynxOS 178 elf PowerPC --- Solaris x86 --- Solaris sparc --- VxWorks ARM --- VxWorks7 ARM --- VxWorks PowerPC --- VxWorks x86 --- Windows XP - --- Note: see also GNAT.Traceback.Symbolic, a child unit in file g-trasym.ads --- providing symbolic trace back capability for a subset of the above targets. - -with System; -with Ada.Exceptions.Traceback; - -package GNAT.Traceback is - pragma Elaborate_Body; - - subtype Code_Loc is System.Address; - -- Code location used in building tracebacks - - subtype Tracebacks_Array is Ada.Exceptions.Traceback.Tracebacks_Array; - -- Traceback array used to hold a generated traceback list - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain (Traceback : out Tracebacks_Array; Len : out Natural); - -- Store up to Traceback'Length tracebacks corresponding to the current - -- call chain. The first entry stored corresponds to the deepest level - -- of subprogram calls. Len shows the number of traceback entries stored. - -- It will be equal to Traceback'Length unless the entire traceback is - -- shorter, in which case positions in Traceback past the Len position - -- are undefined on return. - -end GNAT.Traceback; diff --git a/gcc/ada/g-trasym.adb b/gcc/ada/g-trasym.adb deleted file mode 100644 index 3fdfd1ad..0000000 --- a/gcc/ada/g-trasym.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-trasym.ads b/gcc/ada/g-trasym.ads deleted file mode 100644 index 1d9b3f7..0000000 --- a/gcc/ada/g-trasym.ads +++ /dev/null @@ -1,37 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support - --- See file s-trasym.ads for full documentation of the interface - -with System.Traceback.Symbolic; -package GNAT.Traceback.Symbolic renames System.Traceback.Symbolic; diff --git a/gcc/ada/g-tty.adb b/gcc/ada/g-tty.adb deleted file mode 100644 index 43c1bea..0000000 --- a/gcc/ada/g-tty.adb +++ /dev/null @@ -1,134 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . T T Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2011, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C.Strings; use Interfaces.C.Strings; - -package body GNAT.TTY is - - use System; - - procedure Check_TTY (Handle : TTY_Handle); - -- Check the validity of Handle. Raise Program_Error if ttys are not - -- supported. Raise Constraint_Error if Handle is an invalid handle. - - ------------------ - -- Allocate_TTY -- - ------------------ - - procedure Allocate_TTY (Handle : out TTY_Handle) is - function Internal return System.Address; - pragma Import (C, Internal, "__gnat_new_tty"); - - begin - if not TTY_Supported then - raise Program_Error; - end if; - - Handle.Handle := Internal; - end Allocate_TTY; - - --------------- - -- Check_TTY -- - --------------- - - procedure Check_TTY (Handle : TTY_Handle) is - begin - if not TTY_Supported then - raise Program_Error; - elsif Handle.Handle = System.Null_Address then - raise Constraint_Error; - end if; - end Check_TTY; - - --------------- - -- Close_TTY -- - --------------- - - procedure Close_TTY (Handle : in out TTY_Handle) is - procedure Internal (Handle : System.Address); - pragma Import (C, Internal, "__gnat_close_tty"); - begin - Check_TTY (Handle); - Internal (Handle.Handle); - Handle.Handle := System.Null_Address; - end Close_TTY; - - --------------- - -- Reset_TTY -- - --------------- - - procedure Reset_TTY (Handle : TTY_Handle) is - procedure Internal (Handle : System.Address); - pragma Import (C, Internal, "__gnat_reset_tty"); - begin - Check_TTY (Handle); - Internal (Handle.Handle); - end Reset_TTY; - - -------------------- - -- TTY_Descriptor -- - -------------------- - - function TTY_Descriptor - (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor - is - function Internal - (Handle : System.Address) return GNAT.OS_Lib.File_Descriptor; - pragma Import (C, Internal, "__gnat_tty_fd"); - begin - Check_TTY (Handle); - return Internal (Handle.Handle); - end TTY_Descriptor; - - -------------- - -- TTY_Name -- - -------------- - - function TTY_Name (Handle : TTY_Handle) return String is - function Internal (Handle : System.Address) return chars_ptr; - pragma Import (C, Internal, "__gnat_tty_name"); - begin - Check_TTY (Handle); - return Value (Internal (Handle.Handle)); - end TTY_Name; - - ------------------- - -- TTY_Supported -- - ------------------- - - function TTY_Supported return Boolean is - function Internal return Integer; - pragma Import (C, Internal, "__gnat_tty_supported"); - begin - return Internal /= 0; - end TTY_Supported; - -end GNAT.TTY; diff --git a/gcc/ada/g-tty.ads b/gcc/ada/g-tty.ads deleted file mode 100644 index 12aaba7..0000000 --- a/gcc/ada/g-tty.ads +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . T T Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2011, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides control over pseudo terminals (ttys) - --- This package is only supported on unix systems. See function TTY_Supported --- to test dynamically whether other functions of this package can be called. - -with System; - -with GNAT.OS_Lib; - -package GNAT.TTY is - - type TTY_Handle is private; - -- Handle for a tty descriptor - - function TTY_Supported return Boolean; - -- If True, the other functions of this package can be called. Otherwise, - -- all functions in this package will raise Program_Error if called. - - procedure Allocate_TTY (Handle : out TTY_Handle); - -- Allocate a new tty - - procedure Reset_TTY (Handle : TTY_Handle); - -- Reset settings of a given tty - - procedure Close_TTY (Handle : in out TTY_Handle); - -- Close a given tty - - function TTY_Name (Handle : TTY_Handle) return String; - -- Return the external name of a tty. The name depends on the tty handling - -- on the given target. It will typically look like: "/dev/ptya1" - - function TTY_Descriptor - (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor; - -- Return the low level descriptor associated with Handle - -private - - type TTY_Handle is record - Handle : System.Address := System.Null_Address; - end record; - -end GNAT.TTY; diff --git a/gcc/ada/g-u3spch.adb b/gcc/ada/g-u3spch.adb deleted file mode 100644 index b6c2a56..0000000 --- a/gcc/ada/g-u3spch.adb +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . U T F _ 3 2 _ S P E L L I N G _ C H E C K E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with GNAT.Spelling_Checker_Generic; - -package body GNAT.UTF_32_Spelling_Checker is - - function IBS is new - GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of - (System.WCh_Cnv.UTF_32_Code, System.WCh_Cnv.UTF_32_String); - - ------------------------ - -- Is_Bad_Spelling_Of -- - ------------------------ - - function Is_Bad_Spelling_Of - (Found : System.WCh_Cnv.UTF_32_String; - Expect : System.WCh_Cnv.UTF_32_String) return Boolean - renames IBS; - -end GNAT.UTF_32_Spelling_Checker; diff --git a/gcc/ada/g-u3spch.ads b/gcc/ada/g-u3spch.ads deleted file mode 100644 index 190eabe..0000000 --- a/gcc/ada/g-u3spch.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . U T F _ 3 2 _ S P E L L I N G _ C H E C K E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Spelling checker - --- This package provides a utility routine for checking for bad spellings --- for the case of System.WCh_Cnv.UTF_32_String arguments. - -pragma Compiler_Unit_Warning; - -with System.WCh_Cnv; - -package GNAT.UTF_32_Spelling_Checker is - pragma Pure; - - function Is_Bad_Spelling_Of - (Found : System.WCh_Cnv.UTF_32_String; - Expect : System.WCh_Cnv.UTF_32_String) return Boolean; - -- Determines if the string Found is a plausible misspelling of the string - -- Expect. Returns True for an exact match or a probably misspelling, False - -- if no near match is detected. This routine is case sensitive, so the - -- caller should fold both strings to get a case insensitive match. - -- - -- Note: the spec of this routine is deliberately rather vague. It is used - -- by GNAT itself to detect misspelled keywords and identifiers, and is - -- heuristically adjusted to be appropriate to this usage. It will work - -- well in any similar case of named entities. - -end GNAT.UTF_32_Spelling_Checker; diff --git a/gcc/ada/g-utf_32.adb b/gcc/ada/g-utf_32.adb deleted file mode 100644 index 3f566f1..0000000 --- a/gcc/ada/g-utf_32.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . U T F _ 3 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/g-utf_32.ads b/gcc/ada/g-utf_32.ads deleted file mode 100644 index 062cea4..0000000 --- a/gcc/ada/g-utf_32.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . U T F _ 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is an internal package that provides basic character --- classification capabilities needed by the compiler for handling full --- 32-bit wide wide characters. We avoid the use of the actual type --- Wide_Wide_Character, since we want to use these routines in the compiler --- itself, and we want to be able to compile the compiler with old versions --- of GNAT that did not implement Wide_Wide_Character. - --- This package is available directly for use in application programs, --- and also serves as the basis for Ada.Wide_Wide_Characters.Unicode and --- Ada.Wide_Characters.Unicode, which can also be used directly. - --- See file s-utf_32.ads for full documentation of the interface - -with System.UTF_32; - -package GNAT.UTF_32 renames System.UTF_32; diff --git a/gcc/ada/g-wispch.adb b/gcc/ada/g-wispch.adb deleted file mode 100644 index 1f7614f..0000000 --- a/gcc/ada/g-wispch.adb +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . W I D E _ S P E L L I N G _ C H E C K E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.Spelling_Checker_Generic; - -package body GNAT.Wide_Spelling_Checker is - - function IBS is new - GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of - (Wide_Character, Wide_String); - - ------------------------ - -- Is_Bad_Spelling_Of -- - ------------------------ - - function Is_Bad_Spelling_Of - (Found : Wide_String; - Expect : Wide_String) return Boolean - renames IBS; - -end GNAT.Wide_Spelling_Checker; diff --git a/gcc/ada/g-wispch.ads b/gcc/ada/g-wispch.ads deleted file mode 100644 index 2dd36da..0000000 --- a/gcc/ada/g-wispch.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . W I D E _ S P E L L I N G _ C H E C K E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Spelling checker - --- This package provides a utility routine for checking for bad spellings --- for the case of Wide_String arguments. - -package GNAT.Wide_Spelling_Checker is - pragma Pure; - - function Is_Bad_Spelling_Of - (Found : Wide_String; - Expect : Wide_String) return Boolean; - -- Determines if the string Found is a plausible misspelling of the string - -- Expect. Returns True for an exact match or a probably misspelling, False - -- if no near match is detected. This routine is case sensitive, so the - -- caller should fold both strings to get a case insensitive match. - -- - -- Note: the spec of this routine is deliberately rather vague. It is used - -- by GNAT itself to detect misspelled keywords and identifiers, and is - -- heuristically adjusted to be appropriate to this usage. It will work - -- well in any similar case of named entities. - -end GNAT.Wide_Spelling_Checker; diff --git a/gcc/ada/g-wistsp.ads b/gcc/ada/g-wistsp.ads deleted file mode 100644 index 39f19a6..0000000 --- a/gcc/ada/g-wistsp.ads +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . W I D E _ S T R I N G _ S P L I T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Useful wide_string-manipulation routines: given a set of separators, split --- a wide_string wherever the separators appear, and provide direct access --- to the resulting slices. See GNAT.Array_Split for full documentation. - -with Ada.Strings.Wide_Maps; use Ada.Strings; -with GNAT.Array_Split; - -package GNAT.Wide_String_Split is new GNAT.Array_Split - (Element => Wide_Character, - Element_Sequence => Wide_String, - Element_Set => Wide_Maps.Wide_Character_Set, - To_Set => Wide_Maps.To_Set, - Is_In => Wide_Maps.Is_In); diff --git a/gcc/ada/g-zspche.adb b/gcc/ada/g-zspche.adb deleted file mode 100644 index 6312795..0000000 --- a/gcc/ada/g-zspche.adb +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . W I D E _W I D E _ S P E L L I N G _ C H E C K E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with GNAT.Spelling_Checker_Generic; - -package body GNAT.Wide_Wide_Spelling_Checker is - - function IBS is new - GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of - (Wide_Wide_Character, Wide_Wide_String); - - ------------------------ - -- Is_Bad_Spelling_Of -- - ------------------------ - - function Is_Bad_Spelling_Of - (Found : Wide_Wide_String; - Expect : Wide_Wide_String) return Boolean - renames IBS; - -end GNAT.Wide_Wide_Spelling_Checker; diff --git a/gcc/ada/g-zspche.ads b/gcc/ada/g-zspche.ads deleted file mode 100644 index af5bf2d..0000000 --- a/gcc/ada/g-zspche.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- G N A T . W I D E _ W I D E _ S P E L L I N G _ C H E C K E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Spelling checker - --- This package provides a utility routine for checking for bad spellings --- for the case of Wide_Wide_String arguments. - -package GNAT.Wide_Wide_Spelling_Checker is - pragma Pure; - - function Is_Bad_Spelling_Of - (Found : Wide_Wide_String; - Expect : Wide_Wide_String) return Boolean; - -- Determines if the string Found is a plausible misspelling of the string - -- Expect. Returns True for an exact match or a probably misspelling, False - -- if no near match is detected. This routine is case sensitive, so the - -- caller should fold both strings to get a case insensitive match. - -- - -- Note: the spec of this routine is deliberately rather vague. It is used - -- by GNAT itself to detect misspelled keywords and identifiers, and is - -- heuristically adjusted to be appropriate to this usage. It will work - -- well in any similar case of named entities. - -end GNAT.Wide_Wide_Spelling_Checker; diff --git a/gcc/ada/g-zstspl.ads b/gcc/ada/g-zstspl.ads deleted file mode 100644 index de87324..0000000 --- a/gcc/ada/g-zstspl.ads +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- G N A T . W I D E _ W I D E _ S T R I N G _ S P L I T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Useful wide_string-manipulation routines: given a set of separators, split --- a wide_string wherever the separators appear, and provide direct access --- to the resulting slices. See GNAT.Array_Split for full documentation. - -with Ada.Strings.Wide_Wide_Maps; use Ada.Strings; -with GNAT.Array_Split; - -package GNAT.Wide_Wide_String_Split is new GNAT.Array_Split - (Element => Wide_Wide_Character, - Element_Sequence => Wide_Wide_String, - Element_Set => Wide_Wide_Maps.Wide_Wide_Character_Set, - To_Set => Wide_Wide_Maps.To_Set, - Is_In => Wide_Wide_Maps.Is_In); diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index e38a1f9..b9d06b0 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -68,7 +68,7 @@ ALL_ADAFLAGS = \ $(CFLAGS) $(ADA_CFLAGS) $(ADAFLAGS) $(CHECKING_ADAFLAGS) $(WARN_ADAFLAGS) FORCE_DEBUG_ADAFLAGS = -g ADA_CFLAGS = -ADA_INCLUDES = -nostdinc -I- -I. -Iada/generated -Iada -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface +ADA_INCLUDES = -nostdinc -I- -I. -Iada/generated -Iada -I$(srcdir)/ada -I$(srcdir)/ada/gcc-interface -Iada/libgnat -I$(srcdir)/ada/libgnat GNATLIBFLAGS= -W -Wall -gnatpg -nostdinc GNATLIBCFLAGS= -g -O2 $(TCFLAGS) ADA_INCLUDE_DIR = $(libsubdir)/adainclude @@ -104,23 +104,41 @@ ada/%.o: ada/gcc-interface/%.c $(COMPILE) $< $(POSTCOMPILE) -# Function that dumps the dependencies of an Ada object file by parsing the -# associated ALI file. We match the lines starting with D to achieve that. -ADA_DEPS=case $@ in \ - *sdefault.o);; \ - *)a="`echo $@ | sed -e 's/.o$$/.ali/'`"; \ - echo "$@: `cat $$a | \ - sed -ne 's;^D \([a-z0-9_\.-]*\).*;ada/\1;gp' | \ - sed -e 's;ada/gnatvsn.ads;ada/generated/gnatvsn.ads;g' | \ - tr -d '\015' | tr '\n' ' '`" > $(dir $@)/$(DEPDIR)/$(patsubst %.o,%.Po,$(notdir $@));; \ - esac; +# Function that dumps the dependencies of an Ada object. Dependency only work +# fully if the compiler support -gnatd.n. Otherwise a fallback mechanism is +# used. The fallback mechanism add dependency on all ada sources in the same +# directory as the original source. +ifeq ($(findstring -gnatd.n,$(ALL_ADAFLAGS)),) +ADA_DEPS=\ + mkdir -p $(dir $@)/$(DEPDIR); \ + (o="$@: $<"; \ + for d in $(dir $<)/*.ad[sb]; do \ + o="$$o $$d"; \ + done; \ + echo "$$o"; echo) \ + >$(dir $@)/$(DEPDIR)/$(patsubst %.o,%.Po,$(notdir $@)) +ADA_OUTPUT_OPTION = $(OUTPUT_OPTION) +else +ADA_DEPS=\ + mkdir -p $(dir $@)/$(DEPDIR); \ + (o="$@: $<"; \ + for d in `cat $@.gnatd.n`; do \ + o="$$o $$d"; \ + done; \ + echo "$$o"; echo) \ + >$(dir $@)/$(DEPDIR)/$(patsubst %.o,%.Po,$(notdir $@)) +ADA_OUTPUT_OPTION = $(OUTPUT_OPTION) > $@.gnatd.n +endif + .adb.o: - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + mkdir -p $(dir $@) + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) .ads.o: - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + mkdir -p $(dir $@) + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) # Define the names for selecting Ada in LANGUAGES. @@ -229,13 +247,13 @@ GNAT1_C_OBJS = ada/adadecode.o ada/adaint.o ada/argv.o ada/cio.o \ # Object files from Ada sources that are used by gnat1 GNAT_ADA_OBJS = \ - ada/a-charac.o \ - ada/a-chlat1.o \ - ada/a-elchha.o \ - ada/a-except.o \ - ada/a-exctra.o \ - ada/a-ioexce.o \ - ada/ada.o \ + ada/libgnat/a-charac.o \ + ada/libgnat/a-chlat1.o \ + ada/libgnat/a-elchha.o \ + ada/libgnat/a-except.o \ + ada/libgnat/a-exctra.o \ + ada/libgnat/a-ioexce.o \ + ada/libgnat/ada.o \ ada/spark_xrefs.o \ ada/ali.o \ ada/alloc.o \ @@ -293,21 +311,21 @@ GNAT_ADA_OBJS = \ ada/fname.o \ ada/freeze.o \ ada/frontend.o \ - ada/g-byorma.o \ - ada/g-hesora.o \ - ada/g-htable.o \ - ada/g-spchge.o \ - ada/g-speche.o \ - ada/g-u3spch.o \ + ada/libgnat/g-byorma.o \ + ada/libgnat/g-hesora.o \ + ada/libgnat/g-htable.o \ + ada/libgnat/g-spchge.o \ + ada/libgnat/g-speche.o \ + ada/libgnat/g-u3spch.o \ ada/get_spark_xrefs.o \ ada/get_targ.o \ ada/ghost.o \ - ada/gnat.o \ + ada/libgnat/gnat.o \ ada/gnatvsn.o \ ada/hostparm.o \ ada/impunit.o \ ada/inline.o \ - ada/interfac.o \ + ada/libgnat/interfac.o \ ada/itypes.o \ ada/krunch.o \ ada/layout.o \ @@ -335,60 +353,60 @@ GNAT_ADA_OBJS = \ ada/restrict.o \ ada/rident.o \ ada/rtsfind.o \ - ada/s-addope.o \ - ada/s-addima.o \ - ada/s-assert.o \ - ada/s-bitops.o \ - ada/s-carun8.o \ - ada/s-casuti.o \ - ada/s-conca2.o \ - ada/s-conca3.o \ - ada/s-conca4.o \ - ada/s-conca5.o \ - ada/s-conca6.o \ - ada/s-conca7.o \ - ada/s-conca8.o \ - ada/s-conca9.o \ - ada/s-crc32.o \ - ada/s-crtl.o \ - ada/s-excdeb.o \ - ada/s-except.o \ - ada/s-exctab.o \ - ada/s-excmac.o \ - ada/s-htable.o \ - ada/s-imenne.o \ - ada/s-imgenu.o \ - ada/s-imgint.o \ - ada/s-mastop.o \ - ada/s-memory.o \ - ada/s-os_lib.o \ - ada/s-parame.o \ - ada/s-purexc.o \ - ada/s-restri.o \ - ada/s-secsta.o \ - ada/s-soflin.o \ - ada/s-sopco3.o \ - ada/s-sopco4.o \ - ada/s-sopco5.o \ - ada/s-stache.o \ - ada/s-stalib.o \ - ada/s-stoele.o \ - ada/s-strcom.o \ - ada/s-strhas.o \ - ada/s-string.o \ - ada/s-strops.o \ - ada/s-traceb.o \ - ada/s-traent.o \ - ada/s-trasym.o \ - ada/s-unstyp.o \ - ada/s-utf_32.o \ - ada/s-valint.o \ - ada/s-valuns.o \ - ada/s-valuti.o \ - ada/s-wchcnv.o \ - ada/s-wchcon.o \ - ada/s-wchjis.o \ - ada/s-wchstw.o \ + ada/libgnat/s-addope.o \ + ada/libgnat/s-addima.o \ + ada/libgnat/s-assert.o \ + ada/libgnat/s-bitops.o \ + ada/libgnat/s-carun8.o \ + ada/libgnat/s-casuti.o \ + ada/libgnat/s-conca2.o \ + ada/libgnat/s-conca3.o \ + ada/libgnat/s-conca4.o \ + ada/libgnat/s-conca5.o \ + ada/libgnat/s-conca6.o \ + ada/libgnat/s-conca7.o \ + ada/libgnat/s-conca8.o \ + ada/libgnat/s-conca9.o \ + ada/libgnat/s-crc32.o \ + ada/libgnat/s-crtl.o \ + ada/libgnat/s-excdeb.o \ + ada/libgnat/s-except.o \ + ada/libgnat/s-exctab.o \ + ada/libgnat/s-excmac.o \ + ada/libgnat/s-htable.o \ + ada/libgnat/s-imenne.o \ + ada/libgnat/s-imgenu.o \ + ada/libgnat/s-imgint.o \ + ada/libgnat/s-mastop.o \ + ada/libgnat/s-memory.o \ + ada/libgnat/s-os_lib.o \ + ada/libgnat/s-parame.o \ + ada/libgnat/s-purexc.o \ + ada/libgnat/s-restri.o \ + ada/libgnat/s-secsta.o \ + ada/libgnat/s-soflin.o \ + ada/libgnat/s-sopco3.o \ + ada/libgnat/s-sopco4.o \ + ada/libgnat/s-sopco5.o \ + ada/libgnat/s-stache.o \ + ada/libgnat/s-stalib.o \ + ada/libgnat/s-stoele.o \ + ada/libgnat/s-strcom.o \ + ada/libgnat/s-strhas.o \ + ada/libgnat/s-string.o \ + ada/libgnat/s-strops.o \ + ada/libgnat/s-traceb.o \ + ada/libgnat/s-traent.o \ + ada/libgnat/s-trasym.o \ + ada/libgnat/s-unstyp.o \ + ada/libgnat/s-utf_32.o \ + ada/libgnat/s-valint.o \ + ada/libgnat/s-valuns.o \ + ada/libgnat/s-valuti.o \ + ada/libgnat/s-wchcnv.o \ + ada/libgnat/s-wchcon.o \ + ada/libgnat/s-wchjis.o \ + ada/libgnat/s-wchstw.o \ ada/scans.o \ ada/scil_ll.o \ ada/scn.o \ @@ -443,7 +461,7 @@ GNAT_ADA_OBJS = \ ada/stylesw.o \ ada/switch-c.o \ ada/switch.o \ - ada/system.o \ + ada/libgnat/system.o \ ada/table.o \ ada/targparm.o \ ada/tbuild.o \ @@ -468,9 +486,9 @@ GNAT1_ADA_OBJS = $(GNAT_ADA_OBJS) ada/back_end.o ada/gnat1drv.o GNAT1_OBJS = $(GNAT1_C_OBJS) $(GNAT1_ADA_OBJS) ada/b_gnat1.o GNATBIND_OBJS = \ - ada/a-elchha.o \ - ada/a-except.o \ - ada/ada.o \ + ada/libgnat/a-elchha.o \ + ada/libgnat/a-except.o \ + ada/libgnat/ada.o \ ada/adaint.o \ ada/ali-util.o \ ada/ali.o \ @@ -500,16 +518,16 @@ GNATBIND_OBJS = \ ada/fmap.o \ ada/fname-uf.o \ ada/fname.o \ - ada/g-byorma.o \ - ada/g-hesora.o \ - ada/g-htable.o \ - ada/gnat.o \ + ada/libgnat/g-byorma.o \ + ada/libgnat/g-hesora.o \ + ada/libgnat/g-htable.o \ + ada/libgnat/gnat.o \ ada/gnatbind.o \ ada/gnatvsn.o \ ada/hostparm.o \ ada/init.o \ ada/initialize.o \ - ada/interfac.o \ + ada/libgnat/interfac.o \ ada/krunch.o \ ada/lib.o \ ada/link.o \ @@ -525,53 +543,53 @@ GNATBIND_OBJS = \ ada/rident.o \ ada/rtfinal.o \ ada/rtinit.o \ - ada/s-addope.o \ - ada/s-assert.o \ - ada/s-carun8.o \ - ada/s-casuti.o \ - ada/s-conca2.o \ - ada/s-conca3.o \ - ada/s-conca4.o \ - ada/s-conca5.o \ - ada/s-conca6.o \ - ada/s-conca7.o \ - ada/s-conca8.o \ - ada/s-conca9.o \ - ada/s-crc32.o \ - ada/s-crtl.o \ - ada/s-excdeb.o \ - ada/s-except.o \ - ada/s-excmac.o \ - ada/s-exctab.o \ - ada/s-htable.o \ - ada/s-imenne.o \ - ada/s-imgenu.o \ - ada/s-imgint.o \ - ada/s-mastop.o \ - ada/s-memory.o \ - ada/s-os_lib.o \ - ada/s-parame.o \ - ada/s-resfil.o \ - ada/s-restri.o \ - ada/s-secsta.o \ - ada/s-soflin.o \ - ada/s-sopco3.o \ - ada/s-sopco4.o \ - ada/s-sopco5.o \ - ada/s-stache.o \ - ada/s-stalib.o \ - ada/s-stoele.o \ - ada/s-strhas.o \ - ada/s-string.o \ - ada/s-strops.o \ - ada/s-traent.o \ - ada/s-traceb.o \ - ada/s-unstyp.o \ - ada/s-utf_32.o \ - ada/s-wchcnv.o \ - ada/s-wchcon.o \ - ada/s-wchjis.o \ - ada/s-wchstw.o \ + ada/libgnat/s-addope.o \ + ada/libgnat/s-assert.o \ + ada/libgnat/s-carun8.o \ + ada/libgnat/s-casuti.o \ + ada/libgnat/s-conca2.o \ + ada/libgnat/s-conca3.o \ + ada/libgnat/s-conca4.o \ + ada/libgnat/s-conca5.o \ + ada/libgnat/s-conca6.o \ + ada/libgnat/s-conca7.o \ + ada/libgnat/s-conca8.o \ + ada/libgnat/s-conca9.o \ + ada/libgnat/s-crc32.o \ + ada/libgnat/s-crtl.o \ + ada/libgnat/s-excdeb.o \ + ada/libgnat/s-except.o \ + ada/libgnat/s-excmac.o \ + ada/libgnat/s-exctab.o \ + ada/libgnat/s-htable.o \ + ada/libgnat/s-imenne.o \ + ada/libgnat/s-imgenu.o \ + ada/libgnat/s-imgint.o \ + ada/libgnat/s-mastop.o \ + ada/libgnat/s-memory.o \ + ada/libgnat/s-os_lib.o \ + ada/libgnat/s-parame.o \ + ada/libgnat/s-resfil.o \ + ada/libgnat/s-restri.o \ + ada/libgnat/s-secsta.o \ + ada/libgnat/s-soflin.o \ + ada/libgnat/s-sopco3.o \ + ada/libgnat/s-sopco4.o \ + ada/libgnat/s-sopco5.o \ + ada/libgnat/s-stache.o \ + ada/libgnat/s-stalib.o \ + ada/libgnat/s-stoele.o \ + ada/libgnat/s-strhas.o \ + ada/libgnat/s-string.o \ + ada/libgnat/s-strops.o \ + ada/libgnat/s-traent.o \ + ada/libgnat/s-traceb.o \ + ada/libgnat/s-unstyp.o \ + ada/libgnat/s-utf_32.o \ + ada/libgnat/s-wchcnv.o \ + ada/libgnat/s-wchcon.o \ + ada/libgnat/s-wchjis.o \ + ada/libgnat/s-wchstw.o \ ada/scans.o \ ada/scil_ll.o \ ada/scng.o \ @@ -589,7 +607,7 @@ GNATBIND_OBJS = \ ada/stylesw.o \ ada/switch-b.o \ ada/switch.o \ - ada/system.o \ + ada/libgnat/system.o \ ada/table.o \ ada/targext.o \ ada/targparm.o \ @@ -616,12 +634,14 @@ endif # For unwind-pe.h CFLAGS-ada/raise-gcc.o += -I$(srcdir)/../libgcc -DEH_MECHANISM_$(EH_MECHANISM) -ada/s-excmac.o: ada/s-excmac.ads ada/s-excmac.adb +ada/libgnat/s-excmac.o: ada/libgnat/s-excmac.ads ada/libgnat/s-excmac.adb -ada/s-excmac.ads: $(srcdir)/ada/s-excmac-$(EH_MECHANISM).ads +ada/libgnat/s-excmac.ads: $(srcdir)/ada/libgnat/s-excmac-$(EH_MECHANISM).ads + mkdir -p ada/libgnat $(CP) $< $@ -ada/s-excmac.adb: $(srcdir)/ada/s-excmac-$(EH_MECHANISM).adb +ada/libgnat/s-excmac.adb: $(srcdir)/ada/libgnat/s-excmac-$(EH_MECHANISM).adb + mkdir -p ada/libgnat $(CP) $< $@ # Needs to be built with CC=gcc @@ -977,16 +997,16 @@ ada/b_gnat1.o : ada/b_gnat1.adb # Do not use ADAFLAGS to get rid of -gnatg which generates a lot # of style messages. $(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $< $(ADA_OUTPUT_OPTION) -ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o ada/interfac.o +ada/b_gnatb.adb : $(GNATBIND_OBJS) ada/gnatbind.o ada/libgnat/interfac.o # Old gnatbind do not allow a path for -o. $(GNATBIND) $(ADA_INCLUDES) -o b_gnatb.adb ada/gnatbind.ali $(MV) b_gnatb.adb b_gnatb.ads ada/ ada/b_gnatb.o : ada/b_gnatb.adb $(CC) -c $(CFLAGS) $(ADA_CFLAGS) -gnatp -gnatws $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $< $(ADA_OUTPUT_OPTION) include $(srcdir)/ada/Make-generated.in @@ -995,35 +1015,35 @@ update-sources : ada/treeprs.ads ada/einfo.h ada/sinfo.h ada/nmake.adb \ $(RM) $(addprefix $(srcdir)/ada/,$(notdir $^)) $(CP) $^ $(srcdir)/ada -ada/sdefault.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \ - ada/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads ada/namet.ads \ +ada/sdefault.o : ada/libgnat/ada.ads ada/libgnat/a-except.ads ada/libgnat/a-unccon.ads \ + ada/libgnat/a-uncdea.ads ada/alloc.ads ada/debug.ads ada/hostparm.ads ada/namet.ads \ ada/opt.ads ada/osint.ads ada/output.ads ada/sdefault.ads ada/sdefault.adb \ - ada/s-exctab.ads ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads \ - ada/s-stalib.ads ada/s-strops.ads ada/s-sopco3.ads ada/s-sopco4.ads \ - ada/s-sopco5.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \ - ada/s-wchcon.ads ada/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \ - ada/types.ads ada/unchdeal.ads ada/unchconv.ads + ada/libgnat/s-exctab.ads ada/libgnat/s-memory.ads ada/libgnat/s-os_lib.ads ada/libgnat/s-parame.ads \ + ada/libgnat/s-stalib.ads ada/libgnat/s-strops.ads ada/libgnat/s-sopco3.ads ada/libgnat/s-sopco4.ads \ + ada/libgnat/s-sopco5.ads ada/libgnat/s-string.ads ada/libgnat/s-traent.ads ada/libgnat/s-unstyp.ads \ + ada/libgnat/s-wchcon.ads ada/libgnat/system.ads ada/table.adb ada/table.ads ada/tree_io.ads \ + ada/types.ads ada/libgnat/unchdeal.ads ada/libgnat/unchconv.ads # Special flags - see gcc-interface/Makefile.in for the template. -ada/a-except.o : ada/a-except.adb ada/a-except.ads ada/s-excmac.ads ada/s-excmac.adb +ada/libgnat/a-except.o : ada/libgnat/a-except.adb ada/libgnat/a-except.ads ada/libgnat/s-excmac.ads ada/libgnat/s-excmac.adb $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O1 -fno-inline \ - $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) -ada/s-excdeb.o : ada/s-excdeb.adb ada/s-excdeb.ads +ada/libgnat/s-excdeb.o : ada/libgnat/s-excdeb.adb ada/libgnat/s-excdeb.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) -O0 \ - $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) -ada/s-assert.o : ada/s-assert.adb ada/s-assert.ads +ada/libgnat/s-assert.o : ada/libgnat/s-assert.adb ada/libgnat/s-assert.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) -ada/a-tags.o : ada/a-tags.adb ada/a-tags.ads +ada/libgnat/a-tags.o : ada/libgnat/a-tags.adb ada/libgnat/a-tags.ads $(CC) -c $(ALL_ADAFLAGS) $(FORCE_DEBUG_ADAFLAGS) $(ADA_INCLUDES) \ - $< $(OUTPUT_OPTION) + $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) # Handling of gnatvsn version string @@ -1041,19 +1061,19 @@ ada/generated/gnatvsn.ads: ada/gnatvsn.ads BASE-VER ada/GNAT_DATE cat $< | sed -e "/Version/s/(\([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]\).*)/($$d$$s)/g" >$@ ada/gnatvsn.o : ada/gnatvsn.adb ada/generated/gnatvsn.ads - $(CC) -c $(ALL_ADAFLAGS) -Iada/generated -I../ada/generated $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(CC) -c $(ALL_ADAFLAGS) -Iada/generated -I../ada/generated $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) @$(ADA_DEPS) # Dependencies for windows specific tool (mdll) ada/mdll.o : ada/mdll.adb ada/mdll.ads ada/mdll-fil.ads ada/mdll-utl.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) ada/mdll-fil.o : ada/mdll-fil.adb ada/mdll.ads ada/mdll-fil.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) ada/mdll-utl.o : ada/mdll-utl.adb ada/mdll.ads ada/mdll-utl.ads ada/sdefault.ads ada/types.ads - $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(OUTPUT_OPTION) + $(CC) -c $(ALL_ADAFLAGS) $(ADA_INCLUDES) $< $(ADA_OUTPUT_OPTION) ada_generated_files = ada/sinfo.h ada/einfo.h ada/nmake.adb ada/nmake.ads \ ada/treeprs.ads ada/snames.ads ada/snames.adb ada/snames.h \ diff --git a/gcc/ada/gcc-interface/Makefile.in b/gcc/ada/gcc-interface/Makefile.in index ef3dbec..4fdee80 100644 --- a/gcc/ada/gcc-interface/Makefile.in +++ b/gcc/ada/gcc-interface/Makefile.in @@ -359,7 +359,7 @@ a-intnam.ads. -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the parent package for a library of useful units provided with GNAT - -package GNAT is - pragma Pure; - -end GNAT; diff --git a/gcc/ada/i-c.adb b/gcc/ada/i-c.adb deleted file mode 100644 index 01d6912..0000000 --- a/gcc/ada/i-c.adb +++ /dev/null @@ -1,826 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Interfaces.C is - - ----------------------- - -- Is_Nul_Terminated -- - ----------------------- - - -- Case of char_array - - function Is_Nul_Terminated (Item : char_array) return Boolean is - begin - for J in Item'Range loop - if Item (J) = nul then - return True; - end if; - end loop; - - return False; - end Is_Nul_Terminated; - - -- Case of wchar_array - - function Is_Nul_Terminated (Item : wchar_array) return Boolean is - begin - for J in Item'Range loop - if Item (J) = wide_nul then - return True; - end if; - end loop; - - return False; - end Is_Nul_Terminated; - - -- Case of char16_array - - function Is_Nul_Terminated (Item : char16_array) return Boolean is - begin - for J in Item'Range loop - if Item (J) = char16_nul then - return True; - end if; - end loop; - - return False; - end Is_Nul_Terminated; - - -- Case of char32_array - - function Is_Nul_Terminated (Item : char32_array) return Boolean is - begin - for J in Item'Range loop - if Item (J) = char32_nul then - return True; - end if; - end loop; - - return False; - end Is_Nul_Terminated; - - ------------ - -- To_Ada -- - ------------ - - -- Convert char to Character - - function To_Ada (Item : char) return Character is - begin - return Character'Val (char'Pos (Item)); - end To_Ada; - - -- Convert char_array to String (function form) - - function To_Ada - (Item : char_array; - Trim_Nul : Boolean := True) return String - is - Count : Natural; - From : size_t; - - begin - if Trim_Nul then - From := Item'First; - - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = nul then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - declare - R : String (1 .. Count); - - begin - for J in R'Range loop - R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); - end loop; - - return R; - end; - end To_Ada; - - -- Convert char_array to String (procedure form) - - procedure To_Ada - (Item : char_array; - Target : out String; - Count : out Natural; - Trim_Nul : Boolean := True) - is - From : size_t; - To : Positive; - - begin - if Trim_Nul then - From := Item'First; - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = nul then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - if Count > Target'Length then - raise Constraint_Error; - - else - From := Item'First; - To := Target'First; - - for J in 1 .. Count loop - Target (To) := Character (Item (From)); - From := From + 1; - To := To + 1; - end loop; - end if; - - end To_Ada; - - -- Convert wchar_t to Wide_Character - - function To_Ada (Item : wchar_t) return Wide_Character is - begin - return Wide_Character (Item); - end To_Ada; - - -- Convert wchar_array to Wide_String (function form) - - function To_Ada - (Item : wchar_array; - Trim_Nul : Boolean := True) return Wide_String - is - Count : Natural; - From : size_t; - - begin - if Trim_Nul then - From := Item'First; - - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = wide_nul then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - declare - R : Wide_String (1 .. Count); - - begin - for J in R'Range loop - R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); - end loop; - - return R; - end; - end To_Ada; - - -- Convert wchar_array to Wide_String (procedure form) - - procedure To_Ada - (Item : wchar_array; - Target : out Wide_String; - Count : out Natural; - Trim_Nul : Boolean := True) - is - From : size_t; - To : Positive; - - begin - if Trim_Nul then - From := Item'First; - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = wide_nul then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - if Count > Target'Length then - raise Constraint_Error; - - else - From := Item'First; - To := Target'First; - - for J in 1 .. Count loop - Target (To) := To_Ada (Item (From)); - From := From + 1; - To := To + 1; - end loop; - end if; - end To_Ada; - - -- Convert char16_t to Wide_Character - - function To_Ada (Item : char16_t) return Wide_Character is - begin - return Wide_Character'Val (char16_t'Pos (Item)); - end To_Ada; - - -- Convert char16_array to Wide_String (function form) - - function To_Ada - (Item : char16_array; - Trim_Nul : Boolean := True) return Wide_String - is - Count : Natural; - From : size_t; - - begin - if Trim_Nul then - From := Item'First; - - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = char16_t'Val (0) then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - declare - R : Wide_String (1 .. Count); - - begin - for J in R'Range loop - R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); - end loop; - - return R; - end; - end To_Ada; - - -- Convert char16_array to Wide_String (procedure form) - - procedure To_Ada - (Item : char16_array; - Target : out Wide_String; - Count : out Natural; - Trim_Nul : Boolean := True) - is - From : size_t; - To : Positive; - - begin - if Trim_Nul then - From := Item'First; - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = char16_t'Val (0) then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - if Count > Target'Length then - raise Constraint_Error; - - else - From := Item'First; - To := Target'First; - - for J in 1 .. Count loop - Target (To) := To_Ada (Item (From)); - From := From + 1; - To := To + 1; - end loop; - end if; - end To_Ada; - - -- Convert char32_t to Wide_Wide_Character - - function To_Ada (Item : char32_t) return Wide_Wide_Character is - begin - return Wide_Wide_Character'Val (char32_t'Pos (Item)); - end To_Ada; - - -- Convert char32_array to Wide_Wide_String (function form) - - function To_Ada - (Item : char32_array; - Trim_Nul : Boolean := True) return Wide_Wide_String - is - Count : Natural; - From : size_t; - - begin - if Trim_Nul then - From := Item'First; - - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = char32_t'Val (0) then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - declare - R : Wide_Wide_String (1 .. Count); - - begin - for J in R'Range loop - R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); - end loop; - - return R; - end; - end To_Ada; - - -- Convert char32_array to Wide_Wide_String (procedure form) - - procedure To_Ada - (Item : char32_array; - Target : out Wide_Wide_String; - Count : out Natural; - Trim_Nul : Boolean := True) - is - From : size_t; - To : Positive; - - begin - if Trim_Nul then - From := Item'First; - loop - if From > Item'Last then - raise Terminator_Error; - elsif Item (From) = char32_t'Val (0) then - exit; - else - From := From + 1; - end if; - end loop; - - Count := Natural (From - Item'First); - - else - Count := Item'Length; - end if; - - if Count > Target'Length then - raise Constraint_Error; - - else - From := Item'First; - To := Target'First; - - for J in 1 .. Count loop - Target (To) := To_Ada (Item (From)); - From := From + 1; - To := To + 1; - end loop; - end if; - end To_Ada; - - ---------- - -- To_C -- - ---------- - - -- Convert Character to char - - function To_C (Item : Character) return char is - begin - return char'Val (Character'Pos (Item)); - end To_C; - - -- Convert String to char_array (function form) - - function To_C - (Item : String; - Append_Nul : Boolean := True) return char_array - is - begin - if Append_Nul then - declare - R : char_array (0 .. Item'Length); - - begin - for J in Item'Range loop - R (size_t (J - Item'First)) := To_C (Item (J)); - end loop; - - R (R'Last) := nul; - return R; - end; - - -- Append_Nul False - - else - -- A nasty case, if the string is null, we must return a null - -- char_array. The lower bound of this array is required to be zero - -- (RM B.3(50)) but that is of course impossible given that size_t - -- is unsigned. According to Ada 2005 AI-258, the result is to raise - -- Constraint_Error. This is also the appropriate behavior in Ada 95, - -- since nothing else makes sense. - - if Item'Length = 0 then - raise Constraint_Error; - - -- Normal case - - else - declare - R : char_array (0 .. Item'Length - 1); - - begin - for J in Item'Range loop - R (size_t (J - Item'First)) := To_C (Item (J)); - end loop; - - return R; - end; - end if; - end if; - end To_C; - - -- Convert String to char_array (procedure form) - - procedure To_C - (Item : String; - Target : out char_array; - Count : out size_t; - Append_Nul : Boolean := True) - is - To : size_t; - - begin - if Target'Length < Item'Length then - raise Constraint_Error; - - else - To := Target'First; - for From in Item'Range loop - Target (To) := char (Item (From)); - To := To + 1; - end loop; - - if Append_Nul then - if To > Target'Last then - raise Constraint_Error; - else - Target (To) := nul; - Count := Item'Length + 1; - end if; - - else - Count := Item'Length; - end if; - end if; - end To_C; - - -- Convert Wide_Character to wchar_t - - function To_C (Item : Wide_Character) return wchar_t is - begin - return wchar_t (Item); - end To_C; - - -- Convert Wide_String to wchar_array (function form) - - function To_C - (Item : Wide_String; - Append_Nul : Boolean := True) return wchar_array - is - begin - if Append_Nul then - declare - R : wchar_array (0 .. Item'Length); - - begin - for J in Item'Range loop - R (size_t (J - Item'First)) := To_C (Item (J)); - end loop; - - R (R'Last) := wide_nul; - return R; - end; - - else - -- A nasty case, if the string is null, we must return a null - -- wchar_array. The lower bound of this array is required to be zero - -- (RM B.3(50)) but that is of course impossible given that size_t - -- is unsigned. According to Ada 2005 AI-258, the result is to raise - -- Constraint_Error. This is also the appropriate behavior in Ada 95, - -- since nothing else makes sense. - - if Item'Length = 0 then - raise Constraint_Error; - - else - declare - R : wchar_array (0 .. Item'Length - 1); - - begin - for J in size_t range 0 .. Item'Length - 1 loop - R (J) := To_C (Item (Integer (J) + Item'First)); - end loop; - - return R; - end; - end if; - end if; - end To_C; - - -- Convert Wide_String to wchar_array (procedure form) - - procedure To_C - (Item : Wide_String; - Target : out wchar_array; - Count : out size_t; - Append_Nul : Boolean := True) - is - To : size_t; - - begin - if Target'Length < Item'Length then - raise Constraint_Error; - - else - To := Target'First; - for From in Item'Range loop - Target (To) := To_C (Item (From)); - To := To + 1; - end loop; - - if Append_Nul then - if To > Target'Last then - raise Constraint_Error; - else - Target (To) := wide_nul; - Count := Item'Length + 1; - end if; - - else - Count := Item'Length; - end if; - end if; - end To_C; - - -- Convert Wide_Character to char16_t - - function To_C (Item : Wide_Character) return char16_t is - begin - return char16_t'Val (Wide_Character'Pos (Item)); - end To_C; - - -- Convert Wide_String to char16_array (function form) - - function To_C - (Item : Wide_String; - Append_Nul : Boolean := True) return char16_array - is - begin - if Append_Nul then - declare - R : char16_array (0 .. Item'Length); - - begin - for J in Item'Range loop - R (size_t (J - Item'First)) := To_C (Item (J)); - end loop; - - R (R'Last) := char16_t'Val (0); - return R; - end; - - else - -- A nasty case, if the string is null, we must return a null - -- char16_array. The lower bound of this array is required to be zero - -- (RM B.3(50)) but that is of course impossible given that size_t - -- is unsigned. According to Ada 2005 AI-258, the result is to raise - -- Constraint_Error. This is also the appropriate behavior in Ada 95, - -- since nothing else makes sense. - - if Item'Length = 0 then - raise Constraint_Error; - - else - declare - R : char16_array (0 .. Item'Length - 1); - - begin - for J in size_t range 0 .. Item'Length - 1 loop - R (J) := To_C (Item (Integer (J) + Item'First)); - end loop; - - return R; - end; - end if; - end if; - end To_C; - - -- Convert Wide_String to char16_array (procedure form) - - procedure To_C - (Item : Wide_String; - Target : out char16_array; - Count : out size_t; - Append_Nul : Boolean := True) - is - To : size_t; - - begin - if Target'Length < Item'Length then - raise Constraint_Error; - - else - To := Target'First; - for From in Item'Range loop - Target (To) := To_C (Item (From)); - To := To + 1; - end loop; - - if Append_Nul then - if To > Target'Last then - raise Constraint_Error; - else - Target (To) := char16_t'Val (0); - Count := Item'Length + 1; - end if; - - else - Count := Item'Length; - end if; - end if; - end To_C; - - -- Convert Wide_Character to char32_t - - function To_C (Item : Wide_Wide_Character) return char32_t is - begin - return char32_t'Val (Wide_Wide_Character'Pos (Item)); - end To_C; - - -- Convert Wide_Wide_String to char32_array (function form) - - function To_C - (Item : Wide_Wide_String; - Append_Nul : Boolean := True) return char32_array - is - begin - if Append_Nul then - declare - R : char32_array (0 .. Item'Length); - - begin - for J in Item'Range loop - R (size_t (J - Item'First)) := To_C (Item (J)); - end loop; - - R (R'Last) := char32_t'Val (0); - return R; - end; - - else - -- A nasty case, if the string is null, we must return a null - -- char32_array. The lower bound of this array is required to be zero - -- (RM B.3(50)) but that is of course impossible given that size_t - -- is unsigned. According to Ada 2005 AI-258, the result is to raise - -- Constraint_Error. - - if Item'Length = 0 then - raise Constraint_Error; - - else - declare - R : char32_array (0 .. Item'Length - 1); - - begin - for J in size_t range 0 .. Item'Length - 1 loop - R (J) := To_C (Item (Integer (J) + Item'First)); - end loop; - - return R; - end; - end if; - end if; - end To_C; - - -- Convert Wide_Wide_String to char32_array (procedure form) - - procedure To_C - (Item : Wide_Wide_String; - Target : out char32_array; - Count : out size_t; - Append_Nul : Boolean := True) - is - To : size_t; - - begin - if Target'Length < Item'Length then - raise Constraint_Error; - - else - To := Target'First; - for From in Item'Range loop - Target (To) := To_C (Item (From)); - To := To + 1; - end loop; - - if Append_Nul then - if To > Target'Last then - raise Constraint_Error; - else - Target (To) := char32_t'Val (0); - Count := Item'Length + 1; - end if; - - else - Count := Item'Length; - end if; - end if; - end To_C; - -end Interfaces.C; diff --git a/gcc/ada/i-c.ads b/gcc/ada/i-c.ads deleted file mode 100644 index 1088836..0000000 --- a/gcc/ada/i-c.ads +++ /dev/null @@ -1,230 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with System.Parameters; - -package Interfaces.C is - pragma Pure; - - -- Declaration's based on C's - - CHAR_BIT : constant := 8; - SCHAR_MIN : constant := -128; - SCHAR_MAX : constant := 127; - UCHAR_MAX : constant := 255; - - -- Signed and Unsigned Integers. Note that in GNAT, we have ensured that - -- the standard predefined Ada types correspond to the standard C types - - -- Note: the Integer qualifications used in the declaration of type long - -- avoid ambiguities when compiling in the presence of s-auxdec.ads and - -- a non-private system.address type. - - type int is new Integer; - type short is new Short_Integer; - type long is range -(2 ** (System.Parameters.long_bits - Integer'(1))) - .. +(2 ** (System.Parameters.long_bits - Integer'(1))) - 1; - - type signed_char is range SCHAR_MIN .. SCHAR_MAX; - for signed_char'Size use CHAR_BIT; - - type unsigned is mod 2 ** int'Size; - type unsigned_short is mod 2 ** short'Size; - type unsigned_long is mod 2 ** long'Size; - - type unsigned_char is mod (UCHAR_MAX + 1); - for unsigned_char'Size use CHAR_BIT; - - subtype plain_char is unsigned_char; -- ??? should be parameterized - - -- Note: the Integer qualifications used in the declaration of ptrdiff_t - -- avoid ambiguities when compiling in the presence of s-auxdec.ads and - -- a non-private system.address type. - - type ptrdiff_t is - range -(2 ** (System.Parameters.ptr_bits - Integer'(1))) .. - +(2 ** (System.Parameters.ptr_bits - Integer'(1)) - 1); - - type size_t is mod 2 ** System.Parameters.ptr_bits; - - -- Floating-Point - - type C_float is new Float; - type double is new Standard.Long_Float; - type long_double is new Standard.Long_Long_Float; - - ---------------------------- - -- Characters and Strings -- - ---------------------------- - - type char is new Character; - - nul : constant char := char'First; - - function To_C (Item : Character) return char; - function To_Ada (Item : char) return Character; - - type char_array is array (size_t range <>) of aliased char; - for char_array'Component_Size use CHAR_BIT; - - function Is_Nul_Terminated (Item : char_array) return Boolean; - - function To_C - (Item : String; - Append_Nul : Boolean := True) return char_array; - - function To_Ada - (Item : char_array; - Trim_Nul : Boolean := True) return String; - - procedure To_C - (Item : String; - Target : out char_array; - Count : out size_t; - Append_Nul : Boolean := True); - - procedure To_Ada - (Item : char_array; - Target : out String; - Count : out Natural; - Trim_Nul : Boolean := True); - - ------------------------------------ - -- Wide Character and Wide String -- - ------------------------------------ - - type wchar_t is new Wide_Character; - for wchar_t'Size use Standard'Wchar_T_Size; - - wide_nul : constant wchar_t := wchar_t'First; - - function To_C (Item : Wide_Character) return wchar_t; - function To_Ada (Item : wchar_t) return Wide_Character; - - type wchar_array is array (size_t range <>) of aliased wchar_t; - - function Is_Nul_Terminated (Item : wchar_array) return Boolean; - - function To_C - (Item : Wide_String; - Append_Nul : Boolean := True) return wchar_array; - - function To_Ada - (Item : wchar_array; - Trim_Nul : Boolean := True) return Wide_String; - - procedure To_C - (Item : Wide_String; - Target : out wchar_array; - Count : out size_t; - Append_Nul : Boolean := True); - - procedure To_Ada - (Item : wchar_array; - Target : out Wide_String; - Count : out Natural; - Trim_Nul : Boolean := True); - - Terminator_Error : exception; - - -- The remaining declarations are for Ada 2005 (AI-285) - - -- ISO/IEC 10646:2003 compatible types defined by SC22/WG14 document N1010 - - type char16_t is new Wide_Character; - pragma Ada_05 (char16_t); - - char16_nul : constant char16_t := char16_t'Val (0); - pragma Ada_05 (char16_nul); - - function To_C (Item : Wide_Character) return char16_t; - pragma Ada_05 (To_C); - - function To_Ada (Item : char16_t) return Wide_Character; - pragma Ada_05 (To_Ada); - - type char16_array is array (size_t range <>) of aliased char16_t; - pragma Ada_05 (char16_array); - - function Is_Nul_Terminated (Item : char16_array) return Boolean; - pragma Ada_05 (Is_Nul_Terminated); - - function To_C - (Item : Wide_String; - Append_Nul : Boolean := True) return char16_array; - pragma Ada_05 (To_C); - - function To_Ada - (Item : char16_array; - Trim_Nul : Boolean := True) return Wide_String; - pragma Ada_05 (To_Ada); - - procedure To_C - (Item : Wide_String; - Target : out char16_array; - Count : out size_t; - Append_Nul : Boolean := True); - pragma Ada_05 (To_C); - - procedure To_Ada - (Item : char16_array; - Target : out Wide_String; - Count : out Natural; - Trim_Nul : Boolean := True); - pragma Ada_05 (To_Ada); - - type char32_t is new Wide_Wide_Character; - pragma Ada_05 (char32_t); - - char32_nul : constant char32_t := char32_t'Val (0); - pragma Ada_05 (char32_nul); - - function To_C (Item : Wide_Wide_Character) return char32_t; - pragma Ada_05 (To_C); - - function To_Ada (Item : char32_t) return Wide_Wide_Character; - pragma Ada_05 (To_Ada); - - type char32_array is array (size_t range <>) of aliased char32_t; - pragma Ada_05 (char32_array); - - function Is_Nul_Terminated (Item : char32_array) return Boolean; - pragma Ada_05 (Is_Nul_Terminated); - - function To_C - (Item : Wide_Wide_String; - Append_Nul : Boolean := True) return char32_array; - pragma Ada_05 (To_C); - - function To_Ada - (Item : char32_array; - Trim_Nul : Boolean := True) return Wide_Wide_String; - pragma Ada_05 (To_Ada); - - procedure To_C - (Item : Wide_Wide_String; - Target : out char32_array; - Count : out size_t; - Append_Nul : Boolean := True); - pragma Ada_05 (To_C); - - procedure To_Ada - (Item : char32_array; - Target : out Wide_Wide_String; - Count : out Natural; - Trim_Nul : Boolean := True); - pragma Ada_05 (To_Ada); - -end Interfaces.C; diff --git a/gcc/ada/i-cexten.ads b/gcc/ada/i-cexten.ads deleted file mode 100644 index e256dec..0000000 --- a/gcc/ada/i-cexten.ads +++ /dev/null @@ -1,458 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C . E X T E N S I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains additional C-related definitions, intended for use --- with either manually or automatically generated bindings to C libraries. - -with System; - -package Interfaces.C.Extensions is - pragma Pure; - - -- Definitions for C "void" and "void *" types - - subtype void is System.Address; - subtype void_ptr is System.Address; - - -- Definitions for C incomplete/unknown structs - - subtype opaque_structure_def is System.Address; - type opaque_structure_def_ptr is access opaque_structure_def; - for opaque_structure_def_ptr'Storage_Size use 0; - - -- Definitions for C++ incomplete/unknown classes - - subtype incomplete_class_def is System.Address; - type incomplete_class_def_ptr is access incomplete_class_def; - for incomplete_class_def_ptr'Storage_Size use 0; - - -- C bool - - subtype bool is plain_char; - - -- 64-bit integer types - - subtype long_long is Long_Long_Integer; - type unsigned_long_long is mod 2 ** 64; - - -- 128-bit integer type available on 64-bit platforms: - -- typedef int signed_128 __attribute__ ((mode (TI))); - - type Signed_128 is record - low, high : unsigned_long_long; - end record; - pragma Convention (C_Pass_By_Copy, Signed_128); - for Signed_128'Alignment use unsigned_long_long'Alignment * 2; - - -- Types for bitfields - - type Unsigned_1 is mod 2 ** 1; - for Unsigned_1'Size use 1; - - type Unsigned_2 is mod 2 ** 2; - for Unsigned_2'Size use 2; - - type Unsigned_3 is mod 2 ** 3; - for Unsigned_3'Size use 3; - - type Unsigned_4 is mod 2 ** 4; - for Unsigned_4'Size use 4; - - type Unsigned_5 is mod 2 ** 5; - for Unsigned_5'Size use 5; - - type Unsigned_6 is mod 2 ** 6; - for Unsigned_6'Size use 6; - - type Unsigned_7 is mod 2 ** 7; - for Unsigned_7'Size use 7; - - type Unsigned_8 is mod 2 ** 8; - for Unsigned_8'Size use 8; - - type Unsigned_9 is mod 2 ** 9; - for Unsigned_9'Size use 9; - - type Unsigned_10 is mod 2 ** 10; - for Unsigned_10'Size use 10; - - type Unsigned_11 is mod 2 ** 11; - for Unsigned_11'Size use 11; - - type Unsigned_12 is mod 2 ** 12; - for Unsigned_12'Size use 12; - - type Unsigned_13 is mod 2 ** 13; - for Unsigned_13'Size use 13; - - type Unsigned_14 is mod 2 ** 14; - for Unsigned_14'Size use 14; - - type Unsigned_15 is mod 2 ** 15; - for Unsigned_15'Size use 15; - - type Unsigned_16 is mod 2 ** 16; - for Unsigned_16'Size use 16; - - type Unsigned_17 is mod 2 ** 17; - for Unsigned_17'Size use 17; - - type Unsigned_18 is mod 2 ** 18; - for Unsigned_18'Size use 18; - - type Unsigned_19 is mod 2 ** 19; - for Unsigned_19'Size use 19; - - type Unsigned_20 is mod 2 ** 20; - for Unsigned_20'Size use 20; - - type Unsigned_21 is mod 2 ** 21; - for Unsigned_21'Size use 21; - - type Unsigned_22 is mod 2 ** 22; - for Unsigned_22'Size use 22; - - type Unsigned_23 is mod 2 ** 23; - for Unsigned_23'Size use 23; - - type Unsigned_24 is mod 2 ** 24; - for Unsigned_24'Size use 24; - - type Unsigned_25 is mod 2 ** 25; - for Unsigned_25'Size use 25; - - type Unsigned_26 is mod 2 ** 26; - for Unsigned_26'Size use 26; - - type Unsigned_27 is mod 2 ** 27; - for Unsigned_27'Size use 27; - - type Unsigned_28 is mod 2 ** 28; - for Unsigned_28'Size use 28; - - type Unsigned_29 is mod 2 ** 29; - for Unsigned_29'Size use 29; - - type Unsigned_30 is mod 2 ** 30; - for Unsigned_30'Size use 30; - - type Unsigned_31 is mod 2 ** 31; - for Unsigned_31'Size use 31; - - type Unsigned_32 is mod 2 ** 32; - for Unsigned_32'Size use 32; - - type Unsigned_33 is mod 2 ** 33; - for Unsigned_33'Size use 33; - - type Unsigned_34 is mod 2 ** 34; - for Unsigned_34'Size use 34; - - type Unsigned_35 is mod 2 ** 35; - for Unsigned_35'Size use 35; - - type Unsigned_36 is mod 2 ** 36; - for Unsigned_36'Size use 36; - - type Unsigned_37 is mod 2 ** 37; - for Unsigned_37'Size use 37; - - type Unsigned_38 is mod 2 ** 38; - for Unsigned_38'Size use 38; - - type Unsigned_39 is mod 2 ** 39; - for Unsigned_39'Size use 39; - - type Unsigned_40 is mod 2 ** 40; - for Unsigned_40'Size use 40; - - type Unsigned_41 is mod 2 ** 41; - for Unsigned_41'Size use 41; - - type Unsigned_42 is mod 2 ** 42; - for Unsigned_42'Size use 42; - - type Unsigned_43 is mod 2 ** 43; - for Unsigned_43'Size use 43; - - type Unsigned_44 is mod 2 ** 44; - for Unsigned_44'Size use 44; - - type Unsigned_45 is mod 2 ** 45; - for Unsigned_45'Size use 45; - - type Unsigned_46 is mod 2 ** 46; - for Unsigned_46'Size use 46; - - type Unsigned_47 is mod 2 ** 47; - for Unsigned_47'Size use 47; - - type Unsigned_48 is mod 2 ** 48; - for Unsigned_48'Size use 48; - - type Unsigned_49 is mod 2 ** 49; - for Unsigned_49'Size use 49; - - type Unsigned_50 is mod 2 ** 50; - for Unsigned_50'Size use 50; - - type Unsigned_51 is mod 2 ** 51; - for Unsigned_51'Size use 51; - - type Unsigned_52 is mod 2 ** 52; - for Unsigned_52'Size use 52; - - type Unsigned_53 is mod 2 ** 53; - for Unsigned_53'Size use 53; - - type Unsigned_54 is mod 2 ** 54; - for Unsigned_54'Size use 54; - - type Unsigned_55 is mod 2 ** 55; - for Unsigned_55'Size use 55; - - type Unsigned_56 is mod 2 ** 56; - for Unsigned_56'Size use 56; - - type Unsigned_57 is mod 2 ** 57; - for Unsigned_57'Size use 57; - - type Unsigned_58 is mod 2 ** 58; - for Unsigned_58'Size use 58; - - type Unsigned_59 is mod 2 ** 59; - for Unsigned_59'Size use 59; - - type Unsigned_60 is mod 2 ** 60; - for Unsigned_60'Size use 60; - - type Unsigned_61 is mod 2 ** 61; - for Unsigned_61'Size use 61; - - type Unsigned_62 is mod 2 ** 62; - for Unsigned_62'Size use 62; - - type Unsigned_63 is mod 2 ** 63; - for Unsigned_63'Size use 63; - - type Unsigned_64 is mod 2 ** 64; - for Unsigned_64'Size use 64; - - type Signed_2 is range -2 ** 1 .. 2 ** 1 - 1; - for Signed_2'Size use 2; - - type Signed_3 is range -2 ** 2 .. 2 ** 2 - 1; - for Signed_3'Size use 3; - - type Signed_4 is range -2 ** 3 .. 2 ** 3 - 1; - for Signed_4'Size use 4; - - type Signed_5 is range -2 ** 4 .. 2 ** 4 - 1; - for Signed_5'Size use 5; - - type Signed_6 is range -2 ** 5 .. 2 ** 5 - 1; - for Signed_6'Size use 6; - - type Signed_7 is range -2 ** 6 .. 2 ** 6 - 1; - for Signed_7'Size use 7; - - type Signed_8 is range -2 ** 7 .. 2 ** 7 - 1; - for Signed_8'Size use 8; - - type Signed_9 is range -2 ** 8 .. 2 ** 8 - 1; - for Signed_9'Size use 9; - - type Signed_10 is range -2 ** 9 .. 2 ** 9 - 1; - for Signed_10'Size use 10; - - type Signed_11 is range -2 ** 10 .. 2 ** 10 - 1; - for Signed_11'Size use 11; - - type Signed_12 is range -2 ** 11 .. 2 ** 11 - 1; - for Signed_12'Size use 12; - - type Signed_13 is range -2 ** 12 .. 2 ** 12 - 1; - for Signed_13'Size use 13; - - type Signed_14 is range -2 ** 13 .. 2 ** 13 - 1; - for Signed_14'Size use 14; - - type Signed_15 is range -2 ** 14 .. 2 ** 14 - 1; - for Signed_15'Size use 15; - - type Signed_16 is range -2 ** 15 .. 2 ** 15 - 1; - for Signed_16'Size use 16; - - type Signed_17 is range -2 ** 16 .. 2 ** 16 - 1; - for Signed_17'Size use 17; - - type Signed_18 is range -2 ** 17 .. 2 ** 17 - 1; - for Signed_18'Size use 18; - - type Signed_19 is range -2 ** 18 .. 2 ** 18 - 1; - for Signed_19'Size use 19; - - type Signed_20 is range -2 ** 19 .. 2 ** 19 - 1; - for Signed_20'Size use 20; - - type Signed_21 is range -2 ** 20 .. 2 ** 20 - 1; - for Signed_21'Size use 21; - - type Signed_22 is range -2 ** 21 .. 2 ** 21 - 1; - for Signed_22'Size use 22; - - type Signed_23 is range -2 ** 22 .. 2 ** 22 - 1; - for Signed_23'Size use 23; - - type Signed_24 is range -2 ** 23 .. 2 ** 23 - 1; - for Signed_24'Size use 24; - - type Signed_25 is range -2 ** 24 .. 2 ** 24 - 1; - for Signed_25'Size use 25; - - type Signed_26 is range -2 ** 25 .. 2 ** 25 - 1; - for Signed_26'Size use 26; - - type Signed_27 is range -2 ** 26 .. 2 ** 26 - 1; - for Signed_27'Size use 27; - - type Signed_28 is range -2 ** 27 .. 2 ** 27 - 1; - for Signed_28'Size use 28; - - type Signed_29 is range -2 ** 28 .. 2 ** 28 - 1; - for Signed_29'Size use 29; - - type Signed_30 is range -2 ** 29 .. 2 ** 29 - 1; - for Signed_30'Size use 30; - - type Signed_31 is range -2 ** 30 .. 2 ** 30 - 1; - for Signed_31'Size use 31; - - type Signed_32 is range -2 ** 31 .. 2 ** 31 - 1; - for Signed_32'Size use 32; - - type Signed_33 is range -2 ** 32 .. 2 ** 32 - 1; - for Signed_33'Size use 33; - - type Signed_34 is range -2 ** 33 .. 2 ** 33 - 1; - for Signed_34'Size use 34; - - type Signed_35 is range -2 ** 34 .. 2 ** 34 - 1; - for Signed_35'Size use 35; - - type Signed_36 is range -2 ** 35 .. 2 ** 35 - 1; - for Signed_36'Size use 36; - - type Signed_37 is range -2 ** 36 .. 2 ** 36 - 1; - for Signed_37'Size use 37; - - type Signed_38 is range -2 ** 37 .. 2 ** 37 - 1; - for Signed_38'Size use 38; - - type Signed_39 is range -2 ** 38 .. 2 ** 38 - 1; - for Signed_39'Size use 39; - - type Signed_40 is range -2 ** 39 .. 2 ** 39 - 1; - for Signed_40'Size use 40; - - type Signed_41 is range -2 ** 40 .. 2 ** 40 - 1; - for Signed_41'Size use 41; - - type Signed_42 is range -2 ** 41 .. 2 ** 41 - 1; - for Signed_42'Size use 42; - - type Signed_43 is range -2 ** 42 .. 2 ** 42 - 1; - for Signed_43'Size use 43; - - type Signed_44 is range -2 ** 43 .. 2 ** 43 - 1; - for Signed_44'Size use 44; - - type Signed_45 is range -2 ** 44 .. 2 ** 44 - 1; - for Signed_45'Size use 45; - - type Signed_46 is range -2 ** 45 .. 2 ** 45 - 1; - for Signed_46'Size use 46; - - type Signed_47 is range -2 ** 46 .. 2 ** 46 - 1; - for Signed_47'Size use 47; - - type Signed_48 is range -2 ** 47 .. 2 ** 47 - 1; - for Signed_48'Size use 48; - - type Signed_49 is range -2 ** 48 .. 2 ** 48 - 1; - for Signed_49'Size use 49; - - type Signed_50 is range -2 ** 49 .. 2 ** 49 - 1; - for Signed_50'Size use 50; - - type Signed_51 is range -2 ** 50 .. 2 ** 50 - 1; - for Signed_51'Size use 51; - - type Signed_52 is range -2 ** 51 .. 2 ** 51 - 1; - for Signed_52'Size use 52; - - type Signed_53 is range -2 ** 52 .. 2 ** 52 - 1; - for Signed_53'Size use 53; - - type Signed_54 is range -2 ** 53 .. 2 ** 53 - 1; - for Signed_54'Size use 54; - - type Signed_55 is range -2 ** 54 .. 2 ** 54 - 1; - for Signed_55'Size use 55; - - type Signed_56 is range -2 ** 55 .. 2 ** 55 - 1; - for Signed_56'Size use 56; - - type Signed_57 is range -2 ** 56 .. 2 ** 56 - 1; - for Signed_57'Size use 57; - - type Signed_58 is range -2 ** 57 .. 2 ** 57 - 1; - for Signed_58'Size use 58; - - type Signed_59 is range -2 ** 58 .. 2 ** 58 - 1; - for Signed_59'Size use 59; - - type Signed_60 is range -2 ** 59 .. 2 ** 59 - 1; - for Signed_60'Size use 60; - - type Signed_61 is range -2 ** 60 .. 2 ** 60 - 1; - for Signed_61'Size use 61; - - type Signed_62 is range -2 ** 61 .. 2 ** 61 - 1; - for Signed_62'Size use 62; - - type Signed_63 is range -2 ** 62 .. 2 ** 62 - 1; - for Signed_63'Size use 63; - - type Signed_64 is range -2 ** 63 .. 2 ** 63 - 1; - for Signed_64'Size use 64; - -end Interfaces.C.Extensions; diff --git a/gcc/ada/i-cobol.adb b/gcc/ada/i-cobol.adb deleted file mode 100644 index bd331b4..0000000 --- a/gcc/ada/i-cobol.adb +++ /dev/null @@ -1,993 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I N T E R F A C E S . C O B O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The body of Interfaces.COBOL is implementation independent (i.e. the same --- version is used with all versions of GNAT). The specialization to a --- particular COBOL format is completely contained in the private part of --- the spec. - -with Interfaces; use Interfaces; -with System; use System; -with Ada.Unchecked_Conversion; - -package body Interfaces.COBOL is - - ----------------------------------------------- - -- Declarations for External Binary Handling -- - ----------------------------------------------- - - subtype B1 is Byte_Array (1 .. 1); - subtype B2 is Byte_Array (1 .. 2); - subtype B4 is Byte_Array (1 .. 4); - subtype B8 is Byte_Array (1 .. 8); - -- Representations for 1,2,4,8 byte binary values - - function To_B1 is new Ada.Unchecked_Conversion (Integer_8, B1); - function To_B2 is new Ada.Unchecked_Conversion (Integer_16, B2); - function To_B4 is new Ada.Unchecked_Conversion (Integer_32, B4); - function To_B8 is new Ada.Unchecked_Conversion (Integer_64, B8); - -- Conversions from native binary to external binary - - function From_B1 is new Ada.Unchecked_Conversion (B1, Integer_8); - function From_B2 is new Ada.Unchecked_Conversion (B2, Integer_16); - function From_B4 is new Ada.Unchecked_Conversion (B4, Integer_32); - function From_B8 is new Ada.Unchecked_Conversion (B8, Integer_64); - -- Conversions from external binary to signed native binary - - function From_B1U is new Ada.Unchecked_Conversion (B1, Unsigned_8); - function From_B2U is new Ada.Unchecked_Conversion (B2, Unsigned_16); - function From_B4U is new Ada.Unchecked_Conversion (B4, Unsigned_32); - function From_B8U is new Ada.Unchecked_Conversion (B8, Unsigned_64); - -- Conversions from external binary to unsigned native binary - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Binary_To_Decimal - (Item : Byte_Array; - Format : Binary_Format) return Integer_64; - -- This function converts a numeric value in the given format to its - -- corresponding integer value. This is the non-generic implementation - -- of Decimal_Conversions.To_Decimal. The generic routine does the - -- final conversion to the fixed-point format. - - function Numeric_To_Decimal - (Item : Numeric; - Format : Display_Format) return Integer_64; - -- This function converts a numeric value in the given format to its - -- corresponding integer value. This is the non-generic implementation - -- of Decimal_Conversions.To_Decimal. The generic routine does the - -- final conversion to the fixed-point format. - - function Packed_To_Decimal - (Item : Packed_Decimal; - Format : Packed_Format) return Integer_64; - -- This function converts a packed value in the given format to its - -- corresponding integer value. This is the non-generic implementation - -- of Decimal_Conversions.To_Decimal. The generic routine does the - -- final conversion to the fixed-point format. - - procedure Swap (B : in out Byte_Array; F : Binary_Format); - -- Swaps the bytes if required by the binary format F - - function To_Display - (Item : Integer_64; - Format : Display_Format; - Length : Natural) return Numeric; - -- This function converts the given integer value into display format, - -- using the given format, with the length in bytes of the result given - -- by the last parameter. This is the non-generic implementation of - -- Decimal_Conversions.To_Display. The conversion of the item from its - -- original decimal format to Integer_64 is done by the generic routine. - - function To_Packed - (Item : Integer_64; - Format : Packed_Format; - Length : Natural) return Packed_Decimal; - -- This function converts the given integer value into packed format, - -- using the given format, with the length in digits of the result given - -- by the last parameter. This is the non-generic implementation of - -- Decimal_Conversions.To_Display. The conversion of the item from its - -- original decimal format to Integer_64 is done by the generic routine. - - function Valid_Numeric - (Item : Numeric; - Format : Display_Format) return Boolean; - -- This is the non-generic implementation of Decimal_Conversions.Valid - -- for the display case. - - function Valid_Packed - (Item : Packed_Decimal; - Format : Packed_Format) return Boolean; - -- This is the non-generic implementation of Decimal_Conversions.Valid - -- for the packed case. - - ----------------------- - -- Binary_To_Decimal -- - ----------------------- - - function Binary_To_Decimal - (Item : Byte_Array; - Format : Binary_Format) return Integer_64 - is - Len : constant Natural := Item'Length; - - begin - if Len = 1 then - if Format in Binary_Unsigned_Format then - return Integer_64 (From_B1U (Item)); - else - return Integer_64 (From_B1 (Item)); - end if; - - elsif Len = 2 then - declare - R : B2 := Item; - - begin - Swap (R, Format); - - if Format in Binary_Unsigned_Format then - return Integer_64 (From_B2U (R)); - else - return Integer_64 (From_B2 (R)); - end if; - end; - - elsif Len = 4 then - declare - R : B4 := Item; - - begin - Swap (R, Format); - - if Format in Binary_Unsigned_Format then - return Integer_64 (From_B4U (R)); - else - return Integer_64 (From_B4 (R)); - end if; - end; - - elsif Len = 8 then - declare - R : B8 := Item; - - begin - Swap (R, Format); - - if Format in Binary_Unsigned_Format then - return Integer_64 (From_B8U (R)); - else - return Integer_64 (From_B8 (R)); - end if; - end; - - -- Length is not 1, 2, 4 or 8 - - else - raise Conversion_Error; - end if; - end Binary_To_Decimal; - - ------------------------ - -- Numeric_To_Decimal -- - ------------------------ - - -- The following assumptions are made in the coding of this routine: - - -- The range of COBOL_Digits is compact and the ten values - -- represent the digits 0-9 in sequence - - -- The range of COBOL_Plus_Digits is compact and the ten values - -- represent the digits 0-9 in sequence with a plus sign. - - -- The range of COBOL_Minus_Digits is compact and the ten values - -- represent the digits 0-9 in sequence with a minus sign. - - -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits - - -- These assumptions are true for all COBOL representations we know of - - function Numeric_To_Decimal - (Item : Numeric; - Format : Display_Format) return Integer_64 - is - pragma Unsuppress (Range_Check); - Sign : COBOL_Character := COBOL_Plus; - Result : Integer_64 := 0; - - begin - if not Valid_Numeric (Item, Format) then - raise Conversion_Error; - end if; - - for J in Item'Range loop - declare - K : constant COBOL_Character := Item (J); - - begin - if K in COBOL_Digits then - Result := Result * 10 + - (COBOL_Character'Pos (K) - - COBOL_Character'Pos (COBOL_Digits'First)); - - elsif K in COBOL_Plus_Digits then - Result := Result * 10 + - (COBOL_Character'Pos (K) - - COBOL_Character'Pos (COBOL_Plus_Digits'First)); - - elsif K in COBOL_Minus_Digits then - Result := Result * 10 + - (COBOL_Character'Pos (K) - - COBOL_Character'Pos (COBOL_Minus_Digits'First)); - Sign := COBOL_Minus; - - -- Only remaining possibility is COBOL_Plus or COBOL_Minus - - else - Sign := K; - end if; - end; - end loop; - - if Sign = COBOL_Plus then - return Result; - else - return -Result; - end if; - - exception - when Constraint_Error => - raise Conversion_Error; - - end Numeric_To_Decimal; - - ----------------------- - -- Packed_To_Decimal -- - ----------------------- - - function Packed_To_Decimal - (Item : Packed_Decimal; - Format : Packed_Format) return Integer_64 - is - pragma Unsuppress (Range_Check); - Result : Integer_64 := 0; - Sign : constant Decimal_Element := Item (Item'Last); - - begin - if not Valid_Packed (Item, Format) then - raise Conversion_Error; - end if; - - case Packed_Representation is - when IBM => - for J in Item'First .. Item'Last - 1 loop - Result := Result * 10 + Integer_64 (Item (J)); - end loop; - - if Sign = 16#0B# or else Sign = 16#0D# then - return -Result; - else - return +Result; - end if; - end case; - - exception - when Constraint_Error => - raise Conversion_Error; - end Packed_To_Decimal; - - ---------- - -- Swap -- - ---------- - - procedure Swap (B : in out Byte_Array; F : Binary_Format) is - Little_Endian : constant Boolean := - System.Default_Bit_Order = System.Low_Order_First; - - begin - -- Return if no swap needed - - case F is - when H | HU => - if not Little_Endian then - return; - end if; - - when L | LU => - if Little_Endian then - return; - end if; - - when N | NU => - return; - end case; - - -- Here a swap is needed - - declare - Len : constant Natural := B'Length; - - begin - for J in 1 .. Len / 2 loop - declare - Temp : constant Byte := B (J); - - begin - B (J) := B (Len + 1 - J); - B (Len + 1 - J) := Temp; - end; - end loop; - end; - end Swap; - - ----------------------- - -- To_Ada (function) -- - ----------------------- - - function To_Ada (Item : Alphanumeric) return String is - Result : String (Item'Range); - - begin - for J in Item'Range loop - Result (J) := COBOL_To_Ada (Item (J)); - end loop; - - return Result; - end To_Ada; - - ------------------------ - -- To_Ada (procedure) -- - ------------------------ - - procedure To_Ada - (Item : Alphanumeric; - Target : out String; - Last : out Natural) - is - Last_Val : Integer; - - begin - if Item'Length > Target'Length then - raise Constraint_Error; - end if; - - Last_Val := Target'First - 1; - for J in Item'Range loop - Last_Val := Last_Val + 1; - Target (Last_Val) := COBOL_To_Ada (Item (J)); - end loop; - - Last := Last_Val; - end To_Ada; - - ------------------------- - -- To_COBOL (function) -- - ------------------------- - - function To_COBOL (Item : String) return Alphanumeric is - Result : Alphanumeric (Item'Range); - - begin - for J in Item'Range loop - Result (J) := Ada_To_COBOL (Item (J)); - end loop; - - return Result; - end To_COBOL; - - -------------------------- - -- To_COBOL (procedure) -- - -------------------------- - - procedure To_COBOL - (Item : String; - Target : out Alphanumeric; - Last : out Natural) - is - Last_Val : Integer; - - begin - if Item'Length > Target'Length then - raise Constraint_Error; - end if; - - Last_Val := Target'First - 1; - for J in Item'Range loop - Last_Val := Last_Val + 1; - Target (Last_Val) := Ada_To_COBOL (Item (J)); - end loop; - - Last := Last_Val; - end To_COBOL; - - ---------------- - -- To_Display -- - ---------------- - - function To_Display - (Item : Integer_64; - Format : Display_Format; - Length : Natural) return Numeric - is - Result : Numeric (1 .. Length); - Val : Integer_64 := Item; - - procedure Convert (First, Last : Natural); - -- Convert the number in Val into COBOL_Digits, storing the result - -- in Result (First .. Last). Raise Conversion_Error if too large. - - procedure Embed_Sign (Loc : Natural); - -- Used for the nonseparate formats to embed the appropriate sign - -- at the specified location (i.e. at Result (Loc)) - - ------------- - -- Convert -- - ------------- - - procedure Convert (First, Last : Natural) is - J : Natural; - - begin - J := Last; - while J >= First loop - Result (J) := - COBOL_Character'Val - (COBOL_Character'Pos (COBOL_Digits'First) + - Integer (Val mod 10)); - Val := Val / 10; - - if Val = 0 then - for K in First .. J - 1 loop - Result (J) := COBOL_Digits'First; - end loop; - - return; - - else - J := J - 1; - end if; - end loop; - - raise Conversion_Error; - end Convert; - - ---------------- - -- Embed_Sign -- - ---------------- - - procedure Embed_Sign (Loc : Natural) is - Digit : Natural range 0 .. 9; - - begin - Digit := COBOL_Character'Pos (Result (Loc)) - - COBOL_Character'Pos (COBOL_Digits'First); - - if Item >= 0 then - Result (Loc) := - COBOL_Character'Val - (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit); - else - Result (Loc) := - COBOL_Character'Val - (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit); - end if; - end Embed_Sign; - - -- Start of processing for To_Display - - begin - case Format is - when Unsigned => - if Val < 0 then - raise Conversion_Error; - else - Convert (1, Length); - end if; - - when Leading_Separate => - if Val < 0 then - Result (1) := COBOL_Minus; - Val := -Val; - else - Result (1) := COBOL_Plus; - end if; - - Convert (2, Length); - - when Trailing_Separate => - if Val < 0 then - Result (Length) := COBOL_Minus; - Val := -Val; - else - Result (Length) := COBOL_Plus; - end if; - - Convert (1, Length - 1); - - when Leading_Nonseparate => - Val := abs Val; - Convert (1, Length); - Embed_Sign (1); - - when Trailing_Nonseparate => - Val := abs Val; - Convert (1, Length); - Embed_Sign (Length); - end case; - - return Result; - end To_Display; - - --------------- - -- To_Packed -- - --------------- - - function To_Packed - (Item : Integer_64; - Format : Packed_Format; - Length : Natural) return Packed_Decimal - is - Result : Packed_Decimal (1 .. Length); - Val : Integer_64; - - procedure Convert (First, Last : Natural); - -- Convert the number in Val into a sequence of Decimal_Element values, - -- storing the result in Result (First .. Last). Raise Conversion_Error - -- if the value is too large to fit. - - ------------- - -- Convert -- - ------------- - - procedure Convert (First, Last : Natural) is - J : Natural := Last; - - begin - while J >= First loop - Result (J) := Decimal_Element (Val mod 10); - - Val := Val / 10; - - if Val = 0 then - for K in First .. J - 1 loop - Result (K) := 0; - end loop; - - return; - - else - J := J - 1; - end if; - end loop; - - raise Conversion_Error; - end Convert; - - -- Start of processing for To_Packed - - begin - case Packed_Representation is - when IBM => - if Format = Packed_Unsigned then - if Item < 0 then - raise Conversion_Error; - else - Result (Length) := 16#F#; - Val := Item; - end if; - - elsif Item >= 0 then - Result (Length) := 16#C#; - Val := Item; - - else -- Item < 0 - Result (Length) := 16#D#; - Val := -Item; - end if; - - Convert (1, Length - 1); - return Result; - end case; - end To_Packed; - - ------------------- - -- Valid_Numeric -- - ------------------- - - function Valid_Numeric - (Item : Numeric; - Format : Display_Format) return Boolean - is - begin - if Item'Length = 0 then - return False; - end if; - - -- All character positions except first and last must be Digits. - -- This is true for all the formats. - - for J in Item'First + 1 .. Item'Last - 1 loop - if Item (J) not in COBOL_Digits then - return False; - end if; - end loop; - - case Format is - when Unsigned => - return Item (Item'First) in COBOL_Digits - and then Item (Item'Last) in COBOL_Digits; - - when Leading_Separate => - return (Item (Item'First) = COBOL_Plus or else - Item (Item'First) = COBOL_Minus) - and then Item (Item'Last) in COBOL_Digits; - - when Trailing_Separate => - return Item (Item'First) in COBOL_Digits - and then - (Item (Item'Last) = COBOL_Plus or else - Item (Item'Last) = COBOL_Minus); - - when Leading_Nonseparate => - return (Item (Item'First) in COBOL_Plus_Digits or else - Item (Item'First) in COBOL_Minus_Digits) - and then Item (Item'Last) in COBOL_Digits; - - when Trailing_Nonseparate => - return Item (Item'First) in COBOL_Digits - and then - (Item (Item'Last) in COBOL_Plus_Digits or else - Item (Item'Last) in COBOL_Minus_Digits); - - end case; - end Valid_Numeric; - - ------------------ - -- Valid_Packed -- - ------------------ - - function Valid_Packed - (Item : Packed_Decimal; - Format : Packed_Format) return Boolean - is - begin - case Packed_Representation is - when IBM => - for J in Item'First .. Item'Last - 1 loop - if Item (J) > 9 then - return False; - end if; - end loop; - - -- For unsigned, sign digit must be F - - if Format = Packed_Unsigned then - return Item (Item'Last) = 16#F#; - - -- For signed, accept all standard and non-standard signs - - else - return Item (Item'Last) in 16#A# .. 16#F#; - end if; - end case; - end Valid_Packed; - - ------------------------- - -- Decimal_Conversions -- - ------------------------- - - package body Decimal_Conversions is - - --------------------- - -- Length (binary) -- - --------------------- - - -- Note that the tests here are all compile time tests - - function Length (Format : Binary_Format) return Natural is - pragma Unreferenced (Format); - begin - if Num'Digits <= 2 then - return 1; - elsif Num'Digits <= 4 then - return 2; - elsif Num'Digits <= 9 then - return 4; - else -- Num'Digits in 10 .. 18 - return 8; - end if; - end Length; - - ---------------------- - -- Length (display) -- - ---------------------- - - function Length (Format : Display_Format) return Natural is - begin - if Format = Leading_Separate or else Format = Trailing_Separate then - return Num'Digits + 1; - else - return Num'Digits; - end if; - end Length; - - --------------------- - -- Length (packed) -- - --------------------- - - -- Note that the tests here are all compile time checks - - function Length - (Format : Packed_Format) return Natural - is - pragma Unreferenced (Format); - begin - case Packed_Representation is - when IBM => - return (Num'Digits + 2) / 2 * 2; - end case; - end Length; - - --------------- - -- To_Binary -- - --------------- - - function To_Binary - (Item : Num; - Format : Binary_Format) return Byte_Array - is - begin - -- Note: all these tests are compile time tests - - if Num'Digits <= 2 then - return To_B1 (Integer_8'Integer_Value (Item)); - - elsif Num'Digits <= 4 then - declare - R : B2 := To_B2 (Integer_16'Integer_Value (Item)); - - begin - Swap (R, Format); - return R; - end; - - elsif Num'Digits <= 9 then - declare - R : B4 := To_B4 (Integer_32'Integer_Value (Item)); - - begin - Swap (R, Format); - return R; - end; - - else -- Num'Digits in 10 .. 18 - declare - R : B8 := To_B8 (Integer_64'Integer_Value (Item)); - - begin - Swap (R, Format); - return R; - end; - end if; - - exception - when Constraint_Error => - raise Conversion_Error; - end To_Binary; - - --------------------------------- - -- To_Binary (internal binary) -- - --------------------------------- - - function To_Binary (Item : Num) return Binary is - pragma Unsuppress (Range_Check); - begin - return Binary'Integer_Value (Item); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Binary; - - ------------------------- - -- To_Decimal (binary) -- - ------------------------- - - function To_Decimal - (Item : Byte_Array; - Format : Binary_Format) return Num - is - pragma Unsuppress (Range_Check); - begin - return Num'Fixed_Value (Binary_To_Decimal (Item, Format)); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Decimal; - - ---------------------------------- - -- To_Decimal (internal binary) -- - ---------------------------------- - - function To_Decimal (Item : Binary) return Num is - pragma Unsuppress (Range_Check); - begin - return Num'Fixed_Value (Item); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Decimal; - - -------------------------- - -- To_Decimal (display) -- - -------------------------- - - function To_Decimal - (Item : Numeric; - Format : Display_Format) return Num - is - pragma Unsuppress (Range_Check); - - begin - return Num'Fixed_Value (Numeric_To_Decimal (Item, Format)); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Decimal; - - --------------------------------------- - -- To_Decimal (internal long binary) -- - --------------------------------------- - - function To_Decimal (Item : Long_Binary) return Num is - pragma Unsuppress (Range_Check); - begin - return Num'Fixed_Value (Item); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Decimal; - - ------------------------- - -- To_Decimal (packed) -- - ------------------------- - - function To_Decimal - (Item : Packed_Decimal; - Format : Packed_Format) return Num - is - pragma Unsuppress (Range_Check); - begin - return Num'Fixed_Value (Packed_To_Decimal (Item, Format)); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Decimal; - - ---------------- - -- To_Display -- - ---------------- - - function To_Display - (Item : Num; - Format : Display_Format) return Numeric - is - pragma Unsuppress (Range_Check); - begin - return - To_Display - (Integer_64'Integer_Value (Item), - Format, - Length (Format)); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Display; - - -------------------- - -- To_Long_Binary -- - -------------------- - - function To_Long_Binary (Item : Num) return Long_Binary is - pragma Unsuppress (Range_Check); - begin - return Long_Binary'Integer_Value (Item); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Long_Binary; - - --------------- - -- To_Packed -- - --------------- - - function To_Packed - (Item : Num; - Format : Packed_Format) return Packed_Decimal - is - pragma Unsuppress (Range_Check); - begin - return - To_Packed - (Integer_64'Integer_Value (Item), - Format, - Length (Format)); - exception - when Constraint_Error => - raise Conversion_Error; - end To_Packed; - - -------------------- - -- Valid (binary) -- - -------------------- - - function Valid - (Item : Byte_Array; - Format : Binary_Format) return Boolean - is - Val : Num; - pragma Unreferenced (Val); - begin - Val := To_Decimal (Item, Format); - return True; - exception - when Conversion_Error => - return False; - end Valid; - - --------------------- - -- Valid (display) -- - --------------------- - - function Valid - (Item : Numeric; - Format : Display_Format) return Boolean - is - begin - return Valid_Numeric (Item, Format); - end Valid; - - -------------------- - -- Valid (packed) -- - -------------------- - - function Valid - (Item : Packed_Decimal; - Format : Packed_Format) return Boolean - is - begin - return Valid_Packed (Item, Format); - end Valid; - - end Decimal_Conversions; - -end Interfaces.COBOL; diff --git a/gcc/ada/i-cobol.ads b/gcc/ada/i-cobol.ads deleted file mode 100644 index 9edcc01..0000000 --- a/gcc/ada/i-cobol.ads +++ /dev/null @@ -1,553 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C O B O L -- --- -- --- S p e c -- --- (ASCII Version) -- --- -- --- Copyright (C) 1993-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of the COBOL interfaces package assumes that the COBOL --- compiler uses ASCII as its internal representation of characters, i.e. --- that the type COBOL_Character has the same representation as the Ada --- type Standard.Character. - -package Interfaces.COBOL is - pragma Preelaborate (COBOL); - - ------------------------------------------------------------ - -- Types And Operations For Internal Data Representations -- - ------------------------------------------------------------ - - type Floating is new Float; - type Long_Floating is new Long_Float; - - type Binary is new Integer; - type Long_Binary is new Long_Long_Integer; - - Max_Digits_Binary : constant := 9; - Max_Digits_Long_Binary : constant := 18; - - type Decimal_Element is mod 2**4; - type Packed_Decimal is array (Positive range <>) of Decimal_Element; - pragma Pack (Packed_Decimal); - - type COBOL_Character is new Character; - - Ada_To_COBOL : array (Standard.Character) of COBOL_Character := ( - COBOL_Character'Val (000), COBOL_Character'Val (001), - COBOL_Character'Val (002), COBOL_Character'Val (003), - COBOL_Character'Val (004), COBOL_Character'Val (005), - COBOL_Character'Val (006), COBOL_Character'Val (007), - COBOL_Character'Val (008), COBOL_Character'Val (009), - COBOL_Character'Val (010), COBOL_Character'Val (011), - COBOL_Character'Val (012), COBOL_Character'Val (013), - COBOL_Character'Val (014), COBOL_Character'Val (015), - COBOL_Character'Val (016), COBOL_Character'Val (017), - COBOL_Character'Val (018), COBOL_Character'Val (019), - COBOL_Character'Val (020), COBOL_Character'Val (021), - COBOL_Character'Val (022), COBOL_Character'Val (023), - COBOL_Character'Val (024), COBOL_Character'Val (025), - COBOL_Character'Val (026), COBOL_Character'Val (027), - COBOL_Character'Val (028), COBOL_Character'Val (029), - COBOL_Character'Val (030), COBOL_Character'Val (031), - COBOL_Character'Val (032), COBOL_Character'Val (033), - COBOL_Character'Val (034), COBOL_Character'Val (035), - COBOL_Character'Val (036), COBOL_Character'Val (037), - COBOL_Character'Val (038), COBOL_Character'Val (039), - COBOL_Character'Val (040), COBOL_Character'Val (041), - COBOL_Character'Val (042), COBOL_Character'Val (043), - COBOL_Character'Val (044), COBOL_Character'Val (045), - COBOL_Character'Val (046), COBOL_Character'Val (047), - COBOL_Character'Val (048), COBOL_Character'Val (049), - COBOL_Character'Val (050), COBOL_Character'Val (051), - COBOL_Character'Val (052), COBOL_Character'Val (053), - COBOL_Character'Val (054), COBOL_Character'Val (055), - COBOL_Character'Val (056), COBOL_Character'Val (057), - COBOL_Character'Val (058), COBOL_Character'Val (059), - COBOL_Character'Val (060), COBOL_Character'Val (061), - COBOL_Character'Val (062), COBOL_Character'Val (063), - COBOL_Character'Val (064), COBOL_Character'Val (065), - COBOL_Character'Val (066), COBOL_Character'Val (067), - COBOL_Character'Val (068), COBOL_Character'Val (069), - COBOL_Character'Val (070), COBOL_Character'Val (071), - COBOL_Character'Val (072), COBOL_Character'Val (073), - COBOL_Character'Val (074), COBOL_Character'Val (075), - COBOL_Character'Val (076), COBOL_Character'Val (077), - COBOL_Character'Val (078), COBOL_Character'Val (079), - COBOL_Character'Val (080), COBOL_Character'Val (081), - COBOL_Character'Val (082), COBOL_Character'Val (083), - COBOL_Character'Val (084), COBOL_Character'Val (085), - COBOL_Character'Val (086), COBOL_Character'Val (087), - COBOL_Character'Val (088), COBOL_Character'Val (089), - COBOL_Character'Val (090), COBOL_Character'Val (091), - COBOL_Character'Val (092), COBOL_Character'Val (093), - COBOL_Character'Val (094), COBOL_Character'Val (095), - COBOL_Character'Val (096), COBOL_Character'Val (097), - COBOL_Character'Val (098), COBOL_Character'Val (099), - COBOL_Character'Val (100), COBOL_Character'Val (101), - COBOL_Character'Val (102), COBOL_Character'Val (103), - COBOL_Character'Val (104), COBOL_Character'Val (105), - COBOL_Character'Val (106), COBOL_Character'Val (107), - COBOL_Character'Val (108), COBOL_Character'Val (109), - COBOL_Character'Val (110), COBOL_Character'Val (111), - COBOL_Character'Val (112), COBOL_Character'Val (113), - COBOL_Character'Val (114), COBOL_Character'Val (115), - COBOL_Character'Val (116), COBOL_Character'Val (117), - COBOL_Character'Val (118), COBOL_Character'Val (119), - COBOL_Character'Val (120), COBOL_Character'Val (121), - COBOL_Character'Val (122), COBOL_Character'Val (123), - COBOL_Character'Val (124), COBOL_Character'Val (125), - COBOL_Character'Val (126), COBOL_Character'Val (127), - COBOL_Character'Val (128), COBOL_Character'Val (129), - COBOL_Character'Val (130), COBOL_Character'Val (131), - COBOL_Character'Val (132), COBOL_Character'Val (133), - COBOL_Character'Val (134), COBOL_Character'Val (135), - COBOL_Character'Val (136), COBOL_Character'Val (137), - COBOL_Character'Val (138), COBOL_Character'Val (139), - COBOL_Character'Val (140), COBOL_Character'Val (141), - COBOL_Character'Val (142), COBOL_Character'Val (143), - COBOL_Character'Val (144), COBOL_Character'Val (145), - COBOL_Character'Val (146), COBOL_Character'Val (147), - COBOL_Character'Val (148), COBOL_Character'Val (149), - COBOL_Character'Val (150), COBOL_Character'Val (151), - COBOL_Character'Val (152), COBOL_Character'Val (153), - COBOL_Character'Val (154), COBOL_Character'Val (155), - COBOL_Character'Val (156), COBOL_Character'Val (157), - COBOL_Character'Val (158), COBOL_Character'Val (159), - COBOL_Character'Val (160), COBOL_Character'Val (161), - COBOL_Character'Val (162), COBOL_Character'Val (163), - COBOL_Character'Val (164), COBOL_Character'Val (165), - COBOL_Character'Val (166), COBOL_Character'Val (167), - COBOL_Character'Val (168), COBOL_Character'Val (169), - COBOL_Character'Val (170), COBOL_Character'Val (171), - COBOL_Character'Val (172), COBOL_Character'Val (173), - COBOL_Character'Val (174), COBOL_Character'Val (175), - COBOL_Character'Val (176), COBOL_Character'Val (177), - COBOL_Character'Val (178), COBOL_Character'Val (179), - COBOL_Character'Val (180), COBOL_Character'Val (181), - COBOL_Character'Val (182), COBOL_Character'Val (183), - COBOL_Character'Val (184), COBOL_Character'Val (185), - COBOL_Character'Val (186), COBOL_Character'Val (187), - COBOL_Character'Val (188), COBOL_Character'Val (189), - COBOL_Character'Val (190), COBOL_Character'Val (191), - COBOL_Character'Val (192), COBOL_Character'Val (193), - COBOL_Character'Val (194), COBOL_Character'Val (195), - COBOL_Character'Val (196), COBOL_Character'Val (197), - COBOL_Character'Val (198), COBOL_Character'Val (199), - COBOL_Character'Val (200), COBOL_Character'Val (201), - COBOL_Character'Val (202), COBOL_Character'Val (203), - COBOL_Character'Val (204), COBOL_Character'Val (205), - COBOL_Character'Val (206), COBOL_Character'Val (207), - COBOL_Character'Val (208), COBOL_Character'Val (209), - COBOL_Character'Val (210), COBOL_Character'Val (211), - COBOL_Character'Val (212), COBOL_Character'Val (213), - COBOL_Character'Val (214), COBOL_Character'Val (215), - COBOL_Character'Val (216), COBOL_Character'Val (217), - COBOL_Character'Val (218), COBOL_Character'Val (219), - COBOL_Character'Val (220), COBOL_Character'Val (221), - COBOL_Character'Val (222), COBOL_Character'Val (223), - COBOL_Character'Val (224), COBOL_Character'Val (225), - COBOL_Character'Val (226), COBOL_Character'Val (227), - COBOL_Character'Val (228), COBOL_Character'Val (229), - COBOL_Character'Val (230), COBOL_Character'Val (231), - COBOL_Character'Val (232), COBOL_Character'Val (233), - COBOL_Character'Val (234), COBOL_Character'Val (235), - COBOL_Character'Val (236), COBOL_Character'Val (237), - COBOL_Character'Val (238), COBOL_Character'Val (239), - COBOL_Character'Val (240), COBOL_Character'Val (241), - COBOL_Character'Val (242), COBOL_Character'Val (243), - COBOL_Character'Val (244), COBOL_Character'Val (245), - COBOL_Character'Val (246), COBOL_Character'Val (247), - COBOL_Character'Val (248), COBOL_Character'Val (249), - COBOL_Character'Val (250), COBOL_Character'Val (251), - COBOL_Character'Val (252), COBOL_Character'Val (253), - COBOL_Character'Val (254), COBOL_Character'Val (255)); - - COBOL_To_Ada : array (COBOL_Character) of Standard.Character := ( - Standard.Character'Val (000), Standard.Character'Val (001), - Standard.Character'Val (002), Standard.Character'Val (003), - Standard.Character'Val (004), Standard.Character'Val (005), - Standard.Character'Val (006), Standard.Character'Val (007), - Standard.Character'Val (008), Standard.Character'Val (009), - Standard.Character'Val (010), Standard.Character'Val (011), - Standard.Character'Val (012), Standard.Character'Val (013), - Standard.Character'Val (014), Standard.Character'Val (015), - Standard.Character'Val (016), Standard.Character'Val (017), - Standard.Character'Val (018), Standard.Character'Val (019), - Standard.Character'Val (020), Standard.Character'Val (021), - Standard.Character'Val (022), Standard.Character'Val (023), - Standard.Character'Val (024), Standard.Character'Val (025), - Standard.Character'Val (026), Standard.Character'Val (027), - Standard.Character'Val (028), Standard.Character'Val (029), - Standard.Character'Val (030), Standard.Character'Val (031), - Standard.Character'Val (032), Standard.Character'Val (033), - Standard.Character'Val (034), Standard.Character'Val (035), - Standard.Character'Val (036), Standard.Character'Val (037), - Standard.Character'Val (038), Standard.Character'Val (039), - Standard.Character'Val (040), Standard.Character'Val (041), - Standard.Character'Val (042), Standard.Character'Val (043), - Standard.Character'Val (044), Standard.Character'Val (045), - Standard.Character'Val (046), Standard.Character'Val (047), - Standard.Character'Val (048), Standard.Character'Val (049), - Standard.Character'Val (050), Standard.Character'Val (051), - Standard.Character'Val (052), Standard.Character'Val (053), - Standard.Character'Val (054), Standard.Character'Val (055), - Standard.Character'Val (056), Standard.Character'Val (057), - Standard.Character'Val (058), Standard.Character'Val (059), - Standard.Character'Val (060), Standard.Character'Val (061), - Standard.Character'Val (062), Standard.Character'Val (063), - Standard.Character'Val (064), Standard.Character'Val (065), - Standard.Character'Val (066), Standard.Character'Val (067), - Standard.Character'Val (068), Standard.Character'Val (069), - Standard.Character'Val (070), Standard.Character'Val (071), - Standard.Character'Val (072), Standard.Character'Val (073), - Standard.Character'Val (074), Standard.Character'Val (075), - Standard.Character'Val (076), Standard.Character'Val (077), - Standard.Character'Val (078), Standard.Character'Val (079), - Standard.Character'Val (080), Standard.Character'Val (081), - Standard.Character'Val (082), Standard.Character'Val (083), - Standard.Character'Val (084), Standard.Character'Val (085), - Standard.Character'Val (086), Standard.Character'Val (087), - Standard.Character'Val (088), Standard.Character'Val (089), - Standard.Character'Val (090), Standard.Character'Val (091), - Standard.Character'Val (092), Standard.Character'Val (093), - Standard.Character'Val (094), Standard.Character'Val (095), - Standard.Character'Val (096), Standard.Character'Val (097), - Standard.Character'Val (098), Standard.Character'Val (099), - Standard.Character'Val (100), Standard.Character'Val (101), - Standard.Character'Val (102), Standard.Character'Val (103), - Standard.Character'Val (104), Standard.Character'Val (105), - Standard.Character'Val (106), Standard.Character'Val (107), - Standard.Character'Val (108), Standard.Character'Val (109), - Standard.Character'Val (110), Standard.Character'Val (111), - Standard.Character'Val (112), Standard.Character'Val (113), - Standard.Character'Val (114), Standard.Character'Val (115), - Standard.Character'Val (116), Standard.Character'Val (117), - Standard.Character'Val (118), Standard.Character'Val (119), - Standard.Character'Val (120), Standard.Character'Val (121), - Standard.Character'Val (122), Standard.Character'Val (123), - Standard.Character'Val (124), Standard.Character'Val (125), - Standard.Character'Val (126), Standard.Character'Val (127), - Standard.Character'Val (128), Standard.Character'Val (129), - Standard.Character'Val (130), Standard.Character'Val (131), - Standard.Character'Val (132), Standard.Character'Val (133), - Standard.Character'Val (134), Standard.Character'Val (135), - Standard.Character'Val (136), Standard.Character'Val (137), - Standard.Character'Val (138), Standard.Character'Val (139), - Standard.Character'Val (140), Standard.Character'Val (141), - Standard.Character'Val (142), Standard.Character'Val (143), - Standard.Character'Val (144), Standard.Character'Val (145), - Standard.Character'Val (146), Standard.Character'Val (147), - Standard.Character'Val (148), Standard.Character'Val (149), - Standard.Character'Val (150), Standard.Character'Val (151), - Standard.Character'Val (152), Standard.Character'Val (153), - Standard.Character'Val (154), Standard.Character'Val (155), - Standard.Character'Val (156), Standard.Character'Val (157), - Standard.Character'Val (158), Standard.Character'Val (159), - Standard.Character'Val (160), Standard.Character'Val (161), - Standard.Character'Val (162), Standard.Character'Val (163), - Standard.Character'Val (164), Standard.Character'Val (165), - Standard.Character'Val (166), Standard.Character'Val (167), - Standard.Character'Val (168), Standard.Character'Val (169), - Standard.Character'Val (170), Standard.Character'Val (171), - Standard.Character'Val (172), Standard.Character'Val (173), - Standard.Character'Val (174), Standard.Character'Val (175), - Standard.Character'Val (176), Standard.Character'Val (177), - Standard.Character'Val (178), Standard.Character'Val (179), - Standard.Character'Val (180), Standard.Character'Val (181), - Standard.Character'Val (182), Standard.Character'Val (183), - Standard.Character'Val (184), Standard.Character'Val (185), - Standard.Character'Val (186), Standard.Character'Val (187), - Standard.Character'Val (188), Standard.Character'Val (189), - Standard.Character'Val (190), Standard.Character'Val (191), - Standard.Character'Val (192), Standard.Character'Val (193), - Standard.Character'Val (194), Standard.Character'Val (195), - Standard.Character'Val (196), Standard.Character'Val (197), - Standard.Character'Val (198), Standard.Character'Val (199), - Standard.Character'Val (200), Standard.Character'Val (201), - Standard.Character'Val (202), Standard.Character'Val (203), - Standard.Character'Val (204), Standard.Character'Val (205), - Standard.Character'Val (206), Standard.Character'Val (207), - Standard.Character'Val (208), Standard.Character'Val (209), - Standard.Character'Val (210), Standard.Character'Val (211), - Standard.Character'Val (212), Standard.Character'Val (213), - Standard.Character'Val (214), Standard.Character'Val (215), - Standard.Character'Val (216), Standard.Character'Val (217), - Standard.Character'Val (218), Standard.Character'Val (219), - Standard.Character'Val (220), Standard.Character'Val (221), - Standard.Character'Val (222), Standard.Character'Val (223), - Standard.Character'Val (224), Standard.Character'Val (225), - Standard.Character'Val (226), Standard.Character'Val (227), - Standard.Character'Val (228), Standard.Character'Val (229), - Standard.Character'Val (230), Standard.Character'Val (231), - Standard.Character'Val (232), Standard.Character'Val (233), - Standard.Character'Val (234), Standard.Character'Val (235), - Standard.Character'Val (236), Standard.Character'Val (237), - Standard.Character'Val (238), Standard.Character'Val (239), - Standard.Character'Val (240), Standard.Character'Val (241), - Standard.Character'Val (242), Standard.Character'Val (243), - Standard.Character'Val (244), Standard.Character'Val (245), - Standard.Character'Val (246), Standard.Character'Val (247), - Standard.Character'Val (248), Standard.Character'Val (249), - Standard.Character'Val (250), Standard.Character'Val (251), - Standard.Character'Val (252), Standard.Character'Val (253), - Standard.Character'Val (254), Standard.Character'Val (255)); - - type Alphanumeric is array (Positive range <>) of COBOL_Character; - -- pragma Pack (Alphanumeric); - - function To_COBOL (Item : String) return Alphanumeric; - function To_Ada (Item : Alphanumeric) return String; - - procedure To_COBOL - (Item : String; - Target : out Alphanumeric; - Last : out Natural); - - procedure To_Ada - (Item : Alphanumeric; - Target : out String; - Last : out Natural); - - type Numeric is array (Positive range <>) of COBOL_Character; - -- pragma Pack (Numeric); - - -------------------------------------------- - -- Formats For COBOL Data Representations -- - -------------------------------------------- - - type Display_Format is private; - - Unsigned : constant Display_Format; - Leading_Separate : constant Display_Format; - Trailing_Separate : constant Display_Format; - Leading_Nonseparate : constant Display_Format; - Trailing_Nonseparate : constant Display_Format; - - type Binary_Format is private; - - High_Order_First : constant Binary_Format; - Low_Order_First : constant Binary_Format; - Native_Binary : constant Binary_Format; - High_Order_First_Unsigned : constant Binary_Format; - Low_Order_First_Unsigned : constant Binary_Format; - Native_Binary_Unsigned : constant Binary_Format; - - type Packed_Format is private; - - Packed_Unsigned : constant Packed_Format; - Packed_Signed : constant Packed_Format; - - ------------------------------------------------------------ - -- Types For External Representation Of COBOL Binary Data -- - ------------------------------------------------------------ - - type Byte is mod 2 ** COBOL_Character'Size; - type Byte_Array is array (Positive range <>) of Byte; - -- pragma Pack (Byte_Array); - - Conversion_Error : exception; - - generic - type Num is delta <> digits <>; - - package Decimal_Conversions is - - -- Display Formats: data values are represented as Numeric - - function Valid - (Item : Numeric; - Format : Display_Format) return Boolean; - - function Length - (Format : Display_Format) return Natural; - - function To_Decimal - (Item : Numeric; - Format : Display_Format) - return Num; - - function To_Display - (Item : Num; - Format : Display_Format) return Numeric; - - -- Packed Formats: data values are represented as Packed_Decimal - - function Valid - (Item : Packed_Decimal; - Format : Packed_Format) return Boolean; - - function Length - (Format : Packed_Format) return Natural; - - function To_Decimal - (Item : Packed_Decimal; - Format : Packed_Format) return Num; - - function To_Packed - (Item : Num; - Format : Packed_Format) return Packed_Decimal; - - -- Binary Formats: external data values are represented as Byte_Array - - function Valid - (Item : Byte_Array; - Format : Binary_Format) return Boolean; - - function Length - (Format : Binary_Format) - return Natural; - - function To_Decimal - (Item : Byte_Array; - Format : Binary_Format) return Num; - - function To_Binary - (Item : Num; - Format : Binary_Format) return Byte_Array; - - -- Internal Binary formats: data values are of type Binary/Long_Binary - - function To_Decimal (Item : Binary) return Num; - function To_Decimal (Item : Long_Binary) return Num; - - function To_Binary (Item : Num) return Binary; - function To_Long_Binary (Item : Num) return Long_Binary; - - private - pragma Inline (Length); - pragma Inline (To_Binary); - pragma Inline (To_Decimal); - pragma Inline (To_Display); - pragma Inline (To_Long_Binary); - pragma Inline (Valid); - - end Decimal_Conversions; - - ------------------------------------------ - -- Implementation Dependent Definitions -- - ------------------------------------------ - - -- The implementation dependent definitions are wholly contained in the - -- private part of this spec (the body is implementation independent) - -private - ------------------- - -- Binary Format -- - ------------------- - - type Binary_Format is (H, L, N, HU, LU, NU); - - subtype Binary_Unsigned_Format is Binary_Format range HU .. NU; - - High_Order_First : constant Binary_Format := H; - Low_Order_First : constant Binary_Format := L; - Native_Binary : constant Binary_Format := N; - High_Order_First_Unsigned : constant Binary_Format := HU; - Low_Order_First_Unsigned : constant Binary_Format := LU; - Native_Binary_Unsigned : constant Binary_Format := NU; - - --------------------------- - -- Packed Decimal Format -- - --------------------------- - - -- Packed decimal numbers use the IBM mainframe format: - - -- dd dd ... dd dd ds - - -- where d are the Digits, in natural left to right order, and s is - -- the sign digit. If the number of Digits os even, then the high - -- order (leftmost) Digits is always a 0. For example, a six digit - -- number has the format: - - -- 0d dd dd ds - - -- The sign digit has the possible values - - -- 16#0A# non-standard plus sign - -- 16#0B# non-standard minus sign - -- 16#0C# standard plus sign - -- 16#0D# standard minus sign - -- 16#0E# non-standard plus sign - -- 16#0F# standard unsigned sign - - -- The non-standard signs are recognized on input, but never generated - -- for output numbers. The 16#0F# distinguishes unsigned numbers from - -- signed positive numbers, but is treated as positive for computational - -- purposes. This format provides distinguished positive and negative - -- zero values, which behave the same in all operations. - - type Packed_Format is (U, S); - - Packed_Unsigned : constant Packed_Format := U; - Packed_Signed : constant Packed_Format := S; - - type Packed_Representation_Type is (IBM); - -- Indicator for format used for packed decimal - - Packed_Representation : constant Packed_Representation_Type := IBM; - -- This version of the spec uses IBM internal format, as described above - - ----------------------------- - -- Display Decimal Formats -- - ----------------------------- - - -- Display numbers are stored in standard ASCII format, as ASCII strings. - -- For the embedded signs, the following codes are used: - - -- 0-9 positive: 16#30# .. 16#39# (i.e. natural ASCII digit code) - -- 0-9 negative: 16#20# .. 16#29# (ASCII digit code - 16#10#) - - type Display_Format is (U, LS, TS, LN, TN); - - Unsigned : constant Display_Format := U; - Leading_Separate : constant Display_Format := LS; - Trailing_Separate : constant Display_Format := TS; - Leading_Nonseparate : constant Display_Format := LN; - Trailing_Nonseparate : constant Display_Format := TN; - - subtype COBOL_Digits is COBOL_Character range '0' .. '9'; - -- Digit values in display decimal - - COBOL_Space : constant COBOL_Character := ' '; - COBOL_Plus : constant COBOL_Character := '+'; - COBOL_Minus : constant COBOL_Character := '-'; - -- Sign values for Leading_Separate and Trailing_Separate formats - - subtype COBOL_Plus_Digits is COBOL_Character - range COBOL_Character'Val (16#30#) .. COBOL_Character'Val (16#39#); - -- Values used for embedded plus signs in nonseparate formats - - subtype COBOL_Minus_Digits is COBOL_Character - range COBOL_Character'Val (16#20#) .. COBOL_Character'Val (16#29#); - -- Values used for embedded minus signs in nonseparate formats - -end Interfaces.COBOL; diff --git a/gcc/ada/i-cpoint.adb b/gcc/ada/i-cpoint.adb deleted file mode 100644 index ddf33da..0000000 --- a/gcc/ada/i-cpoint.adb +++ /dev/null @@ -1,295 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C . P O I N T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C.Strings; use Interfaces.C.Strings; -with System; use System; - -with Ada.Unchecked_Conversion; - -package body Interfaces.C.Pointers is - - type Addr is mod 2 ** System.Parameters.ptr_bits; - - function To_Pointer is new Ada.Unchecked_Conversion (Addr, Pointer); - function To_Addr is new Ada.Unchecked_Conversion (Pointer, Addr); - function To_Addr is new Ada.Unchecked_Conversion (ptrdiff_t, Addr); - function To_Ptrdiff is new Ada.Unchecked_Conversion (Addr, ptrdiff_t); - - Elmt_Size : constant ptrdiff_t := - (Element_Array'Component_Size - + Storage_Unit - 1) / Storage_Unit; - - subtype Index_Base is Index'Base; - - --------- - -- "+" -- - --------- - - function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer is - begin - if Left = null then - raise Pointer_Error; - end if; - - return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right)); - end "+"; - - function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer is - begin - if Right = null then - raise Pointer_Error; - end if; - - return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right)); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer is - begin - if Left = null then - raise Pointer_Error; - end if; - - return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size)); - end "-"; - - function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t is - begin - if Left = null or else Right = null then - raise Pointer_Error; - end if; - - return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size; - end "-"; - - ---------------- - -- Copy_Array -- - ---------------- - - procedure Copy_Array - (Source : Pointer; - Target : Pointer; - Length : ptrdiff_t) - is - T : Pointer; - S : Pointer; - - begin - if Source = null or else Target = null then - raise Dereference_Error; - - -- Forward copy - - elsif To_Addr (Target) <= To_Addr (Source) then - T := Target; - S := Source; - for J in 1 .. Length loop - T.all := S.all; - Increment (T); - Increment (S); - end loop; - - -- Backward copy - - else - T := Target + Length; - S := Source + Length; - for J in 1 .. Length loop - Decrement (T); - Decrement (S); - T.all := S.all; - end loop; - end if; - end Copy_Array; - - --------------------------- - -- Copy_Terminated_Array -- - --------------------------- - - procedure Copy_Terminated_Array - (Source : Pointer; - Target : Pointer; - Limit : ptrdiff_t := ptrdiff_t'Last; - Terminator : Element := Default_Terminator) - is - L : ptrdiff_t; - S : Pointer := Source; - - begin - if Source = null or Target = null then - raise Dereference_Error; - end if; - - -- Compute array limited length (including the terminator) - - L := 0; - while L < Limit loop - L := L + 1; - exit when S.all = Terminator; - Increment (S); - end loop; - - Copy_Array (Source, Target, L); - end Copy_Terminated_Array; - - --------------- - -- Decrement -- - --------------- - - procedure Decrement (Ref : in out Pointer) is - begin - Ref := Ref - 1; - end Decrement; - - --------------- - -- Increment -- - --------------- - - procedure Increment (Ref : in out Pointer) is - begin - Ref := Ref + 1; - end Increment; - - ----------- - -- Value -- - ----------- - - function Value - (Ref : Pointer; - Terminator : Element := Default_Terminator) return Element_Array - is - P : Pointer; - L : constant Index_Base := Index'First; - H : Index_Base; - - begin - if Ref = null then - raise Dereference_Error; - - else - H := L; - P := Ref; - - loop - exit when P.all = Terminator; - H := Index_Base'Succ (H); - Increment (P); - end loop; - - declare - subtype A is Element_Array (L .. H); - - type PA is access A; - for PA'Size use System.Parameters.ptr_bits; - function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); - - begin - return To_PA (Ref).all; - end; - end if; - end Value; - - function Value - (Ref : Pointer; - Length : ptrdiff_t) return Element_Array - is - L : Index_Base; - H : Index_Base; - - begin - if Ref = null then - raise Dereference_Error; - - -- For length zero, we need to return a null slice, but we can't make - -- the bounds of this slice Index'First, since this could cause a - -- Constraint_Error if Index'First = Index'Base'First. - - elsif Length <= 0 then - declare - pragma Warnings (Off); -- kill warnings since X not assigned - X : Element_Array (Index'Succ (Index'First) .. Index'First); - pragma Warnings (On); - - begin - return X; - end; - - -- Normal case (length non-zero) - - else - L := Index'First; - H := Index'Val (Index'Pos (Index'First) + Length - 1); - - declare - subtype A is Element_Array (L .. H); - - type PA is access A; - for PA'Size use System.Parameters.ptr_bits; - function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); - - begin - return To_PA (Ref).all; - end; - end if; - end Value; - - -------------------- - -- Virtual_Length -- - -------------------- - - function Virtual_Length - (Ref : Pointer; - Terminator : Element := Default_Terminator) return ptrdiff_t - is - P : Pointer; - C : ptrdiff_t; - - begin - if Ref = null then - raise Dereference_Error; - - else - C := 0; - P := Ref; - - while P.all /= Terminator loop - C := C + 1; - Increment (P); - end loop; - - return C; - end if; - end Virtual_Length; - -end Interfaces.C.Pointers; diff --git a/gcc/ada/i-cpoint.ads b/gcc/ada/i-cpoint.ads deleted file mode 100644 index b3943b5..0000000 --- a/gcc/ada/i-cpoint.ads +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C . P O I N T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1993-2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Parameters; - -generic - type Index is (<>); - type Element is private; - type Element_Array is array (Index range <>) of aliased Element; - Default_Terminator : Element; - -package Interfaces.C.Pointers is - pragma Preelaborate; - - type Pointer is access all Element; - for Pointer'Size use System.Parameters.ptr_bits; - - pragma No_Strict_Aliasing (Pointer); - -- We turn off any strict aliasing assumptions for the pointer type, - -- since it is possible to create "improperly" aliased values. - - function Value - (Ref : Pointer; - Terminator : Element := Default_Terminator) return Element_Array; - - function Value - (Ref : Pointer; - Length : ptrdiff_t) return Element_Array; - - Pointer_Error : exception; - - -------------------------------- - -- C-style Pointer Arithmetic -- - -------------------------------- - - function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer; - function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer; - function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer; - function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t; - - procedure Increment (Ref : in out Pointer); - procedure Decrement (Ref : in out Pointer); - - pragma Convention (Intrinsic, "+"); - pragma Convention (Intrinsic, "-"); - pragma Convention (Intrinsic, Increment); - pragma Convention (Intrinsic, Decrement); - - function Virtual_Length - (Ref : Pointer; - Terminator : Element := Default_Terminator) return ptrdiff_t; - - procedure Copy_Terminated_Array - (Source : Pointer; - Target : Pointer; - Limit : ptrdiff_t := ptrdiff_t'Last; - Terminator : Element := Default_Terminator); - - procedure Copy_Array - (Source : Pointer; - Target : Pointer; - Length : ptrdiff_t); - -private - pragma Inline ("+"); - pragma Inline ("-"); - pragma Inline (Decrement); - pragma Inline (Increment); - -end Interfaces.C.Pointers; diff --git a/gcc/ada/i-cstrea.adb b/gcc/ada/i-cstrea.adb deleted file mode 100644 index d831206..0000000 --- a/gcc/ada/i-cstrea.adb +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C _ S T R E A M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body Interfaces.C_Streams is - - use type System.CRTL.size_t; - - ---------------------------- - -- Interfaced C functions -- - ---------------------------- - - function C_fread - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - pragma Import (C, C_fread, "fread"); - - function C_fwrite - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - pragma Import (C, C_fwrite, "fwrite"); - - function C_setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int; - pragma Import (C, C_setvbuf, "setvbuf"); - - ------------ - -- fread -- - ------------ - - function fread - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return C_fread (buffer, size, count, stream); - end fread; - - ------------ - -- fread -- - ------------ - - -- The following declarations should really be nested within fread, but - -- limitations in front end inlining make this undesirable right now ??? - - type Byte_Buffer is array (0 .. size_t'Last / 2 - 1) of Unsigned_8; - -- This should really be 0 .. size_t'last, but there is a problem - -- in gigi in handling such types (introduced in GCC 3 Sep 2001) - -- since the size in bytes of this array overflows ??? - - type Acc_Bytes is access all Byte_Buffer; - - function To_Acc_Bytes is new Ada.Unchecked_Conversion (voids, Acc_Bytes); - - function fread - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return C_fread - (To_Acc_Bytes (buffer) (index * size)'Address, size, count, stream); - end fread; - - ------------ - -- fwrite -- - ------------ - - function fwrite - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t - is - begin - return C_fwrite (buffer, size, count, stream); - end fwrite; - - ------------- - -- setvbuf -- - ------------- - - function setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int - is - begin - return C_setvbuf (stream, buffer, mode, size); - end setvbuf; - -end Interfaces.C_Streams; diff --git a/gcc/ada/i-cstrea.ads b/gcc/ada/i-cstrea.ads deleted file mode 100644 index 5927e5f..0000000 --- a/gcc/ada/i-cstrea.ads +++ /dev/null @@ -1,315 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C _ S T R E A M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is a thin binding to selected functions in the C --- library that provide a complete interface for handling C streams. - -with System.CRTL; - -package Interfaces.C_Streams is - pragma Preelaborate; - - subtype chars is System.CRTL.chars; - subtype FILEs is System.CRTL.FILEs; - subtype int is System.CRTL.int; - subtype long is System.CRTL.long; - subtype size_t is System.CRTL.size_t; - subtype ssize_t is System.CRTL.ssize_t; - subtype int64 is System.CRTL.int64; - subtype voids is System.Address; - - NULL_Stream : constant FILEs; - -- Value returned (NULL in C) to indicate an fdopen/fopen/tmpfile error - - ---------------------------------- - -- Constants Defined in stdio.h -- - ---------------------------------- - - EOF : constant int; - -- Used by a number of routines to indicate error or end of file - - IOFBF : constant int; - IOLBF : constant int; - IONBF : constant int; - -- Used to indicate buffering mode for setvbuf call - - L_tmpnam : constant int; - -- Maximum length of file name that can be returned by tmpnam - - SEEK_CUR : constant int; - SEEK_END : constant int; - SEEK_SET : constant int; - -- Used to indicate origin for fseek call - - function stdin return FILEs; - function stdout return FILEs; - function stderr return FILEs; - -- Streams associated with standard files - - -------------------------- - -- Standard C functions -- - -------------------------- - - -- The functions selected below are ones that are available in - -- UNIX (but not necessarily in ANSI C). These are very thin - -- interfaces which copy exactly the C headers. For more - -- documentation on these functions, see the Microsoft C "Run-Time - -- Library Reference" (Microsoft Press, 1990, ISBN 1-55615-225-6), - -- which includes useful information on system compatibility. - - procedure clearerr (stream : FILEs) renames System.CRTL.clearerr; - - function fclose (stream : FILEs) return int renames System.CRTL.fclose; - - function fdopen (handle : int; mode : chars) return FILEs - renames System.CRTL.fdopen; - - function feof (stream : FILEs) return int; - - function ferror (stream : FILEs) return int; - - function fflush (stream : FILEs) return int renames System.CRTL.fflush; - - function fgetc (stream : FILEs) return int renames System.CRTL.fgetc; - - function fgets (strng : chars; n : int; stream : FILEs) return chars - renames System.CRTL.fgets; - - function fileno (stream : FILEs) return int; - - function fopen - (filename : chars; - mode : chars; - encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) - return FILEs renames System.CRTL.fopen; - -- Note: to maintain target independence, use text_translation_required, - -- a boolean variable defined in sysdep.c to deal with the target - -- dependent text translation requirement. If this variable is set, - -- then b/t should be appended to the standard mode argument to set - -- the text translation mode off or on as required. - - function fputc (C : int; stream : FILEs) return int - renames System.CRTL.fputc; - - function fputwc (C : int; stream : FILEs) return int - renames System.CRTL.fputwc; - - function fputs (Strng : chars; Stream : FILEs) return int - renames System.CRTL.fputs; - - function fread - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function fread - (buffer : voids; - index : size_t; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - -- Same as normal fread, but has a parameter 'index' that indicates - -- the starting index for the read within 'buffer' (which must be the - -- address of the beginning of a whole array object with an assumed - -- zero base). This is needed for systems that do not support taking - -- the address of an element within an array. - - function freopen - (filename : chars; - mode : chars; - stream : FILEs; - encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) - return FILEs renames System.CRTL.freopen; - - function fseek - (stream : FILEs; - offset : long; - origin : int) return int - renames System.CRTL.fseek; - - function fseek64 - (stream : FILEs; - offset : int64; - origin : int) return int - renames System.CRTL.fseek64; - - function ftell (stream : FILEs) return long - renames System.CRTL.ftell; - - function ftell64 (stream : FILEs) return int64 - renames System.CRTL.ftell64; - - function fwrite - (buffer : voids; - size : size_t; - count : size_t; - stream : FILEs) return size_t; - - function isatty (handle : int) return int renames System.CRTL.isatty; - - procedure mktemp (template : chars) renames System.CRTL.mktemp; - -- The return value (which is just a pointer to template) is discarded - - procedure rewind (stream : FILEs) renames System.CRTL.rewind; - - function setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int; - - procedure tmpnam (str : chars) renames System.CRTL.tmpnam; - -- The parameter must be a pointer to a string buffer of at least L_tmpnam - -- bytes (the call with a null parameter is not supported). The returned - -- value, which is just a copy of the input argument, is discarded. - - function tmpfile return FILEs renames System.CRTL.tmpfile; - - function ungetc (c : int; stream : FILEs) return int - renames System.CRTL.ungetc; - - function unlink (filename : chars) return int - renames System.CRTL.unlink; - - --------------------- - -- Extra functions -- - --------------------- - - -- These functions supply slightly thicker bindings than those above. - -- They are derived from functions in the C Run-Time Library, but may - -- do a bit more work than just directly calling one of the Library - -- functions. - - function file_exists (name : chars) return int; - -- Tests if given name corresponds to an existing file - - function is_regular_file (handle : int) return int; - -- Tests if given handle is for a regular file (result 1) or for a - -- non-regular file (pipe or device, result 0). - - --------------------------------- - -- Control of Text/Binary Mode -- - --------------------------------- - - procedure set_binary_mode (handle : int); - procedure set_text_mode (handle : int); - -- If text_translation_required is true, then these two functions may - -- be used to dynamically switch a file from binary to text mode or vice - -- versa. These functions have no effect if text_translation_required is - -- false (e.g. in normal unix mode). Use fileno to get a stream handle. - - type Content_Encoding is (None, Default_Text, Text, U8text, Wtext, U16text); - for Content_Encoding use (0, 1, 2, 3, 4, 5); - pragma Convention (C, Content_Encoding); - -- Content_Encoding describes the text encoding for file content: - -- None : No text encoding, this file is treated as a binary file - -- Default_Text : A text file but not from Text_Translation form string - -- In this mode we are eventually using the system-wide - -- translation if activated. - -- Text : Text encoding activated - -- Wtext : Unicode mode - -- U16text : Unicode UTF-16 encoding - -- U8text : Unicode UTF-8 encoding - -- - -- This encoding is system dependent and only used on Windows systems. - -- - -- Note that modifications to Content_Encoding must be synchronized with - -- sysdep.c:__gnat_set_mode. - - subtype Text_Content_Encoding - is Content_Encoding range Default_Text .. U16text; - - subtype Non_Default_Text_Content_Encoding - is Content_Encoding range Text .. U16text; - - procedure set_mode (handle : int; Mode : Content_Encoding); - -- As above but can set the handle to any mode. On Windows this can be used - -- to have proper 16-bit wide-string output on the console for example. - - ---------------------------- - -- Full Path Name support -- - ---------------------------- - - procedure full_name (nam : chars; buffer : chars); - -- Given a NUL terminated string representing a file name, returns in - -- buffer a NUL terminated string representing the full path name for - -- the file name. On systems where it is relevant the drive is also part - -- of the full path name. It is the responsibility of the caller to - -- pass an actual parameter for buffer that is big enough for any full - -- path name. Use max_path_len given below as the size of buffer. - - max_path_len : constant Integer; - -- Maximum length of an allowable full path name on the system,including a - -- terminating NUL character. Declared as a constant to allow references - -- from other preelaborated GNAT library packages. - -private - -- The following functions are specialized in the body depending on the - -- operating system. - - pragma Inline (fread); - pragma Inline (fwrite); - pragma Inline (setvbuf); - - pragma Import (C, file_exists, "__gnat_file_exists"); - pragma Import (C, is_regular_file, "__gnat_is_regular_file_fd"); - - pragma Import (C, set_binary_mode, "__gnat_set_binary_mode"); - pragma Import (C, set_text_mode, "__gnat_set_text_mode"); - pragma Import (C, set_mode, "__gnat_set_mode"); - - pragma Import (C, max_path_len, "__gnat_max_path_len"); - pragma Import (C, full_name, "__gnat_full_name"); - - -- The following may be implemented as macros, and so are supported - -- via an interface function in the a-cstrea.c file. - - pragma Import (C, feof, "__gnat_feof"); - pragma Import (C, ferror, "__gnat_ferror"); - pragma Import (C, fileno, "__gnat_fileno"); - - pragma Import (C, EOF, "__gnat_constant_eof"); - pragma Import (C, IOFBF, "__gnat_constant_iofbf"); - pragma Import (C, IOLBF, "__gnat_constant_iolbf"); - pragma Import (C, IONBF, "__gnat_constant_ionbf"); - pragma Import (C, SEEK_CUR, "__gnat_constant_seek_cur"); - pragma Import (C, SEEK_END, "__gnat_constant_seek_end"); - pragma Import (C, SEEK_SET, "__gnat_constant_seek_set"); - pragma Import (C, L_tmpnam, "__gnat_constant_l_tmpnam"); - - pragma Import (C, stderr, "__gnat_constant_stderr"); - pragma Import (C, stdin, "__gnat_constant_stdin"); - pragma Import (C, stdout, "__gnat_constant_stdout"); - - NULL_Stream : constant FILEs := System.Null_Address; - -end Interfaces.C_Streams; diff --git a/gcc/ada/i-cstrin.adb b/gcc/ada/i-cstrin.adb deleted file mode 100644 index a270506..0000000 --- a/gcc/ada/i-cstrin.adb +++ /dev/null @@ -1,360 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C . S T R I N G S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; - -with Ada.Unchecked_Conversion; - -package body Interfaces.C.Strings is - - -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in the - -- spec, to prevent any assumptions about aliasing for values of this type, - -- since arbitrary addresses can be converted, and it is quite likely that - -- this type will in fact be used for aliasing values of other types. - - function To_chars_ptr is - new Ada.Unchecked_Conversion (System.Parameters.C_Address, chars_ptr); - - function To_Address is - new Ada.Unchecked_Conversion (chars_ptr, System.Parameters.C_Address); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Peek (From : chars_ptr) return char; - pragma Inline (Peek); - -- Given a chars_ptr value, obtain referenced character - - procedure Poke (Value : char; Into : chars_ptr); - pragma Inline (Poke); - -- Given a chars_ptr, modify referenced Character value - - function "+" (Left : chars_ptr; Right : size_t) return chars_ptr; - pragma Inline ("+"); - -- Address arithmetic on chars_ptr value - - function Position_Of_Nul (Into : char_array) return size_t; - -- Returns position of the first Nul in Into or Into'Last + 1 if none - - -- We can't use directly System.Memory because the categorization is not - -- compatible, so we directly import here the malloc and free routines. - - function Memory_Alloc (Size : size_t) return chars_ptr; - pragma Import (C, Memory_Alloc, System.Parameters.C_Malloc_Linkname); - - procedure Memory_Free (Address : chars_ptr); - pragma Import (C, Memory_Free, "__gnat_free"); - - --------- - -- "+" -- - --------- - - function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is - begin - return To_chars_ptr (To_Address (Left) + Storage_Offset (Right)); - end "+"; - - ---------- - -- Free -- - ---------- - - procedure Free (Item : in out chars_ptr) is - begin - if Item = Null_Ptr then - return; - end if; - - Memory_Free (Item); - Item := Null_Ptr; - end Free; - - -------------------- - -- New_Char_Array -- - -------------------- - - function New_Char_Array (Chars : char_array) return chars_ptr is - Index : size_t; - Pointer : chars_ptr; - - begin - -- Get index of position of null. If Index > Chars'Last, - -- nul is absent and must be added explicitly. - - Index := Position_Of_Nul (Into => Chars); - Pointer := Memory_Alloc ((Index - Chars'First + 1)); - - -- If nul is present, transfer string up to and including nul - - if Index <= Chars'Last then - Update (Item => Pointer, - Offset => 0, - Chars => Chars (Chars'First .. Index), - Check => False); - else - -- If original string has no nul, transfer whole string and add - -- terminator explicitly. - - Update (Item => Pointer, - Offset => 0, - Chars => Chars, - Check => False); - Poke (nul, Into => Pointer + size_t'(Chars'Length)); - end if; - - return Pointer; - end New_Char_Array; - - ---------------- - -- New_String -- - ---------------- - - function New_String (Str : String) return chars_ptr is - - -- It's important that this subprogram uses the heap directly to compute - -- the result, and doesn't copy the string on the stack, otherwise its - -- use is limited when used from tasks on large strings. - - Result : constant chars_ptr := Memory_Alloc (Str'Length + 1); - - Result_Array : char_array (1 .. Str'Length + 1); - for Result_Array'Address use To_Address (Result); - pragma Import (Ada, Result_Array); - - Count : size_t; - - begin - To_C - (Item => Str, - Target => Result_Array, - Count => Count, - Append_Nul => True); - return Result; - end New_String; - - ---------- - -- Peek -- - ---------- - - function Peek (From : chars_ptr) return char is - begin - return char (From.all); - end Peek; - - ---------- - -- Poke -- - ---------- - - procedure Poke (Value : char; Into : chars_ptr) is - begin - Into.all := Character (Value); - end Poke; - - --------------------- - -- Position_Of_Nul -- - --------------------- - - function Position_Of_Nul (Into : char_array) return size_t is - begin - for J in Into'Range loop - if Into (J) = nul then - return J; - end if; - end loop; - - return Into'Last + 1; - end Position_Of_Nul; - - ------------ - -- Strlen -- - ------------ - - function Strlen (Item : chars_ptr) return size_t is - Item_Index : size_t := 0; - - begin - if Item = Null_Ptr then - raise Dereference_Error; - end if; - - loop - if Peek (Item + Item_Index) = nul then - return Item_Index; - end if; - - Item_Index := Item_Index + 1; - end loop; - end Strlen; - - ------------------ - -- To_Chars_Ptr -- - ------------------ - - function To_Chars_Ptr - (Item : char_array_access; - Nul_Check : Boolean := False) return chars_ptr - is - begin - if Item = null then - return Null_Ptr; - elsif Nul_Check - and then Position_Of_Nul (Into => Item.all) > Item'Last - then - raise Terminator_Error; - else - return To_chars_ptr (Item (Item'First)'Address); - end if; - end To_Chars_Ptr; - - ------------ - -- Update -- - ------------ - - procedure Update - (Item : chars_ptr; - Offset : size_t; - Chars : char_array; - Check : Boolean := True) - is - Index : chars_ptr := Item + Offset; - - begin - if Check and then Offset + Chars'Length > Strlen (Item) then - raise Update_Error; - end if; - - for J in Chars'Range loop - Poke (Chars (J), Into => Index); - Index := Index + size_t'(1); - end loop; - end Update; - - procedure Update - (Item : chars_ptr; - Offset : size_t; - Str : String; - Check : Boolean := True) - is - begin - -- Note: in RM 95, the Append_Nul => False parameter is omitted. But - -- this has the unintended consequence of truncating the string after - -- an update. As discussed in Ada 2005 AI-242, this was unintended, - -- and should be corrected. Since this is a clear error, it seems - -- appropriate to apply the correction in Ada 95 mode as well. - - Update (Item, Offset, To_C (Str, Append_Nul => False), Check); - end Update; - - ----------- - -- Value -- - ----------- - - function Value (Item : chars_ptr) return char_array is - Result : char_array (0 .. Strlen (Item)); - - begin - if Item = Null_Ptr then - raise Dereference_Error; - end if; - - -- Note that the following loop will also copy the terminating Nul - - for J in Result'Range loop - Result (J) := Peek (Item + J); - end loop; - - return Result; - end Value; - - function Value - (Item : chars_ptr; - Length : size_t) return char_array - is - begin - if Item = Null_Ptr then - raise Dereference_Error; - end if; - - -- ACATS cxb3010 checks that Constraint_Error gets raised when Length - -- is 0. Seems better to check that Length is not null before declaring - -- an array with size_t bounds of 0 .. Length - 1 anyway. - - if Length = 0 then - raise Constraint_Error; - end if; - - declare - Result : char_array (0 .. Length - 1); - - begin - for J in Result'Range loop - Result (J) := Peek (Item + J); - - if Result (J) = nul then - return Result (0 .. J); - end if; - end loop; - - return Result; - end; - end Value; - - function Value (Item : chars_ptr) return String is - begin - return To_Ada (Value (Item)); - end Value; - - function Value (Item : chars_ptr; Length : size_t) return String is - Result : char_array (0 .. Length); - - begin - -- As per AI-00177, this is equivalent to: - - -- To_Ada (Value (Item, Length) & nul); - - if Item = Null_Ptr then - raise Dereference_Error; - end if; - - for J in 0 .. Length - 1 loop - Result (J) := Peek (Item + J); - - if Result (J) = nul then - return To_Ada (Result (0 .. J)); - end if; - end loop; - - Result (Length) := nul; - return To_Ada (Result); - end Value; - -end Interfaces.C.Strings; diff --git a/gcc/ada/i-cstrin.ads b/gcc/ada/i-cstrin.ads deleted file mode 100644 index 833a69a..0000000 --- a/gcc/ada/i-cstrin.ads +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . C . S T R I N G S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1993-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package Interfaces.C.Strings is - pragma Preelaborate; - - type char_array_access is access all char_array; - for char_array_access'Size use System.Parameters.ptr_bits; - - pragma No_Strict_Aliasing (char_array_access); - -- Since this type is used for external interfacing, with the pointer - -- coming from who knows where, it seems a good idea to turn off any - -- strict aliasing assumptions for this type. - - type chars_ptr is private; - pragma Preelaborable_Initialization (chars_ptr); - - type chars_ptr_array is array (size_t range <>) of aliased chars_ptr; - - Null_Ptr : constant chars_ptr; - - function To_Chars_Ptr - (Item : char_array_access; - Nul_Check : Boolean := False) return chars_ptr; - - function New_Char_Array (Chars : char_array) return chars_ptr; - - function New_String (Str : String) return chars_ptr; - - procedure Free (Item : in out chars_ptr); - -- When deallocation is prohibited (eg: cert runtimes) this routine - -- will raise Program_Error - - Dereference_Error : exception; - - function Value (Item : chars_ptr) return char_array; - - function Value - (Item : chars_ptr; - Length : size_t) return char_array; - - function Value (Item : chars_ptr) return String; - - function Value - (Item : chars_ptr; - Length : size_t) return String; - - function Strlen (Item : chars_ptr) return size_t; - - procedure Update - (Item : chars_ptr; - Offset : size_t; - Chars : char_array; - Check : Boolean := True); - - procedure Update - (Item : chars_ptr; - Offset : size_t; - Str : String; - Check : Boolean := True); - - Update_Error : exception; - -private - type chars_ptr is access all Character; - for chars_ptr'Size use System.Parameters.ptr_bits; - - pragma No_Strict_Aliasing (chars_ptr); - -- Since this type is used for external interfacing, with the pointer - -- coming from who knows where, it seems a good idea to turn off any - -- strict aliasing assumptions for this type. - - Null_Ptr : constant chars_ptr := null; -end Interfaces.C.Strings; diff --git a/gcc/ada/i-fortra.adb b/gcc/ada/i-fortra.adb deleted file mode 100644 index 532089d..0000000 --- a/gcc/ada/i-fortra.adb +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Interfaces.Fortran is - - ------------ - -- To_Ada -- - ------------ - - -- Single character case - - function To_Ada (Item : Character_Set) return Character is - begin - return Character (Item); - end To_Ada; - - -- String case (function returning converted result) - - function To_Ada (Item : Fortran_Character) return String is - T : String (1 .. Item'Length); - - begin - for J in T'Range loop - T (J) := Character (Item (J - 1 + Item'First)); - end loop; - - return T; - end To_Ada; - - -- String case (procedure copying converted string to given buffer) - - procedure To_Ada - (Item : Fortran_Character; - Target : out String; - Last : out Natural) - is - begin - if Item'Length = 0 then - Last := 0; - return; - - elsif Target'Length = 0 then - raise Constraint_Error; - - else - Last := Target'First - 1; - - for J in Item'Range loop - Last := Last + 1; - - if Last > Target'Last then - raise Constraint_Error; - else - Target (Last) := Character (Item (J)); - end if; - end loop; - end if; - end To_Ada; - - ---------------- - -- To_Fortran -- - ---------------- - - -- Character case - - function To_Fortran (Item : Character) return Character_Set is - begin - return Character_Set (Item); - end To_Fortran; - - -- String case (function returning converted result) - - function To_Fortran (Item : String) return Fortran_Character is - T : Fortran_Character (1 .. Item'Length); - - begin - for J in T'Range loop - T (J) := Character_Set (Item (J - 1 + Item'First)); - end loop; - - return T; - end To_Fortran; - - -- String case (procedure copying converted string to given buffer) - - procedure To_Fortran - (Item : String; - Target : out Fortran_Character; - Last : out Natural) - is - begin - if Item'Length = 0 then - Last := 0; - return; - - elsif Target'Length = 0 then - raise Constraint_Error; - - else - Last := Target'First - 1; - - for J in Item'Range loop - Last := Last + 1; - - if Last > Target'Last then - raise Constraint_Error; - else - Target (Last) := Character_Set (Item (J)); - end if; - end loop; - end if; - end To_Fortran; - -end Interfaces.Fortran; diff --git a/gcc/ada/i-fortra.ads b/gcc/ada/i-fortra.ads deleted file mode 100644 index 5ac9113..0000000 --- a/gcc/ada/i-fortra.ads +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . F O R T R A N -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics.Generic_Complex_Types; -pragma Elaborate_All (Ada.Numerics.Generic_Complex_Types); - -package Interfaces.Fortran is - pragma Pure; - - type Fortran_Integer is new Integer; - type Real is new Float; - type Double_Precision is new Long_Float; - - type Logical is new Boolean; - for Logical'Size use Integer'Size; - pragma Convention (Fortran, Logical); - -- As required by Fortran standard, logical allocates same space as - -- an integer. The convention is important, since in Fortran, Booleans - -- are implemented with zero/non-zero semantics for False/True, and the - -- pragma Convention (Fortran) activates the special handling required - -- in this case. - - package Single_Precision_Complex_Types is - new Ada.Numerics.Generic_Complex_Types (Real); - - package Double_Precision_Complex_Types is - new Ada.Numerics.Generic_Complex_Types (Double_Precision); - - type Complex is new Single_Precision_Complex_Types.Complex; - - type Double_Complex is new Double_Precision_Complex_Types.Complex; - - subtype Imaginary is Single_Precision_Complex_Types.Imaginary; - i : Imaginary renames Single_Precision_Complex_Types.i; - j : Imaginary renames Single_Precision_Complex_Types.j; - - type Character_Set is new Character; - - type Fortran_Character is array (Positive range <>) of Character_Set; - - -- Additional declarations as permitted by Ada 2012, p.608, paragraph 21. - -- Interoperability with Fortran 77's vendor extension using star - -- notation and Fortran 90's intrinsic types with kind=n parameter. - -- The following assumes that `n' matches the byte size, which - -- most Fortran compiler, including GCC's follow. - - type Integer_Star_1 is new Integer_8; - type Integer_Kind_1 is new Integer_8; - type Integer_Star_2 is new Integer_16; - type Integer_Kind_2 is new Integer_16; - type Integer_Star_4 is new Integer_32; - type Integer_Kind_4 is new Integer_32; - type Integer_Star_8 is new Integer_64; - type Integer_Kind_8 is new Integer_64; - - type Logical_Star_1 is new Boolean with Convention => Fortran, Size => 8; - type Logical_Star_2 is new Boolean with Convention => Fortran, Size => 16; - type Logical_Star_4 is new Boolean with Convention => Fortran, Size => 32; - type Logical_Star_8 is new Boolean with Convention => Fortran, Size => 64; - type Logical_Kind_1 is new Boolean with Convention => Fortran, Size => 8; - type Logical_Kind_2 is new Boolean with Convention => Fortran, Size => 16; - type Logical_Kind_4 is new Boolean with Convention => Fortran, Size => 32; - type Logical_Kind_8 is new Boolean with Convention => Fortran, Size => 64; - - type Real_Star_4 is new Float; - type Real_Kind_4 is new Float; - type Real_Star_8 is new Long_Float; - type Real_Kind_8 is new Long_Float; - -- In the kind syntax, n is the same as the associated real kind - - type Complex_Star_8 is new Complex; - type Complex_Kind_4 is new Complex; - type Complex_Star_16 is new Double_Complex; - type Complex_Kind_8 is new Double_Complex; - -- In the star syntax, n is twice as large (real+imaginary size) - - type Character_Kind_n is new Fortran_Character; - - function To_Fortran (Item : Character) return Character_Set; - function To_Ada (Item : Character_Set) return Character; - - function To_Fortran (Item : String) return Fortran_Character; - function To_Ada (Item : Fortran_Character) return String; - - procedure To_Fortran - (Item : String; - Target : out Fortran_Character; - Last : out Natural); - - procedure To_Ada - (Item : Fortran_Character; - Target : out String; - Last : out Natural); - -end Interfaces.Fortran; diff --git a/gcc/ada/i-pacdec.adb b/gcc/ada/i-pacdec.adb deleted file mode 100644 index bb6c21a..0000000 --- a/gcc/ada/i-pacdec.adb +++ /dev/null @@ -1,352 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . P A C K E D _ D E C I M A L -- --- -- --- B o d y -- --- (Version for IBM Mainframe Packed Decimal Format) -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; - -with Ada.Unchecked_Conversion; - -package body Interfaces.Packed_Decimal is - - type Packed is array (Byte_Length) of Unsigned_8; - -- The type used internally to represent packed decimal - - type Packed_Ptr is access Packed; - function To_Packed_Ptr is - new Ada.Unchecked_Conversion (Address, Packed_Ptr); - - -- The following array is used to convert a value in the range 0-99 to - -- a packed decimal format with two hexadecimal nibbles. It is worth - -- using table look up in this direction because divides are expensive. - - Packed_Byte : constant array (00 .. 99) of Unsigned_8 := - (16#00#, 16#01#, 16#02#, 16#03#, 16#04#, - 16#05#, 16#06#, 16#07#, 16#08#, 16#09#, - 16#10#, 16#11#, 16#12#, 16#13#, 16#14#, - 16#15#, 16#16#, 16#17#, 16#18#, 16#19#, - 16#20#, 16#21#, 16#22#, 16#23#, 16#24#, - 16#25#, 16#26#, 16#27#, 16#28#, 16#29#, - 16#30#, 16#31#, 16#32#, 16#33#, 16#34#, - 16#35#, 16#36#, 16#37#, 16#38#, 16#39#, - 16#40#, 16#41#, 16#42#, 16#43#, 16#44#, - 16#45#, 16#46#, 16#47#, 16#48#, 16#49#, - 16#50#, 16#51#, 16#52#, 16#53#, 16#54#, - 16#55#, 16#56#, 16#57#, 16#58#, 16#59#, - 16#60#, 16#61#, 16#62#, 16#63#, 16#64#, - 16#65#, 16#66#, 16#67#, 16#68#, 16#69#, - 16#70#, 16#71#, 16#72#, 16#73#, 16#74#, - 16#75#, 16#76#, 16#77#, 16#78#, 16#79#, - 16#80#, 16#81#, 16#82#, 16#83#, 16#84#, - 16#85#, 16#86#, 16#87#, 16#88#, 16#89#, - 16#90#, 16#91#, 16#92#, 16#93#, 16#94#, - 16#95#, 16#96#, 16#97#, 16#98#, 16#99#); - - --------------------- - -- Int32_To_Packed -- - --------------------- - - procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is - PP : constant Packed_Ptr := To_Packed_Ptr (P); - Empty_Nibble : constant Boolean := ((D rem 2) = 0); - B : constant Byte_Length := (D / 2) + 1; - VV : Integer_32 := V; - - begin - -- Deal with sign byte first - - if VV >= 0 then - PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#; - VV := VV / 10; - - else - VV := -VV; - PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#; - end if; - - for J in reverse B - 1 .. 2 loop - if VV = 0 then - for K in 1 .. J loop - PP (K) := 16#00#; - end loop; - - return; - - else - PP (J) := Packed_Byte (Integer (VV rem 100)); - VV := VV / 100; - end if; - end loop; - - -- Deal with leading byte - - if Empty_Nibble then - if VV > 9 then - raise Constraint_Error; - else - PP (1) := Unsigned_8 (VV); - end if; - - else - if VV > 99 then - raise Constraint_Error; - else - PP (1) := Packed_Byte (Integer (VV)); - end if; - end if; - - end Int32_To_Packed; - - --------------------- - -- Int64_To_Packed -- - --------------------- - - procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is - PP : constant Packed_Ptr := To_Packed_Ptr (P); - Empty_Nibble : constant Boolean := ((D rem 2) = 0); - B : constant Byte_Length := (D / 2) + 1; - VV : Integer_64 := V; - - begin - -- Deal with sign byte first - - if VV >= 0 then - PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#; - VV := VV / 10; - - else - VV := -VV; - PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#; - end if; - - for J in reverse B - 1 .. 2 loop - if VV = 0 then - for K in 1 .. J loop - PP (K) := 16#00#; - end loop; - - return; - - else - PP (J) := Packed_Byte (Integer (VV rem 100)); - VV := VV / 100; - end if; - end loop; - - -- Deal with leading byte - - if Empty_Nibble then - if VV > 9 then - raise Constraint_Error; - else - PP (1) := Unsigned_8 (VV); - end if; - - else - if VV > 99 then - raise Constraint_Error; - else - PP (1) := Packed_Byte (Integer (VV)); - end if; - end if; - - end Int64_To_Packed; - - --------------------- - -- Packed_To_Int32 -- - --------------------- - - function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is - PP : constant Packed_Ptr := To_Packed_Ptr (P); - Empty_Nibble : constant Boolean := ((D mod 2) = 0); - B : constant Byte_Length := (D / 2) + 1; - V : Integer_32; - Dig : Unsigned_8; - Sign : Unsigned_8; - J : Positive; - - begin - -- Cases where there is an unused (zero) nibble in the first byte. - -- Deal with the single digit nibble at the right of this byte - - if Empty_Nibble then - V := Integer_32 (PP (1)); - J := 2; - - if V > 9 then - raise Constraint_Error; - end if; - - -- Cases where all nibbles are used - - else - V := 0; - J := 1; - end if; - - -- Loop to process bytes containing two digit nibbles - - while J < B loop - Dig := Shift_Right (PP (J), 4); - - if Dig > 9 then - raise Constraint_Error; - else - V := V * 10 + Integer_32 (Dig); - end if; - - Dig := PP (J) and 16#0F#; - - if Dig > 9 then - raise Constraint_Error; - else - V := V * 10 + Integer_32 (Dig); - end if; - - J := J + 1; - end loop; - - -- Deal with digit nibble in sign byte - - Dig := Shift_Right (PP (J), 4); - - if Dig > 9 then - raise Constraint_Error; - else - V := V * 10 + Integer_32 (Dig); - end if; - - Sign := PP (J) and 16#0F#; - - -- Process sign nibble (deal with most common cases first) - - if Sign = 16#C# then - return V; - - elsif Sign = 16#D# then - return -V; - - elsif Sign = 16#B# then - return -V; - - elsif Sign >= 16#A# then - return V; - - else - raise Constraint_Error; - end if; - end Packed_To_Int32; - - --------------------- - -- Packed_To_Int64 -- - --------------------- - - function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is - PP : constant Packed_Ptr := To_Packed_Ptr (P); - Empty_Nibble : constant Boolean := ((D mod 2) = 0); - B : constant Byte_Length := (D / 2) + 1; - V : Integer_64; - Dig : Unsigned_8; - Sign : Unsigned_8; - J : Positive; - - begin - -- Cases where there is an unused (zero) nibble in the first byte. - -- Deal with the single digit nibble at the right of this byte - - if Empty_Nibble then - V := Integer_64 (PP (1)); - J := 2; - - if V > 9 then - raise Constraint_Error; - end if; - - -- Cases where all nibbles are used - - else - J := 1; - V := 0; - end if; - - -- Loop to process bytes containing two digit nibbles - - while J < B loop - Dig := Shift_Right (PP (J), 4); - - if Dig > 9 then - raise Constraint_Error; - else - V := V * 10 + Integer_64 (Dig); - end if; - - Dig := PP (J) and 16#0F#; - - if Dig > 9 then - raise Constraint_Error; - else - V := V * 10 + Integer_64 (Dig); - end if; - - J := J + 1; - end loop; - - -- Deal with digit nibble in sign byte - - Dig := Shift_Right (PP (J), 4); - - if Dig > 9 then - raise Constraint_Error; - else - V := V * 10 + Integer_64 (Dig); - end if; - - Sign := PP (J) and 16#0F#; - - -- Process sign nibble (deal with most common cases first) - - if Sign = 16#C# then - return V; - - elsif Sign = 16#D# then - return -V; - - elsif Sign = 16#B# then - return -V; - - elsif Sign >= 16#A# then - return V; - - else - raise Constraint_Error; - end if; - end Packed_To_Int64; - -end Interfaces.Packed_Decimal; diff --git a/gcc/ada/i-pacdec.ads b/gcc/ada/i-pacdec.ads deleted file mode 100644 index ce3f0f2..0000000 --- a/gcc/ada/i-pacdec.ads +++ /dev/null @@ -1,149 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S . P A C K E D _ D E C I M A L -- --- -- --- S p e c -- --- (Version for IBM Mainframe Packed Decimal Format) -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit defines the packed decimal format used by GNAT in response to --- a specification of Machine_Radix 10 for a decimal fixed-point type. The --- format and operations are completely encapsulated in this unit, so all --- that is necessary to compile using different packed decimal formats is --- to replace this single unit. - --- Note that the compiler access the spec of this unit during compilation --- to obtain the data length that needs allocating, so the correct version --- of the spec must be available to the compiler, and must correspond to --- the spec and body made available to the linker, and all units of a given --- program must be compiled with the same version of the spec and body. --- This consistency will be enforced automatically using the normal binder --- consistency checking, since any unit declaring Machine_Radix 10 types or --- containing operations on such data will implicitly with Packed_Decimal. - -with System; - -package Interfaces.Packed_Decimal is - - ------------------------ - -- Format Description -- - ------------------------ - - -- IBM Mainframe packed decimal format uses a byte string of length one - -- to 10 bytes, with the most significant byte first. Each byte contains - -- two decimal digits (with the high order digit in the left nibble, and - -- the low order four bits contain the sign, using the following code: - - -- 16#A# 2#1010# positive - -- 16#B# 2#1011# negative - -- 16#C# 2#1100# positive (preferred representation) - -- 16#D# 2#1101# negative (preferred representation) - -- 16#E# 2#1110# positive - -- 16#F# 2#1011# positive - - -- In this package, all six sign representations are interpreted as - -- shown above when an operand is read, when an operand is written, - -- the preferred representations are always used. Constraint_Error - -- is raised if any other bit pattern is found in the sign nibble, - -- or if a digit nibble contains an invalid digit code. - - -- Some examples follow: - - -- 05 76 3C +5763 - -- 00 01 1D -11 - -- 00 04 4E +44 (non-standard sign) - -- 00 00 00 invalid (incorrect sign nibble) - -- 0A 01 1C invalid (bad digit) - - ------------------ - -- Length Array -- - ------------------ - - -- The following array must be declared in exactly the form shown, since - -- the compiler accesses the associated tree to determine the size to be - -- allocated to a machine radix 10 type, depending on the number of digits. - - subtype Byte_Length is Positive range 1 .. 10; - -- Range of possible byte lengths - - Packed_Size : constant array (1 .. 18) of Byte_Length := - (01 => 01, -- Length in bytes for digits 1 - 02 => 02, -- Length in bytes for digits 2 - 03 => 02, -- Length in bytes for digits 2 - 04 => 03, -- Length in bytes for digits 2 - 05 => 03, -- Length in bytes for digits 2 - 06 => 04, -- Length in bytes for digits 2 - 07 => 04, -- Length in bytes for digits 2 - 08 => 05, -- Length in bytes for digits 2 - 09 => 05, -- Length in bytes for digits 2 - 10 => 06, -- Length in bytes for digits 2 - 11 => 06, -- Length in bytes for digits 2 - 12 => 07, -- Length in bytes for digits 2 - 13 => 07, -- Length in bytes for digits 2 - 14 => 08, -- Length in bytes for digits 2 - 15 => 08, -- Length in bytes for digits 2 - 16 => 09, -- Length in bytes for digits 2 - 17 => 09, -- Length in bytes for digits 2 - 18 => 10); -- Length in bytes for digits 2 - - ------------------------- - -- Conversion Routines -- - ------------------------- - - subtype D32 is Positive range 1 .. 9; - -- Used to represent number of digits in a packed decimal value that - -- can be represented in a 32-bit binary signed integer form. - - subtype D64 is Positive range 10 .. 18; - -- Used to represent number of digits in a packed decimal value that - -- requires a 64-bit signed binary integer for representing all values. - - function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32; - -- The argument P is the address of a packed decimal value and D is the - -- number of digits (in the range 1 .. 9, as implied by the subtype). - -- The returned result is the corresponding signed binary value. The - -- exception Constraint_Error is raised if the input is invalid. - - function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64; - -- The argument P is the address of a packed decimal value and D is the - -- number of digits (in the range 10 .. 18, as implied by the subtype). - -- The returned result is the corresponding signed binary value. The - -- exception Constraint_Error is raised if the input is invalid. - - procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32); - -- The argument V is a signed binary integer, which is converted to - -- packed decimal format and stored using P, the address of a packed - -- decimal item of D digits (D is in the range 1-9). Constraint_Error - -- is raised if V is out of range of this number of digits. - - procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64); - -- The argument V is a signed binary integer, which is converted to - -- packed decimal format and stored using P, the address of a packed - -- decimal item of D digits (D is in the range 10-18). Constraint_Error - -- is raised if V is out of range of this number of digits. - -end Interfaces.Packed_Decimal; diff --git a/gcc/ada/i-vxwoio.adb b/gcc/ada/i-vxwoio.adb deleted file mode 100644 index 4d480e0..0000000 --- a/gcc/ada/i-vxwoio.adb +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V X W O R K S . I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -package body Interfaces.VxWorks.IO is - - -------------------------- - -- Enable_Get_Immediate -- - -------------------------- - - procedure Enable_Get_Immediate - (File : Interfaces.C_Streams.FILEs; - Success : out Boolean) - is - Status : int; - Fd : int; - - begin - Fd := fileno (File); - Status := ioctl (Fd, FIOSETOPTIONS, OPT_RAW); - - if Status /= int (ERROR) then - Success := True; - else - Success := False; - end if; - end Enable_Get_Immediate; - - --------------------------- - -- Disable_Get_Immediate -- - --------------------------- - - procedure Disable_Get_Immediate - (File : Interfaces.C_Streams.FILEs; - Success : out Boolean) - is - Status : int; - Fd : int; - begin - Fd := fileno (File); - Status := ioctl (Fd, FIOSETOPTIONS, OPT_TERMINAL); - Success := (if Status /= int (ERROR) then True else False); - end Disable_Get_Immediate; - -end Interfaces.VxWorks.IO; diff --git a/gcc/ada/i-vxwoio.ads b/gcc/ada/i-vxwoio.ads deleted file mode 100644 index dc69546..0000000 --- a/gcc/ada/i-vxwoio.ads +++ /dev/null @@ -1,229 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V X W O R K S . I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a binding to the functions fileno and ioctl --- in VxWorks, providing a set of definitions of ioctl function codes --- and options for the use of these functions. - --- A particular use of this interface is to enable use of Get_Immediate --- in Ada.Text_IO. There is no way in VxWorks to provide the desired --- functionality of Get_Immediate (no buffering and no waiting for a --- line return) without flushing the buffer, which violates the Ada --- semantic requirements for Ada.Text_IO. - -with Interfaces.C_Streams; - -package Interfaces.VxWorks.IO is - - ------------------------- - -- The ioctl Interface -- - -------------------------- - - type FUNCODE is new int; - -- Type of the function codes in ioctl - - type IOOPT is mod 2 ** int'Size; - -- Type of the option codes in ioctl - - -- ioctl function codes (for more information see ioLib.h) - -- These values could be generated automatically in System.OS_Constants??? - - FIONREAD : constant FUNCODE := 1; - FIOFLUSH : constant FUNCODE := 2; - FIOOPTIONS : constant FUNCODE := 3; - FIOBAUDRATE : constant FUNCODE := 4; - FIODISKFORMAT : constant FUNCODE := 5; - FIODISKINIT : constant FUNCODE := 6; - FIOSEEK : constant FUNCODE := 7; - FIOWHERE : constant FUNCODE := 8; - FIODIRENTRY : constant FUNCODE := 9; - FIORENAME : constant FUNCODE := 10; - FIOREADYCHANGE : constant FUNCODE := 11; - FIONWRITE : constant FUNCODE := 12; - FIODISKCHANGE : constant FUNCODE := 13; - FIOCANCEL : constant FUNCODE := 14; - FIOSQUEEZE : constant FUNCODE := 15; - FIONBIO : constant FUNCODE := 16; - FIONMSGS : constant FUNCODE := 17; - FIOGETNAME : constant FUNCODE := 18; - FIOGETOPTIONS : constant FUNCODE := 19; - FIOSETOPTIONS : constant FUNCODE := FIOOPTIONS; - FIOISATTY : constant FUNCODE := 20; - FIOSYNC : constant FUNCODE := 21; - FIOPROTOHOOK : constant FUNCODE := 22; - FIOPROTOARG : constant FUNCODE := 23; - FIORBUFSET : constant FUNCODE := 24; - FIOWBUFSET : constant FUNCODE := 25; - FIORFLUSH : constant FUNCODE := 26; - FIOWFLUSH : constant FUNCODE := 27; - FIOSELECT : constant FUNCODE := 28; - FIOUNSELECT : constant FUNCODE := 29; - FIONFREE : constant FUNCODE := 30; - FIOMKDIR : constant FUNCODE := 31; - FIORMDIR : constant FUNCODE := 32; - FIOLABELGET : constant FUNCODE := 33; - FIOLABELSET : constant FUNCODE := 34; - FIOATTRIBSE : constant FUNCODE := 35; - FIOCONTIG : constant FUNCODE := 36; - FIOREADDIR : constant FUNCODE := 37; - FIOFSTATGET : constant FUNCODE := 38; - FIOUNMOUNT : constant FUNCODE := 39; - FIOSCSICOMMAND : constant FUNCODE := 40; - FIONCONTIG : constant FUNCODE := 41; - FIOTRUNC : constant FUNCODE := 42; - FIOGETFL : constant FUNCODE := 43; - FIOTIMESET : constant FUNCODE := 44; - FIOINODETONAM : constant FUNCODE := 45; - FIOFSTATFSGE : constant FUNCODE := 46; - - -- ioctl option values - - OPT_ECHO : constant IOOPT := 16#0001#; - OPT_CRMOD : constant IOOPT := 16#0002#; - OPT_TANDEM : constant IOOPT := 16#0004#; - OPT_7_BIT : constant IOOPT := 16#0008#; - OPT_MON_TRAP : constant IOOPT := 16#0010#; - OPT_ABORT : constant IOOPT := 16#0020#; - OPT_LINE : constant IOOPT := 16#0040#; - OPT_RAW : constant IOOPT := 16#0000#; - OPT_TERMINAL : constant IOOPT := OPT_ECHO or - OPT_CRMOD or - OPT_TANDEM or - OPT_MON_TRAP or - OPT_7_BIT or - OPT_ABORT or - OPT_LINE; - - function fileno (Fp : Interfaces.C_Streams.FILEs) return int; - pragma Import (C, fileno, "fileno"); - -- Binding to the C routine fileno - - function ioctl (Fd : int; Function_Code : FUNCODE; Arg : IOOPT) return int; - pragma Import (C, ioctl, "ioctl"); - -- Binding to the C routine ioctl - -- - -- Note: we are taking advantage of the fact that on currently supported - -- VxWorks targets, it is fine to directly bind to a variadic C function. - - ------------------------------ - -- Control of Get_Immediate -- - ------------------------------ - - -- The procedures in this section make use of the interface to ioctl - -- and fileno to provide a mechanism for enabling unbuffered behavior - -- for Get_Immediate in VxWorks. - - -- The situation is that the RM requires that the use of Get_Immediate - -- be identical to Get except that it is desirable (not required) that - -- there be no buffering or line editing. - - -- Unfortunately, in VxWorks, the only way to enable this desired - -- unbuffered behavior involves changing into raw mode. But this - -- transition into raw mode flushes the input buffer, a behavior - -- not permitted by the RM semantics for Get_Immediate. - - -- Given that Get_Immediate cannot be accurately implemented in - -- raw mode, it seems best not to enable it by default, and instead - -- to require specific programmer action, with the programmer being - -- aware that input may be lost. - - -- The following is an example of the use of the two procedures - -- in this section (Enable_Get_Immediate and Disable_Get_Immediate) - - -- with Ada.Text_IO; use Ada.Text_IO; - -- with Ada.Text_IO.C_Streams; use Ada.Text_IO.C_Streams; - -- with Interfaces.VxWorks.IO; use Interfaces.VxWorks.IO; - - -- procedure Example_IO is - -- Input : Character; - -- Available : Boolean; - -- Success : Boolean; - - -- begin - -- Enable_Get_Immediate (C_Stream (Current_Input), Success); - - -- if Success = False then - -- raise Device_Error; - -- end if; - - -- -- Example with the first type of Get_Immediate - -- -- Waits for an entry on the input. Immediately returns - -- -- after having received an character on the input - - -- Put ("Input -> "); - -- Get_Immediate (Input); - -- New_Line; - -- Put_Line ("Character read: " & Input); - - -- -- Example with the second type of Get_Immediate - -- -- This is equivalent to a non blocking read - - -- for J in 1 .. 10 loop - -- Put ("Input -> "); - -- Get_Immediate (Input, Available); - -- New_Line; - - -- if Available = True then - -- Put_Line ("Character read: " & Input); - -- end if; - - -- delay 1.0; - -- end loop; - - -- Disable_Get_Immediate (C_Stream (Current_Input), Success); - - -- if Success = False then - -- raise Device_Error; - -- end if; - - -- exception - -- when Device_Error => - -- Put_Line ("Device Error. Check your configuration"); - -- end Example_IO; - - procedure Enable_Get_Immediate - (File : Interfaces.C_Streams.FILEs; - Success : out Boolean); - -- On VxWorks, a call to this procedure is required before subsequent calls - -- to Get_Immediate have the desired effect of not waiting for a line - -- return. The reason that this call is not automatic on this target is - -- that the call flushes the input buffer, discarding any previous input. - -- Note: Following a call to Enable_Get_Immediate, the only permitted - -- operations on the relevant file are Get_Immediate operations. Any - -- other operations have undefined behavior. - - procedure Disable_Get_Immediate - (File : Interfaces.C_Streams.FILEs; - Success : out Boolean); - -- This procedure resets File to standard mode, and permits subsequent - -- use of the full range of Ada.Text_IO functions - -end Interfaces.VxWorks.IO; diff --git a/gcc/ada/i-vxwork-x86.ads b/gcc/ada/i-vxwork-x86.ads deleted file mode 100644 index 549c3c7..0000000 --- a/gcc/ada/i-vxwork-x86.ads +++ /dev/null @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the x86 VxWorks version of this package - --- This package provides a limited binding to the VxWorks API --- In particular, it interfaces with the VxWorks hardware interrupt --- facilities, allowing the use of low-latency direct-vectored --- interrupt handlers. Note that such handlers have a variety of --- restrictions regarding system calls and language constructs. In particular, --- the use of exception handlers and functions returning variable-length --- objects cannot be used. Less restrictive, but higher-latency handlers can --- be written using Ada protected procedures, Ada 83 style interrupt entries, --- or by signalling an Ada task from within an interrupt handler using a --- binary semaphore as described in the VxWorks Programmer's Manual. --- --- For complete documentation of the operations in this package, please --- consult the VxWorks Programmer's Manual and VxWorks Reference Manual. - -pragma Warnings (Off, "*foreign convention*"); -pragma Warnings (Off, "*add Convention pragma*"); - -with System.VxWorks; - -package Interfaces.VxWorks is - pragma Preelaborate; - - ------------------------------------------------------------------------ - -- Here is a complete example that shows how to handle the Interrupt 0x33 - -- with a direct-vectored interrupt handler in Ada using this package: - - -- with Interfaces.VxWorks; use Interfaces.VxWorks; - -- with System; - -- - -- package P is - -- - -- Count : Integer; - -- pragma Atomic (Count); - -- - -- procedure Handler (Parameter : System.Address); - -- - -- end P; - -- - -- package body P is - -- - -- procedure Handler (Parameter : System.Address) is - -- begin - -- Count := Count + 1; - -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); - -- end Handler; - -- end P; - -- - -- with Interfaces.VxWorks; use Interfaces.VxWorks; - -- with Ada.Text_IO; use Ada.Text_IO; - -- with Ada.Interrupts; - -- with Machine_Code; use Machine_Code; - -- - -- with P; use P; - -- procedure Useint is - -- - -- -- Be sure to use a reasonable interrupt number for target board. - -- -- This one is an unreserved interrupt for the Pentium 3 BSP - -- - -- Interrupt : constant := 16#33#; - -- - -- task T; - -- - -- S : STATUS; - -- - -- task body T is - -- begin - -- loop - -- Put_Line ("Generating an interrupt..."); - -- delay 1.0; - -- - -- -- Generate interrupt, using interrupt number - -- - -- Asm ("int %0", - -- Inputs => - -- Ada.Interrupts.Interrupt_ID'Asm_Input - -- ("i", Interrupt)); - -- end loop; - -- end T; - -- - -- begin - -- S := intConnect (INUM_TO_IVEC (Interrupt), Handler'Access); - -- - -- loop - -- delay 2.0; - -- Put_Line ("value of count:" & P.Count'Img); - -- end loop; - -- end Useint; - ------------------------------------- - - subtype int is Integer; - - type STATUS is new int; - -- Equivalent of the C type STATUS - - OK : constant STATUS := 0; - ERROR : constant STATUS := -1; - - type VOIDFUNCPTR is access procedure (parameter : System.Address); - type Interrupt_Vector is new System.Address; - type Exception_Vector is new System.Address; - - function intConnect - (vector : Interrupt_Vector; - handler : VOIDFUNCPTR; - parameter : System.Address := System.Null_Address) return STATUS; - -- Binding to the C routine intConnect. Use this to set up an user handler. - -- The routine generates a wrapper around the user handler to save and - -- restore context - - function intContext return int; - -- Binding to the C routine intContext. This function returns 1 only if the - -- current execution state is in interrupt context. - - function intVecGet - (Vector : Interrupt_Vector) return VOIDFUNCPTR; - -- Binding to the C routine intVecGet. Use this to get the existing handler - -- for later restoral - - procedure intVecSet - (Vector : Interrupt_Vector; - Handler : VOIDFUNCPTR); - -- Binding to the C routine intVecSet. Use this to restore a handler - -- obtained using intVecGet - - procedure intVecGet2 - (vector : Interrupt_Vector; - pFunction : out VOIDFUNCPTR; - pIdtGate : not null access int; - pIdtSelector : not null access int); - -- Binding to the C routine intVecGet2. Use this to get the existing - -- handler for later restoral - - procedure intVecSet2 - (vector : Interrupt_Vector; - pFunction : VOIDFUNCPTR; - pIdtGate : not null access int; - pIdtSelector : not null access int); - -- Binding to the C routine intVecSet2. Use this to restore a - -- handler obtained using intVecGet2 - - function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; - -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt - -- number to an interrupt vector - - procedure logMsg - (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); - -- Binding to the C routine logMsg. Note that it is the caller's - -- responsibility to ensure that fmt is a null-terminated string - -- (e.g logMsg ("Interrupt" & ASCII.NUL)) - - type FP_CONTEXT is private; - -- Floating point context save and restore. Handlers using floating point - -- must be bracketed with these calls. The pFpContext parameter should be - -- an object of type FP_CONTEXT that is declared local to the handler. - -- - -- See the VxWorks Intel Architecture Supplement regarding these routines - - procedure fppRestore (pFpContext : in out FP_CONTEXT); - -- Restore floating point context - old style - - procedure fppSave (pFpContext : in out FP_CONTEXT); - -- Save floating point context - old style - - procedure fppXrestore (pFpContext : in out FP_CONTEXT); - -- Restore floating point context - new style - - procedure fppXsave (pFpContext : in out FP_CONTEXT); - -- Save floating point context - new style - -private - - type FP_CONTEXT is new System.VxWorks.FP_CONTEXT; - -- Target-dependent floating point context type - - pragma Import (C, intConnect, "intConnect"); - pragma Import (C, intContext, "intContext"); - pragma Import (C, intVecGet, "intVecGet"); - pragma Import (C, intVecSet, "intVecSet"); - pragma Import (C, intVecGet2, "intVecGet2"); - pragma Import (C, intVecSet2, "intVecSet2"); - pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); - pragma Import (C, logMsg, "logMsg"); - pragma Import (C, fppRestore, "fppRestore"); - pragma Import (C, fppSave, "fppSave"); - pragma Import (C, fppXrestore, "fppXrestore"); - pragma Import (C, fppXsave, "fppXsave"); -end Interfaces.VxWorks; diff --git a/gcc/ada/i-vxwork.ads b/gcc/ada/i-vxwork.ads deleted file mode 100644 index 81c4299..0000000 --- a/gcc/ada/i-vxwork.ads +++ /dev/null @@ -1,216 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- I N T E R F A C E S . V X W O R K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a limited binding to the VxWorks API - --- In particular, it interfaces with the VxWorks hardware interrupt --- facilities, allowing the use of low-latency direct-vectored interrupt --- handlers. Note that such handlers have a variety of restrictions regarding --- system calls and language constructs. In particular, the use of exception --- handlers and functions returning variable-length objects cannot be used. --- Less restrictive, but higher-latency handlers can be written using Ada --- protected procedures, Ada 83 style interrupt entries, or by signalling --- an Ada task from within an interrupt handler using a binary semaphore --- as described in the VxWorks Programmer's Manual. --- --- For complete documentation of the operations in this package, please --- consult the VxWorks Programmer's Manual and VxWorks Reference Manual. - -pragma Warnings (Off, "*foreign convention*"); -pragma Warnings (Off, "*add Convention pragma*"); --- These are temporary pragmas to suppress warnings about mismatching --- conventions, which will be a problem when we get rid of trampolines ??? - -with System.VxWorks; - -package Interfaces.VxWorks is - pragma Preelaborate; - - ------------------------------------------------------------------------ - -- Here is a complete example that shows how to handle the Interrupt 0x14 - -- with a direct-vectored interrupt handler in Ada using this package: - - -- with Interfaces.VxWorks; use Interfaces.VxWorks; - -- with System; - -- - -- package P is - -- - -- Count : Integer; - -- pragma Atomic (Count); - -- - -- Level : constant := 1; - -- -- Interrupt level used by this example - -- - -- procedure Handler (parameter : System.Address); - -- - -- end P; - -- - -- package body P is - -- - -- procedure Handler (parameter : System.Address) is - -- S : STATUS; - -- begin - -- Count := Count + 1; - -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); - -- - -- -- Acknowledge VME interrupt - -- - -- S := sysBusIntAck (intLevel => Level); - -- end Handler; - -- end P; - -- - -- with Interfaces.VxWorks; use Interfaces.VxWorks; - -- with Ada.Text_IO; use Ada.Text_IO; - -- - -- with P; use P; - -- procedure Useint is - -- - -- -- Be sure to use a reasonable interrupt number for board. - -- -- This one is the unused VME graphics interrupt on the PPC MV2604 - -- - -- Interrupt : constant := 16#14#; - -- - -- task T; - -- - -- S : STATUS; - -- - -- task body T is - -- begin - -- loop - -- Put_Line ("Generating an interrupt..."); - -- delay 1.0; - -- - -- -- Generate VME interrupt, using interrupt number - -- - -- S := sysBusIntGen (1, Interrupt); - -- end loop; - -- end T; - -- - -- begin - -- S := sysIntEnable (intLevel => Level); - -- S := intConnect (INUM_TO_IVEC (Interrupt), handler'Access); - -- - -- loop - -- delay 2.0; - -- Put_Line ("value of count:" & P.Count'Img); - -- end loop; - -- end Useint; - ------------------------------------- - - subtype int is Integer; - - type STATUS is new int; - -- Equivalent of the C type STATUS - - OK : constant STATUS := 0; - ERROR : constant STATUS := -1; - - type VOIDFUNCPTR is access procedure (parameter : System.Address); - type Interrupt_Vector is new System.Address; - type Exception_Vector is new System.Address; - - function intConnect - (vector : Interrupt_Vector; - handler : VOIDFUNCPTR; - parameter : System.Address := System.Null_Address) return STATUS; - -- Binding to the C routine intConnect. Use this to set up an user handler. - -- The routine generates a wrapper around the user handler to save and - -- restore context - - function intContext return int; - -- Binding to the C routine intContext. This function returns 1 only if the - -- current execution state is in interrupt context. - - function intVecGet - (Vector : Interrupt_Vector) return VOIDFUNCPTR; - -- Binding to the C routine intVecGet. Use this to get the existing handler - -- for later restoral - - procedure intVecSet - (Vector : Interrupt_Vector; - Handler : VOIDFUNCPTR); - -- Binding to the C routine intVecSet. Use this to restore a handler - -- obtained using intVecGet - - function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; - -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt - -- number to an interrupt vector - - function sysIntEnable (intLevel : int) return STATUS; - -- Binding to the C routine sysIntEnable - - function sysIntDisable (intLevel : int) return STATUS; - -- Binding to the C routine sysIntDisable - - function sysBusIntAck (intLevel : int) return STATUS; - -- Binding to the C routine sysBusIntAck - - function sysBusIntGen (intLevel : int; Intnum : int) return STATUS; - -- Binding to the C routine sysBusIntGen. Note that the T2 documentation - -- implies that a vector address is the proper argument - it's not. The - -- interrupt number in the range 0 .. 255 (for 68K and PPC) is the correct - -- argument. - - procedure logMsg - (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); - -- Binding to the C routine logMsg. Note that it is the caller's - -- responsibility to ensure that fmt is a null-terminated string - -- (e.g logMsg ("Interrupt" & ASCII.NUL)) - - type FP_CONTEXT is private; - -- Floating point context save and restore. Handlers using floating point - -- must be bracketed with these calls. The pFpContext parameter should be - -- an object of type FP_CONTEXT that is declared local to the handler. - - procedure fppRestore (pFpContext : in out FP_CONTEXT); - -- Restore floating point context - - procedure fppSave (pFpContext : in out FP_CONTEXT); - -- Save floating point context - -private - - type FP_CONTEXT is new System.VxWorks.FP_CONTEXT; - -- Target-dependent floating point context type - - pragma Import (C, intConnect, "intConnect"); - pragma Import (C, intContext, "intContext"); - pragma Import (C, intVecGet, "intVecGet"); - pragma Import (C, intVecSet, "intVecSet"); - pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); - pragma Import (C, sysIntEnable, "sysIntEnable"); - pragma Import (C, sysIntDisable, "sysIntDisable"); - pragma Import (C, sysBusIntAck, "sysBusIntAck"); - pragma Import (C, sysBusIntGen, "sysBusIntGen"); - pragma Import (C, logMsg, "logMsg"); - pragma Import (C, fppRestore, "fppRestore"); - pragma Import (C, fppSave, "fppSave"); -end Interfaces.VxWorks; diff --git a/gcc/ada/interfac.ads b/gcc/ada/interfac.ads deleted file mode 100644 index 3bda2f4..0000000 --- a/gcc/ada/interfac.ads +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- I N T E R F A C E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2016, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the implementation dependent sections of this file. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package Interfaces is - pragma No_Elaboration_Code_All; - pragma Pure; - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1; - for Integer_8'Size use 8; - - type Integer_16 is range -2 ** 15 .. 2 ** 15 - 1; - for Integer_16'Size use 16; - - type Integer_32 is range -2 ** 31 .. 2 ** 31 - 1; - for Integer_32'Size use 32; - - type Integer_64 is new Long_Long_Integer; - for Integer_64'Size use 64; - -- Note: we use Long_Long_Integer'First instead of -2 ** 63 to allow this - -- unit to compile when using custom target configuration files where the - -- maximum integer is 32 bits. This is useful for static analysis tools - -- such as SPARK or CodePeer. In the normal case Long_Long_Integer is - -- always 64-bits so we get the desired 64-bit type. - - type Unsigned_8 is mod 2 ** 8; - for Unsigned_8'Size use 8; - - type Unsigned_16 is mod 2 ** 16; - for Unsigned_16'Size use 16; - - type Unsigned_24 is mod 2 ** 24; - for Unsigned_24'Size use 24; - -- Declare this type for compatibility with legacy Ada compilers. - -- This is particularly useful in the context of CodePeer analysis. - - type Unsigned_32 is mod 2 ** 32; - for Unsigned_32'Size use 32; - - type Unsigned_64 is mod 2 ** Long_Long_Integer'Size; - for Unsigned_64'Size use 64; - -- See comment on Integer_64 above - - function Shift_Left - (Value : Unsigned_8; - Amount : Natural) return Unsigned_8; - - function Shift_Right - (Value : Unsigned_8; - Amount : Natural) return Unsigned_8; - - function Shift_Right_Arithmetic - (Value : Unsigned_8; - Amount : Natural) return Unsigned_8; - - function Rotate_Left - (Value : Unsigned_8; - Amount : Natural) return Unsigned_8; - - function Rotate_Right - (Value : Unsigned_8; - Amount : Natural) return Unsigned_8; - - function Shift_Left - (Value : Unsigned_16; - Amount : Natural) return Unsigned_16; - - function Shift_Right - (Value : Unsigned_16; - Amount : Natural) return Unsigned_16; - - function Shift_Right_Arithmetic - (Value : Unsigned_16; - Amount : Natural) return Unsigned_16; - - function Rotate_Left - (Value : Unsigned_16; - Amount : Natural) return Unsigned_16; - - function Rotate_Right - (Value : Unsigned_16; - Amount : Natural) return Unsigned_16; - - function Shift_Left - (Value : Unsigned_32; - Amount : Natural) return Unsigned_32; - - function Shift_Right - (Value : Unsigned_32; - Amount : Natural) return Unsigned_32; - - function Shift_Right_Arithmetic - (Value : Unsigned_32; - Amount : Natural) return Unsigned_32; - - function Rotate_Left - (Value : Unsigned_32; - Amount : Natural) return Unsigned_32; - - function Rotate_Right - (Value : Unsigned_32; - Amount : Natural) return Unsigned_32; - - function Shift_Left - (Value : Unsigned_64; - Amount : Natural) return Unsigned_64; - - function Shift_Right - (Value : Unsigned_64; - Amount : Natural) return Unsigned_64; - - function Shift_Right_Arithmetic - (Value : Unsigned_64; - Amount : Natural) return Unsigned_64; - - function Rotate_Left - (Value : Unsigned_64; - Amount : Natural) return Unsigned_64; - - function Rotate_Right - (Value : Unsigned_64; - Amount : Natural) return Unsigned_64; - - pragma Import (Intrinsic, Shift_Left); - pragma Import (Intrinsic, Shift_Right); - pragma Import (Intrinsic, Shift_Right_Arithmetic); - pragma Import (Intrinsic, Rotate_Left); - pragma Import (Intrinsic, Rotate_Right); - - -- IEEE Floating point types - - type IEEE_Float_32 is digits 6; - for IEEE_Float_32'Size use 32; - - type IEEE_Float_64 is digits 15; - for IEEE_Float_64'Size use 64; - - -- If there is an IEEE extended float available on the machine, we assume - -- that it is available as Long_Long_Float. - - -- Note: it is harmless, and explicitly permitted, to include additional - -- types in interfaces, so it is not wrong to have IEEE_Extended_Float - -- defined even if the extended format is not available. - - type IEEE_Extended_Float is new Long_Long_Float; - -end Interfaces; diff --git a/gcc/ada/ioexcept.ads b/gcc/ada/ioexcept.ads deleted file mode 100644 index da46729..0000000 --- a/gcc/ada/ioexcept.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- I O _ E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Ada_2012; --- Explicit setting of Ada 2012 mode is required here, since we want to with a --- child unit (not possible in Ada 83 mode), and IO_Exceptions is not --- considered to be an internal unit that is automatically compiled in Ada --- 2012 mode (since a user is allowed to redeclare IO_Exceptions). - -with Ada.IO_Exceptions; - -package IO_Exceptions renames Ada.IO_Exceptions; diff --git a/gcc/ada/libgnarl/a-intnam-dragonfly.ads b/gcc/ada/libgnarl/a-intnam-dragonfly.ads new file mode 100644 index 0000000..1de9735 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam-dragonfly.ads @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT 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-2015, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the DragonFly BSD THREADS version of this package + +with System.OS_Interface; + +package Ada.Interrupts.Names is + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + -- 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 + + 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 + + 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 + + SIGURG : constant Interrupt_ID := + System.OS_Interface.SIGURG; -- urgent condition on IO channel + + 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 + + SIGCHLD : constant Interrupt_ID := + System.OS_Interface.SIGCHLD; -- 4.3BSD's/POSIX name for SIGCLD + + SIGCLD : constant Interrupt_ID := + System.OS_Interface.SIGCLD; -- child status change + + SIGTTIN : constant Interrupt_ID := + System.OS_Interface.SIGTTIN; -- background tty read attempted + + SIGTTOU : constant Interrupt_ID := + System.OS_Interface.SIGTTOU; -- background tty write attempted + + SIGIO : constant Interrupt_ID := -- input/output possible, + System.OS_Interface.SIGIO; -- SIGPOLL alias (Solaris) + + 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 + + SIGUSR1 : constant Interrupt_ID := + System.OS_Interface.SIGUSR1; -- user defined signal 1 + + SIGUSR2 : constant Interrupt_ID := + System.OS_Interface.SIGUSR2; -- user defined signal 2 + +end Ada.Interrupts.Names; diff --git a/gcc/ada/libgnarl/a-intnam-rtems.ads b/gcc/ada/libgnarl/a-intnam-rtems.ads new file mode 100644 index 0000000..43a5281 --- /dev/null +++ b/gcc/ada/libgnarl/a-intnam-rtems.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2009 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +-- The GNARL files that were developed for RTEMS are maintained by On-Line -- +-- Applications Research Corporation (http://www.oarcorp.com) in coopera- -- +-- tion with Ada Core Technologies Inc. and Florida State University. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a RTEMS version of this package +-- +-- The following signals are reserved by the run time: +-- +-- SIGFPE, SIGILL, SIGSEGV, SIGBUS, SIGTRAP, SIGABRT, SIGINT, +-- SIGALRM, SIGEMT, 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) + + 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 + +end Ada.Interrupts.Names; diff --git a/gcc/ada/libgnat/a-assert.adb b/gcc/ada/libgnat/a-assert.adb new file mode 100644 index 0000000..f7f6943 --- /dev/null +++ b/gcc/ada/libgnat/a-assert.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S S E R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Assertions with + SPARK_Mode +is + ------------ + -- Assert -- + ------------ + + procedure Assert (Check : Boolean) is + begin + if Check = False then + raise Ada.Assertions.Assertion_Error; + end if; + end Assert; + + procedure Assert (Check : Boolean; Message : String) is + begin + if Check = False then + raise Ada.Assertions.Assertion_Error with Message; + end if; + end Assert; + +end Ada.Assertions; diff --git a/gcc/ada/libgnat/a-assert.ads b/gcc/ada/libgnat/a-assert.ads new file mode 100644 index 0000000..caa5aa0 --- /dev/null +++ b/gcc/ada/libgnat/a-assert.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . A S S E R T I O N S -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- S p e c -- +-- -- +-- 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 contracts that have been added. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Preconditions in this unit are meant for analysis only, not for run-time +-- checking, so that the expected exceptions are raised when calling Assert. +-- This is enforced by setting the corresponding assertion policy to Ignore. + +pragma Assertion_Policy (Pre => Ignore); + +-- We do a with of System.Assertions to get hold of the exception (following +-- the specific RM permission that lets' Assertion_Error being a renaming). +-- The suppression of Warnings stops the warning about bad categorization. + +pragma Warnings (Off); +with System.Assertions; +pragma Warnings (On); + +package Ada.Assertions with + SPARK_Mode +is + pragma Pure (Assertions); + + Assertion_Error : exception renames System.Assertions.Assert_Failure; + -- This is the renaming that is allowed by 11.4.2(24). Note that the + -- Exception_Name will refer to the one in System.Assertions (see + -- AARM-11.4.1(12.b)). + + procedure Assert (Check : Boolean) with + Pre => Check; + + procedure Assert (Check : Boolean; Message : String) with + Pre => Check; + +end Ada.Assertions; diff --git a/gcc/ada/libgnat/a-btgbso.adb b/gcc/ada/libgnat/a-btgbso.adb new file mode 100644 index 0000000..740aa17 --- /dev/null +++ b/gcc/ada/libgnat/a-btgbso.adb @@ -0,0 +1,703 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy (Source : Set_Type) return Set_Type; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set_Type) return Set_Type is + begin + return Target : Set_Type (Source.Length) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ---------------- + -- Difference -- + ---------------- + + procedure Set_Difference (Target : in out Set_Type; Source : Set_Type) is + Tgt, Src : Count_Type; + + TN : Nodes_Type renames Target.Nodes; + SN : Nodes_Type renames Source.Nodes; + + Compare : Integer; + + begin + if Target'Address = Source'Address then + TC_Check (Target.TC); + + Tree_Operations.Clear_Tree (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + TC_Check (Target.TC); + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = 0 then + exit; + end if; + + if Src = 0 then + exit; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + if Is_Less (TN (Tgt), SN (Src)) then + Compare := -1; + elsif Is_Less (SN (Src), TN (Tgt)) then + Compare := 1; + else + Compare := 0; + end if; + end; + + if Compare < 0 then + Tgt := Tree_Operations.Next (Target, Tgt); + + elsif Compare > 0 then + Src := Tree_Operations.Next (Source, Src); + + else + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + + Src := Tree_Operations.Next (Source, Src); + end if; + end loop; + end Set_Difference; + + function Set_Difference (Left, Right : Set_Type) return Set_Type is + begin + if Left'Address = Right'Address then + return S : Set_Type (0); -- Empty set + end if; + + if Left.Length = 0 then + return S : Set_Type (0); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + return Result : Set_Type (Left.Length) do + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + exit; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; + end; + end return; + end Set_Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Set_Intersection + (Target : in out Set_Type; + Source : Set_Type) + is + Tgt : Count_Type; + Src : Count_Type; + + Compare : Integer; + + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Target.TC); + + if Source.Length = 0 then + Tree_Operations.Clear_Tree (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + while Tgt /= 0 + and then Src /= 0 + loop + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + Compare := -1; + elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + Compare := 1; + else + Compare := 0; + end if; + end; + + if Compare < 0 then + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + + elsif Compare > 0 then + Src := Tree_Operations.Next (Source, Src); + + else + Tgt := Tree_Operations.Next (Target, Tgt); + Src := Tree_Operations.Next (Source, Src); + end if; + end loop; + + while Tgt /= 0 loop + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + end loop; + end Set_Intersection; + + function Set_Intersection (Left, Right : Set_Type) return Set_Type is + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + return Result : Set_Type (Count_Type'Min (Left.Length, Right.Length)) do + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + exit; + end if; + + if R_Node = 0 then + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + + else + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; + end; + end return; + end Set_Intersection; + + --------------- + -- Is_Subset -- + --------------- + + function Set_Subset + (Subset : Set_Type; + Of_Set : Set_Type) return Boolean + is + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); + Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); + + Subset_Node : Count_Type; + Set_Node : Count_Type; + begin + Subset_Node := Subset.First; + Set_Node := Of_Set.First; + loop + if Set_Node = 0 then + return Subset_Node = 0; + end if; + + if Subset_Node = 0 then + return True; + end if; + + if Is_Less (Subset.Nodes (Subset_Node), + Of_Set.Nodes (Set_Node)) + then + return False; + end if; + + if Is_Less (Of_Set.Nodes (Set_Node), + Subset.Nodes (Subset_Node)) + then + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + else + Set_Node := Tree_Operations.Next (Of_Set, Set_Node); + Subset_Node := Tree_Operations.Next (Subset, Subset_Node); + end if; + end loop; + end; + end Set_Subset; + + ------------- + -- Overlap -- + ------------- + + function Set_Overlap (Left, Right : Set_Type) return Boolean is + begin + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L_Node : Count_Type; + R_Node : Count_Type; + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 + or else R_Node = 0 + then + return False; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + L_Node := Tree_Operations.Next (Left, L_Node); + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + R_Node := Tree_Operations.Next (Right, R_Node); + else + return True; + end if; + end loop; + end; + end Set_Overlap; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Set_Symmetric_Difference + (Target : in out Set_Type; + Source : Set_Type) + is + Tgt : Count_Type; + Src : Count_Type; + + New_Tgt_Node : Count_Type; + pragma Warnings (Off, New_Tgt_Node); + + Compare : Integer; + + begin + if Target'Address = Source'Address then + Tree_Operations.Clear_Tree (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = 0 then + while Src /= 0 loop + Insert_With_Hint + (Dst_Set => Target, + Dst_Hint => 0, + Src_Node => Source.Nodes (Src), + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Source, Src); + end loop; + + return; + end if; + + if Src = 0 then + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + if Is_Less (Target.Nodes (Tgt), Source.Nodes (Src)) then + Compare := -1; + elsif Is_Less (Source.Nodes (Src), Target.Nodes (Tgt)) then + Compare := 1; + else + Compare := 0; + end if; + end; + + if Compare < 0 then + Tgt := Tree_Operations.Next (Target, Tgt); + + elsif Compare > 0 then + Insert_With_Hint + (Dst_Set => Target, + Dst_Hint => Tgt, + Src_Node => Source.Nodes (Src), + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Source, Src); + + else + declare + X : constant Count_Type := Tgt; + begin + Tgt := Tree_Operations.Next (Target, Tgt); + + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Tree_Operations.Free (Target, X); + end; + + Src := Tree_Operations.Next (Source, Src); + end if; + end loop; + end Set_Symmetric_Difference; + + function Set_Symmetric_Difference + (Left, Right : Set_Type) return Set_Type + is + begin + if Left'Address = Right'Address then + return S : Set_Type (0); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + return Result : Set_Type (Left.Length + Right.Length) do + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L_Node : Count_Type; + R_Node : Count_Type; + + Dst_Node : Count_Type; + pragma Warnings (Off, Dst_Node); + + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = 0 then + while R_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (Right, R_Node); + end loop; + + exit; + end if; + + if R_Node = 0 then + while L_Node /= 0 loop + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + end loop; + + exit; + end if; + + if Is_Less (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Left.Nodes (L_Node), + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (Left, L_Node); + + elsif Is_Less (Right.Nodes (R_Node), Left.Nodes (L_Node)) then + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => 0, + Src_Node => Right.Nodes (R_Node), + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (Right, R_Node); + + else + L_Node := Tree_Operations.Next (Left, L_Node); + R_Node := Tree_Operations.Next (Right, R_Node); + end if; + end loop; + end; + end return; + end Set_Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Set_Union (Target : in out Set_Type; Source : Set_Type) is + Hint : Count_Type := 0; + + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Insert_With_Hint + (Dst_Set => Target, + Dst_Hint => Hint, + Src_Node => Source.Nodes (Node), + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + -- Note that there's no way to decide a priori whether the target has + -- enough capacity for the union with source. We cannot simply + -- compare the sum of the existing lengths to the capacity of the + -- target, because equivalent items from source are not included in + -- the union. + + Iterate (Source); + end; + end Set_Union; + + function Set_Union (Left, Right : Set_Type) return Set_Type is + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + return Result : Set_Type (Left.Length + Right.Length) do + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + Assign (Target => Result, Source => Left); + + Insert_Right : declare + Hint : Count_Type := 0; + + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Insert_With_Hint + (Dst_Set => Result, + Dst_Hint => Hint, + Src_Node => Right.Nodes (Node), + Dst_Node => Hint); + end Process; + + -- Start of processing for Insert_Right + + begin + Iterate (Right); + end Insert_Right; + end; + end return; + end Set_Union; + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; diff --git a/gcc/ada/libgnat/a-btgbso.ads b/gcc/ada/libgnat/a-btgbso.ads new file mode 100644 index 0000000..3965d42 --- /dev/null +++ b/gcc/ada/libgnat/a-btgbso.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_SET_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement ordered containers. This package declares +-- set-based tree operations. + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; + +generic + with package Tree_Operations is new Generic_Bounded_Operations (<>); + + type Set_Type is new Tree_Operations.Tree_Types.Tree_Type with private; + + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; + + with procedure Assign (Target : in out Set_Type; Source : Set_Type); + + with procedure Insert_With_Hint + (Dst_Set : in out Set_Type; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type); + + with function Is_Less (Left, Right : Node_Type) return Boolean; + +package Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations is + pragma Pure; + + procedure Set_Union (Target : in out Set_Type; Source : Set_Type); + -- Attempts to insert each element of Source in Target. If Target is + -- busy then Program_Error is raised. We say "attempts" here because + -- if these are unique-element sets, then the insertion should fail + -- (not insert a new item) when the insertion item from Source is + -- equivalent to an item already in Target. If these are multisets + -- then of course the attempt should always succeed. + + function Set_Union (Left, Right : Set_Type) return Set_Type; + -- Makes a copy of Left, and attempts to insert each element of + -- Right into the copy, then returns the copy. + + procedure Set_Intersection (Target : in out Set_Type; Source : Set_Type); + -- Removes elements from Target that are not equivalent to items in + -- Source. If Target is busy then Program_Error is raised. + + function Set_Intersection (Left, Right : Set_Type) return Set_Type; + -- Returns a set comprising all the items in Left equivalent to items in + -- Right. + + procedure Set_Difference (Target : in out Set_Type; Source : Set_Type); + -- Removes elements from Target that are equivalent to items in Source. If + -- Target is busy then Program_Error is raised. + + function Set_Difference (Left, Right : Set_Type) return Set_Type; + -- Returns a set comprising all the items in Left not equivalent to items + -- in Right. + + procedure Set_Symmetric_Difference + (Target : in out Set_Type; + Source : Set_Type); + -- Removes from Target elements that are equivalent to items in Source, + -- and inserts into Target items from Source not equivalent elements in + -- Target. If Target is busy then Program_Error is raised. + + function Set_Symmetric_Difference (Left, Right : Set_Type) return Set_Type; + -- Returns a set comprising the union of the elements in Left not + -- equivalent to items in Right, and the elements in Right not equivalent + -- to items in Left. + + function Set_Subset (Subset : Set_Type; Of_Set : Set_Type) return Boolean; + -- Returns False if Subset contains at least one element not equivalent to + -- any item in Of_Set; returns True otherwise. + + function Set_Overlap (Left, Right : Set_Type) return Boolean; + -- Returns True if at least one element of Left is equivalent to an item in + -- Right; returns False otherwise. + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; diff --git a/gcc/ada/libgnat/a-calari.adb b/gcc/ada/libgnat/a-calari.adb new file mode 100644 index 0000000..77065f2 --- /dev/null +++ b/gcc/ada/libgnat/a-calari.adb @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . A R I T H M E T I C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Calendar.Arithmetic is + + -------------------------- + -- Implementation Notes -- + -------------------------- + + -- All operations in this package are target and time representation + -- independent, thus only one source file is needed for multiple targets. + + --------- + -- "+" -- + --------- + + function "+" (Left : Time; Right : Day_Count) return Time is + R : constant Long_Integer := Long_Integer (Right); + begin + return Arithmetic_Operations.Add (Left, R); + end "+"; + + function "+" (Left : Day_Count; Right : Time) return Time is + L : constant Long_Integer := Long_Integer (Left); + begin + return Arithmetic_Operations.Add (Right, L); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Time; Right : Day_Count) return Time is + R : constant Long_Integer := Long_Integer (Right); + begin + return Arithmetic_Operations.Subtract (Left, R); + end "-"; + + function "-" (Left, Right : Time) return Day_Count is + Days : Long_Integer; + Seconds : Duration; + Leap_Seconds : Integer; + pragma Warnings (Off, Seconds); -- temporary ??? + pragma Warnings (Off, Leap_Seconds); -- temporary ??? + pragma Unreferenced (Seconds, Leap_Seconds); + begin + Arithmetic_Operations.Difference + (Left, Right, Days, Seconds, Leap_Seconds); + return Day_Count (Days); + end "-"; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference + (Left : Time; + Right : Time; + Days : out Day_Count; + Seconds : out Duration; + Leap_Seconds : out Leap_Seconds_Count) + is + Op_Days : Long_Integer; + Op_Leaps : Integer; + begin + Arithmetic_Operations.Difference + (Left, Right, Op_Days, Seconds, Op_Leaps); + Days := Day_Count (Op_Days); + Leap_Seconds := Leap_Seconds_Count (Op_Leaps); + end Difference; + +end Ada.Calendar.Arithmetic; diff --git a/gcc/ada/libgnat/a-calari.ads b/gcc/ada/libgnat/a-calari.ads new file mode 100644 index 0000000..73bd921 --- /dev/null +++ b/gcc/ada/libgnat/a-calari.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . A R I T H M E T I C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides arithmetic operations of time values using days +-- and leap seconds. Ada.Calendar.Arithmetic is defined in the Ada 2005 +-- RM (9.6.1). + +package Ada.Calendar.Arithmetic is + + -- Arithmetic on days: + + -- Rough estimate on the number of days over the range of Ada time + + type Day_Count is range + -(366 * (1 + Year_Number'Last - Year_Number'First)) + .. + +(366 * (1 + Year_Number'Last - Year_Number'First)); + + subtype Leap_Seconds_Count is Integer range -2047 .. 2047; + -- Count of leap seconds. Negative leap seconds occur whenever the + -- astronomical time is faster than the atomic time or as a result of + -- Difference when Left < Right. + + procedure Difference + (Left : Time; + Right : Time; + Days : out Day_Count; + Seconds : out Duration; + Leap_Seconds : out Leap_Seconds_Count); + -- Returns the difference between Left and Right. Days is the number of + -- days of difference, Seconds is the remainder seconds of difference + -- excluding leap seconds, and Leap_Seconds is the number of leap seconds. + -- If Left < Right, then Seconds <= 0.0, Days <= 0, and Leap_Seconds <= 0, + -- otherwise all values are nonnegative. The absolute value of Seconds is + -- always less than 86_400.0. For the returned values, if Days = 0, then + -- Seconds + Duration (Leap_Seconds) = Calendar."-" (Left, Right) + + function "+" (Left : Time; Right : Day_Count) return Time; + function "+" (Left : Day_Count; Right : Time) return Time; + -- Adds a number of days to a time value. Time_Error is raised if the + -- result is not representable as a value of type Time. + + function "-" (Left : Time; Right : Day_Count) return Time; + -- Subtracts a number of days from a time value. Time_Error is raised if + -- the result is not representable as a value of type Time. + + function "-" (Left : Time; Right : Time) return Day_Count; + -- Subtracts two time values, and returns the number of days between them. + -- This is the same value that Difference would return in Days. + +end Ada.Calendar.Arithmetic; diff --git a/gcc/ada/libgnat/a-calcon.adb b/gcc/ada/libgnat/a-calcon.adb new file mode 100644 index 0000000..c17d1f4 --- /dev/null +++ b/gcc/ada/libgnat/a-calcon.adb @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . C O N V E R S I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; use Interfaces.C; + +package body Ada.Calendar.Conversions is + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time (Unix_Time : long) return Time is + Val : constant Long_Integer := Long_Integer (Unix_Time); + begin + return Conversion_Operations.To_Ada_Time (Val); + end To_Ada_Time; + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time + (tm_year : int; + tm_mon : int; + tm_day : int; + tm_hour : int; + tm_min : int; + tm_sec : int; + tm_isdst : int) return Time + is + Year : constant Integer := Integer (tm_year); + Month : constant Integer := Integer (tm_mon); + Day : constant Integer := Integer (tm_day); + Hour : constant Integer := Integer (tm_hour); + Minute : constant Integer := Integer (tm_min); + Second : constant Integer := Integer (tm_sec); + DST : constant Integer := Integer (tm_isdst); + begin + return + Conversion_Operations.To_Ada_Time + (Year, Month, Day, Hour, Minute, Second, DST); + end To_Ada_Time; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration + (tv_sec : long; + tv_nsec : long) return Duration + is + Secs : constant Long_Integer := Long_Integer (tv_sec); + Nano_Secs : constant Long_Integer := Long_Integer (tv_nsec); + begin + return Conversion_Operations.To_Duration (Secs, Nano_Secs); + end To_Duration; + + ------------------------ + -- To_Struct_Timespec -- + ------------------------ + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out long; + tv_nsec : out long) + is + Secs : Long_Integer; + Nano_Secs : Long_Integer; + + begin + Conversion_Operations.To_Struct_Timespec (D, Secs, Nano_Secs); + + tv_sec := long (Secs); + tv_nsec := long (Nano_Secs); + end To_Struct_Timespec; + + ------------------ + -- To_Struct_Tm -- + ------------------ + + procedure To_Struct_Tm + (T : Time; + tm_year : out int; + tm_mon : out int; + tm_day : out int; + tm_hour : out int; + tm_min : out int; + tm_sec : out int) + is + Year : Integer; + Month : Integer; + Day : Integer; + Hour : Integer; + Minute : Integer; + Second : Integer; + + begin + Conversion_Operations.To_Struct_Tm + (T, Year, Month, Day, Hour, Minute, Second); + + tm_year := int (Year); + tm_mon := int (Month); + tm_day := int (Day); + tm_hour := int (Hour); + tm_min := int (Minute); + tm_sec := int (Second); + end To_Struct_Tm; + + ------------------ + -- To_Unix_Time -- + ------------------ + + function To_Unix_Time (Ada_Time : Time) return long is + Val : constant Long_Integer := + Conversion_Operations.To_Unix_Time (Ada_Time); + begin + return long (Val); + end To_Unix_Time; + +end Ada.Calendar.Conversions; diff --git a/gcc/ada/libgnat/a-calcon.ads b/gcc/ada/libgnat/a-calcon.ads new file mode 100644 index 0000000..f62e89e --- /dev/null +++ b/gcc/ada/libgnat/a-calcon.ads @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . C O N V E R S I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides various routines for conversion between Ada and Unix +-- time models - Time, Duration, struct tm and struct timespec. + +with Interfaces.C; + +package Ada.Calendar.Conversions is + + function To_Ada_Time (Unix_Time : Interfaces.C.long) return Time; + -- Convert a time value represented as number of seconds since the + -- Unix Epoch to a time value relative to an Ada implementation-defined + -- Epoch. The units of the result are nanoseconds on all targets. Raises + -- Time_Error if the result cannot fit into a Time value. + + function To_Ada_Time + (tm_year : Interfaces.C.int; + tm_mon : Interfaces.C.int; + tm_day : Interfaces.C.int; + tm_hour : Interfaces.C.int; + tm_min : Interfaces.C.int; + tm_sec : Interfaces.C.int; + tm_isdst : Interfaces.C.int) return Time; + -- Convert a time value expressed in Unix-like fields of struct tm into + -- a Time value relative to the Ada Epoch. The ranges of the formals are + -- as follows: + + -- tm_year -- years since 1900 + -- tm_mon -- months since January [0 .. 11] + -- tm_day -- day of the month [1 .. 31] + -- tm_hour -- hours since midnight [0 .. 24] + -- tm_min -- minutes after the hour [0 .. 59] + -- tm_sec -- seconds after the minute [0 .. 60] + -- tm_isdst -- Daylight Savings Time flag [-1 .. 1] + + -- The returned value is in UTC and may or may not contain leap seconds + -- depending on whether binder flag "-y" was used. Raises Time_Error if + -- the input values are out of the defined ranges or if tm_sec equals 60 + -- and the instance in time is not a leap second occurrence. + + function To_Duration + (tv_sec : Interfaces.C.long; + tv_nsec : Interfaces.C.long) return Duration; + -- Convert an elapsed time value expressed in Unix-like fields of struct + -- timespec into a Duration value. The expected ranges are: + + -- tv_sec - seconds + -- tv_nsec - nanoseconds + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out Interfaces.C.long; + tv_nsec : out Interfaces.C.long); + -- Convert a Duration value into the constituents of struct timespec. + -- Formal tv_sec denotes seconds and tv_nsecs denotes nanoseconds. + + procedure To_Struct_Tm + (T : Time; + tm_year : out Interfaces.C.int; + tm_mon : out Interfaces.C.int; + tm_day : out Interfaces.C.int; + tm_hour : out Interfaces.C.int; + tm_min : out Interfaces.C.int; + tm_sec : out Interfaces.C.int); + -- Convert a Time value set in the Ada Epoch into the constituents of + -- struct tm. The ranges of the out formals are as follows: + + -- tm_year -- years since 1900 + -- tm_mon -- months since January [0 .. 11] + -- tm_day -- day of the month [1 .. 31] + -- tm_hour -- hours since midnight [0 .. 24] + -- tm_min -- minutes after the hour [0 .. 59] + -- tm_sec -- seconds after the minute [0 .. 60] + -- tm_isdst -- Daylight Savings Time flag [-1 .. 1] + + -- The input date is considered to be in UTC + + function To_Unix_Time (Ada_Time : Time) return Interfaces.C.long; + -- Convert a time value represented as number of time units since the Ada + -- implementation-defined Epoch to a value relative to the Unix Epoch. The + -- units of the result are seconds. Raises Time_Error if the result cannot + -- fit into a Time value. + +end Ada.Calendar.Conversions; diff --git a/gcc/ada/libgnat/a-caldel.adb b/gcc/ada/libgnat/a-caldel.adb new file mode 100644 index 0000000..bde488a --- /dev/null +++ b/gcc/ada/libgnat/a-caldel.adb @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . D E L A Y S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1991-2017, Florida State University -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.OS_Primitives; +with System.Soft_Links; + +package body Ada.Calendar.Delays is + + package OSP renames System.OS_Primitives; + package SSL renames System.Soft_Links; + + use type SSL.Timed_Delay_Call; + + -- Earlier, System.Time_Operations was used to implement the following + -- operations. The idea was to avoid sucking in the tasking packages. This + -- did not work. Logically, we can't have it both ways. There is no way to + -- implement time delays that will have correct task semantics without + -- reference to the tasking run-time system. To achieve this goal, we now + -- use soft links. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Timed_Delay_NT (Time : Duration; Mode : Integer); + -- Timed delay procedure used when no tasking is active + + --------------- + -- Delay_For -- + --------------- + + procedure Delay_For (D : Duration) is + begin + SSL.Timed_Delay.all (Duration'Min (D, OSP.Max_Sensible_Delay), + OSP.Relative); + end Delay_For; + + ----------------- + -- Delay_Until -- + ----------------- + + procedure Delay_Until (T : Time) is + D : constant Duration := To_Duration (T); + + begin + SSL.Timed_Delay.all (D, OSP.Absolute_Calendar); + end Delay_Until; + + -------------------- + -- Timed_Delay_NT -- + -------------------- + + procedure Timed_Delay_NT (Time : Duration; Mode : Integer) is + begin + OSP.Timed_Delay (Time, Mode); + end Timed_Delay_NT; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : Time) return Duration is + begin + -- Since time has multiple representations on different platforms, a + -- target independent operation in Ada.Calendar is used to perform + -- this conversion. + + return Delay_Operations.To_Duration (T); + end To_Duration; + +begin + -- Set up the Timed_Delay soft link to the non tasking version if it has + -- not been already set. If tasking is present, Timed_Delay has already set + -- this soft link, or this will be overridden during the elaboration of + -- System.Tasking.Initialization + + if SSL.Timed_Delay = null then + SSL.Timed_Delay := Timed_Delay_NT'Access; + end if; + +end Ada.Calendar.Delays; diff --git a/gcc/ada/libgnat/a-caldel.ads b/gcc/ada/libgnat/a-caldel.ads new file mode 100644 index 0000000..66429dc --- /dev/null +++ b/gcc/ada/libgnat/a-caldel.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . D E L A Y S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements Calendar.Time delays using protected objects + +-- Note: the compiler generates direct calls to this interface, in the +-- processing of time types. + +package Ada.Calendar.Delays is + + procedure Delay_For (D : Duration); + -- Delay until an interval of length (at least) D seconds has passed, or + -- the task is aborted to at least the current ATC nesting level. This is + -- an abort completion point. The body of this procedure must perform all + -- the processing required for an abort point. + + procedure Delay_Until (T : Time); + -- Delay until Clock has reached (at least) time T, or the task is aborted + -- to at least the current ATC nesting level. The body of this procedure + -- must perform all the processing required for an abort point. + + function To_Duration (T : Time) return Duration; + -- Convert Time to Duration elapsed since UNIX epoch + +end Ada.Calendar.Delays; diff --git a/gcc/ada/libgnat/a-calend.adb b/gcc/ada/libgnat/a-calend.adb new file mode 100644 index 0000000..7721d8d --- /dev/null +++ b/gcc/ada/libgnat/a-calend.adb @@ -0,0 +1,1580 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +with System.OS_Primitives; + +package body Ada.Calendar with + SPARK_Mode => Off +is + + -------------------------- + -- Implementation Notes -- + -------------------------- + + -- In complex algorithms, some variables of type Ada.Calendar.Time carry + -- suffix _S or _N to denote units of seconds or nanoseconds. + -- + -- Because time is measured in different units and from different origins + -- on various targets, a system independent model is incorporated into + -- Ada.Calendar. The idea behind the design is to encapsulate all target + -- dependent machinery in a single package, thus providing a uniform + -- interface to all existing and any potential children. + + -- package Ada.Calendar + -- procedure Split (5 parameters) -------+ + -- | Call from local routine + -- private | + -- package Formatting_Operations | + -- procedure Split (11 parameters) <--+ + -- end Formatting_Operations | + -- end Ada.Calendar | + -- | + -- package Ada.Calendar.Formatting | Call from child routine + -- procedure Split (9 or 10 parameters) -+ + -- end Ada.Calendar.Formatting + + -- The behavior of the interfacing routines is controlled via various + -- flags. All new Ada 2005 types from children of Ada.Calendar are + -- emulated by a similar type. For instance, type Day_Number is replaced + -- by Integer in various routines. One ramification of this model is that + -- the caller site must perform validity checks on returned results. + -- The end result of this model is the lack of target specific files per + -- child of Ada.Calendar (e.g. a-calfor). + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Check_Within_Time_Bounds (T : Time_Rep); + -- Ensure that a time representation value falls withing the bounds of Ada + -- time. Leap seconds support is taken into account. + + procedure Cumulative_Leap_Seconds + (Start_Date : Time_Rep; + End_Date : Time_Rep; + Elapsed_Leaps : out Natural; + Next_Leap : out Time_Rep); + -- Elapsed_Leaps is the sum of the leap seconds that have occurred on or + -- after Start_Date and before (strictly before) End_Date. Next_Leap_Sec + -- represents the next leap second occurrence on or after End_Date. If + -- there are no leaps seconds after End_Date, End_Of_Time is returned. + -- End_Of_Time can be used as End_Date to count all the leap seconds that + -- have occurred on or after Start_Date. + -- + -- Note: Any sub seconds of Start_Date and End_Date are discarded before + -- the calculations are done. For instance: if 113 seconds is a leap + -- second (it isn't) and 113.5 is input as an End_Date, the leap second + -- at 113 will not be counted in Leaps_Between, but it will be returned + -- as Next_Leap_Sec. Thus, if the caller wants to know if the End_Date is + -- a leap second, the comparison should be: + -- + -- End_Date >= Next_Leap_Sec; + -- + -- After_Last_Leap is designed so that this comparison works without + -- having to first check if Next_Leap_Sec is a valid leap second. + + function Duration_To_Time_Rep is + new Ada.Unchecked_Conversion (Duration, Time_Rep); + -- Convert a duration value into a time representation value + + function Time_Rep_To_Duration is + new Ada.Unchecked_Conversion (Time_Rep, Duration); + -- Convert a time representation value into a duration value + + function UTC_Time_Offset + (Date : Time; + Is_Historic : Boolean) return Long_Integer; + -- This routine acts as an Ada wrapper around __gnat_localtime_tzoff which + -- in turn utilizes various OS-dependent mechanisms to calculate the time + -- zone offset of a date. Formal parameter Date represents an arbitrary + -- time stamp, either in the past, now, or in the future. If the flag + -- Is_Historic is set, this routine would try to calculate to the best of + -- the OS's abilities the time zone offset that was or will be in effect + -- on Date. If the flag is set to False, the routine returns the current + -- time zone with Date effectively set to Clock. + -- + -- NOTE: Targets which support localtime_r will aways return a historic + -- time zone even if flag Is_Historic is set to False because this is how + -- localtime_r operates. + + ----------------- + -- Local Types -- + ----------------- + + -- An integer time duration. The type is used whenever a positive elapsed + -- duration is needed, for instance when splitting a time value. Here is + -- how Time_Rep and Time_Dur are related: + + -- 'First Ada_Low Ada_High 'Last + -- Time_Rep: +-------+------------------------+---------+ + -- Time_Dur: +------------------------+---------+ + -- 0 'Last + + type Time_Dur is range 0 .. 2 ** 63 - 1; + + -------------------------- + -- Leap seconds control -- + -------------------------- + + Flag : Integer; + pragma Import (C, Flag, "__gl_leap_seconds_support"); + -- This imported value is used to determine whether the compilation had + -- binder flag "-y" present which enables leap seconds. A value of zero + -- signifies no leap seconds support while a value of one enables support. + + Leap_Support : constant Boolean := (Flag = 1); + -- Flag to controls the usage of leap seconds in all Ada.Calendar routines + + Leap_Seconds_Count : constant Natural := 25; + + --------------------- + -- Local Constants -- + --------------------- + + Ada_Min_Year : constant Year_Number := Year_Number'First; + Secs_In_Four_Years : constant := (3 * 365 + 366) * Secs_In_Day; + Secs_In_Non_Leap_Year : constant := 365 * Secs_In_Day; + Nanos_In_Four_Years : constant := Secs_In_Four_Years * Nano; + + -- Lower and upper bound of Ada time. The zero (0) value of type Time is + -- positioned at year 2150. Note that the lower and upper bound account + -- for the non-leap centennial years. + + Ada_Low : constant Time_Rep := -(61 * 366 + 188 * 365) * Nanos_In_Day; + Ada_High : constant Time_Rep := (60 * 366 + 190 * 365) * Nanos_In_Day; + + -- Even though the upper bound of time is 2399-12-31 23:59:59.999999999 + -- UTC, it must be increased to include all leap seconds. + + Ada_High_And_Leaps : constant Time_Rep := + Ada_High + Time_Rep (Leap_Seconds_Count) * Nano; + + -- Two constants used in the calculations of elapsed leap seconds. + -- End_Of_Time is later than Ada_High in time zone -28. Start_Of_Time + -- is earlier than Ada_Low in time zone +28. + + End_Of_Time : constant Time_Rep := + Ada_High + Time_Rep (3) * Nanos_In_Day; + Start_Of_Time : constant Time_Rep := + Ada_Low - Time_Rep (3) * Nanos_In_Day; + + -- The Unix lower time bound expressed as nanoseconds since the start of + -- Ada time in UTC. + + Unix_Min : constant Time_Rep := + Ada_Low + Time_Rep (17 * 366 + 52 * 365) * Nanos_In_Day; + + -- The Unix upper time bound expressed as nanoseconds since the start of + -- Ada time in UTC. + + Unix_Max : constant Time_Rep := + Ada_Low + Time_Rep (34 * 366 + 102 * 365) * Nanos_In_Day + + Time_Rep (Leap_Seconds_Count) * Nano; + + Epoch_Offset : constant Time_Rep := (136 * 365 + 44 * 366) * Nanos_In_Day; + -- The difference between 2150-1-1 UTC and 1970-1-1 UTC expressed in + -- nanoseconds. Note that year 2100 is non-leap. + + Cumulative_Days_Before_Month : + constant array (Month_Number) of Natural := + (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334); + + -- The following table contains the hard time values of all existing leap + -- seconds. The values are produced by the utility program xleaps.adb. This + -- must be updated when additional leap second times are defined. + + Leap_Second_Times : constant array (1 .. Leap_Seconds_Count) of Time_Rep := + (-5601484800000000000, + -5585587199000000000, + -5554051198000000000, + -5522515197000000000, + -5490979196000000000, + -5459356795000000000, + -5427820794000000000, + -5396284793000000000, + -5364748792000000000, + -5317487991000000000, + -5285951990000000000, + -5254415989000000000, + -5191257588000000000, + -5112287987000000000, + -5049129586000000000, + -5017593585000000000, + -4970332784000000000, + -4938796783000000000, + -4907260782000000000, + -4859827181000000000, + -4812566380000000000, + -4765132779000000000, + -4544207978000000000, + -4449513577000000000, + -4339180776000000000); + + --------- + -- "+" -- + --------- + + function "+" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + Left_N : constant Time_Rep := Time_Rep (Left); + begin + return Time (Left_N + Duration_To_Time_Rep (Right)); + exception + when Constraint_Error => + raise Time_Error; + end "+"; + + function "+" (Left : Duration; Right : Time) return Time is + begin + return Right + Left; + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Time; Right : Duration) return Time is + pragma Unsuppress (Overflow_Check); + Left_N : constant Time_Rep := Time_Rep (Left); + begin + return Time (Left_N - Duration_To_Time_Rep (Right)); + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + function "-" (Left : Time; Right : Time) return Duration is + pragma Unsuppress (Overflow_Check); + + Dur_Low : constant Time_Rep := Duration_To_Time_Rep (Duration'First); + Dur_High : constant Time_Rep := Duration_To_Time_Rep (Duration'Last); + -- The bounds of type Duration expressed as time representations + + Res_N : Time_Rep; + + begin + Res_N := Time_Rep (Left) - Time_Rep (Right); + + -- Due to the extended range of Ada time, "-" is capable of producing + -- results which may exceed the range of Duration. In order to prevent + -- the generation of bogus values by the Unchecked_Conversion, we apply + -- the following check. + + if Res_N < Dur_Low or else Res_N > Dur_High then + raise Time_Error; + end if; + + return Time_Rep_To_Duration (Res_N); + + exception + when Constraint_Error => + raise Time_Error; + end "-"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Time) return Boolean is + begin + return Time_Rep (Left) < Time_Rep (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Time) return Boolean is + begin + return Time_Rep (Left) <= Time_Rep (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Time) return Boolean is + begin + return Time_Rep (Left) > Time_Rep (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Time) return Boolean is + begin + return Time_Rep (Left) >= Time_Rep (Right); + end ">="; + + ------------------------------ + -- Check_Within_Time_Bounds -- + ------------------------------ + + procedure Check_Within_Time_Bounds (T : Time_Rep) is + begin + if Leap_Support then + if T < Ada_Low or else T > Ada_High_And_Leaps then + raise Time_Error; + end if; + else + if T < Ada_Low or else T > Ada_High then + raise Time_Error; + end if; + end if; + end Check_Within_Time_Bounds; + + ----------- + -- Clock -- + ----------- + + function Clock return Time is + Elapsed_Leaps : Natural; + Next_Leap_N : Time_Rep; + + -- The system clock returns the time in UTC since the Unix Epoch of + -- 1970-01-01 00:00:00.0. We perform an origin shift to the Ada Epoch + -- by adding the number of nanoseconds between the two origins. + + Res_N : Time_Rep := + Duration_To_Time_Rep (System.OS_Primitives.Clock) + Unix_Min; + + begin + -- If the target supports leap seconds, determine the number of leap + -- seconds elapsed until this moment. + + if Leap_Support then + Cumulative_Leap_Seconds + (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); + + -- The system clock may fall exactly on a leap second + + if Res_N >= Next_Leap_N then + Elapsed_Leaps := Elapsed_Leaps + 1; + end if; + + -- The target does not support leap seconds + + else + Elapsed_Leaps := 0; + end if; + + Res_N := Res_N + Time_Rep (Elapsed_Leaps) * Nano; + + return Time (Res_N); + end Clock; + + ----------------------------- + -- Cumulative_Leap_Seconds -- + ----------------------------- + + procedure Cumulative_Leap_Seconds + (Start_Date : Time_Rep; + End_Date : Time_Rep; + Elapsed_Leaps : out Natural; + Next_Leap : out Time_Rep) + is + End_Index : Positive; + End_T : Time_Rep := End_Date; + Start_Index : Positive; + Start_T : Time_Rep := Start_Date; + + begin + -- Both input dates must be normalized to UTC + + pragma Assert (Leap_Support and then End_Date >= Start_Date); + + Next_Leap := End_Of_Time; + + -- Make sure that the end date does not exceed the upper bound + -- of Ada time. + + if End_Date > Ada_High then + End_T := Ada_High; + end if; + + -- Remove the sub seconds from both dates + + Start_T := Start_T - (Start_T mod Nano); + End_T := End_T - (End_T mod Nano); + + -- Some trivial cases: + -- Leap 1 . . . Leap N + -- ---+========+------+############+-------+========+----- + -- Start_T End_T Start_T End_T + + if End_T < Leap_Second_Times (1) then + Elapsed_Leaps := 0; + Next_Leap := Leap_Second_Times (1); + return; + + elsif Start_T > Leap_Second_Times (Leap_Seconds_Count) then + Elapsed_Leaps := 0; + Next_Leap := End_Of_Time; + return; + end if; + + -- Perform the calculations only if the start date is within the leap + -- second occurrences table. + + if Start_T <= Leap_Second_Times (Leap_Seconds_Count) then + + -- 1 2 N - 1 N + -- +----+----+-- . . . --+-------+---+ + -- | T1 | T2 | | N - 1 | N | + -- +----+----+-- . . . --+-------+---+ + -- ^ ^ + -- | Start_Index | End_Index + -- +-------------------+ + -- Leaps_Between + + -- The idea behind the algorithm is to iterate and find two + -- closest dates which are after Start_T and End_T. Their + -- corresponding index difference denotes the number of leap + -- seconds elapsed. + + Start_Index := 1; + loop + exit when Leap_Second_Times (Start_Index) >= Start_T; + Start_Index := Start_Index + 1; + end loop; + + End_Index := Start_Index; + loop + exit when End_Index > Leap_Seconds_Count + or else Leap_Second_Times (End_Index) >= End_T; + End_Index := End_Index + 1; + end loop; + + if End_Index <= Leap_Seconds_Count then + Next_Leap := Leap_Second_Times (End_Index); + end if; + + Elapsed_Leaps := End_Index - Start_Index; + + else + Elapsed_Leaps := 0; + end if; + end Cumulative_Leap_Seconds; + + --------- + -- Day -- + --------- + + function Day (Date : Time) return Day_Number is + D : Day_Number; + Y : Year_Number; + M : Month_Number; + S : Day_Duration; + pragma Unreferenced (Y, M, S); + begin + Split (Date, Y, M, D, S); + return D; + end Day; + + ------------- + -- Is_Leap -- + ------------- + + function Is_Leap (Year : Year_Number) return Boolean is + begin + -- Leap centennial years + + if Year mod 400 = 0 then + return True; + + -- Non-leap centennial years + + elsif Year mod 100 = 0 then + return False; + + -- Regular years + + else + return Year mod 4 = 0; + end if; + end Is_Leap; + + ----------- + -- Month -- + ----------- + + function Month (Date : Time) return Month_Number is + Y : Year_Number; + M : Month_Number; + D : Day_Number; + S : Day_Duration; + pragma Unreferenced (Y, D, S); + begin + Split (Date, Y, M, D, S); + return M; + end Month; + + ------------- + -- Seconds -- + ------------- + + function Seconds (Date : Time) return Day_Duration is + Y : Year_Number; + M : Month_Number; + D : Day_Number; + S : Day_Duration; + pragma Unreferenced (Y, M, D); + begin + Split (Date, Y, M, D, S); + return S; + end Seconds; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration) + is + H : Integer; + M : Integer; + Se : Integer; + Ss : Duration; + Le : Boolean; + + pragma Unreferenced (H, M, Se, Ss, Le); + + begin + -- Even though the input time zone is UTC (0), the flag Use_TZ will + -- ensure that Split picks up the local time zone. + + Formatting_Operations.Split + (Date => Date, + Year => Year, + Month => Month, + Day => Day, + Day_Secs => Seconds, + Hour => H, + Minute => M, + Second => Se, + Sub_Sec => Ss, + Leap_Sec => Le, + Use_TZ => False, + Is_Historic => True, + Time_Zone => 0); + + -- Validity checks + + if not Year'Valid or else + not Month'Valid or else + not Day'Valid or else + not Seconds'Valid + then + raise Time_Error; + end if; + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) return Time + is + -- The values in the following constants are irrelevant, they are just + -- placeholders; the choice of constructing a Day_Duration value is + -- controlled by the Use_Day_Secs flag. + + H : constant Integer := 1; + M : constant Integer := 1; + Se : constant Integer := 1; + Ss : constant Duration := 0.1; + + begin + -- Validity checks + + if not Year'Valid or else + not Month'Valid or else + not Day'Valid or else + not Seconds'Valid + then + raise Time_Error; + end if; + + -- Even though the input time zone is UTC (0), the flag Use_TZ will + -- ensure that Split picks up the local time zone. + + return + Formatting_Operations.Time_Of + (Year => Year, + Month => Month, + Day => Day, + Day_Secs => Seconds, + Hour => H, + Minute => M, + Second => Se, + Sub_Sec => Ss, + Leap_Sec => False, + Use_Day_Secs => True, + Use_TZ => False, + Is_Historic => True, + Time_Zone => 0); + end Time_Of; + + --------------------- + -- UTC_Time_Offset -- + --------------------- + + function UTC_Time_Offset + (Date : Time; + Is_Historic : Boolean) return Long_Integer + is + -- The following constants denote February 28 during non-leap centennial + -- years, the units are nanoseconds. + + T_2100_2_28 : constant Time_Rep := Ada_Low + + (Time_Rep (49 * 366 + 150 * 365 + 59) * Secs_In_Day + + Time_Rep (Leap_Seconds_Count)) * Nano; + + T_2200_2_28 : constant Time_Rep := Ada_Low + + (Time_Rep (73 * 366 + 226 * 365 + 59) * Secs_In_Day + + Time_Rep (Leap_Seconds_Count)) * Nano; + + T_2300_2_28 : constant Time_Rep := Ada_Low + + (Time_Rep (97 * 366 + 302 * 365 + 59) * Secs_In_Day + + Time_Rep (Leap_Seconds_Count)) * Nano; + + -- 56 years (14 leap years + 42 non-leap years) in nanoseconds: + + Nanos_In_56_Years : constant := (14 * 366 + 42 * 365) * Nanos_In_Day; + + type int_Pointer is access all Interfaces.C.int; + type long_Pointer is access all Interfaces.C.long; + + type time_t is + range -(2 ** (Standard'Address_Size - Integer'(1))) .. + +(2 ** (Standard'Address_Size - Integer'(1)) - 1); + type time_t_Pointer is access all time_t; + + procedure localtime_tzoff + (timer : time_t_Pointer; + is_historic : int_Pointer; + off : long_Pointer); + pragma Import (C, localtime_tzoff, "__gnat_localtime_tzoff"); + -- This routine is a interfacing wrapper around the library function + -- __gnat_localtime_tzoff. Parameter 'timer' represents a Unix-based + -- time equivalent of the input date. If flag 'is_historic' is set, this + -- routine would try to calculate to the best of the OS's abilities the + -- time zone offset that was or will be in effect on 'timer'. If the + -- flag is set to False, the routine returns the current time zone + -- regardless of what 'timer' designates. Parameter 'off' captures the + -- UTC offset of 'timer'. + + Adj_Cent : Integer; + Date_N : Time_Rep; + Flag : aliased Interfaces.C.int; + Offset : aliased Interfaces.C.long; + Secs_T : aliased time_t; + + -- Start of processing for UTC_Time_Offset + + begin + Date_N := Time_Rep (Date); + + -- Dates which are 56 years apart fall on the same day, day light saving + -- and so on. Non-leap centennial years violate this rule by one day and + -- as a consequence, special adjustment is needed. + + Adj_Cent := + (if Date_N <= T_2100_2_28 then 0 + elsif Date_N <= T_2200_2_28 then 1 + elsif Date_N <= T_2300_2_28 then 2 + else 3); + + if Adj_Cent > 0 then + Date_N := Date_N - Time_Rep (Adj_Cent) * Nanos_In_Day; + end if; + + -- Shift the date within bounds of Unix time + + while Date_N < Unix_Min loop + Date_N := Date_N + Nanos_In_56_Years; + end loop; + + while Date_N >= Unix_Max loop + Date_N := Date_N - Nanos_In_56_Years; + end loop; + + -- Perform a shift in origins from Ada to Unix + + Date_N := Date_N - Unix_Min; + + -- Convert the date into seconds + + Secs_T := time_t (Date_N / Nano); + + -- Determine whether to treat the input date as historical or not. A + -- value of "0" signifies that the date is NOT historic. + + Flag := (if Is_Historic then 1 else 0); + + localtime_tzoff + (Secs_T'Unchecked_Access, + Flag'Unchecked_Access, + Offset'Unchecked_Access); + + return Long_Integer (Offset); + end UTC_Time_Offset; + + ---------- + -- Year -- + ---------- + + function Year (Date : Time) return Year_Number is + Y : Year_Number; + M : Month_Number; + D : Day_Number; + S : Day_Duration; + pragma Unreferenced (M, D, S); + begin + Split (Date, Y, M, D, S); + return Y; + end Year; + + -- The following packages assume that Time is a signed 64 bit integer + -- type, the units are nanoseconds and the origin is the start of Ada + -- time (1901-01-01 00:00:00.0 UTC). + + --------------------------- + -- Arithmetic_Operations -- + --------------------------- + + package body Arithmetic_Operations is + + --------- + -- Add -- + --------- + + function Add (Date : Time; Days : Long_Integer) return Time is + pragma Unsuppress (Overflow_Check); + Date_N : constant Time_Rep := Time_Rep (Date); + begin + return Time (Date_N + Time_Rep (Days) * Nanos_In_Day); + exception + when Constraint_Error => + raise Time_Error; + end Add; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference + (Left : Time; + Right : Time; + Days : out Long_Integer; + Seconds : out Duration; + Leap_Seconds : out Integer) + is + Res_Dur : Time_Dur; + Earlier : Time_Rep; + Elapsed_Leaps : Natural; + Later : Time_Rep; + Negate : Boolean := False; + Next_Leap_N : Time_Rep; + Sub_Secs : Duration; + Sub_Secs_Diff : Time_Rep; + + begin + -- Both input time values are assumed to be in UTC + + if Left >= Right then + Later := Time_Rep (Left); + Earlier := Time_Rep (Right); + else + Later := Time_Rep (Right); + Earlier := Time_Rep (Left); + Negate := True; + end if; + + -- If the target supports leap seconds, process them + + if Leap_Support then + Cumulative_Leap_Seconds + (Earlier, Later, Elapsed_Leaps, Next_Leap_N); + + if Later >= Next_Leap_N then + Elapsed_Leaps := Elapsed_Leaps + 1; + end if; + + -- The target does not support leap seconds + + else + Elapsed_Leaps := 0; + end if; + + -- Sub seconds processing. We add the resulting difference to one + -- of the input dates in order to account for any potential rounding + -- of the difference in the next step. + + Sub_Secs_Diff := Later mod Nano - Earlier mod Nano; + Earlier := Earlier + Sub_Secs_Diff; + Sub_Secs := Duration (Sub_Secs_Diff) / Nano_F; + + -- Difference processing. This operation should be able to calculate + -- the difference between opposite values which are close to the end + -- and start of Ada time. To accommodate the large range, we convert + -- to seconds. This action may potentially round the two values and + -- either add or drop a second. We compensate for this issue in the + -- previous step. + + Res_Dur := + Time_Dur (Later / Nano - Earlier / Nano) - Time_Dur (Elapsed_Leaps); + + Days := Long_Integer (Res_Dur / Secs_In_Day); + Seconds := Duration (Res_Dur mod Secs_In_Day) + Sub_Secs; + Leap_Seconds := Integer (Elapsed_Leaps); + + if Negate then + Days := -Days; + Seconds := -Seconds; + + if Leap_Seconds /= 0 then + Leap_Seconds := -Leap_Seconds; + end if; + end if; + end Difference; + + -------------- + -- Subtract -- + -------------- + + function Subtract (Date : Time; Days : Long_Integer) return Time is + pragma Unsuppress (Overflow_Check); + Date_N : constant Time_Rep := Time_Rep (Date); + begin + return Time (Date_N - Time_Rep (Days) * Nanos_In_Day); + exception + when Constraint_Error => + raise Time_Error; + end Subtract; + + end Arithmetic_Operations; + + --------------------------- + -- Conversion_Operations -- + --------------------------- + + package body Conversion_Operations is + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time (Unix_Time : Long_Integer) return Time is + pragma Unsuppress (Overflow_Check); + Unix_Rep : constant Time_Rep := Time_Rep (Unix_Time) * Nano; + begin + return Time (Unix_Rep - Epoch_Offset); + exception + when Constraint_Error => + raise Time_Error; + end To_Ada_Time; + + ----------------- + -- To_Ada_Time -- + ----------------- + + function To_Ada_Time + (tm_year : Integer; + tm_mon : Integer; + tm_day : Integer; + tm_hour : Integer; + tm_min : Integer; + tm_sec : Integer; + tm_isdst : Integer) return Time + is + pragma Unsuppress (Overflow_Check); + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Second : Integer; + Leap : Boolean; + Result : Time_Rep; + + begin + -- Input processing + + Year := Year_Number (1900 + tm_year); + Month := Month_Number (1 + tm_mon); + Day := Day_Number (tm_day); + + -- Step 1: Validity checks of input values + + if not Year'Valid or else not Month'Valid or else not Day'Valid + or else tm_hour not in 0 .. 24 + or else tm_min not in 0 .. 59 + or else tm_sec not in 0 .. 60 + or else tm_isdst not in -1 .. 1 + then + raise Time_Error; + end if; + + -- Step 2: Potential leap second + + if tm_sec = 60 then + Leap := True; + Second := 59; + else + Leap := False; + Second := tm_sec; + end if; + + -- Step 3: Calculate the time value + + Result := + Time_Rep + (Formatting_Operations.Time_Of + (Year => Year, + Month => Month, + Day => Day, + Day_Secs => 0.0, -- Time is given in h:m:s + Hour => tm_hour, + Minute => tm_min, + Second => Second, + Sub_Sec => 0.0, -- No precise sub second given + Leap_Sec => Leap, + Use_Day_Secs => False, -- Time is given in h:m:s + Use_TZ => True, -- Force usage of explicit time zone + Is_Historic => True, + Time_Zone => 0)); -- Place the value in UTC + + -- Step 4: Daylight Savings Time + + if tm_isdst = 1 then + Result := Result + Time_Rep (3_600) * Nano; + end if; + + return Time (Result); + + exception + when Constraint_Error => + raise Time_Error; + end To_Ada_Time; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration + (tv_sec : Long_Integer; + tv_nsec : Long_Integer) return Duration + is + pragma Unsuppress (Overflow_Check); + begin + return Duration (tv_sec) + Duration (tv_nsec) / Nano_F; + end To_Duration; + + ------------------------ + -- To_Struct_Timespec -- + ------------------------ + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out Long_Integer; + tv_nsec : out Long_Integer) + is + pragma Unsuppress (Overflow_Check); + Secs : Duration; + Nano_Secs : Duration; + + begin + -- Seconds extraction, avoid potential rounding errors + + Secs := D - 0.5; + tv_sec := Long_Integer (Secs); + + -- Nanoseconds extraction + + Nano_Secs := D - Duration (tv_sec); + tv_nsec := Long_Integer (Nano_Secs * Nano); + end To_Struct_Timespec; + + ------------------ + -- To_Struct_Tm -- + ------------------ + + procedure To_Struct_Tm + (T : Time; + tm_year : out Integer; + tm_mon : out Integer; + tm_day : out Integer; + tm_hour : out Integer; + tm_min : out Integer; + tm_sec : out Integer) + is + pragma Unsuppress (Overflow_Check); + Year : Year_Number; + Month : Month_Number; + Second : Integer; + Day_Secs : Day_Duration; + Sub_Sec : Duration; + Leap_Sec : Boolean; + + begin + -- Step 1: Split the input time + + Formatting_Operations.Split + (Date => T, + Year => Year, + Month => Month, + Day => tm_day, + Day_Secs => Day_Secs, + Hour => tm_hour, + Minute => tm_min, + Second => Second, + Sub_Sec => Sub_Sec, + Leap_Sec => Leap_Sec, + Use_TZ => True, + Is_Historic => False, + Time_Zone => 0); + + -- Step 2: Correct the year and month + + tm_year := Year - 1900; + tm_mon := Month - 1; + + -- Step 3: Handle leap second occurrences + + tm_sec := (if Leap_Sec then 60 else Second); + end To_Struct_Tm; + + ------------------ + -- To_Unix_Time -- + ------------------ + + function To_Unix_Time (Ada_Time : Time) return Long_Integer is + pragma Unsuppress (Overflow_Check); + Ada_Rep : constant Time_Rep := Time_Rep (Ada_Time); + begin + return Long_Integer ((Ada_Rep + Epoch_Offset) / Nano); + exception + when Constraint_Error => + raise Time_Error; + end To_Unix_Time; + end Conversion_Operations; + + ---------------------- + -- Delay_Operations -- + ---------------------- + + package body Delay_Operations is + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (Date : Time) return Duration is + pragma Unsuppress (Overflow_Check); + + Safe_Ada_High : constant Time_Rep := Ada_High - Epoch_Offset; + -- This value represents a "safe" end of time. In order to perform a + -- proper conversion to Unix duration, we will have to shift origins + -- at one point. For very distant dates, this means an overflow check + -- failure. To prevent this, the function returns the "safe" end of + -- time (roughly 2219) which is still distant enough. + + Elapsed_Leaps : Natural; + Next_Leap_N : Time_Rep; + Res_N : Time_Rep; + + begin + Res_N := Time_Rep (Date); + + -- Step 1: If the target supports leap seconds, remove any leap + -- seconds elapsed up to the input date. + + if Leap_Support then + Cumulative_Leap_Seconds + (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); + + -- The input time value may fall on a leap second occurrence + + if Res_N >= Next_Leap_N then + Elapsed_Leaps := Elapsed_Leaps + 1; + end if; + + -- The target does not support leap seconds + + else + Elapsed_Leaps := 0; + end if; + + Res_N := Res_N - Time_Rep (Elapsed_Leaps) * Nano; + + -- Step 2: Perform a shift in origins to obtain a Unix equivalent of + -- the input. Guard against very large delay values such as the end + -- of time since the computation will overflow. + + Res_N := (if Res_N > Safe_Ada_High then Safe_Ada_High + else Res_N + Epoch_Offset); + + return Time_Rep_To_Duration (Res_N); + end To_Duration; + + end Delay_Operations; + + --------------------------- + -- Formatting_Operations -- + --------------------------- + + package body Formatting_Operations is + + ----------------- + -- Day_Of_Week -- + ----------------- + + function Day_Of_Week (Date : Time) return Integer is + Date_N : constant Time_Rep := Time_Rep (Date); + Time_Zone : constant Long_Integer := UTC_Time_Offset (Date, True); + Ada_Low_N : Time_Rep; + Day_Count : Long_Integer; + Day_Dur : Time_Dur; + High_N : Time_Rep; + Low_N : Time_Rep; + + begin + -- As declared, the Ada Epoch is set in UTC. For this calculation to + -- work properly, both the Epoch and the input date must be in the + -- same time zone. The following places the Epoch in the input date's + -- time zone. + + Ada_Low_N := Ada_Low - Time_Rep (Time_Zone) * Nano; + + if Date_N > Ada_Low_N then + High_N := Date_N; + Low_N := Ada_Low_N; + else + High_N := Ada_Low_N; + Low_N := Date_N; + end if; + + -- Determine the elapsed seconds since the start of Ada time + + Day_Dur := Time_Dur (High_N / Nano - Low_N / Nano); + + -- Count the number of days since the start of Ada time. 1901-01-01 + -- GMT was a Tuesday. + + Day_Count := Long_Integer (Day_Dur / Secs_In_Day) + 1; + + return Integer (Day_Count mod 7); + end Day_Of_Week; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Day_Secs : out Day_Duration; + Hour : out Integer; + Minute : out Integer; + Second : out Integer; + Sub_Sec : out Duration; + Leap_Sec : out Boolean; + Use_TZ : Boolean; + Is_Historic : Boolean; + Time_Zone : Long_Integer) + is + -- The following constants represent the number of nanoseconds + -- elapsed since the start of Ada time to and including the non + -- leap centennial years. + + Year_2101 : constant Time_Rep := Ada_Low + + Time_Rep (49 * 366 + 151 * 365) * Nanos_In_Day; + Year_2201 : constant Time_Rep := Ada_Low + + Time_Rep (73 * 366 + 227 * 365) * Nanos_In_Day; + Year_2301 : constant Time_Rep := Ada_Low + + Time_Rep (97 * 366 + 303 * 365) * Nanos_In_Day; + + Date_Dur : Time_Dur; + Date_N : Time_Rep; + Day_Seconds : Natural; + Elapsed_Leaps : Natural; + Four_Year_Segs : Natural; + Hour_Seconds : Natural; + Is_Leap_Year : Boolean; + Next_Leap_N : Time_Rep; + Rem_Years : Natural; + Sub_Sec_N : Time_Rep; + Year_Day : Natural; + + begin + Date_N := Time_Rep (Date); + + -- Step 1: Leap seconds processing in UTC + + if Leap_Support then + Cumulative_Leap_Seconds + (Start_Of_Time, Date_N, Elapsed_Leaps, Next_Leap_N); + + Leap_Sec := Date_N >= Next_Leap_N; + + if Leap_Sec then + Elapsed_Leaps := Elapsed_Leaps + 1; + end if; + + -- The target does not support leap seconds + + else + Elapsed_Leaps := 0; + Leap_Sec := False; + end if; + + Date_N := Date_N - Time_Rep (Elapsed_Leaps) * Nano; + + -- Step 2: Time zone processing. This action converts the input date + -- from GMT to the requested time zone. Applies from Ada 2005 on. + + if Use_TZ then + if Time_Zone /= 0 then + Date_N := Date_N + Time_Rep (Time_Zone) * 60 * Nano; + end if; + + -- Ada 83 and 95 + + else + declare + Off : constant Long_Integer := + UTC_Time_Offset (Time (Date_N), Is_Historic); + + begin + Date_N := Date_N + Time_Rep (Off) * Nano; + end; + end if; + + -- Step 3: Non-leap centennial year adjustment in local time zone + + -- In order for all divisions to work properly and to avoid more + -- complicated arithmetic, we add fake February 29s to dates which + -- occur after a non-leap centennial year. + + if Date_N >= Year_2301 then + Date_N := Date_N + Time_Rep (3) * Nanos_In_Day; + + elsif Date_N >= Year_2201 then + Date_N := Date_N + Time_Rep (2) * Nanos_In_Day; + + elsif Date_N >= Year_2101 then + Date_N := Date_N + Time_Rep (1) * Nanos_In_Day; + end if; + + -- Step 4: Sub second processing in local time zone + + Sub_Sec_N := Date_N mod Nano; + Sub_Sec := Duration (Sub_Sec_N) / Nano_F; + Date_N := Date_N - Sub_Sec_N; + + -- Convert Date_N into a time duration value, changing the units + -- to seconds. + + Date_Dur := Time_Dur (Date_N / Nano - Ada_Low / Nano); + + -- Step 5: Year processing in local time zone. Determine the number + -- of four year segments since the start of Ada time and the input + -- date. + + Four_Year_Segs := Natural (Date_Dur / Secs_In_Four_Years); + + if Four_Year_Segs > 0 then + Date_Dur := Date_Dur - Time_Dur (Four_Year_Segs) * + Secs_In_Four_Years; + end if; + + -- Calculate the remaining non-leap years + + Rem_Years := Natural (Date_Dur / Secs_In_Non_Leap_Year); + + if Rem_Years > 3 then + Rem_Years := 3; + end if; + + Date_Dur := Date_Dur - Time_Dur (Rem_Years) * Secs_In_Non_Leap_Year; + + Year := Ada_Min_Year + Natural (4 * Four_Year_Segs + Rem_Years); + Is_Leap_Year := Is_Leap (Year); + + -- Step 6: Month and day processing in local time zone + + Year_Day := Natural (Date_Dur / Secs_In_Day) + 1; + + Month := 1; + + -- Processing for months after January + + if Year_Day > 31 then + Month := 2; + Year_Day := Year_Day - 31; + + -- Processing for a new month or a leap February + + if Year_Day > 28 + and then (not Is_Leap_Year or else Year_Day > 29) + then + Month := 3; + Year_Day := Year_Day - 28; + + if Is_Leap_Year then + Year_Day := Year_Day - 1; + end if; + + -- Remaining months + + while Year_Day > Days_In_Month (Month) loop + Year_Day := Year_Day - Days_In_Month (Month); + Month := Month + 1; + end loop; + end if; + end if; + + -- Step 7: Hour, minute, second and sub second processing in local + -- time zone. + + Day := Day_Number (Year_Day); + Day_Seconds := Integer (Date_Dur mod Secs_In_Day); + Day_Secs := Duration (Day_Seconds) + Sub_Sec; + Hour := Day_Seconds / 3_600; + Hour_Seconds := Day_Seconds mod 3_600; + Minute := Hour_Seconds / 60; + Second := Hour_Seconds mod 60; + + exception + when Constraint_Error => + raise Time_Error; + end Split; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Day_Secs : Day_Duration; + Hour : Integer; + Minute : Integer; + Second : Integer; + Sub_Sec : Duration; + Leap_Sec : Boolean; + Use_Day_Secs : Boolean; + Use_TZ : Boolean; + Is_Historic : Boolean; + Time_Zone : Long_Integer) return Time + is + Count : Integer; + Elapsed_Leaps : Natural; + Next_Leap_N : Time_Rep; + Res_N : Time_Rep; + Rounded_Res_N : Time_Rep; + + begin + -- Step 1: Check whether the day, month and year form a valid date + + if Day > Days_In_Month (Month) + and then (Day /= 29 or else Month /= 2 or else not Is_Leap (Year)) + then + raise Time_Error; + end if; + + -- Start accumulating nanoseconds from the low bound of Ada time + + Res_N := Ada_Low; + + -- Step 2: Year processing and centennial year adjustment. Determine + -- the number of four year segments since the start of Ada time and + -- the input date. + + Count := (Year - Year_Number'First) / 4; + + for Four_Year_Segments in 1 .. Count loop + Res_N := Res_N + Nanos_In_Four_Years; + end loop; + + -- Note that non-leap centennial years are automatically considered + -- leap in the operation above. An adjustment of several days is + -- required to compensate for this. + + if Year > 2300 then + Res_N := Res_N - Time_Rep (3) * Nanos_In_Day; + + elsif Year > 2200 then + Res_N := Res_N - Time_Rep (2) * Nanos_In_Day; + + elsif Year > 2100 then + Res_N := Res_N - Time_Rep (1) * Nanos_In_Day; + end if; + + -- Add the remaining non-leap years + + Count := (Year - Year_Number'First) mod 4; + Res_N := Res_N + Time_Rep (Count) * Secs_In_Non_Leap_Year * Nano; + + -- Step 3: Day of month processing. Determine the number of days + -- since the start of the current year. Do not add the current + -- day since it has not elapsed yet. + + Count := Cumulative_Days_Before_Month (Month) + Day - 1; + + -- The input year is leap and we have passed February + + if Is_Leap (Year) + and then Month > 2 + then + Count := Count + 1; + end if; + + Res_N := Res_N + Time_Rep (Count) * Nanos_In_Day; + + -- Step 4: Hour, minute, second and sub second processing + + if Use_Day_Secs then + Res_N := Res_N + Duration_To_Time_Rep (Day_Secs); + + else + Res_N := + Res_N + Time_Rep (Hour * 3_600 + Minute * 60 + Second) * Nano; + + if Sub_Sec = 1.0 then + Res_N := Res_N + Time_Rep (1) * Nano; + else + Res_N := Res_N + Duration_To_Time_Rep (Sub_Sec); + end if; + end if; + + -- At this point, the generated time value should be withing the + -- bounds of Ada time. + + Check_Within_Time_Bounds (Res_N); + + -- Step 4: Time zone processing. At this point we have built an + -- arbitrary time value which is not related to any time zone. + -- For simplicity, the time value is normalized to GMT, producing + -- a uniform representation which can be treated by arithmetic + -- operations for instance without any additional corrections. + + if Use_TZ then + if Time_Zone /= 0 then + Res_N := Res_N - Time_Rep (Time_Zone) * 60 * Nano; + end if; + + -- Ada 83 and 95 + + else + declare + Cur_Off : constant Long_Integer := + UTC_Time_Offset (Time (Res_N), Is_Historic); + Cur_Res_N : constant Time_Rep := + Res_N - Time_Rep (Cur_Off) * Nano; + Off : constant Long_Integer := + UTC_Time_Offset (Time (Cur_Res_N), Is_Historic); + + begin + Res_N := Res_N - Time_Rep (Off) * Nano; + end; + end if; + + -- Step 5: Leap seconds processing in GMT + + if Leap_Support then + Cumulative_Leap_Seconds + (Start_Of_Time, Res_N, Elapsed_Leaps, Next_Leap_N); + + Res_N := Res_N + Time_Rep (Elapsed_Leaps) * Nano; + + -- An Ada 2005 caller requesting an explicit leap second or an + -- Ada 95 caller accounting for an invisible leap second. + + if Leap_Sec or else Res_N >= Next_Leap_N then + Res_N := Res_N + Time_Rep (1) * Nano; + end if; + + -- Leap second validity check + + Rounded_Res_N := Res_N - (Res_N mod Nano); + + if Use_TZ + and then Leap_Sec + and then Rounded_Res_N /= Next_Leap_N + then + raise Time_Error; + end if; + end if; + + return Time (Res_N); + end Time_Of; + + end Formatting_Operations; + + --------------------------- + -- Time_Zones_Operations -- + --------------------------- + + package body Time_Zones_Operations is + + --------------------- + -- UTC_Time_Offset -- + --------------------- + + function UTC_Time_Offset (Date : Time) return Long_Integer is + begin + return UTC_Time_Offset (Date, True); + end UTC_Time_Offset; + + end Time_Zones_Operations; + +-- Start of elaboration code for Ada.Calendar + +begin + System.OS_Primitives.Initialize; + +end Ada.Calendar; diff --git a/gcc/ada/libgnat/a-calend.ads b/gcc/ada/libgnat/a-calend.ads new file mode 100644 index 0000000..6579dc1 --- /dev/null +++ b/gcc/ada/libgnat/a-calend.ads @@ -0,0 +1,395 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Calendar with + SPARK_Mode, + Abstract_State => (Clock_Time with Synchronous, + External => (Async_Readers, + Async_Writers)), + Initializes => Clock_Time +is + + type Time is private; + + -- Declarations representing limits of allowed local time values. Note that + -- these do NOT constrain the possible stored values of time which may well + -- permit a larger range of times (this is explicitly allowed in Ada 95). + + subtype Year_Number is Integer range 1901 .. 2399; + subtype Month_Number is Integer range 1 .. 12; + subtype Day_Number is Integer range 1 .. 31; + + -- A Day_Duration value of 86_400.0 designates a new day + + subtype Day_Duration is Duration range 0.0 .. 86_400.0; + + function Clock return Time with + Volatile_Function, + Global => Clock_Time; + -- The returned time value is the number of nanoseconds since the start + -- of Ada time (1901-01-01 00:00:00.0 UTC). If leap seconds are enabled, + -- the result will contain all elapsed leap seconds since the start of + -- Ada time until now. + + function Year (Date : Time) return Year_Number; + function Month (Date : Time) return Month_Number; + function Day (Date : Time) return Day_Number; + function Seconds (Date : Time) return Day_Duration; + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration); + -- Break down a time value into its date components set in the current + -- time zone. If Split is called on a time value created using Ada 2005 + -- Time_Of in some arbitrary time zone, the input value will always be + -- interpreted as relative to the local time zone. + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0) return Time; + -- GNAT Note: Normally when procedure Split is called on a Time value + -- result of a call to function Time_Of, the out parameters of procedure + -- Split are identical to the in parameters of function Time_Of. However, + -- when a non-existent time of day is specified, the values for Seconds + -- may or may not be different. This may happen when Daylight Saving Time + -- (DST) is in effect, on the day when switching to DST, if Seconds + -- specifies a time of day in the hour that does not exist. For example, + -- in New York: + -- + -- Time_Of (Year => 1998, Month => 4, Day => 5, Seconds => 10740.0) + -- + -- will return a Time value T. If Split is called on T, the resulting + -- Seconds may be 14340.0 (3:59:00) instead of 10740.0 (2:59:00 being + -- a time that not exist). + + function "+" (Left : Time; Right : Duration) return Time; + function "+" (Left : Duration; Right : Time) return Time; + function "-" (Left : Time; Right : Duration) return Time; + function "-" (Left : Time; Right : Time) return Duration; + -- The first three functions will raise Time_Error if the resulting time + -- value is less than the start of Ada time in UTC or greater than the + -- end of Ada time in UTC. The last function will raise Time_Error if the + -- resulting difference cannot fit into a duration value. + + function "<" (Left, Right : Time) return Boolean; + function "<=" (Left, Right : Time) return Boolean; + function ">" (Left, Right : Time) return Boolean; + function ">=" (Left, Right : Time) return Boolean; + + Time_Error : exception; + +private + -- Mark the private part as SPARK_Mode Off to avoid accounting for variable + -- Invalid_Time_Zone_Offset in abstract state. + + pragma SPARK_Mode (Off); + + pragma Inline (Clock); + + pragma Inline (Year); + pragma Inline (Month); + pragma Inline (Day); + + pragma Inline ("+"); + pragma Inline ("-"); + + pragma Inline ("<"); + pragma Inline ("<="); + pragma Inline (">"); + pragma Inline (">="); + + -- The units used in this version of Ada.Calendar are nanoseconds. The + -- following constants provide values used in conversions of seconds or + -- days to the underlying units. + + Nano : constant := 1_000_000_000; + Nano_F : constant := 1_000_000_000.0; + Nanos_In_Day : constant := 86_400_000_000_000; + Secs_In_Day : constant := 86_400; + + ---------------------------- + -- Implementation of Time -- + ---------------------------- + + -- Time is represented as a signed 64 bit integer count of nanoseconds + -- since the start of Ada time (1901-01-01 00:00:00.0 UTC). Time values + -- produced by Time_Of are internally normalized to UTC regardless of their + -- local time zone. This representation ensures correct handling of leap + -- seconds as well as performing arithmetic. In Ada 95, Split and Time_Of + -- will treat a time value as being in the local time zone, in Ada 2005, + -- Split and Time_Of will treat a time value as being in the designated + -- time zone by the formal parameter or in UTC by default. The size of the + -- type is large enough to cover the Ada 2005 range of time (1901-01-01 + -- 00:00:00.0 UTC - 2399-12-31-23:59:59.999999999 UTC). + + ------------------ + -- Leap Seconds -- + ------------------ + + -- Due to Earth's slowdown, the astronomical time is not as precise as the + -- International Atomic Time. To compensate for this inaccuracy, a single + -- leap second is added after the last day of June or December. The count + -- of seconds during those occurrences becomes: + + -- ... 58, 59, leap second 60, 0, 1, 2 ... + + -- Unlike leap days, leap seconds occur simultaneously around the world. + -- In other words, if a leap second occurs at 23:59:60 UTC, it also occurs + -- on 18:59:60 -5 the same day or 2:59:60 +2 on the next day. + + -- Leap seconds do not follow a formula. The International Earth Rotation + -- and Reference System Service decides when to add one. Leap seconds are + -- included in the representation of time in Ada 95 mode. As a result, + -- the following two time values will differ by two seconds: + + -- 1972-06-30 23:59:59.0 + -- 1972-07-01 00:00:00.0 + + -- When a new leap second is introduced, the following steps must be + -- carried out: + + -- 1) Increment Leap_Seconds_Count in a-calend.adb by one + -- 2) Increment LS_Count in xleaps.adb by one + -- 3) Add the new date to the aggregate of array LS_Dates in + -- xleaps.adb + -- 4) Compile and execute xleaps + -- 5) Replace the values of Leap_Second_Times in a-calend.adb with the + -- aggregate generated by xleaps + + -- The algorithms that build the actual leap second values and discover + -- how many leap seconds have occurred between two dates do not need any + -- modification. + + ------------------------------ + -- Non-leap Centennial Years -- + ------------------------------ + + -- Over the range of Ada time, centennial years 2100, 2200 and 2300 are + -- non-leap. As a consequence, seven non-leap years occur over the period + -- of year - 4 to year + 4. Internally, routines Split and Time_Of add or + -- subtract a "fake" February 29 to facilitate the arithmetic involved. + + ------------------------ + -- Local Declarations -- + ------------------------ + + type Time_Rep is new Long_Long_Integer; + type Time is new Time_Rep; + -- The underlying type of Time has been chosen to be a 64 bit signed + -- integer number since it allows for easier processing of sub-seconds + -- and arithmetic. We use Long_Long_Integer to allow this unit to compile + -- when using custom target configuration files where the max integer is + -- 32 bits. This is useful for static analysis tools such as SPARK or + -- CodePeer. + -- + -- Note: the reason we have two separate types here is to avoid problems + -- with overloading ambiguities in the body if we tried to use Time as an + -- internal computational type. + + Days_In_Month : constant array (Month_Number) of Day_Number := + (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31); + -- Days in month for non-leap year, leap year case is adjusted in code + + Invalid_Time_Zone_Offset : Long_Integer; + pragma Import (C, Invalid_Time_Zone_Offset, "__gnat_invalid_tzoff"); + + function Is_Leap (Year : Year_Number) return Boolean; + -- Determine whether a given year is leap + + ---------------------------------------------------------- + -- Target-Independent Interface to Children of Calendar -- + ---------------------------------------------------------- + + -- The following packages provide a target-independent interface to the + -- children of Calendar - Arithmetic, Conversions, Delays, Formatting and + -- Time_Zones. + + --------------------------- + -- Arithmetic_Operations -- + --------------------------- + + package Arithmetic_Operations is + + function Add (Date : Time; Days : Long_Integer) return Time; + -- Add a certain number of days to a time value + + procedure Difference + (Left : Time; + Right : Time; + Days : out Long_Integer; + Seconds : out Duration; + Leap_Seconds : out Integer); + -- Calculate the difference between two time values in terms of days, + -- seconds and leap seconds elapsed. The leap seconds are not included + -- in the seconds returned. If Left is greater than Right, the returned + -- values are positive, negative otherwise. + + function Subtract (Date : Time; Days : Long_Integer) return Time; + -- Subtract a certain number of days from a time value + + end Arithmetic_Operations; + + --------------------------- + -- Conversion_Operations -- + --------------------------- + + package Conversion_Operations is + + function To_Ada_Time (Unix_Time : Long_Integer) return Time; + -- Unix to Ada Epoch conversion + + function To_Ada_Time + (tm_year : Integer; + tm_mon : Integer; + tm_day : Integer; + tm_hour : Integer; + tm_min : Integer; + tm_sec : Integer; + tm_isdst : Integer) return Time; + -- Struct tm to Ada Epoch conversion + + function To_Duration + (tv_sec : Long_Integer; + tv_nsec : Long_Integer) return Duration; + -- Struct timespec to Duration conversion + + procedure To_Struct_Timespec + (D : Duration; + tv_sec : out Long_Integer; + tv_nsec : out Long_Integer); + -- Duration to struct timespec conversion + + procedure To_Struct_Tm + (T : Time; + tm_year : out Integer; + tm_mon : out Integer; + tm_day : out Integer; + tm_hour : out Integer; + tm_min : out Integer; + tm_sec : out Integer); + -- Time to struct tm conversion + + function To_Unix_Time (Ada_Time : Time) return Long_Integer; + -- Ada to Unix Epoch conversion + + end Conversion_Operations; + + ---------------------- + -- Delay_Operations -- + ---------------------- + + package Delay_Operations is + + function To_Duration (Date : Time) return Duration; + -- Given a time value in nanoseconds since 1901, convert it into a + -- duration value giving the number of nanoseconds since the Unix Epoch. + + end Delay_Operations; + + --------------------------- + -- Formatting_Operations -- + --------------------------- + + package Formatting_Operations is + + function Day_Of_Week (Date : Time) return Integer; + -- Determine which day of week Date falls on. The returned values are + -- within the range of 0 .. 6 (Monday .. Sunday). + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Day_Secs : out Day_Duration; + Hour : out Integer; + Minute : out Integer; + Second : out Integer; + Sub_Sec : out Duration; + Leap_Sec : out Boolean; + Use_TZ : Boolean; + Is_Historic : Boolean; + Time_Zone : Long_Integer); + pragma Export (Ada, Split, "__gnat_split"); + -- Split a time value into its components. If flag Is_Historic is set, + -- this routine would try to use to the best of the OS's abilities the + -- time zone offset that was or will be in effect on Date. Set Use_TZ + -- to use the local time zone (the value in Time_Zone is ignored) when + -- splitting a time value. + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Day_Secs : Day_Duration; + Hour : Integer; + Minute : Integer; + Second : Integer; + Sub_Sec : Duration; + Leap_Sec : Boolean; + Use_Day_Secs : Boolean; + Use_TZ : Boolean; + Is_Historic : Boolean; + Time_Zone : Long_Integer) return Time; + pragma Export (Ada, Time_Of, "__gnat_time_of"); + -- Given all the components of a date, return the corresponding time + -- value. Set Use_Day_Secs to use the value in Day_Secs, otherwise the + -- day duration will be calculated from Hour, Minute, Second and Sub_ + -- Sec. If flag Is_Historic is set, this routine would try to use to the + -- best of the OS's abilities the time zone offset that was or will be + -- in effect on the input date. Set Use_TZ to use the local time zone + -- (the value in formal Time_Zone is ignored) when building a time value + -- and to verify the validity of a requested leap second. + + end Formatting_Operations; + + --------------------------- + -- Time_Zones_Operations -- + --------------------------- + + package Time_Zones_Operations is + + function UTC_Time_Offset (Date : Time) return Long_Integer; + -- Return (in seconds) the difference between the local time zone and + -- UTC time at a specific historic date. + + end Time_Zones_Operations; + +end Ada.Calendar; diff --git a/gcc/ada/libgnat/a-calfor.adb b/gcc/ada/libgnat/a-calfor.adb new file mode 100644 index 0000000..c10e790 --- /dev/null +++ b/gcc/ada/libgnat/a-calfor.adb @@ -0,0 +1,882 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . F O R M A T T I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; use Ada.Calendar; +with Ada.Calendar.Time_Zones; use Ada.Calendar.Time_Zones; + +package body Ada.Calendar.Formatting is + + -------------------------- + -- Implementation Notes -- + -------------------------- + + -- All operations in this package are target and time representation + -- independent, thus only one source file is needed for multiple targets. + + procedure Check_Char (S : String; C : Character; Index : Integer); + -- Subsidiary to the two versions of Value. Determine whether the input + -- string S has character C at position Index. Raise Constraint_Error if + -- there is a mismatch. + + procedure Check_Digit (S : String; Index : Integer); + -- Subsidiary to the two versions of Value. Determine whether the character + -- of string S at position Index is a digit. This catches invalid input + -- such as 1983-*1-j3 u5:n7:k9 which should be 1983-01-03 05:07:09. Raise + -- Constraint_Error if there is a mismatch. + + ---------------- + -- Check_Char -- + ---------------- + + procedure Check_Char (S : String; C : Character; Index : Integer) is + begin + if S (Index) /= C then + raise Constraint_Error; + end if; + end Check_Char; + + ----------------- + -- Check_Digit -- + ----------------- + + procedure Check_Digit (S : String; Index : Integer) is + begin + if S (Index) not in '0' .. '9' then + raise Constraint_Error; + end if; + end Check_Digit; + + --------- + -- Day -- + --------- + + function Day + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Day_Number + is + Y : Year_Number; + Mo : Month_Number; + D : Day_Number; + H : Hour_Number; + Mi : Minute_Number; + Se : Second_Number; + Ss : Second_Duration; + Le : Boolean; + + pragma Unreferenced (Y, Mo, H, Mi); + + begin + Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); + return D; + end Day; + + ----------------- + -- Day_Of_Week -- + ----------------- + + function Day_Of_Week (Date : Time) return Day_Name is + begin + return Day_Name'Val (Formatting_Operations.Day_Of_Week (Date)); + end Day_Of_Week; + + ---------- + -- Hour -- + ---------- + + function Hour + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Hour_Number + is + Y : Year_Number; + Mo : Month_Number; + D : Day_Number; + H : Hour_Number; + Mi : Minute_Number; + Se : Second_Number; + Ss : Second_Duration; + Le : Boolean; + + pragma Unreferenced (Y, Mo, D, Mi); + + begin + Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); + return H; + end Hour; + + ----------- + -- Image -- + ----------- + + function Image + (Elapsed_Time : Duration; + Include_Time_Fraction : Boolean := False) return String + is + To_Char : constant array (0 .. 9) of Character := "0123456789"; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Duration; + SS_Nat : Natural; + + -- Determine the two slice bounds for the result string depending on + -- whether the input is negative and whether fractions are requested. + + First : constant Integer := (if Elapsed_Time < 0.0 then 1 else 2); + Last : constant Integer := (if Include_Time_Fraction then 12 else 9); + + Result : String := "-00:00:00.00"; + + begin + Split (abs (Elapsed_Time), Hour, Minute, Second, Sub_Second); + + -- Hour processing, positions 2 and 3 + + Result (2) := To_Char (Hour / 10); + Result (3) := To_Char (Hour mod 10); + + -- Minute processing, positions 5 and 6 + + Result (5) := To_Char (Minute / 10); + Result (6) := To_Char (Minute mod 10); + + -- Second processing, positions 8 and 9 + + Result (8) := To_Char (Second / 10); + Result (9) := To_Char (Second mod 10); + + -- Optional sub second processing, positions 11 and 12 + + if Include_Time_Fraction and then Sub_Second > 0.0 then + + -- Prevent rounding up when converting to natural, avoiding the zero + -- case to prevent rounding down to a negative number. + + SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5); + + Result (11) := To_Char (SS_Nat / 10); + Result (12) := To_Char (SS_Nat mod 10); + end if; + + return Result (First .. Last); + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (Date : Time; + Include_Time_Fraction : Boolean := False; + Time_Zone : Time_Zones.Time_Offset := 0) return String + is + To_Char : constant array (0 .. 9) of Character := "0123456789"; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Duration; + SS_Nat : Natural; + Leap_Second : Boolean; + + -- The result length depends on whether fractions are requested. + + Result : String := "0000-00-00 00:00:00.00"; + Last : constant Positive := + Result'Last - (if Include_Time_Fraction then 0 else 3); + + begin + Split (Date, Year, Month, Day, + Hour, Minute, Second, Sub_Second, Leap_Second, Time_Zone); + + -- Year processing, positions 1, 2, 3 and 4 + + Result (1) := To_Char (Year / 1000); + Result (2) := To_Char (Year / 100 mod 10); + Result (3) := To_Char (Year / 10 mod 10); + Result (4) := To_Char (Year mod 10); + + -- Month processing, positions 6 and 7 + + Result (6) := To_Char (Month / 10); + Result (7) := To_Char (Month mod 10); + + -- Day processing, positions 9 and 10 + + Result (9) := To_Char (Day / 10); + Result (10) := To_Char (Day mod 10); + + Result (12) := To_Char (Hour / 10); + Result (13) := To_Char (Hour mod 10); + + -- Minute processing, positions 15 and 16 + + Result (15) := To_Char (Minute / 10); + Result (16) := To_Char (Minute mod 10); + + -- Second processing, positions 18 and 19 + + Result (18) := To_Char (Second / 10); + Result (19) := To_Char (Second mod 10); + + -- Optional sub second processing, positions 21 and 22 + + if Include_Time_Fraction and then Sub_Second > 0.0 then + + -- Prevent rounding up when converting to natural, avoiding the zero + -- case to prevent rounding down to a negative number. + + SS_Nat := Natural (Duration'(Sub_Second * 100.0) - 0.5); + + Result (21) := To_Char (SS_Nat / 10); + Result (22) := To_Char (SS_Nat mod 10); + end if; + + return Result (Result'First .. Last); + end Image; + + ------------ + -- Minute -- + ------------ + + function Minute + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Minute_Number + is + Y : Year_Number; + Mo : Month_Number; + D : Day_Number; + H : Hour_Number; + Mi : Minute_Number; + Se : Second_Number; + Ss : Second_Duration; + Le : Boolean; + + pragma Unreferenced (Y, Mo, D, H); + + begin + Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); + return Mi; + end Minute; + + ----------- + -- Month -- + ----------- + + function Month + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Month_Number + is + Y : Year_Number; + Mo : Month_Number; + D : Day_Number; + H : Hour_Number; + Mi : Minute_Number; + Se : Second_Number; + Ss : Second_Duration; + Le : Boolean; + + pragma Unreferenced (Y, D, H, Mi); + + begin + Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); + return Mo; + end Month; + + ------------ + -- Second -- + ------------ + + function Second (Date : Time) return Second_Number is + Y : Year_Number; + Mo : Month_Number; + D : Day_Number; + H : Hour_Number; + Mi : Minute_Number; + Se : Second_Number; + Ss : Second_Duration; + Le : Boolean; + + pragma Unreferenced (Y, Mo, D, H, Mi); + + begin + Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le); + return Se; + end Second; + + ---------------- + -- Seconds_Of -- + ---------------- + + function Seconds_Of + (Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number := 0; + Sub_Second : Second_Duration := 0.0) return Day_Duration is + + begin + -- Validity checks + + if not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Sub_Second'Valid + then + raise Constraint_Error; + end if; + + return Day_Duration (Hour * 3_600) + + Day_Duration (Minute * 60) + + Day_Duration (Second) + + Sub_Second; + end Seconds_Of; + + ----------- + -- Split -- + ----------- + + procedure Split + (Seconds : Day_Duration; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration) + is + Secs : Natural; + + begin + -- Validity checks + + if not Seconds'Valid then + raise Constraint_Error; + end if; + + Secs := (if Seconds = 0.0 then 0 else Natural (Seconds - 0.5)); + + Sub_Second := Second_Duration (Seconds - Day_Duration (Secs)); + Hour := Hour_Number (Secs / 3_600); + Secs := Secs mod 3_600; + Minute := Minute_Number (Secs / 60); + Second := Second_Number (Secs mod 60); + + -- Validity checks + + if not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Sub_Second'Valid + then + raise Time_Error; + end if; + end Split; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration; + Leap_Second : out Boolean; + Time_Zone : Time_Zones.Time_Offset := 0) + is + H : Integer; + M : Integer; + Se : Integer; + Su : Duration; + Tz : constant Long_Integer := Long_Integer (Time_Zone); + + begin + Formatting_Operations.Split + (Date => Date, + Year => Year, + Month => Month, + Day => Day, + Day_Secs => Seconds, + Hour => H, + Minute => M, + Second => Se, + Sub_Sec => Su, + Leap_Sec => Leap_Second, + Use_TZ => True, + Is_Historic => True, + Time_Zone => Tz); + + -- Validity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Seconds'Valid + then + raise Time_Error; + end if; + end Split; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration; + Time_Zone : Time_Zones.Time_Offset := 0) + is + Dd : Day_Duration; + Le : Boolean; + Tz : constant Long_Integer := Long_Integer (Time_Zone); + + begin + Formatting_Operations.Split + (Date => Date, + Year => Year, + Month => Month, + Day => Day, + Day_Secs => Dd, + Hour => Hour, + Minute => Minute, + Second => Second, + Sub_Sec => Sub_Second, + Leap_Sec => Le, + Use_TZ => True, + Is_Historic => True, + Time_Zone => Tz); + + -- Validity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Sub_Second'Valid + then + raise Time_Error; + end if; + end Split; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration; + Leap_Second : out Boolean; + Time_Zone : Time_Zones.Time_Offset := 0) + is + Dd : Day_Duration; + Tz : constant Long_Integer := Long_Integer (Time_Zone); + + begin + Formatting_Operations.Split + (Date => Date, + Year => Year, + Month => Month, + Day => Day, + Day_Secs => Dd, + Hour => Hour, + Minute => Minute, + Second => Second, + Sub_Sec => Sub_Second, + Leap_Sec => Leap_Second, + Use_TZ => True, + Is_Historic => True, + Time_Zone => Tz); + + -- Validity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Sub_Second'Valid + then + raise Time_Error; + end if; + end Split; + + ---------------- + -- Sub_Second -- + ---------------- + + function Sub_Second (Date : Time) return Second_Duration is + Y : Year_Number; + Mo : Month_Number; + D : Day_Number; + H : Hour_Number; + Mi : Minute_Number; + Se : Second_Number; + Ss : Second_Duration; + Le : Boolean; + + pragma Unreferenced (Y, Mo, D, H, Mi); + + begin + Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le); + return Ss; + end Sub_Second; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0; + Leap_Second : Boolean := False; + Time_Zone : Time_Zones.Time_Offset := 0) return Time + is + Adj_Year : Year_Number := Year; + Adj_Month : Month_Number := Month; + Adj_Day : Day_Number := Day; + + H : constant Integer := 1; + M : constant Integer := 1; + Se : constant Integer := 1; + Ss : constant Duration := 0.1; + Tz : constant Long_Integer := Long_Integer (Time_Zone); + + begin + -- Validity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Seconds'Valid + or else not Time_Zone'Valid + then + raise Constraint_Error; + end if; + + -- A Seconds value of 86_400 denotes a new day. This case requires an + -- adjustment to the input values. + + if Seconds = 86_400.0 then + if Day < Days_In_Month (Month) + or else (Is_Leap (Year) + and then Month = 2) + then + Adj_Day := Day + 1; + else + Adj_Day := 1; + + if Month < 12 then + Adj_Month := Month + 1; + else + Adj_Month := 1; + Adj_Year := Year + 1; + end if; + end if; + end if; + + return + Formatting_Operations.Time_Of + (Year => Adj_Year, + Month => Adj_Month, + Day => Adj_Day, + Day_Secs => Seconds, + Hour => H, + Minute => M, + Second => Se, + Sub_Sec => Ss, + Leap_Sec => Leap_Second, + Use_Day_Secs => True, + Use_TZ => True, + Is_Historic => True, + Time_Zone => Tz); + end Time_Of; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0; + Leap_Second : Boolean := False; + Time_Zone : Time_Zones.Time_Offset := 0) return Time + is + Dd : constant Day_Duration := Day_Duration'First; + Tz : constant Long_Integer := Long_Integer (Time_Zone); + + begin + -- Validity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Sub_Second'Valid + or else not Time_Zone'Valid + then + raise Constraint_Error; + end if; + + return + Formatting_Operations.Time_Of + (Year => Year, + Month => Month, + Day => Day, + Day_Secs => Dd, + Hour => Hour, + Minute => Minute, + Second => Second, + Sub_Sec => Sub_Second, + Leap_Sec => Leap_Second, + Use_Day_Secs => False, + Use_TZ => True, + Is_Historic => True, + Time_Zone => Tz); + end Time_Of; + + ----------- + -- Value -- + ----------- + + function Value + (Date : String; + Time_Zone : Time_Zones.Time_Offset := 0) return Time + is + D : String (1 .. 22); + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0; + + begin + -- Validity checks + + if not Time_Zone'Valid then + raise Constraint_Error; + end if; + + -- Length checks + + if Date'Length /= 19 + and then Date'Length /= 22 + then + raise Constraint_Error; + end if; + + -- After the correct length has been determined, it is safe to copy the + -- Date in order to avoid Date'First + N indexing. + + D (1 .. Date'Length) := Date; + + -- Format checks + + Check_Char (D, '-', 5); + Check_Char (D, '-', 8); + Check_Char (D, ' ', 11); + Check_Char (D, ':', 14); + Check_Char (D, ':', 17); + + if Date'Length = 22 then + Check_Char (D, '.', 20); + end if; + + -- Leading zero checks + + Check_Digit (D, 6); + Check_Digit (D, 9); + Check_Digit (D, 12); + Check_Digit (D, 15); + Check_Digit (D, 18); + + if Date'Length = 22 then + Check_Digit (D, 21); + end if; + + -- Value extraction + + Year := Year_Number (Year_Number'Value (D (1 .. 4))); + Month := Month_Number (Month_Number'Value (D (6 .. 7))); + Day := Day_Number (Day_Number'Value (D (9 .. 10))); + Hour := Hour_Number (Hour_Number'Value (D (12 .. 13))); + Minute := Minute_Number (Minute_Number'Value (D (15 .. 16))); + Second := Second_Number (Second_Number'Value (D (18 .. 19))); + + -- Optional part + + if Date'Length = 22 then + Sub_Second := Second_Duration (Second_Duration'Value (D (20 .. 22))); + end if; + + -- Sanity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Sub_Second'Valid + then + raise Constraint_Error; + end if; + + return Time_Of (Year, Month, Day, + Hour, Minute, Second, Sub_Second, False, Time_Zone); + + exception + when others => raise Constraint_Error; + end Value; + + ----------- + -- Value -- + ----------- + + function Value (Elapsed_Time : String) return Duration is + D : String (1 .. 11); + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0; + + begin + -- Length checks + + if Elapsed_Time'Length /= 8 + and then Elapsed_Time'Length /= 11 + then + raise Constraint_Error; + end if; + + -- After the correct length has been determined, it is safe to copy the + -- Elapsed_Time in order to avoid Date'First + N indexing. + + D (1 .. Elapsed_Time'Length) := Elapsed_Time; + + -- Format checks + + Check_Char (D, ':', 3); + Check_Char (D, ':', 6); + + if Elapsed_Time'Length = 11 then + Check_Char (D, '.', 9); + end if; + + -- Leading zero checks + + Check_Digit (D, 1); + Check_Digit (D, 4); + Check_Digit (D, 7); + + if Elapsed_Time'Length = 11 then + Check_Digit (D, 10); + end if; + + -- Value extraction + + Hour := Hour_Number (Hour_Number'Value (D (1 .. 2))); + Minute := Minute_Number (Minute_Number'Value (D (4 .. 5))); + Second := Second_Number (Second_Number'Value (D (7 .. 8))); + + -- Optional part + + if Elapsed_Time'Length = 11 then + Sub_Second := Second_Duration (Second_Duration'Value (D (9 .. 11))); + end if; + + -- Sanity checks + + if not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Sub_Second'Valid + then + raise Constraint_Error; + end if; + + return Seconds_Of (Hour, Minute, Second, Sub_Second); + + exception + when others => raise Constraint_Error; + end Value; + + ---------- + -- Year -- + ---------- + + function Year + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Year_Number + is + Y : Year_Number; + Mo : Month_Number; + D : Day_Number; + H : Hour_Number; + Mi : Minute_Number; + Se : Second_Number; + Ss : Second_Duration; + Le : Boolean; + + pragma Unreferenced (Mo, D, H, Mi); + + begin + Split (Date, Y, Mo, D, H, Mi, Se, Ss, Le, Time_Zone); + return Y; + end Year; + +end Ada.Calendar.Formatting; diff --git a/gcc/ada/libgnat/a-calfor.ads b/gcc/ada/libgnat/a-calfor.ads new file mode 100644 index 0000000..58cb4fb --- /dev/null +++ b/gcc/ada/libgnat/a-calfor.ads @@ -0,0 +1,215 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . F O R M A T T I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides additional components to Time, as well as new +-- Time_Of and Split routines which handle time zones and leap seconds. +-- This package is defined in the Ada 2005 RM (9.6.1). + +with Ada.Calendar.Time_Zones; + +package Ada.Calendar.Formatting is + + -- Day of the week + + type Day_Name is + (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); + + function Day_Of_Week (Date : Time) return Day_Name; + + -- Hours:Minutes:Seconds access + + subtype Hour_Number is Natural range 0 .. 23; + subtype Minute_Number is Natural range 0 .. 59; + subtype Second_Number is Natural range 0 .. 59; + subtype Second_Duration is Day_Duration range 0.0 .. 1.0; + + function Year + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Year_Number; + + function Month + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Month_Number; + + function Day + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Day_Number; + + function Hour + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Hour_Number; + + function Minute + (Date : Time; + Time_Zone : Time_Zones.Time_Offset := 0) return Minute_Number; + + function Second + (Date : Time) return Second_Number; + + function Sub_Second + (Date : Time) return Second_Duration; + + function Seconds_Of + (Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number := 0; + Sub_Second : Second_Duration := 0.0) return Day_Duration; + -- Returns a Day_Duration value for the combination of the given Hour, + -- Minute, Second, and Sub_Second. This value can be used in Ada.Calendar. + -- Time_Of as well as the argument to Calendar."+" and Calendar."-". If + -- Seconds_Of is called with a Sub_Second value of 1.0, the value returned + -- is equal to the value of Seconds_Of for the next second with a Sub_ + -- Second value of 0.0. + + procedure Split + (Seconds : Day_Duration; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration); + -- Splits Seconds into Hour, Minute, Second and Sub_Second in such a way + -- that the resulting values all belong to their respective subtypes. The + -- value returned in the Sub_Second parameter is always less than 1.0. + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration; + Time_Zone : Time_Zones.Time_Offset := 0); + -- Splits Date into its constituent parts (Year, Month, Day, Hour, Minute, + -- Second, Sub_Second), relative to the specified time zone offset. The + -- value returned in the Sub_Second parameter is always less than 1.0. + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0; + Leap_Second : Boolean := False; + Time_Zone : Time_Zones.Time_Offset := 0) return Time; + -- If Leap_Second is False, returns a Time built from the date and time + -- values, relative to the specified time zone offset. If Leap_Second is + -- True, returns the Time that represents the time within the leap second + -- that is one second later than the time specified by the parameters. + -- Time_Error is raised if the parameters do not form a proper date or + -- time. If Time_Of is called with a Sub_Second value of 1.0, the value + -- returned is equal to the value of Time_Of for the next second with a + -- Sub_Second value of 0.0. + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Seconds : Day_Duration := 0.0; + Leap_Second : Boolean := False; + Time_Zone : Time_Zones.Time_Offset := 0) return Time; + -- If Leap_Second is False, returns a Time built from the date and time + -- values, relative to the specified time zone offset. If Leap_Second is + -- True, returns the Time that represents the time within the leap second + -- that is one second later than the time specified by the parameters. + -- Time_Error is raised if the parameters do not form a proper date or + -- time. If Time_Of is called with a Seconds value of 86_400.0, the value + -- returned is equal to the value of Time_Of for the next day with a + -- Seconds value of 0.0. + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration; + Leap_Second : out Boolean; + Time_Zone : Time_Zones.Time_Offset := 0); + -- If Date does not represent a time within a leap second, splits Date + -- into its constituent parts (Year, Month, Day, Hour, Minute, Second, + -- Sub_Second), relative to the specified time zone offset, and sets + -- Leap_Second to False. If Date represents a time within a leap second, + -- set the constituent parts to values corresponding to a time one second + -- earlier than that given by Date, relative to the specified time zone + -- offset, and sets Leap_Seconds to True. The value returned in the + -- Sub_Second parameter is always less than 1.0. + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Seconds : out Day_Duration; + Leap_Second : out Boolean; + Time_Zone : Time_Zones.Time_Offset := 0); + -- If Date does not represent a time within a leap second, splits Date + -- into its constituent parts (Year, Month, Day, Seconds), relative to the + -- specified time zone offset, and sets Leap_Second to False. If Date + -- represents a time within a leap second, set the constituent parts to + -- values corresponding to a time one second earlier than that given by + -- Date, relative to the specified time zone offset, and sets Leap_Seconds + -- to True. The value returned in the Seconds parameter is always less + -- than 86_400.0. + + -- Simple image and value + + function Image + (Date : Time; + Include_Time_Fraction : Boolean := False; + Time_Zone : Time_Zones.Time_Offset := 0) return String; + -- Returns a string form of the Date relative to the given Time_Zone. The + -- format is "Year-Month-Day Hour:Minute:Second", where the Year is a + -- 4-digit value, and all others are 2-digit values, of the functions + -- defined in Ada.Calendar and Ada.Calendar.Formatting, including a + -- leading zero, if needed. The separators between the values are a minus, + -- another minus, a colon, and a single space between the Day and Hour. If + -- Include_Time_Fraction is True, the integer part of Sub_Seconds*100 is + -- suffixed to the string as a point followed by a 2-digit value. + + function Value + (Date : String; + Time_Zone : Time_Zones.Time_Offset := 0) return Time; + -- Returns a Time value for the image given as Date, relative to the given + -- time zone. Constraint_Error is raised if the string is not formatted as + -- described for Image, or the function cannot interpret the given string + -- as a Time value. + + function Image + (Elapsed_Time : Duration; + Include_Time_Fraction : Boolean := False) return String; + -- Returns a string form of the Elapsed_Time. The format is "Hour:Minute: + -- Second", where all values are 2-digit values, including a leading zero, + -- if needed. The separators between the values are colons. If Include_ + -- Time_Fraction is True, the integer part of Sub_Seconds*100 is suffixed + -- to the string as a point followed by a 2-digit value. If Elapsed_Time < + -- 0.0, the result is Image (abs Elapsed_Time, Include_Time_Fraction) + -- prefixed with a minus sign. If abs Elapsed_Time represents 100 hours or + -- more, the result is implementation-defined. + + function Value (Elapsed_Time : String) return Duration; + -- Returns a Duration value for the image given as Elapsed_Time. + -- Constraint_Error is raised if the string is not formatted as described + -- for Image, or the function cannot interpret the given string as a + -- Duration value. + +end Ada.Calendar.Formatting; diff --git a/gcc/ada/libgnat/a-catizo.adb b/gcc/ada/libgnat/a-catizo.adb new file mode 100644 index 0000000..480facf --- /dev/null +++ b/gcc/ada/libgnat/a-catizo.adb @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . T I M E _ Z O N E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Calendar.Time_Zones is + + -------------------------- + -- Implementation Notes -- + -------------------------- + + -- All operations in this package are target and time representation + -- independent, thus only one source file is needed for multiple targets. + + --------------------- + -- UTC_Time_Offset -- + --------------------- + + function UTC_Time_Offset (Date : Time := Clock) return Time_Offset is + Offset_L : constant Long_Integer := + Time_Zones_Operations.UTC_Time_Offset (Date); + Offset : Time_Offset; + + begin + if Offset_L = Invalid_Time_Zone_Offset then + raise Unknown_Zone_Error; + end if; + + -- The offset returned by Time_Zones_Operations.UTC_Time_Offset is in + -- seconds, the returned value needs to be in minutes. + + Offset := Time_Offset (Offset_L / 60); + + -- Validity checks + + if not Offset'Valid then + raise Unknown_Zone_Error; + end if; + + return Offset; + end UTC_Time_Offset; + +end Ada.Calendar.Time_Zones; diff --git a/gcc/ada/libgnat/a-catizo.ads b/gcc/ada/libgnat/a-catizo.ads new file mode 100644 index 0000000..5f55869 --- /dev/null +++ b/gcc/ada/libgnat/a-catizo.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C A L E N D A R . T I M E _ Z O N E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines to determine the offset of dates to GMT. +-- It is defined in the Ada 2005 RM (9.6.1). + +package Ada.Calendar.Time_Zones is + + -- Time zone manipulation + + type Time_Offset is range -(28 * 60) .. 28 * 60; + + Unknown_Zone_Error : exception; + + function UTC_Time_Offset (Date : Time := Clock) return Time_Offset; + -- Returns (in minutes), the difference between the implementation-defined + -- time zone of Calendar, and UTC time, at the time Date. If the time zone + -- of the Calendar implementation is unknown, raises Unknown_Zone_Error. + +end Ada.Calendar.Time_Zones; diff --git a/gcc/ada/libgnat/a-cbdlli.adb b/gcc/ada/libgnat/a-cbdlli.adb new file mode 100644 index 0000000..8f7b537 --- /dev/null +++ b/gcc/ada/libgnat/a-cbdlli.adb @@ -0,0 +1,2399 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Doubly_Linked_Lists is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Allocate + (Container : in out List; + Stream : not null access Root_Stream_Type'Class; + New_Node : out Count_Type); + + procedure Free + (Container : in out List; + X : Count_Type); + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type); + + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; + Source : in out List); + + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; + Source : in out List; + Src_Pos : Count_Type; + Tgt_Pos : out Count_Type); + + function Vet (Position : Cursor) return Boolean; + -- Checks invariants of the cursor and its designated container, as a + -- simple way of detecting dangling references (see operation Free for a + -- description of the detection mechanism), returning True if all checks + -- pass. Invocations of Vet are used here as the argument of pragma Assert, + -- so the checks are performed only when assertions are enabled. + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + begin + if Left.Length /= Right.Length then + return False; + end if; + + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + LN : Node_Array renames Left.Nodes; + RN : Node_Array renames Right.Nodes; + + LI : Count_Type := Left.First; + RI : Count_Type := Right.First; + begin + for J in 1 .. Left.Length loop + if LN (LI).Element /= RN (RI).Element then + return False; + end if; + + LI := LN (LI).Next; + RI := RN (RI).Next; + end loop; + end; + + return True; + end "="; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + + -- We always perform the assignment first, before we change container + -- state, in order to defend against exceptions duration assignment. + + N (New_Node).Element := New_Item; + Container.Free := N (New_Node).Next; + + else + -- A negative free store value means that the links of the nodes in + -- the free store have not been initialized. In this case, the nodes + -- are physically contiguous in the array, starting at the index that + -- is the absolute value of the Container.Free, and continuing until + -- the end of the array (Nodes'Last). + + New_Node := abs Container.Free; + + -- As above, we perform this assignment first, before modifying any + -- container state. + + N (New_Node).Element := New_Item; + Container.Free := Container.Free - 1; + end if; + end Allocate; + + procedure Allocate + (Container : in out List; + Stream : not null access Root_Stream_Type'Class; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + + -- We always perform the assignment first, before we change container + -- state, in order to defend against exceptions duration assignment. + + Element_Type'Read (Stream, N (New_Node).Element); + Container.Free := N (New_Node).Next; + + else + -- A negative free store value means that the links of the nodes in + -- the free store have not been initialized. In this case, the nodes + -- are physically contiguous in the array, starting at the index that + -- is the absolute value of the Container.Free, and continuing until + -- the end of the array (Nodes'Last). + + New_Node := abs Container.Free; + + -- As above, we perform this assignment first, before modifying any + -- container state. + + Element_Type'Read (Stream, N (New_Node).Element); + Container.Free := Container.Free - 1; + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + SN : Node_Array renames Source.Nodes; + J : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error -- ??? + with "Target capacity is less than Source length"; + end if; + + Target.Clear; + + J := Source.First; + while J /= 0 loop + Target.Append (SN (J).Element); + J := SN (J).Next; + end loop; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); + return; + end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + TC_Check (Container.TC); + + while Container.Length > 1 loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + + X := Container.First; + pragma Assert (X = Container.Last); + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container, X); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : List; Capacity : Count_Type := 0) return List is + C : Count_Type; + + begin + if Capacity < Source.Length then + if Checks and then Capacity /= 0 then + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + C := Source.Length; + else + C := Capacity; + end if; + + return Target : List (Capacity => C) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; + + if Count = 0 then + Position := No_Element; + return; + end if; + + TC_Check (Container.TC); + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container, X); + return; + end if; + + Position.Node := N (X).Next; + + N (N (X).Next).Prev := N (X).Prev; + N (N (X).Prev).Next := N (X).Next; + + Free (Container, X); + end loop; + + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + for J in 1 .. Count loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + return Position.Container.Nodes (Position.Node).Element; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type := Position.Node; + + begin + if Node = 0 then + Node := Container.First; + + else + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + while Node /= 0 loop + if Nodes (Node).Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Nodes (Node).Next; + end loop; + + return No_Element; + end; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.First); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Doubly_Linked_Lists.First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + begin + if Checks and then Container.First = 0 then + raise Constraint_Error with "list is empty"; + end if; + + return Container.Nodes (Container.First).Element; + end First_Element; + + ---------- + -- Free -- + ---------- + + procedure Free + (Container : in out List; + X : Count_Type) + is + pragma Assert (X > 0); + pragma Assert (X <= Container.Capacity); + + N : Node_Array renames Container.Nodes; + pragma Assert (N (X).Prev >= 0); -- node is active + + begin + -- The list container actually contains two lists: one for the "active" + -- nodes that contain elements that have been inserted onto the list, + -- and another for the "inactive" nodes for the free store. + + -- We desire that merely declaring an object should have only minimal + -- cost; specially, we want to avoid having to initialize the free + -- store (to fill in the links), especially if the capacity is large. + + -- The head of the free list is indicated by Container.Free. If its + -- value is non-negative, then the free store has been initialized in + -- the "normal" way: Container.Free points to the head of the list of + -- free (inactive) nodes, and the value 0 means the free list is empty. + -- Each node on the free list has been initialized to point to the next + -- free node (via its Next component), and the value 0 means that this + -- is the last free node. + + -- If Container.Free is negative, then the links on the free store have + -- not been initialized. In this case the link values are implied: the + -- free store comprises the components of the node array started with + -- the absolute value of Container.Free, and continuing until the end of + -- the array (Nodes'Last). + + -- If the list container is manipulated on one end only (for example if + -- the container were being used as a stack), then there is no need to + -- initialize the free store, since the inactive nodes are physically + -- contiguous (in fact, they lie immediately beyond the logical end + -- being manipulated). The only time we need to actually initialize the + -- nodes in the free store is if the node that becomes inactive is not + -- at the end of the list. The free store would then be discontiguous + -- and so its nodes would need to be linked in the traditional way. + + -- ??? + -- It might be possible to perform an optimization here. Suppose that + -- the free store can be represented as having two parts: one comprising + -- the non-contiguous inactive nodes linked together in the normal way, + -- and the other comprising the contiguous inactive nodes (that are not + -- linked together, at the end of the nodes array). This would allow us + -- to never have to initialize the free store, except in a lazy way as + -- nodes become inactive. + + -- When an element is deleted from the list container, its node becomes + -- inactive, and so we set its Prev component to a negative value, to + -- indicate that it is now inactive. This provides a useful way to + -- detect a dangling cursor reference (and which is used in Vet). + + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Container.Free >= 0 then + + -- The free store has previously been initialized. All we need to + -- do here is link the newly-free'd node onto the free list. + + N (X).Next := Container.Free; + Container.Free := X; + + elsif X + 1 = abs Container.Free then + + -- The free store has not been initialized, and the node becoming + -- inactive immediately precedes the start of the free store. All + -- we need to do is move the start of the free store back by one. + + -- Note: initializing Next to zero is not strictly necessary but + -- seems cleaner and marginally safer. + + N (X).Next := 0; + Container.Free := Container.Free + 1; + + else + -- The free store has not been initialized, and the node becoming + -- inactive does not immediately precede the free store. Here we + -- first initialize the free store (meaning the links are given + -- values in the traditional way), and then link the newly-free'd + -- node onto the head of the free store. + + -- ??? + -- See the comments above for an optimization opportunity. If the + -- next link for a node on the free store is negative, then this + -- means the remaining nodes on the free store are physically + -- contiguous, starting as the absolute value of that index value. + + Container.Free := abs Container.Free; + + if Container.Free > Container.Capacity then + Container.Free := 0; + + else + for I in Container.Free .. Container.Capacity - 1 loop + N (I).Next := I + 1; + end loop; + + N (Container.Capacity).Next := 0; + end if; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type; + begin + Node := Container.First; + for J in 2 .. Container.Length loop + if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then + return False; + end if; + + Node := Nodes (Node).Next; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge + (Target : in out List; + Source : in out List) + is + begin + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then + return; + end if; + + if Checks and then Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + + if Checks and then Target.Length > Count_Type'Last - Source.Length + then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Checks and then Target.Length + Source.Length > Target.Capacity + then + raise Capacity_Error with "new length exceeds target capacity"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); + + LN : Node_Array renames Target.Nodes; + RN : Node_Array renames Source.Nodes; + + LI, LJ, RI, RJ : Count_Type; + + begin + LI := Target.First; + RI := Source.First; + while RI /= 0 loop + pragma Assert (RN (RI).Next = 0 + or else not (RN (RN (RI).Next).Element < + RN (RI).Element)); + + if LI = 0 then + Splice_Internal (Target, 0, Source); + exit; + end if; + + pragma Assert (LN (LI).Next = 0 + or else not (LN (LN (LI).Next).Element < + LN (LI).Element)); + + if RN (RI).Element < LN (LI).Element then + RJ := RI; + RI := RN (RI).Next; + Splice_Internal (Target, LI, Source, RJ, LJ); + + else + LI := LN (LI).Next; + end if; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + N : Node_Array renames Container.Nodes; + + procedure Partition (Pivot, Back : Count_Type); + -- What does this do ??? + + procedure Sort (Front, Back : Count_Type); + -- Internal procedure, what does it do??? rename it??? + + --------------- + -- Partition -- + --------------- + + procedure Partition (Pivot, Back : Count_Type) is + Node : Count_Type; + + begin + Node := N (Pivot).Next; + while Node /= Back loop + if N (Node).Element < N (Pivot).Element then + declare + Prev : constant Count_Type := N (Node).Prev; + Next : constant Count_Type := N (Node).Next; + + begin + N (Prev).Next := Next; + + if Next = 0 then + Container.Last := Prev; + else + N (Next).Prev := Prev; + end if; + + N (Node).Next := Pivot; + N (Node).Prev := N (Pivot).Prev; + + N (Pivot).Prev := Node; + + if N (Node).Prev = 0 then + Container.First := Node; + else + N (N (Node).Prev).Next := Node; + end if; + + Node := Next; + end; + + else + Node := N (Node).Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Count_Type) is + Pivot : constant Count_Type := + (if Front = 0 then Container.First else N (Front).Next); + begin + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Sort + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + TC_Check (Container.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Sort (Front => 0, Back => 0); + end; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Sort; + + end Generic_Sorting; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= 0; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + First_Node : Count_Type; + New_Node : Count_Type; + + begin + if Before.Container /= null then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Before cursor designates wrong list"; + end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Checks and then Container.Length > Container.Capacity - Count then + raise Capacity_Error with "capacity exceeded"; + end if; + + TC_Check (Container.TC); + + Allocate (Container, New_Item, New_Node); + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); + + for Index in Count_Type'(2) .. Count loop + Allocate (Container, New_Item, New_Node); + Insert_Internal (Container, Before.Node, New_Node); + end loop; + + Position := Cursor'(Container'Unchecked_Access, First_Node); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + pragma Warnings (Off); + New_Item : Element_Type; + -- OK to reference, see below. Note that we need to suppress both the + -- front end warning and the back end warning. + + begin + -- There is no explicit element provided, but in an instance the element + -- type may be a scalar with a Default_Value aspect, or a composite + -- type with such a scalar component, or components with default + -- initialization, so insert the specified number of possibly + -- initialized elements at the given position. + + Insert (Container, Before, New_Item, Position, Count); + pragma Warnings (On); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + + Container.First := New_Node; + N (Container.First).Prev := 0; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + -- Before = zero means append + + elsif Before = 0 then + pragma Assert (N (Container.Last).Next = 0); + + N (Container.Last).Next := New_Node; + N (New_Node).Prev := Container.Last; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + -- Before = Container.First means prepend + + elsif Before = Container.First then + pragma Assert (N (Container.First).Prev = 0); + + N (Container.First).Prev := New_Node; + N (New_Node).Next := Container.First; + + Container.First := New_Node; + N (Container.First).Prev := 0; + + else + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + N (New_Node).Next := Before; + N (New_Node).Prev := N (Before).Prev; + + N (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + Node : Count_Type := Container.First; + + begin + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Next; + end loop; + end Iterate; + + function Iterate + (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is 0 (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : List; + Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong list"; + end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is positive (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.Last); + end if; + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Doubly_Linked_Lists.Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + begin + if Checks and then Container.Last = 0 then + raise Constraint_Error with "list is empty"; + end if; + + return Container.Nodes (Container.Last).Element; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out List; + Source : in out List) + is + N : Node_Array renames Source.Nodes; + X : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error with "Source length exceeds Target capacity"; + end if; + + TC_Check (Source.TC); + + -- Clear target, note that this checks busy bits of Target + + Clear (Target); + + while Source.Length > 1 loop + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last /= Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy first element from Source to Target + + X := Source.First; + Append (Target, N (X).Element); + + -- Unlink first node of Source + + Source.First := N (X).Next; + N (Source.First).Prev := 0; + + Source.Length := Source.Length - 1; + + -- The representation invariants for Source have been restored. It is + -- now safe to free the unlinked node, without fear of corrupting the + -- active links of Source. + + -- Note that the algorithm we use here models similar algorithms used + -- in the unbounded form of the doubly-linked list container. In that + -- case, Free is an instantation of Unchecked_Deallocation, which can + -- fail (because PE will be raised if controlled Finalize fails), so + -- we must defer the call until the last step. Here in the bounded + -- form, Free merely links the node we have just "deallocated" onto a + -- list of inactive nodes, so technically Free cannot fail. However, + -- for consistency, we handle Free the same way here as we do for the + -- unbounded form, with the pessimistic assumption that it can fail. + + Free (Source, X); + end loop; + + if Source.Length = 1 then + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last = Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy element from Source to Target + + X := Source.First; + Append (Target, N (X).Element); + + -- Unlink node of Source + + Source.First := 0; + Source.Last := 0; + Source.Length := 0; + + -- Return the unlinked node to the free store + + Free (Source, X); + end if; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Next; + begin + if Node = 0 then + return No_Element; + else + return Cursor'(Position.Container, Node); + end if; + end; + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong list"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Previous"); + + declare + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Prev; + begin + if Node = 0 then + return No_Element; + else + return Cursor'(Position.Container, Node); + end if; + end; + end Previous; + + function Previous + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong list"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); + C : List renames Position.Container.all'Unrestricted_Access.all; + N : Node_Type renames C.Nodes (Position.Node); + begin + Process (N.Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List) + is + N : Count_Type'Base; + X : Count_Type; + + begin + Clear (Item); + Count_Type'Base'Read (Stream, N); + + if Checks and then N < 0 then + raise Program_Error with "bad list length (corrupt stream)"; + end if; + + if N = 0 then + return; + end if; + + if Checks and then N > Item.Capacity then + raise Constraint_Error with "length exceeds capacity"; + end if; + + for Idx in 1 .. N loop + Allocate (Item, Stream, New_Node => X); + Insert_Internal (Item, Before => 0, New_Node => X); + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + TE_Check (Container.TC); + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + N : Node_Array renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; + + procedure Swap (L, R : Count_Type); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; + + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + TC_Check (Container.TC); + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := N (J).Next; + exit when I = J; + + I := N (I).Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := N (I).Next; + exit when I = J; + + J := N (J).Prev; + exit when I = J; + end loop; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Count_Type := Position.Node; + + begin + if Node = 0 then + Node := Container.Last; + + else + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + while Node /= 0 loop + if Container.Nodes (Node).Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Container.Nodes (Node).Prev; + end loop; + + return No_Element; + end; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + Node : Count_Type := Container.Last; + + begin + while Node /= 0 loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Container.Nodes (Node).Prev; + end loop; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); + end if; + + if Target'Address = Source'Address or else Source.Length = 0 then + return; + end if; + + if Checks and then Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Checks and then Target.Length + Source.Length > Target.Capacity then + raise Capacity_Error with "new length exceeds target capacity"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + Splice_Internal (Target, Before.Node, Source); + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + N : Node_Array renames Container.Nodes; + + begin + if Before.Container /= null then + if Checks and then Before.Container /= Container'Unchecked_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + + TC_Check (Container.TC); + + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; + + Container.Last := Position.Node; + N (Container.Last).Next := 0; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.First).Prev := Position.Node; + N (Position.Node).Next := Container.First; + + Container.First := Position.Node; + N (Container.First).Prev := 0; + + return; + end if; + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + elsif Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (N (Before.Node).Prev).Next := Position.Node; + N (Position.Node).Prev := N (Before.Node).Prev; + + N (Before.Node).Prev := Position.Node; + N (Position.Node).Next := Before.Node; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + is + Target_Position : Count_Type; + + begin + if Target'Address = Source'Address then + Splice (Target, Before, Position); + return; + end if; + + if Before.Container /= null then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Source'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Checks and then Target.Length >= Target.Capacity then + raise Capacity_Error with "Target is full"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + Splice_Internal + (Target => Target, + Before => Before.Node, + Source => Source, + Src_Pos => Position.Node, + Tgt_Pos => Target_Position); + + Position := Cursor'(Target'Unrestricted_Access, Target_Position); + end Splice; + + --------------------- + -- Splice_Internal -- + --------------------- + + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; + Source : in out List) + is + N : Node_Array renames Source.Nodes; + X : Count_Type; + + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases disposed of. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= 0); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (Source.Last /= 0); + pragma Assert (N (Source.Last).Next = 0); + pragma Assert (Target.Length <= Count_Type'Last - Source.Length); + pragma Assert (Target.Length + Source.Length <= Target.Capacity); + + while Source.Length > 1 loop + -- Copy first element of Source onto Target + + Allocate (Target, N (Source.First).Element, New_Node => X); + Insert_Internal (Target, Before => Before, New_Node => X); + + -- Unlink the first node from Source + + X := Source.First; + pragma Assert (N (N (X).Next).Prev = X); + + Source.First := N (X).Next; + N (Source.First).Prev := 0; + + Source.Length := Source.Length - 1; + + -- Return the Source node to its free store + + Free (Source, X); + end loop; + + -- Copy first (and only remaining) element of Source onto Target + + Allocate (Target, N (Source.First).Element, New_Node => X); + Insert_Internal (Target, Before => Before, New_Node => X); + + -- Unlink the node from Source + + X := Source.First; + pragma Assert (X = Source.Last); + + Source.First := 0; + Source.Last := 0; + + Source.Length := 0; + + -- Return the Source node to its free store + + Free (Source, X); + end Splice_Internal; + + procedure Splice_Internal + (Target : in out List; + Before : Count_Type; -- node of Target + Source : in out List; + Src_Pos : Count_Type; -- node of Source + Tgt_Pos : out Count_Type) + is + N : Node_Array renames Source.Nodes; + + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases handled. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Target.Length < Target.Capacity); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= 0); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (Source.Last /= 0); + pragma Assert (N (Source.Last).Next = 0); + pragma Assert (Src_Pos /= 0); + + Allocate (Target, N (Src_Pos).Element, New_Node => Tgt_Pos); + Insert_Internal (Target, Before => Before, New_Node => Tgt_Pos); + + if Source.Length = 1 then + pragma Assert (Source.First = Source.Last); + pragma Assert (Src_Pos = Source.First); + + Source.First := 0; + Source.Last := 0; + + elsif Src_Pos = Source.First then + pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); + + Source.First := N (Src_Pos).Next; + N (Source.First).Prev := 0; + + elsif Src_Pos = Source.Last then + pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); + + Source.Last := N (Src_Pos).Prev; + N (Source.Last).Next := 0; + + else + pragma Assert (Source.Length >= 3); + pragma Assert (N (N (Src_Pos).Next).Prev = Src_Pos); + pragma Assert (N (N (Src_Pos).Prev).Next = Src_Pos); + + N (N (Src_Pos).Next).Prev := N (Src_Pos).Prev; + N (N (Src_Pos).Prev).Next := N (Src_Pos).Next; + end if; + + Source.Length := Source.Length - 1; + Free (Source, Src_Pos); + end Splice_Internal; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if Checks and then I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if Checks and then J.Container /= Container'Unchecked_Access then + raise Program_Error with "J cursor designates wrong container"; + end if; + + if I.Node = J.Node then + return; + end if; + + TE_Check (Container.TC); + + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + declare + EI : Element_Type renames Container.Nodes (I.Node).Element; + EJ : Element_Type renames Container.Nodes (J.Node).Element; + + EI_Copy : constant Element_Type := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if Checks and then I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if Checks and then J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor designates wrong container"; + end if; + + if I.Node = J.Node then + return; + end if; + + TC_Check (Container.TC); + + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + + declare + I_Next : constant Cursor := Next (I); + + begin + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + declare + J_Next : constant Cursor := Next (J); + + begin + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end; + end if; + end; + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + N : Node_Type renames Container.Nodes (Position.Node); + begin + Process (N.Element); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + declare + L : List renames Position.Container.all; + N : Node_Array renames L.Nodes; + + begin + if L.Length = 0 then + return False; + end if; + + if L.First = 0 or L.First > L.Capacity then + return False; + end if; + + if L.Last = 0 or L.Last > L.Capacity then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 0 then + return False; + end if; + + if Position.Node > L.Capacity then + return False; + end if; + + -- An invariant of an active node is that its Previous and Next + -- components are non-negative. Operation Free sets the Previous + -- component of the node to the value -1 before actually deallocating + -- the node, to mark the node as inactive. (By "dellocating" we mean + -- only that the node is linked onto a list of inactive nodes used + -- for storage.) This marker gives us a simple way to detect a + -- dangling reference to a node. + + if N (Position.Node).Prev < 0 then -- see Free + return False; + end if; + + if N (Position.Node).Prev > L.Capacity then + return False; + end if; + + if N (Position.Node).Next = Position.Node then + return False; + end if; + + if N (Position.Node).Prev = Position.Node then + return False; + end if; + + if N (Position.Node).Prev = 0 + and then Position.Node /= L.First + then + return False; + end if; + + pragma Assert (N (Position.Node).Prev /= 0 + or else Position.Node = L.First); + + if N (Position.Node).Next = 0 + and then Position.Node /= L.Last + then + return False; + end if; + + pragma Assert (N (Position.Node).Next /= 0 + or else Position.Node = L.Last); + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + -- Eliminate earlier possibility + + if Position.Node = L.First then + return True; + end if; + + pragma Assert (N (Position.Node).Prev /= 0); + + -- Eliminate another possibility + + if Position.Node = L.Last then + return True; + end if; + + pragma Assert (N (Position.Node).Next /= 0); + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if N (L.First).Next /= Position.Node then + return False; + end if; + + if N (L.Last).Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List) + is + Node : Count_Type; + + begin + Count_Type'Base'Write (Stream, Item.Length); + + Node := Item.First; + while Node /= 0 loop + Element_Type'Write (Stream, Item.Nodes (Node).Element); + Node := Item.Nodes (Node).Next; + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cbdlli.ads b/gcc/ada/libgnat/a-cbdlli.ads new file mode 100644 index 0000000..cfcbecf --- /dev/null +++ b/gcc/ada/libgnat/a-cbdlli.ads @@ -0,0 +1,398 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Streams; +private with Ada.Finalization; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Bounded_Doubly_Linked_Lists is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + type List (Capacity : Count_Type) is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package List_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : List) return Boolean; + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type; + + procedure Assign (Target : in out List; Source : List); + + function Copy (Source : List; Capacity : Count_Type := 0) return List; + + procedure Move + (Target : in out List; + Source : in out List); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out List); + + function Iterate + (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : List; + Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'class; + + procedure Swap + (Container : in out List; + I, J : Cursor); + + procedure Swap_Links + (Container : in out List; + I, J : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + use Ada.Streams; + use Ada.Finalization; + + type Node_Type is record + Prev : Count_Type'Base; + Next : Count_Type; + Element : aliased Element_Type; + end record; + + type Node_Array is array (Count_Type range <>) of Node_Type; + + type List (Capacity : Count_Type) is tagged record + Nodes : Node_Array (1 .. Capacity) := (others => <>); + Free : Count_Type'Base := -1; + First : Count_Type := 0; + Last : Count_Type := 0; + Length : Count_Type := 0; + TC : aliased Tamper_Counts; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List); + + for List'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List); + + for List'Write use Write; + + type List_Access is access all List; + for List_Access'Storage_Size use 0; + + type Cursor is record + Container : List_Access; + Node : Count_Type := 0; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_List : constant List := (Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(null, 0); + + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Count_Type; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Bounded_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cbhama.adb b/gcc/ada/libgnat/a-cbhama.adb new file mode 100644 index 0000000..57948d2 --- /dev/null +++ b/gcc/ada/libgnat/a-cbhama.adb @@ -0,0 +1,1252 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Hashed_Maps is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Key_Node); + + function Hash_Node (Node : Node_Type) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Type) return Count_Type; + pragma Inline (Next); + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Bounded_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next); + + package Key_Ops is new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + function Find_Equal_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean; + + function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean + is + R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key); + R_Node : Count_Type := R_HT.Buckets (R_Index); + + begin + while R_Node /= 0 loop + if Equivalent_Keys (L_Node.Key, R_HT.Nodes (R_Node).Key) then + return L_Node.Element = R_HT.Nodes (R_Node).Element; + end if; + + R_Node := R_HT.Nodes (R_Node).Next; + end loop; + + return False; + end Find_Equal_Key; + + -- Start of processing for "=" + + begin + return Is_Equal (Left, Right); + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Element (Source_Node : Count_Type); + + procedure Insert_Elements is + new HT_Ops.Generic_Iteration (Insert_Element); + + -------------------- + -- Insert_Element -- + -------------------- + + procedure Insert_Element (Source_Node : Count_Type) is + N : Node_Type renames Source.Nodes (Source_Node); + C : Cursor; + B : Boolean; + + begin + Insert (Target, N.Key, N.Element, C, B); + pragma Assert (B); + end Insert_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error + with "Target capacity is less than Source length"; + end if; + + HT_Ops.Clear (Target); + Insert_Elements (Source); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type is + begin + return Container.Capacity; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Position), + "Position cursor in Constant_Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Count_Type := + Key_Ops.Find (Container'Unrestricted_Access.all, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Map; + Capacity : Count_Type := 0; + Modulus : Hash_Type := 0) return Map + is + C : Count_Type; + M : Hash_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + elsif Checks then + raise Capacity_Error with "Capacity value too small"; + end if; + + if Modulus = 0 then + M := Default_Modulus (C); + else + M := Modulus; + end if; + + return Target : Map (Capacity => C, Modulus => M) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + --------------------- + -- Default_Modulus -- + --------------------- + + function Default_Modulus (Capacity : Count_Type) return Hash_Type is + begin + return To_Prime (Capacity); + end Default_Modulus; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Count_Type; + + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + + if Checks and then X = 0 then + raise Constraint_Error with "attempt to delete key not in map"; + end if; + + HT_Ops.Free (Container, X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + TC_Check (Container.TC); + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + HT_Ops.Free (Container, Position.Node); + + Position := No_Element; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Count_Type := + Key_Ops.Find (Container'Unrestricted_Access.all, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + return Position.Container.Nodes (Position.Node).Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean is + begin + return Equivalent_Keys (Key, Node.Key); + end Equivalent_Key_Node; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Cursor) + return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if Checks and then Right.Node = 0 then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad"); + pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return Equivalent_Keys (LN.Key, RN.Key); + end; + end Equivalent_Keys; + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + + begin + return Equivalent_Keys (LN.Key, Right); + end; + end Equivalent_Keys; + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = 0 then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); + + declare + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return Equivalent_Keys (Left, RN.Key); + end; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Count_Type; + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + HT_Ops.Free (Container, X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := + Key_Ops.Find (Container'Unrestricted_Access.all, Key); + begin + if Node = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); + end if; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); + begin + if Node = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= 0; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Type) return Hash_Type is + begin + return Hash (Node.Key); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.TC); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + procedure Assign_Key (Node : in out Node_Type); + pragma Inline (Assign_Key); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new HT_Ops.Generic_Allocate (Assign_Key); + + ----------------- + -- Assign_Key -- + ----------------- + + procedure Assign_Key (Node : in out Node_Type) is + New_Item : Element_Type; + pragma Unmodified (New_Item); + -- Default-initialized element (ok to reference, see below) + + begin + Node.Key := Key; + + -- There is no explicit element provided, but in an instance the + -- element type may be a scalar with a Default_Value aspect, or a + -- composite type with such a scalar component, or components with + -- default initialization, so insert a possibly initialized element + -- under the given key. + + Node.Element := New_Item; + end Assign_Key; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for a key, given its hash value. + + if Checks and then Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; + + Local_Insert (Container, Key, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + procedure Assign_Key (Node : in out Node_Type); + pragma Inline (Assign_Key); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new HT_Ops.Generic_Allocate (Assign_Key); + + ----------------- + -- Assign_Key -- + ----------------- + + procedure Assign_Key (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Assign_Key; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for a key, given its hash value. + + if Checks and then Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; + + Local_Insert (Container, Key, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (Container); + end Iterate; + + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + + return Position.Container.Nodes (Position.Node).Key; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) + is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Target.Assign (Source); + Source.Clear; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Type) return Count_Type is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Next"); + + declare + M : Map renames Position.Container.all; + Node : constant Count_Type := HT_Ops.Next (M, Position.Node); + begin + if Node = 0 then + return No_Element; + else + return Cursor'(Position.Container, Node); + end if; + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); + end Next; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + M : Map renames Position.Container.all; + N : Node_Type renames M.Nodes (Position.Node); + Lock : With_Lock (M.TC'Unrestricted_Access); + begin + Process (N.Key, N.Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Count_Type; + -- pragma Inline (Read_Node); ??? + + procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Count_Type + is + procedure Read_Element (Node : in out Node_Type); + -- pragma Inline (Read_Element); ??? + + procedure Allocate is + new HT_Ops.Generic_Allocate (Read_Element); + + procedure Read_Element (Node : in out Node_Type) is + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + Node : Count_Type; + + -- Start of processing for Read_Node + + begin + Allocate (Container, Node); + return Node; + end Read_Node; + + -- Start of processing for Read + + begin + Read_Nodes (Stream, Container); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Position), + "Position cursor in function Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with + "attempt to replace key not in map"; + end if; + + TE_Check (Container.TC); + + declare + N : Node_Type renames Container.Nodes (Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + TE_Check (Position.Container.TC); + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) + is + begin + if Checks and then Capacity > Container.Capacity then + raise Capacity_Error with "requested capacity is too large"; + end if; + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is + begin + Node.Next := Next; + end Set_Next; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + Process (N.Key, N.Element); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + declare + M : Map renames Position.Container.all; + X : Count_Type; + + begin + if M.Length = 0 then + return False; + end if; + + if M.Capacity = 0 then + return False; + end if; + + if M.Buckets'Length = 0 then + return False; + end if; + + if Position.Node > M.Capacity then + return False; + end if; + + if M.Nodes (Position.Node).Next = Position.Node then + return False; + end if; + + X := M.Buckets (Key_Ops.Checked_Index + (M, M.Nodes (Position.Node).Key)); + + for J in 1 .. M.Length loop + if X = Position.Node then + return True; + end if; + + if X = 0 then + return False; + end if; + + if X = M.Nodes (X).Next then -- to prevent unnecessary looping + return False; + end if; + + X := M.Nodes (X).Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Node); + + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write_Nodes (Stream, Container); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Bounded_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cbhama.ads b/gcc/ada/libgnat/a-cbhama.ads new file mode 100644 index 0000000..9d36e15 --- /dev/null +++ b/gcc/ada/libgnat/a-cbhama.ads @@ -0,0 +1,468 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Hash_Tables; +private with Ada.Streams; +private with Ada.Finalization; + +generic + type Key_Type is private; + type Element_Type is private; + + with function Hash (Key : Key_Type) return Hash_Type; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Hashed_Maps is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + type Map (Capacity : Count_Type; Modulus : Hash_Type) is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + -- Map objects declared without an initialization expression are + -- initialized to the value Empty_Map. + + No_Element : constant Cursor; + -- Cursor objects declared without an initialization expression are + -- initialized to the value No_Element. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Map_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Map) return Boolean; + -- For each key/element pair in Left, equality attempts to find the key in + -- Right; if a search fails the equality returns False. The search works by + -- calling Hash to find the bucket in the Right map that corresponds to the + -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys + -- to compare the key (in Left) to the key of each node in the bucket (in + -- Right); if the keys are equivalent, then the equality test for this + -- key/element pair (in Left) completes by calling the element equality + -- operator to compare the element (in Left) to the element of the node + -- (in Right) whose key matched. + + function Capacity (Container : Map) return Count_Type; + -- Returns the current capacity of the map. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); + -- If the value of the Capacity actual parameter is less or equal to + -- Container.Capacity, then the operation has no effect. Otherwise it + -- raises Capacity_Error (as no expansion of capacity is possible for a + -- bounded form). + + function Default_Modulus (Capacity : Count_Type) return Hash_Type; + -- Returns a modulus value (hash table size) which is optimal for the + -- specified capacity (which corresponds to the maximum number of items). + + function Length (Container : Map) return Count_Type; + -- Returns the number of items in the map + + function Is_Empty (Container : Map) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Map); + -- Removes all of the items from the map + + function Key (Position : Cursor) return Key_Type; + -- Returns the key of the node designated by the cursor + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + -- Assigns the value New_Item to the element designated by the cursor + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + -- Calls Process with the key and element (both having only a constant + -- view) of the node designed by the cursor. + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + -- Calls Process with the key (with only a constant view) and element (with + -- a variable view) of the node designed by the cursor. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + + procedure Assign (Target : in out Map; Source : Map); + -- If Target denotes the same object as Source, then the operation has no + -- effect. If the Target capacity is less than the Source length, then + -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then + -- copies the (active) elements from Source to Target. + + function Copy + (Source : Map; + Capacity : Count_Type := 0; + Modulus : Hash_Type := 0) return Map; + -- Constructs a new set object whose elements correspond to Source. If the + -- Capacity parameter is 0, then the capacity of the result is the same as + -- the length of Source. If the Capacity parameter is equal or greater than + -- the length of Source, then the capacity of the result is the specified + -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter + -- is 0, then the modulus of the result is the value returned by a call to + -- Default_Modulus with the capacity parameter determined as above; + -- otherwise the modulus of the result is the specified value. + + procedure Move (Target : in out Map; Source : in out Map); + -- Clears Target (if it's not empty), and then moves (not copies) the + -- buckets array and nodes from Source to Target. + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + -- Conditionally inserts New_Item into the map. If Key is already in the + -- map, then Inserted returns False and Position designates the node + -- containing the existing key/element pair (neither of which is modified). + -- If Key is not already in the map, the Inserted returns True and Position + -- designates the newly-inserted node container Key and New_Item. The + -- search for the key works as follows. Hash is called to determine Key's + -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to + -- compare Key to each node in that bucket. If the bucket is empty, or + -- there were no matching keys in the bucket, the search "fails" and the + -- key/item pair is inserted in the map (and Inserted returns True); + -- otherwise, the search "succeeds" (and Inserted returns False). + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + -- The same as the (conditional) Insert that accepts an element parameter, + -- with the difference that if Inserted returns True, then the element of + -- the newly-inserted node is initialized to its default value. + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map, performing the usual search (which + -- involves calling both Hash and Equivalent_Keys); if the search succeeds + -- (because Key is already in the map), then it raises Constraint_Error. + -- (This version of Insert is similar to Replace, but having the opposite + -- exception behavior. It is intended for use when you want to assert that + -- Key is not already in the map.) + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map. If Key is already in the map, then + -- both the existing key and element are assigned the values of Key and + -- New_Item, respectively. (This version of Insert only raises an exception + -- if cursor tampering occurs. It is intended for use when you want to + -- insert the key/element pair in the map, and you don't care whether Key + -- is already present.) + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Searches for Key in the map; if the search fails (because Key was not in + -- the map), then it raises Constraint_Error. Otherwise, both the existing + -- key and element are assigned the values of Key and New_Item rsp. (This + -- is similar to Insert, but with the opposite exception behavior. It is to + -- be used when you want to assert that Key is already in the map.) + + procedure Exclude (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map, and if found, removes its node from the map + -- and then deallocates it. The search works as follows. The operation + -- calls Hash to determine the key's bucket; if the bucket is not empty, it + -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is + -- the deletion analog of Include. It is intended for use when you want to + -- remove the item from the map, but don't care whether the key is already + -- in the map.) + + procedure Delete (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map (which involves calling both Hash and + -- Equivalent_Keys). If the search fails, then the operation raises + -- Constraint_Error. Otherwise it removes the node from the map and then + -- deallocates it. (This is the deletion analog of non-conditional + -- Insert. It is intended for use when you want to assert that the item is + -- already in the map.) + + procedure Delete (Container : in out Map; Position : in out Cursor); + -- Removes the node designated by Position from the map, and then + -- deallocates the node. The operation calls Hash to determine the bucket, + -- and then compares Position to each node in the bucket until there's a + -- match (it does not call Equivalent_Keys). + + function First (Container : Map) return Cursor; + -- Returns a cursor that designates the first non-empty bucket, by + -- searching from the beginning of the buckets array. + + function Next (Position : Cursor) return Cursor; + -- Returns a cursor that designates the node that follows the current one + -- designated by Position. If Position designates the last node in its + -- bucket, the operation calls Hash to compute the index of this bucket, + -- and searches the buckets array for the first non-empty bucket, starting + -- from that index; otherwise, it simply follows the link to the next node + -- in the same bucket. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Find (Container : Map; Key : Key_Type) return Cursor; + -- Searches for Key in the map. Find calls Hash to determine the key's + -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare + -- Key to each key in the bucket. If the search succeeds, Find returns a + -- cursor designating the matching node; otherwise, it returns No_Element. + + function Contains (Container : Map; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + function Element (Container : Map; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) + + function Equivalent_Keys (Left, Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Keys with the keys of the nodes + -- designated by cursors Left and Right. + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; + -- Returns the result of calling Equivalent_Keys with key of the node + -- designated by Left and key Right. + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Keys with key Left and the node + -- designated by Right. + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + -- Calls Process for each node in the map + + function Iterate (Container : Map) + return Map_Iterator_Interfaces.Forward_Iterator'class; + +private + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Next); + + type Node_Type is record + Key : Key_Type; + Element : aliased Element_Type; + Next : Count_Type; + end record; + + package HT_Types is + new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + + type Map (Capacity : Count_Type; Modulus : Hash_Type) is + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + + use HT_Types, HT_Types.Implementation; + use Ada.Streams; + use Ada.Finalization; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + -- Note: If a Cursor object has no explicit initialization expression, + -- it must default initialize to the same value as constant No_Element. + -- The Node component of type Cursor has scalar type Count_Type, so it + -- requires an explicit initialization expression of its own declaration, + -- in order for objects of record type Cursor to properly initialize. + + type Cursor is record + Container : Map_Access; + Node : Count_Type := 0; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := + (Hash_Table_Type with Capacity => 0, Modulus => 0); + + No_Element : constant Cursor := (Container => null, Node => 0); + + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Bounded_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cbhase.adb b/gcc/ada/libgnat/a-cbhase.adb new file mode 100644 index 0000000..fbf16a2 --- /dev/null +++ b/gcc/ada/libgnat/a-cbhase.adb @@ -0,0 +1,1946 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Hashed_Sets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Keys); + + function Hash_Node (Node : Node_Type) return Hash_Type; + pragma Inline (Hash_Node); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean); + + function Is_In (HT : Set; Key : Node_Type) return Boolean; + pragma Inline (Is_In); + + procedure Set_Element (Node : in out Node_Type; Item : Element_Type); + pragma Inline (Set_Element); + + function Next (Node : Node_Type) return Count_Type; + pragma Inline (Next); + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Bounded_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next); + + package Element_Keys is new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + function Find_Equal_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean; + pragma Inline (Find_Equal_Key); + + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); + + R_Node : Count_Type := R_HT.Buckets (R_Index); + + begin + loop + if R_Node = 0 then + return False; + end if; + + if L_Node.Element = R_HT.Nodes (R_Node).Element then + return True; + end if; + + R_Node := Next (R_HT.Nodes (R_Node)); + end loop; + end Find_Equal_Key; + + -- Start of processing for "=" + + begin + return Is_Equal (Left, Right); + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + procedure Insert_Element (Source_Node : Count_Type); + + procedure Insert_Elements is + new HT_Ops.Generic_Iteration (Insert_Element); + + -------------------- + -- Insert_Element -- + -------------------- + + procedure Insert_Element (Source_Node : Count_Type) is + N : Node_Type renames Source.Nodes (Source_Node); + X : Count_Type; + B : Boolean; + begin + Insert (Target, N.Element, X, B); + pragma Assert (B); + end Insert_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error + with "Target capacity is less than Source length"; + end if; + + HT_Ops.Clear (Target); + Insert_Elements (Source); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Set) return Count_Type is + begin + return Container.Capacity; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + begin + HT_Ops.Clear (Container); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Set; + Capacity : Count_Type := 0; + Modulus : Hash_Type := 0) return Set + is + C : Count_Type; + M : Hash_Type; + + begin + if Capacity = 0 then + C := Source.Length; + elsif Capacity >= Source.Length then + C := Capacity; + elsif Checks then + raise Capacity_Error with "Capacity value too small"; + end if; + + if Modulus = 0 then + M := Default_Modulus (C); + else + M := Modulus; + end if; + + return Target : Set (Capacity => C, Modulus => M) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + --------------------- + -- Default_Modulus -- + --------------------- + + function Default_Modulus (Capacity : Count_Type) return Hash_Type is + begin + return To_Prime (Capacity); + end Default_Modulus; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Item : Element_Type) + is + X : Count_Type; + + begin + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + + if Checks and then X = 0 then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + HT_Ops.Free (Container, X); + end Delete; + + procedure Delete + (Container : in out Set; + Position : in out Cursor) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + TC_Check (Container.TC); + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + HT_Ops.Free (Container, Position.Node); + + Position := No_Element; + end Delete; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference + (Target : in out Set; + Source : Set) + is + Tgt_Node, Src_Node : Count_Type; + + Src : Set renames Source'Unrestricted_Access.all; + + TN : Nodes_Type renames Target.Nodes; + SN : Nodes_Type renames Source.Nodes; + + begin + if Target'Address = Source'Address then + HT_Ops.Clear (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + TC_Check (Target.TC); + + if Source.Length < Target.Length then + Src_Node := HT_Ops.First (Source); + while Src_Node /= 0 loop + Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element); + + if Tgt_Node /= 0 then + HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); + HT_Ops.Free (Target, Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Src, Src_Node); + end loop; + + else + Tgt_Node := HT_Ops.First (Target); + while Tgt_Node /= 0 loop + if Is_In (Source, TN (Tgt_Node)) then + declare + X : constant Count_Type := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + HT_Ops.Free (Target, X); + end; + + else + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + end if; + end loop; + end if; + end Difference; + + function Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Left.Length = 0 then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + return Result : Set (Left.Length, To_Prime (Left.Length)) do + Iterate_Left : declare + procedure Process (L_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Count_Type) is + N : Node_Type renames Left.Nodes (L_Node); + X : Count_Type; + B : Boolean; + begin + if not Is_In (Right, N) then + Insert (Result, N.Element, X, B); -- optimize this ??? + pragma Assert (B); + pragma Assert (X > 0); + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left); + end Iterate_Left; + end return; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + declare + S : Set renames Position.Container.all; + N : Node_Type renames S.Nodes (Position.Node); + begin + return N.Element; + end; + end Element; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Find_Equivalent_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean; + pragma Inline (Find_Equivalent_Key); + + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); + + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); + + R_Node : Count_Type := R_HT.Buckets (R_Index); + + RN : Nodes_Type renames R_HT.Nodes; + + begin + loop + if R_Node = 0 then + return False; + end if; + + if Equivalent_Elements (L_Node.Element, RN (R_Node).Element) then + return True; + end if; + + R_Node := Next (R_HT.Nodes (R_Node)); + end loop; + end Find_Equivalent_Key; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); + end Equivalent_Sets; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Cursor) + return Boolean is + + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if Checks and then Right.Node = 0 then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + + -- AI05-0022 requires that a container implementation detect element + -- tampering by a generic actual subprogram. However, the following case + -- falls outside the scope of that AI. Randy Brukardt explained on the + -- ARG list on 2013/02/07 that: + + -- (Begin Quote): + -- But for an operation like "<" [the ordered set analog of + -- Equivalent_Elements], there is no need to "dereference" a cursor + -- after the call to the generic formal parameter function, so nothing + -- bad could happen if tampering is undetected. And the operation can + -- safely return a result without a problem even if an element is + -- deleted from the container. + -- (End Quote). + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + RN : Node_Type renames Right.Container.Nodes (Right.Node); + begin + return Equivalent_Elements (LN.Element, RN.Element); + end; + end Equivalent_Elements; + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean + is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + begin + return Equivalent_Elements (LN.Element, Right); + end; + end Equivalent_Elements; + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean + is + begin + if Checks and then Right.Node = 0 then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert + (Vet (Right), + "Right cursor of Equivalent_Elements is bad"); + + declare + RN : Node_Type renames Right.Container.Nodes (Right.Node); + begin + return Equivalent_Elements (Left, RN.Element); + end; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Type) return Boolean + is + begin + return Equivalent_Elements (Key, Node.Element); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Item : Element_Type) + is + X : Count_Type; + begin + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + HT_Ops.Free (Container, X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + Node : constant Count_Type := + Element_Keys.Find (Container'Unrestricted_Access.all, Item); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end First; + + overriding function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= 0; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Type) return Hash_Type is + begin + return Hash (Node.Element); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.TC); + + Container.Nodes (Position.Node).Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert (Container, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + procedure Allocate_Set_Element (Node : in out Node_Type); + pragma Inline (Allocate_Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new HT_Ops.Generic_Allocate (Allocate_Set_Element); + + --------------------------- + -- Allocate_Set_Element -- + --------------------------- + + procedure Allocate_Set_Element (Node : in out Node_Type) is + begin + Node.Element := New_Item; + end Allocate_Set_Element; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + -- The buckets array length is specified by the user as a discriminant + -- of the container type, so it is possible for the buckets array to + -- have a length of zero. We must check for this case specifically, in + -- order to prevent divide-by-zero errors later, when we compute the + -- buckets array index value for an element, given its hash value. + + if Checks and then Container.Buckets'Length = 0 then + raise Capacity_Error with "No capacity for insertion"; + end if; + + Local_Insert (Container, New_Item, Node, Inserted); + end Insert; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Set; + Source : Set) + is + Tgt_Node : Count_Type; + TN : Nodes_Type renames Target.Nodes; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Length = 0 then + HT_Ops.Clear (Target); + return; + end if; + + TC_Check (Target.TC); + + Tgt_Node := HT_Ops.First (Target); + while Tgt_Node /= 0 loop + if Is_In (Source, TN (Tgt_Node)) then + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + + else + declare + X : constant Count_Type := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + HT_Ops.Free (Target, X); + end; + end if; + end loop; + end Intersection; + + function Intersection (Left, Right : Set) return Set is + C : Count_Type; + + begin + if Left'Address = Right'Address then + return Left; + end if; + + C := Count_Type'Min (Left.Length, Right.Length); + + if C = 0 then + return Empty_Set; + end if; + + return Result : Set (C, To_Prime (C)) do + Iterate_Left : declare + procedure Process (L_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Count_Type) is + N : Node_Type renames Left.Nodes (L_Node); + X : Count_Type; + B : Boolean; + + begin + if Is_In (Right, N) then + Insert (Result, N.Element, X, B); -- optimize ??? + pragma Assert (B); + pragma Assert (X > 0); + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left); + end Iterate_Left; + end return; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ----------- + -- Is_In -- + ----------- + + function Is_In (HT : Set; Key : Node_Type) return Boolean is + begin + return Element_Keys.Find (HT'Unrestricted_Access.all, Key.Element) /= 0; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + Subset_Node : Count_Type; + SN : Nodes_Type renames Subset.Nodes; + + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + Subset_Node := HT_Ops.First (Subset); + while Subset_Node /= 0 loop + if not Is_In (Of_Set, SN (Subset_Node)) then + return False; + end if; + Subset_Node := HT_Ops.Next + (Subset'Unrestricted_Access.all, Subset_Node); + end loop; + + return True; + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Iterate (Container); + end Iterate; + + function Iterate (Container : Set) + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + begin + Busy (Container.TC'Unrestricted_Access.all); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access); + end Iterate; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Target.Assign (Source); + Source.Clear; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Type) return Count_Type is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + HT : Set renames Position.Container.all; + Node : constant Count_Type := HT_Ops.Next (HT, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + Left_Node : Count_Type; + + begin + if Right.Length = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + Left_Node := HT_Ops.First (Left); + while Left_Node /= 0 loop + if Is_In (Right, Left.Nodes (Left_Node)) then + return True; + end if; + Left_Node := HT_Ops.Next (Left'Unrestricted_Access.all, Left_Node); + end loop; + + return False; + end Overlap; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + S : Set renames Position.Container.all; + Lock : With_Lock (S.TC'Unrestricted_Access); + begin + Process (S.Nodes (Position.Node).Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type; + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new HT_Ops.Generic_Allocate (Read_Element); + + procedure Read_Element (Node : in out Node_Type) is + begin + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + Node : Count_Type; + + -- Start of processing for Read_Node + + begin + Allocate (Container, Node); + return Node; + end Read_Node; + + -- Start of processing for Read + + begin + Read_Nodes (Stream, Container); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + is + Node : constant Count_Type := Element_Keys.Find (Container, New_Item); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + TE_Check (Container.TC); + + Container.Nodes (Node).Element := New_Item; + end Replace; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Replace_Element (Container, Position.Node, New_Item); + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + is + begin + if Checks and then Capacity > Container.Capacity then + raise Capacity_Error with "requested capacity is too large"; + end if; + end Reserve_Capacity; + + ------------------ + -- Set_Element -- + ------------------ + + procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is + begin + Node.Element := Item; + end Set_Element; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is + begin + Node.Next := Next; + end Set_Next; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Set; + Source : Set) + is + procedure Process (Source_Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Source_Node : Count_Type) is + N : Node_Type renames Source.Nodes (Source_Node); + X : Count_Type; + B : Boolean; + + begin + if Is_In (Target, N) then + Delete (Target, N.Element); + else + Insert (Target, N.Element, X, B); + pragma Assert (B); + end if; + end Process; + + -- Start of processing for Symmetric_Difference + + begin + if Target'Address = Source'Address then + HT_Ops.Clear (Target); + return; + end if; + + if Target.Length = 0 then + Assign (Target => Target, Source => Source); + return; + end if; + + TC_Check (Target.TC); + + Iterate (Source); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + C : Count_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + C := Left.Length + Right.Length; + + return Result : Set (C, To_Prime (C)) do + Iterate_Left : declare + procedure Process (L_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Count_Type) is + N : Node_Type renames Left.Nodes (L_Node); + X : Count_Type; + B : Boolean; + begin + if not Is_In (Right, N) then + Insert (Result, N.Element, X, B); + pragma Assert (B); + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left); + end Iterate_Left; + + Iterate_Right : declare + procedure Process (R_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (R_Node : Count_Type) is + N : Node_Type renames Right.Nodes (R_Node); + X : Count_Type; + B : Boolean; + begin + if not Is_In (Left, N) then + Insert (Result, N.Element, X, B); + pragma Assert (B); + end if; + end Process; + + -- Start of processing for Iterate_Right + + begin + Iterate (Right); + end Iterate_Right; + end return; + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + X : Count_Type; + B : Boolean; + begin + return Result : Set (1, 1) do + Insert (Result, New_Item, X, B); + pragma Assert (B); + end return; + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union + (Target : in out Set; + Source : Set) + is + procedure Process (Src_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Count_Type) is + N : Node_Type renames Source.Nodes (Src_Node); + X : Count_Type; + B : Boolean; + begin + Insert (Target, N.Element, X, B); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Target.TC); + + -- ??? why is this code commented out ??? + -- declare + -- N : constant Count_Type := Target.Length + Source.Length; + -- begin + -- if N > HT_Ops.Capacity (Target.HT) then + -- HT_Ops.Reserve_Capacity (Target.HT, N); + -- end if; + -- end; + + Iterate (Source); + end Union; + + function Union (Left, Right : Set) return Set is + C : Count_Type; + + begin + if Left'Address = Right'Address then + return Left; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + C := Left.Length + Right.Length; + + return Result : Set (C, To_Prime (C)) do + Assign (Target => Result, Source => Left); + Union (Target => Result, Source => Right); + end return; + end Union; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + declare + S : Set renames Position.Container.all; + N : Nodes_Type renames S.Nodes; + X : Count_Type; + + begin + if S.Length = 0 then + return False; + end if; + + if Position.Node > N'Last then + return False; + end if; + + if N (Position.Node).Next = Position.Node then + return False; + end if; + + X := S.Buckets (Element_Keys.Checked_Index + (S, N (Position.Node).Element)); + + for J in 1 .. S.Length loop + if X = Position.Node then + return True; + end if; + + if X = 0 then + return False; + end if; + + if X = N (X).Next then -- to prevent unnecessary looping + return False; + end if; + + X := N (X).Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Node); + + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write_Nodes (Stream, Container); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Count_Type := + Key_Keys.Find (Container'Unrestricted_Access.all, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Key : Key_Type) + is + X : Count_Type; + + begin + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + + if Checks and then X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + HT_Ops.Free (Container, X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Count_Type := + Key_Keys.Find (Container'Unrestricted_Access.all, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean + is + begin + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); + end Equivalent_Key_Node; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Key : Key_Type) + is + X : Count_Type; + begin + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + HT_Ops.Free (Container, X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then + Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + then + HT_Ops.Delete_Node_At_Index + (Control.Container.all, Control.Index, Control.Old_Pos.Node); + raise Program_Error with "key not preserved in reference"; + end if; + + Control.Container := null; + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + Node : constant Count_Type := + Key_Keys.Find (Container'Unrestricted_Access.all, Key); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + return Key (Position.Container.Nodes (Position.Node).Element); + end Key; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in function Reference_Preserving_Key"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return R : constant Reference_Type := + (Element => N.Element'Unrestricted_Access, + Control => + (Controlled with + Container.TC'Unrestricted_Access, + Container'Unrestricted_Access, + Index => Key_Keys.Index (Container, Key (Position)), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) + do + Lock (Container.TC); + end return; + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + declare + P : constant Cursor := Find (Container, Key); + begin + return R : constant Reference_Type := + (Element => Container.Nodes (Node).Element'Unrestricted_Access, + Control => + (Controlled with + Container.TC'Unrestricted_Access, + Container'Unrestricted_Access, + Index => Key_Keys.Index (Container, Key), + Old_Pos => P, + Old_Hash => Hash (Key))) + do + Lock (Container.TC); + end return; + end; + end Reference_Preserving_Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container, Node, New_Item); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)) + is + Indx : Hash_Type; + N : Nodes_Type renames Container.Nodes; + + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + -- ??? why is this code commented out ??? + -- if HT.Buckets = null + -- or else HT.Buckets'Length = 0 + -- or else HT.Length = 0 + -- or else Position.Node.Next = Position.Node + -- then + -- raise Program_Error with + -- "Position cursor is bad (set is empty)"; + -- end if; + + pragma Assert + (Vet (Position), + "bad cursor in Update_Element_Preserving_Key"); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + E : Element_Type renames N (Position.Node).Element; + K : constant Key_Type := Key (E); + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + -- Record bucket now, in case key is changed + Indx := HT_Ops.Index (Container.Buckets, N (Position.Node)); + + Process (E); + + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + -- Key was modified, so remove this node from set. + + if Container.Buckets (Indx) = Position.Node then + Container.Buckets (Indx) := N (Position.Node).Next; + + else + declare + Prev : Count_Type := Container.Buckets (Indx); + + begin + while N (Prev).Next /= Position.Node loop + Prev := N (Prev).Next; + + if Checks and then Prev = 0 then + raise Program_Error with + "Position cursor is bad (node not found)"; + end if; + end loop; + + N (Prev).Next := N (Position.Node).Next; + end; + end if; + + Container.Length := Container.Length - 1; + HT_Ops.Free (Container, Position.Node); + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + end Generic_Keys; + +end Ada.Containers.Bounded_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cbhase.ads b/gcc/ada/libgnat/a-cbhase.ads new file mode 100644 index 0000000..3bf3699 --- /dev/null +++ b/gcc/ada/libgnat/a-cbhase.ads @@ -0,0 +1,605 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ H A S H E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Hash_Tables; +with Ada.Containers.Helpers; +private with Ada.Streams; +private with Ada.Finalization; use Ada.Finalization; + +generic + type Element_Type is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + with function Equivalent_Elements + (Left, Right : Element_Type) return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Hashed_Sets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + type Set (Capacity : Count_Type; Modulus : Hash_Type) is tagged private + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + -- Set objects declared without an initialization expression are + -- initialized to the value Empty_Set. + + No_Element : constant Cursor; + -- Cursor objects declared without an initialization expression are + -- initialized to the value No_Element. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + -- For each element in Left, set equality attempts to find the equal + -- element in Right; if a search fails, then set equality immediately + -- returns False. The search works by calling Hash to find the bucket in + -- the Right set that corresponds to the Left element. If the bucket is + -- non-empty, the search calls the generic formal element equality operator + -- to compare the element (in Left) to the element of each node in the + -- bucket (in Right); the search terminates when a matching node in the + -- bucket is found, or the nodes in the bucket are exhausted. (Note that + -- element equality is called here, not Equivalent_Elements. Set equality + -- is the only operation in which element equality is used. Compare set + -- equality to Equivalent_Sets, which does call Equivalent_Elements.) + + function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, with the difference that the element in Left is + -- compared to the elements in Right using the generic formal + -- Equivalent_Elements operation instead of element equality. + + function To_Set (New_Item : Element_Type) return Set; + -- Constructs a singleton set comprising New_Element. To_Set calls Hash to + -- determine the bucket for New_Item. + + function Capacity (Container : Set) return Count_Type; + -- Returns the current capacity of the set. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); + -- If the value of the Capacity actual parameter is less or equal to + -- Container.Capacity, then the operation has no effect. Otherwise it + -- raises Capacity_Error (as no expansion of capacity is possible for a + -- bounded form). + + function Default_Modulus (Capacity : Count_Type) return Hash_Type; + -- Returns a modulus value (hash table size) which is optimal for the + -- specified capacity (which corresponds to the maximum number of items). + + function Length (Container : Set) return Count_Type; + -- Returns the number of items in the set + + function Is_Empty (Container : Set) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Set); + -- Removes all of the items from the set + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + -- If New_Item is equivalent (as determined by calling Equivalent_Elements) + -- to the element of the node designated by Position, then New_Element is + -- assigned to that element. Otherwise, it calls Hash to determine the + -- bucket for New_Item. If the bucket is not empty, then it calls + -- Equivalent_Elements for each node in that bucket to determine whether + -- New_Item is equivalent to an element in that bucket. If + -- Equivalent_Elements returns True then Program_Error is raised (because + -- an element may appear only once in the set); otherwise, New_Item is + -- assigned to the node designated by Position, and the node is moved to + -- its new bucket. + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- Calls Process with the element (having only a constant view) of the node + -- designated by the cursor. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + + procedure Assign (Target : in out Set; Source : Set); + -- If Target denotes the same object as Source, then the operation has no + -- effect. If the Target capacity is less than the Source length, then + -- Assign raises Capacity_Error. Otherwise, Assign clears Target and then + -- copies the (active) elements from Source to Target. + + function Copy + (Source : Set; + Capacity : Count_Type := 0; + Modulus : Hash_Type := 0) return Set; + -- Constructs a new set object whose elements correspond to Source. If the + -- Capacity parameter is 0, then the capacity of the result is the same as + -- the length of Source. If the Capacity parameter is equal or greater than + -- the length of Source, then the capacity of the result is the specified + -- value. Otherwise, Copy raises Capacity_Error. If the Modulus parameter + -- is 0, then the modulus of the result is the value returned by a call to + -- Default_Modulus with the capacity parameter determined as above; + -- otherwise the modulus of the result is the specified value. + + procedure Move (Target : in out Set; Source : in out Set); + -- Clears Target (if it's not empty), and then moves (not copies) the + -- buckets array and nodes from Source to Target. + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + -- Conditionally inserts New_Item into the set. If New_Item is already in + -- the set, then Inserted returns False and Position designates the node + -- containing the existing element (which is not modified). If New_Item is + -- not already in the set, then Inserted returns True and Position + -- designates the newly-inserted node containing New_Item. The search for + -- an existing element works as follows. Hash is called to determine + -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements + -- is called to compare New_Item to the element of each node in that + -- bucket. If the bucket is empty, or there were no equivalent elements in + -- the bucket, the search "fails" and the New_Item is inserted in the set + -- (and Inserted returns True); otherwise, the search "succeeds" (and + -- Inserted returns False). + + procedure Insert (Container : in out Set; New_Item : Element_Type); + -- Attempts to insert New_Item into the set, performing the usual insertion + -- search (which involves calling both Hash and Equivalent_Elements); if + -- the search succeeds (New_Item is equivalent to an element already in the + -- set, and so was not inserted), then this operation raises + -- Constraint_Error. (This version of Insert is similar to Replace, but + -- having the opposite exception behavior. It is intended for use when you + -- want to assert that the item is not already in the set.) + + procedure Include (Container : in out Set; New_Item : Element_Type); + -- Attempts to insert New_Item into the set. If an element equivalent to + -- New_Item is already in the set (the insertion search succeeded, and + -- hence New_Item was not inserted), then the value of New_Item is assigned + -- to the existing element. (This insertion operation only raises an + -- exception if cursor tampering occurs. It is intended for use when you + -- want to insert the item in the set, and you don't care whether an + -- equivalent element is already present.) + + procedure Replace (Container : in out Set; New_Item : Element_Type); + -- Searches for New_Item in the set; if the search fails (because an + -- equivalent element was not in the set), then it raises + -- Constraint_Error. Otherwise, the existing element is assigned the value + -- New_Item. (This is similar to Insert, but with the opposite exception + -- behavior. It is intended for use when you want to assert that the item + -- is already in the set.) + + procedure Exclude (Container : in out Set; Item : Element_Type); + -- Searches for Item in the set, and if found, removes its node from the + -- set and then deallocates it. The search works as follows. The operation + -- calls Hash to determine the item's bucket; if the bucket is not empty, + -- it calls Equivalent_Elements to compare Item to the element of each node + -- in the bucket. (This is the deletion analog of Include. It is intended + -- for use when you want to remove the item from the set, but don't care + -- whether the item is already in the set.) + + procedure Delete (Container : in out Set; Item : Element_Type); + -- Searches for Item in the set (which involves calling both Hash and + -- Equivalent_Elements). If the search fails, then the operation raises + -- Constraint_Error. Otherwise it removes the node from the set and then + -- deallocates it. (This is the deletion analog of non-conditional + -- Insert. It is intended for use when you want to assert that the item is + -- already in the set.) + + procedure Delete (Container : in out Set; Position : in out Cursor); + -- Removes the node designated by Position from the set, and then + -- deallocates the node. The operation calls Hash to determine the bucket, + -- and then compares Position to each node in the bucket until there's a + -- match (it does not call Equivalent_Elements). + + procedure Union (Target : in out Set; Source : Set); + -- Iterates over the Source set, and conditionally inserts each element + -- into Target. + + function Union (Left, Right : Set) return Set; + -- The operation first copies the Left set to the result, and then iterates + -- over the Right set to conditionally insert each element into the result. + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + -- Iterates over the Target set (calling First and Next), calling Find to + -- determine whether the element is in Source. If an equivalent element is + -- not found in Source, the element is deleted from Target. + + function Intersection (Left, Right : Set) return Set; + -- Iterates over the Left set, calling Find to determine whether the + -- element is in Right. If an equivalent element is found, it is inserted + -- into the result set. + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + -- Iterates over the Source (calling First and Next), calling Find to + -- determine whether the element is in Target. If an equivalent element is + -- found, it is deleted from Target. + + function Difference (Left, Right : Set) return Set; + -- Iterates over the Left set, calling Find to determine whether the + -- element is in the Right set. If an equivalent element is not found, the + -- element is inserted into the result set. + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + -- The operation iterates over the Source set, searching for the element + -- in Target (calling Hash and Equivalent_Elements). If an equivalent + -- element is found, it is removed from Target; otherwise it is inserted + -- into Target. + + function Symmetric_Difference (Left, Right : Set) return Set; + -- The operation first iterates over the Left set. It calls Find to + -- determine whether the element is in the Right set. If no equivalent + -- element is found, the element from Left is inserted into the result. The + -- operation then iterates over the Right set, to determine whether the + -- element is in the Left set. If no equivalent element is found, the Right + -- element is inserted into the result. + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + -- Iterates over the Left set (calling First and Next), calling Find to + -- determine whether the element is in the Right set. If an equivalent + -- element is found, the operation immediately returns True. The operation + -- returns False if the iteration over Left terminates without finding any + -- equivalent element in Right. + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + -- Iterates over Subset (calling First and Next), calling Find to determine + -- whether the element is in Of_Set. If no equivalent element is found in + -- Of_Set, the operation immediately returns False. The operation returns + -- True if the iteration over Subset terminates without finding an element + -- not in Of_Set (that is, every element in Subset is equivalent to an + -- element in Of_Set). + + function First (Container : Set) return Cursor; + -- Returns a cursor that designates the first non-empty bucket, by + -- searching from the beginning of the buckets array. + + function Next (Position : Cursor) return Cursor; + -- Returns a cursor that designates the node that follows the current one + -- designated by Position. If Position designates the last node in its + -- bucket, the operation calls Hash to compute the index of this bucket, + -- and searches the buckets array for the first non-empty bucket, starting + -- from that index; otherwise, it simply follows the link to the next node + -- in the same bucket. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Find + (Container : Set; + Item : Element_Type) return Cursor; + -- Searches for Item in the set. Find calls Hash to determine the item's + -- bucket; if the bucket is not empty, it calls Equivalent_Elements to + -- compare Item to each element in the bucket. If the search succeeds, Find + -- returns a cursor designating the node containing the equivalent element; + -- otherwise, it returns No_Element. + + function Contains (Container : Set; Item : Element_Type) return Boolean; + -- Equivalent to Find (Container, Item) /= No_Element + + function Equivalent_Elements (Left, Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Elements with the elements of + -- the nodes designated by cursors Left and Right. + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean; + -- Returns the result of calling Equivalent_Elements with element of the + -- node designated by Left and element Right. + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Elements with element Left and + -- the element of the node designated by Right. + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + -- Calls Process for each node in the set + + function Iterate + (Container : Set) + return Set_Iterator_Interfaces.Forward_Iterator'Class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + package Generic_Keys is + + function Key (Position : Cursor) return Key_Type; + -- Applies generic formal operation Key to the element of the node + -- designated by Position. + + function Element (Container : Set; Key : Key_Type) return Element_Type; + -- Searches (as per the key-based Find) for the node containing Key, and + -- returns the associated element. + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + -- Searches (as per the key-based Find) for the node containing Key, and + -- then replaces the element of that node (as per the element-based + -- Replace_Element). + + procedure Exclude (Container : in out Set; Key : Key_Type); + -- Searches for Key in the set, and if found, removes its node from the + -- set and then deallocates it. The search works by first calling Hash + -- (on Key) to determine the bucket; if the bucket is not empty, it + -- calls Equivalent_Keys to compare parameter Key to the value of + -- generic formal operation Key applied to element of each node in the + -- bucket. + + procedure Delete (Container : in out Set; Key : Key_Type); + -- Deletes the node containing Key as per Exclude, with the difference + -- that Constraint_Error is raised if Key is not found. + + function Find (Container : Set; Key : Key_Type) return Cursor; + -- Searches for the node containing Key, and returns a cursor + -- designating the node. The search works by first calling Hash (on Key) + -- to determine the bucket. If the bucket is not empty, the search + -- compares Key to the element of each node in the bucket, and returns + -- the matching node. The comparison itself works by applying the + -- generic formal Key operation to the element of the node, and then + -- calling generic formal operation Equivalent_Keys. + + function Contains (Container : Set; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + -- Calls Process with the element of the node designated by Position, + -- but with the restriction that the key-value of the element is not + -- modified. The operation first makes a copy of the value returned by + -- applying generic formal operation Key on the element of the node, and + -- then calls Process with the element. The operation verifies that the + -- key-part has not been modified by calling generic formal operation + -- Equivalent_Keys to compare the saved key-value to the value returned + -- by applying generic formal operation Key to the post-Process value of + -- element. If the key values compare equal then the operation + -- completes. Otherwise, the node is removed from the map and + -- Program_Error is raised. + + type Reference_Type (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type; + + private + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + package Impl is new Helpers.Generic_Implementation; + + type Reference_Control_Type is + new Impl.Reference_Control_Type with + record + Container : Set_Access; + Index : Hash_Type; + Old_Pos : Cursor; + Old_Hash : Hash_Type; + end record; + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; + + use Ada.Streams; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + end Generic_Keys; + +private + pragma Inline (Next); + + type Node_Type is record + Element : aliased Element_Type; + Next : Count_Type; + end record; + + package HT_Types is + new Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + + type Set (Capacity : Count_Type; Modulus : Hash_Type) is + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + + use HT_Types, HT_Types.Implementation; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + -- Note: If a Cursor object has no explicit initialization expression, + -- it must default initialize to the same value as constant No_Element. + -- The Node component of type Cursor has scalar type Count_Type, so it + -- requires an explicit initialization expression of its own declaration, + -- in order for objects of record type Cursor to properly initialize. + + type Cursor is record + Container : Set_Access; + Node : Count_Type := 0; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := + (Hash_Table_Type with Capacity => 0, Modulus => 0); + + No_Element : constant Cursor := (Container => null, Node => 0); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record + Container : Set_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Bounded_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cbmutr.adb b/gcc/ada/libgnat/a-cbmutr.adb new file mode 100644 index 0000000..f1145de --- /dev/null +++ b/gcc/ada/libgnat/a-cbmutr.adb @@ -0,0 +1,3327 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System; use type System.Address; + +package body Ada.Containers.Bounded_Multiway_Trees is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + use Finalization; + + -------------------- + -- Root_Iterator -- + -------------------- + + type Root_Iterator is abstract new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with + record + Container : Tree_Access; + Subtree : Count_Type; + end record; + + overriding procedure Finalize (Object : in out Root_Iterator); + + ----------------------- + -- Subtree_Iterator -- + ----------------------- + + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; + + overriding function Next + (Object : Subtree_Iterator; + Position : Cursor) return Cursor; + + --------------------- + -- Child_Iterator -- + --------------------- + + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; + + overriding function First (Object : Child_Iterator) return Cursor; + + overriding function Next + (Object : Child_Iterator; + Position : Cursor) return Cursor; + + overriding function Last (Object : Child_Iterator) return Cursor; + + overriding function Previous + (Object : Child_Iterator; + Position : Cursor) return Cursor; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Initialize_Node (Container : in out Tree; Index : Count_Type); + procedure Initialize_Root (Container : in out Tree); + + procedure Allocate_Node + (Container : in out Tree; + Initialize_Element : not null access procedure (Index : Count_Type); + New_Node : out Count_Type); + + procedure Allocate_Node + (Container : in out Tree; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Allocate_Node + (Container : in out Tree; + Stream : not null access Root_Stream_Type'Class; + New_Node : out Count_Type); + + procedure Deallocate_Node + (Container : in out Tree; + X : Count_Type); + + procedure Deallocate_Children + (Container : in out Tree; + Subtree : Count_Type; + Count : in out Count_Type); + + procedure Deallocate_Subtree + (Container : in out Tree; + Subtree : Count_Type; + Count : in out Count_Type); + + function Equal_Children + (Left_Tree : Tree; + Left_Subtree : Count_Type; + Right_Tree : Tree; + Right_Subtree : Count_Type) return Boolean; + + function Equal_Subtree + (Left_Tree : Tree; + Left_Subtree : Count_Type; + Right_Tree : Tree; + Right_Subtree : Count_Type) return Boolean; + + procedure Iterate_Children + (Container : Tree; + Subtree : Count_Type; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Container : Tree; + Subtree : Count_Type; + Process : not null access procedure (Position : Cursor)); + + procedure Copy_Children + (Source : Tree; + Source_Parent : Count_Type; + Target : in out Tree; + Target_Parent : Count_Type; + Count : in out Count_Type); + + procedure Copy_Subtree + (Source : Tree; + Source_Subtree : Count_Type; + Target : in out Tree; + Target_Parent : Count_Type; + Target_Subtree : out Count_Type; + Count : in out Count_Type); + + function Find_In_Children + (Container : Tree; + Subtree : Count_Type; + Item : Element_Type) return Count_Type; + + function Find_In_Subtree + (Container : Tree; + Subtree : Count_Type; + Item : Element_Type) return Count_Type; + + function Child_Count + (Container : Tree; + Parent : Count_Type) return Count_Type; + + function Subtree_Node_Count + (Container : Tree; + Subtree : Count_Type) return Count_Type; + + function Is_Reachable + (Container : Tree; + From, To : Count_Type) return Boolean; + + function Root_Node (Container : Tree) return Count_Type; + + procedure Remove_Subtree + (Container : in out Tree; + Subtree : Count_Type); + + procedure Insert_Subtree_Node + (Container : in out Tree; + Subtree : Count_Type'Base; + Parent : Count_Type; + Before : Count_Type'Base); + + procedure Insert_Subtree_List + (Container : in out Tree; + First : Count_Type'Base; + Last : Count_Type'Base; + Parent : Count_Type; + Before : Count_Type'Base); + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Count_Type; + Before : Count_Type'Base; + Source_Parent : Count_Type); + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Count_Type; + Before : Count_Type'Base; + Source : in out Tree; + Source_Parent : Count_Type); + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Count_Type; + Before : Count_Type'Base; + Source : in out Tree; + Position : in out Count_Type); -- source on input, target on output + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Tree) return Boolean is + begin + if Left.Count /= Right.Count then + return False; + end if; + + if Left.Count = 0 then + return True; + end if; + + return Equal_Children + (Left_Tree => Left, + Left_Subtree => Root_Node (Left), + Right_Tree => Right, + Right_Subtree => Root_Node (Right)); + end "="; + + ------------------- + -- Allocate_Node -- + ------------------- + + procedure Allocate_Node + (Container : in out Tree; + Initialize_Element : not null access procedure (Index : Count_Type); + New_Node : out Count_Type) + is + begin + if Container.Free >= 0 then + New_Node := Container.Free; + pragma Assert (New_Node in Container.Elements'Range); + + -- We always perform the assignment first, before we change container + -- state, in order to defend against exceptions duration assignment. + + Initialize_Element (New_Node); + + Container.Free := Container.Nodes (New_Node).Next; + + else + -- A negative free store value means that the links of the nodes in + -- the free store have not been initialized. In this case, the nodes + -- are physically contiguous in the array, starting at the index that + -- is the absolute value of the Container.Free, and continuing until + -- the end of the array (Nodes'Last). + + New_Node := abs Container.Free; + pragma Assert (New_Node in Container.Elements'Range); + + -- As above, we perform this assignment first, before modifying any + -- container state. + + Initialize_Element (New_Node); + + Container.Free := Container.Free - 1; + + if abs Container.Free > Container.Capacity then + Container.Free := 0; + end if; + end if; + + Initialize_Node (Container, New_Node); + end Allocate_Node; + + procedure Allocate_Node + (Container : in out Tree; + New_Item : Element_Type; + New_Node : out Count_Type) + is + procedure Initialize_Element (Index : Count_Type); + + procedure Initialize_Element (Index : Count_Type) is + begin + Container.Elements (Index) := New_Item; + end Initialize_Element; + + begin + Allocate_Node (Container, Initialize_Element'Access, New_Node); + end Allocate_Node; + + procedure Allocate_Node + (Container : in out Tree; + Stream : not null access Root_Stream_Type'Class; + New_Node : out Count_Type) + is + procedure Initialize_Element (Index : Count_Type); + + procedure Initialize_Element (Index : Count_Type) is + begin + Element_Type'Read (Stream, Container.Elements (Index)); + end Initialize_Element; + + begin + Allocate_Node (Container, Initialize_Element'Access, New_Node); + end Allocate_Node; + + ------------------- + -- Ancestor_Find -- + ------------------- + + function Ancestor_Find + (Position : Cursor; + Item : Element_Type) return Cursor + is + R, N : Count_Type; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- AI-0136 says to raise PE if Position equals the root node. This does + -- not seem correct, as this value is just the limiting condition of the + -- search. For now we omit this check, pending a ruling from the ARG. + -- ??? + -- + -- if Checks and then Is_Root (Position) then + -- raise Program_Error with "Position cursor designates root"; + -- end if; + + R := Root_Node (Position.Container.all); + N := Position.Node; + while N /= R loop + if Position.Container.Elements (N) = Item then + return Cursor'(Position.Container, N); + end if; + + N := Position.Container.Nodes (N).Parent; + end loop; + + return No_Element; + end Ancestor_Find; + + ------------------ + -- Append_Child -- + ------------------ + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Nodes : Tree_Node_Array renames Container.Nodes; + First, Last : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Count = 0 then + return; + end if; + + if Checks and then Container.Count > Container.Capacity - Count then + raise Capacity_Error + with "requested count exceeds available storage"; + end if; + + TC_Check (Container.TC); + + if Container.Count = 0 then + Initialize_Root (Container); + end if; + + Allocate_Node (Container, New_Item, First); + Nodes (First).Parent := Parent.Node; + + Last := First; + for J in Count_Type'(2) .. Count loop + Allocate_Node (Container, New_Item, Nodes (Last).Next); + Nodes (Nodes (Last).Next).Parent := Parent.Node; + Nodes (Nodes (Last).Next).Prev := Last; + + Last := Nodes (Last).Next; + end loop; + + Insert_Subtree_List + (Container => Container, + First => First, + Last => Last, + Parent => Parent.Node, + Before => No_Node); -- means "insert at end of list" + + Container.Count := Container.Count + Count; + end Append_Child; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Tree; Source : Tree) is + Target_Count : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Count then + raise Capacity_Error -- ??? + with "Target capacity is less than Source count"; + end if; + + Target.Clear; -- Checks busy bit + + if Source.Count = 0 then + return; + end if; + + Initialize_Root (Target); + + -- Copy_Children returns the number of nodes that it allocates, but it + -- does this by incrementing the count value passed in, so we must + -- initialize the count before calling Copy_Children. + + Target_Count := 0; + + Copy_Children + (Source => Source, + Source_Parent => Root_Node (Source), + Target => Target, + Target_Parent => Root_Node (Target), + Count => Target_Count); + + pragma Assert (Target_Count = Source.Count); + Target.Count := Source.Count; + end Assign; + + ----------------- + -- Child_Count -- + ----------------- + + function Child_Count (Parent : Cursor) return Count_Type is + begin + if Parent = No_Element then + return 0; + + elsif Parent.Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + return 0; + + else + return Child_Count (Parent.Container.all, Parent.Node); + end if; + end Child_Count; + + function Child_Count + (Container : Tree; + Parent : Count_Type) return Count_Type + is + NN : Tree_Node_Array renames Container.Nodes; + CC : Children_Type renames NN (Parent).Children; + + Result : Count_Type; + Node : Count_Type'Base; + + begin + Result := 0; + Node := CC.First; + while Node > 0 loop + Result := Result + 1; + Node := NN (Node).Next; + end loop; + + return Result; + end Child_Count; + + ----------------- + -- Child_Depth -- + ----------------- + + function Child_Depth (Parent, Child : Cursor) return Count_Type is + Result : Count_Type; + N : Count_Type'Base; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Child = No_Element then + raise Constraint_Error with "Child cursor has no element"; + end if; + + if Checks and then Parent.Container /= Child.Container then + raise Program_Error with "Parent and Child in different containers"; + end if; + + if Parent.Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + pragma Assert (Child = Parent); + return 0; + end if; + + Result := 0; + N := Child.Node; + while N /= Parent.Node loop + Result := Result + 1; + N := Parent.Container.Nodes (N).Parent; + + if Checks and then N < 0 then + raise Program_Error with "Parent is not ancestor of Child"; + end if; + end loop; + + return Result; + end Child_Depth; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Tree) is + Container_Count : constant Count_Type := Container.Count; + Count : Count_Type; + + begin + TC_Check (Container.TC); + + if Container_Count = 0 then + return; + end if; + + Container.Count := 0; + + -- Deallocate_Children returns the number of nodes that it deallocates, + -- but it does this by incrementing the count value that is passed in, + -- so we must first initialize the count return value before calling it. + + Count := 0; + + Deallocate_Children + (Container => Container, + Subtree => Root_Node (Container), + Count => Count); + + pragma Assert (Count = Container_Count); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements (Position.Node)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Tree; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Tree; + Capacity : Count_Type := 0) return Tree + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Count; + elsif Capacity >= Source.Count then + C := Capacity; + elsif Checks then + raise Capacity_Error with "Capacity value too small"; + end if; + + return Target : Tree (Capacity => C) do + Initialize_Root (Target); + + if Source.Count = 0 then + return; + end if; + + Copy_Children + (Source => Source, + Source_Parent => Root_Node (Source), + Target => Target, + Target_Parent => Root_Node (Target), + Count => Target.Count); + + pragma Assert (Target.Count = Source.Count); + end return; + end Copy; + + ------------------- + -- Copy_Children -- + ------------------- + + procedure Copy_Children + (Source : Tree; + Source_Parent : Count_Type; + Target : in out Tree; + Target_Parent : Count_Type; + Count : in out Count_Type) + is + S_Nodes : Tree_Node_Array renames Source.Nodes; + S_Node : Tree_Node_Type renames S_Nodes (Source_Parent); + + T_Nodes : Tree_Node_Array renames Target.Nodes; + T_Node : Tree_Node_Type renames T_Nodes (Target_Parent); + + pragma Assert (T_Node.Children.First <= 0); + pragma Assert (T_Node.Children.Last <= 0); + + T_CC : Children_Type; + C : Count_Type'Base; + + begin + -- We special-case the first allocation, in order to establish the + -- representation invariants for type Children_Type. + + C := S_Node.Children.First; + + if C <= 0 then -- source parent has no children + return; + end if; + + Copy_Subtree + (Source => Source, + Source_Subtree => C, + Target => Target, + Target_Parent => Target_Parent, + Target_Subtree => T_CC.First, + Count => Count); + + T_CC.Last := T_CC.First; + + -- The representation invariants for the Children_Type list have been + -- established, so we can now copy the remaining children of Source. + + C := S_Nodes (C).Next; + while C > 0 loop + Copy_Subtree + (Source => Source, + Source_Subtree => C, + Target => Target, + Target_Parent => Target_Parent, + Target_Subtree => T_Nodes (T_CC.Last).Next, + Count => Count); + + T_Nodes (T_Nodes (T_CC.Last).Next).Prev := T_CC.Last; + T_CC.Last := T_Nodes (T_CC.Last).Next; + + C := S_Nodes (C).Next; + end loop; + + -- We add the newly-allocated children to their parent list only after + -- the allocation has succeeded, in order to preserve invariants of the + -- parent. + + T_Node.Children := T_CC; + end Copy_Children; + + ------------------ + -- Copy_Subtree -- + ------------------ + + procedure Copy_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : Cursor) + is + Target_Subtree : Count_Type; + Target_Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Source = No_Element then + return; + end if; + + if Checks and then Is_Root (Source) then + raise Constraint_Error with "Source cursor designates root"; + end if; + + if Target.Count = 0 then + Initialize_Root (Target); + end if; + + -- Copy_Subtree returns a count of the number of nodes that it + -- allocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Copy_Subtree. + + Target_Count := 0; + + Copy_Subtree + (Source => Source.Container.all, + Source_Subtree => Source.Node, + Target => Target, + Target_Parent => Parent.Node, + Target_Subtree => Target_Subtree, + Count => Target_Count); + + Insert_Subtree_Node + (Container => Target, + Subtree => Target_Subtree, + Parent => Parent.Node, + Before => Before.Node); + + Target.Count := Target.Count + Target_Count; + end Copy_Subtree; + + procedure Copy_Subtree + (Source : Tree; + Source_Subtree : Count_Type; + Target : in out Tree; + Target_Parent : Count_Type; + Target_Subtree : out Count_Type; + Count : in out Count_Type) + is + T_Nodes : Tree_Node_Array renames Target.Nodes; + + begin + -- First we allocate the root of the target subtree. + + Allocate_Node + (Container => Target, + New_Item => Source.Elements (Source_Subtree), + New_Node => Target_Subtree); + + T_Nodes (Target_Subtree).Parent := Target_Parent; + Count := Count + 1; + + -- We now have a new subtree (for the Target tree), containing only a + -- copy of the corresponding element in the Source subtree. Next we copy + -- the children of the Source subtree as children of the new Target + -- subtree. + + Copy_Children + (Source => Source, + Source_Parent => Source_Subtree, + Target => Target, + Target_Parent => Target_Subtree, + Count => Count); + end Copy_Subtree; + + ------------------------- + -- Deallocate_Children -- + ------------------------- + + procedure Deallocate_Children + (Container : in out Tree; + Subtree : Count_Type; + Count : in out Count_Type) + is + Nodes : Tree_Node_Array renames Container.Nodes; + Node : Tree_Node_Type renames Nodes (Subtree); -- parent + CC : Children_Type renames Node.Children; + C : Count_Type'Base; + + begin + while CC.First > 0 loop + C := CC.First; + CC.First := Nodes (C).Next; + + Deallocate_Subtree (Container, C, Count); + end loop; + + CC.Last := 0; + end Deallocate_Children; + + --------------------- + -- Deallocate_Node -- + --------------------- + + procedure Deallocate_Node + (Container : in out Tree; + X : Count_Type) + is + NN : Tree_Node_Array renames Container.Nodes; + pragma Assert (X > 0); + pragma Assert (X <= NN'Last); + + N : Tree_Node_Type renames NN (X); + pragma Assert (N.Parent /= X); -- node is active + + begin + -- The tree container actually contains two lists: one for the "active" + -- nodes that contain elements that have been inserted onto the tree, + -- and another for the "inactive" nodes of the free store, from which + -- nodes are allocated when a new child is inserted in the tree. + + -- We desire that merely declaring a tree object should have only + -- minimal cost; specially, we want to avoid having to initialize the + -- free store (to fill in the links), especially if the capacity of the + -- tree object is large. + + -- The head of the free list is indicated by Container.Free. If its + -- value is non-negative, then the free store has been initialized in + -- the "normal" way: Container.Free points to the head of the list of + -- free (inactive) nodes, and the value 0 means the free list is + -- empty. Each node on the free list has been initialized to point to + -- the next free node (via its Next component), and the value 0 means + -- that this is the last node of the free list. + + -- If Container.Free is negative, then the links on the free store have + -- not been initialized. In this case the link values are implied: the + -- free store comprises the components of the node array started with + -- the absolute value of Container.Free, and continuing until the end of + -- the array (Nodes'Last). + + -- We prefer to lazy-init the free store (in fact, we would prefer to + -- not initialize it at all, because such initialization is an O(n) + -- operation). The time when we need to actually initialize the nodes in + -- the free store is when the node that becomes inactive is not at the + -- end of the active list. The free store would then be discontigous and + -- so its nodes would need to be linked in the traditional way. + + -- It might be possible to perform an optimization here. Suppose that + -- the free store can be represented as having two parts: one comprising + -- the non-contiguous inactive nodes linked together in the normal way, + -- and the other comprising the contiguous inactive nodes (that are not + -- linked together, at the end of the nodes array). This would allow us + -- to never have to initialize the free store, except in a lazy way as + -- nodes become inactive. ??? + + -- When an element is deleted from the list container, its node becomes + -- inactive, and so we set its Parent and Prev components to an + -- impossible value (the index of the node itself), to indicate that it + -- is now inactive. This provides a useful way to detect a dangling + -- cursor reference. + + N.Parent := X; -- Node is deallocated (not on active list) + N.Prev := X; + + if Container.Free >= 0 then + -- The free store has previously been initialized. All we need to do + -- here is link the newly-free'd node onto the free list. + + N.Next := Container.Free; + Container.Free := X; + + elsif X + 1 = abs Container.Free then + -- The free store has not been initialized, and the node becoming + -- inactive immediately precedes the start of the free store. All + -- we need to do is move the start of the free store back by one. + + N.Next := X; -- Not strictly necessary, but marginally safer + Container.Free := Container.Free + 1; + + else + -- The free store has not been initialized, and the node becoming + -- inactive does not immediately precede the free store. Here we + -- first initialize the free store (meaning the links are given + -- values in the traditional way), and then link the newly-free'd + -- node onto the head of the free store. + + -- See the comments above for an optimization opportunity. If the + -- next link for a node on the free store is negative, then this + -- means the remaining nodes on the free store are physically + -- contiguous, starting at the absolute value of that index value. + -- ??? + + Container.Free := abs Container.Free; + + if Container.Free > Container.Capacity then + Container.Free := 0; + + else + for J in Container.Free .. Container.Capacity - 1 loop + NN (J).Next := J + 1; + end loop; + + NN (Container.Capacity).Next := 0; + end if; + + NN (X).Next := Container.Free; + Container.Free := X; + end if; + end Deallocate_Node; + + ------------------------ + -- Deallocate_Subtree -- + ------------------------ + + procedure Deallocate_Subtree + (Container : in out Tree; + Subtree : Count_Type; + Count : in out Count_Type) + is + begin + Deallocate_Children (Container, Subtree, Count); + Deallocate_Node (Container, Subtree); + Count := Count + 1; + end Deallocate_Subtree; + + --------------------- + -- Delete_Children -- + --------------------- + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor) + is + Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + TC_Check (Container.TC); + + if Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + return; + end if; + + -- Deallocate_Children returns a count of the number of nodes that it + -- deallocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Deallocate_Children. + + Count := 0; + + Deallocate_Children (Container, Parent.Node, Count); + pragma Assert (Count <= Container.Count); + + Container.Count := Container.Count - Count; + end Delete_Children; + + ----------------- + -- Delete_Leaf -- + ----------------- + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor) + is + X : Count_Type; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Checks and then not Is_Leaf (Position) then + raise Constraint_Error with "Position cursor does not designate leaf"; + end if; + + TC_Check (Container.TC); + + X := Position.Node; + Position := No_Element; + + Remove_Subtree (Container, X); + Container.Count := Container.Count - 1; + + Deallocate_Node (Container, X); + end Delete_Leaf; + + -------------------- + -- Delete_Subtree -- + -------------------- + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor) + is + X : Count_Type; + Count : Count_Type; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + TC_Check (Container.TC); + + X := Position.Node; + Position := No_Element; + + Remove_Subtree (Container, X); + + -- Deallocate_Subtree returns a count of the number of nodes that it + -- deallocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Deallocate_Subtree. + + Count := 0; + + Deallocate_Subtree (Container, X, Count); + pragma Assert (Count <= Container.Count); + + Container.Count := Container.Count - Count; + end Delete_Subtree; + + ----------- + -- Depth -- + ----------- + + function Depth (Position : Cursor) return Count_Type is + Result : Count_Type; + N : Count_Type'Base; + + begin + if Position = No_Element then + return 0; + end if; + + if Is_Root (Position) then + return 1; + end if; + + Result := 0; + N := Position.Node; + while N >= 0 loop + N := Position.Container.Nodes (N).Parent; + Result := Result + 1; + end loop; + + return Result; + end Depth; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Node = Root_Node (Position.Container.all) + then + raise Program_Error with "Position cursor designates root"; + end if; + + return Position.Container.Elements (Position.Node); + end Element; + + -------------------- + -- Equal_Children -- + -------------------- + + function Equal_Children + (Left_Tree : Tree; + Left_Subtree : Count_Type; + Right_Tree : Tree; + Right_Subtree : Count_Type) return Boolean + is + L_NN : Tree_Node_Array renames Left_Tree.Nodes; + R_NN : Tree_Node_Array renames Right_Tree.Nodes; + + Left_Children : Children_Type renames L_NN (Left_Subtree).Children; + Right_Children : Children_Type renames R_NN (Right_Subtree).Children; + + L, R : Count_Type'Base; + + begin + if Child_Count (Left_Tree, Left_Subtree) + /= Child_Count (Right_Tree, Right_Subtree) + then + return False; + end if; + + L := Left_Children.First; + R := Right_Children.First; + while L > 0 loop + if not Equal_Subtree (Left_Tree, L, Right_Tree, R) then + return False; + end if; + + L := L_NN (L).Next; + R := R_NN (R).Next; + end loop; + + return True; + end Equal_Children; + + ------------------- + -- Equal_Subtree -- + ------------------- + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean + is + begin + if Checks and then Left_Position = No_Element then + raise Constraint_Error with "Left cursor has no element"; + end if; + + if Checks and then Right_Position = No_Element then + raise Constraint_Error with "Right cursor has no element"; + end if; + + if Left_Position = Right_Position then + return True; + end if; + + if Is_Root (Left_Position) then + if not Is_Root (Right_Position) then + return False; + end if; + + if Left_Position.Container.Count = 0 then + return Right_Position.Container.Count = 0; + end if; + + if Right_Position.Container.Count = 0 then + return False; + end if; + + return Equal_Children + (Left_Tree => Left_Position.Container.all, + Left_Subtree => Left_Position.Node, + Right_Tree => Right_Position.Container.all, + Right_Subtree => Right_Position.Node); + end if; + + if Is_Root (Right_Position) then + return False; + end if; + + return Equal_Subtree + (Left_Tree => Left_Position.Container.all, + Left_Subtree => Left_Position.Node, + Right_Tree => Right_Position.Container.all, + Right_Subtree => Right_Position.Node); + end Equal_Subtree; + + function Equal_Subtree + (Left_Tree : Tree; + Left_Subtree : Count_Type; + Right_Tree : Tree; + Right_Subtree : Count_Type) return Boolean + is + begin + if Left_Tree.Elements (Left_Subtree) /= + Right_Tree.Elements (Right_Subtree) + then + return False; + end if; + + return Equal_Children + (Left_Tree => Left_Tree, + Left_Subtree => Left_Subtree, + Right_Tree => Right_Tree, + Right_Subtree => Right_Subtree); + end Equal_Subtree; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Root_Iterator) is + begin + Unbusy (Object.Container.TC); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Tree; + Item : Element_Type) return Cursor + is + Node : Count_Type; + + begin + if Container.Count = 0 then + return No_Element; + end if; + + Node := Find_In_Children (Container, Root_Node (Container), Item); + + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + overriding function First (Object : Subtree_Iterator) return Cursor is + begin + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; + end First; + + overriding function First (Object : Child_Iterator) return Cursor is + begin + return First_Child (Cursor'(Object.Container, Object.Subtree)); + end First; + + ----------------- + -- First_Child -- + ----------------- + + function First_Child (Parent : Cursor) return Cursor is + Node : Count_Type'Base; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + return No_Element; + end if; + + Node := Parent.Container.Nodes (Parent.Node).Children.First; + + if Node <= 0 then + return No_Element; + end if; + + return Cursor'(Parent.Container, Node); + end First_Child; + + ------------------------- + -- First_Child_Element -- + ------------------------- + + function First_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (First_Child (Parent)); + end First_Child_Element; + + ---------------------- + -- Find_In_Children -- + ---------------------- + + function Find_In_Children + (Container : Tree; + Subtree : Count_Type; + Item : Element_Type) return Count_Type + is + N : Count_Type'Base; + Result : Count_Type; + + begin + N := Container.Nodes (Subtree).Children.First; + while N > 0 loop + Result := Find_In_Subtree (Container, N, Item); + + if Result > 0 then + return Result; + end if; + + N := Container.Nodes (N).Next; + end loop; + + return 0; + end Find_In_Children; + + --------------------- + -- Find_In_Subtree -- + --------------------- + + function Find_In_Subtree + (Position : Cursor; + Item : Element_Type) return Cursor + is + Result : Count_Type; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Commented-out pending ruling by ARG. ??? + + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then + -- raise Program_Error with "Position cursor not in container"; + -- end if; + + if Position.Container.Count = 0 then + pragma Assert (Is_Root (Position)); + return No_Element; + end if; + + if Is_Root (Position) then + Result := Find_In_Children + (Container => Position.Container.all, + Subtree => Position.Node, + Item => Item); + + else + Result := Find_In_Subtree + (Container => Position.Container.all, + Subtree => Position.Node, + Item => Item); + end if; + + if Result = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Result); + end Find_In_Subtree; + + function Find_In_Subtree + (Container : Tree; + Subtree : Count_Type; + Item : Element_Type) return Count_Type + is + begin + if Container.Elements (Subtree) = Item then + return Subtree; + end if; + + return Find_In_Children (Container, Subtree, Item); + end Find_In_Subtree; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements (Position.Node)'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position = No_Element then + return False; + end if; + + return Position.Node /= Root_Node (Position.Container.all); + end Has_Element; + + --------------------- + -- Initialize_Node -- + --------------------- + + procedure Initialize_Node + (Container : in out Tree; + Index : Count_Type) + is + begin + Container.Nodes (Index) := + (Parent => No_Node, + Prev => 0, + Next => 0, + Children => (others => 0)); + end Initialize_Node; + + --------------------- + -- Initialize_Root -- + --------------------- + + procedure Initialize_Root (Container : in out Tree) is + begin + Initialize_Node (Container, Root_Node (Container)); + end Initialize_Root; + + ------------------ + -- Insert_Child -- + ------------------ + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + + begin + Insert_Child (Container, Parent, Before, New_Item, Position, Count); + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Nodes : Tree_Node_Array renames Container.Nodes; + First : Count_Type; + Last : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then + raise Constraint_Error with "Parent cursor not parent of Before"; + end if; + end if; + + if Count = 0 then + Position := No_Element; -- Need ruling from ARG ??? + return; + end if; + + if Checks and then Container.Count > Container.Capacity - Count then + raise Capacity_Error + with "requested count exceeds available storage"; + end if; + + TC_Check (Container.TC); + + if Container.Count = 0 then + Initialize_Root (Container); + end if; + + Allocate_Node (Container, New_Item, First); + Nodes (First).Parent := Parent.Node; + + Last := First; + for J in Count_Type'(2) .. Count loop + Allocate_Node (Container, New_Item, Nodes (Last).Next); + Nodes (Nodes (Last).Next).Parent := Parent.Node; + Nodes (Nodes (Last).Next).Prev := Last; + + Last := Nodes (Last).Next; + end loop; + + Insert_Subtree_List + (Container => Container, + First => First, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + Container.Count := Container.Count + Count; + + Position := Cursor'(Parent.Container, First); + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Nodes : Tree_Node_Array renames Container.Nodes; + First : Count_Type; + Last : Count_Type; + + New_Item : Element_Type; + pragma Unmodified (New_Item); + -- OK to reference, see below + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then + Before.Container.Nodes (Before.Node).Parent /= Parent.Node + then + raise Constraint_Error with "Parent cursor not parent of Before"; + end if; + end if; + + if Count = 0 then + Position := No_Element; -- Need ruling from ARG ??? + return; + end if; + + if Checks and then Container.Count > Container.Capacity - Count then + raise Capacity_Error + with "requested count exceeds available storage"; + end if; + + TC_Check (Container.TC); + + if Container.Count = 0 then + Initialize_Root (Container); + end if; + + -- There is no explicit element provided, but in an instance the element + -- type may be a scalar with a Default_Value aspect, or a composite + -- type with such a scalar component, or components with default + -- initialization, so insert the specified number of possibly + -- initialized elements at the given position. + + Allocate_Node (Container, New_Item, First); + Nodes (First).Parent := Parent.Node; + + Last := First; + for J in Count_Type'(2) .. Count loop + Allocate_Node (Container, New_Item, Nodes (Last).Next); + Nodes (Nodes (Last).Next).Parent := Parent.Node; + Nodes (Nodes (Last).Next).Prev := Last; + + Last := Nodes (Last).Next; + end loop; + + Insert_Subtree_List + (Container => Container, + First => First, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + Container.Count := Container.Count + Count; + + Position := Cursor'(Parent.Container, First); + end Insert_Child; + + ------------------------- + -- Insert_Subtree_List -- + ------------------------- + + procedure Insert_Subtree_List + (Container : in out Tree; + First : Count_Type'Base; + Last : Count_Type'Base; + Parent : Count_Type; + Before : Count_Type'Base) + is + NN : Tree_Node_Array renames Container.Nodes; + N : Tree_Node_Type renames NN (Parent); + CC : Children_Type renames N.Children; + + begin + -- This is a simple utility operation to insert a list of nodes + -- (First..Last) as children of Parent. The Before node specifies where + -- the new children should be inserted relative to existing children. + + if First <= 0 then + pragma Assert (Last <= 0); + return; + end if; + + pragma Assert (Last > 0); + pragma Assert (Before <= 0 or else NN (Before).Parent = Parent); + + if CC.First <= 0 then -- no existing children + CC.First := First; + NN (CC.First).Prev := 0; + CC.Last := Last; + NN (CC.Last).Next := 0; + + elsif Before <= 0 then -- means "insert after existing nodes" + NN (CC.Last).Next := First; + NN (First).Prev := CC.Last; + CC.Last := Last; + NN (CC.Last).Next := 0; + + elsif Before = CC.First then + NN (Last).Next := CC.First; + NN (CC.First).Prev := Last; + CC.First := First; + NN (CC.First).Prev := 0; + + else + NN (NN (Before).Prev).Next := First; + NN (First).Prev := NN (Before).Prev; + NN (Last).Next := Before; + NN (Before).Prev := Last; + end if; + end Insert_Subtree_List; + + ------------------------- + -- Insert_Subtree_Node -- + ------------------------- + + procedure Insert_Subtree_Node + (Container : in out Tree; + Subtree : Count_Type'Base; + Parent : Count_Type; + Before : Count_Type'Base) + is + begin + -- This is a simple wrapper operation to insert a single child into the + -- Parent's children list. + + Insert_Subtree_List + (Container => Container, + First => Subtree, + Last => Subtree, + Parent => Parent, + Before => Before); + end Insert_Subtree_Node; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Tree) return Boolean is + begin + return Container.Count = 0; + end Is_Empty; + + ------------- + -- Is_Leaf -- + ------------- + + function Is_Leaf (Position : Cursor) return Boolean is + begin + if Position = No_Element then + return False; + end if; + + if Position.Container.Count = 0 then + pragma Assert (Is_Root (Position)); + return True; + end if; + + return Position.Container.Nodes (Position.Node).Children.First <= 0; + end Is_Leaf; + + ------------------ + -- Is_Reachable -- + ------------------ + + function Is_Reachable + (Container : Tree; + From, To : Count_Type) return Boolean + is + Idx : Count_Type; + + begin + Idx := From; + while Idx >= 0 loop + if Idx = To then + return True; + end if; + + Idx := Container.Nodes (Idx).Parent; + end loop; + + return False; + end Is_Reachable; + + ------------- + -- Is_Root -- + ------------- + + function Is_Root (Position : Cursor) return Boolean is + begin + return + (if Position.Container = null then False + else Position.Node = Root_Node (Position.Container.all)); + end Is_Root; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + if Container.Count = 0 then + return; + end if; + + Iterate_Children + (Container => Container, + Subtree => Root_Node (Container), + Process => Process); + end Iterate; + + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return Iterate_Subtree (Root (Container)); + end Iterate; + + ---------------------- + -- Iterate_Children -- + ---------------------- + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + return; + end if; + + declare + C : Count_Type; + NN : Tree_Node_Array renames Parent.Container.Nodes; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); + + begin + C := NN (Parent.Node).Children.First; + while C > 0 loop + Process (Cursor'(Parent.Container, Node => C)); + C := NN (C).Next; + end loop; + end; + end Iterate_Children; + + procedure Iterate_Children + (Container : Tree; + Subtree : Count_Type; + Process : not null access procedure (Position : Cursor)) + is + NN : Tree_Node_Array renames Container.Nodes; + N : Tree_Node_Type renames NN (Subtree); + C : Count_Type; + + begin + -- This is a helper function to recursively iterate over all the nodes + -- in a subtree, in depth-first fashion. This particular helper just + -- visits the children of this subtree, not the root of the subtree + -- itself. This is useful when starting from the ultimate root of the + -- entire tree (see Iterate), as that root does not have an element. + + C := N.Children.First; + while C > 0 loop + Iterate_Subtree (Container, C, Process); + C := NN (C).Next; + end loop; + end Iterate_Children; + + function Iterate_Children + (Container : Tree; + Parent : Cursor) + return Tree_Iterator_Interfaces.Reversible_Iterator'Class + is + C : constant Tree_Access := Container'Unrestricted_Access; + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= C then + raise Program_Error with "Parent cursor not in container"; + end if; + + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => C, + Subtree => Parent.Node) + do + Busy (C.TC); + end return; + end Iterate_Children; + + --------------------- + -- Iterate_Subtree -- + --------------------- + + function Iterate_Subtree + (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + C : constant Tree_Access := Position.Container; + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => C, + Subtree => Position.Node) + do + Busy (C.TC); + end return; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)) + is + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container.Count = 0 then + pragma Assert (Is_Root (Position)); + return; + end if; + + declare + T : Tree renames Position.Container.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + begin + if Is_Root (Position) then + Iterate_Children (T, Position.Node, Process); + else + Iterate_Subtree (T, Position.Node, Process); + end if; + end; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Container : Tree; + Subtree : Count_Type; + Process : not null access procedure (Position : Cursor)) + is + begin + -- This is a helper function to recursively iterate over all the nodes + -- in a subtree, in depth-first fashion. It first visits the root of the + -- subtree, then visits its children. + + Process (Cursor'(Container'Unrestricted_Access, Subtree)); + Iterate_Children (Container, Subtree, Process); + end Iterate_Subtree; + + ---------- + -- Last -- + ---------- + + overriding function Last (Object : Child_Iterator) return Cursor is + begin + return Last_Child (Cursor'(Object.Container, Object.Subtree)); + end Last; + + ---------------- + -- Last_Child -- + ---------------- + + function Last_Child (Parent : Cursor) return Cursor is + Node : Count_Type'Base; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + return No_Element; + end if; + + Node := Parent.Container.Nodes (Parent.Node).Children.Last; + + if Node <= 0 then + return No_Element; + end if; + + return Cursor'(Parent.Container, Node); + end Last_Child; + + ------------------------ + -- Last_Child_Element -- + ------------------------ + + function Last_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (Last_Child (Parent)); + end Last_Child_Element; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Tree; Source : in out Tree) is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Target.Assign (Source); + Source.Clear; + end Move; + + ---------- + -- Next -- + ---------- + + overriding function Next + (Object : Subtree_Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; + + pragma Assert (Object.Container.Count > 0); + pragma Assert (Position.Node /= Root_Node (Object.Container.all)); + + declare + Nodes : Tree_Node_Array renames Object.Container.Nodes; + Node : Count_Type; + + begin + Node := Position.Node; + + if Nodes (Node).Children.First > 0 then + return Cursor'(Object.Container, Nodes (Node).Children.First); + end if; + + while Node /= Object.Subtree loop + if Nodes (Node).Next > 0 then + return Cursor'(Object.Container, Nodes (Node).Next); + end if; + + Node := Nodes (Node).Parent; + end loop; + + return No_Element; + end; + end Next; + + overriding function Next + (Object : Child_Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; + + pragma Assert (Object.Container.Count > 0); + pragma Assert (Position.Node /= Root_Node (Object.Container.all)); + + return Next_Sibling (Position); + end Next; + + ------------------ + -- Next_Sibling -- + ------------------ + + function Next_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Container.Count = 0 then + pragma Assert (Is_Root (Position)); + return No_Element; + end if; + + declare + T : Tree renames Position.Container.all; + NN : Tree_Node_Array renames T.Nodes; + N : Tree_Node_Type renames NN (Position.Node); + + begin + if N.Next <= 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, N.Next); + end; + end Next_Sibling; + + procedure Next_Sibling (Position : in out Cursor) is + begin + Position := Next_Sibling (Position); + end Next_Sibling; + + ---------------- + -- Node_Count -- + ---------------- + + function Node_Count (Container : Tree) return Count_Type is + begin + -- Container.Count is the number of nodes we have actually allocated. We + -- cache the value specifically so this Node_Count operation can execute + -- in O(1) time, which makes it behave similarly to how the Length + -- selector function behaves for other containers. + -- + -- The cached node count value only describes the nodes we have + -- allocated; the root node itself is not included in that count. The + -- Node_Count operation returns a value that includes the root node + -- (because the RM says so), so we must add 1 to our cached value. + + return 1 + Container.Count; + end Node_Count; + + ------------ + -- Parent -- + ------------ + + function Parent (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Container.Count = 0 then + pragma Assert (Is_Root (Position)); + return No_Element; + end if; + + declare + T : Tree renames Position.Container.all; + NN : Tree_Node_Array renames T.Nodes; + N : Tree_Node_Type renames NN (Position.Node); + + begin + if N.Parent < 0 then + pragma Assert (Position.Node = Root_Node (T)); + return No_Element; + end if; + + return Cursor'(Position.Container, N.Parent); + end; + end Parent; + + ------------------- + -- Prepend_Child -- + ------------------- + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Nodes : Tree_Node_Array renames Container.Nodes; + First, Last : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Count = 0 then + return; + end if; + + if Checks and then Container.Count > Container.Capacity - Count then + raise Capacity_Error + with "requested count exceeds available storage"; + end if; + + TC_Check (Container.TC); + + if Container.Count = 0 then + Initialize_Root (Container); + end if; + + Allocate_Node (Container, New_Item, First); + Nodes (First).Parent := Parent.Node; + + Last := First; + for J in Count_Type'(2) .. Count loop + Allocate_Node (Container, New_Item, Nodes (Last).Next); + Nodes (Nodes (Last).Next).Parent := Parent.Node; + Nodes (Nodes (Last).Next).Prev := Last; + + Last := Nodes (Last).Next; + end loop; + + Insert_Subtree_List + (Container => Container, + First => First, + Last => Last, + Parent => Parent.Node, + Before => Nodes (Parent.Node).Children.First); + + Container.Count := Container.Count + Count; + end Prepend_Child; + + -------------- + -- Previous -- + -------------- + + overriding function Previous + (Object : Child_Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong tree"; + end if; + + return Previous_Sibling (Position); + end Previous; + + ---------------------- + -- Previous_Sibling -- + ---------------------- + + function Previous_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Container.Count = 0 then + pragma Assert (Is_Root (Position)); + return No_Element; + end if; + + declare + T : Tree renames Position.Container.all; + NN : Tree_Node_Array renames T.Nodes; + N : Tree_Node_Type renames NN (Position.Node); + + begin + if N.Prev <= 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, N.Prev); + end; + end Previous_Sibling; + + procedure Previous_Sibling (Position : in out Cursor) is + begin + Position := Previous_Sibling (Position); + end Previous_Sibling; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + declare + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + Process (Element => T.Elements (Position.Node)); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Tree) + is + procedure Read_Children (Subtree : Count_Type); + + function Read_Subtree + (Parent : Count_Type) return Count_Type; + + NN : Tree_Node_Array renames Container.Nodes; + + Total_Count : Count_Type'Base; + -- Value read from the stream that says how many elements follow + + Read_Count : Count_Type'Base; + -- Actual number of elements read from the stream + + ------------------- + -- Read_Children -- + ------------------- + + procedure Read_Children (Subtree : Count_Type) is + Count : Count_Type'Base; + -- number of child subtrees + + CC : Children_Type; + + begin + Count_Type'Read (Stream, Count); + + if Checks and then Count < 0 then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + if Count = 0 then + return; + end if; + + CC.First := Read_Subtree (Parent => Subtree); + CC.Last := CC.First; + + for J in Count_Type'(2) .. Count loop + NN (CC.Last).Next := Read_Subtree (Parent => Subtree); + NN (NN (CC.Last).Next).Prev := CC.Last; + CC.Last := NN (CC.Last).Next; + end loop; + + -- Now that the allocation and reads have completed successfully, it + -- is safe to link the children to their parent. + + NN (Subtree).Children := CC; + end Read_Children; + + ------------------ + -- Read_Subtree -- + ------------------ + + function Read_Subtree + (Parent : Count_Type) return Count_Type + is + Subtree : Count_Type; + + begin + Allocate_Node (Container, Stream, Subtree); + Container.Nodes (Subtree).Parent := Parent; + + Read_Count := Read_Count + 1; + + Read_Children (Subtree); + + return Subtree; + end Read_Subtree; + + -- Start of processing for Read + + begin + Container.Clear; -- checks busy bit + + Count_Type'Read (Stream, Total_Count); + + if Checks and then Total_Count < 0 then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + if Total_Count = 0 then + return; + end if; + + if Checks and then Total_Count > Container.Capacity then + raise Capacity_Error -- ??? + with "node count in stream exceeds container capacity"; + end if; + + Initialize_Root (Container); + + Read_Count := 0; + + Read_Children (Root_Node (Container)); + + if Checks and then Read_Count /= Total_Count then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + Container.Count := Total_Count; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to read tree cursor from stream"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Container.Elements (Position.Node)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + -------------------- + -- Remove_Subtree -- + -------------------- + + procedure Remove_Subtree + (Container : in out Tree; + Subtree : Count_Type) + is + NN : Tree_Node_Array renames Container.Nodes; + N : Tree_Node_Type renames NN (Subtree); + CC : Children_Type renames NN (N.Parent).Children; + + begin + -- This is a utility operation to remove a subtree node from its + -- parent's list of children. + + if CC.First = Subtree then + pragma Assert (N.Prev <= 0); + + if CC.Last = Subtree then + pragma Assert (N.Next <= 0); + CC.First := 0; + CC.Last := 0; + + else + CC.First := N.Next; + NN (CC.First).Prev := 0; + end if; + + elsif CC.Last = Subtree then + pragma Assert (N.Next <= 0); + CC.Last := N.Prev; + NN (CC.Last).Next := 0; + + else + NN (N.Prev).Next := N.Next; + NN (N.Next).Prev := N.Prev; + end if; + end Remove_Subtree; + + ---------------------- + -- Replace_Element -- + ---------------------- + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + TE_Check (Container.TC); + + Container.Elements (Position.Node) := New_Item; + end Replace_Element; + + ------------------------------ + -- Reverse_Iterate_Children -- + ------------------------------ + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Parent.Container.Count = 0 then + pragma Assert (Is_Root (Parent)); + return; + end if; + + declare + NN : Tree_Node_Array renames Parent.Container.Nodes; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); + C : Count_Type; + + begin + C := NN (Parent.Node).Children.Last; + while C > 0 loop + Process (Cursor'(Parent.Container, Node => C)); + C := NN (C).Prev; + end loop; + end; + end Reverse_Iterate_Children; + + ---------- + -- Root -- + ---------- + + function Root (Container : Tree) return Cursor is + begin + return (Container'Unrestricted_Access, Root_Node (Container)); + end Root; + + --------------- + -- Root_Node -- + --------------- + + function Root_Node (Container : Tree) return Count_Type is + pragma Unreferenced (Container); + + begin + return 0; + end Root_Node; + + --------------------- + -- Splice_Children -- + --------------------- + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor) + is + begin + if Checks and then Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then + raise Program_Error + with "Target_Parent cursor not in Target container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error + with "Before cursor not in Target container"; + end if; + + if Checks and then + Target.Nodes (Before.Node).Parent /= Target_Parent.Node + then + raise Constraint_Error + with "Before cursor not child of Target_Parent"; + end if; + end if; + + if Checks and then Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then + raise Program_Error + with "Source_Parent cursor not in Source container"; + end if; + + if Source.Count = 0 then + pragma Assert (Is_Root (Source_Parent)); + return; + end if; + + if Target'Address = Source'Address then + if Target_Parent = Source_Parent then + return; + end if; + + TC_Check (Target.TC); + + if Checks and then Is_Reachable (Container => Target, + From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Container => Target, + Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + return; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + if Target.Count = 0 then + Initialize_Root (Target); + end if; + + Splice_Children + (Target => Target, + Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source => Source, + Source_Parent => Source_Parent.Node); + end Splice_Children; + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor) + is + begin + if Checks and then Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Target_Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Before cursor not in container"; + end if; + + if Checks and then + Container.Nodes (Before.Node).Parent /= Target_Parent.Node + then + raise Constraint_Error + with "Before cursor not child of Target_Parent"; + end if; + end if; + + if Checks and then Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Source_Parent cursor not in container"; + end if; + + if Target_Parent = Source_Parent then + return; + end if; + + pragma Assert (Container.Count > 0); + + TC_Check (Container.TC); + + if Checks and then Is_Reachable (Container => Container, + From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Container => Container, + Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + end Splice_Children; + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Count_Type; + Before : Count_Type'Base; + Source_Parent : Count_Type) + is + NN : Tree_Node_Array renames Container.Nodes; + CC : constant Children_Type := NN (Source_Parent).Children; + C : Count_Type'Base; + + begin + -- This is a utility operation to remove the children from Source parent + -- and insert them into Target parent. + + NN (Source_Parent).Children := Children_Type'(others => 0); + + -- Fix up the Parent pointers of each child to designate its new Target + -- parent. + + C := CC.First; + while C > 0 loop + NN (C).Parent := Target_Parent; + C := NN (C).Next; + end loop; + + Insert_Subtree_List + (Container => Container, + First => CC.First, + Last => CC.Last, + Parent => Target_Parent, + Before => Before); + end Splice_Children; + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Count_Type; + Before : Count_Type'Base; + Source : in out Tree; + Source_Parent : Count_Type) + is + S_NN : Tree_Node_Array renames Source.Nodes; + S_CC : Children_Type renames S_NN (Source_Parent).Children; + + Target_Count, Source_Count : Count_Type; + T, S : Count_Type'Base; + + begin + -- This is a utility operation to copy the children from the Source + -- parent and insert them as children of the Target parent, and then + -- delete them from the Source. (This is not a true splice operation, + -- but it is the best we can do in a bounded form.) The Before position + -- specifies where among the Target parent's exising children the new + -- children are inserted. + + -- Before we attempt the insertion, we must count the sources nodes in + -- order to determine whether the target have enough storage + -- available. Note that calculating this value is an O(n) operation. + + -- Here is an optimization opportunity: iterate of each children the + -- source explicitly, and keep a running count of the total number of + -- nodes. Compare the running total to the capacity of the target each + -- pass through the loop. This is more efficient than summing the counts + -- of child subtree (which is what Subtree_Node_Count does) and then + -- comparing that total sum to the target's capacity. ??? + + -- Here is another possibility. We currently treat the splice as an + -- all-or-nothing proposition: either we can insert all of children of + -- the source, or we raise exception with modifying the target. The + -- price for not causing side-effect is an O(n) determination of the + -- source count. If we are willing to tolerate side-effect, then we + -- could loop over the children of the source, counting that subtree and + -- then immediately inserting it in the target. The issue here is that + -- the test for available storage could fail during some later pass, + -- after children have already been inserted into target. ??? + + Source_Count := Subtree_Node_Count (Source, Source_Parent) - 1; + + if Source_Count = 0 then + return; + end if; + + if Checks and then Target.Count > Target.Capacity - Source_Count then + raise Capacity_Error -- ??? + with "Source count exceeds available storage on Target"; + end if; + + -- Copy_Subtree returns a count of the number of nodes it inserts, but + -- it does this by incrementing the value passed in. Therefore we must + -- initialize the count before calling Copy_Subtree. + + Target_Count := 0; + + S := S_CC.First; + while S > 0 loop + Copy_Subtree + (Source => Source, + Source_Subtree => S, + Target => Target, + Target_Parent => Target_Parent, + Target_Subtree => T, + Count => Target_Count); + + Insert_Subtree_Node + (Container => Target, + Subtree => T, + Parent => Target_Parent, + Before => Before); + + S := S_NN (S).Next; + end loop; + + pragma Assert (Target_Count = Source_Count); + Target.Count := Target.Count + Target_Count; + + -- As with Copy_Subtree, operation Deallocate_Children returns a count + -- of the number of nodes it deallocates, but it works by incrementing + -- the value passed in. We must therefore initialize the count before + -- calling it. + + Source_Count := 0; + + Deallocate_Children (Source, Source_Parent, Source_Count); + pragma Assert (Source_Count = Target_Count); + + Source.Count := Source.Count - Source_Count; + end Splice_Children; + + -------------------- + -- Splice_Subtree -- + -------------------- + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor) + is + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in Target container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in Target container"; + end if; + + if Checks and then Target.Nodes (Before.Node).Parent /= Parent.Node + then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Source'Unrestricted_Access then + raise Program_Error with "Position cursor not in Source container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Target'Address = Source'Address then + if Target.Nodes (Position.Node).Parent = Parent.Node then + if Before = No_Element then + if Target.Nodes (Position.Node).Next <= 0 then -- last child + return; + end if; + + elsif Position.Node = Before.Node then + return; + + elsif Target.Nodes (Position.Node).Next = Before.Node then + return; + end if; + end if; + + TC_Check (Target.TC); + + if Checks and then Is_Reachable (Container => Target, + From => Parent.Node, + To => Position.Node) + then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Target, Position.Node); + + Target.Nodes (Position.Node).Parent := Parent.Node; + Insert_Subtree_Node (Target, Position.Node, Parent.Node, Before.Node); + + return; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + if Target.Count = 0 then + Initialize_Root (Target); + end if; + + Splice_Subtree + (Target => Target, + Parent => Parent.Node, + Before => Before.Node, + Source => Source, + Position => Position.Node); -- modified during call + + Position.Container := Target'Unrestricted_Access; + end Splice_Subtree; + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor) + is + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Container.Nodes (Before.Node).Parent /= Parent.Node + then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + + -- Should this be PE instead? Need ARG confirmation. ??? + + raise Constraint_Error with "Position cursor designates root"; + end if; + + if Container.Nodes (Position.Node).Parent = Parent.Node then + if Before = No_Element then + if Container.Nodes (Position.Node).Next <= 0 then -- last child + return; + end if; + + elsif Position.Node = Before.Node then + return; + + elsif Container.Nodes (Position.Node).Next = Before.Node then + return; + end if; + end if; + + TC_Check (Container.TC); + + if Checks and then Is_Reachable (Container => Container, + From => Parent.Node, + To => Position.Node) + then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Container, Position.Node); + Container.Nodes (Position.Node).Parent := Parent.Node; + Insert_Subtree_Node (Container, Position.Node, Parent.Node, Before.Node); + end Splice_Subtree; + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Count_Type; + Before : Count_Type'Base; + Source : in out Tree; + Position : in out Count_Type) -- Source on input, Target on output + is + Source_Count : Count_Type := Subtree_Node_Count (Source, Position); + pragma Assert (Source_Count >= 1); + + Target_Subtree : Count_Type; + Target_Count : Count_Type; + + begin + -- This is a utility operation to do the heavy lifting associated with + -- splicing a subtree from one tree to another. Note that "splicing" + -- is a bit of a misnomer here in the case of a bounded tree, because + -- the elements must be copied from the source to the target. + + if Checks and then Target.Count > Target.Capacity - Source_Count then + raise Capacity_Error -- ??? + with "Source count exceeds available storage on Target"; + end if; + + -- Copy_Subtree returns a count of the number of nodes it inserts, but + -- it does this by incrementing the value passed in. Therefore we must + -- initialize the count before calling Copy_Subtree. + + Target_Count := 0; + + Copy_Subtree + (Source => Source, + Source_Subtree => Position, + Target => Target, + Target_Parent => Parent, + Target_Subtree => Target_Subtree, + Count => Target_Count); + + pragma Assert (Target_Count = Source_Count); + + -- Now link the newly-allocated subtree into the target. + + Insert_Subtree_Node + (Container => Target, + Subtree => Target_Subtree, + Parent => Parent, + Before => Before); + + Target.Count := Target.Count + Target_Count; + + -- The manipulation of the Target container is complete. Now we remove + -- the subtree from the Source container. + + Remove_Subtree (Source, Position); -- unlink the subtree + + -- As with Copy_Subtree, operation Deallocate_Subtree returns a count of + -- the number of nodes it deallocates, but it works by incrementing the + -- value passed in. We must therefore initialize the count before + -- calling it. + + Source_Count := 0; + + Deallocate_Subtree (Source, Position, Source_Count); + pragma Assert (Source_Count = Target_Count); + + Source.Count := Source.Count - Source_Count; + + Position := Target_Subtree; + end Splice_Subtree; + + ------------------------ + -- Subtree_Node_Count -- + ------------------------ + + function Subtree_Node_Count (Position : Cursor) return Count_Type is + begin + if Position = No_Element then + return 0; + end if; + + if Position.Container.Count = 0 then + pragma Assert (Is_Root (Position)); + return 1; + end if; + + return Subtree_Node_Count (Position.Container.all, Position.Node); + end Subtree_Node_Count; + + function Subtree_Node_Count + (Container : Tree; + Subtree : Count_Type) return Count_Type + is + Result : Count_Type; + Node : Count_Type'Base; + + begin + Result := 1; + Node := Container.Nodes (Subtree).Children.First; + while Node > 0 loop + Result := Result + Subtree_Node_Count (Container, Node); + Node := Container.Nodes (Node).Next; + end loop; + return Result; + end Subtree_Node_Count; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out Tree; + I, J : Cursor) + is + begin + if Checks and then I = No_Element then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor not in container"; + end if; + + if Checks and then Is_Root (I) then + raise Program_Error with "I cursor designates root"; + end if; + + if I = J then -- make this test sooner??? + return; + end if; + + if Checks and then J = No_Element then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor not in container"; + end if; + + if Checks and then Is_Root (J) then + raise Program_Error with "J cursor designates root"; + end if; + + TE_Check (Container.TC); + + declare + EE : Element_Array renames Container.Elements; + EI : constant Element_Type := EE (I.Node); + + begin + EE (I.Node) := EE (J.Node); + EE (J.Node) := EI; + end; + end Swap; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + declare + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + Process (Element => T.Elements (Position.Node)); + end; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Tree) + is + procedure Write_Children (Subtree : Count_Type); + procedure Write_Subtree (Subtree : Count_Type); + + -------------------- + -- Write_Children -- + -------------------- + + procedure Write_Children (Subtree : Count_Type) is + CC : Children_Type renames Container.Nodes (Subtree).Children; + C : Count_Type'Base; + + begin + Count_Type'Write (Stream, Child_Count (Container, Subtree)); + + C := CC.First; + while C > 0 loop + Write_Subtree (C); + C := Container.Nodes (C).Next; + end loop; + end Write_Children; + + ------------------- + -- Write_Subtree -- + ------------------- + + procedure Write_Subtree (Subtree : Count_Type) is + begin + Element_Type'Write (Stream, Container.Elements (Subtree)); + Write_Children (Subtree); + end Write_Subtree; + + -- Start of processing for Write + + begin + Count_Type'Write (Stream, Container.Count); + + if Container.Count = 0 then + return; + end if; + + Write_Children (Root_Node (Container)); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to write tree cursor to stream"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Bounded_Multiway_Trees; diff --git a/gcc/ada/libgnat/a-cbmutr.ads b/gcc/ada/libgnat/a-cbmutr.ads new file mode 100644 index 0000000..a5d7ae3 --- /dev/null +++ b/gcc/ada/libgnat/a-cbmutr.ads @@ -0,0 +1,406 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_MULTIWAY_TREES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Multiway_Trees is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + type Tree (Capacity : Count_Type) is tagged private + with Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Tree); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Tree : constant Tree; + + No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Tree_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean; + + function "=" (Left, Right : Tree) return Boolean; + + function Is_Empty (Container : Tree) return Boolean; + + function Node_Count (Container : Tree) return Count_Type; + + function Subtree_Node_Count (Position : Cursor) return Count_Type; + + function Depth (Position : Cursor) return Count_Type; + + function Is_Root (Position : Cursor) return Boolean; + + function Is_Leaf (Position : Cursor) return Boolean; + + function Root (Container : Tree) return Cursor; + + procedure Clear (Container : in out Tree); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type; + + procedure Assign (Target : in out Tree; Source : Tree); + + function Copy (Source : Tree; Capacity : Count_Type := 0) return Tree; + + procedure Move (Target : in out Tree; Source : in out Tree); + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor); + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor); + + procedure Swap + (Container : in out Tree; + I, J : Cursor); + + function Find + (Container : Tree; + Item : Element_Type) return Cursor; + + function Find_In_Subtree + (Position : Cursor; + Item : Element_Type) return Cursor; + + function Ancestor_Find + (Position : Cursor; + Item : Element_Type) return Cursor; + + function Contains + (Container : Tree; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)); + + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Children + (Container : Tree; + Parent : Cursor) + return Tree_Iterator_Interfaces.Reversible_Iterator'Class; + + function Child_Count (Parent : Cursor) return Count_Type; + + function Child_Depth (Parent, Child : Cursor) return Count_Type; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor); + + procedure Copy_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : Cursor); + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor); + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor); + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor); + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor); + + function Parent (Position : Cursor) return Cursor; + + function First_Child (Parent : Cursor) return Cursor; + + function First_Child_Element (Parent : Cursor) return Element_Type; + + function Last_Child (Parent : Cursor) return Cursor; + + function Last_Child_Element (Parent : Cursor) return Element_Type; + + function Next_Sibling (Position : Cursor) return Cursor; + + function Previous_Sibling (Position : Cursor) return Cursor; + + procedure Next_Sibling (Position : in out Cursor); + + procedure Previous_Sibling (Position : in out Cursor); + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + +private + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + use Ada.Streams; + + No_Node : constant Count_Type'Base := -1; + -- Need to document all global declarations such as this ??? + + -- Following decls also need much more documentation ??? + + type Children_Type is record + First : Count_Type'Base; + Last : Count_Type'Base; + end record; + + type Tree_Node_Type is record + Parent : Count_Type'Base; + Prev : Count_Type'Base; + Next : Count_Type'Base; + Children : Children_Type; + end record; + + type Tree_Node_Array is array (Count_Type range <>) of Tree_Node_Type; + type Element_Array is array (Count_Type range <>) of aliased Element_Type; + + type Tree (Capacity : Count_Type) is tagged record + Nodes : Tree_Node_Array (0 .. Capacity) := (others => <>); + Elements : Element_Array (1 .. Capacity) := (others => <>); + Free : Count_Type'Base := No_Node; + TC : aliased Tamper_Counts; + Count : Count_Type := 0; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Tree); + + for Tree'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Tree); + + for Tree'Read use Read; + + type Tree_Access is access all Tree; + for Tree_Access'Storage_Size use 0; + + type Cursor is record + Container : Tree_Access; + Node : Count_Type'Base := No_Node; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Tree : constant Tree := (Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(others => <>); + +end Ada.Containers.Bounded_Multiway_Trees; diff --git a/gcc/ada/libgnat/a-cborma.adb b/gcc/ada/libgnat/a-cborma.adb new file mode 100644 index 0000000..7dca13b --- /dev/null +++ b/gcc/ada/libgnat/a-cborma.adb @@ -0,0 +1,1637 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Ordered_Maps is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Type) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Type) return Count_Type; + pragma Inline (Left); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right (Node : Node_Type) return Count_Type; + pragma Inline (Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Color (Node : in out Node_Type; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of ""<"" is bad"); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of ""<"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return LN.Key < RN.Key; + end; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of ""<"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + + begin + return LN.Key < Right; + end; + end "<"; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of ""<"" is bad"); + + declare + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return Left < RN.Key; + end; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + function Is_Equal_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node + (L, R : Node_Type) return Boolean is + begin + if L.Key < R.Key then + return False; + + elsif R.Key < L.Key then + return False; + + else + return L.Element = R.Element; + end if; + end Is_Equal_Node_Node; + + -- Start of processing for "=" + + begin + return Is_Equal (Left, Right); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of "">"" is bad"); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of "">"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return RN.Key < LN.Key; + end; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "Left cursor of "">"" is bad"); + + declare + LN : Node_Type renames Left.Container.Nodes (Left.Node); + begin + return Right < LN.Key; + end; + end ">"; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "Right cursor of "">"" is bad"); + + declare + RN : Node_Type renames Right.Container.Nodes (Right.Node); + + begin + return RN.Key < Left; + end; + end ">"; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + procedure Append_Element (Source_Node : Count_Type) is + SN : Node_Type renames Source.Nodes (Source_Node); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Key_Ops.Generic_Unconditional_Insert (Insert_Post); + + procedure Unconditional_Insert_Avec_Hint is + new Key_Ops.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Unconditional_Insert_Sans_Hint); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + + begin + Allocate (Target, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Key := SN.Key; + Node.Element := SN.Element; + end Set_Element; + + Target_Node : Count_Type; + + -- Start of processing for Append_Element + + begin + Unconditional_Insert_Avec_Hint + (Tree => Target, + Hint => 0, + Key => SN.Key, + Node => Target_Node); + end Append_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error + with "Target capacity is less than Source length"; + end if; + + Tree_Operations.Clear_Tree (Target); + Append_Elements (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + Tree_Operations.Clear_Tree (Container); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor in Constant_Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + elsif Checks then + raise Capacity_Error with "Capacity value too small"; + end if; + + return Target : Map (Capacity => C) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Delete is bad"); + + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); + Tree_Operations.Free (Container, Position.Node); + + Position := No_Element; + end Delete; + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Checks and then X = 0 then + raise Constraint_Error with "key not in map"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) is + X : constant Count_Type := Container.First; + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) is + X : constant Count_Type := Container.Last; + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of function Element is bad"); + + return Position.Container.Nodes (Position.Node).Element; + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + begin + if Node = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); + end if; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + begin + if Container.First = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.First); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Maps.First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + begin + if Checks and then Container.First = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.First).Element; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + begin + if Checks and then Container.First = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.First).Key; + end First_Key; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Floor (Container, Key); + begin + if Node = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); + end if; + end Floor; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.TC); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + procedure Assign (Node : in out Node_Type); + pragma Inline (Assign); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Assign); + + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Assign; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with "key already in map"; + end if; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + procedure Assign (Node : in out Node_Type); + pragma Inline (Assign); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Assign); + + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : in out Node_Type) is + New_Item : Element_Type; + pragma Unmodified (New_Item); + -- Default-initialized element (ok to reference, see below) + + begin + Node.Key := Key; + + -- There is no explicit element provided, but in an instance the element + -- type may be a scalar with a Default_Value aspect, or a composite type + -- with such a scalar component or with defaulted components, so insert + -- possibly initialized elements at the given position. + + Node.Element := New_Item; + end Assign; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + -- Left > Right same as Right < Left + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Key; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (Container); + end Iterate; + + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is 0 (as is the case here), this means the iterator object + -- was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : Map; + Start : Cursor) + return Map_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- Iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong map"; + end if; + + pragma Assert (Vet (Container, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is positive (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. (Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration.) + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of function Key is bad"); + + return Position.Container.Nodes (Position.Node).Key; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.Last); + end if; + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Maps.Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + begin + if Checks and then Container.Last = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.Last).Element; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + begin + if Checks and then Container.Last = 0 then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Container.Last).Key; + end Last_Key; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Map; Source : in out Map) is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Target.Assign (Source); + Source.Clear; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of Next is bad"); + + declare + M : Map renames Position.Container.all; + + Node : constant Count_Type := + Tree_Operations.Next (M, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); + end Next; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of Previous is bad"); + + declare + M : Map renames Position.Container.all; + + Node : constant Count_Type := + Tree_Operations.Previous (M, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + function Previous + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong map"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "Position cursor of Query_Element is bad"); + + declare + M : Map renames Position.Container.all; + N : Node_Type renames M.Nodes (Position.Node); + Lock : With_Lock (M.TC'Unrestricted_Access); + begin + Process (N.Key, N.Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Read_Element); + + procedure Read_Elements is + new Tree_Operations.Generic_Read (Allocate); + + ------------------ + -- Read_Element -- + ------------------ + + procedure Read_Element (Node : in out Node_Type) is + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + -- Start of processing for Read + + begin + Read_Elements (Stream, Container); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor in function Reference is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + TE_Check (Container.TC); + + declare + N : Node_Type renames Container.Nodes (Node); + + begin + N.Key := Key; + N.Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + TE_Check (Container.TC); + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Replace_Element is bad"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : in out Node_Type; + Color : Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Update_Element is bad"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + Process (N.Key, N.Element); + end; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Node); + + procedure Write_Nodes is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write_Nodes (Stream, Container); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cborma.ads b/gcc/ada/libgnat/a-cborma.ads new file mode 100644 index 0000000..cced322 --- /dev/null +++ b/gcc/ada/libgnat/a-cborma.ads @@ -0,0 +1,376 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Red_Black_Trees; +private with Ada.Streams; +private with Ada.Finalization; + +generic + type Key_Type is private; + type Element_Type is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Ordered_Maps is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map (Capacity : Count_Type) is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package Map_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Key (Position : Cursor) return Key_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map; + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + procedure Delete_First (Container : in out Map); + + procedure Delete_Last (Container : in out Map); + + function First (Container : Map) return Cursor; + + function First_Element (Container : Map) return Element_Type; + + function First_Key (Container : Map) return Key_Type; + + function Last (Container : Map) return Cursor; + + function Last_Element (Container : Map) return Element_Type; + + function Last_Key (Container : Map) return Key_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + function Iterate + (Container : Map) + return Map_Iterator_Interfaces.Reversible_Iterator'Class; + + function Iterate + (Container : Map; + Start : Cursor) + return Map_Iterator_Interfaces.Reversible_Iterator'Class; + +private + + use Ada.Finalization; + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type is record + Parent : Count_Type; + Left : Count_Type; + Right : Count_Type; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Key : Key_Type; + Element : aliased Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); + + type Map (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; + + use Red_Black_Trees; + use Tree_Types, Tree_Types.Implementation; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_Access; + Node : Count_Type := 0; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := Map'(Tree_Type with Capacity => 0); + + No_Element : constant Cursor := Cursor'(null, 0); + + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Count_Type; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Bounded_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cborse.adb b/gcc/ada/libgnat/a-cborse.adb new file mode 100644 index 0000000..7a25cd7 --- /dev/null +++ b/gcc/ada/libgnat/a-cborse.adb @@ -0,0 +1,2044 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Ordered_Sets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ------------------------------ + -- Access to Fields of Node -- + ------------------------------ + + -- These subprograms provide functional notation for access to fields + -- of a node, and procedural notation for modifying these fields. + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Type) return Count_Type; + pragma Inline (Left); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right (Node : Node_Type) return Count_Type; + pragma Inline (Right); + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Insert_Sans_Hint + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Insert_With_Hint + (Dst_Set : in out Set; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Less_Node_Node); + + procedure Replace_Element + (Container : in out Set; + Index : Count_Type; + Item : Element_Type); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations (Tree_Types); + + use Tree_Operations; + + package Element_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Red_Black_Trees.Generic_Bounded_Set_Operations + (Tree_Operations => Tree_Operations, + Set_Type => Set, + Assign => Assign, + Insert_With_Hint => Insert_With_Hint, + Is_Less => Is_Less_Node_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in ""<"""); + + declare + LN : Nodes_Type renames Left.Container.Nodes; + RN : Nodes_Type renames Right.Container.Nodes; + begin + return LN (Left.Node).Element < RN (Right.Node).Element; + end; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in ""<"""); + + return Left.Container.Nodes (Left.Node).Element < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in ""<"""); + + return Left < Right.Container.Nodes (Right.Node).Element; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + function Is_Equal_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Type) return Boolean is + begin + return L.Element = R.Element; + end Is_Equal_Node_Node; + + -- Start of processing for Is_Equal + + begin + return Is_Equal (Left, Right); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in "">"""); + + -- L > R same as R < L + + declare + LN : Nodes_Type renames Left.Container.Nodes; + RN : Nodes_Type renames Right.Container.Nodes; + begin + return RN (Right.Node).Element < LN (Left.Node).Element; + end; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = 0 then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.all, Right.Node), + "bad Right cursor in "">"""); + + return Right.Container.Nodes (Right.Node).Element < Left; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Checks and then Left.Node = 0 then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.all, Left.Node), + "bad Left cursor in "">"""); + + return Right < Left.Container.Nodes (Left.Node).Element; + end ">"; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + procedure Append_Element (Source_Node : Count_Type) is + SN : Node_Type renames Source.Nodes (Source_Node); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + procedure Unconditional_Insert_Avec_Hint is + new Element_Keys.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Unconditional_Insert_Sans_Hint); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Target, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := SN.Element; + end Set_Element; + + Target_Node : Count_Type; + + -- Start of processing for Append_Element + + begin + Unconditional_Insert_Avec_Hint + (Tree => Target, + Hint => 0, + Key => SN.Element, + Node => Target_Node); + end Append_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error + with "Target capacity is less than Source length"; + end if; + + Target.Clear; + Append_Elements (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := + Element_Keys.Ceiling (Container, Item); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + begin + Tree_Operations.Clear_Tree (Container); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container, Position.Node), + "bad cursor in Constant_Reference"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + elsif Capacity >= Source.Length then + C := Capacity; + elsif Checks then + raise Capacity_Error with "Capacity value too small"; + end if; + + return Target : Set (Capacity => C) do + Assign (Target => Target, Source => Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + TC_Check (Container.TC); + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); + Tree_Operations.Free (Container, Position.Node); + + Position := No_Element; + end Delete; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + Tree_Operations.Delete_Node_Sans_Free (Container, X); + + if Checks and then X = 0 then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Tree_Operations.Free (Container, X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + X : constant Count_Type := Container.First; + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + X : constant Count_Type := Container.Last; + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) + renames Set_Ops.Set_Difference; + + function Difference (Left, Right : Set) return Set + renames Set_Ops.Set_Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Element"); + + return Position.Container.Nodes (Position.Node).Element; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + return (if Left < Right or else Right < Left then False else True); + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is + begin + return (if L.Element < R.Element then False + elsif R.Element < L.Element then False + else True); + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container, Item); + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := Element_Keys.Find (Container, Item); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + return (if Container.First = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Container.First)); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Sets.First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + if Checks and then Container.First = 0 then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Nodes (Container.First).Element; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := Element_Keys.Floor (Container, Item); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Floor; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := + Key_Keys.Ceiling (Container, Key); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Ceiling; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => N.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Checks and then X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + return (if Left < Right or else Right < Left then False else True); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : constant Count_Type := Key_Keys.Find (Container, Key); + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Tree_Operations.Free (Container, X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then + Delete (Control.Container.all, Key (Control.Pos)); + raise Program_Error; + end if; + + Control.Container := null; + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Floor (Container, Key); + begin + return (if Node = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Key (Right.Element) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Key (Right.Element); + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Key"); + + return Key (Position.Container.Nodes (Position.Node).Element); + end Key; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container, Position.Node), + "bad cursor in function Reference_Preserving_Key"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => + (Controlled with + Container.TC'Unrestricted_Access, + Container => Container'Access, + Pos => Position, + Old_Key => new Key_Type'(Key (Position)))) + do + Lock (Container.TC); + end return; + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + return R : constant Reference_Type := + (Element => N.Element'Access, + Control => + (Controlled with + Container.TC'Unrestricted_Access, + Container => Container'Access, + Pos => Find (Container, Key), + Old_Key => new Key_Type'(Key))) + do + Lock (Container.TC); + end return; + end; + end Reference_Preserving_Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container, Node, New_Item); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + N : Node_Type renames Container.Nodes (Position.Node); + E : Element_Type renames N.Element; + K : constant Key_Type := Key (E); + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + Process (E); + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + Tree_Operations.Delete_Node_Sans_Free (Container, Position.Node); + Tree_Operations.Free (Container, Position.Node); + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + end Generic_Keys; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Nodes (Position.Node).Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.TC); + + Container.Nodes (Position.Node).Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert_Sans_Hint + (Container, + New_Item, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Conditional_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := New_Item; + end Set_Element; + + -- Start of processing for Insert_Sans_Hint + + begin + TC_Check (Container.TC); + + Conditional_Insert_Sans_Hint + (Container, + New_Item, + Node, + Inserted); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Set : in out Set; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type) + is + Success : Boolean; + pragma Unreferenced (Success); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Dst_Set, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := Src_Node.Element; + end Set_Element; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Set, + Dst_Hint, + Src_Node.Element, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) + renames Set_Ops.Set_Intersection; + + function Intersection (Left, Right : Set) return Set + renames Set_Ops.Set_Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + -- Compute e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Type) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean + renames Set_Ops.Set_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + S : Set renames Container'Unrestricted_Access.all; + Busy : With_Busy (S.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (S); + end Iterate; + + function Iterate (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is 0 (as is the case here), this means the iterator object + -- was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => 0) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate (Container : Set; Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is positive (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. (Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration.) + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + return (if Container.Last = 0 then No_Element + else Cursor'(Container'Unrestricted_Access, Container.Last)); + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is 0, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is positive, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = 0 then + return Bounded_Ordered_Sets.Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Checks and then Container.Last = 0 then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Nodes (Container.Last).Element; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Target.Assign (Source); + Source.Clear; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Next"); + + declare + Node : constant Count_Type := + Tree_Operations.Next (Position.Container.all, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean + renames Set_Ops.Set_Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Count_Type := + Tree_Operations.Previous (Position.Container.all, Position.Node); + begin + return (if Node = 0 then No_Element + else Cursor'(Position.Container, Node)); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.all, Position.Node), + "bad cursor in Query_Element"); + + declare + S : Set renames Position.Container.all; + Lock : With_Lock (S.TC'Unrestricted_Access); + begin + Process (S.Nodes (Position.Node).Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + procedure Read_Element (Node : in out Node_Type); + pragma Inline (Read_Element); + + procedure Allocate is + new Tree_Operations.Generic_Allocate (Read_Element); + + procedure Read_Elements is + new Tree_Operations.Generic_Read (Allocate); + + ------------------ + -- Read_Element -- + ------------------ + + procedure Read_Element (Node : in out Node_Type) is + begin + Element_Type'Read (Stream, Node.Element); + end Read_Element; + + -- Start of processing for Read + + begin + Read_Elements (Stream, Container); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Count_Type := Element_Keys.Find (Container, New_Item); + + begin + if Checks and then Node = 0 then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + TE_Check (Container.TC); + + Container.Nodes (Node).Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Set; + Index : Count_Type; + Item : Element_Type) + is + pragma Assert (Index /= 0); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + Nodes : Nodes_Type renames Container.Nodes; + Node : Node_Type renames Nodes (Index); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + begin + Node.Element := Item; + Node.Color := Red_Black_Trees.Red; + Node.Parent := 0; + Node.Right := 0; + Node.Left := 0; + return Index; + end New_Node; + + Hint : Count_Type; + Result : Count_Type; + Inserted : Boolean; + Compare : Boolean; + + -- Start of processing for Replace_Element + + begin + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints, described as follows. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + Compare := (if Item < Node.Element then False + elsif Node.Element < Item then False + else True); + end; + + if Compare then + + -- Item is equivalent to the node's element, so we will not have to + -- move the node. + + TE_Check (Container.TC); + + Node.Element := Item; + return; + end if; + + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns 0. + + Hint := Element_Keys.Ceiling (Container, Item); + + if Hint /= 0 then -- Item <= Nodes (Hint).Element + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + Compare := Item < Nodes (Hint).Element; + end; + + -- Item is equivalent to Nodes (Hint).Element + + if Checks and then not Compare then + + -- Ceiling returns an element that is equivalent or greater than + -- Item. If Item is "not less than" the element, then by + -- elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree + -- (specifically, it is less than Nodes (Hint).Element), so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. + + if Hint = Index then + TE_Check (Container.TC); + + Node.Element := Item; + return; + end if; + end if; + + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = 0), or because Item was less than some element at a + -- different place in the tree (Item < Nodes (Hint).Element and Hint /= + -- Index). In either case, we remove Node from the tree and then insert + -- Item into the tree, onto the same Node. + + Tree_Operations.Delete_Node_Sans_Free (Container, Index); + + Local_Insert_With_Hint + (Tree => Container, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); + + pragma Assert (Inserted); + pragma Assert (Result = Index); + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = 0 then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container, Position.Node, New_Item); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Count_Type); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Count_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + S : Set renames Container'Unrestricted_Access.all; + Busy : With_Busy (S.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (S); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) + renames Set_Ops.Set_Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set + renames Set_Ops.Set_Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Node : Count_Type; + Inserted : Boolean; + begin + return S : Set (1) do + Insert_Sans_Hint (S, New_Item, Node, Inserted); + pragma Assert (Inserted); + end return; + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) + renames Set_Ops.Set_Union; + + function Union (Left, Right : Set) return Set + renames Set_Ops.Set_Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Element + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + pragma Inline (Write_Element); + + procedure Write_Elements is + new Tree_Operations.Generic_Write (Write_Element); + + ------------------- + -- Write_Element -- + ------------------- + + procedure Write_Element + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Element; + + -- Start of processing for Write + + begin + Write_Elements (Stream, Container); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cborse.ads b/gcc/ada/libgnat/a-cborse.ads new file mode 100644 index 0000000..e9bd8b4 --- /dev/null +++ b/gcc/ada/libgnat/a-cborse.ads @@ -0,0 +1,450 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ O R D E R E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Containers.Red_Black_Trees; +private with Ada.Streams; +private with Ada.Finalization; + +generic + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Ordered_Sets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set (Capacity : Count_Type) is tagged private + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + + function Equivalent_Sets (Left, Right : Set) return Boolean; + + function To_Set (New_Item : Element_Type) return Set; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Include + (Container : in out Set; + New_Item : Element_Type); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + function Iterate + (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : Set; + Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Floor (Container : Set; Key : Key_Type) return Cursor; + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type; + + private + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Key_Access is access all Key_Type; + + use Ada.Streams; + + package Impl is new Helpers.Generic_Implementation; + + type Reference_Control_Type is + new Impl.Reference_Control_Type with + record + Container : Set_Access; + Pos : Cursor; + Old_Key : Key_Access; + end record; + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + end Generic_Keys; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type is record + Parent : Count_Type; + Left : Count_Type; + Right : Count_Type; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : aliased Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); + + type Set (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; + + use Tree_Types, Tree_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + -- Note: If a Cursor object has no explicit initialization expression, + -- it must default initialize to the same value as constant No_Element. + -- The Node component of type Cursor has scalar type Count_Type, so it + -- requires an explicit initialization expression of its own declaration, + -- in order for objects of record type Cursor to properly initialize. + + type Cursor is record + Container : Set_Access; + Node : Count_Type := 0; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := Set'(Tree_Type with Capacity => 0); + + No_Element : constant Cursor := Cursor'(null, 0); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Count_Type; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Bounded_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cbprqu.adb b/gcc/ada/libgnat/a-cbprqu.adb new file mode 100644 index 0000000..abb2fe9 --- /dev/null +++ b/gcc/ada/libgnat/a-cbprqu.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_PRIORITY_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Bounded_Priority_Queues is + + package body Implementation is + + ------------- + -- Dequeue -- + ------------- + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type) + is + begin + Element := List.Container.First_Element; + List.Container.Delete_First; + end Dequeue; + + procedure Dequeue + (List : in out List_Type; + At_Least : Queue_Priority; + Element : in out Queue_Interfaces.Element_Type; + Success : out Boolean) + is + begin + -- This operation dequeues a high priority item if it exists in the + -- queue. By "high priority" we mean an item whose priority is equal + -- or greater than the value At_Least. The generic formal operation + -- Before has the meaning "has higher priority than". To dequeue an + -- item (meaning that we return True as our Success value), we need + -- as our predicate the equivalent of "has equal or higher priority + -- than", but we cannot say that directly, so we require some logical + -- gymnastics to make it so. + + -- If E is the element at the head of the queue, and symbol ">" + -- refers to the "is higher priority than" function Before, then we + -- derive our predicate as follows: + + -- original: P(E) >= At_Least + -- same as: not (P(E) < At_Least) + -- same as: not (At_Least > P(E)) + -- same as: not Before (At_Least, P(E)) + + -- But that predicate needs to be true in order to successfully + -- dequeue an item. If it's false, it means no item is dequeued, and + -- we return False as the Success value. + + if List.Length = 0 + or else Before (At_Least, + Get_Priority (List.Container.First_Element)) + then + Success := False; + return; + end if; + + List.Dequeue (Element); + Success := True; + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type) + is + P : constant Queue_Priority := Get_Priority (New_Item); + + C : List_Types.Cursor; + use List_Types; + + Count : Count_Type; + + begin + C := List.Container.First; + while Has_Element (C) loop + + -- ??? why is following commented out ??? + -- if Before (P, Get_Priority (List.Constant_Reference (C))) then + + if Before (P, Get_Priority (Element (C))) then + List.Container.Insert (C, New_Item); + exit; + end if; + + Next (C); + end loop; + + if not Has_Element (C) then + List.Container.Append (New_Item); + end if; + + Count := List.Container.Length; + + if Count > List.Max_Length then + List.Max_Length := Count; + end if; + end Enqueue; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element + (List : List_Type) return Queue_Interfaces.Element_Type + is + begin + + -- Use Constant_Reference for this. ??? + + return List.Container.First_Element; + end First_Element; + + ------------ + -- Length -- + ------------ + + function Length (List : List_Type) return Count_Type is + begin + return List.Container.Length; + end Length; + + ---------------- + -- Max_Length -- + ---------------- + + function Max_Length (List : List_Type) return Count_Type is + begin + return List.Max_Length; + end Max_Length; + + end Implementation; + + protected body Queue is + + ------------------ + -- Current_Use -- + ------------------ + + function Current_Use return Count_Type is + begin + return List.Length; + end Current_Use; + + -------------- + -- Dequeue -- + -------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when List.Length > 0 + is + begin + List.Dequeue (Element); + end Dequeue; + + -------------------------------- + -- Dequeue_Only_High_Priority -- + -------------------------------- + + procedure Dequeue_Only_High_Priority + (At_Least : Queue_Priority; + Element : in out Queue_Interfaces.Element_Type; + Success : out Boolean) + is + begin + List.Dequeue (At_Least, Element, Success); + end Dequeue_Only_High_Priority; + + -------------- + -- Enqueue -- + -------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) + when List.Length < Capacity + is + begin + List.Enqueue (New_Item); + end Enqueue; + + --------------- + -- Peak_Use -- + --------------- + + function Peak_Use return Count_Type is + begin + return List.Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Bounded_Priority_Queues; diff --git a/gcc/ada/libgnat/a-cbprqu.ads b/gcc/ada/libgnat/a-cbprqu.ads new file mode 100644 index 0000000..d3e7e0f --- /dev/null +++ b/gcc/ada/libgnat/a-cbprqu.ads @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_PRIORITY_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; + +with Ada.Containers.Synchronized_Queue_Interfaces; +with Ada.Containers.Bounded_Doubly_Linked_Lists; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + type Queue_Priority is private; + + with function Get_Priority + (Element : Queue_Interfaces.Element_Type) return Queue_Priority is <>; + + with function Before + (Left, Right : Queue_Priority) return Boolean is <>; + + Default_Capacity : Count_Type; + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Bounded_Priority_Queues is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + + package Implementation is + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + type List_Type (Capacity : Count_Type) is tagged limited private; + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + At_Least : Queue_Priority; + Element : in out Queue_Interfaces.Element_Type; + Success : out Boolean); + + function First_Element + (List : List_Type) return Queue_Interfaces.Element_Type; + + function Length (List : List_Type) return Count_Type; + + function Max_Length (List : List_Type) return Count_Type; + + private + + -- We need a better data structure here, such as a proper heap. ??? + + pragma Warnings (Off); + -- Otherwise, we get warnings for the uninitialized variable in Insert + -- in Ada.Containers.Bounded_Doubly_Linked_Lists. + package List_Types is new Bounded_Doubly_Linked_Lists + (Element_Type => Queue_Interfaces.Element_Type, + "=" => Queue_Interfaces."="); + pragma Warnings (On); + + type List_Type (Capacity : Count_Type) is tagged limited record + Container : List_Types.List (Capacity); + Max_Length : Count_Type := 0; + end record; + + end Implementation; + + protected type Queue + (Capacity : Count_Type := Default_Capacity; + Ceiling : System.Any_Priority := Default_Ceiling) + with + Priority => Ceiling + is new Queue_Interfaces.Queue with + + overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + -- The priority queue operation Dequeue_Only_High_Priority had been a + -- protected entry in early drafts of AI05-0159, but it was discovered + -- that that operation as specified was not in fact implementable. The + -- operation was changed from an entry to a protected procedure per the + -- ARG meeting in Edinburgh (June 2011), with a different signature and + -- semantics. + + procedure Dequeue_Only_High_Priority + (At_Least : Queue_Priority; + Element : in out Queue_Interfaces.Element_Type; + Success : out Boolean); + + overriding function Current_Use return Count_Type; + + overriding function Peak_Use return Count_Type; + + private + List : Implementation.List_Type (Capacity); + end Queue; + +end Ada.Containers.Bounded_Priority_Queues; diff --git a/gcc/ada/libgnat/a-cbsyqu.adb b/gcc/ada/libgnat/a-cbsyqu.adb new file mode 100644 index 0000000..17dc62c --- /dev/null +++ b/gcc/ada/libgnat/a-cbsyqu.adb @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Bounded_Synchronized_Queues is + + package body Implementation is + + ------------- + -- Dequeue -- + ------------- + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type) + is + EE : Element_Array renames List.Elements; + + begin + Element := EE (List.First); + List.Length := List.Length - 1; + + if List.Length = 0 then + List.First := 0; + List.Last := 0; + + elsif List.First <= List.Last then + List.First := List.First + 1; + + else + List.First := List.First + 1; + + if List.First > List.Capacity then + List.First := 1; + end if; + end if; + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type) + is + begin + if List.Length >= List.Capacity then + raise Capacity_Error with "No capacity for insertion"; + end if; + + if List.Length = 0 then + List.Elements (1) := New_Item; + List.First := 1; + List.Last := 1; + + elsif List.First <= List.Last then + if List.Last < List.Capacity then + List.Elements (List.Last + 1) := New_Item; + List.Last := List.Last + 1; + + else + List.Elements (1) := New_Item; + List.Last := 1; + end if; + + else + List.Elements (List.Last + 1) := New_Item; + List.Last := List.Last + 1; + end if; + + List.Length := List.Length + 1; + + if List.Length > List.Max_Length then + List.Max_Length := List.Length; + end if; + end Enqueue; + + ------------ + -- Length -- + ------------ + + function Length (List : List_Type) return Count_Type is + begin + return List.Length; + end Length; + + ---------------- + -- Max_Length -- + ---------------- + + function Max_Length (List : List_Type) return Count_Type is + begin + return List.Max_Length; + end Max_Length; + + end Implementation; + + protected body Queue is + + ----------------- + -- Current_Use -- + ----------------- + + function Current_Use return Count_Type is + begin + return List.Length; + end Current_Use; + + ------------- + -- Dequeue -- + ------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when List.Length > 0 + is + begin + List.Dequeue (Element); + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) + when List.Length < Capacity + is + begin + List.Enqueue (New_Item); + end Enqueue; + + -------------- + -- Peak_Use -- + -------------- + + function Peak_Use return Count_Type is + begin + return List.Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Bounded_Synchronized_Queues; diff --git a/gcc/ada/libgnat/a-cbsyqu.ads b/gcc/ada/libgnat/a-cbsyqu.ads new file mode 100644 index 0000000..f734a4d --- /dev/null +++ b/gcc/ada/libgnat/a-cbsyqu.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.BOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; +with Ada.Containers.Synchronized_Queue_Interfaces; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + Default_Capacity : Count_Type; + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Bounded_Synchronized_Queues is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + + package Implementation is + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + type List_Type (Capacity : Count_Type) is tagged limited private; + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type); + + function Length (List : List_Type) return Count_Type; + + function Max_Length (List : List_Type) return Count_Type; + + private + + -- Need proper heap data structure here ??? + + type Element_Array is + array (Count_Type range <>) of Queue_Interfaces.Element_Type; + + type List_Type (Capacity : Count_Type) is tagged limited record + First, Last : Count_Type := 0; + Length : Count_Type := 0; + Max_Length : Count_Type := 0; + Elements : Element_Array (1 .. Capacity) := (others => <>); + end record; + + end Implementation; + + protected type Queue + (Capacity : Count_Type := Default_Capacity; + Ceiling : System.Any_Priority := Default_Ceiling) + with + Priority => Ceiling + is new Queue_Interfaces.Queue with + + overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + overriding function Current_Use return Count_Type; + + overriding function Peak_Use return Count_Type; + + private + List : Implementation.List_Type (Capacity); + end Queue; + +end Ada.Containers.Bounded_Synchronized_Queues; diff --git a/gcc/ada/libgnat/a-cdlili.adb b/gcc/ada/libgnat/a-cdlili.adb new file mode 100644 index 0000000..27275aa --- /dev/null +++ b/gcc/ada/libgnat/a-cdlili.adb @@ -0,0 +1,2186 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Doubly_Linked_Lists is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free (X : in out Node_Access); + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access); + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List); + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List; + Position : Node_Access); + + function Vet (Position : Cursor) return Boolean; + -- Checks invariants of the cursor and its designated container, as a + -- simple way of detecting dangling references (see operation Free for a + -- description of the detection mechanism), returning True if all checks + -- pass. Invocations of Vet are used here as the argument of pragma Assert, + -- so the checks are performed only when assertions are enabled. + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + begin + if Left.Length /= Right.Length then + return False; + end if; + + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L : Node_Access := Left.First; + R : Node_Access := Right.First; + begin + for J in 1 .. Left.Length loop + if L.Element /= R.Element then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + end; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out List) is + Src : Node_Access := Container.First; + + begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + + if Src = null then + pragma Assert (Container.Last = null); + pragma Assert (Container.Length = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + pragma Assert (Container.Length > 0); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + Zero_Counts (Container.TC); + + Container.First := new Node_Type'(Src.Element, null, null); + Container.Last := Container.First; + Container.Length := 1; + + Src := Src.Next; + while Src /= null loop + Container.Last.Next := new Node_Type'(Element => Src.Element, + Prev => Container.Last, + Next => null); + Container.Last := Container.Last.Next; + Container.Length := Container.Length + 1; + + Src := Src.Next; + end loop; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + + Node := Source.First; + while Node /= null loop + Target.Append (Node.Element); + Node := Node.Next; + end loop; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + X : Node_Access; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + TC_Check (Container.TC); + + while Container.Length > 1 loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + Container.First.Prev := null; + + Container.Length := Container.Length - 1; + + Free (X); + end loop; + + X := Container.First; + pragma Assert (X = Container.Last); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + + pragma Warnings (Off); + Free (X); + pragma Warnings (On); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : List) return List is + begin + return Target : List do + Target.Assign (Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + X : Node_Access; + + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; -- Post-York behavior + return; + end if; + + if Count = 0 then + Position := No_Element; -- Post-York behavior + return; + end if; + + TC_Check (Container.TC); + + for Index in 1 .. Count loop + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := X.Prev; + Container.Last.Next := null; + + Free (X); + return; + end if; + + Position.Node := X.Next; + + X.Next.Prev := X.Prev; + X.Prev.Next := X.Next; + + Free (X); + end loop; + + -- The following comment is unacceptable, more detail needed ??? + + Position := No_Element; -- Post-York behavior + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + is + X : Node_Access; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + for J in 1 .. Count loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + Container.First.Prev := null; + + Container.Length := Container.Length - 1; + + Free (X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + is + X : Node_Access; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (X.Prev.Next = Container.Last); + + Container.Last := X.Prev; + Container.Last.Next := null; + + Container.Length := Container.Length - 1; + + Free (X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + return Position.Node.Element; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.First; + + else + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + while Node /= null loop + if Node.Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Node.Next; + end loop; + + return No_Element; + end; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.First); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Doubly_Linked_Lists.First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + begin + if Checks and then Container.First = null then + raise Constraint_Error with "list is empty"; + end if; + + return Container.First.Element; + end First_Element; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + -- While a node is in use, as an active link in a list, its Previous and + -- Next components must be null, or designate a different node; this is + -- a node invariant. Before actually deallocating the node, we set both + -- access value components of the node to point to the node itself, thus + -- falsifying the node invariant. Subprogram Vet inspects the value of + -- the node components when interrogating the node, in order to detect + -- whether the cursor's node access value is dangling. + + -- Note that we have no guarantee that the storage for the node isn't + -- modified when it is deallocated, but there are other tests that Vet + -- does if node invariants appear to be satisifed. However, in practice + -- this simple test works well enough, detecting dangling references + -- immediately, without needing further interrogation. + + X.Prev := X; + X.Next := X; + + Deallocate (X); + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Node : Node_Access; + begin + Node := Container.First; + for Idx in 2 .. Container.Length loop + if Node.Next.Element < Node.Element then + return False; + end if; + + Node := Node.Next; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge + (Target : in out List; + Source : in out List) + is + begin + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then + return; + end if; + + if Checks and then Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + + if Checks and then Target.Length > Count_Type'Last - Source.Length + then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); + + LI, RI, RJ : Node_Access; + + begin + LI := Target.First; + RI := Source.First; + while RI /= null loop + pragma Assert (RI.Next = null + or else not (RI.Next.Element < RI.Element)); + + if LI = null then + Splice_Internal (Target, null, Source); + exit; + end if; + + pragma Assert (LI.Next = null + or else not (LI.Next.Element < LI.Element)); + + if RI.Element < LI.Element then + RJ := RI; + RI := RI.Next; + Splice_Internal (Target, LI, Source, RJ); + + else + LI := LI.Next; + end if; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + + procedure Partition (Pivot : Node_Access; Back : Node_Access); + + procedure Sort (Front, Back : Node_Access); + + --------------- + -- Partition -- + --------------- + + procedure Partition (Pivot : Node_Access; Back : Node_Access) is + Node : Node_Access; + + begin + Node := Pivot.Next; + while Node /= Back loop + if Node.Element < Pivot.Element then + declare + Prev : constant Node_Access := Node.Prev; + Next : constant Node_Access := Node.Next; + + begin + Prev.Next := Next; + + if Next = null then + Container.Last := Prev; + else + Next.Prev := Prev; + end if; + + Node.Next := Pivot; + Node.Prev := Pivot.Prev; + + Pivot.Prev := Node; + + if Node.Prev = null then + Container.First := Node; + else + Node.Prev.Next := Node; + end if; + + Node := Next; + end; + + else + Node := Node.Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Node_Access) is + Pivot : constant Node_Access := + (if Front = null then Container.First else Front.Next); + begin + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Sort + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + TC_Check (Container.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Sort (Front => null, Back => null); + end; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Sort; + + end Generic_Sorting; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + First_Node : Node_Access; + New_Node : Node_Access; + + begin + if Before.Container /= null then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Before cursor designates wrong list"; + end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Checks and then Container.Length > Count_Type'Last - Count then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + TC_Check (Container.TC); + + New_Node := new Node_Type'(New_Item, null, null); + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); + + for J in 2 .. Count loop + New_Node := new Node_Type'(New_Item, null, null); + Insert_Internal (Container, Before.Node, New_Node); + end loop; + + Position := Cursor'(Container'Unchecked_Access, First_Node); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + First_Node : Node_Access; + New_Node : Node_Access; + + begin + if Before.Container /= null then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Before cursor designates wrong list"; + end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Checks and then Container.Length > Count_Type'Last - Count then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + TC_Check (Container.TC); + + New_Node := new Node_Type; + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); + + for J in 2 .. Count loop + New_Node := new Node_Type; + Insert_Internal (Container, Before.Node, New_Node); + end loop; + + Position := Cursor'(Container'Unchecked_Access, First_Node); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access) + is + begin + if Container.Length = 0 then + pragma Assert (Before = null); + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + + Container.First := New_Node; + Container.Last := New_Node; + + elsif Before = null then + pragma Assert (Container.Last.Next = null); + + Container.Last.Next := New_Node; + New_Node.Prev := Container.Last; + + Container.Last := New_Node; + + elsif Before = Container.First then + pragma Assert (Container.First.Prev = null); + + Container.First.Prev := New_Node; + New_Node.Next := Container.First; + + Container.First := New_Node; + + else + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + New_Node.Next := Before; + New_Node.Prev := Before.Prev; + + Before.Prev.Next := New_Node; + Before.Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + Node : Node_Access := Container.First; + + begin + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Next; + end loop; + end Iterate; + + function Iterate (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate (Container : List; Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong list"; + end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of items. + -- The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.Last); + end if; + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Doubly_Linked_Lists.Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + begin + if Checks and then Container.Last = null then + raise Constraint_Error with "list is empty"; + end if; + + return Container.Last.Element; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out List; + Source : in out List) + is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Clear (Target); + + Target.First := Source.First; + Source.First := null; + + Target.Last := Source.Last; + Source.Last := null; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + + else + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + Next_Node : constant Node_Access := Position.Node.Next; + begin + if Next_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Next_Node); + end if; + end; + end if; + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong list"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + + else + pragma Assert (Vet (Position), "bad cursor in Previous"); + + declare + Prev_Node : constant Node_Access := Position.Node.Prev; + begin + if Prev_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Prev_Node); + end if; + end; + end if; + end Previous; + + function Previous + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong list"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); + begin + Process (Position.Node.Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List) + is + N : Count_Type'Base; + X : Node_Access; + + begin + Clear (Item); + Count_Type'Base'Read (Stream, N); + + if N = 0 then + return; + end if; + + X := new Node_Type; + + begin + Element_Type'Read (Stream, X.Element); + exception + when others => + Free (X); + raise; + end; + + Item.First := X; + Item.Last := X; + + loop + Item.Length := Item.Length + 1; + exit when Item.Length = N; + + X := new Node_Type; + + begin + Element_Type'Read (Stream, X.Element); + exception + when others => + Free (X); + raise; + end; + + X.Prev := Item.Last; + Item.Last.Next := X; + Item.Last := X; + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Reference"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + TE_Check (Container.TC); + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Position.Node.Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + I : Node_Access := Container.First; + J : Node_Access := Container.Last; + + procedure Swap (L, R : Node_Access); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Node_Access) is + LN : constant Node_Access := L.Next; + LP : constant Node_Access := L.Prev; + + RN : constant Node_Access := R.Next; + RP : constant Node_Access := R.Prev; + + begin + if LP /= null then + LP.Next := R; + end if; + + if RN /= null then + RN.Prev := L; + end if; + + L.Next := RN; + R.Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + L.Prev := R; + R.Next := L; + + else + L.Prev := RP; + RP.Next := L; + + R.Next := LN; + LN.Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + TC_Check (Container.TC); + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := J.Next; + exit when I = J; + + I := I.Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := I.Next; + exit when I = J; + + J := J.Prev; + exit when I = J; + end loop; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.Last; + + else + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + while Node /= null loop + if Node.Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Node.Prev; + end loop; + + return No_Element; + end; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + Node : Node_Access := Container.Last; + + begin + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Prev; + end loop; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); + end if; + + if Target'Address = Source'Address or else Source.Length = 0 then + return; + end if; + + if Checks and then Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + Splice_Internal (Target, Before.Node, Source); + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + begin + if Before.Container /= null then + if Checks and then Before.Container /= Container'Unchecked_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else Position.Node.Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + + TC_Check (Container.TC); + + if Before.Node = null then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := Position.Node.Next; + Container.First.Prev := null; + else + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + Container.Last.Next := Position.Node; + Position.Node.Prev := Container.Last; + + Container.Last := Position.Node; + Container.Last.Next := null; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := Position.Node.Prev; + Container.Last.Next := null; + else + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + Container.First.Prev := Position.Node; + Position.Node.Next := Container.First; + + Container.First := Position.Node; + Container.First.Prev := null; + + return; + end if; + + if Position.Node = Container.First then + Container.First := Position.Node.Next; + Container.First.Prev := null; + + elsif Position.Node = Container.Last then + Container.Last := Position.Node.Prev; + Container.Last.Next := null; + + else + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; + + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + is + begin + if Target'Address = Source'Address then + Splice (Target, Before, Position); + return; + end if; + + if Before.Container /= null then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Source'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Checks and then Target.Length = Count_Type'Last then + raise Constraint_Error with "Target is full"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + Splice_Internal (Target, Before.Node, Source, Position.Node); + Position.Container := Target'Unchecked_Access; + end Splice; + + --------------------- + -- Splice_Internal -- + --------------------- + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List) + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases disposed of. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Target.Length <= Count_Type'Last - Source.Length); + + if Target.Length = 0 then + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + pragma Assert (Before = null); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before = Target.First then + pragma Assert (Target.First.Prev = null); + + Source.Last.Next := Target.First; + Target.First.Prev := Source.Last; + + Target.First := Source.First; + + else + pragma Assert (Target.Length >= 2); + + Before.Prev.Next := Source.First; + Source.First.Prev := Before.Prev; + + Before.Prev := Source.Last; + Source.Last.Next := Before; + end if; + + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice_Internal; + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; -- node of Target + Source : in out List; + Position : Node_Access) -- node of Source + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Target.Length < Count_Type'Last); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Position /= null); + + if Position = Source.First then + Source.First := Position.Next; + + if Position = Source.Last then + pragma Assert (Source.First = null); + pragma Assert (Source.Length = 1); + Source.Last := null; + + else + Source.First.Prev := null; + end if; + + elsif Position = Source.Last then + pragma Assert (Source.Length >= 2); + Source.Last := Position.Prev; + Source.Last.Next := null; + + else + pragma Assert (Source.Length >= 3); + Position.Prev.Next := Position.Next; + Position.Next.Prev := Position.Prev; + end if; + + if Target.Length = 0 then + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + pragma Assert (Before = null); + + Target.First := Position; + Target.Last := Position; + + Target.First.Prev := null; + Target.Last.Next := null; + + elsif Before = null then + pragma Assert (Target.Last.Next = null); + Target.Last.Next := Position; + Position.Prev := Target.Last; + + Target.Last := Position; + Target.Last.Next := null; + + elsif Before = Target.First then + pragma Assert (Target.First.Prev = null); + Target.First.Prev := Position; + Position.Next := Target.First; + + Target.First := Position; + Target.First.Prev := null; + + else + pragma Assert (Target.Length >= 2); + Before.Prev.Next := Position; + Position.Prev := Before.Prev; + + Before.Prev := Position; + Position.Next := Before; + end if; + + Target.Length := Target.Length + 1; + Source.Length := Source.Length - 1; + end Splice_Internal; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if Checks and then I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if Checks and then J.Container /= Container'Unchecked_Access then + raise Program_Error with "J cursor designates wrong container"; + end if; + + if I.Node = J.Node then + return; + end if; + + TE_Check (Container.TC); + + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + declare + EI : Element_Type renames I.Node.Element; + EJ : Element_Type renames J.Node.Element; + + EI_Copy : constant Element_Type := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if Checks and then I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if Checks and then J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor designates wrong container"; + end if; + + if I.Node = J.Node then + return; + end if; + + TC_Check (Container.TC); + + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + + declare + I_Next : constant Cursor := Next (I); + + begin + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + declare + J_Next : constant Cursor := Next (J); + + begin + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end; + end if; + end; + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Process (Position.Node.Element); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + -- An invariant of a node is that its Previous and Next components can + -- be null, or designate a different node. Operation Free sets the + -- access value components of the node to designate the node itself + -- before actually deallocating the node, thus deliberately violating + -- the node invariant. This gives us a simple way to detect a dangling + -- reference to a node. + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Prev = Position.Node then + return False; + end if; + + -- In practice the tests above will detect most instances of a dangling + -- reference. If we get here, it means that the invariants of the + -- designated node are satisfied (they at least appear to be satisfied), + -- so we perform some more tests, to determine whether invariants of the + -- designated list are satisfied too. + + declare + L : List renames Position.Container.all; + + begin + if L.Length = 0 then + return False; + end if; + + if L.First = null then + return False; + end if; + + if L.Last = null then + return False; + end if; + + if L.First.Prev /= null then + return False; + end if; + + if L.Last.Next /= null then + return False; + end if; + + if Position.Node.Prev = null and then Position.Node /= L.First then + return False; + end if; + + pragma Assert + (Position.Node.Prev /= null or else Position.Node = L.First); + + if Position.Node.Next = null and then Position.Node /= L.Last then + return False; + end if; + + pragma Assert + (Position.Node.Next /= null + or else Position.Node = L.Last); + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if L.First.Next = null then + return False; + end if; + + if L.Last.Prev = null then + return False; + end if; + + if L.First.Next.Prev /= L.First then + return False; + end if; + + if L.Last.Prev.Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if L.First.Next /= L.Last then + return False; + elsif L.Last.Prev /= L.First then + return False; + else + return True; + end if; + end if; + + if L.First.Next = L.Last then + return False; + end if; + + if L.Last.Prev = L.First then + return False; + end if; + + -- Eliminate earlier possibility + + if Position.Node = L.First then + return True; + end if; + + pragma Assert (Position.Node.Prev /= null); + + -- Eliminate earlier possibility + + if Position.Node = L.Last then + return True; + end if; + + pragma Assert (Position.Node.Next /= null); + + if Position.Node.Next.Prev /= Position.Node then + return False; + end if; + + if Position.Node.Prev.Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if L.First.Next /= Position.Node then + return False; + elsif L.Last.Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List) + is + Node : Node_Access; + + begin + Count_Type'Base'Write (Stream, Item.Length); + + Node := Item.First; + while Node /= null loop + Element_Type'Write (Stream, Node.Element); + Node := Node.Next; + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cdlili.ads b/gcc/ada/libgnat/a-cdlili.ads new file mode 100644 index 0000000..e6d587a --- /dev/null +++ b/gcc/ada/libgnat/a-cdlili.ads @@ -0,0 +1,406 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . D O U B L Y _ L I N K E D _ L I S T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Doubly_Linked_Lists is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type List is tagged private + with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package List_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : List) return Boolean; + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out List; Source : List); + + function Copy (Source : List) return List; + + procedure Move + (Target : in out List; + Source : in out List); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out List); + + function Iterate (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'Class; + + function Iterate (Container : List; Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'Class; + + procedure Swap + (Container : in out List; + I, J : Cursor); + + procedure Swap_Links + (Container : in out List; + I, J : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is + limited record + Element : aliased Element_Type; + Next : Node_Access; + Prev : Node_Access; + end record; + + use Ada.Finalization; + use Ada.Streams; + + type List is + new Controlled with record + First : Node_Access := null; + Last : Node_Access := null; + Length : Count_Type := 0; + TC : aliased Tamper_Counts; + end record; + + overriding procedure Adjust (Container : in out List); + + overriding procedure Finalize (Container : in out List) renames Clear; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List); + + for List'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List); + + for List'Write use Write; + + type List_Access is access all List; + for List_Access'Storage_Size use 0; + + type Cursor is + record + Container : List_Access; + Node : Node_Access; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_List : constant List := (Controlled with others => <>); + + No_Element : constant Cursor := Cursor'(null, null); + + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfdlli.adb b/gcc/ada/libgnat/a-cfdlli.adb new file mode 100644 index 0000000..0b4674d --- /dev/null +++ b/gcc/ada/libgnat/a-cfdlli.adb @@ -0,0 +1,1894 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Formal_Doubly_Linked_Lists with + SPARK_Mode => Off +is + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Free (Container : in out List; X : Count_Type); + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type); + + function Vet (L : List; Position : Cursor) return Boolean; + + --------- + -- "=" -- + --------- + + function "=" (Left : List; Right : List) return Boolean is + LI : Count_Type; + RI : Count_Type; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + LI := Left.First; + RI := Left.First; + while LI /= 0 loop + if Left.Nodes (LI).Element /= Right.Nodes (LI).Element then + return False; + end if; + + LI := Left.Nodes (LI).Next; + RI := Right.Nodes (RI).Next; + end loop; + + return True; + end "="; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Container : in out List; + New_Item : Element_Type; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + N (New_Node).Element := New_Item; + Container.Free := N (New_Node).Next; + + else + New_Node := abs Container.Free; + N (New_Node).Element := New_Item; + Container.Free := Container.Free - 1; + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out List; New_Item : Element_Type) is + begin + Insert (Container, No_Element, New_Item, 1); + end Append; + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + N : Node_Array renames Source.Nodes; + J : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + Clear (Target); + + J := Source.First; + while J /= 0 loop + Append (Target, N (J).Element, 1); + J := N (J).Next; + end loop; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + return; + end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + while Container.Length > 1 loop + X := Container.First; + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + + X := Container.First; + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container, X); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : List; + Capacity : Count_Type := 0) return List + is + C : constant Count_Type := Count_Type'Max (Source.Capacity, Capacity); + N : Count_Type; + P : List (C); + + begin + if 0 < Capacity and then Capacity < Source.Capacity then + raise Capacity_Error; + end if; + + N := 1; + while N <= Source.Capacity loop + P.Nodes (N).Prev := Source.Nodes (N).Prev; + P.Nodes (N).Next := Source.Nodes (N).Next; + P.Nodes (N).Element := Source.Nodes (N).Element; + N := N + 1; + end loop; + + P.Free := Source.Free; + P.Length := Source.Length; + P.First := Source.First; + P.Last := Source.Last; + + if P.Free >= 0 then + N := Source.Capacity + 1; + while N <= C loop + Free (P, N); + N := N + 1; + end loop; + end if; + + return P; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out List; Position : in out Cursor) is + begin + Delete + (Container => Container, + Position => Position, + Count => 1); + end Delete; + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if not Has_Element (Container => Container, + Position => Position) + then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in Delete"); + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; + + if Count = 0 then + Position := No_Element; + return; + end if; + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container, X); + return; + end if; + + Position.Node := N (X).Next; + pragma Assert (N (Position.Node).Prev >= 0); + + N (N (X).Next).Prev := N (X).Prev; + N (N (X).Prev).Next := N (X).Next; + + Free (Container, X); + end loop; + + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out List) is + begin + Delete_First + (Container => Container, + Count => 1); + end Delete_First; + + procedure Delete_First (Container : in out List; Count : Count_Type) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + for J in 1 .. Count loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out List) is + begin + Delete_Last + (Container => Container, + Count => 1); + end Delete_Last; + + procedure Delete_Last (Container : in out List; Count : Count_Type) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : List; + Position : Cursor) return Element_Type + is + begin + if not Has_Element (Container => Container, Position => Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + return Container.Nodes (Position.Node).Element; + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + From : Count_Type := Position.Node; + + begin + if From = 0 and Container.Length = 0 then + return No_Element; + end if; + + if From = 0 then + From := Container.First; + end if; + + if Position.Node /= 0 and then not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + while From /= 0 loop + if Container.Nodes (From).Element = Item then + return (Node => From); + end if; + + From := Container.Nodes (From).Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + + return (Node => Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + F : constant Count_Type := Container.First; + + begin + if F = 0 then + raise Constraint_Error with "list is empty"; + else + return Container.Nodes (F).Element; + end if; + end First_Element; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ---------------------------- + -- Lift_Abstraction_Level -- + ---------------------------- + + procedure Lift_Abstraction_Level (Container : List) is null; + + ------------------------- + -- M_Elements_In_Union -- + ------------------------- + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + is + Elem : Element_Type; + + begin + for Index in 1 .. M.Length (Container) loop + Elem := Element (Container, Index); + + if not M.Contains (Left, 1, M.Length (Left), Elem) + and then not M.Contains (Right, 1, M.Length (Right), Elem) + then + return False; + end if; + end loop; + + return True; + end M_Elements_In_Union; + + ------------------------- + -- M_Elements_Included -- + ------------------------- + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Positive_Count_Type := 1; + L_Lst : Count_Type; + Right : M.Sequence; + R_Fst : Positive_Count_Type := 1; + R_Lst : Count_Type) return Boolean + is + begin + for I in L_Fst .. L_Lst loop + declare + Found : Boolean := False; + J : Count_Type := R_Fst - 1; + + begin + while not Found and J < R_Lst loop + J := J + 1; + if Element (Left, I) = Element (Right, J) then + Found := True; + end if; + end loop; + + if not Found then + return False; + end if; + end; + end loop; + + return True; + end M_Elements_Included; + + ------------------------- + -- M_Elements_Reversed -- + ------------------------- + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + is + L : constant Count_Type := M.Length (Left); + + begin + if L /= M.Length (Right) then + return False; + end if; + + for I in 1 .. L loop + if Element (Left, I) /= Element (Right, L - I + 1) then + return False; + end if; + end loop; + + return True; + end M_Elements_Reversed; + + ------------------------ + -- M_Elements_Swapted -- + ------------------------ + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Positive_Count_Type; + Y : Positive_Count_Type) return Boolean + is + begin + if M.Length (Left) /= M.Length (Right) + or else Element (Left, X) /= Element (Right, Y) + or else Element (Left, Y) /= Element (Right, X) + then + return False; + end if; + + for I in 1 .. M.Length (Left) loop + if I /= X and then I /= Y + and then Element (Left, I) /= Element (Right, I) + then + return False; + end if; + end loop; + + return True; + end M_Elements_Swapped; + + ----------- + -- Model -- + ----------- + + function Model (Container : List) return M.Sequence is + Position : Count_Type := Container.First; + R : M.Sequence; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := M.Add (R, Container.Nodes (Position).Element); + Position := Container.Nodes (Position).Next; + end loop; + + return R; + end Model; + + ----------------------- + -- Mapping_Preserved -- + ----------------------- + + function Mapping_Preserved + (M_Left : M.Sequence; + M_Right : M.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + is + begin + for C of P_Left loop + if not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > M.Length (M_Left) + or else P.Get (P_Right, C) > M.Length (M_Right) + or else M.Get (M_Left, P.Get (P_Left, C)) /= + M.Get (M_Right, P.Get (P_Right, C)) + then + return False; + end if; + end loop; + + for C of P_Right loop + if not P.Has_Key (P_Left, C) then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved; + + ------------------------- + -- P_Positions_Shifted -- + ------------------------- + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + Count + then + return False; + end if; + + else + if P.Has_Key (Small, Cu) then + return False; + end if; + end if; + end; + end loop; + + return True; + end P_Positions_Shifted; + + ------------------------- + -- P_Positions_Swapped -- + ------------------------- + + function P_Positions_Swapped + (Left : P.Map; + Right : P.Map; + X : Cursor; + Y : Cursor) return Boolean + is + begin + if not P.Has_Key (Left, X) + or not P.Has_Key (Left, Y) + or not P.Has_Key (Right, X) + or not P.Has_Key (Right, Y) + then + return False; + end if; + + if P.Get (Left, X) /= P.Get (Right, Y) + or P.Get (Left, Y) /= P.Get (Right, X) + then + return False; + end if; + + for C of Left loop + if not P.Has_Key (Right, C) then + return False; + end if; + end loop; + + for C of Right loop + if not P.Has_Key (Left, C) + or else (C /= X + and C /= Y + and P.Get (Left, C) /= P.Get (Right, C)) + then + return False; + end if; + end loop; + + return True; + end P_Positions_Swapped; + + --------------------------- + -- P_Positions_Truncated -- + --------------------------- + + function P_Positions_Truncated + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + return False; + + elsif P.Has_Key (Small, Cu) then + return False; + end if; + end; + end loop; + + return True; + end P_Positions_Truncated; + + --------------- + -- Positions -- + --------------- + + function Positions (Container : List) return P.Map is + I : Count_Type := 1; + Position : Count_Type := Container.First; + R : P.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := P.Add (R, (Node => Position), I); + pragma Assert (P.Length (R) = I); + Position := Container.Nodes (Position).Next; + I := I + 1; + end loop; + + return R; + end Positions; + + end Formal_Model; + + ---------- + -- Free -- + ---------- + + procedure Free (Container : in out List; X : Count_Type) is + pragma Assert (X > 0); + pragma Assert (X <= Container.Capacity); + + N : Node_Array renames Container.Nodes; + + begin + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Container.Free >= 0 then + N (X).Next := Container.Free; + Container.Free := X; + + elsif X + 1 = abs Container.Free then + N (X).Next := 0; -- Not strictly necessary, but marginally safer + Container.Free := Container.Free + 1; + + else + Container.Free := abs Container.Free; + + if Container.Free > Container.Capacity then + Container.Free := 0; + + else + for J in Container.Free .. Container.Capacity - 1 loop + N (J).Next := J + 1; + end loop; + + N (Container.Capacity).Next := 0; + end if; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting with SPARK_Mode => Off is + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ----------------------- + -- M_Elements_Sorted -- + ----------------------- + + function M_Elements_Sorted (Container : M.Sequence) return Boolean is + begin + if M.Length (Container) = 0 then + return True; + end if; + + declare + E1 : Element_Type := Element (Container, 1); + + begin + for I in 2 .. M.Length (Container) loop + declare + E2 : constant Element_Type := Element (Container, I); + + begin + if E2 < E1 then + return False; + end if; + + E1 := E2; + end; + end loop; + end; + + return True; + end M_Elements_Sorted; + + end Formal_Model; + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type := Container.First; + + begin + for J in 2 .. Container.Length loop + if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then + return False; + else + Node := Nodes (Node).Next; + end if; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target : in out List; Source : in out List) is + LN : Node_Array renames Target.Nodes; + RN : Node_Array renames Source.Nodes; + LI : Cursor; + RI : Cursor; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + LI := First (Target); + RI := First (Source); + while RI.Node /= 0 loop + pragma Assert + (RN (RI.Node).Next = 0 + or else not (RN (RN (RI.Node).Next).Element < + RN (RI.Node).Element)); + + if LI.Node = 0 then + Splice (Target, No_Element, Source); + return; + end if; + + pragma Assert + (LN (LI.Node).Next = 0 + or else not (LN (LN (LI.Node).Next).Element < + LN (LI.Node).Element)); + + if RN (RI.Node).Element < LN (LI.Node).Element then + declare + RJ : Cursor := RI; + pragma Warnings (Off, RJ); + begin + RI.Node := RN (RI.Node).Next; + Splice (Target, LI, Source, RJ); + end; + + else + LI.Node := LN (LI.Node).Next; + end if; + end loop; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + N : Node_Array renames Container.Nodes; + + procedure Partition (Pivot : Count_Type; Back : Count_Type); + procedure Sort (Front : Count_Type; Back : Count_Type); + + --------------- + -- Partition -- + --------------- + + procedure Partition (Pivot : Count_Type; Back : Count_Type) is + Node : Count_Type; + + begin + Node := N (Pivot).Next; + while Node /= Back loop + if N (Node).Element < N (Pivot).Element then + declare + Prev : constant Count_Type := N (Node).Prev; + Next : constant Count_Type := N (Node).Next; + + begin + N (Prev).Next := Next; + + if Next = 0 then + Container.Last := Prev; + else + N (Next).Prev := Prev; + end if; + + N (Node).Next := Pivot; + N (Node).Prev := N (Pivot).Prev; + + N (Pivot).Prev := Node; + + if N (Node).Prev = 0 then + Container.First := Node; + else + N (N (Node).Prev).Next := Node; + end if; + + Node := Next; + end; + + else + Node := N (Node).Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front : Count_Type; Back : Count_Type) is + Pivot : Count_Type; + + begin + if Front = 0 then + Pivot := Container.First; + else + Pivot := N (Front).Next; + end if; + + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Sort + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + Sort (Front => 0, Back => 0); + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Sort; + + end Generic_Sorting; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : List; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return False; + end if; + + return Container.Nodes (Position.Node).Prev /= -1; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type) + is + J : Count_Type; + + begin + if Before.Node /= 0 then + pragma Assert (Vet (Container, Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Container.Length > Container.Capacity - Count then + raise Constraint_Error with "new length exceeds capacity"; + end if; + + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + Position := (Node => J); + + for Index in 2 .. Count loop + Allocate (Container, New_Item, New_Node => J); + Insert_Internal (Container, Before.Node, New_Node => J); + end loop; + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor) + is + begin + Insert + (Container => Container, + Before => Before, + New_Item => New_Item, + Position => Position, + Count => 1); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type) + is + Position : Cursor; + + begin + Insert (Container, Before, New_Item, Position, 1); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Count_Type; + New_Node : Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + + Container.First := New_Node; + Container.Last := New_Node; + + N (Container.First).Prev := 0; + N (Container.Last).Next := 0; + + elsif Before = 0 then + pragma Assert (N (Container.Last).Next = 0); + + N (Container.Last).Next := New_Node; + N (New_Node).Prev := Container.Last; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + elsif Before = Container.First then + pragma Assert (N (Container.First).Prev = 0); + + N (Container.First).Prev := New_Node; + N (New_Node).Next := Container.First; + + Container.First := New_Node; + N (Container.First).Prev := 0; + + else + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + N (New_Node).Next := Before; + N (New_Node).Prev := N (Before).Prev; + + N (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + + return (Node => Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + L : constant Count_Type := Container.Last; + + begin + if L = 0 then + raise Constraint_Error with "list is empty"; + else + return Container.Nodes (L).Element; + end if; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out List; Source : in out List) is + N : Node_Array renames Source.Nodes; + X : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + Clear (Target); + + while Source.Length > 1 loop + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last /= Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy first element from Source to Target + + X := Source.First; + Append (Target, N (X).Element); -- optimize away??? + + -- Unlink first node of Source + + Source.First := N (X).Next; + N (Source.First).Prev := 0; + + Source.Length := Source.Length - 1; + + -- The representation invariants for Source have been restored. It is + -- now safe to free the unlinked node, without fear of corrupting the + -- active links of Source. + + -- Note that the algorithm we use here models similar algorithms used + -- in the unbounded form of the doubly-linked list container. In that + -- case, Free is an instantation of Unchecked_Deallocation, which can + -- fail (because PE will be raised if controlled Finalize fails), so + -- we must defer the call until the last step. Here in the bounded + -- form, Free merely links the node we have just "deallocated" onto a + -- list of inactive nodes, so technically Free cannot fail. However, + -- for consistency, we handle Free the same way here as we do for the + -- unbounded form, with the pessimistic assumption that it can fail. + + Free (Source, X); + end loop; + + if Source.Length = 1 then + pragma Assert (Source.First in 1 .. Source.Capacity); + pragma Assert (Source.Last = Source.First); + pragma Assert (N (Source.First).Prev = 0); + pragma Assert (N (Source.Last).Next = 0); + + -- Copy element from Source to Target + + X := Source.First; + Append (Target, N (X).Element); + + -- Unlink node of Source + + Source.First := 0; + Source.Last := 0; + Source.Length := 0; + + -- Return the unlinked node to the free store + + Free (Source, X); + end if; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Container : List; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + function Next (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Program_Error with "Position cursor has no element"; + end if; + + return (Node => Container.Nodes (Position.Node).Next); + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out List; New_Item : Element_Type) is + begin + Insert (Container, First (Container), New_Item, 1); + end Prepend; + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Container : List; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + function Previous (Container : List; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Program_Error with "Position cursor has no element"; + end if; + + return (Node => Container.Nodes (Position.Node).Prev); + end Previous; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in Replace_Element"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + N : Node_Array renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; + + procedure Swap (L : Count_Type; R : Count_Type); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L : Count_Type; R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; + + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := N (J).Next; + exit when I = J; + + I := N (I).Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := N (I).Next; + exit when I = J; + + J := N (J).Prev; + exit when I = J; + end loop; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + CFirst : Count_Type := Position.Node; + + begin + if CFirst = 0 then + CFirst := Container.Last; + end if; + + if Container.Length = 0 then + return No_Element; + + else + while CFirst /= 0 loop + if Container.Nodes (CFirst).Element = Item then + return (Node => CFirst); + else + CFirst := Container.Nodes (CFirst).Prev; + end if; + end loop; + + return No_Element; + end if; + end Reverse_Find; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + SN : Node_Array renames Source.Nodes; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Before.Node /= 0 then + pragma Assert (Vet (Target, Before), "bad cursor in Splice"); + end if; + + pragma Assert (SN (Source.First).Prev = 0); + pragma Assert (SN (Source.Last).Next = 0); + + if Target.Length > Count_Type'Base'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + if Target.Length + Source.Length > Target.Capacity then + raise Constraint_Error; + end if; + + loop + Insert (Target, Before, SN (Source.Last).Element); + Delete_Last (Source); + exit when Is_Empty (Source); + end loop; + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + is + Target_Position : Cursor; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Source, Position), "bad Position cursor in Splice"); + + if Target.Length >= Target.Capacity then + raise Constraint_Error; + end if; + + Insert + (Container => Target, + Before => Before, + New_Item => Source.Nodes (Position.Node).Element, + Position => Target_Position); + + Delete (Source, Position); + Position := Target_Position; + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + N : Node_Array renames Container.Nodes; + + begin + if Before.Node /= 0 then + pragma Assert + (Vet (Container, Before), "bad Before cursor in Splice"); + end if; + + if Position.Node = 0 then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; + + Container.Last := Position.Node; + N (Container.Last).Next := 0; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.First).Prev := Position.Node; + N (Position.Node).Next := Container.First; + + Container.First := Position.Node; + N (Container.First).Prev := 0; + + return; + end if; + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + elsif Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (N (Before.Node).Prev).Next := Position.Node; + N (Position.Node).Prev := N (Before.Node).Prev; + + N (Before.Node).Prev := Position.Node; + N (Position.Node).Next := Before.Node; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I : Cursor; + J : Cursor) + is + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap"); + + declare + NN : Node_Array renames Container.Nodes; + NI : Node_Type renames NN (I.Node); + NJ : Node_Type renames NN (J.Node); + + EI_Copy : constant Element_Type := NI.Element; + + begin + NI.Element := NJ.Element; + NJ.Element := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I : Cursor; + J : Cursor) + is + I_Next : Cursor; + J_Next : Cursor; + + begin + if I.Node = 0 then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Node = 0 then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Node = J.Node then + return; + end if; + + pragma Assert (Vet (Container, I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (Container, J), "bad J cursor in Swap_Links"); + + I_Next := Next (Container, I); + + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + J_Next := Next (Container, J); + + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end if; + end Swap_Links; + + --------- + -- Vet -- + --------- + + function Vet (L : List; Position : Cursor) return Boolean is + N : Node_Array renames L.Nodes; + + begin + if L.Length = 0 then + return False; + end if; + + if L.First = 0 then + return False; + end if; + + if L.Last = 0 then + return False; + end if; + + if Position.Node > L.Capacity then + return False; + end if; + + if N (Position.Node).Prev < 0 + or else N (Position.Node).Prev > L.Capacity + then + return False; + end if; + + if N (Position.Node).Next > L.Capacity then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 and then Position.Node /= L.First then + return False; + end if; + + if N (Position.Node).Next = 0 and then Position.Node /= L.Last then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if N (Position.Node).Next = 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 then + return False; + end if; + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if N (L.First).Next /= Position.Node then + return False; + end if; + + if N (L.Last).Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end Vet; + +end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfdlli.ads b/gcc/ada/libgnat/a-cfdlli.ads new file mode 100644 index 0000000..f6638cb --- /dev/null +++ b/gcc/ada/libgnat/a-cfdlli.ads @@ -0,0 +1,1623 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Containers.Functional_Vectors; +with Ada.Containers.Functional_Maps; + +generic + type Element_Type is private; + +package Ada.Containers.Formal_Doubly_Linked_Lists with + SPARK_Mode +is + pragma Annotate (CodePeer, Skip_Analysis); + + type List (Capacity : Count_Type) is private with + Iterable => (First => First, + Next => Next, + Has_Element => Has_Element, + Element => Element), + Default_Initial_Condition => Is_Empty (List); + pragma Preelaborable_Initialization (List); + + type Cursor is record + Node : Count_Type := 0; + end record; + + No_Element : constant Cursor := Cursor'(Node => 0); + + Empty_List : constant List; + + function Length (Container : List) return Count_Type with + Global => null, + Post => Length'Result <= Container.Capacity; + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package M is new Ada.Containers.Functional_Vectors + (Index_Type => Positive_Count_Type, + Element_Type => Element_Type); + + function "=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."="; + + function "<" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<"; + + function "<=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<="; + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + -- The elements of Container are contained in either Left or Right + with + Global => null, + Post => + M_Elements_In_Union'Result = + (for all I in 1 .. M.Length (Container) => + (for some J in 1 .. M.Length (Left) => + Element (Container, I) = Element (Left, J)) + or (for some J in 1 .. M.Length (Right) => + Element (Container, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Positive_Count_Type := 1; + L_Lst : Count_Type; + Right : M.Sequence; + R_Fst : Positive_Count_Type := 1; + R_Lst : Count_Type) return Boolean + -- The elements of the slice from L_Fst to L_Lst in Left are contained + -- in the slide from R_Fst to R_Lst in Right. + with + Global => null, + Pre => L_Lst <= M.Length (Left) and R_Lst <= M.Length (Right), + Post => + M_Elements_Included'Result = + (for all I in L_Fst .. L_Lst => + (for some J in R_Fst .. R_Lst => + Element (Left, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + -- Right is Left in reverse order + with + Global => null, + Post => + M_Elements_Reversed'Result = + (M.Length (Left) = M.Length (Right) + and (for all I in 1 .. M.Length (Left) => + Element (Left, I) = + Element (Right, M.Length (Left) - I + 1)) + and (for all I in 1 .. M.Length (Left) => + Element (Right, I) = + Element (Left, M.Length (Left) - I + 1))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Positive_Count_Type; + Y : Positive_Count_Type) return Boolean + -- Elements stored at X and Y are reversed in Left and Right + with + Global => null, + Pre => X <= M.Length (Left) and Y <= M.Length (Left), + Post => + M_Elements_Swapped'Result = + (M.Length (Left) = M.Length (Right) + and Element (Left, X) = Element (Right, Y) + and Element (Left, Y) = Element (Right, X) + and M.Equal_Except (Left, Right, X, Y)); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); + + package P is new Ada.Containers.Functional_Maps + (Key_Type => Cursor, + Element_Type => Positive_Count_Type, + Equivalent_Keys => "=", + Enable_Handling_Of_Equivalence => False); + + function "=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."="; + + function "<=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."<="; + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Global => null, + Post => + P_Positions_Shifted'Result = + + -- Big contains all cursors of Small + + (P.Keys_Included (Small, Big) + + -- Cursors located before Cut are not moved, cursors located + -- after are shifted by Count. + + and (for all I of Small => + (if P.Get (Small, I) < Cut then + P.Get (Big, I) = P.Get (Small, I) + else + P.Get (Big, I) - Count = P.Get (Small, I))) + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function P_Positions_Swapped + (Left : P.Map; + Right : P.Map; + X : Cursor; + Y : Cursor) return Boolean + -- Left and Right contain the same cursors, but the positions of X and Y + -- are reversed. + with + Ghost, + Global => null, + Post => + P_Positions_Swapped'Result = + (P.Same_Keys (Left, Right) + and P.Elements_Equal_Except (Left, Right, X, Y) + and P.Has_Key (Left, X) + and P.Has_Key (Left, Y) + and P.Get (Left, X) = P.Get (Right, Y) + and P.Get (Left, Y) = P.Get (Right, X)); + + function P_Positions_Truncated + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Ghost, + Global => null, + Post => + P_Positions_Truncated'Result = + + -- Big contains all cursors of Small at the same position + + (Small <= Big + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function Mapping_Preserved + (M_Left : M.Sequence; + M_Right : M.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + with + Ghost, + Global => null, + Post => + (if Mapping_Preserved'Result then + + -- Left and Right contain the same cursors + + P.Same_Keys (P_Left, P_Right) + + -- Mappings from cursors to elements induced by M_Left, P_Left + -- and M_Right, P_Right are the same. + + and (for all C of P_Left => + M.Get (M_Left, P.Get (P_Left, C)) = + M.Get (M_Right, P.Get (P_Right, C)))); + + function Model (Container : List) return M.Sequence with + -- The high-level model of a list is a sequence of elements. Cursors are + -- not represented in this model. + + Ghost, + Global => null, + Post => M.Length (Model'Result) = Length (Container); + pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Model); + + function Positions (Container : List) return P.Map with + -- The Positions map is used to model cursors. It only contains valid + -- cursors and map them to their position in the container. + + Ghost, + Global => null, + Post => + not P.Has_Key (Positions'Result, No_Element) + + -- Positions of cursors are smaller than the container's length. + + and then + (for all I of Positions'Result => + P.Get (Positions'Result, I) in 1 .. Length (Container) + + -- No two cursors have the same position. Note that we do not + -- state that there is a cursor in the map for each position, as + -- it is rarely needed. + + and then + (for all J of Positions'Result => + (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) + then I = J))); + + procedure Lift_Abstraction_Level (Container : List) with + -- Lift_Abstraction_Level is a ghost procedure that does nothing but + -- assume that we can access to the same elements by iterating over + -- positions or cursors. + -- This information is not generally useful except when switching from + -- a low-level cursor-aware view of a container to a high-level + -- position-based view. + + Ghost, + Global => null, + Post => + (for all Elt of Model (Container) => + (for some I of Positions (Container) => + M.Get (Model (Container), P.Get (Positions (Container), I)) = + Elt)); + + function Element + (S : M.Sequence; + I : Count_Type) return Element_Type renames M.Get; + -- To improve readability of contracts, we rename the function used to + -- access an element in the model to Element. + + end Formal_Model; + use Formal_Model; + + function "=" (Left, Right : List) return Boolean with + Global => null, + Post => "="'Result = (Model (Left) = Model (Right)); + + function Is_Empty (Container : List) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out List) with + Global => null, + Post => Length (Container) = 0; + + procedure Assign (Target : in out List; Source : List) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => Model (Target) = Model (Source); + + function Copy (Source : List; Capacity : Count_Type := 0) return List with + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity, + Post => + Model (Copy'Result) = Model (Source) + and Positions (Copy'Result) = Positions (Source) + and (if Capacity = 0 then + Copy'Result.Capacity = Source.Capacity + else + Copy'Result.Capacity = Capacity); + + function Element + (Container : List; + Position : Cursor) return Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Element'Result = + Element (Model (Container), P.Get (Positions (Container), Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old + + -- Cursors are preserved + + and Positions (Container)'Old = Positions (Container) + + -- The element at the position of Position in Container is New_Item + + and Element + (Model (Container), + P.Get (Positions (Container), Position)) = New_Item + + -- Other elements are preserved + + and M.Equal_Except + (Model (Container)'Old, + Model (Container), + P.Get (Positions (Container), Position)); + + procedure Move (Target : in out List; Source : in out List) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => Model (Target) = Model (Source'Old) and Length (Source) = 0; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + 1, + Contract_Cases => + (Before = No_Element => + + -- Positions contains a new mapping from the last cursor of + -- Container to its length. + + P.Get (Positions (Container), Last (Container)) = Length (Container) + + -- Other cursors come from Container'Old + + and P.Keys_Included_Except + (Left => Positions (Container), + Right => Positions (Container)'Old, + New_Key => Last (Container)) + + -- Cursors of Container'Old keep the same position + + and Positions (Container)'Old <= Positions (Container) + + -- Model contains a new element New_Item at the end + + and Element (Model (Container), Length (Container)) = New_Item + + -- Elements of Container'Old are preserved + + and Model (Container)'Old <= Model (Container), + + others => + + -- The elements of Container located before Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is stored at the previous position of Before in + -- Container. + + and Element + (Model (Container), + P.Get (Positions (Container)'Old, Before)) = New_Item + + -- A new cursor has been inserted at position Before in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container)'Old, Before))); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Container.Capacity - Count + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + Count, + Contract_Cases => + (Before = No_Element => + + -- The elements of Container are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old) + + -- Container contains Count times New_Item at the end + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Length (Container)'Old + 1, + Lst => Length (Container), + Item => New_Item)) + + -- Container contains Count times New_Item at the end + + and M.Constant_Range + (Container => Model (Container), + Fst => Length (Container)'Old + 1, + Lst => Length (Container), + Item => New_Item) + + -- A Count cursors have been inserted at the end of Container + + and P_Positions_Truncated + (Positions (Container)'Old, + Positions (Container), + Cut => Length (Container)'Old + 1, + Count => Count), + + others => + + -- The elements of Container located before Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1) + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => Length (Container)'Old, + Offset => Count) + + -- Container contains Count times New_Item after position Before + + and M.Constant_Range + (Container => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before), + Lst => + P.Get (Positions (Container)'Old, Before) - 1 + Count, + Item => New_Item) + + -- Count cursors have been inserted at position Before in + -- Container. + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container)'Old, Before), + Count => Count)); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Positions is valid in Container and it is located either before + -- Before if it is valid in Container or at the end if it is + -- No_Element. + + and P.Has_Key (Positions (Container), Position) + and (if Before = No_Element then + P.Get (Positions (Container), Position) = Length (Container) + else + P.Get (Positions (Container), Position) = + P.Get (Positions (Container)'Old, Before)) + + -- The elements of Container located before Position are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is stored at Position in Container + + and Element + (Model (Container), + P.Get (Positions (Container), Position)) = New_Item + + -- A new cursor has been inserted at position Position in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position)); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Container.Capacity - Count + and then (Has_Element (Container, Before) + or else Before = No_Element), + Post => Length (Container) = Length (Container)'Old + Count, + Contract_Cases => + (Count = 0 => + Position = Before + and Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + others => + + -- Positions is valid in Container and it is located either before + -- Before if it is valid in Container or at the end if it is + -- No_Element. + + P.Has_Key (Positions (Container), Position) + and (if Before = No_Element then + P.Get (Positions (Container), Position) = + Length (Container)'Old + 1 + else + P.Get (Positions (Container), Position) = + P.Get (Positions (Container)'Old, Before)) + + -- The elements of Container located before Position are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => Count) + + -- Container contains Count times New_Item after position Position + + and M.Constant_Range + (Container => Model (Container), + Fst => P.Get (Positions (Container), Position), + Lst => + P.Get (Positions (Container), Position) - 1 + Count, + Item => New_Item) + + -- Count cursor have been inserted at Position in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position), + Count => Count)); + + procedure Prepend (Container : in out List; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Container.Capacity, + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old, + Offset => 1) + + -- New_Item is the first element of Container + + and Element (Model (Container), 1) = New_Item + + -- A new cursor has been inserted at the beginning of Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Container.Capacity - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- Elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => Length (Container)'Old, + Offset => Count) + + -- Container starts with Count times New_Item + + and M.Constant_Range + (Container => Model (Container), + Fst => 1, + Lst => Count, + Item => New_Item) + + -- Count cursors have been inserted at the beginning of Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => 1, + Count => Count); + + procedure Append (Container : in out List; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Container.Capacity, + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Positions contains a new mapping from the last cursor of Container + -- to its length. + + and P.Get (Positions (Container), Last (Container)) = + Length (Container) + + -- Other cursors come from Container'Old + + and P.Keys_Included_Except + (Left => Positions (Container), + Right => Positions (Container)'Old, + New_Key => Last (Container)) + + -- Cursors of Container'Old keep the same position + + and Positions (Container)'Old <= Positions (Container) + + -- Model contains a new element New_Item at the end + + and Element (Model (Container), Length (Container)) = New_Item + + -- Elements of Container'Old are preserved + + and Model (Container)'Old <= Model (Container); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Container.Capacity - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- The elements of Container are preserved + + and Model (Container)'Old <= Model (Container) + + -- Container contains Count times New_Item at the end + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Length (Container)'Old + 1, + Lst => Length (Container), + Item => New_Item)) + + -- Count cursors have been inserted at the end of Container + + and P_Positions_Truncated + (Positions (Container)'Old, + Positions (Container), + Cut => Length (Container)'Old + 1, + Count => Count); + + procedure Delete (Container : in out List; Position : in out Cursor) with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Position is set to No_Element + + and Position = No_Element + + -- The elements of Container located before Position are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => 1) + + -- Position has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old)); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) in + Length (Container)'Old - Count .. Length (Container)'Old + + -- Position is set to No_Element + + and Position = No_Element + + -- The elements of Container located before Position are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1), + + Contract_Cases => + + -- All the elements after Position have been erased + + (Length (Container) - Count < P.Get (Positions (Container), Position) => + Length (Container) = + P.Get (Positions (Container)'Old, Position'Old) - 1 + + -- At most Count cursors have been removed at the end of Container + + and P_Positions_Truncated + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old), + Count => Count), + + others => + Length (Container) = Length (Container)'Old - Count + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => Count) + + -- Count cursors have been removed from Container at Position + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old), + Count => Count)); + + procedure Delete_First (Container : in out List) with + Global => null, + Pre => not Is_Empty (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- The elements of Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => 1) + + -- The first cursor of Container has been removed + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1); + + procedure Delete_First (Container : in out List; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => + Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- Elements of Container are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => Count) + + -- The first Count cursors have been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1, + Count => Count)); + + procedure Delete_Last (Container : in out List) with + Global => null, + Pre => not Is_Empty (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old + + -- The last cursor of Container has been removed + + and not P.Has_Key (Positions (Container), Last (Container)'Old) + + -- Other cursors are still valid + + and P.Keys_Included_Except + (Left => Positions (Container)'Old, + Right => Positions (Container)'Old, + New_Key => Last (Container)'Old) + + -- The positions of other cursors are preserved + + and Positions (Container) <= Positions (Container)'Old; + + procedure Delete_Last (Container : in out List; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => + Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old + + -- At most Count cursors have been removed at the end of Container + + and P_Positions_Truncated + (Positions (Container), + Positions (Container)'Old, + Cut => Length (Container) + 1, + Count => Count)); + + procedure Reverse_Elements (Container : in out List) with + Global => null, + Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); + + procedure Swap + (Container : in out List; + I : Cursor; + J : Cursor) + with + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J), + Post => + M_Elements_Swapped + (Model (Container)'Old, + Model (Container), + X => P.Get (Positions (Container)'Old, I), + Y => P.Get (Positions (Container)'Old, J)) + + and Positions (Container) = Positions (Container)'Old; + + procedure Swap_Links + (Container : in out List; + I : Cursor; + J : Cursor) + with + Global => null, + Pre => Has_Element (Container, I) and then Has_Element (Container, J), + Post => + M_Elements_Swapped + (Model (Container'Old), + Model (Container), + X => P.Get (Positions (Container)'Old, I), + Y => P.Get (Positions (Container)'Old, J)) + and P_Positions_Swapped + (Positions (Container)'Old, Positions (Container), I, J); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + -- Target and Source should not be aliased + with + Global => null, + Pre => + Length (Source) <= Target.Capacity - Length (Target) + and then (Has_Element (Target, Before) + or else Before = No_Element), + Post => + Length (Source) = 0 + and Length (Target) = Length (Target)'Old + Length (Source)'Old, + Contract_Cases => + (Before = No_Element => + + -- The elements of Target are preserved + + M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => Length (Target)'Old) + + -- The elements of Source are appended to target, the order is not + -- specified. + + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Fst => Length (Target)'Old + 1, + R_Lst => Length (Target)) + + and M_Elements_Included + (Left => Model (Target), + L_Fst => Length (Target)'Old + 1, + L_Lst => Length (Target), + Right => Model (Source)'Old, + R_Lst => Length (Source)'Old) + + -- Cursors have been inserted at the end of Target + + and P_Positions_Truncated + (Positions (Target)'Old, + Positions (Target), + Cut => Length (Target)'Old + 1, + Count => Length (Source)'Old), + + others => + + -- The elements of Target located before Before are preserved + + M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => P.Get (Positions (Target)'Old, Before) - 1) + + -- The elements of Source are inserted before Before, the order is + -- not specified. + + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Fst => P.Get (Positions (Target)'Old, Before), + R_Lst => + P.Get (Positions (Target)'Old, Before) - 1 + + Length (Source)'Old) + + and M_Elements_Included + (Left => Model (Target), + L_Fst => P.Get (Positions (Target)'Old, Before), + L_Lst => + P.Get (Positions (Target)'Old, Before) - 1 + + Length (Source)'Old, + Right => Model (Source)'Old, + R_Lst => Length (Source)'Old) + + -- Other elements are shifted by the length of Source + + and M.Range_Shifted + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => P.Get (Positions (Target)'Old, Before), + Lst => Length (Target)'Old, + Offset => Length (Source)'Old) + + -- Cursors have been inserted at position Before in Target + + and P_Positions_Shifted + (Positions (Target)'Old, + Positions (Target), + Cut => P.Get (Positions (Target)'Old, Before), + Count => Length (Source)'Old)); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + -- Target and Source should not be aliased + with + Global => null, + Pre => + (Has_Element (Target, Before) or else Before = No_Element) + and then Has_Element (Source, Position) + and then Length (Target) < Target.Capacity, + Post => + Length (Target) = Length (Target)'Old + 1 + and Length (Source) = Length (Source)'Old - 1 + + -- The elements of Source located before Position are preserved + + and M.Range_Equal + (Left => Model (Source)'Old, + Right => Model (Source), + Fst => 1, + Lst => P.Get (Positions (Source)'Old, Position'Old) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Source)'Old, + Right => Model (Source), + Fst => P.Get (Positions (Source)'Old, Position'Old) + 1, + Lst => Length (Source)'Old, + Offset => -1) + + -- Position has been removed from Source + + and P_Positions_Shifted + (Positions (Source), + Positions (Source)'Old, + Cut => P.Get (Positions (Source)'Old, Position'Old)) + + -- Positions is valid in Target and it is located either before + -- Before if it is valid in Target or at the end if it is No_Element. + + and P.Has_Key (Positions (Target), Position) + and (if Before = No_Element then + P.Get (Positions (Target), Position) = Length (Target) + else + P.Get (Positions (Target), Position) = + P.Get (Positions (Target)'Old, Before)) + + -- The elements of Target located before Position are preserved + + and M.Range_Equal + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => 1, + Lst => P.Get (Positions (Target), Position) - 1) + + -- Other elements are shifted by 1 + + and M.Range_Shifted + (Left => Model (Target)'Old, + Right => Model (Target), + Fst => P.Get (Positions (Target), Position), + Lst => Length (Target)'Old, + Offset => 1) + + -- The element located at Position in Source is moved to Target + + and Element (Model (Target), + P.Get (Positions (Target), Position)) = + Element (Model (Source)'Old, + P.Get (Positions (Source)'Old, Position'Old)) + + -- A new cursor has been inserted at position Position in Target + + and P_Positions_Shifted + (Positions (Target)'Old, + Positions (Target), + Cut => P.Get (Positions (Target), Position)); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + with + Global => null, + Pre => + (Has_Element (Container, Before) or else Before = No_Element) + and then Has_Element (Container, Position), + Post => Length (Container) = Length (Container)'Old, + Contract_Cases => + (Before = Position => + Model (Container) = Model (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + Before = No_Element => + + -- The elements located before Position are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position) - 1) + + -- The elements located after Position are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Position) + 1, + Lst => Length (Container)'Old, + Offset => -1) + + -- The last element of Container is the one that was previously at + -- Position. + + and Element (Model (Container), + Length (Container)) = + Element (Model (Container)'Old, + P.Get (Positions (Container)'Old, Position)) + + -- Cursors from Container continue designating the same elements + + and Mapping_Preserved + (M_Left => Model (Container)'Old, + M_Right => Model (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)), + + others => + + -- The elements located before Position and Before are preserved + + M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => 1, + Lst => + Count_Type'Min + (P.Get (Positions (Container)'Old, Position) - 1, + P.Get (Positions (Container)'Old, Before) - 1)) + + -- The elements located after Position and Before are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => + Count_Type'Max + (P.Get (Positions (Container)'Old, Position) + 1, + P.Get (Positions (Container)'Old, Before) + 1), + Lst => Length (Container)) + + -- The elements located after Before and before Position are + -- shifted by 1 to the right. + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Before) + 1, + Lst => P.Get (Positions (Container)'Old, Position) - 1, + Offset => 1) + + -- The elements located after Position and before Before are + -- shifted by 1 to the left. + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => P.Get (Positions (Container)'Old, Position) + 1, + Lst => P.Get (Positions (Container)'Old, Before) - 1, + Offset => -1) + + -- The element previously at Position is now before Before + + and Element + (Model (Container), + P.Get (Positions (Container)'Old, Before)) = + Element + (Model (Container)'Old, + P.Get (Positions (Container)'Old, Position)) + + -- Cursors from Container continue designating the same elements + + and Mapping_Preserved + (M_Left => Model (Container)'Old, + M_Right => Model (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container))); + + function First (Container : List) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + First'Result = No_Element, + + others => + Has_Element (Container, First'Result) + and P.Get (Positions (Container), First'Result) = 1); + + function First_Element (Container : List) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => First_Element'Result = M.Get (Model (Container), 1); + + function Last (Container : List) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + Last'Result = No_Element, + + others => + Has_Element (Container, Last'Result) + and P.Get (Positions (Container), Last'Result) = + Length (Container)); + + function Last_Element (Container : List) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Element'Result = M.Get (Model (Container), Length (Container)); + + function Next (Container : List; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Next'Result = No_Element, + + others => + Has_Element (Container, Next'Result) + and then P.Get (Positions (Container), Next'Result) = + P.Get (Positions (Container), Position) + 1); + + procedure Next (Container : List; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) + 1); + + function Previous (Container : List; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Previous'Result = No_Element, + + others => + Has_Element (Container, Previous'Result) + and then P.Get (Positions (Container), Previous'Result) = + P.Get (Positions (Container), Position) - 1); + + procedure Previous (Container : List; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) - 1); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + + -- If Item is not contained in Container after Position, Find returns + -- No_Element. + + (not M.Contains + (Container => Model (Container), + Fst => + (if Position = No_Element then + 1 + else + P.Get (Positions (Container), Position)), + Lst => Length (Container), + Item => Item) + => + Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + + -- The element designated by the result of Find is Item + + and Element + (Model (Container), + P.Get (Positions (Container), Find'Result)) = Item + + -- The result of Find is located after Position + + and (if Position /= No_Element then + P.Get (Positions (Container), Find'Result) >= + P.Get (Positions (Container), Position)) + + -- It is the first occurrence of Item in this slice + + and not M.Contains + (Container => Model (Container), + Fst => + (if Position = No_Element then + 1 + else + P.Get (Positions (Container), Position)), + Lst => + P.Get (Positions (Container), Find'Result) - 1, + Item => Item)); + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + + -- If Item is not contained in Container before Position, Find returns + -- No_Element. + + (not M.Contains + (Container => Model (Container), + Fst => 1, + Lst => + (if Position = No_Element then + Length (Container) + else + P.Get (Positions (Container), Position)), + Item => Item) + => + Reverse_Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Reverse_Find'Result) + + -- The element designated by the result of Find is Item + + and Element + (Model (Container), + P.Get (Positions (Container), Reverse_Find'Result)) = Item + + -- The result of Find is located before Position + + and (if Position /= No_Element then + P.Get (Positions (Container), Reverse_Find'Result) <= + P.Get (Positions (Container), Position)) + + -- It is the last occurrence of Item in this slice + + and not M.Contains + (Container => Model (Container), + Fst => + P.Get (Positions (Container), + Reverse_Find'Result) + 1, + Lst => + (if Position = No_Element then + Length (Container) + else + P.Get (Positions (Container), Position)), + Item => Item)); + + function Contains + (Container : List; + Item : Element_Type) return Boolean + with + Global => null, + Post => + Contains'Result = M.Contains (Container => Model (Container), + Fst => 1, + Lst => Length (Container), + Item => Item); + + function Has_Element + (Container : List; + Position : Cursor) return Boolean + with + Global => null, + Post => + Has_Element'Result = P.Has_Key (Positions (Container), Position); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + + package Generic_Sorting with SPARK_Mode is + + package Formal_Model with Ghost is + function M_Elements_Sorted (Container : M.Sequence) return Boolean + with + Global => null, + Post => + M_Elements_Sorted'Result = + (for all I in 1 .. M.Length (Container) => + (for all J in I .. M.Length (Container) => + Element (Container, I) = Element (Container, J) + or Element (Container, I) < Element (Container, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); + + end Formal_Model; + use Formal_Model; + + function Is_Sorted (Container : List) return Boolean with + Global => null, + Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); + + procedure Sort (Container : in out List) with + Global => null, + Post => + Length (Container) = Length (Container)'Old + and M_Elements_Sorted (Model (Container)) + and M_Elements_Included + (Left => Model (Container)'Old, + L_Lst => Length (Container), + Right => Model (Container), + R_Lst => Length (Container)) + and M_Elements_Included + (Left => Model (Container), + L_Lst => Length (Container), + Right => Model (Container)'Old, + R_Lst => Length (Container)); + + procedure Merge (Target : in out List; Source : in out List) with + -- Target and Source should not be aliased + Global => null, + Pre => Length (Source) <= Target.Capacity - Length (Target), + Post => + Length (Target) = Length (Target)'Old + Length (Source)'Old + and Length (Source) = 0 + and (if M_Elements_Sorted (Model (Target)'Old) + and M_Elements_Sorted (Model (Source)'Old) + then + M_Elements_Sorted (Model (Target))) + and M_Elements_Included + (Left => Model (Target)'Old, + L_Lst => Length (Target)'Old, + Right => Model (Target), + R_Lst => Length (Target)) + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Length (Source)'Old, + Right => Model (Target), + R_Lst => Length (Target)) + and M_Elements_In_Union + (Model (Target), + Model (Source)'Old, + Model (Target)'Old); + end Generic_Sorting; + +private + pragma SPARK_Mode (Off); + + type Node_Type is record + Prev : Count_Type'Base := -1; + Next : Count_Type; + Element : Element_Type; + end record; + + function "=" (L, R : Node_Type) return Boolean is abstract; + + type Node_Array is array (Count_Type range <>) of Node_Type; + function "=" (L, R : Node_Array) return Boolean is abstract; + + type List (Capacity : Count_Type) is record + Free : Count_Type'Base := -1; + Length : Count_Type := 0; + First : Count_Type := 0; + Last : Count_Type := 0; + Nodes : Node_Array (1 .. Capacity) := (others => <>); + end record; + + Empty_List : constant List := (0, others => <>); + +end Ada.Containers.Formal_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cfhama.adb b/gcc/ada/libgnat/a-cfhama.adb new file mode 100644 index 0000000..bf782c6 --- /dev/null +++ b/gcc/ada/libgnat/a-cfhama.adb @@ -0,0 +1,888 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Formal_Hashed_Maps with + SPARK_Mode => Off +is + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- All local subprograms require comments ??? + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Keys); + + procedure Free + (HT : in out Map; + X : Count_Type); + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (HT : in out Map; + Node : out Count_Type); + + function Hash_Node (Node : Node_Type) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Type) return Count_Type; + pragma Inline (Next); + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type); + pragma Inline (Set_Next); + + function Vet (Container : Map; Position : Cursor) return Boolean; + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is + new Hash_Tables.Generic_Bounded_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next); + + package Key_Ops is + new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + if Length (Left) = 0 then + return True; + end if; + + declare + Node : Count_Type; + ENode : Count_Type; + + begin + Node := Left.First.Node; + while Node /= 0 loop + ENode := + Find + (Container => Right, + Key => Left.Nodes (Node).Key).Node; + + if ENode = 0 or else + Right.Nodes (ENode).Element /= Left.Nodes (Node).Element + then + return False; + end if; + + Node := HT_Ops.Next (Left, Node); + end loop; + + return True; + end; + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Element (Source_Node : Count_Type); + pragma Inline (Insert_Element); + + procedure Insert_Elements is + new HT_Ops.Generic_Iteration (Insert_Element); + + -------------------- + -- Insert_Element -- + -------------------- + + procedure Insert_Element (Source_Node : Count_Type) is + N : Node_Type renames Source.Nodes (Source_Node); + begin + Insert (Target, N.Key, N.Element); + end Insert_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- correct exception ??? + "Source length exceeds Target capacity"; + end if; + + Clear (Target); + + Insert_Elements (Source); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type is + begin + return Container.Nodes'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Map; + Capacity : Count_Type := 0) return Map + is + C : constant Count_Type := + Count_Type'Max (Capacity, Source.Capacity); + Cu : Cursor; + H : Hash_Type; + N : Count_Type; + Target : Map (C, Source.Modulus); + + begin + if 0 < Capacity and then Capacity < Source.Capacity then + raise Capacity_Error; + end if; + + Target.Length := Source.Length; + Target.Free := Source.Free; + + H := 1; + while H <= Source.Modulus loop + Target.Buckets (H) := Source.Buckets (H); + H := H + 1; + end loop; + + N := 1; + while N <= Source.Capacity loop + Target.Nodes (N) := Source.Nodes (N); + N := N + 1; + end loop; + + while N <= C loop + Cu := (Node => N); + Free (Target, Cu.Node); + N := N + 1; + end loop; + + return Target; + end Copy; + + --------------------- + -- Default_Modulus -- + --------------------- + + function Default_Modulus (Capacity : Count_Type) return Hash_Type is + begin + return To_Prime (Capacity); + end Default_Modulus; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Count_Type; + + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + + if X = 0 then + raise Constraint_Error with "attempt to delete key not in map"; + end if; + + Free (Container, X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of Delete has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + + Free (Container, Position.Node); + Position := No_Element; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Count_Type := Find (Container, Key).Node; + + begin + if Node = 0 then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + function Element (Container : Map; Position : Cursor) return Element_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in function Element"); + + return Container.Nodes (Position.Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys + (Key : Key_Type; + Node : Node_Type) return Boolean + is + begin + return Equivalent_Keys (Key, Node.Key); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Count_Type; + begin + Key_Ops.Delete_Key_Sans_Free (Container, Key, X); + Free (Container, X); + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end First; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ---------- + -- Find -- + ---------- + + function Find + (Container : K.Sequence; + Key : Key_Type) return Count_Type + is + begin + for I in 1 .. K.Length (Container) loop + if Equivalent_Keys (Key, K.Get (Container, I)) then + return I; + end if; + end loop; + return 0; + end Find; + + --------------------- + -- K_Keys_Included -- + --------------------- + + function K_Keys_Included + (Left : K.Sequence; + Right : K.Sequence) return Boolean + is + begin + for I in 1 .. K.Length (Left) loop + if not K.Contains (Right, 1, K.Length (Right), K.Get (Left, I)) + then + return False; + end if; + end loop; + + return True; + end K_Keys_Included; + + ---------- + -- Keys -- + ---------- + + function Keys (Container : Map) return K.Sequence is + Position : Count_Type := HT_Ops.First (Container); + R : K.Sequence; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := K.Add (R, Container.Nodes (Position).Key); + Position := HT_Ops.Next (Container, Position); + end loop; + + return R; + end Keys; + + ---------------------------- + -- Lift_Abstraction_Level -- + ---------------------------- + + procedure Lift_Abstraction_Level (Container : Map) is null; + + ----------------------- + -- Mapping_preserved -- + ----------------------- + + function Mapping_Preserved + (K_Left : K.Sequence; + K_Right : K.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + is + begin + for C of P_Left loop + if not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > K.Length (K_Left) + or else P.Get (P_Right, C) > K.Length (K_Right) + or else K.Get (K_Left, P.Get (P_Left, C)) /= + K.Get (K_Right, P.Get (P_Right, C)) + then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved; + + ----------- + -- Model -- + ----------- + + function Model (Container : Map) return M.Map is + Position : Count_Type := HT_Ops.First (Container); + R : M.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := + M.Add + (Container => R, + New_Key => Container.Nodes (Position).Key, + New_Item => Container.Nodes (Position).Element); + + Position := HT_Ops.Next (Container, Position); + end loop; + + return R; + end Model; + + --------------- + -- Positions -- + --------------- + + function Positions (Container : Map) return P.Map is + I : Count_Type := 1; + Position : Count_Type := HT_Ops.First (Container); + R : P.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := P.Add (R, (Node => Position), I); + pragma Assert (P.Length (R) = I); + Position := HT_Ops.Next (Container, Position); + I := I + 1; + end loop; + + return R; + end Positions; + + end Formal_Model; + + ---------- + -- Free -- + ---------- + + procedure Free (HT : in out Map; X : Count_Type) is + begin + HT.Nodes (X).Has_Element := False; + HT_Ops.Free (HT, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is + procedure Allocate is + new HT_Ops.Generic_Allocate (Set_Element); + + begin + Allocate (HT, Node); + HT.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : Map; Position : Cursor) return Boolean is + begin + if Position.Node = 0 + or else not Container.Nodes (Position.Node).Has_Element + then + return False; + else + return True; + end if; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Type) return Hash_Type is + begin + return Hash (Node.Key); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + procedure Assign_Key (Node : in out Node_Type); + pragma Inline (Assign_Key); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new Generic_Allocate (Assign_Key); + + ----------------- + -- Assign_Key -- + ----------------- + + procedure Assign_Key (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Assign_Key; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + Local_Insert (Container, Key, Position.Node, Inserted); + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with "attempt to insert key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + --------- + -- Key -- + --------- + + function Key (Container : Map; Position : Cursor) return Key_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of function Key has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in function Key"); + + return Container.Nodes (Position.Node).Key; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) + is + NN : HT_Types.Nodes_Type renames Source.Nodes; + X : Count_Type; + Y : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + Clear (Target); + + if Source.Length = 0 then + return; + end if; + + X := HT_Ops.First (Source); + while X /= 0 loop + Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? + + Y := HT_Ops.Next (Source, X); + + HT_Ops.Delete_Node_Sans_Free (Source, X); + Free (Source, X); + + X := Y; + end loop; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Type) return Count_Type is + begin + return Node.Next; + end Next; + + function Next (Container : Map; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in function Next"); + + declare + Node : constant Count_Type := HT_Ops.Next (Container, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Next; + + procedure Next (Container : Map; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "attempt to replace key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of Replace_Element has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in Replace_Element"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) + is + begin + if Capacity > Container.Capacity then + raise Capacity_Error with "requested capacity is too large"; + end if; + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is + begin + Node.Next := Next; + end Set_Next; + + --------- + -- Vet -- + --------- + + function Vet (Container : Map; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return True; + end if; + + declare + X : Count_Type; + + begin + if Container.Length = 0 then + return False; + end if; + + if Container.Capacity = 0 then + return False; + end if; + + if Container.Buckets'Length = 0 then + return False; + end if; + + if Position.Node > Container.Capacity then + return False; + end if; + + if Container.Nodes (Position.Node).Next = Position.Node then + return False; + end if; + + X := + Container.Buckets + (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key)); + + for J in 1 .. Container.Length loop + if X = Position.Node then + return True; + end if; + + if X = 0 then + return False; + end if; + + if X = Container.Nodes (X).Next then + + -- Prevent unnecessary looping + + return False; + end if; + + X := Container.Nodes (X).Next; + end loop; + + return False; + end; + end Vet; + +end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cfhama.ads b/gcc/ada/libgnat/a-cfhama.ads new file mode 100644 index 0000000..e02accc --- /dev/null +++ b/gcc/ada/libgnat/a-cfhama.ads @@ -0,0 +1,815 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This spec is derived from package Ada.Containers.Bounded_Hashed_Maps in the +-- Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. + +-- The modifications are: + +-- A parameter for the container is added to every function reading the +-- contents of a container: Key, Element, Next, Query_Element, Has_Element, +-- Iterate, Equivalent_Keys. This change is motivated by the need to have +-- cursors which are valid on different containers (typically a container C +-- and its previous version C'Old) for expressing properties, which is not +-- possible if cursors encapsulate an access to the underlying container. + +-- Iteration over maps is done using the Iterable aspect, which is SPARK +-- compatible. "For of" iteration ranges over keys instead of elements. + +with Ada.Containers.Functional_Vectors; +with Ada.Containers.Functional_Maps; +private with Ada.Containers.Hash_Tables; + +generic + type Key_Type is private; + type Element_Type is private; + + with function Hash (Key : Key_Type) return Hash_Type; + with function Equivalent_Keys + (Left : Key_Type; + Right : Key_Type) return Boolean is "="; + +package Ada.Containers.Formal_Hashed_Maps with + SPARK_Mode +is + pragma Annotate (CodePeer, Skip_Analysis); + + type Map (Capacity : Count_Type; Modulus : Hash_Type) is private with + Iterable => (First => First, + Next => Next, + Has_Element => Has_Element, + Element => Key), + Default_Initial_Condition => Is_Empty (Map); + pragma Preelaborable_Initialization (Map); + + Empty_Map : constant Map; + + type Cursor is record + Node : Count_Type; + end record; + + No_Element : constant Cursor := (Node => 0); + + function Length (Container : Map) return Count_Type with + Global => null, + Post => Length'Result <= Container.Capacity; + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package M is new Ada.Containers.Functional_Maps + (Element_Type => Element_Type, + Key_Type => Key_Type, + Equivalent_Keys => Equivalent_Keys); + + function "=" + (Left : M.Map; + Right : M.Map) return Boolean renames M."="; + + function "<=" + (Left : M.Map; + Right : M.Map) return Boolean renames M."<="; + + package K is new Ada.Containers.Functional_Vectors + (Element_Type => Key_Type, + Index_Type => Positive_Count_Type); + + function "=" + (Left : K.Sequence; + Right : K.Sequence) return Boolean renames K."="; + + function "<" + (Left : K.Sequence; + Right : K.Sequence) return Boolean renames K."<"; + + function "<=" + (Left : K.Sequence; + Right : K.Sequence) return Boolean renames K."<="; + + function Find (Container : K.Sequence; Key : Key_Type) return Count_Type + -- Search for Key in Container + + with + Global => null, + Post => + (if Find'Result > 0 then + Find'Result <= K.Length (Container) + and Equivalent_Keys (Key, K.Get (Container, Find'Result))); + + function K_Keys_Included + (Left : K.Sequence; + Right : K.Sequence) return Boolean + -- Return True if Right contains all the keys of Left + + with + Global => null, + Post => + K_Keys_Included'Result = + (for all I in 1 .. K.Length (Left) => + Find (Right, K.Get (Left, I)) > 0 + and then K.Get (Right, Find (Right, K.Get (Left, I))) = + K.Get (Left, I)); + + package P is new Ada.Containers.Functional_Maps + (Key_Type => Cursor, + Element_Type => Positive_Count_Type, + Equivalent_Keys => "=", + Enable_Handling_Of_Equivalence => False); + + function "=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."="; + + function "<=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."<="; + + function Mapping_Preserved + (K_Left : K.Sequence; + K_Right : K.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + with + Global => null, + Post => + (if Mapping_Preserved'Result then + + -- Right contains all the cursors of Left + + P.Keys_Included (P_Left, P_Right) + + -- Right contains all the keys of Left + + and K_Keys_Included (K_Left, K_Right) + + -- Mappings from cursors to elements induced by K_Left, P_Left + -- and K_Right, P_Right are the same. + + and (for all C of P_Left => + K.Get (K_Left, P.Get (P_Left, C)) = + K.Get (K_Right, P.Get (P_Right, C)))); + + function Model (Container : Map) return M.Map with + -- The high-level model of a map is a map from keys to elements. Neither + -- cursors nor order of elements are represented in this model. Keys are + -- modeled up to equivalence. + + Ghost, + Global => null; + + function Keys (Container : Map) return K.Sequence with + -- The Keys sequence represents the underlying list structure of maps + -- that is used for iteration. It stores the actual values of keys in + -- the map. It does not model cursors nor elements. + + Ghost, + Global => null, + Post => + K.Length (Keys'Result) = Length (Container) + + -- It only contains keys contained in Model + + and (for all Key of Keys'Result => + M.Has_Key (Model (Container), Key)) + + -- It contains all the keys contained in Model + + and (for all Key of Model (Container) => + (Find (Keys'Result, Key) > 0 + and then Equivalent_Keys + (K.Get (Keys'Result, Find (Keys'Result, Key)), + Key))) + + -- It has no duplicate + + and (for all I in 1 .. Length (Container) => + Find (Keys'Result, K.Get (Keys'Result, I)) = I) + + and (for all I in 1 .. Length (Container) => + (for all J in 1 .. Length (Container) => + (if Equivalent_Keys + (K.Get (Keys'Result, I), K.Get (Keys'Result, J)) + then + I = J))); + pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); + + function Positions (Container : Map) return P.Map with + -- The Positions map is used to model cursors. It only contains valid + -- cursors and maps them to their position in the container. + + Ghost, + Global => null, + Post => + not P.Has_Key (Positions'Result, No_Element) + + -- Positions of cursors are smaller than the container's length + + and then + (for all I of Positions'Result => + P.Get (Positions'Result, I) in 1 .. Length (Container) + + -- No two cursors have the same position. Note that we do not + -- state that there is a cursor in the map for each position, as + -- it is rarely needed. + + and then + (for all J of Positions'Result => + (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) + then I = J))); + + procedure Lift_Abstraction_Level (Container : Map) with + -- Lift_Abstraction_Level is a ghost procedure that does nothing but + -- assume that we can access the same elements by iterating over + -- positions or cursors. + -- This information is not generally useful except when switching from + -- a low-level, cursor-aware view of a container, to a high-level, + -- position-based view. + + Ghost, + Global => null, + Post => + (for all Key of Keys (Container) => + (for some I of Positions (Container) => + K.Get (Keys (Container), P.Get (Positions (Container), I)) = + Key)); + + function Contains + (C : M.Map; + K : Key_Type) return Boolean renames M.Has_Key; + -- To improve readability of contracts, we rename the function used to + -- search for a key in the model to Contains. + + function Element + (C : M.Map; + K : Key_Type) return Element_Type renames M.Get; + -- To improve readability of contracts, we rename the function used to + -- access an element in the model to Element. + + end Formal_Model; + use Formal_Model; + + function "=" (Left, Right : Map) return Boolean with + Global => null, + Post => "="'Result = (Model (Left) = Model (Right)); + + function Capacity (Container : Map) return Count_Type with + Global => null, + Post => Capacity'Result = Container.Capacity; + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) + with + Global => null, + Pre => Capacity <= Container.Capacity, + Post => + Model (Container) = Model (Container)'Old + and Length (Container)'Old = Length (Container) + + -- Actual keys are preserved + + and K_Keys_Included (Keys (Container), Keys (Container)'Old) + and K_Keys_Included (Keys (Container)'Old, Keys (Container)); + + function Is_Empty (Container : Map) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out Map) with + Global => null, + Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); + + procedure Assign (Target : in out Map; Source : Map) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Model (Target) = Model (Source) + and Length (Source) = Length (Target) + + -- Actual keys are preserved + + and K_Keys_Included (Keys (Target), Keys (Source)) + and K_Keys_Included (Keys (Source), Keys (Target)); + + function Copy + (Source : Map; + Capacity : Count_Type := 0) return Map + with + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity, + Post => + Model (Copy'Result) = Model (Source) + and Keys (Copy'Result) = Keys (Source) + and Positions (Copy'Result) = Positions (Source) + and (if Capacity = 0 then + Copy'Result.Capacity = Source.Capacity + else + Copy'Result.Capacity = Capacity); + -- Copy returns a container stricty equal to Source. It must have the same + -- cursors associated with each element. Therefore: + -- - capacity=0 means use Source.Capacity as capacity of target + -- - the modulus cannot be changed. + + function Key (Container : Map; Position : Cursor) return Key_Type with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Key'Result = + K.Get (Keys (Container), P.Get (Positions (Container), Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Key); + + function Element + (Container : Map; + Position : Cursor) return Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Element'Result = Element (Model (Container), Key (Container, Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + + -- Order of keys and cursors is preserved + + Keys (Container) = Keys (Container)'Old + and Positions (Container) = Positions (Container)'Old + + -- New_Item is now associated with the key at position Position in + -- Container. + + and Element (Container, Position) = New_Item + + -- Elements associated with other keys are preserved + + and M.Same_Keys (Model (Container), Model (Container)'Old) + and M.Elements_Equal_Except + (Model (Container), + Model (Container)'Old, + Key (Container, Position)); + + procedure Move (Target : in out Map; Source : in out Map) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Model (Target) = Model (Source)'Old + and Length (Source)'Old = Length (Target) + and Length (Source) = 0 + + -- Actual keys are preserved + + and K_Keys_Included (Keys (Target), Keys (Source)'Old) + and K_Keys_Included (Keys (Source)'Old, Keys (Target)); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + with + Global => null, + Pre => + Length (Container) < Container.Capacity or Contains (Container, Key), + Post => + Contains (Container, Key) + and Has_Element (Container, Position) + and Equivalent_Keys + (Formal_Hashed_Maps.Key (Container, Position), Key), + Contract_Cases => + + -- If Key is already in Container, it is not modified and Inserted is + -- set to False. + + (Contains (Container, Key) => + not Inserted + and Model (Container) = Model (Container)'Old + and Keys (Container) = Keys (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Key is inserted in Container and Inserted is set to True + + others => + Inserted + and Length (Container) = Length (Container)'Old + 1 + + -- Key now maps to New_Item + + and Formal_Hashed_Maps.Key (Container, Position) = Key + and Element (Model (Container), Key) = New_Item + + -- Other keys are preserved + + and Model (Container)'Old <= Model (Container) + and M.Keys_Included_Except + (Model (Container), + Model (Container)'Old, + Key) + + -- Mapping from cursors to keys is preserved + + and Mapping_Preserved + (K_Left => Keys (Container)'Old, + K_Right => Keys (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)) + and P.Keys_Included_Except + (Positions (Container), + Positions (Container)'Old, + Position)); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + and then (not Contains (Container, Key)), + Post => + Length (Container) = Length (Container)'Old + 1 + and Contains (Container, Key) + + -- Key now maps to New_Item + + and Formal_Hashed_Maps.Key (Container, Find (Container, Key)) = Key + and Element (Model (Container), Key) = New_Item + + -- Other keys are preserved + + and Model (Container)'Old <= Model (Container) + and M.Keys_Included_Except + (Model (Container), + Model (Container)'Old, + Key) + + -- Mapping from cursors to keys is preserved + + and Mapping_Preserved + (K_Left => Keys (Container)'Old, + K_Right => Keys (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)) + and P.Keys_Included_Except + (Positions (Container), + Positions (Container)'Old, + Find (Container, Key)); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Container.Capacity or Contains (Container, Key), + Post => + Contains (Container, Key) and Element (Container, Key) = New_Item, + Contract_Cases => + + -- If Key is already in Container, Key is mapped to New_Item + + (Contains (Container, Key) => + + -- Cursors are preserved + + Positions (Container) = Positions (Container)'Old + + -- The key equivalent to Key in Container is replaced by Key + + and K.Get + (Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) = Key + and K.Equal_Except + (Keys (Container)'Old, + Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) + + -- Elements associated with other keys are preserved + + and M.Same_Keys (Model (Container), Model (Container)'Old) + and M.Elements_Equal_Except + (Model (Container), + Model (Container)'Old, + Key), + + -- Otherwise, Key is inserted in Container + + others => + Length (Container) = Length (Container)'Old + 1 + + -- Other keys are preserved + + and Model (Container)'Old <= Model (Container) + and M.Keys_Included_Except + (Model (Container), + Model (Container)'Old, + Key) + + -- Key is inserted in Container + + and K.Get + (Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) = Key + + -- Mapping from cursors to keys is preserved + + and Mapping_Preserved + (K_Left => Keys (Container)'Old, + K_Right => Keys (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)) + and P.Keys_Included_Except + (Positions (Container), + Positions (Container)'Old, + Find (Container, Key))); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => Contains (Container, Key), + Post => + + -- Cursors are preserved + + Positions (Container) = Positions (Container)'Old + + -- The key equivalent to Key in Container is replaced by Key + + and K.Get + (Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) = Key + and K.Equal_Except + (Keys (Container)'Old, + Keys (Container), + P.Get (Positions (Container), Find (Container, Key))) + + -- New_Item is now associated with the Key in Container + + and Element (Model (Container), Key) = New_Item + + -- Elements associated with other keys are preserved + + and M.Same_Keys (Model (Container), Model (Container)'Old) + and M.Elements_Equal_Except + (Model (Container), + Model (Container)'Old, + Key); + + procedure Exclude (Container : in out Map; Key : Key_Type) with + Global => null, + Post => not Contains (Container, Key), + Contract_Cases => + + -- If Key is not in Container, nothing is changed + + (not Contains (Container, Key) => + Model (Container) = Model (Container)'Old + and Keys (Container) = Keys (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Key is removed from Container + + others => + Length (Container) = Length (Container)'Old - 1 + + -- Other keys are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- Mapping from cursors to keys is preserved + + and Mapping_Preserved + (K_Left => Keys (Container), + K_Right => Keys (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Find (Container, Key)'Old)); + + procedure Delete (Container : in out Map; Key : Key_Type) with + Global => null, + Pre => Contains (Container, Key), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Key is no longer in Container + + and not Contains (Container, Key) + + -- Other keys are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- Mapping from cursors to keys is preserved + + and Mapping_Preserved + (K_Left => Keys (Container), + K_Right => Keys (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Find (Container, Key)'Old); + + procedure Delete (Container : in out Map; Position : in out Cursor) with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Position = No_Element + and Length (Container) = Length (Container)'Old - 1 + + -- The key at position Position is no longer in Container + + and not Contains (Container, Key (Container, Position)'Old) + and not P.Has_Key (Positions (Container), Position'Old) + + -- Other keys are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + Key (Container, Position)'Old) + + -- Mapping from cursors to keys is preserved + + and Mapping_Preserved + (K_Left => Keys (Container), + K_Right => Keys (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Position'Old); + + function First (Container : Map) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + First'Result = No_Element, + + others => + Has_Element (Container, First'Result) + and P.Get (Positions (Container), First'Result) = 1); + + function Next (Container : Map; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Next'Result = No_Element, + + others => + Has_Element (Container, Next'Result) + and then P.Get (Positions (Container), Next'Result) = + P.Get (Positions (Container), Position) + 1); + + procedure Next (Container : Map; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) + 1); + + function Find (Container : Map; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + + -- If Key is not contained in Container, Find returns No_Element + + (not Contains (Model (Container), Key) => + Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + and P.Get (Positions (Container), Find'Result) = + Find (Keys (Container), Key) + + -- The key designated by the result of Find is Key + + and Equivalent_Keys + (Formal_Hashed_Maps.Key (Container, Find'Result), Key)); + + function Contains (Container : Map; Key : Key_Type) return Boolean with + Global => null, + Post => Contains'Result = Contains (Model (Container), Key); + pragma Annotate (GNATprove, Inline_For_Proof, Contains); + + function Element (Container : Map; Key : Key_Type) return Element_Type with + Global => null, + Pre => Contains (Container, Key), + Post => Element'Result = Element (Model (Container), Key); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + function Has_Element (Container : Map; Position : Cursor) return Boolean + with + Global => null, + Post => + Has_Element'Result = P.Has_Key (Positions (Container), Position); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + function Default_Modulus (Capacity : Count_Type) return Hash_Type with + Global => null; + +private + pragma SPARK_Mode (Off); + + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + pragma Inline (Next); + + type Node_Type is record + Key : Key_Type; + Element : Element_Type; + Next : Count_Type; + Has_Element : Boolean := False; + end record; + + package HT_Types is new + Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + + type Map (Capacity : Count_Type; Modulus : Hash_Type) is + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + + use HT_Types; + + Empty_Map : constant Map := (Capacity => 0, Modulus => 0, others => <>); + +end Ada.Containers.Formal_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cfhase.adb b/gcc/ada/libgnat/a-cfhase.adb new file mode 100644 index 0000000..9b2c9a4 --- /dev/null +++ b/gcc/ada/libgnat/a-cfhase.adb @@ -0,0 +1,1573 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Bounded_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations); + +with Ada.Containers.Hash_Tables.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys); + +with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Formal_Hashed_Sets with + SPARK_Mode => Off +is + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- All need comments ??? + + procedure Difference (Left : Set; Right : Set; Target : in out Set); + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Keys); + + procedure Free + (HT : in out Set; + X : Count_Type); + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (HT : in out Set; + Node : out Count_Type); + + function Hash_Node (Node : Node_Type) return Hash_Type; + pragma Inline (Hash_Node); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Intersection + (Left : Set; + Right : Set; + Target : in out Set); + + function Is_In + (HT : Set; + Key : Node_Type) return Boolean; + pragma Inline (Is_In); + + procedure Set_Element (Node : in out Node_Type; Item : Element_Type); + pragma Inline (Set_Element); + + function Next (Node : Node_Type) return Count_Type; + pragma Inline (Next); + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type); + pragma Inline (Set_Next); + + function Vet (Container : Set; Position : Cursor) return Boolean; + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Bounded_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next); + + package Element_Keys is new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + if Length (Left) = 0 then + return True; + end if; + + declare + Node : Count_Type; + ENode : Count_Type; + + begin + Node := First (Left).Node; + while Node /= 0 loop + ENode := + Find + (Container => Right, + Item => Left.Nodes (Node).Element).Node; + + if ENode = 0 + or else Right.Nodes (ENode).Element /= Left.Nodes (Node).Element + then + return False; + end if; + + Node := HT_Ops.Next (Left, Node); + end loop; + + return True; + end; + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + procedure Insert_Element (Source_Node : Count_Type); + + procedure Insert_Elements is + new HT_Ops.Generic_Iteration (Insert_Element); + + -------------------- + -- Insert_Element -- + -------------------- + + procedure Insert_Element (Source_Node : Count_Type) is + N : Node_Type renames Source.Nodes (Source_Node); + X : Count_Type; + B : Boolean; + + begin + Insert (Target, N.Element, X, B); + pragma Assert (B); + end Insert_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Length (Source) then + raise Storage_Error with "not enough capacity"; -- SE or CE? ??? + end if; + + HT_Ops.Clear (Target); + Insert_Elements (Source); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Set) return Count_Type is + begin + return Container.Nodes'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + begin + HT_Ops.Clear (Container); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Set; + Capacity : Count_Type := 0) return Set + is + C : constant Count_Type := + Count_Type'Max (Capacity, Source.Capacity); + Cu : Cursor; + H : Hash_Type; + N : Count_Type; + Target : Set (C, Source.Modulus); + + begin + if 0 < Capacity and then Capacity < Source.Capacity then + raise Capacity_Error; + end if; + + Target.Length := Source.Length; + Target.Free := Source.Free; + + H := 1; + while H <= Source.Modulus loop + Target.Buckets (H) := Source.Buckets (H); + H := H + 1; + end loop; + + N := 1; + while N <= Source.Capacity loop + Target.Nodes (N) := Source.Nodes (N); + N := N + 1; + end loop; + + while N <= C loop + Cu := (Node => N); + Free (Target, Cu.Node); + N := N + 1; + end loop; + + return Target; + end Copy; + + --------------------- + -- Default_Modulus -- + --------------------- + + function Default_Modulus (Capacity : Count_Type) return Hash_Type is + begin + return To_Prime (Capacity); + end Default_Modulus; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : Count_Type; + + begin + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + + if X = 0 then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Free (Container, X); + end Delete; + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container, Position.Node); + Free (Container, Position.Node); + + Position := No_Element; + end Delete; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + Src_Last : Count_Type; + Src_Length : Count_Type; + Src_Node : Count_Type; + Tgt_Node : Count_Type; + + TN : Nodes_Type renames Target.Nodes; + SN : Nodes_Type renames Source.Nodes; + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Src_Length := Source.Length; + + if Src_Length = 0 then + return; + end if; + + if Src_Length >= Target.Length then + Tgt_Node := HT_Ops.First (Target); + while Tgt_Node /= 0 loop + if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then + declare + X : constant Count_Type := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (Target, X); + end; + + else + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + end if; + end loop; + + return; + else + Src_Node := HT_Ops.First (Source); + Src_Last := 0; + end if; + + while Src_Node /= Src_Last loop + Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element); + + if Tgt_Node /= 0 then + HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node); + Free (Target, Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Source, Src_Node); + end loop; + end Difference; + + procedure Difference (Left : Set; Right : Set; Target : in out Set) is + procedure Process (L_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Count_Type) is + B : Boolean; + E : Element_Type renames Left.Nodes (L_Node).Element; + X : Count_Type; + + begin + if Find (Right, E).Node = 0 then + Insert (Target, E, X, B); + pragma Assert (B); + end if; + end Process; + + -- Start of processing for Difference + + begin + Iterate (Left); + end Difference; + + function Difference (Left : Set; Right : Set) return Set is + C : Count_Type; + H : Hash_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Length (Left) = 0 then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + C := Length (Left); + H := Default_Modulus (C); + + return S : Set (C, H) do + Difference (Left, Right, Target => S); + end return; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Position : Cursor) return Element_Type + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in function Element"); + + return Container.Nodes (Position.Node).Element; + end Element; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean; + pragma Inline (Find_Equivalent_Key); + + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); + + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type'Class; + L_Node : Node_Type) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); + R_Node : Count_Type := R_HT.Buckets (R_Index); + RN : Nodes_Type renames R_HT.Nodes; + + begin + loop + if R_Node = 0 then + return False; + end if; + + if Equivalent_Elements + (L_Node.Element, RN (R_Node).Element) + then + return True; + end if; + + R_Node := HT_Ops.Next (R_HT, R_Node); + end loop; + end Find_Equivalent_Key; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); + end Equivalent_Sets; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Type) return Boolean + is + begin + return Equivalent_Elements (Key, Node.Element); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : Count_Type; + begin + Element_Keys.Delete_Key_Sans_Free (Container, Item, X); + Free (Container, X); + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + Node : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + Node : constant Count_Type := HT_Ops.First (Container); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end First; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ------------------------- + -- E_Elements_Included -- + ------------------------- + + function E_Elements_Included + (Left : E.Sequence; + Right : E.Sequence) return Boolean + is + begin + for I in 1 .. E.Length (Left) loop + if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) + then + return False; + end if; + end loop; + + return True; + end E_Elements_Included; + + function E_Elements_Included + (Left : E.Sequence; + Model : M.Set; + Right : E.Sequence) return Boolean + is + begin + for I in 1 .. E.Length (Left) loop + declare + Item : constant Element_Type := E.Get (Left, I); + begin + if M.Contains (Model, Item) then + if not E.Contains (Right, 1, E.Length (Right), Item) then + return False; + end if; + end if; + end; + end loop; + + return True; + end E_Elements_Included; + + function E_Elements_Included + (Container : E.Sequence; + Model : M.Set; + Left : E.Sequence; + Right : E.Sequence) return Boolean + is + begin + for I in 1 .. E.Length (Container) loop + declare + Item : constant Element_Type := E.Get (Container, I); + begin + if M.Contains (Model, Item) then + if not E.Contains (Left, 1, E.Length (Left), Item) then + return False; + end if; + else + if not E.Contains (Right, 1, E.Length (Right), Item) then + return False; + end if; + end if; + end; + end loop; + + return True; + end E_Elements_Included; + + ---------- + -- Find -- + ---------- + + function Find + (Container : E.Sequence; + Item : Element_Type) return Count_Type + is + begin + for I in 1 .. E.Length (Container) loop + if Equivalent_Elements (Item, E.Get (Container, I)) then + return I; + end if; + end loop; + return 0; + end Find; + + -------------- + -- Elements -- + -------------- + + function Elements (Container : Set) return E.Sequence is + Position : Count_Type := HT_Ops.First (Container); + R : E.Sequence; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := E.Add (R, Container.Nodes (Position).Element); + Position := HT_Ops.Next (Container, Position); + end loop; + + return R; + end Elements; + + ---------------------------- + -- Lift_Abstraction_Level -- + ---------------------------- + + procedure Lift_Abstraction_Level (Container : Set) is null; + + ----------------------- + -- Mapping_Preserved -- + ----------------------- + + function Mapping_Preserved + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + is + begin + for C of P_Left loop + if not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > E.Length (E_Left) + or else P.Get (P_Right, C) > E.Length (E_Right) + or else E.Get (E_Left, P.Get (P_Left, C)) /= + E.Get (E_Right, P.Get (P_Right, C)) + then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved; + + ------------------------------ + -- Mapping_Preserved_Except -- + ------------------------------ + + function Mapping_Preserved_Except + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map; + Position : Cursor) return Boolean + is + begin + for C of P_Left loop + if C /= Position + and (not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > E.Length (E_Left) + or else P.Get (P_Right, C) > E.Length (E_Right) + or else E.Get (E_Left, P.Get (P_Left, C)) /= + E.Get (E_Right, P.Get (P_Right, C))) + then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved_Except; + + ----------- + -- Model -- + ----------- + + function Model (Container : Set) return M.Set is + Position : Count_Type := HT_Ops.First (Container); + R : M.Set; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := + M.Add + (Container => R, + Item => Container.Nodes (Position).Element); + + Position := HT_Ops.Next (Container, Position); + end loop; + + return R; + end Model; + + --------------- + -- Positions -- + --------------- + + function Positions (Container : Set) return P.Map is + I : Count_Type := 1; + Position : Count_Type := HT_Ops.First (Container); + R : P.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := P.Add (R, (Node => Position), I); + pragma Assert (P.Length (R) = I); + Position := HT_Ops.Next (Container, Position); + I := I + 1; + end loop; + + return R; + end Positions; + + end Formal_Model; + + ---------- + -- Free -- + ---------- + + procedure Free (HT : in out Set; X : Count_Type) is + begin + HT.Nodes (X).Has_Element := False; + HT_Ops.Free (HT, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate (HT : in out Set; Node : out Count_Type) is + procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element); + begin + Allocate (HT, Node); + HT.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + package body Generic_Keys with SPARK_Mode => Off is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean; + pragma Inline (Equivalent_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is new Hash_Tables.Generic_Bounded_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : Count_Type; + + begin + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + + if X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Free (Container, X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + Node : constant Count_Type := Find (Container, Key).Node; + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Type) return Boolean + is + begin + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); + end Equivalent_Key_Node; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : Count_Type; + begin + Key_Keys.Delete_Key_Sans_Free (Container, Key, X); + Free (Container, X); + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + begin + return (if Node = 0 then No_Element else (Node => Node)); + end Find; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ----------------------- + -- M_Included_Except -- + ----------------------- + + function M_Included_Except + (Left : M.Set; + Right : M.Set; + Key : Key_Type) return Boolean + is + begin + for E of Left loop + if not Contains (Right, E) + and not Equivalent_Keys (Generic_Keys.Key (E), Key) + then + return False; + end if; + end loop; + + return True; + end M_Included_Except; + + end Formal_Model; + + --------- + -- Key -- + --------- + + function Key (Container : Set; Position : Cursor) return Key_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in function Key"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + return Key (N.Element); + end; + end Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "attempt to replace key not in set"; + end if; + + Replace_Element (Container, Node, New_Item); + end Replace; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + if Position.Node = 0 + or else not Container.Nodes (Position.Node).Has_Element + then + return False; + end if; + + return True; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Type) return Hash_Type is + begin + return Hash (Node.Element); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Inserted : Boolean; + Position : Cursor; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + Container.Nodes (Position.Node).Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert (Container, New_Item, Position.Node, Inserted); + end Insert; + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Inserted : Boolean; + Position : Cursor; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + procedure Allocate_Set_Element (Node : in out Node_Type); + pragma Inline (Allocate_Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + procedure Allocate is + new Generic_Allocate (Allocate_Set_Element); + + --------------------------- + -- Allocate_Set_Element -- + --------------------------- + + procedure Allocate_Set_Element (Node : in out Node_Type) is + begin + Node.Element := New_Item; + end Allocate_Set_Element; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + -- Start of processing for Insert + + begin + Local_Insert (Container, New_Item, Node, Inserted); + end Insert; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + Tgt_Node : Count_Type; + TN : Nodes_Type renames Target.Nodes; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + Tgt_Node := HT_Ops.First (Target); + while Tgt_Node /= 0 loop + if Find (Source, TN (Tgt_Node).Element).Node /= 0 then + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + + else + declare + X : constant Count_Type := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target, X); + Free (Target, X); + end; + end if; + end loop; + end Intersection; + + procedure Intersection (Left : Set; Right : Set; Target : in out Set) is + procedure Process (L_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Count_Type) is + E : Element_Type renames Left.Nodes (L_Node).Element; + X : Count_Type; + B : Boolean; + + begin + if Find (Right, E).Node /= 0 then + Insert (Target, E, X, B); + pragma Assert (B); + end if; + end Process; + + -- Start of processing for Intersection + + begin + Iterate (Left); + end Intersection; + + function Intersection (Left : Set; Right : Set) return Set is + C : Count_Type; + H : Hash_Type; + + begin + if Left'Address = Right'Address then + return Left.Copy; + end if; + + C := Count_Type'Min (Length (Left), Length (Right)); -- ??? + H := Default_Modulus (C); + + return S : Set (C, H) do + if Length (Left) /= 0 and Length (Right) /= 0 then + Intersection (Left, Right, Target => S); + end if; + end return; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ----------- + -- Is_In -- + ----------- + + function Is_In (HT : Set; Key : Node_Type) return Boolean is + begin + return Element_Keys.Find (HT, Key.Element) /= 0; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + Subset_Node : Count_Type; + Subset_Nodes : Nodes_Type renames Subset.Nodes; + + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Length (Subset) > Length (Of_Set) then + return False; + end if; + + Subset_Node := First (Subset).Node; + while Subset_Node /= 0 loop + declare + N : Node_Type renames Subset_Nodes (Subset_Node); + E : Element_Type renames N.Element; + + begin + if Find (Of_Set, E).Node = 0 then + return False; + end if; + end; + + Subset_Node := HT_Ops.Next (Subset, Subset_Node); + end loop; + + return True; + end Is_Subset; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + -- Comments??? + + procedure Move (Target : in out Set; Source : in out Set) is + NN : HT_Types.Nodes_Type renames Source.Nodes; + X, Y : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + Clear (Target); + + if Source.Length = 0 then + return; + end if; + + X := HT_Ops.First (Source); + while X /= 0 loop + Insert (Target, NN (X).Element); -- optimize??? + + Y := HT_Ops.Next (Source, X); + + HT_Ops.Delete_Node_Sans_Free (Source, X); + Free (Source, X); + + X := Y; + end loop; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Type) return Count_Type is + begin + return Node.Next; + end Next; + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position has no element"; + end if; + + pragma Assert (Vet (Container, Position), "bad cursor in Next"); + + return (Node => HT_Ops.Next (Container, Position.Node)); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + Left_Node : Count_Type; + Left_Nodes : Nodes_Type renames Left.Nodes; + + begin + if Length (Right) = 0 or Length (Left) = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + Left_Node := First (Left).Node; + while Left_Node /= 0 loop + declare + N : Node_Type renames Left_Nodes (Left_Node); + E : Element_Type renames N.Element; + begin + if Find (Right, E).Node /= 0 then + return True; + end if; + end; + + Left_Node := HT_Ops.Next (Left, Left_Node); + end loop; + + return False; + end Overlap; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Count_Type := Element_Keys.Find (Container, New_Item); + + begin + if Node = 0 then + raise Constraint_Error with "attempt to replace element not in set"; + end if; + + Container.Nodes (Node).Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert + (Vet (Container, Position), "bad cursor in Replace_Element"); + + Replace_Element (Container, Position.Node, New_Item); + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + is + begin + if Capacity > Container.Capacity then + raise Constraint_Error with "requested capacity is too large"; + end if; + end Reserve_Capacity; + + ------------------ + -- Set_Element -- + ------------------ + + procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is + begin + Node.Element := Item; + end Set_Element; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is + begin + Node.Next := Next; + end Set_Next; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + procedure Process (Source_Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Source_Node : Count_Type) is + B : Boolean; + N : Node_Type renames Source.Nodes (Source_Node); + X : Count_Type; + + begin + if Is_In (Target, N) then + Delete (Target, N.Element); + else + Insert (Target, N.Element, X, B); + pragma Assert (B); + end if; + end Process; + + -- Start of processing for Symmetric_Difference + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Length (Target) = 0 then + Assign (Target, Source); + return; + end if; + + Iterate (Source); + end Symmetric_Difference; + + function Symmetric_Difference (Left : Set; Right : Set) return Set is + C : Count_Type; + H : Hash_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + end if; + + C := Length (Left) + Length (Right); + H := Default_Modulus (C); + + return S : Set (C, H) do + Difference (Left, Right, S); + Difference (Right, Left, S); + end return; + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + X : Count_Type; + B : Boolean; + + begin + return S : Set (Capacity => 1, Modulus => 1) do + Insert (S, New_Item, X, B); + pragma Assert (B); + end return; + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + procedure Process (Src_Node : Count_Type); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Count_Type) is + N : Node_Type renames Source.Nodes (Src_Node); + E : Element_Type renames N.Element; + + X : Count_Type; + B : Boolean; + + begin + Insert (Target, E, X, B); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + Iterate (Source); + end Union; + + function Union (Left : Set; Right : Set) return Set is + C : Count_Type; + H : Hash_Type; + + begin + if Left'Address = Right'Address then + return Left.Copy; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + end if; + + C := Length (Left) + Length (Right); + H := Default_Modulus (C); + return S : Set (C, H) do + Assign (Target => S, Source => Left); + Union (Target => S, Source => Right); + end return; + end Union; + + --------- + -- Vet -- + --------- + + function Vet (Container : Set; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return True; + end if; + + declare + S : Set renames Container; + N : Nodes_Type renames S.Nodes; + X : Count_Type; + + begin + if S.Length = 0 then + return False; + end if; + + if Position.Node > N'Last then + return False; + end if; + + if N (Position.Node).Next = Position.Node then + return False; + end if; + + X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element)); + + for J in 1 .. S.Length loop + if X = Position.Node then + return True; + end if; + + if X = 0 then + return False; + end if; + + if X = N (X).Next then -- to prevent unnecessary looping + return False; + end if; + + X := N (X).Next; + end loop; + + return False; + end; + end Vet; + +end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cfhase.ads b/gcc/ada/libgnat/a-cfhase.ads new file mode 100644 index 0000000..fd3d007 --- /dev/null +++ b/gcc/ada/libgnat/a-cfhase.ads @@ -0,0 +1,1335 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This spec is derived from package Ada.Containers.Bounded_Hashed_Sets in the +-- Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. + +-- The modifications are: + +-- A parameter for the container is added to every function reading the +-- content of a container: Element, Next, Query_Element, Has_Element, Key, +-- Iterate, Equivalent_Elements. This change is motivated by the need to +-- have cursors which are valid on different containers (typically a +-- container C and its previous version C'Old) for expressing properties, +-- which is not possible if cursors encapsulate an access to the underlying +-- container. + +with Ada.Containers.Functional_Maps; +with Ada.Containers.Functional_Sets; +with Ada.Containers.Functional_Vectors; +private with Ada.Containers.Hash_Tables; + +generic + type Element_Type is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + with function Equivalent_Elements + (Left : Element_Type; + Right : Element_Type) return Boolean is "="; + +package Ada.Containers.Formal_Hashed_Sets with + SPARK_Mode +is + pragma Annotate (CodePeer, Skip_Analysis); + + type Set (Capacity : Count_Type; Modulus : Hash_Type) is private with + Iterable => (First => First, + Next => Next, + Has_Element => Has_Element, + Element => Element), + Default_Initial_Condition => Is_Empty (Set); + pragma Preelaborable_Initialization (Set); + + type Cursor is record + Node : Count_Type; + end record; + + No_Element : constant Cursor := (Node => 0); + + function Length (Container : Set) return Count_Type with + Global => null, + Post => Length'Result <= Container.Capacity; + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package M is new Ada.Containers.Functional_Sets + (Element_Type => Element_Type, + Equivalent_Elements => Equivalent_Elements); + + function "=" + (Left : M.Set; + Right : M.Set) return Boolean renames M."="; + + function "<=" + (Left : M.Set; + Right : M.Set) return Boolean renames M."<="; + + package E is new Ada.Containers.Functional_Vectors + (Element_Type => Element_Type, + Index_Type => Positive_Count_Type); + + function "=" + (Left : E.Sequence; + Right : E.Sequence) return Boolean renames E."="; + + function "<" + (Left : E.Sequence; + Right : E.Sequence) return Boolean renames E."<"; + + function "<=" + (Left : E.Sequence; + Right : E.Sequence) return Boolean renames E."<="; + + function Find + (Container : E.Sequence; + Item : Element_Type) return Count_Type + -- Search for Item in Container + + with + Global => null, + Post => + (if Find'Result > 0 then + Find'Result <= E.Length (Container) + and Equivalent_Elements + (Item, E.Get (Container, Find'Result))); + + function E_Elements_Included + (Left : E.Sequence; + Right : E.Sequence) return Boolean + -- The elements of Left are contained in Right + + with + Global => null, + Post => + E_Elements_Included'Result = + (for all I in 1 .. E.Length (Left) => + Find (Right, E.Get (Left, I)) > 0 + and then E.Get (Right, Find (Right, E.Get (Left, I))) = + E.Get (Left, I)); + pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); + + function E_Elements_Included + (Left : E.Sequence; + Model : M.Set; + Right : E.Sequence) return Boolean + -- The elements of Container contained in Model are in Right + + with + Global => null, + Post => + E_Elements_Included'Result = + (for all I in 1 .. E.Length (Left) => + (if M.Contains (Model, E.Get (Left, I)) then + Find (Right, E.Get (Left, I)) > 0 + and then E.Get (Right, Find (Right, E.Get (Left, I))) = + E.Get (Left, I))); + pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); + + function E_Elements_Included + (Container : E.Sequence; + Model : M.Set; + Left : E.Sequence; + Right : E.Sequence) return Boolean + -- The elements of Container contained in Model are in Left and others + -- are in Right. + + with + Global => null, + Post => + E_Elements_Included'Result = + (for all I in 1 .. E.Length (Container) => + (if M.Contains (Model, E.Get (Container, I)) then + Find (Left, E.Get (Container, I)) > 0 + and then E.Get (Left, Find (Left, E.Get (Container, I))) = + E.Get (Container, I) + else + Find (Right, E.Get (Container, I)) > 0 + and then E.Get + (Right, Find (Right, E.Get (Container, I))) = + E.Get (Container, I))); + pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); + + package P is new Ada.Containers.Functional_Maps + (Key_Type => Cursor, + Element_Type => Positive_Count_Type, + Equivalent_Keys => "=", + Enable_Handling_Of_Equivalence => False); + + function "=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."="; + + function "<=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."<="; + + function Mapping_Preserved + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + with + Ghost, + Global => null, + Post => + (if Mapping_Preserved'Result then + + -- Right contains all the cursors of Left + + P.Keys_Included (P_Left, P_Right) + + -- Right contains all the elements of Left + + and E_Elements_Included (E_Left, E_Right) + + -- Mappings from cursors to elements induced by E_Left, P_Left + -- and E_Right, P_Right are the same. + + and (for all C of P_Left => + E.Get (E_Left, P.Get (P_Left, C)) = + E.Get (E_Right, P.Get (P_Right, C)))); + + function Mapping_Preserved_Except + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map; + Position : Cursor) return Boolean + with + Ghost, + Global => null, + Post => + (if Mapping_Preserved_Except'Result then + + -- Right contains all the cursors of Left + + P.Keys_Included (P_Left, P_Right) + + -- Mappings from cursors to elements induced by E_Left, P_Left + -- and E_Right, P_Right are the same except for Position. + + and (for all C of P_Left => + (if C /= Position then + E.Get (E_Left, P.Get (P_Left, C)) = + E.Get (E_Right, P.Get (P_Right, C))))); + + function Model (Container : Set) return M.Set with + -- The high-level model of a set is a set of elements. Neither cursors + -- nor order of elements are represented in this model. Elements are + -- modeled up to equivalence. + + Ghost, + Global => null, + Post => M.Length (Model'Result) = Length (Container); + + function Elements (Container : Set) return E.Sequence with + -- The Elements sequence represents the underlying list structure of + -- sets that is used for iteration. It stores the actual values of + -- elements in the set. It does not model cursors. + + Ghost, + Global => null, + Post => + E.Length (Elements'Result) = Length (Container) + + -- It only contains keys contained in Model + + and (for all Item of Elements'Result => + M.Contains (Model (Container), Item)) + + -- It contains all the elements contained in Model + + and (for all Item of Model (Container) => + (Find (Elements'Result, Item) > 0 + and then Equivalent_Elements + (E.Get (Elements'Result, + Find (Elements'Result, Item)), + Item))) + + -- It has no duplicate + + and (for all I in 1 .. Length (Container) => + Find (Elements'Result, E.Get (Elements'Result, I)) = I) + + and (for all I in 1 .. Length (Container) => + (for all J in 1 .. Length (Container) => + (if Equivalent_Elements + (E.Get (Elements'Result, I), + E.Get (Elements'Result, J)) + then I = J))); + pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); + + function Positions (Container : Set) return P.Map with + -- The Positions map is used to model cursors. It only contains valid + -- cursors and maps them to their position in the container. + + Ghost, + Global => null, + Post => + not P.Has_Key (Positions'Result, No_Element) + + -- Positions of cursors are smaller than the container's length + + and then + (for all I of Positions'Result => + P.Get (Positions'Result, I) in 1 .. Length (Container) + + -- No two cursors have the same position. Note that we do not + -- state that there is a cursor in the map for each position, as + -- it is rarely needed. + + and then + (for all J of Positions'Result => + (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) + then I = J))); + + procedure Lift_Abstraction_Level (Container : Set) with + -- Lift_Abstraction_Level is a ghost procedure that does nothing but + -- assume that we can access the same elements by iterating over + -- positions or cursors. + -- This information is not generally useful except when switching from + -- a low-level, cursor-aware view of a container, to a high-level, + -- position-based view. + + Ghost, + Global => null, + Post => + (for all Item of Elements (Container) => + (for some I of Positions (Container) => + E.Get (Elements (Container), P.Get (Positions (Container), I)) = + Item)); + + function Contains + (C : M.Set; + K : Element_Type) return Boolean renames M.Contains; + -- To improve readability of contracts, we rename the function used to + -- search for an element in the model to Contains. + + end Formal_Model; + use Formal_Model; + + Empty_Set : constant Set; + + function "=" (Left, Right : Set) return Boolean with + Global => null, + Post => + "="'Result = + (Length (Left) = Length (Right) + and E_Elements_Included (Elements (Left), Elements (Right))) + and + "="'Result = + (E_Elements_Included (Elements (Left), Elements (Right)) + and E_Elements_Included (Elements (Right), Elements (Left))); + + function Equivalent_Sets (Left, Right : Set) return Boolean with + Global => null, + Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); + + function To_Set (New_Item : Element_Type) return Set with + Global => null, + Post => + M.Is_Singleton (Model (To_Set'Result), New_Item) + and Length (To_Set'Result) = 1 + and E.Get (Elements (To_Set'Result), 1) = New_Item; + + function Capacity (Container : Set) return Count_Type with + Global => null, + Post => Capacity'Result = Container.Capacity; + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + with + Global => null, + Pre => Capacity <= Container.Capacity, + Post => + Model (Container) = Model (Container)'Old + and Length (Container)'Old = Length (Container) + + -- Actual elements are preserved + + and E_Elements_Included + (Elements (Container), Elements (Container)'Old) + and E_Elements_Included + (Elements (Container)'Old, Elements (Container)); + + function Is_Empty (Container : Set) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out Set) with + Global => null, + Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); + + procedure Assign (Target : in out Set; Source : Set) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Model (Target) = Model (Source) + and Length (Target) = Length (Source) + + -- Actual elements are preserved + + and E_Elements_Included (Elements (Target), Elements (Source)) + and E_Elements_Included (Elements (Source), Elements (Target)); + + function Copy + (Source : Set; + Capacity : Count_Type := 0) return Set + with + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity, + Post => + Model (Copy'Result) = Model (Source) + and Elements (Copy'Result) = Elements (Source) + and Positions (Copy'Result) = Positions (Source) + and (if Capacity = 0 then + Copy'Result.Capacity = Source.Capacity + else + Copy'Result.Capacity = Capacity); + + function Element + (Container : Set; + Position : Cursor) return Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Element'Result = + E.Get (Elements (Container), P.Get (Positions (Container), Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old + + -- Position now maps to New_Item + + and Element (Container, Position) = New_Item + + -- New_Item is contained in Container + + and Contains (Model (Container), New_Item) + + -- Other elements are preserved + + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Element (Container, Position)'Old) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved_Except + (E_Left => Elements (Container)'Old, + E_Right => Elements (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container), + Position => Position) + and Positions (Container) = Positions (Container)'Old; + + procedure Move (Target : in out Set; Source : in out Set) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Length (Source) = 0 + and Model (Target) = Model (Source)'Old + and Length (Target) = Length (Source)'Old + + -- Actual elements are preserved + + and E_Elements_Included (Elements (Target), Elements (Source)'Old) + and E_Elements_Included (Elements (Source)'Old, Elements (Target)); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + or Contains (Container, New_Item), + Post => + Contains (Container, New_Item) + and Has_Element (Container, Position) + and Equivalent_Elements (Element (Container, Position), New_Item), + Contract_Cases => + + -- If New_Item is already in Container, it is not modified and Inserted + -- is set to False. + + (Contains (Container, New_Item) => + not Inserted + and Model (Container) = Model (Container)'Old + and Elements (Container) = Elements (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, New_Item is inserted in Container and Inserted is set to + -- True. + + others => + Inserted + and Length (Container) = Length (Container)'Old + 1 + + -- Position now maps to New_Item + + and Element (Container, Position) = New_Item + + -- Other elements are preserved + + and Model (Container)'Old <= Model (Container) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container)'Old, + E_Right => Elements (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)) + and P.Keys_Included_Except + (Positions (Container), + Positions (Container)'Old, + Position)); + + procedure Insert (Container : in out Set; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Container.Capacity + and then (not Contains (Container, New_Item)), + Post => + Length (Container) = Length (Container)'Old + 1 + and Contains (Container, New_Item) + and Element (Container, Find (Container, New_Item)) = New_Item + + -- Other elements are preserved + + and Model (Container)'Old <= Model (Container) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container)'Old, + E_Right => Elements (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)) + and P.Keys_Included_Except + (Positions (Container), + Positions (Container)'Old, + Find (Container, New_Item)); + + procedure Include (Container : in out Set; New_Item : Element_Type) with + Global => null, + Pre => + Length (Container) < Container.Capacity + or Contains (Container, New_Item), + Post => + Contains (Container, New_Item) + and Element (Container, Find (Container, New_Item)) = New_Item, + Contract_Cases => + + -- If an element equivalent to New_Item is already in Container, it is + -- replaced by New_Item. + + (Contains (Container, New_Item) => + + -- Elements are preserved modulo equivalence + + Model (Container) = Model (Container)'Old + + -- Cursors are preserved + + and Positions (Container) = Positions (Container)'Old + + -- The actual value of other elements is preserved + + and E.Equal_Except + (Elements (Container)'Old, + Elements (Container), + P.Get (Positions (Container), Find (Container, New_Item))), + + -- Otherwise, New_Item is inserted in Container + + others => + Length (Container) = Length (Container)'Old + 1 + + -- Other elements are preserved + + and Model (Container)'Old <= Model (Container) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container)'Old, + E_Right => Elements (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container)) + and P.Keys_Included_Except + (Positions (Container), + Positions (Container)'Old, + Find (Container, New_Item))); + + procedure Replace (Container : in out Set; New_Item : Element_Type) with + Global => null, + Pre => Contains (Container, New_Item), + Post => + + -- Elements are preserved modulo equivalence + + Model (Container) = Model (Container)'Old + and Contains (Container, New_Item) + + -- Cursors are preserved + + and Positions (Container) = Positions (Container)'Old + + -- The element equivalent to New_Item in Container is replaced by + -- New_Item. + + and Element (Container, Find (Container, New_Item)) = New_Item + and E.Equal_Except + (Elements (Container)'Old, + Elements (Container), + P.Get (Positions (Container), Find (Container, New_Item))); + + procedure Exclude (Container : in out Set; Item : Element_Type) with + Global => null, + Post => not Contains (Container, Item), + Contract_Cases => + + -- If Item is not in Container, nothing is changed + + (not Contains (Container, Item) => + Model (Container) = Model (Container)'Old + and Elements (Container) = Elements (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Item is removed from Container + + others => + Length (Container) = Length (Container)'Old - 1 + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container), + E_Right => Elements (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Find (Container, Item)'Old)); + + procedure Delete (Container : in out Set; Item : Element_Type) with + Global => null, + Pre => Contains (Container, Item), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Item is no longer in Container + + and not Contains (Container, Item) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container), + E_Right => Elements (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Find (Container, Item)'Old); + + procedure Delete (Container : in out Set; Position : in out Cursor) with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Position = No_Element + and Length (Container) = Length (Container)'Old - 1 + + -- The element at position Position is no longer in Container + + and not Contains (Container, Element (Container, Position)'Old) + and not P.Has_Key (Positions (Container), Position'Old) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Element (Container, Position)'Old) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container), + E_Right => Elements (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Position'Old); + + procedure Union (Target : in out Set; Source : Set) with + Global => null, + Pre => + Length (Source) - Length (Target and Source) <= + Target.Capacity - Length (Target), + Post => + Length (Target) = Length (Target)'Old + - M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + Length (Source) + + -- Elements already in Target are still in Target + + and Model (Target)'Old <= Model (Target) + + -- Elements of Source are included in Target + + and Model (Source) <= Model (Target) + + -- Elements of Target come from either Source or Target + + and M.Included_In_Union + (Model (Target), Model (Source), Model (Target)'Old) + + -- Actual value of elements come from either Left or Right + + and E_Elements_Included + (Elements (Target), + Model (Target)'Old, + Elements (Target)'Old, + Elements (Source)) + + and E_Elements_Included + (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) + + and E_Elements_Included + (Elements (Source), + Model (Target)'Old, + Elements (Source), + Elements (Target)) + + -- Mapping from cursors of Target to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Target)'Old, + E_Right => Elements (Target), + P_Left => Positions (Target)'Old, + P_Right => Positions (Target)); + + function Union (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) <= Count_Type'Last - Length (Right), + Post => + Length (Union'Result) = Length (Left) + - M.Num_Overlaps (Model (Left), Model (Right)) + + Length (Right) + + -- Elements of Left and Right are in the result of Union + + and Model (Left) <= Model (Union'Result) + and Model (Right) <= Model (Union'Result) + + -- Elements of the result of union come from either Left or Right + + and + M.Included_In_Union + (Model (Union'Result), Model (Left), Model (Right)) + + -- Actual value of elements come from either Left or Right + + and E_Elements_Included + (Elements (Union'Result), + Model (Left), + Elements (Left), + Elements (Right)) + + and E_Elements_Included + (Elements (Left), Model (Left), Elements (Union'Result)) + + and E_Elements_Included + (Elements (Right), + Model (Left), + Elements (Right), + Elements (Union'Result)); + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set) with + Global => null, + Post => + Length (Target) = + M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + -- Elements of Target were already in Target + + and Model (Target) <= Model (Target)'Old + + -- Elements of Target are in Source + + and Model (Target) <= Model (Source) + + -- Elements both in Source and Target are in the intersection + + and M.Includes_Intersection + (Model (Target), Model (Source), Model (Target)'Old) + + -- Actual value of elements of Target is preserved + + and E_Elements_Included (Elements (Target), Elements (Target)'Old) + and E_Elements_Included + (Elements (Target)'Old, Model (Source), Elements (Target)) + + -- Mapping from cursors of Target to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Target), + E_Right => Elements (Target)'Old, + P_Left => Positions (Target), + P_Right => Positions (Target)'Old); + + function Intersection (Left, Right : Set) return Set with + Global => null, + Post => + Length (Intersection'Result) = + M.Num_Overlaps (Model (Left), Model (Right)) + + -- Elements in the result of Intersection are in Left and Right + + and Model (Intersection'Result) <= Model (Left) + and Model (Intersection'Result) <= Model (Right) + + -- Elements both in Left and Right are in the result of Intersection + + and M.Includes_Intersection + (Model (Intersection'Result), Model (Left), Model (Right)) + + -- Actual value of elements come from Left + + and E_Elements_Included + (Elements (Intersection'Result), Elements (Left)) + + and E_Elements_Included + (Elements (Left), Model (Right), + Elements (Intersection'Result)); + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set) with + Global => null, + Post => + Length (Target) = Length (Target)'Old - + M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + -- Elements of Target were already in Target + + and Model (Target) <= Model (Target)'Old + + -- Elements of Target are not in Source + + and M.No_Overlap (Model (Target), Model (Source)) + + -- Elements in Target but not in Source are in the difference + + and M.Included_In_Union + (Model (Target)'Old, Model (Target), Model (Source)) + + -- Actual value of elements of Target is preserved + + and E_Elements_Included (Elements (Target), Elements (Target)'Old) + and E_Elements_Included + (Elements (Target)'Old, Model (Target), Elements (Target)) + + -- Mapping from cursors of Target to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Target), + E_Right => Elements (Target)'Old, + P_Left => Positions (Target), + P_Right => Positions (Target)'Old); + + function Difference (Left, Right : Set) return Set with + Global => null, + Post => + Length (Difference'Result) = Length (Left) - + M.Num_Overlaps (Model (Left), Model (Right)) + + -- Elements of the result of Difference are in Left + + and Model (Difference'Result) <= Model (Left) + + -- Elements of the result of Difference are in Right + + and M.No_Overlap (Model (Difference'Result), Model (Right)) + + -- Elements in Left but not in Right are in the difference + + and M.Included_In_Union + (Model (Left), Model (Difference'Result), Model (Right)) + + -- Actual value of elements come from Left + + and E_Elements_Included + (Elements (Difference'Result), Elements (Left)) + + and E_Elements_Included + (Elements (Left), + Model (Difference'Result), + Elements (Difference'Result)); + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set) with + Global => null, + Pre => + Length (Source) - Length (Target and Source) <= + Target.Capacity - Length (Target) + Length (Target and Source), + Post => + Length (Target) = Length (Target)'Old - + 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + Length (Source) + + -- Elements of the difference were not both in Source and in Target + + and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) + + -- Elements in Target but not in Source are in the difference + + and M.Included_In_Union + (Model (Target)'Old, Model (Target), Model (Source)) + + -- Elements in Source but not in Target are in the difference + + and M.Included_In_Union + (Model (Source), Model (Target), Model (Target)'Old) + + -- Actual value of elements come from either Left or Right + + and E_Elements_Included + (Elements (Target), + Model (Target)'Old, + Elements (Target)'Old, + Elements (Source)) + + and E_Elements_Included + (Elements (Target)'Old, Model (Target), Elements (Target)) + + and E_Elements_Included + (Elements (Source), Model (Target), Elements (Target)); + + function Symmetric_Difference (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) <= Count_Type'Last - Length (Right), + Post => + Length (Symmetric_Difference'Result) = Length (Left) - + 2 * M.Num_Overlaps (Model (Left), Model (Right)) + + Length (Right) + + -- Elements of the difference were not both in Left and Right + + and M.Not_In_Both + (Model (Symmetric_Difference'Result), + Model (Left), + Model (Right)) + + -- Elements in Left but not in Right are in the difference + + and M.Included_In_Union + (Model (Left), + Model (Symmetric_Difference'Result), + Model (Right)) + + -- Elements in Right but not in Left are in the difference + + and M.Included_In_Union + (Model (Right), + Model (Symmetric_Difference'Result), + Model (Left)) + + -- Actual value of elements come from either Left or Right + + and E_Elements_Included + (Elements (Symmetric_Difference'Result), + Model (Left), + Elements (Left), + Elements (Right)) + + and E_Elements_Included + (Elements (Left), + Model (Symmetric_Difference'Result), + Elements (Symmetric_Difference'Result)) + + and E_Elements_Included + (Elements (Right), + Model (Symmetric_Difference'Result), + Elements (Symmetric_Difference'Result)); + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean with + Global => null, + Post => + Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with + Global => null, + Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); + + function First (Container : Set) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + First'Result = No_Element, + + others => + Has_Element (Container, First'Result) + and P.Get (Positions (Container), First'Result) = 1); + + function Next (Container : Set; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Next'Result = No_Element, + + others => + Has_Element (Container, Next'Result) + and then P.Get (Positions (Container), Next'Result) = + P.Get (Positions (Container), Position) + 1); + + procedure Next (Container : Set; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) + 1); + + function Find + (Container : Set; + Item : Element_Type) return Cursor + with + Global => null, + Contract_Cases => + + -- If Item is not contained in Container, Find returns No_Element + + (not Contains (Model (Container), Item) => + Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + and P.Get (Positions (Container), Find'Result) = + Find (Elements (Container), Item) + + -- The element designated by the result of Find is Item + + and Equivalent_Elements + (Element (Container, Find'Result), Item)); + + function Contains (Container : Set; Item : Element_Type) return Boolean with + Global => null, + Post => Contains'Result = Contains (Model (Container), Item); + pragma Annotate (GNATprove, Inline_For_Proof, Contains); + + function Has_Element (Container : Set; Position : Cursor) return Boolean + with + Global => null, + Post => + Has_Element'Result = P.Has_Key (Positions (Container), Position); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + function Default_Modulus (Capacity : Count_Type) return Hash_Type with + Global => null; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + package Generic_Keys with SPARK_Mode is + + package Formal_Model with Ghost is + + function M_Included_Except + (Left : M.Set; + Right : M.Set; + Key : Key_Type) return Boolean + with + Global => null, + Post => + M_Included_Except'Result = + (for all E of Left => + Contains (Right, E) + or Equivalent_Keys (Generic_Keys.Key (E), Key)); + + end Formal_Model; + use Formal_Model; + + function Key (Container : Set; Position : Cursor) return Key_Type with + Global => null, + Post => Key'Result = Key (Element (Container, Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Key); + + function Element (Container : Set; Key : Key_Type) return Element_Type + with + Global => null, + Pre => Contains (Container, Key), + Post => + Element'Result = Element (Container, Find (Container, Key)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => Contains (Container, Key), + Post => + Length (Container) = Length (Container)'Old + + -- Key now maps to New_Item + + and Element (Container, Key) = New_Item + + -- New_Item is contained in Container + + and Contains (Model (Container), New_Item) + + -- Other elements are preserved + + and M_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved_Except + (E_Left => Elements (Container)'Old, + E_Right => Elements (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container), + Position => Find (Container, Key)) + and Positions (Container) = Positions (Container)'Old; + + procedure Exclude (Container : in out Set; Key : Key_Type) with + Global => null, + Post => not Contains (Container, Key), + Contract_Cases => + + -- If Key is not in Container, nothing is changed + + (not Contains (Container, Key) => + Model (Container) = Model (Container)'Old + and Elements (Container) = Elements (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Key is removed from Container + + others => + Length (Container) = Length (Container)'Old - 1 + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container), + E_Right => Elements (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Find (Container, Key)'Old)); + + procedure Delete (Container : in out Set; Key : Key_Type) with + Global => null, + Pre => Contains (Container, Key), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Key is no longer in Container + + and not Contains (Container, Key) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Container), + E_Right => Elements (Container)'Old, + P_Left => Positions (Container), + P_Right => Positions (Container)'Old) + and P.Keys_Included_Except + (Positions (Container)'Old, + Positions (Container), + Find (Container, Key)'Old); + + function Find (Container : Set; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + + -- If Key is not contained in Container, Find returns No_Element + + ((for all E of Model (Container) => + not Equivalent_Keys (Key, Generic_Keys.Key (E))) => + Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + + -- The key designated by the result of Find is Key + + and Equivalent_Keys + (Generic_Keys.Key (Container, Find'Result), Key)); + + function Contains (Container : Set; Key : Key_Type) return Boolean with + Global => null, + Post => + Contains'Result = + (for some E of Model (Container) => + Equivalent_Keys (Key, Generic_Keys.Key (E))); + + end Generic_Keys; + +private + pragma SPARK_Mode (Off); + + pragma Inline (Next); + + type Node_Type is + record + Element : Element_Type; + Next : Count_Type; + Has_Element : Boolean := False; + end record; + + package HT_Types is new + Ada.Containers.Hash_Tables.Generic_Bounded_Hash_Table_Types (Node_Type); + + type Set (Capacity : Count_Type; Modulus : Hash_Type) is + new HT_Types.Hash_Table_Type (Capacity, Modulus) with null record; + + use HT_Types; + + Empty_Set : constant Set := (Capacity => 0, Modulus => 0, others => <>); + +end Ada.Containers.Formal_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cfinve.adb b/gcc/ada/libgnat/a-cfinve.adb new file mode 100644 index 0000000..8a9d11d --- /dev/null +++ b/gcc/ada/libgnat/a-cfinve.adb @@ -0,0 +1,1404 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Formal_Indefinite_Vectors with + SPARK_Mode => Off +is + function H (New_Item : Element_Type) return Holder renames To_Holder; + function E (Container : Holder) return Element_Type renames Get; + + Growth_Factor : constant := 2; + -- When growing a container, multiply current capacity by this. Doubling + -- leads to amortized linear-time copying. + + type Int is range System.Min_Int .. System.Max_Int; + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); + + type Maximal_Array_Ptr is access all Elements_Array (Array_Index) + with Storage_Size => 0; + type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) + with Storage_Size => 0; + + function Elems (Container : in out Vector) return Maximal_Array_Ptr; + function Elemsc + (Container : Vector) return Maximal_Array_Ptr_Const; + -- Returns a pointer to the Elements array currently in use -- either + -- Container.Elements_Ptr or a pointer to Container.Elements. We work with + -- pointers to a bogus array subtype that is constrained with the maximum + -- possible bounds. This means that the pointer is a thin pointer. This is + -- necessary because 'Unrestricted_Access doesn't work when it produces + -- access-to-unconstrained and is returned from a function. + -- + -- Note that this is dangerous: make sure calls to this use an indexed + -- component or slice that is within the bounds 1 .. Length (Container). + + function Get_Element + (Container : Vector; + Position : Capacity_Range) return Element_Type; + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; + + function Current_Capacity (Container : Vector) return Capacity_Range; + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + --------- + -- "=" -- + --------- + + function "=" (Left : Vector; Right : Vector) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + if Length (Left) /= Length (Right) then + return False; + end if; + + for J in 1 .. Length (Left) loop + if Get_Element (Left, J) /= Get_Element (Right, J) then + return False; + end if; + end loop; + + return True; + end "="; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then + return; + end if; + + if Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert (Container, Container.Last + 1, New_Item); + end Append; + + procedure Append (Container : in out Vector; New_Item : Element_Type) is + begin + Append (Container, New_Item, 1); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + is + begin + if Count = 0 then + return; + end if; + + if Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert (Container, Container.Last + 1, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + LS : constant Capacity_Range := Length (Source); + + begin + if Target'Address = Source'Address then + return; + end if; + + if Bounded and then Target.Capacity < LS then + raise Constraint_Error; + end if; + + Clear (Target); + Append (Target, Source); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Capacity_Range is + begin + return + (if Bounded then + Container.Capacity + else + Capacity_Range'Last); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + Container.Last := No_Index; + + -- Free element, note that this is OK if Elements_Ptr is null + + Free (Container.Elements_Ptr); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Capacity_Range := 0) return Vector + is + LS : constant Capacity_Range := Length (Source); + C : Capacity_Range; + + begin + if Capacity = 0 then + C := LS; + elsif Capacity >= LS then + C := Capacity; + else + raise Capacity_Error; + end if; + + return Target : Vector (C) do + Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS); + Target.Last := Source.Last; + end return; + end Copy; + + ---------------------- + -- Current_Capacity -- + ---------------------- + + function Current_Capacity (Container : Vector) return Capacity_Range is + begin + return + (if Container.Elements_Ptr = null then + Container.Elements'Length + else + Container.Elements_Ptr.all'Length); + end Current_Capacity; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Vector; Index : Extended_Index) is + begin + Delete (Container, Index, 1); + end Delete; + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type) + is + Old_Last : constant Index_Type'Base := Container.Last; + Old_Len : constant Count_Type := Length (Container); + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + Off : Count_Type'Base; -- Index expressed as offset from IT'First + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + end if; + + return; + end if; + + if Count = 0 then + return; + end if; + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. + + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; + + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Off := Count_Type'Base (Index - Index_Type'First); + New_Last := Old_Last - Index_Type'Base (Count); + else + Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + end if; + + -- The array index values for each slice have already been determined, + -- so we just slide down to Index the elements that weren't deleted. + + declare + EA : Maximal_Array_Ptr renames Elems (Container); + Idx : constant Count_Type := EA'First + Off; + + begin + EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); + Container.Last := New_Last; + end; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Vector) is + begin + Delete_First (Container, 1); + end Delete_First; + + procedure Delete_First (Container : in out Vector; Count : Count_Type) is + begin + if Count = 0 then + return; + + elsif Count >= Length (Container) then + Clear (Container); + return; + + else + Delete (Container, Index_Type'First, Count); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Vector) is + begin + Delete_Last (Container, 1); + end Delete_Last; + + procedure Delete_Last (Container : in out Vector; Count : Count_Type) is + begin + if Count = 0 then + return; + end if; + + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + + if Count >= Length (Container) then + Container.Last := No_Index; + + elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := Container.Last - Index_Type'Base (Count); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Capacity_Range := Capacity_Range (II); + + begin + return Get_Element (Container, I); + end; + end Element; + + -------------- + -- Elements -- + -------------- + + function Elems (Container : in out Vector) return Maximal_Array_Ptr is + begin + return + (if Container.Elements_Ptr = null then + Container.Elements'Unrestricted_Access + else + Container.Elements_Ptr.all'Unrestricted_Access); + end Elems; + + function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is + begin + return + (if Container.Elements_Ptr = null then + Container.Elements'Unrestricted_Access + else + Container.Elements_Ptr.all'Unrestricted_Access); + end Elemsc; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + K : Capacity_Range; + Last : constant Index_Type := Last_Index (Container); + + begin + K := Capacity_Range (Int (Index) - Int (No_Index)); + for Indx in Index .. Last loop + if Get_Element (Container, K) = Item then + return Indx; + end if; + + K := K + 1; + end loop; + + return No_Index; + end Find_Index; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "Container is empty"; + else + return Get_Element (Container, 1); + end if; + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ------------------------- + -- M_Elements_In_Union -- + ------------------------- + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + is + begin + for Index in Index_Type'First .. M.Last (Container) loop + declare + Elem : constant Element_Type := Element (Container, Index); + begin + if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) + and then + not M.Contains + (Right, Index_Type'First, M.Last (Right), Elem) + then + return False; + end if; + end; + end loop; + + return True; + end M_Elements_In_Union; + + ------------------------- + -- M_Elements_Included -- + ------------------------- + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Index_Type := Index_Type'First; + L_Lst : Extended_Index; + Right : M.Sequence; + R_Fst : Index_Type := Index_Type'First; + R_Lst : Extended_Index) return Boolean + is + begin + for I in L_Fst .. L_Lst loop + declare + Found : Boolean := False; + J : Extended_Index := R_Fst - 1; + + begin + while not Found and J < R_Lst loop + J := J + 1; + if Element (Left, I) = Element (Right, J) then + Found := True; + end if; + end loop; + + if not Found then + return False; + end if; + end; + end loop; + + return True; + end M_Elements_Included; + + ------------------------- + -- M_Elements_Reversed -- + ------------------------- + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + is + L : constant Index_Type := M.Last (Left); + + begin + if L /= M.Last (Right) then + return False; + end if; + + for I in Index_Type'First .. L loop + if Element (Left, I) /= Element (Right, L - I + 1) + then + return False; + end if; + end loop; + + return True; + end M_Elements_Reversed; + + ------------------------ + -- M_Elements_Swapted -- + ------------------------ + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Index_Type; + Y : Index_Type) return Boolean + is + begin + if M.Length (Left) /= M.Length (Right) + or else Element (Left, X) /= Element (Right, Y) + or else Element (Left, Y) /= Element (Right, X) + then + return False; + end if; + + for I in Index_Type'First .. M.Last (Left) loop + if I /= X and then I /= Y + and then Element (Left, I) /= Element (Right, I) + then + return False; + end if; + end loop; + + return True; + end M_Elements_Swapped; + + ----------- + -- Model -- + ----------- + + function Model (Container : Vector) return M.Sequence is + R : M.Sequence; + + begin + for Position in 1 .. Length (Container) loop + R := M.Add (R, E (Elemsc (Container) (Position))); + end loop; + + return R; + end Model; + + end Formal_Model; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting with SPARK_Mode => Off is + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ----------------------- + -- M_Elements_Sorted -- + ----------------------- + + function M_Elements_Sorted (Container : M.Sequence) return Boolean is + begin + if M.Length (Container) = 0 then + return True; + end if; + + declare + E1 : Element_Type := Element (Container, Index_Type'First); + + begin + for I in Index_Type'First + 1 .. M.Last (Container) loop + declare + E2 : constant Element_Type := Element (Container, I); + + begin + if E2 < E1 then + return False; + end if; + + E1 := E2; + end; + end loop; + end; + + return True; + end M_Elements_Sorted; + + end Formal_Model; + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + L : constant Capacity_Range := Length (Container); + + begin + for J in 1 .. L - 1 loop + if Get_Element (Container, J + 1) < Get_Element (Container, J) then + return False; + end if; + end loop; + + return True; + end Is_Sorted; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) is + function "<" (Left : Holder; Right : Holder) return Boolean is + (E (Left) < E (Right)); + + procedure Sort is new Generic_Array_Sort + (Index_Type => Array_Index, + Element_Type => Holder, + Array_Type => Elements_Array, + "<" => "<"); + + Len : constant Capacity_Range := Length (Container); + + begin + if Container.Last <= Index_Type'First then + return; + else + Sort (Elems (Container) (1 .. Len)); + end if; + end Sort; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target : in out Vector; Source : in out Vector) is + I : Count_Type; + J : Count_Type; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Length (Source) = 0 then + return; + end if; + + if Length (Target) = 0 then + Move (Target => Target, Source => Source); + return; + end if; + + I := Length (Target); + + declare + New_Length : constant Count_Type := I + Length (Source); + + begin + if not Bounded + and then Current_Capacity (Target) < Capacity_Range (New_Length) + then + Reserve_Capacity + (Target, + Capacity_Range'Max + (Current_Capacity (Target) * Growth_Factor, + Capacity_Range (New_Length))); + end if; + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Target.Last := No_Index + Index_Type'Base (New_Length); + + else + Target.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end; + + declare + TA : Maximal_Array_Ptr renames Elems (Target); + SA : Maximal_Array_Ptr renames Elems (Source); + + begin + J := Length (Target); + while Length (Source) /= 0 loop + if I = 0 then + TA (1 .. J) := SA (1 .. Length (Source)); + Source.Last := No_Index; + exit; + end if; + + if E (SA (Length (Source))) < E (TA (I)) then + TA (J) := TA (I); + I := I - 1; + + else + TA (J) := SA (Length (Source)); + Source.Last := Source.Last - 1; + end if; + + J := J - 1; + end loop; + end; + end Merge; + + end Generic_Sorting; + + ----------------- + -- Get_Element -- + ----------------- + + function Get_Element + (Container : Vector; + Position : Capacity_Range) return Element_Type + is + begin + return E (Elemsc (Container) (Position)); + end Get_Element; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element + (Container : Vector; + Position : Extended_Index) return Boolean + is + begin + return Position in First_Index (Container) .. Last_Index (Container); + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type) + is + begin + Insert (Container, Before, New_Item, 1); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type) + is + J : Count_Type'Base; -- scratch + + begin + -- Use Insert_Space to create the "hole" (the destination slice) + + Insert_Space (Container, Before, Count); + + J := To_Array_Index (Before); + + Elems (Container) (J .. J - 1 + Count) := (others => H (New_Item)); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + B : Count_Type; -- index Before converted to Count_Type + + begin + if Container'Address = New_Item'Address then + raise Program_Error with + "Container and New_Item denote same container"; + end if; + + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. + + Insert_Space (Container, Before, Count => N); + + if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; + end if; + + B := To_Array_Index (Before); + + Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + Old_Length : constant Count_Type := Length (Container); + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before - 1 > Container.Last + then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + -- We treat inserting 0 items into the container as a no-op, so we + -- simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibility of overflow. + + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) + then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + J := To_Array_Index (Before); + + -- Increase the capacity of container if needed + + if not Bounded + and then Current_Capacity (Container) < Capacity_Range (New_Length) + then + Reserve_Capacity + (Container, + Capacity_Range'Max + (Current_Capacity (Container) * Growth_Factor, + Capacity_Range (New_Length))); + end if; + + declare + EA : Maximal_Array_Ptr renames Elems (Container); + + begin + if Before <= Container.Last then + + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. + + EA (J + Count .. New_Length) := EA (J .. Old_Length); + end if; + end; + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := No_Index + Index_Type'Base (New_Length); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Last_Index (Container) < Index_Type'First; + end Is_Empty; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "Container is empty"; + else + return Get_Element (Container, Length (Container)); + end if; + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Capacity_Range is + L : constant Int := Int (Container.Last); + F : constant Int := Int (Index_Type'First); + N : constant Int'Base := L - F + 1; + + begin + return Capacity_Range (N); + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Vector; Source : in out Vector) is + LS : constant Capacity_Range := Length (Source); + + begin + if Target'Address = Source'Address then + return; + end if; + + if Bounded and then Target.Capacity < LS then + raise Constraint_Error; + end if; + + Clear (Target); + Append (Target, Source); + Clear (Source); + end Move; + + ------------ + -- Prepend -- + ------------ + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend (Container : in out Vector; New_Item : Element_Type) is + begin + Prepend (Container, New_Item, 1); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, Index_Type'First, New_Item, Count); + end Prepend; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Capacity_Range := Capacity_Range (II); + + begin + Elems (Container) (I) := H (New_Item); + end; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Capacity_Range) + is + begin + if Bounded then + if Capacity > Container.Capacity then + raise Constraint_Error with "Capacity is out of range"; + end if; + + else + if Capacity > Current_Capacity (Container) then + declare + New_Elements : constant Elements_Array_Ptr := + new Elements_Array (1 .. Capacity); + L : constant Capacity_Range := Length (Container); + + begin + New_Elements (1 .. L) := Elemsc (Container) (1 .. L); + Free (Container.Elements_Ptr); + Container.Elements_Ptr := New_Elements; + end; + end if; + end if; + end Reserve_Capacity; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + begin + if Length (Container) <= 1 then + return; + end if; + + declare + I : Capacity_Range; + J : Capacity_Range; + E : Elements_Array renames + Elems (Container) (1 .. Length (Container)); + + begin + I := 1; + J := Length (Container); + while I < J loop + declare + EI : constant Holder := E (I); + + begin + E (I) := E (J); + E (J) := EI; + end; + + I := I + 1; + J := J - 1; + end loop; + end; + end Reverse_Elements; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + Last : Index_Type'Base; + K : Capacity_Range; + + begin + if Index > Last_Index (Container) then + Last := Last_Index (Container); + else + Last := Index; + end if; + + K := Capacity_Range (Int (Last) - Int (No_Index)); + for Indx in reverse Index_Type'First .. Last loop + if Get_Element (Container, K) = Item then + return Indx; + end if; + + K := K - 1; + end loop; + + return No_Index; + end Reverse_Find_Index; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out Vector; + I : Index_Type; + J : Index_Type) + is + begin + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + declare + II : constant Int'Base := Int (I) - Int (No_Index); + JJ : constant Int'Base := Int (J) - Int (No_Index); + + EI : Holder renames Elems (Container) (Capacity_Range (II)); + EJ : Holder renames Elems (Container) (Capacity_Range (JJ)); + + EI_Copy : constant Holder := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + -------------------- + -- To_Array_Index -- + -------------------- + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is + Offset : Count_Type'Base; + + begin + -- We know that + -- Index >= Index_Type'First + -- hence we also know that + -- Index - Index_Type'First >= 0 + + -- The issue is that even though 0 is guaranteed to be a value in the + -- type Index_Type'Base, there's no guarantee that the difference is a + -- value in that type. To prevent overflow we use the wider of + -- Count_Type'Base and Index_Type'Base to perform intermediate + -- calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Offset := Count_Type'Base (Index - Index_Type'First); + + else + Offset := Count_Type'Base (Index) - + Count_Type'Base (Index_Type'First); + end if; + + -- The array index subtype for all container element arrays always + -- starts with 1. + + return 1 + Offset; + end To_Array_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector + (New_Item : Element_Type; + Length : Capacity_Range) return Vector + is + begin + if Length = 0 then + return Empty_Vector; + end if; + + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : Index_Type; + + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; -- ??? + end if; + + Last := Index_Type (Last_As_Int); + + return + (Capacity => Length, + Last => Last, + Elements_Ptr => <>, + Elements => (others => H (New_Item))); + end; + end To_Vector; + +end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-cfinve.ads b/gcc/ada/libgnat/a-cfinve.ads new file mode 100644 index 0000000..a7799e5 --- /dev/null +++ b/gcc/ada/libgnat/a-cfinve.ads @@ -0,0 +1,937 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FORMAL_INDEFINITE_VECTORS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- Similar to Ada.Containers.Formal_Vectors. The main difference is that +-- Element_Type may be indefinite (but not an unconstrained array). + +with Ada.Containers.Bounded_Holders; +with Ada.Containers.Functional_Vectors; + +generic + type Index_Type is range <>; + type Element_Type (<>) is private; + Max_Size_In_Storage_Elements : Natural := + Element_Type'Max_Size_In_Storage_Elements; + -- Maximum size of Vector elements in bytes. This has the same meaning as + -- in Ada.Containers.Bounded_Holders, with the same restrictions. Note that + -- setting this too small can lead to erroneous execution; see comments in + -- Ada.Containers.Bounded_Holders. If Element_Type is class-wide, it is the + -- responsibility of clients to calculate the maximum size of all types in + -- the class. + + Bounded : Boolean := True; + -- If True, the containers are bounded; the initial capacity is the maximum + -- size, and heap allocation will be avoided. If False, the containers can + -- grow via heap allocation. + +package Ada.Containers.Formal_Indefinite_Vectors with + SPARK_Mode => On +is + pragma Annotate (CodePeer, Skip_Analysis); + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + + No_Index : constant Extended_Index := Extended_Index'First; + + Last_Count : constant Count_Type := + (if Index_Type'Last < Index_Type'First then + 0 + elsif Index_Type'Last < -1 + or else Index_Type'Pos (Index_Type'First) > + Index_Type'Pos (Index_Type'Last) - Count_Type'Last + then + Index_Type'Pos (Index_Type'Last) - + Index_Type'Pos (Index_Type'First) + 1 + else + Count_Type'Last); + -- Maximal capacity of any vector. It is the minimum of the size of the + -- index range and the last possible Count_Type. + + subtype Capacity_Range is Count_Type range 0 .. Last_Count; + + type Vector (Capacity : Capacity_Range) is limited private with + Default_Initial_Condition => Is_Empty (Vector); + -- In the bounded case, Capacity is the capacity of the container, which + -- never changes. In the unbounded case, Capacity is the initial capacity + -- of the container, and operations such as Reserve_Capacity and Append can + -- increase the capacity. The capacity never shrinks, except in the case of + -- Clear. + -- + -- Note that all objects of type Vector are constrained, including in the + -- unbounded case; you can't assign from one object to another if the + -- Capacity is different. + + function Length (Container : Vector) return Capacity_Range with + Global => null, + Post => Length'Result <= Capacity (Container); + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + + package M is new Ada.Containers.Functional_Vectors + (Index_Type => Index_Type, + Element_Type => Element_Type); + + function "=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."="; + + function "<" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<"; + + function "<=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<="; + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + -- The elements of Container are contained in either Left or Right + with + Global => null, + Post => + M_Elements_In_Union'Result = + (for all I in Index_Type'First .. M.Last (Container) => + (for some J in Index_Type'First .. M.Last (Left) => + Element (Container, I) = Element (Left, J)) + or (for some J in Index_Type'First .. M.Last (Right) => + Element (Container, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Index_Type := Index_Type'First; + L_Lst : Extended_Index; + Right : M.Sequence; + R_Fst : Index_Type := Index_Type'First; + R_Lst : Extended_Index) return Boolean + -- The elements of the slice from L_Fst to L_Lst in Left are contained + -- in the slide from R_Fst to R_Lst in Right. + with + Global => null, + Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right), + Post => + M_Elements_Included'Result = + (for all I in L_Fst .. L_Lst => + (for some J in R_Fst .. R_Lst => + Element (Left, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + -- Right is Left in reverse order + with + Global => null, + Post => + M_Elements_Reversed'Result = + (M.Length (Left) = M.Length (Right) + and (for all I in Index_Type'First .. M.Last (Left) => + Element (Left, I) = + Element (Right, M.Last (Left) - I + 1)) + and (for all I in Index_Type'First .. M.Last (Right) => + Element (Right, I) = + Element (Left, M.Last (Left) - I + 1))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Index_Type; + Y : Index_Type) return Boolean + -- Elements stored at X and Y are reversed in Left and Right + with + Global => null, + Pre => X <= M.Last (Left) and Y <= M.Last (Left), + Post => + M_Elements_Swapped'Result = + (M.Length (Left) = M.Length (Right) + and Element (Left, X) = Element (Right, Y) + and Element (Left, Y) = Element (Right, X) + and M.Equal_Except (Left, Right, X, Y)); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); + + function Model (Container : Vector) return M.Sequence with + -- The high-level model of a vector is a sequence of elements. The + -- sequence really is similar to the vector itself. However, it is not + -- limited which allows usage of 'Old and 'Loop_Entry attributes. + + Ghost, + Global => null, + Post => M.Length (Model'Result) = Length (Container); + + function Element + (S : M.Sequence; + I : Index_Type) return Element_Type renames M.Get; + -- To improve readability of contracts, we rename the function used to + -- access an element in the model to Element. + + end Formal_Model; + use Formal_Model; + + function Empty_Vector return Vector with + Global => null, + Post => Length (Empty_Vector'Result) = 0; + + function "=" (Left, Right : Vector) return Boolean with + Global => null, + Post => "="'Result = (Model (Left) = Model (Right)); + + function To_Vector + (New_Item : Element_Type; + Length : Capacity_Range) return Vector + with + Global => null, + Post => + Formal_Indefinite_Vectors.Length (To_Vector'Result) = Length + and M.Constant_Range + (Container => Model (To_Vector'Result), + Fst => Index_Type'First, + Lst => Last_Index (To_Vector'Result), + Item => New_Item); + + function Capacity (Container : Vector) return Capacity_Range with + Global => null, + Post => + Capacity'Result = + (if Bounded then + Container.Capacity + else + Capacity_Range'Last); + pragma Annotate (GNATprove, Inline_For_Proof, Capacity); + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Capacity_Range) + with + Global => null, + Pre => (if Bounded then Capacity <= Container.Capacity), + Post => Model (Container) = Model (Container)'Old; + + function Is_Empty (Container : Vector) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out Vector) with + Global => null, + Post => Length (Container) = 0; + -- Note that this reclaims storage in the unbounded case. You need to call + -- this before a container goes out of scope in order to avoid storage + -- leaks. In addition, "X := ..." can leak unless you Clear(X) first. + + procedure Assign (Target : in out Vector; Source : Vector) with + Global => null, + Pre => (if Bounded then Length (Source) <= Target.Capacity), + Post => Model (Target) = Model (Source); + + function Copy + (Source : Vector; + Capacity : Capacity_Range := 0) return Vector + with + Global => null, + Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)), + Post => + Model (Copy'Result) = Model (Source) + and (if Capacity = 0 then + Copy'Result.Capacity = Length (Source) + else + Copy'Result.Capacity = Capacity); + + procedure Move (Target : in out Vector; Source : in out Vector) + with + Global => null, + Pre => (if Bounded then Length (Source) <= Capacity (Target)), + Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + with + Global => null, + Pre => Index in First_Index (Container) .. Last_Index (Container), + Post => Element'Result = Element (Model (Container), Index); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + with + Global => null, + Pre => Index in First_Index (Container) .. Last_Index (Container), + Post => + Length (Container) = Length (Container)'Old + + -- Container now has New_Item at index Index + + and Element (Model (Container), Index) = New_Item + + -- All other elements are preserved + + and M.Equal_Except + (Left => Model (Container)'Old, + Right => Model (Container), + Position => Index); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + with + Global => null, + Pre => + Length (Container) <= Capacity (Container) - Length (New_Item) + and (Before in Index_Type'First .. Last_Index (Container) + or (Before /= No_Index + and then Before - 1 = Last_Index (Container))), + Post => + Length (Container) = Length (Container)'Old + Length (New_Item) + + -- Elements located before Before in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Before - 1) + + -- Elements of New_Item are inserted at position Before + + and (if Length (New_Item) > 0 then + M.Range_Shifted + (Left => Model (New_Item), + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (New_Item), + Offset => Count_Type (Before - Index_Type'First))) + + -- Elements located after Before in Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Before, + Lst => Last_Index (Container)'Old, + Offset => Length (New_Item)); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Capacity (Container) + and then (Before in Index_Type'First .. Last_Index (Container) + 1), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Elements located before Before in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Before - 1) + + -- Container now has New_Item at index Before + + and Element (Model (Container), Before) = New_Item + + -- Elements located after Before in Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Before, + Lst => Last_Index (Container)'Old, + Offset => 1); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Capacity (Container) - Count + and (Before in Index_Type'First .. Last_Index (Container) + or (Before /= No_Index + and then Before - 1 = Last_Index (Container))), + Post => + Length (Container) = Length (Container)'Old + Count + + -- Elements located before Before in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Before - 1) + + -- New_Item is inserted Count times at position Before + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Before, + Lst => Before + Index_Type'Base (Count - 1), + Item => New_Item)) + + -- Elements located after Before in Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Before, + Lst => Last_Index (Container)'Old, + Offset => Count); + + procedure Prepend (Container : in out Vector; New_Item : Vector) with + Global => null, + Pre => Length (Container) <= Capacity (Container) - Length (New_Item), + Post => + Length (Container) = Length (Container)'Old + Length (New_Item) + + -- Elements of New_Item are inserted at the beginning of Container + + and M.Range_Equal + (Left => Model (New_Item), + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (New_Item)) + + -- Elements of Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container)'Old, + Offset => Length (New_Item)); + + procedure Prepend (Container : in out Vector; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Capacity (Container), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Container now has New_Item at Index_Type'First + + and Element (Model (Container), Index_Type'First) = New_Item + + -- Elements of Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container)'Old, + Offset => 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Capacity (Container) - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- New_Item is inserted Count times at the beginning of Container + + and M.Constant_Range + (Container => Model (Container), + Fst => Index_Type'First, + Lst => Index_Type'First + Index_Type'Base (Count - 1), + Item => New_Item) + + -- Elements of Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container)'Old, + Offset => Count); + + procedure Append (Container : in out Vector; New_Item : Vector) with + Global => null, + Pre => + Length (Container) <= Capacity (Container) - Length (New_Item), + Post => + Length (Container) = Length (Container)'Old + Length (New_Item) + + -- The elements of Container are preserved + + and Model (Container)'Old <= Model (Container) + + -- Elements of New_Item are inserted at the end of Container + + and (if Length (New_Item) > 0 then + M.Range_Shifted + (Left => Model (New_Item), + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (New_Item), + Offset => + Count_Type + (Last_Index (Container)'Old - Index_Type'First + 1))); + + procedure Append (Container : in out Vector; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Capacity (Container), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Elements of Container are preserved + + and Model (Container)'Old < Model (Container) + + -- Container now has New_Item at the end of Container + + and Element + (Model (Container), Last_Index (Container)'Old + 1) = New_Item; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Capacity (Container) - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- Elements of Container are preserved + + and Model (Container)'Old <= Model (Container) + + -- New_Item is inserted Count times at the end of Container + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Last_Index (Container)'Old + 1, + Lst => + Last_Index (Container)'Old + Index_Type'Base (Count), + Item => New_Item)); + + procedure Delete (Container : in out Vector; Index : Extended_Index) with + Global => null, + Pre => Index in First_Index (Container) .. Last_Index (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Elements located before Index in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Index - 1) + + -- Elements located after Index in Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index, + Lst => Last_Index (Container), + Offset => 1); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type) + with + Global => null, + Pre => + Index in First_Index (Container) .. Last_Index (Container), + Post => + Length (Container) in + Length (Container)'Old - Count .. Length (Container)'Old + + -- The elements of Container located before Index are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Index - 1), + + Contract_Cases => + + -- All the elements after Position have been erased + + (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => + Length (Container) = Count_Type (Index - Index_Type'First), + + others => + Length (Container) = Length (Container)'Old - Count + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index, + Lst => Last_Index (Container), + Offset => Count)); + + procedure Delete_First (Container : in out Vector) with + Global => null, + Pre => Length (Container) > 0, + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Elements of Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index_Type'First, + Lst => Last_Index (Container), + Offset => 1); + + procedure Delete_First (Container : in out Vector; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- Elements of Container are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index_Type'First, + Lst => Last_Index (Container), + Offset => Count)); + + procedure Delete_Last (Container : in out Vector) with + Global => null, + Pre => Length (Container) > 0, + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Elements of Container are preserved + + and Model (Container) < Model (Container)'Old; + + procedure Delete_Last (Container : in out Vector; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements after Position have been erased + + (Length (Container) <= Count => Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old); + + procedure Reverse_Elements (Container : in out Vector) with + Global => null, + Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); + + procedure Swap + (Container : in out Vector; + I : Index_Type; + J : Index_Type) + with + Global => null, + Pre => + I in First_Index (Container) .. Last_Index (Container) + and then J in First_Index (Container) .. Last_Index (Container), + Post => + M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); + + function First_Index (Container : Vector) return Index_Type with + Global => null, + Post => First_Index'Result = Index_Type'First; + pragma Annotate (GNATprove, Inline_For_Proof, First_Index); + + function First_Element (Container : Vector) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + First_Element'Result = Element (Model (Container), Index_Type'First); + pragma Annotate (GNATprove, Inline_For_Proof, First_Element); + + function Last_Index (Container : Vector) return Extended_Index with + Global => null, + Post => Last_Index'Result = M.Last (Model (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); + + function Last_Element (Container : Vector) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Element'Result = + Element (Model (Container), Last_Index (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + with + Global => null, + Contract_Cases => + + -- If Item is not contained in Container after Index, Find_Index + -- returns No_Index. + + (Index > Last_Index (Container) + or else not M.Contains + (Container => Model (Container), + Fst => Index, + Lst => Last_Index (Container), + Item => Item) + => + Find_Index'Result = No_Index, + + -- Otherwise, Find_Index returns a valid index greater than Index + + others => + Find_Index'Result in Index .. Last_Index (Container) + + -- The element at this index in Container is Item + + and Element (Model (Container), Find_Index'Result) = Item + + -- It is the first occurrence of Item after Index in Container + + and not M.Contains + (Container => Model (Container), + Fst => Index, + Lst => Find_Index'Result - 1, + Item => Item)); + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + with + Global => null, + Contract_Cases => + + -- If Item is not contained in Container before Index, + -- Reverse_Find_Index returns No_Index. + + (not M.Contains + (Container => Model (Container), + Fst => Index_Type'First, + Lst => (if Index <= Last_Index (Container) then Index + else Last_Index (Container)), + Item => Item) + => + Reverse_Find_Index'Result = No_Index, + + -- Otherwise, Reverse_Find_Index returns a valid index smaller than + -- Index + + others => + Reverse_Find_Index'Result in Index_Type'First .. Index + and Reverse_Find_Index'Result <= Last_Index (Container) + + -- The element at this index in Container is Item + + and Element (Model (Container), Reverse_Find_Index'Result) = Item + + -- It is the last occurrence of Item before Index in Container + + and not M.Contains + (Container => Model (Container), + Fst => Reverse_Find_Index'Result + 1, + Lst => + (if Index <= Last_Index (Container) then + Index + else + Last_Index (Container)), + Item => Item)); + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + with + Global => null, + Post => + Contains'Result = + M.Contains + (Container => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container), + Item => Item); + + function Has_Element + (Container : Vector; + Position : Extended_Index) return Boolean + with + Global => null, + Post => + Has_Element'Result = + (Position in Index_Type'First .. Last_Index (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting with SPARK_Mode is + + package Formal_Model with Ghost is + + function M_Elements_Sorted (Container : M.Sequence) return Boolean + with + Global => null, + Post => + M_Elements_Sorted'Result = + (for all I in Index_Type'First .. M.Last (Container) => + (for all J in I .. M.Last (Container) => + Element (Container, I) = Element (Container, J) + or Element (Container, I) < Element (Container, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); + + end Formal_Model; + use Formal_Model; + + function Is_Sorted (Container : Vector) return Boolean with + Global => null, + Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); + + procedure Sort (Container : in out Vector) with + Global => null, + Post => + Length (Container) = Length (Container)'Old + and M_Elements_Sorted (Model (Container)) + and M_Elements_Included + (Left => Model (Container)'Old, + L_Lst => Last_Index (Container), + Right => Model (Container), + R_Lst => Last_Index (Container)) + and M_Elements_Included + (Left => Model (Container), + L_Lst => Last_Index (Container), + Right => Model (Container)'Old, + R_Lst => Last_Index (Container)); + + procedure Merge (Target : in out Vector; Source : in out Vector) with + -- Target and Source should not be aliased + Global => null, + Pre => Length (Source) <= Capacity (Target) - Length (Target), + Post => + Length (Target) = Length (Target)'Old + Length (Source)'Old + and Length (Source) = 0 + and (if M_Elements_Sorted (Model (Target)'Old) + and M_Elements_Sorted (Model (Source)'Old) + then + M_Elements_Sorted (Model (Target))) + and M_Elements_Included + (Left => Model (Target)'Old, + L_Lst => Last_Index (Target)'Old, + Right => Model (Target), + R_Lst => Last_Index (Target)) + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Last_Index (Source)'Old, + Right => Model (Target), + R_Lst => Last_Index (Target)) + and M_Elements_In_Union + (Model (Target), + Model (Source)'Old, + Model (Target)'Old); + end Generic_Sorting; + +private + pragma SPARK_Mode (Off); + + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Replace_Element); + pragma Inline (Contains); + + -- The implementation method is to instantiate Bounded_Holders to get a + -- definite type for Element_Type. + + package Holders is new Bounded_Holders + (Element_Type, Max_Size_In_Storage_Elements, "="); + use Holders; + + subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; + type Elements_Array is array (Array_Index range <>) of Holder; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Elements_Array_Ptr is access all Elements_Array; + + type Vector (Capacity : Capacity_Range) is limited record + + -- In the bounded case, the elements are stored in Elements. In the + -- unbounded case, the elements are initially stored in Elements, until + -- we run out of room, then we switch to Elements_Ptr. + + Last : Extended_Index := No_Index; + Elements_Ptr : Elements_Array_Ptr := null; + Elements : aliased Elements_Array (1 .. Capacity); + end record; + + -- The primary reason Vector is limited is that in the unbounded case, once + -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will + -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr, + -- so for example "Append (X, ...);" will modify BOTH X and Y. That would + -- allow SPARK to "prove" things that are false. We could fix that by + -- making Vector a controlled type, and override Adjust to make a deep + -- copy, but finalization is not allowed in SPARK. + -- + -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not + -- allowed on Vectors. + + function Empty_Vector return Vector is + ((Capacity => 0, others => <>)); + +end Ada.Containers.Formal_Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-cforma.adb b/gcc/ada/libgnat/a-cforma.adb new file mode 100644 index 0000000..5967973 --- /dev/null +++ b/gcc/ada/libgnat/a-cforma.adb @@ -0,0 +1,1159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Formal_Ordered_Maps with + SPARK_Mode => Off +is + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color + (Node : Node_Type) return Ada.Containers.Red_Black_Trees.Color_Type; + pragma Inline (Color); + + function Left_Son (Node : Node_Type) return Count_Type; + pragma Inline (Left_Son); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right_Son (Node : Node_Type) return Count_Type; + pragma Inline (Right_Son); + + procedure Set_Color + (Node : in out Node_Type; + Color : Ada.Containers.Red_Black_Trees.Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- All need comments ??? + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (Tree : in out Tree_Types.Tree_Type'Class; + Node : out Count_Type); + + procedure Free (Tree : in out Map; X : Count_Type); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations + (Tree_Types => Tree_Types, + Left => Left_Son, + Right => Right_Son); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + Lst : Count_Type; + Node : Count_Type; + ENode : Count_Type; + + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + if Is_Empty (Left) then + return True; + end if; + + Lst := Next (Left, Last (Left).Node); + + Node := First (Left).Node; + while Node /= Lst loop + ENode := Find (Right, Left.Nodes (Node).Key).Node; + + if ENode = 0 or else + Left.Nodes (Node).Element /= Right.Nodes (ENode).Element + then + return False; + end if; + + Node := Next (Left, Node); + end loop; + + return True; + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + procedure Append_Element (Source_Node : Count_Type) is + SN : Node_Type renames Source.Nodes (Source_Node); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Key_Ops.Generic_Unconditional_Insert (Insert_Post); + + procedure Unconditional_Insert_Avec_Hint is + new Key_Ops.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Unconditional_Insert_Sans_Hint); + + procedure Allocate is new Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Target, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Key := SN.Key; + Node.Element := SN.Element; + end Set_Element; + + Target_Node : Count_Type; + + -- Start of processing for Append_Element + + begin + Unconditional_Insert_Avec_Hint + (Tree => Target, + Hint => 0, + Key => SN.Key, + Node => Target_Node); + end Append_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Length (Source) then + raise Storage_Error with "not enough capacity"; -- SE or CE? ??? + end if; + + Tree_Operations.Clear_Tree (Target); + Append_Elements (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Ceiling (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + Tree_Operations.Clear_Tree (Container); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map is + Node : Count_Type := 1; + N : Count_Type; + + begin + if 0 < Capacity and then Capacity < Source.Capacity then + raise Capacity_Error; + end if; + + return Target : Map (Count_Type'Max (Source.Capacity, Capacity)) do + if Length (Source) > 0 then + Target.Length := Source.Length; + Target.Root := Source.Root; + Target.First := Source.First; + Target.Last := Source.Last; + Target.Free := Source.Free; + + while Node <= Source.Capacity loop + Target.Nodes (Node).Element := + Source.Nodes (Node).Element; + Target.Nodes (Node).Key := + Source.Nodes (Node).Key; + Target.Nodes (Node).Parent := + Source.Nodes (Node).Parent; + Target.Nodes (Node).Left := + Source.Nodes (Node).Left; + Target.Nodes (Node).Right := + Source.Nodes (Node).Right; + Target.Nodes (Node).Color := + Source.Nodes (Node).Color; + Target.Nodes (Node).Has_Element := + Source.Nodes (Node).Has_Element; + Node := Node + 1; + end loop; + + while Node <= Target.Capacity loop + N := Node; + Formal_Ordered_Maps.Free (Tree => Target, X => N); + Node := Node + 1; + end loop; + end if; + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of Delete has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Delete is bad"); + + Tree_Operations.Delete_Node_Sans_Free (Container, + Position.Node); + Formal_Ordered_Maps.Free (Container, Position.Node); + Position := No_Element; + end Delete; + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : constant Node_Access := Key_Ops.Find (Container, Key); + + begin + if X = 0 then + raise Constraint_Error with "key not in map"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) is + X : constant Node_Access := First (Container).Node; + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) is + X : constant Node_Access := Last (Container).Node; + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Position : Cursor) return Element_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of function Element has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of function Element is bad"); + + return Container.Nodes (Position.Node).Element; + + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Find (Container, Key).Node; + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + return Container.Nodes (Node).Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : constant Node_Access := Key_Ops.Find (Container, Key); + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Maps.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + begin + if Length (Container) = 0 then + return No_Element; + end if; + + return (Node => Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (First (Container).Node).Element; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (First (Container).Node).Key; + end First_Key; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Map; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Ops.Floor (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Floor; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ---------- + -- Find -- + ---------- + + function Find + (Container : K.Sequence; + Key : Key_Type) return Count_Type + is + begin + for I in 1 .. K.Length (Container) loop + if Equivalent_Keys (Key, K.Get (Container, I)) then + return I; + elsif Key < K.Get (Container, I) then + return 0; + end if; + end loop; + return 0; + end Find; + + ------------------------- + -- K_Bigger_Than_Range -- + ------------------------- + + function K_Bigger_Than_Range + (Container : K.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + is + begin + for I in Fst .. Lst loop + if not (K.Get (Container, I) < Key) then + return False; + end if; + end loop; + return True; + end K_Bigger_Than_Range; + + --------------- + -- K_Is_Find -- + --------------- + + function K_Is_Find + (Container : K.Sequence; + Key : Key_Type; + Position : Count_Type) return Boolean + is + begin + for I in 1 .. Position - 1 loop + if Key < K.Get (Container, I) then + return False; + end if; + end loop; + + if Position < K.Length (Container) then + for I in Position + 1 .. K.Length (Container) loop + if K.Get (Container, I) < Key then + return False; + end if; + end loop; + end if; + return True; + end K_Is_Find; + + -------------------------- + -- K_Smaller_Than_Range -- + -------------------------- + + function K_Smaller_Than_Range + (Container : K.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + is + begin + for I in Fst .. Lst loop + if not (Key < K.Get (Container, I)) then + return False; + end if; + end loop; + return True; + end K_Smaller_Than_Range; + + ---------- + -- Keys -- + ---------- + + function Keys (Container : Map) return K.Sequence is + Position : Count_Type := Container.First; + R : K.Sequence; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := K.Add (R, Container.Nodes (Position).Key); + Position := Tree_Operations.Next (Container, Position); + end loop; + + return R; + end Keys; + + ---------------------------- + -- Lift_Abstraction_Level -- + ---------------------------- + + procedure Lift_Abstraction_Level (Container : Map) is null; + + ----------- + -- Model -- + ----------- + + function Model (Container : Map) return M.Map is + Position : Count_Type := Container.First; + R : M.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := + M.Add + (Container => R, + New_Key => Container.Nodes (Position).Key, + New_Item => Container.Nodes (Position).Element); + + Position := Tree_Operations.Next (Container, Position); + end loop; + + return R; + end Model; + + ------------------------- + -- P_Positions_Shifted -- + ------------------------- + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + Count + then + return False; + end if; + + else + if P.Has_Key (Small, Cu) then + return False; + end if; + end if; + end; + end loop; + + return True; + end P_Positions_Shifted; + + --------------- + -- Positions -- + --------------- + + function Positions (Container : Map) return P.Map is + I : Count_Type := 1; + Position : Count_Type := Container.First; + R : P.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := P.Add (R, (Node => Position), I); + pragma Assert (P.Length (R) = I); + Position := Tree_Operations.Next (Container, Position); + I := I + 1; + end loop; + + return R; + end Positions; + + end Formal_Model; + + ---------- + -- Free -- + ---------- + + procedure Free + (Tree : in out Map; + X : Count_Type) + is + begin + Tree.Nodes (X).Has_Element := False; + Tree_Operations.Free (Tree, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (Tree : in out Tree_Types.Tree_Type'Class; + Node : out Count_Type) + is + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + begin + Allocate (Tree, Node); + Tree.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : Map; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return False; + end if; + + return Container.Nodes (Position.Node).Has_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + declare + N : Node_Type renames Container.Nodes (Position.Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end if; + end Include; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + -- Comment ??? + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + procedure Initialize (Node : in out Node_Type); + procedure Allocate_Node is new Generic_Allocate (Initialize); + + procedure Initialize (Node : in out Node_Type) is + begin + Node.Key := Key; + Node.Element := New_Item; + end Initialize; + + X : Node_Access; + + begin + Allocate_Node (Container, X); + return X; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container, + Key, + Position.Node, + Inserted); + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with "key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + -- k > node same as node < k + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Key; + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Container : Map; Position : Cursor) return Key_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of function Key has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of function Key is bad"); + + return Container.Nodes (Position.Node).Key; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + begin + if Length (Container) = 0 then + return No_Element; + end if; + + return (Node => Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Last (Container).Node).Element; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "map is empty"; + end if; + + return Container.Nodes (Last (Container).Node).Key; + end Last_Key; + + -------------- + -- Left_Son -- + -------------- + + function Left_Son (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left_Son; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Map; Source : in out Map) is + NN : Tree_Types.Nodes_Type renames Source.Nodes; + X : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + Clear (Target); + + loop + X := First (Source).Node; + exit when X = 0; + + -- Here we insert a copy of the source element into the target, and + -- then delete the element from the source. Another possibility is + -- that delete it first (and hang onto its index), then insert it. + -- ??? + + Insert (Target, NN (X).Key, NN (X).Element); -- optimize??? + + Tree_Operations.Delete_Node_Sans_Free (Source, X); + Formal_Ordered_Maps.Free (Source, X); + end loop; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Container : Map; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + function Next (Container : Map; Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Next"); + + return (Node => Tree_Operations.Next (Container, Position.Node)); + end Next; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Container : Map; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + function Previous (Container : Map; Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Count_Type := + Tree_Operations.Previous (Container, Position.Node); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Previous; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + begin + declare + Node : constant Node_Access := Key_Ops.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in map"; + end if; + + declare + N : Node_Type renames Container.Nodes (Node); + begin + N.Key := Key; + N.Element := New_Item; + end; + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor of Replace_Element has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "Position cursor of Replace_Element is bad"); + + Container.Nodes (Position.Node).Element := New_Item; + end Replace_Element; + + --------------- + -- Right_Son -- + --------------- + + function Right_Son (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right_Son; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : in out Node_Type; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + +end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cforma.ads b/gcc/ada/libgnat/a-cforma.ads new file mode 100644 index 0000000..ed4e872 --- /dev/null +++ b/gcc/ada/libgnat/a-cforma.ads @@ -0,0 +1,1052 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This spec is derived from package Ada.Containers.Bounded_Ordered_Maps in +-- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. + +-- The modifications are: + +-- A parameter for the container is added to every function reading the +-- content of a container: Key, Element, Next, Query_Element, Previous, +-- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the +-- need to have cursors which are valid on different containers (typically a +-- container C and its previous version C'Old) for expressing properties, +-- which is not possible if cursors encapsulate an access to the underlying +-- container. The operators "<" and ">" that could not be modified that way +-- have been removed. + +-- Iteration over maps is done using the Iterable aspect, which is SPARK +-- compatible. "For of" iteration ranges over keys instead of elements. + +with Ada.Containers.Functional_Vectors; +with Ada.Containers.Functional_Maps; +private with Ada.Containers.Red_Black_Trees; + +generic + type Key_Type is private; + type Element_Type is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + +package Ada.Containers.Formal_Ordered_Maps with + SPARK_Mode +is + pragma Annotate (CodePeer, Skip_Analysis); + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean with + Global => null, + Post => + Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); + pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); + + type Map (Capacity : Count_Type) is private with + Iterable => (First => First, + Next => Next, + Has_Element => Has_Element, + Element => Key), + Default_Initial_Condition => Is_Empty (Map); + pragma Preelaborable_Initialization (Map); + + type Cursor is record + Node : Count_Type; + end record; + + No_Element : constant Cursor := (Node => 0); + + Empty_Map : constant Map; + + function Length (Container : Map) return Count_Type with + Global => null, + Post => Length'Result <= Container.Capacity; + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package M is new Ada.Containers.Functional_Maps + (Element_Type => Element_Type, + Key_Type => Key_Type, + Equivalent_Keys => Equivalent_Keys); + + function "=" + (Left : M.Map; + Right : M.Map) return Boolean renames M."="; + + function "<=" + (Left : M.Map; + Right : M.Map) return Boolean renames M."<="; + + package K is new Ada.Containers.Functional_Vectors + (Element_Type => Key_Type, + Index_Type => Positive_Count_Type); + + function "=" + (Left : K.Sequence; + Right : K.Sequence) return Boolean renames K."="; + + function "<" + (Left : K.Sequence; + Right : K.Sequence) return Boolean renames K."<"; + + function "<=" + (Left : K.Sequence; + Right : K.Sequence) return Boolean renames K."<="; + + function K_Bigger_Than_Range + (Container : K.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + with + Global => null, + Pre => Lst <= K.Length (Container), + Post => + K_Bigger_Than_Range'Result = + (for all I in Fst .. Lst => K.Get (Container, I) < Key); + pragma Annotate (GNATprove, Inline_For_Proof, K_Bigger_Than_Range); + + function K_Smaller_Than_Range + (Container : K.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + with + Global => null, + Pre => Lst <= K.Length (Container), + Post => + K_Smaller_Than_Range'Result = + (for all I in Fst .. Lst => Key < K.Get (Container, I)); + pragma Annotate (GNATprove, Inline_For_Proof, K_Smaller_Than_Range); + + function K_Is_Find + (Container : K.Sequence; + Key : Key_Type; + Position : Count_Type) return Boolean + with + Global => null, + Pre => Position - 1 <= K.Length (Container), + Post => + K_Is_Find'Result = + ((if Position > 0 then + K_Bigger_Than_Range (Container, 1, Position - 1, Key)) + + and + (if Position < K.Length (Container) then + K_Smaller_Than_Range + (Container, + Position + 1, + K.Length (Container), + Key))); + pragma Annotate (GNATprove, Inline_For_Proof, K_Is_Find); + + function Find (Container : K.Sequence; Key : Key_Type) return Count_Type + -- Search for Key in Container + + with + Global => null, + Post => + (if Find'Result > 0 then + Find'Result <= K.Length (Container) + and Equivalent_Keys (Key, K.Get (Container, Find'Result))); + + package P is new Ada.Containers.Functional_Maps + (Key_Type => Cursor, + Element_Type => Positive_Count_Type, + Equivalent_Keys => "=", + Enable_Handling_Of_Equivalence => False); + + function "=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."="; + + function "<=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."<="; + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Global => null, + Post => + P_Positions_Shifted'Result = + + -- Big contains all cursors of Small + + (P.Keys_Included (Small, Big) + + -- Cursors located before Cut are not moved, cursors located + -- after are shifted by Count. + + and (for all I of Small => + (if P.Get (Small, I) < Cut then + P.Get (Big, I) = P.Get (Small, I) + else + P.Get (Big, I) - Count = P.Get (Small, I))) + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function Model (Container : Map) return M.Map with + -- The high-level model of a map is a map from keys to elements. Neither + -- cursors nor order of elements are represented in this model. Keys are + -- modeled up to equivalence. + + Ghost, + Global => null; + + function Keys (Container : Map) return K.Sequence with + -- The Keys sequence represents the underlying list structure of maps + -- that is used for iteration. It stores the actual values of keys in + -- the map. It does not model cursors nor elements. + + Ghost, + Global => null, + Post => + K.Length (Keys'Result) = Length (Container) + + -- It only contains keys contained in Model + + and (for all Key of Keys'Result => + M.Has_Key (Model (Container), Key)) + + -- It contains all the keys contained in Model + + and (for all Key of Model (Container) => + (Find (Keys'Result, Key) > 0 + and then Equivalent_Keys + (K.Get (Keys'Result, Find (Keys'Result, Key)), + Key))) + + -- It is sorted in increasing order + + and (for all I in 1 .. Length (Container) => + Find (Keys'Result, K.Get (Keys'Result, I)) = I + and K_Is_Find (Keys'Result, K.Get (Keys'Result, I), I)); + pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Keys); + + function Positions (Container : Map) return P.Map with + -- The Positions map is used to model cursors. It only contains valid + -- cursors and maps them to their position in the container. + + Ghost, + Global => null, + Post => + not P.Has_Key (Positions'Result, No_Element) + + -- Positions of cursors are smaller than the container's length. + + and then + (for all I of Positions'Result => + P.Get (Positions'Result, I) in 1 .. Length (Container) + + -- No two cursors have the same position. Note that we do not + -- state that there is a cursor in the map for each position, as + -- it is rarely needed. + + and then + (for all J of Positions'Result => + (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) + then I = J))); + + procedure Lift_Abstraction_Level (Container : Map) with + -- Lift_Abstraction_Level is a ghost procedure that does nothing but + -- assume that we can access the same elements by iterating over + -- positions or cursors. + -- This information is not generally useful except when switching from + -- a low-level, cursor-aware view of a container, to a high-level, + -- position-based view. + + Ghost, + Global => null, + Post => + (for all Key of Keys (Container) => + (for some I of Positions (Container) => + K.Get (Keys (Container), P.Get (Positions (Container), I)) = + Key)); + + function Contains + (C : M.Map; + K : Key_Type) return Boolean renames M.Has_Key; + -- To improve readability of contracts, we rename the function used to + -- search for a key in the model to Contains. + + function Element + (C : M.Map; + K : Key_Type) return Element_Type renames M.Get; + -- To improve readability of contracts, we rename the function used to + -- access an element in the model to Element. + end Formal_Model; + use Formal_Model; + + function "=" (Left, Right : Map) return Boolean with + Global => null, + Post => "="'Result = (Model (Left) = Model (Right)); + + function Is_Empty (Container : Map) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out Map) with + Global => null, + Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); + + procedure Assign (Target : in out Map; Source : Map) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Model (Target) = Model (Source) + and Keys (Target) = Keys (Source) + and Length (Source) = Length (Target); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map with + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity, + Post => + Model (Copy'Result) = Model (Source) + and Keys (Copy'Result) = Keys (Source) + and Positions (Copy'Result) = Positions (Source) + and (if Capacity = 0 then + Copy'Result.Capacity = Source.Capacity + else + Copy'Result.Capacity = Capacity); + + function Key (Container : Map; Position : Cursor) return Key_Type with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Key'Result = + K.Get (Keys (Container), P.Get (Positions (Container), Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Key); + + function Element + (Container : Map; + Position : Cursor) return Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Element'Result = Element (Model (Container), Key (Container, Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + + -- Order of keys and cursors is preserved + + Keys (Container) = Keys (Container)'Old + and Positions (Container) = Positions (Container)'Old + + -- New_Item is now associated with the key at position Position in + -- Container. + + and Element (Container, Position) = New_Item + + -- Elements associated with other keys are preserved + + and M.Same_Keys (Model (Container), Model (Container)'Old) + and M.Elements_Equal_Except + (Model (Container), + Model (Container)'Old, + Key (Container, Position)); + + procedure Move (Target : in out Map; Source : in out Map) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Model (Target) = Model (Source)'Old + and Keys (Target) = Keys (Source)'Old + and Length (Source)'Old = Length (Target) + and Length (Source) = 0; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + with + Global => null, + Pre => + Length (Container) < Container.Capacity or Contains (Container, Key), + Post => + Contains (Container, Key) + and Has_Element (Container, Position) + and Equivalent_Keys + (Formal_Ordered_Maps.Key (Container, Position), Key) + and K_Is_Find + (Keys (Container), + Key, + P.Get (Positions (Container), Position)), + Contract_Cases => + + -- If Key is already in Container, it is not modified and Inserted is + -- set to False. + + (Contains (Container, Key) => + not Inserted + and Model (Container) = Model (Container)'Old + and Keys (Container) = Keys (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Key is inserted in Container and Inserted is set to True + + others => + Inserted + and Length (Container) = Length (Container)'Old + 1 + + -- Key now maps to New_Item + + and Formal_Ordered_Maps.Key (Container, Position) = Key + and Element (Model (Container), Key) = New_Item + + -- Other mappings are preserved + + and Model (Container)'Old <= Model (Container) + and M.Keys_Included_Except + (Model (Container), + Model (Container)'Old, + Key) + + -- The keys of Container located before Position are preserved + + and K.Range_Equal + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other keys are shifted by 1 + + and K.Range_Shifted + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => 1) + + -- A new cursor has been inserted at position Position in + -- Container. + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position))); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + and then (not Contains (Container, Key)), + Post => + Length (Container) = Length (Container)'Old + 1 + and Contains (Container, Key) + + -- Key now maps to New_Item + + and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key + and Element (Model (Container), Key) = New_Item + + -- Other mappings are preserved + + and Model (Container)'Old <= Model (Container) + and M.Keys_Included_Except + (Model (Container), + Model (Container)'Old, + Key) + + -- The keys of Container located before Key are preserved + + and K.Range_Equal + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => 1, + Lst => Find (Keys (Container), Key) - 1) + + -- Other keys are shifted by 1 + + and K.Range_Shifted + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => Find (Keys (Container), Key), + Lst => Length (Container)'Old, + Offset => 1) + + -- A new cursor has been inserted in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => Find (Keys (Container), Key)); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Container.Capacity or Contains (Container, Key), + Post => + Contains (Container, Key) and Element (Container, Key) = New_Item, + Contract_Cases => + + -- If Key is already in Container, Key is mapped to New_Item + + (Contains (Container, Key) => + + -- Cursors are preserved + + Positions (Container) = Positions (Container)'Old + + -- The key equivalent to Key in Container is replaced by Key + + and K.Get + (Keys (Container), Find (Keys (Container), Key)) = Key + + and K.Equal_Except + (Keys (Container)'Old, + Keys (Container), + Find (Keys (Container), Key)) + + -- Elements associated with other keys are preserved + + and M.Same_Keys (Model (Container), Model (Container)'Old) + and M.Elements_Equal_Except + (Model (Container), + Model (Container)'Old, + Key), + + -- Otherwise, Key is inserted in Container + + others => + Length (Container) = Length (Container)'Old + 1 + + -- Other mappings are preserved + + and Model (Container)'Old <= Model (Container) + and M.Keys_Included_Except + (Model (Container), + Model (Container)'Old, + Key) + + -- Key is inserted in Container + + and K.Get + (Keys (Container), Find (Keys (Container), Key)) = Key + + -- The keys of Container located before Key are preserved + + and K.Range_Equal + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => 1, + Lst => Find (Keys (Container), Key) - 1) + + -- Other keys are shifted by 1 + + and K.Range_Shifted + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => Find (Keys (Container), Key), + Lst => Length (Container)'Old, + Offset => 1) + + -- A new cursor has been inserted in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => Find (Keys (Container), Key))); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => Contains (Container, Key), + Post => + + -- Cursors are preserved + + Positions (Container) = Positions (Container)'Old + + -- The key equivalent to Key in Container is replaced by Key + + and K.Get (Keys (Container), Find (Keys (Container), Key)) = Key + and K.Equal_Except + (Keys (Container)'Old, + Keys (Container), + Find (Keys (Container), Key)) + + -- New_Item is now associated with the Key in Container + + and Element (Model (Container), Key) = New_Item + + -- Elements associated with other keys are preserved + + and M.Same_Keys (Model (Container), Model (Container)'Old) + and M.Elements_Equal_Except + (Model (Container), + Model (Container)'Old, + Key); + + procedure Exclude (Container : in out Map; Key : Key_Type) with + Global => null, + Post => not Contains (Container, Key), + Contract_Cases => + + -- If Key is not in Container, nothing is changed + + (not Contains (Container, Key) => + Model (Container) = Model (Container)'Old + and Keys (Container) = Keys (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Key is removed from Container + + others => + Length (Container) = Length (Container)'Old - 1 + + -- Other mappings are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- The keys of Container located before Key are preserved + + and K.Range_Equal + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => 1, + Lst => Find (Keys (Container), Key)'Old - 1) + + -- The keys located after Key are shifted by 1 + + and K.Range_Shifted + (Left => Keys (Container), + Right => Keys (Container)'Old, + Fst => Find (Keys (Container), Key)'Old, + Lst => Length (Container), + Offset => 1) + + -- A cursor has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => Find (Keys (Container), Key)'Old)); + + procedure Delete (Container : in out Map; Key : Key_Type) with + Global => null, + Pre => Contains (Container, Key), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Key is no longer in Container + + and not Contains (Container, Key) + + -- Other mappings are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- The keys of Container located before Key are preserved + + and K.Range_Equal + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => 1, + Lst => Find (Keys (Container), Key)'Old - 1) + + -- The keys located after Key are shifted by 1 + + and K.Range_Shifted + (Left => Keys (Container), + Right => Keys (Container)'Old, + Fst => Find (Keys (Container), Key)'Old, + Lst => Length (Container), + Offset => 1) + + -- A cursor has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => Find (Keys (Container), Key)'Old); + + procedure Delete (Container : in out Map; Position : in out Cursor) with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Position = No_Element + and Length (Container) = Length (Container)'Old - 1 + + -- The key at position Position is no longer in Container + + and not Contains (Container, Key (Container, Position)'Old) + and not P.Has_Key (Positions (Container), Position'Old) + + -- Other mappings are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + Key (Container, Position)'Old) + + -- The keys of Container located before Position are preserved. + + and K.Range_Equal + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) + + -- The keys located after Position are shifted by 1 + + and K.Range_Shifted + (Left => Keys (Container), + Right => Keys (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => 1) + + -- Position has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old)); + + procedure Delete_First (Container : in out Map) with + Global => null, + Contract_Cases => + (Length (Container) = 0 => Length (Container) = 0, + others => + Length (Container) = Length (Container)'Old - 1 + + -- The first key has been removed from Container + + and not Contains (Container, First_Key (Container)'Old) + + -- Other mappings are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + First_Key (Container)'Old) + + -- Other keys are shifted by 1 + + and K.Range_Shifted + (Left => Keys (Container), + Right => Keys (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => 1) + + -- First has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1)); + + procedure Delete_Last (Container : in out Map) with + Global => null, + Contract_Cases => + (Length (Container) = 0 => Length (Container) = 0, + others => + Length (Container) = Length (Container)'Old - 1 + + -- The last key has been removed from Container + + and not Contains (Container, Last_Key (Container)'Old) + + -- Other mappings are preserved + + and Model (Container) <= Model (Container)'Old + and M.Keys_Included_Except + (Model (Container)'Old, + Model (Container), + Last_Key (Container)'Old) + + -- Others keys of Container are preserved + + and K.Range_Equal + (Left => Keys (Container)'Old, + Right => Keys (Container), + Fst => 1, + Lst => Length (Container)) + + -- Last cursor has been removed from Container + + and Positions (Container) <= Positions (Container)'Old); + + function First (Container : Map) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + First'Result = No_Element, + + others => + Has_Element (Container, First'Result) + and P.Get (Positions (Container), First'Result) = 1); + + function First_Element (Container : Map) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + First_Element'Result = + Element (Model (Container), First_Key (Container)); + + function First_Key (Container : Map) return Key_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + First_Key'Result = K.Get (Keys (Container), 1) + and K_Smaller_Than_Range + (Keys (Container), 2, Length (Container), First_Key'Result); + + function Last (Container : Map) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + Last'Result = No_Element, + + others => + Has_Element (Container, Last'Result) + and P.Get (Positions (Container), Last'Result) = + Length (Container)); + + function Last_Element (Container : Map) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Element'Result = Element (Model (Container), Last_Key (Container)); + + function Last_Key (Container : Map) return Key_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Key'Result = K.Get (Keys (Container), Length (Container)) + and K_Bigger_Than_Range + (Keys (Container), 1, Length (Container) - 1, Last_Key'Result); + + function Next (Container : Map; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Next'Result = No_Element, + + others => + Has_Element (Container, Next'Result) + and then P.Get (Positions (Container), Next'Result) = + P.Get (Positions (Container), Position) + 1); + + procedure Next (Container : Map; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) + 1); + + function Previous (Container : Map; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Previous'Result = No_Element, + + others => + Has_Element (Container, Previous'Result) + and then P.Get (Positions (Container), Previous'Result) = + P.Get (Positions (Container), Position) - 1); + + procedure Previous (Container : Map; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) - 1); + + function Find (Container : Map; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + + -- If Key is not contained in Container, Find returns No_Element + + (not Contains (Model (Container), Key) => + not P.Has_Key (Positions (Container), Find'Result) + and Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + and P.Get (Positions (Container), Find'Result) = + Find (Keys (Container), Key) + + -- The key designated by the result of Find is Key + + and Equivalent_Keys + (Formal_Ordered_Maps.Key (Container, Find'Result), Key)); + + function Element (Container : Map; Key : Key_Type) return Element_Type with + Global => null, + Pre => Contains (Container, Key), + Post => Element'Result = Element (Model (Container), Key); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + function Floor (Container : Map; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 or else Key < First_Key (Container) => + Floor'Result = No_Element, + + others => + Has_Element (Container, Floor'Result) + and not (Key < K.Get (Keys (Container), + P.Get (Positions (Container), Floor'Result))) + and K_Is_Find + (Keys (Container), + Key, + P.Get (Positions (Container), Floor'Result))); + + function Ceiling (Container : Map; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 or else Last_Key (Container) < Key => + Ceiling'Result = No_Element, + others => + Has_Element (Container, Ceiling'Result) + and not (K.Get + (Keys (Container), + P.Get (Positions (Container), Ceiling'Result)) < Key) + and K_Is_Find + (Keys (Container), + Key, + P.Get (Positions (Container), Ceiling'Result))); + + function Contains (Container : Map; Key : Key_Type) return Boolean with + Global => null, + Post => Contains'Result = Contains (Model (Container), Key); + pragma Annotate (GNATprove, Inline_For_Proof, Contains); + + function Has_Element (Container : Map; Position : Cursor) return Boolean + with + Global => null, + Post => + Has_Element'Result = P.Has_Key (Positions (Container), Position); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + +private + pragma SPARK_Mode (Off); + + pragma Inline (Next); + pragma Inline (Previous); + + subtype Node_Access is Count_Type; + + use Red_Black_Trees; + + type Node_Type is record + Has_Element : Boolean := False; + Parent : Node_Access := 0; + Left : Node_Access := 0; + Right : Node_Access := 0; + Color : Red_Black_Trees.Color_Type := Red; + Key : Key_Type; + Element : Element_Type; + end record; + + package Tree_Types is + new Ada.Containers.Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); + + type Map (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; + + Empty_Map : constant Map := (Capacity => 0, others => <>); + +end Ada.Containers.Formal_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-cforse.adb b/gcc/ada/libgnat/a-cforse.adb new file mode 100644 index 0000000..6c7f8e4 --- /dev/null +++ b/gcc/ada/libgnat/a-cforse.adb @@ -0,0 +1,1898 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations; +pragma Elaborate_All + (Ada.Containers.Red_Black_Trees.Generic_Bounded_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Formal_Ordered_Sets with + SPARK_Mode => Off +is + + ------------------------------ + -- Access to Fields of Node -- + ------------------------------ + + -- These subprograms provide functional notation for access to fields + -- of a node, and procedural notation for modifiying these fields. + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type; + pragma Inline (Color); + + function Left_Son (Node : Node_Type) return Count_Type; + pragma Inline (Left_Son); + + function Parent (Node : Node_Type) return Count_Type; + pragma Inline (Parent); + + function Right_Son (Node : Node_Type) return Count_Type; + pragma Inline (Right_Son); + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type); + pragma Inline (Set_Left); + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- Comments needed??? + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (Tree : in out Tree_Types.Tree_Type'Class; + Node : out Count_Type); + + procedure Free (Tree : in out Set; X : Count_Type); + + procedure Insert_Sans_Hint + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Insert_With_Hint + (Dst_Set : in out Set; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Type) return Boolean; + pragma Inline (Is_Less_Node_Node); + + procedure Replace_Element + (Tree : in out Set; + Node : Count_Type; + Item : Element_Type); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Bounded_Operations + (Tree_Types, + Left => Left_Son, + Right => Right_Son); + + use Tree_Operations; + + package Element_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Red_Black_Trees.Generic_Bounded_Set_Operations + (Tree_Operations => Tree_Operations, + Set_Type => Set, + Assign => Assign, + Insert_With_Hint => Insert_With_Hint, + Is_Less => Is_Less_Node_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + Lst : Count_Type; + Node : Count_Type; + ENode : Count_Type; + + begin + if Length (Left) /= Length (Right) then + return False; + end if; + + if Is_Empty (Left) then + return True; + end if; + + Lst := Next (Left, Last (Left).Node); + + Node := First (Left).Node; + while Node /= Lst loop + ENode := Find (Right, Left.Nodes (Node).Element).Node; + if ENode = 0 + or else Left.Nodes (Node).Element /= Right.Nodes (ENode).Element + then + return False; + end if; + + Node := Next (Left, Node); + end loop; + + return True; + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + procedure Append_Element (Source_Node : Count_Type); + + procedure Append_Elements is + new Tree_Operations.Generic_Iteration (Append_Element); + + -------------------- + -- Append_Element -- + -------------------- + + procedure Append_Element (Source_Node : Count_Type) is + SN : Node_Type renames Source.Nodes (Source_Node); + + procedure Set_Element (Node : in out Node_Type); + pragma Inline (Set_Element); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + procedure Unconditional_Insert_Avec_Hint is + new Element_Keys.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Unconditional_Insert_Sans_Hint); + + procedure Allocate is new Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Target, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := SN.Element; + end Set_Element; + + -- Local variables + + Target_Node : Count_Type; + + -- Start of processing for Append_Element + + begin + Unconditional_Insert_Avec_Hint + (Tree => Target, + Hint => 0, + Key => SN.Element, + Node => Target_Node); + end Append_Element; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Constraint_Error + with "Target capacity is less than Source length"; + end if; + + Tree_Operations.Clear_Tree (Target); + Append_Elements (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := Element_Keys.Ceiling (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + begin + Tree_Operations.Clear_Tree (Container); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Type) return Red_Black_Trees.Color_Type is + begin + return Node.Color; + end Color; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set is + Node : Count_Type; + N : Count_Type; + Target : Set (Count_Type'Max (Source.Capacity, Capacity)); + + begin + if 0 < Capacity and then Capacity < Source.Capacity then + raise Capacity_Error; + end if; + + if Length (Source) > 0 then + Target.Length := Source.Length; + Target.Root := Source.Root; + Target.First := Source.First; + Target.Last := Source.Last; + Target.Free := Source.Free; + + Node := 1; + while Node <= Source.Capacity loop + Target.Nodes (Node).Element := + Source.Nodes (Node).Element; + Target.Nodes (Node).Parent := + Source.Nodes (Node).Parent; + Target.Nodes (Node).Left := + Source.Nodes (Node).Left; + Target.Nodes (Node).Right := + Source.Nodes (Node).Right; + Target.Nodes (Node).Color := + Source.Nodes (Node).Color; + Target.Nodes (Node).Has_Element := + Source.Nodes (Node).Has_Element; + Node := Node + 1; + end loop; + + while Node <= Target.Capacity loop + N := Node; + Formal_Ordered_Sets.Free (Tree => Target, X => N); + Node := Node + 1; + end loop; + end if; + + return Target; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container, + Position.Node); + Formal_Ordered_Sets.Free (Container, Position.Node); + Position := No_Element; + end Delete; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if X = 0 then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + X : constant Count_Type := Container.First; + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + X : constant Count_Type := Container.Last; + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); + end if; + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Set_Difference (Target, Source); + end Difference; + + function Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Length (Left) = 0 then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + return S : Set (Length (Left)) do + Assign (S, Set_Ops.Set_Difference (Left, Right)); + end return; + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Position : Cursor) return Element_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Element"); + + return Container.Nodes (Position.Node).Element; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Is_Equivalent_Node_Node + (L, R : Node_Type) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Type) return Boolean is + begin + if L.Element < R.Element then + return False; + elsif R.Element < L.Element then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left, Right); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : constant Count_Type := Element_Keys.Find (Container, Item); + begin + if X /= 0 then + Tree_Operations.Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Count_Type := Element_Keys.Find (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Length (Container) = 0 then + return No_Element; + end if; + + return (Node => Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + Fst : constant Count_Type := First (Container).Node; + begin + if Fst = 0 then + raise Constraint_Error with "set is empty"; + end if; + + declare + N : Tree_Types.Nodes_Type renames Container.Nodes; + begin + return N (Fst).Element; + end; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + begin + declare + Node : constant Count_Type := Element_Keys.Floor (Container, Item); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end; + end Floor; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ------------------------- + -- E_Bigger_Than_Range -- + ------------------------- + + function E_Bigger_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Item : Element_Type) return Boolean + is + begin + for I in Fst .. Lst loop + if not (E.Get (Container, I) < Item) then + return False; + end if; + end loop; + + return True; + end E_Bigger_Than_Range; + + ------------------------- + -- E_Elements_Included -- + ------------------------- + + function E_Elements_Included + (Left : E.Sequence; + Right : E.Sequence) return Boolean + is + begin + for I in 1 .. E.Length (Left) loop + if not E.Contains (Right, 1, E.Length (Right), E.Get (Left, I)) + then + return False; + end if; + end loop; + + return True; + end E_Elements_Included; + + function E_Elements_Included + (Left : E.Sequence; + Model : M.Set; + Right : E.Sequence) return Boolean + is + begin + for I in 1 .. E.Length (Left) loop + declare + Item : constant Element_Type := E.Get (Left, I); + begin + if M.Contains (Model, Item) then + if not E.Contains (Right, 1, E.Length (Right), Item) then + return False; + end if; + end if; + end; + end loop; + + return True; + end E_Elements_Included; + + function E_Elements_Included + (Container : E.Sequence; + Model : M.Set; + Left : E.Sequence; + Right : E.Sequence) return Boolean + is + begin + for I in 1 .. E.Length (Container) loop + declare + Item : constant Element_Type := E.Get (Container, I); + begin + if M.Contains (Model, Item) then + if not E.Contains (Left, 1, E.Length (Left), Item) then + return False; + end if; + else + if not E.Contains (Right, 1, E.Length (Right), Item) then + return False; + end if; + end if; + end; + end loop; + + return True; + end E_Elements_Included; + + --------------- + -- E_Is_Find -- + --------------- + + function E_Is_Find + (Container : E.Sequence; + Item : Element_Type; + Position : Count_Type) return Boolean + is + begin + for I in 1 .. Position - 1 loop + if Item < E.Get (Container, I) then + return False; + end if; + end loop; + + if Position < E.Length (Container) then + for I in Position + 1 .. E.Length (Container) loop + if E.Get (Container, I) < Item then + return False; + end if; + end loop; + end if; + + return True; + end E_Is_Find; + + -------------------------- + -- E_Smaller_Than_Range -- + -------------------------- + + function E_Smaller_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Item : Element_Type) return Boolean + is + begin + for I in Fst .. Lst loop + if not (Item < E.Get (Container, I)) then + return False; + end if; + end loop; + + return True; + end E_Smaller_Than_Range; + + ---------- + -- Find -- + ---------- + + function Find + (Container : E.Sequence; + Item : Element_Type) return Count_Type + is + begin + for I in 1 .. E.Length (Container) loop + if Equivalent_Elements (Item, E.Get (Container, I)) then + return I; + end if; + end loop; + + return 0; + end Find; + + -------------- + -- Elements -- + -------------- + + function Elements (Container : Set) return E.Sequence is + Position : Count_Type := Container.First; + R : E.Sequence; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := E.Add (R, Container.Nodes (Position).Element); + Position := Tree_Operations.Next (Container, Position); + end loop; + + return R; + end Elements; + + ---------------------------- + -- Lift_Abstraction_Level -- + ---------------------------- + + procedure Lift_Abstraction_Level (Container : Set) is null; + + ----------------------- + -- Mapping_Preserved -- + ----------------------- + + function Mapping_Preserved + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + is + begin + for C of P_Left loop + if not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > E.Length (E_Left) + or else P.Get (P_Right, C) > E.Length (E_Right) + or else E.Get (E_Left, P.Get (P_Left, C)) /= + E.Get (E_Right, P.Get (P_Right, C)) + then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved; + + ------------------------------ + -- Mapping_Preserved_Except -- + ------------------------------ + + function Mapping_Preserved_Except + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map; + Position : Cursor) return Boolean + is + begin + for C of P_Left loop + if C /= Position + and (not P.Has_Key (P_Right, C) + or else P.Get (P_Left, C) > E.Length (E_Left) + or else P.Get (P_Right, C) > E.Length (E_Right) + or else E.Get (E_Left, P.Get (P_Left, C)) /= + E.Get (E_Right, P.Get (P_Right, C))) + then + return False; + end if; + end loop; + + return True; + end Mapping_Preserved_Except; + + ------------------------- + -- P_Positions_Shifted -- + ------------------------- + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + is + begin + for Cu of Small loop + if not P.Has_Key (Big, Cu) then + return False; + end if; + end loop; + + for Cu of Big loop + declare + Pos : constant Positive_Count_Type := P.Get (Big, Cu); + + begin + if Pos < Cut then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + then + return False; + end if; + + elsif Pos >= Cut + Count then + if not P.Has_Key (Small, Cu) + or else Pos /= P.Get (Small, Cu) + Count + then + return False; + end if; + + else + if P.Has_Key (Small, Cu) then + return False; + end if; + end if; + end; + end loop; + + return True; + end P_Positions_Shifted; + + ----------- + -- Model -- + ----------- + + function Model (Container : Set) return M.Set is + Position : Count_Type := Container.First; + R : M.Set; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := + M.Add + (Container => R, + Item => Container.Nodes (Position).Element); + + Position := Tree_Operations.Next (Container, Position); + end loop; + + return R; + end Model; + + --------------- + -- Positions -- + --------------- + + function Positions (Container : Set) return P.Map is + I : Count_Type := 1; + Position : Count_Type := Container.First; + R : P.Map; + + begin + -- Can't use First, Next or Element here, since they depend on models + -- for their postconditions. + + while Position /= 0 loop + R := P.Add (R, (Node => Position), I); + pragma Assert (P.Length (R) = I); + Position := Tree_Operations.Next (Container, Position); + I := I + 1; + end loop; + + return R; + end Positions; + + end Formal_Model; + + ---------- + -- Free -- + ---------- + + procedure Free (Tree : in out Set; X : Count_Type) is + begin + Tree.Nodes (X).Has_Element := False; + Tree_Operations.Free (Tree, X); + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (Tree : in out Tree_Types.Tree_Type'Class; + Node : out Count_Type) + is + procedure Allocate is + new Tree_Operations.Generic_Allocate (Set_Element); + begin + Allocate (Tree, Node); + Tree.Nodes (Node).Has_Element := True; + end Generic_Allocate; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys with SPARK_Mode => Off is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Bounded_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Ceiling (Container, Key); + + begin + if Node = 0 then + return No_Element; + end if; + + return (Node => Node); + end Ceiling; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if X = 0 then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + + begin + if Node = 0 then + raise Constraint_Error with "key not in set"; + end if; + + declare + N : Tree_Types.Nodes_Type renames Container.Nodes; + begin + return N (Node).Element; + end; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : constant Count_Type := Key_Keys.Find (Container, Key); + begin + if X /= 0 then + Delete_Node_Sans_Free (Container, X); + Formal_Ordered_Sets.Free (Container, X); + end if; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + begin + return (if Node = 0 then No_Element else (Node => Node)); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Count_Type := Key_Keys.Floor (Container, Key); + begin + return (if Node = 0 then No_Element else (Node => Node)); + end Floor; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ------------------------- + -- E_Bigger_Than_Range -- + ------------------------- + + function E_Bigger_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + is + begin + for I in Fst .. Lst loop + if not (Generic_Keys.Key (E.Get (Container, I)) < Key) then + return False; + end if; + end loop; + return True; + end E_Bigger_Than_Range; + + --------------- + -- E_Is_Find -- + --------------- + + function E_Is_Find + (Container : E.Sequence; + Key : Key_Type; + Position : Count_Type) return Boolean + is + begin + for I in 1 .. Position - 1 loop + if Key < Generic_Keys.Key (E.Get (Container, I)) then + return False; + end if; + end loop; + + if Position < E.Length (Container) then + for I in Position + 1 .. E.Length (Container) loop + if Generic_Keys.Key (E.Get (Container, I)) < Key then + return False; + end if; + end loop; + end if; + return True; + end E_Is_Find; + + -------------------------- + -- E_Smaller_Than_Range -- + -------------------------- + + function E_Smaller_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + is + begin + for I in Fst .. Lst loop + if not (Key < Generic_Keys.Key (E.Get (Container, I))) then + return False; + end if; + end loop; + return True; + end E_Smaller_Than_Range; + + ---------- + -- Find -- + ---------- + + function Find + (Container : E.Sequence; + Key : Key_Type) return Count_Type + is + begin + for I in 1 .. E.Length (Container) loop + if Equivalent_Keys + (Key, Generic_Keys.Key (E.Get (Container, I))) + then + return I; + end if; + end loop; + return 0; + end Find; + + ----------------------- + -- M_Included_Except -- + ----------------------- + + function M_Included_Except + (Left : M.Set; + Right : M.Set; + Key : Key_Type) return Boolean + is + begin + for E of Left loop + if not Contains (Right, E) + and not Equivalent_Keys (Generic_Keys.Key (E), Key) + then + return False; + end if; + end loop; + return True; + end M_Included_Except; + end Formal_Model; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Key (Right.Element) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Key (Right.Element); + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Container : Set; Position : Cursor) return Key_Type is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Key"); + + declare + N : Tree_Types.Nodes_Type renames Container.Nodes; + begin + return Key (N (Position.Node).Element); + end; + end Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Count_Type := Key_Keys.Find (Container, Key); + begin + if not Has_Element (Container, (Node => Node)) then + raise Constraint_Error with + "attempt to replace key not in set"; + else + Replace_Element (Container, Node, New_Item); + end if; + end Replace; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Container : Set; Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return False; + else + return Container.Nodes (Position.Node).Has_Element; + end if; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + declare + N : Tree_Types.Nodes_Type renames Container.Nodes; + begin + N (Position.Node).Element := New_Item; + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert_Sans_Hint (Container, New_Item, Position.Node, Inserted); + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Container : in out Set; + New_Item : Element_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + procedure Set_Element (Node : in out Node_Type); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Conditional_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Allocate is new Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Container, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := New_Item; + end Set_Element; + + -- Start of processing for Insert_Sans_Hint + + begin + Conditional_Insert_Sans_Hint + (Container, + New_Item, + Node, + Inserted); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Set : in out Set; + Dst_Hint : Count_Type; + Src_Node : Node_Type; + Dst_Node : out Count_Type) + is + Success : Boolean; + pragma Unreferenced (Success); + + procedure Set_Element (Node : in out Node_Type); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, Insert_Sans_Hint); + + procedure Allocate is new Generic_Allocate (Set_Element); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + Result : Count_Type; + begin + Allocate (Dst_Set, Result); + return Result; + end New_Node; + + ----------------- + -- Set_Element -- + ----------------- + + procedure Set_Element (Node : in out Node_Type) is + begin + Node.Element := Src_Node.Element; + end Set_Element; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Set, + Dst_Hint, + Src_Node.Element, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + Set_Ops.Set_Intersection (Target, Source); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left.Copy; + end if; + + return S : Set (Count_Type'Min (Length (Left), Length (Right))) do + Assign (S, Set_Ops.Set_Intersection (Left, Right)); + end return; + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Length (Container) = 0; + end Is_Empty; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + -- Compute e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Type) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Type) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + return Set_Ops.Set_Subset (Subset, Of_Set => Of_Set); + end Is_Subset; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + return (if Length (Container) = 0 + then No_Element + else (Node => Container.Last)); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Last (Container).Node = 0 then + raise Constraint_Error with "set is empty"; + end if; + + declare + N : Tree_Types.Nodes_Type renames Container.Nodes; + begin + return N (Last (Container).Node).Element; + end; + end Last_Element; + + -------------- + -- Left_Son -- + -------------- + + function Left_Son (Node : Node_Type) return Count_Type is + begin + return Node.Left; + end Left_Son; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + N : Tree_Types.Nodes_Type renames Source.Nodes; + X : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Length (Source) then + raise Constraint_Error with -- ??? + "Source length exceeds Target capacity"; + end if; + + Clear (Target); + + loop + X := Source.First; + exit when X = 0; + + Insert (Target, N (X).Element); -- optimize??? + + Tree_Operations.Delete_Node_Sans_Free (Source, X); + Formal_Ordered_Sets.Free (Source, X); + end loop; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Container : Set; Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Next"); + return (Node => Tree_Operations.Next (Container, Position.Node)); + end Next; + + procedure Next (Container : Set; Position : in out Cursor) is + begin + Position := Next (Container, Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + return Set_Ops.Set_Overlap (Left, Right); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Type) return Count_Type is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Container : Set; Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if not Has_Element (Container, Position) then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Count_Type := + Tree_Operations.Previous (Container, Position.Node); + begin + return (if Node = 0 then No_Element else (Node => Node)); + end; + end Previous; + + procedure Previous (Container : Set; Position : in out Cursor) is + begin + Position := Previous (Container, Position); + end Previous; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Count_Type := Element_Keys.Find (Container, New_Item); + + begin + if Node = 0 then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + Container.Nodes (Node).Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Tree : in out Set; + Node : Count_Type; + Item : Element_Type) + is + pragma Assert (Node /= 0); + + function New_Node return Count_Type; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + NN : Tree_Types.Nodes_Type renames Tree.Nodes; + + -------------- + -- New_Node -- + -------------- + + function New_Node return Count_Type is + N : Node_Type renames NN (Node); + begin + N.Element := Item; + N.Color := Red; + N.Parent := 0; + N.Right := 0; + N.Left := 0; + return Node; + end New_Node; + + Hint : Count_Type; + Result : Count_Type; + Inserted : Boolean; + + -- Start of processing for Insert + + begin + if Item < NN (Node).Element + or else NN (Node).Element < Item + then + null; + + else + NN (Node).Element := Item; + return; + end if; + + Hint := Element_Keys.Ceiling (Tree, Item); + + if Hint = 0 then + null; + + elsif Item < NN (Hint).Element then + if Hint = Node then + NN (Node).Element := Item; + return; + end if; + + else + pragma Assert (not (NN (Hint).Element < Item)); + raise Program_Error with "attempt to replace existing element"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); + + Local_Insert_With_Hint + (Tree => Tree, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); + + pragma Assert (Inserted); + pragma Assert (Result = Node); + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if not Has_Element (Container, Position) then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Container, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container, Position.Node, New_Item); + end Replace_Element; + + --------------- + -- Right_Son -- + --------------- + + function Right_Son (Node : Node_Type) return Count_Type is + begin + return Node.Right; + end Right_Son; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : in out Node_Type; + Color : Red_Black_Trees.Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : in out Node_Type; Left : Count_Type) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : in out Node_Type; Parent : Count_Type) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : in out Node_Type; Right : Count_Type) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Set_Symmetric_Difference (Target, Source); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + end if; + + return S : Set (Length (Left) + Length (Right)) do + Assign (S, Set_Ops.Set_Symmetric_Difference (Left, Right)); + end return; + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Node : Count_Type; + Inserted : Boolean; + begin + return S : Set (Capacity => 1) do + Insert_Sans_Hint (S, New_Item, Node, Inserted); + pragma Assert (Inserted); + end return; + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + Set_Ops.Set_Union (Target, Source); + end Union; + + function Union (Left, Right : Set) return Set is + begin + if Left'Address = Right'Address then + return Left.Copy; + end if; + + if Length (Left) = 0 then + return Right.Copy; + end if; + + if Length (Right) = 0 then + return Left.Copy; + end if; + + return S : Set (Length (Left) + Length (Right)) do + Assign (S, Source => Left); + Union (S, Right); + end return; + end Union; + +end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cforse.ads b/gcc/ada/libgnat/a-cforse.ads new file mode 100644 index 0000000..6c1323d --- /dev/null +++ b/gcc/ada/libgnat/a-cforse.ads @@ -0,0 +1,1784 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ O R D E R E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This spec is derived from package Ada.Containers.Bounded_Ordered_Sets in +-- the Ada 2012 RM. The modifications are meant to facilitate formal proofs by +-- making it easier to express properties, and by making the specification of +-- this unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. + +-- The modifications are: + +-- A parameter for the container is added to every function reading the +-- content of a container: Key, Element, Next, Query_Element, Previous, +-- Has_Element, Iterate, Reverse_Iterate. This change is motivated by the +-- need to have cursors which are valid on different containers (typically +-- a container C and its previous version C'Old) for expressing properties, +-- which is not possible if cursors encapsulate an access to the underlying +-- container. The operators "<" and ">" that could not be modified that way +-- have been removed. + +with Ada.Containers.Functional_Maps; +with Ada.Containers.Functional_Sets; +with Ada.Containers.Functional_Vectors; +private with Ada.Containers.Red_Black_Trees; + +generic + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Formal_Ordered_Sets with + SPARK_Mode +is + pragma Annotate (CodePeer, Skip_Analysis); + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean + with + Global => null, + Post => + Equivalent_Elements'Result = + (not (Left < Right) and not (Right < Left)); + pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Elements); + + type Set (Capacity : Count_Type) is private with + Iterable => (First => First, + Next => Next, + Has_Element => Has_Element, + Element => Element), + Default_Initial_Condition => Is_Empty (Set); + pragma Preelaborable_Initialization (Set); + + type Cursor is record + Node : Count_Type; + end record; + + No_Element : constant Cursor := (Node => 0); + + function Length (Container : Set) return Count_Type with + Global => null, + Post => Length'Result <= Container.Capacity; + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package M is new Ada.Containers.Functional_Sets + (Element_Type => Element_Type, + Equivalent_Elements => Equivalent_Elements); + + function "=" + (Left : M.Set; + Right : M.Set) return Boolean renames M."="; + + function "<=" + (Left : M.Set; + Right : M.Set) return Boolean renames M."<="; + + package E is new Ada.Containers.Functional_Vectors + (Element_Type => Element_Type, + Index_Type => Positive_Count_Type); + + function "=" + (Left : E.Sequence; + Right : E.Sequence) return Boolean renames E."="; + + function "<" + (Left : E.Sequence; + Right : E.Sequence) return Boolean renames E."<"; + + function "<=" + (Left : E.Sequence; + Right : E.Sequence) return Boolean renames E."<="; + + function E_Bigger_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Item : Element_Type) return Boolean + with + Global => null, + Pre => Lst <= E.Length (Container), + Post => + E_Bigger_Than_Range'Result = + (for all I in Fst .. Lst => E.Get (Container, I) < Item); + pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); + + function E_Smaller_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Item : Element_Type) return Boolean + with + Global => null, + Pre => Lst <= E.Length (Container), + Post => + E_Smaller_Than_Range'Result = + (for all I in Fst .. Lst => Item < E.Get (Container, I)); + pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); + + function E_Is_Find + (Container : E.Sequence; + Item : Element_Type; + Position : Count_Type) return Boolean + with + Global => null, + Pre => Position - 1 <= E.Length (Container), + Post => + E_Is_Find'Result = + + ((if Position > 0 then + E_Bigger_Than_Range (Container, 1, Position - 1, Item)) + + and (if Position < E.Length (Container) then + E_Smaller_Than_Range + (Container, + Position + 1, + E.Length (Container), + Item))); + pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); + + function Find + (Container : E.Sequence; + Item : Element_Type) return Count_Type + -- Search for Item in Container + + with + Global => null, + Post => + (if Find'Result > 0 then + Find'Result <= E.Length (Container) + and Equivalent_Elements (Item, E.Get (Container, Find'Result))); + + function E_Elements_Included + (Left : E.Sequence; + Right : E.Sequence) return Boolean + -- The elements of Left are contained in Right + + with + Global => null, + Post => + E_Elements_Included'Result = + (for all I in 1 .. E.Length (Left) => + Find (Right, E.Get (Left, I)) > 0 + and then E.Get (Right, Find (Right, E.Get (Left, I))) = + E.Get (Left, I)); + pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); + + function E_Elements_Included + (Left : E.Sequence; + Model : M.Set; + Right : E.Sequence) return Boolean + -- The elements of Container contained in Model are in Right + + with + Global => null, + Post => + E_Elements_Included'Result = + (for all I in 1 .. E.Length (Left) => + (if M.Contains (Model, E.Get (Left, I)) then + Find (Right, E.Get (Left, I)) > 0 + and then E.Get (Right, Find (Right, E.Get (Left, I))) = + E.Get (Left, I))); + pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); + + function E_Elements_Included + (Container : E.Sequence; + Model : M.Set; + Left : E.Sequence; + Right : E.Sequence) return Boolean + -- The elements of Container contained in Model are in Left and others + -- are in Right. + + with + Global => null, + Post => + E_Elements_Included'Result = + (for all I in 1 .. E.Length (Container) => + (if M.Contains (Model, E.Get (Container, I)) then + Find (Left, E.Get (Container, I)) > 0 + and then E.Get (Left, Find (Left, E.Get (Container, I))) = + E.Get (Container, I) + else + Find (Right, E.Get (Container, I)) > 0 + and then E.Get (Right, Find (Right, E.Get (Container, I))) = + E.Get (Container, I))); + pragma Annotate (GNATprove, Inline_For_Proof, E_Elements_Included); + + package P is new Ada.Containers.Functional_Maps + (Key_Type => Cursor, + Element_Type => Positive_Count_Type, + Equivalent_Keys => "=", + Enable_Handling_Of_Equivalence => False); + + function "=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."="; + + function "<=" + (Left : P.Map; + Right : P.Map) return Boolean renames P."<="; + + function P_Positions_Shifted + (Small : P.Map; + Big : P.Map; + Cut : Positive_Count_Type; + Count : Count_Type := 1) return Boolean + with + Global => null, + Post => + P_Positions_Shifted'Result = + + -- Big contains all cursors of Small + + (P.Keys_Included (Small, Big) + + -- Cursors located before Cut are not moved, cursors located + -- after are shifted by Count. + + and (for all I of Small => + (if P.Get (Small, I) < Cut then + P.Get (Big, I) = P.Get (Small, I) + else + P.Get (Big, I) - Count = P.Get (Small, I))) + + -- New cursors of Big (if any) are between Cut and Cut - 1 + + -- Count. + + and (for all I of Big => + P.Has_Key (Small, I) + or P.Get (Big, I) - Count in Cut - Count .. Cut - 1)); + + function Mapping_Preserved + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map) return Boolean + with + Ghost, + Global => null, + Post => + (if Mapping_Preserved'Result then + + -- Right contains all the cursors of Left + + P.Keys_Included (P_Left, P_Right) + + -- Right contains all the elements of Left + + and E_Elements_Included (E_Left, E_Right) + + -- Mappings from cursors to elements induced by E_Left, P_Left + -- and E_Right, P_Right are the same. + + and (for all C of P_Left => + E.Get (E_Left, P.Get (P_Left, C)) = + E.Get (E_Right, P.Get (P_Right, C)))); + + function Mapping_Preserved_Except + (E_Left : E.Sequence; + E_Right : E.Sequence; + P_Left : P.Map; + P_Right : P.Map; + Position : Cursor) return Boolean + with + Ghost, + Global => null, + Post => + (if Mapping_Preserved_Except'Result then + + -- Right contains all the cursors of Left + + P.Keys_Included (P_Left, P_Right) + + -- Mappings from cursors to elements induced by E_Left, P_Left + -- and E_Right, P_Right are the same except for Position. + + and (for all C of P_Left => + (if C /= Position then + E.Get (E_Left, P.Get (P_Left, C)) = + E.Get (E_Right, P.Get (P_Right, C))))); + + function Model (Container : Set) return M.Set with + -- The high-level model of a set is a set of elements. Neither cursors + -- nor order of elements are represented in this model. Elements are + -- modeled up to equivalence. + + Ghost, + Global => null, + Post => M.Length (Model'Result) = Length (Container); + + function Elements (Container : Set) return E.Sequence with + -- The Elements sequence represents the underlying list structure of + -- sets that is used for iteration. It stores the actual values of + -- elements in the set. It does not model cursors. + + Ghost, + Global => null, + Post => + E.Length (Elements'Result) = Length (Container) + + -- It only contains keys contained in Model + + and (for all Item of Elements'Result => + M.Contains (Model (Container), Item)) + + -- It contains all the elements contained in Model + + and (for all Item of Model (Container) => + (Find (Elements'Result, Item) > 0 + and then Equivalent_Elements + (E.Get (Elements'Result, Find (Elements'Result, Item)), + Item))) + + -- It is sorted in increasing order + + and (for all I in 1 .. Length (Container) => + Find (Elements'Result, E.Get (Elements'Result, I)) = I + and + E_Is_Find + (Elements'Result, E.Get (Elements'Result, I), I)); + pragma Annotate (GNATprove, Iterable_For_Proof, "Model", Elements); + + function Positions (Container : Set) return P.Map with + -- The Positions map is used to model cursors. It only contains valid + -- cursors and maps them to their position in the container. + + Ghost, + Global => null, + Post => + not P.Has_Key (Positions'Result, No_Element) + + -- Positions of cursors are smaller than the container's length + + and then + (for all I of Positions'Result => + P.Get (Positions'Result, I) in 1 .. Length (Container) + + -- No two cursors have the same position. Note that we do not + -- state that there is a cursor in the map for each position, as + -- it is rarely needed. + + and then + (for all J of Positions'Result => + (if P.Get (Positions'Result, I) = P.Get (Positions'Result, J) + then I = J))); + + procedure Lift_Abstraction_Level (Container : Set) with + -- Lift_Abstraction_Level is a ghost procedure that does nothing but + -- assume that we can access the same elements by iterating over + -- positions or cursors. + -- This information is not generally useful except when switching from + -- a low-level, cursor-aware view of a container, to a high-level, + -- position-based view. + + Ghost, + Global => null, + Post => + (for all Item of Elements (Container) => + (for some I of Positions (Container) => + E.Get (Elements (Container), P.Get (Positions (Container), I)) = + Item)); + + function Contains + (C : M.Set; + K : Element_Type) return Boolean renames M.Contains; + -- To improve readability of contracts, we rename the function used to + -- search for an element in the model to Contains. + + end Formal_Model; + use Formal_Model; + + Empty_Set : constant Set; + + function "=" (Left, Right : Set) return Boolean with + Global => null, + Post => + + -- If two sets are equal, they contain the same elements in the same + -- order. + + (if "="'Result then Elements (Left) = Elements (Right) + + -- If they are different, then they do not contain the same elements + + else + not E_Elements_Included (Elements (Left), Elements (Right)) + or not E_Elements_Included (Elements (Right), Elements (Left))); + + function Equivalent_Sets (Left, Right : Set) return Boolean with + Global => null, + Post => Equivalent_Sets'Result = (Model (Left) = Model (Right)); + + function To_Set (New_Item : Element_Type) return Set with + Global => null, + Post => + M.Is_Singleton (Model (To_Set'Result), New_Item) + and Length (To_Set'Result) = 1 + and E.Get (Elements (To_Set'Result), 1) = New_Item; + + function Is_Empty (Container : Set) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out Set) with + Global => null, + Post => Length (Container) = 0 and M.Is_Empty (Model (Container)); + + procedure Assign (Target : in out Set; Source : Set) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Model (Target) = Model (Source) + and Elements (Target) = Elements (Source) + and Length (Target) = Length (Source); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set with + Global => null, + Pre => Capacity = 0 or else Capacity >= Source.Capacity, + Post => + Model (Copy'Result) = Model (Source) + and Elements (Copy'Result) = Elements (Source) + and Positions (Copy'Result) = Positions (Source) + and (if Capacity = 0 then + Copy'Result.Capacity = Source.Capacity + else + Copy'Result.Capacity = Capacity); + + function Element + (Container : Set; + Position : Cursor) return Element_Type + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Element'Result = + E.Get (Elements (Container), P.Get (Positions (Container), Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Length (Container) = Length (Container)'Old + + -- Position now maps to New_Item + + and Element (Container, Position) = New_Item + + -- New_Item is contained in Container + + and Contains (Model (Container), New_Item) + + -- Other elements are preserved + + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Element (Container, Position)'Old) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved_Except + (E_Left => Elements (Container)'Old, + E_Right => Elements (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container), + Position => Position) + and Positions (Container) = Positions (Container)'Old; + + procedure Move (Target : in out Set; Source : in out Set) with + Global => null, + Pre => Target.Capacity >= Length (Source), + Post => + Model (Target) = Model (Source)'Old + and Elements (Target) = Elements (Source)'Old + and Length (Source)'Old = Length (Target) + and Length (Source) = 0; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + or Contains (Container, New_Item), + Post => + Contains (Container, New_Item) + and Has_Element (Container, Position) + and Equivalent_Elements (Element (Container, Position), New_Item) + and E_Is_Find + (Elements (Container), + New_Item, + P.Get (Positions (Container), Position)), + Contract_Cases => + + -- If New_Item is already in Container, it is not modified and Inserted + -- is set to False. + + (Contains (Container, New_Item) => + not Inserted + and Model (Container) = Model (Container)'Old + and Elements (Container) = Elements (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, New_Item is inserted in Container and Inserted is set to + -- True + + others => + Inserted + and Length (Container) = Length (Container)'Old + 1 + + -- Position now maps to New_Item + + and Element (Container, Position) = New_Item + + -- Other elements are preserved + + and Model (Container)'Old <= Model (Container) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- The elements of Container located before Position are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => P.Get (Positions (Container), Position) - 1) + + -- Other elements are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => P.Get (Positions (Container), Position), + Lst => Length (Container)'Old, + Offset => 1) + + -- A new cursor has been inserted at position Position in + -- Container. + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => P.Get (Positions (Container), Position))); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + and then (not Contains (Container, New_Item)), + Post => + Length (Container) = Length (Container)'Old + 1 + and Contains (Container, New_Item) + + -- New_Item is inserted in the set + + and E.Get (Elements (Container), + Find (Elements (Container), New_Item)) = New_Item + + -- Other mappings are preserved + + and Model (Container)'Old <= Model (Container) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- The elements of Container located before New_Item are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => Find (Elements (Container), New_Item) - 1) + + -- Other elements are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => Find (Elements (Container), New_Item), + Lst => Length (Container)'Old, + Offset => 1) + + -- A new cursor has been inserted in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => Find (Elements (Container), New_Item)); + + procedure Include + (Container : in out Set; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Container.Capacity + or Contains (Container, New_Item), + Post => Contains (Container, New_Item), + Contract_Cases => + + -- If New_Item is already in Container + + (Contains (Container, New_Item) => + + -- Elements are preserved + + Model (Container)'Old = Model (Container) + + -- Cursors are preserved + + and Positions (Container) = Positions (Container)'Old + + -- The element equivalent to New_Item in Container is replaced by + -- New_Item. + + and E.Get (Elements (Container), + Find (Elements (Container), New_Item)) = New_Item + + and E.Equal_Except + (Elements (Container)'Old, + Elements (Container), + Find (Elements (Container), New_Item)), + + -- Otherwise, New_Item is inserted in Container + + others => + Length (Container) = Length (Container)'Old + 1 + + -- Other elements are preserved + + and Model (Container)'Old <= Model (Container) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- New_Item is inserted in Container + + and E.Get (Elements (Container), + Find (Elements (Container), New_Item)) = New_Item + + -- The Elements of Container located before New_Item are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => Find (Elements (Container), New_Item) - 1) + + -- Other Elements are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => Find (Elements (Container), New_Item), + Lst => Length (Container)'Old, + Offset => 1) + + -- A new cursor has been inserted in Container + + and P_Positions_Shifted + (Positions (Container)'Old, + Positions (Container), + Cut => Find (Elements (Container), New_Item))); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + with + Global => null, + Pre => Contains (Container, New_Item), + Post => + + -- Elements are preserved + + Model (Container)'Old = Model (Container) + + -- Cursors are preserved + + and Positions (Container) = Positions (Container)'Old + + -- The element equivalent to New_Item in Container is replaced by + -- New_Item. + + and E.Get (Elements (Container), + Find (Elements (Container), New_Item)) = New_Item + and E.Equal_Except + (Elements (Container)'Old, + Elements (Container), + Find (Elements (Container), New_Item)); + + procedure Exclude + (Container : in out Set; + Item : Element_Type) + with + Global => null, + Post => not Contains (Container, Item), + Contract_Cases => + + -- If Item is not in Container, nothing is changed + + (not Contains (Container, Item) => + Model (Container) = Model (Container)'Old + and Elements (Container) = Elements (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Item is removed from Container + + others => + Length (Container) = Length (Container)'Old - 1 + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Item) + + -- The elements of Container located before Item are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => Find (Elements (Container), Item)'Old - 1) + + -- The elements located after Item are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container), + Right => Elements (Container)'Old, + Fst => Find (Elements (Container), Item)'Old, + Lst => Length (Container), + Offset => 1) + + -- A cursor has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => Find (Elements (Container), Item)'Old)); + + procedure Delete + (Container : in out Set; + Item : Element_Type) + with + Global => null, + Pre => Contains (Container, Item), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Item is no longer in Container + + and not Contains (Container, Item) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Item) + + -- The elements of Container located before Item are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => Find (Elements (Container), Item)'Old - 1) + + -- The elements located after Item are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container), + Right => Elements (Container)'Old, + Fst => Find (Elements (Container), Item)'Old, + Lst => Length (Container), + Offset => 1) + + -- A cursor has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => Find (Elements (Container), Item)'Old); + + procedure Delete + (Container : in out Set; + Position : in out Cursor) + with + Global => null, + Pre => Has_Element (Container, Position), + Post => + Position = No_Element + and Length (Container) = Length (Container)'Old - 1 + + -- The element at position Position is no longer in Container + + and not Contains (Container, Element (Container, Position)'Old) + and not P.Has_Key (Positions (Container), Position'Old) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Element (Container, Position)'Old) + + -- The elements of Container located before Position are preserved. + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => P.Get (Positions (Container)'Old, Position'Old) - 1) + + -- The elements located after Position are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container), + Right => Elements (Container)'Old, + Fst => P.Get (Positions (Container)'Old, Position'Old), + Lst => Length (Container), + Offset => 1) + + -- Position has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => P.Get (Positions (Container)'Old, Position'Old)); + + procedure Delete_First (Container : in out Set) with + Global => null, + Contract_Cases => + (Length (Container) = 0 => Length (Container) = 0, + others => + Length (Container) = Length (Container)'Old - 1 + + -- The first element has been removed from Container + + and not Contains (Container, First_Element (Container)'Old) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + First_Element (Container)'Old) + + -- Other elements are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container), + Right => Elements (Container)'Old, + Fst => 1, + Lst => Length (Container), + Offset => 1) + + -- First has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => 1)); + + procedure Delete_Last (Container : in out Set) with + Global => null, + Contract_Cases => + (Length (Container) = 0 => Length (Container) = 0, + others => + Length (Container) = Length (Container)'Old - 1 + + -- The last element has been removed from Container + + and not Contains (Container, Last_Element (Container)'Old) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M.Included_Except + (Model (Container)'Old, + Model (Container), + Last_Element (Container)'Old) + + -- Others elements of Container are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => Length (Container)) + + -- Last cursor has been removed from Container + + and Positions (Container) <= Positions (Container)'Old); + + procedure Union (Target : in out Set; Source : Set) with + Global => null, + Pre => + Length (Source) - Length (Target and Source) <= + Target.Capacity - Length (Target), + Post => + Length (Target) = Length (Target)'Old + - M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + Length (Source) + + -- Elements already in Target are still in Target + + and Model (Target)'Old <= Model (Target) + + -- Elements of Source are included in Target + + and Model (Source) <= Model (Target) + + -- Elements of Target come from either Source or Target + + and + M.Included_In_Union + (Model (Target), Model (Source), Model (Target)'Old) + + -- Actual value of elements come from either Left or Right + + and + E_Elements_Included + (Elements (Target), + Model (Target)'Old, + Elements (Target)'Old, + Elements (Source)) + and + E_Elements_Included + (Elements (Target)'Old, Model (Target)'Old, Elements (Target)) + and + E_Elements_Included + (Elements (Source), + Model (Target)'Old, + Elements (Source), + Elements (Target)) + + -- Mapping from cursors of Target to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Target)'Old, + E_Right => Elements (Target), + P_Left => Positions (Target)'Old, + P_Right => Positions (Target)); + + function Union (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) <= Count_Type'Last - Length (Right), + Post => + Length (Union'Result) = Length (Left) + - M.Num_Overlaps (Model (Left), Model (Right)) + + Length (Right) + + -- Elements of Left and Right are in the result of Union + + and Model (Left) <= Model (Union'Result) + and Model (Right) <= Model (Union'Result) + + -- Elements of the result of union come from either Left or Right + + and + M.Included_In_Union + (Model (Union'Result), Model (Left), Model (Right)) + + -- Actual value of elements come from either Left or Right + + and + E_Elements_Included + (Elements (Union'Result), + Model (Left), + Elements (Left), + Elements (Right)) + and + E_Elements_Included + (Elements (Left), Model (Left), Elements (Union'Result)) + and + E_Elements_Included + (Elements (Right), + Model (Left), + Elements (Right), + Elements (Union'Result)); + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set) with + Global => null, + Post => + Length (Target) = + M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + -- Elements of Target were already in Target + + and Model (Target) <= Model (Target)'Old + + -- Elements of Target are in Source + + and Model (Target) <= Model (Source) + + -- Elements both in Source and Target are in the intersection + + and + M.Includes_Intersection + (Model (Target), Model (Source), Model (Target)'Old) + + -- Actual value of elements of Target is preserved + + and E_Elements_Included (Elements (Target), Elements (Target)'Old) + and + E_Elements_Included + (Elements (Target)'Old, Model (Source), Elements (Target)) + + -- Mapping from cursors of Target to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Target), + E_Right => Elements (Target)'Old, + P_Left => Positions (Target), + P_Right => Positions (Target)'Old); + + function Intersection (Left, Right : Set) return Set with + Global => null, + Post => + Length (Intersection'Result) = + M.Num_Overlaps (Model (Left), Model (Right)) + + -- Elements in the result of Intersection are in Left and Right + + and Model (Intersection'Result) <= Model (Left) + and Model (Intersection'Result) <= Model (Right) + + -- Elements both in Left and Right are in the result of Intersection + + and + M.Includes_Intersection + (Model (Intersection'Result), Model (Left), Model (Right)) + + -- Actual value of elements come from Left + + and + E_Elements_Included + (Elements (Intersection'Result), Elements (Left)) + and + E_Elements_Included + (Elements (Left), Model (Right), Elements (Intersection'Result)); + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set) with + Global => null, + Post => + Length (Target) = Length (Target)'Old - + M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + -- Elements of Target were already in Target + + and Model (Target) <= Model (Target)'Old + + -- Elements of Target are not in Source + + and M.No_Overlap (Model (Target), Model (Source)) + + -- Elements in Target but not in Source are in the difference + + and + M.Included_In_Union + (Model (Target)'Old, Model (Target), Model (Source)) + + -- Actual value of elements of Target is preserved + + and E_Elements_Included (Elements (Target), Elements (Target)'Old) + and + E_Elements_Included + (Elements (Target)'Old, Model (Target), Elements (Target)) + + -- Mapping from cursors of Target to elements is preserved + + and Mapping_Preserved + (E_Left => Elements (Target), + E_Right => Elements (Target)'Old, + P_Left => Positions (Target), + P_Right => Positions (Target)'Old); + + function Difference (Left, Right : Set) return Set with + Global => null, + Post => + Length (Difference'Result) = Length (Left) - + M.Num_Overlaps (Model (Left), Model (Right)) + + -- Elements of the result of Difference are in Left + + and Model (Difference'Result) <= Model (Left) + + -- Elements of the result of Difference are in Right + + and M.No_Overlap (Model (Difference'Result), Model (Right)) + + -- Elements in Left but not in Right are in the difference + + and + M.Included_In_Union + (Model (Left), Model (Difference'Result), Model (Right)) + + -- Actual value of elements come from Left + + and + E_Elements_Included (Elements (Difference'Result), Elements (Left)) + and + E_Elements_Included + (Elements (Left), + Model (Difference'Result), + Elements (Difference'Result)); + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set) with + Global => null, + Pre => + Length (Source) - Length (Target and Source) <= + Target.Capacity - Length (Target) + Length (Target and Source), + Post => + Length (Target) = Length (Target)'Old - + 2 * M.Num_Overlaps (Model (Target)'Old, Model (Source)) + + Length (Source) + + -- Elements of the difference were not both in Source and in Target + + and M.Not_In_Both (Model (Target), Model (Target)'Old, Model (Source)) + + -- Elements in Target but not in Source are in the difference + + and + M.Included_In_Union + (Model (Target)'Old, Model (Target), Model (Source)) + + -- Elements in Source but not in Target are in the difference + + and + M.Included_In_Union + (Model (Source), Model (Target), Model (Target)'Old) + + -- Actual value of elements come from either Left or Right + + and + E_Elements_Included + (Elements (Target), + Model (Target)'Old, + Elements (Target)'Old, + Elements (Source)) + and + E_Elements_Included + (Elements (Target)'Old, Model (Target), Elements (Target)) + and + E_Elements_Included + (Elements (Source), Model (Target), Elements (Target)); + + function Symmetric_Difference (Left, Right : Set) return Set with + Global => null, + Pre => Length (Left) <= Count_Type'Last - Length (Right), + Post => + Length (Symmetric_Difference'Result) = Length (Left) - + 2 * M.Num_Overlaps (Model (Left), Model (Right)) + + Length (Right) + + -- Elements of the difference were not both in Left and Right + + and + M.Not_In_Both + (Model (Symmetric_Difference'Result), Model (Left), Model (Right)) + + -- Elements in Left but not in Right are in the difference + + and + M.Included_In_Union + (Model (Left), Model (Symmetric_Difference'Result), Model (Right)) + + -- Elements in Right but not in Left are in the difference + + and + M.Included_In_Union + (Model (Right), Model (Symmetric_Difference'Result), Model (Left)) + + -- Actual value of elements come from either Left or Right + + and + E_Elements_Included + (Elements (Symmetric_Difference'Result), + Model (Left), + Elements (Left), + Elements (Right)) + and + E_Elements_Included + (Elements (Left), + Model (Symmetric_Difference'Result), + Elements (Symmetric_Difference'Result)) + and + E_Elements_Included + (Elements (Right), + Model (Symmetric_Difference'Result), + Elements (Symmetric_Difference'Result)); + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean with + Global => null, + Post => + Overlap'Result = not (M.No_Overlap (Model (Left), Model (Right))); + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean with + Global => null, + Post => Is_Subset'Result = (Model (Subset) <= Model (Of_Set)); + + function First (Container : Set) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + First'Result = No_Element, + + others => + Has_Element (Container, First'Result) + and P.Get (Positions (Container), First'Result) = 1); + + function First_Element (Container : Set) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + First_Element'Result = E.Get (Elements (Container), 1) + and E_Smaller_Than_Range + (Elements (Container), + 2, + Length (Container), + First_Element'Result); + + function Last (Container : Set) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 => + Last'Result = No_Element, + + others => + Has_Element (Container, Last'Result) + and P.Get (Positions (Container), Last'Result) = + Length (Container)); + + function Last_Element (Container : Set) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Element'Result = E.Get (Elements (Container), Length (Container)) + and E_Bigger_Than_Range + (Elements (Container), + 1, + Length (Container) - 1, + Last_Element'Result); + + function Next (Container : Set; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Next'Result = No_Element, + + others => + Has_Element (Container, Next'Result) + and then P.Get (Positions (Container), Next'Result) = + P.Get (Positions (Container), Position) + 1); + + procedure Next (Container : Set; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = Length (Container) + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) + 1); + + function Previous (Container : Set; Position : Cursor) return Cursor with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Previous'Result = No_Element, + + others => + Has_Element (Container, Previous'Result) + and then P.Get (Positions (Container), Previous'Result) = + P.Get (Positions (Container), Position) - 1); + + procedure Previous (Container : Set; Position : in out Cursor) with + Global => null, + Pre => + Has_Element (Container, Position) or else Position = No_Element, + Contract_Cases => + (Position = No_Element + or else P.Get (Positions (Container), Position) = 1 + => + Position = No_Element, + + others => + Has_Element (Container, Position) + and then P.Get (Positions (Container), Position) = + P.Get (Positions (Container), Position'Old) - 1); + + function Find (Container : Set; Item : Element_Type) return Cursor with + Global => null, + Contract_Cases => + + -- If Item is not contained in Container, Find returns No_Element + + (not Contains (Model (Container), Item) => + not P.Has_Key (Positions (Container), Find'Result) + and Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + and P.Get (Positions (Container), Find'Result) = + Find (Elements (Container), Item) + + -- The element designated by the result of Find is Item + + and Equivalent_Elements + (Element (Container, Find'Result), Item)); + + function Floor (Container : Set; Item : Element_Type) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 or else Item < First_Element (Container) => + Floor'Result = No_Element, + others => + Has_Element (Container, Floor'Result) + and + not (Item < E.Get (Elements (Container), + P.Get (Positions (Container), Floor'Result))) + and E_Is_Find + (Elements (Container), + Item, + P.Get (Positions (Container), Floor'Result))); + + function Ceiling (Container : Set; Item : Element_Type) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 or else Last_Element (Container) < Item => + Ceiling'Result = No_Element, + others => + Has_Element (Container, Ceiling'Result) + and + not (E.Get (Elements (Container), + P.Get (Positions (Container), Ceiling'Result)) < + Item) + and E_Is_Find + (Elements (Container), + Item, + P.Get (Positions (Container), Ceiling'Result))); + + function Contains (Container : Set; Item : Element_Type) return Boolean with + Global => null, + Post => Contains'Result = Contains (Model (Container), Item); + pragma Annotate (GNATprove, Inline_For_Proof, Contains); + + function Has_Element (Container : Set; Position : Cursor) return Boolean + with + Global => null, + Post => + Has_Element'Result = P.Has_Key (Positions (Container), Position); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys with SPARK_Mode is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean with + Global => null, + Post => + Equivalent_Keys'Result = (not (Left < Right) and not (Right < Left)); + pragma Annotate (GNATprove, Inline_For_Proof, Equivalent_Keys); + + package Formal_Model with Ghost is + function E_Bigger_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + with + Global => null, + Pre => Lst <= E.Length (Container), + Post => + E_Bigger_Than_Range'Result = + (for all I in Fst .. Lst => + Generic_Keys.Key (E.Get (Container, I)) < Key); + pragma Annotate (GNATprove, Inline_For_Proof, E_Bigger_Than_Range); + + function E_Smaller_Than_Range + (Container : E.Sequence; + Fst : Positive_Count_Type; + Lst : Count_Type; + Key : Key_Type) return Boolean + with + Global => null, + Pre => Lst <= E.Length (Container), + Post => + E_Smaller_Than_Range'Result = + (for all I in Fst .. Lst => + Key < Generic_Keys.Key (E.Get (Container, I))); + pragma Annotate (GNATprove, Inline_For_Proof, E_Smaller_Than_Range); + + function E_Is_Find + (Container : E.Sequence; + Key : Key_Type; + Position : Count_Type) return Boolean + with + Global => null, + Pre => Position - 1 <= E.Length (Container), + Post => + E_Is_Find'Result = + + ((if Position > 0 then + E_Bigger_Than_Range (Container, 1, Position - 1, Key)) + + and (if Position < E.Length (Container) then + E_Smaller_Than_Range + (Container, + Position + 1, + E.Length (Container), + Key))); + pragma Annotate (GNATprove, Inline_For_Proof, E_Is_Find); + + function Find + (Container : E.Sequence; + Key : Key_Type) return Count_Type + -- Search for Key in Container + + with + Global => null, + Post => + (if Find'Result > 0 then + Find'Result <= E.Length (Container) + and Equivalent_Keys + (Key, Generic_Keys.Key (E.Get (Container, Find'Result))) + and E_Is_Find (Container, Key, Find'Result)); + + function M_Included_Except + (Left : M.Set; + Right : M.Set; + Key : Key_Type) return Boolean + with + Global => null, + Post => + M_Included_Except'Result = + (for all E of Left => + Contains (Right, E) + or Equivalent_Keys (Generic_Keys.Key (E), Key)); + end Formal_Model; + use Formal_Model; + + function Key (Container : Set; Position : Cursor) return Key_Type with + Global => null, + Post => Key'Result = Key (Element (Container, Position)); + pragma Annotate (GNATprove, Inline_For_Proof, Key); + + function Element (Container : Set; Key : Key_Type) return Element_Type + with + Global => null, + Pre => Contains (Container, Key), + Post => + Element'Result = Element (Container, Find (Container, Key)); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + with + Global => null, + Pre => Contains (Container, Key), + Post => + Length (Container) = Length (Container)'Old + + -- Key now maps to New_Item + + and Element (Container, Key) = New_Item + + -- New_Item is contained in Container + + and Contains (Model (Container), New_Item) + + -- Other elements are preserved + + and M_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + and M.Included_Except + (Model (Container), + Model (Container)'Old, + New_Item) + + -- Mapping from cursors to elements is preserved + + and Mapping_Preserved_Except + (E_Left => Elements (Container)'Old, + E_Right => Elements (Container), + P_Left => Positions (Container)'Old, + P_Right => Positions (Container), + Position => Find (Container, Key)) + and Positions (Container) = Positions (Container)'Old; + + procedure Exclude (Container : in out Set; Key : Key_Type) with + Global => null, + Post => not Contains (Container, Key), + Contract_Cases => + + -- If Key is not in Container, nothing is changed + + (not Contains (Container, Key) => + Model (Container) = Model (Container)'Old + and Elements (Container) = Elements (Container)'Old + and Positions (Container) = Positions (Container)'Old, + + -- Otherwise, Key is removed from Container + + others => + Length (Container) = Length (Container)'Old - 1 + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- The elements of Container located before Key are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => Find (Elements (Container), Key)'Old - 1) + + -- The elements located after Key are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container), + Right => Elements (Container)'Old, + Fst => Find (Elements (Container), Key)'Old, + Lst => Length (Container), + Offset => 1) + + -- A cursor has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => Find (Elements (Container), Key)'Old)); + + procedure Delete (Container : in out Set; Key : Key_Type) with + Global => null, + Pre => Contains (Container, Key), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Key is no longer in Container + + and not Contains (Container, Key) + + -- Other elements are preserved + + and Model (Container) <= Model (Container)'Old + and M_Included_Except + (Model (Container)'Old, + Model (Container), + Key) + + -- The elements of Container located before Key are preserved + + and E.Range_Equal + (Left => Elements (Container)'Old, + Right => Elements (Container), + Fst => 1, + Lst => Find (Elements (Container), Key)'Old - 1) + + -- The elements located after Key are shifted by 1 + + and E.Range_Shifted + (Left => Elements (Container), + Right => Elements (Container)'Old, + Fst => Find (Elements (Container), Key)'Old, + Lst => Length (Container), + Offset => 1) + + -- A cursor has been removed from Container + + and P_Positions_Shifted + (Positions (Container), + Positions (Container)'Old, + Cut => Find (Elements (Container), Key)'Old); + + function Find (Container : Set; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + + -- If Key is not contained in Container, Find returns No_Element + + ((for all E of Model (Container) => + not Equivalent_Keys (Key, Generic_Keys.Key (E))) => + not P.Has_Key (Positions (Container), Find'Result) + and Find'Result = No_Element, + + -- Otherwise, Find returns a valid cursor in Container + + others => + P.Has_Key (Positions (Container), Find'Result) + and P.Get (Positions (Container), Find'Result) = + Find (Elements (Container), Key) + + -- The element designated by the result of Find is Key + + and Equivalent_Keys + (Generic_Keys.Key (Element (Container, Find'Result)), Key)); + + function Floor (Container : Set; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 + or else Key < Generic_Keys.Key (First_Element (Container)) => + Floor'Result = No_Element, + others => + Has_Element (Container, Floor'Result) + and + not (Key < + Generic_Keys.Key + (E.Get (Elements (Container), + P.Get (Positions (Container), Floor'Result)))) + and E_Is_Find + (Elements (Container), + Key, + P.Get (Positions (Container), Floor'Result))); + + function Ceiling (Container : Set; Key : Key_Type) return Cursor with + Global => null, + Contract_Cases => + (Length (Container) = 0 + or else Generic_Keys.Key (Last_Element (Container)) < Key => + Ceiling'Result = No_Element, + others => + Has_Element (Container, Ceiling'Result) + and + not (Generic_Keys.Key + (E.Get (Elements (Container), + P.Get (Positions (Container), Ceiling'Result))) + < Key) + and E_Is_Find + (Elements (Container), + Key, + P.Get (Positions (Container), Ceiling'Result))); + + function Contains (Container : Set; Key : Key_Type) return Boolean with + Global => null, + Post => + Contains'Result = + (for some E of Model (Container) => + Equivalent_Keys (Key, Generic_Keys.Key (E))); + + end Generic_Keys; + +private + pragma SPARK_Mode (Off); + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type is record + Has_Element : Boolean := False; + Parent : Count_Type := 0; + Left : Count_Type := 0; + Right : Count_Type := 0; + Color : Red_Black_Trees.Color_Type; + Element : Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Bounded_Tree_Types (Node_Type); + + type Set (Capacity : Count_Type) is + new Tree_Types.Tree_Type (Capacity) with null record; + + use Red_Black_Trees; + + Empty_Set : constant Set := (Capacity => 0, others => <>); + +end Ada.Containers.Formal_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-cgaaso.adb b/gcc/ada/libgnat/a-cgaaso.adb new file mode 100644 index 0000000..2cbebba --- /dev/null +++ b/gcc/ada/libgnat/a-cgaaso.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This unit was originally a GNAT-specific addition to Ada 2005. A unit +-- providing the same feature, Ada.Containers.Generic_Sort, was defined for +-- Ada 2012. We retain Generic_Anonymous_Array_Sort for compatibility, but +-- implement it in terms of the official unit, Generic_Sort. + +with Ada.Containers.Generic_Sort; + +procedure Ada.Containers.Generic_Anonymous_Array_Sort + (First, Last : Index_Type'Base) +is + procedure Sort is new Ada.Containers.Generic_Sort + (Index_Type => Index_Type, + Before => Less, + Swap => Swap); + +begin + Sort (First, Last); +end Ada.Containers.Generic_Anonymous_Array_Sort; diff --git a/gcc/ada/libgnat/a-cgaaso.ads b/gcc/ada/libgnat/a-cgaaso.ads new file mode 100644 index 0000000..b99a5aa --- /dev/null +++ b/gcc/ada/libgnat/a-cgaaso.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_ANONYMOUS_ARRAY_SORT -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Allows an anonymous array (or array-like container) to be sorted. Generic +-- formal Less returns the result of comparing the elements designated by the +-- indexes, and generic formal Swap exchanges the designated elements. + +generic + type Index_Type is (<>); + with function Less (Left, Right : Index_Type) return Boolean is <>; + with procedure Swap (Left, Right : Index_Type) is <>; + +procedure Ada.Containers.Generic_Anonymous_Array_Sort + (First, Last : Index_Type'Base); +pragma Pure (Ada.Containers.Generic_Anonymous_Array_Sort); diff --git a/gcc/ada/libgnat/a-cgarso.adb b/gcc/ada/libgnat/a-cgarso.adb new file mode 100644 index 0000000..0863ff1 --- /dev/null +++ b/gcc/ada/libgnat/a-cgarso.adb @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . G E N E R I C _ A R R A Y _ S O R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Constrained_Array_Sort; + +procedure Ada.Containers.Generic_Array_Sort + (Container : in out Array_Type) +is + subtype Index_Subtype is + Index_Type range Container'First .. Container'Last; + + subtype Array_Subtype is + Array_Type (Index_Subtype); + + procedure Sort is + new Generic_Constrained_Array_Sort + (Index_Type => Index_Subtype, + Element_Type => Element_Type, + Array_Type => Array_Subtype, + "<" => "<"); + +begin + Sort (Container); +end Ada.Containers.Generic_Array_Sort; diff --git a/gcc/ada/libgnat/a-cgarso.ads b/gcc/ada/libgnat/a-cgarso.ads new file mode 100644 index 0000000..77281b5 --- /dev/null +++ b/gcc/ada/libgnat/a-cgarso.ads @@ -0,0 +1,26 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . G E N E R I C _ A R R A Y _ S O R T -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Index_Type is (<>); + type Element_Type is private; + type Array_Type is array (Index_Type range <>) of Element_Type; + + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + +procedure Ada.Containers.Generic_Array_Sort (Container : in out Array_Type); + +pragma Pure (Ada.Containers.Generic_Array_Sort); diff --git a/gcc/ada/libgnat/a-cgcaso.adb b/gcc/ada/libgnat/a-cgcaso.adb new file mode 100644 index 0000000..ac8215a --- /dev/null +++ b/gcc/ada/libgnat/a-cgcaso.adb @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This algorithm was adapted from GNAT.Heap_Sort_G (see g-hesorg.ad[sb]) + +with System; + +procedure Ada.Containers.Generic_Constrained_Array_Sort + (Container : in out Array_Type) +is + type T is range System.Min_Int .. System.Max_Int; + + function To_Index (J : T) return Index_Type; + pragma Inline (To_Index); + + procedure Sift (S : T); + + A : Array_Type renames Container; + + -------------- + -- To_Index -- + -------------- + + function To_Index (J : T) return Index_Type is + K : constant T'Base := Index_Type'Pos (A'First) + J - T'(1); + begin + return Index_Type'Val (K); + end To_Index; + + Max : T := A'Length; + Temp : Element_Type; + + ---------- + -- Sift -- + ---------- + + procedure Sift (S : T) is + C : T := S; + Son : T; + + begin + loop + Son := 2 * C; + + exit when Son > Max; + + declare + Son_Index : Index_Type := To_Index (Son); + + begin + if Son < Max then + if A (Son_Index) < A (Index_Type'Succ (Son_Index)) then + Son := Son + 1; + Son_Index := Index_Type'Succ (Son_Index); + end if; + end if; + + A (To_Index (C)) := A (Son_Index); -- Move (Son, C); + end; + + C := Son; + end loop; + + while C /= S loop + declare + Father : constant T := C / 2; + begin + if A (To_Index (Father)) < Temp then -- Lt (Father, 0) + A (To_Index (C)) := A (To_Index (Father)); -- Move (Father, C) + C := Father; + else + exit; + end if; + end; + end loop; + + A (To_Index (C)) := Temp; -- Move (0, C); + end Sift; + +-- Start of processing for Generic_Constrained_Array_Sort + +begin + for J in reverse 1 .. Max / 2 loop + Temp := Container (To_Index (J)); -- Move (J, 0); + Sift (J); + end loop; + + while Max > 1 loop + Temp := A (To_Index (Max)); -- Move (Max, 0); + A (To_Index (Max)) := A (A'First); -- Move (1, Max); + + Max := Max - 1; + Sift (1); + end loop; +end Ada.Containers.Generic_Constrained_Array_Sort; diff --git a/gcc/ada/libgnat/a-cgcaso.ads b/gcc/ada/libgnat/a-cgcaso.ads new file mode 100644 index 0000000..39ebee6 --- /dev/null +++ b/gcc/ada/libgnat/a-cgcaso.ads @@ -0,0 +1,27 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_CONSTRAINED_ARRAY_SORT -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Index_Type is (<>); + type Element_Type is private; + type Array_Type is array (Index_Type) of Element_Type; + + with function "<" (Left, Right : Element_Type) + return Boolean is <>; + +procedure Ada.Containers.Generic_Constrained_Array_Sort + (Container : in out Array_Type); + +pragma Pure (Ada.Containers.Generic_Constrained_Array_Sort); diff --git a/gcc/ada/libgnat/a-chacon.adb b/gcc/ada/libgnat/a-chacon.adb new file mode 100644 index 0000000..2fddc04 --- /dev/null +++ b/gcc/ada/libgnat/a-chacon.adb @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . C O N V E R S I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Characters.Conversions is + + ------------------ + -- Is_Character -- + ------------------ + + function Is_Character (Item : Wide_Character) return Boolean is + begin + return Wide_Character'Pos (Item) < 256; + end Is_Character; + + function Is_Character (Item : Wide_Wide_Character) return Boolean is + begin + return Wide_Wide_Character'Pos (Item) < 256; + end Is_Character; + + --------------- + -- Is_String -- + --------------- + + function Is_String (Item : Wide_String) return Boolean is + begin + for J in Item'Range loop + if Wide_Character'Pos (Item (J)) >= 256 then + return False; + end if; + end loop; + + return True; + end Is_String; + + function Is_String (Item : Wide_Wide_String) return Boolean is + begin + for J in Item'Range loop + if Wide_Wide_Character'Pos (Item (J)) >= 256 then + return False; + end if; + end loop; + + return True; + end Is_String; + + ----------------------- + -- Is_Wide_Character -- + ----------------------- + + function Is_Wide_Character (Item : Wide_Wide_Character) return Boolean is + begin + return Wide_Wide_Character'Pos (Item) < 2**16; + end Is_Wide_Character; + + -------------------- + -- Is_Wide_String -- + -------------------- + + function Is_Wide_String (Item : Wide_Wide_String) return Boolean is + begin + for J in Item'Range loop + if Wide_Wide_Character'Pos (Item (J)) >= 2**16 then + return False; + end if; + end loop; + + return True; + end Is_Wide_String; + + ------------------ + -- To_Character -- + ------------------ + + function To_Character + (Item : Wide_Character; + Substitute : Character := ' ') return Character + is + begin + if Is_Character (Item) then + return Character'Val (Wide_Character'Pos (Item)); + else + return Substitute; + end if; + end To_Character; + + function To_Character + (Item : Wide_Wide_Character; + Substitute : Character := ' ') return Character + is + begin + if Is_Character (Item) then + return Character'Val (Wide_Wide_Character'Pos (Item)); + else + return Substitute; + end if; + end To_Character; + + --------------- + -- To_String -- + --------------- + + function To_String + (Item : Wide_String; + Substitute : Character := ' ') return String + is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); + end loop; + + return Result; + end To_String; + + function To_String + (Item : Wide_Wide_String; + Substitute : Character := ' ') return String + is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); + end loop; + + return Result; + end To_String; + + ----------------------- + -- To_Wide_Character -- + ----------------------- + + function To_Wide_Character + (Item : Character) return Wide_Character + is + begin + return Wide_Character'Val (Character'Pos (Item)); + end To_Wide_Character; + + function To_Wide_Character + (Item : Wide_Wide_Character; + Substitute : Wide_Character := ' ') return Wide_Character + is + begin + if Wide_Wide_Character'Pos (Item) < 2**16 then + return Wide_Character'Val (Wide_Wide_Character'Pos (Item)); + else + return Substitute; + end if; + end To_Wide_Character; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Item : String) return Wide_String + is + Result : Wide_String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Wide_Character (Item (J)); + end loop; + + return Result; + end To_Wide_String; + + function To_Wide_String + (Item : Wide_Wide_String; + Substitute : Wide_Character := ' ') return Wide_String + is + Result : Wide_String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := + To_Wide_Character (Item (J), Substitute); + end loop; + + return Result; + end To_Wide_String; + + ---------------------------- + -- To_Wide_Wide_Character -- + ---------------------------- + + function To_Wide_Wide_Character + (Item : Character) return Wide_Wide_Character + is + begin + return Wide_Wide_Character'Val (Character'Pos (Item)); + end To_Wide_Wide_Character; + + function To_Wide_Wide_Character + (Item : Wide_Character) return Wide_Wide_Character + is + begin + return Wide_Wide_Character'Val (Wide_Character'Pos (Item)); + end To_Wide_Wide_Character; + + ------------------------- + -- To_Wide_Wide_String -- + ------------------------- + + function To_Wide_Wide_String + (Item : String) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Wide_Wide_Character (Item (J)); + end loop; + + return Result; + end To_Wide_Wide_String; + + function To_Wide_Wide_String + (Item : Wide_String) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Wide_Wide_Character (Item (J)); + end loop; + + return Result; + end To_Wide_Wide_String; + +end Ada.Characters.Conversions; diff --git a/gcc/ada/libgnat/a-chacon.ads b/gcc/ada/libgnat/a-chacon.ads new file mode 100644 index 0000000..098019c --- /dev/null +++ b/gcc/ada/libgnat/a-chacon.ads @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . C O N V E R S I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Characters.Conversions is + pragma Pure; + + function Is_Character (Item : Wide_Character) return Boolean; + function Is_String (Item : Wide_String) return Boolean; + function Is_Character (Item : Wide_Wide_Character) return Boolean; + function Is_String (Item : Wide_Wide_String) return Boolean; + + function Is_Wide_Character (Item : Wide_Wide_Character) return Boolean; + function Is_Wide_String (Item : Wide_Wide_String) return Boolean; + + function To_Wide_Character (Item : Character) return Wide_Character; + function To_Wide_String (Item : String) return Wide_String; + + function To_Wide_Wide_Character + (Item : Character) return Wide_Wide_Character; + + function To_Wide_Wide_String + (Item : String) return Wide_Wide_String; + + function To_Wide_Wide_Character + (Item : Wide_Character) return Wide_Wide_Character; + + function To_Wide_Wide_String + (Item : Wide_String) return Wide_Wide_String; + + function To_Character + (Item : Wide_Character; + Substitute : Character := ' ') return Character; + + function To_String + (Item : Wide_String; + Substitute : Character := ' ') return String; + + function To_Character + (Item : Wide_Wide_Character; + Substitute : Character := ' ') return Character; + + function To_String + (Item : Wide_Wide_String; + Substitute : Character := ' ') return String; + + function To_Wide_Character + (Item : Wide_Wide_Character; + Substitute : Wide_Character := ' ') return Wide_Character; + + function To_Wide_String + (Item : Wide_Wide_String; + Substitute : Wide_Character := ' ') return Wide_String; + +end Ada.Characters.Conversions; diff --git a/gcc/ada/libgnat/a-chahan.adb b/gcc/ada/libgnat/a-chahan.adb new file mode 100644 index 0000000..4f9b54b --- /dev/null +++ b/gcc/ada/libgnat/a-chahan.adb @@ -0,0 +1,609 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . H A N D L I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Maps.Constants; use Ada.Strings.Maps.Constants; + +package body Ada.Characters.Handling is + + ------------------------------------ + -- Character Classification Table -- + ------------------------------------ + + type Character_Flags is mod 256; + for Character_Flags'Size use 8; + + Control : constant Character_Flags := 1; + Lower : constant Character_Flags := 2; + Upper : constant Character_Flags := 4; + Basic : constant Character_Flags := 8; + Hex_Digit : constant Character_Flags := 16; + Digit : constant Character_Flags := 32; + Special : constant Character_Flags := 64; + Line_Term : constant Character_Flags := 128; + + Letter : constant Character_Flags := Lower or Upper; + Alphanum : constant Character_Flags := Letter or Digit; + Graphic : constant Character_Flags := Alphanum or Special; + + Char_Map : constant array (Character) of Character_Flags := + ( + NUL => Control, + SOH => Control, + STX => Control, + ETX => Control, + EOT => Control, + ENQ => Control, + ACK => Control, + BEL => Control, + BS => Control, + HT => Control, + LF => Control + Line_Term, + VT => Control + Line_Term, + FF => Control + Line_Term, + CR => Control + Line_Term, + SO => Control, + SI => Control, + + DLE => Control, + DC1 => Control, + DC2 => Control, + DC3 => Control, + DC4 => Control, + NAK => Control, + SYN => Control, + ETB => Control, + CAN => Control, + EM => Control, + SUB => Control, + ESC => Control, + FS => Control, + GS => Control, + RS => Control, + US => Control, + + Space => Special, + Exclamation => Special, + Quotation => Special, + Number_Sign => Special, + Dollar_Sign => Special, + Percent_Sign => Special, + Ampersand => Special, + Apostrophe => Special, + Left_Parenthesis => Special, + Right_Parenthesis => Special, + Asterisk => Special, + Plus_Sign => Special, + Comma => Special, + Hyphen => Special, + Full_Stop => Special, + Solidus => Special, + + '0' .. '9' => Digit + Hex_Digit, + + Colon => Special, + Semicolon => Special, + Less_Than_Sign => Special, + Equals_Sign => Special, + Greater_Than_Sign => Special, + Question => Special, + Commercial_At => Special, + + 'A' .. 'F' => Upper + Basic + Hex_Digit, + 'G' .. 'Z' => Upper + Basic, + + Left_Square_Bracket => Special, + Reverse_Solidus => Special, + Right_Square_Bracket => Special, + Circumflex => Special, + Low_Line => Special, + Grave => Special, + + 'a' .. 'f' => Lower + Basic + Hex_Digit, + 'g' .. 'z' => Lower + Basic, + + Left_Curly_Bracket => Special, + Vertical_Line => Special, + Right_Curly_Bracket => Special, + Tilde => Special, + + DEL => Control, + Reserved_128 => Control, + Reserved_129 => Control, + BPH => Control, + NBH => Control, + Reserved_132 => Control, + NEL => Control + Line_Term, + SSA => Control, + ESA => Control, + HTS => Control, + HTJ => Control, + VTS => Control, + PLD => Control, + PLU => Control, + RI => Control, + SS2 => Control, + SS3 => Control, + + DCS => Control, + PU1 => Control, + PU2 => Control, + STS => Control, + CCH => Control, + MW => Control, + SPA => Control, + EPA => Control, + + SOS => Control, + Reserved_153 => Control, + SCI => Control, + CSI => Control, + ST => Control, + OSC => Control, + PM => Control, + APC => Control, + + No_Break_Space => Special, + Inverted_Exclamation => Special, + Cent_Sign => Special, + Pound_Sign => Special, + Currency_Sign => Special, + Yen_Sign => Special, + Broken_Bar => Special, + Section_Sign => Special, + Diaeresis => Special, + Copyright_Sign => Special, + Feminine_Ordinal_Indicator => Special, + Left_Angle_Quotation => Special, + Not_Sign => Special, + Soft_Hyphen => Special, + Registered_Trade_Mark_Sign => Special, + Macron => Special, + Degree_Sign => Special, + Plus_Minus_Sign => Special, + Superscript_Two => Special, + Superscript_Three => Special, + Acute => Special, + Micro_Sign => Special, + Pilcrow_Sign => Special, + Middle_Dot => Special, + Cedilla => Special, + Superscript_One => Special, + Masculine_Ordinal_Indicator => Special, + Right_Angle_Quotation => Special, + Fraction_One_Quarter => Special, + Fraction_One_Half => Special, + Fraction_Three_Quarters => Special, + Inverted_Question => Special, + + UC_A_Grave => Upper, + UC_A_Acute => Upper, + UC_A_Circumflex => Upper, + UC_A_Tilde => Upper, + UC_A_Diaeresis => Upper, + UC_A_Ring => Upper, + UC_AE_Diphthong => Upper + Basic, + UC_C_Cedilla => Upper, + UC_E_Grave => Upper, + UC_E_Acute => Upper, + UC_E_Circumflex => Upper, + UC_E_Diaeresis => Upper, + UC_I_Grave => Upper, + UC_I_Acute => Upper, + UC_I_Circumflex => Upper, + UC_I_Diaeresis => Upper, + UC_Icelandic_Eth => Upper + Basic, + UC_N_Tilde => Upper, + UC_O_Grave => Upper, + UC_O_Acute => Upper, + UC_O_Circumflex => Upper, + UC_O_Tilde => Upper, + UC_O_Diaeresis => Upper, + + Multiplication_Sign => Special, + + UC_O_Oblique_Stroke => Upper, + UC_U_Grave => Upper, + UC_U_Acute => Upper, + UC_U_Circumflex => Upper, + UC_U_Diaeresis => Upper, + UC_Y_Acute => Upper, + UC_Icelandic_Thorn => Upper + Basic, + + LC_German_Sharp_S => Lower + Basic, + LC_A_Grave => Lower, + LC_A_Acute => Lower, + LC_A_Circumflex => Lower, + LC_A_Tilde => Lower, + LC_A_Diaeresis => Lower, + LC_A_Ring => Lower, + LC_AE_Diphthong => Lower + Basic, + LC_C_Cedilla => Lower, + LC_E_Grave => Lower, + LC_E_Acute => Lower, + LC_E_Circumflex => Lower, + LC_E_Diaeresis => Lower, + LC_I_Grave => Lower, + LC_I_Acute => Lower, + LC_I_Circumflex => Lower, + LC_I_Diaeresis => Lower, + LC_Icelandic_Eth => Lower + Basic, + LC_N_Tilde => Lower, + LC_O_Grave => Lower, + LC_O_Acute => Lower, + LC_O_Circumflex => Lower, + LC_O_Tilde => Lower, + LC_O_Diaeresis => Lower, + + Division_Sign => Special, + + LC_O_Oblique_Stroke => Lower, + LC_U_Grave => Lower, + LC_U_Acute => Lower, + LC_U_Circumflex => Lower, + LC_U_Diaeresis => Lower, + LC_Y_Acute => Lower, + LC_Icelandic_Thorn => Lower + Basic, + LC_Y_Diaeresis => Lower + ); + + --------------------- + -- Is_Alphanumeric -- + --------------------- + + function Is_Alphanumeric (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Alphanum) /= 0; + end Is_Alphanumeric; + + -------------- + -- Is_Basic -- + -------------- + + function Is_Basic (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Basic) /= 0; + end Is_Basic; + + ------------------ + -- Is_Character -- + ------------------ + + function Is_Character (Item : Wide_Character) return Boolean is + begin + return Wide_Character'Pos (Item) < 256; + end Is_Character; + + ---------------- + -- Is_Control -- + ---------------- + + function Is_Control (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Control) /= 0; + end Is_Control; + + -------------- + -- Is_Digit -- + -------------- + + function Is_Digit (Item : Character) return Boolean is + begin + return Item in '0' .. '9'; + end Is_Digit; + + ---------------- + -- Is_Graphic -- + ---------------- + + function Is_Graphic (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Graphic) /= 0; + end Is_Graphic; + + -------------------------- + -- Is_Hexadecimal_Digit -- + -------------------------- + + function Is_Hexadecimal_Digit (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Hex_Digit) /= 0; + end Is_Hexadecimal_Digit; + + ---------------- + -- Is_ISO_646 -- + ---------------- + + function Is_ISO_646 (Item : Character) return Boolean is + begin + return Item in ISO_646; + end Is_ISO_646; + + -- Note: much more efficient coding of the following function is possible + -- by testing several 16#80# bits in a complete word in a single operation + + function Is_ISO_646 (Item : String) return Boolean is + begin + for J in Item'Range loop + if Item (J) not in ISO_646 then + return False; + end if; + end loop; + + return True; + end Is_ISO_646; + + --------------- + -- Is_Letter -- + --------------- + + function Is_Letter (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Letter) /= 0; + end Is_Letter; + + ------------------------ + -- Is_Line_Terminator -- + ------------------------ + + function Is_Line_Terminator (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Line_Term) /= 0; + end Is_Line_Terminator; + + -------------- + -- Is_Lower -- + -------------- + + function Is_Lower (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Lower) /= 0; + end Is_Lower; + + ------------- + -- Is_Mark -- + ------------- + + function Is_Mark (Item : Character) return Boolean is + pragma Unreferenced (Item); + begin + return False; + end Is_Mark; + + --------------------- + -- Is_Other_Format -- + --------------------- + + function Is_Other_Format (Item : Character) return Boolean is + begin + return Item = Soft_Hyphen; + end Is_Other_Format; + + ------------------------------ + -- Is_Punctuation_Connector -- + ------------------------------ + + function Is_Punctuation_Connector (Item : Character) return Boolean is + begin + return Item = '_'; + end Is_Punctuation_Connector; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (Item : Character) return Boolean is + begin + return Item = ' ' or else Item = No_Break_Space; + end Is_Space; + + ---------------- + -- Is_Special -- + ---------------- + + function Is_Special (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Special) /= 0; + end Is_Special; + + --------------- + -- Is_String -- + --------------- + + function Is_String (Item : Wide_String) return Boolean is + begin + for J in Item'Range loop + if Wide_Character'Pos (Item (J)) >= 256 then + return False; + end if; + end loop; + + return True; + end Is_String; + + -------------- + -- Is_Upper -- + -------------- + + function Is_Upper (Item : Character) return Boolean is + begin + return (Char_Map (Item) and Upper) /= 0; + end Is_Upper; + + -------------- + -- To_Basic -- + -------------- + + function To_Basic (Item : Character) return Character is + begin + return Value (Basic_Map, Item); + end To_Basic; + + function To_Basic (Item : String) return String is + begin + return Result : String (1 .. Item'Length) do + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Basic_Map, Item (J)); + end loop; + end return; + end To_Basic; + + ------------------ + -- To_Character -- + ------------------ + + function To_Character + (Item : Wide_Character; + Substitute : Character := ' ') return Character + is + begin + if Is_Character (Item) then + return Character'Val (Wide_Character'Pos (Item)); + else + return Substitute; + end if; + end To_Character; + + ---------------- + -- To_ISO_646 -- + ---------------- + + function To_ISO_646 + (Item : Character; + Substitute : ISO_646 := ' ') return ISO_646 + is + begin + return (if Item in ISO_646 then Item else Substitute); + end To_ISO_646; + + function To_ISO_646 + (Item : String; + Substitute : ISO_646 := ' ') return String + is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := + (if Item (J) in ISO_646 then Item (J) else Substitute); + end loop; + + return Result; + end To_ISO_646; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (Item : Character) return Character is + begin + return Value (Lower_Case_Map, Item); + end To_Lower; + + function To_Lower (Item : String) return String is + begin + return Result : String (1 .. Item'Length) do + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Lower_Case_Map, Item (J)); + end loop; + end return; + end To_Lower; + + --------------- + -- To_String -- + --------------- + + function To_String + (Item : Wide_String; + Substitute : Character := ' ') return String + is + Result : String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Character (Item (J), Substitute); + end loop; + + return Result; + end To_String; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper + (Item : Character) return Character + is + begin + return Value (Upper_Case_Map, Item); + end To_Upper; + + function To_Upper + (Item : String) return String + is + begin + return Result : String (1 .. Item'Length) do + for J in Item'Range loop + Result (J - (Item'First - 1)) := Value (Upper_Case_Map, Item (J)); + end loop; + end return; + end To_Upper; + + ----------------------- + -- To_Wide_Character -- + ----------------------- + + function To_Wide_Character + (Item : Character) return Wide_Character + is + begin + return Wide_Character'Val (Character'Pos (Item)); + end To_Wide_Character; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Item : String) return Wide_String + is + Result : Wide_String (1 .. Item'Length); + + begin + for J in Item'Range loop + Result (J - (Item'First - 1)) := To_Wide_Character (Item (J)); + end loop; + + return Result; + end To_Wide_String; + +end Ada.Characters.Handling; diff --git a/gcc/ada/libgnat/a-chahan.ads b/gcc/ada/libgnat/a-chahan.ads new file mode 100644 index 0000000..60a6d49 --- /dev/null +++ b/gcc/ada/libgnat/a-chahan.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . H A N D L I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Characters.Handling is + pragma Pure; + -- In accordance with Ada 2005 AI-362 + + ---------------------------------------- + -- Character Classification Functions -- + ---------------------------------------- + + function Is_Control (Item : Character) return Boolean; + function Is_Graphic (Item : Character) return Boolean; + function Is_Letter (Item : Character) return Boolean; + function Is_Lower (Item : Character) return Boolean; + function Is_Upper (Item : Character) return Boolean; + function Is_Basic (Item : Character) return Boolean; + function Is_Digit (Item : Character) return Boolean; + function Is_Decimal_Digit (Item : Character) return Boolean + renames Is_Digit; + function Is_Hexadecimal_Digit (Item : Character) return Boolean; + function Is_Alphanumeric (Item : Character) return Boolean; + function Is_Special (Item : Character) return Boolean; + function Is_Line_Terminator (Item : Character) return Boolean; + function Is_Mark (Item : Character) return Boolean; + function Is_Other_Format (Item : Character) return Boolean; + function Is_Punctuation_Connector (Item : Character) return Boolean; + function Is_Space (Item : Character) return Boolean; + + --------------------------------------------------- + -- Conversion Functions for Character and String -- + --------------------------------------------------- + + function To_Lower (Item : Character) return Character; + function To_Upper (Item : Character) return Character; + function To_Basic (Item : Character) return Character; + + function To_Lower (Item : String) return String; + function To_Upper (Item : String) return String; + function To_Basic (Item : String) return String; + + ---------------------------------------------------------------------- + -- Classifications of and Conversions Between Character and ISO 646 -- + ---------------------------------------------------------------------- + + subtype ISO_646 is + Character range Character'Val (0) .. Character'Val (127); + + function Is_ISO_646 (Item : Character) return Boolean; + function Is_ISO_646 (Item : String) return Boolean; + + function To_ISO_646 + (Item : Character; + Substitute : ISO_646 := ' ') return ISO_646; + + function To_ISO_646 + (Item : String; + Substitute : ISO_646 := ' ') return String; + + ------------------------------------------------------ + -- Classifications of Wide_Character and Characters -- + ------------------------------------------------------ + + -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions + -- and are considered obsolete in Ada.Characters.Handling. However we do + -- not complain about this obsolescence, since in practice it is necessary + -- to use these routines when creating code that is intended to run in + -- either Ada 95 or Ada 2005 mode. + + -- We do however have to flag these if the pragma No_Obsolescent_Features + -- restriction is active (see Restrict.Check_Obsolescent_2005_Entity). + + function Is_Character (Item : Wide_Character) return Boolean; + function Is_String (Item : Wide_String) return Boolean; + + ------------------------------------------------------ + -- Conversions between Wide_Character and Character -- + ------------------------------------------------------ + + -- Ada 2005 AI 395: these functions are moved to Ada.Characters.Conversions + -- and are considered obsolete in Ada.Characters.Handling. However we do + -- not complain about this obsolescence, since in practice it is necessary + -- to use these routines when creating code that is intended to run in + -- either Ada 95 or Ada 2005 mode. + + -- We do however have to flag these if the pragma No_Obsolescent_Features + -- restriction is active (see Restrict.Check_Obsolescent_2005_Entity). + + function To_Character + (Item : Wide_Character; + Substitute : Character := ' ') return Character; + + function To_String + (Item : Wide_String; + Substitute : Character := ' ') return String; + + function To_Wide_Character + (Item : Character) return Wide_Character; + + function To_Wide_String + (Item : String) return Wide_String; + +private + pragma Inline (Is_Alphanumeric); + pragma Inline (Is_Basic); + pragma Inline (Is_Character); + pragma Inline (Is_Control); + pragma Inline (Is_Digit); + pragma Inline (Is_Graphic); + pragma Inline (Is_Hexadecimal_Digit); + pragma Inline (Is_ISO_646); + pragma Inline (Is_Letter); + pragma Inline (Is_Line_Terminator); + pragma Inline (Is_Lower); + pragma Inline (Is_Mark); + pragma Inline (Is_Other_Format); + pragma Inline (Is_Punctuation_Connector); + pragma Inline (Is_Space); + pragma Inline (Is_Special); + pragma Inline (Is_Upper); + pragma Inline (To_Basic); + pragma Inline (To_Character); + pragma Inline (To_Lower); + pragma Inline (To_Upper); + pragma Inline (To_Wide_Character); + +end Ada.Characters.Handling; diff --git a/gcc/ada/libgnat/a-charac.ads b/gcc/ada/libgnat/a-charac.ads new file mode 100644 index 0000000..8355f54 --- /dev/null +++ b/gcc/ada/libgnat/a-charac.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Characters is + pragma Pure; +end Ada.Characters; diff --git a/gcc/ada/libgnat/a-chlat1.ads b/gcc/ada/libgnat/a-chlat1.ads new file mode 100644 index 0000000..2e20d92 --- /dev/null +++ b/gcc/ada/libgnat/a-chlat1.ads @@ -0,0 +1,296 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . L A T I N _ 1 -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package Ada.Characters.Latin_1 is + pragma Pure; + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Character := Character'Val (0); + SOH : constant Character := Character'Val (1); + STX : constant Character := Character'Val (2); + ETX : constant Character := Character'Val (3); + EOT : constant Character := Character'Val (4); + ENQ : constant Character := Character'Val (5); + ACK : constant Character := Character'Val (6); + BEL : constant Character := Character'Val (7); + BS : constant Character := Character'Val (8); + HT : constant Character := Character'Val (9); + LF : constant Character := Character'Val (10); + VT : constant Character := Character'Val (11); + FF : constant Character := Character'Val (12); + CR : constant Character := Character'Val (13); + SO : constant Character := Character'Val (14); + SI : constant Character := Character'Val (15); + + DLE : constant Character := Character'Val (16); + DC1 : constant Character := Character'Val (17); + DC2 : constant Character := Character'Val (18); + DC3 : constant Character := Character'Val (19); + DC4 : constant Character := Character'Val (20); + NAK : constant Character := Character'Val (21); + SYN : constant Character := Character'Val (22); + ETB : constant Character := Character'Val (23); + CAN : constant Character := Character'Val (24); + EM : constant Character := Character'Val (25); + SUB : constant Character := Character'Val (26); + ESC : constant Character := Character'Val (27); + FS : constant Character := Character'Val (28); + GS : constant Character := Character'Val (29); + RS : constant Character := Character'Val (30); + US : constant Character := Character'Val (31); + + -------------------------------- + -- ISO 646 Graphic Characters -- + -------------------------------- + + Space : constant Character := ' '; -- Character'Val(32) + Exclamation : constant Character := '!'; -- Character'Val(33) + Quotation : constant Character := '"'; -- Character'Val(34) + Number_Sign : constant Character := '#'; -- Character'Val(35) + Dollar_Sign : constant Character := '$'; -- Character'Val(36) + Percent_Sign : constant Character := '%'; -- Character'Val(37) + Ampersand : constant Character := '&'; -- Character'Val(38) + Apostrophe : constant Character := '''; -- Character'Val(39) + Left_Parenthesis : constant Character := '('; -- Character'Val(40) + Right_Parenthesis : constant Character := ')'; -- Character'Val(41) + Asterisk : constant Character := '*'; -- Character'Val(42) + Plus_Sign : constant Character := '+'; -- Character'Val(43) + Comma : constant Character := ','; -- Character'Val(44) + Hyphen : constant Character := '-'; -- Character'Val(45) + Minus_Sign : Character renames Hyphen; + Full_Stop : constant Character := '.'; -- Character'Val(46) + Solidus : constant Character := '/'; -- Character'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Character := ':'; -- Character'Val(58) + Semicolon : constant Character := ';'; -- Character'Val(59) + Less_Than_Sign : constant Character := '<'; -- Character'Val(60) + Equals_Sign : constant Character := '='; -- Character'Val(61) + Greater_Than_Sign : constant Character := '>'; -- Character'Val(62) + Question : constant Character := '?'; -- Character'Val(63) + Commercial_At : constant Character := '@'; -- Character'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Character := '['; -- Character'Val (91) + Reverse_Solidus : constant Character := '\'; -- Character'Val (92) + Right_Square_Bracket : constant Character := ']'; -- Character'Val (93) + Circumflex : constant Character := '^'; -- Character'Val (94) + Low_Line : constant Character := '_'; -- Character'Val (95) + + Grave : constant Character := '`'; -- Character'Val (96) + LC_A : constant Character := 'a'; -- Character'Val (97) + LC_B : constant Character := 'b'; -- Character'Val (98) + LC_C : constant Character := 'c'; -- Character'Val (99) + LC_D : constant Character := 'd'; -- Character'Val (100) + LC_E : constant Character := 'e'; -- Character'Val (101) + LC_F : constant Character := 'f'; -- Character'Val (102) + LC_G : constant Character := 'g'; -- Character'Val (103) + LC_H : constant Character := 'h'; -- Character'Val (104) + LC_I : constant Character := 'i'; -- Character'Val (105) + LC_J : constant Character := 'j'; -- Character'Val (106) + LC_K : constant Character := 'k'; -- Character'Val (107) + LC_L : constant Character := 'l'; -- Character'Val (108) + LC_M : constant Character := 'm'; -- Character'Val (109) + LC_N : constant Character := 'n'; -- Character'Val (110) + LC_O : constant Character := 'o'; -- Character'Val (111) + LC_P : constant Character := 'p'; -- Character'Val (112) + LC_Q : constant Character := 'q'; -- Character'Val (113) + LC_R : constant Character := 'r'; -- Character'Val (114) + LC_S : constant Character := 's'; -- Character'Val (115) + LC_T : constant Character := 't'; -- Character'Val (116) + LC_U : constant Character := 'u'; -- Character'Val (117) + LC_V : constant Character := 'v'; -- Character'Val (118) + LC_W : constant Character := 'w'; -- Character'Val (119) + LC_X : constant Character := 'x'; -- Character'Val (120) + LC_Y : constant Character := 'y'; -- Character'Val (121) + LC_Z : constant Character := 'z'; -- Character'Val (122) + Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123) + Vertical_Line : constant Character := '|'; -- Character'Val (124) + Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125) + Tilde : constant Character := '~'; -- Character'Val (126) + DEL : constant Character := Character'Val (127); + + --------------------------------- + -- ISO 6429 Control Characters -- + --------------------------------- + + IS4 : Character renames FS; + IS3 : Character renames GS; + IS2 : Character renames RS; + IS1 : Character renames US; + + Reserved_128 : constant Character := Character'Val (128); + Reserved_129 : constant Character := Character'Val (129); + BPH : constant Character := Character'Val (130); + NBH : constant Character := Character'Val (131); + Reserved_132 : constant Character := Character'Val (132); + NEL : constant Character := Character'Val (133); + SSA : constant Character := Character'Val (134); + ESA : constant Character := Character'Val (135); + HTS : constant Character := Character'Val (136); + HTJ : constant Character := Character'Val (137); + VTS : constant Character := Character'Val (138); + PLD : constant Character := Character'Val (139); + PLU : constant Character := Character'Val (140); + RI : constant Character := Character'Val (141); + SS2 : constant Character := Character'Val (142); + SS3 : constant Character := Character'Val (143); + + DCS : constant Character := Character'Val (144); + PU1 : constant Character := Character'Val (145); + PU2 : constant Character := Character'Val (146); + STS : constant Character := Character'Val (147); + CCH : constant Character := Character'Val (148); + MW : constant Character := Character'Val (149); + SPA : constant Character := Character'Val (150); + EPA : constant Character := Character'Val (151); + + SOS : constant Character := Character'Val (152); + Reserved_153 : constant Character := Character'Val (153); + SCI : constant Character := Character'Val (154); + CSI : constant Character := Character'Val (155); + ST : constant Character := Character'Val (156); + OSC : constant Character := Character'Val (157); + PM : constant Character := Character'Val (158); + APC : constant Character := Character'Val (159); + + ------------------------------ + -- Other Graphic Characters -- + ------------------------------ + + -- Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Character := Character'Val (160); + NBSP : Character renames No_Break_Space; + Inverted_Exclamation : constant Character := Character'Val (161); + Cent_Sign : constant Character := Character'Val (162); + Pound_Sign : constant Character := Character'Val (163); + Currency_Sign : constant Character := Character'Val (164); + Yen_Sign : constant Character := Character'Val (165); + Broken_Bar : constant Character := Character'Val (166); + Section_Sign : constant Character := Character'Val (167); + Diaeresis : constant Character := Character'Val (168); + Copyright_Sign : constant Character := Character'Val (169); + Feminine_Ordinal_Indicator : constant Character := Character'Val (170); + Left_Angle_Quotation : constant Character := Character'Val (171); + Not_Sign : constant Character := Character'Val (172); + Soft_Hyphen : constant Character := Character'Val (173); + Registered_Trade_Mark_Sign : constant Character := Character'Val (174); + Macron : constant Character := Character'Val (175); + + -- Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Character := Character'Val (176); + Ring_Above : Character renames Degree_Sign; + Plus_Minus_Sign : constant Character := Character'Val (177); + Superscript_Two : constant Character := Character'Val (178); + Superscript_Three : constant Character := Character'Val (179); + Acute : constant Character := Character'Val (180); + Micro_Sign : constant Character := Character'Val (181); + Pilcrow_Sign : constant Character := Character'Val (182); + Paragraph_Sign : Character renames Pilcrow_Sign; + Middle_Dot : constant Character := Character'Val (183); + Cedilla : constant Character := Character'Val (184); + Superscript_One : constant Character := Character'Val (185); + Masculine_Ordinal_Indicator : constant Character := Character'Val (186); + Right_Angle_Quotation : constant Character := Character'Val (187); + Fraction_One_Quarter : constant Character := Character'Val (188); + Fraction_One_Half : constant Character := Character'Val (189); + Fraction_Three_Quarters : constant Character := Character'Val (190); + Inverted_Question : constant Character := Character'Val (191); + + -- Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Character := Character'Val (192); + UC_A_Acute : constant Character := Character'Val (193); + UC_A_Circumflex : constant Character := Character'Val (194); + UC_A_Tilde : constant Character := Character'Val (195); + UC_A_Diaeresis : constant Character := Character'Val (196); + UC_A_Ring : constant Character := Character'Val (197); + UC_AE_Diphthong : constant Character := Character'Val (198); + UC_C_Cedilla : constant Character := Character'Val (199); + UC_E_Grave : constant Character := Character'Val (200); + UC_E_Acute : constant Character := Character'Val (201); + UC_E_Circumflex : constant Character := Character'Val (202); + UC_E_Diaeresis : constant Character := Character'Val (203); + UC_I_Grave : constant Character := Character'Val (204); + UC_I_Acute : constant Character := Character'Val (205); + UC_I_Circumflex : constant Character := Character'Val (206); + UC_I_Diaeresis : constant Character := Character'Val (207); + + -- Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Character := Character'Val (208); + UC_N_Tilde : constant Character := Character'Val (209); + UC_O_Grave : constant Character := Character'Val (210); + UC_O_Acute : constant Character := Character'Val (211); + UC_O_Circumflex : constant Character := Character'Val (212); + UC_O_Tilde : constant Character := Character'Val (213); + UC_O_Diaeresis : constant Character := Character'Val (214); + Multiplication_Sign : constant Character := Character'Val (215); + UC_O_Oblique_Stroke : constant Character := Character'Val (216); + UC_U_Grave : constant Character := Character'Val (217); + UC_U_Acute : constant Character := Character'Val (218); + UC_U_Circumflex : constant Character := Character'Val (219); + UC_U_Diaeresis : constant Character := Character'Val (220); + UC_Y_Acute : constant Character := Character'Val (221); + UC_Icelandic_Thorn : constant Character := Character'Val (222); + LC_German_Sharp_S : constant Character := Character'Val (223); + + -- Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Character := Character'Val (224); + LC_A_Acute : constant Character := Character'Val (225); + LC_A_Circumflex : constant Character := Character'Val (226); + LC_A_Tilde : constant Character := Character'Val (227); + LC_A_Diaeresis : constant Character := Character'Val (228); + LC_A_Ring : constant Character := Character'Val (229); + LC_AE_Diphthong : constant Character := Character'Val (230); + LC_C_Cedilla : constant Character := Character'Val (231); + LC_E_Grave : constant Character := Character'Val (232); + LC_E_Acute : constant Character := Character'Val (233); + LC_E_Circumflex : constant Character := Character'Val (234); + LC_E_Diaeresis : constant Character := Character'Val (235); + LC_I_Grave : constant Character := Character'Val (236); + LC_I_Acute : constant Character := Character'Val (237); + LC_I_Circumflex : constant Character := Character'Val (238); + LC_I_Diaeresis : constant Character := Character'Val (239); + + -- Character positions 240 (16#F0#) .. 255 (16#FF) + LC_Icelandic_Eth : constant Character := Character'Val (240); + LC_N_Tilde : constant Character := Character'Val (241); + LC_O_Grave : constant Character := Character'Val (242); + LC_O_Acute : constant Character := Character'Val (243); + LC_O_Circumflex : constant Character := Character'Val (244); + LC_O_Tilde : constant Character := Character'Val (245); + LC_O_Diaeresis : constant Character := Character'Val (246); + Division_Sign : constant Character := Character'Val (247); + LC_O_Oblique_Stroke : constant Character := Character'Val (248); + LC_U_Grave : constant Character := Character'Val (249); + LC_U_Acute : constant Character := Character'Val (250); + LC_U_Circumflex : constant Character := Character'Val (251); + LC_U_Diaeresis : constant Character := Character'Val (252); + LC_Y_Acute : constant Character := Character'Val (253); + LC_Icelandic_Thorn : constant Character := Character'Val (254); + LC_Y_Diaeresis : constant Character := Character'Val (255); + +end Ada.Characters.Latin_1; diff --git a/gcc/ada/libgnat/a-chlat9.ads b/gcc/ada/libgnat/a-chlat9.ads new file mode 100644 index 0000000..27334d8 --- /dev/null +++ b/gcc/ada/libgnat/a-chlat9.ads @@ -0,0 +1,332 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . L A T I N _ 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, 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 modifications made to Ada.Characters.Latin_1, noted -- +-- in the text, to derive the equivalent Latin-9 package. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions for Latin-9 (ISO-8859-15) analogous to +-- those defined in the standard package Ada.Characters.Latin_1 for Latin-1. + +package Ada.Characters.Latin_9 is + pragma Pure; + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Character := Character'Val (0); + SOH : constant Character := Character'Val (1); + STX : constant Character := Character'Val (2); + ETX : constant Character := Character'Val (3); + EOT : constant Character := Character'Val (4); + ENQ : constant Character := Character'Val (5); + ACK : constant Character := Character'Val (6); + BEL : constant Character := Character'Val (7); + BS : constant Character := Character'Val (8); + HT : constant Character := Character'Val (9); + LF : constant Character := Character'Val (10); + VT : constant Character := Character'Val (11); + FF : constant Character := Character'Val (12); + CR : constant Character := Character'Val (13); + SO : constant Character := Character'Val (14); + SI : constant Character := Character'Val (15); + + DLE : constant Character := Character'Val (16); + DC1 : constant Character := Character'Val (17); + DC2 : constant Character := Character'Val (18); + DC3 : constant Character := Character'Val (19); + DC4 : constant Character := Character'Val (20); + NAK : constant Character := Character'Val (21); + SYN : constant Character := Character'Val (22); + ETB : constant Character := Character'Val (23); + CAN : constant Character := Character'Val (24); + EM : constant Character := Character'Val (25); + SUB : constant Character := Character'Val (26); + ESC : constant Character := Character'Val (27); + FS : constant Character := Character'Val (28); + GS : constant Character := Character'Val (29); + RS : constant Character := Character'Val (30); + US : constant Character := Character'Val (31); + + -------------------------------- + -- ISO 646 Graphic Characters -- + -------------------------------- + + Space : constant Character := ' '; -- Character'Val(32) + Exclamation : constant Character := '!'; -- Character'Val(33) + Quotation : constant Character := '"'; -- Character'Val(34) + Number_Sign : constant Character := '#'; -- Character'Val(35) + Dollar_Sign : constant Character := '$'; -- Character'Val(36) + Percent_Sign : constant Character := '%'; -- Character'Val(37) + Ampersand : constant Character := '&'; -- Character'Val(38) + Apostrophe : constant Character := '''; -- Character'Val(39) + Left_Parenthesis : constant Character := '('; -- Character'Val(40) + Right_Parenthesis : constant Character := ')'; -- Character'Val(41) + Asterisk : constant Character := '*'; -- Character'Val(42) + Plus_Sign : constant Character := '+'; -- Character'Val(43) + Comma : constant Character := ','; -- Character'Val(44) + Hyphen : constant Character := '-'; -- Character'Val(45) + Minus_Sign : Character renames Hyphen; + Full_Stop : constant Character := '.'; -- Character'Val(46) + Solidus : constant Character := '/'; -- Character'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Character := ':'; -- Character'Val(58) + Semicolon : constant Character := ';'; -- Character'Val(59) + Less_Than_Sign : constant Character := '<'; -- Character'Val(60) + Equals_Sign : constant Character := '='; -- Character'Val(61) + Greater_Than_Sign : constant Character := '>'; -- Character'Val(62) + Question : constant Character := '?'; -- Character'Val(63) + + Commercial_At : constant Character := '@'; -- Character'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Character := '['; -- Character'Val (91) + Reverse_Solidus : constant Character := '\'; -- Character'Val (92) + Right_Square_Bracket : constant Character := ']'; -- Character'Val (93) + Circumflex : constant Character := '^'; -- Character'Val (94) + Low_Line : constant Character := '_'; -- Character'Val (95) + + Grave : constant Character := '`'; -- Character'Val (96) + LC_A : constant Character := 'a'; -- Character'Val (97) + LC_B : constant Character := 'b'; -- Character'Val (98) + LC_C : constant Character := 'c'; -- Character'Val (99) + LC_D : constant Character := 'd'; -- Character'Val (100) + LC_E : constant Character := 'e'; -- Character'Val (101) + LC_F : constant Character := 'f'; -- Character'Val (102) + LC_G : constant Character := 'g'; -- Character'Val (103) + LC_H : constant Character := 'h'; -- Character'Val (104) + LC_I : constant Character := 'i'; -- Character'Val (105) + LC_J : constant Character := 'j'; -- Character'Val (106) + LC_K : constant Character := 'k'; -- Character'Val (107) + LC_L : constant Character := 'l'; -- Character'Val (108) + LC_M : constant Character := 'm'; -- Character'Val (109) + LC_N : constant Character := 'n'; -- Character'Val (110) + LC_O : constant Character := 'o'; -- Character'Val (111) + LC_P : constant Character := 'p'; -- Character'Val (112) + LC_Q : constant Character := 'q'; -- Character'Val (113) + LC_R : constant Character := 'r'; -- Character'Val (114) + LC_S : constant Character := 's'; -- Character'Val (115) + LC_T : constant Character := 't'; -- Character'Val (116) + LC_U : constant Character := 'u'; -- Character'Val (117) + LC_V : constant Character := 'v'; -- Character'Val (118) + LC_W : constant Character := 'w'; -- Character'Val (119) + LC_X : constant Character := 'x'; -- Character'Val (120) + LC_Y : constant Character := 'y'; -- Character'Val (121) + LC_Z : constant Character := 'z'; -- Character'Val (122) + Left_Curly_Bracket : constant Character := '{'; -- Character'Val (123) + Vertical_Line : constant Character := '|'; -- Character'Val (124) + Right_Curly_Bracket : constant Character := '}'; -- Character'Val (125) + Tilde : constant Character := '~'; -- Character'Val (126) + DEL : constant Character := Character'Val (127); + + --------------------------------- + -- ISO 6429 Control Characters -- + --------------------------------- + + IS4 : Character renames FS; + IS3 : Character renames GS; + IS2 : Character renames RS; + IS1 : Character renames US; + + Reserved_128 : constant Character := Character'Val (128); + Reserved_129 : constant Character := Character'Val (129); + BPH : constant Character := Character'Val (130); + NBH : constant Character := Character'Val (131); + Reserved_132 : constant Character := Character'Val (132); + NEL : constant Character := Character'Val (133); + SSA : constant Character := Character'Val (134); + ESA : constant Character := Character'Val (135); + HTS : constant Character := Character'Val (136); + HTJ : constant Character := Character'Val (137); + VTS : constant Character := Character'Val (138); + PLD : constant Character := Character'Val (139); + PLU : constant Character := Character'Val (140); + RI : constant Character := Character'Val (141); + SS2 : constant Character := Character'Val (142); + SS3 : constant Character := Character'Val (143); + + DCS : constant Character := Character'Val (144); + PU1 : constant Character := Character'Val (145); + PU2 : constant Character := Character'Val (146); + STS : constant Character := Character'Val (147); + CCH : constant Character := Character'Val (148); + MW : constant Character := Character'Val (149); + SPA : constant Character := Character'Val (150); + EPA : constant Character := Character'Val (151); + + SOS : constant Character := Character'Val (152); + Reserved_153 : constant Character := Character'Val (153); + SCI : constant Character := Character'Val (154); + CSI : constant Character := Character'Val (155); + ST : constant Character := Character'Val (156); + OSC : constant Character := Character'Val (157); + PM : constant Character := Character'Val (158); + APC : constant Character := Character'Val (159); + + ------------------------------ + -- Other Graphic Characters -- + ------------------------------ + + -- Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Character := Character'Val (160); + NBSP : Character renames No_Break_Space; + Inverted_Exclamation : constant Character := Character'Val (161); + Cent_Sign : constant Character := Character'Val (162); + Pound_Sign : constant Character := Character'Val (163); + Euro_Sign : constant Character := Character'Val (164); + Yen_Sign : constant Character := Character'Val (165); + UC_S_Caron : constant Character := Character'Val (166); + Section_Sign : constant Character := Character'Val (167); + LC_S_Caron : constant Character := Character'Val (168); + Copyright_Sign : constant Character := Character'Val (169); + Feminine_Ordinal_Indicator : constant Character := Character'Val (170); + Left_Angle_Quotation : constant Character := Character'Val (171); + Not_Sign : constant Character := Character'Val (172); + Soft_Hyphen : constant Character := Character'Val (173); + Registered_Trade_Mark_Sign : constant Character := Character'Val (174); + Macron : constant Character := Character'Val (175); + + -- Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Character := Character'Val (176); + Ring_Above : Character renames Degree_Sign; + Plus_Minus_Sign : constant Character := Character'Val (177); + Superscript_Two : constant Character := Character'Val (178); + Superscript_Three : constant Character := Character'Val (179); + UC_Z_Caron : constant Character := Character'Val (180); + Micro_Sign : constant Character := Character'Val (181); + Pilcrow_Sign : constant Character := Character'Val (182); + Paragraph_Sign : Character renames Pilcrow_Sign; + Middle_Dot : constant Character := Character'Val (183); + LC_Z_Caron : constant Character := Character'Val (184); + Superscript_One : constant Character := Character'Val (185); + Masculine_Ordinal_Indicator : constant Character := Character'Val (186); + Right_Angle_Quotation : constant Character := Character'Val (187); + UC_Ligature_OE : constant Character := Character'Val (188); + LC_Ligature_OE : constant Character := Character'Val (189); + UC_Y_Diaeresis : constant Character := Character'Val (190); + Inverted_Question : constant Character := Character'Val (191); + + -- Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Character := Character'Val (192); + UC_A_Acute : constant Character := Character'Val (193); + UC_A_Circumflex : constant Character := Character'Val (194); + UC_A_Tilde : constant Character := Character'Val (195); + UC_A_Diaeresis : constant Character := Character'Val (196); + UC_A_Ring : constant Character := Character'Val (197); + UC_AE_Diphthong : constant Character := Character'Val (198); + UC_C_Cedilla : constant Character := Character'Val (199); + UC_E_Grave : constant Character := Character'Val (200); + UC_E_Acute : constant Character := Character'Val (201); + UC_E_Circumflex : constant Character := Character'Val (202); + UC_E_Diaeresis : constant Character := Character'Val (203); + UC_I_Grave : constant Character := Character'Val (204); + UC_I_Acute : constant Character := Character'Val (205); + UC_I_Circumflex : constant Character := Character'Val (206); + UC_I_Diaeresis : constant Character := Character'Val (207); + + -- Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Character := Character'Val (208); + UC_N_Tilde : constant Character := Character'Val (209); + UC_O_Grave : constant Character := Character'Val (210); + UC_O_Acute : constant Character := Character'Val (211); + UC_O_Circumflex : constant Character := Character'Val (212); + UC_O_Tilde : constant Character := Character'Val (213); + UC_O_Diaeresis : constant Character := Character'Val (214); + Multiplication_Sign : constant Character := Character'Val (215); + UC_O_Oblique_Stroke : constant Character := Character'Val (216); + UC_U_Grave : constant Character := Character'Val (217); + UC_U_Acute : constant Character := Character'Val (218); + UC_U_Circumflex : constant Character := Character'Val (219); + UC_U_Diaeresis : constant Character := Character'Val (220); + UC_Y_Acute : constant Character := Character'Val (221); + UC_Icelandic_Thorn : constant Character := Character'Val (222); + LC_German_Sharp_S : constant Character := Character'Val (223); + + -- Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Character := Character'Val (224); + LC_A_Acute : constant Character := Character'Val (225); + LC_A_Circumflex : constant Character := Character'Val (226); + LC_A_Tilde : constant Character := Character'Val (227); + LC_A_Diaeresis : constant Character := Character'Val (228); + LC_A_Ring : constant Character := Character'Val (229); + LC_AE_Diphthong : constant Character := Character'Val (230); + LC_C_Cedilla : constant Character := Character'Val (231); + LC_E_Grave : constant Character := Character'Val (232); + LC_E_Acute : constant Character := Character'Val (233); + LC_E_Circumflex : constant Character := Character'Val (234); + LC_E_Diaeresis : constant Character := Character'Val (235); + LC_I_Grave : constant Character := Character'Val (236); + LC_I_Acute : constant Character := Character'Val (237); + LC_I_Circumflex : constant Character := Character'Val (238); + LC_I_Diaeresis : constant Character := Character'Val (239); + + -- Character positions 240 (16#F0#) .. 255 (16#FF) + LC_Icelandic_Eth : constant Character := Character'Val (240); + LC_N_Tilde : constant Character := Character'Val (241); + LC_O_Grave : constant Character := Character'Val (242); + LC_O_Acute : constant Character := Character'Val (243); + LC_O_Circumflex : constant Character := Character'Val (244); + LC_O_Tilde : constant Character := Character'Val (245); + LC_O_Diaeresis : constant Character := Character'Val (246); + Division_Sign : constant Character := Character'Val (247); + LC_O_Oblique_Stroke : constant Character := Character'Val (248); + LC_U_Grave : constant Character := Character'Val (249); + LC_U_Acute : constant Character := Character'Val (250); + LC_U_Circumflex : constant Character := Character'Val (251); + LC_U_Diaeresis : constant Character := Character'Val (252); + LC_Y_Acute : constant Character := Character'Val (253); + LC_Icelandic_Thorn : constant Character := Character'Val (254); + LC_Y_Diaeresis : constant Character := Character'Val (255); + + ------------------------------------------------ + -- Summary of Changes from Latin-1 => Latin-9 -- + ------------------------------------------------ + + -- 164 Currency => Euro_Sign + -- 166 Broken_Bar => UC_S_Caron + -- 168 Diaeresis => LC_S_Caron + -- 180 Acute => UC_Z_Caron + -- 184 Cedilla => LC_Z_Caron + -- 188 Fraction_One_Quarter => UC_Ligature_OE + -- 189 Fraction_One_Half => LC_Ligature_OE + -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis + +end Ada.Characters.Latin_9; diff --git a/gcc/ada/libgnat/a-chtgbk.adb b/gcc/ada/libgnat/a-chtgbk.adb new file mode 100644 index 0000000..0101ed6 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgbk.adb @@ -0,0 +1,346 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------------- + -- Checked_Equivalent_Keys -- + ----------------------------- + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type; + Node : Count_Type) return Boolean + is + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + return Equivalent_Keys (Key, HT.Nodes (Node)); + end Checked_Equivalent_Keys; + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type + is + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; + end Checked_Index; + + -------------------------- + -- Delete_Key_Sans_Free -- + -------------------------- + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + X : out Count_Type) + is + Indx : Hash_Type; + Prev : Count_Type; + + begin + if HT.Length = 0 then + X := 0; + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + TC_Check (HT.TC); + + Indx := Checked_Index (HT, Key); + X := HT.Buckets (Indx); + + if X = 0 then + return; + end if; + + if Checked_Equivalent_Keys (HT, Key, X) then + TC_Check (HT.TC); + HT.Buckets (Indx) := Next (HT.Nodes (X)); + HT.Length := HT.Length - 1; + return; + end if; + + loop + Prev := X; + X := Next (HT.Nodes (Prev)); + + if X = 0 then + return; + end if; + + if Checked_Equivalent_Keys (HT, Key, X) then + TC_Check (HT.TC); + Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X))); + HT.Length := HT.Length - 1; + return; + end if; + end loop; + end Delete_Key_Sans_Free; + + ---------- + -- Find -- + ---------- + + function Find + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Count_Type + is + Indx : Hash_Type; + Node : Count_Type; + + begin + if HT.Length = 0 then + return 0; + end if; + + Indx := Checked_Index (HT'Unrestricted_Access.all, Key); + + Node := HT.Buckets (Indx); + while Node /= 0 loop + if Checked_Equivalent_Keys + (HT'Unrestricted_Access.all, Key, Node) + then + return Node; + end if; + Node := Next (HT.Nodes (Node)); + end loop; + + return 0; + end Find; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + Indx : Hash_Type; + + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + TC_Check (HT.TC); + + Indx := Checked_Index (HT, Key); + Node := HT.Buckets (Indx); + + if Node = 0 then + if Checks and then HT.Length = HT.Capacity then + raise Capacity_Error with "no more capacity for insertion"; + end if; + + Node := New_Node; + Set_Next (HT.Nodes (Node), Next => 0); + + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + + return; + end if; + + loop + if Checked_Equivalent_Keys (HT, Key, Node) then + Inserted := False; + return; + end if; + + Node := Next (HT.Nodes (Node)); + + exit when Node = 0; + end loop; + + if Checks and then HT.Length = HT.Capacity then + raise Capacity_Error with "no more capacity for insertion"; + end if; + + Node := New_Node; + Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); + + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + end Generic_Conditional_Insert; + + ----------------------------- + -- Generic_Replace_Element -- + ----------------------------- + + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type'Class; + Node : Count_Type; + Key : Key_Type) + is + pragma Assert (HT.Length > 0); + pragma Assert (Node /= 0); + + BB : Buckets_Type renames HT.Buckets; + NN : Nodes_Type renames HT.Nodes; + + Old_Indx : Hash_Type; + New_Indx : constant Hash_Type := Checked_Index (HT, Key); + + New_Bucket : Count_Type renames BB (New_Indx); + N, M : Count_Type; + + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + -- The following block appears to be vestigial -- this should be done + -- using Checked_Index instead. Also, we might have to move the actual + -- tampering checks to the top of the subprogram, in order to prevent + -- infinite recursion when calling Hash. (This is similar to how Insert + -- and Delete are implemented.) This implies that we will have to defer + -- the computation of New_Index until after the tampering check. ??? + + declare + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; + end; + + -- Replace_Element is allowed to change a node's key to Key + -- (generic formal operation Assign provides the mechanism), but + -- only if Key is not already in the hash table. (In a unique-key + -- hash table as this one, a key is mapped to exactly one node.) + + if Checked_Equivalent_Keys (HT, Key, Node) then + TE_Check (HT.TC); + + -- The new Key value is mapped to this same Node, so Node + -- stays in the same bucket. + + Assign (NN (Node), Key); + return; + end if; + + -- Key is not equivalent to Node, so we now have to determine if it's + -- equivalent to some other node in the hash table. This is the case + -- irrespective of whether Key is in the same or a different bucket from + -- Node. + + N := New_Bucket; + while N /= 0 loop + if Checks and then Checked_Equivalent_Keys (HT, Key, N) then + pragma Assert (N /= Node); + raise Program_Error with + "attempt to replace existing element"; + end if; + + N := Next (NN (N)); + end loop; + + -- We have determined that Key is not already in the hash table, so + -- the change is tentatively allowed. We now perform the standard + -- checks to determine whether the hash table is locked (because you + -- cannot change an element while it's in use by Query_Element or + -- Update_Element), or if the container is busy (because moving a + -- node to a different bucket would interfere with iteration). + + if Old_Indx = New_Indx then + -- The node is already in the bucket implied by Key. In this case + -- we merely change its value without moving it. + + TE_Check (HT.TC); + + Assign (NN (Node), Key); + return; + end if; + + -- The node is a bucket different from the bucket implied by Key + + TC_Check (HT.TC); + + -- Do the assignment first, before moving the node, so that if Assign + -- propagates an exception, then the hash table will not have been + -- modified (except for any possible side-effect Assign had on Node). + + Assign (NN (Node), Key); + + -- Now we can safely remove the node from its current bucket + + N := BB (Old_Indx); -- get value of first node in old bucket + pragma Assert (N /= 0); + + if N = Node then -- node is first node in its bucket + BB (Old_Indx) := Next (NN (Node)); + + else + pragma Assert (HT.Length > 1); + + loop + M := Next (NN (N)); + pragma Assert (M /= 0); + + if M = Node then + Set_Next (NN (N), Next => Next (NN (Node))); + exit; + end if; + + N := M; + end loop; + end if; + + -- Now we link the node into its new bucket (corresponding to Key) + + Set_Next (NN (Node), Next => New_Bucket); + New_Bucket := Node; + end Generic_Replace_Element; + + ----------- + -- Index -- + ----------- + + function Index + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type is + begin + return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; + end Index; + +end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; diff --git a/gcc/ada/libgnat/a-chtgbk.ads b/gcc/ada/libgnat/a-chtgbk.ads new file mode 100644 index 0000000..ee59d2e --- /dev/null +++ b/gcc/ada/libgnat/a-chtgbk.ads @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that depend on keys. + +generic + with package HT_Types is + new Generic_Bounded_Hash_Table_Types (<>); + + use HT_Types, HT_Types.Implementation; + + with function Next (Node : Node_Type) return Count_Type; + + with procedure Set_Next + (Node : in out Node_Type; + Next : Count_Type); + + type Key_Type (<>) is limited private; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys + (Key : Key_Type; + Node : Node_Type) return Boolean; + +package Ada.Containers.Hash_Tables.Generic_Bounded_Keys is + pragma Pure; + + function Index + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type; + pragma Inline (Index); + -- Returns the bucket number (array index value) for the given key + + function Checked_Index + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type) return Hash_Type; + pragma Inline (Checked_Index); + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type'Class; + Key : Key_Type; + Node : Count_Type) return Boolean; + -- Calls Equivalent_Keys, but locks and unlocks the container, per + -- AI05-0022, in order to detect element tampering by that generic actual. + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + X : out Count_Type); + -- Removes the node (if any) with the given key from the hash table, + -- without deallocating it. Program_Error is raised if the hash + -- table is busy. + + function Find + (HT : Hash_Table_Type'Class; + Key : Key_Type) return Count_Type; + -- Returns the node (if any) corresponding to the given key + + generic + with function New_Node return Count_Type; + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + -- Attempts to insert a new node with the given key into the hash table. + -- If a node with that key already exists in the table, then that node + -- is returned and Inserted returns False. Otherwise New_Node is called + -- to allocate a new node, and Inserted returns True. Program_Error is + -- raised if the hash table is busy. + + generic + with function Hash (Node : Node_Type) return Hash_Type; + with procedure Assign (Node : in out Node_Type; Key : Key_Type); + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type'Class; + Node : Count_Type; + Key : Key_Type); + -- Assigns Key to Node, possibly changing its equivalence class. If Node + -- is in the same equivalence class as Key (that is, it's already in the + -- bucket implied by Key), then if the hash table is locked then + -- Program_Error is raised; otherwise Assign is called to assign Key to + -- Node. If Node is in a different bucket from Key, then Program_Error is + -- raised if the hash table is busy. Otherwise it Assigns Key to Node and + -- moves the Node from its current bucket to the bucket implied by Key. + -- Note that it is never proper to assign to Node a key value already + -- in the map, and so if Key is equivalent to some other node then + -- Program_Error is raised. + +end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; diff --git a/gcc/ada/libgnat/a-chtgbo.adb b/gcc/ada/libgnat/a-chtgbo.adb new file mode 100644 index 0000000..91ca168 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgbo.adb @@ -0,0 +1,553 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type'Class; + Node : Count_Type) return Hash_Type + is + Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); + begin + return Index (Hash_Table, Hash_Table.Nodes (Node)); + end Checked_Index; + + ----------- + -- Clear -- + ----------- + + procedure Clear (HT : in out Hash_Table_Type'Class) is + begin + TC_Check (HT.TC); + + HT.Length := 0; + -- HT.Busy := 0; + -- HT.Lock := 0; + HT.Free := -1; + HT.Buckets := (others => 0); -- optimize this somehow ??? + end Clear; + + -------------------------- + -- Delete_Node_At_Index -- + -------------------------- + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type'Class; + Indx : Hash_Type; + X : Count_Type) + is + Prev : Count_Type; + Curr : Count_Type; + + begin + Prev := HT.Buckets (Indx); + + if Checks and then Prev = 0 then + raise Program_Error with + "attempt to delete node from empty hash bucket"; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (HT.Nodes (Prev)); + HT.Length := HT.Length - 1; + return; + end if; + + if Checks and then HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (HT.Nodes (Prev)); + + if Checks and then Curr = 0 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + Prev := Curr; + end loop; + end Delete_Node_At_Index; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type'Class; + X : Count_Type) + is + pragma Assert (X /= 0); + + Indx : Hash_Type; + Prev : Count_Type; + Curr : Count_Type; + + begin + if Checks and then HT.Length = 0 then + raise Program_Error with + "attempt to delete node from empty hashed container"; + end if; + + Indx := Checked_Index (HT, X); + Prev := HT.Buckets (Indx); + + if Checks and then Prev = 0 then + raise Program_Error with + "attempt to delete node from empty hash bucket"; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (HT.Nodes (Prev)); + HT.Length := HT.Length - 1; + return; + end if; + + if Checks and then HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (HT.Nodes (Prev)); + + if Checks and then Curr = 0 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + if Curr = X then + Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr))); + HT.Length := HT.Length - 1; + return; + end if; + + Prev := Curr; + end loop; + end Delete_Node_Sans_Free; + + ----------- + -- First -- + ----------- + + function First (HT : Hash_Table_Type'Class) return Count_Type is + Indx : Hash_Type; + + begin + if HT.Length = 0 then + return 0; + end if; + + Indx := HT.Buckets'First; + loop + if HT.Buckets (Indx) /= 0 then + return HT.Buckets (Indx); + end if; + + Indx := Indx + 1; + end loop; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free + (HT : in out Hash_Table_Type'Class; + X : Count_Type) + is + N : Nodes_Type renames HT.Nodes; + + begin + -- This subprogram "deallocates" a node by relinking the node off of the + -- active list and onto the free list. Previously it would flag index + -- value 0 as an error. The precondition was weakened, so that index + -- value 0 is now allowed, and this value is interpreted to mean "do + -- nothing". This makes its behavior analogous to the behavior of + -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add + -- special-case checks at the point of call. + + if X = 0 then + return; + end if; + + pragma Assert (X <= HT.Capacity); + + -- pragma Assert (N (X).Prev >= 0); -- node is active + -- Find a way to mark a node as active vs. inactive; we could + -- use a special value in Color_Type for this. ??? + + -- The hash table actually contains two data structures: a list for + -- the "active" nodes that contain elements that have been inserted + -- onto the container, and another for the "inactive" nodes of the free + -- store. + -- + -- We desire that merely declaring an object should have only minimal + -- cost; specially, we want to avoid having to initialize the free + -- store (to fill in the links), especially if the capacity is large. + -- + -- The head of the free list is indicated by Container.Free. If its + -- value is non-negative, then the free store has been initialized + -- in the "normal" way: Container.Free points to the head of the list + -- of free (inactive) nodes, and the value 0 means the free list is + -- empty. Each node on the free list has been initialized to point + -- to the next free node (via its Parent component), and the value 0 + -- means that this is the last free node. + -- + -- If Container.Free is negative, then the links on the free store + -- have not been initialized. In this case the link values are + -- implied: the free store comprises the components of the node array + -- started with the absolute value of Container.Free, and continuing + -- until the end of the array (Nodes'Last). + -- + -- ??? + -- It might be possible to perform an optimization here. Suppose that + -- the free store can be represented as having two parts: one + -- comprising the non-contiguous inactive nodes linked together + -- in the normal way, and the other comprising the contiguous + -- inactive nodes (that are not linked together, at the end of the + -- nodes array). This would allow us to never have to initialize + -- the free store, except in a lazy way as nodes become inactive. + + -- When an element is deleted from the list container, its node + -- becomes inactive, and so we set its Next component to value of + -- the node's index (in the nodes array), to indicate that it is + -- now inactive. This provides a useful way to detect a dangling + -- cursor reference. ??? + + Set_Next (N (X), Next => X); -- Node is deallocated (not on active list) + + if HT.Free >= 0 then + -- The free store has previously been initialized. All we need to + -- do here is link the newly-free'd node onto the free list. + + Set_Next (N (X), HT.Free); + HT.Free := X; + + elsif X + 1 = abs HT.Free then + -- The free store has not been initialized, and the node becoming + -- inactive immediately precedes the start of the free store. All + -- we need to do is move the start of the free store back by one. + + HT.Free := HT.Free + 1; + + else + -- The free store has not been initialized, and the node becoming + -- inactive does not immediately precede the free store. Here we + -- first initialize the free store (meaning the links are given + -- values in the traditional way), and then link the newly-free'd + -- node onto the head of the free store. + + -- ??? + -- See the comments above for an optimization opportunity. If + -- the next link for a node on the free store is negative, then + -- this means the remaining nodes on the free store are + -- physically contiguous, starting as the absolute value of + -- that index value. + + HT.Free := abs HT.Free; + + if HT.Free > HT.Capacity then + HT.Free := 0; + + else + for I in HT.Free .. HT.Capacity - 1 loop + Set_Next (Node => N (I), Next => I + 1); + end loop; + + Set_Next (Node => N (HT.Capacity), Next => 0); + end if; + + Set_Next (Node => N (X), Next => HT.Free); + HT.Free := X; + end if; + end Free; + + ---------------------- + -- Generic_Allocate -- + ---------------------- + + procedure Generic_Allocate + (HT : in out Hash_Table_Type'Class; + Node : out Count_Type) + is + N : Nodes_Type renames HT.Nodes; + + begin + if HT.Free >= 0 then + Node := HT.Free; + + -- We always perform the assignment first, before we + -- change container state, in order to defend against + -- exceptions duration assignment. + + Set_Element (N (Node)); + HT.Free := Next (N (Node)); + + else + -- A negative free store value means that the links of the nodes + -- in the free store have not been initialized. In this case, the + -- nodes are physically contiguous in the array, starting at the + -- index that is the absolute value of the Container.Free, and + -- continuing until the end of the array (Nodes'Last). + + Node := abs HT.Free; + + -- As above, we perform this assignment first, before modifying + -- any container state. + + Set_Element (N (Node)); + HT.Free := HT.Free - 1; + end if; + end Generic_Allocate; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal + (L, R : Hash_Table_Type'Class) return Boolean + is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_L : With_Lock (L.TC'Unrestricted_Access); + Lock_R : With_Lock (R.TC'Unrestricted_Access); + + L_Index : Hash_Type; + L_Node : Count_Type; + + N : Count_Type; + + begin + if L'Address = R'Address then + return True; + end if; + + if L.Length /= R.Length then + return False; + end if; + + if L.Length = 0 then + return True; + end if; + + -- Find the first node of hash table L + + L_Index := L.Buckets'First; + loop + L_Node := L.Buckets (L_Index); + exit when L_Node /= 0; + L_Index := L_Index + 1; + end loop; + + -- For each node of hash table L, search for an equivalent node in hash + -- table R. + + N := L.Length; + loop + if not Find (HT => R, Key => L.Nodes (L_Node)) then + return False; + end if; + + N := N - 1; + + L_Node := Next (L.Nodes (L_Node)); + + if L_Node = 0 then + + -- We have exhausted the nodes in this bucket + + if N = 0 then + return True; + end if; + + -- Find the next bucket + + loop + L_Index := L_Index + 1; + L_Node := L.Buckets (L_Index); + exit when L_Node /= 0; + end loop; + end if; + end loop; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (HT : Hash_Table_Type'Class) is + Node : Count_Type; + + begin + if HT.Length = 0 then + return; + end if; + + for Indx in HT.Buckets'Range loop + Node := HT.Buckets (Indx); + while Node /= 0 loop + Process (Node); + Node := Next (HT.Nodes (Node)); + end loop; + end loop; + end Generic_Iteration; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type'Class) + is + N : Count_Type'Base; + + begin + Clear (HT); + + Count_Type'Base'Read (Stream, N); + + if Checks and then N < 0 then + raise Program_Error with "stream appears to be corrupt"; + end if; + + if N = 0 then + return; + end if; + + if Checks and then N > HT.Capacity then + raise Capacity_Error with "too many elements in stream"; + end if; + + for J in 1 .. N loop + declare + Node : constant Count_Type := New_Node (Stream); + Indx : constant Hash_Type := Checked_Index (HT, Node); + B : Count_Type renames HT.Buckets (Indx); + begin + Set_Next (HT.Nodes (Node), Next => B); + B := Node; + end; + + HT.Length := HT.Length + 1; + end loop; + end Generic_Read; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type'Class) + is + procedure Write (Node : Count_Type); + pragma Inline (Write); + + procedure Write is new Generic_Iteration (Write); + + ----------- + -- Write -- + ----------- + + procedure Write (Node : Count_Type) is + begin + Write (Stream, HT.Nodes (Node)); + end Write; + + begin + Count_Type'Base'Write (Stream, HT.Length); + Write (HT); + end Generic_Write; + + ----------- + -- Index -- + ----------- + + function Index + (Buckets : Buckets_Type; + Node : Node_Type) return Hash_Type is + begin + return Buckets'First + Hash_Node (Node) mod Buckets'Length; + end Index; + + function Index + (HT : Hash_Table_Type'Class; + Node : Node_Type) return Hash_Type is + begin + return Index (HT.Buckets, Node); + end Index; + + ---------- + -- Next -- + ---------- + + function Next + (HT : Hash_Table_Type'Class; + Node : Count_Type) return Count_Type + is + Result : Count_Type; + First : Hash_Type; + + begin + Result := Next (HT.Nodes (Node)); + + if Result /= 0 then -- another node in same bucket + return Result; + end if; + + -- This was the last node in the bucket, so move to the next + -- bucket, and start searching for next node from there. + + First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1; + for Indx in First .. HT.Buckets'Last loop + Result := HT.Buckets (Indx); + + if Result /= 0 then -- bucket is not empty + return Result; + end if; + end loop; + + return 0; + end Next; + +end Ada.Containers.Hash_Tables.Generic_Bounded_Operations; diff --git a/gcc/ada/libgnat/a-chtgbo.ads b/gcc/ada/libgnat/a-chtgbo.ads new file mode 100644 index 0000000..832bac4 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgbo.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that do not depend on keys. + +with Ada.Streams; + +generic + with package HT_Types is + new Generic_Bounded_Hash_Table_Types (<>); + + use HT_Types, HT_Types.Implementation; + + with function Hash_Node (Node : Node_Type) return Hash_Type; + + with function Next (Node : Node_Type) return Count_Type; + + with procedure Set_Next + (Node : in out Node_Type; + Next : Count_Type); + +package Ada.Containers.Hash_Tables.Generic_Bounded_Operations is + pragma Pure; + + function Index + (Buckets : Buckets_Type; + Node : Node_Type) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Buckets array index + + function Index + (HT : Hash_Table_Type'Class; + Node : Node_Type) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Hash_Table buckets array + -- index. + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type'Class; + Node : Count_Type) return Hash_Type; + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + generic + with function Find + (HT : Hash_Table_Type'Class; + Key : Node_Type) return Boolean; + function Generic_Equal (L, R : Hash_Table_Type'Class) return Boolean; + -- Used to implement hashed container equality. For each node in hash table + -- L, it calls Find to search for an equivalent item in hash table R. If + -- Find returns False for any node then Generic_Equal terminates + -- immediately and returns False. Otherwise if Find returns True for every + -- node then Generic_Equal returns True. + + procedure Clear (HT : in out Hash_Table_Type'Class); + -- Deallocates each node in hash table HT. (Note that it only deallocates + -- the nodes, not the buckets array.) Program_Error is raised if the hash + -- table is busy. + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type'Class; + Indx : Hash_Type; + X : Count_Type); + -- Delete a node whose bucket position is known. extracted from following + -- subprogram, but also used directly to remove a node whose element has + -- been modified through a key_preserving reference: in that case we cannot + -- use the value of the element precisely because the current value does + -- not correspond to the hash code that determines its bucket. + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type'Class; + X : Count_Type); + -- Removes node X from the hash table without deallocating the node + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (HT : in out Hash_Table_Type'Class; + Node : out Count_Type); + -- Claim a node from the free store. Generic_Allocate first + -- calls Set_Element on the potential node, and then returns + -- the node's index as the value of the Node parameter. + + procedure Free + (HT : in out Hash_Table_Type'Class; + X : Count_Type); + -- Return a node back to the free store, from where it had + -- been previously claimed via Generic_Allocate. + + function First (HT : Hash_Table_Type'Class) return Count_Type; + -- Returns the head of the list in the first (lowest-index) non-empty + -- bucket. + + function Next + (HT : Hash_Table_Type'Class; + Node : Count_Type) return Count_Type; + -- Returns the node that immediately follows Node. This corresponds to + -- either the next node in the same bucket, or (if Node is the last node in + -- its bucket) the head of the list in the first non-empty bucket that + -- follows. + + generic + with procedure Process (Node : Count_Type); + procedure Generic_Iteration (HT : Hash_Table_Type'Class); + -- Calls Process for each node in hash table HT + + generic + use Ada.Streams; + with procedure Write + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type'Class); + -- Used to implement the streaming attribute for hashed containers. It + -- calls Write for each node to write its value into Stream. + + generic + use Ada.Streams; + with function New_Node (Stream : not null access Root_Stream_Type'Class) + return Count_Type; + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type'Class); + -- Used to implement the streaming attribute for hashed containers. It + -- first clears hash table HT, then populates the hash table by calling + -- New_Node for each item in Stream. + +end Ada.Containers.Hash_Tables.Generic_Bounded_Operations; diff --git a/gcc/ada/libgnat/a-chtgke.adb b/gcc/ada/libgnat/a-chtgke.adb new file mode 100644 index 0000000..6929798 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgke.adb @@ -0,0 +1,329 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Hash_Tables.Generic_Keys is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------------- + -- Checked_Equivalent_Keys -- + ----------------------------- + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type; + Key : Key_Type; + Node : Node_Access) return Boolean + is + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + return Equivalent_Keys (Key, Node); + end Checked_Equivalent_Keys; + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Hash_Type + is + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + return Hash (Key) mod HT.Buckets'Length; + end Checked_Index; + + -------------------------- + -- Delete_Key_Sans_Free -- + -------------------------- + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type; + Key : Key_Type; + X : out Node_Access) + is + Indx : Hash_Type; + Prev : Node_Access; + + begin + if HT.Length = 0 then + X := null; + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + TC_Check (HT.TC); + + Indx := Checked_Index (HT, Key); + X := HT.Buckets (Indx); + + if X = null then + return; + end if; + + if Checked_Equivalent_Keys (HT, Key, X) then + TC_Check (HT.TC); + HT.Buckets (Indx) := Next (X); + HT.Length := HT.Length - 1; + return; + end if; + + loop + Prev := X; + X := Next (Prev); + + if X = null then + return; + end if; + + if Checked_Equivalent_Keys (HT, Key, X) then + TC_Check (HT.TC); + Set_Next (Node => Prev, Next => Next (X)); + HT.Length := HT.Length - 1; + return; + end if; + end loop; + end Delete_Key_Sans_Free; + + ---------- + -- Find -- + ---------- + + function Find + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Node_Access + is + Indx : Hash_Type; + Node : Node_Access; + + begin + if HT.Length = 0 then + return null; + end if; + + Indx := Checked_Index (HT, Key); + + Node := HT.Buckets (Indx); + while Node /= null loop + if Checked_Equivalent_Keys (HT, Key, Node) then + return Node; + end if; + Node := Next (Node); + end loop; + + return null; + end Find; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + Indx : Hash_Type; + + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + TC_Check (HT.TC); + + Indx := Checked_Index (HT, Key); + Node := HT.Buckets (Indx); + + if Node = null then + if Checks and then HT.Length = Count_Type'Last then + raise Constraint_Error; + end if; + + Node := New_Node (Next => null); + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + + return; + end if; + + loop + if Checked_Equivalent_Keys (HT, Key, Node) then + Inserted := False; + return; + end if; + + Node := Next (Node); + + exit when Node = null; + end loop; + + if Checks and then HT.Length = Count_Type'Last then + raise Constraint_Error; + end if; + + Node := New_Node (Next => HT.Buckets (Indx)); + Inserted := True; + + HT.Buckets (Indx) := Node; + HT.Length := HT.Length + 1; + end Generic_Conditional_Insert; + + ----------------------------- + -- Generic_Replace_Element -- + ----------------------------- + + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Key : Key_Type) + is + pragma Assert (HT.Length > 0); + pragma Assert (Node /= null); + + Old_Indx : Hash_Type; + New_Indx : constant Hash_Type := Checked_Index (HT, Key); + + New_Bucket : Node_Access renames HT.Buckets (New_Indx); + N, M : Node_Access; + + begin + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + Old_Indx := Hash (Node) mod HT.Buckets'Length; + end; + + if Checked_Equivalent_Keys (HT, Key, Node) then + TE_Check (HT.TC); + + -- We can change a node's key to Key (that's what Assign is for), but + -- only if Key is not already in the hash table. (In a unique-key + -- hash table as this one a key is mapped to exactly one node only.) + -- The exception is when Key is mapped to Node, in which case the + -- change is allowed. + + Assign (Node, Key); + return; + end if; + + -- Key is not equivalent to Node, so we now have to determine if it's + -- equivalent to some other node in the hash table. This is the case + -- irrespective of whether Key is in the same or a different bucket from + -- Node. + + N := New_Bucket; + while N /= null loop + if Checks and then Checked_Equivalent_Keys (HT, Key, N) then + pragma Assert (N /= Node); + raise Program_Error with + "attempt to replace existing element"; + end if; + + N := Next (N); + end loop; + + -- We have determined that Key is not already in the hash table, so + -- the change is tentatively allowed. We now perform the standard + -- checks to determine whether the hash table is locked (because you + -- cannot change an element while it's in use by Query_Element or + -- Update_Element), or if the container is busy (because moving a + -- node to a different bucket would interfere with iteration). + + if Old_Indx = New_Indx then + -- The node is already in the bucket implied by Key. In this case + -- we merely change its value without moving it. + + TE_Check (HT.TC); + + Assign (Node, Key); + return; + end if; + + -- The node is a bucket different from the bucket implied by Key + + TC_Check (HT.TC); + + -- Do the assignment first, before moving the node, so that if Assign + -- propagates an exception, then the hash table will not have been + -- modified (except for any possible side-effect Assign had on Node). + + Assign (Node, Key); + + -- Now we can safely remove the node from its current bucket + + N := HT.Buckets (Old_Indx); + pragma Assert (N /= null); + + if N = Node then + HT.Buckets (Old_Indx) := Next (Node); + + else + pragma Assert (HT.Length > 1); + + loop + M := Next (N); + pragma Assert (M /= null); + + if M = Node then + Set_Next (Node => N, Next => Next (Node)); + exit; + end if; + + N := M; + end loop; + end if; + + -- Now we link the node into its new bucket (corresponding to Key) + + Set_Next (Node => Node, Next => New_Bucket); + New_Bucket := Node; + end Generic_Replace_Element; + + ----------- + -- Index -- + ----------- + + function Index + (HT : Hash_Table_Type; + Key : Key_Type) return Hash_Type + is + begin + return Hash (Key) mod HT.Buckets'Length; + end Index; + +end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/libgnat/a-chtgke.ads b/gcc/ada/libgnat/a-chtgke.ads new file mode 100644 index 0000000..26c2a55 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgke.ads @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that depend on keys. + +generic + with package HT_Types is + new Generic_Hash_Table_Types (<>); + + use HT_Types, HT_Types.Implementation; + + with function Next (Node : Node_Access) return Node_Access; + + with procedure Set_Next + (Node : Node_Access; + Next : Node_Access); + + type Key_Type (<>) is limited private; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys + (Key : Key_Type; + Node : Node_Access) return Boolean; + +package Ada.Containers.Hash_Tables.Generic_Keys is + pragma Preelaborate; + + function Index + (HT : Hash_Table_Type; + Key : Key_Type) return Hash_Type; + pragma Inline (Index); + -- Returns the bucket number (array index value) for the given key + + function Checked_Index + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Hash_Type; + pragma Inline (Checked_Index); + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + function Checked_Equivalent_Keys + (HT : aliased in out Hash_Table_Type; + Key : Key_Type; + Node : Node_Access) return Boolean; + -- Calls Equivalent_Keys, but locks and unlocks the container, per + -- AI05-0022, in order to detect element tampering by that generic actual. + + procedure Delete_Key_Sans_Free + (HT : in out Hash_Table_Type; + Key : Key_Type; + X : out Node_Access); + -- Removes the node (if any) with the given key from the hash table, + -- without deallocating it. Program_Error is raised if the hash + -- table is busy. + + function Find + (HT : aliased in out Hash_Table_Type; + Key : Key_Type) return Node_Access; + -- Returns the node (if any) corresponding to the given key + + generic + with function New_Node (Next : Node_Access) return Node_Access; + procedure Generic_Conditional_Insert + (HT : in out Hash_Table_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + -- Attempts to insert a new node with the given key into the hash table. + -- If a node with that key already exists in the table, then that node + -- is returned and Inserted returns False. Otherwise New_Node is called + -- to allocate a new node, and Inserted returns True. Program_Error is + -- raised if the hash table is busy. + + generic + with function Hash (Node : Node_Access) return Hash_Type; + with procedure Assign (Node : Node_Access; Key : Key_Type); + procedure Generic_Replace_Element + (HT : in out Hash_Table_Type; + Node : Node_Access; + Key : Key_Type); + -- Assigns Key to Node, possibly changing its equivalence class. If Node + -- is in the same equivalence class as Key (that is, it's already in the + -- bucket implied by Key), then if the hash table is locked then + -- Program_Error is raised; otherwise Assign is called to assign Key to + -- Node. If Node is in a different bucket from Key, then Program_Error is + -- raised if the hash table is busy. Otherwise it Assigns Key to Node and + -- moves the Node from its current bucket to the bucket implied by Key. + -- Note that it is never proper to assign to Node a key value already + -- in the map, and so if Key is equivalent to some other node then + -- Program_Error is raised. + +end Ada.Containers.Hash_Tables.Generic_Keys; diff --git a/gcc/ada/libgnat/a-chtgop.adb b/gcc/ada/libgnat/a-chtgop.adb new file mode 100644 index 0000000..ad951e4 --- /dev/null +++ b/gcc/ada/libgnat/a-chtgop.adb @@ -0,0 +1,838 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Prime_Numbers; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Hash_Tables.Generic_Operations is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + type Buckets_Allocation is access all Buckets_Type; + -- Used for allocation and deallocation (see New_Buckets and Free_Buckets). + -- This is necessary because Buckets_Access has an empty storage pool. + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (HT : in out Hash_Table_Type) is + Src_Buckets : constant Buckets_Access := HT.Buckets; + N : constant Count_Type := HT.Length; + Src_Node : Node_Access; + Dst_Prev : Node_Access; + + begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (HT.TC); + + HT.Buckets := null; + HT.Length := 0; + + if N = 0 then + return; + end if; + + -- Technically it isn't necessary to allocate the exact same length + -- buckets array, because our only requirement is that following + -- assignment the source and target containers compare equal (that is, + -- operator "=" returns True). We can satisfy this requirement with any + -- hash table length, but we decide here to match the length of the + -- source table. This has the benefit that when iterating, elements of + -- the target are delivered in the exact same order as for the source. + + HT.Buckets := New_Buckets (Length => Src_Buckets'Length); + + for Src_Index in Src_Buckets'Range loop + Src_Node := Src_Buckets (Src_Index); + + if Src_Node /= null then + declare + Dst_Node : constant Node_Access := Copy_Node (Src_Node); + + -- See note above + + pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index); + + begin + HT.Buckets (Src_Index) := Dst_Node; + HT.Length := HT.Length + 1; + + Dst_Prev := Dst_Node; + end; + + Src_Node := Next (Src_Node); + while Src_Node /= null loop + declare + Dst_Node : constant Node_Access := Copy_Node (Src_Node); + + -- See note above + + pragma Assert (Checked_Index (HT, Dst_Node) = Src_Index); + + begin + Set_Next (Node => Dst_Prev, Next => Dst_Node); + HT.Length := HT.Length + 1; + + Dst_Prev := Dst_Node; + end; + + Src_Node := Next (Src_Node); + end loop; + end if; + end loop; + + pragma Assert (HT.Length = N); + end Adjust; + + -------------- + -- Capacity -- + -------------- + + function Capacity (HT : Hash_Table_Type) return Count_Type is + begin + if HT.Buckets = null then + return 0; + end if; + + return HT.Buckets'Length; + end Capacity; + + ------------------- + -- Checked_Index -- + ------------------- + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type + is + Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); + begin + return Index (Buckets, Node); + end Checked_Index; + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Node : Node_Access) return Hash_Type + is + begin + return Checked_Index (Hash_Table, Hash_Table.Buckets.all, Node); + end Checked_Index; + + ----------- + -- Clear -- + ----------- + + procedure Clear (HT : in out Hash_Table_Type) is + Index : Hash_Type := 0; + Node : Node_Access; + + begin + TC_Check (HT.TC); + + while HT.Length > 0 loop + while HT.Buckets (Index) = null loop + Index := Index + 1; + end loop; + + declare + Bucket : Node_Access renames HT.Buckets (Index); + begin + loop + Node := Bucket; + Bucket := Next (Bucket); + HT.Length := HT.Length - 1; + Free (Node); + exit when Bucket = null; + end loop; + end; + end loop; + end Clear; + + -------------------------- + -- Delete_Node_At_Index -- + -------------------------- + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type; + Indx : Hash_Type; + X : in out Node_Access) + is + Prev : Node_Access; + Curr : Node_Access; + + begin + Prev := HT.Buckets (Indx); + + if Prev = X then + HT.Buckets (Indx) := Next (Prev); + HT.Length := HT.Length - 1; + Free (X); + return; + end if; + + if Checks and then HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (Prev); + + if Checks and then Curr = null then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + if Curr = X then + Set_Next (Node => Prev, Next => Next (Curr)); + HT.Length := HT.Length - 1; + Free (X); + return; + end if; + + Prev := Curr; + end loop; + end Delete_Node_At_Index; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Node_Access) + is + pragma Assert (X /= null); + + Indx : Hash_Type; + Prev : Node_Access; + Curr : Node_Access; + + begin + if Checks and then HT.Length = 0 then + raise Program_Error with + "attempt to delete node from empty hashed container"; + end if; + + Indx := Checked_Index (HT, X); + Prev := HT.Buckets (Indx); + + if Checks and then Prev = null then + raise Program_Error with + "attempt to delete node from empty hash bucket"; + end if; + + if Prev = X then + HT.Buckets (Indx) := Next (Prev); + HT.Length := HT.Length - 1; + return; + end if; + + if Checks and then HT.Length = 1 then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + loop + Curr := Next (Prev); + + if Checks and then Curr = null then + raise Program_Error with + "attempt to delete node not in its proper hash bucket"; + end if; + + if Curr = X then + Set_Next (Node => Prev, Next => Next (Curr)); + HT.Length := HT.Length - 1; + return; + end if; + + Prev := Curr; + end loop; + end Delete_Node_Sans_Free; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (HT : in out Hash_Table_Type) is + begin + Clear (HT); + Free_Buckets (HT.Buckets); + end Finalize; + + ----------- + -- First -- + ----------- + + function First + (HT : Hash_Table_Type) return Node_Access + is + Dummy : Hash_Type; + begin + return First (HT, Dummy); + end First; + + function First + (HT : Hash_Table_Type; + Position : out Hash_Type) return Node_Access is + begin + if HT.Length = 0 then + Position := Hash_Type'Last; + return null; + end if; + + Position := HT.Buckets'First; + loop + if HT.Buckets (Position) /= null then + return HT.Buckets (Position); + end if; + + Position := Position + 1; + end loop; + end First; + + ------------------ + -- Free_Buckets -- + ------------------ + + procedure Free_Buckets (Buckets : in out Buckets_Access) is + procedure Free is + new Ada.Unchecked_Deallocation (Buckets_Type, Buckets_Allocation); + + begin + -- Buckets must have been created by New_Buckets. Here, we convert back + -- to the Buckets_Allocation type, and do the free on that. + + Free (Buckets_Allocation (Buckets)); + end Free_Buckets; + + --------------------- + -- Free_Hash_Table -- + --------------------- + + procedure Free_Hash_Table (Buckets : in out Buckets_Access) is + Node : Node_Access; + + begin + if Buckets = null then + return; + end if; + + for J in Buckets'Range loop + while Buckets (J) /= null loop + Node := Buckets (J); + Buckets (J) := Next (Node); + Free (Node); + end loop; + end loop; + + Free_Buckets (Buckets); + end Free_Hash_Table; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal + (L, R : Hash_Table_Type) return Boolean + is + begin + if L.Length /= R.Length then + return False; + end if; + + if L.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_L : With_Lock (L.TC'Unrestricted_Access); + Lock_R : With_Lock (R.TC'Unrestricted_Access); + + L_Index : Hash_Type; + L_Node : Node_Access; + + N : Count_Type; + begin + -- Find the first node of hash table L + + L_Index := 0; + loop + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + L_Index := L_Index + 1; + end loop; + + -- For each node of hash table L, search for an equivalent node in + -- hash table R. + + N := L.Length; + loop + if not Find (HT => R, Key => L_Node) then + return False; + end if; + + N := N - 1; + + L_Node := Next (L_Node); + + if L_Node = null then + -- We have exhausted the nodes in this bucket + + if N = 0 then + return True; + end if; + + -- Find the next bucket + + loop + L_Index := L_Index + 1; + L_Node := L.Buckets (L_Index); + exit when L_Node /= null; + end loop; + end if; + end loop; + end; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (HT : Hash_Table_Type) is + procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type); + + ------------- + -- Wrapper -- + ------------- + + procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type) is + begin + Process (Node); + end Wrapper; + + procedure Internal_With_Pos is + new Generic_Iteration_With_Position (Wrapper); + + -- Start of processing for Generic_Iteration + + begin + Internal_With_Pos (HT); + end Generic_Iteration; + + ------------------------------------- + -- Generic_Iteration_With_Position -- + ------------------------------------- + + procedure Generic_Iteration_With_Position + (HT : Hash_Table_Type) + is + Node : Node_Access; + + begin + if HT.Length = 0 then + return; + end if; + + for Indx in HT.Buckets'Range loop + Node := HT.Buckets (Indx); + while Node /= null loop + Process (Node, Indx); + Node := Next (Node); + end loop; + end loop; + end Generic_Iteration_With_Position; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type) + is + N : Count_Type'Base; + NN : Hash_Type; + + begin + Clear (HT); + + Count_Type'Base'Read (Stream, N); + + if Checks and then N < 0 then + raise Program_Error with "stream appears to be corrupt"; + end if; + + if N = 0 then + return; + end if; + + -- The RM does not specify whether or how the capacity changes when a + -- hash table is streamed in. Therefore we decide here to allocate a new + -- buckets array only when it's necessary to preserve representation + -- invariants. + + if HT.Buckets = null + or else HT.Buckets'Length < N + then + Free_Buckets (HT.Buckets); + NN := Prime_Numbers.To_Prime (N); + HT.Buckets := New_Buckets (Length => NN); + end if; + + for J in 1 .. N loop + declare + Node : constant Node_Access := New_Node (Stream); + Indx : constant Hash_Type := Checked_Index (HT, Node); + B : Node_Access renames HT.Buckets (Indx); + begin + Set_Next (Node => Node, Next => B); + B := Node; + end; + + HT.Length := HT.Length + 1; + end loop; + end Generic_Read; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type) + is + procedure Write (Node : Node_Access); + pragma Inline (Write); + + procedure Write is new Generic_Iteration (Write); + + ----------- + -- Write -- + ----------- + + procedure Write (Node : Node_Access) is + begin + Write (Stream, Node); + end Write; + + begin + -- See Generic_Read for an explanation of why we do not stream out the + -- buckets array length too. + + Count_Type'Base'Write (Stream, HT.Length); + Write (HT); + end Generic_Write; + + ----------- + -- Index -- + ----------- + + function Index + (Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type is + begin + return Hash_Node (Node) mod Buckets'Length; + end Index; + + function Index + (Hash_Table : Hash_Table_Type; + Node : Node_Access) return Hash_Type is + begin + return Index (Hash_Table.Buckets.all, Node); + end Index; + + ---------- + -- Move -- + ---------- + + procedure Move (Target, Source : in out Hash_Table_Type) is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Clear (Target); + + declare + Buckets : constant Buckets_Access := Target.Buckets; + begin + Target.Buckets := Source.Buckets; + Source.Buckets := Buckets; + end; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ----------------- + -- New_Buckets -- + ----------------- + + function New_Buckets (Length : Hash_Type) return Buckets_Access is + subtype Rng is Hash_Type range 0 .. Length - 1; + + begin + -- Allocate in Buckets_Allocation'Storage_Pool, then convert to + -- Buckets_Access. + + return Buckets_Access (Buckets_Allocation'(new Buckets_Type (Rng))); + end New_Buckets; + + ---------- + -- Next -- + ---------- + + function Next + (HT : aliased in out Hash_Table_Type; + Node : Node_Access; + Position : in out Hash_Type) return Node_Access + is + Result : Node_Access; + First : Hash_Type; + + begin + -- First, check if the node has other nodes chained to it + Result := Next (Node); + + if Result /= null then + return Result; + end if; + + -- Check if we were supplied a position for Node, from which we + -- can start iteration on the buckets. + + if Position /= Hash_Type'Last then + First := Position + 1; + else + First := Checked_Index (HT, Node) + 1; + end if; + + for Indx in First .. HT.Buckets'Last loop + Result := HT.Buckets (Indx); + + if Result /= null then + Position := Indx; + return Result; + end if; + end loop; + + return null; + end Next; + + function Next + (HT : aliased in out Hash_Table_Type; + Node : Node_Access) return Node_Access + is + Pos : Hash_Type := Hash_Type'Last; + begin + return Next (HT, Node, Pos); + end Next; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (HT : in out Hash_Table_Type; + N : Count_Type) + is + NN : Hash_Type; + + begin + if HT.Buckets = null then + if N > 0 then + NN := Prime_Numbers.To_Prime (N); + HT.Buckets := New_Buckets (Length => NN); + end if; + + return; + end if; + + if HT.Length = 0 then + + -- This is the easy case. There are no nodes, so no rehashing is + -- necessary. All we need to do is allocate a new buckets array + -- having a length implied by the specified capacity. (We say + -- "implied by" because bucket arrays are always allocated with a + -- length that corresponds to a prime number.) + + if N = 0 then + Free_Buckets (HT.Buckets); + return; + end if; + + if N = HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (N); + + if NN = HT.Buckets'Length then + return; + end if; + + declare + X : Buckets_Access := HT.Buckets; + pragma Warnings (Off, X); + begin + HT.Buckets := New_Buckets (Length => NN); + Free_Buckets (X); + end; + + return; + end if; + + if N = HT.Buckets'Length then + return; + end if; + + if N < HT.Buckets'Length then + + -- This is a request to contract the buckets array. The amount of + -- contraction is bounded in order to preserve the invariant that the + -- buckets array length is never smaller than the number of elements + -- (the load factor is 1). + + if HT.Length >= HT.Buckets'Length then + return; + end if; + + NN := Prime_Numbers.To_Prime (HT.Length); + + if NN >= HT.Buckets'Length then + return; + end if; + + else + NN := Prime_Numbers.To_Prime (Count_Type'Max (N, HT.Length)); + + if NN = HT.Buckets'Length then -- can't expand any more + return; + end if; + end if; + + TC_Check (HT.TC); + + Rehash : declare + Dst_Buckets : Buckets_Access := New_Buckets (Length => NN); + Src_Buckets : Buckets_Access := HT.Buckets; + pragma Warnings (Off, Src_Buckets); + + L : Count_Type renames HT.Length; + LL : constant Count_Type := L; + + Src_Index : Hash_Type := Src_Buckets'First; + + begin + while L > 0 loop + declare + Src_Bucket : Node_Access renames Src_Buckets (Src_Index); + + begin + while Src_Bucket /= null loop + declare + Src_Node : constant Node_Access := Src_Bucket; + + Dst_Index : constant Hash_Type := + Checked_Index (HT, Dst_Buckets.all, Src_Node); + + Dst_Bucket : Node_Access renames Dst_Buckets (Dst_Index); + + begin + Src_Bucket := Next (Src_Node); + + Set_Next (Src_Node, Dst_Bucket); + + Dst_Bucket := Src_Node; + end; + + pragma Assert (L > 0); + L := L - 1; + end loop; + + exception + when others => + + -- If there's an error computing a hash value during a + -- rehash, then AI-302 says the nodes "become lost." The + -- issue is whether to actually deallocate these lost nodes, + -- since they might be designated by extant cursors. Here + -- we decide to deallocate the nodes, since it's better to + -- solve real problems (storage consumption) rather than + -- imaginary ones (the user might, or might not, dereference + -- a cursor designating a node that has been deallocated), + -- and because we have a way to vet a dangling cursor + -- reference anyway, and hence can actually detect the + -- problem. + + for Dst_Index in Dst_Buckets'Range loop + declare + B : Node_Access renames Dst_Buckets (Dst_Index); + X : Node_Access; + begin + while B /= null loop + X := B; + B := Next (X); + Free (X); + end loop; + end; + end loop; + + Free_Buckets (Dst_Buckets); + raise Program_Error with + "hash function raised exception during rehash"; + end; + + Src_Index := Src_Index + 1; + end loop; + + HT.Buckets := Dst_Buckets; + HT.Length := LL; + + Free_Buckets (Src_Buckets); + end Rehash; + end Reserve_Capacity; + +end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/libgnat/a-chtgop.ads b/gcc/ada/libgnat/a-chtgop.ads new file mode 100644 index 0000000..ea2209b --- /dev/null +++ b/gcc/ada/libgnat/a-chtgop.ads @@ -0,0 +1,215 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.HASH_TABLES.GENERIC_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Hash_Table_Type is used to implement hashed containers. This package +-- declares hash-table operations that do not depend on keys. + +with Ada.Streams; + +generic + + with package HT_Types is + new Generic_Hash_Table_Types (<>); + + use HT_Types, HT_Types.Implementation; + + with function Hash_Node (Node : Node_Access) return Hash_Type; + + with function Next (Node : Node_Access) return Node_Access; + + with procedure Set_Next + (Node : Node_Access; + Next : Node_Access); + + with function Copy_Node (Source : Node_Access) return Node_Access; + + with procedure Free (X : in out Node_Access); + +package Ada.Containers.Hash_Tables.Generic_Operations is + pragma Preelaborate; + + procedure Free_Hash_Table (Buckets : in out Buckets_Access); + -- First frees the nodes in all non-null buckets of Buckets, and then frees + -- the Buckets array itself. + + function Index + (Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Buckets array index + + function Index + (Hash_Table : Hash_Table_Type; + Node : Node_Access) return Hash_Type; + pragma Inline (Index); + -- Uses the hash value of Node to compute its Hash_Table buckets array + -- index. + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Buckets : Buckets_Type; + Node : Node_Access) return Hash_Type; + -- Calls Index, but also locks and unlocks the container, per AI05-0022, in + -- order to detect element tampering by the generic actual Hash function. + + function Checked_Index + (Hash_Table : aliased in out Hash_Table_Type; + Node : Node_Access) return Hash_Type; + -- Calls Checked_Index using Hash_Table's buckets array. + + procedure Adjust (HT : in out Hash_Table_Type); + -- Used to implement controlled Adjust. It is assumed that HT has the value + -- of the bit-wise copy that immediately follows controlled Finalize. + -- Adjust first allocates a new buckets array for HT (having the same + -- length as the source), and then allocates a copy of each node of source. + + procedure Finalize (HT : in out Hash_Table_Type); + -- Used to implement controlled Finalize. It first calls Clear to + -- deallocate any remaining nodes, and then deallocates the buckets array. + + generic + with function Find + (HT : Hash_Table_Type; + Key : Node_Access) return Boolean; + function Generic_Equal + (L, R : Hash_Table_Type) return Boolean; + -- Used to implement hashed container equality. For each node in hash table + -- L, it calls Find to search for an equivalent item in hash table R. If + -- Find returns False for any node then Generic_Equal terminates + -- immediately and returns False. Otherwise if Find returns True for every + -- node then Generic_Equal returns True. + + procedure Clear (HT : in out Hash_Table_Type); + -- Deallocates each node in hash table HT. (Note that it only deallocates + -- the nodes, not the buckets array.) Program_Error is raised if the hash + -- table is busy. + + procedure Move (Target, Source : in out Hash_Table_Type); + -- Moves (not copies) the buckets array and nodes from Source to + -- Target. Program_Error is raised if Source is busy. The Target is first + -- cleared to deallocate its nodes (implying that Program_Error is also + -- raised if Target is busy). Source is empty following the move. + + function Capacity (HT : Hash_Table_Type) return Count_Type; + -- Returns the length of the buckets array + + procedure Reserve_Capacity + (HT : in out Hash_Table_Type; + N : Count_Type); + -- If N is greater than the current capacity, then it expands the buckets + -- array to at least the value N. If N is less than the current capacity, + -- then it contracts the buckets array. In either case existing nodes are + -- rehashed onto the new buckets array, and the old buckets array is + -- deallocated. Program_Error is raised if the hash table is busy. + + procedure Delete_Node_At_Index + (HT : in out Hash_Table_Type; + Indx : Hash_Type; + X : in out Node_Access); + -- Delete a node whose bucket position is known. Used to remove a node + -- whose element has been modified through a key_preserving reference. + -- We cannot use the value of the element precisely because the current + -- value does not correspond to the hash code that determines the bucket. + + procedure Delete_Node_Sans_Free + (HT : in out Hash_Table_Type; + X : Node_Access); + -- Removes node X from the hash table without deallocating the node + + function First + (HT : Hash_Table_Type) return Node_Access; + function First + (HT : Hash_Table_Type; + Position : out Hash_Type) return Node_Access; + -- Returns the head of the list in the first (lowest-index) non-empty + -- bucket. Position will be the index of the bucket of the first node. + -- It is provided so that clients can implement efficient iterators. + + function Next + (HT : aliased in out Hash_Table_Type; + Node : Node_Access) return Node_Access; + function Next + (HT : aliased in out Hash_Table_Type; + Node : Node_Access; + Position : in out Hash_Type) return Node_Access; + -- Returns the node that immediately follows Node. This corresponds to + -- either the next node in the same bucket, or (if Node is the last node in + -- its bucket) the head of the list in the first non-empty bucket that + -- follows. + -- + -- If Node_Position is supplied, then it will be used as a starting point + -- for iteration (Node_Position must be the index of Node's buckets). If it + -- is not supplied, it will be recomputed. It is provided so that clients + -- can implement efficient iterators. + + generic + with procedure Process (Node : Node_Access; Position : Hash_Type); + procedure Generic_Iteration_With_Position (HT : Hash_Table_Type); + -- Calls Process for each node in hash table HT + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Iteration (HT : Hash_Table_Type); + -- Calls Process for each node in hash table HT + + generic + use Ada.Streams; + with procedure Write + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + HT : Hash_Table_Type); + -- Used to implement the streaming attribute for hashed containers. It + -- calls Write for each node to write its value into Stream. + + generic + use Ada.Streams; + with function New_Node + (Stream : not null access Root_Stream_Type'Class) + return Node_Access; + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + HT : out Hash_Table_Type); + -- Used to implement the streaming attribute for hashed containers. It + -- first clears hash table HT, then populates the hash table by calling + -- New_Node for each item in Stream. + + function New_Buckets (Length : Hash_Type) return Buckets_Access; + pragma Inline (New_Buckets); + -- Allocate a new Buckets_Type array with bounds 0 .. Length - 1 + + procedure Free_Buckets (Buckets : in out Buckets_Access); + pragma Inline (Free_Buckets); + -- Unchecked_Deallocate Buckets + + -- Note: New_Buckets and Free_Buckets are needed because Buckets_Access has + -- an empty pool. + +end Ada.Containers.Hash_Tables.Generic_Operations; diff --git a/gcc/ada/libgnat/a-chzla1.ads b/gcc/ada/libgnat/a-chzla1.ads new file mode 100644 index 0000000..f04a6ce --- /dev/null +++ b/gcc/ada/libgnat/a-chzla1.ads @@ -0,0 +1,376 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions analogous to those in the RM defined +-- package Ada.Characters.Latin_1 except that the type of the constants +-- is Wide_Wide_Character instead of Character. The provision of this package +-- is in accordance with the implementation permission in RM (A.3.3(27)). + +package Ada.Characters.Wide_Wide_Latin_1 is + pragma Pure; + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0); + SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1); + STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2); + ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3); + EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4); + ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5); + ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6); + BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7); + BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8); + HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9); + LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10); + VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11); + FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12); + CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13); + SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14); + SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15); + + DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16); + DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17); + DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18); + DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19); + DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20); + NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21); + SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22); + ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23); + CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24); + EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25); + SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26); + ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27); + FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28); + GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29); + RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30); + US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Wide_Character renames Hyphen; + Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Wide_Character := + Wide_Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Wide_Character renames FS; + IS3 : Wide_Wide_Character renames GS; + IS2 : Wide_Wide_Character renames RS; + IS1 : Wide_Wide_Character renames US; + + Reserved_128 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (128); + Reserved_129 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (129); + BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130); + NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131); + Reserved_132 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (132); + NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133); + SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134); + ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135); + HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136); + HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137); + VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138); + PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139); + PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140); + RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141); + SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142); + SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143); + + DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144); + PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145); + PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146); + STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147); + CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148); + MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149); + SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150); + EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151); + + SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152); + Reserved_153 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (153); + SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154); + CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155); + ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156); + OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157); + PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158); + APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Wide_Characters -- + ----------------------------------- + + -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space + : constant Wide_Wide_Character := Wide_Wide_Character'Val (160); + NBSP : Wide_Wide_Character renames No_Break_Space; + Inverted_Exclamation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (161); + Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162); + Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163); + Currency_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (164); + Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165); + Broken_Bar : constant Wide_Wide_Character := Wide_Wide_Character'Val (166); + Section_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (167); + Diaeresis : constant Wide_Wide_Character := Wide_Wide_Character'Val (168); + Copyright_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (170); + Left_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (171); + Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (174); + Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175); + + -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176); + Ring_Above : Wide_Wide_Character renames Degree_Sign; + Plus_Minus_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (177); + Superscript_Two + : constant Wide_Wide_Character := Wide_Wide_Character'Val (178); + Superscript_Three + : constant Wide_Wide_Character := Wide_Wide_Character'Val (179); + Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (180); + Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181); + Pilcrow_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (182); + Paragraph_Sign + : Wide_Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183); + Cedilla : constant Wide_Wide_Character := Wide_Wide_Character'Val (184); + Superscript_One + : constant Wide_Wide_Character := Wide_Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (187); + Fraction_One_Quarter + : constant Wide_Wide_Character := Wide_Wide_Character'Val (188); + Fraction_One_Half + : constant Wide_Wide_Character := Wide_Wide_Character'Val (189); + Fraction_Three_Quarters + : constant Wide_Wide_Character := Wide_Wide_Character'Val (190); + Inverted_Question + : constant Wide_Wide_Character := Wide_Wide_Character'Val (191); + + -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192); + UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193); + UC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195); + UC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (196); + UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197); + UC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (198); + UC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (199); + UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200); + UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201); + UC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (202); + UC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (203); + UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204); + UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205); + UC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (206); + UC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (207); + + -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209); + UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210); + UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211); + UC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213); + UC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (214); + Multiplication_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (215); + UC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (216); + UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217); + UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218); + UC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (219); + UC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221); + UC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (222); + LC_German_Sharp_S + : constant Wide_Wide_Character := Wide_Wide_Character'Val (223); + + -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224); + LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225); + LC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227); + LC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (228); + LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229); + LC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (230); + LC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (231); + LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232); + LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233); + LC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (234); + LC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (235); + LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236); + LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237); + LC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (238); + LC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (239); + + -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241); + LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242); + LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243); + LC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245); + LC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (246); + Division_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (247); + LC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (248); + LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249); + LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250); + LC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (251); + LC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253); + LC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (254); + LC_Y_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (255); + +end Ada.Characters.Wide_Wide_Latin_1; diff --git a/gcc/ada/libgnat/a-chzla9.ads b/gcc/ada/libgnat/a-chzla9.ads new file mode 100644 index 0000000..a5b3965 --- /dev/null +++ b/gcc/ada/libgnat/a-chzla9.ads @@ -0,0 +1,388 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . W I D E _ W I D E _ L A T I N _ 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions analogous to those in the GNAT package +-- Ada.Characters.Latin_9 except that the type of the various constants is +-- Wide_Wide_Character instead of Character. The provision of this package +-- is in accordance with the implementation permission in RM (A.3.3(27)). + +package Ada.Characters.Wide_Wide_Latin_9 is + pragma Pure; + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Wide_Character := Wide_Wide_Character'Val (0); + SOH : constant Wide_Wide_Character := Wide_Wide_Character'Val (1); + STX : constant Wide_Wide_Character := Wide_Wide_Character'Val (2); + ETX : constant Wide_Wide_Character := Wide_Wide_Character'Val (3); + EOT : constant Wide_Wide_Character := Wide_Wide_Character'Val (4); + ENQ : constant Wide_Wide_Character := Wide_Wide_Character'Val (5); + ACK : constant Wide_Wide_Character := Wide_Wide_Character'Val (6); + BEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (7); + BS : constant Wide_Wide_Character := Wide_Wide_Character'Val (8); + HT : constant Wide_Wide_Character := Wide_Wide_Character'Val (9); + LF : constant Wide_Wide_Character := Wide_Wide_Character'Val (10); + VT : constant Wide_Wide_Character := Wide_Wide_Character'Val (11); + FF : constant Wide_Wide_Character := Wide_Wide_Character'Val (12); + CR : constant Wide_Wide_Character := Wide_Wide_Character'Val (13); + SO : constant Wide_Wide_Character := Wide_Wide_Character'Val (14); + SI : constant Wide_Wide_Character := Wide_Wide_Character'Val (15); + + DLE : constant Wide_Wide_Character := Wide_Wide_Character'Val (16); + DC1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (17); + DC2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (18); + DC3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (19); + DC4 : constant Wide_Wide_Character := Wide_Wide_Character'Val (20); + NAK : constant Wide_Wide_Character := Wide_Wide_Character'Val (21); + SYN : constant Wide_Wide_Character := Wide_Wide_Character'Val (22); + ETB : constant Wide_Wide_Character := Wide_Wide_Character'Val (23); + CAN : constant Wide_Wide_Character := Wide_Wide_Character'Val (24); + EM : constant Wide_Wide_Character := Wide_Wide_Character'Val (25); + SUB : constant Wide_Wide_Character := Wide_Wide_Character'Val (26); + ESC : constant Wide_Wide_Character := Wide_Wide_Character'Val (27); + FS : constant Wide_Wide_Character := Wide_Wide_Character'Val (28); + GS : constant Wide_Wide_Character := Wide_Wide_Character'Val (29); + RS : constant Wide_Wide_Character := Wide_Wide_Character'Val (30); + US : constant Wide_Wide_Character := Wide_Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Wide_Character renames Hyphen; + Full_Stop : constant Wide_Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Wide_Character := + Wide_Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Wide_Character renames FS; + IS3 : Wide_Wide_Character renames GS; + IS2 : Wide_Wide_Character renames RS; + IS1 : Wide_Wide_Character renames US; + + Reserved_128 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (128); + Reserved_129 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (129); + BPH : constant Wide_Wide_Character := Wide_Wide_Character'Val (130); + NBH : constant Wide_Wide_Character := Wide_Wide_Character'Val (131); + Reserved_132 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (132); + NEL : constant Wide_Wide_Character := Wide_Wide_Character'Val (133); + SSA : constant Wide_Wide_Character := Wide_Wide_Character'Val (134); + ESA : constant Wide_Wide_Character := Wide_Wide_Character'Val (135); + HTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (136); + HTJ : constant Wide_Wide_Character := Wide_Wide_Character'Val (137); + VTS : constant Wide_Wide_Character := Wide_Wide_Character'Val (138); + PLD : constant Wide_Wide_Character := Wide_Wide_Character'Val (139); + PLU : constant Wide_Wide_Character := Wide_Wide_Character'Val (140); + RI : constant Wide_Wide_Character := Wide_Wide_Character'Val (141); + SS2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (142); + SS3 : constant Wide_Wide_Character := Wide_Wide_Character'Val (143); + + DCS : constant Wide_Wide_Character := Wide_Wide_Character'Val (144); + PU1 : constant Wide_Wide_Character := Wide_Wide_Character'Val (145); + PU2 : constant Wide_Wide_Character := Wide_Wide_Character'Val (146); + STS : constant Wide_Wide_Character := Wide_Wide_Character'Val (147); + CCH : constant Wide_Wide_Character := Wide_Wide_Character'Val (148); + MW : constant Wide_Wide_Character := Wide_Wide_Character'Val (149); + SPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (150); + EPA : constant Wide_Wide_Character := Wide_Wide_Character'Val (151); + + SOS : constant Wide_Wide_Character := Wide_Wide_Character'Val (152); + Reserved_153 + : constant Wide_Wide_Character := Wide_Wide_Character'Val (153); + SCI : constant Wide_Wide_Character := Wide_Wide_Character'Val (154); + CSI : constant Wide_Wide_Character := Wide_Wide_Character'Val (155); + ST : constant Wide_Wide_Character := Wide_Wide_Character'Val (156); + OSC : constant Wide_Wide_Character := Wide_Wide_Character'Val (157); + PM : constant Wide_Wide_Character := Wide_Wide_Character'Val (158); + APC : constant Wide_Wide_Character := Wide_Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Wide_Characters -- + ----------------------------------- + + -- Wide_Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space + : constant Wide_Wide_Character := Wide_Wide_Character'Val (160); + NBSP : Wide_Wide_Character renames No_Break_Space; + Inverted_Exclamation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (161); + Cent_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (162); + Pound_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (163); + Euro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (164); + Yen_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (165); + UC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (166); + Section_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (167); + LC_S_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (168); + Copyright_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (170); + Left_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (171); + Not_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Wide_Character := Wide_Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (174); + Macron : constant Wide_Wide_Character := Wide_Wide_Character'Val (175); + + -- Wide_Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (176); + Ring_Above : Wide_Wide_Character renames Degree_Sign; + Plus_Minus_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (177); + Superscript_Two + : constant Wide_Wide_Character := Wide_Wide_Character'Val (178); + Superscript_Three + : constant Wide_Wide_Character := Wide_Wide_Character'Val (179); + UC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (180); + Micro_Sign : constant Wide_Wide_Character := Wide_Wide_Character'Val (181); + Pilcrow_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (182); + Paragraph_Sign + : Wide_Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Wide_Character := Wide_Wide_Character'Val (183); + LC_Z_Caron : constant Wide_Wide_Character := Wide_Wide_Character'Val (184); + Superscript_One + : constant Wide_Wide_Character := Wide_Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Wide_Character := Wide_Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Wide_Character := Wide_Wide_Character'Val (187); + UC_Ligature_OE + : constant Wide_Wide_Character := Wide_Wide_Character'Val (188); + LC_Ligature_OE + : constant Wide_Wide_Character := Wide_Wide_Character'Val (189); + UC_Y_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (190); + Inverted_Question + : constant Wide_Wide_Character := Wide_Wide_Character'Val (191); + + -- Wide_Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (192); + UC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (193); + UC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (195); + UC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (196); + UC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (197); + UC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (198); + UC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (199); + UC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (200); + UC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (201); + UC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (202); + UC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (203); + UC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (204); + UC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (205); + UC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (206); + UC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (207); + + -- Wide_Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (209); + UC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (210); + UC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (211); + UC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (213); + UC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (214); + Multiplication_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (215); + UC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (216); + UC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (217); + UC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (218); + UC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (219); + UC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (221); + UC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (222); + LC_German_Sharp_S + : constant Wide_Wide_Character := Wide_Wide_Character'Val (223); + + -- Wide_Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (224); + LC_A_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (225); + LC_A_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (227); + LC_A_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (228); + LC_A_Ring : constant Wide_Wide_Character := Wide_Wide_Character'Val (229); + LC_AE_Diphthong + : constant Wide_Wide_Character := Wide_Wide_Character'Val (230); + LC_C_Cedilla + : constant Wide_Wide_Character := Wide_Wide_Character'Val (231); + LC_E_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (232); + LC_E_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (233); + LC_E_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (234); + LC_E_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (235); + LC_I_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (236); + LC_I_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (237); + LC_I_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (238); + LC_I_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (239); + + -- Wide_Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth + : constant Wide_Wide_Character := Wide_Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (241); + LC_O_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (242); + LC_O_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (243); + LC_O_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Wide_Character := Wide_Wide_Character'Val (245); + LC_O_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (246); + Division_Sign + : constant Wide_Wide_Character := Wide_Wide_Character'Val (247); + LC_O_Oblique_Stroke + : constant Wide_Wide_Character := Wide_Wide_Character'Val (248); + LC_U_Grave : constant Wide_Wide_Character := Wide_Wide_Character'Val (249); + LC_U_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (250); + LC_U_Circumflex + : constant Wide_Wide_Character := Wide_Wide_Character'Val (251); + LC_U_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Wide_Character := Wide_Wide_Character'Val (253); + LC_Icelandic_Thorn + : constant Wide_Wide_Character := Wide_Wide_Character'Val (254); + LC_Y_Diaeresis + : constant Wide_Wide_Character := Wide_Wide_Character'Val (255); + + ------------------------------------------------ + -- Summary of Changes from Latin-1 => Latin-9 -- + ------------------------------------------------ + + -- 164 Currency => Euro_Sign + -- 166 Broken_Bar => UC_S_Caron + -- 168 Diaeresis => LC_S_Caron + -- 180 Acute => UC_Z_Caron + -- 184 Cedilla => LC_Z_Caron + -- 188 Fraction_One_Quarter => UC_Ligature_OE + -- 189 Fraction_One_Half => LC_Ligature_OE + -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis + +end Ada.Characters.Wide_Wide_Latin_9; diff --git a/gcc/ada/libgnat/a-cidlli.adb b/gcc/ada/libgnat/a-cidlli.adb new file mode 100644 index 0000000..55445e3 --- /dev/null +++ b/gcc/ada/libgnat/a-cidlli.adb @@ -0,0 +1,2290 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Doubly_Linked_Lists is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free (X : in out Node_Access); + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access); + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List); + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List; + Position : Node_Access); + + function Vet (Position : Cursor) return Boolean; + -- Checks invariants of the cursor and its designated container, as a + -- simple way of detecting dangling references (see operation Free for a + -- description of the detection mechanism), returning True if all checks + -- pass. Invocations of Vet are used here as the argument of pragma Assert, + -- so the checks are performed only when assertions are enabled. + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + begin + if Left.Length /= Right.Length then + return False; + end if; + + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L : Node_Access := Left.First; + R : Node_Access := Right.First; + begin + for J in 1 .. Left.Length loop + if L.Element.all /= R.Element.all then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + end; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out List) is + Src : Node_Access := Container.First; + Dst : Node_Access; + + begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + + if Src = null then + pragma Assert (Container.Last = null); + pragma Assert (Container.Length = 0); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + pragma Assert (Container.Length > 0); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + + declare + Element : Element_Access := new Element_Type'(Src.Element.all); + begin + Dst := new Node_Type'(Element, null, null); + exception + when others => + Free (Element); + raise; + end; + + Container.First := Dst; + Container.Last := Dst; + Container.Length := 1; + + Src := Src.Next; + while Src /= null loop + declare + Element : Element_Access := new Element_Type'(Src.Element.all); + begin + Dst := new Node_Type'(Element, null, Prev => Container.Last); + exception + when others => + Free (Element); + raise; + end; + + Container.Last.Next := Dst; + Container.Last := Dst; + Container.Length := Container.Length + 1; + + Src := Src.Next; + end loop; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + + else + Target.Clear; + + Node := Source.First; + while Node /= null loop + Target.Append (Node.Element.all); + Node := Node.Next; + end loop; + end if; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + X : Node_Access; + pragma Warnings (Off, X); + + begin + if Container.Length = 0 then + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + pragma Assert (Container.TC = (Busy => 0, Lock => 0)); + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + TC_Check (Container.TC); + + while Container.Length > 1 loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + Container.First.Prev := null; + + Container.Length := Container.Length - 1; + + Free (X); + end loop; + + X := Container.First; + pragma Assert (X = Container.Last); + + Container.First := null; + Container.Last := null; + Container.Length := 0; + + Free (X); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : List) return List is + begin + return Target : List do + Target.Assign (Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + X : Node_Access; + + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; -- Post-York behavior + return; + end if; + + if Count = 0 then + Position := No_Element; -- Post-York behavior + return; + end if; + + TC_Check (Container.TC); + + for Index in 1 .. Count loop + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := X.Prev; + Container.Last.Next := null; + + Free (X); + return; + end if; + + Position.Node := X.Next; + + X.Next.Prev := X.Prev; + X.Prev.Next := X.Next; + + Free (X); + end loop; + + -- Fix this junk comment ??? + + Position := No_Element; -- Post-York behavior + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + is + X : Node_Access; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + for J in 1 .. Count loop + X := Container.First; + pragma Assert (X.Next.Prev = Container.First); + + Container.First := X.Next; + Container.First.Prev := null; + + Container.Length := Container.Length - 1; + + Free (X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + is + X : Node_Access; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + for J in 1 .. Count loop + X := Container.Last; + pragma Assert (X.Prev.Next = Container.Last); + + Container.Last := X.Prev; + Container.Last.Next := null; + + Container.Length := Container.Length - 1; + + Free (X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + return Position.Node.Element.all; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.First; + + else + if Checks and then Node.Element = null then + raise Program_Error; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + while Node /= null loop + if Node.Element.all = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Node.Next; + end loop; + + return No_Element; + end; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.First); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Indefinite_Doubly_Linked_Lists.First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + begin + if Checks and then Container.First = null then + raise Constraint_Error with "list is empty"; + end if; + + return Container.First.Element.all; + end First_Element; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + -- While a node is in use, as an active link in a list, its Previous and + -- Next components must be null, or designate a different node; this is + -- a node invariant. For this indefinite list, there is an additional + -- invariant: that the element access value be non-null. Before actually + -- deallocating the node, we set the node access value components of the + -- node to point to the node itself, and set the element access value to + -- null (by deallocating the node's element), thus falsifying the node + -- invariant. Subprogram Vet inspects the value of the node components + -- when interrogating the node, in order to detect whether the cursor's + -- node access value is dangling. + + -- Note that we have no guarantee that the storage for the node isn't + -- modified when it is deallocated, but there are other tests that Vet + -- does if node invariants appear to be satisifed. However, in practice + -- this simple test works well enough, detecting dangling references + -- immediately, without needing further interrogation. + + X.Next := X; + X.Prev := X; + + begin + Free (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Node : Node_Access; + begin + Node := Container.First; + for J in 2 .. Container.Length loop + if Node.Next.Element.all < Node.Element.all then + return False; + end if; + + Node := Node.Next; + end loop; + + return True; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge + (Target : in out List; + Source : in out List) + is + begin + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then + return; + end if; + + if Checks and then Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + + if Checks and then Target.Length > Count_Type'Last - Source.Length + then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + declare + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); + + LI, RI, RJ : Node_Access; + + begin + LI := Target.First; + RI := Source.First; + while RI /= null loop + pragma Assert (RI.Next = null + or else not (RI.Next.Element.all < + RI.Element.all)); + + if LI = null then + Splice_Internal (Target, null, Source); + exit; + end if; + + pragma Assert (LI.Next = null + or else not (LI.Next.Element.all < + LI.Element.all)); + + if RI.Element.all < LI.Element.all then + RJ := RI; + RI := RI.Next; + Splice_Internal (Target, LI, Source, RJ); + + else + LI := LI.Next; + end if; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + procedure Partition (Pivot : Node_Access; Back : Node_Access); + -- Comment ??? + + procedure Sort (Front, Back : Node_Access); + -- Comment??? Confusing name??? change name??? + + --------------- + -- Partition -- + --------------- + + procedure Partition (Pivot : Node_Access; Back : Node_Access) is + Node : Node_Access; + + begin + Node := Pivot.Next; + while Node /= Back loop + if Node.Element.all < Pivot.Element.all then + declare + Prev : constant Node_Access := Node.Prev; + Next : constant Node_Access := Node.Next; + + begin + Prev.Next := Next; + + if Next = null then + Container.Last := Prev; + else + Next.Prev := Prev; + end if; + + Node.Next := Pivot; + Node.Prev := Pivot.Prev; + + Pivot.Prev := Node; + + if Node.Prev = null then + Container.First := Node; + else + Node.Prev.Next := Node; + end if; + + Node := Next; + end; + + else + Node := Node.Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Node_Access) is + Pivot : constant Node_Access := + (if Front = null then Container.First else Front.Next); + begin + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Sort + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + TC_Check (Container.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Sort (Front => null, Back => null); + end; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Sort; + + end Generic_Sorting; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + First_Node : Node_Access; + New_Node : Node_Access; + + begin + if Before.Container /= null then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Before cursor designates wrong list"; + end if; + + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then + raise Program_Error with + "Before cursor has no element"; + end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Checks and then Container.Length > Count_Type'Last - Count then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + TC_Check (Container.TC); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + + Element : Element_Access := new Element_Type'(New_Item); + + begin + New_Node := new Node_Type'(Element, null, null); + First_Node := New_Node; + + exception + when others => + Free (Element); + raise; + end; + + Insert_Internal (Container, Before.Node, New_Node); + + for J in 2 .. Count loop + declare + Element : Element_Access := new Element_Type'(New_Item); + begin + New_Node := new Node_Type'(Element, null, null); + exception + when others => + Free (Element); + raise; + end; + + Insert_Internal (Container, Before.Node, New_Node); + end loop; + + Position := Cursor'(Container'Unchecked_Access, First_Node); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List; + Before : Node_Access; + New_Node : Node_Access) + is + begin + if Container.Length = 0 then + pragma Assert (Before = null); + pragma Assert (Container.First = null); + pragma Assert (Container.Last = null); + + Container.First := New_Node; + Container.Last := New_Node; + + elsif Before = null then + pragma Assert (Container.Last.Next = null); + + Container.Last.Next := New_Node; + New_Node.Prev := Container.Last; + + Container.Last := New_Node; + + elsif Before = Container.First then + pragma Assert (Container.First.Prev = null); + + Container.First.Prev := New_Node; + New_Node.Next := Container.First; + + Container.First := New_Node; + + else + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + New_Node.Next := Before; + New_Node.Prev := Before.Prev; + + Before.Prev.Next := New_Node; + Before.Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + Node : Node_Access := Container.First; + + begin + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Next; + end loop; + end Iterate; + + function Iterate + (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : List; + Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong list"; + end if; + + pragma Assert (Vet (Start), "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the + -- First and Last selector functions of the iterator object. When + -- the Node component is non-null (as is the case here), it means + -- that this is a partial iteration, over a subset of the complete + -- sequence of items. The iterator object was constructed with + -- a start expression, indicating the position from which the + -- iteration begins. Note that the start position has the same value + -- irrespective of whether this is a forward or reverse iteration. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Container.Last); + end if; + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Indefinite_Doubly_Linked_Lists.Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + begin + if Checks and then Container.Last = null then + raise Constraint_Error with "list is empty"; + end if; + + return Container.Last.Element.all; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out List; Source : in out List) is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Clear (Target); + + Target.First := Source.First; + Source.First := null; + + Target.Last := Source.Last; + Source.Last := null; + + Target.Length := Source.Length; + Source.Length := 0; + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + + else + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + Next_Node : constant Node_Access := Position.Node.Next; + begin + if Next_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Next_Node); + end if; + end; + end if; + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong list"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + + else + pragma Assert (Vet (Position), "bad cursor in Previous"); + + declare + Prev_Node : constant Node_Access := Position.Node.Prev; + begin + if Prev_Node = null then + return No_Element; + else + return Cursor'(Position.Container, Prev_Node); + end if; + end; + end if; + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong list"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + Lock : With_Lock (Position.Container.TC'Unrestricted_Access); + begin + Process (Position.Node.Element.all); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List) + is + N : Count_Type'Base; + Dst : Node_Access; + + begin + Clear (Item); + + Count_Type'Base'Read (Stream, N); + + if N = 0 then + return; + end if; + + declare + Element : Element_Access := + new Element_Type'(Element_Type'Input (Stream)); + begin + Dst := new Node_Type'(Element, null, null); + exception + when others => + Free (Element); + raise; + end; + + Item.First := Dst; + Item.Last := Dst; + Item.Length := 1; + + while Item.Length < N loop + declare + Element : Element_Access := + new Element_Type'(Element_Type'Input (Stream)); + begin + Dst := new Node_Type'(Element, Next => null, Prev => Item.Last); + exception + when others => + Free (Element); + raise; + end; + + Item.Last.Next := Dst; + Item.Last := Dst; + Item.Length := Item.Length + 1; + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Reference"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + TE_Check (Container.TC); + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + X : Element_Access := Position.Node.Element; + + begin + Position.Node.Element := new Element_Type'(New_Item); + Free (X); + end; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + I : Node_Access := Container.First; + J : Node_Access := Container.Last; + + procedure Swap (L, R : Node_Access); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Node_Access) is + LN : constant Node_Access := L.Next; + LP : constant Node_Access := L.Prev; + + RN : constant Node_Access := R.Next; + RP : constant Node_Access := R.Prev; + + begin + if LP /= null then + LP.Next := R; + end if; + + if RN /= null then + RN.Prev := L; + end if; + + L.Next := RN; + R.Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + L.Prev := R; + R.Next := L; + + else + L.Prev := RP; + RP.Next := L; + + R.Next := LN; + LN.Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + + TC_Check (Container.TC); + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := J.Next; + exit when I = J; + + I := I.Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := I.Next; + exit when I = J; + + J := J.Prev; + exit when I = J; + end loop; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Node : Node_Access := Position.Node; + + begin + if Node = null then + Node := Container.Last; + + else + if Checks and then Node.Element = null then + raise Program_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + while Node /= null loop + if Node.Element.all = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Node.Prev; + end loop; + + return No_Element; + end; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + Node : Node_Access := Container.Last; + + begin + while Node /= null loop + Process (Cursor'(Container'Unrestricted_Access, Node)); + Node := Node.Prev; + end loop; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List) + is + begin + if Before.Container /= null then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then + raise Program_Error with + "Before cursor has no element"; + end if; + + pragma Assert (Vet (Before), "bad cursor in Splice"); + end if; + + if Target'Address = Source'Address or else Source.Length = 0 then + return; + end if; + + if Checks and then Target.Length > Count_Type'Last - Source.Length then + raise Constraint_Error with "new length exceeds maximum"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + Splice_Internal (Target, Before.Node, Source); + end Splice; + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor) + is + begin + if Before.Container /= null then + if Checks and then Before.Container /= Container'Unchecked_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then + raise Program_Error with + "Before cursor has no element"; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else Position.Node.Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + + TC_Check (Container.TC); + + if Before.Node = null then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := Position.Node.Next; + Container.First.Prev := null; + else + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + Container.Last.Next := Position.Node; + Position.Node.Prev := Container.Last; + + Container.Last := Position.Node; + Container.Last.Next := null; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := Position.Node.Prev; + Container.Last.Next := null; + else + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + Container.First.Prev := Position.Node; + Position.Node.Next := Container.First; + + Container.First := Position.Node; + Container.First.Prev := null; + + return; + end if; + + if Position.Node = Container.First then + Container.First := Position.Node.Next; + Container.First.Prev := null; + + elsif Position.Node = Container.Last then + Container.Last := Position.Node.Prev; + Container.Last.Next := null; + + else + Position.Node.Prev.Next := Position.Node.Next; + Position.Node.Next.Prev := Position.Node.Prev; + end if; + + Before.Node.Prev.Next := Position.Node; + Position.Node.Prev := Before.Node.Prev; + + Before.Node.Prev := Position.Node; + Position.Node.Next := Before.Node; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Splice; + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor) + is + begin + if Target'Address = Source'Address then + Splice (Target, Before, Position); + return; + end if; + + if Before.Container /= null then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with + "Before cursor designates wrong container"; + end if; + + if Checks and then + (Before.Node = null or else Before.Node.Element = null) + then + raise Program_Error with + "Before cursor has no element"; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Source'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Checks and then Target.Length = Count_Type'Last then + raise Constraint_Error with "Target is full"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + Splice_Internal (Target, Before.Node, Source, Position.Node); + Position.Container := Target'Unchecked_Access; + end Splice; + + --------------------- + -- Splice_Internal -- + --------------------- + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; + Source : in out List) + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted, and corner-cases disposed of. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Target.Length <= Count_Type'Last - Source.Length); + + if Target.Length = 0 then + pragma Assert (Before = null); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + + Target.First := Source.First; + Target.Last := Source.Last; + + elsif Before = null then + pragma Assert (Target.Last.Next = null); + + Target.Last.Next := Source.First; + Source.First.Prev := Target.Last; + + Target.Last := Source.Last; + + elsif Before = Target.First then + pragma Assert (Target.First.Prev = null); + + Source.Last.Next := Target.First; + Target.First.Prev := Source.Last; + + Target.First := Source.First; + + else + pragma Assert (Target.Length >= 2); + Before.Prev.Next := Source.First; + Source.First.Prev := Before.Prev; + + Before.Prev := Source.Last; + Source.Last.Next := Before; + end if; + + Source.First := null; + Source.Last := null; + + Target.Length := Target.Length + Source.Length; + Source.Length := 0; + end Splice_Internal; + + procedure Splice_Internal + (Target : in out List; + Before : Node_Access; -- node of Target + Source : in out List; + Position : Node_Access) -- node of Source + is + begin + -- This implements the corresponding Splice operation, after the + -- parameters have been vetted. + + pragma Assert (Target'Address /= Source'Address); + pragma Assert (Target.Length < Count_Type'Last); + pragma Assert (Source.Length > 0); + pragma Assert (Source.First /= null); + pragma Assert (Source.First.Prev = null); + pragma Assert (Source.Last /= null); + pragma Assert (Source.Last.Next = null); + pragma Assert (Position /= null); + + if Position = Source.First then + Source.First := Position.Next; + + if Position = Source.Last then + pragma Assert (Source.First = null); + pragma Assert (Source.Length = 1); + Source.Last := null; + + else + Source.First.Prev := null; + end if; + + elsif Position = Source.Last then + pragma Assert (Source.Length >= 2); + Source.Last := Position.Prev; + Source.Last.Next := null; + + else + pragma Assert (Source.Length >= 3); + Position.Prev.Next := Position.Next; + Position.Next.Prev := Position.Prev; + end if; + + if Target.Length = 0 then + pragma Assert (Before = null); + pragma Assert (Target.First = null); + pragma Assert (Target.Last = null); + + Target.First := Position; + Target.Last := Position; + + Target.First.Prev := null; + Target.Last.Next := null; + + elsif Before = null then + pragma Assert (Target.Last.Next = null); + Target.Last.Next := Position; + Position.Prev := Target.Last; + + Target.Last := Position; + Target.Last.Next := null; + + elsif Before = Target.First then + pragma Assert (Target.First.Prev = null); + Target.First.Prev := Position; + Position.Next := Target.First; + + Target.First := Position; + Target.First.Prev := null; + + else + pragma Assert (Target.Length >= 2); + Before.Prev.Next := Position; + Position.Prev := Before.Prev; + + Before.Prev := Position; + Position.Next := Before; + end if; + + Target.Length := Target.Length + 1; + Source.Length := Source.Length - 1; + end Splice_Internal; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if Checks and then I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unchecked_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if Checks and then J.Container /= Container'Unchecked_Access then + raise Program_Error with "J cursor designates wrong container"; + end if; + + if I.Node = J.Node then + return; + end if; + + TE_Check (Container.TC); + + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + declare + EI_Copy : constant Element_Access := I.Node.Element; + + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if Checks and then I.Node = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then J.Node = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor designates wrong container"; + end if; + + if Checks and then J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor designates wrong container"; + end if; + + if I.Node = J.Node then + return; + end if; + + TC_Check (Container.TC); + + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + + declare + I_Next : constant Cursor := Next (I); + + begin + if I_Next = J then + Splice (Container, Before => I, Position => J); + + else + declare + J_Next : constant Cursor := Next (J); + + begin + if J_Next = I then + Splice (Container, Before => J, Position => I); + + else + pragma Assert (Container.Length >= 3); + + Splice (Container, Before => I_Next, Position => J); + Splice (Container, Before => J_Next, Position => I); + end if; + end; + end if; + end; + + pragma Assert (Container.First.Prev = null); + pragma Assert (Container.Last.Next = null); + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unchecked_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Process (Position.Node.Element.all); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + -- An invariant of a node is that its Previous and Next components can + -- be null, or designate a different node. Also, its element access + -- value must be non-null. Operation Free sets the node access value + -- components of the node to designate the node itself, and the element + -- access value to null, before actually deallocating the node, thus + -- deliberately violating the node invariant. This gives us a simple way + -- to detect a dangling reference to a node. + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Prev = Position.Node then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + -- In practice the tests above will detect most instances of a dangling + -- reference. If we get here, it means that the invariants of the + -- designated node are satisfied (they at least appear to be satisfied), + -- so we perform some more tests, to determine whether invariants of the + -- designated list are satisfied too. + + declare + L : List renames Position.Container.all; + + begin + if L.Length = 0 then + return False; + end if; + + if L.First = null then + return False; + end if; + + if L.Last = null then + return False; + end if; + + if L.First.Prev /= null then + return False; + end if; + + if L.Last.Next /= null then + return False; + end if; + + if Position.Node.Prev = null and then Position.Node /= L.First then + return False; + end if; + + if Position.Node.Next = null and then Position.Node /= L.Last then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if L.First.Next = null then + return False; + end if; + + if L.Last.Prev = null then + return False; + end if; + + if L.First.Next.Prev /= L.First then + return False; + end if; + + if L.Last.Prev.Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if L.First.Next /= L.Last then + return False; + end if; + + if L.Last.Prev /= L.First then + return False; + end if; + + return True; + end if; + + if L.First.Next = L.Last then + return False; + end if; + + if L.Last.Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if Position.Node.Next = null then + return False; + end if; + + if Position.Node.Prev = null then + return False; + end if; + + if Position.Node.Next.Prev /= Position.Node then + return False; + end if; + + if Position.Node.Prev.Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if L.First.Next /= Position.Node then + return False; + end if; + + if L.Last.Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List) + is + Node : Node_Access := Item.First; + + begin + Count_Type'Base'Write (Stream, Item.Length); + + while Node /= null loop + Element_Type'Output (Stream, Node.Element.all); + Node := Node.Next; + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream list cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cidlli.ads b/gcc/ada/libgnat/a-cidlli.ads new file mode 100644 index 0000000..764d1bd --- /dev/null +++ b/gcc/ada/libgnat/a-cidlli.ads @@ -0,0 +1,397 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type (<>) is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Indefinite_Doubly_Linked_Lists is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type List is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package List_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : List) return Boolean; + + function Length (Container : List) return Count_Type; + + function Is_Empty (Container : List) return Boolean; + + procedure Clear (Container : in out List); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased List; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out List; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out List; Source : List); + + function Copy (Source : List) return List; + + procedure Move + (Target : in out List; + Source : in out List); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out List); + + procedure Swap (Container : in out List; I, J : Cursor); + + procedure Swap_Links (Container : in out List; I, J : Cursor); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List); + + procedure Splice + (Target : in out List; + Before : Cursor; + Source : in out List; + Position : in out Cursor); + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : Cursor); + + function First (Container : List) return Cursor; + + function First_Element (Container : List) return Element_Type; + + function Last (Container : List) return Cursor; + + function Last_Element (Container : List) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + + function Iterate + (Container : List) + return List_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : List; + Start : Cursor) + return List_Iterator_Interfaces.Reversible_Iterator'class; + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + + procedure Sort (Container : in out List); + + procedure Merge (Target, Source : in out List); + + end Generic_Sorting; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + type Node_Type; + type Node_Access is access Node_Type; + + type Element_Access is access all Element_Type; + + type Node_Type is + limited record + Element : Element_Access; + Next : Node_Access; + Prev : Node_Access; + end record; + + use Ada.Finalization; + use Ada.Streams; + + type List is + new Controlled with record + First : Node_Access := null; + Last : Node_Access := null; + Length : Count_Type := 0; + TC : aliased Tamper_Counts; + end record; + + overriding procedure Adjust (Container : in out List); + + overriding procedure Finalize (Container : in out List) renames Clear; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out List); + + for List'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : List); + + for List'Write use Write; + + type List_Access is access all List; + for List_Access'Storage_Size use 0; + + type Cursor is + record + Container : List_Access; + Node : Node_Access; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_List : constant List := List'(Controlled with others => <>); + + No_Element : constant Cursor := Cursor'(null, null); + + type Iterator is new Limited_Controlled and + List_Iterator_Interfaces.Reversible_Iterator with + record + Container : List_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Indefinite_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-cihama.adb b/gcc/ada/libgnat/a-cihama.adb new file mode 100644 index 0000000..43a0380 --- /dev/null +++ b/gcc/ada/libgnat/a-cihama.adb @@ -0,0 +1,1364 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Hashed_Maps is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + procedure Free_Key is + new Ada.Unchecked_Deallocation (Key_Type, Key_Access); + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Node : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Key_Node); + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + procedure Free (X : in out Node_Access); + -- pragma Inline (Free); + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Ada.Containers.Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Key_Ops is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + --------- + -- "=" -- + --------- + + function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); + + overriding function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + + if Target.Capacity < Source.Length then + Target.Reserve_Capacity (Source.Length); + end if; + + Insert_Items (Source.HT); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container.HT); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in Constant_Reference is bad"); + + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "key has no element"; + end if; + + declare + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Map; + Capacity : Count_Type := 0) return Map + is + C : Count_Type; + + begin + if Capacity < Source.Length then + if Checks and then Capacity /= 0 then + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + C := Source.Length; + else + C := Capacity; + end if; + + return Target : Map do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Node : Node_Access) return Node_Access is + K : Key_Access := new Key_Type'(Node.Key.all); + E : Element_Access; + begin + E := new Element_Type'(Node.Element.all); + return new Node_Type'(K, E, null); + exception + when others => + Free_Key (K); + Free_Element (E); + raise; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access; + + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + + if Checks and then X = null then + raise Constraint_Error with "attempt to delete key not in map"; + end if; + + Free (X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + TC_Check (Container.HT.TC); + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); + Position.Container := null; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Node.Element.all; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor of function Element is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + return Position.Node.Element.all; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean + is + begin + return Equivalent_Keys (Key, Node.Key.all); + end Equivalent_Key_Node; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + if Checks and then Left.Node.Key = null then + raise Program_Error with + "Left cursor of Equivalent_Keys is bad"; + end if; + + if Checks and then Right.Node.Key = null then + raise Program_Error with + "Right cursor of Equivalent_Keys is bad"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all); + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Cursor; + Right : Key_Type) return Boolean + is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if Checks and then Left.Node.Key = null then + raise Program_Error with + "Left cursor of Equivalent_Keys is bad"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys"); + + return Equivalent_Keys (Left.Node.Key.all, Right); + end Equivalent_Keys; + + function Equivalent_Keys + (Left : Key_Type; + Right : Cursor) return Boolean + is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + if Checks and then Right.Node.Key = null then + raise Program_Error with + "Right cursor of Equivalent_Keys is bad"; + end if; + + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys"); + + return Equivalent_Keys (Left, Right.Node.Key.all); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access; + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Map) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.HT.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); + end Find; + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all); + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + while R_Node /= null loop + if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then + return L_Node.Element.all = R_Node.Element.all; + end if; + + R_Node := R_Node.Next; + end loop; + + return False; + end Find_Equal_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Pos : Hash_Type; + Node : constant Node_Access := HT_Ops.First (Container.HT, Pos); + begin + if Node = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node, Pos); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X = null then + return; + end if; + + X.Next := X; -- detect mischief (in Vet) + + begin + Free_Key (X.Key); + + exception + when others => + X.Key := null; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + end; + + Deallocate (X); + raise; + end; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Key.all); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + K : Key_Access; + E : Element_Access; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.HT.TC); + + K := Position.Node.Key; + E := Position.Node.Element; + + Position.Node.Key := new Key_Type'(Key); + + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Position.Node.Element := new Element_Type'(New_Item); + + exception + when others => + Free_Key (K); + raise; + end; + + Free_Key (K); + Free_Element (E); + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + K : Key_Access := new Key_Type'(Key); + E : Element_Access; + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + E := new Element_Type'(New_Item); + return new Node_Type'(K, E, Next); + + exception + when others => + Free_Key (K); + Free_Element (E); + raise; + end New_Node; + + HT : Hash_Table_Type renames Container.HT; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.HT.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access; Position : Hash_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new HT_Ops.Generic_Iteration_With_Position (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access; Position : Hash_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node, Position)); + end Process_Node; + + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.HT); + end Iterate; + + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return It : constant Iterator := + (Limited_Controlled with Container => Container'Unrestricted_Access) + do + Busy (Container.HT.TC'Unrestricted_Access.all); + end return; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + if Checks and then Position.Node.Key = null then + raise Program_Error with + "Position cursor of function Key is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + + return Position.Node.Key.all; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.HT.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) + is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + Node : Node_Access; + Pos : Hash_Type; + begin + if Position.Node = null then + return No_Element; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with "Position cursor of Next is bad"; + end if; + + pragma Assert (Vet (Position), "Position cursor of Next is bad"); + + Pos := Position.Position; + Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos); + + if Node = null then + return No_Element; + else + return Cursor'(Position.Container, Node, Pos); + end if; + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); + end Next; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with + "Position cursor of Query_Element is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + begin + Process (K, E); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + begin + Node.Key := new Key_Type'(Key_Type'Input (Stream)); + exception + when others => + Free (Node); + raise; + end; + + begin + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + exception + when others => + Free_Key (Node.Key); + Free (Node); + raise; + end; + + return Node; + end Read_Node; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor has no element"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in function Reference is bad"); + + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + HT : Hash_Table_Type renames Container.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "key has no element"; + end if; + + declare + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + K : Key_Access; + E : Element_Access; + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace key not in map"; + end if; + + TE_Check (Container.HT.TC); + + K := Node.Key; + E := Node.Element; + + Node.Key := new Key_Type'(Key); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(New_Item); + + exception + when others => + Free_Key (K); + raise; + end; + + Free_Key (K); + Free_Element (E); + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with + "Position cursor of Replace_Element is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + TE_Check (Position.Container.HT.TC); + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + declare + X : Element_Access := Position.Node.Element; + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with + "Position cursor of Update_Element is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + HT : Hash_Table_Type renames Container.HT; + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + begin + Process (K, E); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Key = null then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key.all)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Output (Stream, Node.Key.all); + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + +end Ada.Containers.Indefinite_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cihama.ads b/gcc/ada/libgnat/a-cihama.ads new file mode 100644 index 0000000..dad3475 --- /dev/null +++ b/gcc/ada/libgnat/a-cihama.ads @@ -0,0 +1,455 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Hash_Tables; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Key_Type (<>) is private; + type Element_Type (<>) is private; + + with function Hash (Key : Key_Type) return Hash_Type; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Hashed_Maps is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type Map is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + -- Map objects declared without an initialization expression are + -- initialized to the value Empty_Map. + + No_Element : constant Cursor; + -- Cursor objects declared without an initialization expression are + -- initialized to the value No_Element. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Map_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + overriding function "=" (Left, Right : Map) return Boolean; + -- For each key/element pair in Left, equality attempts to find the key in + -- Right; if a search fails the equality returns False. The search works by + -- calling Hash to find the bucket in the Right map that corresponds to the + -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys + -- to compare the key (in Left) to the key of each node in the bucket (in + -- Right); if the keys are equivalent, then the equality test for this + -- key/element pair (in Left) completes by calling the element equality + -- operator to compare the element (in Left) to the element of the node + -- (in Right) whose key matched. + + function Capacity (Container : Map) return Count_Type; + -- Returns the current capacity of the map. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing key in order to + -- compute the new index), and then the old buckets array is deallocated. + + function Length (Container : Map) return Count_Type; + -- Returns the number of items in the map + + function Is_Empty (Container : Map) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Map); + -- Removes all of the items from the map + + function Key (Position : Cursor) return Key_Type; + -- Returns the key of the node designated by the cursor + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + -- Assigns the value New_Item to the element designated by the cursor + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)); + -- Calls Process with the key and element (both having only a constant + -- view) of the node designed by the cursor. + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)); + -- Calls Process with the key (with only a constant view) and element (with + -- a variable view) of the node designed by the cursor. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map; + + procedure Move (Target : in out Map; Source : in out Map); + -- Clears Target (if it's not empty), and then moves (not copies) the + -- buckets array and nodes from Source to Target. + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + -- Conditionally inserts New_Item into the map. If Key is already in the + -- map, then Inserted returns False and Position designates the node + -- containing the existing key/element pair (neither of which is modified). + -- If Key is not already in the map, the Inserted returns True and Position + -- designates the newly-inserted node container Key and New_Item. The + -- search for the key works as follows. Hash is called to determine Key's + -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to + -- compare Key to each node in that bucket. If the bucket is empty, or + -- there were no matching keys in the bucket, the search "fails" and the + -- key/item pair is inserted in the map (and Inserted returns True); + -- otherwise, the search "succeeds" (and Inserted returns False). + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map, performing the usual search (which + -- involves calling both Hash and Equivalent_Keys); if the search succeeds + -- (because Key is already in the map), then it raises Constraint_Error. + -- (This version of Insert is similar to Replace, but having the opposite + -- exception behavior. It is intended for use when you want to assert that + -- Key is not already in the map.) + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map. If Key is already in the map, then + -- both the existing key and element are assigned the values of Key and + -- New_Item, respectively. (This version of Insert only raises an exception + -- if cursor tampering occurs. It is intended for use when you want to + -- insert the key/element pair in the map, and you don't care whether Key + -- is already present.) + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Searches for Key in the map; if the search fails (because Key was not in + -- the map), then it raises Constraint_Error. Otherwise, both the existing + -- key and element are assigned the values of Key and New_Item rsp. (This + -- is similar to Insert, but with the opposite exception behavior. It is + -- intended for use when you want to assert that Key is already in the + -- map.) + + procedure Exclude (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map, and if found, removes its node from the map + -- and then deallocates it. The search works as follows. The operation + -- calls Hash to determine the key's bucket; if the bucket is not empty, it + -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is + -- the deletion analog of Include. It is intended for use when you want to + -- remove the item from the map, but don't care whether the key is already + -- in the map.) + + procedure Delete (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map (which involves calling both Hash and + -- Equivalent_Keys). If the search fails, then the operation raises + -- Constraint_Error. Otherwise it removes the node from the map and then + -- deallocates it. (This is the deletion analog of non-conditional + -- Insert. It is intended for use when you want to assert that the item is + -- already in the map.) + + procedure Delete (Container : in out Map; Position : in out Cursor); + -- Removes the node designated by Position from the map, and then + -- deallocates the node. The operation calls Hash to determine the bucket, + -- and then compares Position to each node in the bucket until there's a + -- match (it does not call Equivalent_Keys). + + function First (Container : Map) return Cursor; + -- Returns a cursor that designates the first non-empty bucket, by + -- searching from the beginning of the buckets array. + + function Next (Position : Cursor) return Cursor; + -- Returns a cursor that designates the node that follows the current one + -- designated by Position. If Position designates the last node in its + -- bucket, the operation calls Hash to compute the index of this bucket, + -- and searches the buckets array for the first non-empty bucket, starting + -- from that index; otherwise, it simply follows the link to the next node + -- in the same bucket. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Find (Container : Map; Key : Key_Type) return Cursor; + -- Searches for Key in the map. Find calls Hash to determine the key's + -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare + -- Key to each key in the bucket. If the search succeeds, Find returns a + -- cursor designating the matching node; otherwise, it returns No_Element. + + function Contains (Container : Map; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + function Element (Container : Map; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) + + function Equivalent_Keys (Left, Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Keys with the keys of the nodes + -- designated by cursors Left and Right. + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; + -- Returns the result of calling Equivalent_Keys with key of the node + -- designated by Left and key Right. + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Keys with key Left and the node + -- designated by Right. + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + -- Calls Process for each node in the map + + function Iterate (Container : Map) + return Map_Iterator_Interfaces.Forward_Iterator'class; + +private + pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Key_Access is access Key_Type; + type Element_Access is access all Element_Type; + + type Node_Type is limited record + Key : Key_Access; + Element : Element_Access; + Next : Node_Access; + end record; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); + + type Map is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + overriding procedure Adjust (Container : in out Map); + + overriding procedure Finalize (Container : in out Map); + + use HT_Types, HT_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_Access; + Node : Node_Access; + Position : Hash_Type := Hash_Type'Last; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); + + No_Element : constant Cursor := + (Container => null, Node => null, Position => Hash_Type'Last); + + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Indefinite_Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cihase.adb b/gcc/ada/libgnat/a-cihase.adb new file mode 100644 index 0000000..af865e2 --- /dev/null +++ b/gcc/ada/libgnat/a-cihase.adb @@ -0,0 +1,2401 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Hashed_Sets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Assign (Node : Node_Access; Item : Element_Type); + pragma Inline (Assign); + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + procedure Free (X : in out Node_Access); + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + + function Is_In + (HT : aliased in out Hash_Table_Type; + Key : Node_Access) return Boolean; + pragma Inline (Is_In); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Node_Access; + pragma Inline (Read_Node); + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + package HT_Ops is new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Element_Keys is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); + + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); + + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Set) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : Node_Access; Item : Element_Type) is + X : Element_Access := Node.Element; + + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end Assign; + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + else + Target.Clear; + Target.Union (Source); + end if; + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Set) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + begin + HT_Ops.Clear (Container.HT); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + HT : Hash_Table_Type renames Position.Container.all.HT; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Set; + Capacity : Count_Type := 0) return Set + is + C : Count_Type; + + begin + if Capacity < Source.Length then + if Checks and then Capacity /= 0 then + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + C := Source.Length; + else + C := Capacity; + end if; + + return Target : Set do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + E : Element_Access := new Element_Type'(Source.Element.all); + begin + return new Node_Type'(Element => E, Next => null); + exception + when others => + Free_Element (E); + raise; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + + if Checks and then X = null then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Free (X); + end Delete; + + procedure Delete + (Container : in out Set; + Position : in out Cursor) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + TC_Check (Container.HT.TC); + + pragma Assert (Vet (Position), "Position cursor is bad"); + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); + Position.Container := null; + end Delete; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference + (Target : in out Set; + Source : Set) + is + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; + Tgt_Node : Node_Access; + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Src_HT.Length = 0 then + return; + end if; + + TC_Check (Target.HT.TC); + + if Src_HT.Length < Target.HT.Length then + declare + Src_Node : Node_Access; + + begin + Src_Node := HT_Ops.First (Src_HT); + while Src_Node /= null loop + Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all); + + if Tgt_Node /= null then + HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); + Free (Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Src_HT, Src_Node); + end loop; + end; + + else + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Src_HT, Tgt_Node) then + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; + + else + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + end if; + end loop; + end if; + end Difference; + + function Difference (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Left.Length = 0 then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Length := 0; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right_HT, L_Node) then + declare + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + Indx : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); + + Bucket : Node_Access renames Buckets (Indx); + Src : Element_Type renames L_Node.Element.all; + Tgt : Element_Access := new Element_Type'(Src); + + begin + Bucket := new Node_Type'(Tgt, Bucket); + + exception + when others => + Free_Element (Tgt); + raise; + end; + + Length := Length + 1; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left.HT); + + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor of equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + -- handle dangling reference + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + return Position.Node.Element.all; + end Element; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + begin + return Is_Equivalent (Left.HT, Right.HT); + end Equivalent_Sets; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + if Checks and then Left.Node.Element = null then + raise Program_Error with + "Left cursor of Equivalent_Elements is bad"; + end if; + + if Checks and then Right.Node.Element = null then + raise Program_Error with + "Right cursor of Equivalent_Elements is bad"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + + -- AI05-0022 requires that a container implementation detect element + -- tampering by a generic actual subprogram. However, the following case + -- falls outside the scope of that AI. Randy Brukardt explained on the + -- ARG list on 2013/02/07 that: + + -- (Begin Quote): + -- But for an operation like "<" [the ordered set analog of + -- Equivalent_Elements], there is no need to "dereference" a cursor + -- after the call to the generic formal parameter function, so nothing + -- bad could happen if tampering is undetected. And the operation can + -- safely return a result without a problem even if an element is + -- deleted from the container. + -- (End Quote). + + return Equivalent_Elements + (Left.Node.Element.all, + Right.Node.Element.all); + end Equivalent_Elements; + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean + is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if Checks and then Left.Node.Element = null then + raise Program_Error with + "Left cursor of Equivalent_Elements is bad"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); + + return Equivalent_Elements (Left.Node.Element.all, Right); + end Equivalent_Elements; + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean + is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + if Checks and then Right.Node.Element = null then + raise Program_Error with + "Right cursor of Equivalent_Elements is bad"; + end if; + + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + + return Equivalent_Elements (Left, Right.Node.Element.all); + end Equivalent_Elements; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean + is + begin + return Equivalent_Elements (Key, Node.Element.all); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Set) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.HT.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Element_Keys.Find (HT, Item); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element.all); + + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + loop + if R_Node = null then + return False; + end if; + + if L_Node.Element.all = R_Node.Element.all then + return True; + end if; + + R_Node := Next (R_Node); + end loop; + end Find_Equal_Key; + + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element.all); + + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + loop + if R_Node = null then + return False; + end if; + + if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then + return True; + end if; + + R_Node := Next (R_Node); + end loop; + end Find_Equivalent_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + Node : constant Node_Access := HT_Ops.First (Container.HT); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end First; + + function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X = null then + return; + end if; + + X.Next := X; -- detect mischief (in Vet) + + begin + Free_Element (X.Element); + + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Element.all); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + X : Element_Access; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.HT.TC); + + X := Position.Node.Element; + + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Position.Node.Element := new Element_Type'(New_Item); + end; + + Free_Element (X); + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert (Container.HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + Element : Element_Access := new Element_Type'(New_Item); + + begin + return new Node_Type'(Element, Next); + + exception + when others => + Free_Element (Element); + raise; + end New_Node; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, New_Item, Node, Inserted); + + if Inserted and then HT.Length > HT_Ops.Capacity (HT) then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + end Insert; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Set; + Source : Set) + is + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; + Tgt_Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + TC_Check (Target.HT.TC); + + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Src_HT, Tgt_Node) then + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + + else + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; + end if; + end loop; + end Intersection; + + function Intersection (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Left; + end if; + + Length := Count_Type'Min (Left.Length, Right.Length); + + if Length = 0 then + return Empty_Set; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Length := 0; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + begin + if Is_In (Right_HT, L_Node) then + declare + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + Indx : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); + + Bucket : Node_Access renames Buckets (Indx); + + Src : Element_Type renames L_Node.Element.all; + Tgt : Element_Access := new Element_Type'(Src); + + begin + Bucket := new Node_Type'(Tgt, Bucket); + + exception + when others => + Free_Element (Tgt); + raise; + end; + + Length := Length + 1; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left.HT); + + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.HT.Length = 0; + end Is_Empty; + + ----------- + -- Is_In -- + ----------- + + function Is_In + (HT : aliased in out Hash_Table_Type; + Key : Node_Access) return Boolean + is + begin + return Element_Keys.Find (HT, Key.Element.all) /= null; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Subset : Set; + Of_Set : Set) return Boolean + is + Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT; + Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT; + Subset_Node : Node_Access; + + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + Subset_Node := HT_Ops.First (Subset_HT); + while Subset_Node /= null loop + if not Is_In (Of_Set_HT, Subset_Node) then + return False; + end if; + + Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node); + end loop; + + return True; + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Iterate (Container.HT); + end Iterate; + + function Iterate (Container : Set) + return Set_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access) + do + Busy (Container.HT.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.HT.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = null then + return No_Element; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "bad cursor in Next"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + HT : Hash_Table_Type renames Position.Container.HT; + Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Left_Node : Node_Access; + + begin + if Right.Length = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + Left_Node := HT_Ops.First (Left_HT); + while Left_Node /= null loop + if Is_In (Right_HT, Left_Node) then + return True; + end if; + + Left_Node := HT_Ops.Next (Left_HT, Left_Node); + end loop; + + return False; + end Overlap; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "bad cursor in Query_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + HT : Hash_Table_Type renames + Position.Container'Unrestricted_Access.all.HT; + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + Process (Position.Node.Element.all); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); + begin + return new Node_Type'(X, null); + exception + when others => + Free_Element (X); + raise; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + is + Node : constant Node_Access := + Element_Keys.Find (Container.HT, New_Item); + + X : Element_Access; + pragma Warnings (Off, X); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + TE_Check (Container.HT.TC); + + X := Node.Element; + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(New_Item); + end; + + Free_Element (X); + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "bad cursor in Replace_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Replace_Element (Container.HT, Position.Node, New_Item); + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Set; + Source : Set) + is + Tgt_HT : Hash_Table_Type renames Target.HT; + Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + TC_Check (Tgt_HT.TC); + + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Tgt_HT) then + HT_Ops.Reserve_Capacity (Tgt_HT, N); + end if; + end; + + if Target.Length = 0 then + Iterate_Source_When_Empty_Target : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element.all; + B : Buckets_Type renames Tgt_HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Tgt_HT.Length; + + begin + declare + X : Element_Access := new Element_Type'(E); + begin + B (J) := new Node_Type'(X, B (J)); + exception + when others => + Free_Element (X); + raise; + end; + + N := N + 1; + end Process; + + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. + + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Source_When_Empty_Target + + begin + Iterate (Src_HT); + end Iterate_Source_When_Empty_Target; + + else + Iterate_Source : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element.all; + B : Buckets_Type renames Tgt_HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Tgt_HT.Length; + + begin + if B (J) = null then + declare + X : Element_Access := new Element_Type'(E); + begin + B (J) := new Node_Type'(X, null); + exception + when others => + Free_Element (X); + raise; + end; + + N := N + 1; + + elsif Equivalent_Elements (E, B (J).Element.all) then + declare + X : Node_Access := B (J); + begin + B (J) := B (J).Next; + N := N - 1; + Free (X); + end; + + else + declare + Prev : Node_Access := B (J); + Curr : Node_Access := Prev.Next; + + begin + while Curr /= null loop + if Equivalent_Elements (E, Curr.Element.all) then + Prev.Next := Curr.Next; + N := N - 1; + Free (Curr); + return; + end if; + + Prev := Curr; + Curr := Prev.Next; + end loop; + + declare + X : Element_Access := new Element_Type'(E); + begin + B (J) := new Node_Type'(X, B (J)); + exception + when others => + Free_Element (X); + raise; + end; + + N := N + 1; + end; + end if; + end Process; + + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. + + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Source + + begin + Iterate (Src_HT); + end Iterate_Source; + end if; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Length := 0; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right_HT, L_Node) then + declare + E : Element_Type renames L_Node.Element.all; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); + + begin + declare + X : Element_Access := new Element_Type'(E); + begin + Buckets (J) := new Node_Type'(X, Buckets (J)); + exception + when others => + Free_Element (X); + raise; + end; + + Length := Length + 1; + end; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left_HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + Iterate_Right : declare + procedure Process (R_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (R_Node : Node_Access) is + begin + if not Is_In (Left_HT, R_Node) then + declare + E : Element_Type renames R_Node.Element.all; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); + + begin + declare + X : Element_Access := new Element_Type'(E); + begin + Buckets (J) := new Node_Type'(X, Buckets (J)); + exception + when others => + Free_Element (X); + raise; + end; + + Length := Length + 1; + end; + end if; + end Process; + + -- Start of processing for Iterate_Right + + begin + Iterate (Right_HT); + + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Right; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + HT : Hash_Table_Type; + Node : Node_Access; + Inserted : Boolean; + pragma Unreferenced (Node, Inserted); + begin + Insert (HT, New_Item, Node, Inserted); + return Set'(Controlled with HT); + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union + (Target : in out Set; + Source : Set) + is + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + Src : Element_Type renames Src_Node.Element.all; + + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + Tgt : Element_Access := new Element_Type'(Src); + begin + return new Node_Type'(Tgt, Next); + exception + when others => + Free_Element (Tgt); + raise; + end New_Node; + + Tgt_Node : Node_Access; + Success : Boolean; + pragma Unreferenced (Tgt_Node, Success); + + -- Start of processing for Process + + begin + Insert (Target.HT, Src, Tgt_Node, Success); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Target.HT.TC); + + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Target.HT) then + HT_Ops.Reserve_Capacity (Target.HT, N); + end if; + end; + + Iterate (Source.HT); + end Union; + + function Union (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; + Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Left; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + Src : Element_Type renames L_Node.Element.all; + J : constant Hash_Type := Hash (Src) mod Buckets'Length; + Bucket : Node_Access renames Buckets (J); + Tgt : Element_Access := new Element_Type'(Src); + begin + Bucket := new Node_Type'(Tgt, Bucket); + exception + when others => + Free_Element (Tgt); + raise; + end Process; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Left + + begin + Iterate (Left_HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + Length := Left.Length; + + Iterate_Right : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + Src : Element_Type renames Src_Node.Element.all; + Idx : constant Hash_Type := Hash (Src) mod Buckets'Length; + + Tgt_Node : Node_Access := Buckets (Idx); + + begin + while Tgt_Node /= null loop + if Equivalent_Elements (Src, Tgt_Node.Element.all) then + return; + end if; + Tgt_Node := Next (Tgt_Node); + end loop; + + declare + Tgt : Element_Access := new Element_Type'(Src); + begin + Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx)); + exception + when others => + Free_Element (Tgt); + raise; + end; + + Length := Length + 1; + end Process; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Right + + begin + Iterate (Right.HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Right; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Union; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + if Position.Node.Element = null then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Element_Keys.Checked_Index + (HT, + Position.Node.Element.all)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + declare + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Key : Key_Type) + is + X : Node_Access; + + begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + + if Checks and then X = null then + raise Constraint_Error with "key not in set"; + end if; + + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in set"; + end if; + + return Node.Element.all; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all)); + end Equivalent_Key_Node; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Key : Key_Type) + is + X : Node_Access; + begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then Hash (Key (Control.Old_Pos)) /= Control.Old_Hash + then + HT_Ops.Delete_Node_At_Index + (Control.Container.HT, Control.Index, Control.Old_Pos.Node); + raise Program_Error; + end if; + + Control.Container := null; + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + + return Key (Position.Node.Element.all); + end Key; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in function Reference_Preserving_Key"); + + declare + HT : Hash_Table_Type renames Container.HT; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => + (Controlled with + HT.TC'Unrestricted_Access, + Container => Container'Access, + Index => HT_Ops.Index (HT, Position.Node), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) + do + Lock (HT.TC); + end return; + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + declare + HT : Hash_Table_Type renames Container.HT; + P : constant Cursor := Find (Container, Key); + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Access, + Control => + (Controlled with + HT.TC'Unrestricted_Access, + Container => Container'Access, + Index => HT_Ops.Index (HT, P.Node), + Old_Pos => P, + Old_Hash => Hash (Key))) + do + Lock (HT.TC); + end return; + end; + end Reference_Preserving_Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container.HT, Node, New_Item); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)) + is + HT : Hash_Table_Type renames Container.HT; + Indx : Hash_Type; + + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then + (Position.Node.Element = null + or else Position.Node.Next = Position.Node) + then + raise Program_Error with "Position cursor is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + if Checks and then + (HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0) + then + raise Program_Error with "Position cursor is bad (set is empty)"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in Update_Element_Preserving_Key"); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + E : Element_Type renames Position.Node.Element.all; + K : constant Key_Type := Key (E); + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + Indx := HT_Ops.Index (HT, Position.Node); + Process (E); + + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + if HT.Buckets (Indx) = Position.Node then + HT.Buckets (Indx) := Position.Node.Next; + + else + declare + Prev : Node_Access := HT.Buckets (Indx); + + begin + while Prev.Next /= Position.Node loop + Prev := Prev.Next; + + if Checks and then Prev = null then + raise Program_Error with + "Position cursor is bad (node not found)"; + end if; + end loop; + + Prev.Next := Position.Node.Next; + end; + end if; + + HT.Length := HT.Length - 1; + + declare + X : Node_Access := Position.Node; + + begin + Free (X); + end; + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + end Generic_Keys; + +end Ada.Containers.Indefinite_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cihase.ads b/gcc/ada/libgnat/a-cihase.ads new file mode 100644 index 0000000..4529a02 --- /dev/null +++ b/gcc/ada/libgnat/a-cihase.ads @@ -0,0 +1,595 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Hash_Tables; +with Ada.Containers.Helpers; +private with Ada.Streams; +private with Ada.Finalization; + +generic + type Element_Type (<>) is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + with function Equivalent_Elements (Left, Right : Element_Type) + return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Hashed_Sets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type Set is tagged private + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + -- Set objects declared without an initialization expression are + -- initialized to the value Empty_Set. + + No_Element : constant Cursor; + -- Cursor objects declared without an initialization expression are + -- initialized to the value No_Element. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + -- For each element in Left, set equality attempts to find the equal + -- element in Right; if a search fails, then set equality immediately + -- returns False. The search works by calling Hash to find the bucket in + -- the Right set that corresponds to the Left element. If the bucket is + -- non-empty, the search calls the generic formal element equality operator + -- to compare the element (in Left) to the element of each node in the + -- bucket (in Right); the search terminates when a matching node in the + -- bucket is found, or the nodes in the bucket are exhausted. (Note that + -- element equality is called here, not Equivalent_Elements. Set equality + -- is the only operation in which element equality is used. Compare set + -- equality to Equivalent_Sets, which does call Equivalent_Elements.) + + function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, with the difference that the element in Left is + -- compared to the elements in Right using the generic formal + -- Equivalent_Elements operation instead of element equality. + + function To_Set (New_Item : Element_Type) return Set; + -- Constructs a singleton set comprising New_Element. To_Set calls Hash to + -- determine the bucket for New_Item. + + function Capacity (Container : Set) return Count_Type; + -- Returns the current capacity of the set. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing element in + -- order to compute the new index), and then the old buckets array is + -- deallocated. + + function Length (Container : Set) return Count_Type; + -- Returns the number of items in the set + + function Is_Empty (Container : Set) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Set); + -- Removes all of the items from the set + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + -- If New_Item is equivalent (as determined by calling Equivalent_Elements) + -- to the element of the node designated by Position, then New_Element is + -- assigned to that element. Otherwise, it calls Hash to determine the + -- bucket for New_Item. If the bucket is not empty, then it calls + -- Equivalent_Elements for each node in that bucket to determine whether + -- New_Item is equivalent to an element in that bucket. If + -- Equivalent_Elements returns True then Program_Error is raised (because + -- an element may appear only once in the set); otherwise, New_Item is + -- assigned to the node designated by Position, and the node is moved to + -- its new bucket. + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- Calls Process with the element (having only a constant view) of the node + -- designated by the cursor. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + -- Clears Target (if it's not empty), and then moves (not copies) the + -- buckets array and nodes from Source to Target. + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + -- Conditionally inserts New_Item into the set. If New_Item is already in + -- the set, then Inserted returns False and Position designates the node + -- containing the existing element (which is not modified). If New_Item is + -- not already in the set, then Inserted returns True and Position + -- designates the newly-inserted node containing New_Item. The search for + -- an existing element works as follows. Hash is called to determine + -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements + -- is called to compare New_Item to the element of each node in that + -- bucket. If the bucket is empty, or there were no equivalent elements in + -- the bucket, the search "fails" and the New_Item is inserted in the set + -- (and Inserted returns True); otherwise, the search "succeeds" (and + -- Inserted returns False). + + procedure Insert (Container : in out Set; New_Item : Element_Type); + -- Attempts to insert New_Item into the set, performing the usual insertion + -- search (which involves calling both Hash and Equivalent_Elements); if + -- the search succeeds (New_Item is equivalent to an element already in the + -- set, and so was not inserted), then this operation raises + -- Constraint_Error. (This version of Insert is similar to Replace, but + -- having the opposite exception behavior. It is intended for use when you + -- want to assert that the item is not already in the set.) + + procedure Include (Container : in out Set; New_Item : Element_Type); + -- Attempts to insert New_Item into the set. If an element equivalent to + -- New_Item is already in the set (the insertion search succeeded, and + -- hence New_Item was not inserted), then the value of New_Item is assigned + -- to the existing element. (This insertion operation only raises an + -- exception if cursor tampering occurs. It is intended for use when you + -- want to insert the item in the set, and you don't care whether an + -- equivalent element is already present.) + + procedure Replace (Container : in out Set; New_Item : Element_Type); + -- Searches for New_Item in the set; if the search fails (because an + -- equivalent element was not in the set), then it raises + -- Constraint_Error. Otherwise, the existing element is assigned the value + -- New_Item. (This is similar to Insert, but with the opposite exception + -- behavior. It is intended for use when you want to assert that the item + -- is already in the set.) + + procedure Exclude (Container : in out Set; Item : Element_Type); + -- Searches for Item in the set, and if found, removes its node from the + -- set and then deallocates it. The search works as follows. The operation + -- calls Hash to determine the item's bucket; if the bucket is not empty, + -- it calls Equivalent_Elements to compare Item to the element of each node + -- in the bucket. (This is the deletion analog of Include. It is intended + -- for use when you want to remove the item from the set, but don't care + -- whether the item is already in the set.) + + procedure Delete (Container : in out Set; Item : Element_Type); + -- Searches for Item in the set (which involves calling both Hash and + -- Equivalent_Elements). If the search fails, then the operation raises + -- Constraint_Error. Otherwise it removes the node from the set and then + -- deallocates it. (This is the deletion analog of non-conditional + -- Insert. It is intended for use when you want to assert that the item is + -- already in the set.) + + procedure Delete (Container : in out Set; Position : in out Cursor); + -- Removes the node designated by Position from the set, and then + -- deallocates the node. The operation calls Hash to determine the bucket, + -- and then compares Position to each node in the bucket until there's a + -- match (it does not call Equivalent_Elements). + + procedure Union (Target : in out Set; Source : Set); + -- The operation first calls Reserve_Capacity if the current capacity is + -- less than the sum of the lengths of Source and Target. It then iterates + -- over the Source set, and conditionally inserts each element into Target. + + function Union (Left, Right : Set) return Set; + -- The operation first copies the Left set to the result, and then iterates + -- over the Right set to conditionally insert each element into the result. + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + -- Iterates over the Target set (calling First and Next), calling Find to + -- determine whether the element is in Source. If an equivalent element is + -- not found in Source, the element is deleted from Target. + + function Intersection (Left, Right : Set) return Set; + -- Iterates over the Left set, calling Find to determine whether the + -- element is in Right. If an equivalent element is found, it is inserted + -- into the result set. + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + -- Iterates over the Source (calling First and Next), calling Find to + -- determine whether the element is in Target. If an equivalent element is + -- found, it is deleted from Target. + + function Difference (Left, Right : Set) return Set; + -- Iterates over the Left set, calling Find to determine whether the + -- element is in the Right set. If an equivalent element is not found, the + -- element is inserted into the result set. + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + -- The operation first calls Reserve_Capacity if the current capacity is + -- less than the sum of the lengths of Source and Target. It then iterates + -- over the Source set, searching for the element in Target (calling Hash + -- and Equivalent_Elements). If an equivalent element is found, it is + -- removed from Target; otherwise it is inserted into Target. + + function Symmetric_Difference (Left, Right : Set) return Set; + -- The operation first iterates over the Left set. It calls Find to + -- determine whether the element is in the Right set. If no equivalent + -- element is found, the element from Left is inserted into the result. The + -- operation then iterates over the Right set, to determine whether the + -- element is in the Left set. If no equivalent element is found, the Right + -- element is inserted into the result. + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + -- Iterates over the Left set (calling First and Next), calling Find to + -- determine whether the element is in the Right set. If an equivalent + -- element is found, the operation immediately returns True. The operation + -- returns False if the iteration over Left terminates without finding any + -- equivalent element in Right. + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + -- Iterates over Subset (calling First and Next), calling Find to determine + -- whether the element is in Of_Set. If no equivalent element is found in + -- Of_Set, the operation immediately returns False. The operation returns + -- True if the iteration over Subset terminates without finding an element + -- not in Of_Set (that is, every element in Subset is equivalent to an + -- element in Of_Set). + + function First (Container : Set) return Cursor; + -- Returns a cursor that designates the first non-empty bucket, by + -- searching from the beginning of the buckets array. + + function Next (Position : Cursor) return Cursor; + -- Returns a cursor that designates the node that follows the current one + -- designated by Position. If Position designates the last node in its + -- bucket, the operation calls Hash to compute the index of this bucket, + -- and searches the buckets array for the first non-empty bucket, starting + -- from that index; otherwise, it simply follows the link to the next node + -- in the same bucket. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Find (Container : Set; Item : Element_Type) return Cursor; + -- Searches for Item in the set. Find calls Hash to determine the item's + -- bucket; if the bucket is not empty, it calls Equivalent_Elements to + -- compare Item to each element in the bucket. If the search succeeds, Find + -- returns a cursor designating the node containing the equivalent element; + -- otherwise, it returns No_Element. + + function Contains (Container : Set; Item : Element_Type) return Boolean; + -- Equivalent to Find (Container, Item) /= No_Element + + function Equivalent_Elements (Left, Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Elements with the elements of + -- the nodes designated by cursors Left and Right. + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean; + -- Returns the result of calling Equivalent_Elements with element of the + -- node designated by Left and element Right. + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Elements with element Left and + -- the element of the node designated by Right. + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + -- Calls Process for each node in the set + + function Iterate (Container : Set) + return Set_Iterator_Interfaces.Forward_Iterator'Class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + package Generic_Keys is + + function Key (Position : Cursor) return Key_Type; + -- Applies generic formal operation Key to the element of the node + -- designated by Position. + + function Element (Container : Set; Key : Key_Type) return Element_Type; + -- Searches (as per the key-based Find) for the node containing Key, and + -- returns the associated element. + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + -- Searches (as per the key-based Find) for the node containing Key, and + -- then replaces the element of that node (as per the element-based + -- Replace_Element). + + procedure Exclude (Container : in out Set; Key : Key_Type); + -- Searches for Key in the set, and if found, removes its node from the + -- set and then deallocates it. The search works by first calling Hash + -- (on Key) to determine the bucket; if the bucket is not empty, it + -- calls Equivalent_Keys to compare parameter Key to the value of + -- generic formal operation Key applied to element of each node in the + -- bucket. + + procedure Delete (Container : in out Set; Key : Key_Type); + -- Deletes the node containing Key as per Exclude, with the difference + -- that Constraint_Error is raised if Key is not found. + + function Find (Container : Set; Key : Key_Type) return Cursor; + -- Searches for the node containing Key, and returns a cursor + -- designating the node. The search works by first calling Hash (on Key) + -- to determine the bucket. If the bucket is not empty, the search + -- compares Key to the element of each node in the bucket, and returns + -- the matching node. The comparison itself works by applying the + -- generic formal Key operation to the element of the node, and then + -- calling generic formal operation Equivalent_Keys. + + function Contains (Container : Set; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + -- Calls Process with the element of the node designated by Position, + -- but with the restriction that the key-value of the element is not + -- modified. The operation first makes a copy of the value returned by + -- applying generic formal operation Key on the element of the node, and + -- then calls Process with the element. The operation verifies that the + -- key-part has not been modified by calling generic formal operation + -- Equivalent_Keys to compare the saved key-value to the value returned + -- by applying generic formal operation Key to the post-Process value of + -- element. If the key values compare equal then the operation + -- completes. Otherwise, the node is removed from the map and + -- Program_Error is raised. + + type Reference_Type (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type; + + private + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + package Impl is new Helpers.Generic_Implementation; + + type Reference_Control_Type is + new Impl.Reference_Control_Type with + record + Container : Set_Access; + Index : Hash_Type; + Old_Pos : Cursor; + Old_Hash : Hash_Type; + end record; + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + use Ada.Streams; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + end Generic_Keys; + +private + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Element_Access is access all Element_Type; + + type Node_Type is limited record + Element : Element_Access; + Next : Node_Access; + end record; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); + + type Set is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + overriding procedure Adjust (Container : in out Set); + + overriding procedure Finalize (Container : in out Set); + + use HT_Types, HT_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); + + No_Element : constant Cursor := (Container => null, Node => null); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record + Container : Set_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Indefinite_Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cimutr.adb b/gcc/ada/libgnat/a-cimutr.adb new file mode 100644 index 0000000..562788f --- /dev/null +++ b/gcc/ada/libgnat/a-cimutr.adb @@ -0,0 +1,2698 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Multiway_Trees is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + -------------------- + -- Root_Iterator -- + -------------------- + + type Root_Iterator is abstract new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with + record + Container : Tree_Access; + Subtree : Tree_Node_Access; + end record; + + overriding procedure Finalize (Object : in out Root_Iterator); + + ----------------------- + -- Subtree_Iterator -- + ----------------------- + + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; + + overriding function Next + (Object : Subtree_Iterator; + Position : Cursor) return Cursor; + + --------------------- + -- Child_Iterator -- + --------------------- + + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record; + + overriding function First (Object : Child_Iterator) return Cursor; + + overriding function Next + (Object : Child_Iterator; + Position : Cursor) return Cursor; + + overriding function Last (Object : Child_Iterator) return Cursor; + + overriding function Previous + (Object : Child_Iterator; + Position : Cursor) return Cursor; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Root_Node (Container : Tree) return Tree_Node_Access; + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + procedure Deallocate_Node (X : in out Tree_Node_Access); + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type); + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type); + + function Equal_Children + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + function Equal_Subtree + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type); + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type); + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Child_Count (Children : Children_Type) return Count_Type; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type; + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean; + + procedure Remove_Subtree (Subtree : Tree_Node_Access); + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Tree) return Boolean is + begin + return Equal_Children (Root_Node (Left), Root_Node (Right)); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Tree) is + Source : constant Children_Type := Container.Root.Children; + Source_Count : constant Count_Type := Container.Count; + Target_Count : Count_Type; + + begin + -- We first restore the target container to its default-initialized + -- state, before we attempt any allocation, to ensure that invariants + -- are preserved in the event that the allocation fails. + + Container.Root.Children := Children_Type'(others => null); + Zero_Counts (Container.TC); + Container.Count := 0; + + -- Copy_Children returns a count of the number of nodes that it + -- allocates, but it works by incrementing the value that is passed in. + -- We must therefore initialize the count value before calling + -- Copy_Children. + + Target_Count := 0; + + -- Now we attempt the allocation of subtrees. The invariants are + -- satisfied even if the allocation fails. + + Copy_Children (Source, Root_Node (Container), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Container.Count := Source_Count; + end Adjust; + + ------------------- + -- Ancestor_Find -- + ------------------- + + function Ancestor_Find + (Position : Cursor; + Item : Element_Type) return Cursor + is + R, N : Tree_Node_Access; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Commented-out pending ARG ruling. ??? + + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then + -- raise Program_Error with "Position cursor not in container"; + -- end if; + + -- AI-0136 says to raise PE if Position equals the root node. This does + -- not seem correct, as this value is just the limiting condition of the + -- search. For now we omit this check pending a ruling from the ARG.??? + + -- if Checks and then Is_Root (Position) then + -- raise Program_Error with "Position cursor designates root"; + -- end if; + + R := Root_Node (Position.Container.all); + N := Position.Node; + while N /= R loop + if N.Element.all = Item then + return Cursor'(Position.Container, N); + end if; + + N := N.Parent; + end loop; + + return No_Element; + end Ancestor_Find; + + ------------------ + -- Append_Child -- + ------------------ + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + Element : Element_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + + begin + Element := new Element_Type'(New_Item); + end; + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => Element, + others => <>); + + Last := First; + + for J in Count_Type'(2) .. Count loop + + -- Reclaim other nodes if Storage_Error. ??? + + Element := new Element_Type'(New_Item); + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => Element, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => null); -- null means "insert at end of list" + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Container.Count := Container.Count + Count; + end Append_Child; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Tree; Source : Tree) is + Source_Count : constant Count_Type := Source.Count; + Target_Count : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; -- checks busy bit + + -- Copy_Children returns the number of nodes that it allocates, but it + -- does this by incrementing the count value passed in, so we must + -- initialize the count before calling Copy_Children. + + Target_Count := 0; + + -- Note that Copy_Children inserts the newly-allocated children into + -- their parent list only after the allocation of all the children has + -- succeeded. This preserves invariants even if the allocation fails. + + Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Target.Count := Source_Count; + end Assign; + + ----------------- + -- Child_Count -- + ----------------- + + function Child_Count (Parent : Cursor) return Count_Type is + begin + if Parent = No_Element then + return 0; + else + return Child_Count (Parent.Node.Children); + end if; + end Child_Count; + + function Child_Count (Children : Children_Type) return Count_Type is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 0; + Node := Children.First; + while Node /= null loop + Result := Result + 1; + Node := Node.Next; + end loop; + + return Result; + end Child_Count; + + ----------------- + -- Child_Depth -- + ----------------- + + function Child_Depth (Parent, Child : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Child = No_Element then + raise Constraint_Error with "Child cursor has no element"; + end if; + + if Checks and then Parent.Container /= Child.Container then + raise Program_Error with "Parent and Child in different containers"; + end if; + + Result := 0; + N := Child.Node; + while N /= Parent.Node loop + Result := Result + 1; + N := N.Parent; + + if Checks and then N = null then + raise Program_Error with "Parent is not ancestor of Child"; + end if; + end loop; + + return Result; + end Child_Depth; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Tree) is + Container_Count : Count_Type; + Children_Count : Count_Type; + + begin + TC_Check (Container.TC); + + -- We first set the container count to 0, in order to preserve + -- invariants in case the deallocation fails. (This works because + -- Deallocate_Children immediately removes the children from their + -- parent, and then does the actual deallocation.) + + Container_Count := Container.Count; + Container.Count := 0; + + -- Deallocate_Children returns the number of nodes that it deallocates, + -- but it does this by incrementing the count value that is passed in, + -- so we must first initialize the count return value before calling it. + + Children_Count := 0; + + -- See comment above. Deallocate_Children immediately removes the + -- children list from their parent node (here, the root of the tree), + -- and only after that does it attempt the actual deallocation. So even + -- if the deallocation fails, the representation invariants + + Deallocate_Children (Root_Node (Container), Children_Count); + pragma Assert (Children_Count = Container_Count); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Tree; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Tree) return Tree is + begin + return Target : Tree do + Copy_Children + (Source => Source.Root.Children, + Parent => Root_Node (Target), + Count => Target.Count); + + pragma Assert (Target.Count = Source.Count); + end return; + end Copy; + + ------------------- + -- Copy_Children -- + ------------------- + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Parent /= null); + pragma Assert (Parent.Children.First = null); + pragma Assert (Parent.Children.Last = null); + + CC : Children_Type; + C : Tree_Node_Access; + + begin + -- We special-case the first allocation, in order to establish the + -- representation invariants for type Children_Type. + + C := Source.First; + + if C = null then + return; + end if; + + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.First, + Count => Count); + + CC.Last := CC.First; + + -- The representation invariants for the Children_Type list have been + -- established, so we can now copy the remaining children of Source. + + C := C.Next; + while C /= null loop + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.Last.Next, + Count => Count); + + CC.Last.Next.Prev := CC.Last; + CC.Last := CC.Last.Next; + + C := C.Next; + end loop; + + -- We add the newly-allocated children to their parent list only after + -- the allocation has succeeded, in order to preserve invariants of the + -- parent. + + Parent.Children := CC; + end Copy_Children; + + ------------------ + -- Copy_Subtree -- + ------------------ + + procedure Copy_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : Cursor) + is + Target_Subtree : Tree_Node_Access; + Target_Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Source = No_Element then + return; + end if; + + if Checks and then Is_Root (Source) then + raise Constraint_Error with "Source cursor designates root"; + end if; + + -- Copy_Subtree returns a count of the number of nodes that it + -- allocates, but it works by incrementing the value that is passed in. + -- We must therefore initialize the count value before calling + -- Copy_Subtree. + + Target_Count := 0; + + Copy_Subtree + (Source => Source.Node, + Parent => Parent.Node, + Target => Target_Subtree, + Count => Target_Count); + + pragma Assert (Target_Subtree /= null); + pragma Assert (Target_Subtree.Parent = Parent.Node); + pragma Assert (Target_Count >= 1); + + Insert_Subtree_Node + (Subtree => Target_Subtree, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Target.Count := Target.Count + Target_Count; + end Copy_Subtree; + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type) + is + E : constant Element_Access := new Element_Type'(Source.Element.all); + + begin + Target := new Tree_Node_Type'(Element => E, + Parent => Parent, + others => <>); + + Count := Count + 1; + + Copy_Children + (Source => Source.Children, + Parent => Target, + Count => Count); + end Copy_Subtree; + + ------------------------- + -- Deallocate_Children -- + ------------------------- + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Subtree /= null); + + CC : Children_Type := Subtree.Children; + C : Tree_Node_Access; + + begin + -- We immediately remove the children from their parent, in order to + -- preserve invariants in case the deallocation fails. + + Subtree.Children := Children_Type'(others => null); + + while CC.First /= null loop + C := CC.First; + CC.First := C.Next; + + Deallocate_Subtree (C, Count); + end loop; + end Deallocate_Children; + + --------------------- + -- Deallocate_Node -- + --------------------- + + procedure Deallocate_Node (X : in out Tree_Node_Access) is + procedure Free_Node is + new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access); + + -- Start of processing for Deallocate_Node + + begin + if X /= null then + Free_Element (X.Element); + Free_Node (X); + end if; + end Deallocate_Node; + + ------------------------ + -- Deallocate_Subtree -- + ------------------------ + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type) + is + begin + Deallocate_Children (Subtree, Count); + Deallocate_Node (Subtree); + Count := Count + 1; + end Deallocate_Subtree; + + --------------------- + -- Delete_Children -- + --------------------- + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor) + is + Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + TC_Check (Container.TC); + + -- Deallocate_Children returns a count of the number of nodes + -- that it deallocates, but it works by incrementing the + -- value that is passed in. We must therefore initialize + -- the count value before calling Deallocate_Children. + + Count := 0; + + Deallocate_Children (Parent.Node, Count); + pragma Assert (Count <= Container.Count); + + Container.Count := Container.Count - Count; + end Delete_Children; + + ----------------- + -- Delete_Leaf -- + ----------------- + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Checks and then not Is_Leaf (Position) then + raise Constraint_Error with "Position cursor does not designate leaf"; + end if; + + TC_Check (Container.TC); + + X := Position.Node; + Position := No_Element; + + -- Restore represention invariants before attempting the actual + -- deallocation. + + Remove_Subtree (X); + Container.Count := Container.Count - 1; + + -- It is now safe to attempt the deallocation. This leaf node has been + -- disassociated from the tree, so even if the deallocation fails, + -- representation invariants will remain satisfied. + + Deallocate_Node (X); + end Delete_Leaf; + + -------------------- + -- Delete_Subtree -- + -------------------- + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + Count : Count_Type; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + TC_Check (Container.TC); + + X := Position.Node; + Position := No_Element; + + -- Here is one case where a deallocation failure can result in the + -- violation of a representation invariant. We disassociate the subtree + -- from the tree now, but we only decrement the total node count after + -- we attempt the deallocation. However, if the deallocation fails, the + -- total node count will not get decremented. + + -- One way around this dilemma is to count the nodes in the subtree + -- before attempt to delete the subtree, but that is an O(n) operation, + -- so it does not seem worth it. + + -- Perhaps this is much ado about nothing, since the only way + -- deallocation can fail is if Controlled Finalization fails: this + -- propagates Program_Error so all bets are off anyway. ??? + + Remove_Subtree (X); + + -- Deallocate_Subtree returns a count of the number of nodes that it + -- deallocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Deallocate_Subtree. + + Count := 0; + + Deallocate_Subtree (X, Count); + pragma Assert (Count <= Container.Count); + + -- See comments above. We would prefer to do this sooner, but there's no + -- way to satisfy that goal without an potentially severe execution + -- penalty. + + Container.Count := Container.Count - Count; + end Delete_Subtree; + + ----------- + -- Depth -- + ----------- + + function Depth (Position : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + Result := 0; + N := Position.Node; + while N /= null loop + N := N.Parent; + Result := Result + 1; + end loop; + + return Result; + end Depth; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Node = Root_Node (Position.Container.all) + then + raise Program_Error with "Position cursor designates root"; + end if; + + return Position.Node.Element.all; + end Element; + + -------------------- + -- Equal_Children -- + -------------------- + + function Equal_Children + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + Left_Children : Children_Type renames Left_Subtree.Children; + Right_Children : Children_Type renames Right_Subtree.Children; + + L, R : Tree_Node_Access; + + begin + if Child_Count (Left_Children) /= Child_Count (Right_Children) then + return False; + end if; + + L := Left_Children.First; + R := Right_Children.First; + while L /= null loop + if not Equal_Subtree (L, R) then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + + return True; + end Equal_Children; + + ------------------- + -- Equal_Subtree -- + ------------------- + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean + is + begin + if Checks and then Left_Position = No_Element then + raise Constraint_Error with "Left cursor has no element"; + end if; + + if Checks and then Right_Position = No_Element then + raise Constraint_Error with "Right cursor has no element"; + end if; + + if Left_Position = Right_Position then + return True; + end if; + + if Is_Root (Left_Position) then + if not Is_Root (Right_Position) then + return False; + end if; + + return Equal_Children (Left_Position.Node, Right_Position.Node); + end if; + + if Is_Root (Right_Position) then + return False; + end if; + + return Equal_Subtree (Left_Position.Node, Right_Position.Node); + end Equal_Subtree; + + function Equal_Subtree + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + begin + if Left_Subtree.Element.all /= Right_Subtree.Element.all then + return False; + end if; + + return Equal_Children (Left_Subtree, Right_Subtree); + end Equal_Subtree; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Root_Iterator) is + begin + Unbusy (Object.Container.TC); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Tree; + Item : Element_Type) return Cursor + is + N : constant Tree_Node_Access := + Find_In_Children (Root_Node (Container), Item); + + begin + if N = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, N); + end Find; + + ----------- + -- First -- + ----------- + + overriding function First (Object : Subtree_Iterator) return Cursor is + begin + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; + end First; + + overriding function First (Object : Child_Iterator) return Cursor is + begin + return First_Child (Cursor'(Object.Container, Object.Subtree)); + end First; + + ----------------- + -- First_Child -- + ----------------- + + function First_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.First; + + if Node = null then + return No_Element; + end if; + + return Cursor'(Parent.Container, Node); + end First_Child; + + ------------------------- + -- First_Child_Element -- + ------------------------- + + function First_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (First_Child (Parent)); + end First_Child_Element; + + ---------------------- + -- Find_In_Children -- + ---------------------- + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + N, Result : Tree_Node_Access; + + begin + N := Subtree.Children.First; + while N /= null loop + Result := Find_In_Subtree (N, Item); + + if Result /= null then + return Result; + end if; + + N := N.Next; + end loop; + + return null; + end Find_In_Children; + + --------------------- + -- Find_In_Subtree -- + --------------------- + + function Find_In_Subtree + (Position : Cursor; + Item : Element_Type) return Cursor + is + Result : Tree_Node_Access; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Commented-out pending ruling from ARG. ??? + + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then + -- raise Program_Error with "Position cursor not in container"; + -- end if; + + if Is_Root (Position) then + Result := Find_In_Children (Position.Node, Item); + + else + Result := Find_In_Subtree (Position.Node, Item); + end if; + + if Result = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Result); + end Find_In_Subtree; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + begin + if Subtree.Element.all = Item then + return Subtree; + end if; + + return Find_In_Children (Subtree, Item); + end Find_In_Subtree; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position = No_Element then + return False; + end if; + + return Position.Node.Parent /= null; + end Has_Element; + + ------------------ + -- Insert_Child -- + ------------------ + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + + begin + Insert_Child (Container, Parent, Before, New_Item, Position, Count); + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + First : Tree_Node_Access; + Last : Tree_Node_Access; + Element : Element_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Parent cursor not parent of Before"; + end if; + end if; + + if Count = 0 then + Position := No_Element; -- Need ruling from ARG ??? + return; + end if; + + TC_Check (Container.TC); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + + begin + Element := new Element_Type'(New_Item); + end; + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => Element, + others => <>); + + Last := First; + for J in Count_Type'(2) .. Count loop + + -- Reclaim other nodes if Storage_Error. ??? + + Element := new Element_Type'(New_Item); + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => Element, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Container.Count := Container.Count + Count; + + Position := Cursor'(Parent.Container, First); + end Insert_Child; + + ------------------------- + -- Insert_Subtree_List -- + ------------------------- + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + pragma Assert (Parent /= null); + C : Children_Type renames Parent.Children; + + begin + -- This is a simple utility operation to insert a list of nodes (from + -- First..Last) as children of Parent. The Before node specifies where + -- the new children should be inserted relative to the existing + -- children. + + if First = null then + pragma Assert (Last = null); + return; + end if; + + pragma Assert (Last /= null); + pragma Assert (Before = null or else Before.Parent = Parent); + + if C.First = null then + C.First := First; + C.First.Prev := null; + C.Last := Last; + C.Last.Next := null; + + elsif Before = null then -- means "insert after existing nodes" + C.Last.Next := First; + First.Prev := C.Last; + C.Last := Last; + C.Last.Next := null; + + elsif Before = C.First then + Last.Next := C.First; + C.First.Prev := Last; + C.First := First; + C.First.Prev := null; + + else + Before.Prev.Next := First; + First.Prev := Before.Prev; + Last.Next := Before; + Before.Prev := Last; + end if; + end Insert_Subtree_List; + + ------------------------- + -- Insert_Subtree_Node -- + ------------------------- + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + begin + -- This is a simple wrapper operation to insert a single child into the + -- Parent's children list. + + Insert_Subtree_List + (First => Subtree, + Last => Subtree, + Parent => Parent, + Before => Before); + end Insert_Subtree_Node; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Tree) return Boolean is + begin + return Container.Root.Children.First = null; + end Is_Empty; + + ------------- + -- Is_Leaf -- + ------------- + + function Is_Leaf (Position : Cursor) return Boolean is + begin + if Position = No_Element then + return False; + end if; + + return Position.Node.Children.First = null; + end Is_Leaf; + + ------------------ + -- Is_Reachable -- + ------------------ + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean is + pragma Assert (From /= null); + pragma Assert (To /= null); + + N : Tree_Node_Access; + + begin + N := From; + while N /= null loop + if N = To then + return True; + end if; + + N := N.Parent; + end loop; + + return False; + end Is_Reachable; + + ------------- + -- Is_Root -- + ------------- + + function Is_Root (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + return Position = Root (Position.Container.all); + end Is_Root; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + Iterate_Children + (Container => Container'Unrestricted_Access, + Subtree => Root_Node (Container), + Process => Process); + end Iterate; + + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return Iterate_Subtree (Root (Container)); + end Iterate; + + ---------------------- + -- Iterate_Children -- + ---------------------- + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; + end Iterate_Children; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + Node : Tree_Node_Access; + + begin + -- This is a helper function to recursively iterate over all the nodes + -- in a subtree, in depth-first fashion. This particular helper just + -- visits the children of this subtree, not the root of the subtree node + -- itself. This is useful when starting from the ultimate root of the + -- entire tree (see Iterate), as that root does not have an element. + + Node := Subtree.Children.First; + while Node /= null loop + Iterate_Subtree (Container, Node, Process); + Node := Node.Next; + end loop; + end Iterate_Children; + + function Iterate_Children + (Container : Tree; + Parent : Cursor) + return Tree_Iterator_Interfaces.Reversible_Iterator'Class + is + C : constant Tree_Access := Container'Unrestricted_Access; + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= C then + raise Program_Error with "Parent cursor not in container"; + end if; + + return It : constant Child_Iterator := + Child_Iterator'(Limited_Controlled with + Container => C, + Subtree => Parent.Node) + do + Busy (C.TC); + end return; + end Iterate_Children; + + --------------------- + -- Iterate_Subtree -- + --------------------- + + function Iterate_Subtree + (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + C : constant Tree_Access := Position.Container; + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => Position.Container, + Subtree => Position.Node) + do + Busy (C.TC); + end return; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Position.Container.TC'Unrestricted_Access); + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + begin + -- This is a helper function to recursively iterate over all the nodes + -- in a subtree, in depth-first fashion. It first visits the root of the + -- subtree, then visits its children. + + Process (Cursor'(Container, Subtree)); + Iterate_Children (Container, Subtree, Process); + end Iterate_Subtree; + + ---------- + -- Last -- + ---------- + + overriding function Last (Object : Child_Iterator) return Cursor is + begin + return Last_Child (Cursor'(Object.Container, Object.Subtree)); + end Last; + + ---------------- + -- Last_Child -- + ---------------- + + function Last_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.Last; + + if Node = null then + return No_Element; + end if; + + return (Parent.Container, Node); + end Last_Child; + + ------------------------ + -- Last_Child_Element -- + ------------------------ + + function Last_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (Last_Child (Parent)); + end Last_Child_Element; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Tree; Source : in out Tree) is + Node : Tree_Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Target.Clear; -- checks busy bit + + Target.Root.Children := Source.Root.Children; + Source.Root.Children := Children_Type'(others => null); + + Node := Target.Root.Children.First; + while Node /= null loop + Node.Parent := Root_Node (Target); + Node := Node.Next; + end loop; + + Target.Count := Source.Count; + Source.Count := 0; + end Move; + + ---------- + -- Next -- + ---------- + + function Next + (Object : Subtree_Iterator; + Position : Cursor) return Cursor + is + Node : Tree_Node_Access; + + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; + + Node := Position.Node; + + if Node.Children.First /= null then + return Cursor'(Object.Container, Node.Children.First); + end if; + + while Node /= Object.Subtree loop + if Node.Next /= null then + return Cursor'(Object.Container, Node.Next); + end if; + + Node := Node.Parent; + end loop; + + return No_Element; + end Next; + + function Next + (Object : Child_Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; + + return Next_Sibling (Position); + end Next; + + ------------------ + -- Next_Sibling -- + ------------------ + + function Next_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Next = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Next); + end Next_Sibling; + + procedure Next_Sibling (Position : in out Cursor) is + begin + Position := Next_Sibling (Position); + end Next_Sibling; + + ---------------- + -- Node_Count -- + ---------------- + + function Node_Count (Container : Tree) return Count_Type is + begin + -- Container.Count is the number of nodes we have actually allocated. We + -- cache the value specifically so this Node_Count operation can execute + -- in O(1) time, which makes it behave similarly to how the Length + -- selector function behaves for other containers. + -- + -- The cached node count value only describes the nodes we have + -- allocated; the root node itself is not included in that count. The + -- Node_Count operation returns a value that includes the root node + -- (because the RM says so), so we must add 1 to our cached value. + + return 1 + Container.Count; + end Node_Count; + + ------------ + -- Parent -- + ------------ + + function Parent (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Parent = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Parent); + end Parent; + + ------------------- + -- Prepent_Child -- + ------------------- + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + Element : Element_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). We don't unsuppress the check on the + -- allocator in the loop below, because the one in this block would + -- have failed already. + + pragma Unsuppress (Accessibility_Check); + + begin + Element := new Element_Type'(New_Item); + end; + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => Element, + others => <>); + + Last := First; + + for J in Count_Type'(2) .. Count loop + + -- Reclaim other nodes if Storage_Error. ??? + + Element := new Element_Type'(New_Item); + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => Element, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => Parent.Node.Children.First); + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Container.Count := Container.Count + Count; + end Prepend_Child; + + -------------- + -- Previous -- + -------------- + + overriding function Previous + (Object : Child_Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong tree"; + end if; + + return Previous_Sibling (Position); + end Previous; + + ---------------------- + -- Previous_Sibling -- + ---------------------- + + function Previous_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Prev = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Prev); + end Previous_Sibling; + + procedure Previous_Sibling (Position : in out Cursor) is + begin + Position := Previous_Sibling (Position); + end Previous_Sibling; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + Process (Position.Node.Element.all); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Tree) + is + procedure Read_Children (Subtree : Tree_Node_Access); + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access; + + Total_Count : Count_Type'Base; + -- Value read from the stream that says how many elements follow + + Read_Count : Count_Type'Base; + -- Actual number of elements read from the stream + + ------------------- + -- Read_Children -- + ------------------- + + procedure Read_Children (Subtree : Tree_Node_Access) is + pragma Assert (Subtree /= null); + pragma Assert (Subtree.Children.First = null); + pragma Assert (Subtree.Children.Last = null); + + Count : Count_Type'Base; + -- Number of child subtrees + + C : Children_Type; + + begin + Count_Type'Read (Stream, Count); + + if Checks and then Count < 0 then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + if Count = 0 then + return; + end if; + + C.First := Read_Subtree (Parent => Subtree); + C.Last := C.First; + + for J in Count_Type'(2) .. Count loop + C.Last.Next := Read_Subtree (Parent => Subtree); + C.Last.Next.Prev := C.Last; + C.Last := C.Last.Next; + end loop; + + -- Now that the allocation and reads have completed successfully, it + -- is safe to link the children to their parent. + + Subtree.Children := C; + end Read_Children; + + ------------------ + -- Read_Subtree -- + ------------------ + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access + is + Element : constant Element_Access := + new Element_Type'(Element_Type'Input (Stream)); + + Subtree : constant Tree_Node_Access := + new Tree_Node_Type' + (Parent => Parent, Element => Element, others => <>); + + begin + Read_Count := Read_Count + 1; + + Read_Children (Subtree); + + return Subtree; + end Read_Subtree; + + -- Start of processing for Read + + begin + Container.Clear; -- checks busy bit + + Count_Type'Read (Stream, Total_Count); + + if Checks and then Total_Count < 0 then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + if Total_Count = 0 then + return; + end if; + + Read_Count := 0; + + Read_Children (Root_Node (Container)); + + if Checks and then Read_Count /= Total_Count then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + Container.Count := Total_Count; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to read tree cursor from stream"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + -------------------- + -- Remove_Subtree -- + -------------------- + + procedure Remove_Subtree (Subtree : Tree_Node_Access) is + C : Children_Type renames Subtree.Parent.Children; + + begin + -- This is a utility operation to remove a subtree node from its + -- parent's list of children. + + if C.First = Subtree then + pragma Assert (Subtree.Prev = null); + + if C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.First := null; + C.Last := null; + + else + C.First := Subtree.Next; + C.First.Prev := null; + end if; + + elsif C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.Last := Subtree.Prev; + C.Last.Next := null; + + else + Subtree.Prev.Next := Subtree.Next; + Subtree.Next.Prev := Subtree.Prev; + end if; + end Remove_Subtree; + + ---------------------- + -- Replace_Element -- + ---------------------- + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type) + is + E, X : Element_Access; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + TE_Check (Container.TC); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + E := new Element_Type'(New_Item); + end; + + X := Position.Node.Element; + Position.Node.Element := E; + + Free_Element (X); + end Replace_Element; + + ------------------------------ + -- Reverse_Iterate_Children -- + ------------------------------ + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Prev; + end loop; + end Reverse_Iterate_Children; + + ---------- + -- Root -- + ---------- + + function Root (Container : Tree) return Cursor is + begin + return (Container'Unrestricted_Access, Root_Node (Container)); + end Root; + + --------------- + -- Root_Node -- + --------------- + + function Root_Node (Container : Tree) return Tree_Node_Access is + begin + return Container.Root'Unrestricted_Access; + end Root_Node; + + --------------------- + -- Splice_Children -- + --------------------- + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor) + is + Count : Count_Type; + + begin + if Checks and then Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then + raise Program_Error + with "Target_Parent cursor not in Target container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error + with "Before cursor not in Target container"; + end if; + + if Checks and then Before.Node.Parent /= Target_Parent.Node then + raise Constraint_Error + with "Before cursor not child of Target_Parent"; + end if; + end if; + + if Checks and then Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then + raise Program_Error + with "Source_Parent cursor not in Source container"; + end if; + + if Target'Address = Source'Address then + if Target_Parent = Source_Parent then + return; + end if; + + TC_Check (Target.TC); + + if Checks and then Is_Reachable (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + return; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + -- We cache the count of the nodes we have allocated, so that operation + -- Node_Count can execute in O(1) time. But that means we must count the + -- nodes in the subtree we remove from Source and insert into Target, in + -- order to keep the count accurate. + + Count := Subtree_Node_Count (Source_Parent.Node); + pragma Assert (Count >= 1); + + Count := Count - 1; -- because Source_Parent node does not move + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + Source.Count := Source.Count - Count; + Target.Count := Target.Count + Count; + end Splice_Children; + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor) + is + begin + if Checks and then Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Target_Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Target_Parent.Node then + raise Constraint_Error + with "Before cursor not child of Target_Parent"; + end if; + end if; + + if Checks and then Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Source_Parent cursor not in container"; + end if; + + if Target_Parent = Source_Parent then + return; + end if; + + TC_Check (Container.TC); + + if Checks and then Is_Reachable (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + end Splice_Children; + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access) + is + CC : constant Children_Type := Source_Parent.Children; + C : Tree_Node_Access; + + begin + -- This is a utility operation to remove the children from Source parent + -- and insert them into Target parent. + + Source_Parent.Children := Children_Type'(others => null); + + -- Fix up the Parent pointers of each child to designate its new Target + -- parent. + + C := CC.First; + while C /= null loop + C.Parent := Target_Parent; + C := C.Next; + end loop; + + Insert_Subtree_List + (First => CC.First, + Last => CC.Last, + Parent => Target_Parent, + Before => Before); + end Splice_Children; + + -------------------- + -- Splice_Subtree -- + -------------------- + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor) + is + Subtree_Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in Target container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in Target container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Source'Unrestricted_Access then + raise Program_Error with "Position cursor not in Source container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Target'Address = Source'Address then + if Position.Node.Parent = Parent.Node then + if Position.Node = Before.Node then + return; + end if; + + if Position.Node.Next = Before.Node then + return; + end if; + end if; + + TC_Check (Target.TC); + + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + return; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + -- This is an unfortunate feature of this API: we must count the nodes + -- in the subtree that we remove from the source tree, which is an O(n) + -- operation. It would have been better if the Tree container did not + -- have a Node_Count selector; a user that wants the number of nodes in + -- the tree could simply call Subtree_Node_Count, with the understanding + -- that such an operation is O(n). + -- + -- Of course, we could choose to implement the Node_Count selector as an + -- O(n) operation, which would turn this splice operation into an O(1) + -- operation. ??? + + Subtree_Count := Subtree_Node_Count (Position.Node); + pragma Assert (Subtree_Count <= Source.Count); + + Remove_Subtree (Position.Node); + Source.Count := Source.Count - Subtree_Count; + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + Target.Count := Target.Count + Subtree_Count; + + Position.Container := Target'Unrestricted_Access; + end Splice_Subtree; + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor) + is + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + + -- Should this be PE instead? Need ARG confirmation. ??? + + raise Constraint_Error with "Position cursor designates root"; + end if; + + if Position.Node.Parent = Parent.Node then + if Position.Node = Before.Node then + return; + end if; + + if Position.Node.Next = Before.Node then + return; + end if; + end if; + + TC_Check (Container.TC); + + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + end Splice_Subtree; + + ------------------------ + -- Subtree_Node_Count -- + ------------------------ + + function Subtree_Node_Count (Position : Cursor) return Count_Type is + begin + if Position = No_Element then + return 0; + end if; + + return Subtree_Node_Count (Position.Node); + end Subtree_Node_Count; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type + is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 1; + Node := Subtree.Children.First; + while Node /= null loop + Result := Result + Subtree_Node_Count (Node); + Node := Node.Next; + end loop; + + return Result; + end Subtree_Node_Count; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out Tree; + I, J : Cursor) + is + begin + if Checks and then I = No_Element then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor not in container"; + end if; + + if Checks and then Is_Root (I) then + raise Program_Error with "I cursor designates root"; + end if; + + if I = J then -- make this test sooner??? + return; + end if; + + if Checks and then J = No_Element then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor not in container"; + end if; + + if Checks and then Is_Root (J) then + raise Program_Error with "J cursor designates root"; + end if; + + TE_Check (Container.TC); + + declare + EI : constant Element_Access := I.Node.Element; + + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI; + end; + end Swap; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + Process (Position.Node.Element.all); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Tree) + is + procedure Write_Children (Subtree : Tree_Node_Access); + procedure Write_Subtree (Subtree : Tree_Node_Access); + + -------------------- + -- Write_Children -- + -------------------- + + procedure Write_Children (Subtree : Tree_Node_Access) is + CC : Children_Type renames Subtree.Children; + C : Tree_Node_Access; + + begin + Count_Type'Write (Stream, Child_Count (CC)); + + C := CC.First; + while C /= null loop + Write_Subtree (C); + C := C.Next; + end loop; + end Write_Children; + + ------------------- + -- Write_Subtree -- + ------------------- + + procedure Write_Subtree (Subtree : Tree_Node_Access) is + begin + Element_Type'Output (Stream, Subtree.Element.all); + Write_Children (Subtree); + end Write_Subtree; + + -- Start of processing for Write + + begin + Count_Type'Write (Stream, Container.Count); + + if Container.Count = 0 then + return; + end if; + + Write_Children (Root_Node (Container)); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to write tree cursor to stream"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Multiway_Trees; diff --git a/gcc/ada/libgnat/a-cimutr.ads b/gcc/ada/libgnat/a-cimutr.ads new file mode 100644 index 0000000..cd97c9f --- /dev/null +++ b/gcc/ada/libgnat/a-cimutr.ads @@ -0,0 +1,456 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_MULTIWAY_TREES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type (<>) is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Multiway_Trees is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type Tree is tagged private + with Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Tree); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Tree : constant Tree; + + No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Tree_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean; + + function "=" (Left, Right : Tree) return Boolean; + + function Is_Empty (Container : Tree) return Boolean; + + function Node_Count (Container : Tree) return Count_Type; + + function Subtree_Node_Count (Position : Cursor) return Count_Type; + + function Depth (Position : Cursor) return Count_Type; + + function Is_Root (Position : Cursor) return Boolean; + + function Is_Leaf (Position : Cursor) return Boolean; + + function Root (Container : Tree) return Cursor; + + procedure Clear (Container : in out Tree); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Tree; Source : Tree); + + function Copy (Source : Tree) return Tree; + + procedure Move (Target : in out Tree; Source : in out Tree); + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor); + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor); + + procedure Swap + (Container : in out Tree; + I, J : Cursor); + + function Find + (Container : Tree; + Item : Element_Type) return Cursor; + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Find_In_Subtree this way: + -- + -- function Find_In_Subtree + -- (Container : Tree; + -- Item : Element_Type; + -- Position : Cursor) return Cursor; + -- + -- It seems that the Container parameter is there by mistake, but we need + -- an official ruling from the ARG. ??? + + function Find_In_Subtree + (Position : Cursor; + Item : Element_Type) return Cursor; + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Ancestor_Find this way: + -- + -- function Ancestor_Find + -- (Container : Tree; + -- Item : Element_Type; + -- Position : Cursor) return Cursor; + -- + -- It seems that the Container parameter is there by mistake, but we need + -- an official ruling from the ARG. ??? + + function Ancestor_Find + (Position : Cursor; + Item : Element_Type) return Cursor; + + function Contains + (Container : Tree; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)); + + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Children + (Container : Tree; + Parent : Cursor) + return Tree_Iterator_Interfaces.Reversible_Iterator'Class; + + function Child_Count (Parent : Cursor) return Count_Type; + + function Child_Depth (Parent, Child : Cursor) return Count_Type; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor); + + procedure Copy_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : Cursor); + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor); + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor); + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor); + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor); + + function Parent (Position : Cursor) return Cursor; + + function First_Child (Parent : Cursor) return Cursor; + + function First_Child_Element (Parent : Cursor) return Element_Type; + + function Last_Child (Parent : Cursor) return Cursor; + + function Last_Child_Element (Parent : Cursor) return Element_Type; + + function Next_Sibling (Position : Cursor) return Cursor; + + function Previous_Sibling (Position : Cursor) return Cursor; + + procedure Next_Sibling (Position : in out Cursor); + + procedure Previous_Sibling (Position : in out Cursor); + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Iterate_Children this way: + -- + -- procedure Iterate_Children + -- (Container : Tree; + -- Parent : Cursor; + -- Process : not null access procedure (Position : Cursor)); + -- + -- It seems that the Container parameter is there by mistake, but we need + -- an official ruling from the ARG. ??? + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + +private + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + type Tree_Node_Type; + type Tree_Node_Access is access all Tree_Node_Type; + + type Children_Type is record + First : Tree_Node_Access; + Last : Tree_Node_Access; + end record; + + type Element_Access is access all Element_Type; + + type Tree_Node_Type is record + Parent : Tree_Node_Access; + Prev : Tree_Node_Access; + Next : Tree_Node_Access; + Children : Children_Type; + Element : Element_Access; + end record; + + use Ada.Finalization; + + -- The Count component of type Tree represents the number of nodes that + -- have been (dynamically) allocated. It does not include the root node + -- itself. As implementors, we decide to cache this value, so that the + -- selector function Node_Count can execute in O(1) time, in order to be + -- consistent with the behavior of the Length selector function for other + -- standard container library units. This does mean, however, that the + -- two-container forms for Splice_XXX (that move subtrees across tree + -- containers) will execute in O(n) time, because we must count the number + -- of nodes in the subtree(s) that get moved. (We resolve the tension + -- between Node_Count and Splice_XXX in favor of Node_Count, under the + -- assumption that Node_Count is the more common operation). + + type Tree is new Controlled with record + Root : aliased Tree_Node_Type; + TC : aliased Tamper_Counts; + Count : Count_Type := 0; + end record; + + overriding procedure Adjust (Container : in out Tree); + + overriding procedure Finalize (Container : in out Tree) renames Clear; + + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Tree); + + for Tree'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Tree); + + for Tree'Read use Read; + + type Tree_Access is access all Tree; + for Tree_Access'Storage_Size use 0; + + type Cursor is record + Container : Tree_Access; + Node : Tree_Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Tree : constant Tree := (Controlled with others => <>); + + No_Element : constant Cursor := (others => <>); + +end Ada.Containers.Indefinite_Multiway_Trees; diff --git a/gcc/ada/libgnat/a-ciorma.adb b/gcc/ada/libgnat/a-ciorma.adb new file mode 100644 index 0000000..3397430 --- /dev/null +++ b/gcc/ada/libgnat/a-ciorma.adb @@ -0,0 +1,1686 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Ordered_Maps is + pragma Suppress (All_Checks); + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + procedure Free (X : in out Node_Access); + + function Is_Equal_Node_Node + (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + procedure Free_Key is + new Ada.Unchecked_Deallocation (Key_Type, Key_Access); + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + if Checks and then Left.Node.Key = null then + raise Program_Error with "Left cursor in ""<"" is bad"; + end if; + + if Checks and then Right.Node.Key = null then + raise Program_Error with "Right cursor in ""<"" is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor in ""<"" is bad"); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor in ""<"" is bad"); + + return Left.Node.Key.all < Right.Node.Key.all; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if Checks and then Left.Node.Key = null then + raise Program_Error with "Left cursor in ""<"" is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor in ""<"" is bad"); + + return Left.Node.Key.all < Right; + end "<"; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + if Checks and then Right.Node.Key = null then + raise Program_Error with "Right cursor in ""<"" is bad"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor in ""<"" is bad"); + + return Left < Right.Node.Key.all; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + if Checks and then Left.Node.Key = null then + raise Program_Error with "Left cursor in ""<"" is bad"; + end if; + + if Checks and then Right.Node.Key = null then + raise Program_Error with "Right cursor in ""<"" is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor in "">"" is bad"); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor in "">"" is bad"); + + return Right.Node.Key.all < Left.Node.Key.all; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if Checks and then Left.Node.Key = null then + raise Program_Error with "Left cursor in ""<"" is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor in "">"" is bad"); + + return Right < Left.Node.Key.all; + end ">"; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + if Checks and then Right.Node.Key = null then + raise Program_Error with "Right cursor in ""<"" is bad"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor in "">"" is bad"); + + return Right.Node.Key.all < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); + + procedure Adjust (Container : in out Map) is + begin + Adjust (Container.Tree); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is + new Tree_Operations.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key.all, New_Item => Node.Element.all); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Insert_Items (Source.Tree); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree); + + procedure Clear (Container : in out Map) is + begin + Clear (Container.Tree); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in Constant_Reference is bad"); + + declare + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Map) return Map is + begin + return Target : Map do + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + K : Key_Access := new Key_Type'(Source.Key.all); + E : Element_Access; + + begin + E := new Element_Type'(Source.Element.all); + + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Key => K, + Element => E); + + exception + when others => + Free_Key (K); + Free_Element (E); + raise; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Map; + Position : in out Cursor) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with "Position cursor of Delete is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor of Delete is bad"); + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then X = null then + raise Constraint_Error with "key not in map"; + end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) is + X : Node_Access := Container.Tree.First; + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) is + X : Node_Access := Container.Tree.Last; + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor of function Element is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of function Element is bad"); + + return Position.Node.Element.all; + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + return Node.Element.all; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + return (if Left < Right or else Right < Left then False else True); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.Tree.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin + return (if T.First = null then No_Element + else Cursor'(Container'Unrestricted_Access, T.First)); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + begin + if Checks and then T.First = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.First.Element.all; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + begin + if Checks and then T.First = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.First.Key.all; + end First_Key; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X = null then + return; + end if; + + X.Parent := X; + X.Left := X; + X.Right := X; + + begin + Free_Key (X.Key); + + exception + when others => + X.Key := null; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + end; + + Deallocate (X); + raise; + end; + + begin + Free_Element (X.Element); + + exception + when others => + X.Element := null; + + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + K : Key_Access; + E : Element_Access; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.Tree.TC); + + K := Position.Node.Key; + E := Position.Node.Element; + + Position.Node.Key := new Key_Type'(Key); + + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Position.Node.Element := new Element_Type'(New_Item); + + exception + when others => + Free_Key (K); + raise; + end; + + Free_Key (K); + Free_Element (E); + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : Node_Access := new Node_Type; + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Key := new Key_Type'(Key); + Node.Element := new Element_Type'(New_Item); + return Node; + + exception + when others => + + -- On exception, deallocate key and elem. Note that free + -- deallocates both the key and the elem. + + Free (Node); + raise; + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with "key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return (if L.Key.all < R.Key.all then False + elsif R.Key.all < L.Key.all then False + else L.Element.all = R.Element.all); + end Is_Equal_Node_Node; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + -- k > node same as node < k + + return Right.Key.all < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left < Right.Key.all; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + Busy (Container.Tree.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : Map; + Start : Cursor) + return Map_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.Tree.TC'Unrestricted_Access.all); + end return; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + if Checks and then Position.Node.Key = null then + raise Program_Error with + "Position cursor of function Key is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of function Key is bad"); + + return Position.Node.Key.all; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin + return (if T.Last = null then No_Element + else Cursor'(Container'Unrestricted_Access, T.Last)); + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + + begin + if Checks and then T.Last = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.Last.Element.all; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + + begin + if Checks and then T.Last = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.Last.Key.all; + end Last_Key; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move is new Tree_Operations.Generic_Move (Clear); + + procedure Move (Target : in out Map; Source : in out Map) is + begin + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Key /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of Next is bad"); + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); + end Next; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Position.Node /= null); + pragma Assert (Position.Node.Key /= null); + pragma Assert (Position.Node.Element /= null); + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of Previous is bad"); + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong map"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with + "Position cursor of Query_Element is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of Query_Element is bad"); + + declare + T : Tree_Type renames Position.Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + begin + Process (K, E); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + begin + Node.Key := new Key_Type'(Key_Type'Input (Stream)); + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + return Node; + exception + when others => + Free (Node); -- Note that Free deallocates key and elem too + raise; + end Read_Node; + + -- Start of processing for Read + + begin + Read (Stream, Container.Tree); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in function Reference is bad"); + + declare + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + K : Key_Access; + E : Element_Access; + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + TE_Check (Container.Tree.TC); + + K := Node.Key; + E := Node.Element; + + Node.Key := new Key_Type'(Key); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(New_Item); + + exception + when others => + Free_Key (K); + raise; + end; + + Free_Key (K); + Free_Element (E); + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with + "Position cursor of Replace_Element is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + TE_Check (Container.Tree.TC); + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor of Replace_Element is bad"); + + declare + X : Element_Access := Position.Node.Element; + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Checks and then + (Position.Node.Key = null or else Position.Node.Element = null) + then + raise Program_Error with + "Position cursor of Update_Element is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor of Update_Element is bad"); + + declare + T : Tree_Type renames Position.Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key.all; + E : Element_Type renames Position.Node.Element.all; + begin + Process (K, E); + end; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Output (Stream, Node.Key.all); + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + + -- Start of processing for Write + + begin + Write (Stream, Container.Tree); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-ciorma.ads b/gcc/ada/libgnat/a-ciorma.ads new file mode 100644 index 0000000..6e9c1ef --- /dev/null +++ b/gcc/ada/libgnat/a-ciorma.ads @@ -0,0 +1,388 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Red_Black_Trees; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Key_Type (<>) is private; + type Element_Type (<>) is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Ordered_Maps is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map is tagged private + with Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Map_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Key (Position : Cursor) return Key_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)); + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map) return Map; + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + procedure Delete_First (Container : in out Map); + + procedure Delete_Last (Container : in out Map); + + function First (Container : Map) return Cursor; + + function First_Element (Container : Map) return Element_Type; + + function First_Key (Container : Map) return Key_Type; + + function Last (Container : Map) return Cursor; + + function Last_Element (Container : Map) return Element_Type; + + function Last_Key (Container : Map) return Key_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + -- The map container supports iteration in both the forward and reverse + -- directions, hence these constructor functions return an object that + -- supports the Reversible_Iterator interface. + + function Iterate + (Container : Map) + return Map_Iterator_Interfaces.Reversible_Iterator'Class; + + function Iterate + (Container : Map; + Start : Cursor) + return Map_Iterator_Interfaces.Reversible_Iterator'Class; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type; + type Node_Access is access Node_Type; + + type Key_Access is access Key_Type; + type Element_Access is access all Element_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Key : Key_Access; + Element : Element_Access; + end record; + + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); + + type Map is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; + end record; + + overriding procedure Adjust (Container : in out Map); + + overriding procedure Finalize (Container : in out Map) renames Clear; + + use Red_Black_Trees; + use Tree_Types, Tree_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_Access; + Node : Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); + + No_Element : constant Cursor := Cursor'(null, null); + + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Indefinite_Ordered_Maps; diff --git a/gcc/ada/libgnat/a-ciormu.adb b/gcc/ada/libgnat/a-ciormu.adb new file mode 100644 index 0000000..916df95 --- /dev/null +++ b/gcc/ada/libgnat/a-ciormu.adb @@ -0,0 +1,2013 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Ordered_Multisets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + procedure Free (X : in out Node_Access); + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + if Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left.Node.Element.all < Right.Node.Element.all; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + return Left.Node.Element.all < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left < Right.Node.Element.all; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + if Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + -- L > R same as R < L + + return Right.Node.Element.all < Left.Node.Element.all; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + return Right < Left.Node.Element.all; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + return Right.Node.Element.all < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + + procedure Adjust (Container : in out Set) is + begin + Adjust (Container.Tree); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + + procedure Clear (Container : in out Set) is + begin + Clear (Container.Tree); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + -- Note: in predefined container units, the creation of a reference + -- increments the busy bit of the container, and its finalization + -- decrements it. In the absence of control machinery, this tampering + -- protection is missing. + + declare + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + pragma Unreferenced (T); + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element, + Control => (Container => Container'Unrestricted_Access)) + do + null; + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + X : Element_Access := new Element_Type'(Source.Element.all); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => X); + + exception + when others => + Free_Element (X); + raise; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + + return Position.Node.Element.all; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + if L.Element.all < R.Element.all then + return False; + elsif R.Element.all < L.Element.all then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + Unbusy (Object.Container.Tree.TC); + end Finalize; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + if Container.Tree.First = null then + raise Constraint_Error with "set is empty"; + end if; + + pragma Assert (Container.Tree.First.Element /= null); + return Container.Tree.First.Element.all; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X = null then + return; + end if; + + X.Parent := X; + X.Left := X; + X.Right := X; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + raise Constraint_Error with "key not in set"; + end if; + + return Node.Element.all; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Key (Right.Element.all) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Key (Right.Element.all); + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Key_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T, Key); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with + "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + + return Key (Position.Node.Element.all); + end Key; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + ------------- + -- Iterate -- + ------------- + + procedure Local_Reverse_Iterate is + new Key_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T, Key); + end Reverse_Iterate; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + Node : constant Node_Access := Position.Node; + + begin + if Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Tree, Node), + "bad cursor in Update_Element"); + + declare + E : Element_Type renames Node.Element.all; + K : constant Key_Type := Key (E); + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Process (E); + + if Equivalent_Keys (Left => K, Right => Key (E)) then + return; + end if; + end; + + -- Delete_Node checks busy-bit + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); + + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Color := Red_Black_Trees.Red; + Node.Parent := null; + Node.Left := null; + Node.Right := null; + + return Node; + end New_Node; + + Result : Node_Access; + + -- Start of processing for Insert_New_Item + + begin + Unconditional_Insert + (Tree => Tree, + Key => Node.Element.all, + Node => Result); + + pragma Assert (Result = Node); + end Insert_New_Item; + end Update_Element; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + pragma Unreferenced (Position); + begin + Insert (Container, New_Item, Position); + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor) + is + begin + Insert_Sans_Hint (Container.Tree, New_Item, Position.Node); + Position.Container := Container'Unrestricted_Access; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + Element : Element_Access := new Element_Type'(New_Item); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red_Black_Trees.Red, + Element => Element); + + exception + when others => + Free_Element (Element); + raise; + end New_Node; + + -- Start of processing for Insert_Sans_Hint + + begin + Unconditional_Insert (Tree, New_Item, Node); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + X : Element_Access := new Element_Type'(Src_Node.Element.all); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => X); + + exception + when others => + Free_Element (X); + raise; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element.all, + Dst_Node); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all = R.Element.all; + end Is_Equal_Node_Node; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + -- e > node same as node < e + + return Right.Element.all < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element.all; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all < R.Element.all; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Element_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T, Item); + end Iterate; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T); + end Iterate; + + function Iterate (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'Class + is + S : constant Set_Access := Container'Unrestricted_Access; + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := (Limited_Controlled with S, null) do + Busy (S.Tree.TC); + end return; + end Iterate; + + function Iterate (Container : Set; Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'Class + is + S : constant Set_Access := Container'Unrestricted_Access; + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with S, Start.Node) + do + Busy (S.Tree.TC); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Container.Tree.Last = null then + raise Constraint_Error with "set is empty"; + end if; + + pragma Assert (Container.Tree.Last.Element /= null); + return Container.Tree.Last.Element.all; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move is + new Tree_Operations.Generic_Move (Clear); + + procedure Move (Target : in out Set; Source : in out Set) is + begin + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + + return Previous (Position); + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); + + declare + T : Tree_Type renames Position.Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + Process (Position.Node.Element.all); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + begin + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + return Node; + exception + when others => + Free (Node); -- Note that Free deallocates elem too + raise; + end Read_Node; + + -- Start of processing for Read + + begin + Read (Stream, Container.Tree); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + begin + if Item < Node.Element.all + or else Node.Element.all < Item + then + null; + else + TE_Check (Tree.TC); + + declare + X : Element_Access := Node.Element; + + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; + + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); -- OK if fails + Node.Color := Red_Black_Trees.Red; + Node.Parent := null; + Node.Left := null; + Node.Right := null; + + return Node; + end New_Node; + + Result : Node_Access; + + X : Element_Access := Node.Element; + + -- Start of processing for Insert_New_Item + + begin + Unconditional_Insert + (Tree => Tree, + Key => Item, + Node => Result); + pragma Assert (Result = Node); + + Free_Element (X); -- OK if fails + end Insert_New_Item; + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container.Tree, Position.Node, New_Item); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Element_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T, Item); + end Reverse_Iterate; + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + pragma Unreferenced (Node); + begin + Insert_Sans_Hint (Tree, New_Item, Node); + return Set'(Controlled with Tree); + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + + -- Start of processing for Write + + begin + Write (Stream, Container.Tree); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; +end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/libgnat/a-ciormu.ads b/gcc/ada/libgnat/a-ciormu.ads new file mode 100644 index 0000000..426924e --- /dev/null +++ b/gcc/ada/libgnat/a-ciormu.ads @@ -0,0 +1,566 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_MULTISETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- The indefinite ordered multiset container is similar to the indefinite +-- ordered set, but with the difference that multiple equivalent elements are +-- allowed. It also provides additional operations, to iterate over items that +-- are equivalent. + +private with Ada.Containers.Red_Black_Trees; +private with Ada.Finalization; +private with Ada.Streams; +with Ada.Iterator_Interfaces; + +generic + type Element_Type (<>) is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Ordered_Multisets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. + + type Set is tagged private + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + -- The default value for set objects declared without an explicit + -- initialization expression. + + No_Element : constant Cursor; + -- The default value for cursor objects declared without an explicit + -- initialization expression. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + -- If Left denotes the same set object as Right, then equality returns + -- True. If the length of Left is different from the length of Right, then + -- it returns False. Otherwise, set equality iterates over Left and Right, + -- comparing the element of Left to the element of Right using the equality + -- operator for elements. If the elements compare False, then the iteration + -- terminates and set equality returns False. Otherwise, if all elements + -- compare True, then set equality returns True. + + function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, but with the difference that elements are + -- compared for equivalence instead of equality. + + function To_Set (New_Item : Element_Type) return Set; + -- Constructs a set object with New_Item as its single element + + function Length (Container : Set) return Count_Type; + -- Returns the total number of elements in Container + + function Is_Empty (Container : Set) return Boolean; + -- Returns True if Container.Length is 0 + + procedure Clear (Container : in out Set); + -- Deletes all elements from Container + + function Element (Position : Cursor) return Element_Type; + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, function Element returns the element designed by Position. + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. If New_Item is equivalent to the element + -- designated by Position, then if Container is locked (element tampering + -- has been attempted), Program_Error is raised; otherwise, the element + -- designated by Position is assigned the value of New_Item. If New_Item is + -- not equivalent to the element designated by Position, then if the + -- container is busy (cursor tampering has been attempted), Program_Error + -- is raised; otherwise, the element designed by Position is assigned the + -- value of New_Item, and the node is moved to its new position (in + -- canonical insertion order). + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- If Position equals No_Element, then Constraint_Error is + -- raised. Otherwise, it calls Process with the element designated by + -- Position as the parameter. This call locks the container, so attempts to + -- change the value of the element while Process is executing (to "tamper + -- with elements") will raise Program_Error. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If either Target or Source is busy (cursor tampering is + -- attempted), then it raises Program_Error. Otherwise, Target is cleared, + -- and the nodes from Source are moved (not copied) to Target (so Source + -- becomes empty). + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor); + -- Insert adds New_Item to Container, and returns cursor Position + -- designating the newly inserted node. The node is inserted after any + -- existing elements less than or equivalent to New_Item (and before any + -- elements greater than New_Item). Note that the issue of where the new + -- node is inserted relative to equivalent elements does not arise for + -- unique-key containers, since in that case the insertion would simply + -- fail. For a multiple-key container (the case here), insertion always + -- succeeds, and is defined such that the new item is positioned after any + -- equivalent elements already in the container. + + procedure Insert (Container : in out Set; New_Item : Element_Type); + -- Inserts New_Item in Container, but does not return a cursor designating + -- the newly-inserted node. + +-- TODO: include Replace too??? +-- +-- procedure Replace +-- (Container : in out Set; +-- New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item + + procedure Delete (Container : in out Set; Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item. If there + -- are no elements equivalent to Item, then it raises Constraint_Error. + + procedure Delete (Container : in out Set; Position : in out Cursor); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. Otherwise, the node designated by Position is + -- removed from Container, and Position is set to No_Element. + + procedure Delete_First (Container : in out Set); + -- Removes the first node from Container + + procedure Delete_Last (Container : in out Set); + -- Removes the last node from Container + + procedure Union (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), then Program_Error is + -- raised. Otherwise, it inserts each element of Source into Target. + -- Elements are inserted in the canonical order for multisets, such that + -- the elements from Source are inserted after equivalent elements already + -- in Target. + + function Union (Left, Right : Set) return Set; + -- Returns a set comprising the all elements from Left and all of the + -- elements from Right. The elements from Right follow the equivalent + -- elements from Left. + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If Target is busy (cursor tampering is attempted), + -- Program_Error is raised. Otherwise, the elements in Target having no + -- equivalent element in Source are deleted from Target. + + function Intersection (Left, Right : Set) return Set; + -- If Left denotes the same object as Right, then the function returns a + -- copy of Left. Otherwise, it returns a set comprising the equivalent + -- elements from both Left and Right. Items are inserted in the result set + -- in canonical order, such that the elements from Left precede the + -- equivalent elements from Right. + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), then Program_Error is + -- raised. Otherwise, the elements in Target that are equivalent to + -- elements in Source are deleted from Target. + + function Difference (Left, Right : Set) return Set; + -- Returns a set comprising the elements from Left that have no equivalent + -- element in Right. + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + -- If Target is busy, then Program_Error is raised. Otherwise, the elements + -- in Target equivalent to elements in Source are deleted from Target, and + -- the elements in Source not equivalent to elements in Target are inserted + -- into Target. + + function Symmetric_Difference (Left, Right : Set) return Set; + -- Returns a set comprising the union of the elements from Target having no + -- equivalent in Source, and the elements of Source having no equivalent in + -- Target. + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + -- Returns True if Left contains an element equivalent to an element of + -- Right. + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + -- Returns True if every element in Subset has an equivalent element in + -- Of_Set. + + function First (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the smallest element. + + function First_Element (Container : Set) return Element_Type; + -- Equivalent to Element (First (Container)) + + function Last (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the largest element. + + function Last_Element (Container : Set) return Element_Type; + -- Equivalent to Element (Last (Container)) + + function Next (Position : Cursor) return Cursor; + -- If Position equals No_Element or Last (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately follows (as per the insertion order) the node designated by + -- Position. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Previous (Position : Cursor) return Cursor; + -- If Position equals No_Element or First (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately precedes (as per the insertion order) the node designated by + -- Position. + + procedure Previous (Position : in out Cursor); + -- Equivalent to Position := Previous (Position) + + function Find (Container : Set; Item : Element_Type) return Cursor; + -- Returns a cursor designating the first element in Container equivalent + -- to Item. If there is no equivalent element, it returns No_Element. + + function Floor (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements in Container, it returns a cursor designating the + -- first equivalent element. Otherwise, it returns a cursor designating the + -- largest element less than Item, or No_Element if all elements are + -- greater than Item. + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements of Container, it returns a cursor designating the + -- last equivalent element. Otherwise, it returns a cursor designating the + -- smallest element greater than Item, or No_Element if all elements are + -- less than Item. + + function Contains (Container : Set; Item : Element_Type) return Boolean; + -- Equivalent to Container.Find (Item) /= No_Element + + function "<" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Left) < Element (Right) + + function ">" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Element (Left) + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Element (Left) < Right + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Right < Element (Left) + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Left < Element (Right) + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Left + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.First to Container.Last. + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.Last to Container.First. + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Floor (Item) to Container.Ceiling (Item). + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Ceiling (Item) to Container.Floor (Item). + + function Iterate + (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : Set; + Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. + + function Key (Position : Cursor) return Key_Type; + -- Equivalent to Key (Element (Position)) + + function Element (Container : Set; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) + + procedure Exclude (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to Key + + procedure Delete (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to + -- Key. If there are no such elements, then it raises Constraint_Error. + + function Find (Container : Set; Key : Key_Type) return Cursor; + -- Returns a cursor designating the first element in Container whose key + -- is equivalent to Key. If there is no equivalent element, it returns + -- No_Element. + + function Floor (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements in Container, it returns a cursor + -- designating the first such element. Otherwise, it returns a cursor + -- designating the largest element whose key is less than Item, or + -- No_Element if all keys are greater than Item. + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements of Container, it returns a cursor + -- designating the last such element. Otherwise, it returns a cursor + -- designating the smallest element whose key is greater than Item, or + -- No_Element if all keys are less than Item. + + function Contains (Container : Set; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + procedure Update_Element -- Update_Element_Preserving_Key ??? + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set object different from Container, + -- then Program_Error is raised. Otherwise, it makes a copy of the key + -- of the element designated by Position, and then calls Process with + -- the element as the parameter. Update_Element then compares the key + -- value obtained before calling Process to the key value obtained from + -- the element after calling Process. If the keys are equivalent then + -- the operation terminates. If Container is busy (cursor tampering has + -- been attempted), then Program_Error is raised. Otherwise, the node + -- is moved to its new position (in canonical order). + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Floor (Container, Key) to + -- Ceiling (Container, Key). + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Ceiling (Container, Key) to + -- Floor (Container, Key). + + end Generic_Keys; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type; + type Node_Access is access Node_Type; + + type Element_Access is access Element_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Access; + end record; + + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); + + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; + end record; + + overriding procedure Adjust (Container : in out Set); + + overriding procedure Finalize (Container : in out Set) renames Clear; + + use Red_Black_Trees; + use Tree_Types, Tree_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + -- In all predefined libraries the following type is controlled, for proper + -- management of tampering checks. For performance reason we omit this + -- machinery for multisets, which are used in a number of our tools. + + type Reference_Control_Type is record + Container : Set_Access; + end record; + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + Empty_Set : constant Set := (Controlled with others => <>); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Indefinite_Ordered_Multisets; diff --git a/gcc/ada/libgnat/a-ciorse.adb b/gcc/ada/libgnat/a-ciorse.adb new file mode 100644 index 0000000..512127e --- /dev/null +++ b/gcc/ada/libgnat/a-ciorse.adb @@ -0,0 +1,2191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Ordered_Sets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + procedure Free (X : in out Node_Access); + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + procedure Free_Element is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Checks and then Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + if Checks and then Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left.Node.Element.all < Right.Node.Element.all; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + return Left.Node.Element.all < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Checks and then Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left < Right.Node.Element.all; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all = R.Element.all; + end Is_Equal_Node_Node; + + -- Start of processing for "=" + + begin + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Checks and then Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + if Checks and then Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + -- L > R same as R < L + + return Right.Node.Element.all < Left.Node.Element.all; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Left.Node.Element = null then + raise Program_Error with "Left cursor is bad"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + return Right < Left.Node.Element.all; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + if Checks and then Right.Node.Element = null then + raise Program_Error with "Right cursor is bad"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + return Right.Node.Element.all < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); + + procedure Adjust (Container : in out Set) is + begin + Adjust (Container.Tree); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + + procedure Clear (Container : in out Set) is + begin + Clear (Container.Tree); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + declare + Tree : Tree_Type renames Position.Container.all.Tree; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Element : Element_Access := new Element_Type'(Source.Element.all); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => Element); + + exception + when others => + Free_Element (Element); + raise; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : Node_Access := Element_Keys.Find (Container.Tree, Item); + begin + if Checks and then X = null then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end if; + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + + return Position.Node.Element.all; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right or else Right < Left then + return False; + else + return True; + end if; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + if L.Element.all < R.Element.all then + return False; + elsif R.Element.all < L.Element.all then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : Node_Access := Element_Keys.Find (Container.Tree, Item); + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.Tree.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); + begin + if Node = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); + end if; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + return + (if Container.Tree.First = null then No_Element + else Cursor'(Container'Unrestricted_Access, Container.Tree.First)); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + if Checks and then Container.Tree.First = null then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Tree.First.Element.all; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X = null then + return; + end if; + + X.Parent := X; + X.Left := X; + X.Right := X; + + begin + Free_Element (X.Element); + exception + when others => + X.Element := null; + Deallocate (X); + raise; + end; + + Deallocate (X); + end Free; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Ceiling; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + declare + Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element.all'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then X = null then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in set"; + end if; + + return Node.Element.all; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right or else Right < Left then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then + Delete (Control.Container.all, Key (Control.Pos)); + raise Program_Error; + end if; + + Control.Container := null; + Control.Old_Key := null; + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Key (Right.Element.all) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Key (Right.Element.all); + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with + "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + + return Key (Position.Node.Element.all); + end Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container.Tree, Node, New_Item); + end Replace; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in function Reference_Preserving_Key"); + + declare + Tree : Tree_Type renames Container.Tree; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element.all'Unchecked_Access, + Control => + (Controlled with + Tree.TC'Unrestricted_Access, + Container => Container'Access, + Pos => Position, + Old_Key => new Key_Type'(Key (Position)))) + do + Lock (Tree.TC); + end return; + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + if Checks and then Node.Element = null then + raise Program_Error with "Node has no element"; + end if; + + declare + Tree : Tree_Type renames Container.Tree; + begin + return R : constant Reference_Type := + (Element => Node.Element.all'Unchecked_Access, + Control => + (Controlled with + Tree.TC'Unrestricted_Access, + Container => Container'Access, + Pos => Find (Container, Key), + Old_Key => new Key_Type'(Key))) + do + Lock (Tree.TC); + end return; + end; + end Reference_Preserving_Key; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + + declare + E : Element_Type renames Position.Node.Element.all; + K : constant Key_Type := Key (E); + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Process (E); + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + declare + X : Node_Access := Position.Node; + begin + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end; + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + end Generic_Keys; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + X : Element_Access; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.Tree.TC); + + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + X := Position.Node.Element; + Position.Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Conditional_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + Element : Element_Access := new Element_Type'(New_Item); + + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red_Black_Trees.Red, + Element => Element); + + exception + when others => + Free_Element (Element); + raise; + end New_Node; + + -- Start of processing for Insert_Sans_Hint + + begin + Conditional_Insert_Sans_Hint + (Tree, + New_Item, + Node, + Inserted); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + Success : Boolean; + pragma Unreferenced (Success); + + function New_Node return Node_Access; + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Element : Element_Access := new Element_Type'(Src_Node.Element.all); + Node : Node_Access; + + begin + begin + Node := new Node_Type; + exception + when others => + Free_Element (Element); + raise; + end; + + Node.Element := Element; + return Node; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element.all, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + -- e > node same as node < e + + return Right.Element.all < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element.all; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element.all < R.Element.all; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T); + end Iterate; + + function Iterate + (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + Busy (Container.Tree.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : Set; + Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.Tree.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + return + (if Container.Tree.Last = null then No_Element + else Cursor'(Container'Unrestricted_Access, Container.Tree.Last)); + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Checks and then Container.Tree.Last = null then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Tree.Last.Element.all; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move is new Tree_Operations.Generic_Move (Clear); + + procedure Move (Target : in out Set; Source : in out Set) is + begin + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + + declare + Node : constant Node_Access := Tree_Operations.Next (Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Previous; + + function Previous + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); + + declare + T : Tree_Type renames Position.Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + Process (Position.Node.Element.all); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + Node.Element := new Element_Type'(Element_Type'Input (Stream)); + return Node; + + exception + when others => + Free (Node); -- Note that Free deallocates elem too + raise; + end Read_Node; + + -- Start of processing for Read + + begin + Read (Stream, Container.Tree); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, New_Item); + + X : Element_Access; + pragma Warnings (Off, X); + + begin + if Checks and then Node = null then + raise Constraint_Error with "attempt to replace element not in set"; + end if; + + TE_Check (Container.Tree.TC); + + declare + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + X := Node.Element; + Node.Element := new Element_Type'(New_Item); + Free_Element (X); + end; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + pragma Assert (Node /= null); + pragma Assert (Node.Element /= null); + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + + -- The element allocator may need an accessibility check in the case + -- the actual type is class-wide or has access discriminants (see + -- RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); -- OK if fails + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + return Node; + end New_Node; + + Hint : Node_Access; + Result : Node_Access; + Inserted : Boolean; + Compare : Boolean; + + X : Element_Access := Node.Element; + + -- Start of processing for Replace_Element + + begin + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints, described as follows. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := (if Item < Node.Element.all then False + elsif Node.Element.all < Item then False + else True); + end; + + if Compare then + -- Item is equivalent to the node's element, so we will not have to + -- move the node. + + TE_Check (Tree.TC); + + declare + -- The element allocator may need an accessibility check in the + -- case the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; + + return; + end if; + + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns null. + + Hint := Element_Keys.Ceiling (Tree, Item); + + if Hint /= null then + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Item < Hint.Element.all; + end; + + -- Item >= Hint.Element + + if Checks and then not Compare then + + -- Ceiling returns an element that is equivalent or greater + -- than Item. If Item is "not less than" the element, then + -- by elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree, so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. + + if Hint = Node then + TE_Check (Tree.TC); + + declare + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Node.Element := new Element_Type'(Item); + Free_Element (X); + end; + + return; + end if; + end if; + + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = null), or because Item was less than some element at + -- a different place in the tree (Item < Hint.Element.all). In either + -- case, we remove Node from the tree (without actually deallocating + -- it), and then insert Item into the tree, onto the same Node (so no + -- new node is actually allocated). + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Local_Insert_With_Hint + (Tree => Tree, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); + + pragma Assert (Inserted); + pragma Assert (Result = Node); + + Free_Element (X); + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Node.Element = null then + raise Program_Error with "Position cursor is bad"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container.Tree, Position.Node, New_Item); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + Inserted : Boolean; + pragma Unreferenced (Node, Inserted); + begin + Insert_Sans_Hint (Tree, New_Item, Node, Inserted); + return Set'(Controlled with Tree); + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Element_Type'Output (Stream, Node.Element.all); + end Write_Node; + + -- Start of processing for Write + + begin + Write (Stream, Container.Tree); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-ciorse.ads b/gcc/ada/libgnat/a-ciorse.ads new file mode 100644 index 0000000..78750f2d --- /dev/null +++ b/gcc/ada/libgnat/a-ciorse.ads @@ -0,0 +1,467 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.INDEFINITE_ORDERED_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Containers.Red_Black_Trees; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type (<>) is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Ordered_Sets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set is tagged private with + Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + + function Equivalent_Sets (Left, Right : Set) return Boolean; + + function To_Set (New_Item : Element_Type) return Set; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Include + (Container : in out Set; + New_Item : Element_Type); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find + (Container : Set; + Item : Element_Type) return Cursor; + + function Floor + (Container : Set; + Item : Element_Type) return Cursor; + + function Ceiling + (Container : Set; + Item : Element_Type) return Cursor; + + function Contains + (Container : Set; + Item : Element_Type) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + function Iterate + (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : Set; + Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + function Find + (Container : Set; + Key : Key_Type) return Cursor; + + function Floor + (Container : Set; + Key : Key_Type) return Cursor; + + function Ceiling + (Container : Set; + Key : Key_Type) return Cursor; + + function Contains + (Container : Set; + Key : Key_Type) return Boolean; + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type; + + private + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Key_Access is access all Key_Type; + + package Impl is new Helpers.Generic_Implementation; + + type Reference_Control_Type is + new Impl.Reference_Control_Type with + record + Container : Set_Access; + Pos : Cursor; + Old_Key : Key_Access; + end record; + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; + + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + end Generic_Keys; + +private + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type; + type Node_Access is access Node_Type; + + type Element_Access is access all Element_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Access; + end record; + + package Tree_Types is new Red_Black_Trees.Generic_Tree_Types + (Node_Type, + Node_Access); + + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; + end record; + + overriding procedure Adjust (Container : in out Set); + + overriding procedure Finalize (Container : in out Set) renames Clear; + + use Red_Black_Trees; + use Tree_Types, Tree_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); + + No_Element : constant Cursor := Cursor'(null, null); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Indefinite_Ordered_Sets; diff --git a/gcc/ada/libgnat/a-clrefi.adb b/gcc/ada/libgnat/a-clrefi.adb new file mode 100644 index 0000000..71d05ff --- /dev/null +++ b/gcc/ada/libgnat/a-clrefi.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/a-clrefi.ads b/gcc/ada/libgnat/a-clrefi.ads new file mode 100644 index 0000000..14971f3 --- /dev/null +++ b/gcc/ada/libgnat/a-clrefi.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E S P O N S E _ F I L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- See s-resfil.ads for documentation + +with System.Response_File; +package Ada.Command_Line.Response_File renames System.Response_File; diff --git a/gcc/ada/libgnat/a-coboho.adb b/gcc/ada/libgnat/a-coboho.adb new file mode 100644 index 0000000..9696d1c --- /dev/null +++ b/gcc/ada/libgnat/a-coboho.adb @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ H O L D E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Unchecked_Conversion; + +package body Ada.Containers.Bounded_Holders is + + function Size_In_Storage_Elements (Element : Element_Type) return Natural; + -- This returns the size of Element in storage units. It raises an + -- exception if the size is not a multiple of Storage_Unit, or if the size + -- is too big. + + ------------------------------ + -- Size_In_Storage_Elements -- + ------------------------------ + + function Size_In_Storage_Elements (Element : Element_Type) return Natural is + Max_Size : Natural renames Max_Size_In_Storage_Elements; + + begin + return S : constant Natural := Element'Size / System.Storage_Unit do + pragma Assert + (Element'Size mod System.Storage_Unit = 0, + "Size must be a multiple of Storage_Unit"); + + pragma Assert + (S <= Max_Size, "Size is too big:" & S'Img & " >" & Max_Size'Img); + end return; + end Size_In_Storage_Elements; + + function Cast is new + Unchecked_Conversion (System.Address, Element_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Holder) return Boolean is + begin + return Get (Left) = Get (Right); + end "="; + + ------------- + -- Element -- + ------------- + + function Get (Container : Holder) return Element_Type is + begin + return Cast (Container'Address).all; + end Get; + + --------- + -- Set -- + --------- + + procedure Set (Container : in out Holder; New_Item : Element_Type) is + Storage : Storage_Array + (1 .. Size_In_Storage_Elements (New_Item)) with + Address => New_Item'Address; + begin + Container.Data (Storage'Range) := Storage; + end Set; + + --------------- + -- To_Holder -- + --------------- + + function To_Holder (New_Item : Element_Type) return Holder is + begin + return Result : Holder do + Set (Result, New_Item); + end return; + end To_Holder; + +end Ada.Containers.Bounded_Holders; diff --git a/gcc/ada/libgnat/a-coboho.ads b/gcc/ada/libgnat/a-coboho.ads new file mode 100644 index 0000000..130f7f2 --- /dev/null +++ b/gcc/ada/libgnat/a-coboho.ads @@ -0,0 +1,114 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ H O L D E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +private with System; + +generic + type Element_Type (<>) is private; + Max_Size_In_Storage_Elements : Natural := + Element_Type'Max_Size_In_Storage_Elements; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Holders is + pragma Annotate (CodePeer, Skip_Analysis); + + -- This package is patterned after Ada.Containers.Indefinite_Holders. It is + -- used to treat indefinite subtypes as definite, but without using heap + -- allocation. For example, you might like to say: + -- + -- type A is array (...) of T'Class; -- illegal + -- + -- Instead, you can instantiate this package with Element_Type => T'Class, + -- and say: + -- + -- type A is array (...) of Holder; + -- + -- Each object of type Holder is allocated Max_Size_In_Storage_Elements + -- bytes. If you try to create a holder from an object of type Element_Type + -- that is too big, an exception is raised (assuming assertions are + -- enabled). This applies to To_Holder and Set. If you pass an Element_Type + -- object that is smaller than Max_Size_In_Storage_Elements, it works fine, + -- but some space is wasted. + -- + -- NOTE: If assertions are disabled, and you try to use an Element that is + -- too big, execution is erroneous, and anything can happen, such as + -- overwriting arbitrary memory locations. + -- + -- Element_Type must not be an unconstrained array type. It can be a + -- class-wide type or a type with non-defaulted discriminants. + -- + -- The 'Size of each Element_Type object must be a multiple of + -- System.Storage_Unit; e.g. creating Holders from 5-bit objects won't + -- work. + + type Holder is private; + + function "=" (Left, Right : Holder) return Boolean; + + function To_Holder (New_Item : Element_Type) return Holder; + function "+" (New_Item : Element_Type) return Holder renames To_Holder; + + function Get (Container : Holder) return Element_Type; + + procedure Set (Container : in out Holder; New_Item : Element_Type); + +private + + -- The implementation uses low-level tricks (Address clauses and unchecked + -- conversions of access types) to treat the elements as storage arrays. + + pragma Assert (Element_Type'Alignment <= Standard'Maximum_Alignment); + -- This prevents elements with a user-specified Alignment that is too big + + type Storage_Element is mod System.Storage_Unit; + type Storage_Array is array (Positive range <>) of Storage_Element; + type Holder is record + Data : Storage_Array (1 .. Max_Size_In_Storage_Elements); + end record + with Alignment => Standard'Maximum_Alignment; + -- We would like to say "Alignment => Element_Type'Alignment", but that + -- is illegal because it's not static, so we use the maximum possible + -- (default) alignment instead. + + type Element_Access is access all Element_Type; + pragma Assert (Element_Access'Size = Standard'Address_Size, + "cannot instantiate with an array type"); + -- If Element_Access is a fat pointer, Element_Type must be an + -- unconstrained array, which is not allowed. Arrays won't work, because + -- the 'Address of an array points to the first element, thus losing the + -- bounds. + + pragma No_Strict_Aliasing (Element_Access); + -- Needed because we are unchecked-converting from Address to + -- Element_Access (see package body), which is a violation of the + -- normal aliasing rules enforced by gcc. + +end Ada.Containers.Bounded_Holders; diff --git a/gcc/ada/libgnat/a-cobove.adb b/gcc/ada/libgnat/a-cobove.adb new file mode 100644 index 0000000..2d0770a --- /dev/null +++ b/gcc/ada/libgnat/a-cobove.adb @@ -0,0 +1,2805 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; + +with System; use type System.Address; + +package body Ada.Containers.Bounded_Vectors is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; + + --------- + -- "&" -- + --------- + + function "&" (Left, Right : Vector) return Vector is + LN : constant Count_Type := Length (Left); + RN : constant Count_Type := Length (Right); + N : Count_Type'Base; -- length of result + J : Count_Type'Base; -- for computing intermediate index values + Last : Index_Type'Base; -- Last index of result + + begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the vector parameters. We could decide to make it larger, but we + -- have no basis for knowing how much larger, so we just allocate the + -- minimum amount of storage. + + -- Here we handle the easy cases first, when one of the vector + -- parameters is empty. (We say "easy" because there's nothing to + -- compute, that can potentially overflow.) + + if LN = 0 then + if RN = 0 then + return Empty_Vector; + end if; + + return Vector'(Capacity => RN, + Elements => Right.Elements (1 .. RN), + Last => Right.Last, + others => <>); + end if; + + if RN = 0 then + return Vector'(Capacity => LN, + Elements => Left.Elements (1 .. LN), + Last => Left.Last, + others => <>); + end if; + + -- Neither of the vector parameters is empty, so must compute the length + -- of the result vector and its last index. (This is the harder case, + -- because our computations must avoid overflow.) + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the combined lengths. Note that we cannot + -- simply add the lengths, because of the possibility of overflow. + + if Checks and then LN > Count_Type'Last - RN then + raise Constraint_Error with "new length is out of range"; + end if; + + -- It is now safe to compute the length of the new vector, without fear + -- of overflow. + + N := LN + RN; + + -- The second constraint is that the new Last index value cannot + -- exceed Index_Type'Last. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (N) < No_Index + then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (N); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of length. + + J := Count_Type'Base (No_Index) + N; -- Last + + if Checks and then J > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (J); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + J := Count_Type'Base (Index_Type'Last) - N; -- No_Index + + if Checks and then J < Count_Type'Base (No_Index) then + raise Constraint_Error with "new length is out of range"; + end if; + + -- We have determined that the result length would not create a Last + -- index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + N); + end if; + + declare + LE : Elements_Array renames Left.Elements (1 .. LN); + RE : Elements_Array renames Right.Elements (1 .. RN); + + begin + return Vector'(Capacity => N, + Elements => LE & RE, + Last => Last, + others => <>); + end; + end "&"; + + function "&" (Left : Vector; Right : Element_Type) return Vector is + LN : constant Count_Type := Length (Left); + + begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last, and the + -- new Last index cannot exceed Index_Type'Last. + + if Checks and then LN = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Checks and then Left.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + return Vector'(Capacity => LN + 1, + Elements => Left.Elements (1 .. LN) & Right, + Last => Left.Last + 1, + others => <>); + end "&"; + + function "&" (Left : Element_Type; Right : Vector) return Vector is + RN : constant Count_Type := Length (Right); + + begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We compute the length of the result vector and its last index, but in + -- such a way that overflow is avoided. We must satisfy two constraints: + -- the new length cannot exceed Count_Type'Last, and the new Last index + -- cannot exceed Index_Type'Last. + + if Checks and then RN = Count_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + if Checks and then Right.Last >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + return Vector'(Capacity => 1 + RN, + Elements => Left & Right.Elements (1 .. RN), + Last => Right.Last + 1, + others => <>); + end "&"; + + function "&" (Left, Right : Element_Type) return Vector is + begin + -- We decide that the capacity of the result is the sum of the lengths + -- of the parameters. We could decide to make it larger, but we have no + -- basis for knowing how much larger, so we just allocate the minimum + -- amount of storage. + + -- We must compute the length of the result vector and its last index, + -- but in such a way that overflow is avoided. We must satisfy two + -- constraints: the new length cannot exceed Count_Type'Last (here, we + -- know that that condition is satisfied), and the new Last index cannot + -- exceed Index_Type'Last. + + if Checks and then Index_Type'First >= Index_Type'Last then + raise Constraint_Error with "new length is out of range"; + end if; + + return Vector'(Capacity => 2, + Elements => (Left, Right), + Last => Index_Type'First + 1, + others => <>); + end "&"; + + --------- + -- "=" -- + --------- + + overriding function "=" (Left, Right : Vector) return Boolean is + begin + if Left.Last /= Right.Last then + return False; + end if; + + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Count_Type range 1 .. Left.Length loop + if Left.Elements (J) /= Right.Elements (J) then + return False; + end if; + end loop; + end; + + return True; + end "="; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error -- ??? + with "Target capacity is less than Source length"; + end if; + + Target.Clear; + + Target.Elements (1 .. Source.Length) := + Source.Elements (1 .. Source.Length); + + Target.Last := Source.Last; + end Assign; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if New_Item.Is_Empty then + return; + end if; + + if Checks and then Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Container.Insert (Container.Last + 1, New_Item); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + end if; + + if Checks and then Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Container.Insert (Container.Last + 1, New_Item, Count); + end Append; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Count_Type is + begin + return Container.Elements'Length; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + TC_Check (Container.TC); + + Container.Last := No_Index; + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Checks and then Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + + declare + A : Elements_Array renames Container.Elements; + J : constant Count_Type := To_Array_Index (Position.Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + A : Elements_Array renames Container.Elements; + J : constant Count_Type := To_Array_Index (Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Count_Type := 0) return Vector + is + C : Count_Type; + + begin + if Capacity = 0 then + C := Source.Length; + + elsif Capacity >= Source.Length then + C := Capacity; + + elsif Checks then + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + return Target : Vector (C) do + Target.Elements (1 .. Source.Length) := + Source.Elements (1 .. Source.Length); + + Target.Last := Source.Last; + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + is + Old_Last : constant Index_Type'Base := Container.Last; + Old_Len : constant Count_Type := Container.Length; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + Off : Count_Type'Base; -- Index expressed as offset from IT'First + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Checks and then Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Checks and then Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + end if; + + return; + end if; + + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + + TC_Check (Container.TC); + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. + + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; + + -- There are some elements aren't being deleted (the requested count was + -- less than the available count), so we must slide them down to + -- Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Off := Count_Type'Base (Index - Index_Type'First); + New_Last := Old_Last - Index_Type'Base (Count); + else + Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + end if; + + -- The array index values for each slice have already been determined, + -- so we just slide down to Index the elements that weren't deleted. + + declare + EA : Elements_Array renames Container.Elements; + Idx : constant Count_Type := EA'First + Off; + begin + EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); + Container.Last := New_Last; + end; + end Delete; + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + is + pragma Warnings (Off, Position); + + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Checks and then Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + + elsif Count >= Length (Container) then + Clear (Container); + return; + + else + Delete (Container, Index_Type'First, Count); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + + if Count = 0 then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + + TC_Check (Container.TC); + + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + + if Count >= Container.Length then + Container.Last := No_Index; + + elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := Container.Last - Index_Type'Base (Count); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + else + return Container.Elements (To_Array_Index (Index)); + end if; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + else + return Position.Container.Element (Position.Index); + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + Unbusy (Object.Container.TC); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + begin + if Position.Container /= null then + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Checks and then Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for J in Position.Index .. Container.Last loop + if Container.Elements (To_Array_Index (J)) = Item then + return Cursor'(Container'Unrestricted_Access, J); + end if; + end loop; + + return No_Element; + end; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for Indx in Index .. Container.Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Find_Index; + + ----------- + -- First -- + ----------- + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + else + return (Container'Unrestricted_Access, Index_Type'First); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Index component influences the + -- behavior of the First (and Last) selector function. + + -- When the Index component is No_Index, this means the iterator + -- object was constructed without a start expression, in which case the + -- (forward) iteration starts from the (logical) beginning of the entire + -- sequence of items (corresponding to Container.First, for a forward + -- iterator). + + -- Otherwise, this is iteration over a partial sequence of items. + -- When the Index component isn't No_Index, the iterator object was + -- constructed with a start expression, that specifies the position + -- from which the (forward) partial iteration begins. + + if Object.Index = No_Index then + return First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Index); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Checks and then Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + return Container.Elements (To_Array_Index (Index_Type'First)); + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + begin + if Container.Last <= Index_Type'First then + return True; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + EA : Elements_Array renames Container.Elements; + begin + for J in 1 .. Container.Length - 1 loop + if EA (J + 1) < EA (J) then + return False; + end if; + end loop; + + return True; + end; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I, J : Count_Type; + + begin + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Is_Empty then + return; + end if; + + if Checks and then Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + + if Target.Is_Empty then + Move (Target => Target, Source => Source); + return; + end if; + + TC_Check (Source.TC); + + I := Target.Length; + Target.Set_Length (I + Source.Length); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + TA : Elements_Array renames Target.Elements; + SA : Elements_Array renames Source.Elements; + + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); + begin + J := Target.Length; + while not Source.Is_Empty loop + pragma Assert (Source.Length <= 1 + or else not (SA (Source.Length) < SA (Source.Length - 1))); + + if I = 0 then + TA (1 .. J) := SA (1 .. Source.Length); + Source.Last := No_Index; + exit; + end if; + + pragma Assert (I <= 1 + or else not (TA (I) < TA (I - 1))); + + if SA (Source.Length) < TA (I) then + TA (J) := TA (I); + I := I - 1; + + else + TA (J) := SA (Source.Length); + Source.Last := Source.Last - 1; + end if; + + J := J - 1; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Count_Type, + Element_Type => Element_Type, + Array_Type => Elements_Array, + "<" => "<"); + + begin + if Container.Last <= Index_Type'First then + return; + end if; + + -- The exception behavior for the vector container must match that + -- for the list container, so we check for cursor tampering here + -- (which will catch more things) instead of for element tampering + -- (which will catch fewer things). It's true that the elements of + -- this vector container could be safely moved around while (say) an + -- iteration is taking place (iteration only increments the busy + -- counter), and so technically all we would need here is a test for + -- element tampering (indicated by the lock counter), that's simply + -- an artifact of our array-based implementation. Logically Sort + -- requires a check for cursor tampering. + + TC_Check (Container.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Sort (Container.Elements (1 .. Container.Length)); + end; + end Sort; + + end Generic_Sorting; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements + (To_Array_Index (Position.Index))'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + end if; + + return Position.Index <= Position.Container.Last; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is + EA : Elements_Array renames Container.Elements; + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Checks and then Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Checks and then Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion + -- count. Note that we cannot simply add these values, because of the + -- possibility of overflow. + + if Checks and then Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= + Count_Type'Pos (Count_Type'Last) + then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if Checks and then New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + TC_Check (Container.TC); + + if Checks and then New_Length > Container.Capacity then + raise Capacity_Error with "New length is larger than capacity"; + end if; + + J := To_Array_Index (Before); + + if Before > Container.Last then + + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. + + EA (J .. New_Length) := (others => New_Item); + + else + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. + + EA (J + Count .. New_Length) := EA (J .. Old_Length); + EA (J .. J + Count - 1) := (others => New_Item); + end if; + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := No_Index + Index_Type'Base (New_Length); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + B : Count_Type; -- index Before converted to Count_Type + + begin + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. + + Insert_Space (Container, Before, Count => N); + + if N = 0 then + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; + end if; + + B := To_Array_Index (Before); + + if Container'Address /= New_Item'Address then + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. + + Container.Elements (B .. B + N - 1) := New_Item.Elements (1 .. N); + return; + end if; + + -- We refer to array index value Before + N - 1 as J. This is the last + -- index value of the destination slice. + + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The destination is always the + -- range [Before, J], but the source is [Index_Type'First, Before) and + -- (J, Container.Last]. We perform the copy in two steps, using each of + -- the two slices of the source items. + + declare + subtype Src_Index_Subtype is Count_Type'Base range 1 .. B - 1; + + Src : Elements_Array renames Container.Elements (Src_Index_Subtype); + + begin + -- We first copy the source items that precede the space we + -- inserted. (If Before equals Index_Type'First, then this first + -- source slice will be empty, which is harmless.) + + Container.Elements (B .. B + Src'Length - 1) := Src; + end; + + declare + subtype Src_Index_Subtype is Count_Type'Base range + B + N .. Container.Length; + + Src : Elements_Array renames Container.Elements (Src_Index_Subtype); + + begin + -- We next copy the source items that follow the space we inserted. + + Container.Elements (B + N - Src'Length .. B + N - 1) := Src; + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + EA : Elements_Array renames Container.Elements; + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Checks and then Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Checks and then Before > Container.Last + and then Before > Container.Last + 1 + then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion count. + -- Note that we cannot simply add these values, because of the + -- possibility of overflow. + + if Checks and then Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= + Count_Type'Pos (Count_Type'Last) + then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if Checks and then New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + TC_Check (Container.TC); + + -- An internal array has already been allocated, so we need to check + -- whether there is enough unused storage for the new items. + + if Checks and then New_Length > Container.Capacity then + raise Capacity_Error with "New length is larger than capacity"; + end if; + + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, and the existing array has enough + -- unused storage for the new items. + + if Before <= Container.Last then + + -- The space is being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. + + J := To_Array_Index (Before); + EA (J + Count .. New_Length) := EA (J .. Old_Length); + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := No_Index + Index_Type'Base (New_Length); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end Insert_Space; + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unchecked_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null + or else Before.Index > Container.Last + then + Position := No_Element; + else + Position := (Container'Unchecked_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null + or else Before.Index > Container.Last + then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert_Space (Container, Index, Count => Count); + + Position := Cursor'(Container'Unchecked_Access, Index); + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + end Iterate; + + function Iterate + (Container : Vector) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class + is + V : constant Vector_Access := Container'Unrestricted_Access; + begin + -- The value of its Index component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Index + -- component is No_Index (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => V, + Index => No_Index) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : Vector; + Start : Cursor) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class + is + V : constant Vector_Access := Container'Unrestricted_Access; + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start.Container = null then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= V then + raise Program_Error with + "Start cursor of Iterate designates wrong vector"; + end if; + + if Checks and then Start.Index > V.Last then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + -- The value of its Index component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Index + -- component is not No_Index (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => V, + Index => Start.Index) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + else + return (Container'Unrestricted_Access, Container.Last); + end if; + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Index component influences the + -- behavior of the Last (and First) selector function. + + -- When the Index component is No_Index, this means the iterator object + -- was constructed without a start expression, in which case the + -- (reverse) iteration starts from the (logical) beginning of the entire + -- sequence (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Index component is not No_Index, the iterator object was + -- constructed with a start expression, that specifies the position from + -- which the (reverse) partial iteration begins. + + if Object.Index = No_Index then + return Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Index); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Checks and then Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + return Container.Elements (Container.Length); + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Count_Type is + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Vector; + Source : in out Vector) + is + begin + if Target'Address = Source'Address then + return; + end if; + + if Checks and then Target.Capacity < Source.Length then + raise Capacity_Error -- ??? + with "Target capacity is less than Source length"; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + -- Clear Target now, in case element assignment fails + + Target.Last := No_Index; + + Target.Elements (1 .. Source.Length) := + Source.Elements (1 .. Source.Length); + + Target.Last := Source.Last; + Source.Last := No_Index; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Position.Index < Position.Container.Last then + return (Position.Container, Position.Index + 1); + else + return No_Element; + end if; + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong vector"; + end if; + + return Next (Position); + end Next; + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index < Position.Container.Last then + Position.Index := Position.Index + 1; + else + Position := No_Element; + end if; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, + Index_Type'First, + New_Item, + Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index > Index_Type'First then + Position.Index := Position.Index - 1; + else + Position := No_Element; + end if; + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Position.Index > Index_Type'First then + return (Position.Container, Position.Index - 1); + else + return No_Element; + end if; + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong vector"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + Lock : With_Lock (Container.TC'Unrestricted_Access); + V : Vector renames Container'Unrestricted_Access.all; + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + Process (V.Elements (To_Array_Index (Index))); + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + Query_Element (Position.Container.all, Position.Index, Process); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := No_Index; + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, Length); + + Reserve_Capacity (Container, Capacity => Length); + + for Idx in Count_Type range 1 .. Length loop + Last := Last + 1; + Element_Type'Read (Stream, Container.Elements (Idx)); + Container.Last := Last; + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Checks and then Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + + declare + A : Elements_Array renames Container.Elements; + J : constant Count_Type := To_Array_Index (Position.Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + A : Elements_Array renames Container.Elements; + J : constant Count_Type := To_Array_Index (Index); + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => A (J)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + TE_Check (Container.TC); + + Container.Elements (To_Array_Index (Index)) := New_Item; + end Replace_Element; + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Checks and then Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + + TE_Check (Container.TC); + + Container.Elements (To_Array_Index (Position.Index)) := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type) + is + begin + if Checks and then Capacity > Container.Capacity then + raise Capacity_Error with "Capacity is out of range"; + end if; + end Reserve_Capacity; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + E : Elements_Array renames Container.Elements; + Idx : Count_Type; + Jdx : Count_Type; + + begin + if Container.Length <= 1 then + return; + end if; + + -- The exception behavior for the vector container must match that for + -- the list container, so we check for cursor tampering here (which will + -- catch more things) instead of for element tampering (which will catch + -- fewer things). It's true that the elements of this vector container + -- could be safely moved around while (say) an iteration is taking place + -- (iteration only increments the busy counter), and so technically + -- all we would need here is a test for element tampering (indicated + -- by the lock counter), that's simply an artifact of our array-based + -- implementation. Logically Reverse_Elements requires a check for + -- cursor tampering. + + TC_Check (Container.TC); + + Idx := 1; + Jdx := Container.Length; + while Idx < Jdx loop + declare + EI : constant Element_Type := E (Idx); + + begin + E (Idx) := E (Jdx); + E (Jdx) := EI; + end; + + Idx := Idx + 1; + Jdx := Jdx - 1; + end loop; + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; + + begin + if Checks and then Position.Container /= null + and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + Last := + (if Position.Container = null or else Position.Index > Container.Last + then Container.Last + else Position.Index); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + return Cursor'(Container'Unrestricted_Access, Indx); + end if; + end loop; + + return No_Element; + end; + end Reverse_Find; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Last : constant Index_Type'Base := + Index_Type'Min (Container.Last, Index); + + begin + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements (To_Array_Index (Indx)) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Reverse_Find_Index; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + end Reverse_Iterate; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length (Container : in out Vector; Length : Count_Type) is + Count : constant Count_Type'Base := Container.Length - Length; + + begin + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less than the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. + + if Count >= 0 then + Container.Delete_Last (Count); + elsif Checks and then Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + else + Container.Insert_Space (Container.Last + 1, -Count); + end if; + end Set_Length; + + ---------- + -- Swap -- + ---------- + + procedure Swap (Container : in out Vector; I, J : Index_Type) is + E : Elements_Array renames Container.Elements; + + begin + if Checks and then I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if Checks and then J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + TE_Check (Container.TC); + + declare + EI_Copy : constant Element_Type := E (To_Array_Index (I)); + begin + E (To_Array_Index (I)) := E (To_Array_Index (J)); + E (To_Array_Index (J)) := EI_Copy; + end; + end Swap; + + procedure Swap (Container : in out Vector; I, J : Cursor) is + begin + if Checks and then I.Container = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then J.Container = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + end if; + + if Checks and then J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; + + Swap (Container, I.Index, J.Index); + end Swap; + + -------------------- + -- To_Array_Index -- + -------------------- + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is + Offset : Count_Type'Base; + + begin + -- We know that + -- Index >= Index_Type'First + -- hence we also know that + -- Index - Index_Type'First >= 0 + + -- The issue is that even though 0 is guaranteed to be a value in + -- the type Index_Type'Base, there's no guarantee that the difference + -- is a value in that type. To prevent overflow we use the wider + -- of Count_Type'Base and Index_Type'Base to perform intermediate + -- calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Offset := Count_Type'Base (Index - Index_Type'First); + + else + Offset := Count_Type'Base (Index) - + Count_Type'Base (Index_Type'First); + end if; + + -- The array index subtype for all container element arrays + -- always starts with 1. + + return 1 + Offset; + end To_Array_Index; + + --------------- + -- To_Cursor -- + --------------- + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is + begin + if Index not in Index_Type'First .. Container.Last then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Index); + end To_Cursor; + + -------------- + -- To_Index -- + -------------- + + function To_Index (Position : Cursor) return Extended_Index is + begin + if Position.Container = null then + return No_Index; + end if; + + if Position.Index <= Position.Container.Last then + return Position.Index; + end if; + + return No_Index; + end To_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector (Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + return V : Vector (Capacity => Length) do + V.Last := Last; + end return; + end To_Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector + is + Index : Count_Type'Base; + Last : Index_Type'Base; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + return V : Vector (Capacity => Length) do + V.Elements := (others => New_Item); + V.Last := Last; + end return; + end To_Vector; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)) + is + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + Process (Container.Elements (To_Array_Index (Index))); + end Update_Element; + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + Update_Element (Container, Position.Index, Process); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector) + is + N : Count_Type; + + begin + N := Container.Length; + Count_Type'Base'Write (Stream, N); + + for J in 1 .. N loop + Element_Type'Write (Stream, Container.Elements (J)); + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/libgnat/a-cobove.ads b/gcc/ada/libgnat/a-cobove.ads new file mode 100644 index 0000000..990dcd1 --- /dev/null +++ b/gcc/ada/libgnat/a-cobove.ads @@ -0,0 +1,506 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . B O U N D E D _ V E C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Streams; +private with Ada.Finalization; + +generic + type Index_Type is range <>; + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Bounded_Vectors is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + pragma Remote_Types; + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + + No_Index : constant Extended_Index := Extended_Index'First; + + type Vector (Capacity : Count_Type) is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package Vector_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + overriding function "=" (Left, Right : Vector) return Boolean; + + function To_Vector (Length : Count_Type) return Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector; + + function "&" (Left, Right : Vector) return Vector; + + function "&" (Left : Vector; Right : Element_Type) return Vector; + + function "&" (Left : Element_Type; Right : Vector) return Vector; + + function "&" (Left, Right : Element_Type) return Vector; + + function Capacity (Container : Vector) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type); + + function Length (Container : Vector) return Count_Type; + + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + + function Is_Empty (Container : Vector) return Boolean; + + procedure Clear (Container : in out Vector); + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor; + + function To_Index (Position : Cursor) return Extended_Index; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type); + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type; + + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type; + + procedure Assign (Target : in out Vector; Source : Vector); + + function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; + + procedure Move (Target : in out Vector; Source : in out Vector); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Vector); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out Vector; + New_Item : Vector); + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out Vector); + + procedure Swap (Container : in out Vector; I, J : Index_Type); + + procedure Swap (Container : in out Vector; I, J : Cursor); + + function First_Index (Container : Vector) return Index_Type; + + function First (Container : Vector) return Cursor; + + function First_Element (Container : Vector) return Element_Type; + + function Last_Index (Container : Vector) return Extended_Index; + + function Last (Container : Vector) return Cursor; + + function Last_Element (Container : Vector) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index; + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index; + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + function Iterate + (Container : Vector) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class; + + function Iterate + (Container : Vector; + Start : Cursor) + return Vector_Iterator_Interfaces.Reversible_Iterator'class; + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target : in out Vector; Source : in out Vector); + + end Generic_Sorting; + +private + + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Query_Element); + pragma Inline (Update_Element); + pragma Inline (Replace_Element); + pragma Inline (Is_Empty); + pragma Inline (Contains); + pragma Inline (Next); + pragma Inline (Previous); + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + use Ada.Streams; + use Ada.Finalization; + + type Elements_Array is array (Count_Type range <>) of aliased Element_Type; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Vector (Capacity : Count_Type) is tagged record + Elements : Elements_Array (1 .. Capacity) := (others => <>); + Last : Extended_Index := No_Index; + TC : aliased Tamper_Counts; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector); + + for Vector'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector); + + for Vector'Read use Read; + + type Vector_Access is access all Vector; + for Vector_Access'Storage_Size use 0; + + type Cursor is record + Container : Vector_Access; + Index : Index_Type := Index_Type'First; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Vector : constant Vector := (Capacity => 0, others => <>); + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type'Base; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Bounded_Vectors; diff --git a/gcc/ada/libgnat/a-cofove.adb b/gcc/ada/libgnat/a-cofove.adb new file mode 100644 index 0000000..63cbebb --- /dev/null +++ b/gcc/ada/libgnat/a-cofove.adb @@ -0,0 +1,1398 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Formal_Vectors with + SPARK_Mode => Off +is + + Growth_Factor : constant := 2; + -- When growing a container, multiply current capacity by this. Doubling + -- leads to amortized linear-time copying. + + type Int is range System.Min_Int .. System.Max_Int; + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Array, Elements_Array_Ptr); + + type Maximal_Array_Ptr is access all Elements_Array (Array_Index) + with Storage_Size => 0; + type Maximal_Array_Ptr_Const is access constant Elements_Array (Array_Index) + with Storage_Size => 0; + + function Elems (Container : in out Vector) return Maximal_Array_Ptr; + function Elemsc + (Container : Vector) return Maximal_Array_Ptr_Const; + -- Returns a pointer to the Elements array currently in use -- either + -- Container.Elements_Ptr or a pointer to Container.Elements. We work with + -- pointers to a bogus array subtype that is constrained with the maximum + -- possible bounds. This means that the pointer is a thin pointer. This is + -- necessary because 'Unrestricted_Access doesn't work when it produces + -- access-to-unconstrained and is returned from a function. + -- + -- Note that this is dangerous: make sure calls to this use an indexed + -- component or slice that is within the bounds 1 .. Length (Container). + + function Get_Element + (Container : Vector; + Position : Capacity_Range) return Element_Type; + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base; + + function Current_Capacity (Container : Vector) return Capacity_Range; + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + --------- + -- "=" -- + --------- + + function "=" (Left : Vector; Right : Vector) return Boolean is + begin + if Left'Address = Right'Address then + return True; + end if; + + if Length (Left) /= Length (Right) then + return False; + end if; + + for J in 1 .. Length (Left) loop + if Get_Element (Left, J) /= Get_Element (Right, J) then + return False; + end if; + end loop; + + return True; + end "="; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then + return; + end if; + + if Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert (Container, Container.Last + 1, New_Item); + end Append; + + procedure Append (Container : in out Vector; New_Item : Element_Type) is + begin + Append (Container, New_Item, 1); + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + is + begin + if Count = 0 then + return; + end if; + + if Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + end if; + + Insert (Container, Container.Last + 1, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + LS : constant Capacity_Range := Length (Source); + + begin + if Target'Address = Source'Address then + return; + end if; + + if Bounded and then Target.Capacity < LS then + raise Constraint_Error; + end if; + + Clear (Target); + Append (Target, Source); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Capacity_Range is + begin + return + (if Bounded then + Container.Capacity + else + Capacity_Range'Last); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + Container.Last := No_Index; + + -- Free element, note that this is OK if Elements_Ptr is null + + Free (Container.Elements_Ptr); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Capacity_Range := 0) return Vector + is + LS : constant Capacity_Range := Length (Source); + C : Capacity_Range; + + begin + if Capacity = 0 then + C := LS; + elsif Capacity >= LS then + C := Capacity; + else + raise Capacity_Error; + end if; + + return Target : Vector (C) do + Elems (Target) (1 .. LS) := Elemsc (Source) (1 .. LS); + Target.Last := Source.Last; + end return; + end Copy; + + ---------------------- + -- Current_Capacity -- + ---------------------- + + function Current_Capacity (Container : Vector) return Capacity_Range is + begin + return + (if Container.Elements_Ptr = null then + Container.Elements'Length + else + Container.Elements_Ptr.all'Length); + end Current_Capacity; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Vector; Index : Extended_Index) is + begin + Delete (Container, Index, 1); + end Delete; + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type) + is + Old_Last : constant Index_Type'Base := Container.Last; + Old_Len : constant Count_Type := Length (Container); + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + Off : Count_Type'Base; -- Index expressed as offset from IT'First + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + end if; + + return; + end if; + + if Count = 0 then + return; + end if; + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. + + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; + + -- There are some elements aren't being deleted (the requested count was + -- less than the available count), so we must slide them down to Index. + -- We first calculate the index values of the respective array slices, + -- using the wider of Index_Type'Base and Count_Type'Base as the type + -- for intermediate calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Off := Count_Type'Base (Index - Index_Type'First); + New_Last := Old_Last - Index_Type'Base (Count); + else + Off := Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + end if; + + -- The array index values for each slice have already been determined, + -- so we just slide down to Index the elements that weren't deleted. + + declare + EA : Maximal_Array_Ptr renames Elems (Container); + Idx : constant Count_Type := EA'First + Off; + begin + EA (Idx .. Old_Len - Count) := EA (Idx + Count .. Old_Len); + Container.Last := New_Last; + end; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Vector) is + begin + Delete_First (Container, 1); + end Delete_First; + + procedure Delete_First (Container : in out Vector; Count : Count_Type) is + begin + if Count = 0 then + return; + + elsif Count >= Length (Container) then + Clear (Container); + return; + + else + Delete (Container, Index_Type'First, Count); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Vector) is + begin + Delete_Last (Container, 1); + end Delete_Last; + + procedure Delete_Last (Container : in out Vector; Count : Count_Type) is + begin + if Count = 0 then + return; + end if; + + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + + if Count >= Length (Container) then + Container.Last := No_Index; + + elsif Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := Container.Last - Index_Type'Base (Count); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Capacity_Range := Capacity_Range (II); + begin + return Get_Element (Container, I); + end; + end Element; + + -------------- + -- Elements -- + -------------- + + function Elems (Container : in out Vector) return Maximal_Array_Ptr is + begin + return + (if Container.Elements_Ptr = null then + Container.Elements'Unrestricted_Access + else + Container.Elements_Ptr.all'Unrestricted_Access); + end Elems; + + function Elemsc (Container : Vector) return Maximal_Array_Ptr_Const is + begin + return + (if Container.Elements_Ptr = null then + Container.Elements'Unrestricted_Access + else + Container.Elements_Ptr.all'Unrestricted_Access); + end Elemsc; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + K : Capacity_Range; + Last : constant Index_Type := Last_Index (Container); + + begin + K := Capacity_Range (Int (Index) - Int (No_Index)); + for Indx in Index .. Last loop + if Get_Element (Container, K) = Item then + return Indx; + end if; + + K := K + 1; + end loop; + + return No_Index; + end Find_Index; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "Container is empty"; + else + return Get_Element (Container, 1); + end if; + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ------------------------- + -- M_Elements_In_Union -- + ------------------------- + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + is + Elem : Element_Type; + + begin + for Index in Index_Type'First .. M.Last (Container) loop + Elem := Element (Container, Index); + + if not M.Contains (Left, Index_Type'First, M.Last (Left), Elem) + and then + not M.Contains (Right, Index_Type'First, M.Last (Right), Elem) + then + return False; + end if; + end loop; + + return True; + end M_Elements_In_Union; + + ------------------------- + -- M_Elements_Included -- + ------------------------- + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Index_Type := Index_Type'First; + L_Lst : Extended_Index; + Right : M.Sequence; + R_Fst : Index_Type := Index_Type'First; + R_Lst : Extended_Index) return Boolean + is + begin + for I in L_Fst .. L_Lst loop + declare + Found : Boolean := False; + J : Extended_Index := R_Fst - 1; + + begin + while not Found and J < R_Lst loop + J := J + 1; + if Element (Left, I) = Element (Right, J) then + Found := True; + end if; + end loop; + + if not Found then + return False; + end if; + end; + end loop; + + return True; + end M_Elements_Included; + + ------------------------- + -- M_Elements_Reversed -- + ------------------------- + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + is + L : constant Index_Type := M.Last (Left); + + begin + if L /= M.Last (Right) then + return False; + end if; + + for I in Index_Type'First .. L loop + if Element (Left, I) /= Element (Right, L - I + 1) + then + return False; + end if; + end loop; + + return True; + end M_Elements_Reversed; + + ------------------------ + -- M_Elements_Swapted -- + ------------------------ + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Index_Type; + Y : Index_Type) return Boolean + is + begin + if M.Length (Left) /= M.Length (Right) + or else Element (Left, X) /= Element (Right, Y) + or else Element (Left, Y) /= Element (Right, X) + then + return False; + end if; + + for I in Index_Type'First .. M.Last (Left) loop + if I /= X and then I /= Y + and then Element (Left, I) /= Element (Right, I) + then + return False; + end if; + end loop; + + return True; + end M_Elements_Swapped; + + ----------- + -- Model -- + ----------- + + function Model (Container : Vector) return M.Sequence is + R : M.Sequence; + + begin + for Position in 1 .. Length (Container) loop + R := M.Add (R, Elemsc (Container) (Position)); + end loop; + + return R; + end Model; + + end Formal_Model; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting with SPARK_Mode => Off is + + ------------------ + -- Formal_Model -- + ------------------ + + package body Formal_Model is + + ----------------------- + -- M_Elements_Sorted -- + ----------------------- + + function M_Elements_Sorted (Container : M.Sequence) return Boolean is + begin + if M.Length (Container) = 0 then + return True; + end if; + + declare + E1 : Element_Type := Element (Container, Index_Type'First); + + begin + for I in Index_Type'First + 1 .. M.Last (Container) loop + declare + E2 : constant Element_Type := Element (Container, I); + + begin + if E2 < E1 then + return False; + end if; + + E1 := E2; + end; + end loop; + end; + + return True; + end M_Elements_Sorted; + + end Formal_Model; + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + L : constant Capacity_Range := Length (Container); + + begin + for J in 1 .. L - 1 loop + if Get_Element (Container, J + 1) < + Get_Element (Container, J) + then + return False; + end if; + end loop; + + return True; + end Is_Sorted; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Array_Index, + Element_Type => Element_Type, + Array_Type => Elements_Array, + "<" => "<"); + + Len : constant Capacity_Range := Length (Container); + + begin + if Container.Last <= Index_Type'First then + return; + else + Sort (Elems (Container) (1 .. Len)); + end if; + end Sort; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target : in out Vector; Source : in out Vector) is + I : Count_Type; + J : Count_Type; + + begin + if Target'Address = Source'Address then + raise Program_Error with "Target and Source denote same container"; + end if; + + if Length (Source) = 0 then + return; + end if; + + if Length (Target) = 0 then + Move (Target => Target, Source => Source); + return; + end if; + + I := Length (Target); + + declare + New_Length : constant Count_Type := I + Length (Source); + + begin + if not Bounded + and then Current_Capacity (Target) < Capacity_Range (New_Length) + then + Reserve_Capacity + (Target, + Capacity_Range'Max + (Current_Capacity (Target) * Growth_Factor, + Capacity_Range (New_Length))); + end if; + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Target.Last := No_Index + Index_Type'Base (New_Length); + + else + Target.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end; + + declare + TA : Maximal_Array_Ptr renames Elems (Target); + SA : Maximal_Array_Ptr renames Elems (Source); + + begin + J := Length (Target); + while Length (Source) /= 0 loop + if I = 0 then + TA (1 .. J) := SA (1 .. Length (Source)); + Source.Last := No_Index; + exit; + end if; + + if SA (Length (Source)) < TA (I) then + TA (J) := TA (I); + I := I - 1; + + else + TA (J) := SA (Length (Source)); + Source.Last := Source.Last - 1; + end if; + + J := J - 1; + end loop; + end; + end Merge; + + end Generic_Sorting; + + ----------------- + -- Get_Element -- + ----------------- + + function Get_Element + (Container : Vector; + Position : Capacity_Range) return Element_Type + is + begin + return Elemsc (Container) (Position); + end Get_Element; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element + (Container : Vector; + Position : Extended_Index) return Boolean + is + begin + return Position in First_Index (Container) .. Last_Index (Container); + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type) + is + begin + Insert (Container, Before, New_Item, 1); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type) + is + J : Count_Type'Base; -- scratch + + begin + -- Use Insert_Space to create the "hole" (the destination slice) + + Insert_Space (Container, Before, Count); + + J := To_Array_Index (Before); + + Elems (Container) (J .. J - 1 + Count) := (others => New_Item); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + B : Count_Type; -- index Before converted to Count_Type + + begin + if Container'Address = New_Item'Address then + raise Program_Error with + "Container and New_Item denote same container"; + end if; + + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. + + Insert_Space (Container, Before, Count => N); + + if N = 0 then + + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; + end if; + + B := To_Array_Index (Before); + + Elems (Container) (B .. B + N - 1) := Elemsc (New_Item) (1 .. N); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + Old_Length : constant Count_Type := Length (Container); + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + begin + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying where the new + -- items should be inserted, so we must manually check. (That the user + -- is allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for the + -- case of appending items to the back end of the vector. (It is assumed + -- that specifying an index value greater than Last + 1 indicates some + -- deeper flaw in the caller's algorithm, so that case is treated as a + -- proper error.) + + if Before > Container.Last + and then Before - 1 > Container.Last + then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + + -- We treat inserting 0 items into the container as a no-op, so we + -- simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion count. + -- Note that the value cannot be simply added because the result may + -- overflow. + + if Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= Count_Type'Pos (Count_Type'Last) + then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + J := To_Array_Index (Before); + + -- Increase the capacity of container if needed + + if not Bounded + and then Current_Capacity (Container) < Capacity_Range (New_Length) + then + Reserve_Capacity + (Container, + Capacity_Range'Max (Current_Capacity (Container) * Growth_Factor, + Capacity_Range (New_Length))); + end if; + + declare + EA : Maximal_Array_Ptr renames Elems (Container); + + begin + if Before <= Container.Last then + + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. + + EA (J + Count .. New_Length) := EA (J .. Old_Length); + end if; + end; + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Container.Last := No_Index + Index_Type'Base (New_Length); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Last_Index (Container) < Index_Type'First; + end Is_Empty; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Is_Empty (Container) then + raise Constraint_Error with "Container is empty"; + else + return Get_Element (Container, Length (Container)); + end if; + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Capacity_Range is + L : constant Int := Int (Container.Last); + F : constant Int := Int (Index_Type'First); + N : constant Int'Base := L - F + 1; + + begin + return Capacity_Range (N); + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Vector; Source : in out Vector) is + LS : constant Capacity_Range := Length (Source); + + begin + if Target'Address = Source'Address then + return; + end if; + + if Bounded and then Target.Capacity < LS then + raise Constraint_Error; + end if; + + Clear (Target); + Append (Target, Source); + Clear (Source); + end Move; + + ------------ + -- Prepend -- + ------------ + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend (Container : in out Vector; New_Item : Element_Type) is + begin + Prepend (Container, New_Item, 1); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + is + begin + Insert (Container, Index_Type'First, New_Item, Count); + end Prepend; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + II : constant Int'Base := Int (Index) - Int (No_Index); + I : constant Capacity_Range := Capacity_Range (II); + + begin + Elems (Container) (I) := New_Item; + end; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Capacity_Range) + is + begin + if Bounded then + if Capacity > Container.Capacity then + raise Constraint_Error with "Capacity is out of range"; + end if; + + else + if Capacity > Formal_Vectors.Current_Capacity (Container) then + declare + New_Elements : constant Elements_Array_Ptr := + new Elements_Array (1 .. Capacity); + L : constant Capacity_Range := Length (Container); + + begin + New_Elements (1 .. L) := Elemsc (Container) (1 .. L); + Free (Container.Elements_Ptr); + Container.Elements_Ptr := New_Elements; + end; + end if; + end if; + end Reserve_Capacity; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + begin + if Length (Container) <= 1 then + return; + end if; + + declare + I, J : Capacity_Range; + E : Elements_Array renames + Elems (Container) (1 .. Length (Container)); + + begin + I := 1; + J := Length (Container); + while I < J loop + declare + EI : constant Element_Type := E (I); + + begin + E (I) := E (J); + E (J) := EI; + end; + + I := I + 1; + J := J - 1; + end loop; + end; + end Reverse_Elements; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + Last : Index_Type'Base; + K : Capacity_Range; + + begin + if Index > Last_Index (Container) then + Last := Last_Index (Container); + else + Last := Index; + end if; + + K := Capacity_Range (Int (Last) - Int (No_Index)); + for Indx in reverse Index_Type'First .. Last loop + if Get_Element (Container, K) = Item then + return Indx; + end if; + + K := K - 1; + end loop; + + return No_Index; + end Reverse_Find_Index; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out Vector; + I : Index_Type; + J : Index_Type) + is + begin + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + + if I = J then + return; + end if; + + declare + II : constant Int'Base := Int (I) - Int (No_Index); + JJ : constant Int'Base := Int (J) - Int (No_Index); + + EI : Element_Type renames Elems (Container) (Capacity_Range (II)); + EJ : Element_Type renames Elems (Container) (Capacity_Range (JJ)); + + EI_Copy : constant Element_Type := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + -------------------- + -- To_Array_Index -- + -------------------- + + function To_Array_Index (Index : Index_Type'Base) return Count_Type'Base is + Offset : Count_Type'Base; + + begin + -- We know that + -- Index >= Index_Type'First + -- hence we also know that + -- Index - Index_Type'First >= 0 + + -- The issue is that even though 0 is guaranteed to be a value in + -- the type Index_Type'Base, there's no guarantee that the difference + -- is a value in that type. To prevent overflow we use the wider + -- of Count_Type'Base and Index_Type'Base to perform intermediate + -- calculations. + + if Index_Type'Base'Last >= Count_Type'Pos (Count_Type'Last) then + Offset := Count_Type'Base (Index - Index_Type'First); + + else + Offset := + Count_Type'Base (Index) - Count_Type'Base (Index_Type'First); + end if; + + -- The array index subtype for all container element arrays always + -- starts with 1. + + return 1 + Offset; + end To_Array_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector + (New_Item : Element_Type; + Length : Capacity_Range) return Vector + is + begin + if Length = 0 then + return Empty_Vector; + end if; + + declare + First : constant Int := Int (Index_Type'First); + Last_As_Int : constant Int'Base := First + Int (Length) - 1; + Last : Index_Type; + + begin + if Last_As_Int > Index_Type'Pos (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; -- ??? + end if; + + Last := Index_Type (Last_As_Int); + + return + (Capacity => Length, + Last => Last, + Elements_Ptr => <>, + Elements => (others => New_Item)); + end; + end To_Vector; + +end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/libgnat/a-cofove.ads b/gcc/ada/libgnat/a-cofove.ads new file mode 100644 index 0000000..681e513 --- /dev/null +++ b/gcc/ada/libgnat/a-cofove.ads @@ -0,0 +1,924 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . F O R M A L _ V E C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This spec is derived from package Ada.Containers.Bounded_Vectors in the Ada +-- 2012 RM. The modifications are meant to facilitate formal proofs by making +-- it easier to express properties, and by making the specification of this +-- unit compatible with SPARK 2014. Note that the API of this unit may be +-- subject to incompatible changes as SPARK 2014 evolves. + +with Ada.Containers.Functional_Vectors; + +generic + type Index_Type is range <>; + type Element_Type is private; + + Bounded : Boolean := True; + -- If True, the containers are bounded; the initial capacity is the maximum + -- size, and heap allocation will be avoided. If False, the containers can + -- grow via heap allocation. + +package Ada.Containers.Formal_Vectors with + SPARK_Mode +is + pragma Annotate (CodePeer, Skip_Analysis); + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + + No_Index : constant Extended_Index := Extended_Index'First; + + Last_Count : constant Count_Type := + (if Index_Type'Last < Index_Type'First then + 0 + elsif Index_Type'Last < -1 + or else Index_Type'Pos (Index_Type'First) > + Index_Type'Pos (Index_Type'Last) - Count_Type'Last + then + Index_Type'Pos (Index_Type'Last) - + Index_Type'Pos (Index_Type'First) + 1 + else + Count_Type'Last); + -- Maximal capacity of any vector. It is the minimum of the size of the + -- index range and the last possible Count_Type. + + subtype Capacity_Range is Count_Type range 0 .. Last_Count; + + type Vector (Capacity : Capacity_Range) is limited private with + Default_Initial_Condition => Is_Empty (Vector); + -- In the bounded case, Capacity is the capacity of the container, which + -- never changes. In the unbounded case, Capacity is the initial capacity + -- of the container, and operations such as Reserve_Capacity and Append can + -- increase the capacity. The capacity never shrinks, except in the case of + -- Clear. + -- + -- Note that all objects of type Vector are constrained, including in the + -- unbounded case; you can't assign from one object to another if the + -- Capacity is different. + + function Length (Container : Vector) return Capacity_Range with + Global => null, + Post => Length'Result <= Capacity (Container); + + pragma Unevaluated_Use_Of_Old (Allow); + + package Formal_Model with Ghost is + + package M is new Ada.Containers.Functional_Vectors + (Index_Type => Index_Type, + Element_Type => Element_Type); + + function "=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."="; + + function "<" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<"; + + function "<=" + (Left : M.Sequence; + Right : M.Sequence) return Boolean renames M."<="; + + function M_Elements_In_Union + (Container : M.Sequence; + Left : M.Sequence; + Right : M.Sequence) return Boolean + -- The elements of Container are contained in either Left or Right + with + Global => null, + Post => + M_Elements_In_Union'Result = + (for all I in Index_Type'First .. M.Last (Container) => + (for some J in Index_Type'First .. M.Last (Left) => + Element (Container, I) = Element (Left, J)) + or (for some J in Index_Type'First .. M.Last (Right) => + Element (Container, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_In_Union); + + function M_Elements_Included + (Left : M.Sequence; + L_Fst : Index_Type := Index_Type'First; + L_Lst : Extended_Index; + Right : M.Sequence; + R_Fst : Index_Type := Index_Type'First; + R_Lst : Extended_Index) return Boolean + -- The elements of the slice from L_Fst to L_Lst in Left are contained + -- in the slide from R_Fst to R_Lst in Right. + with + Global => null, + Pre => L_Lst <= M.Last (Left) and R_Lst <= M.Last (Right), + Post => + M_Elements_Included'Result = + (for all I in L_Fst .. L_Lst => + (for some J in R_Fst .. R_Lst => + Element (Left, I) = Element (Right, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Included); + + function M_Elements_Reversed + (Left : M.Sequence; + Right : M.Sequence) return Boolean + -- Right is Left in reverse order + with + Global => null, + Post => + M_Elements_Reversed'Result = + (M.Length (Left) = M.Length (Right) + and (for all I in Index_Type'First .. M.Last (Left) => + Element (Left, I) = + Element (Right, M.Last (Left) - I + 1)) + and (for all I in Index_Type'First .. M.Last (Right) => + Element (Right, I) = + Element (Left, M.Last (Left) - I + 1))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Reversed); + + function M_Elements_Swapped + (Left : M.Sequence; + Right : M.Sequence; + X : Index_Type; + Y : Index_Type) return Boolean + -- Elements stored at X and Y are reversed in Left and Right + with + Global => null, + Pre => X <= M.Last (Left) and Y <= M.Last (Left), + Post => + M_Elements_Swapped'Result = + (M.Length (Left) = M.Length (Right) + and Element (Left, X) = Element (Right, Y) + and Element (Left, Y) = Element (Right, X) + and M.Equal_Except (Left, Right, X, Y)); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Swapped); + + function Model (Container : Vector) return M.Sequence with + -- The high-level model of a vector is a sequence of elements. The + -- sequence really is similar to the vector itself. However, it is not + -- limited which allows usage of 'Old and 'Loop_Entry attributes. + + Ghost, + Global => null, + Post => M.Length (Model'Result) = Length (Container); + + function Element + (S : M.Sequence; + I : Index_Type) return Element_Type renames M.Get; + -- To improve readability of contracts, we rename the function used to + -- access an element in the model to Element. + + end Formal_Model; + use Formal_Model; + + function Empty_Vector return Vector with + Global => null, + Post => Length (Empty_Vector'Result) = 0; + + function "=" (Left, Right : Vector) return Boolean with + Global => null, + Post => "="'Result = (Model (Left) = Model (Right)); + + function To_Vector + (New_Item : Element_Type; + Length : Capacity_Range) return Vector + with + Global => null, + Post => + Formal_Vectors.Length (To_Vector'Result) = Length + and M.Constant_Range + (Container => Model (To_Vector'Result), + Fst => Index_Type'First, + Lst => Last_Index (To_Vector'Result), + Item => New_Item); + + function Capacity (Container : Vector) return Capacity_Range with + Global => null, + Post => + Capacity'Result = + (if Bounded then + Container.Capacity + else + Capacity_Range'Last); + pragma Annotate (GNATprove, Inline_For_Proof, Capacity); + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Capacity_Range) + with + Global => null, + Pre => (if Bounded then Capacity <= Container.Capacity), + Post => Model (Container) = Model (Container)'Old; + + function Is_Empty (Container : Vector) return Boolean with + Global => null, + Post => Is_Empty'Result = (Length (Container) = 0); + + procedure Clear (Container : in out Vector) with + Global => null, + Post => Length (Container) = 0; + -- Note that this reclaims storage in the unbounded case. You need to call + -- this before a container goes out of scope in order to avoid storage + -- leaks. In addition, "X := ..." can leak unless you Clear(X) first. + + procedure Assign (Target : in out Vector; Source : Vector) with + Global => null, + Pre => (if Bounded then Length (Source) <= Target.Capacity), + Post => Model (Target) = Model (Source); + + function Copy + (Source : Vector; + Capacity : Capacity_Range := 0) return Vector + with + Global => null, + Pre => (if Bounded then (Capacity = 0 or Length (Source) <= Capacity)), + Post => + Model (Copy'Result) = Model (Source) + and (if Capacity = 0 then + Copy'Result.Capacity = Length (Source) + else + Copy'Result.Capacity = Capacity); + + procedure Move (Target : in out Vector; Source : in out Vector) + with + Global => null, + Pre => (if Bounded then Length (Source) <= Capacity (Target)), + Post => Model (Target) = Model (Source)'Old and Length (Source) = 0; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + with + Global => null, + Pre => Index in First_Index (Container) .. Last_Index (Container), + Post => Element'Result = Element (Model (Container), Index); + pragma Annotate (GNATprove, Inline_For_Proof, Element); + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + with + Global => null, + Pre => Index in First_Index (Container) .. Last_Index (Container), + Post => + Length (Container) = Length (Container)'Old + + -- Container now has New_Item at index Index + + and Element (Model (Container), Index) = New_Item + + -- All other elements are preserved + + and M.Equal_Except + (Left => Model (Container)'Old, + Right => Model (Container), + Position => Index); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + with + Global => null, + Pre => + Length (Container) <= Capacity (Container) - Length (New_Item) + and (Before in Index_Type'First .. Last_Index (Container) + or (Before /= No_Index + and then Before - 1 = Last_Index (Container))), + Post => + Length (Container) = Length (Container)'Old + Length (New_Item) + + -- Elements located before Before in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Before - 1) + + -- Elements of New_Item are inserted at position Before + + and (if Length (New_Item) > 0 then + M.Range_Shifted + (Left => Model (New_Item), + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (New_Item), + Offset => Count_Type (Before - Index_Type'First))) + + -- Elements located after Before in Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Before, + Lst => Last_Index (Container)'Old, + Offset => Length (New_Item)); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type) + with + Global => null, + Pre => + Length (Container) < Capacity (Container) + and then (Before in Index_Type'First .. Last_Index (Container) + 1), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Elements located before Before in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Before - 1) + + -- Container now has New_Item at index Before + + and Element (Model (Container), Before) = New_Item + + -- Elements located after Before in Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Before, + Lst => Last_Index (Container)'Old, + Offset => 1); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => + Length (Container) <= Capacity (Container) - Count + and (Before in Index_Type'First .. Last_Index (Container) + or (Before /= No_Index + and then Before - 1 = Last_Index (Container))), + Post => + Length (Container) = Length (Container)'Old + Count + + -- Elements located before Before in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Before - 1) + + -- New_Item is inserted Count times at position Before + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Before, + Lst => Before + Index_Type'Base (Count - 1), + Item => New_Item)) + + -- Elements located after Before in Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Before, + Lst => Last_Index (Container)'Old, + Offset => Count); + + procedure Prepend (Container : in out Vector; New_Item : Vector) with + Global => null, + Pre => Length (Container) <= Capacity (Container) - Length (New_Item), + Post => + Length (Container) = Length (Container)'Old + Length (New_Item) + + -- Elements of New_Item are inserted at the beginning of Container + + and M.Range_Equal + (Left => Model (New_Item), + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (New_Item)) + + -- Elements of Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container)'Old, + Offset => Length (New_Item)); + + procedure Prepend (Container : in out Vector; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Capacity (Container), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Container now has New_Item at Index_Type'First + + and Element (Model (Container), Index_Type'First) = New_Item + + -- Elements of Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container)'Old, + Offset => 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Capacity (Container) - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- New_Item is inserted Count times at the beginning of Container + + and M.Constant_Range + (Container => Model (Container), + Fst => Index_Type'First, + Lst => Index_Type'First + Index_Type'Base (Count - 1), + Item => New_Item) + + -- Elements of Container are shifted + + and M.Range_Shifted + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container)'Old, + Offset => Count); + + procedure Append (Container : in out Vector; New_Item : Vector) with + Global => null, + Pre => + Length (Container) <= Capacity (Container) - Length (New_Item), + Post => + Length (Container) = Length (Container)'Old + Length (New_Item) + + -- The elements of Container are preserved + + and Model (Container)'Old <= Model (Container) + + -- Elements of New_Item are inserted at the end of Container + + and (if Length (New_Item) > 0 then + M.Range_Shifted + (Left => Model (New_Item), + Right => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (New_Item), + Offset => + Count_Type + (Last_Index (Container)'Old - Index_Type'First + 1))); + + procedure Append (Container : in out Vector; New_Item : Element_Type) with + Global => null, + Pre => Length (Container) < Capacity (Container), + Post => + Length (Container) = Length (Container)'Old + 1 + + -- Elements of Container are preserved + + and Model (Container)'Old < Model (Container) + + -- Container now has New_Item at the end of Container + + and Element + (Model (Container), Last_Index (Container)'Old + 1) = New_Item; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + with + Global => null, + Pre => Length (Container) <= Capacity (Container) - Count, + Post => + Length (Container) = Length (Container)'Old + Count + + -- Elements of Container are preserved + + and Model (Container)'Old <= Model (Container) + + -- New_Item is inserted Count times at the end of Container + + and (if Count > 0 then + M.Constant_Range + (Container => Model (Container), + Fst => Last_Index (Container)'Old + 1, + Lst => + Last_Index (Container)'Old + Index_Type'Base (Count), + Item => New_Item)); + + procedure Delete (Container : in out Vector; Index : Extended_Index) with + Global => null, + Pre => Index in First_Index (Container) .. Last_Index (Container), + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Elements located before Index in Container are preserved + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Index - 1) + + -- Elements located after Index in Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index, + Lst => Last_Index (Container), + Offset => 1); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type) + with + Global => null, + Pre => + Index in First_Index (Container) .. Last_Index (Container), + Post => + Length (Container) in + Length (Container)'Old - Count .. Length (Container)'Old + + -- The elements of Container located before Index are preserved. + + and M.Range_Equal + (Left => Model (Container)'Old, + Right => Model (Container), + Fst => Index_Type'First, + Lst => Index - 1), + + Contract_Cases => + + -- All the elements after Position have been erased + + (Length (Container) - Count <= Count_Type (Index - Index_Type'First) => + Length (Container) = Count_Type (Index - Index_Type'First), + + others => + Length (Container) = Length (Container)'Old - Count + + -- Other elements are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index, + Lst => Last_Index (Container), + Offset => Count)); + + procedure Delete_First (Container : in out Vector) with + Global => null, + Pre => Length (Container) > 0, + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Elements of Container are shifted by 1 + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index_Type'First, + Lst => Last_Index (Container), + Offset => 1); + + procedure Delete_First (Container : in out Vector; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements of Container have been erased + + (Length (Container) <= Count => Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- Elements of Container are shifted by Count + + and M.Range_Shifted + (Left => Model (Container), + Right => Model (Container)'Old, + Fst => Index_Type'First, + Lst => Last_Index (Container), + Offset => Count)); + + procedure Delete_Last (Container : in out Vector) with + Global => null, + Pre => Length (Container) > 0, + Post => + Length (Container) = Length (Container)'Old - 1 + + -- Elements of Container are preserved + + and Model (Container) < Model (Container)'Old; + + procedure Delete_Last (Container : in out Vector; Count : Count_Type) with + Global => null, + Contract_Cases => + + -- All the elements after Position have been erased + + (Length (Container) <= Count => Length (Container) = 0, + + others => + Length (Container) = Length (Container)'Old - Count + + -- The elements of Container are preserved + + and Model (Container) <= Model (Container)'Old); + + procedure Reverse_Elements (Container : in out Vector) with + Global => null, + Post => M_Elements_Reversed (Model (Container)'Old, Model (Container)); + + procedure Swap + (Container : in out Vector; + I : Index_Type; + J : Index_Type) + with + Global => null, + Pre => + I in First_Index (Container) .. Last_Index (Container) + and then J in First_Index (Container) .. Last_Index (Container), + Post => + M_Elements_Swapped (Model (Container)'Old, Model (Container), I, J); + + function First_Index (Container : Vector) return Index_Type with + Global => null, + Post => First_Index'Result = Index_Type'First; + pragma Annotate (GNATprove, Inline_For_Proof, First_Index); + + function First_Element (Container : Vector) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + First_Element'Result = Element (Model (Container), Index_Type'First); + pragma Annotate (GNATprove, Inline_For_Proof, First_Element); + + function Last_Index (Container : Vector) return Extended_Index with + Global => null, + Post => Last_Index'Result = M.Last (Model (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Last_Index); + + function Last_Element (Container : Vector) return Element_Type with + Global => null, + Pre => not Is_Empty (Container), + Post => + Last_Element'Result = + Element (Model (Container), Last_Index (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Last_Element); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + with + Global => null, + Contract_Cases => + + -- If Item is not contained in Container after Index, Find_Index + -- returns No_Index. + + (Index > Last_Index (Container) + or else not M.Contains + (Container => Model (Container), + Fst => Index, + Lst => Last_Index (Container), + Item => Item) + => + Find_Index'Result = No_Index, + + -- Otherwise, Find_Index returns a valid index greater than Index + + others => + Find_Index'Result in Index .. Last_Index (Container) + + -- The element at this index in Container is Item + + and Element (Model (Container), Find_Index'Result) = Item + + -- It is the first occurrence of Item after Index in Container + + and not M.Contains + (Container => Model (Container), + Fst => Index, + Lst => Find_Index'Result - 1, + Item => Item)); + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + with + Global => null, + Contract_Cases => + + -- If Item is not contained in Container before Index, + -- Reverse_Find_Index returns No_Index. + + (not M.Contains + (Container => Model (Container), + Fst => Index_Type'First, + Lst => (if Index <= Last_Index (Container) then Index + else Last_Index (Container)), + Item => Item) + => + Reverse_Find_Index'Result = No_Index, + + -- Otherwise, Reverse_Find_Index returns a valid index smaller than + -- Index + + others => + Reverse_Find_Index'Result in Index_Type'First .. Index + and Reverse_Find_Index'Result <= Last_Index (Container) + + -- The element at this index in Container is Item + + and Element (Model (Container), Reverse_Find_Index'Result) = Item + + -- It is the last occurrence of Item before Index in Container + + and not M.Contains + (Container => Model (Container), + Fst => Reverse_Find_Index'Result + 1, + Lst => + (if Index <= Last_Index (Container) then + Index + else + Last_Index (Container)), + Item => Item)); + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + with + Global => null, + Post => + Contains'Result = + M.Contains + (Container => Model (Container), + Fst => Index_Type'First, + Lst => Last_Index (Container), + Item => Item); + + function Has_Element + (Container : Vector; + Position : Extended_Index) return Boolean + with + Global => null, + Post => + Has_Element'Result = + (Position in Index_Type'First .. Last_Index (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Has_Element); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting with SPARK_Mode is + + package Formal_Model with Ghost is + + function M_Elements_Sorted (Container : M.Sequence) return Boolean + with + Global => null, + Post => + M_Elements_Sorted'Result = + (for all I in Index_Type'First .. M.Last (Container) => + (for all J in I .. M.Last (Container) => + Element (Container, I) = Element (Container, J) + or Element (Container, I) < Element (Container, J))); + pragma Annotate (GNATprove, Inline_For_Proof, M_Elements_Sorted); + + end Formal_Model; + use Formal_Model; + + function Is_Sorted (Container : Vector) return Boolean with + Global => null, + Post => Is_Sorted'Result = M_Elements_Sorted (Model (Container)); + + procedure Sort (Container : in out Vector) with + Global => null, + Post => + Length (Container) = Length (Container)'Old + and M_Elements_Sorted (Model (Container)) + and M_Elements_Included + (Left => Model (Container)'Old, + L_Lst => Last_Index (Container), + Right => Model (Container), + R_Lst => Last_Index (Container)) + and M_Elements_Included + (Left => Model (Container), + L_Lst => Last_Index (Container), + Right => Model (Container)'Old, + R_Lst => Last_Index (Container)); + + procedure Merge (Target : in out Vector; Source : in out Vector) with + -- Target and Source should not be aliased + Global => null, + Pre => Length (Source) <= Capacity (Target) - Length (Target), + Post => + Length (Target) = Length (Target)'Old + Length (Source)'Old + and Length (Source) = 0 + and (if M_Elements_Sorted (Model (Target)'Old) + and M_Elements_Sorted (Model (Source)'Old) + then + M_Elements_Sorted (Model (Target))) + and M_Elements_Included + (Left => Model (Target)'Old, + L_Lst => Last_Index (Target)'Old, + Right => Model (Target), + R_Lst => Last_Index (Target)) + and M_Elements_Included + (Left => Model (Source)'Old, + L_Lst => Last_Index (Source)'Old, + Right => Model (Target), + R_Lst => Last_Index (Target)) + and M_Elements_In_Union + (Model (Target), + Model (Source)'Old, + Model (Target)'Old); + end Generic_Sorting; + +private + pragma SPARK_Mode (Off); + + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Replace_Element); + pragma Inline (Contains); + + subtype Array_Index is Capacity_Range range 1 .. Capacity_Range'Last; + type Elements_Array is array (Array_Index range <>) of Element_Type; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Elements_Array_Ptr is access all Elements_Array; + + type Vector (Capacity : Capacity_Range) is limited record + + -- In the bounded case, the elements are stored in Elements. In the + -- unbounded case, the elements are initially stored in Elements, until + -- we run out of room, then we switch to Elements_Ptr. + + Last : Extended_Index := No_Index; + Elements_Ptr : Elements_Array_Ptr := null; + Elements : aliased Elements_Array (1 .. Capacity); + end record; + + -- The primary reason Vector is limited is that in the unbounded case, once + -- Elements_Ptr is in use, assignment statements won't work. "X := Y;" will + -- cause X and Y to share state; that is, X.Elements_Ptr = Y.Elements_Ptr, + -- so for example "Append (X, ...);" will modify BOTH X and Y. That would + -- allow SPARK to "prove" things that are false. We could fix that by + -- making Vector a controlled type, and override Adjust to make a deep + -- copy, but finalization is not allowed in SPARK. + -- + -- Note that (unfortunately) this means that 'Old and 'Loop_Entry are not + -- allowed on Vectors. + + function Empty_Vector return Vector is + ((Capacity => 0, others => <>)); + +end Ada.Containers.Formal_Vectors; diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb new file mode 100644 index 0000000..4e7ac38 --- /dev/null +++ b/gcc/ada/libgnat/a-cofuba.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_BASE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +package body Ada.Containers.Functional_Base with SPARK_Mode => Off is + + function To_Count (Idx : Extended_Index) return Count_Type is + (Count_Type + (Extended_Index'Pos (Idx) - + Extended_Index'Pos (Extended_Index'First))); + + function To_Index (Position : Count_Type) return Extended_Index is + (Extended_Index'Val + (Position + Extended_Index'Pos (Extended_Index'First))); + -- Conversion functions between Index_Type and Count_Type + + function Find (C : Container; E : access Element_Type) return Count_Type; + -- Search a container C for an element equal to E.all, returning the + -- position in the underlying array. + + --------- + -- "=" -- + --------- + + function "=" (C1 : Container; C2 : Container) return Boolean is + begin + if C1.Elements'Length /= C2.Elements'Length then + return False; + end if; + + for I in C1.Elements'Range loop + if C1.Elements (I).all /= C2.Elements (I).all then + return False; + end if; + end loop; + + return True; + end "="; + + ---------- + -- "<=" -- + ---------- + + function "<=" (C1 : Container; C2 : Container) return Boolean is + begin + for I in C1.Elements'Range loop + if Find (C2, C1.Elements (I)) = 0 then + return False; + end if; + end loop; + + return True; + end "<="; + + --------- + -- Add -- + --------- + + function Add + (C : Container; + I : Index_Type; + E : Element_Type) return Container + is + A : constant Element_Array_Access := + new Element_Array'(1 .. C.Elements'Last + 1 => <>); + P : Count_Type := 0; + + begin + for J in 1 .. C.Elements'Last + 1 loop + if J /= To_Count (I) then + P := P + 1; + A (J) := C.Elements (P); + else + A (J) := new Element_Type'(E); + end if; + end loop; + + return Container'(Elements => A); + end Add; + + ---------- + -- Find -- + ---------- + + function Find (C : Container; E : access Element_Type) return Count_Type is + begin + for I in C.Elements'Range loop + if C.Elements (I).all = E.all then + return I; + end if; + end loop; + + return 0; + end Find; + + function Find (C : Container; E : Element_Type) return Extended_Index is + (To_Index (Find (C, E'Unrestricted_Access))); + + --------- + -- Get -- + --------- + + function Get (C : Container; I : Index_Type) return Element_Type is + (C.Elements (To_Count (I)).all); + + ------------------ + -- Intersection -- + ------------------ + + function Intersection (C1 : Container; C2 : Container) return Container is + A : constant Element_Array_Access := + new Element_Array'(1 .. Num_Overlaps (C1, C2) => <>); + P : Count_Type := 0; + + begin + for I in C1.Elements'Range loop + if Find (C2, C1.Elements (I)) > 0 then + P := P + 1; + A (P) := C1.Elements (I); + end if; + end loop; + + return Container'(Elements => A); + end Intersection; + + ------------ + -- Length -- + ------------ + + function Length (C : Container) return Count_Type is (C.Elements'Length); + + --------------------- + -- Num_Overlaps -- + --------------------- + + function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type is + P : Count_Type := 0; + + begin + for I in C1.Elements'Range loop + if Find (C2, C1.Elements (I)) > 0 then + P := P + 1; + end if; + end loop; + + return P; + end Num_Overlaps; + + ------------ + -- Remove -- + ------------ + + function Remove (C : Container; I : Index_Type) return Container is + A : constant Element_Array_Access := + new Element_Array'(1 .. C.Elements'Last - 1 => <>); + P : Count_Type := 0; + + begin + for J in C.Elements'Range loop + if J /= To_Count (I) then + P := P + 1; + A (P) := C.Elements (J); + end if; + end loop; + + return Container'(Elements => A); + end Remove; + + --------- + -- Set -- + --------- + + function Set + (C : Container; + I : Index_Type; + E : Element_Type) return Container + is + Result : constant Container := + Container'(Elements => new Element_Array'(C.Elements.all)); + + begin + Result.Elements (To_Count (I)) := new Element_Type'(E); + return Result; + end Set; + + ----------- + -- Union -- + ----------- + + function Union (C1 : Container; C2 : Container) return Container is + N : constant Count_Type := Num_Overlaps (C1, C2); + + begin + -- if C2 is completely included in C1 then return C1 + + if N = Length (C2) then + return C1; + end if; + + -- else loop through C2 to find the remaining elements + + declare + L : constant Count_Type := Length (C1) - N + Length (C2); + A : constant Element_Array_Access := + new Element_Array' + (C1.Elements.all & (Length (C1) + 1 .. L => <>)); + P : Count_Type := Length (C1); + + begin + for I in C2.Elements'Range loop + if Find (C1, C2.Elements (I)) = 0 then + P := P + 1; + A (P) := C2.Elements (I); + end if; + end loop; + + return Container'(Elements => A); + end; + end Union; + +end Ada.Containers.Functional_Base; diff --git a/gcc/ada/libgnat/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads new file mode 100644 index 0000000..92bc6bd --- /dev/null +++ b/gcc/ada/libgnat/a-cofuba.ads @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_BASE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ +-- Functional containers are neither controlled nor limited. This is safe, as +-- no primitives are provided to modify them. +-- Memory allocated inside functional containers is never reclaimed. + +pragma Ada_2012; + +private generic + type Index_Type is (<>); + -- To avoid Constraint_Error being raised at run time, Index_Type'Base + -- should have at least one more element at the low end than Index_Type. + + type Element_Type (<>) is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Functional_Base with SPARK_Mode => Off is + + subtype Extended_Index is Index_Type'Base range + Index_Type'Pred (Index_Type'First) .. Index_Type'Last; + + type Container is private; + + function "=" (C1 : Container; C2 : Container) return Boolean; + -- Return True if C1 and C2 contain the same elements at the same position + + function Length (C : Container) return Count_Type; + -- Number of elements stored in C + + function Get (C : Container; I : Index_Type) return Element_Type; + -- Access to the element at index I in C + + function Set + (C : Container; + I : Index_Type; + E : Element_Type) return Container; + -- Return a new container which is equal to C except for the element at + -- index I, which is set to E. + + function Add + (C : Container; + I : Index_Type; + E : Element_Type) return Container; + -- Return a new container that is C with E inserted at index I + + function Remove (C : Container; I : Index_Type) return Container; + -- Return a new container that is C without the element at index I + + function Find (C : Container; E : Element_Type) return Extended_Index; + -- Return the first index for which the element stored in C is I. If there + -- are no such indexes, return Extended_Index'First. + + -------------------- + -- Set Operations -- + -------------------- + + function "<=" (C1 : Container; C2 : Container) return Boolean; + -- Return True if every element of C1 is in C2 + + function Num_Overlaps (C1 : Container; C2 : Container) return Count_Type; + -- Return the number of elements that are in both C1 and C2 + + function Union (C1 : Container; C2 : Container) return Container; + -- Return a container which is C1 plus all the elements of C2 that are not + -- in C1. + + function Intersection (C1 : Container; C2 : Container) return Container; + -- Return a container which is C1 minus all the elements that are also in + -- C2. + +private + + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + type Element_Access is access all Element_Type; + + type Element_Array is + array (Positive_Count_Type range <>) of Element_Access; + + type Element_Array_Access is not null access Element_Array; + + Empty_Element_Array_Access : constant Element_Array_Access := + new Element_Array'(1 .. 0 => null); + + type Container is record + Elements : Element_Array_Access := Empty_Element_Array_Access; + end record; + +end Ada.Containers.Functional_Base; diff --git a/gcc/ada/libgnat/a-cofuma.adb b/gcc/ada/libgnat/a-cofuma.adb new file mode 100644 index 0000000..93a38b5 --- /dev/null +++ b/gcc/ada/libgnat/a-cofuma.adb @@ -0,0 +1,284 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_MAPS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +package body Ada.Containers.Functional_Maps with SPARK_Mode => Off is + use Key_Containers; + use Element_Containers; + + --------- + -- "=" -- + --------- + + function "=" (Left : Map; Right : Map) return Boolean is + (Left.Keys <= Right.Keys and Right <= Left); + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left : Map; Right : Map) return Boolean is + I2 : Count_Type; + + begin + for I1 in 1 .. Length (Left.Keys) loop + I2 := Find (Right.Keys, Get (Left.Keys, I1)); + if I2 = 0 + or else Get (Right.Elements, I2) /= Get (Left.Elements, I1) + then + return False; + end if; + end loop; + return True; + end "<="; + + --------- + -- Add -- + --------- + + function Add + (Container : Map; + New_Key : Key_Type; + New_Item : Element_Type) return Map + is + begin + return + (Keys => + Add (Container.Keys, Length (Container.Keys) + 1, New_Key), + Elements => + Add + (Container.Elements, Length (Container.Elements) + 1, New_Item)); + end Add; + + --------------------------- + -- Elements_Equal_Except -- + --------------------------- + + function Elements_Equal_Except + (Left : Map; + Right : Map; + New_Key : Key_Type) return Boolean + is + begin + for I in 1 .. Length (Left.Keys) loop + declare + K : constant Key_Type := Get (Left.Keys, I); + begin + if not Equivalent_Keys (K, New_Key) + and then + (Find (Right.Keys, K) = 0 + or else Get (Right.Elements, Find (Right.Keys, K)) /= + Get (Left.Elements, I)) + then + return False; + end if; + end; + end loop; + return True; + end Elements_Equal_Except; + + function Elements_Equal_Except + (Left : Map; + Right : Map; + X : Key_Type; + Y : Key_Type) return Boolean + is + begin + for I in 1 .. Length (Left.Keys) loop + declare + K : constant Key_Type := Get (Left.Keys, I); + begin + if not Equivalent_Keys (K, X) + and then not Equivalent_Keys (K, Y) + and then + (Find (Right.Keys, K) = 0 + or else Get (Right.Elements, Find (Right.Keys, K)) /= + Get (Left.Elements, I)) + then + return False; + end if; + end; + end loop; + return True; + end Elements_Equal_Except; + + --------- + -- Get -- + --------- + + function Get (Container : Map; Key : Key_Type) return Element_Type is + begin + return Get (Container.Elements, Find (Container.Keys, Key)); + end Get; + + ------------- + -- Has_Key -- + ------------- + + function Has_Key (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container.Keys, Key) > 0; + end Has_Key; + + ----------------- + -- Has_Witness -- + ----------------- + + function Has_Witness + (Container : Map; + Witness : Count_Type) return Boolean + is + (Witness in 1 .. Length (Container.Keys)); + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Length (Container.Keys) = 0; + end Is_Empty; + + ------------------- + -- Keys_Included -- + ------------------- + + function Keys_Included (Left : Map; Right : Map) return Boolean is + begin + for I in 1 .. Length (Left.Keys) loop + declare + K : constant Key_Type := Get (Left.Keys, I); + begin + if Find (Right.Keys, K) = 0 then + return False; + end if; + end; + end loop; + + return True; + end Keys_Included; + + -------------------------- + -- Keys_Included_Except -- + -------------------------- + + function Keys_Included_Except + (Left : Map; + Right : Map; + New_Key : Key_Type) return Boolean + is + begin + for I in 1 .. Length (Left.Keys) loop + declare + K : constant Key_Type := Get (Left.Keys, I); + begin + if not Equivalent_Keys (K, New_Key) + and then Find (Right.Keys, K) = 0 + then + return False; + end if; + end; + end loop; + + return True; + end Keys_Included_Except; + + function Keys_Included_Except + (Left : Map; + Right : Map; + X : Key_Type; + Y : Key_Type) return Boolean + is + begin + for I in 1 .. Length (Left.Keys) loop + declare + K : constant Key_Type := Get (Left.Keys, I); + begin + if not Equivalent_Keys (K, X) + and then not Equivalent_Keys (K, Y) + and then Find (Right.Keys, K) = 0 + then + return False; + end if; + end; + end loop; + + return True; + end Keys_Included_Except; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Length (Container.Elements); + end Length; + + --------------- + -- Same_Keys -- + --------------- + + function Same_Keys (Left : Map; Right : Map) return Boolean is + (Keys_Included (Left, Right) + and Keys_Included (Left => Right, Right => Left)); + + --------- + -- Set -- + --------- + + function Set + (Container : Map; + Key : Key_Type; + New_Item : Element_Type) return Map + is + (Keys => Container.Keys, + Elements => + Set (Container.Elements, Find (Container.Keys, Key), New_Item)); + + ----------- + -- W_Get -- + ----------- + + function W_Get + (Container : Map; + Witness : Count_Type) return Element_Type + is + (Get (Container.Elements, Witness)); + + ------------- + -- Witness -- + ------------- + + function Witness (Container : Map; Key : Key_Type) return Count_Type is + (Find (Container.Keys, Key)); + +end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/libgnat/a-cofuma.ads b/gcc/ada/libgnat/a-cofuma.ads new file mode 100644 index 0000000..f98bfe7 --- /dev/null +++ b/gcc/ada/libgnat/a-cofuma.ads @@ -0,0 +1,361 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_MAPS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +private with Ada.Containers.Functional_Base; + +generic + type Key_Type (<>) is private; + type Element_Type (<>) is private; + + with function Equivalent_Keys + (Left : Key_Type; + Right : Key_Type) return Boolean is "="; + + Enable_Handling_Of_Equivalence : Boolean := True; + -- This constant should only be set to False when no particular handling + -- of equivalence over keys is needed, that is, Equivalent_Keys defines a + -- key uniquely. + +package Ada.Containers.Functional_Maps with SPARK_Mode is + + type Map is private with + Default_Initial_Condition => Is_Empty (Map) and Length (Map) = 0, + Iterable => (First => Iter_First, + Next => Iter_Next, + Has_Element => Iter_Has_Element, + Element => Iter_Element); + -- Maps are empty when default initialized. + -- "For in" quantification over maps should not be used. + -- "For of" quantification over maps iterates over keys. + -- Note that, for proof, "for of" quantification is understood modulo + -- equivalence (the range of quantification comprises all the keys that are + -- equivalent to any key of the map). + + ----------------------- + -- Basic operations -- + ----------------------- + + -- Maps are axiomatized using Has_Key and Get, encoding respectively the + -- presence of a key in a map and an accessor to elements associated with + -- its keys. The length of a map is also added to protect Add against + -- overflows but it is not actually modeled. + + function Has_Key (Container : Map; Key : Key_Type) return Boolean with + -- Return True if Key is present in Container + + Global => null, + Post => + (if Enable_Handling_Of_Equivalence then + + -- Has_Key returns the same result on all equivalent keys + + (if (for some K of Container => Equivalent_Keys (K, Key)) then + Has_Key'Result)); + + function Get (Container : Map; Key : Key_Type) return Element_Type with + -- Return the element associated with Key in Container + + Global => null, + Pre => Has_Key (Container, Key), + Post => + (if Enable_Handling_Of_Equivalence then + + -- Get returns the same result on all equivalent keys + + Get'Result = W_Get (Container, Witness (Container, Key)) + and (for all K of Container => + (Equivalent_Keys (K, Key) = + (Witness (Container, Key) = Witness (Container, K))))); + + function Length (Container : Map) return Count_Type with + Global => null; + -- Return the number of mappings in Container + + ------------------------ + -- Property Functions -- + ------------------------ + + function "<=" (Left : Map; Right : Map) return Boolean with + -- Map inclusion + + Global => null, + Post => + "<="'Result = + (for all Key of Left => + Has_Key (Right, Key) and then Get (Right, Key) = Get (Left, Key)); + + function "=" (Left : Map; Right : Map) return Boolean with + -- Extensional equality over maps + + Global => null, + Post => + "="'Result = + ((for all Key of Left => + Has_Key (Right, Key) + and then Get (Right, Key) = Get (Left, Key)) + and (for all Key of Right => Has_Key (Left, Key))); + + pragma Warnings (Off, "unused variable ""Key"""); + function Is_Empty (Container : Map) return Boolean with + -- A map is empty if it contains no key + + Global => null, + Post => Is_Empty'Result = (for all Key of Container => False); + pragma Warnings (On, "unused variable ""Key"""); + + function Keys_Included (Left : Map; Right : Map) return Boolean + -- Returns True if every Key of Left is in Right + + with + Global => null, + Post => + Keys_Included'Result = (for all Key of Left => Has_Key (Right, Key)); + + function Same_Keys (Left : Map; Right : Map) return Boolean + -- Returns True if Left and Right have the same keys + + with + Global => null, + Post => + Same_Keys'Result = + (Keys_Included (Left, Right) + and Keys_Included (Left => Right, Right => Left)); + pragma Annotate (GNATprove, Inline_For_Proof, Same_Keys); + + function Keys_Included_Except + (Left : Map; + Right : Map; + New_Key : Key_Type) return Boolean + -- Returns True if Left contains only keys of Right and possibly New_Key + + with + Global => null, + Post => + Keys_Included_Except'Result = + (for all Key of Left => + (if not Equivalent_Keys (Key, New_Key) then + Has_Key (Right, Key))); + + function Keys_Included_Except + (Left : Map; + Right : Map; + X : Key_Type; + Y : Key_Type) return Boolean + -- Returns True if Left contains only keys of Right and possibly X and Y + + with + Global => null, + Post => + Keys_Included_Except'Result = + (for all Key of Left => + (if not Equivalent_Keys (Key, X) + and not Equivalent_Keys (Key, Y) + then + Has_Key (Right, Key))); + + function Elements_Equal_Except + (Left : Map; + Right : Map; + New_Key : Key_Type) return Boolean + -- Returns True if all the keys of Left are mapped to the same elements in + -- Left and Right except New_Key. + + with + Global => null, + Post => + Elements_Equal_Except'Result = + (for all Key of Left => + (if not Equivalent_Keys (Key, New_Key) then + Has_Key (Right, Key) + and then Get (Left, Key) = Get (Right, Key))); + + function Elements_Equal_Except + (Left : Map; + Right : Map; + X : Key_Type; + Y : Key_Type) return Boolean + -- Returns True if all the keys of Left are mapped to the same elements in + -- Left and Right except X and Y. + + with + Global => null, + Post => + Elements_Equal_Except'Result = + (for all Key of Left => + (if not Equivalent_Keys (Key, X) + and not Equivalent_Keys (Key, Y) + then + Has_Key (Right, Key) + and then Get (Left, Key) = Get (Right, Key))); + + ---------------------------- + -- Construction Functions -- + ---------------------------- + + -- For better efficiency of both proofs and execution, avoid using + -- construction functions in annotations and rather use property functions. + + function Add + (Container : Map; + New_Key : Key_Type; + New_Item : Element_Type) return Map + -- Returns Container augmented with the mapping Key -> New_Item + + with + Global => null, + Pre => + not Has_Key (Container, New_Key) + and Length (Container) < Count_Type'Last, + Post => + Length (Container) + 1 = Length (Add'Result) + and Has_Key (Add'Result, New_Key) + and Get (Add'Result, New_Key) = New_Item + and Container <= Add'Result + and Keys_Included_Except (Add'Result, Container, New_Key); + + function Set + (Container : Map; + Key : Key_Type; + New_Item : Element_Type) return Map + -- Returns Container, where the element associated with Key has been + -- replaced by New_Item. + + with + Global => null, + Pre => Has_Key (Container, Key), + Post => + Length (Container) = Length (Set'Result) + and Get (Set'Result, Key) = New_Item + and Same_Keys (Container, Set'Result) + and Elements_Equal_Except (Container, Set'Result, Key); + + ------------------------------ + -- Handling of Equivalence -- + ------------------------------ + + -- These functions are used to specify that Get returns the same value on + -- equivalent keys. They should not be used directly in user code. + + function Has_Witness (Container : Map; Witness : Count_Type) return Boolean + with + Ghost, + Global => null; + -- Returns True if there is a key with witness Witness in Container + + function Witness (Container : Map; Key : Key_Type) return Count_Type with + -- Returns the witness of Key in Container + + Ghost, + Global => null, + Pre => Has_Key (Container, Key), + Post => Has_Witness (Container, Witness'Result); + + function W_Get (Container : Map; Witness : Count_Type) return Element_Type + with + -- Returns the element associated with a witness in Container + + Ghost, + Global => null, + Pre => Has_Witness (Container, Witness); + + --------------------------- + -- Iteration Primitives -- + --------------------------- + + type Private_Key is private; + + function Iter_First (Container : Map) return Private_Key with + Global => null; + + function Iter_Has_Element + (Container : Map; + Key : Private_Key) return Boolean + with + Global => null; + + function Iter_Next (Container : Map; Key : Private_Key) return Private_Key + with + Global => null, + Pre => Iter_Has_Element (Container, Key); + + function Iter_Element (Container : Map; Key : Private_Key) return Key_Type + with + Global => null, + Pre => Iter_Has_Element (Container, Key); + pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Has_Key); + +private + + pragma SPARK_Mode (Off); + + function "=" + (Left : Key_Type; + Right : Key_Type) return Boolean renames Equivalent_Keys; + + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + package Element_Containers is new Ada.Containers.Functional_Base + (Element_Type => Element_Type, + Index_Type => Positive_Count_Type); + + package Key_Containers is new Ada.Containers.Functional_Base + (Element_Type => Key_Type, + Index_Type => Positive_Count_Type); + + type Map is record + Keys : Key_Containers.Container; + Elements : Element_Containers.Container; + end record; + + type Private_Key is new Count_Type; + + function Iter_First (Container : Map) return Private_Key is (1); + + function Iter_Has_Element + (Container : Map; + Key : Private_Key) return Boolean + is + (Count_Type (Key) in 1 .. Key_Containers.Length (Container.Keys)); + + function Iter_Next + (Container : Map; + Key : Private_Key) return Private_Key + is + (if Key = Private_Key'Last then 0 else Key + 1); + + function Iter_Element + (Container : Map; + Key : Private_Key) return Key_Type + is + (Key_Containers.Get (Container.Keys, Count_Type (Key))); + +end Ada.Containers.Functional_Maps; diff --git a/gcc/ada/libgnat/a-cofuse.adb b/gcc/ada/libgnat/a-cofuse.adb new file mode 100644 index 0000000..22bf688 --- /dev/null +++ b/gcc/ada/libgnat/a-cofuse.adb @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_SETS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +pragma Ada_2012; + +package body Ada.Containers.Functional_Sets with SPARK_Mode => Off is + use Containers; + + --------- + -- "=" -- + --------- + + function "=" (Left : Set; Right : Set) return Boolean is + (Left.Content <= Right.Content and Right.Content <= Left.Content); + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left : Set; Right : Set) return Boolean is + (Left.Content <= Right.Content); + + --------- + -- Add -- + --------- + + function Add (Container : Set; Item : Element_Type) return Set is + (Content => + Add (Container.Content, Length (Container.Content) + 1, Item)); + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + (Find (Container.Content, Item) > 0); + + --------------------- + -- Included_Except -- + --------------------- + + function Included_Except + (Left : Set; + Right : Set; + Item : Element_Type) return Boolean + is + (for all E of Left => + Equivalent_Elements (E, Item) or Contains (Right, E)); + + ----------------------- + -- Included_In_Union -- + ----------------------- + + function Included_In_Union + (Container : Set; + Left : Set; + Right : Set) return Boolean + is + (for all Item of Container => + Contains (Left, Item) or Contains (Right, Item)); + + --------------------------- + -- Includes_Intersection -- + --------------------------- + + function Includes_Intersection + (Container : Set; + Left : Set; + Right : Set) return Boolean + is + (for all Item of Left => + (if Contains (Right, Item) then Contains (Container, Item))); + + ------------------ + -- Intersection -- + ------------------ + + function Intersection (Left : Set; Right : Set) return Set is + (Content => Intersection (Left.Content, Right.Content)); + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + (Length (Container.Content) = 0); + + ------------------ + -- Is_Singleton -- + ------------------ + + function Is_Singleton + (Container : Set; + New_Item : Element_Type) return Boolean + is + (Length (Container.Content) = 1 + and New_Item = Get (Container.Content, 1)); + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + (Length (Container.Content)); + + ----------------- + -- Not_In_Both -- + ----------------- + + function Not_In_Both + (Container : Set; + Left : Set; + Right : Set) return Boolean + is + (for all Item of Container => + not Contains (Right, Item) or not Contains (Left, Item)); + + ---------------- + -- No_Overlap -- + ---------------- + + function No_Overlap (Left : Set; Right : Set) return Boolean is + (Num_Overlaps (Left.Content, Right.Content) = 0); + + ------------------ + -- Num_Overlaps -- + ------------------ + + function Num_Overlaps (Left : Set; Right : Set) return Count_Type is + (Num_Overlaps (Left.Content, Right.Content)); + + ------------ + -- Remove -- + ------------ + + function Remove (Container : Set; Item : Element_Type) return Set is + (Content => Remove (Container.Content, Find (Container.Content, Item))); + + ----------- + -- Union -- + ----------- + + function Union (Left : Set; Right : Set) return Set is + (Content => Union (Left.Content, Right.Content)); + +end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/libgnat/a-cofuse.ads b/gcc/ada/libgnat/a-cofuse.ads new file mode 100644 index 0000000..5eafbc4 --- /dev/null +++ b/gcc/ada/libgnat/a-cofuse.ads @@ -0,0 +1,322 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_SETS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +private with Ada.Containers.Functional_Base; + +generic + type Element_Type (<>) is private; + + with function Equivalent_Elements + (Left : Element_Type; + Right : Element_Type) return Boolean is "="; + + Enable_Handling_Of_Equivalence : Boolean := True; + -- This constant should only be set to False when no particular handling + -- of equivalence over elements is needed, that is, Equivalent_Elements + -- defines an element uniquely. + +package Ada.Containers.Functional_Sets with SPARK_Mode is + + type Set is private with + Default_Initial_Condition => Is_Empty (Set), + Iterable => (First => Iter_First, + Next => Iter_Next, + Has_Element => Iter_Has_Element, + Element => Iter_Element); + -- Sets are empty when default initialized. + -- "For in" quantification over sets should not be used. + -- "For of" quantification over sets iterates over elements. + -- Note that, for proof, "for of" quantification is understood modulo + -- equivalence (the range of quantification comprises all the elements that + -- are equivalent to any element of the set). + + ----------------------- + -- Basic operations -- + ----------------------- + + -- Sets are axiomatized using Contains, which encodes whether an element is + -- contained in a set. The length of a set is also added to protect Add + -- against overflows but it is not actually modeled. + + function Contains (Container : Set; Item : Element_Type) return Boolean with + -- Return True if Item is contained in Container + + Global => null, + Post => + (if Enable_Handling_Of_Equivalence then + + -- Contains returns the same result on all equivalent elements + + (if (for some E of Container => Equivalent_Elements (E, Item)) then + Contains'Result)); + + function Length (Container : Set) return Count_Type with + Global => null; + -- Return the number of elements in Container + + ------------------------ + -- Property Functions -- + ------------------------ + + function "<=" (Left : Set; Right : Set) return Boolean with + -- Set inclusion + + Global => null, + Post => "<="'Result = (for all Item of Left => Contains (Right, Item)); + + function "=" (Left : Set; Right : Set) return Boolean with + -- Extensional equality over sets + + Global => null, + Post => "="'Result = (Left <= Right and Right <= Left); + + pragma Warnings (Off, "unused variable ""Item"""); + function Is_Empty (Container : Set) return Boolean with + -- A set is empty if it contains no element + + Global => null, + Post => + Is_Empty'Result = (for all Item of Container => False) + and Is_Empty'Result = (Length (Container) = 0); + pragma Warnings (On, "unused variable ""Item"""); + + function Included_Except + (Left : Set; + Right : Set; + Item : Element_Type) return Boolean + -- Return True if Left contains only elements of Right except possibly + -- Item. + + with + Global => null, + Post => + Included_Except'Result = + (for all E of Left => + Contains (Right, E) or Equivalent_Elements (E, Item)); + + function Includes_Intersection + (Container : Set; + Left : Set; + Right : Set) return Boolean + with + -- Return True if every element of the intersection of Left and Right is + -- in Container. + + Global => null, + Post => + Includes_Intersection'Result = + (for all Item of Left => + (if Contains (Right, Item) then Contains (Container, Item))); + + function Included_In_Union + (Container : Set; + Left : Set; + Right : Set) return Boolean + with + -- Return True if every element of Container is the union of Left and Right + + Global => null, + Post => + Included_In_Union'Result = + (for all Item of Container => + Contains (Left, Item) or Contains (Right, Item)); + + function Is_Singleton + (Container : Set; + New_Item : Element_Type) return Boolean + with + -- Return True Container only contains New_Item + + Global => null, + Post => + Is_Singleton'Result = + (for all Item of Container => Equivalent_Elements (Item, New_Item)); + + function Not_In_Both + (Container : Set; + Left : Set; + Right : Set) return Boolean + -- Return True if there are no elements in Container that are in Left and + -- Right. + + with + Global => null, + Post => + Not_In_Both'Result = + (for all Item of Container => + not Contains (Left, Item) or not Contains (Right, Item)); + + function No_Overlap (Left : Set; Right : Set) return Boolean with + -- Return True if there are no equivalent elements in Left and Right + + Global => null, + Post => + No_Overlap'Result = + (for all Item of Left => not Contains (Right, Item)); + + function Num_Overlaps (Left : Set; Right : Set) return Count_Type with + -- Number of elements that are both in Left and Right + + Global => null, + Post => + Num_Overlaps'Result = Length (Intersection (Left, Right)) + and (if Left <= Right then Num_Overlaps'Result = Length (Left) + else Num_Overlaps'Result < Length (Left)) + and (if Right <= Left then Num_Overlaps'Result = Length (Right) + else Num_Overlaps'Result < Length (Right)) + and (Num_Overlaps'Result = 0) = No_Overlap (Left, Right); + + ---------------------------- + -- Construction Functions -- + ---------------------------- + + -- For better efficiency of both proofs and execution, avoid using + -- construction functions in annotations and rather use property functions. + + function Add (Container : Set; Item : Element_Type) return Set with + -- Return a new set containing all the elements of Container plus E + + Global => null, + Pre => + not Contains (Container, Item) + and Length (Container) < Count_Type'Last, + Post => + Length (Add'Result) = Length (Container) + 1 + and Contains (Add'Result, Item) + and Container <= Add'Result + and Included_Except (Add'Result, Container, Item); + + function Remove (Container : Set; Item : Element_Type) return Set with + -- Return a new set containing all the elements of Container except E + + Global => null, + Pre => Contains (Container, Item), + Post => + Length (Remove'Result) = Length (Container) - 1 + and not Contains (Remove'Result, Item) + and Remove'Result <= Container + and Included_Except (Container, Remove'Result, Item); + + function Intersection (Left : Set; Right : Set) return Set with + -- Returns the intersection of Left and Right + + Global => null, + Post => + Intersection'Result <= Left + and Intersection'Result <= Right + and Includes_Intersection (Intersection'Result, Left, Right); + + function Union (Left : Set; Right : Set) return Set with + -- Returns the union of Left and Right + + Global => null, + Pre => + Length (Left) - Num_Overlaps (Left, Right) <= + Count_Type'Last - Length (Right), + Post => + Length (Union'Result) = + Length (Left) - Num_Overlaps (Left, Right) + Length (Right) + and Left <= Union'Result + and Right <= Union'Result + and Included_In_Union (Union'Result, Left, Right); + + --------------------------- + -- Iteration Primitives -- + --------------------------- + + type Private_Key is private; + + function Iter_First (Container : Set) return Private_Key with + Global => null; + + function Iter_Has_Element + (Container : Set; + Key : Private_Key) return Boolean + with + Global => null; + + function Iter_Next + (Container : Set; + Key : Private_Key) return Private_Key + with + Global => null, + Pre => Iter_Has_Element (Container, Key); + + function Iter_Element + (Container : Set; + Key : Private_Key) return Element_Type + with + Global => null, + Pre => Iter_Has_Element (Container, Key); + pragma Annotate (GNATprove, Iterable_For_Proof, "Contains", Contains); + +private + + pragma SPARK_Mode (Off); + + subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last; + + function "=" + (Left : Element_Type; + Right : Element_Type) return Boolean renames Equivalent_Elements; + + package Containers is new Ada.Containers.Functional_Base + (Element_Type => Element_Type, + Index_Type => Positive_Count_Type); + + type Set is record + Content : Containers.Container; + end record; + + type Private_Key is new Count_Type; + + function Iter_First (Container : Set) return Private_Key is (1); + + function Iter_Has_Element + (Container : Set; + Key : Private_Key) return Boolean + is + (Count_Type (Key) in 1 .. Containers.Length (Container.Content)); + + function Iter_Next + (Container : Set; + Key : Private_Key) return Private_Key + is + (if Key = Private_Key'Last then 0 else Key + 1); + + function Iter_Element + (Container : Set; + Key : Private_Key) return Element_Type + is + (Containers.Get (Container.Content, Count_Type (Key))); + +end Ada.Containers.Functional_Sets; diff --git a/gcc/ada/libgnat/a-cofuve.adb b/gcc/ada/libgnat/a-cofuve.adb new file mode 100644 index 0000000..2984bcc --- /dev/null +++ b/gcc/ada/libgnat/a-cofuve.adb @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_VECTORS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +package body Ada.Containers.Functional_Vectors with SPARK_Mode => Off is + use Containers; + + --------- + -- "<" -- + --------- + + function "<" (Left : Sequence; Right : Sequence) return Boolean is + (Length (Left.Content) < Length (Right.Content) + and then (for all I in Index_Type'First .. Last (Left) => + Get (Left.Content, I) = Get (Right.Content, I))); + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left : Sequence; Right : Sequence) return Boolean is + (Length (Left.Content) <= Length (Right.Content) + and then (for all I in Index_Type'First .. Last (Left) => + Get (Left.Content, I) = Get (Right.Content, I))); + + --------- + -- "=" -- + --------- + + function "=" (Left : Sequence; Right : Sequence) return Boolean is + (Left.Content = Right.Content); + + --------- + -- Add -- + --------- + + function Add + (Container : Sequence; + New_Item : Element_Type) return Sequence + is + (Content => + Add (Container.Content, + Index_Type'Val (Index_Type'Pos (Index_Type'First) + + Length (Container.Content)), + New_Item)); + + function Add + (Container : Sequence; + Position : Index_Type; + New_Item : Element_Type) return Sequence + is + (Content => Add (Container.Content, Position, New_Item)); + + -------------------- + -- Constant_Range -- + -------------------- + + function Constant_Range + (Container : Sequence; + Fst : Index_Type; + Lst : Extended_Index; + Item : Element_Type) return Boolean is + begin + for I in Fst .. Lst loop + if Get (Container.Content, I) /= Item then + return False; + end if; + end loop; + + return True; + end Constant_Range; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Sequence; + Fst : Index_Type; + Lst : Extended_Index; + Item : Element_Type) return Boolean + is + begin + for I in Fst .. Lst loop + if Get (Container.Content, I) = Item then + return True; + end if; + end loop; + + return False; + end Contains; + + ------------------ + -- Range_Except -- + ------------------ + + function Equal_Except + (Left : Sequence; + Right : Sequence; + Position : Index_Type) return Boolean + is + begin + if Length (Left.Content) /= Length (Right.Content) then + return False; + end if; + + for I in Index_Type'First .. Last (Left) loop + if I /= Position + and then Get (Left.Content, I) /= Get (Right.Content, I) + then + return False; + end if; + end loop; + + return True; + end Equal_Except; + + function Equal_Except + (Left : Sequence; + Right : Sequence; + X : Index_Type; + Y : Index_Type) return Boolean + is + begin + if Length (Left.Content) /= Length (Right.Content) then + return False; + end if; + + for I in Index_Type'First .. Last (Left) loop + if I /= X and then I /= Y + and then Get (Left.Content, I) /= Get (Right.Content, I) + then + return False; + end if; + end loop; + + return True; + end Equal_Except; + + --------- + -- Get -- + --------- + + function Get (Container : Sequence; + Position : Extended_Index) return Element_Type + is + (Get (Container.Content, Position)); + + ---------- + -- Last -- + ---------- + + function Last (Container : Sequence) return Extended_Index is + (Index_Type'Val + ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container))); + + ------------ + -- Length -- + ------------ + + function Length (Container : Sequence) return Count_Type is + (Length (Container.Content)); + + ----------------- + -- Range_Equal -- + ----------------- + + function Range_Equal + (Left : Sequence; + Right : Sequence; + Fst : Index_Type; + Lst : Extended_Index) return Boolean + is + begin + for I in Fst .. Lst loop + if Get (Left, I) /= Get (Right, I) then + return False; + end if; + end loop; + + return True; + end Range_Equal; + + ------------------- + -- Range_Shifted -- + ------------------- + + function Range_Shifted + (Left : Sequence; + Right : Sequence; + Fst : Index_Type; + Lst : Extended_Index; + Offset : Count_Type'Base) return Boolean + is + begin + for I in Fst .. Lst loop + if Get (Left, I) /= + Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset)) + then + return False; + end if; + end loop; + return True; + end Range_Shifted; + + ------------ + -- Remove -- + ------------ + + function Remove + (Container : Sequence; + Position : Index_Type) return Sequence + is + (Content => Remove (Container.Content, Position)); + + --------- + -- Set -- + --------- + + function Set + (Container : Sequence; + Position : Index_Type; + New_Item : Element_Type) return Sequence + is + (Content => Set (Container.Content, Position, New_Item)); + +end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/libgnat/a-cofuve.ads b/gcc/ada/libgnat/a-cofuve.ads new file mode 100644 index 0000000..b48330c --- /dev/null +++ b/gcc/ada/libgnat/a-cofuve.ads @@ -0,0 +1,393 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.FUNCTIONAL_VECTORS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2016-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +private with Ada.Containers.Functional_Base; + +generic + type Index_Type is (<>); + -- To avoid Constraint_Error being raised at run time, Index_Type'Base + -- should have at least one more element at the low end than Index_Type. + + type Element_Type (<>) is private; + +package Ada.Containers.Functional_Vectors with SPARK_Mode is + + subtype Extended_Index is Index_Type'Base range + Index_Type'Pred (Index_Type'First) .. Index_Type'Last; + -- Index_Type with one more element at the low end of the range. + -- This type is never used but it forces GNATprove to check that there is + -- room for one more element at the low end of Index_Type. + + type Sequence is private + with Default_Initial_Condition => Length (Sequence) = 0, + Iterable => (First => Iter_First, + Has_Element => Iter_Has_Element, + Next => Iter_Next, + Element => Get); + -- Sequences are empty when default initialized. + -- Quantification over sequences can be done using the regular + -- quantification over its range or directly on its elements with "for of". + + ----------------------- + -- Basic operations -- + ----------------------- + + -- Sequences are axiomatized using Length and Get, providing respectively + -- the length of a sequence and an accessor to its Nth element: + + function Length (Container : Sequence) return Count_Type with + -- Length of a sequence + + Global => null, + Post => + (Index_Type'Pos (Index_Type'First) - 1) + Length'Result <= + Index_Type'Pos (Index_Type'Last); + + function Get + (Container : Sequence; + Position : Extended_Index) return Element_Type + -- Access the Element at position Position in Container + + with + Global => null, + Pre => Position in Index_Type'First .. Last (Container); + + function Last (Container : Sequence) return Extended_Index with + -- Last index of a sequence + + Global => null, + Post => + Last'Result = + Index_Type'Val ((Index_Type'Pos (Index_Type'First) - 1) + + Length (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Last); + + function First return Extended_Index is (Index_Type'First); + -- First index of a sequence + + ------------------------ + -- Property Functions -- + ------------------------ + + function "=" (Left : Sequence; Right : Sequence) return Boolean with + -- Extensional equality over sequences + + Global => null, + Post => + "="'Result = + (Length (Left) = Length (Right) + and then (for all N in Index_Type'First .. Last (Left) => + Get (Left, N) = Get (Right, N))); + pragma Annotate (GNATprove, Inline_For_Proof, "="); + + function "<" (Left : Sequence; Right : Sequence) return Boolean with + -- Left is a strict subsequence of Right + + Global => null, + Post => + "<"'Result = + (Length (Left) < Length (Right) + and then (for all N in Index_Type'First .. Last (Left) => + Get (Left, N) = Get (Right, N))); + pragma Annotate (GNATprove, Inline_For_Proof, "<"); + + function "<=" (Left : Sequence; Right : Sequence) return Boolean with + -- Left is a subsequence of Right + + Global => null, + Post => + "<="'Result = + (Length (Left) <= Length (Right) + and then (for all N in Index_Type'First .. Last (Left) => + Get (Left, N) = Get (Right, N))); + pragma Annotate (GNATprove, Inline_For_Proof, "<="); + + function Contains + (Container : Sequence; + Fst : Index_Type; + Lst : Extended_Index; + Item : Element_Type) return Boolean + -- Returns True if Item occurs in the range from Fst to Lst of Container + + with + Global => null, + Pre => Lst <= Last (Container), + Post => + Contains'Result = + (for some I in Fst .. Lst => Get (Container, I) = Item); + pragma Annotate (GNATprove, Inline_For_Proof, Contains); + + function Constant_Range + (Container : Sequence; + Fst : Index_Type; + Lst : Extended_Index; + Item : Element_Type) return Boolean + -- Returns True if every element of the range from Fst to Lst of Container + -- is equal to Item. + + with + Global => null, + Pre => Lst <= Last (Container), + Post => + Constant_Range'Result = + (for all I in Fst .. Lst => Get (Container, I) = Item); + pragma Annotate (GNATprove, Inline_For_Proof, Constant_Range); + + function Equal_Except + (Left : Sequence; + Right : Sequence; + Position : Index_Type) return Boolean + -- Returns True is Left and Right are the same except at position Position + + with + Global => null, + Pre => Position <= Last (Left), + Post => + Equal_Except'Result = + (Length (Left) = Length (Right) + and then (for all I in Index_Type'First .. Last (Left) => + (if I /= Position then Get (Left, I) = Get (Right, I)))); + pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); + + function Equal_Except + (Left : Sequence; + Right : Sequence; + X : Index_Type; + Y : Index_Type) return Boolean + -- Returns True is Left and Right are the same except at positions X and Y + + with + Global => null, + Pre => X <= Last (Left) and Y <= Last (Left), + Post => + Equal_Except'Result = + (Length (Left) = Length (Right) + and then (for all I in Index_Type'First .. Last (Left) => + (if I /= X and I /= Y then + Get (Left, I) = Get (Right, I)))); + pragma Annotate (GNATprove, Inline_For_Proof, Equal_Except); + + function Range_Equal + (Left : Sequence; + Right : Sequence; + Fst : Index_Type; + Lst : Extended_Index) return Boolean + -- Returns True if the ranges from Fst to Lst contain the same elements in + -- Left and Right. + + with + Global => null, + Pre => Lst <= Last (Left) and Lst <= Last (Right), + Post => + Range_Equal'Result = + (for all I in Fst .. Lst => Get (Left, I) = Get (Right, I)); + pragma Annotate (GNATprove, Inline_For_Proof, Range_Equal); + + function Range_Shifted + (Left : Sequence; + Right : Sequence; + Fst : Index_Type; + Lst : Extended_Index; + Offset : Count_Type'Base) return Boolean + -- Returns True if the range from Fst to Lst in Left contains the same + -- elements as the range from Fst + Offset to Lst + Offset in Right. + + with + Global => null, + Pre => + Lst <= Last (Left) + and then + (if Offset < 0 then + Index_Type'Pos (Index_Type'Base'First) - Offset <= + Index_Type'Pos (Index_Type'First)) + and then + (if Fst <= Lst then + Offset in + Index_Type'Pos (Index_Type'First) - Index_Type'Pos (Fst) .. + (Index_Type'Pos (Index_Type'First) - 1) + Length (Right) - + Index_Type'Pos (Lst)), + Post => + Range_Shifted'Result = + ((for all I in Fst .. Lst => + Get (Left, I) = + Get (Right, Index_Type'Val (Index_Type'Pos (I) + Offset))) + and + (for all I in Index_Type'Val (Index_Type'Pos (Fst) + Offset) .. + Index_Type'Val (Index_Type'Pos (Lst) + Offset) + => + Get (Left, Index_Type'Val (Index_Type'Pos (I) - Offset)) = + Get (Right, I))); + pragma Annotate (GNATprove, Inline_For_Proof, Range_Shifted); + + ---------------------------- + -- Construction Functions -- + ---------------------------- + + -- For better efficiency of both proofs and execution, avoid using + -- construction functions in annotations and rather use property functions. + + function Set + (Container : Sequence; + Position : Index_Type; + New_Item : Element_Type) return Sequence + -- Returns a new sequence which contains the same elements as Container + -- except for the one at position Position which is replaced by New_Item. + + with + Global => null, + Pre => Position in Index_Type'First .. Last (Container), + Post => + Get (Set'Result, Position) = New_Item + and then Equal_Except (Container, Set'Result, Position); + + function Add (Container : Sequence; New_Item : Element_Type) return Sequence + -- Returns a new sequence which contains the same elements as Container + -- plus New_Item at the end. + + with + Global => null, + Pre => + Length (Container) < Count_Type'Last + and then Last (Container) < Index_Type'Last, + Post => + Length (Add'Result) = Length (Container) + 1 + and then Get (Add'Result, Last (Add'Result)) = New_Item + and then Container <= Add'Result; + + function Add + (Container : Sequence; + Position : Index_Type; + New_Item : Element_Type) return Sequence + with + -- Returns a new sequence which contains the same elements as Container + -- except that New_Item has been inserted at position Position. + + Global => null, + Pre => + Length (Container) < Count_Type'Last + and then Last (Container) < Index_Type'Last + and then Position <= Extended_Index'Succ (Last (Container)), + Post => + Length (Add'Result) = Length (Container) + 1 + and then Get (Add'Result, Position) = New_Item + and then Range_Equal + (Left => Container, + Right => Add'Result, + Fst => Index_Type'First, + Lst => Index_Type'Pred (Position)) + and then Range_Shifted + (Left => Container, + Right => Add'Result, + Fst => Position, + Lst => Last (Container), + Offset => 1); + + function Remove + (Container : Sequence; + Position : Index_Type) return Sequence + -- Returns a new sequence which contains the same elements as Container + -- except that the element at position Position has been removed. + + with + Global => null, + Pre => Position in Index_Type'First .. Last (Container), + Post => + Length (Remove'Result) = Length (Container) - 1 + and then Range_Equal + (Left => Container, + Right => Remove'Result, + Fst => Index_Type'First, + Lst => Index_Type'Pred (Position)) + and then Range_Shifted + (Left => Remove'Result, + Right => Container, + Fst => Position, + Lst => Last (Remove'Result), + Offset => 1); + + --------------------------- + -- Iteration Primitives -- + --------------------------- + + function Iter_First (Container : Sequence) return Extended_Index with + Global => null; + + function Iter_Has_Element + (Container : Sequence; + Position : Extended_Index) return Boolean + with + Global => null, + Post => + Iter_Has_Element'Result = + (Position in Index_Type'First .. Last (Container)); + pragma Annotate (GNATprove, Inline_For_Proof, Iter_Has_Element); + + function Iter_Next + (Container : Sequence; + Position : Extended_Index) return Extended_Index + with + Global => null, + Pre => Iter_Has_Element (Container, Position); + +private + + pragma SPARK_Mode (Off); + + package Containers is new Ada.Containers.Functional_Base + (Index_Type => Index_Type, + Element_Type => Element_Type); + + type Sequence is record + Content : Containers.Container; + end record; + + function Iter_First (Container : Sequence) return Extended_Index is + (Index_Type'First); + + function Iter_Next + (Container : Sequence; + Position : Extended_Index) return Extended_Index + is + (if Position = Extended_Index'Last then + Extended_Index'First + else + Extended_Index'Succ (Position)); + + function Iter_Has_Element + (Container : Sequence; + Position : Extended_Index) return Boolean + is + (Position in Index_Type'First .. + (Index_Type'Val + ((Index_Type'Pos (Index_Type'First) - 1) + Length (Container)))); + +end Ada.Containers.Functional_Vectors; diff --git a/gcc/ada/libgnat/a-cogeso.adb b/gcc/ada/libgnat/a-cogeso.adb new file mode 100644 index 0000000..e0a4267 --- /dev/null +++ b/gcc/ada/libgnat/a-cogeso.adb @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_SORT -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This algorithm was adapted from GNAT.Heap_Sort (see g-heasor.ad[sb]) + +with System; + +procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base) is + type T is range System.Min_Int .. System.Max_Int; + + function To_Index (J : T) return Index_Type; + pragma Inline (To_Index); + + function Lt (J, K : T) return Boolean; + pragma Inline (Lt); + + procedure Xchg (J, K : T); + pragma Inline (Xchg); + + procedure Sift (S : T); + + -------------- + -- To_Index -- + -------------- + + function To_Index (J : T) return Index_Type is + K : constant T'Base := Index_Type'Pos (First) + J - T'(1); + begin + return Index_Type'Val (K); + end To_Index; + + -------- + -- Lt -- + -------- + + function Lt (J, K : T) return Boolean is + begin + return Before (To_Index (J), To_Index (K)); + end Lt; + + ---------- + -- Xchg -- + ---------- + + procedure Xchg (J, K : T) is + begin + Swap (To_Index (J), To_Index (K)); + end Xchg; + + Max : T := Index_Type'Pos (Last) - Index_Type'Pos (First) + T'(1); + + ---------- + -- Sift -- + ---------- + + procedure Sift (S : T) is + C : T := S; + Son : T; + Father : T; + + begin + loop + Son := C + C; + + if Son < Max then + if Lt (Son, Son + 1) then + Son := Son + 1; + end if; + elsif Son > Max then + exit; + end if; + + Xchg (Son, C); + C := Son; + end loop; + + while C /= S loop + Father := C / 2; + + if Lt (Father, C) then + Xchg (Father, C); + C := Father; + else + exit; + end if; + end loop; + end Sift; + +-- Start of processing for Generic_Sort + +begin + for J in reverse 1 .. Max / 2 loop + Sift (J); + end loop; + + while Max > 1 loop + Xchg (1, Max); + Max := Max - 1; + Sift (1); + end loop; +end Ada.Containers.Generic_Sort; diff --git a/gcc/ada/libgnat/a-cogeso.ads b/gcc/ada/libgnat/a-cogeso.ads new file mode 100644 index 0000000..1151c81 --- /dev/null +++ b/gcc/ada/libgnat/a-cogeso.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.GENERIC_SORT -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Allows an anonymous array (or array-like container) to be sorted. Generic +-- formal Before returns the result of comparing the elements designated by +-- the indexes, and generic formal Swap exchanges the designated elements. + +generic + type Index_Type is (<>); + with function Before (Left, Right : Index_Type) return Boolean; + with procedure Swap (Left, Right : Index_Type); + +procedure Ada.Containers.Generic_Sort (First, Last : Index_Type'Base); +pragma Pure (Ada.Containers.Generic_Sort); diff --git a/gcc/ada/libgnat/a-cohama.adb b/gcc/ada/libgnat/a-cohama.adb new file mode 100644 index 0000000..4ead925 --- /dev/null +++ b/gcc/ada/libgnat/a-cohama.adb @@ -0,0 +1,1200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with System; use type System.Address; + +package body Ada.Containers.Hashed_Maps is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node + (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Key_Node); + + procedure Free (X : in out Node_Access); + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Key_Ops is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key); + + procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node); + procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Map) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key, New_Item => Node.Element); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + + if Target.Capacity < Source.Length then + Target.Reserve_Capacity (Source.Length); + end if; + + Insert_Items (Source.HT); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Map) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Map) is + begin + HT_Ops.Clear (Container.HT); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in Constant_Reference is bad"); + + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + declare + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Map; + Capacity : Count_Type := 0) return Map + is + C : Count_Type; + + begin + if Capacity < Source.Length then + if Checks and then Capacity /= 0 then + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + C := Source.Length; + else + C := Capacity; + end if; + + return Target : Map do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node + (Source : Node_Access) return Node_Access + is + Target : constant Node_Access := + new Node_Type'(Key => Source.Key, + Element => Source.Element, + Next => null); + begin + return Target; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access; + + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + + if Checks and then X = null then + raise Constraint_Error with "attempt to delete key not in map"; + end if; + + Free (X); + end Delete; + + procedure Delete (Container : in out Map; Position : in out Cursor) is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + TC_Check (Container.HT.TC); + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); + Position.Container := null; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Map; Key : Key_Type) return Element_Type is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "no element available because key not in map"; + end if; + + return Node.Element; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + return Position.Node.Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean is + begin + return Equivalent_Keys (Key, Node.Key); + end Equivalent_Key_Node; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Cursor) + return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad"); + pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); + + return Equivalent_Keys (Left.Node.Key, Right.Node.Key); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad"); + + return Equivalent_Keys (Left.Node.Key, Right); + end Equivalent_Keys; + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Keys equals No_Element"; + end if; + + pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad"); + + return Equivalent_Keys (Left, Right.Node.Key); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access; + begin + Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Map) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.HT.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); + end Find; + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key); + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + while R_Node /= null loop + if Equivalent_Keys (L_Node.Key, R_Node.Key) then + return L_Node.Element = R_Node.Element; + end if; + + R_Node := R_Node.Next; + end loop; + + return False; + end Find_Equal_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + Pos : Hash_Type; + Node : constant Node_Access := HT_Ops.First (Container.HT, Pos); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node, Pos); + end First; + + function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + X.Next := X; -- detect mischief (in Vet) + Deallocate (X); + end if; + end Free; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Key); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.HT.TC); + + Position.Node.Key := Key; + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + begin + return new Node_Type'(Key => Key, + Element => <>, + Next => Next); + end New_Node; + + HT : Hash_Table_Type renames Container.HT; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Key_Ops.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + begin + return new Node_Type'(Key, New_Item, Next); + end New_Node; + + HT : Hash_Table_Type renames Container.HT; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + Local_Insert (HT, Key, Position.Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert key already in map"; + end if; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.HT.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access; Position : Hash_Type); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new HT_Ops.Generic_Iteration_With_Position (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access; Position : Hash_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node, Position)); + end Process_Node; + + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.HT); + end Iterate; + + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return It : constant Iterator := + (Limited_Controlled with Container => Container'Unrestricted_Access) + do + Busy (Container.HT.TC'Unrestricted_Access.all); + end return; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + + return Position.Node.Key; + end Key; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.HT.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Map; + Source : in out Map) + is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + Node : Node_Access := null; + + Pos : Hash_Type; + -- Position of cursor's element in the map buckets. + begin + if Position.Node = null then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Next"); + + -- Initialize to current position, so that HT_Ops.Next can use it + Pos := Position.Position; + + Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos); + + if Node = null then + return No_Element; + else + return Cursor'(Position.Container, Node, Pos); + end if; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); + end Next; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + M : Map renames Position.Container.all; + HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all; + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + begin + Process (K, E); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert + (Vet (Position), + "Position cursor in function Reference is bad"); + + declare + HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + HT : Hash_Table_Type renames Container.HT; + Node : constant Node_Access := Key_Ops.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + declare + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + return Node; + + exception + when others => + Free (Node); + raise; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container.HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace key not in map"; + end if; + + TE_Check (Container.HT.TC); + + Node.Key := Key; + Node.Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + TE_Check (Position.Container.HT.TC); + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Position.Node.Element := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Map; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + HT : Hash_Table_Type renames Container.HT; + Lock : With_Lock (HT.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + begin + Process (K, E); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + +end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cohama.ads b/gcc/ada/libgnat/a-cohama.ads new file mode 100644 index 0000000..8a6f8c2 --- /dev/null +++ b/gcc/ada/libgnat/a-cohama.ads @@ -0,0 +1,470 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Hash_Tables; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Key_Type is private; + type Element_Type is private; + + with function Hash (Key : Key_Type) return Hash_Type; + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Hashed_Maps is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type Map is tagged private + with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Map); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + -- Map objects declared without an initialization expression are + -- initialized to the value Empty_Map. + + No_Element : constant Cursor; + -- Cursor objects declared without an initialization expression are + -- initialized to the value No_Element. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Map_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Map) return Boolean; + -- For each key/element pair in Left, equality attempts to find the key in + -- Right; if a search fails the equality returns False. The search works by + -- calling Hash to find the bucket in the Right map that corresponds to the + -- Left key. If bucket is non-empty, then equality calls Equivalent_Keys + -- to compare the key (in Left) to the key of each node in the bucket (in + -- Right); if the keys are equivalent, then the equality test for this + -- key/element pair (in Left) completes by calling the element equality + -- operator to compare the element (in Left) to the element of the node + -- (in Right) whose key matched. + + function Capacity (Container : Map) return Count_Type; + -- Returns the current capacity of the map. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Map; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing key in order to + -- compute the new index), and then the old buckets array is deallocated. + + function Length (Container : Map) return Count_Type; + -- Returns the number of items in the map + + function Is_Empty (Container : Map) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Map); + -- Removes all of the items from the map + + function Key (Position : Cursor) return Key_Type; + -- Returns the key of the node designated by the cursor + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + -- Assigns the value New_Item to the element designated by the cursor + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + -- Calls Process with the key and element (both having only a constant + -- view) of the node designed by the cursor. + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + -- Calls Process with the key (with only a constant view) and element (with + -- a variable view) of the node designed by the cursor. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map; Capacity : Count_Type := 0) return Map; + + procedure Move (Target : in out Map; Source : in out Map); + -- Clears Target (if it's not empty), and then moves (not copies) the + -- buckets array and nodes from Source to Target. + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + -- Conditionally inserts New_Item into the map. If Key is already in the + -- map, then Inserted returns False and Position designates the node + -- containing the existing key/element pair (neither of which is modified). + -- If Key is not already in the map, the Inserted returns True and Position + -- designates the newly-inserted node container Key and New_Item. The + -- search for the key works as follows. Hash is called to determine Key's + -- bucket; if the bucket is non-empty, then Equivalent_Keys is called to + -- compare Key to each node in that bucket. If the bucket is empty, or + -- there were no matching keys in the bucket, the search "fails" and the + -- key/item pair is inserted in the map (and Inserted returns True); + -- otherwise, the search "succeeds" (and Inserted returns False). + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + -- The same as the (conditional) Insert that accepts an element parameter, + -- with the difference that if Inserted returns True, then the element of + -- the newly-inserted node is initialized to its default value. + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map, performing the usual search (which + -- involves calling both Hash and Equivalent_Keys); if the search succeeds + -- (because Key is already in the map), then it raises Constraint_Error. + -- (This version of Insert is similar to Replace, but having the opposite + -- exception behavior. It is intended for use when you want to assert that + -- Key is not already in the map.) + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Attempts to insert Key into the map. If Key is already in the map, then + -- both the existing key and element are assigned the values of Key and + -- New_Item, respectively. (This version of Insert only raises an exception + -- if cursor tampering occurs. It is intended for use when you want to + -- insert the key/element pair in the map, and you don't care whether Key + -- is already present.) + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + -- Searches for Key in the map; if the search fails (because Key was not in + -- the map), then it raises Constraint_Error. Otherwise, both the existing + -- key and element are assigned the values of Key and New_Item rsp. (This + -- is similar to Insert, but with the opposite exception behavior. It is to + -- be used when you want to assert that Key is already in the map.) + + procedure Exclude (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map, and if found, removes its node from the map + -- and then deallocates it. The search works as follows. The operation + -- calls Hash to determine the key's bucket; if the bucket is not empty, it + -- calls Equivalent_Keys to compare Key to each key in the bucket. (This is + -- the deletion analog of Include. It is intended for use when you want to + -- remove the item from the map, but don't care whether the key is already + -- in the map.) + + procedure Delete (Container : in out Map; Key : Key_Type); + -- Searches for Key in the map (which involves calling both Hash and + -- Equivalent_Keys). If the search fails, then the operation raises + -- Constraint_Error. Otherwise it removes the node from the map and then + -- deallocates it. (This is the deletion analog of non-conditional + -- Insert. It is intended for use when you want to assert that the item is + -- already in the map.) + + procedure Delete (Container : in out Map; Position : in out Cursor); + -- Removes the node designated by Position from the map, and then + -- deallocates the node. The operation calls Hash to determine the bucket, + -- and then compares Position to each node in the bucket until there's a + -- match (it does not call Equivalent_Keys). + + function First (Container : Map) return Cursor; + -- Returns a cursor that designates the first non-empty bucket, by + -- searching from the beginning of the buckets array. + + function Next (Position : Cursor) return Cursor; + -- Returns a cursor that designates the node that follows the current one + -- designated by Position. If Position designates the last node in its + -- bucket, the operation calls Hash to compute the index of this bucket, + -- and searches the buckets array for the first non-empty bucket, starting + -- from that index; otherwise, it simply follows the link to the next node + -- in the same bucket. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Find (Container : Map; Key : Key_Type) return Cursor; + -- Searches for Key in the map. Find calls Hash to determine the key's + -- bucket; if the bucket is not empty, it calls Equivalent_Keys to compare + -- Key to each key in the bucket. If the search succeeds, Find returns a + -- cursor designating the matching node; otherwise, it returns No_Element. + + function Contains (Container : Map; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + function Element (Container : Map; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) + + function Equivalent_Keys (Left, Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Keys with the keys of the nodes + -- designated by cursors Left and Right. + + function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean; + -- Returns the result of calling Equivalent_Keys with key of the node + -- designated by Left and key Right. + + function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Keys with key Left and the node + -- designated by Right. + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + -- Calls Process for each node in the map + + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class; + +private + pragma Inline ("="); + pragma Inline (Length); + pragma Inline (Is_Empty); + pragma Inline (Clear); + pragma Inline (Key); + pragma Inline (Element); + pragma Inline (Move); + pragma Inline (Contains); + pragma Inline (Capacity); + pragma Inline (Reserve_Capacity); + pragma Inline (Has_Element); + pragma Inline (Equivalent_Keys); + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Key : Key_Type; + Element : aliased Element_Type; + Next : Node_Access; + end record; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); + + type Map is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + overriding procedure Adjust (Container : in out Map); + + overriding procedure Finalize (Container : in out Map); + + use HT_Types, HT_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_Access; + -- Access to this cursor's container + + Node : Node_Access; + -- Access to the node pointed to by this cursor + + Position : Hash_Type := Hash_Type'Last; + -- Position of the node in the buckets of the container. If this is + -- equal to Hash_Type'Last, then it will not be used. + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); + + No_Element : constant Cursor := (Container => null, Node => null, + Position => Hash_Type'Last); + + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Forward_Iterator with + record + Container : Map_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Hashed_Maps; diff --git a/gcc/ada/libgnat/a-cohase.adb b/gcc/ada/libgnat/a-cohase.adb new file mode 100644 index 0000000..3056f54 --- /dev/null +++ b/gcc/ada/libgnat/a-cohase.adb @@ -0,0 +1,2184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Hash_Tables.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); + +with Ada.Containers.Hash_Tables.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Prime_Numbers; + +with System; use type System.Address; + +package body Ada.Containers.Hashed_Sets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Assign (Node : Node_Access; Item : Element_Type); + pragma Inline (Assign); + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + function Equivalent_Keys + (Key : Element_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Keys); + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean; + + procedure Free (X : in out Node_Access); + + function Hash_Node (Node : Node_Access) return Hash_Type; + pragma Inline (Hash_Node); + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + + function Is_In + (HT : aliased in out Hash_Table_Type; + Key : Node_Access) return Boolean; + pragma Inline (Is_In); + + function Next (Node : Node_Access) return Node_Access; + pragma Inline (Next); + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Node_Access; + pragma Inline (Read_Node); + + procedure Set_Next (Node : Node_Access; Next : Node_Access); + pragma Inline (Set_Next); + + function Vet (Position : Cursor) return Boolean; + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package HT_Ops is new Hash_Tables.Generic_Operations + (HT_Types => HT_Types, + Hash_Node => Hash_Node, + Next => Next, + Set_Next => Set_Next, + Copy_Node => Copy_Node, + Free => Free); + + package Element_Keys is new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Element_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Keys); + + function Is_Equal is + new HT_Ops.Generic_Equal (Find_Equal_Key); + + function Is_Equivalent is + new HT_Ops.Generic_Equal (Find_Equivalent_Key); + + procedure Read_Nodes is + new HT_Ops.Generic_Read (Read_Node); + + procedure Replace_Element is + new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); + + procedure Write_Nodes is + new HT_Ops.Generic_Write (Write_Node); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + return Is_Equal (Left.HT, Right.HT); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Set) is + begin + HT_Ops.Adjust (Container.HT); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Node : Node_Access; Item : Element_Type) is + begin + Node.Element := Item; + end Assign; + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Set) return Count_Type is + begin + return HT_Ops.Capacity (Container.HT); + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Set) is + begin + HT_Ops.Clear (Container.HT); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); + + declare + HT : Hash_Table_Type renames Position.Container.all.HT; + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Set; + Capacity : Count_Type := 0) return Set + is + C : Count_Type; + + begin + if Capacity < Source.Length then + if Checks and then Capacity /= 0 then + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + C := Source.Length; + else + C := Capacity; + end if; + + return Target : Set do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + begin + return new Node_Type'(Element => Source.Element, Next => null); + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + + if Checks and then X = null then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Free (X); + end Delete; + + procedure Delete + (Container : in out Set; + Position : in out Cursor) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + TC_Check (Container.HT.TC); + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); + + Free (Position.Node); + Position.Container := null; + end Delete; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference + (Target : in out Set; + Source : Set) + is + Tgt_Node : Node_Access; + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + if Src_HT.Length = 0 then + return; + end if; + + TC_Check (Target.HT.TC); + + if Src_HT.Length < Target.HT.Length then + declare + Src_Node : Node_Access; + + begin + Src_Node := HT_Ops.First (Src_HT); + while Src_Node /= null loop + Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element); + + if Tgt_Node /= null then + HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); + Free (Tgt_Node); + end if; + + Src_Node := HT_Ops.Next (Src_HT, Src_Node); + end loop; + end; + + else + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Src_HT, Tgt_Node) then + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; + + else + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + end if; + end loop; + end if; + end Difference; + + function Difference (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Left_HT.Length = 0 then + return Empty_Set; + end if; + + if Right_HT.Length = 0 then + return Left; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Length := 0; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right_HT, L_Node) then + declare + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); + + Bucket : Node_Access renames Buckets (J); + + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; + + Length := Length + 1; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left_HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Element"); + + return Position.Node.Element; + end Element; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + begin + return Is_Equivalent (Left.HT, Right.HT); + end Equivalent_Sets; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Cursor) + return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); + pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); + + -- AI05-0022 requires that a container implementation detect element + -- tampering by a generic actual subprogram. However, the following case + -- falls outside the scope of that AI. Randy Brukardt explained on the + -- ARG list on 2013/02/07 that: + + -- (Begin Quote): + -- But for an operation like "<" [the ordered set analog of + -- Equivalent_Elements], there is no need to "dereference" a cursor + -- after the call to the generic formal parameter function, so nothing + -- bad could happen if tampering is undetected. And the operation can + -- safely return a result without a problem even if an element is + -- deleted from the container. + -- (End Quote). + + return Equivalent_Elements (Left.Node.Element, Right.Node.Element); + end Equivalent_Elements; + + function Equivalent_Elements (Left : Cursor; Right : Element_Type) + return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with + "Left cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert (Vet (Left), "Left cursor in Equivalent_Elements is bad"); + + return Equivalent_Elements (Left.Node.Element, Right); + end Equivalent_Elements; + + function Equivalent_Elements (Left : Element_Type; Right : Cursor) + return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with + "Right cursor of Equivalent_Elements equals No_Element"; + end if; + + pragma Assert + (Vet (Right), + "Right cursor of Equivalent_Elements is bad"); + + return Equivalent_Elements (Left, Right.Node.Element); + end Equivalent_Elements; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Key : Element_Type; Node : Node_Access) + return Boolean is + begin + return Equivalent_Elements (Key, Node.Element); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Item : Element_Type) + is + X : Node_Access; + begin + Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Set) is + begin + HT_Ops.Finalize (Container.HT); + end Finalize; + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.HT.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Item : Element_Type) return Cursor + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Element_Keys.Find (HT, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last); + end Find; + + -------------------- + -- Find_Equal_Key -- + -------------------- + + function Find_Equal_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); + + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + loop + if R_Node = null then + return False; + end if; + + if L_Node.Element = R_Node.Element then + return True; + end if; + + R_Node := Next (R_Node); + end loop; + end Find_Equal_Key; + + ------------------------- + -- Find_Equivalent_Key -- + ------------------------- + + function Find_Equivalent_Key + (R_HT : Hash_Table_Type; + L_Node : Node_Access) return Boolean + is + R_Index : constant Hash_Type := + Element_Keys.Index (R_HT, L_Node.Element); + + R_Node : Node_Access := R_HT.Buckets (R_Index); + + begin + loop + if R_Node = null then + return False; + end if; + + if Equivalent_Elements (L_Node.Element, R_Node.Element) then + return True; + end if; + + R_Node := Next (R_Node); + end loop; + end Find_Equivalent_Key; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + Pos : Hash_Type; + Node : constant Node_Access := HT_Ops.First (Container.HT, Pos); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node, Pos); + end First; + + function First (Object : Iterator) return Cursor is + begin + return Object.Container.First; + end First; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X /= null then + X.Next := X; -- detect mischief (in Vet) + Deallocate (X); + end if; + end Free; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= null; + end Has_Element; + + --------------- + -- Hash_Node -- + --------------- + + function Hash_Node (Node : Node_Access) return Hash_Type is + begin + return Hash (Node.Element); + end Hash_Node; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.HT.TC); + + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert (Container.HT, New_Item, Position.Node, Inserted); + Position.Container := Container'Unchecked_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + procedure Insert + (HT : in out Hash_Table_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + begin + return new Node_Type'(New_Item, Next); + end New_Node; + + -- Start of processing for Insert + + begin + if HT_Ops.Capacity (HT) = 0 then + HT_Ops.Reserve_Capacity (HT, 1); + end if; + + TC_Check (HT.TC); + + Local_Insert (HT, New_Item, Node, Inserted); + + if Inserted + and then HT.Length > HT_Ops.Capacity (HT) + then + HT_Ops.Reserve_Capacity (HT, HT.Length); + end if; + end Insert; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Set; + Source : Set) + is + Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; + Tgt_Node : Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + if Source.HT.Length = 0 then + Clear (Target); + return; + end if; + + TC_Check (Target.HT.TC); + + Tgt_Node := HT_Ops.First (Target.HT); + while Tgt_Node /= null loop + if Is_In (Src_HT, Tgt_Node) then + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + + else + declare + X : Node_Access := Tgt_Node; + begin + Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); + HT_Ops.Delete_Node_Sans_Free (Target.HT, X); + Free (X); + end; + end if; + end loop; + end Intersection; + + function Intersection (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Left; + end if; + + Length := Count_Type'Min (Left.Length, Right.Length); + + if Length = 0 then + return Empty_Set; + end if; + + declare + Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Length := 0; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + begin + if Is_In (Right_HT, L_Node) then + declare + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); + + Bucket : Node_Access renames Buckets (J); + + begin + Bucket := new Node_Type'(L_Node.Element, Bucket); + end; + + Length := Length + 1; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left_HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.HT.Length = 0; + end Is_Empty; + + ----------- + -- Is_In -- + ----------- + + function Is_In + (HT : aliased in out Hash_Table_Type; + Key : Node_Access) return Boolean + is + begin + return Element_Keys.Find (HT, Key.Element) /= null; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT; + Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT; + Subset_Node : Node_Access; + + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + Subset_Node := HT_Ops.First (Subset_HT); + while Subset_Node /= null loop + if not Is_In (Of_Set_HT, Subset_Node) then + return False; + end if; + Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node); + end loop; + + return True; + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access; Position : Hash_Type); + pragma Inline (Process_Node); + + procedure Iterate is + new HT_Ops.Generic_Iteration_With_Position (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access; Position : Hash_Type) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node, Position)); + end Process_Node; + + Busy : With_Busy (Container.HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Iterate (Container.HT); + end Iterate; + + function Iterate + (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class + is + begin + Busy (Container.HT.TC'Unrestricted_Access.all); + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access); + end Iterate; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.HT.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Set; Source : in out Set) is + begin + HT_Ops.Move (Target => Target.HT, Source => Source.HT); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + return Node.Next; + end Next; + + function Next (Position : Cursor) return Cursor is + Node : Node_Access; + Pos : Hash_Type; + begin + if Position.Node = null then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Next"); + + Pos := Position.Position; + Node := HT_Ops.Next (Position.Container.HT, Position.Node, Pos); + + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node, Pos); + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Left_Node : Node_Access; + + begin + if Right.Length = 0 then + return False; + end if; + + if Left'Address = Right'Address then + return True; + end if; + + Left_Node := HT_Ops.First (Left_HT); + while Left_Node /= null loop + if Is_In (Right_HT, Left_Node) then + return True; + end if; + Left_Node := HT_Ops.Next (Left_HT, Left_Node); + end loop; + + return False; + end Overlap; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.HT.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + HT : Hash_Table_Type renames Position.Container.HT; + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + Process (Position.Node.Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + begin + Read_Nodes (Stream, Container.HT); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Read_Node -- + --------------- + + function Read_Node (Stream : not null access Root_Stream_Type'Class) + return Node_Access + is + Node : Node_Access := new Node_Type; + begin + Element_Type'Read (Stream, Node.Element); + return Node; + exception + when others => + Free (Node); + raise; + end Read_Node; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + New_Item : Element_Type) + is + Node : constant Node_Access := + Element_Keys.Find (Container.HT, New_Item); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + TE_Check (Container.HT.TC); + + Node.Element := New_Item; + end Replace; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + Replace_Element (Container.HT, Position.Node, New_Item); + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Set; + Capacity : Count_Type) + is + begin + HT_Ops.Reserve_Capacity (Container.HT, Capacity); + end Reserve_Capacity; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (Node : Node_Access; Next : Node_Access) is + begin + Node.Next := Next; + end Set_Next; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Set; + Source : Set) + is + Tgt_HT : Hash_Table_Type renames Target.HT; + Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + TC_Check (Tgt_HT.TC); + + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Tgt_HT) then + HT_Ops.Reserve_Capacity (Tgt_HT, N); + end if; + end; + + if Target.Length = 0 then + Iterate_Source_When_Empty_Target : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element; + B : Buckets_Type renames Tgt_HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Tgt_HT.Length; + + begin + B (J) := new Node_Type'(E, B (J)); + N := N + 1; + end Process; + + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. + + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Source_When_Empty_Target + + begin + Iterate (Src_HT); + end Iterate_Source_When_Empty_Target; + + else + Iterate_Source : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + E : Element_Type renames Src_Node.Element; + B : Buckets_Type renames Tgt_HT.Buckets.all; + J : constant Hash_Type := Hash (E) mod B'Length; + N : Count_Type renames Tgt_HT.Length; + + begin + if B (J) = null then + B (J) := new Node_Type'(E, null); + N := N + 1; + + elsif Equivalent_Elements (E, B (J).Element) then + declare + X : Node_Access := B (J); + begin + B (J) := B (J).Next; + N := N - 1; + Free (X); + end; + + else + declare + Prev : Node_Access := B (J); + Curr : Node_Access := Prev.Next; + + begin + while Curr /= null loop + if Equivalent_Elements (E, Curr.Element) then + Prev.Next := Curr.Next; + N := N - 1; + Free (Curr); + return; + end if; + + Prev := Curr; + Curr := Prev.Next; + end loop; + + B (J) := new Node_Type'(E, B (J)); + N := N + 1; + end; + end if; + end Process; + + -- Per AI05-0022, the container implementation is required to + -- detect element tampering by a generic actual subprogram. + + Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); + Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Source + + begin + Iterate (Src_HT); + end Iterate_Source; + end if; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; + Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Empty_Set; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Length := 0; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + begin + if not Is_In (Right_HT, L_Node) then + declare + E : Element_Type renames L_Node.Element; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); + + begin + Buckets (J) := new Node_Type'(E, Buckets (J)); + Length := Length + 1; + end; + end if; + end Process; + + -- Start of processing for Iterate_Left + + begin + Iterate (Left_HT); + + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + Iterate_Right : declare + procedure Process (R_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (R_Node : Node_Access) is + begin + if not Is_In (Left_HT, R_Node) then + declare + E : Element_Type renames R_Node.Element; + + -- Per AI05-0022, the container implementation is required + -- to detect element tampering by a generic actual + -- subprogram, hence the use of Checked_Index instead of a + -- simple invocation of generic formal Hash. + + J : constant Hash_Type := + HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); + + begin + Buckets (J) := new Node_Type'(E, Buckets (J)); + Length := Length + 1; + end; + end if; + end Process; + + -- Start of processing for Iterate_Right + + begin + Iterate (Right_HT); + + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Right; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + HT : Hash_Table_Type; + + Node : Node_Access; + Inserted : Boolean; + pragma Unreferenced (Node, Inserted); + + begin + Insert (HT, New_Item, Node, Inserted); + return Set'(Controlled with HT); + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union + (Target : in out Set; + Source : Set) + is + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + function New_Node (Next : Node_Access) return Node_Access; + pragma Inline (New_Node); + + procedure Insert is + new Element_Keys.Generic_Conditional_Insert (New_Node); + + -------------- + -- New_Node -- + -------------- + + function New_Node (Next : Node_Access) return Node_Access is + Node : constant Node_Access := + new Node_Type'(Src_Node.Element, Next); + begin + return Node; + end New_Node; + + Tgt_Node : Node_Access; + Success : Boolean; + pragma Unreferenced (Tgt_Node, Success); + + -- Start of processing for Process + + begin + Insert (Target.HT, Src_Node.Element, Tgt_Node, Success); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Target.HT.TC); + + declare + N : constant Count_Type := Target.Length + Source.Length; + begin + if N > HT_Ops.Capacity (Target.HT) then + HT_Ops.Reserve_Capacity (Target.HT, N); + end if; + end; + + Iterate (Source.HT); + end Union; + + function Union (Left, Right : Set) return Set is + Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; + Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; + Buckets : HT_Types.Buckets_Access; + Length : Count_Type; + + begin + if Left'Address = Right'Address then + return Left; + end if; + + if Right.Length = 0 then + return Left; + end if; + + if Left.Length = 0 then + return Right; + end if; + + declare + Size : constant Hash_Type := + Prime_Numbers.To_Prime (Left.Length + Right.Length); + begin + Buckets := HT_Ops.New_Buckets (Length => Size); + end; + + Iterate_Left : declare + procedure Process (L_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (L_Node : Node_Access) is + J : constant Hash_Type := + Hash (L_Node.Element) mod Buckets'Length; + + begin + Buckets (J) := new Node_Type'(L_Node.Element, Buckets (J)); + end Process; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Left + + begin + Iterate (Left_HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Left; + + Length := Left.Length; + + Iterate_Right : declare + procedure Process (Src_Node : Node_Access); + + procedure Iterate is + new HT_Ops.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Src_Node : Node_Access) is + J : constant Hash_Type := + Hash (Src_Node.Element) mod Buckets'Length; + + Tgt_Node : Node_Access := Buckets (J); + + begin + while Tgt_Node /= null loop + if Equivalent_Elements (Src_Node.Element, Tgt_Node.Element) then + return; + end if; + + Tgt_Node := Next (Tgt_Node); + end loop; + + Buckets (J) := new Node_Type'(Src_Node.Element, Buckets (J)); + Length := Length + 1; + end Process; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram, hence the use of + -- Checked_Index instead of a simple invocation of generic formal + -- Hash. + + Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); + + -- Start of processing for Iterate_Right + + begin + Iterate (Right_HT); + exception + when others => + HT_Ops.Free_Hash_Table (Buckets); + raise; + end Iterate_Right; + + return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); + end Union; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = null then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + if Position.Node.Next = Position.Node then + return False; + end if; + + declare + HT : Hash_Table_Type renames Position.Container.HT; + X : Node_Access; + + begin + if HT.Length = 0 then + return False; + end if; + + if HT.Buckets = null + or else HT.Buckets'Length = 0 + then + return False; + end if; + + X := HT.Buckets (Element_Keys.Checked_Index + (HT, + Position.Node.Element)); + + for J in 1 .. HT.Length loop + if X = Position.Node then + return True; + end if; + + if X = null then + return False; + end if; + + if X = X.Next then -- to prevent unnecessary looping + return False; + end if; + + X := X.Next; + end loop; + + return False; + end; + end Vet; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + begin + Write_Nodes (Stream, Container.HT); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean; + pragma Inline (Equivalent_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Hash_Tables.Generic_Keys + (HT_Types => HT_Types, + Next => Next, + Set_Next => Set_Next, + Key_Type => Key_Type, + Hash => Hash, + Equivalent_Keys => Equivalent_Key_Node); + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + declare + TC : constant Tamper_Counts_Access := + HT.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Key : Key_Type) return Boolean + is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Set; + Key : Key_Type) + is + X : Node_Access; + + begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + + if Checks and then X = null then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Set; + Key : Key_Type) return Element_Type + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in set"; + end if; + + return Node.Element; + end Element; + + ------------------------- + -- Equivalent_Key_Node -- + ------------------------- + + function Equivalent_Key_Node + (Key : Key_Type; + Node : Node_Access) return Boolean + is + begin + return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element)); + end Equivalent_Key_Node; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude + (Container : in out Set; + Key : Key_Type) + is + X : Node_Access; + begin + Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); + Free (X); + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then + Hash (Key (Element (Control.Old_Pos))) /= Control.Old_Hash + then + HT_Ops.Delete_Node_At_Index + (Control.Container.HT, Control.Index, Control.Old_Pos.Node); + raise Program_Error with "key not preserved in reference"; + end if; + + Control.Container := null; + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Set; + Key : Key_Type) return Cursor + is + HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; + Node : constant Node_Access := Key_Keys.Find (HT, Key); + begin + if Node = null then + return No_Element; + else + return Cursor' + (Container'Unrestricted_Access, Node, Hash_Type'Last); + end if; + end Find; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position), "bad cursor in function Key"); + + return Key (Position.Node.Element); + end Key; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in function Reference_Preserving_Key"); + + declare + HT : Hash_Table_Type renames Position.Container.all.HT; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with + HT.TC'Unrestricted_Access, + Container'Unrestricted_Access, + Index => HT_Ops.Index (HT, Position.Node), + Old_Pos => Position, + Old_Hash => Hash (Key (Position)))) + do + Lock (HT.TC); + end return; + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in set"; + end if; + + declare + HT : Hash_Table_Type renames Container.HT; + P : constant Cursor := Find (Container, Key); + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with + HT.TC'Unrestricted_Access, + Container'Unrestricted_Access, + Index => HT_Ops.Index (HT, P.Node), + Old_Pos => P, + Old_Hash => Hash (Key))) + do + Lock (HT.TC); + end return; + end; + end Reference_Preserving_Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container.HT, Node, New_Item); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)) + is + HT : Hash_Table_Type renames Container.HT; + Indx : Hash_Type; + + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + if Checks and then + (HT.Buckets = null + or else HT.Buckets'Length = 0 + or else HT.Length = 0 + or else Position.Node.Next = Position.Node) + then + raise Program_Error with "Position cursor is bad (set is empty)"; + end if; + + pragma Assert + (Vet (Position), + "bad cursor in Update_Element_Preserving_Key"); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + E : Element_Type renames Position.Node.Element; + K : constant Key_Type := Key (E); + Lock : With_Lock (HT.TC'Unrestricted_Access); + begin + Indx := HT_Ops.Index (HT, Position.Node); + Process (E); + + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + if HT.Buckets (Indx) = Position.Node then + HT.Buckets (Indx) := Position.Node.Next; + + else + declare + Prev : Node_Access := HT.Buckets (Indx); + + begin + while Prev.Next /= Position.Node loop + Prev := Prev.Next; + + if Checks and then Prev = null then + raise Program_Error with + "Position cursor is bad (node not found)"; + end if; + end loop; + + Prev.Next := Position.Node.Next; + end; + end if; + + HT.Length := HT.Length - 1; + + declare + X : Node_Access := Position.Node; + + begin + Free (X); + end; + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + end Generic_Keys; + +end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cohase.ads b/gcc/ada/libgnat/a-cohase.ads new file mode 100644 index 0000000..79e3400 --- /dev/null +++ b/gcc/ada/libgnat/a-cohase.ads @@ -0,0 +1,609 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Hash_Tables; +with Ada.Containers.Helpers; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function Hash (Element : Element_Type) return Hash_Type; + + with function Equivalent_Elements + (Left, Right : Element_Type) return Boolean; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Hashed_Sets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type Set is tagged private + with + Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + -- Set objects declared without an initialization expression are + -- initialized to the value Empty_Set. + + No_Element : constant Cursor; + -- Cursor objects declared without an initialization expression are + -- initialized to the value No_Element. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + -- For each element in Left, set equality attempts to find the equal + -- element in Right; if a search fails, then set equality immediately + -- returns False. The search works by calling Hash to find the bucket in + -- the Right set that corresponds to the Left element. If the bucket is + -- non-empty, the search calls the generic formal element equality operator + -- to compare the element (in Left) to the element of each node in the + -- bucket (in Right); the search terminates when a matching node in the + -- bucket is found, or the nodes in the bucket are exhausted. (Note that + -- element equality is called here, not Equivalent_Elements. Set equality + -- is the only operation in which element equality is used. Compare set + -- equality to Equivalent_Sets, which does call Equivalent_Elements.) + + function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, with the difference that the element in Left is + -- compared to the elements in Right using the generic formal + -- Equivalent_Elements operation instead of element equality. + + function To_Set (New_Item : Element_Type) return Set; + -- Constructs a singleton set comprising New_Element. To_Set calls Hash to + -- determine the bucket for New_Item. + + function Capacity (Container : Set) return Count_Type; + -- Returns the current capacity of the set. Capacity is the maximum length + -- before which rehashing in guaranteed not to occur. + + procedure Reserve_Capacity (Container : in out Set; Capacity : Count_Type); + -- Adjusts the current capacity, by allocating a new buckets array. If the + -- requested capacity is less than the current capacity, then the capacity + -- is contracted (to a value not less than the current length). If the + -- requested capacity is greater than the current capacity, then the + -- capacity is expanded (to a value not less than what is requested). In + -- either case, the nodes are rehashed from the old buckets array onto the + -- new buckets array (Hash is called once for each existing element in + -- order to compute the new index), and then the old buckets array is + -- deallocated. + + function Length (Container : Set) return Count_Type; + -- Returns the number of items in the set + + function Is_Empty (Container : Set) return Boolean; + -- Equivalent to Length (Container) = 0 + + procedure Clear (Container : in out Set); + -- Removes all of the items from the set + + function Element (Position : Cursor) return Element_Type; + -- Returns the element of the node designated by the cursor + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + -- If New_Item is equivalent (as determined by calling Equivalent_Elements) + -- to the element of the node designated by Position, then New_Element is + -- assigned to that element. Otherwise, it calls Hash to determine the + -- bucket for New_Item. If the bucket is not empty, then it calls + -- Equivalent_Elements for each node in that bucket to determine whether + -- New_Item is equivalent to an element in that bucket. If + -- Equivalent_Elements returns True then Program_Error is raised (because + -- an element may appear only once in the set); otherwise, New_Item is + -- assigned to the node designated by Position, and the node is moved to + -- its new bucket. + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- Calls Process with the element (having only a constant view) of the node + -- designed by the cursor. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set; Capacity : Count_Type := 0) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + -- Clears Target (if it's not empty), and then moves (not copies) the + -- buckets array and nodes from Source to Target. + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + -- Conditionally inserts New_Item into the set. If New_Item is already in + -- the set, then Inserted returns False and Position designates the node + -- containing the existing element (which is not modified). If New_Item is + -- not already in the set, then Inserted returns True and Position + -- designates the newly-inserted node containing New_Item. The search for + -- an existing element works as follows. Hash is called to determine + -- New_Item's bucket; if the bucket is non-empty, then Equivalent_Elements + -- is called to compare New_Item to the element of each node in that + -- bucket. If the bucket is empty, or there were no equivalent elements in + -- the bucket, the search "fails" and the New_Item is inserted in the set + -- (and Inserted returns True); otherwise, the search "succeeds" (and + -- Inserted returns False). + + procedure Insert (Container : in out Set; New_Item : Element_Type); + -- Attempts to insert New_Item into the set, performing the usual insertion + -- search (which involves calling both Hash and Equivalent_Elements); if + -- the search succeeds (New_Item is equivalent to an element already in the + -- set, and so was not inserted), then this operation raises + -- Constraint_Error. (This version of Insert is similar to Replace, but + -- having the opposite exception behavior. It is intended for use when you + -- want to assert that the item is not already in the set.) + + procedure Include (Container : in out Set; New_Item : Element_Type); + -- Attempts to insert New_Item into the set. If an element equivalent to + -- New_Item is already in the set (the insertion search succeeded, and + -- hence New_Item was not inserted), then the value of New_Item is assigned + -- to the existing element. (This insertion operation only raises an + -- exception if cursor tampering occurs. It is intended for use when you + -- want to insert the item in the set, and you don't care whether an + -- equivalent element is already present.) + + procedure Replace (Container : in out Set; New_Item : Element_Type); + -- Searches for New_Item in the set; if the search fails (because an + -- equivalent element was not in the set), then it raises + -- Constraint_Error. Otherwise, the existing element is assigned the value + -- New_Item. (This is similar to Insert, but with the opposite exception + -- behavior. It is intended for use when you want to assert that the item + -- is already in the set.) + + procedure Exclude (Container : in out Set; Item : Element_Type); + -- Searches for Item in the set, and if found, removes its node from the + -- set and then deallocates it. The search works as follows. The operation + -- calls Hash to determine the item's bucket; if the bucket is not empty, + -- it calls Equivalent_Elements to compare Item to the element of each node + -- in the bucket. (This is the deletion analog of Include. It is intended + -- for use when you want to remove the item from the set, but don't care + -- whether the item is already in the set.) + + procedure Delete (Container : in out Set; Item : Element_Type); + -- Searches for Item in the set (which involves calling both Hash and + -- Equivalent_Elements). If the search fails, then the operation raises + -- Constraint_Error. Otherwise it removes the node from the set and then + -- deallocates it. (This is the deletion analog of non-conditional + -- Insert. It is intended for use when you want to assert that the item is + -- already in the set.) + + procedure Delete (Container : in out Set; Position : in out Cursor); + -- Removes the node designated by Position from the set, and then + -- deallocates the node. The operation calls Hash to determine the bucket, + -- and then compares Position to each node in the bucket until there's a + -- match (it does not call Equivalent_Elements). + + procedure Union (Target : in out Set; Source : Set); + -- The operation first calls Reserve_Capacity if the current capacity is + -- less than the sum of the lengths of Source and Target. It then iterates + -- over the Source set, and conditionally inserts each element into Target. + + function Union (Left, Right : Set) return Set; + -- The operation first copies the Left set to the result, and then iterates + -- over the Right set to conditionally insert each element into the result. + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + -- Iterates over the Target set (calling First and Next), calling Find to + -- determine whether the element is in Source. If an equivalent element is + -- not found in Source, the element is deleted from Target. + + function Intersection (Left, Right : Set) return Set; + -- Iterates over the Left set, calling Find to determine whether the + -- element is in Right. If an equivalent element is found, it is inserted + -- into the result set. + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + -- Iterates over the Source (calling First and Next), calling Find to + -- determine whether the element is in Target. If an equivalent element is + -- found, it is deleted from Target. + + function Difference (Left, Right : Set) return Set; + -- Iterates over the Left set, calling Find to determine whether the + -- element is in the Right set. If an equivalent element is not found, the + -- element is inserted into the result set. + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + -- The operation first calls Reserve_Capacity if the current capacity is + -- less than the sum of the lengths of Source and Target. It then iterates + -- over the Source set, searching for the element in Target (calling Hash + -- and Equivalent_Elements). If an equivalent element is found, it is + -- removed from Target; otherwise it is inserted into Target. + + function Symmetric_Difference (Left, Right : Set) return Set; + -- The operation first iterates over the Left set. It calls Find to + -- determine whether the element is in the Right set. If no equivalent + -- element is found, the element from Left is inserted into the result. The + -- operation then iterates over the Right set, to determine whether the + -- element is in the Left set. If no equivalent element is found, the Right + -- element is inserted into the result. + + function "xor" (Left, Right : Set) return Set + renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + -- Iterates over the Left set (calling First and Next), calling Find to + -- determine whether the element is in the Right set. If an equivalent + -- element is found, the operation immediately returns True. The operation + -- returns False if the iteration over Left terminates without finding any + -- equivalent element in Right. + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + -- Iterates over Subset (calling First and Next), calling Find to determine + -- whether the element is in Of_Set. If no equivalent element is found in + -- Of_Set, the operation immediately returns False. The operation returns + -- True if the iteration over Subset terminates without finding an element + -- not in Of_Set (that is, every element in Subset is equivalent to an + -- element in Of_Set). + + function First (Container : Set) return Cursor; + -- Returns a cursor that designates the first non-empty bucket, by + -- searching from the beginning of the buckets array. + + function Next (Position : Cursor) return Cursor; + -- Returns a cursor that designates the node that follows the current one + -- designated by Position. If Position designates the last node in its + -- bucket, the operation calls Hash to compute the index of this bucket, + -- and searches the buckets array for the first non-empty bucket, starting + -- from that index; otherwise, it simply follows the link to the next node + -- in the same bucket. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Find + (Container : Set; + Item : Element_Type) return Cursor; + -- Searches for Item in the set. Find calls Hash to determine the item's + -- bucket; if the bucket is not empty, it calls Equivalent_Elements to + -- compare Item to each element in the bucket. If the search succeeds, Find + -- returns a cursor designating the node containing the equivalent element; + -- otherwise, it returns No_Element. + + function Contains (Container : Set; Item : Element_Type) return Boolean; + -- Equivalent to Find (Container, Item) /= No_Element + + function Equivalent_Elements (Left, Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Elements with the elements of + -- the nodes designated by cursors Left and Right. + + function Equivalent_Elements + (Left : Cursor; + Right : Element_Type) return Boolean; + -- Returns the result of calling Equivalent_Elements with element of the + -- node designated by Left and element Right. + + function Equivalent_Elements + (Left : Element_Type; + Right : Cursor) return Boolean; + -- Returns the result of calling Equivalent_Elements with element Left and + -- the element of the node designated by Right. + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + -- Calls Process for each node in the set + + function Iterate + (Container : Set) return Set_Iterator_Interfaces.Forward_Iterator'Class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function Hash (Key : Key_Type) return Hash_Type; + + with function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + package Generic_Keys is + + function Key (Position : Cursor) return Key_Type; + -- Applies generic formal operation Key to the element of the node + -- designated by Position. + + function Element (Container : Set; Key : Key_Type) return Element_Type; + -- Searches (as per the key-based Find) for the node containing Key, and + -- returns the associated element. + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + -- Searches (as per the key-based Find) for the node containing Key, and + -- then replaces the element of that node (as per the element-based + -- Replace_Element). + + procedure Exclude (Container : in out Set; Key : Key_Type); + -- Searches for Key in the set, and if found, removes its node from the + -- set and then deallocates it. The search works by first calling Hash + -- (on Key) to determine the bucket; if the bucket is not empty, it + -- calls Equivalent_Keys to compare parameter Key to the value of + -- generic formal operation Key applied to element of each node in the + -- bucket. + + procedure Delete (Container : in out Set; Key : Key_Type); + -- Deletes the node containing Key as per Exclude, with the difference + -- that Constraint_Error is raised if Key is not found. + + function Find (Container : Set; Key : Key_Type) return Cursor; + -- Searches for the node containing Key, and returns a cursor + -- designating the node. The search works by first calling Hash (on Key) + -- to determine the bucket. If the bucket is not empty, the search + -- compares Key to the element of each node in the bucket, and returns + -- the matching node. The comparison itself works by applying the + -- generic formal Key operation to the element of the node, and then + -- calling generic formal operation Equivalent_Keys. + + function Contains (Container : Set; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + -- Calls Process with the element of the node designated by Position, + -- but with the restriction that the key-value of the element is not + -- modified. The operation first makes a copy of the value returned by + -- applying generic formal operation Key on the element of the node, and + -- then calls Process with the element. The operation verifies that the + -- key-part has not been modified by calling generic formal operation + -- Equivalent_Keys to compare the saved key-value to the value returned + -- by applying generic formal operation Key to the post-Process value of + -- element. If the key values compare equal then the operation + -- completes. Otherwise, the node is removed from the set and + -- Program_Error is raised. + + type Reference_Type (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type; + + private + use Ada.Streams; + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + -- Key_Preserving references must carry information to allow removal + -- of elements whose value may have been altered improperly, i.e. have + -- been given values incompatible with the hash-code of the previous + -- value, and are thus in the wrong bucket. (RM 18.7 (96.6/3)) + + -- We cannot store the key directly because it is an unconstrained type. + -- To avoid using additional dynamic allocation we store the old cursor + -- which simplifies possible removal. This is not possible for some + -- other set types. + + -- The mechanism is different for Update_Element_Preserving_Key, as + -- in that case the check that buckets have not changed is performed + -- at the time of the update, not when the reference is finalized. + + package Impl is new Helpers.Generic_Implementation; + + type Reference_Control_Type is + new Impl.Reference_Control_Type with + record + Container : Set_Access; + Index : Hash_Type; + Old_Pos : Cursor; + Old_Hash : Hash_Type; + end record; + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + end Generic_Keys; + +private + pragma Inline (Next); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Element : aliased Element_Type; + Next : Node_Access; + end record; + + package HT_Types is + new Hash_Tables.Generic_Hash_Table_Types (Node_Type, Node_Access); + + type Set is new Ada.Finalization.Controlled with record + HT : HT_Types.Hash_Table_Type; + end record; + + overriding procedure Adjust (Container : in out Set); + + overriding procedure Finalize (Container : in out Set); + + use HT_Types, HT_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + Position : Hash_Type := Hash_Type'Last; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); + + No_Element : constant Cursor := + (Container => null, Node => null, Position => Hash_Type'Last); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Forward_Iterator with + record + Container : Set_Access; + end record + with Disable_Controlled => not T_Check; + + overriding function First (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + overriding procedure Finalize (Object : in out Iterator); + +end Ada.Containers.Hashed_Sets; diff --git a/gcc/ada/libgnat/a-cohata.ads b/gcc/ada/libgnat/a-cohata.ads new file mode 100644 index 0000000..ea92083 --- /dev/null +++ b/gcc/ada/libgnat/a-cohata.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H A S H _ T A B L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This package declares the hash-table type used to implement hashed +-- containers. + +with Ada.Containers.Helpers; + +package Ada.Containers.Hash_Tables is + pragma Pure; + -- Declare Pure so this can be imported by Remote_Types packages + + generic + type Node_Type (<>) is limited private; + + type Node_Access is access Node_Type; + + package Generic_Hash_Table_Types is + + type Buckets_Type is array (Hash_Type range <>) of Node_Access; + + type Buckets_Access is access all Buckets_Type; + for Buckets_Access'Storage_Size use 0; + -- Storage_Size of zero so this package can be Pure + + type Hash_Table_Type is tagged record + Buckets : Buckets_Access := null; + Length : Count_Type := 0; + TC : aliased Helpers.Tamper_Counts; + end record; + + package Implementation is new Helpers.Generic_Implementation; + end Generic_Hash_Table_Types; + + generic + type Node_Type is private; + package Generic_Bounded_Hash_Table_Types is + + type Nodes_Type is array (Count_Type range <>) of Node_Type; + type Buckets_Type is array (Hash_Type range <>) of Count_Type; + + type Hash_Table_Type + (Capacity : Count_Type; + Modulus : Hash_Type) is + tagged record + Length : Count_Type := 0; + TC : aliased Helpers.Tamper_Counts; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity) := (others => <>); + Buckets : Buckets_Type (1 .. Modulus) := (others => 0); + end record; + + package Implementation is new Helpers.Generic_Implementation; + end Generic_Bounded_Hash_Table_Types; + +end Ada.Containers.Hash_Tables; diff --git a/gcc/ada/libgnat/a-coinho-shared.adb b/gcc/ada/libgnat/a-coinho-shared.adb new file mode 100644 index 0000000..e4da421 --- /dev/null +++ b/gcc/ada/libgnat/a-coinho-shared.adb @@ -0,0 +1,528 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- Note: special attention must be paid to the case of simultaneous access +-- to internal shared objects and elements by different tasks. The Reference +-- counter of internal shared object is the only component protected using +-- atomic operations; other components and elements can be modified only when +-- reference counter is equal to one (so there are no other references to this +-- internal shared object and element). + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Holders is + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + procedure Detach (Container : Holder); + -- Detach data from shared copy if necessary. This is necessary to prepare + -- container to be modified. + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Holder) return Boolean is + begin + if Left.Reference = Right.Reference then + + -- Covers both null and not null but the same shared object cases + + return True; + + elsif Left.Reference /= null and Right.Reference /= null then + return Left.Reference.Element.all = Right.Reference.Element.all; + + else + return False; + end if; + end "="; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Container : in out Holder) is + begin + if Container.Reference /= null then + if Container.Busy = 0 then + + -- Container is not locked, reuse existing internal shared object + + Reference (Container.Reference); + else + -- Otherwise, create copy of both internal shared object and + -- element. + + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => + new Element_Type'(Container.Reference.Element.all)); + end if; + end if; + + Container.Busy := 0; + end Adjust; + + overriding procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Reference (Control.Container.Reference); + Control.Container.Busy := Control.Container.Busy + 1; + end if; + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Holder; Source : Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Reference /= Source.Reference then + if Target.Reference /= null then + Unreference (Target.Reference); + end if; + + Target.Reference := Source.Reference; + + if Source.Reference /= null then + Reference (Target.Reference); + end if; + end if; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference /= null then + Unreference (Container.Reference); + Container.Reference := null; + end if; + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Holder) return Constant_Reference_Type is + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + declare + Ref : constant Constant_Reference_Type := + (Element => Container.Reference.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + begin + Reference (Ref.Control.Container.Reference); + Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; + return Ref; + end; + end Constant_Reference; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Holder) return Holder is + begin + if Source.Reference = null then + return (Controlled with null, 0); + + elsif Source.Busy = 0 then + + -- Container is not locked, reuse internal shared object + + Reference (Source.Reference); + + return (Controlled with Source.Reference, 0); + + else + -- Otherwise, create copy of both internal shared object and element + + return + (Controlled with + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Source.Reference.Element.all)), + 0); + end if; + end Copy; + + ------------ + -- Detach -- + ------------ + + procedure Detach (Container : Holder) is + begin + if Container.Busy = 0 + and then not System.Atomic_Counters.Is_One + (Container.Reference.Counter) + then + -- Container is not locked and internal shared object is used by + -- other container, create copy of both internal shared object and + -- element. + + declare + Old : constant Shared_Holder_Access := Container.Reference; + + begin + Container'Unrestricted_Access.Reference := + new Shared_Holder' + (Counter => <>, + Element => + new Element_Type'(Container.Reference.Element.all)); + Unreference (Old); + end; + end if; + end Detach; + + ------------- + -- Element -- + ------------- + + function Element (Container : Holder) return Element_Type is + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + else + return Container.Reference.Element.all; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference /= null then + Unreference (Container.Reference); + Container.Reference := null; + end if; + end Finalize; + + overriding procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Unreference (Control.Container.Reference); + Control.Container.Busy := Control.Container.Busy - 1; + Control.Container := null; + end if; + end Finalize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Holder) return Boolean is + begin + return Container.Reference = null; + end Is_Empty; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Holder; Source : in out Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Source.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Reference /= Source.Reference then + if Target.Reference /= null then + Unreference (Target.Reference); + end if; + + Target.Reference := Source.Reference; + Source.Reference := null; + end if; + end Move; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)) + is + B : Natural renames Container'Unrestricted_Access.Busy; + + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + B := B + 1; + + begin + Process (Container.Reference.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder) + is + begin + Clear (Container); + + if not Boolean'Input (Stream) then + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(Element_Type'Input (Stream))); + end if; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Holder_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + function Reference + (Container : aliased in out Holder) return Reference_Type + is + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + declare + Ref : constant Reference_Type := + (Element => Container.Reference.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + begin + Reference (Ref.Control.Container.Reference); + Ref.Control.Container.Busy := Ref.Control.Container.Busy + 1; + return Ref; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type) + is + -- Element allocator may need an accessibility check in case actual type + -- is class-wide or has access discriminants (RM 4.8(10.1) and + -- AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Container.Reference = null then + -- Holder is empty, allocate new Shared_Holder. + + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)); + + elsif System.Atomic_Counters.Is_One (Container.Reference.Counter) then + -- Shared_Holder can be reused. + + Free (Container.Reference.Element); + Container.Reference.Element := new Element_Type'(New_Item); + + else + Unreference (Container.Reference); + Container.Reference := + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)); + end if; + end Replace_Element; + + --------------- + -- To_Holder -- + --------------- + + function To_Holder (New_Item : Element_Type) return Holder is + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + return + (Controlled with + new Shared_Holder' + (Counter => <>, + Element => new Element_Type'(New_Item)), 0); + end To_Holder; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Holder_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_Holder, Shared_Holder_Access); + + Aux : Shared_Holder_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + Free (Aux.Element); + Free (Aux); + end if; + end Unreference; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)) + is + B : Natural renames Container.Busy; + + begin + if Container.Reference = null then + raise Constraint_Error with "container is empty"; + end if; + + Detach (Container); + + B := B + 1; + + begin + Process (Container.Reference.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder) + is + begin + Boolean'Output (Stream, Container.Reference = null); + + if Container.Reference /= null then + Element_Type'Output (Stream, Container.Reference.Element.all); + end if; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-coinho-shared.ads b/gcc/ada/libgnat/a-coinho-shared.ads new file mode 100644 index 0000000..3faab9b --- /dev/null +++ b/gcc/ada/libgnat/a-coinho-shared.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +-- This is an optimized version of Indefinite_Holders using copy-on-write. +-- It is used on platforms that support atomic built-ins. + +private with Ada.Finalization; +private with Ada.Streams; + +private with System.Atomic_Counters; + +generic + type Element_Type (<>) is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Holders is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate (Indefinite_Holders); + pragma Remote_Types (Indefinite_Holders); + + type Holder is tagged private; + pragma Preelaborable_Initialization (Holder); + + Empty_Holder : constant Holder; + + function "=" (Left, Right : Holder) return Boolean; + + function To_Holder (New_Item : Element_Type) return Holder; + + function Is_Empty (Container : Holder) return Boolean; + + procedure Clear (Container : in out Holder); + + function Element (Container : Holder) return Element_Type; + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type); + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)); + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Holder) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Holder) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Holder; Source : Holder); + + function Copy (Source : Holder) return Holder; + + procedure Move (Target : in out Holder; Source : in out Holder); + +private + + use Ada.Finalization; + use Ada.Streams; + + type Element_Access is access all Element_Type; + type Holder_Access is access all Holder; + + type Shared_Holder is record + Counter : System.Atomic_Counters.Atomic_Counter; + Element : Element_Access; + end record; + + type Shared_Holder_Access is access all Shared_Holder; + + procedure Reference (Item : not null Shared_Holder_Access); + -- Increment reference counter + + procedure Unreference (Item : not null Shared_Holder_Access); + -- Decrement reference counter, deallocate Item when counter goes to zero + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder); + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder); + + type Holder is new Ada.Finalization.Controlled with record + Reference : Shared_Holder_Access; + Busy : Natural := 0; + end record; + for Holder'Read use Read; + for Holder'Write use Write; + + overriding procedure Adjust (Container : in out Holder); + overriding procedure Finalize (Container : in out Holder); + + type Reference_Control_Type is new Controlled with record + Container : Holder_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + Empty_Holder : constant Holder := (Controlled with null, 0); + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-coinho.adb b/gcc/ada/libgnat/a-coinho.adb new file mode 100644 index 0000000..7ac42db --- /dev/null +++ b/gcc/ada/libgnat/a-coinho.adb @@ -0,0 +1,383 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Indefinite_Holders is + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Holder) return Boolean is + begin + if Left.Element = null and Right.Element = null then + return True; + elsif Left.Element /= null and Right.Element /= null then + return Left.Element.all = Right.Element.all; + else + return False; + end if; + end "="; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Container : in out Holder) is + begin + if Container.Element /= null then + Container.Element := new Element_Type'(Container.Element.all); + end if; + + Container.Busy := 0; + end Adjust; + + overriding procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + begin + B := B + 1; + end; + end if; + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Holder; Source : Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Element /= Source.Element then + Free (Target.Element); + + if Source.Element /= null then + Target.Element := new Element_Type'(Source.Element.all); + end if; + end if; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + Free (Container.Element); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Holder) return Constant_Reference_Type + is + Ref : constant Constant_Reference_Type := + (Element => Container.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + B : Natural renames Ref.Control.Container.Busy; + begin + B := B + 1; + return Ref; + end Constant_Reference; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Holder) return Holder is + begin + if Source.Element = null then + return (Controlled with null, 0); + else + return (Controlled with new Element_Type'(Source.Element.all), 0); + end if; + end Copy; + + ------------- + -- Element -- + ------------- + + function Element (Container : Holder) return Element_Type is + begin + if Container.Element = null then + raise Constraint_Error with "container is empty"; + else + return Container.Element.all; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Container : in out Holder) is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + Free (Container.Element); + end Finalize; + + overriding procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + declare + B : Natural renames Control.Container.Busy; + begin + B := B - 1; + end; + end if; + + Control.Container := null; + end Finalize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Holder) return Boolean is + begin + return Container.Element = null; + end Is_Empty; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Holder; Source : in out Holder) is + begin + if Target.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Source.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + if Target.Element /= Source.Element then + Free (Target.Element); + Target.Element := Source.Element; + Source.Element := null; + end if; + end Move; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)) + is + B : Natural renames Container'Unrestricted_Access.Busy; + + begin + if Container.Element = null then + raise Constraint_Error with "container is empty"; + end if; + + B := B + 1; + + begin + Process (Container.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder) + is + begin + Clear (Container); + + if not Boolean'Input (Stream) then + Container.Element := new Element_Type'(Element_Type'Input (Stream)); + end if; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Holder) return Reference_Type + is + Ref : constant Reference_Type := + (Element => Container.Element.all'Access, + Control => (Controlled with Container'Unrestricted_Access)); + begin + Container.Busy := Container.Busy + 1; + return Ref; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type) + is + begin + if Container.Busy /= 0 then + raise Program_Error with "attempt to tamper with elements"; + end if; + + declare + X : Element_Access := Container.Element; + + -- Element allocator may need an accessibility check in case actual + -- type is class-wide or has access discriminants (RM 4.8(10.1) and + -- AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Container.Element := new Element_Type'(New_Item); + Free (X); + end; + end Replace_Element; + + --------------- + -- To_Holder -- + --------------- + + function To_Holder (New_Item : Element_Type) return Holder is + + -- The element allocator may need an accessibility check in the case the + -- actual type is class-wide or has access discriminants (RM 4.8(10.1) + -- and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + return (Controlled with new Element_Type'(New_Item), 0); + end To_Holder; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)) + is + B : Natural renames Container.Busy; + + begin + if Container.Element = null then + raise Constraint_Error with "container is empty"; + end if; + + B := B + 1; + + begin + Process (Container.Element.all); + exception + when others => + B := B - 1; + raise; + end; + + B := B - 1; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder) + is + begin + Boolean'Output (Stream, Container.Element = null); + + if Container.Element /= null then + Element_Type'Output (Stream, Container.Element.all); + end if; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-coinho.ads b/gcc/ada/libgnat/a-coinho.ads new file mode 100644 index 0000000..87e6a58 --- /dev/null +++ b/gcc/ada/libgnat/a-coinho.ads @@ -0,0 +1,178 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ H O L D E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type (<>) is private; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Holders is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate (Indefinite_Holders); + pragma Remote_Types (Indefinite_Holders); + + type Holder is tagged private; + pragma Preelaborable_Initialization (Holder); + + Empty_Holder : constant Holder; + + function "=" (Left, Right : Holder) return Boolean; + + function To_Holder (New_Item : Element_Type) return Holder; + + function Is_Empty (Container : Holder) return Boolean; + + procedure Clear (Container : in out Holder); + + function Element (Container : Holder) return Element_Type; + + procedure Replace_Element + (Container : in out Holder; + New_Item : Element_Type); + + procedure Query_Element + (Container : Holder; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Holder; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Holder) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Holder) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Holder; Source : Holder); + + function Copy (Source : Holder) return Holder; + + procedure Move (Target : in out Holder; Source : in out Holder); + +private + + use Ada.Finalization; + use Ada.Streams; + + type Element_Access is access all Element_Type; + + type Holder_Access is access all Holder; + for Holder_Access'Storage_Size use 0; + + procedure Read + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : out Holder); + + procedure Write + (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + Container : Holder); + + type Holder is new Ada.Finalization.Controlled with record + Element : Element_Access; + Busy : Natural := 0; + end record; + for Holder'Read use Read; + for Holder'Write use Write; + + overriding procedure Adjust (Container : in out Holder); + overriding procedure Finalize (Container : in out Holder); + + type Reference_Control_Type is new Controlled with + record + Container : Holder_Access; + end record; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + Empty_Holder : constant Holder := (Controlled with null, 0); + +end Ada.Containers.Indefinite_Holders; diff --git a/gcc/ada/libgnat/a-coinve.adb b/gcc/ada/libgnat/a-coinve.adb new file mode 100644 index 0000000..95431b8 --- /dev/null +++ b/gcc/ada/libgnat/a-coinve.adb @@ -0,0 +1,3663 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Indefinite_Vectors is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Type, Element_Access); + + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type); + -- This is the slow path for Append. This is split out to minimize the size + -- of Append, because we have Inline (Append). + + --------- + -- "&" -- + --------- + + -- We decide that the capacity of the result of "&" is the minimum needed + -- -- the sum of the lengths of the vector parameters. We could decide to + -- make it larger, but we have no basis for knowing how much larger, so we + -- just allocate the minimum amount of storage. + + function "&" (Left, Right : Vector) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + function "&" (Left : Vector; Right : Element_Type) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + 1); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + function "&" (Left : Element_Type; Right : Vector) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, 1 + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + function "&" (Left, Right : Element_Type) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, 1 + 1); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + --------- + -- "=" -- + --------- + + overriding function "=" (Left, Right : Vector) return Boolean is + begin + if Left.Last /= Right.Last then + return False; + end if; + + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Index_Type range Index_Type'First .. Left.Last loop + if Left.Elements.EA (J) = null then + if Right.Elements.EA (J) /= null then + return False; + end if; + + elsif Right.Elements.EA (J) = null then + return False; + + elsif Left.Elements.EA (J).all /= Right.Elements.EA (J).all then + return False; + end if; + end loop; + end; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Vector) is + begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + + if Container.Last = No_Index then + Container.Elements := null; + return; + end if; + + declare + L : constant Index_Type := Container.Last; + E : Elements_Array renames + Container.Elements.EA (Index_Type'First .. L); + + begin + Container.Elements := null; + Container.Last := No_Index; + + Container.Elements := new Elements_Type (L); + + for J in E'Range loop + if E (J) /= null then + Container.Elements.EA (J) := new Element_Type'(E (J).all); + end if; + + Container.Last := J; + end loop; + end; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then + return; + elsif Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item); + end if; + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + -- In the general case, we pass the buck to Insert, but for efficiency, + -- we check for the usual case where Count = 1 and the vector has enough + -- room for at least one more element. + + if Count = 1 + and then Container.Elements /= null + and then Container.Last /= Container.Elements.Last + then + TC_Check (Container.TC); + + -- Increment Container.Last after assigning the New_Item, so we + -- leave the Container unmodified in case Finalize/Adjust raises + -- an exception. + + declare + New_Last : constant Index_Type := Container.Last + 1; + + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + begin + Container.Elements.EA (New_Last) := new Element_Type'(New_Item); + Container.Last := New_Last; + end; + + else + Append_Slow_Path (Container, New_Item, Count); + end if; + end Append; + + ---------------------- + -- Append_Slow_Path -- + ---------------------- + + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + is + begin + if Count = 0 then + return; + elsif Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item, Count); + end if; + end Append_Slow_Path; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + begin + if Target'Address = Source'Address then + return; + else + Target.Clear; + Target.Append (Source); + end if; + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + else + return Container.Elements.EA'Length; + end if; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + TC_Check (Container.TC); + + while Container.Last >= Index_Type'First loop + declare + X : Element_Access := Container.Elements.EA (Container.Last); + begin + Container.Elements.EA (Container.Last) := null; + Container.Last := Container.Last - 1; + Free (X); + end; + end loop; + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Count_Type := 0) return Vector + is + C : Count_Type; + + begin + if Capacity < Source.Length then + if Checks and then Capacity /= 0 then + raise Capacity_Error + with "Requested capacity is less than Source length"; + end if; + + C := Source.Length; + else + C := Capacity; + end if; + + return Target : Vector do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + is + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Checks and then Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Checks and then Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + else + return; + end if; + end if; + + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, so we handle that case here in order to avoid having to + -- check it later. (Note that an empty vector can never be busy, so + -- there's no semantic harm in returning early.) + + if Container.Is_Empty then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + + TC_Check (Container.TC); + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If the number of elements requested (Count) for deletion is equal to + -- (or greater than) the number of elements available (Count2) for + -- deletion beginning at Index, then everything from Index to + -- Container.Last is deleted (this is equivalent to Delete_Last). + + if Count >= Count2 then + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in + -- order to gracefully handle deallocation failures. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + while Container.Last >= Index loop + declare + K : constant Index_Type := Container.Last; + X : Element_Access := EA (K); + + begin + -- We first isolate the element we're deleting, removing it + -- from the vector before we attempt to deallocate it, in + -- case the deallocation fails. + + EA (K) := null; + Container.Last := K - 1; + + -- Container invariants have been restored, so it is now + -- safe to attempt to deallocate the element. + + Free (X); + end; + end loop; + end; + + return; + end if; + + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. + + if Index_Type'Base'Last >= Count_Type_Last then + New_Last := Old_Last - Index_Type'Base (Count); + J := Index + Index_Type'Base (Count); + else + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + J := Index_Type'Base (Count_Type'Base (Index) + Count); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so what remains to be done is to first + -- deallocate the elements that are being deleted, and then slide down + -- to Index the elements that aren't being deleted. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + -- Before we can slide down the elements that aren't being deleted, + -- we need to deallocate the elements that are being deleted. + + for K in Index .. J - 1 loop + declare + X : Element_Access := EA (K); + + begin + -- First we remove the element we're about to deallocate from + -- the vector, in case the deallocation fails, in order to + -- preserve representation invariants. + + EA (K) := null; + + -- The element has been removed from the vector, so it is now + -- safe to attempt to deallocate it. + + Free (X); + end; + end loop; + + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; + end; + end Delete; + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + + elsif Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + + elsif Count >= Length (Container) then + Clear (Container); + return; + + else + Delete (Container, Index_Type'First, Count); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + + if Count = 0 then + return; + end if; + + -- We cannot simply subsume the empty case into the loop below (the loop + -- would iterate 0 times), because we rename the internal array object + -- (which is allocated), but an empty vector isn't guaranteed to have + -- actually allocated an array. (Note that an empty vector can never be + -- busy, so there's no semantic harm in returning early here.) + + if Container.Is_Empty then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + + TC_Check (Container.TC); + + -- Elements in an indefinite vector are allocated, so we must iterate + -- over the loop and deallocate elements one-at-a-time. We work from + -- back to front, deleting the last element during each pass, in order + -- to gracefully handle deallocation failures. + + declare + E : Elements_Array renames Container.Elements.EA; + + begin + for Indx in 1 .. Count_Type'Min (Count, Container.Length) loop + declare + J : constant Index_Type := Container.Last; + X : Element_Access := E (J); + + begin + -- Note that we first isolate the element we're deleting, + -- removing it from the vector, before we actually deallocate + -- it, in order to preserve representation invariants even if + -- the deallocation fails. + + E (J) := null; + Container.Last := J - 1; + + -- Container invariants have been restored, so it is now safe + -- to deallocate the element. + + Free (X); + end; + end loop; + end; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + EA : constant Element_Access := Container.Elements.EA (Index); + begin + if Checks and then EA = null then + raise Constraint_Error with "element is empty"; + else + return EA.all; + end if; + end; + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + declare + EA : constant Element_Access := + Position.Container.Elements.EA (Position.Index); + begin + if Checks and then EA = null then + raise Constraint_Error with "element is empty"; + else + return EA.all; + end if; + end; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Vector) is + begin + Clear (Container); -- Checks busy-bit + + declare + X : Elements_Access := Container.Elements; + begin + Container.Elements := null; + Free (X); + end; + end Finalize; + + procedure Finalize (Object : in out Iterator) is + begin + Unbusy (Object.Container.TC); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + begin + if Checks and then Position.Container /= null then + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for J in Position.Index .. Container.Last loop + if Container.Elements.EA (J).all = Item then + return Cursor'(Container'Unrestricted_Access, J); + end if; + end loop; + + return No_Element; + end; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for Indx in Index .. Container.Last loop + if Container.Elements.EA (Indx).all = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Find_Index; + + ----------- + -- First -- + ----------- + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unrestricted_Access, Index_Type'First); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Index component influences the + -- behavior of the First (and Last) selector function. + + -- When the Index component is No_Index, this means the iterator + -- object was constructed without a start expression, in which case the + -- (forward) iteration starts from the (logical) beginning of the entire + -- sequence of items (corresponding to Container.First, for a forward + -- iterator). + + -- Otherwise, this is iteration over a partial sequence of items. + -- When the Index component isn't No_Index, the iterator object was + -- constructed with a start expression, that specifies the position + -- from which the (forward) partial iteration begins. + + if Object.Index = No_Index then + return First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Index); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Checks and then Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + declare + EA : constant Element_Access := + Container.Elements.EA (Index_Type'First); + begin + if Checks and then EA = null then + raise Constraint_Error with "first element is empty"; + else + return EA.all; + end if; + end; + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Less (L, R : Element_Access) return Boolean; + pragma Inline (Is_Less); + + ------------- + -- Is_Less -- + ------------- + + function Is_Less (L, R : Element_Access) return Boolean is + begin + if L = null then + return R /= null; + elsif R = null then + return False; + else + return L.all < R.all; + end if; + end Is_Less; + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + begin + if Container.Last <= Index_Type'First then + return True; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + E : Elements_Array renames Container.Elements.EA; + begin + for J in Index_Type'First .. Container.Last - 1 loop + if Is_Less (E (J + 1), E (J)) then + return False; + end if; + end loop; + + return True; + end; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I, J : Index_Type'Base; + + begin + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Last < Index_Type'First then -- Source is empty + return; + end if; + + if Checks and then Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + + if Target.Last < Index_Type'First then -- Target is empty + Move (Target => Target, Source => Source); + return; + end if; + + TC_Check (Source.TC); + + I := Target.Last; -- original value (before Set_Length) + Target.Set_Length (Length (Target) + Length (Source)); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + TA : Elements_Array renames Target.Elements.EA; + SA : Elements_Array renames Source.Elements.EA; + + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); + begin + J := Target.Last; -- new value (after Set_Length) + while Source.Last >= Index_Type'First loop + pragma Assert + (Source.Last <= Index_Type'First + or else not (Is_Less (SA (Source.Last), + SA (Source.Last - 1)))); + + if I < Index_Type'First then + declare + Src : Elements_Array renames + SA (Index_Type'First .. Source.Last); + begin + TA (Index_Type'First .. J) := Src; + Src := (others => null); + end; + + Source.Last := No_Index; + exit; + end if; + + pragma Assert + (I <= Index_Type'First + or else not (Is_Less (TA (I), TA (I - 1)))); + + declare + Src : Element_Access renames SA (Source.Last); + Tgt : Element_Access renames TA (I); + + begin + if Is_Less (Src, Tgt) then + Target.Elements.EA (J) := Tgt; + Tgt := null; + I := I - 1; + + else + Target.Elements.EA (J) := Src; + Src := null; + Source.Last := Source.Last - 1; + end if; + end; + + J := J - 1; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) is + procedure Sort is new Generic_Array_Sort + (Index_Type => Index_Type, + Element_Type => Element_Access, + Array_Type => Elements_Array, + "<" => Is_Less); + + -- Start of processing for Sort + + begin + if Container.Last <= Index_Type'First then + return; + end if; + + -- The exception behavior for the vector container must match that + -- for the list container, so we check for cursor tampering here + -- (which will catch more things) instead of for element tampering + -- (which will catch fewer things). It's true that the elements of + -- this vector container could be safely moved around while (say) an + -- iteration is taking place (iteration only increments the busy + -- counter), and so technically all we would need here is a test for + -- element tampering (indicated by the lock counter), that's simply + -- an artifact of our array-based implementation. Logically Sort + -- requires a check for cursor tampering. + + TC_Check (Container.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + end; + end Sort; + + end Generic_Sorting; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access + is + Ptr : constant Element_Access := + Position.Container.Elements.EA (Position.Index); + + begin + -- An indefinite vector may contain spaces that hold no elements. + -- Any iteration over an indefinite vector with spaces will raise + -- Constraint_Error. + + if Ptr = null then + raise Constraint_Error; + + else + return Ptr; + end if; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + if Position.Container = null then + return False; + else + return Position.Index <= Position.Container.Last; + end if; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array + + begin + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) + + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + end if; + + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion count. + -- Note: we cannot simply add these values, because of the possibility + -- of overflow. + + if Checks and then Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= Count_Type_Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if Checks and then New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type_Last then + New_Last := No_Index + Index_Type'Base (New_Length); + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately allocated. + + Container.Elements := new Elements_Type (New_Last); + + -- The element backbone has been successfully allocated, so now we + -- allocate the elements. + + for Idx in Container.Elements.EA'Range loop + + -- In order to preserve container invariants, we always attempt + -- the element allocation first, before setting the Last index + -- value, in case the allocation fails (either because there is no + -- storage available, or because element initialization fails). + + declare + -- The element allocator may need an accessibility check in the + -- case actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Container.Elements.EA (Idx) := new Element_Type'(New_Item); + end; + + -- The allocation of the element succeeded, so it is now safe to + -- update the Last index, restoring container invariants. + + Container.Last := Idx; + end loop; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + TC_Check (Container.TC); + + if New_Length <= Container.Elements.EA'Length then + + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + + declare + E : Elements_Array renames Container.Elements.EA; + K : Index_Type'Base; + + begin + if Before > Container.Last then + + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. + + for Idx in Before .. New_Last loop + + -- In order to preserve container invariants, we always + -- attempt the element allocation first, before setting the + -- Last index value, in case the allocation fails (either + -- because there is no storage available, or because element + -- initialization fails). + + declare + -- The element allocator may need an accessibility check + -- in case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + E (Idx) := new Element_Type'(New_Item); + end; + + -- The allocation of the element succeeded, so it is now + -- safe to update the Last index, restoring container + -- invariants. + + Container.Last := Idx; + end loop; + + else + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + -- The new items are being inserted in the middle of the array, + -- in the range [Before, Index). Copy the existing elements to + -- the end of the array, to make room for the new items. + + E (Index .. New_Last) := E (Before .. Container.Last); + Container.Last := New_Last; + + -- We have copied the existing items up to the end of the + -- array, to make room for the new items in the middle of + -- the array. Now we actually allocate the new items. + + -- Note: initialize K outside loop to make it clear that + -- K always has a value if the exception handler triggers. + + K := Before; + + declare + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + while K < Index loop + E (K) := new Element_Type'(New_Item); + K := K + 1; + end loop; + + exception + when others => + + -- Values in the range [Before, K) were successfully + -- allocated, but values in the range [K, Index) are + -- stale (these array positions contain copies of the + -- old items, that did not get assigned a new item, + -- because the allocation failed). We must finish what + -- we started by clearing out all of the stale values, + -- leaving a "hole" in the middle of the array. + + E (K .. Index - 1) := (others => null); + raise; + end; + end if; + end; + + return; + end if; + + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; + + New_Capacity := 2 * New_Capacity; + end loop; + + if New_Capacity > Max_Length then + + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) + + New_Capacity := Max_Length; + end if; + + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + if Index_Type'Base'Last >= Count_Type_Last then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. + + declare + Src : Elements_Access := Container.Elements; + + begin + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); + + if Before > Container.Last then + + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. + + -- We have copied the elements from to the old source array to the + -- new destination array, so we can now deallocate the old array. + + Container.Elements := Dst; + Free (Src); + + -- Now we append the new items. + + for Idx in Before .. New_Last loop + + -- In order to preserve container invariants, we always attempt + -- the element allocation first, before setting the Last index + -- value, in case the allocation fails (either because there + -- is no storage available, or because element initialization + -- fails). + + declare + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Dst.EA (Idx) := new Element_Type'(New_Item); + end; + + -- The allocation of the element succeeded, so it is now safe + -- to update the Last index, restoring container invariants. + + Container.Last := Idx; + end loop; + + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); + + -- We have copied the elements from to the old source array to the + -- new destination array, so we can now deallocate the old array. + + Container.Elements := Dst; + Container.Last := New_Last; + Free (Src); + + -- The new array has a range in the middle containing null access + -- values. Fill in that partition of the array with the new items. + + for Idx in Before .. Index - 1 loop + + -- Note that container invariants have already been satisfied + -- (in particular, the Last index value of the vector has + -- already been updated), so if this allocation fails we simply + -- let it propagate. + + declare + -- The element allocator may need an accessibility check in + -- the case the actual type is class-wide or has access + -- discriminants (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Dst.EA (Idx) := new Element_Type'(New_Item); + end; + end loop; + end if; + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; + + begin + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. + + Insert_Space (Container, Before, Count => N); + + if N = 0 then + + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; + end if; + + if Container'Address /= New_Item'Address then + + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. + + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. New_Item.Last; + + Src : Elements_Array renames + New_Item.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + Dst_Index := Before - 1; + for Src_Index in Src'Range loop + Dst_Index := Dst_Index + 1; + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + end; + + return; + end if; + + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The first source slice is + -- [Index_Type'First, Before), and the second source slice is + -- [J, Container.Last], where index value J is the first index of the + -- second slice. (J gets computed below, but only after we have + -- determined that the second source slice is non-empty.) The + -- destination slice is always the range [Before, J). We perform the + -- copy in two steps, using each of the two slices of the source items. + + declare + L : constant Index_Type'Base := Before - 1; + + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + -- We first copy the source items that precede the space we + -- inserted. (If Before equals Index_Type'First, then this first + -- source slice will be empty, which is harmless.) + + Dst_Index := Before - 1; + for Src_Index in Src'Range loop + Dst_Index := Dst_Index + 1; + + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + end loop; + + if Src'Length = N then + + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J, which will overflow if J is greater than + -- Index_Type'Base'Last. + + return; + end if; + end; + + -- Index value J is the first index of the second source slice. (It is + -- also 1 greater than the last index of the destination slice.) Note: + -- avoid computing J if J is greater than Index_Type'Base'Last, in order + -- to avoid overflow. Prevent that by returning early above, immediately + -- after copying the first slice of the source, and determining that + -- this second slice of the source is empty. + + if Index_Type'Base'Last >= Count_Type_Last then + J := Before + Index_Type'Base (N); + else + J := Index_Type'Base (Count_Type'Base (Before) + N); + end if; + + declare + subtype Src_Index_Subtype is Index_Type'Base range + J .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + Dst : Elements_Array renames Container.Elements.EA; + + Dst_Index : Index_Type'Base; + + begin + -- We next copy the source items that follow the space we inserted. + -- Index value Dst_Index is the first index of that portion of the + -- destination that receives this slice of the source. (For the + -- reasons given above, this slice is guaranteed to be non-empty.) + + if Index_Type'Base'Last >= Count_Type_Last then + Dst_Index := J - Index_Type'Base (Src'Length); + else + Dst_Index := Index_Type'Base (Count_Type'Base (J) - Src'Length); + end if; + + for Src_Index in Src'Range loop + if Src (Src_Index) /= null then + Dst (Dst_Index) := new Element_Type'(Src (Src_Index).all); + end if; + + Dst_Index := Dst_Index + 1; + end loop; + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + if Before.Container = null or else Before.Index > Container.Last then + Position := No_Element; + else + Position := (Container'Unrestricted_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + Position := (Container'Unrestricted_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null or else Before.Index > Container.Last then + Position := No_Element; + else + Position := (Container'Unrestricted_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + Position := (Container'Unrestricted_Access, Index); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array + + begin + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) + + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + end if; + + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion count. + -- Note: we cannot simply add these values, because of the possibility + -- of overflow. + + if Checks and then Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type_Last then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= Count_Type_Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if Checks and then New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type_Last then + New_Last := No_Index + Index_Type'Base (New_Length); + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In an indefinite vector, elements are allocated individually, and + -- stored as access values on the internal array (the length of which + -- represents the vector "capacity"), which is separately allocated. + -- We have no elements here (because we're inserting "space"), so all + -- we need to do is allocate the backbone. + + Container.Elements := new Elements_Type (New_Last); + Container.Last := New_Last; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on exit. + -- Insert checks the count to determine whether it is being called while + -- the associated callback procedure is executing. + + TC_Check (Container.TC); + + if New_Length <= Container.Elements.EA'Length then + + -- In this case, we are inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + + declare + E : Elements_Array renames Container.Elements.EA; + + begin + if Before <= Container.Last then + + -- The new space is being inserted before some existing + -- elements, so we must slide the existing elements up to + -- their new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + E (Index .. New_Last) := E (Before .. Container.Last); + E (Before .. Index - 1) := (others => null); + end if; + end; + + Container.Last := New_Last; + return; + end if; + + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; + + New_Capacity := 2 * New_Capacity; + end loop; + + if New_Capacity > Max_Length then + + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) + + New_Capacity := Max_Length; + end if; + + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + if Index_Type'Base'Last >= Count_Type_Last then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array) to the new array (the "destination" array), and then + -- deallocate the old array. + + declare + Src : Elements_Access := Container.Elements; + + begin + Dst.EA (Index_Type'First .. Before - 1) := + Src.EA (Index_Type'First .. Before - 1); + + if Before <= Container.Last then + + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + Dst.EA (Index .. New_Last) := Src.EA (Before .. Container.Last); + end if; + + -- We have copied the elements from to the old, source array to the + -- new, destination array, so we can now restore invariants, and + -- deallocate the old array. + + Container.Elements := Dst; + Container.Last := New_Last; + Free (Src); + end; + end Insert_Space; + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null or else Before.Index > Container.Last then + Position := No_Element; + else + Position := (Container'Unrestricted_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert_Space (Container, Index, Count); + + Position := (Container'Unrestricted_Access, Index); + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + end Iterate; + + function Iterate + (Container : Vector) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class + is + V : constant Vector_Access := Container'Unrestricted_Access; + begin + -- The value of its Index component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Index + -- component is No_Index (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => V, + Index => No_Index) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : Vector; + Start : Cursor) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class + is + V : constant Vector_Access := Container'Unrestricted_Access; + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks then + if Start.Container = null then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= V then + raise Program_Error with + "Start cursor of Iterate designates wrong vector"; + end if; + + if Start.Index > V.Last then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + end if; + + -- The value of its Index component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Index + -- component is not No_Index (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => V, + Index => Start.Index) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unrestricted_Access, Container.Last); + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Index component influences the + -- behavior of the Last (and First) selector function. + + -- When the Index component is No_Index, this means the iterator + -- object was constructed without a start expression, in which case the + -- (reverse) iteration starts from the (logical) beginning of the entire + -- sequence (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. + -- When the Index component is not No_Index, the iterator object was + -- constructed with a start expression, that specifies the position + -- from which the (reverse) partial iteration begins. + + if Object.Index = No_Index then + return Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Index); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Checks and then Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + end if; + + declare + EA : constant Element_Access := + Container.Elements.EA (Container.Last); + begin + if Checks and then EA = null then + raise Constraint_Error with "last element is empty"; + else + return EA.all; + end if; + end; + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Count_Type is + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Vector; + Source : in out Vector) + is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Clear (Target); -- Checks busy-bit + + declare + Target_Elements : constant Elements_Access := Target.Elements; + begin + Target.Elements := Source.Elements; + Source.Elements := Target_Elements; + end; + + Target.Last := Source.Last; + Source.Last := No_Index; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Position.Index < Position.Container.Last then + return (Position.Container, Position.Index + 1); + else + return No_Element; + end if; + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong vector"; + else + return Next (Position); + end if; + end Next; + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index < Position.Container.Last then + Position.Index := Position.Index + 1; + else + Position := No_Element; + end if; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, Index_Type'First, New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Position.Index > Index_Type'First then + return (Position.Container, Position.Index - 1); + else + return No_Element; + end if; + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); + end if; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index > Index_Type'First then + Position.Index := Position.Index - 1; + else + Position := No_Element; + end if; + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + Lock : With_Lock (Container.TC'Unrestricted_Access); + V : Vector renames Container'Unrestricted_Access.all; + + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if Checks and then V.Elements.EA (Index) = null then + raise Constraint_Error with "element is null"; + end if; + + Process (V.Elements.EA (Index).all); + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); + end if; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := Index_Type'Pred (Index_Type'First); + B : Boolean; + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, Length); + + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; + + for J in Count_Type range 1 .. Length loop + Last := Last + 1; + + Boolean'Read (Stream, B); + + if B then + Container.Elements.EA (Last) := + new Element_Type'(Element_Type'Input (Stream)); + end if; + + Container.Last := Last; + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + + return R : constant Reference_Type := + (Element => Container.Elements.EA (Position.Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + -- The following will raise Constraint_Error if Element is null + + return R : constant Reference_Type := + (Element => Container.Elements.EA (Index), + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + TE_Check (Container.TC); + + declare + X : Element_Access := Container.Elements.EA (Index); + + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Container.Elements.EA (Index) := new Element_Type'(New_Item); + Free (X); + end; + end Replace_Element; + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + TE_Check (Container.TC); + + declare + X : Element_Access := Container.Elements.EA (Position.Index); + + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + Container.Elements.EA (Position.Index) := new Element_Type'(New_Item); + Free (X); + end; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type) + is + N : constant Count_Type := Length (Container); + + Index : Count_Type'Base; + Last : Index_Type'Base; + + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + + if Capacity = 0 then + + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + + if N = 0 then + + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + + declare + X : Elements_Access := Container.Elements; + + begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception + -- (although that's unlikely, since this is simply an array of + -- access values, all of which are null). + + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + + Free (X); + end; + + elsif N < Container.Elements.EA'Length then + + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + + TC_Check (Container.TC); + + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + + begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have successfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so we can + -- deallocate the old array. + + Free (X); + end; + end if; + + return; + end if; + + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with index values greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index + then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Capacity); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + + if Container.Elements = null then + + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate storage having the given + -- capacity. + + Container.Elements := new Elements_Type (Last); + return; + end if; + + if Capacity <= N then + + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + + if N < Container.Elements.EA'Length then + + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so there + -- is storage available to trim. In this case, we allocate a new + -- internal array having a length that exactly matches the number + -- of items in the container. + + TC_Check (Container.TC); + + declare + subtype Array_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Array_Index_Subtype); + + X : Elements_Access := Container.Elements; + + begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (because there is not enough storage), we + -- let it propagate without causing any side-effect. + + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have successfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to deallocate the old array. + + Free (X); + end; + end if; + + return; + end if; + + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + + if Capacity = Container.Elements.EA'Length then + + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + + return; + end if; + + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + + TC_Check (Container.TC); + + -- We now allocate a new internal array, having a length different from + -- its current value. + + declare + X : Elements_Access := Container.Elements; + + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + begin + -- We now allocate a new internal array, having a length different + -- from its current value. + + Container.Elements := new Elements_Type (Last); + + -- We have successfully allocated the new internal array, so now we + -- move the existing elements from the existing the old internal + -- array onto the new one. Note that we're just copying access + -- values, to this should not raise any exceptions. + + Container.Elements.EA (Index_Subtype) := X.EA (Index_Subtype); + + -- We have moved the elements from the old internal array, so now we + -- can deallocate it. + + Free (X); + end; + end Reserve_Capacity; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + begin + if Container.Length <= 1 then + return; + end if; + + -- The exception behavior for the vector container must match that for + -- the list container, so we check for cursor tampering here (which will + -- catch more things) instead of for element tampering (which will catch + -- fewer things). It's true that the elements of this vector container + -- could be safely moved around while (say) an iteration is taking place + -- (iteration only increments the busy counter), and so technically all + -- we would need here is a test for element tampering (indicated by the + -- lock counter), that's simply an artifact of our array-based + -- implementation. Logically Reverse_Elements requires a check for + -- cursor tampering. + + TC_Check (Container.TC); + + declare + I : Index_Type; + J : Index_Type; + E : Elements_Array renames Container.Elements.EA; + + begin + I := Index_Type'First; + J := Container.Last; + while I < J loop + declare + EI : constant Element_Access := E (I); + + begin + E (I) := E (J); + E (J) := EI; + end; + + I := I + 1; + J := J - 1; + end loop; + end; + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; + + begin + if Checks and then Position.Container /= null + and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + Last := + (if Position.Container = null or else Position.Index > Container.Last + then Container.Last + else Position.Index); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements.EA (Indx) /= null + and then Container.Elements.EA (Indx).all = Item + then + return Cursor'(Container'Unrestricted_Access, Indx); + end if; + end loop; + + return No_Element; + end; + end Reverse_Find; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Last : constant Index_Type'Base := + Index_Type'Min (Container.Last, Index); + + begin + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements.EA (Indx) /= null + and then Container.Elements.EA (Indx).all = Item + then + return Indx; + end if; + end loop; + + return No_Index; + end Reverse_Find_Index; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + end Reverse_Iterate; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length (Container : in out Vector; Length : Count_Type) is + Count : constant Count_Type'Base := Container.Length - Length; + + begin + -- Set_Length allows the user to set the length explicitly, instead of + -- implicitly as a side-effect of deletion or insertion. If the + -- requested length is less than the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent to + -- inserting "space" (nonce items) at the end. + + if Count >= 0 then + Container.Delete_Last (Count); + + elsif Checks and then Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + + else + Container.Insert_Space (Container.Last + 1, -Count); + end if; + end Set_Length; + + ---------- + -- Swap -- + ---------- + + procedure Swap (Container : in out Vector; I, J : Index_Type) is + begin + if Checks then + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + end if; + + if I = J then + return; + end if; + + TE_Check (Container.TC); + + declare + EI : Element_Access renames Container.Elements.EA (I); + EJ : Element_Access renames Container.Elements.EA (J); + + EI_Copy : constant Element_Access := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + procedure Swap + (Container : in out Vector; + I, J : Cursor) + is + begin + if Checks then + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; + end if; + + if J.Container = null then + raise Constraint_Error with "J cursor has no element"; + end if; + + if I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + end if; + + if J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; + end if; + + Swap (Container, I.Index, J.Index); + end Swap; + + --------------- + -- To_Cursor -- + --------------- + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is + begin + if Index not in Index_Type'First .. Container.Last then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Index); + end To_Cursor; + + -------------- + -- To_Index -- + -------------- + + function To_Index (Position : Cursor) return Extended_Index is + begin + if Position.Container = null then + return No_Index; + elsif Position.Index <= Position.Container.Last then + return Position.Index; + else + return No_Index; + end if; + end To_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector (Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type (Last); + + return Vector'(Controlled with Elements, Last, TC => <>); + end To_Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector + is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type (Last); + + -- We use Last as the index of the loop used to populate the internal + -- array with items. In general, we prefer to initialize the loop index + -- immediately prior to entering the loop. However, Last is also used in + -- the exception handler (to reclaim elements that have been allocated, + -- before propagating the exception), and the initialization of Last + -- after entering the block containing the handler confuses some static + -- analysis tools, with respect to whether Last has been properly + -- initialized when the handler executes. So here we initialize our loop + -- variable earlier than we prefer, before entering the block, so there + -- is no ambiguity. + + Last := Index_Type'First; + + declare + -- The element allocator may need an accessibility check in the case + -- where the actual type is class-wide or has access discriminants + -- (see RM 4.8(10.1) and AI12-0035). + + pragma Unsuppress (Accessibility_Check); + + begin + loop + Elements.EA (Last) := new Element_Type'(New_Item); + exit when Last = Elements.Last; + Last := Last + 1; + end loop; + + exception + when others => + for J in Index_Type'First .. Last - 1 loop + Free (Elements.EA (J)); + end loop; + + Free (Elements); + raise; + end; + + return (Controlled with Elements, Last, TC => <>); + end To_Vector; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)) + is + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + if Checks and then Container.Elements.EA (Index) = null then + raise Constraint_Error with "element is null"; + end if; + + Process (Container.Elements.EA (Index).all); + end Update_Element; + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + end if; + + Update_Element (Container, Position.Index, Process); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector) + is + N : constant Count_Type := Length (Container); + + begin + Count_Type'Base'Write (Stream, N); + + if N = 0 then + return; + end if; + + declare + E : Elements_Array renames Container.Elements.EA; + + begin + for Indx in Index_Type'First .. Container.Last loop + if E (Indx) = null then + Boolean'Write (Stream, False); + else + Boolean'Write (Stream, True); + Element_Type'Output (Stream, E (Indx).all); + end if; + end loop; + end; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-coinve.ads b/gcc/ada/libgnat/a-coinve.ads new file mode 100644 index 0000000..dc8e14f --- /dev/null +++ b/gcc/ada/libgnat/a-coinve.ads @@ -0,0 +1,509 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . I N D E F I N I T E _ V E C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Index_Type is range <>; + type Element_Type (<>) is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Indefinite_Vectors is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + + No_Index : constant Extended_Index := Extended_Index'First; + + type Vector is tagged private + with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Vector : constant Vector; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package Vector_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + overriding function "=" (Left, Right : Vector) return Boolean; + + function To_Vector (Length : Count_Type) return Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector; + + function "&" (Left, Right : Vector) return Vector; + + function "&" (Left : Vector; Right : Element_Type) return Vector; + + function "&" (Left : Element_Type; Right : Vector) return Vector; + + function "&" (Left, Right : Element_Type) return Vector; + + function Capacity (Container : Vector) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type); + + function Length (Container : Vector) return Count_Type; + + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + + function Is_Empty (Container : Vector) return Boolean; + + procedure Clear (Container : in out Vector); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type; + pragma Inline (Reference); + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor; + + function To_Index (Position : Cursor) return Extended_Index; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type); + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Assign (Target : in out Vector; Source : Vector); + + function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; + + procedure Move (Target : in out Vector; Source : in out Vector); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Vector); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out Vector; + New_Item : Vector); + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out Vector); + + procedure Swap (Container : in out Vector; I, J : Index_Type); + + procedure Swap (Container : in out Vector; I, J : Cursor); + + function First_Index (Container : Vector) return Index_Type; + + function First (Container : Vector) return Cursor; + + function First_Element (Container : Vector) return Element_Type; + + function Last_Index (Container : Vector) return Extended_Index; + + function Last (Container : Vector) return Cursor; + + function Last_Element (Container : Vector) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index; + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index; + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + function Iterate (Container : Vector) + return Vector_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : Vector; + Start : Cursor) + return Vector_Iterator_Interfaces.Reversible_Iterator'class; + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target : in out Vector; Source : in out Vector); + + end Generic_Sorting; + +private + + pragma Inline (Append); + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Query_Element); + pragma Inline (Update_Element); + pragma Inline (Replace_Element); + pragma Inline (Is_Empty); + pragma Inline (Contains); + pragma Inline (Next); + pragma Inline (Previous); + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + type Element_Access is access Element_Type; + + type Elements_Array is array (Index_Type range <>) of Element_Access; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Elements_Type (Last : Extended_Index) is limited record + EA : Elements_Array (Index_Type'First .. Last); + end record; + + type Elements_Access is access all Elements_Type; + + use Finalization; + use Streams; + + type Vector is new Controlled with record + Elements : Elements_Access := null; + Last : Extended_Index := No_Index; + TC : aliased Tamper_Counts; + end record; + + overriding procedure Adjust (Container : in out Vector); + overriding procedure Finalize (Container : in out Vector); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector); + + for Vector'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector); + + for Vector'Read use Read; + + type Vector_Access is access all Vector; + for Vector_Access'Storage_Size use 0; + + type Cursor is record + Container : Vector_Access; + Index : Index_Type := Index_Type'First; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + + Empty_Vector : constant Vector := (Controlled with others => <>); + + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type'Base; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Indefinite_Vectors; diff --git a/gcc/ada/libgnat/a-colien.adb b/gcc/ada/libgnat/a-colien.adb new file mode 100644 index 0000000..2720fc3 --- /dev/null +++ b/gcc/ada/libgnat/a-colien.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; + +package body Ada.Command_Line.Environment is + + ----------------------- + -- Environment_Count -- + ----------------------- + + function Environment_Count return Natural is + function Env_Count return Natural; + pragma Import (C, Env_Count, "__gnat_env_count"); + + begin + return Env_Count; + end Environment_Count; + + ----------------------- + -- Environment_Value -- + ----------------------- + + function Environment_Value (Number : Positive) return String is + procedure Fill_Env (E : System.Address; Env_Num : Integer); + pragma Import (C, Fill_Env, "__gnat_fill_env"); + + function Len_Env (Env_Num : Integer) return Integer; + pragma Import (C, Len_Env, "__gnat_len_env"); + + begin + if Number > Environment_Count then + raise Constraint_Error; + end if; + + declare + Env : aliased String (1 .. Len_Env (Number - 1)); + begin + Fill_Env (Env'Address, Number - 1); + return Env; + end; + end Environment_Value; + +end Ada.Command_Line.Environment; diff --git a/gcc/ada/libgnat/a-colien.ads b/gcc/ada/libgnat/a-colien.ads new file mode 100644 index 0000000..886620f --- /dev/null +++ b/gcc/ada/libgnat/a-colien.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . E N V I R O N M E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: Services offered by this package are guaranteed to be platform +-- independent as long as no call to GNAT.OS_Lib.Setenv or to C putenv +-- routine is done. On some platforms the services below will report new +-- environment variables (e.g. Windows) on some others it will not +-- (e.g. GNU/Linux and Solaris). + +package Ada.Command_Line.Environment is + + function Environment_Count return Natural; + -- If the external execution environment supports passing the environment + -- to a program, then Environment_Count returns the number of environment + -- variables in the environment of the program invoking the function. + -- Otherwise it returns 0. And that's a lot of environment. + + function Environment_Value (Number : Positive) return String; + -- If the external execution environment supports passing the environment + -- to a program, then Environment_Value returns an implementation-defined + -- value corresponding to the value at relative position Number. If Number + -- is outside the range 1 .. Environment_Count, then Constraint_Error is + -- propagated. + -- + -- in GNAT: Corresponds to envp [n-1] (for n > 0) in C. + +end Ada.Command_Line.Environment; diff --git a/gcc/ada/libgnat/a-colire.adb b/gcc/ada/libgnat/a-colire.adb new file mode 100644 index 0000000..907abf2 --- /dev/null +++ b/gcc/ada/libgnat/a-colire.adb @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E M O V E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Command_Line.Remove is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Initialize; + -- Initialize the Remove_Count and Remove_Args variables + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + if Remove_Args = null then + Remove_Count := Argument_Count; + Remove_Args := new Arg_Nums (1 .. Argument_Count); + + for J in Remove_Args'Range loop + Remove_Args (J) := J; + end loop; + end if; + end Initialize; + + --------------------- + -- Remove_Argument -- + --------------------- + + procedure Remove_Argument (Number : Positive) is + begin + Initialize; + + if Number > Remove_Count then + raise Constraint_Error; + end if; + + Remove_Count := Remove_Count - 1; + + for J in Number .. Remove_Count loop + Remove_Args (J) := Remove_Args (J + 1); + end loop; + end Remove_Argument; + + procedure Remove_Argument (Argument : String) is + begin + for J in reverse 1 .. Argument_Count loop + if Argument = Ada.Command_Line.Argument (J) then + Remove_Argument (J); + end if; + end loop; + end Remove_Argument; + + ---------------------- + -- Remove_Arguments -- + ---------------------- + + procedure Remove_Arguments (From : Positive; To : Natural) is + begin + Initialize; + + if From > Remove_Count + or else To > Remove_Count + then + raise Constraint_Error; + end if; + + if To >= From then + Remove_Count := Remove_Count - (To - From + 1); + + for J in From .. Remove_Count loop + Remove_Args (J) := Remove_Args (J + (To - From + 1)); + end loop; + end if; + end Remove_Arguments; + + procedure Remove_Arguments (Argument_Prefix : String) is + begin + for J in reverse 1 .. Argument_Count loop + declare + Arg : constant String := Argument (J); + + begin + if Arg'Length >= Argument_Prefix'Length + and then Arg (1 .. Argument_Prefix'Length) = Argument_Prefix + then + Remove_Argument (J); + end if; + end; + end loop; + end Remove_Arguments; + +end Ada.Command_Line.Remove; diff --git a/gcc/ada/libgnat/a-colire.ads b/gcc/ada/libgnat/a-colire.ads new file mode 100644 index 0000000..c7c6f63 --- /dev/null +++ b/gcc/ada/libgnat/a-colire.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E . R E M O V E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is intended to be used in conjunction with its parent unit, +-- Ada.Command_Line. It provides facilities for logically removing arguments +-- from the command line, so that subsequent calls to Argument_Count and +-- Argument will reflect the removals. + +-- For example, if the original command line has three arguments A B C, so +-- that Argument_Count is initially three, then after removing B, the second +-- argument, Argument_Count will be 2, and Argument (2) will return C. + +package Ada.Command_Line.Remove is + pragma Preelaborate; + + procedure Remove_Argument (Number : Positive); + -- Removes the argument identified by Number, which must be in the + -- range 1 .. Argument_Count (i.e. an in range argument number which + -- reflects removals). If Number is out of range Constraint_Error + -- will be raised. + -- + -- Note: the numbering of arguments greater than Number is affected + -- by the call. If you need a loop through the arguments, removing + -- some as you go, run the loop in reverse to avoid confusion from + -- this renumbering: + -- + -- for J in reverse 1 .. Argument_Count loop + -- if Should_Remove (Arguments (J)) then + -- Remove_Argument (J); + -- end if; + -- end loop; + -- + -- Reversing the loop in this manner avoids the confusion. + + procedure Remove_Arguments (From : Positive; To : Natural); + -- Removes arguments in the given From..To range. From must be in the + -- range 1 .. Argument_Count and To in the range 0 .. Argument_Count. + -- Constraint_Error is raised if either argument is out of range. If + -- To is less than From, then the call has no effect. + + procedure Remove_Argument (Argument : String); + -- Removes the argument which matches the given string Argument. Has + -- no effect if no argument matches the string. If more than one + -- argument matches the string, all are removed. + + procedure Remove_Arguments (Argument_Prefix : String); + -- Removes all arguments whose prefix matches Argument_Prefix. Has + -- no effect if no argument matches the string. For example a call + -- to Remove_Arguments ("--") removes all arguments starting with --. + +end Ada.Command_Line.Remove; diff --git a/gcc/ada/libgnat/a-comlin.adb b/gcc/ada/libgnat/a-comlin.adb new file mode 100644 index 0000000..a555410 --- /dev/null +++ b/gcc/ada/libgnat/a-comlin.adb @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; + +package body Ada.Command_Line is + + function Arg_Count return Natural; + pragma Import (C, Arg_Count, "__gnat_arg_count"); + + procedure Fill_Arg (A : System.Address; Arg_Num : Integer); + pragma Import (C, Fill_Arg, "__gnat_fill_arg"); + + function Len_Arg (Arg_Num : Integer) return Integer; + pragma Import (C, Len_Arg, "__gnat_len_arg"); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Initialized return Boolean; + -- Checks to ensure that gnat_argc and gnat_argv have been properly + -- initialized. Returns false if not, or if argv / argc are + -- unsupported on the target (e.g. VxWorks). + + -------------- + -- Argument -- + -------------- + + function Argument (Number : Positive) return String is + begin + if Number > Argument_Count then + raise Constraint_Error; + end if; + + declare + Num : constant Positive := + (if Remove_Args = null then Number else Remove_Args (Number)); + Arg : aliased String (1 .. Len_Arg (Num)); + begin + Fill_Arg (Arg'Address, Num); + return Arg; + end; + end Argument; + + -------------------- + -- Argument_Count -- + -------------------- + + function Argument_Count return Natural is + begin + if not Initialized then + -- RM A.15 (11) + return 0; + end if; + + if Remove_Args = null then + return Arg_Count - 1; + else + return Remove_Count; + end if; + end Argument_Count; + + ----------------- + -- Initialized -- + ----------------- + + function Initialized return Boolean is + gnat_argv : System.Address; + pragma Import (C, gnat_argv, "gnat_argv"); + + begin + return gnat_argv /= System.Null_Address; + end Initialized; + + ------------------ + -- Command_Name -- + ------------------ + + function Command_Name return String is + begin + if not Initialized then + return ""; + end if; + + declare + Arg : aliased String (1 .. Len_Arg (0)); + + begin + Fill_Arg (Arg'Address, 0); + return Arg; + end; + end Command_Name; + +end Ada.Command_Line; diff --git a/gcc/ada/libgnat/a-comlin.ads b/gcc/ada/libgnat/a-comlin.ads new file mode 100644 index 0000000..c4eecef --- /dev/null +++ b/gcc/ada/libgnat/a-comlin.ads @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M M A N D _ L I N E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Command_Line is + pragma Preelaborate; + + function Argument_Count return Natural; + -- If the external execution environment supports passing arguments to a + -- program, then Argument_Count returns the number of arguments passed to + -- the program invoking the function. Otherwise it return 0. + -- + -- In GNAT: Corresponds to (argc - 1) in C. + + pragma Assertion_Policy (Pre => Ignore); + -- We need to ignore the precondition of Argument, below, so that we don't + -- raise Assertion_Error. The body raises Constraint_Error. It would be + -- cleaner to add "or else raise Constraint_Error" to the precondition, but + -- SPARK does not yet support raise expressions. + + function Argument (Number : Positive) return String with + Pre => Number <= Argument_Count; + -- If the external execution environment supports passing arguments to + -- a program, then Argument returns an implementation-defined value + -- corresponding to the argument at relative position Number. If Number + -- is outside the range 1 .. Argument_Count, then Constraint_Error is + -- propagated. + -- + -- in GNAT: Corresponds to argv [n] (for n > 0) in C. + + function Command_Name return String; + -- If the external execution environment supports passing arguments to + -- a program, then Command_Name returns an implementation-defined value + -- corresponding to the name of the command invoking the program. + -- Otherwise Command_Name returns the null string. + -- + -- in GNAT: Corresponds to argv [0] in C. + + type Exit_Status is new Integer; + + Success : constant Exit_Status; + Failure : constant Exit_Status; + + procedure Set_Exit_Status (Code : Exit_Status); + + ------------------------------------ + -- Note on Interface Requirements -- + ------------------------------------ + + -- Services in this package are not supported during the elaboration of an + -- auto-initialized Stand-Alone Library. + + -- If the main program is in Ada, this package works as specified without + -- any other work than the normal steps of WITH'ing the package and then + -- calling the desired routines. + + -- If the main program is not in Ada, then the information must be made + -- available for this package to work correctly. In particular, it is + -- required that the global variable "gnat_argc" contain the number of + -- arguments, and that the global variable "gnat_argv" points to an + -- array of null-terminated strings, the first entry being the command + -- name, and the remaining entries being the command arguments. + + -- These correspond to the normal argc/argv variables passed to a C + -- main program, and the following is an example of a complete C main + -- program that stores the required information: + + -- main(int argc, char **argv, char **envp) + -- { + -- extern int gnat_argc; + -- extern char **gnat_argv; + -- extern char **gnat_envp; + -- gnat_argc = argc; + -- gnat_argv = argv; + -- gnat_envp = envp; + + -- adainit(); + -- adamain(); + -- adafinal(); + -- } + + -- The assignment statements ensure that the necessary information is + -- available for finding the command name and command line arguments. + +private + Success : constant Exit_Status := 0; + Failure : constant Exit_Status := 1; + + -- The following locations support the operation of the package + -- Ada.Command_Line.Remove, which provides facilities for logically + -- removing arguments from the command line. If one of the remove + -- procedures is called in this unit, then Remove_Args/Remove_Count + -- are set to indicate which arguments are removed. If no such calls + -- have been made, then Remove_Args is null. + + Remove_Count : Natural; + -- Number of arguments reflecting removals. Not defined unless + -- Remove_Args is non-null. + + type Arg_Nums is array (Positive range <>) of Positive; + type Arg_Nums_Ptr is access Arg_Nums; + -- An array that maps logical argument numbers (reflecting removal) + -- to physical argument numbers (e.g. if the first argument has been + -- removed, but not the second, then Arg_Nums (1) will be set to 2. + + Remove_Args : Arg_Nums_Ptr := null; + -- Left set to null if no remove calls have been made, otherwise set + -- to point to an appropriate mapping array. Only the first Remove_Count + -- elements are relevant. + + pragma Import (C, Set_Exit_Status, "__gnat_set_exit_status"); + +end Ada.Command_Line; diff --git a/gcc/ada/libgnat/a-comutr.adb b/gcc/ada/libgnat/a-comutr.adb new file mode 100644 index 0000000..944e51f --- /dev/null +++ b/gcc/ada/libgnat/a-comutr.adb @@ -0,0 +1,2676 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Multiway_Trees is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + -------------------- + -- Root_Iterator -- + -------------------- + + type Root_Iterator is abstract new Limited_Controlled and + Tree_Iterator_Interfaces.Forward_Iterator with + record + Container : Tree_Access; + Subtree : Tree_Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Root_Iterator); + + ----------------------- + -- Subtree_Iterator -- + ----------------------- + + -- ??? these headers are a bit odd, but for sure they do not substitute + -- for documenting things, what *is* a Subtree_Iterator? + + type Subtree_Iterator is new Root_Iterator with null record; + + overriding function First (Object : Subtree_Iterator) return Cursor; + + overriding function Next + (Object : Subtree_Iterator; + Position : Cursor) return Cursor; + + --------------------- + -- Child_Iterator -- + --------------------- + + type Child_Iterator is new Root_Iterator and + Tree_Iterator_Interfaces.Reversible_Iterator with null record + with Disable_Controlled => not T_Check; + + overriding function First (Object : Child_Iterator) return Cursor; + + overriding function Next + (Object : Child_Iterator; + Position : Cursor) return Cursor; + + overriding function Last (Object : Child_Iterator) return Cursor; + + overriding function Previous + (Object : Child_Iterator; + Position : Cursor) return Cursor; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Root_Node (Container : Tree) return Tree_Node_Access; + + procedure Deallocate_Node is + new Ada.Unchecked_Deallocation (Tree_Node_Type, Tree_Node_Access); + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type); + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type); + + function Equal_Children + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + function Equal_Subtree + (Left_Subtree, Right_Subtree : Tree_Node_Access) return Boolean; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)); + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type); + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type); + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access; + + function Child_Count (Children : Children_Type) return Count_Type; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type; + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean; + + procedure Remove_Subtree (Subtree : Tree_Node_Access); + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access); + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access); + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Tree) return Boolean is + begin + return Equal_Children (Root_Node (Left), Root_Node (Right)); + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Tree) is + Source : constant Children_Type := Container.Root.Children; + Source_Count : constant Count_Type := Container.Count; + Target_Count : Count_Type; + + begin + -- We first restore the target container to its default-initialized + -- state, before we attempt any allocation, to ensure that invariants + -- are preserved in the event that the allocation fails. + + Container.Root.Children := Children_Type'(others => null); + Zero_Counts (Container.TC); + Container.Count := 0; + + -- Copy_Children returns a count of the number of nodes that it + -- allocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Copy_Children. + + Target_Count := 0; + + -- Now we attempt the allocation of subtrees. The invariants are + -- satisfied even if the allocation fails. + + Copy_Children (Source, Root_Node (Container), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Container.Count := Source_Count; + end Adjust; + + ------------------- + -- Ancestor_Find -- + ------------------- + + function Ancestor_Find + (Position : Cursor; + Item : Element_Type) return Cursor + is + R, N : Tree_Node_Access; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Commented-out pending official ruling from ARG. ??? + + -- if Position.Container /= Container'Unrestricted_Access then + -- raise Program_Error with "Position cursor not in container"; + -- end if; + + -- AI-0136 says to raise PE if Position equals the root node. This does + -- not seem correct, as this value is just the limiting condition of the + -- search. For now we omit this check, pending a ruling from the ARG.??? + + -- if Checks and then Is_Root (Position) then + -- raise Program_Error with "Position cursor designates root"; + -- end if; + + R := Root_Node (Position.Container.all); + N := Position.Node; + while N /= R loop + if N.Element = Item then + return Cursor'(Position.Container, N); + end if; + + N := N.Parent; + end loop; + + return No_Element; + end Ancestor_Find; + + ------------------ + -- Append_Child -- + ------------------ + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First : Tree_Node_Access; + Last : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => New_Item, + others => <>); + + Last := First; + for J in Count_Type'(2) .. Count loop + + -- Reclaim other nodes if Storage_Error. ??? + + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => New_Item, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => null); -- null means "insert at end of list" + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Container.Count := Container.Count + Count; + end Append_Child; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Tree; Source : Tree) is + Source_Count : constant Count_Type := Source.Count; + Target_Count : Count_Type; + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; -- checks busy bit + + -- Copy_Children returns the number of nodes that it allocates, but it + -- does this by incrementing the count value passed in, so we must + -- initialize the count before calling Copy_Children. + + Target_Count := 0; + + -- Note that Copy_Children inserts the newly-allocated children into + -- their parent list only after the allocation of all the children has + -- succeeded. This preserves invariants even if the allocation fails. + + Copy_Children (Source.Root.Children, Root_Node (Target), Target_Count); + pragma Assert (Target_Count = Source_Count); + + Target.Count := Source_Count; + end Assign; + + ----------------- + -- Child_Count -- + ----------------- + + function Child_Count (Parent : Cursor) return Count_Type is + begin + return (if Parent = No_Element + then 0 else Child_Count (Parent.Node.Children)); + end Child_Count; + + function Child_Count (Children : Children_Type) return Count_Type is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 0; + Node := Children.First; + while Node /= null loop + Result := Result + 1; + Node := Node.Next; + end loop; + + return Result; + end Child_Count; + + ----------------- + -- Child_Depth -- + ----------------- + + function Child_Depth (Parent, Child : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Child = No_Element then + raise Constraint_Error with "Child cursor has no element"; + end if; + + if Checks and then Parent.Container /= Child.Container then + raise Program_Error with "Parent and Child in different containers"; + end if; + + Result := 0; + N := Child.Node; + while N /= Parent.Node loop + Result := Result + 1; + N := N.Parent; + + if Checks and then N = null then + raise Program_Error with "Parent is not ancestor of Child"; + end if; + end loop; + + return Result; + end Child_Depth; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Tree) is + Container_Count, Children_Count : Count_Type; + + begin + TC_Check (Container.TC); + + -- We first set the container count to 0, in order to preserve + -- invariants in case the deallocation fails. (This works because + -- Deallocate_Children immediately removes the children from their + -- parent, and then does the actual deallocation.) + + Container_Count := Container.Count; + Container.Count := 0; + + -- Deallocate_Children returns the number of nodes that it deallocates, + -- but it does this by incrementing the count value that is passed in, + -- so we must first initialize the count return value before calling it. + + Children_Count := 0; + + -- See comment above. Deallocate_Children immediately removes the + -- children list from their parent node (here, the root of the tree), + -- and only after that does it attempt the actual deallocation. So even + -- if the deallocation fails, the representation invariants for the tree + -- are preserved. + + Deallocate_Children (Root_Node (Container), Children_Count); + pragma Assert (Children_Count = Container_Count); + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + declare + C : Tree renames Position.Container.all; + TC : constant Tamper_Counts_Access := + C.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Tree; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Tree) return Tree is + begin + return Target : Tree do + Copy_Children + (Source => Source.Root.Children, + Parent => Root_Node (Target), + Count => Target.Count); + + pragma Assert (Target.Count = Source.Count); + end return; + end Copy; + + ------------------- + -- Copy_Children -- + ------------------- + + procedure Copy_Children + (Source : Children_Type; + Parent : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Parent /= null); + pragma Assert (Parent.Children.First = null); + pragma Assert (Parent.Children.Last = null); + + CC : Children_Type; + C : Tree_Node_Access; + + begin + -- We special-case the first allocation, in order to establish the + -- representation invariants for type Children_Type. + + C := Source.First; + + if C = null then + return; + end if; + + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.First, + Count => Count); + + CC.Last := CC.First; + + -- The representation invariants for the Children_Type list have been + -- established, so we can now copy the remaining children of Source. + + C := C.Next; + while C /= null loop + Copy_Subtree + (Source => C, + Parent => Parent, + Target => CC.Last.Next, + Count => Count); + + CC.Last.Next.Prev := CC.Last; + CC.Last := CC.Last.Next; + + C := C.Next; + end loop; + + -- Add the newly-allocated children to their parent list only after the + -- allocation has succeeded, so as to preserve invariants of the parent. + + Parent.Children := CC; + end Copy_Children; + + ------------------ + -- Copy_Subtree -- + ------------------ + + procedure Copy_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : Cursor) + is + Target_Subtree : Tree_Node_Access; + Target_Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Source = No_Element then + return; + end if; + + if Checks and then Is_Root (Source) then + raise Constraint_Error with "Source cursor designates root"; + end if; + + -- Copy_Subtree returns a count of the number of nodes that it + -- allocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Copy_Subtree. + + Target_Count := 0; + + Copy_Subtree + (Source => Source.Node, + Parent => Parent.Node, + Target => Target_Subtree, + Count => Target_Count); + + pragma Assert (Target_Subtree /= null); + pragma Assert (Target_Subtree.Parent = Parent.Node); + pragma Assert (Target_Count >= 1); + + Insert_Subtree_Node + (Subtree => Target_Subtree, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Target.Count := Target.Count + Target_Count; + end Copy_Subtree; + + procedure Copy_Subtree + (Source : Tree_Node_Access; + Parent : Tree_Node_Access; + Target : out Tree_Node_Access; + Count : in out Count_Type) + is + begin + Target := new Tree_Node_Type'(Element => Source.Element, + Parent => Parent, + others => <>); + + Count := Count + 1; + + Copy_Children + (Source => Source.Children, + Parent => Target, + Count => Count); + end Copy_Subtree; + + ------------------------- + -- Deallocate_Children -- + ------------------------- + + procedure Deallocate_Children + (Subtree : Tree_Node_Access; + Count : in out Count_Type) + is + pragma Assert (Subtree /= null); + + CC : Children_Type := Subtree.Children; + C : Tree_Node_Access; + + begin + -- We immediately remove the children from their parent, in order to + -- preserve invariants in case the deallocation fails. + + Subtree.Children := Children_Type'(others => null); + + while CC.First /= null loop + C := CC.First; + CC.First := C.Next; + + Deallocate_Subtree (C, Count); + end loop; + end Deallocate_Children; + + ------------------------ + -- Deallocate_Subtree -- + ------------------------ + + procedure Deallocate_Subtree + (Subtree : in out Tree_Node_Access; + Count : in out Count_Type) + is + begin + Deallocate_Children (Subtree, Count); + Deallocate_Node (Subtree); + Count := Count + 1; + end Deallocate_Subtree; + + --------------------- + -- Delete_Children -- + --------------------- + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor) + is + Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + TC_Check (Container.TC); + + -- Deallocate_Children returns a count of the number of nodes that it + -- deallocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Deallocate_Children. + + Count := 0; + + Deallocate_Children (Parent.Node, Count); + pragma Assert (Count <= Container.Count); + + Container.Count := Container.Count - Count; + end Delete_Children; + + ----------------- + -- Delete_Leaf -- + ----------------- + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Checks and then not Is_Leaf (Position) then + raise Constraint_Error with "Position cursor does not designate leaf"; + end if; + + TC_Check (Container.TC); + + X := Position.Node; + Position := No_Element; + + -- Restore represention invariants before attempting the actual + -- deallocation. + + Remove_Subtree (X); + Container.Count := Container.Count - 1; + + -- It is now safe to attempt the deallocation. This leaf node has been + -- disassociated from the tree, so even if the deallocation fails, + -- representation invariants will remain satisfied. + + Deallocate_Node (X); + end Delete_Leaf; + + -------------------- + -- Delete_Subtree -- + -------------------- + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor) + is + X : Tree_Node_Access; + Count : Count_Type; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + TC_Check (Container.TC); + + X := Position.Node; + Position := No_Element; + + -- Here is one case where a deallocation failure can result in the + -- violation of a representation invariant. We disassociate the subtree + -- from the tree now, but we only decrement the total node count after + -- we attempt the deallocation. However, if the deallocation fails, the + -- total node count will not get decremented. + + -- One way around this dilemma is to count the nodes in the subtree + -- before attempt to delete the subtree, but that is an O(n) operation, + -- so it does not seem worth it. + + -- Perhaps this is much ado about nothing, since the only way + -- deallocation can fail is if Controlled Finalization fails: this + -- propagates Program_Error so all bets are off anyway. ??? + + Remove_Subtree (X); + + -- Deallocate_Subtree returns a count of the number of nodes that it + -- deallocates, but it works by incrementing the value that is passed + -- in. We must therefore initialize the count value before calling + -- Deallocate_Subtree. + + Count := 0; + + Deallocate_Subtree (X, Count); + pragma Assert (Count <= Container.Count); + + -- See comments above. We would prefer to do this sooner, but there's no + -- way to satisfy that goal without a potentially severe execution + -- penalty. + + Container.Count := Container.Count - Count; + end Delete_Subtree; + + ----------- + -- Depth -- + ----------- + + function Depth (Position : Cursor) return Count_Type is + Result : Count_Type; + N : Tree_Node_Access; + + begin + Result := 0; + N := Position.Node; + while N /= null loop + N := N.Parent; + Result := Result + 1; + end loop; + + return Result; + end Depth; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Node = Root_Node (Position.Container.all) + then + raise Program_Error with "Position cursor designates root"; + end if; + + return Position.Node.Element; + end Element; + + -------------------- + -- Equal_Children -- + -------------------- + + function Equal_Children + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + Left_Children : Children_Type renames Left_Subtree.Children; + Right_Children : Children_Type renames Right_Subtree.Children; + + L, R : Tree_Node_Access; + + begin + if Child_Count (Left_Children) /= Child_Count (Right_Children) then + return False; + end if; + + L := Left_Children.First; + R := Right_Children.First; + while L /= null loop + if not Equal_Subtree (L, R) then + return False; + end if; + + L := L.Next; + R := R.Next; + end loop; + + return True; + end Equal_Children; + + ------------------- + -- Equal_Subtree -- + ------------------- + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean + is + begin + if Checks and then Left_Position = No_Element then + raise Constraint_Error with "Left cursor has no element"; + end if; + + if Checks and then Right_Position = No_Element then + raise Constraint_Error with "Right cursor has no element"; + end if; + + if Left_Position = Right_Position then + return True; + end if; + + if Is_Root (Left_Position) then + if not Is_Root (Right_Position) then + return False; + end if; + + return Equal_Children (Left_Position.Node, Right_Position.Node); + end if; + + if Is_Root (Right_Position) then + return False; + end if; + + return Equal_Subtree (Left_Position.Node, Right_Position.Node); + end Equal_Subtree; + + function Equal_Subtree + (Left_Subtree : Tree_Node_Access; + Right_Subtree : Tree_Node_Access) return Boolean + is + begin + if Left_Subtree.Element /= Right_Subtree.Element then + return False; + end if; + + return Equal_Children (Left_Subtree, Right_Subtree); + end Equal_Subtree; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Root_Iterator) is + begin + Unbusy (Object.Container.TC); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Tree; + Item : Element_Type) return Cursor + is + N : constant Tree_Node_Access := + Find_In_Children (Root_Node (Container), Item); + begin + if N = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, N); + end if; + end Find; + + ----------- + -- First -- + ----------- + + overriding function First (Object : Subtree_Iterator) return Cursor is + begin + if Object.Subtree = Root_Node (Object.Container.all) then + return First_Child (Root (Object.Container.all)); + else + return Cursor'(Object.Container, Object.Subtree); + end if; + end First; + + overriding function First (Object : Child_Iterator) return Cursor is + begin + return First_Child (Cursor'(Object.Container, Object.Subtree)); + end First; + + ----------------- + -- First_Child -- + ----------------- + + function First_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.First; + + if Node = null then + return No_Element; + end if; + + return Cursor'(Parent.Container, Node); + end First_Child; + + ------------------------- + -- First_Child_Element -- + ------------------------- + + function First_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (First_Child (Parent)); + end First_Child_Element; + + ---------------------- + -- Find_In_Children -- + ---------------------- + + function Find_In_Children + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + N, Result : Tree_Node_Access; + + begin + N := Subtree.Children.First; + while N /= null loop + Result := Find_In_Subtree (N, Item); + + if Result /= null then + return Result; + end if; + + N := N.Next; + end loop; + + return null; + end Find_In_Children; + + --------------------- + -- Find_In_Subtree -- + --------------------- + + function Find_In_Subtree + (Position : Cursor; + Item : Element_Type) return Cursor + is + Result : Tree_Node_Access; + + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Commented out pending official ruling by ARG. ??? + + -- if Checks and then + -- Position.Container /= Container'Unrestricted_Access + -- then + -- raise Program_Error with "Position cursor not in container"; + -- end if; + + Result := + (if Is_Root (Position) + then Find_In_Children (Position.Node, Item) + else Find_In_Subtree (Position.Node, Item)); + + if Result = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Result); + end Find_In_Subtree; + + function Find_In_Subtree + (Subtree : Tree_Node_Access; + Item : Element_Type) return Tree_Node_Access + is + begin + if Subtree.Element = Item then + return Subtree; + end if; + + return Find_In_Children (Subtree, Item); + end Find_In_Subtree; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return (if Position = No_Element then False + else Position.Node.Parent /= null); + end Has_Element; + + ------------------ + -- Insert_Child -- + ------------------ + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + + begin + Insert_Child (Container, Parent, Before, New_Item, Position, Count); + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + First : Tree_Node_Access; + Last : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Parent cursor not parent of Before"; + end if; + end if; + + if Count = 0 then + Position := No_Element; -- Need ruling from ARG ??? + return; + end if; + + TC_Check (Container.TC); + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => New_Item, + others => <>); + + Last := First; + for J in Count_Type'(2) .. Count loop + + -- Reclaim other nodes if Storage_Error. ??? + + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => New_Item, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Container.Count := Container.Count + Count; + + Position := Cursor'(Parent.Container, First); + end Insert_Child; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + First : Tree_Node_Access; + Last : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Parent cursor not parent of Before"; + end if; + end if; + + if Count = 0 then + Position := No_Element; -- Need ruling from ARG ??? + return; + end if; + + TC_Check (Container.TC); + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => <>, + others => <>); + + Last := First; + for J in Count_Type'(2) .. Count loop + + -- Reclaim other nodes if Storage_Error. ??? + + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => <>, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => Before.Node); + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Container.Count := Container.Count + Count; + + Position := Cursor'(Parent.Container, First); + end Insert_Child; + + ------------------------- + -- Insert_Subtree_List -- + ------------------------- + + procedure Insert_Subtree_List + (First : Tree_Node_Access; + Last : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + pragma Assert (Parent /= null); + C : Children_Type renames Parent.Children; + + begin + -- This is a simple utility operation to insert a list of nodes (from + -- First..Last) as children of Parent. The Before node specifies where + -- the new children should be inserted relative to the existing + -- children. + + if First = null then + pragma Assert (Last = null); + return; + end if; + + pragma Assert (Last /= null); + pragma Assert (Before = null or else Before.Parent = Parent); + + if C.First = null then + C.First := First; + C.First.Prev := null; + C.Last := Last; + C.Last.Next := null; + + elsif Before = null then -- means "insert after existing nodes" + C.Last.Next := First; + First.Prev := C.Last; + C.Last := Last; + C.Last.Next := null; + + elsif Before = C.First then + Last.Next := C.First; + C.First.Prev := Last; + C.First := First; + C.First.Prev := null; + + else + Before.Prev.Next := First; + First.Prev := Before.Prev; + Last.Next := Before; + Before.Prev := Last; + end if; + end Insert_Subtree_List; + + ------------------------- + -- Insert_Subtree_Node -- + ------------------------- + + procedure Insert_Subtree_Node + (Subtree : Tree_Node_Access; + Parent : Tree_Node_Access; + Before : Tree_Node_Access) + is + begin + -- This is a simple wrapper operation to insert a single child into the + -- Parent's children list. + + Insert_Subtree_List + (First => Subtree, + Last => Subtree, + Parent => Parent, + Before => Before); + end Insert_Subtree_Node; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Tree) return Boolean is + begin + return Container.Root.Children.First = null; + end Is_Empty; + + ------------- + -- Is_Leaf -- + ------------- + + function Is_Leaf (Position : Cursor) return Boolean is + begin + return (if Position = No_Element then False + else Position.Node.Children.First = null); + end Is_Leaf; + + ------------------ + -- Is_Reachable -- + ------------------ + + function Is_Reachable (From, To : Tree_Node_Access) return Boolean is + pragma Assert (From /= null); + pragma Assert (To /= null); + + N : Tree_Node_Access; + + begin + N := From; + while N /= null loop + if N = To then + return True; + end if; + + N := N.Parent; + end loop; + + return False; + end Is_Reachable; + + ------------- + -- Is_Root -- + ------------- + + function Is_Root (Position : Cursor) return Boolean is + begin + return (if Position.Container = null then False + else Position = Root (Position.Container.all)); + end Is_Root; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + Iterate_Children + (Container => Container'Unrestricted_Access, + Subtree => Root_Node (Container), + Process => Process); + end Iterate; + + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + begin + return Iterate_Subtree (Root (Container)); + end Iterate; + + ---------------------- + -- Iterate_Children -- + ---------------------- + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + C := Parent.Node.Children.First; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Next; + end loop; + end Iterate_Children; + + procedure Iterate_Children + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + Node : Tree_Node_Access; + + begin + -- This is a helper function to recursively iterate over all the nodes + -- in a subtree, in depth-first fashion. This particular helper just + -- visits the children of this subtree, not the root of the subtree node + -- itself. This is useful when starting from the ultimate root of the + -- entire tree (see Iterate), as that root does not have an element. + + Node := Subtree.Children.First; + while Node /= null loop + Iterate_Subtree (Container, Node, Process); + Node := Node.Next; + end loop; + end Iterate_Children; + + function Iterate_Children + (Container : Tree; + Parent : Cursor) + return Tree_Iterator_Interfaces.Reversible_Iterator'Class + is + C : constant Tree_Access := Container'Unrestricted_Access; + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= C then + raise Program_Error with "Parent cursor not in container"; + end if; + + return It : constant Child_Iterator := + (Limited_Controlled with + Container => C, + Subtree => Parent.Node) + do + Busy (C.TC); + end return; + end Iterate_Children; + + --------------------- + -- Iterate_Subtree -- + --------------------- + + function Iterate_Subtree + (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class + is + C : constant Tree_Access := Position.Container; + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + -- Implement Vet for multiway trees??? + -- pragma Assert (Vet (Position), "bad subtree cursor"); + + return It : constant Subtree_Iterator := + (Limited_Controlled with + Container => C, + Subtree => Position.Node) + do + Busy (C.TC); + end return; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Position.Container.TC'Unrestricted_Access); + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Is_Root (Position) then + Iterate_Children (Position.Container, Position.Node, Process); + else + Iterate_Subtree (Position.Container, Position.Node, Process); + end if; + end Iterate_Subtree; + + procedure Iterate_Subtree + (Container : Tree_Access; + Subtree : Tree_Node_Access; + Process : not null access procedure (Position : Cursor)) + is + begin + -- This is a helper function to recursively iterate over all the nodes + -- in a subtree, in depth-first fashion. It first visits the root of the + -- subtree, then visits its children. + + Process (Cursor'(Container, Subtree)); + Iterate_Children (Container, Subtree, Process); + end Iterate_Subtree; + + ---------- + -- Last -- + ---------- + + overriding function Last (Object : Child_Iterator) return Cursor is + begin + return Last_Child (Cursor'(Object.Container, Object.Subtree)); + end Last; + + ---------------- + -- Last_Child -- + ---------------- + + function Last_Child (Parent : Cursor) return Cursor is + Node : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + Node := Parent.Node.Children.Last; + + if Node = null then + return No_Element; + end if; + + return (Parent.Container, Node); + end Last_Child; + + ------------------------ + -- Last_Child_Element -- + ------------------------ + + function Last_Child_Element (Parent : Cursor) return Element_Type is + begin + return Element (Last_Child (Parent)); + end Last_Child_Element; + + ---------- + -- Move -- + ---------- + + procedure Move (Target : in out Tree; Source : in out Tree) is + Node : Tree_Node_Access; + + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Target.Clear; -- checks busy bit + + Target.Root.Children := Source.Root.Children; + Source.Root.Children := Children_Type'(others => null); + + Node := Target.Root.Children.First; + while Node /= null loop + Node.Parent := Root_Node (Target); + Node := Node.Next; + end loop; + + Target.Count := Source.Count; + Source.Count := 0; + end Move; + + ---------- + -- Next -- + ---------- + + function Next + (Object : Subtree_Iterator; + Position : Cursor) return Cursor + is + Node : Tree_Node_Access; + + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; + + Node := Position.Node; + + if Node.Children.First /= null then + return Cursor'(Object.Container, Node.Children.First); + end if; + + while Node /= Object.Subtree loop + if Node.Next /= null then + return Cursor'(Object.Container, Node.Next); + end if; + + Node := Node.Parent; + end loop; + + return No_Element; + end Next; + + function Next + (Object : Child_Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong tree"; + end if; + + return Next_Sibling (Position); + end Next; + + ------------------ + -- Next_Sibling -- + ------------------ + + function Next_Sibling (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Next = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Next); + end Next_Sibling; + + procedure Next_Sibling (Position : in out Cursor) is + begin + Position := Next_Sibling (Position); + end Next_Sibling; + + ---------------- + -- Node_Count -- + ---------------- + + function Node_Count (Container : Tree) return Count_Type is + begin + -- Container.Count is the number of nodes we have actually allocated. We + -- cache the value specifically so this Node_Count operation can execute + -- in O(1) time, which makes it behave similarly to how the Length + -- selector function behaves for other containers. + + -- The cached node count value only describes the nodes we have + -- allocated; the root node itself is not included in that count. The + -- Node_Count operation returns a value that includes the root node + -- (because the RM says so), so we must add 1 to our cached value. + + return 1 + Container.Count; + end Node_Count; + + ------------ + -- Parent -- + ------------ + + function Parent (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + if Position.Node.Parent = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Position.Node.Parent); + end Parent; + + ------------------- + -- Prepent_Child -- + ------------------- + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + First, Last : Tree_Node_Access; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Count = 0 then + return; + end if; + + TC_Check (Container.TC); + + First := new Tree_Node_Type'(Parent => Parent.Node, + Element => New_Item, + others => <>); + + Last := First; + + for J in Count_Type'(2) .. Count loop + + -- Reclaim other nodes if Storage_Error??? + + Last.Next := new Tree_Node_Type'(Parent => Parent.Node, + Prev => Last, + Element => New_Item, + others => <>); + + Last := Last.Next; + end loop; + + Insert_Subtree_List + (First => First, + Last => Last, + Parent => Parent.Node, + Before => Parent.Node.Children.First); + + -- In order for operation Node_Count to complete in O(1) time, we cache + -- the count value. Here we increment the total count by the number of + -- nodes we just inserted. + + Container.Count := Container.Count + Count; + end Prepend_Child; + + -------------- + -- Previous -- + -------------- + + overriding function Previous + (Object : Child_Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong tree"; + end if; + + return Previous_Sibling (Position); + end Previous; + + ---------------------- + -- Previous_Sibling -- + ---------------------- + + function Previous_Sibling (Position : Cursor) return Cursor is + begin + return + (if Position = No_Element then No_Element + elsif Position.Node.Prev = null then No_Element + else Cursor'(Position.Container, Position.Node.Prev)); + end Previous_Sibling; + + procedure Previous_Sibling (Position : in out Cursor) is + begin + Position := Previous_Sibling (Position); + end Previous_Sibling; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + Process (Position.Node.Element); + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Tree) + is + procedure Read_Children (Subtree : Tree_Node_Access); + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access; + + Total_Count : Count_Type'Base; + -- Value read from the stream that says how many elements follow + + Read_Count : Count_Type'Base; + -- Actual number of elements read from the stream + + ------------------- + -- Read_Children -- + ------------------- + + procedure Read_Children (Subtree : Tree_Node_Access) is + pragma Assert (Subtree /= null); + pragma Assert (Subtree.Children.First = null); + pragma Assert (Subtree.Children.Last = null); + + Count : Count_Type'Base; + -- Number of child subtrees + + C : Children_Type; + + begin + Count_Type'Read (Stream, Count); + + if Checks and then Count < 0 then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + if Count = 0 then + return; + end if; + + C.First := Read_Subtree (Parent => Subtree); + C.Last := C.First; + + for J in Count_Type'(2) .. Count loop + C.Last.Next := Read_Subtree (Parent => Subtree); + C.Last.Next.Prev := C.Last; + C.Last := C.Last.Next; + end loop; + + -- Now that the allocation and reads have completed successfully, it + -- is safe to link the children to their parent. + + Subtree.Children := C; + end Read_Children; + + ------------------ + -- Read_Subtree -- + ------------------ + + function Read_Subtree + (Parent : Tree_Node_Access) return Tree_Node_Access + is + Subtree : constant Tree_Node_Access := + new Tree_Node_Type' + (Parent => Parent, + Element => Element_Type'Input (Stream), + others => <>); + + begin + Read_Count := Read_Count + 1; + + Read_Children (Subtree); + + return Subtree; + end Read_Subtree; + + -- Start of processing for Read + + begin + Container.Clear; -- checks busy bit + + Count_Type'Read (Stream, Total_Count); + + if Checks and then Total_Count < 0 then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + if Total_Count = 0 then + return; + end if; + + Read_Count := 0; + + Read_Children (Root_Node (Container)); + + if Checks and then Read_Count /= Total_Count then + raise Program_Error with "attempt to read from corrupt stream"; + end if; + + Container.Count := Total_Count; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to read tree cursor from stream"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + if Checks and then Position.Node = Root_Node (Container) then + raise Program_Error with "Position cursor designates root"; + end if; + + -- Implement Vet for multiway tree??? + -- pragma Assert (Vet (Position), + -- "Position cursor in Constant_Reference is bad"); + + declare + C : Tree renames Position.Container.all; + TC : constant Tamper_Counts_Access := + C.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + -------------------- + -- Remove_Subtree -- + -------------------- + + procedure Remove_Subtree (Subtree : Tree_Node_Access) is + C : Children_Type renames Subtree.Parent.Children; + + begin + -- This is a utility operation to remove a subtree node from its + -- parent's list of children. + + if C.First = Subtree then + pragma Assert (Subtree.Prev = null); + + if C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.First := null; + C.Last := null; + + else + C.First := Subtree.Next; + C.First.Prev := null; + end if; + + elsif C.Last = Subtree then + pragma Assert (Subtree.Next = null); + C.Last := Subtree.Prev; + C.Last.Next := null; + + else + Subtree.Prev.Next := Subtree.Next; + Subtree.Next.Prev := Subtree.Prev; + end if; + end Remove_Subtree; + + ---------------------- + -- Replace_Element -- + ---------------------- + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + TE_Check (Container.TC); + + Position.Node.Element := New_Item; + end Replace_Element; + + ------------------------------ + -- Reverse_Iterate_Children -- + ------------------------------ + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)) + is + C : Tree_Node_Access; + Busy : With_Busy (Parent.Container.TC'Unrestricted_Access); + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + C := Parent.Node.Children.Last; + while C /= null loop + Process (Position => Cursor'(Parent.Container, Node => C)); + C := C.Prev; + end loop; + end Reverse_Iterate_Children; + + ---------- + -- Root -- + ---------- + + function Root (Container : Tree) return Cursor is + begin + return (Container'Unrestricted_Access, Root_Node (Container)); + end Root; + + --------------- + -- Root_Node -- + --------------- + + function Root_Node (Container : Tree) return Tree_Node_Access is + type Root_Node_Access is access all Root_Node_Type; + for Root_Node_Access'Storage_Size use 0; + pragma Convention (C, Root_Node_Access); + + function To_Tree_Node_Access is + new Ada.Unchecked_Conversion (Root_Node_Access, Tree_Node_Access); + + -- Start of processing for Root_Node + + begin + -- This is a utility function for converting from an access type that + -- designates the distinguished root node to an access type designating + -- a non-root node. The representation of a root node does not have an + -- element, but is otherwise identical to a non-root node, so the + -- conversion itself is safe. + + return To_Tree_Node_Access (Container.Root'Unrestricted_Access); + end Root_Node; + + --------------------- + -- Splice_Children -- + --------------------- + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor) + is + Count : Count_Type; + + begin + if Checks and then Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if Checks and then Target_Parent.Container /= Target'Unrestricted_Access + then + raise Program_Error + with "Target_Parent cursor not in Target container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error + with "Before cursor not in Target container"; + end if; + + if Checks and then Before.Node.Parent /= Target_Parent.Node then + raise Constraint_Error + with "Before cursor not child of Target_Parent"; + end if; + end if; + + if Checks and then Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if Checks and then Source_Parent.Container /= Source'Unrestricted_Access + then + raise Program_Error + with "Source_Parent cursor not in Source container"; + end if; + + if Target'Address = Source'Address then + if Target_Parent = Source_Parent then + return; + end if; + + TC_Check (Target.TC); + + if Checks and then Is_Reachable (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + return; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + -- We cache the count of the nodes we have allocated, so that operation + -- Node_Count can execute in O(1) time. But that means we must count the + -- nodes in the subtree we remove from Source and insert into Target, in + -- order to keep the count accurate. + + Count := Subtree_Node_Count (Source_Parent.Node); + pragma Assert (Count >= 1); + + Count := Count - 1; -- because Source_Parent node does not move + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + + Source.Count := Source.Count - Count; + Target.Count := Target.Count + Count; + end Splice_Children; + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor) + is + begin + if Checks and then Target_Parent = No_Element then + raise Constraint_Error with "Target_Parent cursor has no element"; + end if; + + if Checks and then + Target_Parent.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Target_Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Target_Parent.Node then + raise Constraint_Error + with "Before cursor not child of Target_Parent"; + end if; + end if; + + if Checks and then Source_Parent = No_Element then + raise Constraint_Error with "Source_Parent cursor has no element"; + end if; + + if Checks and then + Source_Parent.Container /= Container'Unrestricted_Access + then + raise Program_Error + with "Source_Parent cursor not in container"; + end if; + + if Target_Parent = Source_Parent then + return; + end if; + + TC_Check (Container.TC); + + if Checks and then Is_Reachable (From => Target_Parent.Node, + To => Source_Parent.Node) + then + raise Constraint_Error + with "Source_Parent is ancestor of Target_Parent"; + end if; + + Splice_Children + (Target_Parent => Target_Parent.Node, + Before => Before.Node, + Source_Parent => Source_Parent.Node); + end Splice_Children; + + procedure Splice_Children + (Target_Parent : Tree_Node_Access; + Before : Tree_Node_Access; + Source_Parent : Tree_Node_Access) + is + CC : constant Children_Type := Source_Parent.Children; + C : Tree_Node_Access; + + begin + -- This is a utility operation to remove the children from + -- Source parent and insert them into Target parent. + + Source_Parent.Children := Children_Type'(others => null); + + -- Fix up the Parent pointers of each child to designate + -- its new Target parent. + + C := CC.First; + while C /= null loop + C.Parent := Target_Parent; + C := C.Next; + end loop; + + Insert_Subtree_List + (First => CC.First, + Last => CC.Last, + Parent => Target_Parent, + Before => Before); + end Splice_Children; + + -------------------- + -- Splice_Subtree -- + -------------------- + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor) + is + Subtree_Count : Count_Type; + + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Target'Unrestricted_Access then + raise Program_Error with "Parent cursor not in Target container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Target'Unrestricted_Access then + raise Program_Error with "Before cursor not in Target container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Source'Unrestricted_Access then + raise Program_Error with "Position cursor not in Source container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + if Target'Address = Source'Address then + if Position.Node.Parent = Parent.Node then + if Position.Node = Before.Node then + return; + end if; + + if Position.Node.Next = Before.Node then + return; + end if; + end if; + + TC_Check (Target.TC); + + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + return; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + -- This is an unfortunate feature of this API: we must count the nodes + -- in the subtree that we remove from the source tree, which is an O(n) + -- operation. It would have been better if the Tree container did not + -- have a Node_Count selector; a user that wants the number of nodes in + -- the tree could simply call Subtree_Node_Count, with the understanding + -- that such an operation is O(n). + + -- Of course, we could choose to implement the Node_Count selector as an + -- O(n) operation, which would turn this splice operation into an O(1) + -- operation. ??? + + Subtree_Count := Subtree_Node_Count (Position.Node); + pragma Assert (Subtree_Count <= Source.Count); + + Remove_Subtree (Position.Node); + Source.Count := Source.Count - Subtree_Count; + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + + Target.Count := Target.Count + Subtree_Count; + + Position.Container := Target'Unrestricted_Access; + end Splice_Subtree; + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor) + is + begin + if Checks and then Parent = No_Element then + raise Constraint_Error with "Parent cursor has no element"; + end if; + + if Checks and then Parent.Container /= Container'Unrestricted_Access then + raise Program_Error with "Parent cursor not in container"; + end if; + + if Before /= No_Element then + if Checks and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor not in container"; + end if; + + if Checks and then Before.Node.Parent /= Parent.Node then + raise Constraint_Error with "Before cursor not child of Parent"; + end if; + end if; + + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + + -- Should this be PE instead? Need ARG confirmation. ??? + + raise Constraint_Error with "Position cursor designates root"; + end if; + + if Position.Node.Parent = Parent.Node then + if Position.Node = Before.Node then + return; + end if; + + if Position.Node.Next = Before.Node then + return; + end if; + end if; + + TC_Check (Container.TC); + + if Checks and then + Is_Reachable (From => Parent.Node, To => Position.Node) + then + raise Constraint_Error with "Position is ancestor of Parent"; + end if; + + Remove_Subtree (Position.Node); + + Position.Node.Parent := Parent.Node; + Insert_Subtree_Node (Position.Node, Parent.Node, Before.Node); + end Splice_Subtree; + + ------------------------ + -- Subtree_Node_Count -- + ------------------------ + + function Subtree_Node_Count (Position : Cursor) return Count_Type is + begin + if Position = No_Element then + return 0; + end if; + + return Subtree_Node_Count (Position.Node); + end Subtree_Node_Count; + + function Subtree_Node_Count + (Subtree : Tree_Node_Access) return Count_Type + is + Result : Count_Type; + Node : Tree_Node_Access; + + begin + Result := 1; + Node := Subtree.Children.First; + while Node /= null loop + Result := Result + Subtree_Node_Count (Node); + Node := Node.Next; + end loop; + + return Result; + end Subtree_Node_Count; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out Tree; + I, J : Cursor) + is + begin + if Checks and then I = No_Element then + raise Constraint_Error with "I cursor has no element"; + end if; + + if Checks and then I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor not in container"; + end if; + + if Checks and then Is_Root (I) then + raise Program_Error with "I cursor designates root"; + end if; + + if I = J then -- make this test sooner??? + return; + end if; + + if Checks and then J = No_Element then + raise Constraint_Error with "J cursor has no element"; + end if; + + if Checks and then J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor not in container"; + end if; + + if Checks and then Is_Root (J) then + raise Program_Error with "J cursor designates root"; + end if; + + TE_Check (Container.TC); + + declare + EI : constant Element_Type := I.Node.Element; + + begin + I.Node.Element := J.Node.Element; + J.Node.Element := EI; + end; + end Swap; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + T : Tree renames Position.Container.all'Unrestricted_Access.all; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + if Checks and then Position = No_Element then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor not in container"; + end if; + + if Checks and then Is_Root (Position) then + raise Program_Error with "Position cursor designates root"; + end if; + + Process (Position.Node.Element); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Tree) + is + procedure Write_Children (Subtree : Tree_Node_Access); + procedure Write_Subtree (Subtree : Tree_Node_Access); + + -------------------- + -- Write_Children -- + -------------------- + + procedure Write_Children (Subtree : Tree_Node_Access) is + CC : Children_Type renames Subtree.Children; + C : Tree_Node_Access; + + begin + Count_Type'Write (Stream, Child_Count (CC)); + + C := CC.First; + while C /= null loop + Write_Subtree (C); + C := C.Next; + end loop; + end Write_Children; + + ------------------- + -- Write_Subtree -- + ------------------- + + procedure Write_Subtree (Subtree : Tree_Node_Access) is + begin + Element_Type'Output (Stream, Subtree.Element); + Write_Children (Subtree); + end Write_Subtree; + + -- Start of processing for Write + + begin + Count_Type'Write (Stream, Container.Count); + + if Container.Count = 0 then + return; + end if; + + Write_Children (Root_Node (Container)); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to write tree cursor to stream"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Multiway_Trees; diff --git a/gcc/ada/libgnat/a-comutr.ads b/gcc/ada/libgnat/a-comutr.ads new file mode 100644 index 0000000..a6a6db8 --- /dev/null +++ b/gcc/ada/libgnat/a-comutr.ads @@ -0,0 +1,511 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . M U L T I W A Y _ T R E E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Multiway_Trees is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + type Tree is tagged private + with Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Tree); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Tree : constant Tree; + + No_Element : constant Cursor; + function Has_Element (Position : Cursor) return Boolean; + + package Tree_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function Equal_Subtree + (Left_Position : Cursor; + Right_Position : Cursor) return Boolean; + + function "=" (Left, Right : Tree) return Boolean; + + function Is_Empty (Container : Tree) return Boolean; + + function Node_Count (Container : Tree) return Count_Type; + + function Subtree_Node_Count (Position : Cursor) return Count_Type; + + function Depth (Position : Cursor) return Count_Type; + + function Is_Root (Position : Cursor) return Boolean; + + function Is_Leaf (Position : Cursor) return Boolean; + + function Root (Container : Tree) return Cursor; + + procedure Clear (Container : in out Tree); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Tree; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Tree; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + type Reference_Type + (Element : not null access Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Tree; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Tree; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Tree; Source : Tree); + + function Copy (Source : Tree) return Tree; + + procedure Move (Target : in out Tree; Source : in out Tree); + + procedure Delete_Leaf + (Container : in out Tree; + Position : in out Cursor); + + procedure Delete_Subtree + (Container : in out Tree; + Position : in out Cursor); + + procedure Swap + (Container : in out Tree; + I, J : Cursor); + + function Find + (Container : Tree; + Item : Element_Type) return Cursor; + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Find_In_Subtree this way: + -- + -- function Find_In_Subtree + -- (Container : Tree; + -- Item : Element_Type; + -- Position : Cursor) return Cursor; + -- + -- It seems that the Container parameter is there by mistake, but we need + -- an official ruling from the ARG. ??? + + function Find_In_Subtree + (Position : Cursor; + Item : Element_Type) return Cursor; + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Ancestor_Find this way: + -- + -- function Ancestor_Find + -- (Container : Tree; + -- Item : Element_Type; + -- Position : Cursor) return Cursor; + -- + -- It seems that the Container parameter is there by mistake, but we need + -- an official ruling from the ARG. ??? + + function Ancestor_Find + (Position : Cursor; + Item : Element_Type) return Cursor; + + function Contains + (Container : Tree; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : Tree; + Process : not null access procedure (Position : Cursor)); + + procedure Iterate_Subtree + (Position : Cursor; + Process : not null access procedure (Position : Cursor)); + + function Iterate (Container : Tree) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Subtree (Position : Cursor) + return Tree_Iterator_Interfaces.Forward_Iterator'Class; + + function Iterate_Children + (Container : Tree; + Parent : Cursor) + return Tree_Iterator_Interfaces.Reversible_Iterator'Class; + + function Child_Count (Parent : Cursor) return Count_Type; + + function Child_Depth (Parent, Child : Cursor) return Count_Type; + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert_Child + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append_Child + (Container : in out Tree; + Parent : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Delete_Children + (Container : in out Tree; + Parent : Cursor); + + procedure Copy_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : Cursor); + + procedure Splice_Subtree + (Target : in out Tree; + Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Position : in out Cursor); + + procedure Splice_Subtree + (Container : in out Tree; + Parent : Cursor; + Before : Cursor; + Position : Cursor); + + procedure Splice_Children + (Target : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source : in out Tree; + Source_Parent : Cursor); + + procedure Splice_Children + (Container : in out Tree; + Target_Parent : Cursor; + Before : Cursor; + Source_Parent : Cursor); + + function Parent (Position : Cursor) return Cursor; + + function First_Child (Parent : Cursor) return Cursor; + + function First_Child_Element (Parent : Cursor) return Element_Type; + + function Last_Child (Parent : Cursor) return Cursor; + + function Last_Child_Element (Parent : Cursor) return Element_Type; + + function Next_Sibling (Position : Cursor) return Cursor; + + function Previous_Sibling (Position : Cursor) return Cursor; + + procedure Next_Sibling (Position : in out Cursor); + + procedure Previous_Sibling (Position : in out Cursor); + + -- This version of the AI: + -- 10-06-02 AI05-0136-1/07 + -- declares Iterate_Children this way: + -- + -- procedure Iterate_Children + -- (Container : Tree; + -- Parent : Cursor; + -- Process : not null access procedure (Position : Cursor)); + -- + -- It seems that the Container parameter is there by mistake, but we need + -- an official ruling from the ARG. ??? + + procedure Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate_Children + (Parent : Cursor; + Process : not null access procedure (Position : Cursor)); + +private + -- A node of this multiway tree comprises an element and a list of children + -- (that are themselves trees). The root node is distinguished because it + -- contains only children: it does not have an element itself. + + -- This design feature puts two design goals in tension with one another: + -- (1) treat the root node the same as any other node + -- (2) not declare any objects of type Element_Type unnecessarily + + -- To satisfy (1), we could simply declare the Root node of the tree + -- using the normal Tree_Node_Type, but that would mean that (2) is not + -- satisfied. To resolve the tension (in favor of (2)), we declare the + -- component Root as having a different node type, without an Element + -- component (thus satisfying goal (2)) but otherwise identical to a normal + -- node, and then use Unchecked_Conversion to convert an access object + -- designating the Root node component to the access type designating a + -- normal, non-root node (thus satisfying goal (1)). We make an explicit + -- check for Root when there is any attempt to manipulate the Element + -- component of the node (a check required by the RM anyway). + + -- In order to be explicit about node (and pointer) representation, we + -- specify that the respective node types have convention C, to ensure + -- that the layout of the components of the node records is the same, + -- thus guaranteeing that (unchecked) conversions between access types + -- designating each kind of node type is a meaningful conversion. + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + type Tree_Node_Type; + type Tree_Node_Access is access all Tree_Node_Type; + pragma Convention (C, Tree_Node_Access); + pragma No_Strict_Aliasing (Tree_Node_Access); + -- The above-mentioned Unchecked_Conversion is a violation of the normal + -- aliasing rules. + + type Children_Type is record + First : Tree_Node_Access; + Last : Tree_Node_Access; + end record; + + -- See the comment above. This declaration must exactly match the + -- declaration of Root_Node_Type (except for the Element component). + + type Tree_Node_Type is record + Parent : Tree_Node_Access; + Prev : Tree_Node_Access; + Next : Tree_Node_Access; + Children : Children_Type; + Element : aliased Element_Type; + end record; + pragma Convention (C, Tree_Node_Type); + + -- See the comment above. This declaration must match the declaration of + -- Tree_Node_Type (except for the Element component). + + type Root_Node_Type is record + Parent : Tree_Node_Access; + Prev : Tree_Node_Access; + Next : Tree_Node_Access; + Children : Children_Type; + end record; + pragma Convention (C, Root_Node_Type); + + for Root_Node_Type'Alignment use Standard'Maximum_Alignment; + -- The alignment has to be large enough to allow Root_Node to Tree_Node + -- access value conversions, and Tree_Node_Type's alignment may be bumped + -- up by the Element component. + + use Ada.Finalization; + + -- The Count component of type Tree represents the number of nodes that + -- have been (dynamically) allocated. It does not include the root node + -- itself. As implementors, we decide to cache this value, so that the + -- selector function Node_Count can execute in O(1) time, in order to be + -- consistent with the behavior of the Length selector function for other + -- standard container library units. This does mean, however, that the + -- two-container forms for Splice_XXX (that move subtrees across tree + -- containers) will execute in O(n) time, because we must count the number + -- of nodes in the subtree(s) that get moved. (We resolve the tension + -- between Node_Count and Splice_XXX in favor of Node_Count, under the + -- assumption that Node_Count is the more common operation). + + type Tree is new Controlled with record + Root : aliased Root_Node_Type; + TC : aliased Tamper_Counts; + Count : Count_Type := 0; + end record; + + overriding procedure Adjust (Container : in out Tree); + + overriding procedure Finalize (Container : in out Tree) renames Clear; + + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Tree); + + for Tree'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Tree); + + for Tree'Read use Read; + + type Tree_Access is access all Tree; + for Tree_Access'Storage_Size use 0; + + type Cursor is record + Container : Tree_Access; + Node : Tree_Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Tree'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Tree : constant Tree := (Controlled with others => <>); + + No_Element : constant Cursor := (others => <>); + +end Ada.Containers.Multiway_Trees; diff --git a/gcc/ada/libgnat/a-conhel.adb b/gcc/ada/libgnat/a-conhel.adb new file mode 100644 index 0000000..2e4d32b --- /dev/null +++ b/gcc/ada/libgnat/a-conhel.adb @@ -0,0 +1,186 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H E L P E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Helpers is + + package body Generic_Implementation is + + use type SAC.Atomic_Unsigned; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Control : in out Reference_Control_Type) is + begin + if Control.T_Counts /= null then + Lock (Control.T_Counts.all); + end if; + end Adjust; + + ---------- + -- Busy -- + ---------- + + procedure Busy (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Increment (T_Counts.Busy); + end if; + end Busy; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.T_Counts /= null then + Unlock (Control.T_Counts.all); + Control.T_Counts := null; + end if; + end Finalize; + + -- No need to protect against double Finalize here, because these types + -- are limited. + + procedure Finalize (Busy : in out With_Busy) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Unbusy (Busy.T_Counts.all); + end Finalize; + + procedure Finalize (Lock : in out With_Lock) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Unlock (Lock.T_Counts.all); + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Busy : in out With_Busy) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Generic_Implementation.Busy (Busy.T_Counts.all); + end Initialize; + + procedure Initialize (Lock : in out With_Lock) is + pragma Warnings (Off); + pragma Assert (T_Check); -- not called if check suppressed + pragma Warnings (On); + begin + Generic_Implementation.Lock (Lock.T_Counts.all); + end Initialize; + + ---------- + -- Lock -- + ---------- + + procedure Lock (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Increment (T_Counts.Lock); + SAC.Increment (T_Counts.Busy); + end if; + end Lock; + + -------------- + -- TC_Check -- + -------------- + + procedure TC_Check (T_Counts : Tamper_Counts) is + begin + if T_Check and then T_Counts.Busy > 0 then + raise Program_Error with + "attempt to tamper with cursors"; + end if; + + -- The lock status (which monitors "element tampering") always + -- implies that the busy status (which monitors "cursor tampering") + -- is set too; this is a representation invariant. Thus if the busy + -- bit is not set, then the lock bit must not be set either. + + pragma Assert (T_Counts.Lock = 0); + end TC_Check; + + -------------- + -- TE_Check -- + -------------- + + procedure TE_Check (T_Counts : Tamper_Counts) is + begin + if T_Check and then T_Counts.Lock > 0 then + raise Program_Error with + "attempt to tamper with elements"; + end if; + end TE_Check; + + ------------ + -- Unbusy -- + ------------ + + procedure Unbusy (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Decrement (T_Counts.Busy); + end if; + end Unbusy; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock (T_Counts : in out Tamper_Counts) is + begin + if T_Check then + SAC.Decrement (T_Counts.Lock); + SAC.Decrement (T_Counts.Busy); + end if; + end Unlock; + + ----------------- + -- Zero_Counts -- + ----------------- + + procedure Zero_Counts (T_Counts : out Tamper_Counts) is + begin + if T_Check then + T_Counts := (others => <>); + end if; + end Zero_Counts; + + end Generic_Implementation; + +end Ada.Containers.Helpers; diff --git a/gcc/ada/libgnat/a-conhel.ads b/gcc/ada/libgnat/a-conhel.ads new file mode 100644 index 0000000..77a4ead --- /dev/null +++ b/gcc/ada/libgnat/a-conhel.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . H E L P E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System.Atomic_Counters; + +package Ada.Containers.Helpers is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + + -- Miscellaneous helpers shared among various containers + + package SAC renames System.Atomic_Counters; + + Count_Type_Last : constant := Count_Type'Last; + -- Count_Type'Last as a universal_integer, so we can compare Index_Type + -- values against this without type conversions that might overflow. + + type Tamper_Counts is record + Busy : aliased SAC.Atomic_Unsigned := 0; + Lock : aliased SAC.Atomic_Unsigned := 0; + end record; + + -- Busy is positive when tampering with cursors is prohibited. Busy and + -- Lock are both positive when tampering with elements is prohibited. + + type Tamper_Counts_Access is access all Tamper_Counts; + for Tamper_Counts_Access'Storage_Size use 0; + + generic + package Generic_Implementation is + + -- Generic package used in the implementation of containers. + + -- This needs to be generic so that the 'Enabled attribute will return + -- the value that is relevant at the point where a container generic is + -- instantiated. For example: + -- + -- pragma Suppress (Container_Checks); + -- package My_Vectors is new Ada.Containers.Vectors (...); + -- + -- should suppress all container-related checks within the instance + -- My_Vectors. + + -- Shorthands for "checks enabled" and "tampering checks enabled". Note + -- that suppressing either Container_Checks or Tampering_Check disables + -- tampering checks. Note that this code needs to be in a generic + -- package, because we want to take account of check suppressions at the + -- instance. We use these flags, along with pragma Inline, to ensure + -- that the compiler can optimize away the checks, as well as the + -- tampering check machinery, when checks are suppressed. + + Checks : constant Boolean := Container_Checks'Enabled; + T_Check : constant Boolean := + Container_Checks'Enabled and Tampering_Check'Enabled; + + -- Reference_Control_Type is used as a component of reference types, to + -- prohibit tampering with elements so long as references exist. + + type Reference_Control_Type is + new Finalization.Controlled with record + T_Counts : Tamper_Counts_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Adjust (Control : in out Reference_Control_Type); + pragma Inline (Adjust); + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + procedure Zero_Counts (T_Counts : out Tamper_Counts); + pragma Inline (Zero_Counts); + -- Set Busy and Lock to zero + + procedure Busy (T_Counts : in out Tamper_Counts); + pragma Inline (Busy); + -- Prohibit tampering with cursors + + procedure Unbusy (T_Counts : in out Tamper_Counts); + pragma Inline (Unbusy); + -- Allow tampering with cursors + + procedure Lock (T_Counts : in out Tamper_Counts); + pragma Inline (Lock); + -- Prohibit tampering with elements + + procedure Unlock (T_Counts : in out Tamper_Counts); + pragma Inline (Unlock); + -- Allow tampering with elements + + procedure TC_Check (T_Counts : Tamper_Counts); + pragma Inline (TC_Check); + -- Tampering-with-cursors check + + procedure TE_Check (T_Counts : Tamper_Counts); + pragma Inline (TE_Check); + -- Tampering-with-elements check + + ----------------- + -- RAII Types -- + ----------------- + + -- Initialize of With_Busy increments the Busy count, and Finalize + -- decrements it. Thus, to prohibit tampering with elements within a + -- given scope, declare an object of type With_Busy. The Busy count + -- will be correctly decremented in case of exception or abort. + + -- With_Lock is the same as With_Busy, except it increments/decrements + -- BOTH Busy and Lock, thus prohibiting tampering with cursors. + + type With_Busy (T_Counts : not null access Tamper_Counts) is + new Finalization.Limited_Controlled with null record + with Disable_Controlled => not T_Check; + overriding procedure Initialize (Busy : in out With_Busy); + overriding procedure Finalize (Busy : in out With_Busy); + + type With_Lock (T_Counts : not null access Tamper_Counts) is + new Finalization.Limited_Controlled with null record + with Disable_Controlled => not T_Check; + overriding procedure Initialize (Lock : in out With_Lock); + overriding procedure Finalize (Lock : in out With_Lock); + + -- Variables of type With_Busy and With_Lock are declared only for the + -- effects of Initialize and Finalize, so they are not referenced; + -- disable warnings about that. Note that all variables of these types + -- have names starting with "Busy" or "Lock". These pragmas need to be + -- present wherever these types are used. + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + + end Generic_Implementation; + +end Ada.Containers.Helpers; diff --git a/gcc/ada/libgnat/a-contai.ads b/gcc/ada/libgnat/a-contai.ads new file mode 100644 index 0000000..be8a808 --- /dev/null +++ b/gcc/ada/libgnat/a-contai.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Containers is + pragma Pure; + + type Hash_Type is mod 2**32; + type Count_Type is range 0 .. 2**31 - 1; + + Capacity_Error : exception; + +end Ada.Containers; diff --git a/gcc/ada/libgnat/a-convec.adb b/gcc/ada/libgnat/a-convec.adb new file mode 100644 index 0000000..84d6106 --- /dev/null +++ b/gcc/ada/libgnat/a-convec.adb @@ -0,0 +1,3274 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . V E C T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers.Generic_Array_Sort; +with Ada.Unchecked_Deallocation; + +with System; use type System.Address; + +package body Ada.Containers.Vectors is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + procedure Free is + new Ada.Unchecked_Deallocation (Elements_Type, Elements_Access); + + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type); + -- This is the slow path for Append. This is split out to minimize the size + -- of Append, because we have Inline (Append). + + --------- + -- "&" -- + --------- + + -- We decide that the capacity of the result of "&" is the minimum needed + -- -- the sum of the lengths of the vector parameters. We could decide to + -- make it larger, but we have no basis for knowing how much larger, so we + -- just allocate the minimum amount of storage. + + function "&" (Left, Right : Vector) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + function "&" (Left : Vector; Right : Element_Type) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, Length (Left) + 1); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + function "&" (Left : Element_Type; Right : Vector) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, 1 + Length (Right)); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + function "&" (Left, Right : Element_Type) return Vector is + begin + return Result : Vector do + Reserve_Capacity (Result, 1 + 1); + Append (Result, Left); + Append (Result, Right); + end return; + end "&"; + + --------- + -- "=" -- + --------- + + overriding function "=" (Left, Right : Vector) return Boolean is + begin + if Left.Last /= Right.Last then + return False; + end if; + + if Left.Length = 0 then + return True; + end if; + + declare + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + begin + for J in Index_Type range Index_Type'First .. Left.Last loop + if Left.Elements.EA (J) /= Right.Elements.EA (J) then + return False; + end if; + end loop; + end; + + return True; + end "="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Container : in out Vector) is + begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Container.TC); + + if Container.Last = No_Index then + Container.Elements := null; + return; + end if; + + declare + L : constant Index_Type := Container.Last; + EA : Elements_Array renames + Container.Elements.EA (Index_Type'First .. L); + + begin + Container.Elements := null; + + -- Note: it may seem that the following assignment to Container.Last + -- is useless, since we assign it to L below. However this code is + -- used in case 'new Elements_Type' below raises an exception, to + -- keep Container in a consistent state. + + Container.Last := No_Index; + Container.Elements := new Elements_Type'(L, EA); + Container.Last := L; + end; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append (Container : in out Vector; New_Item : Vector) is + begin + if Is_Empty (New_Item) then + return; + elsif Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item); + end if; + end Append; + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + -- In the general case, we pass the buck to Insert, but for efficiency, + -- we check for the usual case where Count = 1 and the vector has enough + -- room for at least one more element. + + if Count = 1 + and then Container.Elements /= null + and then Container.Last /= Container.Elements.Last + then + TC_Check (Container.TC); + + -- Increment Container.Last after assigning the New_Item, so we + -- leave the Container unmodified in case Finalize/Adjust raises + -- an exception. + + declare + New_Last : constant Index_Type := Container.Last + 1; + begin + Container.Elements.EA (New_Last) := New_Item; + Container.Last := New_Last; + end; + + else + Append_Slow_Path (Container, New_Item, Count); + end if; + end Append; + + ---------------------- + -- Append_Slow_Path -- + ---------------------- + + procedure Append_Slow_Path + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type) + is + begin + if Count = 0 then + return; + elsif Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + else + Insert (Container, Container.Last + 1, New_Item, Count); + end if; + end Append_Slow_Path; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Vector; Source : Vector) is + begin + if Target'Address = Source'Address then + return; + else + Target.Clear; + Target.Append (Source); + end if; + end Assign; + + -------------- + -- Capacity -- + -------------- + + function Capacity (Container : Vector) return Count_Type is + begin + if Container.Elements = null then + return 0; + else + return Container.Elements.EA'Length; + end if; + end Capacity; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out Vector) is + begin + TC_Check (Container.TC); + Container.Last := No_Index; + end Clear; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Position.Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean + is + begin + return Find_Index (Container, Item) /= No_Index; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy + (Source : Vector; + Capacity : Count_Type := 0) return Vector + is + C : Count_Type; + + begin + if Capacity >= Source.Length then + C := Capacity; + + else + C := Source.Length; + + if Checks and then Capacity /= 0 then + raise Capacity_Error with + "Requested capacity is less than Source length"; + end if; + end if; + + return Target : Vector do + Target.Reserve_Capacity (C); + Target.Assign (Source); + end return; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1) + is + Old_Last : constant Index_Type'Base := Container.Last; + New_Last : Index_Type'Base; + Count2 : Count_Type'Base; -- count of items from Index to Old_Last + J : Index_Type'Base; -- first index of items that slide down + + begin + -- Delete removes items from the vector, the number of which is the + -- minimum of the specified Count and the items (if any) that exist from + -- Index to Container.Last. There are no constraints on the specified + -- value of Count (it can be larger than what's available at this + -- position in the vector, for example), but there are constraints on + -- the allowed values of the Index. + + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we do + -- not allow that as the value for Index when specifying which items + -- should be deleted, so we must manually check. (That the user is + -- allowed to specify the value at all here is a consequence of the + -- declaration of the Extended_Index subtype, which includes the values + -- in the base range that immediately precede and immediately follow the + -- values in the Index_Type.) + + if Checks and then Index < Index_Type'First then + raise Constraint_Error with "Index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows the + -- corner case of deleting no items from the back end of the vector to + -- be treated as a no-op. (It is assumed that specifying an index value + -- greater than Last + 1 indicates some deeper flaw in the caller's + -- algorithm, so that case is treated as a proper error.) + + if Index > Old_Last then + if Checks and then Index > Old_Last + 1 then + raise Constraint_Error with "Index is out of range (too large)"; + else + return; + end if; + end if; + + -- Here and elsewhere we treat deleting 0 items from the container as a + -- no-op, even when the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete checks the count to determine whether it is + -- being called while the associated callback procedure is executing. + + TC_Check (Container.TC); + + -- We first calculate what's available for deletion starting at + -- Index. Here and elsewhere we use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate values. (See function + -- Length for more information.) + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + Count2 := Count_Type'Base (Old_Last) - Count_Type'Base (Index) + 1; + else + Count2 := Count_Type'Base (Old_Last - Index + 1); + end if; + + -- If more elements are requested (Count) for deletion than are + -- available (Count2) for deletion beginning at Index, then everything + -- from Index is deleted. There are no elements to slide down, and so + -- all we need to do is set the value of Container.Last. + + if Count >= Count2 then + Container.Last := Index - 1; + return; + end if; + + -- There are some elements that aren't being deleted (the requested + -- count was less than the available count), so we must slide them down + -- to Index. We first calculate the index values of the respective array + -- slices, using the wider of Index_Type'Base and Count_Type'Base as the + -- type for intermediate calculations. For the elements that slide down, + -- index value New_Last is the last index value of their new home, and + -- index value J is the first index of their old home. + + if Index_Type'Base'Last >= Count_Type_Last then + New_Last := Old_Last - Index_Type'Base (Count); + J := Index + Index_Type'Base (Count); + else + New_Last := Index_Type'Base (Count_Type'Base (Old_Last) - Count); + J := Index_Type'Base (Count_Type'Base (Index) + Count); + end if; + + -- The internal elements array isn't guaranteed to exist unless we have + -- elements, but we have that guarantee here because we know we have + -- elements to slide. The array index values for each slice have + -- already been determined, so we just slide down to Index the elements + -- that weren't deleted. + + declare + EA : Elements_Array renames Container.Elements.EA; + begin + EA (Index .. New_Last) := EA (J .. Old_Last); + Container.Last := New_Last; + end; + end Delete; + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1) + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + + elsif Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + end if; + + Delete (Container, Position.Index, Count); + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + if Count = 0 then + return; + + elsif Count >= Length (Container) then + Clear (Container); + return; + + else + Delete (Container, Index_Type'First, Count); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1) + is + begin + -- It is not permitted to delete items while the container is busy (for + -- example, we're in the middle of a passive iteration). However, we + -- always treat deleting 0 items as a no-op, even when we're busy, so we + -- simply return without checking. + + if Count = 0 then + return; + end if; + + -- The tampering bits exist to prevent an item from being deleted (or + -- otherwise harmfully manipulated) while it is being visited. Query, + -- Update, and Iterate increment the busy count on entry, and decrement + -- the count on exit. Delete_Last checks the count to determine whether + -- it is being called while the associated callback procedure is + -- executing. + + TC_Check (Container.TC); + + -- There is no restriction on how large Count can be when deleting + -- items. If it is equal or greater than the current length, then this + -- is equivalent to clearing the vector. (In particular, there's no need + -- for us to actually calculate the new value for Last.) + + -- If the requested count is less than the current length, then we must + -- calculate the new value for Last. For the type we use the widest of + -- Index_Type'Base and Count_Type'Base for the intermediate values of + -- our calculation. (See the comments in Length for more information.) + + if Count >= Container.Length then + Container.Last := No_Index; + + elsif Index_Type'Base'Last >= Count_Type_Last then + Container.Last := Container.Last - Index_Type'Base (Count); + + else + Container.Last := + Index_Type'Base (Count_Type'Base (Container.Last) - Count); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + return Container.Elements.EA (Index); + end Element; + + function Element (Position : Cursor) return Element_Type is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + return Position.Container.Elements.EA (Position.Index); + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Container : in out Vector) is + X : Elements_Access := Container.Elements; + + begin + Container.Elements := null; + Container.Last := No_Index; + + Free (X); + + TC_Check (Container.TC); + end Finalize; + + procedure Finalize (Object : in out Iterator) is + begin + Unbusy (Object.Container.TC); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + begin + if Checks and then Position.Container /= null then + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Container.Last then + raise Program_Error with "Position index is out of range"; + end if; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for J in Position.Index .. Container.Last loop + if Container.Elements.EA (J) = Item then + return Cursor'(Container'Unrestricted_Access, J); + end if; + end loop; + + return No_Element; + end; + end Find; + + ---------------- + -- Find_Index -- + ---------------- + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index + is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for Indx in Index .. Container.Last loop + if Container.Elements.EA (Indx) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Find_Index; + + ----------- + -- First -- + ----------- + + function First (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + end if; + + return (Container'Unrestricted_Access, Index_Type'First); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Index component influences the + -- behavior of the First (and Last) selector function. + + -- When the Index component is No_Index, this means the iterator + -- object was constructed without a start expression, in which case the + -- (forward) iteration starts from the (logical) beginning of the entire + -- sequence of items (corresponding to Container.First, for a forward + -- iterator). + + -- Otherwise, this is iteration over a partial sequence of items. + -- When the Index component isn't No_Index, the iterator object was + -- constructed with a start expression, that specifies the position + -- from which the (forward) partial iteration begins. + + if Object.Index = No_Index then + return First (Object.Container.all); + else + return Cursor'(Object.Container, Object.Index); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Vector) return Element_Type is + begin + if Checks and then Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + else + return Container.Elements.EA (Index_Type'First); + end if; + end First_Element; + + ----------------- + -- First_Index -- + ----------------- + + function First_Index (Container : Vector) return Index_Type is + pragma Unreferenced (Container); + begin + return Index_Type'First; + end First_Index; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : Vector) return Boolean is + begin + if Container.Last <= Index_Type'First then + return True; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + EA : Elements_Array renames Container.Elements.EA; + begin + for J in Index_Type'First .. Container.Last - 1 loop + if EA (J + 1) < EA (J) then + return False; + end if; + end loop; + + return True; + end; + end Is_Sorted; + + ----------- + -- Merge -- + ----------- + + procedure Merge (Target, Source : in out Vector) is + I : Index_Type'Base := Target.Last; + J : Index_Type'Base; + + begin + -- The semantics of Merge changed slightly per AI05-0021. It was + -- originally the case that if Target and Source denoted the same + -- container object, then the GNAT implementation of Merge did + -- nothing. However, it was argued that RM05 did not precisely + -- specify the semantics for this corner case. The decision of the + -- ARG was that if Target and Source denote the same non-empty + -- container object, then Program_Error is raised. + + if Source.Last < Index_Type'First then -- Source is empty + return; + end if; + + if Checks and then Target'Address = Source'Address then + raise Program_Error with + "Target and Source denote same non-empty container"; + end if; + + if Target.Last < Index_Type'First then -- Target is empty + Move (Target => Target, Source => Source); + return; + end if; + + TC_Check (Source.TC); + + Target.Set_Length (Length (Target) + Length (Source)); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + TA : Elements_Array renames Target.Elements.EA; + SA : Elements_Array renames Source.Elements.EA; + + Lock_Target : With_Lock (Target.TC'Unchecked_Access); + Lock_Source : With_Lock (Source.TC'Unchecked_Access); + begin + J := Target.Last; + while Source.Last >= Index_Type'First loop + pragma Assert (Source.Last <= Index_Type'First + or else not (SA (Source.Last) < + SA (Source.Last - 1))); + + if I < Index_Type'First then + TA (Index_Type'First .. J) := + SA (Index_Type'First .. Source.Last); + + Source.Last := No_Index; + exit; + end if; + + pragma Assert (I <= Index_Type'First + or else not (TA (I) < TA (I - 1))); + + if SA (Source.Last) < TA (I) then + TA (J) := TA (I); + I := I - 1; + + else + TA (J) := SA (Source.Last); + Source.Last := Source.Last - 1; + end if; + + J := J - 1; + end loop; + end; + end Merge; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out Vector) is + procedure Sort is + new Generic_Array_Sort + (Index_Type => Index_Type, + Element_Type => Element_Type, + Array_Type => Elements_Array, + "<" => "<"); + + begin + if Container.Last <= Index_Type'First then + return; + end if; + + -- The exception behavior for the vector container must match that + -- for the list container, so we check for cursor tampering here + -- (which will catch more things) instead of for element tampering + -- (which will catch fewer things). It's true that the elements of + -- this vector container could be safely moved around while (say) an + -- iteration is taking place (iteration only increments the busy + -- counter), and so technically all we would need here is a test for + -- element tampering (indicated by the lock counter), that's simply + -- an artifact of our array-based implementation. Logically Sort + -- requires a check for cursor tampering. + + TC_Check (Container.TC); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + Sort (Container.Elements.EA (Index_Type'First .. Container.Last)); + end; + end Sort; + + end Generic_Sorting; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements.EA (Position.Index)'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array + + begin + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) + + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + end if; + + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion count. + -- Note: we cannot simply add these values, because of the possibility + -- of overflow. + + if Checks and then Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= Count_Type_Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if Checks and then New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type_Last then + New_Last := No_Index + Index_Type'Base (New_Length); + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because element initialization fails). + + Container.Elements := new Elements_Type' + (Last => New_Last, + EA => (others => New_Item)); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + + Container.Last := New_Last; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + TC_Check (Container.TC); + + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. + + if New_Length <= Container.Elements.EA'Length then + + -- In this case, we're inserting elements into a vector that has + -- already allocated an internal array, and the existing array has + -- enough unused storage for the new items. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + if Before > Container.Last then + + -- The new items are being appended to the vector, so no + -- sliding of existing elements is required. + + EA (Before .. New_Last) := (others => New_Item); + + else + -- The new items are being inserted before some existing + -- elements, so we must slide the existing elements up to their + -- new home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + EA (Index .. New_Last) := EA (Before .. Container.Last); + EA (Before .. Index - 1) := (others => New_Item); + end if; + end; + + Container.Last := New_Last; + return; + end if; + + -- In this case, we're inserting elements into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + else + New_Capacity := 2 * New_Capacity; + end if; + end loop; + + if New_Capacity > Max_Length then + + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) + + New_Capacity := Max_Length; + end if; + + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + if Index_Type'Base'Last >= Count_Type_Last then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. + + declare + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination + + begin + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); + + if Before > Container.Last then + DA (Before .. New_Last) := (others => New_Item); + + else + -- The new items are being inserted before some existing elements, + -- so we must slide the existing elements up to their new home. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + DA (Before .. Index - 1) := (others => New_Item); + DA (Index .. New_Last) := SA (Before .. Container.Last); + end if; + + exception + when others => + Free (Dst); + raise; + end; + + -- We have successfully copied the items onto the new array, so the + -- final thing to do is deallocate the old array. + + declare + X : Elements_Access := Container.Elements; + + begin + -- We first isolate the old internal array, removing it from the + -- container and replacing it with the new internal array, before we + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + + Container.Elements := Dst; + Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + + Free (X); + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector) + is + N : constant Count_Type := Length (New_Item); + J : Index_Type'Base; + + begin + -- Use Insert_Space to create the "hole" (the destination slice) into + -- which we copy the source items. + + Insert_Space (Container, Before, Count => N); + + if N = 0 then + + -- There's nothing else to do here (vetting of parameters was + -- performed already in Insert_Space), so we simply return. + + return; + end if; + + -- We calculate the last index value of the destination slice using the + -- wider of Index_Type'Base and count_Type'Base. + + if Index_Type'Base'Last >= Count_Type_Last then + J := (Before - 1) + Index_Type'Base (N); + else + J := Index_Type'Base (Count_Type'Base (Before - 1) + N); + end if; + + if Container'Address /= New_Item'Address then + + -- This is the simple case. New_Item denotes an object different + -- from Container, so there's nothing special we need to do to copy + -- the source items to their destination, because all of the source + -- items are contiguous. + + Container.Elements.EA (Before .. J) := + New_Item.Elements.EA (Index_Type'First .. New_Item.Last); + + return; + end if; + + -- New_Item denotes the same object as Container, so an insertion has + -- potentially split the source items. The destination is always the + -- range [Before, J], but the source is [Index_Type'First, Before) and + -- (J, Container.Last]. We perform the copy in two steps, using each of + -- the two slices of the source items. + + declare + L : constant Index_Type'Base := Before - 1; + + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. L; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + K : Index_Type'Base; + + begin + -- We first copy the source items that precede the space we + -- inserted. Index value K is the last index of that portion + -- destination that receives this slice of the source. (If Before + -- equals Index_Type'First, then this first source slice will be + -- empty, which is harmless.) + + if Index_Type'Base'Last >= Count_Type_Last then + K := L + Index_Type'Base (Src'Length); + else + K := Index_Type'Base (Count_Type'Base (L) + Src'Length); + end if; + + Container.Elements.EA (Before .. K) := Src; + + if Src'Length = N then + + -- The new items were effectively appended to the container, so we + -- have already copied all of the items that need to be copied. + -- We return early here, even though the source slice below is + -- empty (so the assignment would be harmless), because we want to + -- avoid computing J + 1, which will overflow if J equals + -- Index_Type'Base'Last. + + return; + end if; + end; + + declare + -- Note that we want to avoid computing J + 1 here, in case J equals + -- Index_Type'Base'Last. We prevent that by returning early above, + -- immediately after copying the first slice of the source, and + -- determining that this second slice of the source is empty. + + F : constant Index_Type'Base := J + 1; + + subtype Src_Index_Subtype is Index_Type'Base range + F .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + K : Index_Type'Base; + + begin + -- We next copy the source items that follow the space we inserted. + -- Index value K is the first index of that portion of the + -- destination that receives this slice of the source. (For the + -- reasons given above, this slice is guaranteed to be non-empty.) + + if Index_Type'Base'Last >= Count_Type_Last then + K := F - Index_Type'Base (Src'Length); + else + K := Index_Type'Base (Count_Type'Base (F) - Src'Length); + end if; + + Container.Elements.EA (K .. J) := Src; + end; + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Is_Empty (New_Item) then + if Before.Container = null or else Before.Index > Container.Last then + Position := No_Element; + else + Position := (Container'Unrestricted_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item); + + Position := (Container'Unrestricted_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + else + Index := Container.Last + 1; + end if; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null or else Before.Index > Container.Last then + Position := No_Element; + else + Position := (Container'Unrestricted_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + end if; + + Index := Container.Last + 1; + + else + Index := Before.Index; + end if; + + Insert (Container, Index, New_Item, Count); + + Position := (Container'Unrestricted_Access, Index); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Count); + end Insert; + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Default-initialized value + pragma Warnings (Off, New_Item); + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + ------------------ + -- Insert_Space -- + ------------------ + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1) + is + Old_Length : constant Count_Type := Container.Length; + + Max_Length : Count_Type'Base; -- determined from range of Index_Type + New_Length : Count_Type'Base; -- sum of current length and Count + New_Last : Index_Type'Base; -- last index of vector after insertion + + Index : Index_Type'Base; -- scratch for intermediate values + J : Count_Type'Base; -- scratch + + New_Capacity : Count_Type'Base; -- length of new, expanded array + Dst_Last : Index_Type'Base; -- last index of new, expanded array + Dst : Elements_Access; -- new, expanded internal array + + begin + if Checks then + -- As a precondition on the generic actual Index_Type, the base type + -- must include Index_Type'Pred (Index_Type'First); this is the value + -- that Container.Last assumes when the vector is empty. However, we + -- do not allow that as the value for Index when specifying where the + -- new items should be inserted, so we must manually check. (That the + -- user is allowed to specify the value at all here is a consequence + -- of the declaration of the Extended_Index subtype, which includes + -- the values in the base range that immediately precede and + -- immediately follow the values in the Index_Type.) + + if Before < Index_Type'First then + raise Constraint_Error with + "Before index is out of range (too small)"; + end if; + + -- We do allow a value greater than Container.Last to be specified as + -- the Index, but only if it's immediately greater. This allows for + -- the case of appending items to the back end of the vector. (It is + -- assumed that specifying an index value greater than Last + 1 + -- indicates some deeper flaw in the caller's algorithm, so that case + -- is treated as a proper error.) + + if Before > Container.Last + 1 then + raise Constraint_Error with + "Before index is out of range (too large)"; + end if; + end if; + + -- We treat inserting 0 items into the container as a no-op, even when + -- the container is busy, so we simply return. + + if Count = 0 then + return; + end if; + + -- There are two constraints we need to satisfy. The first constraint is + -- that a container cannot have more than Count_Type'Last elements, so + -- we must check the sum of the current length and the insertion count. + -- Note: we cannot simply add these values, because of the possibility + -- of overflow. + + if Checks and then Old_Length > Count_Type'Last - Count then + raise Constraint_Error with "Count is out of range"; + end if; + + -- It is now safe compute the length of the new vector, without fear of + -- overflow. + + New_Length := Old_Length + Count; + + -- The second constraint is that the new Last index value cannot exceed + -- Index_Type'Last. In each branch below, we calculate the maximum + -- length (computed from the range of values in Index_Type), and then + -- compare the new length to the maximum length. If the new length is + -- acceptable, then we compute the new last index from that. + + if Index_Type'Base'Last >= Count_Type_Last then + -- We have to handle the case when there might be more values in the + -- range of Index_Type than in the range of Count_Type. + + if Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is + -- less than 0, so it is safe to compute the following sum without + -- fear of overflow. + + Index := No_Index + Index_Type'Base (Count_Type'Last); + + if Index <= Index_Type'Last then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute + -- the difference without fear of overflow (which we would have to + -- worry about if No_Index were less than 0, but that case is + -- handled above). + + if Index_Type'Last - No_Index >= Count_Type_Last then + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the + -- maximum number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than in Count_Type, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := Count_Type'Base (Index_Type'Last - No_Index); + end if; + end if; + + elsif Index_Type'First <= 0 then + + -- We know that No_Index (the same as Index_Type'First - 1) is less + -- than 0, so it is safe to compute the following sum without fear of + -- overflow. + + J := Count_Type'Base (No_Index) + Count_Type'Last; + + if J <= Count_Type'Base (Index_Type'Last) then + + -- We have determined that range of Index_Type has at least as + -- many values as in Count_Type, so Count_Type'Last is the maximum + -- number of items that are allowed. + + Max_Length := Count_Type'Last; + + else + -- The range of Index_Type has fewer values than Count_Type does, + -- so the maximum number of items is computed from the range of + -- the Index_Type. + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + else + -- No_Index is equal or greater than 0, so we can safely compute the + -- difference without fear of overflow (which we would have to worry + -- about if No_Index were less than 0, but that case is handled + -- above). + + Max_Length := + Count_Type'Base (Index_Type'Last) - Count_Type'Base (No_Index); + end if; + + -- We have just computed the maximum length (number of items). We must + -- now compare the requested length to the maximum length, as we do not + -- allow a vector expand beyond the maximum (because that would create + -- an internal array with a last index value greater than + -- Index_Type'Last, with no way to index those elements). + + if Checks and then New_Length > Max_Length then + raise Constraint_Error with "Count is out of range"; + end if; + + -- New_Last is the last index value of the items in the container after + -- insertion. Use the wider of Index_Type'Base and Count_Type'Base to + -- compute its value from the New_Length. + + if Index_Type'Base'Last >= Count_Type_Last then + New_Last := No_Index + Index_Type'Base (New_Length); + else + New_Last := Index_Type'Base (Count_Type'Base (No_Index) + New_Length); + end if; + + if Container.Elements = null then + pragma Assert (Container.Last = No_Index); + + -- This is the simplest case, with which we must always begin: we're + -- inserting items into an empty vector that hasn't allocated an + -- internal array yet. Note that we don't need to check the busy bit + -- here, because an empty container cannot be busy. + + -- In order to preserve container invariants, we allocate the new + -- internal array first, before setting the Last index value, in case + -- the allocation fails (which can happen either because there is no + -- storage available, or because default-valued element + -- initialization fails). + + Container.Elements := new Elements_Type (New_Last); + + -- The allocation of the new, internal array succeeded, so it is now + -- safe to update the Last index, restoring container invariants. + + Container.Last := New_Last; + + return; + end if; + + -- The tampering bits exist to prevent an item from being harmfully + -- manipulated while it is being visited. Query, Update, and Iterate + -- increment the busy count on entry, and decrement the count on + -- exit. Insert checks the count to determine whether it is being called + -- while the associated callback procedure is executing. + + TC_Check (Container.TC); + + -- An internal array has already been allocated, so we must determine + -- whether there is enough unused storage for the new items. + + if New_Last <= Container.Elements.Last then + + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, and the existing array has enough + -- unused storage for the new items. + + declare + EA : Elements_Array renames Container.Elements.EA; + + begin + if Before <= Container.Last then + + -- The space is being inserted before some existing elements, + -- so we must slide the existing elements up to their new + -- home. We use the wider of Index_Type'Base and + -- Count_Type'Base as the type for intermediate index values. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + EA (Index .. New_Last) := EA (Before .. Container.Last); + end if; + end; + + Container.Last := New_Last; + return; + end if; + + -- In this case, we're inserting space into a vector that has already + -- allocated an internal array, but the existing array does not have + -- enough storage, so we must allocate a new, longer array. In order to + -- guarantee that the amortized insertion cost is O(1), we always + -- allocate an array whose length is some power-of-two factor of the + -- current array length. (The new array cannot have a length less than + -- the New_Length of the container, but its last index value cannot be + -- greater than Index_Type'Last.) + + New_Capacity := Count_Type'Max (1, Container.Elements.EA'Length); + while New_Capacity < New_Length loop + if New_Capacity > Count_Type'Last / 2 then + New_Capacity := Count_Type'Last; + exit; + end if; + + New_Capacity := 2 * New_Capacity; + end loop; + + if New_Capacity > Max_Length then + + -- We have reached the limit of capacity, so no further expansion + -- will occur. (This is not a problem, as there is never a need to + -- have more capacity than the maximum container length.) + + New_Capacity := Max_Length; + end if; + + -- We have computed the length of the new internal array (and this is + -- what "vector capacity" means), so use that to compute its last index. + + if Index_Type'Base'Last >= Count_Type_Last then + Dst_Last := No_Index + Index_Type'Base (New_Capacity); + else + Dst_Last := + Index_Type'Base (Count_Type'Base (No_Index) + New_Capacity); + end if; + + -- Now we allocate the new, longer internal array. If the allocation + -- fails, we have not changed any container state, so no side-effect + -- will occur as a result of propagating the exception. + + Dst := new Elements_Type (Dst_Last); + + -- We have our new internal array. All that needs to be done now is to + -- copy the existing items (if any) from the old array (the "source" + -- array, object SA below) to the new array (the "destination" array, + -- object DA below), and then deallocate the old array. + + declare + SA : Elements_Array renames Container.Elements.EA; -- source + DA : Elements_Array renames Dst.EA; -- destination + + begin + DA (Index_Type'First .. Before - 1) := + SA (Index_Type'First .. Before - 1); + + if Before <= Container.Last then + + -- The space is being inserted before some existing elements, so + -- we must slide the existing elements up to their new home. + + if Index_Type'Base'Last >= Count_Type_Last then + Index := Before + Index_Type'Base (Count); + else + Index := Index_Type'Base (Count_Type'Base (Before) + Count); + end if; + + DA (Index .. New_Last) := SA (Before .. Container.Last); + end if; + + exception + when others => + Free (Dst); + raise; + end; + + -- We have successfully copied the items onto the new array, so the + -- final thing to do is restore invariants, and deallocate the old + -- array. + + declare + X : Elements_Access := Container.Elements; + + begin + -- We first isolate the old internal array, removing it from the + -- container and replacing it with the new internal array, before we + -- deallocate the old array (which can fail if finalization of + -- elements propagates an exception). + + Container.Elements := Dst; + Container.Last := New_Last; + + -- The container invariants have been restored, so it is now safe to + -- attempt to deallocate the old array. + + Free (X); + end; + end Insert_Space; + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + Index : Index_Type'Base; + + begin + if Checks and then Before.Container /= null + and then Before.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Before cursor denotes wrong container"; + end if; + + if Count = 0 then + if Before.Container = null or else Before.Index > Container.Last then + Position := No_Element; + else + Position := (Container'Unrestricted_Access, Before.Index); + end if; + + return; + end if; + + if Before.Container = null or else Before.Index > Container.Last then + if Checks and then Container.Last = Index_Type'Last then + raise Constraint_Error with + "vector is already at its maximum length"; + else + Index := Container.Last + 1; + end if; + + else + Index := Before.Index; + end if; + + Insert_Space (Container, Index, Count); + + Position := (Container'Unrestricted_Access, Index); + end Insert_Space; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Vector) return Boolean is + begin + return Container.Last < Index_Type'First; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + for Indx in Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + end Iterate; + + function Iterate + (Container : Vector) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class + is + V : constant Vector_Access := Container'Unrestricted_Access; + begin + -- The value of its Index component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Index + -- component is No_Index (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => V, + Index => No_Index) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate + (Container : Vector; + Start : Cursor) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class + is + V : constant Vector_Access := Container'Unrestricted_Access; + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks then + if Start.Container = null then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= V then + raise Program_Error with + "Start cursor of Iterate designates wrong vector"; + end if; + + if Start.Index > V.Last then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + end if; + + -- The value of its Index component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Index + -- component is not No_Index (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => V, + Index => Start.Index) + do + Busy (Container.TC'Unrestricted_Access.all); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Vector) return Cursor is + begin + if Is_Empty (Container) then + return No_Element; + else + return (Container'Unrestricted_Access, Container.Last); + end if; + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Index component influences the + -- behavior of the Last (and First) selector function. + + -- When the Index component is No_Index, this means the iterator + -- object was constructed without a start expression, in which case the + -- (reverse) iteration starts from the (logical) beginning of the entire + -- sequence (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. + -- When the Index component is not No_Index, the iterator object was + -- constructed with a start expression, that specifies the position + -- from which the (reverse) partial iteration begins. + + if Object.Index = No_Index then + return Last (Object.Container.all); + else + return Cursor'(Object.Container, Object.Index); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Vector) return Element_Type is + begin + if Checks and then Container.Last = No_Index then + raise Constraint_Error with "Container is empty"; + else + return Container.Elements.EA (Container.Last); + end if; + end Last_Element; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index (Container : Vector) return Extended_Index is + begin + return Container.Last; + end Last_Index; + + ------------ + -- Length -- + ------------ + + function Length (Container : Vector) return Count_Type is + L : constant Index_Type'Base := Container.Last; + F : constant Index_Type := Index_Type'First; + + begin + -- The base range of the index type (Index_Type'Base) might not include + -- all values for length (Count_Type). Contrariwise, the index type + -- might include values outside the range of length. Hence we use + -- whatever type is wider for intermediate values when calculating + -- length. Note that no matter what the index type is, the maximum + -- length to which a vector is allowed to grow is always the minimum + -- of Count_Type'Last and (IT'Last - IT'First + 1). + + -- For example, an Index_Type with range -127 .. 127 is only guaranteed + -- to have a base range of -128 .. 127, but the corresponding vector + -- would have lengths in the range 0 .. 255. In this case we would need + -- to use Count_Type'Base for intermediate values. + + -- Another case would be the index range -2**63 + 1 .. -2**63 + 10. The + -- vector would have a maximum length of 10, but the index values lie + -- outside the range of Count_Type (which is only 32 bits). In this + -- case we would need to use Index_Type'Base for intermediate values. + + if Count_Type'Base'Last >= Index_Type'Pos (Index_Type'Base'Last) then + return Count_Type'Base (L) - Count_Type'Base (F) + 1; + else + return Count_Type (L - F + 1); + end if; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move + (Target : in out Vector; + Source : in out Vector) + is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Target.TC); + TC_Check (Source.TC); + + declare + Target_Elements : constant Elements_Access := Target.Elements; + begin + Target.Elements := Source.Elements; + Source.Elements := Target_Elements; + end; + + Target.Last := Source.Last; + Source.Last := No_Index; + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Position.Index < Position.Container.Last then + return (Position.Container, Position.Index + 1); + else + return No_Element; + end if; + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong vector"; + else + return Next (Position); + end if; + end Next; + + procedure Next (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index < Position.Container.Last then + Position.Index := Position.Index + 1; + else + Position := No_Element; + end if; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend (Container : in out Vector; New_Item : Vector) is + begin + Insert (Container, Index_Type'First, New_Item); + end Prepend; + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, Index_Type'First, New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Position.Index > Index_Type'First then + return (Position.Container, Position.Index - 1); + else + return No_Element; + end if; + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + elsif Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong vector"; + else + return Previous (Position); + end if; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + if Position.Container = null then + return; + elsif Position.Index > Index_Type'First then + Position.Index := Position.Index - 1; + else + Position := No_Element; + end if; + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)) + is + Lock : With_Lock (Container.TC'Unrestricted_Access); + V : Vector renames Container'Unrestricted_Access.all; + + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + Process (V.Elements.EA (Index)); + end Query_Element; + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + else + Query_Element (Position.Container.all, Position.Index, Process); + end if; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector) + is + Length : Count_Type'Base; + Last : Index_Type'Base := No_Index; + + begin + Clear (Container); + + Count_Type'Base'Read (Stream, Length); + + if Length > Capacity (Container) then + Reserve_Capacity (Container, Capacity => Length); + end if; + + for J in Count_Type range 1 .. Length loop + Last := Last + 1; + Element_Type'Read (Stream, Container.Elements.EA (Last)); + Container.Last := Last; + end loop; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + if Position.Index > Position.Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Container.Elements.EA (Position.Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + declare + TC : constant Tamper_Counts_Access := + Container.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Container.Elements.EA (Index)'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type) + is + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + TE_Check (Container.TC); + Container.Elements.EA (Index) := New_Item; + end Replace_Element; + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + + elsif Position.Index > Container.Last then + raise Constraint_Error with "Position cursor is out of range"; + end if; + end if; + + TE_Check (Container.TC); + Container.Elements.EA (Position.Index) := New_Item; + end Replace_Element; + + ---------------------- + -- Reserve_Capacity -- + ---------------------- + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type) + is + N : constant Count_Type := Length (Container); + + Index : Count_Type'Base; + Last : Index_Type'Base; + + begin + -- Reserve_Capacity can be used to either expand the storage available + -- for elements (this would be its typical use, in anticipation of + -- future insertion), or to trim back storage. In the latter case, + -- storage can only be trimmed back to the limit of the container + -- length. Note that Reserve_Capacity neither deletes (active) elements + -- nor inserts elements; it only affects container capacity, never + -- container length. + + if Capacity = 0 then + + -- This is a request to trim back storage, to the minimum amount + -- possible given the current state of the container. + + if N = 0 then + + -- The container is empty, so in this unique case we can + -- deallocate the entire internal array. Note that an empty + -- container can never be busy, so there's no need to check the + -- tampering bits. + + declare + X : Elements_Access := Container.Elements; + + begin + -- First we remove the internal array from the container, to + -- handle the case when the deallocation raises an exception. + + Container.Elements := null; + + -- Container invariants have been restored, so it is now safe + -- to attempt to deallocate the internal array. + + Free (X); + end; + + elsif N < Container.Elements.EA'Length then + + -- The container is not empty, and the current length is less than + -- the current capacity, so there's storage available to trim. In + -- this case, we allocate a new internal array having a length + -- that exactly matches the number of items in the + -- container. (Reserve_Capacity does not delete active elements, + -- so this is the best we can do with respect to minimizing + -- storage). + + TC_Check (Container.TC); + + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + X : Elements_Access := Container.Elements; + + begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have successfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + + Free (X); + end; + end if; + + return; + end if; + + -- Reserve_Capacity can be used to expand the storage available for + -- elements, but we do not let the capacity grow beyond the number of + -- values in Index_Type'Range. (Were it otherwise, there would be no way + -- to refer to the elements with an index value greater than + -- Index_Type'Last, so that storage would be wasted.) Here we compute + -- the Last index value of the new internal array, in a way that avoids + -- any possibility of overflow. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Capacity) < No_Index + then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Capacity); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Capacity is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Capacity. + + Index := Count_Type'Base (No_Index) + Capacity; -- Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Capacity; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Capacity is out of range"; + end if; + + -- We have determined that the value of Capacity would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Capacity); + end if; + + -- The requested capacity is non-zero, but we don't know yet whether + -- this is a request for expansion or contraction of storage. + + if Container.Elements = null then + + -- The container is empty (it doesn't even have an internal array), + -- so this represents a request to allocate (expand) storage having + -- the given capacity. + + Container.Elements := new Elements_Type (Last); + return; + end if; + + if Capacity <= N then + + -- This is a request to trim back storage, but only to the limit of + -- what's already in the container. (Reserve_Capacity never deletes + -- active elements, it only reclaims excess storage.) + + if N < Container.Elements.EA'Length then + + -- The container is not empty (because the requested capacity is + -- positive, and less than or equal to the container length), and + -- the current length is less than the current capacity, so + -- there's storage available to trim. In this case, we allocate a + -- new internal array having a length that exactly matches the + -- number of items in the container. + + TC_Check (Container.TC); + + declare + subtype Src_Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Src_Index_Subtype); + + X : Elements_Access := Container.Elements; + + begin + -- Although we have isolated the old internal array that we're + -- going to deallocate, we don't deallocate it until we have + -- successfully allocated a new one. If there is an exception + -- during allocation (either because there is not enough + -- storage, or because initialization of the elements fails), + -- we let it propagate without causing any side-effect. + + Container.Elements := new Elements_Type'(Container.Last, Src); + + -- We have successfully allocated a new internal array (with a + -- smaller length than the old one, and containing a copy of + -- just the active elements in the container), so it is now + -- safe to attempt to deallocate the old array. The old array + -- has been isolated, and container invariants have been + -- restored, so if the deallocation fails (because finalization + -- of the elements fails), we simply let it propagate. + + Free (X); + end; + end if; + + return; + end if; + + -- The requested capacity is larger than the container length (the + -- number of active elements). Whether this represents a request for + -- expansion or contraction of the current capacity depends on what the + -- current capacity is. + + if Capacity = Container.Elements.EA'Length then + + -- The requested capacity matches the existing capacity, so there's + -- nothing to do here. We treat this case as a no-op, and simply + -- return without checking the busy bit. + + return; + end if; + + -- There is a change in the capacity of a non-empty container, so a new + -- internal array will be allocated. (The length of the new internal + -- array could be less or greater than the old internal array. We know + -- only that the length of the new internal array is greater than the + -- number of active elements in the container.) We must check whether + -- the container is busy before doing anything else. + + TC_Check (Container.TC); + + -- We now allocate a new internal array, having a length different from + -- its current value. + + declare + E : Elements_Access := new Elements_Type (Last); + + begin + -- We have successfully allocated the new internal array. We first + -- attempt to copy the existing elements from the old internal array + -- ("src" elements) onto the new internal array ("tgt" elements). + + declare + subtype Index_Subtype is Index_Type'Base range + Index_Type'First .. Container.Last; + + Src : Elements_Array renames + Container.Elements.EA (Index_Subtype); + + Tgt : Elements_Array renames E.EA (Index_Subtype); + + begin + Tgt := Src; + + exception + when others => + Free (E); + raise; + end; + + -- We have successfully copied the existing elements onto the new + -- internal array, so now we can attempt to deallocate the old one. + + declare + X : Elements_Access := Container.Elements; + + begin + -- First we isolate the old internal array, and replace it in the + -- container with the new internal array. + + Container.Elements := E; + + -- Container invariants have been restored, so it is now safe to + -- attempt to deallocate the old internal array. + + Free (X); + end; + end; + end Reserve_Capacity; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out Vector) is + begin + if Container.Length <= 1 then + return; + end if; + + -- The exception behavior for the vector container must match that for + -- the list container, so we check for cursor tampering here (which will + -- catch more things) instead of for element tampering (which will catch + -- fewer things). It's true that the elements of this vector container + -- could be safely moved around while (say) an iteration is taking place + -- (iteration only increments the busy counter), and so technically + -- all we would need here is a test for element tampering (indicated + -- by the lock counter), that's simply an artifact of our array-based + -- implementation. Logically Reverse_Elements requires a check for + -- cursor tampering. + + TC_Check (Container.TC); + + declare + K : Index_Type; + J : Index_Type; + E : Elements_Type renames Container.Elements.all; + + begin + K := Index_Type'First; + J := Container.Last; + while K < J loop + declare + EK : constant Element_Type := E.EA (K); + begin + E.EA (K) := E.EA (J); + E.EA (J) := EK; + end; + + K := K + 1; + J := J - 1; + end loop; + end; + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Last : Index_Type'Base; + + begin + if Checks and then Position.Container /= null + and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + + Last := + (if Position.Container = null or else Position.Index > Container.Last + then Container.Last + else Position.Index); + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock : With_Lock (Container.TC'Unrestricted_Access); + begin + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements.EA (Indx) = Item then + return Cursor'(Container'Unrestricted_Access, Indx); + end if; + end loop; + + return No_Element; + end; + end Reverse_Find; + + ------------------------ + -- Reverse_Find_Index -- + ------------------------ + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index + is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Container.TC'Unrestricted_Access); + + Last : constant Index_Type'Base := + Index_Type'Min (Container.Last, Index); + + begin + for Indx in reverse Index_Type'First .. Last loop + if Container.Elements.EA (Indx) = Item then + return Indx; + end if; + end loop; + + return No_Index; + end Reverse_Find_Index; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)) + is + Busy : With_Busy (Container.TC'Unrestricted_Access); + begin + for Indx in reverse Index_Type'First .. Container.Last loop + Process (Cursor'(Container'Unrestricted_Access, Indx)); + end loop; + end Reverse_Iterate; + + ---------------- + -- Set_Length -- + ---------------- + + procedure Set_Length (Container : in out Vector; Length : Count_Type) is + Count : constant Count_Type'Base := Container.Length - Length; + + begin + -- Set_Length allows the user to set the length explicitly, instead + -- of implicitly as a side-effect of deletion or insertion. If the + -- requested length is less than the current length, this is equivalent + -- to deleting items from the back end of the vector. If the requested + -- length is greater than the current length, then this is equivalent + -- to inserting "space" (nonce items) at the end. + + if Count >= 0 then + Container.Delete_Last (Count); + + elsif Checks and then Container.Last >= Index_Type'Last then + raise Constraint_Error with "vector is already at its maximum length"; + + else + Container.Insert_Space (Container.Last + 1, -Count); + end if; + end Set_Length; + + ---------- + -- Swap -- + ---------- + + procedure Swap (Container : in out Vector; I, J : Index_Type) is + begin + if Checks then + if I > Container.Last then + raise Constraint_Error with "I index is out of range"; + end if; + + if J > Container.Last then + raise Constraint_Error with "J index is out of range"; + end if; + end if; + + if I = J then + return; + end if; + + TE_Check (Container.TC); + + declare + EI_Copy : constant Element_Type := Container.Elements.EA (I); + begin + Container.Elements.EA (I) := Container.Elements.EA (J); + Container.Elements.EA (J) := EI_Copy; + end; + end Swap; + + procedure Swap (Container : in out Vector; I, J : Cursor) is + begin + if Checks then + if I.Container = null then + raise Constraint_Error with "I cursor has no element"; + + elsif J.Container = null then + raise Constraint_Error with "J cursor has no element"; + + elsif I.Container /= Container'Unrestricted_Access then + raise Program_Error with "I cursor denotes wrong container"; + + elsif J.Container /= Container'Unrestricted_Access then + raise Program_Error with "J cursor denotes wrong container"; + end if; + end if; + + Swap (Container, I.Index, J.Index); + end Swap; + + --------------- + -- To_Cursor -- + --------------- + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor + is + begin + if Index not in Index_Type'First .. Container.Last then + return No_Element; + else + return (Container'Unrestricted_Access, Index); + end if; + end To_Cursor; + + -------------- + -- To_Index -- + -------------- + + function To_Index (Position : Cursor) return Extended_Index is + begin + if Position.Container = null then + return No_Index; + elsif Position.Index <= Position.Container.Last then + return Position.Index; + else + return No_Index; + end if; + end To_Index; + + --------------- + -- To_Vector -- + --------------- + + function To_Vector (Length : Count_Type) return Vector is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type (Last); + + return Vector'(Controlled with Elements, Last, TC => <>); + end To_Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector + is + Index : Count_Type'Base; + Last : Index_Type'Base; + Elements : Elements_Access; + + begin + if Length = 0 then + return Empty_Vector; + end if; + + -- We create a vector object with a capacity that matches the specified + -- Length, but we do not allow the vector capacity (the length of the + -- internal array) to exceed the number of values in Index_Type'Range + -- (otherwise, there would be no way to refer to those components via an + -- index). We must therefore check whether the specified Length would + -- create a Last index value greater than Index_Type'Last. + + if Index_Type'Base'Last >= Count_Type_Last then + + -- We perform a two-part test. First we determine whether the + -- computed Last value lies in the base range of the type, and then + -- determine whether it lies in the range of the index (sub)type. + + -- Last must satisfy this relation: + -- First + Length - 1 <= Last + -- We regroup terms: + -- First - 1 <= Last - Length + -- Which can rewrite as: + -- No_Index <= Last - Length + + if Checks and then + Index_Type'Base'Last - Index_Type'Base (Length) < No_Index + then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We now know that the computed value of Last is within the base + -- range of the type, so it is safe to compute its value: + + Last := No_Index + Index_Type'Base (Length); + + -- Finally we test whether the value is within the range of the + -- generic actual index subtype: + + if Checks and then Last > Index_Type'Last then + raise Constraint_Error with "Length is out of range"; + end if; + + elsif Index_Type'First <= 0 then + + -- Here we can compute Last directly, in the normal way. We know that + -- No_Index is less than 0, so there is no danger of overflow when + -- adding the (positive) value of Length. + + Index := Count_Type'Base (No_Index) + Length; -- same value as V.Last + + if Checks and then Index > Count_Type'Base (Index_Type'Last) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We know that the computed value (having type Count_Type) of Last + -- is within the range of the generic actual index subtype, so it is + -- safe to convert to Index_Type: + + Last := Index_Type'Base (Index); + + else + -- Here Index_Type'First (and Index_Type'Last) is positive, so we + -- must test the length indirectly (by working backwards from the + -- largest possible value of Last), in order to prevent overflow. + + Index := Count_Type'Base (Index_Type'Last) - Length; -- No_Index + + if Checks and then Index < Count_Type'Base (No_Index) then + raise Constraint_Error with "Length is out of range"; + end if; + + -- We have determined that the value of Length would not create a + -- Last index value outside of the range of Index_Type, so we can now + -- safely compute its value. + + Last := Index_Type'Base (Count_Type'Base (No_Index) + Length); + end if; + + Elements := new Elements_Type'(Last, EA => (others => New_Item)); + + return (Controlled with Elements, Last, TC => <>); + end To_Vector; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)) + is + Lock : With_Lock (Container.TC'Unchecked_Access); + begin + if Checks and then Index > Container.Last then + raise Constraint_Error with "Index is out of range"; + end if; + + Process (Container.Elements.EA (Index)); + end Update_Element; + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Checks then + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + elsif Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor denotes wrong container"; + end if; + end if; + + Update_Element (Container, Position.Index, Process); + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector) + is + begin + Count_Type'Base'Write (Stream, Length (Container)); + + for J in Index_Type'First .. Container.Last loop + Element_Type'Write (Stream, Container.Elements.EA (J)); + end loop; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor) + is + begin + raise Program_Error with "attempt to stream vector cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Vectors; diff --git a/gcc/ada/libgnat/a-convec.ads b/gcc/ada/libgnat/a-convec.ads new file mode 100644 index 0000000..8e762ca --- /dev/null +++ b/gcc/ada/libgnat/a-convec.ads @@ -0,0 +1,518 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . V E C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Index_Type is range <>; + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Vectors is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + subtype Extended_Index is Index_Type'Base + range Index_Type'First - 1 .. + Index_Type'Min (Index_Type'Base'Last - 1, Index_Type'Last) + 1; + + No_Index : constant Extended_Index := Extended_Index'First; + + type Vector is tagged private + with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + pragma Preelaborable_Initialization (Vector); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package Vector_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + Empty_Vector : constant Vector; + + overriding function "=" (Left, Right : Vector) return Boolean; + + function To_Vector (Length : Count_Type) return Vector; + + function To_Vector + (New_Item : Element_Type; + Length : Count_Type) return Vector; + + function "&" (Left, Right : Vector) return Vector; + + function "&" (Left : Vector; Right : Element_Type) return Vector; + + function "&" (Left : Element_Type; Right : Vector) return Vector; + + function "&" (Left, Right : Element_Type) return Vector; + + function Capacity (Container : Vector) return Count_Type; + + procedure Reserve_Capacity + (Container : in out Vector; + Capacity : Count_Type); + + function Length (Container : Vector) return Count_Type; + + procedure Set_Length + (Container : in out Vector; + Length : Count_Type); + + function Is_Empty (Container : Vector) return Boolean; + + procedure Clear (Container : in out Vector); + + function To_Cursor + (Container : Vector; + Index : Extended_Index) return Cursor; + + function To_Index (Position : Cursor) return Extended_Index; + + function Element + (Container : Vector; + Index : Index_Type) return Element_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Vector; + Index : Index_Type; + New_Item : Element_Type); + + procedure Replace_Element + (Container : in out Vector; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Container : Vector; + Index : Index_Type; + Process : not null access procedure (Element : Element_Type)); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Index : Index_Type; + Process : not null access procedure (Element : in out Element_Type)); + + procedure Update_Element + (Container : in out Vector; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Vector; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Vector; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + function Constant_Reference + (Container : aliased Vector; + Index : Index_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Vector; + Index : Index_Type) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Vector; Source : Vector); + + function Copy (Source : Vector; Capacity : Count_Type := 0) return Vector; + + procedure Move (Target : in out Vector; Source : in out Vector); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Vector; + Position : out Cursor); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Prepend + (Container : in out Vector; + New_Item : Vector); + + procedure Prepend + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Append + (Container : in out Vector; + New_Item : Vector); + + procedure Append + (Container : in out Vector; + New_Item : Element_Type; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Extended_Index; + Count : Count_Type := 1); + + procedure Insert_Space + (Container : in out Vector; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Index : Extended_Index; + Count : Count_Type := 1); + + procedure Delete + (Container : in out Vector; + Position : in out Cursor; + Count : Count_Type := 1); + + procedure Delete_First + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Delete_Last + (Container : in out Vector; + Count : Count_Type := 1); + + procedure Reverse_Elements (Container : in out Vector); + + procedure Swap (Container : in out Vector; I, J : Index_Type); + + procedure Swap (Container : in out Vector; I, J : Cursor); + + function First_Index (Container : Vector) return Index_Type; + + function First (Container : Vector) return Cursor; + + function First_Element (Container : Vector) return Element_Type; + + function Last_Index (Container : Vector) return Extended_Index; + + function Last (Container : Vector) return Cursor; + + function Last_Element (Container : Vector) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'First) return Extended_Index; + + function Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Reverse_Find_Index + (Container : Vector; + Item : Element_Type; + Index : Index_Type := Index_Type'Last) return Extended_Index; + + function Reverse_Find + (Container : Vector; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + + function Contains + (Container : Vector; + Item : Element_Type) return Boolean; + + procedure Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Vector; + Process : not null access procedure (Position : Cursor)); + + function Iterate (Container : Vector) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class; + + function Iterate (Container : Vector; Start : Cursor) + return Vector_Iterator_Interfaces.Reversible_Iterator'Class; + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : Vector) return Boolean; + + procedure Sort (Container : in out Vector); + + procedure Merge (Target : in out Vector; Source : in out Vector); + + end Generic_Sorting; + +private + + pragma Inline (Append); + pragma Inline (First_Index); + pragma Inline (Last_Index); + pragma Inline (Element); + pragma Inline (First_Element); + pragma Inline (Last_Element); + pragma Inline (Query_Element); + pragma Inline (Update_Element); + pragma Inline (Replace_Element); + pragma Inline (Is_Empty); + pragma Inline (Contains); + pragma Inline (Next); + pragma Inline (Previous); + + use Ada.Containers.Helpers; + package Implementation is new Generic_Implementation; + use Implementation; + + type Elements_Array is array (Index_Type range <>) of aliased Element_Type; + function "=" (L, R : Elements_Array) return Boolean is abstract; + + type Elements_Type (Last : Extended_Index) is limited record + EA : Elements_Array (Index_Type'First .. Last); + end record; + + type Elements_Access is access all Elements_Type; + + use Finalization; + use Streams; + + type Vector is new Controlled with record + Elements : Elements_Access := null; + Last : Extended_Index := No_Index; + TC : aliased Tamper_Counts; + end record; + + overriding procedure Adjust (Container : in out Vector); + overriding procedure Finalize (Container : in out Vector); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Vector); + + for Vector'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Vector); + + for Vector'Read use Read; + + type Vector_Access is access all Vector; + for Vector_Access'Storage_Size use 0; + + type Cursor is record + Container : Vector_Access; + Index : Index_Type := Index_Type'First; + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Position : out Cursor); + + for Cursor'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Position : Cursor); + + for Cursor'Write use Write; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Exp_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + No_Element : constant Cursor := Cursor'(null, Index_Type'First); + + Empty_Vector : constant Vector := (Controlled with others => <>); + + type Iterator is new Limited_Controlled and + Vector_Iterator_Interfaces.Reversible_Iterator with + record + Container : Vector_Access; + Index : Index_Type'Base; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Vectors; diff --git a/gcc/ada/libgnat/a-coorma.adb b/gcc/ada/libgnat/a-coorma.adb new file mode 100644 index 0000000..84f6327 --- /dev/null +++ b/gcc/ada/libgnat/a-coorma.adb @@ -0,0 +1,1556 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with System; use type System.Address; + +package body Ada.Containers.Ordered_Maps is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + procedure Free (X : in out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; + + package Key_Ops is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor of ""<"" is bad"); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor of ""<"" is bad"); + + return Left.Node.Key < Right.Node.Key; + end "<"; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor of ""<"" is bad"); + + return Left.Node.Key < Right; + end "<"; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of ""<"" equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor of ""<"" is bad"); + + return Left < Right.Node.Key; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Map) return Boolean is + begin + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor of "">"" is bad"); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor of "">"" is bad"); + + return Right.Node.Key < Left.Node.Key; + end ">"; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "Left cursor of "">"" is bad"); + + return Right < Left.Node.Key; + end ">"; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor of "">"" equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "Right cursor of "">"" is bad"); + + return Right.Node.Key < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust is + new Tree_Operations.Generic_Adjust (Copy_Tree); + + procedure Adjust (Container : in out Map) is + begin + Adjust (Container.Tree); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Map; Source : Map) is + procedure Insert_Item (Node : Node_Access); + pragma Inline (Insert_Item); + + procedure Insert_Items is + new Tree_Operations.Generic_Iteration (Insert_Item); + + ----------------- + -- Insert_Item -- + ----------------- + + procedure Insert_Item (Node : Node_Access) is + begin + Target.Insert (Key => Node.Key, New_Item => Node.Element); + end Insert_Item; + + -- Start of processing for Assign + + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Insert_Items (Source.Tree); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree); + + procedure Clear (Container : in out Map) is + begin + Clear (Container.Tree); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in Constant_Reference is bad"); + + declare + T : Tree_Type renames Position.Container.all.Tree; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Map; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Map) return Map is + begin + return Target : Map do + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Target : constant Node_Access := + new Node_Type'(Color => Source.Color, + Key => Source.Key, + Element => Source.Element, + Parent => null, + Left => null, + Right => null); + begin + return Target; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Map; Position : in out Cursor) is + Tree : Tree_Type renames Container.Tree; + + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Delete equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Delete designates wrong map"; + end if; + + pragma Assert (Vet (Tree, Position.Node), + "Position cursor of Delete is bad"); + + Tree_Operations.Delete_Node_Sans_Free (Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then X = null then + raise Constraint_Error with "key not in map"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Map) is + X : Node_Access := Container.Tree.First; + + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Map) is + X : Node_Access := Container.Tree.Last; + + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Element equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of function Element is bad"); + + return Position.Node.Element; + end Element; + + function Element (Container : Map; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + return Node.Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Map; Key : Key_Type) is + X : Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.Tree.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin + if T.First = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, T.First); + end if; + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + begin + if Checks and then T.First = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.First.Element; + end First_Element; + + --------------- + -- First_Key -- + --------------- + + function First_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + begin + if Checks and then T.First = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.First.Key; + end First_Key; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Map; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Ops.Floor (Container.Tree, Key); + begin + if Node = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, Node); + end if; + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X = null then + return; + end if; + + X.Parent := X; + X.Left := X; + X.Right := X; + + Deallocate (X); + end Free; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.Tree.TC); + + Position.Node.Key := Key; + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return new Node_Type'(Key => Key, + Element => New_Item, + Color => Red_Black_Trees.Red, + Parent => null, + Left => null, + Right => null); + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, Key, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with "key already in map"; + end if; + end Insert; + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Key_Ops.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Key_Ops.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return new Node_Type'(Key => Key, + Element => <>, + Color => Red_Black_Trees.Red, + Parent => null, + Left => null, + Right => null); + end New_Node; + + -- Start of processing for Insert + + begin + Insert_Sans_Hint + (Container.Tree, + Key, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Map) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node + (L, R : Node_Access) return Boolean + is + begin + if L.Key < R.Key then + return False; + elsif R.Key < L.Key then + return False; + else + return L.Element = R.Element; + end if; + end Is_Equal_Node_Node; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + -- Left > Right same as Right < Left + + return Right.Key < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Key; + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (Container.Tree); + end Iterate; + + function Iterate + (Container : Map) return Map_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a + -- complete iterator, meaning that the iteration starts from the + -- (logical) beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null) + do + Busy (Container.Tree.TC'Unrestricted_Access.all); + end return; + end Iterate; + + function Iterate (Container : Map; Start : Cursor) + return Map_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this + -- is a partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this + -- is a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node) + do + Busy (Container.Tree.TC'Unrestricted_Access.all); + end return; + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of function Key equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of function Key is bad"); + + return Position.Node.Key; + end Key; + + ---------- + -- Last -- + ---------- + + function Last (Container : Map) return Cursor is + T : Tree_Type renames Container.Tree; + begin + if T.Last = null then + return No_Element; + else + return Cursor'(Container'Unrestricted_Access, T.Last); + end if; + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Map) return Element_Type is + T : Tree_Type renames Container.Tree; + begin + if Checks and then T.Last = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.Last.Element; + end Last_Element; + + -------------- + -- Last_Key -- + -------------- + + function Last_Key (Container : Map) return Key_Type is + T : Tree_Type renames Container.Tree; + begin + if Checks and then T.Last = null then + raise Constraint_Error with "map is empty"; + end if; + + return T.Last.Key; + end Last_Key; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Map) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move is + new Tree_Operations.Generic_Move (Clear); + + procedure Move (Target : in out Map; Source : in out Map) is + begin + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of Next is bad"); + + declare + Node : constant Node_Access := Tree_Operations.Next (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + function Next + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong map"; + end if; + + return Next (Position); + end Next; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of Previous is bad"); + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + function Previous + (Object : Iterator; + Position : Cursor) return Cursor + is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong map"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Query_Element equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "Position cursor of Query_Element is bad"); + + declare + T : Tree_Type renames Position.Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + begin + Process (K, E); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map) + is + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + begin + Key_Type'Read (Stream, Node.Key); + Element_Type'Read (Stream, Node.Element); + return Node; + exception + when others => + Free (Node); + raise; + end Read_Node; + + -- Start of processing for Read + + begin + Read (Stream, Container.Tree); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------- + -- Reference -- + --------------- + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with + "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor in function Reference is bad"); + + declare + T : Tree_Type renames Position.Container.all.Tree; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + declare + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + TC : constant Tamper_Counts_Access := + T.TC'Unrestricted_Access; + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Reference; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in map"; + end if; + + TE_Check (Container.Tree.TC); + + Node.Key := Key; + Node.Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Replace_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Replace_Element designates wrong map"; + end if; + + TE_Check (Container.Tree.TC); + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor of Replace_Element is bad"); + + Position.Node.Element := New_Item; + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + Busy : With_Busy (Container.Tree.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (Container.Tree); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color + (Node : Node_Access; + Color : Color_Type) + is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access procedure (Key : Key_Type; + Element : in out Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor of Update_Element equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor of Update_Element designates wrong map"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "Position cursor of Update_Element is bad"); + + declare + T : Tree_Type renames Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + K : Key_Type renames Position.Node.Key; + E : Element_Type renames Position.Node.Element; + begin + Process (K, E); + end; + end Update_Element; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Key_Type'Write (Stream, Node.Key); + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write (Stream, Container.Tree); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream map cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/libgnat/a-coorma.ads b/gcc/ada/libgnat/a-coorma.ads new file mode 100644 index 0000000..1e3e6f0 --- /dev/null +++ b/gcc/ada/libgnat/a-coorma.ads @@ -0,0 +1,392 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +private with Ada.Containers.Red_Black_Trees; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Key_Type is private; + type Element_Type is private; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Ordered_Maps is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + type Map is tagged private with + Constant_Indexing => Constant_Reference, + Variable_Indexing => Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Map : constant Map; + + No_Element : constant Cursor; + + function Has_Element (Position : Cursor) return Boolean; + + package Map_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Map) return Boolean; + + function Length (Container : Map) return Count_Type; + + function Is_Empty (Container : Map) return Boolean; + + procedure Clear (Container : in out Map); + + function Key (Position : Cursor) return Key_Type; + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Map; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : Element_Type)); + + procedure Update_Element + (Container : in out Map; + Position : Cursor; + Process : not null access + procedure (Key : Key_Type; Element : in out Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with + Implicit_Dereference => Element; + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Map; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Position : Cursor) return Reference_Type; + pragma Inline (Reference); + + function Constant_Reference + (Container : aliased Map; + Key : Key_Type) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + function Reference + (Container : aliased in out Map; + Key : Key_Type) return Reference_Type; + pragma Inline (Reference); + + procedure Assign (Target : in out Map; Source : Map); + + function Copy (Source : Map) return Map; + + procedure Move (Target : in out Map; Source : in out Map); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Include + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Replace + (Container : in out Map; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Key : Key_Type); + + procedure Delete (Container : in out Map; Position : in out Cursor); + + procedure Delete_First (Container : in out Map); + + procedure Delete_Last (Container : in out Map); + + function First (Container : Map) return Cursor; + + function First_Element (Container : Map) return Element_Type; + + function First_Key (Container : Map) return Key_Type; + + function Last (Container : Map) return Cursor; + + function Last_Element (Container : Map) return Element_Type; + + function Last_Key (Container : Map) return Key_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find (Container : Map; Key : Key_Type) return Cursor; + + function Element (Container : Map; Key : Key_Type) return Element_Type; + + function Floor (Container : Map; Key : Key_Type) return Cursor; + + function Ceiling (Container : Map; Key : Key_Type) return Cursor; + + function Contains (Container : Map; Key : Key_Type) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Key_Type) return Boolean; + + function ">" (Left : Cursor; Right : Key_Type) return Boolean; + + function "<" (Left : Key_Type; Right : Cursor) return Boolean; + + function ">" (Left : Key_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Map; + Process : not null access procedure (Position : Cursor)); + + -- The map container supports iteration in both the forward and reverse + -- directions, hence these constructor functions return an object that + -- supports the Reversible_Iterator interface. + + function Iterate + (Container : Map) + return Map_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : Map; + Start : Cursor) + return Map_Iterator_Interfaces.Reversible_Iterator'class; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Key : Key_Type; + Element : aliased Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Type, Node_Access); + + type Map is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; + end record; + + overriding procedure Adjust (Container : in out Map); + + overriding procedure Finalize (Container : in out Map) renames Clear; + + use Red_Black_Trees; + use Tree_Types, Tree_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Map); + + for Map'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Map); + + for Map'Read use Read; + + type Map_Access is access all Map; + for Map_Access'Storage_Size use 0; + + type Cursor is record + Container : Map_Access; + Node : Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + type Reference_Type + (Element : not null access Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Map : constant Map := (Controlled with others => <>); + + No_Element : constant Cursor := Cursor'(null, null); + + type Iterator is new Limited_Controlled and + Map_Iterator_Interfaces.Reversible_Iterator with + record + Container : Map_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Ordered_Maps; diff --git a/gcc/ada/libgnat/a-coormu.adb b/gcc/ada/libgnat/a-coormu.adb new file mode 100644 index 0000000..b252d13 --- /dev/null +++ b/gcc/ada/libgnat/a-coormu.adb @@ -0,0 +1,1895 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Ordered_Multisets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------------- + -- Node Access Subprograms -- + ----------------------------- + + -- These subprograms provide a functional interface to access fields + -- of a node, and a procedural interface for modifying these values. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + procedure Free (X : in out Node_Access); + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left.Node.Element < Right.Node.Element; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) + return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + return Left.Node.Element < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) + return Boolean is + begin + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left < Right.Node.Element; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + -- L > R same as R < L + + return Right.Node.Element < Left.Node.Element; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) + return Boolean is + begin + if Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + return Right < Left.Node.Element; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) + return Boolean is + begin + if Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + return Right.Node.Element < Left; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); + + procedure Adjust (Container : in out Set) is + begin + Adjust (Container.Tree); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear is + new Tree_Operations.Generic_Clear (Delete_Tree); + + procedure Clear (Container : in out Set) is + begin + Clear (Container.Tree); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + -- Note: in predefined container units, the creation of a reference + -- increments the busy bit of the container, and its finalization + -- decrements it. In the absence of control machinery, this tampering + -- protection is missing. + + declare + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + pragma Unreferenced (T); + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Unrestricted_Access, + Control => (Container => Container'Unrestricted_Access)) + do + null; + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Item : Element_Type) return Boolean is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Target : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => Source.Element); + begin + return Target; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error with + "attempt to delete element not in set"; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + + Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + + Position.Container := null; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; + + begin + if X = null then + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + + return Position.Node.Element; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + if L.Element < R.Element then + return False; + elsif R.Element < L.Element then + return False; + else + return True; + end if; + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Element_Keys.Ceiling (Tree, Item); + Done : constant Node_Access := Element_Keys.Upper_Bound (Tree, Item); + X : Node_Access; + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + Unbusy (Object.Container.Tree.TC); + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + if Container.Tree.First = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Tree.First); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + if Container.Tree.First = null then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Tree.First.Element; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Floor (Container.Tree, Item); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + begin + if X /= null then + X.Parent := X; + X.Left := X; + X.Right := X; + + Deallocate (X); + end if; + end Free; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local_Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := + Key_Keys.Ceiling (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Ceiling; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + + begin + if Node = Done then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + + exit when Node = Done; + end loop; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + if Node = null then + raise Constraint_Error with "key not in set"; + end if; + + return Node.Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + if Left < Right + or else Right < Left + then + return False; + else + return True; + end if; + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + Tree : Tree_Type renames Container.Tree; + Node : Node_Access := Key_Keys.Ceiling (Tree, Key); + Done : constant Node_Access := Key_Keys.Upper_Bound (Tree, Key); + X : Node_Access; + + begin + while Node /= Done loop + X := Node; + Node := Tree_Operations.Next (Node); + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end loop; + end Exclude; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); + + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Node); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Key (Right.Element) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean is + begin + return Left < Key (Right.Element); + end Is_Less_Key_Node; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Key_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T, Key); + end Iterate; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + + return Key (Position.Node.Element); + end Key; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Key_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T, Key); + end Reverse_Iterate; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + Node : constant Node_Access := Position.Node; + + begin + if Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Tree, Node), + "bad cursor in Update_Element"); + + declare + E : Element_Type renames Node.Element; + K : constant Key_Type := Key (E); + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Process (E); + + if Equivalent_Keys (Left => K, Right => Key (E)) then + return; + end if; + end; + + -- Delete_Node checks busy-bit + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); + + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Color := Red_Black_Trees.Red; + Node.Parent := null; + Node.Left := null; + Node.Right := null; + + return Node; + end New_Node; + + Result : Node_Access; + + -- Start of processing for Insert_New_Item + + begin + Unconditional_Insert + (Tree => Tree, + Key => Node.Element, + Node => Result); + + pragma Assert (Result = Node); + end Insert_New_Item; + end Update_Element; + + end Generic_Keys; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + pragma Unreferenced (Position); + begin + Insert (Container, New_Item, Position); + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor) + is + begin + Insert_Sans_Hint (Container.Tree, New_Item, Position.Node); + Position.Container := Container'Unrestricted_Access; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red_Black_Trees.Red, + Element => New_Item); + begin + return Node; + end New_Node; + + -- Start of processing for Insert_Sans_Hint + + begin + Unconditional_Insert (Tree, New_Item, Node); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Unconditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => Src_Node.Element); + begin + return Node; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element, + Dst_Node); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element = R.Element; + end Is_Equal_Node_Node; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + -- e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T); + end Iterate; + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Element_Keys.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T, Item); + end Iterate; + + function Iterate (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'Class + is + S : constant Set_Access := Container'Unrestricted_Access; + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + return It : constant Iterator := (Limited_Controlled with S, null) do + Busy (S.Tree.TC); + end return; + end Iterate; + + function Iterate (Container : Set; Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'Class + is + S : constant Set_Access := Container'Unrestricted_Access; + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + return It : constant Iterator := + (Limited_Controlled with S, Start.Node) + do + Busy (S.Tree.TC); + end return; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + if Container.Tree.Last = null then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Tree.Last); + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Container.Tree.Last = null then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Tree.Last.Element; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move is + new Tree_Operations.Generic_Move (Clear); + + procedure Move (Target : in out Set; Source : in out Set) is + begin + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) + is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + + declare + Node : constant Node_Access := Tree_Operations.Next (Position.Node); + begin + if Node = null then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) + is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + + return Previous (Position); + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); + + declare + T : Tree_Type renames Position.Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + Process (Position.Node.Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + begin + Element_Type'Read (Stream, Node.Element); + return Node; + exception + when others => + Free (Node); -- Note that Free deallocates elem too + raise; + end Read_Node; + + -- Start of processing for Read + + begin + Read (Stream, Container.Tree); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + begin + if Item < Node.Element + or else Node.Element < Item + then + null; + else + TE_Check (Tree.TC); + + Node.Element := Item; + return; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Insert_New_Item : declare + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Unconditional_Insert is + new Element_Keys.Generic_Unconditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := Item; + Node.Color := Red_Black_Trees.Red; + Node.Parent := null; + Node.Left := null; + Node.Right := null; + + return Node; + end New_Node; + + Result : Node_Access; + + -- Start of processing for Insert_New_Item + + begin + Unconditional_Insert + (Tree => Tree, + Key => Item, + Node => Result); + + pragma Assert (Result = Node); + end Insert_New_Item; + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container.Tree, Position.Node, New_Item); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T); + end Reverse_Iterate; + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Element_Keys.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T, Item); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + pragma Unreferenced (Node); + begin + Insert_Sans_Hint (Tree, New_Item, Node); + return Set'(Controlled with Tree); + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := Set_Ops.Union (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write (Stream, Container.Tree); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; +end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/libgnat/a-coormu.ads b/gcc/ada/libgnat/a-coormu.ads new file mode 100644 index 0000000..bc91e27 --- /dev/null +++ b/gcc/ada/libgnat/a-coormu.ads @@ -0,0 +1,570 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . O R D E R E D _ M U L T I S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- The ordered multiset container is similar to the ordered set, but with the +-- difference that multiple equivalent elements are allowed. It also provides +-- additional operations, to iterate over items that are equivalent. + +private with Ada.Containers.Red_Black_Trees; +private with Ada.Finalization; +private with Ada.Streams; +with Ada.Iterator_Interfaces; + +generic + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Ordered_Multisets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. + + type Set is tagged private + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_Set : constant Set; + -- The default value for set objects declared without an explicit + -- initialization expression. + + No_Element : constant Cursor; + -- The default value for cursor objects declared without an explicit + -- initialization expression. + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + -- If Left denotes the same set object as Right, then equality returns + -- True. If the length of Left is different from the length of Right, then + -- it returns False. Otherwise, set equality iterates over Left and Right, + -- comparing the element of Left to the element of Right using the equality + -- operator for elements. If the elements compare False, then the iteration + -- terminates and set equality returns False. Otherwise, if all elements + -- compare True, then set equality returns True. + + function Equivalent_Sets (Left, Right : Set) return Boolean; + -- Similar to set equality, but with the difference that elements are + -- compared for equivalence instead of equality. + + function To_Set (New_Item : Element_Type) return Set; + -- Constructs a set object with New_Item as its single element + + function Length (Container : Set) return Count_Type; + -- Returns the total number of elements in Container + + function Is_Empty (Container : Set) return Boolean; + -- Returns True if Container.Length is 0 + + procedure Clear (Container : in out Set); + -- Deletes all elements from Container + + function Element (Position : Cursor) return Element_Type; + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, function Element returns the element designed by Position. + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. If New_Item is equivalent to the element + -- designated by Position, then if Container is locked (element tampering + -- has been attempted), Program_Error is raised; otherwise, the element + -- designated by Position is assigned the value of New_Item. If New_Item is + -- not equivalent to the element designated by Position, then if the + -- container is busy (cursor tampering has been attempted), Program_Error + -- is raised; otherwise, the element designed by Position is assigned the + -- value of New_Item, and the node is moved to its new position (in + -- canonical insertion order). + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- If Position equals No_Element, then Constraint_Error is + -- raised. Otherwise, it calls Process with the element designated by + -- Position as the parameter. This call locks the container, so attempts to + -- change the value of the element while Process is executing (to "tamper + -- with elements") will raise Program_Error. + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is private + with Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If either Target or Source is busy (cursor tampering is + -- attempted), then it raises Program_Error. Otherwise, Target is cleared, + -- and the nodes from Source are moved (not copied) to Target (so Source + -- becomes empty). + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor); + -- Insert adds New_Item to Container, and returns cursor Position + -- designating the newly inserted node. The node is inserted after any + -- existing elements less than or equivalent to New_Item (and before any + -- elements greater than New_Item). Note that the issue of where the new + -- node is inserted relative to equivalent elements does not arise for + -- unique-key containers, since in that case the insertion would simply + -- fail. For a multiple-key container (the case here), insertion always + -- succeeds, and is defined such that the new item is positioned after any + -- equivalent elements already in the container. + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + -- Inserts New_Item in Container, but does not return a cursor designating + -- the newly-inserted node. + +-- TODO: include Replace too??? +-- +-- procedure Replace +-- (Container : in out Set; +-- New_Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item + + procedure Delete + (Container : in out Set; + Item : Element_Type); + -- Deletes from Container all of the elements equivalent to Item. If there + -- are no elements equivalent to Item, then it raises Constraint_Error. + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set different from Container, then + -- Program_Error is raised. Otherwise, the node designated by Position is + -- removed from Container, and Position is set to No_Element. + + procedure Delete_First (Container : in out Set); + -- Removes the first node from Container + + procedure Delete_Last (Container : in out Set); + -- Removes the last node from Container + + procedure Union (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), the Program_Error is + -- raised. Otherwise, it inserts each element of Source into + -- Target. Elements are inserted in the canonical order for multisets, such + -- that the elements from Source are inserted after equivalent elements + -- already in Target. + + function Union (Left, Right : Set) return Set; + -- Returns a set comprising the all elements from Left and all of the + -- elements from Right. The elements from Right follow the equivalent + -- elements from Left. + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + -- If Target denotes the same object as Source, the operation does + -- nothing. If Target is busy (cursor tampering is attempted), + -- Program_Error is raised. Otherwise, the elements in Target having no + -- equivalent element in Source are deleted from Target. + + function Intersection (Left, Right : Set) return Set; + -- If Left denotes the same object as Right, then the function returns a + -- copy of Left. Otherwise, it returns a set comprising the equivalent + -- elements from both Left and Right. Items are inserted in the result set + -- in canonical order, such that the elements from Left precede the + -- equivalent elements from Right. + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + -- If Target is busy (cursor tampering is attempted), then Program_Error is + -- raised. Otherwise, the elements in Target that are equivalent to + -- elements in Source are deleted from Target. + + function Difference (Left, Right : Set) return Set; + -- Returns a set comprising the elements from Left that have no equivalent + -- element in Right. + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + -- If Target is busy, then Program_Error is raised. Otherwise, the elements + -- in Target equivalent to elements in Source are deleted from Target, and + -- the elements in Source not equivalent to elements in Target are inserted + -- into Target. + + function Symmetric_Difference (Left, Right : Set) return Set; + -- Returns a set comprising the union of the elements from Target having no + -- equivalent in Source, and the elements of Source having no equivalent in + -- Target. + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + -- Returns True if Left contains an element equivalent to an element of + -- Right. + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + -- Returns True if every element in Subset has an equivalent element in + -- Of_Set. + + function First (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the smallest element. + + function First_Element (Container : Set) return Element_Type; + -- Equivalent to Element (First (Container)) + + function Last (Container : Set) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the largest element. + + function Last_Element (Container : Set) return Element_Type; + -- Equivalent to Element (Last (Container)) + + function Next (Position : Cursor) return Cursor; + -- If Position equals No_Element or Last (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately follows (as per the insertion order) the node designated by + -- Position. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Previous (Position : Cursor) return Cursor; + -- If Position equals No_Element or First (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately precedes (as per the insertion order) the node designated by + -- Position. + + procedure Previous (Position : in out Cursor); + -- Equivalent to Position := Previous (Position) + + function Find (Container : Set; Item : Element_Type) return Cursor; + -- Returns a cursor designating the first element in Container equivalent + -- to Item. If there is no equivalent element, it returns No_Element. + + function Floor (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements in Container, it returns a cursor designating the + -- first equivalent element. Otherwise, it returns a cursor designating the + -- largest element less than Item, or No_Element if all elements are + -- greater than Item. + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to elements of Container, it returns a cursor designating the + -- last equivalent element. Otherwise, it returns a cursor designating the + -- smallest element greater than Item, or No_Element if all elements are + -- less than Item. + + function Contains (Container : Set; Item : Element_Type) return Boolean; + -- Equivalent to Container.Find (Item) /= No_Element + + function "<" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Left) < Element (Right) + + function ">" (Left, Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Element (Left) + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Element (Left) < Right + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + -- Equivalent to Right < Element (Left) + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Left < Element (Right) + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + -- Equivalent to Element (Right) < Left + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.First to Container.Last. + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.Last to Container.First. + + procedure Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Floor (Item) to Container.Ceiling (Item). + + procedure Reverse_Iterate + (Container : Set; + Item : Element_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to Item, + -- in order from Container.Ceiling (Item) to Container.Floor (Item). + + function Iterate + (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : Set; + Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + -- Returns False if Left is less than Right, or Right is less than Left; + -- otherwise, it returns True. + + function Key (Position : Cursor) return Key_Type; + -- Equivalent to Key (Element (Position)) + + function Element (Container : Set; Key : Key_Type) return Element_Type; + -- Equivalent to Element (Find (Container, Key)) + + procedure Exclude (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to Key + + procedure Delete (Container : in out Set; Key : Key_Type); + -- Deletes from Container any elements whose key is equivalent to + -- Key. If there are no such elements, then it raises Constraint_Error. + + function Find (Container : Set; Key : Key_Type) return Cursor; + -- Returns a cursor designating the first element in Container whose key + -- is equivalent to Key. If there is no equivalent element, it returns + -- No_Element. + + function Floor (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements in Container, it returns a cursor + -- designating the first such element. Otherwise, it returns a cursor + -- designating the largest element whose key is less than Item, or + -- No_Element if all keys are greater than Item. + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + -- If Container is empty, the function returns No_Element. If Item is + -- equivalent to the keys of elements of Container, it returns a cursor + -- designating the last such element. Otherwise, it returns a cursor + -- designating the smallest element whose key is greater than Item, or + -- No_Element if all keys are less than Item. + + function Contains (Container : Set; Key : Key_Type) return Boolean; + -- Equivalent to Find (Container, Key) /= No_Element + + procedure Update_Element -- Update_Element_Preserving_Key ??? + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a set object different from Container, + -- then Program_Error is raised. Otherwise, it makes a copy of the key + -- of the element designated by Position, and then calls Process with + -- the element as the parameter. Update_Element then compares the key + -- value obtained before calling Process to the key value obtained from + -- the element after calling Process. If the keys are equivalent then + -- the operation terminates. If Container is busy (cursor tampering has + -- been attempted), then Program_Error is raised. Otherwise, the node + -- is moved to its new position (in canonical order). + + procedure Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Floor (Container, Key) to + -- Ceiling (Container, Key). + + procedure Reverse_Iterate + (Container : Set; + Key : Key_Type; + Process : not null access procedure (Position : Cursor)); + -- Call Process with a cursor designating each element equivalent to + -- Key, in order from Ceiling (Container, Key) to + -- Floor (Container, Key). + + end Generic_Keys; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Type, Node_Access); + + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; + end record; + + overriding procedure Adjust (Container : in out Set); + + overriding procedure Finalize (Container : in out Set) renames Clear; + + use Red_Black_Trees; + use Tree_Types, Tree_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + -- In all predefined libraries the following type is controlled, for proper + -- management of tampering checks. For performance reason we omit this + -- machinery for multisets, which are used in a number of our tools. + + type Reference_Control_Type is record + Container : Set_Access; + end record; + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + No_Element : constant Cursor := Cursor'(null, null); + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + Empty_Set : constant Set := (Controlled with others => <>); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Ordered_Multisets; diff --git a/gcc/ada/libgnat/a-coorse.adb b/gcc/ada/libgnat/a-coorse.adb new file mode 100644 index 0000000..428b9b9 --- /dev/null +++ b/gcc/ada/libgnat/a-coorse.adb @@ -0,0 +1,1999 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . O R D E R E D _ S E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with Ada.Containers.Helpers; use Ada.Containers.Helpers; + +with Ada.Containers.Red_Black_Trees.Generic_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Operations); + +with Ada.Containers.Red_Black_Trees.Generic_Keys; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Keys); + +with Ada.Containers.Red_Black_Trees.Generic_Set_Operations; +pragma Elaborate_All (Ada.Containers.Red_Black_Trees.Generic_Set_Operations); + +with System; use type System.Address; + +package body Ada.Containers.Ordered_Sets is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ------------------------------ + -- Access to Fields of Node -- + ------------------------------ + + -- These subprograms provide functional notation for access to fields + -- of a node, and procedural notation for modifying these fields. + + function Color (Node : Node_Access) return Color_Type; + pragma Inline (Color); + + function Left (Node : Node_Access) return Node_Access; + pragma Inline (Left); + + function Parent (Node : Node_Access) return Node_Access; + pragma Inline (Parent); + + function Right (Node : Node_Access) return Node_Access; + pragma Inline (Right); + + procedure Set_Color (Node : Node_Access; Color : Color_Type); + pragma Inline (Set_Color); + + procedure Set_Left (Node : Node_Access; Left : Node_Access); + pragma Inline (Set_Left); + + procedure Set_Right (Node : Node_Access; Right : Node_Access); + pragma Inline (Set_Right); + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access); + pragma Inline (Set_Parent); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Copy_Node (Source : Node_Access) return Node_Access; + pragma Inline (Copy_Node); + + procedure Free (X : in out Node_Access); + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean); + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equal_Node_Node); + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Element_Node); + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Element_Node); + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Less_Node_Node); + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Tree_Operations is + new Red_Black_Trees.Generic_Operations (Tree_Types); + + procedure Delete_Tree is + new Tree_Operations.Generic_Delete_Tree (Free); + + function Copy_Tree is + new Tree_Operations.Generic_Copy_Tree (Copy_Node, Delete_Tree); + + use Tree_Operations; + + function Is_Equal is + new Tree_Operations.Generic_Equal (Is_Equal_Node_Node); + + package Element_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Element_Type, + Is_Less_Key_Node => Is_Less_Element_Node, + Is_Greater_Key_Node => Is_Greater_Element_Node); + + package Set_Ops is + new Generic_Set_Operations + (Tree_Operations => Tree_Operations, + Insert_With_Hint => Insert_With_Hint, + Copy_Tree => Copy_Tree, + Delete_Tree => Delete_Tree, + Is_Less => Is_Less_Node_Node, + Free => Free); + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left.Node.Element < Right.Node.Element; + end "<"; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in ""<"""); + + return Left.Node.Element < Right; + end "<"; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in ""<"""); + + return Left < Right.Node.Element; + end "<"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Set) return Boolean is + begin + return Is_Equal (Left.Tree, Right.Tree); + end "="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Cursor) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + -- L > R same as R < L + + return Right.Node.Element < Left.Node.Element; + end ">"; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean is + begin + if Checks and then Right.Node = null then + raise Constraint_Error with "Right cursor equals No_Element"; + end if; + + pragma Assert (Vet (Right.Container.Tree, Right.Node), + "bad Right cursor in "">"""); + + return Right.Node.Element < Left; + end ">"; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean is + begin + if Checks and then Left.Node = null then + raise Constraint_Error with "Left cursor equals No_Element"; + end if; + + pragma Assert (Vet (Left.Container.Tree, Left.Node), + "bad Left cursor in "">"""); + + return Right < Left.Node.Element; + end ">"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust is new Tree_Operations.Generic_Adjust (Copy_Tree); + + procedure Adjust (Container : in out Set) is + begin + Adjust (Container.Tree); + end Adjust; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out Set; Source : Set) is + begin + if Target'Address = Source'Address then + return; + end if; + + Target.Clear; + Target.Union (Source); + end Assign; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := + Element_Keys.Ceiling (Container.Tree, Item); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Ceiling; + + ----------- + -- Clear -- + ----------- + + procedure Clear is new Tree_Operations.Generic_Clear (Delete_Tree); + + procedure Clear (Container : in out Set) is + begin + Clear (Container.Tree); + end Clear; + + ----------- + -- Color -- + ----------- + + function Color (Node : Node_Access) return Color_Type is + begin + return Node.Color; + end Color; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in Constant_Reference"); + + declare + Tree : Tree_Type renames Position.Container.all.Tree; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Position.Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : Set; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Set) return Set is + begin + return Target : Set do + Target.Assign (Source); + end return; + end Copy; + + --------------- + -- Copy_Node -- + --------------- + + function Copy_Node (Source : Node_Access) return Node_Access is + Target : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Source.Color, + Element => Source.Element); + begin + return Target; + end Copy_Node; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Position : in out Cursor) is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Delete"); + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, Position.Node); + Free (Position.Node); + Position.Container := null; + end Delete; + + procedure Delete (Container : in out Set; Item : Element_Type) is + X : Node_Access := Element_Keys.Find (Container.Tree, Item); + + begin + if Checks and then X = null then + raise Constraint_Error with "attempt to delete element not in set"; + end if; + + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.First; + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end if; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last (Container : in out Set) is + Tree : Tree_Type renames Container.Tree; + X : Node_Access := Tree.Last; + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end if; + end Delete_Last; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Difference (Target.Tree, Source.Tree); + end Difference; + + function Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := Set_Ops.Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Difference; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Element"); + + return Position.Node.Element; + end Element; + + ------------------------- + -- Equivalent_Elements -- + ------------------------- + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean is + begin + return (if Left < Right or else Right < Left then False else True); + end Equivalent_Elements; + + --------------------- + -- Equivalent_Sets -- + --------------------- + + function Equivalent_Sets (Left, Right : Set) return Boolean is + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean; + pragma Inline (Is_Equivalent_Node_Node); + + function Is_Equivalent is + new Tree_Operations.Generic_Equal (Is_Equivalent_Node_Node); + + ----------------------------- + -- Is_Equivalent_Node_Node -- + ----------------------------- + + function Is_Equivalent_Node_Node (L, R : Node_Access) return Boolean is + begin + return (if L.Element < R.Element then False + elsif R.Element < L.Element then False + else True); + end Is_Equivalent_Node_Node; + + -- Start of processing for Equivalent_Sets + + begin + return Is_Equivalent (Left.Tree, Right.Tree); + end Equivalent_Sets; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Item : Element_Type) is + X : Node_Access := Element_Keys.Find (Container.Tree, Item); + + begin + if X /= null then + Tree_Operations.Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Iterator) is + begin + if Object.Container /= null then + Unbusy (Object.Container.Tree.TC); + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := Element_Keys.Find (Container.Tree, Item); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : Set) return Cursor is + begin + return + (if Container.Tree.First = null then No_Element + else Cursor'(Container'Unrestricted_Access, Container.Tree.First)); + end First; + + function First (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the First (and Last) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (forward) + -- iteration starts from the (logical) beginning of the entire sequence + -- of items (corresponding to Container.First, for a forward iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (forward) partial iteration begins. + + if Object.Node = null then + return Object.Container.First; + else + return Cursor'(Object.Container, Object.Node); + end if; + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : Set) return Element_Type is + begin + if Checks and then Container.Tree.First = null then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Tree.First.Element; + end First_Element; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Item : Element_Type) return Cursor is + Node : constant Node_Access := Element_Keys.Floor (Container.Tree, Item); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Floor; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Node_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + begin + if X /= null then + X.Parent := X; + X.Left := X; + X.Right := X; + Deallocate (X); + end if; + end Free; + + ------------------ + -- Generic_Keys -- + ------------------ + + package body Generic_Keys is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Greater_Key_Node); + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean; + pragma Inline (Is_Less_Key_Node); + + -------------------------- + -- Local Instantiations -- + -------------------------- + + package Key_Keys is + new Red_Black_Trees.Generic_Keys + (Tree_Operations => Tree_Operations, + Key_Type => Key_Type, + Is_Less_Key_Node => Is_Less_Key_Node, + Is_Greater_Key_Node => Is_Greater_Key_Node); + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Ceiling (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Ceiling; + + ------------------------ + -- Constant_Reference -- + ------------------------ + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in set"; + end if; + + declare + Tree : Tree_Type renames Container'Unrestricted_Access.all.Tree; + TC : constant Tamper_Counts_Access := + Tree.TC'Unrestricted_Access; + begin + return R : constant Constant_Reference_Type := + (Element => Node.Element'Access, + Control => (Controlled with TC)) + do + Lock (TC.all); + end return; + end; + end Constant_Reference; + + -------------- + -- Contains -- + -------------- + + function Contains (Container : Set; Key : Key_Type) return Boolean is + begin + return Find (Container, Key) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then X = null then + raise Constraint_Error with "attempt to delete key not in set"; + end if; + + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end Delete; + + ------------- + -- Element -- + ------------- + + function Element (Container : Set; Key : Key_Type) return Element_Type is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "key not in set"; + end if; + + return Node.Element; + end Element; + + --------------------- + -- Equivalent_Keys -- + --------------------- + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean is + begin + return (if Left < Right or else Right < Left then False else True); + end Equivalent_Keys; + + ------------- + -- Exclude -- + ------------- + + procedure Exclude (Container : in out Set; Key : Key_Type) is + X : Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + if X /= null then + Delete_Node_Sans_Free (Container.Tree, X); + Free (X); + end if; + end Exclude; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Control : in out Reference_Control_Type) is + begin + if Control.Container /= null then + Impl.Reference_Control_Type (Control).Finalize; + + if Checks and then not (Key (Control.Pos) = Control.Old_Key.all) + then + Delete (Control.Container.all, Key (Control.Pos)); + raise Program_Error; + end if; + + Control.Container := null; + Control.Old_Key := null; + end if; + end Finalize; + + ---------- + -- Find -- + ---------- + + function Find (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Container : Set; Key : Key_Type) return Cursor is + Node : constant Node_Access := Key_Keys.Floor (Container.Tree, Key); + begin + return (if Node = null then No_Element + else Cursor'(Container'Unrestricted_Access, Node)); + end Floor; + + ------------------------- + -- Is_Greater_Key_Node -- + ------------------------- + + function Is_Greater_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Key (Right.Element) < Left; + end Is_Greater_Key_Node; + + ---------------------- + -- Is_Less_Key_Node -- + ---------------------- + + function Is_Less_Key_Node + (Left : Key_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Key (Right.Element); + end Is_Less_Key_Node; + + --------- + -- Key -- + --------- + + function Key (Position : Cursor) return Key_Type is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Key"); + + return Key (Position.Node.Element); + end Key; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------------------------ + -- Reference_Preserving_Key -- + ------------------------------ + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type + is + begin + if Checks and then Position.Container = null then + raise Constraint_Error with "Position cursor has no element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong container"; + end if; + + pragma Assert + (Vet (Container.Tree, Position.Node), + "bad cursor in function Reference_Preserving_Key"); + + declare + Tree : Tree_Type renames Container.Tree; + begin + return R : constant Reference_Type := + (Element => Position.Node.Element'Access, + Control => + (Controlled with + Tree.TC'Unrestricted_Access, + Container => Container'Access, + Pos => Position, + Old_Key => new Key_Type'(Key (Position)))) + do + Lock (Tree.TC); + end return; + end; + end Reference_Preserving_Key; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with "Key not in set"; + end if; + + declare + Tree : Tree_Type renames Container.Tree; + begin + return R : constant Reference_Type := + (Element => Node.Element'Access, + Control => + (Controlled with + Tree.TC'Unrestricted_Access, + Container => Container'Access, + Pos => Find (Container, Key), + Old_Key => new Key_Type'(Key))) + do + Lock (Tree.TC); + end return; + end; + end Reference_Preserving_Key; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type) + is + Node : constant Node_Access := Key_Keys.Find (Container.Tree, Key); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace key not in set"; + end if; + + Replace_Element (Container.Tree, Node, New_Item); + end Replace; + + ----------------------------------- + -- Update_Element_Preserving_Key -- + ----------------------------------- + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + Tree : Tree_Type renames Container.Tree; + + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Update_Element_Preserving_Key"); + + declare + E : Element_Type renames Position.Node.Element; + K : constant Key_Type := Key (E); + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Process (E); + if Equivalent_Keys (K, Key (E)) then + return; + end if; + end; + + declare + X : Node_Access := Position.Node; + begin + Tree_Operations.Delete_Node_Sans_Free (Tree, X); + Free (X); + end; + + raise Program_Error with "key was modified"; + end Update_Element_Preserving_Key; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + + end Generic_Keys; + + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + return Position /= No_Element; + end Has_Element; + + ------------- + -- Include -- + ------------- + + procedure Include (Container : in out Set; New_Item : Element_Type) is + Position : Cursor; + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if not Inserted then + TE_Check (Container.Tree.TC); + + Position.Node.Element := New_Item; + end if; + end Include; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean) + is + begin + Insert_Sans_Hint + (Container.Tree, + New_Item, + Position.Node, + Inserted); + + Position.Container := Container'Unrestricted_Access; + end Insert; + + procedure Insert + (Container : in out Set; + New_Item : Element_Type) + is + Position : Cursor; + pragma Unreferenced (Position); + + Inserted : Boolean; + + begin + Insert (Container, New_Item, Position, Inserted); + + if Checks and then not Inserted then + raise Constraint_Error with + "attempt to insert element already in set"; + end if; + end Insert; + + ---------------------- + -- Insert_Sans_Hint -- + ---------------------- + + procedure Insert_Sans_Hint + (Tree : in out Tree_Type; + New_Item : Element_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Conditional_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + return new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red_Black_Trees.Red, + Element => New_Item); + end New_Node; + + -- Start of processing for Insert_Sans_Hint + + begin + Conditional_Insert_Sans_Hint + (Tree, + New_Item, + Node, + Inserted); + end Insert_Sans_Hint; + + ---------------------- + -- Insert_With_Hint -- + ---------------------- + + procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access) + is + Success : Boolean; + pragma Unreferenced (Success); + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Insert_Post, + Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + Node : constant Node_Access := + new Node_Type'(Parent => null, + Left => null, + Right => null, + Color => Red, + Element => Src_Node.Element); + begin + return Node; + end New_Node; + + -- Start of processing for Insert_With_Hint + + begin + Local_Insert_With_Hint + (Dst_Tree, + Dst_Hint, + Src_Node.Element, + Dst_Node, + Success); + end Insert_With_Hint; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection (Target : in out Set; Source : Set) is + begin + Set_Ops.Intersection (Target.Tree, Source.Tree); + end Intersection; + + function Intersection (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Intersection (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Intersection; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : Set) return Boolean is + begin + return Container.Tree.Length = 0; + end Is_Empty; + + ------------------------ + -- Is_Equal_Node_Node -- + ------------------------ + + function Is_Equal_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element = R.Element; + end Is_Equal_Node_Node; + + ----------------------------- + -- Is_Greater_Element_Node -- + ----------------------------- + + function Is_Greater_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + -- Compute e > node same as node < e + + return Right.Element < Left; + end Is_Greater_Element_Node; + + -------------------------- + -- Is_Less_Element_Node -- + -------------------------- + + function Is_Less_Element_Node + (Left : Element_Type; + Right : Node_Access) return Boolean + is + begin + return Left < Right.Element; + end Is_Less_Element_Node; + + ----------------------- + -- Is_Less_Node_Node -- + ----------------------- + + function Is_Less_Node_Node (L, R : Node_Access) return Boolean is + begin + return L.Element < R.Element; + end Is_Less_Node_Node; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is + begin + return Set_Ops.Is_Subset (Subset => Subset.Tree, Of_Set => Of_Set.Tree); + end Is_Subset; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Iterate is + new Tree_Operations.Generic_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container'Unrestricted_Access.all.Tree; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Iterate + + begin + Local_Iterate (T); + end Iterate; + + function Iterate (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is null (as is the case here), this means the iterator + -- object was constructed without a start expression. This is a complete + -- iterator, meaning that the iteration starts from the (logical) + -- beginning of the sequence of items. + + -- Note: For a forward iterator, Container.First is the beginning, and + -- for a reverse iterator, Container.Last is the beginning. + + Busy (Container.Tree.TC'Unrestricted_Access.all); + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => null); + end Iterate; + + function Iterate (Container : Set; Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'Class + is + begin + -- It was formerly the case that when Start = No_Element, the partial + -- iterator was defined to behave the same as for a complete iterator, + -- and iterate over the entire sequence of items. However, those + -- semantics were unintuitive and arguably error-prone (it is too easy + -- to accidentally create an endless loop), and so they were changed, + -- per the ARG meeting in Denver on 2011/11. However, there was no + -- consensus about what positive meaning this corner case should have, + -- and so it was decided to simply raise an exception. This does imply, + -- however, that it is not possible to use a partial iterator to specify + -- an empty sequence of items. + + if Checks and then Start = No_Element then + raise Constraint_Error with + "Start position for iterator equals No_Element"; + end if; + + if Checks and then Start.Container /= Container'Unrestricted_Access then + raise Program_Error with + "Start cursor of Iterate designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Start.Node), + "Start cursor of Iterate is bad"); + + -- The value of the Node component influences the behavior of the First + -- and Last selector functions of the iterator object. When the Node + -- component is non-null (as is the case here), it means that this is a + -- partial iteration, over a subset of the complete sequence of + -- items. The iterator object was constructed with a start expression, + -- indicating the position from which the iteration begins. Note that + -- the start position has the same value irrespective of whether this is + -- a forward or reverse iteration. + + Busy (Container.Tree.TC'Unrestricted_Access.all); + + return It : constant Iterator := + Iterator'(Limited_Controlled with + Container => Container'Unrestricted_Access, + Node => Start.Node); + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : Set) return Cursor is + begin + return + (if Container.Tree.Last = null then No_Element + else Cursor'(Container'Unrestricted_Access, Container.Tree.Last)); + end Last; + + function Last (Object : Iterator) return Cursor is + begin + -- The value of the iterator object's Node component influences the + -- behavior of the Last (and First) selector function. + + -- When the Node component is null, this means the iterator object was + -- constructed without a start expression, in which case the (reverse) + -- iteration starts from the (logical) beginning of the entire sequence + -- (corresponding to Container.Last, for a reverse iterator). + + -- Otherwise, this is iteration over a partial sequence of items. When + -- the Node component is non-null, the iterator object was constructed + -- with a start expression, that specifies the position from which the + -- (reverse) partial iteration begins. + + if Object.Node = null then + return Object.Container.Last; + else + return Cursor'(Object.Container, Object.Node); + end if; + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : Set) return Element_Type is + begin + if Checks and then Container.Tree.Last = null then + raise Constraint_Error with "set is empty"; + end if; + + return Container.Tree.Last.Element; + end Last_Element; + + ---------- + -- Left -- + ---------- + + function Left (Node : Node_Access) return Node_Access is + begin + return Node.Left; + end Left; + + ------------ + -- Length -- + ------------ + + function Length (Container : Set) return Count_Type is + begin + return Container.Tree.Length; + end Length; + + ---------- + -- Move -- + ---------- + + procedure Move is new Tree_Operations.Generic_Move (Clear); + + procedure Move (Target : in out Set; Source : in out Set) is + begin + Move (Target => Target.Tree, Source => Source.Tree); + end Move; + + ---------- + -- Next -- + ---------- + + function Next (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Next"); + + declare + Node : constant Node_Access := + Tree_Operations.Next (Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Next; + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Next designates wrong set"; + end if; + + return Next (Position); + end Next; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Set) return Boolean is + begin + return Set_Ops.Overlap (Left.Tree, Right.Tree); + end Overlap; + + ------------ + -- Parent -- + ------------ + + function Parent (Node : Node_Access) return Node_Access is + begin + return Node.Parent; + end Parent; + + -------------- + -- Previous -- + -------------- + + function Previous (Position : Cursor) return Cursor is + begin + if Position = No_Element then + return No_Element; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Previous"); + + declare + Node : constant Node_Access := + Tree_Operations.Previous (Position.Node); + begin + return (if Node = null then No_Element + else Cursor'(Position.Container, Node)); + end; + end Previous; + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Object : Iterator; Position : Cursor) return Cursor is + begin + if Position.Container = null then + return No_Element; + end if; + + if Checks and then Position.Container /= Object.Container then + raise Program_Error with + "Position cursor of Previous designates wrong set"; + end if; + + return Previous (Position); + end Previous; + + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + TC : constant Tamper_Counts_Access := + Container.Tree.TC'Unrestricted_Access; + begin + return R : constant Reference_Control_Type := (Controlled with TC) do + Lock (TC.all); + end return; + end Pseudo_Reference; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with "Position cursor equals No_Element"; + end if; + + pragma Assert (Vet (Position.Container.Tree, Position.Node), + "bad cursor in Query_Element"); + + declare + T : Tree_Type renames Position.Container.Tree; + Lock : With_Lock (T.TC'Unrestricted_Access); + begin + Process (Position.Node.Element); + end; + end Query_Element; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set) + is + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + pragma Inline (Read_Node); + + procedure Read is + new Tree_Operations.Generic_Read (Clear, Read_Node); + + --------------- + -- Read_Node -- + --------------- + + function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access + is + Node : Node_Access := new Node_Type; + begin + Element_Type'Read (Stream, Node.Element); + return Node; + exception + when others => + Free (Node); + raise; + end Read_Node; + + -- Start of processing for Read + + begin + Read (Stream, Container.Tree); + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Read; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Read; + + ------------- + -- Replace -- + ------------- + + procedure Replace (Container : in out Set; New_Item : Element_Type) is + Node : constant Node_Access := + Element_Keys.Find (Container.Tree, New_Item); + + begin + if Checks and then Node = null then + raise Constraint_Error with + "attempt to replace element not in set"; + end if; + + TE_Check (Container.Tree.TC); + + Node.Element := New_Item; + end Replace; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Tree : in out Tree_Type; + Node : Node_Access; + Item : Element_Type) + is + pragma Assert (Node /= null); + + function New_Node return Node_Access; + pragma Inline (New_Node); + + procedure Local_Insert_Post is + new Element_Keys.Generic_Insert_Post (New_Node); + + procedure Local_Insert_Sans_Hint is + new Element_Keys.Generic_Conditional_Insert (Local_Insert_Post); + + procedure Local_Insert_With_Hint is + new Element_Keys.Generic_Conditional_Insert_With_Hint + (Local_Insert_Post, + Local_Insert_Sans_Hint); + + -------------- + -- New_Node -- + -------------- + + function New_Node return Node_Access is + begin + Node.Element := Item; + Node.Color := Red; + Node.Parent := null; + Node.Right := null; + Node.Left := null; + return Node; + end New_Node; + + Hint : Node_Access; + Result : Node_Access; + Inserted : Boolean; + Compare : Boolean; + + -- Start of processing for Replace_Element + + begin + -- Replace_Element assigns value Item to the element designated by Node, + -- per certain semantic constraints. + + -- If Item is equivalent to the element, then element is replaced and + -- there's nothing else to do. This is the easy case. + + -- If Item is not equivalent, then the node will (possibly) have to move + -- to some other place in the tree. This is slighly more complicated, + -- because we must ensure that Item is not equivalent to some other + -- element in the tree (in which case, the replacement is not allowed). + + -- Determine whether Item is equivalent to element on the specified + -- node. + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := (if Item < Node.Element then False + elsif Node.Element < Item then False + else True); + end; + + if Compare then + -- Item is equivalent to the node's element, so we will not have to + -- move the node. + + TE_Check (Tree.TC); + + Node.Element := Item; + return; + end if; + + -- The replacement Item is not equivalent to the element on the + -- specified node, which means that it will need to be re-inserted in a + -- different position in the tree. We must now determine whether Item is + -- equivalent to some other element in the tree (which would prohibit + -- the assignment and hence the move). + + -- Ceiling returns the smallest element equivalent or greater than the + -- specified Item; if there is no such element, then it returns null. + + Hint := Element_Keys.Ceiling (Tree, Item); + + if Hint /= null then + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Item < Hint.Element; + end; + + -- Item >= Hint.Element + + if Checks and then not Compare then + + -- Ceiling returns an element that is equivalent or greater + -- than Item. If Item is "not less than" the element, then + -- by elimination we know that Item is equivalent to the element. + + -- But this means that it is not possible to assign the value of + -- Item to the specified element (on Node), because a different + -- element (on Hint) equivalent to Item already exsits. (Were we + -- to change Node's element value, we would have to move Node, but + -- we would be unable to move the Node, because its new position + -- in the tree is already occupied by an equivalent element.) + + raise Program_Error with "attempt to replace existing element"; + end if; + + -- Item is not equivalent to any other element in the tree, so it is + -- safe to assign the value of Item to Node.Element. This means that + -- the node will have to move to a different position in the tree + -- (because its element will have a different value). + + -- The nearest (greater) neighbor of Item is Hint. This will be the + -- insertion position of Node (because its element will have Item as + -- its new value). + + -- If Node equals Hint, the relative position of Node does not + -- change. This allows us to perform an optimization: we need not + -- remove Node from the tree and then reinsert it with its new value, + -- because it would only be placed in the exact same position. + + if Hint = Node then + TE_Check (Tree.TC); + + Node.Element := Item; + return; + end if; + end if; + + -- If we get here, it is because Item was greater than all elements in + -- the tree (Hint = null), or because Item was less than some element at + -- a different place in the tree (Item < Hint.Element). In either case, + -- we remove Node from the tree (without actually deallocating it), and + -- then insert Item into the tree, onto the same Node (so no new node is + -- actually allocated). + + Tree_Operations.Delete_Node_Sans_Free (Tree, Node); -- Checks busy-bit + + Local_Insert_With_Hint -- use unconditional insert here instead??? + (Tree => Tree, + Position => Hint, + Key => Item, + Node => Result, + Inserted => Inserted); + + pragma Assert (Inserted); + pragma Assert (Result = Node); + end Replace_Element; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Checks and then Position.Node = null then + raise Constraint_Error with + "Position cursor equals No_Element"; + end if; + + if Checks and then Position.Container /= Container'Unrestricted_Access + then + raise Program_Error with + "Position cursor designates wrong set"; + end if; + + pragma Assert (Vet (Container.Tree, Position.Node), + "bad cursor in Replace_Element"); + + Replace_Element (Container.Tree, Position.Node, New_Item); + end Replace_Element; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)) + is + procedure Process_Node (Node : Node_Access); + pragma Inline (Process_Node); + + procedure Local_Reverse_Iterate is + new Tree_Operations.Generic_Reverse_Iteration (Process_Node); + + ------------------ + -- Process_Node -- + ------------------ + + procedure Process_Node (Node : Node_Access) is + begin + Process (Cursor'(Container'Unrestricted_Access, Node)); + end Process_Node; + + T : Tree_Type renames Container.Tree'Unrestricted_Access.all; + Busy : With_Busy (T.TC'Unrestricted_Access); + + -- Start of processing for Reverse_Iterate + + begin + Local_Reverse_Iterate (T); + end Reverse_Iterate; + + ----------- + -- Right -- + ----------- + + function Right (Node : Node_Access) return Node_Access is + begin + return Node.Right; + end Right; + + --------------- + -- Set_Color -- + --------------- + + procedure Set_Color (Node : Node_Access; Color : Color_Type) is + begin + Node.Color := Color; + end Set_Color; + + -------------- + -- Set_Left -- + -------------- + + procedure Set_Left (Node : Node_Access; Left : Node_Access) is + begin + Node.Left := Left; + end Set_Left; + + ---------------- + -- Set_Parent -- + ---------------- + + procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is + begin + Node.Parent := Parent; + end Set_Parent; + + --------------- + -- Set_Right -- + --------------- + + procedure Set_Right (Node : Node_Access; Right : Node_Access) is + begin + Node.Right := Right; + end Set_Right; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference (Target : in out Set; Source : Set) is + begin + Set_Ops.Symmetric_Difference (Target.Tree, Source.Tree); + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Symmetric_Difference (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Symmetric_Difference; + + ------------ + -- To_Set -- + ------------ + + function To_Set (New_Item : Element_Type) return Set is + Tree : Tree_Type; + Node : Node_Access; + Inserted : Boolean; + pragma Unreferenced (Node, Inserted); + begin + Insert_Sans_Hint (Tree, New_Item, Node, Inserted); + return Set'(Controlled with Tree); + end To_Set; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Set; Source : Set) is + begin + Set_Ops.Union (Target.Tree, Source.Tree); + end Union; + + function Union (Left, Right : Set) return Set is + Tree : constant Tree_Type := + Set_Ops.Union (Left.Tree, Right.Tree); + begin + return Set'(Controlled with Tree); + end Union; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set) + is + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + pragma Inline (Write_Node); + + procedure Write is + new Tree_Operations.Generic_Write (Write_Node); + + ---------------- + -- Write_Node -- + ---------------- + + procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access) + is + begin + Element_Type'Write (Stream, Node.Element); + end Write_Node; + + -- Start of processing for Write + + begin + Write (Stream, Container.Tree); + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor) + is + begin + raise Program_Error with "attempt to stream set cursor"; + end Write; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type) + is + begin + raise Program_Error with "attempt to stream reference"; + end Write; + +end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/libgnat/a-coorse.ads b/gcc/ada/libgnat/a-coorse.ads new file mode 100644 index 0000000..3222bfb --- /dev/null +++ b/gcc/ada/libgnat/a-coorse.ads @@ -0,0 +1,453 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . O R D E R E D _ S E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Iterator_Interfaces; + +with Ada.Containers.Helpers; +private with Ada.Containers.Red_Black_Trees; +private with Ada.Finalization; +private with Ada.Streams; + +generic + type Element_Type is private; + + with function "<" (Left, Right : Element_Type) return Boolean is <>; + with function "=" (Left, Right : Element_Type) return Boolean is <>; + +package Ada.Containers.Ordered_Sets is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + pragma Remote_Types; + + function Equivalent_Elements (Left, Right : Element_Type) return Boolean; + + type Set is tagged private + with Constant_Indexing => Constant_Reference, + Default_Iterator => Iterate, + Iterator_Element => Element_Type; + + pragma Preelaborable_Initialization (Set); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + function Has_Element (Position : Cursor) return Boolean; + + Empty_Set : constant Set; + + No_Element : constant Cursor; + + package Set_Iterator_Interfaces is new + Ada.Iterator_Interfaces (Cursor, Has_Element); + + function "=" (Left, Right : Set) return Boolean; + + function Equivalent_Sets (Left, Right : Set) return Boolean; + + function To_Set (New_Item : Element_Type) return Set; + + function Length (Container : Set) return Count_Type; + + function Is_Empty (Container : Set) return Boolean; + + procedure Clear (Container : in out Set); + + function Element (Position : Cursor) return Element_Type; + + procedure Replace_Element + (Container : in out Set; + Position : Cursor; + New_Item : Element_Type); + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + private + with + Implicit_Dereference => Element; + + function Constant_Reference + (Container : aliased Set; + Position : Cursor) return Constant_Reference_Type; + pragma Inline (Constant_Reference); + + procedure Assign (Target : in out Set; Source : Set); + + function Copy (Source : Set) return Set; + + procedure Move (Target : in out Set; Source : in out Set); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type; + Position : out Cursor; + Inserted : out Boolean); + + procedure Insert + (Container : in out Set; + New_Item : Element_Type); + + procedure Include + (Container : in out Set; + New_Item : Element_Type); + + procedure Replace + (Container : in out Set; + New_Item : Element_Type); + + procedure Exclude + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Item : Element_Type); + + procedure Delete + (Container : in out Set; + Position : in out Cursor); + + procedure Delete_First (Container : in out Set); + + procedure Delete_Last (Container : in out Set); + + procedure Union (Target : in out Set; Source : Set); + + function Union (Left, Right : Set) return Set; + + function "or" (Left, Right : Set) return Set renames Union; + + procedure Intersection (Target : in out Set; Source : Set); + + function Intersection (Left, Right : Set) return Set; + + function "and" (Left, Right : Set) return Set renames Intersection; + + procedure Difference (Target : in out Set; Source : Set); + + function Difference (Left, Right : Set) return Set; + + function "-" (Left, Right : Set) return Set renames Difference; + + procedure Symmetric_Difference (Target : in out Set; Source : Set); + + function Symmetric_Difference (Left, Right : Set) return Set; + + function "xor" (Left, Right : Set) return Set renames Symmetric_Difference; + + function Overlap (Left, Right : Set) return Boolean; + + function Is_Subset (Subset : Set; Of_Set : Set) return Boolean; + + function First (Container : Set) return Cursor; + + function First_Element (Container : Set) return Element_Type; + + function Last (Container : Set) return Cursor; + + function Last_Element (Container : Set) return Element_Type; + + function Next (Position : Cursor) return Cursor; + + procedure Next (Position : in out Cursor); + + function Previous (Position : Cursor) return Cursor; + + procedure Previous (Position : in out Cursor); + + function Find (Container : Set; Item : Element_Type) return Cursor; + + function Floor (Container : Set; Item : Element_Type) return Cursor; + + function Ceiling (Container : Set; Item : Element_Type) return Cursor; + + function Contains (Container : Set; Item : Element_Type) return Boolean; + + function "<" (Left, Right : Cursor) return Boolean; + + function ">" (Left, Right : Cursor) return Boolean; + + function "<" (Left : Cursor; Right : Element_Type) return Boolean; + + function ">" (Left : Cursor; Right : Element_Type) return Boolean; + + function "<" (Left : Element_Type; Right : Cursor) return Boolean; + + function ">" (Left : Element_Type; Right : Cursor) return Boolean; + + procedure Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + procedure Reverse_Iterate + (Container : Set; + Process : not null access procedure (Position : Cursor)); + + function Iterate + (Container : Set) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + function Iterate + (Container : Set; + Start : Cursor) + return Set_Iterator_Interfaces.Reversible_Iterator'class; + + generic + type Key_Type (<>) is private; + + with function Key (Element : Element_Type) return Key_Type; + + with function "<" (Left, Right : Key_Type) return Boolean is <>; + + package Generic_Keys is + + function Equivalent_Keys (Left, Right : Key_Type) return Boolean; + + function Key (Position : Cursor) return Key_Type; + + function Element (Container : Set; Key : Key_Type) return Element_Type; + + procedure Replace + (Container : in out Set; + Key : Key_Type; + New_Item : Element_Type); + + procedure Exclude (Container : in out Set; Key : Key_Type); + + procedure Delete (Container : in out Set; Key : Key_Type); + + function Find (Container : Set; Key : Key_Type) return Cursor; + + function Floor (Container : Set; Key : Key_Type) return Cursor; + + function Ceiling (Container : Set; Key : Key_Type) return Cursor; + + function Contains (Container : Set; Key : Key_Type) return Boolean; + + procedure Update_Element_Preserving_Key + (Container : in out Set; + Position : Cursor; + Process : not null access + procedure (Element : in out Element_Type)); + + type Reference_Type (Element : not null access Element_Type) is private + with + Implicit_Dereference => Element; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Position : Cursor) return Reference_Type; + + function Constant_Reference + (Container : aliased Set; + Key : Key_Type) return Constant_Reference_Type; + + function Reference_Preserving_Key + (Container : aliased in out Set; + Key : Key_Type) return Reference_Type; + + private + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Key_Access is access all Key_Type; + + package Impl is new Helpers.Generic_Implementation; + + type Reference_Control_Type is + new Impl.Reference_Control_Type with + record + Container : Set_Access; + Pos : Cursor; + Old_Key : Key_Access; + end record; + + overriding procedure Finalize (Control : in out Reference_Control_Type); + pragma Inline (Finalize); + + type Reference_Type (Element : not null access Element_Type) is record + Control : Reference_Control_Type; + end record; + + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Reference_Type); + + for Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Reference_Type); + + for Reference_Type'Read use Read; + end Generic_Keys; + +private + + pragma Inline (Next); + pragma Inline (Previous); + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Parent : Node_Access; + Left : Node_Access; + Right : Node_Access; + Color : Red_Black_Trees.Color_Type := Red_Black_Trees.Red; + Element : aliased Element_Type; + end record; + + package Tree_Types is + new Red_Black_Trees.Generic_Tree_Types (Node_Type, Node_Access); + + type Set is new Ada.Finalization.Controlled with record + Tree : Tree_Types.Tree_Type; + end record; + + overriding procedure Adjust (Container : in out Set); + + overriding procedure Finalize (Container : in out Set) renames Clear; + + use Red_Black_Trees; + use Tree_Types, Tree_Types.Implementation; + use Ada.Finalization; + use Ada.Streams; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Container : Set); + + for Set'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Container : out Set); + + for Set'Read use Read; + + type Set_Access is access all Set; + for Set_Access'Storage_Size use 0; + + type Cursor is record + Container : Set_Access; + Node : Node_Access; + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Cursor); + + for Cursor'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Cursor); + + for Cursor'Read use Read; + + subtype Reference_Control_Type is Implementation.Reference_Control_Type; + -- It is necessary to rename this here, so that the compiler can find it + + type Constant_Reference_Type + (Element : not null access constant Element_Type) is + record + Control : Reference_Control_Type := + raise Program_Error with "uninitialized reference"; + -- The RM says, "The default initialization of an object of + -- type Constant_Reference_Type or Reference_Type propagates + -- Program_Error." + end record; + + procedure Write + (Stream : not null access Root_Stream_Type'Class; + Item : Constant_Reference_Type); + + for Constant_Reference_Type'Write use Write; + + procedure Read + (Stream : not null access Root_Stream_Type'Class; + Item : out Constant_Reference_Type); + + for Constant_Reference_Type'Read use Read; + + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type with + Storage_Size => 0; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + + Empty_Set : constant Set := (Controlled with others => <>); + + No_Element : constant Cursor := Cursor'(null, null); + + type Iterator is new Limited_Controlled and + Set_Iterator_Interfaces.Reversible_Iterator with + record + Container : Set_Access; + Node : Node_Access; + end record + with Disable_Controlled => not T_Check; + + overriding procedure Finalize (Object : in out Iterator); + + overriding function First (Object : Iterator) return Cursor; + overriding function Last (Object : Iterator) return Cursor; + + overriding function Next + (Object : Iterator; + Position : Cursor) return Cursor; + + overriding function Previous + (Object : Iterator; + Position : Cursor) return Cursor; + +end Ada.Containers.Ordered_Sets; diff --git a/gcc/ada/libgnat/a-coprnu.adb b/gcc/ada/libgnat/a-coprnu.adb new file mode 100644 index 0000000..bc2054d --- /dev/null +++ b/gcc/ada/libgnat/a-coprnu.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . P R I M E _ N U M B E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Prime_Numbers is + + -------------- + -- To_Prime -- + -------------- + + function To_Prime (Length : Count_Type) return Hash_Type is + I, J, K : Integer'Base; + Index : Integer'Base; + + begin + I := Primes'Last - Primes'First; + Index := Primes'First; + while I > 0 loop + J := I / 2; + K := Index + J; + + if Primes (K) < Hash_Type (Length) then + Index := K + 1; + I := I - J - 1; + else + I := J; + end if; + end loop; + + return Primes (Index); + end To_Prime; + +end Ada.Containers.Prime_Numbers; diff --git a/gcc/ada/libgnat/a-coprnu.ads b/gcc/ada/libgnat/a-coprnu.ads new file mode 100644 index 0000000..4261267 --- /dev/null +++ b/gcc/ada/libgnat/a-coprnu.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . P R I M E _ N U M B E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This package declares the prime numbers array used to implement hashed +-- containers. Bucket arrays are always allocated with a prime-number +-- length (computed using To_Prime below), as this produces better scatter +-- when hash values are folded. + +package Ada.Containers.Prime_Numbers is + pragma Pure; + + type Primes_Type is array (Positive range <>) of Hash_Type; + + Primes : constant Primes_Type := + (53, 97, 193, 389, 769, + 1543, 3079, 6151, 12289, 24593, + 49157, 98317, 196613, 393241, 786433, + 1572869, 3145739, 6291469, 12582917, 25165843, + 50331653, 100663319, 201326611, 402653189, 805306457, + 1610612741, 3221225473, 4294967291); + + function To_Prime (Length : Count_Type) return Hash_Type; + -- Returns the smallest value in Primes not less than Length + +end Ada.Containers.Prime_Numbers; diff --git a/gcc/ada/libgnat/a-coteio.ads b/gcc/ada/libgnat/a-coteio.ads new file mode 100644 index 0000000..abba889 --- /dev/null +++ b/gcc/ada/libgnat/a-coteio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Complex_Types); diff --git a/gcc/ada/libgnat/a-crbltr.ads b/gcc/ada/libgnat/a-crbltr.ads new file mode 100644 index 0000000..75df71b --- /dev/null +++ b/gcc/ada/libgnat/a-crbltr.ads @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . C O N T A I N E R S . R E D _ B L A C K _ T R E E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- This package declares the tree type used to implement ordered containers + +with Ada.Containers.Helpers; + +package Ada.Containers.Red_Black_Trees is + pragma Pure; + + type Color_Type is (Red, Black); + + generic + type Node_Type (<>) is limited private; + type Node_Access is access Node_Type; + package Generic_Tree_Types is + + type Tree_Type is tagged record + First : Node_Access := null; + Last : Node_Access := null; + Root : Node_Access := null; + Length : Count_Type := 0; + TC : aliased Helpers.Tamper_Counts; + end record; + + package Implementation is new Helpers.Generic_Implementation; + end Generic_Tree_Types; + + generic + type Node_Type is private; + package Generic_Bounded_Tree_Types is + type Nodes_Type is array (Count_Type range <>) of Node_Type; + + -- Note that objects of type Tree_Type are logically initialized (in the + -- sense that representation invariants of type are satisfied by dint of + -- default initialization), even without the Nodes component also having + -- its own initialization expression. We only initializae the Nodes + -- component here in order to prevent spurious compiler warnings about + -- the container object not being fully initialized. + + type Tree_Type (Capacity : Count_Type) is tagged record + First : Count_Type := 0; + Last : Count_Type := 0; + Root : Count_Type := 0; + Length : Count_Type := 0; + TC : aliased Helpers.Tamper_Counts; + Free : Count_Type'Base := -1; + Nodes : Nodes_Type (1 .. Capacity) := (others => <>); + end record; + + package Implementation is new Helpers.Generic_Implementation; + end Generic_Bounded_Tree_Types; + +end Ada.Containers.Red_Black_Trees; diff --git a/gcc/ada/libgnat/a-crbtgk.adb b/gcc/ada/libgnat/a-crbtgk.adb new file mode 100644 index 0000000..8eb3c5d --- /dev/null +++ b/gcc/ada/libgnat/a-crbtgk.adb @@ -0,0 +1,690 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Red_Black_Trees.Generic_Keys is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + package Ops renames Tree_Operations; + + ------------- + -- Ceiling -- + ------------- + + -- AKA Lower_Bound + + function Ceiling (Tree : Tree_Type; Key : Key_Type) return Node_Access is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); + + Y : Node_Access; + X : Node_Access; + + begin + -- If the container is empty, return a result immediately, so that we do + -- not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + return null; + end if; + + X := Tree.Root; + while X /= null loop + if Is_Greater_Key_Node (Key, X) then + X := Ops.Right (X); + else + Y := X; + X := Ops.Left (X); + end if; + end loop; + + return Y; + end Ceiling; + + ---------- + -- Find -- + ---------- + + function Find (Tree : Tree_Type; Key : Key_Type) return Node_Access is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); + + Y : Node_Access; + X : Node_Access; + + begin + -- If the container is empty, return a result immediately, so that we do + -- not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + return null; + end if; + + X := Tree.Root; + while X /= null loop + if Is_Greater_Key_Node (Key, X) then + X := Ops.Right (X); + else + Y := X; + X := Ops.Left (X); + end if; + end loop; + + if Y = null or else Is_Less_Key_Node (Key, Y) then + return null; + else + return Y; + end if; + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor (Tree : Tree_Type; Key : Key_Type) return Node_Access is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock : With_Lock (Tree.TC'Unrestricted_Access); + + Y : Node_Access; + X : Node_Access; + + begin + -- If the container is empty, return a result immediately, so that we do + -- not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + return null; + end if; + + X := Tree.Root; + while X /= null loop + if Is_Less_Key_Node (Key, X) then + X := Ops.Left (X); + else + Y := X; + X := Ops.Right (X); + end if; + end loop; + + return Y; + end Floor; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + X : Node_Access; + Y : Node_Access; + + Compare : Boolean; + + begin + -- This is a "conditional" insertion, meaning that the insertion request + -- can "fail" in the sense that no new node is created. If the Key is + -- equivalent to an existing node, then we return the existing node and + -- Inserted is set to False. Otherwise, we allocate a new node (via + -- Insert_Post) and Inserted is set to True. + + -- Note that we are testing for equivalence here, not equality. Key must + -- be strictly less than its next neighbor, and strictly greater than + -- its previous neighbor, in order for the conditional insertion to + -- succeed. + + -- Handle insertion into an empty container as a special case, so that + -- we do not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + Insert_Post (Tree, null, True, Node); + Inserted := True; + return; + end if; + + -- We search the tree to find the nearest neighbor of Key, which is + -- either the smallest node greater than Key (Inserted is True), or the + -- largest node less or equivalent to Key (Inserted is False). + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + X := Tree.Root; + Y := null; + Inserted := True; + while X /= null loop + Y := X; + Inserted := Is_Less_Key_Node (Key, X); + X := (if Inserted then Ops.Left (X) else Ops.Right (X)); + end loop; + end; + + if Inserted then + + -- Key is less than Y. If Y is the first node in the tree, then there + -- are no other nodes that we need to search for, and we insert a new + -- node into the tree. + + if Y = Tree.First then + Insert_Post (Tree, Y, True, Node); + return; + end if; + + -- Y is the next nearest-neighbor of Key. We know that Key is not + -- equivalent to Y (because Key is strictly less than Y), so we move + -- to the previous node, the nearest-neighbor just smaller or + -- equivalent to Key. + + Node := Ops.Previous (Y); + + else + -- Y is the previous nearest-neighbor of Key. We know that Key is not + -- less than Y, which means either that Key is equivalent to Y, or + -- greater than Y. + + Node := Y; + end if; + + -- Key is equivalent to or greater than Node. We must resolve which is + -- the case, to determine whether the conditional insertion succeeds. + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Is_Greater_Key_Node (Key, Node); + end; + + if Compare then + + -- Key is strictly greater than Node, which means that Key is not + -- equivalent to Node. In this case, the insertion succeeds, and we + -- insert a new node into the tree. + + Insert_Post (Tree, Y, Inserted, Node); + Inserted := True; + return; + end if; + + -- Key is equivalent to Node. This is a conditional insertion, so we do + -- not insert a new node in this case. We return the existing node and + -- report that no insertion has occurred. + + Inserted := False; + end Generic_Conditional_Insert; + + ------------------------------------------ + -- Generic_Conditional_Insert_With_Hint -- + ------------------------------------------ + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type; + Position : Node_Access; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean) + is + Test : Node_Access; + Compare : Boolean; + + begin + -- The purpose of a hint is to avoid a search from the root of + -- tree. If we have it hint it means we only need to traverse the + -- subtree rooted at the hint to find the nearest neighbor. Note + -- that finding the neighbor means merely walking the tree; this + -- is not a search and the only comparisons that occur are with + -- the hint and its neighbor. + + -- Handle insertion into an empty container as a special case, so that + -- we do not manipulate the tamper bits unnecessarily. + + if Tree.Root = null then + Insert_Post (Tree, null, True, Node); + Inserted := True; + return; + end if; + + -- If Position is null, this is interpreted to mean that Key is large + -- relative to the nodes in the tree. If Key is greater than the last + -- node in the tree, then we're done; otherwise the hint was "wrong" and + -- we must search. + + if Position = null then -- largest + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Is_Greater_Key_Node (Key, Tree.Last); + end; + + if Compare then + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + -- A hint can either name the node that immediately follows Key, + -- or immediately precedes Key. We first test whether Key is + -- less than the hint, and if so we compare Key to the node that + -- precedes the hint. If Key is both less than the hint and + -- greater than the hint's preceding neighbor, then we're done; + -- otherwise we must search. + + -- Note also that a hint can either be an anterior node or a leaf + -- node. A new node is always inserted at the bottom of the tree + -- (at least prior to rebalancing), becoming the new left or + -- right child of leaf node (which prior to the insertion must + -- necessarily be null, since this is a leaf). If the hint names + -- an anterior node then its neighbor must be a leaf, and so + -- (here) we insert after the neighbor. If the hint names a leaf + -- then its neighbor must be anterior and so we insert before the + -- hint. + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Is_Less_Key_Node (Key, Position); + end; + + if Compare then + Test := Ops.Previous (Position); -- "before" + + if Test = null then -- new first node + Insert_Post (Tree, Tree.First, True, Node); + + Inserted := True; + return; + end if; + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Is_Greater_Key_Node (Key, Test); + end; + + if Compare then + if Ops.Right (Test) = null then + Insert_Post (Tree, Test, False, Node); + else + Insert_Post (Tree, Position, True, Node); + end if; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + + return; + end if; + + -- We know that Key isn't less than the hint so we try again, this time + -- to see if it's greater than the hint. If so we compare Key to the + -- node that follows the hint. If Key is both greater than the hint and + -- less than the hint's next neighbor, then we're done; otherwise we + -- must search. + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Is_Greater_Key_Node (Key, Position); + end; + + if Compare then + Test := Ops.Next (Position); -- "after" + + if Test = null then -- new last node + Insert_Post (Tree, Tree.Last, False, Node); + + Inserted := True; + return; + end if; + + declare + Lock : With_Lock (Tree.TC'Unrestricted_Access); + begin + Compare := Is_Less_Key_Node (Key, Test); + end; + + if Compare then + if Ops.Right (Position) = null then + Insert_Post (Tree, Position, False, Node); + else + Insert_Post (Tree, Test, True, Node); + end if; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + + return; + end if; + + -- We know that Key is neither less than the hint nor greater than the + -- hint, and that's the definition of equivalence. There's nothing else + -- we need to do, since a search would just reach the same conclusion. + + Node := Position; + Inserted := False; + end Generic_Conditional_Insert_With_Hint; + + ------------------------- + -- Generic_Insert_Post -- + ------------------------- + + procedure Generic_Insert_Post + (Tree : in out Tree_Type; + Y : Node_Access; + Before : Boolean; + Z : out Node_Access) + is + begin + if Checks and then Tree.Length = Count_Type'Last then + raise Constraint_Error with "too many elements"; + end if; + + TC_Check (Tree.TC); + + Z := New_Node; + pragma Assert (Z /= null); + pragma Assert (Ops.Color (Z) = Red); + + if Y = null then + pragma Assert (Tree.Length = 0); + pragma Assert (Tree.Root = null); + pragma Assert (Tree.First = null); + pragma Assert (Tree.Last = null); + + Tree.Root := Z; + Tree.First := Z; + Tree.Last := Z; + + elsif Before then + pragma Assert (Ops.Left (Y) = null); + + Ops.Set_Left (Y, Z); + + if Y = Tree.First then + Tree.First := Z; + end if; + + else + pragma Assert (Ops.Right (Y) = null); + + Ops.Set_Right (Y, Z); + + if Y = Tree.Last then + Tree.Last := Z; + end if; + end if; + + Ops.Set_Parent (Z, Y); + Ops.Rebalance_For_Insert (Tree, Z); + Tree.Length := Tree.Length + 1; + end Generic_Insert_Post; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration + (Tree : Tree_Type; + Key : Key_Type) + is + procedure Iterate (Node : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Node : Node_Access) is + N : Node_Access; + begin + N := Node; + while N /= null loop + if Is_Less_Key_Node (Key, N) then + N := Ops.Left (N); + elsif Is_Greater_Key_Node (Key, N) then + N := Ops.Right (N); + else + Iterate (Ops.Left (N)); + Process (N); + N := Ops.Right (N); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration + (Tree : Tree_Type; + Key : Key_Type) + is + procedure Iterate (Node : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Node : Node_Access) is + N : Node_Access; + begin + N := Node; + while N /= null loop + if Is_Less_Key_Node (Key, N) then + N := Ops.Left (N); + elsif Is_Greater_Key_Node (Key, N) then + N := Ops.Right (N); + else + Iterate (Ops.Right (N)); + Process (N); + N := Ops.Left (N); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ---------------------------------- + -- Generic_Unconditional_Insert -- + ---------------------------------- + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access) + is + Y : Node_Access; + X : Node_Access; + + Before : Boolean; + + begin + Y := null; + Before := False; + + X := Tree.Root; + while X /= null loop + Y := X; + Before := Is_Less_Key_Node (Key, X); + X := (if Before then Ops.Left (X) else Ops.Right (X)); + end loop; + + Insert_Post (Tree, Y, Before, Node); + end Generic_Unconditional_Insert; + + -------------------------------------------- + -- Generic_Unconditional_Insert_With_Hint -- + -------------------------------------------- + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type; + Hint : Node_Access; + Key : Key_Type; + Node : out Node_Access) + is + begin + -- There are fewer constraints for an unconditional insertion + -- than for a conditional insertion, since we allow duplicate + -- keys. So instead of having to check (say) whether Key is + -- (strictly) greater than the hint's previous neighbor, here we + -- allow Key to be equal to or greater than the previous node. + + -- There is the issue of what to do if Key is equivalent to the + -- hint. Does the new node get inserted before or after the hint? + -- We decide that it gets inserted after the hint, reasoning that + -- this is consistent with behavior for non-hint insertion, which + -- inserts a new node after existing nodes with equivalent keys. + + -- First we check whether the hint is null, which is interpreted + -- to mean that Key is large relative to existing nodes. + -- Following our rule above, if Key is equal to or greater than + -- the last node, then we insert the new node immediately after + -- last. (We don't have an operation for testing whether a key is + -- "equal to or greater than" a node, so we must say instead "not + -- less than", which is equivalent.) + + if Hint = null then -- largest + if Tree.Last = null then + Insert_Post (Tree, null, False, Node); + elsif Is_Less_Key_Node (Key, Tree.Last) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + else + Insert_Post (Tree, Tree.Last, False, Node); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + -- We decide here whether to insert the new node prior to the + -- hint. Key could be equivalent to the hint, so in theory we + -- could write the following test as "not greater than" (same as + -- "less than or equal to"). If Key were equivalent to the hint, + -- that would mean that the new node gets inserted before an + -- equivalent node. That wouldn't break any container invariants, + -- but our rule above says that new nodes always get inserted + -- after equivalent nodes. So here we test whether Key is both + -- less than the hint and equal to or greater than the hint's + -- previous neighbor, and if so insert it before the hint. + + if Is_Less_Key_Node (Key, Hint) then + declare + Before : constant Node_Access := Ops.Previous (Hint); + begin + if Before = null then + Insert_Post (Tree, Hint, True, Node); + elsif Is_Less_Key_Node (Key, Before) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + elsif Ops.Right (Before) = null then + Insert_Post (Tree, Before, False, Node); + else + Insert_Post (Tree, Hint, True, Node); + end if; + end; + + return; + end if; + + -- We know that Key isn't less than the hint, so it must be equal + -- or greater. So we just test whether Key is less than or equal + -- to (same as "not greater than") the hint's next neighbor, and + -- if so insert it after the hint. + + declare + After : constant Node_Access := Ops.Next (Hint); + begin + if After = null then + Insert_Post (Tree, Hint, False, Node); + elsif Is_Greater_Key_Node (Key, After) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + elsif Ops.Right (Hint) = null then + Insert_Post (Tree, Hint, False, Node); + else + Insert_Post (Tree, After, True, Node); + end if; + end; + end Generic_Unconditional_Insert_With_Hint; + + ----------------- + -- Upper_Bound -- + ----------------- + + function Upper_Bound + (Tree : Tree_Type; + Key : Key_Type) return Node_Access + is + Y : Node_Access; + X : Node_Access; + + begin + X := Tree.Root; + while X /= null loop + if Is_Less_Key_Node (Key, X) then + Y := X; + X := Ops.Left (X); + else + X := Ops.Right (X); + end if; + end loop; + + return Y; + end Upper_Bound; + +end Ada.Containers.Red_Black_Trees.Generic_Keys; diff --git a/gcc/ada/libgnat/a-crbtgk.ads b/gcc/ada/libgnat/a-crbtgk.ads new file mode 100644 index 0000000..1a9e39e --- /dev/null +++ b/gcc/ada/libgnat/a-crbtgk.ads @@ -0,0 +1,192 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_KEYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement ordered containers. This package declares +-- the tree operations that depend on keys. + +with Ada.Containers.Red_Black_Trees.Generic_Operations; + +generic + with package Tree_Operations is new Generic_Operations (<>); + + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; + + type Key_Type (<>) is limited private; + + with function Is_Less_Key_Node + (L : Key_Type; + R : Node_Access) return Boolean; + + with function Is_Greater_Key_Node + (L : Key_Type; + R : Node_Access) return Boolean; + +package Ada.Containers.Red_Black_Trees.Generic_Keys is + pragma Pure; + + generic + with function New_Node return Node_Access; + procedure Generic_Insert_Post + (Tree : in out Tree_Type; + Y : Node_Access; + Before : Boolean; + Z : out Node_Access); + -- Completes an insertion after the insertion position has been + -- determined. On output Z contains a pointer to the newly inserted + -- node, allocated using New_Node. If Tree is busy then + -- Program_Error is raised. If Y is null, then Tree must be empty. + -- Otherwise Y denotes the insertion position, and Before specifies + -- whether the new node is Y's left (True) or right (False) child. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + -- Inserts a new node in Tree, but only if the tree does not already + -- contain Key. Generic_Conditional_Insert first searches for a key + -- equivalent to Key in Tree. If an equivalent key is found, then on + -- output Node designates the node with that key and Inserted is + -- False; there is no allocation and Tree is not modified. Otherwise + -- Node designates a new node allocated using Insert_Post, and + -- Inserted is True. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access); + -- Inserts a new node in Tree. On output Node designates the new + -- node, which is allocated using Insert_Post. The node is inserted + -- immediately after already-existing equivalent keys. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + with procedure Unconditional_Insert_Sans_Hint + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access); + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type; + Hint : Node_Access; + Key : Key_Type; + Node : out Node_Access); + -- Inserts a new node in Tree near position Hint, to avoid having to + -- search from the root for the insertion position. If Hint is null + -- then Generic_Unconditional_Insert_With_Hint attempts to insert + -- the new node after Tree.Last. If Hint is non-null then if Key is + -- less than Hint, it attempts to insert the new node immediately + -- prior to Hint. Otherwise it attempts to insert the node + -- immediately following Hint. We say "attempts" above to emphasize + -- that insertions always preserve invariants with respect to key + -- order, even when there's a hint. So if Key can't be inserted + -- immediately near Hint, then the new node is inserted in the + -- normal way, by searching for the correct position starting from + -- the root. + + generic + with procedure Insert_Post + (T : in out Tree_Type; + Y : Node_Access; + B : Boolean; + Z : out Node_Access); + + with procedure Conditional_Insert_Sans_Hint + (Tree : in out Tree_Type; + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type; + Position : Node_Access; -- the hint + Key : Key_Type; + Node : out Node_Access; + Inserted : out Boolean); + -- Inserts a new node in Tree if the tree does not already contain + -- Key, using Position as a hint about where to insert the new node. + -- See Generic_Unconditional_Insert_With_Hint for more details about + -- hint semantics. + + function Find + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node equivalent to Key + + function Ceiling + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node equal to or greater than Key + + function Floor + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the largest node less than or equal to Key + + function Upper_Bound + (Tree : Tree_Type; + Key : Key_Type) return Node_Access; + -- Searches Tree for the smallest node greater than Key + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Iteration + (Tree : Tree_Type; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, in order + -- from earliest in range to latest. + + generic + with procedure Process (Node : Node_Access); + procedure Generic_Reverse_Iteration + (Tree : Tree_Type; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, but in + -- order from largest in range to earliest. + +end Ada.Containers.Red_Black_Trees.Generic_Keys; diff --git a/gcc/ada/libgnat/a-crbtgo.adb b/gcc/ada/libgnat/a-crbtgo.adb new file mode 100644 index 0000000..53fe273 --- /dev/null +++ b/gcc/ada/libgnat/a-crbtgo.adb @@ -0,0 +1,1159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- The references below to "CLR" refer to the following book, from which +-- several of the algorithms here were adapted: +-- Introduction to Algorithms +-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest +-- Publisher: The MIT Press (June 18, 1990) +-- ISBN: 0262031418 + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Operations is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access); + + procedure Delete_Swap (Tree : in out Tree_Type; Z, Y : Node_Access); + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access); + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access); + +-- Why is all the following code commented out ??? + +-- --------------------- +-- -- Check_Invariant -- +-- --------------------- + +-- procedure Check_Invariant (Tree : Tree_Type) is +-- Root : constant Node_Access := Tree.Root; +-- +-- function Check (Node : Node_Access) return Natural; +-- +-- ----------- +-- -- Check -- +-- ----------- +-- +-- function Check (Node : Node_Access) return Natural is +-- begin +-- if Node = null then +-- return 0; +-- end if; +-- +-- if Color (Node) = Red then +-- declare +-- L : constant Node_Access := Left (Node); +-- begin +-- pragma Assert (L = null or else Color (L) = Black); +-- null; +-- end; +-- +-- declare +-- R : constant Node_Access := Right (Node); +-- begin +-- pragma Assert (R = null or else Color (R) = Black); +-- null; +-- end; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL; +-- end; +-- end if; +-- +-- declare +-- NL : constant Natural := Check (Left (Node)); +-- NR : constant Natural := Check (Right (Node)); +-- begin +-- pragma Assert (NL = NR); +-- return NL + 1; +-- end; +-- end Check; +-- +-- -- Start of processing for Check_Invariant +-- +-- begin +-- if Root = null then +-- pragma Assert (Tree.First = null); +-- pragma Assert (Tree.Last = null); +-- pragma Assert (Tree.Length = 0); +-- null; +-- +-- else +-- pragma Assert (Color (Root) = Black); +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and Tree.First = Tree.Root)); +-- pragma Assert (Left (Tree.First) = null); +-- pragma Assert (Right (Tree.Last) = null); +-- +-- declare +-- L : constant Node_Access := Left (Root); +-- R : constant Node_Access := Right (Root); +-- NL : constant Natural := Check (L); +-- NR : constant Natural := Check (R); +-- begin +-- pragma Assert (NL = NR); +-- null; +-- end; +-- end if; +-- end Check_Invariant; + + ------------------ + -- Delete_Fixup -- + ------------------ + + procedure Delete_Fixup (Tree : in out Tree_Type; Node : Node_Access) is + + -- CLR p274 + + X : Node_Access := Node; + W : Node_Access; + + begin + while X /= Tree.Root + and then Color (X) = Black + loop + if X = Left (Parent (X)) then + W := Right (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Left_Rotate (Tree, Parent (X)); + W := Right (Parent (X)); + end if; + + if (Left (W) = null or else Color (Left (W)) = Black) + and then + (Right (W) = null or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Right (W) = null + or else Color (Right (W)) = Black + then + -- As a condition for setting the color of the left child to + -- black, the left child access value must be non-null. A + -- truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Left (W) /= null); + Set_Color (Left (W), Black); + + Set_Color (W, Red); + Right_Rotate (Tree, W); + W := Right (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Right (W), Black); + Left_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + + else + pragma Assert (X = Right (Parent (X))); + + W := Left (Parent (X)); + + if Color (W) = Red then + Set_Color (W, Black); + Set_Color (Parent (X), Red); + Right_Rotate (Tree, Parent (X)); + W := Left (Parent (X)); + end if; + + if (Left (W) = null or else Color (Left (W)) = Black) + and then + (Right (W) = null or else Color (Right (W)) = Black) + then + Set_Color (W, Red); + X := Parent (X); + + else + if Left (W) = null or else Color (Left (W)) = Black then + + -- As a condition for setting the color of the right child + -- to black, the right child access value must be non-null. + -- A truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Right (W) /= null); + Set_Color (Right (W), Black); + + Set_Color (W, Red); + Left_Rotate (Tree, W); + W := Left (Parent (X)); + end if; + + Set_Color (W, Color (Parent (X))); + Set_Color (Parent (X), Black); + Set_Color (Left (W), Black); + Right_Rotate (Tree, Parent (X)); + X := Tree.Root; + end if; + end if; + end loop; + + Set_Color (X, Black); + end Delete_Fixup; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p273 + + X, Y : Node_Access; + + Z : constant Node_Access := Node; + pragma Assert (Z /= null); + + begin + TC_Check (Tree.TC); + + -- Why are these all commented out ??? + +-- pragma Assert (Tree.Length > 0); +-- pragma Assert (Tree.Root /= null); +-- pragma Assert (Tree.First /= null); +-- pragma Assert (Tree.Last /= null); +-- pragma Assert (Parent (Tree.Root) = null); +-- pragma Assert ((Tree.Length > 1) +-- or else (Tree.First = Tree.Last +-- and then Tree.First = Tree.Root)); +-- pragma Assert ((Left (Node) = null) +-- or else (Parent (Left (Node)) = Node)); +-- pragma Assert ((Right (Node) = null) +-- or else (Parent (Right (Node)) = Node)); +-- pragma Assert (((Parent (Node) = null) and then (Tree.Root = Node)) +-- or else ((Parent (Node) /= null) and then +-- ((Left (Parent (Node)) = Node) +-- or else (Right (Parent (Node)) = Node)))); + + if Left (Z) = null then + if Right (Z) = null then + if Z = Tree.First then + Tree.First := Parent (Z); + end if; + + if Z = Tree.Last then + Tree.Last := Parent (Z); + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); + + if Z = Tree.Root then + pragma Assert (Tree.Length = 1); + pragma Assert (Parent (Z) = null); + Tree.Root := null; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), null); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), null); + end if; + + else + pragma Assert (Z /= Tree.Last); + + X := Right (Z); + + if Z = Tree.First then + Tree.First := Min (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + + elsif Right (Z) = null then + pragma Assert (Z /= Tree.First); + + X := Left (Z); + + if Z = Tree.Last then + Tree.Last := Max (X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), X); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), X); + end if; + + Set_Parent (X, Parent (Z)); + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + + else + pragma Assert (Z /= Tree.First); + pragma Assert (Z /= Tree.Last); + + Y := Next (Z); + pragma Assert (Left (Y) = null); + + X := Right (Y); + + if X = null then + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + Delete_Swap (Tree, Z, Y); + Set_Left (Parent (Z), Z); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + Set_Right (Y, Z); + Set_Parent (Z, Y); + Set_Left (Z, null); + Set_Right (Z, null); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (Z) = null); + pragma Assert (Right (Z) = null); + + if Z = Right (Parent (Z)) then + Set_Right (Parent (Z), null); + else + pragma Assert (Z = Left (Parent (Z))); + Set_Left (Parent (Z), null); + end if; + + else + if Y = Left (Parent (Y)) then + pragma Assert (Parent (Y) /= Z); + + Delete_Swap (Tree, Z, Y); + + Set_Left (Parent (Z), X); + Set_Parent (X, Parent (Z)); + + else + pragma Assert (Y = Right (Parent (Y))); + pragma Assert (Parent (Y) = Z); + + Set_Parent (Y, Parent (Z)); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (Parent (Z)) then + Set_Left (Parent (Z), Y); + else + pragma Assert (Z = Right (Parent (Z))); + Set_Right (Parent (Z), Y); + end if; + + Set_Left (Y, Left (Z)); + Set_Parent (Left (Y), Y); + + declare + Y_Color : constant Color_Type := Color (Y); + begin + Set_Color (Y, Color (Z)); + Set_Color (Z, Y_Color); + end; + end if; + + if Color (Z) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + end if; + + Tree.Length := Tree.Length - 1; + end Delete_Node_Sans_Free; + + ----------------- + -- Delete_Swap -- + ----------------- + + procedure Delete_Swap + (Tree : in out Tree_Type; + Z, Y : Node_Access) + is + pragma Assert (Z /= Y); + pragma Assert (Parent (Y) /= Z); + + Y_Parent : constant Node_Access := Parent (Y); + Y_Color : constant Color_Type := Color (Y); + + begin + Set_Parent (Y, Parent (Z)); + Set_Left (Y, Left (Z)); + Set_Right (Y, Right (Z)); + Set_Color (Y, Color (Z)); + + if Tree.Root = Z then + Tree.Root := Y; + elsif Right (Parent (Y)) = Z then + Set_Right (Parent (Y), Y); + else + pragma Assert (Left (Parent (Y)) = Z); + Set_Left (Parent (Y), Y); + end if; + + if Right (Y) /= null then + Set_Parent (Right (Y), Y); + end if; + + if Left (Y) /= null then + Set_Parent (Left (Y), Y); + end if; + + Set_Parent (Z, Y_Parent); + Set_Color (Z, Y_Color); + Set_Left (Z, null); + Set_Right (Z, null); + end Delete_Swap; + + -------------------- + -- Generic_Adjust -- + -------------------- + + procedure Generic_Adjust (Tree : in out Tree_Type) is + N : constant Count_Type := Tree.Length; + Root : constant Node_Access := Tree.Root; + + begin + -- If the counts are nonzero, execution is technically erroneous, but + -- it seems friendly to allow things like concurrent "=" on shared + -- constants. + + Zero_Counts (Tree.TC); + + if N = 0 then + pragma Assert (Root = null); + return; + end if; + + Tree.Root := null; + Tree.First := null; + Tree.Last := null; + Tree.Length := 0; + + Tree.Root := Copy_Tree (Root); + Tree.First := Min (Tree.Root); + Tree.Last := Max (Tree.Root); + Tree.Length := N; + end Generic_Adjust; + + ------------------- + -- Generic_Clear -- + ------------------- + + procedure Generic_Clear (Tree : in out Tree_Type) is + Root : Node_Access := Tree.Root; + begin + TC_Check (Tree.TC); + + Tree := (First => null, + Last => null, + Root => null, + Length => 0, + TC => <>); + + Delete_Tree (Root); + end Generic_Clear; + + ----------------------- + -- Generic_Copy_Tree -- + ----------------------- + + function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access is + Target_Root : Node_Access := Copy_Node (Source_Root); + P, X : Node_Access; + + begin + if Right (Source_Root) /= null then + Set_Right + (Node => Target_Root, + Right => Generic_Copy_Tree (Right (Source_Root))); + + Set_Parent + (Node => Right (Target_Root), + Parent => Target_Root); + end if; + + P := Target_Root; + + X := Left (Source_Root); + while X /= null loop + declare + Y : constant Node_Access := Copy_Node (X); + begin + Set_Left (Node => P, Left => Y); + Set_Parent (Node => Y, Parent => P); + + if Right (X) /= null then + Set_Right + (Node => Y, + Right => Generic_Copy_Tree (Right (X))); + + Set_Parent + (Node => Right (Y), + Parent => Y); + end if; + + P := Y; + X := Left (X); + end; + end loop; + + return Target_Root; + + exception + when others => + Delete_Tree (Target_Root); + raise; + end Generic_Copy_Tree; + + ------------------------- + -- Generic_Delete_Tree -- + ------------------------- + + procedure Generic_Delete_Tree (X : in out Node_Access) is + Y : Node_Access; + pragma Warnings (Off, Y); + begin + while X /= null loop + Y := Right (X); + Generic_Delete_Tree (Y); + Y := Left (X); + Free (X); + X := Y; + end loop; + end Generic_Delete_Tree; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type) return Boolean is + begin + if Left.Length /= Right.Length then + return False; + end if; + + -- If the containers are empty, return a result immediately, so as to + -- not manipulate the tamper bits unnecessarily. + + if Left.Length = 0 then + return True; + end if; + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L_Node : Node_Access := Left.First; + R_Node : Node_Access := Right.First; + begin + while L_Node /= null loop + if not Is_Equal (L_Node, R_Node) then + return False; + end if; + + L_Node := Next (L_Node); + R_Node := Next (R_Node); + end loop; + end; + + return True; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (Tree : Tree_Type) is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= null loop + Iterate (Left (X)); + Process (X); + X := Right (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------ + -- Generic_Move -- + ------------------ + + procedure Generic_Move (Target, Source : in out Tree_Type) is + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Source.TC); + + Clear (Target); + + Target := Source; + + Source := (First => null, + Last => null, + Root => null, + Length => 0, + TC => <>); + end Generic_Move; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type) + is + N : Count_Type'Base; + + Node, Last_Node : Node_Access; + + begin + Clear (Tree); + + Count_Type'Base'Read (Stream, N); + pragma Assert (N >= 0); + + if N = 0 then + return; + end if; + + Node := Read_Node (Stream); + pragma Assert (Node /= null); + pragma Assert (Color (Node) = Red); + + Set_Color (Node, Black); + + Tree.Root := Node; + Tree.First := Node; + Tree.Last := Node; + + Tree.Length := 1; + + for J in Count_Type range 2 .. N loop + Last_Node := Node; + pragma Assert (Last_Node = Tree.Last); + + Node := Read_Node (Stream); + pragma Assert (Node /= null); + pragma Assert (Color (Node) = Red); + + Set_Right (Node => Last_Node, Right => Node); + Tree.Last := Node; + Set_Parent (Node => Node, Parent => Last_Node); + Rebalance_For_Insert (Tree, Node); + Tree.Length := Tree.Length + 1; + end loop; + end Generic_Read; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration (Tree : Tree_Type) + is + procedure Iterate (P : Node_Access); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Node_Access) is + X : Node_Access := P; + begin + while X /= null loop + Iterate (Right (X)); + Process (X); + X := Left (X); + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type) + is + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Write_Node (Stream, Node); + end Process; + + -- Start of processing for Generic_Write + + begin + Count_Type'Base'Write (Stream, Tree.Length); + Iterate (Tree); + end Generic_Write; + + ----------------- + -- Left_Rotate -- + ----------------- + + procedure Left_Rotate (Tree : in out Tree_Type; X : Node_Access) is + + -- CLR p266 + + Y : constant Node_Access := Right (X); + pragma Assert (Y /= null); + + begin + Set_Right (X, Left (Y)); + + if Left (Y) /= null then + Set_Parent (Left (Y), X); + end if; + + Set_Parent (Y, Parent (X)); + + if X = Tree.Root then + Tree.Root := Y; + elsif X = Left (Parent (X)) then + Set_Left (Parent (X), Y); + else + pragma Assert (X = Right (Parent (X))); + Set_Right (Parent (X), Y); + end if; + + Set_Left (Y, X); + Set_Parent (X, Y); + end Left_Rotate; + + --------- + -- Max -- + --------- + + function Max (Node : Node_Access) return Node_Access is + + -- CLR p248 + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Right (X); + + if Y = null then + return X; + end if; + + X := Y; + end loop; + end Max; + + --------- + -- Min -- + --------- + + function Min (Node : Node_Access) return Node_Access is + + -- CLR p248 + + X : Node_Access := Node; + Y : Node_Access; + + begin + loop + Y := Left (X); + + if Y = null then + return X; + end if; + + X := Y; + end loop; + end Min; + + ---------- + -- Next -- + ---------- + + function Next (Node : Node_Access) return Node_Access is + begin + -- CLR p249 + + if Node = null then + return null; + end if; + + if Right (Node) /= null then + return Min (Right (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= null + and then X = Right (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + return Y; + end; + end Next; + + -------------- + -- Previous -- + -------------- + + function Previous (Node : Node_Access) return Node_Access is + begin + if Node = null then + return null; + end if; + + if Left (Node) /= null then + return Max (Left (Node)); + end if; + + declare + X : Node_Access := Node; + Y : Node_Access := Parent (Node); + + begin + while Y /= null + and then X = Left (Y) + loop + X := Y; + Y := Parent (Y); + end loop; + + return Y; + end; + end Previous; + + -------------------------- + -- Rebalance_For_Insert -- + -------------------------- + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type; + Node : Node_Access) + is + -- CLR p.268 + + X : Node_Access := Node; + pragma Assert (X /= null); + pragma Assert (Color (X) = Red); + + Y : Node_Access; + + begin + while X /= Tree.Root and then Color (Parent (X)) = Red loop + if Parent (X) = Left (Parent (Parent (X))) then + Y := Right (Parent (Parent (X))); + + if Y /= null and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Right (Parent (X)) then + X := Parent (X); + Left_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Right_Rotate (Tree, Parent (Parent (X))); + end if; + + else + pragma Assert (Parent (X) = Right (Parent (Parent (X)))); + + Y := Left (Parent (Parent (X))); + + if Y /= null and then Color (Y) = Red then + Set_Color (Parent (X), Black); + Set_Color (Y, Black); + Set_Color (Parent (Parent (X)), Red); + X := Parent (Parent (X)); + + else + if X = Left (Parent (X)) then + X := Parent (X); + Right_Rotate (Tree, X); + end if; + + Set_Color (Parent (X), Black); + Set_Color (Parent (Parent (X)), Red); + Left_Rotate (Tree, Parent (Parent (X))); + end if; + end if; + end loop; + + Set_Color (Tree.Root, Black); + end Rebalance_For_Insert; + + ------------------ + -- Right_Rotate -- + ------------------ + + procedure Right_Rotate (Tree : in out Tree_Type; Y : Node_Access) is + X : constant Node_Access := Left (Y); + pragma Assert (X /= null); + + begin + Set_Left (Y, Right (X)); + + if Right (X) /= null then + Set_Parent (Right (X), Y); + end if; + + Set_Parent (X, Parent (Y)); + + if Y = Tree.Root then + Tree.Root := X; + elsif Y = Left (Parent (Y)) then + Set_Left (Parent (Y), X); + else + pragma Assert (Y = Right (Parent (Y))); + Set_Right (Parent (Y), X); + end if; + + Set_Right (X, Y); + Set_Parent (Y, X); + end Right_Rotate; + + --------- + -- Vet -- + --------- + + function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean is + begin + if Node = null then + return True; + end if; + + if Parent (Node) = Node + or else Left (Node) = Node + or else Right (Node) = Node + then + return False; + end if; + + if Tree.Length = 0 + or else Tree.Root = null + or else Tree.First = null + or else Tree.Last = null + then + return False; + end if; + + if Parent (Tree.Root) /= null then + return False; + end if; + + if Left (Tree.First) /= null then + return False; + end if; + + if Right (Tree.Last) /= null then + return False; + end if; + + if Tree.Length = 1 then + if Tree.First /= Tree.Last + or else Tree.First /= Tree.Root + then + return False; + end if; + + if Node /= Tree.First then + return False; + end if; + + if Parent (Node) /= null + or else Left (Node) /= null + or else Right (Node) /= null + then + return False; + end if; + + return True; + end if; + + if Tree.First = Tree.Last then + return False; + end if; + + if Tree.Length = 2 then + if Tree.First /= Tree.Root + and then Tree.Last /= Tree.Root + then + return False; + end if; + + if Tree.First /= Node + and then Tree.Last /= Node + then + return False; + end if; + end if; + + if Left (Node) /= null + and then Parent (Left (Node)) /= Node + then + return False; + end if; + + if Right (Node) /= null + and then Parent (Right (Node)) /= Node + then + return False; + end if; + + if Parent (Node) = null then + if Tree.Root /= Node then + return False; + end if; + + elsif Left (Parent (Node)) /= Node + and then Right (Parent (Node)) /= Node + then + return False; + end if; + + return True; + end Vet; + +end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/libgnat/a-crbtgo.ads b/gcc/ada/libgnat/a-crbtgo.ads new file mode 100644 index 0000000..6cc9d96 --- /dev/null +++ b/gcc/ada/libgnat/a-crbtgo.ads @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement the ordered containers. This package +-- declares the tree operations that do not depend on keys. + +with Ada.Streams; use Ada.Streams; + +generic + with package Tree_Types is new Generic_Tree_Types (<>); + use Tree_Types, Tree_Types.Implementation; + + with function Parent (Node : Node_Access) return Node_Access is <>; + with procedure Set_Parent (Node : Node_Access; Parent : Node_Access) is <>; + with function Left (Node : Node_Access) return Node_Access is <>; + with procedure Set_Left (Node : Node_Access; Left : Node_Access) is <>; + with function Right (Node : Node_Access) return Node_Access is <>; + with procedure Set_Right (Node : Node_Access; Right : Node_Access) is <>; + with function Color (Node : Node_Access) return Color_Type is <>; + with procedure Set_Color (Node : Node_Access; Color : Color_Type) is <>; + +package Ada.Containers.Red_Black_Trees.Generic_Operations is + pragma Pure; + + function Min (Node : Node_Access) return Node_Access; + -- Returns the smallest-valued node of the subtree rooted at Node + + function Max (Node : Node_Access) return Node_Access; + -- Returns the largest-valued node of the subtree rooted at Node + + -- NOTE: The Check_Invariant operation was used during early + -- development of the red-black tree. Now that the tree type + -- implementation has matured, we don't really need Check_Invariant + -- anymore. + + -- procedure Check_Invariant (Tree : Tree_Type); + + function Vet (Tree : Tree_Type; Node : Node_Access) return Boolean; + -- Inspects Node to determine (to the extent possible) whether + -- the node is valid; used to detect if the node is dangling. + + function Next (Node : Node_Access) return Node_Access; + -- Returns the smallest node greater than Node + + function Previous (Node : Node_Access) return Node_Access; + -- Returns the largest node less than Node + + generic + with function Is_Equal (L, R : Node_Access) return Boolean; + function Generic_Equal (Left, Right : Tree_Type) return Boolean; + -- Uses Is_Equal to perform a node-by-node comparison of the + -- Left and Right trees; processing stops as soon as the first + -- non-equal node is found. + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type; + Node : Node_Access); + -- Removes Node from Tree without deallocating the node. If Tree + -- is busy then Program_Error is raised. + + generic + with procedure Free (X : in out Node_Access); + procedure Generic_Delete_Tree (X : in out Node_Access); + -- Deallocates the tree rooted at X, calling Free on each node + + generic + with function Copy_Node (Source : Node_Access) return Node_Access; + with procedure Delete_Tree (X : in out Node_Access); + function Generic_Copy_Tree (Source_Root : Node_Access) return Node_Access; + -- Copies the tree rooted at Source_Root, using Copy_Node to copy each + -- node of the source tree. If Copy_Node propagates an exception + -- (e.g. Storage_Error), then Delete_Tree is first used to deallocate + -- the target tree, and then the exception is propagated. + + generic + with function Copy_Tree (Root : Node_Access) return Node_Access; + procedure Generic_Adjust (Tree : in out Tree_Type); + -- Used to implement controlled Adjust. On input to Generic_Adjust, Tree + -- holds a bitwise (shallow) copy of the source tree (as would be the case + -- when controlled Adjust is called). On output, Tree holds its own (deep) + -- copy of the source tree, which is constructed by calling Copy_Tree. + + generic + with procedure Delete_Tree (X : in out Node_Access); + procedure Generic_Clear (Tree : in out Tree_Type); + -- Clears Tree by deallocating all of its nodes. If Tree is busy then + -- Program_Error is raised. + + generic + with procedure Clear (Tree : in out Tree_Type); + procedure Generic_Move (Target, Source : in out Tree_Type); + -- Moves the tree belonging to Source onto Target. If Source is busy then + -- Program_Error is raised. Otherwise Target is first cleared (by calling + -- Clear, to deallocate its existing tree), then given the Source tree, and + -- then finally Source is cleared (by setting its pointers to null). + + generic + with procedure Process (Node : Node_Access) is <>; + procedure Generic_Iteration (Tree : Tree_Type); + -- Calls Process for each node in Tree, in order from smallest-valued + -- node to largest-valued node. + + generic + with procedure Process (Node : Node_Access) is <>; + procedure Generic_Reverse_Iteration (Tree : Tree_Type); + -- Calls Process for each node in Tree, in order from largest-valued + -- node to smallest-valued node. + + generic + with procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Access); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type); + -- Used to implement stream attribute T'Write. Generic_Write + -- first writes the number of nodes into Stream, then calls + -- Write_Node for each node in Tree. + + generic + with procedure Clear (Tree : in out Tree_Type); + with function Read_Node + (Stream : not null access Root_Stream_Type'Class) return Node_Access; + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type); + -- Used to implement stream attribute T'Read. Generic_Read + -- first clears Tree. It then reads the number of nodes out of + -- Stream, and calls Read_Node for each node in Stream. + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type; + Node : Node_Access); + -- This rebalances Tree to complete the insertion of Node (which + -- must already be linked in at its proper insertion position). + +end Ada.Containers.Red_Black_Trees.Generic_Operations; diff --git a/gcc/ada/libgnat/a-crdlli.adb b/gcc/ada/libgnat/a-crdlli.adb new file mode 100644 index 0000000..92ec3f3 --- /dev/null +++ b/gcc/ada/libgnat/a-crdlli.adb @@ -0,0 +1,1503 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Restricted_Doubly_Linked_Lists is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Allocate + (Container : in out List'Class; + New_Item : Element_Type; + New_Node : out Count_Type); + + procedure Free + (Container : in out List'Class; + X : Count_Type); + + procedure Insert_Internal + (Container : in out List'Class; + Before : Count_Type; + New_Node : Count_Type); + + function Vet (Position : Cursor) return Boolean; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : List) return Boolean is + LN : Node_Array renames Left.Nodes; + RN : Node_Array renames Right.Nodes; + + LI : Count_Type := Left.First; + RI : Count_Type := Right.First; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + for J in 1 .. Left.Length loop + if LN (LI).Element /= RN (RI).Element then + return False; + end if; + + LI := LN (LI).Next; + RI := RN (RI).Next; + end loop; + + return True; + end "="; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Container : in out List'Class; + New_Item : Element_Type; + New_Node : out Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Free >= 0 then + New_Node := Container.Free; + N (New_Node).Element := New_Item; + Container.Free := N (New_Node).Next; + + else + New_Node := abs Container.Free; + N (New_Node).Element := New_Item; + Container.Free := Container.Free - 1; + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, No_Element, New_Item, Count); + end Append; + + ------------ + -- Assign -- + ------------ + + procedure Assign (Target : in out List; Source : List) is + begin + if Target'Address = Source'Address then + return; + end if; + + if Target.Capacity < Source.Length then + raise Constraint_Error; -- ??? + end if; + + Clear (Target); + + declare + N : Node_Array renames Source.Nodes; + J : Count_Type := Source.First; + + begin + while J /= 0 loop + Append (Target, N (J).Element); + J := N (J).Next; + end loop; + end; + end Assign; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Container : in out List) is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Container.Length = 0 then + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); +-- pragma Assert (Container.Busy = 0); +-- pragma Assert (Container.Lock = 0); + return; + end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + while Container.Length > 1 loop + X := Container.First; + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + + X := Container.First; + + Container.First := 0; + Container.Last := 0; + Container.Length := 0; + + Free (Container, X); + end Clear; + + -------------- + -- Contains -- + -------------- + + function Contains + (Container : List; + Item : Element_Type) return Boolean + is + begin + return Find (Container, Item) /= No_Element; + end Contains; + + ------------ + -- Delete -- + ------------ + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Delete"); + + if Position.Node = Container.First then + Delete_First (Container, Count); + Position := No_Element; + return; + end if; + + if Count = 0 then + Position := No_Element; + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Container.First >= 1); + pragma Assert (Container.Last >= 1); + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + for Index in 1 .. Count loop + pragma Assert (Container.Length >= 2); + + X := Position.Node; + Container.Length := Container.Length - 1; + + if X = Container.Last then + Position := No_Element; + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Free (Container, X); + return; + end if; + + Position.Node := N (X).Next; + + N (N (X).Next).Prev := N (X).Prev; + N (N (X).Prev).Next := N (X).Next; + + Free (Container, X); + end loop; + + Position := No_Element; + end Delete; + + ------------------ + -- Delete_First -- + ------------------ + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + for I in 1 .. Count loop + X := Container.First; + pragma Assert (N (N (X).Next).Prev = Container.First); + + Container.First := N (X).Next; + N (Container.First).Prev := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_First; + + ----------------- + -- Delete_Last -- + ----------------- + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1) + is + N : Node_Array renames Container.Nodes; + X : Count_Type; + + begin + if Count >= Container.Length then + Clear (Container); + return; + end if; + + if Count = 0 then + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + for I in 1 .. Count loop + X := Container.Last; + pragma Assert (N (N (X).Prev).Next = Container.Last); + + Container.Last := N (X).Prev; + N (Container.Last).Next := 0; + + Container.Length := Container.Length - 1; + + Free (Container, X); + end loop; + end Delete_Last; + + ------------- + -- Element -- + ------------- + + function Element (Position : Cursor) return Element_Type is + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Element"); + + declare + N : Node_Array renames Position.Container.Nodes; + begin + return N (Position.Node).Element; + end; + end Element; + + ---------- + -- Find -- + ---------- + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type := Position.Node; + + begin + if Node = 0 then + Node := Container.First; + + else + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Find"); + end if; + + while Node /= 0 loop + if Nodes (Node).Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := Nodes (Node).Next; + end loop; + + return No_Element; + end Find; + + ----------- + -- First -- + ----------- + + function First (Container : List) return Cursor is + begin + if Container.First = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.First); + end First; + + ------------------- + -- First_Element -- + ------------------- + + function First_Element (Container : List) return Element_Type is + N : Node_Array renames Container.Nodes; + + begin + if Container.First = 0 then + raise Constraint_Error; + end if; + + return N (Container.First).Element; + end First_Element; + + ---------- + -- Free -- + ---------- + + procedure Free + (Container : in out List'Class; + X : Count_Type) + is + pragma Assert (X > 0); + pragma Assert (X <= Container.Capacity); + + N : Node_Array renames Container.Nodes; + + begin + N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Container.Free >= 0 then + N (X).Next := Container.Free; + Container.Free := X; + + elsif X + 1 = abs Container.Free then + N (X).Next := 0; -- Not strictly necessary, but marginally safer + Container.Free := Container.Free + 1; + + else + Container.Free := abs Container.Free; + + if Container.Free > Container.Capacity then + Container.Free := 0; + + else + for I in Container.Free .. Container.Capacity - 1 loop + N (I).Next := I + 1; + end loop; + + N (Container.Capacity).Next := 0; + end if; + + N (X).Next := Container.Free; + Container.Free := X; + end if; + end Free; + + --------------------- + -- Generic_Sorting -- + --------------------- + + package body Generic_Sorting is + + --------------- + -- Is_Sorted -- + --------------- + + function Is_Sorted (Container : List) return Boolean is + Nodes : Node_Array renames Container.Nodes; + Node : Count_Type := Container.First; + + begin + for I in 2 .. Container.Length loop + if Nodes (Nodes (Node).Next).Element < Nodes (Node).Element then + return False; + end if; + + Node := Nodes (Node).Next; + end loop; + + return True; + end Is_Sorted; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Container : in out List) is + N : Node_Array renames Container.Nodes; + + procedure Partition (Pivot, Back : Count_Type); + procedure Sort (Front, Back : Count_Type); + + --------------- + -- Partition -- + --------------- + + procedure Partition (Pivot, Back : Count_Type) is + Node : Count_Type := N (Pivot).Next; + + begin + while Node /= Back loop + if N (Node).Element < N (Pivot).Element then + declare + Prev : constant Count_Type := N (Node).Prev; + Next : constant Count_Type := N (Node).Next; + + begin + N (Prev).Next := Next; + + if Next = 0 then + Container.Last := Prev; + else + N (Next).Prev := Prev; + end if; + + N (Node).Next := Pivot; + N (Node).Prev := N (Pivot).Prev; + + N (Pivot).Prev := Node; + + if N (Node).Prev = 0 then + Container.First := Node; + else + N (N (Node).Prev).Next := Node; + end if; + + Node := Next; + end; + + else + Node := N (Node).Next; + end if; + end loop; + end Partition; + + ---------- + -- Sort -- + ---------- + + procedure Sort (Front, Back : Count_Type) is + Pivot : constant Count_Type := + (if Front = 0 then Container.First else N (Front).Next); + begin + if Pivot /= Back then + Partition (Pivot, Back); + Sort (Front, Pivot); + Sort (Pivot, Back); + end if; + end Sort; + + -- Start of processing for Sort + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + Sort (Front => 0, Back => 0); + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Sort; + + end Generic_Sorting; + + ----------------- + -- Has_Element -- + ----------------- + + function Has_Element (Position : Cursor) return Boolean is + begin + pragma Assert (Vet (Position), "bad cursor in Has_Element"); + return Position.Node /= 0; + end Has_Element; + + ------------ + -- Insert -- + ------------ + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1) + is + First_Node : Count_Type; + New_Node : Count_Type; + + begin + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad cursor in Insert"); + end if; + + if Count = 0 then + Position := Before; + return; + end if; + + if Container.Length > Container.Capacity - Count then + raise Constraint_Error; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + Allocate (Container, New_Item, New_Node); + First_Node := New_Node; + Insert_Internal (Container, Before.Node, New_Node); + + for Index in 2 .. Count loop + Allocate (Container, New_Item, New_Node); + Insert_Internal (Container, Before.Node, New_Node); + end loop; + + Position := Cursor'(Container'Unrestricted_Access, First_Node); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1) + is + Position : Cursor; + pragma Unreferenced (Position); + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1) + is + New_Item : Element_Type; -- Do we need to reinit node ??? + pragma Warnings (Off, New_Item); + + begin + Insert (Container, Before, New_Item, Position, Count); + end Insert; + + --------------------- + -- Insert_Internal -- + --------------------- + + procedure Insert_Internal + (Container : in out List'Class; + Before : Count_Type; + New_Node : Count_Type) + is + N : Node_Array renames Container.Nodes; + + begin + if Container.Length = 0 then + pragma Assert (Before = 0); + pragma Assert (Container.First = 0); + pragma Assert (Container.Last = 0); + + Container.First := New_Node; + Container.Last := New_Node; + + N (Container.First).Prev := 0; + N (Container.Last).Next := 0; + + elsif Before = 0 then + pragma Assert (N (Container.Last).Next = 0); + + N (Container.Last).Next := New_Node; + N (New_Node).Prev := Container.Last; + + Container.Last := New_Node; + N (Container.Last).Next := 0; + + elsif Before = Container.First then + pragma Assert (N (Container.First).Prev = 0); + + N (Container.First).Prev := New_Node; + N (New_Node).Next := Container.First; + + Container.First := New_Node; + N (Container.First).Prev := 0; + + else + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + + N (New_Node).Next := Before; + N (New_Node).Prev := N (Before).Prev; + + N (N (Before).Prev).Next := New_Node; + N (Before).Prev := New_Node; + end if; + + Container.Length := Container.Length + 1; + end Insert_Internal; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Container : List) return Boolean is + begin + return Container.Length = 0; + end Is_Empty; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + C : List renames Container'Unrestricted_Access.all; + N : Node_Array renames C.Nodes; +-- B : Natural renames C.Busy; + + Node : Count_Type := Container.First; + + Index : Count_Type := 0; + Index_Max : constant Count_Type := Container.Length; + + begin + if Index_Max = 0 then + pragma Assert (Node = 0); + return; + end if; + + loop + pragma Assert (Node /= 0); + + Process (Cursor'(C'Unchecked_Access, Node)); + pragma Assert (Container.Length = Index_Max); + pragma Assert (N (Node).Prev /= -1); + + Node := N (Node).Next; + Index := Index + 1; + + if Index = Index_Max then + pragma Assert (Node = 0); + return; + end if; + end loop; + end Iterate; + + ---------- + -- Last -- + ---------- + + function Last (Container : List) return Cursor is + begin + if Container.Last = 0 then + return No_Element; + end if; + + return Cursor'(Container'Unrestricted_Access, Container.Last); + end Last; + + ------------------ + -- Last_Element -- + ------------------ + + function Last_Element (Container : List) return Element_Type is + N : Node_Array renames Container.Nodes; + + begin + if Container.Last = 0 then + raise Constraint_Error; + end if; + + return N (Container.Last).Element; + end Last_Element; + + ------------ + -- Length -- + ------------ + + function Length (Container : List) return Count_Type is + begin + return Container.Length; + end Length; + + ---------- + -- Next -- + ---------- + + procedure Next (Position : in out Cursor) is + begin + Position := Next (Position); + end Next; + + function Next (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Next"); + + declare + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Next; + + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Next; + + ------------- + -- Prepend -- + ------------- + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1) + is + begin + Insert (Container, First (Container), New_Item, Count); + end Prepend; + + -------------- + -- Previous -- + -------------- + + procedure Previous (Position : in out Cursor) is + begin + Position := Previous (Position); + end Previous; + + function Previous (Position : Cursor) return Cursor is + begin + if Position.Node = 0 then + return No_Element; + end if; + + pragma Assert (Vet (Position), "bad cursor in Previous"); + + declare + Nodes : Node_Array renames Position.Container.Nodes; + Node : constant Count_Type := Nodes (Position.Node).Prev; + begin + if Node = 0 then + return No_Element; + end if; + + return Cursor'(Position.Container, Node); + end; + end Previous; + + ------------------- + -- Query_Element -- + ------------------- + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Query_Element"); + + declare + C : List renames Position.Container.all'Unrestricted_Access.all; + N : Node_Type renames C.Nodes (Position.Node); + + begin + Process (N.Element); + pragma Assert (N.Prev >= 0); + end; + end Query_Element; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type) + is + begin + if Position.Container = null then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + +-- if Container.Lock > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Vet (Position), "bad cursor in Replace_Element"); + + declare + N : Node_Array renames Container.Nodes; + begin + N (Position.Node).Element := New_Item; + end; + end Replace_Element; + + ---------------------- + -- Reverse_Elements -- + ---------------------- + + procedure Reverse_Elements (Container : in out List) is + N : Node_Array renames Container.Nodes; + I : Count_Type := Container.First; + J : Count_Type := Container.Last; + + procedure Swap (L, R : Count_Type); + + ---------- + -- Swap -- + ---------- + + procedure Swap (L, R : Count_Type) is + LN : constant Count_Type := N (L).Next; + LP : constant Count_Type := N (L).Prev; + + RN : constant Count_Type := N (R).Next; + RP : constant Count_Type := N (R).Prev; + + begin + if LP /= 0 then + N (LP).Next := R; + end if; + + if RN /= 0 then + N (RN).Prev := L; + end if; + + N (L).Next := RN; + N (R).Prev := LP; + + if LN = R then + pragma Assert (RP = L); + + N (L).Prev := R; + N (R).Next := L; + + else + N (L).Prev := RP; + N (RP).Next := L; + + N (R).Next := LN; + N (LN).Prev := R; + end if; + end Swap; + + -- Start of processing for Reverse_Elements + + begin + if Container.Length <= 1 then + return; + end if; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + Container.First := J; + Container.Last := I; + loop + Swap (L => I, R => J); + + J := N (J).Next; + exit when I = J; + + I := N (I).Prev; + exit when I = J; + + Swap (L => J, R => I); + + I := N (I).Next; + exit when I = J; + + J := N (J).Prev; + exit when I = J; + end loop; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Reverse_Elements; + + ------------------ + -- Reverse_Find -- + ------------------ + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor + is + N : Node_Array renames Container.Nodes; + Node : Count_Type := Position.Node; + + begin + if Node = 0 then + Node := Container.Last; + + else + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Reverse_Find"); + end if; + + while Node /= 0 loop + if N (Node).Element = Item then + return Cursor'(Container'Unrestricted_Access, Node); + end if; + + Node := N (Node).Prev; + end loop; + + return No_Element; + end Reverse_Find; + + --------------------- + -- Reverse_Iterate -- + --------------------- + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)) + is + C : List renames Container'Unrestricted_Access.all; + N : Node_Array renames C.Nodes; +-- B : Natural renames C.Busy; + + Node : Count_Type := Container.Last; + + Index : Count_Type := 0; + Index_Max : constant Count_Type := Container.Length; + + begin + if Index_Max = 0 then + pragma Assert (Node = 0); + return; + end if; + + loop + pragma Assert (Node > 0); + + Process (Cursor'(C'Unchecked_Access, Node)); + pragma Assert (Container.Length = Index_Max); + pragma Assert (N (Node).Prev /= -1); + + Node := N (Node).Prev; + Index := Index + 1; + + if Index = Index_Max then + pragma Assert (Node = 0); + return; + end if; + end loop; + end Reverse_Iterate; + + ------------ + -- Splice -- + ------------ + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : in out Cursor) + is + N : Node_Array renames Container.Nodes; + + begin + if Before.Container /= null then + if Before.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Before), "bad Before cursor in Splice"); + end if; + + if Position.Node = 0 then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad Position cursor in Splice"); + + if Position.Node = Before.Node + or else N (Position.Node).Next = Before.Node + then + return; + end if; + + pragma Assert (Container.Length >= 2); + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + if Before.Node = 0 then + pragma Assert (Position.Node /= Container.Last); + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.Last).Next := Position.Node; + N (Position.Node).Prev := Container.Last; + + Container.Last := Position.Node; + N (Container.Last).Next := 0; + + return; + end if; + + if Before.Node = Container.First then + pragma Assert (Position.Node /= Container.First); + + if Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (Container.First).Prev := Position.Node; + N (Position.Node).Next := Container.First; + + Container.First := Position.Node; + N (Container.First).Prev := 0; + + return; + end if; + + if Position.Node = Container.First then + Container.First := N (Position.Node).Next; + N (Container.First).Prev := 0; + + elsif Position.Node = Container.Last then + Container.Last := N (Position.Node).Prev; + N (Container.Last).Next := 0; + + else + N (N (Position.Node).Prev).Next := N (Position.Node).Next; + N (N (Position.Node).Next).Prev := N (Position.Node).Prev; + end if; + + N (N (Before.Node).Prev).Next := Position.Node; + N (Position.Node).Prev := N (Before.Node).Prev; + + N (Before.Node).Prev := Position.Node; + N (Position.Node).Next := Before.Node; + + pragma Assert (N (Container.First).Prev = 0); + pragma Assert (N (Container.Last).Next = 0); + end Splice; + + ---------- + -- Swap -- + ---------- + + procedure Swap + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = 0 + or else J.Node = 0 + then + raise Constraint_Error; + end if; + + if I.Container /= Container'Unrestricted_Access + or else J.Container /= Container'Unrestricted_Access + then + raise Program_Error; + end if; + + if I.Node = J.Node then + return; + end if; + +-- if Container.Lock > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Vet (I), "bad I cursor in Swap"); + pragma Assert (Vet (J), "bad J cursor in Swap"); + + declare + N : Node_Array renames Container.Nodes; + + EI : Element_Type renames N (I.Node).Element; + EJ : Element_Type renames N (J.Node).Element; + + EI_Copy : constant Element_Type := EI; + + begin + EI := EJ; + EJ := EI_Copy; + end; + end Swap; + + ---------------- + -- Swap_Links -- + ---------------- + + procedure Swap_Links + (Container : in out List; + I, J : Cursor) + is + begin + if I.Node = 0 + or else J.Node = 0 + then + raise Constraint_Error; + end if; + + if I.Container /= Container'Unrestricted_Access + or else I.Container /= J.Container + then + raise Program_Error; + end if; + + if I.Node = J.Node then + return; + end if; + +-- if Container.Busy > 0 then +-- raise Program_Error; +-- end if; + + pragma Assert (Vet (I), "bad I cursor in Swap_Links"); + pragma Assert (Vet (J), "bad J cursor in Swap_Links"); + + declare + I_Next : constant Cursor := Next (I); + + J_Copy : Cursor := J; + pragma Warnings (Off, J_Copy); + + begin + if I_Next = J then + Splice (Container, Before => I, Position => J_Copy); + + else + declare + J_Next : constant Cursor := Next (J); + + I_Copy : Cursor := I; + pragma Warnings (Off, I_Copy); + + begin + if J_Next = I then + Splice (Container, Before => J, Position => I_Copy); + + else + pragma Assert (Container.Length >= 3); + + Splice (Container, Before => I_Next, Position => J_Copy); + Splice (Container, Before => J_Next, Position => I_Copy); + end if; + end; + end if; + end; + end Swap_Links; + + -------------------- + -- Update_Element -- + -------------------- + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)) + is + begin + if Position.Node = 0 then + raise Constraint_Error; + end if; + + if Position.Container /= Container'Unrestricted_Access then + raise Program_Error; + end if; + + pragma Assert (Vet (Position), "bad cursor in Update_Element"); + + declare + N : Node_Type renames Container.Nodes (Position.Node); + + begin + Process (N.Element); + pragma Assert (N.Prev >= 0); + end; + end Update_Element; + + --------- + -- Vet -- + --------- + + function Vet (Position : Cursor) return Boolean is + begin + if Position.Node = 0 then + return Position.Container = null; + end if; + + if Position.Container = null then + return False; + end if; + + declare + L : List renames Position.Container.all; + N : Node_Array renames L.Nodes; + + begin + if L.Length = 0 then + return False; + end if; + + if L.First = 0 then + return False; + end if; + + if L.Last = 0 then + return False; + end if; + + if Position.Node > L.Capacity then + return False; + end if; + + if N (Position.Node).Prev < 0 + or else N (Position.Node).Prev > L.Capacity + then + return False; + end if; + + if N (Position.Node).Next > L.Capacity then + return False; + end if; + + if N (L.First).Prev /= 0 then + return False; + end if; + + if N (L.Last).Next /= 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 + and then Position.Node /= L.First + then + return False; + end if; + + if N (Position.Node).Next = 0 + and then Position.Node /= L.Last + then + return False; + end if; + + if L.Length = 1 then + return L.First = L.Last; + end if; + + if L.First = L.Last then + return False; + end if; + + if N (L.First).Next = 0 then + return False; + end if; + + if N (L.Last).Prev = 0 then + return False; + end if; + + if N (N (L.First).Next).Prev /= L.First then + return False; + end if; + + if N (N (L.Last).Prev).Next /= L.Last then + return False; + end if; + + if L.Length = 2 then + if N (L.First).Next /= L.Last then + return False; + end if; + + if N (L.Last).Prev /= L.First then + return False; + end if; + + return True; + end if; + + if N (L.First).Next = L.Last then + return False; + end if; + + if N (L.Last).Prev = L.First then + return False; + end if; + + if Position.Node = L.First then + return True; + end if; + + if Position.Node = L.Last then + return True; + end if; + + if N (Position.Node).Next = 0 then + return False; + end if; + + if N (Position.Node).Prev = 0 then + return False; + end if; + + if N (N (Position.Node).Next).Prev /= Position.Node then + return False; + end if; + + if N (N (Position.Node).Prev).Next /= Position.Node then + return False; + end if; + + if L.Length = 3 then + if N (L.First).Next /= Position.Node then + return False; + end if; + + if N (L.Last).Prev /= Position.Node then + return False; + end if; + end if; + + return True; + end; + end Vet; + +end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-crdlli.ads b/gcc/ada/libgnat/a-crdlli.ads new file mode 100644 index 0000000..b73ee5a --- /dev/null +++ b/gcc/ada/libgnat/a-crdlli.ads @@ -0,0 +1,337 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RESTRICTED_DOUBLY_LINKED_LISTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- The doubly-linked list container provides constant-time insertion and +-- deletion at all positions, and allows iteration in both the forward and +-- reverse directions. This list form allocates storage for all nodes +-- statically (there is no dynamic allocation), and a discriminant is used to +-- specify the capacity. This container is also "restricted", meaning that +-- even though it does raise exceptions (as described below), it does not use +-- internal exception handlers. No state changes are made that would need to +-- be reverted (in the event of an exception), and so as a consequence, this +-- container cannot detect tampering (of cursors or elements). + +generic + type Element_Type is private; + + with function "=" (Left, Right : Element_Type) + return Boolean is <>; + +package Ada.Containers.Restricted_Doubly_Linked_Lists is + pragma Pure; + + type List (Capacity : Count_Type) is tagged limited private; + pragma Preelaborable_Initialization (List); + + type Cursor is private; + pragma Preelaborable_Initialization (Cursor); + + Empty_List : constant List; + -- The default value for list objects declared without an explicit + -- initialization expression. + + No_Element : constant Cursor; + -- The default value for cursor objects declared without an explicit + -- initialization expression. + + function "=" (Left, Right : List) return Boolean; + -- If Left denotes the same list object as Right, then equality returns + -- True. If the length of Left is different from the length of Right, then + -- it returns False. Otherwise, list equality iterates over Left and Right, + -- comparing the element of Left to the corresponding element of Right + -- using the generic actual equality operator for elements. If the elements + -- compare False, then the iteration terminates and list equality returns + -- False. Otherwise, if all elements return True, then list equality + -- returns True. + + procedure Assign (Target : in out List; Source : List); + -- If Target denotes the same list object as Source, the operation does + -- nothing. If Target.Capacity is less than Source.Length, then it raises + -- Constraint_Error. Otherwise, it clears Target, and then inserts each + -- element of Source into Target. + + function Length (Container : List) return Count_Type; + -- Returns the total number of (active) elements in Container + + function Is_Empty (Container : List) return Boolean; + -- Returns True if Container.Length is 0 + + procedure Clear (Container : in out List); + -- Deletes all elements from Container. Note that this is a bounded + -- container and so the element is not "deallocated" in the same sense that + -- an unbounded form would deallocate the element. Rather, the node is + -- relinked off of the active part of the list and onto the inactive part + -- of the list (the storage from which new elements are "allocated"). + + function Element (Position : Cursor) return Element_Type; + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, function Element returns the element designed by Position. + + procedure Replace_Element + (Container : in out List; + Position : Cursor; + New_Item : Element_Type); + -- If Position equals No_Element, then Constraint_Error is raised. If + -- Position is associated with a list object different from Container, + -- Program_Error is raised. Otherwise, the element designated by Position + -- is assigned the value New_Item. + + procedure Query_Element + (Position : Cursor; + Process : not null access procedure (Element : Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, it calls Process with (a constant view of) the element + -- designated by Position as the parameter. + + procedure Update_Element + (Container : in out List; + Position : Cursor; + Process : not null access procedure (Element : in out Element_Type)); + -- If Position equals No_Element, then Constraint_Error is raised. + -- Otherwise, it calls Process with (a variable view of) the element + -- designated by Position as the parameter. + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Count : Count_Type := 1); + -- Inserts Count new elements, all with the value New_Item, into Container, + -- immediately prior to the position specified by Before. If Before has the + -- value No_Element, this is interpreted to mean that the elements are + -- appended to the list. If Before is associated with a list object + -- different from Container, then Program_Error is raised. If there are + -- fewer than Count nodes available, then Constraint_Error is raised. + + procedure Insert + (Container : in out List; + Before : Cursor; + New_Item : Element_Type; + Position : out Cursor; + Count : Count_Type := 1); + -- Inserts elements into Container as described above, but with the + -- difference that cursor Position is returned, which designates the first + -- of the new elements inserted. If Count is 0, Position returns the value + -- Before. + + procedure Insert + (Container : in out List; + Before : Cursor; + Position : out Cursor; + Count : Count_Type := 1); + -- Inserts elements in Container as described above, but with the + -- difference that the new elements are initialized to the default value + -- for objects of type Element_Type. + + procedure Prepend + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + -- Inserts Count elements, all having the value New_Item, prior to the + -- first element of Container. + + procedure Append + (Container : in out List; + New_Item : Element_Type; + Count : Count_Type := 1); + -- Inserts Count elements, all having the value New_Item, following the + -- last element of Container. + + procedure Delete + (Container : in out List; + Position : in out Cursor; + Count : Count_Type := 1); + -- If Position equals No_Element, Constraint_Error is raised. If Position + -- is associated with a list object different from Container, then + -- Program_Error is raised. Otherwise, the Count nodes starting from + -- Position are removed from Container ("removed" meaning that the nodes + -- are unlinked from the active nodes of the list and relinked to inactive + -- storage). On return, Position is set to No_Element. + + procedure Delete_First + (Container : in out List; + Count : Count_Type := 1); + -- Removes the first Count nodes from Container + + procedure Delete_Last + (Container : in out List; + Count : Count_Type := 1); + -- Removes the last Count nodes from Container + + procedure Reverse_Elements (Container : in out List); + -- Relinks the nodes in reverse order + + procedure Swap + (Container : in out List; + I, J : Cursor); + -- If I or J equals No_Element, then Constraint_Error is raised. If I or J + -- is associated with a list object different from Container, then + -- Program_Error is raised. Otherwise, Swap exchanges (copies) the values + -- of the elements (on the nodes) designated by I and J. + + procedure Swap_Links + (Container : in out List; + I, J : Cursor); + -- If I or J equals No_Element, then Constraint_Error is raised. If I or J + -- is associated with a list object different from Container, then + -- Program_Error is raised. Otherwise, Swap exchanges (relinks) the nodes + -- designated by I and J. + + procedure Splice + (Container : in out List; + Before : Cursor; + Position : in out Cursor); + -- If Before is associated with a list object different from Container, + -- then Program_Error is raised. If Position equals No_Element, then + -- Constraint_Error is raised; if it associated with a list object + -- different from Container, then Program_Error is raised. Otherwise, the + -- node designated by Position is relinked immediately prior to Before. If + -- Before equals No_Element, this is interpreted to mean to move the node + -- designed by Position to the last end of the list. + + function First (Container : List) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the first element. + + function First_Element (Container : List) return Element_Type; + -- Equivalent to Element (First (Container)) + + function Last (Container : List) return Cursor; + -- If Container is empty, the function returns No_Element. Otherwise, it + -- returns a cursor designating the last element. + + function Last_Element (Container : List) return Element_Type; + -- Equivalent to Element (Last (Container)) + + function Next (Position : Cursor) return Cursor; + -- If Position equals No_Element or Last (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately follows the node designated by Position. + + procedure Next (Position : in out Cursor); + -- Equivalent to Position := Next (Position) + + function Previous (Position : Cursor) return Cursor; + -- If Position equals No_Element or First (Container), the function returns + -- No_Element. Otherwise, it returns a cursor designating the node that + -- immediately precedes the node designated by Position. + + procedure Previous (Position : in out Cursor); + -- Equivalent to Position := Previous (Position) + + function Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + -- Searches for the node whose element is equal to Item, starting from + -- Position and continuing to the last end of the list. If Position equals + -- No_Element, the search starts from the first node. If Position is + -- associated with a list object different from Container, then + -- Program_Error is raised. If no node is found having an element equal to + -- Item, then Find returns No_Element. + + function Reverse_Find + (Container : List; + Item : Element_Type; + Position : Cursor := No_Element) return Cursor; + -- Searches in reverse for the node whose element is equal to Item, + -- starting from Position and continuing to the first end of the list. If + -- Position equals No_Element, the search starts from the last node. If + -- Position is associated with a list object different from Container, then + -- Program_Error is raised. If no node is found having an element equal to + -- Item, then Reverse_Find returns No_Element. + + function Contains + (Container : List; + Item : Element_Type) return Boolean; + -- Equivalent to Container.Find (Item) /= No_Element + + function Has_Element (Position : Cursor) return Boolean; + -- Equivalent to Position /= No_Element + + procedure Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.First to Container.Last. + + procedure Reverse_Iterate + (Container : List; + Process : not null access procedure (Position : Cursor)); + -- Calls Process with a cursor designating each element of Container, in + -- order from Container.Last to Container.First. + + generic + with function "<" (Left, Right : Element_Type) return Boolean is <>; + package Generic_Sorting is + + function Is_Sorted (Container : List) return Boolean; + -- Returns False if there exists an element which is less than its + -- predecessor. + + procedure Sort (Container : in out List); + -- Sorts the elements of Container (by relinking nodes), according to + -- the order specified by the generic formal less-than operator, such + -- that smaller elements are first in the list. The sort is stable, + -- meaning that the relative order of elements is preserved. + + end Generic_Sorting; + +private + + type Node_Type is limited record + Prev : Count_Type'Base; + Next : Count_Type; + Element : Element_Type; + end record; + + type Node_Array is array (Count_Type range <>) of Node_Type; + + type List (Capacity : Count_Type) is tagged limited record + Nodes : Node_Array (1 .. Capacity) := (others => <>); + Free : Count_Type'Base := -1; + First : Count_Type := 0; + Last : Count_Type := 0; + Length : Count_Type := 0; + end record; + + type List_Access is access all List; + for List_Access'Storage_Size use 0; + + type Cursor is + record + Container : List_Access; + Node : Count_Type := 0; + end record; + + Empty_List : constant List := (0, others => <>); + + No_Element : constant Cursor := (null, 0); + +end Ada.Containers.Restricted_Doubly_Linked_Lists; diff --git a/gcc/ada/libgnat/a-csquin.ads b/gcc/ada/libgnat/a-csquin.ads new file mode 100644 index 0000000..4d64e5d --- /dev/null +++ b/gcc/ada/libgnat/a-csquin.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.SYNCHRONIZED_QUEUE_INTERFACES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + type Element_Type is private; + +package Ada.Containers.Synchronized_Queue_Interfaces is + pragma Pure; + + type Queue is synchronized interface; + + procedure Enqueue + (Container : in out Queue; + New_Item : Element_Type) is abstract + with Synchronization => By_Entry; + + procedure Dequeue + (Container : in out Queue; + Element : out Element_Type) is abstract + with Synchronization => By_Entry; + + function Current_Use (Container : Queue) return Count_Type is abstract; + + function Peak_Use (Container : Queue) return Count_Type is abstract; + +end Ada.Containers.Synchronized_Queue_Interfaces; diff --git a/gcc/ada/libgnat/a-cuprqu.adb b/gcc/ada/libgnat/a-cuprqu.adb new file mode 100644 index 0000000..9f3a858 --- /dev/null +++ b/gcc/ada/libgnat/a-cuprqu.adb @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_PRIORITY_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Unbounded_Priority_Queues is + + protected body Queue is + + ----------------- + -- Current_Use -- + ----------------- + + function Current_Use return Count_Type is + begin + return Q_Elems.Length; + end Current_Use; + + ------------- + -- Dequeue -- + ------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when Q_Elems.Length > 0 + is + -- Grab the first item of the set, and remove it from the set + + C : constant Cursor := First (Q_Elems); + begin + Element := Sets.Element (C).Item; + Delete_First (Q_Elems); + end Dequeue; + + -------------------------------- + -- Dequeue_Only_High_Priority -- + -------------------------------- + + procedure Dequeue_Only_High_Priority + (At_Least : Queue_Priority; + Element : in out Queue_Interfaces.Element_Type; + Success : out Boolean) + is + -- Grab the first item. If it exists and has appropriate priority, + -- set Success to True, and remove that item. Otherwise, set Success + -- to False. + + C : constant Cursor := First (Q_Elems); + begin + Success := Has_Element (C) and then + not Before (At_Least, Get_Priority (Sets.Element (C).Item)); + + if Success then + Element := Sets.Element (C).Item; + Delete_First (Q_Elems); + end if; + end Dequeue_Only_High_Priority; + + ------------- + -- Enqueue -- + ------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is + begin + Insert (Q_Elems, (Next_Sequence_Number, New_Item)); + Next_Sequence_Number := Next_Sequence_Number + 1; + + -- If we reached a new high-water mark, increase Max_Length + + if Q_Elems.Length > Max_Length then + pragma Assert (Max_Length + 1 = Q_Elems.Length); + Max_Length := Q_Elems.Length; + end if; + end Enqueue; + + -------------- + -- Peak_Use -- + -------------- + + function Peak_Use return Count_Type is + begin + return Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Unbounded_Priority_Queues; diff --git a/gcc/ada/libgnat/a-cuprqu.ads b/gcc/ada/libgnat/a-cuprqu.ads new file mode 100644 index 0000000..ad9e56f --- /dev/null +++ b/gcc/ada/libgnat/a-cuprqu.ads @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_PRIORITY_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; +with Ada.Containers.Ordered_Sets; +with Ada.Containers.Synchronized_Queue_Interfaces; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + type Queue_Priority is private; + + with function Get_Priority + (Element : Queue_Interfaces.Element_Type) return Queue_Priority is <>; + + with function Before + (Left, Right : Queue_Priority) return Boolean is <>; + + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Unbounded_Priority_Queues is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + + package Implementation is + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + -- We use an ordered set to hold the queue elements. This gives O(lg N) + -- performance in the worst case for Enqueue and Dequeue. + -- Sequence_Number is used to distinguish equivalent items. Each Enqueue + -- uses a higher Sequence_Number, so that a new item is placed after + -- already-enqueued equivalent items. + -- + -- At any time, the first set element is the one to be dequeued next (if + -- the queue is not empty). + + type Set_Elem is record + Sequence_Number : Count_Type; + Item : Queue_Interfaces.Element_Type; + end record; + + function "=" (X, Y : Queue_Interfaces.Element_Type) return Boolean is + (not Before (Get_Priority (X), Get_Priority (Y)) + and then not Before (Get_Priority (Y), Get_Priority (X))); + -- Elements are equal if neither is Before the other + + function "=" (X, Y : Set_Elem) return Boolean is + (X.Sequence_Number = Y.Sequence_Number and then X.Item = Y.Item); + -- Set_Elems are equal if the elements are equal, and the + -- Sequence_Numbers are equal. This is passed to Ordered_Sets. + + function "<" (X, Y : Set_Elem) return Boolean is + (if X.Item = Y.Item + then X.Sequence_Number < Y.Sequence_Number + else Before (Get_Priority (X.Item), Get_Priority (Y.Item))); + -- If the items are equal, Sequence_Number breaks the tie. Otherwise, + -- use Before. This is passed to Ordered_Sets. + + pragma Suppress (Container_Checks); + package Sets is new Ada.Containers.Ordered_Sets (Set_Elem); + + end Implementation; + + use Implementation, Implementation.Sets; + + protected type Queue (Ceiling : System.Any_Priority := Default_Ceiling) + with + Priority => Ceiling + is new Queue_Interfaces.Queue with + + overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + -- The priority queue operation Dequeue_Only_High_Priority had been a + -- protected entry in early drafts of AI05-0159, but it was discovered + -- that that operation as specified was not in fact implementable. The + -- operation was changed from an entry to a protected procedure per the + -- ARG meeting in Edinburgh (June 2011), with a different signature and + -- semantics. + + procedure Dequeue_Only_High_Priority + (At_Least : Queue_Priority; + Element : in out Queue_Interfaces.Element_Type; + Success : out Boolean); + + overriding function Current_Use return Count_Type; + + overriding function Peak_Use return Count_Type; + + private + Q_Elems : Set; + -- Elements of the queue + + Max_Length : Count_Type := 0; + -- The current length of the queue is the Length of Q_Elems. This is the + -- maximum value of that, so far. Updated by Enqueue. + + Next_Sequence_Number : Count_Type := 0; + -- Steadily increasing counter + end Queue; + +end Ada.Containers.Unbounded_Priority_Queues; diff --git a/gcc/ada/libgnat/a-cusyqu.adb b/gcc/ada/libgnat/a-cusyqu.adb new file mode 100644 index 0000000..b0e1a16 --- /dev/null +++ b/gcc/ada/libgnat/a-cusyqu.adb @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body Ada.Containers.Unbounded_Synchronized_Queues is + + package body Implementation is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free is + new Ada.Unchecked_Deallocation (Node_Type, Node_Access); + + ------------- + -- Dequeue -- + ------------- + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type) + is + X : Node_Access; + + begin + Element := List.First.Element; + + X := List.First; + List.First := List.First.Next; + + if List.First = null then + List.Last := null; + end if; + + List.Length := List.Length - 1; + + Free (X); + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type) + is + Node : Node_Access; + + begin + Node := new Node_Type'(New_Item, null); + + if List.First = null then + List.First := Node; + List.Last := List.First; + + else + List.Last.Next := Node; + List.Last := Node; + end if; + + List.Length := List.Length + 1; + + if List.Length > List.Max_Length then + List.Max_Length := List.Length; + end if; + end Enqueue; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (List : in out List_Type) is + X : Node_Access; + + begin + while List.First /= null loop + X := List.First; + List.First := List.First.Next; + Free (X); + end loop; + end Finalize; + + ------------ + -- Length -- + ------------ + + function Length (List : List_Type) return Count_Type is + begin + return List.Length; + end Length; + + ---------------- + -- Max_Length -- + ---------------- + + function Max_Length (List : List_Type) return Count_Type is + begin + return List.Max_Length; + end Max_Length; + + end Implementation; + + protected body Queue is + + ----------------- + -- Current_Use -- + ----------------- + + function Current_Use return Count_Type is + begin + return List.Length; + end Current_Use; + + ------------- + -- Dequeue -- + ------------- + + entry Dequeue (Element : out Queue_Interfaces.Element_Type) + when List.Length > 0 + is + begin + List.Dequeue (Element); + end Dequeue; + + ------------- + -- Enqueue -- + ------------- + + entry Enqueue (New_Item : Queue_Interfaces.Element_Type) when True is + begin + List.Enqueue (New_Item); + end Enqueue; + + -------------- + -- Peak_Use -- + -------------- + + function Peak_Use return Count_Type is + begin + return List.Max_Length; + end Peak_Use; + + end Queue; + +end Ada.Containers.Unbounded_Synchronized_Queues; diff --git a/gcc/ada/libgnat/a-cusyqu.ads b/gcc/ada/libgnat/a-cusyqu.ads new file mode 100644 index 0000000..b9a638d --- /dev/null +++ b/gcc/ada/libgnat/a-cusyqu.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.UNBOUNDED_SYNCHRONIZED_QUEUES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; +with Ada.Containers.Synchronized_Queue_Interfaces; +with Ada.Finalization; + +generic + with package Queue_Interfaces is + new Ada.Containers.Synchronized_Queue_Interfaces (<>); + + Default_Ceiling : System.Any_Priority := System.Priority'Last; + +package Ada.Containers.Unbounded_Synchronized_Queues is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Preelaborate; + + package Implementation is + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + type List_Type is tagged limited private; + + procedure Enqueue + (List : in out List_Type; + New_Item : Queue_Interfaces.Element_Type); + + procedure Dequeue + (List : in out List_Type; + Element : out Queue_Interfaces.Element_Type); + + function Length (List : List_Type) return Count_Type; + + function Max_Length (List : List_Type) return Count_Type; + + private + + type Node_Type; + type Node_Access is access Node_Type; + + type Node_Type is limited record + Element : Queue_Interfaces.Element_Type; + Next : Node_Access; + end record; + + type List_Type is new Ada.Finalization.Limited_Controlled with record + First, Last : Node_Access; + Length : Count_Type := 0; + Max_Length : Count_Type := 0; + end record; + + overriding procedure Finalize (List : in out List_Type); + + end Implementation; + + protected type Queue + (Ceiling : System.Any_Priority := Default_Ceiling) + with + Priority => Ceiling + is new Queue_Interfaces.Queue with + + overriding entry Enqueue (New_Item : Queue_Interfaces.Element_Type); + + overriding entry Dequeue (Element : out Queue_Interfaces.Element_Type); + + overriding function Current_Use return Count_Type; + + overriding function Peak_Use return Count_Type; + + private + List : Implementation.List_Type; + end Queue; + +end Ada.Containers.Unbounded_Synchronized_Queues; diff --git a/gcc/ada/libgnat/a-cwila1.ads b/gcc/ada/libgnat/a-cwila1.ads new file mode 100644 index 0000000..926d666 --- /dev/null +++ b/gcc/ada/libgnat/a-cwila1.ads @@ -0,0 +1,322 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions analogous to those in the RM defined +-- package Ada.Characters.Latin_1 except that the type of the constants +-- is Wide_Character instead of Character. The provision of this package +-- is in accordance with the implementation permission in RM (A.3.3(27)). + +package Ada.Characters.Wide_Latin_1 is + pragma Pure; + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Character := Wide_Character'Val (0); + SOH : constant Wide_Character := Wide_Character'Val (1); + STX : constant Wide_Character := Wide_Character'Val (2); + ETX : constant Wide_Character := Wide_Character'Val (3); + EOT : constant Wide_Character := Wide_Character'Val (4); + ENQ : constant Wide_Character := Wide_Character'Val (5); + ACK : constant Wide_Character := Wide_Character'Val (6); + BEL : constant Wide_Character := Wide_Character'Val (7); + BS : constant Wide_Character := Wide_Character'Val (8); + HT : constant Wide_Character := Wide_Character'Val (9); + LF : constant Wide_Character := Wide_Character'Val (10); + VT : constant Wide_Character := Wide_Character'Val (11); + FF : constant Wide_Character := Wide_Character'Val (12); + CR : constant Wide_Character := Wide_Character'Val (13); + SO : constant Wide_Character := Wide_Character'Val (14); + SI : constant Wide_Character := Wide_Character'Val (15); + + DLE : constant Wide_Character := Wide_Character'Val (16); + DC1 : constant Wide_Character := Wide_Character'Val (17); + DC2 : constant Wide_Character := Wide_Character'Val (18); + DC3 : constant Wide_Character := Wide_Character'Val (19); + DC4 : constant Wide_Character := Wide_Character'Val (20); + NAK : constant Wide_Character := Wide_Character'Val (21); + SYN : constant Wide_Character := Wide_Character'Val (22); + ETB : constant Wide_Character := Wide_Character'Val (23); + CAN : constant Wide_Character := Wide_Character'Val (24); + EM : constant Wide_Character := Wide_Character'Val (25); + SUB : constant Wide_Character := Wide_Character'Val (26); + ESC : constant Wide_Character := Wide_Character'Val (27); + FS : constant Wide_Character := Wide_Character'Val (28); + GS : constant Wide_Character := Wide_Character'Val (29); + RS : constant Wide_Character := Wide_Character'Val (30); + US : constant Wide_Character := Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Character renames Hyphen; + Full_Stop : constant Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Character := Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Character renames FS; + IS3 : Wide_Character renames GS; + IS2 : Wide_Character renames RS; + IS1 : Wide_Character renames US; + + Reserved_128 : constant Wide_Character := Wide_Character'Val (128); + Reserved_129 : constant Wide_Character := Wide_Character'Val (129); + BPH : constant Wide_Character := Wide_Character'Val (130); + NBH : constant Wide_Character := Wide_Character'Val (131); + Reserved_132 : constant Wide_Character := Wide_Character'Val (132); + NEL : constant Wide_Character := Wide_Character'Val (133); + SSA : constant Wide_Character := Wide_Character'Val (134); + ESA : constant Wide_Character := Wide_Character'Val (135); + HTS : constant Wide_Character := Wide_Character'Val (136); + HTJ : constant Wide_Character := Wide_Character'Val (137); + VTS : constant Wide_Character := Wide_Character'Val (138); + PLD : constant Wide_Character := Wide_Character'Val (139); + PLU : constant Wide_Character := Wide_Character'Val (140); + RI : constant Wide_Character := Wide_Character'Val (141); + SS2 : constant Wide_Character := Wide_Character'Val (142); + SS3 : constant Wide_Character := Wide_Character'Val (143); + + DCS : constant Wide_Character := Wide_Character'Val (144); + PU1 : constant Wide_Character := Wide_Character'Val (145); + PU2 : constant Wide_Character := Wide_Character'Val (146); + STS : constant Wide_Character := Wide_Character'Val (147); + CCH : constant Wide_Character := Wide_Character'Val (148); + MW : constant Wide_Character := Wide_Character'Val (149); + SPA : constant Wide_Character := Wide_Character'Val (150); + EPA : constant Wide_Character := Wide_Character'Val (151); + + SOS : constant Wide_Character := Wide_Character'Val (152); + Reserved_153 : constant Wide_Character := Wide_Character'Val (153); + SCI : constant Wide_Character := Wide_Character'Val (154); + CSI : constant Wide_Character := Wide_Character'Val (155); + ST : constant Wide_Character := Wide_Character'Val (156); + OSC : constant Wide_Character := Wide_Character'Val (157); + PM : constant Wide_Character := Wide_Character'Val (158); + APC : constant Wide_Character := Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Characters -- + ----------------------------------- + + -- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Wide_Character := Wide_Character'Val (160); + NBSP : Wide_Character renames No_Break_Space; + Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161); + Cent_Sign : constant Wide_Character := Wide_Character'Val (162); + Pound_Sign : constant Wide_Character := Wide_Character'Val (163); + Currency_Sign : constant Wide_Character := Wide_Character'Val (164); + Yen_Sign : constant Wide_Character := Wide_Character'Val (165); + Broken_Bar : constant Wide_Character := Wide_Character'Val (166); + Section_Sign : constant Wide_Character := Wide_Character'Val (167); + Diaeresis : constant Wide_Character := Wide_Character'Val (168); + Copyright_Sign : constant Wide_Character := Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (170); + Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171); + Not_Sign : constant Wide_Character := Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Character := Wide_Character'Val (174); + Macron : constant Wide_Character := Wide_Character'Val (175); + + -- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Character := Wide_Character'Val (176); + Ring_Above : Wide_Character renames Degree_Sign; + Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177); + Superscript_Two : constant Wide_Character := Wide_Character'Val (178); + Superscript_Three : constant Wide_Character := Wide_Character'Val (179); + Acute : constant Wide_Character := Wide_Character'Val (180); + Micro_Sign : constant Wide_Character := Wide_Character'Val (181); + Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182); + Paragraph_Sign : Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Character := Wide_Character'Val (183); + Cedilla : constant Wide_Character := Wide_Character'Val (184); + Superscript_One : constant Wide_Character := Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Character := Wide_Character'Val (187); + Fraction_One_Quarter : constant Wide_Character := Wide_Character'Val (188); + Fraction_One_Half : constant Wide_Character := Wide_Character'Val (189); + Fraction_Three_Quarters + : constant Wide_Character := Wide_Character'Val (190); + Inverted_Question : constant Wide_Character := Wide_Character'Val (191); + + -- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Character := Wide_Character'Val (192); + UC_A_Acute : constant Wide_Character := Wide_Character'Val (193); + UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195); + UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196); + UC_A_Ring : constant Wide_Character := Wide_Character'Val (197); + UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198); + UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199); + UC_E_Grave : constant Wide_Character := Wide_Character'Val (200); + UC_E_Acute : constant Wide_Character := Wide_Character'Val (201); + UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202); + UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203); + UC_I_Grave : constant Wide_Character := Wide_Character'Val (204); + UC_I_Acute : constant Wide_Character := Wide_Character'Val (205); + UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206); + UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207); + + -- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209); + UC_O_Grave : constant Wide_Character := Wide_Character'Val (210); + UC_O_Acute : constant Wide_Character := Wide_Character'Val (211); + UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213); + UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214); + Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215); + UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216); + UC_U_Grave : constant Wide_Character := Wide_Character'Val (217); + UC_U_Acute : constant Wide_Character := Wide_Character'Val (218); + UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219); + UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221); + UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222); + LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223); + + -- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Character := Wide_Character'Val (224); + LC_A_Acute : constant Wide_Character := Wide_Character'Val (225); + LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227); + LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228); + LC_A_Ring : constant Wide_Character := Wide_Character'Val (229); + LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230); + LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231); + LC_E_Grave : constant Wide_Character := Wide_Character'Val (232); + LC_E_Acute : constant Wide_Character := Wide_Character'Val (233); + LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234); + LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235); + LC_I_Grave : constant Wide_Character := Wide_Character'Val (236); + LC_I_Acute : constant Wide_Character := Wide_Character'Val (237); + LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238); + LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239); + + -- Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241); + LC_O_Grave : constant Wide_Character := Wide_Character'Val (242); + LC_O_Acute : constant Wide_Character := Wide_Character'Val (243); + LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245); + LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246); + Division_Sign : constant Wide_Character := Wide_Character'Val (247); + LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248); + LC_U_Grave : constant Wide_Character := Wide_Character'Val (249); + LC_U_Acute : constant Wide_Character := Wide_Character'Val (250); + LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251); + LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253); + LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254); + LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255); + +end Ada.Characters.Wide_Latin_1; diff --git a/gcc/ada/libgnat/a-cwila9.ads b/gcc/ada/libgnat/a-cwila9.ads new file mode 100644 index 0000000..a2aa0d1 --- /dev/null +++ b/gcc/ada/libgnat/a-cwila9.ads @@ -0,0 +1,334 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . C H A R A C T E R S . W I D E _ L A T I N _ 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides definitions analogous to those in the GNAT +-- package Ada.Characters.Latin_9 except that the type of the constants +-- is Wide_Character instead of Character. The provision of this package +-- is in accordance with the implementation permission in RM (A.3.3(27)). + +package Ada.Characters.Wide_Latin_9 is + pragma Pure; + + ------------------------ + -- Control Characters -- + ------------------------ + + NUL : constant Wide_Character := Wide_Character'Val (0); + SOH : constant Wide_Character := Wide_Character'Val (1); + STX : constant Wide_Character := Wide_Character'Val (2); + ETX : constant Wide_Character := Wide_Character'Val (3); + EOT : constant Wide_Character := Wide_Character'Val (4); + ENQ : constant Wide_Character := Wide_Character'Val (5); + ACK : constant Wide_Character := Wide_Character'Val (6); + BEL : constant Wide_Character := Wide_Character'Val (7); + BS : constant Wide_Character := Wide_Character'Val (8); + HT : constant Wide_Character := Wide_Character'Val (9); + LF : constant Wide_Character := Wide_Character'Val (10); + VT : constant Wide_Character := Wide_Character'Val (11); + FF : constant Wide_Character := Wide_Character'Val (12); + CR : constant Wide_Character := Wide_Character'Val (13); + SO : constant Wide_Character := Wide_Character'Val (14); + SI : constant Wide_Character := Wide_Character'Val (15); + + DLE : constant Wide_Character := Wide_Character'Val (16); + DC1 : constant Wide_Character := Wide_Character'Val (17); + DC2 : constant Wide_Character := Wide_Character'Val (18); + DC3 : constant Wide_Character := Wide_Character'Val (19); + DC4 : constant Wide_Character := Wide_Character'Val (20); + NAK : constant Wide_Character := Wide_Character'Val (21); + SYN : constant Wide_Character := Wide_Character'Val (22); + ETB : constant Wide_Character := Wide_Character'Val (23); + CAN : constant Wide_Character := Wide_Character'Val (24); + EM : constant Wide_Character := Wide_Character'Val (25); + SUB : constant Wide_Character := Wide_Character'Val (26); + ESC : constant Wide_Character := Wide_Character'Val (27); + FS : constant Wide_Character := Wide_Character'Val (28); + GS : constant Wide_Character := Wide_Character'Val (29); + RS : constant Wide_Character := Wide_Character'Val (30); + US : constant Wide_Character := Wide_Character'Val (31); + + ------------------------------------- + -- ISO 646 Graphic Wide_Characters -- + ------------------------------------- + + Space : constant Wide_Character := ' '; -- WC'Val(32) + Exclamation : constant Wide_Character := '!'; -- WC'Val(33) + Quotation : constant Wide_Character := '"'; -- WC'Val(34) + Number_Sign : constant Wide_Character := '#'; -- WC'Val(35) + Dollar_Sign : constant Wide_Character := '$'; -- WC'Val(36) + Percent_Sign : constant Wide_Character := '%'; -- WC'Val(37) + Ampersand : constant Wide_Character := '&'; -- WC'Val(38) + Apostrophe : constant Wide_Character := '''; -- WC'Val(39) + Left_Parenthesis : constant Wide_Character := '('; -- WC'Val(40) + Right_Parenthesis : constant Wide_Character := ')'; -- WC'Val(41) + Asterisk : constant Wide_Character := '*'; -- WC'Val(42) + Plus_Sign : constant Wide_Character := '+'; -- WC'Val(43) + Comma : constant Wide_Character := ','; -- WC'Val(44) + Hyphen : constant Wide_Character := '-'; -- WC'Val(45) + Minus_Sign : Wide_Character renames Hyphen; + Full_Stop : constant Wide_Character := '.'; -- WC'Val(46) + Solidus : constant Wide_Character := '/'; -- WC'Val(47) + + -- Decimal digits '0' though '9' are at positions 48 through 57 + + Colon : constant Wide_Character := ':'; -- WC'Val(58) + Semicolon : constant Wide_Character := ';'; -- WC'Val(59) + Less_Than_Sign : constant Wide_Character := '<'; -- WC'Val(60) + Equals_Sign : constant Wide_Character := '='; -- WC'Val(61) + Greater_Than_Sign : constant Wide_Character := '>'; -- WC'Val(62) + Question : constant Wide_Character := '?'; -- WC'Val(63) + + Commercial_At : constant Wide_Character := '@'; -- WC'Val(64) + + -- Letters 'A' through 'Z' are at positions 65 through 90 + + Left_Square_Bracket : constant Wide_Character := '['; -- WC'Val (91) + Reverse_Solidus : constant Wide_Character := '\'; -- WC'Val (92) + Right_Square_Bracket : constant Wide_Character := ']'; -- WC'Val (93) + Circumflex : constant Wide_Character := '^'; -- WC'Val (94) + Low_Line : constant Wide_Character := '_'; -- WC'Val (95) + + Grave : constant Wide_Character := '`'; -- WC'Val (96) + LC_A : constant Wide_Character := 'a'; -- WC'Val (97) + LC_B : constant Wide_Character := 'b'; -- WC'Val (98) + LC_C : constant Wide_Character := 'c'; -- WC'Val (99) + LC_D : constant Wide_Character := 'd'; -- WC'Val (100) + LC_E : constant Wide_Character := 'e'; -- WC'Val (101) + LC_F : constant Wide_Character := 'f'; -- WC'Val (102) + LC_G : constant Wide_Character := 'g'; -- WC'Val (103) + LC_H : constant Wide_Character := 'h'; -- WC'Val (104) + LC_I : constant Wide_Character := 'i'; -- WC'Val (105) + LC_J : constant Wide_Character := 'j'; -- WC'Val (106) + LC_K : constant Wide_Character := 'k'; -- WC'Val (107) + LC_L : constant Wide_Character := 'l'; -- WC'Val (108) + LC_M : constant Wide_Character := 'm'; -- WC'Val (109) + LC_N : constant Wide_Character := 'n'; -- WC'Val (110) + LC_O : constant Wide_Character := 'o'; -- WC'Val (111) + LC_P : constant Wide_Character := 'p'; -- WC'Val (112) + LC_Q : constant Wide_Character := 'q'; -- WC'Val (113) + LC_R : constant Wide_Character := 'r'; -- WC'Val (114) + LC_S : constant Wide_Character := 's'; -- WC'Val (115) + LC_T : constant Wide_Character := 't'; -- WC'Val (116) + LC_U : constant Wide_Character := 'u'; -- WC'Val (117) + LC_V : constant Wide_Character := 'v'; -- WC'Val (118) + LC_W : constant Wide_Character := 'w'; -- WC'Val (119) + LC_X : constant Wide_Character := 'x'; -- WC'Val (120) + LC_Y : constant Wide_Character := 'y'; -- WC'Val (121) + LC_Z : constant Wide_Character := 'z'; -- WC'Val (122) + Left_Curly_Bracket : constant Wide_Character := '{'; -- WC'Val (123) + Vertical_Line : constant Wide_Character := '|'; -- WC'Val (124) + Right_Curly_Bracket : constant Wide_Character := '}'; -- WC'Val (125) + Tilde : constant Wide_Character := '~'; -- WC'Val (126) + DEL : constant Wide_Character := Wide_Character'Val (127); + + -------------------------------------- + -- ISO 6429 Control Wide_Characters -- + -------------------------------------- + + IS4 : Wide_Character renames FS; + IS3 : Wide_Character renames GS; + IS2 : Wide_Character renames RS; + IS1 : Wide_Character renames US; + + Reserved_128 : constant Wide_Character := Wide_Character'Val (128); + Reserved_129 : constant Wide_Character := Wide_Character'Val (129); + BPH : constant Wide_Character := Wide_Character'Val (130); + NBH : constant Wide_Character := Wide_Character'Val (131); + Reserved_132 : constant Wide_Character := Wide_Character'Val (132); + NEL : constant Wide_Character := Wide_Character'Val (133); + SSA : constant Wide_Character := Wide_Character'Val (134); + ESA : constant Wide_Character := Wide_Character'Val (135); + HTS : constant Wide_Character := Wide_Character'Val (136); + HTJ : constant Wide_Character := Wide_Character'Val (137); + VTS : constant Wide_Character := Wide_Character'Val (138); + PLD : constant Wide_Character := Wide_Character'Val (139); + PLU : constant Wide_Character := Wide_Character'Val (140); + RI : constant Wide_Character := Wide_Character'Val (141); + SS2 : constant Wide_Character := Wide_Character'Val (142); + SS3 : constant Wide_Character := Wide_Character'Val (143); + + DCS : constant Wide_Character := Wide_Character'Val (144); + PU1 : constant Wide_Character := Wide_Character'Val (145); + PU2 : constant Wide_Character := Wide_Character'Val (146); + STS : constant Wide_Character := Wide_Character'Val (147); + CCH : constant Wide_Character := Wide_Character'Val (148); + MW : constant Wide_Character := Wide_Character'Val (149); + SPA : constant Wide_Character := Wide_Character'Val (150); + EPA : constant Wide_Character := Wide_Character'Val (151); + + SOS : constant Wide_Character := Wide_Character'Val (152); + Reserved_153 : constant Wide_Character := Wide_Character'Val (153); + SCI : constant Wide_Character := Wide_Character'Val (154); + CSI : constant Wide_Character := Wide_Character'Val (155); + ST : constant Wide_Character := Wide_Character'Val (156); + OSC : constant Wide_Character := Wide_Character'Val (157); + PM : constant Wide_Character := Wide_Character'Val (158); + APC : constant Wide_Character := Wide_Character'Val (159); + + ----------------------------------- + -- Other Graphic Wide_Characters -- + ----------------------------------- + + -- Wide_Character positions 160 (16#A0#) .. 175 (16#AF#) + + No_Break_Space : constant Wide_Character := Wide_Character'Val (160); + NBSP : Wide_Character renames No_Break_Space; + Inverted_Exclamation : constant Wide_Character := Wide_Character'Val (161); + Cent_Sign : constant Wide_Character := Wide_Character'Val (162); + Pound_Sign : constant Wide_Character := Wide_Character'Val (163); + Euro_Sign : constant Wide_Character := Wide_Character'Val (164); + Yen_Sign : constant Wide_Character := Wide_Character'Val (165); + UC_S_Caron : constant Wide_Character := Wide_Character'Val (166); + Section_Sign : constant Wide_Character := Wide_Character'Val (167); + LC_S_Caron : constant Wide_Character := Wide_Character'Val (168); + Copyright_Sign : constant Wide_Character := Wide_Character'Val (169); + Feminine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (170); + Left_Angle_Quotation : constant Wide_Character := Wide_Character'Val (171); + Not_Sign : constant Wide_Character := Wide_Character'Val (172); + Soft_Hyphen : constant Wide_Character := Wide_Character'Val (173); + Registered_Trade_Mark_Sign + : constant Wide_Character := Wide_Character'Val (174); + Macron : constant Wide_Character := Wide_Character'Val (175); + + -- Wide_Character positions 176 (16#B0#) .. 191 (16#BF#) + + Degree_Sign : constant Wide_Character := Wide_Character'Val (176); + Ring_Above : Wide_Character renames Degree_Sign; + Plus_Minus_Sign : constant Wide_Character := Wide_Character'Val (177); + Superscript_Two : constant Wide_Character := Wide_Character'Val (178); + Superscript_Three : constant Wide_Character := Wide_Character'Val (179); + UC_Z_Caron : constant Wide_Character := Wide_Character'Val (180); + Micro_Sign : constant Wide_Character := Wide_Character'Val (181); + Pilcrow_Sign : constant Wide_Character := Wide_Character'Val (182); + Paragraph_Sign : Wide_Character renames Pilcrow_Sign; + Middle_Dot : constant Wide_Character := Wide_Character'Val (183); + LC_Z_Caron : constant Wide_Character := Wide_Character'Val (184); + Superscript_One : constant Wide_Character := Wide_Character'Val (185); + Masculine_Ordinal_Indicator + : constant Wide_Character := Wide_Character'Val (186); + Right_Angle_Quotation + : constant Wide_Character := Wide_Character'Val (187); + UC_Ligature_OE : constant Wide_Character := Wide_Character'Val (188); + LC_Ligature_OE : constant Wide_Character := Wide_Character'Val (189); + UC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (190); + Inverted_Question : constant Wide_Character := Wide_Character'Val (191); + + -- Wide_Character positions 192 (16#C0#) .. 207 (16#CF#) + + UC_A_Grave : constant Wide_Character := Wide_Character'Val (192); + UC_A_Acute : constant Wide_Character := Wide_Character'Val (193); + UC_A_Circumflex : constant Wide_Character := Wide_Character'Val (194); + UC_A_Tilde : constant Wide_Character := Wide_Character'Val (195); + UC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (196); + UC_A_Ring : constant Wide_Character := Wide_Character'Val (197); + UC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (198); + UC_C_Cedilla : constant Wide_Character := Wide_Character'Val (199); + UC_E_Grave : constant Wide_Character := Wide_Character'Val (200); + UC_E_Acute : constant Wide_Character := Wide_Character'Val (201); + UC_E_Circumflex : constant Wide_Character := Wide_Character'Val (202); + UC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (203); + UC_I_Grave : constant Wide_Character := Wide_Character'Val (204); + UC_I_Acute : constant Wide_Character := Wide_Character'Val (205); + UC_I_Circumflex : constant Wide_Character := Wide_Character'Val (206); + UC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (207); + + -- Wide_Character positions 208 (16#D0#) .. 223 (16#DF#) + + UC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (208); + UC_N_Tilde : constant Wide_Character := Wide_Character'Val (209); + UC_O_Grave : constant Wide_Character := Wide_Character'Val (210); + UC_O_Acute : constant Wide_Character := Wide_Character'Val (211); + UC_O_Circumflex : constant Wide_Character := Wide_Character'Val (212); + UC_O_Tilde : constant Wide_Character := Wide_Character'Val (213); + UC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (214); + Multiplication_Sign : constant Wide_Character := Wide_Character'Val (215); + UC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (216); + UC_U_Grave : constant Wide_Character := Wide_Character'Val (217); + UC_U_Acute : constant Wide_Character := Wide_Character'Val (218); + UC_U_Circumflex : constant Wide_Character := Wide_Character'Val (219); + UC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (220); + UC_Y_Acute : constant Wide_Character := Wide_Character'Val (221); + UC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (222); + LC_German_Sharp_S : constant Wide_Character := Wide_Character'Val (223); + + -- Wide_Character positions 224 (16#E0#) .. 239 (16#EF#) + + LC_A_Grave : constant Wide_Character := Wide_Character'Val (224); + LC_A_Acute : constant Wide_Character := Wide_Character'Val (225); + LC_A_Circumflex : constant Wide_Character := Wide_Character'Val (226); + LC_A_Tilde : constant Wide_Character := Wide_Character'Val (227); + LC_A_Diaeresis : constant Wide_Character := Wide_Character'Val (228); + LC_A_Ring : constant Wide_Character := Wide_Character'Val (229); + LC_AE_Diphthong : constant Wide_Character := Wide_Character'Val (230); + LC_C_Cedilla : constant Wide_Character := Wide_Character'Val (231); + LC_E_Grave : constant Wide_Character := Wide_Character'Val (232); + LC_E_Acute : constant Wide_Character := Wide_Character'Val (233); + LC_E_Circumflex : constant Wide_Character := Wide_Character'Val (234); + LC_E_Diaeresis : constant Wide_Character := Wide_Character'Val (235); + LC_I_Grave : constant Wide_Character := Wide_Character'Val (236); + LC_I_Acute : constant Wide_Character := Wide_Character'Val (237); + LC_I_Circumflex : constant Wide_Character := Wide_Character'Val (238); + LC_I_Diaeresis : constant Wide_Character := Wide_Character'Val (239); + + -- Wide_Character positions 240 (16#F0#) .. 255 (16#FF) + + LC_Icelandic_Eth : constant Wide_Character := Wide_Character'Val (240); + LC_N_Tilde : constant Wide_Character := Wide_Character'Val (241); + LC_O_Grave : constant Wide_Character := Wide_Character'Val (242); + LC_O_Acute : constant Wide_Character := Wide_Character'Val (243); + LC_O_Circumflex : constant Wide_Character := Wide_Character'Val (244); + LC_O_Tilde : constant Wide_Character := Wide_Character'Val (245); + LC_O_Diaeresis : constant Wide_Character := Wide_Character'Val (246); + Division_Sign : constant Wide_Character := Wide_Character'Val (247); + LC_O_Oblique_Stroke : constant Wide_Character := Wide_Character'Val (248); + LC_U_Grave : constant Wide_Character := Wide_Character'Val (249); + LC_U_Acute : constant Wide_Character := Wide_Character'Val (250); + LC_U_Circumflex : constant Wide_Character := Wide_Character'Val (251); + LC_U_Diaeresis : constant Wide_Character := Wide_Character'Val (252); + LC_Y_Acute : constant Wide_Character := Wide_Character'Val (253); + LC_Icelandic_Thorn : constant Wide_Character := Wide_Character'Val (254); + LC_Y_Diaeresis : constant Wide_Character := Wide_Character'Val (255); + + ------------------------------------------------ + -- Summary of Changes from Latin-1 => Latin-9 -- + ------------------------------------------------ + + -- 164 Currency => Euro_Sign + -- 166 Broken_Bar => UC_S_Caron + -- 168 Diaeresis => LC_S_Caron + -- 180 Acute => UC_Z_Caron + -- 184 Cedilla => LC_Z_Caron + -- 188 Fraction_One_Quarter => UC_Ligature_OE + -- 189 Fraction_One_Half => LC_Ligature_OE + -- 190 Fraction_Three_Quarters => UC_Y_Diaeresis + +end Ada.Characters.Wide_Latin_9; diff --git a/gcc/ada/libgnat/a-decima.adb b/gcc/ada/libgnat/a-decima.adb new file mode 100644 index 0000000..bccddbf --- /dev/null +++ b/gcc/ada/libgnat/a-decima.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D E C I M A L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Decimal is + + ------------ + -- Divide -- + ------------ + + procedure Divide + (Dividend : Dividend_Type; + Divisor : Divisor_Type; + Quotient : out Quotient_Type; + Remainder : out Remainder_Type) + is + -- We have a nested procedure that is the actual intrinsic divide. + -- This is required because in the current RM, Divide itself does + -- not have convention Intrinsic. + + procedure Divide + (Dividend : Dividend_Type; + Divisor : Divisor_Type; + Quotient : out Quotient_Type; + Remainder : out Remainder_Type); + + pragma Import (Intrinsic, Divide); + + begin + Divide (Dividend, Divisor, Quotient, Remainder); + end Divide; + +end Ada.Decimal; diff --git a/gcc/ada/libgnat/a-decima.ads b/gcc/ada/libgnat/a-decima.ads new file mode 100644 index 0000000..439bd8a --- /dev/null +++ b/gcc/ada/libgnat/a-decima.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D E C I M A L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Decimal is + pragma Pure; + + -- The compiler makes a number of assumptions based on the following five + -- constants (e.g. there is an assumption that decimal values can always + -- be represented in 64-bit signed binary form), so code modifications are + -- required to increase these constants. + + Max_Scale : constant := +18; + Min_Scale : constant := -18; + + Min_Delta : constant := 1.0E-18; + Max_Delta : constant := 1.0E+18; + + Max_Decimal_Digits : constant := 18; + + generic + type Dividend_Type is delta <> digits <>; + type Divisor_Type is delta <> digits <>; + type Quotient_Type is delta <> digits <>; + type Remainder_Type is delta <> digits <>; + + procedure Divide + (Dividend : Dividend_Type; + Divisor : Divisor_Type; + Quotient : out Quotient_Type; + Remainder : out Remainder_Type); + +private + pragma Inline (Divide); + +end Ada.Decimal; diff --git a/gcc/ada/libgnat/a-dhfina.ads b/gcc/ada/libgnat/a-dhfina.ads new file mode 100644 index 0000000..e34c664 --- /dev/null +++ b/gcc/ada/libgnat/a-dhfina.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.DIRECTORIES.HIERARCHICAL_FILE_NAMES -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Directories.Hierarchical_File_Names is + pragma Unimplemented_Unit; + + function Is_Simple_Name (Name : String) return Boolean; + + function Is_Root_Directory_Name (Name : String) return Boolean; + + function Is_Parent_Directory_Name (Name : String) return Boolean; + + function Is_Current_Directory_Name (Name : String) return Boolean; + + function Is_Full_Name (Name : String) return Boolean; + + function Is_Relative_Name (Name : String) return Boolean; + + function Simple_Name (Name : String) return String + renames Ada.Directories.Simple_Name; + + function Containing_Directory (Name : String) return String + renames Ada.Directories.Containing_Directory; + + function Initial_Directory (Name : String) return String; + + function Relative_Name (Name : String) return String; + + function Compose + (Directory : String := ""; + Relative_Name : String; + Extension : String := "") return String; + +end Ada.Directories.Hierarchical_File_Names; diff --git a/gcc/ada/libgnat/a-diocst.adb b/gcc/ada/libgnat/a-diocst.adb new file mode 100644 index 0000000..508563f --- /dev/null +++ b/gcc/ada/libgnat/a-diocst.adb @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with System.Direct_IO; +with Ada.Unchecked_Conversion; + +package body Ada.Direct_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + package DIO renames System.Direct_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : DIO.Direct_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'D', + Creat => False, + Text => False, + C_Stream => C_Stream); + + File.Bytes := Bytes; + end Open; + +end Ada.Direct_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-diocst.ads b/gcc/ada/libgnat/a-diocst.ads new file mode 100644 index 0000000..d0adf49 --- /dev/null +++ b/gcc/ada/libgnat/a-diocst.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Direct_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +generic +package Ada.Direct_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Direct_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-direct.adb b/gcc/ada/libgnat/a-direct.adb new file mode 100644 index 0000000..010daf6 --- /dev/null +++ b/gcc/ada/libgnat/a-direct.adb @@ -0,0 +1,1344 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; use Ada.Calendar; +with Ada.Calendar.Formatting; use Ada.Calendar.Formatting; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Directories.Validity; use Ada.Directories.Validity; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Unchecked_Deallocation; + +with System; use System; +with System.CRTL; use System.CRTL; +with System.File_Attributes; use System.File_Attributes; +with System.File_IO; use System.File_IO; +with System.OS_Constants; use System.OS_Constants; +with System.OS_Lib; use System.OS_Lib; +with System.Regexp; use System.Regexp; + +package body Ada.Directories is + + type Dir_Type_Value is new Address; + -- This is the low-level address directory structure as returned by the C + -- opendir routine. + + No_Dir : constant Dir_Type_Value := Dir_Type_Value (Null_Address); + -- Null directory value + + Dir_Separator : constant Character; + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + -- Running system default directory separator + + Dir_Seps : constant Character_Set := Strings.Maps.To_Set ("/\"); + -- UNIX and DOS style directory separators + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- The maximum length of a path + + type Search_Data is record + Is_Valid : Boolean := False; + Name : Unbounded_String; + Pattern : Regexp; + Filter : Filter_Type; + Dir : Dir_Type_Value := No_Dir; + Entry_Fetched : Boolean := False; + Dir_Entry : Directory_Entry_Type; + end record; + -- The current state of a search + + Empty_String : constant String := (1 .. 0 => ASCII.NUL); + -- Empty string, returned by function Extension when there is no extension + + procedure Free is new Ada.Unchecked_Deallocation (Search_Data, Search_Ptr); + + procedure Close (Dir : Dir_Type_Value); + + function File_Exists (Name : String) return Boolean; + -- Returns True if the named file exists + + procedure Fetch_Next_Entry (Search : Search_Type); + -- Get the next entry in a directory, setting Entry_Fetched if successful + -- or resetting Is_Valid if not. + + --------------- + -- Base_Name -- + --------------- + + function Base_Name (Name : String) return String is + Simple : constant String := Simple_Name (Name); + -- Simple'First is guaranteed to be 1 + + begin + -- Look for the last dot in the file name and return the part of the + -- file name preceding this last dot. If the first dot is the first + -- character of the file name, the base name is the empty string. + + for Pos in reverse Simple'Range loop + if Simple (Pos) = '.' then + return Simple (1 .. Pos - 1); + end if; + end loop; + + -- If there is no dot, return the complete file name + + return Simple; + end Base_Name; + + ----------- + -- Close -- + ----------- + + procedure Close (Dir : Dir_Type_Value) is + Discard : Integer; + pragma Warnings (Off, Discard); + + function closedir (directory : DIRs) return Integer; + pragma Import (C, closedir, "__gnat_closedir"); + + begin + Discard := closedir (DIRs (Dir)); + end Close; + + ------------- + -- Compose -- + ------------- + + function Compose + (Containing_Directory : String := ""; + Name : String; + Extension : String := "") return String + is + Result : String (1 .. Containing_Directory'Length + + Name'Length + Extension'Length + 2); + Last : Natural; + + begin + -- First, deal with the invalid cases + + if Containing_Directory /= "" + and then not Is_Valid_Path_Name (Containing_Directory) + then + raise Name_Error with + "invalid directory path name """ & Containing_Directory & '"'; + + elsif + Extension'Length = 0 and then (not Is_Valid_Simple_Name (Name)) + then + raise Name_Error with + "invalid simple name """ & Name & '"'; + + elsif Extension'Length /= 0 + and then not Is_Valid_Simple_Name (Name & '.' & Extension) + then + raise Name_Error with + "invalid file name """ & Name & '.' & Extension & '"'; + + -- This is not an invalid case so build the path name + + else + Last := Containing_Directory'Length; + Result (1 .. Last) := Containing_Directory; + + -- Add a directory separator if needed + + if Last /= 0 and then not Is_In (Result (Last), Dir_Seps) then + Last := Last + 1; + Result (Last) := Dir_Separator; + end if; + + -- Add the file name + + Result (Last + 1 .. Last + Name'Length) := Name; + Last := Last + Name'Length; + + -- If extension was specified, add dot followed by this extension + + if Extension'Length /= 0 then + Last := Last + 1; + Result (Last) := '.'; + Result (Last + 1 .. Last + Extension'Length) := Extension; + Last := Last + Extension'Length; + end if; + + return Result (1 .. Last); + end if; + end Compose; + + -------------------------- + -- Containing_Directory -- + -------------------------- + + function Containing_Directory (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + declare + Last_DS : constant Natural := + Strings.Fixed.Index (Name, Dir_Seps, Going => Strings.Backward); + + begin + if Last_DS = 0 then + + -- There is no directory separator, returns "." representing + -- the current working directory. + + return "."; + + -- If Name indicates a root directory, raise Use_Error, because + -- it has no containing directory. + + elsif Name = "/" + or else + (Windows + and then + (Name = "\" + or else + (Name'Length = 3 + and then Name (Name'Last - 1 .. Name'Last) = ":\" + and then (Name (Name'First) in 'a' .. 'z' + or else + Name (Name'First) in 'A' .. 'Z')))) + then + raise Use_Error with + "directory """ & Name & """ has no containing directory"; + + else + declare + Last : Positive := Last_DS - Name'First + 1; + Result : String (1 .. Last); + + begin + Result := Name (Name'First .. Last_DS); + + -- Remove any trailing directory separator, except as the + -- first character or the first character following a drive + -- number on Windows. + + while Last > 1 loop + exit when + Result (Last) /= '/' + and then + Result (Last) /= Directory_Separator; + + exit when Windows + and then Last = 3 + and then Result (2) = ':' + and then + (Result (1) in 'A' .. 'Z' + or else + Result (1) in 'a' .. 'z'); + + Last := Last - 1; + end loop; + + -- Special case of "..": the current directory may be a root + -- directory. + + if Last = 2 and then Result (1 .. 2) = ".." then + return Containing_Directory (Current_Directory); + + else + return Result (1 .. Last); + end if; + end; + end if; + end; + end if; + end Containing_Directory; + + --------------- + -- Copy_File -- + --------------- + + procedure Copy_File + (Source_Name : String; + Target_Name : String; + Form : String := "") + is + Success : Boolean; + Mode : Copy_Mode := Overwrite; + Preserve : Attribute := None; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Source_Name) then + raise Name_Error with + "invalid source path name """ & Source_Name & '"'; + + elsif not Is_Valid_Path_Name (Target_Name) then + raise Name_Error with + "invalid target path name """ & Target_Name & '"'; + + elsif not Is_Regular_File (Source_Name) then + raise Name_Error with '"' & Source_Name & """ is not a file"; + + elsif Is_Directory (Target_Name) then + raise Use_Error with "target """ & Target_Name & """ is a directory"; + + else + if Form'Length > 0 then + declare + Formstr : String (1 .. Form'Length + 1); + V1, V2 : Natural; + + begin + -- Acquire form string, setting required NUL terminator + + Formstr (1 .. Form'Length) := Form; + Formstr (Formstr'Last) := ASCII.NUL; + + -- Convert form string to lower case + + for J in Formstr'Range loop + if Formstr (J) in 'A' .. 'Z' then + Formstr (J) := + Character'Val (Character'Pos (Formstr (J)) + 32); + end if; + end loop; + + -- Check Form + + Form_Parameter (Formstr, "mode", V1, V2); + + if V1 = 0 then + Mode := Overwrite; + elsif Formstr (V1 .. V2) = "copy" then + Mode := Copy; + elsif Formstr (V1 .. V2) = "overwrite" then + Mode := Overwrite; + elsif Formstr (V1 .. V2) = "append" then + Mode := Append; + else + raise Use_Error with "invalid Form"; + end if; + + Form_Parameter (Formstr, "preserve", V1, V2); + + if V1 = 0 then + Preserve := None; + elsif Formstr (V1 .. V2) = "timestamps" then + Preserve := Time_Stamps; + elsif Formstr (V1 .. V2) = "all_attributes" then + Preserve := Full; + elsif Formstr (V1 .. V2) = "no_attributes" then + Preserve := None; + else + raise Use_Error with "invalid Form"; + end if; + end; + end if; + + -- Do actual copy using System.OS_Lib.Copy_File + + Copy_File (Source_Name, Target_Name, Success, Mode, Preserve); + + if not Success then + raise Use_Error with "copy of """ & Source_Name & """ failed"; + end if; + end if; + end Copy_File; + + ---------------------- + -- Create_Directory -- + ---------------------- + + procedure Create_Directory + (New_Directory : String; + Form : String := "") + is + C_Dir_Name : constant String := New_Directory & ASCII.NUL; + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (New_Directory) then + raise Name_Error with + "invalid new directory path name """ & New_Directory & '"'; + + else + -- Acquire setting of encoding parameter + + declare + Formstr : constant String := To_Lower (Form); + + Encoding : CRTL.Filename_Encoding; + -- Filename encoding specified into the form parameter + + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "encoding", V1, V2); + + if V1 = 0 then + Encoding := CRTL.Unspecified; + elsif Formstr (V1 .. V2) = "utf8" then + Encoding := CRTL.UTF8; + elsif Formstr (V1 .. V2) = "8bits" then + Encoding := CRTL.ASCII_8bits; + else + raise Use_Error with "invalid Form"; + end if; + + if CRTL.mkdir (C_Dir_Name, Encoding) /= 0 then + raise Use_Error with + "creation of new directory """ & New_Directory & """ failed"; + end if; + end; + end if; + end Create_Directory; + + ----------------- + -- Create_Path -- + ----------------- + + procedure Create_Path + (New_Directory : String; + Form : String := "") + is + New_Dir : String (1 .. New_Directory'Length + 1); + Last : Positive := 1; + Start : Positive := 1; + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (New_Directory) then + raise Name_Error with + "invalid new directory path name """ & New_Directory & '"'; + + else + -- Build New_Dir with a directory separator at the end, so that the + -- complete path will be found in the loop below. + + New_Dir (1 .. New_Directory'Length) := New_Directory; + New_Dir (New_Dir'Last) := Directory_Separator; + + -- If host is windows, and the first two characters are directory + -- separators, we have an UNC path. Skip it. + + if Directory_Separator = '\' + and then New_Dir'Length > 2 + and then Is_In (New_Dir (1), Dir_Seps) + and then Is_In (New_Dir (2), Dir_Seps) + then + Start := 2; + loop + Start := Start + 1; + exit when Start = New_Dir'Last + or else Is_In (New_Dir (Start), Dir_Seps); + end loop; + end if; + + -- Create, if necessary, each directory in the path + + for J in Start + 1 .. New_Dir'Last loop + + -- Look for the end of an intermediate directory + + if not Is_In (New_Dir (J), Dir_Seps) then + Last := J; + + -- We have found a new intermediate directory each time we find + -- a first directory separator. + + elsif not Is_In (New_Dir (J - 1), Dir_Seps) then + + -- No need to create the directory if it already exists + + if not Is_Directory (New_Dir (1 .. Last)) then + begin + Create_Directory + (New_Directory => New_Dir (1 .. Last), Form => Form); + + exception + when Use_Error => + if File_Exists (New_Dir (1 .. Last)) then + + -- A file with such a name already exists. If it is + -- a directory, then it was apparently just created + -- by another process or thread, and all is well. + -- If it is of some other kind, report an error. + + if not Is_Directory (New_Dir (1 .. Last)) then + raise Use_Error with + "file """ & New_Dir (1 .. Last) & + """ already exists and is not a directory"; + end if; + + else + -- Create_Directory failed for some other reason: + -- propagate the exception. + + raise; + end if; + end; + end if; + end if; + end loop; + end if; + end Create_Path; + + ----------------------- + -- Current_Directory -- + ----------------------- + + function Current_Directory return String is + Path_Len : Natural := Max_Path; + Buffer : String (1 .. 1 + Max_Path + 1); + + procedure Local_Get_Current_Dir (Dir : Address; Length : Address); + pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); + + begin + Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Path_Len = 0 then + raise Use_Error with "current directory does not exist"; + end if; + + -- We need to resolve links because of RM A.16(47), which requires + -- that we not return alternative names for files. + + return Normalize_Pathname (Buffer (1 .. Path_Len)); + end Current_Directory; + + ---------------------- + -- Delete_Directory -- + ---------------------- + + procedure Delete_Directory (Directory : String) is + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Directory) then + raise Name_Error with + "invalid directory path name """ & Directory & '"'; + + elsif not Is_Directory (Directory) then + raise Name_Error with '"' & Directory & """ not a directory"; + + -- Do the deletion, checking for error + + else + declare + C_Dir_Name : constant String := Directory & ASCII.NUL; + begin + if rmdir (C_Dir_Name) /= 0 then + raise Use_Error with + "deletion of directory """ & Directory & """ failed"; + end if; + end; + end if; + end Delete_Directory; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Name : String) is + Success : Boolean; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + elsif not Is_Regular_File (Name) + and then not Is_Symbolic_Link (Name) + then + raise Name_Error with "file """ & Name & """ does not exist"; + + else + -- Do actual deletion using System.OS_Lib.Delete_File + + Delete_File (Name, Success); + + if not Success then + raise Use_Error with "file """ & Name & """ could not be deleted"; + end if; + end if; + end Delete_File; + + ----------------- + -- Delete_Tree -- + ----------------- + + procedure Delete_Tree (Directory : String) is + Search : Search_Type; + Dir_Ent : Directory_Entry_Type; + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Directory) then + raise Name_Error with + "invalid directory path name """ & Directory & '"'; + + elsif not Is_Directory (Directory) then + raise Name_Error with '"' & Directory & """ not a directory"; + + else + + -- We used to change the current directory to Directory here, + -- allowing the use of a local Simple_Name for all references. This + -- turned out unfriendly to multitasking programs, where tasks + -- running in parallel of this Delete_Tree could see their current + -- directory change unpredictably. We now resort to Full_Name + -- computations to reach files and subdirs instead. + + Start_Search (Search, Directory => Directory, Pattern => ""); + while More_Entries (Search) loop + Get_Next_Entry (Search, Dir_Ent); + + declare + Fname : constant String := Full_Name (Dir_Ent); + Sname : constant String := Simple_Name (Dir_Ent); + + begin + if OS_Lib.Is_Directory (Fname) then + if Sname /= "." and then Sname /= ".." then + Delete_Tree (Fname); + end if; + else + Delete_File (Fname); + end if; + end; + end loop; + + End_Search (Search); + + declare + C_Dir_Name : constant String := Directory & ASCII.NUL; + + begin + if rmdir (C_Dir_Name) /= 0 then + raise Use_Error with + "directory tree rooted at """ & + Directory & """ could not be deleted"; + end if; + end; + end if; + end Delete_Tree; + + ------------ + -- Exists -- + ------------ + + function Exists (Name : String) return Boolean is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- The implementation is in File_Exists + + return File_Exists (Name); + end if; + end Exists; + + --------------- + -- Extension -- + --------------- + + function Extension (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- Look for first dot that is not followed by a directory separator + + for Pos in reverse Name'Range loop + + -- If a directory separator is found before a dot, there is no + -- extension. + + if Is_In (Name (Pos), Dir_Seps) then + return Empty_String; + + elsif Name (Pos) = '.' then + + -- We found a dot, build the return value with lower bound 1 + + declare + subtype Result_Type is String (1 .. Name'Last - Pos); + begin + return Result_Type (Name (Pos + 1 .. Name'Last)); + end; + end if; + end loop; + + -- No dot were found, there is no extension + + return Empty_String; + end if; + end Extension; + + ---------------------- + -- Fetch_Next_Entry -- + ---------------------- + + procedure Fetch_Next_Entry (Search : Search_Type) is + Name : String (1 .. NAME_MAX); + Last : Natural; + + Kind : File_Kind := Ordinary_File; + -- Initialized to avoid a compilation warning + + Filename_Addr : Address; + Filename_Len : aliased Integer; + + Buffer : array (1 .. SIZEOF_struct_dirent_alloc) of Character; + + function readdir_gnat + (Directory : Address; + Buffer : Address; + Last : not null access Integer) return Address; + pragma Import (C, readdir_gnat, "__gnat_readdir"); + + begin + -- Search.Value.Is_Valid is always True when Fetch_Next_Entry is called + + loop + Filename_Addr := + readdir_gnat + (Address (Search.Value.Dir), + Buffer'Address, + Filename_Len'Access); + + -- If no matching entry is found, set Is_Valid to False + + if Filename_Addr = Null_Address then + Search.Value.Is_Valid := False; + exit; + end if; + + if Filename_Len > Name'Length then + raise Use_Error with "file name too long"; + end if; + + declare + subtype Name_String is String (1 .. Filename_Len); + Dent_Name : Name_String; + for Dent_Name'Address use Filename_Addr; + pragma Import (Ada, Dent_Name); + + begin + Last := Filename_Len; + Name (1 .. Last) := Dent_Name; + end; + + -- Check if the entry matches the pattern + + if Match (Name (1 .. Last), Search.Value.Pattern) then + declare + C_Full_Name : constant String := + Compose (To_String (Search.Value.Name), + Name (1 .. Last)) & ASCII.NUL; + Full_Name : String renames + C_Full_Name + (C_Full_Name'First .. C_Full_Name'Last - 1); + Found : Boolean := False; + Attr : aliased File_Attributes; + Exists : Integer; + Error : Integer; + + begin + Reset_Attributes (Attr'Access); + Exists := File_Exists_Attr (C_Full_Name'Address, Attr'Access); + Error := Error_Attributes (Attr'Access); + + if Error /= 0 then + raise Use_Error + with Full_Name & ": " & Errno_Message (Err => Error); + end if; + + if Exists = 1 then + + -- Now check if the file kind matches the filter + + if Is_Regular_File_Attr + (C_Full_Name'Address, Attr'Access) = 1 + then + if Search.Value.Filter (Ordinary_File) then + Kind := Ordinary_File; + Found := True; + end if; + + elsif Is_Directory_Attr + (C_Full_Name'Address, Attr'Access) = 1 + then + if Search.Value.Filter (Directory) then + Kind := Directory; + Found := True; + end if; + + elsif Search.Value.Filter (Special_File) then + Kind := Special_File; + Found := True; + end if; + + -- If it does, update Search and return + + if Found then + Search.Value.Entry_Fetched := True; + Search.Value.Dir_Entry := + (Is_Valid => True, + Simple => To_Unbounded_String (Name (1 .. Last)), + Full => To_Unbounded_String (Full_Name), + Kind => Kind); + exit; + end if; + end if; + end; + end if; + end loop; + end Fetch_Next_Entry; + + ----------------- + -- File_Exists -- + ----------------- + + function File_Exists (Name : String) return Boolean is + function C_File_Exists (A : Address) return Integer; + pragma Import (C, C_File_Exists, "__gnat_file_exists"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_File_Exists (C_Name'Address) = 1; + end File_Exists; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Search : in out Search_Type) is + begin + if Search.Value /= null then + + -- Close the directory, if one is open + + if Search.Value.Dir /= No_Dir then + Close (Search.Value.Dir); + end if; + + Free (Search.Value); + end if; + end Finalize; + + --------------- + -- Full_Name -- + --------------- + + function Full_Name (Name : String) return String is + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- Build the return value with lower bound 1 + + -- Use System.OS_Lib.Normalize_Pathname + + declare + -- We need to resolve links because of (RM A.16(47)), which says + -- we must not return alternative names for files. + + Value : constant String := Normalize_Pathname (Name); + subtype Result is String (1 .. Value'Length); + + begin + return Result (Value); + end; + end if; + end Full_Name; + + function Full_Name (Directory_Entry : Directory_Entry_Type) return String is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already been computed + + return To_String (Directory_Entry.Full); + end if; + end Full_Name; + + -------------------- + -- Get_Next_Entry -- + -------------------- + + procedure Get_Next_Entry + (Search : in out Search_Type; + Directory_Entry : out Directory_Entry_Type) + is + begin + -- First, the invalid case + + if Search.Value = null or else not Search.Value.Is_Valid then + raise Status_Error with "invalid search"; + end if; + + -- Fetch the next entry, if needed + + if not Search.Value.Entry_Fetched then + Fetch_Next_Entry (Search); + end if; + + -- It is an error if no valid entry is found + + if not Search.Value.Is_Valid then + raise Status_Error with "no next entry"; + + else + -- Reset Entry_Fetched and return the entry + + Search.Value.Entry_Fetched := False; + Directory_Entry := Search.Value.Dir_Entry; + end if; + end Get_Next_Entry; + + ---------- + -- Kind -- + ---------- + + function Kind (Name : String) return File_Kind is + begin + -- First, the invalid case + + if not File_Exists (Name) then + raise Name_Error with "file """ & Name & """ does not exist"; + + -- If OK, return appropriate kind + + elsif Is_Regular_File (Name) then + return Ordinary_File; + + elsif Is_Directory (Name) then + return Directory; + + else + return Special_File; + end if; + end Kind; + + function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return Directory_Entry.Kind; + end if; + end Kind; + + ----------------------- + -- Modification_Time -- + ----------------------- + + function Modification_Time (Name : String) return Time is + Date : OS_Time; + Year : Year_Type; + Month : Month_Type; + Day : Day_Type; + Hour : Hour_Type; + Minute : Minute_Type; + Second : Second_Type; + + begin + -- First, the invalid cases + + if not (Is_Regular_File (Name) or else Is_Directory (Name)) then + raise Name_Error with '"' & Name & """ not a file or directory"; + + else + Date := File_Time_Stamp (Name); + + -- Break down the time stamp into its constituents relative to GMT. + -- This version of Split does not recognize leap seconds or buffer + -- space for time zone processing. + + GM_Split (Date, Year, Month, Day, Hour, Minute, Second); + + -- The result must be in GMT. Ada.Calendar. + -- Formatting.Time_Of with default time zone of zero (0) is the + -- routine of choice. + + return Time_Of (Year, Month, Day, Hour, Minute, Second, 0.0); + end if; + end Modification_Time; + + function Modification_Time + (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time + is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return Modification_Time (To_String (Directory_Entry.Full)); + end if; + end Modification_Time; + + ------------------ + -- More_Entries -- + ------------------ + + function More_Entries (Search : Search_Type) return Boolean is + begin + if Search.Value = null then + return False; + + elsif Search.Value.Is_Valid then + + -- Fetch the next entry, if needed + + if not Search.Value.Entry_Fetched then + Fetch_Next_Entry (Search); + end if; + end if; + + return Search.Value.Is_Valid; + end More_Entries; + + ------------ + -- Rename -- + ------------ + + procedure Rename (Old_Name, New_Name : String) is + Success : Boolean; + + begin + -- First, the invalid cases + + if not Is_Valid_Path_Name (Old_Name) then + raise Name_Error with "invalid old path name """ & Old_Name & '"'; + + elsif not Is_Valid_Path_Name (New_Name) then + raise Name_Error with "invalid new path name """ & New_Name & '"'; + + elsif not Is_Regular_File (Old_Name) + and then not Is_Directory (Old_Name) + then + raise Name_Error with "old file """ & Old_Name & """ does not exist"; + + elsif Is_Regular_File (New_Name) or else Is_Directory (New_Name) then + raise Use_Error with + "new name """ & New_Name + & """ designates a file that already exists"; + + -- Do actual rename using System.OS_Lib.Rename_File + + else + Rename_File (Old_Name, New_Name, Success); + + if not Success then + + -- AI05-0231-1: Name_Error should be raised in case a directory + -- component of New_Name does not exist (as in New_Name => + -- "/no-such-dir/new-filename"). ENOENT indicates that. ENOENT + -- also indicate that the Old_Name does not exist, but we already + -- checked for that above. All other errors are Use_Error. + + if Errno = ENOENT then + raise Name_Error with + "file """ & Containing_Directory (New_Name) & """ not found"; + + else + raise Use_Error with + "file """ & Old_Name & """ could not be renamed"; + end if; + end if; + end if; + end Rename; + + ------------ + -- Search -- + ------------ + + procedure Search + (Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True); + Process : not null access procedure + (Directory_Entry : Directory_Entry_Type)) + is + Srch : Search_Type; + Directory_Entry : Directory_Entry_Type; + + begin + Start_Search (Srch, Directory, Pattern, Filter); + while More_Entries (Srch) loop + Get_Next_Entry (Srch, Directory_Entry); + Process (Directory_Entry); + end loop; + + End_Search (Srch); + end Search; + + ------------------- + -- Set_Directory -- + ------------------- + + procedure Set_Directory (Directory : String) is + C_Dir_Name : constant String := Directory & ASCII.NUL; + begin + if not Is_Valid_Path_Name (Directory) then + raise Name_Error with + "invalid directory path name & """ & Directory & '"'; + + elsif not Is_Directory (Directory) then + raise Name_Error with + "directory """ & Directory & """ does not exist"; + + elsif chdir (C_Dir_Name) /= 0 then + raise Name_Error with + "could not set to designated directory """ & Directory & '"'; + end if; + end Set_Directory; + + ----------------- + -- Simple_Name -- + ----------------- + + function Simple_Name (Name : String) return String is + + function Simple_Name_Internal (Path : String) return String; + -- This function does the job + + -------------------------- + -- Simple_Name_Internal -- + -------------------------- + + function Simple_Name_Internal (Path : String) return String is + Cut_Start : Natural := + Strings.Fixed.Index (Path, Dir_Seps, Going => Strings.Backward); + Cut_End : Natural; + + begin + -- Cut_Start pointS to the first simple name character + + Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); + + -- Cut_End point to the last simple name character + + Cut_End := Path'Last; + + Check_For_Standard_Dirs : declare + BN : constant String := Path (Cut_Start .. Cut_End); + + Has_Drive_Letter : constant Boolean := + OS_Lib.Path_Separator /= ':'; + -- If Path separator is not ':' then we are on a DOS based OS + -- where this character is used as a drive letter separator. + + begin + if BN = "." or else BN = ".." then + return ""; + + elsif Has_Drive_Letter + and then BN'Length > 2 + and then Characters.Handling.Is_Letter (BN (BN'First)) + and then BN (BN'First + 1) = ':' + then + -- We have a DOS drive letter prefix, remove it + + return BN (BN'First + 2 .. BN'Last); + + else + return BN; + end if; + end Check_For_Standard_Dirs; + end Simple_Name_Internal; + + -- Start of processing for Simple_Name + + begin + -- First, the invalid case + + if not Is_Valid_Path_Name (Name) then + raise Name_Error with "invalid path name """ & Name & '"'; + + else + -- Build the value to return with lower bound 1 + + declare + Value : constant String := Simple_Name_Internal (Name); + subtype Result is String (1 .. Value'Length); + begin + return Result (Value); + end; + end if; + end Simple_Name; + + function Simple_Name + (Directory_Entry : Directory_Entry_Type) return String is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return To_String (Directory_Entry.Simple); + end if; + end Simple_Name; + + ---------- + -- Size -- + ---------- + + function Size (Name : String) return File_Size is + C_Name : String (1 .. Name'Length + 1); + + function C_Size (Name : Address) return int64; + pragma Import (C, C_Size, "__gnat_named_file_length"); + + begin + -- First, the invalid case + + if not Is_Regular_File (Name) then + raise Name_Error with "file """ & Name & """ does not exist"; + + else + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return File_Size (C_Size (C_Name'Address)); + end if; + end Size; + + function Size (Directory_Entry : Directory_Entry_Type) return File_Size is + begin + -- First, the invalid case + + if not Directory_Entry.Is_Valid then + raise Status_Error with "invalid directory entry"; + + else + -- The value to return has already be computed + + return Size (To_String (Directory_Entry.Full)); + end if; + end Size; + + ------------------ + -- Start_Search -- + ------------------ + + procedure Start_Search + (Search : in out Search_Type; + Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True)) + is + function opendir (file_name : String) return DIRs; + pragma Import (C, opendir, "__gnat_opendir"); + + C_File_Name : constant String := Directory & ASCII.NUL; + Pat : Regexp; + Dir : Dir_Type_Value; + + begin + -- First, the invalid case Name_Error + + if not Is_Directory (Directory) then + raise Name_Error with + "unknown directory """ & Simple_Name (Directory) & '"'; + end if; + + -- Check the pattern + + begin + Pat := Compile + (Pattern, + Glob => True, + Case_Sensitive => Is_Path_Name_Case_Sensitive); + exception + when Error_In_Regexp => + Free (Search.Value); + raise Name_Error with "invalid pattern """ & Pattern & '"'; + end; + + Dir := Dir_Type_Value (opendir (C_File_Name)); + + if Dir = No_Dir then + raise Use_Error with + "unreadable directory """ & Simple_Name (Directory) & '"'; + end if; + + -- If needed, finalize Search + + Finalize (Search); + + -- Allocate the default data + + Search.Value := new Search_Data; + + -- Initialize some Search components + + Search.Value.Filter := Filter; + Search.Value.Name := To_Unbounded_String (Full_Name (Directory)); + Search.Value.Pattern := Pat; + Search.Value.Dir := Dir; + Search.Value.Is_Valid := True; + end Start_Search; + +end Ada.Directories; diff --git a/gcc/ada/libgnat/a-direct.ads b/gcc/ada/libgnat/a-direct.ads new file mode 100644 index 0000000..d338ade --- /dev/null +++ b/gcc/ada/libgnat/a-direct.ads @@ -0,0 +1,487 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived for use with GNAT from AI-00248, which is -- +-- expected to be a part of a future expected revised Ada Reference Manual. -- +-- 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005: Implementation of Ada.Directories (AI95-00248). Note that this +-- unit is available without -gnat05. That seems reasonable, since you only +-- get it if you explicitly ask for it. + +-- External files may be classified as directories, special files, or ordinary +-- files. A directory is an external file that is a container for files on +-- the target system. A special file is an external file that cannot be +-- created or read by a predefined Ada Input-Output package. External files +-- that are not special files or directories are called ordinary files. + +-- A file name is a string identifying an external file. Similarly, a +-- directory name is a string identifying a directory. The interpretation of +-- file names and directory names is implementation-defined. + +-- The full name of an external file is a full specification of the name of +-- the file. If the external environment allows alternative specifications of +-- the name (for example, abbreviations), the full name should not use such +-- alternatives. A full name typically will include the names of all of +-- directories that contain the item. The simple name of an external file is +-- the name of the item, not including any containing directory names. Unless +-- otherwise specified, a file name or directory name parameter to a +-- predefined Ada input-output subprogram can be a full name, a simple name, +-- or any other form of name supported by the implementation. + +-- The default directory is the directory that is used if a directory or +-- file name is not a full name (that is, when the name does not fully +-- identify all of the containing directories). + +-- A directory entry is a single item in a directory, identifying a single +-- external file (including directories and special files). + +-- For each function that returns a string, the lower bound of the returned +-- value is 1. + +with Ada.Calendar; +with Ada.Finalization; +with Ada.IO_Exceptions; +with Ada.Strings.Unbounded; + +package Ada.Directories is + + ----------------------------------- + -- Directory and File Operations -- + ----------------------------------- + + function Current_Directory return String; + -- Returns the full directory name for the current default directory. The + -- name returned must be suitable for a future call to Set_Directory. + -- The exception Use_Error is propagated if a default directory is not + -- supported by the external environment. + + procedure Set_Directory (Directory : String); + -- Sets the current default directory. The exception Name_Error is + -- propagated if the string given as Directory does not identify an + -- existing directory. The exception Use_Error is propagated if the + -- external environment does not support making Directory (in the absence + -- of Name_Error) a default directory. + + procedure Create_Directory + (New_Directory : String; + Form : String := ""); + -- Creates a directory with name New_Directory. The Form parameter can be + -- used to give system-dependent characteristics of the directory; the + -- interpretation of the Form parameter is implementation-defined. A null + -- string for Form specifies the use of the default options of the + -- implementation of the new directory. The exception Name_Error is + -- propagated if the string given as New_Directory does not allow the + -- identification of a directory. The exception Use_Error is propagated if + -- the external environment does not support the creation of a directory + -- with the given name (in the absence of Name_Error) and form. + -- + -- The Form parameter is ignored + + procedure Delete_Directory (Directory : String); + -- Deletes an existing empty directory with name Directory. The exception + -- Name_Error is propagated if the string given as Directory does not + -- identify an existing directory. The exception Use_Error is propagated + -- if the external environment does not support the deletion of the + -- directory (or some portion of its contents) with the given name (in the + -- absence of Name_Error). + + procedure Create_Path + (New_Directory : String; + Form : String := ""); + -- Creates zero or more directories with name New_Directory. Each + -- non-existent directory named by New_Directory is created. For example, + -- on a typical Unix system, Create_Path ("/usr/me/my"); would create + -- directory "me" in directory "usr", then create directory "my" + -- in directory "me". The Form can be used to give system-dependent + -- characteristics of the directory; the interpretation of the Form + -- parameter is implementation-defined. A null string for Form specifies + -- the use of the default options of the implementation of the new + -- directory. The exception Name_Error is propagated if the string given + -- as New_Directory does not allow the identification of any directory. The + -- exception Use_Error is propagated if the external environment does not + -- support the creation of any directories with the given name (in the + -- absence of Name_Error) and form. + -- + -- The Form parameter is ignored + + procedure Delete_Tree (Directory : String); + -- Deletes an existing directory with name Directory. The directory and + -- all of its contents (possibly including other directories) are deleted. + -- The exception Name_Error is propagated if the string given as Directory + -- does not identify an existing directory. The exception Use_Error is + -- propagated if the external environment does not support the deletion + -- of the directory or some portion of its contents with the given name + -- (in the absence of Name_Error). If Use_Error is propagated, it is + -- unspecified if a portion of the contents of the directory are deleted. + + procedure Delete_File (Name : String); + -- Deletes an existing ordinary or special file with Name. The exception + -- Name_Error is propagated if the string given as Name does not identify + -- an existing ordinary or special external file. The exception Use_Error + -- is propagated if the external environment does not support the deletion + -- of the file with the given name (in the absence of Name_Error). + + procedure Rename (Old_Name, New_Name : String); + -- Renames an existing external file (including directories) with Old_Name + -- to New_Name. The exception Name_Error is propagated if the string given + -- as Old_Name does not identify an existing external file. The exception + -- Use_Error is propagated if the external environment does not support the + -- renaming of the file with the given name (in the absence of Name_Error). + -- In particular, Use_Error is propagated if a file or directory already + -- exists with New_Name. + + procedure Copy_File + (Source_Name : String; + Target_Name : String; + Form : String := ""); + -- Copies the contents of the existing external file with Source_Name to + -- Target_Name. The resulting external file is a duplicate of the source + -- external file. The Form argument can be used to give system-dependent + -- characteristics of the resulting external file; the interpretation of + -- the Form parameter is implementation-defined. Exception Name_Error is + -- propagated if the string given as Source_Name does not identify an + -- existing external ordinary or special file or if the string given as + -- Target_Name does not allow the identification of an external file. The + -- exception Use_Error is propagated if the external environment does not + -- support the creating of the file with the name given by Target_Name and + -- form given by Form, or copying of the file with the name given by + -- Source_Name (in the absence of Name_Error). + -- + -- Interpretation of the Form parameter: + -- + -- The Form parameter is case-insensitive + -- + -- Two fields are recognized in the Form parameter: + -- preserve= + -- mode= + -- + -- starts immediately after the character '=' and ends with the + -- character immediately preceding the next comma (',') or with the + -- last character of the parameter. + -- + -- The allowed values for preserve= are: + -- + -- no_attributes: Do not try to preserve any file attributes. This + -- is the default if no preserve= is found in Form. + -- + -- all_attributes: Try to preserve all file attributes (timestamps, + -- access rights). + -- + -- timestamps: Preserve the timestamp of the copied file, but not + -- the other file attributes. + -- + -- The allowed values for mode= are: + -- + -- copy: Only copy if the destination file does not already + -- exist. If it already exists, Copy_File will fail. + -- + -- overwrite: Copy the file in all cases. Overwrite an already + -- existing destination file. This is the default if + -- no mode= is found in Form. + -- + -- append: Append the original file to the destination file. + -- If the destination file does not exist, the + -- destination file is a copy of the source file. + -- When mode=append, the field preserve=, if it + -- exists, is not taken into account. + -- + -- If the Form parameter includes one or both of the fields and the value + -- or values are incorrect, Copy_File fails with Use_Error. + -- + -- Examples of correct Forms: + -- Form => "preserve=no_attributes,mode=overwrite" (the default) + -- Form => "mode=append" + -- Form => "mode=copy,preserve=all_attributes" + -- + -- Examples of incorrect Forms: + -- Form => "preserve=junk" + -- Form => "mode=internal,preserve=timestamps" + + ---------------------------------------- + -- File and directory name operations -- + ---------------------------------------- + + function Full_Name (Name : String) return String; + -- Returns the full name corresponding to the file name specified by Name. + -- The exception Name_Error is propagated if the string given as Name does + -- not allow the identification of an external file (including directories + -- and special files). + + function Simple_Name (Name : String) return String; + -- Returns the simple name portion of the file name specified by Name. The + -- exception Name_Error is propagated if the string given as Name does not + -- allow the identification of an external file (including directories and + -- special files). + + function Containing_Directory (Name : String) return String; + -- Returns the name of the containing directory of the external file + -- (including directories) identified by Name. If more than one directory + -- can contain Name, the directory name returned is implementation-defined. + -- The exception Name_Error is propagated if the string given as Name does + -- not allow the identification of an external file. The exception + -- Use_Error is propagated if the external file does not have a containing + -- directory. + + function Extension (Name : String) return String; + -- Returns the extension name corresponding to Name. The extension name is + -- a portion of a simple name (not including any separator characters), + -- typically used to identify the file class. If the external environment + -- does not have extension names, then the null string is returned. + -- The exception Name_Error is propagated if the string given as Name does + -- not allow the identification of an external file. + + function Base_Name (Name : String) return String; + -- Returns the base name corresponding to Name. The base name is the + -- remainder of a simple name after removing any extension and extension + -- separators. The exception Name_Error is propagated if the string given + -- as Name does not allow the identification of an external file + -- (including directories and special files). + + function Compose + (Containing_Directory : String := ""; + Name : String; + Extension : String := "") return String; + -- Returns the name of the external file with the specified + -- Containing_Directory, Name, and Extension. If Extension is the null + -- string, then Name is interpreted as a simple name; otherwise Name is + -- interpreted as a base name. The exception Name_Error is propagated if + -- the string given as Containing_Directory is not null and does not allow + -- the identification of a directory, or if the string given as Extension + -- is not null and is not a possible extension, or if the string given as + -- Name is not a possible simple name (if Extension is null) or base name + -- (if Extension is non-null). + + -------------------------------- + -- File and directory queries -- + -------------------------------- + + type File_Kind is (Directory, Ordinary_File, Special_File); + -- The type File_Kind represents the kind of file represented by an + -- external file or directory. + + type File_Size is range 0 .. Long_Long_Integer'Last; + -- The type File_Size represents the size of an external file + + function Exists (Name : String) return Boolean; + -- Returns True if external file represented by Name exists, and False + -- otherwise. The exception Name_Error is propagated if the string given as + -- Name does not allow the identification of an external file (including + -- directories and special files). + + function Kind (Name : String) return File_Kind; + -- Returns the kind of external file represented by Name. The exception + -- Name_Error is propagated if the string given as Name does not allow the + -- identification of an existing external file. + + function Size (Name : String) return File_Size; + -- Returns the size of the external file represented by Name. The size of + -- an external file is the number of stream elements contained in the file. + -- If the external file is discontiguous (not all elements exist), the + -- result is implementation-defined. If the external file is not an + -- ordinary file, the result is implementation-defined. The exception + -- Name_Error is propagated if the string given as Name does not allow the + -- identification of an existing external file. The exception + -- Constraint_Error is propagated if the file size is not a value of type + -- File_Size. + + function Modification_Time (Name : String) return Ada.Calendar.Time; + -- Returns the time that the external file represented by Name was most + -- recently modified. If the external file is not an ordinary file, the + -- result is implementation-defined. The exception Name_Error is propagated + -- if the string given as Name does not allow the identification of an + -- existing external file. The exception Use_Error is propagated if the + -- external environment does not support the reading the modification time + -- of the file with the name given by Name (in the absence of Name_Error). + + ------------------------- + -- Directory Searching -- + ------------------------- + + type Directory_Entry_Type is limited private; + -- The type Directory_Entry_Type represents a single item in a directory. + -- These items can only be created by the Get_Next_Entry procedure in this + -- package. Information about the item can be obtained from the functions + -- declared in this package. A default initialized object of this type is + -- invalid; objects returned from Get_Next_Entry are valid. + + type Filter_Type is array (File_Kind) of Boolean; + -- The type Filter_Type specifies which directory entries are provided from + -- a search operation. If the Directory component is True, directory + -- entries representing directories are provided. If the Ordinary_File + -- component is True, directory entries representing ordinary files are + -- provided. If the Special_File component is True, directory entries + -- representing special files are provided. + + type Search_Type is limited private; + -- The type Search_Type contains the state of a directory search. A + -- default-initialized Search_Type object has no entries available + -- (More_Entries returns False). + + procedure Start_Search + (Search : in out Search_Type; + Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True)); + -- Starts a search in the directory entry in the directory named by + -- Directory for entries matching Pattern. Pattern represents a file name + -- matching pattern. If Pattern is null, all items in the directory are + -- matched; otherwise, the interpretation of Pattern is implementation- + -- defined. Only items which match Filter will be returned. After a + -- successful call on Start_Search, the object Search may have entries + -- available, but it may have no entries available if no files or + -- directories match Pattern and Filter. The exception Name_Error is + -- propagated if the string given by Directory does not identify an + -- existing directory, or if Pattern does not allow the identification of + -- any possible external file or directory. The exception Use_Error is + -- propagated if the external environment does not support the searching + -- of the directory with the given name (in the absence of Name_Error). + + procedure End_Search (Search : in out Search_Type); + -- Ends the search represented by Search. After a successful call on + -- End_Search, the object Search will have no entries available. Note + -- that it is not necessary to call End_Search if the call to Start_Search + -- was unsuccessful and raised an exception (but it is harmless to make + -- the call in this case). + + function More_Entries (Search : Search_Type) return Boolean; + -- Returns True if more entries are available to be returned by a call + -- to Get_Next_Entry for the specified search object, and False otherwise. + + procedure Get_Next_Entry + (Search : in out Search_Type; + Directory_Entry : out Directory_Entry_Type); + -- Returns the next Directory_Entry for the search described by Search that + -- matches the pattern and filter. If no further matches are available, + -- Status_Error is raised. It is implementation-defined as to whether the + -- results returned by this routine are altered if the contents of the + -- directory are altered while the Search object is valid (for example, by + -- another program). The exception Use_Error is propagated if the external + -- environment does not support continued searching of the directory + -- represented by Search. + + procedure Search + (Directory : String; + Pattern : String; + Filter : Filter_Type := (others => True); + Process : not null access procedure + (Directory_Entry : Directory_Entry_Type)); + -- Searches in the directory named by Directory for entries matching + -- Pattern. The subprogram designated by Process is called with each + -- matching entry in turn. Pattern represents a pattern for matching file + -- names. If Pattern is null, all items in the directory are matched; + -- otherwise, the interpretation of Pattern is implementation-defined. + -- Only items that match Filter will be returned. The exception Name_Error + -- is propagated if the string given by Directory does not identify + -- an existing directory, or if Pattern does not allow the identification + -- of any possible external file or directory. The exception Use_Error is + -- propagated if the external environment does not support the searching + -- of the directory with the given name (in the absence of Name_Error). + + ------------------------------------- + -- Operations on Directory Entries -- + ------------------------------------- + + function Simple_Name (Directory_Entry : Directory_Entry_Type) return String; + -- Returns the simple external name of the external file (including + -- directories) represented by Directory_Entry. The format of the name + -- returned is implementation-defined. The exception Status_Error is + -- propagated if Directory_Entry is invalid. + + function Full_Name (Directory_Entry : Directory_Entry_Type) return String; + -- Returns the full external name of the external file (including + -- directories) represented by Directory_Entry. The format of the name + -- returned is implementation-defined. The exception Status_Error is + -- propagated if Directory_Entry is invalid. + + function Kind (Directory_Entry : Directory_Entry_Type) return File_Kind; + -- Returns the kind of external file represented by Directory_Entry. The + -- exception Status_Error is propagated if Directory_Entry is invalid. + + function Size (Directory_Entry : Directory_Entry_Type) return File_Size; + -- Returns the size of the external file represented by Directory_Entry. + -- The size of an external file is the number of stream elements contained + -- in the file. If the external file is discontiguous (not all elements + -- exist), the result is implementation-defined. If the external file + -- represented by Directory_Entry is not an ordinary file, the result is + -- implementation-defined. The exception Status_Error is propagated if + -- Directory_Entry is invalid. The exception Constraint_Error is propagated + -- if the file size is not a value of type File_Size. + + function Modification_Time + (Directory_Entry : Directory_Entry_Type) return Ada.Calendar.Time; + -- Returns the time that the external file represented by Directory_Entry + -- was most recently modified. If the external file represented by + -- Directory_Entry is not an ordinary file, the result is + -- implementation-defined. The exception Status_Error is propagated if + -- Directory_Entry is invalid. The exception Use_Error is propagated if + -- the external environment does not support the reading the modification + -- time of the file represented by Directory_Entry. + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames Ada.IO_Exceptions.Status_Error; + Name_Error : exception renames Ada.IO_Exceptions.Name_Error; + Use_Error : exception renames Ada.IO_Exceptions.Use_Error; + Device_Error : exception renames Ada.IO_Exceptions.Device_Error; + +private + type Directory_Entry_Type is record + Is_Valid : Boolean := False; + Simple : Ada.Strings.Unbounded.Unbounded_String; + Full : Ada.Strings.Unbounded.Unbounded_String; + Kind : File_Kind := Ordinary_File; + end record; + + -- The type Search_Data is defined in the body, so that the spec does not + -- depend on packages of the GNAT hierarchy. + + type Search_Data; + type Search_Ptr is access Search_Data; + + -- Search_Type need to be a controlled type, because it includes component + -- of type Dir_Type (in GNAT.Directory_Operations) that need to be closed + -- (if opened) during finalization. The component need to be an access + -- value, because Search_Data is not fully defined in the spec. + + type Search_Type is new Ada.Finalization.Controlled with record + Value : Search_Ptr; + end record; + + procedure Finalize (Search : in out Search_Type); + -- Close the directory, if opened, and deallocate Value + + procedure End_Search (Search : in out Search_Type) renames Finalize; + +end Ada.Directories; diff --git a/gcc/ada/libgnat/a-direio.adb b/gcc/ada/libgnat/a-direio.adb new file mode 100644 index 0000000..f506314 --- /dev/null +++ b/gcc/ada/libgnat/a-direio.adb @@ -0,0 +1,289 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the generic template for Direct_IO, i.e. the code that gets +-- duplicated. We absolutely minimize this code by either calling routines +-- in System.File_IO (for common file functions), or in System.Direct_IO +-- (for specialized Direct_IO functions) + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.CRTL; +with System.File_Control_Block; +with System.File_IO; +with System.Storage_Elements; +with Ada.Unchecked_Conversion; + +package body Ada.Direct_IO is + + Zeroes : constant System.Storage_Elements.Storage_Array := + (1 .. System.Storage_Elements.Storage_Offset (Bytes) => 0); + -- Buffer used to fill out partial records + + package FCB renames System.File_Control_Block; + package FIO renames System.File_IO; + package DIO renames System.Direct_IO; + + SU : constant := System.Storage_Unit; + + subtype AP is FCB.AFCB_Ptr; + subtype FP is DIO.File_Type; + subtype DPCount is DIO.Positive_Count; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_DIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + + use type System.CRTL.size_t; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Inout_File; + Name : String := ""; + Form : String := "") + is + begin + DIO.Create (FP (File), To_FCB (Mode), Name, Form); + File.Bytes := Bytes; + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + begin + return DIO.End_Of_File (FP (File)); + end End_Of_File; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + ----------- + -- Index -- + ----------- + + function Index (File : File_Type) return Positive_Count is + begin + return Positive_Count (DIO.Index (FP (File))); + end Index; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_DIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + begin + DIO.Open (FP (File), To_FCB (Mode), Name, Form); + File.Bytes := Bytes; + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : File_Type; + Item : out Element_Type; + From : Positive_Count) + is + begin + -- For a non-constrained variant record type, we read into an + -- intermediate buffer, since we may have the case of discriminated + -- records where a discriminant check is required, and we may need + -- to assign only part of the record buffer originally written. + + -- Note: we have to turn warnings on/off because this use of + -- the Constrained attribute is an obsolescent feature. + + pragma Warnings (Off); + if not Element_Type'Constrained then + pragma Warnings (On); + + declare + Buf : Element_Type; + + begin + DIO.Read (FP (File), Buf'Address, Bytes, DPCount (From)); + Item := Buf; + end; + + -- In the normal case, we can read straight into the buffer + + else + DIO.Read (FP (File), Item'Address, Bytes, DPCount (From)); + end if; + end Read; + + procedure Read (File : File_Type; Item : out Element_Type) is + begin + -- Same processing for unconstrained case as above + + -- Note: we have to turn warnings on/off because this use of + -- the Constrained attribute is an obsolescent feature. + + pragma Warnings (Off); + if not Element_Type'Constrained then + pragma Warnings (On); + + declare + Buf : Element_Type; + + begin + DIO.Read (FP (File), Buf'Address, Bytes); + Item := Buf; + end; + + else + DIO.Read (FP (File), Item'Address, Bytes); + end if; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : File_Mode) is + begin + DIO.Reset (FP (File), To_FCB (Mode)); + end Reset; + + procedure Reset (File : in out File_Type) is + begin + DIO.Reset (FP (File)); + end Reset; + + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index (File : File_Type; To : Positive_Count) is + begin + DIO.Set_Index (FP (File), DPCount (To)); + end Set_Index; + + ---------- + -- Size -- + ---------- + + function Size (File : File_Type) return Count is + begin + return Count (DIO.Size (FP (File))); + end Size; + + ----------- + -- Write -- + ----------- + + procedure Write + (File : File_Type; + Item : Element_Type; + To : Positive_Count) + is + begin + DIO.Set_Index (FP (File), DPCount (To)); + DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); + end Write; + + procedure Write (File : File_Type; Item : Element_Type) is + begin + DIO.Write (FP (File), Item'Address, Item'Size / SU, Zeroes); + end Write; + +end Ada.Direct_IO; diff --git a/gcc/ada/libgnat/a-direio.ads b/gcc/ada/libgnat/a-direio.ads new file mode 100644 index 0000000..96ed11d --- /dev/null +++ b/gcc/ada/libgnat/a-direio.ads @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System.Direct_IO; +with Interfaces.C_Streams; + +generic + type Element_Type is private; + +package Ada.Direct_IO is + + pragma Compile_Time_Warning + (Element_Type'Has_Access_Values, + "Element_Type for Direct_IO instance has access values"); + + pragma Compile_Time_Warning + (Element_Type'Has_Tagged_Values, + "Element_Type for Direct_IO instance has tagged values"); + + type File_Type is limited private; + + type File_Mode is (In_File, Inout_File, Out_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) + Inout_File => 1, -- System.File_IO.File_Mode'Pos (Inout_File); + Out_File => 2); -- System.File_IO.File_Mode'Pos (Out_File) + + type Count is range 0 .. System.Direct_IO.Count'Last; + + subtype Positive_Count is Count range 1 .. Count'Last; + + --------------------- + -- File Management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Inout_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : File_Type) return File_Mode; + function Name (File : File_Type) return String; + function Form (File : File_Type) return String; + + function Is_Open (File : File_Type) return Boolean; + + procedure Flush (File : File_Type); + + --------------------------------- + -- Input and Output Operations -- + --------------------------------- + + procedure Read + (File : File_Type; + Item : out Element_Type; + From : Positive_Count); + + procedure Read + (File : File_Type; + Item : out Element_Type); + + procedure Write + (File : File_Type; + Item : Element_Type; + To : Positive_Count); + + procedure Write + (File : File_Type; + Item : Element_Type); + + procedure Set_Index (File : File_Type; To : Positive_Count); + + function Index (File : File_Type) return Positive_Count; + function Size (File : File_Type) return Count; + + function End_Of_File (File : File_Type) return Boolean; + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + +private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + + type File_Type is new System.Direct_IO.File_Type; + + Bytes : constant Interfaces.C_Streams.size_t := + Interfaces.C_Streams.size_t'Max + (1, Element_Type'Max_Size_In_Storage_Elements); + -- Size of an element in storage units. The Max operation here is to ensure + -- that we allocate a single byte for zero-sized elements. It's a bit weird + -- to instantiate Direct_IO with zero sized elements, but it is legal and + -- this adjustment ensures that we don't get anomalous behavior. + + pragma Inline (Close); + pragma Inline (Create); + pragma Inline (Delete); + pragma Inline (End_Of_File); + pragma Inline (Form); + pragma Inline (Index); + pragma Inline (Is_Open); + pragma Inline (Mode); + pragma Inline (Name); + pragma Inline (Open); + pragma Inline (Read); + pragma Inline (Reset); + pragma Inline (Set_Index); + pragma Inline (Size); + pragma Inline (Write); + +end Ada.Direct_IO; diff --git a/gcc/ada/libgnat/a-dirval-mingw.adb b/gcc/ada/libgnat/a-dirval-mingw.adb new file mode 100644 index 0000000..b0a9cc3 --- /dev/null +++ b/gcc/ada/libgnat/a-dirval-mingw.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S . V A L I D I T Y -- +-- -- +-- B o d y -- +-- (Windows Version) -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows version of this package + +with Ada.Characters.Latin_1; use Ada.Characters.Latin_1; + +package body Ada.Directories.Validity is + + Invalid_Character : constant array (Character) of Boolean := + (NUL .. US | '\' => True, + '/' | ':' | '*' | '?' => True, + '"' | '<' | '>' | '|' => True, + DEL => True, + others => False); + -- Note that a valid file-name or path-name is implementation defined. + -- To support UTF-8 file and directory names, we do not want to be too + -- restrictive here. + + --------------------------------- + -- Is_Path_Name_Case_Sensitive -- + --------------------------------- + + function Is_Path_Name_Case_Sensitive return Boolean is + begin + return False; + end Is_Path_Name_Case_Sensitive; + + ------------------------ + -- Is_Valid_Path_Name -- + ------------------------ + + function Is_Valid_Path_Name (Name : String) return Boolean is + Start : Positive := Name'First; + Last : Natural; + + begin + -- A path name cannot be empty, cannot contain more than 256 characters, + -- cannot contain invalid characters and each directory/file name need + -- to be valid. + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + else + -- A drive letter may be specified at the beginning + + if Name'Length >= 2 + and then Name (Start + 1) = ':' + and then + (Name (Start) in 'A' .. 'Z' or else Name (Start) in 'a' .. 'z') + then + Start := Start + 2; + + -- A drive letter followed by a colon and followed by nothing or + -- by a relative path is an ambiguous path name on Windows, so we + -- don't accept it. + + if Start > Name'Last + or else (Name (Start) /= '/' and then Name (Start) /= '\') + then + return False; + end if; + end if; + + loop + -- Look for the start of the next directory or file name + + while Start <= Name'Last + and then (Name (Start) = '\' or Name (Start) = '/') + loop + Start := Start + 1; + end loop; + + -- If all directories/file names are OK, return True + + exit when Start > Name'Last; + + Last := Start; + + -- Look for the end of the directory/file name + + while Last < Name'Last loop + exit when Name (Last + 1) = '\' or Name (Last + 1) = '/'; + Last := Last + 1; + end loop; + + -- Check if the directory/file name is valid + + if not Is_Valid_Simple_Name (Name (Start .. Last)) then + return False; + end if; + + -- Move to the next name + + Start := Last + 1; + end loop; + end if; + + -- If Name follows the rules, it is valid + + return True; + end Is_Valid_Path_Name; + + -------------------------- + -- Is_Valid_Simple_Name -- + -------------------------- + + function Is_Valid_Simple_Name (Name : String) return Boolean is + Only_Spaces : Boolean; + + begin + -- A file name cannot be empty, cannot contain more than 256 characters, + -- and cannot contain invalid characters. + + if Name'Length = 0 or else Name'Length > 256 then + return False; + + -- Name length is OK + + else + Only_Spaces := True; + for J in Name'Range loop + if Invalid_Character (Name (J)) then + return False; + elsif Name (J) /= ' ' then + Only_Spaces := False; + end if; + end loop; + + -- If no invalid chars, and not all spaces, file name is valid + + return not Only_Spaces; + end if; + end Is_Valid_Simple_Name; + + ------------- + -- Windows -- + ------------- + + function Windows return Boolean is + begin + return True; + end Windows; + +end Ada.Directories.Validity; diff --git a/gcc/ada/libgnat/a-dirval.adb b/gcc/ada/libgnat/a-dirval.adb new file mode 100644 index 0000000..25466a5 --- /dev/null +++ b/gcc/ada/libgnat/a-dirval.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S . V A L I D I T Y -- +-- -- +-- B o d y -- +-- (POSIX Version) -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the POSIX version of this package + +package body Ada.Directories.Validity is + + --------------------------------- + -- Is_Path_Name_Case_Sensitive -- + --------------------------------- + + function Is_Path_Name_Case_Sensitive return Boolean is + begin + return True; + end Is_Path_Name_Case_Sensitive; + + ------------------------ + -- Is_Valid_Path_Name -- + ------------------------ + + function Is_Valid_Path_Name (Name : String) return Boolean is + begin + -- A path name cannot be empty and cannot contain any NUL character + + if Name'Length = 0 then + return False; + + else + for J in Name'Range loop + if Name (J) = ASCII.NUL then + return False; + end if; + end loop; + end if; + + -- If Name does not contain any NUL character, it is valid + + return True; + end Is_Valid_Path_Name; + + -------------------------- + -- Is_Valid_Simple_Name -- + -------------------------- + + function Is_Valid_Simple_Name (Name : String) return Boolean is + begin + -- A file name cannot be empty and cannot contain a slash ('/') or + -- the NUL character. + + if Name'Length = 0 then + return False; + + else + for J in Name'Range loop + if Name (J) = '/' or else Name (J) = ASCII.NUL then + return False; + end if; + end loop; + end if; + + -- If Name does not contain any slash or NUL, it is valid + + return True; + end Is_Valid_Simple_Name; + + ------------- + -- Windows -- + ------------- + + function Windows return Boolean is + begin + return False; + end Windows; + +end Ada.Directories.Validity; diff --git a/gcc/ada/libgnat/a-dirval.ads b/gcc/ada/libgnat/a-dirval.ads new file mode 100644 index 0000000..a5deca6 --- /dev/null +++ b/gcc/ada/libgnat/a-dirval.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . D I R E C T O R I E S . V A L I D I T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This private child package is used in the body of Ada.Directories. +-- It has several bodies, for different platforms. + +private package Ada.Directories.Validity is + + function Is_Valid_Simple_Name (Name : String) return Boolean; + -- Returns True if Name is a valid file name + + function Is_Valid_Path_Name (Name : String) return Boolean; + -- Returns True if Name is a valid path name + + function Is_Path_Name_Case_Sensitive return Boolean; + -- Returns True if file and path names are case-sensitive + + function Windows return Boolean; + -- Return True when OS is Windows + +end Ada.Directories.Validity; diff --git a/gcc/ada/libgnat/a-einuoc.adb b/gcc/ada/libgnat/a-einuoc.adb new file mode 100644 index 0000000..2a9f8b9 --- /dev/null +++ b/gcc/ada/libgnat/a-einuoc.adb @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +--------------------------------------- +-- Ada.Exceptions.Is_Null_Occurrence -- +--------------------------------------- + +function Ada.Exceptions.Is_Null_Occurrence + (X : Exception_Occurrence) return Boolean +is +begin + -- The null exception is uniquely identified by the fact that the Id value + -- is null. No other exception occurrence can have a null Id. + + if X.Id = Null_Id then + return True; + else + return False; + end if; +end Ada.Exceptions.Is_Null_Occurrence; diff --git a/gcc/ada/libgnat/a-einuoc.ads b/gcc/ada/libgnat/a-einuoc.ads new file mode 100644 index 0000000..f428124 --- /dev/null +++ b/gcc/ada/libgnat/a-einuoc.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . I S _ N U L L _ O C C U R R E N C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNAT-specific child function of Ada.Exceptions. It provides +-- clearly missing functionality for its parent package, and most reasonably +-- would simply be an added function to that package, but this change cannot +-- be made in a conforming manner. + +function Ada.Exceptions.Is_Null_Occurrence + (X : Exception_Occurrence) return Boolean; +pragma Preelaborate (Ada.Exceptions.Is_Null_Occurrence); +-- This function yields True if X is Null_Occurrence, and False otherwise diff --git a/gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb b/gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb new file mode 100644 index 0000000..1b03a18 --- /dev/null +++ b/gcc/ada/libgnat/a-elchha-vxworks-ppc-full.adb @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +with System.Standard_Library; +pragma Warnings (On); + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; +with GNAT.IO; use GNAT.IO; + +-- Default last chance handler for use with the full VxWorks 653 partition OS +-- Ada run-time library. + +-- Logs error with health monitor, and dumps exception identity and argument +-- string for vxaddr2line for generation of a symbolic stack backtrace. + +procedure Ada.Exceptions.Last_Chance_Handler (Except : Exception_Occurrence) is + + ---------------------- + -- APEX definitions -- + ---------------------- + + pragma Warnings (Off); + type Error_Code_Type is ( + Deadline_Missed, + Application_Error, + Numeric_Error, + Illegal_Request, + Stack_Overflow, + Memory_Violation, + Hardware_Fault, + Power_Fail); + pragma Warnings (On); + pragma Convention (C, Error_Code_Type); + -- APEX Health Management error codes + + type Message_Addr_Type is new System.Address; + + type Apex_Integer is range -(2 ** 31) .. (2 ** 31) - 1; + pragma Convention (C, Apex_Integer); + + Max_Error_Message_Size : constant := 64; + + type Error_Message_Size_Type is new Apex_Integer range + 1 .. Max_Error_Message_Size; + + pragma Warnings (Off); + type Return_Code_Type is ( + No_Error, -- request valid and operation performed + No_Action, -- status of system unaffected by request + Not_Available, -- resource required by request unavailable + Invalid_Param, -- invalid parameter specified in request + Invalid_Config, -- parameter incompatible with configuration + Invalid_Mode, -- request incompatible with current mode + Timed_Out); -- time-out tied up with request has expired + pragma Warnings (On); + pragma Convention (C, Return_Code_Type); + -- APEX return codes + + procedure Raise_Application_Error + (Error_Code : Error_Code_Type; + Message_Addr : Message_Addr_Type; + Length : Error_Message_Size_Type; + Return_Code : out Return_Code_Type); + pragma Import (C, Raise_Application_Error, "RAISE_APPLICATION_ERROR"); + + procedure Unhandled_Terminate; + pragma No_Return (Unhandled_Terminate); + pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); + -- Perform system dependent shutdown code + + procedure Adainit; + pragma Import (Ada, Adainit, "adainit"); + + Adainit_Addr : constant System.Address := Adainit'Code_Address; + -- Part of arguments to vxaddr2line + + Result : Return_Code_Type; + + Message : String := + Exception_Name (Except) & ": " & ASCII.LF & + Exception_Message (Except) & ASCII.NUL; + + Message_Length : Error_Message_Size_Type; + +begin + New_Line; + Put_Line ("In last chance handler"); + Put_Line (Message (1 .. Message'Length - 1)); + New_Line; + + Put_Line ("adainit and traceback addresses for vxaddr2line:"); + + Put (Image_C (Adainit_Addr)); Put (" "); + + for J in 1 .. Except.Num_Tracebacks loop + Put (Image_C (Except.Tracebacks (J))); + Put (" "); + end loop; + + New_Line; + + if Message'Length > Error_Message_Size_Type'Last then + Message_Length := Error_Message_Size_Type'Last; + else + Message_Length := Message'Length; + end if; + + Raise_Application_Error + (Error_Code => Application_Error, + Message_Addr => Message_Addr_Type (Message (1)'Address), + Length => Message_Length, + Return_Code => Result); + + -- Shutdown the run-time library now. The rest of the procedure needs to be + -- careful not to use anything that would require runtime support. In + -- particular, functions returning strings are banned since the sec stack + -- is no longer functional. + + System.Standard_Library.Adafinal; + Unhandled_Terminate; +end Ada.Exceptions.Last_Chance_Handler; diff --git a/gcc/ada/libgnat/a-elchha.adb b/gcc/ada/libgnat/a-elchha.adb new file mode 100644 index 0000000..8839e8f --- /dev/null +++ b/gcc/ada/libgnat/a-elchha.adb @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Default version for most targets + +pragma Compiler_Unit_Warning; + +with System.Standard_Library; use System.Standard_Library; +with System.Soft_Links; + +procedure Ada.Exceptions.Last_Chance_Handler + (Except : Exception_Occurrence) +is + procedure Unhandled_Terminate; + pragma No_Return (Unhandled_Terminate); + pragma Import (C, Unhandled_Terminate, "__gnat_unhandled_terminate"); + -- Perform system dependent shutdown code + + function Exception_Message_Length + (X : Exception_Occurrence) return Natural; + pragma Import (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); + + procedure Append_Info_Exception_Message + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + pragma Import + (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); + + procedure Append_Info_Untailored_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + pragma Import + (Ada, Append_Info_Untailored_Exception_Information, + "__gnat_append_info_u_e_info"); + + procedure To_Stderr (S : String); + pragma Import (Ada, To_Stderr, "__gnat_to_stderr"); + -- Little routine to output string to stderr + + Ptr : Natural := 0; + Nobuf : String (1 .. 0); + + Nline : constant String := String'(1 => ASCII.LF); + -- Convenient shortcut + +begin + -- Do not execute any task termination code when shutting down the system. + -- The Adafinal procedure would execute the task termination routine for + -- normal termination, but we have already executed the task termination + -- procedure because of an unhandled exception. + + System.Soft_Links.Task_Termination_Handler := + System.Soft_Links.Task_Termination_NT'Access; + + -- We shutdown the runtime now. The rest of the procedure needs to be + -- careful not to use anything that would require runtime support. In + -- particular, functions returning strings are banned since the sec stack + -- is no longer functional. This is particularly important to note for the + -- Exception_Information output. We used to allow the tailored version to + -- show up here, which turned out to be a bad idea as it might involve a + -- traceback decorator the length of which we don't control. Potentially + -- heavy primary/secondary stack use or dynamic allocations right before + -- this point are not welcome, moving the output before the finalization + -- raises order of outputs concerns, and decorators are intended to only + -- be used with exception traces, which should have been issued already. + + System.Standard_Library.Adafinal; + + -- Print a message only when exception traces are not active + + if Exception_Trace /= RM_Convention then + null; + + -- Check for special case of raising _ABORT_SIGNAL, which is not + -- really an exception at all. We recognize this by the fact that + -- it is the only exception whose name starts with underscore. + + elsif To_Ptr (Except.Id.Full_Name) (1) = '_' then + To_Stderr (Nline); + To_Stderr ("Execution terminated by abort of environment task"); + To_Stderr (Nline); + + -- If no tracebacks, we print the unhandled exception in the old style + -- (i.e. the style used before ZCX was implemented). We do this to + -- retain compatibility. + + elsif Except.Num_Tracebacks = 0 then + To_Stderr (Nline); + To_Stderr ("raised "); + To_Stderr + (To_Ptr (Except.Id.Full_Name) (1 .. Except.Id.Name_Length - 1)); + + if Exception_Message_Length (Except) /= 0 then + To_Stderr (" : "); + Append_Info_Exception_Message (Except, Nobuf, Ptr); + end if; + + To_Stderr (Nline); + + -- Traceback exists + + else + To_Stderr (Nline); + To_Stderr ("Execution terminated by unhandled exception"); + To_Stderr (Nline); + + Append_Info_Untailored_Exception_Information (Except, Nobuf, Ptr); + end if; + + Unhandled_Terminate; +end Ada.Exceptions.Last_Chance_Handler; diff --git a/gcc/ada/libgnat/a-elchha.ads b/gcc/ada/libgnat/a-elchha.ads new file mode 100644 index 0000000..0cdcb99 --- /dev/null +++ b/gcc/ada/libgnat/a-elchha.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . L A S T _ C H A N C E _ H A N D L E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Last chance handler. Unhandled exceptions are passed to this routine + +pragma Compiler_Unit_Warning; + +procedure Ada.Exceptions.Last_Chance_Handler + (Except : Exception_Occurrence); +pragma Export (C, + Last_Chance_Handler, + "__gnat_last_chance_handler"); +pragma No_Return (Last_Chance_Handler); diff --git a/gcc/ada/libgnat/a-envvar.adb b/gcc/ada/libgnat/a-envvar.adb new file mode 100644 index 0000000..c414174 --- /dev/null +++ b/gcc/ada/libgnat/a-envvar.adb @@ -0,0 +1,228 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E N V I R O N M E N T _ V A R I A B L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.CRTL; +with Interfaces.C.Strings; +with Ada.Unchecked_Deallocation; + +package body Ada.Environment_Variables is + + ----------- + -- Clear -- + ----------- + + procedure Clear (Name : String) is + procedure Clear_Env_Var (Name : System.Address); + pragma Import (C, Clear_Env_Var, "__gnat_unsetenv"); + + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + Clear_Env_Var (F_Name'Address); + end Clear; + + ----------- + -- Clear -- + ----------- + + procedure Clear is + procedure Clear_Env; + pragma Import (C, Clear_Env, "__gnat_clearenv"); + begin + Clear_Env; + end Clear; + + ------------ + -- Exists -- + ------------ + + function Exists (Name : String) return Boolean is + use System; + + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + Env_Value_Ptr : aliased Address; + Env_Value_Length : aliased Integer; + F_Name : aliased String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + Get_Env_Value_Ptr + (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + if Env_Value_Ptr = System.Null_Address then + return False; + end if; + + return True; + end Exists; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate + (Process : not null access procedure (Name, Value : String)) + is + use Interfaces.C.Strings; + type C_String_Array is array (Natural) of aliased chars_ptr; + type C_String_Array_Access is access C_String_Array; + + function Get_Env return C_String_Array_Access; + pragma Import (C, Get_Env, "__gnat_environ"); + + type String_Access is access all String; + procedure Free is new Ada.Unchecked_Deallocation (String, String_Access); + + Env_Length : Natural := 0; + Env : constant C_String_Array_Access := Get_Env; + + begin + -- If the environment is null return directly + + if Env = null then + return; + end if; + + -- First get the number of environment variables + + loop + exit when Env (Env_Length) = Null_Ptr; + Env_Length := Env_Length + 1; + end loop; + + declare + Env_Copy : array (1 .. Env_Length) of String_Access; + + begin + -- Copy the environment + + for Iterator in 1 .. Env_Length loop + Env_Copy (Iterator) := new String'(Value (Env (Iterator - 1))); + end loop; + + -- Iterate on the environment copy + + for Iterator in 1 .. Env_Length loop + declare + Current_Var : constant String := Env_Copy (Iterator).all; + Value_Index : Natural := Env_Copy (Iterator)'First; + + begin + loop + exit when Current_Var (Value_Index) = '='; + Value_Index := Value_Index + 1; + end loop; + + Process + (Current_Var (Current_Var'First .. Value_Index - 1), + Current_Var (Value_Index + 1 .. Current_Var'Last)); + end; + end loop; + + -- Free the copy of the environment + + for Iterator in 1 .. Env_Length loop + Free (Env_Copy (Iterator)); + end loop; + end; + end Iterate; + + --------- + -- Set -- + --------- + + procedure Set (Name : String; Value : String) is + F_Name : String (1 .. Name'Length + 1); + F_Value : String (1 .. Value'Length + 1); + + procedure Set_Env_Value (Name, Value : System.Address); + pragma Import (C, Set_Env_Value, "__gnat_setenv"); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + F_Value (1 .. Value'Length) := Value; + F_Value (F_Value'Last) := ASCII.NUL; + + Set_Env_Value (F_Name'Address, F_Value'Address); + end Set; + + ----------- + -- Value -- + ----------- + + function Value (Name : String) return String is + use System, System.CRTL; + + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + Env_Value_Ptr : aliased Address; + Env_Value_Length : aliased Integer; + F_Name : aliased String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + Get_Env_Value_Ptr + (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + if Env_Value_Ptr = System.Null_Address then + raise Constraint_Error; + end if; + + if Env_Value_Length > 0 then + declare + Result : aliased String (1 .. Env_Value_Length); + begin + strncpy (Result'Address, Env_Value_Ptr, size_t (Env_Value_Length)); + return Result; + end; + else + return ""; + end if; + end Value; + + function Value (Name : String; Default : String) return String is + begin + return (if Exists (Name) then Value (Name) else Default); + end Value; + +end Ada.Environment_Variables; diff --git a/gcc/ada/libgnat/a-envvar.ads b/gcc/ada/libgnat/a-envvar.ads new file mode 100644 index 0000000..406aee3 --- /dev/null +++ b/gcc/ada/libgnat/a-envvar.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E N V I R O N M E N T _ V A R I A B L E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation of this package is as defined in the Ada 2012 RM, but +-- it is available in Ada 95 and Ada 2005 modes as well. + +package Ada.Environment_Variables is + pragma Preelaborate (Environment_Variables); + + function Value (Name : String) return String; + -- If the external execution environment supports environment variables, + -- then Value returns the value of the environment variable with the given + -- name. If no environment variable with the given name exists, then + -- Constraint_Error is propagated. If the execution environment does not + -- support environment variables, then Program_Error is propagated. + + function Value (Name : String; Default : String) return String; + -- If the external execution environment supports environment variables and + -- an environment variable with the given name currently exists, then Value + -- returns its value; otherwise, it returns Default. + + function Exists (Name : String) return Boolean; + -- If the external execution environment supports environment variables and + -- an environment variable with the given name currently exists, then + -- Exists returns True; otherwise it returns False. + + procedure Set (Name : String; Value : String); + -- If the external execution environment supports environment variables, + -- then Set first clears any existing environment variable with the given + -- name, and then defines a single new environment variable with the given + -- name and value. Otherwise Program_Error is propagated. + -- + -- If implementation-defined circumstances prohibit the definition of an + -- environment variable with the given name and value, then exception + -- Constraint_Error is propagated. + -- + -- It is implementation defined whether there exist values for which the + -- call Set (Name, Value) has the same effect as Clear (Name). + + procedure Clear (Name : String); + -- If the external execution environment supports environment variables, + -- then Clear deletes all existing environment variables with the given + -- name. Otherwise Program_Error is propagated. + + procedure Clear; + -- If the external execution environment supports environment variables, + -- then Clear deletes all existing environment variables. Otherwise + -- Program_Error is propagated. + + procedure Iterate + (Process : not null access procedure (Name, Value : String)); + -- If the external execution environment supports environment variables, + -- then Iterate calls the subprogram designated by Process for each + -- existing environment variable, passing the name and value of that + -- environment variable. Otherwise Program_Error is propagated. + +end Ada.Environment_Variables; diff --git a/gcc/ada/libgnat/a-excach.adb b/gcc/ada/libgnat/a-excach.adb new file mode 100644 index 0000000..5cba070 --- /dev/null +++ b/gcc/ada/libgnat/a-excach.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . C A L L _ C H A I N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +-- Allow withing of non-Preelaborated units in Ada 2005 mode where this +-- package will be categorized as Preelaborate. See AI-362 for details. +-- It is safe in the context of the run-time to violate the rules. + +with System.Traceback; + +pragma Warnings (On); + +separate (Ada.Exceptions) +procedure Call_Chain (Excep : EOA) is + + Exception_Tracebacks : Integer; + pragma Import (C, Exception_Tracebacks, "__gl_exception_tracebacks"); + -- Boolean indicating whether tracebacks should be stored in exception + -- occurrences. + +begin + if Exception_Tracebacks /= 0 and Excep.Num_Tracebacks = 0 then + + -- If Exception_Tracebacks = 0 then the program was not + -- compiled for storing tracebacks in exception occurrences + -- (-bargs -E switch) so that we do not generate them. + -- + -- If Excep.Num_Tracebacks /= 0 then this is a reraise, no need + -- to store a new (wrong) chain. + + -- We ask System.Traceback.Call_Chain to skip 3 frames to ensure that + -- itself, ourselves and our caller are not part of the result. Our + -- caller is always an exception propagation actor that we don't want + -- to see, and it may be part of a separate subunit which pulls it + -- outside the AAA/ZZZ range. + + System.Traceback.Call_Chain + (Traceback => Excep.Tracebacks, + Max_Len => Max_Tracebacks, + Len => Excep.Num_Tracebacks, + Exclude_Min => Code_Address_For_AAA, + Exclude_Max => Code_Address_For_ZZZ, + Skip_Frames => 3); + end if; + +end Call_Chain; diff --git a/gcc/ada/libgnat/a-except.adb b/gcc/ada/libgnat/a-except.adb new file mode 100644 index 0000000..1b8e625 --- /dev/null +++ b/gcc/ada/libgnat/a-except.adb @@ -0,0 +1,1748 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- No subprogram ordering check, due to logical grouping + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +with System; use System; +with System.Exceptions; use System.Exceptions; +with System.Exceptions_Debug; use System.Exceptions_Debug; +with System.Standard_Library; use System.Standard_Library; +with System.Soft_Links; use System.Soft_Links; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; + +pragma Warnings (Off); +-- Suppress complaints about Symbolic not being referenced, and about it not +-- having pragma Preelaborate. +with System.Traceback.Symbolic; +-- Bring Symbolic into the closure. If it is the s-trasym-dwarf.adb version, +-- it will install symbolic tracebacks as the default decorator. Otherwise, +-- symbolic tracebacks are not supported, and we fall back to hexadecimal +-- addresses. +pragma Warnings (On); + +package body Ada.Exceptions is + + pragma Suppress (All_Checks); + -- We definitely do not want exceptions occurring within this unit, or + -- we are in big trouble. If an exceptional situation does occur, better + -- that it not be raised, since raising it can cause confusing chaos. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- Note: the exported subprograms in this package body are called directly + -- from C clients using the given external name, even though they are not + -- technically visible in the Ada sense. + + function Code_Address_For_AAA return System.Address; + function Code_Address_For_ZZZ return System.Address; + -- Return start and end of procedures in this package + -- + -- These procedures are used to provide exclusion bounds in + -- calls to Call_Chain at exception raise points from this unit. The + -- purpose is to arrange for the exception tracebacks not to include + -- frames from subprograms involved in the raise process, as these are + -- meaningless from the user's standpoint. + -- + -- For these bounds to be meaningful, we need to ensure that the object + -- code for the subprograms involved in processing a raise is located + -- after the object code Code_Address_For_AAA and before the object + -- code Code_Address_For_ZZZ. This will indeed be the case as long as + -- the following rules are respected: + -- + -- 1) The bodies of the subprograms involved in processing a raise + -- are located after the body of Code_Address_For_AAA and before the + -- body of Code_Address_For_ZZZ. + -- + -- 2) No pragma Inline applies to any of these subprograms, as this + -- could delay the corresponding assembly output until the end of + -- the unit. + + procedure Call_Chain (Excep : EOA); + -- Store up to Max_Tracebacks in Excep, corresponding to the current + -- call chain. + + function Image (Index : Integer) return String; + -- Return string image corresponding to Index + + procedure To_Stderr (S : String); + pragma Export (Ada, To_Stderr, "__gnat_to_stderr"); + -- Little routine to output string to stderr that is also used + -- in the tasking run time. + + procedure To_Stderr (C : Character); + pragma Inline (To_Stderr); + pragma Export (Ada, To_Stderr, "__gnat_to_stderr_char"); + -- Little routine to output a character to stderr, used by some of + -- the separate units below. + + package Exception_Data is + + ----------------------------------- + -- Exception Message Subprograms -- + ----------------------------------- + + procedure Set_Exception_C_Msg + (Excep : EOA; + Id : Exception_Id; + Msg1 : System.Address; + Line : Integer := 0; + Column : Integer := 0; + Msg2 : System.Address := System.Null_Address); + -- This routine is called to setup the exception referenced by X + -- to contain the indicated Id value and message. Msg1 is a null + -- terminated string which is generated as the exception message. If + -- line is non-zero, then a colon and the decimal representation of + -- this integer is appended to the message. Ditto for Column. When Msg2 + -- is non-null, a space and this additional null terminated string is + -- added to the message. + + procedure Set_Exception_Msg + (Excep : EOA; + Id : Exception_Id; + Message : String); + -- This routine is called to setup the exception referenced by X + -- to contain the indicated Id value and message. Message is a string + -- which is generated as the exception message. + + --------------------------------------- + -- Exception Information Subprograms -- + --------------------------------------- + + function Untailored_Exception_Information + (X : Exception_Occurrence) return String; + -- This is used by Stream_Attributes.EO_To_String to convert an + -- Exception_Occurrence to a String for the stream attributes. + -- String_To_EO understands the format, as documented here. + -- + -- The format of the string is as follows: + -- + -- raised : + -- (" : " is present only if Exception_Message is not empty) + -- PID=nnnn (only if nonzero) + -- Call stack traceback locations: (only if at least one location) + -- <0xyyyyyyyy 0xyyyyyyyy ...> (is recorded) + -- + -- The lines are separated by a ASCII.LF character. + -- The nnnn is the partition Id given as decimal digits. + -- The 0x... line represents traceback program counter locations, in + -- execution order with the first one being the exception location. + -- + -- The Exception_Name and Message lines are omitted in the abort + -- signal case, since this is not really an exception. + -- + -- Note: If the format of the generated string is changed, please note + -- that an equivalent modification to the routine String_To_EO must be + -- made to preserve proper functioning of the stream attributes. + + function Exception_Information (X : Exception_Occurrence) return String; + -- This is the implementation of Ada.Exceptions.Exception_Information, + -- as defined in the Ada RM. + -- + -- If no traceback decorator (see GNAT.Exception_Traces) is currently + -- in place, this is the same as Untailored_Exception_Information. + -- Otherwise, the decorator is used to produce a symbolic traceback + -- instead of hexadecimal addresses. + -- + -- Note that unlike Untailored_Exception_Information, there is no need + -- to keep the output of Exception_Information stable for streaming + -- purposes, and in fact the output differs across platforms. + + end Exception_Data; + + package Exception_Traces is + + ------------------------------------------------- + -- Run-Time Exception Notification Subprograms -- + ------------------------------------------------- + + -- These subprograms provide a common run-time interface to trigger the + -- actions required when an exception is about to be propagated (e.g. + -- user specified actions or output of exception information). They are + -- exported to be usable by the Ada exception handling personality + -- routine when the GCC 3 mechanism is used. + + procedure Notify_Handled_Exception (Excep : EOA); + pragma Export + (C, Notify_Handled_Exception, "__gnat_notify_handled_exception"); + -- This routine is called for a handled occurrence is about to be + -- propagated. + + procedure Notify_Unhandled_Exception (Excep : EOA); + pragma Export + (C, Notify_Unhandled_Exception, "__gnat_notify_unhandled_exception"); + -- This routine is called when an unhandled occurrence is about to be + -- propagated. + + procedure Unhandled_Exception_Terminate (Excep : EOA); + pragma No_Return (Unhandled_Exception_Terminate); + -- This procedure is called to terminate execution following an + -- unhandled exception. The exception information, including + -- traceback if available is output, and execution is then + -- terminated. Note that at the point where this routine is + -- called, the stack has typically been destroyed. + + end Exception_Traces; + + package Exception_Propagation is + + --------------------------------------- + -- Exception Propagation Subprograms -- + --------------------------------------- + + function Allocate_Occurrence return EOA; + -- Allocate an exception occurrence (as well as the machine occurrence) + + procedure Propagate_Exception (Excep : EOA); + pragma No_Return (Propagate_Exception); + -- This procedure propagates the exception represented by Excep + + end Exception_Propagation; + + package Stream_Attributes is + + ---------------------------------- + -- Stream Attribute Subprograms -- + ---------------------------------- + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + -- Functions for implementing Exception_Id stream attributes + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + -- Functions for implementing Exception_Occurrence stream + -- attributes + + end Stream_Attributes; + + procedure Complete_Occurrence (X : EOA); + -- Finish building the occurrence: save the call chain and notify the + -- debugger. + + procedure Complete_And_Propagate_Occurrence (X : EOA); + pragma No_Return (Complete_And_Propagate_Occurrence); + -- This is a simple wrapper to Complete_Occurrence and + -- Exception_Propagation.Propagate_Exception. + + function Create_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return EOA; + -- Create and build an exception occurrence using exception id E and + -- nul-terminated message M. + + function Create_Machine_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return System.Address; + pragma Export (C, Create_Machine_Occurrence_From_Signal_Handler, + "__gnat_create_machine_occurrence_from_signal_handler"); + -- Create and build an exception occurrence using exception id E and + -- nul-terminated message M. Return the machine occurrence. + + procedure Raise_Exception_No_Defer + (E : Exception_Id; + Message : String := ""); + pragma Export + (Ada, Raise_Exception_No_Defer, + "ada__exceptions__raise_exception_no_defer"); + pragma No_Return (Raise_Exception_No_Defer); + -- Similar to Raise_Exception, but with no abort deferral + + procedure Raise_With_Msg (E : Exception_Id); + pragma No_Return (Raise_With_Msg); + pragma Export (C, Raise_With_Msg, "__gnat_raise_with_msg"); + -- Raises an exception with given exception id value. A message + -- is associated with the raise, and has already been stored in the + -- exception occurrence referenced by the Current_Excep in the TSD. + -- Abort is deferred before the raise call. + + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : System.Address; + L : Integer; + C : Integer := 0; + M : System.Address := System.Null_Address); + pragma No_Return (Raise_With_Location_And_Msg); + -- Raise an exception with given exception id value. A filename and line + -- number is associated with the raise and is stored in the exception + -- occurrence and in addition a column and a string message M may be + -- appended to this (if not null/0). + + procedure Raise_Constraint_Error (File : System.Address; Line : Integer); + pragma No_Return (Raise_Constraint_Error); + pragma Export (C, Raise_Constraint_Error, "__gnat_raise_constraint_error"); + -- Raise constraint error with file:line information + + procedure Raise_Constraint_Error_Msg + (File : System.Address; + Line : Integer; + Column : Integer; + Msg : System.Address); + pragma No_Return (Raise_Constraint_Error_Msg); + pragma Export + (C, Raise_Constraint_Error_Msg, "__gnat_raise_constraint_error_msg"); + -- Raise constraint error with file:line:col + msg information + + procedure Raise_Program_Error (File : System.Address; Line : Integer); + pragma No_Return (Raise_Program_Error); + pragma Export (C, Raise_Program_Error, "__gnat_raise_program_error"); + -- Raise program error with file:line information + + procedure Raise_Program_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address); + pragma No_Return (Raise_Program_Error_Msg); + pragma Export + (C, Raise_Program_Error_Msg, "__gnat_raise_program_error_msg"); + -- Raise program error with file:line + msg information + + procedure Raise_Storage_Error (File : System.Address; Line : Integer); + pragma No_Return (Raise_Storage_Error); + pragma Export (C, Raise_Storage_Error, "__gnat_raise_storage_error"); + -- Raise storage error with file:line information + + procedure Raise_Storage_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address); + pragma No_Return (Raise_Storage_Error_Msg); + pragma Export + (C, Raise_Storage_Error_Msg, "__gnat_raise_storage_error_msg"); + -- Raise storage error with file:line + reason msg information + + -- The exception raising process and the automatic tracing mechanism rely + -- on some careful use of flags attached to the exception occurrence. The + -- graph below illustrates the relations between the Raise_ subprograms + -- and identifies the points where basic flags such as Exception_Raised + -- are initialized. + + -- (i) signs indicate the flags initialization points. R stands for Raise, + -- W for With, and E for Exception. + + -- R_No_Msg R_E R_Pe R_Ce R_Se + -- | | | | | + -- +--+ +--+ +---+ | +---+ + -- | | | | | + -- R_E_No_Defer(i) R_W_Msg(i) R_W_Loc + -- | | | | + -- +------------+ | +-----------+ +--+ + -- | | | | + -- | | | Set_E_C_Msg(i) + -- | | | + -- Complete_And_Propagate_Occurrence + + procedure Reraise; + pragma No_Return (Reraise); + pragma Export (C, Reraise, "__gnat_reraise"); + -- Reraises the exception referenced by the Current_Excep field + -- of the TSD (all fields of this exception occurrence are set). + -- Abort is deferred before the reraise operation. Called from + -- System.Tasking.RendezVous.Exceptional_Complete_RendezVous + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence); + pragma Export (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); + -- Called from s-tasren.adb:Local_Complete_RendezVous and + -- s-tpobop.adb:Exceptional_Complete_Entry_Body to setup Target from + -- Source as an exception to be propagated in the caller task. Target is + -- expected to be a pointer to the fixed TSD occurrence for this task. + + -------------------------------- + -- Run-Time Check Subprograms -- + -------------------------------- + + -- These subprograms raise a specific exception with a reason message + -- attached. The parameters are the file name and line number in each + -- case. The names are defined by Exp_Ch11.Get_RT_Exception_Name. + + procedure Rcheck_CE_Access_Check + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Null_Access_Parameter + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Discriminant_Check + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Divide_By_Zero + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Explicit_Raise + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Index_Check + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Invalid_Data + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Length_Check + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Null_Exception_Id + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Null_Not_Allowed + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Overflow_Check + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Partition_Check + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Range_Check + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Tag_Check + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Access_Before_Elaboration + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Accessibility_Check + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Address_Of_Intrinsic + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Aliased_Parameters + (File : System.Address; Line : Integer); + procedure Rcheck_PE_All_Guards_Closed + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Bad_Predicated_Generic_Type + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Current_Task_In_Entry_Body + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Duplicated_Entry_Address + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Explicit_Raise + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Implicit_Return + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Misaligned_Address_Value + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Missing_Return + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Non_Transportable_Actual + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Overlaid_Controlled_Object + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Potentially_Blocking_Operation + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Stubbed_Subprogram_Called + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Unchecked_Union_Restriction + (File : System.Address; Line : Integer); + procedure Rcheck_SE_Empty_Storage_Pool + (File : System.Address; Line : Integer); + procedure Rcheck_SE_Explicit_Raise + (File : System.Address; Line : Integer); + procedure Rcheck_SE_Infinite_Recursion + (File : System.Address; Line : Integer); + procedure Rcheck_SE_Object_Too_Large + (File : System.Address; Line : Integer); + procedure Rcheck_PE_Stream_Operation_Not_Allowed + (File : System.Address; Line : Integer); + procedure Rcheck_CE_Access_Check_Ext + (File : System.Address; Line, Column : Integer); + procedure Rcheck_CE_Index_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + procedure Rcheck_CE_Invalid_Data_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + procedure Rcheck_CE_Range_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer); + + procedure Rcheck_PE_Finalize_Raised_Exception + (File : System.Address; Line : Integer); + -- This routine is separated out because it has quite different behavior + -- from the others. This is the "finalize/adjust raised exception". This + -- subprogram is always called with abort deferred, unlike all other + -- Rcheck_* subprograms, it needs to call Raise_Exception_No_Defer. + + pragma Export (C, Rcheck_CE_Access_Check, + "__gnat_rcheck_CE_Access_Check"); + pragma Export (C, Rcheck_CE_Null_Access_Parameter, + "__gnat_rcheck_CE_Null_Access_Parameter"); + pragma Export (C, Rcheck_CE_Discriminant_Check, + "__gnat_rcheck_CE_Discriminant_Check"); + pragma Export (C, Rcheck_CE_Divide_By_Zero, + "__gnat_rcheck_CE_Divide_By_Zero"); + pragma Export (C, Rcheck_CE_Explicit_Raise, + "__gnat_rcheck_CE_Explicit_Raise"); + pragma Export (C, Rcheck_CE_Index_Check, + "__gnat_rcheck_CE_Index_Check"); + pragma Export (C, Rcheck_CE_Invalid_Data, + "__gnat_rcheck_CE_Invalid_Data"); + pragma Export (C, Rcheck_CE_Length_Check, + "__gnat_rcheck_CE_Length_Check"); + pragma Export (C, Rcheck_CE_Null_Exception_Id, + "__gnat_rcheck_CE_Null_Exception_Id"); + pragma Export (C, Rcheck_CE_Null_Not_Allowed, + "__gnat_rcheck_CE_Null_Not_Allowed"); + pragma Export (C, Rcheck_CE_Overflow_Check, + "__gnat_rcheck_CE_Overflow_Check"); + pragma Export (C, Rcheck_CE_Partition_Check, + "__gnat_rcheck_CE_Partition_Check"); + pragma Export (C, Rcheck_CE_Range_Check, + "__gnat_rcheck_CE_Range_Check"); + pragma Export (C, Rcheck_CE_Tag_Check, + "__gnat_rcheck_CE_Tag_Check"); + pragma Export (C, Rcheck_PE_Access_Before_Elaboration, + "__gnat_rcheck_PE_Access_Before_Elaboration"); + pragma Export (C, Rcheck_PE_Accessibility_Check, + "__gnat_rcheck_PE_Accessibility_Check"); + pragma Export (C, Rcheck_PE_Address_Of_Intrinsic, + "__gnat_rcheck_PE_Address_Of_Intrinsic"); + pragma Export (C, Rcheck_PE_Aliased_Parameters, + "__gnat_rcheck_PE_Aliased_Parameters"); + pragma Export (C, Rcheck_PE_All_Guards_Closed, + "__gnat_rcheck_PE_All_Guards_Closed"); + pragma Export (C, Rcheck_PE_Bad_Predicated_Generic_Type, + "__gnat_rcheck_PE_Bad_Predicated_Generic_Type"); + pragma Export (C, Rcheck_PE_Current_Task_In_Entry_Body, + "__gnat_rcheck_PE_Current_Task_In_Entry_Body"); + pragma Export (C, Rcheck_PE_Duplicated_Entry_Address, + "__gnat_rcheck_PE_Duplicated_Entry_Address"); + pragma Export (C, Rcheck_PE_Explicit_Raise, + "__gnat_rcheck_PE_Explicit_Raise"); + pragma Export (C, Rcheck_PE_Finalize_Raised_Exception, + "__gnat_rcheck_PE_Finalize_Raised_Exception"); + pragma Export (C, Rcheck_PE_Implicit_Return, + "__gnat_rcheck_PE_Implicit_Return"); + pragma Export (C, Rcheck_PE_Misaligned_Address_Value, + "__gnat_rcheck_PE_Misaligned_Address_Value"); + pragma Export (C, Rcheck_PE_Missing_Return, + "__gnat_rcheck_PE_Missing_Return"); + pragma Export (C, Rcheck_PE_Non_Transportable_Actual, + "__gnat_rcheck_PE_Non_Transportable_Actual"); + pragma Export (C, Rcheck_PE_Overlaid_Controlled_Object, + "__gnat_rcheck_PE_Overlaid_Controlled_Object"); + pragma Export (C, Rcheck_PE_Potentially_Blocking_Operation, + "__gnat_rcheck_PE_Potentially_Blocking_Operation"); + pragma Export (C, Rcheck_PE_Stream_Operation_Not_Allowed, + "__gnat_rcheck_PE_Stream_Operation_Not_Allowed"); + pragma Export (C, Rcheck_PE_Stubbed_Subprogram_Called, + "__gnat_rcheck_PE_Stubbed_Subprogram_Called"); + pragma Export (C, Rcheck_PE_Unchecked_Union_Restriction, + "__gnat_rcheck_PE_Unchecked_Union_Restriction"); + pragma Export (C, Rcheck_SE_Empty_Storage_Pool, + "__gnat_rcheck_SE_Empty_Storage_Pool"); + pragma Export (C, Rcheck_SE_Explicit_Raise, + "__gnat_rcheck_SE_Explicit_Raise"); + pragma Export (C, Rcheck_SE_Infinite_Recursion, + "__gnat_rcheck_SE_Infinite_Recursion"); + pragma Export (C, Rcheck_SE_Object_Too_Large, + "__gnat_rcheck_SE_Object_Too_Large"); + + pragma Export (C, Rcheck_CE_Access_Check_Ext, + "__gnat_rcheck_CE_Access_Check_ext"); + pragma Export (C, Rcheck_CE_Index_Check_Ext, + "__gnat_rcheck_CE_Index_Check_ext"); + pragma Export (C, Rcheck_CE_Invalid_Data_Ext, + "__gnat_rcheck_CE_Invalid_Data_ext"); + pragma Export (C, Rcheck_CE_Range_Check_Ext, + "__gnat_rcheck_CE_Range_Check_ext"); + + -- None of these procedures ever returns (they raise an exception). By + -- using pragma No_Return, we ensure that any junk code after the call, + -- such as normal return epilogue stuff, can be eliminated). + + pragma No_Return (Rcheck_CE_Access_Check); + pragma No_Return (Rcheck_CE_Null_Access_Parameter); + pragma No_Return (Rcheck_CE_Discriminant_Check); + pragma No_Return (Rcheck_CE_Divide_By_Zero); + pragma No_Return (Rcheck_CE_Explicit_Raise); + pragma No_Return (Rcheck_CE_Index_Check); + pragma No_Return (Rcheck_CE_Invalid_Data); + pragma No_Return (Rcheck_CE_Length_Check); + pragma No_Return (Rcheck_CE_Null_Exception_Id); + pragma No_Return (Rcheck_CE_Null_Not_Allowed); + pragma No_Return (Rcheck_CE_Overflow_Check); + pragma No_Return (Rcheck_CE_Partition_Check); + pragma No_Return (Rcheck_CE_Range_Check); + pragma No_Return (Rcheck_CE_Tag_Check); + pragma No_Return (Rcheck_PE_Access_Before_Elaboration); + pragma No_Return (Rcheck_PE_Accessibility_Check); + pragma No_Return (Rcheck_PE_Address_Of_Intrinsic); + pragma No_Return (Rcheck_PE_Aliased_Parameters); + pragma No_Return (Rcheck_PE_All_Guards_Closed); + pragma No_Return (Rcheck_PE_Bad_Predicated_Generic_Type); + pragma No_Return (Rcheck_PE_Current_Task_In_Entry_Body); + pragma No_Return (Rcheck_PE_Duplicated_Entry_Address); + pragma No_Return (Rcheck_PE_Explicit_Raise); + pragma No_Return (Rcheck_PE_Implicit_Return); + pragma No_Return (Rcheck_PE_Misaligned_Address_Value); + pragma No_Return (Rcheck_PE_Missing_Return); + pragma No_Return (Rcheck_PE_Non_Transportable_Actual); + pragma No_Return (Rcheck_PE_Overlaid_Controlled_Object); + pragma No_Return (Rcheck_PE_Potentially_Blocking_Operation); + pragma No_Return (Rcheck_PE_Stream_Operation_Not_Allowed); + pragma No_Return (Rcheck_PE_Stubbed_Subprogram_Called); + pragma No_Return (Rcheck_PE_Unchecked_Union_Restriction); + pragma No_Return (Rcheck_PE_Finalize_Raised_Exception); + pragma No_Return (Rcheck_SE_Empty_Storage_Pool); + pragma No_Return (Rcheck_SE_Explicit_Raise); + pragma No_Return (Rcheck_SE_Infinite_Recursion); + pragma No_Return (Rcheck_SE_Object_Too_Large); + + pragma No_Return (Rcheck_CE_Access_Check_Ext); + pragma No_Return (Rcheck_CE_Index_Check_Ext); + pragma No_Return (Rcheck_CE_Invalid_Data_Ext); + pragma No_Return (Rcheck_CE_Range_Check_Ext); + + --------------------------------------------- + -- Reason Strings for Run-Time Check Calls -- + --------------------------------------------- + + -- These strings are null-terminated and are used by Rcheck_nn. The + -- strings correspond to the definitions for Types.RT_Exception_Code. + + use ASCII; + + Rmsg_00 : constant String := "access check failed" & NUL; + Rmsg_01 : constant String := "access parameter is null" & NUL; + Rmsg_02 : constant String := "discriminant check failed" & NUL; + Rmsg_03 : constant String := "divide by zero" & NUL; + Rmsg_04 : constant String := "explicit raise" & NUL; + Rmsg_05 : constant String := "index check failed" & NUL; + Rmsg_06 : constant String := "invalid data" & NUL; + Rmsg_07 : constant String := "length check failed" & NUL; + Rmsg_08 : constant String := "null Exception_Id" & NUL; + Rmsg_09 : constant String := "null-exclusion check failed" & NUL; + Rmsg_10 : constant String := "overflow check failed" & NUL; + Rmsg_11 : constant String := "partition check failed" & NUL; + Rmsg_12 : constant String := "range check failed" & NUL; + Rmsg_13 : constant String := "tag check failed" & NUL; + Rmsg_14 : constant String := "access before elaboration" & NUL; + Rmsg_15 : constant String := "accessibility check failed" & NUL; + Rmsg_16 : constant String := "attempt to take address of" & + " intrinsic subprogram" & NUL; + Rmsg_17 : constant String := "aliased parameters" & NUL; + Rmsg_18 : constant String := "all guards closed" & NUL; + Rmsg_19 : constant String := "improper use of generic subtype" & + " with predicate" & NUL; + Rmsg_20 : constant String := "Current_Task referenced in entry" & + " body" & NUL; + Rmsg_21 : constant String := "duplicated entry address" & NUL; + Rmsg_22 : constant String := "explicit raise" & NUL; + Rmsg_23 : constant String := "finalize/adjust raised exception" & NUL; + Rmsg_24 : constant String := "implicit return with No_Return" & NUL; + Rmsg_25 : constant String := "misaligned address value" & NUL; + Rmsg_26 : constant String := "missing return" & NUL; + Rmsg_27 : constant String := "overlaid controlled object" & NUL; + Rmsg_28 : constant String := "potentially blocking operation" & NUL; + Rmsg_29 : constant String := "stubbed subprogram called" & NUL; + Rmsg_30 : constant String := "unchecked union restriction" & NUL; + Rmsg_31 : constant String := "actual/returned class-wide" & + " value not transportable" & NUL; + Rmsg_32 : constant String := "empty storage pool" & NUL; + Rmsg_33 : constant String := "explicit raise" & NUL; + Rmsg_34 : constant String := "infinite recursion" & NUL; + Rmsg_35 : constant String := "object too large" & NUL; + Rmsg_36 : constant String := "stream operation not allowed" & NUL; + + ----------------------- + -- Polling Interface -- + ----------------------- + + type Unsigned is mod 2 ** 32; + + Counter : Unsigned := 0; + pragma Warnings (Off, Counter); + -- This counter is provided for convenience. It can be used in Poll to + -- perform periodic but not systematic operations. + + procedure Poll is separate; + -- The actual polling routine is separate, so that it can easily be + -- replaced with a target dependent version. + + -------------------------- + -- Code_Address_For_AAA -- + -------------------------- + + -- This function gives us the start of the PC range for addresses within + -- the exception unit itself. We hope that gigi/gcc keep all the procedures + -- in their original order. + + function Code_Address_For_AAA return System.Address is + begin + -- We are using a label instead of Code_Address_For_AAA'Address because + -- on some platforms the latter does not yield the address we want, but + -- the address of a stub or of a descriptor instead. This is the case at + -- least on PA-HPUX. + + <> + return Start_Of_AAA'Address; + end Code_Address_For_AAA; + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain (Excep : EOA) is separate; + -- The actual Call_Chain routine is separate, so that it can easily + -- be dummied out when no exception traceback information is needed. + + ------------------- + -- EId_To_String -- + ------------------- + + function EId_To_String (X : Exception_Id) return String + renames Stream_Attributes.EId_To_String; + + ------------------ + -- EO_To_String -- + ------------------ + + -- We use the null string to represent the null occurrence, otherwise we + -- output the Untailored_Exception_Information string for the occurrence. + + function EO_To_String (X : Exception_Occurrence) return String + renames Stream_Attributes.EO_To_String; + + ------------------------ + -- Exception_Identity -- + ------------------------ + + function Exception_Identity + (X : Exception_Occurrence) return Exception_Id + is + begin + -- Note that the following test used to be here for the original + -- Ada 95 semantics, but these were modified by AI-241 to require + -- returning Null_Id instead of raising Constraint_Error. + + -- if X.Id = Null_Id then + -- raise Constraint_Error; + -- end if; + + return X.Id; + end Exception_Identity; + + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + raise Constraint_Error; + else + return Exception_Data.Exception_Information (X); + end if; + end Exception_Information; + + ----------------------- + -- Exception_Message -- + ----------------------- + + function Exception_Message (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + raise Constraint_Error; + else + return X.Msg (1 .. X.Msg_Length); + end if; + end Exception_Message; + + -------------------- + -- Exception_Name -- + -------------------- + + function Exception_Name (Id : Exception_Id) return String is + begin + if Id = null then + raise Constraint_Error; + else + return To_Ptr (Id.Full_Name) (1 .. Id.Name_Length - 1); + end if; + end Exception_Name; + + function Exception_Name (X : Exception_Occurrence) return String is + begin + return Exception_Name (X.Id); + end Exception_Name; + + --------------------------- + -- Exception_Name_Simple -- + --------------------------- + + function Exception_Name_Simple (X : Exception_Occurrence) return String is + Name : constant String := Exception_Name (X); + P : Natural; + + begin + P := Name'Length; + while P > 1 loop + exit when Name (P - 1) = '.'; + P := P - 1; + end loop; + + -- Return result making sure lower bound is 1 + + declare + subtype Rname is String (1 .. Name'Length - P + 1); + begin + return Rname (Name (P .. Name'Length)); + end; + end Exception_Name_Simple; + + -------------------- + -- Exception_Data -- + -------------------- + + package body Exception_Data is separate; + -- This package can be easily dummied out if we do not want the basic + -- support for exception messages (such as in Ada 83). + + --------------------------- + -- Exception_Propagation -- + --------------------------- + + package body Exception_Propagation is separate; + -- Depending on the actual exception mechanism used (front-end or + -- back-end based), the implementation will differ, which is why this + -- package is separated. + + ---------------------- + -- Exception_Traces -- + ---------------------- + + package body Exception_Traces is separate; + -- Depending on the underlying support for IO the implementation will + -- differ. Moreover we would like to dummy out this package in case we + -- do not want any exception tracing support. This is why this package + -- is separated. + + -------------------------------------- + -- Get_Exception_Machine_Occurrence -- + -------------------------------------- + + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address + is + begin + return X.Machine_Occurrence; + end Get_Exception_Machine_Occurrence; + + ----------- + -- Image -- + ----------- + + function Image (Index : Integer) return String is + Result : constant String := Integer'Image (Index); + begin + if Result (1) = ' ' then + return Result (2 .. Result'Last); + else + return Result; + end if; + end Image; + + ----------------------- + -- Stream Attributes -- + ----------------------- + + package body Stream_Attributes is separate; + -- This package can be easily dummied out if we do not want the + -- support for streaming Exception_Ids and Exception_Occurrences. + + ---------------------------- + -- Raise_Constraint_Error -- + ---------------------------- + + procedure Raise_Constraint_Error (File : System.Address; Line : Integer) is + begin + Raise_With_Location_And_Msg (Constraint_Error_Def'Access, File, Line); + end Raise_Constraint_Error; + + -------------------------------- + -- Raise_Constraint_Error_Msg -- + -------------------------------- + + procedure Raise_Constraint_Error_Msg + (File : System.Address; + Line : Integer; + Column : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Constraint_Error_Def'Access, File, Line, Column, Msg); + end Raise_Constraint_Error_Msg; + + ------------------------- + -- Complete_Occurrence -- + ------------------------- + + procedure Complete_Occurrence (X : EOA) is + begin + -- Compute the backtrace for this occurrence if the corresponding + -- binder option has been set. Call_Chain takes care of the reraise + -- case. + + -- ??? Using Call_Chain here means we are going to walk up the stack + -- once only for backtracing purposes before doing it again for the + -- propagation per se. + + -- The first inspection is much lighter, though, as it only requires + -- partial unwinding of each frame. Additionally, although we could use + -- the personality routine to record the addresses while propagating, + -- this method has two drawbacks: + + -- 1) the trace is incomplete if the exception is handled since we + -- don't walk past the frame with the handler, + + -- and + + -- 2) we would miss the frames for which our personality routine is not + -- called, e.g. if C or C++ calls are on the way. + + Call_Chain (X); + + -- Notify the debugger + Debug_Raise_Exception + (E => SSL.Exception_Data_Ptr (X.Id), + Message => X.Msg (1 .. X.Msg_Length)); + end Complete_Occurrence; + + --------------------------------------- + -- Complete_And_Propagate_Occurrence -- + --------------------------------------- + + procedure Complete_And_Propagate_Occurrence (X : EOA) is + begin + Complete_Occurrence (X); + Exception_Propagation.Propagate_Exception (X); + end Complete_And_Propagate_Occurrence; + + --------------------- + -- Raise_Exception -- + --------------------- + + procedure Raise_Exception + (E : Exception_Id; + Message : String := "") + is + EF : Exception_Id := E; + begin + -- Raise CE if E = Null_ID (AI-446) + + if E = null then + EF := Constraint_Error'Identity; + end if; + + -- Go ahead and raise appropriate exception + + Raise_Exception_Always (EF, Message); + end Raise_Exception; + + ---------------------------- + -- Raise_Exception_Always -- + ---------------------------- + + procedure Raise_Exception_Always + (E : Exception_Id; + Message : String := "") + is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + + begin + Exception_Data.Set_Exception_Msg (X, E, Message); + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_And_Propagate_Occurrence (X); + end Raise_Exception_Always; + + ------------------------------ + -- Raise_Exception_No_Defer -- + ------------------------------ + + procedure Raise_Exception_No_Defer + (E : Exception_Id; + Message : String := "") + is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + + begin + Exception_Data.Set_Exception_Msg (X, E, Message); + + -- Do not call Abort_Defer.all, as specified by the spec + + Complete_And_Propagate_Occurrence (X); + end Raise_Exception_No_Defer; + + ------------------------------------- + -- Raise_From_Controlled_Operation -- + ------------------------------------- + + procedure Raise_From_Controlled_Operation + (X : Ada.Exceptions.Exception_Occurrence) + is + Prefix : constant String := "adjust/finalize raised "; + Orig_Msg : constant String := Exception_Message (X); + Orig_Prefix_Length : constant Natural := + Integer'Min (Prefix'Length, Orig_Msg'Length); + + Orig_Prefix : String renames + Orig_Msg (Orig_Msg'First .. Orig_Msg'First + Orig_Prefix_Length - 1); + + begin + -- Message already has the proper prefix, just re-raise + + if Orig_Prefix = Prefix then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => Orig_Msg); + + else + declare + New_Msg : constant String := Prefix & Exception_Name (X); + + begin + -- No message present, just provide our own + + if Orig_Msg = "" then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg); + + -- Message present, add informational prefix + + else + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => New_Msg & ": " & Orig_Msg); + end if; + end; + end if; + end Raise_From_Controlled_Operation; + + ------------------------------------------- + -- Create_Occurrence_From_Signal_Handler -- + ------------------------------------------- + + function Create_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return EOA + is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + + begin + Exception_Data.Set_Exception_C_Msg (X, E, M); + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_Occurrence (X); + return X; + end Create_Occurrence_From_Signal_Handler; + + --------------------------------------------------- + -- Create_Machine_Occurrence_From_Signal_Handler -- + --------------------------------------------------- + + function Create_Machine_Occurrence_From_Signal_Handler + (E : Exception_Id; + M : System.Address) return System.Address + is + begin + return Create_Occurrence_From_Signal_Handler (E, M).Machine_Occurrence; + end Create_Machine_Occurrence_From_Signal_Handler; + + ------------------------------- + -- Raise_From_Signal_Handler -- + ------------------------------- + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : System.Address) + is + begin + Exception_Propagation.Propagate_Exception + (Create_Occurrence_From_Signal_Handler (E, M)); + end Raise_From_Signal_Handler; + + ------------------------- + -- Raise_Program_Error -- + ------------------------- + + procedure Raise_Program_Error + (File : System.Address; + Line : Integer) + is + begin + Raise_With_Location_And_Msg (Program_Error_Def'Access, File, Line); + end Raise_Program_Error; + + ----------------------------- + -- Raise_Program_Error_Msg -- + ----------------------------- + + procedure Raise_Program_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Program_Error_Def'Access, File, Line, M => Msg); + end Raise_Program_Error_Msg; + + ------------------------- + -- Raise_Storage_Error -- + ------------------------- + + procedure Raise_Storage_Error + (File : System.Address; + Line : Integer) + is + begin + Raise_With_Location_And_Msg (Storage_Error_Def'Access, File, Line); + end Raise_Storage_Error; + + ----------------------------- + -- Raise_Storage_Error_Msg -- + ----------------------------- + + procedure Raise_Storage_Error_Msg + (File : System.Address; + Line : Integer; + Msg : System.Address) + is + begin + Raise_With_Location_And_Msg + (Storage_Error_Def'Access, File, Line, M => Msg); + end Raise_Storage_Error_Msg; + + --------------------------------- + -- Raise_With_Location_And_Msg -- + --------------------------------- + + procedure Raise_With_Location_And_Msg + (E : Exception_Id; + F : System.Address; + L : Integer; + C : Integer := 0; + M : System.Address := System.Null_Address) + is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + begin + Exception_Data.Set_Exception_C_Msg (X, E, F, L, C, M); + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_And_Propagate_Occurrence (X); + end Raise_With_Location_And_Msg; + + -------------------- + -- Raise_With_Msg -- + -------------------- + + procedure Raise_With_Msg (E : Exception_Id) is + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; + begin + Excep.Exception_Raised := False; + Excep.Id := E; + Excep.Num_Tracebacks := 0; + Excep.Pid := Local_Partition_ID; + + -- Copy the message from the current exception + -- Change the interface to be called with an occurrence ??? + + Excep.Msg_Length := Ex.Msg_Length; + Excep.Msg (1 .. Excep.Msg_Length) := Ex.Msg (1 .. Ex.Msg_Length); + + -- The following is a common pattern, should be abstracted + -- into a procedure call ??? + + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Complete_And_Propagate_Occurrence (Excep); + end Raise_With_Msg; + + ----------------------------------------- + -- Calls to Run-Time Check Subprograms -- + ----------------------------------------- + + procedure Rcheck_CE_Access_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_00'Address); + end Rcheck_CE_Access_Check; + + procedure Rcheck_CE_Null_Access_Parameter + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_01'Address); + end Rcheck_CE_Null_Access_Parameter; + + procedure Rcheck_CE_Discriminant_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_02'Address); + end Rcheck_CE_Discriminant_Check; + + procedure Rcheck_CE_Divide_By_Zero + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_03'Address); + end Rcheck_CE_Divide_By_Zero; + + procedure Rcheck_CE_Explicit_Raise + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_04'Address); + end Rcheck_CE_Explicit_Raise; + + procedure Rcheck_CE_Index_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_05'Address); + end Rcheck_CE_Index_Check; + + procedure Rcheck_CE_Invalid_Data + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_06'Address); + end Rcheck_CE_Invalid_Data; + + procedure Rcheck_CE_Length_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_07'Address); + end Rcheck_CE_Length_Check; + + procedure Rcheck_CE_Null_Exception_Id + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_08'Address); + end Rcheck_CE_Null_Exception_Id; + + procedure Rcheck_CE_Null_Not_Allowed + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_09'Address); + end Rcheck_CE_Null_Not_Allowed; + + procedure Rcheck_CE_Overflow_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_10'Address); + end Rcheck_CE_Overflow_Check; + + procedure Rcheck_CE_Partition_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_11'Address); + end Rcheck_CE_Partition_Check; + + procedure Rcheck_CE_Range_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_12'Address); + end Rcheck_CE_Range_Check; + + procedure Rcheck_CE_Tag_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, 0, Rmsg_13'Address); + end Rcheck_CE_Tag_Check; + + procedure Rcheck_PE_Access_Before_Elaboration + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_14'Address); + end Rcheck_PE_Access_Before_Elaboration; + + procedure Rcheck_PE_Accessibility_Check + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_15'Address); + end Rcheck_PE_Accessibility_Check; + + procedure Rcheck_PE_Address_Of_Intrinsic + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_16'Address); + end Rcheck_PE_Address_Of_Intrinsic; + + procedure Rcheck_PE_Aliased_Parameters + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_17'Address); + end Rcheck_PE_Aliased_Parameters; + + procedure Rcheck_PE_All_Guards_Closed + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_18'Address); + end Rcheck_PE_All_Guards_Closed; + + procedure Rcheck_PE_Bad_Predicated_Generic_Type + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_19'Address); + end Rcheck_PE_Bad_Predicated_Generic_Type; + + procedure Rcheck_PE_Current_Task_In_Entry_Body + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_20'Address); + end Rcheck_PE_Current_Task_In_Entry_Body; + + procedure Rcheck_PE_Duplicated_Entry_Address + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_21'Address); + end Rcheck_PE_Duplicated_Entry_Address; + + procedure Rcheck_PE_Explicit_Raise + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_22'Address); + end Rcheck_PE_Explicit_Raise; + + procedure Rcheck_PE_Implicit_Return + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_24'Address); + end Rcheck_PE_Implicit_Return; + + procedure Rcheck_PE_Misaligned_Address_Value + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_25'Address); + end Rcheck_PE_Misaligned_Address_Value; + + procedure Rcheck_PE_Missing_Return + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_26'Address); + end Rcheck_PE_Missing_Return; + + procedure Rcheck_PE_Non_Transportable_Actual + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_31'Address); + end Rcheck_PE_Non_Transportable_Actual; + + procedure Rcheck_PE_Overlaid_Controlled_Object + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_27'Address); + end Rcheck_PE_Overlaid_Controlled_Object; + + procedure Rcheck_PE_Potentially_Blocking_Operation + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_28'Address); + end Rcheck_PE_Potentially_Blocking_Operation; + + procedure Rcheck_PE_Stream_Operation_Not_Allowed + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_36'Address); + end Rcheck_PE_Stream_Operation_Not_Allowed; + + procedure Rcheck_PE_Stubbed_Subprogram_Called + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_29'Address); + end Rcheck_PE_Stubbed_Subprogram_Called; + + procedure Rcheck_PE_Unchecked_Union_Restriction + (File : System.Address; Line : Integer) + is + begin + Raise_Program_Error_Msg (File, Line, Rmsg_30'Address); + end Rcheck_PE_Unchecked_Union_Restriction; + + procedure Rcheck_SE_Empty_Storage_Pool + (File : System.Address; Line : Integer) + is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_32'Address); + end Rcheck_SE_Empty_Storage_Pool; + + procedure Rcheck_SE_Explicit_Raise + (File : System.Address; Line : Integer) + is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_33'Address); + end Rcheck_SE_Explicit_Raise; + + procedure Rcheck_SE_Infinite_Recursion + (File : System.Address; Line : Integer) + is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_34'Address); + end Rcheck_SE_Infinite_Recursion; + + procedure Rcheck_SE_Object_Too_Large + (File : System.Address; Line : Integer) + is + begin + Raise_Storage_Error_Msg (File, Line, Rmsg_35'Address); + end Rcheck_SE_Object_Too_Large; + + procedure Rcheck_CE_Access_Check_Ext + (File : System.Address; Line, Column : Integer) + is + begin + Raise_Constraint_Error_Msg (File, Line, Column, Rmsg_00'Address); + end Rcheck_CE_Access_Check_Ext; + + procedure Rcheck_CE_Index_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_05 (Rmsg_05'First .. Rmsg_05'Last - 1) & ASCII.LF + & "index " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_CE_Index_Check_Ext; + + procedure Rcheck_CE_Invalid_Data_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_06 (Rmsg_06'First .. Rmsg_06'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_CE_Invalid_Data_Ext; + + procedure Rcheck_CE_Range_Check_Ext + (File : System.Address; Line, Column, Index, First, Last : Integer) + is + Msg : constant String := + Rmsg_12 (Rmsg_12'First .. Rmsg_12'Last - 1) & ASCII.LF + & "value " & Image (Index) & " not in " & Image (First) + & ".." & Image (Last) & ASCII.NUL; + begin + Raise_Constraint_Error_Msg (File, Line, Column, Msg'Address); + end Rcheck_CE_Range_Check_Ext; + + procedure Rcheck_PE_Finalize_Raised_Exception + (File : System.Address; Line : Integer) + is + X : constant EOA := Exception_Propagation.Allocate_Occurrence; + + begin + -- This is "finalize/adjust raised exception". This subprogram is always + -- called with abort deferred, unlike all other Rcheck_* subprograms, it + -- needs to call Raise_Exception_No_Defer. + + -- This is consistent with Raise_From_Controlled_Operation + + Exception_Data.Set_Exception_C_Msg + (X, Program_Error_Def'Access, File, Line, 0, Rmsg_23'Address); + Complete_And_Propagate_Occurrence (X); + end Rcheck_PE_Finalize_Raised_Exception; + + ------------- + -- Reraise -- + ------------- + + procedure Reraise is + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Saved_MO : constant System.Address := Excep.Machine_Occurrence; + + begin + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Save_Occurrence (Excep.all, Get_Current_Excep.all.all); + Excep.Machine_Occurrence := Saved_MO; + Complete_And_Propagate_Occurrence (Excep); + end Reraise; + + -------------------------------------- + -- Reraise_Library_Exception_If_Any -- + -------------------------------------- + + procedure Reraise_Library_Exception_If_Any is + LE : Exception_Occurrence; + + begin + if Library_Exception_Set then + LE := Library_Exception; + + if LE.Id = Null_Id then + Raise_Exception_No_Defer + (E => Program_Error'Identity, + Message => "finalize/adjust raised exception"); + else + Raise_From_Controlled_Operation (LE); + end if; + end if; + end Reraise_Library_Exception_If_Any; + + ------------------------ + -- Reraise_Occurrence -- + ------------------------ + + procedure Reraise_Occurrence (X : Exception_Occurrence) is + begin + if X.Id = null then + return; + else + Reraise_Occurrence_Always (X); + end if; + end Reraise_Occurrence; + + ------------------------------- + -- Reraise_Occurrence_Always -- + ------------------------------- + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence) is + begin + if not ZCX_By_Default then + Abort_Defer.all; + end if; + + Reraise_Occurrence_No_Defer (X); + end Reraise_Occurrence_Always; + + --------------------------------- + -- Reraise_Occurrence_No_Defer -- + --------------------------------- + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence) is + Excep : constant EOA := Exception_Propagation.Allocate_Occurrence; + Saved_MO : constant System.Address := Excep.Machine_Occurrence; + begin + Save_Occurrence (Excep.all, X); + Excep.Machine_Occurrence := Saved_MO; + Complete_And_Propagate_Occurrence (Excep); + end Reraise_Occurrence_No_Defer; + + --------------------- + -- Save_Occurrence -- + --------------------- + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence) + is + begin + -- As the machine occurrence might be a data that must be finalized + -- (outside any Ada mechanism), do not copy it + + Target.Id := Source.Id; + Target.Machine_Occurrence := System.Null_Address; + Target.Msg_Length := Source.Msg_Length; + Target.Num_Tracebacks := Source.Num_Tracebacks; + Target.Pid := Source.Pid; + + Target.Msg (1 .. Target.Msg_Length) := + Source.Msg (1 .. Target.Msg_Length); + + Target.Tracebacks (1 .. Target.Num_Tracebacks) := + Source.Tracebacks (1 .. Target.Num_Tracebacks); + end Save_Occurrence; + + function Save_Occurrence (Source : Exception_Occurrence) return EOA is + Target : constant EOA := new Exception_Occurrence; + begin + Save_Occurrence (Target.all, Source); + return Target; + end Save_Occurrence; + + ------------------- + -- String_To_EId -- + ------------------- + + function String_To_EId (S : String) return Exception_Id + renames Stream_Attributes.String_To_EId; + + ------------------ + -- String_To_EO -- + ------------------ + + function String_To_EO (S : String) return Exception_Occurrence + renames Stream_Attributes.String_To_EO; + + --------------- + -- To_Stderr -- + --------------- + + procedure To_Stderr (C : Character) is + procedure Put_Char_Stderr (C : Character); + pragma Import (C, Put_Char_Stderr, "put_char_stderr"); + begin + Put_Char_Stderr (C); + end To_Stderr; + + procedure To_Stderr (S : String) is + begin + for J in S'Range loop + if S (J) /= ASCII.CR then + To_Stderr (S (J)); + end if; + end loop; + end To_Stderr; + + ------------------------- + -- Transfer_Occurrence -- + ------------------------- + + procedure Transfer_Occurrence + (Target : Exception_Occurrence_Access; + Source : Exception_Occurrence) + is + begin + Save_Occurrence (Target.all, Source); + end Transfer_Occurrence; + + ------------------------ + -- Triggered_By_Abort -- + ------------------------ + + function Triggered_By_Abort return Boolean is + Ex : constant Exception_Occurrence_Access := Get_Current_Excep.all; + begin + return Ex /= null + and then Exception_Identity (Ex.all) = Standard'Abort_Signal'Identity; + end Triggered_By_Abort; + + ------------------------- + -- Wide_Exception_Name -- + ------------------------- + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Exception_Name + (Id : Exception_Id) return Wide_String + is + S : constant String := Exception_Name (Id); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Exception_Name; + + function Wide_Exception_Name + (X : Exception_Occurrence) return Wide_String + is + S : constant String := Exception_Name (X); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Exception_Name; + + ---------------------------- + -- Wide_Wide_Exception_Name -- + ----------------------------- + + function Wide_Wide_Exception_Name + (Id : Exception_Id) return Wide_Wide_String + is + S : constant String := Exception_Name (Id); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Exception_Name; + + function Wide_Wide_Exception_Name + (X : Exception_Occurrence) return Wide_Wide_String + is + S : constant String := Exception_Name (X); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Exception_Name; + + -------------------------- + -- Code_Address_For_ZZZ -- + -------------------------- + + -- This function gives us the end of the PC range for addresses + -- within the exception unit itself. We hope that gigi/gcc keeps all the + -- procedures in their original order. + + function Code_Address_For_ZZZ return System.Address is + begin + <> + return Start_Of_ZZZ'Address; + end Code_Address_For_ZZZ; + +end Ada.Exceptions; diff --git a/gcc/ada/libgnat/a-except.ads b/gcc/ada/libgnat/a-except.ads new file mode 100644 index 0000000..ff99e35 --- /dev/null +++ b/gcc/ada/libgnat/a-except.ads @@ -0,0 +1,349 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of Ada.Exceptions fully supports Ada 95 and later language +-- versions. It is used in all situations except for the build of the +-- compiler and other basic tools. For these latter builds, we use an +-- Ada 95-only version. + +-- The reason for this splitting off of a separate version is to support +-- older bootstrap compilers that do not support Ada 2005 features, and +-- Ada.Exceptions is part of the compiler sources. + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with ourself. + +with System; +with System.Parameters; +with System.Standard_Library; +with System.Traceback_Entries; + +package Ada.Exceptions is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362. + + type Exception_Id is private; + pragma Preelaborable_Initialization (Exception_Id); + + Null_Id : constant Exception_Id; + + type Exception_Occurrence is limited private; + pragma Preelaborable_Initialization (Exception_Occurrence); + + type Exception_Occurrence_Access is access all Exception_Occurrence; + + Null_Occurrence : constant Exception_Occurrence; + + function Exception_Name (Id : Exception_Id) return String; + + function Exception_Name (X : Exception_Occurrence) return String; + + function Wide_Exception_Name + (Id : Exception_Id) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + + function Wide_Exception_Name + (X : Exception_Occurrence) return Wide_String; + pragma Ada_05 (Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (Id : Exception_Id) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + + function Wide_Wide_Exception_Name + (X : Exception_Occurrence) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Exception_Name); + + procedure Raise_Exception (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception); + -- Note: In accordance with AI-466, CE is raised if E = Null_Id + + function Exception_Message (X : Exception_Occurrence) return String; + + procedure Reraise_Occurrence (X : Exception_Occurrence); + -- Note: it would be really nice to give a pragma No_Return for this + -- procedure, but it would be wrong, since Reraise_Occurrence does return + -- if the argument is the null exception occurrence. See also procedure + -- Reraise_Occurrence_Always in the private part of this package. + + function Exception_Identity (X : Exception_Occurrence) return Exception_Id; + + function Exception_Information (X : Exception_Occurrence) return String; + -- The format of the exception information is as follows: + -- + -- exception name (as in Exception_Name) + -- message (or a null line if no message) + -- PID=nnnn + -- 0xyyyyyyyy 0xyyyyyyyy ... + -- + -- The lines are separated by a ASCII.LF character + -- + -- The nnnn is the partition Id given as decimal digits + -- + -- The 0x... line represents traceback program counter locations, + -- in order with the first one being the exception location. + + -- Note on ordering: the compiler uses the Save_Occurrence procedure, but + -- not the function from Rtsfind, so it is important that the procedure + -- come first, since Rtsfind finds the first matching entity. + + procedure Save_Occurrence + (Target : out Exception_Occurrence; + Source : Exception_Occurrence); + + function Save_Occurrence + (Source : Exception_Occurrence) + return Exception_Occurrence_Access; + + -- Ada 2005 (AI-438): The language revision introduces the following + -- subprograms and attribute definitions. We do not provide them + -- explicitly. instead, the corresponding stream attributes are made + -- available through a pragma Stream_Convert in the private part. + + -- procedure Read_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : out Exception_Occurrence); + + -- procedure Write_Exception_Occurrence + -- (Stream : not null access Ada.Streams.Root_Stream_Type'Class; + -- Item : Exception_Occurrence); + + -- for Exception_Occurrence'Read use Read_Exception_Occurrence; + -- for Exception_Occurrence'Write use Write_Exception_Occurrence; + +private + package SSL renames System.Standard_Library; + package SP renames System.Parameters; + + subtype EOA is Exception_Occurrence_Access; + + Exception_Msg_Max_Length : constant := SP.Default_Exception_Msg_Max_Length; + + ------------------ + -- Exception_Id -- + ------------------ + + subtype Code_Loc is System.Address; + -- Code location used in building exception tables and for call addresses + -- when propagating an exception. Values of this type are created by using + -- Label'Address or extracted from machine states using Get_Code_Loc. + + Null_Loc : constant Code_Loc := System.Null_Address; + -- Null code location, used to flag outer level frame + + type Exception_Id is new SSL.Exception_Data_Ptr; + + function EId_To_String (X : Exception_Id) return String; + function String_To_EId (S : String) return Exception_Id; + pragma Stream_Convert (Exception_Id, String_To_EId, EId_To_String); + -- Functions for implementing Exception_Id stream attributes + + Null_Id : constant Exception_Id := null; + + ------------------------- + -- Private Subprograms -- + ------------------------- + + function Exception_Name_Simple (X : Exception_Occurrence) return String; + -- Like Exception_Name, but returns the simple non-qualified name of the + -- exception. This is used to implement the Exception_Name function in + -- Current_Exceptions (the DEC compatible unit). It is called from the + -- compiler generated code (using Rtsfind, which does not respect the + -- private barrier, so we can place this function in the private part + -- where the compiler can find it, but the spec is unchanged.) + + procedure Raise_Exception_Always (E : Exception_Id; Message : String := ""); + pragma No_Return (Raise_Exception_Always); + pragma Export (Ada, Raise_Exception_Always, "__gnat_raise_exception"); + -- This differs from Raise_Exception only in that the caller has determined + -- that for sure the parameter E is not null, and that therefore no check + -- for Null_Id is required. The expander converts Raise_Exception calls to + -- Raise_Exception_Always if it can determine this is the case. The Export + -- allows this routine to be accessed from Pure units. + + procedure Raise_From_Signal_Handler + (E : Exception_Id; + M : System.Address); + pragma Export + (Ada, Raise_From_Signal_Handler, + "ada__exceptions__raise_from_signal_handler"); + pragma No_Return (Raise_From_Signal_Handler); + -- This routine is used to raise an exception from a signal handler. The + -- signal handler has already stored the machine state (i.e. the state that + -- corresponds to the location at which the signal was raised). E is the + -- Exception_Id specifying what exception is being raised, and M is a + -- pointer to a null-terminated string which is the message to be raised. + -- Note that this routine never returns, so it is permissible to simply + -- jump to this routine, rather than call it. This may be appropriate for + -- systems where the right way to get out of signal handler is to alter the + -- PC value in the machine state or in some other way ask the operating + -- system to return here rather than to the original location. + + procedure Raise_From_Controlled_Operation + (X : Ada.Exceptions.Exception_Occurrence); + pragma No_Return (Raise_From_Controlled_Operation); + pragma Export + (Ada, Raise_From_Controlled_Operation, + "__gnat_raise_from_controlled_operation"); + -- Raise Program_Error, providing information about X (an exception raised + -- during a controlled operation) in the exception message. + + procedure Reraise_Library_Exception_If_Any; + pragma Export + (Ada, Reraise_Library_Exception_If_Any, + "__gnat_reraise_library_exception_if_any"); + -- If there was an exception raised during library-level finalization, + -- reraise the exception. + + procedure Reraise_Occurrence_Always (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_Always); + -- This differs from Raise_Occurrence only in that the caller guarantees + -- that for sure the parameter X is not the null occurrence, and that + -- therefore this procedure cannot return. The expander uses this routine + -- in the translation of a raise statement with no parameter (reraise). + + procedure Reraise_Occurrence_No_Defer (X : Exception_Occurrence); + pragma No_Return (Reraise_Occurrence_No_Defer); + -- Exactly like Reraise_Occurrence, except that abort is not deferred + -- before the call and the parameter X is known not to be the null + -- occurrence. This is used in generated code when it is known that abort + -- is already deferred. + + function Triggered_By_Abort return Boolean; + -- Determine whether the current exception (if it exists) is an instance of + -- Standard'Abort_Signal. + + ----------------------- + -- Polling Interface -- + ----------------------- + + -- The GNAT compiler has an option to generate polling calls to the Poll + -- routine in this package. Specifying the -gnatP option for a compilation + -- causes a call to Ada.Exceptions.Poll to be generated on every subprogram + -- entry and on every iteration of a loop, thus avoiding the possibility of + -- a case of unbounded time between calls. + + -- This polling interface may be used for instrumentation or debugging + -- purposes (e.g. implementing watchpoints in software or in the debugger). + + -- In the GNAT technology itself, this interface is used to implement + -- immediate asynchronous transfer of control and immediate abort on + -- targets which do not provide for one thread interrupting another. + + -- Note: this used to be in a separate unit called System.Poll, but that + -- caused horrible circular elaboration problems between System.Poll and + -- Ada.Exceptions. + + procedure Poll; + -- Check for asynchronous abort. Note that we do not inline the body. + -- This makes the interface more useful for debugging purposes. + + -------------------------- + -- Exception_Occurrence -- + -------------------------- + + package TBE renames System.Traceback_Entries; + + Max_Tracebacks : constant := 50; + -- Maximum number of trace backs stored in exception occurrence + + subtype Tracebacks_Array is TBE.Tracebacks_Array (1 .. Max_Tracebacks); + -- Traceback array stored in exception occurrence + + type Exception_Occurrence is record + Id : Exception_Id; + -- Exception_Identity for this exception occurrence + + Machine_Occurrence : System.Address; + -- The underlying machine occurrence. For GCC, this corresponds to the + -- _Unwind_Exception structure address. + + Msg_Length : Natural := 0; + -- Length of message (zero = no message) + + Msg : String (1 .. Exception_Msg_Max_Length); + -- Characters of message + + Exception_Raised : Boolean := False; + -- Set to true to indicate that this exception occurrence has actually + -- been raised. When an exception occurrence is first created, this is + -- set to False, then when it is processed by Raise_Current_Exception, + -- it is set to True. If Raise_Current_Exception is used to raise an + -- exception for which this flag is already True, then it knows that + -- it is dealing with the reraise case (which is useful to distinguish + -- for exception tracing purposes). + + Pid : Natural := 0; + -- Partition_Id for partition raising exception + + Num_Tracebacks : Natural range 0 .. Max_Tracebacks := 0; + -- Number of traceback entries stored + + Tracebacks : Tracebacks_Array; + -- Stored tracebacks (in Tracebacks (1 .. Num_Tracebacks)) + end record; + + function "=" (Left, Right : Exception_Occurrence) return Boolean + is abstract; + -- Don't allow comparison on exception occurrences, we should not need + -- this, and it would not work right, because of the Msg and Tracebacks + -- fields which have unused entries not copied by Save_Occurrence. + + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address; + pragma Export (Ada, Get_Exception_Machine_Occurrence, + "__gnat_get_exception_machine_occurrence"); + -- Get the machine occurrence corresponding to an exception occurrence. + -- It is Null_Address if there is no machine occurrence (in runtimes that + -- doesn't use GCC mechanism) or if it has been lost (Save_Occurrence + -- doesn't save the machine occurrence). + + function EO_To_String (X : Exception_Occurrence) return String; + function String_To_EO (S : String) return Exception_Occurrence; + pragma Stream_Convert (Exception_Occurrence, String_To_EO, EO_To_String); + -- Functions for implementing Exception_Occurrence stream attributes + + Null_Occurrence : constant Exception_Occurrence := ( + Id => null, + Machine_Occurrence => System.Null_Address, + Msg_Length => 0, + Msg => (others => ' '), + Exception_Raised => False, + Pid => 0, + Num_Tracebacks => 0, + Tracebacks => (others => TBE.Null_TB_Entry)); + +end Ada.Exceptions; diff --git a/gcc/ada/libgnat/a-excpol-abort.adb b/gcc/ada/libgnat/a-excpol-abort.adb new file mode 100644 index 0000000..8ed2e66 --- /dev/null +++ b/gcc/ada/libgnat/a-excpol-abort.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . P O L L -- +-- (version supporting asynchronous abort test) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for targets that do not support per-thread asynchronous +-- signals. On such targets, we require compilation with the -gnatP switch +-- that activates periodic polling. Then in the body of the polling routine +-- we test for asynchronous abort. + +-- Windows and HPUX 10 currently use this file + +pragma Warnings (Off); +-- Allow withing of non-Preelaborated units in Ada 2005 mode where this +-- package will be categorized as Preelaborate. See AI-362 for details. +-- It is safe in the context of the run-time to violate the rules. + +with System.Soft_Links; + +pragma Warnings (On); + +separate (Ada.Exceptions) + +---------- +-- Poll -- +---------- + +procedure Poll is +begin + -- Test for asynchronous abort on each poll + + if System.Soft_Links.Check_Abort_Status.all /= 0 then + raise Standard'Abort_Signal; + end if; +end Poll; diff --git a/gcc/ada/libgnat/a-excpol.adb b/gcc/ada/libgnat/a-excpol.adb new file mode 100644 index 0000000..3568e9c --- /dev/null +++ b/gcc/ada/libgnat/a-excpol.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . P O L L -- +-- -- +-- B o d y -- +-- (dummy version where polling is not used) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +separate (Ada.Exceptions) + +---------- +-- Poll -- +---------- + +procedure Poll is +begin + null; +end Poll; diff --git a/gcc/ada/libgnat/a-exctra.adb b/gcc/ada/libgnat/a-exctra.adb new file mode 100644 index 0000000..cbe30e5 --- /dev/null +++ b/gcc/ada/libgnat/a-exctra.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Exceptions.Traceback is + + ---------------- + -- Tracebacks -- + ---------------- + + function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array is + begin + return Tracebacks_Array (E.Tracebacks (1 .. E.Num_Tracebacks)); + end Tracebacks; + +end Ada.Exceptions.Traceback; diff --git a/gcc/ada/libgnat/a-exctra.ads b/gcc/ada/libgnat/a-exctra.ads new file mode 100644 index 0000000..f395348 --- /dev/null +++ b/gcc/ada/libgnat/a-exctra.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . T R A C E B A C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is part of the support for tracebacks on exceptions + +with System.Traceback_Entries; + +package Ada.Exceptions.Traceback is + + package STBE renames System.Traceback_Entries; + + subtype Code_Loc is System.Address; + -- Code location in executing program + + subtype Tracebacks_Array is STBE.Tracebacks_Array; + -- A traceback array is an array of traceback entries + + function Tracebacks (E : Exception_Occurrence) return Tracebacks_Array; + -- This function extracts the traceback information from an exception + -- occurrence, and returns it formatted in the manner required for + -- processing in GNAT.Traceback. See g-traceb.ads for further details. + + function "=" (A, B : Tracebacks_Array) return Boolean renames STBE."="; + -- Make "=" operator visible directly + + function Get_PC (TBE : STBE.Traceback_Entry) return Code_Loc + renames STBE.PC_For; + -- Returns the code address held by a given traceback entry, typically the + -- address of a call instruction. + +end Ada.Exceptions.Traceback; diff --git a/gcc/ada/libgnat/a-exexda.adb b/gcc/ada/libgnat/a-exexda.adb new file mode 100644 index 0000000..7966487 --- /dev/null +++ b/gcc/ada/libgnat/a-exexda.adb @@ -0,0 +1,744 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.EXCEPTIONS.EXCEPTION_DATA -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; use System.Storage_Elements; + +separate (Ada.Exceptions) +package body Exception_Data is + + -- This unit implements the Exception_Information related services for + -- both the Ada standard requirements and the GNAT.Exception_Traces + -- facility. This is also used by the implementation of the stream + -- attributes of types Exception_Id and Exception_Occurrence. + + -- There are common parts between the contents of Exception_Information + -- (the regular Ada interface) and Untailored_Exception_Information (used + -- for streaming, and when there is no symbolic traceback available) The + -- overall structure is sketched below: + + -- + -- Untailored_Exception_Information + -- | + -- +-------+--------+ + -- | | + -- Basic_Exc_Info & Untailored_Exc_Tback + -- (B_E_I) (U_E_TB) + + -- o-- + -- (B_E_I) | Exception_Name: (as in Exception_Name) + -- | Message: (or a null line if no message) + -- | PID=nnnn (if nonzero) + -- o-- + -- (U_E_TB) | Call stack traceback locations: + -- | <0xyyyyyyyy 0xyyyyyyyy ...> + -- o-- + + -- Exception_Information + -- | + -- +----------+----------+ + -- | | + -- Basic_Exc_Info & traceback + -- | + -- +-----------+------------+ + -- | | + -- Untailored_Exc_Tback Or Tback_Decorator + -- if no decorator set otherwise + + -- Functions returning String imply secondary stack use, which is a heavy + -- mechanism requiring run-time support. Besides, some of the routines we + -- provide here are to be used by the default Last_Chance_Handler, at the + -- critical point where the runtime is about to be finalized. Since most + -- of the items we have at hand are of bounded length, we also provide a + -- procedural interface able to incrementally append the necessary bits to + -- a preallocated buffer or output them straight to stderr. + + -- The procedural interface is composed of two major sections: a neutral + -- section for basic types like Address, Character, Natural or String, and + -- an exception oriented section for the exception names, messages, and + -- information. This is the Append_Info family of procedures below. + + -- Output to stderr is commanded by passing an empty buffer to update, and + -- care is taken not to overflow otherwise. + + -------------------------------------------- + -- Procedural Interface - Neutral section -- + -------------------------------------------- + + procedure Append_Info_Address + (A : Address; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_Character + (C : Character; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_Nat + (N : Natural; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_NL + (Info : in out String; + Ptr : in out Natural); + pragma Inline (Append_Info_NL); + + procedure Append_Info_String + (S : String; + Info : in out String; + Ptr : in out Natural); + + ------------------------------------------------------- + -- Procedural Interface - Exception oriented section -- + ------------------------------------------------------- + + procedure Append_Info_Exception_Name + (Id : Exception_Id; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_Exception_Name + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_Exception_Message + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_Basic_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_Untailored_Exception_Traceback + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + + procedure Append_Info_Untailored_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural); + + -- The "functional" interface to the exception information not involving + -- a traceback decorator uses preallocated intermediate buffers to avoid + -- the use of secondary stack. Preallocation requires preliminary length + -- computation, for which a series of functions are introduced: + + --------------------------------- + -- Length evaluation utilities -- + --------------------------------- + + function Basic_Exception_Info_Maxlength + (X : Exception_Occurrence) return Natural; + + function Untailored_Exception_Traceback_Maxlength + (X : Exception_Occurrence) return Natural; + + function Exception_Info_Maxlength + (X : Exception_Occurrence) return Natural; + + function Exception_Name_Length + (Id : Exception_Id) return Natural; + + function Exception_Name_Length + (X : Exception_Occurrence) return Natural; + + function Exception_Message_Length + (X : Exception_Occurrence) return Natural; + + -------------------------- + -- Functional Interface -- + -------------------------- + + function Untailored_Exception_Traceback + (X : Exception_Occurrence) return String; + -- Returns an image of the complete call chain associated with an + -- exception occurrence in its most basic form, that is as a raw sequence + -- of hexadecimal addresses. + + function Tailored_Exception_Traceback + (X : Exception_Occurrence) return String; + -- Returns an image of the complete call chain associated with an + -- exception occurrence, either in its basic form if no decorator is + -- in place, or as formatted by the decorator otherwise. + + ----------------------------------------------------------------------- + -- Services for the default Last_Chance_Handler and the task wrapper -- + ----------------------------------------------------------------------- + + pragma Export + (Ada, Append_Info_Exception_Message, "__gnat_append_info_e_msg"); + + pragma Export + (Ada, Append_Info_Untailored_Exception_Information, + "__gnat_append_info_u_e_info"); + + pragma Export + (Ada, Exception_Message_Length, "__gnat_exception_msg_len"); + + function Get_Executable_Load_Address return System.Address; + pragma Import (C, Get_Executable_Load_Address, + "__gnat_get_executable_load_address"); + -- Get the load address of the executable, or Null_Address if not known + + ------------------------- + -- Append_Info_Address -- + ------------------------- + + procedure Append_Info_Address + (A : Address; + Info : in out String; + Ptr : in out Natural) + is + S : String (1 .. 18); + P : Natural; + N : Integer_Address; + + H : constant array (Integer range 0 .. 15) of Character := + "0123456789abcdef"; + begin + P := S'Last; + N := To_Integer (A); + loop + S (P) := H (Integer (N mod 16)); + P := P - 1; + N := N / 16; + exit when N = 0; + end loop; + + S (P - 1) := '0'; + S (P) := 'x'; + + Append_Info_String (S (P - 1 .. S'Last), Info, Ptr); + end Append_Info_Address; + + --------------------------------------------- + -- Append_Info_Basic_Exception_Information -- + --------------------------------------------- + + -- To ease the maximum length computation, we define and pull out some + -- string constants: + + BEI_Name_Header : constant String := "raised "; + BEI_Msg_Header : constant String := " : "; + BEI_PID_Header : constant String := "PID: "; + + procedure Append_Info_Basic_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + Name : String (1 .. Exception_Name_Length (X)); + -- Buffer in which to fetch the exception name, in order to check + -- whether this is an internal _ABORT_SIGNAL or a regular occurrence. + + Name_Ptr : Natural := Name'First - 1; + + begin + -- Output exception name and message except for _ABORT_SIGNAL, where + -- these two lines are omitted. + + Append_Info_Exception_Name (X, Name, Name_Ptr); + + if Name (Name'First) /= '_' then + Append_Info_String (BEI_Name_Header, Info, Ptr); + Append_Info_String (Name, Info, Ptr); + + if Exception_Message_Length (X) /= 0 then + Append_Info_String (BEI_Msg_Header, Info, Ptr); + Append_Info_Exception_Message (X, Info, Ptr); + end if; + + Append_Info_NL (Info, Ptr); + end if; + + -- Output PID line if nonzero + + if X.Pid /= 0 then + Append_Info_String (BEI_PID_Header, Info, Ptr); + Append_Info_Nat (X.Pid, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + end Append_Info_Basic_Exception_Information; + + --------------------------- + -- Append_Info_Character -- + --------------------------- + + procedure Append_Info_Character + (C : Character; + Info : in out String; + Ptr : in out Natural) + is + begin + if Info'Length = 0 then + To_Stderr (C); + elsif Ptr < Info'Last then + Ptr := Ptr + 1; + Info (Ptr) := C; + end if; + end Append_Info_Character; + + ----------------------------------- + -- Append_Info_Exception_Message -- + ----------------------------------- + + procedure Append_Info_Exception_Message + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + if X.Id = Null_Id then + raise Constraint_Error; + end if; + + declare + Len : constant Natural := Exception_Message_Length (X); + Msg : constant String (1 .. Len) := X.Msg (1 .. Len); + begin + Append_Info_String (Msg, Info, Ptr); + end; + end Append_Info_Exception_Message; + + -------------------------------- + -- Append_Info_Exception_Name -- + -------------------------------- + + procedure Append_Info_Exception_Name + (Id : Exception_Id; + Info : in out String; + Ptr : in out Natural) + is + begin + if Id = Null_Id then + raise Constraint_Error; + end if; + + declare + Len : constant Natural := Exception_Name_Length (Id); + Name : constant String (1 .. Len) := To_Ptr (Id.Full_Name) (1 .. Len); + begin + Append_Info_String (Name, Info, Ptr); + end; + end Append_Info_Exception_Name; + + procedure Append_Info_Exception_Name + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + Append_Info_Exception_Name (X.Id, Info, Ptr); + end Append_Info_Exception_Name; + + ------------------------------ + -- Exception_Info_Maxlength -- + ------------------------------ + + function Exception_Info_Maxlength + (X : Exception_Occurrence) return Natural + is + begin + return + Basic_Exception_Info_Maxlength (X) + + Untailored_Exception_Traceback_Maxlength (X); + end Exception_Info_Maxlength; + + --------------------- + -- Append_Info_Nat -- + --------------------- + + procedure Append_Info_Nat + (N : Natural; + Info : in out String; + Ptr : in out Natural) + is + begin + if N > 9 then + Append_Info_Nat (N / 10, Info, Ptr); + end if; + + Append_Info_Character + (Character'Val (Character'Pos ('0') + N mod 10), Info, Ptr); + end Append_Info_Nat; + + -------------------- + -- Append_Info_NL -- + -------------------- + + procedure Append_Info_NL + (Info : in out String; + Ptr : in out Natural) + is + begin + Append_Info_Character (ASCII.LF, Info, Ptr); + end Append_Info_NL; + + ------------------------ + -- Append_Info_String -- + ------------------------ + + procedure Append_Info_String + (S : String; + Info : in out String; + Ptr : in out Natural) + is + begin + if Info'Length = 0 then + To_Stderr (S); + else + declare + Last : constant Natural := + Integer'Min (Ptr + S'Length, Info'Last); + begin + Info (Ptr + 1 .. Last) := S; + Ptr := Last; + end; + end if; + end Append_Info_String; + + -------------------------------------------------- + -- Append_Info_Untailored_Exception_Information -- + -------------------------------------------------- + + procedure Append_Info_Untailored_Exception_Information + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + begin + Append_Info_Basic_Exception_Information (X, Info, Ptr); + Append_Info_Untailored_Exception_Traceback (X, Info, Ptr); + end Append_Info_Untailored_Exception_Information; + + ------------------------------------------------ + -- Append_Info_Untailored_Exception_Traceback -- + ------------------------------------------------ + + -- As for Basic_Exception_Information: + + BETB_Header : constant String := "Call stack traceback locations:"; + LDAD_Header : constant String := "Load address: "; + + procedure Append_Info_Untailored_Exception_Traceback + (X : Exception_Occurrence; + Info : in out String; + Ptr : in out Natural) + is + Load_Address : Address; + + begin + if X.Num_Tracebacks = 0 then + return; + end if; + + -- The executable load address line + + Load_Address := Get_Executable_Load_Address; + + if Load_Address /= Null_Address then + Append_Info_String (LDAD_Header, Info, Ptr); + Append_Info_Address (Load_Address, Info, Ptr); + Append_Info_NL (Info, Ptr); + end if; + + -- The traceback lines + + Append_Info_String (BETB_Header, Info, Ptr); + Append_Info_NL (Info, Ptr); + + for J in 1 .. X.Num_Tracebacks loop + Append_Info_Address (TBE.PC_For (X.Tracebacks (J)), Info, Ptr); + exit when J = X.Num_Tracebacks; + Append_Info_Character (' ', Info, Ptr); + end loop; + + Append_Info_NL (Info, Ptr); + end Append_Info_Untailored_Exception_Traceback; + + ------------------------------------------- + -- Basic_Exception_Information_Maxlength -- + ------------------------------------------- + + function Basic_Exception_Info_Maxlength + (X : Exception_Occurrence) return Natural + is + begin + return + BEI_Name_Header'Length + Exception_Name_Length (X) + + BEI_Msg_Header'Length + Exception_Message_Length (X) + 1 + + BEI_PID_Header'Length + 15; + end Basic_Exception_Info_Maxlength; + + --------------------------- + -- Exception_Information -- + --------------------------- + + function Exception_Information (X : Exception_Occurrence) return String is + -- The tailored exception information is the basic information + -- associated with the tailored call chain backtrace. + + Tback_Info : constant String := Tailored_Exception_Traceback (X); + Tback_Len : constant Natural := Tback_Info'Length; + + Info : String (1 .. Basic_Exception_Info_Maxlength (X) + Tback_Len); + Ptr : Natural := Info'First - 1; + + begin + Append_Info_Basic_Exception_Information (X, Info, Ptr); + Append_Info_String (Tback_Info, Info, Ptr); + return Info (Info'First .. Ptr); + end Exception_Information; + + ------------------------------ + -- Exception_Message_Length -- + ------------------------------ + + function Exception_Message_Length + (X : Exception_Occurrence) return Natural + is + begin + return X.Msg_Length; + end Exception_Message_Length; + + --------------------------- + -- Exception_Name_Length -- + --------------------------- + + function Exception_Name_Length (Id : Exception_Id) return Natural is + begin + -- What is stored in the internal Name buffer includes a terminating + -- null character that we never care about. + + return Id.Name_Length - 1; + end Exception_Name_Length; + + function Exception_Name_Length (X : Exception_Occurrence) return Natural is + begin + return Exception_Name_Length (X.Id); + end Exception_Name_Length; + + ------------------------------- + -- Untailored_Exception_Traceback -- + ------------------------------- + + function Untailored_Exception_Traceback + (X : Exception_Occurrence) return String + is + Info : aliased String + (1 .. Untailored_Exception_Traceback_Maxlength (X)); + Ptr : Natural := Info'First - 1; + begin + Append_Info_Untailored_Exception_Traceback (X, Info, Ptr); + return Info (Info'First .. Ptr); + end Untailored_Exception_Traceback; + + -------------------------------------- + -- Untailored_Exception_Information -- + -------------------------------------- + + function Untailored_Exception_Information + (X : Exception_Occurrence) return String + is + Info : String (1 .. Exception_Info_Maxlength (X)); + Ptr : Natural := Info'First - 1; + begin + Append_Info_Untailored_Exception_Information (X, Info, Ptr); + return Info (Info'First .. Ptr); + end Untailored_Exception_Information; + + ------------------------- + -- Set_Exception_C_Msg -- + ------------------------- + + procedure Set_Exception_C_Msg + (Excep : EOA; + Id : Exception_Id; + Msg1 : System.Address; + Line : Integer := 0; + Column : Integer := 0; + Msg2 : System.Address := System.Null_Address) + is + Remind : Integer; + Ptr : Natural; + + procedure Append_Number (Number : Integer); + -- Append given number to Excep.Msg + + ------------------- + -- Append_Number -- + ------------------- + + procedure Append_Number (Number : Integer) is + Val : Integer; + Size : Integer; + + begin + if Number <= 0 then + return; + end if; + + -- Compute the number of needed characters + + Size := 1; + Val := Number; + while Val > 0 loop + Val := Val / 10; + Size := Size + 1; + end loop; + + -- If enough characters are available, put the line number + + if Excep.Msg_Length <= Exception_Msg_Max_Length - Size then + Excep.Msg (Excep.Msg_Length + 1) := ':'; + Excep.Msg_Length := Excep.Msg_Length + Size; + + Val := Number; + Size := 0; + while Val > 0 loop + Remind := Val rem 10; + Val := Val / 10; + Excep.Msg (Excep.Msg_Length - Size) := + Character'Val (Remind + Character'Pos ('0')); + Size := Size + 1; + end loop; + end if; + end Append_Number; + + -- Start of processing for Set_Exception_C_Msg + + begin + Excep.Exception_Raised := False; + Excep.Id := Id; + Excep.Num_Tracebacks := 0; + Excep.Pid := Local_Partition_ID; + Excep.Msg_Length := 0; + + while To_Ptr (Msg1) (Excep.Msg_Length + 1) /= ASCII.NUL + and then Excep.Msg_Length < Exception_Msg_Max_Length + loop + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg1) (Excep.Msg_Length); + end loop; + + Append_Number (Line); + Append_Number (Column); + + -- Append second message if present + + if Msg2 /= System.Null_Address + and then Excep.Msg_Length + 1 < Exception_Msg_Max_Length + then + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := ' '; + + Ptr := 1; + while To_Ptr (Msg2) (Ptr) /= ASCII.NUL + and then Excep.Msg_Length < Exception_Msg_Max_Length + loop + Excep.Msg_Length := Excep.Msg_Length + 1; + Excep.Msg (Excep.Msg_Length) := To_Ptr (Msg2) (Ptr); + Ptr := Ptr + 1; + end loop; + end if; + end Set_Exception_C_Msg; + + ----------------------- + -- Set_Exception_Msg -- + ----------------------- + + procedure Set_Exception_Msg + (Excep : EOA; + Id : Exception_Id; + Message : String) + is + Len : constant Natural := + Natural'Min (Message'Length, Exception_Msg_Max_Length); + First : constant Integer := Message'First; + begin + Excep.Exception_Raised := False; + Excep.Msg_Length := Len; + Excep.Msg (1 .. Len) := Message (First .. First + Len - 1); + Excep.Id := Id; + Excep.Num_Tracebacks := 0; + Excep.Pid := Local_Partition_ID; + end Set_Exception_Msg; + + ---------------------------------- + -- Tailored_Exception_Traceback -- + ---------------------------------- + + function Tailored_Exception_Traceback + (X : Exception_Occurrence) return String + is + -- We reference the decorator *wrapper* here and not the decorator + -- itself. The purpose of the local variable Wrapper is to prevent a + -- potential race condition in the code below. The atomicity of this + -- assignment is enforced by pragma Atomic in System.Soft_Links. + + -- The potential race condition here, if no local variable was used, + -- relates to the test upon the wrapper's value and the call, which + -- are not performed atomically. With the local variable, potential + -- changes of the wrapper's global value between the test and the + -- call become inoffensive. + + Wrapper : constant Traceback_Decorator_Wrapper_Call := + Traceback_Decorator_Wrapper; + + begin + if Wrapper = null then + return Untailored_Exception_Traceback (X); + else + return Wrapper.all (X.Tracebacks'Address, X.Num_Tracebacks); + end if; + end Tailored_Exception_Traceback; + + ---------------------------------------------- + -- Untailored_Exception_Traceback_Maxlength -- + ---------------------------------------------- + + function Untailored_Exception_Traceback_Maxlength + (X : Exception_Occurrence) return Natural + is + Space_Per_Address : constant := 2 + 16 + 1; + -- Space for "0x" + HHHHHHHHHHHHHHHH + " " + begin + return + LDAD_Header'Length + Space_Per_Address + BETB_Header'Length + 1 + + X.Num_Tracebacks * Space_Per_Address + 1; + end Untailored_Exception_Traceback_Maxlength; + +end Exception_Data; diff --git a/gcc/ada/libgnat/a-exexpr.adb b/gcc/ada/libgnat/a-exexpr.adb new file mode 100644 index 0000000..339582a --- /dev/null +++ b/gcc/ada/libgnat/a-exexpr.adb @@ -0,0 +1,439 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . E X C E P T I O N S . E X C E P T I O N _ P R O P A G A T I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the version using the GCC EH mechanism + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with System.Storage_Elements; use System.Storage_Elements; +with System.Exceptions.Machine; use System.Exceptions.Machine; + +separate (Ada.Exceptions) +package body Exception_Propagation is + + use Exception_Traces; + + Foreign_Exception : aliased System.Standard_Library.Exception_Data; + pragma Import (Ada, Foreign_Exception, + "system__exceptions__foreign_exception"); + -- Id for foreign exceptions + + -------------------------------------------------------------- + -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- + -------------------------------------------------------------- + + procedure GNAT_GCC_Exception_Cleanup + (Reason : Unwind_Reason_Code; + Excep : not null GNAT_GCC_Exception_Access); + pragma Convention (C, GNAT_GCC_Exception_Cleanup); + -- Procedure called when a GNAT GCC exception is free. + + procedure Propagate_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Propagate_GCC_Exception); + -- Propagate a GCC exception + + procedure Reraise_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Reraise_GCC_Exception); + pragma Export (C, Reraise_GCC_Exception, "__gnat_reraise_zcx"); + -- Called to implement raise without exception, ie reraise. Called + -- directly from gigi. + + function Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access) return EOA; + pragma Export (C, Setup_Current_Excep, "__gnat_setup_current_excep"); + -- Write Get_Current_Excep.all from GCC_Exception. Called by the + -- personality routine. + + procedure Unhandled_Except_Handler + (GCC_Exception : not null GCC_Exception_Access); + pragma No_Return (Unhandled_Except_Handler); + pragma Export (C, Unhandled_Except_Handler, + "__gnat_unhandled_except_handler"); + -- Called for handle unhandled exceptions, ie the last chance handler + -- on platforms (such as SEH) that never returns after throwing an + -- exception. Called directly by gigi. + + function CleanupUnwind_Handler + (UW_Version : Integer; + UW_Phases : Unwind_Action; + UW_Eclass : Exception_Class; + UW_Exception : not null GCC_Exception_Access; + UW_Context : System.Address; + UW_Argument : System.Address) return Unwind_Reason_Code; + pragma Import (C, CleanupUnwind_Handler, + "__gnat_cleanupunwind_handler"); + -- Hook called at each step of the forced unwinding we perform to trigger + -- cleanups found during the propagation of an unhandled exception. + + -- GCC runtime functions used. These are C non-void functions, actually, + -- but we ignore the return values. See raise.c as to why we are using + -- __gnat stubs for these. + + procedure Unwind_RaiseException + (UW_Exception : not null GCC_Exception_Access); + pragma Import (C, Unwind_RaiseException, "__gnat_Unwind_RaiseException"); + + procedure Unwind_ForcedUnwind + (UW_Exception : not null GCC_Exception_Access; + UW_Handler : System.Address; + UW_Argument : System.Address); + pragma Import (C, Unwind_ForcedUnwind, "__gnat_Unwind_ForcedUnwind"); + + procedure Set_Exception_Parameter + (Excep : EOA; + GCC_Exception : not null GCC_Exception_Access); + pragma Export + (C, Set_Exception_Parameter, "__gnat_set_exception_parameter"); + -- Called inserted by gigi to set the exception choice parameter from the + -- gcc occurrence. + + procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address); + -- Utility routine to initialize occurrence Excep from a foreign exception + -- whose machine occurrence is Mo. The message is empty, the backtrace + -- is empty too and the exception identity is Foreign_Exception. + + -- Hooks called when entering/leaving an exception handler for a given + -- occurrence, aimed at handling the stack of active occurrences. The + -- calls are generated by gigi in tree_transform/N_Exception_Handler. + + procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access); + pragma Export (C, Begin_Handler, "__gnat_begin_handler"); + + procedure End_Handler (GCC_Exception : GCC_Exception_Access); + pragma Export (C, End_Handler, "__gnat_end_handler"); + + -------------------------------------------------------------------- + -- Accessors to Basic Components of a GNAT Exception Data Pointer -- + -------------------------------------------------------------------- + + -- As of today, these are only used by the C implementation of the GCC + -- propagation personality routine to avoid having to rely on a C + -- counterpart of the whole exception_data structure, which is both + -- painful and error prone. These subprograms could be moved to a more + -- widely visible location if need be. + + function Is_Handled_By_Others (E : Exception_Data_Ptr) return Boolean; + pragma Export (C, Is_Handled_By_Others, "__gnat_is_handled_by_others"); + pragma Warnings (Off, Is_Handled_By_Others); + + function Language_For (E : Exception_Data_Ptr) return Character; + pragma Export (C, Language_For, "__gnat_language_for"); + + function Foreign_Data_For (E : Exception_Data_Ptr) return Address; + pragma Export (C, Foreign_Data_For, "__gnat_foreign_data_for"); + + function EID_For (GNAT_Exception : not null GNAT_GCC_Exception_Access) + return Exception_Id; + pragma Export (C, EID_For, "__gnat_eid_for"); + + --------------------------------------------------------------------------- + -- Objects to materialize "others" and "all others" in the GCC EH tables -- + --------------------------------------------------------------------------- + + -- Currently, these only have their address taken and compared so there is + -- no real point having whole exception data blocks allocated. Note that + -- there are corresponding declarations in gigi (trans.c) which must be + -- kept properly synchronized. + + Others_Value : constant Character := 'O'; + pragma Export (C, Others_Value, "__gnat_others_value"); + + All_Others_Value : constant Character := 'A'; + pragma Export (C, All_Others_Value, "__gnat_all_others_value"); + + Unhandled_Others_Value : constant Character := 'U'; + pragma Export (C, Unhandled_Others_Value, "__gnat_unhandled_others_value"); + -- Special choice (emitted by gigi) to catch and notify unhandled + -- exceptions on targets which always handle exceptions (such as SEH). + -- The handler will simply call Unhandled_Except_Handler. + + ------------------------- + -- Allocate_Occurrence -- + ------------------------- + + function Allocate_Occurrence return EOA is + Res : GNAT_GCC_Exception_Access; + + begin + Res := New_Occurrence; + Res.Header.Cleanup := GNAT_GCC_Exception_Cleanup'Address; + Res.Occurrence.Machine_Occurrence := Res.all'Address; + + return Res.Occurrence'Access; + end Allocate_Occurrence; + + -------------------------------- + -- GNAT_GCC_Exception_Cleanup -- + -------------------------------- + + procedure GNAT_GCC_Exception_Cleanup + (Reason : Unwind_Reason_Code; + Excep : not null GNAT_GCC_Exception_Access) + is + pragma Unreferenced (Reason); + + procedure Free is new Unchecked_Deallocation + (GNAT_GCC_Exception, GNAT_GCC_Exception_Access); + + Copy : GNAT_GCC_Exception_Access := Excep; + + begin + -- Simply free the memory + + Free (Copy); + end GNAT_GCC_Exception_Cleanup; + + ---------------------------- + -- Set_Foreign_Occurrence -- + ---------------------------- + + procedure Set_Foreign_Occurrence (Excep : EOA; Mo : System.Address) is + begin + Excep.all := ( + Id => Foreign_Exception'Access, + Machine_Occurrence => Mo, + Msg => <>, + Msg_Length => 0, + Exception_Raised => True, + Pid => Local_Partition_ID, + Num_Tracebacks => 0, + Tracebacks => <>); + end Set_Foreign_Occurrence; + + ------------------------- + -- Setup_Current_Excep -- + ------------------------- + + function Setup_Current_Excep + (GCC_Exception : not null GCC_Exception_Access) return EOA + is + Excep : constant EOA := Get_Current_Excep.all; + + begin + -- Setup the exception occurrence + + if GCC_Exception.Class = GNAT_Exception_Class then + + -- From the GCC exception + + declare + GNAT_Occurrence : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (GCC_Exception); + begin + Excep.all := GNAT_Occurrence.Occurrence; + return GNAT_Occurrence.Occurrence'Access; + end; + + else + -- A default one + + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); + + return Excep; + end if; + end Setup_Current_Excep; + + ------------------- + -- Begin_Handler -- + ------------------- + + procedure Begin_Handler (GCC_Exception : not null GCC_Exception_Access) is + pragma Unreferenced (GCC_Exception); + begin + null; + end Begin_Handler; + + ----------------- + -- End_Handler -- + ----------------- + + procedure End_Handler (GCC_Exception : GCC_Exception_Access) is + begin + if GCC_Exception /= null then + + -- The exception might have been reraised, in this case the cleanup + -- mustn't be called. + + Unwind_DeleteException (GCC_Exception); + end if; + end End_Handler; + + ----------------------------- + -- Reraise_GCC_Exception -- + ----------------------------- + + procedure Reraise_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access) + is + begin + -- Simply propagate it + + Propagate_GCC_Exception (GCC_Exception); + end Reraise_GCC_Exception; + + ----------------------------- + -- Propagate_GCC_Exception -- + ----------------------------- + + -- Call Unwind_RaiseException to actually throw, taking care of handling + -- the two phase scheme it implements. + + procedure Propagate_GCC_Exception + (GCC_Exception : not null GCC_Exception_Access) + is + Excep : EOA; + + begin + -- Perform a standard raise first. If a regular handler is found, it + -- will be entered after all the intermediate cleanups have run. If + -- there is no regular handler, it will return. + + Unwind_RaiseException (GCC_Exception); + + -- If we get here we know the exception is not handled, as otherwise + -- Unwind_RaiseException arranges for the handler to be entered. Take + -- the necessary steps to enable the debugger to gain control while the + -- stack is still intact. + + Excep := Setup_Current_Excep (GCC_Exception); + Notify_Unhandled_Exception (Excep); + + -- Now, un a forced unwind to trigger cleanups. Control should not + -- resume there, if there are cleanups and in any cases as the + -- unwinding hook calls Unhandled_Exception_Terminate when end of + -- stack is reached. + + Unwind_ForcedUnwind + (GCC_Exception, + CleanupUnwind_Handler'Address, + System.Null_Address); + + -- We get here in case of error. The debugger has been notified before + -- the second step above. + + Unhandled_Except_Handler (GCC_Exception); + end Propagate_GCC_Exception; + + ------------------------- + -- Propagate_Exception -- + ------------------------- + + procedure Propagate_Exception (Excep : EOA) is + begin + Propagate_GCC_Exception (To_GCC_Exception (Excep.Machine_Occurrence)); + end Propagate_Exception; + + ----------------------------- + -- Set_Exception_Parameter -- + ----------------------------- + + procedure Set_Exception_Parameter + (Excep : EOA; + GCC_Exception : not null GCC_Exception_Access) + is + begin + -- Setup the exception occurrence + + if GCC_Exception.Class = GNAT_Exception_Class then + + -- From the GCC exception + + declare + GNAT_Occurrence : constant GNAT_GCC_Exception_Access := + To_GNAT_GCC_Exception (GCC_Exception); + begin + Save_Occurrence (Excep.all, GNAT_Occurrence.Occurrence); + end; + + else + -- A default one + + Set_Foreign_Occurrence (Excep, GCC_Exception.all'Address); + end if; + end Set_Exception_Parameter; + + ------------------------------ + -- Unhandled_Except_Handler -- + ------------------------------ + + procedure Unhandled_Except_Handler + (GCC_Exception : not null GCC_Exception_Access) + is + Excep : EOA; + begin + Excep := Setup_Current_Excep (GCC_Exception); + Unhandled_Exception_Terminate (Excep); + end Unhandled_Except_Handler; + + ------------- + -- EID_For -- + ------------- + + function EID_For + (GNAT_Exception : not null GNAT_GCC_Exception_Access) return Exception_Id + is + begin + return GNAT_Exception.Occurrence.Id; + end EID_For; + + ---------------------- + -- Foreign_Data_For -- + ---------------------- + + function Foreign_Data_For + (E : SSL.Exception_Data_Ptr) return Address + is + begin + return E.Foreign_Data; + end Foreign_Data_For; + + -------------------------- + -- Is_Handled_By_Others -- + -------------------------- + + function Is_Handled_By_Others (E : SSL.Exception_Data_Ptr) return Boolean is + begin + return not E.all.Not_Handled_By_Others; + end Is_Handled_By_Others; + + ------------------ + -- Language_For -- + ------------------ + + function Language_For (E : SSL.Exception_Data_Ptr) return Character is + begin + return E.all.Lang; + end Language_For; + +end Exception_Propagation; diff --git a/gcc/ada/libgnat/a-exextr.adb b/gcc/ada/libgnat/a-exextr.adb new file mode 100644 index 0000000..d59c148 --- /dev/null +++ b/gcc/ada/libgnat/a-exextr.adb @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.EXCEPTIONS.EXCEPTION_TRACES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +pragma Warnings (Off); +with Ada.Exceptions.Last_Chance_Handler; +pragma Warnings (On); +-- Bring last chance handler into closure + +separate (Ada.Exceptions) +package body Exception_Traces is + + Nline : constant String := String'(1 => ASCII.LF); + -- Convenient shortcut + + type Exception_Action is access procedure (E : Exception_Occurrence); + Global_Action : Exception_Action := null; + pragma Export + (Ada, Global_Action, "__gnat_exception_actions_global_action"); + -- Global action, executed whenever an exception is raised. Changing the + -- export name must be coordinated with code in g-excact.adb. + + Raise_Hook_Initialized : Boolean := False; + pragma Export + (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized"); + + procedure Last_Chance_Handler (Except : Exception_Occurrence); + pragma Import (C, Last_Chance_Handler, "__gnat_last_chance_handler"); + pragma No_Return (Last_Chance_Handler); + -- Users can replace the default version of this routine, + -- Ada.Exceptions.Last_Chance_Handler. + + function To_Action is new Ada.Unchecked_Conversion + (Raise_Action, Exception_Action); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean); + -- Factorizes the common processing for Notify_Handled_Exception and + -- Notify_Unhandled_Exception. Is_Unhandled is set to True only in the + -- latter case because Notify_Handled_Exception may be called for an + -- actually unhandled occurrence in the Front-End-SJLJ case. + + ---------------------- + -- Notify_Exception -- + ---------------------- + + procedure Notify_Exception (Excep : EOA; Is_Unhandled : Boolean) is + begin + -- Output the exception information required by the Exception_Trace + -- configuration. Take care not to output information about internal + -- exceptions. + + if not Excep.Id.Not_Handled_By_Others + and then + (Exception_Trace = Every_Raise + or else + (Is_Unhandled + and then + (Exception_Trace = Unhandled_Raise + or else Exception_Trace = Unhandled_Raise_In_Main))) + then + -- Exception trace messages need to be protected when several tasks + -- can issue them at the same time. + + Lock_Task.all; + To_Stderr (Nline); + + if Exception_Trace /= Unhandled_Raise_In_Main then + if Is_Unhandled then + To_Stderr ("Unhandled "); + end if; + + To_Stderr ("Exception raised"); + To_Stderr (Nline); + end if; + + To_Stderr (Exception_Information (Excep.all)); + Unlock_Task.all; + end if; + + -- Call the user-specific actions + -- ??? We should presumably look at the reraise status here. + + if Raise_Hook_Initialized + and then Exception_Data_Ptr (Excep.Id).Raise_Hook /= null + then + To_Action (Exception_Data_Ptr (Excep.Id).Raise_Hook) (Excep.all); + end if; + + if Global_Action /= null then + Global_Action (Excep.all); + end if; + end Notify_Exception; + + ------------------------------ + -- Notify_Handled_Exception -- + ------------------------------ + + procedure Notify_Handled_Exception (Excep : EOA) is + begin + Notify_Exception (Excep, Is_Unhandled => False); + end Notify_Handled_Exception; + + -------------------------------- + -- Notify_Unhandled_Exception -- + -------------------------------- + + procedure Notify_Unhandled_Exception (Excep : EOA) is + begin + -- Check whether there is any termination handler to be executed for + -- the environment task, and execute it if needed. Here we handle both + -- the Abnormal and Unhandled_Exception task termination. Normal + -- task termination routine is executed elsewhere (either in the + -- Task_Wrapper or in the Adafinal routine for the environment task). + + Task_Termination_Handler.all (Excep.all); + + Notify_Exception (Excep, Is_Unhandled => True); + Debug_Unhandled_Exception (SSL.Exception_Data_Ptr (Excep.Id)); + end Notify_Unhandled_Exception; + + ----------------------------------- + -- Unhandled_Exception_Terminate -- + ----------------------------------- + + procedure Unhandled_Exception_Terminate (Excep : EOA) is + Occ : Exception_Occurrence; + -- This occurrence will be used to display a message after finalization. + -- It is necessary to save a copy here, or else the designated value + -- could be overwritten if an exception is raised during finalization + -- (even if that exception is caught). The occurrence is saved on the + -- stack to avoid dynamic allocation (if this exception is due to lack + -- of space in the heap, we therefore avoid a second failure). We assume + -- that there is enough room on the stack however. + + begin + Save_Occurrence (Occ, Excep.all); + Last_Chance_Handler (Occ); + end Unhandled_Exception_Terminate; + + ------------------------------------ + -- Handling GNAT.Exception_Traces -- + ------------------------------------ + + -- The bulk of exception traces output is centralized in Notify_Exception, + -- for both the Handled and Unhandled cases. Extra task specific output is + -- triggered in the task wrapper for unhandled occurrences in tasks. It is + -- not performed in this unit to avoid dependencies on the tasking units + -- here. + + -- We used to rely on the output performed by Unhanded_Exception_Terminate + -- for the case of an unhandled occurrence in the environment thread, and + -- the task wrapper was responsible for the whole output in the tasking + -- case. + + -- This initial scheme had a drawback: the output from Terminate only + -- occurs after finalization is done, which means possibly never if some + -- tasks keep hanging around. + + -- The first "presumably obvious" fix consists in moving the Terminate + -- output before the finalization. It has not been retained because it + -- introduces annoying changes in output orders when the finalization + -- itself issues outputs, this also in "regular" cases not resorting to + -- Exception_Traces. + + -- Today's solution has the advantage of simplicity and better isolates + -- the Exception_Traces machinery. + +end Exception_Traces; diff --git a/gcc/ada/libgnat/a-exstat.adb b/gcc/ada/libgnat/a-exstat.adb new file mode 100644 index 0000000..898e4cb --- /dev/null +++ b/gcc/ada/libgnat/a-exstat.adb @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.EXCEPTIONS.STREAM_ATTRIBUTES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +-- Allow withing of non-Preelaborated units in Ada 2005 mode where this +-- package will be categorized as Preelaborate. See AI-362 for details. +-- It is safe in the context of the run-time to violate the rules. + +with System.Exception_Table; use System.Exception_Table; +with System.Storage_Elements; use System.Storage_Elements; + +pragma Warnings (On); + +separate (Ada.Exceptions) +package body Stream_Attributes is + + ------------------- + -- EId_To_String -- + ------------------- + + function EId_To_String (X : Exception_Id) return String is + begin + if X = Null_Id then + return ""; + else + return Exception_Name (X); + end if; + end EId_To_String; + + ------------------ + -- EO_To_String -- + ------------------ + + -- We use the null string to represent the null occurrence, otherwise we + -- output the Untailored_Exception_Information string for the occurrence. + + function EO_To_String (X : Exception_Occurrence) return String is + begin + if X.Id = Null_Id then + return ""; + else + return Exception_Data.Untailored_Exception_Information (X); + end if; + end EO_To_String; + + ------------------- + -- String_To_EId -- + ------------------- + + function String_To_EId (S : String) return Exception_Id is + begin + if S = "" then + return Null_Id; + else + return Exception_Id (Internal_Exception (S)); + end if; + end String_To_EId; + + ------------------ + -- String_To_EO -- + ------------------ + + function String_To_EO (S : String) return Exception_Occurrence is + From : Natural; + To : Integer; + + X : aliased Exception_Occurrence; + -- This is the exception occurrence we will create + + procedure Bad_EO; + pragma No_Return (Bad_EO); + -- Signal bad exception occurrence string + + procedure Next_String; + -- On entry, To points to last character of previous line of the + -- message, terminated by LF. On return, From .. To are set to + -- specify the next string, or From > To if there are no more lines. + + procedure Bad_EO is + begin + Raise_Exception + (Program_Error'Identity, + "bad exception occurrence in stream input"); + + -- The following junk raise of Program_Error is required because + -- this is a No_Return procedure, and unfortunately Raise_Exception + -- can return (this particular call can't, but the back end is not + -- clever enough to know that). + + raise Program_Error; + end Bad_EO; + + procedure Next_String is + begin + From := To + 2; + + if From < S'Last then + To := From + 1; + + while To < S'Last - 1 loop + if To >= S'Last then + Bad_EO; + elsif S (To + 1) = ASCII.LF then + exit; + else + To := To + 1; + end if; + end loop; + end if; + end Next_String; + + -- Start of processing for String_To_EO + + begin + if S = "" then + return Null_Occurrence; + end if; + + To := S'First - 2; + Next_String; + + if S (From .. From + 6) /= "raised " then + Bad_EO; + end if; + + declare + Name_Start : constant Positive := From + 7; + begin + From := Name_Start + 1; + + while From < To and then S (From) /= ' ' loop + From := From + 1; + end loop; + + X.Id := + Exception_Id (Internal_Exception (S (Name_Start .. From - 1))); + end; + + if From <= To then + if S (From .. From + 2) /= " : " then + Bad_EO; + end if; + + X.Msg_Length := To - From - 2; + X.Msg (1 .. X.Msg_Length) := S (From + 3 .. To); + + else + X.Msg_Length := 0; + end if; + + Next_String; + X.Pid := 0; + + if From <= To and then S (From) = 'P' then + if S (From .. From + 3) /= "PID:" then + Bad_EO; + end if; + + From := From + 5; -- skip past PID: space + + while From <= To loop + X.Pid := X.Pid * 10 + + (Character'Pos (S (From)) - Character'Pos ('0')); + From := From + 1; + end loop; + + Next_String; + end if; + + X.Num_Tracebacks := 0; + + if From <= To then + if S (From .. To) /= "Call stack traceback locations:" then + Bad_EO; + end if; + + Next_String; + loop + exit when From > To; + + declare + Ch : Character; + C : Integer_Address; + N : Integer_Address; + + begin + if S (From) /= '0' + or else S (From + 1) /= 'x' + then + Bad_EO; + else + From := From + 2; + end if; + + C := 0; + while From <= To loop + Ch := S (From); + + if Ch in '0' .. '9' then + N := + Character'Pos (S (From)) - Character'Pos ('0'); + + elsif Ch in 'a' .. 'f' then + N := + Character'Pos (S (From)) - Character'Pos ('a') + 10; + + elsif Ch = ' ' then + From := From + 1; + exit; + + else + Bad_EO; + end if; + + C := C * 16 + N; + + From := From + 1; + end loop; + + if X.Num_Tracebacks = Max_Tracebacks then + Bad_EO; + end if; + + X.Num_Tracebacks := X.Num_Tracebacks + 1; + X.Tracebacks (X.Num_Tracebacks) := + TBE.TB_Entry_For (To_Address (C)); + end; + end loop; + end if; + + -- If an exception was converted to a string, it must have + -- already been raised, so flag it accordingly and we are done. + + X.Exception_Raised := True; + return X; + end String_To_EO; + +end Stream_Attributes; diff --git a/gcc/ada/libgnat/a-finali.adb b/gcc/ada/libgnat/a-finali.adb new file mode 100644 index 0000000..36690f9 --- /dev/null +++ b/gcc/ada/libgnat/a-finali.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body. We provide a dummy file containing a +-- No_Body pragma so that previous versions of the body (which did exist) will +-- not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/a-finali.ads b/gcc/ada/libgnat/a-finali.ads new file mode 100644 index 0000000..6f001db --- /dev/null +++ b/gcc/ada/libgnat/a-finali.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F I N A L I Z A T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +with System.Finalization_Root; +pragma Warnings (On); + +package Ada.Finalization is + pragma Pure; + + type Controlled is abstract tagged private; + pragma Preelaborable_Initialization (Controlled); + + procedure Initialize (Object : in out Controlled) is null; + procedure Adjust (Object : in out Controlled) is null; + procedure Finalize (Object : in out Controlled) is null; + + type Limited_Controlled is abstract tagged limited private; + pragma Preelaborable_Initialization (Limited_Controlled); + + procedure Initialize (Object : in out Limited_Controlled) is null; + procedure Finalize (Object : in out Limited_Controlled) is null; + +private + package SFR renames System.Finalization_Root; + + type Controlled is abstract new SFR.Root_Controlled with null record; + + -- In order to simplify the implementation, the mechanism in Process_Full_ + -- View ensures that the full view is limited even though the parent type + -- is not. + + type Limited_Controlled is + abstract new SFR.Root_Controlled with null record; + +end Ada.Finalization; diff --git a/gcc/ada/libgnat/a-flteio.ads b/gcc/ada/libgnat/a-flteio.ads new file mode 100644 index 0000000..caf4e9b --- /dev/null +++ b/gcc/ada/libgnat/a-flteio.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +pragma Elaborate_All (Ada.Text_IO); + +package Ada.Float_Text_IO is + new Ada.Text_IO.Float_IO (Float); diff --git a/gcc/ada/libgnat/a-fwteio.ads b/gcc/ada/libgnat/a-fwteio.ads new file mode 100644 index 0000000..e87e08a --- /dev/null +++ b/gcc/ada/libgnat/a-fwteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Float); diff --git a/gcc/ada/libgnat/a-fzteio.ads b/gcc/ada/libgnat/a-fzteio.ads new file mode 100644 index 0000000..81bf7b2 --- /dev/null +++ b/gcc/ada/libgnat/a-fzteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Float); diff --git a/gcc/ada/libgnat/a-inteio.ads b/gcc/ada/libgnat/a-inteio.ads new file mode 100644 index 0000000..b2b3867 --- /dev/null +++ b/gcc/ada/libgnat/a-inteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/libgnat/a-ioexce.ads b/gcc/ada/libgnat/a-ioexce.ads new file mode 100644 index 0000000..7fec393 --- /dev/null +++ b/gcc/ada/libgnat/a-ioexce.ads @@ -0,0 +1,30 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I O _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package Ada.IO_Exceptions is + pragma Pure; + + Status_Error : exception; + Mode_Error : exception; + Name_Error : exception; + Use_Error : exception; + Device_Error : exception; + End_Error : exception; + Data_Error : exception; + Layout_Error : exception; + +end Ada.IO_Exceptions; diff --git a/gcc/ada/libgnat/a-iteint.ads b/gcc/ada/libgnat/a-iteint.ads new file mode 100644 index 0000000..8ac9e1a --- /dev/null +++ b/gcc/ada/libgnat/a-iteint.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . I T E R A T O R . I N T E R F A C E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Cursor; + with function Has_Element (Position : Cursor) return Boolean; + pragma Unreferenced (Has_Element); + +package Ada.Iterator_Interfaces is + pragma Pure; + + type Forward_Iterator is limited interface; + + function First + (Object : Forward_Iterator) return Cursor is abstract; + function Next + (Object : Forward_Iterator; + Position : Cursor) return Cursor is abstract; + + type Reversible_Iterator is limited interface and Forward_Iterator; + + function Last + (Object : Reversible_Iterator) return Cursor is abstract; + function Previous + (Object : Reversible_Iterator; + Position : Cursor) return Cursor is abstract; +end Ada.Iterator_Interfaces; diff --git a/gcc/ada/libgnat/a-iwteio.ads b/gcc/ada/libgnat/a-iwteio.ads new file mode 100644 index 0000000..dc53046 --- /dev/null +++ b/gcc/ada/libgnat/a-iwteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/libgnat/a-izteio.ads b/gcc/ada/libgnat/a-izteio.ads new file mode 100644 index 0000000..8eb5466 --- /dev/null +++ b/gcc/ada/libgnat/a-izteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Integer); diff --git a/gcc/ada/libgnat/a-lcteio.ads b/gcc/ada/libgnat/a-lcteio.ads new file mode 100644 index 0000000..f9da97c --- /dev/null +++ b/gcc/ada/libgnat/a-lcteio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Long_Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Long_Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Long_Complex_Types); diff --git a/gcc/ada/libgnat/a-lfteio.ads b/gcc/ada/libgnat/a-lfteio.ads new file mode 100644 index 0000000..1477047 --- /dev/null +++ b/gcc/ada/libgnat/a-lfteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Float_Text_IO is + new Ada.Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/libgnat/a-lfwtio.ads b/gcc/ada/libgnat/a-lfwtio.ads new file mode 100644 index 0000000..8636141 --- /dev/null +++ b/gcc/ada/libgnat/a-lfwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/libgnat/a-lfztio.ads b/gcc/ada/libgnat/a-lfztio.ads new file mode 100644 index 0000000..f1719b1 --- /dev/null +++ b/gcc/ada/libgnat/a-lfztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Long_Float); diff --git a/gcc/ada/libgnat/a-liteio.ads b/gcc/ada/libgnat/a-liteio.ads new file mode 100644 index 0000000..535f6b0 --- /dev/null +++ b/gcc/ada/libgnat/a-liteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/libgnat/a-liwtio.ads b/gcc/ada/libgnat/a-liwtio.ads new file mode 100644 index 0000000..56fad9a --- /dev/null +++ b/gcc/ada/libgnat/a-liwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/libgnat/a-liztio.ads b/gcc/ada/libgnat/a-liztio.ads new file mode 100644 index 0000000..100ef0a --- /dev/null +++ b/gcc/ada/libgnat/a-liztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Integer); diff --git a/gcc/ada/libgnat/a-llctio.ads b/gcc/ada/libgnat/a-llctio.ads new file mode 100644 index 0000000..3b53bf7 --- /dev/null +++ b/gcc/ada/libgnat/a-llctio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Long_Long_Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Long_Long_Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Long_Long_Complex_Types); diff --git a/gcc/ada/libgnat/a-llftio.ads b/gcc/ada/libgnat/a-llftio.ads new file mode 100644 index 0000000..589232d --- /dev/null +++ b/gcc/ada/libgnat/a-llftio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Long_Float_Text_IO is + new Ada.Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/libgnat/a-llfwti.ads b/gcc/ada/libgnat/a-llfwti.ads new file mode 100644 index 0000000..b26aecd --- /dev/null +++ b/gcc/ada/libgnat/a-llfwti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Long_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/libgnat/a-llfzti.ads b/gcc/ada/libgnat/a-llfzti.ads new file mode 100644 index 0000000..6bc9792 --- /dev/null +++ b/gcc/ada/libgnat/a-llfzti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.LONG_LONG_FLOAT_WIDE_WIDE_TEXT_IO -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Long_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Long_Long_Float); diff --git a/gcc/ada/libgnat/a-llitio.ads b/gcc/ada/libgnat/a-llitio.ads new file mode 100644 index 0000000..e153727 --- /dev/null +++ b/gcc/ada/libgnat/a-llitio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Long_Long_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/libgnat/a-lliwti.ads b/gcc/ada/libgnat/a-lliwti.ads new file mode 100644 index 0000000..13a0f21 --- /dev/null +++ b/gcc/ada/libgnat/a-lliwti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Long_Long_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/libgnat/a-llizti.ads b/gcc/ada/libgnat/a-llizti.ads new file mode 100644 index 0000000..09d3219 --- /dev/null +++ b/gcc/ada/libgnat/a-llizti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O N G _ L O N G _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Long_Long_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Long_Long_Integer); diff --git a/gcc/ada/libgnat/a-locale.adb b/gcc/ada/libgnat/a-locale.adb new file mode 100644 index 0000000..9c2f314 --- /dev/null +++ b/gcc/ada/libgnat/a-locale.adb @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O C A L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; + +package body Ada.Locales is + + type Str_4 is new String (1 .. 4); + + -------------- + -- Language -- + -------------- + + function Language return Language_Code is + procedure C_Get_Language_Code (P : Address); + pragma Import (C, C_Get_Language_Code); + F : Str_4; + begin + C_Get_Language_Code (F'Address); + return Language_Code (F (1 .. 3)); + end Language; + + ------------- + -- Country -- + ------------- + + function Country return Country_Code is + procedure C_Get_Country_Code (P : Address); + pragma Import (C, C_Get_Country_Code); + F : Str_4; + begin + C_Get_Country_Code (F'Address); + return Country_Code (F (1 .. 2)); + end Country; + +end Ada.Locales; diff --git a/gcc/ada/libgnat/a-locale.ads b/gcc/ada/libgnat/a-locale.ads new file mode 100644 index 0000000..605ce20 --- /dev/null +++ b/gcc/ada/libgnat/a-locale.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . L O C A L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note that this package is currently not implemented on any platform and +-- functions Language and Country will always return +-- Language_Unknown/Country_Unknown. + +package Ada.Locales is + pragma Preelaborate (Locales); + pragma Remote_Types (Locales); + + type Language_Code is new String (1 .. 3) + with Dynamic_Predicate => + (for all E of Language_Code => E in 'a' .. 'z'); + + type Country_Code is new String (1 .. 2) + with Dynamic_Predicate => + (for all E of Country_Code => E in 'A' .. 'Z'); + + Language_Unknown : constant Language_Code := "und"; + Country_Unknown : constant Country_Code := "ZZ"; + + function Language return Language_Code; + function Country return Country_Code; + +end Ada.Locales; diff --git a/gcc/ada/libgnat/a-ncelfu.ads b/gcc/ada/libgnat/a-ncelfu.ads new file mode 100644 index 0000000..e81730f --- /dev/null +++ b/gcc/ada/libgnat/a-ncelfu.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Complex_Types); + +pragma Pure (Ada.Numerics.Complex_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-ngcefu.adb b/gcc/ada/libgnat/a-ngcefu.adb new file mode 100644 index 0000000..3f3973f --- /dev/null +++ b/gcc/ada/libgnat/a-ngcefu.adb @@ -0,0 +1,710 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package body Ada.Numerics.Generic_Complex_Elementary_Functions is + + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real'Base); + use Elementary_Functions; + + PI : constant := 3.14159_26535_89793_23846_26433_83279_50288_41971; + PI_2 : constant := PI / 2.0; + Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; + Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; + + subtype T is Real'Base; + + Epsilon : constant T := 2.0 ** (1 - T'Model_Mantissa); + Square_Root_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); + Inv_Square_Root_Epsilon : constant T := Sqrt_Two ** (T'Model_Mantissa - 1); + Root_Root_Epsilon : constant T := Sqrt_Two ** + ((1 - T'Model_Mantissa) / 2); + Log_Inverse_Epsilon_2 : constant T := T (T'Model_Mantissa - 1) / 2.0; + + Complex_Zero : constant Complex := (0.0, 0.0); + Complex_One : constant Complex := (1.0, 0.0); + Complex_I : constant Complex := (0.0, 1.0); + Half_Pi : constant Complex := (PI_2, 0.0); + + -------- + -- ** -- + -------- + + function "**" (Left : Complex; Right : Complex) return Complex is + begin + if Re (Right) = 0.0 + and then Im (Right) = 0.0 + and then Re (Left) = 0.0 + and then Im (Left) = 0.0 + then + raise Argument_Error; + + elsif Re (Left) = 0.0 + and then Im (Left) = 0.0 + and then Re (Right) < 0.0 + then + raise Constraint_Error; + + elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then + return Left; + + elsif Right = (0.0, 0.0) then + return Complex_One; + + elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then + return 1.0 + Right; + + elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then + return Left; + + else + return Exp (Right * Log (Left)); + end if; + end "**"; + + function "**" (Left : Real'Base; Right : Complex) return Complex is + begin + if Re (Right) = 0.0 and then Im (Right) = 0.0 and then Left = 0.0 then + raise Argument_Error; + + elsif Left = 0.0 and then Re (Right) < 0.0 then + raise Constraint_Error; + + elsif Left = 0.0 then + return Compose_From_Cartesian (Left, 0.0); + + elsif Re (Right) = 0.0 and then Im (Right) = 0.0 then + return Complex_One; + + elsif Re (Right) = 1.0 and then Im (Right) = 0.0 then + return Compose_From_Cartesian (Left, 0.0); + + else + return Exp (Log (Left) * Right); + end if; + end "**"; + + function "**" (Left : Complex; Right : Real'Base) return Complex is + begin + if Right = 0.0 + and then Re (Left) = 0.0 + and then Im (Left) = 0.0 + then + raise Argument_Error; + + elsif Re (Left) = 0.0 + and then Im (Left) = 0.0 + and then Right < 0.0 + then + raise Constraint_Error; + + elsif Re (Left) = 0.0 and then Im (Left) = 0.0 then + return Left; + + elsif Right = 0.0 then + return Complex_One; + + elsif Right = 1.0 then + return Left; + + else + return Exp (Right * Log (Left)); + end if; + end "**"; + + ------------ + -- Arccos -- + ------------ + + function Arccos (X : Complex) return Complex is + Result : Complex; + + begin + if X = Complex_One then + return Complex_Zero; + + elsif abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Half_Pi - X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + return -2.0 * Complex_I * Log (Sqrt ((1.0 + X) / 2.0) + + Complex_I * Sqrt ((1.0 - X) / 2.0)); + end if; + + Result := -Complex_I * Log (X + Complex_I * Sqrt (1.0 - X * X)); + + if Im (X) = 0.0 + and then abs Re (X) <= 1.00 + then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arccos; + + ------------- + -- Arccosh -- + ------------- + + function Arccosh (X : Complex) return Complex is + Result : Complex; + + begin + if X = Complex_One then + return Complex_Zero; + + elsif abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + Result := Compose_From_Cartesian (-Im (X), -PI_2 + Re (X)); + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := Log_Two + Log (X); + + else + Result := 2.0 * Log (Sqrt ((1.0 + X) / 2.0) + + Sqrt ((X - 1.0) / 2.0)); + end if; + + if Re (Result) <= 0.0 then + Result := -Result; + end if; + + return Result; + end Arccosh; + + ------------ + -- Arccot -- + ------------ + + function Arccot (X : Complex) return Complex is + Xt : Complex; + + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Half_Pi - X; + + elsif abs Re (X) > 1.0 / Epsilon or else + abs Im (X) > 1.0 / Epsilon + then + Xt := Complex_One / X; + + if Re (X) < 0.0 then + Set_Re (Xt, PI - Re (Xt)); + return Xt; + else + return Xt; + end if; + end if; + + Xt := Complex_I * Log ((X - Complex_I) / (X + Complex_I)) / 2.0; + + if Re (Xt) < 0.0 then + Xt := PI + Xt; + end if; + + return Xt; + end Arccot; + + -------------- + -- Arccoth -- + -------------- + + function Arccoth (X : Complex) return Complex is + R : Complex; + + begin + if X = (0.0, 0.0) then + return Compose_From_Cartesian (0.0, PI_2); + + elsif abs Re (X) < Square_Root_Epsilon + and then abs Im (X) < Square_Root_Epsilon + then + return PI_2 * Complex_I + X; + + elsif abs Re (X) > 1.0 / Epsilon or else + abs Im (X) > 1.0 / Epsilon + then + if Im (X) > 0.0 then + return (0.0, 0.0); + else + return PI * Complex_I; + end if; + + elsif Im (X) = 0.0 and then Re (X) = 1.0 then + raise Constraint_Error; + + elsif Im (X) = 0.0 and then Re (X) = -1.0 then + raise Constraint_Error; + end if; + + begin + R := Log ((1.0 + X) / (X - 1.0)) / 2.0; + + exception + when Constraint_Error => + R := (Log (1.0 + X) - Log (X - 1.0)) / 2.0; + end; + + if Im (R) < 0.0 then + Set_Im (R, PI + Im (R)); + end if; + + if Re (X) = 0.0 then + Set_Re (R, Re (X)); + end if; + + return R; + end Arccoth; + + ------------ + -- Arcsin -- + ------------ + + function Arcsin (X : Complex) return Complex is + Result : Complex; + + begin + -- For very small argument, sin (x) = x + + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := -Complex_I * (Log (Complex_I * X) + Log (2.0 * Complex_I)); + + if Im (Result) > PI_2 then + Set_Im (Result, PI - Im (X)); + + elsif Im (Result) < -PI_2 then + Set_Im (Result, -(PI + Im (X))); + end if; + + return Result; + end if; + + Result := -Complex_I * Log (Complex_I * X + Sqrt (1.0 - X * X)); + + if Re (X) = 0.0 then + Set_Re (Result, Re (X)); + + elsif Im (X) = 0.0 + and then abs Re (X) <= 1.00 + then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arcsin; + + ------------- + -- Arcsinh -- + ------------- + + function Arcsinh (X : Complex) return Complex is + Result : Complex; + + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif abs Re (X) > Inv_Square_Root_Epsilon or else + abs Im (X) > Inv_Square_Root_Epsilon + then + Result := Log_Two + Log (X); -- may have wrong sign + + if (Re (X) < 0.0 and then Re (Result) > 0.0) + or else (Re (X) > 0.0 and then Re (Result) < 0.0) + then + Set_Re (Result, -Re (Result)); + end if; + + return Result; + end if; + + Result := Log (X + Sqrt (1.0 + X * X)); + + if Re (X) = 0.0 then + Set_Re (Result, Re (X)); + elsif Im (X) = 0.0 then + Set_Im (Result, Im (X)); + end if; + + return Result; + end Arcsinh; + + ------------ + -- Arctan -- + ------------ + + function Arctan (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + else + return -Complex_I * (Log (1.0 + Complex_I * X) + - Log (1.0 - Complex_I * X)) / 2.0; + end if; + end Arctan; + + ------------- + -- Arctanh -- + ------------- + + function Arctanh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + else + return (Log (1.0 + X) - Log (1.0 - X)) / 2.0; + end if; + end Arctanh; + + --------- + -- Cos -- + --------- + + function Cos (X : Complex) return Complex is + begin + return + Compose_From_Cartesian + (Cos (Re (X)) * Cosh (Im (X)), + -(Sin (Re (X)) * Sinh (Im (X)))); + end Cos; + + ---------- + -- Cosh -- + ---------- + + function Cosh (X : Complex) return Complex is + begin + return + Compose_From_Cartesian + (Cosh (Re (X)) * Cos (Im (X)), + Sinh (Re (X)) * Sin (Im (X))); + end Cosh; + + --------- + -- Cot -- + --------- + + function Cot (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Complex_One / X; + + elsif Im (X) > Log_Inverse_Epsilon_2 then + return -Complex_I; + + elsif Im (X) < -Log_Inverse_Epsilon_2 then + return Complex_I; + end if; + + return Cos (X) / Sin (X); + end Cot; + + ---------- + -- Coth -- + ---------- + + function Coth (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return Complex_One / X; + + elsif Re (X) > Log_Inverse_Epsilon_2 then + return Complex_One; + + elsif Re (X) < -Log_Inverse_Epsilon_2 then + return -Complex_One; + + else + return Cosh (X) / Sinh (X); + end if; + end Coth; + + --------- + -- Exp -- + --------- + + function Exp (X : Complex) return Complex is + EXP_RE_X : constant Real'Base := Exp (Re (X)); + + begin + return Compose_From_Cartesian (EXP_RE_X * Cos (Im (X)), + EXP_RE_X * Sin (Im (X))); + end Exp; + + function Exp (X : Imaginary) return Complex is + ImX : constant Real'Base := Im (X); + + begin + return Compose_From_Cartesian (Cos (ImX), Sin (ImX)); + end Exp; + + --------- + -- Log -- + --------- + + function Log (X : Complex) return Complex is + ReX : Real'Base; + ImX : Real'Base; + Z : Complex; + + begin + if Re (X) = 0.0 and then Im (X) = 0.0 then + raise Constraint_Error; + + elsif abs (1.0 - Re (X)) < Root_Root_Epsilon + and then abs Im (X) < Root_Root_Epsilon + then + Z := X; + Set_Re (Z, Re (Z) - 1.0); + + return (1.0 - (1.0 / 2.0 - + (1.0 / 3.0 - (1.0 / 4.0) * Z) * Z) * Z) * Z; + end if; + + begin + ReX := Log (Modulus (X)); + + exception + when Constraint_Error => + ReX := Log (Modulus (X / 2.0)) - Log_Two; + end; + + ImX := Arctan (Im (X), Re (X)); + + if ImX > PI then + ImX := ImX - 2.0 * PI; + end if; + + return Compose_From_Cartesian (ReX, ImX); + end Log; + + --------- + -- Sin -- + --------- + + function Sin (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon + and then + abs Im (X) < Square_Root_Epsilon + then + return X; + end if; + + return + Compose_From_Cartesian + (Sin (Re (X)) * Cosh (Im (X)), + Cos (Re (X)) * Sinh (Im (X))); + end Sin; + + ---------- + -- Sinh -- + ---------- + + function Sinh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + else + return Compose_From_Cartesian (Sinh (Re (X)) * Cos (Im (X)), + Cosh (Re (X)) * Sin (Im (X))); + end if; + end Sinh; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Complex) return Complex is + ReX : constant Real'Base := Re (X); + ImX : constant Real'Base := Im (X); + XR : constant Real'Base := abs Re (X); + YR : constant Real'Base := abs Im (X); + R : Real'Base; + R_X : Real'Base; + R_Y : Real'Base; + + begin + -- Deal with pure real case, see (RM G.1.2(39)) + + if ImX = 0.0 then + if ReX > 0.0 then + return + Compose_From_Cartesian + (Sqrt (ReX), 0.0); + + elsif ReX = 0.0 then + return X; + + else + return + Compose_From_Cartesian + (0.0, Real'Copy_Sign (Sqrt (-ReX), ImX)); + end if; + + elsif ReX = 0.0 then + R_X := Sqrt (YR / 2.0); + + if ImX > 0.0 then + return Compose_From_Cartesian (R_X, R_X); + else + return Compose_From_Cartesian (R_X, -R_X); + end if; + + else + R := Sqrt (XR ** 2 + YR ** 2); + + -- If the square of the modulus overflows, try rescaling the + -- real and imaginary parts. We cannot depend on an exception + -- being raised on all targets. + + if R > Real'Base'Last then + raise Constraint_Error; + end if; + + -- We are solving the system + + -- XR = R_X ** 2 - Y_R ** 2 (1) + -- YR = 2.0 * R_X * R_Y (2) + -- + -- The symmetric solution involves square roots for both R_X and + -- R_Y, but it is more accurate to use the square root with the + -- larger argument for either R_X or R_Y, and equation (2) for the + -- other. + + if ReX < 0.0 then + R_Y := Sqrt (0.5 * (R - ReX)); + R_X := YR / (2.0 * R_Y); + + else + R_X := Sqrt (0.5 * (R + ReX)); + R_Y := YR / (2.0 * R_X); + end if; + end if; + + if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude + R_Y := -R_Y; + end if; + return Compose_From_Cartesian (R_X, R_Y); + + exception + when Constraint_Error => + + -- Rescale and try again + + R := Modulus (Compose_From_Cartesian (Re (X / 4.0), Im (X / 4.0))); + R_X := 2.0 * Sqrt (0.5 * R + 0.5 * Re (X / 4.0)); + R_Y := 2.0 * Sqrt (0.5 * R - 0.5 * Re (X / 4.0)); + + if Im (X) < 0.0 then -- halve angle, Sqrt of magnitude + R_Y := -R_Y; + end if; + + return Compose_From_Cartesian (R_X, R_Y); + end Sqrt; + + --------- + -- Tan -- + --------- + + function Tan (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif Im (X) > Log_Inverse_Epsilon_2 then + return Complex_I; + + elsif Im (X) < -Log_Inverse_Epsilon_2 then + return -Complex_I; + + else + return Sin (X) / Cos (X); + end if; + end Tan; + + ---------- + -- Tanh -- + ---------- + + function Tanh (X : Complex) return Complex is + begin + if abs Re (X) < Square_Root_Epsilon and then + abs Im (X) < Square_Root_Epsilon + then + return X; + + elsif Re (X) > Log_Inverse_Epsilon_2 then + return Complex_One; + + elsif Re (X) < -Log_Inverse_Epsilon_2 then + return -Complex_One; + + else + return Sinh (X) / Cosh (X); + end if; + end Tanh; + +end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/libgnat/a-ngcefu.ads b/gcc/ada/libgnat/a-ngcefu.ads new file mode 100644 index 0000000..576c84a --- /dev/null +++ b/gcc/ada/libgnat/a-ngcefu.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + use Complex_Types; + +package Ada.Numerics.Generic_Complex_Elementary_Functions is + pragma Pure; + + function Sqrt (X : Complex) return Complex; + + function Log (X : Complex) return Complex; + + function Exp (X : Complex) return Complex; + function Exp (X : Imaginary) return Complex; + + function "**" (Left : Complex; Right : Complex) return Complex; + function "**" (Left : Complex; Right : Real'Base) return Complex; + function "**" (Left : Real'Base; Right : Complex) return Complex; + + function Sin (X : Complex) return Complex; + function Cos (X : Complex) return Complex; + function Tan (X : Complex) return Complex; + function Cot (X : Complex) return Complex; + + function Arcsin (X : Complex) return Complex; + function Arccos (X : Complex) return Complex; + function Arctan (X : Complex) return Complex; + function Arccot (X : Complex) return Complex; + + function Sinh (X : Complex) return Complex; + function Cosh (X : Complex) return Complex; + function Tanh (X : Complex) return Complex; + function Coth (X : Complex) return Complex; + + function Arcsinh (X : Complex) return Complex; + function Arccosh (X : Complex) return Complex; + function Arctanh (X : Complex) return Complex; + function Arccoth (X : Complex) return Complex; + +end Ada.Numerics.Generic_Complex_Elementary_Functions; diff --git a/gcc/ada/libgnat/a-ngcoar.adb b/gcc/ada/libgnat/a-ngcoar.adb new file mode 100644 index 0000000..cf01dcd --- /dev/null +++ b/gcc/ada/libgnat/a-ngcoar.adb @@ -0,0 +1,1255 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ARRAYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Generic_Array_Operations; use System.Generic_Array_Operations; + +package body Ada.Numerics.Generic_Complex_Arrays is + + -- Operations that are defined in terms of operations on the type Real, + -- such as addition, subtraction and scaling, are computed in the canonical + -- way looping over all elements. + + package Ops renames System.Generic_Array_Operations; + + subtype Real is Real_Arrays.Real; + -- Work around visibility bug ??? + + function Is_Non_Zero (X : Complex) return Boolean is (X /= (0.0, 0.0)); + -- Needed by Back_Substitute + + procedure Back_Substitute is new Ops.Back_Substitute + (Scalar => Complex, + Matrix => Complex_Matrix, + Is_Non_Zero => Is_Non_Zero); + + procedure Forward_Eliminate is new Ops.Forward_Eliminate + (Scalar => Complex, + Real => Real'Base, + Matrix => Complex_Matrix, + Zero => (0.0, 0.0), + One => (1.0, 0.0)); + + procedure Transpose is new Ops.Transpose + (Scalar => Complex, + Matrix => Complex_Matrix); + + -- Helper function that raises a Constraint_Error is the argument is + -- not a square matrix, and otherwise returns its length. + + function Length is new Square_Matrix_Length (Complex, Complex_Matrix); + + -- Instant a generic square root implementation here, in order to avoid + -- instantiating a complete copy of Generic_Elementary_Functions. + -- Speed of the square root is not a big concern here. + + function Sqrt is new Ops.Sqrt (Real'Base); + + -- Instantiating the following subprograms directly would lead to + -- name clashes, so use a local package. + + package Instantiations is + + --------- + -- "*" -- + --------- + + function "*" is new Vector_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "*"); + + function "*" is new Vector_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "*"); + + function "*" is new Scalar_Vector_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "*"); + + function "*" is new Scalar_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "*"); + + function "*" is new Inner_Product + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Real_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Inner_Product + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Real_Vector, + Right_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Inner_Product + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Outer_Product + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Complex_Vector, + Matrix => Complex_Matrix); + + function "*" is new Outer_Product + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Real_Vector, + Right_Vector => Complex_Vector, + Matrix => Complex_Matrix); + + function "*" is new Outer_Product + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Real_Vector, + Matrix => Complex_Matrix); + + function "*" is new Matrix_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "*"); + + function "*" is new Matrix_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "*"); + + function "*" is new Scalar_Matrix_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "*"); + + function "*" is new Scalar_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "*"); + + function "*" is new Matrix_Vector_Product + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Matrix => Real_Matrix, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Matrix_Vector_Product + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Matrix => Complex_Matrix, + Right_Vector => Real_Vector, + Result_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Matrix_Vector_Product + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Matrix => Complex_Matrix, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Vector_Matrix_Product + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Real_Vector, + Matrix => Complex_Matrix, + Result_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Vector_Matrix_Product + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Matrix => Real_Matrix, + Result_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Vector_Matrix_Product + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Matrix => Complex_Matrix, + Result_Vector => Complex_Vector, + Zero => (0.0, 0.0)); + + function "*" is new Matrix_Matrix_Product + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Zero => (0.0, 0.0)); + + function "*" is new Matrix_Matrix_Product + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Real_Matrix, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Zero => (0.0, 0.0)); + + function "*" is new Matrix_Matrix_Product + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Complex_Matrix, + Zero => (0.0, 0.0)); + + --------- + -- "+" -- + --------- + + function "+" is new Vector_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Complex, + X_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "+"); + + function "+" is new Vector_Vector_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "+"); + + function "+" is new Vector_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Real_Vector, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "+"); + + function "+" is new Vector_Vector_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Real_Vector, + Result_Vector => Complex_Vector, + Operation => "+"); + + function "+" is new Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Complex, + X_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "+"); + + function "+" is new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "+"); + + function "+" is new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Real_Matrix, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "+"); + + function "+" is new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "+"); + + --------- + -- "-" -- + --------- + + function "-" is new Vector_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Complex, + X_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "-"); + + function "-" is new Vector_Vector_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "-"); + + function "-" is new Vector_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Real_Vector, + Right_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "-"); + + function "-" is new Vector_Vector_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Right_Vector => Real_Vector, + Result_Vector => Complex_Vector, + Operation => "-"); + + function "-" is new Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Complex, + X_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "-"); + + function "-" is new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "-"); + + function "-" is new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Real_Matrix, + Right_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "-"); + + function "-" is new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "-"); + + --------- + -- "/" -- + --------- + + function "/" is new Vector_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "/"); + + function "/" is new Vector_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => "/"); + + function "/" is new Matrix_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Complex, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "/"); + + function "/" is new Matrix_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => "/"); + + ----------- + -- "abs" -- + ----------- + + function "abs" is new L2_Norm + (X_Scalar => Complex, + Result_Real => Real'Base, + X_Vector => Complex_Vector); + + -------------- + -- Argument -- + -------------- + + function Argument is new Vector_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Vector => Complex_Vector, + Result_Vector => Real_Vector, + Operation => Argument); + + function Argument is new Vector_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Complex_Vector, + Result_Vector => Real_Vector, + Operation => Argument); + + function Argument is new Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Matrix => Complex_Matrix, + Result_Matrix => Real_Matrix, + Operation => Argument); + + function Argument is new Matrix_Scalar_Elementwise_Operation + (Left_Scalar => Complex, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Matrix => Complex_Matrix, + Result_Matrix => Real_Matrix, + Operation => Argument); + + ---------------------------- + -- Compose_From_Cartesian -- + ---------------------------- + + function Compose_From_Cartesian is new Vector_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Complex, + X_Vector => Real_Vector, + Result_Vector => Complex_Vector, + Operation => Compose_From_Cartesian); + + function Compose_From_Cartesian is + new Vector_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Real_Vector, + Right_Vector => Real_Vector, + Result_Vector => Complex_Vector, + Operation => Compose_From_Cartesian); + + function Compose_From_Cartesian is new Matrix_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Complex, + X_Matrix => Real_Matrix, + Result_Matrix => Complex_Matrix, + Operation => Compose_From_Cartesian); + + function Compose_From_Cartesian is + new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Matrix => Real_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Complex_Matrix, + Operation => Compose_From_Cartesian); + + ------------------------ + -- Compose_From_Polar -- + ------------------------ + + function Compose_From_Polar is + new Vector_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Vector => Real_Vector, + Right_Vector => Real_Vector, + Result_Vector => Complex_Vector, + Operation => Compose_From_Polar); + + function Compose_From_Polar is + new Vector_Vector_Scalar_Elementwise_Operation + (X_Scalar => Real'Base, + Y_Scalar => Real'Base, + Z_Scalar => Real'Base, + Result_Scalar => Complex, + X_Vector => Real_Vector, + Y_Vector => Real_Vector, + Result_Vector => Complex_Vector, + Operation => Compose_From_Polar); + + function Compose_From_Polar is + new Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Complex, + Left_Matrix => Real_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Complex_Matrix, + Operation => Compose_From_Polar); + + function Compose_From_Polar is + new Matrix_Matrix_Scalar_Elementwise_Operation + (X_Scalar => Real'Base, + Y_Scalar => Real'Base, + Z_Scalar => Real'Base, + Result_Scalar => Complex, + X_Matrix => Real_Matrix, + Y_Matrix => Real_Matrix, + Result_Matrix => Complex_Matrix, + Operation => Compose_From_Polar); + + --------------- + -- Conjugate -- + --------------- + + function Conjugate is new Vector_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Complex, + X_Vector => Complex_Vector, + Result_Vector => Complex_Vector, + Operation => Conjugate); + + function Conjugate is new Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Complex, + X_Matrix => Complex_Matrix, + Result_Matrix => Complex_Matrix, + Operation => Conjugate); + + -------- + -- Im -- + -------- + + function Im is new Vector_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Vector => Complex_Vector, + Result_Vector => Real_Vector, + Operation => Im); + + function Im is new Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Matrix => Complex_Matrix, + Result_Matrix => Real_Matrix, + Operation => Im); + + ------------- + -- Modulus -- + ------------- + + function Modulus is new Vector_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Vector => Complex_Vector, + Result_Vector => Real_Vector, + Operation => Modulus); + + function Modulus is new Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Matrix => Complex_Matrix, + Result_Matrix => Real_Matrix, + Operation => Modulus); + + -------- + -- Re -- + -------- + + function Re is new Vector_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Vector => Complex_Vector, + Result_Vector => Real_Vector, + Operation => Re); + + function Re is new Matrix_Elementwise_Operation + (X_Scalar => Complex, + Result_Scalar => Real'Base, + X_Matrix => Complex_Matrix, + Result_Matrix => Real_Matrix, + Operation => Re); + + ------------ + -- Set_Im -- + ------------ + + procedure Set_Im is new Update_Vector_With_Vector + (X_Scalar => Complex, + Y_Scalar => Real'Base, + X_Vector => Complex_Vector, + Y_Vector => Real_Vector, + Update => Set_Im); + + procedure Set_Im is new Update_Matrix_With_Matrix + (X_Scalar => Complex, + Y_Scalar => Real'Base, + X_Matrix => Complex_Matrix, + Y_Matrix => Real_Matrix, + Update => Set_Im); + + ------------ + -- Set_Re -- + ------------ + + procedure Set_Re is new Update_Vector_With_Vector + (X_Scalar => Complex, + Y_Scalar => Real'Base, + X_Vector => Complex_Vector, + Y_Vector => Real_Vector, + Update => Set_Re); + + procedure Set_Re is new Update_Matrix_With_Matrix + (X_Scalar => Complex, + Y_Scalar => Real'Base, + X_Matrix => Complex_Matrix, + Y_Matrix => Real_Matrix, + Update => Set_Re); + + ----------- + -- Solve -- + ----------- + + function Solve is new Matrix_Vector_Solution + (Complex, (0.0, 0.0), Complex_Vector, Complex_Matrix); + + function Solve is new Matrix_Matrix_Solution + (Complex, (0.0, 0.0), Complex_Matrix); + + ----------------- + -- Unit_Matrix -- + ----------------- + + function Unit_Matrix is new System.Generic_Array_Operations.Unit_Matrix + (Scalar => Complex, + Matrix => Complex_Matrix, + Zero => (0.0, 0.0), + One => (1.0, 0.0)); + + function Unit_Vector is new System.Generic_Array_Operations.Unit_Vector + (Scalar => Complex, + Vector => Complex_Vector, + Zero => (0.0, 0.0), + One => (1.0, 0.0)); + end Instantiations; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Complex_Vector; + Right : Complex_Vector) return Complex + renames Instantiations."*"; + + function "*" + (Left : Real_Vector; + Right : Complex_Vector) return Complex + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Real_Vector) return Complex + renames Instantiations."*"; + + function "*" + (Left : Complex; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Complex) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Real'Base; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Real'Base) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Complex_Matrix; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Complex_Vector) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Complex_Matrix) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Complex_Matrix; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Real_Vector; + Right : Complex_Matrix) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Complex_Vector; + Right : Real_Matrix) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Real_Matrix; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Complex_Matrix; + Right : Real_Vector) return Complex_Vector + renames Instantiations."*"; + + function "*" + (Left : Complex; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Complex_Matrix; + Right : Complex) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Real'Base; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."*"; + + function "*" + (Left : Complex_Matrix; + Right : Real'Base) return Complex_Matrix + renames Instantiations."*"; + + --------- + -- "+" -- + --------- + + function "+" (Right : Complex_Vector) return Complex_Vector + renames Instantiations."+"; + + function "+" + (Left : Complex_Vector; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."+"; + + function "+" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."+"; + + function "+" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Vector + renames Instantiations."+"; + + function "+" (Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."+"; + + function "+" + (Left : Complex_Matrix; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."+"; + + function "+" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."+"; + + function "+" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix + renames Instantiations."+"; + + --------- + -- "-" -- + --------- + + function "-" + (Right : Complex_Vector) return Complex_Vector + renames Instantiations."-"; + + function "-" + (Left : Complex_Vector; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."-"; + + function "-" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Vector + renames Instantiations."-"; + + function "-" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Vector + renames Instantiations."-"; + + function "-" (Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."-"; + + function "-" + (Left : Complex_Matrix; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."-"; + + function "-" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix + renames Instantiations."-"; + + function "-" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix + renames Instantiations."-"; + + --------- + -- "/" -- + --------- + + function "/" + (Left : Complex_Vector; + Right : Complex) return Complex_Vector + renames Instantiations."/"; + + function "/" + (Left : Complex_Vector; + Right : Real'Base) return Complex_Vector + renames Instantiations."/"; + + function "/" + (Left : Complex_Matrix; + Right : Complex) return Complex_Matrix + renames Instantiations."/"; + + function "/" + (Left : Complex_Matrix; + Right : Real'Base) return Complex_Matrix + renames Instantiations."/"; + + ----------- + -- "abs" -- + ----------- + + function "abs" (Right : Complex_Vector) return Real'Base + renames Instantiations."abs"; + + -------------- + -- Argument -- + -------------- + + function Argument (X : Complex_Vector) return Real_Vector + renames Instantiations.Argument; + + function Argument + (X : Complex_Vector; + Cycle : Real'Base) return Real_Vector + renames Instantiations.Argument; + + function Argument (X : Complex_Matrix) return Real_Matrix + renames Instantiations.Argument; + + function Argument + (X : Complex_Matrix; + Cycle : Real'Base) return Real_Matrix + renames Instantiations.Argument; + + ---------------------------- + -- Compose_From_Cartesian -- + ---------------------------- + + function Compose_From_Cartesian (Re : Real_Vector) return Complex_Vector + renames Instantiations.Compose_From_Cartesian; + + function Compose_From_Cartesian + (Re : Real_Vector; + Im : Real_Vector) return Complex_Vector + renames Instantiations.Compose_From_Cartesian; + + function Compose_From_Cartesian (Re : Real_Matrix) return Complex_Matrix + renames Instantiations.Compose_From_Cartesian; + + function Compose_From_Cartesian + (Re : Real_Matrix; + Im : Real_Matrix) return Complex_Matrix + renames Instantiations.Compose_From_Cartesian; + + ------------------------ + -- Compose_From_Polar -- + ------------------------ + + function Compose_From_Polar + (Modulus : Real_Vector; + Argument : Real_Vector) return Complex_Vector + renames Instantiations.Compose_From_Polar; + + function Compose_From_Polar + (Modulus : Real_Vector; + Argument : Real_Vector; + Cycle : Real'Base) return Complex_Vector + renames Instantiations.Compose_From_Polar; + + function Compose_From_Polar + (Modulus : Real_Matrix; + Argument : Real_Matrix) return Complex_Matrix + renames Instantiations.Compose_From_Polar; + + function Compose_From_Polar + (Modulus : Real_Matrix; + Argument : Real_Matrix; + Cycle : Real'Base) return Complex_Matrix + renames Instantiations.Compose_From_Polar; + + --------------- + -- Conjugate -- + --------------- + + function Conjugate (X : Complex_Vector) return Complex_Vector + renames Instantiations.Conjugate; + + function Conjugate (X : Complex_Matrix) return Complex_Matrix + renames Instantiations.Conjugate; + + ----------------- + -- Determinant -- + ----------------- + + function Determinant (A : Complex_Matrix) return Complex is + M : Complex_Matrix := A; + B : Complex_Matrix (A'Range (1), 1 .. 0); + R : Complex; + begin + Forward_Eliminate (M, B, R); + return R; + end Determinant; + + ----------------- + -- Eigensystem -- + ----------------- + + procedure Eigensystem + (A : Complex_Matrix; + Values : out Real_Vector; + Vectors : out Complex_Matrix) + is + N : constant Natural := Length (A); + + -- For a Hermitian matrix C, we convert the eigenvalue problem to a + -- real symmetric one: if C = A + i * B, then the (N, N) complex + -- eigenvalue problem: + -- (A + i * B) * (u + i * v) = Lambda * (u + i * v) + -- + -- is equivalent to the (2 * N, 2 * N) real eigenvalue problem: + -- [ A, B ] [ u ] = Lambda * [ u ] + -- [ -B, A ] [ v ] [ v ] + -- + -- Note that the (2 * N, 2 * N) matrix above is symmetric, as + -- Transpose (A) = A and Transpose (B) = -B if C is Hermitian. + + -- We solve this eigensystem using the real-valued algorithms. The final + -- result will have every eigenvalue twice, so in the sorted output we + -- just pick every second value, with associated eigenvector u + i * v. + + M : Real_Matrix (1 .. 2 * N, 1 .. 2 * N); + Vals : Real_Vector (1 .. 2 * N); + Vecs : Real_Matrix (1 .. 2 * N, 1 .. 2 * N); + + begin + for J in 1 .. N loop + for K in 1 .. N loop + declare + C : constant Complex := + (A (A'First (1) + (J - 1), A'First (2) + (K - 1))); + begin + M (J, K) := Re (C); + M (J + N, K + N) := Re (C); + M (J + N, K) := Im (C); + M (J, K + N) := -Im (C); + end; + end loop; + end loop; + + Eigensystem (M, Vals, Vecs); + + for J in 1 .. N loop + declare + Col : constant Integer := Values'First + (J - 1); + begin + Values (Col) := Vals (2 * J); + + for K in 1 .. N loop + declare + Row : constant Integer := Vectors'First (2) + (K - 1); + begin + Vectors (Row, Col) + := (Vecs (J * 2, Col), Vecs (J * 2, Col + N)); + end; + end loop; + end; + end loop; + end Eigensystem; + + ----------------- + -- Eigenvalues -- + ----------------- + + function Eigenvalues (A : Complex_Matrix) return Real_Vector is + -- See Eigensystem for a description of the algorithm + + N : constant Natural := Length (A); + R : Real_Vector (A'Range (1)); + + M : Real_Matrix (1 .. 2 * N, 1 .. 2 * N); + Vals : Real_Vector (1 .. 2 * N); + begin + for J in 1 .. N loop + for K in 1 .. N loop + declare + C : constant Complex := + (A (A'First (1) + (J - 1), A'First (2) + (K - 1))); + begin + M (J, K) := Re (C); + M (J + N, K + N) := Re (C); + M (J + N, K) := Im (C); + M (J, K + N) := -Im (C); + end; + end loop; + end loop; + + Vals := Eigenvalues (M); + + for J in 1 .. N loop + R (A'First (1) + (J - 1)) := Vals (2 * J); + end loop; + + return R; + end Eigenvalues; + + -------- + -- Im -- + -------- + + function Im (X : Complex_Vector) return Real_Vector + renames Instantiations.Im; + + function Im (X : Complex_Matrix) return Real_Matrix + renames Instantiations.Im; + + ------------- + -- Inverse -- + ------------- + + function Inverse (A : Complex_Matrix) return Complex_Matrix is + (Solve (A, Unit_Matrix (Length (A), + First_1 => A'First (2), + First_2 => A'First (1)))); + + ------------- + -- Modulus -- + ------------- + + function Modulus (X : Complex_Vector) return Real_Vector + renames Instantiations.Modulus; + + function Modulus (X : Complex_Matrix) return Real_Matrix + renames Instantiations.Modulus; + + -------- + -- Re -- + -------- + + function Re (X : Complex_Vector) return Real_Vector + renames Instantiations.Re; + + function Re (X : Complex_Matrix) return Real_Matrix + renames Instantiations.Re; + + ------------ + -- Set_Im -- + ------------ + + procedure Set_Im + (X : in out Complex_Matrix; + Im : Real_Matrix) + renames Instantiations.Set_Im; + + procedure Set_Im + (X : in out Complex_Vector; + Im : Real_Vector) + renames Instantiations.Set_Im; + + ------------ + -- Set_Re -- + ------------ + + procedure Set_Re + (X : in out Complex_Matrix; + Re : Real_Matrix) + renames Instantiations.Set_Re; + + procedure Set_Re + (X : in out Complex_Vector; + Re : Real_Vector) + renames Instantiations.Set_Re; + + ----------- + -- Solve -- + ----------- + + function Solve + (A : Complex_Matrix; + X : Complex_Vector) return Complex_Vector + renames Instantiations.Solve; + + function Solve + (A : Complex_Matrix; + X : Complex_Matrix) return Complex_Matrix + renames Instantiations.Solve; + + --------------- + -- Transpose -- + --------------- + + function Transpose + (X : Complex_Matrix) return Complex_Matrix + is + R : Complex_Matrix (X'Range (2), X'Range (1)); + begin + Transpose (X, R); + return R; + end Transpose; + + ----------------- + -- Unit_Matrix -- + ----------------- + + function Unit_Matrix + (Order : Positive; + First_1 : Integer := 1; + First_2 : Integer := 1) return Complex_Matrix + renames Instantiations.Unit_Matrix; + + ----------------- + -- Unit_Vector -- + ----------------- + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Complex_Vector + renames Instantiations.Unit_Vector; + +end Ada.Numerics.Generic_Complex_Arrays; diff --git a/gcc/ada/libgnat/a-ngcoar.ads b/gcc/ada/libgnat/a-ngcoar.ads new file mode 100644 index 0000000..8f8f37a --- /dev/null +++ b/gcc/ada/libgnat/a-ngcoar.ads @@ -0,0 +1,281 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_COMPLEX_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays, Ada.Numerics.Generic_Complex_Types; + +generic + with package Real_Arrays is new Ada.Numerics.Generic_Real_Arrays (<>); + use Real_Arrays; + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; +package Ada.Numerics.Generic_Complex_Arrays is + pragma Pure (Generic_Complex_Arrays); + + -- Types + + type Complex_Vector is array (Integer range <>) of Complex; + type Complex_Matrix is + array (Integer range <>, Integer range <>) of Complex; + + -- Subprograms for Complex_Vector types + -- Complex_Vector selection, conversion and composition operations + + function Re (X : Complex_Vector) return Real_Vector; + function Im (X : Complex_Vector) return Real_Vector; + + procedure Set_Re (X : in out Complex_Vector; Re : Real_Vector); + procedure Set_Im (X : in out Complex_Vector; Im : Real_Vector); + + function Compose_From_Cartesian + (Re : Real_Vector) return Complex_Vector; + function Compose_From_Cartesian + (Re, Im : Real_Vector) return Complex_Vector; + + function Modulus (X : Complex_Vector) return Real_Vector; + function "abs" (Right : Complex_Vector) return Real_Vector renames Modulus; + function Argument (X : Complex_Vector) return Real_Vector; + + function Argument + (X : Complex_Vector; + Cycle : Real'Base) return Real_Vector; + + function Compose_From_Polar + (Modulus, Argument : Real_Vector) return Complex_Vector; + + function Compose_From_Polar + (Modulus, Argument : Real_Vector; + Cycle : Real'Base) return Complex_Vector; + + -- Complex_Vector arithmetic operations + + function "+" (Right : Complex_Vector) return Complex_Vector; + function "-" (Right : Complex_Vector) return Complex_Vector; + function Conjugate (X : Complex_Vector) return Complex_Vector; + function "+" (Left, Right : Complex_Vector) return Complex_Vector; + function "-" (Left, Right : Complex_Vector) return Complex_Vector; + function "*" (Left, Right : Complex_Vector) return Complex; + function "abs" (Right : Complex_Vector) return Real'Base; + + -- Mixed Real_Vector and Complex_Vector arithmetic operations + + function "+" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Vector; + + function "+" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Vector; + + function "-" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Vector; + + function "-" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Vector; + + function "*" (Left : Real_Vector; Right : Complex_Vector) return Complex; + function "*" (Left : Complex_Vector; Right : Real_Vector) return Complex; + + -- Complex_Vector scaling operations + + function "*" + (Left : Complex; + Right : Complex_Vector) return Complex_Vector; + + function "*" + (Left : Complex_Vector; + Right : Complex) return Complex_Vector; + + function "/" + (Left : Complex_Vector; + Right : Complex) return Complex_Vector; + + function "*" + (Left : Real'Base; + Right : Complex_Vector) return Complex_Vector; + + function "*" + (Left : Complex_Vector; + Right : Real'Base) return Complex_Vector; + + function "/" + (Left : Complex_Vector; + Right : Real'Base) return Complex_Vector; + + -- Other Complex_Vector operations + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Complex_Vector; + + -- Subprograms for Complex_Matrix types + + -- Complex_Matrix selection, conversion and composition operations + + function Re (X : Complex_Matrix) return Real_Matrix; + function Im (X : Complex_Matrix) return Real_Matrix; + + procedure Set_Re (X : in out Complex_Matrix; Re : Real_Matrix); + procedure Set_Im (X : in out Complex_Matrix; Im : Real_Matrix); + + function Compose_From_Cartesian (Re : Real_Matrix) return Complex_Matrix; + + function Compose_From_Cartesian + (Re, Im : Real_Matrix) return Complex_Matrix; + + function Modulus (X : Complex_Matrix) return Real_Matrix; + function "abs" (Right : Complex_Matrix) return Real_Matrix renames Modulus; + + function Argument (X : Complex_Matrix) return Real_Matrix; + + function Argument + (X : Complex_Matrix; + Cycle : Real'Base) return Real_Matrix; + + function Compose_From_Polar + (Modulus, Argument : Real_Matrix) return Complex_Matrix; + + function Compose_From_Polar + (Modulus : Real_Matrix; + Argument : Real_Matrix; + Cycle : Real'Base) return Complex_Matrix; + + -- Complex_Matrix arithmetic operations + + function "+" (Right : Complex_Matrix) return Complex_Matrix; + function "-" (Right : Complex_Matrix) return Complex_Matrix; + + function Conjugate (X : Complex_Matrix) return Complex_Matrix; + function Transpose (X : Complex_Matrix) return Complex_Matrix; + + function "+" (Left, Right : Complex_Matrix) return Complex_Matrix; + function "-" (Left, Right : Complex_Matrix) return Complex_Matrix; + function "*" (Left, Right : Complex_Matrix) return Complex_Matrix; + function "*" (Left, Right : Complex_Vector) return Complex_Matrix; + + function "*" + (Left : Complex_Vector; + Right : Complex_Matrix) return Complex_Vector; + + function "*" + (Left : Complex_Matrix; + Right : Complex_Vector) return Complex_Vector; + + -- Mixed Real_Matrix and Complex_Matrix arithmetic operations + + function "+" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix; + + function "+" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix; + + function "-" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix; + + function "-" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix; + + function "*" + (Left : Real_Matrix; + Right : Complex_Matrix) return Complex_Matrix; + + function "*" + (Left : Complex_Matrix; + Right : Real_Matrix) return Complex_Matrix; + + function "*" + (Left : Real_Vector; + Right : Complex_Vector) return Complex_Matrix; + + function "*" + (Left : Complex_Vector; + Right : Real_Vector) return Complex_Matrix; + + function "*" + (Left : Real_Vector; + Right : Complex_Matrix) return Complex_Vector; + + function "*" + (Left : Complex_Vector; + Right : Real_Matrix) return Complex_Vector; + + function "*" + (Left : Real_Matrix; + Right : Complex_Vector) return Complex_Vector; + + function "*" + (Left : Complex_Matrix; + Right : Real_Vector) return Complex_Vector; + + -- Complex_Matrix scaling operations + + function "*" + (Left : Complex; + Right : Complex_Matrix) return Complex_Matrix; + + function "*" + (Left : Complex_Matrix; + Right : Complex) return Complex_Matrix; + + function "/" + (Left : Complex_Matrix; + Right : Complex) return Complex_Matrix; + + function "*" + (Left : Real'Base; + Right : Complex_Matrix) return Complex_Matrix; + + function "*" + (Left : Complex_Matrix; + Right : Real'Base) return Complex_Matrix; + + function "/" + (Left : Complex_Matrix; + Right : Real'Base) return Complex_Matrix; + + -- Complex_Matrix inversion and related operations + + function Solve + (A : Complex_Matrix; + X : Complex_Vector) return Complex_Vector; + + function Solve (A, X : Complex_Matrix) return Complex_Matrix; + + function Inverse (A : Complex_Matrix) return Complex_Matrix; + + function Determinant (A : Complex_Matrix) return Complex; + + -- Eigenvalues and vectors of a Hermitian matrix + + function Eigenvalues (A : Complex_Matrix) return Real_Vector; + + procedure Eigensystem + (A : Complex_Matrix; + Values : out Real_Vector; + Vectors : out Complex_Matrix); + + -- Other Complex_Matrix operations + + function Unit_Matrix + (Order : Positive; + First_1, First_2 : Integer := 1) return Complex_Matrix; + +end Ada.Numerics.Generic_Complex_Arrays; diff --git a/gcc/ada/libgnat/a-ngcoty.adb b/gcc/ada/libgnat/a-ngcoty.adb new file mode 100644 index 0000000..684fdeb --- /dev/null +++ b/gcc/ada/libgnat/a-ngcoty.adb @@ -0,0 +1,681 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Aux; use Ada.Numerics.Aux; + +package body Ada.Numerics.Generic_Complex_Types is + + subtype R is Real'Base; + + Two_Pi : constant R := R (2.0) * Pi; + Half_Pi : constant R := Pi / R (2.0); + + --------- + -- "*" -- + --------- + + function "*" (Left, Right : Complex) return Complex is + + Scale : constant R := R (R'Machine_Radix) ** ((R'Machine_Emax - 1) / 2); + -- In case of overflow, scale the operands by the largest power of the + -- radix (to avoid rounding error), so that the square of the scale does + -- not overflow itself. + + X : R; + Y : R; + + begin + X := Left.Re * Right.Re - Left.Im * Right.Im; + Y := Left.Re * Right.Im + Left.Im * Right.Re; + + -- If either component overflows, try to scale (skip in fast math mode) + + if not Standard'Fast_Math then + + -- Note that the test below is written as a negation. This is to + -- account for the fact that X and Y may be NaNs, because both of + -- their operands could overflow. Given that all operations on NaNs + -- return false, the test can only be written thus. + + if not (abs (X) <= R'Last) then + X := Scale**2 * ((Left.Re / Scale) * (Right.Re / Scale) - + (Left.Im / Scale) * (Right.Im / Scale)); + end if; + + if not (abs (Y) <= R'Last) then + Y := Scale**2 * ((Left.Re / Scale) * (Right.Im / Scale) + + (Left.Im / Scale) * (Right.Re / Scale)); + end if; + end if; + + return (X, Y); + end "*"; + + function "*" (Left, Right : Imaginary) return Real'Base is + begin + return -(R (Left) * R (Right)); + end "*"; + + function "*" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re * Right, Left.Im * Right); + end "*"; + + function "*" (Left : Real'Base; Right : Complex) return Complex is + begin + return (Left * Right.Re, Left * Right.Im); + end "*"; + + function "*" (Left : Complex; Right : Imaginary) return Complex is + begin + return Complex'(-(Left.Im * R (Right)), Left.Re * R (Right)); + end "*"; + + function "*" (Left : Imaginary; Right : Complex) return Complex is + begin + return Complex'(-(R (Left) * Right.Im), R (Left) * Right.Re); + end "*"; + + function "*" (Left : Imaginary; Right : Real'Base) return Imaginary is + begin + return Left * Imaginary (Right); + end "*"; + + function "*" (Left : Real'Base; Right : Imaginary) return Imaginary is + begin + return Imaginary (Left * R (Right)); + end "*"; + + ---------- + -- "**" -- + ---------- + + function "**" (Left : Complex; Right : Integer) return Complex is + Result : Complex := (1.0, 0.0); + Factor : Complex := Left; + Exp : Integer := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. For positive exponents we + -- multiply the result by this factor, for negative exponents, we + -- divide by this factor. + + if Exp >= 0 then + + -- For a positive exponent, if we get a constraint error during + -- this loop, it is an overflow, and the constraint error will + -- simply be passed on to the caller. + + while Exp /= 0 loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Factor := Factor * Factor; + Exp := Exp / 2; + end loop; + + return Result; + + else -- Exp < 0 then + + -- For the negative exponent case, a constraint error during this + -- calculation happens if Factor gets too large, and the proper + -- response is to return 0.0, since what we essentially have is + -- 1.0 / infinity, and the closest model number will be zero. + + begin + while Exp /= 0 loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Factor := Factor * Factor; + Exp := Exp / 2; + end loop; + + return R'(1.0) / Result; + + exception + when Constraint_Error => + return (0.0, 0.0); + end; + end if; + end "**"; + + function "**" (Left : Imaginary; Right : Integer) return Complex is + M : constant R := R (Left) ** Right; + begin + case Right mod 4 is + when 0 => return (M, 0.0); + when 1 => return (0.0, M); + when 2 => return (-M, 0.0); + when 3 => return (0.0, -M); + when others => raise Program_Error; + end case; + end "**"; + + --------- + -- "+" -- + --------- + + function "+" (Right : Complex) return Complex is + begin + return Right; + end "+"; + + function "+" (Left, Right : Complex) return Complex is + begin + return Complex'(Left.Re + Right.Re, Left.Im + Right.Im); + end "+"; + + function "+" (Right : Imaginary) return Imaginary is + begin + return Right; + end "+"; + + function "+" (Left, Right : Imaginary) return Imaginary is + begin + return Imaginary (R (Left) + R (Right)); + end "+"; + + function "+" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re + Right, Left.Im); + end "+"; + + function "+" (Left : Real'Base; Right : Complex) return Complex is + begin + return Complex'(Left + Right.Re, Right.Im); + end "+"; + + function "+" (Left : Complex; Right : Imaginary) return Complex is + begin + return Complex'(Left.Re, Left.Im + R (Right)); + end "+"; + + function "+" (Left : Imaginary; Right : Complex) return Complex is + begin + return Complex'(Right.Re, R (Left) + Right.Im); + end "+"; + + function "+" (Left : Imaginary; Right : Real'Base) return Complex is + begin + return Complex'(Right, R (Left)); + end "+"; + + function "+" (Left : Real'Base; Right : Imaginary) return Complex is + begin + return Complex'(Left, R (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Right : Complex) return Complex is + begin + return (-Right.Re, -Right.Im); + end "-"; + + function "-" (Left, Right : Complex) return Complex is + begin + return (Left.Re - Right.Re, Left.Im - Right.Im); + end "-"; + + function "-" (Right : Imaginary) return Imaginary is + begin + return Imaginary (-R (Right)); + end "-"; + + function "-" (Left, Right : Imaginary) return Imaginary is + begin + return Imaginary (R (Left) - R (Right)); + end "-"; + + function "-" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re - Right, Left.Im); + end "-"; + + function "-" (Left : Real'Base; Right : Complex) return Complex is + begin + return Complex'(Left - Right.Re, -Right.Im); + end "-"; + + function "-" (Left : Complex; Right : Imaginary) return Complex is + begin + return Complex'(Left.Re, Left.Im - R (Right)); + end "-"; + + function "-" (Left : Imaginary; Right : Complex) return Complex is + begin + return Complex'(-Right.Re, R (Left) - Right.Im); + end "-"; + + function "-" (Left : Imaginary; Right : Real'Base) return Complex is + begin + return Complex'(-Right, R (Left)); + end "-"; + + function "-" (Left : Real'Base; Right : Imaginary) return Complex is + begin + return Complex'(Left, -R (Right)); + end "-"; + + --------- + -- "/" -- + --------- + + function "/" (Left, Right : Complex) return Complex is + a : constant R := Left.Re; + b : constant R := Left.Im; + c : constant R := Right.Re; + d : constant R := Right.Im; + + begin + if c = 0.0 and then d = 0.0 then + raise Constraint_Error; + else + return Complex'(Re => ((a * c) + (b * d)) / (c ** 2 + d ** 2), + Im => ((b * c) - (a * d)) / (c ** 2 + d ** 2)); + end if; + end "/"; + + function "/" (Left, Right : Imaginary) return Real'Base is + begin + return R (Left) / R (Right); + end "/"; + + function "/" (Left : Complex; Right : Real'Base) return Complex is + begin + return Complex'(Left.Re / Right, Left.Im / Right); + end "/"; + + function "/" (Left : Real'Base; Right : Complex) return Complex is + a : constant R := Left; + c : constant R := Right.Re; + d : constant R := Right.Im; + begin + return Complex'(Re => (a * c) / (c ** 2 + d ** 2), + Im => -((a * d) / (c ** 2 + d ** 2))); + end "/"; + + function "/" (Left : Complex; Right : Imaginary) return Complex is + a : constant R := Left.Re; + b : constant R := Left.Im; + d : constant R := R (Right); + + begin + return (b / d, -(a / d)); + end "/"; + + function "/" (Left : Imaginary; Right : Complex) return Complex is + b : constant R := R (Left); + c : constant R := Right.Re; + d : constant R := Right.Im; + + begin + return (Re => b * d / (c ** 2 + d ** 2), + Im => b * c / (c ** 2 + d ** 2)); + end "/"; + + function "/" (Left : Imaginary; Right : Real'Base) return Imaginary is + begin + return Imaginary (R (Left) / Right); + end "/"; + + function "/" (Left : Real'Base; Right : Imaginary) return Imaginary is + begin + return Imaginary (-(Left / R (Right))); + end "/"; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) < R (Right); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) <= R (Right); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) > R (Right); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (Left, Right : Imaginary) return Boolean is + begin + return R (Left) >= R (Right); + end ">="; + + ----------- + -- "abs" -- + ----------- + + function "abs" (Right : Imaginary) return Real'Base is + begin + return abs R (Right); + end "abs"; + + -------------- + -- Argument -- + -------------- + + function Argument (X : Complex) return Real'Base is + a : constant R := X.Re; + b : constant R := X.Im; + arg : R; + + begin + if b = 0.0 then + + if a >= 0.0 then + return 0.0; + else + return R'Copy_Sign (Pi, b); + end if; + + elsif a = 0.0 then + + if b >= 0.0 then + return Half_Pi; + else + return -Half_Pi; + end if; + + else + arg := R (Atan (Double (abs (b / a)))); + + if a > 0.0 then + if b > 0.0 then + return arg; + else -- b < 0.0 + return -arg; + end if; + + else -- a < 0.0 + if b >= 0.0 then + return Pi - arg; + else -- b < 0.0 + return -(Pi - arg); + end if; + end if; + end if; + + exception + when Constraint_Error => + if b > 0.0 then + return Half_Pi; + else + return -Half_Pi; + end if; + end Argument; + + function Argument (X : Complex; Cycle : Real'Base) return Real'Base is + begin + if Cycle > 0.0 then + return Argument (X) * Cycle / Two_Pi; + else + raise Argument_Error; + end if; + end Argument; + + ---------------------------- + -- Compose_From_Cartesian -- + ---------------------------- + + function Compose_From_Cartesian (Re, Im : Real'Base) return Complex is + begin + return (Re, Im); + end Compose_From_Cartesian; + + function Compose_From_Cartesian (Re : Real'Base) return Complex is + begin + return (Re, 0.0); + end Compose_From_Cartesian; + + function Compose_From_Cartesian (Im : Imaginary) return Complex is + begin + return (0.0, R (Im)); + end Compose_From_Cartesian; + + ------------------------ + -- Compose_From_Polar -- + ------------------------ + + function Compose_From_Polar ( + Modulus, Argument : Real'Base) + return Complex + is + begin + if Modulus = 0.0 then + return (0.0, 0.0); + else + return (Modulus * R (Cos (Double (Argument))), + Modulus * R (Sin (Double (Argument)))); + end if; + end Compose_From_Polar; + + function Compose_From_Polar ( + Modulus, Argument, Cycle : Real'Base) + return Complex + is + Arg : Real'Base; + + begin + if Modulus = 0.0 then + return (0.0, 0.0); + + elsif Cycle > 0.0 then + if Argument = 0.0 then + return (Modulus, 0.0); + + elsif Argument = Cycle / 4.0 then + return (0.0, Modulus); + + elsif Argument = Cycle / 2.0 then + return (-Modulus, 0.0); + + elsif Argument = 3.0 * Cycle / R (4.0) then + return (0.0, -Modulus); + else + Arg := Two_Pi * Argument / Cycle; + return (Modulus * R (Cos (Double (Arg))), + Modulus * R (Sin (Double (Arg)))); + end if; + else + raise Argument_Error; + end if; + end Compose_From_Polar; + + --------------- + -- Conjugate -- + --------------- + + function Conjugate (X : Complex) return Complex is + begin + return Complex'(X.Re, -X.Im); + end Conjugate; + + -------- + -- Im -- + -------- + + function Im (X : Complex) return Real'Base is + begin + return X.Im; + end Im; + + function Im (X : Imaginary) return Real'Base is + begin + return R (X); + end Im; + + ------------- + -- Modulus -- + ------------- + + function Modulus (X : Complex) return Real'Base is + Re2, Im2 : R; + + begin + + begin + Re2 := X.Re ** 2; + + -- To compute (a**2 + b**2) ** (0.5) when a**2 may be out of bounds, + -- compute a * (1 + (b/a) **2) ** (0.5). On a machine where the + -- squaring does not raise constraint_error but generates infinity, + -- we can use an explicit comparison to determine whether to use + -- the scaling expression. + + -- The scaling expression is computed in double format throughout + -- in order to prevent inaccuracies on machines where not all + -- immediate expressions are rounded, such as PowerPC. + + -- ??? same weird test, why not Re2 > R'Last ??? + if not (Re2 <= R'Last) then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + return R (Double (abs (X.Re)) + * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); + end; + + begin + Im2 := X.Im ** 2; + + -- ??? same weird test + if not (Im2 <= R'Last) then + raise Constraint_Error; + end if; + + exception + when Constraint_Error => + return R (Double (abs (X.Im)) + * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); + end; + + -- Now deal with cases of underflow. If only one of the squares + -- underflows, return the modulus of the other component. If both + -- squares underflow, use scaling as above. + + if Re2 = 0.0 then + + if X.Re = 0.0 then + return abs (X.Im); + + elsif Im2 = 0.0 then + + if X.Im = 0.0 then + return abs (X.Re); + + else + if abs (X.Re) > abs (X.Im) then + return + R (Double (abs (X.Re)) + * Sqrt (1.0 + (Double (X.Im) / Double (X.Re)) ** 2)); + else + return + R (Double (abs (X.Im)) + * Sqrt (1.0 + (Double (X.Re) / Double (X.Im)) ** 2)); + end if; + end if; + + else + return abs (X.Im); + end if; + + elsif Im2 = 0.0 then + return abs (X.Re); + + -- In all other cases, the naive computation will do + + else + return R (Sqrt (Double (Re2 + Im2))); + end if; + end Modulus; + + -------- + -- Re -- + -------- + + function Re (X : Complex) return Real'Base is + begin + return X.Re; + end Re; + + ------------ + -- Set_Im -- + ------------ + + procedure Set_Im (X : in out Complex; Im : Real'Base) is + begin + X.Im := Im; + end Set_Im; + + procedure Set_Im (X : out Imaginary; Im : Real'Base) is + begin + X := Imaginary (Im); + end Set_Im; + + ------------ + -- Set_Re -- + ------------ + + procedure Set_Re (X : in out Complex; Re : Real'Base) is + begin + X.Re := Re; + end Set_Re; + +end Ada.Numerics.Generic_Complex_Types; diff --git a/gcc/ada/libgnat/a-ngcoty.ads b/gcc/ada/libgnat/a-ngcoty.ads new file mode 100644 index 0000000..bc3ff57 --- /dev/null +++ b/gcc/ada/libgnat/a-ngcoty.ads @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . G E N E R I C _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Real is digits <>; + +package Ada.Numerics.Generic_Complex_Types is + pragma Pure; + + type Complex is record + Re, Im : Real'Base; + end record; + + pragma Complex_Representation (Complex); + + type Imaginary is private; + pragma Preelaborable_Initialization (Imaginary); + + i : constant Imaginary; + j : constant Imaginary; + + function Re (X : Complex) return Real'Base; + function Im (X : Complex) return Real'Base; + function Im (X : Imaginary) return Real'Base; + + procedure Set_Re (X : in out Complex; Re : Real'Base); + procedure Set_Im (X : in out Complex; Im : Real'Base); + procedure Set_Im (X : out Imaginary; Im : Real'Base); + + function Compose_From_Cartesian (Re, Im : Real'Base) return Complex; + function Compose_From_Cartesian (Re : Real'Base) return Complex; + function Compose_From_Cartesian (Im : Imaginary) return Complex; + + function Modulus (X : Complex) return Real'Base; + function "abs" (Right : Complex) return Real'Base renames Modulus; + + function Argument (X : Complex) return Real'Base; + function Argument (X : Complex; Cycle : Real'Base) return Real'Base; + + function Compose_From_Polar ( + Modulus, Argument : Real'Base) + return Complex; + + function Compose_From_Polar ( + Modulus, Argument, Cycle : Real'Base) + return Complex; + + function "+" (Right : Complex) return Complex; + function "-" (Right : Complex) return Complex; + function Conjugate (X : Complex) return Complex; + + function "+" (Left, Right : Complex) return Complex; + function "-" (Left, Right : Complex) return Complex; + function "*" (Left, Right : Complex) return Complex; + function "/" (Left, Right : Complex) return Complex; + + function "**" (Left : Complex; Right : Integer) return Complex; + + function "+" (Right : Imaginary) return Imaginary; + function "-" (Right : Imaginary) return Imaginary; + function Conjugate (X : Imaginary) return Imaginary renames "-"; + function "abs" (Right : Imaginary) return Real'Base; + + function "+" (Left, Right : Imaginary) return Imaginary; + function "-" (Left, Right : Imaginary) return Imaginary; + function "*" (Left, Right : Imaginary) return Real'Base; + function "/" (Left, Right : Imaginary) return Real'Base; + + function "**" (Left : Imaginary; Right : Integer) return Complex; + + function "<" (Left, Right : Imaginary) return Boolean; + function "<=" (Left, Right : Imaginary) return Boolean; + function ">" (Left, Right : Imaginary) return Boolean; + function ">=" (Left, Right : Imaginary) return Boolean; + + function "+" (Left : Complex; Right : Real'Base) return Complex; + function "+" (Left : Real'Base; Right : Complex) return Complex; + function "-" (Left : Complex; Right : Real'Base) return Complex; + function "-" (Left : Real'Base; Right : Complex) return Complex; + function "*" (Left : Complex; Right : Real'Base) return Complex; + function "*" (Left : Real'Base; Right : Complex) return Complex; + function "/" (Left : Complex; Right : Real'Base) return Complex; + function "/" (Left : Real'Base; Right : Complex) return Complex; + + function "+" (Left : Complex; Right : Imaginary) return Complex; + function "+" (Left : Imaginary; Right : Complex) return Complex; + function "-" (Left : Complex; Right : Imaginary) return Complex; + function "-" (Left : Imaginary; Right : Complex) return Complex; + function "*" (Left : Complex; Right : Imaginary) return Complex; + function "*" (Left : Imaginary; Right : Complex) return Complex; + function "/" (Left : Complex; Right : Imaginary) return Complex; + function "/" (Left : Imaginary; Right : Complex) return Complex; + + function "+" (Left : Imaginary; Right : Real'Base) return Complex; + function "+" (Left : Real'Base; Right : Imaginary) return Complex; + function "-" (Left : Imaginary; Right : Real'Base) return Complex; + function "-" (Left : Real'Base; Right : Imaginary) return Complex; + + function "*" (Left : Imaginary; Right : Real'Base) return Imaginary; + function "*" (Left : Real'Base; Right : Imaginary) return Imaginary; + function "/" (Left : Imaginary; Right : Real'Base) return Imaginary; + function "/" (Left : Real'Base; Right : Imaginary) return Imaginary; + +private + type Imaginary is new Real'Base; + + i : constant Imaginary := 1.0; + j : constant Imaginary := 1.0; + + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline ("*"); + pragma Inline ("<"); + pragma Inline ("<="); + pragma Inline (">"); + pragma Inline (">="); + pragma Inline ("abs"); + pragma Inline (Compose_From_Cartesian); + pragma Inline (Conjugate); + pragma Inline (Im); + pragma Inline (Re); + pragma Inline (Set_Im); + pragma Inline (Set_Re); + +end Ada.Numerics.Generic_Complex_Types; diff --git a/gcc/ada/libgnat/a-ngelfu.adb b/gcc/ada/libgnat/a-ngelfu.adb new file mode 100644 index 0000000..87c88c3 --- /dev/null +++ b/gcc/ada/libgnat/a-ngelfu.adb @@ -0,0 +1,997 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This body is specifically for using an Ada interface to C math.h to get +-- the computation engine. Many special cases are handled locally to avoid +-- unnecessary calls or to meet Annex G strict mode requirements. + +-- Uses functions sqrt, exp, log, pow, sin, asin, cos, acos, tan, atan, sinh, +-- cosh, tanh from C library via math.h + +with Ada.Numerics.Aux; + +package body Ada.Numerics.Generic_Elementary_Functions with + SPARK_Mode => Off +is + + use type Ada.Numerics.Aux.Double; + + Sqrt_Two : constant := 1.41421_35623_73095_04880_16887_24209_69807_85696; + Log_Two : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755; + + Half_Log_Two : constant := Log_Two / 2; + + subtype T is Float_Type'Base; + subtype Double is Aux.Double; + + Two_Pi : constant T := 2.0 * Pi; + Half_Pi : constant T := Pi / 2.0; + + Half_Log_Epsilon : constant T := T (1 - T'Model_Mantissa) * Half_Log_Two; + Log_Inverse_Epsilon : constant T := T (T'Model_Mantissa - 1) * Log_Two; + Sqrt_Epsilon : constant T := Sqrt_Two ** (1 - T'Model_Mantissa); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Exp_Strict (X : Float_Type'Base) return Float_Type'Base; + -- Cody/Waite routine, supposedly more precise than the library version. + -- Currently only needed for Sinh/Cosh on X86 with the largest FP type. + + function Local_Atan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) return Float_Type'Base; + -- Common code for arc tangent after cycle reduction + + ---------- + -- "**" -- + ---------- + + function "**" (Left, Right : Float_Type'Base) return Float_Type'Base is + A_Right : Float_Type'Base; + Int_Part : Integer; + Result : Float_Type'Base; + R1 : Float_Type'Base; + Rest : Float_Type'Base; + + begin + if Left = 0.0 + and then Right = 0.0 + then + raise Argument_Error; + + elsif Left < 0.0 then + raise Argument_Error; + + elsif Right = 0.0 then + return 1.0; + + elsif Left = 0.0 then + if Right < 0.0 then + raise Constraint_Error; + else + return 0.0; + end if; + + elsif Left = 1.0 then + return 1.0; + + elsif Right = 1.0 then + return Left; + + else + begin + if Right = 2.0 then + return Left * Left; + + elsif Right = 0.5 then + return Sqrt (Left); + + else + A_Right := abs (Right); + + -- If exponent is larger than one, compute integer exponen- + -- tiation if possible, and evaluate fractional part with more + -- precision. The relative error is now proportional to the + -- fractional part of the exponent only. + + if A_Right > 1.0 + and then A_Right < Float_Type'Base (Integer'Last) + then + Int_Part := Integer (Float_Type'Base'Truncation (A_Right)); + Result := Left ** Int_Part; + Rest := A_Right - Float_Type'Base (Int_Part); + + -- Compute with two leading bits of the mantissa using + -- square roots. Bound to be better than logarithms, and + -- easily extended to greater precision. + + if Rest >= 0.5 then + R1 := Sqrt (Left); + Result := Result * R1; + Rest := Rest - 0.5; + + if Rest >= 0.25 then + Result := Result * Sqrt (R1); + Rest := Rest - 0.25; + end if; + + elsif Rest >= 0.25 then + Result := Result * Sqrt (Sqrt (Left)); + Rest := Rest - 0.25; + end if; + + Result := Result * + Float_Type'Base (Aux.Pow (Double (Left), Double (Rest))); + + if Right >= 0.0 then + return Result; + else + return (1.0 / Result); + end if; + else + return + Float_Type'Base (Aux.Pow (Double (Left), Double (Right))); + end if; + end if; + + exception + when others => + raise Constraint_Error; + end; + end if; + end "**"; + + ------------ + -- Arccos -- + ------------ + + -- Natural cycle + + function Arccos (X : Float_Type'Base) return Float_Type'Base is + Temp : Float_Type'Base; + + begin + if abs X > 1.0 then + raise Argument_Error; + + elsif abs X < Sqrt_Epsilon then + return Pi / 2.0 - X; + + elsif X = 1.0 then + return 0.0; + + elsif X = -1.0 then + return Pi; + end if; + + Temp := Float_Type'Base (Aux.Acos (Double (X))); + + if Temp < 0.0 then + Temp := Pi + Temp; + end if; + + return Temp; + end Arccos; + + -- Arbitrary cycle + + function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base is + Temp : Float_Type'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif abs X > 1.0 then + raise Argument_Error; + + elsif abs X < Sqrt_Epsilon then + return Cycle / 4.0; + + elsif X = 1.0 then + return 0.0; + + elsif X = -1.0 then + return Cycle / 2.0; + end if; + + Temp := Arctan (Sqrt ((1.0 - X) * (1.0 + X)) / X, 1.0, Cycle); + + if Temp < 0.0 then + Temp := Cycle / 2.0 + Temp; + end if; + + return Temp; + end Arccos; + + ------------- + -- Arccosh -- + ------------- + + function Arccosh (X : Float_Type'Base) return Float_Type'Base is + begin + -- Return positive branch of Log (X - Sqrt (X * X - 1.0)), or the proper + -- approximation for X close to 1 or >> 1. + + if X < 1.0 then + raise Argument_Error; + + elsif X < 1.0 + Sqrt_Epsilon then + return Sqrt (2.0 * (X - 1.0)); + + elsif X > 1.0 / Sqrt_Epsilon then + return Log (X) + Log_Two; + + else + return Log (X + Sqrt ((X - 1.0) * (X + 1.0))); + end if; + end Arccosh; + + ------------ + -- Arccot -- + ------------ + + -- Natural cycle + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0) + return Float_Type'Base + is + begin + -- Just reverse arguments + + return Arctan (Y, X); + end Arccot; + + -- Arbitrary cycle + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) + return Float_Type'Base + is + begin + -- Just reverse arguments + + return Arctan (Y, X, Cycle); + end Arccot; + + ------------- + -- Arccoth -- + ------------- + + function Arccoth (X : Float_Type'Base) return Float_Type'Base is + begin + if abs X > 2.0 then + return Arctanh (1.0 / X); + + elsif abs X = 1.0 then + raise Constraint_Error; + + elsif abs X < 1.0 then + raise Argument_Error; + + else + -- 1.0 < abs X <= 2.0. One of X + 1.0 and X - 1.0 is exact, the other + -- has error 0 or Epsilon. + + return 0.5 * (Log (abs (X + 1.0)) - Log (abs (X - 1.0))); + end if; + end Arccoth; + + ------------ + -- Arcsin -- + ------------ + + -- Natural cycle + + function Arcsin (X : Float_Type'Base) return Float_Type'Base is + begin + if abs X > 1.0 then + raise Argument_Error; + + elsif abs X < Sqrt_Epsilon then + return X; + + elsif X = 1.0 then + return Pi / 2.0; + + elsif X = -1.0 then + return -(Pi / 2.0); + end if; + + return Float_Type'Base (Aux.Asin (Double (X))); + end Arcsin; + + -- Arbitrary cycle + + function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base is + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif abs X > 1.0 then + raise Argument_Error; + + elsif X = 0.0 then + return X; + + elsif X = 1.0 then + return Cycle / 4.0; + + elsif X = -1.0 then + return -(Cycle / 4.0); + end if; + + return Arctan (X / Sqrt ((1.0 - X) * (1.0 + X)), 1.0, Cycle); + end Arcsin; + + ------------- + -- Arcsinh -- + ------------- + + function Arcsinh (X : Float_Type'Base) return Float_Type'Base is + begin + if abs X < Sqrt_Epsilon then + return X; + + elsif X > 1.0 / Sqrt_Epsilon then + return Log (X) + Log_Two; + + elsif X < -(1.0 / Sqrt_Epsilon) then + return -(Log (-X) + Log_Two); + + elsif X < 0.0 then + return -Log (abs X + Sqrt (X * X + 1.0)); + + else + return Log (X + Sqrt (X * X + 1.0)); + end if; + end Arcsinh; + + ------------ + -- Arctan -- + ------------ + + -- Natural cycle + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) + return Float_Type'Base + is + begin + if X = 0.0 and then Y = 0.0 then + raise Argument_Error; + + elsif Y = 0.0 then + if X > 0.0 then + return 0.0; + else -- X < 0.0 + return Pi * Float_Type'Copy_Sign (1.0, Y); + end if; + + elsif X = 0.0 then + return Float_Type'Copy_Sign (Half_Pi, Y); + + else + return Local_Atan (Y, X); + end if; + end Arctan; + + -- Arbitrary cycle + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) + return Float_Type'Base + is + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif X = 0.0 and then Y = 0.0 then + raise Argument_Error; + + elsif Y = 0.0 then + if X > 0.0 then + return 0.0; + else -- X < 0.0 + return Cycle / 2.0 * Float_Type'Copy_Sign (1.0, Y); + end if; + + elsif X = 0.0 then + return Float_Type'Copy_Sign (Cycle / 4.0, Y); + + else + return Local_Atan (Y, X) * Cycle / Two_Pi; + end if; + end Arctan; + + ------------- + -- Arctanh -- + ------------- + + function Arctanh (X : Float_Type'Base) return Float_Type'Base is + A, B, D, A_Plus_1, A_From_1 : Float_Type'Base; + + Mantissa : constant Integer := Float_Type'Base'Machine_Mantissa; + + begin + -- The naive formula: + + -- Arctanh (X) := (1/2) * Log (1 + X) / (1 - X) + + -- is not well-behaved numerically when X < 0.5 and when X is close + -- to one. The following is accurate but probably not optimal. + + if abs X = 1.0 then + raise Constraint_Error; + + elsif abs X >= 1.0 - 2.0 ** (-Mantissa) then + + if abs X >= 1.0 then + raise Argument_Error; + else + + -- The one case that overflows if put through the method below: + -- abs X = 1.0 - Epsilon. In this case (1/2) log (2/Epsilon) is + -- accurate. This simplifies to: + + return Float_Type'Copy_Sign ( + Half_Log_Two * Float_Type'Base (Mantissa + 1), X); + end if; + + -- elsif abs X <= 0.5 then + -- why is above line commented out ??? + + else + -- Use several piecewise linear approximations. A is close to X, + -- chosen so 1.0 + A, 1.0 - A, and X - A are exact. The two scalings + -- remove the low-order bits of X. + + A := Float_Type'Base'Scaling ( + Float_Type'Base (Long_Long_Integer + (Float_Type'Base'Scaling (X, Mantissa - 1))), 1 - Mantissa); + + B := X - A; -- This is exact; abs B <= 2**(-Mantissa). + A_Plus_1 := 1.0 + A; -- This is exact. + A_From_1 := 1.0 - A; -- Ditto. + D := A_Plus_1 * A_From_1; -- 1 - A*A. + + -- use one term of the series expansion: + + -- f (x + e) = f(x) + e * f'(x) + .. + + -- The derivative of Arctanh at A is 1/(1-A*A). Next term is + -- A*(B/D)**2 (if a quadratic approximation is ever needed). + + return 0.5 * (Log (A_Plus_1) - Log (A_From_1)) + B / D; + end if; + end Arctanh; + + --------- + -- Cos -- + --------- + + -- Natural cycle + + function Cos (X : Float_Type'Base) return Float_Type'Base is + begin + if abs X < Sqrt_Epsilon then + return 1.0; + end if; + + return Float_Type'Base (Aux.Cos (Double (X))); + end Cos; + + -- Arbitrary cycle + + function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base is + begin + -- Just reuse the code for Sin. The potential small loss of speed is + -- negligible with proper (front-end) inlining. + + return -Sin (abs X - Cycle * 0.25, Cycle); + end Cos; + + ---------- + -- Cosh -- + ---------- + + function Cosh (X : Float_Type'Base) return Float_Type'Base is + Lnv : constant Float_Type'Base := 8#0.542714#; + V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; + Y : constant Float_Type'Base := abs X; + Z : Float_Type'Base; + + begin + if Y < Sqrt_Epsilon then + return 1.0; + + elsif Y > Log_Inverse_Epsilon then + Z := Exp_Strict (Y - Lnv); + return (Z + V2minus1 * Z); + + else + Z := Exp_Strict (Y); + return 0.5 * (Z + 1.0 / Z); + end if; + + end Cosh; + + --------- + -- Cot -- + --------- + + -- Natural cycle + + function Cot (X : Float_Type'Base) return Float_Type'Base is + begin + if X = 0.0 then + raise Constraint_Error; + + elsif abs X < Sqrt_Epsilon then + return 1.0 / X; + end if; + + return 1.0 / Float_Type'Base (Aux.Tan (Double (X))); + end Cot; + + -- Arbitrary cycle + + function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base is + T : Float_Type'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + end if; + + T := Float_Type'Base'Remainder (X, Cycle); + + if T = 0.0 or else abs T = 0.5 * Cycle then + raise Constraint_Error; + + elsif abs T < Sqrt_Epsilon then + return 1.0 / T; + + elsif abs T = 0.25 * Cycle then + return 0.0; + + else + T := T / Cycle * Two_Pi; + return Cos (T) / Sin (T); + end if; + end Cot; + + ---------- + -- Coth -- + ---------- + + function Coth (X : Float_Type'Base) return Float_Type'Base is + begin + if X = 0.0 then + raise Constraint_Error; + + elsif X < Half_Log_Epsilon then + return -1.0; + + elsif X > -Half_Log_Epsilon then + return 1.0; + + elsif abs X < Sqrt_Epsilon then + return 1.0 / X; + end if; + + return 1.0 / Float_Type'Base (Aux.Tanh (Double (X))); + end Coth; + + --------- + -- Exp -- + --------- + + function Exp (X : Float_Type'Base) return Float_Type'Base is + Result : Float_Type'Base; + + begin + if X = 0.0 then + return 1.0; + end if; + + Result := Float_Type'Base (Aux.Exp (Double (X))); + + -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows + -- is False, then we can just leave it as an infinity (and indeed we + -- prefer to do so). But if Machine_Overflows is True, then we have + -- to raise a Constraint_Error exception as required by the RM. + + if Float_Type'Machine_Overflows and then not Result'Valid then + raise Constraint_Error; + end if; + + return Result; + end Exp; + + ---------------- + -- Exp_Strict -- + ---------------- + + function Exp_Strict (X : Float_Type'Base) return Float_Type'Base is + G : Float_Type'Base; + Z : Float_Type'Base; + + P0 : constant := 0.25000_00000_00000_00000; + P1 : constant := 0.75753_18015_94227_76666E-2; + P2 : constant := 0.31555_19276_56846_46356E-4; + + Q0 : constant := 0.5; + Q1 : constant := 0.56817_30269_85512_21787E-1; + Q2 : constant := 0.63121_89437_43985_02557E-3; + Q3 : constant := 0.75104_02839_98700_46114E-6; + + C1 : constant := 8#0.543#; + C2 : constant := -2.1219_44400_54690_58277E-4; + Le : constant := 1.4426_95040_88896_34074; + + XN : Float_Type'Base; + P, Q, R : Float_Type'Base; + + begin + if X = 0.0 then + return 1.0; + end if; + + XN := Float_Type'Base'Rounding (X * Le); + G := (X - XN * C1) - XN * C2; + Z := G * G; + P := G * ((P2 * Z + P1) * Z + P0); + Q := ((Q3 * Z + Q2) * Z + Q1) * Z + Q0; + R := 0.5 + P / (Q - P); + + R := Float_Type'Base'Scaling (R, Integer (XN) + 1); + + -- Deal with case of Exp returning IEEE infinity. If Machine_Overflows + -- is False, then we can just leave it as an infinity (and indeed we + -- prefer to do so). But if Machine_Overflows is True, then we have to + -- raise a Constraint_Error exception as required by the RM. + + if Float_Type'Machine_Overflows and then not R'Valid then + raise Constraint_Error; + else + return R; + end if; + + end Exp_Strict; + + ---------------- + -- Local_Atan -- + ---------------- + + function Local_Atan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) return Float_Type'Base + is + Z : Float_Type'Base; + Raw_Atan : Float_Type'Base; + + begin + Z := (if abs Y > abs X then abs (X / Y) else abs (Y / X)); + + Raw_Atan := + (if Z < Sqrt_Epsilon then Z + elsif Z = 1.0 then Pi / 4.0 + else Float_Type'Base (Aux.Atan (Double (Z)))); + + if abs Y > abs X then + Raw_Atan := Half_Pi - Raw_Atan; + end if; + + if X > 0.0 then + return Float_Type'Copy_Sign (Raw_Atan, Y); + else + return Float_Type'Copy_Sign (Pi - Raw_Atan, Y); + end if; + end Local_Atan; + + --------- + -- Log -- + --------- + + -- Natural base + + function Log (X : Float_Type'Base) return Float_Type'Base is + begin + if X < 0.0 then + raise Argument_Error; + + elsif X = 0.0 then + raise Constraint_Error; + + elsif X = 1.0 then + return 0.0; + end if; + + return Float_Type'Base (Aux.Log (Double (X))); + end Log; + + -- Arbitrary base + + function Log (X, Base : Float_Type'Base) return Float_Type'Base is + begin + if X < 0.0 then + raise Argument_Error; + + elsif Base <= 0.0 or else Base = 1.0 then + raise Argument_Error; + + elsif X = 0.0 then + raise Constraint_Error; + + elsif X = 1.0 then + return 0.0; + end if; + + return Float_Type'Base (Aux.Log (Double (X)) / Aux.Log (Double (Base))); + end Log; + + --------- + -- Sin -- + --------- + + -- Natural cycle + + function Sin (X : Float_Type'Base) return Float_Type'Base is + begin + if abs X < Sqrt_Epsilon then + return X; + end if; + + return Float_Type'Base (Aux.Sin (Double (X))); + end Sin; + + -- Arbitrary cycle + + function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base is + T : Float_Type'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + -- If X is zero, return it as the result, preserving the argument sign. + -- Is this test really needed on any machine ??? + + elsif X = 0.0 then + return X; + end if; + + T := Float_Type'Base'Remainder (X, Cycle); + + -- The following two reductions reduce the argument to the interval + -- [-0.25 * Cycle, 0.25 * Cycle]. This reduction is exact and is needed + -- to prevent inaccuracy that may result if the sine function uses a + -- different (more accurate) value of Pi in its reduction than is used + -- in the multiplication with Two_Pi. + + if abs T > 0.25 * Cycle then + T := 0.5 * Float_Type'Copy_Sign (Cycle, T) - T; + end if; + + -- Could test for 12.0 * abs T = Cycle, and return an exact value in + -- those cases. It is not clear this is worth the extra test though. + + return Float_Type'Base (Aux.Sin (Double (T / Cycle * Two_Pi))); + end Sin; + + ---------- + -- Sinh -- + ---------- + + function Sinh (X : Float_Type'Base) return Float_Type'Base is + Lnv : constant Float_Type'Base := 8#0.542714#; + V2minus1 : constant Float_Type'Base := 0.13830_27787_96019_02638E-4; + Y : constant Float_Type'Base := abs X; + F : constant Float_Type'Base := Y * Y; + Z : Float_Type'Base; + + Float_Digits_1_6 : constant Boolean := Float_Type'Digits < 7; + + begin + if Y < Sqrt_Epsilon then + return X; + + elsif Y > Log_Inverse_Epsilon then + Z := Exp_Strict (Y - Lnv); + Z := Z + V2minus1 * Z; + + elsif Y < 1.0 then + + if Float_Digits_1_6 then + + -- Use expansion provided by Cody and Waite, p. 226. Note that + -- leading term of the polynomial in Q is exactly 1.0. + + declare + P0 : constant := -0.71379_3159E+1; + P1 : constant := -0.19033_3399E+0; + Q0 : constant := -0.42827_7109E+2; + + begin + Z := Y + Y * F * (P1 * F + P0) / (F + Q0); + end; + + else + declare + P0 : constant := -0.35181_28343_01771_17881E+6; + P1 : constant := -0.11563_52119_68517_68270E+5; + P2 : constant := -0.16375_79820_26307_51372E+3; + P3 : constant := -0.78966_12741_73570_99479E+0; + Q0 : constant := -0.21108_77005_81062_71242E+7; + Q1 : constant := 0.36162_72310_94218_36460E+5; + Q2 : constant := -0.27773_52311_96507_01667E+3; + + begin + Z := Y + Y * F * (((P3 * F + P2) * F + P1) * F + P0) + / (((F + Q2) * F + Q1) * F + Q0); + end; + end if; + + else + Z := Exp_Strict (Y); + Z := 0.5 * (Z - 1.0 / Z); + end if; + + if X > 0.0 then + return Z; + else + return -Z; + end if; + end Sinh; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Float_Type'Base) return Float_Type'Base is + begin + if X < 0.0 then + raise Argument_Error; + + -- Special case Sqrt (0.0) to preserve possible minus sign per IEEE + + elsif X = 0.0 then + return X; + end if; + + return Float_Type'Base (Aux.Sqrt (Double (X))); + end Sqrt; + + --------- + -- Tan -- + --------- + + -- Natural cycle + + function Tan (X : Float_Type'Base) return Float_Type'Base is + begin + if abs X < Sqrt_Epsilon then + return X; + end if; + + -- Note: if X is exactly pi/2, then we should raise an exception, since + -- the result would overflow. But for all floating-point formats we deal + -- with, it is impossible for X to be exactly pi/2, and the result is + -- always in range. + + return Float_Type'Base (Aux.Tan (Double (X))); + end Tan; + + -- Arbitrary cycle + + function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base is + T : Float_Type'Base; + + begin + if Cycle <= 0.0 then + raise Argument_Error; + + elsif X = 0.0 then + return X; + end if; + + T := Float_Type'Base'Remainder (X, Cycle); + + if abs T = 0.25 * Cycle then + raise Constraint_Error; + + elsif abs T = 0.5 * Cycle then + return 0.0; + + else + T := T / Cycle * Two_Pi; + return Sin (T) / Cos (T); + end if; + + end Tan; + + ---------- + -- Tanh -- + ---------- + + function Tanh (X : Float_Type'Base) return Float_Type'Base is + P0 : constant Float_Type'Base := -0.16134_11902_39962_28053E+4; + P1 : constant Float_Type'Base := -0.99225_92967_22360_83313E+2; + P2 : constant Float_Type'Base := -0.96437_49277_72254_69787E+0; + + Q0 : constant Float_Type'Base := 0.48402_35707_19886_88686E+4; + Q1 : constant Float_Type'Base := 0.22337_72071_89623_12926E+4; + Q2 : constant Float_Type'Base := 0.11274_47438_05349_49335E+3; + Q3 : constant Float_Type'Base := 0.10000_00000_00000_00000E+1; + + Half_Ln3 : constant Float_Type'Base := 0.54930_61443_34054_84570; + + P, Q, R : Float_Type'Base; + Y : constant Float_Type'Base := abs X; + G : constant Float_Type'Base := Y * Y; + + Float_Type_Digits_15_Or_More : constant Boolean := + Float_Type'Digits > 14; + + begin + if X < Half_Log_Epsilon then + return -1.0; + + elsif X > -Half_Log_Epsilon then + return 1.0; + + elsif Y < Sqrt_Epsilon then + return X; + + elsif Y < Half_Ln3 + and then Float_Type_Digits_15_Or_More + then + P := (P2 * G + P1) * G + P0; + Q := ((Q3 * G + Q2) * G + Q1) * G + Q0; + R := G * (P / Q); + return X + X * R; + + else + return Float_Type'Base (Aux.Tanh (Double (X))); + end if; + end Tanh; + +end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/libgnat/a-ngelfu.ads b/gcc/ada/libgnat/a-ngelfu.ads new file mode 100644 index 0000000..52a00d2 --- /dev/null +++ b/gcc/ada/libgnat/a-ngelfu.ads @@ -0,0 +1,205 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2012-2017, 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 Post aspects that have been added to the spec. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Float_Type is digits <>; + +package Ada.Numerics.Generic_Elementary_Functions with + SPARK_Mode => On +is + pragma Pure; + + -- Preconditions in this unit are meant for analysis only, not for run-time + -- checking, so that the expected exceptions are raised when calling + -- Assert. This is enforced by setting the corresponding assertion policy + -- to Ignore. This is done in the generic spec so that it applies to all + -- instances. + + pragma Assertion_Policy (Pre => Ignore); + + function Sqrt (X : Float_Type'Base) return Float_Type'Base with + Pre => X >= 0.0, + Post => Sqrt'Result >= 0.0 + and then (if X = 0.0 then Sqrt'Result = 0.0) + and then (if X = 1.0 then Sqrt'Result = 1.0) + + -- Finally if X is positive, the result of Sqrt is positive (because + -- the sqrt of numbers greater than 1 is greater than or equal to 1, + -- and the sqrt of numbers less than 1 is greater than the argument). + + -- This property is useful in particular for static analysis. The + -- property that X is positive is not expressed as (X > 0.0), as + -- the value X may be held in registers that have larger range and + -- precision on some architecture (for example, on x86 using x387 + -- FPU, as opposed to SSE2). So, it might be possible for X to be + -- 2.0**(-5000) or so, which could cause the number to compare as + -- greater than 0, but Sqrt would still return a zero result. + + -- Note: we use the comparison with Succ (0.0) here because this is + -- more amenable to CodePeer analysis than the use of 'Machine. + + and then (if X >= Float_Type'Succ (0.0) then Sqrt'Result > 0.0); + + function Log (X : Float_Type'Base) return Float_Type'Base with + Pre => X > 0.0, + Post => (if X = 1.0 then Log'Result = 0.0); + + function Log (X, Base : Float_Type'Base) return Float_Type'Base with + Pre => X > 0.0 and Base > 0.0 and Base /= 1.0, + Post => (if X = 1.0 then Log'Result = 0.0); + + function Exp (X : Float_Type'Base) return Float_Type'Base with + Post => (if X = 0.0 then Exp'Result = 1.0); + + function "**" (Left, Right : Float_Type'Base) return Float_Type'Base with + Pre => (if Left = 0.0 then Right > 0.0) and Left >= 0.0, + Post => "**"'Result >= 0.0 + and then (if Right = 0.0 then "**"'Result = 1.0) + and then (if Right = 1.0 then "**"'Result = Left) + and then (if Left = 1.0 then "**"'Result = 1.0) + and then (if Left = 0.0 then "**"'Result = 0.0); + + function Sin (X : Float_Type'Base) return Float_Type'Base with + Post => Sin'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Sin'Result = 0.0); + + function Sin (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0, + Post => Sin'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Sin'Result = 0.0); + + function Cos (X : Float_Type'Base) return Float_Type'Base with + Post => Cos'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Cos'Result = 1.0); + + function Cos (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0, + Post => Cos'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Cos'Result = 1.0); + + function Tan (X : Float_Type'Base) return Float_Type'Base with + Post => (if X = 0.0 then Tan'Result = 0.0); + + function Tan (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 + and then abs Float_Type'Base'Remainder (X, Cycle) /= 0.25 * Cycle, + Post => (if X = 0.0 then Tan'Result = 0.0); + + function Cot (X : Float_Type'Base) return Float_Type'Base with + Pre => X /= 0.0; + + function Cot (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 + and then X /= 0.0 + and then Float_Type'Base'Remainder (X, Cycle) /= 0.0 + and then abs Float_Type'Base'Remainder (X, Cycle) = 0.5 * Cycle; + + function Arcsin (X : Float_Type'Base) return Float_Type'Base with + Pre => abs X <= 1.0, + Post => (if X = 0.0 then Arcsin'Result = 0.0); + + function Arcsin (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 and abs X <= 1.0, + Post => (if X = 0.0 then Arcsin'Result = 0.0); + + function Arccos (X : Float_Type'Base) return Float_Type'Base with + Pre => abs X <= 1.0, + Post => (if X = 1.0 then Arccos'Result = 0.0); + + function Arccos (X, Cycle : Float_Type'Base) return Float_Type'Base with + Pre => Cycle > 0.0 and abs X <= 1.0, + Post => (if X = 1.0 then Arccos'Result = 0.0); + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0) return Float_Type'Base + with + Pre => X /= 0.0 or Y /= 0.0, + Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0); + + function Arctan + (Y : Float_Type'Base; + X : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) return Float_Type'Base + with + Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0), + Post => (if X > 0.0 and then Y = 0.0 then Arctan'Result = 0.0); + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0) return Float_Type'Base + with + Pre => X /= 0.0 or Y /= 0.0, + Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0); + + function Arccot + (X : Float_Type'Base; + Y : Float_Type'Base := 1.0; + Cycle : Float_Type'Base) return Float_Type'Base + with + Pre => Cycle > 0.0 and (X /= 0.0 or Y /= 0.0), + Post => (if X > 0.0 and then Y = 0.0 then Arccot'Result = 0.0); + + function Sinh (X : Float_Type'Base) return Float_Type'Base with + Post => (if X = 0.0 then Sinh'Result = 0.0); + + function Cosh (X : Float_Type'Base) return Float_Type'Base with + Post => Cosh'Result >= 1.0 + and then (if X = 0.0 then Cosh'Result = 1.0); + + function Tanh (X : Float_Type'Base) return Float_Type'Base with + Post => Tanh'Result in -1.0 .. 1.0 + and then (if X = 0.0 then Tanh'Result = 0.0); + + function Coth (X : Float_Type'Base) return Float_Type'Base with + Pre => X /= 0.0, + Post => abs Coth'Result >= 1.0; + + function Arcsinh (X : Float_Type'Base) return Float_Type'Base with + Post => (if X = 0.0 then Arcsinh'Result = 0.0); + + function Arccosh (X : Float_Type'Base) return Float_Type'Base with + Pre => X >= 1.0, + Post => Arccosh'Result >= 0.0 + and then (if X = 1.0 then Arccosh'Result = 0.0); + + function Arctanh (X : Float_Type'Base) return Float_Type'Base with + Pre => abs X /= 1.0, + Post => (if X = 0.0 then Arctanh'Result = 0.0); + + function Arccoth (X : Float_Type'Base) return Float_Type'Base with + Pre => X <= 1.0 and abs X /= 1.0; + +end Ada.Numerics.Generic_Elementary_Functions; diff --git a/gcc/ada/libgnat/a-ngrear.adb b/gcc/ada/libgnat/a-ngrear.adb new file mode 100644 index 0000000..258f3cb --- /dev/null +++ b/gcc/ada/libgnat/a-ngrear.adb @@ -0,0 +1,777 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_REAL_ARRAYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of Generic_Real_Arrays avoids the use of BLAS and LAPACK. One +-- reason for this is new Ada 2012 requirements that prohibit algorithms such +-- as Strassen's algorithm, which may be used by some BLAS implementations. In +-- addition, some platforms lacked suitable compilers to compile the reference +-- BLAS/LAPACK implementation. Finally, on some platforms there are more +-- floating point types than supported by BLAS/LAPACK. + +with Ada.Containers.Generic_Anonymous_Array_Sort; use Ada.Containers; + +with System; use System; +with System.Generic_Array_Operations; use System.Generic_Array_Operations; + +package body Ada.Numerics.Generic_Real_Arrays is + + package Ops renames System.Generic_Array_Operations; + + function Is_Non_Zero (X : Real'Base) return Boolean is (X /= 0.0); + + procedure Back_Substitute is new Ops.Back_Substitute + (Scalar => Real'Base, + Matrix => Real_Matrix, + Is_Non_Zero => Is_Non_Zero); + + function Diagonal is new Ops.Diagonal + (Scalar => Real'Base, + Vector => Real_Vector, + Matrix => Real_Matrix); + + procedure Forward_Eliminate is new Ops.Forward_Eliminate + (Scalar => Real'Base, + Real => Real'Base, + Matrix => Real_Matrix, + Zero => 0.0, + One => 1.0); + + procedure Swap_Column is new Ops.Swap_Column + (Scalar => Real'Base, + Matrix => Real_Matrix); + + procedure Transpose is new Ops.Transpose + (Scalar => Real'Base, + Matrix => Real_Matrix); + + function Is_Symmetric (A : Real_Matrix) return Boolean is + (Transpose (A) = A); + -- Return True iff A is symmetric, see RM G.3.1 (90). + + function Is_Tiny (Value, Compared_To : Real) return Boolean is + (abs Compared_To + 100.0 * abs (Value) = abs Compared_To); + -- Return True iff the Value is much smaller in magnitude than the least + -- significant digit of Compared_To. + + procedure Jacobi + (A : Real_Matrix; + Values : out Real_Vector; + Vectors : out Real_Matrix; + Compute_Vectors : Boolean := True); + -- Perform Jacobi's eigensystem algorithm on real symmetric matrix A + + function Length is new Square_Matrix_Length (Real'Base, Real_Matrix); + -- Helper function that raises a Constraint_Error is the argument is + -- not a square matrix, and otherwise returns its length. + + procedure Rotate (X, Y : in out Real; Sin, Tau : Real); + -- Perform a Givens rotation + + procedure Sort_Eigensystem + (Values : in out Real_Vector; + Vectors : in out Real_Matrix); + -- Sort Values and associated Vectors by decreasing absolute value + + procedure Swap (Left, Right : in out Real); + -- Exchange Left and Right + + function Sqrt is new Ops.Sqrt (Real); + -- Instant a generic square root implementation here, in order to avoid + -- instantiating a complete copy of Generic_Elementary_Functions. + -- Speed of the square root is not a big concern here. + + ------------ + -- Rotate -- + ------------ + + procedure Rotate (X, Y : in out Real; Sin, Tau : Real) is + Old_X : constant Real := X; + Old_Y : constant Real := Y; + begin + X := Old_X - Sin * (Old_Y + Old_X * Tau); + Y := Old_Y + Sin * (Old_X - Old_Y * Tau); + end Rotate; + + ---------- + -- Swap -- + ---------- + + procedure Swap (Left, Right : in out Real) is + Temp : constant Real := Left; + begin + Left := Right; + Right := Temp; + end Swap; + + -- Instantiating the following subprograms directly would lead to + -- name clashes, so use a local package. + + package Instantiations is + + function "+" is new + Vector_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Real'Base, + X_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "+"); + + function "+" is new + Matrix_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Real'Base, + X_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "+"); + + function "+" is new + Vector_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Right_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "+"); + + function "+" is new + Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Matrix => Real_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "+"); + + function "-" is new + Vector_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Real'Base, + X_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "-"); + + function "-" is new + Matrix_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Real'Base, + X_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "-"); + + function "-" is new + Vector_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Right_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "-"); + + function "-" is new + Matrix_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Matrix => Real_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "-"); + + function "*" is new + Scalar_Vector_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Right_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "*"); + + function "*" is new + Scalar_Matrix_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Right_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "*"); + + function "*" is new + Vector_Scalar_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "*"); + + function "*" is new + Matrix_Scalar_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "*"); + + function "*" is new + Outer_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Right_Vector => Real_Vector, + Matrix => Real_Matrix); + + function "*" is new + Inner_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Right_Vector => Real_Vector, + Zero => 0.0); + + function "*" is new + Matrix_Vector_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Matrix => Real_Matrix, + Right_Vector => Real_Vector, + Result_Vector => Real_Vector, + Zero => 0.0); + + function "*" is new + Vector_Matrix_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Matrix => Real_Matrix, + Result_Vector => Real_Vector, + Zero => 0.0); + + function "*" is new + Matrix_Matrix_Product + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Matrix => Real_Matrix, + Right_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Zero => 0.0); + + function "/" is new + Vector_Scalar_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "/"); + + function "/" is new + Matrix_Scalar_Elementwise_Operation + (Left_Scalar => Real'Base, + Right_Scalar => Real'Base, + Result_Scalar => Real'Base, + Left_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "/"); + + function "abs" is new + L2_Norm + (X_Scalar => Real'Base, + Result_Real => Real'Base, + X_Vector => Real_Vector, + "abs" => "+"); + -- While the L2_Norm by definition uses the absolute values of the + -- elements of X_Vector, for real values the subsequent squaring + -- makes this unnecessary, so we substitute the "+" identity function + -- instead. + + function "abs" is new + Vector_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Real'Base, + X_Vector => Real_Vector, + Result_Vector => Real_Vector, + Operation => "abs"); + + function "abs" is new + Matrix_Elementwise_Operation + (X_Scalar => Real'Base, + Result_Scalar => Real'Base, + X_Matrix => Real_Matrix, + Result_Matrix => Real_Matrix, + Operation => "abs"); + + function Solve is new + Matrix_Vector_Solution (Real'Base, 0.0, Real_Vector, Real_Matrix); + + function Solve is new + Matrix_Matrix_Solution (Real'Base, 0.0, Real_Matrix); + + function Unit_Matrix is new + Generic_Array_Operations.Unit_Matrix + (Scalar => Real'Base, + Matrix => Real_Matrix, + Zero => 0.0, + One => 1.0); + + function Unit_Vector is new + Generic_Array_Operations.Unit_Vector + (Scalar => Real'Base, + Vector => Real_Vector, + Zero => 0.0, + One => 1.0); + + end Instantiations; + + --------- + -- "+" -- + --------- + + function "+" (Right : Real_Vector) return Real_Vector + renames Instantiations."+"; + + function "+" (Right : Real_Matrix) return Real_Matrix + renames Instantiations."+"; + + function "+" (Left, Right : Real_Vector) return Real_Vector + renames Instantiations."+"; + + function "+" (Left, Right : Real_Matrix) return Real_Matrix + renames Instantiations."+"; + + --------- + -- "-" -- + --------- + + function "-" (Right : Real_Vector) return Real_Vector + renames Instantiations."-"; + + function "-" (Right : Real_Matrix) return Real_Matrix + renames Instantiations."-"; + + function "-" (Left, Right : Real_Vector) return Real_Vector + renames Instantiations."-"; + + function "-" (Left, Right : Real_Matrix) return Real_Matrix + renames Instantiations."-"; + + --------- + -- "*" -- + --------- + + -- Scalar multiplication + + function "*" (Left : Real'Base; Right : Real_Vector) return Real_Vector + renames Instantiations."*"; + + function "*" (Left : Real_Vector; Right : Real'Base) return Real_Vector + renames Instantiations."*"; + + function "*" (Left : Real'Base; Right : Real_Matrix) return Real_Matrix + renames Instantiations."*"; + + function "*" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix + renames Instantiations."*"; + + -- Vector multiplication + + function "*" (Left, Right : Real_Vector) return Real'Base + renames Instantiations."*"; + + function "*" (Left, Right : Real_Vector) return Real_Matrix + renames Instantiations."*"; + + function "*" (Left : Real_Vector; Right : Real_Matrix) return Real_Vector + renames Instantiations."*"; + + function "*" (Left : Real_Matrix; Right : Real_Vector) return Real_Vector + renames Instantiations."*"; + + -- Matrix Multiplication + + function "*" (Left, Right : Real_Matrix) return Real_Matrix + renames Instantiations."*"; + + --------- + -- "/" -- + --------- + + function "/" (Left : Real_Vector; Right : Real'Base) return Real_Vector + renames Instantiations."/"; + + function "/" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix + renames Instantiations."/"; + + ----------- + -- "abs" -- + ----------- + + function "abs" (Right : Real_Vector) return Real'Base + renames Instantiations."abs"; + + function "abs" (Right : Real_Vector) return Real_Vector + renames Instantiations."abs"; + + function "abs" (Right : Real_Matrix) return Real_Matrix + renames Instantiations."abs"; + + ----------------- + -- Determinant -- + ----------------- + + function Determinant (A : Real_Matrix) return Real'Base is + M : Real_Matrix := A; + B : Real_Matrix (A'Range (1), 1 .. 0); + R : Real'Base; + begin + Forward_Eliminate (M, B, R); + return R; + end Determinant; + + ----------------- + -- Eigensystem -- + ----------------- + + procedure Eigensystem + (A : Real_Matrix; + Values : out Real_Vector; + Vectors : out Real_Matrix) + is + begin + Jacobi (A, Values, Vectors, Compute_Vectors => True); + Sort_Eigensystem (Values, Vectors); + end Eigensystem; + + ----------------- + -- Eigenvalues -- + ----------------- + + function Eigenvalues (A : Real_Matrix) return Real_Vector is + begin + return Values : Real_Vector (A'Range (1)) do + declare + Vectors : Real_Matrix (1 .. 0, 1 .. 0); + begin + Jacobi (A, Values, Vectors, Compute_Vectors => False); + Sort_Eigensystem (Values, Vectors); + end; + end return; + end Eigenvalues; + + ------------- + -- Inverse -- + ------------- + + function Inverse (A : Real_Matrix) return Real_Matrix is + (Solve (A, Unit_Matrix (Length (A), + First_1 => A'First (2), + First_2 => A'First (1)))); + + ------------ + -- Jacobi -- + ------------ + + procedure Jacobi + (A : Real_Matrix; + Values : out Real_Vector; + Vectors : out Real_Matrix; + Compute_Vectors : Boolean := True) + is + -- This subprogram uses Carl Gustav Jacob Jacobi's iterative method + -- for computing eigenvalues and eigenvectors and is based on + -- Rutishauser's implementation. + + -- The given real symmetric matrix is transformed iteratively to + -- diagonal form through a sequence of appropriately chosen elementary + -- orthogonal transformations, called Jacobi rotations here. + + -- The Jacobi method produces a systematic decrease of the sum of the + -- squares of off-diagonal elements. Convergence to zero is quadratic, + -- both for this implementation, as for the classic method that doesn't + -- use row-wise scanning for pivot selection. + + -- The numerical stability and accuracy of Jacobi's method make it the + -- best choice here, even though for large matrices other methods will + -- be significantly more efficient in both time and space. + + -- While the eigensystem computations are absolutely foolproof for all + -- real symmetric matrices, in presence of invalid values, or similar + -- exceptional situations it might not. In such cases the results cannot + -- be trusted and Constraint_Error is raised. + + -- Note: this implementation needs temporary storage for 2 * N + N**2 + -- values of type Real. + + Max_Iterations : constant := 50; + N : constant Natural := Length (A); + + subtype Square_Matrix is Real_Matrix (1 .. N, 1 .. N); + + -- In order to annihilate the M (Row, Col) element, the + -- rotation parameters Cos and Sin are computed as + -- follows: + + -- Theta = Cot (2.0 * Phi) + -- = (Diag (Col) - Diag (Row)) / (2.0 * M (Row, Col)) + + -- Then Tan (Phi) as the smaller root (in modulus) of + + -- T**2 + 2 * T * Theta = 1 (or 0.5 / Theta, if Theta is large) + + function Compute_Tan (Theta : Real) return Real is + (Real'Copy_Sign (1.0 / (abs Theta + Sqrt (1.0 + Theta**2)), Theta)); + + function Compute_Tan (P, H : Real) return Real is + (if Is_Tiny (P, Compared_To => H) then P / H + else Compute_Tan (Theta => H / (2.0 * P))); + + function Sum_Strict_Upper (M : Square_Matrix) return Real; + -- Return the sum of all elements in the strict upper triangle of M + + ---------------------- + -- Sum_Strict_Upper -- + ---------------------- + + function Sum_Strict_Upper (M : Square_Matrix) return Real is + Sum : Real := 0.0; + + begin + for Row in 1 .. N - 1 loop + for Col in Row + 1 .. N loop + Sum := Sum + abs M (Row, Col); + end loop; + end loop; + + return Sum; + end Sum_Strict_Upper; + + M : Square_Matrix := A; -- Work space for solving eigensystem + Threshold : Real; + Sum : Real; + Diag : Real_Vector (1 .. N); + Diag_Adj : Real_Vector (1 .. N); + + -- The vector Diag_Adj indicates the amount of change in each value, + -- while Diag tracks the value itself and Values holds the values as + -- they were at the beginning. As the changes typically will be small + -- compared to the absolute value of Diag, at the end of each iteration + -- Diag is computed as Diag + Diag_Adj thus avoiding accumulating + -- rounding errors. This technique is due to Rutishauser. + + begin + if Compute_Vectors + and then (Vectors'Length (1) /= N or else Vectors'Length (2) /= N) + then + raise Constraint_Error with "incompatible matrix dimensions"; + + elsif Values'Length /= N then + raise Constraint_Error with "incompatible vector length"; + + elsif not Is_Symmetric (M) then + raise Constraint_Error with "matrix not symmetric"; + end if; + + -- Note: Only the locally declared matrix M and vectors (Diag, Diag_Adj) + -- have lower bound equal to 1. The Vectors matrix may have + -- different bounds, so take care indexing elements. Assignment + -- as a whole is fine as sliding is automatic in that case. + + Vectors := (if not Compute_Vectors then (1 .. 0 => (1 .. 0 => 0.0)) + else Unit_Matrix (Vectors'Length (1), Vectors'Length (2))); + Values := Diagonal (M); + + Sweep : for Iteration in 1 .. Max_Iterations loop + + -- The first three iterations, perform rotation for any non-zero + -- element. After this, rotate only for those that are not much + -- smaller than the average off-diagnal element. After the fifth + -- iteration, additionally zero out off-diagonal elements that are + -- very small compared to elements on the diagonal with the same + -- column or row index. + + Sum := Sum_Strict_Upper (M); + + exit Sweep when Sum = 0.0; + + Threshold := (if Iteration < 4 then 0.2 * Sum / Real (N**2) else 0.0); + + -- Iterate over all off-diagonal elements, rotating any that have + -- an absolute value that exceeds the threshold. + + Diag := Values; + Diag_Adj := (others => 0.0); -- Accumulates adjustments to Diag + + for Row in 1 .. N - 1 loop + for Col in Row + 1 .. N loop + + -- If, before the rotation M (Row, Col) is tiny compared to + -- Diag (Row) and Diag (Col), rotation is skipped. This is + -- meaningful, as it produces no larger error than would be + -- produced anyhow if the rotation had been performed. + -- Suppress this optimization in the first four sweeps, so + -- that this procedure can be used for computing eigenvectors + -- of perturbed diagonal matrices. + + if Iteration > 4 + and then Is_Tiny (M (Row, Col), Compared_To => Diag (Row)) + and then Is_Tiny (M (Row, Col), Compared_To => Diag (Col)) + then + M (Row, Col) := 0.0; + + elsif abs M (Row, Col) > Threshold then + Perform_Rotation : declare + Tan : constant Real := Compute_Tan (M (Row, Col), + Diag (Col) - Diag (Row)); + Cos : constant Real := 1.0 / Sqrt (1.0 + Tan**2); + Sin : constant Real := Tan * Cos; + Tau : constant Real := Sin / (1.0 + Cos); + Adj : constant Real := Tan * M (Row, Col); + + begin + Diag_Adj (Row) := Diag_Adj (Row) - Adj; + Diag_Adj (Col) := Diag_Adj (Col) + Adj; + Diag (Row) := Diag (Row) - Adj; + Diag (Col) := Diag (Col) + Adj; + + M (Row, Col) := 0.0; + + for J in 1 .. Row - 1 loop -- 1 <= J < Row + Rotate (M (J, Row), M (J, Col), Sin, Tau); + end loop; + + for J in Row + 1 .. Col - 1 loop -- Row < J < Col + Rotate (M (Row, J), M (J, Col), Sin, Tau); + end loop; + + for J in Col + 1 .. N loop -- Col < J <= N + Rotate (M (Row, J), M (Col, J), Sin, Tau); + end loop; + + for J in Vectors'Range (1) loop + Rotate (Vectors (J, Row - 1 + Vectors'First (2)), + Vectors (J, Col - 1 + Vectors'First (2)), + Sin, Tau); + end loop; + end Perform_Rotation; + end if; + end loop; + end loop; + + Values := Values + Diag_Adj; + end loop Sweep; + + -- All normal matrices with valid values should converge perfectly. + + if Sum /= 0.0 then + raise Constraint_Error with "eigensystem solution does not converge"; + end if; + end Jacobi; + + ----------- + -- Solve -- + ----------- + + function Solve (A : Real_Matrix; X : Real_Vector) return Real_Vector + renames Instantiations.Solve; + + function Solve (A, X : Real_Matrix) return Real_Matrix + renames Instantiations.Solve; + + ---------------------- + -- Sort_Eigensystem -- + ---------------------- + + procedure Sort_Eigensystem + (Values : in out Real_Vector; + Vectors : in out Real_Matrix) + is + procedure Swap (Left, Right : Integer); + -- Swap Values (Left) with Values (Right), and also swap the + -- corresponding eigenvectors. Note that lowerbounds may differ. + + function Less (Left, Right : Integer) return Boolean is + (Values (Left) > Values (Right)); + -- Sort by decreasing eigenvalue, see RM G.3.1 (76). + + procedure Sort is new Generic_Anonymous_Array_Sort (Integer); + -- Sorts eigenvalues and eigenvectors by decreasing value + + procedure Swap (Left, Right : Integer) is + begin + Swap (Values (Left), Values (Right)); + Swap_Column (Vectors, Left - Values'First + Vectors'First (2), + Right - Values'First + Vectors'First (2)); + end Swap; + + begin + Sort (Values'First, Values'Last); + end Sort_Eigensystem; + + --------------- + -- Transpose -- + --------------- + + function Transpose (X : Real_Matrix) return Real_Matrix is + begin + return R : Real_Matrix (X'Range (2), X'Range (1)) do + Transpose (X, R); + end return; + end Transpose; + + ----------------- + -- Unit_Matrix -- + ----------------- + + function Unit_Matrix + (Order : Positive; + First_1 : Integer := 1; + First_2 : Integer := 1) return Real_Matrix + renames Instantiations.Unit_Matrix; + + ----------------- + -- Unit_Vector -- + ----------------- + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Real_Vector + renames Instantiations.Unit_Vector; + +end Ada.Numerics.Generic_Real_Arrays; diff --git a/gcc/ada/libgnat/a-ngrear.ads b/gcc/ada/libgnat/a-ngrear.ads new file mode 100644 index 0000000..0602d3e --- /dev/null +++ b/gcc/ada/libgnat/a-ngrear.ads @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.GENERIC_REAL_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Real is digits <>; +package Ada.Numerics.Generic_Real_Arrays is + pragma Pure (Generic_Real_Arrays); + + -- Types + + type Real_Vector is array (Integer range <>) of Real'Base; + type Real_Matrix is array (Integer range <>, Integer range <>) of Real'Base; + + -- Subprograms for Real_Vector types + + -- Real_Vector arithmetic operations + + function "+" (Right : Real_Vector) return Real_Vector; + function "-" (Right : Real_Vector) return Real_Vector; + function "abs" (Right : Real_Vector) return Real_Vector; + + function "+" (Left, Right : Real_Vector) return Real_Vector; + function "-" (Left, Right : Real_Vector) return Real_Vector; + + function "*" (Left, Right : Real_Vector) return Real'Base; + + function "abs" (Right : Real_Vector) return Real'Base; + + -- Real_Vector scaling operations + + function "*" (Left : Real'Base; Right : Real_Vector) return Real_Vector; + function "*" (Left : Real_Vector; Right : Real'Base) return Real_Vector; + function "/" (Left : Real_Vector; Right : Real'Base) return Real_Vector; + + -- Other Real_Vector operations + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Real_Vector; + + -- Subprograms for Real_Matrix types + + -- Real_Matrix arithmetic operations + + function "+" (Right : Real_Matrix) return Real_Matrix; + function "-" (Right : Real_Matrix) return Real_Matrix; + function "abs" (Right : Real_Matrix) return Real_Matrix; + function Transpose (X : Real_Matrix) return Real_Matrix; + + function "+" (Left, Right : Real_Matrix) return Real_Matrix; + function "-" (Left, Right : Real_Matrix) return Real_Matrix; + function "*" (Left, Right : Real_Matrix) return Real_Matrix; + + function "*" (Left, Right : Real_Vector) return Real_Matrix; + + function "*" (Left : Real_Vector; Right : Real_Matrix) return Real_Vector; + function "*" (Left : Real_Matrix; Right : Real_Vector) return Real_Vector; + + -- Real_Matrix scaling operations + + function "*" (Left : Real'Base; Right : Real_Matrix) return Real_Matrix; + function "*" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix; + function "/" (Left : Real_Matrix; Right : Real'Base) return Real_Matrix; + + -- Real_Matrix inversion and related operations + + function Solve (A : Real_Matrix; X : Real_Vector) return Real_Vector; + function Solve (A, X : Real_Matrix) return Real_Matrix; + function Inverse (A : Real_Matrix) return Real_Matrix; + function Determinant (A : Real_Matrix) return Real'Base; + + -- Eigenvalues and vectors of a real symmetric matrix + + function Eigenvalues (A : Real_Matrix) return Real_Vector; + + procedure Eigensystem + (A : Real_Matrix; + Values : out Real_Vector; + Vectors : out Real_Matrix); + + -- Other Real_Matrix operations + + function Unit_Matrix + (Order : Positive; + First_1 : Integer := 1; + First_2 : Integer := 1) return Real_Matrix; + +private + -- The following operations are either relatively simple compared to the + -- expense of returning unconstrained arrays, or are just function wrappers + -- calling procedures implementing the actual operation. By having the + -- front end inline these, the expense of the unconstrained returns + -- can be avoided. + + -- Note: We use an extended return statement in their implementation to + -- allow the frontend to inline these functions. + + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline ("*"); + pragma Inline ("/"); + pragma Inline ("abs"); + pragma Inline (Eigenvalues); + pragma Inline (Inverse); + pragma Inline (Solve); + pragma Inline (Transpose); + pragma Inline (Unit_Matrix); + pragma Inline (Unit_Vector); +end Ada.Numerics.Generic_Real_Arrays; diff --git a/gcc/ada/libgnat/a-nlcefu.ads b/gcc/ada/libgnat/a-nlcefu.ads new file mode 100644 index 0000000..083f6a9 --- /dev/null +++ b/gcc/ada/libgnat/a-nlcefu.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Long_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Long_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Long_Complex_Types); +pragma Pure (Ada.Numerics.Long_Complex_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nlcoar.ads b/gcc/ada/libgnat/a-nlcoar.ads new file mode 100644 index 0000000..35e97a5 --- /dev/null +++ b/gcc/ada/libgnat/a-nlcoar.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_COMPLEX_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Arrays; +with Ada.Numerics.Long_Real_Arrays; +with Ada.Numerics.Long_Complex_Types; + +package Ada.Numerics.Long_Complex_Arrays is new + Ada.Numerics.Generic_Complex_Arrays (Long_Real_Arrays, Long_Complex_Types); + +pragma Pure (Long_Complex_Arrays); diff --git a/gcc/ada/libgnat/a-nlcoty.ads b/gcc/ada/libgnat/a-nlcoty.ads new file mode 100644 index 0000000..6eb4fc3 --- /dev/null +++ b/gcc/ada/libgnat/a-nlcoty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Long_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Long_Float); + +pragma Pure (Long_Complex_Types); diff --git a/gcc/ada/libgnat/a-nlelfu.ads b/gcc/ada/libgnat/a-nlelfu.ads new file mode 100644 index 0000000..10b33e9 --- /dev/null +++ b/gcc/ada/libgnat/a-nlelfu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Long_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Long_Float); + +pragma Pure (Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nllcar.ads b/gcc/ada/libgnat/a-nllcar.ads new file mode 100644 index 0000000..48fd91a --- /dev/null +++ b/gcc/ada/libgnat/a-nllcar.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_COMPLEX_ARRAYS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Arrays; +with Ada.Numerics.Long_Long_Real_Arrays; +with Ada.Numerics.Long_Long_Complex_Types; + +package Ada.Numerics.Long_Long_Complex_Arrays is + new Ada.Numerics.Generic_Complex_Arrays (Long_Long_Real_Arrays, + Long_Long_Complex_Types); + +pragma Pure (Long_Long_Complex_Arrays); diff --git a/gcc/ada/libgnat/a-nllcef.ads b/gcc/ada/libgnat/a-nllcef.ads new file mode 100644 index 0000000..7a1f4b1 --- /dev/null +++ b/gcc/ada/libgnat/a-nllcef.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Long_Long_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Long_Long_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Long_Long_Complex_Types); +pragma Pure (Ada.Numerics.Long_Long_Complex_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nllcty.ads b/gcc/ada/libgnat/a-nllcty.ads new file mode 100644 index 0000000..a6081c2 --- /dev/null +++ b/gcc/ada/libgnat/a-nllcty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ L O N G _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Long_Long_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Long_Long_Float); + +pragma Pure (Long_Long_Complex_Types); diff --git a/gcc/ada/libgnat/a-nllefu.ads b/gcc/ada/libgnat/a-nllefu.ads new file mode 100644 index 0000000..7089fc3 --- /dev/null +++ b/gcc/ada/libgnat/a-nllefu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.LONG_LONG_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Long_Long_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Long_Long_Float); + +pragma Pure (Long_Long_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nllrar.ads b/gcc/ada/libgnat/a-nllrar.ads new file mode 100644 index 0000000..62a2457 --- /dev/null +++ b/gcc/ada/libgnat/a-nllrar.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ L O N G _R E A L _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays; + +package Ada.Numerics.Long_Long_Real_Arrays is + new Ada.Numerics.Generic_Real_Arrays (Long_Long_Float); + +pragma Pure (Long_Long_Real_Arrays); diff --git a/gcc/ada/libgnat/a-nlrear.ads b/gcc/ada/libgnat/a-nlrear.ads new file mode 100644 index 0000000..990c39b --- /dev/null +++ b/gcc/ada/libgnat/a-nlrear.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . L O N G _ R E A L _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays; + +package Ada.Numerics.Long_Real_Arrays is + new Ada.Numerics.Generic_Real_Arrays (Long_Float); + +pragma Pure (Long_Real_Arrays); diff --git a/gcc/ada/libgnat/a-nscefu.ads b/gcc/ada/libgnat/a-nscefu.ads new file mode 100644 index 0000000..0d0aa15 --- /dev/null +++ b/gcc/ada/libgnat/a-nscefu.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.SHORT.COMPLEX.ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Short_Complex_Types; +with Ada.Numerics.Generic_Complex_Elementary_Functions; + +package Ada.Numerics.Short_Complex_Elementary_Functions is + new Ada.Numerics.Generic_Complex_Elementary_Functions + (Ada.Numerics.Short_Complex_Types); +pragma Pure (Ada.Numerics.Short_Complex_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nscoty.ads b/gcc/ada/libgnat/a-nscoty.ads new file mode 100644 index 0000000..e58b0b5 --- /dev/null +++ b/gcc/ada/libgnat/a-nscoty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . S H O R T _ C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Short_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Short_Float); + +pragma Pure (Short_Complex_Types); diff --git a/gcc/ada/libgnat/a-nselfu.ads b/gcc/ada/libgnat/a-nselfu.ads new file mode 100644 index 0000000..10b04ac --- /dev/null +++ b/gcc/ada/libgnat/a-nselfu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.NUMERICS.SHORT_ELEMENTARY_FUNCTIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Short_Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Short_Float); + +pragma Pure (Short_Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nucoar.ads b/gcc/ada/libgnat/a-nucoar.ads new file mode 100644 index 0000000..665d02d --- /dev/null +++ b/gcc/ada/libgnat/a-nucoar.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . C O M P L E X _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Arrays; +with Ada.Numerics.Real_Arrays; +with Ada.Numerics.Complex_Types; + +package Ada.Numerics.Complex_Arrays is + new Ada.Numerics.Generic_Complex_Arrays (Real_Arrays, Complex_Types); + +pragma Pure (Complex_Arrays); diff --git a/gcc/ada/libgnat/a-nucoty.ads b/gcc/ada/libgnat/a-nucoty.ads new file mode 100644 index 0000000..3b04a27 --- /dev/null +++ b/gcc/ada/libgnat/a-nucoty.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . C O M P L E X _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +package Ada.Numerics.Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Float); + +pragma Pure (Complex_Types); diff --git a/gcc/ada/libgnat/a-nudira.adb b/gcc/ada/libgnat/a-nudira.adb new file mode 100644 index 0000000..2f065f5 --- /dev/null +++ b/gcc/ada/libgnat/a-nudira.adb @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Numerics.Discrete_Random with + SPARK_Mode => Off +is + + package SRN renames System.Random_Numbers; + use SRN; + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Image (SRN.State (Of_State)); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Result_Subtype is + function Random is + new SRN.Random_Discrete (Result_Subtype, Result_Subtype'First); + begin + return Random (SRN.Generator (Gen)); + end Random; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator) is + begin + Reset (SRN.Generator (Gen)); + end Reset; + + procedure Reset (Gen : Generator; Initiator : Integer) is + begin + Reset (SRN.Generator (Gen), Initiator); + end Reset; + + procedure Reset (Gen : Generator; From_State : State) is + begin + Reset (SRN.Generator (Gen), SRN.State (From_State)); + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + Save (SRN.Generator (Gen), SRN.State (To_State)); + end Save; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + begin + return State (SRN.State'(Value (Coded_State))); + end Value; + +end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/libgnat/a-nudira.ads b/gcc/ada/libgnat/a-nudira.ads new file mode 100644 index 0000000..b957f47 --- /dev/null +++ b/gcc/ada/libgnat/a-nudira.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . D I S C R E T E _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the implementation used in this package is a version of the +-- Mersenne Twister. See s-rannum.adb for details and references. + +with System.Random_Numbers; + +generic + type Result_Subtype is (<>); + +package Ada.Numerics.Discrete_Random with + SPARK_Mode => Off +is + + -- Basic facilities + + type Generator is limited private; + + function Random (Gen : Generator) return Result_Subtype; + + procedure Reset (Gen : Generator; Initiator : Integer); + procedure Reset (Gen : Generator); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + + type Generator is new System.Random_Numbers.Generator; + + type State is new System.Random_Numbers.State; + +end Ada.Numerics.Discrete_Random; diff --git a/gcc/ada/libgnat/a-nuelfu.ads b/gcc/ada/libgnat/a-nuelfu.ads new file mode 100644 index 0000000..149939b --- /dev/null +++ b/gcc/ada/libgnat/a-nuelfu.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . E L E M E N T A R Y _ F U N C T I O N S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Elementary_Functions; + +package Ada.Numerics.Elementary_Functions is + new Ada.Numerics.Generic_Elementary_Functions (Float); + +pragma Pure (Elementary_Functions); diff --git a/gcc/ada/libgnat/a-nuflra.adb b/gcc/ada/libgnat/a-nuflra.adb new file mode 100644 index 0000000..eb58a7b --- /dev/null +++ b/gcc/ada/libgnat/a-nuflra.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . F L O A T _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Numerics.Float_Random with + SPARK_Mode => Off +is + + package SRN renames System.Random_Numbers; + use SRN; + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Image (SRN.State (Of_State)); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Uniformly_Distributed is + begin + return Random (SRN.Generator (Gen)); + end Random; + + ----------- + -- Reset -- + ----------- + + -- Version that works from calendar + + procedure Reset (Gen : Generator) is + begin + Reset (SRN.Generator (Gen)); + end Reset; + + -- Version that works from given initiator value + + procedure Reset (Gen : Generator; Initiator : Integer) is + begin + Reset (SRN.Generator (Gen), Initiator); + end Reset; + + -- Version that works from specific saved state + + procedure Reset (Gen : Generator; From_State : State) is + begin + Reset (SRN.Generator (Gen), From_State); + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + Save (SRN.Generator (Gen), To_State); + end Save; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + G : SRN.Generator; + S : SRN.State; + begin + Reset (G, Coded_State); + Save (G, S); + return State (S); + end Value; + +end Ada.Numerics.Float_Random; diff --git a/gcc/ada/libgnat/a-nuflra.ads b/gcc/ada/libgnat/a-nuflra.ads new file mode 100644 index 0000000..d1eedbc --- /dev/null +++ b/gcc/ada/libgnat/a-nuflra.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . F L O A T _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the implementation used in this package is a version of the +-- Mersenne Twister. See s-rannum.adb for details and references. + +with System.Random_Numbers; + +package Ada.Numerics.Float_Random with + SPARK_Mode => Off +is + + -- Basic facilities + + type Generator is limited private; + + subtype Uniformly_Distributed is Float range 0.0 .. 1.0; + + function Random (Gen : Generator) return Uniformly_Distributed; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + + type Generator is new System.Random_Numbers.Generator; + + type State is new System.Random_Numbers.State; + +end Ada.Numerics.Float_Random; diff --git a/gcc/ada/libgnat/a-numaux-darwin.adb b/gcc/ada/libgnat/a-numaux-darwin.adb new file mode 100644 index 0000000..88e9e7c --- /dev/null +++ b/gcc/ada/libgnat/a-numaux-darwin.adb @@ -0,0 +1,211 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- B o d y -- +-- (Apple OS X Version) -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Numerics.Aux is + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Is_Nan (X : Double) return Boolean; + -- Return True iff X is a IEEE NaN value + + procedure Reduce (X : in out Double; Q : out Natural); + -- Implement reduction of X by Pi/2. Q is the quadrant of the final + -- result in the range 0..3. The absolute value of X is at most Pi/4. + -- It is needed to avoid a loss of accuracy for sin near Pi and cos + -- near Pi/2 due to the use of an insufficiently precise value of Pi + -- in the range reduction. + + -- The following two functions implement Chebishev approximations + -- of the trigonometric functions in their reduced domain. + -- These approximations have been computed using Maple. + + function Sine_Approx (X : Double) return Double; + function Cosine_Approx (X : Double) return Double; + + pragma Inline (Reduce); + pragma Inline (Sine_Approx); + pragma Inline (Cosine_Approx); + + ------------------- + -- Cosine_Approx -- + ------------------- + + function Cosine_Approx (X : Double) return Double is + XX : constant Double := X * X; + begin + return (((((16#8.DC57FBD05F640#E-08 * XX + - 16#4.9F7D00BF25D80#E-06) * XX + + 16#1.A019F7FDEFCC2#E-04) * XX + - 16#5.B05B058F18B20#E-03) * XX + + 16#A.AAAAAAAA73FA8#E-02) * XX + - 16#7.FFFFFFFFFFDE4#E-01) * XX + - 16#3.655E64869ECCE#E-14 + 1.0; + end Cosine_Approx; + + ----------------- + -- Sine_Approx -- + ----------------- + + function Sine_Approx (X : Double) return Double is + XX : constant Double := X * X; + begin + return (((((16#A.EA2D4ABE41808#E-09 * XX + - 16#6.B974C10F9D078#E-07) * XX + + 16#2.E3BC673425B0E#E-05) * XX + - 16#D.00D00CCA7AF00#E-04) * XX + + 16#2.222222221B190#E-02) * XX + - 16#2.AAAAAAAAAAA44#E-01) * (XX * X) + X; + end Sine_Approx; + + ------------ + -- Is_Nan -- + ------------ + + function Is_Nan (X : Double) return Boolean is + begin + -- The IEEE NaN values are the only ones that do not equal themselves + + return X /= X; + end Is_Nan; + + ------------ + -- Reduce -- + ------------ + + procedure Reduce (X : in out Double; Q : out Natural) is + Half_Pi : constant := Pi / 2.0; + Two_Over_Pi : constant := 2.0 / Pi; + + HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); + M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant + P1 : constant Double := Double'Leading_Part (Half_Pi, HM); + P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); + P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); + P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); + P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 + - P4, HM); + P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); + K : Double; + R : Integer; + + begin + -- For X < 2.0**HM, all products below are computed exactly. + -- Due to cancellation effects all subtractions are exact as well. + -- As no double extended floating-point number has more than 75 + -- zeros after the binary point, the result will be the correctly + -- rounded result of X - K * (Pi / 2.0). + + K := X * Two_Over_Pi; + while abs K >= 2.0**HM loop + K := K * M - (K * M - K); + X := + (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + K := X * Two_Over_Pi; + end loop; + + -- If K is not a number (because X was not finite) raise exception + + if Is_Nan (K) then + raise Constraint_Error; + end if; + + -- Go through an integer temporary so as to use machine instructions + + R := Integer (Double'Rounding (K)); + Q := R mod 4; + K := Double (R); + X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + end Reduce; + + --------- + -- Cos -- + --------- + + function Cos (X : Double) return Double is + Reduced_X : Double := abs X; + Quadrant : Natural range 0 .. 3; + + begin + if Reduced_X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + return Cosine_Approx (Reduced_X); + + when 1 => + return Sine_Approx (-Reduced_X); + + when 2 => + return -Cosine_Approx (Reduced_X); + + when 3 => + return Sine_Approx (Reduced_X); + end case; + end if; + + return Cosine_Approx (Reduced_X); + end Cos; + + --------- + -- Sin -- + --------- + + function Sin (X : Double) return Double is + Reduced_X : Double := X; + Quadrant : Natural range 0 .. 3; + + begin + if abs X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + return Sine_Approx (Reduced_X); + + when 1 => + return Cosine_Approx (Reduced_X); + + when 2 => + return Sine_Approx (-Reduced_X); + + when 3 => + return -Cosine_Approx (Reduced_X); + end case; + end if; + + return Sine_Approx (Reduced_X); + end Sin; + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-darwin.ads b/gcc/ada/libgnat/a-numaux-darwin.ads new file mode 100644 index 0000000..5767f4d --- /dev/null +++ b/gcc/ada/libgnat/a-numaux-darwin.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (Apple OS X Version) -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 use on OS X. It uses the normal Unix math functions, +-- except for sine/cosine which have been implemented directly in Ada to get +-- the required accuracy. + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is new Long_Float; + -- Type Double is the type used to call the C routines + + -- The following functions have been implemented in Ada, since + -- the OS X math library didn't meet accuracy requirements for + -- argument reduction. The implementation here has been tailored + -- to match Ada strict mode Numerics requirements while maintaining + -- maximum efficiency. + function Sin (X : Double) return Double; + pragma Inline (Sin); + + function Cos (X : Double) return Double; + pragma Inline (Cos); + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-libc-x86.ads b/gcc/ada/libgnat/a-numaux-libc-x86.ads new file mode 100644 index 0000000..e6adf21 --- /dev/null +++ b/gcc/ada/libgnat/a-numaux-libc-x86.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version for x86) -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 the x86 using the 80-bit x86 long double format + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is new Long_Long_Float; + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sinl"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cosl"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tanl"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "expl"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrtl"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "logl"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acosl"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asinl"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atanl"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinhl"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "coshl"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanhl"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "powl"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-vxworks.ads b/gcc/ada/libgnat/a-numaux-vxworks.ads new file mode 100644 index 0000000..31f57c0 --- /dev/null +++ b/gcc/ada/libgnat/a-numaux-vxworks.ads @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version, VxWorks) -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version for use on VxWorks (where we have no libm.a library), so the pragma +-- Linker_Options ("-lm") is omitted in this version. + +package Ada.Numerics.Aux is + pragma Pure; + + type Double is new Long_Float; + -- Type Double is the type used to call the C routines + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-x86.adb b/gcc/ada/libgnat/a-numaux-x86.adb new file mode 100644 index 0000000..303b729 --- /dev/null +++ b/gcc/ada/libgnat/a-numaux-x86.adb @@ -0,0 +1,577 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- B o d y -- +-- (Machine Version for x86) -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Machine_Code; use System.Machine_Code; + +package body Ada.Numerics.Aux is + + NL : constant String := ASCII.LF & ASCII.HT; + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Is_Nan (X : Double) return Boolean; + -- Return True iff X is a IEEE NaN value + + function Logarithmic_Pow (X, Y : Double) return Double; + -- Implementation of X**Y using Exp and Log functions (binary base) + -- to calculate the exponentiation. This is used by Pow for values + -- for values of Y in the open interval (-0.25, 0.25) + + procedure Reduce (X : in out Double; Q : out Natural); + -- Implement reduction of X by Pi/2. Q is the quadrant of the final + -- result in the range 0..3. The absolute value of X is at most Pi/4. + -- It is needed to avoid a loss of accuracy for sin near Pi and cos + -- near Pi/2 due to the use of an insufficiently precise value of Pi + -- in the range reduction. + + pragma Inline (Is_Nan); + pragma Inline (Reduce); + + -------------------------------- + -- Basic Elementary Functions -- + -------------------------------- + + -- This section implements a few elementary functions that are used to + -- build the more complex ones. This ordering enables better inlining. + + ---------- + -- Atan -- + ---------- + + function Atan (X : Double) return Double is + Result : Double; + + begin + Asm (Template => + "fld1" & NL + & "fpatan", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + + -- The result value is NaN iff input was invalid + + if not (Result = Result) then + raise Argument_Error; + end if; + + return Result; + end Atan; + + --------- + -- Exp -- + --------- + + function Exp (X : Double) return Double is + Result : Double; + begin + Asm (Template => + "fldl2e " & NL + & "fmulp %%st, %%st(1)" & NL -- X * log2 (E) + & "fld %%st(0) " & NL + & "frndint " & NL -- Integer (X * Log2 (E)) + & "fsubr %%st, %%st(1)" & NL -- Fraction (X * Log2 (E)) + & "fxch " & NL + & "f2xm1 " & NL -- 2**(...) - 1 + & "fld1 " & NL + & "faddp %%st, %%st(1)" & NL -- 2**(Fraction (X * Log2 (E))) + & "fscale " & NL -- E ** X + & "fstp %%st(1) ", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + return Result; + end Exp; + + ------------ + -- Is_Nan -- + ------------ + + function Is_Nan (X : Double) return Boolean is + begin + -- The IEEE NaN values are the only ones that do not equal themselves + + return X /= X; + end Is_Nan; + + --------- + -- Log -- + --------- + + function Log (X : Double) return Double is + Result : Double; + + begin + Asm (Template => + "fldln2 " & NL + & "fxch " & NL + & "fyl2x " & NL, + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + return Result; + end Log; + + ------------ + -- Reduce -- + ------------ + + procedure Reduce (X : in out Double; Q : out Natural) is + Half_Pi : constant := Pi / 2.0; + Two_Over_Pi : constant := 2.0 / Pi; + + HM : constant := Integer'Min (Double'Machine_Mantissa / 2, Natural'Size); + M : constant Double := 0.5 + 2.0**(1 - HM); -- Splitting constant + P1 : constant Double := Double'Leading_Part (Half_Pi, HM); + P2 : constant Double := Double'Leading_Part (Half_Pi - P1, HM); + P3 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2, HM); + P4 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3, HM); + P5 : constant Double := Double'Leading_Part (Half_Pi - P1 - P2 - P3 + - P4, HM); + P6 : constant Double := Double'Model (Half_Pi - P1 - P2 - P3 - P4 - P5); + K : Double; + R : Integer; + + begin + -- For X < 2.0**HM, all products below are computed exactly. + -- Due to cancellation effects all subtractions are exact as well. + -- As no double extended floating-point number has more than 75 + -- zeros after the binary point, the result will be the correctly + -- rounded result of X - K * (Pi / 2.0). + + K := X * Two_Over_Pi; + while abs K >= 2.0**HM loop + K := K * M - (K * M - K); + X := + (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + K := X * Two_Over_Pi; + end loop; + + -- If K is not a number (because X was not finite) raise exception + + if Is_Nan (K) then + raise Constraint_Error; + end if; + + -- Go through an integer temporary so as to use machine instructions + + R := Integer (Double'Rounding (K)); + Q := R mod 4; + K := Double (R); + X := (((((X - K * P1) - K * P2) - K * P3) - K * P4) - K * P5) - K * P6; + end Reduce; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Double) return Double is + Result : Double; + + begin + if X < 0.0 then + raise Argument_Error; + end if; + + Asm (Template => "fsqrt", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", X)); + + return Result; + end Sqrt; + + -------------------------------- + -- Other Elementary Functions -- + -------------------------------- + + -- These are built using the previously implemented basic functions + + ---------- + -- Acos -- + ---------- + + function Acos (X : Double) return Double is + Result : Double; + + begin + Result := 2.0 * Atan (Sqrt ((1.0 - X) / (1.0 + X))); + + -- The result value is NaN iff input was invalid + + if Is_Nan (Result) then + raise Argument_Error; + end if; + + return Result; + end Acos; + + ---------- + -- Asin -- + ---------- + + function Asin (X : Double) return Double is + Result : Double; + + begin + Result := Atan (X / Sqrt ((1.0 - X) * (1.0 + X))); + + -- The result value is NaN iff input was invalid + + if Is_Nan (Result) then + raise Argument_Error; + end if; + + return Result; + end Asin; + + --------- + -- Cos -- + --------- + + function Cos (X : Double) return Double is + Reduced_X : Double := abs X; + Result : Double; + Quadrant : Natural range 0 .. 3; + + begin + if Reduced_X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + Asm (Template => "fcos", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 1 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", -Reduced_X)); + + when 2 => + Asm (Template => "fcos ; fchs", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 3 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end case; + + else + Asm (Template => "fcos", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + return Result; + end Cos; + + --------------------- + -- Logarithmic_Pow -- + --------------------- + + function Logarithmic_Pow (X, Y : Double) return Double is + Result : Double; + begin + Asm (Template => "" -- X : Y + & "fyl2x " & NL -- Y * Log2 (X) + & "fld %%st(0) " & NL -- Y * Log2 (X) : Y * Log2 (X) + & "frndint " & NL -- Int (...) : Y * Log2 (X) + & "fsubr %%st, %%st(1)" & NL -- Int (...) : Fract (...) + & "fxch " & NL -- Fract (...) : Int (...) + & "f2xm1 " & NL -- 2**Fract (...) - 1 : Int (...) + & "fld1 " & NL -- 1 : 2**Fract (...) - 1 : Int (...) + & "faddp %%st, %%st(1)" & NL -- 2**Fract (...) : Int (...) + & "fscale ", -- 2**(Fract (...) + Int (...)) + Outputs => Double'Asm_Output ("=t", Result), + Inputs => + (Double'Asm_Input ("0", X), + Double'Asm_Input ("u", Y))); + return Result; + end Logarithmic_Pow; + + --------- + -- Pow -- + --------- + + function Pow (X, Y : Double) return Double is + type Mantissa_Type is mod 2**Double'Machine_Mantissa; + -- Modular type that can hold all bits of the mantissa of Double + + -- For negative exponents, do divide at the end of the processing + + Negative_Y : constant Boolean := Y < 0.0; + Abs_Y : constant Double := abs Y; + + -- During this function the following invariant is kept: + -- X ** (abs Y) = Base**(Exp_High + Exp_Mid + Exp_Low) * Factor + + Base : Double := X; + + Exp_High : Double := Double'Floor (Abs_Y); + Exp_Mid : Double; + Exp_Low : Double; + Exp_Int : Mantissa_Type; + + Factor : Double := 1.0; + + begin + -- Select algorithm for calculating Pow (integer cases fall through) + + if Exp_High >= 2.0**Double'Machine_Mantissa then + + -- In case of Y that is IEEE infinity, just raise constraint error + + if Exp_High > Double'Safe_Last then + raise Constraint_Error; + end if; + + -- Large values of Y are even integers and will stay integer + -- after division by two. + + loop + -- Exp_Mid and Exp_Low are zero, so + -- X**(abs Y) = Base ** Exp_High = (Base**2) ** (Exp_High / 2) + + Exp_High := Exp_High / 2.0; + Base := Base * Base; + exit when Exp_High < 2.0**Double'Machine_Mantissa; + end loop; + + elsif Exp_High /= Abs_Y then + Exp_Low := Abs_Y - Exp_High; + Factor := 1.0; + + if Exp_Low /= 0.0 then + + -- Exp_Low now is in interval (0.0, 1.0) + -- Exp_Mid := Double'Floor (Exp_Low * 4.0) / 4.0; + + Exp_Mid := 0.0; + Exp_Low := Exp_Low - Exp_Mid; + + if Exp_Low >= 0.5 then + Factor := Sqrt (X); + Exp_Low := Exp_Low - 0.5; -- exact + + if Exp_Low >= 0.25 then + Factor := Factor * Sqrt (Factor); + Exp_Low := Exp_Low - 0.25; -- exact + end if; + + elsif Exp_Low >= 0.25 then + Factor := Sqrt (Sqrt (X)); + Exp_Low := Exp_Low - 0.25; -- exact + end if; + + -- Exp_Low now is in interval (0.0, 0.25) + + -- This means it is safe to call Logarithmic_Pow + -- for the remaining part. + + Factor := Factor * Logarithmic_Pow (X, Exp_Low); + end if; + + elsif X = 0.0 then + return 0.0; + end if; + + -- Exp_High is non-zero integer smaller than 2**Double'Machine_Mantissa + + Exp_Int := Mantissa_Type (Exp_High); + + -- Standard way for processing integer powers > 0 + + while Exp_Int > 1 loop + if (Exp_Int and 1) = 1 then + + -- Base**Y = Base**(Exp_Int - 1) * Exp_Int for Exp_Int > 0 + + Factor := Factor * Base; + end if; + + -- Exp_Int is even and Exp_Int > 0, so + -- Base**Y = (Base**2)**(Exp_Int / 2) + + Base := Base * Base; + Exp_Int := Exp_Int / 2; + end loop; + + -- Exp_Int = 1 or Exp_Int = 0 + + if Exp_Int = 1 then + Factor := Base * Factor; + end if; + + if Negative_Y then + Factor := 1.0 / Factor; + end if; + + return Factor; + end Pow; + + --------- + -- Sin -- + --------- + + function Sin (X : Double) return Double is + Reduced_X : Double := X; + Result : Double; + Quadrant : Natural range 0 .. 3; + + begin + if abs X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + case Quadrant is + when 0 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 1 => + Asm (Template => "fcos", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + + when 2 => + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", -Reduced_X)); + + when 3 => + Asm (Template => "fcos ; fchs", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end case; + + else + Asm (Template => "fsin", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + return Result; + end Sin; + + --------- + -- Tan -- + --------- + + function Tan (X : Double) return Double is + Reduced_X : Double := X; + Result : Double; + Quadrant : Natural range 0 .. 3; + + begin + if abs X > Pi / 4.0 then + Reduce (Reduced_X, Quadrant); + + if Quadrant mod 2 = 0 then + Asm (Template => "fptan" & NL + & "ffree %%st(0)" & NL + & "fincstp", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + else + Asm (Template => "fsincos" & NL + & "fdivp %%st, %%st(1)" & NL + & "fchs", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + else + Asm (Template => + "fptan " & NL + & "ffree %%st(0) " & NL + & "fincstp ", + Outputs => Double'Asm_Output ("=t", Result), + Inputs => Double'Asm_Input ("0", Reduced_X)); + end if; + + return Result; + end Tan; + + ---------- + -- Sinh -- + ---------- + + function Sinh (X : Double) return Double is + begin + -- Mathematically Sinh (x) is defined to be (Exp (X) - Exp (-X)) / 2.0 + + if abs X < 25.0 then + return (Exp (X) - Exp (-X)) / 2.0; + else + return Exp (X) / 2.0; + end if; + end Sinh; + + ---------- + -- Cosh -- + ---------- + + function Cosh (X : Double) return Double is + begin + -- Mathematically Cosh (X) is defined to be (Exp (X) + Exp (-X)) / 2.0 + + if abs X < 22.0 then + return (Exp (X) + Exp (-X)) / 2.0; + else + return Exp (X) / 2.0; + end if; + end Cosh; + + ---------- + -- Tanh -- + ---------- + + function Tanh (X : Double) return Double is + begin + -- Return the Hyperbolic Tangent of x + + -- x -x + -- e - e Sinh (X) + -- Tanh (X) is defined to be ----------- = -------- + -- x -x Cosh (X) + -- e + e + + if abs X > 23.0 then + return Double'Copy_Sign (1.0, X); + end if; + + return 1.0 / (1.0 + Exp (-(2.0 * X))) - 1.0 / (1.0 + Exp (2.0 * X)); + end Tanh; + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux-x86.ads b/gcc/ada/libgnat/a-numaux-x86.ads new file mode 100644 index 0000000..2002ccd --- /dev/null +++ b/gcc/ada/libgnat/a-numaux-x86.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (Machine Version for x86) -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 the x86 using the 80-bit x86 long double format with +-- inline asm statements. + +package Ada.Numerics.Aux is + pragma Pure; + + type Double is new Long_Long_Float; + + function Sin (X : Double) return Double; + + function Cos (X : Double) return Double; + + function Tan (X : Double) return Double; + + function Exp (X : Double) return Double; + + function Sqrt (X : Double) return Double; + + function Log (X : Double) return Double; + + function Atan (X : Double) return Double; + + function Acos (X : Double) return Double; + + function Asin (X : Double) return Double; + + function Sinh (X : Double) return Double; + + function Cosh (X : Double) return Double; + + function Tanh (X : Double) return Double; + + function Pow (X, Y : Double) return Double; + +private + pragma Inline (Atan); + pragma Inline (Cos); + pragma Inline (Tan); + pragma Inline (Exp); + pragma Inline (Log); + pragma Inline (Sin); + pragma Inline (Sqrt); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numaux.ads b/gcc/ada/libgnat/a-numaux.ads new file mode 100644 index 0000000..50f6d0b --- /dev/null +++ b/gcc/ada/libgnat/a-numaux.ads @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . A U X -- +-- -- +-- S p e c -- +-- (C Library Version, non-x86) -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the basic computational interface for the generic +-- elementary functions. The C library version interfaces with the routines +-- in the C mathematical library, and is thus quite portable, although it may +-- not necessarily meet the requirements for accuracy in the numerics annex. +-- One advantage of using this package is that it will interface directly to +-- hardware instructions, such as the those provided on the Intel x86. + +-- This version here is for use with normal Unix math functions. Alternative +-- versions are provided for special situations: + +-- a-numaux-darwin For PowerPC/Darwin (special handling of sin/cos) +-- a-numaux-libc-x86 For the x86, using 80-bit long double format +-- a-numaux-x86 For the x86, using 80-bit long double format with +-- inline asm statements +-- a-numaux-vxworks For use on VxWorks (where we have no libm.a library) + +package Ada.Numerics.Aux is + pragma Pure; + + pragma Linker_Options ("-lm"); + + type Double is new Long_Float; + -- Type Double is the type used to call the C routines + + -- We import these functions directly from C. Note that we label them + -- all as pure functions, because indeed all of them are in fact pure. + + function Sin (X : Double) return Double; + pragma Import (C, Sin, "sin"); + pragma Pure_Function (Sin); + + function Cos (X : Double) return Double; + pragma Import (C, Cos, "cos"); + pragma Pure_Function (Cos); + + function Tan (X : Double) return Double; + pragma Import (C, Tan, "tan"); + pragma Pure_Function (Tan); + + function Exp (X : Double) return Double; + pragma Import (C, Exp, "exp"); + pragma Pure_Function (Exp); + + function Sqrt (X : Double) return Double; + pragma Import (C, Sqrt, "sqrt"); + pragma Pure_Function (Sqrt); + + function Log (X : Double) return Double; + pragma Import (C, Log, "log"); + pragma Pure_Function (Log); + + function Acos (X : Double) return Double; + pragma Import (C, Acos, "acos"); + pragma Pure_Function (Acos); + + function Asin (X : Double) return Double; + pragma Import (C, Asin, "asin"); + pragma Pure_Function (Asin); + + function Atan (X : Double) return Double; + pragma Import (C, Atan, "atan"); + pragma Pure_Function (Atan); + + function Sinh (X : Double) return Double; + pragma Import (C, Sinh, "sinh"); + pragma Pure_Function (Sinh); + + function Cosh (X : Double) return Double; + pragma Import (C, Cosh, "cosh"); + pragma Pure_Function (Cosh); + + function Tanh (X : Double) return Double; + pragma Import (C, Tanh, "tanh"); + pragma Pure_Function (Tanh); + + function Pow (X, Y : Double) return Double; + pragma Import (C, Pow, "pow"); + pragma Pure_Function (Pow); + +end Ada.Numerics.Aux; diff --git a/gcc/ada/libgnat/a-numeri.ads b/gcc/ada/libgnat/a-numeri.ads new file mode 100644 index 0000000..805fa56 --- /dev/null +++ b/gcc/ada/libgnat/a-numeri.ads @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Numerics is + pragma Pure; + + Argument_Error : exception; + + Pi : constant := + 3.14159_26535_89793_23846_26433_83279_50288_41971_69399_37511; + + ["03C0"] : constant := Pi; + -- This is the Greek letter Pi (for Ada 2005 AI-388). Note that it is + -- conforming to have this constant present even in Ada 95 mode, as there + -- is no way for a normal mode Ada 95 program to reference this identifier. + + e : constant := + 2.71828_18284_59045_23536_02874_71352_66249_77572_47093_69996; + +end Ada.Numerics; diff --git a/gcc/ada/libgnat/a-nurear.ads b/gcc/ada/libgnat/a-nurear.ads new file mode 100644 index 0000000..0197599 --- /dev/null +++ b/gcc/ada/libgnat/a-nurear.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . N U M E R I C S . R E A L _ A R R A Y S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Real_Arrays; + +package Ada.Numerics.Real_Arrays is + new Ada.Numerics.Generic_Real_Arrays (Float); + +pragma Pure (Real_Arrays); diff --git a/gcc/ada/libgnat/a-rbtgbk.adb b/gcc/ada/libgnat/a-rbtgbk.adb new file mode 100644 index 0000000..2488e21 --- /dev/null +++ b/gcc/ada/libgnat/a-rbtgbk.adb @@ -0,0 +1,627 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is + + package Ops renames Tree_Operations; + + ------------- + -- Ceiling -- + ------------- + + -- AKA Lower_Bound + + function Ceiling + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Greater_Key_Node (Key, N (X)) then + X := Ops.Right (N (X)); + else + Y := X; + X := Ops.Left (N (X)); + end if; + end loop; + + return Y; + end Ceiling; + + ---------- + -- Find -- + ---------- + + function Find + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Greater_Key_Node (Key, N (X)) then + X := Ops.Right (N (X)); + else + Y := X; + X := Ops.Left (N (X)); + end if; + end loop; + + if Y = 0 then + return 0; + end if; + + if Is_Less_Key_Node (Key, N (Y)) then + return 0; + end if; + + return Y; + end Find; + + ----------- + -- Floor -- + ----------- + + function Floor + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Less_Key_Node (Key, N (X)) then + X := Ops.Left (N (X)); + else + Y := X; + X := Ops.Right (N (X)); + end if; + end loop; + + return Y; + end Floor; + + -------------------------------- + -- Generic_Conditional_Insert -- + -------------------------------- + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + -- This is a "conditional" insertion, meaning that the insertion request + -- can "fail" in the sense that no new node is created. If the Key is + -- equivalent to an existing node, then we return the existing node and + -- Inserted is set to False. Otherwise, we allocate a new node (via + -- Insert_Post) and Inserted is set to True. + + -- Note that we are testing for equivalence here, not equality. Key must + -- be strictly less than its next neighbor, and strictly greater than + -- its previous neighbor, in order for the conditional insertion to + -- succeed. + + -- We search the tree to find the nearest neighbor of Key, which is + -- either the smallest node greater than Key (Inserted is True), or the + -- largest node less or equivalent to Key (Inserted is False). + + Y := 0; + X := Tree.Root; + Inserted := True; + while X /= 0 loop + Y := X; + Inserted := Is_Less_Key_Node (Key, N (X)); + X := (if Inserted then Ops.Left (N (X)) else Ops.Right (N (X))); + end loop; + + if Inserted then + + -- Either Tree is empty, or Key is less than Y. If Y is the first + -- node in the tree, then there are no other nodes that we need to + -- search for, and we insert a new node into the tree. + + if Y = Tree.First then + Insert_Post (Tree, Y, True, Node); + return; + end if; + + -- Y is the next nearest-neighbor of Key. We know that Key is not + -- equivalent to Y (because Key is strictly less than Y), so we move + -- to the previous node, the nearest-neighbor just smaller or + -- equivalent to Key. + + Node := Ops.Previous (Tree, Y); + + else + -- Y is the previous nearest-neighbor of Key. We know that Key is not + -- less than Y, which means either that Key is equivalent to Y, or + -- greater than Y. + + Node := Y; + end if; + + -- Key is equivalent to or greater than Node. We must resolve which is + -- the case, to determine whether the conditional insertion succeeds. + + if Is_Greater_Key_Node (Key, N (Node)) then + + -- Key is strictly greater than Node, which means that Key is not + -- equivalent to Node. In this case, the insertion succeeds, and we + -- insert a new node into the tree. + + Insert_Post (Tree, Y, Inserted, Node); + Inserted := True; + return; + end if; + + -- Key is equivalent to Node. This is a conditional insertion, so we do + -- not insert a new node in this case. We return the existing node and + -- report that no insertion has occurred. + + Inserted := False; + end Generic_Conditional_Insert; + + ------------------------------------------ + -- Generic_Conditional_Insert_With_Hint -- + ------------------------------------------ + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Position : Count_Type; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean) + is + N : Nodes_Type renames Tree.Nodes; + + begin + -- The purpose of a hint is to avoid a search from the root of + -- tree. If we have it hint it means we only need to traverse the + -- subtree rooted at the hint to find the nearest neighbor. Note + -- that finding the neighbor means merely walking the tree; this + -- is not a search and the only comparisons that occur are with + -- the hint and its neighbor. + + -- If Position is 0, this is interpreted to mean that Key is + -- large relative to the nodes in the tree. If the tree is empty, + -- or Key is greater than the last node in the tree, then we're + -- done; otherwise the hint was "wrong" and we must search. + + if Position = 0 then -- largest + if Tree.Last = 0 + or else Is_Greater_Key_Node (Key, N (Tree.Last)) + then + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + -- A hint can either name the node that immediately follows Key, + -- or immediately precedes Key. We first test whether Key is + -- less than the hint, and if so we compare Key to the node that + -- precedes the hint. If Key is both less than the hint and + -- greater than the hint's preceding neighbor, then we're done; + -- otherwise we must search. + + -- Note also that a hint can either be an anterior node or a leaf + -- node. A new node is always inserted at the bottom of the tree + -- (at least prior to rebalancing), becoming the new left or + -- right child of leaf node (which prior to the insertion must + -- necessarily be null, since this is a leaf). If the hint names + -- an anterior node then its neighbor must be a leaf, and so + -- (here) we insert after the neighbor. If the hint names a leaf + -- then its neighbor must be anterior and so we insert before the + -- hint. + + if Is_Less_Key_Node (Key, N (Position)) then + declare + Before : constant Count_Type := Ops.Previous (Tree, Position); + + begin + if Before = 0 then + Insert_Post (Tree, Tree.First, True, Node); + Inserted := True; + + elsif Is_Greater_Key_Node (Key, N (Before)) then + if Ops.Right (N (Before)) = 0 then + Insert_Post (Tree, Before, False, Node); + else + Insert_Post (Tree, Position, True, Node); + end if; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + end; + + return; + end if; + + -- We know that Key isn't less than the hint so we try again, + -- this time to see if it's greater than the hint. If so we + -- compare Key to the node that follows the hint. If Key is both + -- greater than the hint and less than the hint's next neighbor, + -- then we're done; otherwise we must search. + + if Is_Greater_Key_Node (Key, N (Position)) then + declare + After : constant Count_Type := Ops.Next (Tree, Position); + + begin + if After = 0 then + Insert_Post (Tree, Tree.Last, False, Node); + Inserted := True; + + elsif Is_Less_Key_Node (Key, N (After)) then + if Ops.Right (N (Position)) = 0 then + Insert_Post (Tree, Position, False, Node); + else + Insert_Post (Tree, After, True, Node); + end if; + + Inserted := True; + + else + Conditional_Insert_Sans_Hint (Tree, Key, Node, Inserted); + end if; + end; + + return; + end if; + + -- We know that Key is neither less than the hint nor greater + -- than the hint, and that's the definition of equivalence. + -- There's nothing else we need to do, since a search would just + -- reach the same conclusion. + + Node := Position; + Inserted := False; + end Generic_Conditional_Insert_With_Hint; + + ------------------------- + -- Generic_Insert_Post -- + ------------------------- + + procedure Generic_Insert_Post + (Tree : in out Tree_Type'Class; + Y : Count_Type; + Before : Boolean; + Z : out Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + begin + TC_Check (Tree.TC); + + if Checks and then Tree.Length >= Tree.Capacity then + raise Capacity_Error with "not enough capacity to insert new item"; + end if; + + Z := New_Node; + pragma Assert (Z /= 0); + + if Y = 0 then + pragma Assert (Tree.Length = 0); + pragma Assert (Tree.Root = 0); + pragma Assert (Tree.First = 0); + pragma Assert (Tree.Last = 0); + + Tree.Root := Z; + Tree.First := Z; + Tree.Last := Z; + + elsif Before then + pragma Assert (Ops.Left (N (Y)) = 0); + + Ops.Set_Left (N (Y), Z); + + if Y = Tree.First then + Tree.First := Z; + end if; + + else + pragma Assert (Ops.Right (N (Y)) = 0); + + Ops.Set_Right (N (Y), Z); + + if Y = Tree.Last then + Tree.Last := Z; + end if; + end if; + + Ops.Set_Color (N (Z), Red); + Ops.Set_Parent (N (Z), Y); + Ops.Rebalance_For_Insert (Tree, Z); + Tree.Length := Tree.Length + 1; + end Generic_Insert_Post; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type) + is + procedure Iterate (Index : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Index : Count_Type) is + J : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + J := Index; + while J /= 0 loop + if Is_Less_Key_Node (Key, N (J)) then + J := Ops.Left (N (J)); + elsif Is_Greater_Key_Node (Key, N (J)) then + J := Ops.Right (N (J)); + else + Iterate (Ops.Left (N (J))); + Process (J); + J := Ops.Right (N (J)); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type) + is + procedure Iterate (Index : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (Index : Count_Type) is + J : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + J := Index; + while J /= 0 loop + if Is_Less_Key_Node (Key, N (J)) then + J := Ops.Left (N (J)); + elsif Is_Greater_Key_Node (Key, N (J)) then + J := Ops.Right (N (J)); + else + Iterate (Ops.Right (N (J))); + Process (J); + J := Ops.Left (N (J)); + end if; + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ---------------------------------- + -- Generic_Unconditional_Insert -- + ---------------------------------- + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type) + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + Before : Boolean; + + begin + Y := 0; + Before := False; + + X := Tree.Root; + while X /= 0 loop + Y := X; + Before := Is_Less_Key_Node (Key, N (X)); + X := (if Before then Ops.Left (N (X)) else Ops.Right (N (X))); + end loop; + + Insert_Post (Tree, Y, Before, Node); + end Generic_Unconditional_Insert; + + -------------------------------------------- + -- Generic_Unconditional_Insert_With_Hint -- + -------------------------------------------- + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Hint : Count_Type; + Key : Key_Type; + Node : out Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + begin + -- There are fewer constraints for an unconditional insertion + -- than for a conditional insertion, since we allow duplicate + -- keys. So instead of having to check (say) whether Key is + -- (strictly) greater than the hint's previous neighbor, here we + -- allow Key to be equal to or greater than the previous node. + + -- There is the issue of what to do if Key is equivalent to the + -- hint. Does the new node get inserted before or after the hint? + -- We decide that it gets inserted after the hint, reasoning that + -- this is consistent with behavior for non-hint insertion, which + -- inserts a new node after existing nodes with equivalent keys. + + -- First we check whether the hint is null, which is interpreted + -- to mean that Key is large relative to existing nodes. + -- Following our rule above, if Key is equal to or greater than + -- the last node, then we insert the new node immediately after + -- last. (We don't have an operation for testing whether a key is + -- "equal to or greater than" a node, so we must say instead "not + -- less than", which is equivalent.) + + if Hint = 0 then -- largest + if Tree.Last = 0 then + Insert_Post (Tree, 0, False, Node); + elsif Is_Less_Key_Node (Key, N (Tree.Last)) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + else + Insert_Post (Tree, Tree.Last, False, Node); + end if; + + return; + end if; + + pragma Assert (Tree.Length > 0); + + -- We decide here whether to insert the new node prior to the + -- hint. Key could be equivalent to the hint, so in theory we + -- could write the following test as "not greater than" (same as + -- "less than or equal to"). If Key were equivalent to the hint, + -- that would mean that the new node gets inserted before an + -- equivalent node. That wouldn't break any container invariants, + -- but our rule above says that new nodes always get inserted + -- after equivalent nodes. So here we test whether Key is both + -- less than the hint and equal to or greater than the hint's + -- previous neighbor, and if so insert it before the hint. + + if Is_Less_Key_Node (Key, N (Hint)) then + declare + Before : constant Count_Type := Ops.Previous (Tree, Hint); + begin + if Before = 0 then + Insert_Post (Tree, Hint, True, Node); + elsif Is_Less_Key_Node (Key, N (Before)) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + elsif Ops.Right (N (Before)) = 0 then + Insert_Post (Tree, Before, False, Node); + else + Insert_Post (Tree, Hint, True, Node); + end if; + end; + + return; + end if; + + -- We know that Key isn't less than the hint, so it must be equal + -- or greater. So we just test whether Key is less than or equal + -- to (same as "not greater than") the hint's next neighbor, and + -- if so insert it after the hint. + + declare + After : constant Count_Type := Ops.Next (Tree, Hint); + begin + if After = 0 then + Insert_Post (Tree, Hint, False, Node); + elsif Is_Greater_Key_Node (Key, N (After)) then + Unconditional_Insert_Sans_Hint (Tree, Key, Node); + elsif Ops.Right (N (Hint)) = 0 then + Insert_Post (Tree, Hint, False, Node); + else + Insert_Post (Tree, After, True, Node); + end if; + end; + end Generic_Unconditional_Insert_With_Hint; + + ----------------- + -- Upper_Bound -- + ----------------- + + function Upper_Bound + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type + is + Y : Count_Type; + X : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + Y := 0; + + X := Tree.Root; + while X /= 0 loop + if Is_Less_Key_Node (Key, N (X)) then + Y := X; + X := Ops.Left (N (X)); + else + X := Ops.Right (N (X)); + end if; + end loop; + + return Y; + end Upper_Bound; + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; diff --git a/gcc/ada/libgnat/a-rbtgbk.ads b/gcc/ada/libgnat/a-rbtgbk.ads new file mode 100644 index 0000000..e91bffd --- /dev/null +++ b/gcc/ada/libgnat/a-rbtgbk.ads @@ -0,0 +1,193 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_KEYS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement ordered containers. This package declares +-- the tree operations that depend on keys. + +with Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; + +generic + with package Tree_Operations is new Generic_Bounded_Operations (<>); + + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; + + type Key_Type (<>) is limited private; + + with function Is_Less_Key_Node + (L : Key_Type; + R : Node_Type) return Boolean; + + with function Is_Greater_Key_Node + (L : Key_Type; + R : Node_Type) return Boolean; + +package Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys is + pragma Pure; + + generic + with function New_Node return Count_Type; + + procedure Generic_Insert_Post + (Tree : in out Tree_Type'Class; + Y : Count_Type; + Before : Boolean; + Z : out Count_Type); + -- Completes an insertion after the insertion position has been + -- determined. On output Z contains the index of the newly inserted + -- node, allocated using Allocate. If Tree is busy then + -- Program_Error is raised. If Y is 0, then Tree must be empty. + -- Otherwise Y denotes the insertion position, and Before specifies + -- whether the new node is Y's left (True) or right (False) child. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + procedure Generic_Conditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + -- Inserts a new node in Tree, but only if the tree does not already + -- contain Key. Generic_Conditional_Insert first searches for a key + -- equivalent to Key in Tree. If an equivalent key is found, then on + -- output Node designates the node with that key and Inserted is + -- False; there is no allocation and Tree is not modified. Otherwise + -- Node designates a new node allocated using Insert_Post, and + -- Inserted is True. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + procedure Generic_Unconditional_Insert + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type); + -- Inserts a new node in Tree. On output Node designates the new + -- node, which is allocated using Insert_Post. The node is inserted + -- immediately after already-existing equivalent keys. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + with procedure Unconditional_Insert_Sans_Hint + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type); + + procedure Generic_Unconditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Hint : Count_Type; + Key : Key_Type; + Node : out Count_Type); + -- Inserts a new node in Tree near position Hint, to avoid having to + -- search from the root for the insertion position. If Hint is 0 + -- then Generic_Unconditional_Insert_With_Hint attempts to insert + -- the new node after Tree.Last. If Hint is non-zero then if Key is + -- less than Hint, it attempts to insert the new node immediately + -- prior to Hint. Otherwise it attempts to insert the node + -- immediately following Hint. We say "attempts" above to emphasize + -- that insertions always preserve invariants with respect to key + -- order, even when there's a hint. So if Key can't be inserted + -- immediately near Hint, then the new node is inserted in the + -- normal way, by searching for the correct position starting from + -- the root. + + generic + with procedure Insert_Post + (T : in out Tree_Type'Class; + Y : Count_Type; + B : Boolean; + Z : out Count_Type); + + with procedure Conditional_Insert_Sans_Hint + (Tree : in out Tree_Type'Class; + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + + procedure Generic_Conditional_Insert_With_Hint + (Tree : in out Tree_Type'Class; + Position : Count_Type; -- the hint + Key : Key_Type; + Node : out Count_Type; + Inserted : out Boolean); + -- Inserts a new node in Tree if the tree does not already contain + -- Key, using Position as a hint about where to insert the new node. + -- See Generic_Unconditional_Insert_With_Hint for more details about + -- hint semantics. + + function Find + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the smallest node equivalent to Key + + function Ceiling + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the smallest node equal to or greater than Key + + function Floor + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the largest node less than or equal to Key + + function Upper_Bound + (Tree : Tree_Type'Class; + Key : Key_Type) return Count_Type; + -- Searches Tree for the smallest node greater than Key + + generic + with procedure Process (Index : Count_Type); + procedure Generic_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, in order + -- from earliest in range to latest. + + generic + with procedure Process (Index : Count_Type); + procedure Generic_Reverse_Iteration + (Tree : Tree_Type'Class; + Key : Key_Type); + -- Calls Process for each node in Tree equivalent to Key, but in + -- order from largest in range to earliest. + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Keys; diff --git a/gcc/ada/libgnat/a-rbtgbo.adb b/gcc/ada/libgnat/a-rbtgbo.adb new file mode 100644 index 0000000..e5c1b64 --- /dev/null +++ b/gcc/ada/libgnat/a-rbtgbo.adb @@ -0,0 +1,1127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- The references in this file to "CLR" refer to the following book, from +-- which several of the algorithms here were adapted: + +-- Introduction to Algorithms +-- by Thomas H. Cormen, Charles E. Leiserson, Ronald L. Rivest +-- Publisher: The MIT Press (June 18, 1990) +-- ISBN: 0262031418 + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Delete_Fixup (Tree : in out Tree_Type'Class; Node : Count_Type); + procedure Delete_Swap (Tree : in out Tree_Type'Class; Z, Y : Count_Type); + + procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type); + procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type); + + ---------------- + -- Clear_Tree -- + ---------------- + + procedure Clear_Tree (Tree : in out Tree_Type'Class) is + begin + TC_Check (Tree.TC); + + Tree.First := 0; + Tree.Last := 0; + Tree.Root := 0; + Tree.Length := 0; + Tree.Free := -1; + end Clear_Tree; + + ------------------ + -- Delete_Fixup -- + ------------------ + + procedure Delete_Fixup + (Tree : in out Tree_Type'Class; + Node : Count_Type) + is + -- CLR p. 274 + + X : Count_Type; + W : Count_Type; + N : Nodes_Type renames Tree.Nodes; + + begin + X := Node; + while X /= Tree.Root and then Color (N (X)) = Black loop + if X = Left (N (Parent (N (X)))) then + W := Right (N (Parent (N (X)))); + + if Color (N (W)) = Red then + Set_Color (N (W), Black); + Set_Color (N (Parent (N (X))), Red); + Left_Rotate (Tree, Parent (N (X))); + W := Right (N (Parent (N (X)))); + end if; + + if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) + and then + (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) + then + Set_Color (N (W), Red); + X := Parent (N (X)); + + else + if Right (N (W)) = 0 + or else Color (N (Right (N (W)))) = Black + then + -- As a condition for setting the color of the left child to + -- black, the left child access value must be non-null. A + -- truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Left (N (W)) /= 0); + Set_Color (N (Left (N (W))), Black); + + Set_Color (N (W), Red); + Right_Rotate (Tree, W); + W := Right (N (Parent (N (X)))); + end if; + + Set_Color (N (W), Color (N (Parent (N (X))))); + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Right (N (W))), Black); + Left_Rotate (Tree, Parent (N (X))); + X := Tree.Root; + end if; + + else + pragma Assert (X = Right (N (Parent (N (X))))); + + W := Left (N (Parent (N (X)))); + + if Color (N (W)) = Red then + Set_Color (N (W), Black); + Set_Color (N (Parent (N (X))), Red); + Right_Rotate (Tree, Parent (N (X))); + W := Left (N (Parent (N (X)))); + end if; + + if (Left (N (W)) = 0 or else Color (N (Left (N (W)))) = Black) + and then + (Right (N (W)) = 0 or else Color (N (Right (N (W)))) = Black) + then + Set_Color (N (W), Red); + X := Parent (N (X)); + + else + if Left (N (W)) = 0 + or else Color (N (Left (N (W)))) = Black + then + -- As a condition for setting the color of the right child + -- to black, the right child access value must be non-null. + -- A truth table analysis shows that if we arrive here, that + -- condition holds, so there's no need for an explicit test. + -- The assertion is here to document what we know is true. + + pragma Assert (Right (N (W)) /= 0); + Set_Color (N (Right (N (W))), Black); + + Set_Color (N (W), Red); + Left_Rotate (Tree, W); + W := Left (N (Parent (N (X)))); + end if; + + Set_Color (N (W), Color (N (Parent (N (X))))); + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Left (N (W))), Black); + Right_Rotate (Tree, Parent (N (X))); + X := Tree.Root; + end if; + end if; + end loop; + + Set_Color (N (X), Black); + end Delete_Fixup; + + --------------------------- + -- Delete_Node_Sans_Free -- + --------------------------- + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type'Class; + Node : Count_Type) + is + -- CLR p. 273 + + X, Y : Count_Type; + + Z : constant Count_Type := Node; + + N : Nodes_Type renames Tree.Nodes; + + begin + TC_Check (Tree.TC); + + -- If node is not present, return (exception will be raised in caller) + + if Z = 0 then + return; + end if; + + pragma Assert (Tree.Length > 0); + pragma Assert (Tree.Root /= 0); + pragma Assert (Tree.First /= 0); + pragma Assert (Tree.Last /= 0); + pragma Assert (Parent (N (Tree.Root)) = 0); + + pragma Assert ((Tree.Length > 1) + or else (Tree.First = Tree.Last + and then Tree.First = Tree.Root)); + + pragma Assert ((Left (N (Node)) = 0) + or else (Parent (N (Left (N (Node)))) = Node)); + + pragma Assert ((Right (N (Node)) = 0) + or else (Parent (N (Right (N (Node)))) = Node)); + + pragma Assert (((Parent (N (Node)) = 0) and then (Tree.Root = Node)) + or else ((Parent (N (Node)) /= 0) and then + ((Left (N (Parent (N (Node)))) = Node) + or else + (Right (N (Parent (N (Node)))) = Node)))); + + if Left (N (Z)) = 0 then + if Right (N (Z)) = 0 then + if Z = Tree.First then + Tree.First := Parent (N (Z)); + end if; + + if Z = Tree.Last then + Tree.Last := Parent (N (Z)); + end if; + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (N (Z)) = 0); + pragma Assert (Right (N (Z)) = 0); + + if Z = Tree.Root then + pragma Assert (Tree.Length = 1); + pragma Assert (Parent (N (Z)) = 0); + Tree.Root := 0; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), 0); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), 0); + end if; + + else + pragma Assert (Z /= Tree.Last); + + X := Right (N (Z)); + + if Z = Tree.First then + Tree.First := Min (Tree, X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), X); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), X); + end if; + + Set_Parent (N (X), Parent (N (Z))); + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + + elsif Right (N (Z)) = 0 then + pragma Assert (Z /= Tree.First); + + X := Left (N (Z)); + + if Z = Tree.Last then + Tree.Last := Max (Tree, X); + end if; + + if Z = Tree.Root then + Tree.Root := X; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), X); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), X); + end if; + + Set_Parent (N (X), Parent (N (Z))); + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, X); + end if; + + else + pragma Assert (Z /= Tree.First); + pragma Assert (Z /= Tree.Last); + + Y := Next (Tree, Z); + pragma Assert (Left (N (Y)) = 0); + + X := Right (N (Y)); + + if X = 0 then + if Y = Left (N (Parent (N (Y)))) then + pragma Assert (Parent (N (Y)) /= Z); + Delete_Swap (Tree, Z, Y); + Set_Left (N (Parent (N (Z))), Z); + + else + pragma Assert (Y = Right (N (Parent (N (Y))))); + pragma Assert (Parent (N (Y)) = Z); + Set_Parent (N (Y), Parent (N (Z))); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), Y); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), Y); + end if; + + Set_Left (N (Y), Left (N (Z))); + Set_Parent (N (Left (N (Y))), Y); + Set_Right (N (Y), Z); + + Set_Parent (N (Z), Y); + Set_Left (N (Z), 0); + Set_Right (N (Z), 0); + + declare + Y_Color : constant Color_Type := Color (N (Y)); + begin + Set_Color (N (Y), Color (N (Z))); + Set_Color (N (Z), Y_Color); + end; + end if; + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, Z); + end if; + + pragma Assert (Left (N (Z)) = 0); + pragma Assert (Right (N (Z)) = 0); + + if Z = Right (N (Parent (N (Z)))) then + Set_Right (N (Parent (N (Z))), 0); + else + pragma Assert (Z = Left (N (Parent (N (Z))))); + Set_Left (N (Parent (N (Z))), 0); + end if; + + else + if Y = Left (N (Parent (N (Y)))) then + pragma Assert (Parent (N (Y)) /= Z); + + Delete_Swap (Tree, Z, Y); + + Set_Left (N (Parent (N (Z))), X); + Set_Parent (N (X), Parent (N (Z))); + + else + pragma Assert (Y = Right (N (Parent (N (Y))))); + pragma Assert (Parent (N (Y)) = Z); + + Set_Parent (N (Y), Parent (N (Z))); + + if Z = Tree.Root then + Tree.Root := Y; + elsif Z = Left (N (Parent (N (Z)))) then + Set_Left (N (Parent (N (Z))), Y); + else + pragma Assert (Z = Right (N (Parent (N (Z))))); + Set_Right (N (Parent (N (Z))), Y); + end if; + + Set_Left (N (Y), Left (N (Z))); + Set_Parent (N (Left (N (Y))), Y); + + declare + Y_Color : constant Color_Type := Color (N (Y)); + begin + Set_Color (N (Y), Color (N (Z))); + Set_Color (N (Z), Y_Color); + end; + end if; + + if Color (N (Z)) = Black then + Delete_Fixup (Tree, X); + end if; + end if; + end if; + + Tree.Length := Tree.Length - 1; + end Delete_Node_Sans_Free; + + ----------------- + -- Delete_Swap -- + ----------------- + + procedure Delete_Swap + (Tree : in out Tree_Type'Class; + Z, Y : Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + pragma Assert (Z /= Y); + pragma Assert (Parent (N (Y)) /= Z); + + Y_Parent : constant Count_Type := Parent (N (Y)); + Y_Color : constant Color_Type := Color (N (Y)); + + begin + Set_Parent (N (Y), Parent (N (Z))); + Set_Left (N (Y), Left (N (Z))); + Set_Right (N (Y), Right (N (Z))); + Set_Color (N (Y), Color (N (Z))); + + if Tree.Root = Z then + Tree.Root := Y; + elsif Right (N (Parent (N (Y)))) = Z then + Set_Right (N (Parent (N (Y))), Y); + else + pragma Assert (Left (N (Parent (N (Y)))) = Z); + Set_Left (N (Parent (N (Y))), Y); + end if; + + if Right (N (Y)) /= 0 then + Set_Parent (N (Right (N (Y))), Y); + end if; + + if Left (N (Y)) /= 0 then + Set_Parent (N (Left (N (Y))), Y); + end if; + + Set_Parent (N (Z), Y_Parent); + Set_Color (N (Z), Y_Color); + Set_Left (N (Z), 0); + Set_Right (N (Z), 0); + end Delete_Swap; + + ---------- + -- Free -- + ---------- + + procedure Free (Tree : in out Tree_Type'Class; X : Count_Type) is + pragma Assert (X > 0); + pragma Assert (X <= Tree.Capacity); + + N : Nodes_Type renames Tree.Nodes; + -- pragma Assert (N (X).Prev >= 0); -- node is active + -- Find a way to mark a node as active vs. inactive; we could + -- use a special value in Color_Type for this. ??? + + begin + -- The set container actually contains two data structures: a list for + -- the "active" nodes that contain elements that have been inserted + -- onto the tree, and another for the "inactive" nodes of the free + -- store. + -- + -- We desire that merely declaring an object should have only minimal + -- cost; specially, we want to avoid having to initialize the free + -- store (to fill in the links), especially if the capacity is large. + -- + -- The head of the free list is indicated by Container.Free. If its + -- value is non-negative, then the free store has been initialized + -- in the "normal" way: Container.Free points to the head of the list + -- of free (inactive) nodes, and the value 0 means the free list is + -- empty. Each node on the free list has been initialized to point + -- to the next free node (via its Parent component), and the value 0 + -- means that this is the last free node. + -- + -- If Container.Free is negative, then the links on the free store + -- have not been initialized. In this case the link values are + -- implied: the free store comprises the components of the node array + -- started with the absolute value of Container.Free, and continuing + -- until the end of the array (Nodes'Last). + -- + -- ??? + -- It might be possible to perform an optimization here. Suppose that + -- the free store can be represented as having two parts: one + -- comprising the non-contiguous inactive nodes linked together + -- in the normal way, and the other comprising the contiguous + -- inactive nodes (that are not linked together, at the end of the + -- nodes array). This would allow us to never have to initialize + -- the free store, except in a lazy way as nodes become inactive. + + -- When an element is deleted from the list container, its node + -- becomes inactive, and so we set its Prev component to a negative + -- value, to indicate that it is now inactive. This provides a useful + -- way to detect a dangling cursor reference. + + -- The comment above is incorrect; we need some other way to + -- indicate a node is inactive, for example by using a special + -- Color_Type value. ??? + -- N (X).Prev := -1; -- Node is deallocated (not on active list) + + if Tree.Free >= 0 then + -- The free store has previously been initialized. All we need to + -- do here is link the newly-free'd node onto the free list. + + Set_Parent (N (X), Tree.Free); + Tree.Free := X; + + elsif X + 1 = abs Tree.Free then + -- The free store has not been initialized, and the node becoming + -- inactive immediately precedes the start of the free store. All + -- we need to do is move the start of the free store back by one. + + Tree.Free := Tree.Free + 1; + + else + -- The free store has not been initialized, and the node becoming + -- inactive does not immediately precede the free store. Here we + -- first initialize the free store (meaning the links are given + -- values in the traditional way), and then link the newly-free'd + -- node onto the head of the free store. + + -- ??? + -- See the comments above for an optimization opportunity. If the + -- next link for a node on the free store is negative, then this + -- means the remaining nodes on the free store are physically + -- contiguous, starting as the absolute value of that index value. + + Tree.Free := abs Tree.Free; + + if Tree.Free > Tree.Capacity then + Tree.Free := 0; + + else + for I in Tree.Free .. Tree.Capacity - 1 loop + Set_Parent (N (I), I + 1); + end loop; + + Set_Parent (N (Tree.Capacity), 0); + end if; + + Set_Parent (N (X), Tree.Free); + Tree.Free := X; + end if; + end Free; + + ----------------------- + -- Generic_Allocate -- + ----------------------- + + procedure Generic_Allocate + (Tree : in out Tree_Type'Class; + Node : out Count_Type) + is + N : Nodes_Type renames Tree.Nodes; + + begin + if Tree.Free >= 0 then + Node := Tree.Free; + + -- We always perform the assignment first, before we + -- change container state, in order to defend against + -- exceptions duration assignment. + + Set_Element (N (Node)); + Tree.Free := Parent (N (Node)); + + else + -- A negative free store value means that the links of the nodes + -- in the free store have not been initialized. In this case, the + -- nodes are physically contiguous in the array, starting at the + -- index that is the absolute value of the Container.Free, and + -- continuing until the end of the array (Nodes'Last). + + Node := abs Tree.Free; + + -- As above, we perform this assignment first, before modifying + -- any container state. + + Set_Element (N (Node)); + Tree.Free := Tree.Free - 1; + end if; + + -- When a node is allocated from the free store, its pointer components + -- (the links to other nodes in the tree) must also be initialized (to + -- 0, the equivalent of null). This simplifies the post-allocation + -- handling of nodes inserted into terminal positions. + + Set_Parent (N (Node), Parent => 0); + Set_Left (N (Node), Left => 0); + Set_Right (N (Node), Right => 0); + end Generic_Allocate; + + ------------------- + -- Generic_Equal -- + ------------------- + + function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean is + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L_Node : Count_Type; + R_Node : Count_Type; + + begin + if Left'Address = Right'Address then + return True; + end if; + + if Left.Length /= Right.Length then + return False; + end if; + + -- If the containers are empty, return a result immediately, so as to + -- not manipulate the tamper bits unnecessarily. + + if Left.Length = 0 then + return True; + end if; + + L_Node := Left.First; + R_Node := Right.First; + while L_Node /= 0 loop + if not Is_Equal (Left.Nodes (L_Node), Right.Nodes (R_Node)) then + return False; + end if; + + L_Node := Next (Left, L_Node); + R_Node := Next (Right, R_Node); + end loop; + + return True; + end Generic_Equal; + + ----------------------- + -- Generic_Iteration -- + ----------------------- + + procedure Generic_Iteration (Tree : Tree_Type'Class) is + procedure Iterate (P : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Count_Type) is + X : Count_Type := P; + begin + while X /= 0 loop + Iterate (Left (Tree.Nodes (X))); + Process (X); + X := Right (Tree.Nodes (X)); + end loop; + end Iterate; + + -- Start of processing for Generic_Iteration + + begin + Iterate (Tree.Root); + end Generic_Iteration; + + ------------------ + -- Generic_Read -- + ------------------ + + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type'Class) + is + Len : Count_Type'Base; + + Node, Last_Node : Count_Type; + + N : Nodes_Type renames Tree.Nodes; + + begin + Clear_Tree (Tree); + Count_Type'Base'Read (Stream, Len); + + if Checks and then Len < 0 then + raise Program_Error with "bad container length (corrupt stream)"; + end if; + + if Len = 0 then + return; + end if; + + if Checks and then Len > Tree.Capacity then + raise Constraint_Error with "length exceeds capacity"; + end if; + + -- Use Unconditional_Insert_With_Hint here instead ??? + + Allocate (Tree, Node); + pragma Assert (Node /= 0); + + Set_Color (N (Node), Black); + + Tree.Root := Node; + Tree.First := Node; + Tree.Last := Node; + Tree.Length := 1; + + for J in Count_Type range 2 .. Len loop + Last_Node := Node; + pragma Assert (Last_Node = Tree.Last); + + Allocate (Tree, Node); + pragma Assert (Node /= 0); + + Set_Color (N (Node), Red); + Set_Right (N (Last_Node), Right => Node); + Tree.Last := Node; + Set_Parent (N (Node), Parent => Last_Node); + + Rebalance_For_Insert (Tree, Node); + Tree.Length := Tree.Length + 1; + end loop; + end Generic_Read; + + ------------------------------- + -- Generic_Reverse_Iteration -- + ------------------------------- + + procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class) is + procedure Iterate (P : Count_Type); + + ------------- + -- Iterate -- + ------------- + + procedure Iterate (P : Count_Type) is + X : Count_Type := P; + begin + while X /= 0 loop + Iterate (Right (Tree.Nodes (X))); + Process (X); + X := Left (Tree.Nodes (X)); + end loop; + end Iterate; + + -- Start of processing for Generic_Reverse_Iteration + + begin + Iterate (Tree.Root); + end Generic_Reverse_Iteration; + + ------------------- + -- Generic_Write -- + ------------------- + + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type'Class) + is + procedure Process (Node : Count_Type); + pragma Inline (Process); + + procedure Iterate is new Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Count_Type) is + begin + Write_Node (Stream, Tree.Nodes (Node)); + end Process; + + -- Start of processing for Generic_Write + + begin + Count_Type'Base'Write (Stream, Tree.Length); + Iterate (Tree); + end Generic_Write; + + ----------------- + -- Left_Rotate -- + ----------------- + + procedure Left_Rotate (Tree : in out Tree_Type'Class; X : Count_Type) is + + -- CLR p. 266 + + N : Nodes_Type renames Tree.Nodes; + + Y : constant Count_Type := Right (N (X)); + pragma Assert (Y /= 0); + + begin + Set_Right (N (X), Left (N (Y))); + + if Left (N (Y)) /= 0 then + Set_Parent (N (Left (N (Y))), X); + end if; + + Set_Parent (N (Y), Parent (N (X))); + + if X = Tree.Root then + Tree.Root := Y; + elsif X = Left (N (Parent (N (X)))) then + Set_Left (N (Parent (N (X))), Y); + else + pragma Assert (X = Right (N (Parent (N (X))))); + Set_Right (N (Parent (N (X))), Y); + end if; + + Set_Left (N (Y), X); + Set_Parent (N (X), Y); + end Left_Rotate; + + --------- + -- Max -- + --------- + + function Max + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + -- CLR p. 248 + + X : Count_Type := Node; + Y : Count_Type; + + begin + loop + Y := Right (Tree.Nodes (X)); + + if Y = 0 then + return X; + end if; + + X := Y; + end loop; + end Max; + + --------- + -- Min -- + --------- + + function Min + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + -- CLR p. 248 + + X : Count_Type := Node; + Y : Count_Type; + + begin + loop + Y := Left (Tree.Nodes (X)); + + if Y = 0 then + return X; + end if; + + X := Y; + end loop; + end Min; + + ---------- + -- Next -- + ---------- + + function Next + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + begin + -- CLR p. 249 + + if Node = 0 then + return 0; + end if; + + if Right (Tree.Nodes (Node)) /= 0 then + return Min (Tree, Right (Tree.Nodes (Node))); + end if; + + declare + X : Count_Type := Node; + Y : Count_Type := Parent (Tree.Nodes (Node)); + + begin + while Y /= 0 and then X = Right (Tree.Nodes (Y)) loop + X := Y; + Y := Parent (Tree.Nodes (Y)); + end loop; + + return Y; + end; + end Next; + + -------------- + -- Previous -- + -------------- + + function Previous + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type + is + begin + if Node = 0 then + return 0; + end if; + + if Left (Tree.Nodes (Node)) /= 0 then + return Max (Tree, Left (Tree.Nodes (Node))); + end if; + + declare + X : Count_Type := Node; + Y : Count_Type := Parent (Tree.Nodes (Node)); + + begin + while Y /= 0 and then X = Left (Tree.Nodes (Y)) loop + X := Y; + Y := Parent (Tree.Nodes (Y)); + end loop; + + return Y; + end; + end Previous; + + -------------------------- + -- Rebalance_For_Insert -- + -------------------------- + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type'Class; + Node : Count_Type) + is + -- CLR p. 268 + + N : Nodes_Type renames Tree.Nodes; + + X : Count_Type := Node; + pragma Assert (X /= 0); + pragma Assert (Color (N (X)) = Red); + + Y : Count_Type; + + begin + while X /= Tree.Root and then Color (N (Parent (N (X)))) = Red loop + if Parent (N (X)) = Left (N (Parent (N (Parent (N (X)))))) then + Y := Right (N (Parent (N (Parent (N (X)))))); + + if Y /= 0 and then Color (N (Y)) = Red then + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Y), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + X := Parent (N (Parent (N (X)))); + + else + if X = Right (N (Parent (N (X)))) then + X := Parent (N (X)); + Left_Rotate (Tree, X); + end if; + + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + Right_Rotate (Tree, Parent (N (Parent (N (X))))); + end if; + + else + pragma Assert (Parent (N (X)) = + Right (N (Parent (N (Parent (N (X))))))); + + Y := Left (N (Parent (N (Parent (N (X)))))); + + if Y /= 0 and then Color (N (Y)) = Red then + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Y), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + X := Parent (N (Parent (N (X)))); + + else + if X = Left (N (Parent (N (X)))) then + X := Parent (N (X)); + Right_Rotate (Tree, X); + end if; + + Set_Color (N (Parent (N (X))), Black); + Set_Color (N (Parent (N (Parent (N (X))))), Red); + Left_Rotate (Tree, Parent (N (Parent (N (X))))); + end if; + end if; + end loop; + + Set_Color (N (Tree.Root), Black); + end Rebalance_For_Insert; + + ------------------ + -- Right_Rotate -- + ------------------ + + procedure Right_Rotate (Tree : in out Tree_Type'Class; Y : Count_Type) is + N : Nodes_Type renames Tree.Nodes; + + X : constant Count_Type := Left (N (Y)); + pragma Assert (X /= 0); + + begin + Set_Left (N (Y), Right (N (X))); + + if Right (N (X)) /= 0 then + Set_Parent (N (Right (N (X))), Y); + end if; + + Set_Parent (N (X), Parent (N (Y))); + + if Y = Tree.Root then + Tree.Root := X; + elsif Y = Left (N (Parent (N (Y)))) then + Set_Left (N (Parent (N (Y))), X); + else + pragma Assert (Y = Right (N (Parent (N (Y))))); + Set_Right (N (Parent (N (Y))), X); + end if; + + Set_Right (N (X), Y); + Set_Parent (N (Y), X); + end Right_Rotate; + + --------- + -- Vet -- + --------- + + function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean is + Nodes : Nodes_Type renames Tree.Nodes; + Node : Node_Type renames Nodes (Index); + + begin + if Parent (Node) = Index + or else Left (Node) = Index + or else Right (Node) = Index + then + return False; + end if; + + if Tree.Length = 0 + or else Tree.Root = 0 + or else Tree.First = 0 + or else Tree.Last = 0 + then + return False; + end if; + + if Parent (Nodes (Tree.Root)) /= 0 then + return False; + end if; + + if Left (Nodes (Tree.First)) /= 0 then + return False; + end if; + + if Right (Nodes (Tree.Last)) /= 0 then + return False; + end if; + + if Tree.Length = 1 then + if Tree.First /= Tree.Last + or else Tree.First /= Tree.Root + then + return False; + end if; + + if Index /= Tree.First then + return False; + end if; + + if Parent (Node) /= 0 + or else Left (Node) /= 0 + or else Right (Node) /= 0 + then + return False; + end if; + + return True; + end if; + + if Tree.First = Tree.Last then + return False; + end if; + + if Tree.Length = 2 then + if Tree.First /= Tree.Root and then Tree.Last /= Tree.Root then + return False; + end if; + + if Tree.First /= Index and then Tree.Last /= Index then + return False; + end if; + end if; + + if Left (Node) /= 0 and then Parent (Nodes (Left (Node))) /= Index then + return False; + end if; + + if Right (Node) /= 0 and then Parent (Nodes (Right (Node))) /= Index then + return False; + end if; + + if Parent (Node) = 0 then + if Tree.Root /= Index then + return False; + end if; + + elsif Left (Nodes (Parent (Node))) /= Index + and then Right (Nodes (Parent (Node))) /= Index + then + return False; + end if; + + return True; + end Vet; + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; diff --git a/gcc/ada/libgnat/a-rbtgbo.ads b/gcc/ada/libgnat/a-rbtgbo.ads new file mode 100644 index 0000000..e5e313e --- /dev/null +++ b/gcc/ada/libgnat/a-rbtgbo.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_BOUNDED_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement the ordered containers. This package +-- declares the tree operations that do not depend on keys. + +with Ada.Streams; use Ada.Streams; + +generic + with package Tree_Types is new Generic_Bounded_Tree_Types (<>); + use Tree_Types, Tree_Types.Implementation; + + with function Parent (Node : Node_Type) return Count_Type is <>; + + with procedure Set_Parent + (Node : in out Node_Type; + Parent : Count_Type) is <>; + + with function Left (Node : Node_Type) return Count_Type is <>; + + with procedure Set_Left + (Node : in out Node_Type; + Left : Count_Type) is <>; + + with function Right (Node : Node_Type) return Count_Type is <>; + + with procedure Set_Right + (Node : in out Node_Type; + Right : Count_Type) is <>; + + with function Color (Node : Node_Type) return Color_Type is <>; + + with procedure Set_Color + (Node : in out Node_Type; + Color : Color_Type) is <>; + +package Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations is + pragma Annotate (CodePeer, Skip_Analysis); + pragma Pure; + + function Min (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; + -- Returns the smallest-valued node of the subtree rooted at Node + + function Max (Tree : Tree_Type'Class; Node : Count_Type) return Count_Type; + -- Returns the largest-valued node of the subtree rooted at Node + + function Vet (Tree : Tree_Type'Class; Index : Count_Type) return Boolean; + -- Inspects Node to determine (to the extent possible) whether + -- the node is valid; used to detect if the node is dangling. + + function Next + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type; + -- Returns the smallest node greater than Node + + function Previous + (Tree : Tree_Type'Class; + Node : Count_Type) return Count_Type; + -- Returns the largest node less than Node + + generic + with function Is_Equal (L, R : Node_Type) return Boolean; + function Generic_Equal (Left, Right : Tree_Type'Class) return Boolean; + -- Uses Is_Equal to perform a node-by-node comparison of the + -- Left and Right trees; processing stops as soon as the first + -- non-equal node is found. + + procedure Delete_Node_Sans_Free + (Tree : in out Tree_Type'Class; Node : Count_Type); + -- Removes Node from Tree without deallocating the node. If Tree + -- is busy then Program_Error is raised. + + procedure Clear_Tree (Tree : in out Tree_Type'Class); + -- Clears Tree by deallocating all of its nodes. If Tree is busy then + -- Program_Error is raised. + + generic + with procedure Process (Node : Count_Type) is <>; + procedure Generic_Iteration (Tree : Tree_Type'Class); + -- Calls Process for each node in Tree, in order from smallest-valued + -- node to largest-valued node. + + generic + with procedure Process (Node : Count_Type) is <>; + procedure Generic_Reverse_Iteration (Tree : Tree_Type'Class); + -- Calls Process for each node in Tree, in order from largest-valued + -- node to smallest-valued node. + + generic + with procedure Write_Node + (Stream : not null access Root_Stream_Type'Class; + Node : Node_Type); + procedure Generic_Write + (Stream : not null access Root_Stream_Type'Class; + Tree : Tree_Type'Class); + -- Used to implement stream attribute T'Write. Generic_Write + -- first writes the number of nodes into Stream, then calls + -- Write_Node for each node in Tree. + + generic + with procedure Allocate + (Tree : in out Tree_Type'Class; + Node : out Count_Type); + procedure Generic_Read + (Stream : not null access Root_Stream_Type'Class; + Tree : in out Tree_Type'Class); + -- Used to implement stream attribute T'Read. Generic_Read + -- first clears Tree. It then reads the number of nodes out of + -- Stream, and calls Read_Node for each node in Stream. + + procedure Rebalance_For_Insert + (Tree : in out Tree_Type'Class; + Node : Count_Type); + -- This rebalances Tree to complete the insertion of Node (which + -- must already be linked in at its proper insertion position). + + generic + with procedure Set_Element (Node : in out Node_Type); + procedure Generic_Allocate + (Tree : in out Tree_Type'Class; + Node : out Count_Type); + -- Claim a node from the free store. Generic_Allocate first + -- calls Set_Element on the potential node, and then returns + -- the node's index as the value of the Node parameter. + + procedure Free (Tree : in out Tree_Type'Class; X : Count_Type); + -- Return a node back to the free store, from where it had + -- been previously claimed via Generic_Allocate. + +end Ada.Containers.Red_Black_Trees.Generic_Bounded_Operations; diff --git a/gcc/ada/libgnat/a-rbtgso.adb b/gcc/ada/libgnat/a-rbtgso.adb new file mode 100644 index 0000000..8f7600c --- /dev/null +++ b/gcc/ada/libgnat/a-rbtgso.adb @@ -0,0 +1,739 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System; use type System.Address; + +package body Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + + pragma Warnings (Off, "variable ""Busy*"" is not referenced"); + pragma Warnings (Off, "variable ""Lock*"" is not referenced"); + -- See comment in Ada.Containers.Helpers + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Clear (Tree : in out Tree_Type); + + function Copy (Source : Tree_Type) return Tree_Type; + + ----------- + -- Clear -- + ----------- + + procedure Clear (Tree : in out Tree_Type) is + use type Helpers.Tamper_Counts; + pragma Assert (Tree.TC = (Busy => 0, Lock => 0)); + + Root : Node_Access := Tree.Root; + pragma Warnings (Off, Root); + + begin + Tree.Root := null; + Tree.First := null; + Tree.Last := null; + Tree.Length := 0; + + Delete_Tree (Root); + end Clear; + + ---------- + -- Copy -- + ---------- + + function Copy (Source : Tree_Type) return Tree_Type is + Target : Tree_Type; + + begin + if Source.Length = 0 then + return Target; + end if; + + Target.Root := Copy_Tree (Source.Root); + Target.First := Tree_Operations.Min (Target.Root); + Target.Last := Tree_Operations.Max (Target.Root); + Target.Length := Source.Length; + + return Target; + end Copy; + + ---------------- + -- Difference -- + ---------------- + + procedure Difference (Target : in out Tree_Type; Source : Tree_Type) is + Tgt : Node_Access; + Src : Node_Access; + + Compare : Integer; + + begin + if Target'Address = Source'Address then + TC_Check (Target.TC); + + Clear (Target); + return; + end if; + + if Source.Length = 0 then + return; + end if; + + TC_Check (Target.TC); + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = null then + exit; + end if; + + if Src = null then + exit; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + end; + + if Compare < 0 then + Tgt := Tree_Operations.Next (Tgt); + + elsif Compare > 0 then + Src := Tree_Operations.Next (Src); + + else + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + Src := Tree_Operations.Next (Src); + end if; + end loop; + end Difference; + + function Difference (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Tree_Type'(others => <>); -- Empty set + end if; + + if Left.Length = 0 then + return Tree_Type'(others => <>); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; + + if Is_Less (L_Node, R_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + return Tree; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end; + end Difference; + + ------------------ + -- Intersection -- + ------------------ + + procedure Intersection + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access; + Src : Node_Access; + + Compare : Integer; + + begin + if Target'Address = Source'Address then + return; + end if; + + TC_Check (Target.TC); + + if Source.Length = 0 then + Clear (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + while Tgt /= null + and then Src /= null + loop + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + end; + + if Compare < 0 then + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + elsif Compare > 0 then + Src := Tree_Operations.Next (Src); + + else + Tgt := Tree_Operations.Next (Tgt); + Src := Tree_Operations.Next (Src); + end if; + end loop; + + while Tgt /= null loop + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + end loop; + end Intersection; + + function Intersection (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + exit; + end if; + + if R_Node = null then + exit; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + return Tree; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end; + end Intersection; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Subset : Tree_Type; + Of_Set : Tree_Type) return Boolean + is + begin + if Subset'Address = Of_Set'Address then + return True; + end if; + + if Subset.Length > Of_Set.Length then + return False; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Subset : With_Lock (Subset.TC'Unrestricted_Access); + Lock_Of_Set : With_Lock (Of_Set.TC'Unrestricted_Access); + + Subset_Node : Node_Access; + Set_Node : Node_Access; + + begin + Subset_Node := Subset.First; + Set_Node := Of_Set.First; + loop + if Set_Node = null then + return Subset_Node = null; + end if; + + if Subset_Node = null then + return True; + end if; + + if Is_Less (Subset_Node, Set_Node) then + return False; + end if; + + if Is_Less (Set_Node, Subset_Node) then + Set_Node := Tree_Operations.Next (Set_Node); + else + Set_Node := Tree_Operations.Next (Set_Node); + Subset_Node := Tree_Operations.Next (Subset_Node); + end if; + end loop; + end; + end Is_Subset; + + ------------- + -- Overlap -- + ------------- + + function Overlap (Left, Right : Tree_Type) return Boolean is + begin + if Left'Address = Right'Address then + return Left.Length /= 0; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + L_Node : Node_Access; + R_Node : Node_Access; + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null + or else R_Node = null + then + return False; + end if; + + if Is_Less (L_Node, R_Node) then + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + R_Node := Tree_Operations.Next (R_Node); + + else + return True; + end if; + end loop; + end; + end Overlap; + + -------------------------- + -- Symmetric_Difference -- + -------------------------- + + procedure Symmetric_Difference + (Target : in out Tree_Type; + Source : Tree_Type) + is + Tgt : Node_Access; + Src : Node_Access; + + New_Tgt_Node : Node_Access; + pragma Warnings (Off, New_Tgt_Node); + + Compare : Integer; + + begin + if Target'Address = Source'Address then + Clear (Target); + return; + end if; + + Tgt := Target.First; + Src := Source.First; + loop + if Tgt = null then + while Src /= null loop + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => null, + Src_Node => Src, + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Src); + end loop; + + return; + end if; + + if Src = null then + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Target : With_Lock (Target.TC'Unrestricted_Access); + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + if Is_Less (Tgt, Src) then + Compare := -1; + elsif Is_Less (Src, Tgt) then + Compare := 1; + else + Compare := 0; + end if; + end; + + if Compare < 0 then + Tgt := Tree_Operations.Next (Tgt); + + elsif Compare > 0 then + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => Tgt, + Src_Node => Src, + Dst_Node => New_Tgt_Node); + + Src := Tree_Operations.Next (Src); + + else + declare + X : Node_Access := Tgt; + begin + Tgt := Tree_Operations.Next (Tgt); + Tree_Operations.Delete_Node_Sans_Free (Target, X); + Free (X); + end; + + Src := Tree_Operations.Next (Src); + end if; + end loop; + end Symmetric_Difference; + + function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Tree_Type'(others => <>); -- Empty set + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + Tree : Tree_Type; + + L_Node : Node_Access; + R_Node : Node_Access; + + Dst_Node : Node_Access; + pragma Warnings (Off, Dst_Node); + + begin + L_Node := Left.First; + R_Node := Right.First; + loop + if L_Node = null then + while R_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => R_Node, + Dst_Node => Dst_Node); + R_Node := Tree_Operations.Next (R_Node); + end loop; + + exit; + end if; + + if R_Node = null then + while L_Node /= null loop + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + end loop; + + exit; + end if; + + if Is_Less (L_Node, R_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => L_Node, + Dst_Node => Dst_Node); + + L_Node := Tree_Operations.Next (L_Node); + + elsif Is_Less (R_Node, L_Node) then + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => null, + Src_Node => R_Node, + Dst_Node => Dst_Node); + + R_Node := Tree_Operations.Next (R_Node); + + else + L_Node := Tree_Operations.Next (L_Node); + R_Node := Tree_Operations.Next (R_Node); + end if; + end loop; + + return Tree; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end; + end Symmetric_Difference; + + ----------- + -- Union -- + ----------- + + procedure Union (Target : in out Tree_Type; Source : Tree_Type) is + Hint : Node_Access; + + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Insert_With_Hint + (Dst_Tree => Target, + Dst_Hint => Hint, -- use node most recently inserted as hint + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + if Target'Address = Source'Address then + return; + end if; + + -- Per AI05-0022, the container implementation is required to detect + -- element tampering by a generic actual subprogram. + + declare + Lock_Source : With_Lock (Source.TC'Unrestricted_Access); + begin + Iterate (Source); + end; + end Union; + + function Union (Left, Right : Tree_Type) return Tree_Type is + begin + if Left'Address = Right'Address then + return Copy (Left); + end if; + + if Left.Length = 0 then + return Copy (Right); + end if; + + if Right.Length = 0 then + return Copy (Left); + end if; + + declare + Lock_Left : With_Lock (Left.TC'Unrestricted_Access); + Lock_Right : With_Lock (Right.TC'Unrestricted_Access); + + Tree : Tree_Type := Copy (Left); + + Hint : Node_Access; + + procedure Process (Node : Node_Access); + pragma Inline (Process); + + procedure Iterate is + new Tree_Operations.Generic_Iteration (Process); + + ------------- + -- Process -- + ------------- + + procedure Process (Node : Node_Access) is + begin + Insert_With_Hint + (Dst_Tree => Tree, + Dst_Hint => Hint, -- use node most recently inserted as hint + Src_Node => Node, + Dst_Node => Hint); + end Process; + + -- Start of processing for Union + + begin + Iterate (Right); + return Tree; + + exception + when others => + Delete_Tree (Tree.Root); + raise; + end; + end Union; + +end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/libgnat/a-rbtgso.ads b/gcc/ada/libgnat/a-rbtgso.ads new file mode 100644 index 0000000..80617f2 --- /dev/null +++ b/gcc/ada/libgnat/a-rbtgso.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.CONTAINERS.RED_BLACK_TREES.GENERIC_SET_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +-- Tree_Type is used to implement ordered containers. This package declares +-- set-based tree operations. + +with Ada.Containers.Red_Black_Trees.Generic_Operations; + +generic + with package Tree_Operations is new Generic_Operations (<>); + + use Tree_Operations.Tree_Types, Tree_Operations.Tree_Types.Implementation; + + with procedure Insert_With_Hint + (Dst_Tree : in out Tree_Type; + Dst_Hint : Node_Access; + Src_Node : Node_Access; + Dst_Node : out Node_Access); + + with function Copy_Tree (Source_Root : Node_Access) + return Node_Access; + + with procedure Delete_Tree (X : in out Node_Access); + + with function Is_Less (Left, Right : Node_Access) return Boolean; + + with procedure Free (X : in out Node_Access); + +package Ada.Containers.Red_Black_Trees.Generic_Set_Operations is + pragma Pure; + + procedure Union (Target : in out Tree_Type; Source : Tree_Type); + -- Attempts to insert each element of Source in Target. If Target is + -- busy then Program_Error is raised. We say "attempts" here because + -- if these are unique-element sets, then the insertion should fail + -- (not insert a new item) when the insertion item from Source is + -- equivalent to an item already in Target. If these are multisets + -- then of course the attempt should always succeed. + + function Union (Left, Right : Tree_Type) return Tree_Type; + -- Makes a copy of Left, and attempts to insert each element of + -- Right into the copy, then returns the copy. + + procedure Intersection (Target : in out Tree_Type; Source : Tree_Type); + -- Removes elements from Target that are not equivalent to items in + -- Source. If Target is busy then Program_Error is raised. + + function Intersection (Left, Right : Tree_Type) return Tree_Type; + -- Returns a set comprising all the items in Left equivalent to items in + -- Right. + + procedure Difference (Target : in out Tree_Type; Source : Tree_Type); + -- Removes elements from Target that are equivalent to items in Source. If + -- Target is busy then Program_Error is raised. + + function Difference (Left, Right : Tree_Type) return Tree_Type; + -- Returns a set comprising all the items in Left not equivalent to items + -- in Right. + + procedure Symmetric_Difference + (Target : in out Tree_Type; + Source : Tree_Type); + -- Removes from Target elements that are equivalent to items in Source, and + -- inserts into Target items from Source not equivalent elements in + -- Target. If Target is busy then Program_Error is raised. + + function Symmetric_Difference (Left, Right : Tree_Type) return Tree_Type; + -- Returns a set comprising the union of the elements in Left not + -- equivalent to items in Right, and the elements in Right not equivalent + -- to items in Left. + + function Is_Subset (Subset : Tree_Type; Of_Set : Tree_Type) return Boolean; + -- Returns False if Subset contains at least one element not equivalent to + -- any item in Of_Set; returns True otherwise. + + function Overlap (Left, Right : Tree_Type) return Boolean; + -- Returns True if at least one element of Left is equivalent to an item in + -- Right; returns False otherwise. + +end Ada.Containers.Red_Black_Trees.Generic_Set_Operations; diff --git a/gcc/ada/libgnat/a-sbecin.adb b/gcc/ada/libgnat/a-sbecin.adb new file mode 100644 index 0000000..381874c --- /dev/null +++ b/gcc/ada/libgnat/a-sbecin.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Equal_Case_Insensitive; + +function Ada.Strings.Bounded.Equal_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean +is +begin + return Ada.Strings.Equal_Case_Insensitive + (Left => Bounded.To_String (Left), + Right => Bounded.To_String (Right)); +end Ada.Strings.Bounded.Equal_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-sbecin.ads b/gcc/ada/libgnat/a-sbecin.ads new file mode 100644 index 0000000..d510864 --- /dev/null +++ b/gcc/ada/libgnat/a-sbecin.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Equal_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Bounded.Equal_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-sbhcin.adb b/gcc/ada/libgnat/a-sbhcin.adb new file mode 100644 index 0000000..8456fae --- /dev/null +++ b/gcc/ada/libgnat/a-sbhcin.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Bounded.Hash_Case_Insensitive + (Key : Bounded.Bounded_String) + return Containers.Hash_Type +is +begin + return Ada.Strings.Hash_Case_Insensitive (Bounded.To_String (Key)); +end Ada.Strings.Bounded.Hash_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-sbhcin.ads b/gcc/ada/libgnat/a-sbhcin.ads new file mode 100644 index 0000000..323e542 --- /dev/null +++ b/gcc/ada/libgnat/a-sbhcin.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Hash_Case_Insensitive + (Key : Bounded.Bounded_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Bounded.Hash_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-sblcin.adb b/gcc/ada/libgnat/a-sblcin.adb new file mode 100644 index 0000000..cc1e242 --- /dev/null +++ b/gcc/ada/libgnat/a-sblcin.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Bounded.Less_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean +is +begin + return Ada.Strings.Less_Case_Insensitive + (Left => Bounded.To_String (Left), + Right => Bounded.To_String (Right)); +end Ada.Strings.Bounded.Less_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-sblcin.ads b/gcc/ada/libgnat/a-sblcin.ads new file mode 100644 index 0000000..97429f3 --- /dev/null +++ b/gcc/ada/libgnat/a-sblcin.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.BOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Less_Case_Insensitive + (Left, Right : Bounded.Bounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Bounded.Less_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-scteio.ads b/gcc/ada/libgnat/a-scteio.ads new file mode 100644 index 0000000..d9ceb2f --- /dev/null +++ b/gcc/ada/libgnat/a-scteio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ C O M P L E X _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Ada 2005 AI-328 + +with Ada.Text_IO.Complex_IO; +with Ada.Numerics.Short_Complex_Types; + +pragma Elaborate_All (Ada.Text_IO.Complex_IO); + +package Ada.Short_Complex_Text_IO is + new Ada.Text_IO.Complex_IO (Ada.Numerics.Short_Complex_Types); diff --git a/gcc/ada/libgnat/a-secain.adb b/gcc/ada/libgnat/a-secain.adb new file mode 100644 index 0000000..903a760 --- /dev/null +++ b/gcc/ada/libgnat/a-secain.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . E Q U A L _ C A S E _ I N S E N S I T I V E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +function Ada.Strings.Equal_Case_Insensitive + (Left, Right : String) return Boolean +is + LI : Integer := Left'First; + RI : Integer := Right'First; + +begin + if Left'Length /= Right'Length then + return False; + end if; + + if Left'Length = 0 then + return True; + end if; + + loop + if To_Lower (Left (LI)) /= To_Lower (Right (RI)) then + return False; + end if; + + if LI = Left'Last then + return True; + end if; + + LI := LI + 1; + RI := RI + 1; + end loop; +end Ada.Strings.Equal_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-secain.ads b/gcc/ada/libgnat/a-secain.ads new file mode 100644 index 0000000..b8b3f89 --- /dev/null +++ b/gcc/ada/libgnat/a-secain.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . E Q U A L _ C A S E _ I N S E N S I T I V E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Equal_Case_Insensitive + (Left, Right : String) return Boolean; +pragma Pure (Ada.Strings.Equal_Case_Insensitive); +-- Performs a case-insensitive equality test of Left and Right. This is +-- useful as the generic actual equivalence operation (Equivalent_Keys) +-- when instantiating a hashed container package with type String as the +-- key. It is also useful as the generic actual equality operator when +-- instantiating a container package with type String as the element, +-- allowing case-insensitive container equality tests. diff --git a/gcc/ada/libgnat/a-sequio.adb b/gcc/ada/libgnat/a-sequio.adb new file mode 100644 index 0000000..770e75a --- /dev/null +++ b/gcc/ada/libgnat/a-sequio.adb @@ -0,0 +1,314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the generic template for Sequential_IO, i.e. the code that gets +-- duplicated. We absolutely minimize this code by either calling routines +-- in System.File_IO (for common file functions), or in System.Sequential_IO +-- (for specialized Sequential_IO functions) + +with Ada.Unchecked_Conversion; + +with System; +with System.Byte_Swapping; +with System.CRTL; +with System.File_Control_Block; +with System.File_IO; +with System.Storage_Elements; + +with Interfaces.C_Streams; use Interfaces.C_Streams; + +package body Ada.Sequential_IO is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + package SIO renames System.Sequential_IO; + package SSE renames System.Storage_Elements; + + SU : constant := System.Storage_Unit; + + subtype AP is FCB.AFCB_Ptr; + subtype FP is SIO.File_Type; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + + use type System.Bit_Order; + use type System.CRTL.size_t; + + procedure Byte_Swap (Siz : in out size_t); + -- Byte swap Siz + + --------------- + -- Byte_Swap -- + --------------- + + procedure Byte_Swap (Siz : in out size_t) is + use System.Byte_Swapping; + begin + case Siz'Size is + when 32 => Siz := size_t (Bswap_32 (U32 (Siz))); + when 64 => Siz := size_t (Bswap_64 (U64 (Siz))); + when others => raise Program_Error; + end case; + end Byte_Swap; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + begin + SIO.Create (FP (File), To_FCB (Mode), Name, Form); + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + begin + return FIO.End_Of_File (AP (File)); + end End_Of_File; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_SIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + begin + SIO.Open (FP (File), To_FCB (Mode), Name, Form); + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read (File : File_Type; Item : out Element_Type) is + Siz : constant size_t := (Item'Size + SU - 1) / SU; + Rsiz : size_t; + + begin + FIO.Check_Read_Status (AP (File)); + + -- For non-definite type or type with discriminants, read size and + -- raise Program_Error if it is larger than the size of the item. + + if not Element_Type'Definite + or else Element_Type'Has_Discriminants + then + FIO.Read_Buf + (AP (File), Rsiz'Address, size_t'Size / System.Storage_Unit); + + -- If item read has non-default scalar storage order, then the size + -- will have been written with that same order, so byte swap it. + + if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then + Byte_Swap (Rsiz); + end if; + + -- For a type with discriminants, we have to read into a temporary + -- buffer if Item is constrained, to check that the discriminants + -- are correct. + + if Element_Type'Has_Discriminants and then Item'Constrained then + declare + RsizS : constant SSE.Storage_Offset := + SSE.Storage_Offset (Rsiz - 1); + + type SA is new SSE.Storage_Array (0 .. RsizS); + + for SA'Alignment use Standard'Maximum_Alignment; + -- We will perform an unchecked conversion of a pointer-to-SA + -- into pointer-to-Element_Type. We need to ensure that the + -- source is always at least as strictly aligned as the target. + + type SAP is access all SA; + type ItemP is access all Element_Type; + + pragma Warnings (Off); + -- We have to turn warnings off for function To_ItemP, + -- because it gets analyzed for all types, including ones + -- which can't possibly come this way, and for which the + -- size of the access types differs. + + function To_ItemP is new Ada.Unchecked_Conversion (SAP, ItemP); + + pragma Warnings (On); + + Buffer : aliased SA; + + pragma Unsuppress (Discriminant_Check); + + begin + FIO.Read_Buf (AP (File), Buffer'Address, Rsiz); + Item := To_ItemP (Buffer'Access).all; + return; + end; + end if; + + -- In the case of a non-definite type, make sure the length is OK. + -- We can't do this in the variant record case, because the size is + -- based on the current discriminant, so may be apparently wrong. + + if not Element_Type'Has_Discriminants and then Rsiz > Siz then + raise Program_Error; + end if; + + FIO.Read_Buf (AP (File), Item'Address, Rsiz); + + -- For definite type without discriminants, use actual size of item + + else + FIO.Read_Buf (AP (File), Item'Address, Siz); + end if; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : File_Mode) is + begin + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + end Reset; + + procedure Reset (File : in out File_Type) is + begin + FIO.Reset (AP (File)'Unrestricted_Access); + end Reset; + + ----------- + -- Write -- + ----------- + + procedure Write (File : File_Type; Item : Element_Type) is + Siz : constant size_t := (Item'Size + SU - 1) / SU; + -- Size to be written, in native representation + + Swapped_Siz : size_t := Siz; + -- Same, possibly byte swapped to account for Element_Type endianness + + begin + FIO.Check_Write_Status (AP (File)); + + -- For non-definite types or types with discriminants, write the size + + if not Element_Type'Definite + or else Element_Type'Has_Discriminants + then + -- If item written has non-default scalar storage order, then the + -- size is written with that same order, so byte swap it. + + if Element_Type'Scalar_Storage_Order /= System.Default_Bit_Order then + Byte_Swap (Swapped_Siz); + end if; + + FIO.Write_Buf + (AP (File), Swapped_Siz'Address, size_t'Size / System.Storage_Unit); + end if; + + FIO.Write_Buf (AP (File), Item'Address, Siz); + end Write; + +end Ada.Sequential_IO; diff --git a/gcc/ada/libgnat/a-sequio.ads b/gcc/ada/libgnat/a-sequio.ads new file mode 100644 index 0000000..6d2d568 --- /dev/null +++ b/gcc/ada/libgnat/a-sequio.ads @@ -0,0 +1,160 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; + +with System.Sequential_IO; + +generic + type Element_Type (<>) is private; + +package Ada.Sequential_IO is + + pragma Compile_Time_Warning + (Element_Type'Has_Access_Values, + "Element_Type for Sequential_IO instance has access values"); + + pragma Compile_Time_Warning + (Element_Type'Has_Tagged_Values, + "Element_Type for Sequential_IO instance has tagged values"); + + type File_Type is limited private; + + type File_Mode is (In_File, Out_File, Append_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) + Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) + Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) + + --------------------- + -- File management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : File_Type) return File_Mode; + function Name (File : File_Type) return String; + function Form (File : File_Type) return String; + + function Is_Open (File : File_Type) return Boolean; + + procedure Flush (File : File_Type); + + --------------------------------- + -- Input and output operations -- + --------------------------------- + + procedure Read (File : File_Type; Item : out Element_Type); + procedure Write (File : File_Type; Item : Element_Type); + + function End_Of_File (File : File_Type) return Boolean; + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + +private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + + type File_Type is new System.Sequential_IO.File_Type; + + -- All subprograms are inlined + + pragma Inline (Close); + pragma Inline (Create); + pragma Inline (Delete); + pragma Inline (End_Of_File); + pragma Inline (Form); + pragma Inline (Is_Open); + pragma Inline (Mode); + pragma Inline (Name); + pragma Inline (Open); + pragma Inline (Read); + pragma Inline (Reset); + pragma Inline (Write); + +end Ada.Sequential_IO; diff --git a/gcc/ada/libgnat/a-sfecin.ads b/gcc/ada/libgnat/a-sfecin.ads new file mode 100644 index 0000000..d2df2ea --- /dev/null +++ b/gcc/ada/libgnat/a-sfecin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Equal_Case_Insensitive; + +function Ada.Strings.Fixed.Equal_Case_Insensitive + (Left, Right : String) + return Boolean renames Ada.Strings.Equal_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Equal_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-sfhcin.ads b/gcc/ada/libgnat/a-sfhcin.ads new file mode 100644 index 0000000..03f3c2c --- /dev/null +++ b/gcc/ada/libgnat/a-sfhcin.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Fixed.Hash_Case_Insensitive + (Key : String) + return Containers.Hash_Type renames Ada.Strings.Hash_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Hash_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-sflcin.ads b/gcc/ada/libgnat/a-sflcin.ads new file mode 100644 index 0000000..69ea297 --- /dev/null +++ b/gcc/ada/libgnat/a-sflcin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.FIXED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Fixed.Less_Case_Insensitive + (Left, Right : String) + return Boolean renames Ada.Strings.Less_Case_Insensitive; + +pragma Pure (Ada.Strings.Fixed.Less_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-sfteio.ads b/gcc/ada/libgnat/a-sfteio.ads new file mode 100644 index 0000000..a1f18cd --- /dev/null +++ b/gcc/ada/libgnat/a-sfteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Float_Text_IO is + new Ada.Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/libgnat/a-sfwtio.ads b/gcc/ada/libgnat/a-sfwtio.ads new file mode 100644 index 0000000..3ac134e --- /dev/null +++ b/gcc/ada/libgnat/a-sfwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Float_Wide_Text_IO is + new Ada.Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/libgnat/a-sfztio.ads b/gcc/ada/libgnat/a-sfztio.ads new file mode 100644 index 0000000..bc34e5d --- /dev/null +++ b/gcc/ada/libgnat/a-sfztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ F L O A T _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Float_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Float_IO (Short_Float); diff --git a/gcc/ada/libgnat/a-shcain.adb b/gcc/ada/libgnat/a-shcain.adb new file mode 100644 index 0000000..83fe21e --- /dev/null +++ b/gcc/ada/libgnat/a-shcain.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with System.String_Hash; + +function Ada.Strings.Hash_Case_Insensitive + (Key : String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Character, String, Hash_Type); +begin + return Hash (To_Lower (Key)); +end Ada.Strings.Hash_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-shcain.ads b/gcc/ada/libgnat/a-shcain.ads new file mode 100644 index 0000000..266d899 --- /dev/null +++ b/gcc/ada/libgnat/a-shcain.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . H A S H _ C A S E _ I N S E N S I T I V E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Hash_Case_Insensitive + (Key : String) return Containers.Hash_Type; +pragma Pure (Ada.Strings.Hash_Case_Insensitive); +-- Computes a hash value for Key without regard for character case. This is +-- useful as the generic actual Hash function when instantiating a hashed +-- container package with type String as the key. diff --git a/gcc/ada/libgnat/a-siocst.adb b/gcc/ada/libgnat/a-siocst.adb new file mode 100644 index 0000000..5972f2d --- /dev/null +++ b/gcc/ada/libgnat/a-siocst.adb @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with System.Sequential_IO; +with Ada.Unchecked_Conversion; + +package body Ada.Sequential_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + package SIO renames System.Sequential_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : SIO.Sequential_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'Q', + Creat => False, + Text => False, + C_Stream => C_Stream); + end Open; + +end Ada.Sequential_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-siocst.ads b/gcc/ada/libgnat/a-siocst.ads new file mode 100644 index 0000000..bf9d135 --- /dev/null +++ b/gcc/ada/libgnat/a-siocst.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S E Q U E N T I A L _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Sequential_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +generic +package Ada.Sequential_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Sequential_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-siteio.ads b/gcc/ada/libgnat/a-siteio.ads new file mode 100644 index 0000000..de45c22 --- /dev/null +++ b/gcc/ada/libgnat/a-siteio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/libgnat/a-siwtio.ads b/gcc/ada/libgnat/a-siwtio.ads new file mode 100644 index 0000000..aa1a2d4 --- /dev/null +++ b/gcc/ada/libgnat/a-siwtio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/libgnat/a-siztio.ads b/gcc/ada/libgnat/a-siztio.ads new file mode 100644 index 0000000..3d6f5cd --- /dev/null +++ b/gcc/ada/libgnat/a-siztio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ I N T E G E R _ W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Integer); diff --git a/gcc/ada/libgnat/a-slcain.adb b/gcc/ada/libgnat/a-slcain.adb new file mode 100644 index 0000000..2a896e3 --- /dev/null +++ b/gcc/ada/libgnat/a-slcain.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; + +function Ada.Strings.Less_Case_Insensitive + (Left, Right : String) return Boolean +is + LI : Integer := Left'First; + RI : Integer := Right'First; + + LC, RC : Character; + +begin + if LI > Left'Last then + return RI <= Right'Last; + end if; + + if RI > Right'Last then + return False; + end if; + + loop + LC := To_Lower (Left (LI)); + RC := To_Lower (Right (RI)); + + if LC < RC then + return True; + end if; + + if LC > RC then + return False; + end if; + + if LI = Left'Last then + return RI < Right'Last; + end if; + + if RI = Right'Last then + return False; + end if; + + LI := LI + 1; + RI := RI + 1; + end loop; +end Ada.Strings.Less_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-slcain.ads b/gcc/ada/libgnat/a-slcain.ads new file mode 100644 index 0000000..e884873 --- /dev/null +++ b/gcc/ada/libgnat/a-slcain.ads @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Less_Case_Insensitive + (Left, Right : String) return Boolean; +pragma Pure (Ada.Strings.Less_Case_Insensitive); +-- Performs a case-insensitive lexicographic comparison of Left and +-- Right. This is useful as the generic actual less-than operator when +-- instantiating an ordered container package with type String as the key, +-- allowing case-insensitive equivalence tests. diff --git a/gcc/ada/libgnat/a-ssicst.adb b/gcc/ada/libgnat/a-ssicst.adb new file mode 100644 index 0000000..1e5b394 --- /dev/null +++ b/gcc/ada/libgnat/a-ssicst.adb @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with Ada.Unchecked_Conversion; + +package body Ada.Streams.Stream_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : Stream_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'S', + Creat => False, + Text => False, + C_Stream => C_Stream); + + File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read); + -- See comment in Ada.Streams.Stream_IO.Open for the reason + end Open; + +end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-ssicst.ads b/gcc/ada/libgnat/a-ssicst.ads new file mode 100644 index 0000000..ceadadf --- /dev/null +++ b/gcc/ada/libgnat/a-ssicst.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S . S T R E A M _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Stream_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +package Ada.Streams.Stream_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Streams.Stream_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-ssitio.ads b/gcc/ada/libgnat/a-ssitio.ads new file mode 100644 index 0000000..98b0540 --- /dev/null +++ b/gcc/ada/libgnat/a-ssitio.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +package Ada.Short_Short_Integer_Text_IO is + new Ada.Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/libgnat/a-ssiwti.ads b/gcc/ada/libgnat/a-ssiwti.ads new file mode 100644 index 0000000..5f6934b --- /dev/null +++ b/gcc/ada/libgnat/a-ssiwti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; + +package Ada.Short_Short_Integer_Wide_Text_IO is + new Ada.Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/libgnat/a-ssizti.ads b/gcc/ada/libgnat/a-ssizti.ads new file mode 100644 index 0000000..13bfda8 --- /dev/null +++ b/gcc/ada/libgnat/a-ssizti.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S H O R T _ S H O R T _ I N T E G E R _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; + +package Ada.Short_Short_Integer_Wide_Wide_Text_IO is + new Ada.Wide_Wide_Text_IO.Integer_IO (Short_Short_Integer); diff --git a/gcc/ada/libgnat/a-stboha.adb b/gcc/ada/libgnat/a-stboha.adb new file mode 100644 index 0000000..67dd87a --- /dev/null +++ b/gcc/ada/libgnat/a-stboha.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . B O U N D E D . H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String) + return Containers.Hash_Type +is + use Ada.Containers; + function Hash_Fun is new System.String_Hash.Hash + (Character, String, Hash_Type); +begin + return Hash_Fun (Bounded.To_String (Key)); +end Ada.Strings.Bounded.Hash; diff --git a/gcc/ada/libgnat/a-stboha.ads b/gcc/ada/libgnat/a-stboha.ads new file mode 100644 index 0000000..876af2a --- /dev/null +++ b/gcc/ada/libgnat/a-stboha.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . B O U N D E D . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Bounded.Hash (Key : Bounded.Bounded_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Bounded.Hash); diff --git a/gcc/ada/libgnat/a-stfiha.ads b/gcc/ada/libgnat/a-stfiha.ads new file mode 100644 index 0000000..aba42e7 --- /dev/null +++ b/gcc/ada/libgnat/a-stfiha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . F I X E D . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers, Ada.Strings.Hash; + +function Ada.Strings.Fixed.Hash (Key : String) return Containers.Hash_Type + renames Ada.Strings.Hash; + +pragma Pure (Ada.Strings.Fixed.Hash); diff --git a/gcc/ada/libgnat/a-stmaco.ads b/gcc/ada/libgnat/a-stmaco.ads new file mode 100644 index 0000000..aed9abc --- /dev/null +++ b/gcc/ada/libgnat/a-stmaco.ads @@ -0,0 +1,915 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . M A P S . C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Latin_1; + +package Ada.Strings.Maps.Constants is + pragma Pure; + -- In accordance with Ada 2005 AI-362 + + Control_Set : constant Character_Set; + Graphic_Set : constant Character_Set; + Letter_Set : constant Character_Set; + Lower_Set : constant Character_Set; + Upper_Set : constant Character_Set; + Basic_Set : constant Character_Set; + Decimal_Digit_Set : constant Character_Set; + Hexadecimal_Digit_Set : constant Character_Set; + Alphanumeric_Set : constant Character_Set; + Special_Set : constant Character_Set; + ISO_646_Set : constant Character_Set; + + Lower_Case_Map : constant Character_Mapping; + -- Maps to lower case for letters, else identity + + Upper_Case_Map : constant Character_Mapping; + -- Maps to upper case for letters, else identity + + Basic_Map : constant Character_Mapping; + -- Maps to basic letters for letters, else identity + +private + package L renames Ada.Characters.Latin_1; + + Control_Set : constant Character_Set := + (L.NUL .. L.US => True, + L.DEL .. L.APC => True, + others => False); + + Graphic_Set : constant Character_Set := + (L.Space .. L.Tilde => True, + L.No_Break_Space .. L.LC_Y_Diaeresis => True, + others => False); + + Letter_Set : constant Character_Set := + ('A' .. 'Z' => True, + L.LC_A .. L.LC_Z => True, + L.UC_A_Grave .. L.UC_O_Diaeresis => True, + L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True, + L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, + others => False); + + Lower_Set : constant Character_Set := + (L.LC_A .. L.LC_Z => True, + L.LC_German_Sharp_S .. L.LC_O_Diaeresis => True, + L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, + others => False); + + Upper_Set : constant Character_Set := + ('A' .. 'Z' => True, + L.UC_A_Grave .. L.UC_O_Diaeresis => True, + L.UC_O_Oblique_Stroke .. L.UC_Icelandic_Thorn => True, + others => False); + + Basic_Set : constant Character_Set := + ('A' .. 'Z' => True, + L.LC_A .. L.LC_Z => True, + L.UC_AE_Diphthong .. L.UC_AE_Diphthong => True, + L.LC_AE_Diphthong .. L.LC_AE_Diphthong => True, + L.LC_German_Sharp_S .. L.LC_German_Sharp_S => True, + L.UC_Icelandic_Thorn .. L.UC_Icelandic_Thorn => True, + L.LC_Icelandic_Thorn .. L.LC_Icelandic_Thorn => True, + L.UC_Icelandic_Eth .. L.UC_Icelandic_Eth => True, + L.LC_Icelandic_Eth .. L.LC_Icelandic_Eth => True, + others => False); + + Decimal_Digit_Set : constant Character_Set := + ('0' .. '9' => True, + others => False); + + Hexadecimal_Digit_Set : constant Character_Set := + ('0' .. '9' => True, + 'A' .. 'F' => True, + L.LC_A .. L.LC_F => True, + others => False); + + Alphanumeric_Set : constant Character_Set := + ('0' .. '9' => True, + 'A' .. 'Z' => True, + L.LC_A .. L.LC_Z => True, + L.UC_A_Grave .. L.UC_O_Diaeresis => True, + L.UC_O_Oblique_Stroke .. L.LC_O_Diaeresis => True, + L.LC_O_Oblique_Stroke .. L.LC_Y_Diaeresis => True, + others => False); + + Special_Set : constant Character_Set := + (L.Space .. L.Solidus => True, + L.Colon .. L.Commercial_At => True, + L.Left_Square_Bracket .. L.Grave => True, + L.Left_Curly_Bracket .. L.Tilde => True, + L.No_Break_Space .. L.Inverted_Question => True, + L.Multiplication_Sign .. L.Multiplication_Sign => True, + L.Division_Sign .. L.Division_Sign => True, + others => False); + + ISO_646_Set : constant Character_Set := + (L.NUL .. L.DEL => True, + others => False); + + Lower_Case_Map : constant Character_Mapping := + (L.NUL & -- NUL 0 + L.SOH & -- SOH 1 + L.STX & -- STX 2 + L.ETX & -- ETX 3 + L.EOT & -- EOT 4 + L.ENQ & -- ENQ 5 + L.ACK & -- ACK 6 + L.BEL & -- BEL 7 + L.BS & -- BS 8 + L.HT & -- HT 9 + L.LF & -- LF 10 + L.VT & -- VT 11 + L.FF & -- FF 12 + L.CR & -- CR 13 + L.SO & -- SO 14 + L.SI & -- SI 15 + L.DLE & -- DLE 16 + L.DC1 & -- DC1 17 + L.DC2 & -- DC2 18 + L.DC3 & -- DC3 19 + L.DC4 & -- DC4 20 + L.NAK & -- NAK 21 + L.SYN & -- SYN 22 + L.ETB & -- ETB 23 + L.CAN & -- CAN 24 + L.EM & -- EM 25 + L.SUB & -- SUB 26 + L.ESC & -- ESC 27 + L.FS & -- FS 28 + L.GS & -- GS 29 + L.RS & -- RS 30 + L.US & -- US 31 + L.Space & -- ' ' 32 + L.Exclamation & -- '!' 33 + L.Quotation & -- '"' 34 + L.Number_Sign & -- '#' 35 + L.Dollar_Sign & -- '$' 36 + L.Percent_Sign & -- '%' 37 + L.Ampersand & -- '&' 38 + L.Apostrophe & -- ''' 39 + L.Left_Parenthesis & -- '(' 40 + L.Right_Parenthesis & -- ')' 41 + L.Asterisk & -- '*' 42 + L.Plus_Sign & -- '+' 43 + L.Comma & -- ',' 44 + L.Hyphen & -- '-' 45 + L.Full_Stop & -- '.' 46 + L.Solidus & -- '/' 47 + '0' & -- '0' 48 + '1' & -- '1' 49 + '2' & -- '2' 50 + '3' & -- '3' 51 + '4' & -- '4' 52 + '5' & -- '5' 53 + '6' & -- '6' 54 + '7' & -- '7' 55 + '8' & -- '8' 56 + '9' & -- '9' 57 + L.Colon & -- ':' 58 + L.Semicolon & -- ';' 59 + L.Less_Than_Sign & -- '<' 60 + L.Equals_Sign & -- '=' 61 + L.Greater_Than_Sign & -- '>' 62 + L.Question & -- '?' 63 + L.Commercial_At & -- '@' 64 + L.LC_A & -- 'a' 65 + L.LC_B & -- 'b' 66 + L.LC_C & -- 'c' 67 + L.LC_D & -- 'd' 68 + L.LC_E & -- 'e' 69 + L.LC_F & -- 'f' 70 + L.LC_G & -- 'g' 71 + L.LC_H & -- 'h' 72 + L.LC_I & -- 'i' 73 + L.LC_J & -- 'j' 74 + L.LC_K & -- 'k' 75 + L.LC_L & -- 'l' 76 + L.LC_M & -- 'm' 77 + L.LC_N & -- 'n' 78 + L.LC_O & -- 'o' 79 + L.LC_P & -- 'p' 80 + L.LC_Q & -- 'q' 81 + L.LC_R & -- 'r' 82 + L.LC_S & -- 's' 83 + L.LC_T & -- 't' 84 + L.LC_U & -- 'u' 85 + L.LC_V & -- 'v' 86 + L.LC_W & -- 'w' 87 + L.LC_X & -- 'x' 88 + L.LC_Y & -- 'y' 89 + L.LC_Z & -- 'z' 90 + L.Left_Square_Bracket & -- '[' 91 + L.Reverse_Solidus & -- '\' 92 + L.Right_Square_Bracket & -- ']' 93 + L.Circumflex & -- '^' 94 + L.Low_Line & -- '_' 95 + L.Grave & -- '`' 96 + L.LC_A & -- 'a' 97 + L.LC_B & -- 'b' 98 + L.LC_C & -- 'c' 99 + L.LC_D & -- 'd' 100 + L.LC_E & -- 'e' 101 + L.LC_F & -- 'f' 102 + L.LC_G & -- 'g' 103 + L.LC_H & -- 'h' 104 + L.LC_I & -- 'i' 105 + L.LC_J & -- 'j' 106 + L.LC_K & -- 'k' 107 + L.LC_L & -- 'l' 108 + L.LC_M & -- 'm' 109 + L.LC_N & -- 'n' 110 + L.LC_O & -- 'o' 111 + L.LC_P & -- 'p' 112 + L.LC_Q & -- 'q' 113 + L.LC_R & -- 'r' 114 + L.LC_S & -- 's' 115 + L.LC_T & -- 't' 116 + L.LC_U & -- 'u' 117 + L.LC_V & -- 'v' 118 + L.LC_W & -- 'w' 119 + L.LC_X & -- 'x' 120 + L.LC_Y & -- 'y' 121 + L.LC_Z & -- 'z' 122 + L.Left_Curly_Bracket & -- '{' 123 + L.Vertical_Line & -- '|' 124 + L.Right_Curly_Bracket & -- '}' 125 + L.Tilde & -- '~' 126 + L.DEL & -- DEL 127 + L.Reserved_128 & -- Reserved_128 128 + L.Reserved_129 & -- Reserved_129 129 + L.BPH & -- BPH 130 + L.NBH & -- NBH 131 + L.Reserved_132 & -- Reserved_132 132 + L.NEL & -- NEL 133 + L.SSA & -- SSA 134 + L.ESA & -- ESA 135 + L.HTS & -- HTS 136 + L.HTJ & -- HTJ 137 + L.VTS & -- VTS 138 + L.PLD & -- PLD 139 + L.PLU & -- PLU 140 + L.RI & -- RI 141 + L.SS2 & -- SS2 142 + L.SS3 & -- SS3 143 + L.DCS & -- DCS 144 + L.PU1 & -- PU1 145 + L.PU2 & -- PU2 146 + L.STS & -- STS 147 + L.CCH & -- CCH 148 + L.MW & -- MW 149 + L.SPA & -- SPA 150 + L.EPA & -- EPA 151 + L.SOS & -- SOS 152 + L.Reserved_153 & -- Reserved_153 153 + L.SCI & -- SCI 154 + L.CSI & -- CSI 155 + L.ST & -- ST 156 + L.OSC & -- OSC 157 + L.PM & -- PM 158 + L.APC & -- APC 159 + L.No_Break_Space & -- No_Break_Space 160 + L.Inverted_Exclamation & -- Inverted_Exclamation 161 + L.Cent_Sign & -- Cent_Sign 162 + L.Pound_Sign & -- Pound_Sign 163 + L.Currency_Sign & -- Currency_Sign 164 + L.Yen_Sign & -- Yen_Sign 165 + L.Broken_Bar & -- Broken_Bar 166 + L.Section_Sign & -- Section_Sign 167 + L.Diaeresis & -- Diaeresis 168 + L.Copyright_Sign & -- Copyright_Sign 169 + L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 + L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 + L.Not_Sign & -- Not_Sign 172 + L.Soft_Hyphen & -- Soft_Hyphen 173 + L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 + L.Macron & -- Macron 175 + L.Degree_Sign & -- Degree_Sign 176 + L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 + L.Superscript_Two & -- Superscript_Two 178 + L.Superscript_Three & -- Superscript_Three 179 + L.Acute & -- Acute 180 + L.Micro_Sign & -- Micro_Sign 181 + L.Pilcrow_Sign & -- Pilcrow_Sign 182 + L.Middle_Dot & -- Middle_Dot 183 + L.Cedilla & -- Cedilla 184 + L.Superscript_One & -- Superscript_One 185 + L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 + L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 + L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 + L.Fraction_One_Half & -- Fraction_One_Half 189 + L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 + L.Inverted_Question & -- Inverted_Question 191 + L.LC_A_Grave & -- UC_A_Grave 192 + L.LC_A_Acute & -- UC_A_Acute 193 + L.LC_A_Circumflex & -- UC_A_Circumflex 194 + L.LC_A_Tilde & -- UC_A_Tilde 195 + L.LC_A_Diaeresis & -- UC_A_Diaeresis 196 + L.LC_A_Ring & -- UC_A_Ring 197 + L.LC_AE_Diphthong & -- UC_AE_Diphthong 198 + L.LC_C_Cedilla & -- UC_C_Cedilla 199 + L.LC_E_Grave & -- UC_E_Grave 200 + L.LC_E_Acute & -- UC_E_Acute 201 + L.LC_E_Circumflex & -- UC_E_Circumflex 202 + L.LC_E_Diaeresis & -- UC_E_Diaeresis 203 + L.LC_I_Grave & -- UC_I_Grave 204 + L.LC_I_Acute & -- UC_I_Acute 205 + L.LC_I_Circumflex & -- UC_I_Circumflex 206 + L.LC_I_Diaeresis & -- UC_I_Diaeresis 207 + L.LC_Icelandic_Eth & -- UC_Icelandic_Eth 208 + L.LC_N_Tilde & -- UC_N_Tilde 209 + L.LC_O_Grave & -- UC_O_Grave 210 + L.LC_O_Acute & -- UC_O_Acute 211 + L.LC_O_Circumflex & -- UC_O_Circumflex 212 + L.LC_O_Tilde & -- UC_O_Tilde 213 + L.LC_O_Diaeresis & -- UC_O_Diaeresis 214 + L.Multiplication_Sign & -- Multiplication_Sign 215 + L.LC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 + L.LC_U_Grave & -- UC_U_Grave 217 + L.LC_U_Acute & -- UC_U_Acute 218 + L.LC_U_Circumflex & -- UC_U_Circumflex 219 + L.LC_U_Diaeresis & -- UC_U_Diaeresis 220 + L.LC_Y_Acute & -- UC_Y_Acute 221 + L.LC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 + L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 + L.LC_A_Grave & -- LC_A_Grave 224 + L.LC_A_Acute & -- LC_A_Acute 225 + L.LC_A_Circumflex & -- LC_A_Circumflex 226 + L.LC_A_Tilde & -- LC_A_Tilde 227 + L.LC_A_Diaeresis & -- LC_A_Diaeresis 228 + L.LC_A_Ring & -- LC_A_Ring 229 + L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 + L.LC_C_Cedilla & -- LC_C_Cedilla 231 + L.LC_E_Grave & -- LC_E_Grave 232 + L.LC_E_Acute & -- LC_E_Acute 233 + L.LC_E_Circumflex & -- LC_E_Circumflex 234 + L.LC_E_Diaeresis & -- LC_E_Diaeresis 235 + L.LC_I_Grave & -- LC_I_Grave 236 + L.LC_I_Acute & -- LC_I_Acute 237 + L.LC_I_Circumflex & -- LC_I_Circumflex 238 + L.LC_I_Diaeresis & -- LC_I_Diaeresis 239 + L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 + L.LC_N_Tilde & -- LC_N_Tilde 241 + L.LC_O_Grave & -- LC_O_Grave 242 + L.LC_O_Acute & -- LC_O_Acute 243 + L.LC_O_Circumflex & -- LC_O_Circumflex 244 + L.LC_O_Tilde & -- LC_O_Tilde 245 + L.LC_O_Diaeresis & -- LC_O_Diaeresis 246 + L.Division_Sign & -- Division_Sign 247 + L.LC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 + L.LC_U_Grave & -- LC_U_Grave 249 + L.LC_U_Acute & -- LC_U_Acute 250 + L.LC_U_Circumflex & -- LC_U_Circumflex 251 + L.LC_U_Diaeresis & -- LC_U_Diaeresis 252 + L.LC_Y_Acute & -- LC_Y_Acute 253 + L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 + L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 + + Upper_Case_Map : constant Character_Mapping := + (L.NUL & -- NUL 0 + L.SOH & -- SOH 1 + L.STX & -- STX 2 + L.ETX & -- ETX 3 + L.EOT & -- EOT 4 + L.ENQ & -- ENQ 5 + L.ACK & -- ACK 6 + L.BEL & -- BEL 7 + L.BS & -- BS 8 + L.HT & -- HT 9 + L.LF & -- LF 10 + L.VT & -- VT 11 + L.FF & -- FF 12 + L.CR & -- CR 13 + L.SO & -- SO 14 + L.SI & -- SI 15 + L.DLE & -- DLE 16 + L.DC1 & -- DC1 17 + L.DC2 & -- DC2 18 + L.DC3 & -- DC3 19 + L.DC4 & -- DC4 20 + L.NAK & -- NAK 21 + L.SYN & -- SYN 22 + L.ETB & -- ETB 23 + L.CAN & -- CAN 24 + L.EM & -- EM 25 + L.SUB & -- SUB 26 + L.ESC & -- ESC 27 + L.FS & -- FS 28 + L.GS & -- GS 29 + L.RS & -- RS 30 + L.US & -- US 31 + L.Space & -- ' ' 32 + L.Exclamation & -- '!' 33 + L.Quotation & -- '"' 34 + L.Number_Sign & -- '#' 35 + L.Dollar_Sign & -- '$' 36 + L.Percent_Sign & -- '%' 37 + L.Ampersand & -- '&' 38 + L.Apostrophe & -- ''' 39 + L.Left_Parenthesis & -- '(' 40 + L.Right_Parenthesis & -- ')' 41 + L.Asterisk & -- '*' 42 + L.Plus_Sign & -- '+' 43 + L.Comma & -- ',' 44 + L.Hyphen & -- '-' 45 + L.Full_Stop & -- '.' 46 + L.Solidus & -- '/' 47 + '0' & -- '0' 48 + '1' & -- '1' 49 + '2' & -- '2' 50 + '3' & -- '3' 51 + '4' & -- '4' 52 + '5' & -- '5' 53 + '6' & -- '6' 54 + '7' & -- '7' 55 + '8' & -- '8' 56 + '9' & -- '9' 57 + L.Colon & -- ':' 58 + L.Semicolon & -- ';' 59 + L.Less_Than_Sign & -- '<' 60 + L.Equals_Sign & -- '=' 61 + L.Greater_Than_Sign & -- '>' 62 + L.Question & -- '?' 63 + L.Commercial_At & -- '@' 64 + 'A' & -- 'A' 65 + 'B' & -- 'B' 66 + 'C' & -- 'C' 67 + 'D' & -- 'D' 68 + 'E' & -- 'E' 69 + 'F' & -- 'F' 70 + 'G' & -- 'G' 71 + 'H' & -- 'H' 72 + 'I' & -- 'I' 73 + 'J' & -- 'J' 74 + 'K' & -- 'K' 75 + 'L' & -- 'L' 76 + 'M' & -- 'M' 77 + 'N' & -- 'N' 78 + 'O' & -- 'O' 79 + 'P' & -- 'P' 80 + 'Q' & -- 'Q' 81 + 'R' & -- 'R' 82 + 'S' & -- 'S' 83 + 'T' & -- 'T' 84 + 'U' & -- 'U' 85 + 'V' & -- 'V' 86 + 'W' & -- 'W' 87 + 'X' & -- 'X' 88 + 'Y' & -- 'Y' 89 + 'Z' & -- 'Z' 90 + L.Left_Square_Bracket & -- '[' 91 + L.Reverse_Solidus & -- '\' 92 + L.Right_Square_Bracket & -- ']' 93 + L.Circumflex & -- '^' 94 + L.Low_Line & -- '_' 95 + L.Grave & -- '`' 96 + 'A' & -- 'a' 97 + 'B' & -- 'b' 98 + 'C' & -- 'c' 99 + 'D' & -- 'd' 100 + 'E' & -- 'e' 101 + 'F' & -- 'f' 102 + 'G' & -- 'g' 103 + 'H' & -- 'h' 104 + 'I' & -- 'i' 105 + 'J' & -- 'j' 106 + 'K' & -- 'k' 107 + 'L' & -- 'l' 108 + 'M' & -- 'm' 109 + 'N' & -- 'n' 110 + 'O' & -- 'o' 111 + 'P' & -- 'p' 112 + 'Q' & -- 'q' 113 + 'R' & -- 'r' 114 + 'S' & -- 's' 115 + 'T' & -- 't' 116 + 'U' & -- 'u' 117 + 'V' & -- 'v' 118 + 'W' & -- 'w' 119 + 'X' & -- 'x' 120 + 'Y' & -- 'y' 121 + 'Z' & -- 'z' 122 + L.Left_Curly_Bracket & -- '{' 123 + L.Vertical_Line & -- '|' 124 + L.Right_Curly_Bracket & -- '}' 125 + L.Tilde & -- '~' 126 + L.DEL & -- DEL 127 + L.Reserved_128 & -- Reserved_128 128 + L.Reserved_129 & -- Reserved_129 129 + L.BPH & -- BPH 130 + L.NBH & -- NBH 131 + L.Reserved_132 & -- Reserved_132 132 + L.NEL & -- NEL 133 + L.SSA & -- SSA 134 + L.ESA & -- ESA 135 + L.HTS & -- HTS 136 + L.HTJ & -- HTJ 137 + L.VTS & -- VTS 138 + L.PLD & -- PLD 139 + L.PLU & -- PLU 140 + L.RI & -- RI 141 + L.SS2 & -- SS2 142 + L.SS3 & -- SS3 143 + L.DCS & -- DCS 144 + L.PU1 & -- PU1 145 + L.PU2 & -- PU2 146 + L.STS & -- STS 147 + L.CCH & -- CCH 148 + L.MW & -- MW 149 + L.SPA & -- SPA 150 + L.EPA & -- EPA 151 + L.SOS & -- SOS 152 + L.Reserved_153 & -- Reserved_153 153 + L.SCI & -- SCI 154 + L.CSI & -- CSI 155 + L.ST & -- ST 156 + L.OSC & -- OSC 157 + L.PM & -- PM 158 + L.APC & -- APC 159 + L.No_Break_Space & -- No_Break_Space 160 + L.Inverted_Exclamation & -- Inverted_Exclamation 161 + L.Cent_Sign & -- Cent_Sign 162 + L.Pound_Sign & -- Pound_Sign 163 + L.Currency_Sign & -- Currency_Sign 164 + L.Yen_Sign & -- Yen_Sign 165 + L.Broken_Bar & -- Broken_Bar 166 + L.Section_Sign & -- Section_Sign 167 + L.Diaeresis & -- Diaeresis 168 + L.Copyright_Sign & -- Copyright_Sign 169 + L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 + L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 + L.Not_Sign & -- Not_Sign 172 + L.Soft_Hyphen & -- Soft_Hyphen 173 + L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 + L.Macron & -- Macron 175 + L.Degree_Sign & -- Degree_Sign 176 + L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 + L.Superscript_Two & -- Superscript_Two 178 + L.Superscript_Three & -- Superscript_Three 179 + L.Acute & -- Acute 180 + L.Micro_Sign & -- Micro_Sign 181 + L.Pilcrow_Sign & -- Pilcrow_Sign 182 + L.Middle_Dot & -- Middle_Dot 183 + L.Cedilla & -- Cedilla 184 + L.Superscript_One & -- Superscript_One 185 + L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 + L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 + L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 + L.Fraction_One_Half & -- Fraction_One_Half 189 + L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 + L.Inverted_Question & -- Inverted_Question 191 + L.UC_A_Grave & -- UC_A_Grave 192 + L.UC_A_Acute & -- UC_A_Acute 193 + L.UC_A_Circumflex & -- UC_A_Circumflex 194 + L.UC_A_Tilde & -- UC_A_Tilde 195 + L.UC_A_Diaeresis & -- UC_A_Diaeresis 196 + L.UC_A_Ring & -- UC_A_Ring 197 + L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 + L.UC_C_Cedilla & -- UC_C_Cedilla 199 + L.UC_E_Grave & -- UC_E_Grave 200 + L.UC_E_Acute & -- UC_E_Acute 201 + L.UC_E_Circumflex & -- UC_E_Circumflex 202 + L.UC_E_Diaeresis & -- UC_E_Diaeresis 203 + L.UC_I_Grave & -- UC_I_Grave 204 + L.UC_I_Acute & -- UC_I_Acute 205 + L.UC_I_Circumflex & -- UC_I_Circumflex 206 + L.UC_I_Diaeresis & -- UC_I_Diaeresis 207 + L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 + L.UC_N_Tilde & -- UC_N_Tilde 209 + L.UC_O_Grave & -- UC_O_Grave 210 + L.UC_O_Acute & -- UC_O_Acute 211 + L.UC_O_Circumflex & -- UC_O_Circumflex 212 + L.UC_O_Tilde & -- UC_O_Tilde 213 + L.UC_O_Diaeresis & -- UC_O_Diaeresis 214 + L.Multiplication_Sign & -- Multiplication_Sign 215 + L.UC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 + L.UC_U_Grave & -- UC_U_Grave 217 + L.UC_U_Acute & -- UC_U_Acute 218 + L.UC_U_Circumflex & -- UC_U_Circumflex 219 + L.UC_U_Diaeresis & -- UC_U_Diaeresis 220 + L.UC_Y_Acute & -- UC_Y_Acute 221 + L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 + L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 + L.UC_A_Grave & -- LC_A_Grave 224 + L.UC_A_Acute & -- LC_A_Acute 225 + L.UC_A_Circumflex & -- LC_A_Circumflex 226 + L.UC_A_Tilde & -- LC_A_Tilde 227 + L.UC_A_Diaeresis & -- LC_A_Diaeresis 228 + L.UC_A_Ring & -- LC_A_Ring 229 + L.UC_AE_Diphthong & -- LC_AE_Diphthong 230 + L.UC_C_Cedilla & -- LC_C_Cedilla 231 + L.UC_E_Grave & -- LC_E_Grave 232 + L.UC_E_Acute & -- LC_E_Acute 233 + L.UC_E_Circumflex & -- LC_E_Circumflex 234 + L.UC_E_Diaeresis & -- LC_E_Diaeresis 235 + L.UC_I_Grave & -- LC_I_Grave 236 + L.UC_I_Acute & -- LC_I_Acute 237 + L.UC_I_Circumflex & -- LC_I_Circumflex 238 + L.UC_I_Diaeresis & -- LC_I_Diaeresis 239 + L.UC_Icelandic_Eth & -- LC_Icelandic_Eth 240 + L.UC_N_Tilde & -- LC_N_Tilde 241 + L.UC_O_Grave & -- LC_O_Grave 242 + L.UC_O_Acute & -- LC_O_Acute 243 + L.UC_O_Circumflex & -- LC_O_Circumflex 244 + L.UC_O_Tilde & -- LC_O_Tilde 245 + L.UC_O_Diaeresis & -- LC_O_Diaeresis 246 + L.Division_Sign & -- Division_Sign 247 + L.UC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 + L.UC_U_Grave & -- LC_U_Grave 249 + L.UC_U_Acute & -- LC_U_Acute 250 + L.UC_U_Circumflex & -- LC_U_Circumflex 251 + L.UC_U_Diaeresis & -- LC_U_Diaeresis 252 + L.UC_Y_Acute & -- LC_Y_Acute 253 + L.UC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 + L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 + + Basic_Map : constant Character_Mapping := + (L.NUL & -- NUL 0 + L.SOH & -- SOH 1 + L.STX & -- STX 2 + L.ETX & -- ETX 3 + L.EOT & -- EOT 4 + L.ENQ & -- ENQ 5 + L.ACK & -- ACK 6 + L.BEL & -- BEL 7 + L.BS & -- BS 8 + L.HT & -- HT 9 + L.LF & -- LF 10 + L.VT & -- VT 11 + L.FF & -- FF 12 + L.CR & -- CR 13 + L.SO & -- SO 14 + L.SI & -- SI 15 + L.DLE & -- DLE 16 + L.DC1 & -- DC1 17 + L.DC2 & -- DC2 18 + L.DC3 & -- DC3 19 + L.DC4 & -- DC4 20 + L.NAK & -- NAK 21 + L.SYN & -- SYN 22 + L.ETB & -- ETB 23 + L.CAN & -- CAN 24 + L.EM & -- EM 25 + L.SUB & -- SUB 26 + L.ESC & -- ESC 27 + L.FS & -- FS 28 + L.GS & -- GS 29 + L.RS & -- RS 30 + L.US & -- US 31 + L.Space & -- ' ' 32 + L.Exclamation & -- '!' 33 + L.Quotation & -- '"' 34 + L.Number_Sign & -- '#' 35 + L.Dollar_Sign & -- '$' 36 + L.Percent_Sign & -- '%' 37 + L.Ampersand & -- '&' 38 + L.Apostrophe & -- ''' 39 + L.Left_Parenthesis & -- '(' 40 + L.Right_Parenthesis & -- ')' 41 + L.Asterisk & -- '*' 42 + L.Plus_Sign & -- '+' 43 + L.Comma & -- ',' 44 + L.Hyphen & -- '-' 45 + L.Full_Stop & -- '.' 46 + L.Solidus & -- '/' 47 + '0' & -- '0' 48 + '1' & -- '1' 49 + '2' & -- '2' 50 + '3' & -- '3' 51 + '4' & -- '4' 52 + '5' & -- '5' 53 + '6' & -- '6' 54 + '7' & -- '7' 55 + '8' & -- '8' 56 + '9' & -- '9' 57 + L.Colon & -- ':' 58 + L.Semicolon & -- ';' 59 + L.Less_Than_Sign & -- '<' 60 + L.Equals_Sign & -- '=' 61 + L.Greater_Than_Sign & -- '>' 62 + L.Question & -- '?' 63 + L.Commercial_At & -- '@' 64 + 'A' & -- 'A' 65 + 'B' & -- 'B' 66 + 'C' & -- 'C' 67 + 'D' & -- 'D' 68 + 'E' & -- 'E' 69 + 'F' & -- 'F' 70 + 'G' & -- 'G' 71 + 'H' & -- 'H' 72 + 'I' & -- 'I' 73 + 'J' & -- 'J' 74 + 'K' & -- 'K' 75 + 'L' & -- 'L' 76 + 'M' & -- 'M' 77 + 'N' & -- 'N' 78 + 'O' & -- 'O' 79 + 'P' & -- 'P' 80 + 'Q' & -- 'Q' 81 + 'R' & -- 'R' 82 + 'S' & -- 'S' 83 + 'T' & -- 'T' 84 + 'U' & -- 'U' 85 + 'V' & -- 'V' 86 + 'W' & -- 'W' 87 + 'X' & -- 'X' 88 + 'Y' & -- 'Y' 89 + 'Z' & -- 'Z' 90 + L.Left_Square_Bracket & -- '[' 91 + L.Reverse_Solidus & -- '\' 92 + L.Right_Square_Bracket & -- ']' 93 + L.Circumflex & -- '^' 94 + L.Low_Line & -- '_' 95 + L.Grave & -- '`' 96 + L.LC_A & -- 'a' 97 + L.LC_B & -- 'b' 98 + L.LC_C & -- 'c' 99 + L.LC_D & -- 'd' 100 + L.LC_E & -- 'e' 101 + L.LC_F & -- 'f' 102 + L.LC_G & -- 'g' 103 + L.LC_H & -- 'h' 104 + L.LC_I & -- 'i' 105 + L.LC_J & -- 'j' 106 + L.LC_K & -- 'k' 107 + L.LC_L & -- 'l' 108 + L.LC_M & -- 'm' 109 + L.LC_N & -- 'n' 110 + L.LC_O & -- 'o' 111 + L.LC_P & -- 'p' 112 + L.LC_Q & -- 'q' 113 + L.LC_R & -- 'r' 114 + L.LC_S & -- 's' 115 + L.LC_T & -- 't' 116 + L.LC_U & -- 'u' 117 + L.LC_V & -- 'v' 118 + L.LC_W & -- 'w' 119 + L.LC_X & -- 'x' 120 + L.LC_Y & -- 'y' 121 + L.LC_Z & -- 'z' 122 + L.Left_Curly_Bracket & -- '{' 123 + L.Vertical_Line & -- '|' 124 + L.Right_Curly_Bracket & -- '}' 125 + L.Tilde & -- '~' 126 + L.DEL & -- DEL 127 + L.Reserved_128 & -- Reserved_128 128 + L.Reserved_129 & -- Reserved_129 129 + L.BPH & -- BPH 130 + L.NBH & -- NBH 131 + L.Reserved_132 & -- Reserved_132 132 + L.NEL & -- NEL 133 + L.SSA & -- SSA 134 + L.ESA & -- ESA 135 + L.HTS & -- HTS 136 + L.HTJ & -- HTJ 137 + L.VTS & -- VTS 138 + L.PLD & -- PLD 139 + L.PLU & -- PLU 140 + L.RI & -- RI 141 + L.SS2 & -- SS2 142 + L.SS3 & -- SS3 143 + L.DCS & -- DCS 144 + L.PU1 & -- PU1 145 + L.PU2 & -- PU2 146 + L.STS & -- STS 147 + L.CCH & -- CCH 148 + L.MW & -- MW 149 + L.SPA & -- SPA 150 + L.EPA & -- EPA 151 + L.SOS & -- SOS 152 + L.Reserved_153 & -- Reserved_153 153 + L.SCI & -- SCI 154 + L.CSI & -- CSI 155 + L.ST & -- ST 156 + L.OSC & -- OSC 157 + L.PM & -- PM 158 + L.APC & -- APC 159 + L.No_Break_Space & -- No_Break_Space 160 + L.Inverted_Exclamation & -- Inverted_Exclamation 161 + L.Cent_Sign & -- Cent_Sign 162 + L.Pound_Sign & -- Pound_Sign 163 + L.Currency_Sign & -- Currency_Sign 164 + L.Yen_Sign & -- Yen_Sign 165 + L.Broken_Bar & -- Broken_Bar 166 + L.Section_Sign & -- Section_Sign 167 + L.Diaeresis & -- Diaeresis 168 + L.Copyright_Sign & -- Copyright_Sign 169 + L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 + L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 + L.Not_Sign & -- Not_Sign 172 + L.Soft_Hyphen & -- Soft_Hyphen 173 + L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 + L.Macron & -- Macron 175 + L.Degree_Sign & -- Degree_Sign 176 + L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 + L.Superscript_Two & -- Superscript_Two 178 + L.Superscript_Three & -- Superscript_Three 179 + L.Acute & -- Acute 180 + L.Micro_Sign & -- Micro_Sign 181 + L.Pilcrow_Sign & -- Pilcrow_Sign 182 + L.Middle_Dot & -- Middle_Dot 183 + L.Cedilla & -- Cedilla 184 + L.Superscript_One & -- Superscript_One 185 + L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 + L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 + L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 + L.Fraction_One_Half & -- Fraction_One_Half 189 + L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 + L.Inverted_Question & -- Inverted_Question 191 + 'A' & -- UC_A_Grave 192 + 'A' & -- UC_A_Acute 193 + 'A' & -- UC_A_Circumflex 194 + 'A' & -- UC_A_Tilde 195 + 'A' & -- UC_A_Diaeresis 196 + 'A' & -- UC_A_Ring 197 + L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 + 'C' & -- UC_C_Cedilla 199 + 'E' & -- UC_E_Grave 200 + 'E' & -- UC_E_Acute 201 + 'E' & -- UC_E_Circumflex 202 + 'E' & -- UC_E_Diaeresis 203 + 'I' & -- UC_I_Grave 204 + 'I' & -- UC_I_Acute 205 + 'I' & -- UC_I_Circumflex 206 + 'I' & -- UC_I_Diaeresis 207 + L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 + 'N' & -- UC_N_Tilde 209 + 'O' & -- UC_O_Grave 210 + 'O' & -- UC_O_Acute 211 + 'O' & -- UC_O_Circumflex 212 + 'O' & -- UC_O_Tilde 213 + 'O' & -- UC_O_Diaeresis 214 + L.Multiplication_Sign & -- Multiplication_Sign 215 + 'O' & -- UC_O_Oblique_Stroke 216 + 'U' & -- UC_U_Grave 217 + 'U' & -- UC_U_Acute 218 + 'U' & -- UC_U_Circumflex 219 + 'U' & -- UC_U_Diaeresis 220 + 'Y' & -- UC_Y_Acute 221 + L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 + L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 + L.LC_A & -- LC_A_Grave 224 + L.LC_A & -- LC_A_Acute 225 + L.LC_A & -- LC_A_Circumflex 226 + L.LC_A & -- LC_A_Tilde 227 + L.LC_A & -- LC_A_Diaeresis 228 + L.LC_A & -- LC_A_Ring 229 + L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 + L.LC_C & -- LC_C_Cedilla 231 + L.LC_E & -- LC_E_Grave 232 + L.LC_E & -- LC_E_Acute 233 + L.LC_E & -- LC_E_Circumflex 234 + L.LC_E & -- LC_E_Diaeresis 235 + L.LC_I & -- LC_I_Grave 236 + L.LC_I & -- LC_I_Acute 237 + L.LC_I & -- LC_I_Circumflex 238 + L.LC_I & -- LC_I_Diaeresis 239 + L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 + L.LC_N & -- LC_N_Tilde 241 + L.LC_O & -- LC_O_Grave 242 + L.LC_O & -- LC_O_Acute 243 + L.LC_O & -- LC_O_Circumflex 244 + L.LC_O & -- LC_O_Tilde 245 + L.LC_O & -- LC_O_Diaeresis 246 + L.Division_Sign & -- Division_Sign 247 + L.LC_O & -- LC_O_Oblique_Stroke 248 + L.LC_U & -- LC_U_Grave 249 + L.LC_U & -- LC_U_Acute 250 + L.LC_U & -- LC_U_Circumflex 251 + L.LC_U & -- LC_U_Diaeresis 252 + L.LC_Y & -- LC_Y_Acute 253 + L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 + L.LC_Y); -- LC_Y_Diaeresis 255 + +end Ada.Strings.Maps.Constants; diff --git a/gcc/ada/libgnat/a-storio.adb b/gcc/ada/libgnat/a-storio.adb new file mode 100644 index 0000000..0cea9d0 --- /dev/null +++ b/gcc/ada/libgnat/a-storio.adb @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T O R A G E _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body Ada.Storage_IO is + + type Buffer_Ptr is access all Buffer_Type; + type Elmt_Ptr is access all Element_Type; + + function To_Buffer_Ptr is + new Ada.Unchecked_Conversion (Elmt_Ptr, Buffer_Ptr); + + ---------- + -- Read -- + ---------- + + procedure Read (Buffer : Buffer_Type; Item : out Element_Type) is + begin + To_Buffer_Ptr (Item'Unrestricted_Access).all := Buffer; + end Read; + + ----------- + -- Write -- + ----------- + + procedure Write (Buffer : out Buffer_Type; Item : Element_Type) is + begin + Buffer := To_Buffer_Ptr (Item'Unrestricted_Access).all; + end Write; + +end Ada.Storage_IO; diff --git a/gcc/ada/libgnat/a-storio.ads b/gcc/ada/libgnat/a-storio.ads new file mode 100644 index 0000000..db0a70b --- /dev/null +++ b/gcc/ada/libgnat/a-storio.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T O R A G E _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System.Storage_Elements; + +generic + type Element_Type is private; + +package Ada.Storage_IO is + pragma Preelaborate; + + Buffer_Size : constant System.Storage_Elements.Storage_Count := + System.Storage_Elements.Storage_Count + ((Element_Type'Size + System.Storage_Unit - 1) / + System.Storage_Unit); + + subtype Buffer_Type is + System.Storage_Elements.Storage_Array (1 .. Buffer_Size); + + --------------------------------- + -- Input and Output Operations -- + --------------------------------- + + procedure Read (Buffer : Buffer_Type; Item : out Element_Type); + + procedure Write (Buffer : out Buffer_Type; Item : Element_Type); + + ---------------- + -- Exceptions -- + ---------------- + + Data_Error : exception renames IO_Exceptions.Data_Error; + +end Ada.Storage_IO; diff --git a/gcc/ada/libgnat/a-strbou.adb b/gcc/ada/libgnat/a-strbou.adb new file mode 100644 index 0000000..da1605b --- /dev/null +++ b/gcc/ada/libgnat/a-strbou.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Bounded is + + package body Generic_Bounded_Length is + + -- The subprograms in this body are those for which there is no + -- Bounded_String input, and hence no implicit information on the + -- maximum size. This means that the maximum size has to be passed + -- explicitly to the routine in Superbounded. + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return Bounded_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + function "*" + (Left : Natural; + Right : String) return Bounded_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + ----------------- + -- From_String -- + ----------------- + + function From_String (Source : String) return Bounded_String is + begin + return To_Super_String (Source, Max_Length, Error); + end From_String; + + --------------- + -- Replicate -- + --------------- + + function Replicate + (Count : Natural; + Item : Character; + Drop : Strings.Truncation := Strings.Error) return Bounded_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + function Replicate + (Count : Natural; + Item : String; + Drop : Strings.Truncation := Strings.Error) return Bounded_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + ----------------------- + -- To_Bounded_String -- + ----------------------- + + function To_Bounded_String + (Source : String; + Drop : Strings.Truncation := Strings.Error) return Bounded_String + is + begin + return To_Super_String (Source, Max_Length, Drop); + end To_Bounded_String; + + end Generic_Bounded_Length; + +end Ada.Strings.Bounded; diff --git a/gcc/ada/libgnat/a-strbou.ads b/gcc/ada/libgnat/a-strbou.ads new file mode 100644 index 0000000..4138a97 --- /dev/null +++ b/gcc/ada/libgnat/a-strbou.ads @@ -0,0 +1,914 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Maps; +with Ada.Strings.Superbounded; + +package Ada.Strings.Bounded is + pragma Preelaborate; + + generic + Max : Positive; + -- Maximum length of a Bounded_String + + package Generic_Bounded_Length is + + Max_Length : constant Positive := Max; + + type Bounded_String is private; + pragma Preelaborable_Initialization (Bounded_String); + + Null_Bounded_String : constant Bounded_String; + + subtype Length_Range is Natural range 0 .. Max_Length; + + function Length (Source : Bounded_String) return Length_Range; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Bounded_String + (Source : String; + Drop : Truncation := Error) return Bounded_String; + + function To_String (Source : Bounded_String) return String; + + procedure Set_Bounded_String + (Target : out Bounded_String; + Source : String; + Drop : Truncation := Error); + pragma Ada_05 (Set_Bounded_String); + + function Append + (Left : Bounded_String; + Right : Bounded_String; + Drop : Truncation := Error) return Bounded_String; + + function Append + (Left : Bounded_String; + Right : String; + Drop : Truncation := Error) return Bounded_String; + + function Append + (Left : String; + Right : Bounded_String; + Drop : Truncation := Error) return Bounded_String; + + function Append + (Left : Bounded_String; + Right : Character; + Drop : Truncation := Error) return Bounded_String; + + function Append + (Left : Character; + Right : Bounded_String; + Drop : Truncation := Error) return Bounded_String; + + procedure Append + (Source : in out Bounded_String; + New_Item : Bounded_String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_String; + New_Item : String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_String; + New_Item : Character; + Drop : Truncation := Error); + + function "&" + (Left : Bounded_String; + Right : Bounded_String) return Bounded_String; + + function "&" + (Left : Bounded_String; + Right : String) return Bounded_String; + + function "&" + (Left : String; + Right : Bounded_String) return Bounded_String; + + function "&" + (Left : Bounded_String; + Right : Character) return Bounded_String; + + function "&" + (Left : Character; + Right : Bounded_String) return Bounded_String; + + function Element + (Source : Bounded_String; + Index : Positive) return Character; + + procedure Replace_Element + (Source : in out Bounded_String; + Index : Positive; + By : Character); + + function Slice + (Source : Bounded_String; + Low : Positive; + High : Natural) return String; + + function Bounded_Slice + (Source : Bounded_String; + Low : Positive; + High : Natural) return Bounded_String; + pragma Ada_05 (Bounded_Slice); + + procedure Bounded_Slice + (Source : Bounded_String; + Target : out Bounded_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Bounded_Slice); + + function "=" + (Left : Bounded_String; + Right : Bounded_String) return Boolean; + + function "=" + (Left : Bounded_String; + Right : String) return Boolean; + + function "=" + (Left : String; + Right : Bounded_String) return Boolean; + + function "<" + (Left : Bounded_String; + Right : Bounded_String) return Boolean; + + function "<" + (Left : Bounded_String; + Right : String) return Boolean; + + function "<" + (Left : String; + Right : Bounded_String) return Boolean; + + function "<=" + (Left : Bounded_String; + Right : Bounded_String) return Boolean; + + function "<=" + (Left : Bounded_String; + Right : String) return Boolean; + + function "<=" + (Left : String; + Right : Bounded_String) return Boolean; + + function ">" + (Left : Bounded_String; + Right : Bounded_String) return Boolean; + + function ">" + (Left : Bounded_String; + Right : String) return Boolean; + + function ">" + (Left : String; + Right : Bounded_String) return Boolean; + + function ">=" + (Left : Bounded_String; + Right : Bounded_String) return Boolean; + + function ">=" + (Left : Bounded_String; + Right : String) return Boolean; + + function ">=" + (Left : String; + Right : Bounded_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Index + (Source : Bounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : Bounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : Bounded_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Bounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Bounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Bounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Bounded_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Bounded_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Bounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : Bounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : Bounded_String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : Bounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Bounded_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Bounded_String; + Mapping : Maps.Character_Mapping) return Bounded_String; + + procedure Translate + (Source : in out Bounded_String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : Bounded_String; + Mapping : Maps.Character_Mapping_Function) return Bounded_String; + + procedure Translate + (Source : in out Bounded_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Bounded_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error) return Bounded_String; + + procedure Replace_Slice + (Source : in out Bounded_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error); + + function Insert + (Source : Bounded_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error) return Bounded_String; + + procedure Insert + (Source : in out Bounded_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Overwrite + (Source : Bounded_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error) return Bounded_String; + + procedure Overwrite + (Source : in out Bounded_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Delete + (Source : Bounded_String; + From : Positive; + Through : Natural) return Bounded_String; + + procedure Delete + (Source : in out Bounded_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Trim + (Source : Bounded_String; + Side : Trim_End) return Bounded_String; + + procedure Trim + (Source : in out Bounded_String; + Side : Trim_End); + + function Trim + (Source : Bounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Bounded_String; + + procedure Trim + (Source : in out Bounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Head + (Source : Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) return Bounded_String; + + procedure Head + (Source : in out Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error); + + function Tail + (Source : Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) return Bounded_String; + + procedure Tail + (Source : in out Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + function "*" + (Left : Natural; + Right : Character) return Bounded_String; + + function "*" + (Left : Natural; + Right : String) return Bounded_String; + + function "*" + (Left : Natural; + Right : Bounded_String) return Bounded_String; + + function Replicate + (Count : Natural; + Item : Character; + Drop : Truncation := Error) return Bounded_String; + + function Replicate + (Count : Natural; + Item : String; + Drop : Truncation := Error) return Bounded_String; + + function Replicate + (Count : Natural; + Item : Bounded_String; + Drop : Truncation := Error) return Bounded_String; + + private + -- Most of the implementation is in the separate non generic package + -- Ada.Strings.Superbounded. Type Bounded_String is derived from type + -- Superbounded.Super_String with the maximum length constraint. In + -- almost all cases, the routines in Superbounded can be called with + -- no requirement to pass the maximum length explicitly, since there + -- is at least one Bounded_String argument from which the maximum + -- length can be obtained. For all such routines, the implementation + -- in this private part is simply a renaming of the corresponding + -- routine in the superbounded package. + + -- The five exceptions are the * and Replicate routines operating on + -- character values. For these cases, we have a routine in the body + -- that calls the superbounded routine passing the maximum length + -- explicitly as an extra parameter. + + type Bounded_String is new Superbounded.Super_String (Max_Length); + -- Deriving Bounded_String from Superbounded.Super_String is the + -- real trick, it ensures that the type Bounded_String declared in + -- the generic instantiation is compatible with the Super_String + -- type declared in the Superbounded package. + + function From_String (Source : String) return Bounded_String; + -- Private routine used only by Stream_Convert + + pragma Stream_Convert (Bounded_String, From_String, To_String); + -- Provide stream routines without dragging in Ada.Streams + + Null_Bounded_String : constant Bounded_String := + (Max_Length => Max_Length, + Current_Length => 0, + Data => + (1 .. Max_Length => ASCII.NUL)); + + pragma Inline (To_Bounded_String); + + procedure Set_Bounded_String + (Target : out Bounded_String; + Source : String; + Drop : Truncation := Error) + renames Set_Super_String; + + function Length + (Source : Bounded_String) return Length_Range + renames Super_Length; + + function To_String + (Source : Bounded_String) return String + renames Super_To_String; + + function Append + (Left : Bounded_String; + Right : Bounded_String; + Drop : Truncation := Error) return Bounded_String + renames Super_Append; + + function Append + (Left : Bounded_String; + Right : String; + Drop : Truncation := Error) return Bounded_String + renames Super_Append; + + function Append + (Left : String; + Right : Bounded_String; + Drop : Truncation := Error) return Bounded_String + renames Super_Append; + + function Append + (Left : Bounded_String; + Right : Character; + Drop : Truncation := Error) return Bounded_String + renames Super_Append; + + function Append + (Left : Character; + Right : Bounded_String; + Drop : Truncation := Error) return Bounded_String + renames Super_Append; + + procedure Append + (Source : in out Bounded_String; + New_Item : Bounded_String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_String; + New_Item : String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_String; + New_Item : Character; + Drop : Truncation := Error) + renames Super_Append; + + function "&" + (Left : Bounded_String; + Right : Bounded_String) return Bounded_String + renames Concat; + + function "&" + (Left : Bounded_String; + Right : String) return Bounded_String + renames Concat; + + function "&" + (Left : String; + Right : Bounded_String) return Bounded_String + renames Concat; + + function "&" + (Left : Bounded_String; + Right : Character) return Bounded_String + renames Concat; + + function "&" + (Left : Character; + Right : Bounded_String) return Bounded_String + renames Concat; + + function Element + (Source : Bounded_String; + Index : Positive) return Character + renames Super_Element; + + procedure Replace_Element + (Source : in out Bounded_String; + Index : Positive; + By : Character) + renames Super_Replace_Element; + + function Slice + (Source : Bounded_String; + Low : Positive; + High : Natural) return String + renames Super_Slice; + + function Bounded_Slice + (Source : Bounded_String; + Low : Positive; + High : Natural) return Bounded_String + renames Super_Slice; + + procedure Bounded_Slice + (Source : Bounded_String; + Target : out Bounded_String; + Low : Positive; + High : Natural) + renames Super_Slice; + + overriding function "=" + (Left : Bounded_String; + Right : Bounded_String) return Boolean + renames Equal; + + function "=" + (Left : Bounded_String; + Right : String) return Boolean + renames Equal; + + function "=" + (Left : String; + Right : Bounded_String) return Boolean + renames Equal; + + function "<" + (Left : Bounded_String; + Right : Bounded_String) return Boolean + renames Less; + + function "<" + (Left : Bounded_String; + Right : String) return Boolean + renames Less; + + function "<" + (Left : String; + Right : Bounded_String) return Boolean + renames Less; + + function "<=" + (Left : Bounded_String; + Right : Bounded_String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : Bounded_String; + Right : String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : String; + Right : Bounded_String) return Boolean + renames Less_Or_Equal; + + function ">" + (Left : Bounded_String; + Right : Bounded_String) return Boolean + renames Greater; + + function ">" + (Left : Bounded_String; + Right : String) return Boolean + renames Greater; + + function ">" + (Left : String; + Right : Bounded_String) return Boolean + renames Greater; + + function ">=" + (Left : Bounded_String; + Right : Bounded_String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : Bounded_String; + Right : String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : String; + Right : Bounded_String) return Boolean + renames Greater_Or_Equal; + + function Index + (Source : Bounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Super_Index; + + function Index + (Source : Bounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Super_Index; + + function Index + (Source : Bounded_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index + (Source : Bounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Super_Index; + + function Index + (Source : Bounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Super_Index; + + function Index + (Source : Bounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index_Non_Blank + (Source : Bounded_String; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Index_Non_Blank + (Source : Bounded_String; + From : Positive; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Count + (Source : Bounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Super_Count; + + function Count + (Source : Bounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Super_Count; + + function Count + (Source : Bounded_String; + Set : Maps.Character_Set) return Natural + renames Super_Count; + + procedure Find_Token + (Source : Bounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Super_Find_Token; + + procedure Find_Token + (Source : Bounded_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Super_Find_Token; + + function Translate + (Source : Bounded_String; + Mapping : Maps.Character_Mapping) return Bounded_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_String; + Mapping : Maps.Character_Mapping) + renames Super_Translate; + + function Translate + (Source : Bounded_String; + Mapping : Maps.Character_Mapping_Function) return Bounded_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_String; + Mapping : Maps.Character_Mapping_Function) + renames Super_Translate; + + function Replace_Slice + (Source : Bounded_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error) return Bounded_String + renames Super_Replace_Slice; + + procedure Replace_Slice + (Source : in out Bounded_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error) + renames Super_Replace_Slice; + + function Insert + (Source : Bounded_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error) return Bounded_String + renames Super_Insert; + + procedure Insert + (Source : in out Bounded_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error) + renames Super_Insert; + + function Overwrite + (Source : Bounded_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error) return Bounded_String + renames Super_Overwrite; + + procedure Overwrite + (Source : in out Bounded_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error) + renames Super_Overwrite; + + function Delete + (Source : Bounded_String; + From : Positive; + Through : Natural) return Bounded_String + renames Super_Delete; + + procedure Delete + (Source : in out Bounded_String; + From : Positive; + Through : Natural) + renames Super_Delete; + + function Trim + (Source : Bounded_String; + Side : Trim_End) return Bounded_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_String; + Side : Trim_End) + renames Super_Trim; + + function Trim + (Source : Bounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Bounded_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + renames Super_Trim; + + function Head + (Source : Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) return Bounded_String + renames Super_Head; + + procedure Head + (Source : in out Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + renames Super_Head; + + function Tail + (Source : Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) return Bounded_String + renames Super_Tail; + + procedure Tail + (Source : in out Bounded_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + renames Super_Tail; + + function "*" + (Left : Natural; + Right : Bounded_String) return Bounded_String + renames Times; + + function Replicate + (Count : Natural; + Item : Bounded_String; + Drop : Truncation := Error) return Bounded_String + renames Super_Replicate; + + end Generic_Bounded_Length; + +end Ada.Strings.Bounded; diff --git a/gcc/ada/libgnat/a-stream.adb b/gcc/ada/libgnat/a-stream.adb new file mode 100644 index 0000000..21e26d4 --- /dev/null +++ b/gcc/ada/libgnat/a-stream.adb @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; + +package body Ada.Streams is + + -------------- + -- Read_SEA -- + -------------- + + procedure Read_SEA + (S : access Root_Stream_Type'Class; + V : out Stream_Element_Array) + is + Last : Stream_Element_Offset; + + begin + Read (S.all, V, Last); + + if Last /= V'Last then + raise Ada.IO_Exceptions.End_Error; + end if; + end Read_SEA; + + --------------- + -- Write_SEA -- + --------------- + + procedure Write_SEA + (S : access Root_Stream_Type'Class; + V : Stream_Element_Array) + is + begin + Write (S.all, V); + end Write_SEA; + +end Ada.Streams; diff --git a/gcc/ada/libgnat/a-stream.ads b/gcc/ada/libgnat/a-stream.ads new file mode 100644 index 0000000..f3aa008 --- /dev/null +++ b/gcc/ada/libgnat/a-stream.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Streams is + pragma Pure; + + type Root_Stream_Type is abstract tagged limited private; + pragma Preelaborable_Initialization (Root_Stream_Type); + + type Stream_Element is mod 2 ** Standard'Storage_Unit; + + type Stream_Element_Offset is new Long_Long_Integer; + -- Stream_Element_Offset needs 64 bits to accommodate large stream files. + -- However, rather than make this explicitly 64-bits we derive from + -- Long_Long_Integer. In normal usage this will have the same effect. + -- But in the case of CodePeer with a target configuration file with a + -- maximum integer size of 32, it allows analysis of this unit. + + subtype Stream_Element_Count is + Stream_Element_Offset range 0 .. Stream_Element_Offset'Last; + + type Stream_Element_Array is + array (Stream_Element_Offset range <>) of aliased Stream_Element; + + procedure Read + (Stream : in out Root_Stream_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is abstract; + + procedure Write + (Stream : in out Root_Stream_Type; + Item : Stream_Element_Array) + is abstract; + +private + + type Root_Stream_Type is abstract tagged limited null record; + + -- Stream attributes for Stream_Element_Array: trivially call the + -- corresponding stream primitive for the whole array, instead of doing + -- so element by element. + + procedure Read_SEA + (S : access Root_Stream_Type'Class; + V : out Stream_Element_Array); + + procedure Write_SEA + (S : access Root_Stream_Type'Class; + V : Stream_Element_Array); + + for Stream_Element_Array'Read use Read_SEA; + for Stream_Element_Array'Write use Write_SEA; + +end Ada.Streams; diff --git a/gcc/ada/libgnat/a-strfix.adb b/gcc/ada/libgnat/a-strfix.adb new file mode 100644 index 0000000..0f24f5a --- /dev/null +++ b/gcc/ada/libgnat/a-strfix.adb @@ -0,0 +1,747 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . F I X E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: This code is derived from the ADAR.CSH public domain Ada 83 versions +-- of the Appendix C string handling packages. One change is to avoid the use +-- of Is_In, so that we are not dependent on inlining. Note that the search +-- function implementations are to be found in the auxiliary package +-- Ada.Strings.Search. Also the Move procedure is directly incorporated (ADAR +-- used a subunit for this procedure). The number of errors having to do with +-- bounds of function return results were also fixed, and use of & removed for +-- efficiency reasons. + +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Search; + +package body Ada.Strings.Fixed is + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Ada.Strings.Search.Index; + + function Index + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index; + + function Index_Non_Blank + (Source : String; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index_Non_Blank; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural + renames Ada.Strings.Search.Index_Non_Blank; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + renames Ada.Strings.Search.Count; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + renames Ada.Strings.Search.Count; + + function Count + (Source : String; + Set : Maps.Character_Set) return Natural + renames Ada.Strings.Search.Count; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Search.Find_Token; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Search.Find_Token; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return String + is + Result : String (1 .. Left); + + begin + for J in Result'Range loop + Result (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : String) return String + is + Result : String (1 .. Left * Right'Length); + Ptr : Integer := 1; + + begin + for J in 1 .. Left loop + Result (Ptr .. Ptr + Right'Length - 1) := Right; + Ptr := Ptr + Right'Length; + end loop; + + return Result; + end "*"; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : String; + From : Positive; + Through : Natural) return String + is + begin + if From > Through then + declare + subtype Result_Type is String (1 .. Source'Length); + + begin + return Result_Type (Source); + end; + + elsif From not in Source'Range + or else Through > Source'Last + then + raise Index_Error; + + else + declare + Front : constant Integer := From - Source'First; + Result : String (1 .. Source'Length - (Through - From + 1)); + + begin + Result (1 .. Front) := + Source (Source'First .. From - 1); + Result (Front + 1 .. Result'Last) := + Source (Through + 1 .. Source'Last); + + return Result; + end; + end if; + end Delete; + + procedure Delete + (Source : in out String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Source => Delete (Source, From, Through), + Target => Source, + Justify => Justify, + Pad => Pad); + end Delete; + + ---------- + -- Head -- + ---------- + + function Head + (Source : String; + Count : Natural; + Pad : Character := Space) return String + is + subtype Result_Type is String (1 .. Count); + + begin + if Count < Source'Length then + return + Result_Type (Source (Source'First .. Source'First + Count - 1)); + + else + declare + Result : Result_Type; + + begin + Result (1 .. Source'Length) := Source; + + for J in Source'Length + 1 .. Count loop + Result (J) := Pad; + end loop; + + return Result; + end; + end if; + end Head; + + procedure Head + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Source => Head (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Head; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : String; + Before : Positive; + New_Item : String) return String + is + Result : String (1 .. Source'Length + New_Item'Length); + Front : constant Integer := Before - Source'First; + + begin + if Before not in Source'First .. Source'Last + 1 then + raise Index_Error; + end if; + + Result (1 .. Front) := + Source (Source'First .. Before - 1); + Result (Front + 1 .. Front + New_Item'Length) := + New_Item; + Result (Front + New_Item'Length + 1 .. Result'Last) := + Source (Before .. Source'Last); + + return Result; + end Insert; + + procedure Insert + (Source : in out String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error) + is + begin + Move (Source => Insert (Source, Before, New_Item), + Target => Source, + Drop => Drop); + end Insert; + + ---------- + -- Move -- + ---------- + + procedure Move + (Source : String; + Target : out String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space) + is + Sfirst : constant Integer := Source'First; + Slast : constant Integer := Source'Last; + Slength : constant Integer := Source'Length; + + Tfirst : constant Integer := Target'First; + Tlast : constant Integer := Target'Last; + Tlength : constant Integer := Target'Length; + + function Is_Padding (Item : String) return Boolean; + -- Check if Item is all Pad characters, return True if so, False if not + + function Is_Padding (Item : String) return Boolean is + begin + for J in Item'Range loop + if Item (J) /= Pad then + return False; + end if; + end loop; + + return True; + end Is_Padding; + + -- Start of processing for Move + + begin + if Slength = Tlength then + Target := Source; + + elsif Slength > Tlength then + case Drop is + when Left => + Target := Source (Slast - Tlength + 1 .. Slast); + + when Right => + Target := Source (Sfirst .. Sfirst + Tlength - 1); + + when Error => + case Justify is + when Left => + if Is_Padding (Source (Sfirst + Tlength .. Slast)) then + Target := + Source (Sfirst .. Sfirst + Target'Length - 1); + else + raise Length_Error; + end if; + + when Right => + if Is_Padding (Source (Sfirst .. Slast - Tlength)) then + Target := Source (Slast - Tlength + 1 .. Slast); + else + raise Length_Error; + end if; + + when Center => + raise Length_Error; + end case; + end case; + + -- Source'Length < Target'Length + + else + case Justify is + when Left => + Target (Tfirst .. Tfirst + Slength - 1) := Source; + + for I in Tfirst + Slength .. Tlast loop + Target (I) := Pad; + end loop; + + when Right => + for I in Tfirst .. Tlast - Slength loop + Target (I) := Pad; + end loop; + + Target (Tlast - Slength + 1 .. Tlast) := Source; + + when Center => + declare + Front_Pad : constant Integer := (Tlength - Slength) / 2; + Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; + + begin + for I in Tfirst .. Tfirst_Fpad - 1 loop + Target (I) := Pad; + end loop; + + Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; + + for I in Tfirst_Fpad + Slength .. Tlast loop + Target (I) := Pad; + end loop; + end; + end case; + end if; + end Move; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : String; + Position : Positive; + New_Item : String) return String + is + begin + if Position not in Source'First .. Source'Last + 1 then + raise Index_Error; + end if; + + declare + Result_Length : constant Natural := + Integer'Max + (Source'Length, + Position - Source'First + New_Item'Length); + + Result : String (1 .. Result_Length); + Front : constant Integer := Position - Source'First; + + begin + Result (1 .. Front) := + Source (Source'First .. Position - 1); + Result (Front + 1 .. Front + New_Item'Length) := + New_Item; + Result (Front + New_Item'Length + 1 .. Result'Length) := + Source (Position + New_Item'Length .. Source'Last); + return Result; + end; + end Overwrite; + + procedure Overwrite + (Source : in out String; + Position : Positive; + New_Item : String; + Drop : Truncation := Right) + is + begin + Move (Source => Overwrite (Source, Position, New_Item), + Target => Source, + Drop => Drop); + end Overwrite; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : String; + Low : Positive; + High : Natural; + By : String) return String + is + begin + if Low > Source'Last + 1 or else High < Source'First - 1 then + raise Index_Error; + end if; + + if High >= Low then + declare + Front_Len : constant Integer := + Integer'Max (0, Low - Source'First); + -- Length of prefix of Source copied to result + + Back_Len : constant Integer := + Integer'Max (0, Source'Last - High); + -- Length of suffix of Source copied to result + + Result_Length : constant Integer := + Front_Len + By'Length + Back_Len; + -- Length of result + + Result : String (1 .. Result_Length); + + begin + Result (1 .. Front_Len) := Source (Source'First .. Low - 1); + Result (Front_Len + 1 .. Front_Len + By'Length) := By; + Result (Front_Len + By'Length + 1 .. Result'Length) := + Source (High + 1 .. Source'Last); + return Result; + end; + + else + return Insert (Source, Before => Low, New_Item => By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); + end Replace_Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : String; + Count : Natural; + Pad : Character := Space) return String + is + subtype Result_Type is String (1 .. Count); + + begin + if Count < Source'Length then + return Result_Type (Source (Source'Last - Count + 1 .. Source'Last)); + + -- Pad on left + + else + declare + Result : Result_Type; + + begin + for J in 1 .. Count - Source'Length loop + Result (J) := Pad; + end loop; + + Result (Count - Source'Length + 1 .. Count) := Source; + return Result; + end; + end if; + end Tail; + + procedure Tail + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Source => Tail (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Tail; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping) return String + is + Result : String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping) + is + begin + for J in Source'Range loop + Source (J) := Value (Mapping, Source (J)); + end loop; + end Translate; + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping_Function) return String + is + Result : String (1 .. Source'Length); + pragma Unsuppress (Access_Check); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Mapping.all (Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping_Function) + is + pragma Unsuppress (Access_Check); + begin + for J in Source'Range loop + Source (J) := Mapping.all (Source (J)); + end loop; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : String; + Side : Trim_End) return String + is + begin + case Side is + when Strings.Left => + declare + Low : constant Natural := Index_Non_Blank (Source, Forward); + begin + -- All blanks case + + if Low = 0 then + return ""; + end if; + + declare + subtype Result_Type is String (1 .. Source'Last - Low + 1); + begin + return Result_Type (Source (Low .. Source'Last)); + end; + end; + + when Strings.Right => + declare + High : constant Natural := Index_Non_Blank (Source, Backward); + begin + -- All blanks case + + if High = 0 then + return ""; + end if; + + declare + subtype Result_Type is String (1 .. High - Source'First + 1); + begin + return Result_Type (Source (Source'First .. High)); + end; + end; + + when Strings.Both => + declare + Low : constant Natural := Index_Non_Blank (Source, Forward); + begin + -- All blanks case + + if Low = 0 then + return ""; + end if; + + declare + High : constant Natural := + Index_Non_Blank (Source, Backward); + subtype Result_Type is String (1 .. High - Low + 1); + begin + return Result_Type (Source (Low .. High)); + end; + end; + end case; + end Trim; + + procedure Trim + (Source : in out String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Character := Space) + is + begin + Move (Trim (Source, Side), + Source, + Justify => Justify, + Pad => Pad); + end Trim; + + function Trim + (Source : String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return String + is + High, Low : Integer; + + begin + Low := Index (Source, Set => Left, Test => Outside, Going => Forward); + + -- Case where source comprises only characters in Left + + if Low = 0 then + return ""; + end if; + + High := + Index (Source, Set => Right, Test => Outside, Going => Backward); + + -- Case where source comprises only characters in Right + + if High = 0 then + return ""; + end if; + + declare + subtype Result_Type is String (1 .. High - Low + 1); + + begin + return Result_Type (Source (Low .. High)); + end; + end Trim; + + procedure Trim + (Source : in out String; + Left : Maps.Character_Set; + Right : Maps.Character_Set; + Justify : Alignment := Strings.Left; + Pad : Character := Space) + is + begin + Move (Source => Trim (Source, Left, Right), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + +end Ada.Strings.Fixed; diff --git a/gcc/ada/libgnat/a-strfix.ads b/gcc/ada/libgnat/a-strfix.ads new file mode 100644 index 0000000..56db8bc --- /dev/null +++ b/gcc/ada/libgnat/a-strfix.ads @@ -0,0 +1,251 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . F I X E D -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Maps; + +package Ada.Strings.Fixed is + pragma Preelaborate; + + -------------------------------------------------------------- + -- Copy Procedure for Strings of Possibly Different Lengths -- + -------------------------------------------------------------- + + procedure Move + (Source : String; + Target : out String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space); + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping) return String; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : String; + Mapping : Maps.Character_Mapping_Function) return String; + + procedure Translate + (Source : in out String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : String; + Low : Positive; + High : Natural; + By : String) return String; + + procedure Replace_Slice + (Source : in out String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Character := Space); + + function Insert + (Source : String; + Before : Positive; + New_Item : String) return String; + + procedure Insert + (Source : in out String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Overwrite + (Source : String; + Position : Positive; + New_Item : String) return String; + + procedure Overwrite + (Source : in out String; + Position : Positive; + New_Item : String; + Drop : Truncation := Right); + + function Delete + (Source : String; + From : Positive; + Through : Natural) return String; + + procedure Delete + (Source : in out String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Character := Space); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Trim + (Source : String; + Side : Trim_End) return String; + + procedure Trim + (Source : in out String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Character := Space); + + function Trim + (Source : String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return String; + + procedure Trim + (Source : in out String; + Left : Maps.Character_Set; + Right : Maps.Character_Set; + Justify : Alignment := Strings.Left; + Pad : Character := Space); + + function Head + (Source : String; + Count : Natural; + Pad : Character := Space) return String; + + procedure Head + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space); + + function Tail + (Source : String; + Count : Natural; + Pad : Character := Space) return String; + + procedure Tail + (Source : in out String; + Count : Natural; + Justify : Alignment := Left; + Pad : Character := Space); + + ---------------------------------- + -- String Constructor Functions -- + ---------------------------------- + + function "*" + (Left : Natural; + Right : Character) return String; + + function "*" + (Left : Natural; + Right : String) return String; + +end Ada.Strings.Fixed; diff --git a/gcc/ada/libgnat/a-strhas.adb b/gcc/ada/libgnat/a-strhas.adb new file mode 100644 index 0000000..bf91af7 --- /dev/null +++ b/gcc/ada/libgnat/a-strhas.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Hash (Key : String) return Containers.Hash_Type is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Character, String, Hash_Type); +begin + return Hash (Key); +end Ada.Strings.Hash; diff --git a/gcc/ada/libgnat/a-strhas.ads b/gcc/ada/libgnat/a-strhas.ads new file mode 100644 index 0000000..2411a52 --- /dev/null +++ b/gcc/ada/libgnat/a-strhas.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Containers; + +function Ada.Strings.Hash (Key : String) return Containers.Hash_Type; +-- Note: this hash function has predictable collisions and is subject to +-- equivalent substring attacks. It is not suitable for construction of a +-- hash table keyed on possibly malicious user input. + +pragma Pure (Ada.Strings.Hash); diff --git a/gcc/ada/libgnat/a-string.ads b/gcc/ada/libgnat/a-string.ads new file mode 100644 index 0000000..51ca102 --- /dev/null +++ b/gcc/ada/libgnat/a-string.ads @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Strings is + pragma Pure; + + Space : constant Character := ' '; + Wide_Space : constant Wide_Character := ' '; + + -- The following declaration is for Ada 2005 (AI-285) + + Wide_Wide_Space : constant Wide_Wide_Character := ' '; + pragma Ada_05 (Wide_Wide_Space); + + Length_Error, Pattern_Error, Index_Error, Translation_Error : exception; + + type Alignment is (Left, Right, Center); + type Truncation is (Left, Right, Error); + type Membership is (Inside, Outside); + type Direction is (Forward, Backward); + type Trim_End is (Left, Right, Both); + +end Ada.Strings; diff --git a/gcc/ada/libgnat/a-strmap.adb b/gcc/ada/libgnat/a-strmap.adb new file mode 100644 index 0000000..a98556b --- /dev/null +++ b/gcc/ada/libgnat/a-strmap.adb @@ -0,0 +1,322 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: parts of this code are derived from the ADAR.CSH public domain +-- Ada 83 versions of the Appendix C string handling packages. The main +-- differences are that we avoid the use of the minimize function which +-- is bit-by-bit or character-by-character and therefore rather slow. +-- Generally for character sets we favor the full 32-byte representation. + +package body Ada.Strings.Maps is + + use Ada.Characters.Latin_1; + + --------- + -- "-" -- + --------- + + function "-" (Left, Right : Character_Set) return Character_Set is + begin + return Left and not Right; + end "-"; + + --------- + -- "=" -- + --------- + + function "=" (Left, Right : Character_Set) return Boolean is + begin + return Character_Set_Internal (Left) = Character_Set_Internal (Right); + end "="; + + ----------- + -- "and" -- + ----------- + + function "and" (Left, Right : Character_Set) return Character_Set is + begin + return Character_Set + (Character_Set_Internal (Left) and Character_Set_Internal (Right)); + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" (Right : Character_Set) return Character_Set is + begin + return Character_Set (not Character_Set_Internal (Right)); + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" (Left, Right : Character_Set) return Character_Set is + begin + return Character_Set + (Character_Set_Internal (Left) or Character_Set_Internal (Right)); + end "or"; + + ----------- + -- "xor" -- + ----------- + + function "xor" (Left, Right : Character_Set) return Character_Set is + begin + return Character_Set + (Character_Set_Internal (Left) xor Character_Set_Internal (Right)); + end "xor"; + + ----------- + -- Is_In -- + ----------- + + function Is_In + (Element : Character; + Set : Character_Set) return Boolean + is + begin + return Set (Element); + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Elements : Character_Set; + Set : Character_Set) return Boolean + is + begin + return (Elements and Set) = Elements; + end Is_Subset; + + --------------- + -- To_Domain -- + --------------- + + function To_Domain (Map : Character_Mapping) return Character_Sequence + is + Result : String (1 .. Map'Length); + J : Natural; + + begin + J := 0; + for C in Map'Range loop + if Map (C) /= C then + J := J + 1; + Result (J) := C; + end if; + end loop; + + return Result (1 .. J); + end To_Domain; + + ---------------- + -- To_Mapping -- + ---------------- + + function To_Mapping + (From, To : Character_Sequence) return Character_Mapping + is + Result : Character_Mapping; + Inserted : Character_Set := Null_Set; + From_Len : constant Natural := From'Length; + To_Len : constant Natural := To'Length; + + begin + if From_Len /= To_Len then + raise Strings.Translation_Error; + end if; + + for Char in Character loop + Result (Char) := Char; + end loop; + + for J in From'Range loop + if Inserted (From (J)) then + raise Strings.Translation_Error; + end if; + + Result (From (J)) := To (J - From'First + To'First); + Inserted (From (J)) := True; + end loop; + + return Result; + end To_Mapping; + + -------------- + -- To_Range -- + -------------- + + function To_Range (Map : Character_Mapping) return Character_Sequence + is + Result : String (1 .. Map'Length); + J : Natural; + begin + J := 0; + for C in Map'Range loop + if Map (C) /= C then + J := J + 1; + Result (J) := Map (C); + end if; + end loop; + + return Result (1 .. J); + end To_Range; + + --------------- + -- To_Ranges -- + --------------- + + function To_Ranges (Set : Character_Set) return Character_Ranges is + Max_Ranges : Character_Ranges (1 .. Set'Length / 2 + 1); + Range_Num : Natural; + C : Character; + + begin + C := Character'First; + Range_Num := 0; + + loop + -- Skip gap between subsets + + while not Set (C) loop + exit when C = Character'Last; + C := Character'Succ (C); + end loop; + + exit when not Set (C); + + Range_Num := Range_Num + 1; + Max_Ranges (Range_Num).Low := C; + + -- Span a subset + + loop + exit when not Set (C) or else C = Character'Last; + C := Character'Succ (C); + end loop; + + if Set (C) then + Max_Ranges (Range_Num). High := C; + exit; + else + Max_Ranges (Range_Num). High := Character'Pred (C); + end if; + end loop; + + return Max_Ranges (1 .. Range_Num); + end To_Ranges; + + ----------------- + -- To_Sequence -- + ----------------- + + function To_Sequence (Set : Character_Set) return Character_Sequence is + Result : String (1 .. Character'Pos (Character'Last) + 1); + Count : Natural := 0; + begin + for Char in Set'Range loop + if Set (Char) then + Count := Count + 1; + Result (Count) := Char; + end if; + end loop; + + return Result (1 .. Count); + end To_Sequence; + + ------------ + -- To_Set -- + ------------ + + function To_Set (Ranges : Character_Ranges) return Character_Set is + Result : Character_Set; + begin + for C in Result'Range loop + Result (C) := False; + end loop; + + for R in Ranges'Range loop + for C in Ranges (R).Low .. Ranges (R).High loop + Result (C) := True; + end loop; + end loop; + + return Result; + end To_Set; + + function To_Set (Span : Character_Range) return Character_Set is + Result : Character_Set; + begin + for C in Result'Range loop + Result (C) := False; + end loop; + + for C in Span.Low .. Span.High loop + Result (C) := True; + end loop; + + return Result; + end To_Set; + + function To_Set (Sequence : Character_Sequence) return Character_Set is + Result : Character_Set := Null_Set; + begin + for J in Sequence'Range loop + Result (Sequence (J)) := True; + end loop; + + return Result; + end To_Set; + + function To_Set (Singleton : Character) return Character_Set is + Result : Character_Set := Null_Set; + begin + Result (Singleton) := True; + return Result; + end To_Set; + + ----------- + -- Value -- + ----------- + + function Value + (Map : Character_Mapping; + Element : Character) return Character + is + begin + return Map (Element); + end Value; + +end Ada.Strings.Maps; diff --git a/gcc/ada/libgnat/a-strmap.ads b/gcc/ada/libgnat/a-strmap.ads new file mode 100644 index 0000000..6e65c0f --- /dev/null +++ b/gcc/ada/libgnat/a-strmap.ads @@ -0,0 +1,411 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Latin_1; + +package Ada.Strings.Maps is + pragma Pure; + -- In accordance with Ada 2005 AI-362 + + -------------------------------- + -- Character Set Declarations -- + -------------------------------- + + type Character_Set is private; + pragma Preelaborable_Initialization (Character_Set); + -- Representation for a set of character values: + + Null_Set : constant Character_Set; + + --------------------------- + -- Constructors for Sets -- + --------------------------- + + type Character_Range is record + Low : Character; + High : Character; + end record; + -- Represents Character range Low .. High + + type Character_Ranges is array (Positive range <>) of Character_Range; + + function To_Set (Ranges : Character_Ranges) return Character_Set; + + function To_Set (Span : Character_Range) return Character_Set; + + function To_Ranges (Set : Character_Set) return Character_Ranges; + + ---------------------------------- + -- Operations on Character Sets -- + ---------------------------------- + + function "=" (Left, Right : Character_Set) return Boolean; + + function "not" (Right : Character_Set) return Character_Set; + function "and" (Left, Right : Character_Set) return Character_Set; + function "or" (Left, Right : Character_Set) return Character_Set; + function "xor" (Left, Right : Character_Set) return Character_Set; + function "-" (Left, Right : Character_Set) return Character_Set; + + function Is_In + (Element : Character; + Set : Character_Set) return Boolean; + + function Is_Subset + (Elements : Character_Set; + Set : Character_Set) return Boolean; + + function "<=" + (Left : Character_Set; + Right : Character_Set) return Boolean + renames Is_Subset; + + subtype Character_Sequence is String; + -- Alternative representation for a set of character values + + function To_Set (Sequence : Character_Sequence) return Character_Set; + function To_Set (Singleton : Character) return Character_Set; + + function To_Sequence (Set : Character_Set) return Character_Sequence; + + ------------------------------------ + -- Character Mapping Declarations -- + ------------------------------------ + + type Character_Mapping is private; + pragma Preelaborable_Initialization (Character_Mapping); + -- Representation for a character to character mapping: + + function Value + (Map : Character_Mapping; + Element : Character) return Character; + + Identity : constant Character_Mapping; + + ---------------------------- + -- Operations on Mappings -- + ---------------------------- + + function To_Mapping + (From, To : Character_Sequence) return Character_Mapping; + + function To_Domain + (Map : Character_Mapping) return Character_Sequence; + + function To_Range + (Map : Character_Mapping) return Character_Sequence; + + type Character_Mapping_Function is + access function (From : Character) return Character; + +private + pragma Inline (Is_In); + pragma Inline (Value); + + type Character_Set_Internal is array (Character) of Boolean; + pragma Pack (Character_Set_Internal); + + type Character_Set is new Character_Set_Internal; + -- Note: the reason for this level of derivation is to make sure + -- that the predefined logical operations on this type remain + -- accessible. The operations on Character_Set are overridden by + -- the defined operations in the spec, but the operations defined + -- on Character_Set_Internal remain visible. + + Null_Set : constant Character_Set := (others => False); + + type Character_Mapping is array (Character) of Character; + + package L renames Ada.Characters.Latin_1; + + Identity : constant Character_Mapping := + (L.NUL & -- NUL 0 + L.SOH & -- SOH 1 + L.STX & -- STX 2 + L.ETX & -- ETX 3 + L.EOT & -- EOT 4 + L.ENQ & -- ENQ 5 + L.ACK & -- ACK 6 + L.BEL & -- BEL 7 + L.BS & -- BS 8 + L.HT & -- HT 9 + L.LF & -- LF 10 + L.VT & -- VT 11 + L.FF & -- FF 12 + L.CR & -- CR 13 + L.SO & -- SO 14 + L.SI & -- SI 15 + L.DLE & -- DLE 16 + L.DC1 & -- DC1 17 + L.DC2 & -- DC2 18 + L.DC3 & -- DC3 19 + L.DC4 & -- DC4 20 + L.NAK & -- NAK 21 + L.SYN & -- SYN 22 + L.ETB & -- ETB 23 + L.CAN & -- CAN 24 + L.EM & -- EM 25 + L.SUB & -- SUB 26 + L.ESC & -- ESC 27 + L.FS & -- FS 28 + L.GS & -- GS 29 + L.RS & -- RS 30 + L.US & -- US 31 + L.Space & -- ' ' 32 + L.Exclamation & -- '!' 33 + L.Quotation & -- '"' 34 + L.Number_Sign & -- '#' 35 + L.Dollar_Sign & -- '$' 36 + L.Percent_Sign & -- '%' 37 + L.Ampersand & -- '&' 38 + L.Apostrophe & -- ''' 39 + L.Left_Parenthesis & -- '(' 40 + L.Right_Parenthesis & -- ')' 41 + L.Asterisk & -- '*' 42 + L.Plus_Sign & -- '+' 43 + L.Comma & -- ',' 44 + L.Hyphen & -- '-' 45 + L.Full_Stop & -- '.' 46 + L.Solidus & -- '/' 47 + '0' & -- '0' 48 + '1' & -- '1' 49 + '2' & -- '2' 50 + '3' & -- '3' 51 + '4' & -- '4' 52 + '5' & -- '5' 53 + '6' & -- '6' 54 + '7' & -- '7' 55 + '8' & -- '8' 56 + '9' & -- '9' 57 + L.Colon & -- ':' 58 + L.Semicolon & -- ';' 59 + L.Less_Than_Sign & -- '<' 60 + L.Equals_Sign & -- '=' 61 + L.Greater_Than_Sign & -- '>' 62 + L.Question & -- '?' 63 + L.Commercial_At & -- '@' 64 + 'A' & -- 'A' 65 + 'B' & -- 'B' 66 + 'C' & -- 'C' 67 + 'D' & -- 'D' 68 + 'E' & -- 'E' 69 + 'F' & -- 'F' 70 + 'G' & -- 'G' 71 + 'H' & -- 'H' 72 + 'I' & -- 'I' 73 + 'J' & -- 'J' 74 + 'K' & -- 'K' 75 + 'L' & -- 'L' 76 + 'M' & -- 'M' 77 + 'N' & -- 'N' 78 + 'O' & -- 'O' 79 + 'P' & -- 'P' 80 + 'Q' & -- 'Q' 81 + 'R' & -- 'R' 82 + 'S' & -- 'S' 83 + 'T' & -- 'T' 84 + 'U' & -- 'U' 85 + 'V' & -- 'V' 86 + 'W' & -- 'W' 87 + 'X' & -- 'X' 88 + 'Y' & -- 'Y' 89 + 'Z' & -- 'Z' 90 + L.Left_Square_Bracket & -- '[' 91 + L.Reverse_Solidus & -- '\' 92 + L.Right_Square_Bracket & -- ']' 93 + L.Circumflex & -- '^' 94 + L.Low_Line & -- '_' 95 + L.Grave & -- '`' 96 + L.LC_A & -- 'a' 97 + L.LC_B & -- 'b' 98 + L.LC_C & -- 'c' 99 + L.LC_D & -- 'd' 100 + L.LC_E & -- 'e' 101 + L.LC_F & -- 'f' 102 + L.LC_G & -- 'g' 103 + L.LC_H & -- 'h' 104 + L.LC_I & -- 'i' 105 + L.LC_J & -- 'j' 106 + L.LC_K & -- 'k' 107 + L.LC_L & -- 'l' 108 + L.LC_M & -- 'm' 109 + L.LC_N & -- 'n' 110 + L.LC_O & -- 'o' 111 + L.LC_P & -- 'p' 112 + L.LC_Q & -- 'q' 113 + L.LC_R & -- 'r' 114 + L.LC_S & -- 's' 115 + L.LC_T & -- 't' 116 + L.LC_U & -- 'u' 117 + L.LC_V & -- 'v' 118 + L.LC_W & -- 'w' 119 + L.LC_X & -- 'x' 120 + L.LC_Y & -- 'y' 121 + L.LC_Z & -- 'z' 122 + L.Left_Curly_Bracket & -- '{' 123 + L.Vertical_Line & -- '|' 124 + L.Right_Curly_Bracket & -- '}' 125 + L.Tilde & -- '~' 126 + L.DEL & -- DEL 127 + L.Reserved_128 & -- Reserved_128 128 + L.Reserved_129 & -- Reserved_129 129 + L.BPH & -- BPH 130 + L.NBH & -- NBH 131 + L.Reserved_132 & -- Reserved_132 132 + L.NEL & -- NEL 133 + L.SSA & -- SSA 134 + L.ESA & -- ESA 135 + L.HTS & -- HTS 136 + L.HTJ & -- HTJ 137 + L.VTS & -- VTS 138 + L.PLD & -- PLD 139 + L.PLU & -- PLU 140 + L.RI & -- RI 141 + L.SS2 & -- SS2 142 + L.SS3 & -- SS3 143 + L.DCS & -- DCS 144 + L.PU1 & -- PU1 145 + L.PU2 & -- PU2 146 + L.STS & -- STS 147 + L.CCH & -- CCH 148 + L.MW & -- MW 149 + L.SPA & -- SPA 150 + L.EPA & -- EPA 151 + L.SOS & -- SOS 152 + L.Reserved_153 & -- Reserved_153 153 + L.SCI & -- SCI 154 + L.CSI & -- CSI 155 + L.ST & -- ST 156 + L.OSC & -- OSC 157 + L.PM & -- PM 158 + L.APC & -- APC 159 + L.No_Break_Space & -- No_Break_Space 160 + L.Inverted_Exclamation & -- Inverted_Exclamation 161 + L.Cent_Sign & -- Cent_Sign 162 + L.Pound_Sign & -- Pound_Sign 163 + L.Currency_Sign & -- Currency_Sign 164 + L.Yen_Sign & -- Yen_Sign 165 + L.Broken_Bar & -- Broken_Bar 166 + L.Section_Sign & -- Section_Sign 167 + L.Diaeresis & -- Diaeresis 168 + L.Copyright_Sign & -- Copyright_Sign 169 + L.Feminine_Ordinal_Indicator & -- Feminine_Ordinal_Indicator 170 + L.Left_Angle_Quotation & -- Left_Angle_Quotation 171 + L.Not_Sign & -- Not_Sign 172 + L.Soft_Hyphen & -- Soft_Hyphen 173 + L.Registered_Trade_Mark_Sign & -- Registered_Trade_Mark_Sign 174 + L.Macron & -- Macron 175 + L.Degree_Sign & -- Degree_Sign 176 + L.Plus_Minus_Sign & -- Plus_Minus_Sign 177 + L.Superscript_Two & -- Superscript_Two 178 + L.Superscript_Three & -- Superscript_Three 179 + L.Acute & -- Acute 180 + L.Micro_Sign & -- Micro_Sign 181 + L.Pilcrow_Sign & -- Pilcrow_Sign 182 + L.Middle_Dot & -- Middle_Dot 183 + L.Cedilla & -- Cedilla 184 + L.Superscript_One & -- Superscript_One 185 + L.Masculine_Ordinal_Indicator & -- Masculine_Ordinal_Indicator 186 + L.Right_Angle_Quotation & -- Right_Angle_Quotation 187 + L.Fraction_One_Quarter & -- Fraction_One_Quarter 188 + L.Fraction_One_Half & -- Fraction_One_Half 189 + L.Fraction_Three_Quarters & -- Fraction_Three_Quarters 190 + L.Inverted_Question & -- Inverted_Question 191 + L.UC_A_Grave & -- UC_A_Grave 192 + L.UC_A_Acute & -- UC_A_Acute 193 + L.UC_A_Circumflex & -- UC_A_Circumflex 194 + L.UC_A_Tilde & -- UC_A_Tilde 195 + L.UC_A_Diaeresis & -- UC_A_Diaeresis 196 + L.UC_A_Ring & -- UC_A_Ring 197 + L.UC_AE_Diphthong & -- UC_AE_Diphthong 198 + L.UC_C_Cedilla & -- UC_C_Cedilla 199 + L.UC_E_Grave & -- UC_E_Grave 200 + L.UC_E_Acute & -- UC_E_Acute 201 + L.UC_E_Circumflex & -- UC_E_Circumflex 202 + L.UC_E_Diaeresis & -- UC_E_Diaeresis 203 + L.UC_I_Grave & -- UC_I_Grave 204 + L.UC_I_Acute & -- UC_I_Acute 205 + L.UC_I_Circumflex & -- UC_I_Circumflex 206 + L.UC_I_Diaeresis & -- UC_I_Diaeresis 207 + L.UC_Icelandic_Eth & -- UC_Icelandic_Eth 208 + L.UC_N_Tilde & -- UC_N_Tilde 209 + L.UC_O_Grave & -- UC_O_Grave 210 + L.UC_O_Acute & -- UC_O_Acute 211 + L.UC_O_Circumflex & -- UC_O_Circumflex 212 + L.UC_O_Tilde & -- UC_O_Tilde 213 + L.UC_O_Diaeresis & -- UC_O_Diaeresis 214 + L.Multiplication_Sign & -- Multiplication_Sign 215 + L.UC_O_Oblique_Stroke & -- UC_O_Oblique_Stroke 216 + L.UC_U_Grave & -- UC_U_Grave 217 + L.UC_U_Acute & -- UC_U_Acute 218 + L.UC_U_Circumflex & -- UC_U_Circumflex 219 + L.UC_U_Diaeresis & -- UC_U_Diaeresis 220 + L.UC_Y_Acute & -- UC_Y_Acute 221 + L.UC_Icelandic_Thorn & -- UC_Icelandic_Thorn 222 + L.LC_German_Sharp_S & -- LC_German_Sharp_S 223 + L.LC_A_Grave & -- LC_A_Grave 224 + L.LC_A_Acute & -- LC_A_Acute 225 + L.LC_A_Circumflex & -- LC_A_Circumflex 226 + L.LC_A_Tilde & -- LC_A_Tilde 227 + L.LC_A_Diaeresis & -- LC_A_Diaeresis 228 + L.LC_A_Ring & -- LC_A_Ring 229 + L.LC_AE_Diphthong & -- LC_AE_Diphthong 230 + L.LC_C_Cedilla & -- LC_C_Cedilla 231 + L.LC_E_Grave & -- LC_E_Grave 232 + L.LC_E_Acute & -- LC_E_Acute 233 + L.LC_E_Circumflex & -- LC_E_Circumflex 234 + L.LC_E_Diaeresis & -- LC_E_Diaeresis 235 + L.LC_I_Grave & -- LC_I_Grave 236 + L.LC_I_Acute & -- LC_I_Acute 237 + L.LC_I_Circumflex & -- LC_I_Circumflex 238 + L.LC_I_Diaeresis & -- LC_I_Diaeresis 239 + L.LC_Icelandic_Eth & -- LC_Icelandic_Eth 240 + L.LC_N_Tilde & -- LC_N_Tilde 241 + L.LC_O_Grave & -- LC_O_Grave 242 + L.LC_O_Acute & -- LC_O_Acute 243 + L.LC_O_Circumflex & -- LC_O_Circumflex 244 + L.LC_O_Tilde & -- LC_O_Tilde 245 + L.LC_O_Diaeresis & -- LC_O_Diaeresis 246 + L.Division_Sign & -- Division_Sign 247 + L.LC_O_Oblique_Stroke & -- LC_O_Oblique_Stroke 248 + L.LC_U_Grave & -- LC_U_Grave 249 + L.LC_U_Acute & -- LC_U_Acute 250 + L.LC_U_Circumflex & -- LC_U_Circumflex 251 + L.LC_U_Diaeresis & -- LC_U_Diaeresis 252 + L.LC_Y_Acute & -- LC_Y_Acute 253 + L.LC_Icelandic_Thorn & -- LC_Icelandic_Thorn 254 + L.LC_Y_Diaeresis); -- LC_Y_Diaeresis 255 + +end Ada.Strings.Maps; diff --git a/gcc/ada/libgnat/a-strsea.adb b/gcc/ada/libgnat/a-strsea.adb new file mode 100644 index 0000000..9b9fa46 --- /dev/null +++ b/gcc/ada/libgnat/a-strsea.adb @@ -0,0 +1,645 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . S E A R C H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: This code is derived from the ADAR.CSH public domain Ada 83 +-- versions of the Appendix C string handling packages (code extracted +-- from Ada.Strings.Fixed). A significant change is that we optimize the +-- case of identity mappings for Count and Index, and also Index_Non_Blank +-- is specialized (rather than using the general Index routine). + +with Ada.Strings.Maps; use Ada.Strings.Maps; +with System; use System; + +package body Ada.Strings.Search is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Belongs + (Element : Character; + Set : Maps.Character_Set; + Test : Membership) return Boolean; + pragma Inline (Belongs); + -- Determines if the given element is in (Test = Inside) or not in + -- (Test = Outside) the given character set. + + ------------- + -- Belongs -- + ------------- + + function Belongs + (Element : Character; + Set : Maps.Character_Set; + Test : Membership) return Boolean + is + begin + if Test = Inside then + return Is_In (Element, Set); + else + return not Is_In (Element, Set); + end if; + end Belongs; + + ----------- + -- Count -- + ----------- + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + Num := 0; + Ind := Source'First; + + -- Unmapped case + + if Mapping'Address = Maps.Identity'Address then + while Ind <= Source'Last - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + Num := Num + 1; + Ind := Ind + Pattern'Length; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped case + + else + while Ind <= Source'Last - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; + end loop; + + Num := Num + 1; + Ind := Ind + Pattern'Length; + + <> + null; + end loop; + end if; + + -- Return result + + return Num; + end Count; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + Num := 0; + Ind := Source'First; + while Ind <= Source'Last - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Mapping (Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; + end loop; + + Num := Num + 1; + Ind := Ind + Pattern'Length; + + <> + null; + end loop; + + return Num; + end Count; + + function Count + (Source : String; + Set : Maps.Character_Set) return Natural + is + N : Natural := 0; + + begin + for J in Source'Range loop + if Is_In (Source (J), Set) then + N := N + 1; + end if; + end loop; + + return N; + end Count; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + is + begin + -- AI05-031: Raise Index error if Source non-empty and From not in range + + if Source'Length /= 0 and then From not in Source'Range then + raise Index_Error; + end if; + + -- If Source is the empty string, From may still be out of its + -- range. The following ensures that in all cases there is no + -- possible erroneous access to a non-existing character. + + for J in Integer'Max (From, Source'First) .. Source'Last loop + if Belongs (Source (J), Set, Test) then + First := J; + + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + end loop; + + -- Here if J indexes first char of token, and all chars after J + -- are in the token. + + Last := Source'Last; + return; + end if; + end loop; + + -- Here if no token found + + First := From; + Last := 0; + end Find_Token; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + is + begin + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + First := J; + + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + end loop; + + -- Here if J indexes first char of token, and all chars after J + -- are in the token. + + Last := Source'Last; + return; + end if; + end loop; + + -- Here if no token found + + -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if + -- Source'First is not positive and is assigned to First. Formulation + -- is slightly different in RM 2012, but the intent seems similar, so + -- we check explicitly for that condition. + + if Source'First not in Positive then + raise Constraint_Error; + + else + First := Source'First; + Last := 0; + end if; + end Find_Token; + + ----------- + -- Index -- + ----------- + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Cur : Natural; + + Ind : Integer; + -- Index for start of match check. This can be negative if the pattern + -- length is greater than the string length, which is why this variable + -- is Integer instead of Natural. In this case, the search loops do not + -- execute at all, so this Ind value is never used. + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + + -- Unmapped forward case + + if Mapping'Address = Maps.Identity'Address then + for J in 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped forward case + + else + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + end if; + + -- Backwards case + + else + -- Unmapped backward case + + Ind := Source'Last - PL1; + + if Mapping'Address = Maps.Identity'Address then + for J in reverse 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind - 1; + end if; + end loop; + + -- Mapped backward case + + else + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + -- If Pattern longer than Source it can't be found + + if Pattern'Length > Source'Length then + return 0; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + + -- Backwards case + + else + Ind := Source'Last - PL1; + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + -- Forwards case + + if Going = Forward then + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + + -- Backwards case + + else + for J in reverse Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + begin + + -- AI05-056: If source is empty result is always zero + + if Source'Length = 0 then + return 0; + + elsif Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + begin + + -- AI05-056: If source is empty result is always zero + + if Source'Length = 0 then + return 0; + + elsif Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return Index + (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return Index + (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + + -- AI05-056 : if source is empty result is always 0. + + if Source'Length = 0 then + return 0; + + elsif Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Set, Test, Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Set, Test, Backward); + end if; + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : String; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Source (J) /= ' ' then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Source (J) /= ' ' then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index_Non_Blank; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (From .. Source'Last), Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (Source'First .. From), Backward); + end if; + end Index_Non_Blank; + +end Ada.Strings.Search; diff --git a/gcc/ada/libgnat/a-strsea.ads b/gcc/ada/libgnat/a-strsea.ads new file mode 100644 index 0000000..380444a --- /dev/null +++ b/gcc/ada/libgnat/a-strsea.ads @@ -0,0 +1,121 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . S E A R C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the search functions from Ada.Strings.Fixed. They +-- are separated out because they are shared by Ada.Strings.Bounded and +-- Ada.Strings.Unbounded, and we don't want to drag in other irrelevant stuff +-- from Ada.Strings.Fixed when using the other two packages. We make this a +-- private package, since user programs should access these subprograms via +-- one of the standard string packages. + +with Ada.Strings.Maps; + +private package Ada.Strings.Search is + pragma Preelaborate; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + + procedure Find_Token + (Source : String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + +end Ada.Strings.Search; diff --git a/gcc/ada/libgnat/a-strsup.adb b/gcc/ada/libgnat/a-strsup.adb new file mode 100644 index 0000000..8cca8eb --- /dev/null +++ b/gcc/ada/libgnat/a-strsup.adb @@ -0,0 +1,1925 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . S U P E R B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Strings.Search; + +package body Ada.Strings.Superbounded is + + ------------ + -- Concat -- + ------------ + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + end if; + + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end; + end return; + end Concat; + + function Concat + (Left : Super_String; + Right : String) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Nlen : constant Natural := Llen + Right'Length; + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + end if; + + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end; + end return; + end Concat; + + function Concat + (Left : String; + Right : Super_String) return Super_String + is + + begin + return Result : Super_String (Right.Max_Length) do + declare + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + end if; + + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end; + end return; + end Concat; + + function Concat + (Left : Super_String; + Right : Character) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + end if; + + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end; + end return; + end Concat; + + function Concat + (Left : Character; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Right.Max_Length) do + declare + Rlen : constant Natural := Right.Current_Length; + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + end if; + + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := + Right.Data (1 .. Rlen); + end; + end return; + end Concat; + + ----------- + -- Equal -- + ----------- + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Current_Length = Right.Current_Length + and then Left.Data (1 .. Left.Current_Length) = + Right.Data (1 .. Right.Current_Length); + end "="; + + function Equal + (Left : Super_String; + Right : String) return Boolean + is + begin + return Left.Current_Length = Right'Length + and then Left.Data (1 .. Left.Current_Length) = Right; + end Equal; + + function Equal + (Left : String; + Right : Super_String) return Boolean + is + begin + return Left'Length = Right.Current_Length + and then Left = Right.Data (1 .. Right.Current_Length); + end Equal; + + ------------- + -- Greater -- + ------------- + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > + Right.Data (1 .. Right.Current_Length); + end Greater; + + function Greater + (Left : Super_String; + Right : String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > Right; + end Greater; + + function Greater + (Left : String; + Right : Super_String) return Boolean + is + begin + return Left > Right.Data (1 .. Right.Current_Length); + end Greater; + + ---------------------- + -- Greater_Or_Equal -- + ---------------------- + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= + Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Super_String; + Right : String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= Right; + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : String; + Right : Super_String) return Boolean + is + begin + return Left >= Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + ---------- + -- Less -- + ---------- + + function Less + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < + Right.Data (1 .. Right.Current_Length); + end Less; + + function Less + (Left : Super_String; + Right : String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < Right; + end Less; + + function Less + (Left : String; + Right : Super_String) return Boolean + is + begin + return Left < Right.Data (1 .. Right.Current_Length); + end Less; + + ------------------- + -- Less_Or_Equal -- + ------------------- + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= + Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Super_String; + Right : String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= Right; + end Less_Or_Equal; + + function Less_Or_Equal + (Left : String; + Right : Super_String) return Boolean + is + begin + return Left <= Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + ---------------------- + -- Set_Super_String -- + ---------------------- + + procedure Set_Super_String + (Target : out Super_String; + Source : String; + Drop : Truncation := Error) + is + Slen : constant Natural := Source'Length; + Max_Length : constant Positive := Target.Max_Length; + + begin + if Slen <= Max_Length then + Target.Current_Length := Slen; + Target.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Set_Super_String; + + ------------------ + -- Super_Append -- + ------------------ + + -- Case of Super_String and Super_String + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Result.Data := Right.Data; + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Source.Data := New_Item.Data; + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Super_String and String + + function Super_Append + (Left : Super_String; + Right : String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right (Right'First .. Right'First - 1 + + Max_Length - Llen); + + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right (Right'Last - (Max_Length - 1) .. Right'Last); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item (New_Item'First .. + New_Item'First - 1 + Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - (Max_Length - 1) .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of String and Super_String + + function Super_Append + (Left : String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then + Result.Data (1 .. Max_Length) := + Left (Left'First .. Left'First + (Max_Length - 1)); + + else + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right.Data (Rlen - (Max_Length - 1) .. Rlen); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + -- Case of Super_String and Character + + function Super_Append + (Left : Super_String; + Right : Character; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen < Max_Length then + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1) := Right; + return Result; + + else + case Drop is + when Strings.Right => + return Left; + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length - 1) := + Left.Data (2 .. Max_Length); + Result.Data (Max_Length) := Right; + return Result; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Character; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + + begin + if Llen < Max_Length then + Source.Current_Length := Llen + 1; + Source.Data (Llen + 1) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + null; + + when Strings.Left => + Source.Data (1 .. Max_Length - 1) := + Source.Data (2 .. Max_Length); + Source.Data (Max_Length) := New_Item; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Character and Super_String + + function Super_Append + (Left : Character; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen < Max_Length then + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + return Result; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1) := Left; + Result.Data (2 .. Max_Length) := + Right.Data (1 .. Max_Length - 1); + return Result; + + when Strings.Left => + return Right; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + ----------------- + -- Super_Count -- + ----------------- + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + begin + return + Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + is + begin + return + Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Set : Maps.Character_Set) return Natural + is + begin + return Search.Count (Source.Data (1 .. Source.Current_Length), Set); + end Super_Count; + + ------------------ + -- Super_Delete -- + ------------------ + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return Source; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Result.Current_Length := From - 1; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + return Result; + + else + Result.Current_Length := Slen - Num_Delete; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + Result.Data (From .. Result.Current_Length) := + Source.Data (Through + 1 .. Slen); + return Result; + end if; + end Super_Delete; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural) + is + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Source.Current_Length := From - 1; + + else + Source.Current_Length := Slen - Num_Delete; + Source.Data (From .. Source.Current_Length) := + Source.Data (Through + 1 .. Slen); + end if; + end Super_Delete; + + ------------------- + -- Super_Element -- + ------------------- + + function Super_Element + (Source : Super_String; + Index : Positive) return Character + is + begin + if Index <= Source.Current_Length then + return Source.Data (Index); + else + raise Strings.Index_Error; + end if; + end Super_Element; + + ---------------------- + -- Super_Find_Token -- + ---------------------- + + procedure Super_Find_Token + (Source : Super_String; + Set : Maps.Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Search.Find_Token + (Source.Data (From .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + procedure Super_Find_Token + (Source : Super_String; + Set : Maps.Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Search.Find_Token + (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + ---------------- + -- Super_Head -- + ---------------- + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := Source.Data (1 .. Count); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Count) := (others => Pad); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Max_Length - Npad) := + Source.Data (Count - Max_Length + 1 .. Slen); + Result.Data (Max_Length - Npad + 1 .. Max_Length) := + (others => Pad); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Head; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + Temp : String (1 .. Max_Length); + + begin + if Npad <= 0 then + Source.Current_Length := Count; + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (Slen + 1 .. Count) := (others => Pad); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad > Max_Length then + Source.Data := (others => Pad); + + else + Temp := Source.Data; + Source.Data (1 .. Max_Length - Npad) := + Temp (Count - Max_Length + 1 .. Slen); + + for J in Max_Length - Npad + 1 .. Max_Length loop + Source.Data (J) := Pad; + end loop; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Head; + + ----------------- + -- Super_Index -- + ----------------- + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Strings.Direction := Strings.Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Maps.Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), Set, Test, Going); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + return Search.Index + (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); + end Super_Index; + + --------------------------- + -- Super_Index_Non_Blank -- + --------------------------- + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return + Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), Going); + end Super_Index_Non_Blank; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + return + Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), From, Going); + end Super_Index_Non_Blank; + + ------------------ + -- Super_Insert -- + ------------------ + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Nlen : constant Natural := New_Item'Length; + Tlen : constant Natural := Slen + Nlen; + Blen : constant Natural := Before - 1; + Alen : constant Integer := Slen - Blen; + Droplen : constant Integer := Tlen - Max_Length; + + -- Tlen is the length of the total string before possible truncation. + -- Blen, Alen are the lengths of the before and after pieces of the + -- source string. + + begin + if Alen < 0 then + raise Ada.Strings.Index_Error; + + elsif Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Tlen) := + Source.Data (Before .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Before .. Max_Length) := + New_Item (New_Item'First + .. New_Item'First + Max_Length - Before); + else + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Max_Length) := + Source.Data (Before .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (Before .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + New_Item (New_Item'Last - (Max_Length - Alen) + 1 + .. New_Item'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := + New_Item; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Insert; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Insert (Source, Before, New_Item, Drop); + end Super_Insert; + + ------------------ + -- Super_Length -- + ------------------ + + function Super_Length (Source : Super_String) return Natural is + begin + return Source.Current_Length; + end Super_Length; + + --------------------- + -- Super_Overwrite -- + --------------------- + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Endpos : constant Natural := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif New_Item'Length = 0 then + return Source; + + elsif Endpos <= Slen then + Result.Current_Length := Source.Current_Length; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + elsif Endpos <= Max_Length then + Result.Current_Length := Endpos; + Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + else + Result.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Position - 1) := + Source.Data (1 .. Position - 1); + + Result.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + return Result; + + when Strings.Left => + if New_Item'Length >= Max_Length then + Result.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + return Result; + + else + Result.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + Result.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + return Result; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : String; + Drop : Strings.Truncation := Strings.Error) + is + Max_Length : constant Positive := Source.Max_Length; + Endpos : constant Positive := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Endpos <= Slen then + Source.Data (Position .. Endpos) := New_Item; + + elsif Endpos <= Max_Length then + Source.Data (Position .. Endpos) := New_Item; + Source.Current_Length := Endpos; + + else + Source.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + + when Strings.Left => + if New_Item'Length > Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + + Source.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + --------------------------- + -- Super_Replace_Element -- + --------------------------- + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Character) + is + begin + if Index <= Source.Current_Length then + Source.Data (Index) := By; + else + raise Ada.Strings.Index_Error; + end if; + end Super_Replace_Element; + + ------------------------- + -- Super_Replace_Slice -- + ------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + + begin + if Low > Slen + 1 then + raise Strings.Index_Error; + + elsif High < Low then + return Super_Insert (Source, Low, By, Drop); + + else + declare + Blen : constant Natural := Natural'Max (0, Low - 1); + Alen : constant Natural := Natural'Max (0, Slen - High); + Tlen : constant Natural := Blen + By'Length + Alen; + Droplen : constant Integer := Tlen - Max_Length; + Result : Super_String (Max_Length); + + -- Tlen is the total length of the result string before any + -- truncation. Blen and Alen are the lengths of the pieces + -- of the original string that end up in the result string + -- before and after the replaced slice. + + begin + if Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Tlen) := + Source.Data (High + 1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Low .. Max_Length) := + By (By'First .. By'First + Max_Length - Low); + else + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Max_Length) := + Source.Data (High + 1 .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (High + 1 .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + By (By'Last - (Max_Length - Alen) + 1 .. By'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := By; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end; + end if; + end Super_Replace_Slice; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Replace_Slice (Source, Low, High, By, Drop); + end Super_Replace_Slice; + + --------------------- + -- Super_Replicate -- + --------------------- + + function Super_Replicate + (Count : Natural; + Item : Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Count <= Max_Length then + Result.Current_Length := Count; + + elsif Drop = Strings.Error then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Max_Length; + end if; + + Result.Data (1 .. Result.Current_Length) := (others => Item); + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Length : constant Integer := Count * Item'Length; + Result : Super_String (Max_Length); + Indx : Positive; + + begin + if Length <= Max_Length then + Result.Current_Length := Length; + + if Length > 0 then + Indx := 1; + + for J in 1 .. Count loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + end if; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Indx := 1; + + while Indx + Item'Length <= Max_Length + 1 loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + + Result.Data (Indx .. Max_Length) := + Item (Item'First .. Item'First + Max_Length - Indx); + + when Strings.Left => + Indx := Max_Length; + + while Indx - Item'Length >= 1 loop + Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; + Indx := Indx - Item'Length; + end loop; + + Result.Data (1 .. Indx) := + Item (Item'Last - Indx + 1 .. Item'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + begin + return + Super_Replicate + (Count, + Item.Data (1 .. Item.Current_Length), + Drop, + Item.Max_Length); + end Super_Replicate; + + ----------------- + -- Super_Slice -- + ----------------- + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + return R : String (Low .. High) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + -- Note: in this case, superflat bounds are not a problem, we just + -- get the null string in accordance with normal Ada slice rules. + + R := Source.Data (Low .. High); + end return; + end Super_Slice; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String + is + begin + return Result : Super_String (Source.Max_Length) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + -- Note: the Max operation here deals with the superflat case + + Result.Current_Length := Integer'Max (0, High - Low + 1); + Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); + end return; + end Super_Slice; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural) + is + begin + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + -- Note: the Max operation here deals with the superflat case + + Target.Current_Length := Integer'Max (0, High - Low + 1); + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); + end Super_Slice; + + ---------------- + -- Super_Tail -- + ---------------- + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := + Source.Data (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Max_Length) := + Source.Data (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + Result.Data (1 .. Max_Length - Slen) := (others => Pad); + Result.Data (Max_Length - Slen + 1 .. Max_Length) := + Source.Data (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Tail; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + Temp : constant String (1 .. Max_Length) := Source.Data; + + begin + if Npad <= 0 then + Source.Current_Length := Count; + Source.Data (1 .. Count) := + Temp (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Source.Data := (others => Pad); + + else + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Max_Length) := + Temp (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + for J in 1 .. Max_Length - Slen loop + Source.Data (J) := Pad; + end loop; + + Source.Data (Max_Length - Slen + 1 .. Max_Length) := + Temp (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Tail; + + --------------------- + -- Super_To_String -- + --------------------- + + function Super_To_String (Source : Super_String) return String is + begin + return R : String (1 .. Source.Current_Length) do + R := Source.Data (1 .. Source.Current_Length); + end return; + end Super_To_String; + + --------------------- + -- Super_Translate -- + --------------------- + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + end Super_Translate; + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping_Function) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Mapping.all (Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping_Function) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Mapping.all (Source.Data (J)); + end loop; + end Super_Translate; + + ---------------- + -- Super_Trim -- + ---------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String + is + Result : Super_String (Source.Max_Length); + Last : Natural := Source.Current_Length; + First : Positive := 1; + + begin + if Side = Left or else Side = Both then + while First <= Last and then Source.Data (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Source.Data (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End) + is + Max_Length : constant Positive := Source.Max_Length; + Last : Natural := Source.Current_Length; + First : Positive := 1; + Temp : String (1 .. Max_Length); + + begin + Temp (1 .. Last) := Source.Data (1 .. Last); + + if Side = Left or else Side = Both then + while First <= Last and then Temp (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Temp (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); + end Super_Trim; + + function Super_Trim + (Source : Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (First .. Last); + return Result; + end if; + end loop; + end if; + end loop; + + Result.Current_Length := 0; + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + is + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + if First = 1 then + Source.Current_Length := Last; + return; + else + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := + Source.Data (First .. Last); + return; + end if; + end if; + end loop; + + Source.Current_Length := 0; + return; + end if; + end loop; + + Source.Current_Length := 0; + end Super_Trim; + + ----------- + -- Times -- + ----------- + + function Times + (Left : Natural; + Right : Character; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Left > Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Left; + + for J in 1 .. Left loop + Result.Data (J) := Right; + end loop; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : String; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := Right; + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := + Right.Data (1 .. Rlen); + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + --------------------- + -- To_Super_String -- + --------------------- + + function To_Super_String + (Source : String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String + is + Result : Super_String (Max_Length); + Slen : constant Natural := Source'Length; + + begin + if Slen <= Max_Length then + Result.Current_Length := Slen; + Result.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end To_Super_String; + +end Ada.Strings.Superbounded; diff --git a/gcc/ada/libgnat/a-strsup.ads b/gcc/ada/libgnat/a-strsup.ads new file mode 100644 index 0000000..950a68a --- /dev/null +++ b/gcc/ada/libgnat/a-strsup.ads @@ -0,0 +1,493 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . S U P E R B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This non generic package contains most of the implementation of the +-- generic package Ada.Strings.Bounded.Generic_Bounded_Length. + +-- It defines type Super_String as a discriminated record with the maximum +-- length as the discriminant. Individual instantiations of Strings.Bounded +-- use this type with an appropriate discriminant value set. + +with Ada.Strings.Maps; + +package Ada.Strings.Superbounded is + pragma Preelaborate; + + -- Type Bounded_String in Ada.Strings.Bounded.Generic_Bounded_Length is + -- derived from Super_String, with the constraint of the maximum length. + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : String (1 .. Max_Length); + -- A previous version had a default initial value for Data, which is + -- no longer necessary, because we now special-case this type in the + -- compiler, so "=" composes properly for descendants of this type. + -- Leaving it out is more efficient. + end record; + + -- The subprograms defined for Super_String are similar to those + -- defined for Bounded_String, except that they have different names, so + -- that they can be renamed in Ada.Strings.Bounded.Generic_Bounded_Length. + + function Super_Length (Source : Super_String) return Natural; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Super_String + (Source : String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String; + -- Note the additional parameter Max_Length, which specifies the maximum + -- length setting of the resulting Super_String value. + + -- The following procedures have declarations (and semantics) that are + -- exactly analogous to those declared in Ada.Strings.Bounded. + + function Super_To_String (Source : Super_String) return String; + + procedure Set_Super_String + (Target : out Super_String; + Source : String; + Drop : Truncation := Error); + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : Character; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Character; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Character; + Drop : Truncation := Error); + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : String) return Super_String; + + function Concat + (Left : String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : Character) return Super_String; + + function Concat + (Left : Character; + Right : Super_String) return Super_String; + + function Super_Element + (Source : Super_String; + Index : Positive) return Character; + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Character); + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return String; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural); + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean; + + function Equal + (Left : Super_String; + Right : Super_String) return Boolean renames "="; + + function Equal + (Left : Super_String; + Right : String) return Boolean; + + function Equal + (Left : String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : String) return Boolean; + + function Less + (Left : String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : String) return Boolean; + + function Less_Or_Equal + (Left : String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : String) return Boolean; + + function Greater + (Left : String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : String) return Boolean; + + function Greater_Or_Equal + (Left : String; + Right : Super_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Super_Index + (Source : Super_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Super_Index + (Source : Super_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index + (Source : Super_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Super_Index + (Source : Super_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Super_Index + (Source : Super_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Super_Count + (Source : Super_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Super_Count + (Source : Super_String; + Set : Maps.Character_Set) return Natural; + + procedure Super_Find_Token + (Source : Super_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + + procedure Super_Find_Token + (Source : Super_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping) return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping); + + function Super_Translate + (Source : Super_String; + Mapping : Maps.Character_Mapping_Function) return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : String; + Drop : Truncation := Error); + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : String; + Drop : Truncation := Error); + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End); + + function Super_Trim + (Source : Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error); + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Character := Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + -- Note: in some of the following routines, there is an extra parameter + -- Max_Length which specifies the value of the maximum length for the + -- resulting Super_String value. + + function Times + (Left : Natural; + Right : Character; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : String; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Super_String) return Super_String; + + function Super_Replicate + (Count : Natural; + Item : Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Truncation := Error) return Super_String; + +private + -- Pragma Inline declarations + + pragma Inline ("="); + pragma Inline (Less); + pragma Inline (Less_Or_Equal); + pragma Inline (Greater); + pragma Inline (Greater_Or_Equal); + pragma Inline (Concat); + pragma Inline (Super_Count); + pragma Inline (Super_Element); + pragma Inline (Super_Find_Token); + pragma Inline (Super_Index); + pragma Inline (Super_Index_Non_Blank); + pragma Inline (Super_Length); + pragma Inline (Super_Replace_Element); + pragma Inline (Super_Slice); + pragma Inline (Super_To_String); + +end Ada.Strings.Superbounded; diff --git a/gcc/ada/libgnat/a-strunb-shared.adb b/gcc/ada/libgnat/a-strunb-shared.adb new file mode 100644 index 0000000..4347c06 --- /dev/null +++ b/gcc/ada/libgnat/a-strunb-shared.adb @@ -0,0 +1,2115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Unbounded is + + use Ada.Strings.Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of the + -- allocated memory segments to use memory effectively by Append/Insert/etc + -- operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left string is empty, return Right string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill data + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String + is + LR : constant Shared_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String + is + DR : Shared_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String + is + RR : constant Shared_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + RR : constant Shared_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean + is + LR : constant Shared_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean + is + RR : constant Shared_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + begin + return + ((Static_Size + Max_Length - 1) / Min_Mul_Alloc + 2) * Min_Mul_Alloc + - Static_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Max_Length : Natural) return not null Shared_String_Access + is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_String'Access); + return Empty_Shared_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String) + is + SR : constant Shared_String_Access := Source.Reference; + NR : constant Shared_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : not null Shared_String_Access; + Length : Natural) return Boolean + is + begin + return + System.Atomic_Counters.Is_One (Item.Counter) + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_String; + Index : Positive) return Character + is + SR : constant Shared_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_String) is + SR : constant not null Shared_String_Access := Object.Reference; + begin + if SR /= Null_Unbounded_String.Reference then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + -- We set the Object to the empty string so there will be no ill + -- effects if a program references an already-finalized object. + + Object.Reference := Null_Unbounded_String.Reference; + Reference (Object.Reference); + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_String_Access := Source.Reference; + begin + Search.Find_Token (SR.Data (From .. SR.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_String_Access := Source.Reference; + begin + Search.Find_Token (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Result is same as source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- existing data and fill remaining positions with Pad characters. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Strings.Direction := Strings.Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_String_Access := Source.Reference; + begin + return Search.Index_Non_Blank (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is same as source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_String_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Index <= SR.Last then + + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + -------------------------- + -- Set_Unbounded_String -- + -------------------------- + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String) + is + TR : constant Shared_String_Access := Target.Reference; + DR : Shared_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + + else + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String + is + SR : constant Shared_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Result is whole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_String_Access; + DR : Shared_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + --------------- + -- To_String -- + --------------- + + function To_String (Source : Unbounded_String) return String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_String; + + ------------------------- + -- To_Unbounded_String -- + ------------------------- + + function To_Unbounded_String (Source : String) return Unbounded_String is + DR : Shared_String_Access; + + begin + if Source'Length = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + function To_Unbounded_String (Length : Natural) return Unbounded_String is + DR : Shared_String_Access; + + begin + if Length = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function) + is + SR : constant Shared_String_Access := Source.Reference; + DR : Shared_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_String'Access); + Source.Reference := Empty_Shared_String'Access; + Unreference (SR); + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String + is + SR : constant Shared_String_Access := Source.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + DR := Empty_Shared_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_String_Access := Source.Reference; + TR : constant Shared_String_Access := Target.Reference; + DL : Natural; + DR : Shared_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_String'Access); + Target.Reference := Empty_Shared_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existing shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_String_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation (Shared_String, Shared_String_Access); + + Aux : Shared_String_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + + -- Reference counter of Empty_Shared_String should never reach + -- zero. We check here in case it wraps around. + + if Aux /= Empty_Shared_String'Access then + Free (Aux); + end if; + end if; + end Unreference; + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-strunb-shared.ads b/gcc/ada/libgnat/a-strunb-shared.ads new file mode 100644 index 0000000..3efa51c --- /dev/null +++ b/gcc/ada/libgnat/a-strunb-shared.ads @@ -0,0 +1,490 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an implementation of Ada.Strings.Unbounded that uses +-- reference counts to implement copy on modification (rather than copy on +-- assignment). This is significantly more efficient on many targets. + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86 platforms +-- - all x86_64 platforms + + -- This package uses several techniques to increase speed: + + -- - Implicit sharing or copy-on-write. An Unbounded_String contains only + -- the reference to the data which is shared between several instances. + -- The shared data is reallocated only when its value is changed and + -- the object mutation can't be used or it is inefficient to use it. + + -- - Object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are met: + -- - the shared data object is no longer used by anyone else; + -- - the size is sufficient to store the new value; + -- - the gap after reuse is less than a defined threshold. + + -- - Memory preallocation. Most of used memory allocation algorithms + -- align allocated segments on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. + +with Ada.Strings.Maps; +private with Ada.Finalization; +private with System.Atomic_Counters; + +package Ada.Strings.Unbounded is + pragma Preelaborate; + + type Unbounded_String is private; + pragma Preelaborable_Initialization (Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String; + + function Length (Source : Unbounded_String) return Natural; + + type String_Access is access all String; + + procedure Free (X : in out String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_String + (Source : String) return Unbounded_String; + + function To_Unbounded_String + (Length : Natural) return Unbounded_String; + + function To_String (Source : Unbounded_String) return String; + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String); + pragma Ada_05 (Set_Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character); + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String; + + function Element + (Source : Unbounded_String; + Index : Positive) return Character; + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character); + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String; + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String); + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String); + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String); + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_String (Max_Length : Natural) is limited record + Counter : System.Atomic_Counters.Atomic_Counter; + -- Reference counter + + Last : Natural := 0; + Data : String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are currently insignificant. + end record; + + type Shared_String_Access is access all Shared_String; + + procedure Reference (Item : not null Shared_String_Access); + -- Increment reference counter + + procedure Unreference (Item : not null Shared_String_Access); + -- Decrement reference counter, deallocate Item when counter goes to zero + + function Can_Be_Reused + (Item : not null Shared_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_String can be reused. There are two criteria when + -- Shared_String can be reused: its reference counter must be one (thus + -- Shared_String is owned exclusively) and its size is sufficient to + -- store string with specified length effectively. + + function Allocate + (Max_Length : Natural) return not null Shared_String_Access; + -- Allocates new Shared_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_String can be slightly + -- greater. Returns reference to Empty_Shared_String when requested length + -- is zero. + + Empty_Shared_String : aliased Shared_String (0); + + function To_Unbounded (S : String) return Unbounded_String + renames To_Unbounded_String; + -- This renames are here only to be used in the pragma Stream_Convert + + type Unbounded_String is new AF.Controlled with record + Reference : not null Shared_String_Access := Empty_Shared_String'Access; + end record; + + pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_String); + overriding procedure Adjust (Object : in out Unbounded_String); + overriding procedure Finalize (Object : in out Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String := + (AF.Controlled with + Reference => Empty_Shared_String'Access); + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-strunb.adb b/gcc/ada/libgnat/a-strunb.adb new file mode 100644 index 0000000..808e26a --- /dev/null +++ b/gcc/ada/libgnat/a-strunb.adb @@ -0,0 +1,1073 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Strings.Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Unbounded is + + use Ada.Finalization; + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String + is + L_Length : constant Natural := Left.Last; + R_Length : constant Natural := Right.Last; + Result : Unbounded_String; + + begin + Result.Last := L_Length + R_Length; + + Result.Reference := new String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := + Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String + is + L_Length : constant Natural := Left.Last; + Result : Unbounded_String; + + begin + Result.Last := L_Length + Right'Length; + + Result.Reference := new String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String + is + R_Length : constant Natural := Right.Last; + Result : Unbounded_String; + + begin + Result.Last := Left'Length + R_Length; + + Result.Reference := new String (1 .. Result.Last); + + Result.Reference (1 .. Left'Length) := Left; + Result.Reference (Left'Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String + is + Result : Unbounded_String; + + begin + Result.Last := Left.Last + 1; + + Result.Reference := new String (1 .. Result.Last); + + Result.Reference (1 .. Result.Last - 1) := + Left.Reference (1 .. Left.Last); + Result.Reference (Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String + is + Result : Unbounded_String; + + begin + Result.Last := Right.Last + 1; + + Result.Reference := new String (1 .. Result.Last); + Result.Reference (1) := Left; + Result.Reference (2 .. Result.Last) := + Right.Reference (1 .. Right.Last); + return Result; + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String + is + Result : Unbounded_String; + + begin + Result.Last := Left; + + Result.Reference := new String (1 .. Left); + for J in Result.Reference'Range loop + Result.Reference (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String + is + Len : constant Natural := Right'Length; + K : Positive; + Result : Unbounded_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new String (1 .. Result.Last); + + K := 1; + for J in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := Right; + K := K + Len; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String + is + Len : constant Natural := Right.Last; + K : Positive; + Result : Unbounded_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new String (1 .. Result.Last); + + K := 1; + for J in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := + Right.Reference (1 .. Right.Last); + K := K + Len; + end loop; + + return Result; + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); + end "<"; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) < Right; + end "<"; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean + is + begin + return Left < Right.Reference (1 .. Right.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); + end "<="; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) <= Right; + end "<="; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean + is + begin + return Left <= Right.Reference (1 .. Right.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); + end "="; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) = Right; + end "="; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean + is + begin + return Left = Right.Reference (1 .. Right.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); + end ">"; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) > Right; + end ">"; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean + is + begin + return Left > Right.Reference (1 .. Right.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); + end ">="; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) >= Right; + end ">="; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean + is + begin + return Left >= Right.Reference (1 .. Right.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_String) is + begin + -- Copy string, except we do not copy the statically allocated null + -- string since it can never be deallocated. Note that we do not copy + -- extra string room here to avoid dragging unused allocated memory. + + if Object.Reference /= Null_String'Access then + Object.Reference := new String'(Object.Reference (1 .. Object.Last)); + end if; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String) + is + begin + Realloc_For_Chunk (Source, New_Item.Last); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := + New_Item.Reference (1 .. New_Item.Last); + Source.Last := Source.Last + New_Item.Last; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : String) + is + begin + Realloc_For_Chunk (Source, New_Item'Length); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := + New_Item; + Source.Last := Source.Last + New_Item'Length; + end Append; + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character) + is + begin + Realloc_For_Chunk (Source, 1); + Source.Reference (Source.Last + 1) := New_Item; + Source.Last := Source.Last + 1; + end Append; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + begin + return + Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural + is + begin + return + Search.Count (Source.Reference (1 .. Source.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural + is + begin + return Search.Count (Source.Reference (1 .. Source.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String + is + begin + return + To_Unbounded_String + (Fixed.Delete (Source.Reference (1 .. Source.Last), From, Through)); + end Delete; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural) + is + begin + if From > Through then + null; + + elsif From < Source.Reference'First or else Through > Source.Last then + raise Index_Error; + + else + declare + Len : constant Natural := Through - From + 1; + + begin + Source.Reference (From .. Source.Last - Len) := + Source.Reference (Through + 1 .. Source.Last); + Source.Last := Source.Last - Len; + end; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_String; + Index : Positive) return Character + is + begin + if Index <= Source.Last then + return Source.Reference (Index); + else + raise Strings.Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_String) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + + begin + -- Note: Don't try to free statically allocated null string + + if Object.Reference /= Null_String'Access then + Deallocate (Object.Reference); + Object.Reference := Null_Unbounded_String.Reference; + Object.Last := 0; + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Search.Find_Token + (Source.Reference (From .. Source.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Search.Find_Token + (Source.Reference (1 .. Source.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + + begin + -- Note: Do not try to free statically allocated null string + + if X /= Null_Unbounded_String.Reference then + Deallocate (X); + end if; + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); + end Head; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + Old : String_Access := Source.Reference; + begin + Source.Reference := + new String'(Fixed.Head (Source.Reference (1 .. Source.Last), + Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Strings.Direction := Strings.Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + begin + return Search.Index + (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + begin + return Search.Index + (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Search.Index + (Source.Reference (1 .. Source.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural + is + begin + return Search.Index + (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural + is + begin + return Search.Index + (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + return Search.Index + (Source.Reference (1 .. Source.Last), Set, From, Test, Going); + end Index; + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return + Search.Index_Non_Blank + (Source.Reference (1 .. Source.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + return + Search.Index_Non_Blank + (Source.Reference (1 .. Source.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_String) is + begin + Object.Reference := Null_Unbounded_String.Reference; + Object.Last := 0; + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Insert (Source.Reference (1 .. Source.Last), Before, New_Item)); + end Insert; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String) + is + begin + if Before not in Source.Reference'First .. Source.Last + 1 then + raise Index_Error; + end if; + + Realloc_For_Chunk (Source, New_Item'Length); + + Source.Reference + (Before + New_Item'Length .. Source.Last + New_Item'Length) := + Source.Reference (Before .. Source.Last); + + Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; + Source.Last := Source.Last + New_Item'Length; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_String) return Natural is + begin + return Source.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String) + is + NL : constant Natural := New_Item'Length; + begin + if Position <= Source.Last - NL + 1 then + Source.Reference (Position .. Position + NL - 1) := New_Item; + else + declare + Old : String_Access := Source.Reference; + begin + Source.Reference := new String' + (Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + Source.Last := Source.Reference'Length; + Free (Old); + end; + end if; + end Overwrite; + + ----------------------- + -- Realloc_For_Chunk -- + ----------------------- + + procedure Realloc_For_Chunk + (Source : in out Unbounded_String; + Chunk_Size : Natural) + is + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + S_Length : constant Natural := Source.Reference'Length; + + begin + if Chunk_Size > S_Length - Source.Last then + declare + New_Size : constant Positive := + S_Length + Chunk_Size + (S_Length / Growth_Factor); + + New_Rounded_Up_Size : constant Positive := + ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc; + + Tmp : constant String_Access := + new String (1 .. New_Rounded_Up_Size); + + begin + Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); + Free (Source.Reference); + Source.Reference := Tmp; + end; + end if; + end Realloc_For_Chunk; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character) + is + begin + if Index <= Source.Last then + Source.Reference (Index) := By; + else + raise Strings.Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String) + is + Old : String_Access := Source.Reference; + begin + Source.Reference := new String' + (Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + Source.Last := Source.Reference'Length; + Free (Old); + end Replace_Slice; + + -------------------------- + -- Set_Unbounded_String -- + -------------------------- + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String) + is + Old : String_Access := Target.Reference; + begin + Target.Last := Source'Length; + Target.Reference := new String (1 .. Source'Length); + Target.Reference.all := Source; + Free (Old); + end Set_Unbounded_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + return Source.Reference (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String is + begin + return To_Unbounded_String + (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); + end Tail; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space) + is + Old : String_Access := Source.Reference; + begin + Source.Reference := new String' + (Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + end Tail; + + --------------- + -- To_String -- + --------------- + + function To_String (Source : Unbounded_String) return String is + begin + return Source.Reference (1 .. Source.Last); + end To_String; + + ------------------------- + -- To_Unbounded_String -- + ------------------------- + + function To_Unbounded_String (Source : String) return Unbounded_String is + Result : Unbounded_String; + begin + -- Do not allocate an empty string: keep the default + + if Source'Length > 0 then + Result.Last := Source'Length; + Result.Reference := new String (1 .. Source'Length); + Result.Reference.all := Source; + end if; + + return Result; + end To_Unbounded_String; + + function To_Unbounded_String + (Length : Natural) return Unbounded_String + is + Result : Unbounded_String; + + begin + -- Do not allocate an empty string: keep the default + + if Length > 0 then + Result.Last := Length; + Result.Reference := new String (1 .. Length); + end if; + + return Result; + end To_Unbounded_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping) + is + begin + Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function) + is + begin + Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End) + is + Old : String_Access := Source.Reference; + begin + Source.Reference := new String' + (Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + Source.Last := Source.Reference'Length; + Free (Old); + end Trim; + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String + is + begin + return To_Unbounded_String + (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); + end Trim; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) + is + Old : String_Access := Source.Reference; + begin + Source.Reference := new String' + (Fixed.Trim (Source.Reference (1 .. Source.Last), Left, Right)); + Source.Last := Source.Reference'Length; + Free (Old); + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String + is + begin + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + return To_Unbounded_String (Source.Reference.all (Low .. High)); + end if; + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural) + is + begin + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + Target := To_Unbounded_String (Source.Reference.all (Low .. High)); + end if; + end Unbounded_Slice; + +end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-strunb.ads b/gcc/ada/libgnat/a-strunb.ads new file mode 100644 index 0000000..a06d1fc --- /dev/null +++ b/gcc/ada/libgnat/a-strunb.ads @@ -0,0 +1,437 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Maps; +with Ada.Finalization; + +package Ada.Strings.Unbounded is + pragma Preelaborate; + + type Unbounded_String is private; + pragma Preelaborable_Initialization (Unbounded_String); + + Null_Unbounded_String : constant Unbounded_String; + + function Length (Source : Unbounded_String) return Natural; + + type String_Access is access all String; + + procedure Free (X : in out String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_String + (Source : String) return Unbounded_String; + + function To_Unbounded_String + (Length : Natural) return Unbounded_String; + + function To_String (Source : Unbounded_String) return String; + + procedure Set_Unbounded_String + (Target : out Unbounded_String; + Source : String); + pragma Ada_05 (Set_Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Unbounded_String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : String); + + procedure Append + (Source : in out Unbounded_String; + New_Item : Character); + + function "&" + (Left : Unbounded_String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : String) return Unbounded_String; + + function "&" + (Left : String; + Right : Unbounded_String) return Unbounded_String; + + function "&" + (Left : Unbounded_String; + Right : Character) return Unbounded_String; + + function "&" + (Left : Character; + Right : Unbounded_String) return Unbounded_String; + + function Element + (Source : Unbounded_String; + Index : Positive) return Character; + + procedure Replace_Element + (Source : in out Unbounded_String; + Index : Positive; + By : Character); + + function Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return String; + + function Unbounded_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural) return Unbounded_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_String; + Target : out Unbounded_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<" + (Left : String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function "<=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function "<=" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">" + (Left : String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : Unbounded_String) return Boolean; + + function ">=" + (Left : Unbounded_String; + Right : String) return Boolean; + + function ">=" + (Left : String; + Right : Unbounded_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Pattern : String; + From : Positive; + Going : Direction := Forward; + Mapping : Maps.Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping := Maps.Identity) return Natural; + + function Count + (Source : Unbounded_String; + Pattern : String; + Mapping : Maps.Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_String; + Set : Maps.Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_String; + Set : Maps.Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping); + + function Translate + (Source : Unbounded_String; + Mapping : Maps.Character_Mapping_Function) return Unbounded_String; + + procedure Translate + (Source : in out Unbounded_String; + Mapping : Maps.Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_String; + Low : Positive; + High : Natural; + By : String) return Unbounded_String; + + procedure Replace_Slice + (Source : in out Unbounded_String; + Low : Positive; + High : Natural; + By : String); + + function Insert + (Source : Unbounded_String; + Before : Positive; + New_Item : String) return Unbounded_String; + + procedure Insert + (Source : in out Unbounded_String; + Before : Positive; + New_Item : String); + + function Overwrite + (Source : Unbounded_String; + Position : Positive; + New_Item : String) return Unbounded_String; + + procedure Overwrite + (Source : in out Unbounded_String; + Position : Positive; + New_Item : String); + + function Delete + (Source : Unbounded_String; + From : Positive; + Through : Natural) return Unbounded_String; + + procedure Delete + (Source : in out Unbounded_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_String; + Side : Trim_End) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set) return Unbounded_String; + + procedure Trim + (Source : in out Unbounded_String; + Left : Maps.Character_Set; + Right : Maps.Character_Set); + + function Head + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Head + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function Tail + (Source : Unbounded_String; + Count : Natural; + Pad : Character := Space) return Unbounded_String; + + procedure Tail + (Source : in out Unbounded_String; + Count : Natural; + Pad : Character := Space); + + function "*" + (Left : Natural; + Right : Character) return Unbounded_String; + + function "*" + (Left : Natural; + Right : String) return Unbounded_String; + + function "*" + (Left : Natural; + Right : Unbounded_String) return Unbounded_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + Null_String : aliased String := ""; + + function To_Unbounded (S : String) return Unbounded_String + renames To_Unbounded_String; + + type Unbounded_String is new AF.Controlled with record + Reference : String_Access := Null_String'Access; + Last : Natural := 0; + end record; + -- The Unbounded_String is using a buffered implementation to increase + -- speed of the Append/Delete/Insert procedures. The Reference string + -- pointer above contains the current string value and extra room at the + -- end to be used by the next Append routine. Last is the index of the + -- string ending character. So the current string value is really + -- Reference (1 .. Last). + + pragma Stream_Convert (Unbounded_String, To_Unbounded, To_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_String); + -- Finalization is required only for freeing storage + + procedure Initialize (Object : in out Unbounded_String); + procedure Adjust (Object : in out Unbounded_String); + procedure Finalize (Object : in out Unbounded_String); + + procedure Realloc_For_Chunk + (Source : in out Unbounded_String; + Chunk_Size : Natural); + pragma Inline (Realloc_For_Chunk); + -- Adjust the size allocated for the string. Add at least Chunk_Size so it + -- is safe to add a string of this size at the end of the current content. + -- The real size allocated for the string is Chunk_Size + x of the current + -- string size. This buffered handling makes the Append unbounded string + -- routines very fast. This spec is in the private part so that it can be + -- accessed from children (e.g. from Unbounded.Text_IO). + + Null_Unbounded_String : constant Unbounded_String := + (AF.Controlled with + Reference => Null_String'Access, + Last => 0); +end Ada.Strings.Unbounded; diff --git a/gcc/ada/libgnat/a-ststio.adb b/gcc/ada/libgnat/a-ststio.adb new file mode 100644 index 0000000..ddc78c9 --- /dev/null +++ b/gcc/ada/libgnat/a-ststio.adb @@ -0,0 +1,490 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S . S T R E A M _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System; use System; +with System.Communication; use System.Communication; +with System.File_IO; +with System.Soft_Links; +with System.CRTL; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body Ada.Streams.Stream_IO is + + package FIO renames System.File_IO; + package SSL renames System.Soft_Links; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_SIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + use type FCB.Shared_Status_Type; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set_Position (File : File_Type); + -- Sets file position pointer according to value of current index + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr is + pragma Warnings (Off, Control_Block); + begin + return new Stream_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + -- No special processing required for closing Stream_IO file + + procedure AFCB_Close (File : not null access Stream_AFCB) is + pragma Warnings (Off, File); + begin + null; + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Stream_AFCB) is + type FCB_Ptr is access all Stream_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new Ada.Unchecked_Deallocation (Stream_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Stream_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'S', + Creat => True, + Text => False); + File.Last_Op := Op_Write; + end Create; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + begin + FIO.Check_Read_Status (AP (File)); + return File.Index > Size (File); + end End_Of_File; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + ----------- + -- Index -- + ----------- + + function Index (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Index; + end Index; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_SIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Stream_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'S', + Creat => False, + Text => False); + + -- Ensure that the stream index is set properly (e.g., for Append_File) + + Reset (File, Mode); + + -- Set last operation. The purpose here is to ensure proper handling + -- of the initial operation. In general, a write after a read requires + -- resetting and doing a seek, so we set the last operation as Read + -- for an In_Out file, but for an Out file we set the last operation + -- to Op_Write, since in this case it is not necessary to do a seek + -- (and furthermore there are situations (such as the case of writing + -- a sequential Posix FIFO file) where the lseek would cause problems. + + File.Last_Op := (if Mode = Out_File then Op_Write else Op_Read); + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset; + From : Positive_Count) + is + begin + Set_Index (File, From); + Read (File, Item, Last); + end Read; + + procedure Read + (File : File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Nread : size_t; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If last operation was not a read, or if in file sharing mode, + -- then reset the physical pointer of the file to match the index + -- We lock out task access over the two operations in this case. + + if File.Last_Op /= Op_Read + or else File.Shared_Status = FCB.Yes + then + Locked_Processing : begin + SSL.Lock_Task.all; + Set_Position (File); + FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + else + FIO.Read_Buf (AP (File), Item'Address, Item'Length, Nread); + end if; + + File.Index := File.Index + Count (Nread); + File.Last_Op := Op_Read; + Last := Last_Index (Item'First, Nread); + end Read; + + -- This version of Read is the primitive operation on the underlying + -- Stream type, used when a Stream_IO file is treated as a Stream + + procedure Read + (File : in out Stream_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + Read (File'Unchecked_Access, Item, Last); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : File_Mode) is + begin + FIO.Check_File_Open (AP (File)); + + -- Reset file index to start of file for read/write cases. For + -- the append case, the Set_Mode call repositions the index. + + File.Index := 1; + Set_Mode (File, Mode); + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Reset (File, To_SIO (File.Mode)); + end Reset; + + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index (File : File_Type; To : Positive_Count) is + begin + FIO.Check_File_Open (AP (File)); + File.Index := Count (To); + File.Last_Op := Op_Other; + end Set_Index; + + -------------- + -- Set_Mode -- + -------------- + + procedure Set_Mode (File : in out File_Type; Mode : File_Mode) is + begin + FIO.Check_File_Open (AP (File)); + + -- If we are switching from read to write, or vice versa, and + -- we are not already open in update mode, then reopen in update + -- mode now. Note that we can use Inout_File as the mode for the + -- call since File_IO handles all modes for all file types. + + if ((File.Mode = FCB.In_File) /= (Mode = In_File)) + and then not File.Update_Mode + then + FIO.Reset (AP (File)'Unrestricted_Access, FCB.Inout_File); + File.Update_Mode := True; + end if; + + -- Set required mode and position to end of file if append mode + + File.Mode := To_FCB (Mode); + FIO.Append_Set (AP (File)); + + if File.Mode = FCB.Append_File then + if Standard'Address_Size = 64 then + File.Index := Count (ftell64 (File.Stream)) + 1; + else + File.Index := Count (ftell (File.Stream)) + 1; + end if; + end if; + + File.Last_Op := Op_Other; + end Set_Mode; + + ------------------ + -- Set_Position -- + ------------------ + + procedure Set_Position (File : File_Type) is + use type System.CRTL.int64; + R : int; + begin + R := fseek64 (File.Stream, System.CRTL.int64 (File.Index) - 1, SEEK_SET); + + if R /= 0 then + raise Use_Error; + end if; + end Set_Position; + + ---------- + -- Size -- + ---------- + + function Size (File : File_Type) return Count is + begin + FIO.Check_File_Open (AP (File)); + + if File.File_Size = -1 then + File.Last_Op := Op_Other; + + if fseek64 (File.Stream, 0, SEEK_END) /= 0 then + raise Device_Error; + end if; + + File.File_Size := Stream_Element_Offset (ftell64 (File.Stream)); + + if File.File_Size = -1 then + raise Use_Error; + end if; + end if; + + return Count (File.File_Size); + end Size; + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + FIO.Check_File_Open (AP (File)); + return Stream_Access (File); + end Stream; + + ----------- + -- Write -- + ----------- + + procedure Write + (File : File_Type; + Item : Stream_Element_Array; + To : Positive_Count) + is + begin + Set_Index (File, To); + Write (File, Item); + end Write; + + procedure Write + (File : File_Type; + Item : Stream_Element_Array) + is + begin + FIO.Check_Write_Status (AP (File)); + + -- If last operation was not a write, or if in file sharing mode, + -- then reset the physical pointer of the file to match the index + -- We lock out task access over the two operations in this case. + + if File.Last_Op /= Op_Write + or else File.Shared_Status = FCB.Yes + then + Locked_Processing : begin + SSL.Lock_Task.all; + Set_Position (File); + FIO.Write_Buf (AP (File), Item'Address, Item'Length); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + else + FIO.Write_Buf (AP (File), Item'Address, Item'Length); + end if; + + File.Index := File.Index + Item'Length; + File.Last_Op := Op_Write; + File.File_Size := -1; + end Write; + + -- This version of Write is the primitive operation on the underlying + -- Stream type, used when a Stream_IO file is treated as a Stream + + procedure Write + (File : in out Stream_AFCB; + Item : Ada.Streams.Stream_Element_Array) + is + begin + Write (File'Unchecked_Access, Item); + end Write; + +end Ada.Streams.Stream_IO; diff --git a/gcc/ada/libgnat/a-ststio.ads b/gcc/ada/libgnat/a-ststio.ads new file mode 100644 index 0000000..efcb5fc --- /dev/null +++ b/gcc/ada/libgnat/a-ststio.ads @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R E A M S . S T R E A M _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System.File_Control_Block; + +package Ada.Streams.Stream_IO is + pragma Preelaborate; + + type Stream_Access is access all Root_Stream_Type'Class; + + type File_Type is limited private; + + type File_Mode is (In_File, Out_File, Append_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.File_IO.File_Mode'Pos (In_File) + Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) + Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) + + type Count is new Stream_Element_Offset + range 0 .. Stream_Element_Offset'Last; + + subtype Positive_Count is Count range 1 .. Count'Last; + -- Index into file, in stream elements + + --------------------- + -- File Management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : File_Type) return File_Mode; + function Name (File : File_Type) return String; + function Form (File : File_Type) return String; + + function Is_Open (File : File_Type) return Boolean; + function End_Of_File (File : File_Type) return Boolean; + + function Stream (File : File_Type) return Stream_Access; + + ----------------------------- + -- Input-Output Operations -- + ----------------------------- + + procedure Read + (File : File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset; + From : Positive_Count); + + procedure Read + (File : File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + + procedure Write + (File : File_Type; + Item : Stream_Element_Array; + To : Positive_Count); + + procedure Write + (File : File_Type; + Item : Stream_Element_Array); + + ---------------------------------------- + -- Operations on Position within File -- + ---------------------------------------- + + procedure Set_Index (File : File_Type; To : Positive_Count); + + function Index (File : File_Type) return Positive_Count; + function Size (File : File_Type) return Count; + + procedure Set_Mode (File : in out File_Type; Mode : File_Mode); + + -- Note: The parameter file is IN OUT in the RM, but this is clearly + -- an oversight, and was intended to be IN, see AI95-00057. + + procedure Flush (File : File_Type); + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + +private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + pragma Export_Procedure + (Internal => Set_Mode, + External => "", + Mechanism => (File => Reference)); + + package FCB renames System.File_Control_Block; + + ----------------------------- + -- Stream_IO Control Block -- + ----------------------------- + + type Operation is (Op_Read, Op_Write, Op_Other); + -- Type used to record last operation (to optimize sequential operations) + + type Stream_AFCB is new FCB.AFCB with record + Index : Count := 1; + -- Current Index value + + File_Size : Stream_Element_Offset := -1; + -- Cached value of File_Size, so that we do not keep recomputing it + -- when not necessary (otherwise End_Of_File becomes gruesomely slow). + -- A value of minus one means that there is no cached value. + + Last_Op : Operation := Op_Other; + -- Last operation performed on file, used to avoid unnecessary + -- repositioning between successive read or write operations. + + Update_Mode : Boolean := False; + -- Set if the mode is changed from write to read or vice versa. + -- Indicates that the file has been reopened in update mode. + + end record; + + type File_Type is access all Stream_AFCB; + + overriding function AFCB_Allocate + (Control_Block : Stream_AFCB) return FCB.AFCB_Ptr; + + overriding procedure AFCB_Close (File : not null access Stream_AFCB); + overriding procedure AFCB_Free (File : not null access Stream_AFCB); + + overriding procedure Read + (File : in out Stream_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read operation used when Stream_IO file is treated directly as Stream + + overriding procedure Write + (File : in out Stream_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Write operation used when Stream_IO file is treated directly as Stream + +end Ada.Streams.Stream_IO; diff --git a/gcc/ada/libgnat/a-stunau-shared.adb b/gcc/ada/libgnat/a-stunau-shared.adb new file mode 100644 index 0000000..583deed --- /dev/null +++ b/gcc/ada/libgnat/a-stunau-shared.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Unbounded.Aux is + + ---------------- + -- Get_String -- + ---------------- + + procedure Get_String + (U : Unbounded_String; + S : out Big_String_Access; + L : out Natural) + is + X : aliased Big_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_String; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String (UP : in out Unbounded_String; S : String_Access) is + X : String_Access := S; + + begin + Set_Unbounded_String (UP, S.all); + Free (X); + end Set_String; + +end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-stunau.adb b/gcc/ada/libgnat/a-stunau.adb new file mode 100644 index 0000000..a2501ac --- /dev/null +++ b/gcc/ada/libgnat/a-stunau.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Unbounded.Aux is + + ---------------- + -- Get_String -- + ---------------- + + procedure Get_String + (U : Unbounded_String; + S : out Big_String_Access; + L : out Natural) + is + X : aliased Big_String; + for X'Address use U.Reference.all'Address; + + begin + S := X'Unchecked_Access; + L := U.Last; + end Get_String; + + ---------------- + -- Set_String -- + ---------------- + + procedure Set_String (UP : in out Unbounded_String; S : String_Access) is + begin + Finalize (UP); + UP.Reference := S; + UP.Last := UP.Reference'Length; + end Set_String; + +end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-stunau.ads b/gcc/ada/libgnat/a-stunau.ads new file mode 100644 index 0000000..90b7505 --- /dev/null +++ b/gcc/ada/libgnat/a-stunau.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Unbounded provides some specialized +-- access functions which are intended to allow more efficient use of the +-- facilities of Ada.Strings.Unbounded, particularly by other layered +-- utilities (such as GNAT.SPITBOL.Patterns). + +package Ada.Strings.Unbounded.Aux is + pragma Preelaborate; + + subtype Big_String is String (1 .. Positive'Last); + pragma Suppress_Initialization (Big_String); + -- Type used to obtain string access to given address. Initialization is + -- suppressed, since we never want to have variables of this type, and + -- we never want to attempt initialiazation of virtual variables of this + -- type (e.g. when pragma Normalize_Scalars is used). + + type Big_String_Access is access all Big_String; + for Big_String_Access'Storage_Size use 0; + -- We use this access type to pass a pointer to an area of storage to be + -- accessed as a string. Of course when this pointer is used, it is the + -- responsibility of the accessor to ensure proper bounds. The storage + -- size clause ensures we do not allocate variables of this type. + + procedure Get_String + (U : Unbounded_String; + S : out Big_String_Access; + L : out Natural); + pragma Inline (Get_String); + -- This procedure returns the internal string pointer used in the + -- representation of an unbounded string as well as the actual current + -- length (which may be less than S.all'Length because in general there + -- can be extra space assigned). The characters of this string may be + -- not be modified via the returned pointer, and are valid only as + -- long as the original unbounded string is not accessed or modified. + -- + -- This procedure is much more efficient than the use of To_String + -- since it avoids the need to copy the string. The lower bound of the + -- referenced string returned by this call is always one, so the actual + -- string data is always accessible as S (1 .. L). + + procedure Set_String (UP : in out Unbounded_String; S : String_Access); + pragma Inline (Set_String); + -- This version of Set_Unbounded_String takes a string access value, rather + -- than a string. The lower bound of the string value is required to be + -- one, and this requirement is not checked. + +end Ada.Strings.Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-stunha.adb b/gcc/ada/libgnat/a-stunha.adb new file mode 100644 index 0000000..a8626fc --- /dev/null +++ b/gcc/ada/libgnat/a-stunha.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Unbounded.Hash + (Key : Unbounded_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Character, String, Hash_Type); +begin + return Hash (To_String (Key)); +end Ada.Strings.Unbounded.Hash; diff --git a/gcc/ada/libgnat/a-stunha.ads b/gcc/ada/libgnat/a-stunha.ads new file mode 100644 index 0000000..1e45bdb --- /dev/null +++ b/gcc/ada/libgnat/a-stunha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Unbounded.Hash + (Key : Unbounded_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Unbounded.Hash); diff --git a/gcc/ada/libgnat/a-stuten.adb b/gcc/ada/libgnat/a-stuten.adb new file mode 100644 index 0000000..02a1115 --- /dev/null +++ b/gcc/ada/libgnat/a-stuten.adb @@ -0,0 +1,209 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U T F _ E N C O D I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding is + use Interfaces; + + -------------- + -- Encoding -- + -------------- + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme + is + begin + if Item'Length >= 2 then + if Item (Item'First .. Item'First + 1) = BOM_16BE then + return UTF_16BE; + + elsif Item (Item'First .. Item'First + 1) = BOM_16LE then + return UTF_16LE; + + elsif Item'Length >= 3 + and then Item (Item'First .. Item'First + 2) = BOM_8 + then + return UTF_8; + end if; + end if; + + return Default; + end Encoding; + + ----------------- + -- From_UTF_16 -- + ----------------- + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String + is + BSpace : constant Natural := 2 * Boolean'Pos (Output_BOM); + Result : UTF_String (1 .. 2 * Item'Length + BSpace); + Len : Natural; + C : Unsigned_16; + Iptr : Natural; + + begin + if Output_BOM then + Result (1 .. 2) := + (if Output_Scheme = UTF_16BE then BOM_16BE else BOM_16LE); + Len := 2; + else + Len := 0; + end if; + + -- Skip input BOM + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- UTF-16BE case + + if Output_Scheme = UTF_16BE then + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (Shift_Right (C, 8)); + Result (Len + 2) := Character'Val (C and 16#00_FF#); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + + -- UTF-16LE case + + else + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Result (Len + 1) := Character'Val (C and 16#00_FF#); + Result (Len + 2) := Character'Val (Shift_Right (C, 8)); + Len := Len + 2; + Iptr := Iptr + 1; + end loop; + end if; + + return Result (1 .. Len); + end From_UTF_16; + + -------------------------- + -- Raise_Encoding_Error -- + -------------------------- + + procedure Raise_Encoding_Error (Index : Natural) is + Val : constant String := Index'Img; + begin + raise Encoding_Error with + "bad input at Item (" & Val (Val'First + 1 .. Val'Last) & ')'; + end Raise_Encoding_Error; + + --------------- + -- To_UTF_16 -- + --------------- + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length / 2 + 1); + Len : Natural; + Iptr : Natural; + + begin + if Item'Length mod 2 /= 0 then + raise Encoding_Error with "UTF-16BE/LE string has odd length"; + end if; + + -- Deal with input BOM, skip if OK, error if bad BOM + + Iptr := Item'First; + + if Item'Length >= 2 then + if Item (Iptr .. Iptr + 1) = BOM_16BE then + if Input_Scheme = UTF_16BE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item (Iptr .. Iptr + 1) = BOM_16LE then + if Input_Scheme = UTF_16LE then + Iptr := Iptr + 2; + else + Raise_Encoding_Error (Iptr); + end if; + + elsif Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Raise_Encoding_Error (Iptr); + end if; + end if; + + -- Output BOM if specified + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- UTF-16BE case + + if Input_Scheme = UTF_16BE then + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) * 256 + + Character'Pos (Item (Iptr + 1))); + Iptr := Iptr + 2; + end loop; + + -- UTF-16LE case + + else + while Iptr < Item'Last loop + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (Character'Pos (Item (Iptr)) + + Character'Pos (Item (Iptr + 1)) * 256); + Iptr := Iptr + 2; + end loop; + end if; + + return Result (1 .. Len); + end To_UTF_16; + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/libgnat/a-stuten.ads b/gcc/ada/libgnat/a-stuten.ads new file mode 100644 index 0000000..fba30df --- /dev/null +++ b/gcc/ada/libgnat/a-stuten.ads @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U T F _ E N C O D I N G -- +-- -- +-- S p e c -- +-- -- +-- 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is one of the Ada 2012 package defined in AI05-0137-1. It is a parent +-- package that contains declarations used in the child packages for handling +-- UTF encoded strings. Note: this package is consistent with Ada 95, and may +-- be used in Ada 95 or Ada 2005 mode. + +with Interfaces; +with Unchecked_Conversion; + +package Ada.Strings.UTF_Encoding is + pragma Pure (UTF_Encoding); + + subtype UTF_String is String; + -- Used to represent a string of 8-bit values containing a sequence of + -- values encoded in one of three ways (UTF-8, UTF-16BE, or UTF-16LE). + -- Typically used in connection with a Scheme parameter indicating which + -- of the encodings applies. This is not strictly a String value in the + -- sense defined in the Ada RM, but in practice type String accommodates + -- all possible 256 codes, and can be used to hold any sequence of 8-bit + -- codes. We use String directly rather than create a new type so that + -- all existing facilities for manipulating type String (e.g. the child + -- packages of Ada.Strings) are available for manipulation of UTF_Strings. + + type Encoding_Scheme is (UTF_8, UTF_16BE, UTF_16LE); + -- Used to specify which of three possible encodings apply to a UTF_String + + subtype UTF_8_String is String; + -- Similar to UTF_String but specifically represents a UTF-8 encoded string + + subtype UTF_16_Wide_String is Wide_String; + -- This is similar to UTF_8_String but is used to represent a Wide_String + -- value which is a sequence of 16-bit values encoded using UTF-16. Again + -- this is not strictly a Wide_String in the sense of the Ada RM, but the + -- type Wide_String can be used to represent a sequence of arbitrary 16-bit + -- values, and it is more convenient to use Wide_String than a new type. + + Encoding_Error : exception; + -- This exception is raised in the following situations: + -- a) A UTF encoded string contains an invalid encoding sequence + -- b) A UTF-16BE or UTF-16LE input string has an odd length + -- c) An incorrect character value is present in the Input string + -- d) The result for a Wide_Character output exceeds 16#FFFF# + -- The exception message has the index value where the error occurred. + + -- The BOM (BYTE_ORDER_MARK) values defined here are used at the start of + -- a string to indicate the encoding. The convention in this package is + -- that on input a correct BOM is ignored and an incorrect BOM causes an + -- Encoding_Error exception. On output, the output string may or may not + -- include a BOM depending on the setting of Output_BOM. + + BOM_8 : constant UTF_8_String := + Character'Val (16#EF#) & + Character'Val (16#BB#) & + Character'Val (16#BF#); + + BOM_16BE : constant UTF_String := + Character'Val (16#FE#) & + Character'Val (16#FF#); + + BOM_16LE : constant UTF_String := + Character'Val (16#FF#) & + Character'Val (16#FE#); + + BOM_16 : constant UTF_16_Wide_String := + (1 => Wide_Character'Val (16#FEFF#)); + + function Encoding + (Item : UTF_String; + Default : Encoding_Scheme := UTF_8) return Encoding_Scheme; + -- This function inspects a UTF_String value to determine whether it + -- starts with a BOM for UTF-8, UTF-16BE, or UTF_16LE. If so, the result + -- is the scheme corresponding to the BOM. If no valid BOM is present + -- then the result is the specified Default value. + +private + function To_Unsigned_8 is new + Unchecked_Conversion (Character, Interfaces.Unsigned_8); + + function To_Unsigned_16 is new + Unchecked_Conversion (Wide_Character, Interfaces.Unsigned_16); + + function To_Unsigned_32 is new + Unchecked_Conversion (Wide_Wide_Character, Interfaces.Unsigned_32); + + subtype UTF_XE_Encoding is Encoding_Scheme range UTF_16BE .. UTF_16LE; + -- Subtype containing only UTF_16BE and UTF_16LE entries + + -- Utility routines for converting between UTF-16 and UTF-16LE/BE + + function From_UTF_16 + (Item : UTF_16_Wide_String; + Output_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_String; + -- The input string Item is encoded in UTF-16. The output is encoded using + -- Output_Scheme (which is either UTF-16LE or UTF-16BE). There are no error + -- cases. The output starts with BOM_16BE/LE if Output_BOM is True. + + function To_UTF_16 + (Item : UTF_String; + Input_Scheme : UTF_XE_Encoding; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- The input string Item is encoded using Input_Scheme which is either + -- UTF-16LE or UTF-16BE. The output is the corresponding UTF_16 wide + -- string. Encoding error is raised if the length of the input is odd. + -- The output starts with BOM_16 if Output_BOM is True. + + procedure Raise_Encoding_Error (Index : Natural); + pragma No_Return (Raise_Encoding_Error); + -- Raise Encoding_Error exception for bad encoding in input item. The + -- parameter Index is the index of the location in Item for the error. + +end Ada.Strings.UTF_Encoding; diff --git a/gcc/ada/libgnat/a-stwibo.adb b/gcc/ada/libgnat/a-stwibo.adb new file mode 100644 index 0000000..0a68d8c --- /dev/null +++ b/gcc/ada/libgnat/a-stwibo.adb @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Bounded is + + package body Generic_Bounded_Length is + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Bounded_Wide_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Bounded_Wide_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + --------------- + -- Replicate -- + --------------- + + function Replicate + (Count : Natural; + Item : Wide_Character; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + function Replicate + (Count : Natural; + Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + ---------------------------- + -- To_Bounded_Wide_String -- + ---------------------------- + + function To_Bounded_Wide_String + (Source : Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_String + is + begin + return To_Super_String (Source, Max_Length, Drop); + end To_Bounded_Wide_String; + + end Generic_Bounded_Length; +end Ada.Strings.Wide_Bounded; diff --git a/gcc/ada/libgnat/a-stwibo.ads b/gcc/ada/libgnat/a-stwibo.ads new file mode 100644 index 0000000..5efce28 --- /dev/null +++ b/gcc/ada/libgnat/a-stwibo.ads @@ -0,0 +1,921 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Superbounded; + +package Ada.Strings.Wide_Bounded is + pragma Preelaborate; + + generic + Max : Positive; + -- Maximum length of a Bounded_Wide_String + + package Generic_Bounded_Length is + + Max_Length : constant Positive := Max; + + type Bounded_Wide_String is private; + pragma Preelaborable_Initialization (Bounded_Wide_String); + + Null_Bounded_Wide_String : constant Bounded_Wide_String; + + subtype Length_Range is Natural range 0 .. Max_Length; + + function Length (Source : Bounded_Wide_String) return Length_Range; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Bounded_Wide_String + (Source : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + function To_Wide_String + (Source : Bounded_Wide_String) return Wide_String; + + procedure Set_Bounded_Wide_String + (Target : out Bounded_Wide_String; + Source : Wide_String; + Drop : Truncation := Error); + pragma Ada_05 (Set_Bounded_Wide_String); + + function Append + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + function Append + (Left : Bounded_Wide_String; + Right : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + function Append + (Left : Wide_String; + Right : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + function Append + (Left : Bounded_Wide_String; + Right : Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_String; + + function Append + (Left : Wide_Character; + Right : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + procedure Append + (Source : in out Bounded_Wide_String; + New_Item : Bounded_Wide_String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_Wide_String; + New_Item : Wide_String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_Wide_String; + New_Item : Wide_Character; + Drop : Truncation := Error); + + function "&" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Bounded_Wide_String; + + function "&" + (Left : Bounded_Wide_String; + Right : Wide_String) return Bounded_Wide_String; + + function "&" + (Left : Wide_String; + Right : Bounded_Wide_String) return Bounded_Wide_String; + + function "&" + (Left : Bounded_Wide_String; + Right : Wide_Character) return Bounded_Wide_String; + + function "&" + (Left : Wide_Character; + Right : Bounded_Wide_String) return Bounded_Wide_String; + + function Element + (Source : Bounded_Wide_String; + Index : Positive) return Wide_Character; + + procedure Replace_Element + (Source : in out Bounded_Wide_String; + Index : Positive; + By : Wide_Character); + + function Slice + (Source : Bounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String; + + function Bounded_Slice + (Source : Bounded_Wide_String; + Low : Positive; + High : Natural) return Bounded_Wide_String; + pragma Ada_05 (Bounded_Slice); + + procedure Bounded_Slice + (Source : Bounded_Wide_String; + Target : out Bounded_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Bounded_Slice); + + function "=" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function "=" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean; + + function "=" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function "<" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function "<" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function "<=" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function "<=" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<=" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function ">" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function ">" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function ">=" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean; + + function ">=" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">=" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Bounded_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Bounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Bounded_Wide_String; + + procedure Translate + (Source : in out Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Bounded_Wide_String; + + procedure Translate + (Source : in out Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Bounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + procedure Replace_Slice + (Source : in out Bounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error); + + function Insert + (Source : Bounded_Wide_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + procedure Insert + (Source : in out Bounded_Wide_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Bounded_Wide_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + procedure Overwrite + (Source : in out Bounded_Wide_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Delete + (Source : Bounded_Wide_String; + From : Positive; + Through : Natural) return Bounded_Wide_String; + + procedure Delete + (Source : in out Bounded_Wide_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Trim + (Source : Bounded_Wide_String; + Side : Trim_End) return Bounded_Wide_String; + + procedure Trim + (Source : in out Bounded_Wide_String; + Side : Trim_End); + + function Trim + (Source : Bounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Bounded_Wide_String; + + procedure Trim + (Source : in out Bounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Head + (Source : Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_String; + + procedure Head + (Source : in out Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error); + + function Tail + (Source : Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_String; + + procedure Tail + (Source : in out Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + function "*" + (Left : Natural; + Right : Wide_Character) return Bounded_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Bounded_Wide_String; + + function "*" + (Left : Natural; + Right : Bounded_Wide_String) return Bounded_Wide_String; + + function Replicate + (Count : Natural; + Item : Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_String; + + function Replicate + (Count : Natural; + Item : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + function Replicate + (Count : Natural; + Item : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String; + + private + -- Most of the implementation is in the separate non generic package + -- Ada.Strings.Wide_Superbounded. Type Bounded_Wide_String is derived + -- from type Wide_Superbounded.Super_String with the maximum length + -- constraint. In almost all cases, the routines in Wide_Superbounded + -- can be called with no requirement to pass the maximum length + -- explicitly, since there is at least one Bounded_Wide_String argument + -- from which the maximum length can be obtained. For all such + -- routines, the implementation in this private part is simply a + -- renaming of the corresponding routine in the super bouded package. + + -- The five exceptions are the * and Replicate routines operating on + -- character values. For these cases, we have a routine in the body + -- that calls the superbounded routine passing the maximum length + -- explicitly as an extra parameter. + + type Bounded_Wide_String is + new Wide_Superbounded.Super_String (Max_Length); + -- Deriving Bounded_Wide_String from Wide_Superbounded.Super_String is + -- the real trick, it ensures that the type Bounded_Wide_String + -- declared in the generic instantiation is compatible with the + -- Super_String type declared in the Wide_Superbounded package. + + Null_Bounded_Wide_String : constant Bounded_Wide_String := + (Max_Length => Max_Length, + Current_Length => 0, + Data => + (1 .. Max_Length => + Wide_Superbounded.Wide_NUL)); + + pragma Inline (To_Bounded_Wide_String); + + procedure Set_Bounded_Wide_String + (Target : out Bounded_Wide_String; + Source : Wide_String; + Drop : Truncation := Error) + renames Set_Super_String; + + function Length + (Source : Bounded_Wide_String) return Length_Range + renames Super_Length; + + function To_Wide_String + (Source : Bounded_Wide_String) return Wide_String + renames Super_To_String; + + function Append + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Append; + + function Append + (Left : Bounded_Wide_String; + Right : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Append; + + function Append + (Left : Wide_String; + Right : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Append; + + function Append + (Left : Bounded_Wide_String; + Right : Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Append; + + function Append + (Left : Wide_Character; + Right : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_String; + New_Item : Bounded_Wide_String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_String; + New_Item : Wide_String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_String; + New_Item : Wide_Character; + Drop : Truncation := Error) + renames Super_Append; + + function "&" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Bounded_Wide_String + renames Concat; + + function "&" + (Left : Bounded_Wide_String; + Right : Wide_String) return Bounded_Wide_String + renames Concat; + + function "&" + (Left : Wide_String; + Right : Bounded_Wide_String) return Bounded_Wide_String + renames Concat; + + function "&" + (Left : Bounded_Wide_String; + Right : Wide_Character) return Bounded_Wide_String + renames Concat; + + function "&" + (Left : Wide_Character; + Right : Bounded_Wide_String) return Bounded_Wide_String + renames Concat; + + function Element + (Source : Bounded_Wide_String; + Index : Positive) return Wide_Character + renames Super_Element; + + procedure Replace_Element + (Source : in out Bounded_Wide_String; + Index : Positive; + By : Wide_Character) + renames Super_Replace_Element; + + function Slice + (Source : Bounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String + renames Super_Slice; + + function Bounded_Slice + (Source : Bounded_Wide_String; + Low : Positive; + High : Natural) return Bounded_Wide_String + renames Super_Slice; + + procedure Bounded_Slice + (Source : Bounded_Wide_String; + Target : out Bounded_Wide_String; + Low : Positive; + High : Natural) + renames Super_Slice; + + overriding function "=" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Equal; + + function "=" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean + renames Equal; + + function "=" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Equal; + + function "<" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Less; + + function "<" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean + renames Less; + + function "<" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Less; + + function "<=" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Less_Or_Equal; + + function ">" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Greater; + + function ">" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean + renames Greater; + + function ">" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Greater; + + function ">=" + (Left : Bounded_Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : Bounded_Wide_String; + Right : Wide_String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : Wide_String; + Right : Bounded_Wide_String) return Boolean + renames Greater_Or_Equal; + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index_Non_Blank + (Source : Bounded_Wide_String; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Index_Non_Blank + (Source : Bounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Count + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + renames Super_Count; + + function Count + (Source : Bounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + renames Super_Count; + + function Count + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + renames Super_Count; + + procedure Find_Token + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Super_Find_Token; + + procedure Find_Token + (Source : Bounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Super_Find_Token; + + function Translate + (Source : Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Bounded_Wide_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + renames Super_Translate; + + function Translate + (Source : Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Bounded_Wide_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + renames Super_Translate; + + function Replace_Slice + (Source : Bounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Replace_Slice; + + procedure Replace_Slice + (Source : in out Bounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error) + renames Super_Replace_Slice; + + function Insert + (Source : Bounded_Wide_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Insert; + + procedure Insert + (Source : in out Bounded_Wide_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) + renames Super_Insert; + + function Overwrite + (Source : Bounded_Wide_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Overwrite; + + procedure Overwrite + (Source : in out Bounded_Wide_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) + renames Super_Overwrite; + + function Delete + (Source : Bounded_Wide_String; + From : Positive; + Through : Natural) return Bounded_Wide_String + renames Super_Delete; + + procedure Delete + (Source : in out Bounded_Wide_String; + From : Positive; + Through : Natural) + renames Super_Delete; + + function Trim + (Source : Bounded_Wide_String; + Side : Trim_End) return Bounded_Wide_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_Wide_String; + Side : Trim_End) + renames Super_Trim; + + function Trim + (Source : Bounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Bounded_Wide_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + renames Super_Trim; + + function Head + (Source : Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Head; + + procedure Head + (Source : in out Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + renames Super_Head; + + function Tail + (Source : Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Tail; + + procedure Tail + (Source : in out Bounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + renames Super_Tail; + + function "*" + (Left : Natural; + Right : Bounded_Wide_String) return Bounded_Wide_String + renames Times; + + function Replicate + (Count : Natural; + Item : Bounded_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_String + renames Super_Replicate; + + end Generic_Bounded_Length; + +end Ada.Strings.Wide_Bounded; diff --git a/gcc/ada/libgnat/a-stwifi.adb b/gcc/ada/libgnat/a-stwifi.adb new file mode 100644 index 0000000..6a7c2fa --- /dev/null +++ b/gcc/ada/libgnat/a-stwifi.adb @@ -0,0 +1,688 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ F I X E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Search; + +package body Ada.Strings.Wide_Fixed is + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Search.Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + renames Ada.Strings.Wide_Search.Index; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Search.Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Search.Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + renames Ada.Strings.Wide_Search.Index; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Search.Index; + + function Index_Non_Blank + (Source : Wide_String; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Search.Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Search.Index_Non_Blank; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Search.Count; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + renames Ada.Strings.Wide_Search.Count; + + function Count + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + renames Ada.Strings.Wide_Search.Count; + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Wide_Search.Find_Token; + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Wide_Search.Find_Token; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Wide_String + is + Result : Wide_String (1 .. Left); + + begin + for J in Result'Range loop + Result (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Wide_String + is + Result : Wide_String (1 .. Left * Right'Length); + Ptr : Integer := 1; + + begin + for J in 1 .. Left loop + Result (Ptr .. Ptr + Right'Length - 1) := Right; + Ptr := Ptr + Right'Length; + end loop; + + return Result; + end "*"; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Wide_String; + From : Positive; + Through : Natural) return Wide_String + is + begin + if From not in Source'Range + or else Through > Source'Last + then + raise Index_Error; + + elsif From > Through then + return Source; + + else + declare + Len : constant Integer := Source'Length - (Through - From + 1); + Result : constant + Wide_String (Source'First .. Source'First + Len - 1) := + Source (Source'First .. From - 1) & + Source (Through + 1 .. Source'Last); + begin + return Result; + end; + end if; + end Delete; + + procedure Delete + (Source : in out Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space) + is + begin + Move (Source => Delete (Source, From, Through), + Target => Source, + Justify => Justify, + Pad => Pad); + end Delete; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Wide_String + is + Result : Wide_String (1 .. Count); + + begin + if Count <= Source'Length then + Result := Source (Source'First .. Source'First + Count - 1); + + else + Result (1 .. Source'Length) := Source; + + for J in Source'Length + 1 .. Count loop + Result (J) := Pad; + end loop; + end if; + + return Result; + end Head; + + procedure Head + (Source : in out Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space) + is + begin + Move (Source => Head (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Head; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Wide_String; + Before : Positive; + New_Item : Wide_String) return Wide_String + is + Result : Wide_String (1 .. Source'Length + New_Item'Length); + + begin + if Before < Source'First or else Before > Source'Last + 1 then + raise Index_Error; + end if; + + Result := Source (Source'First .. Before - 1) & New_Item & + Source (Before .. Source'Last); + return Result; + end Insert; + + procedure Insert + (Source : in out Wide_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) + is + begin + Move (Source => Insert (Source, Before, New_Item), + Target => Source, + Drop => Drop); + end Insert; + + ---------- + -- Move -- + ---------- + + procedure Move + (Source : Wide_String; + Target : out Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space) + is + Sfirst : constant Integer := Source'First; + Slast : constant Integer := Source'Last; + Slength : constant Integer := Source'Length; + + Tfirst : constant Integer := Target'First; + Tlast : constant Integer := Target'Last; + Tlength : constant Integer := Target'Length; + + function Is_Padding (Item : Wide_String) return Boolean; + -- Determine if all characters in Item are pad characters + + ---------------- + -- Is_Padding -- + ---------------- + + function Is_Padding (Item : Wide_String) return Boolean is + begin + for J in Item'Range loop + if Item (J) /= Pad then + return False; + end if; + end loop; + + return True; + end Is_Padding; + + -- Start of processing for Move + + begin + if Slength = Tlength then + Target := Source; + + elsif Slength > Tlength then + case Drop is + when Left => + Target := Source (Slast - Tlength + 1 .. Slast); + + when Right => + Target := Source (Sfirst .. Sfirst + Tlength - 1); + + when Error => + case Justify is + when Left => + if Is_Padding (Source (Sfirst + Tlength .. Slast)) then + Target := + Source (Sfirst .. Sfirst + Target'Length - 1); + else + raise Length_Error; + end if; + + when Right => + if Is_Padding (Source (Sfirst .. Slast - Tlength)) then + Target := Source (Slast - Tlength + 1 .. Slast); + else + raise Length_Error; + end if; + + when Center => + raise Length_Error; + end case; + end case; + + -- Source'Length < Target'Length + + else + case Justify is + when Left => + Target (Tfirst .. Tfirst + Slength - 1) := Source; + + for J in Tfirst + Slength .. Tlast loop + Target (J) := Pad; + end loop; + + when Right => + for J in Tfirst .. Tlast - Slength loop + Target (J) := Pad; + end loop; + + Target (Tlast - Slength + 1 .. Tlast) := Source; + + when Center => + declare + Front_Pad : constant Integer := (Tlength - Slength) / 2; + Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; + + begin + for J in Tfirst .. Tfirst_Fpad - 1 loop + Target (J) := Pad; + end loop; + + Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; + + for J in Tfirst_Fpad + Slength .. Tlast loop + Target (J) := Pad; + end loop; + end; + end case; + end if; + end Move; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Wide_String; + Position : Positive; + New_Item : Wide_String) return Wide_String + is + begin + if Position not in Source'First .. Source'Last + 1 then + raise Index_Error; + else + declare + Result_Length : constant Natural := + Natural'Max + (Source'Length, + Position - Source'First + New_Item'Length); + + Result : Wide_String (1 .. Result_Length); + + begin + Result := Source (Source'First .. Position - 1) & New_Item & + Source (Position + New_Item'Length .. Source'Last); + return Result; + end; + end if; + end Overwrite; + + procedure Overwrite + (Source : in out Wide_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Right) + is + begin + Move (Source => Overwrite (Source, Position, New_Item), + Target => Source, + Drop => Drop); + end Overwrite; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Wide_String + is + begin + if Low > Source'Last + 1 or else High < Source'First - 1 then + raise Index_Error; + end if; + + if High >= Low then + declare + Front_Len : constant Integer := + Integer'Max (0, Low - Source'First); + -- Length of prefix of Source copied to result + + Back_Len : constant Integer := Integer'Max (0, Source'Last - High); + -- Length of suffix of Source copied to result + + Result_Length : constant Integer := + Front_Len + By'Length + Back_Len; + -- Length of result + + Result : Wide_String (1 .. Result_Length); + + begin + Result (1 .. Front_Len) := Source (Source'First .. Low - 1); + Result (Front_Len + 1 .. Front_Len + By'Length) := By; + Result (Front_Len + By'Length + 1 .. Result'Length) := + Source (High + 1 .. Source'Last); + return Result; + end; + + else + return Insert (Source, Before => Low, New_Item => By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space) + is + begin + Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); + end Replace_Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Wide_String + is + Result : Wide_String (1 .. Count); + + begin + if Count < Source'Length then + Result := Source (Source'Last - Count + 1 .. Source'Last); + + -- Pad on left + + else + for J in 1 .. Count - Source'Length loop + Result (J) := Pad; + end loop; + + Result (Count - Source'Length + 1 .. Count) := Source; + end if; + + return Result; + end Tail; + + procedure Tail + (Source : in out Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space) + is + begin + Move (Source => Tail (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Tail; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Wide_String + is + Result : Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + begin + for J in Source'Range loop + Source (J) := Value (Mapping, Source (J)); + end loop; + end Translate; + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Wide_String + is + Result : Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Mapping (Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + begin + for J in Source'Range loop + Source (J) := Mapping (Source (J)); + end loop; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Wide_String; + Side : Trim_End) return Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + if Side = Left or else Side = Both then + while Low <= High and then Source (Low) = Wide_Space loop + Low := Low + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while High >= Low and then Source (High) = Wide_Space loop + High := High - 1; + end loop; + end if; + + -- All blanks case + + if Low > High then + return ""; + + -- At least one non-blank + + else + declare + Result : constant Wide_String (1 .. High - Low + 1) := + Source (Low .. High); + + begin + return Result; + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space) + is + begin + Move (Source => Trim (Source, Side), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + + function Trim + (Source : Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + while Low <= High and then Is_In (Source (Low), Left) loop + Low := Low + 1; + end loop; + + while High >= Low and then Is_In (Source (High), Right) loop + High := High - 1; + end loop; + + -- Case where source comprises only characters in the sets + + if Low > High then + return ""; + else + declare + subtype WS is Wide_String (1 .. High - Low + 1); + + begin + return WS (Source (Low .. High)); + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set; + Justify : Alignment := Strings.Left; + Pad : Wide_Character := Wide_Space) + is + begin + Move (Source => Trim (Source, Left, Right), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + +end Ada.Strings.Wide_Fixed; diff --git a/gcc/ada/libgnat/a-stwifi.ads b/gcc/ada/libgnat/a-stwifi.ads new file mode 100644 index 0000000..75de811 --- /dev/null +++ b/gcc/ada/libgnat/a-stwifi.ads @@ -0,0 +1,254 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ F I X E D -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Maps; + +package Ada.Strings.Wide_Fixed is + pragma Preelaborate; + + ------------------------------------------------------------------- + -- Copy Procedure for Wide_Strings of Possibly Different Lengths -- + ------------------------------------------------------------------- + + procedure Move + (Source : Wide_String; + Target : out Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ----------------------------------------- + -- Wide_String Translation Subprograms -- + ----------------------------------------- + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Wide_String; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Wide_String; + + procedure Translate + (Source : in out Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + -------------------------------------------- + -- Wide_String Transformation Subprograms -- + -------------------------------------------- + + function Replace_Slice + (Source : Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Wide_String; + + procedure Replace_Slice + (Source : in out Wide_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + function Insert + (Source : Wide_String; + Before : Positive; + New_Item : Wide_String) return Wide_String; + + procedure Insert + (Source : in out Wide_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Wide_String; + Position : Positive; + New_Item : Wide_String) return Wide_String; + + procedure Overwrite + (Source : in out Wide_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Right); + + function Delete + (Source : Wide_String; + From : Positive; + Through : Natural) return Wide_String; + + procedure Delete + (Source : in out Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + -------------------------------------- + -- Wide_String Selector Subprograms -- + -------------------------------------- + + function Trim + (Source : Wide_String; + Side : Trim_End) return Wide_String; + + procedure Trim + (Source : in out Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Character := Wide_Space); + + function Trim + (Source : Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Wide_String; + + procedure Trim + (Source : in out Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set; + Justify : Alignment := Ada.Strings.Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + function Head + (Source : Wide_String; + Count : Natural; + Pad : Wide_Character := Ada.Strings.Wide_Space) return Wide_String; + + procedure Head + (Source : in out Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + function Tail + (Source : Wide_String; + Count : Natural; + Pad : Wide_Character := Ada.Strings.Wide_Space) return Wide_String; + + procedure Tail + (Source : in out Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Character := Ada.Strings.Wide_Space); + + --------------------------------------- + -- Wide_String Constructor Functions -- + --------------------------------------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Wide_String; + +end Ada.Strings.Wide_Fixed; diff --git a/gcc/ada/libgnat/a-stwiha.adb b/gcc/ada/libgnat/a-stwiha.adb new file mode 100644 index 0000000..cd1517a --- /dev/null +++ b/gcc/ada/libgnat/a-stwiha.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash_Fun is new System.String_Hash.Hash + (Wide_Character, Wide_String, Hash_Type); +begin + return Hash_Fun (Key); +end Ada.Strings.Wide_Hash; diff --git a/gcc/ada/libgnat/a-stwiha.ads b/gcc/ada/libgnat/a-stwiha.ads new file mode 100644 index 0000000..f8f0b52 --- /dev/null +++ b/gcc/ada/libgnat/a-stwiha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type; + +pragma Pure (Ada.Strings.Wide_Hash); diff --git a/gcc/ada/libgnat/a-stwima.adb b/gcc/ada/libgnat/a-stwima.adb new file mode 100644 index 0000000..dfdddfe --- /dev/null +++ b/gcc/ada/libgnat/a-stwima.adb @@ -0,0 +1,742 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Maps is + + --------- + -- "-" -- + --------- + + function "-" + (Left, Right : Wide_Character_Set) return Wide_Character_Set + is + LS : constant Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); + -- Each range on the right can generate at least one more range in + -- the result, by splitting one of the left operand ranges. + + N : Natural := 0; + R : Natural := 1; + L : Natural := 1; + + Left_Low : Wide_Character; + -- Left_Low is lowest character of the L'th range not yet dealt with + + begin + if LS'Last = 0 or else RS'Last = 0 then + return Left; + end if; + + Left_Low := LS (L).Low; + while R <= RS'Last loop + + -- If next right range is below current left range, skip it + + if RS (R).High < Left_Low then + R := R + 1; + + -- If next right range above current left range, copy remainder + -- of the left range to the result + + elsif RS (R).Low > LS (L).High then + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := LS (L).High; + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + + else + -- Next right range overlaps bottom of left range + + if RS (R).Low <= Left_Low then + + -- Case of right range complete overlaps left range + + if RS (R).High >= LS (L).High then + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + + -- Case of right range eats lower part of left range + + else + Left_Low := Wide_Character'Succ (RS (R).High); + R := R + 1; + end if; + + -- Next right range overlaps some of left range, but not bottom + + else + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := Wide_Character'Pred (RS (R).Low); + + -- Case of right range splits left range + + if RS (R).High < LS (L).High then + Left_Low := Wide_Character'Succ (RS (R).High); + R := R + 1; + + -- Case of right range overlaps top of left range + + else + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + end if; + end if; + end if; + end loop; + + -- Copy remainder of left ranges to result + + if L <= LS'Last then + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := LS (L).High; + + loop + L := L + 1; + exit when L > LS'Last; + N := N + 1; + Result (N) := LS (L); + end loop; + end if; + + return (AF.Controlled with + Set => new Wide_Character_Ranges'(Result (1 .. N))); + end "-"; + + --------- + -- "=" -- + --------- + + -- The sorted, discontiguous form is canonical, so equality can be used + + function "=" (Left, Right : Wide_Character_Set) return Boolean is + begin + return Left.Set.all = Right.Set.all; + end "="; + + ----------- + -- "and" -- + ----------- + + function "and" + (Left, Right : Wide_Character_Set) return Wide_Character_Set + is + LS : constant Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); + N : Natural := 0; + L, R : Natural := 1; + + begin + -- Loop to search for overlapping character ranges + + while L <= LS'Last and then R <= RS'Last loop + + if LS (L).High < RS (R).Low then + L := L + 1; + + elsif RS (R).High < LS (L).Low then + R := R + 1; + + -- Here we have LS (L).High >= RS (R).Low + -- and RS (R).High >= LS (L).Low + -- so we have an overlapping range + + else + N := N + 1; + Result (N).Low := Wide_Character'Max (LS (L).Low, RS (R).Low); + Result (N).High := + Wide_Character'Min (LS (L).High, RS (R).High); + + if RS (R).High = LS (L).High then + L := L + 1; + R := R + 1; + elsif RS (R).High < LS (L).High then + R := R + 1; + else + L := L + 1; + end if; + end if; + end loop; + + return (AF.Controlled with + Set => new Wide_Character_Ranges'(Result (1 .. N))); + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" + (Right : Wide_Character_Set) return Wide_Character_Set + is + RS : constant Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Character_Ranges (1 .. RS'Last + 1); + N : Natural := 0; + + begin + if RS'Last = 0 then + N := 1; + Result (1) := (Low => Wide_Character'First, + High => Wide_Character'Last); + + else + if RS (1).Low /= Wide_Character'First then + N := N + 1; + Result (N).Low := Wide_Character'First; + Result (N).High := Wide_Character'Pred (RS (1).Low); + end if; + + for K in 1 .. RS'Last - 1 loop + N := N + 1; + Result (N).Low := Wide_Character'Succ (RS (K).High); + Result (N).High := Wide_Character'Pred (RS (K + 1).Low); + end loop; + + if RS (RS'Last).High /= Wide_Character'Last then + N := N + 1; + Result (N).Low := Wide_Character'Succ (RS (RS'Last).High); + Result (N).High := Wide_Character'Last; + end if; + end if; + + return (AF.Controlled with + Set => new Wide_Character_Ranges'(Result (1 .. N))); + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" + (Left, Right : Wide_Character_Set) return Wide_Character_Set + is + LS : constant Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Character_Ranges (1 .. LS'Last + RS'Last); + N : Natural; + L, R : Natural; + + begin + N := 0; + L := 1; + R := 1; + + -- Loop through ranges in output file + + loop + -- If no left ranges left, copy next right range + + if L > LS'Last then + exit when R > RS'Last; + N := N + 1; + Result (N) := RS (R); + R := R + 1; + + -- If no right ranges left, copy next left range + + elsif R > RS'Last then + N := N + 1; + Result (N) := LS (L); + L := L + 1; + + else + -- We have two ranges, choose lower one + + N := N + 1; + + if LS (L).Low <= RS (R).Low then + Result (N) := LS (L); + L := L + 1; + else + Result (N) := RS (R); + R := R + 1; + end if; + + -- Loop to collapse ranges into last range + + loop + -- Collapse next length range into current result range + -- if possible. + + if L <= LS'Last + and then LS (L).Low <= Wide_Character'Succ (Result (N).High) + then + Result (N).High := + Wide_Character'Max (Result (N).High, LS (L).High); + L := L + 1; + + -- Collapse next right range into current result range + -- if possible + + elsif R <= RS'Last + and then RS (R).Low <= + Wide_Character'Succ (Result (N).High) + then + Result (N).High := + Wide_Character'Max (Result (N).High, RS (R).High); + R := R + 1; + + -- If neither range collapses, then done with this range + + else + exit; + end if; + end loop; + end if; + end loop; + + return (AF.Controlled with + Set => new Wide_Character_Ranges'(Result (1 .. N))); + end "or"; + + ----------- + -- "xor" -- + ----------- + + function "xor" + (Left, Right : Wide_Character_Set) return Wide_Character_Set + is + begin + return (Left or Right) - (Left and Right); + end "xor"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Wide_Character_Mapping) is + begin + Object.Map := new Wide_Character_Mapping_Values'(Object.Map.all); + end Adjust; + + procedure Adjust (Object : in out Wide_Character_Set) is + begin + Object.Set := new Wide_Character_Ranges'(Object.Set.all); + end Adjust; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Wide_Character_Mapping) is + + procedure Free is new Ada.Unchecked_Deallocation + (Wide_Character_Mapping_Values, + Wide_Character_Mapping_Values_Access); + + begin + if Object.Map /= Null_Map'Unrestricted_Access then + Free (Object.Map); + end if; + end Finalize; + + procedure Finalize (Object : in out Wide_Character_Set) is + + procedure Free is new Ada.Unchecked_Deallocation + (Wide_Character_Ranges, + Wide_Character_Ranges_Access); + + begin + if Object.Set /= Null_Range'Unrestricted_Access then + Free (Object.Set); + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Wide_Character_Mapping) is + begin + Object := Identity; + end Initialize; + + procedure Initialize (Object : in out Wide_Character_Set) is + begin + Object := Null_Set; + end Initialize; + + ----------- + -- Is_In -- + ----------- + + function Is_In + (Element : Wide_Character; + Set : Wide_Character_Set) return Boolean + is + L, R, M : Natural; + SS : constant Wide_Character_Ranges_Access := Set.Set; + + begin + L := 1; + R := SS'Last; + + -- Binary search loop. The invariant is that if Element is in any of + -- of the constituent ranges it is in one between Set (L) and Set (R). + + loop + if L > R then + return False; + + else + M := (L + R) / 2; + + if Element > SS (M).High then + L := M + 1; + elsif Element < SS (M).Low then + R := M - 1; + else + return True; + end if; + end if; + end loop; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Elements : Wide_Character_Set; + Set : Wide_Character_Set) return Boolean + is + ES : constant Wide_Character_Ranges_Access := Elements.Set; + SS : constant Wide_Character_Ranges_Access := Set.Set; + + S : Positive := 1; + E : Positive := 1; + + begin + loop + -- If no more element ranges, done, and result is true + + if E > ES'Last then + return True; + + -- If more element ranges, but no more set ranges, result is false + + elsif S > SS'Last then + return False; + + -- Remove irrelevant set range + + elsif SS (S).High < ES (E).Low then + S := S + 1; + + -- Get rid of element range that is properly covered by set + + elsif SS (S).Low <= ES (E).Low + and then ES (E).High <= SS (S).High + then + E := E + 1; + + -- Otherwise we have a non-covered element range, result is false + + else + return False; + end if; + end loop; + end Is_Subset; + + --------------- + -- To_Domain -- + --------------- + + function To_Domain + (Map : Wide_Character_Mapping) return Wide_Character_Sequence + is + begin + return Map.Map.Domain; + end To_Domain; + + ---------------- + -- To_Mapping -- + ---------------- + + function To_Mapping + (From, To : Wide_Character_Sequence) return Wide_Character_Mapping + is + Domain : Wide_Character_Sequence (1 .. From'Length); + Rangev : Wide_Character_Sequence (1 .. To'Length); + N : Natural := 0; + + begin + if From'Length /= To'Length then + raise Translation_Error; + + else + pragma Warnings (Off); -- apparent uninit use of Domain + + for J in From'Range loop + for M in 1 .. N loop + if From (J) = Domain (M) then + raise Translation_Error; + elsif From (J) < Domain (M) then + Domain (M + 1 .. N + 1) := Domain (M .. N); + Rangev (M + 1 .. N + 1) := Rangev (M .. N); + Domain (M) := From (J); + Rangev (M) := To (J); + goto Continue; + end if; + end loop; + + Domain (N + 1) := From (J); + Rangev (N + 1) := To (J); + + <> + N := N + 1; + end loop; + + pragma Warnings (On); + + return (AF.Controlled with + Map => new Wide_Character_Mapping_Values'( + Length => N, + Domain => Domain (1 .. N), + Rangev => Rangev (1 .. N))); + end if; + end To_Mapping; + + -------------- + -- To_Range -- + -------------- + + function To_Range + (Map : Wide_Character_Mapping) return Wide_Character_Sequence + is + begin + return Map.Map.Rangev; + end To_Range; + + --------------- + -- To_Ranges -- + --------------- + + function To_Ranges + (Set : Wide_Character_Set) return Wide_Character_Ranges + is + begin + return Set.Set.all; + end To_Ranges; + + ----------------- + -- To_Sequence -- + ----------------- + + function To_Sequence + (Set : Wide_Character_Set) return Wide_Character_Sequence + is + SS : constant Wide_Character_Ranges_Access := Set.Set; + N : Natural := 0; + Count : Natural := 0; + + begin + for J in SS'Range loop + Count := + Count + (Wide_Character'Pos (SS (J).High) - + Wide_Character'Pos (SS (J).Low) + 1); + end loop; + + return Result : Wide_String (1 .. Count) do + for J in SS'Range loop + for K in SS (J).Low .. SS (J).High loop + N := N + 1; + Result (N) := K; + end loop; + end loop; + end return; + end To_Sequence; + + ------------ + -- To_Set -- + ------------ + + -- Case of multiple range input + + function To_Set + (Ranges : Wide_Character_Ranges) return Wide_Character_Set + is + Result : Wide_Character_Ranges (Ranges'Range); + N : Natural := 0; + J : Natural; + + begin + -- The output of To_Set is required to be sorted by increasing Low + -- values, and discontiguous, so first we sort them as we enter them, + -- using a simple insertion sort. + + pragma Warnings (Off); + -- Kill bogus warning on Result being uninitialized + + for J in Ranges'Range loop + for K in 1 .. N loop + if Ranges (J).Low < Result (K).Low then + Result (K + 1 .. N + 1) := Result (K .. N); + Result (K) := Ranges (J); + goto Continue; + end if; + end loop; + + Result (N + 1) := Ranges (J); + + <> + N := N + 1; + end loop; + + pragma Warnings (On); + + -- Now collapse any contiguous or overlapping ranges + + J := 1; + while J < N loop + if Result (J).High < Result (J).Low then + N := N - 1; + Result (J .. N) := Result (J + 1 .. N + 1); + + elsif Wide_Character'Succ (Result (J).High) >= Result (J + 1).Low then + Result (J).High := + Wide_Character'Max (Result (J).High, Result (J + 1).High); + + N := N - 1; + Result (J + 1 .. N) := Result (J + 2 .. N + 1); + + else + J := J + 1; + end if; + end loop; + + if N > 0 and then Result (N).High < Result (N).Low then + N := N - 1; + end if; + + return (AF.Controlled with + Set => new Wide_Character_Ranges'(Result (1 .. N))); + end To_Set; + + -- Case of single range input + + function To_Set + (Span : Wide_Character_Range) return Wide_Character_Set + is + begin + if Span.Low > Span.High then + return Null_Set; + -- This is safe, because there is no procedure with parameter + -- Wide_Character_Set of mode "out" or "in out". + + else + return (AF.Controlled with + Set => new Wide_Character_Ranges'(1 => Span)); + end if; + end To_Set; + + -- Case of wide string input + + function To_Set + (Sequence : Wide_Character_Sequence) return Wide_Character_Set + is + R : Wide_Character_Ranges (1 .. Sequence'Length); + + begin + for J in R'Range loop + R (J) := (Sequence (J), Sequence (J)); + end loop; + + return To_Set (R); + end To_Set; + + -- Case of single wide character input + + function To_Set + (Singleton : Wide_Character) return Wide_Character_Set + is + begin + return + (AF.Controlled with + Set => new Wide_Character_Ranges'(1 => (Singleton, Singleton))); + end To_Set; + + ----------- + -- Value -- + ----------- + + function Value + (Map : Wide_Character_Mapping; + Element : Wide_Character) return Wide_Character + is + L, R, M : Natural; + + MV : constant Wide_Character_Mapping_Values_Access := Map.Map; + + begin + L := 1; + R := MV.Domain'Last; + + -- Binary search loop + + loop + -- If not found, identity + + if L > R then + return Element; + + -- Otherwise do binary divide + + else + M := (L + R) / 2; + + if Element < MV.Domain (M) then + R := M - 1; + + elsif Element > MV.Domain (M) then + L := M + 1; + + else -- Element = MV.Domain (M) then + return MV.Rangev (M); + end if; + end if; + end loop; + end Value; + +end Ada.Strings.Wide_Maps; diff --git a/gcc/ada/libgnat/a-stwima.ads b/gcc/ada/libgnat/a-stwima.ads new file mode 100644 index 0000000..cbbb65e --- /dev/null +++ b/gcc/ada/libgnat/a-stwima.ads @@ -0,0 +1,240 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; + +package Ada.Strings.Wide_Maps is + pragma Preelaborate; + + ------------------------------------- + -- Wide Character Set Declarations -- + ------------------------------------- + + type Wide_Character_Set is private; + pragma Preelaborable_Initialization (Wide_Character_Set); + -- Representation for a set of Wide_Character values: + + Null_Set : constant Wide_Character_Set; + + ------------------------------------------ + -- Constructors for Wide Character Sets -- + ------------------------------------------ + + type Wide_Character_Range is record + Low : Wide_Character; + High : Wide_Character; + end record; + -- Represents Wide_Character range Low .. High + + type Wide_Character_Ranges is + array (Positive range <>) of Wide_Character_Range; + + function To_Set + (Ranges : Wide_Character_Ranges) return Wide_Character_Set; + + function To_Set + (Span : Wide_Character_Range) return Wide_Character_Set; + + function To_Ranges + (Set : Wide_Character_Set) return Wide_Character_Ranges; + + --------------------------------------- + -- Operations on Wide Character Sets -- + --------------------------------------- + + function "=" (Left, Right : Wide_Character_Set) return Boolean; + + function "not" + (Right : Wide_Character_Set) return Wide_Character_Set; + + function "and" + (Left, Right : Wide_Character_Set) return Wide_Character_Set; + + function "or" + (Left, Right : Wide_Character_Set) return Wide_Character_Set; + + function "xor" + (Left, Right : Wide_Character_Set) return Wide_Character_Set; + + function "-" + (Left, Right : Wide_Character_Set) return Wide_Character_Set; + + function Is_In + (Element : Wide_Character; + Set : Wide_Character_Set) return Boolean; + + function Is_Subset + (Elements : Wide_Character_Set; + Set : Wide_Character_Set) return Boolean; + + function "<=" + (Left : Wide_Character_Set; + Right : Wide_Character_Set) return Boolean + renames Is_Subset; + + subtype Wide_Character_Sequence is Wide_String; + -- Alternative representation for a set of character values + + function To_Set + (Sequence : Wide_Character_Sequence) return Wide_Character_Set; + + function To_Set + (Singleton : Wide_Character) return Wide_Character_Set; + + function To_Sequence + (Set : Wide_Character_Set) return Wide_Character_Sequence; + + ----------------------------------------- + -- Wide Character Mapping Declarations -- + ----------------------------------------- + + type Wide_Character_Mapping is private; + pragma Preelaborable_Initialization (Wide_Character_Mapping); + -- Representation for a wide character to wide character mapping: + + function Value + (Map : Wide_Character_Mapping; + Element : Wide_Character) return Wide_Character; + + Identity : constant Wide_Character_Mapping; + + --------------------------------- + -- Operations on Wide Mappings -- + --------------------------------- + + function To_Mapping + (From, To : Wide_Character_Sequence) return Wide_Character_Mapping; + + function To_Domain + (Map : Wide_Character_Mapping) return Wide_Character_Sequence; + + function To_Range + (Map : Wide_Character_Mapping) return Wide_Character_Sequence; + + type Wide_Character_Mapping_Function is + access function (From : Wide_Character) return Wide_Character; + +private + package AF renames Ada.Finalization; + + ------------------------------------------ + -- Representation of Wide_Character_Set -- + ------------------------------------------ + + -- A wide character set is represented as a sequence of wide character + -- ranges (i.e. an object of type Wide_Character_Ranges) in which the + -- following hold: + + -- The lower bound is 1 + -- The ranges are in order by increasing Low values + -- The ranges are non-overlapping and discontigous + + -- A character value is in the set if it is contained in one of the + -- ranges. The actual Wide_Character_Set value is a controlled pointer + -- to this Wide_Character_Ranges value. The use of a controlled type + -- is necessary to prevent storage leaks. + + type Wide_Character_Ranges_Access is access all Wide_Character_Ranges; + + type Wide_Character_Set is new AF.Controlled with record + Set : Wide_Character_Ranges_Access; + end record; + + pragma Finalize_Storage_Only (Wide_Character_Set); + -- This avoids useless finalizations, and, more importantly avoids + -- incorrect attempts to finalize constants that are statically + -- declared here and in Ada.Strings.Wide_Maps, which is incorrect. + + overriding procedure Initialize (Object : in out Wide_Character_Set); + overriding procedure Adjust (Object : in out Wide_Character_Set); + overriding procedure Finalize (Object : in out Wide_Character_Set); + + Null_Range : aliased constant Wide_Character_Ranges := + (1 .. 0 => (Low => ' ', High => ' ')); + + Null_Set : constant Wide_Character_Set := + (AF.Controlled with + Set => Null_Range'Unrestricted_Access); + + ---------------------------------------------- + -- Representation of Wide_Character_Mapping -- + ---------------------------------------------- + + -- A wide character mapping is represented as two strings of equal + -- length, where any character appearing in Domain is mapped to the + -- corresponding character in Rangev. A character not appearing in + -- Domain is mapped to itself. The characters in Domain are sorted + -- in ascending order. + + -- The actual Wide_Character_Mapping value is a controlled record + -- that contains a pointer to a discriminated record containing the + -- range and domain values. + + -- Note: this representation is canonical, and the values stored in + -- Domain and Rangev are exactly the values that are returned by the + -- functions To_Domain and To_Range. The use of a controlled type is + -- necessary to prevent storage leaks. + + type Wide_Character_Mapping_Values (Length : Natural) is record + Domain : Wide_Character_Sequence (1 .. Length); + Rangev : Wide_Character_Sequence (1 .. Length); + end record; + + type Wide_Character_Mapping_Values_Access is + access all Wide_Character_Mapping_Values; + + type Wide_Character_Mapping is new AF.Controlled with record + Map : Wide_Character_Mapping_Values_Access; + end record; + + pragma Finalize_Storage_Only (Wide_Character_Mapping); + -- This avoids useless finalizations, and, more importantly avoids + -- incorrect attempts to finalize constants that are statically + -- declared here and in Ada.Strings.Wide_Maps, which is incorrect. + + overriding procedure Initialize (Object : in out Wide_Character_Mapping); + overriding procedure Adjust (Object : in out Wide_Character_Mapping); + overriding procedure Finalize (Object : in out Wide_Character_Mapping); + + Null_Map : aliased constant Wide_Character_Mapping_Values := + (Length => 0, + Domain => "", + Rangev => ""); + + Identity : constant Wide_Character_Mapping := + (AF.Controlled with + Map => Null_Map'Unrestricted_Access); + +end Ada.Strings.Wide_Maps; diff --git a/gcc/ada/libgnat/a-stwise.adb b/gcc/ada/libgnat/a-stwise.adb new file mode 100644 index 0000000..8c2d743 --- /dev/null +++ b/gcc/ada/libgnat/a-stwise.adb @@ -0,0 +1,614 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ S E A R C H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; +with System; use System; + +package body Ada.Strings.Wide_Search is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Belongs + (Element : Wide_Character; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership) return Boolean; + pragma Inline (Belongs); + -- Determines if the given element is in (Test = Inside) or not in + -- (Test = Outside) the given character set. + + ------------- + -- Belongs -- + ------------- + + function Belongs + (Element : Wide_Character; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership) return Boolean + is + begin + if Test = Inside then + return Is_In (Element, Set); + else + return not Is_In (Element, Set); + end if; + end Belongs; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + Num := 0; + Ind := Source'First; + + -- Unmapped case + + if Mapping'Address = Wide_Maps.Identity'Address then + while Ind <= Source'Last - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + Num := Num + 1; + Ind := Ind + Pattern'Length; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped case + + else + while Ind <= Source'Last - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; + end loop; + + Num := Num + 1; + Ind := Ind + Pattern'Length; + + <> + null; + end loop; + end if; + + -- Return result + + return Num; + end Count; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + Num := 0; + Ind := Source'First; + while Ind <= Source'Last - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Mapping (Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; + end loop; + + Num := Num + 1; + Ind := Ind + Pattern'Length; + + <> + null; + end loop; + + return Num; + end Count; + + function Count + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + N : Natural := 0; + + begin + for J in Source'Range loop + if Is_In (Source (J), Set) then + N := N + 1; + end if; + end loop; + + return N; + end Count; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + is + begin + for J in From .. Source'Last loop + if Belongs (Source (J), Set, Test) then + First := J; + + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + end loop; + + -- Here if J indexes first char of token, and all chars after J + -- are in the token. + + Last := Source'Last; + return; + end if; + end loop; + + -- Here if no token found + + First := From; + Last := 0; + end Find_Token; + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + is + begin + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + First := J; + + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + end loop; + + -- Here if J indexes first char of token, and all chars after J + -- are in the token. + + Last := Source'Last; + return; + end if; + end loop; + + -- Here if no token found + + -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if + -- Source'First is not positive and is assigned to First. Formulation + -- is slightly different in RM 2012, but the intent seems similar, so + -- we check explicitly for that condition. + + if Source'First not in Positive then + raise Constraint_Error; + + else + First := Source'First; + Last := 0; + end if; + end Find_Token; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Cur : Natural; + + Ind : Integer; + -- Index for start of match check. This can be negative if the pattern + -- length is greater than the string length, which is why this variable + -- is Integer instead of Natural. In this case, the search loops do not + -- execute at all, so this Ind value is never used. + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + + -- Unmapped forward case + + if Mapping'Address = Wide_Maps.Identity'Address then + for J in 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped forward case + + else + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + end if; + + -- Backwards case + + else + -- Unmapped backward case + + Ind := Source'Last - PL1; + + if Mapping'Address = Wide_Maps.Identity'Address then + for J in reverse 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind - 1; + end if; + end loop; + + -- Mapped backward case + + else + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + -- If Pattern longer than Source it can't be found + + if Pattern'Length > Source'Length then + return 0; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + + -- Backwards case + + else + Ind := Source'Last - PL1; + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + -- Forwards case + + if Going = Forward then + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + + -- Backwards case + + else + for J in reverse Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return Index + (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return Index + (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Set, Test, Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Set, Test, Backward); + end if; + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Wide_String; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Source (J) /= Wide_Space then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Source (J) /= Wide_Space then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (From .. Source'Last), Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (Source'First .. From), Backward); + end if; + end Index_Non_Blank; + +end Ada.Strings.Wide_Search; diff --git a/gcc/ada/libgnat/a-stwise.ads b/gcc/ada/libgnat/a-stwise.ads new file mode 100644 index 0000000..66d9cb2 --- /dev/null +++ b/gcc/ada/libgnat/a-stwise.ads @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ S E A R C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the search functions from Ada.Strings.Wide_Fixed. +-- They are separated out because they are shared by Ada.Strings.Wide_Bounded +-- and Ada.Strings.Wide_Unbounded, and we don't want to drag in other +-- irrelevant stuff from Ada.Strings.Wide_Fixed when using the other two +-- packages. We make this a private package, since user programs should +-- access these subprograms via one of the standard string packages. + +with Ada.Strings.Wide_Maps; + +private package Ada.Strings.Wide_Search is + pragma Preelaborate; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.Identity) return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + +end Ada.Strings.Wide_Search; diff --git a/gcc/ada/libgnat/a-stwisu.adb b/gcc/ada/libgnat/a-stwisu.adb new file mode 100644 index 0000000..b093476 --- /dev/null +++ b/gcc/ada/libgnat/a-stwisu.adb @@ -0,0 +1,1933 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Maps; use Ada.Strings.Wide_Maps; +with Ada.Strings.Wide_Search; + +package body Ada.Strings.Wide_Superbounded is + + ------------ + -- Concat -- + ------------ + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_String) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Nlen : constant Natural := Llen + Right'Length; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end if; + end; + end return; + end Concat; + + function Concat + (Left : Wide_String; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Right.Max_Length) do + declare + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Character) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end if; + end; + end return; + end Concat; + + function Concat + (Left : Wide_Character; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Right.Max_Length) do + declare + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := + Right.Data (1 .. Rlen); + end if; + end; + end return; + end Concat; + + ----------- + -- Equal -- + ----------- + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Current_Length = Right.Current_Length + and then Left.Data (1 .. Left.Current_Length) = + Right.Data (1 .. Right.Current_Length); + end "="; + + function Equal + (Left : Super_String; + Right : Wide_String) return Boolean + is + begin + return Left.Current_Length = Right'Length + and then Left.Data (1 .. Left.Current_Length) = Right; + end Equal; + + function Equal + (Left : Wide_String; + Right : Super_String) return Boolean + is + begin + return Left'Length = Right.Current_Length + and then Left = Right.Data (1 .. Right.Current_Length); + end Equal; + + ------------- + -- Greater -- + ------------- + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > + Right.Data (1 .. Right.Current_Length); + end Greater; + + function Greater + (Left : Super_String; + Right : Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > Right; + end Greater; + + function Greater + (Left : Wide_String; + Right : Super_String) return Boolean + is + begin + return Left > Right.Data (1 .. Right.Current_Length); + end Greater; + + ---------------------- + -- Greater_Or_Equal -- + ---------------------- + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= + Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= Right; + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Wide_String; + Right : Super_String) return Boolean + is + begin + return Left >= Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + ---------- + -- Less -- + ---------- + + function Less + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < + Right.Data (1 .. Right.Current_Length); + end Less; + + function Less + (Left : Super_String; + Right : Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < Right; + end Less; + + function Less + (Left : Wide_String; + Right : Super_String) return Boolean + is + begin + return Left < Right.Data (1 .. Right.Current_Length); + end Less; + + ------------------- + -- Less_Or_Equal -- + ------------------- + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= + Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= Right; + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Wide_String; + Right : Super_String) return Boolean + is + begin + return Left <= Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + ---------------------- + -- Set_Super_String -- + ---------------------- + + procedure Set_Super_String + (Target : out Super_String; + Source : Wide_String; + Drop : Truncation := Error) + is + Slen : constant Natural := Source'Length; + Max_Length : constant Positive := Target.Max_Length; + + begin + if Slen <= Max_Length then + Target.Current_Length := Slen; + Target.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Set_Super_String; + + ------------------ + -- Super_Append -- + ------------------ + + -- Case of Super_String and Super_String + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Result.Data := Right.Data; + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Source.Data := New_Item.Data; + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Super_String and Wide_String + + function Super_Append + (Left : Super_String; + Right : Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right (Right'First .. Right'First - 1 + + Max_Length - Llen); + + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right (Right'Last - (Max_Length - 1) .. Right'Last); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item (New_Item'First .. + New_Item'First - 1 + Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - (Max_Length - 1) .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Wide_String and Super_String + + function Super_Append + (Left : Wide_String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then + Result.Data (1 .. Max_Length) := + Left (Left'First .. Left'First + (Max_Length - 1)); + + else + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right.Data (Rlen - (Max_Length - 1) .. Rlen); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + -- Case of Super_String and Wide_Character + + function Super_Append + (Left : Super_String; + Right : Wide_Character; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen < Max_Length then + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1) := Right; + return Result; + + else + case Drop is + when Strings.Right => + return Left; + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length - 1) := + Left.Data (2 .. Max_Length); + Result.Data (Max_Length) := Right; + return Result; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Character; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + + begin + if Llen < Max_Length then + Source.Current_Length := Llen + 1; + Source.Data (Llen + 1) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + null; + + when Strings.Left => + Source.Data (1 .. Max_Length - 1) := + Source.Data (2 .. Max_Length); + Source.Data (Max_Length) := New_Item; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Wide_Character and Super_String + + function Super_Append + (Left : Wide_Character; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen < Max_Length then + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + return Result; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1) := Left; + Result.Data (2 .. Max_Length) := + Right.Data (1 .. Max_Length - 1); + return Result; + + when Strings.Left => + return Right; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + ----------------- + -- Super_Count -- + ----------------- + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return + Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + return + Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + begin + return Wide_Search.Count (Source.Data (1 .. Source.Current_Length), Set); + end Super_Count; + + ------------------ + -- Super_Delete -- + ------------------ + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return Source; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Result.Current_Length := From - 1; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + return Result; + + else + Result.Current_Length := Slen - Num_Delete; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + Result.Data (From .. Result.Current_Length) := + Source.Data (Through + 1 .. Slen); + return Result; + end if; + end Super_Delete; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural) + is + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Source.Current_Length := From - 1; + + else + Source.Current_Length := Slen - Num_Delete; + Source.Data (From .. Source.Current_Length) := + Source.Data (Through + 1 .. Slen); + end if; + end Super_Delete; + + ------------------- + -- Super_Element -- + ------------------- + + function Super_Element + (Source : Super_String; + Index : Positive) return Wide_Character + is + begin + if Index <= Source.Current_Length then + return Source.Data (Index); + else + raise Strings.Index_Error; + end if; + end Super_Element; + + ---------------------- + -- Super_Find_Token -- + ---------------------- + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Search.Find_Token + (Source.Data (From .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Search.Find_Token + (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + ---------------- + -- Super_Head -- + ---------------- + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := Source.Data (1 .. Count); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Count) := (others => Pad); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Max_Length - Npad) := + Source.Data (Count - Max_Length + 1 .. Slen); + Result.Data (Max_Length - Npad + 1 .. Max_Length) := + (others => Pad); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Head; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + Temp : Wide_String (1 .. Max_Length); + + begin + if Npad <= 0 then + Source.Current_Length := Count; + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (Slen + 1 .. Count) := (others => Pad); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad > Max_Length then + Source.Data := (others => Pad); + + else + Temp := Source.Data; + Source.Data (1 .. Max_Length - Npad) := + Temp (Count - Max_Length + 1 .. Slen); + + for J in Max_Length - Npad + 1 .. Max_Length loop + Source.Data (J) := Pad; + end loop; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Head; + + ----------------- + -- Super_Index -- + ----------------- + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Set, Test, Going); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + return Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); + end Super_Index; + + --------------------------- + -- Super_Index_Non_Blank -- + --------------------------- + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return + Wide_Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), Going); + end Super_Index_Non_Blank; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + return + Wide_Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), From, Going); + end Super_Index_Non_Blank; + + ------------------ + -- Super_Insert -- + ------------------ + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Nlen : constant Natural := New_Item'Length; + Tlen : constant Natural := Slen + Nlen; + Blen : constant Natural := Before - 1; + Alen : constant Integer := Slen - Blen; + Droplen : constant Integer := Tlen - Max_Length; + + -- Tlen is the length of the total string before possible truncation. + -- Blen, Alen are the lengths of the before and after pieces of the + -- source string. + + begin + if Alen < 0 then + raise Ada.Strings.Index_Error; + + elsif Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Tlen) := + Source.Data (Before .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Before .. Max_Length) := + New_Item (New_Item'First + .. New_Item'First + Max_Length - Before); + else + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Max_Length) := + Source.Data (Before .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (Before .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + New_Item (New_Item'Last - (Max_Length - Alen) + 1 + .. New_Item'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := + New_Item; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Insert; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Insert (Source, Before, New_Item, Drop); + end Super_Insert; + + ------------------ + -- Super_Length -- + ------------------ + + function Super_Length (Source : Super_String) return Natural is + begin + return Source.Current_Length; + end Super_Length; + + --------------------- + -- Super_Overwrite -- + --------------------- + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Endpos : constant Natural := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif New_Item'Length = 0 then + return Source; + + elsif Endpos <= Slen then + Result.Current_Length := Source.Current_Length; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + elsif Endpos <= Max_Length then + Result.Current_Length := Endpos; + Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + else + Result.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Position - 1) := + Source.Data (1 .. Position - 1); + + Result.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + return Result; + + when Strings.Left => + if New_Item'Length >= Max_Length then + Result.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + return Result; + + else + Result.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + Result.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + return Result; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + Max_Length : constant Positive := Source.Max_Length; + Endpos : constant Positive := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Endpos <= Slen then + Source.Data (Position .. Endpos) := New_Item; + + elsif Endpos <= Max_Length then + Source.Data (Position .. Endpos) := New_Item; + Source.Current_Length := Endpos; + + else + Source.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + + when Strings.Left => + if New_Item'Length > Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + + Source.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + --------------------------- + -- Super_Replace_Element -- + --------------------------- + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Character) + is + begin + if Index <= Source.Current_Length then + Source.Data (Index) := By; + else + raise Ada.Strings.Index_Error; + end if; + end Super_Replace_Element; + + ------------------------- + -- Super_Replace_Slice -- + ------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + + begin + if Low > Slen + 1 then + raise Strings.Index_Error; + + elsif High < Low then + return Super_Insert (Source, Low, By, Drop); + + else + declare + Blen : constant Natural := Natural'Max (0, Low - 1); + Alen : constant Natural := Natural'Max (0, Slen - High); + Tlen : constant Natural := Blen + By'Length + Alen; + Droplen : constant Integer := Tlen - Max_Length; + Result : Super_String (Max_Length); + + -- Tlen is the total length of the result string before any + -- truncation. Blen and Alen are the lengths of the pieces + -- of the original string that end up in the result string + -- before and after the replaced slice. + + begin + if Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Tlen) := + Source.Data (High + 1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Low .. Max_Length) := + By (By'First .. By'First + Max_Length - Low); + else + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Max_Length) := + Source.Data (High + 1 .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (High + 1 .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + By (By'Last - (Max_Length - Alen) + 1 .. By'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := By; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end; + end if; + end Super_Replace_Slice; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Replace_Slice (Source, Low, High, By, Drop); + end Super_Replace_Slice; + + --------------------- + -- Super_Replicate -- + --------------------- + + function Super_Replicate + (Count : Natural; + Item : Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Count <= Max_Length then + Result.Current_Length := Count; + + elsif Drop = Strings.Error then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Max_Length; + end if; + + Result.Data (1 .. Result.Current_Length) := (others => Item); + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Length : constant Integer := Count * Item'Length; + Result : Super_String (Max_Length); + Indx : Positive; + + begin + if Length <= Max_Length then + Result.Current_Length := Length; + + if Length > 0 then + Indx := 1; + + for J in 1 .. Count loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + end if; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Indx := 1; + + while Indx + Item'Length <= Max_Length + 1 loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + + Result.Data (Indx .. Max_Length) := + Item (Item'First .. Item'First + Max_Length - Indx); + + when Strings.Left => + Indx := Max_Length; + + while Indx - Item'Length >= 1 loop + Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; + Indx := Indx - Item'Length; + end loop; + + Result.Data (1 .. Indx) := + Item (Item'Last - Indx + 1 .. Item'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + begin + return + Super_Replicate + (Count, + Item.Data (1 .. Item.Current_Length), + Drop, + Item.Max_Length); + end Super_Replicate; + + ----------------- + -- Super_Slice -- + ----------------- + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Wide_String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + return R : Wide_String (Low .. High) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + R := Source.Data (Low .. High); + end return; + end Super_Slice; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String + is + begin + return Result : Super_String (Source.Max_Length) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + Result.Current_Length := High - Low + 1; + Result.Data (1 .. Result.Current_Length) := Source.Data (Low .. High); + end return; + end Super_Slice; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural) + is + begin + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + Target.Current_Length := High - Low + 1; + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); + end if; + end Super_Slice; + + ---------------- + -- Super_Tail -- + ---------------- + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := + Source.Data (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Max_Length) := + Source.Data (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + Result.Data (1 .. Max_Length - Slen) := (others => Pad); + Result.Data (Max_Length - Slen + 1 .. Max_Length) := + Source.Data (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Tail; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + Temp : constant Wide_String (1 .. Max_Length) := Source.Data; + + begin + if Npad <= 0 then + Source.Current_Length := Count; + Source.Data (1 .. Count) := + Temp (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Source.Data := (others => Pad); + + else + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Max_Length) := + Temp (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + for J in 1 .. Max_Length - Slen loop + Source.Data (J) := Pad; + end loop; + + Source.Data (Max_Length - Slen + 1 .. Max_Length) := + Temp (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Tail; + + --------------------- + -- Super_To_String -- + --------------------- + + function Super_To_String (Source : Super_String) return Wide_String is + begin + return R : Wide_String (1 .. Source.Current_Length) do + R := Source.Data (1 .. Source.Current_Length); + end return; + end Super_To_String; + + --------------------- + -- Super_Translate -- + --------------------- + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + end Super_Translate; + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Mapping.all (Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Mapping.all (Source.Data (J)); + end loop; + end Super_Translate; + + ---------------- + -- Super_Trim -- + ---------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String + is + Result : Super_String (Source.Max_Length); + Last : Natural := Source.Current_Length; + First : Positive := 1; + + begin + if Side = Left or else Side = Both then + while First <= Last and then Source.Data (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Source.Data (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End) + is + Max_Length : constant Positive := Source.Max_Length; + Last : Natural := Source.Current_Length; + First : Positive := 1; + Temp : Wide_String (1 .. Max_Length); + + begin + Temp (1 .. Last) := Source.Data (1 .. Last); + + if Side = Left or else Side = Both then + while First <= Last and then Temp (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Temp (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Source.Data := (others => Wide_NUL); + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); + end Super_Trim; + + function Super_Trim + (Source : Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (First .. Last); + return Result; + end if; + end loop; + end if; + end loop; + + Result.Current_Length := 0; + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + if First = 1 then + Source.Current_Length := Last; + return; + else + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := + Source.Data (First .. Last); + + for J in Source.Current_Length + 1 .. + Source.Max_Length + loop + Source.Data (J) := Wide_NUL; + end loop; + + return; + end if; + end if; + end loop; + + Source.Current_Length := 0; + return; + end if; + end loop; + + Source.Current_Length := 0; + end Super_Trim; + + ----------- + -- Times -- + ----------- + + function Times + (Left : Natural; + Right : Wide_Character; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Left > Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Left; + + for J in 1 .. Left loop + Result.Data (J) := Right; + end loop; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Wide_String; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Max_Length then + raise Ada.Strings.Index_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := Right; + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := + Right.Data (1 .. Rlen); + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + --------------------- + -- To_Super_String -- + --------------------- + + function To_Super_String + (Source : Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String + is + Result : Super_String (Max_Length); + Slen : constant Natural := Source'Length; + + begin + if Slen <= Max_Length then + Result.Current_Length := Slen; + Result.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end To_Super_String; + +end Ada.Strings.Wide_Superbounded; diff --git a/gcc/ada/libgnat/a-stwisu.ads b/gcc/ada/libgnat/a-stwisu.ads new file mode 100644 index 0000000..e14d7dc --- /dev/null +++ b/gcc/ada/libgnat/a-stwisu.ads @@ -0,0 +1,499 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ S U P E R B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This non generic package contains most of the implementation of the +-- generic package Ada.Strings.Wide_Bounded.Generic_Bounded_Length. + +-- It defines type Super_String as a discriminated record with the maximum +-- length as the discriminant. Individual instantiations of the package +-- Strings.Wide_Bounded.Generic_Bounded_Length use this type with +-- an appropriate discriminant value set. + +with Ada.Strings.Wide_Maps; + +package Ada.Strings.Wide_Superbounded is + pragma Preelaborate; + + Wide_NUL : constant Wide_Character := Wide_Character'Val (0); + + -- Ada.Strings.Wide_Bounded.Generic_Bounded_Length.Wide_Bounded_String is + -- derived from Super_String, with the constraint of the maximum length. + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : Wide_String (1 .. Max_Length); + -- A previous version had a default initial value for Data, which is + -- no longer necessary, because we now special-case this type in the + -- compiler, so "=" composes properly for descendants of this type. + -- Leaving it out is more efficient. + end record; + + -- The subprograms defined for Super_String are similar to those defined + -- for Bounded_Wide_String, except that they have different names, so that + -- they can be renamed in Ada.Strings.Wide_Bounded.Generic_Bounded_Length. + + function Super_Length (Source : Super_String) return Natural; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Super_String + (Source : Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String; + -- Note the additional parameter Max_Length, which specifies the maximum + -- length setting of the resulting Super_String value. + + -- The following procedures have declarations (and semantics) that are + -- exactly analogous to those declared in Ada.Strings.Wide_Bounded. + + function Super_To_String (Source : Super_String) return Wide_String; + + procedure Set_Super_String + (Target : out Super_String; + Source : Wide_String; + Drop : Truncation := Error); + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Wide_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_Character; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Wide_Character; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Character; + Drop : Truncation := Error); + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_String) return Super_String; + + function Concat + (Left : Wide_String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_Character) return Super_String; + + function Concat + (Left : Wide_Character; + Right : Super_String) return Super_String; + + function Super_Element + (Source : Super_String; + Index : Positive) return Wide_Character; + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Character); + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Wide_String; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural); + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean; + + function Equal + (Left : Super_String; + Right : Super_String) return Boolean renames "="; + + function Equal + (Left : Super_String; + Right : Wide_String) return Boolean; + + function Equal + (Left : Wide_String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Wide_String) return Boolean; + + function Less + (Left : Wide_String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_String) return Boolean; + + function Less_Or_Equal + (Left : Wide_String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Wide_String) return Boolean; + + function Greater + (Left : Wide_String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_String) return Boolean; + + function Greater_Or_Equal + (Left : Wide_String; + Right : Super_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Super_Index + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Super_Index + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Super_Count + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_String; + Drop : Truncation := Error); + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_String; + Drop : Truncation := Error); + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End); + + function Super_Trim + (Source : Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error); + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Character := Wide_Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + -- Note: in some of the following routines, there is an extra parameter + -- Max_Length which specifies the value of the maximum length for the + -- resulting Super_String value. + + function Times + (Left : Natural; + Right : Wide_Character; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Wide_String; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Super_String) return Super_String; + + function Super_Replicate + (Count : Natural; + Item : Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Truncation := Error) return Super_String; + +private + -- Pragma Inline declarations + + pragma Inline ("="); + pragma Inline (Less); + pragma Inline (Less_Or_Equal); + pragma Inline (Greater); + pragma Inline (Greater_Or_Equal); + pragma Inline (Concat); + pragma Inline (Super_Count); + pragma Inline (Super_Element); + pragma Inline (Super_Find_Token); + pragma Inline (Super_Index); + pragma Inline (Super_Index_Non_Blank); + pragma Inline (Super_Length); + pragma Inline (Super_Replace_Element); + pragma Inline (Super_Slice); + pragma Inline (Super_To_String); + +end Ada.Strings.Wide_Superbounded; diff --git a/gcc/ada/libgnat/a-stwiun-shared.adb b/gcc/ada/libgnat/a-stwiun-shared.adb new file mode 100644 index 0000000..479e66a --- /dev/null +++ b/gcc/ada/libgnat/a-stwiun-shared.adb @@ -0,0 +1,2128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Unbounded is + + use Ada.Strings.Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left string is empty, return Rigth string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String + is + LR : constant Shared_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + RR : constant Shared_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + LR : constant Shared_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + RR : constant Shared_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + return Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean is + begin + return + System.Atomic_Counters.Is_One (Item.Counter) + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_String) is + SR : constant Shared_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + Wide_Search.Find_Token + (SR.Data (From .. SR.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + Wide_Search.Find_Token + (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_String_Access := Source.Reference; + begin + return Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_String_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String) + is + TR : constant Shared_Wide_String_Access := Target.Reference; + DR : Shared_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_String_Access; + DR : Shared_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + -------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_String; + + ------------------------------ + -- To_Unbounded_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + if Source'Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String + is + DR : Shared_Wide_String_Access; + + begin + if Length = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DR : Shared_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String + is + SR : constant Shared_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + DR := Empty_Shared_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_String_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_String, Shared_Wide_String_Access); + + Aux : Shared_Wide_String_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + + -- Reference counter of Empty_Shared_Wide_String must never reach + -- zero. + + pragma Assert (Aux /= Empty_Shared_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stwiun-shared.ads b/gcc/ada/libgnat/a-stwiun-shared.ads new file mode 100644 index 0000000..a913df4 --- /dev/null +++ b/gcc/ada/libgnat/a-stwiun-shared.ads @@ -0,0 +1,494 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Maps; +private with Ada.Finalization; +private with System.Atomic_Counters; + +package Ada.Strings.Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String; + + function Length (Source : Unbounded_Wide_String) return Natural; + + type Wide_String_Access is access all Wide_String; + + procedure Free (X : in out Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String; + + function To_Wide_String + (Source : Unbounded_Wide_String) return Wide_String; + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character); + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character); + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String); + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String); + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String); + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_String (Max_Length : Natural) is limited record + Counter : System.Atomic_Counters.Atomic_Counter; + -- Reference counter + + Last : Natural := 0; + Data : Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are just extra room for expansion. + end record; + + type Shared_Wide_String_Access is access all Shared_Wide_String; + + procedure Reference (Item : not null Shared_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when ref counter is zero + + function Can_Be_Reused + (Item : Shared_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_String can be reused. There are two criteria + -- when Shared_Wide_String can be reused: its reference counter must be one + -- (thus Shared_Wide_String is owned exclusively) and its size is + -- sufficient to store string with specified length effectively. + + function Allocate (Max_Length : Natural) return Shared_Wide_String_Access; + -- Allocates new Shared_Wide_String with at least specified maximum length. + -- Actual maximum length of the allocated Shared_Wide_String can be + -- slightly greater. Returns reference to Empty_Shared_Wide_String when + -- requested length is zero. + + Empty_Shared_Wide_String : aliased Shared_Wide_String (0); + + function To_Unbounded (S : Wide_String) return Unbounded_Wide_String + renames To_Unbounded_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert + + type Unbounded_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_String_Access := Empty_Shared_Wide_String'Access; + end record; + + -- The Unbounded_Wide_String uses several techniques to increase speed of + -- the application: + + -- - implicit sharing or copy-on-write. Unbounded_Wide_String contains + -- only the reference to the data which is shared between several + -- instances. The shared data is reallocated only when its value is + -- changed and the object mutation can't be used or it is inefficient to + -- use it; + + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less than some threshold. + + -- - memory preallocation. Most of used memory allocation algorithms + -- aligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. + + pragma Stream_Convert (Unbounded_Wide_String, To_Unbounded, To_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize (Object : in out Unbounded_Wide_String); + overriding procedure Adjust (Object : in out Unbounded_Wide_String); + overriding procedure Finalize (Object : in out Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String := + (AF.Controlled with + Reference => + Empty_Shared_Wide_String'Access); + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stwiun.adb b/gcc/ada/libgnat/a-stwiun.adb new file mode 100644 index 0000000..85bc494 --- /dev/null +++ b/gcc/ada/libgnat/a-stwiun.adb @@ -0,0 +1,1097 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Fixed; +with Ada.Strings.Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Unbounded is + + use Ada.Finalization; + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + L_Length : constant Natural := Left.Last; + R_Length : constant Natural := Right.Last; + Result : Unbounded_Wide_String; + + begin + Result.Last := L_Length + R_Length; + + Result.Reference := new Wide_String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := + Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String + is + L_Length : constant Natural := Left.Last; + Result : Unbounded_Wide_String; + + begin + Result.Last := L_Length + Right'Length; + + Result.Reference := new Wide_String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + R_Length : constant Natural := Right.Last; + Result : Unbounded_Wide_String; + + begin + Result.Last := Left'Length + R_Length; + + Result.Reference := new Wide_String (1 .. Result.Last); + + Result.Reference (1 .. Left'Length) := Left; + Result.Reference (Left'Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String + is + Result : Unbounded_Wide_String; + + begin + Result.Last := Left.Last + 1; + + Result.Reference := new Wide_String (1 .. Result.Last); + + Result.Reference (1 .. Result.Last - 1) := + Left.Reference (1 .. Left.Last); + Result.Reference (Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + Result : Unbounded_Wide_String; + + begin + Result.Last := Right.Last + 1; + + Result.Reference := new Wide_String (1 .. Result.Last); + Result.Reference (1) := Left; + Result.Reference (2 .. Result.Last) := + Right.Reference (1 .. Right.Last); + return Result; + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String + is + Result : Unbounded_Wide_String; + + begin + Result.Last := Left; + + Result.Reference := new Wide_String (1 .. Left); + for J in Result.Reference'Range loop + Result.Reference (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String + is + Len : constant Natural := Right'Length; + K : Positive; + Result : Unbounded_Wide_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new Wide_String (1 .. Result.Last); + + K := 1; + for J in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := Right; + K := K + Len; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String + is + Len : constant Natural := Right.Last; + K : Positive; + Result : Unbounded_Wide_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new Wide_String (1 .. Result.Last); + + K := 1; + for J in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := + Right.Reference (1 .. Right.Last); + K := K + Len; + end loop; + + return Result; + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) < Right; + end "<"; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return Left < Right.Reference (1 .. Right.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return Left <= Right.Reference (1 .. Right.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); + end "="; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) = Right; + end "="; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return Left = Right.Reference (1 .. Right.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) > Right; + end ">"; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return Left > Right.Reference (1 .. Right.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean + is + begin + return Left >= Right.Reference (1 .. Right.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_String) is + begin + -- Copy string, except we do not copy the statically allocated null + -- string, since it can never be deallocated. Note that we do not copy + -- extra string room here to avoid dragging unused allocated memory. + + if Object.Reference /= Null_Wide_String'Access then + Object.Reference := + new Wide_String'(Object.Reference (1 .. Object.Last)); + end if; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String) + is + begin + Realloc_For_Chunk (Source, New_Item.Last); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := + New_Item.Reference (1 .. New_Item.Last); + Source.Last := Source.Last + New_Item.Last; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String) + is + begin + Realloc_For_Chunk (Source, New_Item'Length); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := + New_Item; + Source.Last := Source.Last + New_Item'Length; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character) + is + begin + Realloc_For_Chunk (Source, 1); + Source.Reference (Source.Last + 1) := New_Item; + Source.Last := Source.Last + 1; + end Append; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return + Wide_Search.Count + (Source.Reference (1 .. Source.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + return + Wide_Search.Count + (Source.Reference (1 .. Source.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural + is + begin + return + Wide_Search.Count + (Source.Reference (1 .. Source.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String + is + begin + return + To_Unbounded_Wide_String + (Wide_Fixed.Delete + (Source.Reference (1 .. Source.Last), From, Through)); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural) + is + begin + if From > Through then + null; + + elsif From < Source.Reference'First or else Through > Source.Last then + raise Index_Error; + + else + declare + Len : constant Natural := Through - From + 1; + + begin + Source.Reference (From .. Source.Last - Len) := + Source.Reference (Through + 1 .. Source.Last); + Source.Last := Source.Last - Len; + end; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character + is + begin + if Index <= Source.Last then + return Source.Reference (Index); + else + raise Strings.Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_String) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + + begin + -- Note: Don't try to free statically allocated null string + + if Object.Reference /= Null_Wide_String'Access then + Deallocate (Object.Reference); + Object.Reference := Null_Unbounded_Wide_String.Reference; + Object.Last := 0; + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Search.Find_Token + (Source.Reference (From .. Source.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Search.Find_Token + (Source.Reference (1 .. Source.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + + begin + -- Note: Do not try to free statically allocated null string + + if X /= Null_Unbounded_Wide_String.Reference then + Deallocate (X); + end if; + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String + is + begin + return To_Unbounded_Wide_String + (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + Old : Wide_String_Access := Source.Reference; + begin + Source.Reference := + new Wide_String' + (Wide_Fixed.Head (Source.Reference (1 .. Source.Last), Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return + Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + return + Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Wide_Search.Index + (Source.Reference (1 .. Source.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural + is + begin + return + Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural + is + begin + return + Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + return + Wide_Search.Index + (Source.Reference (1 .. Source.Last), Set, From, Test, Going); + end Index; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return + Wide_Search.Index_Non_Blank + (Source.Reference (1 .. Source.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + return + Wide_Search.Index_Non_Blank + (Source.Reference (1 .. Source.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_String) is + begin + Object.Reference := Null_Unbounded_Wide_String.Reference; + Object.Last := 0; + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + begin + return + To_Unbounded_Wide_String + (Wide_Fixed.Insert + (Source.Reference (1 .. Source.Last), Before, New_Item)); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) + is + begin + if Before not in Source.Reference'First .. Source.Last + 1 then + raise Index_Error; + end if; + + Realloc_For_Chunk (Source, New_Item'Length); + + Source.Reference + (Before + New_Item'Length .. Source.Last + New_Item'Length) := + Source.Reference (Before .. Source.Last); + + Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; + Source.Last := Source.Last + New_Item'Length; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_String) return Natural is + begin + return Source.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String + is + begin + return + To_Unbounded_Wide_String + (Wide_Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) + is + NL : constant Natural := New_Item'Length; + begin + if Position <= Source.Last - NL + 1 then + Source.Reference (Position .. Position + NL - 1) := New_Item; + else + declare + Old : Wide_String_Access := Source.Reference; + begin + Source.Reference := new Wide_String' + (Wide_Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + Source.Last := Source.Reference'Length; + Free (Old); + end; + end if; + end Overwrite; + + ----------------------- + -- Realloc_For_Chunk -- + ----------------------- + + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_String; + Chunk_Size : Natural) + is + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + S_Length : constant Natural := Source.Reference'Length; + + begin + if Chunk_Size > S_Length - Source.Last then + declare + New_Size : constant Positive := + S_Length + Chunk_Size + (S_Length / Growth_Factor); + + New_Rounded_Up_Size : constant Positive := + ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc; + + Tmp : constant Wide_String_Access := + new Wide_String (1 .. New_Rounded_Up_Size); + + begin + Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); + Free (Source.Reference); + Source.Reference := Tmp; + end; + end if; + end Realloc_For_Chunk; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character) + is + begin + if Index <= Source.Last then + Source.Reference (Index) := By; + else + raise Strings.Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String + is + begin + return To_Unbounded_Wide_String + (Wide_Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) + is + Old : Wide_String_Access := Source.Reference; + begin + Source.Reference := new Wide_String' + (Wide_Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + Source.Last := Source.Reference'Length; + Free (Old); + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String) + is + begin + Target.Last := Source'Length; + Target.Reference := new Wide_String (1 .. Source'Length); + Target.Reference.all := Source; + end Set_Unbounded_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + return Source.Reference (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String is + begin + return To_Unbounded_Wide_String + (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) + is + Old : Wide_String_Access := Source.Reference; + begin + Source.Reference := new Wide_String' + (Wide_Fixed.Tail (Source.Reference (1 .. Source.Last), Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + end Tail; + + ------------------------------ + -- To_Unbounded_Wide_String -- + ------------------------------ + + function To_Unbounded_Wide_String + (Source : Wide_String) + return Unbounded_Wide_String + is + Result : Unbounded_Wide_String; + begin + Result.Last := Source'Length; + Result.Reference := new Wide_String (1 .. Source'Length); + Result.Reference.all := Source; + return Result; + end To_Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String + is + Result : Unbounded_Wide_String; + begin + Result.Last := Length; + Result.Reference := new Wide_String (1 .. Length); + return Result; + end To_Unbounded_Wide_String; + + ------------------- + -- To_Wide_String -- + -------------------- + + function To_Wide_String + (Source : Unbounded_Wide_String) + return Wide_String + is + begin + return Source.Reference (1 .. Source.Last); + end To_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Unbounded_Wide_String + is + begin + return + To_Unbounded_Wide_String + (Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + is + begin + Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String + is + begin + return + To_Unbounded_Wide_String + (Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + is + begin + Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String + is + begin + return + To_Unbounded_Wide_String + (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End) + is + Old : Wide_String_Access := Source.Reference; + begin + Source.Reference := + new Wide_String' + (Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + Source.Last := Source.Reference'Length; + Free (Old); + end Trim; + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + return Unbounded_Wide_String + is + begin + return + To_Unbounded_Wide_String + (Wide_Fixed.Trim + (Source.Reference (1 .. Source.Last), Left, Right)); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) + is + Old : Wide_String_Access := Source.Reference; + begin + Source.Reference := + new Wide_String' + (Wide_Fixed.Trim + (Source.Reference (1 .. Source.Last), Left, Right)); + Source.Last := Source.Reference'Length; + Free (Old); + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String + is + begin + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + return To_Unbounded_Wide_String (Source.Reference.all (Low .. High)); + end if; + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural) + is + begin + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + Target := + To_Unbounded_Wide_String (Source.Reference.all (Low .. High)); + end if; + end Unbounded_Slice; + +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stwiun.ads b/gcc/ada/libgnat/a-stwiun.ads new file mode 100644 index 0000000..3b232f2 --- /dev/null +++ b/gcc/ada/libgnat/a-stwiun.ads @@ -0,0 +1,443 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Maps; +with Ada.Finalization; + +package Ada.Strings.Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_String); + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String; + + function Length (Source : Unbounded_Wide_String) return Natural; + + type Wide_String_Access is access all Wide_String; + + procedure Free (X : in out Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_String + (Source : Wide_String) return Unbounded_Wide_String; + + function To_Unbounded_Wide_String + (Length : Natural) return Unbounded_Wide_String; + + function To_Wide_String + (Source : Unbounded_Wide_String) + return Wide_String; + + procedure Set_Unbounded_Wide_String + (Target : out Unbounded_Wide_String; + Source : Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Unbounded_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_String; + New_Item : Wide_Character); + + function "&" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function "&" + (Left : Unbounded_Wide_String; + Right : Wide_Character) return Unbounded_Wide_String; + + function "&" + (Left : Wide_Character; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + + function Element + (Source : Unbounded_Wide_String; + Index : Positive) return Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_String; + Index : Positive; + By : Wide_Character); + + function Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_String; + Target : out Unbounded_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function "<=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_String; + Right : Wide_String) return Boolean; + + function ">=" + (Left : Wide_String; + Right : Unbounded_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping := Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_String; + Pattern : Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) return Natural; + + function Count + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_Wide_String; + Set : Wide_Maps.Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function) + return Unbounded_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_String; + Mapping : Wide_Maps.Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String) return Unbounded_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_String; + Low : Positive; + High : Natural; + By : Wide_String); + + function Insert + (Source : Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_String; + Before : Positive; + New_Item : Wide_String); + + function Overwrite + (Source : Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String) return Unbounded_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_String; + Position : Positive; + New_Item : Wide_String); + + function Delete + (Source : Unbounded_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_String; + Side : Trim_End) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set) return Unbounded_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_String; + Left : Wide_Maps.Wide_Character_Set; + Right : Wide_Maps.Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function Tail + (Source : Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space) return Unbounded_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_String; + Count : Natural; + Pad : Wide_Character := Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Character) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_String) return Unbounded_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_String) return Unbounded_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + Null_Wide_String : aliased Wide_String := ""; + + function To_Unbounded_Wide (S : Wide_String) return Unbounded_Wide_String + renames To_Unbounded_Wide_String; + + type Unbounded_Wide_String is new AF.Controlled with record + Reference : Wide_String_Access := Null_Wide_String'Access; + Last : Natural := 0; + end record; + + -- The Unbounded_Wide_String is using a buffered implementation to increase + -- speed of the Append/Delete/Insert procedures. The Reference string + -- pointer above contains the current string value and extra room at the + -- end to be used by the next Append routine. Last is the index of the + -- string ending character. So the current string value is really + -- Reference (1 .. Last). + + pragma Stream_Convert + (Unbounded_Wide_String, To_Unbounded_Wide, To_Wide_String); + + pragma Finalize_Storage_Only (Unbounded_Wide_String); + -- Finalization is required only for freeing storage + + procedure Initialize (Object : in out Unbounded_Wide_String); + procedure Adjust (Object : in out Unbounded_Wide_String); + procedure Finalize (Object : in out Unbounded_Wide_String); + + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_String; + Chunk_Size : Natural); + -- Adjust the size allocated for the string. Add at least Chunk_Size so it + -- is safe to add a string of this size at the end of the current content. + -- The real size allocated for the string is Chunk_Size + x of the current + -- string size. This buffered handling makes the Append unbounded string + -- routines very fast. + + Null_Unbounded_Wide_String : constant Unbounded_Wide_String := + (AF.Controlled with + Reference => Null_Wide_String'Access, + Last => 0); +end Ada.Strings.Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzbou.adb b/gcc/ada/libgnat/a-stzbou.adb new file mode 100644 index 0000000..f7d566a --- /dev/null +++ b/gcc/ada/libgnat/a-stzbou.adb @@ -0,0 +1,94 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Wide_Bounded is + + package body Generic_Bounded_Length is + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String + is + begin + return Times (Left, Right, Max_Length); + end "*"; + + --------------- + -- Replicate -- + --------------- + + function Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_Wide_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + function Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_Wide_String + is + begin + return Super_Replicate (Count, Item, Drop, Max_Length); + end Replicate; + + --------------------------------- + -- To_Bounded_Wide_Wide_String -- + --------------------------------- + + function To_Bounded_Wide_Wide_String + (Source : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + return Bounded_Wide_Wide_String + is + begin + return To_Super_String (Source, Max_Length, Drop); + end To_Bounded_Wide_Wide_String; + + end Generic_Bounded_Length; +end Ada.Strings.Wide_Wide_Bounded; diff --git a/gcc/ada/libgnat/a-stzbou.ads b/gcc/ada/libgnat/a-stzbou.ads new file mode 100644 index 0000000..fb413dc --- /dev/null +++ b/gcc/ada/libgnat/a-stzbou.ads @@ -0,0 +1,937 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Maps; +with Ada.Strings.Wide_Wide_Superbounded; + +package Ada.Strings.Wide_Wide_Bounded is + pragma Preelaborate; + + generic + Max : Positive; + -- Maximum length of a Bounded_Wide_Wide_String + + package Generic_Bounded_Length is + + Max_Length : constant Positive := Max; + + type Bounded_Wide_Wide_String is private; + pragma Preelaborable_Initialization (Bounded_Wide_Wide_String); + + Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String; + + subtype Length_Range is Natural range 0 .. Max_Length; + + function Length (Source : Bounded_Wide_Wide_String) return Length_Range; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Bounded_Wide_Wide_String + (Source : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Bounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Bounded_Wide_Wide_String + (Target : out Bounded_Wide_Wide_String; + Source : Wide_Wide_String; + Drop : Truncation := Error); + pragma Ada_05 (Set_Bounded_Wide_Wide_String); + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Append + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error); + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function Element + (Source : Bounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Bounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Bounded_Wide_Wide_String; + pragma Ada_05 (Bounded_Slice); + + procedure Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Target : out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Bounded_Slice); + + function "=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Bounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Bounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Bounded_Wide_Wide_String; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Bounded_Wide_Wide_String; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error); + + function Insert + (Source : Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Insert + (Source : in out Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Delete + (Source : Bounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Bounded_Wide_Wide_String; + + procedure Delete + (Source : in out Bounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Trim + (Source : Bounded_Wide_Wide_String; + Side : Trim_End) return Bounded_Wide_Wide_String; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Bounded_Wide_Wide_String; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Head + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + function Tail + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + procedure Tail + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String; + + function Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + function Replicate + (Count : Natural; + Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String; + + private + -- Most of the implementation is in the separate non generic package + -- Ada.Strings.Wide_Wide_Superbounded. Type Bounded_Wide_Wide_String is + -- derived from type Wide_Wide_Superbounded.Super_String with the + -- maximum length constraint. In almost all cases, the routines in + -- Wide_Wide_Superbounded can be called with no requirement to pass the + -- maximum length explicitly, since there is at least one + -- Bounded_Wide_Wide_String argument from which the maximum length can + -- be obtained. For all such routines, the implementation in this + -- private part is simply renaming of the corresponding routine in the + -- super bouded package. + + -- The five exceptions are the * and Replicate routines operating on + -- character values. For these cases, we have a routine in the body + -- that calls the superbounded routine passing the maximum length + -- explicitly as an extra parameter. + + type Bounded_Wide_Wide_String is + new Wide_Wide_Superbounded.Super_String (Max_Length); + -- Deriving Bounded_Wide_Wide_String from + -- Wide_Wide_Superbounded.Super_String is the real trick, it ensures + -- that the type Bounded_Wide_Wide_String declared in the generic + -- instantiation is compatible with the Super_String type declared in + -- the Wide_Wide_Superbounded package. + + Null_Bounded_Wide_Wide_String : constant Bounded_Wide_Wide_String := + (Max_Length => Max_Length, + Current_Length => 0, + Data => + (1 .. Max_Length => + Wide_Wide_Superbounded.Wide_Wide_NUL)); + + pragma Inline (To_Bounded_Wide_Wide_String); + + procedure Set_Bounded_Wide_Wide_String + (Target : out Bounded_Wide_Wide_String; + Source : Wide_Wide_String; + Drop : Truncation := Error) + renames Set_Super_String; + + function Length + (Source : Bounded_Wide_Wide_String) return Length_Range + renames Super_Length; + + function To_Wide_Wide_String + (Source : Bounded_Wide_Wide_String) return Wide_Wide_String + renames Super_To_String; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + function Append + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Append; + + procedure Append + (Source : in out Bounded_Wide_Wide_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error) + renames Super_Append; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Bounded_Wide_Wide_String + renames Concat; + + function "&" + (Left : Wide_Wide_Character; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Concat; + + function Element + (Source : Bounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + renames Super_Element; + + procedure Replace_Element + (Source : in out Bounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + renames Super_Replace_Element; + + function Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + renames Super_Slice; + + function Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Bounded_Wide_Wide_String + renames Super_Slice; + + procedure Bounded_Slice + (Source : Bounded_Wide_Wide_String; + Target : out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural) + renames Super_Slice; + + overriding function "=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Equal; + + function "=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Equal; + + function "=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Equal; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less; + + function "<" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Less; + + function "<" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Less_Or_Equal; + + function "<=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Less_Or_Equal; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater; + + function ">" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Greater; + + function ">" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : Bounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + renames Greater_Or_Equal; + + function ">=" + (Left : Wide_Wide_String; + Right : Bounded_Wide_Wide_String) return Boolean + renames Greater_Or_Equal; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Super_Index; + + function Index + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Super_Index; + + function Index_Non_Blank + (Source : Bounded_Wide_Wide_String; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Index_Non_Blank + (Source : Bounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + renames Super_Index_Non_Blank; + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Super_Count; + + function Count + (Source : Bounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Super_Count; + + function Count + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + renames Super_Count; + + procedure Find_Token + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Super_Find_Token; + + procedure Find_Token + (Source : Bounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Super_Find_Token; + + function Translate + (Source : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Bounded_Wide_Wide_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + renames Super_Translate; + + function Translate + (Source : Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Bounded_Wide_Wide_String + renames Super_Translate; + + procedure Translate + (Source : in out Bounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + renames Super_Translate; + + function Replace_Slice + (Source : Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Replace_Slice; + + procedure Replace_Slice + (Source : in out Bounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Replace_Slice; + + function Insert + (Source : Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Insert; + + procedure Insert + (Source : in out Bounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Insert; + + function Overwrite + (Source : Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Overwrite; + + procedure Overwrite + (Source : in out Bounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + renames Super_Overwrite; + + function Delete + (Source : Bounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Bounded_Wide_Wide_String + renames Super_Delete; + + procedure Delete + (Source : in out Bounded_Wide_Wide_String; + From : Positive; + Through : Natural) + renames Super_Delete; + + function Trim + (Source : Bounded_Wide_Wide_String; + Side : Trim_End) return Bounded_Wide_Wide_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Side : Trim_End) + renames Super_Trim; + + function Trim + (Source : Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Bounded_Wide_Wide_String + renames Super_Trim; + + procedure Trim + (Source : in out Bounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + renames Super_Trim; + + function Head + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Head; + + procedure Head + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + renames Super_Head; + + function Tail + (Source : Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Tail; + + procedure Tail + (Source : in out Bounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + renames Super_Tail; + + function "*" + (Left : Natural; + Right : Bounded_Wide_Wide_String) return Bounded_Wide_Wide_String + renames Times; + + function Replicate + (Count : Natural; + Item : Bounded_Wide_Wide_String; + Drop : Truncation := Error) return Bounded_Wide_Wide_String + renames Super_Replicate; + + end Generic_Bounded_Length; + +end Ada.Strings.Wide_Wide_Bounded; diff --git a/gcc/ada/libgnat/a-stzfix.adb b/gcc/ada/libgnat/a-stzfix.adb new file mode 100644 index 0000000..7369208 --- /dev/null +++ b/gcc/ada/libgnat/a-stzfix.adb @@ -0,0 +1,694 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ F I X E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps; +with Ada.Strings.Wide_Wide_Search; + +package body Ada.Strings.Wide_Wide_Fixed is + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index; + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + renames Ada.Strings.Wide_Wide_Search.Index_Non_Blank; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural + renames Ada.Strings.Wide_Wide_Search.Count; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + renames Ada.Strings.Wide_Wide_Search.Count; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + renames Ada.Strings.Wide_Wide_Search.Count; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Wide_Wide_Search.Find_Token; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + renames Ada.Strings.Wide_Wide_Search.Find_Token; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Left); + + begin + for J in Result'Range loop + Result (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Left * Right'Length); + Ptr : Integer := 1; + + begin + for J in 1 .. Left loop + Result (Ptr .. Ptr + Right'Length - 1) := Right; + Ptr := Ptr + Right'Length; + end loop; + + return Result; + end "*"; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Wide_Wide_String; + From : Positive; + Through : Natural) return Wide_Wide_String + is + begin + if From not in Source'Range + or else Through > Source'Last + then + raise Index_Error; + + elsif From > Through then + return Source; + + else + declare + Len : constant Integer := Source'Length - (Through - From + 1); + Result : constant Wide_Wide_String + (Source'First .. Source'First + Len - 1) := + Source (Source'First .. From - 1) & + Source (Through + 1 .. Source'Last); + begin + return Result; + end; + end if; + end Delete; + + procedure Delete + (Source : in out Wide_Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Delete (Source, From, Through), + Target => Source, + Justify => Justify, + Pad => Pad); + end Delete; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Count); + + begin + if Count <= Source'Length then + Result := Source (Source'First .. Source'First + Count - 1); + + else + Result (1 .. Source'Length) := Source; + + for J in Source'Length + 1 .. Count loop + Result (J) := Pad; + end loop; + end if; + + return Result; + end Head; + + procedure Head + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + is + begin + Move (Source => Head (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Head; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length + New_Item'Length); + + begin + if Before < Source'First or else Before > Source'Last + 1 then + raise Index_Error; + end if; + + Result := Source (Source'First .. Before - 1) & New_Item & + Source (Before .. Source'Last); + return Result; + end Insert; + + procedure Insert + (Source : in out Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + is + begin + Move (Source => Insert (Source, Before, New_Item), + Target => Source, + Drop => Drop); + end Insert; + + ---------- + -- Move -- + ---------- + + procedure Move + (Source : Wide_Wide_String; + Target : out Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + Sfirst : constant Integer := Source'First; + Slast : constant Integer := Source'Last; + Slength : constant Integer := Source'Length; + + Tfirst : constant Integer := Target'First; + Tlast : constant Integer := Target'Last; + Tlength : constant Integer := Target'Length; + + function Is_Padding (Item : Wide_Wide_String) return Boolean; + -- Determinbe if all characters in Item are pad characters + + function Is_Padding (Item : Wide_Wide_String) return Boolean is + begin + for J in Item'Range loop + if Item (J) /= Pad then + return False; + end if; + end loop; + + return True; + end Is_Padding; + + -- Start of processing for Move + + begin + if Slength = Tlength then + Target := Source; + + elsif Slength > Tlength then + case Drop is + when Left => + Target := Source (Slast - Tlength + 1 .. Slast); + + when Right => + Target := Source (Sfirst .. Sfirst + Tlength - 1); + + when Error => + case Justify is + when Left => + if Is_Padding (Source (Sfirst + Tlength .. Slast)) then + Target := + Source (Sfirst .. Sfirst + Target'Length - 1); + else + raise Length_Error; + end if; + + when Right => + if Is_Padding (Source (Sfirst .. Slast - Tlength)) then + Target := Source (Slast - Tlength + 1 .. Slast); + else + raise Length_Error; + end if; + + when Center => + raise Length_Error; + end case; + + end case; + + -- Source'Length < Target'Length + + else + case Justify is + when Left => + Target (Tfirst .. Tfirst + Slength - 1) := Source; + + for J in Tfirst + Slength .. Tlast loop + Target (J) := Pad; + end loop; + + when Right => + for J in Tfirst .. Tlast - Slength loop + Target (J) := Pad; + end loop; + + Target (Tlast - Slength + 1 .. Tlast) := Source; + + when Center => + declare + Front_Pad : constant Integer := (Tlength - Slength) / 2; + Tfirst_Fpad : constant Integer := Tfirst + Front_Pad; + + begin + for J in Tfirst .. Tfirst_Fpad - 1 loop + Target (J) := Pad; + end loop; + + Target (Tfirst_Fpad .. Tfirst_Fpad + Slength - 1) := Source; + + for J in Tfirst_Fpad + Slength .. Tlast loop + Target (J) := Pad; + end loop; + end; + end case; + end if; + end Move; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String + is + begin + if Position not in Source'First .. Source'Last + 1 then + raise Index_Error; + else + declare + Result_Length : constant Natural := + Natural'Max + (Source'Length, + Position - Source'First + New_Item'Length); + + Result : Wide_Wide_String (1 .. Result_Length); + + begin + Result := Source (Source'First .. Position - 1) & New_Item & + Source (Position + New_Item'Length .. Source'Last); + return Result; + end; + end if; + end Overwrite; + + procedure Overwrite + (Source : in out Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Right) + is + begin + Move (Source => Overwrite (Source, Position, New_Item), + Target => Source, + Drop => Drop); + end Overwrite; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Wide_Wide_String + is + begin + if Low > Source'Last + 1 or else High < Source'First - 1 then + raise Index_Error; + end if; + + if High >= Low then + declare + Front_Len : constant Integer := + Integer'Max (0, Low - Source'First); + -- Length of prefix of Source copied to result + + Back_Len : constant Integer := + Integer'Max (0, Source'Last - High); + -- Length of suffix of Source copied to result + + Result_Length : constant Integer := + Front_Len + By'Length + Back_Len; + -- Length of result + + Result : Wide_Wide_String (1 .. Result_Length); + + begin + Result (1 .. Front_Len) := Source (Source'First .. Low - 1); + Result (Front_Len + 1 .. Front_Len + By'Length) := By; + Result (Front_Len + By'Length + 1 .. Result'Length) := + Source (High + 1 .. Source'Last); + return Result; + end; + + else + return Insert (Source, Before => Low, New_Item => By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Replace_Slice (Source, Low, High, By), Source, Drop, Justify, Pad); + end Replace_Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Count); + + begin + if Count < Source'Length then + Result := Source (Source'Last - Count + 1 .. Source'Last); + + -- Pad on left + + else + for J in 1 .. Count - Source'Length loop + Result (J) := Pad; + end loop; + + Result (Count - Source'Length + 1 .. Count) := Source; + end if; + + return Result; + end Tail; + + procedure Tail + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + is + begin + Move (Source => Tail (Source, Count, Pad), + Target => Source, + Drop => Error, + Justify => Justify, + Pad => Pad); + end Tail; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Value (Mapping, Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + begin + for J in Source'Range loop + Source (J) := Value (Mapping, Source (J)); + end loop; + end Translate; + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Wide_Wide_String + is + Result : Wide_Wide_String (1 .. Source'Length); + + begin + for J in Source'Range loop + Result (J - (Source'First - 1)) := Mapping (Source (J)); + end loop; + + return Result; + end Translate; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + begin + for J in Source'Range loop + Source (J) := Mapping (Source (J)); + end loop; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Wide_Wide_String; + Side : Trim_End) return Wide_Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + if Side = Left or else Side = Both then + while Low <= High and then Source (Low) = Wide_Wide_Space loop + Low := Low + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while High >= Low and then Source (High) = Wide_Wide_Space loop + High := High - 1; + end loop; + end if; + + -- All blanks case + + if Low > High then + return ""; + + -- At least one non-blank + + else + declare + Result : constant Wide_Wide_String (1 .. High - Low + 1) := + Source (Low .. High); + + begin + return Result; + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Trim (Source, Side), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + + function Trim + (Source : Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Wide_Wide_String + is + Low : Natural := Source'First; + High : Natural := Source'Last; + + begin + while Low <= High and then Is_In (Source (Low), Left) loop + Low := Low + 1; + end loop; + + while High >= Low and then Is_In (Source (High), Right) loop + High := High - 1; + end loop; + + -- Case where source comprises only characters in the sets + + if Low > High then + return ""; + else + declare + subtype WS is Wide_Wide_String (1 .. High - Low + 1); + + begin + return WS (Source (Low .. High)); + end; + end if; + end Trim; + + procedure Trim + (Source : in out Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set; + Justify : Alignment := Strings.Left; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + begin + Move (Source => Trim (Source, Left, Right), + Target => Source, + Justify => Justify, + Pad => Pad); + end Trim; + +end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/libgnat/a-stzfix.ads b/gcc/ada/libgnat/a-stzfix.ads new file mode 100644 index 0000000..bee7658 --- /dev/null +++ b/gcc/ada/libgnat/a-stzfix.ads @@ -0,0 +1,264 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Maps; + +package Ada.Strings.Wide_Wide_Fixed is + pragma Preelaborate; + + ------------------------------------------------------------------------ + -- Copy Procedure for Wide_Wide_Strings of Possibly Different Lengths -- + ------------------------------------------------------------------------ + + procedure Move + (Source : Wide_Wide_String; + Target : out Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ---------------------------------------------- + -- Wide_Wide_String Translation Subprograms -- + ---------------------------------------------- + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Wide_Wide_String; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Wide_Wide_String; + + procedure Translate + (Source : in out Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + ------------------------------------------------- + -- Wide_Wide_String Transformation Subprograms -- + ------------------------------------------------- + + function Replace_Slice + (Source : Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Insert + (Source : Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String; + + procedure Insert + (Source : in out Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Overwrite + (Source : Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Wide_Wide_String; + + procedure Overwrite + (Source : in out Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Right); + + function Delete + (Source : Wide_Wide_String; + From : Positive; + Through : Natural) return Wide_Wide_String; + + procedure Delete + (Source : in out Wide_Wide_String; + From : Positive; + Through : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + ------------------------------------------- + -- Wide_Wide_String Selector Subprograms -- + ------------------------------------------- + + function Trim + (Source : Wide_Wide_String; + Side : Trim_End) return Wide_Wide_String; + + procedure Trim + (Source : in out Wide_Wide_String; + Side : Trim_End; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Trim + (Source : Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Wide_Wide_String; + + procedure Trim + (Source : in out Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set; + Justify : Alignment := Ada.Strings.Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Head + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + return Wide_Wide_String; + + procedure Head + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + function Tail + (Source : Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space) + return Wide_Wide_String; + + procedure Tail + (Source : in out Wide_Wide_String; + Count : Natural; + Justify : Alignment := Left; + Pad : Wide_Wide_Character := Ada.Strings.Wide_Wide_Space); + + -------------------------------------------- + -- Wide_Wide_String Constructor Functions -- + -------------------------------------------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Fixed; diff --git a/gcc/ada/libgnat/a-stzhas.adb b/gcc/ada/libgnat/a-stzhas.adb new file mode 100644 index 0000000..9856476 --- /dev/null +++ b/gcc/ada/libgnat/a-stzhas.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is an instantiation. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/a-stzhas.ads b/gcc/ada/libgnat/a-stzhas.ads new file mode 100644 index 0000000..0c87672 --- /dev/null +++ b/gcc/ada/libgnat/a-stzhas.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Is this really an RM unit? Doc needed??? + +with Ada.Containers; +with System.String_Hash; + +function Ada.Strings.Wide_Wide_Hash +is new System.String_Hash.Hash + (Wide_Wide_Character, Wide_Wide_String, Containers.Hash_Type); + +pragma Pure (Ada.Strings.Wide_Wide_Hash); diff --git a/gcc/ada/libgnat/a-stzmap.adb b/gcc/ada/libgnat/a-stzmap.adb new file mode 100644 index 0000000..e70898d --- /dev/null +++ b/gcc/ada/libgnat/a-stzmap.adb @@ -0,0 +1,747 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ M A P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Maps is + + --------- + -- "-" -- + --------- + + function "-" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); + -- Each range on the right can generate at least one more range in + -- the result, by splitting one of the left operand ranges. + + N : Natural := 0; + R : Natural := 1; + L : Natural := 1; + + Left_Low : Wide_Wide_Character; + -- Left_Low is lowest character of the L'th range not yet dealt with + + begin + if LS'Last = 0 or else RS'Last = 0 then + return Left; + end if; + + Left_Low := LS (L).Low; + while R <= RS'Last loop + + -- If next right range is below current left range, skip it + + if RS (R).High < Left_Low then + R := R + 1; + + -- If next right range above current left range, copy remainder of + -- the left range to the result + + elsif RS (R).Low > LS (L).High then + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := LS (L).High; + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + + else + -- Next right range overlaps bottom of left range + + if RS (R).Low <= Left_Low then + + -- Case of right range complete overlaps left range + + if RS (R).High >= LS (L).High then + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + + -- Case of right range eats lower part of left range + + else + Left_Low := Wide_Wide_Character'Succ (RS (R).High); + R := R + 1; + end if; + + -- Next right range overlaps some of left range, but not bottom + + else + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := Wide_Wide_Character'Pred (RS (R).Low); + + -- Case of right range splits left range + + if RS (R).High < LS (L).High then + Left_Low := Wide_Wide_Character'Succ (RS (R).High); + R := R + 1; + + -- Case of right range overlaps top of left range + + else + L := L + 1; + exit when L > LS'Last; + Left_Low := LS (L).Low; + end if; + end if; + end if; + end loop; + + -- Copy remainder of left ranges to result + + if L <= LS'Last then + N := N + 1; + Result (N).Low := Left_Low; + Result (N).High := LS (L).High; + + loop + L := L + 1; + exit when L > LS'Last; + N := N + 1; + Result (N) := LS (L); + end loop; + end if; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "-"; + + --------- + -- "=" -- + --------- + + -- The sorted, discontiguous form is canonical, so equality can be used + + function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean is + begin + return Left.Set.all = Right.Set.all; + end "="; + + ----------- + -- "and" -- + ----------- + + function "and" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); + N : Natural := 0; + L, R : Natural := 1; + + begin + -- Loop to search for overlapping character ranges + + while L <= LS'Last and then R <= RS'Last loop + + if LS (L).High < RS (R).Low then + L := L + 1; + + elsif RS (R).High < LS (L).Low then + R := R + 1; + + -- Here we have LS (L).High >= RS (R).Low + -- and RS (R).High >= LS (L).Low + -- so we have an overlapping range + + else + N := N + 1; + Result (N).Low := + Wide_Wide_Character'Max (LS (L).Low, RS (R).Low); + Result (N).High := + Wide_Wide_Character'Min (LS (L).High, RS (R).High); + + if RS (R).High = LS (L).High then + L := L + 1; + R := R + 1; + elsif RS (R).High < LS (L).High then + R := R + 1; + else + L := L + 1; + end if; + end if; + end loop; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "and"; + + ----------- + -- "not" -- + ----------- + + function "not" + (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. RS'Last + 1); + N : Natural := 0; + + begin + if RS'Last = 0 then + N := 1; + Result (1) := (Low => Wide_Wide_Character'First, + High => Wide_Wide_Character'Last); + + else + if RS (1).Low /= Wide_Wide_Character'First then + N := N + 1; + Result (N).Low := Wide_Wide_Character'First; + Result (N).High := Wide_Wide_Character'Pred (RS (1).Low); + end if; + + for K in 1 .. RS'Last - 1 loop + N := N + 1; + Result (N).Low := Wide_Wide_Character'Succ (RS (K).High); + Result (N).High := Wide_Wide_Character'Pred (RS (K + 1).Low); + end loop; + + if RS (RS'Last).High /= Wide_Wide_Character'Last then + N := N + 1; + Result (N).Low := Wide_Wide_Character'Succ (RS (RS'Last).High); + Result (N).High := Wide_Wide_Character'Last; + end if; + end if; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "not"; + + ---------- + -- "or" -- + ---------- + + function "or" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + LS : constant Wide_Wide_Character_Ranges_Access := Left.Set; + RS : constant Wide_Wide_Character_Ranges_Access := Right.Set; + + Result : Wide_Wide_Character_Ranges (1 .. LS'Last + RS'Last); + N : Natural; + L, R : Natural; + + begin + N := 0; + L := 1; + R := 1; + + -- Loop through ranges in output file + + loop + -- If no left ranges left, copy next right range + + if L > LS'Last then + exit when R > RS'Last; + N := N + 1; + Result (N) := RS (R); + R := R + 1; + + -- If no right ranges left, copy next left range + + elsif R > RS'Last then + N := N + 1; + Result (N) := LS (L); + L := L + 1; + + else + -- We have two ranges, choose lower one + + N := N + 1; + + if LS (L).Low <= RS (R).Low then + Result (N) := LS (L); + L := L + 1; + else + Result (N) := RS (R); + R := R + 1; + end if; + + -- Loop to collapse ranges into last range + + loop + -- Collapse next length range into current result range + -- if possible. + + if L <= LS'Last + and then LS (L).Low <= + Wide_Wide_Character'Succ (Result (N).High) + then + Result (N).High := + Wide_Wide_Character'Max (Result (N).High, LS (L).High); + L := L + 1; + + -- Collapse next right range into current result range + -- if possible + + elsif R <= RS'Last + and then RS (R).Low <= + Wide_Wide_Character'Succ (Result (N).High) + then + Result (N).High := + Wide_Wide_Character'Max (Result (N).High, RS (R).High); + R := R + 1; + + -- If neither range collapses, then done with this range + + else + exit; + end if; + end loop; + end if; + end loop; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end "or"; + + ----------- + -- "xor" -- + ----------- + + function "xor" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set + is + begin + return (Left or Right) - (Left and Right); + end "xor"; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Wide_Wide_Character_Mapping) is + begin + Object.Map := new Wide_Wide_Character_Mapping_Values'(Object.Map.all); + end Adjust; + + procedure Adjust (Object : in out Wide_Wide_Character_Set) is + begin + Object.Set := new Wide_Wide_Character_Ranges'(Object.Set.all); + end Adjust; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Wide_Wide_Character_Mapping) is + + procedure Free is new Ada.Unchecked_Deallocation + (Wide_Wide_Character_Mapping_Values, + Wide_Wide_Character_Mapping_Values_Access); + + begin + if Object.Map /= Null_Map'Unrestricted_Access then + Free (Object.Map); + end if; + end Finalize; + + procedure Finalize (Object : in out Wide_Wide_Character_Set) is + + procedure Free is new Ada.Unchecked_Deallocation + (Wide_Wide_Character_Ranges, + Wide_Wide_Character_Ranges_Access); + + begin + if Object.Set /= Null_Range'Unrestricted_Access then + Free (Object.Set); + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Wide_Wide_Character_Mapping) is + begin + Object := Identity; + end Initialize; + + procedure Initialize (Object : in out Wide_Wide_Character_Set) is + begin + Object := Null_Set; + end Initialize; + + ----------- + -- Is_In -- + ----------- + + function Is_In + (Element : Wide_Wide_Character; + Set : Wide_Wide_Character_Set) return Boolean + is + L, R, M : Natural; + SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; + + begin + L := 1; + R := SS'Last; + + -- Binary search loop. The invariant is that if Element is in any of + -- of the constituent ranges it is in one between Set (L) and Set (R). + + loop + if L > R then + return False; + + else + M := (L + R) / 2; + + if Element > SS (M).High then + L := M + 1; + elsif Element < SS (M).Low then + R := M - 1; + else + return True; + end if; + end if; + end loop; + end Is_In; + + --------------- + -- Is_Subset -- + --------------- + + function Is_Subset + (Elements : Wide_Wide_Character_Set; + Set : Wide_Wide_Character_Set) return Boolean + is + ES : constant Wide_Wide_Character_Ranges_Access := Elements.Set; + SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; + + S : Positive := 1; + E : Positive := 1; + + begin + loop + -- If no more element ranges, done, and result is true + + if E > ES'Last then + return True; + + -- If more element ranges, but no more set ranges, result is false + + elsif S > SS'Last then + return False; + + -- Remove irrelevant set range + + elsif SS (S).High < ES (E).Low then + S := S + 1; + + -- Get rid of element range that is properly covered by set + + elsif SS (S).Low <= ES (E).Low + and then ES (E).High <= SS (S).High + then + E := E + 1; + + -- Otherwise we have a non-covered element range, result is false + + else + return False; + end if; + end loop; + end Is_Subset; + + --------------- + -- To_Domain -- + --------------- + + function To_Domain + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence + is + begin + return Map.Map.Domain; + end To_Domain; + + ---------------- + -- To_Mapping -- + ---------------- + + function To_Mapping + (From, To : Wide_Wide_Character_Sequence) + return Wide_Wide_Character_Mapping + is + Domain : Wide_Wide_Character_Sequence (1 .. From'Length); + Rangev : Wide_Wide_Character_Sequence (1 .. To'Length); + N : Natural := 0; + + begin + if From'Length /= To'Length then + raise Translation_Error; + + else + pragma Warnings (Off); -- apparent uninit use of Domain + + for J in From'Range loop + for M in 1 .. N loop + if From (J) = Domain (M) then + raise Translation_Error; + elsif From (J) < Domain (M) then + Domain (M + 1 .. N + 1) := Domain (M .. N); + Rangev (M + 1 .. N + 1) := Rangev (M .. N); + Domain (M) := From (J); + Rangev (M) := To (J); + goto Continue; + end if; + end loop; + + Domain (N + 1) := From (J); + Rangev (N + 1) := To (J); + + <> + N := N + 1; + end loop; + + pragma Warnings (On); + + return (AF.Controlled with + Map => new Wide_Wide_Character_Mapping_Values'( + Length => N, + Domain => Domain (1 .. N), + Rangev => Rangev (1 .. N))); + end if; + end To_Mapping; + + -------------- + -- To_Range -- + -------------- + + function To_Range + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence + is + begin + return Map.Map.Rangev; + end To_Range; + + --------------- + -- To_Ranges -- + --------------- + + function To_Ranges + (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges + is + begin + return Set.Set.all; + end To_Ranges; + + ----------------- + -- To_Sequence -- + ----------------- + + function To_Sequence + (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence + is + SS : constant Wide_Wide_Character_Ranges_Access := Set.Set; + N : Natural := 0; + Count : Natural := 0; + + begin + for J in SS'Range loop + Count := + Count + (Wide_Wide_Character'Pos (SS (J).High) - + Wide_Wide_Character'Pos (SS (J).Low) + 1); + end loop; + + return Result : Wide_Wide_String (1 .. Count) do + for J in SS'Range loop + for K in SS (J).Low .. SS (J).High loop + N := N + 1; + Result (N) := K; + end loop; + end loop; + end return; + end To_Sequence; + + ------------ + -- To_Set -- + ------------ + + -- Case of multiple range input + + function To_Set + (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set + is + Result : Wide_Wide_Character_Ranges (Ranges'Range); + N : Natural := 0; + J : Natural; + + begin + -- The output of To_Set is required to be sorted by increasing Low + -- values, and discontiguous, so first we sort them as we enter them, + -- using a simple insertion sort. + + pragma Warnings (Off); + -- Kill bogus warning on Result being uninitialized + + for J in Ranges'Range loop + for K in 1 .. N loop + if Ranges (J).Low < Result (K).Low then + Result (K + 1 .. N + 1) := Result (K .. N); + Result (K) := Ranges (J); + goto Continue; + end if; + end loop; + + Result (N + 1) := Ranges (J); + + <> + N := N + 1; + end loop; + + pragma Warnings (On); + + -- Now collapse any contiguous or overlapping ranges + + J := 1; + while J < N loop + if Result (J).High < Result (J).Low then + N := N - 1; + Result (J .. N) := Result (J + 1 .. N + 1); + + elsif Wide_Wide_Character'Succ (Result (J).High) >= + Result (J + 1).Low + then + Result (J).High := + Wide_Wide_Character'Max (Result (J).High, Result (J + 1).High); + + N := N - 1; + Result (J + 1 .. N) := Result (J + 2 .. N + 1); + + else + J := J + 1; + end if; + end loop; + + if Result (N).High < Result (N).Low then + N := N - 1; + end if; + + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(Result (1 .. N))); + end To_Set; + + -- Case of single range input + + function To_Set + (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set + is + begin + if Span.Low > Span.High then + return Null_Set; + -- This is safe, because there is no procedure with parameter + -- Wide_Wide_Character_Set of mode "out" or "in out". + + else + return (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(1 => Span)); + end if; + end To_Set; + + -- Case of wide string input + + function To_Set + (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set + is + R : Wide_Wide_Character_Ranges (1 .. Sequence'Length); + + begin + for J in R'Range loop + R (J) := (Sequence (J), Sequence (J)); + end loop; + + return To_Set (R); + end To_Set; + + -- Case of single wide character input + + function To_Set + (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set + is + begin + return + (AF.Controlled with + Set => new Wide_Wide_Character_Ranges'(1 => (Singleton, Singleton))); + end To_Set; + + ----------- + -- Value -- + ----------- + + function Value + (Map : Wide_Wide_Character_Mapping; + Element : Wide_Wide_Character) return Wide_Wide_Character + is + L, R, M : Natural; + + MV : constant Wide_Wide_Character_Mapping_Values_Access := Map.Map; + + begin + L := 1; + R := MV.Domain'Last; + + -- Binary search loop + + loop + -- If not found, identity + + if L > R then + return Element; + + -- Otherwise do binary divide + + else + M := (L + R) / 2; + + if Element < MV.Domain (M) then + R := M - 1; + + elsif Element > MV.Domain (M) then + L := M + 1; + + else -- Element = MV.Domain (M) then + return MV.Rangev (M); + end if; + end if; + end loop; + end Value; + +end Ada.Strings.Wide_Wide_Maps; diff --git a/gcc/ada/libgnat/a-stzmap.ads b/gcc/ada/libgnat/a-stzmap.ads new file mode 100644 index 0000000..1b0c231 --- /dev/null +++ b/gcc/ada/libgnat/a-stzmap.ads @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ M A P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; + +package Ada.Strings.Wide_Wide_Maps is + pragma Preelaborate; + + ------------------------------------------ + -- Wide_Wide_Character Set Declarations -- + ------------------------------------------ + + type Wide_Wide_Character_Set is private; + pragma Preelaborable_Initialization (Wide_Wide_Character_Set); + -- Representation for a set of Wide_Wide_Character values: + + Null_Set : constant Wide_Wide_Character_Set; + + ----------------------------------------------- + -- Constructors for Wide_Wide_Character Sets -- + ----------------------------------------------- + + type Wide_Wide_Character_Range is record + Low : Wide_Wide_Character; + High : Wide_Wide_Character; + end record; + -- Represents Wide_Wide_Character range Low .. High + + type Wide_Wide_Character_Ranges is + array (Positive range <>) of Wide_Wide_Character_Range; + + function To_Set + (Ranges : Wide_Wide_Character_Ranges) return Wide_Wide_Character_Set; + + function To_Set + (Span : Wide_Wide_Character_Range) return Wide_Wide_Character_Set; + + function To_Ranges + (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Ranges; + + --------------------------------------- + -- Operations on Wide Character Sets -- + --------------------------------------- + + function "=" (Left, Right : Wide_Wide_Character_Set) return Boolean; + + function "not" + (Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "and" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "or" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "xor" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function "-" + (Left, Right : Wide_Wide_Character_Set) return Wide_Wide_Character_Set; + + function Is_In + (Element : Wide_Wide_Character; + Set : Wide_Wide_Character_Set) return Boolean; + + function Is_Subset + (Elements : Wide_Wide_Character_Set; + Set : Wide_Wide_Character_Set) return Boolean; + + function "<=" + (Left : Wide_Wide_Character_Set; + Right : Wide_Wide_Character_Set) return Boolean + renames Is_Subset; + + subtype Wide_Wide_Character_Sequence is Wide_Wide_String; + -- Alternative representation for a set of character values + + function To_Set + (Sequence : Wide_Wide_Character_Sequence) return Wide_Wide_Character_Set; + + function To_Set + (Singleton : Wide_Wide_Character) return Wide_Wide_Character_Set; + + function To_Sequence + (Set : Wide_Wide_Character_Set) return Wide_Wide_Character_Sequence; + + ---------------------------------------------- + -- Wide_Wide_Character Mapping Declarations -- + ---------------------------------------------- + + type Wide_Wide_Character_Mapping is private; + pragma Preelaborable_Initialization (Wide_Wide_Character_Mapping); + -- Representation for a wide character to wide character mapping: + + function Value + (Map : Wide_Wide_Character_Mapping; + Element : Wide_Wide_Character) return Wide_Wide_Character; + + Identity : constant Wide_Wide_Character_Mapping; + + -------------------------------------- + -- Operations on Wide Wide Mappings -- + --------------------------------------- + + function To_Mapping + (From, To : Wide_Wide_Character_Sequence) + return Wide_Wide_Character_Mapping; + + function To_Domain + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence; + + function To_Range + (Map : Wide_Wide_Character_Mapping) return Wide_Wide_Character_Sequence; + + type Wide_Wide_Character_Mapping_Function is + access function (From : Wide_Wide_Character) return Wide_Wide_Character; + +private + package AF renames Ada.Finalization; + + ----------------------------------------------- + -- Representation of Wide_Wide_Character_Set -- + ----------------------------------------------- + + -- A wide character set is represented as a sequence of wide character + -- ranges (i.e. an object of type Wide_Wide_Character_Ranges) in which the + -- following hold: + + -- The lower bound is 1 + -- The ranges are in order by increasing Low values + -- The ranges are non-overlapping and discontigous + + -- A character value is in the set if it is contained in one of the + -- ranges. The actual Wide_Wide_Character_Set value is a controlled pointer + -- to this Wide_Wide_Character_Ranges value. The use of a controlled type + -- is necessary to prevent storage leaks. + + type Wide_Wide_Character_Ranges_Access is + access all Wide_Wide_Character_Ranges; + + type Wide_Wide_Character_Set is new AF.Controlled with record + Set : Wide_Wide_Character_Ranges_Access; + end record; + + pragma Finalize_Storage_Only (Wide_Wide_Character_Set); + -- This avoids useless finalizations, and, more importantly avoids + -- incorrect attempts to finalize constants that are statically + -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect. + + procedure Initialize (Object : in out Wide_Wide_Character_Set); + procedure Adjust (Object : in out Wide_Wide_Character_Set); + procedure Finalize (Object : in out Wide_Wide_Character_Set); + + Null_Range : aliased constant Wide_Wide_Character_Ranges := + (1 .. 0 => (Low => ' ', High => ' ')); + + Null_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Set => Null_Range'Unrestricted_Access); + + --------------------------------------------------- + -- Representation of Wide_Wide_Character_Mapping -- + --------------------------------------------------- + + -- A wide character mapping is represented as two strings of equal + -- length, where any character appearing in Domain is mapped to the + -- corresponding character in Rangev. A character not appearing in + -- Domain is mapped to itself. The characters in Domain are sorted + -- in ascending order. + + -- The actual Wide_Wide_Character_Mapping value is a controlled record + -- that contains a pointer to a discriminated record containing the + -- range and domain values. + + -- Note: this representation is canonical, and the values stored in + -- Domain and Rangev are exactly the values that are returned by the + -- functions To_Domain and To_Range. The use of a controlled type is + -- necessary to prevent storage leaks. + + type Wide_Wide_Character_Mapping_Values (Length : Natural) is record + Domain : Wide_Wide_Character_Sequence (1 .. Length); + Rangev : Wide_Wide_Character_Sequence (1 .. Length); + end record; + + type Wide_Wide_Character_Mapping_Values_Access is + access all Wide_Wide_Character_Mapping_Values; + + type Wide_Wide_Character_Mapping is new AF.Controlled with record + Map : Wide_Wide_Character_Mapping_Values_Access; + end record; + + pragma Finalize_Storage_Only (Wide_Wide_Character_Mapping); + -- This avoids useless finalizations, and, more importantly avoids + -- incorrect attempts to finalize constants that are statically + -- declared here and in Ada.Strings.Wide_Wide_Maps, which is incorrect. + + procedure Initialize (Object : in out Wide_Wide_Character_Mapping); + procedure Adjust (Object : in out Wide_Wide_Character_Mapping); + procedure Finalize (Object : in out Wide_Wide_Character_Mapping); + + Null_Map : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 0, + Domain => "", + Rangev => ""); + + Identity : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Map => Null_Map'Unrestricted_Access); + +end Ada.Strings.Wide_Wide_Maps; diff --git a/gcc/ada/libgnat/a-stzsea.adb b/gcc/ada/libgnat/a-stzsea.adb new file mode 100644 index 0000000..b5a62e7 --- /dev/null +++ b/gcc/ada/libgnat/a-stzsea.adb @@ -0,0 +1,617 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps; +with System; use System; + +package body Ada.Strings.Wide_Wide_Search is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Belongs + (Element : Wide_Wide_Character; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership) return Boolean; + pragma Inline (Belongs); + -- Determines if the given element is in (Test = Inside) or not in + -- (Test = Outside) the given character set. + + ------------- + -- Belongs -- + ------------- + + function Belongs + (Element : Wide_Wide_Character; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership) return Boolean + is + begin + if Test = Inside then + return Is_In (Element, Set); + else + return not Is_In (Element, Set); + end if; + end Belongs; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + Num := 0; + Ind := Source'First; + + -- Unmapped case + + if Mapping'Address = Wide_Wide_Maps.Identity'Address then + while Ind <= Source'Last - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + Num := Num + 1; + Ind := Ind + Pattern'Length; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped case + + else + while Ind <= Source'Last - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; + end loop; + + Num := Num + 1; + Ind := Ind + Pattern'Length; + + <> + null; + end loop; + end if; + + -- Return result + + return Num; + end Count; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Num : Natural; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + Num := 0; + Ind := Source'First; + while Ind <= Source'Last - PL1 loop + Cur := Ind; + for K in Pattern'Range loop + if Pattern (K) /= Mapping (Source (Cur)) then + Ind := Ind + 1; + goto Cont; + else + Cur := Cur + 1; + end if; + end loop; + + Num := Num + 1; + Ind := Ind + Pattern'Length; + + <> + null; + end loop; + + return Num; + end Count; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + N : Natural := 0; + + begin + for J in Source'Range loop + if Is_In (Source (J), Set) then + N := N + 1; + end if; + end loop; + + return N; + end Count; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural) + is + begin + for J in From .. Source'Last loop + if Belongs (Source (J), Set, Test) then + First := J; + + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + end loop; + + -- Here if J indexes first char of token, and all chars after J + -- are in the token. + + Last := Source'Last; + return; + end if; + end loop; + + -- Here if no token found + + First := From; + Last := 0; + end Find_Token; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural) + is + begin + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + First := J; + + for K in J + 1 .. Source'Last loop + if not Belongs (Source (K), Set, Test) then + Last := K - 1; + return; + end if; + end loop; + + -- Here if J indexes first char of token, and all chars after J + -- are in the token. + + Last := Source'Last; + return; + end if; + end loop; + + -- Here if no token found + + -- RM 2005 A.4.3 (68/1) specifies that an exception must be raised if + -- Source'First is not positive and is assigned to First. Formulation + -- is slightly different in RM 2012, but the intent seems similar, so + -- we check explicitly for that condition. + + if Source'First not in Positive then + raise Constraint_Error; + + else + First := Source'First; + Last := 0; + end if; + end Find_Token; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Cur : Natural; + + Ind : Integer; + -- Index for start of match check. This can be negative if the pattern + -- length is greater than the string length, which is why this variable + -- is Integer instead of Natural. In this case, the search loops do not + -- execute at all, so this Ind value is never used. + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + + -- Unmapped forward case + + if Mapping'Address = Wide_Wide_Maps.Identity'Address then + for J in 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind + 1; + end if; + end loop; + + -- Mapped forward case + + else + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + end if; + + -- Backwards case + + else + -- Unmapped backward case + + Ind := Source'Last - PL1; + + if Mapping'Address = Wide_Wide_Maps.Identity'Address then + for J in reverse 1 .. Source'Length - PL1 loop + if Pattern = Source (Ind .. Ind + PL1) then + return Ind; + else + Ind := Ind - 1; + end if; + end loop; + + -- Mapped backward case + + else + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Value (Mapping, Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + PL1 : constant Integer := Pattern'Length - 1; + Ind : Natural; + Cur : Natural; + + begin + if Pattern = "" then + raise Pattern_Error; + end if; + + -- Check for null pointer in case checks are off + + if Mapping = null then + raise Constraint_Error; + end if; + + -- If Pattern longer than Source it can't be found + + if Pattern'Length > Source'Length then + return 0; + end if; + + -- Forwards case + + if Going = Forward then + Ind := Source'First; + for J in 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont1; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind + 1; + end loop; + + -- Backwards case + + else + Ind := Source'Last - PL1; + for J in reverse 1 .. Source'Length - PL1 loop + Cur := Ind; + + for K in Pattern'Range loop + if Pattern (K) /= Mapping.all (Source (Cur)) then + goto Cont2; + else + Cur := Cur + 1; + end if; + end loop; + + return Ind; + + <> + Ind := Ind - 1; + end loop; + end if; + + -- Fall through if no match found. Note that the loops are skipped + -- completely in the case of the pattern being longer than the source. + + return 0; + end Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + -- Forwards case + + if Going = Forward then + for J in Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + + -- Backwards case + + else + for J in reverse Source'Range loop + if Belongs (Source (J), Set, Test) then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return Index + (Source (From .. Source'Last), Pattern, Forward, Mapping); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return Index + (Source (Source'First .. From), Pattern, Backward, Mapping); + end if; + end Index; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index (Source (From .. Source'Last), Set, Test, Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index (Source (Source'First .. From), Set, Test, Backward); + end if; + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + for J in Source'Range loop + if Source (J) /= Wide_Wide_Space then + return J; + end if; + end loop; + + else -- Going = Backward + for J in reverse Source'Range loop + if Source (J) /= Wide_Wide_Space then + return J; + end if; + end loop; + end if; + + -- Fall through if no match + + return 0; + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + if Going = Forward then + if From < Source'First then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (From .. Source'Last), Forward); + + else + if From > Source'Last then + raise Index_Error; + end if; + + return + Index_Non_Blank (Source (Source'First .. From), Backward); + end if; + end Index_Non_Blank; + +end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/libgnat/a-stzsea.ads b/gcc/ada/libgnat/a-stzsea.ads new file mode 100644 index 0000000..1875af7 --- /dev/null +++ b/gcc/ada/libgnat/a-stzsea.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S E A R C H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains search functions from Ada.Strings.Wide_Wide_Fixed. +-- They are separated because Ada.Strings.Wide_Wide_Bounded shares these +-- search functions with Ada.Strings.Wide_Wide_Unbounded, and we don't want to +-- drag in other irrelevant stuff from Ada.Strings.Wide_Wide_Fixed when using +-- the other two packages. We make this a private package, since user programs +-- should access these subprograms via one of the standard string packages. + +with Ada.Strings.Wide_Wide_Maps; + +private package Ada.Strings.Wide_Wide_Search is + pragma Preelaborate; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + + procedure Find_Token + (Source : Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + +end Ada.Strings.Wide_Wide_Search; diff --git a/gcc/ada/libgnat/a-stzsup.adb b/gcc/ada/libgnat/a-stzsup.adb new file mode 100644 index 0000000..abcb97b --- /dev/null +++ b/gcc/ada/libgnat/a-stzsup.adb @@ -0,0 +1,1941 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Maps; use Ada.Strings.Wide_Wide_Maps; +with Ada.Strings.Wide_Wide_Search; + +package body Ada.Strings.Wide_Wide_Superbounded is + + ------------ + -- Concat -- + ------------ + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Wide_String) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + Nlen : constant Natural := Llen + Right'Length; + + begin + if Nlen > Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + end if; + end; + end return; + end Concat; + + function Concat + (Left : Wide_Wide_String; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Right.Max_Length) do + declare + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + end if; + end; + end return; + end Concat; + + function Concat + (Left : Super_String; + Right : Wide_Wide_Character) return Super_String + is + begin + return Result : Super_String (Left.Max_Length) do + declare + Llen : constant Natural := Left.Current_Length; + + begin + if Llen = Left.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Result.Current_Length) := Right; + end if; + end; + end return; + end Concat; + + function Concat + (Left : Wide_Wide_Character; + Right : Super_String) return Super_String + is + begin + return Result : Super_String (Right.Max_Length) do + declare + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen = Right.Max_Length then + raise Ada.Strings.Length_Error; + else + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Result.Current_Length) := + Right.Data (1 .. Rlen); + end if; + end; + end return; + end Concat; + + ----------- + -- Equal -- + ----------- + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Current_Length = Right.Current_Length + and then Left.Data (1 .. Left.Current_Length) = + Right.Data (1 .. Right.Current_Length); + end "="; + + function Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Current_Length = Right'Length + and then Left.Data (1 .. Left.Current_Length) = Right; + end Equal; + + function Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left'Length = Right.Current_Length + and then Left = Right.Data (1 .. Right.Current_Length); + end Equal; + + ------------- + -- Greater -- + ------------- + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > + Right.Data (1 .. Right.Current_Length); + end Greater; + + function Greater + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) > Right; + end Greater; + + function Greater + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left > Right.Data (1 .. Right.Current_Length); + end Greater; + + ---------------------- + -- Greater_Or_Equal -- + ---------------------- + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= + Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) >= Right; + end Greater_Or_Equal; + + function Greater_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left >= Right.Data (1 .. Right.Current_Length); + end Greater_Or_Equal; + + ---------- + -- Less -- + ---------- + + function Less + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < + Right.Data (1 .. Right.Current_Length); + end Less; + + function Less + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) < Right; + end Less; + + function Less + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left < Right.Data (1 .. Right.Current_Length); + end Less; + + ------------------- + -- Less_Or_Equal -- + ------------------- + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= + Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Data (1 .. Left.Current_Length) <= Right; + end Less_Or_Equal; + + function Less_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean + is + begin + return Left <= Right.Data (1 .. Right.Current_Length); + end Less_Or_Equal; + + ---------------------- + -- Set_Super_String -- + ---------------------- + + procedure Set_Super_String + (Target : out Super_String; + Source : Wide_Wide_String; + Drop : Truncation := Error) + is + Slen : constant Natural := Source'Length; + Max_Length : constant Positive := Target.Max_Length; + + begin + if Slen <= Max_Length then + Target.Current_Length := Slen; + Target.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Target.Current_Length := Max_Length; + Target.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Set_Super_String; + + ------------------ + -- Super_Append -- + ------------------ + + -- Case of Super_String and Super_String + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Result.Data := Right.Data; + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item.Data (1 .. Rlen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then -- only case is Rlen = Max_Length + Source.Data := New_Item.Data; + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Super_String and Wide_Wide_String + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Nlen) := Right; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then -- only case is Llen = Max_Length + Result.Data := Left.Data; + + else + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1 .. Max_Length) := + Right (Right'First .. Right'First - 1 + + Max_Length - Llen); + + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right (Right'Last - (Max_Length - 1) .. Right'Last); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + Rlen : constant Natural := New_Item'Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Source.Current_Length := Nlen; + Source.Data (Llen + 1 .. Nlen) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen < Max_Length then + Source.Data (Llen + 1 .. Max_Length) := + New_Item (New_Item'First .. + New_Item'First - 1 + Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - (Max_Length - 1) .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - Rlen) := + Source.Data (Llen - (Max_Length - Rlen - 1) .. Llen); + Source.Data (Max_Length - Rlen + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + -- Case of Wide_Wide_String and Super_String + + function Super_Append + (Left : Wide_Wide_String; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left'Length; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Llen + Rlen; + + begin + if Nlen <= Max_Length then + Result.Current_Length := Nlen; + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Llen + Rlen) := Right.Data (1 .. Rlen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Llen >= Max_Length then + Result.Data (1 .. Max_Length) := + Left (Left'First .. Left'First + (Max_Length - 1)); + + else + Result.Data (1 .. Llen) := Left; + Result.Data (Llen + 1 .. Max_Length) := + Right.Data (1 .. Max_Length - Llen); + end if; + + when Strings.Left => + if Rlen >= Max_Length then + Result.Data (1 .. Max_Length) := + Right.Data (Rlen - (Max_Length - 1) .. Rlen); + + else + Result.Data (1 .. Max_Length - Rlen) := + Left (Left'Last - (Max_Length - Rlen - 1) .. Left'Last); + Result.Data (Max_Length - Rlen + 1 .. Max_Length) := + Right.Data (1 .. Rlen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Append; + + -- Case of Super_String and Wide_Wide_Character + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_Character; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Left.Max_Length; + Result : Super_String (Max_Length); + Llen : constant Natural := Left.Current_Length; + + begin + if Llen < Max_Length then + Result.Current_Length := Llen + 1; + Result.Data (1 .. Llen) := Left.Data (1 .. Llen); + Result.Data (Llen + 1) := Right; + return Result; + + else + case Drop is + when Strings.Right => + return Left; + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length - 1) := + Left.Data (2 .. Max_Length); + Result.Data (Max_Length) := Right; + return Result; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Llen : constant Natural := Source.Current_Length; + + begin + if Llen < Max_Length then + Source.Current_Length := Llen + 1; + Source.Data (Llen + 1) := New_Item; + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + null; + + when Strings.Left => + Source.Data (1 .. Max_Length - 1) := + Source.Data (2 .. Max_Length); + Source.Data (Max_Length) := New_Item; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + end Super_Append; + + -- Case of Wide_Wide_Character and Super_String + + function Super_Append + (Left : Wide_Wide_Character; + Right : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Right.Max_Length; + Result : Super_String (Max_Length); + Rlen : constant Natural := Right.Current_Length; + + begin + if Rlen < Max_Length then + Result.Current_Length := Rlen + 1; + Result.Data (1) := Left; + Result.Data (2 .. Rlen + 1) := Right.Data (1 .. Rlen); + return Result; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1) := Left; + Result.Data (2 .. Max_Length) := + Right.Data (1 .. Max_Length - 1); + return Result; + + when Strings.Left => + return Right; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Append; + + ----------------- + -- Super_Count -- + ----------------- + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + begin + return + Wide_Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return + Wide_Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Pattern, Mapping); + end Super_Count; + + function Super_Count + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + begin + return Wide_Wide_Search.Count + (Source.Data (1 .. Source.Current_Length), Set); + end Super_Count; + + ------------------ + -- Super_Delete -- + ------------------ + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String + is + Result : Super_String (Source.Max_Length); + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return Source; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Result.Current_Length := From - 1; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + return Result; + + else + Result.Current_Length := Slen - Num_Delete; + Result.Data (1 .. From - 1) := Source.Data (1 .. From - 1); + Result.Data (From .. Result.Current_Length) := + Source.Data (Through + 1 .. Slen); + return Result; + end if; + end Super_Delete; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural) + is + Slen : constant Natural := Source.Current_Length; + Num_Delete : constant Integer := Through - From + 1; + + begin + if Num_Delete <= 0 then + return; + + elsif From > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Through >= Slen then + Source.Current_Length := From - 1; + + else + Source.Current_Length := Slen - Num_Delete; + Source.Data (From .. Source.Current_Length) := + Source.Data (Through + 1 .. Slen); + end if; + end Super_Delete; + + ------------------- + -- Super_Element -- + ------------------- + + function Super_Element + (Source : Super_String; + Index : Positive) return Wide_Wide_Character + is + begin + if Index <= Source.Current_Length then + return Source.Data (Index); + else + raise Strings.Index_Error; + end if; + end Super_Element; + + ---------------------- + -- Super_Find_Token -- + ---------------------- + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Wide_Search.Find_Token + (Source.Data (From .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Wide_Search.Find_Token + (Source.Data (1 .. Source.Current_Length), Set, Test, First, Last); + end Super_Find_Token; + + ---------------- + -- Super_Head -- + ---------------- + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := Source.Data (1 .. Count); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Count) := (others => Pad); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Max_Length - Npad) := + Source.Data (Count - Max_Length + 1 .. Slen); + Result.Data (Max_Length - Npad + 1 .. Max_Length) := + (others => Pad); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Head; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + Temp : Wide_Wide_String (1 .. Max_Length); + + begin + if Npad <= 0 then + Source.Current_Length := Count; + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (Slen + 1 .. Count) := (others => Pad); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Slen + 1 .. Max_Length) := (others => Pad); + + when Strings.Left => + if Npad > Max_Length then + Source.Data := (others => Pad); + + else + Temp := Source.Data; + Source.Data (1 .. Max_Length - Npad) := + Temp (Count - Max_Length + 1 .. Slen); + + for J in Max_Length - Npad + 1 .. Max_Length loop + Source.Data (J) := Pad; + end loop; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Head; + + ----------------- + -- Super_Index -- + ----------------- + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Pattern, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Set, Test, Going); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), + Pattern, From, Going, Mapping); + end Super_Index; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Data (1 .. Source.Current_Length), Set, From, Test, Going); + end Super_Index; + + --------------------------- + -- Super_Index_Non_Blank -- + --------------------------- + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return + Wide_Wide_Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), Going); + end Super_Index_Non_Blank; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + return + Wide_Wide_Search.Index_Non_Blank + (Source.Data (1 .. Source.Current_Length), From, Going); + end Super_Index_Non_Blank; + + ------------------ + -- Super_Insert -- + ------------------ + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Nlen : constant Natural := New_Item'Length; + Tlen : constant Natural := Slen + Nlen; + Blen : constant Natural := Before - 1; + Alen : constant Integer := Slen - Blen; + Droplen : constant Integer := Tlen - Max_Length; + + -- Tlen is the length of the total string before possible truncation. + -- Blen, Alen are the lengths of the before and after pieces of the + -- source string. + + begin + if Alen < 0 then + raise Ada.Strings.Index_Error; + + elsif Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Tlen) := + Source.Data (Before .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Before .. Max_Length) := + New_Item (New_Item'First + .. New_Item'First + Max_Length - Before); + else + Result.Data (Before .. Before + Nlen - 1) := New_Item; + Result.Data (Before + Nlen .. Max_Length) := + Source.Data (Before .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (Before .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + New_Item (New_Item'Last - (Max_Length - Alen) + 1 + .. New_Item'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := + New_Item; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Insert; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Insert (Source, Before, New_Item, Drop); + end Super_Insert; + + ------------------ + -- Super_Length -- + ------------------ + + function Super_Length (Source : Super_String) return Natural is + begin + return Source.Current_Length; + end Super_Length; + + --------------------- + -- Super_Overwrite -- + --------------------- + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Endpos : constant Natural := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif New_Item'Length = 0 then + return Source; + + elsif Endpos <= Slen then + Result.Current_Length := Source.Current_Length; + Result.Data (1 .. Slen) := Source.Data (1 .. Slen); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + elsif Endpos <= Max_Length then + Result.Current_Length := Endpos; + Result.Data (1 .. Position - 1) := Source.Data (1 .. Position - 1); + Result.Data (Position .. Endpos) := New_Item; + return Result; + + else + Result.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Position - 1) := + Source.Data (1 .. Position - 1); + + Result.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + return Result; + + when Strings.Left => + if New_Item'Length >= Max_Length then + Result.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + return Result; + + else + Result.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + Result.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + return Result; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + Max_Length : constant Positive := Source.Max_Length; + Endpos : constant Positive := Position + New_Item'Length - 1; + Slen : constant Natural := Source.Current_Length; + Droplen : Natural; + + begin + if Position > Slen + 1 then + raise Ada.Strings.Index_Error; + + elsif Endpos <= Slen then + Source.Data (Position .. Endpos) := New_Item; + + elsif Endpos <= Max_Length then + Source.Data (Position .. Endpos) := New_Item; + Source.Current_Length := Endpos; + + else + Source.Current_Length := Max_Length; + Droplen := Endpos - Max_Length; + + case Drop is + when Strings.Right => + Source.Data (Position .. Max_Length) := + New_Item (New_Item'First .. New_Item'Last - Droplen); + + when Strings.Left => + if New_Item'Length > Max_Length then + Source.Data (1 .. Max_Length) := + New_Item (New_Item'Last - Max_Length + 1 .. + New_Item'Last); + + else + Source.Data (1 .. Max_Length - New_Item'Length) := + Source.Data (Droplen + 1 .. Position - 1); + + Source.Data + (Max_Length - New_Item'Length + 1 .. Max_Length) := + New_Item; + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Overwrite; + + --------------------------- + -- Super_Replace_Element -- + --------------------------- + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Wide_Character) + is + begin + if Index <= Source.Current_Length then + Source.Data (Index) := By; + else + raise Ada.Strings.Index_Error; + end if; + end Super_Replace_Element; + + ------------------------- + -- Super_Replace_Slice -- + ------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + + begin + if Low > Slen + 1 then + raise Strings.Index_Error; + + elsif High < Low then + return Super_Insert (Source, Low, By, Drop); + + else + declare + Blen : constant Natural := Natural'Max (0, Low - 1); + Alen : constant Natural := Natural'Max (0, Slen - High); + Tlen : constant Natural := Blen + By'Length + Alen; + Droplen : constant Integer := Tlen - Max_Length; + Result : Super_String (Max_Length); + + -- Tlen is the total length of the result string before any + -- truncation. Blen and Alen are the lengths of the pieces + -- of the original string that end up in the result string + -- before and after the replaced slice. + + begin + if Droplen <= 0 then + Result.Current_Length := Tlen; + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Tlen) := + Source.Data (High + 1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Result.Data (1 .. Blen) := Source.Data (1 .. Blen); + + if Droplen > Alen then + Result.Data (Low .. Max_Length) := + By (By'First .. By'First + Max_Length - Low); + else + Result.Data (Low .. Low + By'Length - 1) := By; + Result.Data (Low + By'Length .. Max_Length) := + Source.Data (High + 1 .. Slen - Droplen); + end if; + + when Strings.Left => + Result.Data (Max_Length - (Alen - 1) .. Max_Length) := + Source.Data (High + 1 .. Slen); + + if Droplen >= Blen then + Result.Data (1 .. Max_Length - Alen) := + By (By'Last - (Max_Length - Alen) + 1 .. By'Last); + else + Result.Data + (Blen - Droplen + 1 .. Max_Length - Alen) := By; + Result.Data (1 .. Blen - Droplen) := + Source.Data (Droplen + 1 .. Blen); + end if; + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end; + end if; + end Super_Replace_Slice; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Strings.Truncation := Strings.Error) + is + begin + -- We do a double copy here because this is one of the situations + -- in which we move data to the right, and at least at the moment, + -- GNAT is not handling such cases correctly ??? + + Source := Super_Replace_Slice (Source, Low, High, By, Drop); + end Super_Replace_Slice; + + --------------------- + -- Super_Replicate -- + --------------------- + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Count <= Max_Length then + Result.Current_Length := Count; + + elsif Drop = Strings.Error then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Max_Length; + end if; + + Result.Data (1 .. Result.Current_Length) := (others => Item); + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String + is + Length : constant Integer := Count * Item'Length; + Result : Super_String (Max_Length); + Indx : Positive; + + begin + if Length <= Max_Length then + Result.Current_Length := Length; + + if Length > 0 then + Indx := 1; + + for J in 1 .. Count loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + end if; + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + Indx := 1; + + while Indx + Item'Length <= Max_Length + 1 loop + Result.Data (Indx .. Indx + Item'Length - 1) := Item; + Indx := Indx + Item'Length; + end loop; + + Result.Data (Indx .. Max_Length) := + Item (Item'First .. Item'First + Max_Length - Indx); + + when Strings.Left => + Indx := Max_Length; + + while Indx - Item'Length >= 1 loop + Result.Data (Indx - (Item'Length - 1) .. Indx) := Item; + Indx := Indx - Item'Length; + end loop; + + Result.Data (1 .. Indx) := + Item (Item'Last - Indx + 1 .. Item'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Replicate; + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + begin + return + Super_Replicate + (Count, + Item.Data (1 .. Item.Current_Length), + Drop, + Item.Max_Length); + end Super_Replicate; + + ----------------- + -- Super_Slice -- + ----------------- + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + return R : Wide_Wide_String (Low .. High) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + end if; + + R := Source.Data (Low .. High); + end return; + end Super_Slice; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String + is + begin + return Result : Super_String (Source.Max_Length) do + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + Result.Current_Length := High - Low + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (Low .. High); + end if; + end return; + end Super_Slice; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural) + is + begin + if Low > Source.Current_Length + 1 + or else High > Source.Current_Length + then + raise Index_Error; + else + Target.Current_Length := High - Low + 1; + Target.Data (1 .. Target.Current_Length) := Source.Data (Low .. High); + end if; + end Super_Slice; + + ---------------- + -- Super_Tail -- + ---------------- + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Strings.Truncation := Strings.Error) return Super_String + is + Max_Length : constant Positive := Source.Max_Length; + Result : Super_String (Max_Length); + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + begin + if Npad <= 0 then + Result.Current_Length := Count; + Result.Data (1 .. Count) := + Source.Data (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Result.Current_Length := Count; + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Count) := Source.Data (1 .. Slen); + + else + Result.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Result.Data := (others => Pad); + + else + Result.Data (1 .. Npad) := (others => Pad); + Result.Data (Npad + 1 .. Max_Length) := + Source.Data (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + Result.Data (1 .. Max_Length - Slen) := (others => Pad); + Result.Data (Max_Length - Slen + 1 .. Max_Length) := + Source.Data (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end Super_Tail; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) + is + Max_Length : constant Positive := Source.Max_Length; + Slen : constant Natural := Source.Current_Length; + Npad : constant Integer := Count - Slen; + + Temp : constant Wide_Wide_String (1 .. Max_Length) := Source.Data; + + begin + if Npad <= 0 then + Source.Current_Length := Count; + Source.Data (1 .. Count) := + Temp (Slen - (Count - 1) .. Slen); + + elsif Count <= Max_Length then + Source.Current_Length := Count; + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Count) := Temp (1 .. Slen); + + else + Source.Current_Length := Max_Length; + + case Drop is + when Strings.Right => + if Npad >= Max_Length then + Source.Data := (others => Pad); + + else + Source.Data (1 .. Npad) := (others => Pad); + Source.Data (Npad + 1 .. Max_Length) := + Temp (1 .. Max_Length - Npad); + end if; + + when Strings.Left => + for J in 1 .. Max_Length - Slen loop + Source.Data (J) := Pad; + end loop; + + Source.Data (Max_Length - Slen + 1 .. Max_Length) := + Temp (1 .. Slen); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + end Super_Tail; + + --------------------- + -- Super_To_String -- + --------------------- + + function Super_To_String + (Source : Super_String) return Wide_Wide_String + is + begin + return R : Wide_Wide_String (1 .. Source.Current_Length) do + R := Source.Data (1 .. Source.Current_Length); + end return; + end Super_To_String; + + --------------------- + -- Super_Translate -- + --------------------- + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Value (Mapping, Source.Data (J)); + end loop; + end Super_Translate; + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + Result.Current_Length := Source.Current_Length; + + for J in 1 .. Source.Current_Length loop + Result.Data (J) := Mapping.all (Source.Data (J)); + end loop; + + return Result; + end Super_Translate; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + begin + for J in 1 .. Source.Current_Length loop + Source.Data (J) := Mapping.all (Source.Data (J)); + end loop; + end Super_Translate; + + ---------------- + -- Super_Trim -- + ---------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String + is + Result : Super_String (Source.Max_Length); + Last : Natural := Source.Current_Length; + First : Positive := 1; + + begin + if Side = Left or else Side = Both then + while First <= Last and then Source.Data (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Source.Data (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := Source.Data (First .. Last); + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End) + is + Max_Length : constant Positive := Source.Max_Length; + Last : Natural := Source.Current_Length; + First : Positive := 1; + Temp : Wide_Wide_String (1 .. Max_Length); + + begin + Temp (1 .. Last) := Source.Data (1 .. Last); + + if Side = Left or else Side = Both then + while First <= Last and then Temp (First) = ' ' loop + First := First + 1; + end loop; + end if; + + if Side = Right or else Side = Both then + while Last >= First and then Temp (Last) = ' ' loop + Last := Last - 1; + end loop; + end if; + + Source.Data := (others => Wide_Wide_NUL); + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := Temp (First .. Last); + end Super_Trim; + + function Super_Trim + (Source : Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String + is + Result : Super_String (Source.Max_Length); + + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + Result.Current_Length := Last - First + 1; + Result.Data (1 .. Result.Current_Length) := + Source.Data (First .. Last); + return Result; + end if; + end loop; + end if; + end loop; + + Result.Current_Length := 0; + return Result; + end Super_Trim; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + begin + for First in 1 .. Source.Current_Length loop + if not Is_In (Source.Data (First), Left) then + for Last in reverse First .. Source.Current_Length loop + if not Is_In (Source.Data (Last), Right) then + if First = 1 then + Source.Current_Length := Last; + return; + else + Source.Current_Length := Last - First + 1; + Source.Data (1 .. Source.Current_Length) := + Source.Data (First .. Last); + + for J in Source.Current_Length + 1 .. + Source.Max_Length + loop + Source.Data (J) := Wide_Wide_NUL; + end loop; + + return; + end if; + end if; + end loop; + + Source.Current_Length := 0; + return; + end if; + end loop; + + Source.Current_Length := 0; + end Super_Trim; + + ----------- + -- Times -- + ----------- + + function Times + (Left : Natural; + Right : Wide_Wide_Character; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + + begin + if Left > Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Left; + + for J in 1 .. Left loop + Result.Data (J) := Right; + end loop; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Wide_Wide_String; + Max_Length : Positive) return Super_String + is + Result : Super_String (Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right'Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Max_Length then + raise Ada.Strings.Index_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := Right; + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + function Times + (Left : Natural; + Right : Super_String) return Super_String + is + Result : Super_String (Right.Max_Length); + Pos : Positive := 1; + Rlen : constant Natural := Right.Current_Length; + Nlen : constant Natural := Left * Rlen; + + begin + if Nlen > Right.Max_Length then + raise Ada.Strings.Length_Error; + + else + Result.Current_Length := Nlen; + + if Nlen > 0 then + for J in 1 .. Left loop + Result.Data (Pos .. Pos + Rlen - 1) := + Right.Data (1 .. Rlen); + Pos := Pos + Rlen; + end loop; + end if; + end if; + + return Result; + end Times; + + --------------------- + -- To_Super_String -- + --------------------- + + function To_Super_String + (Source : Wide_Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String + is + Result : Super_String (Max_Length); + Slen : constant Natural := Source'Length; + + begin + if Slen <= Max_Length then + Result.Current_Length := Slen; + Result.Data (1 .. Slen) := Source; + + else + case Drop is + when Strings.Right => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'First .. Source'First - 1 + Max_Length); + + when Strings.Left => + Result.Current_Length := Max_Length; + Result.Data (1 .. Max_Length) := + Source (Source'Last - (Max_Length - 1) .. Source'Last); + + when Strings.Error => + raise Ada.Strings.Length_Error; + end case; + end if; + + return Result; + end To_Super_String; + +end Ada.Strings.Wide_Wide_Superbounded; diff --git a/gcc/ada/libgnat/a-stzsup.ads b/gcc/ada/libgnat/a-stzsup.ads new file mode 100644 index 0000000..a3bc7f5 --- /dev/null +++ b/gcc/ada/libgnat/a-stzsup.ads @@ -0,0 +1,508 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ S U P E R B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This non generic package contains most of the implementation of the +-- generic package Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length. + +-- It defines type Super_String as a discriminated record with the maximum +-- length as the discriminant. Individual instantiations of the package +-- Strings.Wide_Wide_Bounded.Generic_Bounded_Length use this type with +-- an appropriate discriminant value set. + +with Ada.Strings.Wide_Wide_Maps; + +package Ada.Strings.Wide_Wide_Superbounded is + pragma Preelaborate; + + Wide_Wide_NUL : constant Wide_Wide_Character := + Wide_Wide_Character'Val (0); + + -- Wide_Wide_Bounded.Generic_Bounded_Length.Wide_Wide_Bounded_String is + -- derived from Super_String, with the constraint of the maximum length. + + type Super_String (Max_Length : Positive) is record + Current_Length : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length); + -- A previous version had a default initial value for Data, which is + -- no longer necessary, because we now special-case this type in the + -- compiler, so "=" composes properly for descendants of this type. + -- Leaving it out is more efficient. + end record; + + -- The subprograms defined for Super_String are similar to those defined + -- for Bounded_Wide_Wide_String, except that they have different names, so + -- that they can be renamed in Wide_Wide_Bounded.Generic_Bounded_Length. + + function Super_Length (Source : Super_String) return Natural; + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Super_String + (Source : Wide_Wide_String; + Max_Length : Natural; + Drop : Truncation := Error) return Super_String; + -- Note the additional parameter Max_Length, which specifies the maximum + -- length setting of the resulting Super_String value. + + -- The following procedures have declarations (and semantics) that are + -- exactly analogous to those declared in Ada.Strings.Wide_Wide_Bounded. + + function Super_To_String (Source : Super_String) return Wide_Wide_String; + + procedure Set_Super_String + (Target : out Super_String; + Source : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Append + (Left : Super_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Wide_Wide_String; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Super_String; + Right : Wide_Wide_Character; + Drop : Truncation := Error) return Super_String; + + function Super_Append + (Left : Wide_Wide_Character; + Right : Super_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Append + (Source : in out Super_String; + New_Item : Super_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + procedure Super_Append + (Source : in out Super_String; + New_Item : Wide_Wide_Character; + Drop : Truncation := Error); + + function Concat + (Left : Super_String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_Wide_String) return Super_String; + + function Concat + (Left : Wide_Wide_String; + Right : Super_String) return Super_String; + + function Concat + (Left : Super_String; + Right : Wide_Wide_Character) return Super_String; + + function Concat + (Left : Wide_Wide_Character; + Right : Super_String) return Super_String; + + function Super_Element + (Source : Super_String; + Index : Positive) return Wide_Wide_Character; + + procedure Super_Replace_Element + (Source : in out Super_String; + Index : Positive; + By : Wide_Wide_Character); + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Super_Slice + (Source : Super_String; + Low : Positive; + High : Natural) return Super_String; + + procedure Super_Slice + (Source : Super_String; + Target : out Super_String; + Low : Positive; + High : Natural); + + function "=" + (Left : Super_String; + Right : Super_String) return Boolean; + + function Equal + (Left : Super_String; + Right : Super_String) return Boolean renames "="; + + function Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Less + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Less_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Less_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Greater + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Super_String) return Boolean; + + function Greater_Or_Equal + (Left : Super_String; + Right : Wide_Wide_String) return Boolean; + + function Greater_Or_Equal + (Left : Wide_Wide_String; + Right : Super_String) return Boolean; + + ---------------------- + -- Search Functions -- + ---------------------- + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Super_Index + (Source : Super_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Super_Index + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + Going : Direction := Forward) return Natural; + + function Super_Index_Non_Blank + (Source : Super_String; + From : Positive; + Going : Direction := Forward) return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Super_Count + (Source : Super_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Super_Count + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + + procedure Super_Find_Token + (Source : Super_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Super_Translate + (Source : Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Super_String; + + procedure Super_Translate + (Source : in out Super_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Super_Replace_Slice + (Source : Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Replace_Slice + (Source : in out Super_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Insert + (Source : Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Insert + (Source : in out Super_String; + Before : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Overwrite + (Source : Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error) return Super_String; + + procedure Super_Overwrite + (Source : in out Super_String; + Position : Positive; + New_Item : Wide_Wide_String; + Drop : Truncation := Error); + + function Super_Delete + (Source : Super_String; + From : Positive; + Through : Natural) return Super_String; + + procedure Super_Delete + (Source : in out Super_String; + From : Positive; + Through : Natural); + + --------------------------------- + -- String Selector Subprograms -- + --------------------------------- + + function Super_Trim + (Source : Super_String; + Side : Trim_End) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Side : Trim_End); + + function Super_Trim + (Source : Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) return Super_String; + + procedure Super_Trim + (Source : in out Super_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Super_Head + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Head + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + function Super_Tail + (Source : Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error) return Super_String; + + procedure Super_Tail + (Source : in out Super_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space; + Drop : Truncation := Error); + + ------------------------------------ + -- String Constructor Subprograms -- + ------------------------------------ + + -- Note: in some of the following routines, there is an extra parameter + -- Max_Length which specifies the value of the maximum length for the + -- resulting Super_String value. + + function Times + (Left : Natural; + Right : Wide_Wide_Character; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Wide_Wide_String; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Times + (Left : Natural; + Right : Super_String) return Super_String; + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_Character; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Wide_Wide_String; + Drop : Truncation := Error; + Max_Length : Positive) return Super_String; + -- Note the additional parameter Max_Length + + function Super_Replicate + (Count : Natural; + Item : Super_String; + Drop : Truncation := Error) return Super_String; + +private + -- Pragma Inline declarations + + pragma Inline ("="); + pragma Inline (Less); + pragma Inline (Less_Or_Equal); + pragma Inline (Greater); + pragma Inline (Greater_Or_Equal); + pragma Inline (Concat); + pragma Inline (Super_Count); + pragma Inline (Super_Element); + pragma Inline (Super_Find_Token); + pragma Inline (Super_Index); + pragma Inline (Super_Index_Non_Blank); + pragma Inline (Super_Length); + pragma Inline (Super_Replace_Element); + pragma Inline (Super_Slice); + pragma Inline (Super_To_String); + +end Ada.Strings.Wide_Wide_Superbounded; diff --git a/gcc/ada/libgnat/a-stzunb-shared.adb b/gcc/ada/libgnat/a-stzunb-shared.adb new file mode 100644 index 0000000..e8b2372 --- /dev/null +++ b/gcc/ada/libgnat/a-stzunb-shared.adb @@ -0,0 +1,2137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Unbounded is + + use Ada.Strings.Wide_Wide_Maps; + + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc. This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + function Aligned_Max_Length (Max_Length : Natural) return Natural; + -- Returns recommended length of the shared string which is greater or + -- equal to specified length. Calculation take in sense alignment of + -- the allocated memory segments to use memory effectively by + -- Append/Insert/etc operations. + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := LR.Last + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left string is empty, return Rigth string + + elsif LR.Last = 0 then + Reference (RR); + DR := RR; + + -- Right string is empty, return Left string + + elsif RR.Last = 0 then + Reference (LR); + DR := LR; + + -- Overwise, allocate new shared string and fill data + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + Right'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Right is an empty string, return Left string + + elsif Right'Length = 0 then + Reference (LR); + DR := LR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (LR.Last + 1 .. DL) := Right; + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left'Length + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared one + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Left is empty string, return Right string + + elsif Left'Length = 0 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Left'Length) := Left; + DR.Data (Left'Length + 1 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + DL : constant Natural := LR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1 .. LR.Last) := LR.Data (1 .. LR.Last); + DR.Data (DL) := Right; + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := 1 + RR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + DR := Allocate (DL); + DR.Data (1) := Left; + DR.Data (2 .. DL) := RR.Data (1 .. RR.Last); + DR.Last := DL; + + return (AF.Controlled with Reference => DR); + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is an empty string, reuse shared empty string + + if Left = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Left); + + for J in 1 .. Left loop + DR.Data (J) := Right; + end loop; + + DR.Last := Left; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DL : constant Natural := Left * Right'Length; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + Right'Length - 1) := Right; + K := K + Right'Length; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + DL : constant Natural := Left * RR.Last; + DR : Shared_Wide_Wide_String_Access; + K : Positive; + + begin + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Coefficient is one, just return string itself + + elsif Left = 1 then + Reference (RR); + DR := RR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + K := 1; + + for J in 1 .. Left loop + DR.Data (K .. K + RR.Last - 1) := RR.Data (1 .. RR.Last); + K := K + RR.Last; + end loop; + + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) < RR.Data (1 .. RR.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) < Right; + end "<"; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left < RR.Data (1 .. RR.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) <= RR.Data (1 .. RR.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left <= RR.Data (1 .. RR.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + return LR = RR or else LR.Data (1 .. LR.Last) = RR.Data (1 .. RR.Last); + -- LR = RR means two strings shares shared string, thus they are equal + end "="; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) = Right; + end "="; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left = RR.Data (1 .. RR.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return LR.Data (1 .. LR.Last) > RR.Data (1 .. RR.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) > Right; + end ">"; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left > RR.Data (1 .. RR.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + + begin + -- LR = RR means two strings shares shared string, thus they are equal + + return LR = RR or else LR.Data (1 .. LR.Last) >= RR.Data (1 .. RR.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + LR : constant Shared_Wide_Wide_String_Access := Left.Reference; + begin + return LR.Data (1 .. LR.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + RR : constant Shared_Wide_Wide_String_Access := Right.Reference; + begin + return Left >= RR.Data (1 .. RR.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Adjust; + + ------------------------ + -- Aligned_Max_Length -- + ------------------------ + + function Aligned_Max_Length (Max_Length : Natural) return Natural is + Static_Size : constant Natural := + Empty_Shared_Wide_Wide_String'Size / Standard'Storage_Unit; + -- Total size of all static components + + Element_Size : constant Natural := + Wide_Wide_Character'Size / Standard'Storage_Unit; + + begin + return + (((Static_Size + Max_Length * Element_Size - 1) / Min_Mul_Alloc + 2) + * Min_Mul_Alloc - Static_Size) / Element_Size; + end Aligned_Max_Length; + + -------------- + -- Allocate -- + -------------- + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access is + begin + -- Empty string requested, return shared empty string + + if Max_Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + return Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate requested space (and probably some more room) + + else + return new Shared_Wide_Wide_String (Aligned_Max_Length (Max_Length)); + end if; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + NR : constant Shared_Wide_Wide_String_Access := New_Item.Reference; + DL : constant Natural := SR.Last + NR.Last; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Source is an empty string, reuse New_Item data + + if SR.Last = 0 then + Reference (NR); + Source.Reference := NR; + Unreference (SR); + + -- New_Item is empty string, nothing to do + + elsif NR.Last = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := NR.Data (1 .. NR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- New_Item is an empty string, nothing to do + + if New_Item'Length = 0 then + null; + + -- Try to reuse existing shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (SR.Last + 1 .. DL) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (SR.Last + 1 .. DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + 1; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Try to reuse existing shared string + + if Can_Be_Reused (SR, SR.Last + 1) then + SR.Data (SR.Last + 1) := New_Item; + SR.Last := SR.Last + 1; + + -- Otherwise, allocate new one and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (DL) := New_Item; + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Append; + + ------------------- + -- Can_Be_Reused -- + ------------------- + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean is + begin + return + System.Atomic_Counters.Is_One (Item.Counter) + and then Item.Max_Length >= Length + and then Item.Max_Length <= + Aligned_Max_Length (Length + Length / Growth_Factor); + end Can_Be_Reused; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Count (SR.Data (1 .. SR.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Empty slice is deleted, use the same shared string + + if From > Through then + Reference (SR); + DR := SR; + + -- Index is out of range + + elsif Through > SR.Last then + raise Index_Error; + + -- Compute size of the result + + else + DL := SR.Last - (Through - From + 1); + + -- Result is an empty string, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing changed, return + + if From > Through then + null; + + -- Through is outside of the range + + elsif Through > SR.Last then + raise Index_Error; + + else + DL := SR.Last - (Through - From + 1); + + -- Result is empty, reuse shared empty string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. From - 1) := SR.Data (1 .. From - 1); + DR.Data (From .. DL) := SR.Data (Through + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + if Index <= SR.Last then + return SR.Data (Index); + else + raise Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is + SR : constant Shared_Wide_Wide_String_Access := Object.Reference; + + begin + if SR /= null then + + -- The same controlled object can be finalized several times for + -- some reason. As per 7.6.1(24) this should have no ill effect, + -- so we need to add a guard for the case of finalizing the same + -- object twice. + + Object.Reference := null; + Unreference (SR); + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + Wide_Wide_Search.Find_Token + (SR.Data (From .. SR.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + Wide_Wide_Search.Find_Token + (SR.Data (1 .. SR.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + begin + Deallocate (X); + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse shared empty string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Length of the string is the same as requested, reuse source shared + -- string. + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is more than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- contents and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Result is empty, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Result is same with source string, reuse source shared string + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + if Count > SR.Last then + for J in SR.Last + 1 .. Count loop + SR.Data (J) := Pad; + end loop; + end if; + + SR.Last := Count; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (Count); + + -- Length of the source string is greater than requested, copy + -- corresponding slice. + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (1 .. Count); + + -- Length of the source string is less than requested, copy all + -- exists data and fill others by Pad character. + + else + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + + for J in SR.Last + 1 .. Count loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + Source.Reference := DR; + Unreference (SR); + end if; + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index (SR.Data (1 .. SR.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index + (SR.Data (1 .. SR.Last), Set, From, Test, Going); + end Index; + + --------------------- + -- Index_Non_Blank -- + --------------------- + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank (SR.Data (1 .. SR.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + begin + return Wide_Wide_Search.Index_Non_Blank + (SR.Data (1 .. SR.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is + begin + Reference (Object.Reference); + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check index first + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Inserted string is empty, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : constant Natural := SR.Last + New_Item'Length; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Before > SR.Last + 1 then + raise Index_Error; + end if; + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Inserted string is empty, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string first + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + SR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL + DL / Growth_Factor); + DR.Data (1 .. Before - 1) := SR.Data (1 .. Before - 1); + DR.Data (Before .. Before + New_Item'Length - 1) := New_Item; + DR.Data (Before + New_Item'Length .. DL) := + SR.Data (Before .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_Wide_String) return Natural is + begin + return Source.Reference.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is same with source string, reuse source shared string + + elsif New_Item'Length = 0 then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Position > SR.Last + 1 then + raise Index_Error; + end if; + + DL := Integer'Max (SR.Last, Position + New_Item'Length - 1); + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- String unchanged, nothing to do + + elsif New_Item'Length = 0 then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Position - 1) := SR.Data (1 .. Position - 1); + DR.Data (Position .. Position + New_Item'Length - 1) := New_Item; + DR.Data (Position + New_Item'Length .. DL) := + SR.Data (Position + New_Item'Length .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end Overwrite; + + --------------- + -- Reference -- + --------------- + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access) is + begin + System.Atomic_Counters.Increment (Item.Counter); + end Reference; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Index <= SR.Last then + + -- Try to reuse existent shared string + + if Can_Be_Reused (SR, SR.Last) then + SR.Data (Index) := By; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + DR.Data (1 .. SR.Last) := SR.Data (1 .. SR.Last); + DR.Data (Index) := By; + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + else + raise Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation when removed slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + + -- Otherwise just insert string + + else + return Insert (Source, Low, By); + end if; + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Bounds check + + if Low > SR.Last + 1 then + raise Index_Error; + end if; + + -- Do replace operation only when replaced slice is not empty + + if High >= Low then + DL := By'Length + SR.Last + Low - Integer'Min (High, SR.Last) - 1; + -- This is the number of characters remaining in the string after + -- replacing the slice. + + -- Result is empty string, reuse empty shared string + + if DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + SR.Data (Low .. Low + By'Length - 1) := By; + SR.Last := DL; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. Low - 1) := SR.Data (1 .. Low - 1); + DR.Data (Low .. Low + By'Length - 1) := By; + DR.Data (Low + By'Length .. DL) := SR.Data (High + 1 .. SR.Last); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + + -- Otherwise just insert item + + else + Insert (Source, Low, By); + end if; + end Replace_Slice; + + ------------------------------- + -- Set_Unbounded_Wide_Wide_String -- + ------------------------------- + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String) + is + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- In case of empty string, reuse empty shared string + + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + + else + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, Source'Length) then + Reference (TR); + DR := TR; + + -- Otherwise allocate new shared string + + else + DR := Allocate (Source'Length); + Target.Reference := DR; + end if; + + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + Unreference (TR); + end Set_Unbounded_Wide_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + else + return SR.Data (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- For empty result reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Result is hole source string, reuse source shared string + + elsif Count = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + end if; + + DR.Last := Count; + end if; + + return (AF.Controlled with Reference => DR); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural); + -- Common code of tail computation. SR/DR can point to the same object + + ------------ + -- Common -- + ------------ + + procedure Common + (SR : Shared_Wide_Wide_String_Access; + DR : Shared_Wide_Wide_String_Access; + Count : Natural) is + begin + if Count < SR.Last then + DR.Data (1 .. Count) := SR.Data (SR.Last - Count + 1 .. SR.Last); + + else + DR.Data (Count - SR.Last + 1 .. Count) := SR.Data (1 .. SR.Last); + + for J in 1 .. Count - SR.Last loop + DR.Data (J) := Pad; + end loop; + end if; + + DR.Last := Count; + end Common; + + begin + -- Result is empty string, reuse empty shared string + + if Count = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Length of the result is the same with length of the source string, + -- reuse source shared string. + + elsif Count = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, Count) then + Common (SR, SR, Count); + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (Count); + Common (SR, DR, Count); + Source.Reference := DR; + Unreference (SR); + end if; + end Tail; + + ------------------------- + -- To_Wide_Wide_String -- + ------------------------- + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String is + begin + return Source.Reference.Data (1 .. Source.Reference.Last); + end To_Wide_Wide_String; + + ----------------------------------- + -- To_Unbounded_Wide_Wide_String -- + ----------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + if Source'Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + DR := Allocate (Source'Length); + DR.Data (1 .. Source'Length) := Source; + DR.Last := Source'Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String + is + DR : Shared_Wide_Wide_String_Access; + + begin + if Length = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + DR := Allocate (Length); + DR.Last := Length; + end if; + + return (AF.Controlled with Reference => DR); + end To_Unbounded_Wide_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Value (Mapping, SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + end Translate; + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate, reuse empty shared string + + if SR.Last = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + end if; + + return (AF.Controlled with Reference => DR); + + exception + when others => + Unreference (DR); + + raise; + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Nothing to translate + + if SR.Last = 0 then + null; + + -- Try to reuse shared string + + elsif Can_Be_Reused (SR, SR.Last) then + for J in 1 .. SR.Last loop + SR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + -- Otherwise allocate new shared string and fill it + + else + DR := Allocate (SR.Last); + + for J in 1 .. SR.Last loop + DR.Data (J) := Mapping.all (SR.Data (J)); + end loop; + + DR.Last := SR.Last; + Source.Reference := DR; + Unreference (SR); + end if; + + exception + when others => + if DR /= null then + Unreference (DR); + end if; + + raise; + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- reuse source shared string. + + if DL = SR.Last then + Reference (SR); + DR := SR; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index_Non_Blank (Source, Forward); + + -- All blanks, reuse empty shared string + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + case Side is + when Left => + High := SR.Last; + DL := SR.Last - Low + 1; + + when Right => + Low := 1; + High := Index_Non_Blank (Source, Backward); + DL := High; + + when Both => + High := Index_Non_Blank (Source, Backward); + DL := High - Low + 1; + end case; + + -- Length of the result is the same as length of the source string, + -- nothing to do. + + if DL = SR.Last then + null; + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + end if; + + return (AF.Controlled with Reference => DR); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + Low : Natural; + High : Natural; + + begin + Low := Index (Source, Left, Outside, Forward); + + -- Source includes only characters from Left set, reuse empty shared + -- string. + + if Low = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + else + High := Index (Source, Right, Outside, Backward); + DL := Integer'Max (0, High - Low + 1); + + -- Source includes only characters from Right set or result string + -- is empty, reuse empty shared string. + + if High = 0 or else DL = 0 then + Reference (Empty_Shared_Wide_Wide_String'Access); + Source.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (SR); + + -- Try to reuse existent shared string + + elsif Can_Be_Reused (SR, DL) then + SR.Data (1 .. DL) := SR.Data (Low .. High); + SR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Source.Reference := DR; + Unreference (SR); + end if; + end if; + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + DR := Empty_Shared_Wide_Wide_String'Access; + + -- Otherwise, allocate new shared string and fill it + + else + DL := High - Low + 1; + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + end if; + + return (AF.Controlled with Reference => DR); + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) + is + SR : constant Shared_Wide_Wide_String_Access := Source.Reference; + TR : constant Shared_Wide_Wide_String_Access := Target.Reference; + DL : Natural; + DR : Shared_Wide_Wide_String_Access; + + begin + -- Check bounds + + if Low > SR.Last + 1 or else High > SR.Last then + raise Index_Error; + + -- Result is empty slice, reuse empty shared string + + elsif Low > High then + Reference (Empty_Shared_Wide_Wide_String'Access); + Target.Reference := Empty_Shared_Wide_Wide_String'Access; + Unreference (TR); + + else + DL := High - Low + 1; + + -- Try to reuse existent shared string + + if Can_Be_Reused (TR, DL) then + TR.Data (1 .. DL) := SR.Data (Low .. High); + TR.Last := DL; + + -- Otherwise, allocate new shared string and fill it + + else + DR := Allocate (DL); + DR.Data (1 .. DL) := SR.Data (Low .. High); + DR.Last := DL; + Target.Reference := DR; + Unreference (TR); + end if; + end if; + end Unbounded_Slice; + + ----------------- + -- Unreference -- + ----------------- + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access) is + + procedure Free is + new Ada.Unchecked_Deallocation + (Shared_Wide_Wide_String, Shared_Wide_Wide_String_Access); + + Aux : Shared_Wide_Wide_String_Access := Item; + + begin + if System.Atomic_Counters.Decrement (Aux.Counter) then + + -- Reference counter of Empty_Shared_Wide_Wide_String must never + -- reach zero. + + pragma Assert (Aux /= Empty_Shared_Wide_Wide_String'Access); + + Free (Aux); + end if; + end Unreference; + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzunb-shared.ads b/gcc/ada/libgnat/a-stzunb-shared.ads new file mode 100644 index 0000000..f1ad923 --- /dev/null +++ b/gcc/ada/libgnat/a-stzunb-shared.ads @@ -0,0 +1,513 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is supported on: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86 platforms +-- - all x86_64 platforms + +with Ada.Strings.Wide_Wide_Maps; +private with Ada.Finalization; +private with System.Atomic_Counters; + +package Ada.Strings.Wide_Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; + + function Length (Source : Unbounded_Wide_Wide_String) return Natural; + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (X : in out Wide_Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character); + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String); + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String); + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String); + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + type Shared_Wide_Wide_String (Max_Length : Natural) is limited record + Counter : System.Atomic_Counters.Atomic_Counter; + -- Reference counter + + Last : Natural := 0; + Data : Wide_Wide_String (1 .. Max_Length); + -- Last is the index of last significant element of the Data. All + -- elements with larger indexes are just extra room for expansion. + end record; + + type Shared_Wide_Wide_String_Access is access all Shared_Wide_Wide_String; + + procedure Reference (Item : not null Shared_Wide_Wide_String_Access); + -- Increment reference counter. + + procedure Unreference (Item : not null Shared_Wide_Wide_String_Access); + -- Decrement reference counter. Deallocate Item when reference counter is + -- zero. + + function Can_Be_Reused + (Item : Shared_Wide_Wide_String_Access; + Length : Natural) return Boolean; + -- Returns True if Shared_Wide_Wide_String can be reused. There are two + -- criteria when Shared_Wide_Wide_String can be reused: its reference + -- counter must be one (thus Shared_Wide_Wide_String is owned exclusively) + -- and its size is sufficient to store string with specified length + -- effectively. + + function Allocate + (Max_Length : Natural) return Shared_Wide_Wide_String_Access; + -- Allocates new Shared_Wide_Wide_String with at least specified maximum + -- length. Actual maximum length of the allocated Shared_Wide_Wide_String + -- can be slightly greater. Returns reference to + -- Empty_Shared_Wide_Wide_String when requested length is zero. + + Empty_Shared_Wide_Wide_String : aliased Shared_Wide_Wide_String (0); + + function To_Unbounded + (S : Wide_Wide_String) return Unbounded_Wide_Wide_String + renames To_Unbounded_Wide_Wide_String; + -- This renames are here only to be used in the pragma Stream_Convert. + + type Unbounded_Wide_Wide_String is new AF.Controlled with record + Reference : Shared_Wide_Wide_String_Access := + Empty_Shared_Wide_Wide_String'Access; + end record; + + -- The Unbounded_Wide_Wide_String uses several techniques to increase speed + -- of the application: + + -- - implicit sharing or copy-on-write. Unbounded_Wide_Wide_String + -- contains only the reference to the data which is shared between + -- several instances. The shared data is reallocated only when its value + -- is changed and the object mutation can't be used or it is inefficient + -- to use it; + + -- - object mutation. Shared data object can be reused without memory + -- reallocation when all of the following requirements are meat: + -- - shared data object don't used anywhere longer; + -- - its size is sufficient to store new value; + -- - the gap after reuse is less than some threshold. + + -- - memory preallocation. Most of used memory allocation algorithms + -- aligns allocated segment on the some boundary, thus some amount of + -- additional memory can be preallocated without any impact. Such + -- preallocated memory can used later by Append/Insert operations + -- without reallocation. + + -- Reference counting uses GCC builtin atomic operations, which allows safe + -- sharing of internal data between Ada tasks. Nevertheless, this does not + -- make objects of Unbounded_String thread-safe: an instance cannot be + -- accessed by several tasks simultaneously. + + pragma Stream_Convert + (Unbounded_Wide_Wide_String, To_Unbounded, To_Wide_Wide_String); + -- Provide stream routines without dragging in Ada.Streams + + pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); + -- Finalization is required only for freeing storage + + overriding procedure Initialize + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Adjust + (Object : in out Unbounded_Wide_Wide_String); + overriding procedure Finalize + (Object : in out Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := + (AF.Controlled with + Reference => + Empty_Shared_Wide_Wide_String' + Access); + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzunb.adb b/gcc/ada/libgnat/a-stzunb.adb new file mode 100644 index 0000000..25c3b29 --- /dev/null +++ b/gcc/ada/libgnat/a-stzunb.adb @@ -0,0 +1,1107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Fixed; +with Ada.Strings.Wide_Wide_Search; +with Ada.Unchecked_Deallocation; + +package body Ada.Strings.Wide_Wide_Unbounded is + + use Ada.Finalization; + + --------- + -- "&" -- + --------- + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + L_Length : constant Natural := Left.Last; + R_Length : constant Natural := Right.Last; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := L_Length + R_Length; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := + Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + L_Length : constant Natural := Left.Last; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := L_Length + Right'Length; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. L_Length) := Left.Reference (1 .. Left.Last); + Result.Reference (L_Length + 1 .. Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + R_Length : constant Natural := Right.Last; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left'Length + R_Length; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. Left'Length) := Left; + Result.Reference (Left'Length + 1 .. Result.Last) := + Right.Reference (1 .. Right.Last); + + return Result; + end "&"; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left.Last + 1; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + Result.Reference (1 .. Result.Last - 1) := + Left.Reference (1 .. Left.Last); + Result.Reference (Result.Last) := Right; + + return Result; + end "&"; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Right.Last + 1; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + Result.Reference (1) := Left; + Result.Reference (2 .. Result.Last) := + Right.Reference (1 .. Right.Last); + return Result; + end "&"; + + --------- + -- "*" -- + --------- + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left; + + Result.Reference := new Wide_Wide_String (1 .. Left); + for J in Result.Reference'Range loop + Result.Reference (J) := Right; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Len : constant Natural := Right'Length; + K : Positive; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + K := 1; + for J in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := Right; + K := K + Len; + end loop; + + return Result; + end "*"; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Len : constant Natural := Right.Last; + K : Positive; + Result : Unbounded_Wide_Wide_String; + + begin + Result.Last := Left * Len; + + Result.Reference := new Wide_Wide_String (1 .. Result.Last); + + K := 1; + for J in 1 .. Left loop + Result.Reference (K .. K + Len - 1) := + Right.Reference (1 .. Right.Last); + K := K + Len; + end loop; + + return Result; + end "*"; + + --------- + -- "<" -- + --------- + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) < Right.Reference (1 .. Right.Last); + end "<"; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) < Right; + end "<"; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left < Right.Reference (1 .. Right.Last); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) <= Right.Reference (1 .. Right.Last); + end "<="; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) <= Right; + end "<="; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left <= Right.Reference (1 .. Right.Last); + end "<="; + + --------- + -- "=" -- + --------- + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) = Right.Reference (1 .. Right.Last); + end "="; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) = Right; + end "="; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left = Right.Reference (1 .. Right.Last); + end "="; + + --------- + -- ">" -- + --------- + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) > Right.Reference (1 .. Right.Last); + end ">"; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) > Right; + end ">"; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left > Right.Reference (1 .. Right.Last); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return + Left.Reference (1 .. Left.Last) >= Right.Reference (1 .. Right.Last); + end ">="; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean + is + begin + return Left.Reference (1 .. Left.Last) >= Right; + end ">="; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean + is + begin + return Left >= Right.Reference (1 .. Right.Last); + end ">="; + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Unbounded_Wide_Wide_String) is + begin + -- Copy string, except we do not copy the statically allocated null + -- string, since it can never be deallocated. Note that we do not copy + -- extra string room here to avoid dragging unused allocated memory. + + if Object.Reference /= Null_Wide_Wide_String'Access then + Object.Reference := + new Wide_Wide_String'(Object.Reference (1 .. Object.Last)); + end if; + end Adjust; + + ------------ + -- Append -- + ------------ + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String) + is + begin + Realloc_For_Chunk (Source, New_Item.Last); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item.Last) := + New_Item.Reference (1 .. New_Item.Last); + Source.Last := Source.Last + New_Item.Last; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String) + is + begin + Realloc_For_Chunk (Source, New_Item'Length); + Source.Reference (Source.Last + 1 .. Source.Last + New_Item'Length) := + New_Item; + Source.Last := Source.Last + New_Item'Length; + end Append; + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character) + is + begin + Realloc_For_Chunk (Source, 1); + Source.Reference (Source.Last + 1) := New_Item; + Source.Last := Source.Last + 1; + end Append; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + begin + return + Wide_Wide_Search.Count + (Source.Reference (1 .. Source.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return + Wide_Wide_Search.Count + (Source.Reference (1 .. Source.Last), Pattern, Mapping); + end Count; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural + is + begin + return + Wide_Wide_Search.Count + (Source.Reference (1 .. Source.Last), Set); + end Count; + + ------------ + -- Delete -- + ------------ + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String + is + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Delete + (Source.Reference (1 .. Source.Last), From, Through)); + end Delete; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) + is + begin + if From > Through then + null; + + elsif From < Source.Reference'First or else Through > Source.Last then + raise Index_Error; + + else + declare + Len : constant Natural := Through - From + 1; + + begin + Source.Reference (From .. Source.Last - Len) := + Source.Reference (Through + 1 .. Source.Last); + Source.Last := Source.Last - Len; + end; + end if; + end Delete; + + ------------- + -- Element -- + ------------- + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character + is + begin + if Index <= Source.Last then + return Source.Reference (Index); + else + raise Strings.Index_Error; + end if; + end Element; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Unbounded_Wide_Wide_String) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + + begin + -- Note: Don't try to free statically allocated null string + + if Object.Reference /= Null_Wide_Wide_String'Access then + Deallocate (Object.Reference); + Object.Reference := Null_Unbounded_Wide_Wide_String.Reference; + Object.Last := 0; + end if; + end Finalize; + + ---------------- + -- Find_Token -- + ---------------- + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Wide_Search.Find_Token + (Source.Reference (From .. Source.Last), Set, Test, First, Last); + end Find_Token; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership; + First : out Positive; + Last : out Natural) + is + begin + Wide_Wide_Search.Find_Token + (Source.Reference (1 .. Source.Last), Set, Test, First, Last); + end Find_Token; + + ---------- + -- Free -- + ---------- + + procedure Free (X : in out Wide_Wide_String_Access) is + procedure Deallocate is + new Ada.Unchecked_Deallocation + (Wide_Wide_String, Wide_Wide_String_Access); + + begin + -- Note: Do not try to free statically allocated null string + + if X /= Null_Unbounded_Wide_Wide_String.Reference then + Deallocate (X); + end if; + end Free; + + ---------- + -- Head -- + ---------- + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String + is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Head + (Source.Reference (1 .. Source.Last), Count, Pad)); + end Head; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := + new Wide_Wide_String' + (Wide_Wide_Fixed.Head + (Source.Reference (1 .. Source.Last), Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + end Head; + + ----------- + -- Index -- + ----------- + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Strings.Direction := Strings.Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + begin + return + Wide_Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return + Wide_Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Strings.Membership := Strings.Inside; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return Wide_Wide_Search.Index + (Source.Reference (1 .. Source.Last), Set, Test, Going); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) return Natural + is + begin + return + Wide_Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural + is + begin + return + Wide_Wide_Search.Index + (Source.Reference (1 .. Source.Last), Pattern, From, Going, Mapping); + end Index; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural + is + begin + return + Wide_Wide_Search.Index + (Source.Reference (1 .. Source.Last), Set, From, Test, Going); + end Index; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Strings.Direction := Strings.Forward) return Natural + is + begin + return + Wide_Wide_Search.Index_Non_Blank + (Source.Reference (1 .. Source.Last), Going); + end Index_Non_Blank; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural + is + begin + return + Wide_Wide_Search.Index_Non_Blank + (Source.Reference (1 .. Source.Last), From, Going); + end Index_Non_Blank; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String) is + begin + Object.Reference := Null_Unbounded_Wide_Wide_String.Reference; + Object.Last := 0; + end Initialize; + + ------------ + -- Insert -- + ------------ + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Insert + (Source.Reference (1 .. Source.Last), Before, New_Item)); + end Insert; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) + is + begin + if Before not in Source.Reference'First .. Source.Last + 1 then + raise Index_Error; + end if; + + Realloc_For_Chunk (Source, New_Item'Length); + + Source.Reference + (Before + New_Item'Length .. Source.Last + New_Item'Length) := + Source.Reference (Before .. Source.Last); + + Source.Reference (Before .. Before + New_Item'Length - 1) := New_Item; + Source.Last := Source.Last + New_Item'Length; + end Insert; + + ------------ + -- Length -- + ------------ + + function Length (Source : Unbounded_Wide_Wide_String) return Natural is + begin + return Source.Last; + end Length; + + --------------- + -- Overwrite -- + --------------- + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + end Overwrite; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) + is + NL : constant Natural := New_Item'Length; + begin + if Position <= Source.Last - NL + 1 then + Source.Reference (Position .. Position + NL - 1) := New_Item; + else + declare + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Overwrite + (Source.Reference (1 .. Source.Last), Position, New_Item)); + Source.Last := Source.Reference'Length; + Free (Old); + end; + end if; + end Overwrite; + + ----------------------- + -- Realloc_For_Chunk -- + ----------------------- + + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_Wide_String; + Chunk_Size : Natural) + is + Growth_Factor : constant := 32; + -- The growth factor controls how much extra space is allocated when + -- we have to increase the size of an allocated unbounded string. By + -- allocating extra space, we avoid the need to reallocate on every + -- append, particularly important when a string is built up by repeated + -- append operations of small pieces. This is expressed as a factor so + -- 32 means add 1/32 of the length of the string as growth space. + + Min_Mul_Alloc : constant := Standard'Maximum_Alignment; + -- Allocation will be done by a multiple of Min_Mul_Alloc This causes + -- no memory loss as most (all?) malloc implementations are obliged to + -- align the returned memory on the maximum alignment as malloc does not + -- know the target alignment. + + S_Length : constant Natural := Source.Reference'Length; + + begin + if Chunk_Size > S_Length - Source.Last then + declare + New_Size : constant Positive := + S_Length + Chunk_Size + (S_Length / Growth_Factor); + + New_Rounded_Up_Size : constant Positive := + ((New_Size - 1) / Min_Mul_Alloc + 1) * Min_Mul_Alloc; + + Tmp : constant Wide_Wide_String_Access := + new Wide_Wide_String (1 .. New_Rounded_Up_Size); + + begin + Tmp (1 .. Source.Last) := Source.Reference (1 .. Source.Last); + Free (Source.Reference); + Source.Reference := Tmp; + end; + end if; + end Realloc_For_Chunk; + + --------------------- + -- Replace_Element -- + --------------------- + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character) + is + begin + if Index <= Source.Last then + Source.Reference (Index) := By; + else + raise Strings.Index_Error; + end if; + end Replace_Element; + + ------------------- + -- Replace_Slice -- + ------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + end Replace_Slice; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) + is + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Replace_Slice + (Source.Reference (1 .. Source.Last), Low, High, By)); + Source.Last := Source.Reference'Length; + Free (Old); + end Replace_Slice; + + ------------------------------------ + -- Set_Unbounded_Wide_Wide_String -- + ------------------------------------ + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String) + is + begin + Target.Last := Source'Length; + Target.Reference := new Wide_Wide_String (1 .. Source'Length); + Target.Reference.all := Source; + end Set_Unbounded_Wide_Wide_String; + + ----------- + -- Slice -- + ----------- + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String + is + begin + -- Note: test of High > Length is in accordance with AI95-00128 + + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + return Source.Reference (Low .. High); + end if; + end Slice; + + ---------- + -- Tail -- + ---------- + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String is + begin + return To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Tail + (Source.Reference (1 .. Source.Last), Count, Pad)); + end Tail; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + is + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := new Wide_Wide_String' + (Wide_Wide_Fixed.Tail + (Source.Reference (1 .. Source.Last), Count, Pad)); + Source.Last := Source.Reference'Length; + Free (Old); + end Tail; + + ----------------------------------- + -- To_Unbounded_Wide_Wide_String -- + ----------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + begin + Result.Last := Source'Length; + Result.Reference := new Wide_Wide_String (1 .. Source'Length); + Result.Reference.all := Source; + return Result; + end To_Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String + is + Result : Unbounded_Wide_Wide_String; + begin + Result.Last := Length; + Result.Reference := new Wide_Wide_String (1 .. Length); + return Result; + end To_Unbounded_Wide_Wide_String; + + ------------------------- + -- To_Wide_Wide_String -- + ------------------------- + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String + is + begin + return Source.Reference (1 .. Source.Last); + end To_Wide_Wide_String; + + --------------- + -- Translate -- + --------------- + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String + is + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + is + begin + Wide_Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String + is + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Translate + (Source.Reference (1 .. Source.Last), Mapping)); + end Translate; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + is + begin + Wide_Wide_Fixed.Translate (Source.Reference (1 .. Source.Last), Mapping); + end Translate; + + ---------- + -- Trim -- + ---------- + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String + is + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End) + is + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := + new Wide_Wide_String' + (Wide_Wide_Fixed.Trim (Source.Reference (1 .. Source.Last), Side)); + Source.Last := Source.Reference'Length; + Free (Old); + end Trim; + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String + is + begin + return + To_Unbounded_Wide_Wide_String + (Wide_Wide_Fixed.Trim + (Source.Reference (1 .. Source.Last), Left, Right)); + end Trim; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + is + Old : Wide_Wide_String_Access := Source.Reference; + begin + Source.Reference := + new Wide_Wide_String' + (Wide_Wide_Fixed.Trim + (Source.Reference (1 .. Source.Last), Left, Right)); + Source.Last := Source.Reference'Length; + Free (Old); + end Trim; + + --------------------- + -- Unbounded_Slice -- + --------------------- + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String + is + begin + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + return + To_Unbounded_Wide_Wide_String (Source.Reference.all (Low .. High)); + end if; + end Unbounded_Slice; + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) + is + begin + if Low > Source.Last + 1 or else High > Source.Last then + raise Index_Error; + else + Target := + To_Unbounded_Wide_Wide_String (Source.Reference.all (Low .. High)); + end if; + end Unbounded_Slice; + +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-stzunb.ads b/gcc/ada/libgnat/a-stzunb.ads new file mode 100644 index 0000000..9b9cf69 --- /dev/null +++ b/gcc/ada/libgnat/a-stzunb.ads @@ -0,0 +1,452 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Maps; +with Ada.Finalization; + +package Ada.Strings.Wide_Wide_Unbounded is + pragma Preelaborate; + + type Unbounded_Wide_Wide_String is private; + pragma Preelaborable_Initialization (Unbounded_Wide_Wide_String); + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String; + + function Length (Source : Unbounded_Wide_Wide_String) return Natural; + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (X : in out Wide_Wide_String_Access); + + -------------------------------------------------------- + -- Conversion, Concatenation, and Selection Functions -- + -------------------------------------------------------- + + function To_Unbounded_Wide_Wide_String + (Source : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function To_Unbounded_Wide_Wide_String + (Length : Natural) return Unbounded_Wide_Wide_String; + + function To_Wide_Wide_String + (Source : Unbounded_Wide_Wide_String) return Wide_Wide_String; + + procedure Set_Unbounded_Wide_Wide_String + (Target : out Unbounded_Wide_Wide_String; + Source : Wide_Wide_String); + pragma Ada_05 (Set_Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Unbounded_Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_String); + + procedure Append + (Source : in out Unbounded_Wide_Wide_String; + New_Item : Wide_Wide_Character); + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "&" + (Left : Wide_Wide_Character; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function Element + (Source : Unbounded_Wide_Wide_String; + Index : Positive) return Wide_Wide_Character; + + procedure Replace_Element + (Source : in out Unbounded_Wide_Wide_String; + Index : Positive; + By : Wide_Wide_Character); + + function Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Wide_Wide_String; + + function Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural) return Unbounded_Wide_Wide_String; + pragma Ada_05 (Unbounded_Slice); + + procedure Unbounded_Slice + (Source : Unbounded_Wide_Wide_String; + Target : out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural); + pragma Ada_05 (Unbounded_Slice); + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function "<=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function "<=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + function ">=" + (Left : Unbounded_Wide_Wide_String; + Right : Wide_Wide_String) return Boolean; + + function ">=" + (Left : Wide_Wide_String; + Right : Unbounded_Wide_Wide_String) return Boolean; + + ------------------------ + -- Search Subprograms -- + ------------------------ + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + From : Positive; + Going : Direction := Forward; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + pragma Ada_05 (Index); + + function Index + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership := Inside; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index); + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + Going : Direction := Forward) return Natural; + + function Index_Non_Blank + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Going : Direction := Forward) return Natural; + pragma Ada_05 (Index_Non_Blank); + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping := + Wide_Wide_Maps.Identity) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Pattern : Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Natural; + + function Count + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set) return Natural; + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + From : Positive; + Test : Membership; + First : out Positive; + Last : out Natural); + pragma Ada_2012 (Find_Token); + + procedure Find_Token + (Source : Unbounded_Wide_Wide_String; + Set : Wide_Wide_Maps.Wide_Wide_Character_Set; + Test : Membership; + First : out Positive; + Last : out Natural); + + ------------------------------------ + -- String Translation Subprograms -- + ------------------------------------ + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping); + + function Translate + (Source : Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function) + return Unbounded_Wide_Wide_String; + + procedure Translate + (Source : in out Unbounded_Wide_Wide_String; + Mapping : Wide_Wide_Maps.Wide_Wide_Character_Mapping_Function); + + --------------------------------------- + -- String Transformation Subprograms -- + --------------------------------------- + + function Replace_Slice + (Source : Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Replace_Slice + (Source : in out Unbounded_Wide_Wide_String; + Low : Positive; + High : Natural; + By : Wide_Wide_String); + + function Insert + (Source : Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Insert + (Source : in out Unbounded_Wide_Wide_String; + Before : Positive; + New_Item : Wide_Wide_String); + + function Overwrite + (Source : Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + procedure Overwrite + (Source : in out Unbounded_Wide_Wide_String; + Position : Positive; + New_Item : Wide_Wide_String); + + function Delete + (Source : Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural) return Unbounded_Wide_Wide_String; + + procedure Delete + (Source : in out Unbounded_Wide_Wide_String; + From : Positive; + Through : Natural); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Side : Trim_End) return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Side : Trim_End); + + function Trim + (Source : Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set) + return Unbounded_Wide_Wide_String; + + procedure Trim + (Source : in out Unbounded_Wide_Wide_String; + Left : Wide_Wide_Maps.Wide_Wide_Character_Set; + Right : Wide_Wide_Maps.Wide_Wide_Character_Set); + + function Head + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Head + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function Tail + (Source : Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space) + return Unbounded_Wide_Wide_String; + + procedure Tail + (Source : in out Unbounded_Wide_Wide_String; + Count : Natural; + Pad : Wide_Wide_Character := Wide_Wide_Space); + + function "*" + (Left : Natural; + Right : Wide_Wide_Character) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Wide_Wide_String) return Unbounded_Wide_Wide_String; + + function "*" + (Left : Natural; + Right : Unbounded_Wide_Wide_String) return Unbounded_Wide_Wide_String; + +private + pragma Inline (Length); + + package AF renames Ada.Finalization; + + Null_Wide_Wide_String : aliased Wide_Wide_String := ""; + + function To_Unbounded_Wide + (S : Wide_Wide_String) return Unbounded_Wide_Wide_String + renames To_Unbounded_Wide_Wide_String; + + type Unbounded_Wide_Wide_String is new AF.Controlled with record + Reference : Wide_Wide_String_Access := Null_Wide_Wide_String'Access; + Last : Natural := 0; + end record; + + -- The Unbounded_Wide_Wide_String is using a buffered implementation to + -- increase speed of the Append/Delete/Insert procedures. The Reference + -- string pointer above contains the current string value and extra room + -- at the end to be used by the next Append routine. Last is the index of + -- the string ending character. So the current string value is really + -- Reference (1 .. Last). + + pragma Stream_Convert + (Unbounded_Wide_Wide_String, To_Unbounded_Wide, To_Wide_Wide_String); + + pragma Finalize_Storage_Only (Unbounded_Wide_Wide_String); + -- Finalization is required only for freeing storage + + procedure Initialize (Object : in out Unbounded_Wide_Wide_String); + procedure Adjust (Object : in out Unbounded_Wide_Wide_String); + procedure Finalize (Object : in out Unbounded_Wide_Wide_String); + procedure Realloc_For_Chunk + (Source : in out Unbounded_Wide_Wide_String; + Chunk_Size : Natural); + -- Adjust the size allocated for the string. Add at least Chunk_Size so it + -- is safe to add a string of this size at the end of the current content. + -- The real size allocated for the string is Chunk_Size + x of the current + -- string size. This buffered handling makes the Append unbounded string + -- routines very fast. + + Null_Unbounded_Wide_Wide_String : constant Unbounded_Wide_Wide_String := + (AF.Controlled with + Reference => + Null_Wide_Wide_String'Access, + Last => 0); +end Ada.Strings.Wide_Wide_Unbounded; diff --git a/gcc/ada/libgnat/a-suecin.adb b/gcc/ada/libgnat/a-suecin.adb new file mode 100644 index 0000000..0ff4908 --- /dev/null +++ b/gcc/ada/libgnat/a-suecin.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Equal_Case_Insensitive; + +function Ada.Strings.Unbounded.Equal_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean +is + SL, SR : Aux.Big_String_Access; + LL, LR : Natural; + +begin + Aux.Get_String (Left, SL, LL); + Aux.Get_String (Right, SR, LR); + + return Ada.Strings.Equal_Case_Insensitive + (Left => SL (1 .. LL), + Right => SR (1 .. LR)); +end Ada.Strings.Unbounded.Equal_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-suecin.ads b/gcc/ada/libgnat/a-suecin.ads new file mode 100644 index 0000000..996f0e3 --- /dev/null +++ b/gcc/ada/libgnat/a-suecin.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.EQUAL_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Unbounded.Equal_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Unbounded.Equal_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-suenco.adb b/gcc/ada/libgnat/a-suenco.adb new file mode 100644 index 0000000..1e288f5 --- /dev/null +++ b/gcc/ada/libgnat/a-suenco.adb @@ -0,0 +1,418 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Conversions is + use Interfaces; + + -- Convert from UTF-8/UTF-16BE/LE to UTF-8/UTF-16BE/LE + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Nothing to do if identical schemes, but for UTF_8 we need to + -- handle overlong encodings, so need to do the full conversion. + + if Input_Scheme = Output_Scheme + and then Input_Scheme /= UTF_8 + then + return Item; + + -- For remaining cases, one or other of the operands is UTF-16BE/LE + -- encoded, or we have the UTF-8 to UTF-8 case where we must handle + -- overlong encodings. In all cases, go through UTF-16 intermediate. + + else + return Convert (UTF_16_Wide_String'(Convert (Item, Input_Scheme)), + Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Convert from UTF-8/UTF-16BE/LE to UTF-16 + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return To_UTF_16 (Item, Input_Scheme, Output_BOM); + end if; + end Convert; + + -- Convert from UTF-8 to UTF-16 + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. Item'Length + 1); + -- Maximum length of result, including possible BOM + + Len : Natural := 0; + -- Number of characters stored so far in Result + + Iptr : Natural; + -- Next character to process in Item + + C : Unsigned_8; + -- Input UTF-8 code + + R : Unsigned_16; + -- Output UTF-16 code + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6 + -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr + -- is incremented. Raises exception if continuation byte does not exist + -- or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C < 2#10_000000# or else C > 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + else + R := + Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Convert + + begin + -- Output BOM if required + + if Output_BOM then + Len := Len + 1; + Result (Len) := BOM_16 (1); + end if; + + -- Skip OK BOM + + Iptr := Item'First; + + if Item'Length >= 3 and then Item (Iptr .. Iptr + 2) = BOM_8 then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + + -- No BOM present + + else + Iptr := Item'First; + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# .. 16#7F# + -- UTF-8: 0xxxxxxx + -- UTF-16: 00000000_0xxxxxxx + + if C <= 16#7F# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# .. 16#7FF# + -- UTF-8: 110yyyxx 10xxxxxx + -- UTF-16: 00000yyy_xxxxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Codes in the range 16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF# + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + -- UTF-16: yyyyyyyy_xxxxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Make sure that we don't have a result in the forbidden range + -- reserved for UTF-16 surrogate characters. + + if R in 16#D800# .. 16#DF00# then + Raise_Encoding_Error (Iptr - 3); + end if; + + -- Codes in the range 16#10000# .. 16#10FFFF# + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- UTF-16: 110110zz_zzyyyyyy 110111yy_xxxxxxxx + -- Note: zzzz in the output is input zzzzz - 1 + + elsif C <= 2#11110_111# then + R := Unsigned_16 (C and 2#00000_111#); + Get_Continuation; + + -- R now has zzzzzyyyy + + -- At this stage, we check for the case where we have an overlong + -- encoding, and the encoded value in fact lies in the single word + -- range (16#800# .. 16#D7FF or 16#DF01# .. 16#FFFF#). This means + -- that the result fits in a single result word. + + if R <= 2#1111# then + Get_Continuation; + Get_Continuation; + + -- Make sure we are not in the forbidden surrogate range + + if R in 16#D800# .. 16#DF00# then + Raise_Encoding_Error (Iptr - 3); + end if; + + -- Otherwise output a single UTF-16 value + + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + + -- Here for normal case (code value > 16#FFFF and zzzzz non-zero) + + else + -- Subtract 1 from input zzzzz value to get output zzzz value + + R := R - 2#0000_1_0000#; + + -- R now has zzzzyyyy (zzzz minus one for the output) + + Get_Continuation; + + -- R now has zzzzyy_yyyyyyxx + + Len := Len + 1; + Result (Len) := + Wide_Character'Val + (2#110110_00_0000_0000# or Shift_Right (R, 4)); + + R := R and 2#1111#; + Get_Continuation; + Len := Len + 1; + Result (Len) := + Wide_Character'Val (2#110111_00_0000_0000# or R); + end if; + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + + -- Convert from UTF-16 to UTF-8/UTF-16-BE/LE + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Convert (Item, Output_BOM); + else + return From_UTF_16 (Item, Output_Scheme, Output_BOM); + end if; + end Convert; + + -- Convert from UTF-16 to UTF-8 + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is 3 output codes for each input code + BOM space + + Len : Natural; + -- Number of result codes stored + + Iptr : Natural; + -- Pointer to next input character + + C1, C2 : Unsigned_16; + + zzzzz : Unsigned_16; + yyyyyyyy : Unsigned_16; + xxxxxxxx : Unsigned_16; + -- Components of double length case + + begin + Iptr := Item'First; + + -- Skip BOM at start of input + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Generate output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through input + + while Iptr <= Item'Last loop + C1 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000# - 16#007F# + -- UTF-16: 000000000xxxxxxx + -- UTF-8: 0xxxxxxx + + if C1 <= 16#007F# then + Result (Len + 1) := Character'Val (C1); + Len := Len + 1; + + -- Codes in the range 16#80# - 16#7FF# + -- UTF-16: 00000yyyxxxxxxxx + -- UTF-8: 110yyyxx 10xxxxxx + + elsif C1 <= 16#07FF# then + Result (Len + 1) := + Character'Val + (2#110_00000# or Shift_Right (C1, 6)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 2; + + -- Codes in the range 16#800# - 16#D7FF# or 16#E000# - 16#FFFF# + -- UTF-16: yyyyyyyyxxxxxxxx + -- UTF-8: 1110yyyy 10yyyyxx 10xxxxxx + + elsif C1 <= 16#D7FF# or else C1 >= 16#E000# then + Result (Len + 1) := + Character'Val + (2#1110_0000# or Shift_Right (C1, 12)); + Result (Len + 2) := + Character'Val + (2#10_000000# or (Shift_Right (C1, 6) and 2#00_111111#)); + Result (Len + 3) := + Character'Val + (2#10_000000# or (C1 and 2#00_111111#)); + Len := Len + 3; + + -- Codes in the range 16#10000# - 16#10FFFF# + -- UTF-16: 110110zzzzyyyyyy 110111yyxxxxxxxx + -- UTF-8: 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + -- Note: zzzzz in the output is input zzzz + 1 + + elsif C1 <= 2#110110_11_11111111# then + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + else + C2 := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + end if; + + if (C2 and 2#111111_00_00000000#) /= 2#110111_00_00000000# then + Raise_Encoding_Error (Iptr - 1); + end if; + + zzzzz := (Shift_Right (C1, 6) and 2#1111#) + 1; + yyyyyyyy := ((Shift_Left (C1, 2) and 2#111111_00#) + or + (Shift_Right (C2, 8) and 2#000000_11#)); + xxxxxxxx := C2 and 2#11111111#; + + Result (Len + 1) := + Character'Val + (2#11110_000# or (Shift_Right (zzzzz, 2))); + Result (Len + 2) := + Character'Val + (2#10_000000# or Shift_Left (zzzzz and 2#11#, 4) + or Shift_Right (yyyyyyyy, 4)); + Result (Len + 3) := + Character'Val + (2#10_000000# or Shift_Left (yyyyyyyy and 2#1111#, 4) + or Shift_Right (xxxxxxxx, 6)); + Result (Len + 4) := + Character'Val + (2#10_000000# or (xxxxxxxx and 2#00_111111#)); + Len := Len + 4; + + -- Error if input in 16#DC00# - 16#DFFF# (2nd surrogate with no 1st) + + else + Raise_Encoding_Error (Iptr - 2); + end if; + end loop; + + return Result (1 .. Len); + end Convert; + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/libgnat/a-suenco.ads b/gcc/ada/libgnat/a-suenco.ads new file mode 100644 index 0000000..0aa4f88 --- /dev/null +++ b/gcc/ada/libgnat/a-suenco.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.CONVERSIONS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It provides conversions +-- from one UTF encoding method to another. Note: this package is consistent +-- with Ada 95, and may be used in Ada 95 or Ada 2005 mode. + +package Ada.Strings.UTF_Encoding.Conversions is + pragma Pure (Conversions); + + -- In the following conversion routines, a BOM in the input that matches + -- the encoding scheme is ignored, an incorrect BOM causes Encoding_Error + -- to be raised. A BOM is present in the output if the Output_BOM parameter + -- is set to True. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in one of + -- these three schemes as specified by the Output_Scheme argument. + + function Convert + (Item : UTF_String; + Input_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from input encoded in UTF-8, UTF-16LE, or UTF-16BE as specified + -- by the Input_Scheme argument, and generate an output encoded in UTF-16. + + function Convert + (Item : UTF_8_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Convert from UTF-8 to UTF-16 + + function Convert + (Item : UTF_16_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Convert from UTF-16 to UTF-8, UTF-16LE, or UTF-16BE as specified by + -- the Output_Scheme argument. + + function Convert + (Item : UTF_16_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Convert from UTF-16 to UTF-8 + +end Ada.Strings.UTF_Encoding.Conversions; diff --git a/gcc/ada/libgnat/a-suenst.adb b/gcc/ada/libgnat/a-suenst.adb new file mode 100644 index 0000000..44639bd --- /dev/null +++ b/gcc/ada/libgnat/a-suenst.adb @@ -0,0 +1,350 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.STRINGS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Strings is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Decode UTF-8/UTF-16BE/UTF-16LE input to String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to String + + function Decode (Item : UTF_8_String) return String is + Result : String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input Item pointer + + C : Unsigned_8; + R : Unsigned_16; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left + -- by 6 bits, and or's in the xxxxxx to the low order 6 bits. On + -- return Ptr is incremented. Raises exception if continuation + -- byte does not exist or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_16 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + -- Such codes are out of range for type Character + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + -- Such codes are out of range for Wide_String output + + -- Thus all remaining cases raise Encoding_Error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + + -- The value may still be out of range of Standard.Character. We make + -- the check explicit because the library is typically compiled with + -- range checks disabled. + + if R > Character'Pos (Character'Last) then + Raise_Encoding_Error (Iptr - 1); + end if; + + Result (Len) := Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to String + + function Decode (Item : UTF_16_Wide_String) return String is + Result : String (1 .. Item'Length); + -- Result is same length as input (possibly minus 1 if BOM present) + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Index of next Item element + + C : Unsigned_16; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#00FF# represent their own value + + if C <= 16#00FF# then + Len := Len + 1; + Result (Len) := Character'Val (C); + + -- All other codes are invalid, either they are invalid UTF-16 + -- encoding sequences, or they represent values that are out of + -- range for type Character. + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Case of UTF_8 + + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + + -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary + + else + return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), + Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode String in UTF-8 + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is three bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_8; + -- Single input character + + procedure Store (C : Unsigned_8); + pragma Inline (Store); + -- Store one output code, C is in the range 0 .. 255 + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_8) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for UTF8_Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for J in Item'Range loop + C := To_Unsigned_8 (Item (J)); + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + -- For type character of course, the limit is 16#FF# in any case + + else + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode String in UTF-16 + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String + (1 .. Item'Length + Boolean'Pos (Output_BOM)); + -- Output is same length as input + possible BOM + + Len : Integer; + -- Length of output string + + C : Unsigned_8; + + begin + -- Output BOM if required + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_8 (Item (Iptr)); + + -- Codes in the range 16#0000#..16#00FF# are output unchanged. This + -- includes all possible cases of Character values. + + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + end loop; + + return Result; + end Encode; + +end Ada.Strings.UTF_Encoding.Strings; diff --git a/gcc/ada/libgnat/a-suenst.ads b/gcc/ada/libgnat/a-suenst.ads new file mode 100644 index 0000000..1706cd6 --- /dev/null +++ b/gcc/ada/libgnat/a-suenst.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.STRINGS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding String values using UTF encodings. Note: this package is +-- consistent with Ada 95, and may be included in Ada 95 implementations. + +package Ada.Strings.UTF_Encoding.Strings is + pragma Pure (Strings); + + -- The encoding routines take a String as input and encode the result + -- using the specified UTF encoding method. The result includes a BOM if + -- the Output_BOM argument is set to True. All 256 values of type Character + -- are valid, so Encoding_Error cannot be raised for string input data. + + function Encode + (Item : String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode String using UTF-8, UTF-16LE or UTF-16BE encoding as specified by + -- the Output_Scheme parameter. + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode String using UTF-8 encoding + + function Encode + (Item : String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error, + -- as does a code out of range of type Character. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a String value. + -- Note: a convenient form for scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return String; + -- The input is encoded in UTF-8 and returned as a String value + + function Decode + (Item : UTF_16_Wide_String) return String; + -- The input is encoded in UTF-16 and returned as a String value + +end Ada.Strings.UTF_Encoding.Strings; diff --git a/gcc/ada/libgnat/a-suewst.adb b/gcc/ada/libgnat/a-suewst.adb new file mode 100644 index 0000000..5ee896a --- /dev/null +++ b/gcc/ada/libgnat/a-suewst.adb @@ -0,0 +1,370 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_STRINGS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Strings is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Decode UTF-8/UTF-16BE/UTF-16LE input to Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_String + + function Decode (Item : UTF_8_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input Item pointer + + C : Unsigned_8; + R : Unsigned_16; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6 + -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr + -- is incremented. Raises exception if continuation byte does not exist + -- or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_16 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_16 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_16 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_16 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + -- Such codes are out of range for Wide_String output + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_String is + Result : Wide_String (1 .. Item'Length); + -- Result is same length as input (possibly minus 1 if BOM present) + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Index of next Item element + + C : Unsigned_16; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Item'Length > 0 and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- Such codes are out of range for 16-bit output. + + -- The case of input in the range 16#DC00#..16#DFFF# must never + -- occur, since it means we have a second surrogate character with + -- no corresponding first surrogate. + + -- Codes in the range 16#FFFE# .. 16#FFFF# are also invalid since + -- they conflict with codes used for BOM values. + + -- Thus all remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + -- Case of UTF_8 + + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + + -- Case of UTF_16LE or UTF_16BE, use UTF-16 intermediary + + else + return From_UTF_16 (UTF_16_Wide_String'(Encode (Item)), + Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_String in UTF-8 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : UTF_8_String (1 .. 3 * Item'Length + 3); + -- Worst case is three bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_16; + -- Single input character + + procedure Store (C : Unsigned_16); + pragma Inline (Store); + -- Store one output code, C is in the range 0 .. 255 + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_16) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for UTF8_Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for J in Item'Range loop + C := To_Unsigned_16 (Item (J)); + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + else + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_String in UTF-16 + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String + (1 .. Item'Length + Boolean'Pos (Output_BOM)); + -- Output is same length as input + possible BOM + + Len : Integer; + -- Length of output string + + C : Unsigned_16; + + begin + -- Output BOM if required + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_16 (Item (Iptr)); + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# are + -- output unchanged. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DFFF# should never appear in the + -- input, since no valid Unicode characters are in this range (which + -- would conflict with the UTF-16 surrogate encodings). Similarly + -- codes in the range 16#FFFE#..16#FFFF conflict with BOM codes. + -- Thus all remaining codes are illegal. + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result; + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Strings; diff --git a/gcc/ada/libgnat/a-suewst.ads b/gcc/ada/libgnat/a-suewst.ads new file mode 100644 index 0000000..e0f8d4c --- /dev/null +++ b/gcc/ada/libgnat/a-suewst.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_STRINGS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 95, and may be included in Ada 95 implementations. + +package Ada.Strings.UTF_Encoding.Wide_Strings is + pragma Pure (Wide_Strings); + + -- The encoding routines take a Wide_String as input and encode the result + -- using the specified UTF encoding method. The result includes a BOM if + -- the Output_BOM argument is set to True. Encoding_Error is raised if an + -- invalid character appears in the input. In particular the characters + -- in the range 16#D800# .. 16#DFFF# are invalid because they conflict + -- with UTF-16 surrogate encodings, and the characters 16#FFFE# and + -- 16#FFFF# are also invalid because they conflict with BOM codes. + + function Encode + (Item : Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_String + -- value. Note: a convenient form for scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Strings; diff --git a/gcc/ada/libgnat/a-suezst.adb b/gcc/ada/libgnat/a-suezst.adb new file mode 100644 index 0000000..4528bdd --- /dev/null +++ b/gcc/ada/libgnat/a-suezst.adb @@ -0,0 +1,429 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_STRINGS -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.UTF_Encoding.Wide_Wide_Strings is + use Interfaces; + + ------------ + -- Decode -- + ------------ + + -- Decode UTF-8/UTF-16BE/UTF-16LE input to Wide_Wide_String + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String + is + begin + if Input_Scheme = UTF_8 then + return Decode (Item); + else + return Decode (To_UTF_16 (Item, Input_Scheme)); + end if; + end Decode; + + -- Decode UTF-8 input to Wide_Wide_String + + function Decode (Item : UTF_8_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result string (worst case is same length as input) + + Len : Natural := 0; + -- Length of result stored so far + + Iptr : Natural; + -- Input string pointer + + C : Unsigned_8; + R : Unsigned_32; + + procedure Get_Continuation; + -- Reads a continuation byte of the form 10xxxxxx, shifts R left by 6 + -- bits, and or's in the xxxxxx to the low order 6 bits. On return Ptr + -- is incremented. Raises exception if continuation byte does not exist + -- or is invalid. + + ---------------------- + -- Get_Continuation -- + ---------------------- + + procedure Get_Continuation is + begin + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + else + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 2#10_000000# .. 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + else + R := Shift_Left (R, 6) or Unsigned_32 (C and 2#00_111111#); + end if; + end if; + end Get_Continuation; + + -- Start of processing for Decode + + begin + Iptr := Item'First; + + -- Skip BOM at start + + if Item'Length >= 3 + and then Item (Iptr .. Iptr + 2) = BOM_8 + then + Iptr := Iptr + 3; + + -- Error if bad BOM + + elsif Item'Length >= 2 + and then (Item (Iptr .. Iptr + 1) = BOM_16BE + or else + Item (Iptr .. Iptr + 1) = BOM_16LE) + then + Raise_Encoding_Error (Iptr); + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_8 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#00# - 16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + R := Unsigned_32 (C); + + -- No initial code can be of the form 10xxxxxx. Such codes are used + -- only for continuations. + + elsif C <= 2#10_111111# then + Raise_Encoding_Error (Iptr - 1); + + -- Codes in the range 16#80# - 16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 2#110_11111# then + R := Unsigned_32 (C and 2#000_11111#); + Get_Continuation; + + -- Codes in the range 16#800# - 16#FFFF# are represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#1110_1111# then + R := Unsigned_32 (C and 2#0000_1111#); + Get_Continuation; + Get_Continuation; + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C <= 2#11110_111# then + R := Unsigned_32 (C and 2#00000_111#); + Get_Continuation; + Get_Continuation; + Get_Continuation; + + -- Any other code is an error + + else + Raise_Encoding_Error (Iptr - 1); + end if; + + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end loop; + + return Result (1 .. Len); + end Decode; + + -- Decode UTF-16 input to Wide_Wide_String + + function Decode (Item : UTF_16_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. Item'Length); + -- Result cannot be longer than the input string + + Len : Natural := 0; + -- Length of result + + Iptr : Natural; + -- Pointer to next element in Item + + C : Unsigned_16; + R : Unsigned_32; + + begin + -- Skip UTF-16 BOM at start + + Iptr := Item'First; + + if Iptr <= Item'Last and then Item (Iptr) = BOM_16 (1) then + Iptr := Iptr + 1; + end if; + + -- Loop through input characters + + while Iptr <= Item'Last loop + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + -- Codes in the range 16#0000#..16#D7FF# or 16#E000#..16#FFFD# + -- represent their own value. + + if C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (C); + + -- Codes in the range 16#D800#..16#DBFF# represent the first of the + -- two surrogates used to encode the range 16#01_000#..16#10_FFFF". + -- The first surrogate provides 10 high order bits of the result. + + elsif C <= 16#DBFF# then + R := Shift_Left ((Unsigned_32 (C) - 16#D800#), 10); + + -- Error if at end of string + + if Iptr > Item'Last then + Raise_Encoding_Error (Iptr - 1); + + -- Otherwise next character must be valid low order surrogate + -- which provides the low 10 order bits of the result. + + else + C := To_Unsigned_16 (Item (Iptr)); + Iptr := Iptr + 1; + + if C not in 16#DC00# .. 16#DFFF# then + Raise_Encoding_Error (Iptr - 1); + + else + R := R or (Unsigned_32 (C) mod 2 ** 10); + + -- The final adjustment is to add 16#01_0000 to get the + -- result back in the required 21 bit range. + + R := R + 16#01_0000#; + Len := Len + 1; + Result (Len) := Wide_Wide_Character'Val (R); + end if; + end if; + + -- Remaining codes are invalid + + else + Raise_Encoding_Error (Iptr - 1); + end if; + end loop; + + return Result (1 .. Len); + end Decode; + + ------------ + -- Encode -- + ------------ + + -- Encode Wide_Wide_String in UTF-8, UTF-16BE or UTF-16LE + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String + is + begin + if Output_Scheme = UTF_8 then + return Encode (Item, Output_BOM); + else + return From_UTF_16 (Encode (Item), Output_Scheme, Output_BOM); + end if; + end Encode; + + -- Encode Wide_Wide_String in UTF-8 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String + is + Result : String (1 .. 4 * Item'Length + 3); + -- Worst case is four bytes per input byte + space for BOM + + Len : Natural; + -- Number of output codes stored in Result + + C : Unsigned_32; + -- Single input character + + procedure Store (C : Unsigned_32); + pragma Inline (Store); + -- Store one output code (input is in range 0 .. 255) + + ----------- + -- Store -- + ----------- + + procedure Store (C : Unsigned_32) is + begin + Len := Len + 1; + Result (Len) := Character'Val (C); + end Store; + + -- Start of processing for Encode + + begin + -- Output BOM if required + + if Output_BOM then + Result (1 .. 3) := BOM_8; + Len := 3; + else + Len := 0; + end if; + + -- Loop through characters of input + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00#..16#7F# are represented as + -- 0xxxxxxx + + if C <= 16#7F# then + Store (C); + + -- Codes in the range 16#80#..16#7FF# are represented as + -- 110yyyxx 10xxxxxx + + elsif C <= 16#7FF# then + Store (2#110_00000# or Shift_Right (C, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#800#..16#D7FF# or 16#E000#..16#FFFD# are + -- represented as + -- 1110yyyy 10yyyyxx 10xxxxxx + + elsif C <= 16#D7FF# or else C in 16#E000# .. 16#FFFD# then + Store (2#1110_0000# or Shift_Right (C, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or (C and 2#00_111111#)); + + -- Codes in the range 16#10000# - 16#10FFFF# are represented as + -- 11110zzz 10zzyyyy 10yyyyxx 10xxxxxx + + elsif C in 16#1_0000# .. 16#10_FFFF# then + Store (2#11110_000# or + Shift_Right (C, 18)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000_000000#, 12)); + Store (2#10_000000# or + Shift_Right (C and 2#111111_000000#, 6)); + Store (2#10_000000# or + (C and 2#00_111111#)); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + + -- Encode Wide_Wide_String in UTF-16 + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String + is + Result : UTF_16_Wide_String (1 .. 2 * Item'Length + 1); + -- Worst case is each input character generates two output characters + -- plus one for possible BOM. + + Len : Integer; + -- Length of output string + + C : Unsigned_32; + + begin + -- Output BOM if needed + + if Output_BOM then + Result (1) := BOM_16 (1); + Len := 1; + else + Len := 0; + end if; + + -- Loop through input characters encoding them + + for Iptr in Item'Range loop + C := To_Unsigned_32 (Item (Iptr)); + + -- Codes in the range 16#00_0000#..16#00_D7FF# or 16#E000#..16#FFFD# + -- are output unchanged + + if C <= 16#00_D7FF# or else C in 16#E000# .. 16#FFFD# then + Len := Len + 1; + Result (Len) := Wide_Character'Val (C); + + -- Codes in the range 16#01_0000#..16#10_FFFF# are output using two + -- surrogate characters. First 16#1_0000# is subtracted from the code + -- point to give a 20-bit value. This is then split into two separate + -- 10-bit values each of which is represented as a surrogate with the + -- most significant half placed in the first surrogate. The ranges of + -- values used for the two surrogates are 16#D800#-16#DBFF# for the + -- first, most significant surrogate and 16#DC00#-16#DFFF# for the + -- second, least significant surrogate. + + elsif C in 16#1_0000# .. 16#10_FFFF# then + C := C - 16#1_0000#; + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#D800# + C / 2 ** 10); + + Len := Len + 1; + Result (Len) := Wide_Character'Val (16#DC00# + C mod 2 ** 10); + + -- All other codes are invalid + + else + Raise_Encoding_Error (Iptr); + end if; + end loop; + + return Result (1 .. Len); + end Encode; + +end Ada.Strings.UTF_Encoding.Wide_Wide_Strings; diff --git a/gcc/ada/libgnat/a-suezst.ads b/gcc/ada/libgnat/a-suezst.ads new file mode 100644 index 0000000..86d344d --- /dev/null +++ b/gcc/ada/libgnat/a-suezst.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.UTF_ENCODING.WIDE_WIDE_STRINGS -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an Ada 2012 package defined in AI05-0137-1. It is used for encoding +-- and decoding Wide_String values using UTF encodings. Note: this package is +-- consistent with Ada 2005, and may be used in Ada 2005 mode, but cannot be +-- used in Ada 95 mode, since Wide_Wide_Character is an Ada 2005 feature. + +package Ada.Strings.UTF_Encoding.Wide_Wide_Strings is + pragma Pure (Wide_Wide_Strings); + + -- The encoding routines take a Wide_Wide_String as input and encode the + -- result using the specified UTF encoding method. The result includes a + -- BOM if the Output_BOM parameter is set to True. + + function Encode + (Item : Wide_Wide_String; + Output_Scheme : Encoding_Scheme; + Output_BOM : Boolean := False) return UTF_String; + -- Encode Wide_Wide_String using UTF-8, UTF-16LE or UTF-16BE encoding as + -- specified by the Output_Scheme parameter. + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_8_String; + -- Encode Wide_Wide_String using UTF-8 encoding + + function Encode + (Item : Wide_Wide_String; + Output_BOM : Boolean := False) return UTF_16_Wide_String; + -- Encode Wide_Wide_String using UTF_16 encoding + + -- The decoding routines take a UTF String as input, and return a decoded + -- Wide_String. If the UTF String starts with a BOM that matches the + -- encoding method, it is ignored. An incorrect BOM raises Encoding_Error. + + function Decode + (Item : UTF_String; + Input_Scheme : Encoding_Scheme) return Wide_Wide_String; + -- The input is encoded in UTF_8, UTF_16LE or UTF_16BE as specified by the + -- Input_Scheme parameter. It is decoded and returned as a Wide_Wide_String + -- value. Note: a convenient form for Scheme may be Encoding (UTF_String). + + function Decode + (Item : UTF_8_String) return Wide_Wide_String; + -- The input is encoded in UTF-8 and returned as a Wide_Wide_String value + + function Decode + (Item : UTF_16_Wide_String) return Wide_Wide_String; + -- The input is encoded in UTF-16 and returned as a Wide_String value + +end Ada.Strings.UTF_Encoding.Wide_Wide_Strings; diff --git a/gcc/ada/libgnat/a-suhcin.adb b/gcc/ada/libgnat/a-suhcin.adb new file mode 100644 index 0000000..fa94635 --- /dev/null +++ b/gcc/ada/libgnat/a-suhcin.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Hash_Case_Insensitive; + +function Ada.Strings.Unbounded.Hash_Case_Insensitive + (Key : Unbounded.Unbounded_String) + return Containers.Hash_Type +is + S : Aux.Big_String_Access; + L : Natural; + +begin + Aux.Get_String (Key, S, L); + return Ada.Strings.Hash_Case_Insensitive (S (1 .. L)); +end Ada.Strings.Unbounded.Hash_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-suhcin.ads b/gcc/ada/libgnat/a-suhcin.ads new file mode 100644 index 0000000..3a05d8e --- /dev/null +++ b/gcc/ada/libgnat/a-suhcin.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.HASH_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Unbounded.Hash_Case_Insensitive + (Key : Unbounded.Unbounded_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Unbounded.Hash_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-sulcin.adb b/gcc/ada/libgnat/a-sulcin.adb new file mode 100644 index 0000000..93c785e --- /dev/null +++ b/gcc/ada/libgnat/a-sulcin.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded.Aux; +with Ada.Strings.Less_Case_Insensitive; + +function Ada.Strings.Unbounded.Less_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean +is + SL, SR : Aux.Big_String_Access; + LL, LR : Natural; + +begin + Aux.Get_String (Left, SL, LL); + Aux.Get_String (Right, SR, LR); + + return Ada.Strings.Less_Case_Insensitive + (Left => SL (1 .. LL), + Right => SR (1 .. LR)); +end Ada.Strings.Unbounded.Less_Case_Insensitive; diff --git a/gcc/ada/libgnat/a-sulcin.ads b/gcc/ada/libgnat/a-sulcin.ads new file mode 100644 index 0000000..0706c07 --- /dev/null +++ b/gcc/ada/libgnat/a-sulcin.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.UNBOUNDED.LESS_CASE_INSENSITIVE -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +function Ada.Strings.Unbounded.Less_Case_Insensitive + (Left, Right : Unbounded.Unbounded_String) + return Boolean; + +pragma Preelaborate (Ada.Strings.Unbounded.Less_Case_Insensitive); diff --git a/gcc/ada/libgnat/a-suteio-shared.adb b/gcc/ada/libgnat/a-suteio-shared.adb new file mode 100644 index 0000000..13d537d --- /dev/null +++ b/gcc/ada/libgnat/a-suteio-shared.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; + +package body Ada.Strings.Unbounded.Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Result : Unbounded_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Text_IO.File_Type; + Item : out Unbounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_String) is + UR : constant Shared_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/libgnat/a-suteio.adb b/gcc/ada/libgnat/a-suteio.adb new file mode 100644 index 0000000..7c48bc5 --- /dev/null +++ b/gcc/ada/libgnat/a-suteio.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; + +package body Ada.Strings.Unbounded.Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Str1 : String_Access; + Str2 : String_Access; + Result : Unbounded_String; + + begin + Get_Line (Buffer, Last); + Str1 := new String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new String (1 .. Str1'Last + Last); + Str2 (Str1'Range) := Str1.all; + Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); + Free (Str1); + Str1 := Str2; + end loop; + + Result.Reference := Str1; + Result.Last := Str1'Length; + return Result; + end Get_Line; + + function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String is + Buffer : String (1 .. 1000); + Last : Natural; + Str1 : String_Access; + Str2 : String_Access; + Result : Unbounded_String; + + begin + Get_Line (File, Buffer, Last); + Str1 := new String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new String (1 .. Str1'Last + Last); + Str2 (Str1'Range) := Str1.all; + Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); + Free (Str1); + Str1 := Str2; + end loop; + + Result.Reference := Str1; + Result.Last := Str1'Length; + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Text_IO.File_Type; + Item : out Unbounded_String) + is + begin + -- We are going to read into the string that is already there and + -- allocated. Hopefully it is big enough now, if not, we will extend + -- it in the usual manner using Realloc_For_Chunk. + + -- Make sure we start with at least 80 characters + + if Item.Reference'Last < 80 then + Realloc_For_Chunk (Item, 80); + end if; + + -- Loop to read data, filling current string as far as possible. + -- Item.Last holds the number of characters read so far. + + Item.Last := 0; + loop + Get_Line + (File, + Item.Reference (Item.Last + 1 .. Item.Reference'Last), + Item.Last); + + -- If we hit the end of the line before the end of the buffer, then + -- we are all done, and the result length is properly set. + + if Item.Last < Item.Reference'Last then + return; + end if; + + -- If not enough room, double it and keep reading + + Realloc_For_Chunk (Item, Item.Last); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_String) is + begin + Put (U.Reference (1 .. U.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_String) is + begin + Put (File, U.Reference (1 .. U.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_String) is + begin + Put_Line (U.Reference (1 .. U.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_String) is + begin + Put_Line (File, U.Reference (1 .. U.Last)); + end Put_Line; + +end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/libgnat/a-suteio.ads b/gcc/ada/libgnat/a-suteio.ads new file mode 100644 index 0000000..7e92538 --- /dev/null +++ b/gcc/ada/libgnat/a-suteio.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . U N B O U N D E D . T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Unbounded provides some specialized +-- Text_IO routines that work directly with unbounded strings, avoiding the +-- inefficiencies of access via the standard interface, and also taking +-- direct advantage of the variable length semantics of these strings. + +with Ada.Text_IO; + +package Ada.Strings.Unbounded.Text_IO is + + function Get_Line return Unbounded_String; + function Get_Line (File : Ada.Text_IO.File_Type) return Unbounded_String; + -- Reads up to the end of the current line, returning the result + -- as an unbounded string of appropriate length. If no File parameter + -- is present, input is from Current_Input. + + procedure Get_Line + (File : Ada.Text_IO.File_Type; + Item : out Unbounded_String); + procedure Get_Line (Item : out Unbounded_String); + -- Similar to the above, but in procedure form with an out parameter + + procedure Put (U : Unbounded_String); + procedure Put (File : Ada.Text_IO.File_Type; U : Unbounded_String); + procedure Put_Line (U : Unbounded_String); + procedure Put_Line (File : Ada.Text_IO.File_Type; U : Unbounded_String); + -- These are equivalent to the standard Text_IO routines passed the + -- value To_String (U), but operate more efficiently, because the extra + -- copy of the argument is avoided. + +end Ada.Strings.Unbounded.Text_IO; diff --git a/gcc/ada/libgnat/a-swbwha.adb b/gcc/ada/libgnat/a-swbwha.adb new file mode 100644 index 0000000..1addc2e --- /dev/null +++ b/gcc/ada/libgnat/a-swbwha.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ B O U N D E D . W I D E _ H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Bounded.Wide_Hash + (Key : Bounded.Bounded_Wide_String) + return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Character, Wide_String, Hash_Type); +begin + return Hash (Bounded.To_Wide_String (Key)); +end Ada.Strings.Wide_Bounded.Wide_Hash; diff --git a/gcc/ada/libgnat/a-swbwha.ads b/gcc/ada/libgnat/a-swbwha.ads new file mode 100644 index 0000000..6a4fba7 --- /dev/null +++ b/gcc/ada/libgnat/a-swbwha.ads @@ -0,0 +1,25 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ B O U N D E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +generic + with package Bounded is + new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Wide_Bounded.Wide_Hash (Key : Bounded.Bounded_Wide_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Bounded.Wide_Hash); diff --git a/gcc/ada/libgnat/a-swfwha.ads b/gcc/ada/libgnat/a-swfwha.ads new file mode 100644 index 0000000..c42d54c --- /dev/null +++ b/gcc/ada/libgnat/a-swfwha.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ F I X E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers, Ada.Strings.Wide_Hash; + +function Ada.Strings.Wide_Fixed.Wide_Hash + (Key : Wide_String) return Containers.Hash_Type + renames Ada.Strings.Wide_Hash; + +pragma Pure (Ada.Strings.Wide_Fixed.Wide_Hash); diff --git a/gcc/ada/libgnat/a-swmwco.ads b/gcc/ada/libgnat/a-swmwco.ads new file mode 100644 index 0000000..e29f1d1 --- /dev/null +++ b/gcc/ada/libgnat/a-swmwco.ads @@ -0,0 +1,450 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ M A P S . W I D E _ C O N S T A N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Wide_Latin_1; + +package Ada.Strings.Wide_Maps.Wide_Constants is + pragma Preelaborate; + + Control_Set : constant Wide_Maps.Wide_Character_Set; + Graphic_Set : constant Wide_Maps.Wide_Character_Set; + Letter_Set : constant Wide_Maps.Wide_Character_Set; + Lower_Set : constant Wide_Maps.Wide_Character_Set; + Upper_Set : constant Wide_Maps.Wide_Character_Set; + Basic_Set : constant Wide_Maps.Wide_Character_Set; + Decimal_Digit_Set : constant Wide_Maps.Wide_Character_Set; + Hexadecimal_Digit_Set : constant Wide_Maps.Wide_Character_Set; + Alphanumeric_Set : constant Wide_Maps.Wide_Character_Set; + Special_Graphic_Set : constant Wide_Maps.Wide_Character_Set; + ISO_646_Set : constant Wide_Maps.Wide_Character_Set; + Character_Set : constant Wide_Maps.Wide_Character_Set; + + Lower_Case_Map : constant Wide_Maps.Wide_Character_Mapping; + -- Maps to lower case for letters, else identity + + Upper_Case_Map : constant Wide_Maps.Wide_Character_Mapping; + -- Maps to upper case for letters, else identity + + Basic_Map : constant Wide_Maps.Wide_Character_Mapping; + -- Maps to basic letter for letters, else identity + +private + package W renames Ada.Characters.Wide_Latin_1; + + subtype WC is Wide_Character; + + Control_Ranges : aliased constant Wide_Character_Ranges := + ((W.NUL, W.US), + (W.DEL, W.APC)); + + Control_Set : constant Wide_Character_Set := + (AF.Controlled with + Control_Ranges'Unrestricted_Access); + + Graphic_Ranges : aliased constant Wide_Character_Ranges := + ((W.Space, W.Tilde), + (WC'Val (256), WC'Last)); + + Graphic_Set : constant Wide_Character_Set := + (AF.Controlled with + Graphic_Ranges'Unrestricted_Access); + + Letter_Ranges : aliased constant Wide_Character_Ranges := + (('A', 'Z'), + (W.LC_A, W.LC_Z), + (W.UC_A_Grave, W.UC_O_Diaeresis), + (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Letter_Set : constant Wide_Character_Set := + (AF.Controlled with + Letter_Ranges'Unrestricted_Access); + + Lower_Ranges : aliased constant Wide_Character_Ranges := + (1 => (W.LC_A, W.LC_Z), + 2 => (W.LC_German_Sharp_S, W.LC_O_Diaeresis), + 3 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Lower_Set : constant Wide_Character_Set := + (AF.Controlled with + Lower_Ranges'Unrestricted_Access); + + Upper_Ranges : aliased constant Wide_Character_Ranges := + (1 => ('A', 'Z'), + 2 => (W.UC_A_Grave, W.UC_O_Diaeresis), + 3 => (W.UC_O_Oblique_Stroke, W.UC_Icelandic_Thorn)); + + Upper_Set : constant Wide_Character_Set := + (AF.Controlled with + Upper_Ranges'Unrestricted_Access); + + Basic_Ranges : aliased constant Wide_Character_Ranges := + (1 => ('A', 'Z'), + 2 => (W.LC_A, W.LC_Z), + 3 => (W.UC_AE_Diphthong, W.UC_AE_Diphthong), + 4 => (W.LC_AE_Diphthong, W.LC_AE_Diphthong), + 5 => (W.LC_German_Sharp_S, W.LC_German_Sharp_S), + 6 => (W.UC_Icelandic_Thorn, W.UC_Icelandic_Thorn), + 7 => (W.LC_Icelandic_Thorn, W.LC_Icelandic_Thorn), + 8 => (W.UC_Icelandic_Eth, W.UC_Icelandic_Eth), + 9 => (W.LC_Icelandic_Eth, W.LC_Icelandic_Eth)); + + Basic_Set : constant Wide_Character_Set := + (AF.Controlled with + Basic_Ranges'Unrestricted_Access); + + Decimal_Digit_Ranges : aliased constant Wide_Character_Ranges := + (1 => ('0', '9')); + + Decimal_Digit_Set : constant Wide_Character_Set := + (AF.Controlled with + Decimal_Digit_Ranges'Unrestricted_Access); + + Hexadecimal_Digit_Ranges : aliased constant Wide_Character_Ranges := + (1 => ('0', '9'), + 2 => ('A', 'F'), + 3 => (W.LC_A, W.LC_F)); + + Hexadecimal_Digit_Set : constant Wide_Character_Set := + (AF.Controlled with + Hexadecimal_Digit_Ranges'Unrestricted_Access); + + Alphanumeric_Ranges : aliased constant Wide_Character_Ranges := + (1 => ('0', '9'), + 2 => ('A', 'Z'), + 3 => (W.LC_A, W.LC_Z), + 4 => (W.UC_A_Grave, W.UC_O_Diaeresis), + 5 => (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + 6 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Alphanumeric_Set : constant Wide_Character_Set := + (AF.Controlled with + Alphanumeric_Ranges'Unrestricted_Access); + + Special_Graphic_Ranges : aliased constant Wide_Character_Ranges := + (1 => (Wide_Space, W.Solidus), + 2 => (W.Colon, W.Commercial_At), + 3 => (W.Left_Square_Bracket, W.Grave), + 4 => (W.Left_Curly_Bracket, W.Tilde), + 5 => (W.No_Break_Space, W.Inverted_Question), + 6 => (W.Multiplication_Sign, W.Multiplication_Sign), + 7 => (W.Division_Sign, W.Division_Sign)); + + Special_Graphic_Set : constant Wide_Character_Set := + (AF.Controlled with + Special_Graphic_Ranges'Unrestricted_Access); + + ISO_646_Ranges : aliased constant Wide_Character_Ranges := + (1 => (W.NUL, W.DEL)); + + ISO_646_Set : constant Wide_Character_Set := + (AF.Controlled with + ISO_646_Ranges'Unrestricted_Access); + + Character_Ranges : aliased constant Wide_Character_Ranges := + (1 => (W.NUL, WC'Val (255))); + + Character_Set : constant Wide_Character_Set := + (AF.Controlled with + Character_Ranges'Unrestricted_Access); + + Lower_Case_Mapping : aliased constant Wide_Character_Mapping_Values := + (Length => 56, + + Domain => + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_AE_Diphthong & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_Icelandic_Eth & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.UC_Icelandic_Thorn, + + Rangev => + "abcdefghijklmnopqrstuvwxyz" & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_AE_Diphthong & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_Icelandic_Eth & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Icelandic_Thorn); + + Lower_Case_Map : constant Wide_Character_Mapping := + (AF.Controlled with + Map => Lower_Case_Mapping'Unrestricted_Access); + + Upper_Case_Mapping : aliased constant Wide_Character_Mapping_Values := + (Length => 56, + + Domain => + "abcdefghijklmnopqrstuvwxyz" & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_AE_Diphthong & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_Icelandic_Eth & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Icelandic_Thorn, + + Rangev => + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_AE_Diphthong & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_Icelandic_Eth & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.UC_Icelandic_Thorn); + + Upper_Case_Map : constant Wide_Character_Mapping := + (AF.Controlled with + Upper_Case_Mapping'Unrestricted_Access); + + Basic_Mapping : aliased constant Wide_Character_Mapping_Values := + (Length => 55, + + Domain => + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Y_Diaeresis, + + Rangev => + 'A' & -- UC_A_Grave + 'A' & -- UC_A_Acute + 'A' & -- UC_A_Circumflex + 'A' & -- UC_A_Tilde + 'A' & -- UC_A_Diaeresis + 'A' & -- UC_A_Ring + 'C' & -- UC_C_Cedilla + 'E' & -- UC_E_Grave + 'E' & -- UC_E_Acute + 'E' & -- UC_E_Circumflex + 'E' & -- UC_E_Diaeresis + 'I' & -- UC_I_Grave + 'I' & -- UC_I_Acute + 'I' & -- UC_I_Circumflex + 'I' & -- UC_I_Diaeresis + 'N' & -- UC_N_Tilde + 'O' & -- UC_O_Grave + 'O' & -- UC_O_Acute + 'O' & -- UC_O_Circumflex + 'O' & -- UC_O_Tilde + 'O' & -- UC_O_Diaeresis + 'O' & -- UC_O_Oblique_Stroke + 'U' & -- UC_U_Grave + 'U' & -- UC_U_Acute + 'U' & -- UC_U_Circumflex + 'U' & -- UC_U_Diaeresis + 'Y' & -- UC_Y_Acute + 'a' & -- LC_A_Grave + 'a' & -- LC_A_Acute + 'a' & -- LC_A_Circumflex + 'a' & -- LC_A_Tilde + 'a' & -- LC_A_Diaeresis + 'a' & -- LC_A_Ring + 'c' & -- LC_C_Cedilla + 'e' & -- LC_E_Grave + 'e' & -- LC_E_Acute + 'e' & -- LC_E_Circumflex + 'e' & -- LC_E_Diaeresis + 'i' & -- LC_I_Grave + 'i' & -- LC_I_Acute + 'i' & -- LC_I_Circumflex + 'i' & -- LC_I_Diaeresis + 'n' & -- LC_N_Tilde + 'o' & -- LC_O_Grave + 'o' & -- LC_O_Acute + 'o' & -- LC_O_Circumflex + 'o' & -- LC_O_Tilde + 'o' & -- LC_O_Diaeresis + 'o' & -- LC_O_Oblique_Stroke + 'u' & -- LC_U_Grave + 'u' & -- LC_U_Acute + 'u' & -- LC_U_Circumflex + 'u' & -- LC_U_Diaeresis + 'y' & -- LC_Y_Acute + 'y'); -- LC_Y_Diaeresis + + Basic_Map : constant Wide_Character_Mapping := + (AF.Controlled with + Basic_Mapping'Unrestricted_Access); + +end Ada.Strings.Wide_Maps.Wide_Constants; diff --git a/gcc/ada/libgnat/a-swunau-shared.adb b/gcc/ada/libgnat/a-swunau-shared.adb new file mode 100644 index 0000000..c65f7d0 --- /dev/null +++ b/gcc/ada/libgnat/a-swunau-shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Unbounded.Aux is + + --------------------- + -- Get_Wide_String -- + --------------------- + + procedure Get_Wide_String + (U : Unbounded_Wide_String; + S : out Big_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_String; + + --------------------- + -- Set_Wide_String -- + --------------------- + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access) + is + X : Wide_String_Access := S; + + begin + Set_Unbounded_Wide_String (UP, S.all); + Free (X); + end Set_Wide_String; + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-swunau.adb b/gcc/ada/libgnat/a-swunau.adb new file mode 100644 index 0000000..88c2a24 --- /dev/null +++ b/gcc/ada/libgnat/a-swunau.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Unbounded.Aux is + + -------------------- + -- Get_Wide_String -- + --------------------- + + procedure Get_Wide_String + (U : Unbounded_Wide_String; + S : out Big_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_String; + for X'Address use U.Reference.all'Address; + + begin + S := X'Unchecked_Access; + L := U.Last; + end Get_Wide_String; + + --------------------- + -- Set_Wide_String -- + --------------------- + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access) + is + begin + Finalize (UP); + UP.Reference := S; + UP.Last := UP.Reference'Length; + end Set_Wide_String; + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-swunau.ads b/gcc/ada/libgnat/a-swunau.ads new file mode 100644 index 0000000..b4e8ddb --- /dev/null +++ b/gcc/ada/libgnat/a-swunau.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Unbounded provides some specialized +-- access functions which are intended to allow more efficient use of the +-- facilities of Ada.Strings.Wide_Unbounded, particularly by other layered +-- utilities. + +package Ada.Strings.Wide_Unbounded.Aux is + pragma Preelaborate; + + subtype Big_Wide_String is Wide_String (Positive'Range); + type Big_Wide_String_Access is access all Big_Wide_String; + + procedure Get_Wide_String + (U : Unbounded_Wide_String; + S : out Big_Wide_String_Access; + L : out Natural); + pragma Inline (Get_Wide_String); + -- This procedure returns the internal string pointer used in the + -- representation of an unbounded string as well as the actual current + -- length (which may be less than S.all'Length because in general there + -- can be extra space assigned). The characters of this string may be + -- not be modified via the returned pointer, and are valid only as + -- long as the original unbounded string is not accessed or modified. + -- + -- This procedure is much more efficient than the use of To_Wide_String + -- since it avoids the need to copy the string. The lower bound of the + -- referenced string returned by this call is always one, so the actual + -- string data is always accessible as S (1 .. L). + + procedure Set_Wide_String (UP : out Unbounded_Wide_String; S : Wide_String) + renames Set_Unbounded_Wide_String; + -- This function sets the string contents of the referenced unbounded + -- string to the given string value. It is significantly more efficient + -- than the use of To_Unbounded_Wide_String with an assignment, since it + -- avoids the necessity of messing with finalization chains. The lower + -- bound of the string S is not required to be one. + + procedure Set_Wide_String + (UP : in out Unbounded_Wide_String; + S : Wide_String_Access); + pragma Inline (Set_Wide_String); + -- This version of Set_Wide_String takes a string access value, rather + -- than string. The lower bound of the string value is required to be one, + -- and this requirement is not checked. + +end Ada.Strings.Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-swuwha.adb b/gcc/ada/libgnat/a-swuwha.adb new file mode 100644 index 0000000..8333ccd --- /dev/null +++ b/gcc/ada/libgnat/a-swuwha.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Unbounded.Wide_Hash + (Key : Unbounded_Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Character, Wide_String, Hash_Type); +begin + return Hash (To_Wide_String (Key)); +end Ada.Strings.Wide_Unbounded.Wide_Hash; diff --git a/gcc/ada/libgnat/a-swuwha.ads b/gcc/ada/libgnat/a-swuwha.ads new file mode 100644 index 0000000..8da567a --- /dev/null +++ b/gcc/ada/libgnat/a-swuwha.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Is this really an RM unit? Doc needed ??? + +with Ada.Containers; + +function Ada.Strings.Wide_Unbounded.Wide_Hash + (Key : Unbounded_Wide_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Unbounded.Wide_Hash); diff --git a/gcc/ada/libgnat/a-swuwti-shared.adb b/gcc/ada/libgnat/a-swuwti-shared.adb new file mode 100644 index 0000000..1b1c127 --- /dev/null +++ b/gcc/ada/libgnat/a-swuwti-shared.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; + +package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_String is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is + UR : constant Shared_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-swuwti.adb b/gcc/ada/libgnat/a-swuwti.adb new file mode 100644 index 0000000..b849c68 --- /dev/null +++ b/gcc/ada/libgnat/a-swuwti.adb @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; + +package body Ada.Strings.Wide_Unbounded.Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_String is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_String_Access; + Str2 : Wide_String_Access; + Result : Unbounded_Wide_String; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_String (1 .. Str1'Last + Last); + Str2 (Str1'Range) := Str1.all; + Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); + Free (Str1); + Str1 := Str2; + end loop; + + Result.Reference := Str1; + Result.Last := Str1'Length; + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_String_Access; + Str2 : Wide_String_Access; + Result : Unbounded_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new Wide_String (1 .. Str1'Last + Last); + Str2 (Str1'Range) := Str1.all; + Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); + Free (Str1); + Str1 := Str2; + end loop; + + Result.Reference := Str1; + Result.Last := Str1'Length; + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_String) + is + begin + -- We are going to read into the string that is already there and + -- allocated. Hopefully it is big enough now, if not, we will extend + -- it in the usual manner using Realloc_For_Chunk. + + -- Make sure we start with at least 80 characters + + if Item.Reference'Last < 80 then + Realloc_For_Chunk (Item, 80); + end if; + + -- Loop to read data, filling current string as far as possible. + -- Item.Last holds the number of characters read so far. + + Item.Last := 0; + loop + Get_Line + (File, + Item.Reference (Item.Last + 1 .. Item.Reference'Last), + Item.Last); + + -- If we hit the end of the line before the end of the buffer, then + -- we are all done, and the result length is properly set. + + if Item.Last < Item.Reference'Last then + return; + end if; + + -- If not enough room, double it and keep reading + + Realloc_For_Chunk (Item, Item.Last); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_String) is + begin + Put (U.Reference (1 .. U.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_String) is + begin + Put (File, U.Reference (1 .. U.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_String) is + begin + Put_Line (U.Reference (1 .. U.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_String) is + begin + Put_Line (File, U.Reference (1 .. U.Last)); + end Put_Line; + +end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-swuwti.ads b/gcc/ada/libgnat/a-swuwti.ads new file mode 100644 index 0000000..6c6249c --- /dev/null +++ b/gcc/ada/libgnat/a-swuwti.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Unbounded provides specialized +-- Wide_Text_IO routines that work directly with unbounded wide strings, +-- avoiding the inefficiencies of access via the standard interface, and also +-- taking direct advantage of the variable length semantics of these strings. + +with Ada.Wide_Text_IO; + +package Ada.Strings.Wide_Unbounded.Wide_Text_IO is + + function Get_Line + return Unbounded_Wide_String; + function Get_Line + (File : Ada.Wide_Text_IO.File_Type) return Unbounded_Wide_String; + -- Reads up to the end of the current line, returning the result + -- as an unbounded string of appropriate length. If no File parameter + -- is present, input is from Current_Input. + + procedure Get_Line + (File : Ada.Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_String); + procedure Get_Line (Item : out Unbounded_Wide_String); + -- Similar to the above, but in procedure form with an out parameter + + procedure Put + (U : Unbounded_Wide_String); + procedure Put + (File : Ada.Wide_Text_IO.File_Type; + U : Unbounded_Wide_String); + procedure Put_Line + (U : Unbounded_Wide_String); + procedure Put_Line + (File : Ada.Wide_Text_IO.File_Type; + U : Unbounded_Wide_String); + -- These are equivalent to the standard Wide_Text_IO routines passed the + -- value To_Wide_String (U), but operate more efficiently, because the + -- extra copy of the argument is avoided. + +end Ada.Strings.Wide_Unbounded.Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-szbzha.adb b/gcc/ada/libgnat/a-szbzha.adb new file mode 100644 index 0000000..d0ade21 --- /dev/null +++ b/gcc/ada/libgnat/a-szbzha.adb @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_BOUNDED.WIDE_WIDE_HASH -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash + (Key : Bounded.Bounded_Wide_Wide_String) + return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Wide_Character, Wide_Wide_String, Hash_Type); +begin + return Hash (Bounded.To_Wide_Wide_String (Key)); +end Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash; diff --git a/gcc/ada/libgnat/a-szbzha.ads b/gcc/ada/libgnat/a-szbzha.ads new file mode 100644 index 0000000..d7911de --- /dev/null +++ b/gcc/ada/libgnat/a-szbzha.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_BOUNDED.WIDE_WIDE_HASH -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Is this really an RM unit? doc needed ??? + +with Ada.Containers; + +generic + with package Bounded is + new Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length (<>); + +function Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash + (Key : Bounded.Bounded_Wide_Wide_String) + return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Wide_Bounded.Wide_Wide_Hash); diff --git a/gcc/ada/libgnat/a-szfzha.ads b/gcc/ada/libgnat/a-szfzha.ads new file mode 100644 index 0000000..5deb5d7 --- /dev/null +++ b/gcc/ada/libgnat/a-szfzha.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ F I X E D . -- +-- W I D E _ W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; +with Ada.Strings.Wide_Wide_Hash; + +function Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash + (Key : Wide_Wide_String) return Containers.Hash_Type + renames Ada.Strings.Wide_Wide_Hash; + +pragma Pure (Ada.Strings.Wide_Wide_Fixed.Wide_Wide_Hash); diff --git a/gcc/ada/libgnat/a-szmzco.ads b/gcc/ada/libgnat/a-szmzco.ads new file mode 100644 index 0000000..b8208e0 --- /dev/null +++ b/gcc/ada/libgnat/a-szmzco.ads @@ -0,0 +1,450 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_MAPS.WIDE_WIDE_CONSTANTS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Wide_Wide_Latin_1; + +package Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants is + pragma Preelaborate; + + Control_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Letter_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Lower_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Upper_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Basic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Decimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Hexadecimal_Digit_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Alphanumeric_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Special_Graphic_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + ISO_646_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + Character_Set : constant Wide_Wide_Maps.Wide_Wide_Character_Set; + + Lower_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; + -- Maps to lower case for letters, else identity + + Upper_Case_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; + -- Maps to upper case for letters, else identity + + Basic_Map : constant Wide_Wide_Maps.Wide_Wide_Character_Mapping; + -- Maps to basic letter for letters, else identity + +private + package W renames Ada.Characters.Wide_Wide_Latin_1; + + subtype WC is Wide_Wide_Character; + + Control_Ranges : aliased constant Wide_Wide_Character_Ranges := + ((W.NUL, W.US), + (W.DEL, W.APC)); + + Control_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Control_Ranges'Unrestricted_Access); + + Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges := + ((W.Space, W.Tilde), + (WC'Val (256), WC'Last)); + + Graphic_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Graphic_Ranges'Unrestricted_Access); + + Letter_Ranges : aliased constant Wide_Wide_Character_Ranges := + (('A', 'Z'), + (W.LC_A, W.LC_Z), + (W.UC_A_Grave, W.UC_O_Diaeresis), + (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Letter_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Letter_Ranges'Unrestricted_Access); + + Lower_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (W.LC_A, W.LC_Z), + 2 => (W.LC_German_Sharp_S, W.LC_O_Diaeresis), + 3 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Lower_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Lower_Ranges'Unrestricted_Access); + + Upper_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('A', 'Z'), + 2 => (W.UC_A_Grave, W.UC_O_Diaeresis), + 3 => (W.UC_O_Oblique_Stroke, W.UC_Icelandic_Thorn)); + + Upper_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Upper_Ranges'Unrestricted_Access); + + Basic_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('A', 'Z'), + 2 => (W.LC_A, W.LC_Z), + 3 => (W.UC_AE_Diphthong, W.UC_AE_Diphthong), + 4 => (W.LC_AE_Diphthong, W.LC_AE_Diphthong), + 5 => (W.LC_German_Sharp_S, W.LC_German_Sharp_S), + 6 => (W.UC_Icelandic_Thorn, W.UC_Icelandic_Thorn), + 7 => (W.LC_Icelandic_Thorn, W.LC_Icelandic_Thorn), + 8 => (W.UC_Icelandic_Eth, W.UC_Icelandic_Eth), + 9 => (W.LC_Icelandic_Eth, W.LC_Icelandic_Eth)); + + Basic_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Basic_Ranges'Unrestricted_Access); + + Decimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('0', '9')); + + Decimal_Digit_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Decimal_Digit_Ranges'Unrestricted_Access); + + Hexadecimal_Digit_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('0', '9'), + 2 => ('A', 'F'), + 3 => (W.LC_A, W.LC_F)); + + Hexadecimal_Digit_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Hexadecimal_Digit_Ranges'Unrestricted_Access); + + Alphanumeric_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => ('0', '9'), + 2 => ('A', 'Z'), + 3 => (W.LC_A, W.LC_Z), + 4 => (W.UC_A_Grave, W.UC_O_Diaeresis), + 5 => (W.UC_O_Oblique_Stroke, W.LC_O_Diaeresis), + 6 => (W.LC_O_Oblique_Stroke, W.LC_Y_Diaeresis)); + + Alphanumeric_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Alphanumeric_Ranges'Unrestricted_Access); + + Special_Graphic_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (Wide_Wide_Space, W.Solidus), + 2 => (W.Colon, W.Commercial_At), + 3 => (W.Left_Square_Bracket, W.Grave), + 4 => (W.Left_Curly_Bracket, W.Tilde), + 5 => (W.No_Break_Space, W.Inverted_Question), + 6 => (W.Multiplication_Sign, W.Multiplication_Sign), + 7 => (W.Division_Sign, W.Division_Sign)); + + Special_Graphic_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Special_Graphic_Ranges'Unrestricted_Access); + + ISO_646_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (W.NUL, W.DEL)); + + ISO_646_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + ISO_646_Ranges'Unrestricted_Access); + + Character_Ranges : aliased constant Wide_Wide_Character_Ranges := + (1 => (W.NUL, WC'Val (255))); + + Character_Set : constant Wide_Wide_Character_Set := + (AF.Controlled with + Character_Ranges'Unrestricted_Access); + + Lower_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 56, + + Domain => + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_AE_Diphthong & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_Icelandic_Eth & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.UC_Icelandic_Thorn, + + Rangev => + "abcdefghijklmnopqrstuvwxyz" & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_AE_Diphthong & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_Icelandic_Eth & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Icelandic_Thorn); + + Lower_Case_Map : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Map => Lower_Case_Mapping'Unrestricted_Access); + + Upper_Case_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 56, + + Domain => + "abcdefghijklmnopqrstuvwxyz" & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_AE_Diphthong & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_Icelandic_Eth & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Icelandic_Thorn, + + Rangev => + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" & + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_AE_Diphthong & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_Icelandic_Eth & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.UC_Icelandic_Thorn); + + Upper_Case_Map : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Upper_Case_Mapping'Unrestricted_Access); + + Basic_Mapping : aliased constant Wide_Wide_Character_Mapping_Values := + (Length => 55, + + Domain => + W.UC_A_Grave & + W.UC_A_Acute & + W.UC_A_Circumflex & + W.UC_A_Tilde & + W.UC_A_Diaeresis & + W.UC_A_Ring & + W.UC_C_Cedilla & + W.UC_E_Grave & + W.UC_E_Acute & + W.UC_E_Circumflex & + W.UC_E_Diaeresis & + W.UC_I_Grave & + W.UC_I_Acute & + W.UC_I_Circumflex & + W.UC_I_Diaeresis & + W.UC_N_Tilde & + W.UC_O_Grave & + W.UC_O_Acute & + W.UC_O_Circumflex & + W.UC_O_Tilde & + W.UC_O_Diaeresis & + W.UC_O_Oblique_Stroke & + W.UC_U_Grave & + W.UC_U_Acute & + W.UC_U_Circumflex & + W.UC_U_Diaeresis & + W.UC_Y_Acute & + W.LC_A_Grave & + W.LC_A_Acute & + W.LC_A_Circumflex & + W.LC_A_Tilde & + W.LC_A_Diaeresis & + W.LC_A_Ring & + W.LC_C_Cedilla & + W.LC_E_Grave & + W.LC_E_Acute & + W.LC_E_Circumflex & + W.LC_E_Diaeresis & + W.LC_I_Grave & + W.LC_I_Acute & + W.LC_I_Circumflex & + W.LC_I_Diaeresis & + W.LC_N_Tilde & + W.LC_O_Grave & + W.LC_O_Acute & + W.LC_O_Circumflex & + W.LC_O_Tilde & + W.LC_O_Diaeresis & + W.LC_O_Oblique_Stroke & + W.LC_U_Grave & + W.LC_U_Acute & + W.LC_U_Circumflex & + W.LC_U_Diaeresis & + W.LC_Y_Acute & + W.LC_Y_Diaeresis, + + Rangev => + 'A' & -- UC_A_Grave + 'A' & -- UC_A_Acute + 'A' & -- UC_A_Circumflex + 'A' & -- UC_A_Tilde + 'A' & -- UC_A_Diaeresis + 'A' & -- UC_A_Ring + 'C' & -- UC_C_Cedilla + 'E' & -- UC_E_Grave + 'E' & -- UC_E_Acute + 'E' & -- UC_E_Circumflex + 'E' & -- UC_E_Diaeresis + 'I' & -- UC_I_Grave + 'I' & -- UC_I_Acute + 'I' & -- UC_I_Circumflex + 'I' & -- UC_I_Diaeresis + 'N' & -- UC_N_Tilde + 'O' & -- UC_O_Grave + 'O' & -- UC_O_Acute + 'O' & -- UC_O_Circumflex + 'O' & -- UC_O_Tilde + 'O' & -- UC_O_Diaeresis + 'O' & -- UC_O_Oblique_Stroke + 'U' & -- UC_U_Grave + 'U' & -- UC_U_Acute + 'U' & -- UC_U_Circumflex + 'U' & -- UC_U_Diaeresis + 'Y' & -- UC_Y_Acute + 'a' & -- LC_A_Grave + 'a' & -- LC_A_Acute + 'a' & -- LC_A_Circumflex + 'a' & -- LC_A_Tilde + 'a' & -- LC_A_Diaeresis + 'a' & -- LC_A_Ring + 'c' & -- LC_C_Cedilla + 'e' & -- LC_E_Grave + 'e' & -- LC_E_Acute + 'e' & -- LC_E_Circumflex + 'e' & -- LC_E_Diaeresis + 'i' & -- LC_I_Grave + 'i' & -- LC_I_Acute + 'i' & -- LC_I_Circumflex + 'i' & -- LC_I_Diaeresis + 'n' & -- LC_N_Tilde + 'o' & -- LC_O_Grave + 'o' & -- LC_O_Acute + 'o' & -- LC_O_Circumflex + 'o' & -- LC_O_Tilde + 'o' & -- LC_O_Diaeresis + 'o' & -- LC_O_Oblique_Stroke + 'u' & -- LC_U_Grave + 'u' & -- LC_U_Acute + 'u' & -- LC_U_Circumflex + 'u' & -- LC_U_Diaeresis + 'y' & -- LC_Y_Acute + 'y'); -- LC_Y_Diaeresis + + Basic_Map : constant Wide_Wide_Character_Mapping := + (AF.Controlled with + Basic_Mapping'Unrestricted_Access); + +end Ada.Strings.Wide_Wide_Maps.Wide_Wide_Constants; diff --git a/gcc/ada/libgnat/a-szunau-shared.adb b/gcc/ada/libgnat/a-szunau-shared.adb new file mode 100644 index 0000000..51737e0 --- /dev/null +++ b/gcc/ada/libgnat/a-szunau-shared.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Wide_Unbounded.Aux is + + -------------------------- + -- Get_Wide_Wide_String -- + -------------------------- + + procedure Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String; + S : out Big_Wide_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.Data'Address; + begin + S := X'Unchecked_Access; + L := U.Reference.Last; + end Get_Wide_Wide_String; + + -------------------------- + -- Set_Wide_Wide_String -- + -------------------------- + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access) + is + X : Wide_Wide_String_Access := S; + + begin + Set_Unbounded_Wide_Wide_String (UP, S.all); + Free (X); + end Set_Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-szunau.adb b/gcc/ada/libgnat/a-szunau.adb new file mode 100644 index 0000000..bfbdab0 --- /dev/null +++ b/gcc/ada/libgnat/a-szunau.adb @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Strings.Wide_Wide_Unbounded.Aux is + + -------------------------- + -- Get_Wide_Wide_String -- + -------------------------- + + procedure Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String; + S : out Big_Wide_Wide_String_Access; + L : out Natural) + is + X : aliased Big_Wide_Wide_String; + for X'Address use U.Reference.all'Address; + + begin + S := X'Unchecked_Access; + L := U.Last; + end Get_Wide_Wide_String; + + -------------------------- + -- Set_Wide_Wide_String -- + -------------------------- + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access) + is + begin + Finalize (UP); + UP.Reference := S; + UP.Last := UP.Reference'Length; + end Set_Wide_Wide_String; + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-szunau.ads b/gcc/ada/libgnat/a-szunau.ads new file mode 100644 index 0000000..f28d29d --- /dev/null +++ b/gcc/ada/libgnat/a-szunau.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ W I D E _ U N B O U N D E D . A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Wide_Unbounded provides some +-- specialized access functions which are intended to allow more efficient +-- use of the facilities of Ada.Strings.Wide_Wide_Unbounded, particularly by +-- other layered utilities. + +package Ada.Strings.Wide_Wide_Unbounded.Aux is + pragma Preelaborate; + + subtype Big_Wide_Wide_String is Wide_Wide_String (Positive); + type Big_Wide_Wide_String_Access is access all Big_Wide_Wide_String; + + procedure Get_Wide_Wide_String + (U : Unbounded_Wide_Wide_String; + S : out Big_Wide_Wide_String_Access; + L : out Natural); + pragma Inline (Get_Wide_Wide_String); + -- This procedure returns the internal string pointer used in the + -- representation of an unbounded string as well as the actual current + -- length (which may be less than S.all'Length because in general there + -- can be extra space assigned). The characters of this string may be + -- not be modified via the returned pointer, and are valid only as + -- long as the original unbounded string is not accessed or modified. + -- + -- This procedure is more efficient than the use of To_Wide_Wide_String + -- since it avoids the need to copy the string. The lower bound of the + -- referenced string returned by this call is always one, so the actual + -- string data is always accessible as S (1 .. L). + + procedure Set_Wide_Wide_String + (UP : out Unbounded_Wide_Wide_String; + S : Wide_Wide_String) + renames Set_Unbounded_Wide_Wide_String; + -- This function sets the string contents of the referenced unbounded + -- string to the given string value. It is significantly more efficient + -- than the use of To_Unbounded_Wide_Wide_String with an assignment, since + -- it avoids the necessity of messing with finalization chains. The lower + -- bound of the string S is not required to be one. + + procedure Set_Wide_Wide_String + (UP : in out Unbounded_Wide_Wide_String; + S : Wide_Wide_String_Access); + pragma Inline (Set_Wide_Wide_String); + -- This version of Set_Wide_Wide_String takes a string access value, rather + -- than string. The lower bound of the string value is required to be one, + -- and this requirement is not checked. + +end Ada.Strings.Wide_Wide_Unbounded.Aux; diff --git a/gcc/ada/libgnat/a-szuzha.adb b/gcc/ada/libgnat/a-szuzha.adb new file mode 100644 index 0000000..df87671 --- /dev/null +++ b/gcc/ada/libgnat/a-szuzha.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- This unit was originally developed by Matthew J Heaney. -- +------------------------------------------------------------------------------ + +with System.String_Hash; + +function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash + (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type +is + use Ada.Containers; + function Hash is new System.String_Hash.Hash + (Wide_Wide_Character, Wide_Wide_String, Hash_Type); +begin + return Hash (To_Wide_Wide_String (Key)); +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash; diff --git a/gcc/ada/libgnat/a-szuzha.ads b/gcc/ada/libgnat/a-szuzha.ads new file mode 100644 index 0000000..94bed28 --- /dev/null +++ b/gcc/ada/libgnat/a-szuzha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- A D A . S T R I N G S . W I D E _ U N B O U N D E D . W I D E _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Containers; + +function Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash + (Key : Unbounded_Wide_Wide_String) return Containers.Hash_Type; + +pragma Preelaborate (Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Hash); diff --git a/gcc/ada/libgnat/a-szuzti-shared.adb b/gcc/ada/libgnat/a-szuzti-shared.adb new file mode 100644 index 0000000..d8807af --- /dev/null +++ b/gcc/ada/libgnat/a-szuzti-shared.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_UNBOUNDED.WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; + +package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Result, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Result, Buffer (1 .. Last)); + end loop; + + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + Set_Unbounded_Wide_Wide_String (Item, Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Append (Item, Buffer (1 .. Last)); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (UR.Data (1 .. UR.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put (File, UR.Data (1 .. UR.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (UR.Data (1 .. UR.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is + UR : constant Shared_Wide_Wide_String_Access := U.Reference; + + begin + Put_Line (File, UR.Data (1 .. UR.Last)); + end Put_Line; + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-szuzti.adb b/gcc/ada/libgnat/a-szuzti.adb new file mode 100644 index 0000000..f1e9f02 --- /dev/null +++ b/gcc/ada/libgnat/a-szuzti.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; + +package body Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Unbounded_Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_Wide_String (1 .. Str1'Last + Last); + Str2 (Str1'Range) := Str1.all; + Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); + Free (Str1); + Str1 := Str2; + end loop; + + Result.Reference := Str1; + Result.Last := Str1'Length; + return Result; + end Get_Line; + + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) return Unbounded_Wide_Wide_String + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + Result : Unbounded_Wide_Wide_String; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new Wide_Wide_String (1 .. Str1'Last + Last); + Str2 (Str1'Range) := Str1.all; + Str2 (Str1'Last + 1 .. Str2'Last) := Buffer (1 .. Last); + Free (Str1); + Str1 := Str2; + end loop; + + Result.Reference := Str1; + Result.Last := Str1'Length; + return Result; + end Get_Line; + + procedure Get_Line (Item : out Unbounded_Wide_Wide_String) is + begin + Get_Line (Current_Input, Item); + end Get_Line; + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String) + is + begin + -- We are going to read into the string that is already there and + -- allocated. Hopefully it is big enough now, if not, we will extend + -- it in the usual manner using Realloc_For_Chunk. + + -- Make sure we start with at least 80 characters + + if Item.Reference'Last < 80 then + Realloc_For_Chunk (Item, 80); + end if; + + -- Loop to read data, filling current string as far as possible. + -- Item.Last holds the number of characters read so far. + + Item.Last := 0; + loop + Get_Line + (File, + Item.Reference (Item.Last + 1 .. Item.Reference'Last), + Item.Last); + + -- If we hit the end of the line before the end of the buffer, then + -- we are all done, and the result length is properly set. + + if Item.Last < Item.Reference'Last then + return; + end if; + + -- If not enough room, double it and keep reading + + Realloc_For_Chunk (Item, Item.Last); + end loop; + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put (U : Unbounded_Wide_Wide_String) is + begin + Put (U.Reference (1 .. U.Last)); + end Put; + + procedure Put (File : File_Type; U : Unbounded_Wide_Wide_String) is + begin + Put (File, U.Reference (1 .. U.Last)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (U : Unbounded_Wide_Wide_String) is + begin + Put_Line (U.Reference (1 .. U.Last)); + end Put_Line; + + procedure Put_Line (File : File_Type; U : Unbounded_Wide_Wide_String) is + begin + Put_Line (File, U.Reference (1 .. U.Last)); + end Put_Line; + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-szuzti.ads b/gcc/ada/libgnat/a-szuzti.ads new file mode 100644 index 0000000..ec97aa9 --- /dev/null +++ b/gcc/ada/libgnat/a-szuzti.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.STRINGS.WIDE_WIDE_UNBOUNDED.WIDE_WIDE_TEXT_IO -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This child package of Ada.Strings.Wide_Wide_Unbounded provides specialized +-- Wide_Wide_Text_IO routines that work directly with unbounded wide wide +-- strings, avoiding the inefficiencies of access via the standard interface, +-- and also taking direct advantage of the variable length semantics of these +-- strings. + +with Ada.Wide_Wide_Text_IO; + +package Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO is + + function Get_Line + return Unbounded_Wide_Wide_String; + function Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type) + return Unbounded_Wide_Wide_String; + -- Reads up to the end of the current line, returning the result + -- as an unbounded string of appropriate length. If no File parameter + -- is present, input is from Current_Input. + + procedure Get_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + Item : out Unbounded_Wide_Wide_String); + procedure Get_Line (Item : out Unbounded_Wide_Wide_String); + -- Similar to the above, but in procedure form with an out parameter + + procedure Put + (U : Unbounded_Wide_Wide_String); + procedure Put + (File : Ada.Wide_Wide_Text_IO.File_Type; + U : Unbounded_Wide_Wide_String); + procedure Put_Line + (U : Unbounded_Wide_Wide_String); + procedure Put_Line + (File : Ada.Wide_Wide_Text_IO.File_Type; + U : Unbounded_Wide_Wide_String); + -- These are equivalent to the standard Wide_Wide_Text_IO routines passed + -- the value To_Wide_Wide_String (U), but operate more efficiently, + -- because the extra copy of the argument is avoided. + +end Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-tags.adb b/gcc/ada/libgnat/a-tags.adb new file mode 100644 index 0000000..322f991 --- /dev/null +++ b/gcc/ada/libgnat/a-tags.adb @@ -0,0 +1,1100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A G S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Ada.Unchecked_Conversion; + +with System.HTable; +with System.Storage_Elements; use System.Storage_Elements; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_StW; use System.WCh_StW; + +pragma Elaborate (System.HTable); +-- Elaborate needed instead of Elaborate_All to avoid elaboration cycles +-- when polling is turned on. This is safe because HTable doesn't do anything +-- at elaboration time; it just contains a generic package we want to +-- instantiate. + +package body Ada.Tags is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean; + -- Given the tag of an object and the tag associated to a type, return + -- true if Obj is in Typ'Class. + + function Get_External_Tag (T : Tag) return System.Address; + -- Returns address of a null terminated string containing the external name + + function Is_Primary_DT (T : Tag) return Boolean; + -- Given a tag returns True if it has the signature of a primary dispatch + -- table. This is Inline_Always since it is called from other Inline_ + -- Always subprograms where we want no out of line code to be generated. + + function IW_Membership + (Descendant_TSD : Type_Specific_Data_Ptr; + T : Tag) return Boolean; + -- Subsidiary function of IW_Membership and CW_Membership which factorizes + -- the functionality needed to check if a given descendant implements an + -- interface tag T. + + function Length (Str : Cstring_Ptr) return Natural; + -- Length of string represented by the given pointer (treating the string + -- as a C-style string, which is Nul terminated). See comment in body + -- explaining why we cannot use the normal strlen built-in. + + function OSD (T : Tag) return Object_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a secondary dispatch table, + -- retrieve the address of the record containing the Object Specific + -- Data table. + + function SSD (T : Tag) return Select_Specific_Data_Ptr; + -- Ada 2005 (AI-251): Given a pointer T to a dispatch Table, retrieves the + -- address of the record containing the Select Specific Data in T's TSD. + + pragma Inline_Always (CW_Membership); + pragma Inline_Always (Get_External_Tag); + pragma Inline_Always (Is_Primary_DT); + pragma Inline_Always (OSD); + pragma Inline_Always (SSD); + + -- Unchecked conversions + + function To_Address is + new Unchecked_Conversion (Cstring_Ptr, System.Address); + + function To_Cstring_Ptr is + new Unchecked_Conversion (System.Address, Cstring_Ptr); + + -- Disable warnings on possible aliasing problem + + function To_Tag is + new Unchecked_Conversion (Integer_Address, Tag); + + function To_Addr_Ptr is + new Ada.Unchecked_Conversion (System.Address, Addr_Ptr); + + function To_Address is + new Ada.Unchecked_Conversion (Tag, System.Address); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (Tag, Dispatch_Table_Ptr); + + function To_Dispatch_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Dispatch_Table_Ptr); + + function To_Object_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Object_Specific_Data_Ptr); + + function To_Tag_Ptr is + new Ada.Unchecked_Conversion (System.Address, Tag_Ptr); + + function To_Type_Specific_Data_Ptr is + new Ada.Unchecked_Conversion (System.Address, Type_Specific_Data_Ptr); + + ------------------------------- + -- Inline_Always Subprograms -- + ------------------------------- + + -- Inline_always subprograms must be placed before their first call to + -- avoid defeating the frontend inlining mechanism and thus ensure the + -- generation of their correct debug info. + + ------------------- + -- CW_Membership -- + ------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Typ'Class + + -- Each dispatch table contains a reference to a table of ancestors (stored + -- in the first part of the Tags_Table) and a count of the level of + -- inheritance "Idepth". + + -- Obj is in Typ'Class if Typ'Tag is in the table of ancestors that are + -- contained in the dispatch table referenced by Obj'Tag . Knowing the + -- level of inheritance of both types, this can be computed in constant + -- time by the formula: + + -- TSD (Obj'tag).Tags_Table (TSD (Obj'tag).Idepth - TSD (Typ'tag).Idepth) + -- = Typ'tag + + function CW_Membership (Obj_Tag : Tag; Typ_Tag : Tag) return Boolean is + Obj_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Obj_Tag) - DT_Typeinfo_Ptr_Size); + Typ_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Typ_Tag) - DT_Typeinfo_Ptr_Size); + Obj_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Obj_TSD_Ptr.all); + Typ_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Typ_TSD_Ptr.all); + Pos : constant Integer := Obj_TSD.Idepth - Typ_TSD.Idepth; + begin + return Pos >= 0 and then Obj_TSD.Tags_Table (Pos) = Typ_Tag; + end CW_Membership; + + ---------------------- + -- Get_External_Tag -- + ---------------------- + + function Get_External_Tag (T : Tag) return System.Address is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return To_Address (TSD.External_Tag); + end Get_External_Tag; + + ----------------- + -- Is_Abstract -- + ----------------- + + function Is_Abstract (T : Tag) return Boolean is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + return TSD.Is_Abstract; + end Is_Abstract; + + ------------------- + -- Is_Primary_DT -- + ------------------- + + function Is_Primary_DT (T : Tag) return Boolean is + begin + return DT (T).Signature = Primary_DT; + end Is_Primary_DT; + + --------- + -- OSD -- + --------- + + function OSD (T : Tag) return Object_Specific_Data_Ptr is + OSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + begin + return To_Object_Specific_Data_Ptr (OSD_Ptr.all); + end OSD; + + --------- + -- SSD -- + --------- + + function SSD (T : Tag) return Select_Specific_Data_Ptr is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.SSD; + end SSD; + + ------------------------- + -- External_Tag_HTable -- + ------------------------- + + type HTable_Headers is range 1 .. 64; + + -- The following internal package defines the routines used for the + -- instantiation of a new System.HTable.Static_HTable (see below). See + -- spec in g-htable.ads for details of usage. + + package HTable_Subprograms is + procedure Set_HT_Link (T : Tag; Next : Tag); + function Get_HT_Link (T : Tag) return Tag; + function Hash (F : System.Address) return HTable_Headers; + function Equal (A, B : System.Address) return Boolean; + end HTable_Subprograms; + + package External_Tag_HTable is new System.HTable.Static_HTable ( + Header_Num => HTable_Headers, + Element => Dispatch_Table, + Elmt_Ptr => Tag, + Null_Ptr => null, + Set_Next => HTable_Subprograms.Set_HT_Link, + Next => HTable_Subprograms.Get_HT_Link, + Key => System.Address, + Get_Key => Get_External_Tag, + Hash => HTable_Subprograms.Hash, + Equal => HTable_Subprograms.Equal); + + ------------------------ + -- HTable_Subprograms -- + ------------------------ + + -- Bodies of routines for hash table instantiation + + package body HTable_Subprograms is + + ----------- + -- Equal -- + ----------- + + function Equal (A, B : System.Address) return Boolean is + Str1 : constant Cstring_Ptr := To_Cstring_Ptr (A); + Str2 : constant Cstring_Ptr := To_Cstring_Ptr (B); + J : Integer; + begin + J := 1; + loop + if Str1 (J) /= Str2 (J) then + return False; + elsif Str1 (J) = ASCII.NUL then + return True; + else + J := J + 1; + end if; + end loop; + end Equal; + + ----------------- + -- Get_HT_Link -- + ----------------- + + function Get_HT_Link (T : Tag) return Tag is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.HT_Link.all; + end Get_HT_Link; + + ---------- + -- Hash -- + ---------- + + function Hash (F : System.Address) return HTable_Headers is + function H is new System.HTable.Hash (HTable_Headers); + Str : constant Cstring_Ptr := To_Cstring_Ptr (F); + Res : constant HTable_Headers := H (Str (1 .. Length (Str))); + begin + return Res; + end Hash; + + ----------------- + -- Set_HT_Link -- + ----------------- + + procedure Set_HT_Link (T : Tag; Next : Tag) is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + TSD.HT_Link.all := Next; + end Set_HT_Link; + + end HTable_Subprograms; + + ------------------ + -- Base_Address -- + ------------------ + + function Base_Address (This : System.Address) return System.Address is + begin + return This - Offset_To_Top (This); + end Base_Address; + + --------------- + -- Check_TSD -- + --------------- + + procedure Check_TSD (TSD : Type_Specific_Data_Ptr) is + T : Tag; + + E_Tag_Len : constant Integer := Length (TSD.External_Tag); + E_Tag : String (1 .. E_Tag_Len); + for E_Tag'Address use TSD.External_Tag.all'Address; + pragma Import (Ada, E_Tag); + + Dup_Ext_Tag : constant String := "duplicated external tag """; + + begin + -- Verify that the external tag of this TSD is not registered in the + -- runtime hash table. + + T := External_Tag_HTable.Get (To_Address (TSD.External_Tag)); + + if T /= null then + + -- Avoid concatenation, as it is not allowed in no run time mode + + declare + Msg : String (1 .. Dup_Ext_Tag'Length + E_Tag_Len + 1); + begin + Msg (1 .. Dup_Ext_Tag'Length) := Dup_Ext_Tag; + Msg (Dup_Ext_Tag'Length + 1 .. Dup_Ext_Tag'Length + E_Tag_Len) := + E_Tag; + Msg (Msg'Last) := '"'; + raise Program_Error with Msg; + end; + end if; + end Check_TSD; + + -------------------- + -- Descendant_Tag -- + -------------------- + + function Descendant_Tag (External : String; Ancestor : Tag) return Tag is + Int_Tag : constant Tag := Internal_Tag (External); + begin + if not Is_Descendant_At_Same_Level (Int_Tag, Ancestor) then + raise Tag_Error; + else + return Int_Tag; + end if; + end Descendant_Tag; + + -------------- + -- Displace -- + -------------- + + function Displace (This : System.Address; T : Tag) return System.Address is + Iface_Table : Interface_Data_Ptr; + Obj_Base : System.Address; + Obj_DT : Dispatch_Table_Ptr; + Obj_DT_Tag : Tag; + + begin + if System."=" (This, System.Null_Address) then + return System.Null_Address; + end if; + + Obj_Base := Base_Address (This); + Obj_DT_Tag := To_Tag_Ptr (Obj_Base).all; + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then + + -- Case of Static value of Offset_To_Top + + if Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top then + Obj_Base := Obj_Base + + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value; + + -- Otherwise call the function generated by the expander to + -- provide the value. + + else + Obj_Base := Obj_Base + + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func.all + (Obj_Base); + end if; + + return Obj_Base; + end if; + end loop; + end if; + + -- Check if T is an immediate ancestor. This is required to handle + -- conversion of class-wide interfaces to tagged types. + + if CW_Membership (Obj_DT_Tag, T) then + return Obj_Base; + end if; + + -- If the object does not implement the interface we must raise CE + + raise Constraint_Error with "invalid interface conversion"; + end Displace; + + -------- + -- DT -- + -------- + + function DT (T : Tag) return Dispatch_Table_Ptr is + Offset : constant SSE.Storage_Offset := + To_Dispatch_Table_Ptr (T).Prims_Ptr'Position; + begin + return To_Dispatch_Table_Ptr (To_Address (T) - Offset); + end DT; + + ------------------- + -- IW_Membership -- + ------------------- + + function IW_Membership + (Descendant_TSD : Type_Specific_Data_Ptr; + T : Tag) return Boolean + is + Iface_Table : Interface_Data_Ptr; + + begin + Iface_Table := Descendant_TSD.Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = T then + return True; + end if; + end loop; + end if; + + -- Look for the tag in the ancestor tags table. This is required for: + -- Iface_CW in Typ'Class + + for Id in 0 .. Descendant_TSD.Idepth loop + if Descendant_TSD.Tags_Table (Id) = T then + return True; + end if; + end loop; + + return False; + end IW_Membership; + + ------------------- + -- IW_Membership -- + ------------------- + + -- Canonical implementation of Classwide Membership corresponding to: + + -- Obj in Iface'Class + + -- Each dispatch table contains a table with the tags of all the + -- implemented interfaces. + + -- Obj is in Iface'Class if Iface'Tag is found in the table of interfaces + -- that are contained in the dispatch table referenced by Obj'Tag. + + function IW_Membership (This : System.Address; T : Tag) return Boolean is + Obj_Base : System.Address; + Obj_DT : Dispatch_Table_Ptr; + Obj_TSD : Type_Specific_Data_Ptr; + + begin + Obj_Base := Base_Address (This); + Obj_DT := DT (To_Tag_Ptr (Obj_Base).all); + Obj_TSD := To_Type_Specific_Data_Ptr (Obj_DT.TSD); + + return IW_Membership (Obj_TSD, T); + end IW_Membership; + + ------------------- + -- Expanded_Name -- + ------------------- + + function Expanded_Name (T : Tag) return String is + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.Expanded_Name; + return Result (1 .. Length (Result)); + end Expanded_Name; + + ------------------ + -- External_Tag -- + ------------------ + + function External_Tag (T : Tag) return String is + Result : Cstring_Ptr; + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Result := TSD.External_Tag; + return Result (1 .. Length (Result)); + end External_Tag; + + --------------------- + -- Get_Entry_Index -- + --------------------- + + function Get_Entry_Index (T : Tag; Position : Positive) return Positive is + begin + return SSD (T).SSD_Table (Position).Index; + end Get_Entry_Index; + + ---------------------- + -- Get_Prim_Op_Kind -- + ---------------------- + + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind + is + begin + return SSD (T).SSD_Table (Position).Kind; + end Get_Prim_Op_Kind; + + ---------------------- + -- Get_Offset_Index -- + ---------------------- + + function Get_Offset_Index + (T : Tag; + Position : Positive) return Positive + is + begin + if Is_Primary_DT (T) then + return Position; + else + return OSD (T).OSD_Table (Position); + end if; + end Get_Offset_Index; + + --------------------- + -- Get_Tagged_Kind -- + --------------------- + + function Get_Tagged_Kind (T : Tag) return Tagged_Kind is + begin + return DT (T).Tag_Kind; + end Get_Tagged_Kind; + + ----------------------------- + -- Interface_Ancestor_Tags -- + ----------------------------- + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + Iface_Table : constant Interface_Data_Ptr := TSD.Interfaces_Table; + + begin + if Iface_Table = null then + declare + Table : Tag_Array (1 .. 0); + begin + return Table; + end; + + else + declare + Table : Tag_Array (1 .. Iface_Table.Nb_Ifaces); + begin + for J in 1 .. Iface_Table.Nb_Ifaces loop + Table (J) := Iface_Table.Ifaces_Table (J).Iface_Tag; + end loop; + + return Table; + end; + end if; + end Interface_Ancestor_Tags; + + ------------------ + -- Internal_Tag -- + ------------------ + + -- Internal tags have the following format: + -- "Internal tag at 16#ADDRESS#: " + + Internal_Tag_Header : constant String := "Internal tag at "; + Header_Separator : constant Character := '#'; + + function Internal_Tag (External : String) return Tag is + pragma Unsuppress (All_Checks); + -- To make T'Class'Input robust in the case of bad data + + Res : Tag := null; + + begin + -- Raise Tag_Error for empty strings and very long strings. This makes + -- T'Class'Input robust in the case of bad data, for example + -- + -- String (123456789..1234) + -- + -- The limit of 10,000 characters is arbitrary, but is unlikely to be + -- exceeded by legitimate external tag names. + + if External'Length not in 1 .. 10_000 then + raise Tag_Error; + end if; + + -- Handle locally defined tagged types + + if External'Length > Internal_Tag_Header'Length + and then + External (External'First .. + External'First + Internal_Tag_Header'Length - 1) = + Internal_Tag_Header + then + declare + Addr_First : constant Natural := + External'First + Internal_Tag_Header'Length; + Addr_Last : Natural; + Addr : Integer_Address; + + begin + -- Search the second separator (#) to identify the address + + Addr_Last := Addr_First; + + for J in 1 .. 2 loop + while Addr_Last <= External'Last + and then External (Addr_Last) /= Header_Separator + loop + Addr_Last := Addr_Last + 1; + end loop; + + -- Skip the first separator + + if J = 1 then + Addr_Last := Addr_Last + 1; + end if; + end loop; + + if Addr_Last <= External'Last then + + -- Protect the run-time against wrong internal tags. We + -- cannot use exception handlers here because it would + -- disable the use of this run-time compiling with + -- restriction No_Exception_Handler. + + declare + C : Character; + Wrong_Tag : Boolean := False; + + begin + if External (Addr_First) /= '1' + or else External (Addr_First + 1) /= '6' + or else External (Addr_First + 2) /= '#' + then + Wrong_Tag := True; + + else + for J in Addr_First + 3 .. Addr_Last - 1 loop + C := External (J); + + if not (C in '0' .. '9') + and then not (C in 'A' .. 'F') + and then not (C in 'a' .. 'f') + then + Wrong_Tag := True; + exit; + end if; + end loop; + end if; + + -- Convert the numeric value into a tag + + if not Wrong_Tag then + Addr := Integer_Address'Value + (External (Addr_First .. Addr_Last)); + + -- Internal tags never have value 0 + + if Addr /= 0 then + return To_Tag (Addr); + end if; + end if; + end; + end if; + end; + + -- Handle library-level tagged types + + else + -- Make NUL-terminated copy of external tag string + + declare + Ext_Copy : aliased String (External'First .. External'Last + 1); + pragma Assert (Ext_Copy'Length > 1); -- See Length check at top + begin + Ext_Copy (External'Range) := External; + Ext_Copy (Ext_Copy'Last) := ASCII.NUL; + Res := External_Tag_HTable.Get (Ext_Copy'Address); + end; + end if; + + if Res = null then + declare + Msg1 : constant String := "unknown tagged type: "; + Msg2 : String (1 .. Msg1'Length + External'Length); + + begin + Msg2 (1 .. Msg1'Length) := Msg1; + Msg2 (Msg1'Length + 1 .. Msg1'Length + External'Length) := + External; + Ada.Exceptions.Raise_Exception (Tag_Error'Identity, Msg2); + end; + end if; + + return Res; + end Internal_Tag; + + --------------------------------- + -- Is_Descendant_At_Same_Level -- + --------------------------------- + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean + is + begin + if Descendant = Ancestor then + return True; + + else + declare + D_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Descendant) - DT_Typeinfo_Ptr_Size); + A_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Ancestor) - DT_Typeinfo_Ptr_Size); + D_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (D_TSD_Ptr.all); + A_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (A_TSD_Ptr.all); + begin + return + D_TSD.Access_Level = A_TSD.Access_Level + and then (CW_Membership (Descendant, Ancestor) + or else IW_Membership (D_TSD, Ancestor)); + end; + end if; + end Is_Descendant_At_Same_Level; + + ------------ + -- Length -- + ------------ + + -- Note: This unit is used in the Ravenscar runtime library, so it cannot + -- depend on System.CTRL. Furthermore, this happens on CPUs where the GCC + -- intrinsic strlen may not be available, so we need to recode our own Ada + -- version here. + + function Length (Str : Cstring_Ptr) return Natural is + Len : Integer; + + begin + Len := 1; + while Str (Len) /= ASCII.NUL loop + Len := Len + 1; + end loop; + + return Len - 1; + end Length; + + ------------------- + -- Offset_To_Top -- + ------------------- + + function Offset_To_Top + (This : System.Address) return SSE.Storage_Offset + is + Tag_Size : constant SSE.Storage_Count := + SSE.Storage_Count (1 * (Standard'Address_Size / System.Storage_Unit)); + + type Storage_Offset_Ptr is access SSE.Storage_Offset; + function To_Storage_Offset_Ptr is + new Unchecked_Conversion (System.Address, Storage_Offset_Ptr); + + Curr_DT : Dispatch_Table_Ptr; + + begin + Curr_DT := DT (To_Tag_Ptr (This).all); + + if Curr_DT.Offset_To_Top = SSE.Storage_Offset'Last then + return To_Storage_Offset_Ptr (This + Tag_Size).all; + else + return Curr_DT.Offset_To_Top; + end if; + end Offset_To_Top; + + ------------------------ + -- Needs_Finalization -- + ------------------------ + + function Needs_Finalization (T : Tag) return Boolean is + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + begin + return TSD.Needs_Finalization; + end Needs_Finalization; + + ----------------- + -- Parent_Size -- + ----------------- + + function Parent_Size + (Obj : System.Address; + T : Tag) return SSE.Storage_Count + is + Parent_Slot : constant Positive := 1; + -- The tag of the parent is always in the first slot of the table of + -- ancestor tags. + + TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (TSD_Ptr.all); + -- Pointer to the TSD + + Parent_Tag : constant Tag := TSD.Tags_Table (Parent_Slot); + Parent_TSD_Ptr : constant Addr_Ptr := + To_Addr_Ptr (To_Address (Parent_Tag) - DT_Typeinfo_Ptr_Size); + Parent_TSD : constant Type_Specific_Data_Ptr := + To_Type_Specific_Data_Ptr (Parent_TSD_Ptr.all); + + begin + -- Here we compute the size of the _parent field of the object + + return SSE.Storage_Count (Parent_TSD.Size_Func.all (Obj)); + end Parent_Size; + + ---------------- + -- Parent_Tag -- + ---------------- + + function Parent_Tag (T : Tag) return Tag is + TSD_Ptr : Addr_Ptr; + TSD : Type_Specific_Data_Ptr; + + begin + if T = No_Tag then + raise Tag_Error; + end if; + + TSD_Ptr := To_Addr_Ptr (To_Address (T) - DT_Typeinfo_Ptr_Size); + TSD := To_Type_Specific_Data_Ptr (TSD_Ptr.all); + + -- The Parent_Tag of a root-level tagged type is defined to be No_Tag. + -- The first entry in the Ancestors_Tags array will be null for such + -- a type, but it's better to be explicit about returning No_Tag in + -- this case. + + if TSD.Idepth = 0 then + return No_Tag; + else + return TSD.Tags_Table (1); + end if; + end Parent_Tag; + + ------------------------------- + -- Register_Interface_Offset -- + ------------------------------- + + procedure Register_Interface_Offset + (Prim_T : Tag; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T); + Iface_Table : constant Interface_Data_Ptr := + To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table; + + begin + -- Save Offset_Value in the table of interfaces of the primary DT. + -- This data will be used by the subprogram "Displace" to give support + -- to backward abstract interface type conversions. + + -- Register the offset in the table of interfaces + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then + if Is_Static or else Offset_Value = 0 then + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value := + Offset_Value; + else + Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False; + Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func := + Offset_Func; + end if; + + return; + end if; + end loop; + end if; + + -- If we arrive here there is some error in the run-time data structure + + raise Program_Error; + end Register_Interface_Offset; + + ------------------ + -- Register_Tag -- + ------------------ + + procedure Register_Tag (T : Tag) is + begin + External_Tag_HTable.Set (T); + end Register_Tag; + + ------------------- + -- Secondary_Tag -- + ------------------- + + function Secondary_Tag (T, Iface : Tag) return Tag is + Iface_Table : Interface_Data_Ptr; + Obj_DT : Dispatch_Table_Ptr; + + begin + if not Is_Primary_DT (T) then + raise Program_Error; + end if; + + Obj_DT := DT (T); + Iface_Table := To_Type_Specific_Data_Ptr (Obj_DT.TSD).Interfaces_Table; + + if Iface_Table /= null then + for Id in 1 .. Iface_Table.Nb_Ifaces loop + if Iface_Table.Ifaces_Table (Id).Iface_Tag = Iface then + return Iface_Table.Ifaces_Table (Id).Secondary_DT; + end if; + end loop; + end if; + + -- If the object does not implement the interface we must raise CE + + raise Constraint_Error with "invalid interface conversion"; + end Secondary_Tag; + + --------------------- + -- Set_Entry_Index -- + --------------------- + + procedure Set_Entry_Index + (T : Tag; + Position : Positive; + Value : Positive) + is + begin + SSD (T).SSD_Table (Position).Index := Value; + end Set_Entry_Index; + + ----------------------- + -- Set_Offset_To_Top -- + ----------------------- + + procedure Set_Dynamic_Offset_To_Top + (This : System.Address; + Prim_T : Tag; + Interface_T : Tag; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr) + is + Sec_Base : System.Address; + Sec_DT : Dispatch_Table_Ptr; + + begin + -- Save the offset to top field in the secondary dispatch table + + if Offset_Value /= 0 then + Sec_Base := This + Offset_Value; + Sec_DT := DT (To_Tag_Ptr (Sec_Base).all); + Sec_DT.Offset_To_Top := SSE.Storage_Offset'Last; + end if; + + Register_Interface_Offset + (Prim_T, Interface_T, False, Offset_Value, Offset_Func); + end Set_Dynamic_Offset_To_Top; + + ---------------------- + -- Set_Prim_Op_Kind -- + ---------------------- + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind) + is + begin + SSD (T).SSD_Table (Position).Kind := Value; + end Set_Prim_Op_Kind; + + -------------------- + -- Unregister_Tag -- + -------------------- + + procedure Unregister_Tag (T : Tag) is + begin + External_Tag_HTable.Remove (Get_External_Tag (T)); + end Unregister_Tag; + + ------------------------ + -- Wide_Expanded_Name -- + ------------------------ + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Encoding method for source, as exported by binder + + function Wide_Expanded_Name (T : Tag) return Wide_String is + S : constant String := Expanded_Name (T); + W : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Expanded_Name; + + ----------------------------- + -- Wide_Wide_Expanded_Name -- + ----------------------------- + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String is + S : constant String := Expanded_Name (T); + W : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String + (S, W, L, Get_WC_Encoding_Method (WC_Encoding)); + return W (1 .. L); + end Wide_Wide_Expanded_Name; + +end Ada.Tags; diff --git a/gcc/ada/libgnat/a-tags.ads b/gcc/ada/libgnat/a-tags.ads new file mode 100644 index 0000000..564ce20 --- /dev/null +++ b/gcc/ada/libgnat/a-tags.ads @@ -0,0 +1,612 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T A G S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- For performance analysis, take into account that the operations in this +-- package provide the guarantee that all dispatching calls on primitive +-- operations of tagged types and interfaces take constant time (in terms +-- of source lines executed), that is to say, the cost of these calls is +-- independent of the number of primitives of the type or interface, and +-- independent of the number of ancestors or interface progenitors that a +-- tagged type may have. + +-- The following subprograms of the public part of this package take constant +-- time (in terms of source lines executed): + +-- Expanded_Name, Wide_Expanded_Name, Wide_Wide_Expanded_Name, External_Tag, +-- Is_Abstract, Is_Descendant_At_Same_Level, Parent_Tag, +-- Descendant_Tag (when used with a library-level tagged type), +-- Internal_Tag (when used with a library-level tagged type). + +-- The following subprograms of the public part of this package execute in +-- time that is not constant (in terms of sources line executed): + +-- Internal_Tag (when used with a locally defined tagged type), because in +-- such cases this routine processes the external tag, extracts from it an +-- address available there, and converts it into the tag value returned by +-- this function. The number of instructions executed is not constant since +-- it depends on the length of the external tag string. + +-- Descendant_Tag (when used with a locally defined tagged type), because +-- it relies on the subprogram Internal_Tag() to provide its functionality. + +-- Interface_Ancestor_Tags, because this function returns a table whose +-- length depends on the number of interfaces covered by a tagged type. + +with System.Storage_Elements; + +package Ada.Tags is + pragma Preelaborate; + -- In accordance with Ada 2005 AI-362 + + type Tag is private; + pragma Preelaborable_Initialization (Tag); + + No_Tag : constant Tag; + + function Expanded_Name (T : Tag) return String; + + function Wide_Expanded_Name (T : Tag) return Wide_String; + pragma Ada_05 (Wide_Expanded_Name); + + function Wide_Wide_Expanded_Name (T : Tag) return Wide_Wide_String; + pragma Ada_05 (Wide_Wide_Expanded_Name); + + function External_Tag (T : Tag) return String; + + function Internal_Tag (External : String) return Tag; + + function Descendant_Tag + (External : String; + Ancestor : Tag) return Tag; + pragma Ada_05 (Descendant_Tag); + + function Is_Descendant_At_Same_Level + (Descendant : Tag; + Ancestor : Tag) return Boolean; + pragma Ada_05 (Is_Descendant_At_Same_Level); + + function Parent_Tag (T : Tag) return Tag; + pragma Ada_05 (Parent_Tag); + + type Tag_Array is array (Positive range <>) of Tag; + + function Interface_Ancestor_Tags (T : Tag) return Tag_Array; + pragma Ada_05 (Interface_Ancestor_Tags); + + function Is_Abstract (T : Tag) return Boolean; + pragma Ada_2012 (Is_Abstract); + + Tag_Error : exception; + +private + -- Structure of the GNAT Primary Dispatch Table + + -- +--------------------+ + -- | Signature | + -- +--------------------+ + -- | Tagged_Kind | + -- +--------------------+ Predef Prims + -- | Predef_Prims -----------------------------> +------------+ + -- +--------------------+ | table of | + -- | Offset_To_Top | | predefined | + -- +--------------------+ | primitives | + -- |Typeinfo_Ptr/TSD_Ptr---> Type Specific Data +------------+ + -- Tag ---> +--------------------+ +-------------------+ + -- | table of | | inheritance depth | + -- : primitive ops : +-------------------+ + -- | pointers | | access level | + -- +--------------------+ +-------------------+ + -- | alignment | + -- +-------------------+ + -- | expanded name | + -- +-------------------+ + -- | external tag | + -- +-------------------+ + -- | hash table link | + -- +-------------------+ + -- | transportable | + -- +-------------------+ + -- | is_abstract | + -- +-------------------+ + -- | needs finalization| + -- +-------------------+ + -- | Ifaces_Table ---> Interface Data + -- +-------------------+ +------------+ + -- Select Specific Data <---- SSD | | Nb_Ifaces | + -- +------------------+ +-------------------+ +------------+ + -- |table of primitive| | table of | | table | + -- : operation : : ancestor : : of : + -- | kinds | | tags | | interfaces | + -- +------------------+ +-------------------+ +------------+ + -- |table of | + -- : entry : + -- | indexes | + -- +------------------+ + + -- Structure of the GNAT Secondary Dispatch Table + + -- +--------------------+ + -- | Signature | + -- +--------------------+ + -- | Tagged_Kind | + -- +--------------------+ Predef Prims + -- | Predef_Prims -----------------------------> +------------+ + -- +--------------------+ | table of | + -- | Offset_To_Top | | predefined | + -- +--------------------+ | primitives | + -- | OSD_Ptr |---> Object Specific Data | thunks | + -- Tag ---> +--------------------+ +---------------+ +------------+ + -- | table of | | num prim ops | + -- : primitive op : +---------------+ + -- | thunk pointers | | table of | + -- +--------------------+ + primitive | + -- | op offsets | + -- +---------------+ + + -- The runtime information kept for each tagged type is separated into two + -- objects: the Dispatch Table and the Type Specific Data record. + + package SSE renames System.Storage_Elements; + + subtype Cstring is String (Positive); + type Cstring_Ptr is access all Cstring; + pragma No_Strict_Aliasing (Cstring_Ptr); + + -- Declarations for the table of interfaces + + type Offset_To_Top_Function_Ptr is + access function (This : System.Address) return SSE.Storage_Offset; + -- Type definition used to call the function that is generated by the + -- expander in case of tagged types with discriminants that have secondary + -- dispatch tables. This function provides the Offset_To_Top value in this + -- specific case. + + type Interface_Data_Element is record + Iface_Tag : Tag; + Static_Offset_To_Top : Boolean; + Offset_To_Top_Value : SSE.Storage_Offset; + Offset_To_Top_Func : Offset_To_Top_Function_Ptr; + Secondary_DT : Tag; + end record; + -- If some ancestor of the tagged type has discriminants the field + -- Static_Offset_To_Top is False and the field Offset_To_Top_Func + -- is used to store the access to the function generated by the + -- expander which provides this value; otherwise Static_Offset_To_Top + -- is True and such value is stored in the Offset_To_Top_Value field. + -- Secondary_DT references a secondary dispatch table whose contents + -- are pointers to the primitives of the tagged type that cover the + -- interface primitives. Secondary_DT gives support to dispatching + -- calls through interface types associated with Generic Dispatching + -- Constructors. + + type Interfaces_Array is array (Natural range <>) of Interface_Data_Element; + + type Interface_Data (Nb_Ifaces : Positive) is record + Ifaces_Table : Interfaces_Array (1 .. Nb_Ifaces); + end record; + + type Interface_Data_Ptr is access all Interface_Data; + -- Table of abstract interfaces used to give support to backward interface + -- conversions and also to IW_Membership. + + -- Primitive operation kinds. These values differentiate the kinds of + -- callable entities stored in the dispatch table. Certain kinds may + -- not be used, but are added for completeness. + + type Prim_Op_Kind is + (POK_Function, + POK_Procedure, + POK_Protected_Entry, + POK_Protected_Function, + POK_Protected_Procedure, + POK_Task_Entry, + POK_Task_Function, + POK_Task_Procedure); + + -- Select specific data types + + type Select_Specific_Data_Element is record + Index : Positive; + Kind : Prim_Op_Kind; + end record; + + type Select_Specific_Data_Array is + array (Positive range <>) of Select_Specific_Data_Element; + + type Select_Specific_Data (Nb_Prim : Positive) is record + SSD_Table : Select_Specific_Data_Array (1 .. Nb_Prim); + -- NOTE: Nb_Prim is the number of non-predefined primitive operations + end record; + + type Select_Specific_Data_Ptr is access all Select_Specific_Data; + -- A table used to store the primitive operation kind and entry index of + -- primitive subprograms of a type that implements a limited interface. + -- The Select Specific Data table resides in the Type Specific Data of a + -- type. This construct is used in the handling of dispatching triggers + -- in select statements. + + type Prim_Ptr is access procedure; + type Address_Array is array (Positive range <>) of Prim_Ptr; + + subtype Dispatch_Table is Address_Array (1 .. 1); + -- Used by GDB to identify the _tags and traverse the run-time structure + -- associated with tagged types. For compatibility with older versions of + -- gdb, its name must not be changed. + + type Tag is access all Dispatch_Table; + pragma No_Strict_Aliasing (Tag); + + type Interface_Tag is access all Dispatch_Table; + + No_Tag : constant Tag := null; + + -- The expander ensures that Tag objects reference the Prims_Ptr component + -- of the wrapper. + + type Tag_Ptr is access all Tag; + pragma No_Strict_Aliasing (Tag_Ptr); + + type Offset_To_Top_Ptr is access all SSE.Storage_Offset; + pragma No_Strict_Aliasing (Offset_To_Top_Ptr); + + type Tag_Table is array (Natural range <>) of Tag; + + type Size_Ptr is + access function (A : System.Address) return Long_Long_Integer; + + type Type_Specific_Data (Idepth : Natural) is record + -- The discriminant Idepth is the Inheritance Depth Level: Used to + -- implement the membership test associated with single inheritance of + -- tagged types in constant-time. It also indicates the size of the + -- Tags_Table component. + + Access_Level : Natural; + -- Accessibility level required to give support to Ada 2005 nested type + -- extensions. This feature allows safe nested type extensions by + -- shifting the accessibility checks to certain operations, rather than + -- being enforced at the type declaration. In particular, by performing + -- run-time accessibility checks on class-wide allocators, class-wide + -- function return, and class-wide stream I/O, the danger of objects + -- outliving their type declaration can be eliminated (Ada 2005: AI-344) + + Alignment : Natural; + Expanded_Name : Cstring_Ptr; + External_Tag : Cstring_Ptr; + HT_Link : Tag_Ptr; + -- Components used to support to the Ada.Tags subprograms in RM 3.9 + + -- Note: Expanded_Name is referenced by GDB to determine the actual name + -- of the tagged type. Its requirements are: 1) it must have this exact + -- name, and 2) its contents must point to a C-style Nul terminated + -- string containing its expanded name. GDB has no requirement on a + -- given position inside the record. + + Transportable : Boolean; + -- Used to check RM E.4(18), set for types that satisfy the requirements + -- for being used in remote calls as actuals for classwide formals or as + -- return values for classwide functions. + + Is_Abstract : Boolean; + -- True if the type is abstract (Ada 2012: AI05-0173) + + Needs_Finalization : Boolean; + -- Used to dynamically check whether an object is controlled or not + + Size_Func : Size_Ptr; + -- Pointer to the subprogram computing the _size of the object. Used by + -- the run-time whenever a call to the 'size primitive is required. We + -- cannot assume that the contents of dispatch tables are addresses + -- because in some architectures the ABI allows descriptors. + + Interfaces_Table : Interface_Data_Ptr; + -- Pointer to the table of interface tags. It is used to implement the + -- membership test associated with interfaces and also for backward + -- abstract interface type conversions (Ada 2005:AI-251) + + SSD : Select_Specific_Data_Ptr; + -- Pointer to a table of records used in dispatching selects. This field + -- has a meaningful value for all tagged types that implement a limited, + -- protected, synchronized or task interfaces and have non-predefined + -- primitive operations. + + Tags_Table : Tag_Table (0 .. Idepth); + -- Table of ancestor tags. Its size actually depends on the inheritance + -- depth level of the tagged type. + end record; + + type Type_Specific_Data_Ptr is access all Type_Specific_Data; + pragma No_Strict_Aliasing (Type_Specific_Data_Ptr); + + -- Declarations for the dispatch table record + + type Signature_Kind is + (Unknown, + Primary_DT, + Secondary_DT); + + -- Tagged type kinds with respect to concurrency and limitedness + + type Tagged_Kind is + (TK_Abstract_Limited_Tagged, + TK_Abstract_Tagged, + TK_Limited_Tagged, + TK_Protected, + TK_Tagged, + TK_Task); + + type Dispatch_Table_Wrapper (Num_Prims : Natural) is record + Signature : Signature_Kind; + Tag_Kind : Tagged_Kind; + Predef_Prims : System.Address; + -- Pointer to the dispatch table of predefined Ada primitives + + -- According to the C++ ABI the components Offset_To_Top and TSD are + -- stored just "before" the dispatch table, and they are referenced with + -- negative offsets referring to the base of the dispatch table. The + -- _Tag (or the VTable_Ptr in C++ terminology) must point to the base + -- of the virtual table, just after these components, to point to the + -- Prims_Ptr table. + + Offset_To_Top : SSE.Storage_Offset; + TSD : System.Address; + + Prims_Ptr : aliased Address_Array (1 .. Num_Prims); + -- The size of the Prims_Ptr array actually depends on the tagged type + -- to which it applies. For each tagged type, the expander computes the + -- actual array size, allocates the Dispatch_Table record accordingly. + end record; + + type Dispatch_Table_Ptr is access all Dispatch_Table_Wrapper; + pragma No_Strict_Aliasing (Dispatch_Table_Ptr); + + -- The following type declaration is used by the compiler when the program + -- is compiled with restriction No_Dispatching_Calls. It is also used with + -- interface types to generate the tag and run-time information associated + -- with them. + + type No_Dispatch_Table_Wrapper is record + NDT_TSD : System.Address; + NDT_Prims_Ptr : Natural; + end record; + + DT_Predef_Prims_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Predef_Prims field of the Dispatch_Table + + DT_Offset_To_Top_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Offset_To_Top field of the Dispatch Table + + DT_Typeinfo_Ptr_Size : constant SSE.Storage_Count := + SSE.Storage_Count + (1 * (Standard'Address_Size / + System.Storage_Unit)); + -- Size of the Typeinfo_Ptr field of the Dispatch Table + + use type System.Storage_Elements.Storage_Offset; + + DT_Offset_To_Top_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size; + + DT_Predef_Prims_Offset : constant SSE.Storage_Count := + DT_Typeinfo_Ptr_Size + + DT_Offset_To_Top_Size + + DT_Predef_Prims_Size; + -- Offset from Prims_Ptr to Predef_Prims component + + -- Object Specific Data record of secondary dispatch tables + + type Object_Specific_Data_Array is array (Positive range <>) of Positive; + + type Object_Specific_Data (OSD_Num_Prims : Positive) is record + OSD_Table : Object_Specific_Data_Array (1 .. OSD_Num_Prims); + -- Table used in secondary DT to reference their counterpart in the + -- select specific data (in the TSD of the primary DT). This construct + -- is used in the handling of dispatching triggers in select statements. + -- Nb_Prim is the number of non-predefined primitive operations. + end record; + + type Object_Specific_Data_Ptr is access all Object_Specific_Data; + pragma No_Strict_Aliasing (Object_Specific_Data_Ptr); + + -- The following subprogram specifications are placed here instead of the + -- package body to see them from the frontend through rtsfind. + + function Base_Address (This : System.Address) return System.Address; + -- Ada 2005 (AI-251): Displace "This" to point to the base address of the + -- object (that is, the address of the primary tag of the object). + + procedure Check_TSD (TSD : Type_Specific_Data_Ptr); + -- Ada 2012 (AI-113): Raise Program_Error if the external tag of this TSD + -- is the same as the external tag for some other tagged type declaration. + + function Displace (This : System.Address; T : Tag) return System.Address; + -- Ada 2005 (AI-251): Displace "This" to point to the secondary dispatch + -- table of T. + + function Secondary_Tag (T, Iface : Tag) return Tag; + -- Ada 2005 (AI-251): Given a primary tag T associated with a tagged type + -- Typ, search for the secondary tag of the interface type Iface covered + -- by Typ. + + function DT (T : Tag) return Dispatch_Table_Ptr; + -- Return the pointer to the TSD record associated with T + + function Get_Entry_Index (T : Tag; Position : Positive) return Positive; + -- Ada 2005 (AI-251): Return a primitive operation's entry index (if entry) + -- given a dispatch table T and a position of a primitive operation in T. + + function Get_Offset_Index + (T : Tag; + Position : Positive) return Positive; + -- Ada 2005 (AI-251): Given a pointer to a secondary dispatch table (T) + -- and a position of an operation in the DT, retrieve the corresponding + -- operation's position in the primary dispatch table from the Offset + -- Specific Data table of T. + + function Get_Prim_Op_Kind + (T : Tag; + Position : Positive) return Prim_Op_Kind; + -- Ada 2005 (AI-251): Return a primitive operation's kind given a dispatch + -- table T and a position of a primitive operation in T. + + function Get_Tagged_Kind (T : Tag) return Tagged_Kind; + -- Ada 2005 (AI-345): Given a pointer to either a primary or a secondary + -- dispatch table, return the tagged kind of a type in the context of + -- concurrency and limitedness. + + function IW_Membership (This : System.Address; T : Tag) return Boolean; + -- Ada 2005 (AI-251): General routine that checks if a given object + -- implements a tagged type. Its common usage is to check if Obj is in + -- Iface'Class, but it is also used to check if a class-wide interface + -- implements a given type (Iface_CW_Typ in T'Class). For example: + -- + -- type I is interface; + -- type T is tagged ... + -- + -- function Test (O : I'Class) is + -- begin + -- return O in T'Class. + -- end Test; + + function Offset_To_Top + (This : System.Address) return SSE.Storage_Offset; + -- Ada 2005 (AI-251): Returns the current value of the Offset_To_Top + -- component available in the prologue of the dispatch table. If the parent + -- of the tagged type has discriminants this value is stored in a record + -- component just immediately after the tag component. + + function Needs_Finalization (T : Tag) return Boolean; + -- A helper routine used in conjunction with finalization collections which + -- service class-wide types. The function dynamically determines whether an + -- object is controlled or has controlled components. + + function Parent_Size + (Obj : System.Address; + T : Tag) return SSE.Storage_Count; + -- Computes the size the ancestor part of a tagged extension object whose + -- address is 'obj' by calling indirectly the ancestor _size function. The + -- ancestor is the parent of the type represented by tag T. This function + -- assumes that _size is always in slot one of the dispatch table. + + procedure Register_Interface_Offset + (Prim_T : Tag; + Interface_T : Tag; + Is_Static : Boolean; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Register in the table of interfaces of the tagged type associated with + -- Prim_T the offset of the record component associated with the progenitor + -- Interface_T (that is, the distance from "This" to the object component + -- containing the tag of the secondary dispatch table). In case of constant + -- offset, Is_Static is true and Offset_Value has such value. In case of + -- variable offset, Is_Static is false and Offset_Func is an access to + -- function that must be called to evaluate the offset. + + procedure Register_Tag (T : Tag); + -- Insert the Tag and its associated external_tag in a table for the sake + -- of Internal_Tag. + + procedure Set_Dynamic_Offset_To_Top + (This : System.Address; + Prim_T : Tag; + Interface_T : Tag; + Offset_Value : SSE.Storage_Offset; + Offset_Func : Offset_To_Top_Function_Ptr); + -- Ada 2005 (AI-251): The compiler generates calls to this routine only + -- when initializing the Offset_To_Top field of dispatch tables of tagged + -- types that cover interface types whose parent type has variable size + -- components. + -- + -- "This" is the object whose dispatch table is being initialized. Prim_T + -- is the primary tag of such object. Interface_T is the interface tag for + -- which the secondary dispatch table is being initialized. Offset_Value + -- is the distance from "This" to the object component containing the tag + -- of the secondary dispatch table (a zero value means that this interface + -- shares the primary dispatch table). Offset_Func references a function + -- that must be called to evaluate the offset at run time. This routine + -- also takes care of registering these values in the table of interfaces + -- of the type. + + procedure Set_Entry_Index (T : Tag; Position : Positive; Value : Positive); + -- Ada 2005 (AI-345): Set the entry index of a primitive operation in T's + -- TSD table indexed by Position. + + procedure Set_Prim_Op_Kind + (T : Tag; + Position : Positive; + Value : Prim_Op_Kind); + -- Ada 2005 (AI-251): Set the kind of a primitive operation in T's TSD + -- table indexed by Position. + + procedure Unregister_Tag (T : Tag); + -- Remove a particular tag from the external tag hash table + + Max_Predef_Prims : constant Positive := 15; + -- Number of reserved slots for the following predefined ada primitives: + -- + -- 1. Size + -- 2. Read + -- 3. Write + -- 4. Input + -- 5. Output + -- 6. "=" + -- 7. assignment + -- 8. deep adjust + -- 9. deep finalize + -- 10. async select + -- 11. conditional select + -- 12. prim_op kind + -- 13. task_id + -- 14. dispatching requeue + -- 15. timed select + -- + -- The compiler checks that the value here is correct + + subtype Predef_Prims_Table is Address_Array (1 .. Max_Predef_Prims); + type Predef_Prims_Table_Ptr is access Predef_Prims_Table; + pragma No_Strict_Aliasing (Predef_Prims_Table_Ptr); + + type Addr_Ptr is access System.Address; + pragma No_Strict_Aliasing (Addr_Ptr); + -- This type is used by the frontend to generate the code that handles + -- dispatch table slots of types declared at the local level. + +end Ada.Tags; diff --git a/gcc/ada/libgnat/a-teioed.adb b/gcc/ada/libgnat/a-teioed.adb new file mode 100644 index 0000000..93e69f6 --- /dev/null +++ b/gcc/ada/libgnat/a-teioed.adb @@ -0,0 +1,2860 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E D I T I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +package body Ada.Text_IO.Editing is + + package Strings renames Ada.Strings; + package Strings_Fixed renames Ada.Strings.Fixed; + package Text_IO renames Ada.Text_IO; + + --------------------- + -- Blank_When_Zero -- + --------------------- + + function Blank_When_Zero (Pic : Picture) return Boolean is + begin + return Pic.Contents.Original_BWZ; + end Blank_When_Zero; + + ------------ + -- Expand -- + ------------ + + function Expand (Picture : String) return String is + Result : String (1 .. MAX_PICSIZE); + Picture_Index : Integer := Picture'First; + Result_Index : Integer := Result'First; + Count : Natural; + Last : Integer; + + package Int_IO is new Ada.Text_IO.Integer_IO (Integer); + + begin + if Picture'Length < 1 then + raise Picture_Error; + end if; + + if Picture (Picture'First) = '(' then + raise Picture_Error; + end if; + + loop + case Picture (Picture_Index) is + when '(' => + Int_IO.Get + (Picture (Picture_Index + 1 .. Picture'Last), Count, Last); + + if Picture (Last + 1) /= ')' then + raise Picture_Error; + end if; + + -- In what follows note that one copy of the repeated character + -- has already been made, so a count of one is a no-op, and a + -- count of zero erases a character. + + if Result_Index + Count - 2 > Result'Last then + raise Picture_Error; + end if; + + for J in 2 .. Count loop + Result (Result_Index + J - 2) := Picture (Picture_Index - 1); + end loop; + + Result_Index := Result_Index + Count - 1; + + -- Last + 1 was a ')' throw it away too + + Picture_Index := Last + 2; + + when ')' => + raise Picture_Error; + + when others => + if Result_Index > Result'Last then + raise Picture_Error; + end if; + + Result (Result_Index) := Picture (Picture_Index); + Picture_Index := Picture_Index + 1; + Result_Index := Result_Index + 1; + end case; + + exit when Picture_Index > Picture'Last; + end loop; + + return Result (1 .. Result_Index - 1); + + exception + when others => + raise Picture_Error; + end Expand; + + ------------------- + -- Format_Number -- + ------------------- + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : String; + Fill_Character : Character; + Separator_Character : Character; + Radix_Point : Character) return String + is + Attrs : Number_Attributes := Parse_Number_String (Number); + Position : Integer; + Rounded : String := Number; + + Sign_Position : Integer := Pic.Sign_Position; -- may float. + + Answer : String (1 .. Pic.Picture.Length) := Pic.Picture.Expanded; + Last : Integer; + Currency_Pos : Integer := Pic.Start_Currency; + In_Currency : Boolean := False; + + Dollar : Boolean := False; + -- Overridden immediately if necessary + + Zero : Boolean := True; + -- Set to False when a non-zero digit is output + + begin + + -- If the picture has fewer decimal places than the number, the image + -- must be rounded according to the usual rules. + + if Attrs.Has_Fraction then + declare + R : constant Integer := + (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) + - Pic.Max_Trailing_Digits; + R_Pos : Integer; + + begin + if R > 0 then + R_Pos := Attrs.End_Of_Fraction - R; + + if Rounded (R_Pos + 1) > '4' then + + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + + while R_Pos > 1 loop + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + exit; + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + end if; + end loop; + + -- The rounding may add a digit in front. Either the + -- leading blank or the sign (already captured) can + -- be overwritten. + + if R_Pos = 1 then + Rounded (R_Pos) := '1'; + Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; + end if; + end if; + end if; + end if; + end; + end if; + + if Pic.Start_Currency /= Invalid_Position then + Dollar := Answer (Pic.Start_Currency) = '$'; + end if; + + -- Fix up "direct inserts" outside the playing field. Set up as one + -- loop to do the beginning, one (reverse) loop to do the end. + + Last := 1; + loop + exit when Last = Pic.Start_Float; + exit when Last = Pic.Radix_Position; + exit when Answer (Last) = '9'; + + case Answer (Last) is + when '_' => + Answer (Last) := Separator_Character; + + when 'b' => + Answer (Last) := ' '; + + when others => + null; + end case; + + exit when Last = Answer'Last; + + Last := Last + 1; + end loop; + + -- Now for the end... + + for J in reverse Last .. Answer'Last loop + exit when J = Pic.Radix_Position; + + -- Do this test First, Separator_Character can equal Pic.Floater + + if Answer (J) = Pic.Floater then + exit; + end if; + + case Answer (J) is + when '_' => + Answer (J) := Separator_Character; + + when 'b' => + Answer (J) := ' '; + + when '9' => + exit; + + when others => + null; + end case; + end loop; + + -- Non-floating sign + + if Pic.Start_Currency /= -1 + and then Answer (Pic.Start_Currency) = '#' + and then Pic.Floater /= '#' + then + if Currency_Symbol'Length > + Pic.End_Currency - Pic.Start_Currency + 1 + then + raise Picture_Error; + + elsif Currency_Symbol'Length = + Pic.End_Currency - Pic.Start_Currency + 1 + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + Currency_Symbol; + + elsif Pic.Radix_Position = Invalid_Position + or else Pic.Start_Currency < Pic.Radix_Position + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. + Pic.End_Currency) := Currency_Symbol; + + else + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.Start_Currency .. + Pic.Start_Currency + Currency_Symbol'Length - 1) := + Currency_Symbol; + end if; + end if; + + -- Fill in leading digits + + if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > + Pic.Max_Leading_Digits + then + raise Ada.Text_IO.Layout_Error; + end if; + + Position := + (if Pic.Radix_Position = Invalid_Position + then Answer'Last + else Pic.Radix_Position - 1); + + for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop + while Answer (Position) /= '9' + and then + Answer (Position) /= Pic.Floater + loop + if Answer (Position) = '_' then + Answer (Position) := Separator_Character; + + elsif Answer (Position) = 'b' then + Answer (Position) := ' '; + end if; + + Position := Position - 1; + end loop; + + Answer (Position) := Rounded (J); + + if Rounded (J) /= '0' then + Zero := False; + end if; + + Position := Position - 1; + end loop; + + -- Do lead float + + if Pic.Start_Float = Invalid_Position then + + -- No leading floats, but need to change '9' to '0', '_' to + -- Separator_Character and 'b' to ' '. + + for J in Last .. Position loop + + -- Last set when fixing the "uninteresting" leaders above. + -- Don't duplicate the work. + + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + end if; + end loop; + + elsif Pic.Floater = '<' + or else + Pic.Floater = '+' + or else + Pic.Floater = '-' + then + for J in Pic.End_Float .. Position loop -- May be null range. + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Sign_Position := Position; + + elsif Pic.Floater = '$' then + + for J in Pic.End_Float .. Position loop -- May be null range. + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := ' '; -- no separators before leftmost digit. + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Currency_Pos := Position; + + elsif Pic.Floater = '*' then + + for J in Pic.End_Float .. Position loop -- May be null range. + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := Fill_Character; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position loop + Answer (J) := Fill_Character; + end loop; + + else + if Pic.Floater = '#' then + Currency_Pos := Currency_Symbol'Length; + In_Currency := True; + end if; + + for J in reverse Pic.Start_Float .. Position loop + case Answer (J) is + when '*' => + Answer (J) := Fill_Character; + + when 'b' | '/' => + if In_Currency and then Currency_Pos > 0 then + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + else + Answer (J) := ' '; + end if; + + when 'Z' | '0' => + Answer (J) := ' '; + + when '9' => + Answer (J) := '0'; + + when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => + null; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when '_' => + case Pic.Floater is + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'b' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when others => + null; + end case; + + when others => + null; + end case; + end loop; + + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Ada.Text_IO.Layout_Error; + end if; + end if; + + -- Do sign + + if Sign_Position = Invalid_Position then + if Attrs.Negative then + raise Ada.Text_IO.Layout_Error; + end if; + + else + if Attrs.Negative then + case Answer (Sign_Position) is + when 'C' | 'D' | '-' => + null; + + when '+' => + Answer (Sign_Position) := '-'; + + when '<' => + Answer (Sign_Position) := '('; + Answer (Pic.Second_Sign) := ')'; + + when others => + raise Picture_Error; + end case; + + else -- positive + + case Answer (Sign_Position) is + when '-' => + Answer (Sign_Position) := ' '; + + when '<' | 'C' | 'D' => + Answer (Sign_Position) := ' '; + Answer (Pic.Second_Sign) := ' '; + + when '+' => + null; + + when others => + raise Picture_Error; + end case; + end if; + end if; + + -- Fill in trailing digits + + if Pic.Max_Trailing_Digits > 0 then + + if Attrs.Has_Fraction then + Position := Attrs.Start_Of_Fraction; + Last := Pic.Radix_Position + 1; + + for J in Last .. Answer'Last loop + if Answer (J) = '9' or else Answer (J) = Pic.Floater then + Answer (J) := Rounded (Position); + + if Rounded (Position) /= '0' then + Zero := False; + end if; + + Position := Position + 1; + Last := J + 1; + + -- Used up fraction but remember place in Answer + + exit when Position > Attrs.End_Of_Fraction; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + end if; + + Last := J + 1; + end loop; + + Position := Last; + + else + Position := Pic.Radix_Position + 1; + end if; + + -- Now fill remaining 9's with zeros and _ with separators + + Last := Answer'Last; + + for J in Position .. Last loop + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = Pic.Floater then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + end loop; + + Position := Last + 1; + + else + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Ada.Text_IO.Layout_Error; + end if; + + -- No trailing digits, but now J may need to stick in a currency + -- symbol or sign. + + Position := + (if Pic.Start_Currency = Invalid_Position + then Answer'Last + 1 + else Pic.Start_Currency); + end if; + + for J in Position .. Answer'Last loop + if Pic.Start_Currency /= Invalid_Position + and then Answer (Pic.Start_Currency) = '#' + then + Currency_Pos := 1; + end if; + + case Answer (J) is + when '*' => + Answer (J) := Fill_Character; + + when 'b' => + if In_Currency then + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + + if Currency_Pos > Currency_Symbol'Length then + In_Currency := False; + end if; + end if; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + + else + In_Currency := True; + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + + if Currency_Pos > Currency_Symbol'Length then + In_Currency := False; + end if; + end if; + + when '_' => + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + + case Pic.Floater is + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'z' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + end if; + + when others => + null; + end case; + + when others => + exit; + end case; + end loop; + + -- Now get rid of Blank_when_Zero and complete Star fill + + if Zero and then Pic.Blank_When_Zero then + + -- Value is zero, and blank it + + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position + and then Answer (Pic.Radix_Position) = 'V' + then + Last := Last - 1; + end if; + + return String'(1 .. Last => ' '); + + elsif Zero and then Pic.Star_Fill then + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position then + + if Answer (Pic.Radix_Position) = 'V' then + Last := Last - 1; + + elsif Dollar then + if Pic.Radix_Position > Pic.Start_Currency then + return String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + String'(Pic.Radix_Position + 1 .. Last => '*'); + + else + return + String' + (1 .. + Pic.Radix_Position + Currency_Symbol'Length - 2 => + '*') & Radix_Point & + String' + (Pic.Radix_Position + Currency_Symbol'Length .. Last + => '*'); + end if; + + else + return String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + String'(Pic.Radix_Position + 1 .. Last => '*'); + end if; + end if; + + return String'(1 .. Last => '*'); + end if; + + -- This was once a simple return statement, now there are nine different + -- return cases. Not to mention the five above to deal with zeros. Why + -- not split things out? + + -- Processing the radix and sign expansion separately would require + -- lots of copying--the string and some of its indexes--without + -- really simplifying the logic. The cases are: + + -- 1) Expand $, replace '.' with Radix_Point + -- 2) No currency expansion, replace '.' with Radix_Point + -- 3) Expand $, radix blanked + -- 4) No currency expansion, radix blanked + -- 5) Elide V + -- 6) Expand $, Elide V + -- 7) Elide V, Expand $ (Two cases depending on order.) + -- 8) No radix, expand $ + -- 9) No radix, no currency expansion + + if Pic.Radix_Position /= Invalid_Position then + + if Answer (Pic.Radix_Position) = '.' then + Answer (Pic.Radix_Position) := Radix_Point; + + if Dollar then + + -- 1) Expand $, replace '.' with Radix_Point + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 2) No currency expansion, replace '.' with Radix_Point + + return Answer; + end if; + + elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. + if Dollar then + + -- 3) Expand $, radix blanked + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 4) No expansion, radix blanked + + return Answer; + end if; + + -- V cases + + else + if not Dollar then + + -- 5) Elide V + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + elsif Currency_Pos < Pic.Radix_Position then + + -- 6) Expand $, Elide V + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + else + -- 7) Elide V, Expand $ + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & + Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + end if; + end if; + + elsif Dollar then + + -- 8) No radix, expand $ + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 9) No radix, no currency expansion + + return Answer; + end if; + end Format_Number; + + ------------------------- + -- Parse_Number_String -- + ------------------------- + + function Parse_Number_String (Str : String) return Number_Attributes is + Answer : Number_Attributes; + + begin + for J in Str'Range loop + case Str (J) is + when ' ' => + null; -- ignore + + when '1' .. '9' => + + -- Decide if this is the start of a number. + -- If so, figure out which one... + + if Answer.Has_Fraction then + Answer.End_Of_Fraction := J; + else + if Answer.Start_Of_Int = Invalid_Position then + -- start integer + Answer.Start_Of_Int := J; + end if; + Answer.End_Of_Int := J; + end if; + + when '0' => + + -- Only count a zero before the decimal point if it follows a + -- non-zero digit. After the decimal point, zeros will be + -- counted if followed by a non-zero digit. + + if not Answer.Has_Fraction then + if Answer.Start_Of_Int /= Invalid_Position then + Answer.End_Of_Int := J; + end if; + end if; + + when '-' => + + -- Set negative + + Answer.Negative := True; + + when '.' => + + -- Close integer, start fraction + + if Answer.Has_Fraction then + raise Picture_Error; + end if; + + -- Two decimal points is a no-no + + Answer.Has_Fraction := True; + Answer.End_Of_Fraction := J; + + -- Could leave this at Invalid_Position, but this seems the + -- right way to indicate a null range... + + Answer.Start_Of_Fraction := J + 1; + Answer.End_Of_Int := J - 1; + + when others => + raise Picture_Error; -- can this happen? probably not + end case; + end loop; + + if Answer.Start_Of_Int = Invalid_Position then + Answer.Start_Of_Int := Answer.End_Of_Int + 1; + end if; + + -- No significant (integer) digits needs a null range + + return Answer; + end Parse_Number_String; + + ---------------- + -- Pic_String -- + ---------------- + + -- The following ensures that we return B and not b being careful not + -- to break things which expect lower case b for blank. See CXF3A02. + + function Pic_String (Pic : Picture) return String is + Temp : String (1 .. Pic.Contents.Picture.Length) := + Pic.Contents.Picture.Expanded; + begin + for J in Temp'Range loop + if Temp (J) = 'b' then + Temp (J) := 'B'; + end if; + end loop; + + return Temp; + end Pic_String; + + ------------------ + -- Precalculate -- + ------------------ + + procedure Precalculate (Pic : in out Format_Record) is + Debug : constant Boolean := False; + -- Set True to generate debug output + + Computed_BWZ : Boolean := True; + + type Legality is (Okay, Reject); + + State : Legality := Reject; + -- Start in reject, which will reject null strings + + Index : Pic_Index := Pic.Picture.Expanded'First; + + function At_End return Boolean; + pragma Inline (At_End); + + procedure Set_State (L : Legality); + pragma Inline (Set_State); + + function Look return Character; + pragma Inline (Look); + + function Is_Insert return Boolean; + pragma Inline (Is_Insert); + + procedure Skip; + pragma Inline (Skip); + + procedure Debug_Start (Name : String); + pragma Inline (Debug_Start); + + procedure Debug_Integer (Value : Integer; S : String); + pragma Inline (Debug_Integer); + + procedure Trailing_Currency; + procedure Trailing_Bracket; + procedure Number_Fraction; + procedure Number_Completion; + procedure Number_Fraction_Or_Bracket; + procedure Number_Fraction_Or_Z_Fill; + procedure Zero_Suppression; + procedure Floating_Bracket; + procedure Number_Fraction_Or_Star_Fill; + procedure Star_Suppression; + procedure Number_Fraction_Or_Dollar; + procedure Leading_Dollar; + procedure Number_Fraction_Or_Pound; + procedure Leading_Pound; + procedure Picture; + procedure Floating_Plus; + procedure Floating_Minus; + procedure Picture_Plus; + procedure Picture_Minus; + procedure Picture_Bracket; + procedure Number; + procedure Optional_RHS_Sign; + procedure Picture_String; + procedure Set_Debug; + + ------------ + -- At_End -- + ------------ + + function At_End return Boolean is + begin + Debug_Start ("At_End"); + return Index > Pic.Picture.Length; + end At_End; + + -------------- + -- Set_Debug-- + -------------- + + -- Needed to have a procedure to pass to pragma Debug + + procedure Set_Debug is + begin + -- Uncomment this line and make Debug a variable to enable debug + + -- Debug := True; + + null; + end Set_Debug; + + ------------------- + -- Debug_Integer -- + ------------------- + + procedure Debug_Integer (Value : Integer; S : String) is + use Ada.Text_IO; -- needed for > + + begin + if Debug and then Value > 0 then + if Ada.Text_IO.Col > 70 - S'Length then + Ada.Text_IO.New_Line; + end if; + + Ada.Text_IO.Put (' ' & S & Integer'Image (Value) & ','); + end if; + end Debug_Integer; + + ----------------- + -- Debug_Start -- + ----------------- + + procedure Debug_Start (Name : String) is + begin + if Debug then + Ada.Text_IO.Put_Line (" In " & Name & '.'); + end if; + end Debug_Start; + + ---------------------- + -- Floating_Bracket -- + ---------------------- + + -- Note that Floating_Bracket is only called with an acceptable + -- prefix. But we don't set Okay, because we must end with a '>'. + + procedure Floating_Bracket is + begin + Debug_Start ("Floating_Bracket"); + + -- Two different floats not allowed + + if Pic.Floater /= '!' and then Pic.Floater /= '<' then + raise Picture_Error; + + else + Pic.Floater := '<'; + end if; + + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + + -- First bracket wasn't counted... + + Skip; -- known '<' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when '9' => + Number_Completion; + + when '$' => + Leading_Dollar; + + when '#' => + Leading_Pound; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Bracket; + return; + + when others => + return; + end case; + end loop; + end Floating_Bracket; + + -------------------- + -- Floating_Minus -- + -------------------- + + procedure Floating_Minus is + begin + Debug_Start ("Floating_Minus"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '-' then + loop + if At_End then + return; + end if; + + case Look is + when '-' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + end case; + end loop; + end Floating_Minus; + + ------------------- + -- Floating_Plus -- + ------------------- + + procedure Floating_Plus is + begin + Debug_Start ("Floating_Plus"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '+' then + loop + if At_End then + return; + end if; + + case Look is + when '+' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + end case; + end loop; + end Floating_Plus; + + --------------- + -- Is_Insert -- + --------------- + + function Is_Insert return Boolean is + begin + if At_End then + return False; + end if; + + case Pic.Picture.Expanded (Index) is + when '_' | '0' | '/' => + return True; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; -- canonical + return True; + + when others => + return False; + end case; + end Is_Insert; + + -------------------- + -- Leading_Dollar -- + -------------------- + + -- Note that Leading_Dollar can be called in either State. It will set + -- state to Okay only if a 9 or (second) $ is encountered. + + -- Also notice the tricky bit with State and Zero_Suppression. + -- Zero_Suppression is Picture_Error if a '$' or a '9' has been + -- encountered, exactly the cases where State has been set. + + procedure Leading_Dollar is + begin + Debug_Start ("Leading_Dollar"); + + -- Treat as a floating dollar, and unwind otherwise + + if Pic.Floater /= '!' and then Pic.Floater /= '$' then + + -- Two floats not allowed + + raise Picture_Error; + + else + Pic.Floater := '$'; + end if; + + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Skip; -- known '$' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + -- A trailing insertion character is not part of the + -- floating currency, so need to look ahead. + + if Look /= '$' then + Pic.End_Float := Pic.End_Float - 1; + end if; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if State = Okay then + raise Picture_Error; + else + -- Overwrite Floater and Start_Float + + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + Zero_Suppression; + end if; + + when '*' => + if State = Okay then + raise Picture_Error; + else + -- Overwrite Floater and Start_Float + + Pic.Floater := '*'; + Pic.Start_Float := Index; + Star_Suppression; + end if; + + when '$' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); Skip; + + when '9' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- A single dollar does not a floating make + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one dollar before the sign is okay, but doesn't + -- float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Dollar; + return; + + when others => + return; + end case; + end loop; + end Leading_Dollar; + + ------------------- + -- Leading_Pound -- + ------------------- + + -- This one is complex. A Leading_Pound can be fixed or floating, + -- but in some cases the decision has to be deferred until we leave + -- this procedure. Also note that Leading_Pound can be called in + -- either State. + + -- It will set state to Okay only if a 9 or (second) # is encountered + + -- One Last note: In ambiguous cases, the currency is treated as + -- floating unless there is only one '#'. + + procedure Leading_Pound is + + Inserts : Boolean := False; + -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered + + Must_Float : Boolean := False; + -- Set to true if a '#' occurs after an insert + + begin + Debug_Start ("Leading_Pound"); + + -- Treat as a floating currency. If it isn't, this will be + -- overwritten later. + + if Pic.Floater /= '!' and then Pic.Floater /= '#' then + + -- Two floats not allowed + + raise Picture_Error; + + else + Pic.Floater := '#'; + end if; + + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Pic.Max_Currency_Digits := 1; -- we've seen one. + + Skip; -- known '#' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Overwrite Floater and Start_Float + + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + Zero_Suppression; + end if; + + when '*' => + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Overwrite Floater and Start_Float + Pic.Floater := '*'; + Pic.Start_Float := Index; + Star_Suppression; + end if; + + when '#' => + if Inserts then + Must_Float := True; + end if; + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); + Skip; + + when '9' => + if State /= Okay then + + -- A single '#' doesn't float + + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one pound before the sign is okay, but doesn't + -- float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Pound; + return; + + when others => + return; + end case; + end loop; + end Leading_Pound; + + ---------- + -- Look -- + ---------- + + function Look return Character is + begin + if At_End then + raise Picture_Error; + end if; + + return Pic.Picture.Expanded (Index); + end Look; + + ------------ + -- Number -- + ------------ + + procedure Number is + begin + Debug_Start ("Number"); + + loop + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + end case; + + if At_End then + return; + end if; + + -- Will return in Okay state if a '9' was seen + + end loop; + end Number; + + ----------------------- + -- Number_Completion -- + ----------------------- + + procedure Number_Completion is + begin + Debug_Start ("Number_Completion"); + + while not At_End loop + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + end case; + end loop; + end Number_Completion; + + --------------------- + -- Number_Fraction -- + --------------------- + + procedure Number_Fraction is + begin + -- Note that number fraction can be called in either State. + -- It will set state to Valid only if a 9 is encountered. + + Debug_Start ("Number_Fraction"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Set_State (Okay); Skip; + + when others => + return; + end case; + end loop; + end Number_Fraction; + + -------------------------------- + -- Number_Fraction_Or_Bracket -- + -------------------------------- + + procedure Number_Fraction_Or_Bracket is + begin + Debug_Start ("Number_Fraction_Or_Bracket"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Bracket; + + ------------------------------- + -- Number_Fraction_Or_Dollar -- + ------------------------------- + + procedure Number_Fraction_Or_Dollar is + begin + Debug_Start ("Number_Fraction_Or_Dollar"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Dollar; + + ------------------------------ + -- Number_Fraction_Or_Pound -- + ------------------------------ + + procedure Number_Fraction_Or_Pound is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Pound; + + ---------------------------------- + -- Number_Fraction_Or_Star_Fill -- + ---------------------------------- + + procedure Number_Fraction_Or_Star_Fill is + begin + Debug_Start ("Number_Fraction_Or_Star_Fill"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Star_Fill; + + ------------------------------- + -- Number_Fraction_Or_Z_Fill -- + ------------------------------- + + procedure Number_Fraction_Or_Z_Fill is + begin + Debug_Start ("Number_Fraction_Or_Z_Fill"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Z_Fill; + + ----------------------- + -- Optional_RHS_Sign -- + ----------------------- + + procedure Optional_RHS_Sign is + begin + Debug_Start ("Optional_RHS_Sign"); + + if At_End then + return; + end if; + + case Look is + when '+' | '-' => + Pic.Sign_Position := Index; + Skip; + return; + + when 'C' | 'c' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'C'; + Skip; + + if Look = 'R' or else Look = 'r' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'R'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when 'D' | 'd' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'D'; + Skip; + + if Look = 'B' or else Look = 'b' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'B'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when '>' => + if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then + Pic.Second_Sign := Index; + Skip; + + else + raise Picture_Error; + end if; + + when others => + return; + end case; + end Optional_RHS_Sign; + + ------------- + -- Picture -- + ------------- + + -- Note that Picture can be called in either State + + -- It will set state to Valid only if a 9 is encountered or floating + -- currency is called. + + procedure Picture is + begin + Debug_Start ("Picture"); + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Leading_Dollar; + return; + + when '#' => + Leading_Pound; + return; + + when '9' => + Computed_BWZ := False; + Set_State (Okay); + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + Trailing_Currency; + return; + + when others => + return; + end case; + end loop; + end Picture; + + --------------------- + -- Picture_Bracket -- + --------------------- + + procedure Picture_Bracket is + begin + Pic.Sign_Position := Index; + Debug_Start ("Picture_Bracket"); + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '<'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Bracket + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Set_State (Okay); -- "<<>" is enough. + Floating_Bracket; + Trailing_Currency; + Trailing_Bracket; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Trailing_Bracket; + Set_State (Okay); + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + Trailing_Bracket; + return; + + when others => + raise Picture_Error; + end case; + end loop; + end Picture_Bracket; + + ------------------- + -- Picture_Minus -- + ------------------- + + procedure Picture_Minus is + begin + Debug_Start ("Picture_Minus"); + + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '-'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Minus + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "-- " is enough. + Floating_Minus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + + -- Can't have Z and a floating sign + + if State = Okay then + Set_State (Reject); + end if; + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + return; + + when others => + return; + end case; + end loop; + end Picture_Minus; + + ------------------ + -- Picture_Plus -- + ------------------ + + procedure Picture_Plus is + begin + Debug_Start ("Picture_Plus"); + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '+'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Plus + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "++" is enough + Floating_Plus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + if State = Okay then + Set_State (Reject); + end if; + + -- Can't have Z and a floating sign + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + -- '+Z' is acceptable + + Set_State (Okay); + + -- Overwrite Floater and Start_Float + + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + return; + + when others => + return; + end case; + end loop; + end Picture_Plus; + + -------------------- + -- Picture_String -- + -------------------- + + procedure Picture_String is + begin + Debug_Start ("Picture_String"); + + while Is_Insert loop + Skip; + end loop; + + case Look is + when '$' | '#' => + Picture; + Optional_RHS_Sign; + + when '+' => + Picture_Plus; + + when '-' => + Picture_Minus; + + when '<' => + Picture_Bracket; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '*' => + Star_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '9' | '.' | 'V' | 'v' => + Number; + Trailing_Currency; + Optional_RHS_Sign; + + when others => + raise Picture_Error; + end case; + + -- Blank when zero either if the PIC does not contain a '9' or if + -- requested by the user and no '*'. + + Pic.Blank_When_Zero := + (Computed_BWZ or else Pic.Blank_When_Zero) + and then not Pic.Star_Fill; + + -- Star fill if '*' and no '9' + + Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; + + if not At_End then + Set_State (Reject); + end if; + end Picture_String; + + --------------- + -- Set_State -- + --------------- + + procedure Set_State (L : Legality) is + begin + if Debug then + Ada.Text_IO.Put_Line + (" Set state from " & Legality'Image (State) + & " to " & Legality'Image (L)); + end if; + + State := L; + end Set_State; + + ---------- + -- Skip -- + ---------- + + procedure Skip is + begin + if Debug then + Ada.Text_IO.Put_Line (" Skip " & Pic.Picture.Expanded (Index)); + end if; + + Index := Index + 1; + end Skip; + + ---------------------- + -- Star_Suppression -- + ---------------------- + + procedure Star_Suppression is + begin + Debug_Start ("Star_Suppression"); + + if Pic.Floater /= '!' and then Pic.Floater /= '*' then + + -- Two floats not allowed + + raise Picture_Error; + + else + Pic.Floater := '*'; + end if; + + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + + -- Even a single * is a valid picture + + Pic.Star_Fill := True; + Skip; -- Known * + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Star_Fill; + return; + + when '#' | '$' => + if Pic.Max_Currency_Digits > 0 then + raise Picture_Error; + end if; + + -- Cannot have leading and trailing currency + + Trailing_Currency; + Set_State (Okay); + return; + + when others => + raise Picture_Error; + end case; + end loop; + end Star_Suppression; + + ---------------------- + -- Trailing_Bracket -- + ---------------------- + + procedure Trailing_Bracket is + begin + Debug_Start ("Trailing_Bracket"); + + if Look = '>' then + Pic.Second_Sign := Index; + Skip; + else + raise Picture_Error; + end if; + end Trailing_Bracket; + + ----------------------- + -- Trailing_Currency -- + ----------------------- + + procedure Trailing_Currency is + begin + Debug_Start ("Trailing_Currency"); + + if At_End then + return; + end if; + + if Look = '$' then + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Skip; + + else + while not At_End and then Look = '#' loop + if Pic.Start_Currency = Invalid_Position then + Pic.Start_Currency := Index; + end if; + + Pic.End_Currency := Index; + Skip; + end loop; + end if; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + end Trailing_Currency; + + ---------------------- + -- Zero_Suppression -- + ---------------------- + + procedure Zero_Suppression is + begin + Debug_Start ("Zero_Suppression"); + + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; -- Known Z + + loop + -- Even a single Z is a valid picture + + if At_End then + Set_State (Okay); + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Set_State (Okay); + Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Z_Fill; + return; + + when '#' | '$' => + Trailing_Currency; + Set_State (Okay); + return; + + when others => + return; + end case; + end loop; + end Zero_Suppression; + + -- Start of processing for Precalculate + + begin + pragma Debug (Set_Debug); + + Picture_String; + + if Debug then + Ada.Text_IO.New_Line; + Ada.Text_IO.Put (" Picture : """ & + Pic.Picture.Expanded (1 .. Pic.Picture.Length) & ""","); + Ada.Text_IO.Put (" Floater : '" & Pic.Floater & "',"); + end if; + + if State = Reject then + raise Picture_Error; + end if; + + Debug_Integer (Pic.Radix_Position, "Radix Positon : "); + Debug_Integer (Pic.Sign_Position, "Sign Positon : "); + Debug_Integer (Pic.Second_Sign, "Second Sign : "); + Debug_Integer (Pic.Start_Float, "Start Float : "); + Debug_Integer (Pic.End_Float, "End Float : "); + Debug_Integer (Pic.Start_Currency, "Start Currency : "); + Debug_Integer (Pic.End_Currency, "End Currency : "); + Debug_Integer (Pic.Max_Leading_Digits, "Max Leading Digits : "); + Debug_Integer (Pic.Max_Trailing_Digits, "Max Trailing Digits : "); + + if Debug then + Ada.Text_IO.New_Line; + end if; + + exception + + when Constraint_Error => + + -- To deal with special cases like null strings + + raise Picture_Error; + end Precalculate; + + ---------------- + -- To_Picture -- + ---------------- + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture + is + Result : Picture; + + begin + declare + Item : constant String := Expand (Pic_String); + + begin + Result.Contents.Picture := (Item'Length, Item); + Result.Contents.Original_BWZ := Blank_When_Zero; + Result.Contents.Blank_When_Zero := Blank_When_Zero; + Precalculate (Result.Contents); + return Result; + end; + + exception + when others => + raise Picture_Error; + end To_Picture; + + ----------- + -- Valid -- + ----------- + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean + is + begin + declare + Expanded_Pic : constant String := Expand (Pic_String); + -- Raises Picture_Error if Item not well-formed + + Format_Rec : Format_Record; + + begin + Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); + Format_Rec.Blank_When_Zero := Blank_When_Zero; + Format_Rec.Original_BWZ := Blank_When_Zero; + Precalculate (Format_Rec); + + -- False only if Blank_When_Zero is True but the pic string has a '*' + + return not Blank_When_Zero + or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; + end; + + exception + when others => return False; + end Valid; + + -------------------- + -- Decimal_Output -- + -------------------- + + package body Decimal_Output is + + ----------- + -- Image -- + ----------- + + function Image + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark) return String + is + begin + return Format_Number + (Pic.Contents, Num'Image (Item), + Currency, Fill, Separator, Radix_Mark); + end Image; + + ------------ + -- Length -- + ------------ + + function Length + (Pic : Picture; + Currency : String := Default_Currency) return Natural + is + Picstr : constant String := Pic_String (Pic); + V_Adjust : Integer := 0; + Cur_Adjust : Integer := 0; + + begin + -- Check if Picstr has 'V' or '$' + + -- If 'V', then length is 1 less than otherwise + + -- If '$', then length is Currency'Length-1 more than otherwise + + -- This should use the string handling package ??? + + for J in Picstr'Range loop + if Picstr (J) = 'V' then + V_Adjust := -1; + + elsif Picstr (J) = '$' then + Cur_Adjust := Currency'Length - 1; + end if; + end loop; + + return Picstr'Length - V_Adjust + Cur_Adjust; + end Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : Text_IO.File_Type; + Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark) + is + begin + Text_IO.Put (File, Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark) + is + begin + Text_IO.Put (Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (To : out String; + Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark) + is + Result : constant String := + Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); + + begin + if Result'Length > To'Length then + raise Ada.Text_IO.Layout_Error; + else + Strings_Fixed.Move (Source => Result, Target => To, + Justify => Strings.Right); + end if; + end Put; + + ----------- + -- Valid -- + ----------- + + function Valid + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency) return Boolean + is + begin + declare + Temp : constant String := Image (Item, Pic, Currency); + pragma Warnings (Off, Temp); + begin + return True; + end; + + exception + when Ada.Text_IO.Layout_Error => return False; + + end Valid; + end Decimal_Output; + +end Ada.Text_IO.Editing; diff --git a/gcc/ada/libgnat/a-teioed.ads b/gcc/ada/libgnat/a-teioed.ads new file mode 100644 index 0000000..d22015f --- /dev/null +++ b/gcc/ada/libgnat/a-teioed.ads @@ -0,0 +1,194 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E D I T I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Text_IO.Editing is + + type Picture is private; + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean; + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture; + + function Pic_String (Pic : Picture) return String; + function Blank_When_Zero (Pic : Picture) return Boolean; + + Max_Picture_Length : constant := 64; + + Picture_Error : exception; + + Default_Currency : constant String := "$"; + Default_Fill : constant Character := '*'; + Default_Separator : constant Character := ','; + Default_Radix_Mark : constant Character := '.'; + + generic + type Num is delta <> digits <>; + Default_Currency : String := Editing.Default_Currency; + Default_Fill : Character := Editing.Default_Fill; + Default_Separator : Character := Editing.Default_Separator; + Default_Radix_Mark : Character := Editing.Default_Radix_Mark; + + package Decimal_Output is + + function Length + (Pic : Picture; + Currency : String := Default_Currency) return Natural; + + function Valid + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency) return Boolean; + + function Image + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark) return String; + + procedure Put + (File : Ada.Text_IO.File_Type; + Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark); + + procedure Put + (Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark); + + procedure Put + (To : out String; + Item : Num; + Pic : Picture; + Currency : String := Default_Currency; + Fill : Character := Default_Fill; + Separator : Character := Default_Separator; + Radix_Mark : Character := Default_Radix_Mark); + + end Decimal_Output; + +private + + MAX_PICSIZE : constant := 50; + MAX_MONEYSIZE : constant := 10; + Invalid_Position : constant := -1; + + subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; + + type Picture_Record (Length : Pic_Index := 0) is record + Expanded : String (1 .. Length); + end record; + + type Format_Record is record + Picture : Picture_Record; + -- Read only + + Blank_When_Zero : Boolean; + -- Read/write + + Original_BWZ : Boolean; + + -- The following components get written + + Star_Fill : Boolean := False; + + Radix_Position : Integer := Invalid_Position; + + Sign_Position, + Second_Sign : Integer := Invalid_Position; + + Start_Float, + End_Float : Integer := Invalid_Position; + + Start_Currency, + End_Currency : Integer := Invalid_Position; + + Max_Leading_Digits : Integer := 0; + + Max_Trailing_Digits : Integer := 0; + + Max_Currency_Digits : Integer := 0; + + Floater : Character := '!'; + -- Initialized to illegal value + + end record; + + type Picture is record + Contents : Format_Record; + end record; + + type Number_Attributes is record + Negative : Boolean := False; + + Has_Fraction : Boolean := False; + + Start_Of_Int, + End_Of_Int, + Start_Of_Fraction, + End_Of_Fraction : Integer := Invalid_Position; -- invalid value + end record; + + function Parse_Number_String (Str : String) return Number_Attributes; + -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no + -- trailing blanks...) + + procedure Precalculate (Pic : in out Format_Record); + -- Precalculates fields from the user supplied data + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : String; + Fill_Character : Character; + Separator_Character : Character; + Radix_Point : Character) return String; + -- Formats number according to Pic + + function Expand (Picture : String) return String; + +end Ada.Text_IO.Editing; diff --git a/gcc/ada/libgnat/a-textio.adb b/gcc/ada/libgnat/a-textio.adb new file mode 100644 index 0000000..0f842a0 --- /dev/null +++ b/gcc/ada/libgnat/a-textio.adb @@ -0,0 +1,2182 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.File_IO; +with System.CRTL; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +pragma Elaborate_All (System.File_IO); +-- Needed because of calls to Chain_File in package body elaboration + +package body Ada.Text_IO is + + package FIO renames System.File_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + + use type System.CRTL.size_t; + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist. + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Upper_Half_Char + (C : Character; + File : File_Type) return Character; + -- This function is shared by Get and Get_Immediate to extract an encoded + -- upper half character value from the given File. The first byte has + -- already been read and is passed in C. The character value is returned as + -- the result, and the file pointer is bumped past the character. + -- Constraint_Error is raised if the encoded value is outside the bounds of + -- type Character. + + function Get_Upper_Half_Char_Immed + (C : Character; + File : File_Type) return Character; + -- This routine is identical to Get_Upper_Half_Char, except that the reads + -- are done in Get_Immediate mode (i.e. without waiting for a line return). + + function Getc (File : File_Type) return int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + function Has_Upper_Half_Character (Item : String) return Boolean; + -- Returns True if any of the characters is in the range 16#80#-16#FF# + + function Nextc (File : File_Type) return int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). + + procedure Put_Encoded (File : File_Type; Char : Character); + -- Called to output a character Char to the given File, when the encoding + -- method for the file is other than brackets, and Char is upper half. + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + + procedure Set_WCEM (File : in out File_Type); + -- Called by Open and Create to set the wide character encoding method for + -- the file, processing a WCEM form parameter if one is present. File is + -- IN OUT because it may be closed in case of an error. + + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr is + pragma Unreferenced (Control_Block); + begin + return new Text_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + procedure AFCB_Close (File : not null access Text_AFCB) is + begin + -- If the file being closed is one of the current files, then close + -- the corresponding current file. It is not clear that this action + -- is required (RM A.10.3(23)) but it seems reasonable, and besides + -- ACVC test CE3208A expects this behavior. + + if File_Type (File) = Current_In then + Current_In := null; + elsif File_Type (File) = Current_Out then + Current_Out := null; + elsif File_Type (File) = Current_Err then + Current_Err := null; + end if; + + Terminate_Line (File_Type (File)); + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Text_AFCB) is + type FCB_Ptr is access all Text_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new Ada.Unchecked_Deallocation (Text_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + --------- + -- Col -- + --------- + + -- Note: we assume that it is impossible in practice for the column + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Col (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Col; + end Col; + + function Col return Positive_Count is + begin + return Col (Current_Out); + end Col; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'T', + Creat => True, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Create; + + ------------------- + -- Current_Error -- + ------------------- + + function Current_Error return File_Type is + begin + return Current_Err; + end Current_Error; + + function Current_Error return File_Access is + begin + return Current_Err.Self'Access; + end Current_Error; + + ------------------- + -- Current_Input -- + ------------------- + + function Current_Input return File_Type is + begin + return Current_In; + end Current_Input; + + function Current_Input return File_Access is + begin + return Current_In.Self'Access; + end Current_Input; + + -------------------- + -- Current_Output -- + -------------------- + + function Current_Output return File_Type is + begin + return Current_Out; + end Current_Output; + + function Current_Output return File_Access is + begin + return Current_Out.Self'Access; + end Current_Output; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return Nextc (File) = EOF; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch = PM and then File.Is_Regular_File then + File.Before_LM_PM := True; + return Nextc (File) = EOF; + + -- Here if neither EOF nor PM followed end of line + + else + Ungetc (ch, File); + return False; + end if; + + end End_Of_File; + + function End_Of_File return Boolean is + begin + return End_Of_File (Current_In); + end End_Of_File; + + ----------------- + -- End_Of_Line -- + ----------------- + + function End_Of_Line (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + return False; + + elsif File.Before_LM then + return True; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + else + Ungetc (ch, File); + return (ch = LM); + end if; + end if; + end End_Of_Line; + + function End_Of_Line return Boolean is + begin + return End_Of_Line (Current_In); + end End_Of_Line; + + ----------------- + -- End_Of_Page -- + ----------------- + + function End_Of_Page (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if not File.Is_Regular_File then + return False; + + elsif File.Before_Upper_Half_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return True; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Nextc (File); + + return ch = PM or else ch = EOF; + end End_Of_Page; + + function End_Of_Page return Boolean is + begin + return End_Of_Page (Current_In); + end End_Of_Page; + + -------------- + -- EOF_Char -- + -------------- + + function EOF_Char return Integer is + begin + return EOF; + end EOF_Char; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + procedure Flush is + begin + Flush (Current_Out); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + File.Before_Upper_Half_Character := False; + Item := File.Saved_Upper_Half_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + else + File.Line := File.Line + 1; + end if; + end if; + + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item := Character'Val (ch); + File.Col := File.Col + 1; + return; + end if; + end loop; + end Get; + + procedure Get (Item : out Character) is + begin + Get (Current_In, Item); + end Get; + + procedure Get + (File : File_Type; + Item : out String) + is + ch : int; + J : Natural; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + + else + File.Line := File.Line + 1; + end if; + end if; + + J := Item'First; + while J <= Item'Last loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item (J) := Character'Val (ch); + J := J + 1; + File.Col := File.Col + 1; + end if; + end loop; + end Get; + + procedure Get (Item : out String) is + begin + Get (Current_In, Item); + end Get; + + ------------------- + -- Get_Immediate -- + ------------------- + + procedure Get_Immediate + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Upper_Half_Character then + File.Before_Upper_Half_Character := False; + Item := File.Saved_Upper_Half_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := + (if not Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method) + then Character'Val (ch) + else Get_Upper_Half_Char_Immed (Character'Val (ch), File)); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Character) + is + begin + Get_Immediate (Current_In, Item); + end Get_Immediate; + + procedure Get_Immediate + (File : File_Type; + Item : out Character; + Available : out Boolean) + is + ch : int; + end_of_file : int; + avail : int; + + procedure getc_immediate_nowait + (stream : FILEs; + ch : out int; + end_of_file : out int; + avail : out int); + pragma Import (C, getc_immediate_nowait, "getc_immediate_nowait"); + + begin + FIO.Check_Read_Status (AP (File)); + Available := True; + + if File.Before_Upper_Half_Character then + File.Before_Upper_Half_Character := False; + Item := File.Saved_Upper_Half_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Character'Val (LM); + + else + getc_immediate_nowait (File.Stream, ch, end_of_file, avail); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + + elsif end_of_file /= 0 then + raise End_Error; + + elsif avail = 0 then + Available := False; + Item := ASCII.NUL; + + else + Available := True; + + Item := + (if not Is_Start_Of_Encoding (Character'Val (ch), File.WC_Method) + then Character'Val (ch) + else Get_Upper_Half_Char_Immed (Character'Val (ch), File)); + end if; + end if; + + end Get_Immediate; + + procedure Get_Immediate + (Item : out Character; + Available : out Boolean) + is + begin + Get_Immediate (Current_In, Item, Available); + end Get_Immediate; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out String; + Last : out Natural) is separate; + -- The implementation of Ada.Text_IO.Get_Line is split into a subunit so + -- that different implementations can be used on different systems. + + procedure Get_Line + (Item : out String; + Last : out Natural) + is + begin + Get_Line (Current_In, Item, Last); + end Get_Line; + + function Get_Line (File : File_Type) return String is + function Get_Rest (S : String) return String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : String) return String is + + -- The first time we allocate a buffer of size 500. Each following + -- time we allocate a buffer the same size as what we have read so + -- far. This limits us to a logarithmic number of calls to Get_Rest + -- and also ensures only a linear use of stack space. + + Buffer : String (1 .. Integer'Max (500, S'Length)); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + + else + pragma Assert (Last = Buffer'Last); + + -- If the String has the same length as the buffer, and there + -- is no end of line, check whether we are at the end of file, + -- in which case we have the full String in the buffer. + + if End_Of_File (File) then + return R; + + else + return Get_Rest (R); + end if; + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + return Get_Rest (""); + end Get_Line; + + function Get_Line return String is + begin + return Get_Line (Current_In); + end Get_Line; + + ------------------------- + -- Get_Upper_Half_Char -- + ------------------------- + + function Get_Upper_Half_Char + (C : Character; + File : File_Type) return Character + is + Result : Wide_Character; + + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Upper_Half_Char + + begin + Result := WC_In (C, File.WC_Method); + + if Wide_Character'Pos (Result) > 16#FF# then + raise Constraint_Error with + "invalid wide character in Text_'I'O input"; + else + return Character'Val (Wide_Character'Pos (Result)); + end if; + end Get_Upper_Half_Char; + + ------------------------------- + -- Get_Upper_Half_Char_Immed -- + ------------------------------- + + function Get_Upper_Half_Char_Immed + (C : Character; + File : File_Type) return Character + is + Result : Wide_Character; + + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc_Immed (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Upper_Half_Char_Immed + + begin + Result := WC_In (C, File.WC_Method); + + if Wide_Character'Pos (Result) > 16#FF# then + raise Constraint_Error with + "invalid wide character in Text_'I'O input"; + else + return Character'Val (Wide_Character'Pos (Result)); + end if; + end Get_Upper_Half_Char_Immed; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + ---------------- + -- Getc_Immed -- + ---------------- + + function Getc_Immed (File : File_Type) return int is + ch : int; + end_of_file : int; + + procedure getc_immediate + (stream : FILEs; ch : out int; end_of_file : out int); + pragma Import (C, getc_immediate, "getc_immediate"); + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := LM; + + else + getc_immediate (File.Stream, ch, end_of_file); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + elsif end_of_file /= 0 then + return EOF; + end if; + end if; + + return ch; + end Getc_Immed; + + ------------------------------ + -- Has_Upper_Half_Character -- + ------------------------------ + + function Has_Upper_Half_Character (Item : String) return Boolean is + begin + for J in Item'Range loop + if Character'Pos (Item (J)) >= 16#80# then + return True; + end if; + end loop; + + return False; + end Has_Upper_Half_Character; + + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Text_Encoding := Default_Text; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Text_Encoding := Default_Text; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Text_Encoding := Default_Text; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Line -- + ---------- + + -- Note: we assume that it is impossible in practice for the line + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Line (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Line; + end Line; + + function Line return Positive_Count is + begin + return Line (Current_Out); + end Line; + + ----------------- + -- Line_Length -- + ----------------- + + function Line_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Line_Length; + end Line_Length; + + function Line_Length return Count is + begin + return Line_Length (Current_Out); + end Line_Length; + + ---------------- + -- Look_Ahead -- + ---------------- + + procedure Look_Ahead + (File : File_Type; + Item : out Character; + End_Of_Line : out Boolean) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are logically before a line mark, we can return immediately + + if File.Before_LM then + End_Of_Line := True; + Item := ASCII.NUL; + + -- If we are before an upper half character just return it (this can + -- happen if there are two calls to Look_Ahead in a row). + + elsif File.Before_Upper_Half_Character then + End_Of_Line := False; + Item := File.Saved_Upper_Half_Character; + + -- Otherwise we must read a character from the input stream + + else + ch := Getc (File); + + if ch = LM + or else ch = EOF + or else (ch = PM and then File.Is_Regular_File) + then + End_Of_Line := True; + Ungetc (ch, File); + Item := ASCII.NUL; + + -- Case where character obtained does not represent the start of an + -- encoded sequence so it stands for itself and we can unget it with + -- no difficulty. + + elsif not Is_Start_Of_Encoding + (Character'Val (ch), File.WC_Method) + then + End_Of_Line := False; + Ungetc (ch, File); + Item := Character'Val (ch); + + -- For the start of an encoding, we read the character using the + -- Get_Upper_Half_Char routine. It will occupy more than one byte + -- so we can't put it back with ungetc. Instead we save it in the + -- control block, setting a flag that everyone interested in reading + -- characters must test before reading the stream. + + else + Item := Get_Upper_Half_Char (Character'Val (ch), File); + End_Of_Line := False; + File.Saved_Upper_Half_Character := Item; + File.Before_Upper_Half_Character := True; + end if; + end if; + end Look_Ahead; + + procedure Look_Ahead + (Item : out Character; + End_Of_Line : out Boolean) + is + begin + Look_Ahead (Current_In, Item, End_Of_Line); + end Look_Ahead; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_TIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + + for K in 1 .. Spacing loop + Putc (LM, File); + File.Line := File.Line + 1; + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Putc (PM, File); + File.Line := 1; + File.Page := File.Page + 1; + end if; + end loop; + + File.Col := 1; + end New_Line; + + procedure New_Line (Spacing : Positive_Count := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + -------------- + -- New_Page -- + -------------- + + procedure New_Page (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Col /= 1 or else File.Line = 1 then + Putc (LM, File); + end if; + + Putc (PM, File); + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + end New_Page; + + procedure New_Page is + begin + New_Page (Current_Out); + end New_Page; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + + else + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + + return ch; + end Nextc; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'T', + Creat => False, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Open; + + ---------- + -- Page -- + ---------- + + -- Note: we assume that it is impossible in practice for the page + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Page (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Page; + end Page; + + function Page return Positive_Count is + begin + return Page (Current_Out); + end Page; + + ----------------- + -- Page_Length -- + ----------------- + + function Page_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Page_Length; + end Page_Length; + + function Page_Length return Count is + begin + return Page_Length (Current_Out); + end Page_Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Character) + is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Line_Length /= 0 and then File.Col > File.Line_Length then + New_Line (File); + end if; + + -- If lower half character, or brackets encoding, output directly + + if Character'Pos (Item) < 16#80# + or else File.WC_Method = WCEM_Brackets + then + if fputc (Character'Pos (Item), File.Stream) = EOF then + raise Device_Error; + end if; + + -- Case of upper half character with non-brackets encoding + + else + Put_Encoded (File, Item); + end if; + + File.Col := File.Col + 1; + end Put; + + procedure Put (Item : Character) is + begin + Put (Current_Out, Item); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : String) + is + begin + FIO.Check_Write_Status (AP (File)); + + -- Only have something to do if string is non-null + + if Item'Length > 0 then + + -- If we have bounded lines, or if the file encoding is other than + -- Brackets and the string has at least one upper half character, + -- then output the string character by character. + + if File.Line_Length /= 0 + or else (File.WC_Method /= WCEM_Brackets + and then Has_Upper_Half_Character (Item)) + then + for J in Item'Range loop + Put (File, Item (J)); + end loop; + + -- Otherwise we can output the entire string at once. Note that if + -- there are LF or FF characters in the string, we do not bother to + -- count them as line or page terminators. + + else + FIO.Write_Buf (AP (File), Item'Address, Item'Length); + File.Col := File.Col + Item'Length; + end if; + end if; + end Put; + + procedure Put (Item : String) is + begin + Put (Current_Out, Item); + end Put; + + ----------------- + -- Put_Encoded -- + ----------------- + + procedure Put_Encoded (File : File_Type; Char : Character) is + procedure Out_Char (C : Character); + -- Procedure to output one character of an upper half encoded sequence + + procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + Putc (Character'Pos (C), File); + end Out_Char; + + -- Start of processing for Put_Encoded + + begin + WC_Out (Wide_Character'Val (Character'Pos (Char)), File.WC_Method); + end Put_Encoded; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : String) + is + Ilen : Natural := Item'Length; + Istart : Natural := Item'First; + + begin + FIO.Check_Write_Status (AP (File)); + + -- If we have bounded lines, or if the file encoding is other than + -- Brackets and the string has at least one upper half character, then + -- output the string character by character. + + if File.Line_Length /= 0 + or else (File.WC_Method /= WCEM_Brackets + and then Has_Upper_Half_Character (Item)) + then + for J in Item'Range loop + Put (File, Item (J)); + end loop; + + New_Line (File); + return; + end if; + + -- Normal case where we do not need to output character by character + + -- We setup a single string that has the necessary terminators and + -- then write it with a single call. The reason for doing this is + -- that it gives better behavior for the use of Put_Line in multi- + -- tasking programs, since often the OS will treat the entire put + -- operation as an atomic operation. + + -- We only do this if the message is 512 characters or less in length, + -- since otherwise Put_Line would use an unbounded amount of stack + -- space and could cause undetected stack overflow. If we have a + -- longer string, then output the first part separately to avoid this. + + if Ilen > 512 then + FIO.Write_Buf (AP (File), Item'Address, size_t (Ilen - 512)); + Istart := Istart + Ilen - 512; + Ilen := 512; + end if; + + -- Now prepare the string with its terminator + + declare + Buffer : String (1 .. Ilen + 2); + Plen : size_t; + + begin + Buffer (1 .. Ilen) := Item (Istart .. Item'Last); + Buffer (Ilen + 1) := Character'Val (LM); + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Buffer (Ilen + 2) := Character'Val (PM); + Plen := size_t (Ilen) + 2; + File.Line := 1; + File.Page := File.Page + 1; + + else + Plen := size_t (Ilen) + 1; + File.Line := File.Line + 1; + end if; + + FIO.Write_Buf (AP (File), Buffer'Address, Plen); + + File.Col := 1; + end; + end Put_Line; + + procedure Put_Line (Item : String) is + begin + Put_Line (Current_Out, Item); + end Put_Line; + + ---------- + -- Putc -- + ---------- + + procedure Putc (ch : int; File : File_Type) is + begin + if fputc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end Putc; + + ---------- + -- Read -- + ---------- + + -- This is the primitive Stream Read routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Read + (File : in out Text_AFCB; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Discard_ch : int; + pragma Warnings (Off, Discard_ch); + + begin + -- Need to deal with Before_Upper_Half_Character ??? + + if File.Mode /= FCB.In_File then + raise Mode_Error; + end if; + + -- Deal with case where our logical and physical position do not match + -- because of being after an LM or LM-PM sequence when in fact we are + -- logically positioned before it. + + if File.Before_LM then + + -- If we are before a PM, then it is possible for a stream read + -- to leave us after the LM and before the PM, which is a bit + -- odd. The easiest way to deal with this is to unget the PM, + -- so we are indeed positioned between the characters. This way + -- further stream read operations will work correctly, and the + -- effect on text processing is a little weird, but what can + -- be expected if stream and text input are mixed this way? + + if File.Before_LM_PM then + Discard_ch := ungetc (PM, File.Stream); + File.Before_LM_PM := False; + end if; + + File.Before_LM := False; + + Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); + + if Item'Length = 1 then + Last := Item'Last; + + else + Last := + Item'First + + Stream_Element_Offset + (fread (buffer => Item'Address, + index => size_t (Item'First + 1), + size => 1, + count => Item'Length - 1, + stream => File.Stream)); + end if; + + return; + end if; + + -- Now we do the read. Since this is a text file, it is normally in + -- text mode, but stream data must be read in binary mode, so we + -- temporarily set binary mode for the read, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + Last := + Item'First + + Stream_Element_Offset + (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; + + if Last < Item'Last then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end if; + + set_text_mode (fileno (File.Stream)); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset + (File : in out File_Type; + Mode : File_Mode) + is + begin + -- Don't allow change of mode for current file (RM A.10.2(5)) + + if (File = Current_In or else + File = Current_Out or else + File = Current_Error) + and then To_FCB (Mode) /= File.Mode + then + raise Mode_Error; + end if; + + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + ------------- + -- Set_Col -- + ------------- + + procedure Set_Col + (File : File_Type; + To : Positive_Count) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + -- Output case + + if Mode (File) >= Out_File then + + -- Error if we attempt to set Col to a value greater than the + -- maximum permissible line length. + + if File.Line_Length /= 0 and then To > File.Line_Length then + raise Layout_Error; + end if; + + -- If we are behind current position, then go to start of new line + + if To < File.Col then + New_Line (File); + end if; + + -- Loop to output blanks till we are at the required column + + while File.Col < To loop + Put (File, ' '); + end loop; + + -- Input case + + else + -- If we are logically before a LM, but physically after it, the + -- file position still reflects the position before the LM, so eat + -- it now and adjust the file position appropriately. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Line := File.Line + 1; + File.Col := 1; + end if; + + -- Loop reading characters till we get one at the required Col value + + loop + -- Read next character. The reason we have to read ahead is to + -- skip formatting characters, the effect of Set_Col is to set + -- us to a real character with the right Col value, and format + -- characters don't count. + + ch := Getc (File); + + -- Error if we hit an end of file + + if ch = EOF then + raise End_Error; + + -- If line mark, eat it and adjust file position + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + -- If recognized page mark, eat it, and adjust file position + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + + -- Otherwise this is the character we are looking for, so put it + -- back in the input stream (we have not adjusted the file + -- position yet, so everything is set right after this ungetc). + + elsif To = File.Col then + Ungetc (ch, File); + return; + + -- Keep skipping characters if we are not there yet, updating the + -- file position past the skipped character. + + else + File.Col := File.Col + 1; + end if; + end loop; + end if; + end Set_Col; + + procedure Set_Col (To : Positive_Count) is + begin + Set_Col (Current_Out, To); + end Set_Col; + + --------------- + -- Set_Error -- + --------------- + + procedure Set_Error (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Err := File; + end Set_Error; + + --------------- + -- Set_Input -- + --------------- + + procedure Set_Input (File : File_Type) is + begin + FIO.Check_Read_Status (AP (File)); + Current_In := File; + end Set_Input; + + -------------- + -- Set_Line -- + -------------- + + procedure Set_Line + (File : File_Type; + To : Positive_Count) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Line then + return; + end if; + + if Mode (File) >= Out_File then + if File.Page_Length /= 0 and then To > File.Page_Length then + raise Layout_Error; + end if; + + if To < File.Line then + New_Page (File); + end if; + + while File.Line < To loop + New_Line (File); + end loop; + + else + while To /= File.Line loop + Skip_Line (File); + end loop; + end if; + end Set_Line; + + procedure Set_Line (To : Positive_Count) is + begin + Set_Line (Current_Out, To); + end Set_Line; + + --------------------- + -- Set_Line_Length -- + --------------------- + + procedure Set_Line_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Line_Length := To; + end Set_Line_Length; + + procedure Set_Line_Length (To : Count) is + begin + Set_Line_Length (Current_Out, To); + end Set_Line_Length; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Out := File; + end Set_Output; + + --------------------- + -- Set_Page_Length -- + --------------------- + + procedure Set_Page_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Page_Length := To; + end Set_Page_Length; + + procedure Set_Page_Length (To : Count) is + begin + Set_Page_Length (Current_Out, To); + end Set_Page_Length; + + -------------- + -- Set_WCEM -- + -------------- + + procedure Set_WCEM (File : in out File_Type) is + Start : Natural; + Stop : Natural; + + begin + FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); + + if Start = 0 then + File.WC_Method := Default_WCEM; + + else + if Stop = Start then + for J in WC_Encoding_Letters'Range loop + if File.Form (Start) = WC_Encoding_Letters (J) then + File.WC_Method := J; + return; + end if; + end loop; + end if; + + Close (File); + raise Use_Error with "invalid WCEM form parameter"; + end if; + end Set_WCEM; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Read_Status (AP (File)); + + for L in 1 .. Spacing loop + if File.Before_LM then + File.Before_LM := False; + + -- Note that if File.Before_LM_PM is currently set, we also have + -- to reset it (because it makes sense for Before_LM_PM to be set + -- only when Before_LM is also set). This is done later on in this + -- subprogram, as soon as Before_LM_PM has been taken into account + -- for the purpose of page and line counts. + + else + ch := Getc (File); + + -- If at end of file now, then immediately raise End_Error. Note + -- that we can never be positioned between a line mark and a page + -- mark, so if we are at the end of file, we cannot logically be + -- before the implicit page mark that is at the end of the file. + + -- For the same reason, we do not need an explicit check for a + -- page mark. If there is a FF in the middle of a line, the file + -- is not in canonical format and we do not care about the page + -- numbers for files other than ones in canonical format. + + if ch = EOF then + raise End_Error; + end if; + + -- If not at end of file, then loop till we get to an LM or EOF. + -- The latter case happens only in non-canonical files where the + -- last line is not terminated by LM, but we don't want to blow + -- up for such files, so we assume an implicit LM in this case. + + loop + exit when ch = LM or else ch = EOF; + ch := Getc (File); + end loop; + end if; + + -- We have got past a line mark, now, for a regular file only, + -- see if a page mark immediately follows this line mark and + -- if so, skip past the page mark as well. We do not do this + -- for non-regular files, since it would cause an undesirable + -- wait for an additional character. + + File.Col := 1; + File.Line := File.Line + 1; + + if File.Before_LM_PM then + File.Page := File.Page + 1; + File.Line := 1; + File.Before_LM_PM := False; + + elsif File.Is_Regular_File then + ch := Getc (File); + + -- Page mark can be explicit, or implied at the end of the file + + if (ch = PM or else ch = EOF) + and then File.Is_Regular_File + then + File.Page := File.Page + 1; + File.Line := 1; + else + Ungetc (ch, File); + end if; + end if; + end loop; + + File.Before_Upper_Half_Character := False; + end Skip_Line; + + procedure Skip_Line (Spacing : Positive_Count := 1) is + begin + Skip_Line (Current_In, Spacing); + end Skip_Line; + + --------------- + -- Skip_Page -- + --------------- + + procedure Skip_Page (File : File_Type) is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If at page mark already, just skip it + + if File.Before_LM_PM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + return; + end if; + + -- This is a bit tricky, if we are logically before an LM then + -- it is not an error if we are at an end of file now, since we + -- are not really at it. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := Getc (File); + + -- Otherwise we do raise End_Error if we are at the end of file now + + else + ch := Getc (File); + + if ch = EOF then + raise End_Error; + end if; + end if; + + -- Now we can just rumble along to the next page mark, or to the + -- end of file, if that comes first. The latter case happens when + -- the page mark is implied at the end of file. + + loop + exit when ch = EOF + or else (ch = PM and then File.Is_Regular_File); + ch := Getc (File); + end loop; + + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + File.Before_Upper_Half_Character := False; + end Skip_Page; + + procedure Skip_Page is + begin + Skip_Page (Current_In); + end Skip_Page; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Standard_Err; + end Standard_Error; + + function Standard_Error return File_Access is + begin + return Standard_Err'Access; + end Standard_Error; + + -------------------- + -- Standard_Input -- + -------------------- + + function Standard_Input return File_Type is + begin + return Standard_In; + end Standard_Input; + + function Standard_Input return File_Access is + begin + return Standard_In'Access; + end Standard_Input; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Standard_Out; + end Standard_Output; + + function Standard_Output return File_Access is + begin + return Standard_Out'Access; + end Standard_Output; + + -------------------- + -- Terminate_Line -- + -------------------- + + procedure Terminate_Line (File : File_Type) is + begin + FIO.Check_File_Open (AP (File)); + + -- For file other than In_File, test for needing to terminate last line + + if Mode (File) /= In_File then + + -- If not at start of line definition need new line + + if File.Col /= 1 then + New_Line (File); + + -- For files other than standard error and standard output, we + -- make sure that an empty file has a single line feed, so that + -- it is properly formatted. We avoid this for the standard files + -- because it is too much of a nuisance to have these odd line + -- feeds when nothing has been written to the file. + + -- We also avoid this for files opened in append mode, in + -- accordance with (RM A.8.2(10)) + + elsif (File /= Standard_Err and then File /= Standard_Out) + and then (File.Line = 1 and then File.Page = 1) + and then Mode (File) = Out_File + then + New_Line (File); + end if; + end if; + end Terminate_Line; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + + ----------- + -- Write -- + ----------- + + -- This is the primitive Stream Write routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Write + (File : in out Text_AFCB; + Item : Stream_Element_Array) + is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + + function Has_Translated_Characters return Boolean; + -- return True if Item array contains a character which will be + -- translated under the text file mode. There is only one such + -- character under DOS based systems which is character 10. + + text_translation_required : Boolean; + for text_translation_required'Size use Character'Size; + pragma Import (C, text_translation_required, + "__gnat_text_translation_required"); + + Siz : constant size_t := Item'Length; + + ------------------------------- + -- Has_Translated_Characters -- + ------------------------------- + + function Has_Translated_Characters return Boolean is + begin + for K in Item'Range loop + if Item (K) = 10 then + return True; + end if; + end loop; + return False; + end Has_Translated_Characters; + + Needs_Binary_Write : constant Boolean := + text_translation_required and then Has_Translated_Characters; + + -- Start of processing for Write + + begin + if File.Mode = FCB.In_File then + raise Mode_Error; + end if; + + -- Now we do the write. Since this is a text file, it is normally in + -- text mode, but stream data must be written in binary mode, so we + -- temporarily set binary mode for the write, resetting it after. This + -- is done only if needed (i.e. there is some characters in Item which + -- needs to be written using the binary mode). + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + -- Since the character translation is done at the time the buffer is + -- written (this is true under Windows) we first flush current buffer + -- with text mode if needed. + + if Needs_Binary_Write then + if fflush (File.Stream) = -1 then + raise Device_Error; + end if; + + set_binary_mode (fileno (File.Stream)); + end if; + + if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then + raise Device_Error; + end if; + + -- At this point we need to flush the buffer using the binary mode then + -- we reset to text mode. + + if Needs_Binary_Write then + if fflush (File.Stream) = -1 then + raise Device_Error; + end if; + + set_text_mode (fileno (File.Stream)); + end if; + end Write; + +begin + -- Initialize Standard Files + + for J in WC_Encoding_Method loop + if WC_Encoding = WC_Encoding_Letters (J) then + Default_WCEM := J; + end if; + end loop; + + Initialize_Standard_Files; + + FIO.Chain_File (AP (Standard_In)); + FIO.Chain_File (AP (Standard_Out)); + FIO.Chain_File (AP (Standard_Err)); + +end Ada.Text_IO; diff --git a/gcc/ada/libgnat/a-textio.ads b/gcc/ada/libgnat/a-textio.ads new file mode 100644 index 0000000..5c85892 --- /dev/null +++ b/gcc/ada/libgnat/a-textio.ads @@ -0,0 +1,471 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the generic subpackages of Text_IO (Integer_IO, Float_IO, Fixed_IO, +-- Modular_IO, Decimal_IO and Enumeration_IO) appear as private children in +-- GNAT. These children are with'ed automatically if they are referenced, so +-- this rearrangement is invisible to user programs, but has the advantage +-- that only the needed parts of Text_IO are processed and loaded. + +with Ada.IO_Exceptions; +with Ada.Streams; + +with System; +with System.File_Control_Block; +with System.WCh_Con; + +package Ada.Text_IO is + pragma Elaborate_Body; + + type File_Type is limited private; + type File_Mode is (In_File, Out_File, Append_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) + Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) + Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) + + type Count is range 0 .. Natural'Last; + -- The value of Count'Last must be large enough so that the assumption that + -- the Line, Column and Page counts can never exceed this value is valid. + + subtype Positive_Count is Count range 1 .. Count'Last; + + Unbounded : constant Count := 0; + -- Line and page length + + subtype Field is Integer range 0 .. 255; + -- Note: if for any reason, there is a need to increase this value, then it + -- will be necessary to change the corresponding value in System.Img_Real + -- in file s-imgrea.adb. + + subtype Number_Base is Integer range 2 .. 16; + + type Type_Set is (Lower_Case, Upper_Case); + + --------------------- + -- File Management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : File_Type) return File_Mode; + function Name (File : File_Type) return String; + function Form (File : File_Type) return String; + + function Is_Open (File : File_Type) return Boolean; + + ------------------------------------------------------ + -- Control of default input, output and error files -- + ------------------------------------------------------ + + procedure Set_Input (File : File_Type); + procedure Set_Output (File : File_Type); + procedure Set_Error (File : File_Type); + + function Standard_Input return File_Type; + function Standard_Output return File_Type; + function Standard_Error return File_Type; + + function Current_Input return File_Type; + function Current_Output return File_Type; + function Current_Error return File_Type; + + type File_Access is access constant File_Type; + + function Standard_Input return File_Access; + function Standard_Output return File_Access; + function Standard_Error return File_Access; + + function Current_Input return File_Access; + function Current_Output return File_Access; + function Current_Error return File_Access; + + -------------------- + -- Buffer control -- + -------------------- + + -- Note: The parameter file is IN OUT in the RM, but this is clearly + -- an oversight, and was intended to be IN, see AI95-00057. + + procedure Flush (File : File_Type); + procedure Flush; + + -------------------------------------------- + -- Specification of line and page lengths -- + -------------------------------------------- + + procedure Set_Line_Length (File : File_Type; To : Count); + procedure Set_Line_Length (To : Count); + + procedure Set_Page_Length (File : File_Type; To : Count); + procedure Set_Page_Length (To : Count); + + function Line_Length (File : File_Type) return Count; + function Line_Length return Count; + + function Page_Length (File : File_Type) return Count; + function Page_Length return Count; + + ------------------------------------ + -- Column, Line, and Page Control -- + ------------------------------------ + + procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure New_Line (Spacing : Positive_Count := 1); + + procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure Skip_Line (Spacing : Positive_Count := 1); + + function End_Of_Line (File : File_Type) return Boolean; + function End_Of_Line return Boolean; + + procedure New_Page (File : File_Type); + procedure New_Page; + + procedure Skip_Page (File : File_Type); + procedure Skip_Page; + + function End_Of_Page (File : File_Type) return Boolean; + function End_Of_Page return Boolean; + + function End_Of_File (File : File_Type) return Boolean; + function End_Of_File return Boolean; + + procedure Set_Col (File : File_Type; To : Positive_Count); + procedure Set_Col (To : Positive_Count); + + procedure Set_Line (File : File_Type; To : Positive_Count); + procedure Set_Line (To : Positive_Count); + + function Col (File : File_Type) return Positive_Count; + function Col return Positive_Count; + + function Line (File : File_Type) return Positive_Count; + function Line return Positive_Count; + + function Page (File : File_Type) return Positive_Count; + function Page return Positive_Count; + + ---------------------------- + -- Character Input-Output -- + ---------------------------- + + procedure Get (File : File_Type; Item : out Character); + procedure Get (Item : out Character); + procedure Put (File : File_Type; Item : Character); + procedure Put (Item : Character); + + procedure Look_Ahead + (File : File_Type; + Item : out Character; + End_Of_Line : out Boolean); + + procedure Look_Ahead + (Item : out Character; + End_Of_Line : out Boolean); + + procedure Get_Immediate + (File : File_Type; + Item : out Character); + + procedure Get_Immediate + (Item : out Character); + + procedure Get_Immediate + (File : File_Type; + Item : out Character; + Available : out Boolean); + + procedure Get_Immediate + (Item : out Character; + Available : out Boolean); + + ------------------------- + -- String Input-Output -- + ------------------------- + + procedure Get (File : File_Type; Item : out String); + procedure Get (Item : out String); + procedure Put (File : File_Type; Item : String); + procedure Put (Item : String); + + procedure Get_Line + (File : File_Type; + Item : out String; + Last : out Natural); + + procedure Get_Line + (Item : out String; + Last : out Natural); + + function Get_Line (File : File_Type) return String; + pragma Ada_05 (Get_Line); + + function Get_Line return String; + pragma Ada_05 (Get_Line); + + procedure Put_Line + (File : File_Type; + Item : String); + + procedure Put_Line + (Item : String); + + --------------------------------------- + -- Generic packages for Input-Output -- + --------------------------------------- + + -- The generic packages: + + -- Ada.Text_IO.Integer_IO + -- Ada.Text_IO.Modular_IO + -- Ada.Text_IO.Float_IO + -- Ada.Text_IO.Fixed_IO + -- Ada.Text_IO.Decimal_IO + -- Ada.Text_IO.Enumeration_IO + + -- are implemented as separate child packages in GNAT, so the + -- spec and body of these packages are to be found in separate + -- child units. This implementation detail is hidden from the + -- Ada programmer by special circuitry in the compiler that + -- treats these child packages as though they were nested in + -- Text_IO. The advantage of this special processing is that + -- the subsidiary routines needed if these generics are used + -- are not loaded when they are not used. + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + Layout_Error : exception renames IO_Exceptions.Layout_Error; + +private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + + ----------------------------------- + -- Handling of Format Characters -- + ----------------------------------- + + -- Line marks are represented by the single character ASCII.LF (16#0A#). + -- In DOS and similar systems, underlying file translation takes care + -- of translating this to and from the standard CR/LF sequences used in + -- these operating systems to mark the end of a line. On output there is + -- always a line mark at the end of the last line, but on input, this + -- line mark can be omitted, and is implied by the end of file. + + -- Page marks are represented by the single character ASCII.FF (16#0C#), + -- The page mark at the end of the file may be omitted, and is normally + -- omitted on output unless an explicit New_Page call is made before + -- closing the file. No page mark is added when a file is appended to, + -- so, in accordance with the permission in (RM A.10.2(4)), there may + -- or may not be a page mark separating preexisting text in the file + -- from the new text to be written. + + -- A file mark is marked by the physical end of file. In DOS translation + -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the + -- physical end of file, so in effect this character is recognized as + -- marking the end of file in DOS and similar systems. + + LM : constant := Character'Pos (ASCII.LF); + -- Used as line mark + + PM : constant := Character'Pos (ASCII.FF); + -- Used as page mark, except at end of file where it is implied + + -------------------------------- + -- Text_IO File Control Block -- + -------------------------------- + + Default_WCEM : System.WCh_Con.WC_Encoding_Method := + System.WCh_Con.WCEM_UTF8; + -- This gets modified during initialization (see body) using + -- the default value established in the call to Set_Globals. + + package FCB renames System.File_Control_Block; + + type Text_AFCB; + type File_Type is access all Text_AFCB; + + type Text_AFCB is new FCB.AFCB with record + Page : Count := 1; + Line : Count := 1; + Col : Count := 1; + Line_Length : Count := 0; + Page_Length : Count := 0; + + Self : aliased File_Type; + -- Set to point to the containing Text_AFCB block. This is used to + -- implement the Current_{Error,Input,Output} functions which return + -- a File_Access, the file access value returned is a pointer to + -- the Self field of the corresponding file. + + Before_LM : Boolean := False; + -- This flag is used to deal with the anomalies introduced by the + -- peculiar definition of End_Of_File and End_Of_Page in Ada. These + -- functions require looking ahead more than one character. Since + -- there is no convenient way of backing up more than one character, + -- what we do is to leave ourselves positioned past the LM, but set + -- this flag, so that we know that from an Ada point of view we are + -- in front of the LM, not after it. A little odd, but it works. + + Before_LM_PM : Boolean := False; + -- This flag similarly handles the case of being physically positioned + -- after a LM-PM sequence when logically we are before the LM-PM. This + -- flag can only be set if Before_LM is also set. + + WC_Method : System.WCh_Con.WC_Encoding_Method := Default_WCEM; + -- Encoding method to be used for this file. Text_IO does not deal with + -- wide characters, but it does deal with upper half characters in the + -- range 16#80#-16#FF# which may need encoding, e.g. in UTF-8 mode. + + Before_Upper_Half_Character : Boolean := False; + -- This flag is set to indicate that an encoded upper half character has + -- been read by Text_IO.Look_Ahead. If it is set to True, then it means + -- that the stream is logically positioned before the character but is + -- physically positioned after it. The character involved must be in + -- the range 16#80#-16#FF#, i.e. if the flag is set, then we know the + -- next character has a code greater than 16#7F#, and the value of this + -- character is saved in Saved_Upper_Half_Character. + + Saved_Upper_Half_Character : Character; + -- This field is valid only if Before_Upper_Half_Character is set. It + -- contains an upper-half character read by Look_Ahead. If Look_Ahead + -- reads a character in the range 16#00# to 16#7F#, then it can use + -- ungetc to put it back, but ungetc cannot be called more than once, + -- so for characters above this range, we don't try to back up the + -- file. Instead we save the character in this field and set the flag + -- Before_Upper_Half_Character to True to indicate that we are logically + -- positioned before this character even though the stream is physically + -- positioned after it. + + end record; + + function AFCB_Allocate (Control_Block : Text_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : not null access Text_AFCB); + procedure AFCB_Free (File : not null access Text_AFCB); + + procedure Read + (File : in out Text_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read operation used when Text_IO file is treated directly as Stream + + procedure Write + (File : in out Text_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Write operation used when Text_IO file is treated directly as Stream + + ------------------------ + -- The Standard Files -- + ------------------------ + + Standard_In_AFCB : aliased Text_AFCB; + Standard_Out_AFCB : aliased Text_AFCB; + Standard_Err_AFCB : aliased Text_AFCB; + + Standard_In : aliased File_Type := Standard_In_AFCB'Access; + Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; + Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; + -- Standard files + + Current_In : aliased File_Type := Standard_In; + Current_Out : aliased File_Type := Standard_Out; + Current_Err : aliased File_Type := Standard_Err; + -- Current files + + function EOF_Char return Integer; + -- Returns the system-specific character indicating the end of a text file. + -- This is exported for use by child packages such as Enumeration_Aux to + -- eliminate their needing to depend directly on Interfaces.C_Streams, + -- which is not available in certain target environments (such as AAMP). + + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Text_IO.Reset_Standard_Files. + +end Ada.Text_IO; diff --git a/gcc/ada/libgnat/a-tgdico.ads b/gcc/ada/libgnat/a-tgdico.ads new file mode 100644 index 0000000..3aae768 --- /dev/null +++ b/gcc/ada/libgnat/a-tgdico.ads @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- ADA.TAGS.GENERIC_DISPATCHING_CONSTRUCTOR -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Warnings (Off); +-- Turn off categorization warnings + +generic + type T (<>) is abstract tagged limited private; + type Parameters (<>) is limited private; + with function Constructor (Params : not null access Parameters) return T + is abstract; + +function Ada.Tags.Generic_Dispatching_Constructor + (The_Tag : Tag; + Params : not null access Parameters) return T'Class; +pragma Preelaborate (Generic_Dispatching_Constructor); +pragma Import (Intrinsic, Generic_Dispatching_Constructor); diff --git a/gcc/ada/libgnat/a-tiboio.adb b/gcc/ada/libgnat/a-tiboio.adb new file mode 100644 index 0000000..f698061 --- /dev/null +++ b/gcc/ada/libgnat/a-tiboio.adb @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . B O U N D E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Unchecked_Deallocation; + +package body Ada.Text_IO.Bounded_IO is + + type String_Access is access all String; + + procedure Free (SA : in out String_Access); + -- Perform an unchecked deallocation of a non-null string + + ---------- + -- Free -- + ---------- + + procedure Free (SA : in out String_Access) is + Null_String : constant String := ""; + + procedure Deallocate is + new Ada.Unchecked_Deallocation (String, String_Access); + + begin + -- Do not try to free statically allocated null string + + if SA.all /= Null_String then + Deallocate (SA); + end if; + end Free; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Bounded.Bounded_String is + begin + return Bounded.To_Bounded_String (Get_Line); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line + (File : File_Type) return Bounded.Bounded_String + is + begin + return Bounded.To_Bounded_String (Get_Line (File)); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Item : out Bounded.Bounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + Str1 : String_Access; + Str2 : String_Access; + + begin + Get_Line (Buffer, Last); + Str1 := new String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Bounded.To_Bounded_String (Str1.all); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Bounded.Bounded_String) + is + Buffer : String (1 .. 1000); + Last : Natural; + Str1 : String_Access; + Str2 : String_Access; + + begin + Get_Line (File, Buffer, Last); + Str1 := new String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Bounded.To_Bounded_String (Str1.all); + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Bounded.Bounded_String) + is + begin + Put (Bounded.To_String (Item)); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Bounded.Bounded_String) + is + begin + Put (File, Bounded.To_String (Item)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (Item : Bounded.Bounded_String) + is + begin + Put_Line (Bounded.To_String (Item)); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Bounded.Bounded_String) + is + begin + Put_Line (File, Bounded.To_String (Item)); + end Put_Line; + +end Ada.Text_IO.Bounded_IO; diff --git a/gcc/ada/libgnat/a-tiboio.ads b/gcc/ada/libgnat/a-tiboio.ads new file mode 100644 index 0000000..1824c1d2 --- /dev/null +++ b/gcc/ada/libgnat/a-tiboio.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Bounded; + +generic + with package Bounded is + new Ada.Strings.Bounded.Generic_Bounded_Length (<>); + +package Ada.Text_IO.Bounded_IO is + + function Get_Line return Bounded.Bounded_String; + + function Get_Line + (File : File_Type) return Bounded.Bounded_String; + + procedure Get_Line + (Item : out Bounded.Bounded_String); + + procedure Get_Line + (File : File_Type; + Item : out Bounded.Bounded_String); + + procedure Put + (Item : Bounded.Bounded_String); + + procedure Put + (File : File_Type; + Item : Bounded.Bounded_String); + + procedure Put_Line + (Item : Bounded.Bounded_String); + + procedure Put_Line + (File : File_Type; + Item : Bounded.Bounded_String); + +end Ada.Text_IO.Bounded_IO; diff --git a/gcc/ada/libgnat/a-ticoau.adb b/gcc/ada/libgnat/a-ticoau.adb new file mode 100644 index 0000000..5eed392 --- /dev/null +++ b/gcc/ada/libgnat/a-ticoau.adb @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; +with Ada.Text_IO.Float_Aux; + +with System.Img_Real; use System.Img_Real; + +package body Ada.Text_IO.Complex_Aux is + + package Aux renames Ada.Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer; + Paren : Boolean := False; + + begin + -- General note for following code, exceptions from the calls to + -- Get for components of the complex value are propagated. + + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); + + for J in Ptr + 1 .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + + -- Case of width = 0 + + else + Load_Skip (File); + Ptr := 0; + Load (File, Buf, Ptr, '(', Paren); + Aux.Get (File, ItemR, 0); + Load_Skip (File); + Load (File, Buf, Ptr, ','); + Aux.Get (File, ItemI, 0); + + if Paren then + Load_Skip (File); + Load (File, Buf, Ptr, ')', Paren); + + if not Paren then + raise Data_Error; + end if; + end if; + end if; + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive) + is + Paren : Boolean; + Pos : Integer; + + begin + String_Skip (From, Pos); + + if From (Pos) = '(' then + Pos := Pos + 1; + Paren := True; + else + Paren := False; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemR, Pos); + + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) = ',' then + Pos := Pos + 1; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemI, Pos); + + if Paren then + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) /= ')' then + raise Data_Error; + end if; + end if; + + Last := Pos; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + begin + Put (File, '('); + Aux.Put (File, ItemR, Fore, Aft, Exp); + Put (File, ','); + Aux.Put (File, ItemI, Fore, Aft, Exp); + Put (File, ')'); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field) + is + I_String : String (1 .. 3 * Field'Last); + R_String : String (1 .. 3 * Field'Last); + + Iptr : Natural; + Rptr : Natural; + + begin + -- Both parts are initially converted with a Fore of 0 + + Rptr := 0; + Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Iptr := 0; + Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + + -- Check room for both parts plus parens plus comma (RM G.1.3(34)) + + if Rptr + Iptr + 3 > To'Length then + raise Layout_Error; + end if; + + -- If there is room, layout result according to (RM G.1.3(31-33)) + + To (To'First) := '('; + To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); + To (To'First + Rptr + 1) := ','; + + To (To'Last) := ')'; + To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); + + for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop + To (J) := ' '; + end loop; + + end Puts; + +end Ada.Text_IO.Complex_Aux; diff --git a/gcc/ada/libgnat/a-ticoau.ads b/gcc/ada/libgnat/a-ticoau.ads new file mode 100644 index 0000000..8ffe40a --- /dev/null +++ b/gcc/ada/libgnat/a-ticoau.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Text_IO.Complex_IO that are +-- shared among separate instantiations of this package. The routines in +-- this package are identical semantically to those in Complex_IO itself, +-- except that the generic parameter Complex has been replaced by separate +-- real and imaginary values of type Long_Long_Float, and default parameters +-- have been removed because they are supplied explicitly by the calls from +-- within the generic template. + +package Ada.Text_IO.Complex_Aux is + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field); + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive); + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Text_IO.Complex_Aux; diff --git a/gcc/ada/libgnat/a-ticoio.adb b/gcc/ada/libgnat/a-ticoio.adb new file mode 100644 index 0000000..5587845 --- /dev/null +++ b/gcc/ada/libgnat/a-ticoio.adb @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . C O M P L E X _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; + +with Ada.Text_IO.Complex_Aux; + +package body Ada.Text_IO.Complex_IO is + + use Complex_Types; + + package Aux renames Ada.Text_IO.Complex_Aux; + + subtype LLF is Long_Long_Float; + -- Type used for calls to routines in Aux + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Complex_Types.Complex; + Width : Field := 0) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + begin + Aux.Get (File, LLF (Real_Item), LLF (Imag_Item), Width); + Item := (Real_Item, Imag_Item); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (Item : out Complex_Types.Complex; + Width : Field := 0) + is + begin + Get (Current_In, Item, Width); + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (From : String; + Item : out Complex_Types.Complex; + Last : out Positive) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + begin + Aux.Gets (From, LLF (Real_Item), LLF (Imag_Item), Last); + Item := (Real_Item, Imag_Item); + + exception + when Data_Error => raise Constraint_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Complex_Types.Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (File, LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Complex_Types.Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Out, Item, Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (To : out String; + Item : Complex_Types.Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Puts (To, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + end Put; + +end Ada.Text_IO.Complex_IO; diff --git a/gcc/ada/libgnat/a-ticoio.ads b/gcc/ada/libgnat/a-ticoio.ads new file mode 100644 index 0000000..251ad89 --- /dev/null +++ b/gcc/ada/libgnat/a-ticoio.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . C O M P L E X _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + +package Ada.Text_IO.Complex_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Complex_Types.Real'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Complex_Types.Complex; + Width : Field := 0); + + procedure Get + (Item : out Complex_Types.Complex; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Complex_Types.Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Complex_Types.Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : String; + Item : out Complex_Types.Complex; + Last : out Positive); + + procedure Put + (To : out String; + Item : Complex_Types.Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +private + pragma Inline (Get); + pragma Inline (Put); + +end Ada.Text_IO.Complex_IO; diff --git a/gcc/ada/libgnat/a-tideau.adb b/gcc/ada/libgnat/a-tideau.adb new file mode 100644 index 0000000..5f124c0 --- /dev/null +++ b/gcc/ada/libgnat/a-tideau.adb @@ -0,0 +1,261 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; +with Ada.Text_IO.Float_Aux; use Ada.Text_IO.Float_Aux; + +with System.Img_Dec; use System.Img_Dec; +with System.Img_LLD; use System.Img_LLD; +with System.Val_Dec; use System.Val_Dec; +with System.Val_LLD; use System.Val_LLD; + +package body Ada.Text_IO.Decimal_Aux is + + ------------- + -- Get_Dec -- + ------------- + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_Dec; + + ------------- + -- Get_LLD -- + ------------- + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Long_Long_Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_LLD; + + -------------- + -- Gets_Dec -- + -------------- + + function Gets_Dec + (From : String; + Last : not null access Positive; + Scale : Integer) return Integer + is + Pos : aliased Integer; + Item : Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + end Gets_Dec; + + -------------- + -- Gets_LLD -- + -------------- + + function Gets_LLD + (From : String; + Last : not null access Positive; + Scale : Integer) return Long_Long_Integer + is + Pos : aliased Integer; + Item : Long_Long_Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + end Gets_LLD; + + ------------- + -- Put_Dec -- + ------------- + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_Dec; + + ------------- + -- Put_LLD -- + ------------- + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLD; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + -- Compute Fore, allowing for Aft digits and the decimal dot + + Fore := To'Length - Field'Max (1, Aft) - 1; + + -- Allow for Exp and two more for E+ or E- if exponent present + + if Exp /= 0 then + Fore := Fore - 2 - Exp; + end if; + + -- Make sure we have enough room + + if Fore < 1 then + raise Layout_Error; + end if; + + -- Do the conversion and check length of result + + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_Dec; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + Fore := + (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); + + if Fore < 1 then + raise Layout_Error; + end if; + + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_LLD; + +end Ada.Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-tideau.ads b/gcc/ada/libgnat/a-tideau.ads new file mode 100644 index 0000000..e5f42ce --- /dev/null +++ b/gcc/ada/libgnat/a-tideau.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Text_IO.Decimal_IO that are +-- shared among separate instantiations of this package. The routines in +-- the package are identical semantically to those declared in Text_IO, +-- except that default values have been supplied by the generic, and the +-- Num parameter has been replaced by Integer or Long_Long_Integer, with +-- an additional Scale parameter giving the value of Num'Scale. In addition +-- the Get routines return the value rather than store it in an Out parameter. + +private package Ada.Text_IO.Decimal_Aux is + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer; + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer; + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + function Gets_Dec + (From : String; + Last : not null access Positive; + Scale : Integer) return Integer; + + function Gets_LLD + (From : String; + Last : not null access Positive; + Scale : Integer) return Long_Long_Integer; + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + +end Ada.Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-tideio.adb b/gcc/ada/libgnat/a-tideio.adb new file mode 100644 index 0000000..4c4d6d0 --- /dev/null +++ b/gcc/ada/libgnat/a-tideio.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Decimal_Aux; + +package body Ada.Text_IO.Decimal_IO is + + package Aux renames Ada.Text_IO.Decimal_Aux; + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if Num'Size > Integer'Size then + Item := Num'Fixed_Value (Aux.Get_LLD (File, Width, Scale)); + else + Item := Num'Fixed_Value (Aux.Get_Dec (File, Width, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_In, Item, Width); + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + begin + if Num'Size > Integer'Size then + Item := Num'Fixed_Value + (Aux.Gets_LLD (From, Last'Unrestricted_Access, Scale)); + else + Item := Num'Fixed_Value + (Aux.Gets_Dec (From, Last'Unrestricted_Access, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Num'Size > Integer'Size then + Aux.Put_LLD + (File, Long_Long_Integer'Integer_Value (Item), + Fore, Aft, Exp, Scale); + else + Aux.Put_Dec + (File, Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Out, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Num'Size > Integer'Size then + Aux.Puts_LLD + (To, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); + else + Aux.Puts_Dec (To, Integer'Integer_Value (Item), Aft, Exp, Scale); + end if; + end Put; + +end Ada.Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-tideio.ads b/gcc/ada/libgnat/a-tideio.ads new file mode 100644 index 0000000..3234dad --- /dev/null +++ b/gcc/ada/libgnat/a-tideio.ads @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Decimal_IO is a subpackage of Text_IO. +-- This is for compatibility with Ada 83. In GNAT we make it a child package +-- to avoid loading the necessary code if Decimal_IO is not instantiated. +-- See routine Rtsfind.Check_Text_IO_Special_Unit for a description of how +-- we patch up the difference in semantics so that it is invisible to the +-- Ada programmer. + +private generic + type Num is delta <> digits <>; + +package Ada.Text_IO.Decimal_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +private + pragma Inline (Get); + pragma Inline (Put); + +end Ada.Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-tienau.adb b/gcc/ada/libgnat/a-tienau.adb new file mode 100644 index 0000000..729e516 --- /dev/null +++ b/gcc/ada/libgnat/a-tienau.adb @@ -0,0 +1,283 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E N U M E R A T I O N _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; +with Ada.Characters.Handling; use Ada.Characters.Handling; + +-- Note: this package does not yet deal properly with wide characters ??? + +package body Ada.Text_IO.Enumeration_Aux is + + ------------------ + -- Get_Enum_Lit -- + ------------------ + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out String; + Buflen : out Natural) + is + ch : Integer; + C : Character; + + begin + Buflen := 0; + Load_Skip (File); + ch := Getc (File); + C := Character'Val (ch); + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L) + + if C = ''' then + Store_Char (File, ch, Buf, Buflen); + + ch := Getc (File); + + if ch in 16#20# .. 16#7E# or else ch >= 16#80# then + Store_Char (File, ch, Buf, Buflen); + + ch := Getc (File); + + if ch = Character'Pos (''') then + Store_Char (File, ch, Buf, Buflen); + else + Ungetc (ch, File); + end if; + + else + Ungetc (ch, File); + end if; + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter + + if not Is_Letter (C) then + Ungetc (ch, File); + return; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + loop + C := Character'Val (ch); + Store_Char (File, Character'Pos (To_Upper (C)), Buf, Buflen); + + ch := Getc (File); + exit when ch = EOF_Char; + C := Character'Val (ch); + + exit when not Is_Letter (C) + and then not Is_Digit (C) + and then C /= '_'; + + exit when C = '_' + and then Buf (Buflen) = '_'; + end loop; + + Ungetc (ch, File); + end if; + end Get_Enum_Lit; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : String; + Width : Field; + Set : Type_Set) + is + Actual_Width : constant Count := Count'Max (Count (Width), Item'Length); + + begin + -- Deal with limited line length of output file + + if Line_Length (File) /= 0 then + + -- If actual width exceeds line length, raise Layout_Error + + if Actual_Width > Line_Length (File) then + raise Layout_Error; + end if; + + -- If full width cannot fit on current line move to new line + + if Actual_Width + (Col (File) - 1) > Line_Length (File) then + New_Line (File); + end if; + end if; + + -- Output in lower case if necessary + + if Set = Lower_Case and then Item (Item'First) /= ''' then + declare + Iteml : String (Item'First .. Item'Last); + + begin + for J in Item'Range loop + Iteml (J) := To_Lower (Item (J)); + end loop; + + Put_Item (File, Iteml); + end; + + -- Otherwise output in upper case + + else + Put_Item (File, Item); + end if; + + -- Fill out item with spaces to width + + for J in 1 .. Actual_Width - Item'Length loop + Put (File, ' '); + end loop; + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : String; + Set : Type_Set) + is + Ptr : Natural; + + begin + if Item'Length > To'Length then + raise Layout_Error; + + else + Ptr := To'First; + for J in Item'Range loop + if Set = Lower_Case and then Item (Item'First) /= ''' then + To (Ptr) := To_Lower (Item (J)); + else + To (Ptr) := Item (J); + end if; + + Ptr := Ptr + 1; + end loop; + + while Ptr <= To'Last loop + To (Ptr) := ' '; + Ptr := Ptr + 1; + end loop; + end if; + end Puts; + + ------------------- + -- Scan_Enum_Lit -- + ------------------- + + procedure Scan_Enum_Lit + (From : String; + Start : out Natural; + Stop : out Natural) + is + C : Character; + + -- Processing for Scan_Enum_Lit + + begin + String_Skip (From, Start); + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L + -- which is for the analogous case for reading from a file). + + if From (Start) = ''' then + Stop := Start; + + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + end if; + + if From (Stop) in ' ' .. '~' + or else From (Stop) >= Character'Val (16#80#) + then + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + + if From (Stop) = ''' then + return; + end if; + end if; + end if; + + raise Data_Error; + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter + + if not Is_Letter (From (Start)) then + raise Data_Error; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + Stop := Start; + while Stop < From'Last loop + C := From (Stop + 1); + + exit when not Is_Letter (C) + and then not Is_Digit (C) + and then C /= '_'; + + exit when C = '_' + and then From (Stop) = '_'; + + Stop := Stop + 1; + end loop; + end if; + end Scan_Enum_Lit; + +end Ada.Text_IO.Enumeration_Aux; diff --git a/gcc/ada/libgnat/a-tienau.ads b/gcc/ada/libgnat/a-tienau.ads new file mode 100644 index 0000000..e8cce26 --- /dev/null +++ b/gcc/ada/libgnat/a-tienau.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E N U M E R A T I O N _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Text_IO.Enumeration_IO +-- that are shared among separate instantiations of this package. + +private package Ada.Text_IO.Enumeration_Aux is + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out String; + Buflen : out Natural); + -- Reads an enumeration literal value from the file, folds to upper case, + -- and stores the result in Buf, setting Buflen to the number of stored + -- characters (Buf has a lower bound of 1). If more than Buflen characters + -- are present in the literal, Data_Error is raised. + + procedure Scan_Enum_Lit + (From : String; + Start : out Natural; + Stop : out Natural); + -- Scans an enumeration literal at the start of From, skipping any leading + -- spaces. Sets Start to the first character, Stop to the last character. + -- Raises End_Error if no enumeration literal is found. + + procedure Put + (File : File_Type; + Item : String; + Width : Field; + Set : Type_Set); + -- Outputs the enumeration literal image stored in Item to the given File, + -- using the given Width and Set parameters (Item is always in upper case). + + procedure Puts + (To : out String; + Item : String; + Set : Type_Set); + -- Stores the enumeration literal image stored in Item to the string To, + -- padding with trailing spaces if necessary to fill To. Set is used to + +end Ada.Text_IO.Enumeration_Aux; diff --git a/gcc/ada/libgnat/a-tienio.adb b/gcc/ada/libgnat/a-tienio.adb new file mode 100644 index 0000000..0eda96c --- /dev/null +++ b/gcc/ada/libgnat/a-tienio.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Enumeration_Aux; + +package body Ada.Text_IO.Enumeration_IO is + + package Aux renames Ada.Text_IO.Enumeration_Aux; + + --------- + -- Get -- + --------- + + procedure Get (File : File_Type; Item : out Enum) is + Buf : String (1 .. Enum'Width + 1); + Buflen : Natural; + + begin + Aux.Get_Enum_Lit (File, Buf, Buflen); + + declare + Buf_Str : String renames Buf (1 .. Buflen); + pragma Unsuppress (Range_Check); + begin + Item := Enum'Value (Buf_Str); + end; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get (Item : out Enum) is + pragma Unsuppress (Range_Check); + begin + Get (Current_In, Item); + end Get; + + procedure Get + (From : String; + Item : out Enum; + Last : out Positive) + is + Start : Natural; + + begin + Aux.Scan_Enum_Lit (From, Start, Last); + + declare + From_Str : String renames From (Start .. Last); + pragma Unsuppress (Range_Check); + begin + Item := Enum'Value (From_Str); + end; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + begin + -- Ensure that Item is valid before attempting to retrieve the Image, to + -- prevent the possibility of out-of-bounds addressing of index or image + -- tables. Units in the run-time library are normally compiled with + -- checks suppressed, which includes instantiated generics. + + if not Item'Valid then + raise Constraint_Error with "invalid enumeration value"; + end if; + + Aux.Put (File, Enum'Image (Item), Width, Set); + end Put; + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + begin + Put (Current_Out, Item, Width, Set); + end Put; + + procedure Put + (To : out String; + Item : Enum; + Set : Type_Set := Default_Setting) + is + begin + -- Ensure that Item is valid before attempting to retrieve the Image, to + -- prevent the possibility of out-of-bounds addressing of index or image + -- tables. Units in the run-time library are normally compiled with + -- checks suppressed, which includes instantiated generics. + + if not Item'Valid then + raise Constraint_Error with "invalid enumeration value"; + end if; + + Aux.Puts (To, Enum'Image (Item), Set); + end Put; + +end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-tienio.ads b/gcc/ada/libgnat/a-tienio.ads new file mode 100644 index 0000000..68f4694 --- /dev/null +++ b/gcc/ada/libgnat/a-tienio.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Enumeration_IO is a subpackage of +-- Text_IO. This is for compatibility with Ada 83. In GNAT we make it a +-- child package to avoid loading the necessary code if Enumeration_IO is +-- not instantiated. See routine Rtsfind.Check_Text_IO_Special_Unit for a +-- description of how we patch up the difference in semantics so that it +-- is invisible to the Ada programmer. + +private generic + type Enum is (<>); + +package Ada.Text_IO.Enumeration_IO is + + Default_Width : Field := 0; + Default_Setting : Type_Set := Upper_Case; + + procedure Get (File : File_Type; Item : out Enum); + procedure Get (Item : out Enum); + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Get + (From : String; + Item : out Enum; + Last : out Positive); + + procedure Put + (To : out String; + Item : Enum; + Set : Type_Set := Default_Setting); + +end Ada.Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-tifiio.adb b/gcc/ada/libgnat/a-tifiio.adb new file mode 100644 index 0000000..c013012 --- /dev/null +++ b/gcc/ada/libgnat/a-tifiio.adb @@ -0,0 +1,716 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Fixed point I/O +-- --------------- + +-- The following documents implementation details of the fixed point +-- input/output routines in the GNAT run time. The first part describes +-- general properties of fixed point types as defined by the Ada 95 standard, +-- including the Information Systems Annex. + +-- Subsequently these are reduced to implementation constraints and the impact +-- of these constraints on a few possible approaches to I/O are given. +-- Based on this analysis, a specific implementation is selected for use in +-- the GNAT run time. Finally, the chosen algorithm is analyzed numerically in +-- order to provide user-level documentation on limits for range and precision +-- of fixed point types as well as accuracy of input/output conversions. + +-- ------------------------------------------- +-- - General Properties of Fixed Point Types - +-- ------------------------------------------- + +-- Operations on fixed point values, other than input and output, are not +-- important for the purposes of this document. Only the set of values that a +-- fixed point type can represent and the input and output operations are +-- significant. + +-- Values +-- ------ + +-- Set set of values of a fixed point type comprise the integral +-- multiples of a number called the small of the type. The small can +-- either be a power of ten, a power of two or (if the implementation +-- allows) an arbitrary strictly positive real value. + +-- Implementations need to support fixed-point types with a precision +-- of at least 24 bits, and (in order to comply with the Information +-- Systems Annex) decimal types need to support at least digits 18. +-- For the rest, however, no requirements exist for the minimal small +-- and range that need to be supported. + +-- Operations +-- ---------- + +-- 'Image and 'Wide_Image (see RM 3.5(34)) + +-- These attributes return a decimal real literal best approximating +-- the value (rounded away from zero if halfway between) with a +-- single leading character that is either a minus sign or a space, +-- one or more digits before the decimal point (with no redundant +-- leading zeros), a decimal point, and N digits after the decimal +-- point. For a subtype S, the value of N is S'Aft, the smallest +-- positive integer such that (10**N)*S'Delta is greater or equal to +-- one, see RM 3.5.10(5). + +-- For an arbitrary small, this means large number arithmetic needs +-- to be performed. + +-- Put (see RM A.10.9(22-26)) + +-- The requirements for Put add no extra constraints over the image +-- attributes, although it would be nice to be able to output more +-- than S'Aft digits after the decimal point for values of subtype S. + +-- 'Value and 'Wide_Value attribute (RM 3.5(40-55)) + +-- Since the input can be given in any base in the range 2..16, +-- accurate conversion to a fixed point number may require +-- arbitrary precision arithmetic if there is no limit on the +-- magnitude of the small of the fixed point type. + +-- Get (see RM A.10.9(12-21)) + +-- The requirements for Get are identical to those of the Value +-- attribute. + +-- ------------------------------ +-- - Implementation Constraints - +-- ------------------------------ + +-- The requirements listed above for the input/output operations lead to +-- significant complexity, if no constraints are put on supported smalls. + +-- Implementation Strategies +-- ------------------------- + +-- * Float arithmetic +-- * Arbitrary-precision integer arithmetic +-- * Fixed-precision integer arithmetic + +-- Although it seems convenient to convert fixed point numbers to floating- +-- point and then print them, this leads to a number of restrictions. +-- The first one is precision. The widest floating-point type generally +-- available has 53 bits of mantissa. This means that Fine_Delta cannot +-- be less than 2.0**(-53). + +-- In GNAT, Fine_Delta is 2.0**(-63), and Duration for example is a +-- 64-bit type. It would still be possible to use multi-precision +-- floating-point to perform calculations using longer mantissas, +-- but this is a much harder approach. + +-- The base conversions needed for input and output of (non-decimal) +-- fixed point types can be seen as pairs of integer multiplications +-- and divisions. + +-- Arbitrary-precision integer arithmetic would be suitable for the job +-- at hand, but has the draw-back that it is very heavy implementation-wise. +-- Especially in embedded systems, where fixed point types are often used, +-- it may not be desirable to require large amounts of storage and time +-- for fixed I/O operations. + +-- Fixed-precision integer arithmetic has the advantage of simplicity and +-- speed. For the most common fixed point types this would be a perfect +-- solution. The downside however may be a too limited set of acceptable +-- fixed point types. + +-- Extra Precision +-- --------------- + +-- Using a scaled divide which truncates and returns a remainder R, +-- another E trailing digits can be calculated by computing the value +-- (R * (10.0**E)) / Z using another scaled divide. This procedure +-- can be repeated to compute an arbitrary number of digits in linear +-- time and storage. The last scaled divide should be rounded, with +-- a possible carry propagating to the more significant digits, to +-- ensure correct rounding of the unit in the last place. + +-- An extension of this technique is to limit the value of Q to 9 decimal +-- digits, since 32-bit integers can be much more efficient than 64-bit +-- integers to output. + +with Interfaces; use Interfaces; +with System.Arith_64; use System.Arith_64; +with System.Img_Real; use System.Img_Real; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Text_IO.Float_Aux; +with Ada.Text_IO.Generic_Aux; + +package body Ada.Text_IO.Fixed_IO is + + -- Note: we still use the floating-point I/O routines for input of + -- ordinary fixed-point and output using exponent format. This will + -- result in inaccuracies for fixed point types with a small that is + -- not a power of two, and for types that require more precision than + -- is available in Long_Long_Float. + + package Aux renames Ada.Text_IO.Float_Aux; + + Extra_Layout_Space : constant Field := 5 + Num'Fore; + -- Extra space that may be needed for output of sign, decimal point, + -- exponent indication and mandatory decimals after and before the + -- decimal point. A string with length + + -- Fore + Aft + Exp + Extra_Layout_Space + + -- is always long enough for formatting any fixed point number + + -- Implementation of Put routines + + -- The following section describes a specific implementation choice for + -- performing base conversions needed for output of values of a fixed + -- point type T with small T'Small. The goal is to be able to output + -- all values of types with a precision of 64 bits and a delta of at + -- least 2.0**(-63), as these are current GNAT limitations already. + + -- The chosen algorithm uses fixed precision integer arithmetic for + -- reasons of simplicity and efficiency. It is important to understand + -- in what ways the most simple and accurate approach to fixed point I/O + -- is limiting, before considering more complicated schemes. + + -- Without loss of generality assume T has a range (-2.0**63) * T'Small + -- .. (2.0**63 - 1) * T'Small, and is output with Aft digits after the + -- decimal point and T'Fore - 1 before. If T'Small is integer, or + -- 1.0 / T'Small is integer, let S = T'Small and E = 0. For other T'Small, + -- let S and E be integers such that S / 10**E best approximates T'Small + -- and S is in the range 10**17 .. 10**18 - 1. The extra decimal scaling + -- factor 10**E can be trivially handled during final output, by adjusting + -- the decimal point or exponent. + + -- Convert a value X * S of type T to a 64-bit integer value Q equal + -- to 10.0**D * (X * S) rounded to the nearest integer. + -- This conversion is a scaled integer divide of the form + + -- Q := (X * Y) / Z, + + -- where all variables are 64-bit signed integers using 2's complement, + -- and both the multiplication and division are done using full + -- intermediate precision. The final decimal value to be output is + + -- Q * 10**(E-D) + + -- This value can be written to the output file or to the result string + -- according to the format described in RM A.3.10. The details of this + -- operation are omitted here. + + -- A 64-bit value can contain all integers with 18 decimal digits, but + -- not all with 19 decimal digits. If the total number of requested output + -- digits (Fore - 1) + Aft is greater than 18, for purposes of the + -- conversion Aft is adjusted to 18 - (Fore - 1). In that case, or + -- when Fore > 19, trailing zeros can complete the output after writing + -- the first 18 significant digits, or the technique described in the + -- next section can be used. + + -- The final expression for D is + + -- D := Integer'Max (-18, Integer'Min (Aft, 18 - (Fore - 1))); + + -- For Y and Z the following expressions can be derived: + + -- Q / (10.0**D) = X * S + + -- Q = X * S * (10.0**D) = (X * Y) / Z + + -- S * 10.0**D = Y / Z; + + -- If S is an integer greater than or equal to one, then Fore must be at + -- least 20 in order to print T'First, which is at most -2.0**63. + -- This means D < 0, so use + + -- (1) Y = -S and Z = -10**(-D) + + -- If 1.0 / S is an integer greater than one, use + + -- (2) Y = -10**D and Z = -(1.0 / S), for D >= 0 + + -- or + + -- (3) Y = 1 and Z = (1.0 / S) * 10**(-D), for D < 0 + + -- Negative values are used for nominator Y and denominator Z, so that S + -- can have a maximum value of 2.0**63 and a minimum of 2.0**(-63). + -- For Z in -1 .. -9, Fore will still be 20, and D will be negative, as + -- (-2.0**63) / -9 is greater than 10**18. In these cases there is room + -- in the denominator for the extra decimal scaling required, so case (3) + -- will not overflow. + + pragma Assert (System.Fine_Delta >= 2.0**(-63)); + pragma Assert (Num'Small in 2.0**(-63) .. 2.0**63); + pragma Assert (Num'Fore <= 37); + -- These assertions need to be relaxed to allow for a Small of + -- 2.0**(-64) at least, since there is an ACATS test for this ??? + + Max_Digits : constant := 18; + -- Maximum number of decimal digits that can be represented in a + -- 64-bit signed number, see above + + -- The constants E0 .. E5 implement a binary search for the appropriate + -- power of ten to scale the small so that it has one digit before the + -- decimal point. + + subtype Int is Integer; + E0 : constant Int := -(20 * Boolean'Pos (Num'Small >= 1.0E1)); + E1 : constant Int := E0 + 10 * Boolean'Pos (Num'Small * 10.0**E0 < 1.0E-10); + E2 : constant Int := E1 + 5 * Boolean'Pos (Num'Small * 10.0**E1 < 1.0E-5); + E3 : constant Int := E2 + 3 * Boolean'Pos (Num'Small * 10.0**E2 < 1.0E-3); + E4 : constant Int := E3 + 2 * Boolean'Pos (Num'Small * 10.0**E3 < 1.0E-1); + E5 : constant Int := E4 + 1 * Boolean'Pos (Num'Small * 10.0**E4 < 1.0E-0); + + Scale : constant Integer := E5; + + pragma Assert (Num'Small * 10.0**Scale >= 1.0 + and then Num'Small * 10.0**Scale < 10.0); + + Exact : constant Boolean := + Float'Floor (Num'Small) = Float'Ceiling (Num'Small) + or else Float'Floor (1.0 / Num'Small) = Float'Ceiling (1.0 / Num'Small) + or else Num'Small >= 10.0**Max_Digits; + -- True iff a numerator and denominator can be calculated such that + -- their ratio exactly represents the small of Num. + + procedure Put + (To : out String; + Last : out Natural; + Item : Num; + Fore : Integer; + Aft : Field; + Exp : Field); + -- Actual output function, used internally by all other Put routines. + -- The formal Fore is an Integer, not a Field, because the routine is + -- also called from the version of Put that performs I/O to a string, + -- where the starting position depends on the size of the String, and + -- bears no relation to the bounds of Field. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + begin + Aux.Get (File, Long_Long_Float (Item), Width); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + begin + Aux.Get (Current_In, Long_Long_Float (Item), Width); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + begin + Aux.Gets (From, Long_Long_Float (Item), Last); + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); + Last : Natural; + begin + Put (S, Last, Item, Fore, Aft, Exp); + Generic_Aux.Put_Item (File, S (1 .. Last)); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (1 .. Fore + Aft + Exp + Extra_Layout_Space); + Last : Natural; + begin + Put (S, Last, Item, Fore, Aft, Exp); + Generic_Aux.Put_Item (Text_IO.Current_Out, S (1 .. Last)); + end Put; + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + Fore : constant Integer := + To'Length + - 1 -- Decimal point + - Field'Max (1, Aft) -- Decimal part + - Boolean'Pos (Exp /= 0) -- Exponent indicator + - Exp; -- Exponent + + Last : Natural; + + begin + if Fore - Boolean'Pos (Item < 0.0) < 1 then + raise Layout_Error; + end if; + + Put (To, Last, Item, Fore, Aft, Exp); + + if Last /= To'Last then + raise Layout_Error; + end if; + end Put; + + procedure Put + (To : out String; + Last : out Natural; + Item : Num; + Fore : Integer; + Aft : Field; + Exp : Field) + is + subtype Digit is Int64 range 0 .. 9; + + X : constant Int64 := Int64'Integer_Value (Item); + A : constant Field := Field'Max (Aft, 1); + Neg : constant Boolean := (Item < 0.0); + Pos : Integer := 0; -- Next digit X has value X * 10.0**Pos; + + procedure Put_Character (C : Character); + pragma Inline (Put_Character); + -- Add C to the output string To, updating Last + + procedure Put_Digit (X : Digit); + -- Add digit X to the output string (going from left to right), updating + -- Last and Pos, and inserting the sign, leading zeros or a decimal + -- point when necessary. After outputting the first digit, Pos must not + -- be changed outside Put_Digit anymore. + + procedure Put_Int64 (X : Int64; Scale : Integer); + -- Output the decimal number abs X * 10**Scale + + procedure Put_Scaled + (X, Y, Z : Int64; + A : Field; + E : Integer); + -- Output the decimal number (X * Y / Z) * 10**E, producing A digits + -- after the decimal point and rounding the final digit. The value + -- X * Y / Z is computed with full precision, but must be in the + -- range of Int64. + + ------------------- + -- Put_Character -- + ------------------- + + procedure Put_Character (C : Character) is + begin + Last := Last + 1; + + -- Never put a character outside of string To. Exception Layout_Error + -- will be raised later if Last is greater than To'Last. + + if Last <= To'Last then + To (Last) := C; + end if; + end Put_Character; + + --------------- + -- Put_Digit -- + --------------- + + procedure Put_Digit (X : Digit) is + Digs : constant array (Digit) of Character := "0123456789"; + + begin + if Last = To'First - 1 then + if X /= 0 or else Pos <= 0 then + + -- Before outputting first digit, include leading space, + -- possible minus sign and, if the first digit is fractional, + -- decimal seperator and leading zeros. + + -- The Fore part has Pos + 1 + Boolean'Pos (Neg) characters, + -- if Pos >= 0 and otherwise has a single zero digit plus minus + -- sign if negative. Add leading space if necessary. + + for J in Integer'Max (0, Pos) + 2 + Boolean'Pos (Neg) .. Fore + loop + Put_Character (' '); + end loop; + + -- Output minus sign, if number is negative + + if Neg then + Put_Character ('-'); + end if; + + -- If starting with fractional digit, output leading zeros + + if Pos < 0 then + Put_Character ('0'); + Put_Character ('.'); + + for J in Pos .. -2 loop + Put_Character ('0'); + end loop; + end if; + + Put_Character (Digs (X)); + end if; + + else + -- This is not the first digit to be output, so the only + -- special handling is that for the decimal point + + if Pos = -1 then + Put_Character ('.'); + end if; + + Put_Character (Digs (X)); + end if; + + Pos := Pos - 1; + end Put_Digit; + + --------------- + -- Put_Int64 -- + --------------- + + procedure Put_Int64 (X : Int64; Scale : Integer) is + begin + if X = 0 then + return; + end if; + + if X not in -9 .. 9 then + Put_Int64 (X / 10, Scale + 1); + end if; + + -- Use Put_Digit to advance Pos. This fixes a case where the second + -- or later Scaled_Divide would omit leading zeroes, resulting in + -- too few digits produced and a Layout_Error as result. + + while Pos > Scale loop + Put_Digit (0); + end loop; + + -- If and only if more than one digit is output before the decimal + -- point, pos will be unequal to scale when outputting the first + -- digit. + + pragma Assert (Pos = Scale or else Last = To'First - 1); + + Pos := Scale; + + Put_Digit (abs (X rem 10)); + end Put_Int64; + + ---------------- + -- Put_Scaled -- + ---------------- + + procedure Put_Scaled + (X, Y, Z : Int64; + A : Field; + E : Integer) + is + pragma Assert (E >= -Max_Digits); + AA : constant Field := E + A; + N : constant Natural := (AA + Max_Digits - 1) / Max_Digits + 1; + + Q : array (0 .. N - 1) of Int64 := (others => 0); + -- Each element of Q has Max_Digits decimal digits, except the + -- last, which has eAA rem Max_Digits. Only Q (Q'First) may have an + -- absolute value equal to or larger than 10**Max_Digits. Only the + -- absolute value of the elements is not significant, not the sign. + + XX : Int64 := X; + YY : Int64 := Y; + + begin + for J in Q'Range loop + exit when XX = 0; + + if J > 0 then + YY := 10**(Integer'Min (Max_Digits, AA - (J - 1) * Max_Digits)); + end if; + + Scaled_Divide (XX, YY, Z, Q (J), R => XX, Round => False); + end loop; + + if -E > A then + pragma Assert (N = 1); + + Discard_Extra_Digits : declare + Factor : constant Int64 := 10**(-E - A); + + begin + -- The scaling factors were such that the first division + -- produced more digits than requested. So divide away extra + -- digits and compute new remainder for later rounding. + + if abs (Q (0) rem Factor) >= Factor / 2 then + Q (0) := abs (Q (0) / Factor) + 1; + else + Q (0) := Q (0) / Factor; + end if; + + XX := 0; + end Discard_Extra_Digits; + end if; + + -- At this point XX is a remainder and we need to determine if the + -- quotient in Q must be rounded away from zero. + + -- As XX is less than the divisor, it is safe to take its absolute + -- without chance of overflow. The check to see if XX is at least + -- half the absolute value of the divisor must be done carefully to + -- avoid overflow or lose precision. + + XX := abs XX; + + if XX >= 2**62 + or else (Z < 0 and then (-XX) * 2 <= Z) + or else (Z >= 0 and then XX * 2 >= Z) + then + -- OK, rounding is necessary. As the sign is not significant, + -- take advantage of the fact that an extra negative value will + -- always be available when propagating the carry. + + Q (Q'Last) := -abs Q (Q'Last) - 1; + + Propagate_Carry : + for J in reverse 1 .. Q'Last loop + if Q (J) = YY or else Q (J) = -YY then + Q (J) := 0; + Q (J - 1) := -abs Q (J - 1) - 1; + + else + exit Propagate_Carry; + end if; + end loop Propagate_Carry; + end if; + + for J in Q'First .. Q'Last - 1 loop + Put_Int64 (Q (J), E - J * Max_Digits); + end loop; + + Put_Int64 (Q (Q'Last), -A); + end Put_Scaled; + + -- Start of processing for Put + + begin + Last := To'First - 1; + + if Exp /= 0 then + + -- With the Exp format, it is not known how many output digits to + -- generate, as leading zeros must be ignored. Computing too many + -- digits and then truncating the output will not give the closest + -- output, it is necessary to round at the correct digit. + + -- The general approach is as follows: as long as no digits have + -- been generated, compute the Aft next digits (without rounding). + -- Once a non-zero digit is generated, determine the exact number + -- of digits remaining and compute them with rounding. + + -- Since a large number of iterations might be necessary in case + -- of Aft = 1, the following optimization would be desirable. + + -- Count the number Z of leading zero bits in the integer + -- representation of X, and start with producing Aft + Z * 1000 / + -- 3322 digits in the first scaled division. + + -- However, the floating-point routines are still used now ??? + + System.Img_Real.Set_Image_Real (Long_Long_Float (Item), To, Last, + Fore, Aft, Exp); + return; + end if; + + if Exact then + declare + D : constant Integer := Integer'Min (A, Max_Digits + - (Num'Fore - 1)); + Y : constant Int64 := Int64'Min (Int64 (-Num'Small), -1) + * 10**Integer'Max (0, D); + Z : constant Int64 := Int64'Min (Int64 (-(1.0 / Num'Small)), -1) + * 10**Integer'Max (0, -D); + begin + Put_Scaled (X, Y, Z, A, -D); + end; + + else -- not Exact + declare + E : constant Integer := Max_Digits - 1 + Scale; + D : constant Integer := Scale - 1; + Y : constant Int64 := Int64 (-Num'Small * 10.0**E); + Z : constant Int64 := -10**Max_Digits; + begin + Put_Scaled (X, Y, Z, A, -D); + end; + end if; + + -- If only zero digits encountered, unit digit has not been output yet + + if Last < To'First then + Pos := 0; + + elsif Last > To'Last then + raise Layout_Error; -- Not enough room in the output variable + end if; + + -- Always output digits up to the first one after the decimal point + + while Pos >= -A loop + Put_Digit (0); + end loop; + end Put; + +end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-tifiio.ads b/gcc/ada/libgnat/a-tifiio.ads new file mode 100644 index 0000000..265600db --- /dev/null +++ b/gcc/ada/libgnat/a-tifiio.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Fixed_IO is a subpackage of Text_IO. +-- This is for compatibility with Ada 83. In GNAT we make it a child package +-- to avoid loading the necessary code if Fixed_IO is not instantiated. See +-- routine Rtsfind.Check_Text_IO_Special_Unit for a description of how we +-- patch up the difference in semantics so that it is invisible to the Ada +-- programmer. + +private generic + type Num is delta <>; + +package Ada.Text_IO.Fixed_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +private + pragma Inline (Get); + pragma Inline (Put); + +end Ada.Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-tiflau.adb b/gcc/ada/libgnat/a-tiflau.adb new file mode 100644 index 0000000..2d0d900 --- /dev/null +++ b/gcc/ada/libgnat/a-tiflau.adb @@ -0,0 +1,235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F L O A T _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; + +with System.Img_Real; use System.Img_Real; +with System.Val_Real; use System.Val_Real; + +package body Ada.Text_IO.Float_Aux is + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + end if; + + Item := Scan_Real (Buf, Ptr'Access, Stop); + + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Real (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets; + + --------------- + -- Load_Real -- + --------------- + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Loaded : Boolean; + + begin + -- Skip initial blanks, and load possible sign + + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + -- Case of .nnnn + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Otherwise must have digits to start + + else + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Based cases. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + + -- Case of nnn#.xxx# + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '#', ':'); + + -- Case of nnn#xxx.[xxx]# or nnn#xxx# + + else + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + end if; + + -- As usual, it seems strange to allow mixed base characters, + -- but that is what ACVC tests expect, see CE3804M, case (3). + + Load (File, Buf, Ptr, '#', ':'); + end if; + + -- Case of nnn.[nnn] or nnn + + else + -- Prevent the potential processing of '.' in cases where the + -- initial digits have a trailing underscore. + + if Buf (Ptr) = '_' then + return; + end if; + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr); + end if; + end if; + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end Load_Real; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. 3 * Field'Last + 2); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. 3 * Field'Last + 2); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); + + if Ptr > To'Length then + raise Layout_Error; + + else + for J in 1 .. Ptr loop + To (To'Last - Ptr + J) := Buf (J); + end loop; + + for J in To'First .. To'Last - Ptr loop + To (J) := ' '; + end loop; + end if; + end Puts; + +end Ada.Text_IO.Float_Aux; diff --git a/gcc/ada/libgnat/a-tiflau.ads b/gcc/ada/libgnat/a-tiflau.ads new file mode 100644 index 0000000..81830ef --- /dev/null +++ b/gcc/ada/libgnat/a-tiflau.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F L O A T _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Text_IO.Float_IO that are +-- shared among separate instantiations of this package. The routines in +-- this package are identical semantically to those in Float_IO itself, +-- except that generic parameter Num has been replaced by Long_Long_Float, +-- and the default parameters have been removed because they are supplied +-- explicitly by the calls from within the generic template. This package +-- is also used by Ada.Text_IO.Fixed_IO, and Ada.Text_IO.Decimal_IO. + +private package Ada.Text_IO.Float_Aux is + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load a possibly signed + -- real literal value from the input file into Buf, starting at Ptr + 1. + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field); + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive); + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Text_IO.Float_Aux; diff --git a/gcc/ada/libgnat/a-tiflio.adb b/gcc/ada/libgnat/a-tiflio.adb new file mode 100644 index 0000000..a6f7d93 --- /dev/null +++ b/gcc/ada/libgnat/a-tiflio.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F L O A T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Float_Aux; + +package body Ada.Text_IO.Float_IO is + + package Aux renames Ada.Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + Aux.Get (File, Long_Long_Float (Item), Width); + + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + Aux.Get (Current_In, Long_Long_Float (Item), Width); + + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + begin + Aux.Gets (From, Long_Long_Float (Item), Last); + + -- In the case where the type is unconstrained (e.g. Standard'Float), + -- the above conversion may result in an infinite value, which is + -- normally fine for a conversion, but in this case, we want to treat + -- that as a data error. + + if not Item'Valid then + raise Data_Error; + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (File, Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (Current_Out, Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Puts (To, Long_Long_Float (Item), Aft, Exp); + end Put; + +end Ada.Text_IO.Float_IO; diff --git a/gcc/ada/libgnat/a-tiflio.ads b/gcc/ada/libgnat/a-tiflio.ads new file mode 100644 index 0000000..78be75f --- /dev/null +++ b/gcc/ada/libgnat/a-tiflio.ads @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Float_IO is a subpackage of Text_IO. +-- This is for compatibility with Ada 83. In GNAT we make it a child package +-- to avoid loading the necessary code if Float_IO is not instantiated. See +-- routine Rtsfind.Check_Text_IO_Special_Unit for a description of how we +-- patch up the difference in semantics so that it is invisible to the Ada +-- programmer. + +private generic + type Num is digits <>; + +package Ada.Text_IO.Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +private + pragma Inline (Get); + pragma Inline (Put); + +end Ada.Text_IO.Float_IO; diff --git a/gcc/ada/libgnat/a-tigeau.adb b/gcc/ada/libgnat/a-tigeau.adb new file mode 100644 index 0000000..34dac8b --- /dev/null +++ b/gcc/ada/libgnat/a-tigeau.adb @@ -0,0 +1,487 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; + +package body Ada.Text_IO.Generic_Aux is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + subtype AP is FCB.AFCB_Ptr; + + ------------------------ + -- Check_End_Of_Field -- + ------------------------ + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field) + is + begin + if Ptr > Stop then + return; + + elsif Width = 0 then + raise Data_Error; + + else + for J in Ptr .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + end if; + end Check_End_Of_Field; + + ----------------------- + -- Check_On_One_Line -- + ----------------------- + + procedure Check_On_One_Line + (File : File_Type; + Length : Integer) + is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Line_Length /= 0 then + if Count (Length) > File.Line_Length then + raise Layout_Error; + elsif File.Col + Count (Length) > File.Line_Length + 1 then + New_Line (File); + end if; + end if; + end Check_On_One_Line; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + -------------- + -- Is_Blank -- + -------------- + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + ---------- + -- Load -- + ---------- + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean) + is + ch : int; + + begin + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character) + is + ch : int; + + begin + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean) + is + ch : int; + + begin + ch := Getc (File); + + if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character) + is + ch : int; + + begin + ch := Getc (File); + + if ch = Character'Pos (Char1) or else ch = Character'Pos (Char2) then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end Load; + + ----------------- + -- Load_Digits -- + ----------------- + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean; + + begin + ch := Getc (File); + + if ch not in Character'Pos ('0') .. Character'Pos ('9') then + Loaded := False; + + else + Loaded := True; + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end Load_Digits; + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + After_Digit : Boolean; + + begin + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end Load_Digits; + + -------------------------- + -- Load_Extended_Digits -- + -------------------------- + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean := False; + + begin + Loaded := False; + + loop + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') + or else + ch in Character'Pos ('a') .. Character'Pos ('f') + or else + ch in Character'Pos ('A') .. Character'Pos ('F') + then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + end loop; + + Ungetc (ch, File); + end Load_Extended_Digits; + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + Junk : Boolean; + pragma Unreferenced (Junk); + begin + Load_Extended_Digits (File, Buf, Ptr, Junk); + end Load_Extended_Digits; + + --------------- + -- Load_Skip -- + --------------- + + procedure Load_Skip (File : File_Type) is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + -- Loop till we find a non-blank character (note that as usual in + -- Text_IO, blank includes horizontal tab). Note that Get deals with + -- the Before_LM and Before_LM_PM flags appropriately. + + loop + Get (File, C); + exit when not Is_Blank (C); + end loop; + + Ungetc (Character'Pos (C), File); + File.Col := File.Col - 1; + end Load_Skip; + + ---------------- + -- Load_Width -- + ---------------- + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are immediately before a line mark, then we have no characters. + -- This is always a data error, so we may as well raise it right away. + + if File.Before_LM then + raise Data_Error; + + else + for J in 1 .. Width loop + ch := Getc (File); + + if ch = EOF then + return; + + elsif ch = LM then + Ungetc (ch, File); + return; + + else + Store_Char (File, ch, Buf, Ptr); + end if; + end loop; + end if; + end Load_Width; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + else + return EOF; + end if; + + else + Ungetc (ch, File); + return ch; + end if; + end Nextc; + + -------------- + -- Put_Item -- + -------------- + + procedure Put_Item (File : File_Type; Str : String) is + begin + Check_On_One_Line (File, Str'Length); + Put (File, Str); + end Put_Item; + + ---------------- + -- Store_Char -- + ---------------- + + procedure Store_Char + (File : File_Type; + ch : int; + Buf : in out String; + Ptr : in out Integer) + is + begin + File.Col := File.Col + 1; + + if Ptr < Buf'Last then + Ptr := Ptr + 1; + end if; + + Buf (Ptr) := Character'Val (ch); + end Store_Char; + + ----------------- + -- String_Skip -- + ----------------- + + procedure String_Skip (Str : String; Ptr : out Integer) is + begin + -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. + -- It's too much trouble to make this silly case work, so we just raise + -- Program_Error with an appropriate message. We raise Program_Error + -- rather than Constraint_Error because we don't want this case to be + -- converted to Data_Error. + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + -- Normal case where Str'Last < Positive'Last + + Ptr := Str'First; + + loop + if Ptr > Str'Last then + raise End_Error; + + elsif not Is_Blank (Str (Ptr)) then + return; + + else + Ptr := Ptr + 1; + end if; + end loop; + end String_Skip; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + +end Ada.Text_IO.Generic_Aux; diff --git a/gcc/ada/libgnat/a-tigeau.ads b/gcc/ada/libgnat/a-tigeau.ads new file mode 100644 index 0000000..0b99ff7 --- /dev/null +++ b/gcc/ada/libgnat/a-tigeau.ads @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a set of auxiliary routines used by the Text_IO +-- generic children, including for reading and writing numeric strings. + +private package Ada.Text_IO.Generic_Aux is + + -- Note: for all the Load routines, File indicates the file to be read, + -- Buf is the string into which data is stored, Ptr is the index of the + -- last character stored so far, and is updated if additional characters + -- are stored. Data_Error is raised if the input overflows Buf. The only + -- Load routines that do a file status check are Load_Skip and Load_Width + -- so one of these two routines must be called first. + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field); + -- This routine is used after doing a get operations on a numeric value. + -- Buf is the string being scanned, and Stop is the last character of + -- the field being scanned. Ptr is as set by the call to the scan routine + -- that scanned out the numeric value, i.e. it points one past the last + -- character scanned, and Width is the width parameter from the Get call. + -- + -- There are two cases, if Width is non-zero, then a check is made that + -- the remainder of the field is all blanks. If Width is zero, then it + -- means that the scan routine scanned out only part of the field. We + -- have already scanned out the field that the ACVC tests seem to expect + -- us to read (even if it does not follow the syntax of the type being + -- scanned, e.g. allowing negative exponents in integers, and underscores + -- at the end of the string), so we just raise Data_Error. + + procedure Check_On_One_Line (File : File_Type; Length : Integer); + -- Check to see if item of length Integer characters can fit on + -- current line. Call New_Line if not, first checking that the + -- line length can accommodate Length characters, raise Layout_Error + -- if item is too large for a single line. + + function Getc (File : File_Type) return Integer; + -- Gets next character from file, which has already been checked for + -- being in read status, and returns the character read if no error + -- occurs. The result is EOF if the end of file was read. Note that + -- the Col value is not bumped, so it is the caller's responsibility + -- to bump it if necessary. + + function Is_Blank (C : Character) return Boolean; + -- Determines if C is a blank (space or tab) + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer); + -- Loads exactly Width characters, unless a line mark is encountered first + + procedure Load_Skip (File : File_Type); + -- Skips leading blanks and line and page marks, if the end of file is + -- read without finding a non-blank character, then End_Error is raised. + -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean); + -- If next character is Char, loads it, otherwise no characters are loaded + -- Loaded is set to indicate whether or not the character was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character); + -- Same as above, but no indication if character is loaded + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean); + -- If next character is Char1 or Char2, loads it, otherwise no characters + -- are loaded. Loaded is set to indicate whether or not one of the two + -- characters was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character); + -- Same as above, but no indication if character is loaded + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Loads a sequence of zero or more decimal digits. Loaded is set if + -- at least one digit is loaded. + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Like Load_Digits, but also allows extended digits a-f and A-F + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + function Nextc (File : File_Type) return Integer; + -- Like Getc, but includes a call to Ungetc, so that the file + -- pointer is not moved by the call. + + procedure Put_Item (File : File_Type; Str : String); + -- This routine is like Text_IO.Put, except that it checks for overflow + -- of bounded lines, as described in (RM A.10.6(8)). It is used for + -- all output of numeric values and of enumeration values. + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : in out String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow and + -- adjusting the column number in the file to reflect the fact + -- that a character has been acquired from the input stream. If + -- the character will not fit in the buffer it is stored in the + -- last character position of the buffer and Ptr is unchanged. + -- No exception is raised in this case, it is the caller's job + -- to raise Data_Error if the buffer fills up, so typically the + -- caller will make the buffer one character longer than needed. + + procedure String_Skip (Str : String; Ptr : out Integer); + -- Used in the Get from string procedures to skip leading blanks in the + -- string. Ptr is set to the index of the first non-blank. If the string + -- is all blanks, then the exception End_Error is raised, Note that blank + -- is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Ungetc (ch : Integer; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has + -- checked that the file is in read status. Device_Error is raised + -- if the character cannot be pushed back. An attempt to push back + -- an end of file (EOF) is ignored. + +private + pragma Inline (Is_Blank); + +end Ada.Text_IO.Generic_Aux; diff --git a/gcc/ada/libgnat/a-tigeli.adb b/gcc/ada/libgnat/a-tigeli.adb new file mode 100644 index 0000000..77b2179 --- /dev/null +++ b/gcc/ada/libgnat/a-tigeli.adb @@ -0,0 +1,241 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . G E T _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation of Ada.Text_IO.Get_Line is split into a subunit so that +-- different implementations can be used on different systems. This is the +-- standard implementation (it uses low level features not suitable for use +-- on virtual machines). + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +separate (Ada.Text_IO) +procedure Get_Line + (File : File_Type; + Item : out String; + Last : out Natural) +is + Chunk_Size : constant := 80; + -- We read into a fixed size auxiliary buffer. Because this buffer + -- needs to be pre-initialized, there is a trade-off between size and + -- speed. Experiments find returns are diminishing after 50 and this + -- size allows most lines to be processed with a single read. + + ch : int; + N : Natural; + + procedure memcpy (s1, s2 : chars; n : size_t); + pragma Import (C, memcpy); + + function memchr (s : chars; ch : int; n : size_t) return chars; + pragma Import (C, memchr); + + procedure memset (b : chars; ch : int; n : size_t); + pragma Import (C, memset); + + function Get_Chunk (N : Positive) return Natural; + -- Reads at most N - 1 characters into Item (Last + 1 .. Item'Last), + -- updating Last. Raises End_Error if nothing was read (End_Of_File). + -- Returns number of characters still to read (either 0 or 1) in + -- case of success. + + --------------- + -- Get_Chunk -- + --------------- + + function Get_Chunk (N : Positive) return Natural is + Buf : String (1 .. Chunk_Size); + S : constant chars := Buf (1)'Address; + P : chars; + + begin + if N = 1 then + return N; + end if; + + memset (S, 10, size_t (N)); + + if fgets (S, N, File.Stream) = Null_Address then + if ferror (File.Stream) /= 0 then + raise Device_Error; + + -- If incomplete last line, pretend we found a LM + + elsif Last >= Item'First then + return 0; + + else + raise End_Error; + end if; + end if; + + P := memchr (S, LM, size_t (N)); + + -- If no LM is found, the buffer got filled without reading a new + -- line. Otherwise, the LM is either one from the input, or else one + -- from the initialization, which means an incomplete end-of-line was + -- encountered. Only in first case the LM will be followed by a 0. + + if P = Null_Address then + pragma Assert (Buf (N) = ASCII.NUL); + memcpy (Item (Last + 1)'Address, + Buf (1)'Address, size_t (N - 1)); + Last := Last + N - 1; + + return 1; + + else + -- P points to the LM character. Set K so Buf (K) is the character + -- right before. + + declare + K : Natural := Natural (P - S); + + begin + -- If K + 2 is greater than N, then Buf (K + 1) cannot be a LM + -- character from the source file, as the call to fgets copied at + -- most N - 1 characters. Otherwise, either LM is a character from + -- the source file and then Buf (K + 2) should be 0, or LM is a + -- character put in Buf by memset and then Buf (K) is the 0 put in + -- by fgets. In both cases where LM does not come from the source + -- file, compensate. + + if K + 2 > N or else Buf (K + 2) /= ASCII.NUL then + + -- Incomplete last line, so remove the extra 0 + + pragma Assert (Buf (K) = ASCII.NUL); + K := K - 1; + end if; + + memcpy (Item (Last + 1)'Address, + Buf (1)'Address, size_t (K)); + Last := Last + K; + end; + + return 0; + end if; + end Get_Chunk; + +-- Start of processing for Get_Line + +begin + FIO.Check_Read_Status (AP (File)); + + -- Set Last to Item'First - 1 when no characters are read, as mandated by + -- Ada RM. In the case where Item'First is negative or null, this results + -- in Constraint_Error being raised. + + Last := Item'First - 1; + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Item'First > Item'Last then + return; + end if; + + N := Item'Last - Item'First + 1; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + while N >= Chunk_Size loop + if Get_Chunk (Chunk_Size) = 0 then + N := 0; + else + N := N - Chunk_Size + 1; + end if; + end loop; + + if N > 1 then + N := Get_Chunk (N); + end if; + + -- Almost there, only a little bit more to read + + if N = 1 then + ch := Getc (File); + + -- If we get EOF after already reading data, this is an incomplete + -- last line, in which case no End_Error should be raised. + + if ch = EOF then + if Last < Item'First then + raise End_Error; + + else -- All done + return; + end if; + + elsif ch /= LM then + + -- Buffer really is full without having seen LM, update col + + Last := Last + 1; + Item (Last) := Character'Val (ch); + File.Col := File.Col + Count (Last - Item'First + 1); + return; + end if; + end if; + end if; + + -- We have skipped past, but not stored, a line mark. Skip following + -- page mark if one follows, but do not do this for a non-regular file + -- (since otherwise we get annoying wait for an extra character) + + File.Line := File.Line + 1; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + + elsif File.Is_Regular_File then + ch := Getc (File); + + if ch = PM and then File.Is_Regular_File then + File.Line := 1; + File.Page := File.Page + 1; + else + Ungetc (ch, File); + end if; + end if; +end Get_Line; diff --git a/gcc/ada/libgnat/a-tiinau.adb b/gcc/ada/libgnat/a-tiinau.adb new file mode 100644 index 0000000..cf729b6 --- /dev/null +++ b/gcc/ada/libgnat/a-tiinau.adb @@ -0,0 +1,297 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; + +package body Ada.Text_IO.Integer_Aux is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load a possibly signed + -- integer literal value from the input file into Buf, starting at Ptr + 1. + -- On return, Ptr is set to the last character stored. + + ------------- + -- Get_Int -- + ------------- + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Int; + + ------------- + -- Get_LLI -- + ------------- + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLI; + + -------------- + -- Gets_Int -- + -------------- + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Int; + + -------------- + -- Gets_LLI -- + -------------- + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLI; + + ------------------ + -- Load_Integer -- + ------------------ + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based literal. We recognize either the standard '#' or + -- the allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Integer; + + ------------- + -- Put_Int -- + ------------- + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Integer'Max (Field'Last, Width)); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Int; + + ------------- + -- Put_LLI -- + ------------- + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Integer'Max (Field'Last, Width)); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLI; + + -------------- + -- Puts_Int -- + -------------- + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base) + is + Buf : String (1 .. Integer'Max (Field'Last, To'Length)); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Int; + + -------------- + -- Puts_LLI -- + -------------- + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base) + is + Buf : String (1 .. Integer'Max (Field'Last, To'Length)); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLI; + +end Ada.Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-tiinau.ads b/gcc/ada/libgnat/a-tiinau.ads new file mode 100644 index 0000000..d644e4a --- /dev/null +++ b/gcc/ada/libgnat/a-tiinau.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Text_IO.Integer_IO that are +-- shared among separate instantiations of this package. The routines in +-- this package are identical semantically to those in Integer_IO itself, +-- except that the generic parameter Num has been replaced by Integer or +-- Long_Long_Integer, and the default parameters have been removed because +-- they are supplied explicitly by the calls from within the generic template. + +private package Ada.Text_IO.Integer_Aux is + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field); + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field); + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base); + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base); + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive); + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive); + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base); + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base); + +end Ada.Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-tiinio.adb b/gcc/ada/libgnat/a-tiinio.adb new file mode 100644 index 0000000..b93dc6a --- /dev/null +++ b/gcc/ada/libgnat/a-tiinio.adb @@ -0,0 +1,154 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Integer_Aux; + +package body Ada.Text_IO.Integer_IO is + + package Aux renames Ada.Text_IO.Integer_Aux; + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + begin + if Need_LLI then + Aux.Get_LLI (File, Long_Long_Integer (Item), Width); + else + Aux.Get_Int (File, Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + begin + if Need_LLI then + Aux.Get_LLI (Current_In, Long_Long_Integer (Item), Width); + else + Aux.Get_Int (Current_In, Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + -- We depend on a range check to get Data_Error + + pragma Unsuppress (Range_Check); + pragma Unsuppress (Overflow_Check); + + begin + if Need_LLI then + Aux.Gets_LLI (From, Long_Long_Integer (Item), Last); + else + Aux.Gets_Int (From, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Put_LLI (File, Long_Long_Integer (Item), Width, Base); + else + Aux.Put_Int (File, Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Put_LLI (Current_Out, Long_Long_Integer (Item), Width, Base); + else + Aux.Put_Int (Current_Out, Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (To : out String; + Item : Num; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Puts_LLI (To, Long_Long_Integer (Item), Base); + else + Aux.Puts_Int (To, Integer (Item), Base); + end if; + end Put; + +end Ada.Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-tiinio.ads b/gcc/ada/libgnat/a-tiinio.ads new file mode 100644 index 0000000..7063631 --- /dev/null +++ b/gcc/ada/libgnat/a-tiinio.ads @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Integer_IO is a subpackage of Text_IO. +-- This is for compatibility with Ada 83. In GNAT we make it a child package +-- to avoid loading the necessary code if Integer_IO is not instantiated. +-- See routine Rtsfind.Check_Text_IO_Special_Unit for a description of how +-- we patch up the difference in semantics so that it is invisible to the +-- Ada programmer. + +private generic + type Num is range <>; + +package Ada.Text_IO.Integer_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out String; + Item : Num; + Base : Number_Base := Default_Base); + +private + pragma Inline (Get); + pragma Inline (Put); + +end Ada.Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-timoau.adb b/gcc/ada/libgnat/a-timoau.adb new file mode 100644 index 0000000..6322efc --- /dev/null +++ b/gcc/ada/libgnat/a-timoau.adb @@ -0,0 +1,305 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Generic_Aux; use Ada.Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; + +package body Ada.Text_IO.Modular_Aux is + + use System.Unsigned_Types; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load an possibly signed + -- modular literal value from the input file into Buf, starting at Ptr + 1. + -- Ptr is left set to the last character stored. + + ------------- + -- Get_LLU -- + ------------- + + procedure Get_LLU + (File : File_Type; + Item : out Long_Long_Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLU; + + ------------- + -- Get_Uns -- + ------------- + + procedure Get_Uns + (File : File_Type; + Item : out Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Uns; + + -------------- + -- Gets_LLU -- + -------------- + + procedure Gets_LLU + (From : String; + Item : out Long_Long_Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLU; + + -------------- + -- Gets_Uns -- + -------------- + + procedure Gets_Uns + (From : String; + Item : out Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Uns; + + ------------------ + -- Load_Modular -- + ------------------ + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + + -- Note: it is a bit strange to allow a minus sign here, but it seems + -- consistent with the general behavior expected by the ACVC tests + -- which is to scan past junk and then signal data error, see ACVC + -- test CE3704F, case (6), which is for signed integer exponents, + -- which seems a similar case. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants + -- for the signed case, and there seems no good reason to treat + -- exponents differently for the signed and unsigned cases. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Modular; + + ------------- + -- Put_LLU -- + ------------- + + procedure Put_LLU + (File : File_Type; + Item : Long_Long_Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLU; + + ------------- + -- Put_Uns -- + ------------- + + procedure Put_Uns + (File : File_Type; + Item : Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Uns; + + -------------- + -- Puts_LLU -- + -------------- + + procedure Puts_LLU + (To : out String; + Item : Long_Long_Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLU; + + -------------- + -- Puts_Uns -- + -------------- + + procedure Puts_Uns + (To : out String; + Item : Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Uns; + +end Ada.Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-timoau.ads b/gcc/ada/libgnat/a-timoau.ads new file mode 100644 index 0000000..da5556f --- /dev/null +++ b/gcc/ada/libgnat/a-timoau.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Text_IO.Modular_IO that are +-- shared among separate instantiations of this package. The routines in +-- this package are identical semantically to those in Modular_IO itself, +-- except that the generic parameter Num has been replaced by Unsigned or +-- Long_Long_Unsigned, and the default parameters have been removed because +-- they are supplied explicitly by the calls from within the generic template. + +with System.Unsigned_Types; + +private package Ada.Text_IO.Modular_Aux is + + package U renames System.Unsigned_Types; + + procedure Get_Uns + (File : File_Type; + Item : out U.Unsigned; + Width : Field); + + procedure Get_LLU + (File : File_Type; + Item : out U.Long_Long_Unsigned; + Width : Field); + + procedure Put_Uns + (File : File_Type; + Item : U.Unsigned; + Width : Field; + Base : Number_Base); + + procedure Put_LLU + (File : File_Type; + Item : U.Long_Long_Unsigned; + Width : Field; + Base : Number_Base); + + procedure Gets_Uns + (From : String; + Item : out U.Unsigned; + Last : out Positive); + + procedure Gets_LLU + (From : String; + Item : out U.Long_Long_Unsigned; + Last : out Positive); + + procedure Puts_Uns + (To : out String; + Item : U.Unsigned; + Base : Number_Base); + + procedure Puts_LLU + (To : out String; + Item : U.Long_Long_Unsigned; + Base : Number_Base); + +end Ada.Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-timoio.adb b/gcc/ada/libgnat/a-timoio.adb new file mode 100644 index 0000000..3e0430d --- /dev/null +++ b/gcc/ada/libgnat/a-timoio.adb @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO.Modular_Aux; + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body Ada.Text_IO.Modular_IO is + + package Aux renames Ada.Text_IO.Modular_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if Num'Size > Unsigned'Size then + Aux.Get_LLU (File, Long_Long_Unsigned (Item), Width); + else + Aux.Get_Uns (File, Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + pragma Unsuppress (Range_Check); + + begin + if Num'Size > Unsigned'Size then + Aux.Get_LLU (Current_In, Long_Long_Unsigned (Item), Width); + else + Aux.Get_Uns (Current_In, Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (From : String; + Item : out Num; + Last : out Positive) + is + pragma Unsuppress (Range_Check); + + begin + if Num'Size > Unsigned'Size then + Aux.Gets_LLU (From, Long_Long_Unsigned (Item), Last); + else + Aux.Gets_Uns (From, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Num'Size > Unsigned'Size then + Aux.Put_LLU (File, Long_Long_Unsigned (Item), Width, Base); + else + Aux.Put_Uns (File, Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Num'Size > Unsigned'Size then + Aux.Put_LLU (Current_Out, Long_Long_Unsigned (Item), Width, Base); + else + Aux.Put_Uns (Current_Out, Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (To : out String; + Item : Num; + Base : Number_Base := Default_Base) + is + begin + if Num'Size > Unsigned'Size then + Aux.Puts_LLU (To, Long_Long_Unsigned (Item), Base); + else + Aux.Puts_Uns (To, Unsigned (Item), Base); + end if; + end Put; + +end Ada.Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-timoio.ads b/gcc/ada/libgnat/a-timoio.ads new file mode 100644 index 0000000..d1ba92f --- /dev/null +++ b/gcc/ada/libgnat/a-timoio.ads @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1993-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Text_IO.Modular_IO is a subpackage of Text_IO. +-- This is for compatibility with Ada 83. In GNAT we make it a child package +-- to avoid loading the necessary code if Modular_IO is not instantiated. +-- See routine Rtsfind.Check_Text_IO_Special_Unit for a description of how +-- we patch up the difference in semantics so that it is invisible to the +-- Ada programmer. + +private generic + type Num is mod <>; + +package Ada.Text_IO.Modular_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out String; + Item : Num; + Base : Number_Base := Default_Base); + +private + pragma Inline (Get); + pragma Inline (Put); + +end Ada.Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-tiocst.adb b/gcc/ada/libgnat/a-tiocst.adb new file mode 100644 index 0000000..ac7d345 --- /dev/null +++ b/gcc/ada/libgnat/a-tiocst.adb @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with Ada.Unchecked_Conversion; + +package body Ada.Text_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'T', + Creat => False, + Text => True, + C_Stream => C_Stream); + end Open; + +end Ada.Text_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-tiocst.ads b/gcc/ada/libgnat/a-tiocst.ads new file mode 100644 index 0000000..b0c0229 --- /dev/null +++ b/gcc/ada/libgnat/a-tiocst.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Text_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +package Ada.Text_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Text_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-tirsfi.adb b/gcc/ada/libgnat/a-tirsfi.adb new file mode 100644 index 0000000..443bbe4 --- /dev/null +++ b/gcc/ada/libgnat/a-tirsfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-------------------------------------- +-- Ada.Text_IO.Reset_Standard_Files -- +-------------------------------------- + +procedure Ada.Text_IO.Reset_Standard_Files is +begin + Ada.Text_IO.Initialize_Standard_Files; +end Ada.Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/libgnat/a-tirsfi.ads b/gcc/ada/libgnat/a-tirsfi.ads new file mode 100644 index 0000000..1e436af --- /dev/null +++ b/gcc/ada/libgnat/a-tirsfi.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . R E S E T _ S T A N D A R D _ F I L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 reset routine that resets the standard files used +-- by Text_IO. This is useful in systems such as VxWorks where Ada.Text_IO is +-- elaborated at the program start, but a system restart may alter the status +-- of these files, resulting in incorrect operation of Text_IO (in particular +-- if the standard input file is changed to be interactive, then Get_Line may +-- hang looking for an extra character after the end of the line. + +procedure Ada.Text_IO.Reset_Standard_Files; +-- Reset standard Text_IO files as described above diff --git a/gcc/ada/libgnat/a-titest.adb b/gcc/ada/libgnat/a-titest.adb new file mode 100644 index 0000000..2093500 --- /dev/null +++ b/gcc/ada/libgnat/a-titest.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; + +package body Ada.Text_IO.Text_Streams is + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); + return Stream_Access (File); + end Stream; + +end Ada.Text_IO.Text_Streams; diff --git a/gcc/ada/libgnat/a-titest.ads b/gcc/ada/libgnat/a-titest.ads new file mode 100644 index 0000000..93cf47a --- /dev/null +++ b/gcc/ada/libgnat/a-titest.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; +package Ada.Text_IO.Text_Streams is + + type Stream_Access is access all Streams.Root_Stream_Type'Class; + + function Stream (File : File_Type) return Stream_Access; + +end Ada.Text_IO.Text_Streams; diff --git a/gcc/ada/libgnat/a-tiunio.ads b/gcc/ada/libgnat/a-tiunio.ads new file mode 100644 index 0000000..ea5caec --- /dev/null +++ b/gcc/ada/libgnat/a-tiunio.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . U N B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Unbounded. So we implement this new Ada 2005 package +-- by renaming the subprograms in that child. This is a more straightforward +-- implementation anyway, since we need access to the internal representation +-- of Ada.Strings.Unbounded.Unbounded_String. + +with Ada.Strings.Unbounded; +with Ada.Strings.Unbounded.Text_IO; + +package Ada.Text_IO.Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put; + + procedure Put + (Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put; + + procedure Put_Line + (File : Text_IO.File_Type; + Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Put_Line; + + function Get_Line + (File : File_Type) return Strings.Unbounded.Unbounded_String + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + function Get_Line return Strings.Unbounded.Unbounded_String + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Unbounded.Unbounded_String) + renames Ada.Strings.Unbounded.Text_IO.Get_Line; + +end Ada.Text_IO.Unbounded_IO; diff --git a/gcc/ada/libgnat/a-unccon.ads b/gcc/ada/libgnat/a-unccon.ads new file mode 100644 index 0000000..a8429c1 --- /dev/null +++ b/gcc/ada/libgnat/a-unccon.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . U N C H E C K E D _ C O N V E R S I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Source (<>) is limited private; + type Target (<>) is limited private; + +function Ada.Unchecked_Conversion (S : Source) return Target; + +pragma No_Elaboration_Code_All (Ada.Unchecked_Conversion); +pragma Pure (Ada.Unchecked_Conversion); +pragma Import (Intrinsic, Ada.Unchecked_Conversion); diff --git a/gcc/ada/libgnat/a-uncdea.ads b/gcc/ada/libgnat/a-uncdea.ads new file mode 100644 index 0000000..a61cd50 --- /dev/null +++ b/gcc/ada/libgnat/a-uncdea.ads @@ -0,0 +1,23 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . U N C H E C K E D _ D E A L L O C A T I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Object (<>) is limited private; + type Name is access Object; + +procedure Ada.Unchecked_Deallocation (X : in out Name); +pragma Preelaborate (Unchecked_Deallocation); + +pragma Import (Intrinsic, Ada.Unchecked_Deallocation); diff --git a/gcc/ada/libgnat/a-undesu.adb b/gcc/ada/libgnat/a-undesu.adb new file mode 100644 index 0000000..4fb4c17 --- /dev/null +++ b/gcc/ada/libgnat/a-undesu.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Pools.Subpools, + System.Storage_Pools.Subpools.Finalization; + +use System.Storage_Pools.Subpools, + System.Storage_Pools.Subpools.Finalization; + +procedure Ada.Unchecked_Deallocate_Subpool + (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle) +is +begin + Finalize_And_Deallocate (Subpool); +end Ada.Unchecked_Deallocate_Subpool; diff --git a/gcc/ada/libgnat/a-undesu.ads b/gcc/ada/libgnat/a-undesu.ads new file mode 100644 index 0000000..6665725 --- /dev/null +++ b/gcc/ada/libgnat/a-undesu.ads @@ -0,0 +1,19 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- A D A . U N C H E C K E D _ D E A L L O C A T E _ S U B P O O L -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Pools.Subpools; + +procedure Ada.Unchecked_Deallocate_Subpool + (Subpool : in out System.Storage_Pools.Subpools.Subpool_Handle); diff --git a/gcc/ada/libgnat/a-wichha.adb b/gcc/ada/libgnat/a-wichha.adb new file mode 100644 index 0000000..cd124f0 --- /dev/null +++ b/gcc/ada/libgnat/a-wichha.adb @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ C H A R A C T E R S . H A N D L I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Characters.Unicode; use Ada.Wide_Characters.Unicode; + +package body Ada.Wide_Characters.Handling is + + --------------------------- + -- Character_Set_Version -- + --------------------------- + + function Character_Set_Version return String is + begin + return "Unicode 4.0"; + end Character_Set_Version; + + --------------------- + -- Is_Alphanumeric -- + --------------------- + + function Is_Alphanumeric (Item : Wide_Character) return Boolean is + begin + return Is_Letter (Item) or else Is_Digit (Item); + end Is_Alphanumeric; + + ---------------- + -- Is_Control -- + ---------------- + + function Is_Control (Item : Wide_Character) return Boolean is + begin + return Get_Category (Item) = Cc; + end Is_Control; + + -------------- + -- Is_Digit -- + -------------- + + function Is_Digit (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Digit; + + ---------------- + -- Is_Graphic -- + ---------------- + + function Is_Graphic (Item : Wide_Character) return Boolean is + begin + return not Is_Non_Graphic (Item); + end Is_Graphic; + + -------------------------- + -- Is_Hexadecimal_Digit -- + -------------------------- + + function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean is + begin + return Is_Digit (Item) + or else Item in 'A' .. 'F' + or else Item in 'a' .. 'f'; + end Is_Hexadecimal_Digit; + + --------------- + -- Is_Letter -- + --------------- + + function Is_Letter (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Letter; + + ------------------------ + -- Is_Line_Terminator -- + ------------------------ + + function Is_Line_Terminator (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Line_Terminator; + + -------------- + -- Is_Lower -- + -------------- + + function Is_Lower (Item : Wide_Character) return Boolean is + begin + return Get_Category (Item) = Ll; + end Is_Lower; + + ------------- + -- Is_Mark -- + ------------- + + function Is_Mark (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Mark; + + --------------------- + -- Is_Other_Format -- + --------------------- + + function Is_Other_Format (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Other; + + ------------------------------ + -- Is_Punctuation_Connector -- + ------------------------------ + + function Is_Punctuation_Connector (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Punctuation; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (Item : Wide_Character) return Boolean + renames Ada.Wide_Characters.Unicode.Is_Space; + + ---------------- + -- Is_Special -- + ---------------- + + function Is_Special (Item : Wide_Character) return Boolean is + begin + return Is_Graphic (Item) and then not Is_Alphanumeric (Item); + end Is_Special; + + -------------- + -- Is_Upper -- + -------------- + + function Is_Upper (Item : Wide_Character) return Boolean is + begin + return Get_Category (Item) = Lu; + end Is_Upper; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (Item : Wide_Character) return Wide_Character + renames Ada.Wide_Characters.Unicode.To_Lower_Case; + + function To_Lower (Item : Wide_String) return Wide_String is + Result : Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Lower (Item (J)); + end loop; + + return Result; + end To_Lower; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper (Item : Wide_Character) return Wide_Character + renames Ada.Wide_Characters.Unicode.To_Upper_Case; + + function To_Upper (Item : Wide_String) return Wide_String is + Result : Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Upper (Item (J)); + end loop; + + return Result; + end To_Upper; + +end Ada.Wide_Characters.Handling; diff --git a/gcc/ada/libgnat/a-wichha.ads b/gcc/ada/libgnat/a-wichha.ads new file mode 100644 index 0000000..583308e --- /dev/null +++ b/gcc/ada/libgnat/a-wichha.ads @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ C H A R A C T E R S . H A N D L I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Characters.Handling is + pragma Pure; + + function Character_Set_Version return String; + pragma Inline (Character_Set_Version); + -- Returns an implementation-defined identifier that identifies the version + -- of the character set standard that is used for categorizing characters + -- by the implementation. For GNAT this is "Unicode v.v". + + function Is_Control (Item : Wide_Character) return Boolean; + pragma Inline (Is_Control); + -- Returns True if the Wide_Character designated by Item is categorized as + -- other_control, otherwise returns false. + + function Is_Letter (Item : Wide_Character) return Boolean; + pragma Inline (Is_Letter); + -- Returns True if the Wide_Character designated by Item is categorized as + -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, + -- letter_other, or number_letter. Otherwise returns false. + + function Is_Lower (Item : Wide_Character) return Boolean; + pragma Inline (Is_Lower); + -- Returns True if the Wide_Character designated by Item is categorized as + -- letter_lowercase, otherwise returns false. + + function Is_Upper (Item : Wide_Character) return Boolean; + pragma Inline (Is_Upper); + -- Returns True if the Wide_Character designated by Item is categorized as + -- letter_uppercase, otherwise returns false. + + function Is_Digit (Item : Wide_Character) return Boolean; + pragma Inline (Is_Digit); + -- Returns True if the Wide_Character designated by Item is categorized as + -- number_decimal, otherwise returns false. + + function Is_Decimal_Digit (Item : Wide_Character) return Boolean + renames Is_Digit; + + function Is_Hexadecimal_Digit (Item : Wide_Character) return Boolean; + -- Returns True if the Wide_Character designated by Item is categorized as + -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise + -- returns false. + + function Is_Alphanumeric (Item : Wide_Character) return Boolean; + pragma Inline (Is_Alphanumeric); + -- Returns True if the Wide_Character designated by Item is categorized as + -- number_decimal, or is in the range 'A' .. 'F' or 'a' .. 'f', otherwise + -- returns false. + + function Is_Special (Item : Wide_Character) return Boolean; + pragma Inline (Is_Special); + -- Returns True if the Wide_Character designated by Item is categorized + -- as graphic_character, but not categorized as letter_uppercase, + -- letter_lowercase, letter_titlecase, letter_modifier, letter_other, + -- number_letter, or number_decimal. Otherwise returns false. + + function Is_Line_Terminator (Item : Wide_Character) return Boolean; + pragma Inline (Is_Line_Terminator); + -- Returns True if the Wide_Character designated by Item is categorized as + -- separator_line or separator_paragraph, or if Item is a conventional line + -- terminator character (CR, LF, VT, or FF). Otherwise returns false. + + function Is_Mark (Item : Wide_Character) return Boolean; + pragma Inline (Is_Mark); + -- Returns True if the Wide_Character designated by Item is categorized as + -- mark_non_spacing or mark_spacing_combining, otherwise returns false. + + function Is_Other_Format (Item : Wide_Character) return Boolean; + pragma Inline (Is_Other_Format); + -- Returns True if the Wide_Character designated by Item is categorized as + -- other_format, otherwise returns false. + + function Is_Punctuation_Connector (Item : Wide_Character) return Boolean; + pragma Inline (Is_Punctuation_Connector); + -- Returns True if the Wide_Character designated by Item is categorized as + -- punctuation_connector, otherwise returns false. + + function Is_Space (Item : Wide_Character) return Boolean; + pragma Inline (Is_Space); + -- Returns True if the Wide_Character designated by Item is categorized as + -- separator_space, otherwise returns false. + + function Is_Graphic (Item : Wide_Character) return Boolean; + pragma Inline (Is_Graphic); + -- Returns True if the Wide_Character designated by Item is categorized as + -- graphic_character, otherwise returns false. + + function To_Lower (Item : Wide_Character) return Wide_Character; + pragma Inline (To_Lower); + -- Returns the Simple Lowercase Mapping of the Wide_Character designated by + -- Item. If the Simple Lowercase Mapping does not exist for the + -- Wide_Character designated by Item, then the value of Item is returned. + + function To_Lower (Item : Wide_String) return Wide_String; + -- Returns the result of applying the To_Lower Wide_Character to + -- Wide_Character conversion to each element of the Wide_String designated + -- by Item. The result is the null Wide_String if the value of the formal + -- parameter is the null Wide_String. + + function To_Upper (Item : Wide_Character) return Wide_Character; + pragma Inline (To_Upper); + -- Returns the Simple Uppercase Mapping of the Wide_Character designated by + -- Item. If the Simple Uppercase Mapping does not exist for the + -- Wide_Character designated by Item, then the value of Item is returned. + + function To_Upper (Item : Wide_String) return Wide_String; + -- Returns the result of applying the To_Upper Wide_Character to + -- Wide_Character conversion to each element of the Wide_String designated + -- by Item. The result is the null Wide_String if the value of the formal + -- parameter is the null Wide_String. + +end Ada.Wide_Characters.Handling; diff --git a/gcc/ada/libgnat/a-wichun.adb b/gcc/ada/libgnat/a-wichun.adb new file mode 100644 index 0000000..a58ccd3 --- /dev/null +++ b/gcc/ada/libgnat/a-wichun.adb @@ -0,0 +1,178 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ C H A R A C T E R T S . U N I C O D E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Wide_Characters.Unicode is + + package G renames System.UTF_32; + + ------------------ + -- Get_Category -- + ------------------ + + function Get_Category (U : Wide_Character) return Category is + begin + return Category (G.Get_Category (Wide_Character'Pos (U))); + end Get_Category; + + -------------- + -- Is_Digit -- + -------------- + + function Is_Digit (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Digit (Wide_Character'Pos (U)); + end Is_Digit; + + function Is_Digit (C : Category) return Boolean is + begin + return G.Is_UTF_32_Digit (G.Category (C)); + end Is_Digit; + + --------------- + -- Is_Letter -- + --------------- + + function Is_Letter (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Letter (Wide_Character'Pos (U)); + end Is_Letter; + + function Is_Letter (C : Category) return Boolean is + begin + return G.Is_UTF_32_Letter (G.Category (C)); + end Is_Letter; + + ------------------------ + -- Is_Line_Terminator -- + ------------------------ + + function Is_Line_Terminator (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Line_Terminator (Wide_Character'Pos (U)); + end Is_Line_Terminator; + + ------------- + -- Is_Mark -- + ------------- + + function Is_Mark (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Mark (Wide_Character'Pos (U)); + end Is_Mark; + + function Is_Mark (C : Category) return Boolean is + begin + return G.Is_UTF_32_Mark (G.Category (C)); + end Is_Mark; + + -------------------- + -- Is_Non_Graphic -- + -------------------- + + function Is_Non_Graphic (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Non_Graphic (Wide_Character'Pos (U)); + end Is_Non_Graphic; + + function Is_Non_Graphic (C : Category) return Boolean is + begin + return G.Is_UTF_32_Non_Graphic (G.Category (C)); + end Is_Non_Graphic; + + -------------- + -- Is_Other -- + -------------- + + function Is_Other (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Other (Wide_Character'Pos (U)); + end Is_Other; + + function Is_Other (C : Category) return Boolean is + begin + return G.Is_UTF_32_Other (G.Category (C)); + end Is_Other; + + -------------------- + -- Is_Punctuation -- + -------------------- + + function Is_Punctuation (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Punctuation (Wide_Character'Pos (U)); + end Is_Punctuation; + + function Is_Punctuation (C : Category) return Boolean is + begin + return G.Is_UTF_32_Punctuation (G.Category (C)); + end Is_Punctuation; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (U : Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Space (Wide_Character'Pos (U)); + end Is_Space; + + function Is_Space (C : Category) return Boolean is + begin + return G.Is_UTF_32_Space (G.Category (C)); + end Is_Space; + + ------------------- + -- To_Lower_Case -- + ------------------- + + function To_Lower_Case + (U : Wide_Character) return Wide_Character + is + begin + return + Wide_Character'Val + (G.UTF_32_To_Lower_Case (Wide_Character'Pos (U))); + end To_Lower_Case; + + ------------------- + -- To_Upper_Case -- + ------------------- + + function To_Upper_Case + (U : Wide_Character) return Wide_Character + is + begin + return + Wide_Character'Val + (G.UTF_32_To_Upper_Case (Wide_Character'Pos (U))); + end To_Upper_Case; + +end Ada.Wide_Characters.Unicode; diff --git a/gcc/ada/libgnat/a-wichun.ads b/gcc/ada/libgnat/a-wichun.ads new file mode 100644 index 0000000..a014402 --- /dev/null +++ b/gcc/ada/libgnat/a-wichun.ads @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ C H A R A C T E R S . U N I C O D E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Unicode categorization routines for Wide_Character. Note that this +-- package is strictly speaking Ada 2005 (since it is a child of an +-- Ada 2005 unit), but we make it available in Ada 95 mode, since it +-- only deals with wide characters. + +with System.UTF_32; + +package Ada.Wide_Characters.Unicode is + pragma Pure; + + -- The following type defines the categories from the unicode definitions. + -- The one addition we make is Fe, which represents the characters FFFE + -- and FFFF in any of the planes. + + type Category is new System.UTF_32.Category; + -- Cc Other, Control + -- Cf Other, Format + -- Cn Other, Not Assigned + -- Co Other, Private Use + -- Cs Other, Surrogate + -- Ll Letter, Lowercase + -- Lm Letter, Modifier + -- Lo Letter, Other + -- Lt Letter, Titlecase + -- Lu Letter, Uppercase + -- Mc Mark, Spacing Combining + -- Me Mark, Enclosing + -- Mn Mark, Nonspacing + -- Nd Number, Decimal Digit + -- Nl Number, Letter + -- No Number, Other + -- Pc Punctuation, Connector + -- Pd Punctuation, Dash + -- Pe Punctuation, Close + -- Pf Punctuation, Final quote + -- Pi Punctuation, Initial quote + -- Po Punctuation, Other + -- Ps Punctuation, Open + -- Sc Symbol, Currency + -- Sk Symbol, Modifier + -- Sm Symbol, Math + -- So Symbol, Other + -- Zl Separator, Line + -- Zp Separator, Paragraph + -- Zs Separator, Space + -- Fe relative position FFFE/FFFF in plane + + function Get_Category (U : Wide_Character) return Category; + pragma Inline (Get_Category); + -- Given a Wide_Character, returns corresponding Category, or Cn if the + -- code does not have an assigned unicode category. + + -- The following functions perform category tests corresponding to lexical + -- classes defined in the Ada standard. There are two interfaces for each + -- function. The second takes a Category (e.g. returned by Get_Category). + -- The first takes a Wide_Character. The form taking the Wide_Character is + -- typically more efficient than calling Get_Category, but if several + -- different tests are to be performed on the same code, it is more + -- efficient to use Get_Category to get the category, then test the + -- resulting category. + + function Is_Letter (U : Wide_Character) return Boolean; + function Is_Letter (C : Category) return Boolean; + pragma Inline (Is_Letter); + -- Returns true iff U is a letter that can be used to start an identifier, + -- or if C is one of the corresponding categories, which are the following: + -- Letter, Uppercase (Lu) + -- Letter, Lowercase (Ll) + -- Letter, Titlecase (Lt) + -- Letter, Modifier (Lm) + -- Letter, Other (Lo) + -- Number, Letter (Nl) + + function Is_Digit (U : Wide_Character) return Boolean; + function Is_Digit (C : Category) return Boolean; + pragma Inline (Is_Digit); + -- Returns true iff U is a digit that can be used to extend an identifer, + -- or if C is one of the corresponding categories, which are the following: + -- Number, Decimal_Digit (Nd) + + function Is_Line_Terminator (U : Wide_Character) return Boolean; + pragma Inline (Is_Line_Terminator); + -- Returns true iff U is an allowed line terminator for source programs, + -- if U is in the category Zp (Separator, Paragaph), or Zs (Separator, + -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). + -- There is no category version for this function, since the set of + -- characters does not correspond to a set of Unicode categories. + + function Is_Mark (U : Wide_Character) return Boolean; + function Is_Mark (C : Category) return Boolean; + pragma Inline (Is_Mark); + -- Returns true iff U is a mark character which can be used to extend an + -- identifier, or if C is one of the corresponding categories, which are + -- the following: + -- Mark, Non-Spacing (Mn) + -- Mark, Spacing Combining (Mc) + + function Is_Other (U : Wide_Character) return Boolean; + function Is_Other (C : Category) return Boolean; + pragma Inline (Is_Other); + -- Returns true iff U is an other format character, which means that it + -- can be used to extend an identifier, but is ignored for the purposes of + -- matching of identiers, or if C is one of the corresponding categories, + -- which are the following: + -- Other, Format (Cf) + + function Is_Punctuation (U : Wide_Character) return Boolean; + function Is_Punctuation (C : Category) return Boolean; + pragma Inline (Is_Punctuation); + -- Returns true iff U is a punctuation character that can be used to + -- separate pices of an identifier, or if C is one of the corresponding + -- categories, which are the following: + -- Punctuation, Connector (Pc) + + function Is_Space (U : Wide_Character) return Boolean; + function Is_Space (C : Category) return Boolean; + pragma Inline (Is_Space); + -- Returns true iff U is considered a space to be ignored, or if C is one + -- of the corresponding categories, which are the following: + -- Separator, Space (Zs) + + function Is_Non_Graphic (U : Wide_Character) return Boolean; + function Is_Non_Graphic (C : Category) return Boolean; + pragma Inline (Is_Non_Graphic); + -- Returns true iff U is considered to be a non-graphic character, or if C + -- is one of the corresponding categories, which are the following: + -- Other, Control (Cc) + -- Other, Private Use (Co) + -- Other, Surrogate (Cs) + -- Separator, Line (Zl) + -- Separator, Paragraph (Zp) + -- FFFE or FFFF positions in any plane (Fe) + -- + -- Note that the Ada category format effector is subsumed by the above + -- list of Unicode categories. + -- + -- Note that Other, Unassiged (Cn) is quite deliberately not included + -- in the list of categories above. This means that should any of these + -- code positions be defined in future with graphic characters they will + -- be allowed without a need to change implementations or the standard. + -- + -- Note that Other, Format (Cf) is also quite deliberately not included + -- in the list of categories above. This means that these characters can + -- be included in character and string literals. + + -- The following function is used to fold to upper case, as required by + -- the Ada 2005 standard rules for identifier case folding. Two + -- identifiers are equivalent if they are identical after folding all + -- letters to upper case using this routine. A corresponding function to + -- fold to lower case is also provided. + + function To_Lower_Case (U : Wide_Character) return Wide_Character; + pragma Inline (To_Lower_Case); + -- If U represents an upper case letter, returns the corresponding lower + -- case letter, otherwise U is returned unchanged. The folding is locale + -- independent as defined by documents referenced in the note in section + -- 1 of ISO/IEC 10646:2003 + + function To_Upper_Case (U : Wide_Character) return Wide_Character; + pragma Inline (To_Upper_Case); + -- If U represents a lower case letter, returns the corresponding upper + -- case letter, otherwise U is returned unchanged. The folding is locale + -- independent as defined by documents referenced in the note in section + -- 1 of ISO/IEC 10646:2003 + +end Ada.Wide_Characters.Unicode; diff --git a/gcc/ada/libgnat/a-widcha.ads b/gcc/ada/libgnat/a-widcha.ads new file mode 100644 index 0000000..a5dde73 --- /dev/null +++ b/gcc/ada/libgnat/a-widcha.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ C H A R A C T E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: strictly this is an Ada 2005 package, but we make it freely +-- available in Ada 95 mode, since it deals only with wide characters. + +package Ada.Wide_Characters is + pragma Pure; +end Ada.Wide_Characters; diff --git a/gcc/ada/libgnat/a-witeio.adb b/gcc/ada/libgnat/a-witeio.adb new file mode 100644 index 0000000..aadc5ee --- /dev/null +++ b/gcc/ada/libgnat/a-witeio.adb @@ -0,0 +1,1965 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.CRTL; +with System.File_IO; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +pragma Elaborate_All (System.File_IO); +-- Needed because of calls to Chain_File in package body elaboration + +package body Ada.Wide_Text_IO is + + package FIO renames System.File_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + + use type System.CRTL.size_t; + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist. + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Character; + -- This routine is identical to Get_Wide_Char, except that the reads are + -- done in Get_Immediate mode (i.e. without waiting for a line return). + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + + procedure Set_WCEM (File : in out File_Type); + -- Called by Open and Create to set the wide character encoding method for + -- the file, processing a WCEM form parameter if one is present. File is + -- IN OUT because it may be closed in case of an error. + + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate + (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr + is + pragma Unreferenced (Control_Block); + begin + return new Wide_Text_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + procedure AFCB_Close (File : not null access Wide_Text_AFCB) is + begin + -- If the file being closed is one of the current files, then close + -- the corresponding current file. It is not clear that this action + -- is required (RM A.10.3(23)) but it seems reasonable, and besides + -- ACVC test CE3208A expects this behavior. + + if File_Type (File) = Current_In then + Current_In := null; + elsif File_Type (File) = Current_Out then + Current_Out := null; + elsif File_Type (File) = Current_Err then + Current_Err := null; + end if; + + Terminate_Line (File_Type (File)); + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Wide_Text_AFCB) is + type FCB_Ptr is access all Wide_Text_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is + new Ada.Unchecked_Deallocation (Wide_Text_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + --------- + -- Col -- + --------- + + -- Note: we assume that it is impossible in practice for the column + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Col (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Col; + end Col; + + function Col return Positive_Count is + begin + return Col (Current_Out); + end Col; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => True, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Create; + + ------------------- + -- Current_Error -- + ------------------- + + function Current_Error return File_Type is + begin + return Current_Err; + end Current_Error; + + function Current_Error return File_Access is + begin + return Current_Err.Self'Access; + end Current_Error; + + ------------------- + -- Current_Input -- + ------------------- + + function Current_Input return File_Type is + begin + return Current_In; + end Current_Input; + + function Current_Input return File_Access is + begin + return Current_In.Self'Access; + end Current_Input; + + -------------------- + -- Current_Output -- + -------------------- + + function Current_Output return File_Type is + begin + return Current_Out; + end Current_Output; + + function Current_Output return File_Access is + begin + return Current_Out.Self'Access; + end Current_Output; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return Nextc (File) = EOF; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch = PM and then File.Is_Regular_File then + File.Before_LM_PM := True; + return Nextc (File) = EOF; + + -- Here if neither EOF nor PM followed end of line + + else + Ungetc (ch, File); + return False; + end if; + + end End_Of_File; + + function End_Of_File return Boolean is + begin + return End_Of_File (Current_In); + end End_Of_File; + + ----------------- + -- End_Of_Line -- + ----------------- + + function End_Of_Line (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + return False; + + elsif File.Before_LM then + return True; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + else + Ungetc (ch, File); + return (ch = LM); + end if; + end if; + end End_Of_Line; + + function End_Of_Line return Boolean is + begin + return End_Of_Line (Current_In); + end End_Of_Line; + + ----------------- + -- End_Of_Page -- + ----------------- + + function End_Of_Page (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if not File.Is_Regular_File then + return False; + + elsif File.Before_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return True; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Nextc (File); + + return ch = PM or else ch = EOF; + end End_Of_Page; + + function End_Of_Page return Boolean is + begin + return End_Of_Page (Current_In); + end End_Of_Page; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + procedure Flush is + begin + Flush (Current_Out); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Wide_Character) + is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + File.Before_Wide_Character := False; + Item := File.Saved_Wide_Character; + + -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same??? + + else + Get_Character (File, C); + Item := Get_Wide_Char (C, File); + end if; + end Get; + + procedure Get (Item : out Wide_Character) is + begin + Get (Current_In, Item); + end Get; + + procedure Get + (File : File_Type; + Item : out Wide_String) + is + begin + for J in Item'Range loop + Get (File, Item (J)); + end loop; + end Get; + + procedure Get (Item : out Wide_String) is + begin + Get (Current_In, Item); + end Get; + + ------------------- + -- Get_Character -- + ------------------- + + procedure Get_Character + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + + else + File.Line := File.Line + 1; + end if; + end if; + + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item := Character'Val (ch); + File.Col := File.Col + 1; + return; + end if; + end loop; + end Get_Character; + + ------------------- + -- Get_Immediate -- + ------------------- + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Character then + File.Before_Wide_Character := False; + Item := File.Saved_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Character) + is + begin + Get_Immediate (Current_In, Item); + end Get_Immediate; + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Character; + Available : out Boolean) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + Available := True; + + if File.Before_Wide_Character then + File.Before_Wide_Character := False; + Item := File.Saved_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Character'Val (LM); + + else + -- Shouldn't we use getc_immediate_nowait here, like Text_IO??? + + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Character; + Available : out Boolean) + is + begin + Get_Immediate (Current_In, Item, Available); + end Get_Immediate; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_String; + Last : out Natural) + is + begin + FIO.Check_Read_Status (AP (File)); + Last := Item'First - 1; + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Last >= Item'Last then + return; + end if; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + -- If we are at the end of file now, it means we are trying to + -- skip a file terminator and we raise End_Error (RM A.10.7(20)) + + if Nextc (File) = EOF then + raise End_Error; + end if; + + -- Loop through characters in string + + loop + -- Exit the loop if read is terminated by encountering line mark + -- Note that the use of Skip_Line here ensures we properly deal + -- with setting the page and line numbers. + + if End_Of_Line (File) then + Skip_Line (File); + return; + end if; + + -- Otherwise store the character, note that we know that ch is + -- something other than LM or EOF. It could possibly be a page + -- mark if there is a stray page mark in the middle of a line, but + -- this is not an official page mark in any case, since official + -- page marks can only follow a line mark. The whole page business + -- is pretty much nonsense anyway, so we do not want to waste + -- time trying to make sense out of non-standard page marks in + -- the file. This means that the behavior of Get_Line is different + -- from repeated Get of a character, but that's too bad. We + -- only promise that page numbers etc make sense if the file + -- is formatted in a standard manner. + + -- Note: we do not adjust the column number because it is quicker + -- to adjust it once at the end of the operation than incrementing + -- it each time around the loop. + + Last := Last + 1; + Get (File, Item (Last)); + + -- All done if the string is full, this is the case in which + -- we do not skip the following line mark. We need to adjust + -- the column number in this case. + + if Last = Item'Last then + File.Col := File.Col + Count (Item'Length); + return; + end if; + + -- Exit from the loop if we are at the end of file. This happens + -- if we have a last line that is not terminated with a line mark. + -- In this case we consider that there is an implied line mark; + -- this is a non-standard file, but we will treat it nicely. + + exit when Nextc (File) = EOF; + end loop; + end if; + end Get_Line; + + procedure Get_Line + (Item : out Wide_String; + Last : out Natural) + is + begin + Get_Line (Current_In, Item, Last); + end Get_Line; + + function Get_Line (File : File_Type) return Wide_String is + Buffer : Wide_String (1 .. 500); + Last : Natural; + + function Get_Rest (S : Wide_String) return Wide_String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : Wide_String) return Wide_String is + + -- Each time we allocate a buffer the same size as what we have + -- read so far. This limits us to a logarithmic number of calls + -- to Get_Rest and also ensures only a linear use of stack space. + + Buffer : Wide_String (1 .. S'Length); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant Wide_String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + else + return Get_Rest (R); + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Get_Rest (Buffer (1 .. Last)); + end if; + end Get_Line; + + function Get_Line return Wide_String is + begin + return Get_Line (Current_In); + end Get_Line; + + ------------------- + -- Get_Wide_Char -- + ------------------- + + function Get_Wide_Char + (C : Character; + File : File_Type) return Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Char + + begin + FIO.Check_Read_Status (AP (File)); + return WC_In (C, File.WC_Method); + end Get_Wide_Char; + + ------------------------- + -- Get_Wide_Char_Immed -- + ------------------------- + + function Get_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_Wide_Char (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc_Immed (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Char_Immed + + begin + FIO.Check_Read_Status (AP (File)); + return WC_In (C, File.WC_Method); + end Get_Wide_Char_Immed; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + ---------------- + -- Getc_Immed -- + ---------------- + + function Getc_Immed (File : File_Type) return int is + ch : int; + end_of_file : int; + + procedure getc_immediate + (stream : FILEs; ch : out int; end_of_file : out int); + pragma Import (C, getc_immediate, "getc_immediate"); + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := LM; + + else + getc_immediate (File.Stream, ch, end_of_file); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + elsif end_of_file /= 0 then + return EOF; + end if; + end if; + + return ch; + end Getc_Immed; + + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Text_Encoding := Default_Text; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Text_Encoding := Default_Text; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Text_Encoding := Default_Text; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Line -- + ---------- + + -- Note: we assume that it is impossible in practice for the line to exceed + -- the value of Count'Last, i.e. no check is required for overflow raising + -- layout error. + + function Line (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Line; + end Line; + + function Line return Positive_Count is + begin + return Line (Current_Out); + end Line; + + ----------------- + -- Line_Length -- + ----------------- + + function Line_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Line_Length; + end Line_Length; + + function Line_Length return Count is + begin + return Line_Length (Current_Out); + end Line_Length; + + ---------------- + -- Look_Ahead -- + ---------------- + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Character; + End_Of_Line : out Boolean) + is + ch : int; + + -- Start of processing for Look_Ahead + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are logically before a line mark, we can return immediately + + if File.Before_LM then + End_Of_Line := True; + Item := Wide_Character'Val (0); + + -- If we are before a wide character, just return it (this can happen + -- if there are two calls to Look_Ahead in a row). + + elsif File.Before_Wide_Character then + End_Of_Line := False; + Item := File.Saved_Wide_Character; + + -- otherwise we must read a character from the input stream + + else + ch := Getc (File); + + if ch = LM + or else ch = EOF + or else (ch = EOF and then File.Is_Regular_File) + then + End_Of_Line := True; + Ungetc (ch, File); + Item := Wide_Character'Val (0); + + -- Case where character obtained does not represent the start of an + -- encoded sequence so it stands for itself and we can unget it with + -- no difficulty. + + elsif not Is_Start_Of_Encoding + (Character'Val (ch), File.WC_Method) + then + End_Of_Line := False; + Ungetc (ch, File); + Item := Wide_Character'Val (ch); + + -- For the start of an encoding, we read the character using the + -- Get_Wide_Char routine. It will occupy more than one byte so we + -- can't put it back with ungetc. Instead we save it in the control + -- block, setting a flag that everyone interested in reading + -- characters must test before reading the stream. + + else + Item := Get_Wide_Char (Character'Val (ch), File); + End_Of_Line := False; + File.Saved_Wide_Character := Item; + File.Before_Wide_Character := True; + end if; + end if; + end Look_Ahead; + + procedure Look_Ahead + (Item : out Wide_Character; + End_Of_Line : out Boolean) + is + begin + Look_Ahead (Current_In, Item, End_Of_Line); + end Look_Ahead; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_TIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + + for K in 1 .. Spacing loop + + -- We use Put here (rather than Putc) so that we get the proper + -- behavior on windows for output of Wide_String to the console. + + Put (File, Wide_Character'Val (LM)); + + File.Line := File.Line + 1; + + if File.Page_Length /= 0 and then File.Line > File.Page_Length then + + -- Same situation as above, use Put instead of Putc + + Put (File, Wide_Character'Val (PM)); + + File.Line := 1; + File.Page := File.Page + 1; + end if; + end loop; + + File.Col := 1; + end New_Line; + + procedure New_Line (Spacing : Positive_Count := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + -------------- + -- New_Page -- + -------------- + + procedure New_Page (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Col /= 1 or else File.Line = 1 then + Putc (LM, File); + end if; + + Putc (PM, File); + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + end New_Page; + + procedure New_Page is + begin + New_Page (Current_Out); + end New_Page; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + + else + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + + return ch; + end Nextc; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Open; + + ---------- + -- Page -- + ---------- + + -- Note: we assume that it is impossible in practice for the page + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Page (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Page; + end Page; + + function Page return Positive_Count is + begin + return Page (Current_Out); + end Page; + + ----------------- + -- Page_Length -- + ----------------- + + function Page_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Page_Length; + end Page_Length; + + function Page_Length return Count is + begin + return Page_Length (Current_Out); + end Page_Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Character) + is + wide_text_translation_required : Integer; + pragma Import + (C, wide_text_translation_required, + "__gnat_wide_text_translation_required"); + -- Text translation is required on Windows only. This means that the + -- console is doing translation and we do not want to do any encoding + -- here. If this variable is not 0 we output the character via fputwc. + + procedure Out_Char (C : Character); + -- Procedure to output one character of a wide character sequence + + procedure WC_Out is new Wide_Char_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + Putc (Character'Pos (C), File); + end Out_Char; + + Discard : int; + + -- Start of processing for Put + + begin + FIO.Check_Write_Status (AP (File)); + + if wide_text_translation_required /= 0 + or else File.Text_Encoding in Non_Default_Text_Content_Encoding + then + set_mode (fileno (File.Stream), File.Text_Encoding); + Discard := fputwc (Wide_Character'Pos (Item), File.Stream); + else + WC_Out (Item, File.WC_Method); + end if; + + File.Col := File.Col + 1; + end Put; + + procedure Put (Item : Wide_Character) is + begin + Put (Current_Out, Item); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_String) + is + begin + for J in Item'Range loop + Put (File, Item (J)); + end loop; + end Put; + + procedure Put (Item : Wide_String) is + begin + Put (Current_Out, Item); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_String) + is + begin + Put (File, Item); + New_Line (File); + end Put_Line; + + procedure Put_Line (Item : Wide_String) is + begin + Put (Current_Out, Item); + New_Line (Current_Out); + end Put_Line; + + ---------- + -- Putc -- + ---------- + + procedure Putc (ch : int; File : File_Type) is + begin + if fputc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end Putc; + + ---------- + -- Read -- + ---------- + + -- This is the primitive Stream Read routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Read + (File : in out Wide_Text_AFCB; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Discard_ch : int; + pragma Unreferenced (Discard_ch); + + begin + -- Need to deal with Before_Wide_Character ??? + + if File.Mode /= FCB.In_File then + raise Mode_Error; + end if; + + -- Deal with case where our logical and physical position do not match + -- because of being after an LM or LM-PM sequence when in fact we are + -- logically positioned before it. + + if File.Before_LM then + + -- If we are before a PM, then it is possible for a stream read + -- to leave us after the LM and before the PM, which is a bit + -- odd. The easiest way to deal with this is to unget the PM, + -- so we are indeed positioned between the characters. This way + -- further stream read operations will work correctly, and the + -- effect on text processing is a little weird, but what can + -- be expected if stream and text input are mixed this way? + + if File.Before_LM_PM then + Discard_ch := ungetc (PM, File.Stream); + File.Before_LM_PM := False; + end if; + + File.Before_LM := False; + + Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); + + if Item'Length = 1 then + Last := Item'Last; + + else + Last := + Item'First + + Stream_Element_Offset + (fread (buffer => Item'Address, + index => size_t (Item'First + 1), + size => 1, + count => Item'Length - 1, + stream => File.Stream)); + end if; + + return; + end if; + + -- Now we do the read. Since this is a text file, it is normally in + -- text mode, but stream data must be read in binary mode, so we + -- temporarily set binary mode for the read, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + Last := + Item'First + + Stream_Element_Offset + (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; + + if Last < Item'Last then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end if; + + set_text_mode (fileno (File.Stream)); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset + (File : in out File_Type; + Mode : File_Mode) + is + begin + -- Don't allow change of mode for current file (RM A.10.2(5)) + + if (File = Current_In or else + File = Current_Out or else + File = Current_Error) + and then To_FCB (Mode) /= File.Mode + then + raise Mode_Error; + end if; + + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + ------------- + -- Set_Col -- + ------------- + + procedure Set_Col + (File : File_Type; + To : Positive_Count) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Col then + return; + end if; + + if Mode (File) >= Out_File then + if File.Line_Length /= 0 and then To > File.Line_Length then + raise Layout_Error; + end if; + + if To < File.Col then + New_Line (File); + end if; + + while File.Col < To loop + Put (File, ' '); + end loop; + + else + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + + elsif To = File.Col then + Ungetc (ch, File); + return; + + else + File.Col := File.Col + 1; + end if; + end loop; + end if; + end Set_Col; + + procedure Set_Col (To : Positive_Count) is + begin + Set_Col (Current_Out, To); + end Set_Col; + + --------------- + -- Set_Error -- + --------------- + + procedure Set_Error (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Err := File; + end Set_Error; + + --------------- + -- Set_Input -- + --------------- + + procedure Set_Input (File : File_Type) is + begin + FIO.Check_Read_Status (AP (File)); + Current_In := File; + end Set_Input; + + -------------- + -- Set_Line -- + -------------- + + procedure Set_Line + (File : File_Type; + To : Positive_Count) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Line then + return; + end if; + + if Mode (File) >= Out_File then + if File.Page_Length /= 0 and then To > File.Page_Length then + raise Layout_Error; + end if; + + if To < File.Line then + New_Page (File); + end if; + + while File.Line < To loop + New_Line (File); + end loop; + + else + while To /= File.Line loop + Skip_Line (File); + end loop; + end if; + end Set_Line; + + procedure Set_Line (To : Positive_Count) is + begin + Set_Line (Current_Out, To); + end Set_Line; + + --------------------- + -- Set_Line_Length -- + --------------------- + + procedure Set_Line_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Line_Length := To; + end Set_Line_Length; + + procedure Set_Line_Length (To : Count) is + begin + Set_Line_Length (Current_Out, To); + end Set_Line_Length; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Out := File; + end Set_Output; + + --------------------- + -- Set_Page_Length -- + --------------------- + + procedure Set_Page_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Page_Length := To; + end Set_Page_Length; + + procedure Set_Page_Length (To : Count) is + begin + Set_Page_Length (Current_Out, To); + end Set_Page_Length; + + -------------- + -- Set_WCEM -- + -------------- + + procedure Set_WCEM (File : in out File_Type) is + Start : Natural; + Stop : Natural; + + begin + FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); + + if Start = 0 then + File.WC_Method := Default_WCEM; + + else + if Stop = Start then + for J in WC_Encoding_Letters'Range loop + if File.Form (Start) = WC_Encoding_Letters (J) then + File.WC_Method := J; + return; + end if; + end loop; + end if; + + Close (File); + raise Use_Error with "invalid WCEM form parameter"; + end if; + end Set_WCEM; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Read_Status (AP (File)); + + for L in 1 .. Spacing loop + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + else + ch := Getc (File); + + -- If at end of file now, then immediately raise End_Error. Note + -- that we can never be positioned between a line mark and a page + -- mark, so if we are at the end of file, we cannot logically be + -- before the implicit page mark that is at the end of the file. + + -- For the same reason, we do not need an explicit check for a + -- page mark. If there is a FF in the middle of a line, the file + -- is not in canonical format and we do not care about the page + -- numbers for files other than ones in canonical format. + + if ch = EOF then + raise End_Error; + end if; + + -- If not at end of file, then loop till we get to an LM or EOF. + -- The latter case happens only in non-canonical files where the + -- last line is not terminated by LM, but we don't want to blow + -- up for such files, so we assume an implicit LM in this case. + + loop + exit when ch = LM or else ch = EOF; + ch := Getc (File); + end loop; + end if; + + -- We have got past a line mark, now, for a regular file only, + -- see if a page mark immediately follows this line mark and + -- if so, skip past the page mark as well. We do not do this + -- for non-regular files, since it would cause an undesirable + -- wait for an additional character. + + File.Col := 1; + File.Line := File.Line + 1; + + if File.Before_LM_PM then + File.Page := File.Page + 1; + File.Line := 1; + File.Before_LM_PM := False; + + elsif File.Is_Regular_File then + ch := Getc (File); + + -- Page mark can be explicit, or implied at the end of the file + + if (ch = PM or else ch = EOF) + and then File.Is_Regular_File + then + File.Page := File.Page + 1; + File.Line := 1; + else + Ungetc (ch, File); + end if; + end if; + end loop; + + File.Before_Wide_Character := False; + end Skip_Line; + + procedure Skip_Line (Spacing : Positive_Count := 1) is + begin + Skip_Line (Current_In, Spacing); + end Skip_Line; + + --------------- + -- Skip_Page -- + --------------- + + procedure Skip_Page (File : File_Type) is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If at page mark already, just skip it + + if File.Before_LM_PM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + return; + end if; + + -- This is a bit tricky, if we are logically before an LM then + -- it is not an error if we are at an end of file now, since we + -- are not really at it. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := Getc (File); + + -- Otherwise we do raise End_Error if we are at the end of file now + + else + ch := Getc (File); + + if ch = EOF then + raise End_Error; + end if; + end if; + + -- Now we can just rumble along to the next page mark, or to the + -- end of file, if that comes first. The latter case happens when + -- the page mark is implied at the end of file. + + loop + exit when ch = EOF + or else (ch = PM and then File.Is_Regular_File); + ch := Getc (File); + end loop; + + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + File.Before_Wide_Character := False; + end Skip_Page; + + procedure Skip_Page is + begin + Skip_Page (Current_In); + end Skip_Page; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Standard_Err; + end Standard_Error; + + function Standard_Error return File_Access is + begin + return Standard_Err'Access; + end Standard_Error; + + -------------------- + -- Standard_Input -- + -------------------- + + function Standard_Input return File_Type is + begin + return Standard_In; + end Standard_Input; + + function Standard_Input return File_Access is + begin + return Standard_In'Access; + end Standard_Input; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Standard_Out; + end Standard_Output; + + function Standard_Output return File_Access is + begin + return Standard_Out'Access; + end Standard_Output; + + -------------------- + -- Terminate_Line -- + -------------------- + + procedure Terminate_Line (File : File_Type) is + begin + FIO.Check_File_Open (AP (File)); + + -- For file other than In_File, test for needing to terminate last line + + if Mode (File) /= In_File then + + -- If not at start of line definition need new line + + if File.Col /= 1 then + New_Line (File); + + -- For files other than standard error and standard output, we + -- make sure that an empty file has a single line feed, so that + -- it is properly formatted. We avoid this for the standard files + -- because it is too much of a nuisance to have these odd line + -- feeds when nothing has been written to the file. + + elsif (File /= Standard_Err and then File /= Standard_Out) + and then (File.Line = 1 and then File.Page = 1) + then + New_Line (File); + end if; + end if; + end Terminate_Line; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + + ----------- + -- Write -- + ----------- + + -- This is the primitive Stream Write routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Write + (File : in out Wide_Text_AFCB; + Item : Stream_Element_Array) + is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + + Siz : constant size_t := Item'Length; + + begin + if File.Mode = FCB.In_File then + raise Mode_Error; + end if; + + -- Now we do the write. Since this is a text file, it is normally in + -- text mode, but stream data must be written in binary mode, so we + -- temporarily set binary mode for the write, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then + raise Device_Error; + end if; + + set_text_mode (fileno (File.Stream)); + end Write; + +begin + -- Initialize Standard Files + + for J in WC_Encoding_Method loop + if WC_Encoding = WC_Encoding_Letters (J) then + Default_WCEM := J; + end if; + end loop; + + Initialize_Standard_Files; + + FIO.Chain_File (AP (Standard_In)); + FIO.Chain_File (AP (Standard_Out)); + FIO.Chain_File (AP (Standard_Err)); + +end Ada.Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-witeio.ads b/gcc/ada/libgnat/a-witeio.ads new file mode 100644 index 0000000..bbf35eb --- /dev/null +++ b/gcc/ada/libgnat/a-witeio.ads @@ -0,0 +1,495 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the generic subpackages of Wide_Text_IO (Integer_IO, Float_IO, +-- Fixed_IO, Modular_IO, Decimal_IO and Enumeration_IO) appear as private +-- children in GNAT. These children are with'ed automatically if they are +-- referenced, so this rearrangement is invisible to user programs, but has +-- the advantage that only the needed parts of Wide_Text_IO are processed +-- and loaded. + +with Ada.IO_Exceptions; +with Ada.Streams; + +with Interfaces.C_Streams; + +with System; +with System.File_Control_Block; +with System.WCh_Con; + +package Ada.Wide_Text_IO is + + type File_Type is limited private; + type File_Mode is (In_File, Out_File, Append_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) + Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) + Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) + + type Count is range 0 .. Natural'Last; + -- The value of Count'Last must be large enough so that the assumption that + -- the Line, Column and Page counts can never exceed this value is valid. + + subtype Positive_Count is Count range 1 .. Count'Last; + + Unbounded : constant Count := 0; + -- Line and page length + + subtype Field is Integer range 0 .. 255; + -- Note: if for any reason, there is a need to increase this value, then it + -- will be necessary to change the corresponding value in System.Img_Real + -- in file s-imgrea.adb. + + subtype Number_Base is Integer range 2 .. 16; + + type Type_Set is (Lower_Case, Upper_Case); + + --------------------- + -- File Management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : File_Type) return File_Mode; + function Name (File : File_Type) return String; + function Form (File : File_Type) return String; + + function Is_Open (File : File_Type) return Boolean; + + ------------------------------------------------------ + -- Control of default input, output and error files -- + ------------------------------------------------------ + + procedure Set_Input (File : File_Type); + procedure Set_Output (File : File_Type); + procedure Set_Error (File : File_Type); + + function Standard_Input return File_Type; + function Standard_Output return File_Type; + function Standard_Error return File_Type; + + function Current_Input return File_Type; + function Current_Output return File_Type; + function Current_Error return File_Type; + + type File_Access is access constant File_Type; + + function Standard_Input return File_Access; + function Standard_Output return File_Access; + function Standard_Error return File_Access; + + function Current_Input return File_Access; + function Current_Output return File_Access; + function Current_Error return File_Access; + + -------------------- + -- Buffer control -- + -------------------- + + -- Note: The parameter file is in out in the RM, but as pointed out + -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. + + procedure Flush (File : File_Type); + procedure Flush; + + -------------------------------------------- + -- Specification of line and page lengths -- + -------------------------------------------- + + procedure Set_Line_Length (File : File_Type; To : Count); + procedure Set_Line_Length (To : Count); + + procedure Set_Page_Length (File : File_Type; To : Count); + procedure Set_Page_Length (To : Count); + + function Line_Length (File : File_Type) return Count; + function Line_Length return Count; + + function Page_Length (File : File_Type) return Count; + function Page_Length return Count; + + ------------------------------------ + -- Column, Line, and Page Control -- + ------------------------------------ + + procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure New_Line (Spacing : Positive_Count := 1); + + procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure Skip_Line (Spacing : Positive_Count := 1); + + function End_Of_Line (File : File_Type) return Boolean; + function End_Of_Line return Boolean; + + procedure New_Page (File : File_Type); + procedure New_Page; + + procedure Skip_Page (File : File_Type); + procedure Skip_Page; + + function End_Of_Page (File : File_Type) return Boolean; + function End_Of_Page return Boolean; + + function End_Of_File (File : File_Type) return Boolean; + function End_Of_File return Boolean; + + procedure Set_Col (File : File_Type; To : Positive_Count); + procedure Set_Col (To : Positive_Count); + + procedure Set_Line (File : File_Type; To : Positive_Count); + procedure Set_Line (To : Positive_Count); + + function Col (File : File_Type) return Positive_Count; + function Col return Positive_Count; + + function Line (File : File_Type) return Positive_Count; + function Line return Positive_Count; + + function Page (File : File_Type) return Positive_Count; + function Page return Positive_Count; + + ---------------------------- + -- Character Input-Output -- + ---------------------------- + + procedure Get (File : File_Type; Item : out Wide_Character); + procedure Get (Item : out Wide_Character); + procedure Put (File : File_Type; Item : Wide_Character); + procedure Put (Item : Wide_Character); + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Character; + End_Of_Line : out Boolean); + + procedure Look_Ahead + (Item : out Wide_Character; + End_Of_Line : out Boolean); + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Character); + + procedure Get_Immediate + (Item : out Wide_Character); + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Character; + Available : out Boolean); + + procedure Get_Immediate + (Item : out Wide_Character; + Available : out Boolean); + + ------------------------- + -- String Input-Output -- + ------------------------- + + procedure Get (File : File_Type; Item : out Wide_String); + procedure Get (Item : out Wide_String); + procedure Put (File : File_Type; Item : Wide_String); + procedure Put (Item : Wide_String); + + procedure Get_Line + (File : File_Type; + Item : out Wide_String; + Last : out Natural); + + procedure Get_Line + (Item : out Wide_String; + Last : out Natural); + + function Get_Line (File : File_Type) return Wide_String; + pragma Ada_05 (Get_Line); + + function Get_Line return Wide_String; + pragma Ada_05 (Get_Line); + + procedure Put_Line + (File : File_Type; + Item : Wide_String); + + procedure Put_Line + (Item : Wide_String); + + --------------------------------------- + -- Generic packages for Input-Output -- + --------------------------------------- + + -- The generic packages: + + -- Ada.Wide_Text_IO.Integer_IO + -- Ada.Wide_Text_IO.Modular_IO + -- Ada.Wide_Text_IO.Float_IO + -- Ada.Wide_Text_IO.Fixed_IO + -- Ada.Wide_Text_IO.Decimal_IO + -- Ada.Wide_Text_IO.Enumeration_IO + + -- are implemented as separate child packages in GNAT, so the + -- spec and body of these packages are to be found in separate + -- child units. This implementation detail is hidden from the + -- Ada programmer by special circuitry in the compiler that + -- treats these child packages as though they were nested in + -- Text_IO. The advantage of this special processing is that + -- the subsidiary routines needed if these generics are used + -- are not loaded when they are not used. + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + Layout_Error : exception renames IO_Exceptions.Layout_Error; + +private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + + package WCh_Con renames System.WCh_Con; + + ----------------------------------- + -- Handling of Format Characters -- + ----------------------------------- + + -- Line marks are represented by the single character ASCII.LF (16#0A#). + -- In DOS and similar systems, underlying file translation takes care + -- of translating this to and from the standard CR/LF sequences used in + -- these operating systems to mark the end of a line. On output there is + -- always a line mark at the end of the last line, but on input, this + -- line mark can be omitted, and is implied by the end of file. + + -- Page marks are represented by the single character ASCII.FF (16#0C#), + -- The page mark at the end of the file may be omitted, and is normally + -- omitted on output unless an explicit New_Page call is made before + -- closing the file. No page mark is added when a file is appended to, + -- so, in accordance with the permission in (RM A.10.2(4)), there may + -- or may not be a page mark separating preexisting text in the file + -- from the new text to be written. + + -- A file mark is marked by the physical end of file. In DOS translation + -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the + -- physical end of file, so in effect this character is recognized as + -- marking the end of file in DOS and similar systems. + + LM : constant := Character'Pos (ASCII.LF); + -- Used as line mark + + PM : constant := Character'Pos (ASCII.FF); + -- Used as page mark, except at end of file where it is implied + + ------------------------------------- + -- Wide_Text_IO File Control Block -- + ------------------------------------- + + Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8; + -- This gets modified during initialization (see body) using + -- the default value established in the call to Set_Globals. + + package FCB renames System.File_Control_Block; + + type Wide_Text_AFCB is new FCB.AFCB with record + Page : Count := 1; + Line : Count := 1; + Col : Count := 1; + Line_Length : Count := 0; + Page_Length : Count := 0; + + Self : aliased File_Type; + -- Set to point to the containing Text_AFCB block. This is used to + -- implement the Current_{Error,Input,Output} functions which return + -- a File_Access, the file access value returned is a pointer to + -- the Self field of the corresponding file. + + Before_LM : Boolean := False; + -- This flag is used to deal with the anomalies introduced by the + -- peculiar definition of End_Of_File and End_Of_Page in Ada. These + -- functions require looking ahead more than one character. Since + -- there is no convenient way of backing up more than one character, + -- what we do is to leave ourselves positioned past the LM, but set + -- this flag, so that we know that from an Ada point of view we are + -- in front of the LM, not after it. A bit odd, but it works. + + Before_LM_PM : Boolean := False; + -- This flag similarly handles the case of being physically positioned + -- after a LM-PM sequence when logically we are before the LM-PM. This + -- flag can only be set if Before_LM is also set. + + WC_Method : WCh_Con.WC_Encoding_Method := Default_WCEM; + -- Encoding method to be used for this file + + Before_Wide_Character : Boolean := False; + -- This flag is set to indicate that a wide character in the input has + -- been read by Wide_Text_IO.Look_Ahead. If it is set to True, then it + -- means that the stream is logically positioned before the character + -- but is physically positioned after it. The character involved must + -- not be in the range 16#00#-16#7F#, i.e. if the flag is set, then + -- we know the next character has a code greater than 16#7F#, and the + -- value of this character is saved in Saved_Wide_Character. + + Saved_Wide_Character : Wide_Character; + -- This field is valid only if Before_Wide_Character is set. It + -- contains a wide character read by Look_Ahead. If Look_Ahead + -- reads a character in the range 16#0000# to 16#007F#, then it + -- can use ungetc to put it back, but ungetc cannot be called + -- more than once, so for characters above this range, we don't + -- try to back up the file. Instead we save the character in this + -- field and set the flag Before_Wide_Character to indicate that + -- we are logically positioned before this character even though + -- the stream is physically positioned after it. + + end record; + + type File_Type is access all Wide_Text_AFCB; + + function AFCB_Allocate (Control_Block : Wide_Text_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : not null access Wide_Text_AFCB); + procedure AFCB_Free (File : not null access Wide_Text_AFCB); + + procedure Read + (File : in out Wide_Text_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read operation used when Wide_Text_IO file is treated as a Stream + + procedure Write + (File : in out Wide_Text_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Write operation used when Wide_Text_IO file is treated as a Stream + + ------------------------ + -- The Standard Files -- + ------------------------ + + Standard_Err_AFCB : aliased Wide_Text_AFCB; + Standard_In_AFCB : aliased Wide_Text_AFCB; + Standard_Out_AFCB : aliased Wide_Text_AFCB; + + Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; + Standard_In : aliased File_Type := Standard_In_AFCB'Access; + Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; + -- Standard files + + Current_In : aliased File_Type := Standard_In; + Current_Out : aliased File_Type := Standard_Out; + Current_Err : aliased File_Type := Standard_Err; + -- Current files + + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Wide_Text_IO.Reset_Standard_Files. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- These subprograms are in the private part of the spec so that they can + -- be shared by the children of Ada.Wide_Text_IO. + + function Getc (File : File_Type) return Interfaces.C_Streams.int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. + + procedure Get_Character (File : File_Type; Item : out Character); + -- This is essentially a copy of the normal Get routine from Text_IO. It + -- obtains a single character from the input file File, and places it in + -- Item. This character may be the leading character of a Wide_Character + -- sequence, but that is up to the caller to deal with. + + function Get_Wide_Char + (C : Character; + File : File_Type) return Wide_Character; + -- This function is shared by Get and Get_Immediate to extract a wide + -- character value from the given File. The first byte has already been + -- read and is passed in C. The wide character value is returned as the + -- result, and the file pointer is bumped past the character. + + function Nextc (File : File_Type) return Interfaces.C_Streams.int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). + +end Ada.Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-wrstfi.adb b/gcc/ada/libgnat/a-wrstfi.adb new file mode 100644 index 0000000..b9df99a --- /dev/null +++ b/gcc/ada/libgnat/a-wrstfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------- +-- Ada.Wide_Text_IO.Reset_Standard_Files -- +------------------------------------------- + +procedure Ada.Wide_Text_IO.Reset_Standard_Files is +begin + Ada.Wide_Text_IO.Initialize_Standard_Files; +end Ada.Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/libgnat/a-wrstfi.ads b/gcc/ada/libgnat/a-wrstfi.ads new file mode 100644 index 0000000..13ed65f --- /dev/null +++ b/gcc/ada/libgnat/a-wrstfi.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 reset routine that resets the standard files used +-- by Ada.Wide_Text_IO. This is useful in systems such as VxWorks where +-- Ada.Wide_Text_IO is elaborated at the program start, but a system restart +-- may alter the status of these files, resulting in incorrect operation of +-- Wide_Text_IO (in particular if the standard input file is changed to be +-- interactive, then Get_Line may hang looking for an extra character after +-- the end of the line. + +procedure Ada.Wide_Text_IO.Reset_Standard_Files; +-- Reset standard Wide_Text_IO files as described above diff --git a/gcc/ada/libgnat/a-wtcoau.adb b/gcc/ada/libgnat/a-wtcoau.adb new file mode 100644 index 0000000..ca14dcb --- /dev/null +++ b/gcc/ada/libgnat/a-wtcoau.adb @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; +with Ada.Wide_Text_IO.Float_Aux; + +with System.Img_Real; use System.Img_Real; + +package body Ada.Wide_Text_IO.Complex_Aux is + + package Aux renames Ada.Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer; + Paren : Boolean := False; + + begin + -- General note for following code, exceptions from the calls + -- to Get for components of the complex value are propagated. + + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); + + for J in Ptr + 1 .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + + -- Case of width = 0 + + else + Load_Skip (File); + Ptr := 0; + Load (File, Buf, Ptr, '(', Paren); + Aux.Get (File, ItemR, 0); + Load_Skip (File); + Load (File, Buf, Ptr, ','); + Aux.Get (File, ItemI, 0); + + if Paren then + Load_Skip (File); + Load (File, Buf, Ptr, ')', Paren); + + if not Paren then + raise Data_Error; + end if; + end if; + end if; + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive) + is + Paren : Boolean; + Pos : Integer; + + begin + String_Skip (From, Pos); + + if From (Pos) = '(' then + Pos := Pos + 1; + Paren := True; + else + Paren := False; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemR, Pos); + + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) = ',' then + Pos := Pos + 1; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemI, Pos); + + if Paren then + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) /= ')' then + raise Data_Error; + end if; + end if; + + Last := Pos; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + begin + Put (File, '('); + Aux.Put (File, ItemR, Fore, Aft, Exp); + Put (File, ','); + Aux.Put (File, ItemI, Fore, Aft, Exp); + Put (File, ')'); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field) + is + I_String : String (1 .. 3 * Field'Last); + R_String : String (1 .. 3 * Field'Last); + + Iptr : Natural; + Rptr : Natural; + + begin + -- Both parts are initially converted with a Fore of 0 + + Rptr := 0; + Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Iptr := 0; + Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + + -- Check room for both parts plus parens plus comma (RM G.1.3(34)) + + if Rptr + Iptr + 3 > To'Length then + raise Layout_Error; + end if; + + -- If there is room, layout result according to (RM G.1.3(31-33)) + + To (To'First) := '('; + To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); + To (To'First + Rptr + 1) := ','; + + To (To'Last) := ')'; + + To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); + + for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop + To (J) := ' '; + end loop; + end Puts; + +end Ada.Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/libgnat/a-wtcoau.ads b/gcc/ada/libgnat/a-wtcoau.ads new file mode 100644 index 0000000..23bd6ce --- /dev/null +++ b/gcc/ada/libgnat/a-wtcoau.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Text_IO.Complex_IO that +-- are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Complex_IO itself, +-- except that the generic parameter Complex has been replaced by separate +-- real and imaginary values of type Long_Long_Float, and default parameters +-- have been removed because they are supplied explicitly by the calls from +-- within the generic template. + +package Ada.Wide_Text_IO.Complex_Aux is + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field); + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive); + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/libgnat/a-wtcoio.adb b/gcc/ada/libgnat/a-wtcoio.adb new file mode 100644 index 0000000..117b43e --- /dev/null +++ b/gcc/ada/libgnat/a-wtcoio.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Complex_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +with Ada.Unchecked_Conversion; + +package body Ada.Wide_Text_IO.Complex_IO is + + package Aux renames Ada.Wide_Text_IO.Complex_Aux; + + subtype LLF is Long_Long_Float; + -- Type used for calls to routines in Aux + + function TFT is new + Ada.Unchecked_Conversion (File_Type, Ada.Wide_Text_IO.File_Type); + -- This unchecked conversion is to get around a visibility bug in + -- GNAT version 2.04w. It should be possible to simply use the + -- subtype declared above and do normal checked conversions. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + begin + Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); + Item := (Real_Item, Imag_Item); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (Item : out Complex; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (From : Wide_String; + Item : out Complex; + Last : out Positive) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); + Item := (Real_Item, Imag_Item); + + exception + when Data_Error => raise Constraint_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (To : out Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/libgnat/a-wtcoio.ads b/gcc/ada/libgnat/a-wtcoio.ads new file mode 100644 index 0000000..31fab2b --- /dev/null +++ b/gcc/ada/libgnat/a-wtcoio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + +package Ada.Wide_Text_IO.Complex_IO is + + use Complex_Types; + + Default_Fore : Field := 2; + Default_Aft : Field := Real'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0); + + procedure Get + (Item : out Complex; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Complex; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/libgnat/a-wtcstr.adb b/gcc/ada/libgnat/a-wtcstr.adb new file mode 100644 index 0000000..8c4544d --- /dev/null +++ b/gcc/ada/libgnat/a-wtcstr.adb @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with Ada.Unchecked_Conversion; + +package body Ada.Wide_Text_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True, + C_Stream => C_Stream); + + end Open; + +end Ada.Wide_Text_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-wtcstr.ads b/gcc/ada/libgnat/a-wtcstr.ads new file mode 100644 index 0000000..898b028 --- /dev/null +++ b/gcc/ada/libgnat/a-wtcstr.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Wide_Text_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +package Ada.Wide_Text_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Wide_Text_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-wtdeau.adb b/gcc/ada/libgnat/a-wtdeau.adb new file mode 100644 index 0000000..9aea8ad --- /dev/null +++ b/gcc/ada/libgnat/a-wtdeau.adb @@ -0,0 +1,265 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; +with Ada.Wide_Text_IO.Float_Aux; use Ada.Wide_Text_IO.Float_Aux; + +with System.Img_Dec; use System.Img_Dec; +with System.Img_LLD; use System.Img_LLD; +with System.Val_Dec; use System.Val_Dec; +with System.Val_LLD; use System.Val_LLD; + +package body Ada.Wide_Text_IO.Decimal_Aux is + + ------------- + -- Get_Dec -- + ------------- + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_Dec; + + ------------- + -- Get_LLD -- + ------------- + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Long_Long_Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_LLD; + + -------------- + -- Gets_Dec -- + -------------- + + function Gets_Dec + (From : String; + Last : not null access Positive; + Scale : Integer) return Integer + is + Pos : aliased Integer; + Item : Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + + end Gets_Dec; + + -------------- + -- Gets_LLD -- + -------------- + + function Gets_LLD + (From : String; + Last : not null access Positive; + Scale : Integer) return Long_Long_Integer + is + Pos : aliased Integer; + Item : Long_Long_Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + + end Gets_LLD; + + ------------- + -- Put_Dec -- + ------------- + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_Dec; + + ------------- + -- Put_LLD -- + ------------- + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLD; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + -- Compute Fore, allowing for Aft digits and the decimal dot + + Fore := To'Length - Field'Max (1, Aft) - 1; + + -- Allow for Exp and two more for E+ or E- if exponent present + + if Exp /= 0 then + Fore := Fore - 2 - Exp; + end if; + + -- Make sure we have enough room + + if Fore < 1 then + raise Layout_Error; + end if; + + -- Do the conversion and check length of result + + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_Dec; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + Fore := + (if Exp = 0 + then To'Length - 1 - Aft + else To'Length - 2 - Aft - Exp); + + if Fore < 1 then + raise Layout_Error; + end if; + + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_LLD; + +end Ada.Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-wtdeau.ads b/gcc/ada/libgnat/a-wtdeau.ads new file mode 100644 index 0000000..c99f0e0 --- /dev/null +++ b/gcc/ada/libgnat/a-wtdeau.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Text_IO.Decimal_IO +-- that are shared among separate instantiations of this package. The +-- routines in the package are identical semantically to those declared +-- in Wide_Text_IO, except that default values have been supplied by the +-- generic, and the Num parameter has been replaced by Integer or +-- Long_Long_Integer, with an additional Scale parameter giving the +-- value of Num'Scale. In addition the Get routines return the value +-- rather than store it in an Out parameter. + +private package Ada.Wide_Text_IO.Decimal_Aux is + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer; + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer; + + function Gets_Dec + (From : String; + Last : not null access Positive; + Scale : Integer) return Integer; + + function Gets_LLD + (From : String; + Last : not null access Positive; + Scale : Integer) return Long_Long_Integer; + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + +end Ada.Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-wtdeio.adb b/gcc/ada/libgnat/a-wtdeio.adb new file mode 100644 index 0000000..1c13f9a --- /dev/null +++ b/gcc/ada/libgnat/a-wtdeio.adb @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Decimal_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Decimal_IO is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Decimal_Aux; + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Integer'Size then + Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); + else + Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); + end if; + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Integer'Size then + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); + else + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Num'Size > Integer'Size then + Aux.Put_LLD + (TFT (File), Long_Long_Integer'Integer_Value (Item), + Fore, Aft, Exp, Scale); + else + Aux.Put_Dec + (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Integer'Size then + Aux.Puts_LLD + (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); + + else + Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); + end if; + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-wtdeio.ads b/gcc/ada/libgnat/a-wtdeio.ads new file mode 100644 index 0000000..dbeb80a --- /dev/null +++ b/gcc/ada/libgnat/a-wtdeio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Decimal_IO is a subpackage +-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Decimal_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <> digits <>; + +package Ada.Wide_Text_IO.Decimal_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-wtedit.adb b/gcc/ada/libgnat/a-wtedit.adb new file mode 100644 index 0000000..4690b21 --- /dev/null +++ b/gcc/ada/libgnat/a-wtedit.adb @@ -0,0 +1,2716 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . E D I T I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Strings.Wide_Fixed; + +package body Ada.Wide_Text_IO.Editing is + + package Strings renames Ada.Strings; + package Strings_Fixed renames Ada.Strings.Fixed; + package Strings_Wide_Fixed renames Ada.Strings.Wide_Fixed; + package Wide_Text_IO renames Ada.Wide_Text_IO; + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + function To_Wide (C : Character) return Wide_Character; + pragma Inline (To_Wide); + -- Convert Character to corresponding Wide_Character + + --------------------- + -- Blank_When_Zero -- + --------------------- + + function Blank_When_Zero (Pic : Picture) return Boolean is + begin + return Pic.Contents.Original_BWZ; + end Blank_When_Zero; + + -------------------- + -- Decimal_Output -- + -------------------- + + package body Decimal_Output is + + ----------- + -- Image -- + ----------- + + function Image + (Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark) return Wide_String + is + begin + return Format_Number + (Pic.Contents, Num'Image (Item), + Currency, Fill, Separator, Radix_Mark); + end Image; + + ------------ + -- Length -- + ------------ + + function Length + (Pic : Picture; + Currency : Wide_String := Default_Currency) return Natural + is + Picstr : constant String := Pic_String (Pic); + V_Adjust : Integer := 0; + Cur_Adjust : Integer := 0; + + begin + -- Check if Picstr has 'V' or '$' + + -- If 'V', then length is 1 less than otherwise + + -- If '$', then length is Currency'Length-1 more than otherwise + + -- This should use the string handling package ??? + + for J in Picstr'Range loop + if Picstr (J) = 'V' then + V_Adjust := -1; + + elsif Picstr (J) = '$' then + Cur_Adjust := Currency'Length - 1; + end if; + end loop; + + return Picstr'Length - V_Adjust + Cur_Adjust; + end Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : Wide_Text_IO.File_Type; + Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark) + is + begin + Wide_Text_IO.Put (File, Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark) + is + begin + Wide_Text_IO.Put (Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark) + is + Result : constant Wide_String := + Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); + + begin + if Result'Length > To'Length then + raise Wide_Text_IO.Layout_Error; + else + Strings_Wide_Fixed.Move (Source => Result, Target => To, + Justify => Strings.Right); + end if; + end Put; + + ----------- + -- Valid -- + ----------- + + function Valid + (Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency) return Boolean + is + begin + declare + Temp : constant Wide_String := Image (Item, Pic, Currency); + pragma Warnings (Off, Temp); + begin + return True; + end; + + exception + when Layout_Error => return False; + + end Valid; + end Decimal_Output; + + ------------ + -- Expand -- + ------------ + + function Expand (Picture : String) return String is + Result : String (1 .. MAX_PICSIZE); + Picture_Index : Integer := Picture'First; + Result_Index : Integer := Result'First; + Count : Natural; + Last : Integer; + + begin + if Picture'Length < 1 then + raise Picture_Error; + end if; + + if Picture (Picture'First) = '(' then + raise Picture_Error; + end if; + + loop + case Picture (Picture_Index) is + when '(' => + + -- We now need to scan out the count after a left paren. In + -- the non-wide version we used Integer_IO.Get, but that is + -- not convenient here, since we don't want to drag in normal + -- Text_IO just for this purpose. So we do the scan ourselves, + -- with the normal validity checks. + + Last := Picture_Index + 1; + Count := 0; + + if Picture (Last) not in '0' .. '9' then + raise Picture_Error; + end if; + + Count := Character'Pos (Picture (Last)) - Character'Pos ('0'); + Last := Last + 1; + + loop + if Last > Picture'Last then + raise Picture_Error; + end if; + + if Picture (Last) = '_' then + if Picture (Last - 1) = '_' then + raise Picture_Error; + end if; + + elsif Picture (Last) = ')' then + exit; + + elsif Picture (Last) not in '0' .. '9' then + raise Picture_Error; + + else + Count := Count * 10 + + Character'Pos (Picture (Last)) - + Character'Pos ('0'); + end if; + + Last := Last + 1; + end loop; + + -- In what follows note that one copy of the repeated + -- character has already been made, so a count of one is + -- no-op, and a count of zero erases a character. + + for J in 2 .. Count loop + Result (Result_Index + J - 2) := Picture (Picture_Index - 1); + end loop; + + Result_Index := Result_Index + Count - 1; + + -- Last was a ')' throw it away too + + Picture_Index := Last + 1; + + when ')' => + raise Picture_Error; + + when others => + Result (Result_Index) := Picture (Picture_Index); + Picture_Index := Picture_Index + 1; + Result_Index := Result_Index + 1; + end case; + + exit when Picture_Index > Picture'Last; + end loop; + + return Result (1 .. Result_Index - 1); + + exception + when others => + raise Picture_Error; + end Expand; + + ------------------- + -- Format_Number -- + ------------------- + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : Wide_String; + Fill_Character : Wide_Character; + Separator_Character : Wide_Character; + Radix_Point : Wide_Character) return Wide_String + is + Attrs : Number_Attributes := Parse_Number_String (Number); + Position : Integer; + Rounded : String := Number; + + Sign_Position : Integer := Pic.Sign_Position; -- may float. + + Answer : Wide_String (1 .. Pic.Picture.Length); + Last : Integer; + Currency_Pos : Integer := Pic.Start_Currency; + + Dollar : Boolean := False; + -- Overridden immediately if necessary + + Zero : Boolean := True; + -- Set to False when a non-zero digit is output + + begin + + -- If the picture has fewer decimal places than the number, the image + -- must be rounded according to the usual rules. + + if Attrs.Has_Fraction then + declare + R : constant Integer := + (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) + - Pic.Max_Trailing_Digits; + R_Pos : Integer; + + begin + if R > 0 then + R_Pos := Rounded'Length - R; + + if Rounded (R_Pos + 1) > '4' then + + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + + while R_Pos > 1 loop + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + exit; + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + end if; + end loop; + + -- The rounding may add a digit in front. Either the + -- leading blank or the sign (already captured) can be + -- overwritten. + + if R_Pos = 1 then + Rounded (R_Pos) := '1'; + Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; + end if; + end if; + end if; + end if; + end; + end if; + + for J in Answer'Range loop + Answer (J) := To_Wide (Pic.Picture.Expanded (J)); + end loop; + + if Pic.Start_Currency /= Invalid_Position then + Dollar := Answer (Pic.Start_Currency) = '$'; + end if; + + -- Fix up "direct inserts" outside the playing field. Set up as one + -- loop to do the beginning, one (reverse) loop to do the end. + + Last := 1; + loop + exit when Last = Pic.Start_Float; + exit when Last = Pic.Radix_Position; + exit when Answer (Last) = '9'; + + case Answer (Last) is + when '_' => + Answer (Last) := Separator_Character; + + when 'b' => + Answer (Last) := ' '; + + when others => + null; + end case; + + exit when Last = Answer'Last; + + Last := Last + 1; + end loop; + + -- Now for the end... + + for J in reverse Last .. Answer'Last loop + exit when J = Pic.Radix_Position; + + -- Do this test First, Separator_Character can equal Pic.Floater + + if Answer (J) = Pic.Floater then + exit; + end if; + + case Answer (J) is + when '_' => + Answer (J) := Separator_Character; + + when 'b' => + Answer (J) := ' '; + + when '9' => + exit; + + when others => + null; + end case; + end loop; + + -- Non-floating sign + + if Pic.Start_Currency /= -1 + and then Answer (Pic.Start_Currency) = '#' + and then Pic.Floater /= '#' + then + if Currency_Symbol'Length > + Pic.End_Currency - Pic.Start_Currency + 1 + then + raise Picture_Error; + + elsif Currency_Symbol'Length = + Pic.End_Currency - Pic.Start_Currency + 1 + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + Currency_Symbol; + + elsif Pic.Radix_Position = Invalid_Position + or else Pic.Start_Currency < Pic.Radix_Position + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. + Pic.End_Currency) := Currency_Symbol; + + else + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.Start_Currency .. + Pic.Start_Currency + Currency_Symbol'Length - 1) := + Currency_Symbol; + end if; + end if; + + -- Fill in leading digits + + if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > + Pic.Max_Leading_Digits + then + raise Layout_Error; + end if; + + Position := + (if Pic.Radix_Position = Invalid_Position then Answer'Last + else Pic.Radix_Position - 1); + + for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop + while Answer (Position) /= '9' + and then + Answer (Position) /= Pic.Floater + loop + if Answer (Position) = '_' then + Answer (Position) := Separator_Character; + elsif Answer (Position) = 'b' then + Answer (Position) := ' '; + end if; + + Position := Position - 1; + end loop; + + Answer (Position) := To_Wide (Rounded (J)); + + if Rounded (J) /= '0' then + Zero := False; + end if; + + Position := Position - 1; + end loop; + + -- Do lead float + + if Pic.Start_Float = Invalid_Position then + + -- No leading floats, but need to change '9' to '0', '_' to + -- Separator_Character and 'b' to ' '. + + for J in Last .. Position loop + + -- Last set when fixing the "uninteresting" leaders above. + -- Don't duplicate the work. + + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + + end loop; + + elsif Pic.Floater = '<' + or else + Pic.Floater = '+' + or else + Pic.Floater = '-' + then + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Sign_Position := Position; + + elsif Pic.Floater = '$' then + + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := ' '; -- no separator before leftmost digit + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Currency_Pos := Position; + + elsif Pic.Floater = '*' then + + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := '*'; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position loop + Answer (J) := '*'; + end loop; + + else + if Pic.Floater = '#' then + Currency_Pos := Currency_Symbol'Length; + end if; + + for J in reverse Pic.Start_Float .. Position loop + case Answer (J) is + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'b' | '/' | '0' => + Answer (J) := ' '; + + when '9' => + Answer (J) := '0'; + + when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => + null; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when '_' => + case Pic.Floater is + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'b' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when others => + null; + end case; + + when others => + null; + end case; + end loop; + + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Layout_Error; + end if; + end if; + + -- Do sign + + if Sign_Position = Invalid_Position then + if Attrs.Negative then + raise Layout_Error; + end if; + + else + if Attrs.Negative then + case Answer (Sign_Position) is + when 'C' | 'D' | '-' => + null; + + when '+' => + Answer (Sign_Position) := '-'; + + when '<' => + Answer (Sign_Position) := '('; + Answer (Pic.Second_Sign) := ')'; + + when others => + raise Picture_Error; + end case; + + else -- positive + + case Answer (Sign_Position) is + when '-' => + Answer (Sign_Position) := ' '; + + when '<' | 'C' | 'D' => + Answer (Sign_Position) := ' '; + Answer (Pic.Second_Sign) := ' '; + + when '+' => + null; + + when others => + raise Picture_Error; + end case; + end if; + end if; + + -- Fill in trailing digits + + if Pic.Max_Trailing_Digits > 0 then + + if Attrs.Has_Fraction then + Position := Attrs.Start_Of_Fraction; + Last := Pic.Radix_Position + 1; + + for J in Last .. Answer'Last loop + if Answer (J) = '9' or else Answer (J) = Pic.Floater then + Answer (J) := To_Wide (Rounded (Position)); + + if Rounded (Position) /= '0' then + Zero := False; + end if; + + Position := Position + 1; + Last := J + 1; + + -- Used up fraction but remember place in Answer + + exit when Position > Attrs.End_Of_Fraction; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + end if; + + Last := J + 1; + end loop; + + Position := Last; + + else + Position := Pic.Radix_Position + 1; + end if; + + -- Now fill remaining 9's with zeros and _ with separators + + Last := Answer'Last; + + for J in Position .. Last loop + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = Pic.Floater then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + end loop; + + Position := Last + 1; + + else + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Layout_Error; + end if; + + -- No trailing digits, but now J may need to stick in a currency + -- symbol or sign. + + Position := + (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1 + else Pic.Start_Currency); + end if; + + for J in Position .. Answer'Last loop + if Pic.Start_Currency /= Invalid_Position + and then Answer (Pic.Start_Currency) = '#' + then + Currency_Pos := 1; + end if; + + -- Note: There are some weird cases J can imagine with 'b' or '#' in + -- currency strings where the following code will cause glitches. The + -- trick is to tell when the character in the answer should be + -- checked, and when to look at the original string. Some other time. + -- RIE 11/26/96 ??? + + case Answer (J) is + when '*' => + Answer (J) := Fill_Character; + + when 'b' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + end if; + + when '_' => + case Pic.Floater is + + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'z' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + end if; + + when others => + null; + end case; + + when others => + exit; + end case; + end loop; + + -- Now get rid of Blank_when_Zero and complete Star fill + + if Zero and then Pic.Blank_When_Zero then + + -- Value is zero, and blank it + + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position + and then Answer (Pic.Radix_Position) = 'V' + then + Last := Last - 1; + end if; + + return Wide_String'(1 .. Last => ' '); + + elsif Zero and then Pic.Star_Fill then + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position then + + if Answer (Pic.Radix_Position) = 'V' then + Last := Last - 1; + + elsif Dollar then + if Pic.Radix_Position > Pic.Start_Currency then + return Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); + + else + return + Wide_String' + (1 .. + Pic.Radix_Position + Currency_Symbol'Length - 2 + => '*') & + Radix_Point & + Wide_String' + (Pic.Radix_Position + Currency_Symbol'Length .. Last + => '*'); + end if; + + else + return + Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); + end if; + end if; + + return Wide_String'(1 .. Last => '*'); + end if; + + -- This was once a simple return statement, now there are nine + -- different return cases. Not to mention the five above to deal + -- with zeros. Why not split things out? + + -- Processing the radix and sign expansion separately would require + -- lots of copying--the string and some of its indexes--without + -- really simplifying the logic. The cases are: + + -- 1) Expand $, replace '.' with Radix_Point + -- 2) No currency expansion, replace '.' with Radix_Point + -- 3) Expand $, radix blanked + -- 4) No currency expansion, radix blanked + -- 5) Elide V + -- 6) Expand $, Elide V + -- 7) Elide V, Expand $ (Two cases depending on order.) + -- 8) No radix, expand $ + -- 9) No radix, no currency expansion + + if Pic.Radix_Position /= Invalid_Position then + + if Answer (Pic.Radix_Position) = '.' then + Answer (Pic.Radix_Position) := Radix_Point; + + if Dollar then + + -- 1) Expand $, replace '.' with Radix_Point + + return + Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 2) No currency expansion, replace '.' with Radix_Point + + return Answer; + end if; + + elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. + if Dollar then + + -- 3) Expand $, radix blanked + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 4) No expansion, radix blanked + + return Answer; + end if; + + -- V cases + + else + if not Dollar then + + -- 5) Elide V + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + elsif Currency_Pos < Pic.Radix_Position then + + -- 6) Expand $, Elide V + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + else + -- 7) Elide V, Expand $ + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & + Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + end if; + end if; + + elsif Dollar then + + -- 8) No radix, expand $ + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 9) No radix, no currency expansion + + return Answer; + end if; + end Format_Number; + + ------------------------- + -- Parse_Number_String -- + ------------------------- + + function Parse_Number_String (Str : String) return Number_Attributes is + Answer : Number_Attributes; + + begin + for J in Str'Range loop + case Str (J) is + when ' ' => + null; -- ignore + + when '1' .. '9' => + + -- Decide if this is the start of a number. + -- If so, figure out which one... + + if Answer.Has_Fraction then + Answer.End_Of_Fraction := J; + else + if Answer.Start_Of_Int = Invalid_Position then + -- start integer + Answer.Start_Of_Int := J; + end if; + Answer.End_Of_Int := J; + end if; + + when '0' => + + -- Only count a zero before the decimal point if it follows a + -- non-zero digit. After the decimal point, zeros will be + -- counted if followed by a non-zero digit. + + if not Answer.Has_Fraction then + if Answer.Start_Of_Int /= Invalid_Position then + Answer.End_Of_Int := J; + end if; + end if; + + when '-' => + + -- Set negative + + Answer.Negative := True; + + when '.' => + + -- Close integer, start fraction + + if Answer.Has_Fraction then + raise Picture_Error; + end if; + + -- Two decimal points is a no-no + + Answer.Has_Fraction := True; + Answer.End_Of_Fraction := J; + + -- Could leave this at Invalid_Position, but this seems the + -- right way to indicate a null range... + + Answer.Start_Of_Fraction := J + 1; + Answer.End_Of_Int := J - 1; + + when others => + raise Picture_Error; -- can this happen? probably not + end case; + end loop; + + if Answer.Start_Of_Int = Invalid_Position then + Answer.Start_Of_Int := Answer.End_Of_Int + 1; + end if; + + -- No significant (intger) digits needs a null range + + return Answer; + end Parse_Number_String; + + ---------------- + -- Pic_String -- + ---------------- + + -- The following ensures that we return B and not b being careful not + -- to break things which expect lower case b for blank. See CXF3A02. + + function Pic_String (Pic : Picture) return String is + Temp : String (1 .. Pic.Contents.Picture.Length) := + Pic.Contents.Picture.Expanded; + begin + for J in Temp'Range loop + if Temp (J) = 'b' then + Temp (J) := 'B'; + end if; + end loop; + + return Temp; + end Pic_String; + + ------------------ + -- Precalculate -- + ------------------ + + procedure Precalculate (Pic : in out Format_Record) is + + Computed_BWZ : Boolean := True; + + type Legality is (Okay, Reject); + State : Legality := Reject; + -- Start in reject, which will reject null strings + + Index : Pic_Index := Pic.Picture.Expanded'First; + + function At_End return Boolean; + pragma Inline (At_End); + + procedure Set_State (L : Legality); + pragma Inline (Set_State); + + function Look return Character; + pragma Inline (Look); + + function Is_Insert return Boolean; + pragma Inline (Is_Insert); + + procedure Skip; + pragma Inline (Skip); + + procedure Trailing_Currency; + procedure Trailing_Bracket; + procedure Number_Fraction; + procedure Number_Completion; + procedure Number_Fraction_Or_Bracket; + procedure Number_Fraction_Or_Z_Fill; + procedure Zero_Suppression; + procedure Floating_Bracket; + procedure Number_Fraction_Or_Star_Fill; + procedure Star_Suppression; + procedure Number_Fraction_Or_Dollar; + procedure Leading_Dollar; + procedure Number_Fraction_Or_Pound; + procedure Leading_Pound; + procedure Picture; + procedure Floating_Plus; + procedure Floating_Minus; + procedure Picture_Plus; + procedure Picture_Minus; + procedure Picture_Bracket; + procedure Number; + procedure Optional_RHS_Sign; + procedure Picture_String; + + ------------ + -- At_End -- + ------------ + + function At_End return Boolean is + begin + return Index > Pic.Picture.Length; + end At_End; + + ---------------------- + -- Floating_Bracket -- + ---------------------- + + -- Note that Floating_Bracket is only called with an acceptable + -- prefix. But we don't set Okay, because we must end with a '>'. + + procedure Floating_Bracket is + begin + Pic.Floater := '<'; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + + -- First bracket wasn't counted... + + Skip; -- known '<' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when '9' => + Number_Completion; + + when '$' => + Leading_Dollar; + + when '#' => + Leading_Pound; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Bracket; + return; + + when others => + return; + end case; + end loop; + end Floating_Bracket; + + -------------------- + -- Floating_Minus -- + -------------------- + + procedure Floating_Minus is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '-' then + loop + if At_End then + return; + end if; + + case Look is + when '-' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + end case; + end loop; + end Floating_Minus; + + ------------------- + -- Floating_Plus -- + ------------------- + + procedure Floating_Plus is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '+' then + loop + if At_End then + return; + end if; + + case Look is + when '+' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + end case; + end loop; + end Floating_Plus; + + --------------- + -- Is_Insert -- + --------------- + + function Is_Insert return Boolean is + begin + if At_End then + return False; + end if; + + case Pic.Picture.Expanded (Index) is + when '_' | '0' | '/' => + return True; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; -- canonical + return True; + + when others => + return False; + end case; + end Is_Insert; + + -------------------- + -- Leading_Dollar -- + -------------------- + + -- Note that Leading_Dollar can be called in either State. + -- It will set state to Okay only if a 9 or (second) $ is encountered. + + -- Also notice the tricky bit with State and Zero_Suppression. + -- Zero_Suppression is Picture_Error if a '$' or a '9' has been + -- encountered, exactly the cases where State has been set. + + procedure Leading_Dollar is + begin + -- Treat as a floating dollar, and unwind otherwise + + Pic.Floater := '$'; + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Skip; -- known '$' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + -- A trailing insertion character is not part of the + -- floating currency, so need to look ahead. + + if Look /= '$' then + Pic.End_Float := Pic.End_Float - 1; + end if; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if State = Okay then + raise Picture_Error; + else + -- Will overwrite Floater and Start_Float + + Zero_Suppression; + end if; + + when '*' => + if State = Okay then + raise Picture_Error; + else + -- Will overwrite Floater and Start_Float + + Star_Suppression; + end if; + + when '$' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); Skip; + + when '9' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- A single dollar does not a floating make + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one dollar before the sign is okay, but doesn't + -- float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Dollar; + return; + + when others => + return; + end case; + end loop; + end Leading_Dollar; + + ------------------- + -- Leading_Pound -- + ------------------- + + -- This one is complex. A Leading_Pound can be fixed or floating, + -- but in some cases the decision has to be deferred until we leave + -- this procedure. Also note that Leading_Pound can be called in + -- either State. + + -- It will set state to Okay only if a 9 or (second) # is + -- encountered. + + -- One Last note: In ambiguous cases, the currency is treated as + -- floating unless there is only one '#'. + + procedure Leading_Pound is + + Inserts : Boolean := False; + -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered + + Must_Float : Boolean := False; + -- Set to true if a '#' occurs after an insert + + begin + -- Treat as a floating currency. If it isn't, this will be + -- overwritten later. + + Pic.Floater := '#'; + + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Pic.Max_Currency_Digits := 1; -- we've seen one. + + Skip; -- known '#' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Will overwrite Floater and Start_Float + + Zero_Suppression; + end if; + + when '*' => + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Will overwrite Floater and Start_Float + + Star_Suppression; + end if; + + when '#' => + if Inserts then + Must_Float := True; + end if; + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); + Skip; + + when '9' => + if State /= Okay then + + -- A single '#' doesn't float + + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one pound before the sign is okay, but doesn't + -- float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Pound; + return; + + when others => + return; + end case; + end loop; + end Leading_Pound; + + ---------- + -- Look -- + ---------- + + function Look return Character is + begin + if At_End then + raise Picture_Error; + end if; + + return Pic.Picture.Expanded (Index); + end Look; + + ------------ + -- Number -- + ------------ + + procedure Number is + begin + loop + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + end case; + + if At_End then + return; + end if; + + -- Will return in Okay state if a '9' was seen + + end loop; + end Number; + + ----------------------- + -- Number_Completion -- + ----------------------- + + procedure Number_Completion is + begin + while not At_End loop + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + end case; + end loop; + end Number_Completion; + + --------------------- + -- Number_Fraction -- + --------------------- + + procedure Number_Fraction is + begin + -- Note that number fraction can be called in either State. + -- It will set state to Valid only if a 9 is encountered. + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Set_State (Okay); Skip; + + when others => + return; + end case; + end loop; + end Number_Fraction; + + -------------------------------- + -- Number_Fraction_Or_Bracket -- + -------------------------------- + + procedure Number_Fraction_Or_Bracket is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Bracket; + + ------------------------------- + -- Number_Fraction_Or_Dollar -- + ------------------------------- + + procedure Number_Fraction_Or_Dollar is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Dollar; + + ------------------------------ + -- Number_Fraction_Or_Pound -- + ------------------------------ + + procedure Number_Fraction_Or_Pound is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Pound; + + ---------------------------------- + -- Number_Fraction_Or_Star_Fill -- + ---------------------------------- + + procedure Number_Fraction_Or_Star_Fill is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Star_Fill; + + ------------------------------- + -- Number_Fraction_Or_Z_Fill -- + ------------------------------- + + procedure Number_Fraction_Or_Z_Fill is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Z_Fill; + + ----------------------- + -- Optional_RHS_Sign -- + ----------------------- + + procedure Optional_RHS_Sign is + begin + if At_End then + return; + end if; + + case Look is + when '+' | '-' => + Pic.Sign_Position := Index; + Skip; + return; + + when 'C' | 'c' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'C'; + Skip; + + if Look = 'R' or else Look = 'r' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'R'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when 'D' | 'd' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'D'; + Skip; + + if Look = 'B' or else Look = 'b' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'B'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when '>' => + if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then + Pic.Second_Sign := Index; + Skip; + + else + raise Picture_Error; + end if; + + when others => + return; + end case; + end Optional_RHS_Sign; + + ------------- + -- Picture -- + ------------- + + -- Note that Picture can be called in either State + + -- It will set state to Valid only if a 9 is encountered or floating + -- currency is called. + + procedure Picture is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Leading_Dollar; + return; + + when '#' => + Leading_Pound; + return; + + when '9' => + Computed_BWZ := False; + Set_State (Okay); + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + Trailing_Currency; + return; + + when others => + return; + end case; + end loop; + end Picture; + + --------------------- + -- Picture_Bracket -- + --------------------- + + procedure Picture_Bracket is + begin + Pic.Sign_Position := Index; + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '<'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Bracket + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Set_State (Okay); -- "<<>" is enough. + Floating_Bracket; + Trailing_Currency; + Trailing_Bracket; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Trailing_Bracket; + Set_State (Okay); + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + Trailing_Bracket; + return; + + when others => + raise Picture_Error; + end case; + end loop; + end Picture_Bracket; + + ------------------- + -- Picture_Minus -- + ------------------- + + procedure Picture_Minus is + begin + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '-'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Minus + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "-- " is enough + Floating_Minus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + + -- Can't have Z and a floating sign + + if State = Okay then + Set_State (Reject); + end if; + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + return; + + when others => + return; + end case; + end loop; + end Picture_Minus; + + ------------------ + -- Picture_Plus -- + ------------------ + + procedure Picture_Plus is + begin + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '+'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Plus + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "++" is enough + Floating_Plus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + if State = Okay then + Set_State (Reject); + end if; + + -- Can't have Z and a floating sign + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + -- '+Z' is acceptable + + Set_State (Okay); + + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + return; + + when others => + return; + end case; + end loop; + end Picture_Plus; + + -------------------- + -- Picture_String -- + -------------------- + + procedure Picture_String is + begin + while Is_Insert loop + Skip; + end loop; + + case Look is + when '$' | '#' => + Picture; + Optional_RHS_Sign; + + when '+' => + Picture_Plus; + + when '-' => + Picture_Minus; + + when '<' => + Picture_Bracket; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '*' => + Star_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '9' | '.' | 'V' | 'v' => + Number; + Trailing_Currency; + Optional_RHS_Sign; + + when others => + raise Picture_Error; + end case; + + -- Blank when zero either if the PIC does not contain a '9' or if + -- requested by the user and no '*'. + + Pic.Blank_When_Zero := + (Computed_BWZ or else Pic.Blank_When_Zero) + and then not Pic.Star_Fill; + + -- Star fill if '*' and no '9' + + Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; + + if not At_End then + Set_State (Reject); + end if; + end Picture_String; + + --------------- + -- Set_State -- + --------------- + + procedure Set_State (L : Legality) is + begin + State := L; + end Set_State; + + ---------- + -- Skip -- + ---------- + + procedure Skip is + begin + Index := Index + 1; + end Skip; + + ---------------------- + -- Star_Suppression -- + ---------------------- + + procedure Star_Suppression is + begin + Pic.Floater := '*'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + + -- Even a single * is a valid picture + + Pic.Star_Fill := True; + Skip; -- Known * + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Star_Fill; + return; + + when '#' | '$' => + Trailing_Currency; + Set_State (Okay); + return; + + when others => + raise Picture_Error; + end case; + end loop; + end Star_Suppression; + + ---------------------- + -- Trailing_Bracket -- + ---------------------- + + procedure Trailing_Bracket is + begin + if Look = '>' then + Pic.Second_Sign := Index; + Skip; + else + raise Picture_Error; + end if; + end Trailing_Bracket; + + ----------------------- + -- Trailing_Currency -- + ----------------------- + + procedure Trailing_Currency is + begin + if At_End then + return; + end if; + + if Look = '$' then + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Skip; + + else + while not At_End and then Look = '#' loop + if Pic.Start_Currency = Invalid_Position then + Pic.Start_Currency := Index; + end if; + + Pic.End_Currency := Index; + Skip; + end loop; + end if; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + end Trailing_Currency; + + ---------------------- + -- Zero_Suppression -- + ---------------------- + + procedure Zero_Suppression is + begin + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; -- Known Z + + loop + -- Even a single Z is a valid picture + + if At_End then + Set_State (Okay); + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Set_State (Okay); + Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Z_Fill; + return; + + when '#' | '$' => + Trailing_Currency; + Set_State (Okay); + return; + + when others => + return; + end case; + end loop; + end Zero_Suppression; + + -- Start of processing for Precalculate + + begin + Picture_String; + + if State = Reject then + raise Picture_Error; + end if; + + exception + + when Constraint_Error => + + -- To deal with special cases like null strings + + raise Picture_Error; + end Precalculate; + + ---------------- + -- To_Picture -- + ---------------- + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture + is + Result : Picture; + + begin + declare + Item : constant String := Expand (Pic_String); + + begin + Result.Contents.Picture := (Item'Length, Item); + Result.Contents.Original_BWZ := Blank_When_Zero; + Result.Contents.Blank_When_Zero := Blank_When_Zero; + Precalculate (Result.Contents); + return Result; + end; + + exception + when others => + raise Picture_Error; + + end To_Picture; + + ------------- + -- To_Wide -- + ------------- + + function To_Wide (C : Character) return Wide_Character is + begin + return Wide_Character'Val (Character'Pos (C)); + end To_Wide; + + ----------- + -- Valid -- + ----------- + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean + is + begin + declare + Expanded_Pic : constant String := Expand (Pic_String); + -- Raises Picture_Error if Item not well-formed + + Format_Rec : Format_Record; + + begin + Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); + Format_Rec.Blank_When_Zero := Blank_When_Zero; + Format_Rec.Original_BWZ := Blank_When_Zero; + Precalculate (Format_Rec); + + -- False only if Blank_When_0 is True but the pic string has a '*' + + return not Blank_When_Zero + or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; + end; + + exception + when others => return False; + end Valid; + +end Ada.Wide_Text_IO.Editing; diff --git a/gcc/ada/libgnat/a-wtedit.ads b/gcc/ada/libgnat/a-wtedit.ads new file mode 100644 index 0000000..1f2c1b1 --- /dev/null +++ b/gcc/ada/libgnat/a-wtedit.ads @@ -0,0 +1,197 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . E D I T I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Text_IO.Editing is + + type Picture is private; + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean; + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture; + + function Pic_String (Pic : Picture) return String; + function Blank_When_Zero (Pic : Picture) return Boolean; + + Max_Picture_Length : constant := 64; + + Picture_Error : exception; + + Default_Currency : constant Wide_String := "$"; + Default_Fill : constant Wide_Character := ' '; + Default_Separator : constant Wide_Character := ','; + Default_Radix_Mark : constant Wide_Character := '.'; + + generic + type Num is delta <> digits <>; + Default_Currency : Wide_String := + Wide_Text_IO.Editing.Default_Currency; + Default_Fill : Wide_Character := + Wide_Text_IO.Editing.Default_Fill; + Default_Separator : Wide_Character := + Wide_Text_IO.Editing.Default_Separator; + Default_Radix_Mark : Wide_Character := + Wide_Text_IO.Editing.Default_Radix_Mark; + + package Decimal_Output is + + function Length + (Pic : Picture; + Currency : Wide_String := Default_Currency) return Natural; + + function Valid + (Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency) return Boolean; + + function Image + (Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark) return Wide_String; + + procedure Put + (File : File_Type; + Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark); + + procedure Put + (Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark); + + procedure Put + (To : out Wide_String; + Item : Num; + Pic : Picture; + Currency : Wide_String := Default_Currency; + Fill : Wide_Character := Default_Fill; + Separator : Wide_Character := Default_Separator; + Radix_Mark : Wide_Character := Default_Radix_Mark); + + end Decimal_Output; + +private + MAX_PICSIZE : constant := 50; + MAX_MONEYSIZE : constant := 10; + Invalid_Position : constant := -1; + + subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; + + type Picture_Record (Length : Pic_Index := 0) is record + Expanded : String (1 .. Length); + end record; + + type Format_Record is record + Picture : Picture_Record; + -- Read only + + Blank_When_Zero : Boolean; + -- Read/write + + Original_BWZ : Boolean; + + -- The following components get written + + Star_Fill : Boolean := False; + + Radix_Position : Integer := Invalid_Position; + + Sign_Position, + Second_Sign : Integer := Invalid_Position; + + Start_Float, + End_Float : Integer := Invalid_Position; + + Start_Currency, + End_Currency : Integer := Invalid_Position; + + Max_Leading_Digits : Integer := 0; + + Max_Trailing_Digits : Integer := 0; + + Max_Currency_Digits : Integer := 0; + + Floater : Wide_Character := '!'; + -- Initialized to illegal value + + end record; + + type Picture is record + Contents : Format_Record; + end record; + + type Number_Attributes is record + Negative : Boolean := False; + + Has_Fraction : Boolean := False; + + Start_Of_Int, + End_Of_Int, + Start_Of_Fraction, + End_Of_Fraction : Integer := Invalid_Position; -- invalid value + end record; + + function Parse_Number_String (Str : String) return Number_Attributes; + -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no + -- trailing blanks...) + + procedure Precalculate (Pic : in out Format_Record); + -- Precalculates fields from the user supplied data + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : Wide_String; + Fill_Character : Wide_Character; + Separator_Character : Wide_Character; + Radix_Point : Wide_Character) return Wide_String; + -- Formats number according to Pic + + function Expand (Picture : String) return String; + +end Ada.Wide_Text_IO.Editing; diff --git a/gcc/ada/libgnat/a-wtenau.adb b/gcc/ada/libgnat/a-wtenau.adb new file mode 100644 index 0000000..3c88036 --- /dev/null +++ b/gcc/ada/libgnat/a-wtenau.adb @@ -0,0 +1,349 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.WCh_Con; use System.WCh_Con; + +package body Ada.Wide_Text_IO.Enumeration_Aux is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Store_Char + (WC : Wide_Character; + Buf : out Wide_String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow + + -- These definitions replace the ones in Ada.Characters.Handling, which + -- do not seem to work for some strange not understood reason ??? at + -- least in the OS/2 version. + + function To_Lower (C : Character) return Character; + + ------------------ + -- Get_Enum_Lit -- + ------------------ + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out Wide_String; + Buflen : out Natural) + is + ch : int; + WC : Wide_Character; + + begin + Buflen := 0; + Load_Skip (TFT (File)); + ch := Nextc (TFT (File)); + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L) + + if ch = Character'Pos (''') then + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + if ch = LM or else ch = EOF then + return; + end if; + + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + if ch /= Character'Pos (''') then + return; + end if; + + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter. Any wide character value + -- outside the normal Latin-1 range counts as a letter for this. + + if ch < 255 and then not Is_Letter (Character'Val (ch)) then + return; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + loop + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + exit when ch = EOF; + + if ch = Character'Pos ('_') then + exit when Buf (Buflen) = '_'; + + elsif ch = Character'Pos (ASCII.ESC) then + null; + + elsif File.WC_Method in WC_Upper_Half_Encoding_Method + and then ch > 127 + then + null; + + else + exit when not Is_Letter (Character'Val (ch)) + and then + not Is_Digit (Character'Val (ch)); + end if; + end loop; + end if; + end Get_Enum_Lit; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_String; + Width : Field; + Set : Type_Set) + is + Actual_Width : constant Integer := + Integer'Max (Integer (Width), Item'Length); + + begin + Check_On_One_Line (TFT (File), Actual_Width); + + if Set = Lower_Case and then Item (Item'First) /= ''' then + declare + Iteml : Wide_String (Item'First .. Item'Last); + + begin + for J in Item'Range loop + if Is_Character (Item (J)) then + Iteml (J) := + To_Wide_Character (To_Lower (To_Character (Item (J)))); + else + Iteml (J) := Item (J); + end if; + end loop; + + Put (File, Iteml); + end; + + else + Put (File, Item); + end if; + + for J in 1 .. Actual_Width - Item'Length loop + Put (File, ' '); + end loop; + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out Wide_String; + Item : Wide_String; + Set : Type_Set) + is + Ptr : Natural; + + begin + if Item'Length > To'Length then + raise Layout_Error; + + else + Ptr := To'First; + for J in Item'Range loop + if Set = Lower_Case + and then Item (Item'First) /= ''' + and then Is_Character (Item (J)) + then + To (Ptr) := + To_Wide_Character (To_Lower (To_Character (Item (J)))); + else + To (Ptr) := Item (J); + end if; + + Ptr := Ptr + 1; + end loop; + + while Ptr <= To'Last loop + To (Ptr) := ' '; + Ptr := Ptr + 1; + end loop; + end if; + end Puts; + + ------------------- + -- Scan_Enum_Lit -- + ------------------- + + procedure Scan_Enum_Lit + (From : Wide_String; + Start : out Natural; + Stop : out Natural) + is + WC : Wide_Character; + + -- Processing for Scan_Enum_Lit + + begin + Start := From'First; + + loop + if Start > From'Last then + raise End_Error; + + elsif Is_Character (From (Start)) + and then not Is_Blank (To_Character (From (Start))) + then + exit; + + else + Start := Start + 1; + end if; + end loop; + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L + -- which is for the analogous case for reading from a file). + + if From (Start) = ''' then + Stop := Start; + + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + end if; + + if From (Stop) in ' ' .. '~' + or else From (Stop) >= Wide_Character'Val (16#80#) + then + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + + if From (Stop) = ''' then + return; + end if; + end if; + end if; + + raise Data_Error; + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter, any wide character outside + -- the normal Latin-1 range is considered a letter for this test. + + if Is_Character (From (Start)) + and then not Is_Letter (To_Character (From (Start))) + then + raise Data_Error; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + Stop := Start + 1; + while Stop < From'Last loop + WC := From (Stop + 1); + + exit when + Is_Character (WC) + and then + not Is_Letter (To_Character (WC)) + and then + (WC /= '_' or else From (Stop - 1) = '_'); + + Stop := Stop + 1; + end loop; + end if; + + end Scan_Enum_Lit; + + ---------------- + -- Store_Char -- + ---------------- + + procedure Store_Char + (WC : Wide_Character; + Buf : out Wide_String; + Ptr : in out Integer) + is + begin + if Ptr = Buf'Last then + raise Data_Error; + else + Ptr := Ptr + 1; + Buf (Ptr) := WC; + end if; + end Store_Char; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (C : Character) return Character is + begin + if C in 'A' .. 'Z' then + return Character'Val (Character'Pos (C) + 32); + else + return C; + end if; + end To_Lower; + +end Ada.Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/libgnat/a-wtenau.ads b/gcc/ada/libgnat/a-wtenau.ads new file mode 100644 index 0000000..a466aaa --- /dev/null +++ b/gcc/ada/libgnat/a-wtenau.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Text_IO.Enumeration_IO +-- that are shared among separate instantiations. + +private package Ada.Wide_Text_IO.Enumeration_Aux is + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out Wide_String; + Buflen : out Natural); + -- Reads an enumeration literal value from the file, folds to upper case, + -- and stores the result in Buf, setting Buflen to the number of stored + -- characters (Buf has a lower bound of 1). If more than Buflen characters + -- are present in the literal, Data_Error is raised. + + procedure Scan_Enum_Lit + (From : Wide_String; + Start : out Natural; + Stop : out Natural); + -- Scans an enumeration literal at the start of From, skipping any leading + -- spaces. Sets Start to the first character, Stop to the last character. + -- Raises End_Error if no enumeration literal is found. + + procedure Put + (File : File_Type; + Item : Wide_String; + Width : Field; + Set : Type_Set); + -- Outputs the enumeration literal image stored in Item to the given File, + -- using the given Width and Set parameters (Item is always in upper case). + + procedure Puts + (To : out Wide_String; + Item : Wide_String; + Set : Type_Set); + -- Stores the enumeration literal image stored in Item to the string To, + -- padding with trailing spaces if necessary to fill To. Set is used to + +end Ada.Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/libgnat/a-wtenio.adb b/gcc/ada/libgnat/a-wtenio.adb new file mode 100644 index 0000000..ef80a2e --- /dev/null +++ b/gcc/ada/libgnat/a-wtenio.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Enumeration_Aux; + +package body Ada.Wide_Text_IO.Enumeration_IO is + + package Aux renames Ada.Wide_Text_IO.Enumeration_Aux; + + --------- + -- Get -- + --------- + + procedure Get (File : File_Type; Item : out Enum) is + Buf : Wide_String (1 .. Enum'Width); + Buflen : Natural; + begin + Aux.Get_Enum_Lit (File, Buf, Buflen); + Item := Enum'Wide_Value (Buf (1 .. Buflen)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get (Item : out Enum) is + begin + Get (Current_Input, Item); + end Get; + + procedure Get + (From : Wide_String; + Item : out Enum; + Last : out Positive) + is + Start : Natural; + begin + Aux.Scan_Enum_Lit (From, Start, Last); + Item := Enum'Wide_Value (From (Start .. Last)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_String := Enum'Wide_Image (Item); + begin + Aux.Put (File, Image, Width, Set); + end Put; + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + begin + Put (Current_Output, Item, Width, Set); + end Put; + + procedure Put + (To : out Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_String := Enum'Wide_Image (Item); + begin + Aux.Puts (To, Image, Set); + end Put; + +end Ada.Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-wtenio.ads b/gcc/ada/libgnat/a-wtenio.ads new file mode 100644 index 0000000..f0a1c0b --- /dev/null +++ b/gcc/ada/libgnat/a-wtenio.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Enumeration_IO is a subpackage +-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading the +-- necessary code if Enumeration_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Enum is (<>); + +package Ada.Wide_Text_IO.Enumeration_IO is + + Default_Width : Field := 0; + Default_Setting : Type_Set := Upper_Case; + + procedure Get (File : File_Type; Item : out Enum); + procedure Get (Item : out Enum); + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Get + (From : Wide_String; + Item : out Enum; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting); + +end Ada.Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-wtfiio.adb b/gcc/ada/libgnat/a-wtfiio.adb new file mode 100644 index 0000000..fc41c45 --- /dev/null +++ b/gcc/ada/libgnat/a-wtfiio.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Fixed_IO is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-wtfiio.ads b/gcc/ada/libgnat/a-wtfiio.ads new file mode 100644 index 0000000..939229e --- /dev/null +++ b/gcc/ada/libgnat/a-wtfiio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Fixed_IO is a subpackage of +-- Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Fixed_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <>; + +package Ada.Wide_Text_IO.Fixed_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-wtflau.adb b/gcc/ada/libgnat/a-wtflau.adb new file mode 100644 index 0000000..daf4583 --- /dev/null +++ b/gcc/ada/libgnat/a-wtflau.adb @@ -0,0 +1,235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F L O A T _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; + +with System.Img_Real; use System.Img_Real; +with System.Val_Real; use System.Val_Real; + +package body Ada.Wide_Text_IO.Float_Aux is + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + end if; + + Item := Scan_Real (Buf, Ptr'Access, Stop); + + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Real (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets; + + --------------- + -- Load_Real -- + --------------- + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Loaded : Boolean; + + begin + -- Skip initial blanks and load possible sign + + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + -- Case of .nnnn + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Otherwise must have digits to start + + else + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + + -- Case of nnn#.xxx# + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '#', ':'); + + -- Case of nnn#xxx.[xxx]# or nnn#xxx# + + else + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + end if; + + -- As usual, it seems strange to allow mixed base characters, + -- but that is what ACVC tests expect, see CE3804M, case (3). + + Load (File, Buf, Ptr, '#', ':'); + end if; + + -- Case of nnn.[nnn] or nnn + + else + -- Prevent the potential processing of '.' in cases where the + -- initial digits have a trailing underscore. + + if Buf (Ptr) = '_' then + return; + end if; + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr); + end if; + end if; + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end Load_Real; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); + + if Ptr > To'Length then + raise Layout_Error; + + else + for J in 1 .. Ptr loop + To (To'Last - Ptr + J) := Buf (J); + end loop; + + for J in To'First .. To'Last - Ptr loop + To (J) := ' '; + end loop; + end if; + end Puts; + +end Ada.Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/libgnat/a-wtflau.ads b/gcc/ada/libgnat/a-wtflau.ads new file mode 100644 index 0000000..6addc74 --- /dev/null +++ b/gcc/ada/libgnat/a-wtflau.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F L O A T _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Text_IO.Float_IO that +-- are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Float_IO itself, +-- except that generic parameter Num has been replaced by Long_Long_Float, +-- and the default parameters have been removed because they are supplied +-- explicitly by the calls from within the generic template. This package +-- is also used by Ada.Wide_Text_IO.Fixed_IO, Ada.Wide_Text_IO.Decimal_IO. + +private package Ada.Wide_Text_IO.Float_Aux is + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load a possibly signed + -- real literal value from the input file into Buf, starting at Ptr + 1. + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field); + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive); + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/libgnat/a-wtflio.adb b/gcc/ada/libgnat/a-wtflio.adb new file mode 100644 index 0000000..24bd570 --- /dev/null +++ b/gcc/ada/libgnat/a-wtflio.adb @@ -0,0 +1,127 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Float_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Float_IO is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Float_IO; diff --git a/gcc/ada/libgnat/a-wtflio.ads b/gcc/ada/libgnat/a-wtflio.ads new file mode 100644 index 0000000..445ad26 --- /dev/null +++ b/gcc/ada/libgnat/a-wtflio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Float_IO is a subpackage of +-- Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Float_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is digits <>; + +package Ada.Wide_Text_IO.Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Text_IO.Float_IO; diff --git a/gcc/ada/libgnat/a-wtgeau.adb b/gcc/ada/libgnat/a-wtgeau.adb new file mode 100644 index 0000000..365e6d0 --- /dev/null +++ b/gcc/ada/libgnat/a-wtgeau.adb @@ -0,0 +1,528 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; + +package body Ada.Wide_Text_IO.Generic_Aux is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + subtype AP is FCB.AFCB_Ptr; + + ------------------------ + -- Check_End_Of_Field -- + ------------------------ + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field) + is + begin + if Ptr > Stop then + return; + + elsif Width = 0 then + raise Data_Error; + + else + for J in Ptr .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + end if; + end Check_End_Of_Field; + + ----------------------- + -- Check_On_One_Line -- + ----------------------- + + procedure Check_On_One_Line + (File : File_Type; + Length : Integer) + is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Line_Length /= 0 then + if Count (Length) > File.Line_Length then + raise Layout_Error; + elsif File.Col + Count (Length) > File.Line_Length + 1 then + New_Line (File); + end if; + end if; + end Check_On_One_Line; + + -------------- + -- Is_Blank -- + -------------- + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + ---------- + -- Load -- + ---------- + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean) + is + ch : int; + + begin + if File.Before_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character) + is + ch : int; + + begin + if File.Before_Wide_Character then + null; + + else + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean) + is + ch : int; + + begin + if File.Before_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch = Character'Pos (Char1) + or else ch = Character'Pos (Char2) + then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character) + is + ch : int; + + begin + if File.Before_Wide_Character then + null; + + else + ch := Getc (File); + + if ch = Character'Pos (Char1) + or else ch = Character'Pos (Char2) + then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end if; + end Load; + + ----------------- + -- Load_Digits -- + ----------------- + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean; + + begin + if File.Before_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch not in Character'Pos ('0') .. Character'Pos ('9') then + Loaded := False; + + else + Loaded := True; + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end if; + end Load_Digits; + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + After_Digit : Boolean; + + begin + if File.Before_Wide_Character then + return; + + else + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end if; + end Load_Digits; + + -------------------------- + -- Load_Extended_Digits -- + -------------------------- + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean := False; + + begin + if File.Before_Wide_Character then + Loaded := False; + return; + + else + Loaded := False; + + loop + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') + or else + ch in Character'Pos ('a') .. Character'Pos ('f') + or else + ch in Character'Pos ('A') .. Character'Pos ('F') + then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + end loop; + + Ungetc (ch, File); + end if; + end Load_Extended_Digits; + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + Junk : Boolean; + pragma Unreferenced (Junk); + begin + Load_Extended_Digits (File, Buf, Ptr, Junk); + end Load_Extended_Digits; + + --------------- + -- Load_Skip -- + --------------- + + procedure Load_Skip (File : File_Type) is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + -- We need to explicitly test for the case of being before a wide + -- character (greater than 16#7F#). Since no such character can + -- ever legitimately be a valid numeric character, we can + -- immediately signal Data_Error. + + if File.Before_Wide_Character then + raise Data_Error; + end if; + + -- Otherwise loop till we find a non-blank character (note that as + -- usual in Wide_Text_IO, blank includes horizontal tab). Note that + -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately. + + loop + Get_Character (File, C); + exit when not Is_Blank (C); + end loop; + + Ungetc (Character'Pos (C), File); + File.Col := File.Col - 1; + end Load_Skip; + + ---------------- + -- Load_Width -- + ---------------- + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + WC : Wide_Character; + + Bad_Wide_C : Boolean := False; + -- Set True if one of the characters read is not in range of type + -- Character. This is always a Data_Error, but we do not signal it + -- right away, since we have to read the full number of characters. + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are immediately before a line mark, then we have no characters. + -- This is always a data error, so we may as well raise it right away. + + if File.Before_LM then + raise Data_Error; + + else + for J in 1 .. Width loop + if File.Before_Wide_Character then + Bad_Wide_C := True; + Store_Char (File, 0, Buf, Ptr); + File.Before_Wide_Character := False; + + else + ch := Getc (File); + + if ch = EOF then + exit; + + elsif ch = LM then + Ungetc (ch, File); + exit; + + else + WC := Get_Wide_Char (Character'Val (ch), File); + ch := Wide_Character'Pos (WC); + + if ch > 255 then + Bad_Wide_C := True; + ch := 0; + end if; + + Store_Char (File, ch, Buf, Ptr); + end if; + end if; + end loop; + + if Bad_Wide_C then + raise Data_Error; + end if; + end if; + end Load_Width; + + -------------- + -- Put_Item -- + -------------- + + procedure Put_Item (File : File_Type; Str : String) is + begin + Check_On_One_Line (File, Str'Length); + + for J in Str'Range loop + Put (File, Wide_Character'Val (Character'Pos (Str (J)))); + end loop; + end Put_Item; + + ---------------- + -- Store_Char -- + ---------------- + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : out String; + Ptr : in out Integer) + is + begin + File.Col := File.Col + 1; + + if Ptr = Buf'Last then + raise Data_Error; + else + Ptr := Ptr + 1; + Buf (Ptr) := Character'Val (ch); + end if; + end Store_Char; + + ----------------- + -- String_Skip -- + ----------------- + + procedure String_Skip (Str : String; Ptr : out Integer) is + begin + -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. + -- It's too much trouble to make this silly case work, so we just raise + -- Program_Error with an appropriate message. We raise Program_Error + -- rather than Constraint_Error because we don't want this case to be + -- converted to Data_Error. + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + -- Normal case where Str'Last < Positive'Last + + Ptr := Str'First; + + loop + if Ptr > Str'Last then + raise End_Error; + + elsif not Is_Blank (Str (Ptr)) then + return; + + else + Ptr := Ptr + 1; + end if; + end loop; + end String_Skip; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + +end Ada.Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/libgnat/a-wtgeau.ads b/gcc/ada/libgnat/a-wtgeau.ads new file mode 100644 index 0000000..432afc5 --- /dev/null +++ b/gcc/ada/libgnat/a-wtgeau.ads @@ -0,0 +1,184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a set of auxiliary routines used by Wide_Text_IO +-- generic children, including for reading and writing numeric strings. + +-- Note: although this is the Wide version of the package, the interface +-- here is still in terms of Character and String rather than Wide_Character +-- and Wide_String, since all numeric strings are composed entirely of +-- characters in the range of type Standard.Character, and the basic +-- conversion routines work with Character rather than Wide_Character. + +package Ada.Wide_Text_IO.Generic_Aux is + + -- Note: for all the Load routines, File indicates the file to be read, + -- Buf is the string into which data is stored, Ptr is the index of the + -- last character stored so far, and is updated if additional characters + -- are stored. Data_Error is raised if the input overflows Buf. The only + -- Load routines that do a file status check are Load_Skip and Load_Width + -- so one of these two routines must be called first. + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field); + -- This routine is used after doing a get operations on a numeric value. + -- Buf is the string being scanned, and Stop is the last character of + -- the field being scanned. Ptr is as set by the call to the scan routine + -- that scanned out the numeric value, i.e. it points one past the last + -- character scanned, and Width is the width parameter from the Get call. + -- + -- There are two cases, if Width is non-zero, then a check is made that + -- the remainder of the field is all blanks. If Width is zero, then it + -- means that the scan routine scanned out only part of the field. We + -- have already scanned out the field that the ACVC tests seem to expect + -- us to read (even if it does not follow the syntax of the type being + -- scanned, e.g. allowing negative exponents in integers, and underscores + -- at the end of the string), so we just raise Data_Error. + + procedure Check_On_One_Line (File : File_Type; Length : Integer); + -- Check to see if item of length Integer characters can fit on + -- current line. Call New_Line if not, first checking that the + -- line length can accommodate Length characters, raise Layout_Error + -- if item is too large for a single line. + + function Is_Blank (C : Character) return Boolean; + -- Determines if C is a blank (space or tab) + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer); + -- Loads exactly Width characters, unless a line mark is encountered first + + procedure Load_Skip (File : File_Type); + -- Skips leading blanks and line and page marks, if the end of file is + -- read without finding a non-blank character, then End_Error is raised. + -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean); + -- If next character is Char, loads it, otherwise no characters are loaded + -- Loaded is set to indicate whether or not the character was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character); + -- Same as above, but no indication if character is loaded + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean); + -- If next character is Char1 or Char2, loads it, otherwise no characters + -- are loaded. Loaded is set to indicate whether or not one of the two + -- characters was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character); + -- Same as above, but no indication if character is loaded + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Loads a sequence of zero or more decimal digits. Loaded is set if + -- at least one digit is loaded. + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Like Load_Digits, but also allows extended digits a-f and A-F + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Put_Item (File : File_Type; Str : String); + -- This routine is like Wide_Text_IO.Put, except that it checks for + -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used + -- for all output of numeric values and of enumeration values. Note that + -- the buffer is of type String. Put_Item deals with converting this to + -- Wide_Characters as required. + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : out String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow and + -- adjusting the column number in the file to reflect the fact + -- that a character has been acquired from the input stream. + -- The pos value of the character to store is in ch on entry. + + procedure String_Skip (Str : String; Ptr : out Integer); + -- Used in the Get from string procedures to skip leading blanks in the + -- string. Ptr is set to the index of the first non-blank. If the string + -- is all blanks, then the excption End_Error is raised, Note that blank + -- is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Ungetc (ch : Integer; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has + -- checked that the file is in read status. Device_Error is raised + -- if the character cannot be pushed back. An attempt to push back + -- an end of file (EOF) is ignored. + +private + pragma Inline (Is_Blank); + +end Ada.Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/libgnat/a-wtinau.adb b/gcc/ada/libgnat/a-wtinau.adb new file mode 100644 index 0000000..26d884f --- /dev/null +++ b/gcc/ada/libgnat/a-wtinau.adb @@ -0,0 +1,295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; + +package body Ada.Wide_Text_IO.Integer_Aux is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load an possibly signed + -- integer literal value from the input file into Buf, starting at Ptr + 1. + -- On return, Ptr is set to the last character stored. + + ------------- + -- Get_Int -- + ------------- + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Int; + + ------------- + -- Get_LLI -- + ------------- + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLI; + + -------------- + -- Gets_Int -- + -------------- + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Int; + + -------------- + -- Gets_LLI -- + -------------- + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLI; + + ------------------ + -- Load_Integer -- + ------------------ + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Integer; + + ------------- + -- Put_Int -- + ------------- + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Int; + + ------------- + -- Put_LLI -- + ------------- + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLI; + + -------------- + -- Puts_Int -- + -------------- + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Int; + + -------------- + -- Puts_LLI -- + -------------- + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLI; + +end Ada.Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-wtinau.ads b/gcc/ada/libgnat/a-wtinau.ads new file mode 100644 index 0000000..c5e2902 --- /dev/null +++ b/gcc/ada/libgnat/a-wtinau.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Text_IO.Integer_IO that +-- are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Integer_IO itself, +-- except that the generic parameter Num has been replaced by Integer or +-- Long_Long_Integer, and the default parameters have been removed because +-- they are supplied explicitly by the calls from within the generic template. + +private package Ada.Wide_Text_IO.Integer_Aux is + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field); + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field); + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive); + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive); + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base); + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base); + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base); + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base); + +end Ada.Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-wtinio.adb b/gcc/ada/libgnat/a-wtinio.adb new file mode 100644 index 0000000..9cf4072 --- /dev/null +++ b/gcc/ada/libgnat/a-wtinio.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Integer_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Integer_IO is + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Integer_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Need_LLI then + Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); + else + Aux.Get_Int (TFT (File), Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLI then + Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); + else + Aux.Gets_Int (S, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); + else + Aux.Put_Int (TFT (File), Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLI then + Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); + else + Aux.Puts_Int (S, Integer (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-wtinio.ads b/gcc/ada/libgnat/a-wtinio.ads new file mode 100644 index 0000000..c2821db --- /dev/null +++ b/gcc/ada/libgnat/a-wtinio.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Integer_IO is a subpackage +-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Integer_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is range <>; + +package Ada.Wide_Text_IO.Integer_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-wtmoau.adb b/gcc/ada/libgnat/a-wtmoau.adb new file mode 100644 index 0000000..1e1f852 --- /dev/null +++ b/gcc/ada/libgnat/a-wtmoau.adb @@ -0,0 +1,305 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Generic_Aux; use Ada.Wide_Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; + +package body Ada.Wide_Text_IO.Modular_Aux is + + use System.Unsigned_Types; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load an possibly signed + -- modular literal value from the input file into Buf, starting at Ptr + 1. + -- Ptr is left set to the last character stored. + + ------------- + -- Get_LLU -- + ------------- + + procedure Get_LLU + (File : File_Type; + Item : out Long_Long_Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLU; + + ------------- + -- Get_Uns -- + ------------- + + procedure Get_Uns + (File : File_Type; + Item : out Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Uns; + + -------------- + -- Gets_LLU -- + -------------- + + procedure Gets_LLU + (From : String; + Item : out Long_Long_Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLU; + + -------------- + -- Gets_Uns -- + -------------- + + procedure Gets_Uns + (From : String; + Item : out Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Uns; + + ------------------ + -- Load_Modular -- + ------------------ + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + + -- Note: it is a bit strange to allow a minus sign here, but it seems + -- consistent with the general behavior expected by the ACVC tests + -- which is to scan past junk and then signal data error, see ACVC + -- test CE3704F, case (6), which is for signed integer exponents, + -- which seems a similar case. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants + -- for the signed case, and there seems no good reason to treat + -- exponents differently for the signed and unsigned cases. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Modular; + + ------------- + -- Put_LLU -- + ------------- + + procedure Put_LLU + (File : File_Type; + Item : Long_Long_Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLU; + + ------------- + -- Put_Uns -- + ------------- + + procedure Put_Uns + (File : File_Type; + Item : Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Uns; + + -------------- + -- Puts_LLU -- + -------------- + + procedure Puts_LLU + (To : out String; + Item : Long_Long_Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLU; + + -------------- + -- Puts_Uns -- + -------------- + + procedure Puts_Uns + (To : out String; + Item : Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Uns; + +end Ada.Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-wtmoau.ads b/gcc/ada/libgnat/a-wtmoau.ads new file mode 100644 index 0000000..2e9c328 --- /dev/null +++ b/gcc/ada/libgnat/a-wtmoau.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Text_IO.Modular_IO that +-- are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Modular_IO itself, +-- except that the generic parameter Num has been replaced by Unsigned or +-- Long_Long_Unsigned, and the default parameters have been removed because +-- they are supplied explicitly by the calls from within the generic template. + +with System.Unsigned_Types; + +private package Ada.Wide_Text_IO.Modular_Aux is + + package U renames System.Unsigned_Types; + + procedure Get_Uns + (File : File_Type; + Item : out U.Unsigned; + Width : Field); + + procedure Get_LLU + (File : File_Type; + Item : out U.Long_Long_Unsigned; + Width : Field); + + procedure Gets_Uns + (From : String; + Item : out U.Unsigned; + Last : out Positive); + + procedure Gets_LLU + (From : String; + Item : out U.Long_Long_Unsigned; + Last : out Positive); + + procedure Put_Uns + (File : File_Type; + Item : U.Unsigned; + Width : Field; + Base : Number_Base); + + procedure Put_LLU + (File : File_Type; + Item : U.Long_Long_Unsigned; + Width : Field; + Base : Number_Base); + + procedure Puts_Uns + (To : out String; + Item : U.Unsigned; + Base : Number_Base); + + procedure Puts_LLU + (To : out String; + Item : U.Long_Long_Unsigned; + Base : Number_Base); + +end Ada.Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-wtmoio.adb b/gcc/ada/libgnat/a-wtmoio.adb new file mode 100644 index 0000000..509a2aa --- /dev/null +++ b/gcc/ada/libgnat/a-wtmoio.adb @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO.Modular_Aux; + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Text_IO.Modular_IO is + + subtype TFT is Ada.Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Text_IO.Modular_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Unsigned'Size then + Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); + else + Aux.Get_Uns (TFT (File), Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Unsigned'Size then + Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); + else + Aux.Gets_Uns (S, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Num'Size > Unsigned'Size then + Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); + else + Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Unsigned'Size then + Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); + else + Aux.Puts_Uns (S, Unsigned (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-wtmoio.ads b/gcc/ada/libgnat/a-wtmoio.ads new file mode 100644 index 0000000..4fe7c6b --- /dev/null +++ b/gcc/ada/libgnat/a-wtmoio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Text_IO.Modular_IO is a subpackage +-- of Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Modular_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is mod <>; + +package Ada.Wide_Text_IO.Modular_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-wttest.adb b/gcc/ada/libgnat/a-wttest.adb new file mode 100644 index 0000000..f966560 --- /dev/null +++ b/gcc/ada/libgnat/a-wttest.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; + +package body Ada.Wide_Text_IO.Text_Streams is + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); + return Stream_Access (File); + end Stream; + +end Ada.Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/libgnat/a-wttest.ads b/gcc/ada/libgnat/a-wttest.ads new file mode 100644 index 0000000..7c180ff --- /dev/null +++ b/gcc/ada/libgnat/a-wttest.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; + +package Ada.Wide_Text_IO.Text_Streams is + + type Stream_Access is access all Streams.Root_Stream_Type'Class; + + function Stream (File : File_Type) return Stream_Access; + +end Ada.Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/libgnat/a-wwboio.adb b/gcc/ada/libgnat/a-wwboio.adb new file mode 100644 index 0000000..4b12984 --- /dev/null +++ b/gcc/ada/libgnat/a-wwboio.adb @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . W I D E _ B O U N D E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Text_IO; use Ada.Wide_Text_IO; +with Ada.Unchecked_Deallocation; + +package body Ada.Wide_Text_IO.Wide_Bounded_IO is + + type Wide_String_Access is access all Wide_String; + + procedure Free (WSA : in out Wide_String_Access); + -- Perform an unchecked deallocation of a non-null string + + ---------- + -- Free -- + ---------- + + procedure Free (WSA : in out Wide_String_Access) is + Null_Wide_String : constant Wide_String := ""; + + procedure Deallocate is + new Ada.Unchecked_Deallocation (Wide_String, Wide_String_Access); + + begin + -- Do not try to free statically allocated null string + + if WSA.all /= Null_Wide_String then + Deallocate (WSA); + end if; + end Free; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Wide_Bounded.Bounded_Wide_String is + begin + return Wide_Bounded.To_Bounded_Wide_String (Get_Line); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line + (File : File_Type) return Wide_Bounded.Bounded_Wide_String + is + begin + return Wide_Bounded.To_Bounded_Wide_String (Get_Line (File)); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Item : out Wide_Bounded.Bounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_String_Access; + Str2 : Wide_String_Access; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Bounded.To_Bounded_Wide_String (Str1.all); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_Bounded.Bounded_Wide_String) + is + Buffer : Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_String_Access; + Str2 : Wide_String_Access; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Bounded.To_Bounded_Wide_String (Str1.all); + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put (Wide_Bounded.To_Wide_String (Item)); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put (File, Wide_Bounded.To_Wide_String (Item)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put_Line (Wide_Bounded.To_Wide_String (Item)); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String) + is + begin + Put_Line (File, Wide_Bounded.To_Wide_String (Item)); + end Put_Line; + +end Ada.Wide_Text_IO.Wide_Bounded_IO; diff --git a/gcc/ada/libgnat/a-wwboio.ads b/gcc/ada/libgnat/a-wwboio.ads new file mode 100644 index 0000000..2b8dd2a --- /dev/null +++ b/gcc/ada/libgnat/a-wwboio.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . W I D E _ B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Bounded; + +generic + with package Wide_Bounded is + new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (<>); + +package Ada.Wide_Text_IO.Wide_Bounded_IO is + + function Get_Line return Wide_Bounded.Bounded_Wide_String; + + function Get_Line + (File : File_Type) return Wide_Bounded.Bounded_Wide_String; + + procedure Get_Line + (Item : out Wide_Bounded.Bounded_Wide_String); + + procedure Get_Line + (File : File_Type; + Item : out Wide_Bounded.Bounded_Wide_String); + + procedure Put + (Item : Wide_Bounded.Bounded_Wide_String); + + procedure Put + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String); + + procedure Put_Line + (Item : Wide_Bounded.Bounded_Wide_String); + + procedure Put_Line + (File : File_Type; + Item : Wide_Bounded.Bounded_Wide_String); + +end Ada.Wide_Text_IO.Wide_Bounded_IO; diff --git a/gcc/ada/libgnat/a-wwunio.ads b/gcc/ada/libgnat/a-wwunio.ads new file mode 100644 index 0000000..de044c5 --- /dev/null +++ b/gcc/ada/libgnat/a-wwunio.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ T E X T _ I O . W I D E _ U N B O U N D E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Wide_Unbounded. So we implement this new Ada 2005 +-- package by renaming the subprograms in that child. This is a more +-- straightforward implementation anyway, since we need access to the +-- internal representation of Unbounded_Wide_String. + +with Ada.Strings.Wide_Unbounded; +with Ada.Strings.Wide_Unbounded.Wide_Text_IO; + +package Ada.Wide_Text_IO.Wide_Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; + + procedure Put + (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put; + + procedure Put_Line + (File : Wide_Text_IO.File_Type; + Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Put_Line; + + function Get_Line + (File : File_Type) return Strings.Wide_Unbounded.Unbounded_Wide_String + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + function Get_Line return Strings.Wide_Unbounded.Unbounded_Wide_String + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Wide_Unbounded.Unbounded_Wide_String) + renames Ada.Strings.Wide_Unbounded.Wide_Text_IO.Get_Line; + +end Ada.Wide_Text_IO.Wide_Unbounded_IO; diff --git a/gcc/ada/libgnat/a-zchara.ads b/gcc/ada/libgnat/a-zchara.ads new file mode 100644 index 0000000..d8d5f9f --- /dev/null +++ b/gcc/ada/libgnat/a-zchara.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ C H A R A C T E R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Wide_Characters is + pragma Pure; +end Ada.Wide_Wide_Characters; diff --git a/gcc/ada/libgnat/a-zchhan.adb b/gcc/ada/libgnat/a-zchhan.adb new file mode 100644 index 0000000..fb9f8c8 --- /dev/null +++ b/gcc/ada/libgnat/a-zchhan.adb @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ C H A R A C T E R S . H A N D L I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Characters.Unicode; use Ada.Wide_Wide_Characters.Unicode; + +package body Ada.Wide_Wide_Characters.Handling is + + --------------------- + -- Is_Alphanumeric -- + --------------------- + + function Is_Alphanumeric (Item : Wide_Wide_Character) return Boolean is + begin + return Is_Letter (Item) or else Is_Digit (Item); + end Is_Alphanumeric; + + ---------------- + -- Is_Control -- + ---------------- + + function Is_Control (Item : Wide_Wide_Character) return Boolean is + begin + return Get_Category (Item) = Cc; + end Is_Control; + + -------------- + -- Is_Digit -- + -------------- + + function Is_Digit (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Digit; + + ---------------- + -- Is_Graphic -- + ---------------- + + function Is_Graphic (Item : Wide_Wide_Character) return Boolean is + begin + return not Is_Non_Graphic (Item); + end Is_Graphic; + + -------------------------- + -- Is_Hexadecimal_Digit -- + -------------------------- + + function Is_Hexadecimal_Digit (Item : Wide_Wide_Character) return Boolean is + begin + return Is_Digit (Item) + or else Item in 'A' .. 'F' + or else Item in 'a' .. 'f'; + end Is_Hexadecimal_Digit; + + --------------- + -- Is_Letter -- + --------------- + + function Is_Letter (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Letter; + + ------------------------ + -- Is_Line_Terminator -- + ------------------------ + + function Is_Line_Terminator (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Line_Terminator; + + -------------- + -- Is_Lower -- + -------------- + + function Is_Lower (Item : Wide_Wide_Character) return Boolean is + begin + return Get_Category (Item) = Ll; + end Is_Lower; + + ------------- + -- Is_Mark -- + ------------- + + function Is_Mark (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Mark; + + --------------------- + -- Is_Other_Format -- + --------------------- + + function Is_Other_Format (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Other; + + ------------------------------ + -- Is_Punctuation_Connector -- + ------------------------------ + + function Is_Punctuation_Connector + (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Punctuation; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (Item : Wide_Wide_Character) return Boolean + renames Ada.Wide_Wide_Characters.Unicode.Is_Space; + + ---------------- + -- Is_Special -- + ---------------- + + function Is_Special (Item : Wide_Wide_Character) return Boolean is + begin + return Is_Graphic (Item) and then not Is_Alphanumeric (Item); + end Is_Special; + + -------------- + -- Is_Upper -- + -------------- + + function Is_Upper (Item : Wide_Wide_Character) return Boolean is + begin + return Get_Category (Item) = Lu; + end Is_Upper; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character + renames Ada.Wide_Wide_Characters.Unicode.To_Lower_Case; + + function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Lower (Item (J)); + end loop; + + return Result; + end To_Lower; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character + renames Ada.Wide_Wide_Characters.Unicode.To_Upper_Case; + + function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String is + Result : Wide_Wide_String (Item'Range); + + begin + for J in Result'Range loop + Result (J) := To_Upper (Item (J)); + end loop; + + return Result; + end To_Upper; + +end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/libgnat/a-zchhan.ads b/gcc/ada/libgnat/a-zchhan.ads new file mode 100644 index 0000000..354452b --- /dev/null +++ b/gcc/ada/libgnat/a-zchhan.ads @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ C H A R A C T E R S . H A N D L I N G -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Wide_Characters.Handling is + pragma Pure; + -- This package is clearly intended to be Pure, by analogy with the + -- base Ada.Characters.Handling package. The version in the RM does + -- not yet have this pragma, but that is a clear omission. This will + -- be fixed in a future version of AI05-0266-1. + + function Is_Control (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Control); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as other_control, otherwise returns false. + + function Is_Letter (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Letter); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_uppercase, letter_lowercase, letter_titlecase, + -- letter_modifier, letter_other, or number_letter. Otherwise returns + -- false. + + function Is_Lower (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Lower); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_lowercase, otherwise returns false. + + function Is_Upper (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Upper); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_uppercase, otherwise returns false. + + function Is_Digit (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Digit); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as number_decimal, otherwise returns false. + + function Is_Decimal_Digit (Item : Wide_Wide_Character) return Boolean + renames Is_Digit; + + function Is_Hexadecimal_Digit (Item : Wide_Wide_Character) return Boolean; + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as number_decimal, or is in the range 'A' .. 'F' or + -- 'a' .. 'f', otherwise returns false. + + function Is_Alphanumeric (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Alphanumeric); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as letter_uppercase, letter_lowercase, letter_titlecase, + -- letter_modifier, letter_other, number_letter, or number_decimal. + -- Otherwise returns false. + + function Is_Special (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Special); + -- Returns True if the Wide_Wide_Character designated by Item + -- is categorized as graphic_character, but not categorized as + -- letter_uppercase, letter_lowercase, letter_titlecase, letter_modifier, + -- letter_other, number_letter, or number_decimal. Otherwise returns false. + + function Is_Line_Terminator (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Line_Terminator); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as separator_line or separator_paragraph, or if Item is a + -- conventional line terminator character (CR, LF, VT, or FF). Otherwise + -- returns false. + + function Is_Mark (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Mark); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as mark_non_spacing or mark_spacing_combining, otherwise + -- returns false. + + function Is_Other_Format (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Other_Format); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as other_format, otherwise returns false. + + function Is_Punctuation_Connector + (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Punctuation_Connector); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as punctuation_connector, otherwise returns false. + + function Is_Space (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Space); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as separator_space, otherwise returns false. + + function Is_Graphic (Item : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Graphic); + -- Returns True if the Wide_Wide_Character designated by Item is + -- categorized as graphic_character, otherwise returns false. + + function To_Lower (Item : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Lower); + -- Returns the Simple Lowercase Mapping of the Wide_Wide_Character + -- designated by Item. If the Simple Lowercase Mapping does not exist for + -- the Wide_Wide_Character designated by Item, then the value of Item is + -- returned. + + function To_Lower (Item : Wide_Wide_String) return Wide_Wide_String; + -- Returns the result of applying the To_Lower Wide_Wide_Character to + -- Wide_Wide_Character conversion to each element of the Wide_Wide_String + -- designated by Item. The result is the null Wide_Wide_String if the value + -- of the formal parameter is the null Wide_Wide_String. + + function To_Upper (Item : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Upper); + -- Returns the Simple Uppercase Mapping of the Wide_Wide_Character + -- designated by Item. If the Simple Uppercase Mapping does not exist for + -- the Wide_Wide_Character designated by Item, then the value of Item is + -- returned. + + function To_Upper (Item : Wide_Wide_String) return Wide_Wide_String; + -- Returns the result of applying the To_Upper Wide_Wide_Character to + -- Wide_Wide_Character conversion to each element of the Wide_Wide_String + -- designated by Item. The result is the null Wide_Wide_String if the value + -- of the formal parameter is the null Wide_Wide_String. + +end Ada.Wide_Wide_Characters.Handling; diff --git a/gcc/ada/libgnat/a-zchuni.adb b/gcc/ada/libgnat/a-zchuni.adb new file mode 100644 index 0000000..4d8456c --- /dev/null +++ b/gcc/ada/libgnat/a-zchuni.adb @@ -0,0 +1,178 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ C H A R A C T E R T S . U N I C O D E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Ada.Wide_Wide_Characters.Unicode is + + package G renames System.UTF_32; + + ------------------ + -- Get_Category -- + ------------------ + + function Get_Category (U : Wide_Wide_Character) return Category is + begin + return Category (G.Get_Category (Wide_Wide_Character'Pos (U))); + end Get_Category; + + -------------- + -- Is_Digit -- + -------------- + + function Is_Digit (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Digit (Wide_Wide_Character'Pos (U)); + end Is_Digit; + + function Is_Digit (C : Category) return Boolean is + begin + return G.Is_UTF_32_Digit (G.Category (C)); + end Is_Digit; + + --------------- + -- Is_Letter -- + --------------- + + function Is_Letter (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Letter (Wide_Wide_Character'Pos (U)); + end Is_Letter; + + function Is_Letter (C : Category) return Boolean is + begin + return G.Is_UTF_32_Letter (G.Category (C)); + end Is_Letter; + + ------------------------ + -- Is_Line_Terminator -- + ------------------------ + + function Is_Line_Terminator (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Line_Terminator (Wide_Wide_Character'Pos (U)); + end Is_Line_Terminator; + + ------------- + -- Is_Mark -- + ------------- + + function Is_Mark (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Mark (Wide_Wide_Character'Pos (U)); + end Is_Mark; + + function Is_Mark (C : Category) return Boolean is + begin + return G.Is_UTF_32_Mark (G.Category (C)); + end Is_Mark; + + -------------------- + -- Is_Non_Graphic -- + -------------------- + + function Is_Non_Graphic (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Non_Graphic (Wide_Wide_Character'Pos (U)); + end Is_Non_Graphic; + + function Is_Non_Graphic (C : Category) return Boolean is + begin + return G.Is_UTF_32_Non_Graphic (G.Category (C)); + end Is_Non_Graphic; + + -------------- + -- Is_Other -- + -------------- + + function Is_Other (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Other (Wide_Wide_Character'Pos (U)); + end Is_Other; + + function Is_Other (C : Category) return Boolean is + begin + return G.Is_UTF_32_Other (G.Category (C)); + end Is_Other; + + -------------------- + -- Is_Punctuation -- + -------------------- + + function Is_Punctuation (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Punctuation (Wide_Wide_Character'Pos (U)); + end Is_Punctuation; + + function Is_Punctuation (C : Category) return Boolean is + begin + return G.Is_UTF_32_Punctuation (G.Category (C)); + end Is_Punctuation; + + -------------- + -- Is_Space -- + -------------- + + function Is_Space (U : Wide_Wide_Character) return Boolean is + begin + return G.Is_UTF_32_Space (Wide_Wide_Character'Pos (U)); + end Is_Space; + + function Is_Space (C : Category) return Boolean is + begin + return G.Is_UTF_32_Space (G.Category (C)); + end Is_Space; + + ------------------- + -- To_Lower_Case -- + ------------------- + + function To_Lower_Case + (U : Wide_Wide_Character) return Wide_Wide_Character + is + begin + return + Wide_Wide_Character'Val + (G.UTF_32_To_Lower_Case (Wide_Wide_Character'Pos (U))); + end To_Lower_Case; + + ------------------- + -- To_Upper_Case -- + ------------------- + + function To_Upper_Case + (U : Wide_Wide_Character) return Wide_Wide_Character + is + begin + return + Wide_Wide_Character'Val + (G.UTF_32_To_Upper_Case (Wide_Wide_Character'Pos (U))); + end To_Upper_Case; + +end Ada.Wide_Wide_Characters.Unicode; diff --git a/gcc/ada/libgnat/a-zchuni.ads b/gcc/ada/libgnat/a-zchuni.ads new file mode 100644 index 0000000..f05e628 --- /dev/null +++ b/gcc/ada/libgnat/a-zchuni.ads @@ -0,0 +1,196 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ C H A R A C T E R T S . U N I C O D E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Unicode categorization routines for Wide_Wide_Character + +with System.UTF_32; + +package Ada.Wide_Wide_Characters.Unicode is + pragma Pure; + + -- The following type defines the categories from the unicode definitions. + -- The one addition we make is Fe, which represents the characters FFFE + -- and FFFF in any of the planes. + + type Category is new System.UTF_32.Category; + -- Cc Other, Control + -- Cf Other, Format + -- Cn Other, Not Assigned + -- Co Other, Private Use + -- Cs Other, Surrogate + -- Ll Letter, Lowercase + -- Lm Letter, Modifier + -- Lo Letter, Other + -- Lt Letter, Titlecase + -- Lu Letter, Uppercase + -- Mc Mark, Spacing Combining + -- Me Mark, Enclosing + -- Mn Mark, Nonspacing + -- Nd Number, Decimal Digit + -- Nl Number, Letter + -- No Number, Other + -- Pc Punctuation, Connector + -- Pd Punctuation, Dash + -- Pe Punctuation, Close + -- Pf Punctuation, Final quote + -- Pi Punctuation, Initial quote + -- Po Punctuation, Other + -- Ps Punctuation, Open + -- Sc Symbol, Currency + -- Sk Symbol, Modifier + -- Sm Symbol, Math + -- So Symbol, Other + -- Zl Separator, Line + -- Zp Separator, Paragraph + -- Zs Separator, Space + -- Fe relative position FFFE/FFFF in plane + + function Get_Category (U : Wide_Wide_Character) return Category; + pragma Inline (Get_Category); + -- Given a Wide_Wide_Character, returns corresponding Category, or Cn if + -- the code does not have an assigned unicode category. + + -- The following functions perform category tests corresponding to lexical + -- classes defined in the Ada standard. There are two interfaces for each + -- function. The second takes a Category (e.g. returned by Get_Category). + -- The first takes a Wide_Wide_Character. The form taking the + -- Wide_Wide_Character is typically more efficient than calling + -- Get_Category, but if several different tests are to be performed on the + -- same code, it is more efficient to use Get_Category to get the category, + -- then test the resulting category. + + function Is_Letter (U : Wide_Wide_Character) return Boolean; + function Is_Letter (C : Category) return Boolean; + pragma Inline (Is_Letter); + -- Returns true iff U is a letter that can be used to start an identifier, + -- or if C is one of the corresponding categories, which are the following: + -- Letter, Uppercase (Lu) + -- Letter, Lowercase (Ll) + -- Letter, Titlecase (Lt) + -- Letter, Modifier (Lm) + -- Letter, Other (Lo) + -- Number, Letter (Nl) + + function Is_Digit (U : Wide_Wide_Character) return Boolean; + function Is_Digit (C : Category) return Boolean; + pragma Inline (Is_Digit); + -- Returns true iff U is a digit that can be used to extend an identifer, + -- or if C is one of the corresponding categories, which are the following: + -- Number, Decimal_Digit (Nd) + + function Is_Line_Terminator (U : Wide_Wide_Character) return Boolean; + pragma Inline (Is_Line_Terminator); + -- Returns true iff U is an allowed line terminator for source programs, + -- if U is in the category Zp (Separator, Paragaph), or Zs (Separator, + -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). + -- There is no category version for this function, since the set of + -- characters does not correspond to a set of Unicode categories. + + function Is_Mark (U : Wide_Wide_Character) return Boolean; + function Is_Mark (C : Category) return Boolean; + pragma Inline (Is_Mark); + -- Returns true iff U is a mark character which can be used to extend an + -- identifier, or if C is one of the corresponding categories, which are + -- the following: + -- Mark, Non-Spacing (Mn) + -- Mark, Spacing Combining (Mc) + + function Is_Other (U : Wide_Wide_Character) return Boolean; + function Is_Other (C : Category) return Boolean; + pragma Inline (Is_Other); + -- Returns true iff U is an other format character, which means that it + -- can be used to extend an identifier, but is ignored for the purposes of + -- matching of identiers, or if C is one of the corresponding categories, + -- which are the following: + -- Other, Format (Cf) + + function Is_Punctuation (U : Wide_Wide_Character) return Boolean; + function Is_Punctuation (C : Category) return Boolean; + pragma Inline (Is_Punctuation); + -- Returns true iff U is a punctuation character that can be used to + -- separate pices of an identifier, or if C is one of the corresponding + -- categories, which are the following: + -- Punctuation, Connector (Pc) + + function Is_Space (U : Wide_Wide_Character) return Boolean; + function Is_Space (C : Category) return Boolean; + pragma Inline (Is_Space); + -- Returns true iff U is considered a space to be ignored, or if C is one + -- of the corresponding categories, which are the following: + -- Separator, Space (Zs) + + function Is_Non_Graphic (U : Wide_Wide_Character) return Boolean; + function Is_Non_Graphic (C : Category) return Boolean; + pragma Inline (Is_Non_Graphic); + -- Returns true iff U is considered to be a non-graphic character, or if C + -- is one of the corresponding categories, which are the following: + -- Other, Control (Cc) + -- Other, Private Use (Co) + -- Other, Surrogate (Cs) + -- Separator, Line (Zl) + -- Separator, Paragraph (Zp) + -- FFFE or FFFF positions in any plane (Fe) + -- + -- Note that the Ada category format effector is subsumed by the above + -- list of Unicode categories. + -- + -- Note that Other, Unassiged (Cn) is quite deliberately not included + -- in the list of categories above. This means that should any of these + -- code positions be defined in future with graphic characters they will + -- be allowed without a need to change implementations or the standard. + -- + -- Note that Other, Format (Cf) is also quite deliberately not included + -- in the list of categories above. This means that these characters can + -- be included in character and string literals. + + -- The following function is used to fold to upper case, as required by + -- the Ada 2005 standard rules for identifier case folding. Two + -- identifiers are equivalent if they are identical after folding all + -- letters to upper case using this routine. A fold to lower routine is + -- also provided. + + function To_Lower_Case + (U : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Lower_Case); + -- If U represents an upper case letter, returns the corresponding lower + -- case letter, otherwise U is returned unchanged. The folding is locale + -- independent as defined by documents referenced in the note in section + -- 1 of ISO/IEC 10646:2003 + + function To_Upper_Case + (U : Wide_Wide_Character) return Wide_Wide_Character; + pragma Inline (To_Upper_Case); + -- If U represents a lower case letter, returns the corresponding upper + -- case letter, otherwise U is returned unchanged. The folding is locale + -- independent as defined by documents referenced in the note in section + -- 1 of ISO/IEC 10646:2003 + +end Ada.Wide_Wide_Characters.Unicode; diff --git a/gcc/ada/libgnat/a-zrstfi.adb b/gcc/ada/libgnat/a-zrstfi.adb new file mode 100644 index 0000000..66636d8 --- /dev/null +++ b/gcc/ada/libgnat/a-zrstfi.adb @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------------ +-- Ada.Wide_Wide_Text_IO.Reset_Standard_Files -- +------------------------------------------------ + +procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files is +begin + Ada.Wide_Wide_Text_IO.Initialize_Standard_Files; +end Ada.Wide_Wide_Text_IO.Reset_Standard_Files; diff --git a/gcc/ada/libgnat/a-zrstfi.ads b/gcc/ada/libgnat/a-zrstfi.ads new file mode 100644 index 0000000..aa79a0e --- /dev/null +++ b/gcc/ada/libgnat/a-zrstfi.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.RESET_STANDARD_FILES -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 reset routine that resets the standard files used +-- by Ada.Wide_Wide_Text_IO. This is useful in systems such as VxWorks where +-- Ada.Wide_Wide_Text_IO is elaborated at the program start, but a system +-- restart may alter the status of these files, resulting in incorrect +-- operation of Wide_Wide_Text_IO (in particular if the standard input file +-- is changed to be interactive, then Get_Line may hang looking for an extra +-- character after the end of the line. + +procedure Ada.Wide_Wide_Text_IO.Reset_Standard_Files; +-- Reset standard Wide_Wide_Text_IO files as described above diff --git a/gcc/ada/libgnat/a-ztcoau.adb b/gcc/ada/libgnat/a-ztcoau.adb new file mode 100644 index 0000000..c1870e4 --- /dev/null +++ b/gcc/ada/libgnat/a-ztcoau.adb @@ -0,0 +1,202 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Wide_Wide_Text_IO.Float_Aux; + +with System.Img_Real; use System.Img_Real; + +package body Ada.Wide_Wide_Text_IO.Complex_Aux is + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer; + Paren : Boolean := False; + + begin + -- General note for following code, exceptions from the calls + -- to Get for components of the complex value are propagated. + + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + Gets (Buf (1 .. Stop), ItemR, ItemI, Ptr); + + for J in Ptr + 1 .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + + -- Case of width = 0 + + else + Load_Skip (File); + Ptr := 0; + Load (File, Buf, Ptr, '(', Paren); + Aux.Get (File, ItemR, 0); + Load_Skip (File); + Load (File, Buf, Ptr, ','); + Aux.Get (File, ItemI, 0); + + if Paren then + Load_Skip (File); + Load (File, Buf, Ptr, ')', Paren); + + if not Paren then + raise Data_Error; + end if; + end if; + end if; + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive) + is + Paren : Boolean; + Pos : Integer; + + begin + String_Skip (From, Pos); + + if From (Pos) = '(' then + Pos := Pos + 1; + Paren := True; + else + Paren := False; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemR, Pos); + + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) = ',' then + Pos := Pos + 1; + end if; + + Aux.Gets (From (Pos .. From'Last), ItemI, Pos); + + if Paren then + String_Skip (From (Pos + 1 .. From'Last), Pos); + + if From (Pos) /= ')' then + raise Data_Error; + end if; + end if; + + Last := Pos; + end Gets; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + begin + Put (File, '('); + Aux.Put (File, ItemR, Fore, Aft, Exp); + Put (File, ','); + Aux.Put (File, ItemI, Fore, Aft, Exp); + Put (File, ')'); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field) + is + I_String : String (1 .. 3 * Field'Last); + R_String : String (1 .. 3 * Field'Last); + + Iptr : Natural; + Rptr : Natural; + + begin + -- Both parts are initially converted with a Fore of 0 + + Rptr := 0; + Set_Image_Real (ItemR, R_String, Rptr, 0, Aft, Exp); + Iptr := 0; + Set_Image_Real (ItemI, I_String, Iptr, 0, Aft, Exp); + + -- Check room for both parts plus parens plus comma (RM G.1.3(34)) + + if Rptr + Iptr + 3 > To'Length then + raise Layout_Error; + end if; + + -- If there is room, layout result according to (RM G.1.3(31-33)) + + To (To'First) := '('; + To (To'First + 1 .. To'First + Rptr) := R_String (1 .. Rptr); + To (To'First + Rptr + 1) := ','; + + To (To'Last) := ')'; + + To (To'Last - Iptr .. To'Last - 1) := I_String (1 .. Iptr); + + for J in To'First + Rptr + 2 .. To'Last - Iptr - 1 loop + To (J) := ' '; + end loop; + end Puts; + +end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/libgnat/a-ztcoau.ads b/gcc/ada/libgnat/a-ztcoau.ads new file mode 100644 index 0000000..b68c38b --- /dev/null +++ b/gcc/ada/libgnat/a-ztcoau.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C O M P L E X _ A U X -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Complex_IO +-- that are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Complex_IO itself, +-- except that the generic parameter Complex has been replaced by separate +-- real and imaginary values of type Long_Long_Float, and default parameters +-- have been removed because they are supplied explicitly by the calls from +-- within the generic template. + +package Ada.Wide_Wide_Text_IO.Complex_Aux is + + procedure Get + (File : File_Type; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Width : Field); + + procedure Gets + (From : String; + ItemR : out Long_Long_Float; + ItemI : out Long_Long_Float; + Last : out Positive); + + procedure Put + (File : File_Type; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Puts + (To : out String; + ItemR : Long_Long_Float; + ItemI : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Wide_Wide_Text_IO.Complex_Aux; diff --git a/gcc/ada/libgnat/a-ztcoio.adb b/gcc/ada/libgnat/a-ztcoio.adb new file mode 100644 index 0000000..4498ae4 --- /dev/null +++ b/gcc/ada/libgnat/a-ztcoio.adb @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Complex_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +with Ada.Unchecked_Conversion; + +package body Ada.Wide_Wide_Text_IO.Complex_IO is + + package Aux renames Ada.Wide_Wide_Text_IO.Complex_Aux; + + subtype LLF is Long_Long_Float; + -- Type used for calls to routines in Aux + + function TFT is new + Ada.Unchecked_Conversion (File_Type, Ada.Wide_Wide_Text_IO.File_Type); + -- This unchecked conversion is to get around a visibility bug in + -- GNAT version 2.04w. It should be possible to simply use the + -- subtype declared above and do normal checked conversions. + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + begin + Aux.Get (TFT (File), LLF (Real_Item), LLF (Imag_Item), Width); + Item := (Real_Item, Imag_Item); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (Item : out Complex; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + --------- + -- Get -- + --------- + + procedure Get + (From : Wide_Wide_String; + Item : out Complex; + Last : out Positive) + is + Real_Item : Real'Base; + Imag_Item : Real'Base; + + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, LLF (Real_Item), LLF (Imag_Item), Last); + Item := (Real_Item, Imag_Item); + + exception + when Data_Error => raise Constraint_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), LLF (Re (Item)), LLF (Im (Item)), Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (To : out Wide_Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, LLF (Re (Item)), LLF (Im (Item)), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/libgnat/a-ztcoio.ads b/gcc/ada/libgnat/a-ztcoio.ads new file mode 100644 index 0000000..866fd87 --- /dev/null +++ b/gcc/ada/libgnat/a-ztcoio.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ IO . C O M P L E X _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; + +generic + with package Complex_Types is new Ada.Numerics.Generic_Complex_Types (<>); + +package Ada.Wide_Wide_Text_IO.Complex_IO is + + use Complex_Types; + + Default_Fore : Field := 2; + Default_Aft : Field := Real'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Complex; + Width : Field := 0); + + procedure Get + (Item : out Complex; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Complex; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Complex; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Complex; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Complex_IO; diff --git a/gcc/ada/libgnat/a-ztcstr.adb b/gcc/ada/libgnat/a-ztcstr.adb new file mode 100644 index 0000000..835cc33 --- /dev/null +++ b/gcc/ada/libgnat/a-ztcstr.adb @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; +with Ada.Unchecked_Conversion; + +package body Ada.Wide_Wide_Text_IO.C_Streams is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + + -------------- + -- C_Stream -- + -------------- + + function C_Stream (F : File_Type) return FILEs is + begin + FIO.Check_File_Open (AP (F)); + return F.Stream; + end C_Stream; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : FILEs; + Form : String := ""; + Name : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True, + C_Stream => C_Stream); + + end Open; + +end Ada.Wide_Wide_Text_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-ztcstr.ads b/gcc/ada/libgnat/a-ztcstr.ads new file mode 100644 index 0000000..7e2fc74 --- /dev/null +++ b/gcc/ada/libgnat/a-ztcstr.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface between Ada.Wide_Wide_Text_IO and the +-- C streams. This allows sharing of a stream between Ada and C or C++, +-- as well as allowing the Ada program to operate directly on the stream. + +with Interfaces.C_Streams; + +package Ada.Wide_Wide_Text_IO.C_Streams is + + package ICS renames Interfaces.C_Streams; + + function C_Stream (F : File_Type) return ICS.FILEs; + -- Obtain stream from existing open file + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + C_Stream : ICS.FILEs; + Form : String := ""; + Name : String := ""); + -- Create new file from existing stream + +end Ada.Wide_Wide_Text_IO.C_Streams; diff --git a/gcc/ada/libgnat/a-ztdeau.adb b/gcc/ada/libgnat/a-ztdeau.adb new file mode 100644 index 0000000..67e18e7 --- /dev/null +++ b/gcc/ada/libgnat/a-ztdeau.adb @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Wide_Wide_Text_IO.Float_Aux; use Ada.Wide_Wide_Text_IO.Float_Aux; + +with System.Img_Dec; use System.Img_Dec; +with System.Img_LLD; use System.Img_LLD; +with System.Val_Dec; use System.Val_Dec; +with System.Val_LLD; use System.Val_LLD; + +package body Ada.Wide_Wide_Text_IO.Decimal_Aux is + + ------------- + -- Get_Dec -- + ------------- + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_Dec; + + ------------- + -- Get_LLD -- + ------------- + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer; + Stop : Integer := 0; + Item : Long_Long_Integer; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + Ptr := 1; + end if; + + Item := Scan_Long_Long_Decimal (Buf, Ptr'Access, Stop, Scale); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + return Item; + end Get_LLD; + + -------------- + -- Gets_Dec -- + -------------- + + function Gets_Dec + (From : String; + Last : not null access Positive; + Scale : Integer) return Integer + is + Pos : aliased Integer; + Item : Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + + end Gets_Dec; + + -------------- + -- Gets_LLD -- + -------------- + + function Gets_LLD + (From : String; + Last : not null access Positive; + Scale : Integer) return Long_Long_Integer + is + Pos : aliased Integer; + Item : Long_Long_Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Decimal (From, Pos'Access, From'Last, Scale); + Last.all := Pos - 1; + return Item; + + exception + when Constraint_Error => + Last.all := Pos - 1; + raise Data_Error; + + end Gets_LLD; + + ------------- + -- Put_Dec -- + ------------- + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_Dec; + + ------------- + -- Put_LLD -- + ------------- + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLD; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + -- Compute Fore, allowing for Aft digits and the decimal dot + + Fore := To'Length - Field'Max (1, Aft) - 1; + + -- Allow for Exp and two more for E+ or E- if exponent present + + if Exp /= 0 then + Fore := Fore - 2 - Exp; + end if; + + -- Make sure we have enough room + + if Fore < 1 then + raise Layout_Error; + end if; + + -- Do the conversion and check length of result + + Set_Image_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_Dec; + + -------------- + -- Puts_Dec -- + -------------- + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer) + is + Buf : String (1 .. Field'Last); + Fore : Integer; + Ptr : Natural := 0; + + begin + Fore := + (if Exp = 0 then To'Length - 1 - Aft else To'Length - 2 - Aft - Exp); + + if Fore < 1 then + raise Layout_Error; + end if; + + Set_Image_Long_Long_Decimal (Item, Buf, Ptr, Scale, Fore, Aft, Exp); + + if Ptr > To'Length then + raise Layout_Error; + else + To := Buf (1 .. Ptr); + end if; + end Puts_LLD; + +end Ada.Wide_Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-ztdeau.ads b/gcc/ada/libgnat/a-ztdeau.ads new file mode 100644 index 0000000..3a21fb7 --- /dev/null +++ b/gcc/ada/libgnat/a-ztdeau.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Decimal_IO +-- that are shared among separate instantiations of this package. The +-- routines in the package are identical semantically to those declared +-- in Wide_Wide_Text_IO, except that default values have been supplied by the +-- generic, and the Num parameter has been replaced by Integer or +-- Long_Long_Integer, with an additional Scale parameter giving the +-- value of Num'Scale. In addition the Get routines return the value +-- rather than store it in an Out parameter. + +private package Ada.Wide_Wide_Text_IO.Decimal_Aux is + + function Get_Dec + (File : File_Type; + Width : Field; + Scale : Integer) return Integer; + + function Get_LLD + (File : File_Type; + Width : Field; + Scale : Integer) return Long_Long_Integer; + + function Gets_Dec + (From : String; + Last : not null access Positive; + Scale : Integer) return Integer; + + function Gets_LLD + (From : String; + Last : not null access Positive; + Scale : Integer) return Long_Long_Integer; + + procedure Put_Dec + (File : File_Type; + Item : Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Put_LLD + (File : File_Type; + Item : Long_Long_Integer; + Fore : Field; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_Dec + (To : out String; + Item : Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + + procedure Puts_LLD + (To : out String; + Item : Long_Long_Integer; + Aft : Field; + Exp : Field; + Scale : Integer); + +end Ada.Wide_Wide_Text_IO.Decimal_Aux; diff --git a/gcc/ada/libgnat/a-ztdeio.adb b/gcc/ada/libgnat/a-ztdeio.adb new file mode 100644 index 0000000..d2d32a5 --- /dev/null +++ b/gcc/ada/libgnat/a-ztdeio.adb @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Decimal_Aux; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Decimal_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Decimal_Aux; + + Scale : constant Integer := Num'Scale; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Integer'Size then + Item := Num'Fixed_Value (Aux.Get_LLD (TFT (File), Width, Scale)); + else + Item := Num'Fixed_Value (Aux.Get_Dec (TFT (File), Width, Scale)); + end if; + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Integer'Size then + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_LLD (S, Last'Unrestricted_Access, Scale)); + else + -- Item := Num'Fixed_Value + -- should write above, but gets assert error ??? + Item := Num + (Aux.Gets_Dec (S, Last'Unrestricted_Access, Scale)); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + if Num'Size > Integer'Size then + Aux.Put_LLD +-- (TFT (File), Long_Long_Integer'Integer_Value (Item), +-- ??? + (TFT (File), Long_Long_Integer (Item), + Fore, Aft, Exp, Scale); + else + Aux.Put_Dec +-- (TFT (File), Integer'Integer_Value (Item), Fore, Aft, Exp, Scale); +-- ??? + (TFT (File), Integer (Item), Fore, Aft, Exp, Scale); + + end if; + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Integer'Size then +-- Aux.Puts_LLD +-- (S, Long_Long_Integer'Integer_Value (Item), Aft, Exp, Scale); +-- ??? + Aux.Puts_LLD + (S, Long_Long_Integer (Item), Aft, Exp, Scale); + else +-- Aux.Puts_Dec (S, Integer'Integer_Value (Item), Aft, Exp, Scale); +-- ??? + Aux.Puts_Dec (S, Integer (Item), Aft, Exp, Scale); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-ztdeio.ads b/gcc/ada/libgnat/a-ztdeio.ads new file mode 100644 index 0000000..efe24da --- /dev/null +++ b/gcc/ada/libgnat/a-ztdeio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . D E C I M A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Decimal_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Decimal_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <> digits <>; + +package Ada.Wide_Wide_Text_IO.Decimal_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Decimal_IO; diff --git a/gcc/ada/libgnat/a-ztedit.adb b/gcc/ada/libgnat/a-ztedit.adb new file mode 100644 index 0000000..896aeee --- /dev/null +++ b/gcc/ada/libgnat/a-ztedit.adb @@ -0,0 +1,2712 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Strings.Wide_Wide_Fixed; + +package body Ada.Wide_Wide_Text_IO.Editing is + + package Strings renames Ada.Strings; + package Strings_Fixed renames Ada.Strings.Fixed; + package Strings_Wide_Wide_Fixed renames Ada.Strings.Wide_Wide_Fixed; + package Wide_Wide_Text_IO renames Ada.Wide_Wide_Text_IO; + + ----------------------- + -- Local_Subprograms -- + ----------------------- + + function To_Wide (C : Character) return Wide_Wide_Character; + pragma Inline (To_Wide); + -- Convert Character to corresponding Wide_Wide_Character + + --------------------- + -- Blank_When_Zero -- + --------------------- + + function Blank_When_Zero (Pic : Picture) return Boolean is + begin + return Pic.Contents.Original_BWZ; + end Blank_When_Zero; + + -------------------- + -- Decimal_Output -- + -------------------- + + package body Decimal_Output is + + ----------- + -- Image -- + ----------- + + function Image + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + return Wide_Wide_String + is + begin + return Format_Number + (Pic.Contents, Num'Image (Item), + Currency, Fill, Separator, Radix_Mark); + end Image; + + ------------ + -- Length -- + ------------ + + function Length + (Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Natural + is + Picstr : constant String := Pic_String (Pic); + V_Adjust : Integer := 0; + Cur_Adjust : Integer := 0; + + begin + -- Check if Picstr has 'V' or '$' + + -- If 'V', then length is 1 less than otherwise + + -- If '$', then length is Currency'Length-1 more than otherwise + + -- This should use the string handling package ??? + + for J in Picstr'Range loop + if Picstr (J) = 'V' then + V_Adjust := -1; + + elsif Picstr (J) = '$' then + Cur_Adjust := Currency'Length - 1; + end if; + end loop; + + return Picstr'Length - V_Adjust + Cur_Adjust; + end Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : Wide_Wide_Text_IO.File_Type; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + is + begin + Wide_Wide_Text_IO.Put (File, Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + is + begin + Wide_Wide_Text_IO.Put (Image (Item, Pic, + Currency, Fill, Separator, Radix_Mark)); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + is + Result : constant Wide_Wide_String := + Image (Item, Pic, Currency, Fill, Separator, Radix_Mark); + + begin + if Result'Length > To'Length then + raise Wide_Wide_Text_IO.Layout_Error; + else + Strings_Wide_Wide_Fixed.Move (Source => Result, Target => To, + Justify => Strings.Right); + end if; + end Put; + + ----------- + -- Valid -- + ----------- + + function Valid + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Boolean + is + begin + declare + Temp : constant Wide_Wide_String := Image (Item, Pic, Currency); + pragma Warnings (Off, Temp); + begin + return True; + end; + + exception + when Layout_Error => return False; + + end Valid; + end Decimal_Output; + + ------------ + -- Expand -- + ------------ + + function Expand (Picture : String) return String is + Result : String (1 .. MAX_PICSIZE); + Picture_Index : Integer := Picture'First; + Result_Index : Integer := Result'First; + Count : Natural; + Last : Integer; + + begin + if Picture'Length < 1 then + raise Picture_Error; + end if; + + if Picture (Picture'First) = '(' then + raise Picture_Error; + end if; + + loop + case Picture (Picture_Index) is + when '(' => + + -- We now need to scan out the count after a left paren. In + -- the non-wide version we used Integer_IO.Get, but that is + -- not convenient here, since we don't want to drag in normal + -- Text_IO just for this purpose. So we do the scan ourselves, + -- with the normal validity checks. + + Last := Picture_Index + 1; + Count := 0; + + if Picture (Last) not in '0' .. '9' then + raise Picture_Error; + end if; + + Count := Character'Pos (Picture (Last)) - Character'Pos ('0'); + Last := Last + 1; + + loop + if Last > Picture'Last then + raise Picture_Error; + end if; + + if Picture (Last) = '_' then + if Picture (Last - 1) = '_' then + raise Picture_Error; + end if; + + elsif Picture (Last) = ')' then + exit; + + elsif Picture (Last) not in '0' .. '9' then + raise Picture_Error; + + else + Count := Count * 10 + + Character'Pos (Picture (Last)) - + Character'Pos ('0'); + end if; + + Last := Last + 1; + end loop; + + -- In what follows note that one copy of the repeated + -- character has already been made, so a count of one is + -- no-op, and a count of zero erases a character. + + for J in 2 .. Count loop + Result (Result_Index + J - 2) := Picture (Picture_Index - 1); + end loop; + + Result_Index := Result_Index + Count - 1; + + -- Last was a ')' throw it away too + + Picture_Index := Last + 1; + + when ')' => + raise Picture_Error; + + when others => + Result (Result_Index) := Picture (Picture_Index); + Picture_Index := Picture_Index + 1; + Result_Index := Result_Index + 1; + end case; + + exit when Picture_Index > Picture'Last; + end loop; + + return Result (1 .. Result_Index - 1); + + exception + when others => + raise Picture_Error; + end Expand; + + ------------------- + -- Format_Number -- + ------------------- + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : Wide_Wide_String; + Fill_Character : Wide_Wide_Character; + Separator_Character : Wide_Wide_Character; + Radix_Point : Wide_Wide_Character) return Wide_Wide_String + is + Attrs : Number_Attributes := Parse_Number_String (Number); + Position : Integer; + Rounded : String := Number; + + Sign_Position : Integer := Pic.Sign_Position; -- may float. + + Answer : Wide_Wide_String (1 .. Pic.Picture.Length); + Last : Integer; + Currency_Pos : Integer := Pic.Start_Currency; + + Dollar : Boolean := False; + -- Overridden immediately if necessary + + Zero : Boolean := True; + -- Set to False when a non-zero digit is output + + begin + + -- If the picture has fewer decimal places than the number, the image + -- must be rounded according to the usual rules. + + if Attrs.Has_Fraction then + declare + R : constant Integer := + (Attrs.End_Of_Fraction - Attrs.Start_Of_Fraction + 1) + - Pic.Max_Trailing_Digits; + R_Pos : Integer; + + begin + if R > 0 then + R_Pos := Rounded'Length - R; + + if Rounded (R_Pos + 1) > '4' then + + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + + while R_Pos > 1 loop + if Rounded (R_Pos) = '.' then + R_Pos := R_Pos - 1; + end if; + + if Rounded (R_Pos) /= '9' then + Rounded (R_Pos) := Character'Succ (Rounded (R_Pos)); + exit; + else + Rounded (R_Pos) := '0'; + R_Pos := R_Pos - 1; + end if; + end loop; + + -- The rounding may add a digit in front. Either the + -- leading blank or the sign (already captured) can be + -- overwritten. + + if R_Pos = 1 then + Rounded (R_Pos) := '1'; + Attrs.Start_Of_Int := Attrs.Start_Of_Int - 1; + end if; + end if; + end if; + end if; + end; + end if; + + for J in Answer'Range loop + Answer (J) := To_Wide (Pic.Picture.Expanded (J)); + end loop; + + if Pic.Start_Currency /= Invalid_Position then + Dollar := Answer (Pic.Start_Currency) = '$'; + end if; + + -- Fix up "direct inserts" outside the playing field. Set up as one + -- loop to do the beginning, one (reverse) loop to do the end. + + Last := 1; + loop + exit when Last = Pic.Start_Float; + exit when Last = Pic.Radix_Position; + exit when Answer (Last) = '9'; + + case Answer (Last) is + when '_' => + Answer (Last) := Separator_Character; + + when 'b' => + Answer (Last) := ' '; + + when others => + null; + end case; + + exit when Last = Answer'Last; + + Last := Last + 1; + end loop; + + -- Now for the end... + + for J in reverse Last .. Answer'Last loop + exit when J = Pic.Radix_Position; + + -- Do this test First, Separator_Character can equal Pic.Floater + + if Answer (J) = Pic.Floater then + exit; + end if; + + case Answer (J) is + when '_' => + Answer (J) := Separator_Character; + + when 'b' => + Answer (J) := ' '; + + when '9' => + exit; + + when others => + null; + end case; + end loop; + + -- Non-floating sign + + if Pic.Start_Currency /= -1 + and then Answer (Pic.Start_Currency) = '#' + and then Pic.Floater /= '#' + then + if Currency_Symbol'Length > + Pic.End_Currency - Pic.Start_Currency + 1 + then + raise Picture_Error; + + elsif Currency_Symbol'Length = + Pic.End_Currency - Pic.Start_Currency + 1 + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + Currency_Symbol; + + elsif Pic.Radix_Position = Invalid_Position + or else Pic.Start_Currency < Pic.Radix_Position + then + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.End_Currency - Currency_Symbol'Length + 1 .. + Pic.End_Currency) := Currency_Symbol; + + else + Answer (Pic.Start_Currency .. Pic.End_Currency) := + (others => ' '); + Answer (Pic.Start_Currency .. + Pic.Start_Currency + Currency_Symbol'Length - 1) := + Currency_Symbol; + end if; + end if; + + -- Fill in leading digits + + if Attrs.End_Of_Int - Attrs.Start_Of_Int + 1 > + Pic.Max_Leading_Digits + then + raise Layout_Error; + end if; + + Position := + (if Pic.Radix_Position = Invalid_Position then Answer'Last + else Pic.Radix_Position - 1); + + for J in reverse Attrs.Start_Of_Int .. Attrs.End_Of_Int loop + while Answer (Position) /= '9' + and then + Answer (Position) /= Pic.Floater + loop + if Answer (Position) = '_' then + Answer (Position) := Separator_Character; + elsif Answer (Position) = 'b' then + Answer (Position) := ' '; + end if; + + Position := Position - 1; + end loop; + + Answer (Position) := To_Wide (Rounded (J)); + + if Rounded (J) /= '0' then + Zero := False; + end if; + + Position := Position - 1; + end loop; + + -- Do lead float + + if Pic.Start_Float = Invalid_Position then + + -- No leading floats, but need to change '9' to '0', '_' to + -- Separator_Character and 'b' to ' '. + + for J in Last .. Position loop + + -- Last set when fixing the "uninteresting" leaders above. + -- Don't duplicate the work. + + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + + end loop; + + elsif Pic.Floater = '<' + or else + Pic.Floater = '+' + or else + Pic.Floater = '-' + then + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Sign_Position := Position; + + elsif Pic.Floater = '$' then + + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := ' '; -- no separator before leftmost digit + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position - 1 loop + Answer (J) := ' '; + end loop; + + Answer (Position) := Pic.Floater; + Currency_Pos := Position; + + elsif Pic.Floater = '*' then + + for J in Pic.End_Float .. Position loop -- May be null range + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := '*'; + end if; + end loop; + + if Position > Pic.End_Float then + Position := Pic.End_Float; + end if; + + for J in Pic.Start_Float .. Position loop + Answer (J) := '*'; + end loop; + + else + if Pic.Floater = '#' then + Currency_Pos := Currency_Symbol'Length; + end if; + + for J in reverse Pic.Start_Float .. Position loop + case Answer (J) is + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'b' | '/' | '0' => + Answer (J) := ' '; + + when '9' => + Answer (J) := '0'; + + when '.' | 'V' | 'v' | '<' | '$' | '+' | '-' => + null; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when '_' => + case Pic.Floater is + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'b' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos = 0 then + Answer (J) := ' '; + + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos - 1; + end if; + + when others => + null; + end case; + + when others => + null; + end case; + end loop; + + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Layout_Error; + end if; + end if; + + -- Do sign + + if Sign_Position = Invalid_Position then + if Attrs.Negative then + raise Layout_Error; + end if; + + else + if Attrs.Negative then + case Answer (Sign_Position) is + when 'C' | 'D' | '-' => + null; + + when '+' => + Answer (Sign_Position) := '-'; + + when '<' => + Answer (Sign_Position) := '('; + Answer (Pic.Second_Sign) := ')'; + + when others => + raise Picture_Error; + end case; + + else -- positive + + case Answer (Sign_Position) is + when '-' => + Answer (Sign_Position) := ' '; + + when '<' | 'C' | 'D' => + Answer (Sign_Position) := ' '; + Answer (Pic.Second_Sign) := ' '; + + when '+' => + null; + + when others => + raise Picture_Error; + end case; + end if; + end if; + + -- Fill in trailing digits + + if Pic.Max_Trailing_Digits > 0 then + if Attrs.Has_Fraction then + Position := Attrs.Start_Of_Fraction; + Last := Pic.Radix_Position + 1; + + for J in Last .. Answer'Last loop + if Answer (J) = '9' or else Answer (J) = Pic.Floater then + Answer (J) := To_Wide (Rounded (Position)); + + if Rounded (Position) /= '0' then + Zero := False; + end if; + + Position := Position + 1; + Last := J + 1; + + -- Used up fraction but remember place in Answer + + exit when Position > Attrs.End_Of_Fraction; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + end if; + + Last := J + 1; + end loop; + + Position := Last; + + else + Position := Pic.Radix_Position + 1; + end if; + + -- Now fill remaining 9's with zeros and _ with separators + + Last := Answer'Last; + + for J in Position .. Last loop + if Answer (J) = '9' then + Answer (J) := '0'; + + elsif Answer (J) = Pic.Floater then + Answer (J) := '0'; + + elsif Answer (J) = '_' then + Answer (J) := Separator_Character; + + elsif Answer (J) = 'b' then + Answer (J) := ' '; + end if; + end loop; + + Position := Last + 1; + + else + if Pic.Floater = '#' and then Currency_Pos /= 0 then + raise Layout_Error; + end if; + + -- No trailing digits, but now J may need to stick in a currency + -- symbol or sign. + + Position := + (if Pic.Start_Currency = Invalid_Position then Answer'Last + 1 + else Pic.Start_Currency); + end if; + + for J in Position .. Answer'Last loop + if Pic.Start_Currency /= Invalid_Position + and then Answer (Pic.Start_Currency) = '#' + then + Currency_Pos := 1; + end if; + + -- Note: There are some weird cases J can imagine with 'b' or '#' + -- in currency strings where the following code will cause + -- glitches. The trick is to tell when the character in the + -- answer should be checked, and when to look at the original + -- string. Some other time. RIE 11/26/96 ??? + + case Answer (J) is + when '*' => + Answer (J) := Fill_Character; + + when 'b' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + end if; + + when '_' => + case Pic.Floater is + when '*' => + Answer (J) := Fill_Character; + + when 'Z' | 'z' => + Answer (J) := ' '; + + when '#' => + if Currency_Pos > Currency_Symbol'Length then + Answer (J) := ' '; + else + Answer (J) := Currency_Symbol (Currency_Pos); + Currency_Pos := Currency_Pos + 1; + end if; + + when others => + null; + end case; + + when others => + exit; + end case; + end loop; + + -- Now get rid of Blank_when_Zero and complete Star fill + + if Zero and then Pic.Blank_When_Zero then + + -- Value is zero, and blank it + + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position + and then Answer (Pic.Radix_Position) = 'V' + then + Last := Last - 1; + end if; + + return Wide_Wide_String'(1 .. Last => ' '); + + elsif Zero and then Pic.Star_Fill then + Last := Answer'Last; + + if Dollar then + Last := Last - 1 + Currency_Symbol'Length; + end if; + + if Pic.Radix_Position /= Invalid_Position then + + if Answer (Pic.Radix_Position) = 'V' then + Last := Last - 1; + + elsif Dollar then + if Pic.Radix_Position > Pic.Start_Currency then + return + Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); + + else + return + Wide_Wide_String' + (1 .. + Pic.Radix_Position + Currency_Symbol'Length - 2 + => '*') & + Radix_Point & + Wide_Wide_String' + (Pic.Radix_Position + Currency_Symbol'Length .. Last + => '*'); + end if; + + else + return + Wide_Wide_String'(1 .. Pic.Radix_Position - 1 => '*') & + Radix_Point & + Wide_Wide_String'(Pic.Radix_Position + 1 .. Last => '*'); + end if; + end if; + + return Wide_Wide_String'(1 .. Last => '*'); + end if; + + -- This was once a simple return statement, now there are nine different + -- return cases. Not to mention the five above to deal with zeros. Why + -- not split things out? + + -- Processing the radix and sign expansion separately would require + -- lots of copying--the string and some of its indexes--without + -- really simplifying the logic. The cases are: + + -- 1) Expand $, replace '.' with Radix_Point + -- 2) No currency expansion, replace '.' with Radix_Point + -- 3) Expand $, radix blanked + -- 4) No currency expansion, radix blanked + -- 5) Elide V + -- 6) Expand $, Elide V + -- 7) Elide V, Expand $ (Two cases depending on order.) + -- 8) No radix, expand $ + -- 9) No radix, no currency expansion + + if Pic.Radix_Position /= Invalid_Position then + if Answer (Pic.Radix_Position) = '.' then + Answer (Pic.Radix_Position) := Radix_Point; + + if Dollar then + + -- 1) Expand $, replace '.' with Radix_Point + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 2) No currency expansion, replace '.' with Radix_Point + + return Answer; + end if; + + elsif Answer (Pic.Radix_Position) = ' ' then -- blanked radix. + if Dollar then + + -- 3) Expand $, radix blanked + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 4) No expansion, radix blanked + + return Answer; + end if; + + -- V cases + + else + if not Dollar then + + -- 5) Elide V + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + elsif Currency_Pos < Pic.Radix_Position then + + -- 6) Expand $, Elide V + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Answer'Last); + + else + -- 7) Elide V, Expand $ + + return Answer (1 .. Pic.Radix_Position - 1) & + Answer (Pic.Radix_Position + 1 .. Currency_Pos - 1) & + Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + end if; + end if; + + elsif Dollar then + + -- 8) No radix, expand $ + + return Answer (1 .. Currency_Pos - 1) & Currency_Symbol & + Answer (Currency_Pos + 1 .. Answer'Last); + + else + -- 9) No radix, no currency expansion + + return Answer; + end if; + end Format_Number; + + ------------------------- + -- Parse_Number_String -- + ------------------------- + + function Parse_Number_String (Str : String) return Number_Attributes is + Answer : Number_Attributes; + + begin + for J in Str'Range loop + case Str (J) is + when ' ' => + null; -- ignore + + when '1' .. '9' => + + -- Decide if this is the start of a number. + -- If so, figure out which one... + + if Answer.Has_Fraction then + Answer.End_Of_Fraction := J; + else + if Answer.Start_Of_Int = Invalid_Position then + -- start integer + Answer.Start_Of_Int := J; + end if; + Answer.End_Of_Int := J; + end if; + + when '0' => + + -- Only count a zero before the decimal point if it follows a + -- non-zero digit. After the decimal point, zeros will be + -- counted if followed by a non-zero digit. + + if not Answer.Has_Fraction then + if Answer.Start_Of_Int /= Invalid_Position then + Answer.End_Of_Int := J; + end if; + end if; + + when '-' => + + -- Set negative + + Answer.Negative := True; + + when '.' => + + -- Close integer, start fraction + + if Answer.Has_Fraction then + raise Picture_Error; + end if; + + -- Two decimal points is a no-no + + Answer.Has_Fraction := True; + Answer.End_Of_Fraction := J; + + -- Could leave this at Invalid_Position, but this seems the + -- right way to indicate a null range... + + Answer.Start_Of_Fraction := J + 1; + Answer.End_Of_Int := J - 1; + + when others => + raise Picture_Error; -- can this happen? probably not + end case; + end loop; + + if Answer.Start_Of_Int = Invalid_Position then + Answer.Start_Of_Int := Answer.End_Of_Int + 1; + end if; + + -- No significant (intger) digits needs a null range + + return Answer; + end Parse_Number_String; + + ---------------- + -- Pic_String -- + ---------------- + + -- The following ensures that we return B and not b being careful not + -- to break things which expect lower case b for blank. See CXF3A02. + + function Pic_String (Pic : Picture) return String is + Temp : String (1 .. Pic.Contents.Picture.Length) := + Pic.Contents.Picture.Expanded; + begin + for J in Temp'Range loop + if Temp (J) = 'b' then + Temp (J) := 'B'; + end if; + end loop; + + return Temp; + end Pic_String; + + ------------------ + -- Precalculate -- + ------------------ + + procedure Precalculate (Pic : in out Format_Record) is + + Computed_BWZ : Boolean := True; + + type Legality is (Okay, Reject); + State : Legality := Reject; + -- Start in reject, which will reject null strings + + Index : Pic_Index := Pic.Picture.Expanded'First; + + function At_End return Boolean; + pragma Inline (At_End); + + procedure Set_State (L : Legality); + pragma Inline (Set_State); + + function Look return Character; + pragma Inline (Look); + + function Is_Insert return Boolean; + pragma Inline (Is_Insert); + + procedure Skip; + pragma Inline (Skip); + + procedure Trailing_Currency; + procedure Trailing_Bracket; + procedure Number_Fraction; + procedure Number_Completion; + procedure Number_Fraction_Or_Bracket; + procedure Number_Fraction_Or_Z_Fill; + procedure Zero_Suppression; + procedure Floating_Bracket; + procedure Number_Fraction_Or_Star_Fill; + procedure Star_Suppression; + procedure Number_Fraction_Or_Dollar; + procedure Leading_Dollar; + procedure Number_Fraction_Or_Pound; + procedure Leading_Pound; + procedure Picture; + procedure Floating_Plus; + procedure Floating_Minus; + procedure Picture_Plus; + procedure Picture_Minus; + procedure Picture_Bracket; + procedure Number; + procedure Optional_RHS_Sign; + procedure Picture_String; + + ------------ + -- At_End -- + ------------ + + function At_End return Boolean is + begin + return Index > Pic.Picture.Length; + end At_End; + + ---------------------- + -- Floating_Bracket -- + ---------------------- + + -- Note that Floating_Bracket is only called with an acceptable + -- prefix. But we don't set Okay, because we must end with a '>'. + + procedure Floating_Bracket is + begin + Pic.Floater := '<'; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + + -- First bracket wasn't counted... + + Skip; -- known '<' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when '9' => + Number_Completion; + + when '$' => + Leading_Dollar; + + when '#' => + Leading_Pound; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Bracket; + return; + + when others => + return; + end case; + end loop; + end Floating_Bracket; + + -------------------- + -- Floating_Minus -- + -------------------- + + procedure Floating_Minus is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '-' then + loop + if At_End then + return; + end if; + + case Look is + when '-' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + end case; + end loop; + end Floating_Minus; + + ------------------- + -- Floating_Plus -- + ------------------- + + procedure Floating_Plus is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '9' => + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; -- Radix + + while Is_Insert loop + Skip; + end loop; + + if At_End then + return; + end if; + + if Look = '+' then + loop + if At_End then + return; + end if; + + case Look is + when '+' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + + else + Number_Completion; + end if; + + return; + + when others => + return; + end case; + end loop; + end Floating_Plus; + + --------------- + -- Is_Insert -- + --------------- + + function Is_Insert return Boolean is + begin + if At_End then + return False; + end if; + + case Pic.Picture.Expanded (Index) is + when '_' | '0' | '/' => + return True; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; -- canonical + return True; + + when others => + return False; + end case; + end Is_Insert; + + -------------------- + -- Leading_Dollar -- + -------------------- + + -- Note that Leading_Dollar can be called in either State. It will set + -- state to Okay only if a 9 or (second) is encountered. + + -- Also notice the tricky bit with State and Zero_Suppression. + -- Zero_Suppression is Picture_Error if a '$' or a '9' has been + -- encountered, exactly the cases where State has been set. + + procedure Leading_Dollar is + begin + -- Treat as a floating dollar, and unwind otherwise + + Pic.Floater := '$'; + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Skip; -- known '$' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + -- A trailing insertion character is not part of the + -- floating currency, so need to look ahead. + + if Look /= '$' then + Pic.End_Float := Pic.End_Float - 1; + end if; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if State = Okay then + raise Picture_Error; + else + -- Will overwrite Floater and Start_Float + + Zero_Suppression; + end if; + + when '*' => + if State = Okay then + raise Picture_Error; + else + -- Will overwrite Floater and Start_Float + + Star_Suppression; + end if; + + when '$' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); Skip; + + when '9' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- A single dollar does not a floating make + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one dollar before the sign is okay, but doesn't + -- float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Dollar; + return; + + when others => + return; + end case; + end loop; + end Leading_Dollar; + + ------------------- + -- Leading_Pound -- + ------------------- + + -- This one is complex. A Leading_Pound can be fixed or floating, but + -- in some cases the decision has to be deferred until we leave this + -- procedure. Also note that Leading_Pound can be called in either + -- State. + + -- It will set state to Okay only if a 9 or (second) # is encountered + + -- One Last note: In ambiguous cases, the currency is treated as + -- floating unless there is only one '#'. + + procedure Leading_Pound is + Inserts : Boolean := False; + -- Set to True if a '_', '0', '/', 'B', or 'b' is encountered + + Must_Float : Boolean := False; + -- Set to true if a '#' occurs after an insert + + begin + -- Treat as a floating currency. If it isn't, this will be + -- overwritten later. + + Pic.Floater := '#'; + + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- currency place. + + Pic.Max_Currency_Digits := 1; -- we've seen one. + + Skip; -- known '#' + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Pic.End_Float := Index; + Inserts := True; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Will overwrite Floater and Start_Float + + Zero_Suppression; + end if; + + when '*' => + if Must_Float then + raise Picture_Error; + else + Pic.Max_Leading_Digits := 0; + + -- Will overwrite Floater and Start_Float + + Star_Suppression; + end if; + + when '#' => + if Inserts then + Must_Float := True; + end if; + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Pic.End_Currency := Index; + Set_State (Okay); + Skip; + + when '9' => + if State /= Okay then + + -- A single '#' doesn't float + + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Number_Completion; + return; + + when 'V' | 'v' | '.' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Only one pound before the sign is okay, but doesn't + -- float. + + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Pound; + return; + + when others => + return; + end case; + end loop; + end Leading_Pound; + + ---------- + -- Look -- + ---------- + + function Look return Character is + begin + if At_End then + raise Picture_Error; + end if; + + return Pic.Picture.Expanded (Index); + end Look; + + ------------ + -- Number -- + ------------ + + procedure Number is + begin + loop + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + + end case; + + if At_End then + return; + end if; + + -- Will return in Okay state if a '9' was seen + + end loop; + end Number; + + ----------------------- + -- Number_Completion -- + ----------------------- + + procedure Number_Completion is + begin + while not At_End loop + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + return; + + when others => + return; + end case; + end loop; + end Number_Completion; + + --------------------- + -- Number_Fraction -- + --------------------- + + procedure Number_Fraction is + begin + -- Note that number fraction can be called in either State. + -- It will set state to Valid only if a 9 is encountered. + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '9' => + Computed_BWZ := False; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Set_State (Okay); Skip; + + when others => + return; + end case; + end loop; + end Number_Fraction; + + -------------------------------- + -- Number_Fraction_Or_Bracket -- + -------------------------------- + + procedure Number_Fraction_Or_Bracket is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Bracket; + + ------------------------------- + -- Number_Fraction_Or_Dollar -- + ------------------------------- + + procedure Number_Fraction_Or_Dollar is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Dollar; + + ------------------------------ + -- Number_Fraction_Or_Pound -- + ------------------------------ + + procedure Number_Fraction_Or_Pound is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '#' => + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Pound; + + ---------------------------------- + -- Number_Fraction_Or_Star_Fill -- + ---------------------------------- + + procedure Number_Fraction_Or_Star_Fill is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.Star_Fill := True; + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Star_Fill; + + ------------------------------- + -- Number_Fraction_Or_Z_Fill -- + ------------------------------- + + procedure Number_Fraction_Or_Z_Fill is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Max_Trailing_Digits := Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Trailing_Digits := + Pic.Max_Trailing_Digits + 1; + Pic.End_Float := Index; + Skip; + + when others => + return; + end case; + end loop; + + when others => + Number_Fraction; + return; + end case; + end loop; + end Number_Fraction_Or_Z_Fill; + + ----------------------- + -- Optional_RHS_Sign -- + ----------------------- + + procedure Optional_RHS_Sign is + begin + if At_End then + return; + end if; + + case Look is + when '+' | '-' => + Pic.Sign_Position := Index; + Skip; + return; + + when 'C' | 'c' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'C'; + Skip; + + if Look = 'R' or else Look = 'r' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'R'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when 'D' | 'd' => + Pic.Sign_Position := Index; + Pic.Picture.Expanded (Index) := 'D'; + Skip; + + if Look = 'B' or else Look = 'b' then + Pic.Second_Sign := Index; + Pic.Picture.Expanded (Index) := 'B'; + Skip; + + else + raise Picture_Error; + end if; + + return; + + when '>' => + if Pic.Picture.Expanded (Pic.Sign_Position) = '<' then + Pic.Second_Sign := Index; + Skip; + + else + raise Picture_Error; + end if; + + when others => + return; + end case; + end Optional_RHS_Sign; + + ------------- + -- Picture -- + ------------- + + -- Note that Picture can be called in either State + + -- It will set state to Valid only if a 9 is encountered or floating + -- currency is called. + + procedure Picture is + begin + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '$' => + Leading_Dollar; + return; + + when '#' => + Leading_Pound; + return; + + when '9' => + Computed_BWZ := False; + Set_State (Okay); + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Skip; + + when 'V' | 'v' | '.' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction; + Trailing_Currency; + return; + + when others => + return; + end case; + end loop; + end Picture; + + --------------------- + -- Picture_Bracket -- + --------------------- + + procedure Picture_Bracket is + begin + Pic.Sign_Position := Index; + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '<'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Bracket + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '<' => + Set_State (Okay); -- "<<>" is enough. + Floating_Bracket; + Trailing_Currency; + Trailing_Bracket; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Trailing_Bracket; + Set_State (Okay); + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + Trailing_Bracket; + return; + + when others => + raise Picture_Error; + end case; + end loop; + end Picture_Bracket; + + ------------------- + -- Picture_Minus -- + ------------------- + + procedure Picture_Minus is + begin + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '-'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Minus + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '-' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "-- " is enough. + Floating_Minus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + + -- Can't have Z and a floating sign + + if State = Okay then + Set_State (Reject); + end if; + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + return; + + when others => + return; + end case; + end loop; + end Picture_Minus; + + ------------------ + -- Picture_Plus -- + ------------------ + + procedure Picture_Plus is + begin + Pic.Sign_Position := Index; + + -- Treat as a floating sign, and unwind otherwise + + Pic.Floater := '+'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + + -- Don't increment Pic.Max_Leading_Digits, we need one "real" + -- sign place. + + Skip; -- Known Plus + + loop + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '+' => + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Skip; + Set_State (Okay); -- "++" is enough + Floating_Plus; + Trailing_Currency; + return; + + when '$' | '#' | '9' | '*' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + Picture; + Set_State (Okay); + return; + + when 'Z' | 'z' => + if State = Okay then + Set_State (Reject); + end if; + + -- Can't have Z and a floating sign + + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + -- '+Z' is acceptable + + Set_State (Okay); + + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + return; + + when '.' | 'V' | 'v' => + if State /= Okay then + Pic.Floater := '!'; + Pic.Start_Float := Invalid_Position; + Pic.End_Float := Invalid_Position; + end if; + + -- Don't assume that state is okay, haven't seen a digit + + Picture; + return; + + when others => + return; + end case; + end loop; + end Picture_Plus; + + -------------------- + -- Picture_String -- + -------------------- + + procedure Picture_String is + begin + while Is_Insert loop + Skip; + end loop; + + case Look is + when '$' | '#' => + Picture; + Optional_RHS_Sign; + + when '+' => + Picture_Plus; + + when '-' => + Picture_Minus; + + when '<' => + Picture_Bracket; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + Zero_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '*' => + Star_Suppression; + Trailing_Currency; + Optional_RHS_Sign; + + when '9' | '.' | 'V' | 'v' => + Number; + Trailing_Currency; + Optional_RHS_Sign; + + when others => + raise Picture_Error; + end case; + + -- Blank when zero either if the PIC does not contain a '9' or if + -- requested by the user and no '*'. + + Pic.Blank_When_Zero := + (Computed_BWZ or else Pic.Blank_When_Zero) + and then not Pic.Star_Fill; + + -- Star fill if '*' and no '9' + + Pic.Star_Fill := Pic.Star_Fill and then Computed_BWZ; + + if not At_End then + Set_State (Reject); + end if; + end Picture_String; + + --------------- + -- Set_State -- + --------------- + + procedure Set_State (L : Legality) is + begin + State := L; + end Set_State; + + ---------- + -- Skip -- + ---------- + + procedure Skip is + begin + Index := Index + 1; + end Skip; + + ---------------------- + -- Star_Suppression -- + ---------------------- + + procedure Star_Suppression is + begin + Pic.Floater := '*'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); + + -- Even a single * is a valid picture + + Pic.Star_Fill := True; + Skip; -- Known * + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when '*' => + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Set_State (Okay); Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Star_Fill; + return; + + when '#' | '$' => + Trailing_Currency; + Set_State (Okay); + return; + + when others => + raise Picture_Error; + end case; + end loop; + end Star_Suppression; + + ---------------------- + -- Trailing_Bracket -- + ---------------------- + + procedure Trailing_Bracket is + begin + if Look = '>' then + Pic.Second_Sign := Index; + Skip; + else + raise Picture_Error; + end if; + end Trailing_Bracket; + + ----------------------- + -- Trailing_Currency -- + ----------------------- + + procedure Trailing_Currency is + begin + if At_End then + return; + end if; + + if Look = '$' then + Pic.Start_Currency := Index; + Pic.End_Currency := Index; + Skip; + + else + while not At_End and then Look = '#' loop + if Pic.Start_Currency = Invalid_Position then + Pic.Start_Currency := Index; + end if; + + Pic.End_Currency := Index; + Skip; + end loop; + end if; + + loop + if At_End then + return; + end if; + + case Look is + when '_' | '0' | '/' => + Skip; + + when 'B' | 'b' => + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when others => + return; + end case; + end loop; + end Trailing_Currency; + + ---------------------- + -- Zero_Suppression -- + ---------------------- + + procedure Zero_Suppression is + begin + Pic.Floater := 'Z'; + Pic.Start_Float := Index; + Pic.End_Float := Index; + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Skip; -- Known Z + + loop + -- Even a single Z is a valid picture + + if At_End then + Set_State (Okay); + return; + end if; + + case Look is + when '_' | '0' | '/' => + Pic.End_Float := Index; + Skip; + + when 'B' | 'b' => + Pic.End_Float := Index; + Pic.Picture.Expanded (Index) := 'b'; + Skip; + + when 'Z' | 'z' => + Pic.Picture.Expanded (Index) := 'Z'; -- consistency + + Pic.Max_Leading_Digits := Pic.Max_Leading_Digits + 1; + Pic.End_Float := Index; + Set_State (Okay); + Skip; + + when '9' => + Set_State (Okay); + Number_Completion; + return; + + when '.' | 'V' | 'v' => + Pic.Radix_Position := Index; + Skip; + Number_Fraction_Or_Z_Fill; + return; + + when '#' | '$' => + Trailing_Currency; + Set_State (Okay); + return; + + when others => + return; + end case; + end loop; + end Zero_Suppression; + + -- Start of processing for Precalculate + + begin + Picture_String; + + if State = Reject then + raise Picture_Error; + end if; + + exception + + when Constraint_Error => + + -- To deal with special cases like null strings + + raise Picture_Error; + + end Precalculate; + + ---------------- + -- To_Picture -- + ---------------- + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture + is + Result : Picture; + + begin + declare + Item : constant String := Expand (Pic_String); + + begin + Result.Contents.Picture := (Item'Length, Item); + Result.Contents.Original_BWZ := Blank_When_Zero; + Result.Contents.Blank_When_Zero := Blank_When_Zero; + Precalculate (Result.Contents); + return Result; + end; + + exception + when others => + raise Picture_Error; + + end To_Picture; + + ------------- + -- To_Wide -- + ------------- + + function To_Wide (C : Character) return Wide_Wide_Character is + begin + return Wide_Wide_Character'Val (Character'Pos (C)); + end To_Wide; + + ----------- + -- Valid -- + ----------- + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean + is + begin + declare + Expanded_Pic : constant String := Expand (Pic_String); + -- Raises Picture_Error if Item not well-formed + + Format_Rec : Format_Record; + + begin + Format_Rec.Picture := (Expanded_Pic'Length, Expanded_Pic); + Format_Rec.Blank_When_Zero := Blank_When_Zero; + Format_Rec.Original_BWZ := Blank_When_Zero; + Precalculate (Format_Rec); + + -- False only if Blank_When_0 is True but the pic string has a '*' + + return not Blank_When_Zero + or else Strings_Fixed.Index (Expanded_Pic, "*") = 0; + end; + + exception + when others => return False; + end Valid; + +end Ada.Wide_Wide_Text_IO.Editing; diff --git a/gcc/ada/libgnat/a-ztedit.ads b/gcc/ada/libgnat/a-ztedit.ads new file mode 100644 index 0000000..be564dc --- /dev/null +++ b/gcc/ada/libgnat/a-ztedit.ads @@ -0,0 +1,198 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E D I T I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Ada.Wide_Wide_Text_IO.Editing is + + type Picture is private; + + function Valid + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Boolean; + + function To_Picture + (Pic_String : String; + Blank_When_Zero : Boolean := False) return Picture; + + function Pic_String (Pic : Picture) return String; + function Blank_When_Zero (Pic : Picture) return Boolean; + + Max_Picture_Length : constant := 64; + + Picture_Error : exception; + + Default_Currency : constant Wide_Wide_String := "$"; + Default_Fill : constant Wide_Wide_Character := ' '; + Default_Separator : constant Wide_Wide_Character := ','; + Default_Radix_Mark : constant Wide_Wide_Character := '.'; + + generic + type Num is delta <> digits <>; + Default_Currency : Wide_Wide_String := + Wide_Wide_Text_IO.Editing.Default_Currency; + Default_Fill : Wide_Wide_Character := + Wide_Wide_Text_IO.Editing.Default_Fill; + Default_Separator : Wide_Wide_Character := + Wide_Wide_Text_IO.Editing.Default_Separator; + Default_Radix_Mark : Wide_Wide_Character := + Wide_Wide_Text_IO.Editing.Default_Radix_Mark; + + package Decimal_Output is + + function Length + (Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Natural; + + function Valid + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency) return Boolean; + + function Image + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark) + return Wide_Wide_String; + + procedure Put + (File : File_Type; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); + + procedure Put + (Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Pic : Picture; + Currency : Wide_Wide_String := Default_Currency; + Fill : Wide_Wide_Character := Default_Fill; + Separator : Wide_Wide_Character := Default_Separator; + Radix_Mark : Wide_Wide_Character := Default_Radix_Mark); + + end Decimal_Output; + +private + MAX_PICSIZE : constant := 50; + MAX_MONEYSIZE : constant := 10; + Invalid_Position : constant := -1; + + subtype Pic_Index is Natural range 0 .. MAX_PICSIZE; + + type Picture_Record (Length : Pic_Index := 0) is record + Expanded : String (1 .. Length); + end record; + + type Format_Record is record + Picture : Picture_Record; + -- Read only + + Blank_When_Zero : Boolean; + -- Read/write + + Original_BWZ : Boolean; + + -- The following components get written + + Star_Fill : Boolean := False; + + Radix_Position : Integer := Invalid_Position; + + Sign_Position, + Second_Sign : Integer := Invalid_Position; + + Start_Float, + End_Float : Integer := Invalid_Position; + + Start_Currency, + End_Currency : Integer := Invalid_Position; + + Max_Leading_Digits : Integer := 0; + + Max_Trailing_Digits : Integer := 0; + + Max_Currency_Digits : Integer := 0; + + Floater : Wide_Wide_Character := '!'; + -- Initialized to illegal value + + end record; + + type Picture is record + Contents : Format_Record; + end record; + + type Number_Attributes is record + Negative : Boolean := False; + + Has_Fraction : Boolean := False; + + Start_Of_Int, + End_Of_Int, + Start_Of_Fraction, + End_Of_Fraction : Integer := Invalid_Position; -- invalid value + end record; + + function Parse_Number_String (Str : String) return Number_Attributes; + -- Assumed format is 'IMAGE or Fixed_IO.Put format (depends on no + -- trailing blanks...) + + procedure Precalculate (Pic : in out Format_Record); + -- Precalculates fields from the user supplied data + + function Format_Number + (Pic : Format_Record; + Number : String; + Currency_Symbol : Wide_Wide_String; + Fill_Character : Wide_Wide_Character; + Separator_Character : Wide_Wide_Character; + Radix_Point : Wide_Wide_Character) return Wide_Wide_String; + -- Formats number according to Pic + + function Expand (Picture : String) return String; + +end Ada.Wide_Wide_Text_IO.Editing; diff --git a/gcc/ada/libgnat/a-ztenau.adb b/gcc/ada/libgnat/a-ztenau.adb new file mode 100644 index 0000000..a4b1600 --- /dev/null +++ b/gcc/ada/libgnat/a-ztenau.adb @@ -0,0 +1,353 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; +with Ada.Characters.Conversions; use Ada.Characters.Conversions; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.WCh_Con; use System.WCh_Con; + +package body Ada.Wide_Wide_Text_IO.Enumeration_Aux is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Store_Char + (WC : Wide_Wide_Character; + Buf : out Wide_Wide_String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow + + -- These definitions replace the ones in Ada.Characters.Handling, which + -- do not seem to work for some strange not understood reason ??? at + -- least in the OS/2 version. + + function To_Lower (C : Character) return Character; + + ------------------ + -- Get_Enum_Lit -- + ------------------ + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out Wide_Wide_String; + Buflen : out Natural) + is + ch : int; + WC : Wide_Wide_Character; + + begin + Buflen := 0; + Load_Skip (TFT (File)); + ch := Nextc (TFT (File)); + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L) + + if ch = Character'Pos (''') then + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + if ch = LM or else ch = EOF then + return; + end if; + + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + if ch /= Character'Pos (''') then + return; + end if; + + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter. Any wide character value + -- outside the normal Latin-1 range counts as a letter for this. + + if ch < 255 and then not Is_Letter (Character'Val (ch)) then + return; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + loop + Get (File, WC); + Store_Char (WC, Buf, Buflen); + + ch := Nextc (TFT (File)); + + exit when ch = EOF; + + if ch = Character'Pos ('_') then + exit when Buf (Buflen) = '_'; + + elsif ch = Character'Pos (ASCII.ESC) then + null; + + elsif File.WC_Method in WC_Upper_Half_Encoding_Method + and then ch > 127 + then + null; + + else + exit when not Is_Letter (Character'Val (ch)) + and then + not Is_Digit (Character'Val (ch)); + end if; + end loop; + end if; + end Get_Enum_Lit; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_String; + Width : Field; + Set : Type_Set) + is + Actual_Width : constant Integer := + Integer'Max (Integer (Width), Item'Length); + + begin + Check_On_One_Line (TFT (File), Actual_Width); + + if Set = Lower_Case and then Item (Item'First) /= ''' then + declare + Iteml : Wide_Wide_String (Item'First .. Item'Last); + + begin + for J in Item'Range loop + if Is_Character (Item (J)) then + Iteml (J) := + To_Wide_Wide_Character + (To_Lower (To_Character (Item (J)))); + else + Iteml (J) := Item (J); + end if; + end loop; + + Put (File, Iteml); + end; + + else + Put (File, Item); + end if; + + for J in 1 .. Actual_Width - Item'Length loop + Put (File, ' '); + end loop; + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out Wide_Wide_String; + Item : Wide_Wide_String; + Set : Type_Set) + is + Ptr : Natural; + + begin + if Item'Length > To'Length then + raise Layout_Error; + + else + Ptr := To'First; + for J in Item'Range loop + if Set = Lower_Case + and then Item (Item'First) /= ''' + and then Is_Character (Item (J)) + then + To (Ptr) := + To_Wide_Wide_Character (To_Lower (To_Character (Item (J)))); + else + To (Ptr) := Item (J); + end if; + + Ptr := Ptr + 1; + end loop; + + while Ptr <= To'Last loop + To (Ptr) := ' '; + Ptr := Ptr + 1; + end loop; + end if; + end Puts; + + ------------------- + -- Scan_Enum_Lit -- + ------------------- + + procedure Scan_Enum_Lit + (From : Wide_Wide_String; + Start : out Natural; + Stop : out Natural) + is + WC : Wide_Wide_Character; + + -- Processing for Scan_Enum_Lit + + begin + Start := From'First; + + loop + if Start > From'Last then + raise End_Error; + + elsif Is_Character (From (Start)) + and then not Is_Blank (To_Character (From (Start))) + then + exit; + + else + Start := Start + 1; + end if; + end loop; + + -- Character literal case. If the initial character is a quote, then + -- we read as far as we can without backup (see ACVC test CE3905L + -- which is for the analogous case for reading from a file). + + if From (Start) = ''' then + Stop := Start; + + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + end if; + + if From (Stop) in ' ' .. '~' + or else From (Stop) >= Wide_Wide_Character'Val (16#80#) + then + if Stop = From'Last then + raise Data_Error; + else + Stop := Stop + 1; + + if From (Stop) = ''' then + return; + end if; + end if; + end if; + + raise Data_Error; + + -- Similarly for identifiers, read as far as we can, in particular, + -- do read a trailing underscore (again see ACVC test CE3905L to + -- understand why we do this, although it seems somewhat peculiar). + + else + -- Identifier must start with a letter, any wide character outside + -- the normal Latin-1 range is considered a letter for this test. + + if Is_Character (From (Start)) + and then not Is_Letter (To_Character (From (Start))) + then + raise Data_Error; + end if; + + -- If we do have a letter, loop through the characters quitting on + -- the first non-identifier character (note that this includes the + -- cases of hitting a line mark or page mark). + + Stop := Start + 1; + while Stop < From'Last loop + WC := From (Stop + 1); + + exit when + Is_Character (WC) + and then + not Is_Letter (To_Character (WC)) + and then + not Is_Letter (To_Character (WC)) + and then + (WC /= '_' or else From (Stop - 1) = '_'); + + Stop := Stop + 1; + end loop; + end if; + + end Scan_Enum_Lit; + + ---------------- + -- Store_Char -- + ---------------- + + procedure Store_Char + (WC : Wide_Wide_Character; + Buf : out Wide_Wide_String; + Ptr : in out Integer) + is + begin + if Ptr = Buf'Last then + raise Data_Error; + else + Ptr := Ptr + 1; + Buf (Ptr) := WC; + end if; + end Store_Char; + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (C : Character) return Character is + begin + if C in 'A' .. 'Z' then + return Character'Val (Character'Pos (C) + 32); + else + return C; + end if; + end To_Lower; + +end Ada.Wide_Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/libgnat/a-ztenau.ads b/gcc/ada/libgnat/a-ztenau.ads new file mode 100644 index 0000000..394ad20 --- /dev/null +++ b/gcc/ada/libgnat/a-ztenau.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.ENUMERATION_AUX -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Enumeration_IO +-- that are shared among separate instantiations. + +private package Ada.Wide_Wide_Text_IO.Enumeration_Aux is + + procedure Get_Enum_Lit + (File : File_Type; + Buf : out Wide_Wide_String; + Buflen : out Natural); + -- Reads an enumeration literal value from the file, folds to upper case, + -- and stores the result in Buf, setting Buflen to the number of stored + -- characters (Buf has a lower bound of 1). If more than Buflen characters + -- are present in the literal, Data_Error is raised. + + procedure Scan_Enum_Lit + (From : Wide_Wide_String; + Start : out Natural; + Stop : out Natural); + -- Scans an enumeration literal at the start of From, skipping any leading + -- spaces. Sets Start to the first character, Stop to the last character. + -- Raises End_Error if no enumeration literal is found. + + procedure Put + (File : File_Type; + Item : Wide_Wide_String; + Width : Field; + Set : Type_Set); + -- Outputs the enumeration literal image stored in Item to the given File, + -- using the given Width and Set parameters (Item is always in upper case). + + procedure Puts + (To : out Wide_Wide_String; + Item : Wide_Wide_String; + Set : Type_Set); + -- Stores the enumeration literal image stored in Item to the string To, + -- padding with trailing spaces if necessary to fill To. Set is used to + +end Ada.Wide_Wide_Text_IO.Enumeration_Aux; diff --git a/gcc/ada/libgnat/a-ztenio.adb b/gcc/ada/libgnat/a-ztenio.adb new file mode 100644 index 0000000..ba26735 --- /dev/null +++ b/gcc/ada/libgnat/a-ztenio.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Enumeration_Aux; + +package body Ada.Wide_Wide_Text_IO.Enumeration_IO is + + package Aux renames Ada.Wide_Wide_Text_IO.Enumeration_Aux; + + --------- + -- Get -- + --------- + + procedure Get (File : File_Type; Item : out Enum) is + Buf : Wide_Wide_String (1 .. Enum'Width); + Buflen : Natural; + begin + Aux.Get_Enum_Lit (File, Buf, Buflen); + Item := Enum'Wide_Wide_Value (Buf (1 .. Buflen)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get (Item : out Enum) is + begin + Get (Current_Input, Item); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Enum; + Last : out Positive) + is + Start : Natural; + begin + Aux.Scan_Enum_Lit (From, Start, Last); + Item := Enum'Wide_Wide_Value (From (Start .. Last)); + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); + begin + Aux.Put (File, Image, Width, Set); + end Put; + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting) + is + begin + Put (Current_Output, Item, Width, Set); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting) + is + Image : constant Wide_Wide_String := Enum'Wide_Wide_Image (Item); + begin + Aux.Puts (To, Image, Set); + end Put; + +end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-ztenio.ads b/gcc/ada/libgnat/a-ztenio.ads new file mode 100644 index 0000000..5a00351 --- /dev/null +++ b/gcc/ada/libgnat/a-ztenio.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . E N U M E R A T I O N _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Enumeration_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Enumeration_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up the +-- difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Enum is (<>); + +package Ada.Wide_Wide_Text_IO.Enumeration_IO is + + Default_Width : Field := 0; + Default_Setting : Type_Set := Upper_Case; + + procedure Get (File : File_Type; Item : out Enum); + procedure Get (Item : out Enum); + + procedure Put + (File : File_Type; + Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Put + (Item : Enum; + Width : Field := Default_Width; + Set : Type_Set := Default_Setting); + + procedure Get + (From : Wide_Wide_String; + Item : out Enum; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Enum; + Set : Type_Set := Default_Setting); + +end Ada.Wide_Wide_Text_IO.Enumeration_IO; diff --git a/gcc/ada/libgnat/a-ztexio.adb b/gcc/ada/libgnat/a-ztexio.adb new file mode 100644 index 0000000..39fd38a --- /dev/null +++ b/gcc/ada/libgnat/a-ztexio.adb @@ -0,0 +1,1939 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.CRTL; +with System.File_IO; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +pragma Elaborate_All (System.File_IO); +-- Needed because of calls to Chain_File in package body elaboration + +package body Ada.Wide_Wide_Text_IO is + + package FIO renames System.File_IO; + + subtype AP is FCB.AFCB_Ptr; + + function To_FCB is new Ada.Unchecked_Conversion (File_Mode, FCB.File_Mode); + function To_TIO is new Ada.Unchecked_Conversion (FCB.File_Mode, File_Mode); + use type FCB.File_Mode; + + use type System.CRTL.size_t; + + WC_Encoding : Character; + pragma Import (C, WC_Encoding, "__gl_wc_encoding"); + -- Default wide character encoding + + Err_Name : aliased String := "*stderr" & ASCII.NUL; + In_Name : aliased String := "*stdin" & ASCII.NUL; + Out_Name : aliased String := "*stdout" & ASCII.NUL; + -- Names of standard files + -- + -- Use "preallocated" strings to avoid calling "new" during the elaboration + -- of the run time. This is needed in the tasking case to avoid calling + -- Task_Lock too early. A filename is expected to end with a null character + -- in the runtime, here the null characters are added just to have a + -- correct filename length. + -- + -- Note: the names for these files are bogus, and probably it would be + -- better for these files to have no names, but the ACVC tests insist. + -- We use names that are bound to fail in open etc. + + Null_Str : aliased constant String := ""; + -- Used as form string for standard files + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Get_Wide_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Wide_Character; + -- This routine is identical to Get_Wide_Wide_Char, except that the reads + -- are done in Get_Immediate mode (i.e. without waiting for a line return). + + function Getc_Immed (File : File_Type) return int; + -- This routine is identical to Getc, except that the read is done in + -- Get_Immediate mode (i.e. without waiting for a line return). + + procedure Putc (ch : int; File : File_Type); + -- Outputs the given character to the file, which has already been checked + -- for being in output status. Device_Error is raised if the character + -- cannot be written. + + procedure Set_WCEM (File : in out File_Type); + -- Called by Open and Create to set the wide character encoding method for + -- the file, processing a WCEM form parameter if one is present. File is + -- IN OUT because it may be closed in case of an error. + + procedure Terminate_Line (File : File_Type); + -- If the file is in Write_File or Append_File mode, and the current line + -- is not terminated, then a line terminator is written using New_Line. + -- Note that there is no Terminate_Page routine, because the page mark at + -- the end of the file is implied if necessary. + + procedure Ungetc (ch : int; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has checked + -- that the file is in read status. Device_Error is raised if the character + -- cannot be pushed back. An attempt to push back and end of file character + -- (EOF) is ignored. + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate + (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr + is + pragma Unreferenced (Control_Block); + begin + return new Wide_Wide_Text_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + procedure AFCB_Close (File : not null access Wide_Wide_Text_AFCB) is + begin + -- If the file being closed is one of the current files, then close + -- the corresponding current file. It is not clear that this action + -- is required (RM A.10.3(23)) but it seems reasonable, and besides + -- ACVC test CE3208A expects this behavior. + + if File_Type (File) = Current_In then + Current_In := null; + elsif File_Type (File) = Current_Out then + Current_Out := null; + elsif File_Type (File) = Current_Err then + Current_Err := null; + end if; + + Terminate_Line (File_Type (File)); + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Wide_Wide_Text_AFCB) is + type FCB_Ptr is access all Wide_Wide_Text_AFCB; + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new + Ada.Unchecked_Deallocation (Wide_Wide_Text_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out File_Type) is + begin + FIO.Close (AP (File)'Unrestricted_Access); + end Close; + + --------- + -- Col -- + --------- + + -- Note: we assume that it is impossible in practice for the column + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Col (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Col; + end Col; + + function Col return Positive_Count is + begin + return Col (Current_Out); + end Col; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => True, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Create; + + ------------------- + -- Current_Error -- + ------------------- + + function Current_Error return File_Type is + begin + return Current_Err; + end Current_Error; + + function Current_Error return File_Access is + begin + return Current_Err.Self'Access; + end Current_Error; + + ------------------- + -- Current_Input -- + ------------------- + + function Current_Input return File_Type is + begin + return Current_In; + end Current_Input; + + function Current_Input return File_Access is + begin + return Current_In.Self'Access; + end Current_Input; + + -------------------- + -- Current_Output -- + -------------------- + + function Current_Output return File_Type is + begin + return Current_Out; + end Current_Output; + + function Current_Output return File_Access is + begin + return Current_Out.Self'Access; + end Current_Output; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File : in out File_Type) is + begin + FIO.Delete (AP (File)'Unrestricted_Access); + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return Nextc (File) = EOF; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch = PM and then File.Is_Regular_File then + File.Before_LM_PM := True; + return Nextc (File) = EOF; + + -- Here if neither EOF nor PM followed end of line + + else + Ungetc (ch, File); + return False; + end if; + + end End_Of_File; + + function End_Of_File return Boolean is + begin + return End_Of_File (Current_In); + end End_Of_File; + + ----------------- + -- End_Of_Line -- + ----------------- + + function End_Of_Line (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + return True; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + else + Ungetc (ch, File); + return (ch = LM); + end if; + end if; + end End_Of_Line; + + function End_Of_Line return Boolean is + begin + return End_Of_Line (Current_In); + end End_Of_Line; + + ----------------- + -- End_Of_Page -- + ----------------- + + function End_Of_Page (File : File_Type) return Boolean is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if not File.Is_Regular_File then + return False; + + elsif File.Before_Wide_Wide_Character then + return False; + + elsif File.Before_LM then + if File.Before_LM_PM then + return True; + end if; + + else + ch := Getc (File); + + if ch = EOF then + return True; + + elsif ch /= LM then + Ungetc (ch, File); + return False; + + else -- ch = LM + File.Before_LM := True; + end if; + end if; + + -- Here we are just past the line mark with Before_LM set so that we + -- do not have to try to back up past the LM, thus avoiding the need + -- to back up more than one character. + + ch := Nextc (File); + + return ch = PM or else ch = EOF; + end End_Of_Page; + + function End_Of_Page return Boolean is + begin + return End_Of_Page (Current_In); + end End_Of_Page; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : File_Type) is + begin + FIO.Flush (AP (File)); + end Flush; + + procedure Flush is + begin + Flush (Current_Out); + end Flush; + + ---------- + -- Form -- + ---------- + + function Form (File : File_Type) return String is + begin + return FIO.Form (AP (File)); + end Form; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Wide_Wide_Character) + is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + -- Ada.Text_IO checks Before_LM_PM here, shouldn't we do the same??? + + else + Get_Character (File, C); + Item := Get_Wide_Wide_Char (C, File); + end if; + end Get; + + procedure Get (Item : out Wide_Wide_Character) is + begin + Get (Current_In, Item); + end Get; + + procedure Get + (File : File_Type; + Item : out Wide_Wide_String) + is + begin + for J in Item'Range loop + Get (File, Item (J)); + end loop; + end Get; + + procedure Get (Item : out Wide_Wide_String) is + begin + Get (Current_In, Item); + end Get; + + ------------------- + -- Get_Character -- + ------------------- + + procedure Get_Character + (File : File_Type; + Item : out Character) + is + ch : int; + + begin + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Col := 1; + + if File.Before_LM_PM then + File.Line := 1; + File.Page := File.Page + 1; + File.Before_LM_PM := False; + + else + File.Line := File.Line + 1; + end if; + end if; + + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + + else + Item := Character'Val (ch); + File.Col := File.Col + 1; + return; + end if; + end loop; + end Get_Character; + + ------------------- + -- Get_Immediate -- + ------------------- + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Wide_Character'Val (LM); + + else + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Wide_Character) + is + begin + Get_Immediate (Current_In, Item); + end Get_Immediate; + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character; + Available : out Boolean) + is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + Available := True; + + if File.Before_Wide_Wide_Character then + File.Before_Wide_Wide_Character := False; + Item := File.Saved_Wide_Wide_Character; + + elsif File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + Item := Wide_Wide_Character'Val (LM); + + else + -- Shouldn't we use getc_immediate_nowait here, like Text_IO??? + + ch := Getc_Immed (File); + + if ch = EOF then + raise End_Error; + else + Item := Get_Wide_Wide_Char_Immed (Character'Val (ch), File); + end if; + end if; + end Get_Immediate; + + procedure Get_Immediate + (Item : out Wide_Wide_Character; + Available : out Boolean) + is + begin + Get_Immediate (Current_In, Item, Available); + end Get_Immediate; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_String; + Last : out Natural) + is + begin + FIO.Check_Read_Status (AP (File)); + Last := Item'First - 1; + + -- Immediate exit for null string, this is a case in which we do not + -- need to test for end of file and we do not skip a line mark under + -- any circumstances. + + if Last >= Item'Last then + return; + end if; + + -- Here we have at least one character, if we are immediately before + -- a line mark, then we will just skip past it storing no characters. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + -- Otherwise we need to read some characters + + else + -- If we are at the end of file now, it means we are trying to + -- skip a file terminator and we raise End_Error (RM A.10.7(20)) + + if Nextc (File) = EOF then + raise End_Error; + end if; + + -- Loop through characters in string + + loop + -- Exit the loop if read is terminated by encountering line mark + -- Note that the use of Skip_Line here ensures we properly deal + -- with setting the page and line numbers. + + if End_Of_Line (File) then + Skip_Line (File); + return; + end if; + + -- Otherwise store the character, note that we know that ch is + -- something other than LM or EOF. It could possibly be a page + -- mark if there is a stray page mark in the middle of a line, + -- but this is not an official page mark in any case, since + -- official page marks can only follow a line mark. The whole + -- page business is pretty much nonsense anyway, so we do not + -- want to waste time trying to make sense out of non-standard + -- page marks in the file. This means that the behavior of + -- Get_Line is different from repeated Get of a character, but + -- that's too bad. We only promise that page numbers etc make + -- sense if the file is formatted in a standard manner. + + -- Note: we do not adjust the column number because it is quicker + -- to adjust it once at the end of the operation than incrementing + -- it each time around the loop. + + Last := Last + 1; + Get (File, Item (Last)); + + -- All done if the string is full, this is the case in which + -- we do not skip the following line mark. We need to adjust + -- the column number in this case. + + if Last = Item'Last then + File.Col := File.Col + Count (Item'Length); + return; + end if; + + -- Exit from the loop if we are at the end of file. This happens + -- if we have a last line that is not terminated with a line mark. + -- In this case we consider that there is an implied line mark; + -- this is a non-standard file, but we will treat it nicely. + + exit when Nextc (File) = EOF; + end loop; + end if; + end Get_Line; + + procedure Get_Line + (Item : out Wide_Wide_String; + Last : out Natural) + is + begin + Get_Line (Current_In, Item, Last); + end Get_Line; + + function Get_Line (File : File_Type) return Wide_Wide_String is + Buffer : Wide_Wide_String (1 .. 500); + Last : Natural; + + function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String; + -- This is a recursive function that reads the rest of the line and + -- returns it. S is the part read so far. + + -------------- + -- Get_Rest -- + -------------- + + function Get_Rest (S : Wide_Wide_String) return Wide_Wide_String is + + -- Each time we allocate a buffer the same size as what we have + -- read so far. This limits us to a logarithmic number of calls + -- to Get_Rest and also ensures only a linear use of stack space. + + Buffer : Wide_Wide_String (1 .. S'Length); + Last : Natural; + + begin + Get_Line (File, Buffer, Last); + + declare + R : constant Wide_Wide_String := S & Buffer (1 .. Last); + begin + if Last < Buffer'Last then + return R; + else + return Get_Rest (R); + end if; + end; + end Get_Rest; + + -- Start of processing for Get_Line + + begin + Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Get_Rest (Buffer (1 .. Last)); + end if; + end Get_Line; + + function Get_Line return Wide_Wide_String is + begin + return Get_Line (Current_In); + end Get_Line; + + ------------------------ + -- Get_Wide_Wide_Char -- + ------------------------ + + function Get_Wide_Wide_Char + (C : Character; + File : File_Type) return Wide_Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_UTF_32 (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Wide_Char + + begin + FIO.Check_Read_Status (AP (File)); + return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); + end Get_Wide_Wide_Char; + + ------------------------------ + -- Get_Wide_Wide_Char_Immed -- + ------------------------------ + + function Get_Wide_Wide_Char_Immed + (C : Character; + File : File_Type) return Wide_Wide_Character + is + function In_Char return Character; + -- Function used to obtain additional characters it the wide character + -- sequence is more than one character long. + + function WC_In is new Char_Sequence_To_UTF_32 (In_Char); + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + ch : constant Integer := Getc_Immed (File); + begin + if ch = EOF then + raise End_Error; + else + return Character'Val (ch); + end if; + end In_Char; + + -- Start of processing for Get_Wide_Wide_Char_Immed + + begin + FIO.Check_Read_Status (AP (File)); + return Wide_Wide_Character'Val (WC_In (C, File.WC_Method)); + end Get_Wide_Wide_Char_Immed; + + ---------- + -- Getc -- + ---------- + + function Getc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF and then ferror (File.Stream) /= 0 then + raise Device_Error; + else + return ch; + end if; + end Getc; + + ---------------- + -- Getc_Immed -- + ---------------- + + function Getc_Immed (File : File_Type) return int is + ch : int; + end_of_file : int; + + procedure getc_immediate + (stream : FILEs; ch : out int; end_of_file : out int); + pragma Import (C, getc_immediate, "getc_immediate"); + + begin + FIO.Check_Read_Status (AP (File)); + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := LM; + + else + getc_immediate (File.Stream, ch, end_of_file); + + if ferror (File.Stream) /= 0 then + raise Device_Error; + elsif end_of_file /= 0 then + return EOF; + end if; + end if; + + return ch; + end Getc_Immed; + + ------------------------------- + -- Initialize_Standard_Files -- + ------------------------------- + + procedure Initialize_Standard_Files is + begin + Standard_Err.Stream := stderr; + Standard_Err.Name := Err_Name'Access; + Standard_Err.Form := Null_Str'Unrestricted_Access; + Standard_Err.Mode := FCB.Out_File; + Standard_Err.Is_Regular_File := is_regular_file (fileno (stderr)) /= 0; + Standard_Err.Is_Temporary_File := False; + Standard_Err.Is_System_File := True; + Standard_Err.Text_Encoding := Default_Text; + Standard_Err.Access_Method := 'T'; + Standard_Err.Self := Standard_Err; + Standard_Err.WC_Method := Default_WCEM; + + Standard_In.Stream := stdin; + Standard_In.Name := In_Name'Access; + Standard_In.Form := Null_Str'Unrestricted_Access; + Standard_In.Mode := FCB.In_File; + Standard_In.Is_Regular_File := is_regular_file (fileno (stdin)) /= 0; + Standard_In.Is_Temporary_File := False; + Standard_In.Is_System_File := True; + Standard_In.Text_Encoding := Default_Text; + Standard_In.Access_Method := 'T'; + Standard_In.Self := Standard_In; + Standard_In.WC_Method := Default_WCEM; + + Standard_Out.Stream := stdout; + Standard_Out.Name := Out_Name'Access; + Standard_Out.Form := Null_Str'Unrestricted_Access; + Standard_Out.Mode := FCB.Out_File; + Standard_Out.Is_Regular_File := is_regular_file (fileno (stdout)) /= 0; + Standard_Out.Is_Temporary_File := False; + Standard_Out.Is_System_File := True; + Standard_Out.Text_Encoding := Default_Text; + Standard_Out.Access_Method := 'T'; + Standard_Out.Self := Standard_Out; + Standard_Out.WC_Method := Default_WCEM; + + FIO.Make_Unbuffered (AP (Standard_Out)); + FIO.Make_Unbuffered (AP (Standard_Err)); + end Initialize_Standard_Files; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : File_Type) return Boolean is + begin + return FIO.Is_Open (AP (File)); + end Is_Open; + + ---------- + -- Line -- + ---------- + + -- Note: we assume that it is impossible in practice for the line + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Line (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Line; + end Line; + + function Line return Positive_Count is + begin + return Line (Current_Out); + end Line; + + ----------------- + -- Line_Length -- + ----------------- + + function Line_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Line_Length; + end Line_Length; + + function Line_Length return Count is + begin + return Line_Length (Current_Out); + end Line_Length; + + ---------------- + -- Look_Ahead -- + ---------------- + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Wide_Character; + End_Of_Line : out Boolean) + is + ch : int; + + -- Start of processing for Look_Ahead + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are logically before a line mark, we can return immediately + + if File.Before_LM then + End_Of_Line := True; + Item := Wide_Wide_Character'Val (0); + + -- If we are before a wide character, just return it (this can happen + -- if there are two calls to Look_Ahead in a row). + + elsif File.Before_Wide_Wide_Character then + End_Of_Line := False; + Item := File.Saved_Wide_Wide_Character; + + -- otherwise we must read a character from the input stream + + else + ch := Getc (File); + + if ch = LM + or else ch = EOF + or else (ch = EOF and then File.Is_Regular_File) + then + End_Of_Line := True; + Ungetc (ch, File); + Item := Wide_Wide_Character'Val (0); + + -- Case where character obtained does not represent the start of an + -- encoded sequence so it stands for itself and we can unget it with + -- no difficulty. + + elsif not Is_Start_Of_Encoding + (Character'Val (ch), File.WC_Method) + then + End_Of_Line := False; + Ungetc (ch, File); + Item := Wide_Wide_Character'Val (ch); + + -- For the start of an encoding, we read the character using the + -- Get_Wide_Wide_Char routine. It will occupy more than one byte so + -- we can't put it back with ungetc. Instead we save it in the + -- control block, setting a flag that everyone interested in reading + -- characters must test before reading the stream. + + else + Item := Get_Wide_Wide_Char (Character'Val (ch), File); + End_Of_Line := False; + File.Saved_Wide_Wide_Character := Item; + File.Before_Wide_Wide_Character := True; + end if; + end if; + end Look_Ahead; + + procedure Look_Ahead + (Item : out Wide_Wide_Character; + End_Of_Line : out Boolean) + is + begin + Look_Ahead (Current_In, Item, End_Of_Line); + end Look_Ahead; + + ---------- + -- Mode -- + ---------- + + function Mode (File : File_Type) return File_Mode is + begin + return To_TIO (FIO.Mode (AP (File))); + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : File_Type) return String is + begin + return FIO.Name (AP (File)); + end Name; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + + for K in 1 .. Spacing loop + Putc (LM, File); + File.Line := File.Line + 1; + + if File.Page_Length /= 0 + and then File.Line > File.Page_Length + then + Putc (PM, File); + File.Line := 1; + File.Page := File.Page + 1; + end if; + end loop; + + File.Col := 1; + end New_Line; + + procedure New_Line (Spacing : Positive_Count := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + -------------- + -- New_Page -- + -------------- + + procedure New_Page (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Col /= 1 or else File.Line = 1 then + Putc (LM, File); + end if; + + Putc (PM, File); + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + end New_Page; + + procedure New_Page is + begin + New_Page (Current_Out); + end New_Page; + + ----------- + -- Nextc -- + ----------- + + function Nextc (File : File_Type) return int is + ch : int; + + begin + ch := fgetc (File.Stream); + + if ch = EOF then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + + else + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + + return ch; + end Nextc; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Wide_Wide_Text_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => To_FCB (Mode), + Name => Name, + Form => Form, + Amethod => 'W', + Creat => False, + Text => True); + + File.Self := File; + Set_WCEM (File); + end Open; + + ---------- + -- Page -- + ---------- + + -- Note: we assume that it is impossible in practice for the page + -- to exceed the value of Count'Last, i.e. no check is required for + -- overflow raising layout error. + + function Page (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Page; + end Page; + + function Page return Positive_Count is + begin + return Page (Current_Out); + end Page; + + ----------------- + -- Page_Length -- + ----------------- + + function Page_Length (File : File_Type) return Count is + begin + FIO.Check_Write_Status (AP (File)); + return File.Page_Length; + end Page_Length; + + function Page_Length return Count is + begin + return Page_Length (Current_Out); + end Page_Length; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_Character) + is + procedure Out_Char (C : Character); + -- Procedure to output one character of a wide character sequence + + procedure WC_Out is new UTF_32_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + Putc (Character'Pos (C), File); + end Out_Char; + + -- Start of processing for Put + + begin + FIO.Check_Write_Status (AP (File)); + WC_Out (Wide_Wide_Character'Pos (Item), File.WC_Method); + File.Col := File.Col + 1; + end Put; + + procedure Put (Item : Wide_Wide_Character) is + begin + Put (Current_Out, Item); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_String) + is + begin + for J in Item'Range loop + Put (File, Item (J)); + end loop; + end Put; + + procedure Put (Item : Wide_Wide_String) is + begin + Put (Current_Out, Item); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_String) + is + begin + Put (File, Item); + New_Line (File); + end Put_Line; + + procedure Put_Line (Item : Wide_Wide_String) is + begin + Put (Current_Out, Item); + New_Line (Current_Out); + end Put_Line; + + ---------- + -- Putc -- + ---------- + + procedure Putc (ch : int; File : File_Type) is + begin + if fputc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end Putc; + + ---------- + -- Read -- + ---------- + + -- This is the primitive Stream Read routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Read + (File : in out Wide_Wide_Text_AFCB; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Discard_ch : int; + pragma Unreferenced (Discard_ch); + + begin + -- Need to deal with Before_Wide_Wide_Character ??? + + if File.Mode /= FCB.In_File then + raise Mode_Error; + end if; + + -- Deal with case where our logical and physical position do not match + -- because of being after an LM or LM-PM sequence when in fact we are + -- logically positioned before it. + + if File.Before_LM then + + -- If we are before a PM, then it is possible for a stream read + -- to leave us after the LM and before the PM, which is a bit + -- odd. The easiest way to deal with this is to unget the PM, + -- so we are indeed positioned between the characters. This way + -- further stream read operations will work correctly, and the + -- effect on text processing is a little weird, but what can + -- be expected if stream and text input are mixed this way? + + if File.Before_LM_PM then + Discard_ch := ungetc (PM, File.Stream); + File.Before_LM_PM := False; + end if; + + File.Before_LM := False; + + Item (Item'First) := Stream_Element (Character'Pos (ASCII.LF)); + + if Item'Length = 1 then + Last := Item'Last; + + else + Last := + Item'First + + Stream_Element_Offset + (fread (buffer => Item'Address, + index => size_t (Item'First + 1), + size => 1, + count => Item'Length - 1, + stream => File.Stream)); + end if; + + return; + end if; + + -- Now we do the read. Since this is a text file, it is normally in + -- text mode, but stream data must be read in binary mode, so we + -- temporarily set binary mode for the read, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + Last := + Item'First + + Stream_Element_Offset + (fread (Item'Address, 1, Item'Length, File.Stream)) - 1; + + if Last < Item'Last then + if ferror (File.Stream) /= 0 then + raise Device_Error; + end if; + end if; + + set_text_mode (fileno (File.Stream)); + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset + (File : in out File_Type; + Mode : File_Mode) + is + begin + -- Don't allow change of mode for current file (RM A.10.2(5)) + + if (File = Current_In or else + File = Current_Out or else + File = Current_Error) + and then To_FCB (Mode) /= File.Mode + then + raise Mode_Error; + end if; + + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access, To_FCB (Mode)); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Terminate_Line (File); + FIO.Reset (AP (File)'Unrestricted_Access); + File.Page := 1; + File.Line := 1; + File.Col := 1; + File.Line_Length := 0; + File.Page_Length := 0; + File.Before_LM := False; + File.Before_LM_PM := False; + end Reset; + + ------------- + -- Set_Col -- + ------------- + + procedure Set_Col + (File : File_Type; + To : Positive_Count) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Col then + return; + end if; + + if Mode (File) >= Out_File then + if File.Line_Length /= 0 and then To > File.Line_Length then + raise Layout_Error; + end if; + + if To < File.Col then + New_Line (File); + end if; + + while File.Col < To loop + Put (File, ' '); + end loop; + + else + loop + ch := Getc (File); + + if ch = EOF then + raise End_Error; + + elsif ch = LM then + File.Line := File.Line + 1; + File.Col := 1; + + elsif ch = PM and then File.Is_Regular_File then + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + + elsif To = File.Col then + Ungetc (ch, File); + return; + + else + File.Col := File.Col + 1; + end if; + end loop; + end if; + end Set_Col; + + procedure Set_Col (To : Positive_Count) is + begin + Set_Col (Current_Out, To); + end Set_Col; + + --------------- + -- Set_Error -- + --------------- + + procedure Set_Error (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Err := File; + end Set_Error; + + --------------- + -- Set_Input -- + --------------- + + procedure Set_Input (File : File_Type) is + begin + FIO.Check_Read_Status (AP (File)); + Current_In := File; + end Set_Input; + + -------------- + -- Set_Line -- + -------------- + + procedure Set_Line + (File : File_Type; + To : Positive_Count) + is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_File_Open (AP (File)); + + if To = File.Line then + return; + end if; + + if Mode (File) >= Out_File then + if File.Page_Length /= 0 and then To > File.Page_Length then + raise Layout_Error; + end if; + + if To < File.Line then + New_Page (File); + end if; + + while File.Line < To loop + New_Line (File); + end loop; + + else + while To /= File.Line loop + Skip_Line (File); + end loop; + end if; + end Set_Line; + + procedure Set_Line (To : Positive_Count) is + begin + Set_Line (Current_Out, To); + end Set_Line; + + --------------------- + -- Set_Line_Length -- + --------------------- + + procedure Set_Line_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Line_Length := To; + end Set_Line_Length; + + procedure Set_Line_Length (To : Count) is + begin + Set_Line_Length (Current_Out, To); + end Set_Line_Length; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + FIO.Check_Write_Status (AP (File)); + Current_Out := File; + end Set_Output; + + --------------------- + -- Set_Page_Length -- + --------------------- + + procedure Set_Page_Length (File : File_Type; To : Count) is + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not To'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Write_Status (AP (File)); + File.Page_Length := To; + end Set_Page_Length; + + procedure Set_Page_Length (To : Count) is + begin + Set_Page_Length (Current_Out, To); + end Set_Page_Length; + + -------------- + -- Set_WCEM -- + -------------- + + procedure Set_WCEM (File : in out File_Type) is + Start : Natural; + Stop : Natural; + + begin + FIO.Form_Parameter (File.Form.all, "wcem", Start, Stop); + + if Start = 0 then + File.WC_Method := Default_WCEM; + + else + if Stop = Start then + for J in WC_Encoding_Letters'Range loop + if File.Form (Start) = WC_Encoding_Letters (J) then + File.WC_Method := J; + return; + end if; + end loop; + end if; + + Close (File); + raise Use_Error with "invalid WCEM form parameter"; + end if; + end Set_WCEM; + + --------------- + -- Skip_Line -- + --------------- + + procedure Skip_Line + (File : File_Type; + Spacing : Positive_Count := 1) + is + ch : int; + + begin + -- Raise Constraint_Error if out of range value. The reason for this + -- explicit test is that we don't want junk values around, even if + -- checks are off in the caller. + + if not Spacing'Valid then + raise Constraint_Error; + end if; + + FIO.Check_Read_Status (AP (File)); + + for L in 1 .. Spacing loop + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + + else + ch := Getc (File); + + -- If at end of file now, then immediately raise End_Error. Note + -- that we can never be positioned between a line mark and a page + -- mark, so if we are at the end of file, we cannot logically be + -- before the implicit page mark that is at the end of the file. + + -- For the same reason, we do not need an explicit check for a + -- page mark. If there is a FF in the middle of a line, the file + -- is not in canonical format and we do not care about the page + -- numbers for files other than ones in canonical format. + + if ch = EOF then + raise End_Error; + end if; + + -- If not at end of file, then loop till we get to an LM or EOF. + -- The latter case happens only in non-canonical files where the + -- last line is not terminated by LM, but we don't want to blow + -- up for such files, so we assume an implicit LM in this case. + + loop + exit when ch = LM or else ch = EOF; + ch := Getc (File); + end loop; + end if; + + -- We have got past a line mark, now, for a regular file only, + -- see if a page mark immediately follows this line mark and + -- if so, skip past the page mark as well. We do not do this + -- for non-regular files, since it would cause an undesirable + -- wait for an additional character. + + File.Col := 1; + File.Line := File.Line + 1; + + if File.Before_LM_PM then + File.Page := File.Page + 1; + File.Line := 1; + File.Before_LM_PM := False; + + elsif File.Is_Regular_File then + ch := Getc (File); + + -- Page mark can be explicit, or implied at the end of the file + + if (ch = PM or else ch = EOF) + and then File.Is_Regular_File + then + File.Page := File.Page + 1; + File.Line := 1; + else + Ungetc (ch, File); + end if; + end if; + end loop; + + File.Before_Wide_Wide_Character := False; + end Skip_Line; + + procedure Skip_Line (Spacing : Positive_Count := 1) is + begin + Skip_Line (Current_In, Spacing); + end Skip_Line; + + --------------- + -- Skip_Page -- + --------------- + + procedure Skip_Page (File : File_Type) is + ch : int; + + begin + FIO.Check_Read_Status (AP (File)); + + -- If at page mark already, just skip it + + if File.Before_LM_PM then + File.Before_LM := False; + File.Before_LM_PM := False; + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + return; + end if; + + -- This is a bit tricky, if we are logically before an LM then + -- it is not an error if we are at an end of file now, since we + -- are not really at it. + + if File.Before_LM then + File.Before_LM := False; + File.Before_LM_PM := False; + ch := Getc (File); + + -- Otherwise we do raise End_Error if we are at the end of file now + + else + ch := Getc (File); + + if ch = EOF then + raise End_Error; + end if; + end if; + + -- Now we can just rumble along to the next page mark, or to the + -- end of file, if that comes first. The latter case happens when + -- the page mark is implied at the end of file. + + loop + exit when ch = EOF + or else (ch = PM and then File.Is_Regular_File); + ch := Getc (File); + end loop; + + File.Page := File.Page + 1; + File.Line := 1; + File.Col := 1; + File.Before_Wide_Wide_Character := False; + end Skip_Page; + + procedure Skip_Page is + begin + Skip_Page (Current_In); + end Skip_Page; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Standard_Err; + end Standard_Error; + + function Standard_Error return File_Access is + begin + return Standard_Err'Access; + end Standard_Error; + + -------------------- + -- Standard_Input -- + -------------------- + + function Standard_Input return File_Type is + begin + return Standard_In; + end Standard_Input; + + function Standard_Input return File_Access is + begin + return Standard_In'Access; + end Standard_Input; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Standard_Out; + end Standard_Output; + + function Standard_Output return File_Access is + begin + return Standard_Out'Access; + end Standard_Output; + + -------------------- + -- Terminate_Line -- + -------------------- + + procedure Terminate_Line (File : File_Type) is + begin + FIO.Check_File_Open (AP (File)); + + -- For file other than In_File, test for needing to terminate last line + + if Mode (File) /= In_File then + + -- If not at start of line definition need new line + + if File.Col /= 1 then + New_Line (File); + + -- For files other than standard error and standard output, we + -- make sure that an empty file has a single line feed, so that + -- it is properly formatted. We avoid this for the standard files + -- because it is too much of a nuisance to have these odd line + -- feeds when nothing has been written to the file. + + elsif (File /= Standard_Err and then File /= Standard_Out) + and then (File.Line = 1 and then File.Page = 1) + then + New_Line (File); + end if; + end if; + end Terminate_Line; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + + ----------- + -- Write -- + ----------- + + -- This is the primitive Stream Write routine, used when a Text_IO file + -- is treated directly as a stream using Text_IO.Streams.Stream. + + procedure Write + (File : in out Wide_Wide_Text_AFCB; + Item : Stream_Element_Array) + is + pragma Warnings (Off, File); + -- Because in this implementation we don't need IN OUT, we only read + + Siz : constant size_t := Item'Length; + + begin + if File.Mode = FCB.In_File then + raise Mode_Error; + end if; + + -- Now we do the write. Since this is a text file, it is normally in + -- text mode, but stream data must be written in binary mode, so we + -- temporarily set binary mode for the write, resetting it after. + -- These calls have no effect in a system (like Unix) where there is + -- no distinction between text and binary files. + + set_binary_mode (fileno (File.Stream)); + + if fwrite (Item'Address, 1, Siz, File.Stream) /= Siz then + raise Device_Error; + end if; + + set_text_mode (fileno (File.Stream)); + end Write; + +begin + -- Initialize Standard Files + + for J in WC_Encoding_Method loop + if WC_Encoding = WC_Encoding_Letters (J) then + Default_WCEM := J; + end if; + end loop; + + Initialize_Standard_Files; + + FIO.Chain_File (AP (Standard_In)); + FIO.Chain_File (AP (Standard_Out)); + FIO.Chain_File (AP (Standard_Err)); + +end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-ztexio.ads b/gcc/ada/libgnat/a-ztexio.ads new file mode 100644 index 0000000..730fc02 --- /dev/null +++ b/gcc/ada/libgnat/a-ztexio.ads @@ -0,0 +1,497 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the generic subpackages of Wide_Wide_Text_IO (Integer_IO, Float_IO, +-- Fixed_IO, Modular_IO, Decimal_IO and Enumeration_IO) appear as private +-- children in GNAT. These children are with'ed automatically if they are +-- referenced, so this rearrangement is invisible to user programs, but has +-- the advantage that only the needed parts of Wide_Wide_Text_IO are processed +-- and loaded. + +with Ada.IO_Exceptions; +with Ada.Streams; + +with Interfaces.C_Streams; + +with System; +with System.File_Control_Block; +with System.WCh_Con; + +package Ada.Wide_Wide_Text_IO is + + type File_Type is limited private; + type File_Mode is (In_File, Out_File, Append_File); + + -- The following representation clause allows the use of unchecked + -- conversion for rapid translation between the File_Mode type + -- used in this package and System.File_IO. + + for File_Mode use + (In_File => 0, -- System.FIle_IO.File_Mode'Pos (In_File) + Out_File => 2, -- System.File_IO.File_Mode'Pos (Out_File) + Append_File => 3); -- System.File_IO.File_Mode'Pos (Append_File) + + type Count is range 0 .. Natural'Last; + -- The value of Count'Last must be large enough so that the assumption that + -- the Line, Column and Page counts can never exceed this value is valid. + + subtype Positive_Count is Count range 1 .. Count'Last; + + Unbounded : constant Count := 0; + -- Line and page length + + subtype Field is Integer range 0 .. 255; + -- Note: if for any reason, there is a need to increase this value, then it + -- will be necessary to change the corresponding value in System.Img_Real + -- in file s-imgrea.adb. + + subtype Number_Base is Integer range 2 .. 16; + + type Type_Set is (Lower_Case, Upper_Case); + + --------------------- + -- File Management -- + --------------------- + + procedure Create + (File : in out File_Type; + Mode : File_Mode := Out_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : File_Mode; + Name : String; + Form : String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + procedure Reset (File : in out File_Type; Mode : File_Mode); + procedure Reset (File : in out File_Type); + + function Mode (File : File_Type) return File_Mode; + function Name (File : File_Type) return String; + function Form (File : File_Type) return String; + + function Is_Open (File : File_Type) return Boolean; + + ------------------------------------------------------ + -- Control of default input, output and error files -- + ------------------------------------------------------ + + procedure Set_Input (File : File_Type); + procedure Set_Output (File : File_Type); + procedure Set_Error (File : File_Type); + + function Standard_Input return File_Type; + function Standard_Output return File_Type; + function Standard_Error return File_Type; + + function Current_Input return File_Type; + function Current_Output return File_Type; + function Current_Error return File_Type; + + type File_Access is access constant File_Type; + + function Standard_Input return File_Access; + function Standard_Output return File_Access; + function Standard_Error return File_Access; + + function Current_Input return File_Access; + function Current_Output return File_Access; + function Current_Error return File_Access; + + -------------------- + -- Buffer control -- + -------------------- + + -- Note: The parameter file is in out in the RM, but as pointed out + -- in <<95-5166.a Tucker Taft 95-6-23>> this is clearly an oversight. + + procedure Flush (File : File_Type); + procedure Flush; + + -------------------------------------------- + -- Specification of line and page lengths -- + -------------------------------------------- + + procedure Set_Line_Length (File : File_Type; To : Count); + procedure Set_Line_Length (To : Count); + + procedure Set_Page_Length (File : File_Type; To : Count); + procedure Set_Page_Length (To : Count); + + function Line_Length (File : File_Type) return Count; + function Line_Length return Count; + + function Page_Length (File : File_Type) return Count; + function Page_Length return Count; + + ------------------------------------ + -- Column, Line, and Page Control -- + ------------------------------------ + + procedure New_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure New_Line (Spacing : Positive_Count := 1); + + procedure Skip_Line (File : File_Type; Spacing : Positive_Count := 1); + procedure Skip_Line (Spacing : Positive_Count := 1); + + function End_Of_Line (File : File_Type) return Boolean; + function End_Of_Line return Boolean; + + procedure New_Page (File : File_Type); + procedure New_Page; + + procedure Skip_Page (File : File_Type); + procedure Skip_Page; + + function End_Of_Page (File : File_Type) return Boolean; + function End_Of_Page return Boolean; + + function End_Of_File (File : File_Type) return Boolean; + function End_Of_File return Boolean; + + procedure Set_Col (File : File_Type; To : Positive_Count); + procedure Set_Col (To : Positive_Count); + + procedure Set_Line (File : File_Type; To : Positive_Count); + procedure Set_Line (To : Positive_Count); + + function Col (File : File_Type) return Positive_Count; + function Col return Positive_Count; + + function Line (File : File_Type) return Positive_Count; + function Line return Positive_Count; + + function Page (File : File_Type) return Positive_Count; + function Page return Positive_Count; + + ---------------------------- + -- Character Input-Output -- + ---------------------------- + + procedure Get (File : File_Type; Item : out Wide_Wide_Character); + procedure Get (Item : out Wide_Wide_Character); + procedure Put (File : File_Type; Item : Wide_Wide_Character); + procedure Put (Item : Wide_Wide_Character); + + procedure Look_Ahead + (File : File_Type; + Item : out Wide_Wide_Character; + End_Of_Line : out Boolean); + + procedure Look_Ahead + (Item : out Wide_Wide_Character; + End_Of_Line : out Boolean); + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character); + + procedure Get_Immediate + (Item : out Wide_Wide_Character); + + procedure Get_Immediate + (File : File_Type; + Item : out Wide_Wide_Character; + Available : out Boolean); + + procedure Get_Immediate + (Item : out Wide_Wide_Character; + Available : out Boolean); + + ------------------------- + -- String Input-Output -- + ------------------------- + + procedure Get (File : File_Type; Item : out Wide_Wide_String); + procedure Get (Item : out Wide_Wide_String); + procedure Put (File : File_Type; Item : Wide_Wide_String); + procedure Put (Item : Wide_Wide_String); + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_String; + Last : out Natural); + + function Get_Line (File : File_Type) return Wide_Wide_String; + pragma Ada_05 (Get_Line); + + function Get_Line return Wide_Wide_String; + pragma Ada_05 (Get_Line); + + procedure Get_Line + (Item : out Wide_Wide_String; + Last : out Natural); + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_String); + + procedure Put_Line + (Item : Wide_Wide_String); + + --------------------------------------- + -- Generic packages for Input-Output -- + --------------------------------------- + + -- The generic packages: + + -- Ada.Wide_Wide_Text_IO.Integer_IO + -- Ada.Wide_Wide_Text_IO.Modular_IO + -- Ada.Wide_Wide_Text_IO.Float_IO + -- Ada.Wide_Wide_Text_IO.Fixed_IO + -- Ada.Wide_Wide_Text_IO.Decimal_IO + -- Ada.Wide_Wide_Text_IO.Enumeration_IO + + -- are implemented as separate child packages in GNAT, so the + -- spec and body of these packages are to be found in separate + -- child units. This implementation detail is hidden from the + -- Ada programmer by special circuitry in the compiler that + -- treats these child packages as though they were nested in + -- Text_IO. The advantage of this special processing is that + -- the subsidiary routines needed if these generics are used + -- are not loaded when they are not used. + + ---------------- + -- Exceptions -- + ---------------- + + Status_Error : exception renames IO_Exceptions.Status_Error; + Mode_Error : exception renames IO_Exceptions.Mode_Error; + Name_Error : exception renames IO_Exceptions.Name_Error; + Use_Error : exception renames IO_Exceptions.Use_Error; + Device_Error : exception renames IO_Exceptions.Device_Error; + End_Error : exception renames IO_Exceptions.End_Error; + Data_Error : exception renames IO_Exceptions.Data_Error; + Layout_Error : exception renames IO_Exceptions.Layout_Error; + +private + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Close, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Delete, + External => "", + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, File_Mode), + Mechanism => (File => Reference)); + + package WCh_Con renames System.WCh_Con; + + ----------------------------------- + -- Handling of Format Characters -- + ----------------------------------- + + -- Line marks are represented by the single character ASCII.LF (16#0A#). + -- In DOS and similar systems, underlying file translation takes care + -- of translating this to and from the standard CR/LF sequences used in + -- these operating systems to mark the end of a line. On output there is + -- always a line mark at the end of the last line, but on input, this + -- line mark can be omitted, and is implied by the end of file. + + -- Page marks are represented by the single character ASCII.FF (16#0C#), + -- The page mark at the end of the file may be omitted, and is normally + -- omitted on output unless an explicit New_Page call is made before + -- closing the file. No page mark is added when a file is appended to, + -- so, in accordance with the permission in (RM A.10.2(4)), there may + -- or may not be a page mark separating preexisting text in the file + -- from the new text to be written. + + -- A file mark is marked by the physical end of file. In DOS translation + -- mode on input, an EOF character (SUB = 16#1A#) gets translated to the + -- physical end of file, so in effect this character is recognized as + -- marking the end of file in DOS and similar systems. + + LM : constant := Character'Pos (ASCII.LF); + -- Used as line mark + + PM : constant := Character'Pos (ASCII.FF); + -- Used as page mark, except at end of file where it is implied + + ------------------------------------------ + -- Wide_Wide_Text_IO File Control Block -- + ------------------------------------------ + + Default_WCEM : WCh_Con.WC_Encoding_Method := WCh_Con.WCEM_UTF8; + -- This gets modified during initialization (see body) using the default + -- value established in the call to Set_Globals. + + package FCB renames System.File_Control_Block; + + type Wide_Wide_Text_AFCB is new FCB.AFCB with record + Page : Count := 1; + Line : Count := 1; + Col : Count := 1; + Line_Length : Count := 0; + Page_Length : Count := 0; + + Self : aliased File_Type; + -- Set to point to the containing Text_AFCB block. This is used to + -- implement the Current_{Error,Input,Output} functions which return + -- a File_Access, the file access value returned is a pointer to + -- the Self field of the corresponding file. + + Before_LM : Boolean := False; + -- This flag is used to deal with the anomalies introduced by the + -- peculiar definition of End_Of_File and End_Of_Page in Ada. These + -- functions require looking ahead more than one character. Since + -- there is no convenient way of backing up more than one character, + -- what we do is to leave ourselves positioned past the LM, but set + -- this flag, so that we know that from an Ada point of view we are + -- in front of the LM, not after it. A bit odd, but it works. + + Before_LM_PM : Boolean := False; + -- This flag similarly handles the case of being physically positioned + -- after a LM-PM sequence when logically we are before the LM-PM. This + -- flag can only be set if Before_LM is also set. + + WC_Method : WCh_Con.WC_Encoding_Method := Default_WCEM; + -- Encoding method to be used for this file + + Before_Wide_Wide_Character : Boolean := False; + -- This flag is set to indicate that a wide character in the input has + -- been read by Wide_Wide_Text_IO.Look_Ahead. If it is set to True, + -- then it means that the stream is logically positioned before the + -- character but is physically positioned after it. The character + -- involved must not be in the range 16#00#-16#7F#, i.e. if the flag is + -- set, then we know the next character has a code greater than 16#7F#, + -- and the value of this character is saved in + -- Saved_Wide_Wide_Character. + + Saved_Wide_Wide_Character : Wide_Wide_Character; + -- This field is valid only if Before_Wide_Wide_Character is set. It + -- contains a wide character read by Look_Ahead. If Look_Ahead + -- reads a character in the range 16#0000# to 16#007F#, then it + -- can use ungetc to put it back, but ungetc cannot be called + -- more than once, so for characters above this range, we don't + -- try to back up the file. Instead we save the character in this + -- field and set the flag Before_Wide_Wide_Character to indicate that + -- we are logically positioned before this character even though + -- the stream is physically positioned after it. + + end record; + + type File_Type is access all Wide_Wide_Text_AFCB; + + function AFCB_Allocate + (Control_Block : Wide_Wide_Text_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : not null access Wide_Wide_Text_AFCB); + procedure AFCB_Free (File : not null access Wide_Wide_Text_AFCB); + + procedure Read + (File : in out Wide_Wide_Text_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read operation used when Wide_Wide_Text_IO file is treated as a Stream + + procedure Write + (File : in out Wide_Wide_Text_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Write operation used when Wide_Wide_Text_IO file is treated as a Stream + + ------------------------ + -- The Standard Files -- + ------------------------ + + Standard_Err_AFCB : aliased Wide_Wide_Text_AFCB; + Standard_In_AFCB : aliased Wide_Wide_Text_AFCB; + Standard_Out_AFCB : aliased Wide_Wide_Text_AFCB; + + Standard_Err : aliased File_Type := Standard_Err_AFCB'Access; + Standard_In : aliased File_Type := Standard_In_AFCB'Access; + Standard_Out : aliased File_Type := Standard_Out_AFCB'Access; + -- Standard files + + Current_In : aliased File_Type := Standard_In; + Current_Out : aliased File_Type := Standard_Out; + Current_Err : aliased File_Type := Standard_Err; + -- Current files + + procedure Initialize_Standard_Files; + -- Initializes the file control blocks for the standard files. Called from + -- the elaboration routine for this package, and from Reset_Standard_Files + -- in package Ada.Wide_Wide_Text_IO.Reset_Standard_Files. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- These subprograms are in the private part of the spec so that they can + -- be shared by the children of Ada.Text_IO.Wide_Wide_Text_IO. + + function Getc (File : File_Type) return Interfaces.C_Streams.int; + -- Gets next character from file, which has already been checked for being + -- in read status, and returns the character read if no error occurs. The + -- result is EOF if the end of file was read. + + procedure Get_Character (File : File_Type; Item : out Character); + -- This is essentially copy of Wide_Wide_Text_IO.Get. It obtains a single + -- obtains a single character from the input file File, and places it in + -- Item. This result may be the leading character of a Wide_Wide_Character + -- sequence, but that is up to the caller to deal with. + + function Get_Wide_Wide_Char + (C : Character; + File : File_Type) return Wide_Wide_Character; + -- This function is shared by Get and Get_Immediate to extract a wide + -- character value from the given File. The first byte has already been + -- read and is passed in C. The wide character value is returned as the + -- result, and the file pointer is bumped past the character. + + function Nextc (File : File_Type) return Interfaces.C_Streams.int; + -- Returns next character from file without skipping past it (i.e. it is a + -- combination of Getc followed by an Ungetc). + +end Ada.Wide_Wide_Text_IO; diff --git a/gcc/ada/libgnat/a-ztfiio.adb b/gcc/ada/libgnat/a-ztfiio.adb new file mode 100644 index 0000000..ead6178 --- /dev/null +++ b/gcc/ada/libgnat/a-ztfiio.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . T E X T _ I O . W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Fixed_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-ztfiio.ads b/gcc/ada/libgnat/a-ztfiio.ads new file mode 100644 index 0000000..498565c --- /dev/null +++ b/gcc/ada/libgnat/a-ztfiio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F I X E D _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Fixed_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Fixed_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is delta <>; + +package Ada.Wide_Wide_Text_IO.Fixed_IO is + + Default_Fore : Field := Num'Fore; + Default_Aft : Field := Num'Aft; + Default_Exp : Field := 0; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Fixed_IO; diff --git a/gcc/ada/libgnat/a-ztflau.adb b/gcc/ada/libgnat/a-ztflau.adb new file mode 100644 index 0000000..2b7db92 --- /dev/null +++ b/gcc/ada/libgnat/a-ztflau.adb @@ -0,0 +1,235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; + +with System.Img_Real; use System.Img_Real; +with System.Val_Real; use System.Val_Real; + +package body Ada.Wide_Wide_Text_IO.Float_Aux is + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Real (File, Buf, Stop); + end if; + + Item := Scan_Real (Buf, Ptr'Access, Stop); + + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get; + + ---------- + -- Gets -- + ---------- + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Real (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets; + + --------------- + -- Load_Real -- + --------------- + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Loaded : Boolean; + + begin + -- Skip initial blanks and load possible sign + + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + -- Case of .nnnn + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Otherwise must have digits to start + + else + Load_Digits (File, Buf, Ptr, Loaded); + + -- Hopeless junk if no digits loaded + + if not Loaded then + return; + end if; + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + + -- Case of nnn#.xxx# + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '#', ':'); + + -- Case of nnn#xxx.[xxx]# or nnn#xxx# + + else + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Extended_Digits (File, Buf, Ptr); + end if; + + -- As usual, it seems strange to allow mixed base characters, + -- but that is what ACVC tests expect, see CE3804M, case (3). + + Load (File, Buf, Ptr, '#', ':'); + end if; + + -- Case of nnn.[nnn] or nnn + + else + -- Prevent the potential processing of '.' in cases where the + -- initial digits have a trailing underscore. + + if Buf (Ptr) = '_' then + return; + end if; + + Load (File, Buf, Ptr, '.', Loaded); + + if Loaded then + Load_Digits (File, Buf, Ptr); + end if; + end if; + end if; + + -- Deal with exponent + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end Load_Real; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore, Aft, Exp); + Put_Item (File, Buf (1 .. Ptr)); + end Put; + + ---------- + -- Puts -- + ---------- + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + Set_Image_Real (Item, Buf, Ptr, Fore => 1, Aft => Aft, Exp => Exp); + + if Ptr > To'Length then + raise Layout_Error; + + else + for J in 1 .. Ptr loop + To (To'Last - Ptr + J) := Buf (J); + end loop; + + for J in To'First .. To'Last - Ptr loop + To (J) := ' '; + end loop; + end if; + end Puts; + +end Ada.Wide_Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/libgnat/a-ztflau.ads b/gcc/ada/libgnat/a-ztflau.ads new file mode 100644 index 0000000..f6e8f7c --- /dev/null +++ b/gcc/ada/libgnat/a-ztflau.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Float_IO that +-- are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Float_IO itself, +-- except that generic parameter Num has been replaced by Long_Long_Float, +-- and the default parameters have been removed because they are supplied +-- explicitly by the calls from within the generic template. Also used by +-- Ada.Wide_Wide_Text_IO.Fixed_IO, and by Ada.Wide_Wide_Text_IO.Decimal_IO. + +private package Ada.Wide_Wide_Text_IO.Float_Aux is + + procedure Load_Real + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load a possibly signed + -- real literal value from the input file into Buf, starting at Ptr + 1. + + procedure Get + (File : File_Type; + Item : out Long_Long_Float; + Width : Field); + + procedure Gets + (From : String; + Item : out Long_Long_Float; + Last : out Positive); + + procedure Put + (File : File_Type; + Item : Long_Long_Float; + Fore : Field; + Aft : Field; + Exp : Field); + + procedure Puts + (To : out String; + Item : Long_Long_Float; + Aft : Field; + Exp : Field); + +end Ada.Wide_Wide_Text_IO.Float_Aux; diff --git a/gcc/ada/libgnat/a-ztflio.adb b/gcc/ada/libgnat/a-ztflio.adb new file mode 100644 index 0000000..e19fef9 --- /dev/null +++ b/gcc/ada/libgnat/a-ztflio.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Float_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Float_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Float_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + Aux.Get (TFT (File), Long_Long_Float (Item), Width); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + Aux.Gets (S, Long_Long_Float (Item), Last); + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Aux.Put (TFT (File), Long_Long_Float (Item), Fore, Aft, Exp); + end Put; + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + begin + Put (Current_Output, Item, Fore, Aft, Exp); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp) + is + S : String (To'First .. To'Last); + + begin + Aux.Puts (S, Long_Long_Float (Item), Aft, Exp); + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/libgnat/a-ztflio.ads b/gcc/ada/libgnat/a-ztflio.ads new file mode 100644 index 0000000..ca3f86b --- /dev/null +++ b/gcc/ada/libgnat/a-ztflio.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Float_IO is a subpackage of +-- Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Float_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is digits <>; + +package Ada.Wide_Wide_Text_IO.Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num'Digits - 1; + Default_Exp : Field := 3; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Put + (Item : Num; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp); + +end Ada.Wide_Wide_Text_IO.Float_IO; diff --git a/gcc/ada/libgnat/a-ztgeau.adb b/gcc/ada/libgnat/a-ztgeau.adb new file mode 100644 index 0000000..55daa74 --- /dev/null +++ b/gcc/ada/libgnat/a-ztgeau.adb @@ -0,0 +1,528 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System.File_IO; +with System.File_Control_Block; + +package body Ada.Wide_Wide_Text_IO.Generic_Aux is + + package FIO renames System.File_IO; + package FCB renames System.File_Control_Block; + subtype AP is FCB.AFCB_Ptr; + + ------------------------ + -- Check_End_Of_Field -- + ------------------------ + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field) + is + begin + if Ptr > Stop then + return; + + elsif Width = 0 then + raise Data_Error; + + else + for J in Ptr .. Stop loop + if not Is_Blank (Buf (J)) then + raise Data_Error; + end if; + end loop; + end if; + end Check_End_Of_Field; + + ----------------------- + -- Check_On_One_Line -- + ----------------------- + + procedure Check_On_One_Line + (File : File_Type; + Length : Integer) + is + begin + FIO.Check_Write_Status (AP (File)); + + if File.Line_Length /= 0 then + if Count (Length) > File.Line_Length then + raise Layout_Error; + elsif File.Col + Count (Length) > File.Line_Length + 1 then + New_Line (File); + end if; + end if; + end Check_On_One_Line; + + -------------- + -- Is_Blank -- + -------------- + + function Is_Blank (C : Character) return Boolean is + begin + return C = ' ' or else C = ASCII.HT; + end Is_Blank; + + ---------- + -- Load -- + ---------- + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + null; + + else + ch := Getc (File); + + if ch = Character'Pos (Char) then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch = Character'Pos (Char1) + or else ch = Character'Pos (Char2) + then + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + else + Ungetc (ch, File); + Loaded := False; + end if; + end if; + end Load; + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character) + is + ch : int; + + begin + if File.Before_Wide_Wide_Character then + null; + + else + ch := Getc (File); + + if ch = Character'Pos (Char1) + or else ch = Character'Pos (Char2) + then + Store_Char (File, ch, Buf, Ptr); + else + Ungetc (ch, File); + end if; + end if; + end Load; + + ----------------- + -- Load_Digits -- + ----------------- + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + ch := Getc (File); + + if ch not in Character'Pos ('0') .. Character'Pos ('9') then + Loaded := False; + + else + Loaded := True; + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end if; + end Load_Digits; + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + After_Digit : Boolean; + + begin + if File.Before_Wide_Wide_Character then + return; + + else + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + loop + Store_Char (File, ch, Buf, Ptr); + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + end loop; + end if; + + Ungetc (ch, File); + end if; + end Load_Digits; + + -------------------------- + -- Load_Extended_Digits -- + -------------------------- + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean) + is + ch : int; + After_Digit : Boolean := False; + + begin + if File.Before_Wide_Wide_Character then + Loaded := False; + return; + + else + Loaded := False; + + loop + ch := Getc (File); + + if ch in Character'Pos ('0') .. Character'Pos ('9') + or else + ch in Character'Pos ('a') .. Character'Pos ('f') + or else + ch in Character'Pos ('A') .. Character'Pos ('F') + then + After_Digit := True; + + elsif ch = Character'Pos ('_') and then After_Digit then + After_Digit := False; + + else + exit; + end if; + + Store_Char (File, ch, Buf, Ptr); + Loaded := True; + end loop; + + Ungetc (ch, File); + end if; + end Load_Extended_Digits; + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer) + is + Junk : Boolean; + pragma Unreferenced (Junk); + begin + Load_Extended_Digits (File, Buf, Ptr, Junk); + end Load_Extended_Digits; + + --------------- + -- Load_Skip -- + --------------- + + procedure Load_Skip (File : File_Type) is + C : Character; + + begin + FIO.Check_Read_Status (AP (File)); + + -- We need to explicitly test for the case of being before a wide + -- character (greater than 16#7F#). Since no such character can + -- ever legitimately be a valid numeric character, we can + -- immediately signal Data_Error. + + if File.Before_Wide_Wide_Character then + raise Data_Error; + end if; + + -- Otherwise loop till we find a non-blank character (note that as + -- usual in Wide_Wide_Text_IO, blank includes horizontal tab). Note that + -- Get_Character deals with Before_LM/Before_LM_PM flags appropriately. + + loop + Get_Character (File, C); + exit when not Is_Blank (C); + end loop; + + Ungetc (Character'Pos (C), File); + File.Col := File.Col - 1; + end Load_Skip; + + ---------------- + -- Load_Width -- + ---------------- + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer) + is + ch : int; + WC : Wide_Wide_Character; + + Bad_Wide_Wide_C : Boolean := False; + -- Set True if one of the characters read is not in range of type + -- Character. This is always a Data_Error, but we do not signal it + -- right away, since we have to read the full number of characters. + + begin + FIO.Check_Read_Status (AP (File)); + + -- If we are immediately before a line mark, then we have no characters. + -- This is always a data error, so we may as well raise it right away. + + if File.Before_LM then + raise Data_Error; + + else + for J in 1 .. Width loop + if File.Before_Wide_Wide_Character then + Bad_Wide_Wide_C := True; + Store_Char (File, 0, Buf, Ptr); + File.Before_Wide_Wide_Character := False; + + else + ch := Getc (File); + + if ch = EOF then + exit; + + elsif ch = LM then + Ungetc (ch, File); + exit; + + else + WC := Get_Wide_Wide_Char (Character'Val (ch), File); + ch := Wide_Wide_Character'Pos (WC); + + if ch > 255 then + Bad_Wide_Wide_C := True; + ch := 0; + end if; + + Store_Char (File, ch, Buf, Ptr); + end if; + end if; + end loop; + + if Bad_Wide_Wide_C then + raise Data_Error; + end if; + end if; + end Load_Width; + + -------------- + -- Put_Item -- + -------------- + + procedure Put_Item (File : File_Type; Str : String) is + begin + Check_On_One_Line (File, Str'Length); + + for J in Str'Range loop + Put (File, Wide_Wide_Character'Val (Character'Pos (Str (J)))); + end loop; + end Put_Item; + + ---------------- + -- Store_Char -- + ---------------- + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : out String; + Ptr : in out Integer) + is + begin + File.Col := File.Col + 1; + + if Ptr = Buf'Last then + raise Data_Error; + else + Ptr := Ptr + 1; + Buf (Ptr) := Character'Val (ch); + end if; + end Store_Char; + + ----------------- + -- String_Skip -- + ----------------- + + procedure String_Skip (Str : String; Ptr : out Integer) is + begin + -- Routines calling String_Skip malfunction if Str'Last = Positive'Last. + -- It's too much trouble to make this silly case work, so we just raise + -- Program_Error with an appropriate message. We raise Program_Error + -- rather than Constraint_Error because we don't want this case to be + -- converted to Data_Error. + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + -- Normal case where Str'Last < Positive'Last + + Ptr := Str'First; + + loop + if Ptr > Str'Last then + raise End_Error; + + elsif not Is_Blank (Str (Ptr)) then + return; + + else + Ptr := Ptr + 1; + end if; + end loop; + end String_Skip; + + ------------ + -- Ungetc -- + ------------ + + procedure Ungetc (ch : int; File : File_Type) is + begin + if ch /= EOF then + if ungetc (ch, File.Stream) = EOF then + raise Device_Error; + end if; + end if; + end Ungetc; + +end Ada.Wide_Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/libgnat/a-ztgeau.ads b/gcc/ada/libgnat/a-ztgeau.ads new file mode 100644 index 0000000..c2388b1 --- /dev/null +++ b/gcc/ada/libgnat/a-ztgeau.ads @@ -0,0 +1,184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . G E N E R I C _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a set of auxiliary routines used by Wide_Wide_Text_IO +-- generic children, including for reading and writing numeric strings. + +-- Note: although this is the Wide version of the package, the interface here +-- is still in terms of Character and String rather than Wide_Wide_Character +-- and Wide_Wide_String, since all numeric strings are composed entirely of +-- characters in the range of type Standard.Character, and the basic +-- conversion routines work with Character rather than Wide_Wide_Character. + +package Ada.Wide_Wide_Text_IO.Generic_Aux is + + -- Note: for all the Load routines, File indicates the file to be read, + -- Buf is the string into which data is stored, Ptr is the index of the + -- last character stored so far, and is updated if additional characters + -- are stored. Data_Error is raised if the input overflows Buf. The only + -- Load routines that do a file status check are Load_Skip and Load_Width + -- so one of these two routines must be called first. + + procedure Check_End_Of_Field + (Buf : String; + Stop : Integer; + Ptr : Integer; + Width : Field); + -- This routine is used after doing a get operations on a numeric value. + -- Buf is the string being scanned, and Stop is the last character of + -- the field being scanned. Ptr is as set by the call to the scan routine + -- that scanned out the numeric value, i.e. it points one past the last + -- character scanned, and Width is the width parameter from the Get call. + -- + -- There are two cases, if Width is non-zero, then a check is made that + -- the remainder of the field is all blanks. If Width is zero, then it + -- means that the scan routine scanned out only part of the field. We + -- have already scanned out the field that the ACVC tests seem to expect + -- us to read (even if it does not follow the syntax of the type being + -- scanned, e.g. allowing negative exponents in integers, and underscores + -- at the end of the string), so we just raise Data_Error. + + procedure Check_On_One_Line (File : File_Type; Length : Integer); + -- Check to see if item of length Integer characters can fit on + -- current line. Call New_Line if not, first checking that the + -- line length can accommodate Length characters, raise Layout_Error + -- if item is too large for a single line. + + function Is_Blank (C : Character) return Boolean; + -- Determines if C is a blank (space or tab) + + procedure Load_Width + (File : File_Type; + Width : Field; + Buf : out String; + Ptr : in out Integer); + -- Loads exactly Width characters, unless a line mark is encountered first + + procedure Load_Skip (File : File_Type); + -- Skips leading blanks and line and page marks, if the end of file is + -- read without finding a non-blank character, then End_Error is raised. + -- Note: a blank is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character; + Loaded : out Boolean); + -- If next character is Char, loads it, otherwise no characters are loaded + -- Loaded is set to indicate whether or not the character was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char : Character); + -- Same as above, but no indication if character is loaded + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character; + Loaded : out Boolean); + -- If next character is Char1 or Char2, loads it, otherwise no characters + -- are loaded. Loaded is set to indicate whether or not one of the two + -- characters was found. + + procedure Load + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Char1 : Character; + Char2 : Character); + -- Same as above, but no indication if character is loaded + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Loads a sequence of zero or more decimal digits. Loaded is set if + -- at least one digit is loaded. + + procedure Load_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer; + Loaded : out Boolean); + -- Like Load_Digits, but also allows extended digits a-f and A-F + + procedure Load_Extended_Digits + (File : File_Type; + Buf : out String; + Ptr : in out Integer); + -- Same as above, but no indication if character is loaded + + procedure Put_Item (File : File_Type; Str : String); + -- This routine is like Wide_Wide_Text_IO.Put, except that it checks for + -- overflow of bounded lines, as described in (RM A.10.6(8)). It is used + -- for all output of numeric values and of enumeration values. Note that + -- the buffer is of type String. Put_Item deals with converting this to + -- Wide_Wide_Characters as required. + + procedure Store_Char + (File : File_Type; + ch : Integer; + Buf : out String; + Ptr : in out Integer); + -- Store a single character in buffer, checking for overflow and + -- adjusting the column number in the file to reflect the fact + -- that a character has been acquired from the input stream. + -- The pos value of the character to store is in ch on entry. + + procedure String_Skip (Str : String; Ptr : out Integer); + -- Used in the Get from string procedures to skip leading blanks in the + -- string. Ptr is set to the index of the first non-blank. If the string + -- is all blanks, then the excption End_Error is raised, Note that blank + -- is defined as a space or horizontal tab (RM A.10.6(5)). + + procedure Ungetc (ch : Integer; File : File_Type); + -- Pushes back character into stream, using ungetc. The caller has + -- checked that the file is in read status. Device_Error is raised + -- if the character cannot be pushed back. An attempt to push back + -- an end of file (EOF) is ignored. + +private + pragma Inline (Is_Blank); + +end Ada.Wide_Wide_Text_IO.Generic_Aux; diff --git a/gcc/ada/libgnat/a-ztinau.adb b/gcc/ada/libgnat/a-ztinau.adb new file mode 100644 index 0000000..6e5ba72 --- /dev/null +++ b/gcc/ada/libgnat/a-ztinau.adb @@ -0,0 +1,295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Int; use System.Img_Int; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLI; use System.Img_LLI; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Int; use System.Val_Int; +with System.Val_LLI; use System.Val_LLI; + +package body Ada.Wide_Wide_Text_IO.Integer_Aux is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load an possibly signed + -- integer literal value from the input file into Buf, starting at Ptr + 1. + -- On return, Ptr is set to the last character stored. + + ------------- + -- Get_Int -- + ------------- + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Int; + + ------------- + -- Get_LLI -- + ------------- + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field) + is + Buf : String (1 .. Field'Last); + Ptr : aliased Integer := 1; + Stop : Integer := 0; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Integer (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Integer (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLI; + + -------------- + -- Gets_Int -- + -------------- + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Int; + + -------------- + -- Gets_LLI -- + -------------- + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Integer (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLI; + + ------------------ + -- Load_Integer -- + ------------------ + + procedure Load_Integer + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + Load (File, Buf, Ptr, '+', '-'); + + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Integer; + + ------------- + -- Put_Int -- + ------------- + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Int; + + ------------- + -- Put_LLI -- + ------------- + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Integer (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLI; + + -------------- + -- Puts_Int -- + -------------- + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Int; + + -------------- + -- Puts_LLI -- + -------------- + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Integer (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Integer (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLI; + +end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-ztinau.ads b/gcc/ada/libgnat/a-ztinau.ads new file mode 100644 index 0000000..b294eab1 --- /dev/null +++ b/gcc/ada/libgnat/a-ztinau.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Integer_IO +-- that are shared among separate instantiations of this package. The routines +-- in this package are identical semantically to those in Integer_IO itself, +-- except that the generic parameter Num has been replaced by Integer or +-- Long_Long_Integer, and the default parameters have been removed because +-- they are supplied explicitly by the calls from within the generic template. + +private package Ada.Wide_Wide_Text_IO.Integer_Aux is + + procedure Get_Int + (File : File_Type; + Item : out Integer; + Width : Field); + + procedure Get_LLI + (File : File_Type; + Item : out Long_Long_Integer; + Width : Field); + + procedure Gets_Int + (From : String; + Item : out Integer; + Last : out Positive); + + procedure Gets_LLI + (From : String; + Item : out Long_Long_Integer; + Last : out Positive); + + procedure Put_Int + (File : File_Type; + Item : Integer; + Width : Field; + Base : Number_Base); + + procedure Put_LLI + (File : File_Type; + Item : Long_Long_Integer; + Width : Field; + Base : Number_Base); + + procedure Puts_Int + (To : out String; + Item : Integer; + Base : Number_Base); + + procedure Puts_LLI + (To : out String; + Item : Long_Long_Integer; + Base : Number_Base); + +end Ada.Wide_Wide_Text_IO.Integer_Aux; diff --git a/gcc/ada/libgnat/a-ztinio.adb b/gcc/ada/libgnat/a-ztinio.adb new file mode 100644 index 0000000..197b99b --- /dev/null +++ b/gcc/ada/libgnat/a-ztinio.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Integer_Aux; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Integer_IO is + + Need_LLI : constant Boolean := Num'Base'Size > Integer'Size; + -- Throughout this generic body, we distinguish between the case where type + -- Integer is acceptable, and where a Long_Long_Integer is needed. This + -- Boolean is used to test for these cases and since it is a constant, only + -- code for the relevant case will be included in the instance. + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Integer_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Need_LLI then + Aux.Get_LLI (TFT (File), Long_Long_Integer (Item), Width); + else + Aux.Get_Int (TFT (File), Integer (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Need_LLI then + Aux.Gets_LLI (S, Long_Long_Integer (Item), Last); + else + Aux.Gets_Int (S, Integer (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Need_LLI then + Aux.Put_LLI (TFT (File), Long_Long_Integer (Item), Width, Base); + else + Aux.Put_Int (TFT (File), Integer (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Need_LLI then + Aux.Puts_LLI (S, Long_Long_Integer (Item), Base); + else + Aux.Puts_Int (S, Integer (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-ztinio.ads b/gcc/ada/libgnat/a-ztinio.ads new file mode 100644 index 0000000..2434f8b3 --- /dev/null +++ b/gcc/ada/libgnat/a-ztinio.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Integer_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Integer_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is range <>; + +package Ada.Wide_Wide_Text_IO.Integer_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Wide_Text_IO.Integer_IO; diff --git a/gcc/ada/libgnat/a-ztmoau.adb b/gcc/ada/libgnat/a-ztmoau.adb new file mode 100644 index 0000000..6394b35 --- /dev/null +++ b/gcc/ada/libgnat/a-ztmoau.adb @@ -0,0 +1,305 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Generic_Aux; use Ada.Wide_Wide_Text_IO.Generic_Aux; + +with System.Img_BIU; use System.Img_BIU; +with System.Img_Uns; use System.Img_Uns; +with System.Img_LLB; use System.Img_LLB; +with System.Img_LLU; use System.Img_LLU; +with System.Img_LLW; use System.Img_LLW; +with System.Img_WIU; use System.Img_WIU; +with System.Val_Uns; use System.Val_Uns; +with System.Val_LLU; use System.Val_LLU; + +package body Ada.Wide_Wide_Text_IO.Modular_Aux is + + use System.Unsigned_Types; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural); + -- This is an auxiliary routine that is used to load an possibly signed + -- modular literal value from the input file into Buf, starting at Ptr + 1. + -- Ptr is left set to the last character stored. + + ------------- + -- Get_LLU -- + ------------- + + procedure Get_LLU + (File : File_Type; + Item : out Long_Long_Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Long_Long_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_LLU; + + ------------- + -- Get_Uns -- + ------------- + + procedure Get_Uns + (File : File_Type; + Item : out Unsigned; + Width : Field) + is + Buf : String (1 .. Field'Last); + Stop : Integer := 0; + Ptr : aliased Integer := 1; + + begin + if Width /= 0 then + Load_Width (File, Width, Buf, Stop); + String_Skip (Buf, Ptr); + else + Load_Modular (File, Buf, Stop); + end if; + + Item := Scan_Unsigned (Buf, Ptr'Access, Stop); + Check_End_Of_Field (Buf, Stop, Ptr, Width); + end Get_Uns; + + -------------- + -- Gets_LLU -- + -------------- + + procedure Gets_LLU + (From : String; + Item : out Long_Long_Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Long_Long_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_LLU; + + -------------- + -- Gets_Uns -- + -------------- + + procedure Gets_Uns + (From : String; + Item : out Unsigned; + Last : out Positive) + is + Pos : aliased Integer; + + begin + String_Skip (From, Pos); + Item := Scan_Unsigned (From, Pos'Access, From'Last); + Last := Pos - 1; + + exception + when Constraint_Error => + raise Data_Error; + end Gets_Uns; + + ------------------ + -- Load_Modular -- + ------------------ + + procedure Load_Modular + (File : File_Type; + Buf : out String; + Ptr : in out Natural) + is + Hash_Loc : Natural; + Loaded : Boolean; + + begin + Load_Skip (File); + + -- Note: it is a bit strange to allow a minus sign here, but it seems + -- consistent with the general behavior expected by the ACVC tests + -- which is to scan past junk and then signal data error, see ACVC + -- test CE3704F, case (6), which is for signed integer exponents, + -- which seems a similar case. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr, Loaded); + + if Loaded then + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + Load (File, Buf, Ptr, '#', ':', Loaded); + + if Loaded then + Hash_Loc := Ptr; + Load_Extended_Digits (File, Buf, Ptr); + Load (File, Buf, Ptr, Buf (Hash_Loc)); + end if; + + Load (File, Buf, Ptr, 'E', 'e', Loaded); + + if Loaded then + + -- Note: it is strange to allow a minus sign, since the syntax + -- does not, but that is what ACVC test CE3704F, case (6) wants + -- for the signed case, and there seems no good reason to treat + -- exponents differently for the signed and unsigned cases. + + Load (File, Buf, Ptr, '+', '-'); + Load_Digits (File, Buf, Ptr); + end if; + end if; + end Load_Modular; + + ------------- + -- Put_LLU -- + ------------- + + procedure Put_LLU + (File : File_Type; + Item : Long_Long_Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Long_Long_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_LLU; + + ------------- + -- Put_Uns -- + ------------- + + procedure Put_Uns + (File : File_Type; + Item : Unsigned; + Width : Field; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 and then Width = 0 then + Set_Image_Unsigned (Item, Buf, Ptr); + elsif Base = 10 then + Set_Image_Width_Unsigned (Item, Width, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, Width, Buf, Ptr); + end if; + + Put_Item (File, Buf (1 .. Ptr)); + end Put_Uns; + + -------------- + -- Puts_LLU -- + -------------- + + procedure Puts_LLU + (To : out String; + Item : Long_Long_Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Long_Long_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Long_Long_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_LLU; + + -------------- + -- Puts_Uns -- + -------------- + + procedure Puts_Uns + (To : out String; + Item : Unsigned; + Base : Number_Base) + is + Buf : String (1 .. Field'Last); + Ptr : Natural := 0; + + begin + if Base = 10 then + Set_Image_Width_Unsigned (Item, To'Length, Buf, Ptr); + else + Set_Image_Based_Unsigned (Item, Base, To'Length, Buf, Ptr); + end if; + + if Ptr > To'Length then + raise Layout_Error; + else + To (To'First .. To'First + Ptr - 1) := Buf (1 .. Ptr); + end if; + end Puts_Uns; + +end Ada.Wide_Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-ztmoau.ads b/gcc/ada/libgnat/a-ztmoau.ads new file mode 100644 index 0000000..be387d2 --- /dev/null +++ b/gcc/ada/libgnat/a-ztmoau.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for Ada.Wide_Wide_Text_IO.Modular_IO +-- that are shared among separate instantiations of this package. The +-- routines in this package are identical semantically to those in Modular_IO +-- itself, except that the generic parameter Num has been replaced by +-- Unsigned or Long_Long_Unsigned, and the default parameters have been +-- removed because they are supplied explicitly by the calls from within the +-- generic template. + +with System.Unsigned_Types; + +private package Ada.Wide_Wide_Text_IO.Modular_Aux is + + package U renames System.Unsigned_Types; + + procedure Get_Uns + (File : File_Type; + Item : out U.Unsigned; + Width : Field); + + procedure Get_LLU + (File : File_Type; + Item : out U.Long_Long_Unsigned; + Width : Field); + + procedure Gets_Uns + (From : String; + Item : out U.Unsigned; + Last : out Positive); + + procedure Gets_LLU + (From : String; + Item : out U.Long_Long_Unsigned; + Last : out Positive); + + procedure Put_Uns + (File : File_Type; + Item : U.Unsigned; + Width : Field; + Base : Number_Base); + + procedure Put_LLU + (File : File_Type; + Item : U.Long_Long_Unsigned; + Width : Field; + Base : Number_Base); + + procedure Puts_Uns + (To : out String; + Item : U.Unsigned; + Base : Number_Base); + + procedure Puts_LLU + (To : out String; + Item : U.Long_Long_Unsigned; + Base : Number_Base); + +end Ada.Wide_Wide_Text_IO.Modular_Aux; diff --git a/gcc/ada/libgnat/a-ztmoio.adb b/gcc/ada/libgnat/a-ztmoio.adb new file mode 100644 index 0000000..f79d701 --- /dev/null +++ b/gcc/ada/libgnat/a-ztmoio.adb @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO.Modular_Aux; + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_WtS; use System.WCh_WtS; + +package body Ada.Wide_Wide_Text_IO.Modular_IO is + + subtype TFT is Ada.Wide_Wide_Text_IO.File_Type; + -- File type required for calls to routines in Aux + + package Aux renames Ada.Wide_Wide_Text_IO.Modular_Aux; + + --------- + -- Get -- + --------- + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0) + is + begin + if Num'Size > Unsigned'Size then + Aux.Get_LLU (TFT (File), Long_Long_Unsigned (Item), Width); + else + Aux.Get_Uns (TFT (File), Unsigned (Item), Width); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + procedure Get + (Item : out Num; + Width : Field := 0) + is + begin + Get (Current_Input, Item, Width); + end Get; + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive) + is + S : constant String := Wide_Wide_String_To_String (From, WCEM_Upper); + -- String on which we do the actual conversion. Note that the method + -- used for wide character encoding is irrelevant, since if there is + -- a character outside the Standard.Character range then the call to + -- Aux.Gets will raise Data_Error in any case. + + begin + if Num'Size > Unsigned'Size then + Aux.Gets_LLU (S, Long_Long_Unsigned (Item), Last); + else + Aux.Gets_Uns (S, Unsigned (Item), Last); + end if; + + exception + when Constraint_Error => raise Data_Error; + end Get; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + if Num'Size > Unsigned'Size then + Aux.Put_LLU (TFT (File), Long_Long_Unsigned (Item), Width, Base); + else + Aux.Put_Uns (TFT (File), Unsigned (Item), Width, Base); + end if; + end Put; + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base) + is + begin + Put (Current_Output, Item, Width, Base); + end Put; + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base) + is + S : String (To'First .. To'Last); + + begin + if Num'Size > Unsigned'Size then + Aux.Puts_LLU (S, Long_Long_Unsigned (Item), Base); + else + Aux.Puts_Uns (S, Unsigned (Item), Base); + end if; + + for J in S'Range loop + To (J) := Wide_Wide_Character'Val (Character'Pos (S (J))); + end loop; + end Put; + +end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-ztmoio.ads b/gcc/ada/libgnat/a-ztmoio.ads new file mode 100644 index 0000000..11aeaef --- /dev/null +++ b/gcc/ada/libgnat/a-ztmoio.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . M O D U L A R _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- In Ada 95, the package Ada.Wide_Wide_Text_IO.Modular_IO is a subpackage +-- of Wide_Wide_Text_IO. In GNAT we make it a child package to avoid loading +-- the necessary code if Modular_IO is not instantiated. See the routine +-- Rtsfind.Check_Text_IO_Special_Unit for a description of how we patch up +-- the difference in semantics so that it is invisible to the Ada programmer. + +private generic + type Num is mod <>; + +package Ada.Wide_Wide_Text_IO.Modular_IO is + + Default_Width : Field := Num'Width; + Default_Base : Number_Base := 10; + + procedure Get + (File : File_Type; + Item : out Num; + Width : Field := 0); + + procedure Get + (Item : out Num; + Width : Field := 0); + + procedure Put + (File : File_Type; + Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Put + (Item : Num; + Width : Field := Default_Width; + Base : Number_Base := Default_Base); + + procedure Get + (From : Wide_Wide_String; + Item : out Num; + Last : out Positive); + + procedure Put + (To : out Wide_Wide_String; + Item : Num; + Base : Number_Base := Default_Base); + +end Ada.Wide_Wide_Text_IO.Modular_IO; diff --git a/gcc/ada/libgnat/a-zttest.adb b/gcc/ada/libgnat/a-zttest.adb new file mode 100644 index 0000000..db2a398 --- /dev/null +++ b/gcc/ada/libgnat/a-zttest.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; + +package body Ada.Wide_Wide_Text_IO.Text_Streams is + + ------------ + -- Stream -- + ------------ + + function Stream (File : File_Type) return Stream_Access is + begin + System.File_IO.Check_File_Open (FCB.AFCB_Ptr (File)); + return Stream_Access (File); + end Stream; + +end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/libgnat/a-zttest.ads b/gcc/ada/libgnat/a-zttest.ads new file mode 100644 index 0000000..1599253 --- /dev/null +++ b/gcc/ada/libgnat/a-zttest.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A . W I D E _ W I D E _ T E X T _ I O . T E X T _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; + +package Ada.Wide_Wide_Text_IO.Text_Streams is + + type Stream_Access is access all Streams.Root_Stream_Type'Class; + + function Stream (File : File_Type) return Stream_Access; + +end Ada.Wide_Wide_Text_IO.Text_Streams; diff --git a/gcc/ada/libgnat/a-zzboio.adb b/gcc/ada/libgnat/a-zzboio.adb new file mode 100644 index 0000000..8763e48 --- /dev/null +++ b/gcc/ada/libgnat/a-zzboio.adb @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_BOUNDED_IO -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Wide_Wide_Text_IO; use Ada.Wide_Wide_Text_IO; +with Ada.Unchecked_Deallocation; + +package body Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO is + + type Wide_Wide_String_Access is access all Wide_Wide_String; + + procedure Free (WWSA : in out Wide_Wide_String_Access); + -- Perform an unchecked deallocation of a non-null string + + ---------- + -- Free -- + ---------- + + procedure Free (WWSA : in out Wide_Wide_String_Access) is + Null_Wide_Wide_String : constant Wide_Wide_String := ""; + + procedure Deallocate is + new Ada.Unchecked_Deallocation ( + Wide_Wide_String, Wide_Wide_String_Access); + + begin + -- Do not try to free statically allocated null string + + if WWSA.all /= Null_Wide_Wide_String then + Deallocate (WWSA); + end if; + end Free; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line return Wide_Wide_Bounded.Bounded_Wide_Wide_String is + begin + return Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Get_Line); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + function Get_Line + (File : File_Type) return Wide_Wide_Bounded.Bounded_Wide_Wide_String + is + begin + return Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Get_Line (File)); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + + begin + Get_Line (Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Str1.all); + end Get_Line; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + Buffer : Wide_Wide_String (1 .. 1000); + Last : Natural; + Str1 : Wide_Wide_String_Access; + Str2 : Wide_Wide_String_Access; + + begin + Get_Line (File, Buffer, Last); + Str1 := new Wide_Wide_String'(Buffer (1 .. Last)); + + while Last = Buffer'Last loop + Get_Line (File, Buffer, Last); + Str2 := new Wide_Wide_String'(Str1.all & Buffer (1 .. Last)); + Free (Str1); + Str1 := Str2; + end loop; + + Item := Wide_Wide_Bounded.To_Bounded_Wide_Wide_String (Str1.all); + end Get_Line; + + --------- + -- Put -- + --------- + + procedure Put + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put (Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put (File, Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put_Line (Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put_Line; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String) + is + begin + Put_Line (File, Wide_Wide_Bounded.To_Wide_Wide_String (Item)); + end Put_Line; + +end Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO; diff --git a/gcc/ada/libgnat/a-zzboio.ads b/gcc/ada/libgnat/a-zzboio.ads new file mode 100644 index 0000000..68157e9 --- /dev/null +++ b/gcc/ada/libgnat/a-zzboio.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_BOUNDED_IO -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Wide_Wide_Bounded; + +generic + with package Wide_Wide_Bounded is + new Ada.Strings.Wide_Wide_Bounded.Generic_Bounded_Length (<>); + +package Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO is + + function Get_Line return Wide_Wide_Bounded.Bounded_Wide_Wide_String; + + function Get_Line + (File : File_Type) return Wide_Wide_Bounded.Bounded_Wide_Wide_String; + + procedure Get_Line + (Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Get_Line + (File : File_Type; + Item : out Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put_Line + (Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + + procedure Put_Line + (File : File_Type; + Item : Wide_Wide_Bounded.Bounded_Wide_Wide_String); + +end Ada.Wide_Wide_Text_IO.Wide_Wide_Bounded_IO; diff --git a/gcc/ada/libgnat/a-zzunio.ads b/gcc/ada/libgnat/a-zzunio.ads new file mode 100644 index 0000000..1695b06 --- /dev/null +++ b/gcc/ada/libgnat/a-zzunio.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- ADA.WIDE_WIDE_TEXT_IO.WIDE_WIDE_UNBOUNDED_IO -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: historically GNAT provided these subprograms as a child of the +-- package Ada.Strings.Wide_Wide_Unbounded. So we implement this new Ada 2005 +-- package by renaming the subprograms in that child. This is a more +-- straightforward implementation anyway, since we need access to the +-- internal representation of Unbounded_Wide_Wide_String. + +with Ada.Strings.Wide_Wide_Unbounded; +with Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO; + +package Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO is + + procedure Put + (File : File_Type; + Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; + + procedure Put + (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put; + + procedure Put_Line + (File : Wide_Wide_Text_IO.File_Type; + Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; + + procedure Put_Line + (Item : Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Put_Line; + + function Get_Line + (File : File_Type) + return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + function Get_Line + return Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + procedure Get_Line + (File : File_Type; + Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + + procedure Get_Line + (Item : out Strings.Wide_Wide_Unbounded.Unbounded_Wide_Wide_String) + renames Ada.Strings.Wide_Wide_Unbounded.Wide_Wide_Text_IO.Get_Line; + +end Ada.Wide_Wide_Text_IO.Wide_Wide_Unbounded_IO; diff --git a/gcc/ada/libgnat/ada.ads b/gcc/ada/libgnat/ada.ads new file mode 100644 index 0000000..1effebe --- /dev/null +++ b/gcc/ada/libgnat/ada.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- A D A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package Ada is + pragma No_Elaboration_Code_All; + pragma Pure; + +end Ada; diff --git a/gcc/ada/libgnat/calendar.ads b/gcc/ada/libgnat/calendar.ads new file mode 100644 index 0000000..7b13a6f --- /dev/null +++ b/gcc/ada/libgnat/calendar.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +package Calendar renames Ada.Calendar; diff --git a/gcc/ada/libgnat/directio.ads b/gcc/ada/libgnat/directio.ads new file mode 100644 index 0000000..6c0f9f5 --- /dev/null +++ b/gcc/ada/libgnat/directio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- D I R E C T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and Direct_IO is not considered +-- to be an internal unit that is automatically compiled in Ada 2012 mode +-- (since a user is allowed to redeclare Direct_IO). + +with Ada.Direct_IO; + +generic package Direct_IO renames Ada.Direct_IO; diff --git a/gcc/ada/libgnat/g-allein.ads b/gcc/ada/libgnat/g-allein.ads new file mode 100644 index 0000000..5dc7fb4 --- /dev/null +++ b/gcc/ada/libgnat/g-allein.ads @@ -0,0 +1,304 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . L O W _ L E V E L _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides entities to be used internally by the units common to +-- both bindings (Hard or Soft), and relevant to the interfacing with the +-- underlying Low Level support. + +with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; +with GNAT.Altivec.Low_Level_Vectors; use GNAT.Altivec.Low_Level_Vectors; + +with Ada.Unchecked_Conversion; + +package GNAT.Altivec.Low_Level_Interface is + + ----------------------------------------- + -- Conversions between low level types -- + ----------------------------------------- + + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBC, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUC, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSC, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBS, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUS, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSS, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VBI, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VUI, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VSI, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VF, LL_VBC); + function To_LL_VBC is new Ada.Unchecked_Conversion (LL_VP, LL_VBC); + + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBC, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUC, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSC, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBS, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUS, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSS, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VBI, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VUI, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VSI, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VF, LL_VUC); + function To_LL_VUC is new Ada.Unchecked_Conversion (LL_VP, LL_VUC); + + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBC, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUC, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSC, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBS, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUS, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSS, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VBI, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VUI, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VSI, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VF, LL_VSC); + function To_LL_VSC is new Ada.Unchecked_Conversion (LL_VP, LL_VSC); + + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBC, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUC, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSC, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBS, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUS, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSS, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VBI, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VUI, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VSI, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VF, LL_VBS); + function To_LL_VBS is new Ada.Unchecked_Conversion (LL_VP, LL_VBS); + + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBC, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUC, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSC, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBS, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUS, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSS, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VBI, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VUI, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VSI, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VF, LL_VUS); + function To_LL_VUS is new Ada.Unchecked_Conversion (LL_VP, LL_VUS); + + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBC, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUC, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSC, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBS, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUS, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSS, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VBI, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VUI, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VSI, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VF, LL_VSS); + function To_LL_VSS is new Ada.Unchecked_Conversion (LL_VP, LL_VSS); + + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBC, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUC, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSC, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBS, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUS, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSS, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VBI, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VUI, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VSI, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VF, LL_VBI); + function To_LL_VBI is new Ada.Unchecked_Conversion (LL_VP, LL_VBI); + + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBC, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUC, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSC, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBS, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUS, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSS, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VBI, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VUI, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VSI, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VF, LL_VUI); + function To_LL_VUI is new Ada.Unchecked_Conversion (LL_VP, LL_VUI); + + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBC, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUC, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSC, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBS, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUS, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSS, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VBI, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VUI, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VSI, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VF, LL_VSI); + function To_LL_VSI is new Ada.Unchecked_Conversion (LL_VP, LL_VSI); + + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBC, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUC, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSC, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBS, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUS, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSS, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VBI, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VUI, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VSI, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VF, LL_VF); + function To_LL_VF is new Ada.Unchecked_Conversion (LL_VP, LL_VF); + + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBC, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUC, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSC, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBS, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUS, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSS, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VBI, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VUI, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VSI, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VF, LL_VP); + function To_LL_VP is new Ada.Unchecked_Conversion (LL_VP, LL_VP); + + ---------------------------------------------- + -- Conversions Between Pointer/Access Types -- + ---------------------------------------------- + + function To_PTR is + new Ada.Unchecked_Conversion (vector_unsigned_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_signed_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_bool_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_unsigned_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_signed_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_bool_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_unsigned_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_signed_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_bool_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_float_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (vector_pixel_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_bool_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_signed_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_unsigned_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_bool_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_signed_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_unsigned_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_bool_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_signed_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_unsigned_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_float_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_vector_pixel_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (c_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (signed_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (unsigned_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (signed_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (unsigned_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (signed_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (unsigned_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (signed_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (unsigned_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (float_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_signed_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_unsigned_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_signed_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_unsigned_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_signed_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_unsigned_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_signed_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_unsigned_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (const_float_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_signed_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_unsigned_char_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_signed_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_unsigned_short_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_signed_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_unsigned_int_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_signed_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_unsigned_long_ptr, c_ptr); + function To_PTR is + new Ada.Unchecked_Conversion (constv_float_ptr, c_ptr); + +end GNAT.Altivec.Low_Level_Interface; diff --git a/gcc/ada/libgnat/g-alleve-hard.adb b/gcc/ada/libgnat/g-alleve-hard.adb new file mode 100644 index 0000000..4819211 --- /dev/null +++ b/gcc/ada/libgnat/g-alleve-hard.adb @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- +-- -- +-- B o d y -- +-- (Hard Binding Version) -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Altivec.Low_Level_Vectors is + +end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-alleve-hard.ads b/gcc/ada/libgnat/g-alleve-hard.ads new file mode 100644 index 0000000..63a0a67 --- /dev/null +++ b/gcc/ada/libgnat/g-alleve-hard.ads @@ -0,0 +1,593 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- +-- -- +-- S p e c -- +-- (Hard Binding Version) -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit exposes the low level vector support for the Hard binding, +-- intended for AltiVec capable targets. See Altivec.Design for a description +-- of what is expected to be exposed. + +package GNAT.Altivec.Low_Level_Vectors is + pragma Elaborate_Body; + + ---------------------------------------- + -- Low-level Vector Type Declarations -- + ---------------------------------------- + + type LL_VUC is private; + type LL_VSC is private; + type LL_VBC is private; + + type LL_VUS is private; + type LL_VSS is private; + type LL_VBS is private; + + type LL_VUI is private; + type LL_VSI is private; + type LL_VBI is private; + + type LL_VF is private; + type LL_VP is private; + + ------------------------------------ + -- Low-level Functional Interface -- + ------------------------------------ + + function abs_v16qi (A : LL_VSC) return LL_VSC; + function abs_v8hi (A : LL_VSS) return LL_VSS; + function abs_v4si (A : LL_VSI) return LL_VSI; + function abs_v4sf (A : LL_VF) return LL_VF; + + function abss_v16qi (A : LL_VSC) return LL_VSC; + function abss_v8hi (A : LL_VSS) return LL_VSS; + function abss_v4si (A : LL_VSI) return LL_VSI; + + function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vaddfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vand (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI; + + function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VF; + + function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vcfux (A : LL_VUI; B : c_int) return LL_VF; + function vcfsx (A : LL_VSI; B : c_int) return LL_VF; + + function vctsxs (A : LL_VF; B : c_int) return LL_VSI; + function vctuxs (A : LL_VF; B : c_int) return LL_VUI; + + procedure dss (A : c_int); + procedure dssall; + + procedure dst (A : c_ptr; B : c_int; C : c_int); + procedure dstst (A : c_ptr; B : c_int; C : c_int); + procedure dststt (A : c_ptr; B : c_int; C : c_int); + procedure dstt (A : c_ptr; B : c_int; C : c_int); + + function vexptefp (A : LL_VF) return LL_VF; + + function vrfim (A : LL_VF) return LL_VF; + + function lvx (A : c_long; B : c_ptr) return LL_VSI; + function lvebx (A : c_long; B : c_ptr) return LL_VSC; + function lvehx (A : c_long; B : c_ptr) return LL_VSS; + function lvewx (A : c_long; B : c_ptr) return LL_VSI; + function lvxl (A : c_long; B : c_ptr) return LL_VSI; + + function vlogefp (A : LL_VF) return LL_VF; + + function lvsl (A : c_long; B : c_ptr) return LL_VSC; + function lvsr (A : c_long; B : c_ptr) return LL_VSC; + + function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; + + function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function mfvscr return LL_VSS; + + function vminfp (A : LL_VF; B : LL_VF) return LL_VF; + function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; + function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; + function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + + procedure mtvscr (A : LL_VSI); + + function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI; + function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI; + + function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI; + function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI; + + function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; + + function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vor (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS; + + function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI; + + function vrefp (A : LL_VF) return LL_VF; + + function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vrfin (A : LL_VF) return LL_VF; + function vrfip (A : LL_VF) return LL_VF; + function vrfiz (A : LL_VF) return LL_VF; + + function vrsqrtefp (A : LL_VF) return LL_VF; + + function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI; + + function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI; + function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS; + function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC; + function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF; + + function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vspltb (A : LL_VSC; B : c_int) return LL_VSC; + function vsplth (A : LL_VSS; B : c_int) return LL_VSS; + function vspltw (A : LL_VSI; B : c_int) return LL_VSI; + + function vspltisb (A : c_int) return LL_VSC; + function vspltish (A : c_int) return LL_VSS; + function vspltisw (A : c_int) return LL_VSI; + + function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI; + + procedure stvx (A : LL_VSI; B : c_int; C : c_ptr); + procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr); + procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr); + procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr); + procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr); + + function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsubfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI; + function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI; + function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI; + + function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vupkhsb (A : LL_VSC) return LL_VSS; + function vupkhsh (A : LL_VSS) return LL_VSI; + function vupkhpx (A : LL_VSS) return LL_VSI; + + function vupklsb (A : LL_VSC) return LL_VSS; + function vupklsh (A : LL_VSS) return LL_VSI; + function vupklpx (A : LL_VSS) return LL_VSI; + + function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + + function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + + function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + +private + + --------------------------------------- + -- Low-level Vector Type Definitions -- + --------------------------------------- + + -- [PIM-2.3.3 Alignment of aggregate and unions containing vector types]: + + -- "Aggregates (structures and arrays) and unions containing vector + -- types must be aligned on 16-byte boundaries and their internal + -- organization padded, if necessary, so that each internal vector + -- type is aligned on a 16-byte boundary. This is an extension to + -- all ABIs (AIX, Apple, SVR4, and EABI). + + -------------------------- + -- char Core Components -- + -------------------------- + + type LL_VUC is array (1 .. 16) of unsigned_char; + for LL_VUC'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VUC, "vector_type"); + pragma Suppress (All_Checks, LL_VUC); + + type LL_VSC is array (1 .. 16) of signed_char; + for LL_VSC'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VSC, "vector_type"); + pragma Suppress (All_Checks, LL_VSC); + + type LL_VBC is array (1 .. 16) of unsigned_char; + for LL_VBC'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VBC, "vector_type"); + pragma Suppress (All_Checks, LL_VBC); + + --------------------------- + -- short Core Components -- + --------------------------- + + type LL_VUS is array (1 .. 8) of unsigned_short; + for LL_VUS'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VUS, "vector_type"); + pragma Suppress (All_Checks, LL_VUS); + + type LL_VSS is array (1 .. 8) of signed_short; + for LL_VSS'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VSS, "vector_type"); + pragma Suppress (All_Checks, LL_VSS); + + type LL_VBS is array (1 .. 8) of unsigned_short; + for LL_VBS'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VBS, "vector_type"); + pragma Suppress (All_Checks, LL_VBS); + + ------------------------- + -- int Core Components -- + ------------------------- + + type LL_VUI is array (1 .. 4) of unsigned_int; + for LL_VUI'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VUI, "vector_type"); + pragma Suppress (All_Checks, LL_VUI); + + type LL_VSI is array (1 .. 4) of signed_int; + for LL_VSI'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VSI, "vector_type"); + pragma Suppress (All_Checks, LL_VSI); + + type LL_VBI is array (1 .. 4) of unsigned_int; + for LL_VBI'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VBI, "vector_type"); + pragma Suppress (All_Checks, LL_VBI); + + --------------------------- + -- Float Core Components -- + --------------------------- + + type LL_VF is array (1 .. 4) of Float; + for LL_VF'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VF, "vector_type"); + pragma Suppress (All_Checks, LL_VF); + + --------------------------- + -- pixel Core Components -- + --------------------------- + + type LL_VP is array (1 .. 8) of pixel; + for LL_VP'Alignment use VECTOR_ALIGNMENT; + pragma Machine_Attribute (LL_VP, "vector_type"); + pragma Suppress (All_Checks, LL_VP); + + ------------------------------------ + -- Low-level Functional Interface -- + ------------------------------------ + + -- The functions we have to expose here are exactly those for which + -- GCC builtins are available. Calls to these functions will be turned + -- into real AltiVec instructions by the GCC back-end. + + pragma Convention_Identifier (LL_Altivec, Intrinsic); + + pragma Import (LL_Altivec, dss, "__builtin_altivec_dss"); + pragma Import (LL_Altivec, dssall, "__builtin_altivec_dssall"); + pragma Import (LL_Altivec, dst, "__builtin_altivec_dst"); + pragma Import (LL_Altivec, dstst, "__builtin_altivec_dstst"); + pragma Import (LL_Altivec, dststt, "__builtin_altivec_dststt"); + pragma Import (LL_Altivec, dstt, "__builtin_altivec_dstt"); + pragma Import (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr"); + pragma Import (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr"); + pragma Import (LL_Altivec, stvebx, "__builtin_altivec_stvebx"); + pragma Import (LL_Altivec, stvehx, "__builtin_altivec_stvehx"); + pragma Import (LL_Altivec, stvewx, "__builtin_altivec_stvewx"); + pragma Import (LL_Altivec, stvx, "__builtin_altivec_stvx"); + pragma Import (LL_Altivec, stvxl, "__builtin_altivec_stvxl"); + pragma Import (LL_Altivec, lvebx, "__builtin_altivec_lvebx"); + pragma Import (LL_Altivec, lvehx, "__builtin_altivec_lvehx"); + pragma Import (LL_Altivec, lvewx, "__builtin_altivec_lvewx"); + pragma Import (LL_Altivec, lvx, "__builtin_altivec_lvx"); + pragma Import (LL_Altivec, lvxl, "__builtin_altivec_lvxl"); + pragma Import (LL_Altivec, lvsl, "__builtin_altivec_lvsl"); + pragma Import (LL_Altivec, lvsr, "__builtin_altivec_lvsr"); + pragma Import (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi"); + pragma Import (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi"); + pragma Import (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si"); + pragma Import (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf"); + pragma Import (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi"); + pragma Import (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi"); + pragma Import (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si"); + pragma Import (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw"); + pragma Import (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp"); + pragma Import (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs"); + pragma Import (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs"); + pragma Import (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws"); + pragma Import (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm"); + pragma Import (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs"); + pragma Import (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm"); + pragma Import (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs"); + pragma Import (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm"); + pragma Import (LL_Altivec, vadduws, "__builtin_altivec_vadduws"); + pragma Import (LL_Altivec, vand, "__builtin_altivec_vand"); + pragma Import (LL_Altivec, vandc, "__builtin_altivec_vandc"); + pragma Import (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb"); + pragma Import (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh"); + pragma Import (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw"); + pragma Import (LL_Altivec, vavgub, "__builtin_altivec_vavgub"); + pragma Import (LL_Altivec, vavguh, "__builtin_altivec_vavguh"); + pragma Import (LL_Altivec, vavguw, "__builtin_altivec_vavguw"); + pragma Import (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx"); + pragma Import (LL_Altivec, vcfux, "__builtin_altivec_vcfux"); + pragma Import (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp"); + pragma Import (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp"); + pragma Import (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb"); + pragma Import (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh"); + pragma Import (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw"); + pragma Import (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp"); + pragma Import (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp"); + pragma Import (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb"); + pragma Import (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh"); + pragma Import (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw"); + pragma Import (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub"); + pragma Import (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh"); + pragma Import (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw"); + pragma Import (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs"); + pragma Import (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs"); + pragma Import (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp"); + pragma Import (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp"); + pragma Import (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp"); + pragma Import (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp"); + pragma Import (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb"); + pragma Import (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh"); + pragma Import (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw"); + pragma Import (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub"); + pragma Import (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh"); + pragma Import (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw"); + pragma Import (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs"); + pragma Import (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs"); + pragma Import (LL_Altivec, vminfp, "__builtin_altivec_vminfp"); + pragma Import (LL_Altivec, vminsb, "__builtin_altivec_vminsb"); + pragma Import (LL_Altivec, vminsh, "__builtin_altivec_vminsh"); + pragma Import (LL_Altivec, vminsw, "__builtin_altivec_vminsw"); + pragma Import (LL_Altivec, vminub, "__builtin_altivec_vminub"); + pragma Import (LL_Altivec, vminuh, "__builtin_altivec_vminuh"); + pragma Import (LL_Altivec, vminuw, "__builtin_altivec_vminuw"); + pragma Import (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm"); + pragma Import (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb"); + pragma Import (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh"); + pragma Import (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw"); + pragma Import (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb"); + pragma Import (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh"); + pragma Import (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw"); + pragma Import (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm"); + pragma Import (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm"); + pragma Import (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs"); + pragma Import (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm"); + pragma Import (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm"); + pragma Import (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs"); + pragma Import (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb"); + pragma Import (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh"); + pragma Import (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub"); + pragma Import (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh"); + pragma Import (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb"); + pragma Import (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh"); + pragma Import (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub"); + pragma Import (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh"); + pragma Import (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp"); + pragma Import (LL_Altivec, vnor, "__builtin_altivec_vnor"); + pragma Import (LL_Altivec, vxor, "__builtin_altivec_vxor"); + pragma Import (LL_Altivec, vor, "__builtin_altivec_vor"); + pragma Import (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si"); + pragma Import (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx"); + pragma Import (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss"); + pragma Import (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus"); + pragma Import (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss"); + pragma Import (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus"); + pragma Import (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum"); + pragma Import (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus"); + pragma Import (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum"); + pragma Import (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus"); + pragma Import (LL_Altivec, vrefp, "__builtin_altivec_vrefp"); + pragma Import (LL_Altivec, vrfim, "__builtin_altivec_vrfim"); + pragma Import (LL_Altivec, vrfin, "__builtin_altivec_vrfin"); + pragma Import (LL_Altivec, vrfip, "__builtin_altivec_vrfip"); + pragma Import (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz"); + pragma Import (LL_Altivec, vrlb, "__builtin_altivec_vrlb"); + pragma Import (LL_Altivec, vrlh, "__builtin_altivec_vrlh"); + pragma Import (LL_Altivec, vrlw, "__builtin_altivec_vrlw"); + pragma Import (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp"); + pragma Import (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si"); + pragma Import (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si"); + pragma Import (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi"); + pragma Import (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi"); + pragma Import (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf"); + pragma Import (LL_Altivec, vsl, "__builtin_altivec_vsl"); + pragma Import (LL_Altivec, vslb, "__builtin_altivec_vslb"); + pragma Import (LL_Altivec, vslh, "__builtin_altivec_vslh"); + pragma Import (LL_Altivec, vslo, "__builtin_altivec_vslo"); + pragma Import (LL_Altivec, vslw, "__builtin_altivec_vslw"); + pragma Import (LL_Altivec, vspltb, "__builtin_altivec_vspltb"); + pragma Import (LL_Altivec, vsplth, "__builtin_altivec_vsplth"); + pragma Import (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb"); + pragma Import (LL_Altivec, vspltish, "__builtin_altivec_vspltish"); + pragma Import (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw"); + pragma Import (LL_Altivec, vspltw, "__builtin_altivec_vspltw"); + pragma Import (LL_Altivec, vsr, "__builtin_altivec_vsr"); + pragma Import (LL_Altivec, vsrab, "__builtin_altivec_vsrab"); + pragma Import (LL_Altivec, vsrah, "__builtin_altivec_vsrah"); + pragma Import (LL_Altivec, vsraw, "__builtin_altivec_vsraw"); + pragma Import (LL_Altivec, vsrb, "__builtin_altivec_vsrb"); + pragma Import (LL_Altivec, vsrh, "__builtin_altivec_vsrh"); + pragma Import (LL_Altivec, vsro, "__builtin_altivec_vsro"); + pragma Import (LL_Altivec, vsrw, "__builtin_altivec_vsrw"); + pragma Import (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw"); + pragma Import (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp"); + pragma Import (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs"); + pragma Import (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs"); + pragma Import (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws"); + pragma Import (LL_Altivec, vsububm, "__builtin_altivec_vsububm"); + pragma Import (LL_Altivec, vsububs, "__builtin_altivec_vsububs"); + pragma Import (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm"); + pragma Import (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs"); + pragma Import (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm"); + pragma Import (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws"); + pragma Import (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws"); + pragma Import (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs"); + pragma Import (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs"); + pragma Import (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs"); + pragma Import (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws"); + pragma Import (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx"); + pragma Import (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb"); + pragma Import (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh"); + pragma Import (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx"); + pragma Import (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb"); + pragma Import (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh"); + pragma Import (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p"); + pragma Import (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p"); + pragma Import (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p"); + pragma Import (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p"); + pragma Import (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p"); + pragma Import (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p"); + pragma Import (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p"); + pragma Import (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p"); + pragma Import (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p"); + pragma Import (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p"); + pragma Import (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p"); + pragma Import (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p"); + pragma Import (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p"); + +end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-alleve.adb b/gcc/ada/libgnat/g-alleve.adb new file mode 100644 index 0000000..faa3545 --- /dev/null +++ b/gcc/ada/libgnat/g-alleve.adb @@ -0,0 +1,4956 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- +-- -- +-- B o d y -- +-- (Soft Binding Version) -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- ??? What is exactly needed for the soft case is still a bit unclear on +-- some accounts. The expected functional equivalence with the Hard binding +-- might require tricky things to be done on some targets. + +-- Examples that come to mind are endianness variations or differences in the +-- base FP model while we need the operation results to be the same as what +-- the real AltiVec instructions would do on a PowerPC. + +with Ada.Numerics.Generic_Elementary_Functions; +with Interfaces; use Interfaces; +with System.Storage_Elements; use System.Storage_Elements; + +with GNAT.Altivec.Conversions; use GNAT.Altivec.Conversions; +with GNAT.Altivec.Low_Level_Interface; use GNAT.Altivec.Low_Level_Interface; + +package body GNAT.Altivec.Low_Level_Vectors is + + -- Pixel types. As defined in [PIM-2.1 Data types]: + -- A 16-bit pixel is 1/5/5/5; + -- A 32-bit pixel is 8/8/8/8. + -- We use the following records as an intermediate representation, to + -- ease computation. + + type Unsigned_1 is mod 2 ** 1; + type Unsigned_5 is mod 2 ** 5; + + type Pixel_16 is record + T : Unsigned_1; + R : Unsigned_5; + G : Unsigned_5; + B : Unsigned_5; + end record; + + type Pixel_32 is record + T : unsigned_char; + R : unsigned_char; + G : unsigned_char; + B : unsigned_char; + end record; + + -- Conversions to/from the pixel records to the integer types that are + -- actually stored into the pixel vectors: + + function To_Pixel (Source : unsigned_short) return Pixel_16; + function To_unsigned_short (Source : Pixel_16) return unsigned_short; + function To_Pixel (Source : unsigned_int) return Pixel_32; + function To_unsigned_int (Source : Pixel_32) return unsigned_int; + + package C_float_Operations is + new Ada.Numerics.Generic_Elementary_Functions (C_float); + + -- Model of the Vector Status and Control Register (VSCR), as + -- defined in [PIM-4.1 Vector Status and Control Register]: + + VSCR : unsigned_int; + + -- Positions of the flags in VSCR(0 .. 31): + + NJ_POS : constant := 15; + SAT_POS : constant := 31; + + -- To control overflows, integer operations are done on 64-bit types: + + SINT64_MIN : constant := -2 ** 63; + SINT64_MAX : constant := 2 ** 63 - 1; + UINT64_MAX : constant := 2 ** 64 - 1; + + type SI64 is range SINT64_MIN .. SINT64_MAX; + type UI64 is mod UINT64_MAX + 1; + + type F64 is digits 15 + range -16#0.FFFF_FFFF_FFFF_F8#E+256 .. 16#0.FFFF_FFFF_FFFF_F8#E+256; + + function Bits + (X : unsigned_int; + Low : Natural; + High : Natural) return unsigned_int; + + function Bits + (X : unsigned_short; + Low : Natural; + High : Natural) return unsigned_short; + + function Bits + (X : unsigned_char; + Low : Natural; + High : Natural) return unsigned_char; + + function Write_Bit + (X : unsigned_int; + Where : Natural; + Value : Unsigned_1) return unsigned_int; + + function Write_Bit + (X : unsigned_short; + Where : Natural; + Value : Unsigned_1) return unsigned_short; + + function Write_Bit + (X : unsigned_char; + Where : Natural; + Value : Unsigned_1) return unsigned_char; + + function NJ_Truncate (X : C_float) return C_float; + -- If NJ and A is a denormalized number, return zero + + function Bound_Align + (X : Integer_Address; + Y : Integer_Address) return Integer_Address; + -- [PIM-4.3 Notations and Conventions] + -- Align X in a y-byte boundary and return the result + + function Rnd_To_FP_Nearest (X : F64) return C_float; + -- [PIM-4.3 Notations and Conventions] + + function Rnd_To_FPI_Near (X : F64) return F64; + + function Rnd_To_FPI_Trunc (X : F64) return F64; + + function FP_Recip_Est (X : C_float) return C_float; + -- [PIM-4.3 Notations and Conventions] + -- 12-bit accurate floating-point estimate of 1/x + + function ROTL + (Value : unsigned_char; + Amount : Natural) return unsigned_char; + -- [PIM-4.3 Notations and Conventions] + -- Rotate left + + function ROTL + (Value : unsigned_short; + Amount : Natural) return unsigned_short; + + function ROTL + (Value : unsigned_int; + Amount : Natural) return unsigned_int; + + function Recip_SQRT_Est (X : C_float) return C_float; + + function Shift_Left + (Value : unsigned_char; + Amount : Natural) return unsigned_char; + -- [PIM-4.3 Notations and Conventions] + -- Shift left + + function Shift_Left + (Value : unsigned_short; + Amount : Natural) return unsigned_short; + + function Shift_Left + (Value : unsigned_int; + Amount : Natural) return unsigned_int; + + function Shift_Right + (Value : unsigned_char; + Amount : Natural) return unsigned_char; + -- [PIM-4.3 Notations and Conventions] + -- Shift Right + + function Shift_Right + (Value : unsigned_short; + Amount : Natural) return unsigned_short; + + function Shift_Right + (Value : unsigned_int; + Amount : Natural) return unsigned_int; + + Signed_Bool_False : constant := 0; + Signed_Bool_True : constant := -1; + + ------------------------------ + -- Signed_Operations (spec) -- + ------------------------------ + + generic + type Component_Type is range <>; + type Index_Type is range <>; + type Varray_Type is array (Index_Type) of Component_Type; + + package Signed_Operations is + + function Modular_Result (X : SI64) return Component_Type; + + function Saturate (X : SI64) return Component_Type; + + function Saturate (X : F64) return Component_Type; + + function Sign_Extend (X : c_int) return Component_Type; + -- [PIM-4.3 Notations and Conventions] + -- Sign-extend X + + function abs_vxi (A : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, abs_vxi); + + function abss_vxi (A : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, abss_vxi); + + function vaddsxs (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vaddsxs); + + function vavgsx (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vavgsx); + + function vcmpgtsx (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vcmpgtsx); + + function lvexx (A : c_long; B : c_ptr) return Varray_Type; + pragma Convention (LL_Altivec, lvexx); + + function vmaxsx (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vmaxsx); + + function vmrghx (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vmrghx); + + function vmrglx (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vmrglx); + + function vminsx (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vminsx); + + function vspltx (A : Varray_Type; B : c_int) return Varray_Type; + pragma Convention (LL_Altivec, vspltx); + + function vspltisx (A : c_int) return Varray_Type; + pragma Convention (LL_Altivec, vspltisx); + + type Bit_Operation is + access function + (Value : Component_Type; + Amount : Natural) return Component_Type; + + function vsrax + (A : Varray_Type; + B : Varray_Type; + Shift_Func : Bit_Operation) return Varray_Type; + + procedure stvexx (A : Varray_Type; B : c_int; C : c_ptr); + pragma Convention (LL_Altivec, stvexx); + + function vsubsxs (A : Varray_Type; B : Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vsubsxs); + + function Check_CR6 (A : c_int; D : Varray_Type) return c_int; + -- If D is the result of a vcmp operation and A the flag for + -- the kind of operation (e.g CR6_LT), check the predicate + -- that corresponds to this flag. + + end Signed_Operations; + + ------------------------------ + -- Signed_Operations (body) -- + ------------------------------ + + package body Signed_Operations is + + Bool_True : constant Component_Type := Signed_Bool_True; + Bool_False : constant Component_Type := Signed_Bool_False; + + Number_Of_Elements : constant Integer := + VECTOR_BIT / Component_Type'Size; + + -------------------- + -- Modular_Result -- + -------------------- + + function Modular_Result (X : SI64) return Component_Type is + D : Component_Type; + + begin + if X > 0 then + D := Component_Type (UI64 (X) + mod (UI64 (Component_Type'Last) + 1)); + else + D := Component_Type ((-(UI64 (-X) + mod (UI64 (Component_Type'Last) + 1)))); + end if; + + return D; + end Modular_Result; + + -------------- + -- Saturate -- + -------------- + + function Saturate (X : SI64) return Component_Type is + D : Component_Type; + + begin + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + D := Component_Type (SI64'Max + (SI64 (Component_Type'First), + SI64'Min + (SI64 (Component_Type'Last), + X))); + + if SI64 (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + function Saturate (X : F64) return Component_Type is + D : Component_Type; + + begin + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + D := Component_Type (F64'Max + (F64 (Component_Type'First), + F64'Min + (F64 (Component_Type'Last), + X))); + + if F64 (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + ----------------- + -- Sign_Extend -- + ----------------- + + function Sign_Extend (X : c_int) return Component_Type is + begin + -- X is usually a 5-bits literal. In the case of the simulator, + -- it is an integral parameter, so sign extension is straightforward. + + return Component_Type (X); + end Sign_Extend; + + ------------- + -- abs_vxi -- + ------------- + + function abs_vxi (A : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for K in Varray_Type'Range loop + D (K) := (if A (K) /= Component_Type'First + then abs (A (K)) else Component_Type'First); + end loop; + + return D; + end abs_vxi; + + -------------- + -- abss_vxi -- + -------------- + + function abss_vxi (A : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for K in Varray_Type'Range loop + D (K) := Saturate (abs (SI64 (A (K)))); + end loop; + + return D; + end abss_vxi; + + ------------- + -- vaddsxs -- + ------------- + + function vaddsxs (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := Saturate (SI64 (A (J)) + SI64 (B (J))); + end loop; + + return D; + end vaddsxs; + + ------------ + -- vavgsx -- + ------------ + + function vavgsx (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := Component_Type ((SI64 (A (J)) + SI64 (B (J)) + 1) / 2); + end loop; + + return D; + end vavgsx; + + -------------- + -- vcmpgtsx -- + -------------- + + function vcmpgtsx + (A : Varray_Type; + B : Varray_Type) return Varray_Type + is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := (if A (J) > B (J) then Bool_True else Bool_False); + end loop; + + return D; + end vcmpgtsx; + + ----------- + -- lvexx -- + ----------- + + function lvexx (A : c_long; B : c_ptr) return Varray_Type is + D : Varray_Type; + S : Integer; + EA : Integer_Address; + J : Index_Type; + + begin + S := 16 / Number_Of_Elements; + EA := Bound_Align (Integer_Address (A) + To_Integer (B), + Integer_Address (S)); + J := Index_Type (((EA mod 16) / Integer_Address (S)) + + Integer_Address (Index_Type'First)); + + declare + Component : Component_Type; + for Component'Address use To_Address (EA); + begin + D (J) := Component; + end; + + return D; + end lvexx; + + ------------ + -- vmaxsx -- + ------------ + + function vmaxsx (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := (if A (J) > B (J) then A (J) else B (J)); + end loop; + + return D; + end vmaxsx; + + ------------ + -- vmrghx -- + ------------ + + function vmrghx (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + Offset : constant Integer := Integer (Index_Type'First); + M : constant Integer := Number_Of_Elements / 2; + + begin + for J in 0 .. M - 1 loop + D (Index_Type (2 * J + Offset)) := A (Index_Type (J + Offset)); + D (Index_Type (2 * J + Offset + 1)) := B (Index_Type (J + Offset)); + end loop; + + return D; + end vmrghx; + + ------------ + -- vmrglx -- + ------------ + + function vmrglx (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + Offset : constant Integer := Integer (Index_Type'First); + M : constant Integer := Number_Of_Elements / 2; + + begin + for J in 0 .. M - 1 loop + D (Index_Type (2 * J + Offset)) := A (Index_Type (J + Offset + M)); + D (Index_Type (2 * J + Offset + 1)) := + B (Index_Type (J + Offset + M)); + end loop; + + return D; + end vmrglx; + + ------------ + -- vminsx -- + ------------ + + function vminsx (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := (if A (J) < B (J) then A (J) else B (J)); + end loop; + + return D; + end vminsx; + + ------------ + -- vspltx -- + ------------ + + function vspltx (A : Varray_Type; B : c_int) return Varray_Type is + J : constant Integer := + Integer (B) mod Number_Of_Elements + + Integer (Varray_Type'First); + D : Varray_Type; + + begin + for K in Varray_Type'Range loop + D (K) := A (Index_Type (J)); + end loop; + + return D; + end vspltx; + + -------------- + -- vspltisx -- + -------------- + + function vspltisx (A : c_int) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := Sign_Extend (A); + end loop; + + return D; + end vspltisx; + + ----------- + -- vsrax -- + ----------- + + function vsrax + (A : Varray_Type; + B : Varray_Type; + Shift_Func : Bit_Operation) return Varray_Type + is + D : Varray_Type; + S : constant Component_Type := + Component_Type (128 / Number_Of_Elements); + + begin + for J in Varray_Type'Range loop + D (J) := Shift_Func (A (J), Natural (B (J) mod S)); + end loop; + + return D; + end vsrax; + + ------------ + -- stvexx -- + ------------ + + procedure stvexx (A : Varray_Type; B : c_int; C : c_ptr) is + S : Integer; + EA : Integer_Address; + J : Index_Type; + + begin + S := 16 / Number_Of_Elements; + EA := Bound_Align (Integer_Address (B) + To_Integer (C), + Integer_Address (S)); + J := Index_Type ((EA mod 16) / Integer_Address (S) + + Integer_Address (Index_Type'First)); + + declare + Component : Component_Type; + for Component'Address use To_Address (EA); + begin + Component := A (J); + end; + end stvexx; + + ------------- + -- vsubsxs -- + ------------- + + function vsubsxs (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := Saturate (SI64 (A (J)) - SI64 (B (J))); + end loop; + + return D; + end vsubsxs; + + --------------- + -- Check_CR6 -- + --------------- + + function Check_CR6 (A : c_int; D : Varray_Type) return c_int is + All_Element : Boolean := True; + Any_Element : Boolean := False; + + begin + for J in Varray_Type'Range loop + All_Element := All_Element and then (D (J) = Bool_True); + Any_Element := Any_Element or else (D (J) = Bool_True); + end loop; + + if A = CR6_LT then + if All_Element then + return 1; + else + return 0; + end if; + + elsif A = CR6_EQ then + if not Any_Element then + return 1; + else + return 0; + end if; + + elsif A = CR6_EQ_REV then + if Any_Element then + return 1; + else + return 0; + end if; + + elsif A = CR6_LT_REV then + if not All_Element then + return 1; + else + return 0; + end if; + end if; + + return 0; + end Check_CR6; + + end Signed_Operations; + + -------------------------------- + -- Unsigned_Operations (spec) -- + -------------------------------- + + generic + type Component_Type is mod <>; + type Index_Type is range <>; + type Varray_Type is array (Index_Type) of Component_Type; + + package Unsigned_Operations is + + function Bits + (X : Component_Type; + Low : Natural; + High : Natural) return Component_Type; + -- Return X [Low:High] as defined in [PIM-4.3 Notations and Conventions] + -- using big endian bit ordering. + + function Write_Bit + (X : Component_Type; + Where : Natural; + Value : Unsigned_1) return Component_Type; + -- Write Value into X[Where:Where] (if it fits in) and return the result + -- (big endian bit ordering). + + function Modular_Result (X : UI64) return Component_Type; + + function Saturate (X : UI64) return Component_Type; + + function Saturate (X : F64) return Component_Type; + + function Saturate (X : SI64) return Component_Type; + + function vadduxm (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function vadduxs (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function vavgux (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function vcmpequx (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function vcmpgtux (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function vmaxux (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function vminux (A : Varray_Type; B : Varray_Type) return Varray_Type; + + type Bit_Operation is + access function + (Value : Component_Type; + Amount : Natural) return Component_Type; + + function vrlx + (A : Varray_Type; + B : Varray_Type; + ROTL : Bit_Operation) return Varray_Type; + + function vsxx + (A : Varray_Type; + B : Varray_Type; + Shift_Func : Bit_Operation) return Varray_Type; + -- Vector shift (left or right, depending on Shift_Func) + + function vsubuxm (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function vsubuxs (A : Varray_Type; B : Varray_Type) return Varray_Type; + + function Check_CR6 (A : c_int; D : Varray_Type) return c_int; + -- If D is the result of a vcmp operation and A the flag for + -- the kind of operation (e.g CR6_LT), check the predicate + -- that corresponds to this flag. + + end Unsigned_Operations; + + -------------------------------- + -- Unsigned_Operations (body) -- + -------------------------------- + + package body Unsigned_Operations is + + Number_Of_Elements : constant Integer := + VECTOR_BIT / Component_Type'Size; + + Bool_True : constant Component_Type := Component_Type'Last; + Bool_False : constant Component_Type := 0; + + -------------------- + -- Modular_Result -- + -------------------- + + function Modular_Result (X : UI64) return Component_Type is + D : Component_Type; + begin + D := Component_Type (X mod (UI64 (Component_Type'Last) + 1)); + return D; + end Modular_Result; + + -------------- + -- Saturate -- + -------------- + + function Saturate (X : UI64) return Component_Type is + D : Component_Type; + + begin + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + D := Component_Type (UI64'Max + (UI64 (Component_Type'First), + UI64'Min + (UI64 (Component_Type'Last), + X))); + + if UI64 (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + function Saturate (X : SI64) return Component_Type is + D : Component_Type; + + begin + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + D := Component_Type (SI64'Max + (SI64 (Component_Type'First), + SI64'Min + (SI64 (Component_Type'Last), + X))); + + if SI64 (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + function Saturate (X : F64) return Component_Type is + D : Component_Type; + + begin + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + D := Component_Type (F64'Max + (F64 (Component_Type'First), + F64'Min + (F64 (Component_Type'Last), + X))); + + if F64 (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + ---------- + -- Bits -- + ---------- + + function Bits + (X : Component_Type; + Low : Natural; + High : Natural) return Component_Type + is + Mask : Component_Type := 0; + + -- The Altivec ABI uses a big endian bit ordering, and we are + -- using little endian bit ordering for extracting bits: + + Low_LE : constant Natural := Component_Type'Size - 1 - High; + High_LE : constant Natural := Component_Type'Size - 1 - Low; + + begin + pragma Assert (Low <= Component_Type'Size); + pragma Assert (High <= Component_Type'Size); + + for J in Low_LE .. High_LE loop + Mask := Mask or 2 ** J; + end loop; + + return (X and Mask) / 2 ** Low_LE; + end Bits; + + --------------- + -- Write_Bit -- + --------------- + + function Write_Bit + (X : Component_Type; + Where : Natural; + Value : Unsigned_1) return Component_Type + is + Result : Component_Type := 0; + + -- The Altivec ABI uses a big endian bit ordering, and we are + -- using little endian bit ordering for extracting bits: + + Where_LE : constant Natural := Component_Type'Size - 1 - Where; + + begin + pragma Assert (Where < Component_Type'Size); + + case Value is + when 1 => + Result := X or 2 ** Where_LE; + when 0 => + Result := X and not (2 ** Where_LE); + end case; + + return Result; + end Write_Bit; + + ------------- + -- vadduxm -- + ------------- + + function vadduxm (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := A (J) + B (J); + end loop; + + return D; + end vadduxm; + + ------------- + -- vadduxs -- + ------------- + + function vadduxs (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := Saturate (UI64 (A (J)) + UI64 (B (J))); + end loop; + + return D; + end vadduxs; + + ------------ + -- vavgux -- + ------------ + + function vavgux (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := Component_Type ((UI64 (A (J)) + UI64 (B (J)) + 1) / 2); + end loop; + + return D; + end vavgux; + + -------------- + -- vcmpequx -- + -------------- + + function vcmpequx + (A : Varray_Type; + B : Varray_Type) return Varray_Type + is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := (if A (J) = B (J) then Bool_True else Bool_False); + end loop; + + return D; + end vcmpequx; + + -------------- + -- vcmpgtux -- + -------------- + + function vcmpgtux + (A : Varray_Type; + B : Varray_Type) return Varray_Type + is + D : Varray_Type; + begin + for J in Varray_Type'Range loop + D (J) := (if A (J) > B (J) then Bool_True else Bool_False); + end loop; + + return D; + end vcmpgtux; + + ------------ + -- vmaxux -- + ------------ + + function vmaxux (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := (if A (J) > B (J) then A (J) else B (J)); + end loop; + + return D; + end vmaxux; + + ------------ + -- vminux -- + ------------ + + function vminux (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := (if A (J) < B (J) then A (J) else B (J)); + end loop; + + return D; + end vminux; + + ---------- + -- vrlx -- + ---------- + + function vrlx + (A : Varray_Type; + B : Varray_Type; + ROTL : Bit_Operation) return Varray_Type + is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := ROTL (A (J), Natural (B (J))); + end loop; + + return D; + end vrlx; + + ---------- + -- vsxx -- + ---------- + + function vsxx + (A : Varray_Type; + B : Varray_Type; + Shift_Func : Bit_Operation) return Varray_Type + is + D : Varray_Type; + S : constant Component_Type := + Component_Type (128 / Number_Of_Elements); + + begin + for J in Varray_Type'Range loop + D (J) := Shift_Func (A (J), Natural (B (J) mod S)); + end loop; + + return D; + end vsxx; + + ------------- + -- vsubuxm -- + ------------- + + function vsubuxm (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := A (J) - B (J); + end loop; + + return D; + end vsubuxm; + + ------------- + -- vsubuxs -- + ------------- + + function vsubuxs (A : Varray_Type; B : Varray_Type) return Varray_Type is + D : Varray_Type; + + begin + for J in Varray_Type'Range loop + D (J) := Saturate (SI64 (A (J)) - SI64 (B (J))); + end loop; + + return D; + end vsubuxs; + + --------------- + -- Check_CR6 -- + --------------- + + function Check_CR6 (A : c_int; D : Varray_Type) return c_int is + All_Element : Boolean := True; + Any_Element : Boolean := False; + + begin + for J in Varray_Type'Range loop + All_Element := All_Element and then (D (J) = Bool_True); + Any_Element := Any_Element or else (D (J) = Bool_True); + end loop; + + if A = CR6_LT then + if All_Element then + return 1; + else + return 0; + end if; + + elsif A = CR6_EQ then + if not Any_Element then + return 1; + else + return 0; + end if; + + elsif A = CR6_EQ_REV then + if Any_Element then + return 1; + else + return 0; + end if; + + elsif A = CR6_LT_REV then + if not All_Element then + return 1; + else + return 0; + end if; + end if; + + return 0; + end Check_CR6; + + end Unsigned_Operations; + + -------------------------------------- + -- Signed_Merging_Operations (spec) -- + -------------------------------------- + + generic + type Component_Type is range <>; + type Index_Type is range <>; + type Varray_Type is array (Index_Type) of Component_Type; + type Double_Component_Type is range <>; + type Double_Index_Type is range <>; + type Double_Varray_Type is array (Double_Index_Type) + of Double_Component_Type; + + package Signed_Merging_Operations is + + pragma Assert (Integer (Varray_Type'First) + = Integer (Double_Varray_Type'First)); + pragma Assert (Varray_Type'Length = 2 * Double_Varray_Type'Length); + pragma Assert (2 * Component_Type'Size = Double_Component_Type'Size); + + function Saturate + (X : Double_Component_Type) return Component_Type; + + function vmulxsx + (Use_Even_Components : Boolean; + A : Varray_Type; + B : Varray_Type) return Double_Varray_Type; + + function vpksxss + (A : Double_Varray_Type; + B : Double_Varray_Type) return Varray_Type; + pragma Convention (LL_Altivec, vpksxss); + + function vupkxsx + (A : Varray_Type; + Offset : Natural) return Double_Varray_Type; + + end Signed_Merging_Operations; + + -------------------------------------- + -- Signed_Merging_Operations (body) -- + -------------------------------------- + + package body Signed_Merging_Operations is + + -------------- + -- Saturate -- + -------------- + + function Saturate + (X : Double_Component_Type) return Component_Type + is + D : Component_Type; + + begin + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + D := Component_Type (Double_Component_Type'Max + (Double_Component_Type (Component_Type'First), + Double_Component_Type'Min + (Double_Component_Type (Component_Type'Last), + X))); + + if Double_Component_Type (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + ------------- + -- vmulsxs -- + ------------- + + function vmulxsx + (Use_Even_Components : Boolean; + A : Varray_Type; + B : Varray_Type) return Double_Varray_Type + is + Double_Offset : Double_Index_Type; + Offset : Index_Type; + D : Double_Varray_Type; + N : constant Integer := + Integer (Double_Index_Type'Last) + - Integer (Double_Index_Type'First) + 1; + + begin + + for J in 0 .. N - 1 loop + Offset := + Index_Type ((if Use_Even_Components then 2 * J else 2 * J + 1) + + Integer (Index_Type'First)); + + Double_Offset := + Double_Index_Type (J + Integer (Double_Index_Type'First)); + D (Double_Offset) := + Double_Component_Type (A (Offset)) * + Double_Component_Type (B (Offset)); + end loop; + + return D; + end vmulxsx; + + ------------- + -- vpksxss -- + ------------- + + function vpksxss + (A : Double_Varray_Type; + B : Double_Varray_Type) return Varray_Type + is + N : constant Index_Type := + Index_Type (Double_Index_Type'Last); + D : Varray_Type; + Offset : Index_Type; + Double_Offset : Double_Index_Type; + + begin + for J in 0 .. N - 1 loop + Offset := Index_Type (Integer (J) + Integer (Index_Type'First)); + Double_Offset := + Double_Index_Type (Integer (J) + + Integer (Double_Index_Type'First)); + D (Offset) := Saturate (A (Double_Offset)); + D (Offset + N) := Saturate (B (Double_Offset)); + end loop; + + return D; + end vpksxss; + + ------------- + -- vupkxsx -- + ------------- + + function vupkxsx + (A : Varray_Type; + Offset : Natural) return Double_Varray_Type + is + K : Index_Type; + D : Double_Varray_Type; + + begin + for J in Double_Varray_Type'Range loop + K := Index_Type (Integer (J) + - Integer (Double_Index_Type'First) + + Integer (Index_Type'First) + + Offset); + D (J) := Double_Component_Type (A (K)); + end loop; + + return D; + end vupkxsx; + + end Signed_Merging_Operations; + + ---------------------------------------- + -- Unsigned_Merging_Operations (spec) -- + ---------------------------------------- + + generic + type Component_Type is mod <>; + type Index_Type is range <>; + type Varray_Type is array (Index_Type) of Component_Type; + type Double_Component_Type is mod <>; + type Double_Index_Type is range <>; + type Double_Varray_Type is array (Double_Index_Type) + of Double_Component_Type; + + package Unsigned_Merging_Operations is + + pragma Assert (Integer (Varray_Type'First) + = Integer (Double_Varray_Type'First)); + pragma Assert (Varray_Type'Length = 2 * Double_Varray_Type'Length); + pragma Assert (2 * Component_Type'Size = Double_Component_Type'Size); + + function UI_To_UI_Mod + (X : Double_Component_Type; + Y : Natural) return Component_Type; + + function Saturate (X : Double_Component_Type) return Component_Type; + + function vmulxux + (Use_Even_Components : Boolean; + A : Varray_Type; + B : Varray_Type) return Double_Varray_Type; + + function vpkuxum + (A : Double_Varray_Type; + B : Double_Varray_Type) return Varray_Type; + + function vpkuxus + (A : Double_Varray_Type; + B : Double_Varray_Type) return Varray_Type; + + end Unsigned_Merging_Operations; + + ---------------------------------------- + -- Unsigned_Merging_Operations (body) -- + ---------------------------------------- + + package body Unsigned_Merging_Operations is + + ------------------ + -- UI_To_UI_Mod -- + ------------------ + + function UI_To_UI_Mod + (X : Double_Component_Type; + Y : Natural) return Component_Type is + Z : Component_Type; + begin + Z := Component_Type (X mod 2 ** Y); + return Z; + end UI_To_UI_Mod; + + -------------- + -- Saturate -- + -------------- + + function Saturate (X : Double_Component_Type) return Component_Type is + D : Component_Type; + + begin + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + D := Component_Type (Double_Component_Type'Max + (Double_Component_Type (Component_Type'First), + Double_Component_Type'Min + (Double_Component_Type (Component_Type'Last), + X))); + + if Double_Component_Type (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + ------------- + -- vmulxux -- + ------------- + + function vmulxux + (Use_Even_Components : Boolean; + A : Varray_Type; + B : Varray_Type) return Double_Varray_Type + is + Double_Offset : Double_Index_Type; + Offset : Index_Type; + D : Double_Varray_Type; + N : constant Integer := + Integer (Double_Index_Type'Last) + - Integer (Double_Index_Type'First) + 1; + + begin + for J in 0 .. N - 1 loop + Offset := + Index_Type ((if Use_Even_Components then 2 * J else 2 * J + 1) + + Integer (Index_Type'First)); + + Double_Offset := + Double_Index_Type (J + Integer (Double_Index_Type'First)); + D (Double_Offset) := + Double_Component_Type (A (Offset)) * + Double_Component_Type (B (Offset)); + end loop; + + return D; + end vmulxux; + + ------------- + -- vpkuxum -- + ------------- + + function vpkuxum + (A : Double_Varray_Type; + B : Double_Varray_Type) return Varray_Type + is + S : constant Natural := + Double_Component_Type'Size / 2; + N : constant Index_Type := + Index_Type (Double_Index_Type'Last); + D : Varray_Type; + Offset : Index_Type; + Double_Offset : Double_Index_Type; + + begin + for J in 0 .. N - 1 loop + Offset := Index_Type (Integer (J) + Integer (Index_Type'First)); + Double_Offset := + Double_Index_Type (Integer (J) + + Integer (Double_Index_Type'First)); + D (Offset) := UI_To_UI_Mod (A (Double_Offset), S); + D (Offset + N) := UI_To_UI_Mod (B (Double_Offset), S); + end loop; + + return D; + end vpkuxum; + + ------------- + -- vpkuxus -- + ------------- + + function vpkuxus + (A : Double_Varray_Type; + B : Double_Varray_Type) return Varray_Type + is + N : constant Index_Type := + Index_Type (Double_Index_Type'Last); + D : Varray_Type; + Offset : Index_Type; + Double_Offset : Double_Index_Type; + + begin + for J in 0 .. N - 1 loop + Offset := Index_Type (Integer (J) + Integer (Index_Type'First)); + Double_Offset := + Double_Index_Type (Integer (J) + + Integer (Double_Index_Type'First)); + D (Offset) := Saturate (A (Double_Offset)); + D (Offset + N) := Saturate (B (Double_Offset)); + end loop; + + return D; + end vpkuxus; + + end Unsigned_Merging_Operations; + + package LL_VSC_Operations is + new Signed_Operations (signed_char, + Vchar_Range, + Varray_signed_char); + + package LL_VSS_Operations is + new Signed_Operations (signed_short, + Vshort_Range, + Varray_signed_short); + + package LL_VSI_Operations is + new Signed_Operations (signed_int, + Vint_Range, + Varray_signed_int); + + package LL_VUC_Operations is + new Unsigned_Operations (unsigned_char, + Vchar_Range, + Varray_unsigned_char); + + package LL_VUS_Operations is + new Unsigned_Operations (unsigned_short, + Vshort_Range, + Varray_unsigned_short); + + package LL_VUI_Operations is + new Unsigned_Operations (unsigned_int, + Vint_Range, + Varray_unsigned_int); + + package LL_VSC_LL_VSS_Operations is + new Signed_Merging_Operations (signed_char, + Vchar_Range, + Varray_signed_char, + signed_short, + Vshort_Range, + Varray_signed_short); + + package LL_VSS_LL_VSI_Operations is + new Signed_Merging_Operations (signed_short, + Vshort_Range, + Varray_signed_short, + signed_int, + Vint_Range, + Varray_signed_int); + + package LL_VUC_LL_VUS_Operations is + new Unsigned_Merging_Operations (unsigned_char, + Vchar_Range, + Varray_unsigned_char, + unsigned_short, + Vshort_Range, + Varray_unsigned_short); + + package LL_VUS_LL_VUI_Operations is + new Unsigned_Merging_Operations (unsigned_short, + Vshort_Range, + Varray_unsigned_short, + unsigned_int, + Vint_Range, + Varray_unsigned_int); + + ---------- + -- Bits -- + ---------- + + function Bits + (X : unsigned_int; + Low : Natural; + High : Natural) return unsigned_int renames LL_VUI_Operations.Bits; + + function Bits + (X : unsigned_short; + Low : Natural; + High : Natural) return unsigned_short renames LL_VUS_Operations.Bits; + + function Bits + (X : unsigned_char; + Low : Natural; + High : Natural) return unsigned_char renames LL_VUC_Operations.Bits; + + --------------- + -- Write_Bit -- + --------------- + + function Write_Bit + (X : unsigned_int; + Where : Natural; + Value : Unsigned_1) return unsigned_int + renames LL_VUI_Operations.Write_Bit; + + function Write_Bit + (X : unsigned_short; + Where : Natural; + Value : Unsigned_1) return unsigned_short + renames LL_VUS_Operations.Write_Bit; + + function Write_Bit + (X : unsigned_char; + Where : Natural; + Value : Unsigned_1) return unsigned_char + renames LL_VUC_Operations.Write_Bit; + + ----------------- + -- Bound_Align -- + ----------------- + + function Bound_Align + (X : Integer_Address; + Y : Integer_Address) return Integer_Address + is + D : Integer_Address; + begin + D := X - X mod Y; + return D; + end Bound_Align; + + ----------------- + -- NJ_Truncate -- + ----------------- + + function NJ_Truncate (X : C_float) return C_float is + D : C_float; + + begin + if (Bits (VSCR, NJ_POS, NJ_POS) = 1) + and then abs (X) < 2.0 ** (-126) + then + D := (if X < 0.0 then -0.0 else +0.0); + else + D := X; + end if; + + return D; + end NJ_Truncate; + + ----------------------- + -- Rnd_To_FP_Nearest -- + ----------------------- + + function Rnd_To_FP_Nearest (X : F64) return C_float is + begin + return C_float (X); + end Rnd_To_FP_Nearest; + + --------------------- + -- Rnd_To_FPI_Near -- + --------------------- + + function Rnd_To_FPI_Near (X : F64) return F64 is + Result : F64; + Ceiling : F64; + + begin + Result := F64 (SI64 (X)); + + if (F64'Ceiling (X) - X) = (X + 1.0 - F64'Ceiling (X)) then + + -- Round to even + + Ceiling := F64'Ceiling (X); + Result := + (if Rnd_To_FPI_Trunc (Ceiling / 2.0) * 2.0 = Ceiling + then Ceiling else Ceiling - 1.0); + end if; + + return Result; + end Rnd_To_FPI_Near; + + ---------------------- + -- Rnd_To_FPI_Trunc -- + ---------------------- + + function Rnd_To_FPI_Trunc (X : F64) return F64 is + Result : F64; + + begin + Result := F64'Ceiling (X); + + -- Rnd_To_FPI_Trunc rounds toward 0, 'Ceiling rounds toward + -- +Infinity + + if X > 0.0 + and then Result /= X + then + Result := Result - 1.0; + end if; + + return Result; + end Rnd_To_FPI_Trunc; + + ------------------ + -- FP_Recip_Est -- + ------------------ + + function FP_Recip_Est (X : C_float) return C_float is + begin + -- ??? [PIM-4.4 vec_re] "For result that are not +0, -0, +Inf, + -- -Inf, or QNaN, the estimate has a relative error no greater + -- than one part in 4096, that is: + -- Abs ((estimate - 1 / x) / (1 / x)) < = 1/4096" + + return NJ_Truncate (1.0 / NJ_Truncate (X)); + end FP_Recip_Est; + + ---------- + -- ROTL -- + ---------- + + function ROTL + (Value : unsigned_char; + Amount : Natural) return unsigned_char + is + Result : Unsigned_8; + begin + Result := Rotate_Left (Unsigned_8 (Value), Amount); + return unsigned_char (Result); + end ROTL; + + function ROTL + (Value : unsigned_short; + Amount : Natural) return unsigned_short + is + Result : Unsigned_16; + begin + Result := Rotate_Left (Unsigned_16 (Value), Amount); + return unsigned_short (Result); + end ROTL; + + function ROTL + (Value : unsigned_int; + Amount : Natural) return unsigned_int + is + Result : Unsigned_32; + begin + Result := Rotate_Left (Unsigned_32 (Value), Amount); + return unsigned_int (Result); + end ROTL; + + -------------------- + -- Recip_SQRT_Est -- + -------------------- + + function Recip_SQRT_Est (X : C_float) return C_float is + Result : C_float; + + begin + -- ??? + -- [PIM-4.4 vec_rsqrte] the estimate has a relative error in precision + -- no greater than one part in 4096, that is: + -- abs ((estimate - 1 / sqrt (x)) / (1 / sqrt (x)) <= 1 / 4096" + + Result := 1.0 / NJ_Truncate (C_float_Operations.Sqrt (NJ_Truncate (X))); + return NJ_Truncate (Result); + end Recip_SQRT_Est; + + ---------------- + -- Shift_Left -- + ---------------- + + function Shift_Left + (Value : unsigned_char; + Amount : Natural) return unsigned_char + is + Result : Unsigned_8; + begin + Result := Shift_Left (Unsigned_8 (Value), Amount); + return unsigned_char (Result); + end Shift_Left; + + function Shift_Left + (Value : unsigned_short; + Amount : Natural) return unsigned_short + is + Result : Unsigned_16; + begin + Result := Shift_Left (Unsigned_16 (Value), Amount); + return unsigned_short (Result); + end Shift_Left; + + function Shift_Left + (Value : unsigned_int; + Amount : Natural) return unsigned_int + is + Result : Unsigned_32; + begin + Result := Shift_Left (Unsigned_32 (Value), Amount); + return unsigned_int (Result); + end Shift_Left; + + ----------------- + -- Shift_Right -- + ----------------- + + function Shift_Right + (Value : unsigned_char; + Amount : Natural) return unsigned_char + is + Result : Unsigned_8; + begin + Result := Shift_Right (Unsigned_8 (Value), Amount); + return unsigned_char (Result); + end Shift_Right; + + function Shift_Right + (Value : unsigned_short; + Amount : Natural) return unsigned_short + is + Result : Unsigned_16; + begin + Result := Shift_Right (Unsigned_16 (Value), Amount); + return unsigned_short (Result); + end Shift_Right; + + function Shift_Right + (Value : unsigned_int; + Amount : Natural) return unsigned_int + is + Result : Unsigned_32; + begin + Result := Shift_Right (Unsigned_32 (Value), Amount); + return unsigned_int (Result); + end Shift_Right; + + ------------------- + -- Shift_Right_A -- + ------------------- + + generic + type Signed_Type is range <>; + type Unsigned_Type is mod <>; + with function Shift_Right (Value : Unsigned_Type; Amount : Natural) + return Unsigned_Type; + function Shift_Right_Arithmetic + (Value : Signed_Type; + Amount : Natural) return Signed_Type; + + function Shift_Right_Arithmetic + (Value : Signed_Type; + Amount : Natural) return Signed_Type + is + begin + if Value > 0 then + return Signed_Type (Shift_Right (Unsigned_Type (Value), Amount)); + else + return -Signed_Type (Shift_Right (Unsigned_Type (-Value - 1), Amount) + + 1); + end if; + end Shift_Right_Arithmetic; + + function Shift_Right_A is new Shift_Right_Arithmetic (signed_int, + Unsigned_32, + Shift_Right); + + function Shift_Right_A is new Shift_Right_Arithmetic (signed_short, + Unsigned_16, + Shift_Right); + + function Shift_Right_A is new Shift_Right_Arithmetic (signed_char, + Unsigned_8, + Shift_Right); + -------------- + -- To_Pixel -- + -------------- + + function To_Pixel (Source : unsigned_short) return Pixel_16 is + + -- This conversion should not depend on the host endianness; + -- therefore, we cannot use an unchecked conversion. + + Target : Pixel_16; + + begin + Target.T := Unsigned_1 (Bits (Source, 0, 0) mod 2 ** 1); + Target.R := Unsigned_5 (Bits (Source, 1, 5) mod 2 ** 5); + Target.G := Unsigned_5 (Bits (Source, 6, 10) mod 2 ** 5); + Target.B := Unsigned_5 (Bits (Source, 11, 15) mod 2 ** 5); + return Target; + end To_Pixel; + + function To_Pixel (Source : unsigned_int) return Pixel_32 is + + -- This conversion should not depend on the host endianness; + -- therefore, we cannot use an unchecked conversion. + + Target : Pixel_32; + + begin + Target.T := unsigned_char (Bits (Source, 0, 7)); + Target.R := unsigned_char (Bits (Source, 8, 15)); + Target.G := unsigned_char (Bits (Source, 16, 23)); + Target.B := unsigned_char (Bits (Source, 24, 31)); + return Target; + end To_Pixel; + + --------------------- + -- To_unsigned_int -- + --------------------- + + function To_unsigned_int (Source : Pixel_32) return unsigned_int is + + -- This conversion should not depend on the host endianness; + -- therefore, we cannot use an unchecked conversion. + -- It should also be the same result, value-wise, on two hosts + -- with the same endianness. + + Target : unsigned_int := 0; + + begin + -- In big endian bit ordering, Pixel_32 looks like: + -- ------------------------------------- + -- | T | R | G | B | + -- ------------------------------------- + -- 0 (MSB) 7 15 23 32 + -- + -- Sizes of the components: (8/8/8/8) + -- + Target := Target or unsigned_int (Source.T); + Target := Shift_Left (Target, 8); + Target := Target or unsigned_int (Source.R); + Target := Shift_Left (Target, 8); + Target := Target or unsigned_int (Source.G); + Target := Shift_Left (Target, 8); + Target := Target or unsigned_int (Source.B); + return Target; + end To_unsigned_int; + + ----------------------- + -- To_unsigned_short -- + ----------------------- + + function To_unsigned_short (Source : Pixel_16) return unsigned_short is + + -- This conversion should not depend on the host endianness; + -- therefore, we cannot use an unchecked conversion. + -- It should also be the same result, value-wise, on two hosts + -- with the same endianness. + + Target : unsigned_short := 0; + + begin + -- In big endian bit ordering, Pixel_16 looks like: + -- ------------------------------------- + -- | T | R | G | B | + -- ------------------------------------- + -- 0 (MSB) 1 5 11 15 + -- + -- Sizes of the components: (1/5/5/5) + -- + Target := Target or unsigned_short (Source.T); + Target := Shift_Left (Target, 5); + Target := Target or unsigned_short (Source.R); + Target := Shift_Left (Target, 5); + Target := Target or unsigned_short (Source.G); + Target := Shift_Left (Target, 5); + Target := Target or unsigned_short (Source.B); + return Target; + end To_unsigned_short; + + --------------- + -- abs_v16qi -- + --------------- + + function abs_v16qi (A : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + begin + return To_Vector ((Values => + LL_VSC_Operations.abs_vxi (VA.Values))); + end abs_v16qi; + + -------------- + -- abs_v8hi -- + -------------- + + function abs_v8hi (A : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + begin + return To_Vector ((Values => + LL_VSS_Operations.abs_vxi (VA.Values))); + end abs_v8hi; + + -------------- + -- abs_v4si -- + -------------- + + function abs_v4si (A : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + begin + return To_Vector ((Values => + LL_VSI_Operations.abs_vxi (VA.Values))); + end abs_v4si; + + -------------- + -- abs_v4sf -- + -------------- + + function abs_v4sf (A : LL_VF) return LL_VF is + D : Varray_float; + VA : constant VF_View := To_View (A); + + begin + for J in Varray_float'Range loop + D (J) := abs (VA.Values (J)); + end loop; + + return To_Vector ((Values => D)); + end abs_v4sf; + + ---------------- + -- abss_v16qi -- + ---------------- + + function abss_v16qi (A : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + begin + return To_Vector ((Values => + LL_VSC_Operations.abss_vxi (VA.Values))); + end abss_v16qi; + + --------------- + -- abss_v8hi -- + --------------- + + function abss_v8hi (A : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + begin + return To_Vector ((Values => + LL_VSS_Operations.abss_vxi (VA.Values))); + end abss_v8hi; + + --------------- + -- abss_v4si -- + --------------- + + function abss_v4si (A : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + begin + return To_Vector ((Values => + LL_VSI_Operations.abss_vxi (VA.Values))); + end abss_v4si; + + ------------- + -- vaddubm -- + ------------- + + function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC is + UC : constant GNAT.Altivec.Low_Level_Vectors.LL_VUC := + To_LL_VUC (A); + VA : constant VUC_View := + To_View (UC); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : Varray_unsigned_char; + + begin + D := LL_VUC_Operations.vadduxm (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (VUC_View'(Values => D))); + end vaddubm; + + ------------- + -- vadduhm -- + ------------- + + function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : Varray_unsigned_short; + + begin + D := LL_VUS_Operations.vadduxm (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (VUS_View'(Values => D))); + end vadduhm; + + ------------- + -- vadduwm -- + ------------- + + function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : Varray_unsigned_int; + + begin + D := LL_VUI_Operations.vadduxm (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (VUI_View'(Values => D))); + end vadduwm; + + ------------ + -- vaddfp -- + ------------ + + function vaddfp (A : LL_VF; B : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : Varray_float; + + begin + for J in Varray_float'Range loop + D (J) := NJ_Truncate (NJ_Truncate (VA.Values (J)) + + NJ_Truncate (VB.Values (J))); + end loop; + + return To_Vector (VF_View'(Values => D)); + end vaddfp; + + ------------- + -- vaddcuw -- + ------------- + + function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI is + Addition_Result : UI64; + D : VUI_View; + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + + begin + for J in Varray_unsigned_int'Range loop + Addition_Result := UI64 (VA.Values (J)) + UI64 (VB.Values (J)); + D.Values (J) := + (if Addition_Result > UI64 (unsigned_int'Last) then 1 else 0); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vaddcuw; + + ------------- + -- vaddubs -- + ------------- + + function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + + begin + return To_LL_VSC (To_Vector + (VUC_View'(Values => + (LL_VUC_Operations.vadduxs + (VA.Values, + VB.Values))))); + end vaddubs; + + ------------- + -- vaddsbs -- + ------------- + + function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + + begin + D.Values := LL_VSC_Operations.vaddsxs (VA.Values, VB.Values); + return To_Vector (D); + end vaddsbs; + + ------------- + -- vadduhs -- + ------------- + + function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + + begin + D.Values := LL_VUS_Operations.vadduxs (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vadduhs; + + ------------- + -- vaddshs -- + ------------- + + function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + + begin + D.Values := LL_VSS_Operations.vaddsxs (VA.Values, VB.Values); + return To_Vector (D); + end vaddshs; + + ------------- + -- vadduws -- + ------------- + + function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + D.Values := LL_VUI_Operations.vadduxs (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vadduws; + + ------------- + -- vaddsws -- + ------------- + + function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + + begin + D.Values := LL_VSI_Operations.vaddsxs (VA.Values, VB.Values); + return To_Vector (D); + end vaddsws; + + ---------- + -- vand -- + ---------- + + function vand (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + for J in Varray_unsigned_int'Range loop + D.Values (J) := VA.Values (J) and VB.Values (J); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vand; + + ----------- + -- vandc -- + ----------- + + function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + for J in Varray_unsigned_int'Range loop + D.Values (J) := VA.Values (J) and not VB.Values (J); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vandc; + + ------------ + -- vavgub -- + ------------ + + function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + + begin + D.Values := LL_VUC_Operations.vavgux (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vavgub; + + ------------ + -- vavgsb -- + ------------ + + function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + + begin + D.Values := LL_VSC_Operations.vavgsx (VA.Values, VB.Values); + return To_Vector (D); + end vavgsb; + + ------------ + -- vavguh -- + ------------ + + function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + + begin + D.Values := LL_VUS_Operations.vavgux (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vavguh; + + ------------ + -- vavgsh -- + ------------ + + function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + + begin + D.Values := LL_VSS_Operations.vavgsx (VA.Values, VB.Values); + return To_Vector (D); + end vavgsh; + + ------------ + -- vavguw -- + ------------ + + function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + D.Values := LL_VUI_Operations.vavgux (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vavguw; + + ------------ + -- vavgsw -- + ------------ + + function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + + begin + D.Values := LL_VSI_Operations.vavgsx (VA.Values, VB.Values); + return To_Vector (D); + end vavgsw; + + ----------- + -- vrfip -- + ----------- + + function vrfip (A : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + D : VF_View; + + begin + for J in Varray_float'Range loop + + -- If A (J) is infinite, D (J) should be infinite; With + -- IEEE floating points, we can use 'Ceiling for that purpose. + + D.Values (J) := C_float'Ceiling (NJ_Truncate (VA.Values (J))); + + end loop; + + return To_Vector (D); + end vrfip; + + ------------- + -- vcmpbfp -- + ------------- + + function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : VUI_View; + K : Vint_Range; + + begin + for J in Varray_float'Range loop + K := Vint_Range (J); + D.Values (K) := 0; + + if NJ_Truncate (VB.Values (J)) < 0.0 then + + -- [PIM-4.4 vec_cmpb] "If any single-precision floating-point + -- word element in B is negative; the corresponding element in A + -- is out of bounds. + + D.Values (K) := Write_Bit (D.Values (K), 0, 1); + D.Values (K) := Write_Bit (D.Values (K), 1, 1); + + else + D.Values (K) := + (if NJ_Truncate (VA.Values (J)) <= NJ_Truncate (VB.Values (J)) + then Write_Bit (D.Values (K), 0, 0) + else Write_Bit (D.Values (K), 0, 1)); + + D.Values (K) := + (if NJ_Truncate (VA.Values (J)) >= -NJ_Truncate (VB.Values (J)) + then Write_Bit (D.Values (K), 1, 0) + else Write_Bit (D.Values (K), 1, 1)); + end if; + end loop; + + return To_LL_VSI (To_Vector (D)); + end vcmpbfp; + + -------------- + -- vcmpequb -- + -------------- + + function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + + begin + D.Values := LL_VUC_Operations.vcmpequx (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vcmpequb; + + -------------- + -- vcmpequh -- + -------------- + + function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := LL_VUS_Operations.vcmpequx (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vcmpequh; + + -------------- + -- vcmpequw -- + -------------- + + function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := LL_VUI_Operations.vcmpequx (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vcmpequw; + + -------------- + -- vcmpeqfp -- + -------------- + + function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VSI is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : VUI_View; + + begin + for J in Varray_float'Range loop + D.Values (Vint_Range (J)) := + (if VA.Values (J) = VB.Values (J) then unsigned_int'Last else 0); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vcmpeqfp; + + -------------- + -- vcmpgefp -- + -------------- + + function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VSI is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : VSI_View; + + begin + for J in Varray_float'Range loop + D.Values (Vint_Range (J)) := + (if VA.Values (J) >= VB.Values (J) then Signed_Bool_True + else Signed_Bool_False); + end loop; + + return To_Vector (D); + end vcmpgefp; + + -------------- + -- vcmpgtub -- + -------------- + + function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := LL_VUC_Operations.vcmpgtux (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vcmpgtub; + + -------------- + -- vcmpgtsb -- + -------------- + + function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vcmpgtsx (VA.Values, VB.Values); + return To_Vector (D); + end vcmpgtsb; + + -------------- + -- vcmpgtuh -- + -------------- + + function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := LL_VUS_Operations.vcmpgtux (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vcmpgtuh; + + -------------- + -- vcmpgtsh -- + -------------- + + function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vcmpgtsx (VA.Values, VB.Values); + return To_Vector (D); + end vcmpgtsh; + + -------------- + -- vcmpgtuw -- + -------------- + + function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := LL_VUI_Operations.vcmpgtux (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vcmpgtuw; + + -------------- + -- vcmpgtsw -- + -------------- + + function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vcmpgtsx (VA.Values, VB.Values); + return To_Vector (D); + end vcmpgtsw; + + -------------- + -- vcmpgtfp -- + -------------- + + function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VSI is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : VSI_View; + + begin + for J in Varray_float'Range loop + D.Values (Vint_Range (J)) := + (if NJ_Truncate (VA.Values (J)) > NJ_Truncate (VB.Values (J)) + then Signed_Bool_True else Signed_Bool_False); + end loop; + + return To_Vector (D); + end vcmpgtfp; + + ----------- + -- vcfux -- + ----------- + + function vcfux (A : LL_VUI; B : c_int) return LL_VF is + VA : constant VUI_View := To_View (A); + D : VF_View; + K : Vfloat_Range; + + begin + for J in Varray_signed_int'Range loop + K := Vfloat_Range (J); + + -- Note: The conversion to Integer is safe, as Integers are required + -- to include the range -2 ** 15 + 1 .. 2 ** 15 + 1 and therefore + -- include the range of B (should be 0 .. 255). + + D.Values (K) := + C_float (VA.Values (J)) / (2.0 ** Integer (B)); + end loop; + + return To_Vector (D); + end vcfux; + + ----------- + -- vcfsx -- + ----------- + + function vcfsx (A : LL_VSI; B : c_int) return LL_VF is + VA : constant VSI_View := To_View (A); + D : VF_View; + K : Vfloat_Range; + + begin + for J in Varray_signed_int'Range loop + K := Vfloat_Range (J); + D.Values (K) := C_float (VA.Values (J)) + / (2.0 ** Integer (B)); + end loop; + + return To_Vector (D); + end vcfsx; + + ------------ + -- vctsxs -- + ------------ + + function vctsxs (A : LL_VF; B : c_int) return LL_VSI is + VA : constant VF_View := To_View (A); + D : VSI_View; + K : Vfloat_Range; + + begin + for J in Varray_signed_int'Range loop + K := Vfloat_Range (J); + D.Values (J) := + LL_VSI_Operations.Saturate + (F64 (NJ_Truncate (VA.Values (K))) + * F64 (2.0 ** Integer (B))); + end loop; + + return To_Vector (D); + end vctsxs; + + ------------ + -- vctuxs -- + ------------ + + function vctuxs (A : LL_VF; B : c_int) return LL_VUI is + VA : constant VF_View := To_View (A); + D : VUI_View; + K : Vfloat_Range; + + begin + for J in Varray_unsigned_int'Range loop + K := Vfloat_Range (J); + D.Values (J) := + LL_VUI_Operations.Saturate + (F64 (NJ_Truncate (VA.Values (K))) + * F64 (2.0 ** Integer (B))); + end loop; + + return To_Vector (D); + end vctuxs; + + --------- + -- dss -- + --------- + + -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: + + procedure dss (A : c_int) is + pragma Unreferenced (A); + begin + null; + end dss; + + ------------ + -- dssall -- + ------------ + + -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: + + procedure dssall is + begin + null; + end dssall; + + --------- + -- dst -- + --------- + + -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: + + procedure dst (A : c_ptr; B : c_int; C : c_int) is + pragma Unreferenced (A); + pragma Unreferenced (B); + pragma Unreferenced (C); + begin + null; + end dst; + + ----------- + -- dstst -- + ----------- + + -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: + + procedure dstst (A : c_ptr; B : c_int; C : c_int) is + pragma Unreferenced (A); + pragma Unreferenced (B); + pragma Unreferenced (C); + begin + null; + end dstst; + + ------------ + -- dststt -- + ------------ + + -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: + + procedure dststt (A : c_ptr; B : c_int; C : c_int) is + pragma Unreferenced (A); + pragma Unreferenced (B); + pragma Unreferenced (C); + begin + null; + end dststt; + + ---------- + -- dstt -- + ---------- + + -- No-ops, as allowed by [PEM-5.2.1.1 Data Stream Touch (dst)]: + + procedure dstt (A : c_ptr; B : c_int; C : c_int) is + pragma Unreferenced (A); + pragma Unreferenced (B); + pragma Unreferenced (C); + begin + null; + end dstt; + + -------------- + -- vexptefp -- + -------------- + + function vexptefp (A : LL_VF) return LL_VF is + use C_float_Operations; + + VA : constant VF_View := To_View (A); + D : VF_View; + + begin + for J in Varray_float'Range loop + + -- ??? Check the precision of the operation. + -- As described in [PEM-6 vexptefp]: + -- If theoretical_result is equal to 2 at the power of A (J) with + -- infinite precision, we should have: + -- abs ((D (J) - theoretical_result) / theoretical_result) <= 1/16 + + D.Values (J) := 2.0 ** NJ_Truncate (VA.Values (J)); + end loop; + + return To_Vector (D); + end vexptefp; + + ----------- + -- vrfim -- + ----------- + + function vrfim (A : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + D : VF_View; + + begin + for J in Varray_float'Range loop + + -- If A (J) is infinite, D (J) should be infinite; With + -- IEEE floating point, we can use 'Ceiling for that purpose. + + D.Values (J) := C_float'Ceiling (NJ_Truncate (VA.Values (J))); + + -- Vrfim rounds toward -Infinity, whereas 'Ceiling rounds toward + -- +Infinity: + + if D.Values (J) /= VA.Values (J) then + D.Values (J) := D.Values (J) - 1.0; + end if; + end loop; + + return To_Vector (D); + end vrfim; + + --------- + -- lvx -- + --------- + + function lvx (A : c_long; B : c_ptr) return LL_VSI is + + -- Simulate the altivec unit behavior regarding what Effective Address + -- is accessed, stripping off the input address least significant bits + -- wrt to vector alignment. + + -- On targets where VECTOR_ALIGNMENT is less than the vector size (16), + -- an address within a vector is not necessarily rounded back at the + -- vector start address. Besides, rounding on 16 makes no sense on such + -- targets because the address of a properly aligned vector (that is, + -- a proper multiple of VECTOR_ALIGNMENT) could be affected, which we + -- want never to happen. + + EA : constant System.Address := + To_Address + (Bound_Align + (Integer_Address (A) + To_Integer (B), VECTOR_ALIGNMENT)); + + D : LL_VSI; + for D'Address use EA; + + begin + return D; + end lvx; + + ----------- + -- lvebx -- + ----------- + + function lvebx (A : c_long; B : c_ptr) return LL_VSC is + D : VSC_View; + begin + D.Values := LL_VSC_Operations.lvexx (A, B); + return To_Vector (D); + end lvebx; + + ----------- + -- lvehx -- + ----------- + + function lvehx (A : c_long; B : c_ptr) return LL_VSS is + D : VSS_View; + begin + D.Values := LL_VSS_Operations.lvexx (A, B); + return To_Vector (D); + end lvehx; + + ----------- + -- lvewx -- + ----------- + + function lvewx (A : c_long; B : c_ptr) return LL_VSI is + D : VSI_View; + begin + D.Values := LL_VSI_Operations.lvexx (A, B); + return To_Vector (D); + end lvewx; + + ---------- + -- lvxl -- + ---------- + + function lvxl (A : c_long; B : c_ptr) return LL_VSI renames + lvx; + + ------------- + -- vlogefp -- + ------------- + + function vlogefp (A : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + D : VF_View; + + begin + for J in Varray_float'Range loop + + -- ??? Check the precision of the operation. + -- As described in [PEM-6 vlogefp]: + -- If theorical_result is equal to the log2 of A (J) with + -- infinite precision, we should have: + -- abs (D (J) - theorical_result) <= 1/32, + -- unless abs(D(J) - 1) <= 1/8. + + D.Values (J) := + C_float_Operations.Log (NJ_Truncate (VA.Values (J)), 2.0); + end loop; + + return To_Vector (D); + end vlogefp; + + ---------- + -- lvsl -- + ---------- + + function lvsl (A : c_long; B : c_ptr) return LL_VSC is + type bit4_type is mod 16#F# + 1; + for bit4_type'Alignment use 1; + EA : Integer_Address; + D : VUC_View; + SH : bit4_type; + + begin + EA := Integer_Address (A) + To_Integer (B); + SH := bit4_type (EA mod 2 ** 4); + + for J in D.Values'Range loop + D.Values (J) := unsigned_char (SH) + unsigned_char (J) + - unsigned_char (D.Values'First); + end loop; + + return To_LL_VSC (To_Vector (D)); + end lvsl; + + ---------- + -- lvsr -- + ---------- + + function lvsr (A : c_long; B : c_ptr) return LL_VSC is + type bit4_type is mod 16#F# + 1; + for bit4_type'Alignment use 1; + EA : Integer_Address; + D : VUC_View; + SH : bit4_type; + + begin + EA := Integer_Address (A) + To_Integer (B); + SH := bit4_type (EA mod 2 ** 4); + + for J in D.Values'Range loop + D.Values (J) := (16#F# - unsigned_char (SH)) + unsigned_char (J); + end loop; + + return To_LL_VSC (To_Vector (D)); + end lvsr; + + ------------- + -- vmaddfp -- + ------------- + + function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + VC : constant VF_View := To_View (C); + D : VF_View; + + begin + for J in Varray_float'Range loop + D.Values (J) := + Rnd_To_FP_Nearest (F64 (VA.Values (J)) + * F64 (VB.Values (J)) + + F64 (VC.Values (J))); + end loop; + + return To_Vector (D); + end vmaddfp; + + --------------- + -- vmhaddshs -- + --------------- + + function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + VC : constant VSS_View := To_View (C); + D : VSS_View; + + begin + for J in Varray_signed_short'Range loop + D.Values (J) := LL_VSS_Operations.Saturate + ((SI64 (VA.Values (J)) * SI64 (VB.Values (J))) + / SI64 (2 ** 15) + SI64 (VC.Values (J))); + end loop; + + return To_Vector (D); + end vmhaddshs; + + ------------ + -- vmaxub -- + ------------ + + function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := LL_VUC_Operations.vmaxux (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vmaxub; + + ------------ + -- vmaxsb -- + ------------ + + function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vmaxsx (VA.Values, VB.Values); + return To_Vector (D); + end vmaxsb; + + ------------ + -- vmaxuh -- + ------------ + + function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := LL_VUS_Operations.vmaxux (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vmaxuh; + + ------------ + -- vmaxsh -- + ------------ + + function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vmaxsx (VA.Values, VB.Values); + return To_Vector (D); + end vmaxsh; + + ------------ + -- vmaxuw -- + ------------ + + function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := LL_VUI_Operations.vmaxux (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vmaxuw; + + ------------ + -- vmaxsw -- + ------------ + + function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vmaxsx (VA.Values, VB.Values); + return To_Vector (D); + end vmaxsw; + + -------------- + -- vmaxsxfp -- + -------------- + + function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : VF_View; + + begin + for J in Varray_float'Range loop + D.Values (J) := (if VA.Values (J) > VB.Values (J) then VA.Values (J) + else VB.Values (J)); + end loop; + + return To_Vector (D); + end vmaxfp; + + ------------ + -- vmrghb -- + ------------ + + function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vmrghx (VA.Values, VB.Values); + return To_Vector (D); + end vmrghb; + + ------------ + -- vmrghh -- + ------------ + + function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vmrghx (VA.Values, VB.Values); + return To_Vector (D); + end vmrghh; + + ------------ + -- vmrghw -- + ------------ + + function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vmrghx (VA.Values, VB.Values); + return To_Vector (D); + end vmrghw; + + ------------ + -- vmrglb -- + ------------ + + function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vmrglx (VA.Values, VB.Values); + return To_Vector (D); + end vmrglb; + + ------------ + -- vmrglh -- + ------------ + + function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vmrglx (VA.Values, VB.Values); + return To_Vector (D); + end vmrglh; + + ------------ + -- vmrglw -- + ------------ + + function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vmrglx (VA.Values, VB.Values); + return To_Vector (D); + end vmrglw; + + ------------ + -- mfvscr -- + ------------ + + function mfvscr return LL_VSS is + D : VUS_View; + begin + for J in Varray_unsigned_short'Range loop + D.Values (J) := 0; + end loop; + + D.Values (Varray_unsigned_short'Last) := + unsigned_short (VSCR mod 2 ** unsigned_short'Size); + D.Values (Varray_unsigned_short'Last - 1) := + unsigned_short (VSCR / 2 ** unsigned_short'Size); + return To_LL_VSS (To_Vector (D)); + end mfvscr; + + ------------ + -- vminfp -- + ------------ + + function vminfp (A : LL_VF; B : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : VF_View; + + begin + for J in Varray_float'Range loop + D.Values (J) := (if VA.Values (J) < VB.Values (J) then VA.Values (J) + else VB.Values (J)); + end loop; + + return To_Vector (D); + end vminfp; + + ------------ + -- vminsb -- + ------------ + + function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vminsx (VA.Values, VB.Values); + return To_Vector (D); + end vminsb; + + ------------ + -- vminub -- + ------------ + + function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := LL_VUC_Operations.vminux (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vminub; + + ------------ + -- vminsh -- + ------------ + + function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vminsx (VA.Values, VB.Values); + return To_Vector (D); + end vminsh; + + ------------ + -- vminuh -- + ------------ + + function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := LL_VUS_Operations.vminux (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vminuh; + + ------------ + -- vminsw -- + ------------ + + function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vminsx (VA.Values, VB.Values); + return To_Vector (D); + end vminsw; + + ------------ + -- vminuw -- + ------------ + + function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := LL_VUI_Operations.vminux (VA.Values, + VB.Values); + return To_LL_VSI (To_Vector (D)); + end vminuw; + + --------------- + -- vmladduhm -- + --------------- + + function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + VC : constant VUS_View := To_View (To_LL_VUS (C)); + D : VUS_View; + + begin + for J in Varray_unsigned_short'Range loop + D.Values (J) := VA.Values (J) * VB.Values (J) + + VC.Values (J); + end loop; + + return To_LL_VSS (To_Vector (D)); + end vmladduhm; + + ---------------- + -- vmhraddshs -- + ---------------- + + function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + VC : constant VSS_View := To_View (C); + D : VSS_View; + + begin + for J in Varray_signed_short'Range loop + D.Values (J) := + LL_VSS_Operations.Saturate (((SI64 (VA.Values (J)) + * SI64 (VB.Values (J)) + + 2 ** 14) + / 2 ** 15 + + SI64 (VC.Values (J)))); + end loop; + + return To_Vector (D); + end vmhraddshs; + + -------------- + -- vmsumubm -- + -------------- + + function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI is + Offset : Vchar_Range; + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + VC : constant VUI_View := To_View (To_LL_VUI (C)); + D : VUI_View; + + begin + for J in 0 .. 3 loop + Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); + D.Values (Vint_Range + (J + Integer (Vint_Range'First))) := + (unsigned_int (VA.Values (Offset)) + * unsigned_int (VB.Values (Offset))) + + (unsigned_int (VA.Values (Offset + 1)) + * unsigned_int (VB.Values (1 + Offset))) + + (unsigned_int (VA.Values (2 + Offset)) + * unsigned_int (VB.Values (2 + Offset))) + + (unsigned_int (VA.Values (3 + Offset)) + * unsigned_int (VB.Values (3 + Offset))) + + VC.Values (Vint_Range + (J + Integer (Varray_unsigned_int'First))); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vmsumubm; + + -------------- + -- vmsumumbm -- + -------------- + + function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI is + Offset : Vchar_Range; + VA : constant VSC_View := To_View (A); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + VC : constant VSI_View := To_View (C); + D : VSI_View; + + begin + for J in 0 .. 3 loop + Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); + D.Values (Vint_Range + (J + Integer (Varray_unsigned_int'First))) := 0 + + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset)) + * SI64 (VB.Values (Offset))) + + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset + 1)) + * SI64 (VB.Values + (1 + Offset))) + + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (2 + Offset)) + * SI64 (VB.Values + (2 + Offset))) + + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (3 + Offset)) + * SI64 (VB.Values + (3 + Offset))) + + VC.Values (Vint_Range + (J + Integer (Varray_unsigned_int'First))); + end loop; + + return To_Vector (D); + end vmsummbm; + + -------------- + -- vmsumuhm -- + -------------- + + function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is + Offset : Vshort_Range; + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + VC : constant VUI_View := To_View (To_LL_VUI (C)); + D : VUI_View; + + begin + for J in 0 .. 3 loop + Offset := + Vshort_Range (2 * J + Integer (Vshort_Range'First)); + D.Values (Vint_Range + (J + Integer (Varray_unsigned_int'First))) := + (unsigned_int (VA.Values (Offset)) + * unsigned_int (VB.Values (Offset))) + + (unsigned_int (VA.Values (Offset + 1)) + * unsigned_int (VB.Values (1 + Offset))) + + VC.Values (Vint_Range + (J + Integer (Vint_Range'First))); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vmsumuhm; + + -------------- + -- vmsumshm -- + -------------- + + function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + VC : constant VSI_View := To_View (C); + Offset : Vshort_Range; + D : VSI_View; + + begin + for J in 0 .. 3 loop + Offset := + Vshort_Range (2 * J + Integer (Varray_signed_char'First)); + D.Values (Vint_Range + (J + Integer (Varray_unsigned_int'First))) := 0 + + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset)) + * SI64 (VB.Values (Offset))) + + LL_VSI_Operations.Modular_Result (SI64 (VA.Values (Offset + 1)) + * SI64 (VB.Values + (1 + Offset))) + + VC.Values (Vint_Range + (J + Integer (Varray_unsigned_int'First))); + end loop; + + return To_Vector (D); + end vmsumshm; + + -------------- + -- vmsumuhs -- + -------------- + + function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is + Offset : Vshort_Range; + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + VC : constant VUI_View := To_View (To_LL_VUI (C)); + D : VUI_View; + + begin + for J in 0 .. 3 loop + Offset := + Vshort_Range (2 * J + Integer (Varray_signed_short'First)); + D.Values (Vint_Range + (J + Integer (Varray_unsigned_int'First))) := + LL_VUI_Operations.Saturate + (UI64 (VA.Values (Offset)) + * UI64 (VB.Values (Offset)) + + UI64 (VA.Values (Offset + 1)) + * UI64 (VB.Values (1 + Offset)) + + UI64 (VC.Values + (Vint_Range + (J + Integer (Varray_unsigned_int'First))))); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vmsumuhs; + + -------------- + -- vmsumshs -- + -------------- + + function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + VC : constant VSI_View := To_View (C); + Offset : Vshort_Range; + D : VSI_View; + + begin + for J in 0 .. 3 loop + Offset := + Vshort_Range (2 * J + Integer (Varray_signed_short'First)); + D.Values (Vint_Range + (J + Integer (Varray_signed_int'First))) := + LL_VSI_Operations.Saturate + (SI64 (VA.Values (Offset)) + * SI64 (VB.Values (Offset)) + + SI64 (VA.Values (Offset + 1)) + * SI64 (VB.Values (1 + Offset)) + + SI64 (VC.Values + (Vint_Range + (J + Integer (Varray_signed_int'First))))); + end loop; + + return To_Vector (D); + end vmsumshs; + + ------------ + -- mtvscr -- + ------------ + + procedure mtvscr (A : LL_VSI) is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + begin + VSCR := VA.Values (Varray_unsigned_int'Last); + end mtvscr; + + ------------- + -- vmuleub -- + ------------- + + function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUS_View; + begin + D.Values := LL_VUC_LL_VUS_Operations.vmulxux (True, + VA.Values, + VB.Values); + return To_LL_VSS (To_Vector (D)); + end vmuleub; + + ------------- + -- vmuleuh -- + ------------- + + function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUI_View; + begin + D.Values := LL_VUS_LL_VUI_Operations.vmulxux (True, + VA.Values, + VB.Values); + return To_LL_VSI (To_Vector (D)); + end vmuleuh; + + ------------- + -- vmulesb -- + ------------- + + function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSC_LL_VSS_Operations.vmulxsx (True, + VA.Values, + VB.Values); + return To_Vector (D); + end vmulesb; + + ------------- + -- vmulesh -- + ------------- + + function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSS_LL_VSI_Operations.vmulxsx (True, + VA.Values, + VB.Values); + return To_Vector (D); + end vmulesh; + + ------------- + -- vmuloub -- + ------------- + + function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUS_View; + begin + D.Values := LL_VUC_LL_VUS_Operations.vmulxux (False, + VA.Values, + VB.Values); + return To_LL_VSS (To_Vector (D)); + end vmuloub; + + ------------- + -- vmulouh -- + ------------- + + function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUI_View; + begin + D.Values := + LL_VUS_LL_VUI_Operations.vmulxux (False, VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vmulouh; + + ------------- + -- vmulosb -- + ------------- + + function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSC_LL_VSS_Operations.vmulxsx (False, + VA.Values, + VB.Values); + return To_Vector (D); + end vmulosb; + + ------------- + -- vmulosh -- + ------------- + + function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSS_LL_VSI_Operations.vmulxsx (False, + VA.Values, + VB.Values); + return To_Vector (D); + end vmulosh; + + -------------- + -- vnmsubfp -- + -------------- + + function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + VC : constant VF_View := To_View (C); + D : VF_View; + + begin + for J in Vfloat_Range'Range loop + D.Values (J) := + -Rnd_To_FP_Nearest (F64 (VA.Values (J)) + * F64 (VB.Values (J)) + - F64 (VC.Values (J))); + end loop; + + return To_Vector (D); + end vnmsubfp; + + ---------- + -- vnor -- + ---------- + + function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + for J in Vint_Range'Range loop + D.Values (J) := not (VA.Values (J) or VB.Values (J)); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vnor; + + ---------- + -- vor -- + ---------- + + function vor (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + for J in Vint_Range'Range loop + D.Values (J) := VA.Values (J) or VB.Values (J); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vor; + + ------------- + -- vpkuhum -- + ------------- + + function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUC_View; + begin + D.Values := LL_VUC_LL_VUS_Operations.vpkuxum (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vpkuhum; + + ------------- + -- vpkuwum -- + ------------- + + function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUS_View; + begin + D.Values := LL_VUS_LL_VUI_Operations.vpkuxum (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vpkuwum; + + ----------- + -- vpkpx -- + ----------- + + function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUS_View; + Offset : Vint_Range; + P16 : Pixel_16; + P32 : Pixel_32; + + begin + for J in 0 .. 3 loop + Offset := Vint_Range (J + Integer (Vshort_Range'First)); + P32 := To_Pixel (VA.Values (Offset)); + P16.T := Unsigned_1 (P32.T mod 2 ** 1); + P16.R := Unsigned_5 (Shift_Right (P32.R, 3) mod 2 ** 5); + P16.G := Unsigned_5 (Shift_Right (P32.G, 3) mod 2 ** 5); + P16.B := Unsigned_5 (Shift_Right (P32.B, 3) mod 2 ** 5); + D.Values (Vshort_Range (Offset)) := To_unsigned_short (P16); + P32 := To_Pixel (VB.Values (Offset)); + P16.T := Unsigned_1 (P32.T mod 2 ** 1); + P16.R := Unsigned_5 (Shift_Right (P32.R, 3) mod 2 ** 5); + P16.G := Unsigned_5 (Shift_Right (P32.G, 3) mod 2 ** 5); + P16.B := Unsigned_5 (Shift_Right (P32.B, 3) mod 2 ** 5); + D.Values (Vshort_Range (Offset) + 4) := To_unsigned_short (P16); + end loop; + + return To_LL_VSS (To_Vector (D)); + end vpkpx; + + ------------- + -- vpkuhus -- + ------------- + + function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUC_View; + begin + D.Values := LL_VUC_LL_VUS_Operations.vpkuxus (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vpkuhus; + + ------------- + -- vpkuwus -- + ------------- + + function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUS_View; + begin + D.Values := LL_VUS_LL_VUI_Operations.vpkuxus (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vpkuwus; + + ------------- + -- vpkshss -- + ------------- + + function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSC_View; + begin + D.Values := LL_VSC_LL_VSS_Operations.vpksxss (VA.Values, VB.Values); + return To_Vector (D); + end vpkshss; + + ------------- + -- vpkswss -- + ------------- + + function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSS_LL_VSI_Operations.vpksxss (VA.Values, VB.Values); + return To_Vector (D); + end vpkswss; + + ------------- + -- vpksxus -- + ------------- + + generic + type Signed_Component_Type is range <>; + type Signed_Index_Type is range <>; + type Signed_Varray_Type is + array (Signed_Index_Type) of Signed_Component_Type; + type Unsigned_Component_Type is mod <>; + type Unsigned_Index_Type is range <>; + type Unsigned_Varray_Type is + array (Unsigned_Index_Type) of Unsigned_Component_Type; + + function vpksxus + (A : Signed_Varray_Type; + B : Signed_Varray_Type) return Unsigned_Varray_Type; + + function vpksxus + (A : Signed_Varray_Type; + B : Signed_Varray_Type) return Unsigned_Varray_Type + is + N : constant Unsigned_Index_Type := + Unsigned_Index_Type (Signed_Index_Type'Last); + Offset : Unsigned_Index_Type; + Signed_Offset : Signed_Index_Type; + D : Unsigned_Varray_Type; + + function Saturate + (X : Signed_Component_Type) return Unsigned_Component_Type; + -- Saturation, as defined in + -- [PIM-4.1 Vector Status and Control Register] + + -------------- + -- Saturate -- + -------------- + + function Saturate + (X : Signed_Component_Type) return Unsigned_Component_Type + is + D : Unsigned_Component_Type; + + begin + D := Unsigned_Component_Type + (Signed_Component_Type'Max + (Signed_Component_Type (Unsigned_Component_Type'First), + Signed_Component_Type'Min + (Signed_Component_Type (Unsigned_Component_Type'Last), + X))); + if Signed_Component_Type (D) /= X then + VSCR := Write_Bit (VSCR, SAT_POS, 1); + end if; + + return D; + end Saturate; + + -- Start of processing for vpksxus + + begin + for J in 0 .. N - 1 loop + Offset := + Unsigned_Index_Type (Integer (J) + + Integer (Unsigned_Index_Type'First)); + Signed_Offset := + Signed_Index_Type (Integer (J) + + Integer (Signed_Index_Type'First)); + D (Offset) := Saturate (A (Signed_Offset)); + D (Offset + N) := Saturate (B (Signed_Offset)); + end loop; + + return D; + end vpksxus; + + ------------- + -- vpkshus -- + ------------- + + function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC is + function vpkshus_Instance is + new vpksxus (signed_short, + Vshort_Range, + Varray_signed_short, + unsigned_char, + Vchar_Range, + Varray_unsigned_char); + + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VUC_View; + + begin + D.Values := vpkshus_Instance (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vpkshus; + + ------------- + -- vpkswus -- + ------------- + + function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS is + function vpkswus_Instance is + new vpksxus (signed_int, + Vint_Range, + Varray_signed_int, + unsigned_short, + Vshort_Range, + Varray_unsigned_short); + + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VUS_View; + begin + D.Values := vpkswus_Instance (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vpkswus; + + --------------- + -- vperm_4si -- + --------------- + + function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + VC : constant VUC_View := To_View (To_LL_VUC (C)); + J : Vchar_Range; + D : VUC_View; + + begin + for N in Vchar_Range'Range loop + J := Vchar_Range (Integer (Bits (VC.Values (N), 4, 7)) + + Integer (Vchar_Range'First)); + D.Values (N) := + (if Bits (VC.Values (N), 3, 3) = 0 then VA.Values (J) + else VB.Values (J)); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vperm_4si; + + ----------- + -- vrefp -- + ----------- + + function vrefp (A : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + D : VF_View; + + begin + for J in Vfloat_Range'Range loop + D.Values (J) := FP_Recip_Est (VA.Values (J)); + end loop; + + return To_Vector (D); + end vrefp; + + ---------- + -- vrlb -- + ---------- + + function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := LL_VUC_Operations.vrlx (VA.Values, VB.Values, ROTL'Access); + return To_LL_VSC (To_Vector (D)); + end vrlb; + + ---------- + -- vrlh -- + ---------- + + function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := LL_VUS_Operations.vrlx (VA.Values, VB.Values, ROTL'Access); + return To_LL_VSS (To_Vector (D)); + end vrlh; + + ---------- + -- vrlw -- + ---------- + + function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := LL_VUI_Operations.vrlx (VA.Values, VB.Values, ROTL'Access); + return To_LL_VSI (To_Vector (D)); + end vrlw; + + ----------- + -- vrfin -- + ----------- + + function vrfin (A : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + D : VF_View; + + begin + for J in Vfloat_Range'Range loop + D.Values (J) := C_float (Rnd_To_FPI_Near (F64 (VA.Values (J)))); + end loop; + + return To_Vector (D); + end vrfin; + + --------------- + -- vrsqrtefp -- + --------------- + + function vrsqrtefp (A : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + D : VF_View; + + begin + for J in Vfloat_Range'Range loop + D.Values (J) := Recip_SQRT_Est (VA.Values (J)); + end loop; + + return To_Vector (D); + end vrsqrtefp; + + -------------- + -- vsel_4si -- + -------------- + + function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + VC : constant VUI_View := To_View (To_LL_VUI (C)); + D : VUI_View; + + begin + for J in Vint_Range'Range loop + D.Values (J) := ((not VC.Values (J)) and VA.Values (J)) + or (VC.Values (J) and VB.Values (J)); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vsel_4si; + + ---------- + -- vslb -- + ---------- + + function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := + LL_VUC_Operations.vsxx (VA.Values, VB.Values, Shift_Left'Access); + return To_LL_VSC (To_Vector (D)); + end vslb; + + ---------- + -- vslh -- + ---------- + + function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := + LL_VUS_Operations.vsxx (VA.Values, VB.Values, Shift_Left'Access); + return To_LL_VSS (To_Vector (D)); + end vslh; + + ---------- + -- vslw -- + ---------- + + function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := + LL_VUI_Operations.vsxx (VA.Values, VB.Values, Shift_Left'Access); + return To_LL_VSI (To_Vector (D)); + end vslw; + + ---------------- + -- vsldoi_4si -- + ---------------- + + function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + Offset : c_int; + Bound : c_int; + D : VUC_View; + + begin + for J in Vchar_Range'Range loop + Offset := c_int (J) + C; + Bound := c_int (Vchar_Range'First) + + c_int (Varray_unsigned_char'Length); + + if Offset < Bound then + D.Values (J) := VA.Values (Vchar_Range (Offset)); + else + D.Values (J) := + VB.Values (Vchar_Range (Offset - Bound + + c_int (Vchar_Range'First))); + end if; + end loop; + + return To_LL_VSI (To_Vector (D)); + end vsldoi_4si; + + ---------------- + -- vsldoi_8hi -- + ---------------- + + function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS is + begin + return To_LL_VSS (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); + end vsldoi_8hi; + + ----------------- + -- vsldoi_16qi -- + ----------------- + + function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC is + begin + return To_LL_VSC (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); + end vsldoi_16qi; + + ---------------- + -- vsldoi_4sf -- + ---------------- + + function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF is + begin + return To_LL_VF (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); + end vsldoi_4sf; + + --------- + -- vsl -- + --------- + + function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + M : constant Natural := + Natural (Bits (VB.Values (Vint_Range'Last), 29, 31)); + + -- [PIM-4.4 vec_sll] "Note that the three low-order byte elements in B + -- must be the same. Otherwise the value placed into D is undefined." + -- ??? Shall we add a optional check for B? + + begin + for J in Vint_Range'Range loop + D.Values (J) := 0; + D.Values (J) := D.Values (J) + Shift_Left (VA.Values (J), M); + + if J /= Vint_Range'Last then + D.Values (J) := + D.Values (J) + Shift_Right (VA.Values (J + 1), + signed_int'Size - M); + end if; + end loop; + + return To_LL_VSI (To_Vector (D)); + end vsl; + + ---------- + -- vslo -- + ---------- + + function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + M : constant Natural := + Natural (Bits (VB.Values (Vchar_Range'Last), 1, 4)); + J : Natural; + + begin + for N in Vchar_Range'Range loop + J := Natural (N) + M; + D.Values (N) := + (if J <= Natural (Vchar_Range'Last) then VA.Values (Vchar_Range (J)) + else 0); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vslo; + + ------------ + -- vspltb -- + ------------ + + function vspltb (A : LL_VSC; B : c_int) return LL_VSC is + VA : constant VSC_View := To_View (A); + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vspltx (VA.Values, B); + return To_Vector (D); + end vspltb; + + ------------ + -- vsplth -- + ------------ + + function vsplth (A : LL_VSS; B : c_int) return LL_VSS is + VA : constant VSS_View := To_View (A); + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vspltx (VA.Values, B); + return To_Vector (D); + end vsplth; + + ------------ + -- vspltw -- + ------------ + + function vspltw (A : LL_VSI; B : c_int) return LL_VSI is + VA : constant VSI_View := To_View (A); + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vspltx (VA.Values, B); + return To_Vector (D); + end vspltw; + + -------------- + -- vspltisb -- + -------------- + + function vspltisb (A : c_int) return LL_VSC is + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vspltisx (A); + return To_Vector (D); + end vspltisb; + + -------------- + -- vspltish -- + -------------- + + function vspltish (A : c_int) return LL_VSS is + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vspltisx (A); + return To_Vector (D); + end vspltish; + + -------------- + -- vspltisw -- + -------------- + + function vspltisw (A : c_int) return LL_VSI is + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vspltisx (A); + return To_Vector (D); + end vspltisw; + + ---------- + -- vsrb -- + ---------- + + function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := + LL_VUC_Operations.vsxx (VA.Values, VB.Values, Shift_Right'Access); + return To_LL_VSC (To_Vector (D)); + end vsrb; + + ---------- + -- vsrh -- + ---------- + + function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := + LL_VUS_Operations.vsxx (VA.Values, VB.Values, Shift_Right'Access); + return To_LL_VSS (To_Vector (D)); + end vsrh; + + ---------- + -- vsrw -- + ---------- + + function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := + LL_VUI_Operations.vsxx (VA.Values, VB.Values, Shift_Right'Access); + return To_LL_VSI (To_Vector (D)); + end vsrw; + + ----------- + -- vsrab -- + ----------- + + function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + begin + D.Values := + LL_VSC_Operations.vsrax (VA.Values, VB.Values, Shift_Right_A'Access); + return To_Vector (D); + end vsrab; + + ----------- + -- vsrah -- + ----------- + + function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + begin + D.Values := + LL_VSS_Operations.vsrax (VA.Values, VB.Values, Shift_Right_A'Access); + return To_Vector (D); + end vsrah; + + ----------- + -- vsraw -- + ----------- + + function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + begin + D.Values := + LL_VSI_Operations.vsrax (VA.Values, VB.Values, Shift_Right_A'Access); + return To_Vector (D); + end vsraw; + + --------- + -- vsr -- + --------- + + function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + M : constant Natural := + Natural (Bits (VB.Values (Vint_Range'Last), 29, 31)); + D : VUI_View; + + begin + for J in Vint_Range'Range loop + D.Values (J) := 0; + D.Values (J) := D.Values (J) + Shift_Right (VA.Values (J), M); + + if J /= Vint_Range'First then + D.Values (J) := + D.Values (J) + + Shift_Left (VA.Values (J - 1), signed_int'Size - M); + end if; + end loop; + + return To_LL_VSI (To_Vector (D)); + end vsr; + + ---------- + -- vsro -- + ---------- + + function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + M : constant Natural := + Natural (Bits (VB.Values (Vchar_Range'Last), 1, 4)); + J : Natural; + D : VUC_View; + + begin + for N in Vchar_Range'Range loop + J := Natural (N) - M; + + if J >= Natural (Vchar_Range'First) then + D.Values (N) := VA.Values (Vchar_Range (J)); + else + D.Values (N) := 0; + end if; + end loop; + + return To_LL_VSI (To_Vector (D)); + end vsro; + + ---------- + -- stvx -- + ---------- + + procedure stvx (A : LL_VSI; B : c_int; C : c_ptr) is + + -- Simulate the altivec unit behavior regarding what Effective Address + -- is accessed, stripping off the input address least significant bits + -- wrt to vector alignment (see comment in lvx for further details). + + EA : constant System.Address := + To_Address + (Bound_Align + (Integer_Address (B) + To_Integer (C), VECTOR_ALIGNMENT)); + + D : LL_VSI; + for D'Address use EA; + + begin + D := A; + end stvx; + + ------------ + -- stvewx -- + ------------ + + procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr) is + VA : constant VSC_View := To_View (A); + begin + LL_VSC_Operations.stvexx (VA.Values, B, C); + end stvebx; + + ------------ + -- stvehx -- + ------------ + + procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr) is + VA : constant VSS_View := To_View (A); + begin + LL_VSS_Operations.stvexx (VA.Values, B, C); + end stvehx; + + ------------ + -- stvewx -- + ------------ + + procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr) is + VA : constant VSI_View := To_View (A); + begin + LL_VSI_Operations.stvexx (VA.Values, B, C); + end stvewx; + + ----------- + -- stvxl -- + ----------- + + procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr) renames stvx; + + ------------- + -- vsububm -- + ------------- + + function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := LL_VUC_Operations.vsubuxm (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vsububm; + + ------------- + -- vsubuhm -- + ------------- + + function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := LL_VUS_Operations.vsubuxm (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vsubuhm; + + ------------- + -- vsubuwm -- + ------------- + + function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := LL_VUI_Operations.vsubuxm (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vsubuwm; + + ------------ + -- vsubfp -- + ------------ + + function vsubfp (A : LL_VF; B : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + VB : constant VF_View := To_View (B); + D : VF_View; + + begin + for J in Vfloat_Range'Range loop + D.Values (J) := + NJ_Truncate (NJ_Truncate (VA.Values (J)) + - NJ_Truncate (VB.Values (J))); + end loop; + + return To_Vector (D); + end vsubfp; + + ------------- + -- vsubcuw -- + ------------- + + function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI is + Subst_Result : SI64; + + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + for J in Vint_Range'Range loop + Subst_Result := SI64 (VA.Values (J)) - SI64 (VB.Values (J)); + D.Values (J) := + (if Subst_Result < SI64 (unsigned_int'First) then 0 else 1); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vsubcuw; + + ------------- + -- vsububs -- + ------------- + + function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUC_View := To_View (To_LL_VUC (B)); + D : VUC_View; + begin + D.Values := LL_VUC_Operations.vsubuxs (VA.Values, VB.Values); + return To_LL_VSC (To_Vector (D)); + end vsububs; + + ------------- + -- vsubsbs -- + ------------- + + function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC is + VA : constant VSC_View := To_View (A); + VB : constant VSC_View := To_View (B); + D : VSC_View; + begin + D.Values := LL_VSC_Operations.vsubsxs (VA.Values, VB.Values); + return To_Vector (D); + end vsubsbs; + + ------------- + -- vsubuhs -- + ------------- + + function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + VB : constant VUS_View := To_View (To_LL_VUS (B)); + D : VUS_View; + begin + D.Values := LL_VUS_Operations.vsubuxs (VA.Values, VB.Values); + return To_LL_VSS (To_Vector (D)); + end vsubuhs; + + ------------- + -- vsubshs -- + ------------- + + function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS is + VA : constant VSS_View := To_View (A); + VB : constant VSS_View := To_View (B); + D : VSS_View; + begin + D.Values := LL_VSS_Operations.vsubsxs (VA.Values, VB.Values); + return To_Vector (D); + end vsubshs; + + ------------- + -- vsubuws -- + ------------- + + function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + begin + D.Values := LL_VUI_Operations.vsubuxs (VA.Values, VB.Values); + return To_LL_VSI (To_Vector (D)); + end vsubuws; + + ------------- + -- vsubsws -- + ------------- + + function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + begin + D.Values := LL_VSI_Operations.vsubsxs (VA.Values, VB.Values); + return To_Vector (D); + end vsubsws; + + -------------- + -- vsum4ubs -- + -------------- + + function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI is + VA : constant VUC_View := To_View (To_LL_VUC (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + Offset : Vchar_Range; + D : VUI_View; + + begin + for J in 0 .. 3 loop + Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); + D.Values (Vint_Range (J + Integer (Vint_Range'First))) := + LL_VUI_Operations.Saturate + (UI64 (VA.Values (Offset)) + + UI64 (VA.Values (Offset + 1)) + + UI64 (VA.Values (Offset + 2)) + + UI64 (VA.Values (Offset + 3)) + + UI64 (VB.Values (Vint_Range (J + Integer (Vint_Range'First))))); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vsum4ubs; + + -------------- + -- vsum4sbs -- + -------------- + + function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI is + VA : constant VSC_View := To_View (A); + VB : constant VSI_View := To_View (B); + Offset : Vchar_Range; + D : VSI_View; + + begin + for J in 0 .. 3 loop + Offset := Vchar_Range (4 * J + Integer (Vchar_Range'First)); + D.Values (Vint_Range (J + Integer (Vint_Range'First))) := + LL_VSI_Operations.Saturate + (SI64 (VA.Values (Offset)) + + SI64 (VA.Values (Offset + 1)) + + SI64 (VA.Values (Offset + 2)) + + SI64 (VA.Values (Offset + 3)) + + SI64 (VB.Values (Vint_Range (J + Integer (Vint_Range'First))))); + end loop; + + return To_Vector (D); + end vsum4sbs; + + -------------- + -- vsum4shs -- + -------------- + + function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI is + VA : constant VSS_View := To_View (A); + VB : constant VSI_View := To_View (B); + Offset : Vshort_Range; + D : VSI_View; + + begin + for J in 0 .. 3 loop + Offset := Vshort_Range (2 * J + Integer (Vchar_Range'First)); + D.Values (Vint_Range (J + Integer (Vint_Range'First))) := + LL_VSI_Operations.Saturate + (SI64 (VA.Values (Offset)) + + SI64 (VA.Values (Offset + 1)) + + SI64 (VB.Values (Vint_Range (J + Integer (Vint_Range'First))))); + end loop; + + return To_Vector (D); + end vsum4shs; + + -------------- + -- vsum2sws -- + -------------- + + function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + Offset : Vint_Range; + D : VSI_View; + + begin + for J in 0 .. 1 loop + Offset := Vint_Range (2 * J + Integer (Vchar_Range'First)); + D.Values (Offset) := 0; + D.Values (Offset + 1) := + LL_VSI_Operations.Saturate + (SI64 (VA.Values (Offset)) + + SI64 (VA.Values (Offset + 1)) + + SI64 (VB.Values (Vint_Range (Offset + 1)))); + end loop; + + return To_Vector (D); + end vsum2sws; + + ------------- + -- vsumsws -- + ------------- + + function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VSI_View := To_View (A); + VB : constant VSI_View := To_View (B); + D : VSI_View; + Sum_Buffer : SI64 := 0; + + begin + for J in Vint_Range'Range loop + D.Values (J) := 0; + Sum_Buffer := Sum_Buffer + SI64 (VA.Values (J)); + end loop; + + Sum_Buffer := Sum_Buffer + SI64 (VB.Values (Vint_Range'Last)); + D.Values (Vint_Range'Last) := LL_VSI_Operations.Saturate (Sum_Buffer); + return To_Vector (D); + end vsumsws; + + ----------- + -- vrfiz -- + ----------- + + function vrfiz (A : LL_VF) return LL_VF is + VA : constant VF_View := To_View (A); + D : VF_View; + begin + for J in Vfloat_Range'Range loop + D.Values (J) := C_float (Rnd_To_FPI_Trunc (F64 (VA.Values (J)))); + end loop; + + return To_Vector (D); + end vrfiz; + + ------------- + -- vupkhsb -- + ------------- + + function vupkhsb (A : LL_VSC) return LL_VSS is + VA : constant VSC_View := To_View (A); + D : VSS_View; + begin + D.Values := LL_VSC_LL_VSS_Operations.vupkxsx (VA.Values, 0); + return To_Vector (D); + end vupkhsb; + + ------------- + -- vupkhsh -- + ------------- + + function vupkhsh (A : LL_VSS) return LL_VSI is + VA : constant VSS_View := To_View (A); + D : VSI_View; + begin + D.Values := LL_VSS_LL_VSI_Operations.vupkxsx (VA.Values, 0); + return To_Vector (D); + end vupkhsh; + + ------------- + -- vupkxpx -- + ------------- + + function vupkxpx (A : LL_VSS; Offset : Natural) return LL_VSI; + -- For vupkhpx and vupklpx (depending on Offset) + + function vupkxpx (A : LL_VSS; Offset : Natural) return LL_VSI is + VA : constant VUS_View := To_View (To_LL_VUS (A)); + K : Vshort_Range; + D : VUI_View; + P16 : Pixel_16; + P32 : Pixel_32; + + function Sign_Extend (X : Unsigned_1) return unsigned_char; + + function Sign_Extend (X : Unsigned_1) return unsigned_char is + begin + if X = 1 then + return 16#FF#; + else + return 16#00#; + end if; + end Sign_Extend; + + begin + for J in Vint_Range'Range loop + K := Vshort_Range (Integer (J) + - Integer (Vint_Range'First) + + Integer (Vshort_Range'First) + + Offset); + P16 := To_Pixel (VA.Values (K)); + P32.T := Sign_Extend (P16.T); + P32.R := unsigned_char (P16.R); + P32.G := unsigned_char (P16.G); + P32.B := unsigned_char (P16.B); + D.Values (J) := To_unsigned_int (P32); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vupkxpx; + + ------------- + -- vupkhpx -- + ------------- + + function vupkhpx (A : LL_VSS) return LL_VSI is + begin + return vupkxpx (A, 0); + end vupkhpx; + + ------------- + -- vupklsb -- + ------------- + + function vupklsb (A : LL_VSC) return LL_VSS is + VA : constant VSC_View := To_View (A); + D : VSS_View; + begin + D.Values := + LL_VSC_LL_VSS_Operations.vupkxsx (VA.Values, + Varray_signed_short'Length); + return To_Vector (D); + end vupklsb; + + ------------- + -- vupklsh -- + ------------- + + function vupklsh (A : LL_VSS) return LL_VSI is + VA : constant VSS_View := To_View (A); + D : VSI_View; + begin + D.Values := + LL_VSS_LL_VSI_Operations.vupkxsx (VA.Values, + Varray_signed_int'Length); + return To_Vector (D); + end vupklsh; + + ------------- + -- vupklpx -- + ------------- + + function vupklpx (A : LL_VSS) return LL_VSI is + begin + return vupkxpx (A, Varray_signed_int'Length); + end vupklpx; + + ---------- + -- vxor -- + ---------- + + function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI is + VA : constant VUI_View := To_View (To_LL_VUI (A)); + VB : constant VUI_View := To_View (To_LL_VUI (B)); + D : VUI_View; + + begin + for J in Vint_Range'Range loop + D.Values (J) := VA.Values (J) xor VB.Values (J); + end loop; + + return To_LL_VSI (To_Vector (D)); + end vxor; + + ---------------- + -- vcmpequb_p -- + ---------------- + + function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int is + D : LL_VSC; + begin + D := vcmpequb (B, C); + return LL_VSC_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpequb_p; + + ---------------- + -- vcmpequh_p -- + ---------------- + + function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int is + D : LL_VSS; + begin + D := vcmpequh (B, C); + return LL_VSS_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpequh_p; + + ---------------- + -- vcmpequw_p -- + ---------------- + + function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int is + D : LL_VSI; + begin + D := vcmpequw (B, C); + return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpequw_p; + + ---------------- + -- vcmpeqfp_p -- + ---------------- + + function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is + D : LL_VSI; + begin + D := vcmpeqfp (B, C); + return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpeqfp_p; + + ---------------- + -- vcmpgtub_p -- + ---------------- + + function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int is + D : LL_VSC; + begin + D := vcmpgtub (B, C); + return LL_VSC_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgtub_p; + + ---------------- + -- vcmpgtuh_p -- + ---------------- + + function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int is + D : LL_VSS; + begin + D := vcmpgtuh (B, C); + return LL_VSS_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgtuh_p; + + ---------------- + -- vcmpgtuw_p -- + ---------------- + + function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int is + D : LL_VSI; + begin + D := vcmpgtuw (B, C); + return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgtuw_p; + + ---------------- + -- vcmpgtsb_p -- + ---------------- + + function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int is + D : LL_VSC; + begin + D := vcmpgtsb (B, C); + return LL_VSC_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgtsb_p; + + ---------------- + -- vcmpgtsh_p -- + ---------------- + + function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int is + D : LL_VSS; + begin + D := vcmpgtsh (B, C); + return LL_VSS_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgtsh_p; + + ---------------- + -- vcmpgtsw_p -- + ---------------- + + function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int is + D : LL_VSI; + begin + D := vcmpgtsw (B, C); + return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgtsw_p; + + ---------------- + -- vcmpgefp_p -- + ---------------- + + function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is + D : LL_VSI; + begin + D := vcmpgefp (B, C); + return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgefp_p; + + ---------------- + -- vcmpgtfp_p -- + ---------------- + + function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is + D : LL_VSI; + begin + D := vcmpgtfp (B, C); + return LL_VSI_Operations.Check_CR6 (A, To_View (D).Values); + end vcmpgtfp_p; + + ---------------- + -- vcmpbfp_p -- + ---------------- + + function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int is + D : VSI_View; + begin + D := To_View (vcmpbfp (B, C)); + + for J in Vint_Range'Range loop + + -- vcmpbfp is not returning the usual bool vector; do the conversion + + D.Values (J) := + (if D.Values (J) = 0 then Signed_Bool_False else Signed_Bool_True); + end loop; + + return LL_VSI_Operations.Check_CR6 (A, D.Values); + end vcmpbfp_p; + +end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-alleve.ads b/gcc/ada/libgnat/g-alleve.ads new file mode 100644 index 0000000..5ecac0a --- /dev/null +++ b/gcc/ada/libgnat/g-alleve.ads @@ -0,0 +1,525 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . L O W _ L E V E L _ V E C T O R S -- +-- -- +-- S p e c -- +-- (Soft Binding Version) -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit exposes the low level vector support for the Soft binding, +-- intended for non AltiVec capable targets. See Altivec.Design for a +-- description of what is expected to be exposed. + +with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; + +package GNAT.Altivec.Low_Level_Vectors is + + ---------------------------------------- + -- Low level vector type declarations -- + ---------------------------------------- + + type LL_VUC is private; + type LL_VSC is private; + type LL_VBC is private; + + type LL_VUS is private; + type LL_VSS is private; + type LL_VBS is private; + + type LL_VUI is private; + type LL_VSI is private; + type LL_VBI is private; + + type LL_VF is private; + type LL_VP is private; + + ------------------------------------ + -- Low level functional interface -- + ------------------------------------ + + function abs_v16qi (A : LL_VSC) return LL_VSC; + function abs_v8hi (A : LL_VSS) return LL_VSS; + function abs_v4si (A : LL_VSI) return LL_VSI; + function abs_v4sf (A : LL_VF) return LL_VF; + + function abss_v16qi (A : LL_VSC) return LL_VSC; + function abss_v8hi (A : LL_VSS) return LL_VSS; + function abss_v4si (A : LL_VSI) return LL_VSI; + + function vaddubm (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vadduhm (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vadduwm (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vaddfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vaddcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vaddubs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vaddsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vadduhs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vaddshs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vadduws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vaddsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vand (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vandc (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vavgub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vavgsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vavguh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vavgsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vavguw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vavgsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vcmpbfp (A : LL_VF; B : LL_VF) return LL_VSI; + + function vcmpequb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpequh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpequw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpeqfp (A : LL_VF; B : LL_VF) return LL_VSI; + + function vcmpgefp (A : LL_VF; B : LL_VF) return LL_VSI; + + function vcmpgtub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpgtsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vcmpgtuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpgtsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vcmpgtuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpgtsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vcmpgtfp (A : LL_VF; B : LL_VF) return LL_VSI; + + function vcfux (A : LL_VUI; B : c_int) return LL_VF; + function vcfsx (A : LL_VSI; B : c_int) return LL_VF; + + function vctsxs (A : LL_VF; B : c_int) return LL_VSI; + function vctuxs (A : LL_VF; B : c_int) return LL_VUI; + + procedure dss (A : c_int); + procedure dssall; + + procedure dst (A : c_ptr; B : c_int; C : c_int); + procedure dstst (A : c_ptr; B : c_int; C : c_int); + procedure dststt (A : c_ptr; B : c_int; C : c_int); + procedure dstt (A : c_ptr; B : c_int; C : c_int); + + function vexptefp (A : LL_VF) return LL_VF; + + function vrfim (A : LL_VF) return LL_VF; + + function lvx (A : c_long; B : c_ptr) return LL_VSI; + function lvebx (A : c_long; B : c_ptr) return LL_VSC; + function lvehx (A : c_long; B : c_ptr) return LL_VSS; + function lvewx (A : c_long; B : c_ptr) return LL_VSI; + function lvxl (A : c_long; B : c_ptr) return LL_VSI; + + function vlogefp (A : LL_VF) return LL_VF; + + function lvsl (A : c_long; B : c_ptr) return LL_VSC; + function lvsr (A : c_long; B : c_ptr) return LL_VSC; + + function vmaddfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; + + function vmhaddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmaxub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmaxsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmaxuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmaxsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmaxuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmaxsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmaxfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vmrghb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmrghh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmrghw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vmrglb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vmrglh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vmrglw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function mfvscr return LL_VSS; + + function vminfp (A : LL_VF; B : LL_VF) return LL_VF; + function vminsb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vminsh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vminsw (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vminub (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vminuh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vminuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vmladduhm (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmhraddshs (A : LL_VSS; B : LL_VSS; C : LL_VSS) return LL_VSS; + + function vmsumubm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; + function vmsummbm (A : LL_VSC; B : LL_VSC; C : LL_VSI) return LL_VSI; + function vmsumuhm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumshm (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumuhs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + function vmsumshs (A : LL_VSS; B : LL_VSS; C : LL_VSI) return LL_VSI; + + procedure mtvscr (A : LL_VSI); + + function vmuleub (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmuleuh (A : LL_VSS; B : LL_VSS) return LL_VSI; + function vmulesb (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulesh (A : LL_VSS; B : LL_VSS) return LL_VSI; + + function vmulosb (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulosh (A : LL_VSS; B : LL_VSS) return LL_VSI; + function vmuloub (A : LL_VSC; B : LL_VSC) return LL_VSS; + function vmulouh (A : LL_VSS; B : LL_VSS) return LL_VSI; + + function vnmsubfp (A : LL_VF; B : LL_VF; C : LL_VF) return LL_VF; + + function vxor (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vnor (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vor (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vpkuhum (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkuwum (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkpx (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkuhus (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkuwus (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkshss (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkswss (A : LL_VSI; B : LL_VSI) return LL_VSS; + function vpkshus (A : LL_VSS; B : LL_VSS) return LL_VSC; + function vpkswus (A : LL_VSI; B : LL_VSI) return LL_VSS; + + function vperm_4si (A : LL_VSI; B : LL_VSI; C : LL_VSC) return LL_VSI; + + function vrefp (A : LL_VF) return LL_VF; + + function vrlb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vrlh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vrlw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vrfin (A : LL_VF) return LL_VF; + function vrfip (A : LL_VF) return LL_VF; + function vrfiz (A : LL_VF) return LL_VF; + + function vrsqrtefp (A : LL_VF) return LL_VF; + + function vsel_4si (A : LL_VSI; B : LL_VSI; C : LL_VSI) return LL_VSI; + + function vslb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vslh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vslw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsldoi_4si (A : LL_VSI; B : LL_VSI; C : c_int) return LL_VSI; + function vsldoi_8hi (A : LL_VSS; B : LL_VSS; C : c_int) return LL_VSS; + function vsldoi_16qi (A : LL_VSC; B : LL_VSC; C : c_int) return LL_VSC; + function vsldoi_4sf (A : LL_VF; B : LL_VF; C : c_int) return LL_VF; + + function vsl (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vslo (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vspltb (A : LL_VSC; B : c_int) return LL_VSC; + function vsplth (A : LL_VSS; B : c_int) return LL_VSS; + function vspltw (A : LL_VSI; B : c_int) return LL_VSI; + + function vspltisb (A : c_int) return LL_VSC; + function vspltish (A : c_int) return LL_VSS; + function vspltisw (A : c_int) return LL_VSI; + + function vsrb (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsrh (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsrw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsrab (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsrah (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsraw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsr (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsro (A : LL_VSI; B : LL_VSI) return LL_VSI; + + procedure stvx (A : LL_VSI; B : c_int; C : c_ptr); + procedure stvebx (A : LL_VSC; B : c_int; C : c_ptr); + procedure stvehx (A : LL_VSS; B : c_int; C : c_ptr); + procedure stvewx (A : LL_VSI; B : c_int; C : c_ptr); + procedure stvxl (A : LL_VSI; B : c_int; C : c_ptr); + + function vsububm (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubuhm (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubuwm (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsubfp (A : LL_VF; B : LL_VF) return LL_VF; + + function vsubcuw (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsububs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubsbs (A : LL_VSC; B : LL_VSC) return LL_VSC; + function vsubuhs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubshs (A : LL_VSS; B : LL_VSS) return LL_VSS; + function vsubuws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsubsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vsum4ubs (A : LL_VSC; B : LL_VSI) return LL_VSI; + function vsum4sbs (A : LL_VSC; B : LL_VSI) return LL_VSI; + function vsum4shs (A : LL_VSS; B : LL_VSI) return LL_VSI; + + function vsum2sws (A : LL_VSI; B : LL_VSI) return LL_VSI; + function vsumsws (A : LL_VSI; B : LL_VSI) return LL_VSI; + + function vupkhsb (A : LL_VSC) return LL_VSS; + function vupkhsh (A : LL_VSS) return LL_VSI; + function vupkhpx (A : LL_VSS) return LL_VSI; + + function vupklsb (A : LL_VSC) return LL_VSS; + function vupklsh (A : LL_VSS) return LL_VSI; + function vupklpx (A : LL_VSS) return LL_VSI; + + function vcmpequb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpequh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpequw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpeqfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + + function vcmpgtub_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpgtuh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpgtuw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpgtsb_p (A : c_int; B : LL_VSC; C : LL_VSC) return c_int; + function vcmpgtsh_p (A : c_int; B : LL_VSS; C : LL_VSS) return c_int; + function vcmpgtsw_p (A : c_int; B : LL_VSI; C : LL_VSI) return c_int; + function vcmpgtfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + + function vcmpgefp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + function vcmpbfp_p (A : c_int; B : LL_VF; C : LL_VF) return c_int; + +private + + --------------------------------------- + -- Low level vector type definitions -- + --------------------------------------- + + -- We simply use the natural array definitions corresponding to each + -- user-level vector type. + + type LL_VUI is new VUI_View; + type LL_VSI is new VSI_View; + type LL_VBI is new VBI_View; + + type LL_VUS is new VUS_View; + type LL_VSS is new VSS_View; + type LL_VBS is new VBS_View; + + type LL_VUC is new VUC_View; + type LL_VSC is new VSC_View; + type LL_VBC is new VBC_View; + + type LL_VF is new VF_View; + type LL_VP is new VP_View; + + ------------------------------------ + -- Low level functional interface -- + ------------------------------------ + + pragma Convention_Identifier (LL_Altivec, C); + + pragma Export (LL_Altivec, dss, "__builtin_altivec_dss"); + pragma Export (LL_Altivec, dssall, "__builtin_altivec_dssall"); + pragma Export (LL_Altivec, dst, "__builtin_altivec_dst"); + pragma Export (LL_Altivec, dstst, "__builtin_altivec_dstst"); + pragma Export (LL_Altivec, dststt, "__builtin_altivec_dststt"); + pragma Export (LL_Altivec, dstt, "__builtin_altivec_dstt"); + pragma Export (LL_Altivec, mtvscr, "__builtin_altivec_mtvscr"); + pragma Export (LL_Altivec, mfvscr, "__builtin_altivec_mfvscr"); + pragma Export (LL_Altivec, stvebx, "__builtin_altivec_stvebx"); + pragma Export (LL_Altivec, stvehx, "__builtin_altivec_stvehx"); + pragma Export (LL_Altivec, stvewx, "__builtin_altivec_stvewx"); + pragma Export (LL_Altivec, stvx, "__builtin_altivec_stvx"); + pragma Export (LL_Altivec, stvxl, "__builtin_altivec_stvxl"); + pragma Export (LL_Altivec, lvebx, "__builtin_altivec_lvebx"); + pragma Export (LL_Altivec, lvehx, "__builtin_altivec_lvehx"); + pragma Export (LL_Altivec, lvewx, "__builtin_altivec_lvewx"); + pragma Export (LL_Altivec, lvx, "__builtin_altivec_lvx"); + pragma Export (LL_Altivec, lvxl, "__builtin_altivec_lvxl"); + pragma Export (LL_Altivec, lvsl, "__builtin_altivec_lvsl"); + pragma Export (LL_Altivec, lvsr, "__builtin_altivec_lvsr"); + pragma Export (LL_Altivec, abs_v16qi, "__builtin_altivec_abs_v16qi"); + pragma Export (LL_Altivec, abs_v8hi, "__builtin_altivec_abs_v8hi"); + pragma Export (LL_Altivec, abs_v4si, "__builtin_altivec_abs_v4si"); + pragma Export (LL_Altivec, abs_v4sf, "__builtin_altivec_abs_v4sf"); + pragma Export (LL_Altivec, abss_v16qi, "__builtin_altivec_abss_v16qi"); + pragma Export (LL_Altivec, abss_v8hi, "__builtin_altivec_abss_v8hi"); + pragma Export (LL_Altivec, abss_v4si, "__builtin_altivec_abss_v4si"); + pragma Export (LL_Altivec, vaddcuw, "__builtin_altivec_vaddcuw"); + pragma Export (LL_Altivec, vaddfp, "__builtin_altivec_vaddfp"); + pragma Export (LL_Altivec, vaddsbs, "__builtin_altivec_vaddsbs"); + pragma Export (LL_Altivec, vaddshs, "__builtin_altivec_vaddshs"); + pragma Export (LL_Altivec, vaddsws, "__builtin_altivec_vaddsws"); + pragma Export (LL_Altivec, vaddubm, "__builtin_altivec_vaddubm"); + pragma Export (LL_Altivec, vaddubs, "__builtin_altivec_vaddubs"); + pragma Export (LL_Altivec, vadduhm, "__builtin_altivec_vadduhm"); + pragma Export (LL_Altivec, vadduhs, "__builtin_altivec_vadduhs"); + pragma Export (LL_Altivec, vadduwm, "__builtin_altivec_vadduwm"); + pragma Export (LL_Altivec, vadduws, "__builtin_altivec_vadduws"); + pragma Export (LL_Altivec, vand, "__builtin_altivec_vand"); + pragma Export (LL_Altivec, vandc, "__builtin_altivec_vandc"); + pragma Export (LL_Altivec, vavgsb, "__builtin_altivec_vavgsb"); + pragma Export (LL_Altivec, vavgsh, "__builtin_altivec_vavgsh"); + pragma Export (LL_Altivec, vavgsw, "__builtin_altivec_vavgsw"); + pragma Export (LL_Altivec, vavgub, "__builtin_altivec_vavgub"); + pragma Export (LL_Altivec, vavguh, "__builtin_altivec_vavguh"); + pragma Export (LL_Altivec, vavguw, "__builtin_altivec_vavguw"); + pragma Export (LL_Altivec, vcfsx, "__builtin_altivec_vcfsx"); + pragma Export (LL_Altivec, vcfux, "__builtin_altivec_vcfux"); + pragma Export (LL_Altivec, vcmpbfp, "__builtin_altivec_vcmpbfp"); + pragma Export (LL_Altivec, vcmpeqfp, "__builtin_altivec_vcmpeqfp"); + pragma Export (LL_Altivec, vcmpequb, "__builtin_altivec_vcmpequb"); + pragma Export (LL_Altivec, vcmpequh, "__builtin_altivec_vcmpequh"); + pragma Export (LL_Altivec, vcmpequw, "__builtin_altivec_vcmpequw"); + pragma Export (LL_Altivec, vcmpgefp, "__builtin_altivec_vcmpgefp"); + pragma Export (LL_Altivec, vcmpgtfp, "__builtin_altivec_vcmpgtfp"); + pragma Export (LL_Altivec, vcmpgtsb, "__builtin_altivec_vcmpgtsb"); + pragma Export (LL_Altivec, vcmpgtsh, "__builtin_altivec_vcmpgtsh"); + pragma Export (LL_Altivec, vcmpgtsw, "__builtin_altivec_vcmpgtsw"); + pragma Export (LL_Altivec, vcmpgtub, "__builtin_altivec_vcmpgtub"); + pragma Export (LL_Altivec, vcmpgtuh, "__builtin_altivec_vcmpgtuh"); + pragma Export (LL_Altivec, vcmpgtuw, "__builtin_altivec_vcmpgtuw"); + pragma Export (LL_Altivec, vctsxs, "__builtin_altivec_vctsxs"); + pragma Export (LL_Altivec, vctuxs, "__builtin_altivec_vctuxs"); + pragma Export (LL_Altivec, vexptefp, "__builtin_altivec_vexptefp"); + pragma Export (LL_Altivec, vlogefp, "__builtin_altivec_vlogefp"); + pragma Export (LL_Altivec, vmaddfp, "__builtin_altivec_vmaddfp"); + pragma Export (LL_Altivec, vmaxfp, "__builtin_altivec_vmaxfp"); + pragma Export (LL_Altivec, vmaxsb, "__builtin_altivec_vmaxsb"); + pragma Export (LL_Altivec, vmaxsh, "__builtin_altivec_vmaxsh"); + pragma Export (LL_Altivec, vmaxsw, "__builtin_altivec_vmaxsw"); + pragma Export (LL_Altivec, vmaxub, "__builtin_altivec_vmaxub"); + pragma Export (LL_Altivec, vmaxuh, "__builtin_altivec_vmaxuh"); + pragma Export (LL_Altivec, vmaxuw, "__builtin_altivec_vmaxuw"); + pragma Export (LL_Altivec, vmhaddshs, "__builtin_altivec_vmhaddshs"); + pragma Export (LL_Altivec, vmhraddshs, "__builtin_altivec_vmhraddshs"); + pragma Export (LL_Altivec, vminfp, "__builtin_altivec_vminfp"); + pragma Export (LL_Altivec, vminsb, "__builtin_altivec_vminsb"); + pragma Export (LL_Altivec, vminsh, "__builtin_altivec_vminsh"); + pragma Export (LL_Altivec, vminsw, "__builtin_altivec_vminsw"); + pragma Export (LL_Altivec, vminub, "__builtin_altivec_vminub"); + pragma Export (LL_Altivec, vminuh, "__builtin_altivec_vminuh"); + pragma Export (LL_Altivec, vminuw, "__builtin_altivec_vminuw"); + pragma Export (LL_Altivec, vmladduhm, "__builtin_altivec_vmladduhm"); + pragma Export (LL_Altivec, vmrghb, "__builtin_altivec_vmrghb"); + pragma Export (LL_Altivec, vmrghh, "__builtin_altivec_vmrghh"); + pragma Export (LL_Altivec, vmrghw, "__builtin_altivec_vmrghw"); + pragma Export (LL_Altivec, vmrglb, "__builtin_altivec_vmrglb"); + pragma Export (LL_Altivec, vmrglh, "__builtin_altivec_vmrglh"); + pragma Export (LL_Altivec, vmrglw, "__builtin_altivec_vmrglw"); + pragma Export (LL_Altivec, vmsummbm, "__builtin_altivec_vmsummbm"); + pragma Export (LL_Altivec, vmsumshm, "__builtin_altivec_vmsumshm"); + pragma Export (LL_Altivec, vmsumshs, "__builtin_altivec_vmsumshs"); + pragma Export (LL_Altivec, vmsumubm, "__builtin_altivec_vmsumubm"); + pragma Export (LL_Altivec, vmsumuhm, "__builtin_altivec_vmsumuhm"); + pragma Export (LL_Altivec, vmsumuhs, "__builtin_altivec_vmsumuhs"); + pragma Export (LL_Altivec, vmulesb, "__builtin_altivec_vmulesb"); + pragma Export (LL_Altivec, vmulesh, "__builtin_altivec_vmulesh"); + pragma Export (LL_Altivec, vmuleub, "__builtin_altivec_vmuleub"); + pragma Export (LL_Altivec, vmuleuh, "__builtin_altivec_vmuleuh"); + pragma Export (LL_Altivec, vmulosb, "__builtin_altivec_vmulosb"); + pragma Export (LL_Altivec, vmulosh, "__builtin_altivec_vmulosh"); + pragma Export (LL_Altivec, vmuloub, "__builtin_altivec_vmuloub"); + pragma Export (LL_Altivec, vmulouh, "__builtin_altivec_vmulouh"); + pragma Export (LL_Altivec, vnmsubfp, "__builtin_altivec_vnmsubfp"); + pragma Export (LL_Altivec, vnor, "__builtin_altivec_vnor"); + pragma Export (LL_Altivec, vxor, "__builtin_altivec_vxor"); + pragma Export (LL_Altivec, vor, "__builtin_altivec_vor"); + pragma Export (LL_Altivec, vperm_4si, "__builtin_altivec_vperm_4si"); + pragma Export (LL_Altivec, vpkpx, "__builtin_altivec_vpkpx"); + pragma Export (LL_Altivec, vpkshss, "__builtin_altivec_vpkshss"); + pragma Export (LL_Altivec, vpkshus, "__builtin_altivec_vpkshus"); + pragma Export (LL_Altivec, vpkswss, "__builtin_altivec_vpkswss"); + pragma Export (LL_Altivec, vpkswus, "__builtin_altivec_vpkswus"); + pragma Export (LL_Altivec, vpkuhum, "__builtin_altivec_vpkuhum"); + pragma Export (LL_Altivec, vpkuhus, "__builtin_altivec_vpkuhus"); + pragma Export (LL_Altivec, vpkuwum, "__builtin_altivec_vpkuwum"); + pragma Export (LL_Altivec, vpkuwus, "__builtin_altivec_vpkuwus"); + pragma Export (LL_Altivec, vrefp, "__builtin_altivec_vrefp"); + pragma Export (LL_Altivec, vrfim, "__builtin_altivec_vrfim"); + pragma Export (LL_Altivec, vrfin, "__builtin_altivec_vrfin"); + pragma Export (LL_Altivec, vrfip, "__builtin_altivec_vrfip"); + pragma Export (LL_Altivec, vrfiz, "__builtin_altivec_vrfiz"); + pragma Export (LL_Altivec, vrlb, "__builtin_altivec_vrlb"); + pragma Export (LL_Altivec, vrlh, "__builtin_altivec_vrlh"); + pragma Export (LL_Altivec, vrlw, "__builtin_altivec_vrlw"); + pragma Export (LL_Altivec, vrsqrtefp, "__builtin_altivec_vrsqrtefp"); + pragma Export (LL_Altivec, vsel_4si, "__builtin_altivec_vsel_4si"); + pragma Export (LL_Altivec, vsldoi_4si, "__builtin_altivec_vsldoi_4si"); + pragma Export (LL_Altivec, vsldoi_8hi, "__builtin_altivec_vsldoi_8hi"); + pragma Export (LL_Altivec, vsldoi_16qi, "__builtin_altivec_vsldoi_16qi"); + pragma Export (LL_Altivec, vsldoi_4sf, "__builtin_altivec_vsldoi_4sf"); + pragma Export (LL_Altivec, vsl, "__builtin_altivec_vsl"); + pragma Export (LL_Altivec, vslb, "__builtin_altivec_vslb"); + pragma Export (LL_Altivec, vslh, "__builtin_altivec_vslh"); + pragma Export (LL_Altivec, vslo, "__builtin_altivec_vslo"); + pragma Export (LL_Altivec, vslw, "__builtin_altivec_vslw"); + pragma Export (LL_Altivec, vspltb, "__builtin_altivec_vspltb"); + pragma Export (LL_Altivec, vsplth, "__builtin_altivec_vsplth"); + pragma Export (LL_Altivec, vspltisb, "__builtin_altivec_vspltisb"); + pragma Export (LL_Altivec, vspltish, "__builtin_altivec_vspltish"); + pragma Export (LL_Altivec, vspltisw, "__builtin_altivec_vspltisw"); + pragma Export (LL_Altivec, vspltw, "__builtin_altivec_vspltw"); + pragma Export (LL_Altivec, vsr, "__builtin_altivec_vsr"); + pragma Export (LL_Altivec, vsrab, "__builtin_altivec_vsrab"); + pragma Export (LL_Altivec, vsrah, "__builtin_altivec_vsrah"); + pragma Export (LL_Altivec, vsraw, "__builtin_altivec_vsraw"); + pragma Export (LL_Altivec, vsrb, "__builtin_altivec_vsrb"); + pragma Export (LL_Altivec, vsrh, "__builtin_altivec_vsrh"); + pragma Export (LL_Altivec, vsro, "__builtin_altivec_vsro"); + pragma Export (LL_Altivec, vsrw, "__builtin_altivec_vsrw"); + pragma Export (LL_Altivec, vsubcuw, "__builtin_altivec_vsubcuw"); + pragma Export (LL_Altivec, vsubfp, "__builtin_altivec_vsubfp"); + pragma Export (LL_Altivec, vsubsbs, "__builtin_altivec_vsubsbs"); + pragma Export (LL_Altivec, vsubshs, "__builtin_altivec_vsubshs"); + pragma Export (LL_Altivec, vsubsws, "__builtin_altivec_vsubsws"); + pragma Export (LL_Altivec, vsububm, "__builtin_altivec_vsububm"); + pragma Export (LL_Altivec, vsububs, "__builtin_altivec_vsububs"); + pragma Export (LL_Altivec, vsubuhm, "__builtin_altivec_vsubuhm"); + pragma Export (LL_Altivec, vsubuhs, "__builtin_altivec_vsubuhs"); + pragma Export (LL_Altivec, vsubuwm, "__builtin_altivec_vsubuwm"); + pragma Export (LL_Altivec, vsubuws, "__builtin_altivec_vsubuws"); + pragma Export (LL_Altivec, vsum2sws, "__builtin_altivec_vsum2sws"); + pragma Export (LL_Altivec, vsum4sbs, "__builtin_altivec_vsum4sbs"); + pragma Export (LL_Altivec, vsum4shs, "__builtin_altivec_vsum4shs"); + pragma Export (LL_Altivec, vsum4ubs, "__builtin_altivec_vsum4ubs"); + pragma Export (LL_Altivec, vsumsws, "__builtin_altivec_vsumsws"); + pragma Export (LL_Altivec, vupkhpx, "__builtin_altivec_vupkhpx"); + pragma Export (LL_Altivec, vupkhsb, "__builtin_altivec_vupkhsb"); + pragma Export (LL_Altivec, vupkhsh, "__builtin_altivec_vupkhsh"); + pragma Export (LL_Altivec, vupklpx, "__builtin_altivec_vupklpx"); + pragma Export (LL_Altivec, vupklsb, "__builtin_altivec_vupklsb"); + pragma Export (LL_Altivec, vupklsh, "__builtin_altivec_vupklsh"); + pragma Export (LL_Altivec, vcmpbfp_p, "__builtin_altivec_vcmpbfp_p"); + pragma Export (LL_Altivec, vcmpeqfp_p, "__builtin_altivec_vcmpeqfp_p"); + pragma Export (LL_Altivec, vcmpgefp_p, "__builtin_altivec_vcmpgefp_p"); + pragma Export (LL_Altivec, vcmpgtfp_p, "__builtin_altivec_vcmpgtfp_p"); + pragma Export (LL_Altivec, vcmpequw_p, "__builtin_altivec_vcmpequw_p"); + pragma Export (LL_Altivec, vcmpgtsw_p, "__builtin_altivec_vcmpgtsw_p"); + pragma Export (LL_Altivec, vcmpgtuw_p, "__builtin_altivec_vcmpgtuw_p"); + pragma Export (LL_Altivec, vcmpgtuh_p, "__builtin_altivec_vcmpgtuh_p"); + pragma Export (LL_Altivec, vcmpgtsh_p, "__builtin_altivec_vcmpgtsh_p"); + pragma Export (LL_Altivec, vcmpequh_p, "__builtin_altivec_vcmpequh_p"); + pragma Export (LL_Altivec, vcmpequb_p, "__builtin_altivec_vcmpequb_p"); + pragma Export (LL_Altivec, vcmpgtsb_p, "__builtin_altivec_vcmpgtsb_p"); + pragma Export (LL_Altivec, vcmpgtub_p, "__builtin_altivec_vcmpgtub_p"); + +end GNAT.Altivec.Low_Level_Vectors; diff --git a/gcc/ada/libgnat/g-altcon.adb b/gcc/ada/libgnat/g-altcon.adb new file mode 100644 index 0000000..8cce5a8 --- /dev/null +++ b/gcc/ada/libgnat/g-altcon.adb @@ -0,0 +1,514 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . C O N V E R S I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with System; use System; + +package body GNAT.Altivec.Conversions is + + -- All the vector/view conversions operate similarly: bare unchecked + -- conversion on big endian targets, and elements permutation on little + -- endian targets. We call "Mirroring" the elements permutation process. + + -- We would like to provide a generic version of the conversion routines + -- and just have a set of "renaming as body" declarations to satisfy the + -- public interface. This unfortunately prevents inlining, which we must + -- preserve at least for the hard binding. + + -- We instead provide a generic version of facilities needed by all the + -- conversion routines and use them repeatedly. + + generic + type Vitem_Type is private; + + type Varray_Index_Type is range <>; + type Varray_Type is array (Varray_Index_Type) of Vitem_Type; + + type Vector_Type is private; + type View_Type is private; + + package Generic_Conversions is + + subtype Varray is Varray_Type; + -- This provides an easy common way to refer to the type parameter + -- in contexts where a specific instance of this package is "use"d. + + procedure Mirror (A : Varray_Type; Into : out Varray_Type); + pragma Inline (Mirror); + -- Mirror the elements of A into INTO, not touching the per-element + -- internal ordering. + + -- A procedure with an out parameter is a bit heavier to use than a + -- function but reduces the amount of temporary creations around the + -- call. Instances are typically not front-end inlined. They can still + -- be back-end inlined on request with the proper command-line option. + + -- Below are Unchecked Conversion routines for various purposes, + -- relying on internal knowledge about the bits layout in the different + -- types (all 128 value bits blocks). + + -- View<->Vector straight bitwise conversions on BE targets + + function UNC_To_Vector is + new Ada.Unchecked_Conversion (View_Type, Vector_Type); + + function UNC_To_View is + new Ada.Unchecked_Conversion (Vector_Type, View_Type); + + -- Varray->Vector/View for returning mirrored results on LE targets + + function UNC_To_Vector is + new Ada.Unchecked_Conversion (Varray_Type, Vector_Type); + + function UNC_To_View is + new Ada.Unchecked_Conversion (Varray_Type, View_Type); + + -- Vector/View->Varray for to-be-permuted source on LE targets + + function UNC_To_Varray is + new Ada.Unchecked_Conversion (Vector_Type, Varray_Type); + + function UNC_To_Varray is + new Ada.Unchecked_Conversion (View_Type, Varray_Type); + + end Generic_Conversions; + + package body Generic_Conversions is + + procedure Mirror (A : Varray_Type; Into : out Varray_Type) is + begin + for J in A'Range loop + Into (J) := A (A'Last - J + A'First); + end loop; + end Mirror; + + end Generic_Conversions; + + -- Now we declare the instances and implement the interface function + -- bodies simply calling the instantiated routines. + + --------------------- + -- Char components -- + --------------------- + + package SC_Conversions is new Generic_Conversions + (signed_char, Vchar_Range, Varray_signed_char, VSC, VSC_View); + + function To_Vector (S : VSC_View) return VSC is + use SC_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VSC) return VSC_View is + use SC_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + -- + + package UC_Conversions is new Generic_Conversions + (unsigned_char, Vchar_Range, Varray_unsigned_char, VUC, VUC_View); + + function To_Vector (S : VUC_View) return VUC is + use UC_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VUC) return VUC_View is + use UC_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + -- + + package BC_Conversions is new Generic_Conversions + (bool_char, Vchar_Range, Varray_bool_char, VBC, VBC_View); + + function To_Vector (S : VBC_View) return VBC is + use BC_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VBC) return VBC_View is + use BC_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + ---------------------- + -- Short components -- + ---------------------- + + package SS_Conversions is new Generic_Conversions + (signed_short, Vshort_Range, Varray_signed_short, VSS, VSS_View); + + function To_Vector (S : VSS_View) return VSS is + use SS_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VSS) return VSS_View is + use SS_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + -- + + package US_Conversions is new Generic_Conversions + (unsigned_short, Vshort_Range, Varray_unsigned_short, VUS, VUS_View); + + function To_Vector (S : VUS_View) return VUS is + use US_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VUS) return VUS_View is + use US_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + -- + + package BS_Conversions is new Generic_Conversions + (bool_short, Vshort_Range, Varray_bool_short, VBS, VBS_View); + + function To_Vector (S : VBS_View) return VBS is + use BS_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VBS) return VBS_View is + use BS_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + -------------------- + -- Int components -- + -------------------- + + package SI_Conversions is new Generic_Conversions + (signed_int, Vint_Range, Varray_signed_int, VSI, VSI_View); + + function To_Vector (S : VSI_View) return VSI is + use SI_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VSI) return VSI_View is + use SI_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + -- + + package UI_Conversions is new Generic_Conversions + (unsigned_int, Vint_Range, Varray_unsigned_int, VUI, VUI_View); + + function To_Vector (S : VUI_View) return VUI is + use UI_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VUI) return VUI_View is + use UI_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + -- + + package BI_Conversions is new Generic_Conversions + (bool_int, Vint_Range, Varray_bool_int, VBI, VBI_View); + + function To_Vector (S : VBI_View) return VBI is + use BI_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VBI) return VBI_View is + use BI_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + ---------------------- + -- Float components -- + ---------------------- + + package F_Conversions is new Generic_Conversions + (C_float, Vfloat_Range, Varray_float, VF, VF_View); + + function To_Vector (S : VF_View) return VF is + use F_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VF) return VF_View is + use F_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + + ---------------------- + -- Pixel components -- + ---------------------- + + package P_Conversions is new Generic_Conversions + (pixel, Vpixel_Range, Varray_pixel, VP, VP_View); + + function To_Vector (S : VP_View) return VP is + use P_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_Vector (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_Vector (M); + end; + end if; + end To_Vector; + + function To_View (S : VP) return VP_View is + use P_Conversions; + begin + if Default_Bit_Order = High_Order_First then + return UNC_To_View (S); + else + declare + M : Varray; + begin + Mirror (UNC_To_Varray (S), Into => M); + return UNC_To_View (M); + end; + end if; + end To_View; + +end GNAT.Altivec.Conversions; diff --git a/gcc/ada/libgnat/g-altcon.ads b/gcc/ada/libgnat/g-altcon.ads new file mode 100644 index 0000000..b43cb65 --- /dev/null +++ b/gcc/ada/libgnat/g-altcon.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . C O N V E R S I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides the Vector/Views conversions + +with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; +with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; + +package GNAT.Altivec.Conversions is + + --------------------- + -- char components -- + --------------------- + + function To_Vector (S : VUC_View) return VUC; + function To_Vector (S : VSC_View) return VSC; + function To_Vector (S : VBC_View) return VBC; + + function To_View (S : VUC) return VUC_View; + function To_View (S : VSC) return VSC_View; + function To_View (S : VBC) return VBC_View; + + ---------------------- + -- short components -- + ---------------------- + + function To_Vector (S : VUS_View) return VUS; + function To_Vector (S : VSS_View) return VSS; + function To_Vector (S : VBS_View) return VBS; + + function To_View (S : VUS) return VUS_View; + function To_View (S : VSS) return VSS_View; + function To_View (S : VBS) return VBS_View; + + -------------------- + -- int components -- + -------------------- + + function To_Vector (S : VUI_View) return VUI; + function To_Vector (S : VSI_View) return VSI; + function To_Vector (S : VBI_View) return VBI; + + function To_View (S : VUI) return VUI_View; + function To_View (S : VSI) return VSI_View; + function To_View (S : VBI) return VBI_View; + + ---------------------- + -- float components -- + ---------------------- + + function To_Vector (S : VF_View) return VF; + + function To_View (S : VF) return VF_View; + + ---------------------- + -- pixel components -- + ---------------------- + + function To_Vector (S : VP_View) return VP; + + function To_View (S : VP) return VP_View; + +private + + -- We want the above subprograms to always be inlined in the case of the + -- hard PowerPC AltiVec support in order to avoid the unnecessary function + -- call. On the other hand there is no problem with inlining these + -- subprograms on little-endian targets. + + pragma Inline_Always (To_Vector); + pragma Inline_Always (To_View); + +end GNAT.Altivec.Conversions; diff --git a/gcc/ada/libgnat/g-altive.ads b/gcc/ada/libgnat/g-altive.ads new file mode 100644 index 0000000..1e247b3 --- /dev/null +++ b/gcc/ada/libgnat/g-altive.ads @@ -0,0 +1,766 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------- +-- General description -- +------------------------- + +-- This is the root of a package hierarchy offering an Ada binding to the +-- PowerPC AltiVec extensions, a set of 128bit vector types together with a +-- set of subprograms operating on them. Relevant documents are: + +-- o AltiVec Technology, Programming Interface Manual (1999-06) +-- to which we will refer as [PIM], describes the data types, the +-- functional interface and the ABI conventions. + +-- o AltiVec Technology, Programming Environments Manual (2002-02) +-- to which we will refer as [PEM], describes the hardware architecture +-- and instruction set. + +-- These documents, as well as a number of others of general interest on the +-- AltiVec technology, are available from the Motorola/AltiVec Web site at: + +-- http://www.freescale.com/altivec + +-- The binding interface is structured to allow alternate implementations: +-- for real AltiVec capable targets, and for other targets. In the latter +-- case, everything is emulated in software. The two versions are referred +-- to as: + +-- o The Hard binding for AltiVec capable targets (with the appropriate +-- hardware support and corresponding instruction set) + +-- o The Soft binding for other targets (with the low level primitives +-- emulated in software). + +-- In addition, interfaces that are not strictly part of the base AltiVec API +-- are provided, such as vector conversions to and from array representations, +-- which are of interest for client applications (e.g. for vector +-- initialization purposes). + +-- Only the soft binding is available today + +----------------------------------------- +-- General package architecture survey -- +----------------------------------------- + +-- The various vector representations are all "containers" of elementary +-- values, the possible types of which are declared in this root package to +-- be generally accessible. + +-- From the user standpoint, the binding materializes as a consistent +-- hierarchy of units: + +-- GNAT.Altivec +-- (component types) +-- | +-- o----------------o----------------o-------------o +-- | | | | +-- Vector_Types Vector_Operations Vector_Views Conversions + +-- Users can manipulate vectors through two families of types: Vector +-- types and View types. + +-- Vector types are available through the Vector_Types and Vector_Operations +-- packages, which implement the core binding to the AltiVec API, as +-- described in [PIM-2.1 data types] and [PIM-4 AltiVec operations and +-- predicates]. + +-- The layout of Vector objects is dependant on the target machine +-- endianness, and View types were devised to offer a higher level user +-- interface. With Views, a vector of 4 uints (1, 2, 3, 4) is always declared +-- with a VUI_View := (Values => (1, 2, 3, 4)), element 1 first, natural +-- notation to denote the element values, and indexed notation is available +-- to access individual elements. + +-- View types do not represent Altivec vectors per se, in the sense that the +-- Altivec_Operations are not available for them. They are intended to allow +-- Vector initializations as well as access to the Vector component values. + +-- The GNAT.Altivec.Conversions package is provided to convert a View to the +-- corresponding Vector and vice-versa. + +--------------------------- +-- Underlying principles -- +--------------------------- + +-- Internally, the binding relies on an abstraction of the Altivec API, a +-- rich set of functions around a core of low level primitives mapping to +-- AltiVec instructions. See for instance "vec_add" in [PIM-4.4 Generic and +-- Specific AltiVec operations], with no less than six result/arguments +-- combinations of byte vector types that map to "vaddubm". + +-- The "soft" version is a software emulation of the low level primitives. + +-- The "hard" version would map to real AltiVec instructions via GCC builtins +-- and inlining. + +-- See the "Design Notes" section below for additional details on the +-- internals. + +------------------- +-- Example usage -- +------------------- + +-- Here is a sample program declaring and initializing two vectors, 'add'ing +-- them and displaying the result components: + +-- with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; +-- with GNAT.Altivec.Vector_Operations; use GNAT.Altivec.Vector_Operations; +-- with GNAT.Altivec.Vector_Views; use GNAT.Altivec.Vector_Views; +-- with GNAT.Altivec.Conversions; use GNAT.Altivec.Conversions; + +-- use GNAT.Altivec; + +-- with Ada.Text_IO; use Ada.Text_IO; + +-- procedure Sample is +-- Va : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4))); +-- Vb : Vector_Unsigned_Int := To_Vector ((Values => (1, 2, 3, 4))); + +-- Vs : Vector_Unsigned_Int; +-- Vs_View : VUI_View; +-- begin +-- Vs := Vec_Add (Va, Vb); +-- Vs_View := To_View (Vs); + +-- for I in Vs_View.Values'Range loop +-- Put_Line (Unsigned_Int'Image (Vs_View.Values (I))); +-- end loop; +-- end; + +-- $ gnatmake sample.adb +-- [...] +-- $ ./sample +-- 2 +-- 4 +-- 6 +-- 8 + +------------------------------------------------------------------------------ + +with System; + +package GNAT.Altivec is + + -- Definitions of constants and vector/array component types common to all + -- the versions of the binding. + + -- All the vector types are 128bits + + VECTOR_BIT : constant := 128; + + ------------------------------------------- + -- [PIM-2.3.1 Alignment of vector types] -- + ------------------------------------------- + + -- "A defined data item of any vector data type in memory is always + -- aligned on a 16-byte boundary. A pointer to any vector data type always + -- points to a 16-byte boundary. The compiler is responsible for aligning + -- vector data types on 16-byte boundaries." + + VECTOR_ALIGNMENT : constant := Natural'Min (16, Standard'Maximum_Alignment); + -- This value is used to set the alignment of vector datatypes in both the + -- hard and the soft binding implementations. + -- + -- We want this value to never be greater than 16, because none of the + -- binding implementations requires larger alignments and such a value + -- would cause useless space to be allocated/wasted for vector objects. + -- Furthermore, the alignment of 16 matches the hard binding leading to + -- a more faithful emulation. + -- + -- It needs to be exactly 16 for the hard binding, and the initializing + -- expression is just right for this purpose since Maximum_Alignment is + -- expected to be 16 for the real Altivec ABI. + -- + -- The soft binding doesn't rely on strict 16byte alignment, and we want + -- the value to be no greater than Standard'Maximum_Alignment in this case + -- to ensure it is supported on every possible target. + + ------------------------------------------------------- + -- [PIM-2.1] Data Types - Interpretation of contents -- + ------------------------------------------------------- + + --------------------- + -- char components -- + --------------------- + + CHAR_BIT : constant := 8; + SCHAR_MIN : constant := -2 ** (CHAR_BIT - 1); + SCHAR_MAX : constant := 2 ** (CHAR_BIT - 1) - 1; + UCHAR_MAX : constant := 2 ** CHAR_BIT - 1; + + type unsigned_char is mod UCHAR_MAX + 1; + for unsigned_char'Size use CHAR_BIT; + + type signed_char is range SCHAR_MIN .. SCHAR_MAX; + for signed_char'Size use CHAR_BIT; + + subtype bool_char is unsigned_char; + -- ??? There is a difference here between what the Altivec Technology + -- Programming Interface Manual says and what GCC says. In the manual, + -- vector_bool_char is a vector_unsigned_char, while in altivec.h it + -- is a vector_signed_char. + + bool_char_True : constant bool_char := bool_char'Last; + bool_char_False : constant bool_char := 0; + + ---------------------- + -- short components -- + ---------------------- + + SHORT_BIT : constant := 16; + SSHORT_MIN : constant := -2 ** (SHORT_BIT - 1); + SSHORT_MAX : constant := 2 ** (SHORT_BIT - 1) - 1; + USHORT_MAX : constant := 2 ** SHORT_BIT - 1; + + type unsigned_short is mod USHORT_MAX + 1; + for unsigned_short'Size use SHORT_BIT; + + subtype unsigned_short_int is unsigned_short; + + type signed_short is range SSHORT_MIN .. SSHORT_MAX; + for signed_short'Size use SHORT_BIT; + + subtype signed_short_int is signed_short; + + subtype bool_short is unsigned_short; + -- ??? See bool_char + + bool_short_True : constant bool_short := bool_short'Last; + bool_short_False : constant bool_short := 0; + + subtype bool_short_int is bool_short; + + -------------------- + -- int components -- + -------------------- + + INT_BIT : constant := 32; + SINT_MIN : constant := -2 ** (INT_BIT - 1); + SINT_MAX : constant := 2 ** (INT_BIT - 1) - 1; + UINT_MAX : constant := 2 ** INT_BIT - 1; + + type unsigned_int is mod UINT_MAX + 1; + for unsigned_int'Size use INT_BIT; + + type signed_int is range SINT_MIN .. SINT_MAX; + for signed_int'Size use INT_BIT; + + subtype bool_int is unsigned_int; + -- ??? See bool_char + + bool_int_True : constant bool_int := bool_int'Last; + bool_int_False : constant bool_int := 0; + + ---------------------- + -- float components -- + ---------------------- + + FLOAT_BIT : constant := 32; + FLOAT_DIGIT : constant := 6; + FLOAT_MIN : constant := -16#0.FFFF_FF#E+32; + FLOAT_MAX : constant := 16#0.FFFF_FF#E+32; + + type C_float is digits FLOAT_DIGIT range FLOAT_MIN .. FLOAT_MAX; + for C_float'Size use FLOAT_BIT; + -- Altivec operations always use the standard native floating-point + -- support of the target. Note that this means that there may be + -- minor differences in results between targets when the floating- + -- point implementations are slightly different, as would happen + -- with normal non-Altivec floating-point operations. In particular + -- the Altivec simulations may yield slightly different results + -- from those obtained on a true hardware Altivec target if the + -- floating-point implementation is not 100% compatible. + + ---------------------- + -- pixel components -- + ---------------------- + + subtype pixel is unsigned_short; + + ----------------------------------------------------------- + -- Subtypes for variants found in the GCC implementation -- + ----------------------------------------------------------- + + subtype c_int is signed_int; + subtype c_short is c_int; + + LONG_BIT : constant := 32; + -- Some of the GCC builtins are built with "long" arguments and + -- expect SImode to come in. + + SLONG_MIN : constant := -2 ** (LONG_BIT - 1); + SLONG_MAX : constant := 2 ** (LONG_BIT - 1) - 1; + ULONG_MAX : constant := 2 ** LONG_BIT - 1; + + type signed_long is range SLONG_MIN .. SLONG_MAX; + type unsigned_long is mod ULONG_MAX + 1; + + subtype c_long is signed_long; + + subtype c_ptr is System.Address; + + --------------------------------------------------------- + -- Access types, for the sake of some argument passing -- + --------------------------------------------------------- + + type signed_char_ptr is access all signed_char; + type unsigned_char_ptr is access all unsigned_char; + + type short_ptr is access all c_short; + type signed_short_ptr is access all signed_short; + type unsigned_short_ptr is access all unsigned_short; + + type int_ptr is access all c_int; + type signed_int_ptr is access all signed_int; + type unsigned_int_ptr is access all unsigned_int; + + type long_ptr is access all c_long; + type signed_long_ptr is access all signed_long; + type unsigned_long_ptr is access all unsigned_long; + + type float_ptr is access all Float; + + -- + + type const_signed_char_ptr is access constant signed_char; + type const_unsigned_char_ptr is access constant unsigned_char; + + type const_short_ptr is access constant c_short; + type const_signed_short_ptr is access constant signed_short; + type const_unsigned_short_ptr is access constant unsigned_short; + + type const_int_ptr is access constant c_int; + type const_signed_int_ptr is access constant signed_int; + type const_unsigned_int_ptr is access constant unsigned_int; + + type const_long_ptr is access constant c_long; + type const_signed_long_ptr is access constant signed_long; + type const_unsigned_long_ptr is access constant unsigned_long; + + type const_float_ptr is access constant Float; + + -- Access to const volatile arguments need specialized types + + type volatile_float is new Float; + pragma Volatile (volatile_float); + + type volatile_signed_char is new signed_char; + pragma Volatile (volatile_signed_char); + + type volatile_unsigned_char is new unsigned_char; + pragma Volatile (volatile_unsigned_char); + + type volatile_signed_short is new signed_short; + pragma Volatile (volatile_signed_short); + + type volatile_unsigned_short is new unsigned_short; + pragma Volatile (volatile_unsigned_short); + + type volatile_signed_int is new signed_int; + pragma Volatile (volatile_signed_int); + + type volatile_unsigned_int is new unsigned_int; + pragma Volatile (volatile_unsigned_int); + + type volatile_signed_long is new signed_long; + pragma Volatile (volatile_signed_long); + + type volatile_unsigned_long is new unsigned_long; + pragma Volatile (volatile_unsigned_long); + + type constv_char_ptr is access constant volatile_signed_char; + type constv_signed_char_ptr is access constant volatile_signed_char; + type constv_unsigned_char_ptr is access constant volatile_unsigned_char; + + type constv_short_ptr is access constant volatile_signed_short; + type constv_signed_short_ptr is access constant volatile_signed_short; + type constv_unsigned_short_ptr is access constant volatile_unsigned_short; + + type constv_int_ptr is access constant volatile_signed_int; + type constv_signed_int_ptr is access constant volatile_signed_int; + type constv_unsigned_int_ptr is access constant volatile_unsigned_int; + + type constv_long_ptr is access constant volatile_signed_long; + type constv_signed_long_ptr is access constant volatile_signed_long; + type constv_unsigned_long_ptr is access constant volatile_unsigned_long; + + type constv_float_ptr is access constant volatile_float; + +private + + ----------------------- + -- Various constants -- + ----------------------- + + CR6_EQ : constant := 0; + CR6_EQ_REV : constant := 1; + CR6_LT : constant := 2; + CR6_LT_REV : constant := 3; + +end GNAT.Altivec; + +-------------------- +-- Design Notes -- +-------------------- + +------------------------ +-- General principles -- +------------------------ + +-- The internal organization has been devised from a number of driving ideas: + +-- o From the clients standpoint, the two versions of the binding should be +-- as easily exchangable as possible, + +-- o From the maintenance standpoint, we want to avoid as much code +-- duplication as possible. + +-- o From both standpoints above, we want to maintain a clear interface +-- separation between the base bindings to the Motorola API and the +-- additional facilities. + +-- The identification of the low level interface is directly inspired by the +-- the base API organization, basically consisting of a rich set of functions +-- around a core of low level primitives mapping to AltiVec instructions. + +-- See for instance "vec_add" in [PIM-4.4 Generic and Specific AltiVec +-- operations]: no less than six result/arguments combinations of byte vector +-- types map to "vaddubm". + +-- The "hard" version of the low level primitives map to real AltiVec +-- instructions via the corresponding GCC builtins. The "soft" version is +-- a software emulation of those. + +--------------------------------------- +-- The Low_Level_Vectors abstraction -- +--------------------------------------- + +-- The AltiVec C interface spirit is to map a large set of C functions down +-- to a much smaller set of AltiVec instructions, most of them operating on a +-- set of vector data types in a transparent manner. See for instance the +-- case of vec_add, which maps six combinations of result/argument types to +-- vaddubm for signed/unsigned/bool variants of 'char' components. + +-- The GCC implementation of this idiom for C/C++ is to setup builtins +-- corresponding to the instructions and to expose the C user function as +-- wrappers around those builtins with no-op type conversions as required. +-- Typically, for the vec_add case mentioned above, we have (altivec.h): +-- +-- inline __vector signed char +-- vec_add (__vector signed char a1, __vector signed char a2) +-- { +-- return (__vector signed char) +-- __builtin_altivec_vaddubm ((__vector signed char) a1, +-- (__vector signed char) a2); +-- } + +-- inline __vector unsigned char +-- vec_add (__vector __bool char a1, __vector unsigned char a2) +-- { +-- return (__vector unsigned char) +-- __builtin_altivec_vaddubm ((__vector signed char) a1, +-- (__vector signed char) a2); +-- } + +-- The central idea for the Ada bindings is to leverage on the existing GCC +-- architecture, with the introduction of a Low_Level_Vectors abstraction. +-- This abstaction acts as a representative of the vector-types and builtins +-- compiler interface for either the Hard or the Soft case. + +-- For the Hard binding, Low_Level_Vectors exposes data types with a GCC +-- internal translation identical to the "vector ..." C types, and a set of +-- subprograms mapping straight to the internal GCC builtins. + +-- For the Soft binding, Low_Level_Vectors exposes the same set of types +-- and subprograms, with bodies simulating the instructions behavior. + +-- Vector_Types/Operations "simply" bind the user types and operations to +-- some Low_Level_Vectors implementation, selected in accordance with the +-- target + +-- To achieve a complete Hard/Soft independence in the Vector_Types and +-- Vector_Operations implementations, both versions of the low level support +-- are expected to expose a number of facilities: + +-- o Private data type declarations for base vector representations embedded +-- in the user visible vector types, that is: + +-- LL_VBC, LL_VUC and LL_VSC +-- for vector_bool_char, vector_unsigned_char and vector_signed_char + +-- LL_VBS, LL_VUS and LL_VSS +-- for vector_bool_short, vector_unsigned_short and vector_signed_short + +-- LL_VBI, LL_VUI and LL_VSI +-- for vector_bool_int, vector_unsigned_int and vector_signed_int + +-- as well as: + +-- LL_VP for vector_pixel and LL_VF for vector_float + +-- o Primitive operations corresponding to the AltiVec hardware instruction +-- names, like "vaddubm". The whole set is not described here. The actual +-- sets are inspired from the GCC builtins which are invoked from GCC's +-- "altivec.h". + +-- o An LL_Altivec convention identifier, specifying the calling convention +-- to be used to access the aforementioned primitive operations. + +-- Besides: + +-- o Unchecked_Conversion are expected to be allowed between any pair of +-- exposed data types, and are expected to have no effect on the value +-- bit patterns. + +------------------------- +-- Vector views layout -- +------------------------- + +-- Vector Views combine intuitive user level ordering for both elements +-- within a vector and bytes within each element. They basically map to an +-- array representation where array(i) always represents element (i), in the +-- natural target representation. This way, a user vector (1, 2, 3, 4) is +-- represented as: + +-- Increasing Addresses +-- -------------------------------------------------------------------------> + +-- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | +-- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | + +-- on a big endian target, and as: + +-- | 0x1 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x4 0x0 0x0 0x0 | +-- | V (0), LE | V (1), LE | V (2), LE | V (3), LE | + +-- on a little-endian target + +------------------------- +-- Vector types layout -- +------------------------- + +-- In the case of the hard binding, the layout of the vector type in +-- memory is documented by the Altivec documentation. In the case of the +-- soft binding, the simplest solution is to represent a vector as an +-- array of components. This representation can depend on the endianness. +-- We can consider three possibilities: + +-- * First component at the lowest address, components in big endian format. +-- It is the natural way to represent an array in big endian, and it would +-- also be the natural way to represent a quad-word integer in big endian. + +-- Example: + +-- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is +-- represented as: + +-- Addresses growing +-- -------------------------------------------------------------------------> +-- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | +-- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | + +-- * First component at the lowest address, components in little endian +-- format. It is the natural way to represent an array in little endian. + +-- Example: + +-- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is +-- represented as: + +-- Addresses growing +-- -------------------------------------------------------------------------> +-- | 0x1 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x4 0x0 0x0 0x0 | +-- | V (0), LE | V (1), LE | V (2), LE | V (3), LE | + +-- * Last component at the lowest address, components in little endian format. +-- It is the natural way to represent a quad-word integer in little endian. + +-- Example: + +-- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is +-- represented as: + +-- Addresses growing +-- -------------------------------------------------------------------------> +-- | 0x4 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x1 0x0 0x0 0x0 | +-- | V (3), LE | V (2), LE | V (1), LE | V (0), LE | + +-- There is actually a fourth case (components in big endian, first +-- component at the lowest address), but it does not have any interesting +-- properties: it is neither the natural way to represent a quad-word on any +-- machine, nor the natural way to represent an array on any machine. + +-- Example: + +-- Let V be a vector of unsigned int which value is (1, 2, 3, 4). It is +-- represented as: + +-- Addresses growing +-- -------------------------------------------------------------------------> +-- | 0x0 0x0 0x0 0x4 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x1 | +-- | V (3), BE | V (2), BE | V (1), BE | V (0), BE | + +-- Most of the Altivec operations are specific to a component size, and +-- can be implemented with any of these three formats. But some operations +-- are defined by the same Altivec primitive operation for different type +-- sizes: + +-- * operations doing arithmetics on a complete vector, seen as a quad-word; +-- * operations dealing with memory. + +-- Operations on a complete vector: +-- -------------------------------- + +-- Examples: + +-- vec_sll/vsl : shift left on the entire vector. +-- vec_slo/vslo: shift left on the entire vector, by octet. + +-- Those operations works on vectors seens as a quad-word. +-- Let us suppose that we have a conversion operation named To_Quad_Word +-- for converting vector types to a quad-word. + +-- Let A be a Altivec vector of 16 components: +-- A = (A(0), A(1), A(2), A(3), ... , A(14), A(15)) +-- Let B be a Altivec vector of 8 components verifying: +-- B = (A(0) |8| A(1), A(2) |8| A(3), ... , A(14) |8| A(15)) +-- Let C be a Altivec vector of 4 components verifying: +-- C = (A(0) |8| A(1) |8| A(2) |8| A(3), ... , +-- A(12) |8| A(13) |8| A(14) |8| A(15)) + +-- (definition: |8| is the concatenation operation between two bytes; +-- i.e. 0x1 |8| 0x2 = 0x0102) + +-- According to [PIM - 4.2 byte ordering], we have the following property: +-- To_Quad_Word (A) = To_Quad_Word (B) = To_Quad_Word (C) + +-- Let To_Type_Of_A be a conversion operation from the type of B to the +-- type of A. The quad-word operations are only implemented by one +-- Altivec primitive operation. That means that, if QW_Operation is a +-- quad-word operation, we should have: +-- QW_Operation (To_Type_of_A (B)) = QW_Operation (A) + +-- That is true iff: +-- To_Quad_Word (To_Type_of_A (B)) = To_Quad_Word (A) + +-- As To_Quad_Word is a bijection. we have: +-- To_Type_of_A (B) = A + +-- resp. any combination of A, B, C: +-- To_Type_of_A (C) = A +-- To_Type_of_B (A) = B +-- To_Type_of_C (B) = C +-- ... + +-- Making sure that the properties described above are verified by the +-- conversion operations between vector types has different implications +-- depending on the layout of the vector types: +-- * with format 1 and 3: only a unchecked conversion is needed; +-- * with format 2 and 4: some reorganisation is needed for conversions +-- between vector types with different component sizes; that has a cost on the +-- efficiency, plus the complexity of having different memory pattern for +-- the same quad-word value, depending on the type. + +-- Operation dealing with memory: +-- ------------------------------ + +-- These operations are either load operation (vec_ld and the +-- corresponding primitive operation: vlx) or store operation (vec_st +-- and the corresponding primitive operation: vstx). + +-- According to [PIM 4.4 - vec_ld], those operations take in input +-- either an access to a vector (e.g. a const_vector_unsigned_int_ptr) +-- or an access to a flow of components (e.g. a const_unsigned_int_ptr), +-- relying on the same Altivec primitive operations. That means that both +-- should have the same representation in memory. + +-- For the stream, it is easier to adopt the format of the target. That +-- means that, in memory, the components of the vector should also have the +-- format of the target. meaning that we will prefer: +-- * On a big endian target: format 1 or 4 +-- * On a little endian target: format 2 or 3 + +-- Conclusion: +-- ----------- + +-- To take into consideration the constraint brought about by the routines +-- operating on quad-words and the routines operating on memory, the best +-- choice seems to be: + +-- * On a big endian target: format 1; +-- * On a little endian target: format 3. + +-- Those layout choices are enforced by GNAT.Altivec.Low_Level_Conversions, +-- which is the endianness-dependant unit providing conversions between +-- vector views and vector types. + +---------------------- +-- Layouts summary -- +---------------------- + +-- For a user abstract vector of 4 uints (1, 2, 3, 4), increasing +-- addresses from left to right: + +-- ========================================================================= +-- BIG ENDIAN TARGET MEMORY LAYOUT for (1, 2, 3, 4) +-- ========================================================================= + +-- View +-- ------------------------------------------------------------------------- +-- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | +-- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | +-- ------------------------------------------------------------------------- + +-- Vector +-- ------------------------------------------------------------------------- +-- | 0x0 0x0 0x0 0x1 | 0x0 0x0 0x0 0x2 | 0x0 0x0 0x0 0x3 | 0x0 0x0 0x0 0x4 | +-- | V (0), BE | V (1), BE | V (2), BE | V (3), BE | +-- ------------------------------------------------------------------------- + +-- ========================================================================= +-- LITTLE ENDIAN TARGET MEMORY LAYOUT for (1, 2, 3, 4) +-- ========================================================================= + +-- View +-- ------------------------------------------------------------------------- +-- | 0x1 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x4 0x0 0x0 0x0 | +-- | V (0), LE | V (1), LE | V (2), LE | V (3), LE | + +-- Vector +-- ------------------------------------------------------------------------- +-- | 0x4 0x0 0x0 0x0 | 0x3 0x0 0x0 0x0 | 0x2 0x0 0x0 0x0 | 0x1 0x0 0x0 0x0 | +-- | V (3), LE | V (2), LE | V (1), LE | V (0), LE | +-- ------------------------------------------------------------------------- + +-- These layouts are common to both the soft and hard implementations on +-- Altivec capable targets. diff --git a/gcc/ada/libgnat/g-alveop.adb b/gcc/ada/libgnat/g-alveop.adb new file mode 100644 index 0000000..4e7317f --- /dev/null +++ b/gcc/ada/libgnat/g-alveop.adb @@ -0,0 +1,11008 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . V E C T O R _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Altivec.Low_Level_Interface; use GNAT.Altivec.Low_Level_Interface; + +package body GNAT.Altivec.Vector_Operations is + + -------------------------------------------------------- + -- Bodies for generic and specific Altivec operations -- + -------------------------------------------------------- + + ------------- + -- vec_abs -- + ------------- + + function vec_abs + (A : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (abs_v16qi (A)); + end vec_abs; + + function vec_abs + (A : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (abs_v8hi (A)); + end vec_abs; + + function vec_abs + (A : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (abs_v4si (A)); + end vec_abs; + + function vec_abs + (A : vector_float) return vector_float + is + begin + return To_LL_VF (abs_v4sf (A)); + end vec_abs; + + -------------- + -- vec_abss -- + -------------- + + function vec_abss + (A : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (abss_v16qi (A)); + end vec_abss; + + function vec_abss + (A : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (abss_v8hi (A)); + end vec_abss; + + function vec_abss + (A : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (abss_v4si (A)); + end vec_abss; + + ------------- + -- vec_add -- + ------------- + + function vec_add + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_add; + + function vec_add + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_add; + + function vec_add + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_add; + + function vec_add + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_add; + + function vec_add + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_add; + + function vec_add + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_add; + + function vec_add + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_add; + + function vec_add + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_add; + + function vec_add + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_add; + + function vec_add + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_add; + + function vec_add + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_add; + + function vec_add + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_add; + + function vec_add + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_add; + + function vec_add + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_add; + + function vec_add + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_add; + + function vec_add + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_add; + + function vec_add + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_add; + + function vec_add + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_add; + + function vec_add + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vaddfp (To_LL_VF (A), To_LL_VF (B))); + end vec_add; + + ---------------- + -- vec_vaddfp -- + ---------------- + + function vec_vaddfp + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vaddfp (To_LL_VF (A), To_LL_VF (B))); + end vec_vaddfp; + + ----------------- + -- vec_vadduwm -- + ----------------- + + function vec_vadduwm + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduwm; + + function vec_vadduwm + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduwm; + + function vec_vadduwm + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduwm; + + function vec_vadduwm + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduwm; + + function vec_vadduwm + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduwm; + + function vec_vadduwm + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduwm; + + ----------------- + -- vec_vadduhm -- + ----------------- + + function vec_vadduhm + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhm; + + function vec_vadduhm + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhm; + + function vec_vadduhm + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhm; + + function vec_vadduhm + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhm; + + function vec_vadduhm + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhm; + + function vec_vadduhm + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhm; + + ----------------- + -- vec_vaddubm -- + ----------------- + + function vec_vaddubm + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubm; + + function vec_vaddubm + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubm; + + function vec_vaddubm + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubm; + + function vec_vaddubm + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubm; + + function vec_vaddubm + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubm; + + function vec_vaddubm + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubm; + + -------------- + -- vec_addc -- + -------------- + + function vec_addc + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vaddcuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_addc; + + -------------- + -- vec_adds -- + -------------- + + function vec_adds + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_adds; + + function vec_adds + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_adds; + + function vec_adds + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_adds; + + function vec_adds + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_adds; + + function vec_adds + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_adds; + + function vec_adds + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_adds; + + function vec_adds + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_adds; + + function vec_adds + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_adds; + + function vec_adds + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_adds; + + function vec_adds + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_adds; + + function vec_adds + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_adds; + + function vec_adds + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_adds; + + function vec_adds + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_adds; + + function vec_adds + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_adds; + + function vec_adds + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_adds; + + function vec_adds + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_adds; + + function vec_adds + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_adds; + + function vec_adds + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_adds; + + ----------------- + -- vec_vaddsws -- + ----------------- + + function vec_vaddsws + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vaddsws; + + function vec_vaddsws + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vaddsws; + + function vec_vaddsws + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vaddsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vaddsws; + + ----------------- + -- vec_vadduws -- + ----------------- + + function vec_vadduws + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduws; + + function vec_vadduws + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduws; + + function vec_vadduws + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vadduws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vadduws; + + ----------------- + -- vec_vaddshs -- + ----------------- + + function vec_vaddshs + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vaddshs; + + function vec_vaddshs + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vaddshs; + + function vec_vaddshs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vaddshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vaddshs; + + ----------------- + -- vec_vadduhs -- + ----------------- + + function vec_vadduhs + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhs; + + function vec_vadduhs + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhs; + + function vec_vadduhs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vadduhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vadduhs; + + ----------------- + -- vec_vaddsbs -- + ----------------- + + function vec_vaddsbs + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddsbs; + + function vec_vaddsbs + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddsbs; + + function vec_vaddsbs + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vaddsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddsbs; + + ----------------- + -- vec_vaddubs -- + ----------------- + + function vec_vaddubs + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubs; + + function vec_vaddubs + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubs; + + function vec_vaddubs + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vaddubs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vaddubs; + + ------------- + -- vec_and -- + ------------- + + function vec_and + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_float; + B : vector_bool_int) return vector_float + is + begin + return To_LL_VF (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_int; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + function vec_and + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vand (To_LL_VSI (A), To_LL_VSI (B))); + end vec_and; + + -------------- + -- vec_andc -- + -------------- + + function vec_andc + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_float; + B : vector_bool_int) return vector_float + is + begin + return To_LL_VF (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_int; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + function vec_andc + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vandc (To_LL_VSI (A), To_LL_VSI (B))); + end vec_andc; + + ------------- + -- vec_avg -- + ------------- + + function vec_avg + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vavgub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_avg; + + function vec_avg + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vavgsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_avg; + + function vec_avg + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vavguh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_avg; + + function vec_avg + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vavgsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_avg; + + function vec_avg + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vavguw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_avg; + + function vec_avg + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vavgsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_avg; + + ---------------- + -- vec_vavgsw -- + ---------------- + + function vec_vavgsw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vavgsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vavgsw; + + ---------------- + -- vec_vavguw -- + ---------------- + + function vec_vavguw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vavguw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vavguw; + + ---------------- + -- vec_vavgsh -- + ---------------- + + function vec_vavgsh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vavgsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vavgsh; + + ---------------- + -- vec_vavguh -- + ---------------- + + function vec_vavguh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vavguh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vavguh; + + ---------------- + -- vec_vavgsb -- + ---------------- + + function vec_vavgsb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vavgsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vavgsb; + + ---------------- + -- vec_vavgub -- + ---------------- + + function vec_vavgub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vavgub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vavgub; + + -------------- + -- vec_ceil -- + -------------- + + function vec_ceil + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vrfip (To_LL_VF (A))); + end vec_ceil; + + -------------- + -- vec_cmpb -- + -------------- + + function vec_cmpb + (A : vector_float; + B : vector_float) return vector_signed_int + is + begin + return To_LL_VSI (vcmpbfp (To_LL_VF (A), To_LL_VF (B))); + end vec_cmpb; + + --------------- + -- vec_cmpeq -- + --------------- + + function vec_cmpeq + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_cmpeq; + + function vec_cmpeq + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_cmpeq; + + function vec_cmpeq + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_cmpeq; + + function vec_cmpeq + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_cmpeq; + + function vec_cmpeq + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_cmpeq; + + function vec_cmpeq + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_cmpeq; + + function vec_cmpeq + (A : vector_float; + B : vector_float) return vector_bool_int + is + begin + return To_LL_VBI (vcmpeqfp (To_LL_VF (A), To_LL_VF (B))); + end vec_cmpeq; + + ------------------ + -- vec_vcmpeqfp -- + ------------------ + + function vec_vcmpeqfp + (A : vector_float; + B : vector_float) return vector_bool_int + is + begin + return To_LL_VBI (vcmpeqfp (To_LL_VF (A), To_LL_VF (B))); + end vec_vcmpeqfp; + + ------------------ + -- vec_vcmpequw -- + ------------------ + + function vec_vcmpequw + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vcmpequw; + + function vec_vcmpequw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpequw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vcmpequw; + + ------------------ + -- vec_vcmpequh -- + ------------------ + + function vec_vcmpequh + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vcmpequh; + + function vec_vcmpequh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpequh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vcmpequh; + + ------------------ + -- vec_vcmpequb -- + ------------------ + + function vec_vcmpequb + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vcmpequb; + + function vec_vcmpequb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpequb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vcmpequb; + + --------------- + -- vec_cmpge -- + --------------- + + function vec_cmpge + (A : vector_float; + B : vector_float) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgefp (To_LL_VF (A), To_LL_VF (B))); + end vec_cmpge; + + --------------- + -- vec_cmpgt -- + --------------- + + function vec_cmpgt + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpgtub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_cmpgt; + + function vec_cmpgt + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpgtsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_cmpgt; + + function vec_cmpgt + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpgtuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_cmpgt; + + function vec_cmpgt + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpgtsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_cmpgt; + + function vec_cmpgt + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_cmpgt; + + function vec_cmpgt + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_cmpgt; + + function vec_cmpgt + (A : vector_float; + B : vector_float) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtfp (To_LL_VF (A), To_LL_VF (B))); + end vec_cmpgt; + + ------------------ + -- vec_vcmpgtfp -- + ------------------ + + function vec_vcmpgtfp + (A : vector_float; + B : vector_float) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtfp (To_LL_VF (A), To_LL_VF (B))); + end vec_vcmpgtfp; + + ------------------ + -- vec_vcmpgtsw -- + ------------------ + + function vec_vcmpgtsw + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vcmpgtsw; + + ------------------ + -- vec_vcmpgtuw -- + ------------------ + + function vec_vcmpgtuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vcmpgtuw; + + ------------------ + -- vec_vcmpgtsh -- + ------------------ + + function vec_vcmpgtsh + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpgtsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vcmpgtsh; + + ------------------ + -- vec_vcmpgtuh -- + ------------------ + + function vec_vcmpgtuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpgtuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vcmpgtuh; + + ------------------ + -- vec_vcmpgtsb -- + ------------------ + + function vec_vcmpgtsb + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpgtsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vcmpgtsb; + + ------------------ + -- vec_vcmpgtub -- + ------------------ + + function vec_vcmpgtub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpgtub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vcmpgtub; + + --------------- + -- vec_cmple -- + --------------- + + function vec_cmple + (A : vector_float; + B : vector_float) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgefp (To_LL_VF (B), To_LL_VF (A))); + end vec_cmple; + + --------------- + -- vec_cmplt -- + --------------- + + function vec_cmplt + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpgtub (To_LL_VSC (B), To_LL_VSC (A))); + end vec_cmplt; + + function vec_cmplt + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char + is + begin + return To_LL_VBC (vcmpgtsb (To_LL_VSC (B), To_LL_VSC (A))); + end vec_cmplt; + + function vec_cmplt + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpgtuh (To_LL_VSS (B), To_LL_VSS (A))); + end vec_cmplt; + + function vec_cmplt + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short + is + begin + return To_LL_VBS (vcmpgtsh (To_LL_VSS (B), To_LL_VSS (A))); + end vec_cmplt; + + function vec_cmplt + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtuw (To_LL_VSI (B), To_LL_VSI (A))); + end vec_cmplt; + + function vec_cmplt + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtsw (To_LL_VSI (B), To_LL_VSI (A))); + end vec_cmplt; + + function vec_cmplt + (A : vector_float; + B : vector_float) return vector_bool_int + is + begin + return To_LL_VBI (vcmpgtfp (To_LL_VF (B), To_LL_VF (A))); + end vec_cmplt; + + --------------- + -- vec_expte -- + --------------- + + function vec_expte + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vexptefp (To_LL_VF (A))); + end vec_expte; + + --------------- + -- vec_floor -- + --------------- + + function vec_floor + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vrfim (To_LL_VF (A))); + end vec_floor; + + ------------ + -- vec_ld -- + ------------ + + function vec_ld + (A : c_long; + B : const_vector_float_ptr) return vector_float + is + begin + return To_LL_VF (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_float_ptr) return vector_float + is + begin + return To_LL_VF (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_bool_int_ptr) return vector_bool_int + is + begin + return To_LL_VBI (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_signed_int_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_int_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_long_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_unsigned_int_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_bool_short_ptr) return vector_bool_short + is + begin + return To_LL_VBS (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_pixel_ptr) return vector_pixel + is + begin + return To_LL_VP (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_signed_short_ptr) return vector_signed_short + is + begin + return To_LL_VSS (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_short_ptr) return vector_signed_short + is + begin + return To_LL_VSS (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_unsigned_short_ptr) return vector_unsigned_short + is + begin + return To_LL_VUS (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short + is + begin + return To_LL_VUS (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_bool_char_ptr) return vector_bool_char + is + begin + return To_LL_VBC (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_signed_char_ptr) return vector_signed_char + is + begin + return To_LL_VSC (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char + is + begin + return To_LL_VSC (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_vector_unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvx (A, To_PTR (B))); + end vec_ld; + + function vec_ld + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvx (A, To_PTR (B))); + end vec_ld; + + ------------- + -- vec_lde -- + ------------- + + function vec_lde + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char + is + begin + return To_LL_VSC (lvebx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvebx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_short_ptr) return vector_signed_short + is + begin + return To_LL_VSS (lvehx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short + is + begin + return To_LL_VUS (lvehx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_float_ptr) return vector_float + is + begin + return To_LL_VF (lvewx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_int_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvewx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvewx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_long_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvewx (A, To_PTR (B))); + end vec_lde; + + function vec_lde + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvewx (A, To_PTR (B))); + end vec_lde; + + --------------- + -- vec_lvewx -- + --------------- + + function vec_lvewx + (A : c_long; + B : float_ptr) return vector_float + is + begin + return To_LL_VF (lvewx (A, To_PTR (B))); + end vec_lvewx; + + function vec_lvewx + (A : c_long; + B : int_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvewx (A, To_PTR (B))); + end vec_lvewx; + + function vec_lvewx + (A : c_long; + B : unsigned_int_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvewx (A, To_PTR (B))); + end vec_lvewx; + + function vec_lvewx + (A : c_long; + B : long_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvewx (A, To_PTR (B))); + end vec_lvewx; + + function vec_lvewx + (A : c_long; + B : unsigned_long_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvewx (A, To_PTR (B))); + end vec_lvewx; + + --------------- + -- vec_lvehx -- + --------------- + + function vec_lvehx + (A : c_long; + B : short_ptr) return vector_signed_short + is + begin + return To_LL_VSS (lvehx (A, To_PTR (B))); + end vec_lvehx; + + function vec_lvehx + (A : c_long; + B : unsigned_short_ptr) return vector_unsigned_short + is + begin + return To_LL_VUS (lvehx (A, To_PTR (B))); + end vec_lvehx; + + --------------- + -- vec_lvebx -- + --------------- + + function vec_lvebx + (A : c_long; + B : signed_char_ptr) return vector_signed_char + is + begin + return To_LL_VSC (lvebx (A, To_PTR (B))); + end vec_lvebx; + + function vec_lvebx + (A : c_long; + B : unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvebx (A, To_PTR (B))); + end vec_lvebx; + + ------------- + -- vec_ldl -- + ------------- + + function vec_ldl + (A : c_long; + B : const_vector_float_ptr) return vector_float + is + begin + return To_LL_VF (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_float_ptr) return vector_float + is + begin + return To_LL_VF (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_bool_int_ptr) return vector_bool_int + is + begin + return To_LL_VBI (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_signed_int_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_int_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_long_ptr) return vector_signed_int + is + begin + return To_LL_VSI (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_unsigned_int_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int + is + begin + return To_LL_VUI (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_bool_short_ptr) return vector_bool_short + is + begin + return To_LL_VBS (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_pixel_ptr) return vector_pixel + is + begin + return To_LL_VP (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_signed_short_ptr) return vector_signed_short + is + begin + return To_LL_VSS (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_short_ptr) return vector_signed_short + is + begin + return To_LL_VSS (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_unsigned_short_ptr) return vector_unsigned_short + is + begin + return To_LL_VUS (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short + is + begin + return To_LL_VUS (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_bool_char_ptr) return vector_bool_char + is + begin + return To_LL_VBC (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_signed_char_ptr) return vector_signed_char + is + begin + return To_LL_VSC (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char + is + begin + return To_LL_VSC (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_vector_unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvxl (A, To_PTR (B))); + end vec_ldl; + + function vec_ldl + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvxl (A, To_PTR (B))); + end vec_ldl; + + -------------- + -- vec_loge -- + -------------- + + function vec_loge + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vlogefp (To_LL_VF (A))); + end vec_loge; + + -------------- + -- vec_lvsl -- + -------------- + + function vec_lvsl + (A : c_long; + B : constv_unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_signed_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_unsigned_short_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_short_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_unsigned_int_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_int_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_unsigned_long_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_long_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + function vec_lvsl + (A : c_long; + B : constv_float_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsl (A, To_PTR (B))); + end vec_lvsl; + + -------------- + -- vec_lvsr -- + -------------- + + function vec_lvsr + (A : c_long; + B : constv_unsigned_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_signed_char_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_unsigned_short_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_short_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_unsigned_int_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_int_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_unsigned_long_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_long_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + function vec_lvsr + (A : c_long; + B : constv_float_ptr) return vector_unsigned_char + is + begin + return To_LL_VUC (lvsr (A, To_PTR (B))); + end vec_lvsr; + + -------------- + -- vec_madd -- + -------------- + + function vec_madd + (A : vector_float; + B : vector_float; + C : vector_float) return vector_float + is + begin + return vmaddfp (A, B, C); + end vec_madd; + + --------------- + -- vec_madds -- + --------------- + + function vec_madds + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + is + begin + return vmhaddshs (A, B, C); + end vec_madds; + + ------------- + -- vec_max -- + ------------- + + function vec_max + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_max; + + function vec_max + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_max; + + function vec_max + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_max; + + function vec_max + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_max; + + function vec_max + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_max; + + function vec_max + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_max; + + function vec_max + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_max; + + function vec_max + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_max; + + function vec_max + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_max; + + function vec_max + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_max; + + function vec_max + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_max; + + function vec_max + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_max; + + function vec_max + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_max; + + function vec_max + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_max; + + function vec_max + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_max; + + function vec_max + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_max; + + function vec_max + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_max; + + function vec_max + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_max; + + function vec_max + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vmaxfp (To_LL_VF (A), To_LL_VF (B))); + end vec_max; + + ---------------- + -- vec_vmaxfp -- + ---------------- + + function vec_vmaxfp + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vmaxfp (To_LL_VF (A), To_LL_VF (B))); + end vec_vmaxfp; + + ---------------- + -- vec_vmaxsw -- + ---------------- + + function vec_vmaxsw + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmaxsw; + + function vec_vmaxsw + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmaxsw; + + function vec_vmaxsw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmaxsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmaxsw; + + ---------------- + -- vec_vmaxuw -- + ---------------- + + function vec_vmaxuw + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmaxuw; + + function vec_vmaxuw + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmaxuw; + + function vec_vmaxuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmaxuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmaxuw; + + ---------------- + -- vec_vmaxsh -- + ---------------- + + function vec_vmaxsh + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmaxsh; + + function vec_vmaxsh + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmaxsh; + + function vec_vmaxsh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmaxsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmaxsh; + + ---------------- + -- vec_vmaxuh -- + ---------------- + + function vec_vmaxuh + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmaxuh; + + function vec_vmaxuh + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmaxuh; + + function vec_vmaxuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmaxuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmaxuh; + + ---------------- + -- vec_vmaxsb -- + ---------------- + + function vec_vmaxsb + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmaxsb; + + function vec_vmaxsb + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmaxsb; + + function vec_vmaxsb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmaxsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmaxsb; + + ---------------- + -- vec_vmaxub -- + ---------------- + + function vec_vmaxub + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmaxub; + + function vec_vmaxub + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmaxub; + + function vec_vmaxub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmaxub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmaxub; + + ---------------- + -- vec_mergeh -- + ---------------- + + function vec_mergeh + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_pixel; + B : vector_pixel) return vector_pixel + is + begin + return To_LL_VP (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergeh; + + function vec_mergeh + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergeh; + + ---------------- + -- vec_vmrghw -- + ---------------- + + function vec_vmrghw + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrghw; + + function vec_vmrghw + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrghw; + + function vec_vmrghw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrghw; + + function vec_vmrghw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmrghw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrghw; + + ---------------- + -- vec_vmrghh -- + ---------------- + + function vec_vmrghh + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrghh; + + function vec_vmrghh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrghh; + + function vec_vmrghh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrghh; + + function vec_vmrghh + (A : vector_pixel; + B : vector_pixel) return vector_pixel + is + begin + return To_LL_VP (vmrghh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrghh; + + ---------------- + -- vec_vmrghb -- + ---------------- + + function vec_vmrghb + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmrghb; + + function vec_vmrghb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmrghb; + + function vec_vmrghb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmrghb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmrghb; + + ---------------- + -- vec_mergel -- + ---------------- + + function vec_mergel + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mergel; + + function vec_mergel + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mergel; + + function vec_mergel + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mergel; + + function vec_mergel + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergel; + + function vec_mergel + (A : vector_pixel; + B : vector_pixel) return vector_pixel + is + begin + return To_LL_VP (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergel; + + function vec_mergel + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergel; + + function vec_mergel + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mergel; + + function vec_mergel + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergel; + + function vec_mergel + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergel; + + function vec_mergel + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergel; + + function vec_mergel + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_mergel; + + ---------------- + -- vec_vmrglw -- + ---------------- + + function vec_vmrglw + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrglw; + + function vec_vmrglw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrglw; + + function vec_vmrglw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrglw; + + function vec_vmrglw + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vmrglw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vmrglw; + + ---------------- + -- vec_vmrglh -- + ---------------- + + function vec_vmrglh + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrglh; + + function vec_vmrglh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrglh; + + function vec_vmrglh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrglh; + + function vec_vmrglh + (A : vector_pixel; + B : vector_pixel) return vector_pixel + is + begin + return To_LL_VP (vmrglh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmrglh; + + ---------------- + -- vec_vmrglb -- + ---------------- + + function vec_vmrglb + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmrglb; + + function vec_vmrglb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmrglb; + + function vec_vmrglb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vmrglb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmrglb; + + ---------------- + -- vec_mfvscr -- + ---------------- + + function vec_mfvscr return vector_unsigned_short + is + begin + return To_LL_VUS (mfvscr); + end vec_mfvscr; + + ------------- + -- vec_min -- + ------------- + + function vec_min + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_min; + + function vec_min + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_min; + + function vec_min + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_min; + + function vec_min + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_min; + + function vec_min + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_min; + + function vec_min + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_min; + + function vec_min + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_min; + + function vec_min + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_min; + + function vec_min + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_min; + + function vec_min + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_min; + + function vec_min + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_min; + + function vec_min + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_min; + + function vec_min + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_min; + + function vec_min + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_min; + + function vec_min + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_min; + + function vec_min + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_min; + + function vec_min + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_min; + + function vec_min + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_min; + + function vec_min + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vminfp (To_LL_VF (A), To_LL_VF (B))); + end vec_min; + + -- vec_vminfp -- + + function vec_vminfp + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vminfp (To_LL_VF (A), To_LL_VF (B))); + end vec_vminfp; + + -- vec_vminsw -- + + function vec_vminsw + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vminsw; + + function vec_vminsw + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vminsw; + + function vec_vminsw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vminsw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vminsw; + + -- vec_vminuw -- + + function vec_vminuw + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vminuw; + + function vec_vminuw + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vminuw; + + function vec_vminuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vminuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vminuw; + + -- vec_vminsh -- + + function vec_vminsh + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vminsh; + + function vec_vminsh + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vminsh; + + function vec_vminsh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vminsh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vminsh; + + ---------------- + -- vec_vminuh -- + ---------------- + + function vec_vminuh + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vminuh; + + function vec_vminuh + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vminuh; + + function vec_vminuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vminuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vminuh; + + ---------------- + -- vec_vminsb -- + ---------------- + + function vec_vminsb + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vminsb; + + function vec_vminsb + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vminsb; + + function vec_vminsb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vminsb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vminsb; + + ---------------- + -- vec_vminub -- + ---------------- + + function vec_vminub + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vminub; + + function vec_vminub + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vminub; + + function vec_vminub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vminub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vminub; + + --------------- + -- vec_mladd -- + --------------- + + function vec_mladd + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + is + begin + return vmladduhm (A, B, C); + end vec_mladd; + + function vec_mladd + (A : vector_signed_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_signed_short + is + begin + return vmladduhm (A, To_LL_VSS (B), To_LL_VSS (C)); + end vec_mladd; + + function vec_mladd + (A : vector_unsigned_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + is + begin + return vmladduhm (To_LL_VSS (A), B, C); + end vec_mladd; + + function vec_mladd + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_unsigned_short + is + begin + return + To_LL_VUS (vmladduhm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSS (C))); + end vec_mladd; + + ---------------- + -- vec_mradds -- + ---------------- + + function vec_mradds + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + is + begin + return vmhraddshs (A, B, C); + end vec_mradds; + + -------------- + -- vec_msum -- + -------------- + + function vec_msum + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vmsumubm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); + end vec_msum; + + function vec_msum + (A : vector_signed_char; + B : vector_unsigned_char; + C : vector_signed_int) return vector_signed_int + is + begin + return + To_LL_VSI (vmsummbm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); + end vec_msum; + + function vec_msum + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vmsumuhm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_msum; + + function vec_msum + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int + is + begin + return + To_LL_VSI (vmsumshm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_msum; + + ------------------ + -- vec_vmsumshm -- + ------------------ + + function vec_vmsumshm + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int + is + begin + return + To_LL_VSI (vmsumshm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_vmsumshm; + + ------------------ + -- vec_vmsumuhm -- + ------------------ + + function vec_vmsumuhm + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vmsumuhm (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_vmsumuhm; + + ------------------ + -- vec_vmsummbm -- + ------------------ + + function vec_vmsummbm + (A : vector_signed_char; + B : vector_unsigned_char; + C : vector_signed_int) return vector_signed_int + is + begin + return + To_LL_VSI (vmsummbm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); + end vec_vmsummbm; + + ------------------ + -- vec_vmsumubm -- + ------------------ + + function vec_vmsumubm + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vmsumubm (To_LL_VSC (A), To_LL_VSC (B), To_LL_VSI (C))); + end vec_vmsumubm; + + --------------- + -- vec_msums -- + --------------- + + function vec_msums + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vmsumuhs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_msums; + + function vec_msums + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int + is + begin + return + To_LL_VSI (vmsumshs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_msums; + + ------------------ + -- vec_vmsumshs -- + ------------------ + + function vec_vmsumshs + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int + is + begin + return + To_LL_VSI (vmsumshs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_vmsumshs; + + ------------------ + -- vec_vmsumuhs -- + ------------------ + + function vec_vmsumuhs + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vmsumuhs (To_LL_VSS (A), To_LL_VSS (B), To_LL_VSI (C))); + end vec_vmsumuhs; + + ---------------- + -- vec_mtvscr -- + ---------------- + + procedure vec_mtvscr + (A : vector_signed_int) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_unsigned_int) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_bool_int) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_signed_short) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_unsigned_short) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_bool_short) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_pixel) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_signed_char) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_unsigned_char) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + procedure vec_mtvscr + (A : vector_bool_char) + is + begin + mtvscr (To_LL_VSI (A)); + end vec_mtvscr; + + -------------- + -- vec_mule -- + -------------- + + function vec_mule + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vmuleub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mule; + + function vec_mule + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vmulesb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mule; + + function vec_mule + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int + is + begin + return To_LL_VUI (vmuleuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mule; + + function vec_mule + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vmulesh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mule; + + ----------------- + -- vec_vmulesh -- + ----------------- + + function vec_vmulesh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vmulesh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmulesh; + + ----------------- + -- vec_vmuleuh -- + ----------------- + + function vec_vmuleuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int + is + begin + return To_LL_VUI (vmuleuh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmuleuh; + + ----------------- + -- vec_vmulesb -- + ----------------- + + function vec_vmulesb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vmuleub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmulesb; + + ----------------- + -- vec_vmuleub -- + ----------------- + + function vec_vmuleub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vmuleub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmuleub; + + -------------- + -- vec_mulo -- + -------------- + + function vec_mulo + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vmuloub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mulo; + + function vec_mulo + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vmulosb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_mulo; + + function vec_mulo + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int + is + begin + return To_LL_VUI (vmulouh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mulo; + + function vec_mulo + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vmulosh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_mulo; + + ----------------- + -- vec_vmulosh -- + ----------------- + + function vec_vmulosh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vmulosh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmulosh; + + ----------------- + -- vec_vmulouh -- + ----------------- + + function vec_vmulouh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int + is + begin + return To_LL_VUI (vmulouh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vmulouh; + + ----------------- + -- vec_vmulosb -- + ----------------- + + function vec_vmulosb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vmulosb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmulosb; + + ----------------- + -- vec_vmuloub -- + ----------------- + + function vec_vmuloub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vmuloub (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vmuloub; + + --------------- + -- vec_nmsub -- + --------------- + + function vec_nmsub + (A : vector_float; + B : vector_float; + C : vector_float) return vector_float + is + begin + return To_LL_VF (vnmsubfp (To_LL_VF (A), To_LL_VF (B), To_LL_VF (C))); + end vec_nmsub; + + ------------- + -- vec_nor -- + ------------- + + function vec_nor + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + function vec_nor + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vnor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_nor; + + ------------ + -- vec_or -- + ------------ + + function vec_or + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_float; + B : vector_bool_int) return vector_float + is + begin + return To_LL_VF (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_int; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + function vec_or + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_or; + + -------------- + -- vec_pack -- + -------------- + + function vec_pack + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char + is + begin + return To_LL_VSC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); + end vec_pack; + + function vec_pack + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); + end vec_pack; + + function vec_pack + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_char + is + begin + return To_LL_VBC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); + end vec_pack; + + function vec_pack + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short + is + begin + return To_LL_VSS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); + end vec_pack; + + function vec_pack + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); + end vec_pack; + + function vec_pack + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_short + is + begin + return To_LL_VBS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); + end vec_pack; + + ----------------- + -- vec_vpkuwum -- + ----------------- + + function vec_vpkuwum + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_short + is + begin + return To_LL_VBS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vpkuwum; + + function vec_vpkuwum + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short + is + begin + return To_LL_VSS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vpkuwum; + + function vec_vpkuwum + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vpkuwum (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vpkuwum; + + ----------------- + -- vec_vpkuhum -- + ----------------- + + function vec_vpkuhum + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_char + is + begin + return To_LL_VBC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vpkuhum; + + function vec_vpkuhum + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char + is + begin + return To_LL_VSC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vpkuhum; + + function vec_vpkuhum + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vpkuhum (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vpkuhum; + + ---------------- + -- vec_packpx -- + ---------------- + + function vec_packpx + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_pixel + is + begin + return To_LL_VP (vpkpx (To_LL_VSI (A), To_LL_VSI (B))); + end vec_packpx; + + --------------- + -- vec_packs -- + --------------- + + function vec_packs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vpkuhus (To_LL_VSS (A), To_LL_VSS (B))); + end vec_packs; + + function vec_packs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char + is + begin + return To_LL_VSC (vpkshss (To_LL_VSS (A), To_LL_VSS (B))); + end vec_packs; + + function vec_packs + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vpkuwus (To_LL_VSI (A), To_LL_VSI (B))); + end vec_packs; + + function vec_packs + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short + is + begin + return To_LL_VSS (vpkswss (To_LL_VSI (A), To_LL_VSI (B))); + end vec_packs; + + ----------------- + -- vec_vpkswss -- + ----------------- + + function vec_vpkswss + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short + is + begin + return To_LL_VSS (vpkswss (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vpkswss; + + ----------------- + -- vec_vpkuwus -- + ----------------- + + function vec_vpkuwus + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vpkuwus (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vpkuwus; + + ----------------- + -- vec_vpkshss -- + ----------------- + + function vec_vpkshss + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char + is + begin + return To_LL_VSC (vpkshss (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vpkshss; + + ----------------- + -- vec_vpkuhus -- + ----------------- + + function vec_vpkuhus + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vpkuhus (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vpkuhus; + + ---------------- + -- vec_packsu -- + ---------------- + + function vec_packsu + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vpkuhus (To_LL_VSS (A), To_LL_VSS (B))); + end vec_packsu; + + function vec_packsu + (A : vector_signed_short; + B : vector_signed_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vpkshus (To_LL_VSS (A), To_LL_VSS (B))); + end vec_packsu; + + function vec_packsu + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vpkuwus (To_LL_VSI (A), To_LL_VSI (B))); + end vec_packsu; + + function vec_packsu + (A : vector_signed_int; + B : vector_signed_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vpkswus (To_LL_VSI (A), To_LL_VSI (B))); + end vec_packsu; + + ----------------- + -- vec_vpkswus -- + ----------------- + + function vec_vpkswus + (A : vector_signed_int; + B : vector_signed_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vpkswus (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vpkswus; + + ----------------- + -- vec_vpkshus -- + ----------------- + + function vec_vpkshus + (A : vector_signed_short; + B : vector_signed_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vpkshus (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vpkshus; + + -------------- + -- vec_perm -- + -------------- + + function vec_perm + (A : vector_float; + B : vector_float; + C : vector_unsigned_char) return vector_float + is + begin + return + To_LL_VF (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_signed_int; + B : vector_signed_int; + C : vector_unsigned_char) return vector_signed_int + is + begin + return + To_LL_VSI (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_unsigned_char) return vector_unsigned_int + is + begin + return + To_LL_VUI (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_bool_int; + B : vector_bool_int; + C : vector_unsigned_char) return vector_bool_int + is + begin + return + To_LL_VBI (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_signed_short; + B : vector_signed_short; + C : vector_unsigned_char) return vector_signed_short + is + begin + return + To_LL_VSS (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_char) return vector_unsigned_short + is + begin + return + To_LL_VUS (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_bool_short; + B : vector_bool_short; + C : vector_unsigned_char) return vector_bool_short + is + begin + return + To_LL_VBS (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_pixel; + B : vector_pixel; + C : vector_unsigned_char) return vector_pixel + is + begin + return To_LL_VP + (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_signed_char; + B : vector_signed_char; + C : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC + (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_char) return vector_unsigned_char + is + begin + return + To_LL_VUC (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + function vec_perm + (A : vector_bool_char; + B : vector_bool_char; + C : vector_unsigned_char) return vector_bool_char + is + begin + return + To_LL_VBC (vperm_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSC (C))); + end vec_perm; + + ------------ + -- vec_re -- + ------------ + + function vec_re + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vrefp (To_LL_VF (A))); + end vec_re; + + ------------ + -- vec_rl -- + ------------ + + function vec_rl + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_rl; + + function vec_rl + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_rl; + + function vec_rl + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_rl; + + function vec_rl + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_rl; + + function vec_rl + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_rl; + + function vec_rl + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_rl; + + -------------- + -- vec_vrlw -- + -------------- + + function vec_vrlw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vrlw; + + function vec_vrlw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vrlw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vrlw; + + -------------- + -- vec_vrlh -- + -------------- + + function vec_vrlh + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vrlh; + + function vec_vrlh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vrlh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vrlh; + + -------------- + -- vec_vrlb -- + -------------- + + function vec_vrlb + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vrlb; + + function vec_vrlb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vrlb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vrlb; + + --------------- + -- vec_round -- + --------------- + + function vec_round + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vrfin (To_LL_VF (A))); + end vec_round; + + ---------------- + -- vec_rsqrte -- + ---------------- + + function vec_rsqrte + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vrsqrtefp (To_LL_VF (A))); + end vec_rsqrte; + + ------------- + -- vec_sel -- + ------------- + + function vec_sel + (A : vector_float; + B : vector_float; + C : vector_bool_int) return vector_float + is + begin + return To_LL_VF (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_float; + B : vector_float; + C : vector_unsigned_int) return vector_float + is + begin + return To_LL_VF (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_signed_int; + B : vector_signed_int; + C : vector_bool_int) return vector_signed_int + is + begin + return + To_LL_VSI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_signed_int; + B : vector_signed_int; + C : vector_unsigned_int) return vector_signed_int + is + begin + return + To_LL_VSI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_bool_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_unsigned_int) return vector_unsigned_int + is + begin + return + To_LL_VUI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_bool_int; + B : vector_bool_int; + C : vector_bool_int) return vector_bool_int + is + begin + return + To_LL_VBI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_bool_int; + B : vector_bool_int; + C : vector_unsigned_int) return vector_bool_int + is + begin + return + To_LL_VBI (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_signed_short; + B : vector_signed_short; + C : vector_bool_short) return vector_signed_short + is + begin + return + To_LL_VSS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_signed_short; + B : vector_signed_short; + C : vector_unsigned_short) return vector_signed_short + is + begin + return + To_LL_VSS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_bool_short) return vector_unsigned_short + is + begin + return + To_LL_VUS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_unsigned_short + is + begin + return + To_LL_VUS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_bool_short; + B : vector_bool_short; + C : vector_bool_short) return vector_bool_short + is + begin + return + To_LL_VBS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_bool_short; + B : vector_bool_short; + C : vector_unsigned_short) return vector_bool_short + is + begin + return + To_LL_VBS (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_signed_char; + B : vector_signed_char; + C : vector_bool_char) return vector_signed_char + is + begin + return + To_LL_VSC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_signed_char; + B : vector_signed_char; + C : vector_unsigned_char) return vector_signed_char + is + begin + return + To_LL_VSC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_bool_char) return vector_unsigned_char + is + begin + return + To_LL_VUC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_char) return vector_unsigned_char + is + begin + return + To_LL_VUC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_bool_char; + B : vector_bool_char; + C : vector_bool_char) return vector_bool_char + is + begin + return + To_LL_VBC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + function vec_sel + (A : vector_bool_char; + B : vector_bool_char; + C : vector_unsigned_char) return vector_bool_char + is + begin + return + To_LL_VBC (vsel_4si (To_LL_VSI (A), To_LL_VSI (B), To_LL_VSI (C))); + end vec_sel; + + ------------ + -- vec_sl -- + ------------ + + function vec_sl + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vslb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sl; + + function vec_sl + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vslb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sl; + + function vec_sl + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vslh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sl; + + function vec_sl + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vslh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sl; + + function vec_sl + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vslw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sl; + + function vec_sl + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vslw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sl; + + -------------- + -- vec_vslw -- + -------------- + + function vec_vslw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vslw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vslw; + + function vec_vslw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vslw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vslw; + + -------------- + -- vec_vslh -- + -------------- + + function vec_vslh + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vslh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vslh; + + function vec_vslh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vslh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vslh; + + -------------- + -- vec_vslb -- + -------------- + + function vec_vslb + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vslb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vslb; + + function vec_vslb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vslb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vslb; + + ------------- + -- vec_sll -- + ------------- + + function vec_sll + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_int; + B : vector_unsigned_short) return vector_signed_int + is + begin + return To_LL_VSI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + is + begin + return To_LL_VSI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_int; + B : vector_unsigned_short) return vector_unsigned_int + is + begin + return To_LL_VUI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + is + begin + return To_LL_VUI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_int; + B : vector_unsigned_int) return vector_bool_int + is + begin + return To_LL_VBI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_int; + B : vector_unsigned_short) return vector_bool_int + is + begin + return To_LL_VBI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_int; + B : vector_unsigned_char) return vector_bool_int + is + begin + return To_LL_VBI (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_short; + B : vector_unsigned_int) return vector_signed_short + is + begin + return To_LL_VSS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + is + begin + return To_LL_VSS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_short; + B : vector_unsigned_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_short; + B : vector_unsigned_int) return vector_bool_short + is + begin + return To_LL_VBS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_short; + B : vector_unsigned_short) return vector_bool_short + is + begin + return To_LL_VBS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_short; + B : vector_unsigned_char) return vector_bool_short + is + begin + return To_LL_VBS (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_pixel; + B : vector_unsigned_int) return vector_pixel + is + begin + return To_LL_VP (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_pixel; + B : vector_unsigned_short) return vector_pixel + is + begin + return To_LL_VP (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + is + begin + return To_LL_VP (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_char; + B : vector_unsigned_int) return vector_signed_char + is + begin + return To_LL_VSC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_char; + B : vector_unsigned_short) return vector_signed_char + is + begin + return To_LL_VSC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_char + is + begin + return To_LL_VUC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_char; + B : vector_unsigned_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_char; + B : vector_unsigned_int) return vector_bool_char + is + begin + return To_LL_VBC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_char; + B : vector_unsigned_short) return vector_bool_char + is + begin + return To_LL_VBC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + function vec_sll + (A : vector_bool_char; + B : vector_unsigned_char) return vector_bool_char + is + begin + return To_LL_VBC (vsl (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sll; + + ------------- + -- vec_slo -- + ------------- + + function vec_slo + (A : vector_float; + B : vector_signed_char) return vector_float + is + begin + return To_LL_VF (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_float; + B : vector_unsigned_char) return vector_float + is + begin + return To_LL_VF (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_signed_int; + B : vector_signed_char) return vector_signed_int + is + begin + return To_LL_VSI (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + is + begin + return To_LL_VSI (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_unsigned_int; + B : vector_signed_char) return vector_unsigned_int + is + begin + return To_LL_VUI (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + is + begin + return To_LL_VUI (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_signed_short; + B : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + is + begin + return To_LL_VSS (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_unsigned_short; + B : vector_signed_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_pixel; + B : vector_signed_char) return vector_pixel + is + begin + return To_LL_VP (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + is + begin + return To_LL_VP (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_unsigned_char; + B : vector_signed_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + function vec_slo + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vslo (To_LL_VSI (A), To_LL_VSI (B))); + end vec_slo; + + ------------ + -- vec_sr -- + ------------ + + function vec_sr + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sr; + + function vec_sr + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sr; + + function vec_sr + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sr; + + function vec_sr + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sr; + + function vec_sr + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sr; + + function vec_sr + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sr; + + -------------- + -- vec_vsrw -- + -------------- + + function vec_vsrw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsrw; + + function vec_vsrw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsrw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsrw; + + -------------- + -- vec_vsrh -- + -------------- + + function vec_vsrh + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsrh; + + function vec_vsrh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsrh (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsrh; + + -------------- + -- vec_vsrb -- + -------------- + + function vec_vsrb + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsrb; + + function vec_vsrb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsrb (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsrb; + + ------------- + -- vec_sra -- + ------------- + + function vec_sra + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sra; + + function vec_sra + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sra; + + function vec_sra + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sra; + + function vec_sra + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sra; + + function vec_sra + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sra; + + function vec_sra + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sra; + + --------------- + -- vec_vsraw -- + --------------- + + function vec_vsraw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsraw; + + function vec_vsraw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsraw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsraw; + + --------------- + -- vec_vsrah -- + --------------- + + function vec_vsrah + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsrah; + + function vec_vsrah + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsrah (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsrah; + + --------------- + -- vec_vsrab -- + --------------- + + function vec_vsrab + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsrab; + + function vec_vsrab + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsrab (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsrab; + + ------------- + -- vec_srl -- + ------------- + + function vec_srl + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + is + begin + return To_LL_VSI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_int; + B : vector_unsigned_short) return vector_signed_int + is + begin + return To_LL_VSI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + is + begin + return To_LL_VSI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_int; + B : vector_unsigned_short) return vector_unsigned_int + is + begin + return To_LL_VUI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + is + begin + return To_LL_VUI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_int; + B : vector_unsigned_int) return vector_bool_int + is + begin + return To_LL_VBI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_int; + B : vector_unsigned_short) return vector_bool_int + is + begin + return To_LL_VBI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_int; + B : vector_unsigned_char) return vector_bool_int + is + begin + return To_LL_VBI (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_short; + B : vector_unsigned_int) return vector_signed_short + is + begin + return To_LL_VSS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + is + begin + return To_LL_VSS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + is + begin + return To_LL_VSS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_short; + B : vector_unsigned_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_short; + B : vector_unsigned_int) return vector_bool_short + is + begin + return To_LL_VBS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_short; + B : vector_unsigned_short) return vector_bool_short + is + begin + return To_LL_VBS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_short; + B : vector_unsigned_char) return vector_bool_short + is + begin + return To_LL_VBS (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_pixel; + B : vector_unsigned_int) return vector_pixel + is + begin + return To_LL_VP (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_pixel; + B : vector_unsigned_short) return vector_pixel + is + begin + return To_LL_VP (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + is + begin + return To_LL_VP (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_char; + B : vector_unsigned_int) return vector_signed_char + is + begin + return To_LL_VSC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_char; + B : vector_unsigned_short) return vector_signed_char + is + begin + return To_LL_VSC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_char + is + begin + return To_LL_VUC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_char; + B : vector_unsigned_short) return vector_unsigned_char + is + begin + return To_LL_VUC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_char; + B : vector_unsigned_int) return vector_bool_char + is + begin + return To_LL_VBC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_char; + B : vector_unsigned_short) return vector_bool_char + is + begin + return To_LL_VBC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + function vec_srl + (A : vector_bool_char; + B : vector_unsigned_char) return vector_bool_char + is + begin + return To_LL_VBC (vsr (To_LL_VSI (A), To_LL_VSI (B))); + end vec_srl; + + ------------- + -- vec_sro -- + ------------- + + function vec_sro + (A : vector_float; + B : vector_signed_char) return vector_float + is + begin + return To_LL_VF (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_float; + B : vector_unsigned_char) return vector_float + is + begin + return To_LL_VF (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_signed_int; + B : vector_signed_char) return vector_signed_int + is + begin + return To_LL_VSI (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + is + begin + return To_LL_VSI (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_unsigned_int; + B : vector_signed_char) return vector_unsigned_int + is + begin + return To_LL_VUI (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + is + begin + return To_LL_VUI (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_signed_short; + B : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + is + begin + return To_LL_VSS (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_unsigned_short; + B : vector_signed_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + is + begin + return To_LL_VUS (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_pixel; + B : vector_signed_char) return vector_pixel + is + begin + return To_LL_VP (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + is + begin + return To_LL_VP (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + is + begin + return To_LL_VSC (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_unsigned_char; + B : vector_signed_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + function vec_sro + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsro (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sro; + + ------------ + -- vec_st -- + ------------ + + procedure vec_st + (A : vector_float; + B : c_int; + C : vector_float_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_float; + B : c_int; + C : float_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_signed_int; + B : c_int; + C : vector_signed_int_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_signed_int; + B : c_int; + C : int_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_unsigned_int; + B : c_int; + C : vector_unsigned_int_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_int; + B : c_int; + C : vector_bool_int_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_int; + B : c_int; + C : int_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_signed_short; + B : c_int; + C : vector_signed_short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_signed_short; + B : c_int; + C : short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_unsigned_short; + B : c_int; + C : vector_unsigned_short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_short; + B : c_int; + C : vector_bool_short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_pixel; + B : c_int; + C : vector_pixel_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_pixel; + B : c_int; + C : short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_short; + B : c_int; + C : short_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_signed_char; + B : c_int; + C : vector_signed_char_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_unsigned_char; + B : c_int; + C : vector_unsigned_char_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_char; + B : c_int; + C : vector_bool_char_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + procedure vec_st + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvx (To_LL_VSI (A), B, To_PTR (C)); + end vec_st; + + ------------- + -- vec_ste -- + ------------- + + procedure vec_ste + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_signed_short; + B : c_int; + C : short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_bool_short; + B : c_int; + C : short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_pixel; + B : c_int; + C : short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_float; + B : c_int; + C : float_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_signed_int; + B : c_int; + C : int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_bool_int; + B : c_int; + C : int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_ste; + + procedure vec_ste + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_ste; + + ---------------- + -- vec_stvewx -- + ---------------- + + procedure vec_stvewx + (A : vector_float; + B : c_int; + C : float_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_stvewx; + + procedure vec_stvewx + (A : vector_signed_int; + B : c_int; + C : int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_stvewx; + + procedure vec_stvewx + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_stvewx; + + procedure vec_stvewx + (A : vector_bool_int; + B : c_int; + C : int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_stvewx; + + procedure vec_stvewx + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvewx (To_LL_VSI (A), B, To_PTR (C)); + end vec_stvewx; + + ---------------- + -- vec_stvehx -- + ---------------- + + procedure vec_stvehx + (A : vector_signed_short; + B : c_int; + C : short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_stvehx; + + procedure vec_stvehx + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_stvehx; + + procedure vec_stvehx + (A : vector_bool_short; + B : c_int; + C : short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_stvehx; + + procedure vec_stvehx + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_stvehx; + + procedure vec_stvehx + (A : vector_pixel; + B : c_int; + C : short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_stvehx; + + procedure vec_stvehx + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvehx (To_LL_VSS (A), B, To_PTR (C)); + end vec_stvehx; + + ---------------- + -- vec_stvebx -- + ---------------- + + procedure vec_stvebx + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_stvebx; + + procedure vec_stvebx + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_stvebx; + + procedure vec_stvebx + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_stvebx; + + procedure vec_stvebx + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvebx (To_LL_VSC (A), B, To_PTR (C)); + end vec_stvebx; + + ------------- + -- vec_stl -- + ------------- + + procedure vec_stl + (A : vector_float; + B : c_int; + C : vector_float_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_float; + B : c_int; + C : float_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_signed_int; + B : c_int; + C : vector_signed_int_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_signed_int; + B : c_int; + C : int_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_unsigned_int; + B : c_int; + C : vector_unsigned_int_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_int; + B : c_int; + C : vector_bool_int_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_int; + B : c_int; + C : int_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_signed_short; + B : c_int; + C : vector_signed_short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_signed_short; + B : c_int; + C : short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_unsigned_short; + B : c_int; + C : vector_unsigned_short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_short; + B : c_int; + C : vector_bool_short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_short; + B : c_int; + C : short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_pixel; + B : c_int; + C : vector_pixel_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_pixel; + B : c_int; + C : short_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_signed_char; + B : c_int; + C : vector_signed_char_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_unsigned_char; + B : c_int; + C : vector_unsigned_char_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_char; + B : c_int; + C : vector_bool_char_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + procedure vec_stl + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr) + is + begin + stvxl (To_LL_VSI (A), B, To_PTR (C)); + end vec_stl; + + ------------- + -- vec_sub -- + ------------- + + function vec_sub + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sub; + + function vec_sub + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sub; + + function vec_sub + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sub; + + function vec_sub + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sub; + + function vec_sub + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sub; + + function vec_sub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_sub; + + function vec_sub + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sub; + + function vec_sub + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sub; + + function vec_sub + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sub; + + function vec_sub + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sub; + + function vec_sub + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sub; + + function vec_sub + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_sub; + + function vec_sub + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sub; + + function vec_sub + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sub; + + function vec_sub + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sub; + + function vec_sub + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sub; + + function vec_sub + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sub; + + function vec_sub + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sub; + + function vec_sub + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vsubfp (To_LL_VF (A), To_LL_VF (B))); + end vec_sub; + + ---------------- + -- vec_vsubfp -- + ---------------- + + function vec_vsubfp + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vsubfp (To_LL_VF (A), To_LL_VF (B))); + end vec_vsubfp; + + ----------------- + -- vec_vsubuwm -- + ----------------- + + function vec_vsubuwm + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuwm; + + function vec_vsubuwm + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuwm; + + function vec_vsubuwm + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuwm; + + function vec_vsubuwm + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuwm; + + function vec_vsubuwm + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuwm; + + function vec_vsubuwm + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuwm (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuwm; + + ----------------- + -- vec_vsubuhm -- + ----------------- + + function vec_vsubuhm + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhm; + + function vec_vsubuhm + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhm; + + function vec_vsubuhm + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhm; + + function vec_vsubuhm + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhm; + + function vec_vsubuhm + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhm; + + function vec_vsubuhm + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhm (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhm; + + ----------------- + -- vec_vsububm -- + ----------------- + + function vec_vsububm + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububm; + + function vec_vsububm + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububm; + + function vec_vsububm + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububm; + + function vec_vsububm + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububm; + + function vec_vsububm + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububm; + + function vec_vsububm + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububm (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububm; + + -------------- + -- vec_subc -- + -------------- + + function vec_subc + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubcuw (To_LL_VSI (A), To_LL_VSI (B))); + end vec_subc; + + -------------- + -- vec_subs -- + -------------- + + function vec_subs + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_subs; + + function vec_subs + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_subs; + + function vec_subs + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_subs; + + function vec_subs + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_subs; + + function vec_subs + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_subs; + + function vec_subs + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_subs; + + function vec_subs + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_subs; + + function vec_subs + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_subs; + + function vec_subs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_subs; + + function vec_subs + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_subs; + + function vec_subs + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_subs; + + function vec_subs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_subs; + + function vec_subs + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_subs; + + function vec_subs + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_subs; + + function vec_subs + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_subs; + + function vec_subs + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_subs; + + function vec_subs + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_subs; + + function vec_subs + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_subs; + + ----------------- + -- vec_vsubsws -- + ----------------- + + function vec_vsubsws + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubsws; + + function vec_vsubsws + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubsws; + + function vec_vsubsws + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsubsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubsws; + + ----------------- + -- vec_vsubuws -- + ----------------- + + function vec_vsubuws + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuws; + + function vec_vsubuws + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuws; + + function vec_vsubuws + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsubuws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_vsubuws; + + ----------------- + -- vec_vsubshs -- + ----------------- + + function vec_vsubshs + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubshs; + + function vec_vsubshs + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubshs; + + function vec_vsubshs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vsubshs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubshs; + + ----------------- + -- vec_vsubuhs -- + ----------------- + + function vec_vsubuhs + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhs; + + function vec_vsubuhs + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhs; + + function vec_vsubuhs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vsubuhs (To_LL_VSS (A), To_LL_VSS (B))); + end vec_vsubuhs; + + ----------------- + -- vec_vsubsbs -- + ----------------- + + function vec_vsubsbs + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsubsbs; + + function vec_vsubsbs + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsubsbs; + + function vec_vsubsbs + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vsubsbs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsubsbs; + + ----------------- + -- vec_vsububs -- + ----------------- + + function vec_vsububs + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububs; + + function vec_vsububs + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububs; + + function vec_vsububs + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vsububs (To_LL_VSC (A), To_LL_VSC (B))); + end vec_vsububs; + + --------------- + -- vec_sum4s -- + --------------- + + function vec_sum4s + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsum4ubs (To_LL_VSC (A), To_LL_VSI (B))); + end vec_sum4s; + + function vec_sum4s + (A : vector_signed_char; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsum4sbs (To_LL_VSC (A), To_LL_VSI (B))); + end vec_sum4s; + + function vec_sum4s + (A : vector_signed_short; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsum4shs (To_LL_VSS (A), To_LL_VSI (B))); + end vec_sum4s; + + ------------------ + -- vec_vsum4shs -- + ------------------ + + function vec_vsum4shs + (A : vector_signed_short; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsum4shs (To_LL_VSS (A), To_LL_VSI (B))); + end vec_vsum4shs; + + ------------------ + -- vec_vsum4sbs -- + ------------------ + + function vec_vsum4sbs + (A : vector_signed_char; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsum4sbs (To_LL_VSC (A), To_LL_VSI (B))); + end vec_vsum4sbs; + + ------------------ + -- vec_vsum4ubs -- + ------------------ + + function vec_vsum4ubs + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsum4ubs (To_LL_VSC (A), To_LL_VSI (B))); + end vec_vsum4ubs; + + --------------- + -- vec_sum2s -- + --------------- + + function vec_sum2s + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsum2sws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sum2s; + + -------------- + -- vec_sums -- + -------------- + + function vec_sums + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vsumsws (To_LL_VSI (A), To_LL_VSI (B))); + end vec_sums; + + --------------- + -- vec_trunc -- + --------------- + + function vec_trunc + (A : vector_float) return vector_float + is + begin + return To_LL_VF (vrfiz (To_LL_VF (A))); + end vec_trunc; + + ----------------- + -- vec_unpackh -- + ----------------- + + function vec_unpackh + (A : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vupkhsb (To_LL_VSC (A))); + end vec_unpackh; + + function vec_unpackh + (A : vector_bool_char) return vector_bool_short + is + begin + return To_LL_VBS (vupkhsb (To_LL_VSC (A))); + end vec_unpackh; + + function vec_unpackh + (A : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vupkhsh (To_LL_VSS (A))); + end vec_unpackh; + + function vec_unpackh + (A : vector_bool_short) return vector_bool_int + is + begin + return To_LL_VBI (vupkhsh (To_LL_VSS (A))); + end vec_unpackh; + + function vec_unpackh + (A : vector_pixel) return vector_unsigned_int + is + begin + return To_LL_VUI (vupkhpx (To_LL_VSS (A))); + end vec_unpackh; + + ----------------- + -- vec_vupkhsh -- + ----------------- + + function vec_vupkhsh + (A : vector_bool_short) return vector_bool_int + is + begin + return To_LL_VBI (vupkhsh (To_LL_VSS (A))); + end vec_vupkhsh; + + function vec_vupkhsh + (A : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vupkhsh (To_LL_VSS (A))); + end vec_vupkhsh; + + ----------------- + -- vec_vupkhpx -- + ----------------- + + function vec_vupkhpx + (A : vector_pixel) return vector_unsigned_int + is + begin + return To_LL_VUI (vupkhpx (To_LL_VSS (A))); + end vec_vupkhpx; + + ----------------- + -- vec_vupkhsb -- + ----------------- + + function vec_vupkhsb + (A : vector_bool_char) return vector_bool_short + is + begin + return To_LL_VBS (vupkhsb (To_LL_VSC (A))); + end vec_vupkhsb; + + function vec_vupkhsb + (A : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vupkhsb (To_LL_VSC (A))); + end vec_vupkhsb; + + ----------------- + -- vec_unpackl -- + ----------------- + + function vec_unpackl + (A : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vupklsb (To_LL_VSC (A))); + end vec_unpackl; + + function vec_unpackl + (A : vector_bool_char) return vector_bool_short + is + begin + return To_LL_VBS (vupklsb (To_LL_VSC (A))); + end vec_unpackl; + + function vec_unpackl + (A : vector_pixel) return vector_unsigned_int + is + begin + return To_LL_VUI (vupklpx (To_LL_VSS (A))); + end vec_unpackl; + + function vec_unpackl + (A : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vupklsh (To_LL_VSS (A))); + end vec_unpackl; + + function vec_unpackl + (A : vector_bool_short) return vector_bool_int + is + begin + return To_LL_VBI (vupklsh (To_LL_VSS (A))); + end vec_unpackl; + + ----------------- + -- vec_vupklpx -- + ----------------- + + function vec_vupklpx + (A : vector_pixel) return vector_unsigned_int + is + begin + return To_LL_VUI (vupklpx (To_LL_VSS (A))); + end vec_vupklpx; + + ----------------- + -- vec_vupklsh -- + ----------------- + + function vec_vupklsh + (A : vector_bool_short) return vector_bool_int + is + begin + return To_LL_VBI (vupklsh (To_LL_VSS (A))); + end vec_vupklsh; + + function vec_vupklsh + (A : vector_signed_short) return vector_signed_int + is + begin + return To_LL_VSI (vupklsh (To_LL_VSS (A))); + end vec_vupklsh; + + ----------------- + -- vec_vupklsb -- + ----------------- + + function vec_vupklsb + (A : vector_bool_char) return vector_bool_short + is + begin + return To_LL_VBS (vupklsb (To_LL_VSC (A))); + end vec_vupklsb; + + function vec_vupklsb + (A : vector_signed_char) return vector_signed_short + is + begin + return To_LL_VSS (vupklsb (To_LL_VSC (A))); + end vec_vupklsb; + + ------------- + -- vec_xor -- + ------------- + + function vec_xor + (A : vector_float; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_float; + B : vector_bool_int) return vector_float + is + begin + return To_LL_VF (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_int; + B : vector_float) return vector_float + is + begin + return To_LL_VF (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + is + begin + return To_LL_VBI (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + is + begin + return To_LL_VSI (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + is + begin + return To_LL_VSI (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + is + begin + return To_LL_VBS (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + is + begin + return To_LL_VSS (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + is + begin + return To_LL_VSS (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + is + begin + return To_LL_VUS (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + is + begin + return To_LL_VBC (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + is + begin + return To_LL_VSC (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + is + begin + return To_LL_VSC (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + function vec_xor + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + is + begin + return To_LL_VUC (vxor (To_LL_VSI (A), To_LL_VSI (B))); + end vec_xor; + + ------------- + -- vec_dst -- + ------------- + + procedure vec_dst + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_short_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_int_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_long_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + procedure vec_dst + (A : const_float_ptr; + B : c_int; + C : c_int) + is + begin + dst (To_PTR (A), B, C); + end vec_dst; + + -------------- + -- vec_dstt -- + -------------- + + procedure vec_dstt + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_short_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_int_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_long_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + procedure vec_dstt + (A : const_float_ptr; + B : c_int; + C : c_int) + is + begin + dstt (To_PTR (A), B, C); + end vec_dstt; + + --------------- + -- vec_dstst -- + --------------- + + procedure vec_dstst + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_short_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_int_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_long_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + procedure vec_dstst + (A : const_float_ptr; + B : c_int; + C : c_int) + is + begin + dstst (To_PTR (A), B, C); + end vec_dstst; + + ---------------- + -- vec_dststt -- + ---------------- + + procedure vec_dststt + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_vector_float_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_signed_char_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_short_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_int_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_long_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + procedure vec_dststt + (A : const_float_ptr; + B : c_int; + C : c_int) + is + begin + dststt (To_PTR (A), B, C); + end vec_dststt; + + ---------------- + -- vec_vspltw -- + ---------------- + + function vec_vspltw + (A : vector_float; + B : c_int) return vector_float + is + begin + return To_LL_VF (vspltw (To_LL_VSI (A), B)); + end vec_vspltw; + + function vec_vspltw + (A : vector_unsigned_int; + B : c_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vspltw (To_LL_VSI (A), B)); + end vec_vspltw; + + function vec_vspltw + (A : vector_bool_int; + B : c_int) return vector_bool_int + is + begin + return To_LL_VBI (vspltw (To_LL_VSI (A), B)); + end vec_vspltw; + + ---------------- + -- vec_vsplth -- + ---------------- + + function vec_vsplth + (A : vector_bool_short; + B : c_int) return vector_bool_short + is + begin + return To_LL_VBS (vsplth (To_LL_VSS (A), B)); + end vec_vsplth; + + function vec_vsplth + (A : vector_unsigned_short; + B : c_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vsplth (To_LL_VSS (A), B)); + end vec_vsplth; + + function vec_vsplth + (A : vector_pixel; + B : c_int) return vector_pixel + is + begin + return To_LL_VP (vsplth (To_LL_VSS (A), B)); + end vec_vsplth; + + ---------------- + -- vec_vspltb -- + ---------------- + + function vec_vspltb + (A : vector_unsigned_char; + B : c_int) return vector_unsigned_char + is + begin + return To_LL_VUC (vspltb (To_LL_VSC (A), B)); + end vec_vspltb; + + function vec_vspltb + (A : vector_bool_char; + B : c_int) return vector_bool_char + is + begin + return To_LL_VBC (vspltb (To_LL_VSC (A), B)); + end vec_vspltb; + + ------------------ + -- vec_splat_u8 -- + ------------------ + + function vec_splat_u8 + (A : c_int) return vector_unsigned_char + is + begin + return To_LL_VUC (vspltisb (A)); + end vec_splat_u8; + + ------------------- + -- vec_splat_u16 -- + ------------------- + + function vec_splat_u16 + (A : c_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vspltish (A)); + end vec_splat_u16; + + ------------------- + -- vec_splat_u32 -- + ------------------- + + function vec_splat_u32 + (A : c_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vspltisw (A)); + end vec_splat_u32; + + ------------- + -- vec_sld -- + ------------- + + function vec_sld + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : c_int) return vector_unsigned_int + is + begin + return To_LL_VUI (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); + end vec_sld; + + function vec_sld + (A : vector_bool_int; + B : vector_bool_int; + C : c_int) return vector_bool_int + is + begin + return To_LL_VBI (vsldoi_4si (To_LL_VSI (A), To_LL_VSI (B), C)); + end vec_sld; + + function vec_sld + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : c_int) return vector_unsigned_short + is + begin + return To_LL_VUS (vsldoi_8hi (To_LL_VSS (A), To_LL_VSS (B), C)); + end vec_sld; + + function vec_sld + (A : vector_bool_short; + B : vector_bool_short; + C : c_int) return vector_bool_short + is + begin + return To_LL_VBS (vsldoi_8hi (To_LL_VSS (A), To_LL_VSS (B), C)); + end vec_sld; + + function vec_sld + (A : vector_pixel; + B : vector_pixel; + C : c_int) return vector_pixel + is + begin + return To_LL_VP (vsldoi_8hi (To_LL_VSS (A), To_LL_VSS (B), C)); + end vec_sld; + + function vec_sld + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : c_int) return vector_unsigned_char + is + begin + return To_LL_VUC (vsldoi_16qi (To_LL_VSC (A), To_LL_VSC (B), C)); + end vec_sld; + + function vec_sld + (A : vector_bool_char; + B : vector_bool_char; + C : c_int) return vector_bool_char + is + begin + return To_LL_VBC (vsldoi_16qi (To_LL_VSC (A), To_LL_VSC (B), C)); + end vec_sld; + + ---------------- + -- vec_all_eq -- + ---------------- + + function vec_all_eq + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_pixel; + B : vector_pixel) return c_int + is + begin + return vcmpequh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_eq; + + function vec_all_eq + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_LT, To_LL_VF (A), To_LL_VF (B)); + end vec_all_eq; + + ---------------- + -- vec_all_ge -- + ---------------- + + function vec_all_ge + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_ge; + + function vec_all_ge + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_LT, To_LL_VF (A), To_LL_VF (B)); + end vec_all_ge; + + ---------------- + -- vec_all_gt -- + ---------------- + + function vec_all_gt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_gt; + + function vec_all_gt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_LT, To_LL_VF (A), To_LL_VF (B)); + end vec_all_gt; + + ---------------- + -- vec_all_in -- + ---------------- + + function vec_all_in + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpbfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); + end vec_all_in; + + ---------------- + -- vec_all_le -- + ---------------- + + function vec_all_le + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_le; + + function vec_all_le + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_le; + + function vec_all_le + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_le; + + function vec_all_le + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_le; + + function vec_all_le + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_le; + + function vec_all_le + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_le; + + function vec_all_le + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_le; + + function vec_all_le + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_le; + + function vec_all_le + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_le; + + function vec_all_le + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_le; + + function vec_all_le + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_le; + + function vec_all_le + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_le; + + function vec_all_le + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_le; + + function vec_all_le + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_le; + + function vec_all_le + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_le; + + function vec_all_le + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_le; + + function vec_all_le + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_le; + + function vec_all_le + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_le; + + function vec_all_le + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_LT, To_LL_VF (B), To_LL_VF (A)); + end vec_all_le; + + ---------------- + -- vec_all_lt -- + ---------------- + + function vec_all_lt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT, To_LL_VSC (B), To_LL_VSC (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT, To_LL_VSS (B), To_LL_VSS (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT, To_LL_VSI (B), To_LL_VSI (A)); + end vec_all_lt; + + function vec_all_lt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_LT, To_LL_VF (B), To_LL_VF (A)); + end vec_all_lt; + + ----------------- + -- vec_all_nan -- + ----------------- + + function vec_all_nan + (A : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (A)); + end vec_all_nan; + + ---------------- + -- vec_all_ne -- + ---------------- + + function vec_all_ne + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ, To_LL_VSC (A), To_LL_VSC (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_pixel; + B : vector_pixel) return c_int + is + begin + return vcmpequh_p (CR6_EQ, To_LL_VSS (A), To_LL_VSS (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ, To_LL_VSI (A), To_LL_VSI (B)); + end vec_all_ne; + + function vec_all_ne + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); + end vec_all_ne; + + ----------------- + -- vec_all_nge -- + ----------------- + + function vec_all_nge + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); + end vec_all_nge; + + ----------------- + -- vec_all_ngt -- + ----------------- + + function vec_all_ngt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_EQ, To_LL_VF (A), To_LL_VF (B)); + end vec_all_ngt; + + ----------------- + -- vec_all_nle -- + ----------------- + + function vec_all_nle + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_EQ, To_LL_VF (B), To_LL_VF (A)); + end vec_all_nle; + + ----------------- + -- vec_all_nlt -- + ----------------- + + function vec_all_nlt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_EQ, To_LL_VF (B), To_LL_VF (A)); + end vec_all_nlt; + + --------------------- + -- vec_all_numeric -- + --------------------- + + function vec_all_numeric + (A : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_LT, To_LL_VF (A), To_LL_VF (A)); + end vec_all_numeric; + + ---------------- + -- vec_any_eq -- + ---------------- + + function vec_any_eq + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_pixel; + B : vector_pixel) return c_int + is + begin + return vcmpequh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_eq; + + function vec_any_eq + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); + end vec_any_eq; + + ---------------- + -- vec_any_ge -- + ---------------- + + function vec_any_ge + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_ge; + + function vec_any_ge + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); + end vec_any_ge; + + ---------------- + -- vec_any_gt -- + ---------------- + + function vec_any_gt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_gt; + + function vec_any_gt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); + end vec_any_gt; + + ---------------- + -- vec_any_le -- + ---------------- + + function vec_any_le + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_le; + + function vec_any_le + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_le; + + function vec_any_le + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_le; + + function vec_any_le + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_le; + + function vec_any_le + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_le; + + function vec_any_le + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_le; + + function vec_any_le + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_le; + + function vec_any_le + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_le; + + function vec_any_le + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_le; + + function vec_any_le + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_le; + + function vec_any_le + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_le; + + function vec_any_le + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_le; + + function vec_any_le + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_le; + + function vec_any_le + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_le; + + function vec_any_le + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_le; + + function vec_any_le + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_le; + + function vec_any_le + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_le; + + function vec_any_le + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_le; + + function vec_any_le + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_EQ_REV, To_LL_VF (B), To_LL_VF (A)); + end vec_any_le; + + ---------------- + -- vec_any_lt -- + ---------------- + + function vec_any_lt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpgtub_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpgtsb_p (CR6_EQ_REV, To_LL_VSC (B), To_LL_VSC (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpgtuh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpgtsh_p (CR6_EQ_REV, To_LL_VSS (B), To_LL_VSS (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpgtuw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpgtsw_p (CR6_EQ_REV, To_LL_VSI (B), To_LL_VSI (A)); + end vec_any_lt; + + function vec_any_lt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_EQ_REV, To_LL_VF (B), To_LL_VF (A)); + end vec_any_lt; + + ----------------- + -- vec_any_nan -- + ----------------- + + function vec_any_nan + (A : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (A)); + end vec_any_nan; + + ---------------- + -- vec_any_ne -- + ---------------- + + function vec_any_ne + (A : vector_signed_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_signed_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_unsigned_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_char; + B : vector_bool_char) return c_int + is + begin + return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_char; + B : vector_unsigned_char) return c_int + is + begin + return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_char; + B : vector_signed_char) return c_int + is + begin + return vcmpequb_p (CR6_LT_REV, To_LL_VSC (A), To_LL_VSC (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_signed_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_signed_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_unsigned_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_short; + B : vector_bool_short) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_short; + B : vector_unsigned_short) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_short; + B : vector_signed_short) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_pixel; + B : vector_pixel) return c_int + is + begin + return vcmpequh_p (CR6_LT_REV, To_LL_VSS (A), To_LL_VSS (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_signed_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_signed_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_unsigned_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_int; + B : vector_bool_int) return c_int + is + begin + return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_int; + B : vector_unsigned_int) return c_int + is + begin + return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_bool_int; + B : vector_signed_int) return c_int + is + begin + return vcmpequw_p (CR6_LT_REV, To_LL_VSI (A), To_LL_VSI (B)); + end vec_any_ne; + + function vec_any_ne + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (B)); + end vec_any_ne; + + ----------------- + -- vec_any_nge -- + ----------------- + + function vec_any_nge + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (B)); + end vec_any_nge; + + ----------------- + -- vec_any_ngt -- + ----------------- + + function vec_any_ngt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_LT_REV, To_LL_VF (A), To_LL_VF (B)); + end vec_any_ngt; + + ----------------- + -- vec_any_nle -- + ----------------- + + function vec_any_nle + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgefp_p (CR6_LT_REV, To_LL_VF (B), To_LL_VF (A)); + end vec_any_nle; + + ----------------- + -- vec_any_nlt -- + ----------------- + + function vec_any_nlt + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpgtfp_p (CR6_LT_REV, To_LL_VF (B), To_LL_VF (A)); + end vec_any_nlt; + + --------------------- + -- vec_any_numeric -- + --------------------- + + function vec_any_numeric + (A : vector_float) return c_int + is + begin + return vcmpeqfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (A)); + end vec_any_numeric; + + ----------------- + -- vec_any_out -- + ----------------- + + function vec_any_out + (A : vector_float; + B : vector_float) return c_int + is + begin + return vcmpbfp_p (CR6_EQ_REV, To_LL_VF (A), To_LL_VF (B)); + end vec_any_out; + + -------------- + -- vec_step -- + -------------- + + function vec_step + (V : vector_unsigned_char) return Integer + is + pragma Unreferenced (V); + begin + return 16; + end vec_step; + + function vec_step + (V : vector_signed_char) return Integer + is + pragma Unreferenced (V); + begin + return 16; + end vec_step; + + function vec_step + (V : vector_bool_char) return Integer + is + pragma Unreferenced (V); + begin + return 16; + end vec_step; + + function vec_step + (V : vector_unsigned_short) return Integer + is + pragma Unreferenced (V); + begin + return 8; + end vec_step; + + function vec_step + (V : vector_signed_short) return Integer + is + pragma Unreferenced (V); + begin + return 8; + end vec_step; + + function vec_step + (V : vector_bool_short) return Integer + is + pragma Unreferenced (V); + begin + return 8; + end vec_step; + + function vec_step + (V : vector_unsigned_int) return Integer + is + pragma Unreferenced (V); + begin + return 4; + end vec_step; + + function vec_step + (V : vector_signed_int) return Integer + is + pragma Unreferenced (V); + begin + return 4; + end vec_step; + + function vec_step + (V : vector_bool_int) return Integer + is + pragma Unreferenced (V); + begin + return 4; + end vec_step; + + function vec_step + (V : vector_float) return Integer + is + pragma Unreferenced (V); + begin + return 4; + end vec_step; + + function vec_step + (V : vector_pixel) return Integer + is + pragma Unreferenced (V); + begin + return 4; + end vec_step; + +end GNAT.Altivec.Vector_Operations; diff --git a/gcc/ada/libgnat/g-alveop.ads b/gcc/ada/libgnat/g-alveop.ads new file mode 100644 index 0000000..39782ba --- /dev/null +++ b/gcc/ada/libgnat/g-alveop.ads @@ -0,0 +1,8362 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . V E C T O R _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit is the user-level Ada interface to AltiVec operations on vector +-- objects. It is common to both the Soft and the Hard bindings. + +with GNAT.Altivec.Vector_Types; use GNAT.Altivec.Vector_Types; +with GNAT.Altivec.Low_Level_Vectors; use GNAT.Altivec.Low_Level_Vectors; + +------------------------------------ +-- GNAT.Altivec.Vector_Operations -- +------------------------------------ + +------------------------------------ +-- GNAT.Altivec.Vector_Operations -- +------------------------------------ + +package GNAT.Altivec.Vector_Operations is + + ------------------------------------- + -- Different Flavors of Interfaces -- + ------------------------------------- + + -- The vast majority of the user visible functions are just neutral type + -- conversion wrappers around calls to low level primitives. For instance: + + -- function vec_sll + -- (A : vector_signed_int; + -- B : vector_unsigned_char) return vector_signed_int is + -- begin + -- return To_VSI (vsl (To_VSI (A), To_VSI (B))); + -- end vec_sll; + + -- We actually don't always need an explicit wrapper and can bind directly + -- with a straight Import of the low level routine, or a renaming of such + -- instead. + + -- A direct binding is not possible (that is, a wrapper is mandatory) in + -- a number of cases: + + -- o When the high-level/low-level types don't match, in which case a + -- straight import would risk wrong code generation or compiler blowups in + -- the Hard binding case. This is the case for 'B' in the example above. + + -- o When the high-level/low-level argument lists differ, as is the case + -- for most of the AltiVec predicates, relying on a low-level primitive + -- which expects a control code argument, like: + + -- function vec_any_ne + -- (A : vector_signed_int; + -- B : vector_signed_int) return c_int is + -- begin + -- return vcmpequw_p (CR6_LT_REV, To_VSI (A), To_VSI (B)); + -- end vec_any_ne; + + -- o When the high-level/low-level arguments order don't match, as in: + + -- function vec_cmplt + -- (A : vector_unsigned_char; + -- B : vector_unsigned_char) return vector_bool_char is + -- begin + -- return To_VBC (vcmpgtub (To_VSC (B), To_VSC (A))); + -- end vec_cmplt; + + ----------------------------- + -- Inlining Considerations -- + ----------------------------- + + -- The intent in the hard binding case is to eventually map operations to + -- hardware instructions. Needless to say, intermediate function calls do + -- not fit this purpose, so all user visible subprograms need to be marked + -- Inline_Always. Some of the builtins we eventually bind to expect literal + -- arguments. Wrappers to such builtins are made Convention Intrinsic as + -- well so we don't attempt to compile the bodies on their own. + + -- In the soft case, the bulk of the work is performed by the low level + -- routines, and those exported by this unit are short enough for the + -- inlining to make sense and even be beneficial. + + ------------------------------------------------------- + -- [PIM-4.4 Generic and Specific AltiVec operations] -- + ------------------------------------------------------- + + ------------- + -- vec_abs -- + ------------- + + function vec_abs + (A : vector_signed_char) return vector_signed_char; + + function vec_abs + (A : vector_signed_short) return vector_signed_short; + + function vec_abs + (A : vector_signed_int) return vector_signed_int; + + function vec_abs + (A : vector_float) return vector_float; + + -------------- + -- vec_abss -- + -------------- + + function vec_abss + (A : vector_signed_char) return vector_signed_char; + + function vec_abss + (A : vector_signed_short) return vector_signed_short; + + function vec_abss + (A : vector_signed_int) return vector_signed_int; + + ------------- + -- vec_add -- + ------------- + + function vec_add + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_add + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_add + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_add + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_add + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_add + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_add + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_add + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_add + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_add + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_add + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_add + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_add + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_add + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_add + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_add + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_add + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_add + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_add + (A : vector_float; + B : vector_float) return vector_float; + + ---------------- + -- vec_vaddfp -- + ---------------- + + function vec_vaddfp + (A : vector_float; + B : vector_float) return vector_float; + + ----------------- + -- vec_vadduwm -- + ----------------- + + function vec_vadduwm + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vadduwm + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_vadduwm + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vadduwm + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vadduwm + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_vadduwm + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ----------------- + -- vec_vadduhm -- + ----------------- + + function vec_vadduhm + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vadduhm + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_vadduhm + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vadduhm + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vadduhm + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_vadduhm + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + ----------------- + -- vec_vaddubm -- + ----------------- + + function vec_vaddubm + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vaddubm + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_vaddubm + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vaddubm + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_vaddubm + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_vaddubm + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + -------------- + -- vec_addc -- + -------------- + + function vec_addc + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_adds -- + -------------- + + function vec_adds + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_adds + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_adds + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_adds + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_adds + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_adds + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_adds + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_adds + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_adds + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_adds + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_adds + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_adds + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_adds + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_adds + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_adds + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_adds + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_adds + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_adds + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ----------------- + -- vec_vaddsws -- + ----------------- + + function vec_vaddsws + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vaddsws + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_vaddsws + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ----------------- + -- vec_vadduws -- + ----------------- + + function vec_vadduws + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vadduws + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_vadduws + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ----------------- + -- vec_vaddshs -- + ----------------- + + function vec_vaddshs + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vaddshs + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_vaddshs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + ----------------- + -- vec_vadduhs -- + ----------------- + + function vec_vadduhs + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vadduhs + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_vadduhs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + ----------------- + -- vec_vaddsbs -- + ----------------- + + function vec_vaddsbs + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vaddsbs + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_vaddsbs + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + ----------------- + -- vec_vaddubs -- + ----------------- + + function vec_vaddubs + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_vaddubs + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_vaddubs + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ------------- + -- vec_and -- + ------------- + + function vec_and + (A : vector_float; + B : vector_float) return vector_float; + + function vec_and + (A : vector_float; + B : vector_bool_int) return vector_float; + + function vec_and + (A : vector_bool_int; + B : vector_float) return vector_float; + + function vec_and + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_and + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_and + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_and + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_and + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_and + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_and + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_and + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_and + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_and + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_and + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_and + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_and + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_and + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_and + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_and + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_and + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_and + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_and + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_and + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_and + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + -------------- + -- vec_andc -- + -------------- + + function vec_andc + (A : vector_float; + B : vector_float) return vector_float; + + function vec_andc + (A : vector_float; + B : vector_bool_int) return vector_float; + + function vec_andc + (A : vector_bool_int; + B : vector_float) return vector_float; + + function vec_andc + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_andc + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_andc + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_andc + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_andc + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_andc + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_andc + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_andc + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_andc + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_andc + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_andc + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_andc + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_andc + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_andc + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_andc + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_andc + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_andc + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_andc + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_andc + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_andc + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_andc + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ------------- + -- vec_avg -- + ------------- + + function vec_avg + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_avg + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_avg + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_avg + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_avg + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_avg + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ---------------- + -- vec_vavgsw -- + ---------------- + + function vec_vavgsw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ---------------- + -- vec_vavguw -- + ---------------- + + function vec_vavguw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ---------------- + -- vec_vavgsh -- + ---------------- + + function vec_vavgsh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + ---------------- + -- vec_vavguh -- + ---------------- + + function vec_vavguh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + ---------------- + -- vec_vavgsb -- + ---------------- + + function vec_vavgsb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + ---------------- + -- vec_vavgub -- + ---------------- + + function vec_vavgub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + -------------- + -- vec_ceil -- + -------------- + + function vec_ceil + (A : vector_float) return vector_float; + + -------------- + -- vec_cmpb -- + -------------- + + function vec_cmpb + (A : vector_float; + B : vector_float) return vector_signed_int; + + function vec_cmpeq + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char; + + function vec_cmpeq + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char; + + function vec_cmpeq + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short; + + function vec_cmpeq + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short; + + function vec_cmpeq + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int; + + function vec_cmpeq + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int; + + function vec_cmpeq + (A : vector_float; + B : vector_float) return vector_bool_int; + + ------------------ + -- vec_vcmpeqfp -- + ------------------ + + function vec_vcmpeqfp + (A : vector_float; + B : vector_float) return vector_bool_int; + + ------------------ + -- vec_vcmpequw -- + ------------------ + + function vec_vcmpequw + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int; + + function vec_vcmpequw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int; + + ------------------ + -- vec_vcmpequh -- + ------------------ + + function vec_vcmpequh + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short; + + function vec_vcmpequh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short; + + ------------------ + -- vec_vcmpequb -- + ------------------ + + function vec_vcmpequb + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char; + + function vec_vcmpequb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char; + + --------------- + -- vec_cmpge -- + --------------- + + function vec_cmpge + (A : vector_float; + B : vector_float) return vector_bool_int; + + --------------- + -- vec_cmpgt -- + --------------- + + function vec_cmpgt + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char; + + function vec_cmpgt + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char; + + function vec_cmpgt + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short; + + function vec_cmpgt + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short; + + function vec_cmpgt + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int; + + function vec_cmpgt + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int; + + function vec_cmpgt + (A : vector_float; + B : vector_float) return vector_bool_int; + + ------------------ + -- vec_vcmpgtfp -- + ------------------ + + function vec_vcmpgtfp + (A : vector_float; + B : vector_float) return vector_bool_int; + + ------------------ + -- vec_vcmpgtsw -- + ------------------ + + function vec_vcmpgtsw + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int; + + ------------------ + -- vec_vcmpgtuw -- + ------------------ + + function vec_vcmpgtuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int; + + ------------------ + -- vec_vcmpgtsh -- + ------------------ + + function vec_vcmpgtsh + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short; + + ------------------ + -- vec_vcmpgtuh -- + ------------------ + + function vec_vcmpgtuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short; + + ------------------ + -- vec_vcmpgtsb -- + ------------------ + + function vec_vcmpgtsb + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char; + + ------------------ + -- vec_vcmpgtub -- + ------------------ + + function vec_vcmpgtub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char; + + --------------- + -- vec_cmple -- + --------------- + + function vec_cmple + (A : vector_float; + B : vector_float) return vector_bool_int; + + --------------- + -- vec_cmplt -- + --------------- + + function vec_cmplt + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_bool_char; + + function vec_cmplt + (A : vector_signed_char; + B : vector_signed_char) return vector_bool_char; + + function vec_cmplt + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_bool_short; + + function vec_cmplt + (A : vector_signed_short; + B : vector_signed_short) return vector_bool_short; + + function vec_cmplt + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_bool_int; + + function vec_cmplt + (A : vector_signed_int; + B : vector_signed_int) return vector_bool_int; + + function vec_cmplt + (A : vector_float; + B : vector_float) return vector_bool_int; + + --------------- + -- vec_vcfsx -- + --------------- + + function vec_vcfsx + (A : vector_signed_int; + B : c_int) return vector_float + renames Low_Level_Vectors.vcfsx; + + --------------- + -- vec_vcfux -- + --------------- + + function vec_vcfux + (A : vector_unsigned_int; + B : c_int) return vector_float + renames Low_Level_Vectors.vcfux; + + ---------------- + -- vec_vctsxs -- + ---------------- + + function vec_vctsxs + (A : vector_float; + B : c_int) return vector_signed_int + renames Low_Level_Vectors.vctsxs; + + ---------------- + -- vec_vctuxs -- + ---------------- + + function vec_vctuxs + (A : vector_float; + B : c_int) return vector_unsigned_int + renames Low_Level_Vectors.vctuxs; + + ------------- + -- vec_dss -- + ------------- + + procedure vec_dss + (A : c_int) + renames Low_Level_Vectors.dss; + + ---------------- + -- vec_dssall -- + ---------------- + + procedure vec_dssall + renames Low_Level_Vectors.dssall; + + ------------- + -- vec_dst -- + ------------- + + procedure vec_dst + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dst + (A : const_float_ptr; + B : c_int; + C : c_int); + pragma Inline_Always (vec_dst); + pragma Convention (Intrinsic, vec_dst); + + --------------- + -- vec_dstst -- + --------------- + + procedure vec_dstst + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dstst + (A : const_float_ptr; + B : c_int; + C : c_int); + pragma Inline_Always (vec_dstst); + pragma Convention (Intrinsic, vec_dstst); + + ---------------- + -- vec_dststt -- + ---------------- + + procedure vec_dststt + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dststt + (A : const_float_ptr; + B : c_int; + C : c_int); + pragma Inline_Always (vec_dststt); + pragma Convention (Intrinsic, vec_dststt); + + -------------- + -- vec_dstt -- + -------------- + + procedure vec_dstt + (A : const_vector_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_bool_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_signed_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_bool_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_pixel_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_signed_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_bool_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_vector_float_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_unsigned_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_signed_char_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_unsigned_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_short_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_unsigned_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_int_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_unsigned_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_long_ptr; + B : c_int; + C : c_int); + + procedure vec_dstt + (A : const_float_ptr; + B : c_int; + C : c_int); + pragma Inline_Always (vec_dstt); + pragma Convention (Intrinsic, vec_dstt); + + --------------- + -- vec_expte -- + --------------- + + function vec_expte + (A : vector_float) return vector_float; + + --------------- + -- vec_floor -- + --------------- + + function vec_floor + (A : vector_float) return vector_float; + + ------------ + -- vec_ld -- + ------------ + + function vec_ld + (A : c_long; + B : const_vector_float_ptr) return vector_float; + + function vec_ld + (A : c_long; + B : const_float_ptr) return vector_float; + + function vec_ld + (A : c_long; + B : const_vector_bool_int_ptr) return vector_bool_int; + + function vec_ld + (A : c_long; + B : const_vector_signed_int_ptr) return vector_signed_int; + + function vec_ld + (A : c_long; + B : const_int_ptr) return vector_signed_int; + + function vec_ld + (A : c_long; + B : const_long_ptr) return vector_signed_int; + + function vec_ld + (A : c_long; + B : const_vector_unsigned_int_ptr) return vector_unsigned_int; + + function vec_ld + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int; + + function vec_ld + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int; + + function vec_ld + (A : c_long; + B : const_vector_bool_short_ptr) return vector_bool_short; + + function vec_ld + (A : c_long; + B : const_vector_pixel_ptr) return vector_pixel; + + function vec_ld + (A : c_long; + B : const_vector_signed_short_ptr) return vector_signed_short; + + function vec_ld + (A : c_long; + B : const_short_ptr) return vector_signed_short; + + function vec_ld + (A : c_long; + B : const_vector_unsigned_short_ptr) return vector_unsigned_short; + + function vec_ld + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short; + + function vec_ld + (A : c_long; + B : const_vector_bool_char_ptr) return vector_bool_char; + + function vec_ld + (A : c_long; + B : const_vector_signed_char_ptr) return vector_signed_char; + + function vec_ld + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char; + + function vec_ld + (A : c_long; + B : const_vector_unsigned_char_ptr) return vector_unsigned_char; + + function vec_ld + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char; + + ------------- + -- vec_lde -- + ------------- + + function vec_lde + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char; + + function vec_lde + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char; + + function vec_lde + (A : c_long; + B : const_short_ptr) return vector_signed_short; + + function vec_lde + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short; + + function vec_lde + (A : c_long; + B : const_float_ptr) return vector_float; + + function vec_lde + (A : c_long; + B : const_int_ptr) return vector_signed_int; + + function vec_lde + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int; + + function vec_lde + (A : c_long; + B : const_long_ptr) return vector_signed_int; + + function vec_lde + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int; + + --------------- + -- vec_lvewx -- + --------------- + + function vec_lvewx + (A : c_long; + B : float_ptr) return vector_float; + + function vec_lvewx + (A : c_long; + B : int_ptr) return vector_signed_int; + + function vec_lvewx + (A : c_long; + B : unsigned_int_ptr) return vector_unsigned_int; + + function vec_lvewx + (A : c_long; + B : long_ptr) return vector_signed_int; + + function vec_lvewx + (A : c_long; + B : unsigned_long_ptr) return vector_unsigned_int; + + --------------- + -- vec_lvehx -- + --------------- + + function vec_lvehx + (A : c_long; + B : short_ptr) return vector_signed_short; + + function vec_lvehx + (A : c_long; + B : unsigned_short_ptr) return vector_unsigned_short; + + --------------- + -- vec_lvebx -- + --------------- + + function vec_lvebx + (A : c_long; + B : signed_char_ptr) return vector_signed_char; + + function vec_lvebx + (A : c_long; + B : unsigned_char_ptr) return vector_unsigned_char; + + ------------- + -- vec_ldl -- + ------------- + + function vec_ldl + (A : c_long; + B : const_vector_float_ptr) return vector_float; + + function vec_ldl + (A : c_long; + B : const_float_ptr) return vector_float; + + function vec_ldl + (A : c_long; + B : const_vector_bool_int_ptr) return vector_bool_int; + + function vec_ldl + (A : c_long; + B : const_vector_signed_int_ptr) return vector_signed_int; + + function vec_ldl + (A : c_long; + B : const_int_ptr) return vector_signed_int; + + function vec_ldl + (A : c_long; + B : const_long_ptr) return vector_signed_int; + + function vec_ldl + (A : c_long; + B : const_vector_unsigned_int_ptr) return vector_unsigned_int; + + function vec_ldl + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int; + + function vec_ldl + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int; + + function vec_ldl + (A : c_long; + B : const_vector_bool_short_ptr) return vector_bool_short; + + function vec_ldl + (A : c_long; + B : const_vector_pixel_ptr) return vector_pixel; + + function vec_ldl + (A : c_long; + B : const_vector_signed_short_ptr) return vector_signed_short; + + function vec_ldl + (A : c_long; + B : const_short_ptr) return vector_signed_short; + + function vec_ldl + (A : c_long; + B : const_vector_unsigned_short_ptr) return vector_unsigned_short; + + function vec_ldl + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short; + + function vec_ldl + (A : c_long; + B : const_vector_bool_char_ptr) return vector_bool_char; + + function vec_ldl + (A : c_long; + B : const_vector_signed_char_ptr) return vector_signed_char; + + function vec_ldl + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char; + + function vec_ldl + (A : c_long; + B : const_vector_unsigned_char_ptr) return vector_unsigned_char; + + function vec_ldl + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char; + + -------------- + -- vec_loge -- + -------------- + + function vec_loge + (A : vector_float) return vector_float; + + -------------- + -- vec_lvsl -- + -------------- + + function vec_lvsl + (A : c_long; + B : constv_unsigned_char_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_signed_char_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_unsigned_short_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_short_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_unsigned_int_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_int_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_unsigned_long_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_long_ptr) return vector_unsigned_char; + + function vec_lvsl + (A : c_long; + B : constv_float_ptr) return vector_unsigned_char; + + -------------- + -- vec_lvsr -- + -------------- + + function vec_lvsr + (A : c_long; + B : constv_unsigned_char_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_signed_char_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_unsigned_short_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_short_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_unsigned_int_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_int_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_unsigned_long_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_long_ptr) return vector_unsigned_char; + + function vec_lvsr + (A : c_long; + B : constv_float_ptr) return vector_unsigned_char; + + -------------- + -- vec_madd -- + -------------- + + function vec_madd + (A : vector_float; + B : vector_float; + C : vector_float) return vector_float; + + --------------- + -- vec_madds -- + --------------- + + function vec_madds + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short; + + ------------- + -- vec_max -- + ------------- + + function vec_max + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_max + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_max + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_max + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_max + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_max + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_max + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_max + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_max + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_max + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_max + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_max + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_max + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_max + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_max + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_max + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_max + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_max + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_max + (A : vector_float; + B : vector_float) return vector_float; + + ---------------- + -- vec_vmaxfp -- + ---------------- + + function vec_vmaxfp + (A : vector_float; + B : vector_float) return vector_float; + + ---------------- + -- vec_vmaxsw -- + ---------------- + + function vec_vmaxsw + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vmaxsw + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_vmaxsw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ---------------- + -- vec_vmaxuw -- + ---------------- + + function vec_vmaxuw + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vmaxuw + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_vmaxuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ---------------- + -- vec_vmaxsh -- + ---------------- + + function vec_vmaxsh + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vmaxsh + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_vmaxsh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + ---------------- + -- vec_vmaxuh -- + ---------------- + + function vec_vmaxuh + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vmaxuh + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_vmaxuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + ---------------- + -- vec_vmaxsb -- + ---------------- + + function vec_vmaxsb + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vmaxsb + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_vmaxsb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + ---------------- + -- vec_vmaxub -- + ---------------- + + function vec_vmaxub + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_vmaxub + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_vmaxub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ---------------- + -- vec_mergeh -- + ---------------- + + function vec_mergeh + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_mergeh + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_mergeh + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_mergeh + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_mergeh + (A : vector_pixel; + B : vector_pixel) return vector_pixel; + + function vec_mergeh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_mergeh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_mergeh + (A : vector_float; + B : vector_float) return vector_float; + + function vec_mergeh + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_mergeh + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_mergeh + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ---------------- + -- vec_vmrghw -- + ---------------- + + function vec_vmrghw + (A : vector_float; + B : vector_float) return vector_float; + + function vec_vmrghw + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_vmrghw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vmrghw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ---------------- + -- vec_vmrghh -- + ---------------- + + function vec_vmrghh + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_vmrghh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vmrghh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vmrghh + (A : vector_pixel; + B : vector_pixel) return vector_pixel; + + ---------------- + -- vec_vmrghb -- + ---------------- + + function vec_vmrghb + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_vmrghb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vmrghb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ---------------- + -- vec_mergel -- + ---------------- + + function vec_mergel + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_mergel + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_mergel + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_mergel + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_mergel + (A : vector_pixel; + B : vector_pixel) return vector_pixel; + + function vec_mergel + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_mergel + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_mergel + (A : vector_float; + B : vector_float) return vector_float; + + function vec_mergel + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_mergel + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_mergel + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ---------------- + -- vec_vmrglw -- + ---------------- + + function vec_vmrglw + (A : vector_float; + B : vector_float) return vector_float; + + function vec_vmrglw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vmrglw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vmrglw + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + ---------------- + -- vec_vmrglh -- + ---------------- + + function vec_vmrglh + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_vmrglh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vmrglh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vmrglh + (A : vector_pixel; + B : vector_pixel) return vector_pixel; + + ---------------- + -- vec_vmrglb -- + ---------------- + + function vec_vmrglb + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_vmrglb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vmrglb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ---------------- + -- vec_mfvscr -- + ---------------- + + function vec_mfvscr return vector_unsigned_short; + + ------------- + -- vec_min -- + ------------- + + function vec_min + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_min + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_min + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_min + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_min + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_min + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_min + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_min + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_min + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_min + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_min + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_min + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_min + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_min + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_min + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_min + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_min + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_min + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_min + (A : vector_float; + B : vector_float) return vector_float; + + ---------------- + -- vec_vminfp -- + ---------------- + + function vec_vminfp + (A : vector_float; + B : vector_float) return vector_float; + + ---------------- + -- vec_vminsw -- + ---------------- + + function vec_vminsw + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vminsw + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_vminsw + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ---------------- + -- vec_vminuw -- + ---------------- + + function vec_vminuw + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vminuw + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_vminuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ---------------- + -- vec_vminsh -- + ---------------- + + function vec_vminsh + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vminsh + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_vminsh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + ---------------- + -- vec_vminuh -- + ---------------- + + function vec_vminuh + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vminuh + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_vminuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + ---------------- + -- vec_vminsb -- + ---------------- + + function vec_vminsb + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vminsb + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_vminsb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + ---------------- + -- vec_vminub -- + ---------------- + + function vec_vminub + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_vminub + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_vminub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + --------------- + -- vec_mladd -- + --------------- + + function vec_mladd + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short; + + function vec_mladd + (A : vector_signed_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_signed_short; + + function vec_mladd + (A : vector_unsigned_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short; + + function vec_mladd + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_unsigned_short; + + ---------------- + -- vec_mradds -- + ---------------- + + function vec_mradds + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short; + + -------------- + -- vec_msum -- + -------------- + + function vec_msum + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_int) return vector_unsigned_int; + + function vec_msum + (A : vector_signed_char; + B : vector_unsigned_char; + C : vector_signed_int) return vector_signed_int; + + function vec_msum + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int; + + function vec_msum + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int; + + ------------------ + -- vec_vmsumshm -- + ------------------ + + function vec_vmsumshm + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int; + + ------------------ + -- vec_vmsumuhm -- + ------------------ + + function vec_vmsumuhm + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int; + + ------------------ + -- vec_vmsummbm -- + ------------------ + + function vec_vmsummbm + (A : vector_signed_char; + B : vector_unsigned_char; + C : vector_signed_int) return vector_signed_int; + + ------------------ + -- vec_vmsumubm -- + ------------------ + + function vec_vmsumubm + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_int) return vector_unsigned_int; + + --------------- + -- vec_msums -- + --------------- + + function vec_msums + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int; + + function vec_msums + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int; + + function vec_vmsumshs + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_int) return vector_signed_int; + + ------------------ + -- vec_vmsumuhs -- + ------------------ + + function vec_vmsumuhs + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_int) return vector_unsigned_int; + + ---------------- + -- vec_mtvscr -- + ---------------- + + procedure vec_mtvscr + (A : vector_signed_int); + + procedure vec_mtvscr + (A : vector_unsigned_int); + + procedure vec_mtvscr + (A : vector_bool_int); + + procedure vec_mtvscr + (A : vector_signed_short); + + procedure vec_mtvscr + (A : vector_unsigned_short); + + procedure vec_mtvscr + (A : vector_bool_short); + + procedure vec_mtvscr + (A : vector_pixel); + + procedure vec_mtvscr + (A : vector_signed_char); + + procedure vec_mtvscr + (A : vector_unsigned_char); + + procedure vec_mtvscr + (A : vector_bool_char); + + -------------- + -- vec_mule -- + -------------- + + function vec_mule + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short; + + function vec_mule + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short; + + function vec_mule + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int; + + function vec_mule + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int; + + ----------------- + -- vec_vmulesh -- + ----------------- + + function vec_vmulesh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int; + + ----------------- + -- vec_vmuleuh -- + ----------------- + + function vec_vmuleuh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int; + + ----------------- + -- vec_vmulesb -- + ----------------- + + function vec_vmulesb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short; + + ----------------- + -- vec_vmuleub -- + ----------------- + + function vec_vmuleub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short; + + -------------- + -- vec_mulo -- + -------------- + + function vec_mulo + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short; + + function vec_mulo + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short; + + function vec_mulo + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int; + + function vec_mulo + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int; + + ----------------- + -- vec_vmulosh -- + ----------------- + + function vec_vmulosh + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_int; + + ----------------- + -- vec_vmulouh -- + ----------------- + + function vec_vmulouh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_int; + + ----------------- + -- vec_vmulosb -- + ----------------- + + function vec_vmulosb + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_short; + + ----------------- + -- vec_vmuloub -- + ----------------- + + function vec_vmuloub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_short; + + --------------- + -- vec_nmsub -- + --------------- + + function vec_nmsub + (A : vector_float; + B : vector_float; + C : vector_float) return vector_float; + + ------------- + -- vec_nor -- + ------------- + + function vec_nor + (A : vector_float; + B : vector_float) return vector_float; + + function vec_nor + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_nor + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_nor + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_nor + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_nor + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_nor + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_nor + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_nor + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_nor + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + ------------ + -- vec_or -- + ------------ + + function vec_or + (A : vector_float; + B : vector_float) return vector_float; + + function vec_or + (A : vector_float; + B : vector_bool_int) return vector_float; + + function vec_or + (A : vector_bool_int; + B : vector_float) return vector_float; + + function vec_or + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_or + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_or + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_or + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_or + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_or + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_or + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_or + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_or + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_or + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_or + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_or + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_or + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_or + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_or + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_or + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_or + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_or + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_or + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_or + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_or + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + -------------- + -- vec_pack -- + -------------- + + function vec_pack + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char; + + function vec_pack + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char; + + function vec_pack + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_char; + + function vec_pack + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short; + + function vec_pack + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short; + + function vec_pack + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_short; + + ----------------- + -- vec_vpkuwum -- + ----------------- + + function vec_vpkuwum + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_short; + + function vec_vpkuwum + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short; + + function vec_vpkuwum + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short; + + ----------------- + -- vec_vpkuhum -- + ----------------- + + function vec_vpkuhum + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_char; + + function vec_vpkuhum + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char; + + function vec_vpkuhum + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char; + + ---------------- + -- vec_packpx -- + ---------------- + + function vec_packpx + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_pixel; + + --------------- + -- vec_packs -- + --------------- + + function vec_packs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char; + + function vec_packs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char; + + function vec_packs + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short; + + function vec_packs + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short; + + ----------------- + -- vec_vpkswss -- + ----------------- + + function vec_vpkswss + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_short; + + ----------------- + -- vec_vpkuwus -- + ----------------- + + function vec_vpkuwus + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short; + + ----------------- + -- vec_vpkshss -- + ----------------- + + function vec_vpkshss + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_char; + + ----------------- + -- vec_vpkuhus -- + ----------------- + + function vec_vpkuhus + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char; + + ---------------- + -- vec_packsu -- + ---------------- + + function vec_packsu + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_char; + + function vec_packsu + (A : vector_signed_short; + B : vector_signed_short) return vector_unsigned_char; + + function vec_packsu + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_short; + + function vec_packsu + (A : vector_signed_int; + B : vector_signed_int) return vector_unsigned_short; + + ----------------- + -- vec_vpkswus -- + ----------------- + + function vec_vpkswus + (A : vector_signed_int; + B : vector_signed_int) return vector_unsigned_short; + + ----------------- + -- vec_vpkshus -- + ----------------- + + function vec_vpkshus + (A : vector_signed_short; + B : vector_signed_short) return vector_unsigned_char; + + -------------- + -- vec_perm -- + -------------- + + function vec_perm + (A : vector_float; + B : vector_float; + C : vector_unsigned_char) return vector_float; + + function vec_perm + (A : vector_signed_int; + B : vector_signed_int; + C : vector_unsigned_char) return vector_signed_int; + + function vec_perm + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_unsigned_char) return vector_unsigned_int; + + function vec_perm + (A : vector_bool_int; + B : vector_bool_int; + C : vector_unsigned_char) return vector_bool_int; + + function vec_perm + (A : vector_signed_short; + B : vector_signed_short; + C : vector_unsigned_char) return vector_signed_short; + + function vec_perm + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_char) return vector_unsigned_short; + + function vec_perm + (A : vector_bool_short; + B : vector_bool_short; + C : vector_unsigned_char) return vector_bool_short; + + function vec_perm + (A : vector_pixel; + B : vector_pixel; + C : vector_unsigned_char) return vector_pixel; + + function vec_perm + (A : vector_signed_char; + B : vector_signed_char; + C : vector_unsigned_char) return vector_signed_char; + + function vec_perm + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_char) return vector_unsigned_char; + + function vec_perm + (A : vector_bool_char; + B : vector_bool_char; + C : vector_unsigned_char) return vector_bool_char; + + ------------ + -- vec_re -- + ------------ + + function vec_re + (A : vector_float) return vector_float; + + ------------ + -- vec_rl -- + ------------ + + function vec_rl + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_rl + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_rl + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_rl + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_rl + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_rl + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_vrlw -- + -------------- + + function vec_vrlw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_vrlw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_vrlh -- + -------------- + + function vec_vrlh + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_vrlh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + -------------- + -- vec_vrlb -- + -------------- + + function vec_vrlb + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_vrlb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + --------------- + -- vec_round -- + --------------- + + function vec_round + (A : vector_float) return vector_float; + + ---------------- + -- vec_rsqrte -- + ---------------- + + function vec_rsqrte + (A : vector_float) return vector_float; + + ------------- + -- vec_sel -- + ------------- + + function vec_sel + (A : vector_float; + B : vector_float; + C : vector_bool_int) return vector_float; + + function vec_sel + (A : vector_float; + B : vector_float; + C : vector_unsigned_int) return vector_float; + + function vec_sel + (A : vector_signed_int; + B : vector_signed_int; + C : vector_bool_int) return vector_signed_int; + + function vec_sel + (A : vector_signed_int; + B : vector_signed_int; + C : vector_unsigned_int) return vector_signed_int; + + function vec_sel + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_bool_int) return vector_unsigned_int; + + function vec_sel + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_unsigned_int) return vector_unsigned_int; + + function vec_sel + (A : vector_bool_int; + B : vector_bool_int; + C : vector_bool_int) return vector_bool_int; + + function vec_sel + (A : vector_bool_int; + B : vector_bool_int; + C : vector_unsigned_int) return vector_bool_int; + + function vec_sel + (A : vector_signed_short; + B : vector_signed_short; + C : vector_bool_short) return vector_signed_short; + + function vec_sel + (A : vector_signed_short; + B : vector_signed_short; + C : vector_unsigned_short) return vector_signed_short; + + function vec_sel + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_bool_short) return vector_unsigned_short; + + function vec_sel + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_unsigned_short; + + function vec_sel + (A : vector_bool_short; + B : vector_bool_short; + C : vector_bool_short) return vector_bool_short; + + function vec_sel + (A : vector_bool_short; + B : vector_bool_short; + C : vector_unsigned_short) return vector_bool_short; + + function vec_sel + (A : vector_signed_char; + B : vector_signed_char; + C : vector_bool_char) return vector_signed_char; + + function vec_sel + (A : vector_signed_char; + B : vector_signed_char; + C : vector_unsigned_char) return vector_signed_char; + + function vec_sel + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_bool_char) return vector_unsigned_char; + + function vec_sel + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_char) return vector_unsigned_char; + + function vec_sel + (A : vector_bool_char; + B : vector_bool_char; + C : vector_bool_char) return vector_bool_char; + + function vec_sel + (A : vector_bool_char; + B : vector_bool_char; + C : vector_unsigned_char) return vector_bool_char; + + ------------ + -- vec_sl -- + ------------ + + function vec_sl + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_sl + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_sl + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_sl + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_sl + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_sl + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_vslw -- + -------------- + + function vec_vslw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_vslw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_vslh -- + -------------- + + function vec_vslh + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_vslh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + -------------- + -- vec_vslb -- + -------------- + + function vec_vslb + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_vslb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ------------- + -- vec_sld -- + ------------- + + function vec_sld + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : c_int) return vector_unsigned_int; + + function vec_sld + (A : vector_bool_int; + B : vector_bool_int; + C : c_int) return vector_bool_int; + + function vec_sld + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : c_int) return vector_unsigned_short; + + function vec_sld + (A : vector_bool_short; + B : vector_bool_short; + C : c_int) return vector_bool_short; + + function vec_sld + (A : vector_pixel; + B : vector_pixel; + C : c_int) return vector_pixel; + + function vec_sld + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : c_int) return vector_unsigned_char; + + function vec_sld + (A : vector_bool_char; + B : vector_bool_char; + C : c_int) return vector_bool_char; + pragma Inline_Always (vec_sld); + pragma Convention (Intrinsic, vec_sld); + + function vec_sld + (A : vector_float; + B : vector_float; + C : c_int) return vector_float + renames Low_Level_Vectors.vsldoi_4sf; + + function vec_sld + (A : vector_signed_int; + B : vector_signed_int; + C : c_int) return vector_signed_int + renames Low_Level_Vectors.vsldoi_4si; + + function vec_sld + (A : vector_signed_short; + B : vector_signed_short; + C : c_int) return vector_signed_short + renames Low_Level_Vectors.vsldoi_8hi; + + function vec_sld + (A : vector_signed_char; + B : vector_signed_char; + C : c_int) return vector_signed_char + renames Low_Level_Vectors.vsldoi_16qi; + + ------------- + -- vec_sll -- + ------------- + + function vec_sll + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_sll + (A : vector_signed_int; + B : vector_unsigned_short) return vector_signed_int; + + function vec_sll + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int; + + function vec_sll + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_sll + (A : vector_unsigned_int; + B : vector_unsigned_short) return vector_unsigned_int; + + function vec_sll + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int; + + function vec_sll + (A : vector_bool_int; + B : vector_unsigned_int) return vector_bool_int; + + function vec_sll + (A : vector_bool_int; + B : vector_unsigned_short) return vector_bool_int; + + function vec_sll + (A : vector_bool_int; + B : vector_unsigned_char) return vector_bool_int; + + function vec_sll + (A : vector_signed_short; + B : vector_unsigned_int) return vector_signed_short; + + function vec_sll + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_sll + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short; + + function vec_sll + (A : vector_unsigned_short; + B : vector_unsigned_int) return vector_unsigned_short; + + function vec_sll + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_sll + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short; + + function vec_sll + (A : vector_bool_short; + B : vector_unsigned_int) return vector_bool_short; + + function vec_sll + (A : vector_bool_short; + B : vector_unsigned_short) return vector_bool_short; + + function vec_sll + (A : vector_bool_short; + B : vector_unsigned_char) return vector_bool_short; + + function vec_sll + (A : vector_pixel; + B : vector_unsigned_int) return vector_pixel; + + function vec_sll + (A : vector_pixel; + B : vector_unsigned_short) return vector_pixel; + + function vec_sll + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel; + + function vec_sll + (A : vector_signed_char; + B : vector_unsigned_int) return vector_signed_char; + + function vec_sll + (A : vector_signed_char; + B : vector_unsigned_short) return vector_signed_char; + + function vec_sll + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_sll + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_char; + + function vec_sll + (A : vector_unsigned_char; + B : vector_unsigned_short) return vector_unsigned_char; + + function vec_sll + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_sll + (A : vector_bool_char; + B : vector_unsigned_int) return vector_bool_char; + + function vec_sll + (A : vector_bool_char; + B : vector_unsigned_short) return vector_bool_char; + + function vec_sll + (A : vector_bool_char; + B : vector_unsigned_char) return vector_bool_char; + + ------------- + -- vec_slo -- + ------------- + + function vec_slo + (A : vector_float; + B : vector_signed_char) return vector_float; + + function vec_slo + (A : vector_float; + B : vector_unsigned_char) return vector_float; + + function vec_slo + (A : vector_signed_int; + B : vector_signed_char) return vector_signed_int; + + function vec_slo + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int; + + function vec_slo + (A : vector_unsigned_int; + B : vector_signed_char) return vector_unsigned_int; + + function vec_slo + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int; + + function vec_slo + (A : vector_signed_short; + B : vector_signed_char) return vector_signed_short; + + function vec_slo + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short; + + function vec_slo + (A : vector_unsigned_short; + B : vector_signed_char) return vector_unsigned_short; + + function vec_slo + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short; + + function vec_slo + (A : vector_pixel; + B : vector_signed_char) return vector_pixel; + + function vec_slo + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel; + + function vec_slo + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_slo + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_slo + (A : vector_unsigned_char; + B : vector_signed_char) return vector_unsigned_char; + + function vec_slo + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ---------------- + -- vec_vspltw -- + ---------------- + + function vec_vspltw + (A : vector_float; + B : c_int) return vector_float; + + function vec_vspltw + (A : vector_unsigned_int; + B : c_int) return vector_unsigned_int; + + function vec_vspltw + (A : vector_bool_int; + B : c_int) return vector_bool_int; + pragma Inline_Always (vec_vspltw); + pragma Convention (Intrinsic, vec_vspltw); + + function vec_vspltw + (A : vector_signed_int; + B : c_int) return vector_signed_int + renames Low_Level_Vectors.vspltw; + + ---------------- + -- vec_vsplth -- + ---------------- + + function vec_vsplth + (A : vector_bool_short; + B : c_int) return vector_bool_short; + + function vec_vsplth + (A : vector_unsigned_short; + B : c_int) return vector_unsigned_short; + + function vec_vsplth + (A : vector_pixel; + B : c_int) return vector_pixel; + pragma Inline_Always (vec_vsplth); + pragma Convention (Intrinsic, vec_vsplth); + + function vec_vsplth + (A : vector_signed_short; + B : c_int) return vector_signed_short + renames Low_Level_Vectors.vsplth; + + ---------------- + -- vec_vspltb -- + ---------------- + + function vec_vspltb + (A : vector_unsigned_char; + B : c_int) return vector_unsigned_char; + + function vec_vspltb + (A : vector_bool_char; + B : c_int) return vector_bool_char; + pragma Inline_Always (vec_vspltb); + pragma Convention (Intrinsic, vec_vspltb); + + function vec_vspltb + (A : vector_signed_char; + B : c_int) return vector_signed_char + renames Low_Level_Vectors.vspltb; + + ------------------ + -- vec_vspltisb -- + ------------------ + + function vec_vspltisb + (A : c_int) return vector_signed_char + renames Low_Level_Vectors.vspltisb; + + ------------------ + -- vec_vspltish -- + ------------------ + + function vec_vspltish + (A : c_int) return vector_signed_short + renames Low_Level_Vectors.vspltish; + + ------------------ + -- vec_vspltisw -- + ------------------ + + function vec_vspltisw + (A : c_int) return vector_signed_int + renames Low_Level_Vectors.vspltisw; + + ------------ + -- vec_sr -- + ------------ + + function vec_sr + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_sr + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_sr + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_sr + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_sr + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_sr + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_vsrw -- + -------------- + + function vec_vsrw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_vsrw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_vsrh -- + -------------- + + function vec_vsrh + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_vsrh + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + -------------- + -- vec_vsrb -- + -------------- + + function vec_vsrb + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_vsrb + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ------------- + -- vec_sra -- + ------------- + + function vec_sra + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_sra + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_sra + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_sra + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_sra + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_sra + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + --------------- + -- vec_vsraw -- + --------------- + + function vec_vsraw + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_vsraw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vsrah + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_vsrah + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vsrab + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_vsrab + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + ------------- + -- vec_srl -- + ------------- + + function vec_srl + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int; + + function vec_srl + (A : vector_signed_int; + B : vector_unsigned_short) return vector_signed_int; + + function vec_srl + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int; + + function vec_srl + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_srl + (A : vector_unsigned_int; + B : vector_unsigned_short) return vector_unsigned_int; + + function vec_srl + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int; + + function vec_srl + (A : vector_bool_int; + B : vector_unsigned_int) return vector_bool_int; + + function vec_srl + (A : vector_bool_int; + B : vector_unsigned_short) return vector_bool_int; + + function vec_srl + (A : vector_bool_int; + B : vector_unsigned_char) return vector_bool_int; + + function vec_srl + (A : vector_signed_short; + B : vector_unsigned_int) return vector_signed_short; + + function vec_srl + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short; + + function vec_srl + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short; + + function vec_srl + (A : vector_unsigned_short; + B : vector_unsigned_int) return vector_unsigned_short; + + function vec_srl + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_srl + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short; + + function vec_srl + (A : vector_bool_short; + B : vector_unsigned_int) return vector_bool_short; + + function vec_srl + (A : vector_bool_short; + B : vector_unsigned_short) return vector_bool_short; + + function vec_srl + (A : vector_bool_short; + B : vector_unsigned_char) return vector_bool_short; + + function vec_srl + (A : vector_pixel; + B : vector_unsigned_int) return vector_pixel; + + function vec_srl + (A : vector_pixel; + B : vector_unsigned_short) return vector_pixel; + + function vec_srl + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel; + + function vec_srl + (A : vector_signed_char; + B : vector_unsigned_int) return vector_signed_char; + + function vec_srl + (A : vector_signed_char; + B : vector_unsigned_short) return vector_signed_char; + + function vec_srl + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_srl + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_char; + + function vec_srl + (A : vector_unsigned_char; + B : vector_unsigned_short) return vector_unsigned_char; + + function vec_srl + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_srl + (A : vector_bool_char; + B : vector_unsigned_int) return vector_bool_char; + + function vec_srl + (A : vector_bool_char; + B : vector_unsigned_short) return vector_bool_char; + + function vec_srl + (A : vector_bool_char; + B : vector_unsigned_char) return vector_bool_char; + + function vec_sro + (A : vector_float; + B : vector_signed_char) return vector_float; + + function vec_sro + (A : vector_float; + B : vector_unsigned_char) return vector_float; + + function vec_sro + (A : vector_signed_int; + B : vector_signed_char) return vector_signed_int; + + function vec_sro + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int; + + function vec_sro + (A : vector_unsigned_int; + B : vector_signed_char) return vector_unsigned_int; + + function vec_sro + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int; + + function vec_sro + (A : vector_signed_short; + B : vector_signed_char) return vector_signed_short; + + function vec_sro + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short; + + function vec_sro + (A : vector_unsigned_short; + B : vector_signed_char) return vector_unsigned_short; + + function vec_sro + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short; + + function vec_sro + (A : vector_pixel; + B : vector_signed_char) return vector_pixel; + + function vec_sro + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel; + + function vec_sro + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_sro + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char; + + function vec_sro + (A : vector_unsigned_char; + B : vector_signed_char) return vector_unsigned_char; + + function vec_sro + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + procedure vec_st + (A : vector_float; + B : c_int; + C : vector_float_ptr); + + procedure vec_st + (A : vector_float; + B : c_int; + C : float_ptr); + + procedure vec_st + (A : vector_signed_int; + B : c_int; + C : vector_signed_int_ptr); + + procedure vec_st + (A : vector_signed_int; + B : c_int; + C : int_ptr); + + procedure vec_st + (A : vector_unsigned_int; + B : c_int; + C : vector_unsigned_int_ptr); + + procedure vec_st + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr); + + procedure vec_st + (A : vector_bool_int; + B : c_int; + C : vector_bool_int_ptr); + + procedure vec_st + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr); + + procedure vec_st + (A : vector_bool_int; + B : c_int; + C : int_ptr); + + procedure vec_st + (A : vector_signed_short; + B : c_int; + C : vector_signed_short_ptr); + + procedure vec_st + (A : vector_signed_short; + B : c_int; + C : short_ptr); + + procedure vec_st + (A : vector_unsigned_short; + B : c_int; + C : vector_unsigned_short_ptr); + + procedure vec_st + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_st + (A : vector_bool_short; + B : c_int; + C : vector_bool_short_ptr); + + procedure vec_st + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_st + (A : vector_pixel; + B : c_int; + C : vector_pixel_ptr); + + procedure vec_st + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_st + (A : vector_pixel; + B : c_int; + C : short_ptr); + + procedure vec_st + (A : vector_bool_short; + B : c_int; + C : short_ptr); + + procedure vec_st + (A : vector_signed_char; + B : c_int; + C : vector_signed_char_ptr); + + procedure vec_st + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr); + + procedure vec_st + (A : vector_unsigned_char; + B : c_int; + C : vector_unsigned_char_ptr); + + procedure vec_st + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_st + (A : vector_bool_char; + B : c_int; + C : vector_bool_char_ptr); + + procedure vec_st + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_st + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr); + + ------------- + -- vec_ste -- + ------------- + + procedure vec_ste + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr); + + procedure vec_ste + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_ste + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr); + + procedure vec_ste + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_ste + (A : vector_signed_short; + B : c_int; + C : short_ptr); + + procedure vec_ste + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_ste + (A : vector_bool_short; + B : c_int; + C : short_ptr); + + procedure vec_ste + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_ste + (A : vector_pixel; + B : c_int; + C : short_ptr); + + procedure vec_ste + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_ste + (A : vector_float; + B : c_int; + C : float_ptr); + + procedure vec_ste + (A : vector_signed_int; + B : c_int; + C : int_ptr); + + procedure vec_ste + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr); + + procedure vec_ste + (A : vector_bool_int; + B : c_int; + C : int_ptr); + + procedure vec_ste + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr); + + ---------------- + -- vec_stvewx -- + ---------------- + + procedure vec_stvewx + (A : vector_float; + B : c_int; + C : float_ptr); + + procedure vec_stvewx + (A : vector_signed_int; + B : c_int; + C : int_ptr); + + procedure vec_stvewx + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr); + + procedure vec_stvewx + (A : vector_bool_int; + B : c_int; + C : int_ptr); + + procedure vec_stvewx + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr); + + procedure vec_stvehx + (A : vector_signed_short; + B : c_int; + C : short_ptr); + + procedure vec_stvehx + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_stvehx + (A : vector_bool_short; + B : c_int; + C : short_ptr); + + procedure vec_stvehx + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_stvehx + (A : vector_pixel; + B : c_int; + C : short_ptr); + + procedure vec_stvehx + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_stvebx + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr); + + procedure vec_stvebx + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_stvebx + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr); + + procedure vec_stvebx + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_stl + (A : vector_float; + B : c_int; + C : vector_float_ptr); + + procedure vec_stl + (A : vector_float; + B : c_int; + C : float_ptr); + + procedure vec_stl + (A : vector_signed_int; + B : c_int; + C : vector_signed_int_ptr); + + procedure vec_stl + (A : vector_signed_int; + B : c_int; + C : int_ptr); + + procedure vec_stl + (A : vector_unsigned_int; + B : c_int; + C : vector_unsigned_int_ptr); + + procedure vec_stl + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr); + + procedure vec_stl + (A : vector_bool_int; + B : c_int; + C : vector_bool_int_ptr); + + procedure vec_stl + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr); + + procedure vec_stl + (A : vector_bool_int; + B : c_int; + C : int_ptr); + + procedure vec_stl + (A : vector_signed_short; + B : c_int; + C : vector_signed_short_ptr); + + procedure vec_stl + (A : vector_signed_short; + B : c_int; + C : short_ptr); + + procedure vec_stl + (A : vector_unsigned_short; + B : c_int; + C : vector_unsigned_short_ptr); + + procedure vec_stl + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_stl + (A : vector_bool_short; + B : c_int; + C : vector_bool_short_ptr); + + procedure vec_stl + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_stl + (A : vector_bool_short; + B : c_int; + C : short_ptr); + + procedure vec_stl + (A : vector_pixel; + B : c_int; + C : vector_pixel_ptr); + + procedure vec_stl + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr); + + procedure vec_stl + (A : vector_pixel; + B : c_int; + C : short_ptr); + + procedure vec_stl + (A : vector_signed_char; + B : c_int; + C : vector_signed_char_ptr); + + procedure vec_stl + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr); + + procedure vec_stl + (A : vector_unsigned_char; + B : c_int; + C : vector_unsigned_char_ptr); + + procedure vec_stl + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_stl + (A : vector_bool_char; + B : c_int; + C : vector_bool_char_ptr); + + procedure vec_stl + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr); + + procedure vec_stl + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr); + + ------------- + -- vec_sub -- + ------------- + + function vec_sub + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_sub + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_sub + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_sub + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_sub + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_sub + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_sub + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_sub + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_sub + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_sub + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_sub + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_sub + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_sub + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_sub + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_sub + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_sub + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_sub + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_sub + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_sub + (A : vector_float; + B : vector_float) return vector_float; + + ---------------- + -- vec_vsubfp -- + ---------------- + + function vec_vsubfp + (A : vector_float; + B : vector_float) return vector_float; + + ----------------- + -- vec_vsubuwm -- + ----------------- + + function vec_vsubuwm + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vsubuwm + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_vsubuwm + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vsubuwm + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vsubuwm + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_vsubuwm + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ----------------- + -- vec_vsubuhm -- + ----------------- + + function vec_vsubuhm + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vsubuhm + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_vsubuhm + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vsubuhm + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vsubuhm + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_vsubuhm + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + ----------------- + -- vec_vsububm -- + ----------------- + + function vec_vsububm + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vsububm + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_vsububm + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vsububm + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_vsububm + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_vsububm + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + -------------- + -- vec_subc -- + -------------- + + function vec_subc + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + -------------- + -- vec_subs -- + -------------- + + function vec_subs + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_subs + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_subs + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_subs + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_subs + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_subs + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_subs + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_subs + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_subs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_subs + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_subs + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_subs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_subs + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_subs + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_subs + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_subs + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_subs + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_subs + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ----------------- + -- vec_vsubsws -- + ----------------- + + function vec_vsubsws + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_vsubsws + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_vsubsws + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + ----------------- + -- vec_vsubuws -- + ----------------- + + function vec_vsubuws + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_vsubuws + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_vsubuws + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + ----------------- + -- vec_vsubshs -- + ----------------- + + function vec_vsubshs + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_vsubshs + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_vsubshs + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + ----------------- + -- vec_vsubuhs -- + ----------------- + + function vec_vsubuhs + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_vsubuhs + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_vsubuhs + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + ----------------- + -- vec_vsubsbs -- + ----------------- + + function vec_vsubsbs + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_vsubsbs + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_vsubsbs + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + ----------------- + -- vec_vsububs -- + ----------------- + + function vec_vsububs + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_vsububs + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_vsububs + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + --------------- + -- vec_sum4s -- + --------------- + + function vec_sum4s + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_sum4s + (A : vector_signed_char; + B : vector_signed_int) return vector_signed_int; + + function vec_sum4s + (A : vector_signed_short; + B : vector_signed_int) return vector_signed_int; + + ------------------ + -- vec_vsum4shs -- + ------------------ + + function vec_vsum4shs + (A : vector_signed_short; + B : vector_signed_int) return vector_signed_int; + + ------------------ + -- vec_vsum4sbs -- + ------------------ + + function vec_vsum4sbs + (A : vector_signed_char; + B : vector_signed_int) return vector_signed_int; + + ------------------ + -- vec_vsum4ubs -- + ------------------ + + function vec_vsum4ubs + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_int; + + --------------- + -- vec_sum2s -- + --------------- + + function vec_sum2s + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + -------------- + -- vec_sums -- + -------------- + + function vec_sums + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_trunc + (A : vector_float) return vector_float; + + function vec_unpackh + (A : vector_signed_char) return vector_signed_short; + + function vec_unpackh + (A : vector_bool_char) return vector_bool_short; + + function vec_unpackh + (A : vector_signed_short) return vector_signed_int; + + function vec_unpackh + (A : vector_bool_short) return vector_bool_int; + + function vec_unpackh + (A : vector_pixel) return vector_unsigned_int; + + function vec_vupkhsh + (A : vector_bool_short) return vector_bool_int; + + function vec_vupkhsh + (A : vector_signed_short) return vector_signed_int; + + function vec_vupkhpx + (A : vector_pixel) return vector_unsigned_int; + + function vec_vupkhsb + (A : vector_bool_char) return vector_bool_short; + + function vec_vupkhsb + (A : vector_signed_char) return vector_signed_short; + + function vec_unpackl + (A : vector_signed_char) return vector_signed_short; + + function vec_unpackl + (A : vector_bool_char) return vector_bool_short; + + function vec_unpackl + (A : vector_pixel) return vector_unsigned_int; + + function vec_unpackl + (A : vector_signed_short) return vector_signed_int; + + function vec_unpackl + (A : vector_bool_short) return vector_bool_int; + + function vec_vupklpx + (A : vector_pixel) return vector_unsigned_int; + + ----------------- + -- vec_vupklsh -- + ----------------- + + function vec_vupklsh + (A : vector_bool_short) return vector_bool_int; + + function vec_vupklsh + (A : vector_signed_short) return vector_signed_int; + + ----------------- + -- vec_vupklsb -- + ----------------- + + function vec_vupklsb + (A : vector_bool_char) return vector_bool_short; + + function vec_vupklsb + (A : vector_signed_char) return vector_signed_short; + + ------------- + -- vec_xor -- + ------------- + + function vec_xor + (A : vector_float; + B : vector_float) return vector_float; + + function vec_xor + (A : vector_float; + B : vector_bool_int) return vector_float; + + function vec_xor + (A : vector_bool_int; + B : vector_float) return vector_float; + + function vec_xor + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int; + + function vec_xor + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int; + + function vec_xor + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int; + + function vec_xor + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int; + + function vec_xor + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_xor + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int; + + function vec_xor + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int; + + function vec_xor + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short; + + function vec_xor + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short; + + function vec_xor + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short; + + function vec_xor + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short; + + function vec_xor + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_xor + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short; + + function vec_xor + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short; + + function vec_xor + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char; + + function vec_xor + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char; + + function vec_xor + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char; + + function vec_xor + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char; + + function vec_xor + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char; + + function vec_xor + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char; + + function vec_xor + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char; + + -- vec_all_eq -- + + function vec_all_eq + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_all_eq + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_all_eq + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_all_eq + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_all_eq + (A : vector_bool_char; + B : vector_bool_char) return c_int; + + function vec_all_eq + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_all_eq + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_all_eq + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_all_eq + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_all_eq + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_all_eq + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_all_eq + (A : vector_bool_short; + B : vector_bool_short) return c_int; + + function vec_all_eq + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_all_eq + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_all_eq + (A : vector_pixel; + B : vector_pixel) return c_int; + + function vec_all_eq + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_all_eq + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_all_eq + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_all_eq + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_all_eq + (A : vector_bool_int; + B : vector_bool_int) return c_int; + + function vec_all_eq + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_all_eq + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_all_eq + (A : vector_float; + B : vector_float) return c_int; + + ---------------- + -- vec_all_ge -- + ---------------- + + function vec_all_ge + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_all_ge + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_all_ge + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_all_ge + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_all_ge + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_all_ge + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_all_ge + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_all_ge + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_all_ge + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_all_ge + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_all_ge + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_all_ge + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_all_ge + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_all_ge + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_all_ge + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_all_ge + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_all_ge + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_all_ge + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_all_ge + (A : vector_float; + B : vector_float) return c_int; + + ---------------- + -- vec_all_gt -- + ---------------- + + function vec_all_gt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_all_gt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_all_gt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_all_gt + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_all_gt + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_all_gt + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_all_gt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_all_gt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_all_gt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_all_gt + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_all_gt + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_all_gt + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_all_gt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_all_gt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_all_gt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_all_gt + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_all_gt + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_all_gt + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_all_gt + (A : vector_float; + B : vector_float) return c_int; + + ---------------- + -- vec_all_in -- + ---------------- + + function vec_all_in + (A : vector_float; + B : vector_float) return c_int; + + ---------------- + -- vec_all_le -- + ---------------- + + function vec_all_le + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_all_le + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_all_le + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_all_le + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_all_le + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_all_le + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_all_le + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_all_le + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_all_le + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_all_le + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_all_le + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_all_le + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_all_le + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_all_le + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_all_le + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_all_le + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_all_le + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_all_le + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_all_le + (A : vector_float; + B : vector_float) return c_int; + + ---------------- + -- vec_all_lt -- + ---------------- + + function vec_all_lt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_all_lt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_all_lt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_all_lt + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_all_lt + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_all_lt + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_all_lt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_all_lt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_all_lt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_all_lt + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_all_lt + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_all_lt + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_all_lt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_all_lt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_all_lt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_all_lt + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_all_lt + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_all_lt + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_all_lt + (A : vector_float; + B : vector_float) return c_int; + + ----------------- + -- vec_all_nan -- + ----------------- + + function vec_all_nan + (A : vector_float) return c_int; + + ---------------- + -- vec_all_ne -- + ---------------- + + function vec_all_ne + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_all_ne + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_all_ne + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_all_ne + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_all_ne + (A : vector_bool_char; + B : vector_bool_char) return c_int; + + function vec_all_ne + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_all_ne + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_all_ne + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_all_ne + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_all_ne + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_all_ne + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_all_ne + (A : vector_bool_short; + B : vector_bool_short) return c_int; + + function vec_all_ne + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_all_ne + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_all_ne + (A : vector_pixel; + B : vector_pixel) return c_int; + + function vec_all_ne + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_all_ne + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_all_ne + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_all_ne + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_all_ne + (A : vector_bool_int; + B : vector_bool_int) return c_int; + + function vec_all_ne + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_all_ne + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_all_ne + (A : vector_float; + B : vector_float) return c_int; + + ----------------- + -- vec_all_nge -- + ----------------- + + function vec_all_nge + (A : vector_float; + B : vector_float) return c_int; + + ----------------- + -- vec_all_ngt -- + ----------------- + + function vec_all_ngt + (A : vector_float; + B : vector_float) return c_int; + + ----------------- + -- vec_all_nle -- + ----------------- + + function vec_all_nle + (A : vector_float; + B : vector_float) return c_int; + + ----------------- + -- vec_all_nlt -- + ----------------- + + function vec_all_nlt + (A : vector_float; + B : vector_float) return c_int; + + --------------------- + -- vec_all_numeric -- + --------------------- + + function vec_all_numeric + (A : vector_float) return c_int; + + ---------------- + -- vec_any_eq -- + ---------------- + + function vec_any_eq + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_any_eq + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_any_eq + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_any_eq + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_any_eq + (A : vector_bool_char; + B : vector_bool_char) return c_int; + + function vec_any_eq + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_any_eq + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_any_eq + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_any_eq + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_any_eq + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_any_eq + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_any_eq + (A : vector_bool_short; + B : vector_bool_short) return c_int; + + function vec_any_eq + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_any_eq + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_any_eq + (A : vector_pixel; + B : vector_pixel) return c_int; + + function vec_any_eq + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_any_eq + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_any_eq + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_any_eq + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_any_eq + (A : vector_bool_int; + B : vector_bool_int) return c_int; + + function vec_any_eq + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_any_eq + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_any_eq + (A : vector_float; + B : vector_float) return c_int; + + ---------------- + -- vec_any_ge -- + ---------------- + + function vec_any_ge + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_any_ge + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_any_ge + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_any_ge + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_any_ge + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_any_ge + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_any_ge + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_any_ge + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_any_ge + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_any_ge + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_any_ge + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_any_ge + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_any_ge + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_any_ge + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_any_ge + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_any_ge + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_any_ge + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_any_ge + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_any_ge + (A : vector_float; + B : vector_float) return c_int; + + ---------------- + -- vec_any_gt -- + ---------------- + + function vec_any_gt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_any_gt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_any_gt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_any_gt + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_any_gt + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_any_gt + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_any_gt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_any_gt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_any_gt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_any_gt + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_any_gt + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_any_gt + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_any_gt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_any_gt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_any_gt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_any_gt + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_any_gt + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_any_gt + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_any_gt + (A : vector_float; + B : vector_float) return c_int; + + function vec_any_le + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_any_le + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_any_le + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_any_le + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_any_le + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_any_le + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_any_le + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_any_le + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_any_le + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_any_le + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_any_le + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_any_le + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_any_le + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_any_le + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_any_le + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_any_le + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_any_le + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_any_le + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_any_le + (A : vector_float; + B : vector_float) return c_int; + + function vec_any_lt + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_any_lt + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_any_lt + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_any_lt + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_any_lt + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_any_lt + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_any_lt + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_any_lt + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_any_lt + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_any_lt + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_any_lt + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_any_lt + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_any_lt + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_any_lt + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_any_lt + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_any_lt + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_any_lt + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_any_lt + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_any_lt + (A : vector_float; + B : vector_float) return c_int; + + function vec_any_nan + (A : vector_float) return c_int; + + function vec_any_ne + (A : vector_signed_char; + B : vector_bool_char) return c_int; + + function vec_any_ne + (A : vector_signed_char; + B : vector_signed_char) return c_int; + + function vec_any_ne + (A : vector_unsigned_char; + B : vector_bool_char) return c_int; + + function vec_any_ne + (A : vector_unsigned_char; + B : vector_unsigned_char) return c_int; + + function vec_any_ne + (A : vector_bool_char; + B : vector_bool_char) return c_int; + + function vec_any_ne + (A : vector_bool_char; + B : vector_unsigned_char) return c_int; + + function vec_any_ne + (A : vector_bool_char; + B : vector_signed_char) return c_int; + + function vec_any_ne + (A : vector_signed_short; + B : vector_bool_short) return c_int; + + function vec_any_ne + (A : vector_signed_short; + B : vector_signed_short) return c_int; + + function vec_any_ne + (A : vector_unsigned_short; + B : vector_bool_short) return c_int; + + function vec_any_ne + (A : vector_unsigned_short; + B : vector_unsigned_short) return c_int; + + function vec_any_ne + (A : vector_bool_short; + B : vector_bool_short) return c_int; + + function vec_any_ne + (A : vector_bool_short; + B : vector_unsigned_short) return c_int; + + function vec_any_ne + (A : vector_bool_short; + B : vector_signed_short) return c_int; + + function vec_any_ne + (A : vector_pixel; + B : vector_pixel) return c_int; + + function vec_any_ne + (A : vector_signed_int; + B : vector_bool_int) return c_int; + + function vec_any_ne + (A : vector_signed_int; + B : vector_signed_int) return c_int; + + function vec_any_ne + (A : vector_unsigned_int; + B : vector_bool_int) return c_int; + + function vec_any_ne + (A : vector_unsigned_int; + B : vector_unsigned_int) return c_int; + + function vec_any_ne + (A : vector_bool_int; + B : vector_bool_int) return c_int; + + function vec_any_ne + (A : vector_bool_int; + B : vector_unsigned_int) return c_int; + + function vec_any_ne + (A : vector_bool_int; + B : vector_signed_int) return c_int; + + function vec_any_ne + (A : vector_float; + B : vector_float) return c_int; + + ----------------- + -- vec_any_nge -- + ----------------- + + function vec_any_nge + (A : vector_float; + B : vector_float) return c_int; + + function vec_any_ngt + (A : vector_float; + B : vector_float) return c_int; + + function vec_any_nle + (A : vector_float; + B : vector_float) return c_int; + + function vec_any_nlt + (A : vector_float; + B : vector_float) return c_int; + + function vec_any_numeric + (A : vector_float) return c_int; + + function vec_any_out + (A : vector_float; + B : vector_float) return c_int; + + function vec_splat_s8 + (A : c_int) return vector_signed_char + renames vec_vspltisb; + + ------------------- + -- vec_splat_s16 -- + ------------------- + + function vec_splat_s16 + (A : c_int) return vector_signed_short + renames vec_vspltish; + + ------------------- + -- vec_splat_s32 -- + ------------------- + + function vec_splat_s32 + (A : c_int) return vector_signed_int + renames vec_vspltisw; + + function vec_splat + (A : vector_signed_char; + B : c_int) return vector_signed_char + renames vec_vspltb; + + function vec_splat + (A : vector_unsigned_char; + B : c_int) return vector_unsigned_char + renames vec_vspltb; + + function vec_splat + (A : vector_bool_char; + B : c_int) return vector_bool_char + renames vec_vspltb; + + function vec_splat + (A : vector_signed_short; + B : c_int) return vector_signed_short + renames vec_vsplth; + + function vec_splat + (A : vector_unsigned_short; + B : c_int) return vector_unsigned_short + renames vec_vsplth; + + function vec_splat + (A : vector_bool_short; + B : c_int) return vector_bool_short + renames vec_vsplth; + + function vec_splat + (A : vector_pixel; + B : c_int) return vector_pixel + renames vec_vsplth; + + function vec_splat + (A : vector_float; + B : c_int) return vector_float + renames vec_vspltw; + + function vec_splat + (A : vector_signed_int; + B : c_int) return vector_signed_int + renames vec_vspltw; + + function vec_splat + (A : vector_unsigned_int; + B : c_int) return vector_unsigned_int + renames vec_vspltw; + + function vec_splat + (A : vector_bool_int; + B : c_int) return vector_bool_int + renames vec_vspltw; + + ------------------ + -- vec_splat_u8 -- + ------------------ + + function vec_splat_u8 + (A : c_int) return vector_unsigned_char; + pragma Inline_Always (vec_splat_u8); + pragma Convention (Intrinsic, vec_splat_u8); + + ------------------- + -- vec_splat_u16 -- + ------------------- + + function vec_splat_u16 + (A : c_int) return vector_unsigned_short; + pragma Inline_Always (vec_splat_u16); + pragma Convention (Intrinsic, vec_splat_u16); + + ------------------- + -- vec_splat_u32 -- + ------------------- + + function vec_splat_u32 + (A : c_int) return vector_unsigned_int; + pragma Inline_Always (vec_splat_u32); + pragma Convention (Intrinsic, vec_splat_u32); + + ------------- + -- vec_ctf -- + ------------- + + function vec_ctf + (A : vector_unsigned_int; + B : c_int) return vector_float + renames vec_vcfux; + + function vec_ctf + (A : vector_signed_int; + B : c_int) return vector_float + renames vec_vcfsx; + + ------------- + -- vec_cts -- + ------------- + + function vec_cts + (A : vector_float; + B : c_int) return vector_signed_int + renames vec_vctsxs; + + function vec_ctu + (A : vector_float; + B : c_int) return vector_unsigned_int + renames vec_vctuxs; + + function vec_vaddcuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_addc; + + function vec_vand + (A : vector_float; + B : vector_float) return vector_float + renames vec_and; + + function vec_vand + (A : vector_float; + B : vector_bool_int) return vector_float + renames vec_and; + + function vec_vand + (A : vector_bool_int; + B : vector_float) return vector_float + renames vec_and; + + function vec_vand + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + renames vec_and; + + function vec_vand + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + renames vec_and; + + function vec_vand + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + renames vec_and; + + function vec_vand + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_and; + + function vec_vand + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_and; + + function vec_vand + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + renames vec_and; + + function vec_vand + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_and; + + function vec_vand + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + renames vec_and; + + function vec_vand + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + renames vec_and; + + function vec_vand + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + renames vec_and; + + function vec_vand + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + renames vec_and; + + function vec_vand + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_and; + + function vec_vand + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + renames vec_and; + + function vec_vand + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_and; + + function vec_vand + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + renames vec_and; + + function vec_vand + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + renames vec_and; + + function vec_vand + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + renames vec_and; + + function vec_vand + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + renames vec_and; + + function vec_vand + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_and; + + function vec_vand + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + renames vec_and; + + function vec_vand + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_and; + + --------------- + -- vec_vandc -- + --------------- + + function vec_vandc + (A : vector_float; + B : vector_float) return vector_float + renames vec_andc; + + function vec_vandc + (A : vector_float; + B : vector_bool_int) return vector_float + renames vec_andc; + + function vec_vandc + (A : vector_bool_int; + B : vector_float) return vector_float + renames vec_andc; + + function vec_vandc + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + renames vec_andc; + + function vec_vandc + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + renames vec_andc; + + function vec_vandc + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + renames vec_andc; + + function vec_vandc + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_andc; + + function vec_vandc + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_andc; + + function vec_vandc + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + renames vec_andc; + + function vec_vandc + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_andc; + + function vec_vandc + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + renames vec_andc; + + function vec_vandc + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + renames vec_andc; + + function vec_vandc + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + renames vec_andc; + + function vec_vandc + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + renames vec_andc; + + function vec_vandc + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_andc; + + function vec_vandc + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + renames vec_andc; + + function vec_vandc + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_andc; + + function vec_vandc + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + renames vec_andc; + + function vec_vandc + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + renames vec_andc; + + function vec_vandc + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + renames vec_andc; + + function vec_vandc + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + renames vec_andc; + + function vec_vandc + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_andc; + + function vec_vandc + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + renames vec_andc; + + function vec_vandc + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_andc; + + --------------- + -- vec_vrfip -- + --------------- + + function vec_vrfip + (A : vector_float) return vector_float + renames vec_ceil; + + ----------------- + -- vec_vcmpbfp -- + ----------------- + + function vec_vcmpbfp + (A : vector_float; + B : vector_float) return vector_signed_int + renames vec_cmpb; + + function vec_vcmpgefp + (A : vector_float; + B : vector_float) return vector_bool_int + renames vec_cmpge; + + function vec_vexptefp + (A : vector_float) return vector_float + renames vec_expte; + + --------------- + -- vec_vrfim -- + --------------- + + function vec_vrfim + (A : vector_float) return vector_float + renames vec_floor; + + function vec_lvx + (A : c_long; + B : const_vector_float_ptr) return vector_float + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_float_ptr) return vector_float + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_bool_int_ptr) return vector_bool_int + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_signed_int_ptr) return vector_signed_int + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_int_ptr) return vector_signed_int + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_long_ptr) return vector_signed_int + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_unsigned_int_ptr) return vector_unsigned_int + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_bool_short_ptr) return vector_bool_short + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_pixel_ptr) return vector_pixel + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_signed_short_ptr) return vector_signed_short + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_short_ptr) return vector_signed_short + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_unsigned_short_ptr) return vector_unsigned_short + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_bool_char_ptr) return vector_bool_char + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_signed_char_ptr) return vector_signed_char + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_vector_unsigned_char_ptr) return vector_unsigned_char + renames vec_ld; + + function vec_lvx + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char + renames vec_ld; + + function vec_lvxl + (A : c_long; + B : const_vector_float_ptr) return vector_float + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_float_ptr) return vector_float + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_bool_int_ptr) return vector_bool_int + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_signed_int_ptr) return vector_signed_int + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_int_ptr) return vector_signed_int + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_long_ptr) return vector_signed_int + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_unsigned_int_ptr) return vector_unsigned_int + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_unsigned_int_ptr) return vector_unsigned_int + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_unsigned_long_ptr) return vector_unsigned_int + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_bool_short_ptr) return vector_bool_short + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_pixel_ptr) return vector_pixel + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_signed_short_ptr) return vector_signed_short + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_short_ptr) return vector_signed_short + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_unsigned_short_ptr) return vector_unsigned_short + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_unsigned_short_ptr) return vector_unsigned_short + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_bool_char_ptr) return vector_bool_char + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_signed_char_ptr) return vector_signed_char + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_signed_char_ptr) return vector_signed_char + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_vector_unsigned_char_ptr) return vector_unsigned_char + renames vec_ldl; + + function vec_lvxl + (A : c_long; + B : const_unsigned_char_ptr) return vector_unsigned_char + renames vec_ldl; + + function vec_vlogefp + (A : vector_float) return vector_float + renames vec_loge; + + ----------------- + -- vec_vmaddfp -- + ----------------- + + function vec_vmaddfp + (A : vector_float; + B : vector_float; + C : vector_float) return vector_float + renames vec_madd; + + ------------------- + -- vec_vmhaddshs -- + ------------------- + + function vec_vmhaddshs + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + renames vec_madds; + + ------------------- + -- vec_vmladduhm -- + ------------------- + + function vec_vmladduhm + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + renames vec_mladd; + + function vec_vmladduhm + (A : vector_signed_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_signed_short + renames vec_mladd; + + function vec_vmladduhm + (A : vector_unsigned_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + renames vec_mladd; + + function vec_vmladduhm + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_unsigned_short + renames vec_mladd; + + -------------------- + -- vec_vmhraddshs -- + -------------------- + + function vec_vmhraddshs + (A : vector_signed_short; + B : vector_signed_short; + C : vector_signed_short) return vector_signed_short + renames vec_mradds; + + ------------------ + -- vec_vnmsubfp -- + ------------------ + + function vec_vnmsubfp + (A : vector_float; + B : vector_float; + C : vector_float) return vector_float + renames vec_nmsub; + + -------------- + -- vec_vnor -- + -------------- + + function vec_vnor + (A : vector_float; + B : vector_float) return vector_float + renames vec_nor; + + function vec_vnor + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_nor; + + function vec_vnor + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_nor; + + function vec_vnor + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + renames vec_nor; + + function vec_vnor + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + renames vec_nor; + + function vec_vnor + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_nor; + + function vec_vnor + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + renames vec_nor; + + function vec_vnor + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + renames vec_nor; + + function vec_vnor + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_nor; + + function vec_vnor + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + renames vec_nor; + + ------------- + -- vec_vor -- + ------------- + + function vec_vor + (A : vector_float; + B : vector_float) return vector_float + renames vec_or; + + function vec_vor + (A : vector_float; + B : vector_bool_int) return vector_float + renames vec_or; + + function vec_vor + (A : vector_bool_int; + B : vector_float) return vector_float + renames vec_or; + + function vec_vor + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + renames vec_or; + + function vec_vor + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + renames vec_or; + + function vec_vor + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + renames vec_or; + + function vec_vor + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_or; + + function vec_vor + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_or; + + function vec_vor + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + renames vec_or; + + function vec_vor + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_or; + + function vec_vor + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + renames vec_or; + + function vec_vor + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + renames vec_or; + + function vec_vor + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + renames vec_or; + + function vec_vor + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + renames vec_or; + + function vec_vor + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_or; + + function vec_vor + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + renames vec_or; + + function vec_vor + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_or; + + function vec_vor + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + renames vec_or; + + function vec_vor + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + renames vec_or; + + function vec_vor + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + renames vec_or; + + function vec_vor + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + renames vec_or; + + function vec_vor + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_or; + + function vec_vor + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + renames vec_or; + + function vec_vor + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_or; + + --------------- + -- vec_vpkpx -- + --------------- + + function vec_vpkpx + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_pixel + renames vec_packpx; + + --------------- + -- vec_vperm -- + --------------- + + function vec_vperm + (A : vector_float; + B : vector_float; + C : vector_unsigned_char) return vector_float + renames vec_perm; + + function vec_vperm + (A : vector_signed_int; + B : vector_signed_int; + C : vector_unsigned_char) return vector_signed_int + renames vec_perm; + + function vec_vperm + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_unsigned_char) return vector_unsigned_int + renames vec_perm; + + function vec_vperm + (A : vector_bool_int; + B : vector_bool_int; + C : vector_unsigned_char) return vector_bool_int + renames vec_perm; + + function vec_vperm + (A : vector_signed_short; + B : vector_signed_short; + C : vector_unsigned_char) return vector_signed_short + renames vec_perm; + + function vec_vperm + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_char) return vector_unsigned_short + renames vec_perm; + + function vec_vperm + (A : vector_bool_short; + B : vector_bool_short; + C : vector_unsigned_char) return vector_bool_short + renames vec_perm; + + function vec_vperm + (A : vector_pixel; + B : vector_pixel; + C : vector_unsigned_char) return vector_pixel + renames vec_perm; + + function vec_vperm + (A : vector_signed_char; + B : vector_signed_char; + C : vector_unsigned_char) return vector_signed_char + renames vec_perm; + + function vec_vperm + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_char) return vector_unsigned_char + renames vec_perm; + + function vec_vperm + (A : vector_bool_char; + B : vector_bool_char; + C : vector_unsigned_char) return vector_bool_char + renames vec_perm; + + --------------- + -- vec_vrefp -- + --------------- + + function vec_vrefp + (A : vector_float) return vector_float + renames vec_re; + + --------------- + -- vec_vrfin -- + --------------- + + function vec_vrfin + (A : vector_float) return vector_float + renames vec_round; + + function vec_vrsqrtefp + (A : vector_float) return vector_float + renames vec_rsqrte; + + function vec_vsel + (A : vector_float; + B : vector_float; + C : vector_bool_int) return vector_float + renames vec_sel; + + function vec_vsel + (A : vector_float; + B : vector_float; + C : vector_unsigned_int) return vector_float + renames vec_sel; + + function vec_vsel + (A : vector_signed_int; + B : vector_signed_int; + C : vector_bool_int) return vector_signed_int + renames vec_sel; + + function vec_vsel + (A : vector_signed_int; + B : vector_signed_int; + C : vector_unsigned_int) return vector_signed_int + renames vec_sel; + + function vec_vsel + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_bool_int) return vector_unsigned_int + renames vec_sel; + + function vec_vsel + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : vector_unsigned_int) return vector_unsigned_int + renames vec_sel; + + function vec_vsel + (A : vector_bool_int; + B : vector_bool_int; + C : vector_bool_int) return vector_bool_int + renames vec_sel; + + function vec_vsel + (A : vector_bool_int; + B : vector_bool_int; + C : vector_unsigned_int) return vector_bool_int + renames vec_sel; + + function vec_vsel + (A : vector_signed_short; + B : vector_signed_short; + C : vector_bool_short) return vector_signed_short + renames vec_sel; + + function vec_vsel + (A : vector_signed_short; + B : vector_signed_short; + C : vector_unsigned_short) return vector_signed_short + renames vec_sel; + + function vec_vsel + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_bool_short) return vector_unsigned_short + renames vec_sel; + + function vec_vsel + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : vector_unsigned_short) return vector_unsigned_short + renames vec_sel; + + function vec_vsel + (A : vector_bool_short; + B : vector_bool_short; + C : vector_bool_short) return vector_bool_short + renames vec_sel; + + function vec_vsel + (A : vector_bool_short; + B : vector_bool_short; + C : vector_unsigned_short) return vector_bool_short + renames vec_sel; + + function vec_vsel + (A : vector_signed_char; + B : vector_signed_char; + C : vector_bool_char) return vector_signed_char + renames vec_sel; + + function vec_vsel + (A : vector_signed_char; + B : vector_signed_char; + C : vector_unsigned_char) return vector_signed_char + renames vec_sel; + + function vec_vsel + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_bool_char) return vector_unsigned_char + renames vec_sel; + + function vec_vsel + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : vector_unsigned_char) return vector_unsigned_char + renames vec_sel; + + function vec_vsel + (A : vector_bool_char; + B : vector_bool_char; + C : vector_bool_char) return vector_bool_char + renames vec_sel; + + function vec_vsel + (A : vector_bool_char; + B : vector_bool_char; + C : vector_unsigned_char) return vector_bool_char + renames vec_sel; + + ---------------- + -- vec_vsldoi -- + ---------------- + + function vec_vsldoi + (A : vector_float; + B : vector_float; + C : c_int) return vector_float + renames vec_sld; + + function vec_vsldoi + (A : vector_signed_int; + B : vector_signed_int; + C : c_int) return vector_signed_int + renames vec_sld; + + function vec_vsldoi + (A : vector_unsigned_int; + B : vector_unsigned_int; + C : c_int) return vector_unsigned_int + renames vec_sld; + + function vec_vsldoi + (A : vector_bool_int; + B : vector_bool_int; + C : c_int) return vector_bool_int + renames vec_sld; + + function vec_vsldoi + (A : vector_signed_short; + B : vector_signed_short; + C : c_int) return vector_signed_short + renames vec_sld; + + function vec_vsldoi + (A : vector_unsigned_short; + B : vector_unsigned_short; + C : c_int) return vector_unsigned_short + renames vec_sld; + + function vec_vsldoi + (A : vector_bool_short; + B : vector_bool_short; + C : c_int) return vector_bool_short + renames vec_sld; + + function vec_vsldoi + (A : vector_pixel; + B : vector_pixel; + C : c_int) return vector_pixel + renames vec_sld; + + function vec_vsldoi + (A : vector_signed_char; + B : vector_signed_char; + C : c_int) return vector_signed_char + renames vec_sld; + + function vec_vsldoi + (A : vector_unsigned_char; + B : vector_unsigned_char; + C : c_int) return vector_unsigned_char + renames vec_sld; + + function vec_vsldoi + (A : vector_bool_char; + B : vector_bool_char; + C : c_int) return vector_bool_char + renames vec_sld; + + ------------- + -- vec_vsl -- + ------------- + + function vec_vsl + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + renames vec_sll; + + function vec_vsl + (A : vector_signed_int; + B : vector_unsigned_short) return vector_signed_int + renames vec_sll; + + function vec_vsl + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_int; + B : vector_unsigned_short) return vector_unsigned_int + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + renames vec_sll; + + function vec_vsl + (A : vector_bool_int; + B : vector_unsigned_int) return vector_bool_int + renames vec_sll; + + function vec_vsl + (A : vector_bool_int; + B : vector_unsigned_short) return vector_bool_int + renames vec_sll; + + function vec_vsl + (A : vector_bool_int; + B : vector_unsigned_char) return vector_bool_int + renames vec_sll; + + function vec_vsl + (A : vector_signed_short; + B : vector_unsigned_int) return vector_signed_short + renames vec_sll; + + function vec_vsl + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + renames vec_sll; + + function vec_vsl + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_short; + B : vector_unsigned_int) return vector_unsigned_short + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + renames vec_sll; + + function vec_vsl + (A : vector_bool_short; + B : vector_unsigned_int) return vector_bool_short + renames vec_sll; + + function vec_vsl + (A : vector_bool_short; + B : vector_unsigned_short) return vector_bool_short + renames vec_sll; + + function vec_vsl + (A : vector_bool_short; + B : vector_unsigned_char) return vector_bool_short + renames vec_sll; + + function vec_vsl + (A : vector_pixel; + B : vector_unsigned_int) return vector_pixel + renames vec_sll; + + function vec_vsl + (A : vector_pixel; + B : vector_unsigned_short) return vector_pixel + renames vec_sll; + + function vec_vsl + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + renames vec_sll; + + function vec_vsl + (A : vector_signed_char; + B : vector_unsigned_int) return vector_signed_char + renames vec_sll; + + function vec_vsl + (A : vector_signed_char; + B : vector_unsigned_short) return vector_signed_char + renames vec_sll; + + function vec_vsl + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_char + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_char; + B : vector_unsigned_short) return vector_unsigned_char + renames vec_sll; + + function vec_vsl + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_sll; + + function vec_vsl + (A : vector_bool_char; + B : vector_unsigned_int) return vector_bool_char + renames vec_sll; + + function vec_vsl + (A : vector_bool_char; + B : vector_unsigned_short) return vector_bool_char + renames vec_sll; + + function vec_vsl + (A : vector_bool_char; + B : vector_unsigned_char) return vector_bool_char + renames vec_sll; + + -------------- + -- vec_vslo -- + -------------- + + function vec_vslo + (A : vector_float; + B : vector_signed_char) return vector_float + renames vec_slo; + + function vec_vslo + (A : vector_float; + B : vector_unsigned_char) return vector_float + renames vec_slo; + + function vec_vslo + (A : vector_signed_int; + B : vector_signed_char) return vector_signed_int + renames vec_slo; + + function vec_vslo + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + renames vec_slo; + + function vec_vslo + (A : vector_unsigned_int; + B : vector_signed_char) return vector_unsigned_int + renames vec_slo; + + function vec_vslo + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + renames vec_slo; + + function vec_vslo + (A : vector_signed_short; + B : vector_signed_char) return vector_signed_short + renames vec_slo; + + function vec_vslo + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + renames vec_slo; + + function vec_vslo + (A : vector_unsigned_short; + B : vector_signed_char) return vector_unsigned_short + renames vec_slo; + + function vec_vslo + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + renames vec_slo; + + function vec_vslo + (A : vector_pixel; + B : vector_signed_char) return vector_pixel + renames vec_slo; + + function vec_vslo + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + renames vec_slo; + + function vec_vslo + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + renames vec_slo; + + function vec_vslo + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + renames vec_slo; + + function vec_vslo + (A : vector_unsigned_char; + B : vector_signed_char) return vector_unsigned_char + renames vec_slo; + + function vec_vslo + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_slo; + + function vec_vsr + (A : vector_signed_int; + B : vector_unsigned_int) return vector_signed_int + renames vec_srl; + + function vec_vsr + (A : vector_signed_int; + B : vector_unsigned_short) return vector_signed_int + renames vec_srl; + + function vec_vsr + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_int; + B : vector_unsigned_short) return vector_unsigned_int + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + renames vec_srl; + + function vec_vsr + (A : vector_bool_int; + B : vector_unsigned_int) return vector_bool_int + renames vec_srl; + + function vec_vsr + (A : vector_bool_int; + B : vector_unsigned_short) return vector_bool_int + renames vec_srl; + + function vec_vsr + (A : vector_bool_int; + B : vector_unsigned_char) return vector_bool_int + renames vec_srl; + + function vec_vsr + (A : vector_signed_short; + B : vector_unsigned_int) return vector_signed_short + renames vec_srl; + + function vec_vsr + (A : vector_signed_short; + B : vector_unsigned_short) return vector_signed_short + renames vec_srl; + + function vec_vsr + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_short; + B : vector_unsigned_int) return vector_unsigned_short + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + renames vec_srl; + + function vec_vsr + (A : vector_bool_short; + B : vector_unsigned_int) return vector_bool_short + renames vec_srl; + + function vec_vsr + (A : vector_bool_short; + B : vector_unsigned_short) return vector_bool_short + renames vec_srl; + + function vec_vsr + (A : vector_bool_short; + B : vector_unsigned_char) return vector_bool_short + renames vec_srl; + + function vec_vsr + (A : vector_pixel; + B : vector_unsigned_int) return vector_pixel + renames vec_srl; + + function vec_vsr + (A : vector_pixel; + B : vector_unsigned_short) return vector_pixel + renames vec_srl; + + function vec_vsr + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + renames vec_srl; + + function vec_vsr + (A : vector_signed_char; + B : vector_unsigned_int) return vector_signed_char + renames vec_srl; + + function vec_vsr + (A : vector_signed_char; + B : vector_unsigned_short) return vector_signed_char + renames vec_srl; + + function vec_vsr + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_char; + B : vector_unsigned_int) return vector_unsigned_char + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_char; + B : vector_unsigned_short) return vector_unsigned_char + renames vec_srl; + + function vec_vsr + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_srl; + + function vec_vsr + (A : vector_bool_char; + B : vector_unsigned_int) return vector_bool_char + renames vec_srl; + + function vec_vsr + (A : vector_bool_char; + B : vector_unsigned_short) return vector_bool_char + renames vec_srl; + + function vec_vsr + (A : vector_bool_char; + B : vector_unsigned_char) return vector_bool_char + renames vec_srl; + + function vec_vsro + (A : vector_float; + B : vector_signed_char) return vector_float + renames vec_sro; + + function vec_vsro + (A : vector_float; + B : vector_unsigned_char) return vector_float + renames vec_sro; + + function vec_vsro + (A : vector_signed_int; + B : vector_signed_char) return vector_signed_int + renames vec_sro; + + function vec_vsro + (A : vector_signed_int; + B : vector_unsigned_char) return vector_signed_int + renames vec_sro; + + function vec_vsro + (A : vector_unsigned_int; + B : vector_signed_char) return vector_unsigned_int + renames vec_sro; + + function vec_vsro + (A : vector_unsigned_int; + B : vector_unsigned_char) return vector_unsigned_int + renames vec_sro; + + function vec_vsro + (A : vector_signed_short; + B : vector_signed_char) return vector_signed_short + renames vec_sro; + + function vec_vsro + (A : vector_signed_short; + B : vector_unsigned_char) return vector_signed_short + renames vec_sro; + + function vec_vsro + (A : vector_unsigned_short; + B : vector_signed_char) return vector_unsigned_short + renames vec_sro; + + function vec_vsro + (A : vector_unsigned_short; + B : vector_unsigned_char) return vector_unsigned_short + renames vec_sro; + + function vec_vsro + (A : vector_pixel; + B : vector_signed_char) return vector_pixel + renames vec_sro; + + function vec_vsro + (A : vector_pixel; + B : vector_unsigned_char) return vector_pixel + renames vec_sro; + + function vec_vsro + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + renames vec_sro; + + function vec_vsro + (A : vector_signed_char; + B : vector_unsigned_char) return vector_signed_char + renames vec_sro; + + function vec_vsro + (A : vector_unsigned_char; + B : vector_signed_char) return vector_unsigned_char + renames vec_sro; + + function vec_vsro + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_sro; + + -------------- + -- vec_stvx -- + -------------- + + procedure vec_stvx + (A : vector_float; + B : c_int; + C : vector_float_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_float; + B : c_int; + C : float_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_signed_int; + B : c_int; + C : vector_signed_int_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_signed_int; + B : c_int; + C : int_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_unsigned_int; + B : c_int; + C : vector_unsigned_int_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_int; + B : c_int; + C : vector_bool_int_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_int; + B : c_int; + C : int_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_signed_short; + B : c_int; + C : vector_signed_short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_signed_short; + B : c_int; + C : short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_unsigned_short; + B : c_int; + C : vector_unsigned_short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_short; + B : c_int; + C : vector_bool_short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_pixel; + B : c_int; + C : vector_pixel_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_pixel; + B : c_int; + C : short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_short; + B : c_int; + C : short_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_signed_char; + B : c_int; + C : vector_signed_char_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_unsigned_char; + B : c_int; + C : vector_unsigned_char_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_char; + B : c_int; + C : vector_bool_char_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr) + renames vec_st; + + procedure vec_stvx + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr) + renames vec_st; + + --------------- + -- vec_stvxl -- + --------------- + + procedure vec_stvxl + (A : vector_float; + B : c_int; + C : vector_float_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_float; + B : c_int; + C : float_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_signed_int; + B : c_int; + C : vector_signed_int_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_signed_int; + B : c_int; + C : int_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_unsigned_int; + B : c_int; + C : vector_unsigned_int_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_unsigned_int; + B : c_int; + C : unsigned_int_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_int; + B : c_int; + C : vector_bool_int_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_int; + B : c_int; + C : unsigned_int_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_int; + B : c_int; + C : int_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_signed_short; + B : c_int; + C : vector_signed_short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_signed_short; + B : c_int; + C : short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_unsigned_short; + B : c_int; + C : vector_unsigned_short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_unsigned_short; + B : c_int; + C : unsigned_short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_short; + B : c_int; + C : vector_bool_short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_short; + B : c_int; + C : unsigned_short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_short; + B : c_int; + C : short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_pixel; + B : c_int; + C : vector_pixel_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_pixel; + B : c_int; + C : unsigned_short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_pixel; + B : c_int; + C : short_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_signed_char; + B : c_int; + C : vector_signed_char_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_signed_char; + B : c_int; + C : signed_char_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_unsigned_char; + B : c_int; + C : vector_unsigned_char_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_unsigned_char; + B : c_int; + C : unsigned_char_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_char; + B : c_int; + C : vector_bool_char_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_char; + B : c_int; + C : unsigned_char_ptr) + renames vec_stl; + + procedure vec_stvxl + (A : vector_bool_char; + B : c_int; + C : signed_char_ptr) + renames vec_stl; + + function vec_vsubcuw + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_subc; + + ------------------ + -- vec_vsum2sws -- + ------------------ + + function vec_vsum2sws + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_sum2s; + + function vec_vsumsws + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_sums; + + function vec_vrfiz + (A : vector_float) return vector_float + renames vec_trunc; + + -------------- + -- vec_vxor -- + -------------- + + function vec_vxor + (A : vector_float; + B : vector_float) return vector_float + renames vec_xor; + + function vec_vxor + (A : vector_float; + B : vector_bool_int) return vector_float + renames vec_xor; + + function vec_vxor + (A : vector_bool_int; + B : vector_float) return vector_float + renames vec_xor; + + function vec_vxor + (A : vector_bool_int; + B : vector_bool_int) return vector_bool_int + renames vec_xor; + + function vec_vxor + (A : vector_bool_int; + B : vector_signed_int) return vector_signed_int + renames vec_xor; + + function vec_vxor + (A : vector_signed_int; + B : vector_bool_int) return vector_signed_int + renames vec_xor; + + function vec_vxor + (A : vector_signed_int; + B : vector_signed_int) return vector_signed_int + renames vec_xor; + + function vec_vxor + (A : vector_bool_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_xor; + + function vec_vxor + (A : vector_unsigned_int; + B : vector_bool_int) return vector_unsigned_int + renames vec_xor; + + function vec_vxor + (A : vector_unsigned_int; + B : vector_unsigned_int) return vector_unsigned_int + renames vec_xor; + + function vec_vxor + (A : vector_bool_short; + B : vector_bool_short) return vector_bool_short + renames vec_xor; + + function vec_vxor + (A : vector_bool_short; + B : vector_signed_short) return vector_signed_short + renames vec_xor; + + function vec_vxor + (A : vector_signed_short; + B : vector_bool_short) return vector_signed_short + renames vec_xor; + + function vec_vxor + (A : vector_signed_short; + B : vector_signed_short) return vector_signed_short + renames vec_xor; + + function vec_vxor + (A : vector_bool_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_xor; + + function vec_vxor + (A : vector_unsigned_short; + B : vector_bool_short) return vector_unsigned_short + renames vec_xor; + + function vec_vxor + (A : vector_unsigned_short; + B : vector_unsigned_short) return vector_unsigned_short + renames vec_xor; + + function vec_vxor + (A : vector_bool_char; + B : vector_signed_char) return vector_signed_char + renames vec_xor; + + function vec_vxor + (A : vector_bool_char; + B : vector_bool_char) return vector_bool_char + renames vec_xor; + + function vec_vxor + (A : vector_signed_char; + B : vector_bool_char) return vector_signed_char + renames vec_xor; + + function vec_vxor + (A : vector_signed_char; + B : vector_signed_char) return vector_signed_char + renames vec_xor; + + function vec_vxor + (A : vector_bool_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_xor; + + function vec_vxor + (A : vector_unsigned_char; + B : vector_bool_char) return vector_unsigned_char + renames vec_xor; + + function vec_vxor + (A : vector_unsigned_char; + B : vector_unsigned_char) return vector_unsigned_char + renames vec_xor; + + -------------- + -- vec_step -- + -------------- + + function vec_step (V : vector_unsigned_char) return Integer; + function vec_step (V : vector_signed_char) return Integer; + function vec_step (V : vector_bool_char) return Integer; + + function vec_step (V : vector_unsigned_short) return Integer; + function vec_step (V : vector_signed_short) return Integer; + function vec_step (V : vector_bool_short) return Integer; + + function vec_step (V : vector_unsigned_int) return Integer; + function vec_step (V : vector_signed_int) return Integer; + function vec_step (V : vector_bool_int) return Integer; + + function vec_step (V : vector_float) return Integer; + function vec_step (V : vector_pixel) return Integer; + +private + + pragma Inline_Always (vec_abs); + pragma Inline_Always (vec_abss); + pragma Inline_Always (vec_add); + pragma Inline_Always (vec_vaddfp); + pragma Inline_Always (vec_vadduwm); + pragma Inline_Always (vec_vadduhm); + pragma Inline_Always (vec_vaddubm); + pragma Inline_Always (vec_addc); + pragma Inline_Always (vec_adds); + pragma Inline_Always (vec_vaddsws); + pragma Inline_Always (vec_vadduws); + pragma Inline_Always (vec_vaddshs); + pragma Inline_Always (vec_vadduhs); + pragma Inline_Always (vec_vaddsbs); + pragma Inline_Always (vec_vaddubs); + pragma Inline_Always (vec_and); + pragma Inline_Always (vec_andc); + pragma Inline_Always (vec_avg); + pragma Inline_Always (vec_vavgsw); + pragma Inline_Always (vec_vavguw); + pragma Inline_Always (vec_vavgsh); + pragma Inline_Always (vec_vavguh); + pragma Inline_Always (vec_vavgsb); + pragma Inline_Always (vec_vavgub); + pragma Inline_Always (vec_ceil); + pragma Inline_Always (vec_cmpb); + pragma Inline_Always (vec_cmpeq); + pragma Inline_Always (vec_vcmpeqfp); + pragma Inline_Always (vec_vcmpequw); + pragma Inline_Always (vec_vcmpequh); + pragma Inline_Always (vec_vcmpequb); + pragma Inline_Always (vec_cmpge); + pragma Inline_Always (vec_cmpgt); + pragma Inline_Always (vec_vcmpgtfp); + pragma Inline_Always (vec_vcmpgtsw); + pragma Inline_Always (vec_vcmpgtuw); + pragma Inline_Always (vec_vcmpgtsh); + pragma Inline_Always (vec_vcmpgtuh); + pragma Inline_Always (vec_vcmpgtsb); + pragma Inline_Always (vec_vcmpgtub); + pragma Inline_Always (vec_cmple); + pragma Inline_Always (vec_cmplt); + pragma Inline_Always (vec_expte); + pragma Inline_Always (vec_floor); + pragma Inline_Always (vec_ld); + pragma Inline_Always (vec_lde); + pragma Inline_Always (vec_lvewx); + pragma Inline_Always (vec_lvehx); + pragma Inline_Always (vec_lvebx); + pragma Inline_Always (vec_ldl); + pragma Inline_Always (vec_loge); + pragma Inline_Always (vec_lvsl); + pragma Inline_Always (vec_lvsr); + pragma Inline_Always (vec_madd); + pragma Inline_Always (vec_madds); + pragma Inline_Always (vec_max); + pragma Inline_Always (vec_vmaxfp); + pragma Inline_Always (vec_vmaxsw); + pragma Inline_Always (vec_vmaxuw); + pragma Inline_Always (vec_vmaxsh); + pragma Inline_Always (vec_vmaxuh); + pragma Inline_Always (vec_vmaxsb); + pragma Inline_Always (vec_vmaxub); + pragma Inline_Always (vec_mergeh); + pragma Inline_Always (vec_vmrghw); + pragma Inline_Always (vec_vmrghh); + pragma Inline_Always (vec_vmrghb); + pragma Inline_Always (vec_mergel); + pragma Inline_Always (vec_vmrglw); + pragma Inline_Always (vec_vmrglh); + pragma Inline_Always (vec_vmrglb); + pragma Inline_Always (vec_mfvscr); + pragma Inline_Always (vec_min); + pragma Inline_Always (vec_vminfp); + pragma Inline_Always (vec_vminsw); + pragma Inline_Always (vec_vminuw); + pragma Inline_Always (vec_vminsh); + pragma Inline_Always (vec_vminuh); + pragma Inline_Always (vec_vminsb); + pragma Inline_Always (vec_vminub); + pragma Inline_Always (vec_mladd); + pragma Inline_Always (vec_mradds); + pragma Inline_Always (vec_msum); + pragma Inline_Always (vec_vmsumshm); + pragma Inline_Always (vec_vmsumuhm); + pragma Inline_Always (vec_vmsummbm); + pragma Inline_Always (vec_vmsumubm); + pragma Inline_Always (vec_msums); + pragma Inline_Always (vec_vmsumshs); + pragma Inline_Always (vec_vmsumuhs); + pragma Inline_Always (vec_mtvscr); + pragma Inline_Always (vec_mule); + pragma Inline_Always (vec_vmulesh); + pragma Inline_Always (vec_vmuleuh); + pragma Inline_Always (vec_vmulesb); + pragma Inline_Always (vec_vmuleub); + pragma Inline_Always (vec_mulo); + pragma Inline_Always (vec_vmulosh); + pragma Inline_Always (vec_vmulouh); + pragma Inline_Always (vec_vmulosb); + pragma Inline_Always (vec_vmuloub); + pragma Inline_Always (vec_nmsub); + pragma Inline_Always (vec_nor); + pragma Inline_Always (vec_or); + pragma Inline_Always (vec_pack); + pragma Inline_Always (vec_vpkuwum); + pragma Inline_Always (vec_vpkuhum); + pragma Inline_Always (vec_packpx); + pragma Inline_Always (vec_packs); + pragma Inline_Always (vec_vpkswss); + pragma Inline_Always (vec_vpkuwus); + pragma Inline_Always (vec_vpkshss); + pragma Inline_Always (vec_vpkuhus); + pragma Inline_Always (vec_packsu); + pragma Inline_Always (vec_vpkswus); + pragma Inline_Always (vec_vpkshus); + pragma Inline_Always (vec_perm); + pragma Inline_Always (vec_re); + pragma Inline_Always (vec_rl); + pragma Inline_Always (vec_vrlw); + pragma Inline_Always (vec_vrlh); + pragma Inline_Always (vec_vrlb); + pragma Inline_Always (vec_round); + pragma Inline_Always (vec_rsqrte); + pragma Inline_Always (vec_sel); + pragma Inline_Always (vec_sl); + pragma Inline_Always (vec_vslw); + pragma Inline_Always (vec_vslh); + pragma Inline_Always (vec_vslb); + pragma Inline_Always (vec_sll); + pragma Inline_Always (vec_slo); + pragma Inline_Always (vec_sr); + pragma Inline_Always (vec_vsrw); + pragma Inline_Always (vec_vsrh); + pragma Inline_Always (vec_vsrb); + pragma Inline_Always (vec_sra); + pragma Inline_Always (vec_vsraw); + pragma Inline_Always (vec_vsrah); + pragma Inline_Always (vec_vsrab); + pragma Inline_Always (vec_srl); + pragma Inline_Always (vec_sro); + pragma Inline_Always (vec_st); + pragma Inline_Always (vec_ste); + pragma Inline_Always (vec_stvewx); + pragma Inline_Always (vec_stvehx); + pragma Inline_Always (vec_stvebx); + pragma Inline_Always (vec_stl); + pragma Inline_Always (vec_sub); + pragma Inline_Always (vec_vsubfp); + pragma Inline_Always (vec_vsubuwm); + pragma Inline_Always (vec_vsubuhm); + pragma Inline_Always (vec_vsububm); + pragma Inline_Always (vec_subc); + pragma Inline_Always (vec_subs); + pragma Inline_Always (vec_vsubsws); + pragma Inline_Always (vec_vsubuws); + pragma Inline_Always (vec_vsubshs); + pragma Inline_Always (vec_vsubuhs); + pragma Inline_Always (vec_vsubsbs); + pragma Inline_Always (vec_vsububs); + pragma Inline_Always (vec_sum4s); + pragma Inline_Always (vec_vsum4shs); + pragma Inline_Always (vec_vsum4sbs); + pragma Inline_Always (vec_vsum4ubs); + pragma Inline_Always (vec_sum2s); + pragma Inline_Always (vec_sums); + pragma Inline_Always (vec_trunc); + pragma Inline_Always (vec_unpackh); + pragma Inline_Always (vec_vupkhsh); + pragma Inline_Always (vec_vupkhpx); + pragma Inline_Always (vec_vupkhsb); + pragma Inline_Always (vec_unpackl); + pragma Inline_Always (vec_vupklpx); + pragma Inline_Always (vec_vupklsh); + pragma Inline_Always (vec_vupklsb); + pragma Inline_Always (vec_xor); + + pragma Inline_Always (vec_all_eq); + pragma Inline_Always (vec_all_ge); + pragma Inline_Always (vec_all_gt); + pragma Inline_Always (vec_all_in); + pragma Inline_Always (vec_all_le); + pragma Inline_Always (vec_all_lt); + pragma Inline_Always (vec_all_nan); + pragma Inline_Always (vec_all_ne); + pragma Inline_Always (vec_all_nge); + pragma Inline_Always (vec_all_ngt); + pragma Inline_Always (vec_all_nle); + pragma Inline_Always (vec_all_nlt); + pragma Inline_Always (vec_all_numeric); + pragma Inline_Always (vec_any_eq); + pragma Inline_Always (vec_any_ge); + pragma Inline_Always (vec_any_gt); + pragma Inline_Always (vec_any_le); + pragma Inline_Always (vec_any_lt); + pragma Inline_Always (vec_any_nan); + pragma Inline_Always (vec_any_ne); + pragma Inline_Always (vec_any_nge); + pragma Inline_Always (vec_any_ngt); + pragma Inline_Always (vec_any_nle); + pragma Inline_Always (vec_any_nlt); + pragma Inline_Always (vec_any_numeric); + pragma Inline_Always (vec_any_out); + pragma Inline_Always (vec_step); + +end GNAT.Altivec.Vector_Operations; diff --git a/gcc/ada/libgnat/g-alvety.ads b/gcc/ada/libgnat/g-alvety.ads new file mode 100644 index 0000000..623a5fc --- /dev/null +++ b/gcc/ada/libgnat/g-alvety.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . V E C T O R _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit exposes the various vector types part of the Ada binding to +-- Altivec facilities. + +with GNAT.Altivec.Low_Level_Vectors; + +package GNAT.Altivec.Vector_Types is + + use GNAT.Altivec.Low_Level_Vectors; + + --------------------------------------------------- + -- Vector type declarations [PIM-2.1 Data Types] -- + --------------------------------------------------- + + -- Except for assignments and pointer creation/dereference, operations + -- on vectors are only performed via subprograms. The vector types are + -- then private, and non-limited since assignments are allowed. + + -- The Hard/Soft binding type-structure differentiation is achieved in + -- Low_Level_Vectors. Each version only exposes private vector types, that + -- we just sub-type here. This is fine from the design standpoint and + -- reduces the amount of explicit conversion required in various places + -- internally. + + subtype vector_unsigned_char is Low_Level_Vectors.LL_VUC; + subtype vector_signed_char is Low_Level_Vectors.LL_VSC; + subtype vector_bool_char is Low_Level_Vectors.LL_VBC; + + subtype vector_unsigned_short is Low_Level_Vectors.LL_VUS; + subtype vector_signed_short is Low_Level_Vectors.LL_VSS; + subtype vector_bool_short is Low_Level_Vectors.LL_VBS; + + subtype vector_unsigned_int is Low_Level_Vectors.LL_VUI; + subtype vector_signed_int is Low_Level_Vectors.LL_VSI; + subtype vector_bool_int is Low_Level_Vectors.LL_VBI; + + subtype vector_float is Low_Level_Vectors.LL_VF; + subtype vector_pixel is Low_Level_Vectors.LL_VP; + + -- [PIM-2.1] shows groups of declarations with exact same component types, + -- e.g. vector unsigned short together with vector unsigned short int. It + -- so appears tempting to define subtypes for those matches here. + -- + -- [PIM-2.1] does not qualify items in those groups as "the same types", + -- though, and [PIM-2.4.2 Assignments] reads: "if either the left hand + -- side or the right hand side of an expression has a vector type, then + -- both sides of the expression must be of the same vector type". + -- + -- Not so clear what is exactly right, then. We go with subtypes for now + -- and can adjust later if need be. + + subtype vector_unsigned_short_int is vector_unsigned_short; + subtype vector_signed_short_int is vector_signed_short; + + subtype vector_char is vector_signed_char; + subtype vector_short is vector_signed_short; + subtype vector_int is vector_signed_int; + + -------------------------------- + -- Corresponding access types -- + -------------------------------- + + type vector_unsigned_char_ptr is access all vector_unsigned_char; + type vector_signed_char_ptr is access all vector_signed_char; + type vector_bool_char_ptr is access all vector_bool_char; + + type vector_unsigned_short_ptr is access all vector_unsigned_short; + type vector_signed_short_ptr is access all vector_signed_short; + type vector_bool_short_ptr is access all vector_bool_short; + + type vector_unsigned_int_ptr is access all vector_unsigned_int; + type vector_signed_int_ptr is access all vector_signed_int; + type vector_bool_int_ptr is access all vector_bool_int; + + type vector_float_ptr is access all vector_float; + type vector_pixel_ptr is access all vector_pixel; + + -------------------------------------------------------------------- + -- Additional access types, for the sake of some argument passing -- + -------------------------------------------------------------------- + + -- ... because some of the operations expect pointers to possibly + -- constant objects. + + type const_vector_bool_char_ptr is access constant vector_bool_char; + type const_vector_signed_char_ptr is access constant vector_signed_char; + type const_vector_unsigned_char_ptr is access constant vector_unsigned_char; + + type const_vector_bool_short_ptr is access constant vector_bool_short; + type const_vector_signed_short_ptr is access constant vector_signed_short; + type const_vector_unsigned_short_ptr is access + constant vector_unsigned_short; + + type const_vector_bool_int_ptr is access constant vector_bool_int; + type const_vector_signed_int_ptr is access constant vector_signed_int; + type const_vector_unsigned_int_ptr is access constant vector_unsigned_int; + + type const_vector_float_ptr is access constant vector_float; + type const_vector_pixel_ptr is access constant vector_pixel; + + ---------------------- + -- Useful shortcuts -- + ---------------------- + + subtype VUC is vector_unsigned_char; + subtype VSC is vector_signed_char; + subtype VBC is vector_bool_char; + + subtype VUS is vector_unsigned_short; + subtype VSS is vector_signed_short; + subtype VBS is vector_bool_short; + + subtype VUI is vector_unsigned_int; + subtype VSI is vector_signed_int; + subtype VBI is vector_bool_int; + + subtype VP is vector_pixel; + subtype VF is vector_float; + +end GNAT.Altivec.Vector_Types; diff --git a/gcc/ada/libgnat/g-alvevi.ads b/gcc/ada/libgnat/g-alvevi.ads new file mode 100644 index 0000000..35a25a7 --- /dev/null +++ b/gcc/ada/libgnat/g-alvevi.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A L T I V E C . V E C T O R _ V I E W S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides public 'View' data types from/to which private vector +-- representations can be converted via Altivec.Conversions. This allows +-- convenient access to individual vector elements and provides a simple way +-- to initialize vector objects. + +-- Accessing vector contents with direct memory overlays should be avoided +-- because actual vector representations may vary across configurations, for +-- instance to accommodate different target endianness. + +-- The natural representation of a vector is an array indexed by vector +-- component number, which is materialized by the Varray type definitions +-- below. The 16byte alignment constraint is unfortunately sometimes not +-- properly honored for constant array aggregates, so the View types are +-- actually records enclosing such arrays. + +package GNAT.Altivec.Vector_Views is + + --------------------- + -- char components -- + --------------------- + + type Vchar_Range is range 1 .. 16; + + type Varray_unsigned_char is array (Vchar_Range) of unsigned_char; + for Varray_unsigned_char'Alignment use VECTOR_ALIGNMENT; + + type VUC_View is record + Values : Varray_unsigned_char; + end record; + + type Varray_signed_char is array (Vchar_Range) of signed_char; + for Varray_signed_char'Alignment use VECTOR_ALIGNMENT; + + type VSC_View is record + Values : Varray_signed_char; + end record; + + type Varray_bool_char is array (Vchar_Range) of bool_char; + for Varray_bool_char'Alignment use VECTOR_ALIGNMENT; + + type VBC_View is record + Values : Varray_bool_char; + end record; + + ---------------------- + -- short components -- + ---------------------- + + type Vshort_Range is range 1 .. 8; + + type Varray_unsigned_short is array (Vshort_Range) of unsigned_short; + for Varray_unsigned_short'Alignment use VECTOR_ALIGNMENT; + + type VUS_View is record + Values : Varray_unsigned_short; + end record; + + type Varray_signed_short is array (Vshort_Range) of signed_short; + for Varray_signed_short'Alignment use VECTOR_ALIGNMENT; + + type VSS_View is record + Values : Varray_signed_short; + end record; + + type Varray_bool_short is array (Vshort_Range) of bool_short; + for Varray_bool_short'Alignment use VECTOR_ALIGNMENT; + + type VBS_View is record + Values : Varray_bool_short; + end record; + + -------------------- + -- int components -- + -------------------- + + type Vint_Range is range 1 .. 4; + + type Varray_unsigned_int is array (Vint_Range) of unsigned_int; + for Varray_unsigned_int'Alignment use VECTOR_ALIGNMENT; + + type VUI_View is record + Values : Varray_unsigned_int; + end record; + + type Varray_signed_int is array (Vint_Range) of signed_int; + for Varray_signed_int'Alignment use VECTOR_ALIGNMENT; + + type VSI_View is record + Values : Varray_signed_int; + end record; + + type Varray_bool_int is array (Vint_Range) of bool_int; + for Varray_bool_int'Alignment use VECTOR_ALIGNMENT; + + type VBI_View is record + Values : Varray_bool_int; + end record; + + ---------------------- + -- float components -- + ---------------------- + + type Vfloat_Range is range 1 .. 4; + + type Varray_float is array (Vfloat_Range) of C_float; + for Varray_float'Alignment use VECTOR_ALIGNMENT; + + type VF_View is record + Values : Varray_float; + end record; + + ---------------------- + -- pixel components -- + ---------------------- + + type Vpixel_Range is range 1 .. 8; + + type Varray_pixel is array (Vpixel_Range) of pixel; + for Varray_pixel'Alignment use VECTOR_ALIGNMENT; + + type VP_View is record + Values : Varray_pixel; + end record; + +end GNAT.Altivec.Vector_Views; diff --git a/gcc/ada/libgnat/g-arrspl.adb b/gcc/ada/libgnat/g-arrspl.adb new file mode 100644 index 0000000..4e1e90e --- /dev/null +++ b/gcc/ada/libgnat/g-arrspl.adb @@ -0,0 +1,352 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A R R A Y _ S P L I T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body GNAT.Array_Split is + + procedure Free is + new Ada.Unchecked_Deallocation (Slices_Indexes, Slices_Access); + + procedure Free is + new Ada.Unchecked_Deallocation (Separators_Indexes, Indexes_Access); + + function Count + (Source : Element_Sequence; + Pattern : Element_Set) return Natural; + -- Returns the number of occurrences of Pattern elements in Source, 0 is + -- returned if no occurrence is found in Source. + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (S : in out Slice_Set) is + begin + S.D.Ref_Counter := S.D.Ref_Counter + 1; + end Adjust; + + ------------ + -- Create -- + ------------ + + procedure Create + (S : out Slice_Set; + From : Element_Sequence; + Separators : Element_Sequence; + Mode : Separator_Mode := Single) + is + begin + Create (S, From, To_Set (Separators), Mode); + end Create; + + ------------ + -- Create -- + ------------ + + procedure Create + (S : out Slice_Set; + From : Element_Sequence; + Separators : Element_Set; + Mode : Separator_Mode := Single) + is + Result : Slice_Set; + begin + Result.D.Source := new Element_Sequence'(From); + Set (Result, Separators, Mode); + S := Result; + end Create; + + ----------- + -- Count -- + ----------- + + function Count + (Source : Element_Sequence; + Pattern : Element_Set) return Natural + is + C : Natural := 0; + begin + for K in Source'Range loop + if Is_In (Source (K), Pattern) then + C := C + 1; + end if; + end loop; + + return C; + end Count; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (S : in out Slice_Set) is + + procedure Free is + new Ada.Unchecked_Deallocation (Element_Sequence, Element_Access); + + procedure Free is + new Ada.Unchecked_Deallocation (Data, Data_Access); + + D : Data_Access := S.D; + + begin + -- Ensure call is idempotent + + S.D := null; + + if D /= null then + D.Ref_Counter := D.Ref_Counter - 1; + + if D.Ref_Counter = 0 then + Free (D.Source); + Free (D.Indexes); + Free (D.Slices); + Free (D); + end if; + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (S : in out Slice_Set) is + begin + S.D := new Data'(1, null, 0, null, null); + end Initialize; + + ---------------- + -- Separators -- + ---------------- + + function Separators + (S : Slice_Set; + Index : Slice_Number) return Slice_Separators + is + begin + if Index > S.D.N_Slice then + raise Index_Error; + + elsif Index = 0 + or else (Index = 1 and then S.D.N_Slice = 1) + then + -- Whole string, or no separator used + + return (Before => Array_End, + After => Array_End); + + elsif Index = 1 then + return (Before => Array_End, + After => S.D.Source (S.D.Slices (Index).Stop + 1)); + + elsif Index = S.D.N_Slice then + return (Before => S.D.Source (S.D.Slices (Index).Start - 1), + After => Array_End); + + else + return (Before => S.D.Source (S.D.Slices (Index).Start - 1), + After => S.D.Source (S.D.Slices (Index).Stop + 1)); + end if; + end Separators; + + ---------------- + -- Separators -- + ---------------- + + function Separators (S : Slice_Set) return Separators_Indexes is + begin + return S.D.Indexes.all; + end Separators; + + --------- + -- Set -- + --------- + + procedure Set + (S : in out Slice_Set; + Separators : Element_Sequence; + Mode : Separator_Mode := Single) + is + begin + Set (S, To_Set (Separators), Mode); + end Set; + + --------- + -- Set -- + --------- + + procedure Set + (S : in out Slice_Set; + Separators : Element_Set; + Mode : Separator_Mode := Single) + is + + procedure Copy_On_Write (S : in out Slice_Set); + -- Make a copy of S if shared with another variable + + ------------------- + -- Copy_On_Write -- + ------------------- + + procedure Copy_On_Write (S : in out Slice_Set) is + begin + if S.D.Ref_Counter > 1 then + -- First let's remove our count from the current data + + S.D.Ref_Counter := S.D.Ref_Counter - 1; + + -- Then duplicate the data + + S.D := new Data'(S.D.all); + S.D.Ref_Counter := 1; + + if S.D.Source /= null then + S.D.Source := new Element_Sequence'(S.D.Source.all); + S.D.Indexes := null; + S.D.Slices := null; + end if; + + else + -- If there is a single reference to this variable, free it now + -- as it will be redefined below. + + Free (S.D.Indexes); + Free (S.D.Slices); + end if; + end Copy_On_Write; + + Count_Sep : constant Natural := Count (S.D.Source.all, Separators); + J : Positive; + + begin + Copy_On_Write (S); + + -- Compute all separator's indexes + + S.D.Indexes := new Separators_Indexes (1 .. Count_Sep); + J := S.D.Indexes'First; + + for K in S.D.Source'Range loop + if Is_In (S.D.Source (K), Separators) then + S.D.Indexes (J) := K; + J := J + 1; + end if; + end loop; + + -- Compute slice info for fast slice access + + declare + S_Info : Slices_Indexes (1 .. Slice_Number (Count_Sep) + 1); + K : Natural := 1; + Start, Stop : Natural; + + begin + S.D.N_Slice := 0; + + Start := S.D.Source'First; + Stop := 0; + + loop + if K > Count_Sep then + + -- No more separators, last slice ends at end of source string + + Stop := S.D.Source'Last; + + else + Stop := S.D.Indexes (K) - 1; + end if; + + -- Add slice to the table + + S.D.N_Slice := S.D.N_Slice + 1; + S_Info (S.D.N_Slice) := (Start, Stop); + + exit when K > Count_Sep; + + case Mode is + when Single => + + -- In this mode just set start to character next to the + -- current separator, advance the separator index. + + Start := S.D.Indexes (K) + 1; + K := K + 1; + + when Multiple => + + -- In this mode skip separators following each other + + loop + Start := S.D.Indexes (K) + 1; + K := K + 1; + exit when K > Count_Sep + or else S.D.Indexes (K) > S.D.Indexes (K - 1) + 1; + end loop; + end case; + end loop; + + S.D.Slices := new Slices_Indexes'(S_Info (1 .. S.D.N_Slice)); + end; + end Set; + + ----------- + -- Slice -- + ----------- + + function Slice + (S : Slice_Set; + Index : Slice_Number) return Element_Sequence + is + begin + if Index = 0 then + return S.D.Source.all; + + elsif Index > S.D.N_Slice then + raise Index_Error; + + else + return + S.D.Source (S.D.Slices (Index).Start .. S.D.Slices (Index).Stop); + end if; + end Slice; + + ----------------- + -- Slice_Count -- + ----------------- + + function Slice_Count (S : Slice_Set) return Slice_Number is + begin + return S.D.N_Slice; + end Slice_Count; + +end GNAT.Array_Split; diff --git a/gcc/ada/libgnat/g-arrspl.ads b/gcc/ada/libgnat/g-arrspl.ads new file mode 100644 index 0000000..d350fac --- /dev/null +++ b/gcc/ada/libgnat/g-arrspl.ads @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A R R A Y _ S P L I T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Useful array-manipulation routines: given a set of separators, split +-- an array wherever the separators appear, and provide direct access +-- to the resulting slices. + +with Ada.Finalization; + +generic + type Element is (<>); + -- Element of the array, this must be a discrete type + + type Element_Sequence is array (Positive range <>) of Element; + -- The array which is a sequence of element + + type Element_Set is private; + -- This type represent a set of elements. This set does not define a + -- specific order of the elements. The conversion of a sequence to a + -- set and membership tests in the set is performed using the routines + -- To_Set and Is_In defined below. + + with function To_Set (Sequence : Element_Sequence) return Element_Set; + -- Returns an Element_Set given an Element_Sequence. Duplicate elements + -- can be ignored during this conversion. + + with function Is_In (Item : Element; Set : Element_Set) return Boolean; + -- Returns True if Item is found in Set, False otherwise + +package GNAT.Array_Split is + + Index_Error : exception; + -- Raised by all operations below if Index > Field_Count (S) + + type Separator_Mode is + (Single, + -- In this mode the array is cut at each element in the separator + -- set. If two separators are contiguous the result at that position + -- is an empty slice. + + Multiple + -- In this mode contiguous separators are handled as a single + -- separator and no empty slice is created. + ); + + type Slice_Set is private; + -- This type uses by-reference semantics. This is a set of slices as + -- returned by Create or Set routines below. The abstraction represents + -- a set of items. Each item is a part of the original array named a + -- Slice. It is possible to access individual slices by using the Slice + -- routine below. The first slice in the Set is at the position/index + -- 1. The total number of slices in the set is returned by Slice_Count. + + procedure Create + (S : out Slice_Set; + From : Element_Sequence; + Separators : Element_Sequence; + Mode : Separator_Mode := Single); + -- Create a cut array object. From is the source array, and Separators + -- is a sequence of Element along which to split the array. The source + -- array is sliced at separator boundaries. The separators are not + -- included as part of the resulting slices. + -- + -- Note that if From is terminated by a separator an extra empty element + -- is added to the slice set. If From only contains a separator the slice + -- set contains two empty elements. + + procedure Create + (S : out Slice_Set; + From : Element_Sequence; + Separators : Element_Set; + Mode : Separator_Mode := Single); + -- Same as above but using a Element_Set + + procedure Set + (S : in out Slice_Set; + Separators : Element_Sequence; + Mode : Separator_Mode := Single); + -- Change the set of separators. The source array will be split according + -- to this new set of separators. + + procedure Set + (S : in out Slice_Set; + Separators : Element_Set; + Mode : Separator_Mode := Single); + -- Same as above but using a Element_Set + + type Slice_Number is new Natural; + -- Type used to count number of slices + + function Slice_Count (S : Slice_Set) return Slice_Number; + pragma Inline (Slice_Count); + -- Returns the number of slices (fields) in S + + function Slice + (S : Slice_Set; + Index : Slice_Number) return Element_Sequence; + pragma Inline (Slice); + -- Returns the slice at position Index. First slice is 1. If Index is 0 + -- the whole array is returned including the separators (this is the + -- original source array). + + type Position is (Before, After); + -- Used to designate position of separator + + type Slice_Separators is array (Position) of Element; + -- Separators found before and after the slice + + Array_End : constant Element; + -- This is the separator returned for the start or the end of the array + + function Separators + (S : Slice_Set; + Index : Slice_Number) return Slice_Separators; + -- Returns the separators used to slice (front and back) the slice at + -- position Index. For slices at start and end of the original array, the + -- Array_End value is returned for the corresponding outer bound. In + -- Multiple mode only the element closest to the slice is returned. + -- if Index = 0, returns (Array_End, Array_End). + + type Separators_Indexes is array (Positive range <>) of Positive; + + function Separators (S : Slice_Set) return Separators_Indexes; + -- Returns indexes of all separators used to slice original source array S + +private + + Array_End : constant Element := Element'First; + + type Element_Access is access Element_Sequence; + + type Indexes_Access is access Separators_Indexes; + + type Slice_Info is record + Start : Positive; + Stop : Natural; + end record; + -- Starting/Ending position of a slice. This does not include separators + + type Slices_Indexes is array (Slice_Number range <>) of Slice_Info; + type Slices_Access is access Slices_Indexes; + -- All indexes for fast access to slices. In the Slice_Set we keep only + -- the original array and the indexes where each slice start and stop. + + type Data is record + Ref_Counter : Natural; -- Reference counter, by-address sem + Source : Element_Access; + N_Slice : Slice_Number := 0; -- Number of slices found + Indexes : Indexes_Access; + Slices : Slices_Access; + end record; + type Data_Access is access all Data; + + type Slice_Set is new Ada.Finalization.Controlled with record + D : Data_Access; + end record; + + procedure Initialize (S : in out Slice_Set); + procedure Adjust (S : in out Slice_Set); + procedure Finalize (S : in out Slice_Set); + +end GNAT.Array_Split; diff --git a/gcc/ada/libgnat/g-awk.adb b/gcc/ada/libgnat/g-awk.adb new file mode 100644 index 0000000..5086c02 --- /dev/null +++ b/gcc/ada/libgnat/g-awk.adb @@ -0,0 +1,1488 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A W K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; +with Ada.Text_IO; +with Ada.Strings.Unbounded; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with Ada.Unchecked_Deallocation; + +with GNAT.Directory_Operations; +with GNAT.Dynamic_Tables; +with GNAT.OS_Lib; + +package body GNAT.AWK is + + use Ada; + use Ada.Strings.Unbounded; + + ----------------------- + -- Local subprograms -- + ----------------------- + + -- The following two subprograms provide a functional interface to the + -- two special session variables, that are manipulated explicitly by + -- Finalize, but must be declared after Finalize to prevent static + -- elaboration warnings. + + function Get_Def return Session_Data_Access; + procedure Set_Cur; + + ---------------- + -- Split mode -- + ---------------- + + package Split is + + type Mode is abstract tagged null record; + -- This is the main type which is declared abstract. This type must be + -- derived for each split style. + + type Mode_Access is access Mode'Class; + + procedure Current_Line (S : Mode; Session : Session_Type) + is abstract; + -- Split current line of Session using split mode S + + ------------------------ + -- Split on separator -- + ------------------------ + + type Separator (Size : Positive) is new Mode with record + Separators : String (1 .. Size); + end record; + + procedure Current_Line + (S : Separator; + Session : Session_Type); + + --------------------- + -- Split on column -- + --------------------- + + type Column (Size : Positive) is new Mode with record + Columns : Widths_Set (1 .. Size); + end record; + + procedure Current_Line (S : Column; Session : Session_Type); + + end Split; + + procedure Free is new Unchecked_Deallocation + (Split.Mode'Class, Split.Mode_Access); + + ---------------- + -- File_Table -- + ---------------- + + type AWK_File is access String; + + package File_Table is + new Dynamic_Tables (AWK_File, Natural, 1, 5, 50); + -- List of file names associated with a Session + + procedure Free is new Unchecked_Deallocation (String, AWK_File); + + ----------------- + -- Field_Table -- + ----------------- + + type Field_Slice is record + First : Positive; + Last : Natural; + end record; + -- This is a field slice (First .. Last) in session's current line + + package Field_Table is + new Dynamic_Tables (Field_Slice, Natural, 1, 10, 100); + -- List of fields for the current line + + -------------- + -- Patterns -- + -------------- + + -- Define all patterns style: exact string, regular expression, boolean + -- function. + + package Patterns is + + type Pattern is abstract tagged null record; + -- This is the main type which is declared abstract. This type must be + -- derived for each patterns style. + + type Pattern_Access is access Pattern'Class; + + function Match + (P : Pattern; + Session : Session_Type) return Boolean + is abstract; + -- Returns True if P match for the current session and False otherwise + + procedure Release (P : in out Pattern); + -- Release memory used by the pattern structure + + -------------------------- + -- Exact string pattern -- + -------------------------- + + type String_Pattern is new Pattern with record + Str : Unbounded_String; + Rank : Count; + end record; + + function Match + (P : String_Pattern; + Session : Session_Type) return Boolean; + + -------------------------------- + -- Regular expression pattern -- + -------------------------------- + + type Pattern_Matcher_Access is access Regpat.Pattern_Matcher; + + type Regexp_Pattern is new Pattern with record + Regx : Pattern_Matcher_Access; + Rank : Count; + end record; + + function Match + (P : Regexp_Pattern; + Session : Session_Type) return Boolean; + + procedure Release (P : in out Regexp_Pattern); + + ------------------------------ + -- Boolean function pattern -- + ------------------------------ + + type Callback_Pattern is new Pattern with record + Pattern : Pattern_Callback; + end record; + + function Match + (P : Callback_Pattern; + Session : Session_Type) return Boolean; + + end Patterns; + + procedure Free is new Unchecked_Deallocation + (Patterns.Pattern'Class, Patterns.Pattern_Access); + + ------------- + -- Actions -- + ------------- + + -- Define all action style : simple call, call with matches + + package Actions is + + type Action is abstract tagged null record; + -- This is the main type which is declared abstract. This type must be + -- derived for each action style. + + type Action_Access is access Action'Class; + + procedure Call + (A : Action; + Session : Session_Type) is abstract; + -- Call action A as required + + ------------------- + -- Simple action -- + ------------------- + + type Simple_Action is new Action with record + Proc : Action_Callback; + end record; + + procedure Call + (A : Simple_Action; + Session : Session_Type); + + ------------------------- + -- Action with matches -- + ------------------------- + + type Match_Action is new Action with record + Proc : Match_Action_Callback; + end record; + + procedure Call + (A : Match_Action; + Session : Session_Type); + + end Actions; + + procedure Free is new Unchecked_Deallocation + (Actions.Action'Class, Actions.Action_Access); + + -------------------------- + -- Pattern/Action table -- + -------------------------- + + type Pattern_Action is record + Pattern : Patterns.Pattern_Access; -- If Pattern is True + Action : Actions.Action_Access; -- Action will be called + end record; + + package Pattern_Action_Table is + new Dynamic_Tables (Pattern_Action, Natural, 1, 5, 50); + + ------------------ + -- Session Data -- + ------------------ + + type Session_Data is record + Current_File : Text_IO.File_Type; + Current_Line : Unbounded_String; + Separators : Split.Mode_Access; + Files : File_Table.Instance; + File_Index : Natural := 0; + Fields : Field_Table.Instance; + Filters : Pattern_Action_Table.Instance; + NR : Natural := 0; + FNR : Natural := 0; + Matches : Regpat.Match_Array (0 .. 100); + -- Latest matches for the regexp pattern + end record; + + procedure Free is + new Unchecked_Deallocation (Session_Data, Session_Data_Access); + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Session : in out Session_Type) is + begin + -- We release the session data only if it is not the default session + + if Session.Data /= Get_Def then + -- Release separators + + Free (Session.Data.Separators); + + Free (Session.Data); + + -- Since we have closed the current session, set it to point now to + -- the default session. + + Set_Cur; + end if; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Session : in out Session_Type) is + begin + Session.Data := new Session_Data; + + -- Initialize separators + + Session.Data.Separators := + new Split.Separator'(Default_Separators'Length, Default_Separators); + + -- Initialize all tables + + File_Table.Init (Session.Data.Files); + Field_Table.Init (Session.Data.Fields); + Pattern_Action_Table.Init (Session.Data.Filters); + end Initialize; + + ----------------------- + -- Session Variables -- + ----------------------- + + Def_Session : Session_Type; + Cur_Session : Session_Type; + + ---------------------- + -- Private Services -- + ---------------------- + + function Always_True return Boolean; + -- A function that always returns True + + function Apply_Filters + (Session : Session_Type) return Boolean; + -- Apply any filters for which the Pattern is True for Session. It returns + -- True if a least one filters has been applied (i.e. associated action + -- callback has been called). + + procedure Open_Next_File + (Session : Session_Type); + pragma Inline (Open_Next_File); + -- Open next file for Session closing current file if needed. It raises + -- End_Error if there is no more file in the table. + + procedure Raise_With_Info + (E : Exceptions.Exception_Id; + Message : String; + Session : Session_Type); + pragma No_Return (Raise_With_Info); + -- Raises exception E with the message prepended with the current line + -- number and the filename if possible. + + procedure Read_Line (Session : Session_Type); + -- Read a line for the Session and set Current_Line + + procedure Split_Line (Session : Session_Type); + -- Split session's Current_Line according to the session separators and + -- set the Fields table. This procedure can be called at any time. + + ---------------------- + -- Private Packages -- + ---------------------- + + ------------- + -- Actions -- + ------------- + + package body Actions is + + ---------- + -- Call -- + ---------- + + procedure Call + (A : Simple_Action; + Session : Session_Type) + is + pragma Unreferenced (Session); + begin + A.Proc.all; + end Call; + + ---------- + -- Call -- + ---------- + + procedure Call + (A : Match_Action; + Session : Session_Type) + is + begin + A.Proc (Session.Data.Matches); + end Call; + + end Actions; + + -------------- + -- Patterns -- + -------------- + + package body Patterns is + + ----------- + -- Match -- + ----------- + + function Match + (P : String_Pattern; + Session : Session_Type) return Boolean + is + begin + return P.Str = Field (P.Rank, Session); + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (P : Regexp_Pattern; + Session : Session_Type) return Boolean + is + use type Regpat.Match_Location; + begin + Regpat.Match + (P.Regx.all, Field (P.Rank, Session), Session.Data.Matches); + return Session.Data.Matches (0) /= Regpat.No_Match; + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (P : Callback_Pattern; + Session : Session_Type) return Boolean + is + pragma Unreferenced (Session); + begin + return P.Pattern.all; + end Match; + + ------------- + -- Release -- + ------------- + + procedure Release (P : in out Pattern) is + pragma Unreferenced (P); + begin + null; + end Release; + + ------------- + -- Release -- + ------------- + + procedure Release (P : in out Regexp_Pattern) is + procedure Free is new Unchecked_Deallocation + (Regpat.Pattern_Matcher, Pattern_Matcher_Access); + begin + Free (P.Regx); + end Release; + + end Patterns; + + ----------- + -- Split -- + ----------- + + package body Split is + + use Ada.Strings; + + ------------------ + -- Current_Line -- + ------------------ + + procedure Current_Line (S : Separator; Session : Session_Type) is + Line : constant String := To_String (Session.Data.Current_Line); + Fields : Field_Table.Instance renames Session.Data.Fields; + Seps : constant Maps.Character_Set := Maps.To_Set (S.Separators); + + Start : Natural; + Stop : Natural; + + begin + -- First field start here + + Start := Line'First; + + -- Record the first field start position which is the first character + -- in the line. + + Field_Table.Increment_Last (Fields); + Fields.Table (Field_Table.Last (Fields)).First := Start; + + loop + -- Look for next separator + + Stop := Fixed.Index + (Source => Line (Start .. Line'Last), + Set => Seps); + + exit when Stop = 0; + + Fields.Table (Field_Table.Last (Fields)).Last := Stop - 1; + + -- If separators are set to the default (space and tab) we skip + -- all spaces and tabs following current field. + + if S.Separators = Default_Separators then + Start := Fixed.Index + (Line (Stop + 1 .. Line'Last), + Maps.To_Set (Default_Separators), + Outside, + Strings.Forward); + + if Start = 0 then + Start := Stop + 1; + end if; + + else + Start := Stop + 1; + end if; + + -- Record in the field table the start of this new field + + Field_Table.Increment_Last (Fields); + Fields.Table (Field_Table.Last (Fields)).First := Start; + + end loop; + + Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; + end Current_Line; + + ------------------ + -- Current_Line -- + ------------------ + + procedure Current_Line (S : Column; Session : Session_Type) is + Line : constant String := To_String (Session.Data.Current_Line); + Fields : Field_Table.Instance renames Session.Data.Fields; + Start : Positive := Line'First; + + begin + -- Record the first field start position which is the first character + -- in the line. + + for C in 1 .. S.Columns'Length loop + + Field_Table.Increment_Last (Fields); + + Fields.Table (Field_Table.Last (Fields)).First := Start; + + Start := Start + S.Columns (C); + + Fields.Table (Field_Table.Last (Fields)).Last := Start - 1; + + end loop; + + -- If there is some remaining character on the line, add them in a + -- new field. + + if Start - 1 < Line'Length then + + Field_Table.Increment_Last (Fields); + + Fields.Table (Field_Table.Last (Fields)).First := Start; + + Fields.Table (Field_Table.Last (Fields)).Last := Line'Last; + end if; + end Current_Line; + + end Split; + + -------------- + -- Add_File -- + -------------- + + procedure Add_File + (Filename : String; + Session : Session_Type) + is + Files : File_Table.Instance renames Session.Data.Files; + + begin + if OS_Lib.Is_Regular_File (Filename) then + File_Table.Increment_Last (Files); + Files.Table (File_Table.Last (Files)) := new String'(Filename); + else + Raise_With_Info + (File_Error'Identity, + "File " & Filename & " not found.", + Session); + end if; + end Add_File; + + procedure Add_File + (Filename : String) + is + + begin + Add_File (Filename, Cur_Session); + end Add_File; + + --------------- + -- Add_Files -- + --------------- + + procedure Add_Files + (Directory : String; + Filenames : String; + Number_Of_Files_Added : out Natural; + Session : Session_Type) + is + use Directory_Operations; + + Dir : Dir_Type; + Filename : String (1 .. 200); + Last : Natural; + + begin + Number_Of_Files_Added := 0; + + Open (Dir, Directory); + + loop + Read (Dir, Filename, Last); + exit when Last = 0; + + Add_File (Filename (1 .. Last), Session); + Number_Of_Files_Added := Number_Of_Files_Added + 1; + end loop; + + Close (Dir); + + exception + when others => + Raise_With_Info + (File_Error'Identity, + "Error scanning directory " & Directory + & " for files " & Filenames & '.', + Session); + end Add_Files; + + procedure Add_Files + (Directory : String; + Filenames : String; + Number_Of_Files_Added : out Natural) + is + + begin + Add_Files (Directory, Filenames, Number_Of_Files_Added, Cur_Session); + end Add_Files; + + ----------------- + -- Always_True -- + ----------------- + + function Always_True return Boolean is + begin + return True; + end Always_True; + + ------------------- + -- Apply_Filters -- + ------------------- + + function Apply_Filters + (Session : Session_Type) return Boolean + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + Results : Boolean := False; + + begin + -- Iterate through the filters table, if pattern match call action + + for F in 1 .. Pattern_Action_Table.Last (Filters) loop + if Patterns.Match (Filters.Table (F).Pattern.all, Session) then + Results := True; + Actions.Call (Filters.Table (F).Action.all, Session); + end if; + end loop; + + return Results; + end Apply_Filters; + + ----------- + -- Close -- + ----------- + + procedure Close (Session : Session_Type) is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + Files : File_Table.Instance renames Session.Data.Files; + + begin + -- Close current file if needed + + if Text_IO.Is_Open (Session.Data.Current_File) then + Text_IO.Close (Session.Data.Current_File); + end if; + + -- Release Filters table + + for F in 1 .. Pattern_Action_Table.Last (Filters) loop + Patterns.Release (Filters.Table (F).Pattern.all); + Free (Filters.Table (F).Pattern); + Free (Filters.Table (F).Action); + end loop; + + for F in 1 .. File_Table.Last (Files) loop + Free (Files.Table (F)); + end loop; + + File_Table.Set_Last (Session.Data.Files, 0); + Field_Table.Set_Last (Session.Data.Fields, 0); + Pattern_Action_Table.Set_Last (Session.Data.Filters, 0); + + Session.Data.NR := 0; + Session.Data.FNR := 0; + Session.Data.File_Index := 0; + Session.Data.Current_Line := Null_Unbounded_String; + end Close; + + --------------------- + -- Current_Session -- + --------------------- + + function Current_Session return not null access Session_Type is + begin + return Cur_Session.Self; + end Current_Session; + + --------------------- + -- Default_Session -- + --------------------- + + function Default_Session return not null access Session_Type is + begin + return Def_Session.Self; + end Default_Session; + + -------------------- + -- Discrete_Field -- + -------------------- + + function Discrete_Field + (Rank : Count; + Session : Session_Type) return Discrete + is + begin + return Discrete'Value (Field (Rank, Session)); + end Discrete_Field; + + function Discrete_Field_Current_Session + (Rank : Count) return Discrete is + function Do_It is new Discrete_Field (Discrete); + begin + return Do_It (Rank, Cur_Session); + end Discrete_Field_Current_Session; + + ----------------- + -- End_Of_Data -- + ----------------- + + function End_Of_Data + (Session : Session_Type) return Boolean + is + begin + return Session.Data.File_Index = File_Table.Last (Session.Data.Files) + and then End_Of_File (Session); + end End_Of_Data; + + function End_Of_Data + return Boolean + is + begin + return End_Of_Data (Cur_Session); + end End_Of_Data; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File + (Session : Session_Type) return Boolean + is + begin + return Text_IO.End_Of_File (Session.Data.Current_File); + end End_Of_File; + + function End_Of_File + return Boolean + is + begin + return End_Of_File (Cur_Session); + end End_Of_File; + + ----------- + -- Field -- + ----------- + + function Field + (Rank : Count; + Session : Session_Type) return String + is + Fields : Field_Table.Instance renames Session.Data.Fields; + + begin + if Rank > Number_Of_Fields (Session) then + Raise_With_Info + (Field_Error'Identity, + "Field number" & Count'Image (Rank) & " does not exist.", + Session); + + elsif Rank = 0 then + + -- Returns the whole line, this is what $0 does under Session_Type + + return To_String (Session.Data.Current_Line); + + else + return Slice (Session.Data.Current_Line, + Fields.Table (Positive (Rank)).First, + Fields.Table (Positive (Rank)).Last); + end if; + end Field; + + function Field + (Rank : Count) return String + is + begin + return Field (Rank, Cur_Session); + end Field; + + function Field + (Rank : Count; + Session : Session_Type) return Integer + is + begin + return Integer'Value (Field (Rank, Session)); + + exception + when Constraint_Error => + Raise_With_Info + (Field_Error'Identity, + "Field number" & Count'Image (Rank) + & " cannot be converted to an integer.", + Session); + end Field; + + function Field + (Rank : Count) return Integer + is + begin + return Field (Rank, Cur_Session); + end Field; + + function Field + (Rank : Count; + Session : Session_Type) return Float + is + begin + return Float'Value (Field (Rank, Session)); + + exception + when Constraint_Error => + Raise_With_Info + (Field_Error'Identity, + "Field number" & Count'Image (Rank) + & " cannot be converted to a float.", + Session); + end Field; + + function Field + (Rank : Count) return Float + is + begin + return Field (Rank, Cur_Session); + end Field; + + ---------- + -- File -- + ---------- + + function File + (Session : Session_Type) return String + is + Files : File_Table.Instance renames Session.Data.Files; + + begin + if Session.Data.File_Index = 0 then + return "??"; + else + return Files.Table (Session.Data.File_Index).all; + end if; + end File; + + function File + return String + is + begin + return File (Cur_Session); + end File; + + -------------------- + -- For_Every_Line -- + -------------------- + + procedure For_Every_Line + (Separators : String := Use_Current; + Filename : String := Use_Current; + Callbacks : Callback_Mode := None; + Session : Session_Type) + is + Quit : Boolean; + + begin + Open (Separators, Filename, Session); + + while not End_Of_Data (Session) loop + Read_Line (Session); + Split_Line (Session); + + if Callbacks in Only .. Pass_Through then + declare + Discard : Boolean; + begin + Discard := Apply_Filters (Session); + end; + end if; + + if Callbacks /= Only then + Quit := False; + Action (Quit); + exit when Quit; + end if; + end loop; + + Close (Session); + end For_Every_Line; + + procedure For_Every_Line_Current_Session + (Separators : String := Use_Current; + Filename : String := Use_Current; + Callbacks : Callback_Mode := None) + is + procedure Do_It is new For_Every_Line (Action); + begin + Do_It (Separators, Filename, Callbacks, Cur_Session); + end For_Every_Line_Current_Session; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line + (Callbacks : Callback_Mode := None; + Session : Session_Type) + is + Filter_Active : Boolean; + + begin + if not Text_IO.Is_Open (Session.Data.Current_File) then + raise File_Error; + end if; + + loop + Read_Line (Session); + Split_Line (Session); + + case Callbacks is + when None => + exit; + + when Only => + Filter_Active := Apply_Filters (Session); + exit when not Filter_Active; + + when Pass_Through => + Filter_Active := Apply_Filters (Session); + exit; + end case; + end loop; + end Get_Line; + + procedure Get_Line + (Callbacks : Callback_Mode := None) + is + begin + Get_Line (Callbacks, Cur_Session); + end Get_Line; + + ---------------------- + -- Number_Of_Fields -- + ---------------------- + + function Number_Of_Fields + (Session : Session_Type) return Count + is + begin + return Count (Field_Table.Last (Session.Data.Fields)); + end Number_Of_Fields; + + function Number_Of_Fields + return Count + is + begin + return Number_Of_Fields (Cur_Session); + end Number_Of_Fields; + + -------------------------- + -- Number_Of_File_Lines -- + -------------------------- + + function Number_Of_File_Lines + (Session : Session_Type) return Count + is + begin + return Count (Session.Data.FNR); + end Number_Of_File_Lines; + + function Number_Of_File_Lines + return Count + is + begin + return Number_Of_File_Lines (Cur_Session); + end Number_Of_File_Lines; + + --------------------- + -- Number_Of_Files -- + --------------------- + + function Number_Of_Files + (Session : Session_Type) return Natural + is + Files : File_Table.Instance renames Session.Data.Files; + begin + return File_Table.Last (Files); + end Number_Of_Files; + + function Number_Of_Files + return Natural + is + begin + return Number_Of_Files (Cur_Session); + end Number_Of_Files; + + --------------------- + -- Number_Of_Lines -- + --------------------- + + function Number_Of_Lines + (Session : Session_Type) return Count + is + begin + return Count (Session.Data.NR); + end Number_Of_Lines; + + function Number_Of_Lines + return Count + is + begin + return Number_Of_Lines (Cur_Session); + end Number_Of_Lines; + + ---------- + -- Open -- + ---------- + + procedure Open + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type) + is + begin + if Text_IO.Is_Open (Session.Data.Current_File) then + raise Session_Error; + end if; + + if Filename /= Use_Current then + File_Table.Init (Session.Data.Files); + Add_File (Filename, Session); + end if; + + if Separators /= Use_Current then + Set_Field_Separators (Separators, Session); + end if; + + Open_Next_File (Session); + + exception + when End_Error => + raise File_Error; + end Open; + + procedure Open + (Separators : String := Use_Current; + Filename : String := Use_Current) + is + begin + Open (Separators, Filename, Cur_Session); + end Open; + + -------------------- + -- Open_Next_File -- + -------------------- + + procedure Open_Next_File + (Session : Session_Type) + is + Files : File_Table.Instance renames Session.Data.Files; + + begin + if Text_IO.Is_Open (Session.Data.Current_File) then + Text_IO.Close (Session.Data.Current_File); + end if; + + Session.Data.File_Index := Session.Data.File_Index + 1; + + -- If there are no mores file in the table, raise End_Error + + if Session.Data.File_Index > File_Table.Last (Files) then + raise End_Error; + end if; + + Text_IO.Open + (File => Session.Data.Current_File, + Name => Files.Table (Session.Data.File_Index).all, + Mode => Text_IO.In_File); + end Open_Next_File; + + ----------- + -- Parse -- + ----------- + + procedure Parse + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type) + is + Filter_Active : Boolean; + pragma Unreferenced (Filter_Active); + + begin + Open (Separators, Filename, Session); + + while not End_Of_Data (Session) loop + Get_Line (None, Session); + Filter_Active := Apply_Filters (Session); + end loop; + + Close (Session); + end Parse; + + procedure Parse + (Separators : String := Use_Current; + Filename : String := Use_Current) + is + begin + Parse (Separators, Filename, Cur_Session); + end Parse; + + --------------------- + -- Raise_With_Info -- + --------------------- + + procedure Raise_With_Info + (E : Exceptions.Exception_Id; + Message : String; + Session : Session_Type) + is + function Filename return String; + -- Returns current filename and "??" if this information is not + -- available. + + function Line return String; + -- Returns current line number without the leading space + + -------------- + -- Filename -- + -------------- + + function Filename return String is + File : constant String := AWK.File (Session); + begin + if File = "" then + return "??"; + else + return File; + end if; + end Filename; + + ---------- + -- Line -- + ---------- + + function Line return String is + L : constant String := Natural'Image (Session.Data.FNR); + begin + return L (2 .. L'Last); + end Line; + + -- Start of processing for Raise_With_Info + + begin + Exceptions.Raise_Exception + (E, + '[' & Filename & ':' & Line & "] " & Message); + raise Constraint_Error; -- to please GNAT as this is a No_Return proc + end Raise_With_Info; + + --------------- + -- Read_Line -- + --------------- + + procedure Read_Line (Session : Session_Type) is + + function Read_Line return String; + -- Read a line in the current file. This implementation is recursive + -- and does not have a limitation on the line length. + + NR : Natural renames Session.Data.NR; + FNR : Natural renames Session.Data.FNR; + + --------------- + -- Read_Line -- + --------------- + + function Read_Line return String is + Buffer : String (1 .. 1_024); + Last : Natural; + + begin + Text_IO.Get_Line (Session.Data.Current_File, Buffer, Last); + + if Last = Buffer'Last then + return Buffer & Read_Line; + else + return Buffer (1 .. Last); + end if; + end Read_Line; + + -- Start of processing for Read_Line + + begin + if End_Of_File (Session) then + Open_Next_File (Session); + FNR := 0; + end if; + + Session.Data.Current_Line := To_Unbounded_String (Read_Line); + + NR := NR + 1; + FNR := FNR + 1; + end Read_Line; + + -------------- + -- Register -- + -------------- + + procedure Register + (Field : Count; + Pattern : String; + Action : Action_Callback; + Session : Session_Type) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + U_Pattern : constant Unbounded_String := To_Unbounded_String (Pattern); + + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.String_Pattern'(U_Pattern, Field), + Action => new Actions.Simple_Action'(Proc => Action)); + end Register; + + procedure Register + (Field : Count; + Pattern : String; + Action : Action_Callback) + is + begin + Register (Field, Pattern, Action, Cur_Session); + end Register; + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Action_Callback; + Session : Session_Type) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + + A_Pattern : constant Patterns.Pattern_Matcher_Access := + new Regpat.Pattern_Matcher'(Pattern); + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), + Action => new Actions.Simple_Action'(Proc => Action)); + end Register; + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Action_Callback) + is + begin + Register (Field, Pattern, Action, Cur_Session); + end Register; + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Match_Action_Callback; + Session : Session_Type) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + + A_Pattern : constant Patterns.Pattern_Matcher_Access := + new Regpat.Pattern_Matcher'(Pattern); + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.Regexp_Pattern'(A_Pattern, Field), + Action => new Actions.Match_Action'(Proc => Action)); + end Register; + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Match_Action_Callback) + is + begin + Register (Field, Pattern, Action, Cur_Session); + end Register; + + procedure Register + (Pattern : Pattern_Callback; + Action : Action_Callback; + Session : Session_Type) + is + Filters : Pattern_Action_Table.Instance renames Session.Data.Filters; + + begin + Pattern_Action_Table.Increment_Last (Filters); + + Filters.Table (Pattern_Action_Table.Last (Filters)) := + (Pattern => new Patterns.Callback_Pattern'(Pattern => Pattern), + Action => new Actions.Simple_Action'(Proc => Action)); + end Register; + + procedure Register + (Pattern : Pattern_Callback; + Action : Action_Callback) + is + begin + Register (Pattern, Action, Cur_Session); + end Register; + + procedure Register + (Action : Action_Callback; + Session : Session_Type) + is + begin + Register (Always_True'Access, Action, Session); + end Register; + + procedure Register + (Action : Action_Callback) + is + begin + Register (Action, Cur_Session); + end Register; + + ----------------- + -- Set_Current -- + ----------------- + + procedure Set_Current (Session : Session_Type) is + begin + Cur_Session.Data := Session.Data; + end Set_Current; + + -------------------------- + -- Set_Field_Separators -- + -------------------------- + + procedure Set_Field_Separators + (Separators : String := Default_Separators; + Session : Session_Type) + is + begin + Free (Session.Data.Separators); + + Session.Data.Separators := + new Split.Separator'(Separators'Length, Separators); + + -- If there is a current line read, split it according to the new + -- separators. + + if Session.Data.Current_Line /= Null_Unbounded_String then + Split_Line (Session); + end if; + end Set_Field_Separators; + + procedure Set_Field_Separators + (Separators : String := Default_Separators) + is + begin + Set_Field_Separators (Separators, Cur_Session); + end Set_Field_Separators; + + ---------------------- + -- Set_Field_Widths -- + ---------------------- + + procedure Set_Field_Widths + (Field_Widths : Widths_Set; + Session : Session_Type) + is + begin + Free (Session.Data.Separators); + + Session.Data.Separators := + new Split.Column'(Field_Widths'Length, Field_Widths); + + -- If there is a current line read, split it according to + -- the new separators. + + if Session.Data.Current_Line /= Null_Unbounded_String then + Split_Line (Session); + end if; + end Set_Field_Widths; + + procedure Set_Field_Widths + (Field_Widths : Widths_Set) + is + begin + Set_Field_Widths (Field_Widths, Cur_Session); + end Set_Field_Widths; + + ---------------- + -- Split_Line -- + ---------------- + + procedure Split_Line (Session : Session_Type) is + Fields : Field_Table.Instance renames Session.Data.Fields; + begin + Field_Table.Init (Fields); + Split.Current_Line (Session.Data.Separators.all, Session); + end Split_Line; + + ------------- + -- Get_Def -- + ------------- + + function Get_Def return Session_Data_Access is + begin + return Def_Session.Data; + end Get_Def; + + ------------- + -- Set_Cur -- + ------------- + + procedure Set_Cur is + begin + Cur_Session.Data := Def_Session.Data; + end Set_Cur; + +begin + -- We have declared two sessions but both should share the same data. + -- The current session must point to the default session as its initial + -- value. So first we release the session data then we set current + -- session data to point to default session data. + + Free (Cur_Session.Data); + Cur_Session.Data := Def_Session.Data; +end GNAT.AWK; diff --git a/gcc/ada/libgnat/g-awk.ads b/gcc/ada/libgnat/g-awk.ads new file mode 100644 index 0000000..11330b6 --- /dev/null +++ b/gcc/ada/libgnat/g-awk.ads @@ -0,0 +1,642 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . A W K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an AWK-like unit. It provides an easy interface for parsing one +-- or more files containing formatted data. The file can be viewed seen as +-- a database where each record is a line and a field is a data element in +-- this line. In this implementation an AWK record is a line. This means +-- that a record cannot span multiple lines. The operating procedure is to +-- read files line by line, with each line being presented to the user of +-- the package. The interface provides services to access specific fields +-- in the line. Thus it is possible to control actions taken on a line based +-- on values of some fields. This can be achieved directly or by registering +-- callbacks triggered on programmed conditions. +-- +-- The state of an AWK run is recorded in an object of type session. +-- The following is the procedure for using a session to control an +-- AWK run: +-- +-- 1) Specify which session is to be used. It is possible to use the +-- default session or to create a new one by declaring an object of +-- type Session_Type. For example: +-- +-- Computers : Session_Type; +-- +-- 2) Specify how to cut a line into fields. There are two modes: using +-- character fields separators or column width. This is done by using +-- Set_Fields_Separators or Set_Fields_Width. For example by: +-- +-- AWK.Set_Field_Separators (";,", Computers); +-- +-- or by using iterators' Separators parameter. +-- +-- 3) Specify which files to parse. This is done with Add_File/Add_Files +-- services, or by using the iterators' Filename parameter. For +-- example: +-- +-- AWK.Add_File ("myfile.db", Computers); +-- +-- 4) Run the AWK session using one of the provided iterators. +-- +-- Parse +-- This is the most automated iterator. You can gain control on +-- the session only by registering one or more callbacks (see +-- Register). +-- +-- Get_Line/End_Of_Data +-- This is a manual iterator to be used with a loop. You have +-- complete control on the session. You can use callbacks but +-- this is not required. +-- +-- For_Every_Line +-- This provides a mixture of manual/automated iterator action. +-- +-- Examples of these three approaches appear below +-- +-- There are many ways to use this package. The following discussion shows +-- three approaches to using this package, using the three iterator forms. +-- All examples will use the following file (computer.db): +-- +-- Pluton;Windows-NT;Pentium III +-- Mars;Linux;Pentium Pro +-- Venus;Solaris;Sparc +-- Saturn;OS/2;i486 +-- Jupiter;MacOS;PPC +-- +-- 1) Using Parse iterator +-- +-- Here the first step is to register some action associated to a pattern +-- and then to call the Parse iterator (this is the simplest way to use +-- this unit). The default session is used here. For example to output the +-- second field (the OS) of computer "Saturn". +-- +-- procedure Action is +-- begin +-- Put_Line (AWK.Field (2)); +-- end Action; +-- +-- begin +-- AWK.Register (1, "Saturn", Action'Access); +-- AWK.Parse (";", "computer.db"); +-- +-- +-- 2) Using the Get_Line/End_Of_Data iterator +-- +-- Here you have full control. For example to do the same as +-- above but using a specific session, you could write: +-- +-- Computer_File : Session_Type; +-- +-- begin +-- AWK.Set_Current (Computer_File); +-- AWK.Open (Separators => ";", +-- Filename => "computer.db"); +-- +-- -- Display Saturn OS +-- +-- while not AWK.End_Of_File loop +-- AWK.Get_Line; +-- +-- if AWK.Field (1) = "Saturn" then +-- Put_Line (AWK.Field (2)); +-- end if; +-- end loop; +-- +-- AWK.Close (Computer_File); +-- +-- +-- 3) Using For_Every_Line iterator +-- +-- In this case you use a provided iterator and you pass the procedure +-- that must be called for each record. You could code the previous +-- example could be coded as follows (using the iterator quick interface +-- but without using the current session): +-- +-- Computer_File : Session_Type; +-- +-- procedure Action (Quit : in out Boolean) is +-- begin +-- if AWK.Field (1, Computer_File) = "Saturn" then +-- Put_Line (AWK.Field (2, Computer_File)); +-- end if; +-- end Action; +-- +-- procedure Look_For_Saturn is +-- new AWK.For_Every_Line (Action); +-- +-- begin +-- Look_For_Saturn (Separators => ";", +-- Filename => "computer.db", +-- Session => Computer_File); +-- +-- Integer_Text_IO.Put +-- (Integer (AWK.NR (Session => Computer_File))); +-- Put_Line (" line(s) have been processed."); +-- +-- You can also use a regular expression for the pattern. Let us output +-- the computer name for all computer for which the OS has a character +-- O in its name. +-- +-- Regexp : String := ".*O.*"; +-- +-- Matcher : Regpat.Pattern_Matcher := Regpat.Compile (Regexp); +-- +-- procedure Action is +-- begin +-- Text_IO.Put_Line (AWK.Field (2)); +-- end Action; +-- +-- begin +-- AWK.Register (2, Matcher, Action'Unrestricted_Access); +-- AWK.Parse (";", "computer.db"); +-- + +with Ada.Finalization; +with GNAT.Regpat; + +package GNAT.AWK is + + Session_Error : exception; + -- Raised when a Session is reused but is not closed + + File_Error : exception; + -- Raised when there is a file problem (see below) + + End_Error : exception; + -- Raised when an attempt is made to read beyond the end of the last + -- file of a session. + + Field_Error : exception; + -- Raised when accessing a field value which does not exist + + Data_Error : exception; + -- Raised when it is impossible to convert a field value to a specific type + + type Count is new Natural; + + type Widths_Set is array (Positive range <>) of Positive; + -- Used to store a set of columns widths + + Default_Separators : constant String := " " & ASCII.HT; + + Use_Current : constant String := ""; + -- Value used when no separator or filename is specified in iterators + + type Session_Type is limited private; + -- This is the main exported type. A session is used to keep the state of + -- a full AWK run. The state comprises a list of files, the current file, + -- the number of line processed, the current line, the number of fields in + -- the current line... A default session is provided (see Set_Current, + -- Current_Session and Default_Session below). + + ---------------------------- + -- Package initialization -- + ---------------------------- + + -- To be thread safe it is not possible to use the default provided + -- session. Each task must used a specific session and specify it + -- explicitly for every services. + + procedure Set_Current (Session : Session_Type); + -- Set the session to be used by default. This file will be used when the + -- Session parameter in following services is not specified. + + function Current_Session return not null access Session_Type; + -- Returns the session used by default by all services. This is the + -- latest session specified by Set_Current service or the session + -- provided by default with this implementation. + + function Default_Session return not null access Session_Type; + -- Returns the default session provided by this package. Note that this is + -- the session return by Current_Session if Set_Current has not been used. + + procedure Set_Field_Separators + (Separators : String := Default_Separators; + Session : Session_Type); + procedure Set_Field_Separators + (Separators : String := Default_Separators); + -- Set the field separators. Each character in the string is a field + -- separator. When a line is read it will be split by field using the + -- separators set here. Separators can be changed at any point and in this + -- case the current line is split according to the new separators. In the + -- special case that Separators is a space and a tabulation + -- (Default_Separators), fields are separated by runs of spaces and/or + -- tabs. + + procedure Set_FS + (Separators : String := Default_Separators; + Session : Session_Type) + renames Set_Field_Separators; + procedure Set_FS + (Separators : String := Default_Separators) + renames Set_Field_Separators; + -- FS is the AWK abbreviation for above service + + procedure Set_Field_Widths + (Field_Widths : Widths_Set; + Session : Session_Type); + procedure Set_Field_Widths + (Field_Widths : Widths_Set); + -- This is another way to split a line by giving the length (in number of + -- characters) of each field in a line. Field widths can be changed at any + -- point and in this case the current line is split according to the new + -- field lengths. A line split with this method must have a length equal or + -- greater to the total of the field widths. All characters remaining on + -- the line after the latest field are added to a new automatically + -- created field. + + procedure Add_File + (Filename : String; + Session : Session_Type); + procedure Add_File + (Filename : String); + -- Add Filename to the list of file to be processed. There is no limit on + -- the number of files that can be added. Files are processed in the order + -- they have been added (i.e. the filename list is FIFO). If Filename does + -- not exist or if it is not readable, File_Error is raised. + + procedure Add_Files + (Directory : String; + Filenames : String; + Number_Of_Files_Added : out Natural; + Session : Session_Type); + procedure Add_Files + (Directory : String; + Filenames : String; + Number_Of_Files_Added : out Natural); + -- Add all files matching the regular expression Filenames in the specified + -- directory to the list of file to be processed. There is no limit on + -- the number of files that can be added. Each file is processed in + -- the same order they have been added (i.e. the filename list is FIFO). + -- The number of files (possibly 0) added is returned in + -- Number_Of_Files_Added. + + ------------------------------------- + -- Information about current state -- + ------------------------------------- + + function Number_Of_Fields + (Session : Session_Type) return Count; + function Number_Of_Fields + return Count; + pragma Inline (Number_Of_Fields); + -- Returns the number of fields in the current record. It returns 0 when + -- no file is being processed. + + function NF + (Session : Session_Type) return Count + renames Number_Of_Fields; + function NF + return Count + renames Number_Of_Fields; + -- AWK abbreviation for above service + + function Number_Of_File_Lines + (Session : Session_Type) return Count; + function Number_Of_File_Lines + return Count; + pragma Inline (Number_Of_File_Lines); + -- Returns the current line number in the processed file. It returns 0 when + -- no file is being processed. + + function FNR (Session : Session_Type) return Count + renames Number_Of_File_Lines; + function FNR return Count + renames Number_Of_File_Lines; + -- AWK abbreviation for above service + + function Number_Of_Lines + (Session : Session_Type) return Count; + function Number_Of_Lines + return Count; + pragma Inline (Number_Of_Lines); + -- Returns the number of line processed until now. This is equal to number + -- of line in each already processed file plus FNR. It returns 0 when + -- no file is being processed. + + function NR (Session : Session_Type) return Count + renames Number_Of_Lines; + function NR return Count + renames Number_Of_Lines; + -- AWK abbreviation for above service + + function Number_Of_Files + (Session : Session_Type) return Natural; + function Number_Of_Files + return Natural; + pragma Inline (Number_Of_Files); + -- Returns the number of files associated with Session. This is the total + -- number of files added with Add_File and Add_Files services. + + function File (Session : Session_Type) return String; + function File return String; + -- Returns the name of the file being processed. It returns the empty + -- string when no file is being processed. + + --------------------- + -- Field accessors -- + --------------------- + + function Field + (Rank : Count; + Session : Session_Type) return String; + function Field + (Rank : Count) return String; + -- Returns field number Rank value of the current record. If Rank = 0 it + -- returns the current record (i.e. the line as read in the file). It + -- raises Field_Error if Rank > NF or if Session is not open. + + function Field + (Rank : Count; + Session : Session_Type) return Integer; + function Field + (Rank : Count) return Integer; + -- Returns field number Rank value of the current record as an integer. It + -- raises Field_Error if Rank > NF or if Session is not open. It + -- raises Data_Error if the field value cannot be converted to an integer. + + function Field + (Rank : Count; + Session : Session_Type) return Float; + function Field + (Rank : Count) return Float; + -- Returns field number Rank value of the current record as a float. It + -- raises Field_Error if Rank > NF or if Session is not open. It + -- raises Data_Error if the field value cannot be converted to a float. + + generic + type Discrete is (<>); + function Discrete_Field + (Rank : Count; + Session : Session_Type) return Discrete; + generic + type Discrete is (<>); + function Discrete_Field_Current_Session + (Rank : Count) return Discrete; + -- Returns field number Rank value of the current record as a type + -- Discrete. It raises Field_Error if Rank > NF. It raises Data_Error if + -- the field value cannot be converted to type Discrete. + + -------------------- + -- Pattern/Action -- + -------------------- + + -- AWK defines rules like "PATTERN { ACTION }". Which means that ACTION + -- will be executed if PATTERN match. A pattern in this implementation can + -- be a simple string (match function is equality), a regular expression, + -- a function returning a boolean. An action is associated to a pattern + -- using the Register services. + -- + -- Each procedure Register will add a rule to the set of rules for the + -- session. Rules are examined in the order they have been added. + + type Pattern_Callback is access function return Boolean; + -- This is a pattern function pointer. When it returns True the associated + -- action will be called. + + type Action_Callback is access procedure; + -- A simple action pointer + + type Match_Action_Callback is + access procedure (Matches : GNAT.Regpat.Match_Array); + -- An advanced action pointer used with a regular expression pattern. It + -- returns an array of all the matches. See GNAT.Regpat for further + -- information. + + procedure Register + (Field : Count; + Pattern : String; + Action : Action_Callback; + Session : Session_Type); + procedure Register + (Field : Count; + Pattern : String; + Action : Action_Callback); + -- Register an Action associated with a Pattern. The pattern here is a + -- simple string that must match exactly the field number specified. + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Action_Callback; + Session : Session_Type); + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Action_Callback); + -- Register an Action associated with a Pattern. The pattern here is a + -- simple regular expression which must match the field number specified. + + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Match_Action_Callback; + Session : Session_Type); + procedure Register + (Field : Count; + Pattern : GNAT.Regpat.Pattern_Matcher; + Action : Match_Action_Callback); + -- Same as above but it pass the set of matches to the action + -- procedure. This is useful to analyze further why and where a regular + -- expression did match. + + procedure Register + (Pattern : Pattern_Callback; + Action : Action_Callback; + Session : Session_Type); + procedure Register + (Pattern : Pattern_Callback; + Action : Action_Callback); + -- Register an Action associated with a Pattern. The pattern here is a + -- function that must return a boolean. Action callback will be called if + -- the pattern callback returns True and nothing will happen if it is + -- False. This version is more general, the two other register services + -- trigger an action based on the value of a single field only. + + procedure Register + (Action : Action_Callback; + Session : Session_Type); + procedure Register + (Action : Action_Callback); + -- Register an Action that will be called for every line. This is + -- equivalent to a Pattern_Callback function always returning True. + + -------------------- + -- Parse iterator -- + -------------------- + + procedure Parse + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type); + procedure Parse + (Separators : String := Use_Current; + Filename : String := Use_Current); + -- Launch the iterator, it will read every line in all specified + -- session's files. Registered callbacks are then called if the associated + -- pattern match. It is possible to specify a filename and a set of + -- separators directly. This offer a quick way to parse a single + -- file. These parameters will override those specified by Set_FS and + -- Add_File. The Session will be opened and closed automatically. + -- File_Error is raised if there is no file associated with Session, or if + -- a file associated with Session is not longer readable. It raises + -- Session_Error is Session is already open. + + ----------------------------------- + -- Get_Line/End_Of_Data Iterator -- + ----------------------------------- + + type Callback_Mode is (None, Only, Pass_Through); + -- These mode are used for Get_Line/End_Of_Data and For_Every_Line + -- iterators. The associated semantic is: + -- + -- None + -- callbacks are not active. This is the default mode for + -- Get_Line/End_Of_Data and For_Every_Line iterators. + -- + -- Only + -- callbacks are active, if at least one pattern match, the associated + -- action is called and this line will not be passed to the user. In + -- the Get_Line case the next line will be read (if there is some + -- line remaining), in the For_Every_Line case Action will + -- not be called for this line. + -- + -- Pass_Through + -- callbacks are active, for patterns which match the associated + -- action is called. Then the line is passed to the user. It means + -- that Action procedure is called in the For_Every_Line case and + -- that Get_Line returns with the current line active. + -- + + procedure Open + (Separators : String := Use_Current; + Filename : String := Use_Current; + Session : Session_Type); + procedure Open + (Separators : String := Use_Current; + Filename : String := Use_Current); + -- Open the first file and initialize the unit. This must be called once + -- before using Get_Line. It is possible to specify a filename and a set of + -- separators directly. This offer a quick way to parse a single file. + -- These parameters will override those specified by Set_FS and Add_File. + -- File_Error is raised if there is no file associated with Session, or if + -- the first file associated with Session is no longer readable. It raises + -- Session_Error is Session is already open. + + procedure Get_Line + (Callbacks : Callback_Mode := None; + Session : Session_Type); + procedure Get_Line + (Callbacks : Callback_Mode := None); + -- Read a line from the current input file. If the file index is at the + -- end of the current input file (i.e. End_Of_File is True) then the + -- following file is opened. If there is no more file to be processed, + -- exception End_Error will be raised. File_Error will be raised if Open + -- has not been called. Next call to Get_Line will return the following + -- line in the file. By default the registered callbacks are not called by + -- Get_Line, this can activated by setting Callbacks (see Callback_Mode + -- description above). File_Error may be raised if a file associated with + -- Session is not readable. + -- + -- When Callbacks is not None, it is possible to exhaust all the lines + -- of all the files associated with Session. In this case, File_Error + -- is not raised. + -- + -- This procedure can be used from a subprogram called by procedure Parse + -- or by an instantiation of For_Every_Line (see below). + + function End_Of_Data + (Session : Session_Type) return Boolean; + function End_Of_Data + return Boolean; + pragma Inline (End_Of_Data); + -- Returns True if there is no more data to be processed in Session. It + -- means that the latest session's file is being processed and that + -- there is no more data to be read in this file (End_Of_File is True). + + function End_Of_File + (Session : Session_Type) return Boolean; + function End_Of_File + return Boolean; + pragma Inline (End_Of_File); + -- Returns True when there is no more data to be processed on the current + -- session's file. + + procedure Close (Session : Session_Type); + -- Release all associated data with Session. All memory allocated will + -- be freed, the current file will be closed if needed, the callbacks + -- will be unregistered. Close is convenient in reestablishing a session + -- for new use. Get_Line is no longer usable (will raise File_Error) + -- except after a successful call to Open, Parse or an instantiation + -- of For_Every_Line. + + ----------------------------- + -- For_Every_Line iterator -- + ----------------------------- + + generic + with procedure Action (Quit : in out Boolean); + procedure For_Every_Line + (Separators : String := Use_Current; + Filename : String := Use_Current; + Callbacks : Callback_Mode := None; + Session : Session_Type); + generic + with procedure Action (Quit : in out Boolean); + procedure For_Every_Line_Current_Session + (Separators : String := Use_Current; + Filename : String := Use_Current; + Callbacks : Callback_Mode := None); + -- This is another iterator. Action will be called for each new + -- record. The iterator's termination can be controlled by setting Quit + -- to True. It is by default set to False. It is possible to specify a + -- filename and a set of separators directly. This offer a quick way to + -- parse a single file. These parameters will override those specified by + -- Set_FS and Add_File. By default the registered callbacks are not called + -- by For_Every_Line, this can activated by setting Callbacks (see + -- Callback_Mode description above). The Session will be opened and + -- closed automatically. File_Error is raised if there is no file + -- associated with Session. It raises Session_Error is Session is already + -- open. + +private + type Session_Data; + type Session_Data_Access is access Session_Data; + + type Session_Type is new Ada.Finalization.Limited_Controlled with record + Data : Session_Data_Access; + Self : not null access Session_Type := Session_Type'Unchecked_Access; + end record; + + procedure Initialize (Session : in out Session_Type); + procedure Finalize (Session : in out Session_Type); + +end GNAT.AWK; diff --git a/gcc/ada/libgnat/g-binenv.adb b/gcc/ada/libgnat/g-binenv.adb new file mode 100644 index 0000000..971e9d2 --- /dev/null +++ b/gcc/ada/libgnat/g-binenv.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- G N A T . B I N D _ E N V I R O N M E N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by AdaCore. -- +-- -- +------------------------------------------------------------------------------ + +with System; + +package body GNAT.Bind_Environment is + + --------- + -- Get -- + --------- + + function Get (Key : String) return String is + use type System.Address; + + Bind_Env_Addr : System.Address; + pragma Import (C, Bind_Env_Addr, "__gl_bind_env_addr"); + -- Variable provided by init.c/s-init.ads, and initialized by + -- the binder generated file. + + Bind_Env : String (Positive); + for Bind_Env'Address use Bind_Env_Addr; + pragma Import (Ada, Bind_Env); + -- Import Bind_Env string from binder file. Note that we import + -- it here as a string with maximum boundaries. The "real" end + -- of the string is indicated by a NUL byte. + + Index, KLen, VLen : Integer; + + begin + if Bind_Env_Addr = System.Null_Address then + return ""; + end if; + + Index := Bind_Env'First; + loop + -- Index points to key length + + VLen := 0; + KLen := Character'Pos (Bind_Env (Index)); + exit when KLen = 0; + + Index := Index + KLen + 1; + + -- Index points to value length + + VLen := Character'Pos (Bind_Env (Index)); + exit when Bind_Env (Index - KLen .. Index - 1) = Key; + + Index := Index + VLen + 1; + end loop; + + return Bind_Env (Index + 1 .. Index + VLen); + end Get; + +end GNAT.Bind_Environment; diff --git a/gcc/ada/libgnat/g-binenv.ads b/gcc/ada/libgnat/g-binenv.ads new file mode 100644 index 0000000..7a3424b --- /dev/null +++ b/gcc/ada/libgnat/g-binenv.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- G N A T . B I N D _ E N V I R O N M E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by AdaCore. -- +-- -- +------------------------------------------------------------------------------ + +package GNAT.Bind_Environment is + + pragma Pure; + + function Get (Key : String) return String; + -- Return the value associated with Key at bind time, + -- or an empty string if not found. + +end GNAT.Bind_Environment; diff --git a/gcc/ada/libgnat/g-bubsor.adb b/gcc/ada/libgnat/g-bubsor.adb new file mode 100644 index 0000000..d0e4ed5 --- /dev/null +++ b/gcc/ada/libgnat/g-bubsor.adb @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Bubble_Sort is + + ---------- + -- Sort -- + ---------- + + procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function) is + Switched : Boolean; + + begin + loop + Switched := False; + + for J in 1 .. N - 1 loop + if Lt (J + 1, J) then + Xchg (J, J + 1); + Switched := True; + end if; + end loop; + + exit when not Switched; + end loop; + end Sort; + +end GNAT.Bubble_Sort; diff --git a/gcc/ada/libgnat/g-bubsor.ads b/gcc/ada/libgnat/g-bubsor.ads new file mode 100644 index 0000000..8201c41 --- /dev/null +++ b/gcc/ada/libgnat/g-bubsor.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Sort Utility (Using Bubblesort Algorithm) + +-- This package provides a bubblesort routine that works with access to +-- subprogram parameters, so that it can be used with different types with +-- shared sorting code. + +-- See also GNAT.Bubble_Sort_G and GNAT.Bubble_Sort_A. These are older +-- versions of this routine. In some cases GNAT.Bubble_Sort_G may be a +-- little faster than GNAT.Bubble_Sort, at the expense of generic code +-- duplication and a less convenient interface. The generic version also +-- has the advantage of being Pure, while this unit can only be Preelaborate. + +package GNAT.Bubble_Sort is + pragma Pure; + + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. + + type Xchg_Procedure is access procedure (Op1, Op2 : Natural); + -- A pointer to a procedure that exchanges the two data items whose + -- index values are Op1 and Op2. + + type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; + -- A pointer to a function that compares two items and returns True if + -- the item with index value Op1 is less than the item with Index value + -- Op2, and False if the Op1 item is greater than or equal to the Op2 + -- item. + + procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and calls to + -- Xchg to exchange items. The sort is stable, that is the order of + -- equal items in the input is preserved. + +end GNAT.Bubble_Sort; diff --git a/gcc/ada/libgnat/g-busora.adb b/gcc/ada/libgnat/g-busora.adb new file mode 100644 index 0000000..9833058 --- /dev/null +++ b/gcc/ada/libgnat/g-busora.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Bubble_Sort_A is + + ---------- + -- Sort -- + ---------- + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is + Switched : Boolean; + + begin + loop + Switched := False; + + for J in 1 .. N - 1 loop + if Lt (J + 1, J) then + Move (J, 0); + Move (J + 1, J); + Move (0, J + 1); + Switched := True; + end if; + end loop; + + exit when not Switched; + end loop; + end Sort; + +end GNAT.Bubble_Sort_A; diff --git a/gcc/ada/libgnat/g-busora.ads b/gcc/ada/libgnat/g-busora.ads new file mode 100644 index 0000000..cce64d9 --- /dev/null +++ b/gcc/ada/libgnat/g-busora.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Bubblesort using access to procedure parameters + +-- This package provides a bubble sort routine that works with access to +-- subprogram parameters, so that it can be used with different types with +-- shared sorting code. It is considered obsoleted by GNAT.Bubble_Sort which +-- offers a similar routine with a more convenient interface. + +package GNAT.Bubble_Sort_A is + pragma Preelaborate; + + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + type Move_Procedure is access procedure (From : Natural; To : Natural); + -- A pointer to a procedure that moves the data item with index From to + -- the data item with index To. An index value of zero is used for moves + -- from and to the single temporary location used by the sort. + + type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; + -- A pointer to a function that compares two items and returns True if + -- the item with index Op1 is less than the item with index Op2, and False + -- if the Op2 item is greater than or equal to the Op1 item. + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is not + -- stable, i.e. the order of equal elements in the input is not preserved. + +end GNAT.Bubble_Sort_A; diff --git a/gcc/ada/libgnat/g-busorg.adb b/gcc/ada/libgnat/g-busorg.adb new file mode 100644 index 0000000..f917a69 --- /dev/null +++ b/gcc/ada/libgnat/g-busorg.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Bubble_Sort_G is + + ---------- + -- Sort -- + ---------- + + procedure Sort (N : Natural) is + Switched : Boolean; + + begin + loop + Switched := False; + + for J in 1 .. N - 1 loop + if Lt (J + 1, J) then + Move (J, 0); + Move (J + 1, J); + Move (0, J + 1); + Switched := True; + end if; + end loop; + + exit when not Switched; + end loop; + end Sort; + +end GNAT.Bubble_Sort_G; diff --git a/gcc/ada/libgnat/g-busorg.ads b/gcc/ada/libgnat/g-busorg.ads new file mode 100644 index 0000000..41a2194 --- /dev/null +++ b/gcc/ada/libgnat/g-busorg.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B U B B L E _ S O R T _ G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Bubblesort generic package using formal procedures + +-- This package provides a generic bubble sort routine that can be used with +-- different types of data. + +-- See also GNAT.Bubble_Sort, a version that works with subprogram access +-- parameters, allowing code sharing. The generic version is slightly more +-- efficient but does not allow code sharing and has an interface that is +-- more awkward to use. + +-- There is also GNAT.Bubble_Sort_A, which is now considered obsolete, but +-- was an older version working with subprogram parameters. This version +-- is retained for backwards compatibility with old versions of GNAT. + +generic + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + with procedure Move (From : Natural; To : Natural); + -- A procedure that moves the data item with index value From to the data + -- item with index value To (the old value in To being lost). An index + -- value of zero is used for moves from and to a single temporary location + -- used by the sort. + + with function Lt (Op1, Op2 : Natural) return Boolean; + -- A function that compares two items and returns True if the item with + -- index Op1 is less than the item with Index Op2, and False if the Op2 + -- item is greater than or equal to the Op1 item. + +package GNAT.Bubble_Sort_G is + pragma Pure; + + procedure Sort (N : Natural); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is stable, + -- that is the order of equal elements in the input is preserved. + +end GNAT.Bubble_Sort_G; diff --git a/gcc/ada/libgnat/g-byorma.adb b/gcc/ada/libgnat/g-byorma.adb new file mode 100644 index 0000000..a1de878 --- /dev/null +++ b/gcc/ada/libgnat/g-byorma.adb @@ -0,0 +1,195 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . B Y T E _ O R D E R _ M A R K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body GNAT.Byte_Order_Mark is + + -------------- + -- Read_BOM -- + -------------- + + procedure Read_BOM + (Str : String; + Len : out Natural; + BOM : out BOM_Kind; + XML_Support : Boolean := False) + is + begin + -- Note: the order of these tests is important, because in some cases + -- one sequence is a prefix of a longer sequence, and we must test for + -- the longer sequence first + + -- UTF-32 (big-endian) + + if Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#00#) + and then Str (Str'First + 1) = Character'Val (16#00#) + and then Str (Str'First + 2) = Character'Val (16#FE#) + and then Str (Str'First + 3) = Character'Val (16#FF#) + then + Len := 4; + BOM := UTF32_BE; + + -- UTF-32 (little-endian) + + elsif Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#FF#) + and then Str (Str'First + 1) = Character'Val (16#FE#) + and then Str (Str'First + 2) = Character'Val (16#00#) + and then Str (Str'First + 3) = Character'Val (16#00#) + then + Len := 4; + BOM := UTF32_LE; + + -- UTF-16 (big-endian) + + elsif Str'Length >= 2 + and then Str (Str'First) = Character'Val (16#FE#) + and then Str (Str'First + 1) = Character'Val (16#FF#) + then + Len := 2; + BOM := UTF16_BE; + + -- UTF-16 (little-endian) + + elsif Str'Length >= 2 + and then Str (Str'First) = Character'Val (16#FF#) + and then Str (Str'First + 1) = Character'Val (16#FE#) + then + Len := 2; + BOM := UTF16_LE; + + -- UTF-8 (endian-independent) + + elsif Str'Length >= 3 + and then Str (Str'First) = Character'Val (16#EF#) + and then Str (Str'First + 1) = Character'Val (16#BB#) + and then Str (Str'First + 2) = Character'Val (16#BF#) + then + Len := 3; + BOM := UTF8_All; + + -- UCS-4 (big-endian) XML only + + elsif XML_Support + and then Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#00#) + and then Str (Str'First + 1) = Character'Val (16#00#) + and then Str (Str'First + 2) = Character'Val (16#00#) + and then Str (Str'First + 3) = Character'Val (16#3C#) + then + Len := 0; + BOM := UCS4_BE; + + -- UCS-4 (little-endian) XML case + + elsif XML_Support + and then Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#3C#) + and then Str (Str'First + 1) = Character'Val (16#00#) + and then Str (Str'First + 2) = Character'Val (16#00#) + and then Str (Str'First + 3) = Character'Val (16#00#) + then + Len := 0; + BOM := UCS4_LE; + + -- UCS-4 (unusual byte order 2143) XML case + + elsif XML_Support + and then Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#00#) + and then Str (Str'First + 1) = Character'Val (16#00#) + and then Str (Str'First + 2) = Character'Val (16#3C#) + and then Str (Str'First + 3) = Character'Val (16#00#) + then + Len := 0; + BOM := UCS4_2143; + + -- UCS-4 (unusual byte order 3412) XML case + + elsif XML_Support + and then Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#00#) + and then Str (Str'First + 1) = Character'Val (16#3C#) + and then Str (Str'First + 2) = Character'Val (16#00#) + and then Str (Str'First + 3) = Character'Val (16#00#) + then + Len := 0; + BOM := UCS4_3412; + + -- UTF-16 (big-endian) XML case + + elsif XML_Support + and then Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#00#) + and then Str (Str'First + 1) = Character'Val (16#3C#) + and then Str (Str'First + 2) = Character'Val (16#00#) + and then Str (Str'First + 3) = Character'Val (16#3F#) + then + Len := 0; + BOM := UTF16_BE; + + -- UTF-32 (little-endian) XML case + + elsif XML_Support + and then Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#3C#) + and then Str (Str'First + 1) = Character'Val (16#00#) + and then Str (Str'First + 2) = Character'Val (16#3F#) + and then Str (Str'First + 3) = Character'Val (16#00#) + then + Len := 0; + BOM := UTF16_LE; + + -- Unrecognized special encodings XML only + + elsif XML_Support + and then Str'Length >= 4 + and then Str (Str'First) = Character'Val (16#3C#) + and then Str (Str'First + 1) = Character'Val (16#3F#) + and then Str (Str'First + 2) = Character'Val (16#78#) + and then Str (Str'First + 3) = Character'Val (16#6D#) + then + -- UTF-8, ASCII, some part of ISO8859, Shift-JIS, EUC,... + + Len := 0; + BOM := Unknown; + + -- No BOM recognized + + else + Len := 0; + BOM := Unknown; + end if; + end Read_BOM; + +end GNAT.Byte_Order_Mark; diff --git a/gcc/ada/libgnat/g-byorma.ads b/gcc/ada/libgnat/g-byorma.ads new file mode 100644 index 0000000..29e0757 --- /dev/null +++ b/gcc/ada/libgnat/g-byorma.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . B Y T E _ O R D E R _ M A R K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 procedure for reading and interpreting the BOM +-- (byte order mark) used to publish the encoding method for a string (for +-- example, a UTF-8 encoded file in windows will start with the appropriate +-- BOM sequence to signal UTF-8 encoding). + +-- There are two cases + +-- Case 1. UTF encodings for Unicode files + +-- Here the convention is to have the first character of the file be a +-- non-breaking zero width space character (16#0000_FEFF#). For the UTF +-- encodings, the representation of this character can be used to uniquely +-- determine the encoding. Furthermore, the possibility of any confusion +-- with unencoded files is minimal, since for example the UTF-8 encoding +-- of this character looks like the sequence: + +-- LC_I_Diaeresis +-- Right_Angle_Quotation +-- Fraction_One_Half + +-- which is so unlikely to occur legitimately in normal use that it can +-- safely be ignored in most cases (for example, no legitimate Ada source +-- file could start with this sequence of characters). + +-- Case 2. Specialized XML encodings + +-- The XML standard defines a number of other possible encodings and also +-- defines standardized sequences for marking these encodings. This package +-- can also optionally handle these XML defined BOM sequences. These XML +-- cases depend on the first character of the XML file being < so that the +-- encoding of this character can be recognized. + +pragma Compiler_Unit_Warning; + +package GNAT.Byte_Order_Mark is + + type BOM_Kind is + (UTF8_All, -- UTF8-encoding + UTF16_LE, -- UTF16 little-endian encoding + UTF16_BE, -- UTF16 big-endian encoding + UTF32_LE, -- UTF32 little-endian encoding + UTF32_BE, -- UTF32 big-endian encoding + + -- The following cases are for XML only + + UCS4_BE, -- UCS-4, big endian machine (1234 order) + UCS4_LE, -- UCS-4, little endian machine (4321 order) + UCS4_2143, -- UCS-4, unusual byte order (2143 order) + UCS4_3412, -- UCS-4, unusual byte order (3412 order) + + -- Value returned if no BOM recognized + + Unknown); -- Unknown, assumed to be ASCII compatible + + procedure Read_BOM + (Str : String; + Len : out Natural; + BOM : out BOM_Kind; + XML_Support : Boolean := False); + -- This is the routine to read the BOM from the start of the given string + -- Str. On return BOM is set to the appropriate BOM_Kind and Len is set to + -- its length. The caller will typically skip the first Len characters in + -- the string to ignore the BOM sequence. The special XML possibilities are + -- recognized only if flag XML_Support is set to True. Note that for the + -- XML cases, Len is always set to zero on return (not to the length of the + -- relevant sequence) since in the XML cases, the sequence recognized is + -- for the first real character in the file (<) which is not to be skipped. + +end GNAT.Byte_Order_Mark; diff --git a/gcc/ada/libgnat/g-bytswa.adb b/gcc/ada/libgnat/g-bytswa.adb new file mode 100644 index 0000000..8921dfb --- /dev/null +++ b/gcc/ada/libgnat/g-bytswa.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B Y T E _ S W A P P I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a general implementation that uses GCC intrinsics to take +-- advantage of any machine-specific instructions. + +with Ada.Unchecked_Conversion; use Ada; + +with System.Byte_Swapping; use System.Byte_Swapping; + +package body GNAT.Byte_Swapping is + + -------------- + -- Swapped2 -- + -------------- + + function Swapped2 (Input : Item) return Item is + function As_U16 is new Unchecked_Conversion (Item, U16); + function As_Item is new Unchecked_Conversion (U16, Item); + pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 2, + "storage size must be 2 bytes"); + begin + return As_Item (Bswap_16 (As_U16 (Input))); + end Swapped2; + + -------------- + -- Swapped4 -- + -------------- + + function Swapped4 (Input : Item) return Item is + function As_U32 is new Unchecked_Conversion (Item, U32); + function As_Item is new Unchecked_Conversion (U32, Item); + pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 4, + "storage size must be 4 bytes"); + begin + return As_Item (Bswap_32 (As_U32 (Input))); + end Swapped4; + + -------------- + -- Swapped8 -- + -------------- + + function Swapped8 (Input : Item) return Item is + function As_U64 is new Unchecked_Conversion (Item, U64); + function As_Item is new Unchecked_Conversion (U64, Item); + pragma Compile_Time_Error (Item'Max_Size_In_Storage_Elements /= 8, + "storage size must be 8 bytes"); + begin + return As_Item (Bswap_64 (As_U64 (Input))); + end Swapped8; + + ----------- + -- Swap2 -- + ----------- + + procedure Swap2 (Location : System.Address) is + X : U16; + for X'Address use Location; + begin + X := Bswap_16 (X); + end Swap2; + + ----------- + -- Swap4 -- + ----------- + + procedure Swap4 (Location : System.Address) is + X : U32; + for X'Address use Location; + begin + X := Bswap_32 (X); + end Swap4; + + ----------- + -- Swap8 -- + ----------- + + procedure Swap8 (Location : System.Address) is + X : U64; + for X'Address use Location; + begin + X := Bswap_64 (X); + end Swap8; + +end GNAT.Byte_Swapping; diff --git a/gcc/ada/libgnat/g-bytswa.ads b/gcc/ada/libgnat/g-bytswa.ads new file mode 100644 index 0000000..d953f4f --- /dev/null +++ b/gcc/ada/libgnat/g-bytswa.ads @@ -0,0 +1,206 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . B Y T E _ S W A P P I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple routines for swapping the bytes of 16-, 32-, and 64-bit objects + +-- The generic functions should be instantiated with types that are of a size +-- in bytes corresponding to the name of the generic. For example, a 2-byte +-- integer type would be compatible with Swapped2, 4-byte integer with +-- Swapped4, and so on. Failure to do so will result in a warning when +-- compiling the instantiation; this warning should be heeded. Ignoring this +-- warning can result in unexpected results. + +-- An example of proper usage follows: + +-- declare +-- type Short_Integer is range -32768 .. 32767; +-- for Short_Integer'Size use 16; -- for confirmation + +-- X : Short_Integer := 16#7FFF#; + +-- function Swapped is new Byte_Swapping.Swapped2 (Short_Integer); + +-- begin +-- Put_Line (X'Img); +-- X := Swapped (X); +-- Put_Line (X'Img); +-- end; + +-- Note that the generic actual types need not be scalars, but must be +-- 'definite' types. They can, for example, be constrained subtypes of +-- unconstrained array types as long as the size is correct. For instance, +-- a subtype of String with length of 4 would be compatible with the +-- Swapped4 generic: + +-- declare +-- subtype String4 is String (1 .. 4); +-- function Swapped is new Byte_Swapping.Swapped4 (String4); +-- S : String4 := "ABCD"; +-- for S'Alignment use 4; +-- begin +-- Put_Line (S); +-- S := Swapped (S); +-- Put_Line (S); +-- end; + +-- Similarly, a constrained array type is also acceptable: + +-- declare +-- type Mask is array (0 .. 15) of Boolean; +-- for Mask'Alignment use 2; +-- for Mask'Component_Size use Boolean'Size; +-- X : Mask := (0 .. 7 => True, others => False); +-- function Swapped is new Byte_Swapping.Swapped2 (Mask); +-- begin +-- ... +-- X := Swapped (X); +-- ... +-- end; + +-- A properly-sized record type will also be acceptable, and so forth + +-- However, as described, a size mismatch must be avoided. In the following we +-- instantiate one of the generics with a type that is too large. The result +-- of the function call is undefined, such that assignment to an object can +-- result in garbage values. + +-- Wrong: declare +-- subtype String16 is String (1 .. 16); + +-- function Swapped is new Byte_Swapping.Swapped8 (String16); +-- -- Instantiation generates a compiler warning about +-- -- mismatched sizes + +-- S : String16; + +-- begin +-- S := "ABCDEFGHDEADBEEF"; +-- +-- Put_Line (S); +-- +-- -- the following assignment results in garbage in S after the +-- -- first 8 bytes +-- +-- S := Swapped (S); +-- +-- Put_Line (S); +-- end Wrong; + +-- When the size of the type is larger than 8 bytes, the use of the non- +-- generic procedures is an alternative because no function result is +-- involved; manipulation of the object is direct. + +-- The procedures are passed the address of an object to manipulate. They will +-- swap the first N bytes of that object corresponding to the name of the +-- procedure. For example: + +-- declare +-- S2 : String := "AB"; +-- for S2'Alignment use 2; +-- S4 : String := "ABCD"; +-- for S4'Alignment use 4; +-- S8 : String := "ABCDEFGH"; +-- for S8'Alignment use 8; + +-- begin +-- Swap2 (S2'Address); +-- Put_Line (S2); + +-- Swap4 (S4'Address); +-- Put_Line (S4); + +-- Swap8 (S8'Address); +-- Put_Line (S8); +-- end; + +-- If an object of a type larger than N is passed, the remaining bytes of the +-- object are undisturbed. For example: + +-- declare +-- subtype String16 is String (1 .. 16); + +-- S : String16; +-- for S'Alignment use 8; + +-- begin +-- S := "ABCDEFGHDEADBEEF"; +-- Put_Line (S); +-- Swap8 (S'Address); +-- Put_Line (S); +-- end; + +with System; + +package GNAT.Byte_Swapping is + pragma Pure; + + -- NB: all the routines in this package treat the application objects as + -- unsigned (modular) types of a size in bytes corresponding to the routine + -- name. For example, the generic function Swapped2 manipulates the object + -- passed to the formal parameter Input as a value of an unsigned type that + -- is 2 bytes long. Therefore clients are responsible for the compatibility + -- of application types manipulated by these routines and these modular + -- types, in terms of both size and alignment. This requirement applies to + -- the generic actual type passed to the generic formal type Item in the + -- generic functions, as well as to the type of the object implicitly + -- designated by the address passed to the non-generic procedures. Use of + -- incompatible types can result in implementation- defined effects. + + generic + type Item is limited private; + function Swapped2 (Input : Item) return Item; + -- Return the 2-byte value of Input with the bytes swapped + + generic + type Item is limited private; + function Swapped4 (Input : Item) return Item; + -- Return the 4-byte value of Input with the bytes swapped + + generic + type Item is limited private; + function Swapped8 (Input : Item) return Item; + -- Return the 8-byte value of Input with the bytes swapped + + procedure Swap2 (Location : System.Address); + -- Swap the first 2 bytes of the object starting at the address specified + -- by Location. + + procedure Swap4 (Location : System.Address); + -- Swap the first 4 bytes of the object starting at the address specified + -- by Location. + + procedure Swap8 (Location : System.Address); + -- Swap the first 8 bytes of the object starting at the address specified + -- by Location. + + pragma Inline (Swap2, Swap4, Swap8, Swapped2, Swapped4, Swapped8); + +end GNAT.Byte_Swapping; diff --git a/gcc/ada/libgnat/g-calend.adb b/gcc/ada/libgnat/g-calend.adb new file mode 100644 index 0000000..a4aad21 --- /dev/null +++ b/gcc/ada/libgnat/g-calend.adb @@ -0,0 +1,652 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C.Extensions; + +package body GNAT.Calendar is + use Ada.Calendar; + use Interfaces; + + ----------------- + -- Day_In_Year -- + ----------------- + + function Day_In_Year (Date : Time) return Day_In_Year_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Day_Secs : Day_Duration; + pragma Unreferenced (Day_Secs); + begin + Split (Date, Year, Month, Day, Day_Secs); + return Julian_Day (Year, Month, Day) - Julian_Day (Year, 1, 1) + 1; + end Day_In_Year; + + ----------------- + -- Day_Of_Week -- + ----------------- + + function Day_Of_Week (Date : Time) return Day_Name is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Day_Secs : Day_Duration; + pragma Unreferenced (Day_Secs); + begin + Split (Date, Year, Month, Day, Day_Secs); + return Day_Name'Val ((Julian_Day (Year, Month, Day)) mod 7); + end Day_Of_Week; + + ---------- + -- Hour -- + ---------- + + function Hour (Date : Time) return Hour_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + pragma Unreferenced (Year, Month, Day, Minute, Second, Sub_Second); + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Hour; + end Hour; + + ---------------- + -- Julian_Day -- + ---------------- + + -- Julian_Day is used to by Day_Of_Week and Day_In_Year. Note that this + -- implementation is not expensive. + + function Julian_Day + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number) return Integer + is + Internal_Year : Integer; + Internal_Month : Integer; + Internal_Day : Integer; + Julian_Date : Integer; + C : Integer; + Ya : Integer; + + begin + Internal_Year := Integer (Year); + Internal_Month := Integer (Month); + Internal_Day := Integer (Day); + + if Internal_Month > 2 then + Internal_Month := Internal_Month - 3; + else + Internal_Month := Internal_Month + 9; + Internal_Year := Internal_Year - 1; + end if; + + C := Internal_Year / 100; + Ya := Internal_Year - (100 * C); + + Julian_Date := (146_097 * C) / 4 + + (1_461 * Ya) / 4 + + (153 * Internal_Month + 2) / 5 + + Internal_Day + 1_721_119; + + return Julian_Date; + end Julian_Day; + + ------------ + -- Minute -- + ------------ + + function Minute (Date : Time) return Minute_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + pragma Unreferenced (Year, Month, Day, Hour, Second, Sub_Second); + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Minute; + end Minute; + + ------------ + -- Second -- + ------------ + + function Second (Date : Time) return Second_Number is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + pragma Unreferenced (Year, Month, Day, Hour, Minute, Sub_Second); + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Second; + end Second; + + ----------- + -- Split -- + ----------- + + procedure Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration) + is + Day_Secs : Day_Duration; + Secs : Natural; + + begin + Split (Date, Year, Month, Day, Day_Secs); + + Secs := (if Day_Secs = 0.0 then 0 else Natural (Day_Secs - 0.5)); + Sub_Second := Second_Duration (Day_Secs - Day_Duration (Secs)); + Hour := Hour_Number (Secs / 3_600); + Secs := Secs mod 3_600; + Minute := Minute_Number (Secs / 60); + Second := Second_Number (Secs mod 60); + end Split; + + --------------------- + -- Split_At_Locale -- + --------------------- + + procedure Split_At_Locale + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration) + is + procedure Ada_Calendar_Split + (Date : Time; + Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Day_Secs : out Day_Duration; + Hour : out Integer; + Minute : out Integer; + Second : out Integer; + Sub_Sec : out Duration; + Leap_Sec : out Boolean; + Use_TZ : Boolean; + Is_Historic : Boolean; + Time_Zone : Long_Integer); + pragma Import (Ada, Ada_Calendar_Split, "__gnat_split"); + + Ds : Day_Duration; + Le : Boolean; + + pragma Unreferenced (Ds, Le); + + begin + -- Even though the input time zone is UTC (0), the flag Use_TZ will + -- ensure that Split picks up the local time zone. + + Ada_Calendar_Split + (Date => Date, + Year => Year, + Month => Month, + Day => Day, + Day_Secs => Ds, + Hour => Hour, + Minute => Minute, + Second => Second, + Sub_Sec => Sub_Second, + Leap_Sec => Le, + Use_TZ => False, + Is_Historic => False, + Time_Zone => 0); + end Split_At_Locale; + + ---------------- + -- Sub_Second -- + ---------------- + + function Sub_Second (Date : Time) return Second_Duration is + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + pragma Unreferenced (Year, Month, Day, Hour, Minute, Second); + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + return Sub_Second; + end Sub_Second; + + ------------- + -- Time_Of -- + ------------- + + function Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0) return Time + is + Day_Secs : constant Day_Duration := + Day_Duration (Hour * 3_600) + + Day_Duration (Minute * 60) + + Day_Duration (Second) + + Sub_Second; + begin + return Time_Of (Year, Month, Day, Day_Secs); + end Time_Of; + + ----------------------- + -- Time_Of_At_Locale -- + ----------------------- + + function Time_Of_At_Locale + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0) return Time + is + function Ada_Calendar_Time_Of + (Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Day_Secs : Day_Duration; + Hour : Integer; + Minute : Integer; + Second : Integer; + Sub_Sec : Duration; + Leap_Sec : Boolean; + Use_Day_Secs : Boolean; + Use_TZ : Boolean; + Is_Historic : Boolean; + Time_Zone : Long_Integer) return Time; + pragma Import (Ada, Ada_Calendar_Time_Of, "__gnat_time_of"); + + begin + -- Even though the input time zone is UTC (0), the flag Use_TZ will + -- ensure that Split picks up the local time zone. + + return + Ada_Calendar_Time_Of + (Year => Year, + Month => Month, + Day => Day, + Day_Secs => 0.0, + Hour => Hour, + Minute => Minute, + Second => Second, + Sub_Sec => Sub_Second, + Leap_Sec => False, + Use_Day_Secs => False, + Use_TZ => False, + Is_Historic => False, + Time_Zone => 0); + end Time_Of_At_Locale; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (T : not null access timeval) return Duration is + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access C.Extensions.long_long; + usec : not null access C.long); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased C.Extensions.long_long; + usec : aliased C.long; + + begin + timeval_to_duration (T, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end To_Duration; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (D : Duration) return timeval is + + procedure duration_to_timeval + (Sec : C.Extensions.long_long; + Usec : C.long; + T : not null access timeval); + pragma Import (C, duration_to_timeval, "__gnat_duration_to_timeval"); + + Micro : constant := 10**6; + Result : aliased timeval; + sec : C.Extensions.long_long; + usec : C.long; + + begin + if D = 0.0 then + sec := 0; + usec := 0; + else + sec := C.Extensions.long_long (D - 0.5); + usec := C.long ((D - Duration (sec)) * Micro - 0.5); + end if; + + duration_to_timeval (sec, usec, Result'Access); + + return Result; + end To_Timeval; + + ------------------ + -- Week_In_Year -- + ------------------ + + function Week_In_Year (Date : Time) return Week_In_Year_Number is + Year : Year_Number; + Week : Week_In_Year_Number; + pragma Unreferenced (Year); + begin + Year_Week_In_Year (Date, Year, Week); + return Week; + end Week_In_Year; + + ----------------------- + -- Year_Week_In_Year -- + ----------------------- + + procedure Year_Week_In_Year + (Date : Time; + Year : out Year_Number; + Week : out Week_In_Year_Number) + is + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + Jan_1 : Day_Name; + Shift : Week_In_Year_Number; + Start_Week : Week_In_Year_Number; + + pragma Unreferenced (Hour, Minute, Second, Sub_Second); + + function Is_Leap (Year : Year_Number) return Boolean; + -- Return True if Year denotes a leap year. Leap centennial years are + -- properly handled. + + function Jan_1_Day_Of_Week + (Jan_1 : Day_Name; + Year : Year_Number; + Last_Year : Boolean := False; + Next_Year : Boolean := False) return Day_Name; + -- Given the weekday of January 1 in Year, determine the weekday on + -- which January 1 fell last year or will fall next year as set by + -- the two flags. This routine does not call Time_Of or Split. + + function Last_Year_Has_53_Weeks + (Jan_1 : Day_Name; + Year : Year_Number) return Boolean; + -- Given the weekday of January 1 in Year, determine whether last year + -- has 53 weeks. A False value implies that the year has 52 weeks. + + ------------- + -- Is_Leap -- + ------------- + + function Is_Leap (Year : Year_Number) return Boolean is + begin + if Year mod 400 = 0 then + return True; + elsif Year mod 100 = 0 then + return False; + else + return Year mod 4 = 0; + end if; + end Is_Leap; + + ----------------------- + -- Jan_1_Day_Of_Week -- + ----------------------- + + function Jan_1_Day_Of_Week + (Jan_1 : Day_Name; + Year : Year_Number; + Last_Year : Boolean := False; + Next_Year : Boolean := False) return Day_Name + is + Shift : Integer := 0; + + begin + if Last_Year then + Shift := (if Is_Leap (Year - 1) then -2 else -1); + elsif Next_Year then + Shift := (if Is_Leap (Year) then 2 else 1); + end if; + + return Day_Name'Val ((Day_Name'Pos (Jan_1) + Shift) mod 7); + end Jan_1_Day_Of_Week; + + ---------------------------- + -- Last_Year_Has_53_Weeks -- + ---------------------------- + + function Last_Year_Has_53_Weeks + (Jan_1 : Day_Name; + Year : Year_Number) return Boolean + is + Last_Jan_1 : constant Day_Name := + Jan_1_Day_Of_Week (Jan_1, Year, Last_Year => True); + + begin + -- These two cases are illustrated in the table below + + return + Last_Jan_1 = Thursday + or else (Last_Jan_1 = Wednesday and then Is_Leap (Year - 1)); + end Last_Year_Has_53_Weeks; + + -- Start of processing for Week_In_Year + + begin + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + + -- According to ISO 8601, the first week of year Y is the week that + -- contains the first Thursday in year Y. The following table contains + -- all possible combinations of years and weekdays along with examples. + + -- +-------+------+-------+---------+ + -- | Jan 1 | Leap | Weeks | Example | + -- +-------+------+-------+---------+ + -- | Mon | No | 52 | 2007 | + -- +-------+------+-------+---------+ + -- | Mon | Yes | 52 | 1996 | + -- +-------+------+-------+---------+ + -- | Tue | No | 52 | 2002 | + -- +-------+------+-------+---------+ + -- | Tue | Yes | 52 | 1980 | + -- +-------+------+-------+---------+ + -- | Wed | No | 52 | 2003 | + -- +-------+------#########---------+ + -- | Wed | Yes # 53 # 1992 | + -- +-------+------#-------#---------+ + -- | Thu | No # 53 # 1998 | + -- +-------+------#-------#---------+ + -- | Thu | Yes # 53 # 2004 | + -- +-------+------#########---------+ + -- | Fri | No | 52 | 1999 | + -- +-------+------+-------+---------+ + -- | Fri | Yes | 52 | 1988 | + -- +-------+------+-------+---------+ + -- | Sat | No | 52 | 1994 | + -- +-------+------+-------+---------+ + -- | Sat | Yes | 52 | 1972 | + -- +-------+------+-------+---------+ + -- | Sun | No | 52 | 1995 | + -- +-------+------+-------+---------+ + -- | Sun | Yes | 52 | 1956 | + -- +-------+------+-------+---------+ + + -- A small optimization, the input date is January 1. Note that this + -- is a key day since it determines the number of weeks and is used + -- when special casing the first week of January and the last week of + -- December. + + Jan_1 := Day_Of_Week (if Day = 1 and then Month = 1 + then Date + else (Time_Of (Year, 1, 1, 0.0))); + + -- Special cases for January + + if Month = 1 then + + -- Special case 1: January 1, 2 and 3. These three days may belong + -- to last year's last week which can be week number 52 or 53. + + -- +-----+-----+-----+=====+-----+-----+-----+ + -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 26 | 27 | 28 # 29 # 30 | 31 | 1 | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 27 | 28 | 29 # 30 # 31 | 1 | 2 | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 28 | 29 | 30 # 31 # 1 | 2 | 3 | + -- +-----+-----+-----+=====+-----+-----+-----+ + + if (Day = 1 and then Jan_1 in Friday .. Sunday) + or else + (Day = 2 and then Jan_1 in Friday .. Saturday) + or else + (Day = 3 and then Jan_1 = Friday) + then + Week := (if Last_Year_Has_53_Weeks (Jan_1, Year) then 53 else 52); + + -- January 1, 2 and 3 belong to the previous year + + Year := Year - 1; + return; + + -- Special case 2: January 1, 2, 3, 4, 5, 6 and 7 of the first week + + -- +-----+-----+-----+=====+-----+-----+-----+ + -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 1 | 2 | 3 # 4 # 5 | 6 | 7 | + -- +-----+-----+-----+=====+-----+-----+-----+ + + elsif (Day <= 4 and then Jan_1 in Monday .. Thursday) + or else + (Day = 5 and then Jan_1 in Monday .. Wednesday) + or else + (Day = 6 and then Jan_1 in Monday .. Tuesday) + or else + (Day = 7 and then Jan_1 = Monday) + then + Week := 1; + return; + end if; + + -- Month other than 1 + + -- Special case 3: December 29, 30 and 31. These days may belong to + -- next year's first week. + + -- +-----+-----+-----+=====+-----+-----+-----+ + -- | Mon | Tue | Wed # Thu # Fri | Sat | Sun | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 29 | 30 | 31 # 1 # 2 | 3 | 4 | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 30 | 31 | 1 # 2 # 3 | 4 | 5 | + -- +-----+-----+-----+-----+-----+-----+-----+ + -- | 31 | 1 | 2 # 3 # 4 | 5 | 6 | + -- +-----+-----+-----+=====+-----+-----+-----+ + + elsif Month = 12 and then Day > 28 then + declare + Next_Jan_1 : constant Day_Name := + Jan_1_Day_Of_Week (Jan_1, Year, Next_Year => True); + begin + if (Day = 29 and then Next_Jan_1 = Thursday) + or else + (Day = 30 and then Next_Jan_1 in Wednesday .. Thursday) + or else + (Day = 31 and then Next_Jan_1 in Tuesday .. Thursday) + then + Year := Year + 1; + Week := 1; + return; + end if; + end; + end if; + + -- Determine the week from which to start counting. If January 1 does + -- not belong to the first week of the input year, then the next week + -- is the first week. + + Start_Week := (if Jan_1 in Friday .. Sunday then 1 else 2); + + -- At this point all special combinations have been accounted for and + -- the proper start week has been found. Since January 1 may not fall + -- on a Monday, shift 7 - Day_Name'Pos (Jan_1). This action ensures an + -- origin which falls on Monday. + + Shift := 7 - Day_Name'Pos (Jan_1); + Week := Start_Week + (Day_In_Year (Date) - Shift - 1) / 7; + end Year_Week_In_Year; + +end GNAT.Calendar; diff --git a/gcc/ada/libgnat/g-calend.ads b/gcc/ada/libgnat/g-calend.ads new file mode 100644 index 0000000..44653b7 --- /dev/null +++ b/gcc/ada/libgnat/g-calend.ads @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package extends Ada.Calendar to handle Hour, Minute, Second, +-- Second_Duration and Day_Of_Week and Day_In_Year from Calendar.Time. +-- Second_Duration precision depends on the target clock precision. +-- +-- GNAT.Calendar provides the same kind of abstraction found in Ada.Calendar. +-- It provides Split and Time_Of to build and split a Time data. And it +-- provides accessor functions to get only one of Hour, Minute, Second, +-- Second_Duration. Other functions are to access more advanced values like +-- Day_Of_Week, Day_In_Year and Week_In_Year. + +with Ada.Calendar.Formatting; +with Interfaces.C; + +package GNAT.Calendar is + + type Day_Name is + (Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, Sunday); + pragma Ordered (Day_Name); + + subtype Hour_Number is Natural range 0 .. 23; + subtype Minute_Number is Natural range 0 .. 59; + subtype Second_Number is Natural range 0 .. 59; + subtype Second_Duration is Ada.Calendar.Day_Duration range 0.0 .. 1.0; + subtype Day_In_Year_Number is Positive range 1 .. 366; + subtype Week_In_Year_Number is Positive range 1 .. 53; + + No_Time : constant Ada.Calendar.Time; + -- A constant set to the first date that can be represented by the type + -- Time. It can be used to indicate an uninitialized date. + + function Hour (Date : Ada.Calendar.Time) return Hour_Number; + function Minute (Date : Ada.Calendar.Time) return Minute_Number; + function Second (Date : Ada.Calendar.Time) return Second_Number; + function Sub_Second (Date : Ada.Calendar.Time) return Second_Duration; + -- Hour, Minute, Second and Sub_Second returns the complete time data for + -- the Date (H:M:S.SS). See Ada.Calendar for Year, Month, Day accessors. + -- Second_Duration precision depends on the target clock precision. + + function Day_Of_Week (Date : Ada.Calendar.Time) return Day_Name; + -- Return the day name + + function Day_In_Year (Date : Ada.Calendar.Time) return Day_In_Year_Number; + -- Return the day number in the year. (1st January is day 1 and 31st + -- December is day 365 or 366 for leap year). + + procedure Split + (Date : Ada.Calendar.Time; + Year : out Ada.Calendar.Year_Number; + Month : out Ada.Calendar.Month_Number; + Day : out Ada.Calendar.Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration); + -- Split a standard Ada.Calendar.Time value in date data (Year, Month, Day) + -- and Time data (Hour, Minute, Second, Sub_Second). + + procedure Split_At_Locale + (Date : Ada.Calendar.Time; + Year : out Ada.Calendar.Year_Number; + Month : out Ada.Calendar.Month_Number; + Day : out Ada.Calendar.Day_Number; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Sub_Second : out Second_Duration); + -- Split a standard Ada.Calendar.Time value in date data (Year, Month, Day) + -- and Time data (Hour, Minute, Second, Sub_Second). This version of Split + -- utilizes the time zone and DST bias of the locale (equivalent to Clock). + -- Due to this simplified behavior, the implementation does not require + -- expensive system calls on targets such as Windows. + -- WARNING: Split_At_Locale is no longer aware of historic events and may + -- produce inaccurate results over DST changes which occurred in the past. + + function Time_Of + (Year : Ada.Calendar.Year_Number; + Month : Ada.Calendar.Month_Number; + Day : Ada.Calendar.Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0) return Ada.Calendar.Time; + -- Return an Ada.Calendar.Time data built from the date and time values + + function Time_Of_At_Locale + (Year : Ada.Calendar.Year_Number; + Month : Ada.Calendar.Month_Number; + Day : Ada.Calendar.Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration := 0.0) return Ada.Calendar.Time; + -- Return an Ada.Calendar.Time data built from the date and time values. + -- This version of Time_Of utilizes the time zone and DST bias of the + -- locale (equivalent to Clock). Due to this simplified behavior, the + -- implementation does not require expensive system calls on targets such + -- as Windows. + -- WARNING: Split_At_Locale is no longer aware of historic events and may + -- produce inaccurate results over DST changes which occurred in the past. + + function Week_In_Year (Date : Ada.Calendar.Time) return Week_In_Year_Number; + -- Return the week number as defined in ISO 8601. A week always starts on + -- a Monday and the first week of a particular year is the one containing + -- the first Thursday. A year may have 53 weeks when January 1st is a + -- Wednesday and the year is leap or January 1st is a Thursday. Note that + -- the last days of December may belong to the first week on the next year + -- and conversely, the first days of January may belong to the last week + -- of the last year. + + procedure Year_Week_In_Year + (Date : Ada.Calendar.Time; + Year : out Ada.Calendar.Year_Number; + Week : out Week_In_Year_Number); + -- Return the week number as defined in ISO 8601 along with the year in + -- which the week occurs. + + -- C timeval conversion + + -- C timeval represent a duration (used in Select for example). This + -- structure is composed of a number of seconds and a number of micro + -- seconds. The timeval structure is not exposed here because its + -- definition is target dependent. Interface to C programs is done via a + -- pointer to timeval structure. + + type timeval is private; + + function To_Duration (T : not null access timeval) return Duration; + function To_Timeval (D : Duration) return timeval; + +private + -- This is a dummy declaration that should be the largest possible timeval + -- structure of all supported targets. + + type timeval is array (1 .. 3) of Interfaces.C.long; + + function Julian_Day + (Year : Ada.Calendar.Year_Number; + Month : Ada.Calendar.Month_Number; + Day : Ada.Calendar.Day_Number) return Integer; + -- Compute Julian day number + -- + -- The code of this function is a modified version of algorithm 199 from + -- the Collected Algorithms of the ACM. The author of algorithm 199 is + -- Robert G. Tantzen. + + No_Time : constant Ada.Calendar.Time := + Ada.Calendar.Formatting.Time_Of + (Ada.Calendar.Year_Number'First, + Ada.Calendar.Month_Number'First, + Ada.Calendar.Day_Number'First, + Time_Zone => 0); + -- Use Time_Zone => 0 to be the same binary representation in any timezone + +end GNAT.Calendar; diff --git a/gcc/ada/libgnat/g-casuti.adb b/gcc/ada/libgnat/g-casuti.adb new file mode 100644 index 0000000..21df839 --- /dev/null +++ b/gcc/ada/libgnat/g-casuti.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A S E _ U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a dummy body, required because if we remove the body we have +-- bootstrap path problems (this unit used to have a body, and if we do not +-- supply a dummy body, the old incorrect body is picked up during the +-- bootstrap process. + +package body GNAT.Case_Util is +end GNAT.Case_Util; diff --git a/gcc/ada/libgnat/g-casuti.ads b/gcc/ada/libgnat/g-casuti.ads new file mode 100644 index 0000000..4477406 --- /dev/null +++ b/gcc/ada/libgnat/g-casuti.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A S E _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple casing functions + +-- This package provides simple casing functions that do not require the +-- overhead of the full casing tables found in Ada.Characters.Handling. + +-- Note: actual code is found in System.Case_Util, which is used internally +-- by the GNAT run time. Applications programs should always use this package +-- rather than using System.Case_Util directly. + +with System.Case_Util; + +package GNAT.Case_Util is + pragma Pure; + pragma Elaborate_Body; + -- The elaborate body is because we have a dummy body to deal with + -- bootstrap path problems (we used to have a real body, and now we don't + -- need it any more, but the bootstrap requires that we have a dummy body, + -- since otherwise the old body gets picked up. + + -- Note: all the following functions handle the full Latin-1 set + + function To_Upper (A : Character) return Character + renames System.Case_Util.To_Upper; + -- Converts A to upper case if it is a lower case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Upper (A : in out String) + renames System.Case_Util.To_Upper; + -- Folds all characters of string A to upper case + + function To_Lower (A : Character) return Character + renames System.Case_Util.To_Lower; + -- Converts A to lower case if it is an upper case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Lower (A : in out String) + renames System.Case_Util.To_Lower; + -- Folds all characters of string A to lower case + + procedure To_Mixed (A : in out String) + renames System.Case_Util.To_Mixed; + -- Converts A to mixed case (i.e. lower case, except for initial + -- character and any character after an underscore, which are + -- converted to upper case. + +end GNAT.Case_Util; diff --git a/gcc/ada/libgnat/g-catiio.adb b/gcc/ada/libgnat/g-catiio.adb new file mode 100644 index 0000000..6677a9b --- /dev/null +++ b/gcc/ada/libgnat/g-catiio.adb @@ -0,0 +1,1242 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R . T I M E _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; use Ada.Calendar; +with Ada.Characters.Handling; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Ada.Text_IO; + +with GNAT.Case_Util; + +package body GNAT.Calendar.Time_IO is + + type Month_Name is + (January, + February, + March, + April, + May, + June, + July, + August, + September, + October, + November, + December); + + function Month_Name_To_Number + (Str : String) return Ada.Calendar.Month_Number; + -- Converts a string that contains an abbreviated month name to a month + -- number. Constraint_Error is raised if Str is not a valid month name. + -- Comparison is case insensitive + + type Padding_Mode is (None, Zero, Space); + + type Sec_Number is mod 2 ** 64; + -- Type used to compute the number of seconds since 01/01/1970. A 32 bit + -- number will cover only a period of 136 years. This means that for date + -- past 2106 the computation is not possible. A 64 bits number should be + -- enough for a very large period of time. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Am_Pm (H : Natural) return String; + -- Return AM or PM depending on the hour H + + function Hour_12 (H : Natural) return Positive; + -- Convert a 1-24h format to a 0-12 hour format + + function Image (Str : String; Length : Natural := 0) return String; + -- Return Str capitalized and cut to length number of characters. If + -- length is 0, then no cut operation is performed. + + function Image + (N : Sec_Number; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String; + -- Return image of N. This number is eventually padded with zeros or spaces + -- depending of the length required. If length is 0 then no padding occurs. + + function Image + (N : Natural; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String; + -- As above with N provided in Integer format + + procedure Parse_ISO_8861_UTC + (Date : String; + Time : out Ada.Calendar.Time; + Success : out Boolean); + -- Subsidiary of function Value. It parses the string Date, interpreted as + -- an ISO 8861 time representation, and returns corresponding Time value. + -- Success is set to False when the string is not a supported ISO 8861 + -- date. The following regular expression defines the supported format: + -- + -- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss) + -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ] + -- + -- Trailing characters (in particular spaces) are not allowed. + -- + -- Examples: + -- + -- 2017-04-14T14:47:06 20170414T14:47:06 20170414T144706 + -- 2017-04-14T14:47:06,12 20170414T14:47:06.12 + -- 2017-04-14T19:47:06+05 20170414T09:00:06-05:47 + + ----------- + -- Am_Pm -- + ----------- + + function Am_Pm (H : Natural) return String is + begin + if H = 0 or else H > 12 then + return "PM"; + else + return "AM"; + end if; + end Am_Pm; + + ------------- + -- Hour_12 -- + ------------- + + function Hour_12 (H : Natural) return Positive is + begin + if H = 0 then + return 12; + elsif H <= 12 then + return H; + else -- H > 12 + return H - 12; + end if; + end Hour_12; + + ----------- + -- Image -- + ----------- + + function Image + (Str : String; + Length : Natural := 0) return String + is + use Ada.Characters.Handling; + Local : constant String := + To_Upper (Str (Str'First)) & + To_Lower (Str (Str'First + 1 .. Str'Last)); + begin + if Length = 0 then + return Local; + else + return Local (1 .. Length); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (N : Natural; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String + is + begin + return Image (Sec_Number (N), Padding, Length); + end Image; + + function Image + (N : Sec_Number; + Padding : Padding_Mode := Zero; + Length : Natural := 0) return String + is + function Pad_Char return String; + + -------------- + -- Pad_Char -- + -------------- + + function Pad_Char return String is + begin + case Padding is + when None => return ""; + when Zero => return "00"; + when Space => return " "; + end case; + end Pad_Char; + + -- Local Declarations + + NI : constant String := Sec_Number'Image (N); + NIP : constant String := Pad_Char & NI (2 .. NI'Last); + + -- Start of processing for Image + + begin + if Length = 0 or else Padding = None then + return NI (2 .. NI'Last); + else + return NIP (NIP'Last - Length + 1 .. NIP'Last); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image + (Date : Ada.Calendar.Time; + Picture : Picture_String) return String + is + Padding : Padding_Mode := Zero; + -- Padding is set for one directive + + Result : Unbounded_String; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + Sub_Second : Second_Duration; + + P : Positive; + + begin + -- Get current time in split format + + Split (Date, Year, Month, Day, Hour, Minute, Second, Sub_Second); + + -- Null picture string is error + + if Picture = "" then + raise Picture_Error with "null picture string"; + end if; + + -- Loop through characters of picture string, building result + + Result := Null_Unbounded_String; + P := Picture'First; + while P <= Picture'Last loop + + -- A directive has the following format "%[-_]." + + if Picture (P) = '%' then + Padding := Zero; + + if P = Picture'Last then + raise Picture_Error with "picture string ends with '%"; + end if; + + -- Check for GNU extension to change the padding + + if Picture (P + 1) = '-' then + Padding := None; + P := P + 1; + + elsif Picture (P + 1) = '_' then + Padding := Space; + P := P + 1; + end if; + + if P = Picture'Last then + raise Picture_Error with "picture string ends with '- or '_"; + end if; + + case Picture (P + 1) is + + -- Literal % + + when '%' => + Result := Result & '%'; + + -- A newline + + when 'n' => + Result := Result & ASCII.LF; + + -- A horizontal tab + + when 't' => + Result := Result & ASCII.HT; + + -- Hour (00..23) + + when 'H' => + Result := Result & Image (Hour, Padding, 2); + + -- Hour (01..12) + + when 'I' => + Result := Result & Image (Hour_12 (Hour), Padding, 2); + + -- Hour ( 0..23) + + when 'k' => + Result := Result & Image (Hour, Space, 2); + + -- Hour ( 1..12) + + when 'l' => + Result := Result & Image (Hour_12 (Hour), Space, 2); + + -- Minute (00..59) + + when 'M' => + Result := Result & Image (Minute, Padding, 2); + + -- AM/PM + + when 'p' => + Result := Result & Am_Pm (Hour); + + -- Time, 12-hour (hh:mm:ss [AP]M) + + when 'r' => + Result := Result & + Image (Hour_12 (Hour), Padding, Length => 2) & ':' & + Image (Minute, Padding, Length => 2) & ':' & + Image (Second, Padding, Length => 2) & ' ' & + Am_Pm (Hour); + + -- Seconds since 1970-01-01 00:00:00 UTC + -- (a nonstandard extension) + + when 's' => + declare + -- Compute the number of seconds using Ada.Calendar.Time + -- values rather than Julian days to account for Daylight + -- Savings Time. + + Neg : Boolean := False; + Sec : Duration := Date - Time_Of (1970, 1, 1, 0.0); + + begin + -- Avoid rounding errors and perform special processing + -- for dates earlier than the Unix Epoc. + + if Sec > 0.0 then + Sec := Sec - 0.5; + elsif Sec < 0.0 then + Neg := True; + Sec := abs (Sec + 0.5); + end if; + + -- Prepend a minus sign to the result since Sec_Number + -- cannot handle negative numbers. + + if Neg then + Result := + Result & "-" & Image (Sec_Number (Sec), None); + else + Result := Result & Image (Sec_Number (Sec), None); + end if; + end; + + -- Second (00..59) + + when 'S' => + Result := Result & Image (Second, Padding, Length => 2); + + -- Milliseconds (3 digits) + -- Microseconds (6 digits) + -- Nanoseconds (9 digits) + + when 'i' | 'e' | 'o' => + declare + Sub_Sec : constant Long_Integer := + Long_Integer (Sub_Second * 1_000_000_000); + + Img1 : constant String := Sub_Sec'Img; + Img2 : constant String := + "00000000" & Img1 (Img1'First + 1 .. Img1'Last); + Nanos : constant String := + Img2 (Img2'Last - 8 .. Img2'Last); + + begin + case Picture (P + 1) is + when 'i' => + Result := Result & + Nanos (Nanos'First .. Nanos'First + 2); + + when 'e' => + Result := Result & + Nanos (Nanos'First .. Nanos'First + 5); + + when 'o' => + Result := Result & Nanos; + + when others => + null; + end case; + end; + + -- Time, 24-hour (hh:mm:ss) + + when 'T' => + Result := Result & + Image (Hour, Padding, Length => 2) & ':' & + Image (Minute, Padding, Length => 2) & ':' & + Image (Second, Padding, Length => 2); + + -- Locale's abbreviated weekday name (Sun..Sat) + + when 'a' => + Result := Result & + Image (Day_Name'Image (Day_Of_Week (Date)), 3); + + -- Locale's full weekday name, variable length + -- (Sunday..Saturday) + + when 'A' => + Result := Result & + Image (Day_Name'Image (Day_Of_Week (Date))); + + -- Locale's abbreviated month name (Jan..Dec) + + when 'b' | 'h' => + Result := Result & + Image (Month_Name'Image (Month_Name'Val (Month - 1)), 3); + + -- Locale's full month name, variable length + -- (January..December). + + when 'B' => + Result := Result & + Image (Month_Name'Image (Month_Name'Val (Month - 1))); + + -- Locale's date and time (Sat Nov 04 12:02:33 EST 1989) + + when 'c' => + case Padding is + when Zero => + Result := Result & Image (Date, "%a %b %d %T %Y"); + when Space => + Result := Result & Image (Date, "%a %b %_d %_T %Y"); + when None => + Result := Result & Image (Date, "%a %b %-d %-T %Y"); + end case; + + -- Day of month (01..31) + + when 'd' => + Result := Result & Image (Day, Padding, 2); + + -- Date (mm/dd/yy) + + when 'D' | 'x' => + Result := Result & + Image (Month, Padding, 2) & '/' & + Image (Day, Padding, 2) & '/' & + Image (Year, Padding, 2); + + -- Day of year (001..366) + + when 'j' => + Result := Result & Image (Day_In_Year (Date), Padding, 3); + + -- Month (01..12) + + when 'm' => + Result := Result & Image (Month, Padding, 2); + + -- Week number of year with Sunday as first day of week + -- (00..53) + + when 'U' => + declare + Offset : constant Natural := + (Julian_Day (Year, 1, 1) + 1) mod 7; + + Week : constant Natural := + 1 + ((Day_In_Year (Date) - 1) + Offset) / 7; + + begin + Result := Result & Image (Week, Padding, 2); + end; + + -- Day of week (0..6) with 0 corresponding to Sunday + + when 'w' => + declare + DOW : constant Natural range 0 .. 6 := + (if Day_Of_Week (Date) = Sunday + then 0 + else Day_Name'Pos (Day_Of_Week (Date))); + begin + Result := Result & Image (DOW, Length => 1); + end; + + -- Week number of year with Monday as first day of week + -- (00..53) + + when 'W' => + Result := Result & Image (Week_In_Year (Date), Padding, 2); + + -- Last two digits of year (00..99) + + when 'y' => + declare + Y : constant Natural := Year - (Year / 100) * 100; + begin + Result := Result & Image (Y, Padding, 2); + end; + + -- Year (1970...) + + when 'Y' => + Result := Result & Image (Year, None, 4); + + when others => + raise Picture_Error with + "unknown format character in picture string"; + end case; + + -- Skip past % and format character + + P := P + 2; + + -- Character other than % is copied into the result + + else + Result := Result & Picture (P); + P := P + 1; + end if; + end loop; + + return To_String (Result); + end Image; + + -------------------------- + -- Month_Name_To_Number -- + -------------------------- + + function Month_Name_To_Number + (Str : String) return Ada.Calendar.Month_Number + is + subtype String3 is String (1 .. 3); + Abbrev_Upper_Month_Names : + constant array (Ada.Calendar.Month_Number) of String3 := + ("JAN", "FEB", "MAR", "APR", "MAY", "JUN", + "JUL", "AUG", "SEP", "OCT", "NOV", "DEC"); + -- Short version of the month names, used when parsing date strings + + S : String := Str; + + begin + GNAT.Case_Util.To_Upper (S); + + for J in Abbrev_Upper_Month_Names'Range loop + if Abbrev_Upper_Month_Names (J) = S then + return J; + end if; + end loop; + + return Abbrev_Upper_Month_Names'First; + end Month_Name_To_Number; + + ------------------------ + -- Parse_ISO_8861_UTC -- + ------------------------ + + procedure Parse_ISO_8861_UTC + (Date : String; + Time : out Ada.Calendar.Time; + Success : out Boolean) + is + Index : Positive := Date'First; + -- The current character scan index. After a call to Advance, Index + -- points to the next character. + + End_Of_Source_Reached : exception; + -- An exception used to signal that the scan pointer has reached the + -- end of the source string. + + Wrong_Syntax : exception; + -- An exception used to signal that the scan pointer has reached an + -- unexpected character in the source string. + + procedure Advance; + pragma Inline (Advance); + -- Past the current character of Date + + procedure Advance_Digits (Num_Digits : Positive); + pragma Inline (Advance_Digits); + -- Past the given number of digit characters + + function Scan_Day return Day_Number; + pragma Inline (Scan_Day); + -- Scan the two digits of a day number and return its value + + function Scan_Hour return Hour_Number; + pragma Inline (Scan_Hour); + -- Scan the two digits of an hour number and return its value + + function Scan_Minute return Minute_Number; + pragma Inline (Scan_Minute); + -- Scan the two digits of a minute number and return its value + + function Scan_Month return Month_Number; + pragma Inline (Scan_Month); + -- Scan the two digits of a month number and return its value + + function Scan_Second return Second_Number; + pragma Inline (Scan_Second); + -- Scan the two digits of a second number and return its value + + function Scan_Separator (Expected_Symbol : Character) return Boolean; + pragma Inline (Scan_Separator); + -- If the current symbol matches the Expected_Symbol then advance the + -- scanner index and return True; otherwise do nothing and return False + + procedure Scan_Separator (Required : Boolean; Separator : Character); + pragma Inline (Scan_Separator); + -- If Required then check that the current character matches Separator + -- and advance the scanner index; if not Required then do nothing. + + function Scan_Subsecond return Second_Duration; + pragma Inline (Scan_Subsecond); + -- Scan all the digits of a subsecond number and return its value + + function Scan_Year return Year_Number; + pragma Inline (Scan_Year); + -- Scan the four digits of a year number and return its value + + function Symbol return Character; + pragma Inline (Symbol); + -- Return the current character being scanned + + ------------- + -- Advance -- + ------------- + + procedure Advance is + begin + -- Signal the end of the source string. This stops a complex scan by + -- bottoming up any recursive calls till control reaches routine Scan + -- which handles the exception. Certain scanning scenarios may handle + -- this exception on their own. + + if Index > Date'Last then + raise End_Of_Source_Reached; + + -- Advance the scan pointer as long as there are characters to scan, + -- in other words, the scan pointer has not passed the end of the + -- source string. + + else + Index := Index + 1; + end if; + end Advance; + + -------------------- + -- Advance_Digits -- + -------------------- + + procedure Advance_Digits (Num_Digits : Positive) is + begin + for J in 1 .. Num_Digits loop + if Symbol not in '0' .. '9' then + raise Wrong_Syntax; + end if; + + Advance; -- past digit + end loop; + end Advance_Digits; + + -------------- + -- Scan_Day -- + -------------- + + function Scan_Day return Day_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Day_Number'Value (Date (From .. Index - 1)); + end Scan_Day; + + --------------- + -- Scan_Hour -- + --------------- + + function Scan_Hour return Hour_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Hour_Number'Value (Date (From .. Index - 1)); + end Scan_Hour; + + ----------------- + -- Scan_Minute -- + ----------------- + + function Scan_Minute return Minute_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Minute_Number'Value (Date (From .. Index - 1)); + end Scan_Minute; + + ---------------- + -- Scan_Month -- + ---------------- + + function Scan_Month return Month_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Month_Number'Value (Date (From .. Index - 1)); + end Scan_Month; + + ----------------- + -- Scan_Second -- + ----------------- + + function Scan_Second return Second_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 2); + return Second_Number'Value (Date (From .. Index - 1)); + end Scan_Second; + + -------------------- + -- Scan_Separator -- + -------------------- + + function Scan_Separator (Expected_Symbol : Character) return Boolean is + begin + if Symbol = Expected_Symbol then + Advance; + return True; + else + return False; + end if; + end Scan_Separator; + + -------------------- + -- Scan_Separator -- + -------------------- + + procedure Scan_Separator (Required : Boolean; Separator : Character) is + begin + if Required then + if Symbol /= Separator then + raise Wrong_Syntax; + end if; + + Advance; -- Past the separator + end if; + end Scan_Separator; + + -------------------- + -- Scan_Subsecond -- + -------------------- + + function Scan_Subsecond return Second_Duration is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 1); + + while Symbol in '0' .. '9' + and then Index < Date'Length + loop + Advance; + end loop; + + if Symbol not in '0' .. '9' then + raise Wrong_Syntax; + end if; + + Advance; + return Second_Duration'Value ("0." & Date (From .. Index - 1)); + end Scan_Subsecond; + + --------------- + -- Scan_Year -- + --------------- + + function Scan_Year return Year_Number is + From : constant Positive := Index; + begin + Advance_Digits (Num_Digits => 4); + return Year_Number'Value (Date (From .. Index - 1)); + end Scan_Year; + + ------------ + -- Symbol -- + ------------ + + function Symbol return Character is + begin + -- Signal the end of the source string. This stops a complex scan by + -- bottoming up any recursive calls till control reaches routine Scan + -- which handles the exception. Certain scanning scenarios may handle + -- this exception on their own. + + if Index > Date'Last then + raise End_Of_Source_Reached; + + else + return Date (Index); + end if; + end Symbol; + + -- Local variables + + Date_Separator : constant Character := '-'; + Hour_Separator : constant Character := ':'; + + Day : Day_Number; + Month : Month_Number; + Year : Year_Number; + Hour : Hour_Number := 0; + Minute : Minute_Number := 0; + Second : Second_Number := 0; + Subsec : Second_Duration := 0.0; + + Local_Hour : Hour_Number := 0; + Local_Minute : Minute_Number := 0; + Local_Sign : Character := ' '; + Local_Disp : Duration; + + Sep_Required : Boolean := False; + -- True if a separator is seen (and therefore required after it!) + + begin + -- Parse date + + Year := Scan_Year; + Sep_Required := Scan_Separator (Date_Separator); + + Month := Scan_Month; + Scan_Separator (Sep_Required, Date_Separator); + + Day := Scan_Day; + + if Index < Date'Last and then Symbol = 'T' then + Advance; + + -- Parse time + + Hour := Scan_Hour; + Sep_Required := Scan_Separator (Hour_Separator); + + Minute := Scan_Minute; + Scan_Separator (Sep_Required, Hour_Separator); + + Second := Scan_Second; + + -- [('Z' | ('.' | ',') s{s} | ('+'|'-')hh:mm)] + + if Index <= Date'Last then + + -- Suffix 'Z' just confirms that this is an UTC time. No further + -- action needed. + + if Symbol = 'Z' then + Advance; + + -- A decimal fraction shall have at least one digit, and has as + -- many digits as supported by the underlying implementation. + -- The valid decimal separators are those specified in ISO 31-0, + -- i.e. the comma [,] or full stop [.]. Of these, the comma is + -- the preferred separator of ISO-8861. + + elsif Symbol = ',' or else Symbol = '.' then + Advance; -- past decimal separator + Subsec := Scan_Subsecond; + + -- Difference between local time and UTC: It shall be expressed + -- as positive (i.e. with the leading plus sign [+]) if the local + -- time is ahead of or equal to UTC of day and as negative (i.e. + -- with the leading minus sign [-]) if it is behind UTC of day. + -- The minutes time element of the difference may only be omitted + -- if the difference between the time scales is exactly an + -- integral number of hours. + + elsif Symbol = '+' or else Symbol = '-' then + Local_Sign := Symbol; + Advance; + Local_Hour := Scan_Hour; + + -- Past ':' + + if Index < Date'Last and then Symbol = Hour_Separator then + Advance; + Local_Minute := Scan_Minute; + end if; + + -- Compute local displacement + + Local_Disp := Local_Hour * 3600.0 + Local_Minute * 60.0; + else + raise Wrong_Syntax; + end if; + end if; + end if; + + -- Sanity checks. The check on Index ensures that there are no trailing + -- characters. + + if Index /= Date'Length + 1 + or else not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + or else not Subsec'Valid + or else not Local_Hour'Valid + or else not Local_Minute'Valid + then + raise Wrong_Syntax; + end if; + + -- Compute time without local displacement + + if Local_Sign = ' ' then + Time := Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec); + + -- Compute time with positive local displacement + + elsif Local_Sign = '+' then + Time := + Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) - + Local_Disp; + + -- Compute time with negative local displacement + + elsif Local_Sign = '-' then + Time := + Time_Of (Year, Month, Day, Hour, Minute, Second, Subsec) + + Local_Disp; + end if; + + -- Notify that the input string was successfully parsed + + Success := True; + + exception + when End_Of_Source_Reached + | Wrong_Syntax + => + Success := False; + end Parse_ISO_8861_UTC; + + ----------- + -- Value -- + ----------- + + function Value (Date : String) return Ada.Calendar.Time is + D : String (1 .. 21); + D_Length : constant Natural := Date'Length; + + Year : Year_Number; + Month : Month_Number; + Day : Day_Number; + Hour : Hour_Number; + Minute : Minute_Number; + Second : Second_Number; + + procedure Extract_Date + (Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Time_Start : out Natural); + -- Try and extract a date value from string D. Time_Start is set to the + -- first character that could be the start of time data. + + procedure Extract_Time + (Index : Positive; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Check_Space : Boolean := False); + -- Try and extract a time value from string D starting from position + -- Index. Set Check_Space to True to check whether the character at + -- Index - 1 is a space. Raise Constraint_Error if the portion of D + -- corresponding to the date is not well formatted. + + ------------------ + -- Extract_Date -- + ------------------ + + procedure Extract_Date + (Year : out Year_Number; + Month : out Month_Number; + Day : out Day_Number; + Time_Start : out Natural) + is + begin + if D (3) = '-' or else D (3) = '/' then + if D_Length = 8 or else D_Length = 17 then + + -- Formats are "yy*mm*dd" or "yy*mm*dd hh:mm:ss" + + if D (6) /= D (3) then + raise Constraint_Error; + end if; + + Year := Year_Number'Value ("20" & D (1 .. 2)); + Month := Month_Number'Value (D (4 .. 5)); + Day := Day_Number'Value (D (7 .. 8)); + Time_Start := 10; + + elsif D_Length = 10 or else D_Length = 19 then + + -- Formats are "mm*dd*yyyy" or "mm*dd*yyyy hh:mm:ss" + + if D (6) /= D (3) then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (7 .. 10)); + Month := Month_Number'Value (D (1 .. 2)); + Day := Day_Number'Value (D (4 .. 5)); + Time_Start := 12; + + elsif D_Length = 11 or else D_Length = 20 then + + -- Formats are "dd*mmm*yyyy" or "dd*mmm*yyyy hh:mm:ss" + + if D (7) /= D (3) then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (8 .. 11)); + Month := Month_Name_To_Number (D (4 .. 6)); + Day := Day_Number'Value (D (1 .. 2)); + Time_Start := 13; + + else + raise Constraint_Error; + end if; + + elsif D (3) = ' ' then + if D_Length = 11 or else D_Length = 20 then + + -- Possible formats are "dd mmm yyyy", "dd mmm yyyy hh:mm:ss" + + if D (7) /= ' ' then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (8 .. 11)); + Month := Month_Name_To_Number (D (4 .. 6)); + Day := Day_Number'Value (D (1 .. 2)); + Time_Start := 13; + + else + raise Constraint_Error; + end if; + + else + if D_Length = 8 or else D_Length = 17 then + + -- Possible formats are "yyyymmdd" or "yyyymmdd hh:mm:ss" + + Year := Year_Number'Value (D (1 .. 4)); + Month := Month_Number'Value (D (5 .. 6)); + Day := Day_Number'Value (D (7 .. 8)); + Time_Start := 10; + + elsif D_Length = 10 or else D_Length = 19 then + + -- Possible formats are "yyyy*mm*dd" or "yyyy*mm*dd hh:mm:ss" + + if (D (5) /= '-' and then D (5) /= '/') + or else D (8) /= D (5) + then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (1 .. 4)); + Month := Month_Number'Value (D (6 .. 7)); + Day := Day_Number'Value (D (9 .. 10)); + Time_Start := 12; + + elsif D_Length = 11 or else D_Length = 20 then + + -- Possible formats are "yyyy*mmm*dd" + + if (D (5) /= '-' and then D (5) /= '/') + or else D (9) /= D (5) + then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (1 .. 4)); + Month := Month_Name_To_Number (D (6 .. 8)); + Day := Day_Number'Value (D (10 .. 11)); + Time_Start := 13; + + elsif D_Length = 12 or else D_Length = 21 then + + -- Formats are "mmm dd, yyyy" or "mmm dd, yyyy hh:mm:ss" + + if D (4) /= ' ' + or else D (7) /= ',' + or else D (8) /= ' ' + then + raise Constraint_Error; + end if; + + Year := Year_Number'Value (D (9 .. 12)); + Month := Month_Name_To_Number (D (1 .. 3)); + Day := Day_Number'Value (D (5 .. 6)); + Time_Start := 14; + + else + raise Constraint_Error; + end if; + end if; + end Extract_Date; + + ------------------ + -- Extract_Time -- + ------------------ + + procedure Extract_Time + (Index : Positive; + Hour : out Hour_Number; + Minute : out Minute_Number; + Second : out Second_Number; + Check_Space : Boolean := False) + is + begin + -- If no time was specified in the string (do not allow trailing + -- character either) + + if Index = D_Length + 2 then + Hour := 0; + Minute := 0; + Second := 0; + + else + -- Not enough characters left ? + + if Index /= D_Length - 7 then + raise Constraint_Error; + end if; + + if Check_Space and then D (Index - 1) /= ' ' then + raise Constraint_Error; + end if; + + if D (Index + 2) /= ':' or else D (Index + 5) /= ':' then + raise Constraint_Error; + end if; + + Hour := Hour_Number'Value (D (Index .. Index + 1)); + Minute := Minute_Number'Value (D (Index + 3 .. Index + 4)); + Second := Second_Number'Value (D (Index + 6 .. Index + 7)); + end if; + end Extract_Time; + + -- Local Declarations + + Success : Boolean; + Time_Start : Natural := 1; + Time : Ada.Calendar.Time; + + -- Start of processing for Value + + begin + -- Let's try parsing Date as a supported ISO-8861 format. If we do not + -- succeed, then retry using all the other GNAT supported formats. + + Parse_ISO_8861_UTC (Date, Time, Success); + + if Success then + return Time; + end if; + + -- Length checks + + if D_Length /= 8 + and then D_Length /= 10 + and then D_Length /= 11 + and then D_Length /= 12 + and then D_Length /= 17 + and then D_Length /= 19 + and then D_Length /= 20 + and then D_Length /= 21 + then + raise Constraint_Error; + end if; + + -- After the correct length has been determined, it is safe to create + -- a local string copy in order to avoid String'First N arithmetic. + + D (1 .. D_Length) := Date; + + if D_Length /= 8 or else D (3) /= ':' then + Extract_Date (Year, Month, Day, Time_Start); + Extract_Time (Time_Start, Hour, Minute, Second, Check_Space => True); + + else + declare + Discard : Second_Duration; + begin + Split (Clock, Year, Month, Day, Hour, Minute, Second, + Sub_Second => Discard); + end; + + Extract_Time (1, Hour, Minute, Second, Check_Space => False); + end if; + + -- Sanity checks + + if not Year'Valid + or else not Month'Valid + or else not Day'Valid + or else not Hour'Valid + or else not Minute'Valid + or else not Second'Valid + then + raise Constraint_Error; + end if; + + return Time_Of (Year, Month, Day, Hour, Minute, Second); + end Value; + + -------------- + -- Put_Time -- + -------------- + + procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String) is + begin + Ada.Text_IO.Put (Image (Date, Picture)); + end Put_Time; + +end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/libgnat/g-catiio.ads b/gcc/ada/libgnat/g-catiio.ads new file mode 100644 index 0000000..8b93518 --- /dev/null +++ b/gcc/ada/libgnat/g-catiio.ads @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C A L E N D A R . T I M E _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package augments standard Ada.Text_IO with facilities for input +-- and output of time values in standardized format. + +package GNAT.Calendar.Time_IO is + + Picture_Error : exception; + -- Exception raised for incorrect picture + + type Picture_String is new String; + -- This is a string to describe date and time output format. The string is + -- a set of standard character and special tag that are replaced by the + -- corresponding values. It follows the GNU Date specification. Here are + -- the recognized directives : + -- + -- % a literal % + -- n a newline + -- t a horizontal tab + -- + -- Time fields: + -- + -- %H hour (00..23) + -- %I hour (01..12) + -- %k hour ( 0..23) + -- %l hour ( 1..12) + -- %M minute (00..59) + -- %p locale's AM or PM + -- %r time, 12-hour (hh:mm:ss [AP]M) + -- %s seconds since 1970-01-01 00:00:00 UTC + -- (a nonstandard extension) + -- %S second (00..59) + -- %T time, 24-hour (hh:mm:ss) + -- + -- Date fields: + -- + -- %a locale's abbreviated weekday name (Sun..Sat) + -- %A locale's full weekday name, variable length + -- (Sunday..Saturday) + -- %b locale's abbreviated month name (Jan..Dec) + -- %B locale's full month name, variable length + -- (January..December) + -- %c locale's date and time (Sat Nov 04 12:02:33 EST 1989) + -- %d day of month (01..31) + -- %D date (mm/dd/yy) + -- %h same as %b + -- %j day of year (001..366) + -- %m month (01..12) + -- %U week number of year with Sunday as first day of week + -- (00..53) + -- %w day of week (0..6) with 0 corresponding to Sunday + -- %W week number of year with Monday as first day of week + -- (00..53) + -- %x locale's date representation (mm/dd/yy) + -- %y last two digits of year (00..99) + -- %Y year (1970...) + -- + -- By default, date pads numeric fields with zeroes. GNU date + -- recognizes the following nonstandard numeric modifiers: + -- + -- - (hyphen) do not pad the field + -- _ (underscore) pad the field with spaces + -- + -- Here are some GNAT extensions to the GNU Date specification: + -- + -- %i milliseconds (3 digits) + -- %e microseconds (6 digits) + -- %o nanoseconds (9 digits) + + ISO_Date : constant Picture_String; + -- This format follow the ISO 8601 standard. The format is "YYYY-MM-DD", + -- four digits year, month and day number separated by minus. + + US_Date : constant Picture_String; + -- This format is the common US date format: "MM/DD/YY", + -- month and day number, two digits year separated by slashes. + + European_Date : constant Picture_String; + -- This format is the common European date format: "DD/MM/YY", + -- day and month number, two digits year separated by slashes. + + function Image + (Date : Ada.Calendar.Time; + Picture : Picture_String) return String; + -- Return Date, as interpreted in the current local time zone, as a string + -- with format Picture. Raise Picture_Error if picture string is null or + -- has an incorrect format. + + function Value (Date : String) return Ada.Calendar.Time; + -- Parse the string Date, interpreted as a time representation in the + -- current local time zone, and return the corresponding Time value. The + -- following time format is supported: + -- + -- hh:mm:ss - Date is the current date + -- + -- The following formats are also supported. They all accept an optional + -- time with the format "hh:mm:ss". The time is separated from the date by + -- exactly one space character. + -- + -- When the time is not specified, it is set to 00:00:00. The delimiter '*' + -- must be either '-' and '/' and both occurrences must use the same + -- character. + -- + -- Trailing characters (in particular spaces) are not allowed + -- + -- yyyy*mm*dd - ISO format + -- yy*mm*dd - Year is assumed to be 20yy + -- mm*dd*yyyy - (US date format) + -- dd*mmm*yyyy - month spelled out + -- yyyy*mmm*dd - month spelled out + -- yyyymmdd - Iso format, no separator + -- mmm dd, yyyy - month spelled out + -- dd mmm yyyy - month spelled out + -- + -- The following ISO-8861 format expressed as a regular expression is also + -- supported: + -- + -- (yyyymmdd | yyyy'-'mm'-'dd)'T'(hhmmss | hh':'mm':'ss) + -- [ ('Z' | ('.' | ',') s{s} | ('+'|'-')hh':'mm) ] + -- + -- Examples: + -- + -- 2017-04-14T14:47:06 20170414T14:47:06 20170414T144706 + -- 2017-04-14T14:47:06,1234 20170414T14:47:06.1234 + -- 2017-04-14T19:47:06+05 20170414T09:00:06-05:47 + + -- Constraint_Error is raised if the input string is malformed (does not + -- conform to one of the above dates, or has an invalid time string), or + -- the resulting time is not valid. + + procedure Put_Time (Date : Ada.Calendar.Time; Picture : Picture_String); + -- Put Date with format Picture. Raise Picture_Error if bad picture string + +private + ISO_Date : constant Picture_String := "%Y-%m-%d"; + US_Date : constant Picture_String := "%m/%d/%y"; + European_Date : constant Picture_String := "%d/%m/%y"; + +end GNAT.Calendar.Time_IO; diff --git a/gcc/ada/libgnat/g-cgi.adb b/gcc/ada/libgnat/g-cgi.adb new file mode 100644 index 0000000..9d658e6 --- /dev/null +++ b/gcc/ada/libgnat/g-cgi.adb @@ -0,0 +1,494 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Text_IO; +with Ada.Strings.Fixed; +with Ada.Characters.Handling; +with Ada.Strings.Maps; + +with GNAT.OS_Lib; +with GNAT.Table; + +package body GNAT.CGI is + + use Ada; + + Valid_Environment : Boolean := True; + -- This boolean will be set to False if the initialization was not + -- completed correctly. It must be set to true there because the + -- Initialize routine (called during elaboration) will use some of the + -- services exported by this unit. + + Current_Method : Method_Type; + -- This is the current method used to pass CGI parameters + + Header_Sent : Boolean := False; + -- Will be set to True when the header will be sent + + -- Key/Value table declaration + + type String_Access is access String; + + type Key_Value is record + Key : String_Access; + Value : String_Access; + end record; + + package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); + + ----------------------- + -- Local subprograms -- + ----------------------- + + procedure Check_Environment; + pragma Inline (Check_Environment); + -- This procedure will raise Data_Error if Valid_Environment is False + + procedure Initialize; + -- Initialize CGI package by reading the runtime environment. This + -- procedure is called during elaboration. All exceptions raised during + -- this procedure are deferred. + + -------------------- + -- Argument_Count -- + -------------------- + + function Argument_Count return Natural is + begin + Check_Environment; + return Key_Value_Table.Last; + end Argument_Count; + + ----------------------- + -- Check_Environment -- + ----------------------- + + procedure Check_Environment is + begin + if not Valid_Environment then + raise Data_Error; + end if; + end Check_Environment; + + ------------ + -- Decode -- + ------------ + + function Decode (S : String) return String is + Result : String (S'Range); + K : Positive := S'First; + J : Positive := Result'First; + + begin + while K <= S'Last loop + if K + 2 <= S'Last + and then S (K) = '%' + and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 1)) + and then Characters.Handling.Is_Hexadecimal_Digit (S (K + 2)) + then + -- Here we have '%HH' which is an encoded character where 'HH' is + -- the character number in hexadecimal. + + Result (J) := Character'Val + (Natural'Value ("16#" & S (K + 1 .. K + 2) & '#')); + K := K + 3; + + -- Plus sign is decoded as a space + + elsif S (K) = '+' then + Result (J) := ' '; + K := K + 1; + + else + Result (J) := S (K); + K := K + 1; + end if; + + J := J + 1; + end loop; + + return Result (Result'First .. J - 1); + end Decode; + + ------------------------- + -- For_Every_Parameter -- + ------------------------- + + procedure For_Every_Parameter is + Quit : Boolean; + + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + + Quit := False; + + Action (Key_Value_Table.Table (K).Key.all, + Key_Value_Table.Table (K).Value.all, + K, + Quit); + + exit when Quit; + + end loop; + end For_Every_Parameter; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + + Request_Method : constant String := + Characters.Handling.To_Upper + (Metavariable (CGI.Request_Method)); + + procedure Initialize_GET; + -- Read CGI parameters for a GET method. In this case the parameters + -- are passed into QUERY_STRING environment variable. + + procedure Initialize_POST; + -- Read CGI parameters for a POST method. In this case the parameters + -- are passed with the standard input. The total number of characters + -- for the data is passed in CONTENT_LENGTH environment variable. + + procedure Set_Parameter_Table (Data : String); + -- Parse the parameter data and set the parameter table + + -------------------- + -- Initialize_GET -- + -------------------- + + procedure Initialize_GET is + Data : constant String := Metavariable (Query_String); + begin + Current_Method := Get; + + if Data /= "" then + Set_Parameter_Table (Data); + end if; + end Initialize_GET; + + --------------------- + -- Initialize_POST -- + --------------------- + + procedure Initialize_POST is + Content_Length : constant Natural := + Natural'Value (Metavariable (CGI.Content_Length)); + Data : String (1 .. Content_Length); + + begin + Current_Method := Post; + + if Content_Length /= 0 then + Text_IO.Get (Data); + Set_Parameter_Table (Data); + end if; + end Initialize_POST; + + ------------------------- + -- Set_Parameter_Table -- + ------------------------- + + procedure Set_Parameter_Table (Data : String) is + + procedure Add_Parameter (K : Positive; P : String); + -- Add a single parameter into the table at index K. The parameter + -- format is "key=value". + + Count : constant Positive := + 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set ("&")); + -- Count is the number of parameters in the string. Parameters are + -- separated by ampersand character. + + Index : Positive := Data'First; + Amp : Natural; + + ------------------- + -- Add_Parameter -- + ------------------- + + procedure Add_Parameter (K : Positive; P : String) is + Equal : constant Natural := Strings.Fixed.Index (P, "="); + + begin + if Equal = 0 then + raise Data_Error; + + else + Key_Value_Table.Table (K) := + Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), + new String'(Decode (P (Equal + 1 .. P'Last)))); + end if; + end Add_Parameter; + + -- Start of processing for Set_Parameter_Table + + begin + Key_Value_Table.Set_Last (Count); + + for K in 1 .. Count - 1 loop + Amp := Strings.Fixed.Index (Data (Index .. Data'Last), "&"); + + Add_Parameter (K, Data (Index .. Amp - 1)); + + Index := Amp + 1; + end loop; + + -- add last parameter + + Add_Parameter (Count, Data (Index .. Data'Last)); + end Set_Parameter_Table; + + -- Start of processing for Initialize + + begin + if Request_Method = "GET" then + Initialize_GET; + + elsif Request_Method = "POST" then + Initialize_POST; + + else + Valid_Environment := False; + end if; + + exception + when others => + + -- If we have an exception during initialization of this unit we + -- just declare it invalid. + + Valid_Environment := False; + end Initialize; + + --------- + -- Key -- + --------- + + function Key (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Key.all; + else + raise Parameter_Not_Found; + end if; + end Key; + + ---------------- + -- Key_Exists -- + ---------------- + + function Key_Exists (Key : String) return Boolean is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return True; + end if; + end loop; + + return False; + end Key_Exists; + + ------------------ + -- Metavariable -- + ------------------ + + function Metavariable + (Name : Metavariable_Name; + Required : Boolean := False) return String + is + function Get_Environment (Variable_Name : String) return String; + -- Returns the environment variable content + + --------------------- + -- Get_Environment -- + --------------------- + + function Get_Environment (Variable_Name : String) return String is + Value : OS_Lib.String_Access := OS_Lib.Getenv (Variable_Name); + Result : constant String := Value.all; + begin + OS_Lib.Free (Value); + return Result; + end Get_Environment; + + Result : constant String := + Get_Environment (Metavariable_Name'Image (Name)); + + -- Start of processing for Metavariable + + begin + Check_Environment; + + if Result = "" and then Required then + raise Parameter_Not_Found; + else + return Result; + end if; + end Metavariable; + + ------------------------- + -- Metavariable_Exists -- + ------------------------- + + function Metavariable_Exists (Name : Metavariable_Name) return Boolean is + begin + Check_Environment; + + if Metavariable (Name) = "" then + return False; + else + return True; + end if; + end Metavariable_Exists; + + ------------ + -- Method -- + ------------ + + function Method return Method_Type is + begin + Check_Environment; + return Current_Method; + end Method; + + -------- + -- Ok -- + -------- + + function Ok return Boolean is + begin + return Valid_Environment; + end Ok; + + ---------------- + -- Put_Header -- + ---------------- + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False) + is + begin + if Header_Sent = False or else Force then + Check_Environment; + Text_IO.Put_Line (Header); + Text_IO.New_Line; + Header_Sent := True; + end if; + end Put_Header; + + --------- + -- URL -- + --------- + + function URL return String is + + function Exists_And_Not_80 (Server_Port : String) return String; + -- Returns ':' & Server_Port if Server_Port is not "80" and the empty + -- string otherwise (80 is the default sever port). + + ----------------------- + -- Exists_And_Not_80 -- + ----------------------- + + function Exists_And_Not_80 (Server_Port : String) return String is + begin + if Server_Port = "80" then + return ""; + else + return ':' & Server_Port; + end if; + end Exists_And_Not_80; + + -- Start of processing for URL + + begin + Check_Environment; + + return "http://" + & Metavariable (Server_Name) + & Exists_And_Not_80 (Metavariable (Server_Port)) + & Metavariable (Script_Name); + end URL; + + ----------- + -- Value -- + ----------- + + function Value + (Key : String; + Required : Boolean := False) + return String + is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return Key_Value_Table.Table (K).Value.all; + end if; + end loop; + + if Required then + raise Parameter_Not_Found; + else + return ""; + end if; + end Value; + + ----------- + -- Value -- + ----------- + + function Value (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Value.all; + else + raise Parameter_Not_Found; + end if; + end Value; + +begin + + Initialize; + +end GNAT.CGI; diff --git a/gcc/ada/libgnat/g-cgi.ads b/gcc/ada/libgnat/g-cgi.ads new file mode 100644 index 0000000..7310d45 --- /dev/null +++ b/gcc/ada/libgnat/g-cgi.ads @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a package to interface a GNAT program with a Web server via the +-- Common Gateway Interface (CGI). + +-- Other related packages are: + +-- GNAT.CGI.Cookie which deal with Web HTTP Cookies. +-- GNAT.CGI.Debug which output complete CGI runtime environment + +-- Basically this package parse the CGI parameter which are a set of key/value +-- pairs. It builds a table whose index is the key and provides some services +-- to deal with this table. + +-- Example: + +-- Consider the following simple HTML form to capture a client name: + +-- +-- +-- +-- My Web Page +-- + +-- +--
+-- +-- +--
+-- +-- + +-- The following program will retrieve the client's name: + +-- with GNAT.CGI; + +-- procedure New_Client is +-- use GNAT; + +-- procedure Add_Client_To_Database (Name : String) is +-- begin +-- ... +-- end Add_Client_To_Database; + +-- begin +-- -- Check that we have 2 arguments (there is two inputs tag in +-- -- the HTML form) and that one of them is called "client_name". + +-- if CGI.Argument_Count = 2 +-- and then CGI.Key_Exists ("client_name") +-- then +-- Add_Client_To_Database (CGI.Value ("client_name")); +-- end if; + +-- ... + +-- CGI.Put_Header; +-- Text_IO.Put_Line ("< ... Ok ... >"); + +-- exception +-- when CGI.Data_Error => +-- CGI.Put_Header ("Location: /htdocs/error.html"); +-- -- This returns the address of a Web page to be displayed +-- -- using a "Location:" header style. +-- end New_Client; + +-- Note that the names in this package interface have been designed so that +-- they read nicely with the CGI prefix. The recommended style is to avoid +-- a use clause for GNAT.CGI, but to include a use clause for GNAT. + +-- This package builds up a table of CGI parameters whose memory is not +-- released. A CGI program is expected to be a short lived program and +-- so it is adequate to have the underlying OS free the program on exit. + +package GNAT.CGI is + + Data_Error : exception; + -- This is raised when there is a problem with the CGI protocol. Either + -- the data could not be retrieved or the CGI environment is invalid. + -- + -- The package will initialize itself by parsing the runtime CGI + -- environment during elaboration but we do not want to raise an + -- exception at this time, so the exception Data_Error is deferred + -- and will be raised when calling any services below (except for Ok). + + Parameter_Not_Found : exception; + -- This exception is raised when a specific parameter is not found + + Default_Header : constant String := "Content-type: text/html"; + -- This is the default header returned by Put_Header. If the CGI program + -- returned data is not an HTML page, this header must be change to a + -- valid MIME type. + + type Method_Type is (Get, Post); + -- The method used to pass parameter from the Web client to the + -- server. With the GET method parameters are passed via the command + -- line, with the POST method parameters are passed via environment + -- variables. Others methods are not supported by this implementation. + + type Metavariable_Name is + (Auth_Type, + Content_Length, + Content_Type, + Document_Root, -- Web server dependent + Gateway_Interface, + HTTP_Accept, + HTTP_Accept_Encoding, + HTTP_Accept_Language, + HTTP_Connection, + HTTP_Cookie, + HTTP_Extension, + HTTP_From, + HTTP_Host, + HTTP_Referer, + HTTP_User_Agent, + Path, + Path_Info, + Path_Translated, + Query_String, + Remote_Addr, + Remote_Host, + Remote_Port, -- Web server dependent + Remote_Ident, + Remote_User, + Request_Method, + Request_URI, -- Web server dependent + Script_Filename, -- Web server dependent + Script_Name, + Server_Addr, -- Web server dependent + Server_Admin, -- Web server dependent + Server_Name, + Server_Port, + Server_Protocol, + Server_Signature, -- Web server dependent + Server_Software); + -- CGI metavariables that are set by the Web server during program + -- execution. All these variables are part of the restricted CGI runtime + -- environment and can be read using Metavariable service. The detailed + -- meanings of these metavariables are out of the scope of this + -- description. Please refer to http://www.w3.org/CGI/ for a description + -- of the CGI specification. Some metavariables are Web server dependent + -- and are not described in the cited document. + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False); + -- Output standard CGI header by default. The header string is followed by + -- an empty line. This header must be the first answer sent back to the + -- server. Do nothing if this function has already been called and Force + -- is False. + + function Ok return Boolean; + -- Returns True if the CGI environment is valid and False otherwise. + -- Every service used when the CGI environment is not valid will raise + -- the exception Data_Error. + + function Method return Method_Type; + -- Returns the method used to call the CGI + + function Metavariable + (Name : Metavariable_Name; + Required : Boolean := False) return String; + -- Returns parameter Name value. Returns the null string if Name + -- environment variable is not defined or raises Data_Error if + -- Required is set to True. + + function Metavariable_Exists (Name : Metavariable_Name) return Boolean; + -- Returns True if the environment variable Name is defined in + -- the CGI runtime environment and False otherwise. + + function URL return String; + -- Returns the URL used to call this script without the parameters. + -- The URL form is: http://[:] + + function Argument_Count return Natural; + -- Returns the number of parameters passed to the client. This is the + -- number of input tags in a form or the number of parameters passed to + -- the CGI via the command line. + + --------------------------------------------------- + -- Services to retrieve key/value CGI parameters -- + --------------------------------------------------- + + function Value + (Key : String; + Required : Boolean := False) return String; + -- Returns the parameter value associated to the parameter named Key. + -- If parameter does not exist, returns an empty string if Required + -- is False and raises the exception Parameter_Not_Found otherwise. + + function Value (Position : Positive) return String; + -- Returns the parameter value associated with the CGI parameter number + -- Position. Raises Parameter_Not_Found if there is no such parameter + -- (i.e. Position > Argument_Count) + + function Key_Exists (Key : String) return Boolean; + -- Returns True if the parameter named Key exists and False otherwise + + function Key (Position : Positive) return String; + -- Returns the parameter key associated with the CGI parameter number + -- Position. Raises the exception Parameter_Not_Found if there is no + -- such parameter (i.e. Position > Argument_Count) + + generic + with procedure + Action + (Key : String; + Value : String; + Position : Positive; + Quit : in out Boolean); + procedure For_Every_Parameter; + -- Iterate through all existing key/value pairs and call the Action + -- supplied procedure. The Key and Value are set appropriately, Position + -- is the parameter order in the list, Quit is set to True by default. + -- Quit can be set to False to control the iterator termination. + +private + + function Decode (S : String) return String; + -- Decode Web string S. A string when passed to a CGI is encoded, + -- this function will decode the string to return the original + -- string's content. Every triplet of the form %HH (where H is an + -- hexadecimal number) is translated into the character such that: + -- Hex (Character'Pos (C)) = HH. + +end GNAT.CGI; diff --git a/gcc/ada/libgnat/g-cgicoo.adb b/gcc/ada/libgnat/g-cgicoo.adb new file mode 100644 index 0000000..6733612 --- /dev/null +++ b/gcc/ada/libgnat/g-cgicoo.adb @@ -0,0 +1,405 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . C O O K I E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with Ada.Text_IO; +with Ada.Integer_Text_IO; + +with GNAT.Table; + +package body GNAT.CGI.Cookie is + + use Ada; + + Valid_Environment : Boolean := False; + -- This boolean will be set to True if the initialization was fine + + Header_Sent : Boolean := False; + -- Will be set to True when the header will be sent + + -- Cookie data that has been added + + type String_Access is access String; + + type Cookie_Data is record + Key : String_Access; + Value : String_Access; + Comment : String_Access; + Domain : String_Access; + Max_Age : Natural; + Path : String_Access; + Secure : Boolean := False; + end record; + + type Key_Value is record + Key, Value : String_Access; + end record; + + package Cookie_Table is new Table (Cookie_Data, Positive, 1, 5, 50); + -- This is the table to keep all cookies to be sent back to the server + + package Key_Value_Table is new Table (Key_Value, Positive, 1, 1, 50); + -- This is the table to keep all cookies received from the server + + procedure Check_Environment; + pragma Inline (Check_Environment); + -- This procedure will raise Data_Error if Valid_Environment is False + + procedure Initialize; + -- Initialize CGI package by reading the runtime environment. This + -- procedure is called during elaboration. All exceptions raised during + -- this procedure are deferred. + + ----------------------- + -- Check_Environment -- + ----------------------- + + procedure Check_Environment is + begin + if not Valid_Environment then + raise Data_Error; + end if; + end Check_Environment; + + ----------- + -- Count -- + ----------- + + function Count return Natural is + begin + return Key_Value_Table.Last; + end Count; + + ------------ + -- Exists -- + ------------ + + function Exists (Key : String) return Boolean is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return True; + end if; + end loop; + + return False; + end Exists; + + ---------------------- + -- For_Every_Cookie -- + ---------------------- + + procedure For_Every_Cookie is + Quit : Boolean; + + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + Quit := False; + + Action (Key_Value_Table.Table (K).Key.all, + Key_Value_Table.Table (K).Value.all, + K, + Quit); + + exit when Quit; + end loop; + end For_Every_Cookie; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + + HTTP_COOKIE : constant String := Metavariable (CGI.HTTP_Cookie); + + procedure Set_Parameter_Table (Data : String); + -- Parse Data and insert information in Key_Value_Table + + ------------------------- + -- Set_Parameter_Table -- + ------------------------- + + procedure Set_Parameter_Table (Data : String) is + + procedure Add_Parameter (K : Positive; P : String); + -- Add a single parameter into the table at index K. The parameter + -- format is "key=value". + + Count : constant Positive := + 1 + Strings.Fixed.Count (Data, Strings.Maps.To_Set (";")); + -- Count is the number of parameters in the string. Parameters are + -- separated by ampersand character. + + Index : Positive := Data'First; + Sep : Natural; + + ------------------- + -- Add_Parameter -- + ------------------- + + procedure Add_Parameter (K : Positive; P : String) is + Equal : constant Natural := Strings.Fixed.Index (P, "="); + begin + if Equal = 0 then + raise Data_Error; + else + Key_Value_Table.Table (K) := + Key_Value'(new String'(Decode (P (P'First .. Equal - 1))), + new String'(Decode (P (Equal + 1 .. P'Last)))); + end if; + end Add_Parameter; + + -- Start of processing for Set_Parameter_Table + + begin + Key_Value_Table.Set_Last (Count); + + for K in 1 .. Count - 1 loop + Sep := Strings.Fixed.Index (Data (Index .. Data'Last), ";"); + + Add_Parameter (K, Data (Index .. Sep - 1)); + + Index := Sep + 2; + end loop; + + -- Add last parameter + + Add_Parameter (Count, Data (Index .. Data'Last)); + end Set_Parameter_Table; + + -- Start of processing for Initialize + + begin + if HTTP_COOKIE /= "" then + Set_Parameter_Table (HTTP_COOKIE); + end if; + + Valid_Environment := True; + + exception + when others => + Valid_Environment := False; + end Initialize; + + --------- + -- Key -- + --------- + + function Key (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Key.all; + else + raise Cookie_Not_Found; + end if; + end Key; + + -------- + -- Ok -- + -------- + + function Ok return Boolean is + begin + return Valid_Environment; + end Ok; + + ---------------- + -- Put_Header -- + ---------------- + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False) + is + procedure Output_Cookies; + -- Iterate through the list of cookies to be sent to the server + -- and output them. + + -------------------- + -- Output_Cookies -- + -------------------- + + procedure Output_Cookies is + + procedure Output_One_Cookie + (Key : String; + Value : String; + Comment : String; + Domain : String; + Max_Age : Natural; + Path : String; + Secure : Boolean); + -- Output one cookie in the CGI header + + ----------------------- + -- Output_One_Cookie -- + ----------------------- + + procedure Output_One_Cookie + (Key : String; + Value : String; + Comment : String; + Domain : String; + Max_Age : Natural; + Path : String; + Secure : Boolean) + is + begin + Text_IO.Put ("Set-Cookie: "); + Text_IO.Put (Key & '=' & Value); + + if Comment /= "" then + Text_IO.Put ("; Comment=" & Comment); + end if; + + if Domain /= "" then + Text_IO.Put ("; Domain=" & Domain); + end if; + + if Max_Age /= Natural'Last then + Text_IO.Put ("; Max-Age="); + Integer_Text_IO.Put (Max_Age, Width => 0); + end if; + + if Path /= "" then + Text_IO.Put ("; Path=" & Path); + end if; + + if Secure then + Text_IO.Put ("; Secure"); + end if; + + Text_IO.New_Line; + end Output_One_Cookie; + + -- Start of processing for Output_Cookies + + begin + for C in 1 .. Cookie_Table.Last loop + Output_One_Cookie (Cookie_Table.Table (C).Key.all, + Cookie_Table.Table (C).Value.all, + Cookie_Table.Table (C).Comment.all, + Cookie_Table.Table (C).Domain.all, + Cookie_Table.Table (C).Max_Age, + Cookie_Table.Table (C).Path.all, + Cookie_Table.Table (C).Secure); + end loop; + end Output_Cookies; + + -- Start of processing for Put_Header + + begin + if Header_Sent = False or else Force then + Check_Environment; + Text_IO.Put_Line (Header); + Output_Cookies; + Text_IO.New_Line; + Header_Sent := True; + end if; + end Put_Header; + + --------- + -- Set -- + --------- + + procedure Set + (Key : String; + Value : String; + Comment : String := ""; + Domain : String := ""; + Max_Age : Natural := Natural'Last; + Path : String := "/"; + Secure : Boolean := False) + is + begin + Cookie_Table.Increment_Last; + + Cookie_Table.Table (Cookie_Table.Last) := + Cookie_Data'(new String'(Key), + new String'(Value), + new String'(Comment), + new String'(Domain), + Max_Age, + new String'(Path), + Secure); + end Set; + + ----------- + -- Value -- + ----------- + + function Value + (Key : String; + Required : Boolean := False) return String + is + begin + Check_Environment; + + for K in 1 .. Key_Value_Table.Last loop + if Key_Value_Table.Table (K).Key.all = Key then + return Key_Value_Table.Table (K).Value.all; + end if; + end loop; + + if Required then + raise Cookie_Not_Found; + else + return ""; + end if; + end Value; + + function Value (Position : Positive) return String is + begin + Check_Environment; + + if Position <= Key_Value_Table.Last then + return Key_Value_Table.Table (Position).Value.all; + else + raise Cookie_Not_Found; + end if; + end Value; + +-- Elaboration code for package + +begin + -- Initialize unit by reading the HTTP_COOKIE metavariable and fill + -- Key_Value_Table structure. + + Initialize; +end GNAT.CGI.Cookie; diff --git a/gcc/ada/libgnat/g-cgicoo.ads b/gcc/ada/libgnat/g-cgicoo.ads new file mode 100644 index 0000000..46751a4 --- /dev/null +++ b/gcc/ada/libgnat/g-cgicoo.ads @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . C O O K I E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a package to interface a GNAT program with a Web server via the +-- Common Gateway Interface (CGI). It exports services to deal with Web +-- cookies (piece of information kept in the Web client software). + +-- The complete CGI Cookie specification can be found in the RFC2109 at: +-- http://www.ics.uci.edu/pub/ietf/http/rfc2109.txt + +-- This package builds up data tables whose memory is not released. A CGI +-- program is expected to be a short lived program and so it is adequate to +-- have the underlying OS free the program on exit. + +package GNAT.CGI.Cookie is + + -- The package will initialize itself by parsing the HTTP_Cookie runtime + -- CGI environment variable during elaboration but we do not want to raise + -- an exception at this time, so the exception Data_Error is deferred and + -- will be raised when calling any services below (except for Ok). + + Cookie_Not_Found : exception; + -- This exception is raised when a specific parameter is not found + + procedure Put_Header + (Header : String := Default_Header; + Force : Boolean := False); + -- Output standard CGI header by default. This header must be returned + -- back to the server at the very beginning and will be output only for + -- the first call to Put_Header if Force is set to False. This procedure + -- also outputs the Cookies that have been defined. If the program uses + -- the GNAT.CGI.Put_Header service, cookies will not be set. + -- + -- Cookies are passed back to the server in the header, the format is: + -- + -- Set-Cookie: =; comment=; domain=; + -- max_age=; path=[; secured] + + function Ok return Boolean; + -- Returns True if the CGI cookie environment is valid and False otherwise. + -- Every service used when the CGI environment is not valid will raise the + -- exception Data_Error. + + function Count return Natural; + -- Returns the number of cookies received by the CGI + + function Value + (Key : String; + Required : Boolean := False) return String; + -- Returns the cookie value associated with the cookie named Key. If cookie + -- does not exist, returns an empty string if Required is False and raises + -- the exception Cookie_Not_Found otherwise. + + function Value (Position : Positive) return String; + -- Returns the value associated with the cookie number Position of the CGI. + -- It raises Cookie_Not_Found if there is no such cookie (i.e. Position > + -- Count) + + function Exists (Key : String) return Boolean; + -- Returns True if the cookie named Key exist and False otherwise + + function Key (Position : Positive) return String; + -- Returns the key associated with the cookie number Position of the CGI. + -- It raises Cookie_Not_Found if there is no such cookie (i.e. Position > + -- Count) + + procedure Set + (Key : String; + Value : String; + Comment : String := ""; + Domain : String := ""; + Max_Age : Natural := Natural'Last; + Path : String := "/"; + Secure : Boolean := False); + -- Add a cookie to the list of cookies. This will be sent back to the + -- server by the Put_Header service above. + + generic + with procedure + Action + (Key : String; + Value : String; + Position : Positive; + Quit : in out Boolean); + procedure For_Every_Cookie; + -- Iterate through all cookies received from the server and call + -- the Action supplied procedure. The Key, Value parameters are set + -- appropriately, Position is the cookie order in the list, Quit is set to + -- True by default. Quit can be set to False to control the iterator + -- termination. + +end GNAT.CGI.Cookie; diff --git a/gcc/ada/libgnat/g-cgideb.adb b/gcc/ada/libgnat/g-cgideb.adb new file mode 100644 index 0000000..890c2db --- /dev/null +++ b/gcc/ada/libgnat/g-cgideb.adb @@ -0,0 +1,314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . D E B U G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings.Unbounded; + +package body GNAT.CGI.Debug is + + use Ada.Strings.Unbounded; + + -- Define the abstract type which act as a template for all debug IO modes. + -- To create a new IO mode you must: + -- 1. create a new package spec + -- 2. create a new type derived from IO.Format + -- 3. implement all the abstract routines in IO + + package IO is + + type Format is abstract tagged null record; + + function Output (Mode : Format'Class) return String; + + function Variable + (Mode : Format; + Name : String; + Value : String) return String is abstract; + -- Returns variable Name and its associated value + + function New_Line (Mode : Format) return String is abstract; + -- Returns a new line such as this concatenated between two strings + -- will display the strings on two lines. + + function Title (Mode : Format; Str : String) return String is abstract; + -- Returns Str as a Title. A title must be alone and centered on a + -- line. Next output will be on the following line. + + function Header + (Mode : Format; + Str : String) return String is abstract; + -- Returns Str as an Header. An header must be alone on its line. Next + -- output will be on the following line. + + end IO; + + ---------------------- + -- IO for HTML Mode -- + ---------------------- + + package HTML_IO is + + -- See IO for comments about these routines + + type Format is new IO.Format with null record; + + function Variable + (IO : Format; + Name : String; + Value : String) return String; + + function New_Line (IO : Format) return String; + + function Title (IO : Format; Str : String) return String; + + function Header (IO : Format; Str : String) return String; + + end HTML_IO; + + ---------------------------- + -- IO for Plain Text Mode -- + ---------------------------- + + package Text_IO is + + -- See IO for comments about these routines + + type Format is new IO.Format with null record; + + function Variable + (IO : Format; + Name : String; + Value : String) return String; + + function New_Line (IO : Format) return String; + + function Title (IO : Format; Str : String) return String; + + function Header (IO : Format; Str : String) return String; + + end Text_IO; + + -------------- + -- Debug_IO -- + -------------- + + package body IO is + + ------------ + -- Output -- + ------------ + + function Output (Mode : Format'Class) return String is + Result : Unbounded_String; + + begin + Result := + To_Unbounded_String + (Title (Mode, "CGI complete runtime environment") + & Header (Mode, "CGI parameters:") + & New_Line (Mode)); + + for K in 1 .. Argument_Count loop + Result := Result + & Variable (Mode, Key (K), Value (K)) + & New_Line (Mode); + end loop; + + Result := Result + & New_Line (Mode) + & Header (Mode, "CGI environment variables (Metavariables):") + & New_Line (Mode); + + for P in Metavariable_Name'Range loop + if Metavariable_Exists (P) then + Result := Result + & Variable (Mode, + Metavariable_Name'Image (P), + Metavariable (P)) + & New_Line (Mode); + end if; + end loop; + + return To_String (Result); + end Output; + + end IO; + + ------------- + -- HTML_IO -- + ------------- + + package body HTML_IO is + + NL : constant String := (1 => ASCII.LF); + + function Bold (S : String) return String; + -- Returns S as an HTML bold string + + function Italic (S : String) return String; + -- Returns S as an HTML italic string + + ---------- + -- Bold -- + ---------- + + function Bold (S : String) return String is + begin + return "" & S & ""; + end Bold; + + ------------ + -- Header -- + ------------ + + function Header (IO : Format; Str : String) return String is + pragma Unreferenced (IO); + begin + return "

" & Str & "

" & NL; + end Header; + + ------------ + -- Italic -- + ------------ + + function Italic (S : String) return String is + begin + return "" & S & ""; + end Italic; + + -------------- + -- New_Line -- + -------------- + + function New_Line (IO : Format) return String is + pragma Unreferenced (IO); + begin + return "
" & NL; + end New_Line; + + ----------- + -- Title -- + ----------- + + function Title (IO : Format; Str : String) return String is + pragma Unreferenced (IO); + begin + return "

" & Str & "

" & NL; + end Title; + + -------------- + -- Variable -- + -------------- + + function Variable + (IO : Format; + Name : String; + Value : String) return String + is + pragma Unreferenced (IO); + begin + return Bold (Name) & " = " & Italic (Value); + end Variable; + + end HTML_IO; + + ------------- + -- Text_IO -- + ------------- + + package body Text_IO is + + ------------ + -- Header -- + ------------ + + function Header (IO : Format; Str : String) return String is + begin + return "*** " & Str & New_Line (IO); + end Header; + + -------------- + -- New_Line -- + -------------- + + function New_Line (IO : Format) return String is + pragma Unreferenced (IO); + begin + return String'(1 => ASCII.LF); + end New_Line; + + ----------- + -- Title -- + ----------- + + function Title (IO : Format; Str : String) return String is + Spaces : constant Natural := (80 - Str'Length) / 2; + Indent : constant String (1 .. Spaces) := (others => ' '); + begin + return Indent & Str & New_Line (IO); + end Title; + + -------------- + -- Variable -- + -------------- + + function Variable + (IO : Format; + Name : String; + Value : String) return String + is + pragma Unreferenced (IO); + begin + return " " & Name & " = " & Value; + end Variable; + + end Text_IO; + + ----------------- + -- HTML_Output -- + ----------------- + + function HTML_Output return String is + HTML : HTML_IO.Format; + begin + return IO.Output (Mode => HTML); + end HTML_Output; + + ----------------- + -- Text_Output -- + ----------------- + + function Text_Output return String is + Text : Text_IO.Format; + begin + return IO.Output (Mode => Text); + end Text_Output; + +end GNAT.CGI.Debug; diff --git a/gcc/ada/libgnat/g-cgideb.ads b/gcc/ada/libgnat/g-cgideb.ads new file mode 100644 index 0000000..7a0337b --- /dev/null +++ b/gcc/ada/libgnat/g-cgideb.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C G I . D E B U G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a package to help debugging CGI (Common Gateway Interface) +-- programs written in Ada. + +package GNAT.CGI.Debug is + + -- Both functions below output all possible CGI parameters set. These are + -- the form field and all CGI environment variables which make the CGI + -- environment at runtime. + + function Text_Output return String; + -- Returns a plain text version of the CGI runtime environment + + function HTML_Output return String; + -- Returns an HTML version of the CGI runtime environment + +end GNAT.CGI.Debug; diff --git a/gcc/ada/libgnat/g-comlin.adb b/gcc/ada/libgnat/g-comlin.adb new file mode 100644 index 0000000..2fd90df --- /dev/null +++ b/gcc/ada/libgnat/g-comlin.adb @@ -0,0 +1,3613 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M M A N D _ L I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Strings.Unbounded; +with Ada.Text_IO; use Ada.Text_IO; +with Ada.Unchecked_Deallocation; + +with GNAT.Directory_Operations; use GNAT.Directory_Operations; +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body GNAT.Command_Line is + + -- General note: this entire body could use much more commenting. There + -- are large sections of uncommented code throughout, and many formal + -- parameters of local subprograms are not documented at all ??? + + package CL renames Ada.Command_Line; + + type Switch_Parameter_Type is + (Parameter_None, + Parameter_With_Optional_Space, -- ':' in getopt + Parameter_With_Space_Or_Equal, -- '=' in getopt + Parameter_No_Space, -- '!' in getopt + Parameter_Optional); -- '?' in getopt + + procedure Set_Parameter + (Variable : out Parameter_Type; + Arg_Num : Positive; + First : Positive; + Last : Natural; + Extra : Character := ASCII.NUL); + pragma Inline (Set_Parameter); + -- Set the parameter that will be returned by Parameter below + -- + -- Extra is a character that needs to be added when reporting Full_Switch. + -- (it will in general be the switch character, for instance '-'). + -- Otherwise, Full_Switch will report 'f' instead of '-f'. In particular, + -- it needs to be set when reporting an invalid switch or handling '*'. + -- + -- Parameters need to be defined ??? + + function Goto_Next_Argument_In_Section (Parser : Opt_Parser) return Boolean; + -- Go to the next argument on the command line. If we are at the end of + -- the current section, we want to make sure there is no other identical + -- section on the command line (there might be multiple instances of + -- -largs). Returns True iff there is another argument. + + function Get_File_Names_Case_Sensitive return Integer; + pragma Import (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + File_Names_Case_Sensitive : constant Boolean := + Get_File_Names_Case_Sensitive /= 0; + + procedure Canonical_Case_File_Name (S : in out String); + -- Given a file name, converts it to canonical case form. For systems where + -- file names are case sensitive, this procedure has no effect. If file + -- names are not case sensitive (i.e. for example if you have the file + -- "xyz.adb", you can refer to it as XYZ.adb or XyZ.AdB), then this call + -- converts the given string to canonical all lower case form, so that two + -- file names compare equal if they refer to the same file. + + procedure Internal_Initialize_Option_Scan + (Parser : Opt_Parser; + Switch_Char : Character; + Stop_At_First_Non_Switch : Boolean; + Section_Delimiters : String); + -- Initialize Parser, which must have been allocated already + + function Argument (Parser : Opt_Parser; Index : Integer) return String; + -- Return the index-th command line argument + + procedure Find_Longest_Matching_Switch + (Switches : String; + Arg : String; + Index_In_Switches : out Integer; + Switch_Length : out Integer; + Param : out Switch_Parameter_Type); + -- Return the Longest switch from Switches that at least partially matches + -- Arg. Index_In_Switches is set to 0 if none matches. What are other + -- parameters??? in particular Param is not always set??? + + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Argument_List, Argument_List_Access); + + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Command_Line_Configuration_Record, Command_Line_Configuration); + + procedure Remove (Line : in out Argument_List_Access; Index : Integer); + -- Remove a specific element from Line + + procedure Add + (Line : in out Argument_List_Access; + Str : String_Access; + Before : Boolean := False); + -- Add a new element to Line. If Before is True, the item is inserted at + -- the beginning, else it is appended. + + procedure Add + (Config : in out Command_Line_Configuration; + Switch : Switch_Definition); + procedure Add + (Def : in out Alias_Definitions_List; + Alias : Alias_Definition); + -- Add a new element to Def + + procedure Initialize_Switch_Def + (Def : out Switch_Definition; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Argument : String := "ARG"); + -- Initialize [Def] with the contents of the other parameters. + -- This also checks consistency of the switch parameters, and will raise + -- Invalid_Switch if they do not match. + + procedure Decompose_Switch + (Switch : String; + Parameter_Type : out Switch_Parameter_Type; + Switch_Last : out Integer); + -- Given a switch definition ("name:" for instance), extracts the type of + -- parameter that is expected, and the name of the switch + + function Can_Have_Parameter (S : String) return Boolean; + -- True if S can have a parameter + + function Require_Parameter (S : String) return Boolean; + -- True if S requires a parameter + + function Actual_Switch (S : String) return String; + -- Remove any possible trailing '!', ':', '?' and '=' + + generic + with procedure Callback + (Simple_Switch : String; + Separator : String; + Parameter : String; + Index : Integer); -- Index in Config.Switches, or -1 + procedure For_Each_Simple_Switch + (Config : Command_Line_Configuration; + Section : String; + Switch : String; + Parameter : String := ""; + Unalias : Boolean := True); + -- Breaks Switch into as simple switches as possible (expanding aliases and + -- ungrouping common prefixes when possible), and call Callback for each of + -- these. + + procedure Sort_Sections + (Line : not null GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access); + -- Reorder the command line switches so that the switches belonging to a + -- section are grouped together. + + procedure Group_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Sections : Argument_List_Access; + Params : Argument_List_Access); + -- Group switches with common prefixes whenever possible. Once they have + -- been grouped, we also check items for possible aliasing. + + procedure Alias_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Params : Argument_List_Access); + -- When possible, replace one or more switches by an alias, i.e. a shorter + -- version. + + function Looking_At + (Type_Str : String; + Index : Natural; + Substring : String) return Boolean; + -- Return True if the characters starting at Index in Type_Str are + -- equivalent to Substring. + + generic + with function Callback (S : String; Index : Integer) return Boolean; + procedure Foreach_Switch + (Config : Command_Line_Configuration; + Section : String); + -- Iterate over all switches defined in Config, for a specific section. + -- Index is set to the index in Config.Switches. Stop iterating when + -- Callback returns False. + + -------------- + -- Argument -- + -------------- + + function Argument (Parser : Opt_Parser; Index : Integer) return String is + begin + if Parser.Arguments /= null then + return Parser.Arguments (Index + Parser.Arguments'First - 1).all; + else + return CL.Argument (Index); + end if; + end Argument; + + ------------------------------ + -- Canonical_Case_File_Name -- + ------------------------------ + + procedure Canonical_Case_File_Name (S : in out String) is + begin + if not File_Names_Case_Sensitive then + for J in S'Range loop + if S (J) in 'A' .. 'Z' then + S (J) := Character'Val + (Character'Pos (S (J)) + + (Character'Pos ('a') - Character'Pos ('A'))); + end if; + end loop; + end if; + end Canonical_Case_File_Name; + + --------------- + -- Expansion -- + --------------- + + function Expansion (Iterator : Expansion_Iterator) return String is + type Pointer is access all Expansion_Iterator; + + It : constant Pointer := Iterator'Unrestricted_Access; + S : String (1 .. 1024); + Last : Natural; + + Current : Depth := It.Current_Depth; + NL : Positive; + + begin + -- It is assumed that a directory is opened at the current level. + -- Otherwise GNAT.Directory_Operations.Directory_Error will be raised + -- at the first call to Read. + + loop + Read (It.Levels (Current).Dir, S, Last); + + -- If we have exhausted the directory, close it and go back one level + + if Last = 0 then + Close (It.Levels (Current).Dir); + + -- If we are at level 1, we are finished; return an empty string + + if Current = 1 then + return String'(1 .. 0 => ' '); + + -- Otherwise continue with the directory at the previous level + + else + Current := Current - 1; + It.Current_Depth := Current; + end if; + + -- If this is a directory, that is neither "." or "..", attempt to + -- go to the next level. + + elsif Is_Directory + (It.Dir_Name (1 .. It.Levels (Current).Name_Last) & + S (1 .. Last)) + and then S (1 .. Last) /= "." + and then S (1 .. Last) /= ".." + then + -- We can go to the next level only if we have not reached the + -- maximum depth, + + if Current < It.Maximum_Depth then + NL := It.Levels (Current).Name_Last; + + -- And if relative path of this new directory is not too long + + if NL + Last + 1 < Max_Path_Length then + Current := Current + 1; + It.Current_Depth := Current; + It.Dir_Name (NL + 1 .. NL + Last) := S (1 .. Last); + NL := NL + Last + 1; + It.Dir_Name (NL) := Directory_Separator; + It.Levels (Current).Name_Last := NL; + Canonical_Case_File_Name (It.Dir_Name (1 .. NL)); + + -- Open the new directory, and read from it + + GNAT.Directory_Operations.Open + (It.Levels (Current).Dir, It.Dir_Name (1 .. NL)); + end if; + end if; + end if; + + -- Check the relative path against the pattern + + -- Note that we try to match also against directory names, since + -- clients of this function may expect to retrieve directories. + + declare + Name : String := + It.Dir_Name (It.Start .. It.Levels (Current).Name_Last) + & S (1 .. Last); + + begin + Canonical_Case_File_Name (Name); + + -- If it matches return the relative path + + if GNAT.Regexp.Match (Name, Iterator.Regexp) then + return Name; + end if; + end; + end loop; + end Expansion; + + --------------------- + -- Current_Section -- + --------------------- + + function Current_Section + (Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.Current_Section = 1 then + return ""; + end if; + + for Index in reverse 1 .. Integer'Min (Parser.Current_Argument - 1, + Parser.Section'Last) + loop + if Parser.Section (Index) = 0 then + return Argument (Parser, Index); + end if; + end loop; + + return ""; + end Current_Section; + + ----------------- + -- Full_Switch -- + ----------------- + + function Full_Switch + (Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.The_Switch.Extra = ASCII.NUL then + return Argument (Parser, Parser.The_Switch.Arg_Num) + (Parser.The_Switch.First .. Parser.The_Switch.Last); + else + return Parser.The_Switch.Extra + & Argument (Parser, Parser.The_Switch.Arg_Num) + (Parser.The_Switch.First .. Parser.The_Switch.Last); + end if; + end Full_Switch; + + ------------------ + -- Get_Argument -- + ------------------ + + function Get_Argument + (Do_Expansion : Boolean := False; + Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.In_Expansion then + declare + S : constant String := Expansion (Parser.Expansion_It); + begin + if S'Length /= 0 then + return S; + else + Parser.In_Expansion := False; + end if; + end; + end if; + + if Parser.Current_Argument > Parser.Arg_Count then + + -- If this is the first time this function is called + + if Parser.Current_Index = 1 then + Parser.Current_Argument := 1; + while Parser.Current_Argument <= Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument) /= + Parser.Current_Section + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + end loop; + + else + return String'(1 .. 0 => ' '); + end if; + + elsif Parser.Section (Parser.Current_Argument) = 0 then + while Parser.Current_Argument <= Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument) /= + Parser.Current_Section + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + end loop; + end if; + + Parser.Current_Index := Integer'Last; + + while Parser.Current_Argument <= Parser.Arg_Count + and then Parser.Is_Switch (Parser.Current_Argument) + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + end loop; + + if Parser.Current_Argument > Parser.Arg_Count then + return String'(1 .. 0 => ' '); + elsif Parser.Section (Parser.Current_Argument) = 0 then + return Get_Argument (Do_Expansion); + end if; + + Parser.Current_Argument := Parser.Current_Argument + 1; + + -- Could it be a file name with wild cards to expand? + + if Do_Expansion then + declare + Arg : constant String := + Argument (Parser, Parser.Current_Argument - 1); + begin + for Index in Arg'Range loop + if Arg (Index) = '*' + or else Arg (Index) = '?' + or else Arg (Index) = '[' + then + Parser.In_Expansion := True; + Start_Expansion (Parser.Expansion_It, Arg); + return Get_Argument (Do_Expansion, Parser); + end if; + end loop; + end; + end if; + + return Argument (Parser, Parser.Current_Argument - 1); + end Get_Argument; + + ---------------------- + -- Decompose_Switch -- + ---------------------- + + procedure Decompose_Switch + (Switch : String; + Parameter_Type : out Switch_Parameter_Type; + Switch_Last : out Integer) + is + begin + if Switch = "" then + Parameter_Type := Parameter_None; + Switch_Last := Switch'Last; + return; + end if; + + case Switch (Switch'Last) is + when ':' => + Parameter_Type := Parameter_With_Optional_Space; + Switch_Last := Switch'Last - 1; + + when '=' => + Parameter_Type := Parameter_With_Space_Or_Equal; + Switch_Last := Switch'Last - 1; + + when '!' => + Parameter_Type := Parameter_No_Space; + Switch_Last := Switch'Last - 1; + + when '?' => + Parameter_Type := Parameter_Optional; + Switch_Last := Switch'Last - 1; + + when others => + Parameter_Type := Parameter_None; + Switch_Last := Switch'Last; + end case; + end Decompose_Switch; + + ---------------------------------- + -- Find_Longest_Matching_Switch -- + ---------------------------------- + + procedure Find_Longest_Matching_Switch + (Switches : String; + Arg : String; + Index_In_Switches : out Integer; + Switch_Length : out Integer; + Param : out Switch_Parameter_Type) + is + Index : Natural; + Length : Natural := 1; + Last : Natural; + P : Switch_Parameter_Type; + + begin + Index_In_Switches := 0; + Switch_Length := 0; + + -- Remove all leading spaces first to make sure that Index points + -- at the start of the first switch. + + Index := Switches'First; + while Index <= Switches'Last and then Switches (Index) = ' ' loop + Index := Index + 1; + end loop; + + while Index <= Switches'Last loop + + -- Search the length of the parameter at this position in Switches + + Length := Index; + while Length <= Switches'Last + and then Switches (Length) /= ' ' + loop + Length := Length + 1; + end loop; + + -- Length now marks the separator after the current switch. Last will + -- mark the last character of the name of the switch. + + if Length = Index + 1 then + P := Parameter_None; + Last := Index; + else + Decompose_Switch (Switches (Index .. Length - 1), P, Last); + end if; + + -- If it is the one we searched, it may be a candidate + + if Arg'First + Last - Index <= Arg'Last + and then Switches (Index .. Last) = + Arg (Arg'First .. Arg'First + Last - Index) + and then Last - Index + 1 > Switch_Length + and then + (P /= Parameter_With_Space_Or_Equal + or else Arg'Last = Arg'First + Last - Index + or else Arg (Arg'First + Last - Index + 1) = '=') + then + Param := P; + Index_In_Switches := Index; + Switch_Length := Last - Index + 1; + end if; + + -- Look for the next switch in Switches + + while Index <= Switches'Last + and then Switches (Index) /= ' ' + loop + Index := Index + 1; + end loop; + + Index := Index + 1; + end loop; + end Find_Longest_Matching_Switch; + + ------------ + -- Getopt -- + ------------ + + function Getopt + (Switches : String; + Concatenate : Boolean := True; + Parser : Opt_Parser := Command_Line_Parser) return Character + is + Dummy : Boolean; + + begin + <> + + -- If we have finished parsing the current command line item (there + -- might be multiple switches in a single item), then go to the next + -- element. + + if Parser.Current_Argument > Parser.Arg_Count + or else (Parser.Current_Index > + Argument (Parser, Parser.Current_Argument)'Last + and then not Goto_Next_Argument_In_Section (Parser)) + then + return ASCII.NUL; + end if; + + -- By default, the switch will not have a parameter + + Parser.The_Parameter := + (Integer'Last, Integer'Last, Integer'Last - 1, ASCII.NUL); + Parser.The_Separator := ASCII.NUL; + + declare + Arg : constant String := + Argument (Parser, Parser.Current_Argument); + Index_Switches : Natural := 0; + Max_Length : Natural := 0; + End_Index : Natural; + Param : Switch_Parameter_Type; + begin + -- If we are on a new item, test if this might be a switch + + if Parser.Current_Index = Arg'First then + if Arg = "" or else Arg (Arg'First) /= Parser.Switch_Character then + + -- If it isn't a switch, return it immediately. We also know it + -- isn't the parameter to a previous switch, since that has + -- already been handled. + + if Switches (Switches'First) = '*' then + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Arg'First, + Last => Arg'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + return '*'; + end if; + + if Parser.Stop_At_First then + Parser.Current_Argument := Positive'Last; + return ASCII.NUL; + + elsif not Goto_Next_Argument_In_Section (Parser) then + return ASCII.NUL; + + else + -- Recurse to get the next switch on the command line + + goto Restart; + end if; + end if; + + -- We are on the first character of a new command line argument, + -- which starts with Switch_Character. Further analysis is needed. + + Parser.Current_Index := Parser.Current_Index + 1; + Parser.Is_Switch (Parser.Current_Argument) := True; + end if; + + Find_Longest_Matching_Switch + (Switches => Switches, + Arg => Arg (Parser.Current_Index .. Arg'Last), + Index_In_Switches => Index_Switches, + Switch_Length => Max_Length, + Param => Param); + + -- If switch is not accepted, it is either invalid or is returned + -- in the context of '*'. + + if Index_Switches = 0 then + + -- Find the current switch that we did not recognize. This is in + -- fact difficult because Getopt does not know explicitly about + -- short and long switches. Ideally, we would want the following + -- behavior: + + -- * for short switches, with Concatenate: + -- if -a is not recognized, and the command line has -daf + -- we should report the invalid switch as "-a". + + -- * for short switches, wihtout Concatenate: + -- we should report the invalid switch as "-daf". + + -- * for long switches: + -- if the commadn line is "--long" we should report --long + -- as unrecongized. + + -- Unfortunately, the fact that long switches start with a + -- duplicate switch character is just a convention (so we could + -- have a long switch "-long" for instance). We'll still rely on + -- this convention here to try and get as helpful an error message + -- as possible. + + -- Long switch case (starting with double switch character) + + if Arg (Arg'First + 1) = Parser.Switch_Character then + End_Index := Arg'Last; + + -- Short switch case + + else + End_Index := + (if Concatenate then Parser.Current_Index else Arg'Last); + end if; + + if Switches /= "" and then Switches (Switches'First) = '*' then + + -- Always prepend the switch character, so that users know + -- that this comes from a switch on the command line. This + -- is especially important when Concatenate is False, since + -- otherwise the current argument first character is lost. + + if Parser.Section (Parser.Current_Argument) = 0 then + + -- A section transition should not be returned to the user + + Dummy := Goto_Next_Argument_In_Section (Parser); + goto Restart; + + else + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => Arg'Last, + Extra => Parser.Switch_Character); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + return '*'; + end if; + end if; + + if Parser.Current_Index = Arg'First then + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => End_Index); + else + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => End_Index, + Extra => Parser.Switch_Character); + end if; + + Parser.Current_Index := End_Index + 1; + + raise Invalid_Switch; + end if; + + End_Index := Parser.Current_Index + Max_Length - 1; + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => End_Index); + + case Param is + when Parameter_With_Optional_Space => + if End_Index < Arg'Last then + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section (Parser); + + elsif Parser.Current_Argument < Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument + 1) /= 0 + then + Parser.Current_Argument := Parser.Current_Argument + 1; + Parser.The_Separator := ' '; + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => Argument (Parser, Parser.Current_Argument)'First, + Last => Argument (Parser, Parser.Current_Argument)'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when Parameter_With_Space_Or_Equal => + + -- If the switch is of the form =xxx + + if End_Index < Arg'Last then + if Arg (End_Index + 1) = '=' + and then End_Index + 1 < Arg'Last + then + Parser.The_Separator := '='; + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 2, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section (Parser); + + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + -- Case of switch of the form xxx + + elsif Parser.Current_Argument < Parser.Arg_Count + and then Parser.Section (Parser.Current_Argument + 1) /= 0 + then + Parser.Current_Argument := Parser.Current_Argument + 1; + Parser.The_Separator := ' '; + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => Argument (Parser, Parser.Current_Argument)'First, + Last => Argument (Parser, Parser.Current_Argument)'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when Parameter_No_Space => + if End_Index < Arg'Last then + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + Dummy := Goto_Next_Argument_In_Section (Parser); + + else + Parser.Current_Index := End_Index + 1; + raise Invalid_Parameter; + end if; + + when Parameter_Optional => + if End_Index < Arg'Last then + Set_Parameter + (Parser.The_Parameter, + Arg_Num => Parser.Current_Argument, + First => End_Index + 1, + Last => Arg'Last); + end if; + + Dummy := Goto_Next_Argument_In_Section (Parser); + + when Parameter_None => + if Concatenate or else End_Index = Arg'Last then + Parser.Current_Index := End_Index + 1; + + else + -- If Concatenate is False and the full argument is not + -- recognized as a switch, this is an invalid switch. + + if Switches (Switches'First) = '*' then + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Arg'First, + Last => Arg'Last); + Parser.Is_Switch (Parser.Current_Argument) := True; + Dummy := Goto_Next_Argument_In_Section (Parser); + return '*'; + end if; + + Set_Parameter + (Parser.The_Switch, + Arg_Num => Parser.Current_Argument, + First => Parser.Current_Index, + Last => Arg'Last, + Extra => Parser.Switch_Character); + Parser.Current_Index := Arg'Last + 1; + raise Invalid_Switch; + end if; + end case; + + return Switches (Index_Switches); + end; + end Getopt; + + ----------------------------------- + -- Goto_Next_Argument_In_Section -- + ----------------------------------- + + function Goto_Next_Argument_In_Section + (Parser : Opt_Parser) return Boolean + is + begin + Parser.Current_Argument := Parser.Current_Argument + 1; + + if Parser.Current_Argument > Parser.Arg_Count + or else Parser.Section (Parser.Current_Argument) = 0 + then + loop + Parser.Current_Argument := Parser.Current_Argument + 1; + + if Parser.Current_Argument > Parser.Arg_Count then + Parser.Current_Index := 1; + return False; + end if; + + exit when Parser.Section (Parser.Current_Argument) = + Parser.Current_Section; + end loop; + end if; + + Parser.Current_Index := + Argument (Parser, Parser.Current_Argument)'First; + + return True; + end Goto_Next_Argument_In_Section; + + ------------------ + -- Goto_Section -- + ------------------ + + procedure Goto_Section + (Name : String := ""; + Parser : Opt_Parser := Command_Line_Parser) + is + Index : Integer; + + begin + Parser.In_Expansion := False; + + if Name = "" then + Parser.Current_Argument := 1; + Parser.Current_Index := 1; + Parser.Current_Section := 1; + return; + end if; + + Index := 1; + while Index <= Parser.Arg_Count loop + if Parser.Section (Index) = 0 + and then Argument (Parser, Index) = Parser.Switch_Character & Name + then + Parser.Current_Argument := Index + 1; + Parser.Current_Index := 1; + + if Parser.Current_Argument <= Parser.Arg_Count then + Parser.Current_Section := + Parser.Section (Parser.Current_Argument); + end if; + + -- Exit from loop if we have the start of another section + + if Index = Parser.Section'Last + or else Parser.Section (Index + 1) /= 0 + then + return; + end if; + end if; + + Index := Index + 1; + end loop; + + Parser.Current_Argument := Positive'Last; + Parser.Current_Index := 2; -- so that Get_Argument returns nothing + end Goto_Section; + + ---------------------------- + -- Initialize_Option_Scan -- + ---------------------------- + + procedure Initialize_Option_Scan + (Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := "") + is + begin + Internal_Initialize_Option_Scan + (Parser => Command_Line_Parser, + Switch_Char => Switch_Char, + Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, + Section_Delimiters => Section_Delimiters); + end Initialize_Option_Scan; + + ---------------------------- + -- Initialize_Option_Scan -- + ---------------------------- + + procedure Initialize_Option_Scan + (Parser : out Opt_Parser; + Command_Line : GNAT.OS_Lib.Argument_List_Access; + Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := "") + is + begin + Free (Parser); + + if Command_Line = null then + Parser := new Opt_Parser_Data (CL.Argument_Count); + Internal_Initialize_Option_Scan + (Parser => Parser, + Switch_Char => Switch_Char, + Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, + Section_Delimiters => Section_Delimiters); + else + Parser := new Opt_Parser_Data (Command_Line'Length); + Parser.Arguments := Command_Line; + Internal_Initialize_Option_Scan + (Parser => Parser, + Switch_Char => Switch_Char, + Stop_At_First_Non_Switch => Stop_At_First_Non_Switch, + Section_Delimiters => Section_Delimiters); + end if; + end Initialize_Option_Scan; + + ------------------------------------- + -- Internal_Initialize_Option_Scan -- + ------------------------------------- + + procedure Internal_Initialize_Option_Scan + (Parser : Opt_Parser; + Switch_Char : Character; + Stop_At_First_Non_Switch : Boolean; + Section_Delimiters : String) + is + Section_Num : Section_Number; + Section_Index : Integer; + Last : Integer; + Delimiter_Found : Boolean; + + Discard : Boolean; + pragma Warnings (Off, Discard); + + begin + Parser.Current_Argument := 0; + Parser.Current_Index := 0; + Parser.In_Expansion := False; + Parser.Switch_Character := Switch_Char; + Parser.Stop_At_First := Stop_At_First_Non_Switch; + Parser.Section := (others => 1); + + -- If we are using sections, we have to preprocess the command line to + -- delimit them. A section can be repeated, so we just give each item + -- on the command line a section number + + Section_Num := 1; + Section_Index := Section_Delimiters'First; + while Section_Index <= Section_Delimiters'Last loop + Last := Section_Index; + while Last <= Section_Delimiters'Last + and then Section_Delimiters (Last) /= ' ' + loop + Last := Last + 1; + end loop; + + Delimiter_Found := False; + Section_Num := Section_Num + 1; + + for Index in 1 .. Parser.Arg_Count loop + pragma Assert (Argument (Parser, Index)'First = 1); + if Argument (Parser, Index) /= "" + and then Argument (Parser, Index)(1) = Parser.Switch_Character + and then + Argument (Parser, Index) = Parser.Switch_Character & + Section_Delimiters + (Section_Index .. Last - 1) + then + Parser.Section (Index) := 0; + Delimiter_Found := True; + + elsif Parser.Section (Index) = 0 then + + -- A previous section delimiter + + Delimiter_Found := False; + + elsif Delimiter_Found then + Parser.Section (Index) := Section_Num; + end if; + end loop; + + Section_Index := Last + 1; + while Section_Index <= Section_Delimiters'Last + and then Section_Delimiters (Section_Index) = ' ' + loop + Section_Index := Section_Index + 1; + end loop; + end loop; + + Discard := Goto_Next_Argument_In_Section (Parser); + end Internal_Initialize_Option_Scan; + + --------------- + -- Parameter -- + --------------- + + function Parameter + (Parser : Opt_Parser := Command_Line_Parser) return String + is + begin + if Parser.The_Parameter.First > Parser.The_Parameter.Last then + return String'(1 .. 0 => ' '); + else + return Argument (Parser, Parser.The_Parameter.Arg_Num) + (Parser.The_Parameter.First .. Parser.The_Parameter.Last); + end if; + end Parameter; + + --------------- + -- Separator -- + --------------- + + function Separator + (Parser : Opt_Parser := Command_Line_Parser) return Character + is + begin + return Parser.The_Separator; + end Separator; + + ------------------- + -- Set_Parameter -- + ------------------- + + procedure Set_Parameter + (Variable : out Parameter_Type; + Arg_Num : Positive; + First : Positive; + Last : Natural; + Extra : Character := ASCII.NUL) + is + begin + Variable.Arg_Num := Arg_Num; + Variable.First := First; + Variable.Last := Last; + Variable.Extra := Extra; + end Set_Parameter; + + --------------------- + -- Start_Expansion -- + --------------------- + + procedure Start_Expansion + (Iterator : out Expansion_Iterator; + Pattern : String; + Directory : String := ""; + Basic_Regexp : Boolean := True) + is + Directory_Separator : Character; + pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + + First : Positive := Pattern'First; + Pat : String := Pattern; + + begin + Canonical_Case_File_Name (Pat); + Iterator.Current_Depth := 1; + + -- If Directory is unspecified, use the current directory ("./" or ".\") + + if Directory = "" then + Iterator.Dir_Name (1 .. 2) := "." & Directory_Separator; + Iterator.Start := 3; + + else + Iterator.Dir_Name (1 .. Directory'Length) := Directory; + Iterator.Start := Directory'Length + 1; + Canonical_Case_File_Name (Iterator.Dir_Name (1 .. Directory'Length)); + + -- Make sure that the last character is a directory separator + + if Directory (Directory'Last) /= Directory_Separator then + Iterator.Dir_Name (Iterator.Start) := Directory_Separator; + Iterator.Start := Iterator.Start + 1; + end if; + end if; + + Iterator.Levels (1).Name_Last := Iterator.Start - 1; + + -- Open the initial Directory, at depth 1 + + GNAT.Directory_Operations.Open + (Iterator.Levels (1).Dir, Iterator.Dir_Name (1 .. Iterator.Start - 1)); + + -- If in the current directory and the pattern starts with "./" or ".\", + -- drop the "./" or ".\" from the pattern. + + if Directory = "" and then Pat'Length > 2 + and then Pat (Pat'First) = '.' + and then Pat (Pat'First + 1) = Directory_Separator + then + First := Pat'First + 2; + end if; + + Iterator.Regexp := + GNAT.Regexp.Compile (Pat (First .. Pat'Last), Basic_Regexp, True); + + Iterator.Maximum_Depth := 1; + + -- Maximum_Depth is equal to 1 plus the number of directory separators + -- in the pattern. + + for Index in First .. Pat'Last loop + if Pat (Index) = Directory_Separator then + Iterator.Maximum_Depth := Iterator.Maximum_Depth + 1; + exit when Iterator.Maximum_Depth = Max_Depth; + end if; + end loop; + end Start_Expansion; + + ---------- + -- Free -- + ---------- + + procedure Free (Parser : in out Opt_Parser) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation (Opt_Parser_Data, Opt_Parser); + begin + if Parser /= null and then Parser /= Command_Line_Parser then + Free (Parser.Arguments); + Unchecked_Free (Parser); + end if; + end Free; + + ------------------ + -- Define_Alias -- + ------------------ + + procedure Define_Alias + (Config : in out Command_Line_Configuration; + Switch : String; + Expanded : String; + Section : String := "") + is + Def : Alias_Definition; + + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Def.Alias := new String'(Switch); + Def.Expansion := new String'(Expanded); + Def.Section := new String'(Section); + Add (Config.Aliases, Def); + end Define_Alias; + + ------------------- + -- Define_Prefix -- + ------------------- + + procedure Define_Prefix + (Config : in out Command_Line_Configuration; + Prefix : String) + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Add (Config.Prefixes, new String'(Prefix)); + end Define_Prefix; + + --------- + -- Add -- + --------- + + procedure Add + (Config : in out Command_Line_Configuration; + Switch : Switch_Definition) + is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Switch_Definitions, Switch_Definitions_List); + + Tmp : Switch_Definitions_List; + + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Tmp := Config.Switches; + + if Tmp = null then + Config.Switches := new Switch_Definitions (1 .. 1); + else + Config.Switches := new Switch_Definitions (1 .. Tmp'Length + 1); + Config.Switches (1 .. Tmp'Length) := Tmp.all; + Unchecked_Free (Tmp); + end if; + + if Switch.Switch /= null and then Switch.Switch.all = "*" then + Config.Star_Switch := True; + end if; + + Config.Switches (Config.Switches'Last) := Switch; + end Add; + + --------- + -- Add -- + --------- + + procedure Add + (Def : in out Alias_Definitions_List; + Alias : Alias_Definition) + is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation + (Alias_Definitions, Alias_Definitions_List); + + Tmp : Alias_Definitions_List := Def; + + begin + if Tmp = null then + Def := new Alias_Definitions (1 .. 1); + else + Def := new Alias_Definitions (1 .. Tmp'Length + 1); + Def (1 .. Tmp'Length) := Tmp.all; + Unchecked_Free (Tmp); + end if; + + Def (Def'Last) := Alias; + end Add; + + --------------------------- + -- Initialize_Switch_Def -- + --------------------------- + + procedure Initialize_Switch_Def + (Def : out Switch_Definition; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Argument : String := "ARG") + is + P1, P2 : Switch_Parameter_Type := Parameter_None; + Last1, Last2 : Integer; + + begin + if Switch /= "" then + Def.Switch := new String'(Switch); + Decompose_Switch (Switch, P1, Last1); + end if; + + if Long_Switch /= "" then + Def.Long_Switch := new String'(Long_Switch); + Decompose_Switch (Long_Switch, P2, Last2); + end if; + + if Switch /= "" and then Long_Switch /= "" then + if (P1 = Parameter_None and then P2 /= P1) + or else (P2 = Parameter_None and then P1 /= P2) + or else (P1 = Parameter_Optional and then P2 /= P1) + or else (P2 = Parameter_Optional and then P2 /= P1) + then + raise Invalid_Switch + with "Inconsistent parameter types for " + & Switch & " and " & Long_Switch; + end if; + end if; + + if Section /= "" then + Def.Section := new String'(Section); + end if; + + if Argument /= "ARG" then + Def.Argument := new String'(Argument); + end if; + + if Help /= "" then + Def.Help := new String'(Help); + end if; + end Initialize_Switch_Def; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Argument : String := "ARG") + is + Def : Switch_Definition; + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def + (Def, Switch, Long_Switch, Help, Section, Argument); + Add (Config, Def); + end if; + end Define_Switch; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access Boolean; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Value : Boolean := True) + is + Def : Switch_Definition (Switch_Boolean); + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def (Def, Switch, Long_Switch, Help, Section); + Def.Boolean_Output := Output.all'Unchecked_Access; + Def.Boolean_Value := Value; + Add (Config, Def); + end if; + end Define_Switch; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access Integer; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Initial : Integer := 0; + Default : Integer := 1; + Argument : String := "ARG") + is + Def : Switch_Definition (Switch_Integer); + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def + (Def, Switch, Long_Switch, Help, Section, Argument); + Def.Integer_Output := Output.all'Unchecked_Access; + Def.Integer_Default := Default; + Def.Integer_Initial := Initial; + Add (Config, Def); + end if; + end Define_Switch; + + ------------------- + -- Define_Switch -- + ------------------- + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access GNAT.Strings.String_Access; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Argument : String := "ARG") + is + Def : Switch_Definition (Switch_String); + begin + if Switch /= "" or else Long_Switch /= "" then + Initialize_Switch_Def + (Def, Switch, Long_Switch, Help, Section, Argument); + Def.String_Output := Output.all'Unchecked_Access; + Add (Config, Def); + end if; + end Define_Switch; + + -------------------- + -- Define_Section -- + -------------------- + + procedure Define_Section + (Config : in out Command_Line_Configuration; + Section : String) + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Add (Config.Sections, new String'(Section)); + end Define_Section; + + -------------------- + -- Foreach_Switch -- + -------------------- + + procedure Foreach_Switch + (Config : Command_Line_Configuration; + Section : String) + is + begin + if Config /= null and then Config.Switches /= null then + for J in Config.Switches'Range loop + if (Section = "" and then Config.Switches (J).Section = null) + or else + (Config.Switches (J).Section /= null + and then Config.Switches (J).Section.all = Section) + then + exit when Config.Switches (J).Switch /= null + and then not Callback (Config.Switches (J).Switch.all, J); + + exit when Config.Switches (J).Long_Switch /= null + and then + not Callback (Config.Switches (J).Long_Switch.all, J); + end if; + end loop; + end if; + end Foreach_Switch; + + ------------------ + -- Get_Switches -- + ------------------ + + function Get_Switches + (Config : Command_Line_Configuration; + Switch_Char : Character := '-'; + Section : String := "") return String + is + Ret : Ada.Strings.Unbounded.Unbounded_String; + use Ada.Strings.Unbounded; + + function Add_Switch (S : String; Index : Integer) return Boolean; + -- Add a switch to Ret + + ---------------- + -- Add_Switch -- + ---------------- + + function Add_Switch (S : String; Index : Integer) return Boolean is + pragma Unreferenced (Index); + begin + if S = "*" then + Ret := "*" & Ret; -- Always first + elsif S (S'First) = Switch_Char then + Append (Ret, " " & S (S'First + 1 .. S'Last)); + else + Append (Ret, " " & S); + end if; + + return True; + end Add_Switch; + + Tmp : Boolean; + pragma Unreferenced (Tmp); + + procedure Foreach is new Foreach_Switch (Add_Switch); + + -- Start of processing for Get_Switches + + begin + if Config = null then + return ""; + end if; + + Foreach (Config, Section => Section); + + -- Add relevant aliases + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section then + Tmp := Add_Switch (Config.Aliases (A).Alias.all, -1); + end if; + end loop; + end if; + + return To_String (Ret); + end Get_Switches; + + ------------------------ + -- Section_Delimiters -- + ------------------------ + + function Section_Delimiters + (Config : Command_Line_Configuration) return String + is + use Ada.Strings.Unbounded; + Result : Unbounded_String; + + begin + if Config /= null and then Config.Sections /= null then + for S in Config.Sections'Range loop + Append (Result, " " & Config.Sections (S).all); + end loop; + end if; + + return To_String (Result); + end Section_Delimiters; + + ----------------------- + -- Set_Configuration -- + ----------------------- + + procedure Set_Configuration + (Cmd : in out Command_Line; + Config : Command_Line_Configuration) + is + begin + Cmd.Config := Config; + end Set_Configuration; + + ----------------------- + -- Get_Configuration -- + ----------------------- + + function Get_Configuration + (Cmd : Command_Line) return Command_Line_Configuration + is + begin + return Cmd.Config; + end Get_Configuration; + + ---------------------- + -- Set_Command_Line -- + ---------------------- + + procedure Set_Command_Line + (Cmd : in out Command_Line; + Switches : String; + Getopt_Description : String := ""; + Switch_Char : Character := '-') + is + Tmp : Argument_List_Access; + Parser : Opt_Parser; + S : Character; + Section : String_Access := null; + + function Real_Full_Switch + (S : Character; + Parser : Opt_Parser) return String; + -- Ensure that the returned switch value contains the Switch_Char prefix + -- if needed. + + ---------------------- + -- Real_Full_Switch -- + ---------------------- + + function Real_Full_Switch + (S : Character; + Parser : Opt_Parser) return String + is + begin + if S = '*' then + return Full_Switch (Parser); + else + return Switch_Char & Full_Switch (Parser); + end if; + end Real_Full_Switch; + + -- Start of processing for Set_Command_Line + + begin + Free (Cmd.Expanded); + Free (Cmd.Params); + + if Switches /= "" then + Tmp := Argument_String_To_List (Switches); + Initialize_Option_Scan (Parser, Tmp, Switch_Char); + + loop + begin + if Cmd.Config /= null then + + -- Do not use Getopt_Description in this case. Otherwise, + -- if we have defined a prefix -gnaty, and two switches + -- -gnatya and -gnatyL!, we would have a different behavior + -- depending on the order of switches: + + -- -gnatyL1a => -gnatyL with argument "1a" + -- -gnatyaL1 => -gnatya and -gnatyL with argument "1" + + -- This is because the call to Getopt below knows nothing + -- about prefixes, and in the first case finds a valid + -- switch with arguments, so returns it without analyzing + -- the argument. In the second case, the switch matches "*", + -- and is then decomposed below. + + -- Note: When a Command_Line object is associated with a + -- Command_Line_Config (which is mostly the case for tools + -- that let users choose the command line before spawning + -- other tools, for instance IDEs), the configuration of + -- the switches must be taken from the Command_Line_Config. + + S := Getopt (Switches => "* " & Get_Switches (Cmd.Config), + Concatenate => False, + Parser => Parser); + + else + S := Getopt (Switches => "* " & Getopt_Description, + Concatenate => False, + Parser => Parser); + end if; + + exit when S = ASCII.NUL; + + declare + Sw : constant String := Real_Full_Switch (S, Parser); + Is_Section : Boolean := False; + + begin + if Cmd.Config /= null + and then Cmd.Config.Sections /= null + then + Section_Search : + for S in Cmd.Config.Sections'Range loop + if Sw = Cmd.Config.Sections (S).all then + Section := Cmd.Config.Sections (S); + Is_Section := True; + + exit Section_Search; + end if; + end loop Section_Search; + end if; + + if not Is_Section then + if Section = null then + Add_Switch (Cmd, Sw, Parameter (Parser)); + else + Add_Switch + (Cmd, Sw, Parameter (Parser), + Section => Section.all); + end if; + end if; + end; + + exception + when Invalid_Parameter => + + -- Add it with no parameter, if that's the way the user + -- wants it. + + -- Specify the separator in all cases, as the switch might + -- need to be unaliased, and the alias might contain + -- switches with parameters. + + if Section = null then + Add_Switch + (Cmd, Switch_Char & Full_Switch (Parser)); + else + Add_Switch + (Cmd, Switch_Char & Full_Switch (Parser), + Section => Section.all); + end if; + end; + end loop; + + Free (Parser); + end if; + end Set_Command_Line; + + ---------------- + -- Looking_At -- + ---------------- + + function Looking_At + (Type_Str : String; + Index : Natural; + Substring : String) return Boolean + is + begin + return Index + Substring'Length - 1 <= Type_Str'Last + and then Type_Str (Index .. Index + Substring'Length - 1) = Substring; + end Looking_At; + + ------------------------ + -- Can_Have_Parameter -- + ------------------------ + + function Can_Have_Parameter (S : String) return Boolean is + begin + if S'Length <= 1 then + return False; + end if; + + case S (S'Last) is + when '!' | ':' | '?' | '=' => + return True; + when others => + return False; + end case; + end Can_Have_Parameter; + + ----------------------- + -- Require_Parameter -- + ----------------------- + + function Require_Parameter (S : String) return Boolean is + begin + if S'Length <= 1 then + return False; + end if; + + case S (S'Last) is + when '!' | ':' | '=' => + return True; + when others => + return False; + end case; + end Require_Parameter; + + ------------------- + -- Actual_Switch -- + ------------------- + + function Actual_Switch (S : String) return String is + begin + if S'Length <= 1 then + return S; + end if; + + case S (S'Last) is + when '!' | ':' | '?' | '=' => + return S (S'First .. S'Last - 1); + when others => + return S; + end case; + end Actual_Switch; + + ---------------------------- + -- For_Each_Simple_Switch -- + ---------------------------- + + procedure For_Each_Simple_Switch + (Config : Command_Line_Configuration; + Section : String; + Switch : String; + Parameter : String := ""; + Unalias : Boolean := True) + is + function Group_Analysis + (Prefix : String; + Group : String) return Boolean; + -- Perform the analysis of a group of switches + + Found_In_Config : Boolean := False; + function Is_In_Config + (Config_Switch : String; Index : Integer) return Boolean; + -- If Switch is the same as Config_Switch, run the callback and sets + -- Found_In_Config to True. + + function Starts_With + (Config_Switch : String; Index : Integer) return Boolean; + -- if Switch starts with Config_Switch, sets Found_In_Config to True. + -- The return value is for the Foreach_Switch iterator. + + -------------------- + -- Group_Analysis -- + -------------------- + + function Group_Analysis + (Prefix : String; + Group : String) return Boolean + is + Idx : Natural; + Found : Boolean; + + function Analyze_Simple_Switch + (Switch : String; Index : Integer) return Boolean; + -- "Switches" is one of the switch definitions passed to the + -- configuration, not one of the switches found on the command line. + + --------------------------- + -- Analyze_Simple_Switch -- + --------------------------- + + function Analyze_Simple_Switch + (Switch : String; Index : Integer) return Boolean + is + pragma Unreferenced (Index); + + Full : constant String := Prefix & Group (Idx .. Group'Last); + + Sw : constant String := Actual_Switch (Switch); + -- Switches definition minus argument definition + + Last : Natural; + Param : Natural; + + begin + -- Verify that sw starts with Prefix + + if Looking_At (Sw, Sw'First, Prefix) + + -- Verify that the group starts with sw + + and then Looking_At (Full, Full'First, Sw) + then + Last := Idx + Sw'Length - Prefix'Length - 1; + Param := Last + 1; + + if Can_Have_Parameter (Switch) then + + -- Include potential parameter to the recursive call. Only + -- numbers are allowed. + + while Last < Group'Last + and then Group (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + end if; + + if not Require_Parameter (Switch) or else Last >= Param then + if Idx = Group'First + and then Last = Group'Last + and then Last < Param + then + -- The group only concerns a single switch. Do not + -- perform recursive call. + + -- Note that we still perform a recursive call if + -- a parameter is detected in the switch, as this + -- is a way to correctly identify such a parameter + -- in aliases. + + return False; + end if; + + Found := True; + + -- Recursive call, using the detected parameter if any + + if Last >= Param then + For_Each_Simple_Switch + (Config, + Section, + Prefix & Group (Idx .. Param - 1), + Group (Param .. Last)); + + else + For_Each_Simple_Switch + (Config, Section, Prefix & Group (Idx .. Last), ""); + end if; + + Idx := Last + 1; + return False; + end if; + end if; + + return True; + end Analyze_Simple_Switch; + + procedure Foreach is new Foreach_Switch (Analyze_Simple_Switch); + + -- Start of processing for Group_Analysis + + begin + Idx := Group'First; + while Idx <= Group'Last loop + Found := False; + Foreach (Config, Section); + + if not Found then + For_Each_Simple_Switch + (Config, Section, Prefix & Group (Idx), ""); + Idx := Idx + 1; + end if; + end loop; + + return True; + end Group_Analysis; + + ------------------ + -- Is_In_Config -- + ------------------ + + function Is_In_Config + (Config_Switch : String; Index : Integer) return Boolean + is + Last : Natural; + P : Switch_Parameter_Type; + + begin + Decompose_Switch (Config_Switch, P, Last); + + if Config_Switch (Config_Switch'First .. Last) = Switch then + case P is + when Parameter_None => + if Parameter = "" then + Callback (Switch, "", "", Index => Index); + Found_In_Config := True; + return False; + end if; + + when Parameter_With_Optional_Space => + Callback (Switch, " ", Parameter, Index => Index); + Found_In_Config := True; + return False; + + when Parameter_With_Space_Or_Equal => + Callback (Switch, "=", Parameter, Index => Index); + Found_In_Config := True; + return False; + + when Parameter_No_Space + | Parameter_Optional + => + Callback (Switch, "", Parameter, Index); + Found_In_Config := True; + return False; + end case; + end if; + + return True; + end Is_In_Config; + + ----------------- + -- Starts_With -- + ----------------- + + function Starts_With + (Config_Switch : String; Index : Integer) return Boolean + is + Last : Natural; + Param : Natural; + P : Switch_Parameter_Type; + + begin + -- This function is called when we believe the parameter was + -- specified as part of the switch, instead of separately. Thus we + -- look in the config to find all possible switches. + + Decompose_Switch (Config_Switch, P, Last); + + if Looking_At + (Switch, Switch'First, + Config_Switch (Config_Switch'First .. Last)) + then + -- Set first char of Param, and last char of Switch + + Param := Switch'First + Last; + Last := Switch'First + Last - Config_Switch'First; + + case P is + + -- None is already handled in Is_In_Config + + when Parameter_None => + null; + + when Parameter_With_Space_Or_Equal => + if Param <= Switch'Last + and then + (Switch (Param) = ' ' or else Switch (Param) = '=') + then + Callback (Switch (Switch'First .. Last), + "=", Switch (Param + 1 .. Switch'Last), Index); + Found_In_Config := True; + return False; + end if; + + when Parameter_With_Optional_Space => + if Param <= Switch'Last and then Switch (Param) = ' ' then + Param := Param + 1; + end if; + + Callback (Switch (Switch'First .. Last), + " ", Switch (Param .. Switch'Last), Index); + Found_In_Config := True; + return False; + + when Parameter_No_Space + | Parameter_Optional + => + Callback (Switch (Switch'First .. Last), + "", Switch (Param .. Switch'Last), Index); + Found_In_Config := True; + return False; + end case; + end if; + return True; + end Starts_With; + + procedure Foreach_In_Config is new Foreach_Switch (Is_In_Config); + procedure Foreach_Starts_With is new Foreach_Switch (Starts_With); + + -- Start of processing for For_Each_Simple_Switch + + begin + -- First determine if the switch corresponds to one belonging to the + -- configuration. If so, run callback and exit. + + -- ??? Is this necessary. On simple tests, we seem to have the same + -- results with or without this call. + + Foreach_In_Config (Config, Section); + + if Found_In_Config then + return; + end if; + + -- If adding a switch that can in fact be expanded through aliases, + -- add separately each of its expansions. + + -- This takes care of expansions like "-T" -> "-gnatwrs", where the + -- alias and its expansion do not have the same prefix. Given the order + -- in which we do things here, the expansion of the alias will itself + -- be checked for a common prefix and split into simple switches. + + if Unalias + and then Config /= null + and then Config.Aliases /= null + then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section + and then Config.Aliases (A).Alias.all = Switch + and then Parameter = "" + then + For_Each_Simple_Switch + (Config, Section, Config.Aliases (A).Expansion.all, ""); + return; + end if; + end loop; + end if; + + -- If adding a switch grouping several switches, add each of the simple + -- switches instead. + + if Config /= null and then Config.Prefixes /= null then + for P in Config.Prefixes'Range loop + if Switch'Length > Config.Prefixes (P)'Length + 1 + and then + Looking_At (Switch, Switch'First, Config.Prefixes (P).all) + then + -- Alias expansion will be done recursively + + if Config.Switches = null then + for S in Switch'First + Config.Prefixes (P)'Length + .. Switch'Last + loop + For_Each_Simple_Switch + (Config, Section, + Config.Prefixes (P).all & Switch (S), ""); + end loop; + + return; + + elsif Group_Analysis + (Config.Prefixes (P).all, + Switch + (Switch'First + Config.Prefixes (P)'Length .. Switch'Last)) + then + -- Recursive calls already done on each switch of the group: + -- Return without executing Callback. + + return; + end if; + end if; + end loop; + end if; + + -- Test if added switch is a known switch with parameter attached + -- instead of being specified separately + + if Parameter = "" + and then Config /= null + and then Config.Switches /= null + then + Found_In_Config := False; + Foreach_Starts_With (Config, Section); + + if Found_In_Config then + return; + end if; + end if; + + -- The switch is invalid in the config, but we still want to report it. + -- The config could, for instance, include "*" to specify it accepts + -- all switches. + + Callback (Switch, " ", Parameter, Index => -1); + end For_Each_Simple_Switch; + + ---------------- + -- Add_Switch -- + ---------------- + + procedure Add_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ASCII.NUL; + Section : String := ""; + Add_Before : Boolean := False) + is + Success : Boolean; + pragma Unreferenced (Success); + begin + Add_Switch (Cmd, Switch, Parameter, Separator, + Section, Add_Before, Success); + end Add_Switch; + + ---------------- + -- Add_Switch -- + ---------------- + + procedure Add_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ASCII.NUL; + Section : String := ""; + Add_Before : Boolean := False; + Success : out Boolean) + is + procedure Add_Simple_Switch + (Simple : String; + Sepa : String; + Param : String; + Index : Integer); + -- Add a new switch that has had all its aliases expanded, and switches + -- ungrouped. We know there are no more aliases in Switches. + + ----------------------- + -- Add_Simple_Switch -- + ----------------------- + + procedure Add_Simple_Switch + (Simple : String; + Sepa : String; + Param : String; + Index : Integer) + is + Sep : Character; + + begin + if Index = -1 + and then Cmd.Config /= null + and then not Cmd.Config.Star_Switch + then + raise Invalid_Switch + with "Invalid switch " & Simple; + end if; + + if Separator /= ASCII.NUL then + Sep := Separator; + + elsif Sepa = "" then + Sep := ASCII.NUL; + else + Sep := Sepa (Sepa'First); + end if; + + if Cmd.Expanded = null then + Cmd.Expanded := new Argument_List'(1 .. 1 => new String'(Simple)); + + if Param /= "" then + Cmd.Params := + new Argument_List'(1 .. 1 => new String'(Sep & Param)); + else + Cmd.Params := new Argument_List'(1 .. 1 => null); + end if; + + if Section = "" then + Cmd.Sections := new Argument_List'(1 .. 1 => null); + else + Cmd.Sections := + new Argument_List'(1 .. 1 => new String'(Section)); + end if; + + else + -- Do we already have this switch? + + for C in Cmd.Expanded'Range loop + if Cmd.Expanded (C).all = Simple + and then + ((Cmd.Params (C) = null and then Param = "") + or else + (Cmd.Params (C) /= null + and then Cmd.Params (C).all = Sep & Param)) + and then + ((Cmd.Sections (C) = null and then Section = "") + or else + (Cmd.Sections (C) /= null + and then Cmd.Sections (C).all = Section)) + then + return; + end if; + end loop; + + -- Inserting at least one switch + + Success := True; + Add (Cmd.Expanded, new String'(Simple), Add_Before); + + if Param /= "" then + Add + (Cmd.Params, + new String'(Sep & Param), + Add_Before); + else + Add + (Cmd.Params, + null, + Add_Before); + end if; + + if Section = "" then + Add + (Cmd.Sections, + null, + Add_Before); + else + Add + (Cmd.Sections, + new String'(Section), + Add_Before); + end if; + end if; + end Add_Simple_Switch; + + procedure Add_Simple_Switches is + new For_Each_Simple_Switch (Add_Simple_Switch); + + -- Local Variables + + Section_Valid : Boolean := False; + + -- Start of processing for Add_Switch + + begin + if Section /= "" and then Cmd.Config /= null then + for S in Cmd.Config.Sections'Range loop + if Section = Cmd.Config.Sections (S).all then + Section_Valid := True; + exit; + end if; + end loop; + + if not Section_Valid then + raise Invalid_Section; + end if; + end if; + + Success := False; + Add_Simple_Switches (Cmd.Config, Section, Switch, Parameter); + Free (Cmd.Coalesce); + end Add_Switch; + + ------------ + -- Remove -- + ------------ + + procedure Remove (Line : in out Argument_List_Access; Index : Integer) is + Tmp : Argument_List_Access := Line; + + begin + Line := new Argument_List (Tmp'First .. Tmp'Last - 1); + + if Index /= Tmp'First then + Line (Tmp'First .. Index - 1) := Tmp (Tmp'First .. Index - 1); + end if; + + Free (Tmp (Index)); + + if Index /= Tmp'Last then + Line (Index .. Tmp'Last - 1) := Tmp (Index + 1 .. Tmp'Last); + end if; + + Unchecked_Free (Tmp); + end Remove; + + --------- + -- Add -- + --------- + + procedure Add + (Line : in out Argument_List_Access; + Str : String_Access; + Before : Boolean := False) + is + Tmp : Argument_List_Access := Line; + + begin + if Tmp /= null then + Line := new Argument_List (Tmp'First .. Tmp'Last + 1); + + if Before then + Line (Tmp'First) := Str; + Line (Tmp'First + 1 .. Tmp'Last + 1) := Tmp.all; + else + Line (Tmp'Range) := Tmp.all; + Line (Tmp'Last + 1) := Str; + end if; + + Unchecked_Free (Tmp); + + else + Line := new Argument_List'(1 .. 1 => Str); + end if; + end Add; + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Remove_All : Boolean := False; + Has_Parameter : Boolean := False; + Section : String := "") + is + Success : Boolean; + pragma Unreferenced (Success); + begin + Remove_Switch (Cmd, Switch, Remove_All, Has_Parameter, Section, Success); + end Remove_Switch; + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Remove_All : Boolean := False; + Has_Parameter : Boolean := False; + Section : String := ""; + Success : out Boolean) + is + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer); + -- Removes a simple switch, with no aliasing or grouping + + -------------------------- + -- Remove_Simple_Switch -- + -------------------------- + + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer) + is + C : Integer; + pragma Unreferenced (Param, Separator, Index); + + begin + if Cmd.Expanded /= null then + C := Cmd.Expanded'First; + while C <= Cmd.Expanded'Last loop + if Cmd.Expanded (C).all = Simple + and then + (Remove_All + or else (Cmd.Sections (C) = null + and then Section = "") + or else (Cmd.Sections (C) /= null + and then Section = Cmd.Sections (C).all)) + and then (not Has_Parameter or else Cmd.Params (C) /= null) + then + Remove (Cmd.Expanded, C); + Remove (Cmd.Params, C); + Remove (Cmd.Sections, C); + Success := True; + + if not Remove_All then + return; + end if; + + else + C := C + 1; + end if; + end loop; + end if; + end Remove_Simple_Switch; + + procedure Remove_Simple_Switches is + new For_Each_Simple_Switch (Remove_Simple_Switch); + + -- Start of processing for Remove_Switch + + begin + Success := False; + Remove_Simple_Switches + (Cmd.Config, Section, Switch, "", Unalias => not Has_Parameter); + Free (Cmd.Coalesce); + end Remove_Switch; + + ------------------- + -- Remove_Switch -- + ------------------- + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String; + Section : String := "") + is + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer); + -- Removes a simple switch, with no aliasing or grouping + + -------------------------- + -- Remove_Simple_Switch -- + -------------------------- + + procedure Remove_Simple_Switch + (Simple, Separator, Param : String; Index : Integer) + is + pragma Unreferenced (Separator, Index); + C : Integer; + + begin + if Cmd.Expanded /= null then + C := Cmd.Expanded'First; + while C <= Cmd.Expanded'Last loop + if Cmd.Expanded (C).all = Simple + and then + ((Cmd.Sections (C) = null + and then Section = "") + or else + (Cmd.Sections (C) /= null + and then Section = Cmd.Sections (C).all)) + and then + ((Cmd.Params (C) = null and then Param = "") + or else + (Cmd.Params (C) /= null + + -- Ignore the separator stored in Parameter + + and then + Cmd.Params (C) (Cmd.Params (C)'First + 1 + .. Cmd.Params (C)'Last) = Param)) + then + Remove (Cmd.Expanded, C); + Remove (Cmd.Params, C); + Remove (Cmd.Sections, C); + + -- The switch is necessarily unique by construction of + -- Add_Switch. + + return; + + else + C := C + 1; + end if; + end loop; + end if; + end Remove_Simple_Switch; + + procedure Remove_Simple_Switches is + new For_Each_Simple_Switch (Remove_Simple_Switch); + + -- Start of processing for Remove_Switch + + begin + Remove_Simple_Switches (Cmd.Config, Section, Switch, Parameter); + Free (Cmd.Coalesce); + end Remove_Switch; + + -------------------- + -- Group_Switches -- + -------------------- + + procedure Group_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Sections : Argument_List_Access; + Params : Argument_List_Access) + is + function Compatible_Parameter (Param : String_Access) return Boolean; + -- True when the parameter can be part of a group + + -------------------------- + -- Compatible_Parameter -- + -------------------------- + + function Compatible_Parameter (Param : String_Access) return Boolean is + begin + -- No parameter OK + + if Param = null then + return True; + + -- We need parameters without separators + + elsif Param (Param'First) /= ASCII.NUL then + return False; + + -- Parameters must be all digits + + else + for J in Param'First + 1 .. Param'Last loop + if Param (J) not in '0' .. '9' then + return False; + end if; + end loop; + + return True; + end if; + end Compatible_Parameter; + + -- Local declarations + + Group : Ada.Strings.Unbounded.Unbounded_String; + First : Natural; + use type Ada.Strings.Unbounded.Unbounded_String; + + -- Start of processing for Group_Switches + + begin + if Cmd.Config = null or else Cmd.Config.Prefixes = null then + return; + end if; + + for P in Cmd.Config.Prefixes'Range loop + Group := Ada.Strings.Unbounded.Null_Unbounded_String; + First := 0; + + for C in Result'Range loop + if Result (C) /= null + and then Compatible_Parameter (Params (C)) + and then Looking_At + (Result (C).all, + Result (C)'First, + Cmd.Config.Prefixes (P).all) + then + -- If we are still in the same section, group the switches + + if First = 0 + or else + (Sections (C) = null + and then Sections (First) = null) + or else + (Sections (C) /= null + and then Sections (First) /= null + and then Sections (C).all = Sections (First).all) + then + Group := + Group & + Result (C) + (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. + Result (C)'Last); + + if Params (C) /= null then + Group := + Group & + Params (C) (Params (C)'First + 1 .. Params (C)'Last); + Free (Params (C)); + end if; + + if First = 0 then + First := C; + end if; + + Free (Result (C)); + + -- We changed section: we put the grouped switches to the first + -- place, on continue with the new section. + + else + Result (First) := + new String' + (Cmd.Config.Prefixes (P).all & + Ada.Strings.Unbounded.To_String (Group)); + Group := + Ada.Strings.Unbounded.To_Unbounded_String + (Result (C) + (Result (C)'First + Cmd.Config.Prefixes (P)'Length .. + Result (C)'Last)); + First := C; + end if; + end if; + end loop; + + if First > 0 then + Result (First) := + new String' + (Cmd.Config.Prefixes (P).all & + Ada.Strings.Unbounded.To_String (Group)); + end if; + end loop; + end Group_Switches; + + -------------------- + -- Alias_Switches -- + -------------------- + + procedure Alias_Switches + (Cmd : Command_Line; + Result : Argument_List_Access; + Params : Argument_List_Access) + is + Found : Boolean; + First : Natural; + + procedure Check_Cb (Switch, Separator, Param : String; Index : Integer); + -- Checks whether the command line contains [Switch]. Sets the global + -- variable [Found] appropriately. This is called for each simple switch + -- that make up an alias, to know whether the alias should be applied. + + procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer); + -- Remove the simple switch [Switch] from the command line, since it is + -- part of a simpler alias + + -------------- + -- Check_Cb -- + -------------- + + procedure Check_Cb + (Switch, Separator, Param : String; Index : Integer) + is + pragma Unreferenced (Separator, Index); + + begin + if Found then + for E in Result'Range loop + if Result (E) /= null + and then + (Params (E) = null + or else Params (E) (Params (E)'First + 1 .. + Params (E)'Last) = Param) + and then Result (E).all = Switch + then + return; + end if; + end loop; + + Found := False; + end if; + end Check_Cb; + + --------------- + -- Remove_Cb -- + --------------- + + procedure Remove_Cb (Switch, Separator, Param : String; Index : Integer) + is + pragma Unreferenced (Separator, Index); + + begin + for E in Result'Range loop + if Result (E) /= null + and then + (Params (E) = null + or else Params (E) (Params (E)'First + 1 + .. Params (E)'Last) = Param) + and then Result (E).all = Switch + then + if First > E then + First := E; + end if; + + Free (Result (E)); + Free (Params (E)); + return; + end if; + end loop; + end Remove_Cb; + + procedure Check_All is new For_Each_Simple_Switch (Check_Cb); + procedure Remove_All is new For_Each_Simple_Switch (Remove_Cb); + + -- Start of processing for Alias_Switches + + begin + if Cmd.Config = null or else Cmd.Config.Aliases = null then + return; + end if; + + for A in Cmd.Config.Aliases'Range loop + + -- Compute the various simple switches that make up the alias. We + -- split the expansion into as many simple switches as possible, and + -- then check whether the expanded command line has all of them. + + Found := True; + Check_All (Cmd.Config, + Switch => Cmd.Config.Aliases (A).Expansion.all, + Section => Cmd.Config.Aliases (A).Section.all); + + if Found then + First := Integer'Last; + Remove_All (Cmd.Config, + Switch => Cmd.Config.Aliases (A).Expansion.all, + Section => Cmd.Config.Aliases (A).Section.all); + Result (First) := new String'(Cmd.Config.Aliases (A).Alias.all); + end if; + end loop; + end Alias_Switches; + + ------------------- + -- Sort_Sections -- + ------------------- + + procedure Sort_Sections + (Line : not null GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access) + is + Sections_List : Argument_List_Access := + new Argument_List'(1 .. 1 => null); + Found : Boolean; + Old_Line : constant Argument_List := Line.all; + Old_Sections : constant Argument_List := Sections.all; + Old_Params : constant Argument_List := Params.all; + Index : Natural; + + begin + -- First construct a list of all sections + + for E in Line'Range loop + if Sections (E) /= null then + Found := False; + for S in Sections_List'Range loop + if (Sections_List (S) = null and then Sections (E) = null) + or else + (Sections_List (S) /= null + and then Sections (E) /= null + and then Sections_List (S).all = Sections (E).all) + then + Found := True; + exit; + end if; + end loop; + + if not Found then + Add (Sections_List, Sections (E)); + end if; + end if; + end loop; + + Index := Line'First; + + for S in Sections_List'Range loop + for E in Old_Line'Range loop + if (Sections_List (S) = null and then Old_Sections (E) = null) + or else + (Sections_List (S) /= null + and then Old_Sections (E) /= null + and then Sections_List (S).all = Old_Sections (E).all) + then + Line (Index) := Old_Line (E); + Sections (Index) := Old_Sections (E); + Params (Index) := Old_Params (E); + Index := Index + 1; + end if; + end loop; + end loop; + + Unchecked_Free (Sections_List); + end Sort_Sections; + + ----------- + -- Start -- + ----------- + + procedure Start + (Cmd : in out Command_Line; + Iter : in out Command_Line_Iterator; + Expanded : Boolean := False) + is + begin + if Cmd.Expanded = null then + Iter.List := null; + return; + end if; + + -- Reorder the expanded line so that sections are grouped + + Sort_Sections (Cmd.Expanded, Cmd.Sections, Cmd.Params); + + -- Coalesce the switches as much as possible + + if not Expanded + and then Cmd.Coalesce = null + then + Cmd.Coalesce := new Argument_List (Cmd.Expanded'Range); + for E in Cmd.Expanded'Range loop + Cmd.Coalesce (E) := new String'(Cmd.Expanded (E).all); + end loop; + + Free (Cmd.Coalesce_Sections); + Cmd.Coalesce_Sections := new Argument_List (Cmd.Sections'Range); + for E in Cmd.Sections'Range loop + Cmd.Coalesce_Sections (E) := + (if Cmd.Sections (E) = null then null + else new String'(Cmd.Sections (E).all)); + end loop; + + Free (Cmd.Coalesce_Params); + Cmd.Coalesce_Params := new Argument_List (Cmd.Params'Range); + for E in Cmd.Params'Range loop + Cmd.Coalesce_Params (E) := + (if Cmd.Params (E) = null then null + else new String'(Cmd.Params (E).all)); + end loop; + + -- Not a clone, since we will not modify the parameters anyway + + Alias_Switches (Cmd, Cmd.Coalesce, Cmd.Coalesce_Params); + Group_Switches + (Cmd, Cmd.Coalesce, Cmd.Coalesce_Sections, Cmd.Coalesce_Params); + end if; + + if Expanded then + Iter.List := Cmd.Expanded; + Iter.Params := Cmd.Params; + Iter.Sections := Cmd.Sections; + else + Iter.List := Cmd.Coalesce; + Iter.Params := Cmd.Coalesce_Params; + Iter.Sections := Cmd.Coalesce_Sections; + end if; + + if Iter.List = null then + Iter.Current := Integer'Last; + else + Iter.Current := Iter.List'First - 1; + Next (Iter); + end if; + end Start; + + -------------------- + -- Current_Switch -- + -------------------- + + function Current_Switch (Iter : Command_Line_Iterator) return String is + begin + return Iter.List (Iter.Current).all; + end Current_Switch; + + -------------------- + -- Is_New_Section -- + -------------------- + + function Is_New_Section (Iter : Command_Line_Iterator) return Boolean is + Section : constant String := Current_Section (Iter); + + begin + if Iter.Sections = null then + return False; + + elsif Iter.Current = Iter.Sections'First + or else Iter.Sections (Iter.Current - 1) = null + then + return Section /= ""; + + else + return Section /= Iter.Sections (Iter.Current - 1).all; + end if; + end Is_New_Section; + + --------------------- + -- Current_Section -- + --------------------- + + function Current_Section (Iter : Command_Line_Iterator) return String is + begin + if Iter.Sections = null + or else Iter.Current > Iter.Sections'Last + or else Iter.Sections (Iter.Current) = null + then + return ""; + end if; + + return Iter.Sections (Iter.Current).all; + end Current_Section; + + ----------------------- + -- Current_Separator -- + ----------------------- + + function Current_Separator (Iter : Command_Line_Iterator) return String is + begin + if Iter.Params = null + or else Iter.Current > Iter.Params'Last + or else Iter.Params (Iter.Current) = null + then + return ""; + + else + declare + Sep : constant Character := + Iter.Params (Iter.Current) (Iter.Params (Iter.Current)'First); + begin + if Sep = ASCII.NUL then + return ""; + else + return "" & Sep; + end if; + end; + end if; + end Current_Separator; + + ----------------------- + -- Current_Parameter -- + ----------------------- + + function Current_Parameter (Iter : Command_Line_Iterator) return String is + begin + if Iter.Params = null + or else Iter.Current > Iter.Params'Last + or else Iter.Params (Iter.Current) = null + then + return ""; + + else + -- Return result, skipping separator + + declare + P : constant String := Iter.Params (Iter.Current).all; + begin + return P (P'First + 1 .. P'Last); + end; + end if; + end Current_Parameter; + + -------------- + -- Has_More -- + -------------- + + function Has_More (Iter : Command_Line_Iterator) return Boolean is + begin + return Iter.List /= null and then Iter.Current <= Iter.List'Last; + end Has_More; + + ---------- + -- Next -- + ---------- + + procedure Next (Iter : in out Command_Line_Iterator) is + begin + Iter.Current := Iter.Current + 1; + while Iter.Current <= Iter.List'Last + and then Iter.List (Iter.Current) = null + loop + Iter.Current := Iter.Current + 1; + end loop; + end Next; + + ---------- + -- Free -- + ---------- + + procedure Free (Config : in out Command_Line_Configuration) is + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation + (Switch_Definitions, Switch_Definitions_List); + + procedure Unchecked_Free is new + Ada.Unchecked_Deallocation + (Alias_Definitions, Alias_Definitions_List); + + begin + if Config /= null then + Free (Config.Prefixes); + Free (Config.Sections); + Free (Config.Usage); + Free (Config.Help); + Free (Config.Help_Msg); + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + Free (Config.Aliases (A).Alias); + Free (Config.Aliases (A).Expansion); + Free (Config.Aliases (A).Section); + end loop; + + Unchecked_Free (Config.Aliases); + end if; + + if Config.Switches /= null then + for S in Config.Switches'Range loop + Free (Config.Switches (S).Switch); + Free (Config.Switches (S).Long_Switch); + Free (Config.Switches (S).Help); + Free (Config.Switches (S).Section); + Free (Config.Switches (S).Argument); + end loop; + + Unchecked_Free (Config.Switches); + end if; + + Unchecked_Free (Config); + end if; + end Free; + + ---------- + -- Free -- + ---------- + + procedure Free (Cmd : in out Command_Line) is + begin + Free (Cmd.Expanded); + Free (Cmd.Coalesce); + Free (Cmd.Coalesce_Sections); + Free (Cmd.Coalesce_Params); + Free (Cmd.Params); + Free (Cmd.Sections); + end Free; + + --------------- + -- Set_Usage -- + --------------- + + procedure Set_Usage + (Config : in out Command_Line_Configuration; + Usage : String := "[switches] [arguments]"; + Help : String := ""; + Help_Msg : String := "") + is + begin + if Config = null then + Config := new Command_Line_Configuration_Record; + end if; + + Free (Config.Usage); + Free (Config.Help); + Free (Config.Help_Msg); + + Config.Usage := new String'(Usage); + Config.Help := new String'(Help); + Config.Help_Msg := new String'(Help_Msg); + end Set_Usage; + + ------------------ + -- Display_Help -- + ------------------ + + procedure Display_Help (Config : Command_Line_Configuration) is + function Switch_Name + (Def : Switch_Definition; + Section : String) return String; + -- Return the "-short, --long=ARG" string for Def. + -- Returns "" if the switch is not in the section. + + function Param_Name + (P : Switch_Parameter_Type; + Name : String := "ARG") return String; + -- Return the display for a switch parameter + + procedure Display_Section_Help (Section : String); + -- Display the help for a specific section ("" is the default section) + + -------------------------- + -- Display_Section_Help -- + -------------------------- + + procedure Display_Section_Help (Section : String) is + Max_Len : Natural := 0; + + begin + -- ??? Special display for "*" + + New_Line; + + if Section /= "" and then Config.Switches /= null then + Put_Line ("Switches after " & Section); + end if; + + -- Compute size of the switches column + + if Config.Switches /= null then + for S in Config.Switches'Range loop + Max_Len := Natural'Max + (Max_Len, Switch_Name (Config.Switches (S), Section)'Length); + end loop; + end if; + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section then + Max_Len := Natural'Max + (Max_Len, Config.Aliases (A).Alias'Length); + end if; + end loop; + end if; + + -- Display the switches + + if Config.Switches /= null then + for S in Config.Switches'Range loop + declare + N : constant String := + Switch_Name (Config.Switches (S), Section); + + begin + if N /= "" then + Put (" "); + Put (N); + Put ((1 .. Max_Len - N'Length + 1 => ' ')); + + if Config.Switches (S).Help /= null then + Put (Config.Switches (S).Help.all); + end if; + + New_Line; + end if; + end; + end loop; + end if; + + -- Display the aliases + + if Config.Aliases /= null then + for A in Config.Aliases'Range loop + if Config.Aliases (A).Section.all = Section then + Put (" "); + Put (Config.Aliases (A).Alias.all); + Put ((1 .. Max_Len - Config.Aliases (A).Alias'Length + 1 + => ' ')); + Put ("Equivalent to " & Config.Aliases (A).Expansion.all); + New_Line; + end if; + end loop; + end if; + end Display_Section_Help; + + ---------------- + -- Param_Name -- + ---------------- + + function Param_Name + (P : Switch_Parameter_Type; + Name : String := "ARG") return String + is + begin + case P is + when Parameter_None => + return ""; + + when Parameter_With_Optional_Space => + return " " & To_Upper (Name); + + when Parameter_With_Space_Or_Equal => + return "=" & To_Upper (Name); + + when Parameter_No_Space => + return To_Upper (Name); + + when Parameter_Optional => + return '[' & To_Upper (Name) & ']'; + end case; + end Param_Name; + + ----------------- + -- Switch_Name -- + ----------------- + + function Switch_Name + (Def : Switch_Definition; + Section : String) return String + is + use Ada.Strings.Unbounded; + Result : Unbounded_String; + P1, P2 : Switch_Parameter_Type; + Last1, Last2 : Integer := 0; + + begin + if (Section = "" and then Def.Section = null) + or else (Def.Section /= null and then Def.Section.all = Section) + then + if Def.Switch /= null and then Def.Switch.all = "*" then + return "[any switch]"; + end if; + + if Def.Switch /= null then + Decompose_Switch (Def.Switch.all, P1, Last1); + Append (Result, Def.Switch (Def.Switch'First .. Last1)); + + if Def.Long_Switch /= null then + Decompose_Switch (Def.Long_Switch.all, P2, Last2); + Append (Result, ", " + & Def.Long_Switch (Def.Long_Switch'First .. Last2)); + + if Def.Argument = null then + Append (Result, Param_Name (P2, "ARG")); + else + Append (Result, Param_Name (P2, Def.Argument.all)); + end if; + + else + if Def.Argument = null then + Append (Result, Param_Name (P1, "ARG")); + else + Append (Result, Param_Name (P1, Def.Argument.all)); + end if; + end if; + + -- Def.Switch is null (Long_Switch must be non-null) + + else + Decompose_Switch (Def.Long_Switch.all, P2, Last2); + Append (Result, + Def.Long_Switch (Def.Long_Switch'First .. Last2)); + + if Def.Argument = null then + Append (Result, Param_Name (P2, "ARG")); + else + Append (Result, Param_Name (P2, Def.Argument.all)); + end if; + end if; + end if; + + return To_String (Result); + end Switch_Name; + + -- Start of processing for Display_Help + + begin + if Config = null then + return; + end if; + + if Config.Help /= null and then Config.Help.all /= "" then + Put_Line (Config.Help.all); + end if; + + if Config.Usage /= null then + Put_Line ("Usage: " + & Base_Name + (Ada.Command_Line.Command_Name) & " " & Config.Usage.all); + else + Put_Line ("Usage: " & Base_Name (Ada.Command_Line.Command_Name) + & " [switches] [arguments]"); + end if; + + if Config.Help_Msg /= null and then Config.Help_Msg.all /= "" then + Put_Line (Config.Help_Msg.all); + + else + Display_Section_Help (""); + + if Config.Sections /= null and then Config.Switches /= null then + for S in Config.Sections'Range loop + Display_Section_Help (Config.Sections (S).all); + end loop; + end if; + end if; + end Display_Help; + + ------------ + -- Getopt -- + ------------ + + procedure Getopt + (Config : Command_Line_Configuration; + Callback : Switch_Handler := null; + Parser : Opt_Parser := Command_Line_Parser; + Concatenate : Boolean := True) + is + Getopt_Switches : String_Access; + C : Character := ASCII.NUL; + + Empty_Name : aliased constant String := ""; + Current_Section : Integer := -1; + Section_Name : not null access constant String := Empty_Name'Access; + + procedure Simple_Callback + (Simple_Switch : String; + Separator : String; + Parameter : String; + Index : Integer); + -- Needs comments ??? + + procedure Do_Callback (Switch, Parameter : String; Index : Integer); + + ----------------- + -- Do_Callback -- + ----------------- + + procedure Do_Callback (Switch, Parameter : String; Index : Integer) is + begin + -- Do automatic handling when possible + + if Index /= -1 then + case Config.Switches (Index).Typ is + when Switch_Untyped => + null; -- no automatic handling + + when Switch_Boolean => + Config.Switches (Index).Boolean_Output.all := + Config.Switches (Index).Boolean_Value; + return; + + when Switch_Integer => + begin + if Parameter = "" then + Config.Switches (Index).Integer_Output.all := + Config.Switches (Index).Integer_Default; + else + Config.Switches (Index).Integer_Output.all := + Integer'Value (Parameter); + end if; + + exception + when Constraint_Error => + raise Invalid_Parameter + with "Expected integer parameter for '" + & Switch & "'"; + end; + + return; + + when Switch_String => + Free (Config.Switches (Index).String_Output.all); + Config.Switches (Index).String_Output.all := + new String'(Parameter); + return; + end case; + end if; + + -- Otherwise calls the user callback if one was defined + + if Callback /= null then + Callback (Switch => Switch, + Parameter => Parameter, + Section => Section_Name.all); + end if; + end Do_Callback; + + procedure For_Each_Simple + is new For_Each_Simple_Switch (Simple_Callback); + + --------------------- + -- Simple_Callback -- + --------------------- + + procedure Simple_Callback + (Simple_Switch : String; + Separator : String; + Parameter : String; + Index : Integer) + is + pragma Unreferenced (Separator); + begin + Do_Callback (Switch => Simple_Switch, + Parameter => Parameter, + Index => Index); + end Simple_Callback; + + -- Start of processing for Getopt + + begin + -- Initialize sections + + if Config.Sections = null then + Config.Sections := new Argument_List'(1 .. 0 => null); + end if; + + Internal_Initialize_Option_Scan + (Parser => Parser, + Switch_Char => Parser.Switch_Character, + Stop_At_First_Non_Switch => Parser.Stop_At_First, + Section_Delimiters => Section_Delimiters (Config)); + + Getopt_Switches := new String' + (Get_Switches (Config, Parser.Switch_Character, Section_Name.all) + & " h -help"); + + -- Initialize output values for automatically handled switches + + if Config.Switches /= null then + for S in Config.Switches'Range loop + case Config.Switches (S).Typ is + when Switch_Untyped => + null; -- Nothing to do + + when Switch_Boolean => + Config.Switches (S).Boolean_Output.all := + not Config.Switches (S).Boolean_Value; + + when Switch_Integer => + Config.Switches (S).Integer_Output.all := + Config.Switches (S).Integer_Initial; + + when Switch_String => + if Config.Switches (S).String_Output.all = null then + Config.Switches (S).String_Output.all := new String'(""); + end if; + end case; + end loop; + end if; + + -- For all sections, and all switches within those sections + + loop + C := Getopt (Switches => Getopt_Switches.all, + Concatenate => Concatenate, + Parser => Parser); + + if C = '*' then + -- Full_Switch already includes the leading '-' + + Do_Callback (Switch => Full_Switch (Parser), + Parameter => Parameter (Parser), + Index => -1); + + elsif C /= ASCII.NUL then + if Full_Switch (Parser) = "h" + or else + Full_Switch (Parser) = "-help" + then + Display_Help (Config); + raise Exit_From_Command_Line; + end if; + + -- Do switch expansion if needed + + For_Each_Simple + (Config, + Section => Section_Name.all, + Switch => Parser.Switch_Character & Full_Switch (Parser), + Parameter => Parameter (Parser)); + + else + if Current_Section = -1 then + Current_Section := Config.Sections'First; + else + Current_Section := Current_Section + 1; + end if; + + exit when Current_Section > Config.Sections'Last; + + Section_Name := Config.Sections (Current_Section); + Goto_Section (Section_Name.all, Parser); + + Free (Getopt_Switches); + Getopt_Switches := new String' + (Get_Switches + (Config, Parser.Switch_Character, Section_Name.all)); + end if; + end loop; + + Free (Getopt_Switches); + + exception + when Invalid_Switch => + Free (Getopt_Switches); + + -- Message inspired by "ls" on Unix + + Put_Line (Standard_Error, + Base_Name (Ada.Command_Line.Command_Name) + & ": unrecognized option '" + & Full_Switch (Parser) + & "'"); + Try_Help; + + raise; + + when others => + Free (Getopt_Switches); + raise; + end Getopt; + + ----------- + -- Build -- + ----------- + + procedure Build + (Line : in out Command_Line; + Args : out GNAT.OS_Lib.Argument_List_Access; + Expanded : Boolean := False; + Switch_Char : Character := '-') + is + Iter : Command_Line_Iterator; + Count : Natural := 0; + + begin + Start (Line, Iter, Expanded => Expanded); + while Has_More (Iter) loop + if Is_New_Section (Iter) then + Count := Count + 1; + end if; + + Count := Count + 1; + Next (Iter); + end loop; + + Args := new Argument_List (1 .. Count); + Count := Args'First; + + Start (Line, Iter, Expanded => Expanded); + while Has_More (Iter) loop + if Is_New_Section (Iter) then + Args (Count) := new String'(Switch_Char & Current_Section (Iter)); + Count := Count + 1; + end if; + + Args (Count) := new String'(Current_Switch (Iter) + & Current_Separator (Iter) + & Current_Parameter (Iter)); + Count := Count + 1; + Next (Iter); + end loop; + end Build; + + -------------- + -- Try_Help -- + -------------- + + -- Note: Any change to the message displayed should also be done in + -- gnatbind.adb that does not use this interface. + + procedure Try_Help is + begin + Put_Line + (Standard_Error, + "try """ & Base_Name (Ada.Command_Line.Command_Name, Suffix => ".exe") + & " --help"" for more information."); + end Try_Help; + +end GNAT.Command_Line; diff --git a/gcc/ada/libgnat/g-comlin.ads b/gcc/ada/libgnat/g-comlin.ads new file mode 100644 index 0000000..4ad239b --- /dev/null +++ b/gcc/ada/libgnat/g-comlin.ads @@ -0,0 +1,1201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M M A N D _ L I N E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- High level package for command line parsing and manipulation + +---------------------------------------- +-- Simple Parsing of the Command Line -- +---------------------------------------- + +-- This package provides an interface for parsing command line arguments, +-- when they are either read from Ada.Command_Line or read from a string list. +-- As shown in the example below, one should first retrieve the switches +-- (special command line arguments starting with '-' by default) and their +-- parameters, and then the rest of the command line arguments. +-- +-- While it may appear easy to parse the command line arguments with +-- Ada.Command_Line, there are in fact lots of special cases to handle in some +-- applications. Those are fully managed by GNAT.Command_Line. Among these are +-- switches with optional parameters, grouping switches (for instance "-ab" +-- might mean the same as "-a -b"), various characters to separate a switch +-- and its parameter (or none: "-a 1" and "-a1" are generally the same, which +-- can introduce confusion with grouped switches),... +-- +-- begin +-- loop +-- case Getopt ("a b: ad") is -- Accepts '-a', '-ad', or '-b argument' +-- when ASCII.NUL => exit; + +-- when 'a' => +-- if Full_Switch = "a" then +-- Put_Line ("Got a"); +-- else +-- Put_Line ("Got ad"); +-- end if; + +-- when 'b' => Put_Line ("Got b + " & Parameter); + +-- when others => +-- raise Program_Error; -- cannot occur +-- end case; +-- end loop; + +-- loop +-- declare +-- S : constant String := Get_Argument (Do_Expansion => True); +-- begin +-- exit when S'Length = 0; +-- Put_Line ("Got " & S); +-- end; +-- end loop; + +-- exception +-- when Invalid_Switch => Put_Line ("Invalid Switch " & Full_Switch); +-- when Invalid_Parameter => Put_Line ("No parameter for " & Full_Switch); +-- end; + +-------------- +-- Sections -- +-------------- + +-- A more complicated example would involve the use of sections for the +-- switches, as for instance in gnatmake. The same command line is used to +-- provide switches for several tools. Each tool recognizes its switches by +-- separating them with special switches that act as section separators. +-- Each section acts as a command line of its own. + +-- begin +-- Initialize_Option_Scan ('-', False, "largs bargs cargs"); +-- loop +-- -- Same loop as above to get switches and arguments +-- end loop; + +-- Goto_Section ("bargs"); +-- loop +-- -- Same loop as above to get switches and arguments +-- -- The supported switches in Getopt might be different +-- end loop; + +-- Goto_Section ("cargs"); +-- loop +-- -- Same loop as above to get switches and arguments +-- -- The supported switches in Getopt might be different +-- end loop; +-- end; + +------------------------------- +-- Parsing a List of Strings -- +------------------------------- + +-- The examples above show how to parse the command line when the arguments +-- are read directly from Ada.Command_Line. However, these arguments can also +-- be read from a list of strings. This can be useful in several contexts, +-- either because your system does not support Ada.Command_Line, or because +-- you are manipulating other tools and creating their command lines by hand, +-- or for any other reason. + +-- To create the list of strings, it is recommended to use +-- GNAT.OS_Lib.Argument_String_To_List. + +-- The example below shows how to get the parameters from such a list. Note +-- also the use of '*' to get all the switches, and not report errors when an +-- unexpected switch was used by the user + +-- declare +-- Parser : Opt_Parser; +-- Args : constant Argument_List_Access := +-- GNAT.OS_Lib.Argument_String_To_List ("-g -O1 -Ipath"); +-- begin +-- Initialize_Option_Scan (Parser, Args); +-- while Getopt ("* g O! I=", Parser) /= ASCII.NUL loop +-- Put_Line ("Switch " & Full_Switch (Parser) +-- & " param=" & Parameter (Parser)); +-- end loop; +-- Free (Parser); +-- end; + +------------------------------------------- +-- High-Level Command Line Configuration -- +------------------------------------------- + +-- As shown above, the code is still relatively low-level. For instance, there +-- is no way to indicate which switches are related (thus if "-l" and "--long" +-- should have the same effect, your code will need to test for both cases). +-- Likewise, it is difficult to handle more advanced constructs, like: + +-- * Specifying -gnatwa is the same as specifying -gnatwu -gnatwv, but +-- shorter and more readable + +-- * All switches starting with -gnatw can be grouped, for instance one +-- can write -gnatwcd instead of -gnatwc -gnatwd. +-- Of course, this can be combined with the above and -gnatwacd is the +-- same as -gnatwc -gnatwd -gnatwu -gnatwv + +-- * The switch -T is the same as -gnatwAB (same as -gnatwA -gnatwB) + +-- With the above form of Getopt, you would receive "-gnatwa", "-T" or +-- "-gnatwcd" in the examples above, and thus you require additional manual +-- parsing of the switch. + +-- Instead, this package provides the type Command_Line_Configuration, which +-- stores all the knowledge above. For instance: + +-- Config : Command_Line_Configuration; +-- Define_Alias (Config, "-gnatwa", "-gnatwu -gnatwv"); +-- Define_Prefix (Config, "-gnatw"); +-- Define_Alias (Config, "-T", "-gnatwAB"); + +-- You then need to specify all possible switches in your application by +-- calling Define_Switch, for instance: + +-- Define_Switch (Config, "-gnatwu", Help => "warn on unused entities"); +-- Define_Switch (Config, "-gnatwv", Help => "warn on unassigned var"); +-- ... + +-- Specifying the help message is optional, but makes it easy to then call +-- the function: + +-- Display_Help (Config); + +-- that will display a properly formatted help message for your application, +-- listing all possible switches. That way you have a single place in which +-- to maintain the list of switches and their meaning, rather than maintaining +-- both the string to pass to Getopt and a subprogram to display the help. +-- Both will properly stay synchronized. + +-- Once you have this Config, you just have to call: + +-- Getopt (Config, Callback'Access); + +-- to parse the command line. The Callback will be called for each switch +-- found on the command line (in the case of our example, that is "-gnatwu" +-- and then "-gnatwv", not "-gnatwa" itself). This simplifies command line +-- parsing a lot. + +-- In fact, this can be further automated for the most command case where the +-- parameter passed to a switch is stored in a variable in the application. +-- When a switch is defined, you only have to indicate where to store the +-- value, and let Getopt do the rest. For instance: + +-- Optimization : aliased Integer; +-- Verbose : aliased Boolean; + +-- Define_Switch (Config, Verbose'Access, +-- "-v", Long_Switch => "--verbose", +-- Help => "Output extra verbose information"); +-- Define_Switch (Config, Optimization'Access, +-- "-O?", Help => "Optimization level"); + +-- Getopt (Config); -- No callback + +-- Since all switches are handled automatically, we don't even need to pass +-- a callback to Getopt. Once getopt has been called, the two variables +-- Optimization and Verbose have been properly initialized, either to the +-- default value or to the value found on the command line. + +------------------------------------------------ +-- Creating and Manipulating the Command Line -- +------------------------------------------------ + +-- This package provides mechanisms to create and modify command lines by +-- adding or removing arguments from them. The resulting command line is kept +-- as short as possible by coalescing arguments whenever possible. + +-- Complex command lines can thus be constructed, for example from a GUI +-- (although this package does not by itself depend upon any specific GUI +-- toolkit). + +-- Using the configuration defined earlier, one can then construct a command +-- line for the tool with: + +-- Cmd : Command_Line; +-- Set_Configuration (Cmd, Config); -- Config created earlier +-- Add_Switch (Cmd, "-bar"); +-- Add_Switch (Cmd, "-gnatwu"); +-- Add_Switch (Cmd, "-gnatwv"); -- will be grouped with the above +-- Add_Switch (Cmd, "-T"); + +-- The resulting command line can be iterated over to get all its switches, +-- There are two modes for this iteration: either you want to get the +-- shortest possible command line, which would be: + +-- -bar -gnatwaAB + +-- or on the other hand you want each individual switch (so that your own +-- tool does not have to do further complex processing), which would be: + +-- -bar -gnatwu -gnatwv -gnatwA -gnatwB + +-- Of course, we can assume that the tool you want to spawn would understand +-- both of these, since they are both compatible with the description we gave +-- above. However, the first result is useful if you want to show the user +-- what you are spawning (since that keeps the output shorter), and the second +-- output is more useful for a tool that would check whether -gnatwu was +-- passed (which isn't obvious in the first output). Likewise, the second +-- output is more useful if you have a graphical interface since each switch +-- can be associated with a widget, and you immediately know whether -gnatwu +-- was selected. +-- +-- Some command line arguments can have parameters, which on a command line +-- appear as a separate argument that must immediately follow the switch. +-- Since the subprograms in this package will reorganize the switches to group +-- them, you need to indicate what is a command line parameter, and what is a +-- switch argument. + +-- This is done by passing an extra argument to Add_Switch, as in: + +-- Add_Switch (Cmd, "-foo", Parameter => "arg1"); + +-- This ensures that "arg1" will always be treated as the argument to -foo, +-- and will not be grouped with other parts of the command line. + +with Ada.Command_Line; + +with GNAT.Directory_Operations; +with GNAT.OS_Lib; +with GNAT.Regexp; +with GNAT.Strings; + +package GNAT.Command_Line is + + ------------- + -- Parsing -- + ------------- + + type Opt_Parser is private; + Command_Line_Parser : constant Opt_Parser; + -- This object is responsible for parsing a list of arguments, which by + -- default are the standard command line arguments from Ada.Command_Line. + -- This is really a pointer to actual data, which must therefore be + -- initialized through a call to Initialize_Option_Scan, and must be freed + -- with a call to Free. + -- + -- As a special case, Command_Line_Parser does not need to be either + -- initialized or free-ed. + + procedure Initialize_Option_Scan + (Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := ""); + procedure Initialize_Option_Scan + (Parser : out Opt_Parser; + Command_Line : GNAT.OS_Lib.Argument_List_Access; + Switch_Char : Character := '-'; + Stop_At_First_Non_Switch : Boolean := False; + Section_Delimiters : String := ""); + -- The first procedure resets the internal state of the package to prepare + -- to rescan the parameters. It does not need to be called before the + -- first use of Getopt (but it could be), but it must be called if you + -- want to start rescanning the command line parameters from the start. + -- The optional parameter Switch_Char can be used to reset the switch + -- character, e.g. to '/' for use in DOS-like systems. + -- + -- The second subprogram initializes a parser that takes its arguments + -- from an array of strings rather than directly from the command line. In + -- this case, the parser is responsible for freeing the strings stored in + -- Command_Line. If you pass null to Command_Line, this will in fact create + -- a second parser for Ada.Command_Line, which doesn't share any data with + -- the default parser. This parser must be free'ed. + -- + -- The optional parameter Stop_At_First_Non_Switch indicates if Getopt is + -- to look for switches on the whole command line, or if it has to stop as + -- soon as a non-switch argument is found. + -- + -- Example: + -- + -- Arguments: my_application file1 -c + -- + -- If Stop_At_First_Non_Switch is False, then -c will be considered + -- as a switch (returned by getopt), otherwise it will be considered + -- as a normal argument (returned by Get_Argument). + -- + -- If Section_Delimiters is set, then every following subprogram + -- (Getopt and Get_Argument) will only operate within a section, which + -- is delimited by any of these delimiters or the end of the command line. + -- + -- Example: + -- Initialize_Option_Scan (Section_Delimiters => "largs bargs cargs"); + -- + -- Arguments on command line : my_application -c -bargs -d -e -largs -f + -- This line contains three sections, the first one is the default one + -- and includes only the '-c' switch, the second one is between -bargs + -- and -largs and includes '-d -e' and the last one includes '-f'. + + procedure Free (Parser : in out Opt_Parser); + -- Free the memory used by the parser. Calling this is not mandatory for + -- the Command_Line_Parser + + procedure Goto_Section + (Name : String := ""; + Parser : Opt_Parser := Command_Line_Parser); + -- Change the current section. The next Getopt or Get_Argument will start + -- looking at the beginning of the section. An empty name ("") refers to + -- the first section between the program name and the first section + -- delimiter. If the section does not exist in Section_Delimiters, then + -- Invalid_Section is raised. If the section does not appear on the command + -- line, then it is treated as an empty section. + + function Full_Switch + (Parser : Opt_Parser := Command_Line_Parser) return String; + -- Returns the full name of the last switch found (Getopt only returns the + -- first character). Does not include the Switch_Char ('-' by default), + -- unless the "*" option of Getopt is used (see below). + + function Current_Section + (Parser : Opt_Parser := Command_Line_Parser) return String; + -- Return the name of the current section. + -- The list of valid sections is defined through Initialize_Option_Scan + + function Getopt + (Switches : String; + Concatenate : Boolean := True; + Parser : Opt_Parser := Command_Line_Parser) return Character; + -- This function moves to the next switch on the command line (defined as + -- switch character followed by a character within Switches, casing being + -- significant). The result returned is the first character of the switch + -- that is located. If there are no more switches in the current section, + -- returns ASCII.NUL. If Concatenate is True (the default), the switches do + -- not need to be separated by spaces (they can be concatenated if they do + -- not require an argument, e.g. -ab is the same as two separate arguments + -- -a -b). + -- + -- Switches is a string of all the possible switches, separated by + -- spaces. A switch can be followed by one of the following characters: + -- + -- ':' The switch requires a parameter. There can optionally be a space + -- on the command line between the switch and its parameter. + -- + -- '=' The switch requires a parameter. There can either be a '=' or a + -- space on the command line between the switch and its parameter. + -- + -- '!' The switch requires a parameter, but there can be no space on the + -- command line between the switch and its parameter. + -- + -- '?' The switch may have an optional parameter. There can be no space + -- between the switch and its argument. + -- + -- e.g. if Switches has the following value : "a? b", + -- The command line can be: + -- + -- -afoo : -a switch with 'foo' parameter + -- -a foo : -a switch and another element on the + -- command line 'foo', returned by Get_Argument + -- + -- Example: if Switches is "-a: -aO:", you can have the following + -- command lines: + -- + -- -aarg : 'a' switch with 'arg' parameter + -- -a arg : 'a' switch with 'arg' parameter + -- -aOarg : 'aO' switch with 'arg' parameter + -- -aO arg : 'aO' switch with 'arg' parameter + -- + -- Example: + -- + -- Getopt ("a b: ac ad?") + -- + -- accept either 'a' or 'ac' with no argument, + -- accept 'b' with a required argument + -- accept 'ad' with an optional argument + -- + -- If the first item in switches is '*', then Getopt will catch + -- every element on the command line that was not caught by any other + -- switch. The character returned by GetOpt is '*', but Full_Switch + -- contains the full command line argument, including leading '-' if there + -- is one. If this character was not returned, there would be no way of + -- knowing whether it is there or not. + -- + -- Example + -- Getopt ("* a b") + -- If the command line is '-a -c toto.o -b', Getopt will return + -- successively 'a', '*', '*' and 'b', with Full_Switch returning + -- "a", "-c", "toto.o", and "b". + -- + -- When Getopt encounters an invalid switch, it raises the exception + -- Invalid_Switch and sets Full_Switch to return the invalid switch. + -- When Getopt cannot find the parameter associated with a switch, it + -- raises Invalid_Parameter, and sets Full_Switch to return the invalid + -- switch. + -- + -- Note: in case of ambiguity, e.g. switches a ab abc, then the longest + -- matching switch is returned. + -- + -- Arbitrary characters are allowed for switches, although it is + -- strongly recommended to use only letters and digits for portability + -- reasons. + -- + -- When Concatenate is False, individual switches need to be separated by + -- spaces. + -- + -- Example + -- Getopt ("a b", Concatenate => False) + -- If the command line is '-ab', exception Invalid_Switch will be + -- raised and Full_Switch will return "ab". + + function Get_Argument + (Do_Expansion : Boolean := False; + Parser : Opt_Parser := Command_Line_Parser) return String; + -- Returns the next element on the command line that is not a switch. This + -- function should not be called before Getopt has returned ASCII.NUL. + -- + -- If Do_Expansion is True, then the parameter on the command line will + -- be considered as a filename with wild cards, and will be expanded. The + -- matching file names will be returned one at a time. This is useful in + -- non-Unix systems for obtaining normal expansion of wild card references. + -- When there are no more arguments on the command line, this function + -- returns an empty string. + + function Parameter + (Parser : Opt_Parser := Command_Line_Parser) return String; + -- Returns parameter associated with the last switch returned by Getopt. + -- If no parameter was associated with the last switch, or no previous call + -- has been made to Get_Argument, raises Invalid_Parameter. If the last + -- switch was associated with an optional argument and this argument was + -- not found on the command line, Parameter returns an empty string. + + function Separator + (Parser : Opt_Parser := Command_Line_Parser) return Character; + -- The separator that was between the switch and its parameter. This is + -- useful if you want to know exactly what was on the command line. This + -- is in general a single character, set to ASCII.NUL if the switch and + -- the parameter were concatenated. A space is returned if the switch and + -- its argument were in two separate arguments. + + Invalid_Section : exception; + -- Raised when an invalid section is selected by Goto_Section + + Invalid_Switch : exception; + -- Raised when an invalid switch is detected in the command line + + Invalid_Parameter : exception; + -- Raised when a parameter is missing, or an attempt is made to obtain a + -- parameter for a switch that does not allow a parameter. + + ----------------------------------------- + -- Expansion of command line arguments -- + ----------------------------------------- + + -- These subprograms take care of expanding globbing patterns on the + -- command line. On Unix, such expansion is done by the shell before your + -- application is called. But on Windows you must do this expansion + -- yourself. + + type Expansion_Iterator is limited private; + -- Type used during expansion of file names + + procedure Start_Expansion + (Iterator : out Expansion_Iterator; + Pattern : String; + Directory : String := ""; + Basic_Regexp : Boolean := True); + -- Initialize a wild card expansion. The next calls to Expansion will + -- return the next file name in Directory which match Pattern (Pattern + -- is a regular expression, using only the Unix shell and DOS syntax if + -- Basic_Regexp is True). When Directory is an empty string, the current + -- directory is searched. + -- + -- Pattern may contain directory separators (as in "src/*/*.ada"). + -- Subdirectories of Directory will also be searched, up to one + -- hundred levels deep. + -- + -- When Start_Expansion has been called, function Expansion should + -- be called repeatedly until it returns an empty string, before + -- Start_Expansion can be called again with the same Expansion_Iterator + -- variable. + + function Expansion (Iterator : Expansion_Iterator) return String; + -- Returns the next file in the directory matching the parameters given + -- to Start_Expansion and updates Iterator to point to the next entry. + -- Returns an empty string when there are no more files. + -- + -- If Expansion is called again after an empty string has been returned, + -- then the exception GNAT.Directory_Operations.Directory_Error is raised. + + ----------------- + -- Configuring -- + ----------------- + + -- The following subprograms are used to manipulate a command line + -- represented as a string (for instance "-g -O2"), as well as parsing + -- the switches from such a string. They provide high-level configurations + -- to define aliases (a switch is equivalent to one or more other switches) + -- or grouping of switches ("-gnatyac" is equivalent to "-gnatya" and + -- "-gnatyc"). + + -- See the top of this file for examples on how to use these subprograms + + type Command_Line_Configuration is private; + + procedure Define_Section + (Config : in out Command_Line_Configuration; + Section : String); + -- Indicates a new switch section. All switches belonging to the same + -- section are ordered together, preceded by the section. They are placed + -- at the end of the command line (as in "gnatmake somefile.adb -cargs -g") + -- + -- The section name should not include the leading '-'. So for instance in + -- the case of gnatmake we would use: + -- + -- Define_Section (Config, "cargs"); + -- Define_Section (Config, "bargs"); + + procedure Define_Alias + (Config : in out Command_Line_Configuration; + Switch : String; + Expanded : String; + Section : String := ""); + -- Indicates that whenever Switch appears on the command line, it should + -- be expanded as Expanded. For instance, for the GNAT compiler switches, + -- we would define "-gnatwa" as an alias for "-gnatwcfijkmopruvz", ie some + -- default warnings to be activated. + -- + -- This expansion is only done within the specified section, which must + -- have been defined first through a call to [Define_Section]. + + procedure Define_Prefix + (Config : in out Command_Line_Configuration; + Prefix : String); + -- Indicates that all switches starting with the given prefix should be + -- grouped. For instance, for the GNAT compiler we would define "-gnatw" as + -- a prefix, so that "-gnatwu -gnatwv" can be grouped into "-gnatwuv" It is + -- assumed that the remainder of the switch ("uv") is a set of characters + -- whose order is irrelevant. In fact, this package will sort them + -- alphabetically. + -- + -- When grouping switches that accept arguments (for instance "-gnatyL!" + -- as the definition, and "-gnatyaL12b" as the command line), only + -- numerical arguments are accepted. The above is equivalent to + -- "-gnatya -gnatyL12 -gnatyb". + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Argument : String := "ARG"); + -- Indicates a new switch. The format of this switch follows the getopt + -- format (trailing ':', '?', etc for defining a switch with parameters). + -- + -- Switch should also start with the leading '-' (or any other characters). + -- If this character is not '-', you need to call Initialize_Option_Scan to + -- set the proper character for the parser. + -- + -- The switches defined in the command_line_configuration object are used + -- when ungrouping switches with more that one character after the prefix. + -- + -- Switch and Long_Switch (when specified) are aliases and can be used + -- interchangeably. There is no check that they both take an argument or + -- both take no argument. Switch can be set to "*" to indicate that any + -- switch is supported (in which case Getopt will return '*', see its + -- documentation). + -- + -- Help is used by the Display_Help procedure to describe the supported + -- switches. + -- + -- In_Section indicates in which section the switch is valid (you need to + -- first define the section through a call to Define_Section). + -- + -- Argument is the name of the argument, as displayed in the automatic + -- help message. It is always capitalized for consistency. + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access Boolean; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Value : Boolean := True); + -- See Define_Switch for a description of the parameters. + -- When the switch is found on the command line, Getopt will set + -- Output.all to Value. + -- + -- Output is always initially set to "not Value", so that if the switch is + -- not found on the command line, Output still has a valid value. + -- The switch must not take any parameter. + -- + -- Output must exist at least as long as Config, otherwise an erroneous + -- memory access may occur. + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access Integer; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Initial : Integer := 0; + Default : Integer := 1; + Argument : String := "ARG"); + -- See Define_Switch for a description of the parameters. When the + -- switch is found on the command line, Getopt will set Output.all to the + -- value of the switch's parameter. If the parameter is not an integer, + -- Invalid_Parameter is raised. + + -- Output is always initialized to Initial. If the switch has an optional + -- argument which isn't specified by the user, then Output will be set to + -- Default. The switch must accept an argument. + + procedure Define_Switch + (Config : in out Command_Line_Configuration; + Output : access GNAT.Strings.String_Access; + Switch : String := ""; + Long_Switch : String := ""; + Help : String := ""; + Section : String := ""; + Argument : String := "ARG"); + -- Set Output to the value of the switch's parameter when the switch is + -- found on the command line. Output is always initialized to the empty + -- string if it does not have a value already (otherwise it is left as is + -- so that you can specify the default value directly in the declaration + -- of the variable). The switch must accept an argument. + + procedure Set_Usage + (Config : in out Command_Line_Configuration; + Usage : String := "[switches] [arguments]"; + Help : String := ""; + Help_Msg : String := ""); + -- Defines the general format of the call to the application, and a short + -- help text. These are both displayed by Display_Help. When a non-empty + -- Help_Msg is given, it is used by Display_Help instead of the + -- automatically generated list of supported switches. + + procedure Display_Help (Config : Command_Line_Configuration); + -- Display the help for the tool (ie its usage, and its supported switches) + + function Get_Switches + (Config : Command_Line_Configuration; + Switch_Char : Character := '-'; + Section : String := "") return String; + -- Get the switches list as expected by Getopt, for a specific section of + -- the command line. This list is built using all switches defined + -- previously via Define_Switch above. + + function Section_Delimiters + (Config : Command_Line_Configuration) return String; + -- Return a string suitable for use in Initialize_Option_Scan + + procedure Free (Config : in out Command_Line_Configuration); + -- Free the memory used by Config + + type Switch_Handler is access procedure + (Switch : String; + Parameter : String; + Section : String); + -- Called when a switch is found on the command line. Switch includes + -- any leading '-' that was specified in Define_Switch. This is slightly + -- different from the functional version of Getopt above, for which + -- Full_Switch omits the first leading '-'. + + Exit_From_Command_Line : exception; + -- Emitted when the program should exit. This is called when Getopt below + -- has seen -h, --help or an invalid switch. + + procedure Getopt + (Config : Command_Line_Configuration; + Callback : Switch_Handler := null; + Parser : Opt_Parser := Command_Line_Parser; + Concatenate : Boolean := True); + -- Similar to the standard Getopt function. For each switch found on the + -- command line, this calls Callback, if the switch is not handled + -- automatically. + -- + -- The list of valid switches are the ones from the configuration. The + -- switches that were declared through Define_Switch with an Output + -- parameter are never returned (and result in a modification of the Output + -- variable). This function will in fact never call [Callback] if all + -- switches were handled automatically and there is nothing left to do. + -- + -- The option Concatenate is identical to the one of the standard Getopt + -- function. + -- + -- This procedure automatically adds -h and --help to the valid switches, + -- to display the help message and raises Exit_From_Command_Line. + -- If an invalid switch is specified on the command line, this procedure + -- will display an error message and raises Invalid_Switch again. + -- + -- This function automatically expands switches: + -- + -- If Define_Prefix was called (for instance "-gnaty") and the user + -- specifies "-gnatycb" on the command line, then Getopt returns + -- "-gnatyc" and "-gnatyb" separately. + -- + -- If Define_Alias was called (for instance "-gnatya = -gnatycb") then + -- the latter is returned (in this case it also expands -gnaty as per + -- the above. + -- + -- The goal is to make handling as easy as possible by leaving as much + -- work as possible to this package. + -- + -- As opposed to the standard Getopt, this one will analyze all sections + -- as defined by Define_Section, and automatically jump from one section to + -- the next. + + ------------------------------ + -- Generating command lines -- + ------------------------------ + + -- Once the command line configuration has been created, you can build your + -- own command line. This will be done in general because you need to spawn + -- external tools from your application. + + -- Although it could be done by concatenating strings, the following + -- subprograms will properly take care of grouping switches when possible, + -- so as to keep the command line as short as possible. They also provide a + -- way to remove a switch from an existing command line. + + -- For instance: + + -- declare + -- Config : Command_Line_Configuration; + -- Line : Command_Line; + -- Args : Argument_List_Access; + + -- begin + -- Define_Switch (Config, "-gnatyc"); + -- Define_Switch (Config, ...); -- for all valid switches + -- Define_Prefix (Config, "-gnaty"); + + -- Set_Configuration (Line, Config); + -- Add_Switch (Line, "-O2"); + -- Add_Switch (Line, "-gnatyc"); + -- Add_Switch (Line, "-gnatyd"); + -- + -- Build (Line, Args); + -- -- Args is now ["-O2", "-gnatycd"] + -- end; + + type Command_Line is private; + + procedure Set_Configuration + (Cmd : in out Command_Line; + Config : Command_Line_Configuration); + function Get_Configuration + (Cmd : Command_Line) return Command_Line_Configuration; + -- Set or retrieve the configuration used for that command line. The Config + -- must have been initialized first, by calling one of the Define_Switches + -- subprograms. + + procedure Set_Command_Line + (Cmd : in out Command_Line; + Switches : String; + Getopt_Description : String := ""; + Switch_Char : Character := '-'); + -- Set the new content of the command line, by replacing the current + -- version with Switches. + -- + -- The parsing of Switches is done through calls to Getopt, by passing + -- Getopt_Description as an argument. (A "*" is automatically prepended so + -- that all switches and command line arguments are accepted). If a config + -- was defined via Set_Configuration, the Getopt_Description parameter will + -- be ignored. + -- + -- To properly handle switches that take parameters, you should document + -- them in Getopt_Description. Otherwise, the switch and its parameter will + -- be recorded as two separate command line arguments as returned by a + -- Command_Line_Iterator (which might be fine depending on your + -- application). + -- + -- If the command line has sections (such as -bargs -cargs), then they + -- should be listed in the Sections parameter (as "-bargs -cargs"). + -- + -- This function can be used to reset Cmd by passing an empty string + -- + -- If an invalid switch is found on the command line (ie wasn't defined in + -- the configuration via Define_Switch), and the configuration wasn't set + -- to accept all switches (by defining "*" as a valid switch), then an + -- exception Invalid_Switch is raised. The exception message indicates the + -- invalid switch. + + procedure Add_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ASCII.NUL; + Section : String := ""; + Add_Before : Boolean := False); + -- Add a new switch to the command line, and combine/group it with existing + -- switches if possible. Nothing is done if the switch already exists with + -- the same parameter. + -- + -- If the Switch takes a parameter, the latter should be specified + -- separately, so that the association between the two is always correctly + -- recognized even if the order of switches on the command line changes. + -- For instance, you should pass "--check=full" as ("--check", "full") so + -- that Remove_Switch below can simply take "--check" in parameter. That + -- will automatically remove "full" as well. The value of the parameter is + -- never modified by this package. + -- + -- On the other hand, you could decide to simply pass "--check=full" as + -- the Switch above, and then pass no parameter. This means that you need + -- to pass "--check=full" to Remove_Switch as well. + -- + -- A Switch with a parameter will never be grouped with another switch to + -- avoid ambiguities as to what the parameter applies to. + -- + -- If the switch is part of a section, then it should be specified so that + -- the switch is correctly placed in the command line, and the section + -- added if not already present. For example, to add the -g switch into the + -- -cargs section, you need to call (Cmd, "-g", Section => "-cargs"). + -- + -- [Separator], if specified, overrides the separator that was defined + -- through Define_Switch. For instance, if the switch was defined as + -- "-from:", the separator defaults to a space. But if your application + -- uses unusual separators not supported by GNAT.Command_Line (for instance + -- it requires ":"), you can specify this separator here. + -- + -- For instance, + -- Add_Switch(Cmd, "-from", "bar", ':') + -- + -- results in + -- -from:bar + -- + -- rather than the default + -- -from bar + -- + -- Note however that Getopt doesn't know how to handle ":" as a separator. + -- So the recommendation is to declare the switch as "-from!" (ie no + -- space between the switch and its parameter). Then Getopt will return + -- ":bar" as the parameter, and you can trim the ":" in your application. + -- + -- Invalid_Section is raised if Section was not defined in the + -- configuration of the command line. + -- + -- Add_Before allows insertion of the switch at the beginning of the + -- command line. + + procedure Add_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String := ""; + Separator : Character := ASCII.NUL; + Section : String := ""; + Add_Before : Boolean := False; + Success : out Boolean); + -- Same as above, returning the status of the operation + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Remove_All : Boolean := False; + Has_Parameter : Boolean := False; + Section : String := ""); + -- Remove Switch from the command line, and ungroup existing switches if + -- necessary. + -- + -- The actual parameter to the switches are ignored. If for instance + -- you are removing "-foo", then "-foo param1" and "-foo param2" can + -- be removed. + -- + -- If Remove_All is True, then all matching switches are removed, otherwise + -- only the first matching one is removed. + -- + -- If Has_Parameter is set to True, then only switches having a parameter + -- are removed. + -- + -- If the switch belongs to a section, then this section should be + -- specified: Remove_Switch (Cmd_Line, "-g", Section => "-cargs") called + -- on the command line "-g -cargs -g" will result in "-g", while if + -- called with (Cmd_Line, "-g") this will result in "-cargs -g". + -- If Remove_All is set, then both "-g" will be removed. + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Remove_All : Boolean := False; + Has_Parameter : Boolean := False; + Section : String := ""; + Success : out Boolean); + -- Same as above, reporting the success of the operation (Success is False + -- if no switch was removed). + + procedure Remove_Switch + (Cmd : in out Command_Line; + Switch : String; + Parameter : String; + Section : String := ""); + -- Remove a switch with a specific parameter. If Parameter is the empty + -- string, then only a switch with no parameter will be removed. + + procedure Free (Cmd : in out Command_Line); + -- Free the memory used by Cmd + + --------------- + -- Iteration -- + --------------- + + -- When a command line was created with the above, you can then iterate + -- over its contents using the following iterator. + + type Command_Line_Iterator is private; + + procedure Start + (Cmd : in out Command_Line; + Iter : in out Command_Line_Iterator; + Expanded : Boolean := False); + -- Start iterating over the command line arguments. If Expanded is true, + -- then the arguments are not grouped and no alias is used. For instance, + -- "-gnatwv" and "-gnatwu" would be returned instead of "-gnatwuv". + -- + -- The iterator becomes invalid if the command line is changed through a + -- call to Add_Switch, Remove_Switch or Set_Command_Line. + + function Current_Switch (Iter : Command_Line_Iterator) return String; + function Is_New_Section (Iter : Command_Line_Iterator) return Boolean; + function Current_Section (Iter : Command_Line_Iterator) return String; + function Current_Separator (Iter : Command_Line_Iterator) return String; + function Current_Parameter (Iter : Command_Line_Iterator) return String; + -- Return the current switch and its parameter (or the empty string if + -- there is no parameter or the switch was added through Add_Switch + -- without specifying the parameter. + -- + -- Separator is the string that goes between the switch and its separator. + -- It could be the empty string if they should be concatenated, or a space + -- for instance. When printing, you should not add any other character. + + function Has_More (Iter : Command_Line_Iterator) return Boolean; + -- Return True if there are more switches to be returned + + procedure Next (Iter : in out Command_Line_Iterator); + -- Move to the next switch + + procedure Build + (Line : in out Command_Line; + Args : out GNAT.OS_Lib.Argument_List_Access; + Expanded : Boolean := False; + Switch_Char : Character := '-'); + -- This is a wrapper using the Command_Line_Iterator. It provides a simple + -- way to get all switches (grouped as much as possible), and possibly + -- create an Opt_Parser. + -- + -- Args must be freed by the caller. + -- + -- Expanded has the same meaning as in Start. + + procedure Try_Help; + -- Output a message on standard error to indicate how to get the usage for + -- the executable. This procedure should only be called when the executable + -- accepts switch --help. When this procedure is called by executable xxx, + -- the following message is displayed on standard error: + -- try "xxx --help" for more information. + +private + + Max_Depth : constant := 100; + -- Maximum depth of subdirectories + + Max_Path_Length : constant := 1024; + -- Maximum length of relative path + + type Depth is range 1 .. Max_Depth; + + type Level is record + Name_Last : Natural := 0; + Dir : GNAT.Directory_Operations.Dir_Type; + end record; + + type Level_Array is array (Depth) of Level; + + type Section_Number is new Natural range 0 .. 65534; + for Section_Number'Size use 16; + + type Parameter_Type is record + Arg_Num : Positive; + First : Positive; + Last : Natural; + Extra : Character; + end record; + + type Is_Switch_Type is array (Natural range <>) of Boolean; + pragma Pack (Is_Switch_Type); + + type Section_Type is array (Natural range <>) of Section_Number; + pragma Pack (Section_Type); + + type Expansion_Iterator is limited record + Start : Positive := 1; + -- Position of the first character of the relative path to check against + -- the pattern. + + Dir_Name : String (1 .. Max_Path_Length); + + Current_Depth : Depth := 1; + + Levels : Level_Array; + + Regexp : GNAT.Regexp.Regexp; + -- Regular expression built with the pattern + + Maximum_Depth : Depth := 1; + -- The maximum depth of directories, reflecting the number of directory + -- separators in the pattern. + end record; + + type Opt_Parser_Data (Arg_Count : Natural) is record + Arguments : GNAT.OS_Lib.Argument_List_Access; + -- null if reading from the command line + + The_Parameter : Parameter_Type; + The_Separator : Character; + The_Switch : Parameter_Type; + -- This type and this variable are provided to store the current switch + -- and parameter. + + Is_Switch : Is_Switch_Type (1 .. Arg_Count) := (others => False); + -- Indicates wich arguments on the command line are considered not be + -- switches or parameters to switches (leaving e.g. filenames,...) + + Section : Section_Type (1 .. Arg_Count) := (others => 1); + -- Contains the number of the section associated with the current + -- switch. If this number is 0, then it is a section delimiter, which is + -- never returned by GetOpt. + + Current_Argument : Natural := 1; + -- Number of the current argument parsed on the command line + + Current_Index : Natural := 1; + -- Index in the current argument of the character to be processed + + Current_Section : Section_Number := 1; + + Expansion_It : aliased Expansion_Iterator; + -- When Get_Argument is expanding a file name, this is the iterator used + + In_Expansion : Boolean := False; + -- True if we are expanding a file + + Switch_Character : Character := '-'; + -- The character at the beginning of the command line arguments, + -- indicating the beginning of a switch. + + Stop_At_First : Boolean := False; + -- If it is True then Getopt stops at the first non-switch argument + end record; + + Command_Line_Parser_Data : aliased Opt_Parser_Data + (Ada.Command_Line.Argument_Count); + -- The internal data used when parsing the command line + + type Opt_Parser is access all Opt_Parser_Data; + Command_Line_Parser : constant Opt_Parser := + Command_Line_Parser_Data'Access; + + type Switch_Type is (Switch_Untyped, + Switch_Boolean, + Switch_Integer, + Switch_String); + + type Switch_Definition (Typ : Switch_Type := Switch_Untyped) is record + Switch : GNAT.OS_Lib.String_Access; + Long_Switch : GNAT.OS_Lib.String_Access; + Section : GNAT.OS_Lib.String_Access; + Help : GNAT.OS_Lib.String_Access; + + Argument : GNAT.OS_Lib.String_Access; + -- null if "ARG". + -- Name of the argument for this switch. + + case Typ is + when Switch_Untyped => + null; + when Switch_Boolean => + Boolean_Output : access Boolean; + Boolean_Value : Boolean; -- will set Output to that value + when Switch_Integer => + Integer_Output : access Integer; + Integer_Initial : Integer; + Integer_Default : Integer; + when Switch_String => + String_Output : access GNAT.Strings.String_Access; + end case; + end record; + type Switch_Definitions is array (Natural range <>) of Switch_Definition; + type Switch_Definitions_List is access all Switch_Definitions; + -- [Switch] includes the leading '-' + + type Alias_Definition is record + Alias : GNAT.OS_Lib.String_Access; + Expansion : GNAT.OS_Lib.String_Access; + Section : GNAT.OS_Lib.String_Access; + end record; + type Alias_Definitions is array (Natural range <>) of Alias_Definition; + type Alias_Definitions_List is access all Alias_Definitions; + + type Command_Line_Configuration_Record is record + Prefixes : GNAT.OS_Lib.Argument_List_Access; + -- The list of prefixes + + Sections : GNAT.OS_Lib.Argument_List_Access; + -- The list of sections + + Star_Switch : Boolean := False; + -- Whether switches not described in this configuration should be + -- returned to the user (True). If False, an exception Invalid_Switch + -- is raised. + + Aliases : Alias_Definitions_List; + Usage : GNAT.OS_Lib.String_Access; + Help : GNAT.OS_Lib.String_Access; + Help_Msg : GNAT.OS_Lib.String_Access; + Switches : Switch_Definitions_List; + -- List of expected switches (Used when expanding switch groups) + end record; + type Command_Line_Configuration is access Command_Line_Configuration_Record; + + type Command_Line is record + Config : Command_Line_Configuration; + Expanded : GNAT.OS_Lib.Argument_List_Access; + + Params : GNAT.OS_Lib.Argument_List_Access; + -- Parameter for the corresponding switch in Expanded. The first + -- character is the separator (or ASCII.NUL if there is no separator). + + Sections : GNAT.OS_Lib.Argument_List_Access; + -- The list of sections + + Coalesce : GNAT.OS_Lib.Argument_List_Access; + Coalesce_Params : GNAT.OS_Lib.Argument_List_Access; + Coalesce_Sections : GNAT.OS_Lib.Argument_List_Access; + -- Cached version of the command line. This is recomputed every time + -- the command line changes. Switches are grouped as much as possible, + -- and aliases are used to reduce the length of the command line. The + -- parameters are not allocated, they point into Params, so they must + -- not be freed. + end record; + + type Command_Line_Iterator is record + List : GNAT.OS_Lib.Argument_List_Access; + Sections : GNAT.OS_Lib.Argument_List_Access; + Params : GNAT.OS_Lib.Argument_List_Access; + Current : Natural; + end record; + +end GNAT.Command_Line; diff --git a/gcc/ada/libgnat/g-comver.adb b/gcc/ada/libgnat/g-comver.adb new file mode 100644 index 0000000..61ca4d6 --- /dev/null +++ b/gcc/ada/libgnat/g-comver.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M P I L E R _ V E R S I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2010, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a routine for obtaining the version number of the +-- GNAT compiler used to compile the program. It relies on the generated +-- constant in the binder generated package that records this information. + +package body GNAT.Compiler_Version is + + Ver_Len_Max : constant := 256; + -- This is logically a reference to Gnatvsn.Ver_Len_Max but we cannot + -- import this directly since run-time units cannot WITH compiler units. + + Ver_Prefix : constant String := "GNAT Version: "; + -- This is logically a reference to Gnatvsn.Ver_Prefix but we cannot + -- import this directly since run-time units cannot WITH compiler units. + + GNAT_Version : constant String (1 .. Ver_Len_Max + Ver_Prefix'Length); + pragma Import (C, GNAT_Version, "__gnat_version"); + + ------------- + -- Version -- + ------------- + + function Version return String is + begin + -- Search for terminating right paren or NUL ending the string + + for J in Ver_Prefix'Length + 1 .. GNAT_Version'Last loop + if GNAT_Version (J) = ')' then + return GNAT_Version (Ver_Prefix'Length + 1 .. J); + end if; + + if GNAT_Version (J) = Character'Val (0) then + return GNAT_Version (Ver_Prefix'Length + 1 .. J - 1); + end if; + end loop; + + -- This should not happen (no right paren or NUL found) + + return GNAT_Version; + end Version; + +end GNAT.Compiler_Version; diff --git a/gcc/ada/libgnat/g-comver.ads b/gcc/ada/libgnat/g-comver.ads new file mode 100644 index 0000000..8707a49 --- /dev/null +++ b/gcc/ada/libgnat/g-comver.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . C O M P I L E R _ V E R S I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a routine for obtaining the version number of the +-- GNAT compiler used to compile the program. It relies on the generated +-- constant in the binder generated package that records this information. + +-- Note: to use this package you must first instantiate it, for example: + +-- package CVer is new GNAT.Compiler_Version; + +-- and then you use the function in the instantiated package (Cver.Version). +-- The reason that this unit is generic is that otherwise the direct attempt +-- to import the necessary variable from the binder file causes trouble when +-- building a shared library, since the symbol is not available. + +-- Note: this unit is only useable if the main program is written in Ada. +-- It cannot be used if the main program is written in foreign language. + +generic +package GNAT.Compiler_Version is + pragma Pure; + + function Version return String; + -- This function returns the version in the form "v.vvx (yyyyddmm)". + -- Here v.vv is the main version number (e.g. 3.16), x is the version + -- designator (e.g. a1 in 3.16a1), and yyyyddmm is the date in ISO form. + -- An example of the returned value would be "3.16w (20021029)". The + -- version is actually that of the binder used to bind the program, + -- which will be the same as the compiler version if a consistent + -- set of tools is used to build the program. + +end GNAT.Compiler_Version; diff --git a/gcc/ada/libgnat/g-cppexc.adb b/gcc/ada/libgnat/g-cppexc.adb new file mode 100644 index 0000000..473bb43 --- /dev/null +++ b/gcc/ada/libgnat/g-cppexc.adb @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P _ E X C E P T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with System.Storage_Elements; +with Interfaces.C; use Interfaces.C; +with Ada.Unchecked_Conversion; +with System.Standard_Library; use System.Standard_Library; + +package body GNAT.CPP_Exceptions is + + -- Note: all functions prefixed by __cxa are part of the c++ ABI for + -- exception handling. As they are provided by the c++ library, there + -- must be no dependencies on it in the compiled code of this unit, but + -- there can be dependencies in instances. This is required to be able + -- to build the shared library without the c++ library. + + function To_Exception_Data_Ptr is new + Ada.Unchecked_Conversion + (Exception_Id, Exception_Data_Ptr); + -- Convert an Exception_Id to its non-private type. This is used to get + -- the RTTI of a C++ exception + + function Get_Exception_Machine_Occurrence + (X : Exception_Occurrence) return System.Address; + pragma Import (Ada, Get_Exception_Machine_Occurrence, + "__gnat_get_exception_machine_occurrence"); + -- Imported function (from Ada.Exceptions) that returns the machine + -- occurrence from an exception occurrence. + + ------------------------- + -- Raise_Cpp_Exception -- + ------------------------- + + procedure Raise_Cpp_Exception (Id : Exception_Id; Value : T) + is + Id_Data : constant Exception_Data_Ptr := To_Exception_Data_Ptr (Id); + -- Get a non-private view on the exception + + type T_Acc is access all T; + pragma Convention (C, T_Acc); + -- Access type to the object compatible with C + + Occ : T_Acc; + -- The occurrence to propagate + + function cxa_allocate_exception (Size : size_t) return T_Acc; + pragma Import (C, cxa_allocate_exception, "__cxa_allocate_exception"); + -- The C++ function to allocate an occurrence + + procedure cxa_throw (Obj : T_Acc; Tinfo : System.Address; + Dest : System.Address); + pragma Import (C, cxa_throw, "__cxa_throw"); + pragma No_Return (cxa_throw); + -- The C++ function to raise an exception + begin + -- Check the exception was imported from C++ + + if Id_Data.Lang /= 'C' then + raise Constraint_Error; + end if; + + -- Allocate the C++ occurrence + + Occ := cxa_allocate_exception (T'Size / System.Storage_Unit); + + -- Set the object + + Occ.all := Value; + + -- Throw the exception + + cxa_throw (Occ, Id_Data.Foreign_Data, System.Null_Address); + end Raise_Cpp_Exception; + + ---------------- + -- Get_Object -- + ---------------- + + function Get_Object (X : Exception_Occurrence) return T + is + use System; + use System.Storage_Elements; + + Unwind_Exception_Size : Natural; + pragma Import (C, Unwind_Exception_Size, "__gnat_unwind_exception_size"); + -- Size in bytes of _Unwind_Exception + + Exception_Addr : constant Address := + Get_Exception_Machine_Occurrence (X); + -- Machine occurrence of X + + begin + -- Check the machine occurrence exists + + if Exception_Addr = Null_Address then + raise Constraint_Error; + end if; + + declare + -- Import the object from the occurrence + Result : T; + pragma Import (Ada, Result); + for Result'Address use + Exception_Addr + Storage_Offset (Unwind_Exception_Size); + begin + -- And return it + return Result; + end; + end Get_Object; +end GNAT.CPP_Exceptions; diff --git a/gcc/ada/libgnat/g-cppexc.ads b/gcc/ada/libgnat/g-cppexc.ads new file mode 100644 index 0000000..7884e3e --- /dev/null +++ b/gcc/ada/libgnat/g-cppexc.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C P P _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface for raising and handling C++ exceptions + +with Ada.Exceptions; use Ada.Exceptions; + +package GNAT.CPP_Exceptions is + generic + type T is private; + procedure Raise_Cpp_Exception (Id : Exception_Id; Value : T); + -- Raise a C++ exception identified by Id. Associate Value with this + -- occurrence. Id must refer to an exception that has the Cpp convention. + + generic + type T is private; + function Get_Object (X : Exception_Occurrence) return T; + -- Extract the object associated with X. The exception of the occurrence + -- X must have a Cpp Convention. +end GNAT.CPP_Exceptions; diff --git a/gcc/ada/libgnat/g-crc32.adb b/gcc/ada/libgnat/g-crc32.adb new file mode 100644 index 0000000..b7f3336 --- /dev/null +++ b/gcc/ada/libgnat/g-crc32.adb @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . C R C 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body GNAT.CRC32 is + + ------------ + -- Update -- + ------------ + + procedure Update (C : in out CRC32; Value : String) is + begin + for K in Value'Range loop + Update (C, Value (K)); + end loop; + end Update; + + procedure Update (C : in out CRC32; Value : Ada.Streams.Stream_Element) is + function To_Char is new Ada.Unchecked_Conversion + (Ada.Streams.Stream_Element, Character); + V : constant Character := To_Char (Value); + begin + Update (C, V); + end Update; + + procedure Update + (C : in out CRC32; + Value : Ada.Streams.Stream_Element_Array) + is + begin + for K in Value'Range loop + Update (C, Value (K)); + end loop; + end Update; + + ----------------- + -- Wide_Update -- + ----------------- + + procedure Wide_Update (C : in out CRC32; Value : Wide_Character) is + subtype S2 is String (1 .. 2); + function To_S2 is new Ada.Unchecked_Conversion (Wide_Character, S2); + VS : constant S2 := To_S2 (Value); + begin + Update (C, VS (1)); + Update (C, VS (2)); + end Wide_Update; + + procedure Wide_Update (C : in out CRC32; Value : Wide_String) is + begin + for K in Value'Range loop + Wide_Update (C, Value (K)); + end loop; + end Wide_Update; + +end GNAT.CRC32; diff --git a/gcc/ada/libgnat/g-crc32.ads b/gcc/ada/libgnat/g-crc32.ads new file mode 100644 index 0000000..979c7bb --- /dev/null +++ b/gcc/ada/libgnat/g-crc32.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . C R C 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines for computing a commonly used checksum +-- called CRC-32. This is a checksum based on treating the binary data +-- as a polynomial over a binary field, and the exact specifications of +-- the CRC-32 algorithm are as follows: + +-- Name : "CRC-32" +-- Width : 32 +-- Poly : 04C11DB7 +-- Init : FFFFFFFF +-- RefIn : True +-- RefOut : True +-- XorOut : FFFFFFFF +-- Check : CBF43926 + +-- Note that this is the algorithm used by PKZip, Ethernet and FDDI + +-- For more information about this algorithm see: + +-- ftp://ftp.rocksoft.com/papers/crc_v3.txt + +-- "A Painless Guide to CRC Error Detection Algorithms", Ross N. Williams + +-- "Computation of Cyclic Redundancy Checks via Table Look-Up", Communications +-- of the ACM, Vol. 31 No. 8, pp.1008-1013 Aug. 1988. Sarwate, D.V. + +with Ada.Streams; +with Interfaces; +with System.CRC32; + +package GNAT.CRC32 is + + subtype CRC32 is System.CRC32.CRC32; + -- Used to represent CRC32 values, which are 32 bit bit-strings + + procedure Initialize (C : out CRC32) + renames System.CRC32.Initialize; + -- Initialize CRC value by assigning the standard Init value (16#FFFF_FFFF) + + procedure Update + (C : in out CRC32; + Value : Character) + renames System.CRC32.Update; + -- Evolve CRC by including the contribution from Character'Pos (Value) + + procedure Update + (C : in out CRC32; + Value : String); + -- For each character in the Value string call above routine + + procedure Wide_Update + (C : in out CRC32; + Value : Wide_Character); + -- Evolve CRC by including the contribution from Wide_Character'Pos (Value) + -- with the bytes being included in the natural memory order. + + procedure Wide_Update + (C : in out CRC32; + Value : Wide_String); + -- For each character in the Value string call above routine + + procedure Update + (C : in out CRC32; + Value : Ada.Streams.Stream_Element); + -- Evolve CRC by including the contribution from Value + + procedure Update + (C : in out CRC32; + Value : Ada.Streams.Stream_Element_Array); + -- For each element in the Value array call above routine + + function Get_Value (C : CRC32) return Interfaces.Unsigned_32 + renames System.CRC32.Get_Value; + -- Get_Value computes the CRC32 value by performing an XOR with the + -- standard XorOut value (16#FFFF_FFFF). Note that this does not + -- change the value of C, so it may be used to retrieve intermediate + -- values of the CRC32 value during a sequence of Update calls. + + pragma Inline (Update); + pragma Inline (Wide_Update); +end GNAT.CRC32; diff --git a/gcc/ada/libgnat/g-ctrl_c.adb b/gcc/ada/libgnat/g-ctrl_c.adb new file mode 100644 index 0000000..352de9c --- /dev/null +++ b/gcc/ada/libgnat/g-ctrl_c.adb @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C T R L _ C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Ctrl_C is + + type C_Handler_Type is access procedure; + pragma Convention (C, C_Handler_Type); + + Ada_Handler : Handler_Type; + + procedure C_Handler; + pragma Convention (C, C_Handler); + + --------------- + -- C_Handler -- + --------------- + + procedure C_Handler is + begin + Ada_Handler.all; + end C_Handler; + + --------------------- + -- Install_Handler -- + --------------------- + + procedure Install_Handler (Handler : Handler_Type) is + procedure Internal (Handler : C_Handler_Type); + pragma Import (C, Internal, "__gnat_install_int_handler"); + begin + Ada_Handler := Handler; + Internal (C_Handler'Access); + end Install_Handler; + +end GNAT.Ctrl_C; diff --git a/gcc/ada/libgnat/g-ctrl_c.ads b/gcc/ada/libgnat/g-ctrl_c.ads new file mode 100644 index 0000000..190554c --- /dev/null +++ b/gcc/ada/libgnat/g-ctrl_c.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . C T R L _ C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package may be used to intercept the interruption of a running +-- program by the operator typing Control-C, without having to use an Ada +-- interrupt handler protected object. + +-- This package is currently implemented under Windows and Unix platforms + +-- Note concerning Unix systems: + +-- The behavior of this package when using tasking depends on the interaction +-- between sigaction() and the thread library. + +package GNAT.Ctrl_C is + + type Handler_Type is access procedure; + -- Any parameterless library level procedure can be used as a handler. + -- Handler_Type should not propagate exceptions. + + procedure Install_Handler (Handler : Handler_Type); + -- Set up Handler to be called if the operator hits Ctrl-C, instead of the + -- standard Control-C handler. + + procedure Uninstall_Handler; + -- Reinstall the standard Control-C handler. + -- If Install_Handler has never been called, this procedure has no effect. + +private + pragma Import (C, Uninstall_Handler, "__gnat_uninstall_int_handler"); +end GNAT.Ctrl_C; diff --git a/gcc/ada/libgnat/g-curexc.ads b/gcc/ada/libgnat/g-curexc.ads new file mode 100644 index 0000000..edc62b6 --- /dev/null +++ b/gcc/ada/libgnat/g-curexc.ads @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . C U R R E N T _ E X C E P T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines for obtaining the current exception +-- information in Ada 83 style. In Ada 83, there was no official method +-- for obtaining exception information, but a number of vendors supplied +-- routines for this purpose, and this package closely approximates the +-- interfaces supplied by DEC Ada 83 and VADS Ada. + +-- The routines in this package are associated with a particular exception +-- handler, and can only be called from within an exception handler. See +-- also the package GNAT.Most_Recent_Exception, which provides access to +-- the most recently raised exception, and is not limited to static calls +-- from an exception handler. + +package GNAT.Current_Exception is + pragma Pure; + + ----------------- + -- Subprograms -- + ----------------- + + -- Note: the lower bound of returned String values is always one + + function Exception_Information return String; + -- Returns the result of calling Ada.Exceptions.Exception_Information + -- with an argument that is the Exception_Occurrence corresponding to + -- the current exception. Returns the null string if called from outside + -- an exception handler. + + function Exception_Message return String; + -- Returns the result of calling Ada.Exceptions.Exception_Message with + -- an argument that is the Exception_Occurrence corresponding to the + -- current exception. Returns the null string if called from outside an + -- exception handler. + + function Exception_Name return String; + -- Returns the result of calling Ada.Exceptions.Exception_Name with + -- an argument that is the Exception_Occurrence corresponding to the + -- current exception. Returns the null string if called from outside + -- an exception handler. + + -- Note: all these functions return useful information only if + -- called statically from within an exception handler, and they + -- return information about the exception corresponding to the + -- handler in which they appear. This is NOT the same as the most + -- recently raised exception. Consider the example: + + -- exception + -- when Constraint_Error => + -- begin + -- ... + -- exception + -- when Tasking_Error => ... + -- end; + -- + -- -- Exception_xxx at this point returns the information about + -- -- the constraint error, not about any exception raised within + -- -- the nested block since it is the static nesting that counts. + + ----------------------------------- + -- Use of Library Level Renaming -- + ----------------------------------- + + -- For greater compatibility with existing legacy software, library + -- level renaming may be used to create a function with a name matching + -- one that is in use. For example, some versions of VADS Ada provided + -- a function called Current_Exception whose semantics was identical to + -- that of GNAT. The following library level renaming declaration: + + -- with GNAT.Current_Exception; + -- function Current_Exception + -- renames GNAT.Current_Exception.Exception_Name; + + -- placed in a file called current_exception.ads and compiled into the + -- application compilation environment, will make the function available + -- in a manner exactly compatible with that in VADS Ada 83. + +private + pragma Import (Intrinsic, Exception_Information); + pragma Import (intrinsic, Exception_Message); + pragma Import (Intrinsic, Exception_Name); + +end GNAT.Current_Exception; diff --git a/gcc/ada/libgnat/g-debpoo.adb b/gcc/ada/libgnat/g-debpoo.adb new file mode 100644 index 0000000..9934e61 --- /dev/null +++ b/gcc/ada/libgnat/g-debpoo.adb @@ -0,0 +1,2520 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D E B U G _ P O O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.IO; use GNAT.IO; + +with System.CRTL; +with System.Memory; use System.Memory; +with System.Soft_Links; use System.Soft_Links; + +with System.Traceback_Entries; + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; +with GNAT.HTable; +with GNAT.Traceback; use GNAT.Traceback; + +with Ada.Finalization; +with Ada.Unchecked_Conversion; + +package body GNAT.Debug_Pools is + + Storage_Alignment : constant := Standard'Maximum_Alignment; + -- Alignment enforced for all the memory chunks returned by Allocate, + -- maximized to make sure that it will be compatible with all types. + -- + -- The addresses returned by the underlying low-level allocator (be it + -- 'new' or a straight 'malloc') aren't guaranteed to be that much aligned + -- on some targets, so we manage the needed alignment padding ourselves + -- systematically. Use of a common value for every allocation allows + -- significant simplifications in the code, nevertheless, for improved + -- robustness and efficiency overall. + + -- We combine a few internal devices to offer the pool services: + -- + -- * A management header attached to each allocated memory block, located + -- right ahead of it, like so: + -- + -- Storage Address returned by the pool, + -- aligned on Storage_Alignment + -- v + -- +------+--------+--------------------- + -- | ~~~~ | HEADER | USER DATA ... | + -- +------+--------+--------------------- + -- <----> + -- alignment + -- padding + -- + -- The alignment padding is required + -- + -- * A validity bitmap, which holds a validity bit for blocks managed by + -- the pool. Enforcing Storage_Alignment on those blocks allows efficient + -- validity management. + -- + -- * A list of currently used blocks. + + 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. + + Disable : Boolean := False; + -- This variable is used to avoid infinite loops, where this package would + -- itself allocate memory and then call itself recursively, forever. Useful + -- when System_Memory_Debug_Pool_Enabled is True. + + System_Memory_Debug_Pool_Enabled : Boolean := False; + -- If True, System.Memory allocation uses Debug_Pool + + Allow_Unhandled_Memory : Boolean := False; + -- If True, protects Deallocate against releasing memory allocated before + -- System_Memory_Debug_Pool_Enabled was set. + + Traceback_Count : Byte_Count := 0; + -- Total number of traceback elements + + --------------------------- + -- Back Trace Hash Table -- + --------------------------- + + -- 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; + -- Number of elements in the hash-table + + type Tracebacks_Array_Access is access 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; + -- Size of the memory allocated/freed at Traceback since last Reset call + + Total : Byte_Count; + -- Number of chunk of memory allocated/freed at Traceback since last + -- Reset call. + + Frees : Natural; + -- Number of chunk of memory allocated at Traceback, currently freed + -- since last Reset call. (only for Alloc & Indirect_Alloc elements) + + Total_Frees : Byte_Count; + -- Size of the memory allocated at Traceback, currently freed since last + -- Reset call. (only for Alloc & Indirect_Alloc elements) + + Next : Traceback_Htable_Elem_Ptr; + end record; + + -- Subprograms used for the Backtrace_Htable instantiation + + procedure Set_Next + (E : Traceback_Htable_Elem_Ptr; + Next : Traceback_Htable_Elem_Ptr); + pragma Inline (Set_Next); + + function Next + (E : Traceback_Htable_Elem_Ptr) return Traceback_Htable_Elem_Ptr; + pragma Inline (Next); + + function Get_Key + (E : Traceback_Htable_Elem_Ptr) return Tracebacks_Array_Access; + pragma Inline (Get_Key); + + function Hash (T : Tracebacks_Array_Access) return Header; + pragma Inline (Hash); + + function Equal (K1, K2 : Tracebacks_Array_Access) return Boolean; + -- Why is this not inlined??? + + -- The hash table for back traces + + 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; + + 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. + + -- The following record stores extra information that needs to be + -- memorized for each block allocated with the special debug pool. + + type Allocation_Header is record + Allocation_Address : System.Address; + -- Address of the block returned by malloc, possibly unaligned + + 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; + -- ??? comment required + + Dealloc_Traceback : Traceback_Ptr_Or_Address; + -- Pointer to the traceback for the allocation (if the memory chunk 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); + + Header_Offset : constant Storage_Count := + (Allocation_Header'Object_Size / System.Storage_Unit); + -- Offset, in bytes, from start of allocation Header to start of User + -- data. The start of user data is assumed to be aligned at least as much + -- as what the header type requires, so applying this offset yields a + -- suitably aligned address as well. + + Extra_Allocation : constant Storage_Count := + (Storage_Alignment - 1 + Header_Offset); + -- Amount we need to secure in addition to the user data for a given + -- allocation request: room for the allocation header plus worst-case + -- alignment padding. + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Align (Addr : Integer_Address) return Integer_Address; + pragma Inline (Align); + -- Return the next address aligned on Storage_Alignment from Addr. + + 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. + + function Output_File (Pool : Debug_Pool) return File_Type; + pragma Inline (Output_File); + -- Returns file_type on which error messages have to be generated for Pool + + procedure Put_Line + (File : File_Type; + 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 File. 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 + + procedure Stdout_Put (S : String); + -- Wrapper for Put that ensures we always write to stdout instead of the + -- current output file defined in GNAT.IO. + + procedure Stdout_Put_Line (S : String); + -- Wrapper for Put_Line that ensures we always write to stdout instead of + -- the current output file defined in GNAT.IO. + + procedure Print_Traceback + (Output_File : File_Type; + Prefix : String; + Traceback : Traceback_Htable_Elem_Ptr); + -- Output Prefix & Traceback & EOL. Print nothing if Traceback is null. + + procedure Print_Address (File : File_Type; Addr : Address); + -- Output System.Address without using secondary stack. + -- When System.Memory uses Debug_Pool, secondary stack cannot be used + -- during Allocate calls, as some Allocate calls are done to + -- register/initialize a secondary stack for a foreign thread. + -- During these calls, the secondary stack is not available yet. + + package Validity is + function Is_Handled (Storage : System.Address) return Boolean; + pragma Inline (Is_Handled); + -- Return True if Storage is the address of a block that the debug pool + -- already had under its control. Used to allow System.Memory to use + -- Debug_Pools + + function Is_Valid (Storage : System.Address) return Boolean; + pragma Inline (Is_Valid); + -- Return True if Storage is the address of a block that the debug pool + -- has under its control, in which case Header_Of may be used to access + -- the associated allocation header. + + 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). + + Validity_Count : Byte_Count := 0; + -- Total number of validity elements + + end Validity; + + use Validity; + + 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 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 excludes 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. + + package STBE renames System.Traceback_Entries; + + function PC_For (TB_Entry : STBE.Traceback_Entry) return System.Address + renames STBE.PC_For; + + type Scope_Lock is + new Ada.Finalization.Limited_Controlled with null record; + -- Used to handle Lock_Task/Unlock_Task calls + + overriding procedure Initialize (This : in out Scope_Lock); + -- Lock task on initialization + + overriding procedure Finalize (This : in out Scope_Lock); + -- Unlock task on finalization + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (This : in out Scope_Lock) is + pragma Unreferenced (This); + begin + Lock_Task.all; + end Initialize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (This : in out Scope_Lock) is + pragma Unreferenced (This); + begin + Unlock_Task.all; + end Finalize; + + ----------- + -- Align -- + ----------- + + function Align (Addr : Integer_Address) return Integer_Address is + Factor : constant Integer_Address := Storage_Alignment; + begin + return ((Addr + Factor - 1) / Factor) * Factor; + end Align; + + --------------- + -- 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 - Header_Offset); + 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 type Tracebacks_Array; + 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 -- + ---------- + + 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; + + ----------------- + -- Output_File -- + ----------------- + + function Output_File (Pool : Debug_Pool) return File_Type is + begin + if Pool.Errors_To_Stdout then + return Standard_Output; + else + return Standard_Error; + end if; + end Output_File; + + ------------------- + -- Print_Address -- + ------------------- + + procedure Print_Address (File : File_Type; Addr : Address) is + begin + -- Warning: secondary stack cannot be used here. When System.Memory + -- implementation uses Debug_Pool, Print_Address can be called during + -- secondary stack creation for foreign threads. + + Put (File, Image_C (Addr)); + end Print_Address; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line + (File : File_Type; + 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 + Print_Address (File, PC_For (Tr (J))); + Put (File, ' '); + end loop; + Put (File, ASCII.LF); + end Print; + + -- Start of processing for Put_Line + + begin + if Traceback = null then + declare + Len : Natural; + Start : Natural; + Trace : aliased Tracebacks_Array (1 .. Depth + Max_Ignored_Levels); + + begin + Call_Chain (Trace, Len); + Skip_Levels + (Depth => Depth, + Trace => Trace, + Start => Start, + Len => Len, + Ignored_Frame_Start => Ignored_Frame_Start, + Ignored_Frame_End => Ignored_Frame_End); + Print (Trace (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 + Disable_Exit_Value : constant Boolean := Disable; + + Elem : Traceback_Htable_Elem_Ptr; + Len : Natural; + Start : Natural; + Trace : aliased Tracebacks_Array + (1 .. Integer (Pool.Stack_Trace_Depth) + + Max_Ignored_Levels); + + begin + Disable := True; + Call_Chain (Trace, Len); + Skip_Levels + (Depth => Pool.Stack_Trace_Depth, + Trace => Trace, + Start => Start, + Len => Len, + Ignored_Frame_Start => Ignored_Frame_Start, + Ignored_Frame_End => 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), + Frees => 0, + Total_Frees => 0, + Next => null); + Traceback_Count := Traceback_Count + 1; + Backtrace_Htable.Set (Elem); + + else + Elem.Count := Elem.Count + 1; + Elem.Total := Elem.Total + Byte_Count (Size); + end if; + + Disable := Disable_Exit_Value; + return Elem; + exception + when others => + Disable := Disable_Exit_Value; + raise; + end; + end Find_Or_Create_Traceback; + + -------------- + -- Validity -- + -------------- + + package body Validity is + + -- The validity bits of the allocated blocks are kept in a has table. + -- Each component of the hash table contains the validity bits for a + -- 16 Mbyte memory chunk. + + -- The reason the validity bits are kept for chunks of memory rather + -- than in a big array is that on some 64 bit platforms, it may happen + -- that two chunk of allocated data are very far from each other. + + Memory_Chunk_Size : constant Integer_Address := 2 ** 24; -- 16 MB + Validity_Divisor : constant := Storage_Alignment * System.Storage_Unit; + + Max_Validity_Byte_Index : constant := + Memory_Chunk_Size / Validity_Divisor; + + subtype Validity_Byte_Index is + Integer_Address range 0 .. Max_Validity_Byte_Index - 1; + + type Byte is mod 2 ** System.Storage_Unit; + + type Validity_Bits_Part is array (Validity_Byte_Index) of Byte; + type Validity_Bits_Part_Ref is access all Validity_Bits_Part; + No_Validity_Bits_Part : constant Validity_Bits_Part_Ref := null; + + type Validity_Bits is record + Valid : Validity_Bits_Part_Ref := No_Validity_Bits_Part; + -- True if chunk of memory at this address is currently allocated + + Handled : Validity_Bits_Part_Ref := No_Validity_Bits_Part; + -- True if chunk of memory at this address was allocated once after + -- Allow_Unhandled_Memory was set to True. Used to know on Deallocate + -- if chunk of memory should be handled a block allocated by this + -- package. + + end record; + + type Validity_Bits_Ref is access all Validity_Bits; + No_Validity_Bits : constant Validity_Bits_Ref := null; + + Max_Header_Num : constant := 1023; + + type Header_Num is range 0 .. Max_Header_Num - 1; + + function Hash (F : Integer_Address) return Header_Num; + + function Is_Valid_Or_Handled + (Storage : System.Address; + Valid : Boolean) return Boolean; + pragma Inline (Is_Valid_Or_Handled); + -- Internal implementation of Is_Valid and Is_Handled. + -- Valid is used to select Valid or Handled arrays. + + package Validy_Htable is new GNAT.HTable.Simple_HTable + (Header_Num => Header_Num, + Element => Validity_Bits_Ref, + No_Element => No_Validity_Bits, + Key => Integer_Address, + Hash => Hash, + Equal => "="); + -- Table to keep the validity and handled bit blocks for the allocated + -- data. + + function To_Pointer is new Ada.Unchecked_Conversion + (System.Address, Validity_Bits_Part_Ref); + + procedure Memset (A : Address; C : Integer; N : size_t); + pragma Import (C, Memset, "memset"); + + ---------- + -- Hash -- + ---------- + + function Hash (F : Integer_Address) return Header_Num is + begin + return Header_Num (F mod Max_Header_Num); + end Hash; + + ------------------------- + -- Is_Valid_Or_Handled -- + ------------------------- + + function Is_Valid_Or_Handled + (Storage : System.Address; + Valid : Boolean) return Boolean is + Int_Storage : constant Integer_Address := To_Integer (Storage); + + begin + -- The pool only returns addresses aligned on Storage_Alignment so + -- anything off cannot be a valid block address and we can return + -- early in this case. We actually have to since our data structures + -- map validity bits for such aligned addresses only. + + if Int_Storage mod Storage_Alignment /= 0 then + return False; + end if; + + declare + Block_Number : constant Integer_Address := + Int_Storage / Memory_Chunk_Size; + Ptr : constant Validity_Bits_Ref := + Validy_Htable.Get (Block_Number); + Offset : constant Integer_Address := + (Int_Storage - + (Block_Number * Memory_Chunk_Size)) / + Storage_Alignment; + Bit : constant Byte := + 2 ** Natural (Offset mod System.Storage_Unit); + begin + if Ptr = No_Validity_Bits then + return False; + else + if Valid then + return (Ptr.Valid (Offset / System.Storage_Unit) + and Bit) /= 0; + else + if Ptr.Handled = No_Validity_Bits_Part then + return False; + else + return (Ptr.Handled (Offset / System.Storage_Unit) + and Bit) /= 0; + end if; + end if; + end if; + end; + end Is_Valid_Or_Handled; + + -------------- + -- Is_Valid -- + -------------- + + function Is_Valid (Storage : System.Address) return Boolean is + begin + return Is_Valid_Or_Handled (Storage => Storage, Valid => True); + end Is_Valid; + + ----------------- + -- Is_Handled -- + ----------------- + + function Is_Handled (Storage : System.Address) return Boolean is + begin + return Is_Valid_Or_Handled (Storage => Storage, Valid => False); + end Is_Handled; + + --------------- + -- Set_Valid -- + --------------- + + procedure Set_Valid (Storage : System.Address; Value : Boolean) is + Int_Storage : constant Integer_Address := To_Integer (Storage); + Block_Number : constant Integer_Address := + Int_Storage / Memory_Chunk_Size; + Ptr : Validity_Bits_Ref := Validy_Htable.Get (Block_Number); + Offset : constant Integer_Address := + (Int_Storage - (Block_Number * Memory_Chunk_Size)) / + Storage_Alignment; + Bit : constant Byte := + 2 ** Natural (Offset mod System.Storage_Unit); + + procedure Set_Handled; + pragma Inline (Set_Handled); + -- if Allow_Unhandled_Memory set Handled bit in table. + + ----------------- + -- Set_Handled -- + ----------------- + + procedure Set_Handled is + begin + if Allow_Unhandled_Memory then + if Ptr.Handled = No_Validity_Bits_Part then + Ptr.Handled := + To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Memset + (A => Ptr.Handled.all'Address, + C => 0, + N => size_t (Max_Validity_Byte_Index)); + end if; + + Ptr.Handled (Offset / System.Storage_Unit) := + Ptr.Handled (Offset / System.Storage_Unit) or Bit; + end if; + end Set_Handled; + + -- Start of processing for Set_Valid + + begin + if Ptr = No_Validity_Bits then + + -- First time in this memory area: allocate a new block and put + -- it in the table. + + if Value then + Ptr := new Validity_Bits; + Validity_Count := Validity_Count + 1; + Ptr.Valid := + To_Pointer (Alloc (size_t (Max_Validity_Byte_Index))); + Validy_Htable.Set (Block_Number, Ptr); + Memset + (A => Ptr.Valid.all'Address, + C => 0, + N => size_t (Max_Validity_Byte_Index)); + Ptr.Valid (Offset / System.Storage_Unit) := Bit; + Set_Handled; + end if; + + else + if Value then + Ptr.Valid (Offset / System.Storage_Unit) := + Ptr.Valid (Offset / System.Storage_Unit) or Bit; + Set_Handled; + else + Ptr.Valid (Offset / System.Storage_Unit) := + Ptr.Valid (Offset / System.Storage_Unit) and (not Bit); + end if; + end if; + end Set_Valid; + end Validity; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Debug_Pool; + Storage_Address : out Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + pragma Unreferenced (Alignment); + -- Ignored, we always force Storage_Alignment + + type Local_Storage_Array is new Storage_Array + (1 .. Size_In_Storage_Elements + Extra_Allocation); + + 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(). + + Current : Byte_Count; + P : Ptr; + Trace : Traceback_Htable_Elem_Ptr; + + Reset_Disable_At_Exit : Boolean := False; + + Lock : Scope_Lock; + pragma Unreferenced (Lock); + + begin + <> + + if Disable then + Storage_Address := + System.CRTL.malloc (System.CRTL.size_t (Size_In_Storage_Elements)); + return; + end if; + + Reset_Disable_At_Exit := True; + Disable := True; + + Pool.Alloc_Count := Pool.Alloc_Count + 1; + + -- 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 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.Logically_Deallocated > + Byte_Count (Pool.Maximum_Logically_Freed_Memory) + then + Free_Physically (Pool); + end if; + + -- Use standard (i.e. 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. Note that we do not initialize the storage array since it + -- is not necessary to do so (however this will cause bogus valgrind + -- warnings, which should simply be ignored). + + begin + P := new Local_Storage_Array; + + exception + when Storage_Error => + Free_Physically (Pool); + P := new Local_Storage_Array; + end; + + -- Compute Storage_Address, aimed at receiving user data. We need room + -- for the allocation header just ahead of the user data space plus + -- alignment padding so Storage_Address is aligned on Storage_Alignment, + -- like so: + -- + -- Storage_Address, aligned + -- on Storage_Alignment + -- v + -- | ~~~~ | Header | User data ... | + -- ^........^ + -- Header_Offset + -- + -- Header_Offset is fixed so moving back and forth between user data + -- and allocation header is straightforward. The value is also such + -- that the header type alignment is honored when starting from + -- Default_alignment. + + -- For the purpose of computing Storage_Address, we just do as if the + -- header was located first, followed by the alignment padding: + + Storage_Address := + To_Address (Align (To_Integer (P.all'Address) + + Integer_Address (Header_Offset))); + -- Computation is done in Integer_Address, not Storage_Offset, because + -- the range of Storage_Offset may not be large enough. + + pragma Assert ((Storage_Address - System.Null_Address) + mod Storage_Alignment = 0); + pragma Assert (Storage_Address + Size_In_Storage_Elements + <= P.all'Address + P'Length); + + Trace := + Find_Or_Create_Traceback + (Pool => Pool, + Kind => Alloc, + Size => Size_In_Storage_Elements, + Ignored_Frame_Start => Allocate_Label'Address, + Ignored_Frame_End => 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 + -- Storage_Alignment. + + Header_Of (Storage_Address).all := + (Allocation_Address => P.all'Address, + 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); + + if Pool.Low_Level_Traces then + Put (Output_File (Pool), + "info: Allocated" + & Storage_Count'Image (Size_In_Storage_Elements) + & " bytes at "); + Print_Address (Output_File (Pool), Storage_Address); + Put (Output_File (Pool), + " (physically:" + & Storage_Count'Image (Local_Storage_Array'Length) + & " bytes at "); + Print_Address (Output_File (Pool), P.all'Address); + Put (Output_File (Pool), + "), at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Allocate_Label'Address, + Code_Address_For_Deallocate_End); + end if; + + -- Update internal data + + Pool.Allocated := + Pool.Allocated + Byte_Count (Size_In_Storage_Elements); + + Current := Pool.Current_Water_Mark; + + if Current > Pool.High_Water then + Pool.High_Water := Current; + end if; + + Disable := False; + + exception + when others => + if Reset_Disable_At_Exit then + Disable := False; + end if; + raise; + 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 + <> + 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 + not (Total_Freed > Pool.Minimum_To_Free + and Pool.Logically_Deallocated < + Byte_Count (Pool.Maximum_Logically_Freed_Memory)) + loop + Header := Header_Of (Tmp); + + -- If we know, or at least assume, the block is no longer + -- referenced 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; + + if Pool.Low_Level_Traces then + Put + (Output_File (Pool), + "info: Freeing physical memory " + & Storage_Count'Image + ((abs Header.Block_Size) + Extra_Allocation) + & " bytes at "); + Print_Address (Output_File (Pool), + Header.Allocation_Address); + Put_Line (Output_File (Pool), ""); + end if; + + if System_Memory_Debug_Pool_Enabled then + System.CRTL.free (Header.Allocation_Address); + else + System.Memory.Free (Header.Allocation_Address); + end if; + + 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 + To_Byte (A).all := (if In_Use then In_Use_Mark else Free_Mark); + 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; + + Lock : Scope_Lock; + pragma Unreferenced (Lock); + + -- Start of processing for Free_Physically + + begin + if Pool.Advanced_Scanning then + + -- Reset the mark for each freed block + + Reset_Marks; + + 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; + end Free_Physically; + + -------------- + -- Get_Size -- + -------------- + + procedure Get_Size + (Storage_Address : Address; + Size_In_Storage_Elements : out Storage_Count; + Valid : out Boolean) + is + Lock : Scope_Lock; + pragma Unreferenced (Lock); + + begin + Valid := Is_Valid (Storage_Address); + + if Is_Valid (Storage_Address) then + declare + Header : constant Allocation_Header_Access := + Header_Of (Storage_Address); + + begin + if Header.Block_Size >= 0 then + Valid := True; + Size_In_Storage_Elements := Header.Block_Size; + else + Valid := False; + end if; + end; + else + Valid := False; + end if; + end Get_Size; + + --------------------- + -- Print_Traceback -- + --------------------- + + procedure Print_Traceback + (Output_File : File_Type; + Prefix : String; + Traceback : Traceback_Htable_Elem_Ptr) + is + begin + if Traceback /= null then + Put (Output_File, Prefix); + Put_Line (Output_File, 0, Traceback.Traceback); + end if; + end Print_Traceback; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + pragma Unreferenced (Alignment); + + Header : constant Allocation_Header_Access := + Header_Of (Storage_Address); + Previous : System.Address; + Valid : Boolean; + + Header_Block_Size_Was_Less_Than_0 : Boolean := True; + + begin + <> + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + + begin + Valid := Is_Valid (Storage_Address); + + if Valid and then not (Header.Block_Size < 0) then + Header_Block_Size_Was_Less_Than_0 := False; + + -- Some sort of codegen problem or heap corruption caused the + -- Size_In_Storage_Elements to be wrongly computed. The code + -- below is all based on the assumption that Header.all is not + -- corrupted, such that the error is non-fatal. + + if Header.Block_Size /= Size_In_Storage_Elements and then + Size_In_Storage_Elements /= Storage_Count'Last + then + Put_Line (Output_File (Pool), + "error: Deallocate size " + & Storage_Count'Image (Size_In_Storage_Elements) + & " does not match allocate size " + & Storage_Count'Image (Header.Block_Size)); + end if; + + if Pool.Low_Level_Traces then + Put (Output_File (Pool), + "info: Deallocated" + & Storage_Count'Image (Header.Block_Size) + & " bytes at "); + Print_Address (Output_File (Pool), Storage_Address); + Put (Output_File (Pool), + " (physically" + & Storage_Count'Image + (Header.Block_Size + Extra_Allocation) + & " bytes at "); + Print_Address (Output_File (Pool), Header.Allocation_Address); + Put (Output_File (Pool), "), at "); + + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + Print_Traceback (Output_File (Pool), + " Memory was allocated at ", + Header.Alloc_Traceback); + end if; + + -- Remove this block from the list of used blocks + + Previous := + To_Address (Header.Dealloc_Traceback); + + if Previous = System.Null_Address then + Pool.First_Used_Block := Header_Of (Pool.First_Used_Block).Next; + + if Pool.First_Used_Block /= System.Null_Address then + Header_Of (Pool.First_Used_Block).Dealloc_Traceback := + To_Traceback (null); + end if; + + else + Header_Of (Previous).Next := Header.Next; + + if Header.Next /= System.Null_Address then + Header_Of + (Header.Next).Dealloc_Traceback := To_Address (Previous); + end if; + end if; + + -- Update the Alloc_Traceback Frees/Total_Frees members + -- (if present) + + if Header.Alloc_Traceback /= null then + Header.Alloc_Traceback.Frees := + Header.Alloc_Traceback.Frees + 1; + Header.Alloc_Traceback.Total_Frees := + Header.Alloc_Traceback.Total_Frees + + Byte_Count (Header.Block_Size); + end if; + + Pool.Free_Count := Pool.Free_Count + 1; + + -- Update the header + + Header.all := + (Allocation_Address => Header.Allocation_Address, + Alloc_Traceback => Header.Alloc_Traceback, + Dealloc_Traceback => To_Traceback + (Find_Or_Create_Traceback + (Pool, Dealloc, + Header.Block_Size, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End)), + Next => System.Null_Address, + Block_Size => -Header.Block_Size); + + if Pool.Reset_Content_On_Free then + Set_Dead_Beef (Storage_Address, -Header.Block_Size); + end if; + + Pool.Logically_Deallocated := + Pool.Logically_Deallocated + Byte_Count (-Header.Block_Size); + + -- 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. + end if; + end; + + if not Valid then + if Storage_Address = System.Null_Address then + if Pool.Raise_Exceptions and then + Size_In_Storage_Elements /= Storage_Count'Last + then + raise Freeing_Not_Allocated_Storage; + else + Put (Output_File (Pool), + "error: Freeing Null_Address, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + return; + end if; + end if; + + if Allow_Unhandled_Memory + and then not Is_Handled (Storage_Address) + then + System.CRTL.free (Storage_Address); + return; + end if; + + if Pool.Raise_Exceptions + and then Size_In_Storage_Elements /= Storage_Count'Last + then + raise Freeing_Not_Allocated_Storage; + else + Put (Output_File (Pool), + "error: Freeing not allocated storage, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + end if; + + elsif Header_Block_Size_Was_Less_Than_0 then + if Pool.Raise_Exceptions then + raise Freeing_Deallocated_Storage; + else + Put (Output_File (Pool), + "error: Freeing already deallocated storage, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Deallocate_Label'Address, + Code_Address_For_Deallocate_End); + Print_Traceback (Output_File (Pool), + " Memory already deallocated at ", + To_Traceback (Header.Dealloc_Traceback)); + Print_Traceback (Output_File (Pool), " Memory was allocated at ", + Header.Alloc_Traceback); + end if; + end if; + end Deallocate; + + -------------------- + -- Deallocate_End -- + -------------------- + + -- DO NOT MOVE, this must be right after Deallocate + + -- See Allocate_End + + -- This is making assumptions about code order that may be invalid ??? + + procedure Deallocate_End is + begin + <> + Code_Address_For_Deallocate_End := Deallocate_End_Label'Address; + end Deallocate_End; + + ----------------- + -- Dereference -- + ----------------- + + procedure Dereference + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count) + is + pragma Unreferenced (Alignment, Size_In_Storage_Elements); + + 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 not Valid then + if Pool.Raise_Exceptions then + raise Accessing_Not_Allocated_Storage; + else + Put (Output_File (Pool), + "error: Accessing not allocated storage, at "); + Put_Line (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Dereference_Label'Address, + Code_Address_For_Dereference_End); + end if; + + else + Header := Header_Of (Storage_Address); + + if Header.Block_Size < 0 then + if Pool.Raise_Exceptions then + raise Accessing_Deallocated_Storage; + else + Put (Output_File (Pool), + "error: Accessing deallocated storage, at "); + Put_Line + (Output_File (Pool), Pool.Stack_Trace_Depth, null, + Dereference_Label'Address, + Code_Address_For_Dereference_End); + Print_Traceback (Output_File (Pool), " First deallocation at ", + To_Traceback (Header.Dealloc_Traceback)); + Print_Traceback (Output_File (Pool), " Initial allocation at ", + Header.Alloc_Traceback); + end if; + end if; + end if; + end Dereference; + + --------------------- + -- Dereference_End -- + --------------------- + + -- DO NOT MOVE: this must be right after Dereference + + -- See Allocate_End + + -- This is making assumptions about code order that may be invalid ??? + + procedure Dereference_End is + begin + <> + Code_Address_For_Dereference_End := Dereference_End_Label'Address; + end Dereference_End; + + ---------------- + -- Print_Info -- + ---------------- + + procedure Print_Info + (Pool : Debug_Pool; + Cumulate : Boolean := False; + Display_Slots : Boolean := False; + Display_Leaks : Boolean := False) + is + 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??? + + Current : System.Address; + Data : Traceback_Htable_Elem_Ptr; + Elem : Traceback_Htable_Elem_Ptr; + Header : Allocation_Header_Access; + K : Traceback_Kind; + + begin + Put_Line + ("Total allocated bytes : " & + Byte_Count'Image (Pool.Allocated)); + + Put_Line + ("Total logically deallocated bytes : " & + Byte_Count'Image (Pool.Logically_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 dangerous, 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.Current_Water_Mark)); + + Put_Line + ("High Water Mark: " & + Byte_Count'Image (Pool.High_Water)); + + Put_Line (""); + + if Display_Slots then + 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, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + Next => null); + Backtrace_Htable_Cumulate.Set (Elem); + + if Cumulate then + K := (if Data.Kind = Alloc then Indirect_Alloc + else Indirect_Dealloc); + + -- 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, + Frees => Data.Frees, + Total_Frees => Data.Total_Frees, + 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; + + 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 (Image_C (PC_For (Data.Traceback (T))) & ' '); + end loop; + + Put_Line (""); + + Data := Backtrace_Htable_Cumulate.Get_Next; + end loop; + + Backtrace_Htable_Cumulate.Reset; + 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: "); + + if Header.Alloc_Traceback /= null then + for T in Header.Alloc_Traceback.Traceback'Range loop + Put (Image_C + (PC_For (Header.Alloc_Traceback.Traceback (T))) & ' '); + end loop; + end if; + + Put_Line (""); + Current := Header.Next; + end loop; + end if; + end Print_Info; + + ---------- + -- Dump -- + ---------- + + procedure Dump + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports) + is + procedure Do_Report (Sort : Report_Type); + -- Do a specific type of report + + --------------- + -- Do_Report -- + --------------- + + procedure Do_Report (Sort : Report_Type) is + Elem : Traceback_Htable_Elem_Ptr; + Bigger : Boolean; + Grand_Total : Float; + + Max : array (1 .. Size) of Traceback_Htable_Elem_Ptr := + (others => null); + -- Sorted array for the biggest memory users + + Allocated_In_Pool : Byte_Count; + -- safe thread Pool.Allocated + + Elem_Safe : Traceback_Htable_Elem; + -- safe thread current elem.all; + + Max_M_Safe : Traceback_Htable_Elem; + -- safe thread Max(M).all + + begin + Put_Line (""); + + case Sort is + when All_Reports + | Memory_Usage + => + Put_Line (Size'Img & " biggest memory users at this time:"); + Put_Line ("Results include bytes and chunks still allocated"); + Grand_Total := Float (Pool.Current_Water_Mark); + + when Allocations_Count => + Put_Line (Size'Img & " biggest number of live allocations:"); + Put_Line ("Results include bytes and chunks still allocated"); + Grand_Total := Float (Pool.Current_Water_Mark); + + when Sort_Total_Allocs => + Put_Line (Size'Img & " biggest number of allocations:"); + Put_Line ("Results include total bytes and chunks allocated,"); + Put_Line ("even if no longer allocated - Deallocations are" + & " ignored"); + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Allocated_In_Pool := Pool.Allocated; + end; + + Grand_Total := Float (Allocated_In_Pool); + + when Marked_Blocks => + Put_Line ("Special blocks marked by Mark_Traceback"); + Grand_Total := 0.0; + end case; + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Elem := Backtrace_Htable.Get_First; + end; + + while Elem /= null loop + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Elem_Safe := Elem.all; + end; + + -- Handle only alloc elememts + if Elem_Safe.Kind = Alloc then + -- Ignore small blocks (depending on the sorting criteria) to + -- gain speed. + + if (Sort = Memory_Usage + and then Elem_Safe.Total - Elem_Safe.Total_Frees >= 1_000) + or else (Sort = Allocations_Count + and then Elem_Safe.Count - Elem_Safe.Frees >= 1) + or else (Sort = Sort_Total_Allocs + and then Elem_Safe.Count > 1) + or else (Sort = Marked_Blocks + and then Elem_Safe.Total = 0) + then + if Sort = Marked_Blocks then + Grand_Total := Grand_Total + Float (Elem_Safe.Count); + end if; + + for M in Max'Range loop + Bigger := Max (M) = null; + if not Bigger then + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Max_M_Safe := Max (M).all; + end; + + case Sort is + when All_Reports + | Memory_Usage + => + Bigger := + Max_M_Safe.Total - Max_M_Safe.Total_Frees + < Elem_Safe.Total - Elem_Safe.Total_Frees; + + when Allocations_Count => + Bigger := + Max_M_Safe.Count - Max_M_Safe.Frees + < Elem_Safe.Count - Elem_Safe.Frees; + + when Marked_Blocks + | Sort_Total_Allocs + => + Bigger := Max_M_Safe.Count < Elem_Safe.Count; + end case; + end if; + + if Bigger then + Max (M + 1 .. Max'Last) := Max (M .. Max'Last - 1); + Max (M) := Elem; + exit; + end if; + end loop; + end if; + end if; + + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Elem := Backtrace_Htable.Get_Next; + end; + end loop; + + if Grand_Total = 0.0 then + Grand_Total := 1.0; + end if; + + for M in Max'Range loop + exit when Max (M) = null; + declare + type Percent is delta 0.1 range 0.0 .. 100.0; + + P : Percent; + Total : Byte_Count; + + begin + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Max_M_Safe := Max (M).all; + end; + + case Sort is + when All_Reports + | Allocations_Count + | Memory_Usage + => + Total := Max_M_Safe.Total - Max_M_Safe.Total_Frees; + + when Sort_Total_Allocs => + Total := Max_M_Safe.Total; + + when Marked_Blocks => + Total := Byte_Count (Max_M_Safe.Count); + end case; + + declare + Normalized_Total : constant Float := Float (Total); + -- In multi tasking configuration, memory deallocations + -- during Do_Report processing can lead to Total > + -- Grand_Total. As Percent requires Total <= Grand_Total + + begin + if Normalized_Total > Grand_Total then + P := 100.0; + else + P := Percent (100.0 * Normalized_Total / Grand_Total); + end if; + end; + + case Sort is + when All_Reports + | Allocations_Count + | Memory_Usage + => + declare + Count : constant Natural := + Max_M_Safe.Count - Max_M_Safe.Frees; + begin + Put (P'Img & "%:" & Total'Img & " bytes in" + & Count'Img & " chunks at"); + end; + + when Sort_Total_Allocs => + Put (P'Img & "%:" & Total'Img & " bytes in" + & Max_M_Safe.Count'Img & " chunks at"); + + when Marked_Blocks => + Put (P'Img & "%:" + & Max_M_Safe.Count'Img & " chunks /" + & Integer (Grand_Total)'Img & " at"); + end case; + end; + + for J in Max (M).Traceback'Range loop + Put (" " & Image_C (PC_For (Max (M).Traceback (J)))); + end loop; + + Put_Line (""); + end loop; + end Do_Report; + + -- Local variables + + Total_Freed : Byte_Count; + -- safe thread pool logically & physically deallocated + + Traceback_Elements_Allocated : Byte_Count; + -- safe thread Traceback_Count + + Validity_Elements_Allocated : Byte_Count; + -- safe thread Validity_Count + + Ada_Allocs_Bytes : Byte_Count; + -- safe thread pool Allocated + + Ada_Allocs_Chunks : Byte_Count; + -- safe thread pool Alloc_Count + + Ada_Free_Chunks : Byte_Count; + -- safe thread pool Free_Count + + -- Start of processing for Dump + + begin + declare + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Total_Freed := + Pool.Logically_Deallocated + Pool.Physically_Deallocated; + Traceback_Elements_Allocated := Traceback_Count; + Validity_Elements_Allocated := Validity_Count; + Ada_Allocs_Bytes := Pool.Allocated; + Ada_Allocs_Chunks := Pool.Alloc_Count; + Ada_Free_Chunks := Pool.Free_Count; + end; + + Put_Line + ("Traceback elements allocated: " & Traceback_Elements_Allocated'Img); + Put_Line + ("Validity elements allocated: " & Validity_Elements_Allocated'Img); + Put_Line (""); + + Put_Line ("Ada Allocs:" & Ada_Allocs_Bytes'Img + & " bytes in" & Ada_Allocs_Chunks'Img & " chunks"); + Put_Line ("Ada Free:" & Total_Freed'Img & " bytes in" & + Ada_Free_Chunks'Img + & " chunks"); + Put_Line ("Ada Current watermark: " + & Byte_Count'Image (Pool.Current_Water_Mark) + & " in" & Byte_Count'Image (Ada_Allocs_Chunks - + Ada_Free_Chunks) & " chunks"); + Put_Line ("Ada High watermark: " & Pool.High_Water_Mark'Img); + + case Report is + when All_Reports => + for Sort in Report_Type loop + if Sort /= All_Reports then + Do_Report (Sort); + end if; + end loop; + + when others => + Do_Report (Report); + end case; + end Dump; + + ----------------- + -- Dump_Stdout -- + ----------------- + + procedure Dump_Stdout + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports) + is + procedure Internal is new Dump + (Put_Line => Stdout_Put_Line, + Put => Stdout_Put); + + -- Start of processing for Dump_Stdout + + begin + Internal (Pool, Size, Report); + end Dump_Stdout; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + Elem : Traceback_Htable_Elem_Ptr; + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + Elem := Backtrace_Htable.Get_First; + while Elem /= null loop + Elem.Count := 0; + Elem.Frees := 0; + Elem.Total := 0; + Elem.Total_Frees := 0; + Elem := Backtrace_Htable.Get_Next; + end loop; + end Reset; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size (Pool : Debug_Pool) return Storage_Count is + pragma Unreferenced (Pool); + begin + return Storage_Count'Last; + end Storage_Size; + + --------------------- + -- High_Water_Mark -- + --------------------- + + function High_Water_Mark (Pool : Debug_Pool) return Byte_Count is + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + return Pool.High_Water; + end High_Water_Mark; + + ------------------------ + -- Current_Water_Mark -- + ------------------------ + + function Current_Water_Mark (Pool : Debug_Pool) return Byte_Count is + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + return Pool.Allocated - Pool.Logically_Deallocated - + Pool.Physically_Deallocated; + end Current_Water_Mark; + + ------------------------------ + -- System_Memory_Debug_Pool -- + ------------------------------ + + procedure System_Memory_Debug_Pool + (Has_Unhandled_Memory : Boolean := True) + is + Lock : Scope_Lock; + pragma Unreferenced (Lock); + begin + System_Memory_Debug_Pool_Enabled := True; + Allow_Unhandled_Memory := Has_Unhandled_Memory; + end System_Memory_Debug_Pool; + + --------------- + -- 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; + Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; + Low_Level_Traces : Boolean := Default_Low_Level_Traces) + is + Lock : Scope_Lock; + pragma Unreferenced (Lock); + 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; + Pool.Errors_To_Stdout := Errors_To_Stdout; + Pool.Low_Level_Traces := Low_Level_Traces; + 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 + (Standard_Output, "Memory not under control of the storage pool"); + return; + end if; + + if not Valid then + Put_Line + (Standard_Output, "Memory not under control of the storage pool"); + + else + Header := Header_Of (Storage); + Print_Address (Standard_Output, A); + Put_Line (Standard_Output, " allocated at:"); + Print_Traceback (Standard_Output, "", Header.Alloc_Traceback); + + if To_Traceback (Header.Dealloc_Traceback) /= null then + Print_Address (Standard_Output, A); + Put_Line (Standard_Output, + " logically freed memory, deallocated at:"); + Print_Traceback (Standard_Output, "", + To_Traceback (Header.Dealloc_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 => Stdout_Put_Line, + Put => Stdout_Put); + + -- Start of processing for Print_Info_Stdout + + 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; + Dummy_Time : Duration := 1.0; + + begin + File := fopen (File_Name & ASCII.NUL, "wb" & ASCII.NUL); + fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, File); + + fwrite + (Ptr => Dummy_Time'Address, + Size => Duration'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => 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); + + if Header.Alloc_Traceback /= null then + Tracebk := Header.Alloc_Traceback.Traceback; + Num_Calls := Tracebk'Length; + + -- (Code taken from memtrack.adb in GNAT's sources) + + -- Logs allocation call using the format: + + -- 'A' ... + + fputc (Character'Pos ('A'), File); + fwrite (Current'Address, Address_Size, 1, File); + + fwrite + (Ptr => Actual_Size'Address, + Size => size_t'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => File); + + fwrite + (Ptr => Dummy_Time'Address, + Size => Duration'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => File); + + fwrite + (Ptr => Num_Calls'Address, + Size => Integer'Max_Size_In_Storage_Elements, + Nmemb => 1, + Stream => 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; + end if; + + Current := Header.Next; + end loop; + + fclose (File); + end Dump_Gnatmem; + + ---------------- + -- Stdout_Put -- + ---------------- + + procedure Stdout_Put (S : String) is + begin + Put (Standard_Output, S); + end Stdout_Put; + + --------------------- + -- Stdout_Put_Line -- + --------------------- + + procedure Stdout_Put_Line (S : String) is + begin + Put_Line (Standard_Output, S); + end Stdout_Put_Line; + +-- Package initialization + +begin + Allocate_End; + Deallocate_End; + Dereference_End; +end GNAT.Debug_Pools; diff --git a/gcc/ada/libgnat/g-debpoo.ads b/gcc/ada/libgnat/g-debpoo.ads new file mode 100644 index 0000000..7cd3fa1 --- /dev/null +++ b/gcc/ada/libgnat/g-debpoo.ads @@ -0,0 +1,409 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D E B U G _ P O O L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This packages provides a special implementation of the Ada 95 storage pools + +-- The goal of this debug pool is to detect incorrect uses of memory +-- (multiple deallocations, access to invalid memory,...). Errors are reported +-- in one of two ways: either by immediately raising an exception, or by +-- printing a message on standard output or standard error. + +-- You need to instrument your code to use this package: for each access type +-- you want to monitor, you need to add a clause similar to: + +-- type Integer_Access is access Integer; +-- for Integer_Access'Storage_Pool use Pool; + +-- where Pool is a tagged object declared with +-- +-- Pool : GNAT.Debug_Pools.Debug_Pool; + +-- This package was designed to be as efficient as possible, but still has an +-- impact on the performance of your code, which depends on the number of +-- allocations, deallocations and, somewhat less, dereferences that your +-- application performs. + +-- For each faulty memory use, this debug pool will print several lines +-- of information, including things like the location where the memory +-- was initially allocated, the location where it was freed etc. + +-- Physical allocations and deallocations are done through the usual system +-- calls. However, in order to provide proper checks, the debug pool will not +-- release the memory immediately. It keeps released memory around (the amount +-- kept around is configurable) so that it can distinguish between memory that +-- has not been allocated and memory that has been allocated but freed. This +-- also means that this memory cannot be reallocated, preventing what would +-- otherwise be a false indication that freed memory is now allocated. + +-- In addition, this package presents several subprograms that help analyze +-- the behavior of your program, by reporting memory leaks, the total amount +-- of memory that was allocated. The pool is also designed to work correctly +-- in conjunction with gnatmem. + +-- Finally, a subprogram Print_Pool is provided for use from the debugger + +-- Limitations +-- =========== + +-- Current limitation of this debug pool: if you use this debug pool for a +-- general access type ("access all"), the pool might report invalid +-- dereferences if the access object is pointing to another object on the +-- stack which was not allocated through a call to "new". + +-- This debug pool will respect all alignments specified in your code, but +-- it does that by aligning all objects using Standard'Maximum_Alignment. +-- This allows faster checks, and limits the performance impact of using +-- this pool. + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; +with System.Checked_Pools; + +package GNAT.Debug_Pools is + + type Debug_Pool is new System.Checked_Pools.Checked_Pool with private; + -- The new debug pool + + subtype SSC is System.Storage_Elements.Storage_Count; + + Default_Max_Freed : constant SSC := 50_000_000; + Default_Stack_Trace_Depth : constant Natural := 20; + Default_Reset_Content : constant Boolean := False; + Default_Raise_Exceptions : constant Boolean := True; + Default_Advanced_Scanning : constant Boolean := False; + Default_Min_Freed : constant SSC := 0; + Default_Errors_To_Stdout : constant Boolean := True; + Default_Low_Level_Traces : constant Boolean := False; + -- The above values are constants used for the parameters to Configure + -- if not overridden in the call. See description of Configure for full + -- details on these parameters. If these defaults are not satisfactory, + -- then you need to call Configure to change the default values. + + 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; + Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; + Low_Level_Traces : Boolean := Default_Low_Level_Traces); + -- Subprogram used to configure the debug pool. + -- + -- Stack_Trace_Depth. This parameter controls the maximum depth of stack + -- traces that are output to indicate locations of actions for error + -- conditions such as bad allocations. If set to zero, the debug pool + -- will not try to compute backtraces. This is more efficient but gives + -- less information on problem locations + -- + -- Maximum_Logically_Freed_Memory: maximum amount of memory (bytes) + -- that should be kept before starting to physically deallocate some. + -- This value should be non-zero, since having memory that is logically + -- but not physically freed helps to detect invalid memory accesses. + -- + -- Minimum_To_Free is the minimum amount of memory that should be freed + -- every time the pool starts physically releasing memory. The algorithm + -- to compute which block should be physically released needs some + -- expensive initialization (see Advanced_Scanning below), and this + -- parameter can be used to limit the performance impact by ensuring + -- that a reasonable amount of memory is freed each time. Even in the + -- advanced scanning mode, marked blocks may be released to match this + -- Minimum_To_Free parameter. + -- + -- Reset_Content_On_Free: If true, then the contents of the freed memory + -- is reset to the pattern 16#DEADBEEF#, following an old IBM convention. + -- This helps in detecting invalid memory references from the debugger. + -- + -- Raise_Exceptions: If true, the exceptions below will be raised every + -- time an error is detected. If you set this to False, then the action + -- is to generate output on standard error or standard output, depending + -- on Errors_To_Stdout, noting the errors, but to + -- keep running if possible (of course if storage is badly damaged, this + -- attempt may fail. This helps to detect more than one error in a run. + -- + -- Advanced_Scanning: If true, the pool will check the contents of all + -- allocated blocks before physically releasing memory. Any possible + -- reference to a logically free block will prevent its deallocation. + -- Note that this algorithm is approximate, and it is recommended + -- that you set Minimum_To_Free to a non-zero value to save time. + -- + -- Errors_To_Stdout: Errors messages will be displayed on stdout if + -- this parameter is True, or to stderr otherwise. + -- + -- Low_Level_Traces: Traces all allocation and deallocations on the + -- stream specified by Errors_To_Stdout. This can be used for + -- post-processing by your own application, or to debug the + -- debug_pool itself. The output indicates the size of the allocated + -- block both as requested by the application and as physically + -- allocated to fit the additional information needed by the debug + -- pool. + -- + -- All instantiations of this pool use the same internal tables. However, + -- they do not store the same amount of information for the tracebacks, + -- and they have different counters for maximum logically freed memory. + + Accessing_Not_Allocated_Storage : exception; + -- Exception raised if Raise_Exception is True, and an attempt is made + -- to access storage that was never allocated. + + Accessing_Deallocated_Storage : exception; + -- Exception raised if Raise_Exception is True, and an attempt is made + -- to access storage that was allocated but has been deallocated. + + Freeing_Not_Allocated_Storage : exception; + -- Exception raised if Raise_Exception is True, and an attempt is made + -- to free storage that had not been previously allocated. + + Freeing_Deallocated_Storage : exception; + -- Exception raised if Raise_Exception is True, and an attempt is made + -- to free storage that had already been freed. + + -- Note on the above exceptions. The distinction between not allocated + -- and deallocated storage is not guaranteed to be accurate in the case + -- where storage is allocated, and then physically freed. Larger values + -- of the parameter Maximum_Logically_Freed_Memory will help to guarantee + -- that this distinction is made more accurately. + + generic + with procedure Put_Line (S : String) is <>; + with procedure Put (S : String) is <>; + procedure Print_Info + (Pool : Debug_Pool; + Cumulate : Boolean := False; + Display_Slots : Boolean := False; + Display_Leaks : Boolean := False); + -- Print out information about the High Water Mark, the current and + -- total number of bytes allocated and the total number of bytes + -- deallocated. + -- + -- If Display_Slots is true, this subprogram prints a list of all the + -- locations in the application that have done at least one allocation or + -- deallocation. The result might be used to detect places in the program + -- where lots of allocations are taking place. This output is not in any + -- defined order. + -- + -- If Cumulate if True, then each stack trace will display the number of + -- allocations that were done either directly, or by the subprograms called + -- at that location (e.g: if there were two physical allocations at a->b->c + -- and a->b->d, then a->b would be reported as performing two allocations). + -- + -- If Display_Leaks is true, then each block that has not been deallocated + -- (often called a "memory leak") will be listed, along with the traceback + -- showing where it was allocated. Not that no grouping of the blocks is + -- done, you should use the Dump_Gnatmem procedure below in conjunction + -- with the gnatmem utility. + + procedure Print_Info_Stdout + (Pool : Debug_Pool; + Cumulate : Boolean := False; + Display_Slots : Boolean := False; + Display_Leaks : Boolean := False); + -- Standard instantiation of Print_Info to print on standard_output. More + -- convenient to use where this is the intended location, and in particular + -- easier to use from the debugger. + + procedure Dump_Gnatmem (Pool : Debug_Pool; File_Name : String); + -- Create an external file on the disk, which can be processed by gnatmem + -- to display the location of memory leaks. + -- + -- This provides a nicer output that Print_Info above, and groups similar + -- stack traces together. This also provides an easy way to save the memory + -- status of your program for post-mortem analysis. + -- + -- To use this file, use the following command line: + -- gnatmem 5 -i + -- If you want all the stack traces to be displayed with 5 levels. + + procedure Print_Pool (A : System.Address); + pragma Export (C, Print_Pool, "print_pool"); + -- This subprogram is meant to be used from a debugger. Given an address in + -- memory, it will print on standard output the known information about + -- this address (provided, of course, the matching pointer is handled by + -- the Debug_Pool). + -- + -- The information includes the stacktrace for the allocation or + -- deallocation of that memory chunk, its current status (allocated or + -- logically freed), etc. + + type Report_Type is + (All_Reports, + Memory_Usage, + Allocations_Count, + Sort_Total_Allocs, + Marked_Blocks); + for Report_Type use + (All_Reports => 0, + Memory_Usage => 1, + Allocations_Count => 2, + Sort_Total_Allocs => 3, + Marked_Blocks => 4); + + generic + with procedure Put_Line (S : String) is <>; + with procedure Put (S : String) is <>; + procedure Dump + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports); + -- Dump information about memory usage. + -- Size is the number of the biggest memory users we want to show. Report + -- indicates which sorting order is used in the report. + + procedure Dump_Stdout + (Pool : Debug_Pool; + Size : Positive; + Report : Report_Type := All_Reports); + -- Standard instantiation of Dump to print on standard_output. More + -- convenient to use where this is the intended location, and in particular + -- easier to use from the debugger. + + procedure Reset; + -- Reset all internal data. This is in general not needed, unless you want + -- to know what memory is used by specific parts of your application + + procedure Get_Size + (Storage_Address : Address; + Size_In_Storage_Elements : out Storage_Count; + Valid : out Boolean); + -- Set Valid if Storage_Address is the address of a chunk of memory + -- currently allocated by any pool. + -- If Valid is True, Size_In_Storage_Elements is set to the size of this + -- chunk of memory. + + type Byte_Count is mod System.Max_Binary_Modulus; + -- Type used for maintaining byte counts, needs to be large enough to + -- to accommodate counts allowing for repeated use of the same memory. + + function High_Water_Mark + (Pool : Debug_Pool) return Byte_Count; + -- Return the highest size of the memory allocated by the pool. + -- Memory used internally by the pool is not taken into account. + + function Current_Water_Mark + (Pool : Debug_Pool) return Byte_Count; + -- Return the size of the memory currently allocated by the pool. + -- Memory used internally by the pool is not taken into account. + + procedure System_Memory_Debug_Pool + (Has_Unhandled_Memory : Boolean := True); + -- Let the package know the System.Memory is using it. + -- If Has_Unhandled_Memory is true, some deallocation can be done for + -- memory not allocated with Allocate. + +private + -- The following are the standard primitive subprograms for a pool + + procedure Allocate + (Pool : in out Debug_Pool; + Storage_Address : out Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count); + -- Allocate a new chunk of memory, and set it up so that the debug pool + -- can check accesses to its data, and report incorrect access later on. + -- The parameters have the same semantics as defined in the ARM95. + + procedure Deallocate + (Pool : in out Debug_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count); + -- Mark a block of memory as invalid. It might not be physically removed + -- immediately, depending on the setup of the debug pool, so that checks + -- are still possible. The parameters have the same semantics as defined + -- in the RM. + + function Storage_Size (Pool : Debug_Pool) return SSC; + -- Return the maximal size of data that can be allocated through Pool. + -- Since Pool uses the malloc() system call, all the memory is accessible + -- through the pool + + procedure Dereference + (Pool : in out Debug_Pool; + Storage_Address : System.Address; + Size_In_Storage_Elements : Storage_Count; + Alignment : Storage_Count); + -- Check whether a dereference statement is valid, i.e. whether the pointer + -- was allocated through Pool. As documented above, errors will be + -- reported either by a special error message or an exception, depending + -- on the setup of the storage pool. + -- The parameters have the same semantics as defined in the ARM95. + + type Debug_Pool is new System.Checked_Pools.Checked_Pool with record + Stack_Trace_Depth : Natural := Default_Stack_Trace_Depth; + Maximum_Logically_Freed_Memory : SSC := Default_Max_Freed; + Reset_Content_On_Free : Boolean := Default_Reset_Content; + Raise_Exceptions : Boolean := Default_Raise_Exceptions; + Minimum_To_Free : SSC := Default_Min_Freed; + Advanced_Scanning : Boolean := Default_Advanced_Scanning; + Errors_To_Stdout : Boolean := Default_Errors_To_Stdout; + Low_Level_Traces : Boolean := Default_Low_Level_Traces; + + Alloc_Count : Byte_Count := 0; + -- Total number of allocation + + Free_Count : Byte_Count := 0; + -- Total number of deallocation + + Allocated : Byte_Count := 0; + -- Total number of bytes allocated in this pool + + Logically_Deallocated : Byte_Count := 0; + -- Total number of bytes logically deallocated in this pool. This is the + -- memory that the application has released, but that the pool has not + -- yet physically released through a call to free(), to detect later + -- accessed to deallocated memory. + + Physically_Deallocated : Byte_Count := 0; + -- Total number of bytes that were free()-ed + + Marked_Blocks_Deallocated : Boolean := False; + -- Set to true if some mark blocks had to be deallocated in the advanced + -- scanning scheme. Since this is potentially dangerous, this is + -- reported to the user, who might want to rerun his program with a + -- lower Minimum_To_Free value. + + High_Water : Byte_Count := 0; + -- Maximum of Allocated - Logically_Deallocated - Physically_Deallocated + + First_Free_Block : System.Address := System.Null_Address; + Last_Free_Block : System.Address := System.Null_Address; + -- Pointers to the first and last logically freed blocks + + First_Used_Block : System.Address := System.Null_Address; + -- Pointer to the list of currently allocated blocks. This list is + -- used to list the memory leaks in the application on exit, as well as + -- for the advanced freeing algorithms that needs to traverse all these + -- blocks to find possible references to the block being physically + -- freed. + + end record; +end GNAT.Debug_Pools; diff --git a/gcc/ada/libgnat/g-debuti.adb b/gcc/ada/libgnat/g-debuti.adb new file mode 100644 index 0000000..a7c30d0 --- /dev/null +++ b/gcc/ada/libgnat/g-debuti.adb @@ -0,0 +1,188 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . D E B U G _ U T I L I T I E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +package body GNAT.Debug_Utilities is + + H : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + -- Table of hex digits + + ----------- + -- Image -- + ----------- + + -- Address case + + function Image (A : Address) return Image_String is + S : Image_String; + P : Natural; + N : Integer_Address; + U : Natural := 0; + + begin + S (S'Last) := '#'; + P := Address_Image_Length - 1; + N := To_Integer (A); + while P > 3 loop + if U = 4 then + S (P) := '_'; + P := P - 1; + U := 1; + + else + U := U + 1; + end if; + + S (P) := H (Integer (N mod 16)); + P := P - 1; + N := N / 16; + end loop; + + S (1 .. 3) := "16#"; + return S; + end Image; + + ----------- + -- Image -- + ----------- + + -- String case + + function Image (S : String) return String is + W : String (1 .. 2 * S'Length + 2); + P : Positive := 1; + + begin + W (1) := '"'; + + for J in S'Range loop + if S (J) = '"' then + P := P + 1; + W (P) := '"'; + end if; + + P := P + 1; + W (P) := S (J); + end loop; + + P := P + 1; + W (P) := '"'; + return W (1 .. P); + end Image; + + ------------- + -- Image_C -- + ------------- + + function Image_C (A : Address) return Image_C_String is + S : Image_C_String; + N : Integer_Address := To_Integer (A); + + begin + for P in reverse 3 .. S'Last loop + S (P) := H (Integer (N mod 16)); + N := N / 16; + end loop; + + S (1 .. 2) := "0x"; + return S; + end Image_C; + + ----------- + -- Value -- + ----------- + + function Value (S : String) return System.Address is + Base : Integer_Address := 10; + Res : Integer_Address := 0; + Last : Natural := S'Last; + C : Character; + N : Integer_Address; + + begin + -- Skip final Ada 95 base character + + if S (Last) = '#' or else S (Last) = ':' then + Last := Last - 1; + end if; + + -- Loop through characters + + for J in S'First .. Last loop + C := S (J); + + -- C format hex constant + + if C = 'x' then + if Res /= 0 then + raise Constraint_Error; + end if; + + Base := 16; + + -- Ada form based literal + + elsif C = '#' or else C = ':' then + Base := Res; + Res := 0; + + -- Ignore all underlines + + elsif C = '_' then + null; + + -- Otherwise must have digit + + else + if C in '0' .. '9' then + N := Character'Pos (C) - Character'Pos ('0'); + elsif C in 'A' .. 'F' then + N := Character'Pos (C) - (Character'Pos ('A') - 10); + elsif C in 'a' .. 'f' then + N := Character'Pos (C) - (Character'Pos ('a') - 10); + else + raise Constraint_Error; + end if; + + if N >= Base then + raise Constraint_Error; + else + Res := Res * Base + N; + end if; + end if; + end loop; + + return To_Address (Res); + end Value; + +end GNAT.Debug_Utilities; diff --git a/gcc/ada/libgnat/g-debuti.ads b/gcc/ada/libgnat/g-debuti.ads new file mode 100644 index 0000000..7e3dfe1 --- /dev/null +++ b/gcc/ada/libgnat/g-debuti.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D E B U G _ U T I L I T I E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Debugging utilities + +-- This package provides some useful utility subprograms for use in writing +-- routines that generate debugging output. + +with System; + +package GNAT.Debug_Utilities is + pragma Pure; + + Address_64 : constant Boolean := Standard'Address_Size = 64; + -- Set true if 64 bit addresses (assumes only 32 and 64 are possible) + + Address_Image_Length : constant := 13 + 10 * Boolean'Pos (Address_64); + -- Length of string returned by Image function for an address + + subtype Image_String is String (1 .. Address_Image_Length); + -- Subtype returned by Image function for an address + + Address_Image_C_Length : constant := 10 + 8 * Boolean'Pos (Address_64); + -- Length of string returned by Image_C function + + subtype Image_C_String is String (1 .. Address_Image_C_Length); + -- Subtype returned by Image_C function + + function Image (S : String) return String; + -- Returns a string image of S, obtained by prepending and appending + -- quote (") characters and doubling any quote characters in the string. + -- The maximum length of the result is thus 2 ** S'Length + 2. + + function Image (A : System.Address) return Image_String; + -- Returns a string of the form 16#hhhh_hhhh# for 32-bit addresses + -- or 16#hhhh_hhhh_hhhh_hhhh# for 64-bit addresses. Hex characters + -- are in upper case. + + function Image_C (A : System.Address) return Image_C_String; + -- Returns a string of the form 0xhhhhhhhh for 32 bit addresses or + -- 0xhhhhhhhhhhhhhhhh for 64-bit addresses. Hex characters are in + -- upper case. + + function Value (S : String) return System.Address; + -- Given a valid integer literal in any form, including the form returned + -- by the Image function in this package, yields the corresponding address. + -- Note that this routine will handle any Ada integer format, and will + -- also handle hex constants in C format (0xhh..hhh). Constraint_Error + -- may be raised for obviously incorrect data, but the routine is fairly + -- permissive, and in particular, all underscores in whatever position + -- are simply ignored completely. + +end GNAT.Debug_Utilities; diff --git a/gcc/ada/libgnat/g-decstr.adb b/gcc/ada/libgnat/g-decstr.adb new file mode 100644 index 0000000..ab3bfd1 --- /dev/null +++ b/gcc/ada/libgnat/g-decstr.adb @@ -0,0 +1,796 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D E C O D E _ S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 utility routine for converting from an encoded +-- string to a corresponding Wide_String or Wide_Wide_String value. + +with Interfaces; use Interfaces; + +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +package body GNAT.Decode_String is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Bad; + pragma No_Return (Bad); + -- Raise error for bad encoding + + procedure Past_End; + pragma No_Return (Past_End); + -- Raise error for off end of string + + --------- + -- Bad -- + --------- + + procedure Bad is + begin + raise Constraint_Error with + "bad encoding or character out of range"; + end Bad; + + --------------------------- + -- Decode_Wide_Character -- + --------------------------- + + procedure Decode_Wide_Character + (Input : String; + Ptr : in out Natural; + Result : out Wide_Character) + is + Char : Wide_Wide_Character; + begin + Decode_Wide_Wide_Character (Input, Ptr, Char); + + if Wide_Wide_Character'Pos (Char) > 16#FFFF# then + Bad; + else + Result := Wide_Character'Val (Wide_Wide_Character'Pos (Char)); + end if; + end Decode_Wide_Character; + + ------------------------ + -- Decode_Wide_String -- + ------------------------ + + function Decode_Wide_String (S : String) return Wide_String is + Result : Wide_String (1 .. S'Length); + Length : Natural; + begin + Decode_Wide_String (S, Result, Length); + return Result (1 .. Length); + end Decode_Wide_String; + + procedure Decode_Wide_String + (S : String; + Result : out Wide_String; + Length : out Natural) + is + Ptr : Natural; + + begin + Ptr := S'First; + Length := 0; + while Ptr <= S'Last loop + if Length >= Result'Last then + Past_End; + end if; + + Length := Length + 1; + Decode_Wide_Character (S, Ptr, Result (Length)); + end loop; + end Decode_Wide_String; + + -------------------------------- + -- Decode_Wide_Wide_Character -- + -------------------------------- + + procedure Decode_Wide_Wide_Character + (Input : String; + Ptr : in out Natural; + Result : out Wide_Wide_Character) + is + C : Character; + + function In_Char return Character; + pragma Inline (In_Char); + -- Function to get one input character + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + begin + if Ptr <= Input'Last then + Ptr := Ptr + 1; + return Input (Ptr - 1); + else + Past_End; + end if; + end In_Char; + + -- Start of processing for Decode_Wide_Wide_Character + + begin + C := In_Char; + + -- Special fast processing for UTF-8 case + + if Encoding_Method = WCEM_UTF8 then + UTF8 : declare + U : Unsigned_32; + W : Unsigned_32; + + procedure Get_UTF_Byte; + pragma Inline (Get_UTF_Byte); + -- Used to interpret 2#10xxxxxx# continuation byte in UTF-8 mode. + -- Reads a byte, and raises CE if the first two bits are not 10. + -- Otherwise shifts W 6 bits left and or's in the 6 xxxxxx bits. + + ------------------ + -- Get_UTF_Byte -- + ------------------ + + procedure Get_UTF_Byte is + begin + U := Unsigned_32 (Character'Pos (In_Char)); + + if (U and 2#11000000#) /= 2#10_000000# then + Bad; + end if; + + W := Shift_Left (W, 6) or (U and 2#00111111#); + end Get_UTF_Byte; + + -- Start of processing for UTF8 case + + begin + -- Note: for details of UTF8 encoding see RFC 3629 + + U := Unsigned_32 (Character'Pos (C)); + + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + if (U and 2#10000000#) = 2#00000000# then + Result := Wide_Wide_Character'Val (Character'Pos (C)); + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + elsif (U and 2#11100000#) = 2#110_00000# then + W := U and 2#00011111#; + Get_UTF_Byte; + + if W not in 16#00_0080# .. 16#00_07FF# then + Bad; + end if; + + Result := Wide_Wide_Character'Val (W); + + -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11110000#) = 2#1110_0000# then + W := U and 2#00001111#; + Get_UTF_Byte; + Get_UTF_Byte; + + if W not in 16#00_0800# .. 16#00_FFFF# then + Bad; + end if; + + Result := Wide_Wide_Character'Val (W); + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11111000#) = 2#11110_000# then + W := U and 2#00000111#; + + for K in 1 .. 3 loop + Get_UTF_Byte; + end loop; + + if W not in 16#01_0000# .. 16#10_FFFF# then + Bad; + end if; + + Result := Wide_Wide_Character'Val (W); + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + elsif (U and 2#11111100#) = 2#111110_00# then + W := U and 2#00000011#; + + for K in 1 .. 4 loop + Get_UTF_Byte; + end loop; + + if W not in 16#0020_0000# .. 16#03FF_FFFF# then + Bad; + end if; + + Result := Wide_Wide_Character'Val (W); + + -- All other cases are invalid, note that this includes: + + -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx 10xxxxxx + + -- since Wide_Wide_Character does not include code values + -- greater than 16#03FF_FFFF#. + + else + Bad; + end if; + end UTF8; + + -- All encoding functions other than UTF-8 + + else + Non_UTF8 : declare + function Char_Sequence_To_UTF is + new Char_Sequence_To_UTF_32 (In_Char); + + begin + -- For brackets, must test for specific case of [ not followed by + -- quotation, where we must not call Char_Sequence_To_UTF, but + -- instead just return the bracket unchanged. + + if Encoding_Method = WCEM_Brackets + and then C = '[' + and then (Ptr > Input'Last or else Input (Ptr) /= '"') + then + Result := '['; + + -- All other cases including [" with Brackets + + else + Result := + Wide_Wide_Character'Val + (Char_Sequence_To_UTF (C, Encoding_Method)); + end if; + end Non_UTF8; + end if; + end Decode_Wide_Wide_Character; + + ----------------------------- + -- Decode_Wide_Wide_String -- + ----------------------------- + + function Decode_Wide_Wide_String (S : String) return Wide_Wide_String is + Result : Wide_Wide_String (1 .. S'Length); + Length : Natural; + begin + Decode_Wide_Wide_String (S, Result, Length); + return Result (1 .. Length); + end Decode_Wide_Wide_String; + + procedure Decode_Wide_Wide_String + (S : String; + Result : out Wide_Wide_String; + Length : out Natural) + is + Ptr : Natural; + + begin + Ptr := S'First; + Length := 0; + while Ptr <= S'Last loop + if Length >= Result'Last then + Past_End; + end if; + + Length := Length + 1; + Decode_Wide_Wide_Character (S, Ptr, Result (Length)); + end loop; + end Decode_Wide_Wide_String; + + ------------------------- + -- Next_Wide_Character -- + ------------------------- + + procedure Next_Wide_Character (Input : String; Ptr : in out Natural) is + Discard : Wide_Character; + begin + Decode_Wide_Character (Input, Ptr, Discard); + end Next_Wide_Character; + + ------------------------------ + -- Next_Wide_Wide_Character -- + ------------------------------ + + procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural) is + Discard : Wide_Wide_Character; + begin + Decode_Wide_Wide_Character (Input, Ptr, Discard); + end Next_Wide_Wide_Character; + + -------------- + -- Past_End -- + -------------- + + procedure Past_End is + begin + raise Constraint_Error with "past end of string"; + end Past_End; + + ------------------------- + -- Prev_Wide_Character -- + ------------------------- + + procedure Prev_Wide_Character (Input : String; Ptr : in out Natural) is + begin + if Ptr > Input'Last + 1 then + Past_End; + end if; + + -- Special efficient encoding for UTF-8 case + + if Encoding_Method = WCEM_UTF8 then + UTF8 : declare + U : Unsigned_32; + + procedure Getc; + pragma Inline (Getc); + -- Gets the character at Input (Ptr - 1) and returns code in U as + -- Unsigned_32 value. On return Ptr is decremented by one. + + procedure Skip_UTF_Byte; + pragma Inline (Skip_UTF_Byte); + -- Checks that U is 2#10xxxxxx# and then calls Get + + ---------- + -- Getc -- + ---------- + + procedure Getc is + begin + if Ptr <= Input'First then + Past_End; + else + Ptr := Ptr - 1; + U := Unsigned_32 (Character'Pos (Input (Ptr))); + end if; + end Getc; + + ------------------- + -- Skip_UTF_Byte -- + ------------------- + + procedure Skip_UTF_Byte is + begin + if (U and 2#11000000#) = 2#10_000000# then + Getc; + else + Bad; + end if; + end Skip_UTF_Byte; + + -- Start of processing for UTF-8 case + + begin + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + Getc; + + if (U and 2#10000000#) = 2#00000000# then + return; + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + else + Skip_UTF_Byte; + + if (U and 2#11100000#) = 2#110_00000# then + return; + + -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx + + else + Skip_UTF_Byte; + + if (U and 2#11110000#) = 2#1110_0000# then + return; + + -- Any other code is invalid, note that this includes: + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx + -- 10xxxxxx + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx + -- 10xxxxxx 10xxxxxx + -- 10xxxxxx + + -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx + -- 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + -- since Wide_Character does not allow codes > 16#FFFF# + + else + Bad; + end if; + end if; + end if; + end UTF8; + + -- Special efficient encoding for brackets case + + elsif Encoding_Method = WCEM_Brackets then + Brackets : declare + P : Natural; + S : Natural; + + begin + -- See if we have "] at end positions + + if Ptr > Input'First + 1 + and then Input (Ptr - 1) = ']' + and then Input (Ptr - 2) = '"' + then + P := Ptr - 2; + + -- Loop back looking for [" at start + + while P >= Ptr - 10 loop + if P <= Input'First + 1 then + Bad; + + elsif Input (P - 1) = '"' + and then Input (P - 2) = '[' + then + -- Found ["..."], scan forward to check it + + S := P - 2; + P := S; + Next_Wide_Character (Input, P); + + -- OK if at original pointer, else error + + if P = Ptr then + Ptr := S; + return; + else + Bad; + end if; + end if; + + P := P - 1; + end loop; + + -- Falling through loop means more than 8 chars between the + -- enclosing brackets (or simply a missing left bracket) + + Bad; + + -- Here if no bracket sequence present + + else + if Ptr = Input'First then + Past_End; + else + Ptr := Ptr - 1; + end if; + end if; + end Brackets; + + -- Non-UTF-8/Brackets. These are the inefficient cases where we have to + -- go to the start of the string and skip forwards till Ptr matches. + + else + Non_UTF_Brackets : declare + Discard : Wide_Character; + PtrS : Natural; + PtrP : Natural; + + begin + PtrS := Input'First; + + if Ptr <= PtrS then + Past_End; + end if; + + loop + PtrP := PtrS; + Decode_Wide_Character (Input, PtrS, Discard); + + if PtrS = Ptr then + Ptr := PtrP; + return; + + elsif PtrS > Ptr then + Bad; + end if; + end loop; + + exception + when Constraint_Error => + Bad; + end Non_UTF_Brackets; + end if; + end Prev_Wide_Character; + + ------------------------------ + -- Prev_Wide_Wide_Character -- + ------------------------------ + + procedure Prev_Wide_Wide_Character (Input : String; Ptr : in out Natural) is + begin + if Ptr > Input'Last + 1 then + Past_End; + end if; + + -- Special efficient encoding for UTF-8 case + + if Encoding_Method = WCEM_UTF8 then + UTF8 : declare + U : Unsigned_32; + + procedure Getc; + pragma Inline (Getc); + -- Gets the character at Input (Ptr - 1) and returns code in U as + -- Unsigned_32 value. On return Ptr is decremented by one. + + procedure Skip_UTF_Byte; + pragma Inline (Skip_UTF_Byte); + -- Checks that U is 2#10xxxxxx# and then calls Get + + ---------- + -- Getc -- + ---------- + + procedure Getc is + begin + if Ptr <= Input'First then + Past_End; + else + Ptr := Ptr - 1; + U := Unsigned_32 (Character'Pos (Input (Ptr))); + end if; + end Getc; + + ------------------- + -- Skip_UTF_Byte -- + ------------------- + + procedure Skip_UTF_Byte is + begin + if (U and 2#11000000#) = 2#10_000000# then + Getc; + else + Bad; + end if; + end Skip_UTF_Byte; + + -- Start of processing for UTF-8 case + + begin + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + Getc; + + if (U and 2#10000000#) = 2#00000000# then + return; + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + else + Skip_UTF_Byte; + + if (U and 2#11100000#) = 2#110_00000# then + return; + + -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx + + else + Skip_UTF_Byte; + + if (U and 2#11110000#) = 2#1110_0000# then + return; + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx + -- 10xxxxxx + + else + Skip_UTF_Byte; + + if (U and 2#11111000#) = 2#11110_000# then + return; + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx + -- 10xxxxxx 10xxxxxx + -- 10xxxxxx + + else + Skip_UTF_Byte; + + if (U and 2#11111100#) = 2#111110_00# then + return; + + -- Any other code is invalid, note that this includes: + + -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx + -- 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + -- since Wide_Wide_Character does not allow codes + -- greater than 16#03FF_FFFF# + + else + Bad; + end if; + end if; + end if; + end if; + end if; + end UTF8; + + -- Special efficient encoding for brackets case + + elsif Encoding_Method = WCEM_Brackets then + Brackets : declare + P : Natural; + S : Natural; + + begin + -- See if we have "] at end positions + + if Ptr > Input'First + 1 + and then Input (Ptr - 1) = ']' + and then Input (Ptr - 2) = '"' + then + P := Ptr - 2; + + -- Loop back looking for [" at start + + while P >= Ptr - 10 loop + if P <= Input'First + 1 then + Bad; + + elsif Input (P - 1) = '"' + and then Input (P - 2) = '[' + then + -- Found ["..."], scan forward to check it + + S := P - 2; + P := S; + Next_Wide_Wide_Character (Input, P); + + -- OK if at original pointer, else error + + if P = Ptr then + Ptr := S; + return; + else + Bad; + end if; + end if; + + P := P - 1; + end loop; + + -- Falling through loop means more than 8 chars between the + -- enclosing brackets (or simply a missing left bracket) + + Bad; + + -- Here if no bracket sequence present + + else + if Ptr = Input'First then + Past_End; + else + Ptr := Ptr - 1; + end if; + end if; + end Brackets; + + -- Non-UTF-8/Brackets. These are the inefficient cases where we have to + -- go to the start of the string and skip forwards till Ptr matches. + + else + Non_UTF8_Brackets : declare + Discard : Wide_Wide_Character; + PtrS : Natural; + PtrP : Natural; + + begin + PtrS := Input'First; + + if Ptr <= PtrS then + Past_End; + end if; + + loop + PtrP := PtrS; + Decode_Wide_Wide_Character (Input, PtrS, Discard); + + if PtrS = Ptr then + Ptr := PtrP; + return; + + elsif PtrS > Ptr then + Bad; + end if; + end loop; + + exception + when Constraint_Error => + Bad; + end Non_UTF8_Brackets; + end if; + end Prev_Wide_Wide_Character; + + -------------------------- + -- Validate_Wide_String -- + -------------------------- + + function Validate_Wide_String (S : String) return Boolean is + Ptr : Natural; + + begin + Ptr := S'First; + while Ptr <= S'Last loop + Next_Wide_Character (S, Ptr); + end loop; + + return True; + + exception + when Constraint_Error => + return False; + end Validate_Wide_String; + + ------------------------------- + -- Validate_Wide_Wide_String -- + ------------------------------- + + function Validate_Wide_Wide_String (S : String) return Boolean is + Ptr : Natural; + + begin + Ptr := S'First; + while Ptr <= S'Last loop + Next_Wide_Wide_Character (S, Ptr); + end loop; + + return True; + + exception + when Constraint_Error => + return False; + end Validate_Wide_Wide_String; + +end GNAT.Decode_String; diff --git a/gcc/ada/libgnat/g-decstr.ads b/gcc/ada/libgnat/g-decstr.ads new file mode 100644 index 0000000..1572939 --- /dev/null +++ b/gcc/ada/libgnat/g-decstr.ads @@ -0,0 +1,176 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D E C O D E _ S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This generic package provides utility routines for converting from an +-- encoded string to a corresponding Wide_String or Wide_Wide_String value +-- using a specified encoding convention, which is supplied as the generic +-- parameter. UTF-8 is handled especially efficiently, and if the encoding +-- method is known at compile time to be WCEM_UTF8, then the instantiation +-- is specialized to handle only the UTF-8 case and exclude code for the +-- other encoding methods. The package also provides positioning routines +-- for skipping encoded characters in either direction, and for validating +-- strings for correct encodings. + +-- Note: this package is only about decoding sequences of 8-bit characters +-- into corresponding 16-bit Wide_String or 32-bit Wide_Wide_String values. +-- It knows nothing at all about the character encodings being used for the +-- resulting Wide_Character and Wide_Wide_Character values. Most often this +-- will be Unicode/ISO-10646 as specified by the Ada RM, but this package +-- does not make any assumptions about the character coding. See also the +-- packages Ada.Wide_[Wide_]Characters.Unicode for unicode specific functions. + +-- In particular, in the case of UTF-8, all valid UTF-8 encodings, as listed +-- in table 3.6 of the Unicode Standard, version 6.2.0, are recognized as +-- legitimate. This includes the full range 16#0000_0000# .. 16#03FF_FFFF#. +-- This includes codes in the range 16#D800# - 16#DFFF#. These codes all +-- have UTF-8 encoding sequences that are well-defined (e.g. the encoding for +-- 16#D800# is ED A0 80). But these codes do not correspond to defined Unicode +-- characters and are thus considered to be "not well-formed" (see table 3.7 +-- of the Unicode Standard). If you need to exclude these codes, you must do +-- that manually, e.g. use Decode_Wide_Character/Decode_Wide_String and check +-- that the resulting code(s) are not in this range. + +-- Note on the use of brackets encoding (WCEM_Brackets). The brackets encoding +-- method is ambiguous in the context of this package, since there is no way +-- to tell if ["1234"] is eight unencoded characters or one encoded character. +-- In the context of Ada sources, any sequence starting [" must be the start +-- of an encoding (since that sequence is not valid in Ada source otherwise). +-- The routines in this package use the same approach. If the input string +-- contains the sequence [" then this is assumed to be the start of a brackets +-- encoding sequence, and if it does not match the syntax, an error is raised. +-- In the case of the Prev functions, a sequence ending with "] is assumed to +-- be a valid brackets sequence, and an error is raised if it is not. + +with System.WCh_Con; + +generic + Encoding_Method : System.WCh_Con.WC_Encoding_Method; + +package GNAT.Decode_String is + pragma Pure; + + function Decode_Wide_String (S : String) return Wide_String; + pragma Inline (Decode_Wide_String); + -- Decode the given String, which is encoded using the indicated coding + -- method, returning the corresponding decoded Wide_String value. If S + -- contains a character code that cannot be represented with the given + -- encoding, then Constraint_Error is raised. + + procedure Decode_Wide_String + (S : String; + Result : out Wide_String; + Length : out Natural); + -- Similar to the above function except that the result is stored in the + -- given Wide_String variable Result, starting at Result (Result'First). On + -- return, Length is set to the number of characters stored in Result. The + -- caller must ensure that Result is long enough (an easy choice is to set + -- the length equal to the S'Length, since decoding can never increase the + -- string length). If the length of Result is insufficient Constraint_Error + -- will be raised. + + function Decode_Wide_Wide_String (S : String) return Wide_Wide_String; + -- Same as above function but for Wide_Wide_String output + + procedure Decode_Wide_Wide_String + (S : String; + Result : out Wide_Wide_String; + Length : out Natural); + -- Same as above procedure, but for Wide_Wide_String output + + function Validate_Wide_String (S : String) return Boolean; + -- This function inspects the string S to determine if it contains only + -- valid encodings corresponding to Wide_Character values using the + -- given encoding. If a call to Decode_Wide_String (S) would return + -- without raising Constraint_Error, then Validate_Wide_String will + -- return True. If the call would have raised Constraint_Error, then + -- Validate_Wide_String will return False. + + function Validate_Wide_Wide_String (S : String) return Boolean; + -- Similar to Validate_Wide_String, except that it succeeds if the string + -- contains only encodings corresponding to Wide_Wide_Character values. + + procedure Decode_Wide_Character + (Input : String; + Ptr : in out Natural; + Result : out Wide_Character); + pragma Inline (Decode_Wide_Character); + -- This is a lower level procedure that decodes a single character using + -- the given encoding method. The encoded character is stored in Input, + -- starting at Input (Ptr). The resulting output character is stored in + -- Result, and on return Ptr is updated past the input character or + -- encoding sequence. Constraint_Error will be raised if the input has + -- has a character that cannot be represented using the given encoding, + -- or if Ptr is outside the bounds of the Input string. + + procedure Decode_Wide_Wide_Character + (Input : String; + Ptr : in out Natural; + Result : out Wide_Wide_Character); + pragma Inline (Decode_Wide_Wide_Character); + -- Same as above procedure but with Wide_Wide_Character input + + procedure Next_Wide_Character (Input : String; Ptr : in out Natural); + pragma Inline (Next_Wide_Character); + -- This procedure examines the input string starting at Input (Ptr), and + -- advances Ptr past one character in the encoded string, so that on return + -- Ptr points to the next encoded character. Constraint_Error is raised if + -- an invalid encoding is encountered, or the end of the string is reached + -- or if Ptr is less than String'First on entry, or if the character + -- skipped is not a valid Wide_Character code. + + procedure Prev_Wide_Character (Input : String; Ptr : in out Natural); + -- This procedure is similar to Next_Encoded_Character except that it moves + -- backwards in the string, so that on return, Ptr is set to point to the + -- previous encoded character. Constraint_Error is raised if the start of + -- the string is encountered. It is valid for Ptr to be one past the end + -- of the string for this call (in which case on return it will point to + -- the last encoded character). + -- + -- Note: it is not generally possible to do this function efficiently with + -- all encodings, the current implementation is only efficient for the case + -- of UTF-8 (Encoding_Method = WCEM_UTF8) and Brackets (Encoding_Method = + -- WCEM_Brackets). For all other encodings, we work by starting at the + -- beginning of the string and moving forward till Ptr is reached, which + -- is correct but slow. + -- + -- Note: this routine assumes that the sequence prior to Ptr is correctly + -- encoded, it does not have a defined behavior if this is not the case. + + procedure Next_Wide_Wide_Character (Input : String; Ptr : in out Natural); + pragma Inline (Next_Wide_Wide_Character); + -- Similar to Next_Wide_Character except that codes skipped must be valid + -- Wide_Wide_Character codes. + + procedure Prev_Wide_Wide_Character (Input : String; Ptr : in out Natural); + -- Similar to Prev_Wide_Character except that codes skipped must be valid + -- Wide_Wide_Character codes. + +end GNAT.Decode_String; diff --git a/gcc/ada/libgnat/g-deutst.ads b/gcc/ada/libgnat/g-deutst.ads new file mode 100644 index 0000000..54306b8 --- /dev/null +++ b/gcc/ada/libgnat/g-deutst.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D E C O D E _ U T F 8 _ S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 pre-instantiation of GNAT.Decode_String for the +-- common case of UTF-8 encoding. As noted in the documentation of that +-- package, this UTF-8 instantiation is efficient and specialized so that +-- it has only the code for the UTF-8 case. See g-decstr.ads for full +-- documentation on this package. + +with GNAT.Decode_String; + +with System.WCh_Con; + +package GNAT.Decode_UTF8_String is + new GNAT.Decode_String (System.WCh_Con.WCEM_UTF8); diff --git a/gcc/ada/libgnat/g-diopit.adb b/gcc/ada/libgnat/g-diopit.adb new file mode 100644 index 0000000..bc40d5d --- /dev/null +++ b/gcc/ada/libgnat/g-diopit.adb @@ -0,0 +1,396 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D I R E C T O R Y _ O P E R A T I O N S . I T E R A T I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; +with Ada.Strings.Fixed; +with Ada.Strings.Maps; +with GNAT.OS_Lib; +with GNAT.Regexp; + +package body GNAT.Directory_Operations.Iteration is + + use Ada; + + ---------- + -- Find -- + ---------- + + procedure Find + (Root_Directory : Dir_Name_Str; + File_Pattern : String) + is + File_Regexp : constant Regexp.Regexp := Regexp.Compile (File_Pattern); + Index : Natural := 0; + Quit : Boolean; + + procedure Read_Directory (Directory : Dir_Name_Str); + -- Open Directory and read all entries. This routine is called + -- recursively for each sub-directories. + + function Make_Pathname (Dir, File : String) return String; + -- Returns the pathname for File by adding Dir as prefix + + ------------------- + -- Make_Pathname -- + ------------------- + + function Make_Pathname (Dir, File : String) return String is + begin + if Dir (Dir'Last) = '/' or else Dir (Dir'Last) = '\' then + return Dir & File; + else + return Dir & Dir_Separator & File; + end if; + end Make_Pathname; + + -------------------- + -- Read_Directory -- + -------------------- + + procedure Read_Directory (Directory : Dir_Name_Str) is + Buffer : String (1 .. 2_048); + Last : Natural; + + Dir : Dir_Type; + pragma Warnings (Off, Dir); + + begin + Open (Dir, Directory); + + loop + Read (Dir, Buffer, Last); + exit when Last = 0; + + declare + Dir_Entry : constant String := Buffer (1 .. Last); + Pathname : constant String := + Make_Pathname (Directory, Dir_Entry); + + begin + if Regexp.Match (Dir_Entry, File_Regexp) then + Index := Index + 1; + + begin + Action (Pathname, Index, Quit); + exception + when others => + Close (Dir); + raise; + end; + + exit when Quit; + end if; + + -- Recursively call for sub-directories, except for . and .. + + if not (Dir_Entry = "." or else Dir_Entry = "..") + and then OS_Lib.Is_Directory (Pathname) + then + Read_Directory (Pathname); + exit when Quit; + end if; + end; + end loop; + + Close (Dir); + end Read_Directory; + + begin + Quit := False; + Read_Directory (Root_Directory); + end Find; + + ----------------------- + -- Wildcard_Iterator -- + ----------------------- + + procedure Wildcard_Iterator (Path : Path_Name) is + + Index : Natural := 0; + + procedure Read + (Directory : String; + File_Pattern : String; + Suffix_Pattern : String); + -- Read entries in Directory and call user's callback if the entry match + -- File_Pattern and Suffix_Pattern is empty; otherwise go down one more + -- directory level by calling Next_Level routine below. + + procedure Next_Level + (Current_Path : String; + Suffix_Path : String); + -- Extract next File_Pattern from Suffix_Path and call Read routine + -- above. + + ---------------- + -- Next_Level -- + ---------------- + + procedure Next_Level + (Current_Path : String; + Suffix_Path : String) + is + DS : Natural; + SP : String renames Suffix_Path; + + begin + if SP'Length > 2 + and then SP (SP'First) = '.' + and then Strings.Maps.Is_In (SP (SP'First + 1), Dir_Seps) + then + -- Starting with "./" + + DS := Strings.Fixed.Index + (SP (SP'First + 2 .. SP'Last), + Dir_Seps); + + if DS = 0 then + + -- We have "./" + + Read (Current_Path & ".", "*", ""); + + else + -- We have "./dir" + + Read (Current_Path & ".", + SP (SP'First + 2 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + elsif SP'Length > 3 + and then SP (SP'First .. SP'First + 1) = ".." + and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps) + then + -- Starting with "../" + + DS := Strings.Fixed.Index + (SP (SP'First + 3 .. SP'Last), Dir_Seps); + + if DS = 0 then + + -- We have "../" + + Read (Current_Path & "..", "*", ""); + + else + -- We have "../dir" + + Read (Current_Path & "..", + SP (SP'First + 3 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + elsif Current_Path = "" + and then SP'Length > 1 + and then Characters.Handling.Is_Letter (SP (SP'First)) + and then SP (SP'First + 1) = ':' + then + -- Starting with ":" + + if SP'Length > 2 + and then Strings.Maps.Is_In (SP (SP'First + 2), Dir_Seps) + then + -- Starting with ":\" + + DS := Strings.Fixed.Index + (SP (SP'First + 3 .. SP'Last), Dir_Seps); + + if DS = 0 then + + -- We have ":\dir" + + Read (SP (SP'First .. SP'First + 2), + SP (SP'First + 3 .. SP'Last), + ""); + + else + -- We have ":\dir\kkk" + + Read (SP (SP'First .. SP'First + 2), + SP (SP'First + 3 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + else + -- Starting with ":" and the drive letter not followed + -- by a directory separator. The proper semantic on Windows is + -- to read the content of the current selected directory on + -- this drive. For example, if drive C current selected + -- directory is c:\temp the suffix pattern "c:m*" is + -- equivalent to c:\temp\m*. + + DS := Strings.Fixed.Index + (SP (SP'First + 2 .. SP'Last), Dir_Seps); + + if DS = 0 then + + -- We have ":dir" + + Read (SP, "", ""); + + else + -- We have ":dir/kkk" + + Read (SP (SP'First .. DS - 1), "", SP (DS .. SP'Last)); + end if; + end if; + + elsif Strings.Maps.Is_In (SP (SP'First), Dir_Seps) then + + -- Starting with a / + + DS := Strings.Fixed.Index + (SP (SP'First + 1 .. SP'Last), Dir_Seps); + + if DS = 0 then + + -- We have "/dir" + + Read (Current_Path, SP (SP'First + 1 .. SP'Last), ""); + else + -- We have "/dir/kkk" + + Read (Current_Path, + SP (SP'First + 1 .. DS - 1), + SP (DS .. SP'Last)); + end if; + + else + -- Starting with a name + + DS := Strings.Fixed.Index (SP, Dir_Seps); + + if DS = 0 then + + -- We have "dir" + + Read (Current_Path & '.', SP, ""); + else + -- We have "dir/kkk" + + Read (Current_Path & '.', + SP (SP'First .. DS - 1), + SP (DS .. SP'Last)); + end if; + + end if; + end Next_Level; + + ---------- + -- Read -- + ---------- + + Quit : Boolean := False; + -- Global state to be able to exit all recursive calls + + procedure Read + (Directory : String; + File_Pattern : String; + Suffix_Pattern : String) + is + File_Regexp : constant Regexp.Regexp := + Regexp.Compile (File_Pattern, Glob => True); + + Dir : Dir_Type; + pragma Warnings (Off, Dir); + + Buffer : String (1 .. 2_048); + Last : Natural; + + begin + if OS_Lib.Is_Directory (Directory & Dir_Separator) then + Open (Dir, Directory & Dir_Separator); + + Dir_Iterator : loop + Read (Dir, Buffer, Last); + exit Dir_Iterator when Last = 0; + + declare + Dir_Entry : constant String := Buffer (1 .. Last); + Pathname : constant String := + Directory & Dir_Separator & Dir_Entry; + begin + -- Handle "." and ".." only if explicit use in the + -- File_Pattern. + + if not + ((Dir_Entry = "." and then File_Pattern /= ".") + or else + (Dir_Entry = ".." and then File_Pattern /= "..")) + then + if Regexp.Match (Dir_Entry, File_Regexp) then + if Suffix_Pattern = "" then + + -- No more matching needed, call user's callback + + Index := Index + 1; + + begin + Action (Pathname, Index, Quit); + exception + when others => + Close (Dir); + raise; + end; + + else + -- Down one level + + Next_Level + (Directory & Dir_Separator & Dir_Entry, + Suffix_Pattern); + end if; + end if; + end if; + end; + + -- Exit if Quit set by call to Action, either at this level + -- or at some lower recursive call to Next_Level. + + exit Dir_Iterator when Quit; + end loop Dir_Iterator; + + Close (Dir); + end if; + end Read; + + -- Start of processing for Wildcard_Iterator + + begin + if Path = "" then + return; + end if; + + Next_Level ("", Path); + end Wildcard_Iterator; + +end GNAT.Directory_Operations.Iteration; diff --git a/gcc/ada/libgnat/g-diopit.ads b/gcc/ada/libgnat/g-diopit.ads new file mode 100644 index 0000000..9b65c19 --- /dev/null +++ b/gcc/ada/libgnat/g-diopit.ads @@ -0,0 +1,92 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D I R E C T O R Y _ O P E R A T I O N S . I T E R A T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Iterators among files + +package GNAT.Directory_Operations.Iteration is + + generic + with procedure Action + (Item : String; + Index : Positive; + Quit : in out Boolean); + procedure Find + (Root_Directory : Dir_Name_Str; + File_Pattern : String); + -- Recursively searches the directory structure rooted at Root_Directory. + -- This provides functionality similar to the UNIX 'find' command. + -- Action will be called for every item matching the regular expression + -- File_Pattern (see GNAT.Regexp). Item is the full pathname to the file + -- starting with Root_Directory that has been matched. Index is set to one + -- for the first call and is incremented by one at each call. The iterator + -- will pass in the value False on each call to Action. The iterator will + -- terminate after passing the last matched path to Action or after + -- returning from a call to Action which sets Quit to True. + -- Raises GNAT.Regexp.Error_In_Regexp if File_Pattern is ill formed. + + generic + with procedure Action + (Item : String; + Index : Positive; + Quit : in out Boolean); + procedure Wildcard_Iterator (Path : Path_Name); + -- Calls Action for each path matching Path. Path can include wildcards '*' + -- and '?' and [...]. The rules are: + -- + -- * can be replaced by any sequence of characters + -- ? can be replaced by a single character + -- [a-z] match one character in the range 'a' through 'z' + -- [abc] match either character 'a', 'b' or 'c' + -- + -- Item is the filename that has been matched. Index is set to one for the + -- first call and is incremented by one at each call. The iterator's + -- termination can be controlled by setting Quit to True. It is by default + -- set to False. + -- + -- For example, if we have the following directory structure: + -- /boo/ + -- foo.ads + -- /sed/ + -- foo.ads + -- file/ + -- foo.ads + -- /sid/ + -- foo.ads + -- file/ + -- foo.ads + -- /life/ + -- + -- A call with expression "/s*/file/*" will call Action for the following + -- items: + -- /sed/file/foo.ads + -- /sid/file/foo.ads + +end GNAT.Directory_Operations.Iteration; diff --git a/gcc/ada/libgnat/g-dirope.adb b/gcc/ada/libgnat/g-dirope.adb new file mode 100644 index 0000000..bc342029 --- /dev/null +++ b/gcc/ada/libgnat/g-dirope.adb @@ -0,0 +1,775 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with Ada.Characters.Handling; +with Ada.Strings.Fixed; + +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; + +with System; use System; +with System.CRTL; use System.CRTL; + +with GNAT.OS_Lib; + +package body GNAT.Directory_Operations is + + use Ada; + + Filename_Max : constant Integer := 1024; + -- 1024 is the value of FILENAME_MAX in stdio.h + + procedure Free is new + Ada.Unchecked_Deallocation (Dir_Type_Value, Dir_Type); + + On_Windows : constant Boolean := GNAT.OS_Lib.Directory_Separator = '\'; + -- An indication that we are on Windows. Used in Get_Current_Dir, to + -- deal with drive letters in the beginning of absolute paths. + + --------------- + -- Base_Name -- + --------------- + + function Base_Name + (Path : Path_Name; + Suffix : String := "") return String + is + function Get_File_Names_Case_Sensitive return Integer; + pragma Import + (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + Case_Sensitive_File_Name : constant Boolean := + Get_File_Names_Case_Sensitive = 1; + + function Basename + (Path : Path_Name; + Suffix : String := "") return String; + -- This function does the job. The only difference between Basename + -- and Base_Name (the parent function) is that the former is case + -- sensitive, while the latter is not. Path and Suffix are adjusted + -- appropriately before calling Basename under platforms where the + -- file system is not case sensitive. + + -------------- + -- Basename -- + -------------- + + function Basename + (Path : Path_Name; + Suffix : String := "") return String + is + Cut_Start : Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + Cut_End : Natural; + + begin + -- Cut_Start point to the first basename character + + Cut_Start := (if Cut_Start = 0 then Path'First else Cut_Start + 1); + + -- Cut_End point to the last basename character + + Cut_End := Path'Last; + + -- If basename ends with Suffix, adjust Cut_End + + if Suffix /= "" + and then Path (Path'Last - Suffix'Length + 1 .. Cut_End) = Suffix + then + Cut_End := Path'Last - Suffix'Length; + end if; + + Check_For_Standard_Dirs : declare + Offset : constant Integer := Path'First - Base_Name.Path'First; + BN : constant String := + Base_Name.Path (Cut_Start - Offset .. Cut_End - Offset); + -- Here we use Base_Name.Path to keep the original casing + + Has_Drive_Letter : constant Boolean := + OS_Lib.Path_Separator /= ':'; + -- If Path separator is not ':' then we are on a DOS based OS + -- where this character is used as a drive letter separator. + + begin + if BN = "." or else BN = ".." then + return ""; + + elsif Has_Drive_Letter + and then BN'Length > 2 + and then Characters.Handling.Is_Letter (BN (BN'First)) + and then BN (BN'First + 1) = ':' + then + -- We have a DOS drive letter prefix, remove it + + return BN (BN'First + 2 .. BN'Last); + + else + return BN; + end if; + end Check_For_Standard_Dirs; + end Basename; + + -- Start of processing for Base_Name + + begin + if Path'Length <= Suffix'Length then + return Path; + end if; + + if Case_Sensitive_File_Name then + return Basename (Path, Suffix); + else + return Basename + (Characters.Handling.To_Lower (Path), + Characters.Handling.To_Lower (Suffix)); + end if; + end Base_Name; + + ---------------- + -- Change_Dir -- + ---------------- + + procedure Change_Dir (Dir_Name : Dir_Name_Str) is + C_Dir_Name : constant String := Dir_Name & ASCII.NUL; + begin + if chdir (C_Dir_Name) /= 0 then + raise Directory_Error; + end if; + end Change_Dir; + + ----------- + -- Close -- + ----------- + + procedure Close (Dir : in out Dir_Type) is + Discard : Integer; + pragma Warnings (Off, Discard); + + function closedir (directory : DIRs) return Integer; + pragma Import (C, closedir, "__gnat_closedir"); + + begin + if not Is_Open (Dir) then + raise Directory_Error; + end if; + + Discard := closedir (DIRs (Dir.all)); + Free (Dir); + end Close; + + -------------- + -- Dir_Name -- + -------------- + + function Dir_Name (Path : Path_Name) return Dir_Name_Str is + Last_DS : constant Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + + begin + if Last_DS = 0 then + + -- There is no directory separator, returns current working directory + + return "." & Dir_Separator; + + else + return Path (Path'First .. Last_DS); + end if; + end Dir_Name; + + ----------------- + -- Expand_Path -- + ----------------- + + function Expand_Path + (Path : Path_Name; + Mode : Environment_Style := System_Default) return Path_Name + is + Environment_Variable_Char : Character; + pragma Import (C, Environment_Variable_Char, "__gnat_environment_char"); + + Result : OS_Lib.String_Access := new String (1 .. 200); + Result_Last : Natural := 0; + + procedure Append (C : Character); + procedure Append (S : String); + -- Append to Result + + procedure Double_Result_Size; + -- Reallocate Result, doubling its size + + function Is_Var_Prefix (C : Character) return Boolean; + pragma Inline (Is_Var_Prefix); + + procedure Read (K : in out Positive); + -- Update Result while reading current Path starting at position K. If + -- a variable is found, call Var below. + + procedure Var (K : in out Positive); + -- Translate variable name starting at position K with the associated + -- environment value. + + ------------ + -- Append -- + ------------ + + procedure Append (C : Character) is + begin + if Result_Last = Result'Last then + Double_Result_Size; + end if; + + Result_Last := Result_Last + 1; + Result (Result_Last) := C; + end Append; + + procedure Append (S : String) is + begin + while Result_Last + S'Length - 1 > Result'Last loop + Double_Result_Size; + end loop; + + Result (Result_Last + 1 .. Result_Last + S'Length) := S; + Result_Last := Result_Last + S'Length; + end Append; + + ------------------------ + -- Double_Result_Size -- + ------------------------ + + procedure Double_Result_Size is + New_Result : constant OS_Lib.String_Access := + new String (1 .. 2 * Result'Last); + begin + New_Result (1 .. Result_Last) := Result (1 .. Result_Last); + OS_Lib.Free (Result); + Result := New_Result; + end Double_Result_Size; + + ------------------- + -- Is_Var_Prefix -- + ------------------- + + function Is_Var_Prefix (C : Character) return Boolean is + begin + return (C = Environment_Variable_Char and then Mode = System_Default) + or else + (C = '$' and then (Mode = UNIX or else Mode = Both)) + or else + (C = '%' and then (Mode = DOS or else Mode = Both)); + end Is_Var_Prefix; + + ---------- + -- Read -- + ---------- + + procedure Read (K : in out Positive) is + P : Character; + + begin + For_All_Characters : loop + if Is_Var_Prefix (Path (K)) then + P := Path (K); + + -- Could be a variable + + if K < Path'Last then + if Path (K + 1) = P then + + -- Not a variable after all, this is a double $ or %, + -- just insert one in the result string. + + Append (P); + K := K + 1; + + else + -- Let's parse the variable + + Var (K); + end if; + + else + -- We have an ending $ or % sign + + Append (P); + end if; + + else + -- This is a standard character, just add it to the result + + Append (Path (K)); + end if; + + -- Skip to next character + + K := K + 1; + + exit For_All_Characters when K > Path'Last; + end loop For_All_Characters; + end Read; + + --------- + -- Var -- + --------- + + procedure Var (K : in out Positive) is + P : constant Character := Path (K); + T : Character; + E : Positive; + + begin + K := K + 1; + + if P = '%' or else Path (K) = '{' then + + -- Set terminator character + + if P = '%' then + T := '%'; + else + T := '}'; + K := K + 1; + end if; + + -- Look for terminator character, k point to the first character + -- for the variable name. + + E := K; + + loop + E := E + 1; + exit when Path (E) = T or else E = Path'Last; + end loop; + + if Path (E) = T then + + -- OK found, translate with environment value + + declare + Env : OS_Lib.String_Access := + OS_Lib.Getenv (Path (K .. E - 1)); + + begin + Append (Env.all); + OS_Lib.Free (Env); + end; + + else + -- No terminator character, not a variable after all or a + -- syntax error, ignore it, insert string as-is. + + Append (P); -- Add prefix character + + if T = '}' then -- If we were looking for curly bracket + Append ('{'); -- terminator, add the curly bracket + end if; + + Append (Path (K .. E)); + end if; + + else + -- The variable name is everything from current position to first + -- non letter/digit character. + + E := K; + + -- Check that first character is a letter + + if Characters.Handling.Is_Letter (Path (E)) then + E := E + 1; + + Var_Name : loop + exit Var_Name when E > Path'Last; + + if Characters.Handling.Is_Letter (Path (E)) + or else Characters.Handling.Is_Digit (Path (E)) + then + E := E + 1; + else + exit Var_Name; + end if; + end loop Var_Name; + + E := E - 1; + + declare + Env : OS_Lib.String_Access := OS_Lib.Getenv (Path (K .. E)); + + begin + Append (Env.all); + OS_Lib.Free (Env); + end; + + else + -- This is not a variable after all + + Append ('$'); + Append (Path (E)); + end if; + + end if; + + K := E; + end Var; + + -- Start of processing for Expand_Path + + begin + declare + K : Positive := Path'First; + + begin + Read (K); + + declare + Returned_Value : constant String := Result (1 .. Result_Last); + + begin + OS_Lib.Free (Result); + return Returned_Value; + end; + end; + end Expand_Path; + + -------------------- + -- File_Extension -- + -------------------- + + function File_Extension (Path : Path_Name) return String is + First : Natural := + Strings.Fixed.Index + (Path, Dir_Seps, Going => Strings.Backward); + + Dot : Natural; + + begin + if First = 0 then + First := Path'First; + end if; + + Dot := Strings.Fixed.Index (Path (First .. Path'Last), + ".", + Going => Strings.Backward); + + if Dot = 0 or else Dot = Path'Last then + return ""; + else + return Path (Dot .. Path'Last); + end if; + end File_Extension; + + --------------- + -- File_Name -- + --------------- + + function File_Name (Path : Path_Name) return String is + begin + return Base_Name (Path); + end File_Name; + + --------------------- + -- Format_Pathname -- + --------------------- + + function Format_Pathname + (Path : Path_Name; + Style : Path_Style := System_Default) return String + is + N_Path : String := Path; + K : Positive := N_Path'First; + Prev_Dirsep : Boolean := False; + + begin + if Dir_Separator = '\' + and then Path'Length > 1 + and then Path (K .. K + 1) = "\\" + then + if Style = UNIX then + N_Path (K .. K + 1) := "//"; + end if; + + K := K + 2; + end if; + + for J in K .. Path'Last loop + if Strings.Maps.Is_In (Path (J), Dir_Seps) then + if not Prev_Dirsep then + case Style is + when UNIX => N_Path (K) := '/'; + when DOS => N_Path (K) := '\'; + when System_Default => N_Path (K) := Dir_Separator; + end case; + + K := K + 1; + end if; + + Prev_Dirsep := True; + + else + N_Path (K) := Path (J); + K := K + 1; + Prev_Dirsep := False; + end if; + end loop; + + return N_Path (N_Path'First .. K - 1); + end Format_Pathname; + + --------------------- + -- Get_Current_Dir -- + --------------------- + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + + function Get_Current_Dir return Dir_Name_Str is + Current_Dir : String (1 .. Max_Path + 1); + Last : Natural; + begin + Get_Current_Dir (Current_Dir, Last); + return Current_Dir (1 .. Last); + end Get_Current_Dir; + + procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural) is + Path_Len : Natural := Max_Path; + Buffer : String (Dir'First .. Dir'First + Max_Path + 1); + + procedure Local_Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Local_Get_Current_Dir, "__gnat_get_current_dir"); + + begin + Local_Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Path_Len = 0 then + raise Ada.IO_Exceptions.Use_Error + with "current directory does not exist"; + end if; + + Last := + (if Dir'Length > Path_Len then Dir'First + Path_Len - 1 else Dir'Last); + + Dir (Buffer'First .. Last) := Buffer (Buffer'First .. Last); + + -- By default, the drive letter on Windows is in upper case + + if On_Windows and then Last > Dir'First and then + Dir (Dir'First + 1) = ':' + then + Dir (Dir'First) := + Ada.Characters.Handling.To_Upper (Dir (Dir'First)); + end if; + end Get_Current_Dir; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (Dir : Dir_Type) return Boolean is + begin + return Dir /= Null_Dir + and then System.Address (Dir.all) /= System.Null_Address; + end Is_Open; + + -------------- + -- Make_Dir -- + -------------- + + procedure Make_Dir (Dir_Name : Dir_Name_Str) is + C_Dir_Name : constant String := Dir_Name & ASCII.NUL; + begin + if CRTL.mkdir (C_Dir_Name, Unspecified) /= 0 then + raise Directory_Error; + end if; + end Make_Dir; + + ---------- + -- Open -- + ---------- + + procedure Open + (Dir : out Dir_Type; + Dir_Name : Dir_Name_Str) + is + function opendir (file_name : String) return DIRs; + pragma Import (C, opendir, "__gnat_opendir"); + + C_File_Name : constant String := Dir_Name & ASCII.NUL; + + begin + Dir := new Dir_Type_Value'(Dir_Type_Value (opendir (C_File_Name))); + + if not Is_Open (Dir) then + Free (Dir); + Dir := Null_Dir; + raise Directory_Error; + end if; + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (Dir : Dir_Type; + Str : out String; + Last : out Natural) + is + Filename_Addr : Address; + Filename_Len : aliased Integer; + + Buffer : array (0 .. Filename_Max + 12) of Character; + -- 12 is the size of the dirent structure (see dirent.h), without the + -- field for the filename. + + function readdir_gnat + (Directory : System.Address; + Buffer : System.Address; + Last : not null access Integer) return System.Address; + pragma Import (C, readdir_gnat, "__gnat_readdir"); + + begin + if not Is_Open (Dir) then + raise Directory_Error; + end if; + + Filename_Addr := + readdir_gnat + (System.Address (Dir.all), Buffer'Address, Filename_Len'Access); + + if Filename_Addr = System.Null_Address then + Last := 0; + return; + end if; + + Last := + (if Str'Length > Filename_Len then Str'First + Filename_Len - 1 + else Str'Last); + + declare + subtype Path_String is String (1 .. Filename_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new + Ada.Unchecked_Conversion + (Source => Address, + Target => Path_String_Access); + + Path_Access : constant Path_String_Access := + Address_To_Access (Filename_Addr); + + begin + for J in Str'First .. Last loop + Str (J) := Path_Access (J - Str'First + 1); + end loop; + end; + end Read; + + ------------------------- + -- Read_Is_Thread_Safe -- + ------------------------- + + function Read_Is_Thread_Safe return Boolean is + function readdir_is_thread_safe return Integer; + pragma Import + (C, readdir_is_thread_safe, "__gnat_readdir_is_thread_safe"); + begin + return (readdir_is_thread_safe /= 0); + end Read_Is_Thread_Safe; + + ---------------- + -- Remove_Dir -- + ---------------- + + procedure Remove_Dir + (Dir_Name : Dir_Name_Str; + Recursive : Boolean := False) + is + C_Dir_Name : constant String := Dir_Name & ASCII.NUL; + Last : Integer; + Str : String (1 .. Filename_Max); + Success : Boolean; + Current_Dir : Dir_Type; + + begin + -- Remove the directory only if it is empty + + if not Recursive then + if rmdir (C_Dir_Name) /= 0 then + raise Directory_Error; + end if; + + -- Remove directory and all files and directories that it may contain + + else + Open (Current_Dir, Dir_Name); + + loop + Read (Current_Dir, Str, Last); + exit when Last = 0; + + if GNAT.OS_Lib.Is_Directory + (Dir_Name & Dir_Separator & Str (1 .. Last)) + then + if Str (1 .. Last) /= "." + and then + Str (1 .. Last) /= ".." + then + -- Recursive call to remove a subdirectory and all its + -- files. + + Remove_Dir + (Dir_Name & Dir_Separator & Str (1 .. Last), + True); + end if; + + else + GNAT.OS_Lib.Delete_File + (Dir_Name & Dir_Separator & Str (1 .. Last), + Success); + + if not Success then + raise Directory_Error; + end if; + end if; + end loop; + + Close (Current_Dir); + Remove_Dir (Dir_Name); + end if; + end Remove_Dir; + +end GNAT.Directory_Operations; diff --git a/gcc/ada/libgnat/g-dirope.ads b/gcc/ada/libgnat/g-dirope.ads new file mode 100644 index 0000000..6c00451 --- /dev/null +++ b/gcc/ada/libgnat/g-dirope.ads @@ -0,0 +1,262 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D I R E C T O R Y _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Directory operations + +-- This package provides routines for manipulating directories. A directory +-- can be treated as a file, using open and close routines, and a scanning +-- routine is provided for iterating through the entries in a directory. + +-- See also child package GNAT.Directory_Operations.Iteration + +with System; +with Ada.Strings.Maps; + +package GNAT.Directory_Operations is + + subtype Dir_Name_Str is String; + -- A subtype used in this package to represent string values that are + -- directory names. A directory name is a prefix for files that appear + -- with in the directory. This means that for UNIX systems, the string + -- includes a final '/', and for DOS-like systems, it includes a final + -- '\' character. It can also include drive letters if the operating + -- system provides for this. The final '/' or '\' in a Dir_Name_Str is + -- optional when passed as a procedure or function in parameter. + + type Dir_Type is limited private; + -- A value used to reference a directory. Conceptually this value includes + -- the identity of the directory, and a sequential position within it. + + Null_Dir : constant Dir_Type; + -- Represent the value for an uninitialized or closed directory + + Directory_Error : exception; + -- Exception raised if the directory cannot be opened, read, closed, + -- created or if it is not possible to change the current execution + -- environment directory. + + Dir_Separator : constant Character; + -- Running system default directory separator + + -------------------------------- + -- Basic Directory operations -- + -------------------------------- + + procedure Change_Dir (Dir_Name : Dir_Name_Str); + -- Changes the working directory of the current execution environment + -- to the directory named by Dir_Name. Raises Directory_Error if Dir_Name + -- does not exist. + + procedure Make_Dir (Dir_Name : Dir_Name_Str); + -- Create a new directory named Dir_Name. Raises Directory_Error if + -- Dir_Name cannot be created. + + procedure Remove_Dir + (Dir_Name : Dir_Name_Str; + Recursive : Boolean := False); + -- Remove the directory named Dir_Name. If Recursive is set to True, then + -- Remove_Dir removes all the subdirectories and files that are in + -- Dir_Name. Raises Directory_Error if Dir_Name cannot be removed. + + function Get_Current_Dir return Dir_Name_Str; + -- Returns the current working directory for the execution environment + + procedure Get_Current_Dir (Dir : out Dir_Name_Str; Last : out Natural); + -- Returns the current working directory for the execution environment + -- The name is returned in Dir_Name. Last is the index in Dir_Name such + -- that Dir_Name (Last) is the last character written. If Dir_Name is + -- too small for the directory name, the name will be truncated before + -- being copied to Dir_Name. + + ------------------------- + -- Pathname Operations -- + ------------------------- + + subtype Path_Name is String; + -- All routines using Path_Name handle both styles (UNIX and DOS) of + -- directory separators (either slash or back slash). + + function Dir_Name (Path : Path_Name) return Dir_Name_Str; + -- Returns directory name for Path. This is similar to the UNIX dirname + -- command. Everything after the last directory separator is removed. If + -- there is no directory separator the current working directory is + -- returned. Note that the contents of Path is case-sensitive on + -- systems that have case-sensitive file names (like Unix), and + -- non-case-sensitive on systems where the file system is also non- + -- case-sensitive (such as Windows). + + function Base_Name + (Path : Path_Name; + Suffix : String := "") return String; + -- Any directory prefix is removed. A directory prefix is defined as + -- text up to and including the last directory separator character in + -- the input string. In addition if Path ends with the string given for + -- Suffix, then it is also removed. Note that Suffix here can be an + -- arbitrary string (it is not required to be a file extension). This + -- is equivalent to the UNIX basename command. The following rule is + -- always true: + -- + -- 'Path' and 'Dir_Name (Path) & Dir_Separator & Base_Name (Path)' + -- represent the same file. + -- + -- The comparison of Suffix is case-insensitive on systems like Windows + -- where the file search is case-insensitive (e.g. on such systems, + -- Base_Name ("/Users/AdaCore/BB12.patch", ".Patch") returns "BB12"). + -- + -- Note that the index bounds of the result match the corresponding indexes + -- in the Path string (you cannot assume that the lower bound of the + -- returned string is one). + + function File_Extension (Path : Path_Name) return String; + -- Return the file extension. This is defined as the string after the + -- last dot, including the dot itself. For example, if the file name + -- is "file1.xyz.adq", then the returned value would be ".adq". If no + -- dot is present in the file name, or the last character of the file + -- name is a dot, then the null string is returned. + + function File_Name (Path : Path_Name) return String; + -- Returns the file name and the file extension if present. It removes all + -- path information. This is equivalent to Base_Name with default Extension + -- value. + + type Path_Style is (UNIX, DOS, System_Default); + function Format_Pathname + (Path : Path_Name; + Style : Path_Style := System_Default) return Path_Name; + -- Removes all double directory separator and converts all '\' to '/' if + -- Style is UNIX and converts all '/' to '\' if Style is set to DOS. This + -- function will help to provide a consistent naming scheme running for + -- different environments. If style is set to System_Default the routine + -- will use the default directory separator on the running environment. + -- + -- The Style argument indicates the syntax to be used for path names: + -- + -- DOS + -- Use '\' as the directory separator (default on Windows) + -- + -- UNIX + -- Use '/' as the directory separator (default on all other systems) + -- + -- System_Default + -- Use the default style for the current system + + type Environment_Style is (UNIX, DOS, Both, System_Default); + function Expand_Path + (Path : Path_Name; + Mode : Environment_Style := System_Default) return Path_Name; + -- Returns Path with environment variables replaced by the current + -- environment variable value. For example, $HOME/mydir will be replaced + -- by /home/joe/mydir if $HOME environment variable is set to /home/joe and + -- Mode is UNIX. If an environment variable does not exist the variable + -- will be replaced by the empty string. Two dollar or percent signs are + -- replaced by a single dollar/percent sign. Note that a variable must + -- start with a letter. + -- + -- The Mode argument indicates the recognized syntax for environment + -- variables as follows: + -- + -- UNIX + -- Environment variables use $ as prefix and can use curly brackets + -- as in ${HOME}/mydir. If there is no closing curly bracket for an + -- opening one then no translation is done, so for example ${VAR/toto + -- is returned as ${VAR/toto. The use of {} brackets is required if + -- the environment variable name contains other than alphanumeric + -- characters. + -- + -- DOS + -- Environment variables uses % as prefix and suffix (e.g. %HOME%/dir). + -- The name DOS refer to "DOS-like" environment. This includes all + -- Windows systems. + -- + -- Both + -- Recognize both forms described above. + -- + -- System_Default + -- Uses either DOS on Windows, and UNIX on all other systems, depending + -- on the running environment. + + --------------- + -- Iterators -- + --------------- + + procedure Open (Dir : out Dir_Type; Dir_Name : Dir_Name_Str); + -- Opens the directory named by Dir_Name and returns a Dir_Type value + -- that refers to this directory, and is positioned at the first entry. + -- Raises Directory_Error if Dir_Name cannot be accessed. In that case + -- Dir will be set to Null_Dir. + + procedure Close (Dir : in out Dir_Type); + -- Closes the directory stream referred to by Dir. After calling Close + -- Is_Open will return False. Dir will be set to Null_Dir. + -- Raises Directory_Error if Dir has not be opened (Dir = Null_Dir). + + function Is_Open (Dir : Dir_Type) return Boolean; + -- Returns True if Dir is open, or False otherwise + + procedure Read + (Dir : Dir_Type; + Str : out String; + Last : out Natural); + -- Reads the next entry from the directory and sets Str to the name + -- of that entry. Last is the index in Str such that Str (Last) is the + -- last character written. Last is 0 when there are no more files in the + -- directory. If Str is too small for the file name, the file name will + -- be truncated before being copied to Str. The list of files returned + -- includes directories in systems providing a hierarchical directory + -- structure, including . (the current directory) and .. (the parent + -- directory) in systems providing these entries. The directory is + -- returned in target-OS form. Raises Directory_Error if Dir has not + -- be opened (Dir = Null_Dir). + + function Read_Is_Thread_Safe return Boolean; + -- Indicates if procedure Read is thread safe. On systems where the + -- target system supports this functionality, Read is thread safe, + -- and this function returns True (e.g. this will be the case on any + -- UNIX or UNIX-like system providing a correct implementation of the + -- function readdir_r). If the system cannot provide a thread safe + -- implementation of Read, then this function returns False. + +private + + type Dir_Type_Value is new System.Address; + -- Low-level address directory structure as returned by opendir in C + + type Dir_Type is access Dir_Type_Value; + + Null_Dir : constant Dir_Type := null; + + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + + Dir_Seps : constant Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set ("/\"); + -- UNIX and DOS style directory separators + +end GNAT.Directory_Operations; diff --git a/gcc/ada/libgnat/g-dynhta.adb b/gcc/ada/libgnat/g-dynhta.adb new file mode 100644 index 0000000..afa9e80 --- /dev/null +++ b/gcc/ada/libgnat/g-dynhta.adb @@ -0,0 +1,369 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ H T A B L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +package body GNAT.Dynamic_HTables is + + ------------------- + -- Static_HTable -- + ------------------- + + package body Static_HTable is + + function Get_Non_Null (T : Instance) return Elmt_Ptr; + -- Returns Null_Ptr if Iterator_Started is False or if the Table is + -- empty. Returns Iterator_Ptr if non null, or the next non null + -- element in table if any. + + --------- + -- Get -- + --------- + + function Get (T : Instance; K : Key) return Elmt_Ptr is + Elmt : Elmt_Ptr; + + begin + if T = null then + return Null_Ptr; + end if; + + Elmt := T.Table (Hash (K)); + + loop + if Elmt = Null_Ptr then + return Null_Ptr; + + elsif Equal (Get_Key (Elmt), K) then + return Elmt; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First (T : Instance) return Elmt_Ptr is + begin + if T = null then + return Null_Ptr; + end if; + + T.Iterator_Started := True; + T.Iterator_Index := T.Table'First; + T.Iterator_Ptr := T.Table (T.Iterator_Index); + return Get_Non_Null (T); + end Get_First; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next (T : Instance) return Elmt_Ptr is + begin + if T = null or else not T.Iterator_Started then + return Null_Ptr; + end if; + + T.Iterator_Ptr := Next (T.Iterator_Ptr); + return Get_Non_Null (T); + end Get_Next; + + ------------------ + -- Get_Non_Null -- + ------------------ + + function Get_Non_Null (T : Instance) return Elmt_Ptr is + begin + if T = null then + return Null_Ptr; + end if; + + while T.Iterator_Ptr = Null_Ptr loop + if T.Iterator_Index = T.Table'Last then + T.Iterator_Started := False; + return Null_Ptr; + end if; + + T.Iterator_Index := T.Iterator_Index + 1; + T.Iterator_Ptr := T.Table (T.Iterator_Index); + end loop; + + return T.Iterator_Ptr; + end Get_Non_Null; + + ------------ + -- Remove -- + ------------ + + procedure Remove (T : Instance; K : Key) is + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr; + Next_Elmt : Elmt_Ptr; + + begin + if T = null then + return; + end if; + + Elmt := T.Table (Index); + + if Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Elmt), K) then + T.Table (Index) := Next (Elmt); + + else + loop + Next_Elmt := Next (Elmt); + + if Next_Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Next_Elmt), K) then + Set_Next (Elmt, Next (Next_Elmt)); + return; + + else + Elmt := Next_Elmt; + end if; + end loop; + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset (T : in out Instance) is + procedure Free is + new Ada.Unchecked_Deallocation (Instance_Data, Instance); + + begin + if T = null then + return; + end if; + + for J in T.Table'Range loop + T.Table (J) := Null_Ptr; + end loop; + + Free (T); + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (T : in out Instance; E : Elmt_Ptr) is + Index : Header_Num; + + begin + if T = null then + T := new Instance_Data; + end if; + + Index := Hash (Get_Key (E)); + Set_Next (E, T.Table (Index)); + T.Table (Index) := E; + end Set; + + end Static_HTable; + + ------------------- + -- Simple_HTable -- + ------------------- + + package body Simple_HTable is + procedure Free is new + Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); + + --------- + -- Get -- + --------- + + function Get (T : Instance; K : Key) return Element is + Tmp : Elmt_Ptr; + + begin + if T = Nil then + return No_Element; + end if; + + Tmp := Tab.Get (Tab.Instance (T), K); + + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First (T : Instance) return Element is + Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); + + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_First; + + ------------------- + -- Get_First_Key -- + ------------------- + + function Get_First_Key (T : Instance) return Key_Option is + Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); + begin + if Tmp = null then + return Key_Option'(Present => False); + else + return Key_Option'(Present => True, K => Tmp.all.K); + end if; + end Get_First_Key; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Elmt_Ptr) return Key is + begin + return E.K; + end Get_Key; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next (T : Instance) return Element is + Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_Next; + + ------------------ + -- Get_Next_Key -- + ------------------ + + function Get_Next_Key (T : Instance) return Key_Option is + Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); + begin + if Tmp = null then + return Key_Option'(Present => False); + else + return Key_Option'(Present => True, K => Tmp.all.K); + end if; + end Get_Next_Key; + + ---------- + -- Next -- + ---------- + + function Next (E : Elmt_Ptr) return Elmt_Ptr is + begin + return E.Next; + end Next; + + ------------ + -- Remove -- + ------------ + + procedure Remove (T : Instance; K : Key) is + Tmp : Elmt_Ptr; + + begin + Tmp := Tab.Get (Tab.Instance (T), K); + + if Tmp /= null then + Tab.Remove (Tab.Instance (T), K); + Free (Tmp); + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset (T : in out Instance) is + E1, E2 : Elmt_Ptr; + + begin + E1 := Tab.Get_First (Tab.Instance (T)); + while E1 /= null loop + E2 := Tab.Get_Next (Tab.Instance (T)); + Free (E1); + E1 := E2; + end loop; + + Tab.Reset (Tab.Instance (T)); + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (T : in out Instance; K : Key; E : Element) is + Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K); + begin + if Tmp = null then + Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null)); + else + Tmp.E := E; + end if; + end Set; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is + begin + E.Next := Next; + end Set_Next; + + end Simple_HTable; + +end GNAT.Dynamic_HTables; diff --git a/gcc/ada/libgnat/g-dynhta.ads b/gcc/ada/libgnat/g-dynhta.ads new file mode 100644 index 0000000..85a0427 --- /dev/null +++ b/gcc/ada/libgnat/g-dynhta.ads @@ -0,0 +1,266 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ H T A B L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Hash table searching routines + +-- This package contains three separate packages. The Simple_HTable package +-- provides a very simple abstraction that associates one element to one key +-- value and takes care of all allocations automatically using the heap. The +-- Static_HTable package provides a more complex interface that allows full +-- control over allocation. The Load_Factor_HTable package provides a more +-- complex abstraction where collisions are resolved by chaining, and the +-- table grows by a percentage after the load factor has been exceeded. + +-- This package provides a facility similar to that of GNAT.HTable, except +-- that this package declares types that can be used to define dynamic +-- instances of hash tables, while instantiations in GNAT.HTable creates a +-- single instance of the hash table. + +-- Note that this interface should remain synchronized with those in +-- GNAT.HTable to keep as much coherency as possible between these two +-- related units. + +package GNAT.Dynamic_HTables is + + ------------------- + -- Static_HTable -- + ------------------- + + -- A low-level Hash-Table abstraction, not as easy to instantiate as + -- Simple_HTable. This mirrors the interface of GNAT.HTable.Static_HTable, + -- but does require dynamic allocation (since we allow multiple instances + -- of the table). The model is that each Element contains its own Key that + -- can be retrieved by Get_Key. Furthermore, Element provides a link that + -- can be used by the HTable for linking elements with same hash codes: + + -- Element + + -- +-------------------+ + -- | Key | + -- +-------------------+ + -- : other data : + -- +-------------------+ + -- | Next Elmt | + -- +-------------------+ + + generic + type Header_Num is range <>; + -- An integer type indicating the number and range of hash headers + + type Element (<>) is limited private; + -- The type of element to be stored + + type Elmt_Ptr is private; + -- The type used to reference an element (will usually be an access + -- type, but could be some other form of type such as an integer type). + + Null_Ptr : Elmt_Ptr; + -- The null value of the Elmt_Ptr type + + with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + with function Next (E : Elmt_Ptr) return Elmt_Ptr; + -- The type must provide an internal link for the sake of the + -- staticness of the HTable. + + type Key is limited private; + with function Get_Key (E : Elmt_Ptr) return Key; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Static_HTable is + + type Instance is private; + Nil : constant Instance; + + procedure Reset (T : in out Instance); + -- Resets the hash table by releasing all memory associated with + -- it. The hash table can safely be reused after this call. For the + -- most common case where Elmt_Ptr is an access type, and Null_Ptr is + -- null, this is only needed if the same table is reused in a new + -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is + -- other than null, then Reset must be called before the first use of + -- the hash table. + + procedure Set (T : in out Instance; E : Elmt_Ptr); + -- Insert the element pointer in the HTable + + function Get (T : Instance; K : Key) return Elmt_Ptr; + -- Returns the latest inserted element pointer with the given Key + -- or null if none. + + procedure Remove (T : Instance; K : Key); + -- Removes the latest inserted element pointer associated with the + -- given key if any, does nothing if none. + + function Get_First (T : Instance) return Elmt_Ptr; + -- Returns Null_Ptr if the Htable is empty, otherwise returns one + -- unspecified element. There is no guarantee that 2 calls to this + -- function will return the same element. + + function Get_Next (T : Instance) return Elmt_Ptr; + -- Returns an unspecified element that has not been returned by the + -- same function since the last call to Get_First or Null_Ptr if + -- there is no such element or Get_First has never been called. If + -- there is no call to 'Set' in between Get_Next calls, all the + -- elements of the Htable will be traversed. + + private + type Table_Type is array (Header_Num) of Elmt_Ptr; + + type Instance_Data is record + Table : Table_Type; + Iterator_Index : Header_Num; + Iterator_Ptr : Elmt_Ptr; + Iterator_Started : Boolean := False; + end record; + + type Instance is access all Instance_Data; + + Nil : constant Instance := null; + end Static_HTable; + + ------------------- + -- Simple_HTable -- + ------------------- + + -- A simple hash table abstraction, easy to instantiate, easy to use. + -- The table associates one element to one key with the procedure Set. + -- Get retrieves the Element stored for a given Key. The efficiency of + -- retrieval is function of the size of the Table parameterized by + -- Header_Num and the hashing function Hash. + + generic + type Header_Num is range <>; + -- An integer type indicating the number and range of hash headers + + type Element is private; + -- The type of element to be stored + + No_Element : Element; + -- The object that is returned by Get when no element has been set for + -- a given key + + type Key is private; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Simple_HTable is + + type Instance is private; + Nil : constant Instance; + + type Key_Option (Present : Boolean := False) is record + case Present is + when True => K : Key; + when False => null; + end case; + end record; + + procedure Set (T : in out Instance; K : Key; E : Element); + -- Associates an element with a given key. Overrides any previously + -- associated element. + + procedure Reset (T : in out Instance); + -- Releases all memory associated with the table. The table can be + -- reused after this call (it is automatically allocated on the first + -- access to the table). + + function Get (T : Instance; K : Key) return Element; + -- Returns the Element associated with a key or No_Element if the given + -- key has not associated element + + procedure Remove (T : Instance; K : Key); + -- Removes the latest inserted element pointer associated with the given + -- key if any, does nothing if none. + + function Get_First (T : Instance) return Element; + -- Returns No_Element if the Htable is empty, otherwise returns one + -- unspecified element. There is no guarantee that two calls to this + -- function will return the same element, if the Htable has been + -- modified between the two calls. + + function Get_First_Key (T : Instance) return Key_Option; + -- Returns an option type giving an unspecified key. If the Htable + -- is empty, the discriminant will have field Present set to False, + -- otherwise its Present field is set to True and the field K contains + -- the key. There is no guarantee that two calls to this function will + -- return the same key, if the Htable has been modified between the two + -- calls. + + function Get_Next (T : Instance) return Element; + -- Returns an unspecified element that has not been returned by the + -- same function since the last call to Get_First or No_Element if + -- there is no such element. If there is no call to 'Set' in between + -- Get_Next calls, all the elements of the Htable will be traversed. + -- To guarantee that all the elements of the Htable will be traversed, + -- no modification of the Htable (Set, Reset, Remove) should occur + -- between a call to Get_First and subsequent consecutive calls to + -- Get_Next, until one of these calls returns No_Element. + + function Get_Next_Key (T : Instance) return Key_Option; + -- Same as Get_Next except that this returns an option type having field + -- Present set either to False if there no key never returned before by + -- either Get_First_Key or this very same function, or to True if there + -- is one, with the field K containing the key specified as before. The + -- same restrictions apply as Get_Next. + + private + + type Element_Wrapper; + type Elmt_Ptr is access all Element_Wrapper; + type Element_Wrapper is record + K : Key; + E : Element; + Next : Elmt_Ptr; + end record; + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + function Next (E : Elmt_Ptr) return Elmt_Ptr; + function Get_Key (E : Elmt_Ptr) return Key; + + package Tab is new Static_HTable + (Header_Num => Header_Num, + Element => Element_Wrapper, + Elmt_Ptr => Elmt_Ptr, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Key, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + type Instance is new Tab.Instance; + Nil : constant Instance := Instance (Tab.Nil); + + end Simple_HTable; + +end GNAT.Dynamic_HTables; diff --git a/gcc/ada/libgnat/g-dyntab.adb b/gcc/ada/libgnat/g-dyntab.adb new file mode 100644 index 0000000..ff27f07 --- /dev/null +++ b/gcc/ada/libgnat/g-dyntab.adb @@ -0,0 +1,497 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ T A B L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with GNAT.Heap_Sort_G; + +with Ada.Unchecked_Deallocation; +with System; + +package body GNAT.Dynamic_Tables is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Last_Allocated (T : Instance) return Table_Last_Type; + pragma Inline (Last_Allocated); + -- Return the index of the last allocated element + + procedure Grow (T : in out Instance; New_Last : Table_Last_Type); + -- This is called when we are about to set the value of Last to a value + -- that is larger than Last_Allocated. This reallocates the table to the + -- larger size, as indicated by New_Last. At the time this is called, + -- Last (T) is still the old value, and this does not modify it. + + -------------- + -- Allocate -- + -------------- + + procedure Allocate (T : in out Instance; Num : Integer := 1) is + begin + -- Note that Num can be negative + + pragma Assert (not T.Locked); + Set_Last (T, Last (T) + Table_Index_Type'Base (Num)); + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (T : in out Instance; New_Val : Table_Component_Type) is + pragma Assert (not T.Locked); + New_Last : constant Table_Last_Type := Last (T) + 1; + + begin + if New_Last <= Last_Allocated (T) then + + -- Fast path + + T.P.Last := New_Last; + T.Table (New_Last) := New_Val; + + else + Set_Item (T, New_Last, New_Val); + end if; + end Append; + + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (T : in out Instance; New_Vals : Table_Type) is + begin + for J in New_Vals'Range loop + Append (T, New_Vals (J)); + end loop; + end Append_All; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last (T : in out Instance) is + begin + pragma Assert (not T.Locked); + Allocate (T, -1); + end Decrement_Last; + + ----------- + -- First -- + ----------- + + function First return Table_Index_Type is + begin + return Table_Low_Bound; + end First; + + -------------- + -- For_Each -- + -------------- + + procedure For_Each (Table : Instance) is + Quit : Boolean := False; + begin + for Index in First .. Last (Table) loop + Action (Index, Table.Table (Index), Quit); + exit when Quit; + end loop; + end For_Each; + + ---------- + -- Grow -- + ---------- + + procedure Grow (T : in out Instance; New_Last : Table_Last_Type) is + + -- Note: Type Alloc_Ptr below needs to be declared locally so we know + -- the bounds. That means that the collection is local, so is finalized + -- when leaving Grow. That's why this package doesn't support controlled + -- types; the table elements would be finalized prematurely. An Ada + -- implementation would also be within its rights to reclaim the + -- storage. Fortunately, GNAT doesn't do that. + + pragma Assert (not T.Locked); + pragma Assert (New_Last > Last_Allocated (T)); + + subtype Table_Length_Type is Table_Index_Type'Base + range 0 .. Table_Index_Type'Base'Last; + + Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); + Old_Allocated_Length : constant Table_Length_Type := + Old_Last_Allocated - First + 1; + + New_Length : constant Table_Length_Type := New_Last - First + 1; + New_Allocated_Length : Table_Length_Type; + + begin + if T.Table = Empty_Table_Ptr then + New_Allocated_Length := Table_Length_Type (Table_Initial); + else + New_Allocated_Length := + Table_Length_Type + (Long_Long_Integer (Old_Allocated_Length) * + (100 + Long_Long_Integer (Table_Increment)) / 100); + end if; + + -- Make sure it really did grow + + if New_Allocated_Length <= Old_Allocated_Length then + New_Allocated_Length := Old_Allocated_Length + 10; + end if; + + if New_Allocated_Length <= New_Length then + New_Allocated_Length := New_Length + 10; + end if; + + pragma Assert (New_Allocated_Length > Old_Allocated_Length); + pragma Assert (New_Allocated_Length > New_Length); + + T.P.Last_Allocated := First + New_Allocated_Length - 1; + + declare + subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); + type Old_Alloc_Ptr is access all Old_Alloc_Type; + + procedure Free is + new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); + function To_Old_Alloc_Ptr is + new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); + + subtype Alloc_Type is + Table_Type (First .. First + New_Allocated_Length - 1); + type Alloc_Ptr is access all Alloc_Type; + + function To_Table_Ptr is + new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); + + Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); + New_Table : constant Alloc_Ptr := new Alloc_Type; + + begin + if T.Table /= Empty_Table_Ptr then + New_Table (First .. Last (T)) := Old_Table (First .. Last (T)); + Free (Old_Table); + end if; + + T.Table := To_Table_Ptr (New_Table); + end; + + pragma Assert (New_Last <= Last_Allocated (T)); + pragma Assert (T.Table /= null); + pragma Assert (T.Table /= Empty_Table_Ptr); + end Grow; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last (T : in out Instance) is + begin + pragma Assert (not T.Locked); + Allocate (T, 1); + end Increment_Last; + + ---------- + -- Init -- + ---------- + + procedure Init (T : in out Instance) is + pragma Assert (not T.Locked); + subtype Alloc_Type is Table_Type (First .. Last_Allocated (T)); + type Alloc_Ptr is access all Alloc_Type; + + procedure Free is new Ada.Unchecked_Deallocation (Alloc_Type, Alloc_Ptr); + function To_Alloc_Ptr is + new Ada.Unchecked_Conversion (Table_Ptr, Alloc_Ptr); + + Temp : Alloc_Ptr := To_Alloc_Ptr (T.Table); + + begin + if T.Table = Empty_Table_Ptr then + pragma Assert (T.P = (Last_Allocated | Last => First - 1)); + null; + else + Free (Temp); + T.Table := Empty_Table_Ptr; + T.P := (Last_Allocated | Last => First - 1); + end if; + end Init; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (T : Instance) return Boolean is + begin + return Last (T) = First - 1; + end Is_Empty; + + ---------- + -- Last -- + ---------- + + function Last (T : Instance) return Table_Last_Type is + begin + return T.P.Last; + end Last; + + -------------------- + -- Last_Allocated -- + -------------------- + + function Last_Allocated (T : Instance) return Table_Last_Type is + begin + return T.P.Last_Allocated; + end Last_Allocated; + + ---------- + -- Move -- + ---------- + + procedure Move (From, To : in out Instance) is + begin + pragma Assert (not From.Locked); + pragma Assert (not To.Locked); + pragma Assert (Is_Empty (To)); + To := From; + + From.Table := Empty_Table_Ptr; + From.Locked := False; + From.P.Last_Allocated := First - 1; + From.P.Last := First - 1; + pragma Assert (Is_Empty (From)); + end Move; + + ------------- + -- Release -- + ------------- + + procedure Release (T : in out Instance) is + pragma Assert (not T.Locked); + Old_Last_Allocated : constant Table_Last_Type := Last_Allocated (T); + + function New_Last_Allocated return Table_Last_Type; + -- Compute the new value of Last_Allocated. This is normally equal to + -- Last, but if Release_Threshold /= 0, then we need to take that into + -- account. + + ------------------------ + -- New_Last_Allocated -- + ------------------------ + + function New_Last_Allocated return Table_Last_Type is + subtype Table_Length_Type is Table_Index_Type'Base + range 0 .. Table_Index_Type'Base'Last; + + Length : constant Table_Length_Type := Last (T) - First + 1; + + Comp_Size_In_Bytes : constant Table_Length_Type := + Table_Type'Component_Size / System.Storage_Unit; + + Length_Threshold : constant Table_Length_Type := + Table_Length_Type (Release_Threshold) / Comp_Size_In_Bytes; + + begin + if Release_Threshold = 0 or else Length < Length_Threshold then + return Last (T); + else + declare + Extra_Length : constant Table_Length_Type := Length / 1000; + begin + return (Length + Extra_Length) - 1 + First; + end; + end if; + end New_Last_Allocated; + + -- Local variables + + New_Last_Alloc : constant Table_Last_Type := New_Last_Allocated; + + -- Start of processing for Release + + begin + if New_Last_Alloc < Last_Allocated (T) then + pragma Assert (Last (T) < Last_Allocated (T)); + pragma Assert (T.Table /= Empty_Table_Ptr); + + declare + subtype Old_Alloc_Type is Table_Type (First .. Old_Last_Allocated); + type Old_Alloc_Ptr is access all Old_Alloc_Type; + + procedure Free is + new Ada.Unchecked_Deallocation (Old_Alloc_Type, Old_Alloc_Ptr); + function To_Old_Alloc_Ptr is + new Ada.Unchecked_Conversion (Table_Ptr, Old_Alloc_Ptr); + + subtype Alloc_Type is Table_Type (First .. New_Last_Alloc); + type Alloc_Ptr is access all Alloc_Type; + + function To_Table_Ptr is + new Ada.Unchecked_Conversion (Alloc_Ptr, Table_Ptr); + + Old_Table : Old_Alloc_Ptr := To_Old_Alloc_Ptr (T.Table); + New_Table : constant Alloc_Ptr := new Alloc_Type; + + begin + New_Table (First .. Last (T)) := Old_Table (First .. Last (T)); + T.P.Last_Allocated := New_Last_Alloc; + Free (Old_Table); + T.Table := To_Table_Ptr (New_Table); + end; + end if; + end Release; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (T : in out Instance; + Index : Valid_Table_Index_Type; + Item : Table_Component_Type) + is + begin + pragma Assert (not T.Locked); + + -- If Set_Last is going to reallocate the table, we make a copy of Item, + -- in case the call was "Set_Item (T, X, T.Table (Y));", and Item is + -- passed by reference. Without the copy, we would deallocate the array + -- containing Item, leaving a dangling pointer. + + if Index > Last_Allocated (T) then + declare + Item_Copy : constant Table_Component_Type := Item; + begin + Set_Last (T, Index); + T.Table (Index) := Item_Copy; + end; + + else + if Index > Last (T) then + Set_Last (T, Index); + end if; + + T.Table (Index) := Item; + end if; + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (T : in out Instance; New_Val : Table_Last_Type) is + begin + pragma Assert (not T.Locked); + if New_Val > Last_Allocated (T) then + Grow (T, New_Val); + end if; + + T.P.Last := New_Val; + end Set_Last; + + ---------------- + -- Sort_Table -- + ---------------- + + procedure Sort_Table (Table : in out Instance) is + Temp : Table_Component_Type; + -- A temporary position to simulate index 0 + + -- Local subprograms + + function Index_Of (Idx : Natural) return Table_Index_Type'Base; + -- Return index of Idx'th element of table + + function Lower_Than (Op1, Op2 : Natural) return Boolean; + -- Compare two components + + procedure Move (From : Natural; To : Natural); + -- Move one component + + package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than); + + -------------- + -- Index_Of -- + -------------- + + function Index_Of (Idx : Natural) return Table_Index_Type'Base is + J : constant Integer'Base := + Table_Index_Type'Base'Pos (First) + Idx - 1; + begin + return Table_Index_Type'Base'Val (J); + end Index_Of; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + if From = 0 then + Table.Table (Index_Of (To)) := Temp; + + elsif To = 0 then + Temp := Table.Table (Index_Of (From)); + + else + Table.Table (Index_Of (To)) := + Table.Table (Index_Of (From)); + end if; + end Move; + + ---------------- + -- Lower_Than -- + ---------------- + + function Lower_Than (Op1, Op2 : Natural) return Boolean is + begin + if Op1 = 0 then + return Lt (Temp, Table.Table (Index_Of (Op2))); + + elsif Op2 = 0 then + return Lt (Table.Table (Index_Of (Op1)), Temp); + + else + return + Lt (Table.Table (Index_Of (Op1)), Table.Table (Index_Of (Op2))); + end if; + end Lower_Than; + + -- Start of processing for Sort_Table + + begin + Heap_Sort.Sort (Natural (Last (Table) - First) + 1); + end Sort_Table; + +end GNAT.Dynamic_Tables; diff --git a/gcc/ada/libgnat/g-dyntab.ads b/gcc/ada/libgnat/g-dyntab.ads new file mode 100644 index 0000000..cb4b741 --- /dev/null +++ b/gcc/ada/libgnat/g-dyntab.ads @@ -0,0 +1,293 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . D Y N A M I C _ T A B L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Resizable one dimensional array support + +-- This package provides an implementation of dynamically resizable one +-- dimensional arrays. The idea is to mimic the normal Ada semantics for +-- arrays as closely as possible with the one additional capability of +-- dynamically modifying the value of the Last attribute. + +-- This package provides a facility similar to that of Ada.Containers.Vectors. + +-- Note that these three interfaces should remain synchronized to keep as much +-- coherency as possible among these related units: +-- +-- GNAT.Dynamic_Tables +-- GNAT.Table +-- Table (the compiler unit) + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Conversion; + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type := Table_Index_Type'First; + Table_Initial : Positive := 8; + Table_Increment : Natural := 100; + Release_Threshold : Natural := 0; -- size in bytes + +package GNAT.Dynamic_Tables is + + -- Table_Component_Type and Table_Index_Type specify the type of the array, + -- Table_Low_Bound is the lower bound. The effect is roughly to declare: + + -- Table : array (Table_Low_Bound .. <>) of Table_Component_Type; + + -- The lower bound of Table_Index_Type is ignored. + + -- Table_Component_Type must not be a type with controlled parts. + + -- The Table_Initial value controls the allocation of the table when it is + -- first allocated. + + -- The Table_Increment value controls the amount of increase, if the table + -- has to be increased in size. The value given is a percentage value (e.g. + -- 100 = increase table size by 100%, i.e. double it). + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: we do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + -- WARNING: On HPPA, the virtual addressing approach used in this unit is + -- incompatible with the indexing instructions on the HPPA. So when using + -- this unit, compile your application with -mdisable-indexing. + + -- WARNING: If the table is reallocated, then the address of all its + -- components will change. So do not capture the address of an element + -- and then use the address later after the table may be reallocated. One + -- tricky case of this is passing an element of the table to a subprogram + -- by reference where the table gets reallocated during the execution of + -- the subprogram. The best rule to follow is never to pass a table element + -- as a parameter except for the case of IN mode parameters with scalar + -- values. + + pragma Assert (Table_Low_Bound /= Table_Index_Type'Base'First); + + subtype Valid_Table_Index_Type is Table_Index_Type'Base + range Table_Low_Bound .. Table_Index_Type'Base'Last; + subtype Table_Last_Type is Table_Index_Type'Base + range Table_Low_Bound - 1 .. Table_Index_Type'Base'Last; + + -- Table_Component_Type must not be a type with controlled parts. + + -- The Table_Initial value controls the allocation of the table when it is + -- first allocated. + + -- The Table_Increment value controls the amount of increase, if the table + -- has to be increased in size. The value given is a percentage value (e.g. + -- 100 = increase table size by 100%, i.e. double it). + + -- The Last and Set_Last subprograms provide control over the current + -- logical allocation. They are quite efficient, so they can be used + -- freely (expensive reallocation occurs only at major granularity + -- chunks controlled by the allocation parameters). + + -- Note: we do not make the table components aliased, since this would + -- restrict the use of table for discriminated types. If it is necessary + -- to take the access of a table element, use Unrestricted_Access. + + type Table_Type is + array (Valid_Table_Index_Type range <>) of Table_Component_Type; + subtype Big_Table_Type is + Table_Type (Table_Low_Bound .. Valid_Table_Index_Type'Last); + -- We work with pointers to a bogus array type that is constrained with + -- the maximum possible range bound. This means that the pointer is a thin + -- pointer, which is more efficient. Since subscript checks in any case + -- must be on the logical, rather than physical bounds, safety is not + -- compromised by this approach. + + -- To get subscript checking, rename a slice of the Table, like this: + + -- Table : Table_Type renames T.Table (First .. Last (T)); + + -- and then refer to components of Table. + + type Table_Ptr is access all Big_Table_Type; + for Table_Ptr'Storage_Size use 0; + -- The table is actually represented as a pointer to allow reallocation + + type Table_Private is private; + -- Table private data that is not exported in Instance + + -- Private use only: + subtype Empty_Table_Array_Type is + Table_Type (Table_Low_Bound .. Table_Low_Bound - 1); + type Empty_Table_Array_Ptr is access all Empty_Table_Array_Type; + Empty_Table_Array : aliased Empty_Table_Array_Type; + function Empty_Table_Array_Ptr_To_Table_Ptr is + new Ada.Unchecked_Conversion (Empty_Table_Array_Ptr, Table_Ptr); + Empty_Table_Ptr : constant Table_Ptr := + Empty_Table_Array_Ptr_To_Table_Ptr (Empty_Table_Array'Access); + -- End private use only. The above are used to initialize Table to point to + -- an empty array. + + type Instance is record + Table : Table_Ptr := Empty_Table_Ptr; + -- The table itself. The lower bound is the value of First. Logically + -- the upper bound is the current value of Last (although the actual + -- size of the allocated table may be larger than this). The program may + -- only access and modify Table entries in the range First .. Last. + -- + -- It's a good idea to access this via a renaming of a slice, in order + -- to ensure bounds checking, as in: + -- + -- Tab : Table_Type renames X.Table (First .. X.Last); + -- + -- Note: The Table component must come first. See declarations of + -- SCO_Unit_Table and SCO_Table in scos.h. + + Locked : Boolean := False; + -- Table reallocation is permitted only if this is False. A client may + -- set Locked to True, in which case any operation that might expand or + -- shrink the table will cause an assertion failure. While a table is + -- locked, its address in memory remains fixed and unchanging. + + P : Table_Private; + end record; + + function Is_Empty (T : Instance) return Boolean; + pragma Inline (Is_Empty); + + procedure Init (T : in out Instance); + -- Reinitializes the table to empty. There is no need to call this before + -- using a table; tables default to empty. + + procedure Free (T : in out Instance) renames Init; + + function First return Table_Index_Type; + pragma Inline (First); + -- Export First as synonym for Table_Low_Bound (parallel with use of Last) + + function Last (T : Instance) return Table_Last_Type; + pragma Inline (Last); + -- Returns the current value of the last used entry in the table, which can + -- then be used as a subscript for Table. + + procedure Release (T : in out Instance); + -- Storage is allocated in chunks according to the values given in the + -- Table_Initial and Table_Increment parameters. If Release_Threshold is + -- 0 or the length of the table does not exceed this threshold then a call + -- to Release releases all storage that is allocated, but is not logically + -- part of the current array value; otherwise the call to Release leaves + -- the current array value plus 0.1% of the current table length free + -- elements located at the end of the table. This parameter facilitates + -- reopening large tables and adding a few elements without allocating a + -- chunk of memory. In both cases current array values are not affected by + -- this call. + + procedure Set_Last (T : in out Instance; New_Val : Table_Last_Type); + pragma Inline (Set_Last); + -- This procedure sets Last to the indicated value. If necessary the table + -- is reallocated to accommodate the new value (i.e. on return the + -- allocated table has an upper bound of at least Last). If Set_Last + -- reduces the size of the table, then logically entries are removed from + -- the table. If Set_Last increases the size of the table, then new entries + -- are logically added to the table. + + procedure Increment_Last (T : in out Instance); + pragma Inline (Increment_Last); + -- Adds 1 to Last (same as Set_Last (Last + 1)) + + procedure Decrement_Last (T : in out Instance); + pragma Inline (Decrement_Last); + -- Subtracts 1 from Last (same as Set_Last (Last - 1)) + + procedure Append (T : in out Instance; New_Val : Table_Component_Type); + pragma Inline (Append); + -- Appends New_Val onto the end of the table + -- Equivalent to: + -- Increment_Last (T); + -- T.Table (T.Last) := New_Val; + + procedure Append_All (T : in out Instance; New_Vals : Table_Type); + -- Appends all components of New_Vals + + procedure Set_Item + (T : in out Instance; + Index : Valid_Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + -- Put Item in the table at position Index. If Index points to an existing + -- item (i.e. it is in the range First .. Last (T)), the item is replaced. + -- Otherwise (i.e. Index > Last (T)), the table is expanded, and Last is + -- set to Index. + + procedure Move (From, To : in out Instance); + -- Moves from From to To, and sets From to empty + + procedure Allocate (T : in out Instance; Num : Integer := 1); + pragma Inline (Allocate); + -- Adds Num to Last + + generic + with procedure Action + (Index : Valid_Table_Index_Type; + Item : Table_Component_Type; + Quit : in out Boolean) is <>; + procedure For_Each (Table : Instance); + -- Calls procedure Action for each component of the table, or until one of + -- these calls set Quit to True. + + generic + with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; + procedure Sort_Table (Table : in out Instance); + -- This procedure sorts the components of the table into ascending order + -- making calls to Lt to do required comparisons, and using assignments + -- to move components around. The Lt function returns True if Comp1 is + -- less than Comp2 (in the sense of the desired sort), and False if Comp1 + -- is greater than Comp2. For equal objects it does not matter if True or + -- False is returned (it is slightly more efficient to return False). The + -- sort is not stable (the order of equal items in the table is not + -- preserved). + +private + + type Table_Private is record + Last_Allocated : Table_Last_Type := Table_Low_Bound - 1; + -- Subscript of the maximum entry in the currently allocated table. + -- Initial value ensures that we initially allocate the table. + + Last : Table_Last_Type := Table_Low_Bound - 1; + -- Current value of Last function + + -- Invariant: Last <= Last_Allocated + end record; + +end GNAT.Dynamic_Tables; diff --git a/gcc/ada/libgnat/g-eacodu.adb b/gcc/ada/libgnat/g-eacodu.adb new file mode 100644 index 0000000..30dca3d --- /dev/null +++ b/gcc/ada/libgnat/g-eacodu.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default (Unix) version + +separate (GNAT.Exception_Actions) +procedure Core_Dump (Occurrence : Exception_Occurrence) is + pragma Unreferenced (Occurrence); + SIG_ABORT : constant := 6; + procedure C_Abort; + pragma Import (C, C_Abort, "abort"); + procedure Signal (Signum : Integer; Handler : System.Address); + pragma Import (C, Signal, "signal"); + +begin + -- Unregister the default handler for SIGABRT, since otherwise we would + -- simply get a standard Ada exception, which is not what we want. + + Signal (SIG_ABORT, System.Null_Address); + C_Abort; +end Core_Dump; diff --git a/gcc/ada/libgnat/g-encstr.adb b/gcc/ada/libgnat/g-encstr.adb new file mode 100644 index 0000000..260e677 --- /dev/null +++ b/gcc/ada/libgnat/g-encstr.adb @@ -0,0 +1,258 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E N C O D E _ S T R I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; use Interfaces; + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_Cnv; use System.WCh_Cnv; + +package body GNAT.Encode_String is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Bad; + pragma No_Return (Bad); + -- Raise error for bad character code + + procedure Past_End; + pragma No_Return (Past_End); + -- Raise error for off end of string + + --------- + -- Bad -- + --------- + + procedure Bad is + begin + raise Constraint_Error with + "character cannot be encoded with given Encoding_Method"; + end Bad; + + ------------------------ + -- Encode_Wide_String -- + ------------------------ + + function Encode_Wide_String (S : Wide_String) return String is + Long : constant Natural := WC_Longest_Sequences (Encoding_Method); + Result : String (1 .. S'Length * Long); + Length : Natural; + begin + Encode_Wide_String (S, Result, Length); + return Result (1 .. Length); + end Encode_Wide_String; + + procedure Encode_Wide_String + (S : Wide_String; + Result : out String; + Length : out Natural) + is + Ptr : Natural; + + begin + Ptr := S'First; + for J in S'Range loop + Encode_Wide_Character (S (J), Result, Ptr); + end loop; + + Length := Ptr - S'First; + end Encode_Wide_String; + + ----------------------------- + -- Encode_Wide_Wide_String -- + ----------------------------- + + function Encode_Wide_Wide_String (S : Wide_Wide_String) return String is + Long : constant Natural := WC_Longest_Sequences (Encoding_Method); + Result : String (1 .. S'Length * Long); + Length : Natural; + begin + Encode_Wide_Wide_String (S, Result, Length); + return Result (1 .. Length); + end Encode_Wide_Wide_String; + + procedure Encode_Wide_Wide_String + (S : Wide_Wide_String; + Result : out String; + Length : out Natural) + is + Ptr : Natural; + + begin + Ptr := S'First; + for J in S'Range loop + Encode_Wide_Wide_Character (S (J), Result, Ptr); + end loop; + + Length := Ptr - S'First; + end Encode_Wide_Wide_String; + + --------------------------- + -- Encode_Wide_Character -- + --------------------------- + + procedure Encode_Wide_Character + (Char : Wide_Character; + Result : in out String; + Ptr : in out Natural) + is + begin + Encode_Wide_Wide_Character + (Wide_Wide_Character'Val (Wide_Character'Pos (Char)), Result, Ptr); + + exception + when Constraint_Error => + Bad; + end Encode_Wide_Character; + + -------------------------------- + -- Encode_Wide_Wide_Character -- + -------------------------------- + + procedure Encode_Wide_Wide_Character + (Char : Wide_Wide_Character; + Result : in out String; + Ptr : in out Natural) + is + U : Unsigned_32; + + procedure Out_Char (C : Character); + pragma Inline (Out_Char); + -- Procedure to store one character for instantiation below + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + if Ptr > Result'Last then + Past_End; + else + Result (Ptr) := C; + Ptr := Ptr + 1; + end if; + end Out_Char; + + -- Start of processing for Encode_Wide_Wide_Character; + + begin + -- Efficient code for UTF-8 case + + if Encoding_Method = WCEM_UTF8 then + + -- Note: for details of UTF8 encoding see RFC 3629 + + U := Unsigned_32 (Wide_Wide_Character'Pos (Char)); + + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + if U <= 16#00_007F# then + Out_Char (Character'Val (U)); + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + elsif U <= 16#00_07FF# then + Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx + + elsif U <= 16#00_FFFF# then + Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + + elsif U <= 16#10_FFFF# then + Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + elsif U <= 16#03FF_FFFF# then + Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- All other cases are invalid character codes, not this includes: + + -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx 10xxxxxx + + -- since Wide_Wide_Character values cannot exceed 16#3F_FFFF# + + else + Bad; + end if; + + -- All encoding methods other than UTF-8 + + else + Non_UTF8 : declare + procedure UTF_32_To_String is + new UTF_32_To_Char_Sequence (Out_Char); + -- Instantiate conversion procedure with above Out_Char routine + + begin + UTF_32_To_String + (UTF_32_Code (Wide_Wide_Character'Pos (Char)), Encoding_Method); + + exception + when Constraint_Error => + Bad; + end Non_UTF8; + end if; + end Encode_Wide_Wide_Character; + + -------------- + -- Past_End -- + -------------- + + procedure Past_End is + begin + raise Constraint_Error with "past end of string"; + end Past_End; + +end GNAT.Encode_String; diff --git a/gcc/ada/libgnat/g-encstr.ads b/gcc/ada/libgnat/g-encstr.ads new file mode 100644 index 0000000..a8aa669 --- /dev/null +++ b/gcc/ada/libgnat/g-encstr.ads @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E N C O D E _ S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This generic package provides utility routines for converting from +-- Wide_String or Wide_Wide_String to encoded String using a specified +-- encoding convention, which is supplied as the generic parameter. If +-- this parameter is a known at compile time constant (e.g. a constant +-- defined in System.WCh_Con), the instantiation is specialized so that +-- it applies only to this specified coding. + +-- Note: this package is only about encoding sequences of 16- or 32-bit +-- characters into a sequence of 8-bit codes. It knows nothing at all about +-- the character encodings being used for the input Wide_Character and +-- Wide_Wide_Character values, although some of the encoding methods (notably +-- JIS and EUC) have built in assumptions about the range of possible input +-- code values. Most often the input will be Unicode/ISO-10646 as specified by +-- the Ada RM, but this package does not make any assumptions about the +-- character coding, and in the case of UTF-8 all possible code values can be +-- encoded. See also the packages Ada.Wide_[Wide_]Characters.Unicode for +-- unicode specific functions. + +-- Note on brackets encoding (WCEM_Brackets). On input, upper half characters +-- can be represented as ["hh"] but the routines in this package will only use +-- brackets encodings for codes higher than 16#FF#, so upper half characters +-- will be output as single Character values. + +with System.WCh_Con; + +generic + Encoding_Method : System.WCh_Con.WC_Encoding_Method; + +package GNAT.Encode_String is + pragma Pure; + + function Encode_Wide_String (S : Wide_String) return String; + pragma Inline (Encode_Wide_String); + -- Encode the given Wide_String, returning a String encoded using the + -- given encoding method. Constraint_Error will be raised if the encoding + -- method cannot accommodate the input data. + + procedure Encode_Wide_String + (S : Wide_String; + Result : out String; + Length : out Natural); + -- Encode the given Wide_String, storing the encoded string in Result, + -- with Length being set to the length of the encoded string. The caller + -- must ensure that Result is long enough (see useful constants defined + -- in System.WCh_Con: WC_Longest_Sequence, WC_Longest_Sequences). If the + -- length of Result is insufficient Constraint_Error will be raised. + -- Constraint_Error will also be raised if the encoding method cannot + -- accommodate the input data. + + function Encode_Wide_Wide_String (S : Wide_Wide_String) return String; + pragma Inline (Encode_Wide_Wide_String); + -- Same as above function but for Wide_Wide_String input + + procedure Encode_Wide_Wide_String + (S : Wide_Wide_String; + Result : out String; + Length : out Natural); + -- Same as above procedure, but for Wide_Wide_String input + + procedure Encode_Wide_Character + (Char : Wide_Character; + Result : in out String; + Ptr : in out Natural); + pragma Inline (Encode_Wide_Character); + -- This is a lower level procedure that encodes the single character Char. + -- The output is stored in Result starting at Result (Ptr), and Ptr is + -- updated past the stored value. Constraint_Error is raised if Result + -- is not long enough to accommodate the result, or if the encoding method + -- specified does not accommodate the input character value, or if Ptr is + -- outside the bounds of the Result string. + + procedure Encode_Wide_Wide_Character + (Char : Wide_Wide_Character; + Result : in out String; + Ptr : in out Natural); + -- Same as above procedure but with Wide_Wide_Character input + +end GNAT.Encode_String; diff --git a/gcc/ada/libgnat/g-enutst.ads b/gcc/ada/libgnat/g-enutst.ads new file mode 100644 index 0000000..f173084 --- /dev/null +++ b/gcc/ada/libgnat/g-enutst.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E N C O D E _ U T F 8 _ S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 pre-instantiation of GNAT.Encode_String for the +-- common case of UTF-8 encoding. As noted in the documentation of that +-- package, this UTF-8 instantiation is efficient and specialized so that +-- it has only the code for the UTF-8 case. See g-encstr.ads for full +-- documentation on this package. + +with GNAT.Encode_String; + +with System.WCh_Con; + +package GNAT.Encode_UTF8_String is + new GNAT.Encode_String (System.WCh_Con.WCEM_UTF8); diff --git a/gcc/ada/libgnat/g-excact.adb b/gcc/ada/libgnat/g-excact.adb new file mode 100644 index 0000000..a0899fa --- /dev/null +++ b/gcc/ada/libgnat/g-excact.adb @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N _ A C T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; +with System; +with System.Soft_Links; use System.Soft_Links; +with System.Standard_Library; use System.Standard_Library; +with System.Exception_Table; use System.Exception_Table; + +package body GNAT.Exception_Actions is + + Global_Action : Exception_Action; + pragma Import (C, Global_Action, "__gnat_exception_actions_global_action"); + -- Imported from Ada.Exceptions. Any change in the external name needs to + -- be coordinated with a-except.adb + + Raise_Hook_Initialized : Boolean; + pragma Import + (Ada, Raise_Hook_Initialized, "__gnat_exception_actions_initialized"); + + function To_Raise_Action is new Ada.Unchecked_Conversion + (Exception_Action, Raise_Action); + + -- ??? Would be nice to have this in System.Standard_Library + function To_Data is new Ada.Unchecked_Conversion + (Exception_Id, Exception_Data_Ptr); + function To_Id is new Ada.Unchecked_Conversion + (Exception_Data_Ptr, Exception_Id); + + ---------------------------- + -- Register_Global_Action -- + ---------------------------- + + procedure Register_Global_Action (Action : Exception_Action) is + begin + Lock_Task.all; + Global_Action := Action; + Unlock_Task.all; + end Register_Global_Action; + + ------------------------ + -- Register_Id_Action -- + ------------------------ + + procedure Register_Id_Action + (Id : Exception_Id; + Action : Exception_Action) + is + begin + if Id = Null_Id then + raise Program_Error; + end if; + + Lock_Task.all; + To_Data (Id).Raise_Hook := To_Raise_Action (Action); + Raise_Hook_Initialized := True; + Unlock_Task.all; + end Register_Id_Action; + + --------------- + -- Core_Dump -- + --------------- + + procedure Core_Dump (Occurrence : Exception_Occurrence) is separate; + + ---------------- + -- Name_To_Id -- + ---------------- + + function Name_To_Id (Name : String) return Exception_Id is + begin + return To_Id (Internal_Exception (Name, Create_If_Not_Exist => False)); + end Name_To_Id; + + --------------------------------- + -- Registered_Exceptions_Count -- + --------------------------------- + + function Registered_Exceptions_Count return Natural renames + System.Exception_Table.Registered_Exceptions_Count; + + ------------------------------- + -- Get_Registered_Exceptions -- + ------------------------------- + -- This subprogram isn't an iterator to avoid concurrency problems, + -- since the exceptions are registered dynamically. Since we have to lock + -- the runtime while computing this array, this means that any callback in + -- an active iterator would be unable to access the runtime. + + procedure Get_Registered_Exceptions + (List : out Exception_Id_Array; + Last : out Integer) + is + Ids : Exception_Data_Array (List'Range); + begin + Get_Registered_Exceptions (Ids, Last); + + for L in List'First .. Last loop + List (L) := To_Id (Ids (L)); + end loop; + end Get_Registered_Exceptions; + +end GNAT.Exception_Actions; diff --git a/gcc/ada/libgnat/g-excact.ads b/gcc/ada/libgnat/g-excact.ads new file mode 100644 index 0000000..f8ea04d --- /dev/null +++ b/gcc/ada/libgnat/g-excact.ads @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N _ A C T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides support for callbacks on exceptions + +-- These callbacks are called immediately when either a specific exception, +-- or any exception, is raised, before any other actions taken by raise, in +-- particular before any unwinding of the stack occurs. + +-- Callbacks for specific exceptions are registered through calls to +-- Register_Id_Action. Here is an example of code that uses this package to +-- automatically core dump when the exception Constraint_Error is raised. + +-- Register_Id_Action (Constraint_Error'Identity, Core_Dump'Access); + +-- Subprograms are also provided to list the currently registered exceptions, +-- or to convert from a string to an exception id. + +-- This package can easily be extended, for instance to provide a callback +-- whenever an exception matching a regular expression is raised. The idea +-- is to register a global action, called whenever any exception is raised. +-- Dispatching can then be done directly in this global action callback. + +with Ada.Exceptions; use Ada.Exceptions; + +package GNAT.Exception_Actions is + + type Exception_Action is access + procedure (Occurrence : Exception_Occurrence); + -- General callback type whenever an exception is raised. The callback + -- procedure must not propagate an exception (execution of the program + -- is erroneous if such an exception is propagated). + + procedure Register_Global_Action (Action : Exception_Action); + -- Action will be called whenever an exception is raised. Only one such + -- action can be registered at any given time, and registering a new action + -- will override any previous action that might have been registered. + -- + -- Action is called before the exception is propagated to user's code. + -- If Action is null, this will in effect cancel all exception actions. + + procedure Register_Id_Action + (Id : Exception_Id; + Action : Exception_Action); + -- Action will be called whenever an exception of type Id is raised. Only + -- one such action can be registered for each exception id, and registering + -- a new action will override any previous action registered for this + -- Exception_Id. Program_Error is raised if Id is Null_Id. + + function Name_To_Id (Name : String) return Exception_Id; + -- Convert an exception name to an exception id. Null_Id is returned + -- if no such exception exists. Name must be an all upper-case string, + -- or the exception will not be found. The exception name must be fully + -- qualified (but not including Standard). It is not possible to convert + -- an exception that is declared within an unlabeled block. + -- + -- Note: All non-predefined exceptions will return Null_Id for programs + -- compiled with pragma Restriction (No_Exception_Registration) + + function Registered_Exceptions_Count return Natural; + -- Return the number of exceptions that have been registered so far. + -- Exceptions declared locally will not appear in this list until their + -- block has been executed at least once. + -- + -- Note: The count includes only predefined exceptions for programs + -- compiled with pragma Restrictions (No_Exception_Registration). + + type Exception_Id_Array is array (Natural range <>) of Exception_Id; + + procedure Get_Registered_Exceptions + (List : out Exception_Id_Array; + Last : out Integer); + -- Return the list of registered exceptions. + -- Last is the index in List of the last exception returned. + -- + -- An exception is registered the first time the block containing its + -- declaration is elaborated. Exceptions defined at library-level are + -- therefore immediately visible, whereas exceptions declared in local + -- blocks will not be visible until the block is executed at least once. + -- + -- Note: The list contains only the predefined exceptions if the program + -- is compiled with pragma Restrictions (No_Exception_Registration); + + procedure Core_Dump (Occurrence : Exception_Occurrence); + -- Dump memory (called a core dump in some systems) if supported by the + -- OS (most unix systems), and abort execution of the application. Under + -- Windows this procedure will not dump the memory, it will only abort + -- execution. + +end GNAT.Exception_Actions; diff --git a/gcc/ada/libgnat/g-except.ads b/gcc/ada/libgnat/g-except.ads new file mode 100644 index 0000000..69ae928 --- /dev/null +++ b/gcc/ada/libgnat/g-except.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface for raising predefined exceptions +-- with an exception message. It can be used from Pure units. + +-- There is no prohibition in Ada that prevents exceptions being raised +-- from within pure units. The raise statement is perfectly acceptable. + +-- However, it is not normally possible to raise an exception with a +-- message because the routine Ada.Exceptions.Raise_Exception is not in +-- a Pure unit. This is an annoying and unnecessary restriction and this +-- package allows for raising the standard predefined exceptions at least. + +package GNAT.Exceptions is + pragma Pure; + + type Exception_Type is limited null record; + -- Type used to specify which exception to raise + + -- Really Exception_Type is Exception_Id, but Exception_Id can't be + -- used directly since it is declared in the non-pure unit Ada.Exceptions, + + -- Exception_Id is in fact simply a pointer to the type Exception_Data + -- declared in System.Standard_Library (which is also non-pure). So what + -- we do is to define it here as a by reference type (any by reference + -- type would do), and then Import the definitions from Standard_Library. + -- Since this is a by reference type, these will be passed by reference, + -- which has the same effect as passing a pointer. + + -- This type is not private because keeping it by reference would require + -- defining it in a way (e.g. using a tagged type) that would drag in other + -- run-time files, which is unwanted in the case of e.g. Ravenscar where we + -- want to minimize the number of run-time files needed by default. + + CE : constant Exception_Type; -- Constraint_Error + PE : constant Exception_Type; -- Program_Error + SE : constant Exception_Type; -- Storage_Error + TE : constant Exception_Type; -- Tasking_Error + -- One of these constants is used in the call to specify the exception + + procedure Raise_Exception (E : Exception_Type; Message : String); + pragma Import (Ada, Raise_Exception, "__gnat_raise_exception"); + pragma No_Return (Raise_Exception); + -- Raise specified exception with specified message + +private + pragma Import (C, CE, "constraint_error"); + pragma Import (C, PE, "program_error"); + pragma Import (C, SE, "storage_error"); + pragma Import (C, TE, "tasking_error"); + -- References to the exception structures in the standard library + +end GNAT.Exceptions; diff --git a/gcc/ada/libgnat/g-exctra.adb b/gcc/ada/libgnat/g-exctra.adb new file mode 100644 index 0000000..ad30f4f --- /dev/null +++ b/gcc/ada/libgnat/g-exctra.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N _ T R A C E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-exctra.ads b/gcc/ada/libgnat/g-exctra.ads new file mode 100644 index 0000000..cc93fd8 --- /dev/null +++ b/gcc/ada/libgnat/g-exctra.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . E X C E P T I O N _ T R A C E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface allowing to control *automatic* output +-- to standard error upon exception occurrences (as opposed to explicit +-- generation of traceback information using System.Traceback). + +-- See file s-exctra.ads for full documentation of the interface + +with System.Exception_Traces; +package GNAT.Exception_Traces renames System.Exception_Traces; diff --git a/gcc/ada/libgnat/g-expect.adb b/gcc/ada/libgnat/g-expect.adb new file mode 100644 index 0000000..4435b6a --- /dev/null +++ b/gcc/ada/libgnat/g-expect.adb @@ -0,0 +1,1488 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.OS_Constants; use System.OS_Constants; +with Ada.Calendar; use Ada.Calendar; + +with GNAT.IO; use GNAT.IO; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Regpat; use GNAT.Regpat; + +with Ada.Unchecked_Deallocation; + +package body GNAT.Expect is + + type Array_Of_Pd is array (Positive range <>) of Process_Descriptor_Access; + + Expect_Process_Died : constant Expect_Match := -100; + Expect_Internal_Error : constant Expect_Match := -101; + -- Additional possible outputs of Expect_Internal. These are not visible in + -- the spec because the user will never see them. + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean); + -- Internal function used to read from the process Descriptor. + -- + -- Several outputs are possible: + -- Result=Expect_Timeout, if no output was available before the timeout + -- expired. + -- Result=Expect_Full_Buffer, if Full_Buffer is True and some characters + -- had to be discarded from the internal buffer of Descriptor. + -- Result=Express_Process_Died if one of the processes was terminated. + -- That process's Input_Fd is set to Invalid_FD + -- Result=Express_Internal_Error + -- Result=, indicates how many characters were added to the + -- internal buffer. These characters are from indexes + -- Descriptor.Buffer_Index - Result + 1 .. Descriptor.Buffer_Index + -- Process_Died is raised if the process is no longer valid. + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class); + -- Reinitialize the internal buffer. + -- The buffer is deleted up to the end of the last match. + + procedure Free is new Ada.Unchecked_Deallocation + (Pattern_Matcher, Pattern_Matcher_Access); + + procedure Free is new Ada.Unchecked_Deallocation + (Filter_List_Elem, Filter_List); + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type); + -- Call all the filters that have the appropriate type. + -- This function does nothing if the filters are locked + + ------------------------------ + -- Target dependent section -- + ------------------------------ + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2); + + procedure Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); + pragma Import (C, Kill, "__gnat_kill"); + -- if Close is set to 1 all OS resources used by the Pid must be freed + + function Create_Pipe (Pipe : not null access Pipe_Type) return Integer; + pragma Import (C, Create_Pipe, "__gnat_pipe"); + + function Poll + (Fds : System.Address; + Num_Fds : Integer; + Timeout : Integer; + Dead_Process : access Integer; + Is_Set : System.Address) return Integer; + pragma Import (C, Poll, "__gnat_expect_poll"); + -- Check whether there is any data waiting on the file descriptors + -- Fds, and wait if there is none, at most Timeout milliseconds + -- Returns -1 in case of error, 0 if the timeout expired before + -- data became available. + -- + -- Is_Set is an array of the same size as FDs and elements are set to 1 if + -- data is available for the corresponding File Descriptor, 0 otherwise. + -- + -- If a process dies, then Dead_Process is set to the index of the + -- corresponding file descriptor. + + function Waitpid (Pid : Process_Id) return Integer; + pragma Import (C, Waitpid, "__gnat_waitpid"); + -- Wait for a specific process id, and return its exit code + + --------- + -- "+" -- + --------- + + function "+" (S : String) return GNAT.OS_Lib.String_Access is + begin + return new String'(S); + end "+"; + + --------- + -- "+" -- + --------- + + function "+" + (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access + is + begin + return new GNAT.Regpat.Pattern_Matcher'(P); + end "+"; + + ---------------- + -- Add_Filter -- + ---------------- + + procedure Add_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function; + Filter_On : Filter_Type := Output; + User_Data : System.Address := System.Null_Address; + After : Boolean := False) + is + Current : Filter_List := Descriptor.Filters; + + begin + if After then + while Current /= null and then Current.Next /= null loop + Current := Current.Next; + end loop; + + if Current = null then + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + else + Current.Next := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => null); + end if; + + else + Descriptor.Filters := + new Filter_List_Elem' + (Filter => Filter, Filter_On => Filter_On, + User_Data => User_Data, Next => Descriptor.Filters); + end if; + end Add_Filter; + + ------------------ + -- Call_Filters -- + ------------------ + + procedure Call_Filters + (Pid : Process_Descriptor'Class; + Str : String; + Filter_On : Filter_Type) + is + Current_Filter : Filter_List; + + begin + if Pid.Filters_Lock = 0 then + Current_Filter := Pid.Filters; + + while Current_Filter /= null loop + if Current_Filter.Filter_On = Filter_On then + Current_Filter.Filter + (Pid, Str, Current_Filter.User_Data); + end if; + + Current_Filter := Current_Filter.Next; + end loop; + end if; + end Call_Filters; + + ----------- + -- Close -- + ----------- + + procedure Close + (Descriptor : in out Process_Descriptor; + Status : out Integer) + is + Current_Filter : Filter_List; + Next_Filter : Filter_List; + + begin + if Descriptor.Input_Fd /= Invalid_FD then + Close (Descriptor.Input_Fd); + end if; + + if Descriptor.Error_Fd /= Descriptor.Output_Fd then + Close (Descriptor.Error_Fd); + end if; + + Close (Descriptor.Output_Fd); + + -- ??? Should have timeouts for different signals + + if Descriptor.Pid > 0 then -- see comment in Send_Signal + Kill (Descriptor.Pid, Sig_Num => 9, Close => 0); + end if; + + GNAT.OS_Lib.Free (Descriptor.Buffer); + Descriptor.Buffer_Size := 0; + + Current_Filter := Descriptor.Filters; + + while Current_Filter /= null loop + Next_Filter := Current_Filter.Next; + Free (Current_Filter); + Current_Filter := Next_Filter; + end loop; + + Descriptor.Filters := null; + + -- Check process id (see comment in Send_Signal) + + if Descriptor.Pid > 0 then + Status := Waitpid (Descriptor.Pid); + else + raise Invalid_Process; + end if; + end Close; + + procedure Close (Descriptor : in out Process_Descriptor) is + Status : Integer; + pragma Unreferenced (Status); + begin + Close (Descriptor, Status); + end Close; + + ------------ + -- Expect -- + ------------ + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + begin + if Regexp = "" then + Expect (Descriptor, Result, Never_Match, Timeout, Full_Buffer); + else + Expect (Descriptor, Result, Compile (Regexp), Timeout, Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + begin + pragma Assert (Matched'First = 0); + if Regexp = "" then + Expect + (Descriptor, Result, Never_Match, Matched, Timeout, Full_Buffer); + else + Expect + (Descriptor, Result, Compile (Regexp), Matched, Timeout, + Full_Buffer); + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + pragma Warnings (Off, Matched); + begin + Expect (Descriptor, Result, Regexp, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + Try_Until : constant Time := Clock + Duration (Timeout) / 1000.0; + Timeout_Tmp : Integer := Timeout; + + begin + pragma Assert (Matched'First = 0); + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Descriptor.Buffer_Index >= 1 and then Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + + -- Else try to read new input + + Expect_Internal (Descriptors, N, Timeout_Tmp, Full_Buffer); + + case N is + when Expect_Internal_Error + | Expect_Process_Died + => + raise Process_Died; + + when Expect_Full_Buffer + | Expect_Timeout + => + Result := N; + return; + + when others => + null; -- See below + end case; + + -- Calculate the timeout for the next turn + + -- Note that Timeout is, from the caller's perspective, the maximum + -- time until a match, not the maximum time until some output is + -- read, and thus cannot be reused as is for Expect_Internal. + + if Timeout /= -1 then + Timeout_Tmp := Integer (Try_Until - Clock) * 1000; + + if Timeout_Tmp < 0 then + Result := Expect_Timeout; + exit; + end if; + end if; + end loop; + + -- Even if we had the general timeout above, we have to test that the + -- last test we read from the external process didn't match. + + Match + (Regexp, Descriptor.Buffer (1 .. Descriptor.Buffer_Index), Matched); + + if Matched (0).First /= 0 then + Result := 1; + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + + Matched : GNAT.Regpat.Match_Array (0 .. 0); + pragma Warnings (Off, Matched); + + begin + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + pragma Warnings (Off, Matched); + begin + Expect (Descriptor, Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + Matched : GNAT.Regpat.Match_Array (0 .. 0); + pragma Warnings (Off, Matched); + begin + Expect (Result, Regexps, Matched, Timeout, Full_Buffer); + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + Patterns : Compiled_Regexp_Array (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Regexps'Range loop + Patterns (J) := new Pattern_Matcher'(Compile (Regexps (J).all)); + end loop; + + Expect (Descriptor, Result, Patterns, Matched, Timeout, Full_Buffer); + + for J in Regexps'Range loop + Free (Patterns (J)); + end loop; + end Expect; + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + begin + pragma Assert (Matched'First = 0); + + Reinitialize_Buffer (Descriptor); + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + if Descriptor.Buffer /= null then + for J in Regexps'Range loop + Match + (Regexps (J).all, + Descriptor.Buffer (1 .. Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Descriptor.Last_Match_Start := Matched (0).First; + Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end loop; + end if; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + case N is + when Expect_Internal_Error + | Expect_Process_Died + => + raise Process_Died; + + when Expect_Full_Buffer + | Expect_Timeout + => + Result := N; + return; + + when others => + null; -- Continue + end case; + end loop; + end Expect; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False) + is + N : Expect_Match; + Descriptors : Array_Of_Pd (Regexps'Range); + + begin + pragma Assert (Matched'First = 0); + + for J in Descriptors'Range loop + Descriptors (J) := Regexps (J).Descriptor; + + if Descriptors (J) /= null then + Reinitialize_Buffer (Regexps (J).Descriptor.all); + end if; + end loop; + + loop + -- First, test if what is already in the buffer matches (This is + -- required if this package is used in multi-task mode, since one of + -- the tasks might have added something in the buffer, and we don't + -- want other tasks to wait for new input to be available before + -- checking the regexps). + + for J in Regexps'Range loop + if Regexps (J).Regexp /= null + and then Regexps (J).Descriptor /= null + then + Match (Regexps (J).Regexp.all, + Regexps (J).Descriptor.Buffer + (1 .. Regexps (J).Descriptor.Buffer_Index), + Matched); + + if Matched (0) /= No_Match then + Result := Expect_Match (J); + Regexps (J).Descriptor.Last_Match_Start := Matched (0).First; + Regexps (J).Descriptor.Last_Match_End := Matched (0).Last; + return; + end if; + end if; + end loop; + + Expect_Internal (Descriptors, N, Timeout, Full_Buffer); + + case N is + when Expect_Internal_Error + | Expect_Process_Died + => + raise Process_Died; + + when Expect_Full_Buffer + | Expect_Timeout + => + Result := N; + return; + + when others => + null; -- Continue + end case; + end loop; + end Expect; + + --------------------- + -- Expect_Internal -- + --------------------- + + procedure Expect_Internal + (Descriptors : in out Array_Of_Pd; + Result : out Expect_Match; + Timeout : Integer; + Full_Buffer : Boolean) + is + Num_Descriptors : Integer; + Buffer_Size : Integer := 0; + + N : Integer; + + type File_Descriptor_Array is + array (0 .. Descriptors'Length - 1) of File_Descriptor; + Fds : aliased File_Descriptor_Array; + Fds_Count : Natural := 0; + + Fds_To_Descriptor : array (Fds'Range) of Integer; + -- Maps file descriptor entries from Fds to entries in Descriptors. + -- They do not have the same index when entries in Descriptors are null. + + type Integer_Array is array (Fds'Range) of Integer; + Is_Set : aliased Integer_Array; + + begin + for J in Descriptors'Range loop + if Descriptors (J) /= null then + Fds (Fds'First + Fds_Count) := Descriptors (J).Output_Fd; + Fds_To_Descriptor (Fds'First + Fds_Count) := J; + Fds_Count := Fds_Count + 1; + + if Descriptors (J).Buffer_Size = 0 then + Buffer_Size := Integer'Max (Buffer_Size, 4096); + else + Buffer_Size := + Integer'Max (Buffer_Size, Descriptors (J).Buffer_Size); + end if; + end if; + end loop; + + declare + Buffer : aliased String (1 .. Buffer_Size); + -- Buffer used for input. This is allocated only once, not for + -- every iteration of the loop + + D : aliased Integer; + -- Index in Descriptors + + begin + -- Loop until we match or we have a timeout + + loop + Num_Descriptors := + Poll (Fds'Address, Fds_Count, Timeout, D'Access, Is_Set'Address); + + case Num_Descriptors is + + -- Error? + + when -1 => + Result := Expect_Internal_Error; + + if D /= 0 then + Close (Descriptors (D).Input_Fd); + Descriptors (D).Input_Fd := Invalid_FD; + end if; + + return; + + -- Timeout? + + when 0 => + Result := Expect_Timeout; + return; + + -- Some input + + when others => + for F in Fds'Range loop + if Is_Set (F) = 1 then + D := Fds_To_Descriptor (F); + + Buffer_Size := Descriptors (D).Buffer_Size; + + if Buffer_Size = 0 then + Buffer_Size := 4096; + end if; + + N := Read (Descriptors (D).Output_Fd, Buffer'Address, + Buffer_Size); + + -- Error or End of file + + if N <= 0 then + -- ??? Note that ddd tries again up to three times + -- in that case. See LiterateA.C:174 + + Close (Descriptors (D).Input_Fd); + Descriptors (D).Input_Fd := Invalid_FD; + Result := Expect_Process_Died; + return; + + else + -- If there is no limit to the buffer size + + if Descriptors (D).Buffer_Size = 0 then + declare + Tmp : String_Access := Descriptors (D).Buffer; + + begin + if Tmp /= null then + Descriptors (D).Buffer := + new String (1 .. Tmp'Length + N); + Descriptors (D).Buffer (1 .. Tmp'Length) := + Tmp.all; + Descriptors (D).Buffer + (Tmp'Length + 1 .. Tmp'Length + N) := + Buffer (1 .. N); + Free (Tmp); + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer'Last; + + else + Descriptors (D).Buffer := + new String (1 .. N); + Descriptors (D).Buffer.all := + Buffer (1 .. N); + Descriptors (D).Buffer_Index := N; + end if; + end; + + else + -- Add what we read to the buffer + + if Descriptors (D).Buffer_Index + N > + Descriptors (D).Buffer_Size + then + -- If the user wants to know when we have + -- read more than the buffer can contain. + + if Full_Buffer then + Result := Expect_Full_Buffer; + return; + end if; + + -- Keep as much as possible from the buffer, + -- and forget old characters. + + Descriptors (D).Buffer + (1 .. Descriptors (D).Buffer_Size - N) := + Descriptors (D).Buffer + (N - Descriptors (D).Buffer_Size + + Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index); + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Size - N; + end if; + + -- Keep what we read in the buffer + + Descriptors (D).Buffer + (Descriptors (D).Buffer_Index + 1 .. + Descriptors (D).Buffer_Index + N) := + Buffer (1 .. N); + Descriptors (D).Buffer_Index := + Descriptors (D).Buffer_Index + N; + end if; + + -- Call each of the output filter with what we + -- read. + + Call_Filters + (Descriptors (D).all, Buffer (1 .. N), Output); + + Result := Expect_Match (D); + return; + end if; + end if; + end loop; + end case; + end loop; + end; + end Expect_Internal; + + ---------------- + -- Expect_Out -- + ---------------- + + function Expect_Out (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer (1 .. Descriptor.Last_Match_End); + end Expect_Out; + + ---------------------- + -- Expect_Out_Match -- + ---------------------- + + function Expect_Out_Match (Descriptor : Process_Descriptor) return String is + begin + return Descriptor.Buffer + (Descriptor.Last_Match_Start .. Descriptor.Last_Match_End); + end Expect_Out_Match; + + ------------------------ + -- First_Dead_Process -- + ------------------------ + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural is + begin + for R in Regexp'Range loop + if Regexp (R).Descriptor /= null + and then Regexp (R).Descriptor.Input_Fd = GNAT.OS_Lib.Invalid_FD + then + return R; + end if; + end loop; + + return 0; + end First_Dead_Process; + + ----------- + -- Flush -- + ----------- + + procedure Flush + (Descriptor : in out Process_Descriptor; + Timeout : Integer := 0) + is + Buffer_Size : constant Integer := 8192; + Num_Descriptors : Integer; + N : aliased Integer; + Is_Set : aliased Integer; + Buffer : aliased String (1 .. Buffer_Size); + + begin + -- Empty the current buffer + + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + Reinitialize_Buffer (Descriptor); + + -- Read everything from the process to flush its output + + loop + Num_Descriptors := + Poll (Descriptor.Output_Fd'Address, + 1, + Timeout, + N'Access, + Is_Set'Address); + + case Num_Descriptors is + + -- Error ? + + when -1 => + raise Process_Died; + + -- Timeout => End of flush + + when 0 => + return; + + -- Some input + + when others => + if Is_Set = 1 then + N := Read (Descriptor.Output_Fd, Buffer'Address, + Buffer_Size); + + if N = -1 then + raise Process_Died; + elsif N = 0 then + return; + end if; + end if; + end case; + end loop; + end Flush; + + ---------- + -- Free -- + ---------- + + procedure Free (Regexp : in out Multiprocess_Regexp) is + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Process_Descriptor'Class, Process_Descriptor_Access); + begin + Unchecked_Free (Regexp.Descriptor); + Free (Regexp.Regexp); + end Free; + + ------------------------ + -- Get_Command_Output -- + ------------------------ + + function Get_Command_Output + (Command : String; + Arguments : GNAT.OS_Lib.Argument_List; + Input : String; + Status : not null access Integer; + Err_To_Out : Boolean := False) return String + is + use GNAT.Expect; + + Process : Process_Descriptor; + + Output : String_Access := new String (1 .. 1024); + -- Buffer used to accumulate standard output from the launched + -- command, expanded as necessary during execution. + + Last : Integer := 0; + -- Index of the last used character within Output + + begin + Non_Blocking_Spawn + (Process, Command, Arguments, Err_To_Out => Err_To_Out, + Buffer_Size => 0); + + if Input'Length > 0 then + Send (Process, Input); + end if; + + Close (Process.Input_Fd); + Process.Input_Fd := Invalid_FD; + + declare + Result : Expect_Match; + pragma Unreferenced (Result); + + begin + -- This loop runs until the call to Expect raises Process_Died + + loop + Expect (Process, Result, ".+", Timeout => -1); + + declare + NOutput : String_Access; + S : constant String := Expect_Out (Process); + pragma Assert (S'Length > 0); + + begin + -- Expand buffer if we need more space. Note here that we add + -- S'Length to ensure that S will fit in the new buffer size. + + if Last + S'Length > Output'Last then + NOutput := new String (1 .. 2 * Output'Last + S'Length); + NOutput (Output'Range) := Output.all; + Free (Output); + + -- Here if current buffer size is OK + + else + NOutput := Output; + end if; + + NOutput (Last + 1 .. Last + S'Length) := S; + Last := Last + S'Length; + Output := NOutput; + end; + end loop; + + exception + when Process_Died => + Close (Process, Status.all); + end; + + if Last = 0 then + Free (Output); + return ""; + end if; + + declare + S : constant String := Output (1 .. Last); + begin + Free (Output); + return S; + end; + end Get_Command_Output; + + ------------------ + -- Get_Error_Fd -- + ------------------ + + function Get_Error_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Error_Fd; + end Get_Error_Fd; + + ------------------ + -- Get_Input_Fd -- + ------------------ + + function Get_Input_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Input_Fd; + end Get_Input_Fd; + + ------------------- + -- Get_Output_Fd -- + ------------------- + + function Get_Output_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor + is + begin + return Descriptor.Output_Fd; + end Get_Output_Fd; + + ------------- + -- Get_Pid -- + ------------- + + function Get_Pid + (Descriptor : Process_Descriptor) return Process_Id + is + begin + return Descriptor.Pid; + end Get_Pid; + + ----------------- + -- Has_Process -- + ----------------- + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean is + begin + return Regexp /= (Regexp'Range => (null, null)); + end Has_Process; + + --------------- + -- Interrupt -- + --------------- + + procedure Interrupt (Descriptor : in out Process_Descriptor) is + SIGINT : constant := 2; + begin + Send_Signal (Descriptor, SIGINT); + end Interrupt; + + ------------------ + -- Lock_Filters -- + ------------------ + + procedure Lock_Filters (Descriptor : in out Process_Descriptor) is + begin + Descriptor.Filters_Lock := Descriptor.Filters_Lock + 1; + end Lock_Filters; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + procedure Non_Blocking_Spawn + (Descriptor : out Process_Descriptor'Class; + Command : String; + Args : GNAT.OS_Lib.Argument_List; + Buffer_Size : Natural := 4096; + Err_To_Out : Boolean := False) + is + function Fork return Process_Id; + pragma Import (C, Fork, "__gnat_expect_fork"); + -- Starts a new process if possible. See the Unix command fork for more + -- information. On systems that do not support this capability (such as + -- Windows...), this command does nothing, and Fork will return + -- Null_Pid. + + Pipe1, Pipe2, Pipe3 : aliased Pipe_Type; + + Arg : String_Access; + Arg_List : String_List (1 .. Args'Length + 2); + C_Arg_List : aliased array (1 .. Args'Length + 2) of System.Address; + + Command_With_Path : String_Access; + + begin + Command_With_Path := Locate_Exec_On_Path (Command); + + if Command_With_Path = null then + raise Invalid_Process; + end if; + + -- Create the rest of the pipes once we know we will be able to + -- execute the process. + + Set_Up_Communications + (Descriptor, Err_To_Out, Pipe1'Access, Pipe2'Access, Pipe3'Access); + + -- Fork a new process + + Descriptor.Pid := Fork; + + -- Are we now in the child (or, for Windows, still in the common + -- process). + + if Descriptor.Pid = Null_Pid then + -- Prepare an array of arguments to pass to C + + Arg := new String (1 .. Command_With_Path'Length + 1); + Arg (1 .. Command_With_Path'Length) := Command_With_Path.all; + Arg (Arg'Last) := ASCII.NUL; + Arg_List (1) := Arg; + + for J in Args'Range loop + Arg := new String (1 .. Args (J)'Length + 1); + Arg (1 .. Args (J)'Length) := Args (J).all; + Arg (Arg'Last) := ASCII.NUL; + Arg_List (J + 2 - Args'First) := Arg.all'Access; + end loop; + + Arg_List (Arg_List'Last) := null; + + -- Make sure all arguments are compatible with OS conventions + + Normalize_Arguments (Arg_List); + + -- Prepare low-level argument list from the normalized arguments + + for K in Arg_List'Range loop + C_Arg_List (K) := + (if Arg_List (K) /= null + then Arg_List (K).all'Address + else System.Null_Address); + end loop; + + -- This does not return on Unix systems + + Set_Up_Child_Communications + (Descriptor, Pipe1, Pipe2, Pipe3, Command_With_Path.all, + C_Arg_List'Address); + end if; + + Free (Command_With_Path); + + -- Did we have an error when spawning the child ? + + if Descriptor.Pid < Null_Pid then + raise Invalid_Process; + else + -- We are now in the parent process + + Set_Up_Parent_Communications (Descriptor, Pipe1, Pipe2, Pipe3); + end if; + + -- Create the buffer + + Descriptor.Buffer_Size := Buffer_Size; + + if Buffer_Size /= 0 then + Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); + end if; + + -- Initialize the filters + + Descriptor.Filters := null; + end Non_Blocking_Spawn; + + ------------------------- + -- Reinitialize_Buffer -- + ------------------------- + + procedure Reinitialize_Buffer + (Descriptor : in out Process_Descriptor'Class) + is + begin + if Descriptor.Buffer_Size = 0 then + declare + Tmp : String_Access := Descriptor.Buffer; + + begin + Descriptor.Buffer := + new String + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End); + + if Tmp /= null then + Descriptor.Buffer.all := Tmp + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + Free (Tmp); + end if; + end; + + Descriptor.Buffer_Index := Descriptor.Buffer'Last; + + else + Descriptor.Buffer + (1 .. Descriptor.Buffer_Index - Descriptor.Last_Match_End) := + Descriptor.Buffer + (Descriptor.Last_Match_End + 1 .. Descriptor.Buffer_Index); + + if Descriptor.Buffer_Index > Descriptor.Last_Match_End then + Descriptor.Buffer_Index := + Descriptor.Buffer_Index - Descriptor.Last_Match_End; + else + Descriptor.Buffer_Index := 0; + end if; + end if; + + Descriptor.Last_Match_Start := 0; + Descriptor.Last_Match_End := 0; + end Reinitialize_Buffer; + + ------------------- + -- Remove_Filter -- + ------------------- + + procedure Remove_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function) + is + Previous : Filter_List := null; + Current : Filter_List := Descriptor.Filters; + + begin + while Current /= null loop + if Current.Filter = Filter then + if Previous = null then + Descriptor.Filters := Current.Next; + else + Previous.Next := Current.Next; + end if; + end if; + + Previous := Current; + Current := Current.Next; + end loop; + end Remove_Filter; + + ---------- + -- Send -- + ---------- + + procedure Send + (Descriptor : in out Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False) + is + Line_Feed : aliased constant String := (1 .. 1 => ASCII.LF); + Descriptors : Array_Of_Pd := (1 => Descriptor'Unrestricted_Access); + + Result : Expect_Match; + Discard : Natural; + pragma Warnings (Off, Result); + pragma Warnings (Off, Discard); + + begin + if Empty_Buffer then + + -- Force a read on the process if there is anything waiting + + Expect_Internal + (Descriptors, Result, Timeout => 0, Full_Buffer => False); + + if Result = Expect_Internal_Error + or else Result = Expect_Process_Died + then + raise Process_Died; + end if; + + Descriptor.Last_Match_End := Descriptor.Buffer_Index; + + -- Empty the buffer + + Reinitialize_Buffer (Descriptor); + end if; + + Call_Filters (Descriptor, Str, Input); + Discard := + Write (Descriptor.Input_Fd, Str'Address, Str'Last - Str'First + 1); + + if Add_LF then + Call_Filters (Descriptor, Line_Feed, Input); + Discard := + Write (Descriptor.Input_Fd, Line_Feed'Address, 1); + end if; + end Send; + + ----------------- + -- Send_Signal -- + ----------------- + + procedure Send_Signal + (Descriptor : Process_Descriptor; + Signal : Integer) + is + begin + -- A nonpositive process id passed to kill has special meanings. For + -- example, -1 means kill all processes in sight, including self, in + -- POSIX and Windows (and something slightly different in Linux). See + -- man pages for details. In any case, we don't want to do that. Note + -- that Descriptor.Pid will be -1 if the process was not successfully + -- started; we don't want to kill ourself in that case. + + if Descriptor.Pid > 0 then + Kill (Descriptor.Pid, Signal, Close => 1); + -- ??? Need to check process status here + else + raise Invalid_Process; + end if; + end Send_Signal; + + --------------------------------- + -- Set_Up_Child_Communications -- + --------------------------------- + + procedure Set_Up_Child_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : String; + Args : System.Address) + is + pragma Warnings (Off, Pid); + pragma Warnings (Off, Pipe1); + pragma Warnings (Off, Pipe2); + pragma Warnings (Off, Pipe3); + + Input : File_Descriptor; + Output : File_Descriptor; + Error : File_Descriptor; + + No_Fork_On_Target : constant Boolean := Target_OS = Windows; + + begin + if No_Fork_On_Target then + + -- Since Windows does not have a separate fork/exec, we need to + -- perform the following actions: + + -- - save stdin, stdout, stderr + -- - replace them by our pipes + -- - create the child with process handle inheritance + -- - revert to the previous stdin, stdout and stderr. + + Input := Dup (GNAT.OS_Lib.Standin); + Output := Dup (GNAT.OS_Lib.Standout); + Error := Dup (GNAT.OS_Lib.Standerr); + end if; + + -- Since we are still called from the parent process, there is no way + -- currently we can cleanly close the unneeded ends of the pipes, but + -- this doesn't really matter. + + -- We could close Pipe1.Output, Pipe2.Input, Pipe3.Input + + Dup2 (Pipe1.Input, GNAT.OS_Lib.Standin); + Dup2 (Pipe2.Output, GNAT.OS_Lib.Standout); + Dup2 (Pipe3.Output, GNAT.OS_Lib.Standerr); + + Portable_Execvp (Pid.Pid'Access, Cmd & ASCII.NUL, Args); + + -- The following lines are only required for Windows systems and will + -- not be executed on Unix systems, but we use the same condition as + -- above to avoid warnings on uninitialized variables on Unix systems. + -- We are now in the parent process. + + if No_Fork_On_Target then + + -- Restore the old descriptors + + Dup2 (Input, GNAT.OS_Lib.Standin); + Dup2 (Output, GNAT.OS_Lib.Standout); + Dup2 (Error, GNAT.OS_Lib.Standerr); + Close (Input); + Close (Output); + Close (Error); + end if; + end Set_Up_Child_Communications; + + --------------------------- + -- Set_Up_Communications -- + --------------------------- + + procedure Set_Up_Communications + (Pid : in out Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : not null access Pipe_Type; + Pipe2 : not null access Pipe_Type; + Pipe3 : not null access Pipe_Type) + is + Status : Boolean; + pragma Unreferenced (Status); + + begin + -- Create the pipes + + if Create_Pipe (Pipe1) /= 0 then + return; + end if; + + if Create_Pipe (Pipe2) /= 0 then + Close (Pipe1.Input); + Close (Pipe1.Output); + return; + end if; + + -- Record the 'parent' end of the two pipes in Pid: + -- Child stdin is connected to the 'write' end of Pipe1; + -- Child stdout is connected to the 'read' end of Pipe2. + -- We do not want these descriptors to remain open in the child + -- process, so we mark them close-on-exec/non-inheritable. + + Pid.Input_Fd := Pipe1.Output; + Set_Close_On_Exec (Pipe1.Output, True, Status); + Pid.Output_Fd := Pipe2.Input; + Set_Close_On_Exec (Pipe2.Input, True, Status); + + if Err_To_Out then + + -- Reuse the standard output pipe for standard error + + Pipe3.all := Pipe2.all; + + else + -- Create a separate pipe for standard error + + if Create_Pipe (Pipe3) /= 0 then + Pipe3.all := Pipe2.all; + end if; + end if; + + -- As above, record the proper fd for the child's standard error stream + + Pid.Error_Fd := Pipe3.Input; + Set_Close_On_Exec (Pipe3.Input, True, Status); + end Set_Up_Communications; + + ---------------------------------- + -- Set_Up_Parent_Communications -- + ---------------------------------- + + procedure Set_Up_Parent_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type) + is + pragma Warnings (Off, Pid); + pragma Warnings (Off, Pipe1); + pragma Warnings (Off, Pipe2); + pragma Warnings (Off, Pipe3); + + begin + Close (Pipe1.Input); + Close (Pipe2.Output); + + if Pipe3.Output /= Pipe2.Output then + Close (Pipe3.Output); + end if; + end Set_Up_Parent_Communications; + + ------------------ + -- Trace_Filter -- + ------------------ + + procedure Trace_Filter + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address) + is + pragma Warnings (Off, Descriptor); + pragma Warnings (Off, User_Data); + begin + GNAT.IO.Put (Str); + end Trace_Filter; + + -------------------- + -- Unlock_Filters -- + -------------------- + + procedure Unlock_Filters (Descriptor : in out Process_Descriptor) is + begin + if Descriptor.Filters_Lock > 0 then + Descriptor.Filters_Lock := Descriptor.Filters_Lock - 1; + end if; + end Unlock_Filters; + +end GNAT.Expect; diff --git a/gcc/ada/libgnat/g-expect.ads b/gcc/ada/libgnat/g-expect.ads new file mode 100644 index 0000000..0c05867 --- /dev/null +++ b/gcc/ada/libgnat/g-expect.ads @@ -0,0 +1,647 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Currently this package is implemented on all native GNAT ports. It is not +-- yet implemented for any of the cross-ports (e.g. it is not available for +-- VxWorks or LynxOS). + +-- ----------- +-- -- Usage -- +-- ----------- + +-- This package provides a set of subprograms similar to what is available +-- with the standard Tcl Expect tool. + +-- It allows you to easily spawn and communicate with an external process. +-- You can send commands or inputs to the process, and compare the output +-- with some expected regular expression. + +-- Usage example: + +-- Non_Blocking_Spawn +-- (Fd, "ftp", +-- (1 => new String' ("machine@domain"))); +-- Timeout := 10_000; -- 10 seconds +-- Expect (Fd, Result, Regexp_Array'(+"\(user\)", +"\(passwd\)"), +-- Timeout); +-- case Result is +-- when 1 => Send (Fd, "my_name"); -- matched "user" +-- when 2 => Send (Fd, "my_passwd"); -- matched "passwd" +-- when Expect_Timeout => null; -- timeout +-- when others => null; +-- end case; +-- Close (Fd); + +-- You can also combine multiple regular expressions together, and get the +-- specific string matching a parenthesis pair by doing something like this: +-- If you expect either "lang=optional ada" or "lang=ada" from the external +-- process, you can group the two together, which is more efficient, and +-- simply get the name of the language by doing: + +-- declare +-- Matched : Match_Array (0 .. 2); +-- begin +-- Expect (Fd, Result, "lang=(optional)? ([a-z]+)", Matched); +-- Put_Line ("Seen: " & +-- Expect_Out (Fd) (Matched (2).First .. Matched (2).Last)); +-- end; + +-- Alternatively, you might choose to use a lower-level interface to the +-- processes, where you can give your own input and output filters every +-- time characters are read from or written to the process. + +-- procedure My_Filter +-- (Descriptor : Process_Descriptor'Class; +-- Str : String; +-- User_Data : System.Address) +-- is +-- begin +-- Put_Line (Str); +-- end; + +-- Non_Blocking_Spawn +-- (Fd, "tail", +-- (new String' ("-f"), new String' ("a_file"))); +-- Add_Filter (Fd, My_Filter'Access, Output); +-- Expect (Fd, Result, "", 0); -- wait forever + +-- The above example should probably be run in a separate task, since it is +-- blocking on the call to Expect. + +-- Both examples can be combined, for instance to systematically print the +-- output seen by expect, even though you still want to let Expect do the +-- filtering. You can use the Trace_Filter subprogram for such a filter. + +-- If you want to get the output of a simple command, and ignore any previous +-- existing output, it is recommended to do something like: + +-- Expect (Fd, Result, ".*", Timeout => 0); +-- -- Empty the buffer, by matching everything (after checking +-- -- if there was any input). + +-- Send (Fd, "command"); +-- Expect (Fd, Result, ".."); -- match only on the output of command + +-- ----------------- +-- -- Task Safety -- +-- ----------------- + +-- This package is not task-safe: there should not be concurrent calls to the +-- functions defined in this package. In other words, separate tasks must not +-- access the facilities of this package without synchronization that +-- serializes access. + +with System; +with GNAT.OS_Lib; +with GNAT.Regpat; + +package GNAT.Expect is + + type Process_Id is new Integer; + Invalid_Pid : constant Process_Id := -1; + Null_Pid : constant Process_Id := 0; + + type Filter_Type is (Output, Input, Died); + -- The signals that are emitted by the Process_Descriptor upon state change + -- in the child. One can connect to any of these signals through the + -- Add_Filter subprograms. + -- + -- Output => Every time new characters are read from the process + -- associated with Descriptor, the filter is called with + -- these new characters in the argument. + -- + -- Note that output is generated only when the program is + -- blocked in a call to Expect. + -- + -- Input => Every time new characters are written to the process + -- associated with Descriptor, the filter is called with + -- these new characters in the argument. + -- Note that input is generated only by calls to Send. + -- + -- Died => The child process has died, or was explicitly killed + + type Process_Descriptor is tagged private; + -- Contains all the components needed to describe a process handled + -- in this package, including a process identifier, file descriptors + -- associated with the standard input, output and error, and the buffer + -- needed to handle the expect calls. + + type Process_Descriptor_Access is access Process_Descriptor'Class; + + ------------------------ + -- Spawning a process -- + ------------------------ + + procedure Non_Blocking_Spawn + (Descriptor : out Process_Descriptor'Class; + Command : String; + Args : GNAT.OS_Lib.Argument_List; + Buffer_Size : Natural := 4096; + Err_To_Out : Boolean := False); + -- This call spawns a new process and allows sending commands to + -- the process and/or automatic parsing of the output. + -- + -- The expect buffer associated with that process can contain at most + -- Buffer_Size characters. Older characters are simply discarded when this + -- buffer is full. Beware that if the buffer is too big, this could slow + -- down the Expect calls if the output not is matched, since Expect has to + -- match all the regexp against all the characters in the buffer. If + -- Buffer_Size is 0, there is no limit (i.e. all the characters are kept + -- till Expect matches), but this is slower. + -- + -- If Err_To_Out is True, then the standard error of the spawned process is + -- connected to the standard output. This is the only way to get the Expect + -- subprograms to also match on output on standard error. + -- + -- Invalid_Process is raised if the process could not be spawned. + -- + -- For information about spawning processes from tasking programs, see the + -- "NOTE: Spawn in tasking programs" in System.OS_Lib (s-os_lib.ads). + + procedure Close (Descriptor : in out Process_Descriptor); + -- Terminate the process and close the pipes to it. It implicitly does the + -- 'wait' command required to clean up the process table. This also frees + -- the buffer associated with the process id. Raise Invalid_Process if the + -- process id is invalid. + + procedure Close + (Descriptor : in out Process_Descriptor; + Status : out Integer); + -- Same as above, but also returns the exit status of the process, as set + -- for example by the procedure GNAT.OS_Lib.OS_Exit. + + procedure Send_Signal + (Descriptor : Process_Descriptor; + Signal : Integer); + -- Send a given signal to the process. Raise Invalid_Process if the process + -- id is invalid. + + procedure Interrupt (Descriptor : in out Process_Descriptor); + -- Interrupt the process (the equivalent of Ctrl-C on unix and windows) + -- and call close if the process dies. + + function Get_Input_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor; + -- Return the input file descriptor associated with Descriptor + + function Get_Output_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor; + -- Return the output file descriptor associated with Descriptor + + function Get_Error_Fd + (Descriptor : Process_Descriptor) return GNAT.OS_Lib.File_Descriptor; + -- Return the error output file descriptor associated with Descriptor + + function Get_Pid + (Descriptor : Process_Descriptor) return Process_Id; + -- Return the process id associated with a given process descriptor + + function Get_Command_Output + (Command : String; + Arguments : GNAT.OS_Lib.Argument_List; + Input : String; + Status : not null access Integer; + Err_To_Out : Boolean := False) return String; + -- Execute Command with the specified Arguments and Input, and return the + -- generated standard output data as a single string. If Err_To_Out is + -- True, generated standard error output is included as well. On return, + -- Status is set to the command's exit status. + + -------------------- + -- Adding filters -- + -------------------- + + -- This is a rather low-level interface to subprocesses, since basically + -- the filtering is left entirely to the user. See the Expect subprograms + -- below for higher level functions. + + type Filter_Function is access + procedure + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address); + -- Function called every time new characters are read from or written to + -- the process. + -- + -- Str is a string of all these characters. + -- + -- User_Data, if specified, is user specific data that will be passed to + -- the filter. Note that no checks are done on this parameter, so it should + -- be used with caution. + + procedure Add_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function; + Filter_On : Filter_Type := Output; + User_Data : System.Address := System.Null_Address; + After : Boolean := False); + -- Add a new filter for one of the filter types. This filter will be run + -- before all the existing filters, unless After is set True, in which case + -- it will be run after existing filters. User_Data is passed as is to the + -- filter procedure. + + procedure Remove_Filter + (Descriptor : in out Process_Descriptor; + Filter : Filter_Function); + -- Remove a filter from the list of filters (whatever the type of the + -- filter). + + procedure Trace_Filter + (Descriptor : Process_Descriptor'Class; + Str : String; + User_Data : System.Address := System.Null_Address); + -- Function that can be used as a filter and that simply outputs Str on + -- Standard_Output. This is mainly used for debugging purposes. + -- User_Data is ignored. + + procedure Lock_Filters (Descriptor : in out Process_Descriptor); + -- Temporarily disables all output and input filters. They will be + -- reactivated only when Unlock_Filters has been called as many times as + -- Lock_Filters. + + procedure Unlock_Filters (Descriptor : in out Process_Descriptor); + -- Unlocks the filters. They are reactivated only if Unlock_Filters + -- has been called as many times as Lock_Filters. + + ------------------ + -- Sending data -- + ------------------ + + procedure Send + (Descriptor : in out Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False); + -- Send a string to the file descriptor. + -- + -- The string is not formatted in any way, except if Add_LF is True, in + -- which case an ASCII.LF is added at the end, so that Str is recognized + -- as a command by the external process. + -- + -- If Empty_Buffer is True, any input waiting from the process (or in the + -- buffer) is first discarded before the command is sent. The output + -- filters are of course called as usual. + + ----------------------------------------------------------- + -- Working on the output (single process, simple regexp) -- + ----------------------------------------------------------- + + type Expect_Match is new Integer; + Expect_Full_Buffer : constant Expect_Match := -1; + -- If the buffer was full and some characters were discarded + + Expect_Timeout : constant Expect_Match := -2; + -- If no output matching the regexps was found before the timeout + + function "+" (S : String) return GNAT.OS_Lib.String_Access; + -- Allocate some memory for the string. This is merely a convenience + -- function to help create the array of regexps in the call to Expect. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Wait till a string matching Fd can be read from Fd, and return 1 if a + -- match was found. + -- + -- It consumes all the characters read from Fd until a match found, and + -- then sets the return values for the subprograms Expect_Out and + -- Expect_Out_Match. + -- + -- The empty string "" will never match, and can be used if you only want + -- to match after a specific timeout. Beware that if Timeout is -1 at the + -- time, the current task will be blocked forever. + -- + -- This command times out after Timeout milliseconds (or never if Timeout + -- is -1). In that case, Expect_Timeout is returned. The value returned by + -- Expect_Out and Expect_Out_Match are meaningless in that case. + -- + -- Note that using a timeout of 0ms leads to unpredictable behavior, since + -- the result depends on whether the process has already sent some output + -- the first time Expect checks, and this depends on the operating system. + -- + -- The regular expression must obey the syntax described in GNAT.Regpat. + -- + -- If Full_Buffer is True, then Expect will match if the buffer was too + -- small and some characters were about to be discarded. In that case, + -- Expect_Full_Buffer is returned. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as the previous one, but with a precompiled regular expression. + -- This is more efficient however, especially if you are using this + -- expression multiple times, since this package won't need to recompile + -- the regexp every time. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : String; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as above, but it is now possible to get the indexes of the + -- substrings for the parentheses in the regexp (see the example at the + -- top of this package, as well as the documentation in the package + -- GNAT.Regpat). + -- + -- Matched'First should be 0, and this index will contain the indexes for + -- the whole string that was matched. The index 1 will contain the indexes + -- for the first parentheses-pair, and so on. + + ------------ + -- Expect -- + ------------ + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexp : GNAT.Regpat.Pattern_Matcher; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as above, but with a precompiled regular expression + + ------------------------------------------------------------- + -- Working on the output (single process, multiple regexp) -- + ------------------------------------------------------------- + + type Regexp_Array is array (Positive range <>) of GNAT.OS_Lib.String_Access; + + type Pattern_Matcher_Access is access all GNAT.Regpat.Pattern_Matcher; + type Compiled_Regexp_Array is + array (Positive range <>) of Pattern_Matcher_Access; + + function "+" + (P : GNAT.Regpat.Pattern_Matcher) return Pattern_Matcher_Access; + -- Allocate some memory for the pattern matcher. This is only a convenience + -- function to help create the array of compiled regular expressions. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Wait till a string matching one of the regular expressions in Regexps + -- is found. This function returns the index of the regexp that matched. + -- This command is blocking, but will timeout after Timeout milliseconds. + -- In that case, Timeout is returned. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as the previous one, but with precompiled regular expressions. + -- This can be much faster if you are using them multiple times. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as above, except that you can also access the parenthesis + -- groups inside the matching regular expression. + -- + -- The first index in Matched must be 0, or Constraint_Error will be + -- raised. The index 0 contains the indexes for the whole string that was + -- matched, the index 1 contains the indexes for the first parentheses + -- pair, and so on. + + procedure Expect + (Descriptor : in out Process_Descriptor; + Result : out Expect_Match; + Regexps : Compiled_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as above, but with precompiled regular expressions. The first index + -- in Matched must be 0, or Constraint_Error will be raised. + + ------------------------------------------- + -- Working on the output (multi-process) -- + ------------------------------------------- + + type Multiprocess_Regexp is record + Descriptor : Process_Descriptor_Access; + Regexp : Pattern_Matcher_Access; + end record; + + type Multiprocess_Regexp_Array is + array (Positive range <>) of Multiprocess_Regexp; + + procedure Free (Regexp : in out Multiprocess_Regexp); + -- Free the memory occupied by Regexp + + function Has_Process (Regexp : Multiprocess_Regexp_Array) return Boolean; + -- Return True if at least one entry in Regexp is non-null, ie there is + -- still at least one process to monitor + + function First_Dead_Process + (Regexp : Multiprocess_Regexp_Array) return Natural; + -- Find the first entry in Regexp that corresponds to a dead process that + -- wasn't Free-d yet. This function is called in general when Expect + -- (below) raises the exception Process_Died. This returns 0 if no process + -- has died yet. + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Matched : out GNAT.Regpat.Match_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as above, but for multi processes. Any of the entries in + -- Regexps can have a null Descriptor or Regexp. Such entries will + -- simply be ignored. Therefore when a process terminates, you can + -- simply reset its entry. + -- + -- The expect loop would therefore look like: + -- + -- Processes : Multiprocess_Regexp_Array (...) := ...; + -- R : Natural; + -- + -- while Has_Process (Processes) loop + -- begin + -- Expect (Result, Processes, Timeout => -1); + -- ... process output of process Result (output, full buffer,...) + -- + -- exception + -- when Process_Died => + -- -- Free memory + -- R := First_Dead_Process (Processes); + -- Close (Processes (R).Descriptor.all, Status); + -- Free (Processes (R)); + -- end; + -- end loop; + + procedure Expect + (Result : out Expect_Match; + Regexps : Multiprocess_Regexp_Array; + Timeout : Integer := 10_000; + Full_Buffer : Boolean := False); + -- Same as the previous one, but for multiple processes. This procedure + -- finds the first regexp that match the associated process. + + ------------------------ + -- Getting the output -- + ------------------------ + + procedure Flush + (Descriptor : in out Process_Descriptor; + Timeout : Integer := 0); + -- Discard all output waiting from the process. + -- + -- This output is simply discarded, and no filter is called. This output + -- will also not be visible by the next call to Expect, nor will any output + -- currently buffered. + -- + -- Timeout is the delay for which we wait for output to be available from + -- the process. If 0, we only get what is immediately available. + + function Expect_Out (Descriptor : Process_Descriptor) return String; + -- Return the string matched by the last Expect call. + -- + -- The returned string is in fact the concatenation of all the strings read + -- from the file descriptor up to, and including, the characters that + -- matched the regular expression. + -- + -- For instance, with an input "philosophic", and a regular expression "hi" + -- in the call to expect, the strings returned the first and second time + -- would be respectively "phi" and "losophi". + + function Expect_Out_Match (Descriptor : Process_Descriptor) return String; + -- Return the string matched by the last Expect call. + -- + -- The returned string includes only the character that matched the + -- specific regular expression. All the characters that came before are + -- simply discarded. + -- + -- For instance, with an input "philosophic", and a regular expression + -- "hi" in the call to expect, the strings returned the first and second + -- time would both be "hi". + + ---------------- + -- Exceptions -- + ---------------- + + Invalid_Process : exception; + -- Raised by most subprograms above when the parameter Descriptor is not a + -- valid process or is a closed process. + + Process_Died : exception; + -- Raised by all the expect subprograms if Descriptor was originally a + -- valid process that died while Expect was executing. It is also raised + -- when Expect receives an end-of-file. + +private + type Filter_List_Elem; + type Filter_List is access Filter_List_Elem; + type Filter_List_Elem is record + Filter : Filter_Function; + User_Data : System.Address; + Filter_On : Filter_Type; + Next : Filter_List; + end record; + + type Pipe_Type is record + Input, Output : GNAT.OS_Lib.File_Descriptor; + end record; + -- This type represents a pipe, used to communicate between two processes + + procedure Set_Up_Communications + (Pid : in out Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : not null access Pipe_Type; + Pipe2 : not null access Pipe_Type; + Pipe3 : not null access Pipe_Type); + -- Set up all the communication pipes and file descriptors prior to + -- spawning the child process. + + procedure Set_Up_Parent_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type); + -- Finish the set up of the pipes while in the parent process + + procedure Set_Up_Child_Communications + (Pid : in out Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : String; + Args : System.Address); + -- Finish the set up of the pipes while in the child process This also + -- spawns the child process (based on Cmd). On systems that support fork, + -- this procedure is executed inside the newly created process. + + type Process_Descriptor is tagged record + Pid : aliased Process_Id := Invalid_Pid; + Input_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; + Output_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; + Error_Fd : GNAT.OS_Lib.File_Descriptor := GNAT.OS_Lib.Invalid_FD; + Filters_Lock : Integer := 0; + + Filters : Filter_List := null; + + Buffer : GNAT.OS_Lib.String_Access := null; + Buffer_Size : Natural := 0; + Buffer_Index : Natural := 0; + + Last_Match_Start : Natural := 0; + Last_Match_End : Natural := 0; + end record; + + -- The following subprogram is provided for use in the body, and also + -- possibly in future child units providing extensions to this package. + + procedure Portable_Execvp + (Pid : not null access Process_Id; + Cmd : String; + Args : System.Address); + pragma Import (C, Portable_Execvp, "__gnat_expect_portable_execvp"); + -- Executes, in a portable way, the command Cmd (full path must be + -- specified), with the given Args, which must be an array of string + -- pointers. Note that the first element in Args must be the executable + -- name, and the last element must be a null pointer. The returned value + -- in Pid is the process ID, or zero if not supported on the platform. + +end GNAT.Expect; diff --git a/gcc/ada/libgnat/g-exptty.adb b/gcc/ada/libgnat/g-exptty.adb new file mode 100644 index 0000000..93f4d49 --- /dev/null +++ b/gcc/ada/libgnat/g-exptty.adb @@ -0,0 +1,324 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T . T T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +with System; use System; + +package body GNAT.Expect.TTY is + + On_Windows : constant Boolean := Directory_Separator = '\'; + -- True when on Windows + + ----------- + -- Close -- + ----------- + + overriding procedure Close + (Descriptor : in out TTY_Process_Descriptor; + Status : out Integer) + is + procedure Terminate_Process (Process : System.Address); + pragma Import (C, Terminate_Process, "__gnat_terminate_process"); + + function Waitpid (Process : System.Address) return Integer; + pragma Import (C, Waitpid, "__gnat_tty_waitpid"); + -- Wait for a specific process id, and return its exit code + + procedure Free_Process (Process : System.Address); + pragma Import (C, Free_Process, "__gnat_free_process"); + + procedure Close_TTY (Process : System.Address); + pragma Import (C, Close_TTY, "__gnat_close_tty"); + + begin + -- If we haven't already closed the process + + if Descriptor.Process = System.Null_Address then + Status := -1; + + else + -- Send a Ctrl-C to the process first. This way, if the launched + -- process is a "sh" or "cmd", the child processes will get + -- terminated as well. Otherwise, terminating the main process + -- brutally will leave the children running. + + -- Note: special characters are sent to the terminal to generate the + -- signal, so this needs to be done while the file descriptors are + -- still open (it used to be after the closes and that was wrong). + + Interrupt (Descriptor); + delay (0.05); + + if Descriptor.Input_Fd /= Invalid_FD then + Close (Descriptor.Input_Fd); + end if; + + if Descriptor.Error_Fd /= Descriptor.Output_Fd + and then Descriptor.Error_Fd /= Invalid_FD + then + Close (Descriptor.Error_Fd); + end if; + + if Descriptor.Output_Fd /= Invalid_FD then + Close (Descriptor.Output_Fd); + end if; + + Terminate_Process (Descriptor.Process); + Status := Waitpid (Descriptor.Process); + + if not On_Windows then + Close_TTY (Descriptor.Process); + end if; + + Free_Process (Descriptor.Process'Address); + Descriptor.Process := System.Null_Address; + + GNAT.OS_Lib.Free (Descriptor.Buffer); + Descriptor.Buffer_Size := 0; + end if; + end Close; + + overriding procedure Close (Descriptor : in out TTY_Process_Descriptor) is + Status : Integer; + begin + Close (Descriptor, Status); + end Close; + + ----------------------------- + -- Close_Pseudo_Descriptor -- + ----------------------------- + + procedure Close_Pseudo_Descriptor + (Descriptor : in out TTY_Process_Descriptor) + is + begin + Descriptor.Buffer_Size := 0; + GNAT.OS_Lib.Free (Descriptor.Buffer); + end Close_Pseudo_Descriptor; + + --------------- + -- Interrupt -- + --------------- + + overriding procedure Interrupt + (Descriptor : in out TTY_Process_Descriptor) + is + procedure Internal (Process : System.Address); + pragma Import (C, Internal, "__gnat_interrupt_process"); + begin + if Descriptor.Process /= System.Null_Address then + Internal (Descriptor.Process); + end if; + end Interrupt; + + procedure Interrupt (Pid : Integer) is + procedure Internal (Pid : Integer); + pragma Import (C, Internal, "__gnat_interrupt_pid"); + begin + Internal (Pid); + end Interrupt; + + ----------------------- + -- Terminate_Process -- + ----------------------- + + procedure Terminate_Process (Pid : Integer) is + procedure Internal (Pid : Integer); + pragma Import (C, Internal, "__gnat_terminate_pid"); + begin + Internal (Pid); + end Terminate_Process; + + ----------------------- + -- Pseudo_Descriptor -- + ----------------------- + + procedure Pseudo_Descriptor + (Descriptor : out TTY_Process_Descriptor'Class; + TTY : GNAT.TTY.TTY_Handle; + Buffer_Size : Natural := 4096) is + begin + Descriptor.Input_Fd := GNAT.TTY.TTY_Descriptor (TTY); + Descriptor.Output_Fd := Descriptor.Input_Fd; + + -- Create the buffer + + Descriptor.Buffer_Size := Buffer_Size; + + if Buffer_Size /= 0 then + Descriptor.Buffer := new String (1 .. Positive (Buffer_Size)); + end if; + end Pseudo_Descriptor; + + ---------- + -- Send -- + ---------- + + overriding procedure Send + (Descriptor : in out TTY_Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False) + is + Header : String (1 .. 5); + Length : Natural; + Ret : Natural; + + procedure Internal + (Process : System.Address; + S : in out String; + Length : Natural; + Ret : out Natural); + pragma Import (C, Internal, "__gnat_send_header"); + + begin + Length := Str'Length; + + if Add_LF then + Length := Length + 1; + end if; + + Internal (Descriptor.Process, Header, Length, Ret); + + if Ret = 1 then + + -- Need to use the header + + GNAT.Expect.Send + (Process_Descriptor (Descriptor), + Header & Str, Add_LF, Empty_Buffer); + + else + GNAT.Expect.Send + (Process_Descriptor (Descriptor), + Str, Add_LF, Empty_Buffer); + end if; + end Send; + + -------------- + -- Set_Size -- + -------------- + + procedure Set_Size + (Descriptor : in out TTY_Process_Descriptor'Class; + Rows : Natural; + Columns : Natural) + is + procedure Internal (Process : System.Address; R, C : Integer); + pragma Import (C, Internal, "__gnat_setup_winsize"); + begin + if Descriptor.Process /= System.Null_Address then + Internal (Descriptor.Process, Rows, Columns); + end if; + end Set_Size; + + --------------------------- + -- Set_Up_Communications -- + --------------------------- + + overriding procedure Set_Up_Communications + (Pid : in out TTY_Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type) + is + pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3); + + function Internal (Process : System.Address) return Integer; + pragma Import (C, Internal, "__gnat_setup_communication"); + + begin + if Internal (Pid.Process'Address) /= 0 then + raise Invalid_Process with "cannot setup communication."; + end if; + end Set_Up_Communications; + + --------------------------------- + -- Set_Up_Child_Communications -- + --------------------------------- + + overriding procedure Set_Up_Child_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : String; + Args : System.Address) + is + pragma Unreferenced (Pipe1, Pipe2, Pipe3, Cmd); + function Internal + (Process : System.Address; Argv : System.Address; Use_Pipes : Integer) + return Process_Id; + pragma Import (C, Internal, "__gnat_setup_child_communication"); + + begin + Pid.Pid := Internal (Pid.Process, Args, Boolean'Pos (Pid.Use_Pipes)); + end Set_Up_Child_Communications; + + ---------------------------------- + -- Set_Up_Parent_Communications -- + ---------------------------------- + + overriding procedure Set_Up_Parent_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type) + is + pragma Unreferenced (Pipe1, Pipe2, Pipe3); + + procedure Internal + (Process : System.Address; + Inputfp : out File_Descriptor; + Outputfp : out File_Descriptor; + Errorfp : out File_Descriptor; + Pid : out Process_Id); + pragma Import (C, Internal, "__gnat_setup_parent_communication"); + + begin + Internal + (Pid.Process, Pid.Input_Fd, Pid.Output_Fd, Pid.Error_Fd, Pid.Pid); + end Set_Up_Parent_Communications; + + ------------------- + -- Set_Use_Pipes -- + ------------------- + + procedure Set_Use_Pipes + (Descriptor : in out TTY_Process_Descriptor; + Use_Pipes : Boolean) is + begin + Descriptor.Use_Pipes := Use_Pipes; + end Set_Use_Pipes; + +end GNAT.Expect.TTY; diff --git a/gcc/ada/libgnat/g-exptty.ads b/gcc/ada/libgnat/g-exptty.ads new file mode 100644 index 0000000..17c361c --- /dev/null +++ b/gcc/ada/libgnat/g-exptty.ads @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . E X P E C T . T T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.TTY; + +with System; +with System.OS_Constants; + +package GNAT.Expect.TTY is + + pragma Linker_Options (System.OS_Constants.PTY_Library); + + ------------------ + -- TTY_Process -- + ------------------ + + type TTY_Process_Descriptor is new Process_Descriptor with private; + -- Similar to Process_Descriptor, with the parent set up as a full terminal + -- (Unix sense, see tty(4)). + + procedure Pseudo_Descriptor + (Descriptor : out TTY_Process_Descriptor'Class; + TTY : GNAT.TTY.TTY_Handle; + Buffer_Size : Natural := 4096); + -- Given a terminal descriptor (TTY), create a pseudo process descriptor + -- to be used with GNAT.Expect. + -- + -- Note that it is invalid to call Close, Interrupt, Send_Signal on the + -- resulting descriptor. To deallocate memory associated with Process, + -- call Close_Pseudo_Descriptor instead. + + procedure Close_Pseudo_Descriptor + (Descriptor : in out TTY_Process_Descriptor); + -- Free memory and ressources associated with Descriptor. Will *not* + -- close the associated TTY, it is the caller's responsibility to call + -- GNAT.TTY.Close_TTY. + + procedure Interrupt (Pid : Integer); + -- Interrupt a process given its pid. + -- This is equivalent to sending a ctrl-c event, or kill -SIGINT. + + procedure Terminate_Process (Pid : Integer); + -- Terminate abruptly a process given its pid. + -- This is equivalent to kill -SIGKILL under unix, or TerminateProcess + -- under Windows. + + overriding procedure Send + (Descriptor : in out TTY_Process_Descriptor; + Str : String; + Add_LF : Boolean := True; + Empty_Buffer : Boolean := False); + -- See parent + -- What does that comment mean??? what is "parent" here + + procedure Set_Use_Pipes + (Descriptor : in out TTY_Process_Descriptor; + Use_Pipes : Boolean); + -- Tell Expect.TTY whether to use Pipes or Console (on windows). Needs to + -- be set before spawning the process. Default is to use Pipes. + + procedure Set_Size + (Descriptor : in out TTY_Process_Descriptor'Class; + Rows : Natural; + Columns : Natural); + -- Sets up the size of the terminal as reported to the spawned process + +private + + -- All declarations in the private part must be fully commented ??? + + overriding procedure Close + (Descriptor : in out TTY_Process_Descriptor; + Status : out Integer); + + overriding procedure Close + (Descriptor : in out TTY_Process_Descriptor); + + overriding procedure Interrupt (Descriptor : in out TTY_Process_Descriptor); + -- When we use pseudo-terminals, we do not need to use signals to + -- interrupt the debugger, we can simply send the appropriate character. + -- This provides a better support for remote debugging for instance. + + procedure Set_Up_Communications + (Pid : in out TTY_Process_Descriptor; + Err_To_Out : Boolean; + Pipe1 : access Pipe_Type; + Pipe2 : access Pipe_Type; + Pipe3 : access Pipe_Type); + + procedure Set_Up_Parent_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type); + + procedure Set_Up_Child_Communications + (Pid : in out TTY_Process_Descriptor; + Pipe1 : in out Pipe_Type; + Pipe2 : in out Pipe_Type; + Pipe3 : in out Pipe_Type; + Cmd : String; + Args : System.Address); + + type TTY_Process_Descriptor is new Process_Descriptor with record + Process : System.Address; -- Underlying structure used in C + Use_Pipes : Boolean := True; + end record; + +end GNAT.Expect.TTY; diff --git a/gcc/ada/libgnat/g-flocon.ads b/gcc/ada/libgnat/g-flocon.ads new file mode 100644 index 0000000..5bc0a0d --- /dev/null +++ b/gcc/ada/libgnat/g-flocon.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . F L O A T _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Control functions for floating-point unit + +-- See file s-flocon.ads for full documentation of the interface + +with System.Float_Control; + +package GNAT.Float_Control renames System.Float_Control; diff --git a/gcc/ada/libgnat/g-forstr.adb b/gcc/ada/libgnat/g-forstr.adb new file mode 100644 index 0000000..21ed66e --- /dev/null +++ b/gcc/ada/libgnat/g-forstr.adb @@ -0,0 +1,984 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . F O R M A T T E D _ S T R I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Characters.Handling; +with Ada.Float_Text_IO; +with Ada.Integer_Text_IO; +with Ada.Long_Float_Text_IO; +with Ada.Long_Integer_Text_IO; +with Ada.Strings.Fixed; +with Ada.Unchecked_Deallocation; + +with System.Address_Image; + +package body GNAT.Formatted_String is + + type F_Kind is (Decimal_Int, -- %d %i + Unsigned_Decimal_Int, -- %u + Unsigned_Octal, -- %o + Unsigned_Hexadecimal_Int, -- %x + Unsigned_Hexadecimal_Int_Up, -- %X + Decimal_Float, -- %f %F + Decimal_Scientific_Float, -- %e + Decimal_Scientific_Float_Up, -- %E + Shortest_Decimal_Float, -- %g + Shortest_Decimal_Float_Up, -- %G + Char, -- %c + Str, -- %s + Pointer -- %p + ); + + type Sign_Kind is (Neg, Zero, Pos); + + subtype Is_Number is F_Kind range Decimal_Int .. Decimal_Float; + + type F_Sign is (If_Neg, Forced, Space) with Default_Value => If_Neg; + + type F_Base is (None, C_Style, Ada_Style) with Default_Value => None; + + Unset : constant Integer := -1; + + type F_Data is record + Kind : F_Kind; + Width : Natural := 0; + Precision : Integer := Unset; + Left_Justify : Boolean := False; + Sign : F_Sign; + Base : F_Base; + Zero_Pad : Boolean := False; + Value_Needed : Natural range 0 .. 2 := 0; + end record; + + procedure Next_Format + (Format : Formatted_String; + F_Spec : out F_Data; + Start : out Positive); + -- Parse the next format specifier, a format specifier has the following + -- syntax: %[flags][width][.precision][length]specifier + + function Get_Formatted + (F_Spec : F_Data; + Value : String; + Len : Positive) return String; + -- Returns Value formatted given the information in F_Spec + + procedure Raise_Wrong_Format (Format : Formatted_String) with No_Return; + -- Raise the Format_Error exception which information about the context + + generic + type Flt is private; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function P_Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- Generic routine which handles all floating point numbers + + generic + type Int is private; + + with function To_Integer (Item : Int) return Integer; + + with function Sign (Item : Int) return Sign_Kind; + + with procedure Put + (To : out String; + Item : Int; + Base : Text_IO.Number_Base); + function P_Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String; + -- Generic routine which handles all the integer numbers + + --------- + -- "+" -- + --------- + + function "+" (Format : String) return Formatted_String is + begin + return Formatted_String' + (Finalization.Controlled with + D => new Data'(Format'Length, 1, 1, + Null_Unbounded_String, 0, 0, (0, 0), Format)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Format : Formatted_String) return String is + F : String renames Format.D.Format; + J : Natural renames Format.D.Index; + R : Unbounded_String := Format.D.Result; + + begin + -- Make sure we get the remaining character up to the next unhandled + -- format specifier. + + while (J <= F'Length and then F (J) /= '%') + or else (J < F'Length - 1 and then F (J + 1) = '%') + loop + Append (R, F (J)); + + -- If we have two consecutive %, skip the second one + + if F (J) = '%' and then J < F'Length - 1 and then F (J + 1) = '%' then + J := J + 1; + end if; + + J := J + 1; + end loop; + + return To_String (R); + end "-"; + + --------- + -- "&" -- + --------- + + function "&" + (Format : Formatted_String; + Var : Character) return Formatted_String + is + F : F_Data; + Start : Positive; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + case F.Kind is + when Char => + Append (Format.D.Result, Get_Formatted (F, String'(1 => Var), 1)); + when others => + Raise_Wrong_Format (Format); + end case; + + return Format; + end "&"; + + function "&" + (Format : Formatted_String; + Var : String) return Formatted_String + is + F : F_Data; + Start : Positive; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + case F.Kind is + when Str => + declare + S : constant String := Get_Formatted (F, Var, Var'Length); + begin + if F.Precision = Unset then + Append (Format.D.Result, S); + else + Append + (Format.D.Result, + S (S'First .. S'First + F.Precision - 1)); + end if; + end; + + when others => + Raise_Wrong_Format (Format); + end case; + + return Format; + end "&"; + + function "&" + (Format : Formatted_String; + Var : Boolean) return Formatted_String is + begin + return Format & Boolean'Image (Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Float) return Formatted_String + is + function Float_Format is new Flt_Format (Float, Float_Text_IO.Put); + begin + return Float_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Long_Float) return Formatted_String + is + function Float_Format is + new Flt_Format (Long_Float, Long_Float_Text_IO.Put); + begin + return Float_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Duration) return Formatted_String + is + package Duration_Text_IO is new Text_IO.Fixed_IO (Duration); + function Duration_Format is + new P_Flt_Format (Duration, Duration_Text_IO.Put); + begin + return Duration_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Integer) return Formatted_String + is + function Integer_Format is + new Int_Format (Integer, Integer_Text_IO.Put); + begin + return Integer_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : Long_Integer) return Formatted_String + is + function Integer_Format is + new Int_Format (Long_Integer, Long_Integer_Text_IO.Put); + begin + return Integer_Format (Format, Var); + end "&"; + + function "&" + (Format : Formatted_String; + Var : System.Address) return Formatted_String + is + A_Img : constant String := System.Address_Image (Var); + F : F_Data; + Start : Positive; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + case F.Kind is + when Pointer => + Append (Format.D.Result, Get_Formatted (F, A_Img, A_Img'Length)); + when others => + Raise_Wrong_Format (Format); + end case; + + return Format; + end "&"; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (F : in out Formatted_String) is + begin + F.D.Ref_Count := F.D.Ref_Count + 1; + end Adjust; + + -------------------- + -- Decimal_Format -- + -------------------- + + function Decimal_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + function Flt_Format is new P_Flt_Format (Flt, Put); + begin + return Flt_Format (Format, Var); + end Decimal_Format; + + ----------------- + -- Enum_Format -- + ----------------- + + function Enum_Format + (Format : Formatted_String; + Var : Enum) return Formatted_String is + begin + return Format & Enum'Image (Var); + end Enum_Format; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (F : in out Formatted_String) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Data, Data_Access); + + D : Data_Access := F.D; + + begin + F.D := null; + + D.Ref_Count := D.Ref_Count - 1; + + if D.Ref_Count = 0 then + Unchecked_Free (D); + end if; + end Finalize; + + ------------------ + -- Fixed_Format -- + ------------------ + + function Fixed_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + function Flt_Format is new P_Flt_Format (Flt, Put); + begin + return Flt_Format (Format, Var); + end Fixed_Format; + + ---------------- + -- Flt_Format -- + ---------------- + + function Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + function Flt_Format is new P_Flt_Format (Flt, Put); + begin + return Flt_Format (Format, Var); + end Flt_Format; + + ------------------- + -- Get_Formatted -- + ------------------- + + function Get_Formatted + (F_Spec : F_Data; + Value : String; + Len : Positive) return String + is + use Ada.Strings.Fixed; + + Res : Unbounded_String; + S : Positive := Value'First; + + begin + -- Handle the flags + + if F_Spec.Kind in Is_Number then + if F_Spec.Sign = Forced and then Value (Value'First) /= '-' then + Append (Res, "+"); + elsif F_Spec.Sign = Space and then Value (Value'First) /= '-' then + Append (Res, " "); + end if; + + if Value (Value'First) = '-' then + Append (Res, "-"); + S := S + 1; + end if; + end if; + + -- Zero padding if required and possible + + if F_Spec.Left_Justify = False + and then F_Spec.Zero_Pad + and then F_Spec.Width > Len + Value'First - S + then + Append (Res, String'((F_Spec.Width - Len + Value'First - S) * '0')); + end if; + + -- Add the value now + + Append (Res, Value (S .. Value'Last)); + + declare + R : String (1 .. Natural'Max (Natural'Max (F_Spec.Width, Len), + Length (Res))) := (others => ' '); + begin + if F_Spec.Left_Justify then + R (1 .. Length (Res)) := To_String (Res); + else + R (R'Last - Length (Res) + 1 .. R'Last) := To_String (Res); + end if; + + return R; + end; + end Get_Formatted; + + ---------------- + -- Int_Format -- + ---------------- + + function Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String + is + function Sign (Var : Int) return Sign_Kind is + (if Var < 0 then Neg elsif Var = 0 then Zero else Pos); + + function To_Integer (Var : Int) return Integer is + (Integer (Var)); + + function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put); + + begin + return Int_Format (Format, Var); + end Int_Format; + + ---------------- + -- Mod_Format -- + ---------------- + + function Mod_Format + (Format : Formatted_String; + Var : Int) return Formatted_String + is + function Sign (Var : Int) return Sign_Kind is + (if Var < 0 then Neg elsif Var = 0 then Zero else Pos); + + function To_Integer (Var : Int) return Integer is + (Integer (Var)); + + function Int_Format is new P_Int_Format (Int, To_Integer, Sign, Put); + + begin + return Int_Format (Format, Var); + end Mod_Format; + + ----------------- + -- Next_Format -- + ----------------- + + procedure Next_Format + (Format : Formatted_String; + F_Spec : out F_Data; + Start : out Positive) + is + F : String renames Format.D.Format; + J : Natural renames Format.D.Index; + S : Natural; + Width_From_Var : Boolean := False; + + begin + Format.D.Current := Format.D.Current + 1; + F_Spec.Value_Needed := 0; + + -- Got to next % + + while (J <= F'Last and then F (J) /= '%') + or else (J < F'Last - 1 and then F (J + 1) = '%') + loop + Append (Format.D.Result, F (J)); + + -- If we have two consecutive %, skip the second one + + if F (J) = '%' and then J < F'Last - 1 and then F (J + 1) = '%' then + J := J + 1; + end if; + + J := J + 1; + end loop; + + if F (J) /= '%' or else J = F'Last then + raise Format_Error with "no format specifier found for parameter" + & Positive'Image (Format.D.Current); + end if; + + Start := J; + + J := J + 1; + + -- Check for any flags + + Flags_Check : while J < F'Last loop + if F (J) = '-' then + F_Spec.Left_Justify := True; + elsif F (J) = '+' then + F_Spec.Sign := Forced; + elsif F (J) = ' ' then + F_Spec.Sign := Space; + elsif F (J) = '#' then + F_Spec.Base := C_Style; + elsif F (J) = '~' then + F_Spec.Base := Ada_Style; + elsif F (J) = '0' then + F_Spec.Zero_Pad := True; + else + exit Flags_Check; + end if; + + J := J + 1; + end loop Flags_Check; + + -- Check width if any + + if F (J) in '0' .. '9' then + + -- We have a width parameter + + S := J; + + while J < F'Last and then F (J + 1) in '0' .. '9' loop + J := J + 1; + end loop; + + F_Spec.Width := Natural'Value (F (S .. J)); + + J := J + 1; + + elsif F (J) = '*' then + + -- The width will be taken from the integer parameter + + F_Spec.Value_Needed := 1; + Width_From_Var := True; + + J := J + 1; + end if; + + if F (J) = '.' then + + -- We have a precision parameter + + J := J + 1; + + if F (J) in '0' .. '9' then + S := J; + + while J < F'Length and then F (J + 1) in '0' .. '9' loop + J := J + 1; + end loop; + + if F (J) = '.' then + + -- No precision, 0 is assumed + + F_Spec.Precision := 0; + + else + F_Spec.Precision := Natural'Value (F (S .. J)); + end if; + + J := J + 1; + + elsif F (J) = '*' then + + -- The prevision will be taken from the integer parameter + + F_Spec.Value_Needed := F_Spec.Value_Needed + 1; + J := J + 1; + end if; + end if; + + -- Skip the length specifier, this is not needed for this implementation + -- but yet for compatibility reason it is handled. + + Length_Check : + while J <= F'Last + and then F (J) in 'h' | 'l' | 'j' | 'z' | 't' | 'L' + loop + J := J + 1; + end loop Length_Check; + + if J > F'Last then + Raise_Wrong_Format (Format); + end if; + + -- Read next character which should be the expected type + + case F (J) is + when 'c' => F_Spec.Kind := Char; + when 's' => F_Spec.Kind := Str; + when 'd' | 'i' => F_Spec.Kind := Decimal_Int; + when 'u' => F_Spec.Kind := Unsigned_Decimal_Int; + when 'f' | 'F' => F_Spec.Kind := Decimal_Float; + when 'e' => F_Spec.Kind := Decimal_Scientific_Float; + when 'E' => F_Spec.Kind := Decimal_Scientific_Float_Up; + when 'g' => F_Spec.Kind := Shortest_Decimal_Float; + when 'G' => F_Spec.Kind := Shortest_Decimal_Float_Up; + when 'o' => F_Spec.Kind := Unsigned_Octal; + when 'x' => F_Spec.Kind := Unsigned_Hexadecimal_Int; + when 'X' => F_Spec.Kind := Unsigned_Hexadecimal_Int_Up; + + when others => + raise Format_Error with "unknown format specified for parameter" + & Positive'Image (Format.D.Current); + end case; + + J := J + 1; + + if F_Spec.Value_Needed > 0 + and then F_Spec.Value_Needed = Format.D.Stored_Value + then + if F_Spec.Value_Needed = 1 then + if Width_From_Var then + F_Spec.Width := Format.D.Stack (1); + else + F_Spec.Precision := Format.D.Stack (1); + end if; + + else + F_Spec.Width := Format.D.Stack (1); + F_Spec.Precision := Format.D.Stack (2); + end if; + end if; + end Next_Format; + + ------------------ + -- P_Flt_Format -- + ------------------ + + function P_Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String + is + F : F_Data; + Buffer : String (1 .. 50); + S, E : Positive := 1; + Start : Positive; + Aft : Text_IO.Field; + + begin + Next_Format (Format, F, Start); + + if F.Value_Needed > 0 then + Raise_Wrong_Format (Format); + end if; + + if F.Precision = Unset then + Aft := 6; + else + Aft := F.Precision; + end if; + + case F.Kind is + when Decimal_Float => + + Put (Buffer, Var, Aft, Exp => 0); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + when Decimal_Scientific_Float + | Decimal_Scientific_Float_Up + => + Put (Buffer, Var, Aft, Exp => 3); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + if F.Kind = Decimal_Scientific_Float then + Buffer (S .. E) := + Characters.Handling.To_Lower (Buffer (S .. E)); + end if; + + when Shortest_Decimal_Float + | Shortest_Decimal_Float_Up + => + -- Without exponent + + Put (Buffer, Var, Aft, Exp => 0); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + -- Check with exponent + + declare + Buffer2 : String (1 .. 50); + S2, E2 : Positive; + + begin + Put (Buffer2, Var, Aft, Exp => 3); + S2 := Strings.Fixed.Index_Non_Blank (Buffer2); + E2 := Buffer2'Last; + + -- If with exponent it is shorter, use it + + if (E2 - S2) < (E - S) then + Buffer := Buffer2; + S := S2; + E := E2; + end if; + end; + + if F.Kind = Shortest_Decimal_Float then + Buffer (S .. E) := + Characters.Handling.To_Lower (Buffer (S .. E)); + end if; + + when others => + Raise_Wrong_Format (Format); + end case; + + Append (Format.D.Result, + Get_Formatted (F, Buffer (S .. E), Buffer (S .. E)'Length)); + + return Format; + end P_Flt_Format; + + ------------------ + -- P_Int_Format -- + ------------------ + + function P_Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String + is + function Handle_Precision return Boolean; + -- Return True if nothing else to do + + F : F_Data; + Buffer : String (1 .. 50); + S, E : Positive := 1; + Len : Natural := 0; + Start : Positive; + + ---------------------- + -- Handle_Precision -- + ---------------------- + + function Handle_Precision return Boolean is + begin + if F.Precision = 0 and then Sign (Var) = Zero then + return True; + + elsif F.Precision = Natural'Last then + null; + + elsif F.Precision > E - S + 1 then + Len := F.Precision - (E - S + 1); + Buffer (S - Len .. S - 1) := (others => '0'); + S := S - Len; + end if; + + return False; + end Handle_Precision; + + -- Start of processing for P_Int_Format + + begin + Next_Format (Format, F, Start); + + if Format.D.Stored_Value < F.Value_Needed then + Format.D.Stored_Value := Format.D.Stored_Value + 1; + Format.D.Stack (Format.D.Stored_Value) := To_Integer (Var); + Format.D.Index := Start; + return Format; + end if; + + case F.Kind is + when Unsigned_Octal => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 8); + S := Strings.Fixed.Index (Buffer, "8#") + 2; + E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; + + if Handle_Precision then + return Format; + end if; + + case F.Base is + when None => null; + when C_Style => Len := 1; + when Ada_Style => Len := 3; + end case; + + when Unsigned_Hexadecimal_Int => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 16); + S := Strings.Fixed.Index (Buffer, "16#") + 3; + E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; + Buffer (S .. E) := Characters.Handling.To_Lower (Buffer (S .. E)); + + if Handle_Precision then + return Format; + end if; + + case F.Base is + when None => null; + when C_Style => Len := 2; + when Ada_Style => Len := 4; + end case; + + when Unsigned_Hexadecimal_Int_Up => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 16); + S := Strings.Fixed.Index (Buffer, "16#") + 3; + E := Strings.Fixed.Index (Buffer (S .. Buffer'Last), "#") - 1; + + if Handle_Precision then + return Format; + end if; + + case F.Base is + when None => null; + when C_Style => Len := 2; + when Ada_Style => Len := 4; + end case; + + when Unsigned_Decimal_Int => + if Sign (Var) = Neg then + Raise_Wrong_Format (Format); + end if; + + Put (Buffer, Var, Base => 10); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + if Handle_Precision then + return Format; + end if; + + when Decimal_Int => + Put (Buffer, Var, Base => 10); + S := Strings.Fixed.Index_Non_Blank (Buffer); + E := Buffer'Last; + + if Handle_Precision then + return Format; + end if; + + when Char => + S := Buffer'First; + E := Buffer'First; + Buffer (S) := Character'Val (To_Integer (Var)); + + if Handle_Precision then + return Format; + end if; + + when others => + Raise_Wrong_Format (Format); + end case; + + -- Then add base if needed + + declare + N : String := Get_Formatted (F, Buffer (S .. E), E - S + 1 + Len); + P : constant Positive := + (if F.Left_Justify + then N'First + else Natural'Max (Strings.Fixed.Index_Non_Blank (N) - 1, + N'First)); + begin + case F.Base is + when None => + null; + + when C_Style => + case F.Kind is + when Unsigned_Octal => + N (P) := 'O'; + + when Unsigned_Hexadecimal_Int => + if F.Left_Justify then + N (P .. P + 1) := "Ox"; + else + N (P - 1 .. P) := "0x"; + end if; + + when Unsigned_Hexadecimal_Int_Up => + if F.Left_Justify then + N (P .. P + 1) := "OX"; + else + N (P - 1 .. P) := "0X"; + end if; + + when others => + null; + end case; + + when Ada_Style => + case F.Kind is + when Unsigned_Octal => + if F.Left_Justify then + N (N'First + 2 .. N'Last) := N (N'First .. N'Last - 2); + else + N (P .. N'Last - 1) := N (P + 1 .. N'Last); + end if; + + N (N'First .. N'First + 1) := "8#"; + N (N'Last) := '#'; + + when Unsigned_Hexadecimal_Int + | Unsigned_Hexadecimal_Int_Up + => + if F.Left_Justify then + N (N'First + 3 .. N'Last) := N (N'First .. N'Last - 3); + else + N (P .. N'Last - 1) := N (P + 1 .. N'Last); + end if; + + N (N'First .. N'First + 2) := "16#"; + N (N'Last) := '#'; + + when others => + null; + end case; + end case; + + Append (Format.D.Result, N); + end; + + return Format; + end P_Int_Format; + + ------------------------ + -- Raise_Wrong_Format -- + ------------------------ + + procedure Raise_Wrong_Format (Format : Formatted_String) is + begin + raise Format_Error with + "wrong format specified for parameter" + & Positive'Image (Format.D.Current); + end Raise_Wrong_Format; + +end GNAT.Formatted_String; diff --git a/gcc/ada/libgnat/g-forstr.ads b/gcc/ada/libgnat/g-forstr.ads new file mode 100644 index 0000000..165440c --- /dev/null +++ b/gcc/ada/libgnat/g-forstr.ads @@ -0,0 +1,311 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . F O R M A T T E D _ S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package add support for formatted string as supported by C printf() + +-- A simple usage is: +-- +-- Put_Line (-(+"%s" & "a string")); +-- +-- or with a constant for the format: +-- +-- declare +-- Format : constant Formatted_String := +"%s"; +-- begin +-- Put_Line (-(Format & "a string")); +-- end; +-- +-- Finally a more complex example: +-- +-- declare +-- F : Formatted_String := +"['%c' ; %10d]"; +-- C : Character := 'v'; +-- I : Integer := 98; +-- begin +-- F := F & C & I; +-- Put_Line (-F); +-- end; + +-- Which will display: + +-- ['v' ; 98] + +-- Each format specifier is: %[flags][width][.precision][length]specifier + +-- Specifiers: +-- d or i Signed decimal integer +-- u Unsigned decimal integer +-- o Unsigned octal +-- x Unsigned hexadecimal integer +-- X Unsigned hexadecimal integer (uppercase) +-- f Decimal floating point, lowercase +-- F Decimal floating point, uppercase +-- e Scientific notation (mantissa/exponent), lowercase +-- E Scientific notation (mantissa/exponent), uppercase +-- g Use the shortest representation: %e or %f +-- G Use the shortest representation: %E or %F +-- c Character +-- s String of characters +-- p Pointer address +-- % A % followed by another % character will write a single % + +-- Flags: + +-- - Left-justify within the given field width; +-- Right justification is the default. + +-- + Forces to preceed the result with a plus or minus sign (+ or -) +-- even for positive numbers. By default, only negative numbers +-- are preceded with a - sign. + +-- (space) If no sign is going to be written, a blank space is inserted +-- before the value. + +-- # Used with o, x or X specifiers the value is preceeded with +-- 0, 0x or 0X respectively for values different than zero. +-- Used with a, A, e, E, f, F, g or G it forces the written +-- output to contain a decimal point even if no more digits +-- follow. By default, if no digits follow, no decimal point is +-- written. + +-- ~ As above, but using Ada style based ## + +-- 0 Left-pads the number with zeroes (0) instead of spaces when +-- padding is specified. + +-- Width: +-- number Minimum number of characters to be printed. If the value to +-- be printed is shorter than this number, the result is padded +-- with blank spaces. The value is not truncated even if the +-- result is larger. + +-- * The width is not specified in the format string, but as an +-- additional integer value argument preceding the argument that +-- has to be formatted. +-- Precision: +-- number For integer specifiers (d, i, o, u, x, X): precision specifies +-- the minimum number of digits to be written. If the value to be +-- written is shorter than this number, the result is padded with +-- leading zeros. The value is not truncated even if the result +-- is longer. A precision of 0 means that no character is written +-- for the value 0. + +-- For e, E, f and F specifiers: this is the number of digits to +-- be printed after the decimal point (by default, this is 6). +-- For g and G specifiers: This is the maximum number of +-- significant digits to be printed. + +-- For s: this is the maximum number of characters to be printed. +-- By default all characters are printed until the ending null +-- character is encountered. + +-- If the period is specified without an explicit value for +-- precision, 0 is assumed. + +-- .* The precision is not specified in the format string, but as an +-- additional integer value argument preceding the argument that +-- has to be formatted. + +with Ada.Text_IO; +with System; + +private with Ada.Finalization; +private with Ada.Strings.Unbounded; + +package GNAT.Formatted_String is + use Ada; + + type Formatted_String (<>) is private; + -- A format string as defined for printf routine. This string is the + -- actual format for all the parameters added with the "&" routines below. + -- Note that a Formatted_String object can't be reused as it serves as + -- recipient for the final result. That is, each use of "&" will build + -- incrementally the final result string which can be retrieved with + -- the "-" routine below. + + Format_Error : exception; + -- Raised for every mismatch between the parameter and the expected format + -- and for malformed format. + + function "+" (Format : String) return Formatted_String; + -- Create the format string + + function "-" (Format : Formatted_String) return String; + -- Get the result of the formatted string corresponding to the current + -- rendering (up to the last parameter formated). + + function "&" + (Format : Formatted_String; + Var : Character) return Formatted_String; + -- A character, expect a %c + + function "&" + (Format : Formatted_String; + Var : String) return Formatted_String; + -- A string, expect a %s + + function "&" + (Format : Formatted_String; + Var : Boolean) return Formatted_String; + -- A boolean image, expect a %s + + function "&" + (Format : Formatted_String; + Var : Integer) return Formatted_String; + -- An integer, expect a %d, %o, %x, %X + + function "&" + (Format : Formatted_String; + Var : Long_Integer) return Formatted_String; + -- As above + + function "&" + (Format : Formatted_String; + Var : System.Address) return Formatted_String; + -- An address, expect a %p + + function "&" + (Format : Formatted_String; + Var : Float) return Formatted_String; + -- A float, expect %f, %e, %F, %E, %g, %G + + function "&" + (Format : Formatted_String; + Var : Long_Float) return Formatted_String; + -- As above + + function "&" + (Format : Formatted_String; + Var : Duration) return Formatted_String; + -- As above + + -- Some generics + + generic + type Int is range <>; + + with procedure Put + (To : out String; + Item : Int; + Base : Text_IO.Number_Base); + function Int_Format + (Format : Formatted_String; + Var : Int) return Formatted_String; + -- As for Integer above + + generic + type Int is mod <>; + + with procedure Put + (To : out String; + Item : Int; + Base : Text_IO.Number_Base); + function Mod_Format + (Format : Formatted_String; + Var : Int) return Formatted_String; + -- As for Integer above + + generic + type Flt is digits <>; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function Flt_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- As for Float above + + generic + type Flt is delta <>; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function Fixed_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- As for Float above + + generic + type Flt is delta <> digits <>; + + with procedure Put + (To : out String; + Item : Flt; + Aft : Text_IO.Field; + Exp : Text_IO.Field); + function Decimal_Format + (Format : Formatted_String; + Var : Flt) return Formatted_String; + -- As for Float above + + generic + type Enum is (<>); + function Enum_Format + (Format : Formatted_String; + Var : Enum) return Formatted_String; + -- As for String above, output the string representation of the enumeration + +private + use Ada.Strings.Unbounded; + + type I_Vars is array (Positive range 1 .. 2) of Integer; + -- Used to keep 2 numbers for the possible * for the width and precision + + type Data (Size : Natural) is record + Ref_Count : Natural := 1; + Index : Positive := 1; -- format index for next value + Result : Unbounded_String; -- current value + Current : Natural; -- the current format number + Stored_Value : Natural := 0; -- number of stored values in Stack + Stack : I_Vars; + Format : String (1 .. Size); -- the format string + end record; + + type Data_Access is access Data; + + -- The formatted string record is controlled and do not need an initialize + -- as it requires an explit initial value. This is given with "+" and + -- properly initialize the record at this point. + + type Formatted_String is new Finalization.Controlled with record + D : Data_Access; + end record; + + overriding procedure Adjust (F : in out Formatted_String); + overriding procedure Finalize (F : in out Formatted_String); + +end GNAT.Formatted_String; diff --git a/gcc/ada/libgnat/g-heasor.adb b/gcc/ada/libgnat/g-heasor.adb new file mode 100644 index 0000000..4a47160 --- /dev/null +++ b/gcc/ada/libgnat/g-heasor.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Heap_Sort is + + ---------- + -- Sort -- + ---------- + + -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) + -- as described by Knuth ("The Art of Programming", Volume III, first + -- edition, section 5.2.3, p. 145-147) with the modification that is + -- mentioned in exercise 18. For more details on this algorithm, see + -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray + -- Phase Problem". University of Chicago, 1968, which was the first + -- publication of the modification, which reduces the number of compares + -- from 2NlogN to NlogN. + + procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function) is + Max : Natural := N; + -- Current Max index in tree being sifted. Note that we make Max + -- Natural rather than Positive so that the case of sorting zero + -- elements is correctly handled (i.e. does nothing at all). + + procedure Sift (S : Positive); + -- This procedure sifts up node S, i.e. converts the subtree rooted + -- at node S into a heap, given the precondition that any sons of + -- S are already heaps. + + ---------- + -- Sift -- + ---------- + + procedure Sift (S : Positive) is + C : Positive := S; + Son : Positive; + Father : Positive; + + begin + -- This is where the optimization is done, normally we would do a + -- comparison at each stage between the current node and the larger + -- of the two sons, and continue the sift only if the current node + -- was less than this maximum. In this modified optimized version, + -- we assume that the current node will be less than the larger + -- son, and unconditionally sift up. Then when we get to the bottom + -- of the tree, we check parents to make sure that we did not make + -- a mistake. This roughly cuts the number of comparisons in half, + -- since it is almost always the case that our assumption is correct. + + -- Loop to pull up larger sons + + loop + Son := C + C; + + if Son < Max then + if Lt (Son, Son + 1) then + Son := Son + 1; + end if; + elsif Son > Max then + exit; + end if; + + Xchg (Son, C); + C := Son; + end loop; + + -- Loop to check fathers + + while C /= S loop + Father := C / 2; + + if Lt (Father, C) then + Xchg (Father, C); + C := Father; + else + exit; + end if; + end loop; + end Sift; + + -- Start of processing for Sort + + begin + -- Phase one of heapsort is to build the heap. This is done by + -- sifting nodes N/2 .. 1 in sequence. + + for J in reverse 1 .. N / 2 loop + Sift (J); + end loop; + + -- In phase 2, the largest node is moved to end, reducing the size + -- of the tree by one, and the displaced node is sifted down from + -- the top, so that the largest node is again at the top. + + while Max > 1 loop + Xchg (1, Max); + Max := Max - 1; + Sift (1); + end loop; + end Sort; + +end GNAT.Heap_Sort; diff --git a/gcc/ada/libgnat/g-heasor.ads b/gcc/ada/libgnat/g-heasor.ads new file mode 100644 index 0000000..1adff7b --- /dev/null +++ b/gcc/ada/libgnat/g-heasor.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Sort utility (Using Heapsort Algorithm) + +-- This package provides a heapsort routine that works with access to +-- subprogram parameters, so that it can be used with different types with +-- shared sorting code. + +-- This heapsort algorithm uses approximately N*log(N) compares in the +-- worst case and is in place with no additional storage required. See +-- the body for exact details of the algorithm used. + +-- See also GNAT.Heap_Sort_G which is a generic version that will be faster +-- since the overhead of the indirect calls is avoided, at the expense of +-- generic code duplication and less convenient interface. + +-- Note: GNAT.Heap_Sort replaces and obsoletes GNAT.Heap_Sort_A, which is +-- retained in the GNAT library for backwards compatibility. + +package GNAT.Heap_Sort is + pragma Pure; + + -- The data to be sorted is assumed to be indexed by integer values + -- from 1 to N, where N is the number of items to be sorted. + + type Xchg_Procedure is access procedure (Op1, Op2 : Natural); + -- A pointer to a procedure that exchanges the two data items whose + -- index values are Op1 and Op2. + + type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; + -- A pointer to a function that compares two items and returns True if + -- the item with index value Op1 is less than the item with Index value + -- Op2, and False if the Op1 item is greater than the Op2 item. If + -- the items are equal, then it does not matter if True or False is + -- returned (but it is slightly more efficient to return False). + + procedure Sort (N : Natural; Xchg : Xchg_Procedure; Lt : Lt_Function); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and calls to + -- Xchg to exchange items. The sort is not stable, that is the order + -- of equal items in the input data set is not preserved. + +end GNAT.Heap_Sort; diff --git a/gcc/ada/libgnat/g-hesora.adb b/gcc/ada/libgnat/g-hesora.adb new file mode 100644 index 0000000..ba0a440 --- /dev/null +++ b/gcc/ada/libgnat/g-hesora.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body GNAT.Heap_Sort_A is + + ---------- + -- Sort -- + ---------- + + -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) + -- as described by Knuth ("The Art of Programming", Volume III, first + -- edition, section 5.2.3, p. 145-147) with the modification that is + -- mentioned in exercise 18. For more details on this algorithm, see + -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray + -- Phase Problem". University of Chicago, 1968, which was the first + -- publication of the modification, which reduces the number of compares + -- from 2NlogN to NlogN. + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function) is + + Max : Natural := N; + -- Current Max index in tree being sifted + + procedure Sift (S : Positive); + -- This procedure sifts up node S, i.e. converts the subtree rooted + -- at node S into a heap, given the precondition that any sons of + -- S are already heaps. On entry, the contents of node S is found + -- in the temporary (index 0), the actual contents of node S on + -- entry are irrelevant. This is just a minor optimization to avoid + -- what would otherwise be two junk moves in phase two of the sort. + + procedure Sift (S : Positive) is + C : Positive := S; + Son : Positive; + Father : Positive; + + begin + -- This is where the optimization is done, normally we would do a + -- comparison at each stage between the current node and the larger + -- of the two sons, and continue the sift only if the current node + -- was less than this maximum. In this modified optimized version, + -- we assume that the current node will be less than the larger + -- son, and unconditionally sift up. Then when we get to the bottom + -- of the tree, we check parents to make sure that we did not make + -- a mistake. This roughly cuts the number of comparisons in half, + -- since it is almost always the case that our assumption is correct. + + -- Loop to pull up larger sons + + loop + Son := 2 * C; + exit when Son > Max; + + if Son < Max and then Lt (Son, Son + 1) then + Son := Son + 1; + end if; + + Move (Son, C); + C := Son; + end loop; + + -- Loop to check fathers + + while C /= S loop + Father := C / 2; + + if Lt (Father, 0) then + Move (Father, C); + C := Father; + else + exit; + end if; + end loop; + + -- Last step is to pop the sifted node into place + + Move (0, C); + end Sift; + + -- Start of processing for Sort + + begin + -- Phase one of heapsort is to build the heap. This is done by + -- sifting nodes N/2 .. 1 in sequence. + + for J in reverse 1 .. N / 2 loop + Move (J, 0); + Sift (J); + end loop; + + -- In phase 2, the largest node is moved to end, reducing the size + -- of the tree by one, and the displaced node is sifted down from + -- the top, so that the largest node is again at the top. + + while Max > 1 loop + Move (Max, 0); + Move (1, Max); + Max := Max - 1; + Sift (1); + end loop; + + end Sort; + +end GNAT.Heap_Sort_A; diff --git a/gcc/ada/libgnat/g-hesora.ads b/gcc/ada/libgnat/g-hesora.ads new file mode 100644 index 0000000..a5a42ff0 --- /dev/null +++ b/gcc/ada/libgnat/g-hesora.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Heapsort using access to procedure parameters + +-- This package provides a heap sort routine that works with access to +-- subprogram parameters, so that it can be used with different types with +-- shared sorting code. It is considered obsoleted by GNAT.Heap_Sort which +-- offers a similar routine with a more convenient interface. + +-- This heapsort algorithm uses approximately N*log(N) compares in the +-- worst case and is in place with no additional storage required. See +-- the body for exact details of the algorithm used. + +pragma Compiler_Unit_Warning; + +package GNAT.Heap_Sort_A is + pragma Preelaborate; + + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + type Move_Procedure is access procedure (From : Natural; To : Natural); + -- A pointer to a procedure that moves the data item with index From to + -- the data item with index To. An index value of zero is used for moves + -- from and to the single temporary location used by the sort. + + type Lt_Function is access function (Op1, Op2 : Natural) return Boolean; + -- A pointer to a function that compares two items and returns True if + -- the item with index Op1 is less than the item with index Op2, and False + -- if the Op1 item is greater than or equal to the Op2 item. + + procedure Sort (N : Natural; Move : Move_Procedure; Lt : Lt_Function); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is not + -- stable, i.e. the order of equal elements in the input is not preserved. + +end GNAT.Heap_Sort_A; diff --git a/gcc/ada/libgnat/g-hesorg.adb b/gcc/ada/libgnat/g-hesorg.adb new file mode 100644 index 0000000..a31a219 --- /dev/null +++ b/gcc/ada/libgnat/g-hesorg.adb @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Heap_Sort_G is + + ---------- + -- Sort -- + ---------- + + -- We are using the classical heapsort algorithm (i.e. Floyd's Treesort3) + -- as described by Knuth ("The Art of Programming", Volume III, first + -- edition, section 5.2.3, p. 145-147) with the modification that is + -- mentioned in exercise 18. For more details on this algorithm, see + -- Robert B. K. Dewar PhD thesis "The use of Computers in the X-ray + -- Phase Problem". University of Chicago, 1968, which was the first + -- publication of the modification, which reduces the number of compares + -- from 2NlogN to NlogN. + + procedure Sort (N : Natural) is + + Max : Natural := N; + -- Current Max index in tree being sifted + + procedure Sift (S : Positive); + -- This procedure sifts up node S, i.e. converts the subtree rooted + -- at node S into a heap, given the precondition that any sons of + -- S are already heaps. On entry, the contents of node S is found + -- in the temporary (index 0), the actual contents of node S on + -- entry are irrelevant. This is just a minor optimization to avoid + -- what would otherwise be two junk moves in phase two of the sort. + + ---------- + -- Sift -- + ---------- + + procedure Sift (S : Positive) is + C : Positive := S; + Son : Positive; + Father : Positive; + -- Note: by making the above all Positive, we ensure that a test + -- against zero for the temporary location can be resolved on the + -- basis of types when the routines are inlined. + + begin + -- This is where the optimization is done, normally we would do a + -- comparison at each stage between the current node and the larger + -- of the two sons, and continue the sift only if the current node + -- was less than this maximum. In this modified optimized version, + -- we assume that the current node will be less than the larger + -- son, and unconditionally sift up. Then when we get to the bottom + -- of the tree, we check parents to make sure that we did not make + -- a mistake. This roughly cuts the number of comparisons in half, + -- since it is almost always the case that our assumption is correct. + + -- Loop to pull up larger sons + + loop + Son := 2 * C; + + if Son < Max then + if Lt (Son, Son + 1) then + Son := Son + 1; + end if; + elsif Son > Max then + exit; + end if; + + Move (Son, C); + C := Son; + end loop; + + -- Loop to check fathers + + while C /= S loop + Father := C / 2; + + if Lt (Father, 0) then + Move (Father, C); + C := Father; + else + exit; + end if; + end loop; + + -- Last step is to pop the sifted node into place + + Move (0, C); + end Sift; + + -- Start of processing for Sort + + begin + -- Phase one of heapsort is to build the heap. This is done by + -- sifting nodes N/2 .. 1 in sequence. + + for J in reverse 1 .. N / 2 loop + Move (J, 0); + Sift (J); + end loop; + + -- In phase 2, the largest node is moved to end, reducing the size + -- of the tree by one, and the displaced node is sifted down from + -- the top, so that the largest node is again at the top. + + while Max > 1 loop + Move (Max, 0); + Move (1, Max); + Max := Max - 1; + Sift (1); + end loop; + + end Sort; + +end GNAT.Heap_Sort_G; diff --git a/gcc/ada/libgnat/g-hesorg.ads b/gcc/ada/libgnat/g-hesorg.ads new file mode 100644 index 0000000..67965bb --- /dev/null +++ b/gcc/ada/libgnat/g-hesorg.ads @@ -0,0 +1,88 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H E A P _ S O R T _ G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Heapsort generic package using formal procedures + +-- This package provides a generic heapsort routine that can be used with +-- different types of data. + +-- See also GNAT.Heap_Sort, a version that works with subprogram access +-- parameters, allowing code sharing. The generic version is slightly more +-- efficient but does not allow code sharing and has an interface that is +-- more awkward to use. + +-- There is also GNAT.Heap_Sort_A, which is now considered obsolete, but +-- was an older version working with subprogram parameters. This version +-- is retained for backwards compatibility with old versions of GNAT. + +-- This heapsort algorithm uses approximately N*log(N) compares in the +-- worst case and is in place with no additional storage required. See +-- the body for exact details of the algorithm used. + +generic + -- The data to be sorted is assumed to be indexed by integer values from + -- 1 to N, where N is the number of items to be sorted. In addition, the + -- index value zero is used for a temporary location used during the sort. + + with procedure Move (From : Natural; To : Natural); + -- A procedure that moves the data item with index value From to the data + -- item with index value To (the old value in To being lost). An index + -- value of zero is used for moves from and to a single temporary location. + -- For best efficiency, this routine should be marked as inlined. + + with function Lt (Op1, Op2 : Natural) return Boolean; + -- A function that compares two items and returns True if the item with + -- index Op1 is less than the item with Index Op2, and False if the Op1 + -- item is greater than the Op2 item. If the two items are equal, then + -- it does not matter whether True or False is returned (it is slightly + -- more efficient to return False). For best efficiency, this routine + -- should be marked as inlined. + + -- Note on use of temporary location + + -- There are two ways of providing for the index value zero to represent + -- a temporary value. Either an extra location can be allocated at the + -- start of the array, or alternatively the Move and Lt subprograms can + -- test for the case of zero and treat it specially. In any case it is + -- desirable to specify the two subprograms as inlined and the tests for + -- zero will in this case be resolved at instantiation time. + +package GNAT.Heap_Sort_G is + pragma Pure; + + procedure Sort (N : Natural); + -- This procedures sorts items in the range from 1 to N into ascending + -- order making calls to Lt to do required comparisons, and Move to move + -- items around. Note that, as described above, both Move and Lt use a + -- single temporary location with index value zero. This sort is not + -- stable, i.e. the order of equal elements in the input is not preserved. + +end GNAT.Heap_Sort_G; diff --git a/gcc/ada/libgnat/g-htable.adb b/gcc/ada/libgnat/g-htable.adb new file mode 100644 index 0000000..633df39 --- /dev/null +++ b/gcc/ada/libgnat/g-htable.adb @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H T A B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a dummy body, required because if we remove the body we have +-- bootstrap path problems (this unit used to have a body, and if we do not +-- supply a dummy body, the old incorrect body is picked up during the +-- bootstrap process). + +pragma Compiler_Unit_Warning; + +package body GNAT.HTable is +end GNAT.HTable; diff --git a/gcc/ada/libgnat/g-htable.ads b/gcc/ada/libgnat/g-htable.ads new file mode 100644 index 0000000..c71d2c9 --- /dev/null +++ b/gcc/ada/libgnat/g-htable.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . H T A B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Hash table searching routines + +-- This package contains two separate packages. The Simple_HTable package +-- provides a very simple abstraction that associates one element to one +-- key value and takes care of all allocations automatically using the heap. +-- The Static_HTable package provides a more complex interface that allows +-- complete control over allocation. + +-- See file s-htable.ads for full documentation of the interface + +pragma Compiler_Unit_Warning; + +with System.HTable; + +package GNAT.HTable is + pragma Preelaborate; + pragma Elaborate_Body; + -- The elaborate body is because we have a dummy body to deal with + -- bootstrap path problems (we used to have a real body, and now we don't + -- need it any more, but the bootstrap requires that we have a dummy body, + -- since otherwise the old body gets picked up; also, we can't use pragma + -- No_Body because older bootstrap compilers don't support that). + + generic package Simple_HTable renames System.HTable.Simple_HTable; + generic package Static_HTable renames System.HTable.Static_HTable; + + generic function Hash renames System.HTable.Hash; + +end GNAT.HTable; diff --git a/gcc/ada/libgnat/g-io-put-vxworks.adb b/gcc/ada/libgnat/g-io-put-vxworks.adb new file mode 100644 index 0000000..65ee8db --- /dev/null +++ b/gcc/ada/libgnat/g-io-put-vxworks.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- vxworks zfp version of Put (C : Character) + +with Interfaces.C; use Interfaces.C; + +separate (GNAT.IO) +procedure Put (C : Character) is + + function ioGlobalStdGet + (File : int) return int; + pragma Import (C, ioGlobalStdGet, "ioGlobalStdGet"); + + procedure fdprintf + (File : int; + Format : String; + Value : Character); + pragma Import (C, fdprintf, "fdprintf"); + + Stdout_ID : constant int := 1; + +begin + fdprintf (ioGlobalStdGet (Stdout_ID), "%c" & ASCII.NUL, C); +end Put; diff --git a/gcc/ada/libgnat/g-io.adb b/gcc/ada/libgnat/g-io.adb new file mode 100644 index 0000000..765d07f --- /dev/null +++ b/gcc/ada/libgnat/g-io.adb @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.IO is + + Current_Out : File_Type := Stdout; + pragma Atomic (Current_Out); + -- Current output file (modified by Set_Output) + + --------- + -- Get -- + --------- + + procedure Get (X : out Integer) is + function Get_Int return Integer; + pragma Import (C, Get_Int, "get_int"); + begin + X := Get_Int; + end Get; + + procedure Get (C : out Character) is + function Get_Char return Character; + pragma Import (C, Get_Char, "get_char"); + begin + C := Get_Char; + end Get; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line (Item : out String; Last : out Natural) is + C : Character; + + begin + for Nstore in Item'Range loop + Get (C); + + if C = ASCII.LF then + Last := Nstore - 1; + return; + + else + Item (Nstore) := C; + end if; + end loop; + + Last := Item'Last; + end Get_Line; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (File : File_Type; Spacing : Positive := 1) is + begin + for J in 1 .. Spacing loop + Put (File, ASCII.LF); + end loop; + end New_Line; + + procedure New_Line (Spacing : Positive := 1) is + begin + New_Line (Current_Out, Spacing); + end New_Line; + + --------- + -- Put -- + --------- + + procedure Put (X : Integer) is + begin + Put (Current_Out, X); + end Put; + + procedure Put (File : File_Type; X : Integer) is + procedure Put_Int (X : Integer); + pragma Import (C, Put_Int, "put_int"); + + procedure Put_Int_Stderr (X : Integer); + pragma Import (C, Put_Int_Stderr, "put_int_stderr"); + + begin + case File is + when Stdout => Put_Int (X); + when Stderr => Put_Int_Stderr (X); + end case; + end Put; + + procedure Put (C : Character) is + begin + Put (Current_Out, C); + end Put; + + procedure Put (File : File_Type; C : Character) is + procedure Put_Char (C : Character); + pragma Import (C, Put_Char, "put_char"); + + procedure Put_Char_Stderr (C : Character); + pragma Import (C, Put_Char_Stderr, "put_char_stderr"); + + begin + case File is + when Stdout => Put_Char (C); + when Stderr => Put_Char_Stderr (C); + end case; + end Put; + + procedure Put (S : String) is + begin + Put (Current_Out, S); + end Put; + + procedure Put (File : File_Type; S : String) is + begin + for J in S'Range loop + Put (File, S (J)); + end loop; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + Put_Line (Current_Out, S); + end Put_Line; + + procedure Put_Line (File : File_Type; S : String) is + begin + Put (File, S); + New_Line (File); + end Put_Line; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + Current_Out := File; + end Set_Output; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Stdout; + end Standard_Output; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Stderr; + end Standard_Error; + +end GNAT.IO; diff --git a/gcc/ada/libgnat/g-io.ads b/gcc/ada/libgnat/g-io.ads new file mode 100644 index 0000000..016d40b --- /dev/null +++ b/gcc/ada/libgnat/g-io.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- A simple preelaborable subset of Text_IO capabilities + +-- A simple text I/O package that can be used for simple I/O functions in +-- user programs as required. This package is also preelaborated, unlike +-- Text_IO, and can thus be with'ed by preelaborated library units. + +-- Note that Data_Error is not raised by these subprograms for bad data. +-- If such checks are needed then the regular Text_IO package must be used. + +package GNAT.IO is + pragma Preelaborate; + + type File_Type is limited private; + -- Specifies file to be used (the only possibilities are Standard_Output + -- and Standard_Error). There is no Create or Open facility that would + -- allow more general use of file names. + + function Standard_Output return File_Type; + function Standard_Error return File_Type; + -- These functions are the only way to get File_Type values + + procedure Get (X : out Integer); + procedure Get (C : out Character); + procedure Get_Line (Item : out String; Last : out Natural); + -- These routines always read from Standard_Input + + procedure Put (File : File_Type; X : Integer); + procedure Put (X : Integer); + -- Output integer to specified file, or to current output file, same + -- output as if Ada.Text_IO.Integer_IO had been instantiated for Integer. + + procedure Put (File : File_Type; C : Character); + procedure Put (C : Character); + -- Output character to specified file, or to current output file + + procedure Put (File : File_Type; S : String); + procedure Put (S : String); + -- Output string to specified file, or to current output file + + procedure Put_Line (File : File_Type; S : String); + procedure Put_Line (S : String); + -- Output string followed by new line to specified file, or to + -- current output file. + + procedure New_Line (File : File_Type; Spacing : Positive := 1); + procedure New_Line (Spacing : Positive := 1); + -- Output new line character to specified file, or to current output file + + procedure Set_Output (File : File_Type); + -- Set current output file, default is Standard_Output if no call to + -- Set_Output is made. + +private + type File_Type is (Stdout, Stderr); + -- Stdout = Standard_Output, Stderr = Standard_Error + + pragma Inline (Standard_Error); + pragma Inline (Standard_Output); + +end GNAT.IO; diff --git a/gcc/ada/libgnat/g-io_aux.adb b/gcc/ada/libgnat/g-io_aux.adb new file mode 100644 index 0000000..1e5c27d --- /dev/null +++ b/gcc/ada/libgnat/g-io_aux.adb @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O _ A U X -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C_Streams; use Interfaces.C_Streams; + +package body GNAT.IO_Aux is + + Buflen : constant := 2000; + -- Buffer length. Works for any non-zero value, larger values take + -- more stack space, smaller values require more recursion. + + ----------------- + -- File_Exists -- + ----------------- + + function File_Exists (Name : String) return Boolean + is + Namestr : aliased String (1 .. Name'Length + 1); + -- Name as given with ASCII.NUL appended + + begin + Namestr (1 .. Name'Length) := Name; + Namestr (Name'Length + 1) := ASCII.NUL; + return file_exists (Namestr'Address) /= 0; + end File_Exists; + + -------------- + -- Get_Line -- + -------------- + + -- Current_Input case + + function Get_Line return String is + Buffer : String (1 .. Buflen); + -- Buffer to read in chunks of remaining line. Will work with any + -- size buffer. We choose a length so that most of the time no + -- recursion will be required. + + Last : Natural; + + begin + Ada.Text_IO.Get_Line (Buffer, Last); + + -- If the buffer is not full, then we are all done + + if Last < Buffer'Last then + return Buffer (1 .. Last); + + -- Otherwise, we still have characters left on the line. Note that + -- as specified by (RM A.10.7(19)) the end of line is not skipped + -- in this case, even if we are right at it now. + + else + return Buffer & GNAT.IO_Aux.Get_Line; + end if; + end Get_Line; + + -- Case of reading from a specified file. Note that we could certainly + -- share code between these two versions, but these are very short + -- routines, and we may as well aim for maximum speed, cutting out an + -- intermediate call (calls returning string may be somewhat slow) + + function Get_Line (File : Ada.Text_IO.File_Type) return String is + Buffer : String (1 .. Buflen); + Last : Natural; + + begin + Ada.Text_IO.Get_Line (File, Buffer, Last); + + if Last < Buffer'Last then + return Buffer (1 .. Last); + else + return Buffer & Get_Line (File); + end if; + end Get_Line; + +end GNAT.IO_Aux; diff --git a/gcc/ada/libgnat/g-io_aux.ads b/gcc/ada/libgnat/g-io_aux.ads new file mode 100644 index 0000000..0724286 --- /dev/null +++ b/gcc/ada/libgnat/g-io_aux.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . I O _ A U X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Auxiliary functions or use with Text_IO + +-- This package provides some auxiliary functions for use with Text_IO, +-- including a test for an existing file, and a Get_Line function which +-- returns a string. + +with Ada.Text_IO; + +package GNAT.IO_Aux is + + function File_Exists (Name : String) return Boolean; + -- Test for existence of a file named Name + + function Get_Line return String; + -- Read Ada.Text_IO.Current_Input and return string that includes all + -- characters from the current character up to the end of the line, + -- with no limit on its length. Raises Ada.IO_Exceptions.End_Error if + -- at end of file. + + function Get_Line (File : Ada.Text_IO.File_Type) return String; + -- Same, but reads from specified file + +end GNAT.IO_Aux; diff --git a/gcc/ada/libgnat/g-locfil.adb b/gcc/ada/libgnat/g-locfil.adb new file mode 100644 index 0000000..5e6d06b --- /dev/null +++ b/gcc/ada/libgnat/g-locfil.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . L O C K _ F I L E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; + +package body GNAT.Lock_Files is + + Dir_Separator : Character; + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + + --------------- + -- Lock_File -- + --------------- + + procedure Lock_File + (Directory : Path_Name; + Lock_File_Name : Path_Name; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last) + is + Dir : aliased String := Directory & ASCII.NUL; + File : aliased String := Lock_File_Name & ASCII.NUL; + + function Try_Lock (Dir, File : System.Address) return Integer; + pragma Import (C, Try_Lock, "__gnat_try_lock"); + + begin + -- If a directory separator was provided, just remove the one we have + -- added above. + + if Directory (Directory'Last) = Dir_Separator + or else Directory (Directory'Last) = '/' + then + Dir (Dir'Last - 1) := ASCII.NUL; + end if; + + -- Try to lock the file Retries times + + for I in 0 .. Retries loop + if Try_Lock (Dir'Address, File'Address) = 1 then + return; + end if; + + exit when I = Retries; + delay Wait; + end loop; + + raise Lock_Error; + end Lock_File; + + --------------- + -- Lock_File -- + --------------- + + procedure Lock_File + (Lock_File_Name : Path_Name; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last) + is + begin + for J in reverse Lock_File_Name'Range loop + if Lock_File_Name (J) = Dir_Separator + or else Lock_File_Name (J) = '/' + then + Lock_File + (Lock_File_Name (Lock_File_Name'First .. J - 1), + Lock_File_Name (J + 1 .. Lock_File_Name'Last), + Wait, + Retries); + return; + end if; + end loop; + + Lock_File (".", Lock_File_Name, Wait, Retries); + end Lock_File; + + ----------------- + -- Unlock_File -- + ----------------- + + procedure Unlock_File (Lock_File_Name : Path_Name) is + S : aliased String := Lock_File_Name & ASCII.NUL; + + procedure unlink (A : System.Address); + pragma Import (C, unlink, "unlink"); + + begin + unlink (S'Address); + end Unlock_File; + + ----------------- + -- Unlock_File -- + ----------------- + + procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name) is + begin + if Directory (Directory'Last) = Dir_Separator + or else Directory (Directory'Last) = '/' + then + Unlock_File (Directory & Lock_File_Name); + else + Unlock_File (Directory & Dir_Separator & Lock_File_Name); + end if; + end Unlock_File; + +end GNAT.Lock_Files; diff --git a/gcc/ada/libgnat/g-locfil.ads b/gcc/ada/libgnat/g-locfil.ads new file mode 100644 index 0000000..e866588 --- /dev/null +++ b/gcc/ada/libgnat/g-locfil.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . L O C K _ F I L E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the necessary routines for using files for the +-- purpose of providing reliable system wide locking capability. + +package GNAT.Lock_Files is + pragma Preelaborate; + + Lock_Error : exception; + -- Exception raised if file cannot be locked + + subtype Path_Name is String; + -- Pathname is used by all services provided in this unit to specify + -- directory name and file name. On DOS based systems both directory + -- separators are handled (i.e. slash and backslash). + + procedure Lock_File + (Directory : Path_Name; + Lock_File_Name : Path_Name; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last); + -- Create a lock file Lock_File_Name in directory Directory. If the file + -- cannot be locked because someone already owns the lock, this procedure + -- waits Wait seconds and retries at most Retries times. If the file + -- still cannot be locked, Lock_Error is raised. The default is to try + -- every second, almost forever (Natural'Last times). The full path of + -- the file is constructed by concatenating Directory and Lock_File_Name. + -- Directory can optionally terminate with a directory separator. + + procedure Lock_File + (Lock_File_Name : Path_Name; + Wait : Duration := 1.0; + Retries : Natural := Natural'Last); + -- See above. The full lock file path is given as one string + + procedure Unlock_File (Directory : Path_Name; Lock_File_Name : Path_Name); + -- Unlock a file. Directory can optionally terminate with a directory + -- separator. + + procedure Unlock_File (Lock_File_Name : Path_Name); + -- Unlock a file whose full path is given in Lock_File_Name + +end GNAT.Lock_Files; diff --git a/gcc/ada/libgnat/g-mbdira.adb b/gcc/ada/libgnat/g-mbdira.adb new file mode 100644 index 0000000..33fc9d7 --- /dev/null +++ b/gcc/ada/libgnat/g-mbdira.adb @@ -0,0 +1,282 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +with Interfaces; use Interfaces; + +package body GNAT.MBBS_Discrete_Random is + + package Calendar renames Ada.Calendar; + + Fits_In_32_Bits : constant Boolean := + Rst'Size < 31 + or else (Rst'Size = 31 + and then Rst'Pos (Rst'First) < 0); + -- This is set True if we do not need more than 32 bits in the result. If + -- we need 64-bits, we will only use the meaningful 48 bits of any 64-bit + -- number generated, since if more than 48 bits are required, we split the + -- computation into two separate parts, since the algorithm does not behave + -- above 48 bits. + + -- The way this expression works is that obviously if the size is 31 bits, + -- it fits in 32 bits. In the 32-bit case, it fits in 32-bit signed if the + -- range has negative values. It is too conservative in the case that the + -- programmer has set a size greater than the default, e.g. a size of 33 + -- for an integer type with a range of 1..10, but an over-conservative + -- result is OK. The important thing is that the value is only True if + -- we know the result will fit in 32-bits signed. If the value is False + -- when it could be True, the behavior will be correct, just a bit less + -- efficient than it could have been in some unusual cases. + -- + -- One might assume that we could get a more accurate result by testing + -- the lower and upper bounds of the type Rst against the bounds of 32-bit + -- Integer. However, there is no easy way to do that. Why? Because in the + -- relatively rare case where this expression has to be evaluated at run + -- time rather than compile time (when the bounds are dynamic), we need a + -- type to use for the computation. But the possible range of upper bound + -- values for Rst (remembering the possibility of 64-bit modular types) is + -- from -2**63 to 2**64-1, and no run-time type has a big enough range. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Square_Mod_N (X, N : Int) return Int; + pragma Inline (Square_Mod_N); + -- Computes X**2 mod N avoiding intermediate overflow + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & + ',' & + Int'Image (Of_State.X2) & + ',' & + Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Rst is + S : State renames Gen.Writable.Self.Gen_State; + Temp : Int; + TF : Flt; + + begin + -- Check for flat range here, since we are typically run with checks + -- off, note that in practice, this condition will usually be static + -- so we will not actually generate any code for the normal case. + + if Rst'Last < Rst'First then + raise Constraint_Error; + end if; + + -- Continue with computation if non-flat range + + S.X1 := Square_Mod_N (S.X1, S.P); + S.X2 := Square_Mod_N (S.X2, S.Q); + Temp := S.X2 - S.X1; + + -- Following duplication is not an error, it is a loop unwinding + + if Temp < 0 then + Temp := Temp + S.Q; + end if; + + if Temp < 0 then + Temp := Temp + S.Q; + end if; + + TF := Offs + (Flt (Temp) * Flt (S.P) + Flt (S.X1)) * S.Scl; + + -- Pathological, but there do exist cases where the rounding implicit + -- in calculating the scale factor will cause rounding to 'Last + 1. + -- In those cases, returning 'First results in the least bias. + + if TF >= Flt (Rst'Pos (Rst'Last)) + 0.5 then + return Rst'First; + + elsif not Fits_In_32_Bits then + return Rst'Val (Interfaces.Integer_64 (TF)); + + else + return Rst'Val (Int (TF)); + end if; + end Random; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; Initiator : Integer) is + S : State renames Gen.Writable.Self.Gen_State; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + -- Eliminate effects of small Initiators + + S := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator) is + S : State renames Gen.Writable.Self.Gen_State; + Now : constant Calendar.Time := Calendar.Clock; + X1 : Int; + X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now) * 31) + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + S := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + FP => K1F, + Scl => Scal); + + end Reset; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator; From_State : State) is + begin + Gen.Writable.Self.Gen_State := From_State; + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + begin + return Int ((Integer_64 (X) ** 2) mod (Integer_64 (N))); + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Last : constant Natural := Coded_State'Last; + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Stop <= Last and then Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); + Outs.P := Outs.Q * 2 + 1; + Outs.FP := Flt (Outs.P); + Outs.Scl := (RstL - RstF + 1.0) / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks + + if Outs.Q < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; + +end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/libgnat/g-mbdira.ads b/gcc/ada/libgnat/g-mbdira.ads new file mode 100644 index 0000000..8d61965 --- /dev/null +++ b/gcc/ada/libgnat/g-mbdira.ads @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ D I S C R E T E _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation used in this package was contributed by Robert +-- Eachus. It is based on the work of L. Blum, M. Blum, and M. Shub, SIAM +-- Journal of Computing, Vol 15. No 2, May 1986. The particular choices for P +-- and Q chosen here guarantee a period of 562,085,314,430,582 (about 2**49), +-- and the generated sequence has excellent randomness properties. For further +-- details, see the paper "Fast Generation of Trustworthy Random Numbers", by +-- Robert Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. + +-- Formerly, this package was Ada.Numerics.Discrete_Random. It is retained +-- here in part to allow users to reconstruct number sequences generated +-- by previous versions. + +with Interfaces; + +generic + type Result_Subtype is (<>); + +package GNAT.MBBS_Discrete_Random is + + -- The algorithm used here is reliable from a required statistical point of + -- view only up to 48 bits. We try to behave reasonably in the case of + -- larger types, but we can't guarantee the required properties. So + -- generate a warning for these (slightly) dubious cases. + + pragma Compile_Time_Warning + (Result_Subtype'Size > 48, + "statistical properties not guaranteed for size > 48"); + + -- Basic facilities + + type Generator is limited private; + + function Random (Gen : Generator) return Result_Subtype; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + subtype Int is Interfaces.Integer_32; + subtype Rst is Result_Subtype; + + -- We prefer to use 14 digits for Flt, but some targets are more limited + + type Flt is digits Positive'Min (14, Long_Long_Float'Digits); + + RstF : constant Flt := Flt (Rst'Pos (Rst'First)); + RstL : constant Flt := Flt (Rst'Pos (Rst'Last)); + + Offs : constant Flt := RstF - 0.5; + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant Flt := (RstL - RstF + 1.0) / (K1F * K2F); + + type State is record + X1 : Int := Int (2999 ** 2); + X2 : Int := Int (1439 ** 2); + P : Int := K1; + Q : Int := K2; + FP : Flt := K1F; + Scl : Flt := Scal; + end record; + + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + Gen_State : State; + end record; + +end GNAT.MBBS_Discrete_Random; diff --git a/gcc/ada/libgnat/g-mbflra.adb b/gcc/ada/libgnat/g-mbflra.adb new file mode 100644 index 0000000..e4537de --- /dev/null +++ b/gcc/ada/libgnat/g-mbflra.adb @@ -0,0 +1,314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ F L O A T _ R A N D O M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Calendar; + +package body GNAT.MBBS_Float_Random is + + ------------------------- + -- Implementation Note -- + ------------------------- + + -- The design of this spec is a bit awkward, as a result of Ada 95 not + -- permitting in-out parameters for function formals (most naturally + -- Generator values would be passed this way). In pure Ada 95, the only + -- solution would be to add a self-referential component to the generator + -- allowing access to the generator object from inside the function. This + -- would work because the generator is limited, which prevents any copy. + + -- This is a bit heavy, so what we do is to use Unrestricted_Access to + -- get a pointer to the state in the passed Generator. This works because + -- Generator is a limited type and will thus always be passed by reference. + + package Calendar renames Ada.Calendar; + + type Pointer is access all State; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int); + + function Euclid (P, Q : Int) return Int; + + function Square_Mod_N (X, N : Int) return Int; + + ------------ + -- Euclid -- + ------------ + + procedure Euclid (P, Q : Int; X, Y : out Int; GCD : out Int) is + + XT : Int := 1; + YT : Int := 0; + + procedure Recur + (P, Q : Int; -- a (i-1), a (i) + X, Y : Int; -- x (i), y (i) + XP, YP : in out Int; -- x (i-1), y (i-1) + GCD : out Int); + + procedure Recur + (P, Q : Int; + X, Y : Int; + XP, YP : in out Int; + GCD : out Int) + is + Quo : Int := P / Q; -- q <-- |_ a (i-1) / a (i) _| + XT : Int := X; -- x (i) + YT : Int := Y; -- y (i) + + begin + if P rem Q = 0 then -- while does not divide + GCD := Q; + XP := X; + YP := Y; + else + Recur (Q, P - Q * Quo, XP - Quo * X, YP - Quo * Y, XT, YT, Quo); + + -- a (i) <== a (i) + -- a (i+1) <-- a (i-1) - q*a (i) + -- x (i+1) <-- x (i-1) - q*x (i) + -- y (i+1) <-- y (i-1) - q*y (i) + -- x (i) <== x (i) + -- y (i) <== y (i) + + XP := XT; + YP := YT; + GCD := Quo; + end if; + end Recur; + + -- Start of processing for Euclid + + begin + Recur (P, Q, 0, 1, XT, YT, GCD); + X := XT; + Y := YT; + end Euclid; + + function Euclid (P, Q : Int) return Int is + X, Y, GCD : Int; + pragma Unreferenced (Y, GCD); + begin + Euclid (P, Q, X, Y, GCD); + return X; + end Euclid; + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + begin + return Int'Image (Of_State.X1) & ',' & Int'Image (Of_State.X2) + & ',' & + Int'Image (Of_State.P) & ',' & Int'Image (Of_State.Q); + end Image; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Uniformly_Distributed is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.X1 := Square_Mod_N (Genp.X1, Genp.P); + Genp.X2 := Square_Mod_N (Genp.X2, Genp.Q); + return + Float ((Flt (((Genp.X2 - Genp.X1) * Genp.X) + mod Genp.Q) * Flt (Genp.P) + + Flt (Genp.X1)) * Genp.Scl); + end Random; + + ----------- + -- Reset -- + ----------- + + -- Version that works from given initiator value + + procedure Reset (Gen : Generator; Initiator : Integer) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + X1, X2 : Int; + + begin + X1 := 2 + Int (Initiator) mod (K1 - 3); + X2 := 2 + Int (Initiator) mod (K2 - 3); + + -- Eliminate effects of small initiators + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + end Reset; + + -- Version that works from specific saved state + + procedure Reset (Gen : Generator; From_State : State) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + + begin + Genp.all := From_State; + end Reset; + + -- Version that works from calendar + + procedure Reset (Gen : Generator) is + Genp : constant Pointer := Gen.Gen_State'Unrestricted_Access; + Now : constant Calendar.Time := Calendar.Clock; + X1, X2 : Int; + + begin + X1 := Int (Calendar.Year (Now)) * 12 * 31 + + Int (Calendar.Month (Now)) * 31 + + Int (Calendar.Day (Now)); + + X2 := Int (Calendar.Seconds (Now) * Duration (1000.0)); + + X1 := 2 + X1 mod (K1 - 3); + X2 := 2 + X2 mod (K2 - 3); + + -- Eliminate visible effects of same day starts + + for J in 1 .. 5 loop + X1 := Square_Mod_N (X1, K1); + X2 := Square_Mod_N (X2, K2); + end loop; + + Genp.all := + (X1 => X1, + X2 => X2, + P => K1, + Q => K2, + X => 1, + Scl => Scal); + + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + begin + To_State := Gen.Gen_State; + end Save; + + ------------------ + -- Square_Mod_N -- + ------------------ + + function Square_Mod_N (X, N : Int) return Int is + Temp : constant Flt := Flt (X) * Flt (X); + Div : Int; + + begin + Div := Int (Temp / Flt (N)); + Div := Int (Temp - Flt (Div) * Flt (N)); + + if Div < 0 then + return Div + N; + else + return Div; + end if; + end Square_Mod_N; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Last : constant Natural := Coded_State'Last; + Start : Positive := Coded_State'First; + Stop : Positive := Coded_State'First; + Outs : State; + + begin + while Stop <= Last and then Coded_State (Stop) /= ',' loop + Stop := Stop + 1; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X1 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.X2 := Int'Value (Coded_State (Start .. Stop - 1)); + Start := Stop + 1; + + loop + Stop := Stop + 1; + exit when Stop > Last or else Coded_State (Stop) = ','; + end loop; + + if Stop > Last then + raise Constraint_Error; + end if; + + Outs.P := Int'Value (Coded_State (Start .. Stop - 1)); + Outs.Q := Int'Value (Coded_State (Stop + 1 .. Last)); + Outs.X := Euclid (Outs.P, Outs.Q); + Outs.Scl := 1.0 / (Flt (Outs.P) * Flt (Outs.Q)); + + -- Now do *some* sanity checks + + if Outs.Q < 31 or else Outs.P < 31 + or else Outs.X1 not in 2 .. Outs.P - 1 + or else Outs.X2 not in 2 .. Outs.Q - 1 + then + raise Constraint_Error; + end if; + + return Outs; + end Value; +end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/libgnat/g-mbflra.ads b/gcc/ada/libgnat/g-mbflra.ads new file mode 100644 index 0000000..f662173 --- /dev/null +++ b/gcc/ada/libgnat/g-mbflra.ads @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M B B S _ F L O A T _ R A N D O M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation used in this package was contributed by +-- Robert Eachus. It is based on the work of L. Blum, M. Blum, and +-- M. Shub, SIAM Journal of Computing, Vol 15. No 2, May 1986. The +-- particular choices for P and Q chosen here guarantee a period of +-- 562,085,314,430,582 (about 2**49), and the generated sequence has +-- excellent randomness properties. For further details, see the +-- paper "Fast Generation of Trustworthy Random Numbers", by Robert +-- Eachus, which describes both the algorithm and the efficient +-- implementation approach used here. + +-- Formerly, this package was Ada.Numerics.Float_Random. It is retained +-- here in part to allow users to reconstruct number sequences generated +-- by previous versions. + +with Interfaces; + +package GNAT.MBBS_Float_Random is + + -- Basic facilities + + type Generator is limited private; + + subtype Uniformly_Distributed is Float range 0.0 .. 1.0; + + function Random (Gen : Generator) return Uniformly_Distributed; + + procedure Reset (Gen : Generator); + procedure Reset (Gen : Generator; Initiator : Integer); + + -- Advanced facilities + + type State is private; + + procedure Save (Gen : Generator; To_State : out State); + procedure Reset (Gen : Generator; From_State : State); + + Max_Image_Width : constant := 80; + + function Image (Of_State : State) return String; + function Value (Coded_State : String) return State; + +private + type Int is new Interfaces.Integer_32; + + -- We prefer to use 14 digits for Flt, but some targets are more limited + + type Flt is digits Positive'Min (14, Long_Long_Float'Digits); + + K1 : constant := 94_833_359; + K1F : constant := 94_833_359.0; + K2 : constant := 47_416_679; + K2F : constant := 47_416_679.0; + Scal : constant := 1.0 / (K1F * K2F); + + type State is record + X1 : Int := 2999 ** 2; -- Square mod p + X2 : Int := 1439 ** 2; -- Square mod q + P : Int := K1; + Q : Int := K2; + X : Int := 1; + Scl : Flt := Scal; + end record; + + type Generator is limited record + Gen_State : State; + end record; + +end GNAT.MBBS_Float_Random; diff --git a/gcc/ada/libgnat/g-md5.adb b/gcc/ada/libgnat/g-md5.adb new file mode 100644 index 0000000..76ff535 --- /dev/null +++ b/gcc/ada/libgnat/g-md5.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M D 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-md5.ads b/gcc/ada/libgnat/g-md5.ads new file mode 100644 index 0000000..6867b5c --- /dev/null +++ b/gcc/ada/libgnat/g-md5.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M D 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the MD5 Message-Digest Algorithm as described in +-- RFC 1321. The complete text of RFC 1321 can be found at: +-- http://www.ietf.org/rfc/rfc1321.txt + +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. + +with GNAT.Secure_Hashes.MD5; +with System; + +package GNAT.MD5 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.MD5.Block_Words, + State_Words => 4, + Hash_Words => 4, + Hash_Bit_Order => System.Low_Order_First, + Hash_State => GNAT.Secure_Hashes.MD5.Hash_State, + Initial_State => GNAT.Secure_Hashes.MD5.Initial_State, + Transform => GNAT.Secure_Hashes.MD5.Transform); diff --git a/gcc/ada/libgnat/g-memdum.adb b/gcc/ada/libgnat/g-memdum.adb new file mode 100644 index 0000000..3cc8be1 --- /dev/null +++ b/gcc/ada/libgnat/g-memdum.adb @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M E M O R Y _ D U M P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Img_BIU; use System.Img_BIU; +with System.Storage_Elements; use System.Storage_Elements; + +with GNAT.IO; use GNAT.IO; +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; + +with Ada.Unchecked_Conversion; + +package body GNAT.Memory_Dump is + + ---------- + -- Dump -- + ---------- + + procedure Dump + (Addr : Address; + Count : Natural) + is + begin + Dump (Addr, Count, Prefix => Absolute_Address); + end Dump; + + procedure Dump + (Addr : Address; + Count : Natural; + Prefix : Prefix_Type) + is + Ctr : Natural := Count; + -- Count of bytes left to output + + Offset_Buf : String (1 .. Standard'Address_Size / 4 + 4); + Offset_Last : Natural; + -- Buffer for prefix in Offset mode + + Adr : Address := Addr; + -- Current address + + N : Natural := 0; + -- Number of bytes output on current line + + C : Character; + -- Character at current storage address + + AIL : Natural; + -- Number of chars in prefix (including colon and space) + + Line_Len : Natural; + -- Line length for entire line + + Hex : constant array (0 .. 15) of Character := "0123456789ABCDEF"; + + type Char_Ptr is access all Character; + + function To_Char_Ptr is new Ada.Unchecked_Conversion (Address, Char_Ptr); + + begin + case Prefix is + when Absolute_Address => + AIL := Address_Image_Length - 4 + 2; + + when Offset => + Offset_Last := Offset_Buf'First - 1; + Set_Image_Based_Integer (Ctr, 16, 0, Offset_Buf, Offset_Last); + AIL := Offset_Last - 4 + 2; + + when None => + AIL := 0; + end case; + + Line_Len := AIL + 3 * 16 + 2 + 16; + + declare + Line_Buf : String (1 .. Line_Len); + + begin + while Ctr /= 0 loop + + -- Start of line processing + + if N = 0 then + case Prefix is + when Absolute_Address => + declare + S : constant String := Image (Adr); + begin + Line_Buf (1 .. AIL) := S (4 .. S'Length - 1) & ": "; + end; + + when Offset => + declare + Last : Natural := 0; + Len : Natural; + + begin + Set_Image_Based_Integer + (Count - Ctr, 16, 0, Offset_Buf, Last); + Len := Last - 4; + + Line_Buf (1 .. AIL - Len - 2) := (others => '0'); + Line_Buf (AIL - Len - 1 .. AIL - 2) := + Offset_Buf (4 .. Last - 1); + Line_Buf (AIL - 1 .. AIL) := ": "; + end; + + when None => + null; + end case; + + Line_Buf (AIL + 1 .. Line_Buf'Last) := (others => ' '); + Line_Buf (AIL + 3 * 16 + 1) := '"'; + end if; + + -- Add one character to current line + + C := To_Char_Ptr (Adr).all; + Adr := Adr + 1; + Ctr := Ctr - 1; + + Line_Buf (AIL + 3 * N + 1) := Hex (Character'Pos (C) / 16); + Line_Buf (AIL + 3 * N + 2) := Hex (Character'Pos (C) mod 16); + + if C < ' ' or else C = Character'Val (16#7F#) then + C := '?'; + end if; + + Line_Buf (AIL + 3 * 16 + 2 + N) := C; + N := N + 1; + + -- End of line processing + + if N = 16 then + Line_Buf (Line_Buf'Last) := '"'; + GNAT.IO.Put_Line (Line_Buf); + N := 0; + end if; + end loop; + + -- Deal with possible last partial line + + if N /= 0 then + Line_Buf (AIL + 3 * 16 + 2 + N) := '"'; + GNAT.IO.Put_Line (Line_Buf (1 .. AIL + 3 * 16 + 2 + N)); + end if; + end; + end Dump; + +end GNAT.Memory_Dump; diff --git a/gcc/ada/libgnat/g-memdum.ads b/gcc/ada/libgnat/g-memdum.ads new file mode 100644 index 0000000..3150376 --- /dev/null +++ b/gcc/ada/libgnat/g-memdum.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . M E M O R Y _ D U M P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- A routine for dumping memory to either standard output or standard error. +-- Uses GNAT.IO for actual output (use the controls in GNAT.IO to specify +-- the destination of the output, which by default is Standard_Output). + +with System; + +package GNAT.Memory_Dump is + pragma Preelaborate; + + type Prefix_Type is (Absolute_Address, Offset, None); + + procedure Dump + (Addr : System.Address; + Count : Natural); + -- Dumps indicated number (Count) of bytes, starting at the address given + -- by Addr. The coding of this routine in its current form assumes the case + -- of a byte addressable machine (and is therefore inapplicable to machines + -- like the AAMP, where the storage unit is not 8 bits). The output is one + -- or more lines in the following format, which is for the case of 32-bit + -- addresses (64-bit addresses are handled appropriately): + -- + -- 0234_3368: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" + -- + -- All but the last line have 16 bytes. A question mark is used in the + -- string data to indicate a non-printable character. + + procedure Dump + (Addr : System.Address; + Count : Natural; + Prefix : Prefix_Type); + -- Same as above, but allows the selection of different line formats. + -- If Prefix is set to Absolute_Address, the output is identical to the + -- above version, each line starting with the absolute address of the + -- first dumped storage element. + -- + -- If Prefix is set to Offset, then instead each line starts with the + -- indication of the offset relative to Addr: + -- + -- 00: 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" + -- + -- Finally if Prefix is set to None, the prefix is suppressed altogether, + -- and only the memory contents are displayed: + -- + -- 66 67 68 . . . 73 74 75 "fghijklmnopqstuv" + +end GNAT.Memory_Dump; diff --git a/gcc/ada/libgnat/g-moreex.adb b/gcc/ada/libgnat/g-moreex.adb new file mode 100644 index 0000000..5f27772 --- /dev/null +++ b/gcc/ada/libgnat/g-moreex.adb @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions.Is_Null_Occurrence; +with System.Soft_Links; + +package body GNAT.Most_Recent_Exception is + + ---------------- + -- Occurrence -- + ---------------- + + function Occurrence return Ada.Exceptions.Exception_Occurrence is + EOA : constant Ada.Exceptions.Exception_Occurrence_Access := + GNAT.Most_Recent_Exception.Occurrence_Access; + + use type Ada.Exceptions.Exception_Occurrence_Access; + + begin + return Result : Ada.Exceptions.Exception_Occurrence do + if EOA = null then + Ada.Exceptions.Save_Occurrence + (Target => Result, + Source => Ada.Exceptions.Null_Occurrence); + else + Ada.Exceptions.Save_Occurrence + (Target => Result, + Source => EOA.all); + end if; + end return; + end Occurrence; + + ----------------------- + -- Occurrence_Access -- + ----------------------- + + function Occurrence_Access + return Ada.Exceptions.Exception_Occurrence_Access + is + use Ada.Exceptions; + + EOA : constant Exception_Occurrence_Access := + System.Soft_Links.Get_Current_Excep.all; + + begin + if EOA = null then + return null; + + elsif Is_Null_Occurrence (EOA.all) then + return null; + + else + return EOA; + end if; + end Occurrence_Access; + +end GNAT.Most_Recent_Exception; diff --git a/gcc/ada/libgnat/g-moreex.ads b/gcc/ada/libgnat/g-moreex.ads new file mode 100644 index 0000000..f94420c --- /dev/null +++ b/gcc/ada/libgnat/g-moreex.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . M O S T _ R E C E N T _ E X C E P T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines for accessing the most recently raised +-- exception. This may be useful for certain logging activities. It may +-- also be useful for mimicking implementation dependent capabilities in +-- Ada 83 compilers, but see also GNAT.Current_Exceptions for this usage. + +with Ada.Exceptions; +package GNAT.Most_Recent_Exception is + + ----------------- + -- Subprograms -- + ----------------- + + function Occurrence + return Ada.Exceptions.Exception_Occurrence; + -- Returns the Exception_Occurrence for the most recently raised exception + -- in the current task. If no exception has been raised in the current task + -- prior to the call, returns Null_Occurrence. + + function Occurrence_Access + return Ada.Exceptions.Exception_Occurrence_Access; + -- Similar to the above, but returns an access to the occurrence value. + -- This value is in a task specific location, and may be validly accessed + -- as long as no further exception is raised in the calling task. + + -- Note: unlike the routines in GNAT.Current_Exception, these functions + -- access the most recently raised exception, regardless of where they + -- are called. Consider the following example: + + -- exception + -- when Constraint_Error => + -- begin + -- ... + -- exception + -- when Tasking_Error => ... + -- end; + -- + -- -- Assuming a Tasking_Error was raised in the inner block, + -- -- a call to GNAT.Most_Recent_Exception.Occurrence will + -- -- return information about this Tasking_Error exception, + -- -- not about the Constraint_Error exception being handled + -- -- by the current handler code. + +end GNAT.Most_Recent_Exception; diff --git a/gcc/ada/libgnat/g-os_lib.adb b/gcc/ada/libgnat/g-os_lib.adb new file mode 100644 index 0000000..1d69285 --- /dev/null +++ b/gcc/ada/libgnat/g-os_lib.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . O S _ L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-os_lib.ads b/gcc/ada/libgnat/g-os_lib.ads new file mode 100644 index 0000000..5a4b03d --- /dev/null +++ b/gcc/ada/libgnat/g-os_lib.ads @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . O S _ L I B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Operating system interface facilities + +-- This package contains types and procedures for interfacing to the +-- underlying OS. It is used by the GNAT compiler and by tools associated +-- with the GNAT compiler, and therefore works for the various operating +-- systems to which GNAT has been ported. This package will undoubtedly grow +-- as new services are needed by various tools. + +-- This package tends to use fairly low-level Ada in order to not bring in +-- large portions of the RTL. For example, functions return access to string +-- as part of avoiding functions returning unconstrained types. + +-- Except where specifically noted, these routines are portable across all +-- GNAT implementations on all supported operating systems. + +-- See file s-os_lib.ads for full documentation of the interface + +with System.OS_Lib; + +package GNAT.OS_Lib renames System.OS_Lib; diff --git a/gcc/ada/libgnat/g-pehage.adb b/gcc/ada/libgnat/g-pehage.adb new file mode 100644 index 0000000..773512e --- /dev/null +++ b/gcc/ada/libgnat/g-pehage.adb @@ -0,0 +1,2600 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Directories; + +with GNAT.Heap_Sort_G; +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Table; + +package body GNAT.Perfect_Hash_Generators is + + -- We are using the algorithm of J. Czech as described in Zbigniew J. + -- Czech, George Havas, and Bohdan S. Majewski ``An Optimal Algorithm for + -- Generating Minimal Perfect Hash Functions'', Information Processing + -- Letters, 43(1992) pp.257-264, Oct.1992 + + -- This minimal perfect hash function generator is based on random graphs + -- and produces a hash function of the form: + + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + -- where f1 and f2 are functions that map strings into integers, and g is + -- a function that maps integers into [0, m-1]. h can be order preserving. + -- For instance, let W = {w_0, ..., w_i, ..., w_m-1}, h can be defined + -- such that h (w_i) = i. + + -- This algorithm defines two possible constructions of f1 and f2. Method + -- b) stores the hash function in less memory space at the expense of + -- greater CPU time. + + -- a) fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n + + -- size (Tk) = max (for w in W) (length (w)) * size (used char set) + + -- b) fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n + + -- size (Tk) = max (for w in W) (length (w)) but the table lookups are + -- replaced by multiplications. + + -- where Tk values are randomly generated. n is defined later on but the + -- algorithm recommends to use a value a little bit greater than 2m. Note + -- that for large values of m, the main memory space requirements comes + -- from the memory space for storing function g (>= 2m entries). + + -- Random graphs are frequently used to solve difficult problems that do + -- not have polynomial solutions. This algorithm is based on a weighted + -- undirected graph. It comprises two steps: mapping and assignment. + + -- In the mapping step, a graph G = (V, E) is constructed, where = {0, 1, + -- ..., n-1} and E = {(for w in W) (f1 (w), f2 (w))}. In order for the + -- assignment step to be successful, G has to be acyclic. To have a high + -- probability of generating an acyclic graph, n >= 2m. If it is not + -- acyclic, Tk have to be regenerated. + + -- In the assignment step, the algorithm builds function g. As G is + -- acyclic, there is a vertex v1 with only one neighbor v2. Let w_i be + -- the word such that v1 = f1 (w_i) and v2 = f2 (w_i). Let g (v1) = 0 by + -- construction and g (v2) = (i - g (v1)) mod n (or h (i) - g (v1) mod n). + -- If word w_j is such that v2 = f1 (w_j) and v3 = f2 (w_j), g (v3) = (j - + -- g (v2)) mod (or to be general, (h (j) - g (v2)) mod n). If w_i has no + -- neighbor, then another vertex is selected. The algorithm traverses G to + -- assign values to all the vertices. It cannot assign a value to an + -- already assigned vertex as G is acyclic. + + subtype Word_Id is Integer; + subtype Key_Id is Integer; + subtype Vertex_Id is Integer; + subtype Edge_Id is Integer; + subtype Table_Id is Integer; + + No_Vertex : constant Vertex_Id := -1; + No_Edge : constant Edge_Id := -1; + No_Table : constant Table_Id := -1; + + type Word_Type is new String_Access; + procedure Free_Word (W : in out Word_Type) renames Free; + function New_Word (S : String) return Word_Type; + + procedure Resize_Word (W : in out Word_Type; Len : Natural); + -- Resize string W to have a length Len + + type Key_Type is record + Edge : Edge_Id; + end record; + -- A key corresponds to an edge in the algorithm graph + + type Vertex_Type is record + First : Edge_Id; + Last : Edge_Id; + end record; + -- A vertex can be involved in several edges. First and Last are the bounds + -- of an array of edges stored in a global edge table. + + type Edge_Type is record + X : Vertex_Id; + Y : Vertex_Id; + Key : Key_Id; + end record; + -- An edge is a peer of vertices. In the algorithm, a key is associated to + -- an edge. + + package WT is new GNAT.Table (Word_Type, Word_Id, 0, 32, 32); + package IT is new GNAT.Table (Integer, Integer, 0, 32, 32); + -- The two main tables. WT is used to store the words in their initial + -- version and in their reduced version (that is words reduced to their + -- significant characters). As an instance of GNAT.Table, WT does not + -- initialize string pointers to null. This initialization has to be done + -- manually when the table is allocated. IT is used to store several + -- tables of components containing only integers. + + function Image (Int : Integer; W : Natural := 0) return String; + function Image (Str : String; W : Natural := 0) return String; + -- Return a string which includes string Str or integer Int preceded by + -- leading spaces if required by width W. + + function Trim_Trailing_Nuls (Str : String) return String; + -- Return Str with trailing NUL characters removed + + Output : File_Descriptor renames GNAT.OS_Lib.Standout; + -- Shortcuts + + EOL : constant Character := ASCII.LF; + + Max : constant := 78; + Last : Natural := 0; + Line : String (1 .. Max); + -- Use this line to provide buffered IO + + procedure Add (C : Character); + procedure Add (S : String); + -- Add a character or a string in Line and update Last + + procedure Put + (F : File_Descriptor; + S : String; + F1 : Natural; + L1 : Natural; + C1 : Natural; + F2 : Natural; + L2 : Natural; + C2 : Natural); + -- Write string S into file F as a element of an array of one or two + -- dimensions. Fk (resp. Lk and Ck) indicates the first (resp last and + -- current) index in the k-th dimension. If F1 = L1 the array is considered + -- as a one dimension array. This dimension is described by F2 and L2. This + -- routine takes care of all the parenthesis, spaces and commas needed to + -- format correctly the array. Moreover, the array is well indented and is + -- wrapped to fit in a 80 col line. When the line is full, the routine + -- writes it into file F. When the array is completed, the routine adds + -- semi-colon and writes the line into file F. + + procedure New_Line (File : File_Descriptor); + -- Simulate Ada.Text_IO.New_Line with GNAT.OS_Lib + + procedure Put (File : File_Descriptor; Str : String); + -- Simulate Ada.Text_IO.Put with GNAT.OS_Lib + + procedure Put_Used_Char_Set (File : File_Descriptor; Title : String); + -- Output a title and a used character set + + procedure Put_Int_Vector + (File : File_Descriptor; + Title : String; + Vector : Integer; + Length : Natural); + -- Output a title and a vector + + procedure Put_Int_Matrix + (File : File_Descriptor; + Title : String; + Table : Table_Id; + Len_1 : Natural; + Len_2 : Natural); + -- Output a title and a matrix. When the matrix has only one non-empty + -- dimension (Len_2 = 0), output a vector. + + procedure Put_Edges (File : File_Descriptor; Title : String); + -- Output a title and an edge table + + procedure Put_Initial_Keys (File : File_Descriptor; Title : String); + -- Output a title and a key table + + procedure Put_Reduced_Keys (File : File_Descriptor; Title : String); + -- Output a title and a key table + + procedure Put_Vertex_Table (File : File_Descriptor; Title : String); + -- Output a title and a vertex table + + function Ada_File_Base_Name (Pkg_Name : String) return String; + -- Return the base file name (i.e. without .ads/.adb extension) for an + -- Ada source file containing the named package, using the standard GNAT + -- file-naming convention. For example, if Pkg_Name is "Parent.Child", we + -- return "parent-child". + + ---------------------------------- + -- Character Position Selection -- + ---------------------------------- + + -- We reduce the maximum key size by selecting representative positions + -- in these keys. We build a matrix with one word per line. We fill the + -- remaining space of a line with ASCII.NUL. The heuristic selects the + -- position that induces the minimum number of collisions. If there are + -- collisions, select another position on the reduced key set responsible + -- of the collisions. Apply the heuristic until there is no more collision. + + procedure Apply_Position_Selection; + -- Apply Position selection and build the reduced key table + + procedure Parse_Position_Selection (Argument : String); + -- Parse Argument and compute the position set. Argument is list of + -- substrings separated by commas. Each substring represents a position + -- or a range of positions (like x-y). + + procedure Select_Character_Set; + -- Define an optimized used character set like Character'Pos in order not + -- to allocate tables of 256 entries. + + procedure Select_Char_Position; + -- Find a min char position set in order to reduce the max key length. The + -- heuristic selects the position that induces the minimum number of + -- collisions. If there are collisions, select another position on the + -- reduced key set responsible of the collisions. Apply the heuristic until + -- there is no collision. + + ----------------------------- + -- Random Graph Generation -- + ----------------------------- + + procedure Random (Seed : in out Natural); + -- Simulate Ada.Discrete_Numerics.Random + + procedure Generate_Mapping_Table + (Tab : Table_Id; + L1 : Natural; + L2 : Natural; + Seed : in out Natural); + -- Random generation of the tables below. T is already allocated + + procedure Generate_Mapping_Tables + (Opt : Optimization; + Seed : in out Natural); + -- Generate the mapping tables T1 and T2. They are used to define fk (w) = + -- sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n. Keys, NK and Chars + -- are used to compute the matrix size. + + --------------------------- + -- Algorithm Computation -- + --------------------------- + + procedure Compute_Edges_And_Vertices (Opt : Optimization); + -- Compute the edge and vertex tables. These are empty when a self loop is + -- detected (f1 (w) = f2 (w)). The edge table is sorted by X value and then + -- Y value. Keys is the key table and NK the number of keys. Chars is the + -- set of characters really used in Keys. NV is the number of vertices + -- recommended by the algorithm. T1 and T2 are the mapping tables needed to + -- compute f1 (w) and f2 (w). + + function Acyclic return Boolean; + -- Return True when the graph is acyclic. Vertices is the current vertex + -- table and Edges the current edge table. + + procedure Assign_Values_To_Vertices; + -- Execute the assignment step of the algorithm. Keys is the current key + -- table. Vertices and Edges represent the random graph. G is the result of + -- the assignment step such that: + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + function Sum + (Word : Word_Type; + Table : Table_Id; + Opt : Optimization) return Natural; + -- For an optimization of CPU_Time return + -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i, w (i))) mod n + -- For an optimization of Memory_Space return + -- fk (w) = sum (for i in 1 .. length (w)) (Tk (i) * w (i)) mod n + -- Here NV = n + + ------------------------------- + -- Internal Table Management -- + ------------------------------- + + function Allocate (N : Natural; S : Natural := 1) return Table_Id; + -- Allocate N * S ints from IT table + + ---------- + -- Keys -- + ---------- + + Keys : Table_Id := No_Table; + NK : Natural := 0; + -- NK : Number of Keys + + function Initial (K : Key_Id) return Word_Id; + pragma Inline (Initial); + + function Reduced (K : Key_Id) return Word_Id; + pragma Inline (Reduced); + + function Get_Key (N : Key_Id) return Key_Type; + procedure Set_Key (N : Key_Id; Item : Key_Type); + -- Get or Set Nth element of Keys table + + ------------------ + -- Char_Pos_Set -- + ------------------ + + Char_Pos_Set : Table_Id := No_Table; + Char_Pos_Set_Len : Natural; + -- Character Selected Position Set + + function Get_Char_Pos (P : Natural) return Natural; + procedure Set_Char_Pos (P : Natural; Item : Natural); + -- Get or Set the string position of the Pth selected character + + ------------------- + -- Used_Char_Set -- + ------------------- + + Used_Char_Set : Table_Id := No_Table; + Used_Char_Set_Len : Natural; + -- Used Character Set : Define a new character mapping. When all the + -- characters are not present in the keys, in order to reduce the size + -- of some tables, we redefine the character mapping. + + function Get_Used_Char (C : Character) return Natural; + procedure Set_Used_Char (C : Character; Item : Natural); + + ------------ + -- Tables -- + ------------ + + T1 : Table_Id := No_Table; + T2 : Table_Id := No_Table; + T1_Len : Natural; + T2_Len : Natural; + -- T1 : Values table to compute F1 + -- T2 : Values table to compute F2 + + function Get_Table (T : Integer; X, Y : Natural) return Natural; + procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural); + + ----------- + -- Graph -- + ----------- + + G : Table_Id := No_Table; + G_Len : Natural; + -- Values table to compute G + + NT : Natural := Default_Tries; + -- Number of tries running the algorithm before raising an error + + function Get_Graph (N : Natural) return Integer; + procedure Set_Graph (N : Natural; Item : Integer); + -- Get or Set Nth element of graph + + ----------- + -- Edges -- + ----------- + + Edge_Size : constant := 3; + Edges : Table_Id := No_Table; + Edges_Len : Natural; + -- Edges : Edge table of the random graph G + + function Get_Edges (F : Natural) return Edge_Type; + procedure Set_Edges (F : Natural; Item : Edge_Type); + + -------------- + -- Vertices -- + -------------- + + Vertex_Size : constant := 2; + + Vertices : Table_Id := No_Table; + -- Vertex table of the random graph G + + NV : Natural; + -- Number of Vertices + + function Get_Vertices (F : Natural) return Vertex_Type; + procedure Set_Vertices (F : Natural; Item : Vertex_Type); + -- Comments needed ??? + + K2V : Float; + -- Ratio between Keys and Vertices (parameter of Czech's algorithm) + + Opt : Optimization; + -- Optimization mode (memory vs CPU) + + Max_Key_Len : Natural := 0; + Min_Key_Len : Natural := 0; + -- Maximum and minimum of all the word length + + S : Natural; + -- Seed + + function Type_Size (L : Natural) return Natural; + -- Given the last L of an unsigned integer type T, return its size + + ------------- + -- Acyclic -- + ------------- + + function Acyclic return Boolean is + Marks : array (0 .. NV - 1) of Vertex_Id := (others => No_Vertex); + + function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean; + -- Propagate Mark from X to Y. X is already marked. Mark Y and propagate + -- it to the edges of Y except the one representing the same key. Return + -- False when Y is marked with Mark. + + -------------- + -- Traverse -- + -------------- + + function Traverse (Edge : Edge_Id; Mark : Vertex_Id) return Boolean is + E : constant Edge_Type := Get_Edges (Edge); + K : constant Key_Id := E.Key; + Y : constant Vertex_Id := E.Y; + M : constant Vertex_Id := Marks (E.Y); + V : Vertex_Type; + + begin + if M = Mark then + return False; + + elsif M = No_Vertex then + Marks (Y) := Mark; + V := Get_Vertices (Y); + + for J in V.First .. V.Last loop + + -- Do not propagate to the edge representing the same key + + if Get_Edges (J).Key /= K + and then not Traverse (J, Mark) + then + return False; + end if; + end loop; + end if; + + return True; + end Traverse; + + Edge : Edge_Type; + + -- Start of processing for Acyclic + + begin + -- Edges valid range is + + for J in 1 .. Edges_Len - 1 loop + + Edge := Get_Edges (J); + + -- Mark X of E when it has not been already done + + if Marks (Edge.X) = No_Vertex then + Marks (Edge.X) := Edge.X; + end if; + + -- Traverse E when this has not already been done + + if Marks (Edge.Y) = No_Vertex + and then not Traverse (J, Edge.X) + then + return False; + end if; + end loop; + + return True; + end Acyclic; + + ------------------------ + -- Ada_File_Base_Name -- + ------------------------ + + function Ada_File_Base_Name (Pkg_Name : String) return String is + begin + -- Convert to lower case, then replace '.' with '-' + + return Result : String := To_Lower (Pkg_Name) do + for J in Result'Range loop + if Result (J) = '.' then + Result (J) := '-'; + end if; + end loop; + end return; + end Ada_File_Base_Name; + + --------- + -- Add -- + --------- + + procedure Add (C : Character) is + pragma Assert (C /= ASCII.NUL); + begin + Line (Last + 1) := C; + Last := Last + 1; + end Add; + + --------- + -- Add -- + --------- + + procedure Add (S : String) is + Len : constant Natural := S'Length; + begin + for J in S'Range loop + pragma Assert (S (J) /= ASCII.NUL); + null; + end loop; + + Line (Last + 1 .. Last + Len) := S; + Last := Last + Len; + end Add; + + -------------- + -- Allocate -- + -------------- + + function Allocate (N : Natural; S : Natural := 1) return Table_Id is + L : constant Integer := IT.Last; + begin + IT.Set_Last (L + N * S); + + -- Initialize, so debugging printouts don't trip over uninitialized + -- components. + + for J in L + 1 .. IT.Last loop + IT.Table (J) := -1; + end loop; + + return L + 1; + end Allocate; + + ------------------------------ + -- Apply_Position_Selection -- + ------------------------------ + + procedure Apply_Position_Selection is + begin + for J in 0 .. NK - 1 loop + declare + IW : constant String := WT.Table (Initial (J)).all; + RW : String (1 .. IW'Length) := (others => ASCII.NUL); + N : Natural := IW'First - 1; + + begin + -- Select the characters of Word included in the position + -- selection. + + for C in 0 .. Char_Pos_Set_Len - 1 loop + exit when IW (Get_Char_Pos (C)) = ASCII.NUL; + N := N + 1; + RW (N) := IW (Get_Char_Pos (C)); + end loop; + + -- Build the new table with the reduced word. Be careful + -- to deallocate the old version to avoid memory leaks. + + Free_Word (WT.Table (Reduced (J))); + WT.Table (Reduced (J)) := New_Word (RW); + Set_Key (J, (Edge => No_Edge)); + end; + end loop; + end Apply_Position_Selection; + + ------------------------------- + -- Assign_Values_To_Vertices -- + ------------------------------- + + procedure Assign_Values_To_Vertices is + X : Vertex_Id; + + procedure Assign (X : Vertex_Id); + -- Execute assignment on X's neighbors except the vertex that we are + -- coming from which is already assigned. + + ------------ + -- Assign -- + ------------ + + procedure Assign (X : Vertex_Id) is + E : Edge_Type; + V : constant Vertex_Type := Get_Vertices (X); + + begin + for J in V.First .. V.Last loop + E := Get_Edges (J); + + if Get_Graph (E.Y) = -1 then + Set_Graph (E.Y, (E.Key - Get_Graph (X)) mod NK); + Assign (E.Y); + end if; + end loop; + end Assign; + + -- Start of processing for Assign_Values_To_Vertices + + begin + -- Value -1 denotes an uninitialized value as it is supposed to + -- be in the range 0 .. NK. + + if G = No_Table then + G_Len := NV; + G := Allocate (G_Len, 1); + end if; + + for J in 0 .. G_Len - 1 loop + Set_Graph (J, -1); + end loop; + + for K in 0 .. NK - 1 loop + X := Get_Edges (Get_Key (K).Edge).X; + + if Get_Graph (X) = -1 then + Set_Graph (X, 0); + Assign (X); + end if; + end loop; + + for J in 0 .. G_Len - 1 loop + if Get_Graph (J) = -1 then + Set_Graph (J, 0); + end if; + end loop; + + if Verbose then + Put_Int_Vector (Output, "Assign Values To Vertices", G, G_Len); + end if; + end Assign_Values_To_Vertices; + + ------------- + -- Compute -- + ------------- + + procedure Compute (Position : String := Default_Position) is + Success : Boolean := False; + + begin + if NK = 0 then + raise Program_Error with "keywords set cannot be empty"; + end if; + + if Verbose then + Put_Initial_Keys (Output, "Initial Key Table"); + end if; + + if Position'Length /= 0 then + Parse_Position_Selection (Position); + else + Select_Char_Position; + end if; + + if Verbose then + Put_Int_Vector + (Output, "Char Position Set", Char_Pos_Set, Char_Pos_Set_Len); + end if; + + Apply_Position_Selection; + + if Verbose then + Put_Reduced_Keys (Output, "Reduced Keys Table"); + end if; + + Select_Character_Set; + + if Verbose then + Put_Used_Char_Set (Output, "Character Position Table"); + end if; + + -- Perform Czech's algorithm + + for J in 1 .. NT loop + Generate_Mapping_Tables (Opt, S); + Compute_Edges_And_Vertices (Opt); + + -- When graph is not empty (no self-loop from previous operation) and + -- not acyclic. + + if 0 < Edges_Len and then Acyclic then + Success := True; + exit; + end if; + end loop; + + if not Success then + raise Too_Many_Tries; + end if; + + Assign_Values_To_Vertices; + end Compute; + + -------------------------------- + -- Compute_Edges_And_Vertices -- + -------------------------------- + + procedure Compute_Edges_And_Vertices (Opt : Optimization) is + X : Natural; + Y : Natural; + Key : Key_Type; + Edge : Edge_Type; + Vertex : Vertex_Type; + Not_Acyclic : Boolean := False; + + procedure Move (From : Natural; To : Natural); + function Lt (L, R : Natural) return Boolean; + -- Subprograms needed for GNAT.Heap_Sort_G + + -------- + -- Lt -- + -------- + + function Lt (L, R : Natural) return Boolean is + EL : constant Edge_Type := Get_Edges (L); + ER : constant Edge_Type := Get_Edges (R); + begin + return EL.X < ER.X or else (EL.X = ER.X and then EL.Y < ER.Y); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + begin + Set_Edges (To, Get_Edges (From)); + end Move; + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Compute_Edges_And_Vertices + + begin + -- We store edges from 1 to 2 * NK and leave zero alone in order to use + -- GNAT.Heap_Sort_G. + + Edges_Len := 2 * NK + 1; + + if Edges = No_Table then + Edges := Allocate (Edges_Len, Edge_Size); + end if; + + if Vertices = No_Table then + Vertices := Allocate (NV, Vertex_Size); + end if; + + for J in 0 .. NV - 1 loop + Set_Vertices (J, (No_Vertex, No_Vertex - 1)); + end loop; + + -- For each w, X = f1 (w) and Y = f2 (w) + + for J in 0 .. NK - 1 loop + Key := Get_Key (J); + Key.Edge := No_Edge; + Set_Key (J, Key); + + X := Sum (WT.Table (Reduced (J)), T1, Opt); + Y := Sum (WT.Table (Reduced (J)), T2, Opt); + + -- Discard T1 and T2 as soon as we discover a self loop + + if X = Y then + Not_Acyclic := True; + exit; + end if; + + -- We store (X, Y) and (Y, X) to ease assignment step + + Set_Edges (2 * J + 1, (X, Y, J)); + Set_Edges (2 * J + 2, (Y, X, J)); + end loop; + + -- Return an empty graph when self loop detected + + if Not_Acyclic then + Edges_Len := 0; + + else + if Verbose then + Put_Edges (Output, "Unsorted Edge Table"); + Put_Int_Matrix (Output, "Function Table 1", T1, + T1_Len, T2_Len); + Put_Int_Matrix (Output, "Function Table 2", T2, + T1_Len, T2_Len); + end if; + + -- Enforce consistency between edges and keys. Construct Vertices and + -- compute the list of neighbors of a vertex First .. Last as Edges + -- is sorted by X and then Y. To compute the neighbor list, sort the + -- edges. + + Sorting.Sort (Edges_Len - 1); + + if Verbose then + Put_Edges (Output, "Sorted Edge Table"); + Put_Int_Matrix (Output, "Function Table 1", T1, + T1_Len, T2_Len); + Put_Int_Matrix (Output, "Function Table 2", T2, + T1_Len, T2_Len); + end if; + + -- Edges valid range is 1 .. 2 * NK + + for E in 1 .. Edges_Len - 1 loop + Edge := Get_Edges (E); + Key := Get_Key (Edge.Key); + + if Key.Edge = No_Edge then + Key.Edge := E; + Set_Key (Edge.Key, Key); + end if; + + Vertex := Get_Vertices (Edge.X); + + if Vertex.First = No_Edge then + Vertex.First := E; + end if; + + Vertex.Last := E; + Set_Vertices (Edge.X, Vertex); + end loop; + + if Verbose then + Put_Reduced_Keys (Output, "Key Table"); + Put_Edges (Output, "Edge Table"); + Put_Vertex_Table (Output, "Vertex Table"); + end if; + end if; + end Compute_Edges_And_Vertices; + + ------------ + -- Define -- + ------------ + + procedure Define + (Name : Table_Name; + Item_Size : out Natural; + Length_1 : out Natural; + Length_2 : out Natural) + is + begin + case Name is + when Character_Position => + Item_Size := 8; + Length_1 := Char_Pos_Set_Len; + Length_2 := 0; + + when Used_Character_Set => + Item_Size := 8; + Length_1 := 256; + Length_2 := 0; + + when Function_Table_1 + | Function_Table_2 + => + Item_Size := Type_Size (NV); + Length_1 := T1_Len; + Length_2 := T2_Len; + + when Graph_Table => + Item_Size := Type_Size (NK); + Length_1 := NV; + Length_2 := 0; + end case; + end Define; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if Verbose then + Put (Output, "Finalize"); + New_Line (Output); + end if; + + -- Deallocate all the WT components (both initial and reduced ones) to + -- avoid memory leaks. + + for W in 0 .. WT.Last loop + + -- Note: WT.Table (NK) is a temporary variable, do not free it since + -- this would cause a double free. + + if W /= NK then + Free_Word (WT.Table (W)); + end if; + end loop; + + WT.Release; + IT.Release; + + -- Reset all variables for next usage + + Keys := No_Table; + + Char_Pos_Set := No_Table; + Char_Pos_Set_Len := 0; + + Used_Char_Set := No_Table; + Used_Char_Set_Len := 0; + + T1 := No_Table; + T2 := No_Table; + + T1_Len := 0; + T2_Len := 0; + + G := No_Table; + G_Len := 0; + + Edges := No_Table; + Edges_Len := 0; + + Vertices := No_Table; + NV := 0; + + NK := 0; + Max_Key_Len := 0; + Min_Key_Len := 0; + end Finalize; + + ---------------------------- + -- Generate_Mapping_Table -- + ---------------------------- + + procedure Generate_Mapping_Table + (Tab : Integer; + L1 : Natural; + L2 : Natural; + Seed : in out Natural) + is + begin + for J in 0 .. L1 - 1 loop + for K in 0 .. L2 - 1 loop + Random (Seed); + Set_Table (Tab, J, K, Seed mod NV); + end loop; + end loop; + end Generate_Mapping_Table; + + ----------------------------- + -- Generate_Mapping_Tables -- + ----------------------------- + + procedure Generate_Mapping_Tables + (Opt : Optimization; + Seed : in out Natural) + is + begin + -- If T1 and T2 are already allocated no need to do it twice. Reuse them + -- as their size has not changed. + + if T1 = No_Table and then T2 = No_Table then + declare + Used_Char_Last : Natural := 0; + Used_Char : Natural; + + begin + if Opt = CPU_Time then + for P in reverse Character'Range loop + Used_Char := Get_Used_Char (P); + if Used_Char /= 0 then + Used_Char_Last := Used_Char; + exit; + end if; + end loop; + end if; + + T1_Len := Char_Pos_Set_Len; + T2_Len := Used_Char_Last + 1; + T1 := Allocate (T1_Len * T2_Len); + T2 := Allocate (T1_Len * T2_Len); + end; + end if; + + Generate_Mapping_Table (T1, T1_Len, T2_Len, Seed); + Generate_Mapping_Table (T2, T1_Len, T2_Len, Seed); + + if Verbose then + Put_Used_Char_Set (Output, "Used Character Set"); + Put_Int_Matrix (Output, "Function Table 1", T1, + T1_Len, T2_Len); + Put_Int_Matrix (Output, "Function Table 2", T2, + T1_Len, T2_Len); + end if; + end Generate_Mapping_Tables; + + ------------------ + -- Get_Char_Pos -- + ------------------ + + function Get_Char_Pos (P : Natural) return Natural is + N : constant Natural := Char_Pos_Set + P; + begin + return IT.Table (N); + end Get_Char_Pos; + + --------------- + -- Get_Edges -- + --------------- + + function Get_Edges (F : Natural) return Edge_Type is + N : constant Natural := Edges + (F * Edge_Size); + E : Edge_Type; + begin + E.X := IT.Table (N); + E.Y := IT.Table (N + 1); + E.Key := IT.Table (N + 2); + return E; + end Get_Edges; + + --------------- + -- Get_Graph -- + --------------- + + function Get_Graph (N : Natural) return Integer is + begin + return IT.Table (G + N); + end Get_Graph; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (N : Key_Id) return Key_Type is + K : Key_Type; + begin + K.Edge := IT.Table (Keys + N); + return K; + end Get_Key; + + --------------- + -- Get_Table -- + --------------- + + function Get_Table (T : Integer; X, Y : Natural) return Natural is + N : constant Natural := T + (Y * T1_Len) + X; + begin + return IT.Table (N); + end Get_Table; + + ------------------- + -- Get_Used_Char -- + ------------------- + + function Get_Used_Char (C : Character) return Natural is + N : constant Natural := Used_Char_Set + Character'Pos (C); + begin + return IT.Table (N); + end Get_Used_Char; + + ------------------ + -- Get_Vertices -- + ------------------ + + function Get_Vertices (F : Natural) return Vertex_Type is + N : constant Natural := Vertices + (F * Vertex_Size); + V : Vertex_Type; + begin + V.First := IT.Table (N); + V.Last := IT.Table (N + 1); + return V; + end Get_Vertices; + + ----------- + -- Image -- + ----------- + + function Image (Int : Integer; W : Natural := 0) return String is + B : String (1 .. 32); + L : Natural := 0; + + procedure Img (V : Natural); + -- Compute image of V into B, starting at B (L), incrementing L + + --------- + -- Img -- + --------- + + procedure Img (V : Natural) is + begin + if V > 9 then + Img (V / 10); + end if; + + L := L + 1; + B (L) := Character'Val ((V mod 10) + Character'Pos ('0')); + end Img; + + -- Start of processing for Image + + begin + if Int < 0 then + L := L + 1; + B (L) := '-'; + Img (-Int); + else + Img (Int); + end if; + + return Image (B (1 .. L), W); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Str : String; W : Natural := 0) return String is + Len : constant Natural := Str'Length; + Max : Natural := Len; + + begin + if Max < W then + Max := W; + end if; + + declare + Buf : String (1 .. Max) := (1 .. Max => ' '); + + begin + for J in 0 .. Len - 1 loop + Buf (Max - Len + 1 + J) := Str (Str'First + J); + end loop; + + return Buf; + end; + end Image; + + ------------- + -- Initial -- + ------------- + + function Initial (K : Key_Id) return Word_Id is + begin + return K; + end Initial; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize + (Seed : Natural; + K_To_V : Float := Default_K_To_V; + Optim : Optimization := Memory_Space; + Tries : Positive := Default_Tries) + is + begin + if Verbose then + Put (Output, "Initialize"); + New_Line (Output); + end if; + + -- Deallocate the part of the table concerning the reduced words. + -- Initial words are already present in the table. We may have reduced + -- words already there because a previous computation failed. We are + -- currently retrying and the reduced words have to be deallocated. + + for W in Reduced (0) .. WT.Last loop + Free_Word (WT.Table (W)); + end loop; + + IT.Init; + + -- Initialize of computation variables + + Keys := No_Table; + + Char_Pos_Set := No_Table; + Char_Pos_Set_Len := 0; + + Used_Char_Set := No_Table; + Used_Char_Set_Len := 0; + + T1 := No_Table; + T2 := No_Table; + + T1_Len := 0; + T2_Len := 0; + + G := No_Table; + G_Len := 0; + + Edges := No_Table; + Edges_Len := 0; + + Vertices := No_Table; + NV := 0; + + S := Seed; + K2V := K_To_V; + Opt := Optim; + NT := Tries; + + if K2V <= 2.0 then + raise Program_Error with "K to V ratio cannot be lower than 2.0"; + end if; + + -- Do not accept a value of K2V too close to 2.0 such that once + -- rounded up, NV = 2 * NK because the algorithm would not converge. + + NV := Natural (Float (NK) * K2V); + if NV <= 2 * NK then + NV := 2 * NK + 1; + end if; + + Keys := Allocate (NK); + + -- Resize initial words to have all of them at the same size + -- (so the size of the largest one). + + for K in 0 .. NK - 1 loop + Resize_Word (WT.Table (Initial (K)), Max_Key_Len); + end loop; + + -- Allocated the table to store the reduced words. As WT is a + -- GNAT.Table (using C memory management), pointers have to be + -- explicitly initialized to null. + + WT.Set_Last (Reduced (NK - 1)); + + -- Note: Reduced (0) = NK + 1 + + WT.Table (NK) := null; + + for W in 0 .. NK - 1 loop + WT.Table (Reduced (W)) := null; + end loop; + end Initialize; + + ------------ + -- Insert -- + ------------ + + procedure Insert (Value : String) is + Len : constant Natural := Value'Length; + + begin + if Verbose then + Put (Output, "Inserting """ & Value & """"); + New_Line (Output); + end if; + + for J in Value'Range loop + pragma Assert (Value (J) /= ASCII.NUL); + null; + end loop; + + WT.Set_Last (NK); + WT.Table (NK) := New_Word (Value); + NK := NK + 1; + + if Max_Key_Len < Len then + Max_Key_Len := Len; + end if; + + if Min_Key_Len = 0 or else Len < Min_Key_Len then + Min_Key_Len := Len; + end if; + end Insert; + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (File : File_Descriptor) is + begin + if Write (File, EOL'Address, 1) /= 1 then + raise Program_Error; + end if; + end New_Line; + + -------------- + -- New_Word -- + -------------- + + function New_Word (S : String) return Word_Type is + begin + return new String'(S); + end New_Word; + + ------------------------------ + -- Parse_Position_Selection -- + ------------------------------ + + procedure Parse_Position_Selection (Argument : String) is + N : Natural := Argument'First; + L : constant Natural := Argument'Last; + M : constant Natural := Max_Key_Len; + + T : array (1 .. M) of Boolean := (others => False); + + function Parse_Index return Natural; + -- Parse argument starting at index N to find an index + + ----------------- + -- Parse_Index -- + ----------------- + + function Parse_Index return Natural is + C : Character := Argument (N); + V : Natural := 0; + + begin + if C = '$' then + N := N + 1; + return M; + end if; + + if C not in '0' .. '9' then + raise Program_Error with "cannot read position argument"; + end if; + + while C in '0' .. '9' loop + V := V * 10 + (Character'Pos (C) - Character'Pos ('0')); + N := N + 1; + exit when L < N; + C := Argument (N); + end loop; + + return V; + end Parse_Index; + + -- Start of processing for Parse_Position_Selection + + begin + -- Empty specification means all the positions + + if L < N then + Char_Pos_Set_Len := M; + Char_Pos_Set := Allocate (Char_Pos_Set_Len); + + for C in 0 .. Char_Pos_Set_Len - 1 loop + Set_Char_Pos (C, C + 1); + end loop; + + else + loop + declare + First, Last : Natural; + + begin + First := Parse_Index; + Last := First; + + -- Detect a range + + if N <= L and then Argument (N) = '-' then + N := N + 1; + Last := Parse_Index; + end if; + + -- Include the positions in the selection + + for J in First .. Last loop + T (J) := True; + end loop; + end; + + exit when L < N; + + if Argument (N) /= ',' then + raise Program_Error with "cannot read position argument"; + end if; + + N := N + 1; + end loop; + + -- Compute position selection length + + N := 0; + for J in T'Range loop + if T (J) then + N := N + 1; + end if; + end loop; + + -- Fill position selection + + Char_Pos_Set_Len := N; + Char_Pos_Set := Allocate (Char_Pos_Set_Len); + + N := 0; + for J in T'Range loop + if T (J) then + Set_Char_Pos (N, J); + N := N + 1; + end if; + end loop; + end if; + end Parse_Position_Selection; + + ------------- + -- Produce -- + ------------- + + procedure Produce + (Pkg_Name : String := Default_Pkg_Name; + Use_Stdout : Boolean := False) + is + File : File_Descriptor := Standout; + + Status : Boolean; + -- For call to Close + + function Array_Img (N, T, R1 : String; R2 : String := "") return String; + -- Return string "N : constant array (R1[, R2]) of T;" + + function Range_Img (F, L : Natural; T : String := "") return String; + -- Return string "[T range ]F .. L" + + function Type_Img (L : Natural) return String; + -- Return the larger unsigned type T such that T'Last < L + + --------------- + -- Array_Img -- + --------------- + + function Array_Img + (N, T, R1 : String; + R2 : String := "") return String + is + begin + Last := 0; + Add (" "); + Add (N); + Add (" : constant array ("); + Add (R1); + + if R2 /= "" then + Add (", "); + Add (R2); + end if; + + Add (") of "); + Add (T); + Add (" :="); + return Line (1 .. Last); + end Array_Img; + + --------------- + -- Range_Img -- + --------------- + + function Range_Img (F, L : Natural; T : String := "") return String is + FI : constant String := Image (F); + FL : constant Natural := FI'Length; + LI : constant String := Image (L); + LL : constant Natural := LI'Length; + TL : constant Natural := T'Length; + RI : String (1 .. TL + 7 + FL + 4 + LL); + Len : Natural := 0; + + begin + if TL /= 0 then + RI (Len + 1 .. Len + TL) := T; + Len := Len + TL; + RI (Len + 1 .. Len + 7) := " range "; + Len := Len + 7; + end if; + + RI (Len + 1 .. Len + FL) := FI; + Len := Len + FL; + RI (Len + 1 .. Len + 4) := " .. "; + Len := Len + 4; + RI (Len + 1 .. Len + LL) := LI; + Len := Len + LL; + return RI (1 .. Len); + end Range_Img; + + -------------- + -- Type_Img -- + -------------- + + function Type_Img (L : Natural) return String is + S : constant String := Image (Type_Size (L)); + U : String := "Unsigned_ "; + N : Natural := 9; + + begin + for J in S'Range loop + N := N + 1; + U (N) := S (J); + end loop; + + return U (1 .. N); + end Type_Img; + + F : Natural; + L : Natural; + P : Natural; + + FName : String := Ada_File_Base_Name (Pkg_Name) & ".ads"; + -- Initially, the name of the spec file, then modified to be the name of + -- the body file. Not used if Use_Stdout is True. + + -- Start of processing for Produce + + begin + + if Verbose and then not Use_Stdout then + Put (Output, + "Producing " & Ada.Directories.Current_Directory & "/" & FName); + New_Line (Output); + end if; + + if not Use_Stdout then + File := Create_File (FName, Binary); + + if File = Invalid_FD then + raise Program_Error with "cannot create: " & FName; + end if; + end if; + + Put (File, "package "); + Put (File, Pkg_Name); + Put (File, " is"); + New_Line (File); + Put (File, " function Hash (S : String) return Natural;"); + New_Line (File); + Put (File, "end "); + Put (File, Pkg_Name); + Put (File, ";"); + New_Line (File); + + if not Use_Stdout then + Close (File, Status); + + if not Status then + raise Device_Error; + end if; + end if; + + if not Use_Stdout then + + -- Set to body file name + + FName (FName'Last) := 'b'; + + File := Create_File (FName, Binary); + + if File = Invalid_FD then + raise Program_Error with "cannot create: " & FName; + end if; + end if; + + Put (File, "with Interfaces; use Interfaces;"); + New_Line (File); + New_Line (File); + Put (File, "package body "); + Put (File, Pkg_Name); + Put (File, " is"); + New_Line (File); + New_Line (File); + + if Opt = CPU_Time then + Put (File, Array_Img ("C", Type_Img (256), "Character")); + New_Line (File); + + F := Character'Pos (Character'First); + L := Character'Pos (Character'Last); + + for J in Character'Range loop + P := Get_Used_Char (J); + Put (File, Image (P), 1, 0, 1, F, L, Character'Pos (J)); + end loop; + + New_Line (File); + end if; + + F := 0; + L := Char_Pos_Set_Len - 1; + + Put (File, Array_Img ("P", "Natural", Range_Img (F, L))); + New_Line (File); + + for J in F .. L loop + Put (File, Image (Get_Char_Pos (J)), 1, 0, 1, F, L, J); + end loop; + + New_Line (File); + + case Opt is + when CPU_Time => + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, T1_Len - 1), + Range_Img (0, T2_Len - 1, Type_Img (256))), + T1, T1_Len, T2_Len); + + when Memory_Space => + Put_Int_Matrix + (File, + Array_Img ("T1", Type_Img (NV), + Range_Img (0, T1_Len - 1)), + T1, T1_Len, 0); + end case; + + New_Line (File); + + case Opt is + when CPU_Time => + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, T1_Len - 1), + Range_Img (0, T2_Len - 1, Type_Img (256))), + T2, T1_Len, T2_Len); + + when Memory_Space => + Put_Int_Matrix + (File, + Array_Img ("T2", Type_Img (NV), + Range_Img (0, T1_Len - 1)), + T2, T1_Len, 0); + end case; + + New_Line (File); + + Put_Int_Vector + (File, + Array_Img ("G", Type_Img (NK), + Range_Img (0, G_Len - 1)), + G, G_Len); + New_Line (File); + + Put (File, " function Hash (S : String) return Natural is"); + New_Line (File); + Put (File, " F : constant Natural := S'First - 1;"); + New_Line (File); + Put (File, " L : constant Natural := S'Length;"); + New_Line (File); + Put (File, " F1, F2 : Natural := 0;"); + New_Line (File); + + Put (File, " J : "); + + case Opt is + when CPU_Time => + Put (File, Type_Img (256)); + + when Memory_Space => + Put (File, "Natural"); + end case; + + Put (File, ";"); + New_Line (File); + + Put (File, " begin"); + New_Line (File); + Put (File, " for K in P'Range loop"); + New_Line (File); + Put (File, " exit when L < P (K);"); + New_Line (File); + Put (File, " J := "); + + case Opt is + when CPU_Time => + Put (File, "C"); + + when Memory_Space => + Put (File, "Character'Pos"); + end case; + + Put (File, " (S (P (K) + F));"); + New_Line (File); + + Put (File, " F1 := (F1 + Natural (T1 (K"); + + if Opt = CPU_Time then + Put (File, ", J"); + end if; + + Put (File, "))"); + + if Opt = Memory_Space then + Put (File, " * J"); + end if; + + Put (File, ") mod "); + Put (File, Image (NV)); + Put (File, ";"); + New_Line (File); + + Put (File, " F2 := (F2 + Natural (T2 (K"); + + if Opt = CPU_Time then + Put (File, ", J"); + end if; + + Put (File, "))"); + + if Opt = Memory_Space then + Put (File, " * J"); + end if; + + Put (File, ") mod "); + Put (File, Image (NV)); + Put (File, ";"); + New_Line (File); + + Put (File, " end loop;"); + New_Line (File); + + Put (File, + " return (Natural (G (F1)) + Natural (G (F2))) mod "); + + Put (File, Image (NK)); + Put (File, ";"); + New_Line (File); + Put (File, " end Hash;"); + New_Line (File); + New_Line (File); + Put (File, "end "); + Put (File, Pkg_Name); + Put (File, ";"); + New_Line (File); + + if not Use_Stdout then + Close (File, Status); + + if not Status then + raise Device_Error; + end if; + end if; + end Produce; + + --------- + -- Put -- + --------- + + procedure Put (File : File_Descriptor; Str : String) is + Len : constant Natural := Str'Length; + begin + for J in Str'Range loop + pragma Assert (Str (J) /= ASCII.NUL); + null; + end loop; + + if Write (File, Str'Address, Len) /= Len then + raise Program_Error; + end if; + end Put; + + --------- + -- Put -- + --------- + + procedure Put + (F : File_Descriptor; + S : String; + F1 : Natural; + L1 : Natural; + C1 : Natural; + F2 : Natural; + L2 : Natural; + C2 : Natural) + is + Len : constant Natural := S'Length; + + procedure Flush; + -- Write current line, followed by LF + + ----------- + -- Flush -- + ----------- + + procedure Flush is + begin + Put (F, Line (1 .. Last)); + New_Line (F); + Last := 0; + end Flush; + + -- Start of processing for Put + + begin + if C1 = F1 and then C2 = F2 then + Last := 0; + end if; + + if Last + Len + 3 >= Max then + Flush; + end if; + + if Last = 0 then + Add (" "); + + if F1 <= L1 then + if C1 = F1 and then C2 = F2 then + Add ('('); + + if F1 = L1 then + Add ("0 .. 0 => "); + end if; + + else + Add (' '); + end if; + end if; + end if; + + if C2 = F2 then + Add ('('); + + if F2 = L2 then + Add ("0 .. 0 => "); + end if; + + else + Add (' '); + end if; + + Add (S); + + if C2 = L2 then + Add (')'); + + if F1 > L1 then + Add (';'); + Flush; + + elsif C1 /= L1 then + Add (','); + Flush; + + else + Add (')'); + Add (';'); + Flush; + end if; + + else + Add (','); + end if; + end Put; + + --------------- + -- Put_Edges -- + --------------- + + procedure Put_Edges (File : File_Descriptor; Title : String) is + E : Edge_Type; + F1 : constant Natural := 1; + L1 : constant Natural := Edges_Len - 1; + M : constant Natural := Max / 5; + + begin + Put (File, Title); + New_Line (File); + + -- Edges valid range is 1 .. Edge_Len - 1 + + for J in F1 .. L1 loop + E := Get_Edges (J); + Put (File, Image (J, M), F1, L1, J, 1, 4, 1); + Put (File, Image (E.X, M), F1, L1, J, 1, 4, 2); + Put (File, Image (E.Y, M), F1, L1, J, 1, 4, 3); + Put (File, Image (E.Key, M), F1, L1, J, 1, 4, 4); + end loop; + end Put_Edges; + + ---------------------- + -- Put_Initial_Keys -- + ---------------------- + + procedure Put_Initial_Keys (File : File_Descriptor; Title : String) is + F1 : constant Natural := 0; + L1 : constant Natural := NK - 1; + M : constant Natural := Max / 5; + K : Key_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + K := Get_Key (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); + Put (File, Trim_Trailing_Nuls (WT.Table (Initial (J)).all), + F1, L1, J, 1, 3, 3); + end loop; + end Put_Initial_Keys; + + -------------------- + -- Put_Int_Matrix -- + -------------------- + + procedure Put_Int_Matrix + (File : File_Descriptor; + Title : String; + Table : Integer; + Len_1 : Natural; + Len_2 : Natural) + is + F1 : constant Integer := 0; + L1 : constant Integer := Len_1 - 1; + F2 : constant Integer := 0; + L2 : constant Integer := Len_2 - 1; + Ix : Natural; + + begin + Put (File, Title); + New_Line (File); + + if Len_2 = 0 then + for J in F1 .. L1 loop + Ix := IT.Table (Table + J); + Put (File, Image (Ix), 1, 0, 1, F1, L1, J); + end loop; + + else + for J in F1 .. L1 loop + for K in F2 .. L2 loop + Ix := IT.Table (Table + J + K * Len_1); + Put (File, Image (Ix), F1, L1, J, F2, L2, K); + end loop; + end loop; + end if; + end Put_Int_Matrix; + + -------------------- + -- Put_Int_Vector -- + -------------------- + + procedure Put_Int_Vector + (File : File_Descriptor; + Title : String; + Vector : Integer; + Length : Natural) + is + F2 : constant Natural := 0; + L2 : constant Natural := Length - 1; + + begin + Put (File, Title); + New_Line (File); + + for J in F2 .. L2 loop + Put (File, Image (IT.Table (Vector + J)), 1, 0, 1, F2, L2, J); + end loop; + end Put_Int_Vector; + + ---------------------- + -- Put_Reduced_Keys -- + ---------------------- + + procedure Put_Reduced_Keys (File : File_Descriptor; Title : String) is + F1 : constant Natural := 0; + L1 : constant Natural := NK - 1; + M : constant Natural := Max / 5; + K : Key_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + K := Get_Key (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (K.Edge, M), F1, L1, J, 1, 3, 2); + Put (File, Trim_Trailing_Nuls (WT.Table (Reduced (J)).all), + F1, L1, J, 1, 3, 3); + end loop; + end Put_Reduced_Keys; + + ----------------------- + -- Put_Used_Char_Set -- + ----------------------- + + procedure Put_Used_Char_Set (File : File_Descriptor; Title : String) is + F : constant Natural := Character'Pos (Character'First); + L : constant Natural := Character'Pos (Character'Last); + + begin + Put (File, Title); + New_Line (File); + + for J in Character'Range loop + Put + (File, Image (Get_Used_Char (J)), 1, 0, 1, F, L, Character'Pos (J)); + end loop; + end Put_Used_Char_Set; + + ---------------------- + -- Put_Vertex_Table -- + ---------------------- + + procedure Put_Vertex_Table (File : File_Descriptor; Title : String) is + F1 : constant Natural := 0; + L1 : constant Natural := NV - 1; + M : constant Natural := Max / 4; + V : Vertex_Type; + + begin + Put (File, Title); + New_Line (File); + + for J in F1 .. L1 loop + V := Get_Vertices (J); + Put (File, Image (J, M), F1, L1, J, 1, 3, 1); + Put (File, Image (V.First, M), F1, L1, J, 1, 3, 2); + Put (File, Image (V.Last, M), F1, L1, J, 1, 3, 3); + end loop; + end Put_Vertex_Table; + + ------------ + -- Random -- + ------------ + + procedure Random (Seed : in out Natural) is + + -- Park & Miller Standard Minimal using Schrage's algorithm to avoid + -- overflow: Xn+1 = 16807 * Xn mod (2 ** 31 - 1) + + R : Natural; + Q : Natural; + X : Integer; + + begin + R := Seed mod 127773; + Q := Seed / 127773; + X := 16807 * R - 2836 * Q; + + Seed := (if X < 0 then X + 2147483647 else X); + end Random; + + ------------- + -- Reduced -- + ------------- + + function Reduced (K : Key_Id) return Word_Id is + begin + return K + NK + 1; + end Reduced; + + ----------------- + -- Resize_Word -- + ----------------- + + procedure Resize_Word (W : in out Word_Type; Len : Natural) is + S1 : constant String := W.all; + S2 : String (1 .. Len) := (others => ASCII.NUL); + L : constant Natural := S1'Length; + begin + if L /= Len then + Free_Word (W); + S2 (1 .. L) := S1; + W := New_Word (S2); + end if; + end Resize_Word; + + -------------------------- + -- Select_Char_Position -- + -------------------------- + + procedure Select_Char_Position is + + type Vertex_Table_Type is array (Natural range <>) of Vertex_Type; + + procedure Build_Identical_Keys_Sets + (Table : in out Vertex_Table_Type; + Last : in out Natural; + Pos : Natural); + -- Build a list of keys subsets that are identical with the current + -- position selection plus Pos. Once this routine is called, reduced + -- words are sorted by subsets and each item (First, Last) in Sets + -- defines the range of identical keys. + -- Need comment saying exactly what Last is ??? + + function Count_Different_Keys + (Table : Vertex_Table_Type; + Last : Natural; + Pos : Natural) return Natural; + -- For each subset in Sets, count the number of different keys if we add + -- Pos to the current position selection. + + Sel_Position : IT.Table_Type (1 .. Max_Key_Len); + Last_Sel_Pos : Natural := 0; + Max_Sel_Pos : Natural := 0; + + ------------------------------- + -- Build_Identical_Keys_Sets -- + ------------------------------- + + procedure Build_Identical_Keys_Sets + (Table : in out Vertex_Table_Type; + Last : in out Natural; + Pos : Natural) + is + S : constant Vertex_Table_Type := Table (Table'First .. Last); + C : constant Natural := Pos; + -- Shortcuts (why are these not renames ???) + + F : Integer; + L : Integer; + -- First and last words of a subset + + Offset : Natural; + -- GNAT.Heap_Sort assumes that the first array index is 1. Offset + -- defines the translation to operate. + + function Lt (L, R : Natural) return Boolean; + procedure Move (From : Natural; To : Natural); + -- Subprograms needed by GNAT.Heap_Sort_G + + -------- + -- Lt -- + -------- + + function Lt (L, R : Natural) return Boolean is + C : constant Natural := Pos; + Left : Natural; + Right : Natural; + + begin + if L = 0 then + Left := NK; + Right := Offset + R; + elsif R = 0 then + Left := Offset + L; + Right := NK; + else + Left := Offset + L; + Right := Offset + R; + end if; + + return WT.Table (Left)(C) < WT.Table (Right)(C); + end Lt; + + ---------- + -- Move -- + ---------- + + procedure Move (From : Natural; To : Natural) is + Target, Source : Natural; + + begin + if From = 0 then + Source := NK; + Target := Offset + To; + elsif To = 0 then + Source := Offset + From; + Target := NK; + else + Source := Offset + From; + Target := Offset + To; + end if; + + WT.Table (Target) := WT.Table (Source); + WT.Table (Source) := null; + end Move; + + package Sorting is new GNAT.Heap_Sort_G (Move, Lt); + + -- Start of processing for Build_Identical_Key_Sets + + begin + Last := 0; + + -- For each subset in S, extract the new subsets we have by adding C + -- in the position selection. + + for J in S'Range loop + if S (J).First = S (J).Last then + F := S (J).First; + L := S (J).Last; + Last := Last + 1; + Table (Last) := (F, L); + + else + Offset := Reduced (S (J).First) - 1; + Sorting.Sort (S (J).Last - S (J).First + 1); + + F := S (J).First; + L := F; + for N in S (J).First .. S (J).Last loop + + -- For the last item, close the last subset + + if N = S (J).Last then + Last := Last + 1; + Table (Last) := (F, N); + + -- Two contiguous words are identical when they have the + -- same Cth character. + + elsif WT.Table (Reduced (N))(C) = + WT.Table (Reduced (N + 1))(C) + then + L := N + 1; + + -- Find a new subset of identical keys. Store the current + -- one and create a new subset. + + else + Last := Last + 1; + Table (Last) := (F, L); + F := N + 1; + L := F; + end if; + end loop; + end if; + end loop; + end Build_Identical_Keys_Sets; + + -------------------------- + -- Count_Different_Keys -- + -------------------------- + + function Count_Different_Keys + (Table : Vertex_Table_Type; + Last : Natural; + Pos : Natural) return Natural + is + N : array (Character) of Natural; + C : Character; + T : Natural := 0; + + begin + -- For each subset, count the number of words that are still + -- different when we include Pos in the position selection. Only + -- focus on this position as the other positions already produce + -- identical keys. + + for S in 1 .. Last loop + + -- Count the occurrences of the different characters + + N := (others => 0); + for K in Table (S).First .. Table (S).Last loop + C := WT.Table (Reduced (K))(Pos); + N (C) := N (C) + 1; + end loop; + + -- Update the number of different keys. Each character used + -- denotes a different key. + + for J in N'Range loop + if N (J) > 0 then + T := T + 1; + end if; + end loop; + end loop; + + return T; + end Count_Different_Keys; + + -- Start of processing for Select_Char_Position + + begin + -- Initialize the reduced words set + + for K in 0 .. NK - 1 loop + WT.Table (Reduced (K)) := New_Word (WT.Table (Initial (K)).all); + end loop; + + declare + Differences : Natural; + Max_Differences : Natural := 0; + Old_Differences : Natural; + Max_Diff_Sel_Pos : Natural := 0; -- init to kill warning + Max_Diff_Sel_Pos_Idx : Natural := 0; -- init to kill warning + Same_Keys_Sets_Table : Vertex_Table_Type (1 .. NK); + Same_Keys_Sets_Last : Natural := 1; + + begin + for C in Sel_Position'Range loop + Sel_Position (C) := C; + end loop; + + Same_Keys_Sets_Table (1) := (0, NK - 1); + + loop + -- Preserve maximum number of different keys and check later on + -- that this value is strictly incrementing. Otherwise, it means + -- that two keys are strictly identical. + + Old_Differences := Max_Differences; + + -- The first position should not exceed the minimum key length. + -- Otherwise, we may end up with an empty word once reduced. + + Max_Sel_Pos := + (if Last_Sel_Pos = 0 then Min_Key_Len else Max_Key_Len); + + -- Find which position increases more the number of differences + + for J in Last_Sel_Pos + 1 .. Max_Sel_Pos loop + Differences := Count_Different_Keys + (Same_Keys_Sets_Table, + Same_Keys_Sets_Last, + Sel_Position (J)); + + if Verbose then + Put (Output, + "Selecting position" & Sel_Position (J)'Img & + " results in" & Differences'Img & + " differences"); + New_Line (Output); + end if; + + if Differences > Max_Differences then + Max_Differences := Differences; + Max_Diff_Sel_Pos := Sel_Position (J); + Max_Diff_Sel_Pos_Idx := J; + end if; + end loop; + + if Old_Differences = Max_Differences then + raise Program_Error with "some keys are identical"; + end if; + + -- Insert selected position and sort Sel_Position table + + Last_Sel_Pos := Last_Sel_Pos + 1; + Sel_Position (Last_Sel_Pos + 1 .. Max_Diff_Sel_Pos_Idx) := + Sel_Position (Last_Sel_Pos .. Max_Diff_Sel_Pos_Idx - 1); + Sel_Position (Last_Sel_Pos) := Max_Diff_Sel_Pos; + + for P in 1 .. Last_Sel_Pos - 1 loop + if Max_Diff_Sel_Pos < Sel_Position (P) then + Sel_Position (P + 1 .. Last_Sel_Pos) := + Sel_Position (P .. Last_Sel_Pos - 1); + Sel_Position (P) := Max_Diff_Sel_Pos; + exit; + end if; + end loop; + + exit when Max_Differences = NK; + + Build_Identical_Keys_Sets + (Same_Keys_Sets_Table, + Same_Keys_Sets_Last, + Max_Diff_Sel_Pos); + + if Verbose then + Put (Output, + "Selecting position" & Max_Diff_Sel_Pos'Img & + " results in" & Max_Differences'Img & + " differences"); + New_Line (Output); + Put (Output, "--"); + New_Line (Output); + for J in 1 .. Same_Keys_Sets_Last loop + for K in + Same_Keys_Sets_Table (J).First .. + Same_Keys_Sets_Table (J).Last + loop + Put (Output, + Trim_Trailing_Nuls (WT.Table (Reduced (K)).all)); + New_Line (Output); + end loop; + Put (Output, "--"); + New_Line (Output); + end loop; + end if; + end loop; + end; + + Char_Pos_Set_Len := Last_Sel_Pos; + Char_Pos_Set := Allocate (Char_Pos_Set_Len); + + for C in 1 .. Last_Sel_Pos loop + Set_Char_Pos (C - 1, Sel_Position (C)); + end loop; + end Select_Char_Position; + + -------------------------- + -- Select_Character_Set -- + -------------------------- + + procedure Select_Character_Set is + Last : Natural := 0; + Used : array (Character) of Boolean := (others => False); + Char : Character; + + begin + for J in 0 .. NK - 1 loop + for K in 0 .. Char_Pos_Set_Len - 1 loop + Char := WT.Table (Initial (J))(Get_Char_Pos (K)); + exit when Char = ASCII.NUL; + Used (Char) := True; + end loop; + end loop; + + Used_Char_Set_Len := 256; + Used_Char_Set := Allocate (Used_Char_Set_Len); + + for J in Used'Range loop + if Used (J) then + Set_Used_Char (J, Last); + Last := Last + 1; + else + Set_Used_Char (J, 0); + end if; + end loop; + end Select_Character_Set; + + ------------------ + -- Set_Char_Pos -- + ------------------ + + procedure Set_Char_Pos (P : Natural; Item : Natural) is + N : constant Natural := Char_Pos_Set + P; + begin + IT.Table (N) := Item; + end Set_Char_Pos; + + --------------- + -- Set_Edges -- + --------------- + + procedure Set_Edges (F : Natural; Item : Edge_Type) is + N : constant Natural := Edges + (F * Edge_Size); + begin + IT.Table (N) := Item.X; + IT.Table (N + 1) := Item.Y; + IT.Table (N + 2) := Item.Key; + end Set_Edges; + + --------------- + -- Set_Graph -- + --------------- + + procedure Set_Graph (N : Natural; Item : Integer) is + begin + IT.Table (G + N) := Item; + end Set_Graph; + + ------------- + -- Set_Key -- + ------------- + + procedure Set_Key (N : Key_Id; Item : Key_Type) is + begin + IT.Table (Keys + N) := Item.Edge; + end Set_Key; + + --------------- + -- Set_Table -- + --------------- + + procedure Set_Table (T : Integer; X, Y : Natural; Item : Natural) is + N : constant Natural := T + ((Y * T1_Len) + X); + begin + IT.Table (N) := Item; + end Set_Table; + + ------------------- + -- Set_Used_Char -- + ------------------- + + procedure Set_Used_Char (C : Character; Item : Natural) is + N : constant Natural := Used_Char_Set + Character'Pos (C); + begin + IT.Table (N) := Item; + end Set_Used_Char; + + ------------------ + -- Set_Vertices -- + ------------------ + + procedure Set_Vertices (F : Natural; Item : Vertex_Type) is + N : constant Natural := Vertices + (F * Vertex_Size); + begin + IT.Table (N) := Item.First; + IT.Table (N + 1) := Item.Last; + end Set_Vertices; + + --------- + -- Sum -- + --------- + + function Sum + (Word : Word_Type; + Table : Table_Id; + Opt : Optimization) return Natural + is + S : Natural := 0; + R : Natural; + + begin + case Opt is + when CPU_Time => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, Get_Used_Char (Word (J + 1))); + S := (S + R) mod NV; + end loop; + + when Memory_Space => + for J in 0 .. T1_Len - 1 loop + exit when Word (J + 1) = ASCII.NUL; + R := Get_Table (Table, J, 0); + S := (S + R * Character'Pos (Word (J + 1))) mod NV; + end loop; + end case; + + return S; + end Sum; + + ------------------------ + -- Trim_Trailing_Nuls -- + ------------------------ + + function Trim_Trailing_Nuls (Str : String) return String is + begin + for J in reverse Str'Range loop + if Str (J) /= ASCII.NUL then + return Str (Str'First .. J); + end if; + end loop; + + return Str; + end Trim_Trailing_Nuls; + + --------------- + -- Type_Size -- + --------------- + + function Type_Size (L : Natural) return Natural is + begin + if L <= 2 ** 8 then + return 8; + elsif L <= 2 ** 16 then + return 16; + else + return 32; + end if; + end Type_Size; + + ----------- + -- Value -- + ----------- + + function Value + (Name : Table_Name; + J : Natural; + K : Natural := 0) return Natural + is + begin + case Name is + when Character_Position => + return Get_Char_Pos (J); + + when Used_Character_Set => + return Get_Used_Char (Character'Val (J)); + + when Function_Table_1 => + return Get_Table (T1, J, K); + + when Function_Table_2 => + return Get_Table (T2, J, K); + + when Graph_Table => + return Get_Graph (J); + end case; + end Value; + +end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/libgnat/g-pehage.ads b/gcc/ada/libgnat/g-pehage.ads new file mode 100644 index 0000000..d09c5bd --- /dev/null +++ b/gcc/ada/libgnat/g-pehage.ads @@ -0,0 +1,238 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . P E R F E C T _ H A S H _ G E N E R A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 generator of static minimal perfect hash functions. +-- To understand what a perfect hash function is, we define several notions. +-- These definitions are inspired from the following paper: + +-- Zbigniew J. Czech, George Havas, and Bohdan S. Majewski ``An Optimal +-- Algorithm for Generating Minimal Perfect Hash Functions'', Information +-- Processing Letters, 43(1992) pp.257-264, Oct.1992 + +-- Let W be a set of m words. A hash function h is a function that maps the +-- set of words W into some given interval I of integers [0, k-1], where k is +-- an integer, usually k >= m. h (w) where w is a word in W computes an +-- address or an integer from I for the storage or the retrieval of that +-- item. The storage area used to store items is known as a hash table. Words +-- for which the same address is computed are called synonyms. Due to the +-- existence of synonyms a situation called collision may arise in which two +-- items w1 and w2 have the same address. Several schemes for resolving +-- collisions are known. A perfect hash function is an injection from the word +-- set W to the integer interval I with k >= m. If k = m, then h is a minimal +-- perfect hash function. A hash function is order preserving if it puts +-- entries into the hash table in a prespecified order. + +-- A minimal perfect hash function is defined by two properties: + +-- Since no collisions occur each item can be retrieved from the table in +-- *one* probe. This represents the "perfect" property. + +-- The hash table size corresponds to the exact size of W and *no larger*. +-- This represents the "minimal" property. + +-- The functions generated by this package require the words to be known in +-- advance (they are "static" hash functions). The hash functions are also +-- order preserving. If w2 is inserted after w1 in the generator, then h (w1) +-- < h (w2). These hashing functions are convenient for use with realtime +-- applications. + +package GNAT.Perfect_Hash_Generators is + + Default_K_To_V : constant Float := 2.05; + -- Default ratio for the algorithm. When K is the number of keys, V = + -- (K_To_V) * K is the size of the main table of the hash function. To + -- converge, the algorithm requires K_To_V to be strictly greater than 2.0. + + Default_Pkg_Name : constant String := "Perfect_Hash"; + -- Default package name in which the hash function is defined + + Default_Position : constant String := ""; + -- The generator allows selection of the character positions used in the + -- hash function. By default, all positions are selected. + + Default_Tries : constant Positive := 20; + -- This algorithm may not succeed to find a possible mapping on the first + -- try and may have to iterate a number of times. This constant bounds the + -- number of tries. + + type Optimization is (Memory_Space, CPU_Time); + -- Optimize either the memory space or the execution time. Note: in + -- practice, the optimization mode has little effect on speed. The tables + -- are somewhat smaller with Memory_Space. + + Verbose : Boolean := False; + -- Output the status of the algorithm. For instance, the tables, the random + -- graph (edges, vertices) and selected char positions are output between + -- two iterations. + + procedure Initialize + (Seed : Natural; + K_To_V : Float := Default_K_To_V; + Optim : Optimization := Memory_Space; + Tries : Positive := Default_Tries); + -- Initialize the generator and its internal structures. Set the ratio of + -- vertices over keys in the random graphs. This value has to be greater + -- than 2.0 in order for the algorithm to succeed. The word set is not + -- modified (in particular when it is already set). For instance, it is + -- possible to run several times the generator with different settings on + -- the same words. + -- + -- A classical way of doing is to Insert all the words and then to invoke + -- Initialize and Compute. If Compute fails to find a perfect hash + -- function, invoke Initialize another time with other configuration + -- parameters (probably with a greater K_To_V ratio). Once successful, + -- invoke Produce and Finalize. + + procedure Finalize; + -- Deallocate the internal structures and the words table + + procedure Insert (Value : String); + -- Insert a new word into the table. ASCII.NUL characters are not allowed. + + Too_Many_Tries : exception; + -- Raised after Tries unsuccessful runs + + procedure Compute (Position : String := Default_Position); + -- Compute the hash function. Position allows the definition of selection + -- of character positions used in the word hash function. Positions can be + -- separated by commas and ranges like x-y may be used. Character '$' + -- represents the final character of a word. With an empty position, the + -- generator automatically produces positions to reduce the memory usage. + -- Raise Too_Many_Tries if the algorithm does not succeed within Tries + -- attempts (see Initialize). + + procedure Produce + (Pkg_Name : String := Default_Pkg_Name; + Use_Stdout : Boolean := False); + -- Generate the hash function package Pkg_Name. This package includes the + -- minimal perfect Hash function. The output is normally placed in the + -- current directory, in files X.ads and X.adb, where X is the standard + -- GNAT file name for a package named Pkg_Name. If Use_Stdout is True, the + -- output goes to standard output, and no files are written. + + ---------------------------------------------------------------- + + -- The routines and structures defined below allow producing the hash + -- function using a different way from the procedure above. The procedure + -- Define returns the lengths of an internal table and its item type size. + -- The function Value returns the value of each item in the table. + + -- The hash function has the following form: + + -- h (w) = (g (f1 (w)) + g (f2 (w))) mod m + + -- G is a function based on a graph table [0,n-1] -> [0,m-1]. m is the + -- number of keys. n is an internally computed value and it can be obtained + -- as the length of vector G. + + -- F1 and F2 are two functions based on two function tables T1 and T2. + -- Their definition depends on the chosen optimization mode. + + -- Only some character positions are used in the words because they are + -- significant. They are listed in a character position table (P in the + -- pseudo-code below). For instance, in {"jan", "feb", "mar", "apr", "jun", + -- "jul", "aug", "sep", "oct", "nov", "dec"}, only positions 2 and 3 are + -- significant (the first character can be ignored). In this example, P = + -- {2, 3} + + -- When Optimization is CPU_Time, the first dimension of T1 and T2 + -- corresponds to the character position in the word and the second to the + -- character set. As all the character set is not used, we define a used + -- character table which associates a distinct index to each used character + -- (unused characters are mapped to zero). In this case, the second + -- dimension of T1 and T2 is reduced to the used character set (C in the + -- pseudo-code below). Therefore, the hash function has the following: + + -- function Hash (S : String) return Natural is + -- F : constant Natural := S'First - 1; + -- L : constant Natural := S'Length; + -- F1, F2 : Natural := 0; + -- J : ; + + -- begin + -- for K in P'Range loop + -- exit when L < P (K); + -- J := C (S (P (K) + F)); + -- F1 := (F1 + Natural (T1 (K, J))) mod ; + -- F2 := (F2 + Natural (T2 (K, J))) mod ; + -- end loop; + + -- return (Natural (G (F1)) + Natural (G (F2))) mod ; + -- end Hash; + + -- When Optimization is Memory_Space, the first dimension of T1 and T2 + -- corresponds to the character position in the word and the second + -- dimension is ignored. T1 and T2 are no longer matrices but vectors. + -- Therefore, the used character table is not available. The hash function + -- has the following form: + + -- function Hash (S : String) return Natural is + -- F : constant Natural := S'First - 1; + -- L : constant Natural := S'Length; + -- F1, F2 : Natural := 0; + -- J : ; + + -- begin + -- for K in P'Range loop + -- exit when L < P (K); + -- J := Character'Pos (S (P (K) + F)); + -- F1 := (F1 + Natural (T1 (K) * J)) mod ; + -- F2 := (F2 + Natural (T2 (K) * J)) mod ; + -- end loop; + + -- return (Natural (G (F1)) + Natural (G (F2))) mod ; + -- end Hash; + + type Table_Name is + (Character_Position, + Used_Character_Set, + Function_Table_1, + Function_Table_2, + Graph_Table); + + procedure Define + (Name : Table_Name; + Item_Size : out Natural; + Length_1 : out Natural; + Length_2 : out Natural); + -- Return the definition of the table Name. This includes the length of + -- dimensions 1 and 2 and the size of an unsigned integer item. When + -- Length_2 is zero, the table has only one dimension. All the ranges + -- start from zero. + + function Value + (Name : Table_Name; + J : Natural; + K : Natural := 0) return Natural; + -- Return the value of the component (I, J) of the table Name. When the + -- table has only one dimension, J is ignored. + +end GNAT.Perfect_Hash_Generators; diff --git a/gcc/ada/libgnat/g-rannum.adb b/gcc/ada/libgnat/g-rannum.adb new file mode 100644 index 0000000..dd5c7f0 --- /dev/null +++ b/gcc/ada/libgnat/g-rannum.adb @@ -0,0 +1,344 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . R A N D O M _ N U M B E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Long_Elementary_Functions; +use Ada.Numerics.Long_Elementary_Functions; +with Ada.Unchecked_Conversion; + +with System.Random_Numbers; use System.Random_Numbers; + +package body GNAT.Random_Numbers with + SPARK_Mode => Off +is + Sys_Max_Image_Width : constant := System.Random_Numbers.Max_Image_Width; + + subtype Image_String is String (1 .. Max_Image_Width); + + -- Utility function declarations + + procedure Insert_Image + (S : in out Image_String; + Index : Integer; + V : Integer_64); + -- Insert string representation of V in S starting at position Index + + --------------- + -- To_Signed -- + --------------- + + function To_Signed is + new Ada.Unchecked_Conversion (Unsigned_32, Integer_32); + function To_Signed is + new Ada.Unchecked_Conversion (Unsigned_64, Integer_64); + + ------------------ + -- Insert_Image -- + ------------------ + + procedure Insert_Image + (S : in out Image_String; + Index : Integer; + V : Integer_64) + is + Image : constant String := Integer_64'Image (V); + begin + S (Index .. Index + Image'Length - 1) := Image; + end Insert_Image; + + --------------------- + -- Random_Discrete -- + --------------------- + + function Random_Discrete + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype + is + function F is + new System.Random_Numbers.Random_Discrete + (Result_Subtype, Default_Min); + begin + return F (Gen.Rep, Min, Max); + end Random_Discrete; + + -------------------------- + -- Random_Decimal_Fixed -- + -------------------------- + + function Random_Decimal_Fixed + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype + is + subtype IntV is Integer_64 range + Integer_64'Integer_Value (Min) .. + Integer_64'Integer_Value (Max); + function R is new Random_Discrete (Integer_64, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end Random_Decimal_Fixed; + + --------------------------- + -- Random_Ordinary_Fixed -- + --------------------------- + + function Random_Ordinary_Fixed + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype + is + subtype IntV is Integer_64 range + Integer_64'Integer_Value (Min) .. + Integer_64'Integer_Value (Max); + function R is new Random_Discrete (Integer_64, IntV'First); + begin + return Result_Subtype'Fixed_Value (R (Gen, IntV'First, IntV'Last)); + end Random_Ordinary_Fixed; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Float is + begin + return Random (Gen.Rep); + end Random; + + function Random (Gen : Generator) return Long_Float is + begin + return Random (Gen.Rep); + end Random; + + function Random (Gen : Generator) return Interfaces.Unsigned_32 is + begin + return Random (Gen.Rep); + end Random; + + function Random (Gen : Generator) return Interfaces.Unsigned_64 is + begin + return Random (Gen.Rep); + end Random; + + function Random (Gen : Generator) return Integer_64 is + begin + return To_Signed (Unsigned_64'(Random (Gen))); + end Random; + + function Random (Gen : Generator) return Integer_32 is + begin + return To_Signed (Unsigned_32'(Random (Gen))); + end Random; + + function Random (Gen : Generator) return Long_Integer is + function Random_Long_Integer is new Random_Discrete (Long_Integer); + begin + return Random_Long_Integer (Gen); + end Random; + + function Random (Gen : Generator) return Integer is + function Random_Integer is new Random_Discrete (Integer); + begin + return Random_Integer (Gen); + end Random; + + ------------------ + -- Random_Float -- + ------------------ + + function Random_Float (Gen : Generator) return Result_Subtype is + function F is new System.Random_Numbers.Random_Float (Result_Subtype); + begin + return F (Gen.Rep); + end Random_Float; + + --------------------- + -- Random_Gaussian -- + --------------------- + + -- Generates pairs of normally distributed values using the polar method of + -- G. E. P. Box, M. E. Muller, and G. Marsaglia. See Donald E. Knuth, The + -- Art of Computer Programming, Vol 2: Seminumerical Algorithms, section + -- 3.4.1, subsection C, algorithm P. Returns half of the pair on each call, + -- using the Next_Gaussian field of Gen to hold the second member on + -- even-numbered calls. + + function Random_Gaussian (Gen : Generator) return Long_Float is + G : Generator renames Gen'Unrestricted_Access.all; + + V1, V2, Rad2, Mult : Long_Float; + + begin + if G.Have_Gaussian then + G.Have_Gaussian := False; + return G.Next_Gaussian; + + else + loop + V1 := 2.0 * Random (G) - 1.0; + V2 := 2.0 * Random (G) - 1.0; + Rad2 := V1 ** 2 + V2 ** 2; + exit when Rad2 < 1.0 and then Rad2 /= 0.0; + end loop; + + -- Now V1 and V2 are coordinates in the unit circle + + Mult := Sqrt (-2.0 * Log (Rad2) / Rad2); + G.Next_Gaussian := V2 * Mult; + G.Have_Gaussian := True; + return Long_Float'Machine (V1 * Mult); + end if; + end Random_Gaussian; + + function Random_Gaussian (Gen : Generator) return Float is + V : constant Long_Float := Random_Gaussian (Gen); + begin + return Float'Machine (Float (V)); + end Random_Gaussian; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : out Generator) is + begin + Reset (Gen.Rep); + Gen.Have_Gaussian := False; + end Reset; + + procedure Reset + (Gen : out Generator; + Initiator : Initialization_Vector) + is + begin + Reset (Gen.Rep, Initiator); + Gen.Have_Gaussian := False; + end Reset; + + procedure Reset + (Gen : out Generator; + Initiator : Interfaces.Integer_32) + is + begin + Reset (Gen.Rep, Initiator); + Gen.Have_Gaussian := False; + end Reset; + + procedure Reset + (Gen : out Generator; + Initiator : Interfaces.Unsigned_32) + is + begin + Reset (Gen.Rep, Initiator); + Gen.Have_Gaussian := False; + end Reset; + + procedure Reset + (Gen : out Generator; + Initiator : Integer) + is + begin + Reset (Gen.Rep, Initiator); + Gen.Have_Gaussian := False; + end Reset; + + procedure Reset + (Gen : out Generator; + From_State : Generator) + is + begin + Reset (Gen.Rep, From_State.Rep); + Gen.Have_Gaussian := From_State.Have_Gaussian; + Gen.Next_Gaussian := From_State.Next_Gaussian; + end Reset; + + Frac_Scale : constant Long_Float := + Long_Float + (Long_Float'Machine_Radix) ** Long_Float'Machine_Mantissa; + + function Val64 (Image : String) return Integer_64; + -- Renames Integer64'Value + -- We cannot use a 'renames Integer64'Value' since for some strange + -- reason, this requires a dependency on s-auxdec.ads which not all + -- run-times support ??? + + function Val64 (Image : String) return Integer_64 is + begin + return Integer_64'Value (Image); + end Val64; + + procedure Reset + (Gen : out Generator; + From_Image : String) + is + F0 : constant Integer := From_Image'First; + T0 : constant Integer := From_Image'First + Sys_Max_Image_Width; + + begin + Reset (Gen.Rep, From_Image (F0 .. F0 + Sys_Max_Image_Width)); + + if From_Image (T0 + 1) = '1' then + Gen.Have_Gaussian := True; + Gen.Next_Gaussian := + Long_Float (Val64 (From_Image (T0 + 3 .. T0 + 23))) / Frac_Scale + * Long_Float (Long_Float'Machine_Radix) + ** Integer (Val64 (From_Image (T0 + 25 .. From_Image'Last))); + else + Gen.Have_Gaussian := False; + end if; + end Reset; + + ----------- + -- Image -- + ----------- + + function Image (Gen : Generator) return String is + Result : Image_String; + + begin + Result := (others => ' '); + Result (1 .. Sys_Max_Image_Width) := Image (Gen.Rep); + + if Gen.Have_Gaussian then + Result (Sys_Max_Image_Width + 2) := '1'; + Insert_Image (Result, Sys_Max_Image_Width + 4, + Integer_64 (Long_Float'Fraction (Gen.Next_Gaussian) + * Frac_Scale)); + Insert_Image (Result, Sys_Max_Image_Width + 24, + Integer_64 (Long_Float'Exponent (Gen.Next_Gaussian))); + + else + Result (Sys_Max_Image_Width + 2) := '0'; + end if; + + return Result; + end Image; + +end GNAT.Random_Numbers; diff --git a/gcc/ada/libgnat/g-rannum.ads b/gcc/ada/libgnat/g-rannum.ads new file mode 100644 index 0000000..d230d48 --- /dev/null +++ b/gcc/ada/libgnat/g-rannum.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . R A N D O M _ N U M B E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Extended pseudo-random number generation + +-- This package provides a type representing pseudo-random number generators, +-- and subprograms to extract various distributions of numbers from them. It +-- also provides types for representing initialization values and snapshots of +-- internal generator state, which permit reproducible pseudo-random streams. + +-- The generator currently provided by this package has an extremely long +-- period (at least 2**19937-1), and passes the Big Crush test suite, with the +-- exception of the two linear complexity tests. Therefore, it is suitable for +-- simulations, but should not be used as a cryptographic pseudo-random source +-- without additional processing. + +-- The design of this package effects is simplified compared to the design +-- of standard Ada.Numerics packages. There is no separate State type; the +-- Generator type itself suffices for this purpose. The parameter modes on +-- Reset procedures better reflect the effect of these routines. + +-- Note: this package is marked SPARK_Mode Off, because functions Random work +-- by side-effect to change the value of the generator, hence they should not +-- be called from SPARK code. + +with System.Random_Numbers; +with Interfaces; use Interfaces; + +package GNAT.Random_Numbers with + SPARK_Mode => Off +is + type Generator is limited private; + subtype Initialization_Vector is + System.Random_Numbers.Initialization_Vector; + + function Random (Gen : Generator) return Float; + function Random (Gen : Generator) return Long_Float; + -- Return pseudo-random numbers uniformly distributed on [0 .. 1) + + function Random (Gen : Generator) return Interfaces.Integer_32; + function Random (Gen : Generator) return Interfaces.Unsigned_32; + function Random (Gen : Generator) return Interfaces.Integer_64; + function Random (Gen : Generator) return Interfaces.Unsigned_64; + function Random (Gen : Generator) return Integer; + function Random (Gen : Generator) return Long_Integer; + -- Return pseudo-random numbers uniformly distributed on T'First .. T'Last + -- for various builtin integer types. + + generic + type Result_Subtype is (<>); + Default_Min : Result_Subtype := Result_Subtype'Val (0); + function Random_Discrete + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; + -- Returns pseudo-random numbers uniformly distributed on Min .. Max + + generic + type Result_Subtype is delta <>; + Default_Min : Result_Subtype := 0.0; + function Random_Ordinary_Fixed + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; + -- Returns pseudo-random numbers uniformly distributed on Min .. Max + + generic + type Result_Subtype is delta <> digits <>; + Default_Min : Result_Subtype := 0.0; + function Random_Decimal_Fixed + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; + -- Returns pseudo-random numbers uniformly distributed on Min .. Max + + generic + type Result_Subtype is digits <>; + function Random_Float (Gen : Generator) return Result_Subtype; + -- Returns pseudo-random numbers uniformly distributed on [0.0 .. 1.0) + + function Random_Gaussian (Gen : Generator) return Long_Float; + function Random_Gaussian (Gen : Generator) return Float; + -- Returns pseudo-random numbers normally distributed value with mean 0 + -- and standard deviation 1.0. + + procedure Reset (Gen : out Generator); + -- Re-initialize the state of Gen from the time of day + + procedure Reset + (Gen : out Generator; + Initiator : Initialization_Vector); + procedure Reset + (Gen : out Generator; + Initiator : Interfaces.Integer_32); + procedure Reset + (Gen : out Generator; + Initiator : Interfaces.Unsigned_32); + procedure Reset + (Gen : out Generator; + Initiator : Integer); + -- Re-initialize Gen based on the Initiator in various ways. Identical + -- values of Initiator cause identical sequences of values. + + procedure Reset (Gen : out Generator; From_State : Generator); + -- Causes the state of Gen to be identical to that of From_State; Gen + -- and From_State will produce identical sequences of values subsequently. + + procedure Reset (Gen : out Generator; From_Image : String); + function Image (Gen : Generator) return String; + -- The call + -- Reset (Gen2, Image (Gen1)) + -- has the same effect as Reset (Gen2, Gen1); + + Max_Image_Width : constant := + System.Random_Numbers.Max_Image_Width + 2 + 20 + 5; + -- Maximum possible length of result of Image (...) + +private + + type Generator is limited record + Rep : System.Random_Numbers.Generator; + + Have_Gaussian : Boolean; + -- The algorithm used for Random_Gaussian produces deviates in + -- pairs. Have_Gaussian is true iff Random_Gaussian has returned one + -- member of the pair and Next_Gaussian contains the other. + + Next_Gaussian : Long_Float; + -- Next random deviate to be produced by Random_Gaussian, if + -- Have_Gaussian. + end record; + +end GNAT.Random_Numbers; diff --git a/gcc/ada/libgnat/g-regexp.adb b/gcc/ada/libgnat/g-regexp.adb new file mode 100644 index 0000000..cdee8ff --- /dev/null +++ b/gcc/ada/libgnat/g-regexp.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G E X P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-regexp.ads b/gcc/ada/libgnat/g-regexp.ads new file mode 100644 index 0000000..8e2e2c8 --- /dev/null +++ b/gcc/ada/libgnat/g-regexp.ads @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G E X P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple Regular expression matching + +-- This package provides a simple implementation of a regular expression +-- pattern matching algorithm, using a subset of the syntax of regular +-- expressions copied from familiar Unix style utilities. + +-- See file s-regexp.ads for full documentation of the interface + +------------------------------------------------------------ +-- Summary of Pattern Matching Packages in GNAT Hierarchy -- +------------------------------------------------------------ + +-- There are three related packages that perform pattern matching functions. +-- the following is an outline of these packages, to help you determine +-- which is best for your needs. + +-- GNAT.Regexp (files g-regexp.ads/s-regexp.ads/s-regexp.adb) +-- This is a simple package providing Unix-style regular expression +-- matching with the restriction that it matches entire strings. It +-- is particularly useful for file name matching, and in particular +-- it provides "globbing patterns" that are useful in implementing +-- unix or DOS style wild card matching for file names. + +-- GNAT.Regpat (files g-regpat.ads/s-regpat.ads/g-regpat.adb) +-- This is a more complete implementation of Unix-style regular +-- expressions, copied from the original V7 style regular expression +-- library written in C by Henry Spencer. It is functionally the +-- same as this library, and uses the same internal data structures +-- stored in a binary compatible manner. + +-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) +-- This is a completely general pattern matching package based on the +-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern +-- language is modeled on context free grammars, with context sensitive +-- extensions that provide full (type 0) computational capabilities. + +with System.Regexp; + +package GNAT.Regexp renames System.Regexp; diff --git a/gcc/ada/libgnat/g-regist.adb b/gcc/ada/libgnat/g-regist.adb new file mode 100644 index 0000000..5b097bb --- /dev/null +++ b/gcc/ada/libgnat/g-regist.adb @@ -0,0 +1,553 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G I S T R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; +with System; +with GNAT.Directory_Operations; + +package body GNAT.Registry is + + use System; + + ------------------------------ + -- Binding to the Win32 API -- + ------------------------------ + + subtype LONG is Interfaces.C.long; + subtype ULONG is Interfaces.C.unsigned_long; + subtype DWORD is ULONG; + + type PULONG is access all ULONG; + subtype PDWORD is PULONG; + subtype LPDWORD is PDWORD; + + subtype Error_Code is LONG; + + subtype REGSAM is LONG; + + type PHKEY is access all HKEY; + + ERROR_SUCCESS : constant Error_Code := 0; + + REG_SZ : constant := 1; + REG_EXPAND_SZ : constant := 2; + + function RegCloseKey (Key : HKEY) return LONG; + pragma Import (Stdcall, RegCloseKey, "RegCloseKey"); + + function RegCreateKeyEx + (Key : HKEY; + lpSubKey : Address; + Reserved : DWORD; + lpClass : Address; + dwOptions : DWORD; + samDesired : REGSAM; + lpSecurityAttributes : Address; + phkResult : PHKEY; + lpdwDisposition : LPDWORD) + return LONG; + pragma Import (Stdcall, RegCreateKeyEx, "RegCreateKeyExA"); + + function RegDeleteKey + (Key : HKEY; + lpSubKey : Address) return LONG; + pragma Import (Stdcall, RegDeleteKey, "RegDeleteKeyA"); + + function RegDeleteValue + (Key : HKEY; + lpValueName : Address) return LONG; + pragma Import (Stdcall, RegDeleteValue, "RegDeleteValueA"); + + function RegEnumValue + (Key : HKEY; + dwIndex : DWORD; + lpValueName : Address; + lpcbValueName : LPDWORD; + lpReserved : LPDWORD; + lpType : LPDWORD; + lpData : Address; + lpcbData : LPDWORD) return LONG; + pragma Import (Stdcall, RegEnumValue, "RegEnumValueA"); + + function RegOpenKeyEx + (Key : HKEY; + lpSubKey : Address; + ulOptions : DWORD; + samDesired : REGSAM; + phkResult : PHKEY) return LONG; + pragma Import (Stdcall, RegOpenKeyEx, "RegOpenKeyExA"); + + function RegQueryValueEx + (Key : HKEY; + lpValueName : Address; + lpReserved : LPDWORD; + lpType : LPDWORD; + lpData : Address; + lpcbData : LPDWORD) return LONG; + pragma Import (Stdcall, RegQueryValueEx, "RegQueryValueExA"); + + function RegSetValueEx + (Key : HKEY; + lpValueName : Address; + Reserved : DWORD; + dwType : DWORD; + lpData : Address; + cbData : DWORD) return LONG; + pragma Import (Stdcall, RegSetValueEx, "RegSetValueExA"); + + function RegEnumKey + (Key : HKEY; + dwIndex : DWORD; + lpName : Address; + cchName : DWORD) return LONG; + pragma Import (Stdcall, RegEnumKey, "RegEnumKeyA"); + + --------------------- + -- Local Constants -- + --------------------- + + Max_Key_Size : constant := 1_024; + -- Maximum number of characters for a registry key + + Max_Value_Size : constant := 2_048; + -- Maximum number of characters for a key's value + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function To_C_Mode (Mode : Key_Mode) return REGSAM; + -- Returns the Win32 mode value for the Key_Mode value + + procedure Check_Result (Result : LONG; Message : String); + -- Checks value Result and raise the exception Registry_Error if it is not + -- equal to ERROR_SUCCESS. Message and the error value (Result) is added + -- to the exception message. + + ------------------ + -- Check_Result -- + ------------------ + + procedure Check_Result (Result : LONG; Message : String) is + use type LONG; + begin + if Result /= ERROR_SUCCESS then + raise Registry_Error with + Message & " (" & LONG'Image (Result) & ')'; + end if; + end Check_Result; + + --------------- + -- Close_Key -- + --------------- + + procedure Close_Key (Key : HKEY) is + Result : LONG; + begin + Result := RegCloseKey (Key); + Check_Result (Result, "Close_Key"); + end Close_Key; + + ---------------- + -- Create_Key -- + ---------------- + + function Create_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Write) return HKEY + is + use type REGSAM; + use type DWORD; + + REG_OPTION_NON_VOLATILE : constant := 16#0#; + + C_Sub_Key : constant String := Sub_Key & ASCII.NUL; + C_Class : constant String := "" & ASCII.NUL; + C_Mode : constant REGSAM := To_C_Mode (Mode); + + New_Key : aliased HKEY; + Result : LONG; + Dispos : aliased DWORD; + + begin + Result := + RegCreateKeyEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + 0, + C_Class (C_Class'First)'Address, + REG_OPTION_NON_VOLATILE, + C_Mode, + Null_Address, + New_Key'Unchecked_Access, + Dispos'Unchecked_Access); + + Check_Result (Result, "Create_Key " & Sub_Key); + return New_Key; + end Create_Key; + + ---------------- + -- Delete_Key -- + ---------------- + + procedure Delete_Key (From_Key : HKEY; Sub_Key : String) is + C_Sub_Key : constant String := Sub_Key & ASCII.NUL; + Result : LONG; + begin + Result := RegDeleteKey (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); + Check_Result (Result, "Delete_Key " & Sub_Key); + end Delete_Key; + + ------------------ + -- Delete_Value -- + ------------------ + + procedure Delete_Value (From_Key : HKEY; Sub_Key : String) is + C_Sub_Key : constant String := Sub_Key & ASCII.NUL; + Result : LONG; + begin + Result := RegDeleteValue (From_Key, C_Sub_Key (C_Sub_Key'First)'Address); + Check_Result (Result, "Delete_Value " & Sub_Key); + end Delete_Value; + + ------------------- + -- For_Every_Key -- + ------------------- + + procedure For_Every_Key + (From_Key : HKEY; + Recursive : Boolean := False) + is + procedure Recursive_For_Every_Key + (From_Key : HKEY; + Recursive : Boolean := False; + Quit : in out Boolean); + + ----------------------------- + -- Recursive_For_Every_Key -- + ----------------------------- + + procedure Recursive_For_Every_Key + (From_Key : HKEY; + Recursive : Boolean := False; + Quit : in out Boolean) + is + use type LONG; + use type ULONG; + + Index : ULONG := 0; + Result : LONG; + + Sub_Key : Interfaces.C.char_array (1 .. Max_Key_Size); + pragma Warnings (Off, Sub_Key); + + Size_Sub_Key : aliased ULONG; + Sub_Hkey : HKEY; + + function Current_Name return String; + + ------------------ + -- Current_Name -- + ------------------ + + function Current_Name return String is + begin + return Interfaces.C.To_Ada (Sub_Key); + end Current_Name; + + -- Start of processing for Recursive_For_Every_Key + + begin + loop + Size_Sub_Key := Sub_Key'Length; + + Result := + RegEnumKey + (From_Key, Index, Sub_Key (1)'Address, Size_Sub_Key); + + exit when not (Result = ERROR_SUCCESS); + + Sub_Hkey := Open_Key (From_Key, Interfaces.C.To_Ada (Sub_Key)); + + Action (Natural (Index) + 1, Sub_Hkey, Current_Name, Quit); + + if not Quit and then Recursive then + Recursive_For_Every_Key (Sub_Hkey, True, Quit); + end if; + + Close_Key (Sub_Hkey); + + exit when Quit; + + Index := Index + 1; + end loop; + end Recursive_For_Every_Key; + + -- Local Variables + + Quit : Boolean := False; + + -- Start of processing for For_Every_Key + + begin + Recursive_For_Every_Key (From_Key, Recursive, Quit); + end For_Every_Key; + + ------------------------- + -- For_Every_Key_Value -- + ------------------------- + + procedure For_Every_Key_Value + (From_Key : HKEY; + Expand : Boolean := False) + is + use GNAT.Directory_Operations; + use type LONG; + use type ULONG; + + Index : ULONG := 0; + Result : LONG; + + Sub_Key : String (1 .. Max_Key_Size); + pragma Warnings (Off, Sub_Key); + + Value : String (1 .. Max_Value_Size); + pragma Warnings (Off, Value); + + Size_Sub_Key : aliased ULONG; + Size_Value : aliased ULONG; + Type_Sub_Key : aliased DWORD; + + Quit : Boolean; + + begin + loop + Size_Sub_Key := Sub_Key'Length; + Size_Value := Value'Length; + + Result := + RegEnumValue + (From_Key, Index, + Sub_Key (1)'Address, + Size_Sub_Key'Unchecked_Access, + null, + Type_Sub_Key'Unchecked_Access, + Value (1)'Address, + Size_Value'Unchecked_Access); + + exit when not (Result = ERROR_SUCCESS); + + Quit := False; + + if Type_Sub_Key = REG_EXPAND_SZ and then Expand then + Action + (Natural (Index) + 1, + Sub_Key (1 .. Integer (Size_Sub_Key)), + Directory_Operations.Expand_Path + (Value (1 .. Integer (Size_Value) - 1), + Directory_Operations.DOS), + Quit); + + elsif Type_Sub_Key = REG_SZ or else Type_Sub_Key = REG_EXPAND_SZ then + Action + (Natural (Index) + 1, + Sub_Key (1 .. Integer (Size_Sub_Key)), + Value (1 .. Integer (Size_Value) - 1), + Quit); + end if; + + exit when Quit; + + Index := Index + 1; + end loop; + end For_Every_Key_Value; + + ---------------- + -- Key_Exists -- + ---------------- + + function Key_Exists + (From_Key : HKEY; + Sub_Key : String) return Boolean + is + New_Key : HKEY; + + begin + New_Key := Open_Key (From_Key, Sub_Key); + Close_Key (New_Key); + + -- We have been able to open the key so it exists + + return True; + + exception + when Registry_Error => + + -- An error occurred, the key was not found + + return False; + end Key_Exists; + + -------------- + -- Open_Key -- + -------------- + + function Open_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Only) return HKEY + is + use type REGSAM; + + C_Sub_Key : constant String := Sub_Key & ASCII.NUL; + C_Mode : constant REGSAM := To_C_Mode (Mode); + + New_Key : aliased HKEY; + Result : LONG; + + begin + Result := + RegOpenKeyEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + 0, + C_Mode, + New_Key'Unchecked_Access); + + Check_Result (Result, "Open_Key " & Sub_Key); + return New_Key; + end Open_Key; + + ----------------- + -- Query_Value -- + ----------------- + + function Query_Value + (From_Key : HKEY; + Sub_Key : String; + Expand : Boolean := False) return String + is + use GNAT.Directory_Operations; + use type LONG; + use type ULONG; + + Value : String (1 .. Max_Value_Size); + pragma Warnings (Off, Value); + + Size_Value : aliased ULONG; + Type_Value : aliased DWORD; + + C_Sub_Key : constant String := Sub_Key & ASCII.NUL; + Result : LONG; + + begin + Size_Value := Value'Length; + + Result := + RegQueryValueEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + null, + Type_Value'Unchecked_Access, + Value (Value'First)'Address, + Size_Value'Unchecked_Access); + + Check_Result (Result, "Query_Value " & Sub_Key & " key"); + + if Type_Value = REG_EXPAND_SZ and then Expand then + return Directory_Operations.Expand_Path + (Value (1 .. Integer (Size_Value - 1)), + Directory_Operations.DOS); + else + return Value (1 .. Integer (Size_Value - 1)); + end if; + end Query_Value; + + --------------- + -- Set_Value -- + --------------- + + procedure Set_Value + (From_Key : HKEY; + Sub_Key : String; + Value : String; + Expand : Boolean := False) + is + C_Sub_Key : constant String := Sub_Key & ASCII.NUL; + C_Value : constant String := Value & ASCII.NUL; + + Value_Type : DWORD; + Result : LONG; + + begin + Value_Type := (if Expand then REG_EXPAND_SZ else REG_SZ); + + Result := + RegSetValueEx + (From_Key, + C_Sub_Key (C_Sub_Key'First)'Address, + 0, + Value_Type, + C_Value (C_Value'First)'Address, + C_Value'Length); + + Check_Result (Result, "Set_Value " & Sub_Key & " key"); + end Set_Value; + + --------------- + -- To_C_Mode -- + --------------- + + function To_C_Mode (Mode : Key_Mode) return REGSAM is + use type REGSAM; + + KEY_READ : constant := 16#20019#; + KEY_WRITE : constant := 16#20006#; + KEY_WOW64_64KEY : constant := 16#00100#; + KEY_WOW64_32KEY : constant := 16#00200#; + + begin + case Mode is + when Read_Only => + return KEY_READ + KEY_WOW64_32KEY; + + when Read_Write => + return KEY_READ + KEY_WRITE + KEY_WOW64_32KEY; + + when Read_Only_64 => + return KEY_READ + KEY_WOW64_64KEY; + + when Read_Write_64 => + return KEY_READ + KEY_WRITE + KEY_WOW64_64KEY; + end case; + end To_C_Mode; + +end GNAT.Registry; diff --git a/gcc/ada/libgnat/g-regist.ads b/gcc/ada/libgnat/g-regist.ads new file mode 100644 index 0000000..806a06e --- /dev/null +++ b/gcc/ada/libgnat/g-regist.ads @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E G I S T R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The registry is a Windows database to store key/value pair. It is used +-- to keep Windows operation system and applications configuration options. +-- The database is a hierarchal set of key and for each key a value can +-- be associated. This package provides high level routines to deal with +-- the Windows registry. For full registry API, but at a lower level of +-- abstraction, refer to the Win32.Winreg package provided with the +-- Win32Ada binding. For example this binding handle only key values of +-- type Standard.String. + +-- This package is specific to the NT version of GNAT, and is not available +-- on any other platforms. + +package GNAT.Registry is + + type HKEY is private; + -- HKEY is a handle to a registry key, including standard registry keys: + -- HKEY_CLASSES_ROOT, HKEY_CURRENT_CONFIG, HKEY_CURRENT_USER, + -- HKEY_LOCAL_MACHINE, HKEY_USERS, HKEY_PERFORMANCE_DATA. + + HKEY_CLASSES_ROOT : constant HKEY; + HKEY_CURRENT_USER : constant HKEY; + HKEY_CURRENT_CONFIG : constant HKEY; + HKEY_LOCAL_MACHINE : constant HKEY; + HKEY_USERS : constant HKEY; + HKEY_PERFORMANCE_DATA : constant HKEY; + + type Key_Mode is + (Read_Only, Read_Write, -- operates on 32bit view of the registry + Read_Only_64, Read_Write_64); -- operates on 64bit view of the registry + -- Access mode for the registry key. The *_64 are only meaningful on + -- Windows 64bit and ignored on Windows 32bit where _64 are equivalent to + -- the non 64bit versions. + + Registry_Error : exception; + -- Registry_Error is raises by all routines below if a problem occurs + -- (key cannot be opened, key cannot be found etc). + + function Create_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Write) return HKEY; + -- Open or create a key (named Sub_Key) in the Windows registry database. + -- The key will be created under key From_Key. It returns the key handle. + -- From_Key must be a valid handle to an already opened key or one of + -- the standard keys identified by HKEY declarations above. + + function Open_Key + (From_Key : HKEY; + Sub_Key : String; + Mode : Key_Mode := Read_Only) return HKEY; + -- Return a registry key handle for key named Sub_Key opened under key + -- From_Key. It is possible to open a key at any level in the registry + -- tree in a single call to Open_Key. + + procedure Close_Key (Key : HKEY); + -- Close registry key handle. All resources used by Key are released + + function Key_Exists (From_Key : HKEY; Sub_Key : String) return Boolean; + -- Returns True if Sub_Key is defined under From_Key in the registry + + function Query_Value + (From_Key : HKEY; + Sub_Key : String; + Expand : Boolean := False) return String; + -- Returns the registry key's value associated with Sub_Key in From_Key + -- registry key. If Expand is set to True and the Sub_Key is a + -- REG_EXPAND_SZ the returned value will have the %name% variables + -- replaced by the corresponding environment variable value. + + procedure Set_Value + (From_Key : HKEY; + Sub_Key : String; + Value : String; + Expand : Boolean := False); + -- Add the pair (Sub_Key, Value) into From_Key registry key. + -- By default the value created is of type REG_SZ, unless + -- Expand is True in which case it is of type REG_EXPAND_SZ + + procedure Delete_Key (From_Key : HKEY; Sub_Key : String); + -- Remove Sub_Key from the registry key From_Key + + procedure Delete_Value (From_Key : HKEY; Sub_Key : String); + -- Remove the named value Sub_Key from the registry key From_Key + + generic + with procedure Action + (Index : Positive; + Key : HKEY; + Key_Name : String; + Quit : in out Boolean); + procedure For_Every_Key (From_Key : HKEY; Recursive : Boolean := False); + -- Iterates over all the keys registered under From_Key, recursively if + -- Recursive is set to True. Index will be set to 1 for the first key and + -- will be incremented by one in each iteration. The current key of an + -- iteration is set in Key, and its name - in Key_Name. Quit can be set + -- to True to stop iteration; its initial value is False. + + generic + with procedure Action + (Index : Positive; + Sub_Key : String; + Value : String; + Quit : in out Boolean); + procedure For_Every_Key_Value (From_Key : HKEY; Expand : Boolean := False); + -- Iterates over all the pairs (Sub_Key, Value) registered under + -- From_Key. Index will be set to 1 for the first key and will be + -- incremented by one in each iteration. Quit can be set to True to + -- stop iteration; its initial value is False. + -- + -- Key value that are not of type string (i.e. not REG_SZ / REG_EXPAND_SZ) + -- are skipped. In this case, the iterator behaves exactly as if the key + -- were not present. Note that you must use the Win32.Winreg API to deal + -- with this case. Furthermore, if Expand is set to True and the Sub_Key + -- is a REG_EXPAND_SZ the returned value will have the %name% variables + -- replaced by the corresponding environment variable value. + -- + -- This iterator can be used in conjunction with For_Every_Key in + -- order to analyze all subkeys and values of a given registry key. + +private + + type HKEY is mod 2 ** Standard'Address_Size; + + HKEY_CLASSES_ROOT : constant HKEY := 16#80000000#; + HKEY_CURRENT_USER : constant HKEY := 16#80000001#; + HKEY_LOCAL_MACHINE : constant HKEY := 16#80000002#; + HKEY_USERS : constant HKEY := 16#80000003#; + HKEY_PERFORMANCE_DATA : constant HKEY := 16#80000004#; + HKEY_CURRENT_CONFIG : constant HKEY := 16#80000005#; + +end GNAT.Registry; diff --git a/gcc/ada/libgnat/g-regpat.adb b/gcc/ada/libgnat/g-regpat.adb new file mode 100644 index 0000000..55f2710 --- /dev/null +++ b/gcc/ada/libgnat/g-regpat.adb @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . R E G P A T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1986 by University of Toronto. -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-regpat.ads b/gcc/ada/libgnat/g-regpat.ads new file mode 100644 index 0000000..c12096e --- /dev/null +++ b/gcc/ada/libgnat/g-regpat.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . R E G P A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1986 by University of Toronto. -- +-- Copyright (C) 1996-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements roughly the same set of regular expressions as +-- are available in the Perl or Python programming languages. + +-- This is an extension of the original V7 style regular expression library +-- written in C by Henry Spencer. Apart from the translation to Ada, the +-- interface has been considerably changed to use the Ada String type +-- instead of C-style nul-terminated strings. + +-- See file s-regpat.ads for full documentation of the interface + +------------------------------------------------------------ +-- Summary of Pattern Matching Packages in GNAT Hierarchy -- +------------------------------------------------------------ + +-- There are three related packages that perform pattern matching functions. +-- the following is an outline of these packages, to help you determine +-- which is best for your needs. + +-- GNAT.Regexp (files g-regexp.ads/s-regexp.ads/s-regexp.adb) +-- This is a simple package providing Unix-style regular expression +-- matching with the restriction that it matches entire strings. It +-- is particularly useful for file name matching, and in particular +-- it provides "globbing patterns" that are useful in implementing +-- unix or DOS style wild card matching for file names. + +-- GNAT.Regpat (files g-regpat.ads/s-regpat.ads/s-regpat.adb) +-- This is a more complete implementation of Unix-style regular +-- expressions, copied from the Perl regular expression engine, +-- written originally in C by Henry Spencer. It is functionally the +-- same as that library. + +-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) +-- This is a completely general pattern matching package based on the +-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern +-- language is modeled on context free grammars, with context sensitive +-- extensions that provide full (type 0) computational capabilities. + +with System.Regpat; + +package GNAT.Regpat renames System.Regpat; diff --git a/gcc/ada/libgnat/g-rewdat.adb b/gcc/ada/libgnat/g-rewdat.adb new file mode 100644 index 0000000..5f523c1 --- /dev/null +++ b/gcc/ada/libgnat/g-rewdat.adb @@ -0,0 +1,253 @@ +----------------------------------------------------------------------------- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E W R I T E _ D A T A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body GNAT.Rewrite_Data is + + use Ada; + + subtype SEO is Stream_Element_Offset; + + procedure Do_Output + (B : in out Buffer; + Data : Stream_Element_Array; + Output : not null access procedure (Data : Stream_Element_Array)); + -- Do the actual output. This ensures that we properly send the data + -- through linked rewrite buffers if any. + + ------------ + -- Create -- + ------------ + + function Create + (Pattern, Value : String; + Size : Stream_Element_Offset := 1_024) return Buffer + is + + subtype SP is String (1 .. Pattern'Length); + subtype SEAP is Stream_Element_Array (1 .. Pattern'Length); + + subtype SV is String (1 .. Value'Length); + subtype SEAV is Stream_Element_Array (1 .. Value'Length); + + function To_SEAP is new Unchecked_Conversion (SP, SEAP); + function To_SEAV is new Unchecked_Conversion (SV, SEAV); + + begin + -- Return result (can't be smaller than pattern) + + return B : Buffer + (SEO'Max (Size, SEO (Pattern'Length)), + SEO (Pattern'Length), + SEO (Value'Length)) + do + B.Pattern := To_SEAP (Pattern); + B.Value := To_SEAV (Value); + B.Pos_C := 0; + B.Pos_B := 0; + end return; + end Create; + + --------------- + -- Do_Output -- + --------------- + + procedure Do_Output + (B : in out Buffer; + Data : Stream_Element_Array; + Output : not null access procedure (Data : Stream_Element_Array)) + is + begin + if B.Next = null then + Output (Data); + else + Write (B.Next.all, Data, Output); + end if; + end Do_Output; + + ----------- + -- Flush -- + ----------- + + procedure Flush + (B : in out Buffer; + Output : not null access procedure (Data : Stream_Element_Array)) + is + begin + -- Flush output buffer + + if B.Pos_B > 0 then + Do_Output (B, B.Buffer (1 .. B.Pos_B), Output); + end if; + + -- Flush current buffer + + if B.Pos_C > 0 then + Do_Output (B, B.Current (1 .. B.Pos_C), Output); + end if; + + -- Flush linked buffer if any + + if B.Next /= null then + Flush (B.Next.all, Output); + end if; + + Reset (B); + end Flush; + + ---------- + -- Link -- + ---------- + + procedure Link (From : in out Buffer; To : Buffer_Ref) is + begin + From.Next := To; + end Link; + + ----------- + -- Reset -- + ----------- + + procedure Reset (B : in out Buffer) is + begin + B.Pos_B := 0; + B.Pos_C := 0; + + if B.Next /= null then + Reset (B.Next.all); + end if; + end Reset; + + ------------- + -- Rewrite -- + ------------- + + procedure Rewrite + (B : in out Buffer; + Input : not null access procedure + (Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset); + Output : not null access procedure (Data : Stream_Element_Array)) + is + Buffer : Stream_Element_Array (1 .. B.Size); + Last : Stream_Element_Offset; + + begin + Rewrite_All : loop + Input (Buffer, Last); + exit Rewrite_All when Last = 0; + Write (B, Buffer (1 .. Last), Output); + end loop Rewrite_All; + + Flush (B, Output); + end Rewrite; + + ---------- + -- Size -- + ---------- + + function Size (B : Buffer) return Natural is + begin + return Natural (B.Pos_B + B.Pos_C); + end Size; + + ----------- + -- Write -- + ----------- + + procedure Write + (B : in out Buffer; + Data : Stream_Element_Array; + Output : not null access procedure (Data : Stream_Element_Array)) + is + procedure Need_Space (Size : Stream_Element_Offset); + pragma Inline (Need_Space); + + ---------------- + -- Need_Space -- + ---------------- + + procedure Need_Space (Size : Stream_Element_Offset) is + begin + if B.Pos_B + Size > B.Size then + Do_Output (B, B.Buffer (1 .. B.Pos_B), Output); + B.Pos_B := 0; + end if; + end Need_Space; + + -- Start of processing for Write + + begin + if B.Size_Pattern = 0 then + Do_Output (B, Data, Output); + + else + for K in Data'Range loop + if Data (K) = B.Pattern (B.Pos_C + 1) then + + -- Store possible start of a match + + B.Pos_C := B.Pos_C + 1; + B.Current (B.Pos_C) := Data (K); + + else + -- Not part of pattern, if a start of a match was found, + -- remove it. + + if B.Pos_C /= 0 then + Need_Space (B.Pos_C); + + B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Pos_C) := + B.Current (1 .. B.Pos_C); + B.Pos_B := B.Pos_B + B.Pos_C; + B.Pos_C := 0; + end if; + + Need_Space (1); + B.Pos_B := B.Pos_B + 1; + B.Buffer (B.Pos_B) := Data (K); + end if; + + if B.Pos_C = B.Size_Pattern then + + -- The pattern is found + + Need_Space (B.Size_Value); + + B.Buffer (B.Pos_B + 1 .. B.Pos_B + B.Size_Value) := B.Value; + B.Pos_C := 0; + B.Pos_B := B.Pos_B + B.Size_Value; + end if; + end loop; + end if; + end Write; + +end GNAT.Rewrite_Data; diff --git a/gcc/ada/libgnat/g-rewdat.ads b/gcc/ada/libgnat/g-rewdat.ads new file mode 100644 index 0000000..994b3ee --- /dev/null +++ b/gcc/ada/libgnat/g-rewdat.ads @@ -0,0 +1,152 @@ +------------------------------------------------------------------------------ +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . R E W R I T E _ D A T A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package can be used to rewrite data on the fly. All occurrences of a +-- string (named pattern) will be replaced by another string. + +-- It is not necessary to load all data in memory and so this package can be +-- used for large data chunks like disk files for example. The pattern is +-- a standard string and not a regular expression. + +-- There is no dynamic allocation in the implementation. + +-- For example, to replace all occurrences of "Gnat" with "GNAT": + +-- Rewriter : Buffer := Create (Pattern => "Gnat", Value => "GNAT"); + +-- The output procedure that will receive the rewritten data: + +-- procedure Do (Data : Stream_Element_Array) is +-- begin +-- +-- end Do; + +-- Then: + +-- Write (Rewriter, "Let's talk about Gnat compiler", Do'Access); +-- Write (Rewriter, "Gnat is an Ada compiler", Do'Access); +-- Flush (Rewriter, Do'Access); + +-- Another possible usage is to specify a method to get the input data: + +-- procedure Get +-- (Buffer : out Stream_Element_Array; +-- Last : out Stream_Element_Offset) +-- is +-- begin +-- +-- Last := ... +-- Buffer := ... +-- end Get; + +-- Then we can rewrite the whole file with: + +-- Rewrite (Rewriter, Input => Get'Access, Output => Do'Access); + +with Ada.Streams; use Ada.Streams; + +package GNAT.Rewrite_Data is + + type Buffer (<>) is limited private; + type Buffer_Ref is access all Buffer; + + function Create + (Pattern, Value : String; + Size : Stream_Element_Offset := 1_024) return Buffer; + -- Create a rewrite buffer. Pattern is the string to be rewritten as Value. + -- Size represents the size of the internal buffer used to store the data + -- ready to be output. A larger buffer may improve the performance, as the + -- Output routine (see Write, Rewrite below) will be called only when this + -- buffer is full. Note that Size cannot be lower than Pattern'Length, and + -- if this is the case, then Size value is set to Pattern'Length. + + function Size (B : Buffer) return Natural; + -- Returns the current size of the buffer (count of Stream_Array_Element) + + procedure Flush + (B : in out Buffer; + Output : not null access procedure (Data : Stream_Element_Array)); + -- Call Output for all remaining data in the buffer. The buffer is + -- reset and ready for another use after this call. + + procedure Reset (B : in out Buffer); + pragma Inline (Reset); + -- Clear all data in buffer, B is ready for another use. Note that this is + -- not needed after a Flush. Note: all data remaining in Buffer is lost. + + procedure Write + (B : in out Buffer; + Data : Stream_Element_Array; + Output : not null access procedure (Data : Stream_Element_Array)); + -- Write Data into the buffer, call Output for any prepared data. Flush + -- must be called when the last piece of Data as been sent in the Buffer. + + procedure Rewrite + (B : in out Buffer; + Input : not null access procedure + (Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset); + Output : not null access procedure (Data : Stream_Element_Array)); + -- Read data from Input, rewrite it, and then call Output. When there is + -- no more data to be read from Input, Last must be set to 0. Before + -- leaving this routine, call Flush above to send all remaining data to + -- Output. + + procedure Link (From : in out Buffer; To : Buffer_Ref); + -- Link two rewrite buffers. That is, all data sent to From buffer will be + -- rewritten and then passed to the To rewrite buffer. + +private + + type Buffer + (Size, Size_Pattern, Size_Value : Stream_Element_Offset) is + limited record + Pos_C : Stream_Element_Offset; -- last valid element in Current + Pos_B : Stream_Element_Offset; -- last valid element in Buffer + + Next : Buffer_Ref; + -- A link to another rewriter if any + + Buffer : Stream_Element_Array (1 .. Size); + -- Fully prepared/rewritten data waiting to be output + + Current : Stream_Element_Array (1 .. Size_Pattern); + -- Current data checked, this buffer contains every piece of data + -- starting with the pattern. It means that at any point: + -- Current (1 .. Pos_C) = Pattern (1 .. Pos_C). + + Pattern : Stream_Element_Array (1 .. Size_Pattern); + -- The pattern to look for + + Value : Stream_Element_Array (1 .. Size_Value); + -- The value the pattern is replaced by + end record; + +end GNAT.Rewrite_Data; diff --git a/gcc/ada/libgnat/g-sechas.adb b/gcc/ada/libgnat/g-sechas.adb new file mode 100644 index 0000000..39c3162 --- /dev/null +++ b/gcc/ada/libgnat/g-sechas.adb @@ -0,0 +1,486 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with Interfaces; use Interfaces; + +package body GNAT.Secure_Hashes is + + Hex_Digit : constant array (Stream_Element range 0 .. 15) of Character := + "0123456789abcdef"; + + type Fill_Buffer_Access is + access procedure + (M : in out Message_State; + S : String; + First : Natural; + Last : out Natural); + -- A procedure to transfer data from S, starting at First, into M's block + -- buffer until either the block buffer is full or all data from S has been + -- consumed. + + procedure Fill_Buffer_Copy + (M : in out Message_State; + S : String; + First : Natural; + Last : out Natural); + -- Transfer procedure which just copies data from S to M + + procedure Fill_Buffer_Swap + (M : in out Message_State; + S : String; + First : Natural; + Last : out Natural); + -- Transfer procedure which swaps bytes from S when copying into M. S must + -- have even length. Note that the swapping is performed considering pairs + -- starting at S'First, even if S'First /= First (that is, if + -- First = S'First then the first copied byte is always S (S'First + 1), + -- and if First = S'First + 1 then the first copied byte is always + -- S (S'First). + + procedure To_String (SEA : Stream_Element_Array; S : out String); + -- Return the hexadecimal representation of SEA + + ---------------------- + -- Fill_Buffer_Copy -- + ---------------------- + + procedure Fill_Buffer_Copy + (M : in out Message_State; + S : String; + First : Natural; + Last : out Natural) + is + Buf_String : String (M.Buffer'Range); + for Buf_String'Address use M.Buffer'Address; + pragma Import (Ada, Buf_String); + + Length : constant Natural := + Natural'Min (M.Block_Length - M.Last, S'Last - First + 1); + + begin + pragma Assert (Length > 0); + + Buf_String (M.Last + 1 .. M.Last + Length) := + S (First .. First + Length - 1); + M.Last := M.Last + Length; + Last := First + Length - 1; + end Fill_Buffer_Copy; + + ---------------------- + -- Fill_Buffer_Swap -- + ---------------------- + + procedure Fill_Buffer_Swap + (M : in out Message_State; + S : String; + First : Natural; + Last : out Natural) + is + pragma Assert (S'Length mod 2 = 0); + Length : constant Natural := + Natural'Min (M.Block_Length - M.Last, S'Last - First + 1); + begin + Last := First; + while Last - First < Length loop + M.Buffer (M.Last + 1 + Last - First) := + (if (Last - S'First) mod 2 = 0 + then S (Last + 1) + else S (Last - 1)); + Last := Last + 1; + end loop; + M.Last := M.Last + Length; + Last := First + Length - 1; + end Fill_Buffer_Swap; + + --------------- + -- To_String -- + --------------- + + procedure To_String (SEA : Stream_Element_Array; S : out String) is + pragma Assert (S'Length = 2 * SEA'Length); + begin + for J in SEA'Range loop + declare + S_J : constant Natural := 1 + Natural (J - SEA'First) * 2; + begin + S (S_J) := Hex_Digit (SEA (J) / 16); + S (S_J + 1) := Hex_Digit (SEA (J) mod 16); + end; + end loop; + end To_String; + + ------- + -- H -- + ------- + + package body H is + + procedure Update + (C : in out Context; + S : String; + Fill_Buffer : Fill_Buffer_Access); + -- Internal common routine for all Update procedures + + procedure Final + (C : Context; + Hash_Bits : out Ada.Streams.Stream_Element_Array); + -- Perform final hashing operations (data padding) and extract the + -- (possibly truncated) state of C into Hash_Bits. + + ------------ + -- Digest -- + ------------ + + function Digest (C : Context) return Message_Digest is + Hash_Bits : Stream_Element_Array + (1 .. Stream_Element_Offset (Hash_Length)); + begin + Final (C, Hash_Bits); + return MD : Message_Digest do + To_String (Hash_Bits, MD); + end return; + end Digest; + + function Digest (S : String) return Message_Digest is + C : Context; + begin + Update (C, S); + return Digest (C); + end Digest; + + function Digest (A : Stream_Element_Array) return Message_Digest is + C : Context; + begin + Update (C, A); + return Digest (C); + end Digest; + + function Digest (C : Context) return Binary_Message_Digest is + Hash_Bits : Stream_Element_Array + (1 .. Stream_Element_Offset (Hash_Length)); + begin + Final (C, Hash_Bits); + return Hash_Bits; + end Digest; + + function Digest (S : String) return Binary_Message_Digest is + C : Context; + begin + Update (C, S); + return Digest (C); + end Digest; + + function Digest + (A : Stream_Element_Array) return Binary_Message_Digest + is + C : Context; + begin + Update (C, A); + return Digest (C); + end Digest; + + ----------- + -- Final -- + ----------- + + -- Once a complete message has been processed, it is padded with one 1 + -- bit followed by enough 0 bits so that the last block is 2 * Word'Size + -- bits short of being completed. The last 2 * Word'Size bits are set to + -- the message size in bits (excluding padding). + + procedure Final + (C : Context; + Hash_Bits : out Stream_Element_Array) + is + FC : Context := C; + + Zeroes : Natural; + -- Number of 0 bytes in padding + + Message_Length : Unsigned_64 := FC.M_State.Length; + -- Message length in bytes + + Size_Length : constant Natural := + 2 * Hash_State.Word'Size / 8; + -- Length in bytes of the size representation + + begin + Zeroes := (Block_Length - 1 - Size_Length - FC.M_State.Last) + mod FC.M_State.Block_Length; + declare + Pad : String (1 .. 1 + Zeroes + Size_Length) := + (1 => Character'Val (128), others => ASCII.NUL); + + Index : Natural; + First_Index : Natural; + + begin + First_Index := (if Hash_Bit_Order = Low_Order_First + then Pad'Last - Size_Length + 1 + else Pad'Last); + + Index := First_Index; + while Message_Length > 0 loop + if Index = First_Index then + + -- Message_Length is in bytes, but we need to store it as + -- a bit count. + + Pad (Index) := Character'Val + (Shift_Left (Message_Length and 16#1f#, 3)); + Message_Length := Shift_Right (Message_Length, 5); + + else + Pad (Index) := Character'Val (Message_Length and 16#ff#); + Message_Length := Shift_Right (Message_Length, 8); + end if; + + Index := Index + + (if Hash_Bit_Order = Low_Order_First then 1 else -1); + end loop; + + Update (FC, Pad); + end; + + pragma Assert (FC.M_State.Last = 0); + + Hash_State.To_Hash (FC.H_State, Hash_Bits); + + -- HMAC case: hash outer pad + + if C.KL /= 0 then + declare + Outer_C : Context; + Opad : Stream_Element_Array := + (1 .. Stream_Element_Offset (Block_Length) => 16#5c#); + + begin + for J in C.Key'Range loop + Opad (J) := Opad (J) xor C.Key (J); + end loop; + + Update (Outer_C, Opad); + Update (Outer_C, Hash_Bits); + + Final (Outer_C, Hash_Bits); + end; + end if; + end Final; + + -------------------------- + -- HMAC_Initial_Context -- + -------------------------- + + function HMAC_Initial_Context (Key : String) return Context is + begin + if Key'Length = 0 then + raise Constraint_Error with "null key"; + end if; + + return C : Context (KL => (if Key'Length <= Key_Length'Last + then Key'Length + else Stream_Element_Offset (Hash_Length))) + do + -- Set Key (if longer than block length, first hash it) + + if C.KL = Key'Length then + declare + SK : String (1 .. Key'Length); + for SK'Address use C.Key'Address; + pragma Import (Ada, SK); + begin + SK := Key; + end; + + else + C.Key := Digest (Key); + end if; + + -- Hash inner pad + + declare + Ipad : Stream_Element_Array := + (1 .. Stream_Element_Offset (Block_Length) => 16#36#); + + begin + for J in C.Key'Range loop + Ipad (J) := Ipad (J) xor C.Key (J); + end loop; + + Update (C, Ipad); + end; + end return; + end HMAC_Initial_Context; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Hash_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + pragma Unreferenced (Stream, Item, Last); + begin + raise Program_Error with "Hash_Stream is write-only"; + end Read; + + ------------ + -- Update -- + ------------ + + procedure Update + (C : in out Context; + S : String; + Fill_Buffer : Fill_Buffer_Access) + is + Last : Natural; + + begin + C.M_State.Length := C.M_State.Length + S'Length; + + Last := S'First - 1; + while Last < S'Last loop + Fill_Buffer (C.M_State, S, Last + 1, Last); + + if C.M_State.Last = Block_Length then + Transform (C.H_State, C.M_State); + C.M_State.Last := 0; + end if; + end loop; + end Update; + + ------------ + -- Update -- + ------------ + + procedure Update (C : in out Context; Input : String) is + begin + Update (C, Input, Fill_Buffer_Copy'Access); + end Update; + + ------------ + -- Update -- + ------------ + + procedure Update (C : in out Context; Input : Stream_Element_Array) is + S : String (1 .. Input'Length); + for S'Address use Input'Address; + pragma Import (Ada, S); + begin + Update (C, S, Fill_Buffer_Copy'Access); + end Update; + + ----------------- + -- Wide_Update -- + ----------------- + + procedure Wide_Update (C : in out Context; Input : Wide_String) is + S : String (1 .. 2 * Input'Length); + for S'Address use Input'Address; + pragma Import (Ada, S); + begin + Update + (C, S, + (if System.Default_Bit_Order /= Low_Order_First + then Fill_Buffer_Swap'Access + else Fill_Buffer_Copy'Access)); + end Wide_Update; + + ----------------- + -- Wide_Digest -- + ----------------- + + function Wide_Digest (W : Wide_String) return Message_Digest is + C : Context; + begin + Wide_Update (C, W); + return Digest (C); + end Wide_Digest; + + function Wide_Digest (W : Wide_String) return Binary_Message_Digest is + C : Context; + begin + Wide_Update (C, W); + return Digest (C); + end Wide_Digest; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Hash_Stream; + Item : Stream_Element_Array) + is + begin + Update (Stream.C.all, Item); + end Write; + + end H; + + ------------------------- + -- Hash_Function_State -- + ------------------------- + + package body Hash_Function_State is + + ------------- + -- To_Hash -- + ------------- + + procedure To_Hash (H : State; H_Bits : out Stream_Element_Array) is + Hash_Words : constant Natural := H'Size / Word'Size; + Result : State (1 .. Hash_Words) := + H (H'Last - Hash_Words + 1 .. H'Last); + + R_SEA : Stream_Element_Array (1 .. Result'Size / 8); + for R_SEA'Address use Result'Address; + pragma Import (Ada, R_SEA); + + begin + if System.Default_Bit_Order /= Hash_Bit_Order then + for J in Result'Range loop + Swap (Result (J)'Address); + end loop; + end if; + + -- Return truncated hash + + pragma Assert (H_Bits'Length <= R_SEA'Length); + H_Bits := R_SEA (R_SEA'First .. R_SEA'First + H_Bits'Length - 1); + end To_Hash; + + end Hash_Function_State; + +end GNAT.Secure_Hashes; diff --git a/gcc/ada/libgnat/g-sechas.ads b/gcc/ada/libgnat/g-sechas.ads new file mode 100644 index 0000000..99e48e6 --- /dev/null +++ b/gcc/ada/libgnat/g-sechas.ads @@ -0,0 +1,240 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides common supporting code for a family of secure +-- hash functions (including MD5 and the FIPS PUB 180-3 functions SHA-1, +-- SHA-224, SHA-256, SHA-384 and SHA-512). + +-- This is an internal unit and should be not used directly in applications. +-- Use GNAT.MD5 and GNAT.SHA* instead. + +with Ada.Streams; use Ada.Streams; + +with Interfaces; + +with System; + +package GNAT.Secure_Hashes is + + type Buffer_Type is new String; + for Buffer_Type'Alignment use 8; + -- Secure hash functions use a string buffer that is also accessed as an + -- array of words, which may require up to 64 bit alignment. + + -- The function-independent part of processing state: A buffer of data + -- being accumulated until a complete block is ready for hashing. + + type Message_State (Block_Length : Natural) is record + Last : Natural := 0; + -- Index of last used element in Buffer + + Length : Interfaces.Unsigned_64 := 0; + -- Total length of processed data + + Buffer : Buffer_Type (1 .. Block_Length); + -- Data buffer + end record; + + -- The function-specific part of processing state: + + -- Each hash function maintains an internal state as an array of words, + -- which is ultimately converted to a stream representation with the + -- appropriate bit order. + + generic + type Word is mod <>; + -- Either 32 or 64 bits + + with procedure Swap (X : System.Address); + -- Byte swapping function for a Word at X + + Hash_Bit_Order : System.Bit_Order; + -- Bit order of the produced hash + + package Hash_Function_State is + + type State is array (Natural range <>) of Word; + -- Used to store a hash function's internal state + + procedure To_Hash + (H : State; + H_Bits : out Stream_Element_Array); + -- Convert H to stream representation with the given bit order. If + -- H_Bits is smaller than the internal hash state, then the state + -- is truncated. + + end Hash_Function_State; + + -- Generic hashing framework: The user interface for each implemented + -- secure hash function is an instance of this generic package. + + generic + Block_Words : Natural; + -- Number of words in each block + + State_Words : Natural; + -- Number of words in internal state + + Hash_Words : Natural; + -- Number of words in the final hash (must be no greater than + -- State_Words). + + Hash_Bit_Order : System.Bit_Order; + -- Bit order used for conversion between bit representation and word + -- representation. + + with package Hash_State is new Hash_Function_State (<>); + -- Hash function state package + + Initial_State : Hash_State.State; + -- Initial value of the hash function state + + with procedure Transform + (H : in out Hash_State.State; + M : in out Message_State); + -- Transformation function updating H by processing a complete data + -- block from M. + + package H is + + -- The visible part of H is the interface to secure hashing functions + -- that is exposed to user applications, and is intended to remain + -- a stable interface. + + pragma Assert (Hash_Words <= State_Words); + + type Context is private; + -- The internal processing state of the hashing function + + function "=" (L, R : Context) return Boolean is abstract; + -- Context is the internal, implementation defined intermediate state + -- in a hash computation, and no specific semantics can be expected on + -- equality of context values. Only equality of final hash values (as + -- returned by the [Wide_]Digest functions below) is meaningful. + + Initial_Context : constant Context; + -- Initial value of a Context object. May be used to reinitialize + -- a Context value by simple assignment of this value to the object. + + function HMAC_Initial_Context (Key : String) return Context; + -- Initial Context for HMAC computation with the given Key + + procedure Update (C : in out Context; Input : String); + procedure Wide_Update (C : in out Context; Input : Wide_String); + procedure Update + (C : in out Context; + Input : Stream_Element_Array); + -- Update C to process the given input. Successive calls to Update are + -- equivalent to a single call with the concatenation of the inputs. For + -- the Wide_String version, each Wide_Character is processed low order + -- byte first. + + Word_Length : constant Natural := Hash_State.Word'Size / 8; + Hash_Length : constant Natural := Hash_Words * Word_Length; + + subtype Binary_Message_Digest is + Stream_Element_Array (1 .. Stream_Element_Offset (Hash_Length)); + -- The fixed-length byte array returned by Digest, providing + -- the hash in binary representation. + + function Digest (C : Context) return Binary_Message_Digest; + -- Return hash or HMAC for the data accumulated with C + + function Digest (S : String) return Binary_Message_Digest; + function Wide_Digest (W : Wide_String) return Binary_Message_Digest; + function Digest + (A : Stream_Element_Array) return Binary_Message_Digest; + -- These functions are equivalent to the corresponding Update (or + -- Wide_Update) on a default initialized Context, followed by Digest + -- on the resulting Context. + + subtype Message_Digest is String (1 .. 2 * Hash_Length); + -- The fixed-length string returned by Digest, providing the hash in + -- hexadecimal representation. + + function Digest (C : Context) return Message_Digest; + -- Return hash or HMAC for the data accumulated with C in hexadecimal + -- representation. + + function Digest (S : String) return Message_Digest; + function Wide_Digest (W : Wide_String) return Message_Digest; + function Digest (A : Stream_Element_Array) return Message_Digest; + -- These functions are equivalent to the corresponding Update (or + -- Wide_Update) on a default initialized Context, followed by Digest + -- on the resulting Context. + + type Hash_Stream (C : access Context) is + new Root_Stream_Type with private; + -- Stream wrapper converting Write calls to Update calls on C. + -- Arbitrary data structures can thus be conveniently hashed using + -- their stream attributes. + + private + + Block_Length : constant Natural := Block_Words * Word_Length; + -- Length in bytes of a data block + + subtype Key_Length is + Stream_Element_Offset range 0 .. Stream_Element_Offset (Block_Length); + + -- KL is 0 for a normal hash context, > 0 for HMAC + + type Context (KL : Key_Length := 0) is record + H_State : Hash_State.State (0 .. State_Words - 1) := Initial_State; + -- Function-specific state + + M_State : Message_State (Block_Length); + -- Function-independent state (block buffer) + + Key : Stream_Element_Array (1 .. KL); + -- HMAC key + end record; + + Initial_Context : constant Context (KL => 0) := (others => <>); + -- Initial values are provided by default initialization of Context + + type Hash_Stream (C : access Context) is + new Root_Stream_Type with null record; + + procedure Read + (Stream : in out Hash_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + -- Raise Program_Error: hash streams are write-only + + procedure Write + (Stream : in out Hash_Stream; + Item : Stream_Element_Array); + -- Call Update + + end H; + +end GNAT.Secure_Hashes; diff --git a/gcc/ada/libgnat/g-sehamd.adb b/gcc/ada/libgnat/g-sehamd.adb new file mode 100644 index 0000000..616f15e --- /dev/null +++ b/gcc/ada/libgnat/g-sehamd.adb @@ -0,0 +1,342 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . M D 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Byte_Swapping; use GNAT.Byte_Swapping; + +package body GNAT.Secure_Hashes.MD5 is + + use Interfaces; + + -- The sixteen values used to rotate the context words. Four for each + -- rounds. Used in procedure Transform. + + -- Round 1 + + S11 : constant := 7; + S12 : constant := 12; + S13 : constant := 17; + S14 : constant := 22; + + -- Round 2 + + S21 : constant := 5; + S22 : constant := 9; + S23 : constant := 14; + S24 : constant := 20; + + -- Round 3 + + S31 : constant := 4; + S32 : constant := 11; + S33 : constant := 16; + S34 : constant := 23; + + -- Round 4 + + S41 : constant := 6; + S42 : constant := 10; + S43 : constant := 15; + S44 : constant := 21; + + -- The following functions (F, FF, G, GG, H, HH, I and II) are the + -- equivalent of the macros of the same name in the example C + -- implementation in the annex of RFC 1321. + + function F (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (F); + + procedure FF + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (FF); + + function G (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (G); + + procedure GG + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (GG); + + function H (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (H); + + procedure HH + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (HH); + + function I (X, Y, Z : Unsigned_32) return Unsigned_32; + pragma Inline (I); + + procedure II + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive); + pragma Inline (II); + + ------- + -- F -- + ------- + + function F (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return (X and Y) or ((not X) and Z); + end F; + + -------- + -- FF -- + -------- + + procedure FF + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + F (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end FF; + + ------- + -- G -- + ------- + + function G (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return (X and Z) or (Y and (not Z)); + end G; + + -------- + -- GG -- + -------- + + procedure GG + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + G (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end GG; + + ------- + -- H -- + ------- + + function H (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return X xor Y xor Z; + end H; + + -------- + -- HH -- + -------- + + procedure HH + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + H (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end HH; + + ------- + -- I -- + ------- + + function I (X, Y, Z : Unsigned_32) return Unsigned_32 is + begin + return Y xor (X or (not Z)); + end I; + + -------- + -- II -- + -------- + + procedure II + (A : in out Unsigned_32; + B, C, D : Unsigned_32; + X : Unsigned_32; + AC : Unsigned_32; + S : Positive) + is + begin + A := A + I (B, C, D) + X + AC; + A := Rotate_Left (A, S); + A := A + B; + end II; + + --------------- + -- Transform -- + --------------- + + procedure Transform + (H : in out Hash_State.State; + M : in out Message_State) + is + use System; + + X : array (0 .. 15) of Interfaces.Unsigned_32; + for X'Address use M.Buffer'Address; + pragma Import (Ada, X); + + AA : Unsigned_32 := H (0); + BB : Unsigned_32 := H (1); + CC : Unsigned_32 := H (2); + DD : Unsigned_32 := H (3); + + begin + if Default_Bit_Order /= Low_Order_First then + for J in X'Range loop + Swap4 (X (J)'Address); + end loop; + end if; + + -- Round 1 + + FF (AA, BB, CC, DD, X (00), 16#D76aa478#, S11); -- 1 + FF (DD, AA, BB, CC, X (01), 16#E8c7b756#, S12); -- 2 + FF (CC, DD, AA, BB, X (02), 16#242070db#, S13); -- 3 + FF (BB, CC, DD, AA, X (03), 16#C1bdceee#, S14); -- 4 + + FF (AA, BB, CC, DD, X (04), 16#f57c0faf#, S11); -- 5 + FF (DD, AA, BB, CC, X (05), 16#4787c62a#, S12); -- 6 + FF (CC, DD, AA, BB, X (06), 16#a8304613#, S13); -- 7 + FF (BB, CC, DD, AA, X (07), 16#fd469501#, S14); -- 8 + + FF (AA, BB, CC, DD, X (08), 16#698098d8#, S11); -- 9 + FF (DD, AA, BB, CC, X (09), 16#8b44f7af#, S12); -- 10 + FF (CC, DD, AA, BB, X (10), 16#ffff5bb1#, S13); -- 11 + FF (BB, CC, DD, AA, X (11), 16#895cd7be#, S14); -- 12 + + FF (AA, BB, CC, DD, X (12), 16#6b901122#, S11); -- 13 + FF (DD, AA, BB, CC, X (13), 16#fd987193#, S12); -- 14 + FF (CC, DD, AA, BB, X (14), 16#a679438e#, S13); -- 15 + FF (BB, CC, DD, AA, X (15), 16#49b40821#, S14); -- 16 + + -- Round 2 + + GG (AA, BB, CC, DD, X (01), 16#f61e2562#, S21); -- 17 + GG (DD, AA, BB, CC, X (06), 16#c040b340#, S22); -- 18 + GG (CC, DD, AA, BB, X (11), 16#265e5a51#, S23); -- 19 + GG (BB, CC, DD, AA, X (00), 16#e9b6c7aa#, S24); -- 20 + + GG (AA, BB, CC, DD, X (05), 16#d62f105d#, S21); -- 21 + GG (DD, AA, BB, CC, X (10), 16#02441453#, S22); -- 22 + GG (CC, DD, AA, BB, X (15), 16#d8a1e681#, S23); -- 23 + GG (BB, CC, DD, AA, X (04), 16#e7d3fbc8#, S24); -- 24 + + GG (AA, BB, CC, DD, X (09), 16#21e1cde6#, S21); -- 25 + GG (DD, AA, BB, CC, X (14), 16#c33707d6#, S22); -- 26 + GG (CC, DD, AA, BB, X (03), 16#f4d50d87#, S23); -- 27 + GG (BB, CC, DD, AA, X (08), 16#455a14ed#, S24); -- 28 + + GG (AA, BB, CC, DD, X (13), 16#a9e3e905#, S21); -- 29 + GG (DD, AA, BB, CC, X (02), 16#fcefa3f8#, S22); -- 30 + GG (CC, DD, AA, BB, X (07), 16#676f02d9#, S23); -- 31 + GG (BB, CC, DD, AA, X (12), 16#8d2a4c8a#, S24); -- 32 + + -- Round 3 + + HH (AA, BB, CC, DD, X (05), 16#fffa3942#, S31); -- 33 + HH (DD, AA, BB, CC, X (08), 16#8771f681#, S32); -- 34 + HH (CC, DD, AA, BB, X (11), 16#6d9d6122#, S33); -- 35 + HH (BB, CC, DD, AA, X (14), 16#fde5380c#, S34); -- 36 + + HH (AA, BB, CC, DD, X (01), 16#a4beea44#, S31); -- 37 + HH (DD, AA, BB, CC, X (04), 16#4bdecfa9#, S32); -- 38 + HH (CC, DD, AA, BB, X (07), 16#f6bb4b60#, S33); -- 39 + HH (BB, CC, DD, AA, X (10), 16#bebfbc70#, S34); -- 40 + + HH (AA, BB, CC, DD, X (13), 16#289b7ec6#, S31); -- 41 + HH (DD, AA, BB, CC, X (00), 16#eaa127fa#, S32); -- 42 + HH (CC, DD, AA, BB, X (03), 16#d4ef3085#, S33); -- 43 + HH (BB, CC, DD, AA, X (06), 16#04881d05#, S34); -- 44 + + HH (AA, BB, CC, DD, X (09), 16#d9d4d039#, S31); -- 45 + HH (DD, AA, BB, CC, X (12), 16#e6db99e5#, S32); -- 46 + HH (CC, DD, AA, BB, X (15), 16#1fa27cf8#, S33); -- 47 + HH (BB, CC, DD, AA, X (02), 16#c4ac5665#, S34); -- 48 + + -- Round 4 + + II (AA, BB, CC, DD, X (00), 16#f4292244#, S41); -- 49 + II (DD, AA, BB, CC, X (07), 16#432aff97#, S42); -- 50 + II (CC, DD, AA, BB, X (14), 16#ab9423a7#, S43); -- 51 + II (BB, CC, DD, AA, X (05), 16#fc93a039#, S44); -- 52 + + II (AA, BB, CC, DD, X (12), 16#655b59c3#, S41); -- 53 + II (DD, AA, BB, CC, X (03), 16#8f0ccc92#, S42); -- 54 + II (CC, DD, AA, BB, X (10), 16#ffeff47d#, S43); -- 55 + II (BB, CC, DD, AA, X (01), 16#85845dd1#, S44); -- 56 + + II (AA, BB, CC, DD, X (08), 16#6fa87e4f#, S41); -- 57 + II (DD, AA, BB, CC, X (15), 16#fe2ce6e0#, S42); -- 58 + II (CC, DD, AA, BB, X (06), 16#a3014314#, S43); -- 59 + II (BB, CC, DD, AA, X (13), 16#4e0811a1#, S44); -- 60 + + II (AA, BB, CC, DD, X (04), 16#f7537e82#, S41); -- 61 + II (DD, AA, BB, CC, X (11), 16#bd3af235#, S42); -- 62 + II (CC, DD, AA, BB, X (02), 16#2ad7d2bb#, S43); -- 63 + II (BB, CC, DD, AA, X (09), 16#eb86d391#, S44); -- 64 + + H (0) := H (0) + AA; + H (1) := H (1) + BB; + H (2) := H (2) + CC; + H (3) := H (3) + DD; + + end Transform; + +end GNAT.Secure_Hashes.MD5; diff --git a/gcc/ada/libgnat/g-sehamd.ads b/gcc/ada/libgnat/g-sehamd.ads new file mode 100644 index 0000000..5a19f34 --- /dev/null +++ b/gcc/ada/libgnat/g-sehamd.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . M D 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides supporting code for implementation of the MD5 +-- Message-Digest Algorithm as described in RFC 1321. The complete text of +-- RFC 1321 can be found at: +-- http://www.ietf.org/rfc/rfc1321.txt + +-- This is an internal unit and should not be used directly in applications. +-- Use GNAT.MD5 instead. + +with GNAT.Byte_Swapping; +with Interfaces; + +package GNAT.Secure_Hashes.MD5 is + + package Hash_State is + new GNAT.Secure_Hashes.Hash_Function_State + (Word => Interfaces.Unsigned_32, + Swap => GNAT.Byte_Swapping.Swap4, + Hash_Bit_Order => System.Low_Order_First); + -- MD5 operates on 32-bit little endian words + + Block_Words : constant := 16; + -- Messages are processed in chunks of 16 words + + procedure Transform + (H : in out Hash_State.State; + M : in out Message_State); + -- Transformation function applied for each block + + Initial_State : constant Hash_State.State; + -- Initialization vector + +private + + Initial_A : constant := 16#67452301#; + Initial_B : constant := 16#EFCDAB89#; + Initial_C : constant := 16#98BADCFE#; + Initial_D : constant := 16#10325476#; + + Initial_State : constant Hash_State.State := + (Initial_A, Initial_B, Initial_C, Initial_D); + -- Initialization vector from RFC 1321 + +end GNAT.Secure_Hashes.MD5; diff --git a/gcc/ada/libgnat/g-sehash.adb b/gcc/ada/libgnat/g-sehash.adb new file mode 100644 index 0000000..59d9dd4 --- /dev/null +++ b/gcc/ada/libgnat/g-sehash.adb @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Secure_Hashes.SHA1 is + + use Interfaces; + use GNAT.Byte_Swapping; + + -- The following functions are the four elementary components of each + -- of the four round groups (0 .. 19, 20 .. 39, 40 .. 59, and 60 .. 79) + -- defined in RFC 3174. + + function F0 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F0); + + function F1 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F1); + + function F2 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F2); + + function F3 (B, C, D : Unsigned_32) return Unsigned_32; + pragma Inline (F3); + + -------- + -- F0 -- + -------- + + function F0 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + is + begin + return (B and C) or ((not B) and D); + end F0; + + -------- + -- F1 -- + -------- + + function F1 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + is + begin + return B xor C xor D; + end F1; + + -------- + -- F2 -- + -------- + + function F2 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + is + begin + return (B and C) or (B and D) or (C and D); + end F2; + + -------- + -- F3 -- + -------- + + function F3 + (B, C, D : Interfaces.Unsigned_32) return Interfaces.Unsigned_32 + renames F1; + + --------------- + -- Transform -- + --------------- + + procedure Transform + (H : in out Hash_State.State; + M : in out Message_State) + is + use System; + + type Words is array (Natural range <>) of Interfaces.Unsigned_32; + + X : Words (0 .. 15); + for X'Address use M.Buffer'Address; + pragma Import (Ada, X); + + W : Words (0 .. 79); + + A, B, C, D, E, Temp : Interfaces.Unsigned_32; + + begin + if Default_Bit_Order /= High_Order_First then + for J in X'Range loop + Swap4 (X (J)'Address); + end loop; + end if; + + -- a. Divide data block into sixteen words + + W (0 .. 15) := X; + + -- b. Prepare working block of 80 words + + for T in 16 .. 79 loop + + -- W(t) = S^1(W(t-3) XOR W(t-8) XOR W(t-14) XOR W(t-16)) + + W (T) := Rotate_Left + (W (T - 3) xor W (T - 8) xor W (T - 14) xor W (T - 16), 1); + + end loop; + + -- c. Set up transformation variables + + A := H (0); + B := H (1); + C := H (2); + D := H (3); + E := H (4); + + -- d. For each of the 80 rounds, compute: + + -- TEMP = S^5(A) + f(t;B,C,D) + E + W(t) + K(t); + -- E = D; D = C; C = S^30(B); B = A; A = TEMP; + + for T in 0 .. 19 loop + Temp := Rotate_Left (A, 5) + F0 (B, C, D) + E + W (T) + 16#5A827999#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + for T in 20 .. 39 loop + Temp := Rotate_Left (A, 5) + F1 (B, C, D) + E + W (T) + 16#6ED9EBA1#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + for T in 40 .. 59 loop + Temp := Rotate_Left (A, 5) + F2 (B, C, D) + E + W (T) + 16#8F1BBCDC#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + for T in 60 .. 79 loop + Temp := Rotate_Left (A, 5) + F3 (B, C, D) + E + W (T) + 16#CA62C1D6#; + E := D; D := C; C := Rotate_Left (B, 30); B := A; A := Temp; + end loop; + + -- e. Update context: + -- H0 = H0 + A, H1 = H1 + B, H2 = H2 + C, H3 = H3 + D, H4 = H4 + E + + H (0) := H (0) + A; + H (1) := H (1) + B; + H (2) := H (2) + C; + H (3) := H (3) + D; + H (4) := H (4) + E; + end Transform; + +end GNAT.Secure_Hashes.SHA1; diff --git a/gcc/ada/libgnat/g-sehash.ads b/gcc/ada/libgnat/g-sehash.ads new file mode 100644 index 0000000..713eced --- /dev/null +++ b/gcc/ada/libgnat/g-sehash.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides supporting code for implementation of the SHA-1 +-- secure hash function as described in FIPS PUB 180-3. The complete text +-- of FIPS PUB 180-3 can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf + +-- This is an internal unit and should not be used directly in applications. +-- Use GNAT.SHA1 instead. + +with GNAT.Byte_Swapping; +with Interfaces; + +package GNAT.Secure_Hashes.SHA1 is + + package Hash_State is new Hash_Function_State + (Word => Interfaces.Unsigned_32, + Swap => GNAT.Byte_Swapping.Swap4, + Hash_Bit_Order => System.High_Order_First); + -- SHA-1 operates on 32-bit big endian words + + Block_Words : constant := 16; + -- Messages are processed in chunks of 16 words + + procedure Transform + (H : in out Hash_State.State; + M : in out Message_State); + -- Transformation function applied for each block + + Initial_State : constant Hash_State.State; + -- Initialization vector + +private + + Initial_State : constant Hash_State.State := + (0 => 16#67452301#, + 1 => 16#EFCDAB89#, + 2 => 16#98BADCFE#, + 3 => 16#10325476#, + 4 => 16#C3D2E1F0#); + -- Initialization vector from FIPS PUB 180-3 + +end GNAT.Secure_Hashes.SHA1; diff --git a/gcc/ada/libgnat/g-sercom-linux.adb b/gcc/ada/libgnat/g-sercom-linux.adb new file mode 100644 index 0000000..78e629f --- /dev/null +++ b/gcc/ada/libgnat/g-sercom-linux.adb @@ -0,0 +1,314 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/Linux implementation of this package + +with Ada.Streams; use Ada.Streams; +with Ada; use Ada; +with Ada.Unchecked_Deallocation; + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.OS_Constants; + +with GNAT.OS_Lib; use GNAT.OS_Lib; + +package body GNAT.Serial_Communications is + + package OSC renames System.OS_Constants; + + use type Interfaces.C.unsigned; + + type Port_Data is new int; + + subtype unsigned is Interfaces.C.unsigned; + subtype char is Interfaces.C.char; + subtype unsigned_char is Interfaces.C.unsigned_char; + + function fcntl (fd : int; cmd : int; value : int) return int; + pragma Import (C, fcntl, "fcntl"); + + C_Data_Rate : constant array (Data_Rate) of unsigned := + (B75 => OSC.B75, + B110 => OSC.B110, + B150 => OSC.B150, + B300 => OSC.B300, + B600 => OSC.B600, + B1200 => OSC.B1200, + B2400 => OSC.B2400, + B4800 => OSC.B4800, + B9600 => OSC.B9600, + B19200 => OSC.B19200, + B38400 => OSC.B38400, + B57600 => OSC.B57600, + B115200 => OSC.B115200); + + C_Bits : constant array (Data_Bits) of unsigned := + (CS7 => OSC.CS7, CS8 => OSC.CS8); + + C_Stop_Bits : constant array (Stop_Bits_Number) of unsigned := + (One => 0, Two => OSC.CSTOPB); + + C_Parity : constant array (Parity_Check) of unsigned := + (None => 0, + Odd => OSC.PARENB or OSC.PARODD, + Even => OSC.PARENB); + + procedure Raise_Error (Message : String; Error : Integer := Errno); + pragma No_Return (Raise_Error); + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N : constant Natural := Number - 1; + N_Img : constant String := Natural'Image (N); + begin + return Port_Name ("/dev/ttyS" & N_Img (N_Img'First + 1 .. N_Img'Last)); + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + use OSC; + + C_Name : constant String := String (Name) & ASCII.NUL; + Res : int; + + begin + if Port.H = null then + Port.H := new Port_Data; + end if; + + Port.H.all := Port_Data (open + (C_Name (C_Name'First)'Address, int (O_RDWR + O_NOCTTY + O_NDELAY))); + + if Port.H.all = -1 then + Raise_Error ("open: open failed"); + end if; + + -- By default we are in blocking mode + + Res := fcntl (int (Port.H.all), F_SETFL, 0); + + if Res = -1 then + Raise_Error ("open: fcntl failed"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : Integer := Errno) is + begin + raise Serial_Error with Message + & (if Error /= 0 + then " (" & Errno_Message (Err => Error) & ')' + else ""); + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Len : constant size_t := Buffer'Length; + Res : ssize_t; + + begin + if Port.H = null then + Raise_Error ("read: port not opened", 0); + end if; + + Res := read (Integer (Port.H.all), Buffer'Address, Len); + + if Res = -1 then + Raise_Error ("read failed"); + end if; + + Last := Last_Index (Buffer'First, size_t (Res)); + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; + Timeout : Duration := 10.0) + is + use OSC; + + type termios is record + c_iflag : unsigned; + c_oflag : unsigned; + c_cflag : unsigned; + c_lflag : unsigned; + c_line : unsigned_char; + c_cc : Interfaces.C.char_array (0 .. 31); + c_ispeed : unsigned; + c_ospeed : unsigned; + end record; + pragma Convention (C, termios); + + function tcgetattr (fd : int; termios_p : Address) return int; + pragma Import (C, tcgetattr, "tcgetattr"); + + function tcsetattr + (fd : int; action : int; termios_p : Address) return int; + pragma Import (C, tcsetattr, "tcsetattr"); + + function tcflush (fd : int; queue_selector : int) return int; + pragma Import (C, tcflush, "tcflush"); + + Current : termios; + + Res : int; + pragma Warnings (Off, Res); + -- Warnings off, since we don't always test the result + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + -- Get current port settings + + Res := tcgetattr (int (Port.H.all), Current'Address); + + -- Change settings now + + Current.c_cflag := C_Data_Rate (Rate) + or C_Bits (Bits) + or C_Stop_Bits (Stop_Bits) + or C_Parity (Parity) + or CREAD; + Current.c_iflag := 0; + Current.c_lflag := 0; + Current.c_oflag := 0; + + if Local then + Current.c_cflag := Current.c_cflag or CLOCAL; + end if; + + case Flow is + when None => + null; + + when RTS_CTS => + Current.c_cflag := Current.c_cflag or CRTSCTS; + + when Xon_Xoff => + Current.c_iflag := Current.c_iflag or IXON; + end case; + + Current.c_ispeed := Data_Rate_Value (Rate); + Current.c_ospeed := Data_Rate_Value (Rate); + Current.c_cc (VMIN) := char'Val (0); + Current.c_cc (VTIME) := char'Val (Natural (Timeout * 10)); + + -- Set port settings + + Res := tcflush (int (Port.H.all), TCIFLUSH); + Res := tcsetattr (int (Port.H.all), TCSANOW, Current'Address); + + -- Block + + Res := fcntl (int (Port.H.all), F_SETFL, (if Block then 0 else FNDELAY)); + + if Res = -1 then + Raise_Error ("set: fcntl failed"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Len : constant size_t := Buffer'Length; + Res : ssize_t; + + begin + if Port.H = null then + Raise_Error ("write: port not opened", 0); + end if; + + Res := write (int (Port.H.all), Buffer'Address, Len); + + if Res = -1 then + Raise_Error ("write failed"); + end if; + + pragma Assert (size_t (Res) = Len); + end Write; + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Res : int; + pragma Unreferenced (Res); + + begin + if Port.H /= null then + Res := close (int (Port.H.all)); + Unchecked_Free (Port.H); + end if; + end Close; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sercom-mingw.adb b/gcc/ada/libgnat/g-sercom-mingw.adb new file mode 100644 index 0000000..ed78a52 --- /dev/null +++ b/gcc/ada/libgnat/g-sercom-mingw.adb @@ -0,0 +1,316 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows implementation of this package + +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Deallocation; use Ada; + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.OS_Constants; +with System.Win32; use System.Win32; +with System.Win32.Ext; use System.Win32.Ext; + +with GNAT.OS_Lib; + +package body GNAT.Serial_Communications is + + package OSC renames System.OS_Constants; + + -- Common types + + type Port_Data is new HANDLE; + + C_Bits : constant array (Data_Bits) of Interfaces.C.unsigned := (8, 7); + C_Parity : constant array (Parity_Check) of Interfaces.C.unsigned := + (None => NOPARITY, Odd => ODDPARITY, Even => EVENPARITY); + C_Stop_Bits : constant array (Stop_Bits_Number) of Interfaces.C.unsigned := + (One => ONESTOPBIT, Two => TWOSTOPBITS); + + ----------- + -- Files -- + ----------- + + procedure Raise_Error (Message : String; Error : DWORD := GetLastError); + pragma No_Return (Raise_Error); + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + procedure Unchecked_Free is + new Unchecked_Deallocation (Port_Data, Port_Data_Access); + + Success : BOOL; + + begin + if Port.H /= null then + Success := CloseHandle (HANDLE (Port.H.all)); + Unchecked_Free (Port.H); + + if Success = Win32.FALSE then + Raise_Error ("error closing the port"); + end if; + end if; + end Close; + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + N_Img : constant String := Positive'Image (Number); + begin + if Number > 9 then + return + Port_Name ("\\.\COM" & N_Img (N_Img'First + 1 .. N_Img'Last)); + else + return + Port_Name ("COM" & N_Img (N_Img'First + 1 .. N_Img'Last) & ':'); + end if; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + C_Name : constant String := String (Name) & ASCII.NUL; + Success : BOOL; + pragma Unreferenced (Success); + + begin + if Port.H = null then + Port.H := new Port_Data; + else + Success := CloseHandle (HANDLE (Port.H.all)); + end if; + + Port.H.all := CreateFileA + (lpFileName => C_Name (C_Name'First)'Address, + dwDesiredAccess => GENERIC_READ or GENERIC_WRITE, + dwShareMode => 0, + lpSecurityAttributes => null, + dwCreationDisposition => OPEN_EXISTING, + dwFlagsAndAttributes => 0, + hTemplateFile => 0); + + if Port.H.all = Port_Data (INVALID_HANDLE_VALUE) then + Raise_Error ("cannot open com port"); + end if; + end Open; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error (Message : String; Error : DWORD := GetLastError) is + begin + raise Serial_Error with Message + & (if Error /= 0 + then " (" & GNAT.OS_Lib.Errno_Message (Err => Integer (Error)) & ')' + else ""); + end Raise_Error; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + Success : BOOL; + Read_Last : aliased DWORD; + + begin + if Port.H = null then + Raise_Error ("read: port not opened", 0); + end if; + + Success := + ReadFile + (hFile => HANDLE (Port.H.all), + lpBuffer => Buffer (Buffer'First)'Address, + nNumberOfBytesToRead => DWORD (Buffer'Length), + lpNumberOfBytesRead => Read_Last'Access, + lpOverlapped => null); + + if Success = Win32.FALSE then + Raise_Error ("read error"); + end if; + + Last := Last_Index (Buffer'First, size_t (Read_Last)); + end Read; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; + Timeout : Duration := 10.0) + is + pragma Unreferenced (Local); + + Success : BOOL; + Com_Time_Out : aliased COMMTIMEOUTS; + Com_Settings : aliased DCB; + + begin + if Port.H = null then + Raise_Error ("set: port not opened", 0); + end if; + + Success := GetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if Success = Win32.FALSE then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("set: cannot get comm state"); + end if; + + Com_Settings.BaudRate := DWORD (Data_Rate_Value (Rate)); + Com_Settings.fParity := 1; + Com_Settings.fBinary := Bits1 (System.Win32.TRUE); + Com_Settings.fOutxDsrFlow := 0; + Com_Settings.fDsrSensitivity := 0; + Com_Settings.fDtrControl := OSC.DTR_CONTROL_ENABLE; + Com_Settings.fInX := 0; + Com_Settings.fRtsControl := OSC.RTS_CONTROL_ENABLE; + + case Flow is + when None => + Com_Settings.fOutX := 0; + Com_Settings.fOutxCtsFlow := 0; + + when RTS_CTS => + Com_Settings.fOutX := 0; + Com_Settings.fOutxCtsFlow := 1; + + when Xon_Xoff => + Com_Settings.fOutX := 1; + Com_Settings.fOutxCtsFlow := 0; + end case; + + Com_Settings.fAbortOnError := 0; + Com_Settings.ByteSize := BYTE (C_Bits (Bits)); + Com_Settings.Parity := BYTE (C_Parity (Parity)); + Com_Settings.StopBits := BYTE (C_Stop_Bits (Stop_Bits)); + + Success := SetCommState (HANDLE (Port.H.all), Com_Settings'Access); + + if Success = Win32.FALSE then + Success := CloseHandle (HANDLE (Port.H.all)); + Port.H.all := 0; + Raise_Error ("cannot set comm state"); + end if; + + -- Set the timeout status, to honor our spec with respect to read + -- timeouts. Always disconnect write timeouts. + + -- Blocking reads - no timeout at all + + if Block then + Com_Time_Out := (others => 0); + + -- Non-blocking reads and null timeout - immediate return with what we + -- have - set ReadIntervalTimeout to MAXDWORD. + + elsif Timeout = 0.0 then + Com_Time_Out := + (ReadIntervalTimeout => DWORD'Last, + others => 0); + + -- Non-blocking reads with timeout - set total read timeout accordingly + + else + Com_Time_Out := + (ReadTotalTimeoutConstant => DWORD (1000 * Timeout), + others => 0); + end if; + + Success := + SetCommTimeouts + (hFile => HANDLE (Port.H.all), + lpCommTimeouts => Com_Time_Out'Access); + + if Success = Win32.FALSE then + Raise_Error ("cannot set the timeout"); + end if; + end Set; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + Success : BOOL; + Temp_Last : aliased DWORD; + + begin + if Port.H = null then + Raise_Error ("write: port not opened", 0); + end if; + + Success := + WriteFile + (hFile => HANDLE (Port.H.all), + lpBuffer => Buffer'Address, + nNumberOfBytesToWrite => DWORD (Buffer'Length), + lpNumberOfBytesWritten => Temp_Last'Access, + lpOverlapped => null); + + if Success = Win32.FALSE + or else Stream_Element_Offset (Temp_Last) /= Buffer'Length + then + Raise_Error ("failed to write data"); + end if; + end Write; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sercom.adb b/gcc/ada/libgnat/g-sercom.adb new file mode 100644 index 0000000..009d1a7 --- /dev/null +++ b/gcc/ada/libgnat/g-sercom.adb @@ -0,0 +1,136 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Default version of this package + +with Ada.Streams; use Ada.Streams; + +package body GNAT.Serial_Communications is + + pragma Warnings (Off); + -- Kill warnings on unreferenced formals + + type Port_Data is new Integer; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Unimplemented; + pragma No_Return (Unimplemented); + -- This procedure raises a Program_Error with an appropriate message + -- indicating that an unimplemented feature has been used. + + ---------- + -- Name -- + ---------- + + function Name (Number : Positive) return Port_Name is + begin + Unimplemented; + return ""; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (Port : out Serial_Port; + Name : Port_Name) + is + begin + Unimplemented; + end Open; + + --------- + -- Set -- + --------- + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; + Timeout : Duration := 10.0) + is + begin + Unimplemented; + end Set; + + ---------- + -- Read -- + ---------- + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Stream_Element_Array; + Last : out Stream_Element_Offset) + is + begin + Unimplemented; + end Read; + + ----------- + -- Write -- + ----------- + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Stream_Element_Array) + is + begin + Unimplemented; + end Write; + + ----------- + -- Close -- + ----------- + + procedure Close (Port : in out Serial_Port) is + begin + Unimplemented; + end Close; + + ------------------- + -- Unimplemented; -- + ------------------- + + procedure Unimplemented is + begin + raise Program_Error with "Serial_Communications not implemented"; + end Unimplemented; + +end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sercom.ads b/gcc/ada/libgnat/g-sercom.ads new file mode 100644 index 0000000..652b93b --- /dev/null +++ b/gcc/ada/libgnat/g-sercom.ads @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S E R I A L _ C O M M U N I C A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Serial communications package, implemented on Windows and GNU/Linux + +with Ada.Streams; +with Interfaces.C; + +package GNAT.Serial_Communications is + + -- Following is a simple example of using GNAT.Serial_Communications. + -- + -- with Ada.Streams; + -- with GNAT.Serial_Communications; + -- + -- procedure Serial is + -- use Ada.Streams; + -- use GNAT; + -- + -- subtype Message is Stream_Element_Array (1 .. 20); + -- + -- Data : constant String (1 .. 20) := "ABCDEFGHIJLKMNOPQRST"; + -- Buffer : Message; + -- + -- S_Port : constant Natural := 5; + -- -- Serial port number + -- + -- begin + -- -- Convert message (String -> Stream_Element_Array) + -- + -- for K in Data'Range loop + -- Buffer (Stream_Element_Offset (K)) := Character'Pos (Data (K)); + -- end loop; + -- + -- declare + -- Port_Name : constant Serial_Communications.Port_Name := + -- Serial_Communications.Name (Number => S_Port); + -- Port : Serial_Communications.Serial_Port; + -- + -- begin + -- Serial_Communications.Open + -- (Port => Port, + -- Name => Port_Name); + -- + -- Serial_Communications.Set + -- (Port => Port, + -- Rate => Serial_Communications.B9600, + -- Bits => Serial_Communications.CS8, + -- Stop_Bits => Serial_Communications.One, + -- Parity => Serial_Communications.Even); + -- + -- Serial_Communications.Write + -- (Port => Port, + -- Buffer => Buffer); + -- + -- Serial_Communications.Close + -- (Port => Port); + -- end; + -- end Serial; + + Serial_Error : exception; + -- Raised when a communication problem occurs + + type Port_Name is new String; + -- A serial com port name + + function Name (Number : Positive) return Port_Name; + -- Returns a possible port name for the given legacy PC architecture serial + -- port number (COM: on Windows, ttyS on Linux). + -- Note that this function does not support other kinds of serial ports + -- nor operating systems other than Windows and Linux. For all other + -- cases, an explicit port name can be passed directly to Open. + + type Data_Rate is + (B75, B110, B150, B300, B600, B1200, B2400, B4800, B9600, + B19200, B38400, B57600, B115200); + -- Speed of the communication + + type Data_Bits is (CS8, CS7); + -- Communication bits + + type Stop_Bits_Number is (One, Two); + -- One or two stop bits + + type Parity_Check is (None, Even, Odd); + -- Either no parity check or an even or odd parity + + type Flow_Control is (None, RTS_CTS, Xon_Xoff); + -- No flow control, hardware flow control, software flow control + + type Serial_Port is new Ada.Streams.Root_Stream_Type with private; + + procedure Open + (Port : out Serial_Port; + Name : Port_Name); + -- Open the given port name. Raises Serial_Error if the port cannot be + -- opened. + + procedure Set + (Port : Serial_Port; + Rate : Data_Rate := B9600; + Bits : Data_Bits := CS8; + Stop_Bits : Stop_Bits_Number := One; + Parity : Parity_Check := None; + Block : Boolean := True; + Local : Boolean := True; + Flow : Flow_Control := None; + Timeout : Duration := 10.0); + -- The communication port settings. If Block is set then a read call + -- will wait for the whole buffer to be filed. If Block is not set then + -- the given Timeout (in seconds) is used. If Local is set then modem + -- control lines (in particular DCD) are ignored (not supported on + -- Windows). Flow indicates the flow control type as defined above. + + -- Note: the timeout precision may be limited on some implementation + -- (e.g. on GNU/Linux the maximum precision is a tenth of seconds). + + -- Note: calling this procedure may reinitialize the serial port hardware + -- and thus cause loss of some buffered data if used during communication. + + overriding procedure Read + (Port : in out Serial_Port; + Buffer : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Read a set of bytes, put result into Buffer and set Last accordingly. + -- Last is set to Buffer'First - 1 if no byte has been read, unless + -- Buffer'First = Stream_Element_Offset'First, in which case the exception + -- Constraint_Error is raised instead. + + overriding procedure Write + (Port : in out Serial_Port; + Buffer : Ada.Streams.Stream_Element_Array); + -- Write buffer into the port + + procedure Close (Port : in out Serial_Port); + -- Close port + +private + + type Port_Data; + type Port_Data_Access is access Port_Data; + + type Serial_Port is new Ada.Streams.Root_Stream_Type with record + H : Port_Data_Access; + end record; + + Data_Rate_Value : constant array (Data_Rate) of Interfaces.C.unsigned := + (B75 => 75, + B110 => 110, + B150 => 150, + B300 => 300, + B600 => 600, + B1200 => 1_200, + B2400 => 2_400, + B4800 => 4_800, + B9600 => 9_600, + B19200 => 19_200, + B38400 => 38_400, + B57600 => 57_600, + B115200 => 115_200); + +end GNAT.Serial_Communications; diff --git a/gcc/ada/libgnat/g-sestin.ads b/gcc/ada/libgnat/g-sestin.ads new file mode 100644 index 0000000..d1764a4 --- /dev/null +++ b/gcc/ada/libgnat/g-sestin.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S E C O N D A R Y _ S T A C K _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for obtaining information on secondary +-- stack usage. + +with System.Secondary_Stack; + +package GNAT.Secondary_Stack_Info is + + function SS_Get_Max return Long_Long_Integer + renames System.Secondary_Stack.SS_Get_Max; + -- Return maximum used space in storage units for the current secondary + -- stack. For a dynamically allocated secondary stack, the returned + -- result is always -1. For a statically allocated secondary stack, + -- the returned value shows the largest amount of space allocated so + -- far during execution of the program to the current secondary stack, + -- i.e. the secondary stack for the current task. + +end GNAT.Secondary_Stack_Info; diff --git a/gcc/ada/libgnat/g-sha1.adb b/gcc/ada/libgnat/g-sha1.adb new file mode 100644 index 0000000..f27b886 --- /dev/null +++ b/gcc/ada/libgnat/g-sha1.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-sha1.ads b/gcc/ada/libgnat/g-sha1.ads new file mode 100644 index 0000000..c5fffe7 --- /dev/null +++ b/gcc/ada/libgnat/g-sha1.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the SHA-1 secure hash function as described in +-- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf + +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. + +with GNAT.Secure_Hashes.SHA1; +with System; + +package GNAT.SHA1 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.SHA1.Block_Words, + State_Words => 5, + Hash_Words => 5, + Hash_Bit_Order => System.High_Order_First, + Hash_State => GNAT.Secure_Hashes.SHA1.Hash_State, + Initial_State => GNAT.Secure_Hashes.SHA1.Initial_State, + Transform => GNAT.Secure_Hashes.SHA1.Transform); diff --git a/gcc/ada/libgnat/g-sha224.ads b/gcc/ada/libgnat/g-sha224.ads new file mode 100644 index 0000000..9d169f6 --- /dev/null +++ b/gcc/ada/libgnat/g-sha224.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 2 2 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the SHA-224 secure hash function as described in +-- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf + +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. + +with GNAT.Secure_Hashes.SHA2_Common; +with GNAT.Secure_Hashes.SHA2_32; +with System; + +package GNAT.SHA224 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, + State_Words => 8, + Hash_Words => 7, + Hash_Bit_Order => System.High_Order_First, + Hash_State => GNAT.Secure_Hashes.SHA2_32.Hash_State, + Initial_State => GNAT.Secure_Hashes.SHA2_32.SHA224_Init_State, + Transform => GNAT.Secure_Hashes.SHA2_32.Transform); diff --git a/gcc/ada/libgnat/g-sha256.ads b/gcc/ada/libgnat/g-sha256.ads new file mode 100644 index 0000000..255b520 --- /dev/null +++ b/gcc/ada/libgnat/g-sha256.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 2 5 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the SHA-256 secure hash function as described in +-- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf + +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. + +with GNAT.Secure_Hashes.SHA2_Common; +with GNAT.Secure_Hashes.SHA2_32; +with System; + +package GNAT.SHA256 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, + State_Words => 8, + Hash_Words => 8, + Hash_Bit_Order => System.High_Order_First, + Hash_State => GNAT.Secure_Hashes.SHA2_32.Hash_State, + Initial_State => GNAT.Secure_Hashes.SHA2_32.SHA256_Init_State, + Transform => GNAT.Secure_Hashes.SHA2_32.Transform); diff --git a/gcc/ada/libgnat/g-sha384.ads b/gcc/ada/libgnat/g-sha384.ads new file mode 100644 index 0000000..3e3aa3b --- /dev/null +++ b/gcc/ada/libgnat/g-sha384.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 3 8 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the SHA-384 secure hash function as described in +-- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf + +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. + +with GNAT.Secure_Hashes.SHA2_Common; +with GNAT.Secure_Hashes.SHA2_64; +with System; + +package GNAT.SHA384 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, + State_Words => 8, + Hash_Words => 6, + Hash_Bit_Order => System.High_Order_First, + Hash_State => GNAT.Secure_Hashes.SHA2_64.Hash_State, + Initial_State => GNAT.Secure_Hashes.SHA2_64.SHA384_Init_State, + Transform => GNAT.Secure_Hashes.SHA2_64.Transform); diff --git a/gcc/ada/libgnat/g-sha512.ads b/gcc/ada/libgnat/g-sha512.ads new file mode 100644 index 0000000..da22788 --- /dev/null +++ b/gcc/ada/libgnat/g-sha512.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S H A 5 1 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the SHA-512 secure hash function as described in +-- FIPS PUB 180-3. The complete text of FIPS PUB 180-3 can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf + +-- See the declaration of GNAT.Secure_Hashes.H in g-sechas.ads for complete +-- documentation. + +with GNAT.Secure_Hashes.SHA2_Common; +with GNAT.Secure_Hashes.SHA2_64; +with System; + +package GNAT.SHA512 is new GNAT.Secure_Hashes.H + (Block_Words => GNAT.Secure_Hashes.SHA2_Common.Block_Words, + State_Words => 8, + Hash_Words => 8, + Hash_Bit_Order => System.High_Order_First, + Hash_State => GNAT.Secure_Hashes.SHA2_64.Hash_State, + Initial_State => GNAT.Secure_Hashes.SHA2_64.SHA512_Init_State, + Transform => GNAT.Secure_Hashes.SHA2_64.Transform); diff --git a/gcc/ada/libgnat/g-shsh32.adb b/gcc/ada/libgnat/g-shsh32.adb new file mode 100644 index 0000000..fece8ca --- /dev/null +++ b/gcc/ada/libgnat/g-shsh32.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Secure_Hashes.SHA2_32 is + + use Interfaces; + + ------------ + -- Sigma0 -- + ------------ + + function Sigma0 (X : Word) return Word is + begin + return Rotate_Right (X, 2) + xor Rotate_Right (X, 13) + xor Rotate_Right (X, 22); + end Sigma0; + + ------------ + -- Sigma1 -- + ------------ + + function Sigma1 (X : Word) return Word is + begin + return Rotate_Right (X, 6) + xor Rotate_Right (X, 11) + xor Rotate_Right (X, 25); + end Sigma1; + + -------- + -- S0 -- + -------- + + function S0 (X : Word) return Word is + begin + return Rotate_Right (X, 7) + xor Rotate_Right (X, 18) + xor Shift_Right (X, 3); + end S0; + + -------- + -- S1 -- + -------- + + function S1 (X : Word) return Word is + begin + return Rotate_Right (X, 17) + xor Rotate_Right (X, 19) + xor Shift_Right (X, 10); + end S1; + +end GNAT.Secure_Hashes.SHA2_32; diff --git a/gcc/ada/libgnat/g-shsh32.ads b/gcc/ada/libgnat/g-shsh32.ads new file mode 100644 index 0000000..573f917 --- /dev/null +++ b/gcc/ada/libgnat/g-shsh32.ads @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides support for the 32-bit FIPS PUB 180-3 functions +-- SHA-224 and SHA-256. + +-- This is an internal unit and should not be used directly in applications. +-- Use GNAT.SHA224 and GNAT.SHA256 instead. + +with Interfaces; +with GNAT.Byte_Swapping; +with GNAT.Secure_Hashes.SHA2_Common; + +package GNAT.Secure_Hashes.SHA2_32 is + + subtype Word is Interfaces.Unsigned_32; + + package Hash_State is new Hash_Function_State + (Word => Word, + Swap => GNAT.Byte_Swapping.Swap4, + Hash_Bit_Order => System.High_Order_First); + -- SHA-224 and SHA-256 operate on 32-bit big endian words + + K : constant Hash_State.State (0 .. 63) := + (16#428a2f98#, 16#71374491#, 16#b5c0fbcf#, 16#e9b5dba5#, + 16#3956c25b#, 16#59f111f1#, 16#923f82a4#, 16#ab1c5ed5#, + 16#d807aa98#, 16#12835b01#, 16#243185be#, 16#550c7dc3#, + 16#72be5d74#, 16#80deb1fe#, 16#9bdc06a7#, 16#c19bf174#, + 16#e49b69c1#, 16#efbe4786#, 16#0fc19dc6#, 16#240ca1cc#, + 16#2de92c6f#, 16#4a7484aa#, 16#5cb0a9dc#, 16#76f988da#, + 16#983e5152#, 16#a831c66d#, 16#b00327c8#, 16#bf597fc7#, + 16#c6e00bf3#, 16#d5a79147#, 16#06ca6351#, 16#14292967#, + 16#27b70a85#, 16#2e1b2138#, 16#4d2c6dfc#, 16#53380d13#, + 16#650a7354#, 16#766a0abb#, 16#81c2c92e#, 16#92722c85#, + 16#a2bfe8a1#, 16#a81a664b#, 16#c24b8b70#, 16#c76c51a3#, + 16#d192e819#, 16#d6990624#, 16#f40e3585#, 16#106aa070#, + 16#19a4c116#, 16#1e376c08#, 16#2748774c#, 16#34b0bcb5#, + 16#391c0cb3#, 16#4ed8aa4a#, 16#5b9cca4f#, 16#682e6ff3#, + 16#748f82ee#, 16#78a5636f#, 16#84c87814#, 16#8cc70208#, + 16#90befffa#, 16#a4506ceb#, 16#bef9a3f7#, 16#c67178f2#); + -- Constants from FIPS PUB 180-3 + + function Sigma0 (X : Word) return Word; + function Sigma1 (X : Word) return Word; + function S0 (X : Word) return Word; + function S1 (X : Word) return Word; + pragma Inline (Sigma0, Sigma1, S0, S1); + -- Elementary functions Sigma^256_0, Sigma^256_1, sigma^256_0, sigma^256_1 + -- from FIPS PUB 180-3. + + procedure Transform is new SHA2_Common.Transform + (Hash_State => Hash_State, + K => K, + Rounds => 64, + Sigma0 => Sigma0, + Sigma1 => Sigma1, + S0 => S0, + S1 => S1); + + SHA224_Init_State : constant Hash_State.State (0 .. 7) := + (0 => 16#c1059ed8#, + 1 => 16#367cd507#, + 2 => 16#3070dd17#, + 3 => 16#f70e5939#, + 4 => 16#ffc00b31#, + 5 => 16#68581511#, + 6 => 16#64f98fa7#, + 7 => 16#befa4fa4#); + SHA256_Init_State : constant Hash_State.State (0 .. 7) := + (0 => 16#6a09e667#, + 1 => 16#bb67ae85#, + 2 => 16#3c6ef372#, + 3 => 16#a54ff53a#, + 4 => 16#510e527f#, + 5 => 16#9b05688c#, + 6 => 16#1f83d9ab#, + 7 => 16#5be0cd19#); + -- Initialization vectors from FIPS PUB 180-3 + +end GNAT.Secure_Hashes.SHA2_32; diff --git a/gcc/ada/libgnat/g-shsh64.adb b/gcc/ada/libgnat/g-shsh64.adb new file mode 100644 index 0000000..1546e10 --- /dev/null +++ b/gcc/ada/libgnat/g-shsh64.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 6 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Secure_Hashes.SHA2_64 is + + use Interfaces; + + ------------ + -- Sigma0 -- + ------------ + + function Sigma0 (X : Word) return Word is + begin + return Rotate_Right (X, 28) + xor Rotate_Right (X, 34) + xor Rotate_Right (X, 39); + end Sigma0; + + ------------ + -- Sigma1 -- + ------------ + + function Sigma1 (X : Word) return Word is + begin + return Rotate_Right (X, 14) + xor Rotate_Right (X, 18) + xor Rotate_Right (X, 41); + end Sigma1; + + -------- + -- S0 -- + -------- + + function S0 (X : Word) return Word is + begin + return Rotate_Right (X, 1) + xor Rotate_Right (X, 8) + xor Shift_Right (X, 7); + end S0; + + -------- + -- S1 -- + -------- + + function S1 (X : Word) return Word is + begin + return Rotate_Right (X, 19) + xor Rotate_Right (X, 61) + xor Shift_Right (X, 6); + end S1; + +end GNAT.Secure_Hashes.SHA2_64; diff --git a/gcc/ada/libgnat/g-shsh64.ads b/gcc/ada/libgnat/g-shsh64.ads new file mode 100644 index 0000000..00a0aea --- /dev/null +++ b/gcc/ada/libgnat/g-shsh64.ads @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 2 _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides support for the 64-bit FIPS PUB 180-3 functions +-- SHA-384 and SHA-512. + +-- This is an internal unit and should not be used directly in applications. +-- Use GNAT.SHA384 and GNAT.SHA512 instead. + +with Interfaces; +with GNAT.Byte_Swapping; + +with GNAT.Secure_Hashes.SHA2_Common; + +package GNAT.Secure_Hashes.SHA2_64 is + subtype Word is Interfaces.Unsigned_64; + + package Hash_State is new Hash_Function_State + (Word => Word, + Swap => GNAT.Byte_Swapping.Swap8, + Hash_Bit_Order => System.High_Order_First); + -- SHA-384 and SHA-512 operate on 64-bit big endian words + + K : Hash_State.State (0 .. 79) := + (16#428a2f98d728ae22#, 16#7137449123ef65cd#, + 16#b5c0fbcfec4d3b2f#, 16#e9b5dba58189dbbc#, + 16#3956c25bf348b538#, 16#59f111f1b605d019#, + 16#923f82a4af194f9b#, 16#ab1c5ed5da6d8118#, + 16#d807aa98a3030242#, 16#12835b0145706fbe#, + 16#243185be4ee4b28c#, 16#550c7dc3d5ffb4e2#, + 16#72be5d74f27b896f#, 16#80deb1fe3b1696b1#, + 16#9bdc06a725c71235#, 16#c19bf174cf692694#, + 16#e49b69c19ef14ad2#, 16#efbe4786384f25e3#, + 16#0fc19dc68b8cd5b5#, 16#240ca1cc77ac9c65#, + 16#2de92c6f592b0275#, 16#4a7484aa6ea6e483#, + 16#5cb0a9dcbd41fbd4#, 16#76f988da831153b5#, + 16#983e5152ee66dfab#, 16#a831c66d2db43210#, + 16#b00327c898fb213f#, 16#bf597fc7beef0ee4#, + 16#c6e00bf33da88fc2#, 16#d5a79147930aa725#, + 16#06ca6351e003826f#, 16#142929670a0e6e70#, + 16#27b70a8546d22ffc#, 16#2e1b21385c26c926#, + 16#4d2c6dfc5ac42aed#, 16#53380d139d95b3df#, + 16#650a73548baf63de#, 16#766a0abb3c77b2a8#, + 16#81c2c92e47edaee6#, 16#92722c851482353b#, + 16#a2bfe8a14cf10364#, 16#a81a664bbc423001#, + 16#c24b8b70d0f89791#, 16#c76c51a30654be30#, + 16#d192e819d6ef5218#, 16#d69906245565a910#, + 16#f40e35855771202a#, 16#106aa07032bbd1b8#, + 16#19a4c116b8d2d0c8#, 16#1e376c085141ab53#, + 16#2748774cdf8eeb99#, 16#34b0bcb5e19b48a8#, + 16#391c0cb3c5c95a63#, 16#4ed8aa4ae3418acb#, + 16#5b9cca4f7763e373#, 16#682e6ff3d6b2b8a3#, + 16#748f82ee5defb2fc#, 16#78a5636f43172f60#, + 16#84c87814a1f0ab72#, 16#8cc702081a6439ec#, + 16#90befffa23631e28#, 16#a4506cebde82bde9#, + 16#bef9a3f7b2c67915#, 16#c67178f2e372532b#, + 16#ca273eceea26619c#, 16#d186b8c721c0c207#, + 16#eada7dd6cde0eb1e#, 16#f57d4f7fee6ed178#, + 16#06f067aa72176fba#, 16#0a637dc5a2c898a6#, + 16#113f9804bef90dae#, 16#1b710b35131c471b#, + 16#28db77f523047d84#, 16#32caab7b40c72493#, + 16#3c9ebe0a15c9bebc#, 16#431d67c49c100d4c#, + 16#4cc5d4becb3e42b6#, 16#597f299cfc657e2a#, + 16#5fcb6fab3ad6faec#, 16#6c44198c4a475817#); + -- Constants from FIPS PUB 180-3 + + function Sigma0 (X : Word) return Word; + function Sigma1 (X : Word) return Word; + function S0 (X : Word) return Word; + function S1 (X : Word) return Word; + pragma Inline (Sigma0, Sigma1, S0, S1); + -- Elementary functions Sigma^512_0, Sigma^512_1, sigma^512_0, sigma^512_1 + -- from FIPS PUB 180-3. + + procedure Transform is new SHA2_Common.Transform + (Hash_State => Hash_State, + K => K, + Rounds => 80, + Sigma0 => Sigma0, + Sigma1 => Sigma1, + S0 => S0, + S1 => S1); + + SHA384_Init_State : constant Hash_State.State := + (0 => 16#cbbb9d5dc1059ed8#, + 1 => 16#629a292a367cd507#, + 2 => 16#9159015a3070dd17#, + 3 => 16#152fecd8f70e5939#, + 4 => 16#67332667ffc00b31#, + 5 => 16#8eb44a8768581511#, + 6 => 16#db0c2e0d64f98fa7#, + 7 => 16#47b5481dbefa4fa4#); + SHA512_Init_State : constant Hash_State.State := + (0 => 16#6a09e667f3bcc908#, + 1 => 16#bb67ae8584caa73b#, + 2 => 16#3c6ef372fe94f82b#, + 3 => 16#a54ff53a5f1d36f1#, + 4 => 16#510e527fade682d1#, + 5 => 16#9b05688c2b3e6c1f#, + 6 => 16#1f83d9abfb41bd6b#, + 7 => 16#5be0cd19137e2179#); + -- Initialization vectors from FIPS PUB 180-3 + +end GNAT.Secure_Hashes.SHA2_64; diff --git a/gcc/ada/libgnat/g-shshco.adb b/gcc/ada/libgnat/g-shshco.adb new file mode 100644 index 0000000..8641a59 --- /dev/null +++ b/gcc/ada/libgnat/g-shshco.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 2 _ C O M M O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Secure_Hashes.SHA2_Common is + + --------------- + -- Transform -- + --------------- + + procedure Transform + (H_St : in out Hash_State.State; + M_St : in out Message_State) + is + use System; + + subtype Word is Hash_State.Word; + use type Hash_State.Word; + + function Ch (X, Y, Z : Word) return Word; + function Maj (X, Y, Z : Word) return Word; + pragma Inline (Ch, Maj); + -- Elementary functions from FIPS PUB 180-3 + + -------- + -- Ch -- + -------- + + function Ch (X, Y, Z : Word) return Word is + begin + return (X and Y) xor ((not X) and Z); + end Ch; + + --------- + -- Maj -- + --------- + + function Maj (X, Y, Z : Word) return Word is + begin + return (X and Y) xor (X and Z) xor (Y and Z); + end Maj; + + type Words is array (Natural range <>) of Word; + + X : Words (0 .. 15); + for X'Address use M_St.Buffer'Address; + pragma Import (Ada, X); + + W : Words (0 .. Rounds - 1); + + A, B, C, D, E, F, G, H, T1, T2 : Word; + + -- Start of processing for Transform + + begin + if Default_Bit_Order /= High_Order_First then + for J in X'Range loop + Hash_State.Swap (X (J)'Address); + end loop; + end if; + + -- 1. Prepare message schedule + + W (0 .. 15) := X; + + for T in 16 .. Rounds - 1 loop + W (T) := S1 (W (T - 2)) + W (T - 7) + S0 (W (T - 15)) + W (T - 16); + end loop; + + -- 2. Initialize working variables + + A := H_St (0); + B := H_St (1); + C := H_St (2); + D := H_St (3); + E := H_St (4); + F := H_St (5); + G := H_St (6); + H := H_St (7); + + -- 3. Perform transformation rounds + + for T in 0 .. Rounds - 1 loop + T1 := H + Sigma1 (E) + Ch (E, F, G) + K (T) + W (T); + T2 := Sigma0 (A) + Maj (A, B, C); + H := G; + G := F; + F := E; + E := D + T1; + D := C; + C := B; + B := A; + A := T1 + T2; + end loop; + + -- 4. Update hash state + + H_St (0) := A + H_St (0); + H_St (1) := B + H_St (1); + H_St (2) := C + H_St (2); + H_St (3) := D + H_St (3); + H_St (4) := E + H_St (4); + H_St (5) := F + H_St (5); + H_St (6) := G + H_St (6); + H_St (7) := H + H_St (7); + end Transform; + +end GNAT.Secure_Hashes.SHA2_Common; diff --git a/gcc/ada/libgnat/g-shshco.ads b/gcc/ada/libgnat/g-shshco.ads new file mode 100644 index 0000000..21a92eb --- /dev/null +++ b/gcc/ada/libgnat/g-shshco.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S E C U R E _ H A S H E S . S H A 2 _ C O M M O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides supporting code for implementation of the following +-- secure hash functions described in FIPS PUB 180-3: SHA-224, SHA-256, +-- SHA-384, SHA-512. It contains the generic transform operation that is +-- common to the above four functions. The complete text of FIPS PUB 180-3 +-- can be found at: +-- http://csrc.nist.gov/publications/fips/fips180-3/fips180-3_final.pdf + +-- This is an internal unit and should not be used directly in applications. +-- Use GNAT.SHA* instead. + +package GNAT.Secure_Hashes.SHA2_Common is + + Block_Words : constant := 16; + -- All functions operate on blocks of 16 words + + generic + with package Hash_State is new Hash_Function_State (<>); + + Rounds : Natural; + -- Number of transformation rounds + + K : Hash_State.State; + -- Constants used in the transform operation + + with function Sigma0 (X : Hash_State.Word) return Hash_State.Word is <>; + with function Sigma1 (X : Hash_State.Word) return Hash_State.Word is <>; + with function S0 (X : Hash_State.Word) return Hash_State.Word is <>; + with function S1 (X : Hash_State.Word) return Hash_State.Word is <>; + -- FIPS PUB 180-3 elementary functions + + procedure Transform + (H_St : in out Hash_State.State; + M_St : in out Message_State); + +end GNAT.Secure_Hashes.SHA2_Common; diff --git a/gcc/ada/libgnat/g-soccon.ads b/gcc/ada/libgnat/g-soccon.ads new file mode 100644 index 0000000..074a2e9 --- /dev/null +++ b/gcc/ada/libgnat/g-soccon.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 temporary compatibility renaming for deprecated +-- internal package GNAT.Sockets.Constants. + +-- This package should not be directly used by an applications program. +-- It is a compatibility artefact to help building legacy code with newer +-- compilers, and will be removed at some point in the future. + +with System.OS_Constants; +package GNAT.Sockets.Constants renames System.OS_Constants; diff --git a/gcc/ada/libgnat/g-socket-dummy.adb b/gcc/ada/libgnat/g-socket-dummy.adb new file mode 100644 index 0000000..6cf2eab --- /dev/null +++ b/gcc/ada/libgnat/g-socket-dummy.adb @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-socket-dummy.ads b/gcc/ada/libgnat/g-socket-dummy.ads new file mode 100644 index 0000000..18caed9 --- /dev/null +++ b/gcc/ada/libgnat/g-socket-dummy.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets is + pragma Unimplemented_Unit; +end GNAT.Sockets; diff --git a/gcc/ada/libgnat/g-socket.adb b/gcc/ada/libgnat/g-socket.adb new file mode 100644 index 0000000..9b2ad7f --- /dev/null +++ b/gcc/ada/libgnat/g-socket.adb @@ -0,0 +1,2786 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Streams; use Ada.Streams; +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Finalization; +with Ada.Unchecked_Conversion; + +with GNAT.Sockets.Thin_Common; use GNAT.Sockets.Thin_Common; +with GNAT.Sockets.Thin; use GNAT.Sockets.Thin; + +with GNAT.Sockets.Linker_Options; +pragma Warnings (Off, GNAT.Sockets.Linker_Options); +-- Need to include pragma Linker_Options which is platform dependent + +with System; use System; +with System.Communication; use System.Communication; +with System.CRTL; use System.CRTL; +with System.Task_Lock; + +package body GNAT.Sockets is + + package C renames Interfaces.C; + + ENOERROR : constant := 0; + + Netdb_Buffer_Size : constant := SOSC.Need_Netdb_Buffer * 1024; + Need_Netdb_Lock : constant Boolean := SOSC.Need_Netdb_Lock /= 0; + -- The network database functions gethostbyname, gethostbyaddr, + -- getservbyname and getservbyport can either be guaranteed task safe by + -- the operating system, or else return data through a user-provided buffer + -- to ensure concurrent uses do not interfere. + + -- Correspondence tables + + Levels : constant array (Level_Type) of C.int := + (Socket_Level => SOSC.SOL_SOCKET, + IP_Protocol_For_IP_Level => SOSC.IPPROTO_IP, + IP_Protocol_For_UDP_Level => SOSC.IPPROTO_UDP, + IP_Protocol_For_TCP_Level => SOSC.IPPROTO_TCP); + + Modes : constant array (Mode_Type) of C.int := + (Socket_Stream => SOSC.SOCK_STREAM, + Socket_Datagram => SOSC.SOCK_DGRAM); + + Shutmodes : constant array (Shutmode_Type) of C.int := + (Shut_Read => SOSC.SHUT_RD, + Shut_Write => SOSC.SHUT_WR, + Shut_Read_Write => SOSC.SHUT_RDWR); + + Requests : constant array (Request_Name) of SOSC.IOCTL_Req_T := + (Non_Blocking_IO => SOSC.FIONBIO, + N_Bytes_To_Read => SOSC.FIONREAD); + + Options : constant array (Specific_Option_Name) of C.int := + (Keep_Alive => SOSC.SO_KEEPALIVE, + Reuse_Address => SOSC.SO_REUSEADDR, + Broadcast => SOSC.SO_BROADCAST, + Send_Buffer => SOSC.SO_SNDBUF, + Receive_Buffer => SOSC.SO_RCVBUF, + Linger => SOSC.SO_LINGER, + Error => SOSC.SO_ERROR, + No_Delay => SOSC.TCP_NODELAY, + Add_Membership => SOSC.IP_ADD_MEMBERSHIP, + Drop_Membership => SOSC.IP_DROP_MEMBERSHIP, + Multicast_If => SOSC.IP_MULTICAST_IF, + Multicast_TTL => SOSC.IP_MULTICAST_TTL, + Multicast_Loop => SOSC.IP_MULTICAST_LOOP, + Receive_Packet_Info => SOSC.IP_PKTINFO, + Send_Timeout => SOSC.SO_SNDTIMEO, + Receive_Timeout => SOSC.SO_RCVTIMEO, + Busy_Polling => SOSC.SO_BUSY_POLL); + -- ??? Note: for OpenSolaris, Receive_Packet_Info should be IP_RECVPKTINFO, + -- but for Linux compatibility this constant is the same as IP_PKTINFO. + + Flags : constant array (0 .. 3) of C.int := + (0 => SOSC.MSG_OOB, -- Process_Out_Of_Band_Data + 1 => SOSC.MSG_PEEK, -- Peek_At_Incoming_Data + 2 => SOSC.MSG_WAITALL, -- Wait_For_A_Full_Reception + 3 => SOSC.MSG_EOR); -- Send_End_Of_Record + + Socket_Error_Id : constant Exception_Id := Socket_Error'Identity; + Host_Error_Id : constant Exception_Id := Host_Error'Identity; + + Hex_To_Char : constant String (1 .. 16) := "0123456789ABCDEF"; + -- Use to print in hexadecimal format + + ----------------------- + -- Local subprograms -- + ----------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) return Error_Type; + -- Associate an enumeration value (error_type) to an error value (errno). + -- From_Errno prevents from mixing h_errno with errno. + + function To_Name (N : String) return Name_Type; + function To_String (HN : Name_Type) return String; + -- Conversion functions + + function To_Int (F : Request_Flag_Type) return C.int; + -- Return the int value corresponding to the specified flags combination + + function Set_Forced_Flags (F : C.int) return C.int; + -- Return F with the bits from SOSC.MSG_Forced_Flags forced set + + function Short_To_Network + (S : C.unsigned_short) return C.unsigned_short; + pragma Inline (Short_To_Network); + -- Convert a port number into a network port number + + function Network_To_Short + (S : C.unsigned_short) return C.unsigned_short + renames Short_To_Network; + -- Symmetric operation + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) return String; + -- Output an array of inet address components in hex or decimal mode + + function Is_IP_Address (Name : String) return Boolean; + -- Return true when Name is an IPv4 address in dotted quad notation + + procedure Netdb_Lock; + pragma Inline (Netdb_Lock); + procedure Netdb_Unlock; + pragma Inline (Netdb_Unlock); + -- Lock/unlock operation used to protect netdb access for platforms that + -- require such protection. + + function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr; + procedure To_Inet_Addr + (Addr : In_Addr; + Result : out Inet_Addr_Type); + -- Conversion functions + + function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type; + -- Conversion function + + function To_Service_Entry (E : Servent_Access) return Service_Entry_Type; + -- Conversion function + + function Value (S : System.Address) return String; + -- Same as Interfaces.C.Strings.Value but taking a System.Address + + function To_Timeval (Val : Timeval_Duration) return Timeval; + -- Separate Val in seconds and microseconds + + function To_Duration (Val : Timeval) return Timeval_Duration; + -- Reconstruct a Duration value from a Timeval record (seconds and + -- microseconds). + + procedure Raise_Socket_Error (Error : Integer); + -- Raise Socket_Error with an exception message describing the error code + -- from errno. + + procedure Raise_Host_Error (H_Error : Integer; Name : String); + -- Raise Host_Error exception with message describing error code (note + -- hstrerror seems to be obsolete) from h_errno. Name is the name + -- or address that was being looked up. + + procedure Narrow (Item : in out Socket_Set_Type); + -- Update Last as it may be greater than the real last socket + + procedure Check_For_Fd_Set (Fd : Socket_Type); + pragma Inline (Check_For_Fd_Set); + -- Raise Constraint_Error if Fd is less than 0 or greater than or equal to + -- FD_SETSIZE, on platforms where fd_set is a bitmap. + + function Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) return C.int; + pragma Inline (Connect_Socket); + -- Underlying implementation for the Connect_Socket procedures + + -- Types needed for Datagram_Socket_Stream_Type + + type Datagram_Socket_Stream_Type is new Root_Stream_Type with record + Socket : Socket_Type; + To : Sock_Addr_Type; + From : Sock_Addr_Type; + end record; + + type Datagram_Socket_Stream_Access is + access all Datagram_Socket_Stream_Type; + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -- Types needed for Stream_Socket_Stream_Type + + type Stream_Socket_Stream_Type is new Root_Stream_Type with record + Socket : Socket_Type; + end record; + + type Stream_Socket_Stream_Access is + access all Stream_Socket_Stream_Type; + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Common code for variants of socket operations supporting a timeout: + -- block in Check_Selector on Socket for at most the indicated timeout. + -- If For_Read is True, Socket is added to the read set for this call, else + -- it is added to the write set. If no selector is provided, a local one is + -- created for this call and destroyed prior to returning. + + type Sockets_Library_Controller is new Ada.Finalization.Limited_Controlled + with null record; + -- This type is used to generate automatic calls to Initialize and Finalize + -- during the elaboration and finalization of this package. A single object + -- of this type must exist at library level. + + function Err_Code_Image (E : Integer) return String; + -- Return the value of E surrounded with brackets + + procedure Initialize (X : in out Sockets_Library_Controller); + procedure Finalize (X : in out Sockets_Library_Controller); + + procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type); + -- If S is the empty set (detected by Last = No_Socket), make sure its + -- fd_set component is actually cleared. Note that the case where it is + -- not can occur for an uninitialized Socket_Set_Type object. + + function Is_Open (S : Selector_Type) return Boolean; + -- Return True for an "open" Selector_Type object, i.e. one for which + -- Create_Selector has been called and Close_Selector has not been called, + -- or the null selector. + + --------- + -- "+" -- + --------- + + function "+" (L, R : Request_Flag_Type) return Request_Flag_Type is + begin + return L or R; + end "+"; + + -------------------- + -- Abort_Selector -- + -------------------- + + procedure Abort_Selector (Selector : Selector_Type) is + Res : C.int; + + begin + if not Is_Open (Selector) then + raise Program_Error with "closed selector"; + + elsif Selector.Is_Null then + raise Program_Error with "null selector"; + + end if; + + -- Send one byte to unblock select system call + + Res := Signalling_Fds.Write (C.int (Selector.W_Sig_Socket)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Abort_Selector; + + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := C_Accept (C.int (Server), Sin'Address, Len'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + + To_Inet_Addr (Sin.Sin_Addr, Address.Addr); + Address.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + end Accept_Socket; + + ------------------- + -- Accept_Socket -- + ------------------- + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + begin + if Selector /= null and then not Is_Open (Selector.all) then + raise Program_Error with "closed selector"; + end if; + + -- Wait for socket to become available for reading + + Wait_On_Socket + (Socket => Server, + For_Read => True, + Timeout => Timeout, + Selector => Selector, + Status => Status); + + -- Accept connection if available + + if Status = Completed then + Accept_Socket (Server, Socket, Address); + else + Socket := No_Socket; + end if; + end Accept_Socket; + + --------------- + -- Addresses -- + --------------- + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) return Inet_Addr_Type + is + begin + return E.Addresses (N); + end Addresses; + + ---------------------- + -- Addresses_Length -- + ---------------------- + + function Addresses_Length (E : Host_Entry_Type) return Natural is + begin + return E.Addresses_Length; + end Addresses_Length; + + ------------- + -- Aliases -- + ------------- + + function Aliases + (E : Host_Entry_Type; + N : Positive := 1) return String + is + begin + return To_String (E.Aliases (N)); + end Aliases; + + ------------- + -- Aliases -- + ------------- + + function Aliases + (S : Service_Entry_Type; + N : Positive := 1) return String + is + begin + return To_String (S.Aliases (N)); + end Aliases; + + -------------------- + -- Aliases_Length -- + -------------------- + + function Aliases_Length (E : Host_Entry_Type) return Natural is + begin + return E.Aliases_Length; + end Aliases_Length; + + -------------------- + -- Aliases_Length -- + -------------------- + + function Aliases_Length (S : Service_Entry_Type) return Natural is + begin + return S.Aliases_Length; + end Aliases_Length; + + ----------------- + -- Bind_Socket -- + ----------------- + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : constant C.int := Sin'Size / 8; + -- This assumes that Address.Family = Family_Inet??? + + begin + if Address.Family = Family_Inet6 then + raise Socket_Error with "IPv6 not supported"; + end if; + + Set_Family (Sin.Sin_Family, Address.Family); + Set_Address (Sin'Unchecked_Access, To_In_Addr (Address.Addr)); + Set_Port + (Sin'Unchecked_Access, + Short_To_Network (C.unsigned_short (Address.Port))); + + Res := C_Bind (C.int (Socket), Sin'Address, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Bind_Socket; + + ---------------------- + -- Check_For_Fd_Set -- + ---------------------- + + procedure Check_For_Fd_Set (Fd : Socket_Type) is + use SOSC; + + begin + -- On Windows, fd_set is a FD_SETSIZE array of socket ids: + -- no check required. Warnings suppressed because condition + -- is known at compile time. + + if Target_OS = Windows then + + return; + + -- On other platforms, fd_set is an FD_SETSIZE bitmap: check + -- that Fd is within range (otherwise behavior is undefined). + + elsif Fd < 0 or else Fd >= SOSC.FD_SETSIZE then + raise Constraint_Error + with "invalid value for socket set: " & Image (Fd); + end if; + end Check_For_Fd_Set; + + -------------------- + -- Check_Selector -- + -------------------- + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever) + is + E_Socket_Set : Socket_Set_Type; + begin + Check_Selector + (Selector, R_Socket_Set, W_Socket_Set, E_Socket_Set, Status, Timeout); + end Check_Selector; + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + E_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever) + is + Res : C.int; + Last : C.int; + RSig : Socket_Type := No_Socket; + TVal : aliased Timeval; + TPtr : Timeval_Access; + + begin + if not Is_Open (Selector) then + raise Program_Error with "closed selector"; + end if; + + Status := Completed; + + -- No timeout or Forever is indicated by a null timeval pointer + + if Timeout = Forever then + TPtr := null; + else + TVal := To_Timeval (Timeout); + TPtr := TVal'Unchecked_Access; + end if; + + -- Add read signalling socket, if present + + if not Selector.Is_Null then + RSig := Selector.R_Sig_Socket; + Set (R_Socket_Set, RSig); + end if; + + Last := C.int'Max (C.int'Max (C.int (R_Socket_Set.Last), + C.int (W_Socket_Set.Last)), + C.int (E_Socket_Set.Last)); + + -- Zero out fd_set for empty Socket_Set_Type objects + + Normalize_Empty_Socket_Set (R_Socket_Set); + Normalize_Empty_Socket_Set (W_Socket_Set); + Normalize_Empty_Socket_Set (E_Socket_Set); + + Res := + C_Select + (Last + 1, + R_Socket_Set.Set'Access, + W_Socket_Set.Set'Access, + E_Socket_Set.Set'Access, + TPtr); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + -- If Select was resumed because of read signalling socket, read this + -- data and remove socket from set. + + if RSig /= No_Socket and then Is_Set (R_Socket_Set, RSig) then + Clear (R_Socket_Set, RSig); + + Res := Signalling_Fds.Read (C.int (RSig)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Status := Aborted; + + elsif Res = 0 then + Status := Expired; + end if; + + -- Update socket sets in regard to their new contents + + Narrow (R_Socket_Set); + Narrow (W_Socket_Set); + Narrow (E_Socket_Set); + end Check_Selector; + + ----------- + -- Clear -- + ----------- + + procedure Clear + (Item : in out Socket_Set_Type; + Socket : Socket_Type) + is + Last : aliased C.int := C.int (Item.Last); + + begin + Check_For_Fd_Set (Socket); + + if Item.Last /= No_Socket then + Remove_Socket_From_Set (Item.Set'Access, C.int (Socket)); + Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); + Item.Last := Socket_Type (Last); + end if; + end Clear; + + -------------------- + -- Close_Selector -- + -------------------- + + procedure Close_Selector (Selector : in out Selector_Type) is + begin + -- Nothing to do if selector already in closed state + + if Selector.Is_Null or else not Is_Open (Selector) then + return; + end if; + + -- Close the signalling file descriptors used internally for the + -- implementation of Abort_Selector. + + Signalling_Fds.Close (C.int (Selector.R_Sig_Socket)); + Signalling_Fds.Close (C.int (Selector.W_Sig_Socket)); + + -- Reset R_Sig_Socket and W_Sig_Socket to No_Socket to ensure that any + -- (erroneous) subsequent attempt to use this selector properly fails. + + Selector.R_Sig_Socket := No_Socket; + Selector.W_Sig_Socket := No_Socket; + end Close_Selector; + + ------------------ + -- Close_Socket -- + ------------------ + + procedure Close_Socket (Socket : Socket_Type) is + Res : C.int; + + begin + Res := C_Close (C.int (Socket)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Close_Socket; + + -------------------- + -- Connect_Socket -- + -------------------- + + function Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) return C.int + is + Sin : aliased Sockaddr_In; + Len : constant C.int := Sin'Size / 8; + + begin + if Server.Family = Family_Inet6 then + raise Socket_Error with "IPv6 not supported"; + end if; + + Set_Family (Sin.Sin_Family, Server.Family); + Set_Address (Sin'Unchecked_Access, To_In_Addr (Server.Addr)); + Set_Port + (Sin'Unchecked_Access, + Short_To_Network (C.unsigned_short (Server.Port))); + + return C_Connect (C.int (Socket), Sin'Address, Len); + end Connect_Socket; + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type) + is + begin + if Connect_Socket (Socket, Server) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Connect_Socket; + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + Req : Request_Type; + -- Used to set Socket to non-blocking I/O + + Conn_Err : aliased Integer; + -- Error status of the socket after completion of select(2) + + Res : C.int; + Conn_Err_Size : aliased C.int := Conn_Err'Size / 8; + -- For getsockopt(2) call + + begin + if Selector /= null and then not Is_Open (Selector.all) then + raise Program_Error with "closed selector"; + end if; + + -- Set the socket to non-blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => True); + Control_Socket (Socket, Request => Req); + + -- Start operation (non-blocking), will return Failure with errno set + -- to EINPROGRESS. + + Res := Connect_Socket (Socket, Server); + if Res = Failure then + Conn_Err := Socket_Errno; + if Conn_Err /= SOSC.EINPROGRESS then + Raise_Socket_Error (Conn_Err); + end if; + end if; + + -- Wait for socket to become available for writing (unless the Timeout + -- is zero, in which case we consider that it has already expired, and + -- we do not need to wait at all). + + if Timeout = 0.0 then + Status := Expired; + + else + Wait_On_Socket + (Socket => Socket, + For_Read => False, + Timeout => Timeout, + Selector => Selector, + Status => Status); + end if; + + -- Check error condition (the asynchronous connect may have terminated + -- with an error, e.g. ECONNREFUSED) if select(2) completed. + + if Status = Completed then + Res := C_Getsockopt + (C.int (Socket), SOSC.SOL_SOCKET, SOSC.SO_ERROR, + Conn_Err'Address, Conn_Err_Size'Access); + + if Res /= 0 then + Conn_Err := Socket_Errno; + end if; + + else + Conn_Err := 0; + end if; + + -- Reset the socket to blocking I/O + + Req := (Name => Non_Blocking_IO, Enabled => False); + Control_Socket (Socket, Request => Req); + + -- Report error condition if any + + if Conn_Err /= 0 then + Raise_Socket_Error (Conn_Err); + end if; + end Connect_Socket; + + -------------------- + -- Control_Socket -- + -------------------- + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type) + is + Arg : aliased C.int; + Res : C.int; + + begin + case Request.Name is + when Non_Blocking_IO => + Arg := C.int (Boolean'Pos (Request.Enabled)); + + when N_Bytes_To_Read => + null; + end case; + + Res := Socket_Ioctl + (C.int (Socket), Requests (Request.Name), Arg'Unchecked_Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Request.Name is + when Non_Blocking_IO => + null; + + when N_Bytes_To_Read => + Request.Size := Natural (Arg); + end case; + end Control_Socket; + + ---------- + -- Copy -- + ---------- + + procedure Copy + (Source : Socket_Set_Type; + Target : out Socket_Set_Type) + is + begin + Target := Source; + end Copy; + + --------------------- + -- Create_Selector -- + --------------------- + + procedure Create_Selector (Selector : out Selector_Type) is + Two_Fds : aliased Fd_Pair; + Res : C.int; + + begin + if Is_Open (Selector) then + -- Raise exception to prevent socket descriptor leak + + raise Program_Error with "selector already open"; + end if; + + -- We open two signalling file descriptors. One of them is used to send + -- data to the other, which is included in a C_Select socket set. The + -- communication is used to force a call to C_Select to complete, and + -- the waiting task to resume its execution. + + Res := Signalling_Fds.Create (Two_Fds'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Selector.R_Sig_Socket := Socket_Type (Two_Fds (Read_End)); + Selector.W_Sig_Socket := Socket_Type (Two_Fds (Write_End)); + end Create_Selector; + + ------------------- + -- Create_Socket -- + ------------------- + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream) + is + Res : C.int; + + begin + Res := C_Socket (Families (Family), Modes (Mode), 0); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Socket := Socket_Type (Res); + end Create_Socket; + + ----------- + -- Empty -- + ----------- + + procedure Empty (Item : out Socket_Set_Type) is + begin + Reset_Socket_Set (Item.Set'Access); + Item.Last := No_Socket; + end Empty; + + -------------------- + -- Err_Code_Image -- + -------------------- + + function Err_Code_Image (E : Integer) return String is + Msg : String := E'Img & "] "; + begin + Msg (Msg'First) := '['; + return Msg; + end Err_Code_Image; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (X : in out Sockets_Library_Controller) is + pragma Unreferenced (X); + + begin + -- Finalization operation for the GNAT.Sockets package + + Thin.Finalize; + end Finalize; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + -- This is a dummy placeholder for an obsolete API. + -- The real finalization actions are in Initialize primitive operation + -- of Sockets_Library_Controller. + + null; + end Finalize; + + --------- + -- Get -- + --------- + + procedure Get + (Item : in out Socket_Set_Type; + Socket : out Socket_Type) + is + S : aliased C.int; + L : aliased C.int := C.int (Item.Last); + + begin + if Item.Last /= No_Socket then + Get_Socket_From_Set + (Item.Set'Access, Last => L'Access, Socket => S'Access); + Item.Last := Socket_Type (L); + Socket := Socket_Type (S); + else + Socket := No_Socket; + end if; + end Get; + + ----------------- + -- Get_Address -- + ----------------- + + function Get_Address + (Stream : not null Stream_Access) return Sock_Addr_Type + is + begin + if Stream.all in Datagram_Socket_Stream_Type then + return Datagram_Socket_Stream_Type (Stream.all).From; + else + return Get_Peer_Name (Stream_Socket_Stream_Type (Stream.all).Socket); + end if; + end Get_Address; + + ------------------------- + -- Get_Host_By_Address -- + ------------------------- + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) return Host_Entry_Type + is + pragma Unreferenced (Family); + + HA : aliased In_Addr := To_In_Addr (Address); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Hostent; + Err : aliased C.int; + + begin + Netdb_Lock; + + if C_Gethostbyaddr (HA'Address, HA'Size / 8, SOSC.AF_INET, + Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Netdb_Unlock; + Raise_Host_Error (Integer (Err), Image (Address)); + end if; + + begin + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + exception + when others => + Netdb_Unlock; + raise; + end; + end Get_Host_By_Address; + + ---------------------- + -- Get_Host_By_Name -- + ---------------------- + + function Get_Host_By_Name (Name : String) return Host_Entry_Type is + begin + -- If the given name actually is the string representation of + -- an IP address, use Get_Host_By_Address instead. + + if Is_IP_Address (Name) then + return Get_Host_By_Address (Inet_Addr (Name)); + end if; + + declare + HN : constant C.char_array := C.To_C (Name); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Hostent; + Err : aliased C.int; + + begin + Netdb_Lock; + + if C_Gethostbyname + (HN, Res'Access, Buf'Address, Buflen, Err'Access) /= 0 + then + Netdb_Unlock; + Raise_Host_Error (Integer (Err), Name); + end if; + + return H : constant Host_Entry_Type := + To_Host_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end; + end Get_Host_By_Name; + + ------------------- + -- Get_Peer_Name -- + ------------------- + + function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : Sock_Addr_Type (Family_Inet); + + begin + if C_Getpeername (C.int (Socket), Sin'Address, Len'Access) = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + To_Inet_Addr (Sin.Sin_Addr, Res.Addr); + Res.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + + return Res; + end Get_Peer_Name; + + ------------------------- + -- Get_Service_By_Name -- + ------------------------- + + function Get_Service_By_Name + (Name : String; + Protocol : String) return Service_Entry_Type + is + SN : constant C.char_array := C.To_C (Name); + SP : constant C.char_array := C.To_C (Protocol); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Servent; + + begin + Netdb_Lock; + + if C_Getservbyname (SN, SP, Res'Access, Buf'Address, Buflen) /= 0 then + Netdb_Unlock; + raise Service_Error with "Service not found"; + end if; + + -- Translate from the C format to the API format + + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end Get_Service_By_Name; + + ------------------------- + -- Get_Service_By_Port -- + ------------------------- + + function Get_Service_By_Port + (Port : Port_Type; + Protocol : String) return Service_Entry_Type + is + SP : constant C.char_array := C.To_C (Protocol); + Buflen : constant C.int := Netdb_Buffer_Size; + Buf : aliased C.char_array (1 .. Netdb_Buffer_Size); + Res : aliased Servent; + + begin + Netdb_Lock; + + if C_Getservbyport + (C.int (Short_To_Network (C.unsigned_short (Port))), SP, + Res'Access, Buf'Address, Buflen) /= 0 + then + Netdb_Unlock; + raise Service_Error with "Service not found"; + end if; + + -- Translate from the C format to the API format + + return S : constant Service_Entry_Type := + To_Service_Entry (Res'Unchecked_Access) + do + Netdb_Unlock; + end return; + end Get_Service_By_Port; + + --------------------- + -- Get_Socket_Name -- + --------------------- + + function Get_Socket_Name + (Socket : Socket_Type) return Sock_Addr_Type + is + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + Res : C.int; + Addr : Sock_Addr_Type := No_Sock_Addr; + + begin + Res := C_Getsockname (C.int (Socket), Sin'Address, Len'Access); + + if Res /= Failure then + To_Inet_Addr (Sin.Sin_Addr, Addr.Addr); + Addr.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + end if; + + return Addr; + end Get_Socket_Name; + + ----------------------- + -- Get_Socket_Option -- + ----------------------- + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name; + Optname : Interfaces.C.int := -1) return Option_Type + is + use SOSC; + use type C.unsigned_char; + + V8 : aliased Two_Ints; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + VT : aliased Timeval; + Len : aliased C.int; + Add : System.Address; + Res : C.int; + Opt : Option_Type (Name); + Onm : Interfaces.C.int; + + begin + if Name in Specific_Option_Name then + Onm := Options (Name); + + elsif Optname = -1 then + raise Socket_Error with "optname must be specified"; + + else + Onm := Optname; + end if; + + case Name is + when Multicast_Loop + | Multicast_TTL + | Receive_Packet_Info + => + Len := V1'Size / 8; + Add := V1'Address; + + when Broadcast + | Busy_Polling + | Error + | Generic_Option + | Keep_Alive + | Multicast_If + | No_Delay + | Receive_Buffer + | Reuse_Address + | Send_Buffer + => + Len := V4'Size / 8; + Add := V4'Address; + + when Receive_Timeout + | Send_Timeout + => + -- The standard argument for SO_RCVTIMEO and SO_SNDTIMEO is a + -- struct timeval, but on Windows it is a milliseconds count in + -- a DWORD. + + if Target_OS = Windows then + Len := V4'Size / 8; + Add := V4'Address; + + else + Len := VT'Size / 8; + Add := VT'Address; + end if; + + when Add_Membership + | Drop_Membership + | Linger + => + Len := V8'Size / 8; + Add := V8'Address; + end case; + + Res := + C_Getsockopt + (C.int (Socket), + Levels (Level), + Onm, + Add, Len'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + case Name is + when Generic_Option => + Opt.Optname := Onm; + Opt.Optval := V4; + + when Broadcast + | Keep_Alive + | No_Delay + | Reuse_Address + => + Opt.Enabled := (V4 /= 0); + + when Busy_Polling => + Opt.Microseconds := Natural (V4); + + when Linger => + Opt.Enabled := (V8 (V8'First) /= 0); + Opt.Seconds := Natural (V8 (V8'Last)); + + when Receive_Buffer + | Send_Buffer + => + Opt.Size := Natural (V4); + + when Error => + Opt.Error := Resolve_Error (Integer (V4)); + + when Add_Membership + | Drop_Membership + => + To_Inet_Addr (To_In_Addr (V8 (V8'First)), Opt.Multicast_Address); + To_Inet_Addr (To_In_Addr (V8 (V8'Last)), Opt.Local_Interface); + + when Multicast_If => + To_Inet_Addr (To_In_Addr (V4), Opt.Outgoing_If); + + when Multicast_TTL => + Opt.Time_To_Live := Integer (V1); + + when Multicast_Loop + | Receive_Packet_Info + => + Opt.Enabled := (V1 /= 0); + + when Receive_Timeout + | Send_Timeout + => + if Target_OS = Windows then + + -- Timeout is in milliseconds, actual value is 500 ms + + -- returned value (unless it is 0). + + if V4 = 0 then + Opt.Timeout := 0.0; + else + Opt.Timeout := Natural (V4) * 0.001 + 0.500; + end if; + + else + Opt.Timeout := To_Duration (VT); + end if; + end case; + + return Opt; + end Get_Socket_Option; + + --------------- + -- Host_Name -- + --------------- + + function Host_Name return String is + Name : aliased C.char_array (1 .. 64); + Res : C.int; + + begin + Res := C_Gethostname (Name'Address, Name'Length); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + return C.To_Ada (Name); + end Host_Name; + + ----------- + -- Image -- + ----------- + + function Image + (Val : Inet_Addr_VN_Type; + Hex : Boolean := False) return String + is + -- The largest Inet_Addr_Comp_Type image occurs with IPv4. It + -- has at most a length of 3 plus one '.' character. + + Buffer : String (1 .. 4 * Val'Length); + Length : Natural := 1; + Separator : Character; + + procedure Img10 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in decimal format + + procedure Img16 (V : Inet_Addr_Comp_Type); + -- Append to Buffer image of V in hexadecimal format + + ----------- + -- Img10 -- + ----------- + + procedure Img10 (V : Inet_Addr_Comp_Type) is + Img : constant String := V'Img; + Len : constant Natural := Img'Length - 1; + begin + Buffer (Length .. Length + Len - 1) := Img (2 .. Img'Last); + Length := Length + Len; + end Img10; + + ----------- + -- Img16 -- + ----------- + + procedure Img16 (V : Inet_Addr_Comp_Type) is + begin + Buffer (Length) := Hex_To_Char (Natural (V / 16) + 1); + Buffer (Length + 1) := Hex_To_Char (Natural (V mod 16) + 1); + Length := Length + 2; + end Img16; + + -- Start of processing for Image + + begin + Separator := (if Hex then ':' else '.'); + + for J in Val'Range loop + if Hex then + Img16 (Val (J)); + else + Img10 (Val (J)); + end if; + + if J /= Val'Last then + Buffer (Length) := Separator; + Length := Length + 1; + end if; + end loop; + + return Buffer (1 .. Length - 1); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Inet_Addr_Type) return String is + begin + if Value.Family = Family_Inet then + return Image (Inet_Addr_VN_Type (Value.Sin_V4), Hex => False); + else + return Image (Inet_Addr_VN_Type (Value.Sin_V6), Hex => True); + end if; + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Value : Sock_Addr_Type) return String is + Port : constant String := Value.Port'Img; + begin + return Image (Value.Addr) & ':' & Port (2 .. Port'Last); + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Socket : Socket_Type) return String is + begin + return Socket'Img; + end Image; + + ----------- + -- Image -- + ----------- + + function Image (Item : Socket_Set_Type) return String is + Socket_Set : Socket_Set_Type := Item; + + begin + declare + Last_Img : constant String := Socket_Set.Last'Img; + Buffer : String + (1 .. (Integer (Socket_Set.Last) + 1) * Last_Img'Length); + Index : Positive := 1; + Socket : Socket_Type; + + begin + while not Is_Empty (Socket_Set) loop + Get (Socket_Set, Socket); + + declare + Socket_Img : constant String := Socket'Img; + begin + Buffer (Index .. Index + Socket_Img'Length - 1) := Socket_Img; + Index := Index + Socket_Img'Length; + end; + end loop; + + return "[" & Last_Img & "]" & Buffer (1 .. Index - 1); + end; + end Image; + + --------------- + -- Inet_Addr -- + --------------- + + function Inet_Addr (Image : String) return Inet_Addr_Type is + use Interfaces.C; + + Img : aliased char_array := To_C (Image); + Addr : aliased C.int; + Res : C.int; + Result : Inet_Addr_Type; + + begin + -- Special case for an empty Image as on some platforms (e.g. Windows) + -- calling Inet_Addr("") will not return an error. + + if Image = "" then + Raise_Socket_Error (SOSC.EINVAL); + end if; + + Res := Inet_Pton (SOSC.AF_INET, Img'Address, Addr'Address); + + if Res < 0 then + Raise_Socket_Error (Socket_Errno); + + elsif Res = 0 then + Raise_Socket_Error (SOSC.EINVAL); + end if; + + To_Inet_Addr (To_In_Addr (Addr), Result); + return Result; + end Inet_Addr; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (X : in out Sockets_Library_Controller) is + pragma Unreferenced (X); + + begin + Thin.Initialize; + end Initialize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Process_Blocking_IO : Boolean) is + Expected : constant Boolean := not SOSC.Thread_Blocking_IO; + + begin + if Process_Blocking_IO /= Expected then + raise Socket_Error with + "incorrect Process_Blocking_IO setting, expected " & Expected'Img; + end if; + + -- This is a dummy placeholder for an obsolete API + + -- Real initialization actions are in Initialize primitive operation + -- of Sockets_Library_Controller. + + null; + end Initialize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + -- This is a dummy placeholder for an obsolete API + + -- Real initialization actions are in Initialize primitive operation + -- of Sockets_Library_Controller. + + null; + end Initialize; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty (Item : Socket_Set_Type) return Boolean is + begin + return Item.Last = No_Socket; + end Is_Empty; + + ------------------- + -- Is_IP_Address -- + ------------------- + + function Is_IP_Address (Name : String) return Boolean is + Dots : Natural := 0; + + begin + -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots, + -- and there must be at least one digit around each. + + for J in Name'Range loop + if Name (J) = '.' then + + -- Check that the dot is not in first or last position, and that + -- it is followed by a digit. Note that we already know that it is + -- preceded by a digit, or we would have returned earlier on. + + if J in Name'First + 1 .. Name'Last - 1 + and then Name (J + 1) in '0' .. '9' + then + Dots := Dots + 1; + + -- Definitely not a proper dotted quad + + else + return False; + end if; + + elsif Name (J) not in '0' .. '9' then + return False; + end if; + end loop; + + return Dots in 1 .. 3; + end Is_IP_Address; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (S : Selector_Type) return Boolean is + begin + if S.Is_Null then + return True; + + else + -- Either both controlling socket descriptors are valid (case of an + -- open selector) or neither (case of a closed selector). + + pragma Assert ((S.R_Sig_Socket /= No_Socket) + = + (S.W_Sig_Socket /= No_Socket)); + + return S.R_Sig_Socket /= No_Socket; + end if; + end Is_Open; + + ------------ + -- Is_Set -- + ------------ + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) return Boolean + is + begin + Check_For_Fd_Set (Socket); + + return Item.Last /= No_Socket + and then Socket <= Item.Last + and then Is_Socket_In_Set (Item.Set'Access, C.int (Socket)) /= 0; + end Is_Set; + + ------------------- + -- Listen_Socket -- + ------------------- + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Natural := 15) + is + Res : constant C.int := C_Listen (C.int (Socket), C.int (Length)); + begin + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Listen_Socket; + + ------------ + -- Narrow -- + ------------ + + procedure Narrow (Item : in out Socket_Set_Type) is + Last : aliased C.int := C.int (Item.Last); + begin + if Item.Last /= No_Socket then + Last_Socket_In_Set (Item.Set'Access, Last'Unchecked_Access); + Item.Last := Socket_Type (Last); + end if; + end Narrow; + + ---------------- + -- Netdb_Lock -- + ---------------- + + procedure Netdb_Lock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Lock; + end if; + end Netdb_Lock; + + ------------------ + -- Netdb_Unlock -- + ------------------ + + procedure Netdb_Unlock is + begin + if Need_Netdb_Lock then + System.Task_Lock.Unlock; + end if; + end Netdb_Unlock; + + -------------------------------- + -- Normalize_Empty_Socket_Set -- + -------------------------------- + + procedure Normalize_Empty_Socket_Set (S : in out Socket_Set_Type) is + begin + if S.Last = No_Socket then + Reset_Socket_Set (S.Set'Access); + end if; + end Normalize_Empty_Socket_Set; + + ------------------- + -- Official_Name -- + ------------------- + + function Official_Name (E : Host_Entry_Type) return String is + begin + return To_String (E.Official); + end Official_Name; + + ------------------- + -- Official_Name -- + ------------------- + + function Official_Name (S : Service_Entry_Type) return String is + begin + return To_String (S.Official); + end Official_Name; + + -------------------- + -- Wait_On_Socket -- + -------------------- + + procedure Wait_On_Socket + (Socket : Socket_Type; + For_Read : Boolean; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status) + is + type Local_Selector_Access is access Selector_Type; + for Local_Selector_Access'Storage_Size use Selector_Type'Size; + + S : Selector_Access; + -- Selector to use for waiting + + R_Fd_Set : Socket_Set_Type; + W_Fd_Set : Socket_Set_Type; + + begin + -- Create selector if not provided by the user + + if Selector = null then + declare + Local_S : constant Local_Selector_Access := new Selector_Type; + begin + S := Local_S.all'Unchecked_Access; + Create_Selector (S.all); + end; + + else + S := Selector.all'Access; + end if; + + if For_Read then + Set (R_Fd_Set, Socket); + else + Set (W_Fd_Set, Socket); + end if; + + Check_Selector (S.all, R_Fd_Set, W_Fd_Set, Status, Timeout); + + if Selector = null then + Close_Selector (S.all); + end if; + end Wait_On_Socket; + + ----------------- + -- Port_Number -- + ----------------- + + function Port_Number (S : Service_Entry_Type) return Port_Type is + begin + return S.Port; + end Port_Number; + + ------------------- + -- Protocol_Name -- + ------------------- + + function Protocol_Name (S : Service_Entry_Type) return String is + begin + return To_String (S.Protocol); + end Protocol_Name; + + ---------------------- + -- Raise_Host_Error -- + ---------------------- + + procedure Raise_Host_Error (H_Error : Integer; Name : String) is + function Dedot (Value : String) return String is + (if Value /= "" and then Value (Value'Last) = '.' then + Value (Value'First .. Value'Last - 1) + else + Value); + -- Removes dot at the end of error message + + begin + raise Host_Error with + Err_Code_Image (H_Error) + & Dedot (Host_Error_Messages.Host_Error_Message (H_Error)) + & ": " & Name; + end Raise_Host_Error; + + ------------------------ + -- Raise_Socket_Error -- + ------------------------ + + procedure Raise_Socket_Error (Error : Integer) is + begin + raise Socket_Error with + Err_Code_Image (Error) & Socket_Error_Message (Error); + end Raise_Socket_Error; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Datagram_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + Receive_Socket + (Stream.Socket, + Item, + Last, + Stream.From); + end Read; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Stream_Socket_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + First : Ada.Streams.Stream_Element_Offset := Item'First; + Index : Ada.Streams.Stream_Element_Offset := First - 1; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + loop + Receive_Socket (Stream.Socket, Item (First .. Max), Index); + Last := Index; + + -- Exit when all or zero data received. Zero means that the socket + -- peer is closed. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + end Read; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : C.int; + + begin + Res := + C_Recv (C.int (Socket), Item'Address, Item'Length, To_Int (Flags)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Last_Index (First => Item'First, Count => size_t (Res)); + end Receive_Socket; + + -------------------- + -- Receive_Socket -- + -------------------- + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + From : out Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : C.int; + Sin : aliased Sockaddr_In; + Len : aliased C.int := Sin'Size / 8; + + begin + Res := + C_Recvfrom + (C.int (Socket), + Item'Address, + Item'Length, + To_Int (Flags), + Sin'Address, + Len'Access); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Last_Index (First => Item'First, Count => size_t (Res)); + + To_Inet_Addr (Sin.Sin_Addr, From.Addr); + From.Port := Port_Type (Network_To_Short (Sin.Sin_Port)); + end Receive_Socket; + + -------------------- + -- Receive_Vector -- + -------------------- + + procedure Receive_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : ssize_t; + + Msg : Msghdr := + (Msg_Name => System.Null_Address, + Msg_Namelen => 0, + Msg_Iov => Vector'Address, + + -- recvmsg(2) returns EMSGSIZE on Linux (and probably on other + -- platforms) when the supplied vector is longer than IOV_MAX, + -- so use minimum of the two lengths. + + Msg_Iovlen => SOSC.Msg_Iovlen_T'Min + (Vector'Length, SOSC.IOV_MAX), + + Msg_Control => System.Null_Address, + Msg_Controllen => 0, + Msg_Flags => 0); + + begin + Res := + C_Recvmsg + (C.int (Socket), + Msg'Address, + To_Int (Flags)); + + if Res = ssize_t (Failure) then + Raise_Socket_Error (Socket_Errno); + end if; + + Count := Ada.Streams.Stream_Element_Count (Res); + end Receive_Vector; + + ------------------- + -- Resolve_Error -- + ------------------- + + function Resolve_Error + (Error_Value : Integer; + From_Errno : Boolean := True) return Error_Type + is + use GNAT.Sockets.SOSC; + + begin + if not From_Errno then + case Error_Value is + when SOSC.HOST_NOT_FOUND => return Unknown_Host; + when SOSC.TRY_AGAIN => return Host_Name_Lookup_Failure; + when SOSC.NO_RECOVERY => return Non_Recoverable_Error; + when SOSC.NO_DATA => return Unknown_Server_Error; + when others => return Cannot_Resolve_Error; + end case; + end if; + + -- Special case: EAGAIN may be the same value as EWOULDBLOCK, so we + -- can't include it in the case statement below. + + pragma Warnings (Off); + -- Condition "EAGAIN /= EWOULDBLOCK" is known at compile time + + if EAGAIN /= EWOULDBLOCK and then Error_Value = EAGAIN then + return Resource_Temporarily_Unavailable; + end if; + + -- This is not a case statement because if a particular error + -- number constant is not defined, s-oscons-tmplt.c defines + -- it to -1. If multiple constants are not defined, they + -- would each be -1 and result in a "duplicate value in case" error. + -- + -- But we have to leave warnings off because the compiler is also + -- smart enough to note that when two errnos have the same value, + -- the second if condition is useless. + if Error_Value = ENOERROR then + return Success; + elsif Error_Value = EACCES then + return Permission_Denied; + elsif Error_Value = EADDRINUSE then + return Address_Already_In_Use; + elsif Error_Value = EADDRNOTAVAIL then + return Cannot_Assign_Requested_Address; + elsif Error_Value = EAFNOSUPPORT then + return Address_Family_Not_Supported_By_Protocol; + elsif Error_Value = EALREADY then + return Operation_Already_In_Progress; + elsif Error_Value = EBADF then + return Bad_File_Descriptor; + elsif Error_Value = ECONNABORTED then + return Software_Caused_Connection_Abort; + elsif Error_Value = ECONNREFUSED then + return Connection_Refused; + elsif Error_Value = ECONNRESET then + return Connection_Reset_By_Peer; + elsif Error_Value = EDESTADDRREQ then + return Destination_Address_Required; + elsif Error_Value = EFAULT then + return Bad_Address; + elsif Error_Value = EHOSTDOWN then + return Host_Is_Down; + elsif Error_Value = EHOSTUNREACH then + return No_Route_To_Host; + elsif Error_Value = EINPROGRESS then + return Operation_Now_In_Progress; + elsif Error_Value = EINTR then + return Interrupted_System_Call; + elsif Error_Value = EINVAL then + return Invalid_Argument; + elsif Error_Value = EIO then + return Input_Output_Error; + elsif Error_Value = EISCONN then + return Transport_Endpoint_Already_Connected; + elsif Error_Value = ELOOP then + return Too_Many_Symbolic_Links; + elsif Error_Value = EMFILE then + return Too_Many_Open_Files; + elsif Error_Value = EMSGSIZE then + return Message_Too_Long; + elsif Error_Value = ENAMETOOLONG then + return File_Name_Too_Long; + elsif Error_Value = ENETDOWN then + return Network_Is_Down; + elsif Error_Value = ENETRESET then + return Network_Dropped_Connection_Because_Of_Reset; + elsif Error_Value = ENETUNREACH then + return Network_Is_Unreachable; + elsif Error_Value = ENOBUFS then + return No_Buffer_Space_Available; + elsif Error_Value = ENOPROTOOPT then + return Protocol_Not_Available; + elsif Error_Value = ENOTCONN then + return Transport_Endpoint_Not_Connected; + elsif Error_Value = ENOTSOCK then + return Socket_Operation_On_Non_Socket; + elsif Error_Value = EOPNOTSUPP then + return Operation_Not_Supported; + elsif Error_Value = EPFNOSUPPORT then + return Protocol_Family_Not_Supported; + elsif Error_Value = EPIPE then + return Broken_Pipe; + elsif Error_Value = EPROTONOSUPPORT then + return Protocol_Not_Supported; + elsif Error_Value = EPROTOTYPE then + return Protocol_Wrong_Type_For_Socket; + elsif Error_Value = ESHUTDOWN then + return Cannot_Send_After_Transport_Endpoint_Shutdown; + elsif Error_Value = ESOCKTNOSUPPORT then + return Socket_Type_Not_Supported; + elsif Error_Value = ETIMEDOUT then + return Connection_Timed_Out; + elsif Error_Value = ETOOMANYREFS then + return Too_Many_References; + elsif Error_Value = EWOULDBLOCK then + return Resource_Temporarily_Unavailable; + else + return Cannot_Resolve_Error; + end if; + pragma Warnings (On); + + end Resolve_Error; + + ----------------------- + -- Resolve_Exception -- + ----------------------- + + function Resolve_Exception + (Occurrence : Exception_Occurrence) return Error_Type + is + Id : constant Exception_Id := Exception_Identity (Occurrence); + Msg : constant String := Exception_Message (Occurrence); + First : Natural; + Last : Natural; + Val : Integer; + + begin + First := Msg'First; + while First <= Msg'Last + and then Msg (First) not in '0' .. '9' + loop + First := First + 1; + end loop; + + if First > Msg'Last then + return Cannot_Resolve_Error; + end if; + + Last := First; + while Last < Msg'Last + and then Msg (Last + 1) in '0' .. '9' + loop + Last := Last + 1; + end loop; + + Val := Integer'Value (Msg (First .. Last)); + + if Id = Socket_Error_Id then + return Resolve_Error (Val); + + elsif Id = Host_Error_Id then + return Resolve_Error (Val, False); + + else + return Cannot_Resolve_Error; + end if; + end Resolve_Exception; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag) + is + begin + Send_Socket (Socket, Item, Last, To => null, Flags => Flags); + end Send_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + begin + Send_Socket + (Socket, Item, Last, To => To'Unrestricted_Access, Flags => Flags); + end Send_Socket; + + ----------------- + -- Send_Socket -- + ----------------- + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : access Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag) + is + Res : C.int; + + Sin : aliased Sockaddr_In; + C_To : System.Address; + Len : C.int; + + begin + if To /= null then + Set_Family (Sin.Sin_Family, To.Family); + Set_Address (Sin'Unchecked_Access, To_In_Addr (To.Addr)); + Set_Port + (Sin'Unchecked_Access, + Short_To_Network (C.unsigned_short (To.Port))); + C_To := Sin'Address; + Len := Sin'Size / 8; + + else + C_To := System.Null_Address; + Len := 0; + end if; + + Res := C_Sendto + (C.int (Socket), + Item'Address, + Item'Length, + Set_Forced_Flags (To_Int (Flags)), + C_To, + Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + + Last := Last_Index (First => Item'First, Count => size_t (Res)); + end Send_Socket; + + ----------------- + -- Send_Vector -- + ----------------- + + procedure Send_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag) + is + use SOSC; + use Interfaces.C; + + Res : ssize_t; + Iov_Count : SOSC.Msg_Iovlen_T; + This_Iov_Count : SOSC.Msg_Iovlen_T; + Msg : Msghdr; + + begin + Count := 0; + Iov_Count := 0; + while Iov_Count < Vector'Length loop + + pragma Warnings (Off); + -- Following test may be compile time known on some targets + + This_Iov_Count := + (if Vector'Length - Iov_Count > SOSC.IOV_MAX + then SOSC.IOV_MAX + else Vector'Length - Iov_Count); + + pragma Warnings (On); + + Msg := + (Msg_Name => System.Null_Address, + Msg_Namelen => 0, + Msg_Iov => Vector + (Vector'First + Integer (Iov_Count))'Address, + Msg_Iovlen => This_Iov_Count, + Msg_Control => System.Null_Address, + Msg_Controllen => 0, + Msg_Flags => 0); + + Res := + C_Sendmsg + (C.int (Socket), + Msg'Address, + Set_Forced_Flags (To_Int (Flags))); + + if Res = ssize_t (Failure) then + Raise_Socket_Error (Socket_Errno); + end if; + + Count := Count + Ada.Streams.Stream_Element_Count (Res); + Iov_Count := Iov_Count + This_Iov_Count; + end loop; + end Send_Vector; + + --------- + -- Set -- + --------- + + procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type) is + begin + Check_For_Fd_Set (Socket); + + if Item.Last = No_Socket then + + -- Uninitialized socket set, make sure it is properly zeroed out + + Reset_Socket_Set (Item.Set'Access); + Item.Last := Socket; + + elsif Item.Last < Socket then + Item.Last := Socket; + end if; + + Insert_Socket_In_Set (Item.Set'Access, C.int (Socket)); + end Set; + + ----------------------- + -- Set_Close_On_Exec -- + ----------------------- + + procedure Set_Close_On_Exec + (Socket : Socket_Type; + Close_On_Exec : Boolean; + Status : out Boolean) + is + function C_Set_Close_On_Exec + (Socket : Socket_Type; Close_On_Exec : C.int) return C.int; + pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); + begin + Status := C_Set_Close_On_Exec (Socket, Boolean'Pos (Close_On_Exec)) = 0; + end Set_Close_On_Exec; + + ---------------------- + -- Set_Forced_Flags -- + ---------------------- + + function Set_Forced_Flags (F : C.int) return C.int is + use type C.unsigned; + function To_unsigned is + new Ada.Unchecked_Conversion (C.int, C.unsigned); + function To_int is + new Ada.Unchecked_Conversion (C.unsigned, C.int); + begin + return To_int (To_unsigned (F) or SOSC.MSG_Forced_Flags); + end Set_Forced_Flags; + + ----------------------- + -- Set_Socket_Option -- + ----------------------- + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type) + is + use SOSC; + + V8 : aliased Two_Ints; + V4 : aliased C.int; + V1 : aliased C.unsigned_char; + VT : aliased Timeval; + Len : C.int; + Add : System.Address := Null_Address; + Res : C.int; + Onm : C.int; + + begin + case Option.Name is + when Generic_Option => + V4 := Option.Optval; + Len := V4'Size / 8; + Add := V4'Address; + + when Broadcast + | Keep_Alive + | No_Delay + | Reuse_Address + => + V4 := C.int (Boolean'Pos (Option.Enabled)); + Len := V4'Size / 8; + Add := V4'Address; + + when Busy_Polling => + V4 := C.int (Option.Microseconds); + Len := V4'Size / 8; + Add := V4'Address; + + when Linger => + V8 (V8'First) := C.int (Boolean'Pos (Option.Enabled)); + V8 (V8'Last) := C.int (Option.Seconds); + Len := V8'Size / 8; + Add := V8'Address; + + when Receive_Buffer + | Send_Buffer + => + V4 := C.int (Option.Size); + Len := V4'Size / 8; + Add := V4'Address; + + when Error => + V4 := C.int (Boolean'Pos (True)); + Len := V4'Size / 8; + Add := V4'Address; + + when Add_Membership + | Drop_Membership + => + V8 (V8'First) := To_Int (To_In_Addr (Option.Multicast_Address)); + V8 (V8'Last) := To_Int (To_In_Addr (Option.Local_Interface)); + Len := V8'Size / 8; + Add := V8'Address; + + when Multicast_If => + V4 := To_Int (To_In_Addr (Option.Outgoing_If)); + Len := V4'Size / 8; + Add := V4'Address; + + when Multicast_TTL => + V1 := C.unsigned_char (Option.Time_To_Live); + Len := V1'Size / 8; + Add := V1'Address; + + when Multicast_Loop + | Receive_Packet_Info + => + V1 := C.unsigned_char (Boolean'Pos (Option.Enabled)); + Len := V1'Size / 8; + Add := V1'Address; + + when Receive_Timeout + | Send_Timeout + => + if Target_OS = Windows then + + -- On Windows, the timeout is a DWORD in milliseconds, and + -- the actual timeout is 500 ms + the given value (unless it + -- is 0). + + V4 := C.int (Option.Timeout / 0.001); + + if V4 > 500 then + V4 := V4 - 500; + + elsif V4 > 0 then + V4 := 1; + end if; + + Len := V4'Size / 8; + Add := V4'Address; + + else + VT := To_Timeval (Option.Timeout); + Len := VT'Size / 8; + Add := VT'Address; + end if; + end case; + + if Option.Name in Specific_Option_Name then + Onm := Options (Option.Name); + + elsif Option.Optname = -1 then + raise Socket_Error with "optname must be specified"; + + else + Onm := Option.Optname; + end if; + + Res := C_Setsockopt + (C.int (Socket), + Levels (Level), + Onm, + Add, Len); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Set_Socket_Option; + + ---------------------- + -- Short_To_Network -- + ---------------------- + + function Short_To_Network (S : C.unsigned_short) return C.unsigned_short is + use type C.unsigned_short; + + begin + -- Big-endian case. No conversion needed. On these platforms, htons() + -- defaults to a null procedure. + + if Default_Bit_Order = High_Order_First then + return S; + + -- Little-endian case. We must swap the high and low bytes of this + -- short to make the port number network compliant. + + else + return (S / 256) + (S mod 256) * 256; + end if; + end Short_To_Network; + + --------------------- + -- Shutdown_Socket -- + --------------------- + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write) + is + Res : C.int; + + begin + Res := C_Shutdown (C.int (Socket), Shutmodes (How)); + + if Res = Failure then + Raise_Socket_Error (Socket_Errno); + end if; + end Shutdown_Socket; + + ------------ + -- Stream -- + ------------ + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) return Stream_Access + is + S : Datagram_Socket_Stream_Access; + + begin + S := new Datagram_Socket_Stream_Type; + S.Socket := Socket; + S.To := Send_To; + S.From := Get_Socket_Name (Socket); + return Stream_Access (S); + end Stream; + + ------------ + -- Stream -- + ------------ + + function Stream (Socket : Socket_Type) return Stream_Access is + S : Stream_Socket_Stream_Access; + begin + S := new Stream_Socket_Stream_Type; + S.Socket := Socket; + return Stream_Access (S); + end Stream; + + ------------ + -- To_Ada -- + ------------ + + function To_Ada (Fd : Integer) return Socket_Type is + begin + return Socket_Type (Fd); + end To_Ada; + + ---------- + -- To_C -- + ---------- + + function To_C (Socket : Socket_Type) return Integer is + begin + return Integer (Socket); + end To_C; + + ----------------- + -- To_Duration -- + ----------------- + + function To_Duration (Val : Timeval) return Timeval_Duration is + begin + return Natural (Val.Tv_Sec) * 1.0 + Natural (Val.Tv_Usec) * 1.0E-6; + end To_Duration; + + ------------------- + -- To_Host_Entry -- + ------------------- + + function To_Host_Entry (E : Hostent_Access) return Host_Entry_Type is + use type C.size_t; + + Aliases_Count, Addresses_Count : Natural; + + -- H_Length is not used because it is currently only ever set to 4, as + -- we only handle the case of H_Addrtype being AF_INET. + + begin + if Hostent_H_Addrtype (E) /= SOSC.AF_INET then + Raise_Socket_Error (SOSC.EPFNOSUPPORT); + end if; + + Aliases_Count := 0; + while Hostent_H_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; + end loop; + + Addresses_Count := 0; + while Hostent_H_Addr (E, C.int (Addresses_Count)) /= Null_Address loop + Addresses_Count := Addresses_Count + 1; + end loop; + + return Result : Host_Entry_Type + (Aliases_Length => Aliases_Count, + Addresses_Length => Addresses_Count) + do + Result.Official := To_Name (Value (Hostent_H_Name (E))); + + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Hostent_H_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + for J in Result.Addresses'Range loop + declare + Addr : In_Addr; + + -- Hostent_H_Addr (E, ) may return an address that is + -- not correctly aligned for In_Addr, so we need to use + -- an intermediate copy operation on a type with an alignment + -- of 1 to recover the value. + + subtype Addr_Buf_T is C.char_array (1 .. Addr'Size / 8); + Unaligned_Addr : Addr_Buf_T; + for Unaligned_Addr'Address + use Hostent_H_Addr (E, C.int (J - Result.Addresses'First)); + pragma Import (Ada, Unaligned_Addr); + + Aligned_Addr : Addr_Buf_T; + for Aligned_Addr'Address use Addr'Address; + pragma Import (Ada, Aligned_Addr); + + begin + Aligned_Addr := Unaligned_Addr; + To_Inet_Addr (Addr, Result.Addresses (J)); + end; + end loop; + end return; + end To_Host_Entry; + + ---------------- + -- To_In_Addr -- + ---------------- + + function To_In_Addr (Addr : Inet_Addr_Type) return In_Addr is + begin + if Addr.Family = Family_Inet then + return (S_B1 => C.unsigned_char (Addr.Sin_V4 (1)), + S_B2 => C.unsigned_char (Addr.Sin_V4 (2)), + S_B3 => C.unsigned_char (Addr.Sin_V4 (3)), + S_B4 => C.unsigned_char (Addr.Sin_V4 (4))); + end if; + + raise Socket_Error with "IPv6 not supported"; + end To_In_Addr; + + ------------------ + -- To_Inet_Addr -- + ------------------ + + procedure To_Inet_Addr + (Addr : In_Addr; + Result : out Inet_Addr_Type) is + begin + Result.Sin_V4 (1) := Inet_Addr_Comp_Type (Addr.S_B1); + Result.Sin_V4 (2) := Inet_Addr_Comp_Type (Addr.S_B2); + Result.Sin_V4 (3) := Inet_Addr_Comp_Type (Addr.S_B3); + Result.Sin_V4 (4) := Inet_Addr_Comp_Type (Addr.S_B4); + end To_Inet_Addr; + + ------------ + -- To_Int -- + ------------ + + function To_Int (F : Request_Flag_Type) return C.int + is + Current : Request_Flag_Type := F; + Result : C.int := 0; + + begin + for J in Flags'Range loop + exit when Current = 0; + + if Current mod 2 /= 0 then + if Flags (J) = -1 then + Raise_Socket_Error (SOSC.EOPNOTSUPP); + end if; + + Result := Result + Flags (J); + end if; + + Current := Current / 2; + end loop; + + return Result; + end To_Int; + + ------------- + -- To_Name -- + ------------- + + function To_Name (N : String) return Name_Type is + begin + return Name_Type'(N'Length, N); + end To_Name; + + ---------------------- + -- To_Service_Entry -- + ---------------------- + + function To_Service_Entry (E : Servent_Access) return Service_Entry_Type is + Aliases_Count : Natural; + + begin + Aliases_Count := 0; + while Servent_S_Alias (E, C.int (Aliases_Count)) /= Null_Address loop + Aliases_Count := Aliases_Count + 1; + end loop; + + return Result : Service_Entry_Type (Aliases_Length => Aliases_Count) do + Result.Official := To_Name (Value (Servent_S_Name (E))); + + for J in Result.Aliases'Range loop + Result.Aliases (J) := + To_Name (Value (Servent_S_Alias + (E, C.int (J - Result.Aliases'First)))); + end loop; + + Result.Protocol := To_Name (Value (Servent_S_Proto (E))); + Result.Port := + Port_Type (Network_To_Short (Servent_S_Port (E))); + end return; + end To_Service_Entry; + + --------------- + -- To_String -- + --------------- + + function To_String (HN : Name_Type) return String is + begin + return HN.Name (1 .. HN.Length); + end To_String; + + ---------------- + -- To_Timeval -- + ---------------- + + function To_Timeval (Val : Timeval_Duration) return Timeval is + S : time_t; + uS : suseconds_t; + + begin + -- If zero, set result as zero (otherwise it gets rounded down to -1) + + if Val = 0.0 then + S := 0; + uS := 0; + + -- Normal case where we do round down + + else + S := time_t (Val - 0.5); + uS := suseconds_t (1_000_000 * (Val - Selector_Duration (S))); + end if; + + return (S, uS); + end To_Timeval; + + ----------- + -- Value -- + ----------- + + function Value (S : System.Address) return String is + Str : String (1 .. Positive'Last); + for Str'Address use S; + pragma Import (Ada, Str); + + Terminator : Positive := Str'First; + + begin + while Str (Terminator) /= ASCII.NUL loop + Terminator := Terminator + 1; + end loop; + + return Str (1 .. Terminator - 1); + end Value; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Datagram_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + Last : Stream_Element_Offset; + + begin + Send_Socket + (Stream.Socket, + Item, + Last, + Stream.To); + + -- It is an error if not all of the data has been sent + + if Last /= Item'Last then + Raise_Socket_Error (Socket_Errno); + end if; + end Write; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Stream_Socket_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + First : Ada.Streams.Stream_Element_Offset; + Index : Ada.Streams.Stream_Element_Offset; + Max : constant Ada.Streams.Stream_Element_Offset := Item'Last; + + begin + First := Item'First; + Index := First - 1; + while First <= Max loop + Send_Socket (Stream.Socket, Item (First .. Max), Index, null); + + -- Exit when all or zero data sent. Zero means that the socket has + -- been closed by peer. + + exit when Index < First or else Index = Max; + + First := Index + 1; + end loop; + + -- For an empty array, we have First > Max, and hence Index >= Max (no + -- error, the loop above is never executed). After a successful send, + -- Index = Max. The only remaining case, Index < Max, is therefore + -- always an actual send failure. + + if Index < Max then + Raise_Socket_Error (Socket_Errno); + end if; + end Write; + + Sockets_Library_Controller_Object : Sockets_Library_Controller; + pragma Unreferenced (Sockets_Library_Controller_Object); + -- The elaboration and finalization of this object perform the required + -- initialization and cleanup actions for the sockets library. + +end GNAT.Sockets; diff --git a/gcc/ada/libgnat/g-socket.ads b/gcc/ada/libgnat/g-socket.ads new file mode 100644 index 0000000..06d7a85 --- /dev/null +++ b/gcc/ada/libgnat/g-socket.ads @@ -0,0 +1,1288 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface to the sockets communication facility +-- provided on many operating systems. This is implemented on the following +-- platforms: + +-- All native ports, with restrictions as follows + +-- Multicast is available only on systems which provide support for this +-- feature, so it is not available if Multicast is not supported, or not +-- installed. + +-- VxWorks cross ports fully implement this package + +-- This package is not yet implemented on LynxOS or other cross ports + +with Ada.Exceptions; +with Ada.Streams; +with Ada.Unchecked_Deallocation; + +with Interfaces.C; + +with System.OS_Constants; +with System.Storage_Elements; + +package GNAT.Sockets is + + -- Sockets are designed to provide a consistent communication facility + -- between applications. This package provides an Ada binding to the + -- de-facto standard BSD sockets API. The documentation below covers + -- only the specific binding provided by this package. It assumes that + -- the reader is already familiar with general network programming and + -- sockets usage. A useful reference on this matter is W. Richard Stevens' + -- "UNIX Network Programming: The Sockets Networking API" + -- (ISBN: 0131411551). + + -- GNAT.Sockets has been designed with several ideas in mind + + -- This is a system independent interface. Therefore, we try as much as + -- possible to mask system incompatibilities. Some functionalities are not + -- available because there are not fully supported on some systems. + + -- This is a thick binding. For instance, a major effort has been done to + -- avoid using memory addresses or untyped ints. We preferred to define + -- streams and enumeration types. Errors are not returned as returned + -- values but as exceptions. + + -- This package provides a POSIX-compliant interface (between two + -- different implementations of the same routine, we adopt the one closest + -- to the POSIX specification). For instance, using select(), the + -- notification of an asynchronous connect failure is delivered in the + -- write socket set (POSIX) instead of the exception socket set (NT). + + -- The example below demonstrates various features of GNAT.Sockets: + + -- with GNAT.Sockets; use GNAT.Sockets; + + -- with Ada.Text_IO; + -- with Ada.Exceptions; use Ada.Exceptions; + + -- procedure PingPong is + + -- Group : constant String := "239.255.128.128"; + -- -- Multicast group: administratively scoped IP address + + -- task Pong is + -- entry Start; + -- entry Stop; + -- end Pong; + + -- task body Pong is + -- Address : Sock_Addr_Type; + -- Server : Socket_Type; + -- Socket : Socket_Type; + -- Channel : Stream_Access; + + -- begin + -- -- Get an Internet address of a host (here the local host name). + -- -- Note that a host can have several addresses. Here we get + -- -- the first one which is supposed to be the official one. + + -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); + + -- -- Get a socket address that is an Internet address and a port + + -- Address.Port := 5876; + + -- -- The first step is to create a socket. Once created, this + -- -- socket must be associated to with an address. Usually only a + -- -- server (Pong here) needs to bind an address explicitly. Most + -- -- of the time clients can skip this step because the socket + -- -- routines will bind an arbitrary address to an unbound socket. + + -- Create_Socket (Server); + + -- -- Allow reuse of local addresses + + -- Set_Socket_Option + -- (Server, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- Bind_Socket (Server, Address); + + -- -- A server marks a socket as willing to receive connect events + + -- Listen_Socket (Server); + + -- -- Once a server calls Listen_Socket, incoming connects events + -- -- can be accepted. The returned Socket is a new socket that + -- -- represents the server side of the connection. Server remains + -- -- available to receive further connections. + + -- accept Start; + + -- Accept_Socket (Server, Socket, Address); + + -- -- Return a stream associated to the connected socket + + -- Channel := Stream (Socket); + + -- -- Force Pong to block + + -- delay 0.2; + + -- -- Receive and print message from client Ping + + -- declare + -- Message : String := String'Input (Channel); + + -- begin + -- Ada.Text_IO.Put_Line (Message); + + -- -- Send same message back to client Ping + + -- String'Output (Channel, Message); + -- end; + + -- Close_Socket (Server); + -- Close_Socket (Socket); + + -- -- Part of the multicast example + + -- -- Create a datagram socket to send connectionless, unreliable + -- -- messages of a fixed maximum length. + + -- Create_Socket (Socket, Family_Inet, Socket_Datagram); + + -- -- Allow reuse of local addresses + + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- -- Controls the live time of the datagram to avoid it being + -- -- looped forever due to routing errors. Routers decrement + -- -- the TTL of every datagram as it traverses from one network + -- -- to another and when its value reaches 0 the packet is + -- -- dropped. Default is 1. + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_TTL, 1)); + + -- -- Want the data you send to be looped back to your host + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_Loop, True)); + + -- -- If this socket is intended to receive messages, bind it + -- -- to a given socket address. + + -- Address.Addr := Any_Inet_Addr; + -- Address.Port := 55505; + + -- Bind_Socket (Socket, Address); + + -- -- Join a multicast group + + -- -- Portability note: On Windows, this option may be set only + -- -- on a bound socket. + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); + + -- -- If this socket is intended to send messages, provide the + -- -- receiver socket address. + + -- Address.Addr := Inet_Addr (Group); + -- Address.Port := 55506; + + -- Channel := Stream (Socket, Address); + + -- -- Receive and print message from client Ping + + -- declare + -- Message : String := String'Input (Channel); + + -- begin + -- -- Get the address of the sender + + -- Address := Get_Address (Channel); + -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); + + -- -- Send same message back to client Ping + + -- String'Output (Channel, Message); + -- end; + + -- Close_Socket (Socket); + + -- accept Stop; + + -- exception when E : others => + -- Ada.Text_IO.Put_Line + -- (Exception_Name (E) & ": " & Exception_Message (E)); + -- end Pong; + + -- task Ping is + -- entry Start; + -- entry Stop; + -- end Ping; + + -- task body Ping is + -- Address : Sock_Addr_Type; + -- Socket : Socket_Type; + -- Channel : Stream_Access; + + -- begin + -- accept Start; + + -- -- See comments in Ping section for the first steps + + -- Address.Addr := Addresses (Get_Host_By_Name (Host_Name), 1); + -- Address.Port := 5876; + -- Create_Socket (Socket); + + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- -- Force Ping to block + + -- delay 0.2; + + -- -- If the client's socket is not bound, Connect_Socket will + -- -- bind to an unused address. The client uses Connect_Socket to + -- -- create a logical connection between the client's socket and + -- -- a server's socket returned by Accept_Socket. + + -- Connect_Socket (Socket, Address); + + -- Channel := Stream (Socket); + + -- -- Send message to server Pong + + -- String'Output (Channel, "Hello world"); + + -- -- Force Ping to block + + -- delay 0.2; + + -- -- Receive and print message from server Pong + + -- Ada.Text_IO.Put_Line (String'Input (Channel)); + -- Close_Socket (Socket); + + -- -- Part of multicast example. Code similar to Pong's one + + -- Create_Socket (Socket, Family_Inet, Socket_Datagram); + + -- Set_Socket_Option + -- (Socket, + -- Socket_Level, + -- (Reuse_Address, True)); + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_TTL, 1)); + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Multicast_Loop, True)); + + -- Address.Addr := Any_Inet_Addr; + -- Address.Port := 55506; + + -- Bind_Socket (Socket, Address); + + -- Set_Socket_Option + -- (Socket, + -- IP_Protocol_For_IP_Level, + -- (Add_Membership, Inet_Addr (Group), Any_Inet_Addr)); + + -- Address.Addr := Inet_Addr (Group); + -- Address.Port := 55505; + + -- Channel := Stream (Socket, Address); + + -- -- Send message to server Pong + + -- String'Output (Channel, "Hello world"); + + -- -- Receive and print message from server Pong + + -- declare + -- Message : String := String'Input (Channel); + + -- begin + -- Address := Get_Address (Channel); + -- Ada.Text_IO.Put_Line (Message & " from " & Image (Address)); + -- end; + + -- Close_Socket (Socket); + + -- accept Stop; + + -- exception when E : others => + -- Ada.Text_IO.Put_Line + -- (Exception_Name (E) & ": " & Exception_Message (E)); + -- end Ping; + + -- begin + -- Initialize; + -- Ping.Start; + -- Pong.Start; + -- Ping.Stop; + -- Pong.Stop; + -- Finalize; + -- end PingPong; + + package SOSC renames System.OS_Constants; + -- Renaming used to provide short-hand notations throughout the sockets + -- binding. Note that System.OS_Constants is an internal unit, and the + -- entities declared therein are not meant for direct access by users, + -- including through this renaming. + + use type Interfaces.C.int; + -- Need visibility on "-" operator so that we can write -1 + + procedure Initialize; + pragma Obsolescent + (Entity => Initialize, + Message => "explicit initialization is no longer required"); + -- Initialize must be called before using any other socket routines. + -- Note that this operation is a no-op on UNIX platforms, but applications + -- should make sure to call it if portability is expected: some platforms + -- (such as Windows) require initialization before any socket operation. + -- This is now a no-op (initialization and finalization are done + -- automatically). + + procedure Initialize (Process_Blocking_IO : Boolean); + pragma Obsolescent + (Entity => Initialize, + Message => "passing a parameter to Initialize is no longer supported"); + -- Previous versions of GNAT.Sockets used to require the user to indicate + -- whether socket I/O was process- or thread-blocking on the platform. + -- This property is now determined automatically when the run-time library + -- is built. The old version of Initialize, taking a parameter, is kept + -- for compatibility reasons, but this interface is obsolete (and if the + -- value given is wrong, an exception will be raised at run time). + -- This is now a no-op (initialization and finalization are done + -- automatically). + + procedure Finalize; + pragma Obsolescent + (Entity => Finalize, + Message => "explicit finalization is no longer required"); + -- After Finalize is called it is not possible to use any routines + -- exported in by this package. This procedure is idempotent. + -- This is now a no-op (initialization and finalization are done + -- automatically). + + type Socket_Type is private; + -- Sockets are used to implement a reliable bi-directional point-to-point, + -- stream-based connections between hosts. No_Socket provides a special + -- value to denote uninitialized sockets. + + No_Socket : constant Socket_Type; + + type Selector_Type is limited private; + type Selector_Access is access all Selector_Type; + -- Selector objects are used to wait for i/o events to occur on sockets + + Null_Selector : constant Selector_Type; + -- The Null_Selector can be used in place of a normal selector without + -- having to call Create_Selector if the use of Abort_Selector is not + -- required. + + -- Timeval_Duration is a subtype of Standard.Duration because the full + -- range of Standard.Duration cannot be represented in the equivalent C + -- structure (struct timeval). Moreover, negative values are not allowed + -- to avoid system incompatibilities. + + Immediate : constant Duration := 0.0; + + Forever : constant Duration := + Duration'Min (Duration'Last, 1.0 * SOSC.MAX_tv_sec); + -- Largest possible Duration that is also a valid value for struct timeval + + subtype Timeval_Duration is Duration range Immediate .. Forever; + + subtype Selector_Duration is Timeval_Duration; + -- Timeout value for selector operations + + type Selector_Status is (Completed, Expired, Aborted); + -- Completion status of a selector operation, indicated as follows: + -- Complete: one of the expected events occurred + -- Expired: no event occurred before the expiration of the timeout + -- Aborted: an external action cancelled the wait operation before + -- any event occurred. + + Socket_Error : exception; + -- There is only one exception in this package to deal with an error during + -- a socket routine. Once raised, its message contains a string describing + -- the error code. + + function Image (Socket : Socket_Type) return String; + -- Return a printable string for Socket + + function To_Ada (Fd : Integer) return Socket_Type with Inline; + -- Convert a file descriptor to Socket_Type. This is useful when a socket + -- file descriptor is obtained from an external library call. + + function To_C (Socket : Socket_Type) return Integer with Inline; + -- Return a file descriptor to be used by external subprograms. This is + -- useful for C functions that are not yet interfaced in this package. + + type Family_Type is (Family_Inet, Family_Inet6); + -- Address family (or protocol family) identifies the communication domain + -- and groups protocols with similar address formats. + + type Mode_Type is (Socket_Stream, Socket_Datagram); + -- Stream sockets provide connection-oriented byte streams. Datagram + -- sockets support unreliable connectionless message based communication. + + type Shutmode_Type is (Shut_Read, Shut_Write, Shut_Read_Write); + -- When a process closes a socket, the policy is to retain any data queued + -- until either a delivery or a timeout expiration (in this case, the data + -- are discarded). A finer control is available through shutdown. With + -- Shut_Read, no more data can be received from the socket. With_Write, no + -- more data can be transmitted. Neither transmission nor reception can be + -- performed with Shut_Read_Write. + + type Port_Type is range 0 .. 16#ffff#; + -- TCP/UDP port number + + Any_Port : constant Port_Type; + -- All ports + + No_Port : constant Port_Type; + -- Uninitialized port number + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is private; + -- An Internet address depends on an address family (IPv4 contains 4 octets + -- and IPv6 contains 16 octets). Any_Inet_Addr is a special value treated + -- like a wildcard enabling all addresses. No_Inet_Addr provides a special + -- value to denote uninitialized inet addresses. + + Any_Inet_Addr : constant Inet_Addr_Type; + No_Inet_Addr : constant Inet_Addr_Type; + Broadcast_Inet_Addr : constant Inet_Addr_Type; + Loopback_Inet_Addr : constant Inet_Addr_Type; + + -- Useful constants for IPv4 multicast addresses + + Unspecified_Group_Inet_Addr : constant Inet_Addr_Type; + All_Hosts_Group_Inet_Addr : constant Inet_Addr_Type; + All_Routers_Group_Inet_Addr : constant Inet_Addr_Type; + + type Sock_Addr_Type (Family : Family_Type := Family_Inet) is record + Addr : Inet_Addr_Type (Family); + Port : Port_Type; + end record; + pragma No_Component_Reordering (Sock_Addr_Type); + -- Socket addresses fully define a socket connection with protocol family, + -- an Internet address and a port. No_Sock_Addr provides a special value + -- for uninitialized socket addresses. + + No_Sock_Addr : constant Sock_Addr_Type; + + function Image (Value : Inet_Addr_Type) return String; + -- Return an image of an Internet address. IPv4 notation consists in 4 + -- octets in decimal format separated by dots. IPv6 notation consists in + -- 16 octets in hexadecimal format separated by colons (and possibly + -- dots). + + function Image (Value : Sock_Addr_Type) return String; + -- Return inet address image and port image separated by a colon + + function Inet_Addr (Image : String) return Inet_Addr_Type; + -- Convert address image from numbers-and-dots notation into an + -- inet address. + + -- Host entries provide complete information on a given host: the official + -- name, an array of alternative names or aliases and array of network + -- addresses. + + type Host_Entry_Type + (Aliases_Length, Addresses_Length : Natural) is private; + + function Official_Name (E : Host_Entry_Type) return String; + -- Return official name in host entry + + function Aliases_Length (E : Host_Entry_Type) return Natural; + -- Return number of aliases in host entry + + function Addresses_Length (E : Host_Entry_Type) return Natural; + -- Return number of addresses in host entry + + function Aliases + (E : Host_Entry_Type; + N : Positive := 1) return String; + -- Return N'th aliases in host entry. The first index is 1 + + function Addresses + (E : Host_Entry_Type; + N : Positive := 1) return Inet_Addr_Type; + -- Return N'th addresses in host entry. The first index is 1 + + Host_Error : exception; + -- Exception raised by the two following procedures. Once raised, its + -- message contains a string describing the error code. This exception is + -- raised when an host entry cannot be retrieved. + + function Get_Host_By_Address + (Address : Inet_Addr_Type; + Family : Family_Type := Family_Inet) return Host_Entry_Type; + -- Return host entry structure for the given Inet address. Note that no + -- result will be returned if there is no mapping of this IP address to a + -- host name in the system tables (host database, DNS or otherwise). + + function Get_Host_By_Name + (Name : String) return Host_Entry_Type; + -- Return host entry structure for the given host name. Here name is + -- either a host name, or an IP address. If Name is an IP address, this + -- is equivalent to Get_Host_By_Address (Inet_Addr (Name)). + + function Host_Name return String; + -- Return the name of the current host + + type Service_Entry_Type (Aliases_Length : Natural) is private; + -- Service entries provide complete information on a given service: the + -- official name, an array of alternative names or aliases and the port + -- number. + + function Official_Name (S : Service_Entry_Type) return String; + -- Return official name in service entry + + function Port_Number (S : Service_Entry_Type) return Port_Type; + -- Return port number in service entry + + function Protocol_Name (S : Service_Entry_Type) return String; + -- Return Protocol in service entry (usually UDP or TCP) + + function Aliases_Length (S : Service_Entry_Type) return Natural; + -- Return number of aliases in service entry + + function Aliases + (S : Service_Entry_Type; + N : Positive := 1) return String; + -- Return N'th aliases in service entry (the first index is 1) + + function Get_Service_By_Name + (Name : String; + Protocol : String) return Service_Entry_Type; + -- Return service entry structure for the given service name + + function Get_Service_By_Port + (Port : Port_Type; + Protocol : String) return Service_Entry_Type; + -- Return service entry structure for the given service port number + + Service_Error : exception; + -- Comment required ??? + + -- Errors are described by an enumeration type. There is only one exception + -- Socket_Error in this package to deal with an error during a socket + -- routine. Once raised, its message contains the error code between + -- brackets and a string describing the error code. + + -- The name of the enumeration constant documents the error condition + -- Note that on some platforms, a single error value is used for both + -- EWOULDBLOCK and EAGAIN. Both errors are therefore always reported as + -- Resource_Temporarily_Unavailable. + + type Error_Type is + (Success, + Permission_Denied, + Address_Already_In_Use, + Cannot_Assign_Requested_Address, + Address_Family_Not_Supported_By_Protocol, + Operation_Already_In_Progress, + Bad_File_Descriptor, + Software_Caused_Connection_Abort, + Connection_Refused, + Connection_Reset_By_Peer, + Destination_Address_Required, + Bad_Address, + Host_Is_Down, + No_Route_To_Host, + Operation_Now_In_Progress, + Interrupted_System_Call, + Invalid_Argument, + Input_Output_Error, + Transport_Endpoint_Already_Connected, + Too_Many_Symbolic_Links, + Too_Many_Open_Files, + Message_Too_Long, + File_Name_Too_Long, + Network_Is_Down, + Network_Dropped_Connection_Because_Of_Reset, + Network_Is_Unreachable, + No_Buffer_Space_Available, + Protocol_Not_Available, + Transport_Endpoint_Not_Connected, + Socket_Operation_On_Non_Socket, + Operation_Not_Supported, + Protocol_Family_Not_Supported, + Protocol_Not_Supported, + Protocol_Wrong_Type_For_Socket, + Cannot_Send_After_Transport_Endpoint_Shutdown, + Socket_Type_Not_Supported, + Connection_Timed_Out, + Too_Many_References, + Resource_Temporarily_Unavailable, + Broken_Pipe, + Unknown_Host, + Host_Name_Lookup_Failure, + Non_Recoverable_Error, + Unknown_Server_Error, + Cannot_Resolve_Error); + + -- Get_Socket_Options and Set_Socket_Options manipulate options associated + -- with a socket. Options may exist at multiple protocol levels in the + -- communication stack. Socket_Level is the uppermost socket level. + + type Level_Type is + (Socket_Level, + IP_Protocol_For_IP_Level, + IP_Protocol_For_UDP_Level, + IP_Protocol_For_TCP_Level); + + -- There are several options available to manipulate sockets. Each option + -- has a name and several values available. Most of the time, the value is + -- a boolean to enable or disable this option. + + type Option_Name is + (Generic_Option, + Keep_Alive, -- Enable sending of keep-alive messages + Reuse_Address, -- Allow bind to reuse local address + Broadcast, -- Enable datagram sockets to recv/send broadcasts + Send_Buffer, -- Set/get the maximum socket send buffer in bytes + Receive_Buffer, -- Set/get the maximum socket recv buffer in bytes + Linger, -- Shutdown wait for msg to be sent or timeout occur + Error, -- Get and clear the pending socket error + No_Delay, -- Do not delay send to coalesce data (TCP_NODELAY) + Add_Membership, -- Join a multicast group + Drop_Membership, -- Leave a multicast group + Multicast_If, -- Set default out interface for multicast packets + Multicast_TTL, -- Set the time-to-live of sent multicast packets + Multicast_Loop, -- Sent multicast packets are looped to local socket + Receive_Packet_Info, -- Receive low level packet info as ancillary data + Send_Timeout, -- Set timeout value for output + Receive_Timeout, -- Set timeout value for input + Busy_Polling); -- Set busy polling mode + subtype Specific_Option_Name is + Option_Name range Keep_Alive .. Option_Name'Last; + + type Option_Type (Name : Option_Name := Keep_Alive) is record + case Name is + when Generic_Option => + Optname : Interfaces.C.int := -1; + Optval : Interfaces.C.int; + + when Keep_Alive | + Reuse_Address | + Broadcast | + Linger | + No_Delay | + Receive_Packet_Info | + Multicast_Loop => + Enabled : Boolean; + + case Name is + when Linger => + Seconds : Natural; + when others => + null; + end case; + + when Busy_Polling => + Microseconds : Natural; + + when Send_Buffer | + Receive_Buffer => + Size : Natural; + + when Error => + Error : Error_Type; + + when Add_Membership | + Drop_Membership => + Multicast_Address : Inet_Addr_Type; + Local_Interface : Inet_Addr_Type; + + when Multicast_If => + Outgoing_If : Inet_Addr_Type; + + when Multicast_TTL => + Time_To_Live : Natural; + + when Send_Timeout | + Receive_Timeout => + Timeout : Timeval_Duration; + + end case; + end record; + + -- There are several controls available to manipulate sockets. Each option + -- has a name and several values available. These controls differ from the + -- socket options in that they are not specific to sockets but are + -- available for any device. + + type Request_Name is + (Non_Blocking_IO, -- Cause a caller not to wait on blocking operations + N_Bytes_To_Read); -- Return the number of bytes available to read + + type Request_Type (Name : Request_Name := Non_Blocking_IO) is record + case Name is + when Non_Blocking_IO => + Enabled : Boolean; + + when N_Bytes_To_Read => + Size : Natural; + + end case; + end record; + + -- A request flag allows specification of the type of message transmissions + -- or receptions. A request flag can be combination of zero or more + -- predefined request flags. + + type Request_Flag_Type is private; + + No_Request_Flag : constant Request_Flag_Type; + -- This flag corresponds to the normal execution of an operation + + Process_Out_Of_Band_Data : constant Request_Flag_Type; + -- This flag requests that the receive or send function operates on + -- out-of-band data when the socket supports this notion (e.g. + -- Socket_Stream). + + Peek_At_Incoming_Data : constant Request_Flag_Type; + -- This flag causes the receive operation to return data from the beginning + -- of the receive queue without removing that data from the queue. A + -- subsequent receive call will return the same data. + + Wait_For_A_Full_Reception : constant Request_Flag_Type; + -- This flag requests that the operation block until the full request is + -- satisfied. However, the call may still return less data than requested + -- if a signal is caught, an error or disconnect occurs, or the next data + -- to be received is of a different type than that returned. Note that + -- this flag depends on support in the underlying sockets implementation, + -- and is not supported under Windows. + + Send_End_Of_Record : constant Request_Flag_Type; + -- This flag indicates that the entire message has been sent and so this + -- terminates the record. + + function "+" (L, R : Request_Flag_Type) return Request_Flag_Type; + -- Combine flag L with flag R + + type Stream_Element_Reference is access all Ada.Streams.Stream_Element; + + type Vector_Element is record + Base : Stream_Element_Reference; + Length : Interfaces.C.size_t; + end record; + + type Vector_Type is array (Integer range <>) of Vector_Element; + + procedure Create_Socket + (Socket : out Socket_Type; + Family : Family_Type := Family_Inet; + Mode : Mode_Type := Socket_Stream); + -- Create an endpoint for communication. Raises Socket_Error on error + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type); + -- Extracts the first connection request on the queue of pending + -- connections, creates a new connected socket with mostly the same + -- properties as Server, and allocates a new socket. The returned Address + -- is filled in with the address of the connection. Raises Socket_Error on + -- error. Note: if Server is a non-blocking socket, whether or not this + -- aspect is inherited by Socket is platform-dependent. + + procedure Accept_Socket + (Server : Socket_Type; + Socket : out Socket_Type; + Address : out Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Accept a new connection on Server using Accept_Socket, waiting no longer + -- than the given timeout duration. Status is set to indicate whether the + -- operation completed successfully, timed out, or was aborted. If Selector + -- is not null, the designated selector is used to wait for the socket to + -- become available, else a private selector object is created by this + -- procedure and destroyed before it returns. + + procedure Bind_Socket + (Socket : Socket_Type; + Address : Sock_Addr_Type); + -- Once a socket is created, assign a local address to it. Raise + -- Socket_Error on error. + + procedure Close_Socket (Socket : Socket_Type); + -- Close a socket and more specifically a non-connected socket + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type); + -- Make a connection to another socket which has the address of Server. + -- Raises Socket_Error on error. + + procedure Connect_Socket + (Socket : Socket_Type; + Server : Sock_Addr_Type; + Timeout : Selector_Duration; + Selector : access Selector_Type := null; + Status : out Selector_Status); + -- Connect Socket to the given Server address using Connect_Socket, waiting + -- no longer than the given timeout duration. Status is set to indicate + -- whether the operation completed successfully, timed out, or was aborted. + -- If Selector is not null, the designated selector is used to wait for the + -- socket to become available, else a private selector object is created + -- by this procedure and destroyed before it returns. If Timeout is 0.0, + -- no attempt is made to detect whether the connection has succeeded; it + -- is up to the user to determine this using Check_Selector later on. + + procedure Control_Socket + (Socket : Socket_Type; + Request : in out Request_Type); + -- Obtain or set parameter values that control the socket. This control + -- differs from the socket options in that they are not specific to sockets + -- but are available for any device. + + function Get_Peer_Name (Socket : Socket_Type) return Sock_Addr_Type; + -- Return the peer or remote socket address of a socket. Raise + -- Socket_Error on error. + + function Get_Socket_Name (Socket : Socket_Type) return Sock_Addr_Type; + -- Return the local or current socket address of a socket. Return + -- No_Sock_Addr on error (e.g. socket closed or not locally bound). + + function Get_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Name : Option_Name; + Optname : Interfaces.C.int := -1) return Option_Type; + -- Get the options associated with a socket. Raises Socket_Error on error. + -- Optname identifies specific option when Name is Generic_Option. + + procedure Listen_Socket + (Socket : Socket_Type; + Length : Natural := 15); + -- To accept connections, a socket is first created with Create_Socket, + -- a willingness to accept incoming connections and a queue Length for + -- incoming connections are specified. Raise Socket_Error on error. + -- The queue length of 15 is an example value that should be appropriate + -- in usual cases. It can be adjusted according to each application's + -- particular requirements. + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag); + -- Receive message from Socket. Last is the index value such that Item + -- (Last) is the last character assigned. Note that Last is set to + -- Item'First - 1 when the socket has been closed by peer. This is not + -- an error, and no exception is raised in this case unless Item'First + -- is Stream_Element_Offset'First, in which case Constraint_Error is + -- raised. Flags allows control of the reception. Raise Socket_Error on + -- error. + + procedure Receive_Socket + (Socket : Socket_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + From : out Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag); + -- Receive message from Socket. If Socket is not connection-oriented, the + -- source address From of the message is filled in. Last is the index + -- value such that Item (Last) is the last character assigned. Flags + -- allows control of the reception. Raises Socket_Error on error. + + procedure Receive_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag); + -- Receive data from a socket and scatter it into the set of vector + -- elements Vector. Count is set to the count of received stream elements. + -- Flags allow control over reception. + + function Resolve_Exception + (Occurrence : Ada.Exceptions.Exception_Occurrence) return Error_Type; + -- When Socket_Error or Host_Error are raised, the exception message + -- contains the error code between brackets and a string describing the + -- error code. Resolve_Error extracts the error code from an exception + -- message and translate it into an enumeration value. + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : access Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag); + pragma Inline (Send_Socket); + -- Transmit a message over a socket. For a datagram socket, the address + -- is given by To.all. For a stream socket, To must be null. Last + -- is the index value such that Item (Last) is the last character + -- sent. Note that Last is set to Item'First - 1 if the socket has been + -- closed by the peer (unless Item'First is Stream_Element_Offset'First, + -- in which case Constraint_Error is raised instead). This is not an error, + -- and Socket_Error is not raised in that case. Flags allows control of the + -- transmission. Raises exception Socket_Error on error. Note: this + -- subprogram is inlined because it is also used to implement the two + -- variants below. + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + Flags : Request_Flag_Type := No_Request_Flag); + -- Transmit a message over a socket. Upon return, Last is set to the index + -- within Item of the last element transmitted. Flags allows control of + -- the transmission. Raises Socket_Error on any detected error condition. + + procedure Send_Socket + (Socket : Socket_Type; + Item : Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset; + To : Sock_Addr_Type; + Flags : Request_Flag_Type := No_Request_Flag); + -- Transmit a message over a datagram socket. The destination address is + -- To. Flags allows control of the transmission. Raises Socket_Error on + -- error. + + procedure Send_Vector + (Socket : Socket_Type; + Vector : Vector_Type; + Count : out Ada.Streams.Stream_Element_Count; + Flags : Request_Flag_Type := No_Request_Flag); + -- Transmit data gathered from the set of vector elements Vector to a + -- socket. Count is set to the count of transmitted stream elements. Flags + -- allow control over transmission. + + procedure Set_Close_On_Exec + (Socket : Socket_Type; + Close_On_Exec : Boolean; + Status : out Boolean); + -- When Close_On_Exec is True, mark Socket to be closed automatically when + -- a new program is executed by the calling process (i.e. prevent Socket + -- from being inherited by child processes). When Close_On_Exec is False, + -- mark Socket to not be closed on exec (i.e. allow it to be inherited). + -- Status is False if the operation could not be performed, or is not + -- supported on the target platform. + + procedure Set_Socket_Option + (Socket : Socket_Type; + Level : Level_Type := Socket_Level; + Option : Option_Type); + -- Manipulate socket options. Raises Socket_Error on error + + procedure Shutdown_Socket + (Socket : Socket_Type; + How : Shutmode_Type := Shut_Read_Write); + -- Shutdown a connected socket. If How is Shut_Read further receives will + -- be disallowed. If How is Shut_Write further sends will be disallowed. + -- If How is Shut_Read_Write further sends and receives will be disallowed. + + type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class; + -- Same interface as Ada.Streams.Stream_IO + + function Stream (Socket : Socket_Type) return Stream_Access; + -- Create a stream associated with a connected stream-based socket. + -- Note: keep in mind that the default stream attributes for composite + -- types perform separate Read/Write operations for each component, + -- recursively. If performance is an issue, you may want to consider + -- introducing a buffering stage. + + function Stream + (Socket : Socket_Type; + Send_To : Sock_Addr_Type) return Stream_Access; + -- Create a stream associated with an already bound datagram-based socket. + -- Send_To is the destination address to which messages are being sent. + + function Get_Address + (Stream : not null Stream_Access) return Sock_Addr_Type; + -- Return the socket address from which the last message was received + + procedure Free is new Ada.Unchecked_Deallocation + (Ada.Streams.Root_Stream_Type'Class, Stream_Access); + -- Destroy a stream created by one of the Stream functions above, releasing + -- the corresponding resources. The user is responsible for calling this + -- subprogram when the stream is not needed anymore. + + type Socket_Set_Type is limited private; + -- This type allows manipulation of sets of sockets. It allows waiting + -- for events on multiple endpoints at one time. This type has default + -- initialization, and the default value is the empty set. + -- + -- Note: This type used to contain a pointer to dynamically allocated + -- storage, but this is not the case anymore, and no special precautions + -- are required to avoid memory leaks. + + procedure Clear (Item : in out Socket_Set_Type; Socket : Socket_Type); + -- Remove Socket from Item + + procedure Copy (Source : Socket_Set_Type; Target : out Socket_Set_Type); + -- Copy Source into Target as Socket_Set_Type is limited private + + procedure Empty (Item : out Socket_Set_Type); + -- Remove all Sockets from Item + + procedure Get (Item : in out Socket_Set_Type; Socket : out Socket_Type); + -- Extract a Socket from socket set Item. Socket is set to + -- No_Socket when the set is empty. + + function Is_Empty (Item : Socket_Set_Type) return Boolean; + -- Return True iff Item is empty + + function Is_Set + (Item : Socket_Set_Type; + Socket : Socket_Type) return Boolean; + -- Return True iff Socket is present in Item + + procedure Set (Item : in out Socket_Set_Type; Socket : Socket_Type); + -- Insert Socket into Item + + function Image (Item : Socket_Set_Type) return String; + -- Return a printable image of Item, for debugging purposes + + -- The select(2) system call waits for events to occur on any of a set of + -- file descriptors. Usually, three independent sets of descriptors are + -- watched (read, write and exception). A timeout gives an upper bound + -- on the amount of time elapsed before select returns. This function + -- blocks until an event occurs. On some platforms, the select(2) system + -- can block the full process (not just the calling thread). + -- + -- Check_Selector provides the very same behavior. The only difference is + -- that it does not watch for exception events. Note that on some platforms + -- it is kept process blocking on purpose. The timeout parameter allows the + -- user to have the behavior he wants. Abort_Selector allows the safe + -- abort of a blocked Check_Selector call. A special socket is opened by + -- Create_Selector and included in each call to Check_Selector. + -- + -- Abort_Selector causes an event to occur on this descriptor in order to + -- unblock Check_Selector. Note that each call to Abort_Selector will cause + -- exactly one call to Check_Selector to return with Aborted status. The + -- special socket created by Create_Selector is closed when Close_Selector + -- is called. + -- + -- A typical case where it is useful to abort a Check_Selector operation is + -- the situation where a change to the monitored sockets set must be made. + + procedure Create_Selector (Selector : out Selector_Type); + -- Initialize (open) a new selector + + procedure Close_Selector (Selector : in out Selector_Type); + -- Close Selector and all internal descriptors associated; deallocate any + -- associated resources. This subprogram may be called only when there is + -- no other task still using Selector (i.e. still executing Check_Selector + -- or Abort_Selector on this Selector). Has no effect if Selector is + -- already closed. + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever); + -- Return when one Socket in R_Socket_Set has some data to be read or if + -- one Socket in W_Socket_Set is ready to transmit some data. In these + -- cases Status is set to Completed and sockets that are ready are set in + -- R_Socket_Set or W_Socket_Set. Status is set to Expired if no socket was + -- ready after a Timeout expiration. Status is set to Aborted if an abort + -- signal has been received while checking socket status. + -- + -- Note that two different Socket_Set_Type objects must be passed as + -- R_Socket_Set and W_Socket_Set (even if they denote the same set of + -- Sockets), or some event may be lost. Also keep in mind that this + -- procedure modifies the passed socket sets to indicate which sockets + -- actually had events upon return. The socket set therefore has to + -- be reset by the caller for further calls. + -- + -- Socket_Error is raised when the select(2) system call returns an error + -- condition, or when a read error occurs on the signalling socket used for + -- the implementation of Abort_Selector. + + procedure Check_Selector + (Selector : Selector_Type; + R_Socket_Set : in out Socket_Set_Type; + W_Socket_Set : in out Socket_Set_Type; + E_Socket_Set : in out Socket_Set_Type; + Status : out Selector_Status; + Timeout : Selector_Duration := Forever); + -- This refined version of Check_Selector allows watching for exception + -- events (i.e. notifications of out-of-band transmission and reception). + -- As above, all of R_Socket_Set, W_Socket_Set and E_Socket_Set must be + -- different objects. + + procedure Abort_Selector (Selector : Selector_Type); + -- Send an abort signal to the selector. The Selector may not be the + -- Null_Selector. + + type Fd_Set is private; + -- ??? This type must not be used directly, it needs to be visible because + -- it is used in the visible part of GNAT.Sockets.Thin_Common. This is + -- really an inversion of abstraction. The private part of GNAT.Sockets + -- needs to have visibility on this type, but since Thin_Common is a child + -- of Sockets, the type can't be declared there. The correct fix would + -- be to move the thin sockets binding outside of GNAT.Sockets altogether, + -- e.g. by renaming it to GNAT.Sockets_Thin. + +private + + type Socket_Type is new Integer; + No_Socket : constant Socket_Type := -1; + + -- A selector is either a null selector, which is always "open" and can + -- never be aborted, or a regular selector, which is created "closed", + -- becomes "open" when Create_Selector is called, and "closed" again when + -- Close_Selector is called. + + type Selector_Type (Is_Null : Boolean := False) is limited record + case Is_Null is + when True => + null; + + when False => + R_Sig_Socket : Socket_Type := No_Socket; + W_Sig_Socket : Socket_Type := No_Socket; + -- Signalling sockets used to abort a select operation + end case; + end record; + + pragma Volatile (Selector_Type); + + Null_Selector : constant Selector_Type := (Is_Null => True); + + type Fd_Set is + new System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_fd_set); + for Fd_Set'Alignment use Interfaces.C.long'Alignment; + -- Set conservative alignment so that our Fd_Sets are always adequately + -- aligned for the underlying data type (which is implementation defined + -- and may be an array of C long integers). + + type Fd_Set_Access is access all Fd_Set; + pragma Convention (C, Fd_Set_Access); + No_Fd_Set_Access : constant Fd_Set_Access := null; + + type Socket_Set_Type is record + Last : Socket_Type := No_Socket; + -- Highest socket in set. Last = No_Socket denotes an empty set (which + -- is the default initial value). + + Set : aliased Fd_Set; + -- Underlying socket set. Note that the contents of this component is + -- undefined if Last = No_Socket. + end record; + + subtype Inet_Addr_Comp_Type is Natural range 0 .. 255; + -- Octet for Internet address + + type Inet_Addr_VN_Type is array (Natural range <>) of Inet_Addr_Comp_Type; + + subtype Inet_Addr_V4_Type is Inet_Addr_VN_Type (1 .. 4); + subtype Inet_Addr_V6_Type is Inet_Addr_VN_Type (1 .. 16); + + type Inet_Addr_Type (Family : Family_Type := Family_Inet) is record + case Family is + when Family_Inet => + Sin_V4 : Inet_Addr_V4_Type := (others => 0); + + when Family_Inet6 => + Sin_V6 : Inet_Addr_V6_Type := (others => 0); + end case; + end record; + + Any_Port : constant Port_Type := 0; + No_Port : constant Port_Type := 0; + + Any_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (others => 0)); + No_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (others => 0)); + Broadcast_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (others => 255)); + Loopback_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (127, 0, 0, 1)); + + Unspecified_Group_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (224, 0, 0, 0)); + All_Hosts_Group_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (224, 0, 0, 1)); + All_Routers_Group_Inet_Addr : constant Inet_Addr_Type := + (Family_Inet, (224, 0, 0, 2)); + + No_Sock_Addr : constant Sock_Addr_Type := (Family_Inet, No_Inet_Addr, 0); + + Max_Name_Length : constant := 64; + -- The constant MAXHOSTNAMELEN is usually set to 64 + + subtype Name_Index is Natural range 1 .. Max_Name_Length; + + type Name_Type (Length : Name_Index := Max_Name_Length) is record + Name : String (1 .. Length); + end record; + -- We need fixed strings to avoid access types in host entry type + + type Name_Array is array (Natural range <>) of Name_Type; + type Inet_Addr_Array is array (Natural range <>) of Inet_Addr_Type; + + type Host_Entry_Type (Aliases_Length, Addresses_Length : Natural) is record + Official : Name_Type; + Aliases : Name_Array (1 .. Aliases_Length); + Addresses : Inet_Addr_Array (1 .. Addresses_Length); + end record; + + type Service_Entry_Type (Aliases_Length : Natural) is record + Official : Name_Type; + Port : Port_Type; + Protocol : Name_Type; + Aliases : Name_Array (1 .. Aliases_Length); + end record; + + type Request_Flag_Type is mod 2 ** 8; + No_Request_Flag : constant Request_Flag_Type := 0; + Process_Out_Of_Band_Data : constant Request_Flag_Type := 1; + Peek_At_Incoming_Data : constant Request_Flag_Type := 2; + Wait_For_A_Full_Reception : constant Request_Flag_Type := 4; + Send_End_Of_Record : constant Request_Flag_Type := 8; + +end GNAT.Sockets; diff --git a/gcc/ada/libgnat/g-socthi-dummy.adb b/gcc/ada/libgnat/g-socthi-dummy.adb new file mode 100644 index 0000000..4ee3dfd --- /dev/null +++ b/gcc/ada/libgnat/g-socthi-dummy.adb @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-socthi-dummy.ads b/gcc/ada/libgnat/g-socthi-dummy.ads new file mode 100644 index 0000000..53c49f4 --- /dev/null +++ b/gcc/ada/libgnat/g-socthi-dummy.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets.Thin is + pragma Unimplemented_Unit; +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-mingw.adb b/gcc/ada/libgnat/g-socthi-mingw.adb new file mode 100644 index 0000000..e0cde85 --- /dev/null +++ b/gcc/ada/libgnat/g-socthi-mingw.adb @@ -0,0 +1,631 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 Ada.Unchecked_Conversion; +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +package body GNAT.Sockets.Thin is + + use type C.unsigned; + + WSAData_Dummy : array (1 .. 512) of C.int; + + WS_Version : constant := 16#0202#; + -- Winsock 2.2 + + Initialized : Boolean := False; + + 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 : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int; + pragma Import (Stdcall, Standard_Select, "select"); + + type Error_Type is + (N_EINTR, + N_EBADF, + N_EACCES, + N_EFAULT, + N_EINVAL, + N_EMFILE, + N_EWOULDBLOCK, + N_EINPROGRESS, + N_EALREADY, + N_ENOTSOCK, + N_EDESTADDRREQ, + N_EMSGSIZE, + N_EPROTOTYPE, + N_ENOPROTOOPT, + N_EPROTONOSUPPORT, + N_ESOCKTNOSUPPORT, + N_EOPNOTSUPP, + N_EPFNOSUPPORT, + N_EAFNOSUPPORT, + N_EADDRINUSE, + N_EADDRNOTAVAIL, + N_ENETDOWN, + N_ENETUNREACH, + N_ENETRESET, + N_ECONNABORTED, + N_ECONNRESET, + N_ENOBUFS, + N_EISCONN, + N_ENOTCONN, + N_ESHUTDOWN, + N_ETOOMANYREFS, + N_ETIMEDOUT, + N_ECONNREFUSED, + N_ELOOP, + N_ENAMETOOLONG, + N_EHOSTDOWN, + N_EHOSTUNREACH, + N_WSASYSNOTREADY, + N_WSAVERNOTSUPPORTED, + N_WSANOTINITIALISED, + N_WSAEDISCON, + N_HOST_NOT_FOUND, + N_TRY_AGAIN, + N_NO_RECOVERY, + N_NO_DATA, + N_OTHERS); + + Error_Messages : constant array (Error_Type) of chars_ptr := + (N_EINTR => + New_String ("Interrupted system call"), + N_EBADF => + New_String ("Bad file number"), + N_EACCES => + New_String ("Permission denied"), + N_EFAULT => + New_String ("Bad address"), + N_EINVAL => + New_String ("Invalid argument"), + N_EMFILE => + New_String ("Too many open files"), + N_EWOULDBLOCK => + New_String ("Operation would block"), + N_EINPROGRESS => + New_String ("Operation now in progress. This error is " + & "returned if any Windows Sockets API " + & "function is called while a blocking " + & "function is in progress"), + N_EALREADY => + New_String ("Operation already in progress"), + N_ENOTSOCK => + New_String ("Socket operation on nonsocket"), + N_EDESTADDRREQ => + New_String ("Destination address required"), + N_EMSGSIZE => + New_String ("Message too long"), + N_EPROTOTYPE => + New_String ("Protocol wrong type for socket"), + N_ENOPROTOOPT => + New_String ("Protocol not available"), + N_EPROTONOSUPPORT => + New_String ("Protocol not supported"), + N_ESOCKTNOSUPPORT => + New_String ("Socket type not supported"), + N_EOPNOTSUPP => + New_String ("Operation not supported on socket"), + N_EPFNOSUPPORT => + New_String ("Protocol family not supported"), + N_EAFNOSUPPORT => + New_String ("Address family not supported by protocol family"), + N_EADDRINUSE => + New_String ("Address already in use"), + N_EADDRNOTAVAIL => + New_String ("Cannot assign requested address"), + N_ENETDOWN => + New_String ("Network is down. This error may be " + & "reported at any time if the Windows " + & "Sockets implementation detects an " + & "underlying failure"), + N_ENETUNREACH => + New_String ("Network is unreachable"), + N_ENETRESET => + New_String ("Network dropped connection on reset"), + N_ECONNABORTED => + New_String ("Software caused connection abort"), + N_ECONNRESET => + New_String ("Connection reset by peer"), + N_ENOBUFS => + New_String ("No buffer space available"), + N_EISCONN => + New_String ("Socket is already connected"), + N_ENOTCONN => + New_String ("Socket is not connected"), + N_ESHUTDOWN => + New_String ("Cannot send after socket shutdown"), + N_ETOOMANYREFS => + New_String ("Too many references: cannot splice"), + N_ETIMEDOUT => + New_String ("Connection timed out"), + N_ECONNREFUSED => + New_String ("Connection refused"), + N_ELOOP => + New_String ("Too many levels of symbolic links"), + N_ENAMETOOLONG => + New_String ("File name too long"), + N_EHOSTDOWN => + New_String ("Host is down"), + N_EHOSTUNREACH => + New_String ("No route to host"), + N_WSASYSNOTREADY => + New_String ("Returned by WSAStartup(), indicating that " + & "the network subsystem is unusable"), + N_WSAVERNOTSUPPORTED => + New_String ("Returned by WSAStartup(), indicating that " + & "the Windows Sockets DLL cannot support " + & "this application"), + N_WSANOTINITIALISED => + New_String ("Winsock not initialized. This message is " + & "returned by any function except WSAStartup(), " + & "indicating that a successful WSAStartup() has " + & "not yet been performed"), + N_WSAEDISCON => + New_String ("Disconnected"), + N_HOST_NOT_FOUND => + New_String ("Host not found. This message indicates " + & "that the key (name, address, and so on) was not found"), + N_TRY_AGAIN => + New_String ("Nonauthoritative host not found. This error may " + & "suggest that the name service itself is not " + & "functioning"), + N_NO_RECOVERY => + New_String ("Nonrecoverable error. This error may suggest that the " + & "name service itself is not functioning"), + N_NO_DATA => + New_String ("Valid name, no data record of requested type. " + & "This error indicates that the key (name, address, " + & "and so on) was not found."), + N_OTHERS => + New_String ("Unknown system error")); + + --------------- + -- C_Connect -- + --------------- + + function C_Connect + (S : C.int; + Name : System.Address; + Namelen : C.int) return C.int + is + Res : C.int; + + begin + Res := Standard_Connect (S, Name, Namelen); + + if Res = -1 then + if Socket_Errno = SOSC.EWOULDBLOCK then + Set_Socket_Errno (SOSC.EINPROGRESS); + end if; + end if; + + return Res; + end C_Connect; + + ------------------ + -- Socket_Ioctl -- + ------------------ + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int + is + begin + return C_Ioctl (S, Req, Arg); + end Socket_Ioctl; + + --------------- + -- C_Recvmsg -- + --------------- + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + use type C.size_t; + + Fill : constant Boolean := + SOSC.MSG_WAITALL /= -1 + and then (C.unsigned (Flags) and SOSC.MSG_WAITALL) /= 0; + -- Is the MSG_WAITALL flag set? If so we need to fully fill all vectors + + Res : C.int; + Count : C.int := 0; + + MH : Msghdr; + for MH'Address use Msg; + + Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; + for Iovec'Address use MH.Msg_Iov; + pragma Import (Ada, Iovec); + + Iov_Index : Integer; + Current_Iovec : Vector_Element; + + function To_Access is new Ada.Unchecked_Conversion + (System.Address, Stream_Element_Reference); + pragma Warnings (Off, Stream_Element_Reference); + + Req : Request_Type (Name => N_Bytes_To_Read); + + begin + -- Windows does not provide an implementation of recvmsg(). The spec for + -- WSARecvMsg() is incompatible with the data types we define, and is + -- available starting with Windows Vista and Server 2008 only. So, + -- we use C_Recv instead. + + -- Check how much data are available + + Control_Socket (Socket_Type (S), Req); + + -- Fill the vectors + + Iov_Index := -1; + Current_Iovec := (Base => null, Length => 0); + + loop + if Current_Iovec.Length = 0 then + Iov_Index := Iov_Index + 1; + exit when Iov_Index > Integer (Iovec'Last); + Current_Iovec := Iovec (SOSC.Msg_Iovlen_T (Iov_Index)); + end if; + + Res := + C_Recv + (S, + Current_Iovec.Base.all'Address, + C.int (Current_Iovec.Length), + Flags); + + if Res < 0 then + return System.CRTL.ssize_t (Res); + + elsif Res = 0 and then not Fill then + exit; + + else + pragma Assert (Interfaces.C.size_t (Res) <= Current_Iovec.Length); + + Count := Count + Res; + Current_Iovec.Length := + Current_Iovec.Length - Interfaces.C.size_t (Res); + Current_Iovec.Base := + To_Access (Current_Iovec.Base.all'Address + + Storage_Offset (Res)); + + -- If all the data that was initially available read, do not + -- attempt to receive more, since this might block, or merge data + -- from successive datagrams for a datagram-oriented socket. We + -- still try to receive more if we need to fill all vectors + -- (MSG_WAITALL flag is set). + + exit when Natural (Count) >= Req.Size + and then + + -- Either we are not in fill mode + + (not Fill + + -- Or else last vector filled + + or else (Interfaces.C.size_t (Iov_Index) = Iovec'Last + and then Current_Iovec.Length = 0)); + end if; + end loop; + + return System.CRTL.ssize_t (Count); + end C_Recvmsg; + + -------------- + -- C_Select -- + -------------- + + function C_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int + is + pragma Warnings (Off, Exceptfds); + + Original_WFS : aliased constant Fd_Set := Writefds.all; + + Res : C.int; + S : aliased C.int; + Last : aliased C.int; + + begin + -- Asynchronous connection failures are notified in the exception fd + -- set instead of the write fd set. To ensure POSIX compatibility, 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 successful, and 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 Writefds /= No_Fd_Set_Access then + + -- Add any socket present in write fd set into exception fd set + + declare + WFS : aliased Fd_Set := Writefds.all; + begin + Last := Nfds - 1; + loop + Get_Socket_From_Set + (WFS'Access, S'Unchecked_Access, Last'Unchecked_Access); + exit when S = -1; + Insert_Socket_In_Set (Exceptfds, S); + end loop; + end; + end if; + + Res := Standard_Select (Nfds, Readfds, Writefds, Exceptfds, Timeout); + + if Exceptfds /= No_Fd_Set_Access then + declare + EFSC : aliased Fd_Set := Exceptfds.all; + Flag : constant C.int := SOSC.MSG_PEEK + SOSC.MSG_OOB; + Buffer : Character; + Length : C.int; + Fromlen : aliased C.int; + + begin + Last := Nfds - 1; + loop + Get_Socket_From_Set + (EFSC'Access, 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, + From => System.Null_Address, + Fromlen => Fromlen'Unchecked_Access); + -- Is Fromlen necessary if From is Null_Address??? + + -- 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 (Exceptfds, 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 Writefds /= No_Fd_Set_Access + and then (Is_Socket_In_Set (Original_WFS'Access, S) /= 0) + then + Insert_Socket_In_Set (Writefds, S); + end if; + end if; + end loop; + end; + end if; + return Res; + end C_Select; + + --------------- + -- C_Sendmsg -- + --------------- + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + use type C.size_t; + + Res : C.int; + Count : C.int := 0; + + MH : Msghdr; + for MH'Address use Msg; + + Iovec : array (0 .. MH.Msg_Iovlen - 1) of Vector_Element; + for Iovec'Address use MH.Msg_Iov; + pragma Import (Ada, Iovec); + + begin + -- Windows does not provide an implementation of sendmsg(). The spec for + -- WSASendMsg() is incompatible with the data types we define, and is + -- available starting with Windows Vista and Server 2008 only. So + -- use C_Sendto instead. + + for J in Iovec'Range loop + Res := + C_Sendto + (S, + Iovec (J).Base.all'Address, + C.int (Iovec (J).Length), + Flags => Flags, + To => MH.Msg_Name, + Tolen => C.int (MH.Msg_Namelen)); + + if Res < 0 then + return System.CRTL.ssize_t (Res); + else + Count := Count + Res; + end if; + + -- Exit now if the buffer is not fully transmitted + + exit when Interfaces.C.size_t (Res) < Iovec (J).Length; + end loop; + + return System.CRTL.ssize_t (Count); + end C_Sendmsg; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if Initialized then + WSACleanup; + Initialized := False; + end if; + end Finalize; + + ------------------------- + -- Host_Error_Messages -- + ------------------------- + + package body Host_Error_Messages is + + -- On Windows, socket and host errors share the same code space, and + -- error messages are provided by Socket_Error_Message, so the default + -- separate body for Host_Error_Messages is not used in this case. + + function Host_Error_Message (H_Errno : Integer) return String + renames Socket_Error_Message; + + end Host_Error_Messages; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + Return_Value : Interfaces.C.int; + begin + if not Initialized then + Return_Value := WSAStartup (WS_Version, WSAData_Dummy'Address); + pragma Assert (Return_Value = 0); + Initialized := True; + end if; + end Initialize; + + -------------------- + -- Signalling_Fds -- + -------------------- + + package body Signalling_Fds is separate; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message (Errno : Integer) return String is + use GNAT.Sockets.SOSC; + + Errm : C.Strings.chars_ptr; + + begin + case Errno is + when EINTR => Errm := Error_Messages (N_EINTR); + when EBADF => Errm := Error_Messages (N_EBADF); + when EACCES => Errm := Error_Messages (N_EACCES); + when EFAULT => Errm := Error_Messages (N_EFAULT); + when EINVAL => Errm := Error_Messages (N_EINVAL); + when EMFILE => Errm := Error_Messages (N_EMFILE); + when EWOULDBLOCK => Errm := Error_Messages (N_EWOULDBLOCK); + when EINPROGRESS => Errm := Error_Messages (N_EINPROGRESS); + when EALREADY => Errm := Error_Messages (N_EALREADY); + when ENOTSOCK => Errm := Error_Messages (N_ENOTSOCK); + when EDESTADDRREQ => Errm := Error_Messages (N_EDESTADDRREQ); + when EMSGSIZE => Errm := Error_Messages (N_EMSGSIZE); + when EPROTOTYPE => Errm := Error_Messages (N_EPROTOTYPE); + when ENOPROTOOPT => Errm := Error_Messages (N_ENOPROTOOPT); + when EPROTONOSUPPORT => Errm := Error_Messages (N_EPROTONOSUPPORT); + when ESOCKTNOSUPPORT => Errm := Error_Messages (N_ESOCKTNOSUPPORT); + when EOPNOTSUPP => Errm := Error_Messages (N_EOPNOTSUPP); + when EPFNOSUPPORT => Errm := Error_Messages (N_EPFNOSUPPORT); + when EAFNOSUPPORT => Errm := Error_Messages (N_EAFNOSUPPORT); + when EADDRINUSE => Errm := Error_Messages (N_EADDRINUSE); + when EADDRNOTAVAIL => Errm := Error_Messages (N_EADDRNOTAVAIL); + when ENETDOWN => Errm := Error_Messages (N_ENETDOWN); + when ENETUNREACH => Errm := Error_Messages (N_ENETUNREACH); + when ENETRESET => Errm := Error_Messages (N_ENETRESET); + when ECONNABORTED => Errm := Error_Messages (N_ECONNABORTED); + when ECONNRESET => Errm := Error_Messages (N_ECONNRESET); + when ENOBUFS => Errm := Error_Messages (N_ENOBUFS); + when EISCONN => Errm := Error_Messages (N_EISCONN); + when ENOTCONN => Errm := Error_Messages (N_ENOTCONN); + when ESHUTDOWN => Errm := Error_Messages (N_ESHUTDOWN); + when ETOOMANYREFS => Errm := Error_Messages (N_ETOOMANYREFS); + when ETIMEDOUT => Errm := Error_Messages (N_ETIMEDOUT); + when ECONNREFUSED => Errm := Error_Messages (N_ECONNREFUSED); + when ELOOP => Errm := Error_Messages (N_ELOOP); + when ENAMETOOLONG => Errm := Error_Messages (N_ENAMETOOLONG); + when EHOSTDOWN => Errm := Error_Messages (N_EHOSTDOWN); + when EHOSTUNREACH => Errm := Error_Messages (N_EHOSTUNREACH); + + -- Windows-specific error codes + + when WSASYSNOTREADY => Errm := Error_Messages (N_WSASYSNOTREADY); + when WSAVERNOTSUPPORTED => + Errm := Error_Messages (N_WSAVERNOTSUPPORTED); + when WSANOTINITIALISED => + Errm := Error_Messages (N_WSANOTINITIALISED); + when WSAEDISCON => Errm := Error_Messages (N_WSAEDISCON); + + -- h_errno values + + when HOST_NOT_FOUND => Errm := Error_Messages (N_HOST_NOT_FOUND); + when TRY_AGAIN => Errm := Error_Messages (N_TRY_AGAIN); + when NO_RECOVERY => Errm := Error_Messages (N_NO_RECOVERY); + when NO_DATA => Errm := Error_Messages (N_NO_DATA); + when others => Errm := Error_Messages (N_OTHERS); + end case; + + return Value (Errm); + end Socket_Error_Message; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-mingw.ads b/gcc/ada/libgnat/g-socthi-mingw.ads new file mode 100644 index 0000000..48f5aeb --- /dev/null +++ b/gcc/ada/libgnat/g-socthi-mingw.ads @@ -0,0 +1,242 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 Interfaces.C; + +with GNAT.Sockets.Thin_Common; + +with System; +with System.CRTL; + +package GNAT.Sockets.Thin is + + use Thin_Common; + + package C renames Interfaces.C; + + use type System.CRTL.ssize_t; + + 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, returns "Unknown system error". + + function Host_Errno return Integer; + pragma Import (C, Host_Errno, "__gnat_get_h_errno"); + -- Returns last host error number + + package Host_Error_Messages is + + function Host_Error_Message (H_Errno : Integer) return String; + -- Returns the error message string for the host error number H_Errno. + -- If H_Errno is not known, returns "Unknown system error". + + end Host_Error_Messages; + + -------------------------------- + -- Standard library functions -- + -------------------------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null 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_Gethostname + (Name : System.Address; + Namelen : C.int) return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : not null access C.int) return C.int; + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int; + + function C_Listen + (S : C.int; + Backlog : 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 : System.Address; + Fromlen : not null access C.int) return C.int; + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int; + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + 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_System + (Command : System.Address) return C.int; + + function WSAStartup + (WS_Version : Interfaces.C.unsigned_short; + WSADataAddress : System.Address) return Interfaces.C.int; + + ------------------------------------------------------- + -- Signalling file descriptors for selector abortion -- + ------------------------------------------------------- + + package Signalling_Fds is + + function Create (Fds : not null access Fd_Pair) return C.int; + pragma Convention (C, Create); + -- Create a pair of connected descriptors suitable for use with C_Select + -- (used for signalling in Selector objects). + + function Read (Rsig : C.int) return C.int; + pragma Convention (C, Read); + -- Read one byte of data from rsig, the read end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + function Write (Wsig : C.int) return C.int; + pragma Convention (C, Write); + -- Write one byte of data to wsig, the write end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + procedure Close (Sig : C.int); + pragma Convention (C, Close); + -- Close one end of a pair of signalling fds (ignoring any error) + + end Signalling_Fds; + + procedure WSACleanup; + + procedure Initialize; + procedure Finalize; + +private + pragma Import (Stdcall, C_Accept, "accept"); + pragma Import (Stdcall, C_Bind, "bind"); + pragma Import (Stdcall, C_Close, "closesocket"); + pragma Import (Stdcall, C_Gethostname, "gethostname"); + pragma Import (Stdcall, C_Getpeername, "getpeername"); + pragma Import (Stdcall, C_Getsockname, "getsockname"); + pragma Import (Stdcall, C_Getsockopt, "getsockopt"); + pragma Import (Stdcall, C_Listen, "listen"); + pragma Import (Stdcall, C_Recv, "recv"); + pragma Import (Stdcall, C_Recvfrom, "recvfrom"); + pragma Import (Stdcall, C_Sendto, "sendto"); + pragma Import (Stdcall, C_Setsockopt, "setsockopt"); + pragma Import (Stdcall, C_Shutdown, "shutdown"); + pragma Import (Stdcall, C_Socket, "socket"); + pragma Import (C, C_System, "_system"); + pragma Import (Stdcall, Socket_Errno, "WSAGetLastError"); + pragma Import (Stdcall, Set_Socket_Errno, "WSASetLastError"); + pragma Import (Stdcall, WSAStartup, "WSAStartup"); + pragma Import (Stdcall, WSACleanup, "WSACleanup"); + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-vxworks.adb b/gcc/ada/libgnat/g-socthi-vxworks.adb new file mode 100644 index 0000000..05bedc2 --- /dev/null +++ b/gcc/ada/libgnat/g-socthi-vxworks.adb @@ -0,0 +1,487 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +package body GNAT.Sockets.Thin is + + Non_Blocking_Sockets : aliased Fd_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 SOSC.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. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + -- All these require comments ??? + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null 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_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 : System.Address; + Fromlen : not null access C.int) return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Recvmsg, "recvmsg"); + + function Syscall_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return C.int; + pragma Import (C, Syscall_Sendmsg, "sendmsg"); + + 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 : System.Address; + 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 : not null access C.int) return C.int + is + R : C.int; + Val : aliased C.int := 1; + + Res : C.int; + pragma Unreferenced (Res); + + begin + loop + R := Syscall_Accept (S, Addr, Addrlen); + exit when SOSC.Thread_Blocking_IO + or else R /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + if not SOSC.Thread_Blocking_IO + and then R /= Failure + then + -- A socket inherits the properties of its server especially + -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram + -- tracks sockets set in non-blocking mode by user. + + Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); + Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); + -- Is it OK to ignore result ??? + 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 SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EINPROGRESS + then + return Res; + end if; + + declare + WSet : aliased Fd_Set; + Now : aliased Timeval; + begin + Reset_Socket_Set (WSet'Access); + loop + Insert_Socket_In_Set (WSet'Access, S); + Now := Immediat; + Res := C_Select + (S + 1, + No_Fd_Set_Access, + WSet'Access, + No_Fd_Set_Access, + Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + return Res; + end if; + + delay Quantum; + end loop; + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = SOSC.EISCONN + then + return Thin_Common.Success; + else + return Res; + end if; + end C_Connect; + + ------------------ + -- Socket_Ioctl -- + ------------------ + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int + is + begin + if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then + if Arg.all /= 0 then + Set_Non_Blocking_Socket (S, True); + end if; + end if; + + return C_Ioctl (S, Req, Arg); + end Socket_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 SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.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 : System.Address; + Fromlen : not null access C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + --------------- + -- C_Recvmsg -- + --------------- + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + Res : C.int; + + begin + loop + Res := Syscall_Recvmsg (S, Msg, Flags); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return System.CRTL.ssize_t (Res); + end C_Recvmsg; + + --------------- + -- C_Sendmsg -- + --------------- + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + Res : C.int; + + begin + loop + Res := Syscall_Sendmsg (S, Msg, Flags); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return System.CRTL.ssize_t (Res); + end C_Sendmsg; + + -------------- + -- C_Sendto -- + -------------- + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + Tolen : C.int) return C.int + is + use System; + + Res : C.int; + + begin + loop + if To = Null_Address then + + -- In violation of the standard sockets API, VxWorks does not + -- support sendto(2) calls on connected sockets with a null + -- destination address, so use send(2) instead in that case. + + Res := Syscall_Send (S, Msg, Len, Flags); + + -- Normal case where destination address is non-null + + else + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + end if; + + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.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; + pragma Unreferenced (Res); + + begin + R := Syscall_Socket (Domain, Typ, Protocol); + + if not SOSC.Thread_Blocking_IO + and then R /= Failure + then + -- Do not use Socket_Ioctl as this subprogram tracks sockets set + -- in non-blocking mode by user. + + Res := C_Ioctl (R, SOSC.FIONBIO, Val'Access); + -- Is it OK to ignore result ??? + Set_Non_Blocking_Socket (R, False); + end if; + + return R; + end C_Socket; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ------------------------- + -- Host_Error_Messages -- + ------------------------- + + package body Host_Error_Messages is separate; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Reset_Socket_Set (Non_Blocking_Sockets'Access); + 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'Access, S) /= 0); + Task_Lock.Unlock; + return R; + end Non_Blocking_Socket; + + ----------------------------- + -- 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'Access, S); + else + Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); + end if; + + Task_Lock.Unlock; + end Set_Non_Blocking_Socket; + + -------------------- + -- Signalling_Fds -- + -------------------- + + package body Signalling_Fds is separate; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message (Errno : Integer) return String is separate; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi-vxworks.ads b/gcc/ada/libgnat/g-socthi-vxworks.ads new file mode 100644 index 0000000..9cb4018 --- /dev/null +++ b/gcc/ada/libgnat/g-socthi-vxworks.ads @@ -0,0 +1,228 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + +with GNAT.OS_Lib; +with GNAT.Sockets.Thin_Common; + +with System; +with System.CRTL; + +package GNAT.Sockets.Thin is + + use Thin_Common; + + package C renames Interfaces.C; + + use type System.CRTL.ssize_t; + + function Socket_Errno return Integer renames GNAT.OS_Lib.Errno; + -- Returns last socket error number + + procedure Set_Socket_Errno (Errno : Integer) renames GNAT.OS_Lib.Set_Errno; + -- 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, returns "Unknown system error". + + function Host_Errno return Integer; + pragma Import (C, Host_Errno, "__gnat_get_h_errno"); + -- Returns last host error number + + package Host_Error_Messages is + + function Host_Error_Message (H_Errno : Integer) return String; + -- Returns the error message string for the host error number H_Errno. + -- If H_Errno is not known, returns "Unknown system error". + + end Host_Error_Messages; + + -------------------------------- + -- Standard library functions -- + -------------------------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null 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_Gethostname + (Name : System.Address; + Namelen : C.int) return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : not null access C.int) return C.int; + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int; + + function C_Listen + (S : C.int; + Backlog : 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 : System.Address; + Fromlen : not null access C.int) return C.int; + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int; + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + 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_System + (Command : System.Address) return C.int; + + ------------------------------------------------------- + -- Signalling file descriptors for selector abortion -- + ------------------------------------------------------- + + package Signalling_Fds is + + function Create (Fds : not null access Fd_Pair) return C.int; + pragma Convention (C, Create); + -- Create a pair of connected descriptors suitable for use with C_Select + -- (used for signalling in Selector objects). + + function Read (Rsig : C.int) return C.int; + pragma Convention (C, Read); + -- Read one byte of data from rsig, the read end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + function Write (Wsig : C.int) return C.int; + pragma Convention (C, Write); + -- Write one byte of data to wsig, the write end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + procedure Close (Sig : C.int); + pragma Convention (C, Close); + -- Close one end of a pair of signalling fds (ignoring any error) + + end Signalling_Fds; + + procedure Initialize; + procedure Finalize; + +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_Listen, "listen"); + pragma Import (C, C_Select, "select"); + pragma Import (C, C_Setsockopt, "setsockopt"); + pragma Import (C, C_Shutdown, "shutdown"); + pragma Import (C, C_System, "system"); +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi.adb b/gcc/ada/libgnat/g-socthi.adb new file mode 100644 index 0000000..635d0f5 --- /dev/null +++ b/gcc/ada/libgnat/g-socthi.adb @@ -0,0 +1,491 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the default version + +with GNAT.OS_Lib; use GNAT.OS_Lib; +with GNAT.Task_Lock; + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Sockets.Thin is + + Non_Blocking_Sockets : aliased Fd_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 SOSC.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. + + -- Comments required for following functions ??? + + function Syscall_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null 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_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 : System.Address; + Fromlen : not null access C.int) return C.int; + pragma Import (C, Syscall_Recvfrom, "recvfrom"); + + function Syscall_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + pragma Import (C, Syscall_Recvmsg, "recvmsg"); + + function Syscall_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + pragma Import (C, Syscall_Sendmsg, "sendmsg"); + + function Syscall_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + 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"); + + procedure Disable_SIGPIPE (S : C.int); + pragma Import (C, Disable_SIGPIPE, "__gnat_disable_sigpipe"); + + procedure Disable_All_SIGPIPEs; + pragma Import (C, Disable_All_SIGPIPEs, "__gnat_disable_all_sigpipes"); + -- Sets the process to ignore all SIGPIPE signals on platforms that + -- don't support Disable_SIGPIPE for particular streams. + + 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 : not null 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 SOSC.Thread_Blocking_IO + or else R /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + if not SOSC.Thread_Blocking_IO + and then R /= Failure + then + -- A socket inherits the properties ot its server especially + -- the FIONBIO flag. Do not use Socket_Ioctl as this subprogram + -- tracks sockets set in non-blocking mode by user. + + Set_Non_Blocking_Socket (R, Non_Blocking_Socket (S)); + Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); + end if; + + Disable_SIGPIPE (R); + 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 SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EINPROGRESS + then + return Res; + end if; + + declare + WSet : aliased Fd_Set; + Now : aliased Timeval; + + begin + Reset_Socket_Set (WSet'Access); + loop + Insert_Socket_In_Set (WSet'Access, S); + Now := Immediat; + Res := C_Select + (S + 1, + No_Fd_Set_Access, + WSet'Access, + No_Fd_Set_Access, + Now'Unchecked_Access); + + exit when Res > 0; + + if Res = Failure then + return Res; + end if; + + delay Quantum; + end loop; + end; + + Res := Syscall_Connect (S, Name, Namelen); + + if Res = Failure + and then Errno = SOSC.EISCONN + then + return Thin_Common.Success; + else + return Res; + end if; + end C_Connect; + + ------------------ + -- Socket_Ioctl -- + ------------------ + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int + is + begin + if not SOSC.Thread_Blocking_IO and then Req = SOSC.FIONBIO then + if Arg.all /= 0 then + Set_Non_Blocking_Socket (S, True); + end if; + end if; + + return C_Ioctl (S, Req, Arg); + end Socket_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 SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.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 : System.Address; + Fromlen : not null access C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Recvfrom (S, Msg, Len, Flags, From, Fromlen); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvfrom; + + --------------- + -- C_Recvmsg -- + --------------- + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + Res : System.CRTL.ssize_t; + + begin + loop + Res := Syscall_Recvmsg (S, Msg, Flags); + exit when SOSC.Thread_Blocking_IO + or else Res /= System.CRTL.ssize_t (Failure) + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Recvmsg; + + --------------- + -- C_Sendmsg -- + --------------- + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t + is + Res : System.CRTL.ssize_t; + + begin + loop + Res := Syscall_Sendmsg (S, Msg, Flags); + exit when SOSC.Thread_Blocking_IO + or else Res /= System.CRTL.ssize_t (Failure) + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.EWOULDBLOCK; + delay Quantum; + end loop; + + return Res; + end C_Sendmsg; + + -------------- + -- C_Sendto -- + -------------- + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + Tolen : C.int) return C.int + is + Res : C.int; + + begin + loop + Res := Syscall_Sendto (S, Msg, Len, Flags, To, Tolen); + exit when SOSC.Thread_Blocking_IO + or else Res /= Failure + or else Non_Blocking_Socket (S) + or else Errno /= SOSC.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; + + begin + R := Syscall_Socket (Domain, Typ, Protocol); + + if not SOSC.Thread_Blocking_IO + and then R /= Failure + then + -- Do not use Socket_Ioctl as this subprogram tracks sockets set + -- in non-blocking mode by user. + + Discard := C_Ioctl (R, SOSC.FIONBIO, Val'Access); + Set_Non_Blocking_Socket (R, False); + end if; + Disable_SIGPIPE (R); + return R; + end C_Socket; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + null; + end Finalize; + + ------------------------- + -- Host_Error_Messages -- + ------------------------- + + package body Host_Error_Messages is separate; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + Disable_All_SIGPIPEs; + Reset_Socket_Set (Non_Blocking_Sockets'Access); + 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'Access, S) /= 0); + Task_Lock.Unlock; + return R; + end Non_Blocking_Socket; + + ----------------------------- + -- 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'Access, S); + else + Remove_Socket_From_Set (Non_Blocking_Sockets'Access, S); + end if; + + Task_Lock.Unlock; + end Set_Non_Blocking_Socket; + + -------------------- + -- Signalling_Fds -- + -------------------- + + package body Signalling_Fds is + + -- In this default implementation, we use a C version of these + -- subprograms provided by socket.c. + + function C_Create (Fds : not null access Fd_Pair) return C.int; + function C_Read (Rsig : C.int) return C.int; + function C_Write (Wsig : C.int) return C.int; + procedure C_Close (Sig : C.int); + + pragma Import (C, C_Create, "__gnat_create_signalling_fds"); + pragma Import (C, C_Read, "__gnat_read_signalling_fd"); + pragma Import (C, C_Write, "__gnat_write_signalling_fd"); + pragma Import (C, C_Close, "__gnat_close_signalling_fd"); + + function Create + (Fds : not null access Fd_Pair) return C.int renames C_Create; + function Read (Rsig : C.int) return C.int renames C_Read; + function Write (Wsig : C.int) return C.int renames C_Write; + procedure Close (Sig : C.int) renames C_Close; + + end Signalling_Fds; + + -------------------------- + -- Socket_Error_Message -- + -------------------------- + + function Socket_Error_Message (Errno : Integer) return String is separate; + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-socthi.ads b/gcc/ada/libgnat/g-socthi.ads new file mode 100644 index 0000000..0338f7f --- /dev/null +++ b/gcc/ada/libgnat/g-socthi.ads @@ -0,0 +1,259 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a target dependent thin interface to the sockets +-- layer for use by the GNAT.Sockets package (g-socket.ads). This package +-- should not be directly with'ed by an applications program. + +-- This is the default version + +with Interfaces.C; + +with GNAT.OS_Lib; +with GNAT.Sockets.Thin_Common; + +with System; +with System.CRTL; + +package GNAT.Sockets.Thin is + + -- This package is intended for hosts implementing BSD sockets with a + -- standard interface. It will be used as a default for all the platforms + -- that do not have a specific version of this file. + + use Thin_Common; + + package C renames Interfaces.C; + + use type System.CRTL.ssize_t; + + 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, returns "Unknown system error". + + function Host_Errno return Integer; + pragma Import (C, Host_Errno, "__gnat_get_h_errno"); + -- Returns last host error number + + package Host_Error_Messages is + + function Host_Error_Message (H_Errno : Integer) return String; + -- Returns the error message string for the host error number H_Errno. + -- If H_Errno is not known, returns "Unknown system error". + + end Host_Error_Messages; + + -------------------------------- + -- Standard library functions -- + -------------------------------- + + function C_Accept + (S : C.int; + Addr : System.Address; + Addrlen : not null 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_Gethostname + (Name : System.Address; + Namelen : C.int) return C.int; + + function C_Getpeername + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockname + (S : C.int; + Name : System.Address; + Namelen : not null access C.int) return C.int; + + function C_Getsockopt + (S : C.int; + Level : C.int; + Optname : C.int; + Optval : System.Address; + Optlen : not null access C.int) return C.int; + + function Socket_Ioctl + (S : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int; + + function C_Listen + (S : C.int; + Backlog : 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 : System.Address; + Fromlen : not null access C.int) return C.int; + + function C_Recvmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Select + (Nfds : C.int; + Readfds : access Fd_Set; + Writefds : access Fd_Set; + Exceptfds : access Fd_Set; + Timeout : Timeval_Access) return C.int; + + function C_Sendmsg + (S : C.int; + Msg : System.Address; + Flags : C.int) return System.CRTL.ssize_t; + + function C_Sendto + (S : C.int; + Msg : System.Address; + Len : C.int; + Flags : C.int; + To : System.Address; + 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_System + (Command : System.Address) return C.int; + + ------------------------------------------------------- + -- Signalling file descriptors for selector abortion -- + ------------------------------------------------------- + + package Signalling_Fds is + + function Create (Fds : not null access Fd_Pair) return C.int; + pragma Convention (C, Create); + -- Create a pair of connected descriptors suitable for use with C_Select + -- (used for signalling in Selector objects). + + function Read (Rsig : C.int) return C.int; + pragma Convention (C, Read); + -- Read one byte of data from rsig, the read end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + function Write (Wsig : C.int) return C.int; + pragma Convention (C, Write); + -- Write one byte of data to wsig, the write end of a pair of signalling + -- fds created by Create_Signalling_Fds. + + procedure Close (Sig : C.int); + pragma Convention (C, Close); + -- Close one end of a pair of signalling fds (ignoring any error) + + end Signalling_Fds; + + ------------------------------------------- + -- Nonreentrant network databases access -- + ------------------------------------------- + + -- The following are used only on systems that have nonreentrant + -- getXXXbyYYY functions, and do NOT have corresponding getXXXbyYYY_ + -- functions. Currently, LynxOS is the only such system. + + function Nonreentrant_Gethostbyname + (Name : C.char_array) return Hostent_Access; + + function Nonreentrant_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int) return Hostent_Access; + + function Nonreentrant_Getservbyname + (Name : C.char_array; + Proto : C.char_array) return Servent_Access; + + function Nonreentrant_Getservbyport + (Port : C.int; + Proto : C.char_array) return Servent_Access; + + procedure Initialize; + procedure Finalize; + +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_Listen, "listen"); + pragma Import (C, C_Select, "select"); + pragma Import (C, C_Setsockopt, "setsockopt"); + pragma Import (C, C_Shutdown, "shutdown"); + pragma Import (C, C_System, "system"); + + pragma Import (C, Nonreentrant_Gethostbyname, "gethostbyname"); + pragma Import (C, Nonreentrant_Gethostbyaddr, "gethostbyaddr"); + pragma Import (C, Nonreentrant_Getservbyname, "getservbyname"); + pragma Import (C, Nonreentrant_Getservbyport, "getservbyport"); + +end GNAT.Sockets.Thin; diff --git a/gcc/ada/libgnat/g-soliop-mingw.ads b/gcc/ada/libgnat/g-soliop-mingw.ads new file mode 100644 index 0000000..25d5605 --- /dev/null +++ b/gcc/ada/libgnat/g-soliop-mingw.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 sockets as required by the package GNAT.Sockets. + +-- This is the Windows/NT version of this package + +-- This package should not be directly with'ed by an application program + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lws2_32"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-soliop-solaris.ads b/gcc/ada/libgnat/g-soliop-solaris.ads new file mode 100644 index 0000000..734a2bc --- /dev/null +++ b/gcc/ada/libgnat/g-soliop-solaris.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 sockets as required by the package GNAT.Sockets. + +-- This is the Solaris version of this package + +-- This package should not be directly with'ed by an application program + +package GNAT.Sockets.Linker_Options is +private + pragma Linker_Options ("-lnsl"); + pragma Linker_Options ("-lsocket"); +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-soliop.ads b/gcc/ada/libgnat/g-soliop.ads new file mode 100644 index 0000000..1898bb0 --- /dev/null +++ b/gcc/ada/libgnat/g-soliop.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . L I N K E R _ O P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 sockets as required by the package GNAT.Sockets. + +-- This is an empty version for default use where no additional libraries +-- are required. On some targets a target specific version of this unit +-- ensures linking with required libraries for proper sockets operation. + +-- This package should not be directly with'ed by an application program + +package GNAT.Sockets.Linker_Options is +end GNAT.Sockets.Linker_Options; diff --git a/gcc/ada/libgnat/g-sothco-dummy.adb b/gcc/ada/libgnat/g-sothco-dummy.adb new file mode 100644 index 0000000..cd2ec9c --- /dev/null +++ b/gcc/ada/libgnat/g-sothco-dummy.adb @@ -0,0 +1,32 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-sothco-dummy.ads b/gcc/ada/libgnat/g-sothco-dummy.ads new file mode 100644 index 0000000..2f17b6c --- /dev/null +++ b/gcc/ada/libgnat/g-sothco-dummy.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a placeholder for the sockets binding for platforms where +-- it is not implemented. + +package GNAT.Sockets.Thin_Common is + pragma Unimplemented_Unit; +end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/libgnat/g-sothco.adb b/gcc/ada/libgnat/g-sothco.adb new file mode 100644 index 0000000..3739d64 --- /dev/null +++ b/gcc/ada/libgnat/g-sothco.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body GNAT.Sockets.Thin_Common is + + ----------------- + -- 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 + (Length_And_Family : out Sockaddr_Length_And_Family; + Family : Family_Type) + is + C_Family : C.int renames Families (Family); + Has_Sockaddr_Len : constant Boolean := SOSC.Has_Sockaddr_Len /= 0; + begin + if Has_Sockaddr_Len then + Length_And_Family.Length := Lengths (Family); + Length_And_Family.Char_Family := C.unsigned_char (C_Family); + else + Length_And_Family.Short_Family := C.unsigned_short (C_Family); + end if; + end Set_Family; + + -------------- + -- Set_Port -- + -------------- + + procedure Set_Port + (Sin : Sockaddr_In_Access; + Port : C.unsigned_short) + is + begin + Sin.Sin_Port := Port; + end Set_Port; + +end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/libgnat/g-sothco.ads b/gcc/ada/libgnat/g-sothco.ads new file mode 100644 index 0000000..64def59 --- /dev/null +++ b/gcc/ada/libgnat/g-sothco.ads @@ -0,0 +1,409 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N _ C O M M O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the target-independent part of the thin sockets mapping. +-- This package should not be directly with'ed by an applications program. + +with Ada.Unchecked_Conversion; + +with Interfaces.C; +with Interfaces.C.Pointers; + +package GNAT.Sockets.Thin_Common is + + package C renames Interfaces.C; + + Success : constant C.int := 0; + Failure : constant C.int := -1; + + type time_t is + range -2 ** (8 * SOSC.SIZEOF_tv_sec - 1) + .. 2 ** (8 * SOSC.SIZEOF_tv_sec - 1) - 1; + for time_t'Size use 8 * SOSC.SIZEOF_tv_sec; + pragma Convention (C, time_t); + + type suseconds_t is + range -2 ** (8 * SOSC.SIZEOF_tv_usec - 1) + .. 2 ** (8 * SOSC.SIZEOF_tv_usec - 1) - 1; + for suseconds_t'Size use 8 * SOSC.SIZEOF_tv_usec; + pragma Convention (C, suseconds_t); + + type Timeval is record + Tv_Sec : time_t; + Tv_Usec : suseconds_t; + end record; + pragma Convention (C, Timeval); + + type Timeval_Access is access all Timeval; + pragma Convention (C, Timeval_Access); + + Immediat : constant Timeval := (0, 0); + + ------------------------------------------- + -- Mapping tables to low level constants -- + ------------------------------------------- + + Families : constant array (Family_Type) of C.int := + (Family_Inet => SOSC.AF_INET, + Family_Inet6 => SOSC.AF_INET6); + + Lengths : constant array (Family_Type) of C.unsigned_char := + (Family_Inet => SOSC.SIZEOF_sockaddr_in, + Family_Inet6 => SOSC.SIZEOF_sockaddr_in6); + + ---------------------------- + -- Generic socket address -- + ---------------------------- + + -- Common header + + -- All socket address types (struct sockaddr, struct sockaddr_storage, + -- and protocol specific address types) start with the same 2-byte header, + -- which is either a length and a family (one byte each) or just a two-byte + -- family. The following unchecked union describes the two possible layouts + -- and is meant to be constrained with SOSC.Have_Sockaddr_Len. + + type Sockaddr_Length_And_Family + (Has_Sockaddr_Len : Boolean := False) + is record + case Has_Sockaddr_Len is + when True => + Length : C.unsigned_char; + Char_Family : C.unsigned_char; + + when False => + Short_Family : C.unsigned_short; + end case; + end record; + pragma Unchecked_Union (Sockaddr_Length_And_Family); + pragma Convention (C, Sockaddr_Length_And_Family); + + procedure Set_Family + (Length_And_Family : out Sockaddr_Length_And_Family; + Family : Family_Type); + -- Set the family component to the appropriate value for Family, and also + -- set Length accordingly if applicable on this platform. + + type Sockaddr is record + Sa_Family : Sockaddr_Length_And_Family; + -- Address family (and address length on some platforms) + + Sa_Data : C.char_array (1 .. 14) := (others => C.nul); + -- Family-specific data + -- Note that some platforms require that all unused (reserved) bytes + -- in addresses be initialized to 0 (e.g. VxWorks). + end record; + pragma Convention (C, Sockaddr); + -- Generic socket address + + type Sockaddr_Access is access all Sockaddr; + pragma Convention (C, Sockaddr_Access); + -- Access to socket address + + ---------------------------- + -- AF_INET socket address -- + ---------------------------- + + type In_Addr is record + S_B1, S_B2, S_B3, S_B4 : C.unsigned_char; + end record; + for In_Addr'Alignment use C.int'Alignment; + pragma Convention (C, In_Addr); + -- IPv4 address, represented as a network-order C.int. Note that the + -- underlying operating system may assume that values of this type have + -- C.int alignment, so we need to provide a suitable alignment clause here. + + function To_In_Addr is new Ada.Unchecked_Conversion (C.int, In_Addr); + function To_Int is new Ada.Unchecked_Conversion (In_Addr, C.int); + + 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_In is record + Sin_Family : Sockaddr_Length_And_Family; + -- Address family (and address length on some platforms) + + Sin_Port : C.unsigned_short; + -- Port in network byte order + + Sin_Addr : In_Addr; + -- IPv4 address + + Sin_Zero : C.char_array (1 .. 8) := (others => C.nul); + -- Padding + -- + -- Note that some platforms require that all unused (reserved) bytes + -- in addresses be initialized to 0 (e.g. VxWorks). + 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_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 + + ------------------ + -- Host entries -- + ------------------ + + type Hostent is new + System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_hostent); + for Hostent'Alignment use 8; + -- Host entry. This is an opaque type used only via the following + -- accessor functions, because 'struct hostent' has different layouts on + -- different platforms. + + type Hostent_Access is access all Hostent; + pragma Convention (C, Hostent_Access); + -- Access to host entry + + function Hostent_H_Name + (E : Hostent_Access) return System.Address; + + function Hostent_H_Alias + (E : Hostent_Access; I : C.int) return System.Address; + + function Hostent_H_Addrtype + (E : Hostent_Access) return C.int; + + function Hostent_H_Length + (E : Hostent_Access) return C.int; + + function Hostent_H_Addr + (E : Hostent_Access; Index : C.int) return System.Address; + + --------------------- + -- Service entries -- + --------------------- + + type Servent is new + System.Storage_Elements.Storage_Array (1 .. SOSC.SIZEOF_struct_servent); + for Servent'Alignment use 8; + -- Service entry. This is an opaque type used only via the following + -- accessor functions, because 'struct servent' has different layouts on + -- different platforms. + + type Servent_Access is access all Servent; + pragma Convention (C, Servent_Access); + -- Access to service entry + + function Servent_S_Name + (E : Servent_Access) return System.Address; + + function Servent_S_Alias + (E : Servent_Access; Index : C.int) return System.Address; + + function Servent_S_Port + (E : Servent_Access) return C.unsigned_short; + + function Servent_S_Proto + (E : Servent_Access) return System.Address; + + ------------------ + -- NetDB access -- + ------------------ + + -- There are three possible situations for the following NetDB access + -- functions: + -- - inherently thread safe (case of data returned in a thread specific + -- buffer); + -- - thread safe using user-provided buffer; + -- - thread unsafe. + -- + -- In the first and third cases, the Buf and Buflen are ignored. In the + -- second case, the caller must provide a buffer large enough to + -- accommodate the returned data. In the third case, the caller must ensure + -- that these functions are called within a critical section. + + function C_Gethostbyname + (Name : C.char_array; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function C_Gethostbyaddr + (Addr : System.Address; + Addr_Len : C.int; + Addr_Type : C.int; + Ret : not null access Hostent; + Buf : System.Address; + Buflen : C.int; + H_Errnop : not null access C.int) return C.int; + + function C_Getservbyname + (Name : C.char_array; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + + function C_Getservbyport + (Port : C.int; + Proto : C.char_array; + Ret : not null access Servent; + Buf : System.Address; + Buflen : C.int) return C.int; + + ------------------------------------ + -- Scatter/gather vector handling -- + ------------------------------------ + + type Msghdr is record + Msg_Name : System.Address; + Msg_Namelen : C.unsigned; + Msg_Iov : System.Address; + Msg_Iovlen : SOSC.Msg_Iovlen_T; + Msg_Control : System.Address; + Msg_Controllen : C.size_t; + Msg_Flags : C.int; + end record; + pragma Convention (C, Msghdr); + + ---------------------------- + -- Socket sets management -- + ---------------------------- + + procedure Get_Socket_From_Set + (Set : access Fd_Set; + Last : access C.int; + Socket : access C.int); + -- 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 : access Fd_Set; + Socket : C.int); + -- Insert socket in the socket set + + function Is_Socket_In_Set + (Set : access constant Fd_Set; + Socket : C.int) return C.int; + -- Check whether Socket is in the socket set, return a non-zero + -- value if it is, zero if it is not. + + procedure Last_Socket_In_Set + (Set : access Fd_Set; + Last : access C.int); + -- 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. + + procedure Remove_Socket_From_Set (Set : access Fd_Set; Socket : C.int); + -- Remove socket from the socket set + + procedure Reset_Socket_Set (Set : access Fd_Set); + -- Make Set empty + + ------------------------------------------ + -- Pairs of signalling file descriptors -- + ------------------------------------------ + + type Two_Ints is array (0 .. 1) of C.int; + pragma Convention (C, Two_Ints); + -- Container for two int values + + subtype Fd_Pair is Two_Ints; + -- Two_Ints as used for Create_Signalling_Fds: a pair of connected file + -- descriptors, one of which (the "read end" of the connection) being used + -- for reading, the other one (the "write end") being used for writing. + + Read_End : constant := 0; + Write_End : constant := 1; + -- Indexes into an Fd_Pair value providing access to each of the connected + -- file descriptors. + + function Inet_Pton + (Af : C.int; + Cp : System.Address; + Inp : System.Address) return C.int; + + function C_Ioctl + (Fd : C.int; + Req : SOSC.IOCTL_Req_T; + Arg : access C.int) return C.int; + +private + 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, Insert_Socket_In_Set, "__gnat_insert_socket_in_set"); + pragma Import (C, Remove_Socket_From_Set, "__gnat_remove_socket_from_set"); + pragma Import (C, Reset_Socket_Set, "__gnat_reset_socket_set"); + pragma Import (C, C_Ioctl, "__gnat_socket_ioctl"); + pragma Import (C, Inet_Pton, SOSC.Inet_Pton_Linkname); + + pragma Import (C, C_Gethostbyname, "__gnat_gethostbyname"); + pragma Import (C, C_Gethostbyaddr, "__gnat_gethostbyaddr"); + pragma Import (C, C_Getservbyname, "__gnat_getservbyname"); + pragma Import (C, C_Getservbyport, "__gnat_getservbyport"); + + pragma Import (C, Servent_S_Name, "__gnat_servent_s_name"); + pragma Import (C, Servent_S_Alias, "__gnat_servent_s_alias"); + pragma Import (C, Servent_S_Port, "__gnat_servent_s_port"); + pragma Import (C, Servent_S_Proto, "__gnat_servent_s_proto"); + + pragma Import (C, Hostent_H_Name, "__gnat_hostent_h_name"); + pragma Import (C, Hostent_H_Alias, "__gnat_hostent_h_alias"); + pragma Import (C, Hostent_H_Addrtype, "__gnat_hostent_h_addrtype"); + pragma Import (C, Hostent_H_Length, "__gnat_hostent_h_length"); + pragma Import (C, Hostent_H_Addr, "__gnat_hostent_h_addr"); + +end GNAT.Sockets.Thin_Common; diff --git a/gcc/ada/libgnat/g-souinf.ads b/gcc/ada/libgnat/g-souinf.ads new file mode 100644 index 0000000..f050511 --- /dev/null +++ b/gcc/ada/libgnat/g-souinf.ads @@ -0,0 +1,96 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S O U R C E _ I N F O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides some useful utility subprograms that provide access +-- to source code information known at compile time. These subprograms are +-- intrinsic operations that provide information known to the compiler in +-- a form that can be embedded into the source program for identification +-- and logging purposes. For example, an exception handler can print out +-- the name of the source file in which the exception is handled. + +package GNAT.Source_Info is + pragma Preelaborate; + -- Note that this unit is Preelaborate, but not Pure, that's because the + -- functions here such as Line are clearly not pure functions, and normally + -- we mark intrinsic functions in a Pure unit as Pure, even though they are + -- imported. + -- + -- Historical note: this used to be Pure, but that was when we marked all + -- intrinsics as not Pure, even in Pure units, so no problems arose. + + function File return String with + Import, Convention => Intrinsic; + -- Return the name of the current file, not including the path information. + -- The result is considered to be a static string constant. + + function Line return Positive with + Import, Convention => Intrinsic; + -- Return the current input line number. The result is considered to be a + -- static expression. + + function Source_Location return String with + Import, Convention => Intrinsic; + -- Return a string literal of the form "name:line", where name is the + -- current source file name without path information, and line is the + -- current line number. In the event that instantiations are involved, + -- additional suffixes of the same form are appended after the separating + -- string " instantiated at ". The result is considered to be a static + -- string constant. + + function Enclosing_Entity return String with + Import, Convention => Intrinsic; + -- Return the name of the current subprogram, package, task, entry or + -- protected subprogram. The string is in exactly the form used for the + -- declaration of the entity (casing and encoding conventions), and is + -- considered to be a static string constant. The name is fully qualified + -- using periods where possible (this is not always possible, notably in + -- the case of entities appearing in unnamed block statements.) + -- + -- Note: if this function is used at the outer level of a generic package, + -- the string returned will be the name of the instance, not the generic + -- package itself. This is useful in identifying and logging information + -- from within generic templates. + + function Compilation_ISO_Date return String with + Import, Convention => Intrinsic; + -- Returns date of compilation as a static string "yyyy-mm-dd". + + function Compilation_Date return String with + Import, Convention => Intrinsic; + -- Returns date of compilation as a static string "mmm dd yyyy". This is + -- in local time form, and is exactly compatible with C macro __DATE__. + + function Compilation_Time return String with + Import, Convention => Intrinsic; + -- Returns GMT time of compilation as a static string "hh:mm:ss". This is + -- in local time form, and is exactly compatible with C macro __TIME__. + +end GNAT.Source_Info; diff --git a/gcc/ada/libgnat/g-spchge.adb b/gcc/ada/libgnat/g-spchge.adb new file mode 100644 index 0000000..55c9141 --- /dev/null +++ b/gcc/ada/libgnat/g-spchge.adb @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S P E L L I N G _ C H E C K E R _ G E N E R I C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body GNAT.Spelling_Checker_Generic is + + ------------------------ + -- Is_Bad_Spelling_Of -- + ------------------------ + + function Is_Bad_Spelling_Of + (Found : String_Type; + Expect : String_Type) return Boolean + is + FN : constant Natural := Found'Length; + FF : constant Natural := Found'First; + FL : constant Natural := Found'Last; + + EN : constant Natural := Expect'Length; + EF : constant Natural := Expect'First; + EL : constant Natural := Expect'Last; + + Letter_o : constant Char_Type := Char_Type'Val (Character'Pos ('o')); + Digit_0 : constant Char_Type := Char_Type'Val (Character'Pos ('0')); + Digit_9 : constant Char_Type := Char_Type'Val (Character'Pos ('9')); + + begin + -- If both strings null, then we consider this a match, but if one + -- is null and the other is not, then we definitely do not match + + if FN = 0 then + return (EN = 0); + + elsif EN = 0 then + return False; + + -- If first character does not match, then we consider that this is + -- definitely not a misspelling. An exception is when we expect a + -- letter O and found a zero. + + elsif Found (FF) /= Expect (EF) + and then (Found (FF) /= Digit_0 or else Expect (EF) /= Letter_o) + then + return False; + + -- Not a bad spelling if both strings are 1-2 characters long + + elsif FN < 3 and then EN < 3 then + return False; + + -- Lengths match. Execute loop to check for a single error, single + -- transposition or exact match (we only fall through this loop if + -- one of these three conditions is found). + + elsif FN = EN then + for J in 1 .. FN - 2 loop + if Expect (EF + J) /= Found (FF + J) then + + -- If both mismatched characters are digits, then we do + -- not consider it a misspelling (e.g. B345 is not a + -- misspelling of B346, it is something quite different) + + if Expect (EF + J) in Digit_0 .. Digit_9 + and then Found (FF + J) in Digit_0 .. Digit_9 + then + return False; + + elsif Expect (EF + J + 1) = Found (FF + J + 1) + and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL) + then + return True; + + elsif Expect (EF + J) = Found (FF + J + 1) + and then Expect (EF + J + 1) = Found (FF + J) + and then Expect (EF + J + 2 .. EL) = Found (FF + J + 2 .. FL) + then + return True; + + else + return False; + end if; + end if; + end loop; + + -- At last character. Test digit case as above, otherwise we + -- have a match since at most this last character fails to match. + + if Expect (EL) in Digit_0 .. Digit_9 + and then Found (FL) in Digit_0 .. Digit_9 + and then Expect (EL) /= Found (FL) + then + return False; + else + return True; + end if; + + -- Length is 1 too short. Execute loop to check for single deletion + + elsif FN = EN - 1 then + for J in 1 .. FN - 1 loop + if Found (FF + J) /= Expect (EF + J) then + return Found (FF + J .. FL) = Expect (EF + J + 1 .. EL); + end if; + end loop; + + -- If we fall through then the last character was missing, which + -- we consider to be a match (e.g. found xyz, expected xyza). + + return True; + + -- Length is 1 too long. Execute loop to check for single insertion + + elsif FN = EN + 1 then + for J in 1 .. EN - 1 loop + if Found (FF + J) /= Expect (EF + J) then + return Found (FF + J + 1 .. FL) = Expect (EF + J .. EL); + end if; + end loop; + + -- If we fall through then the last character was an additional + -- character, which is a match (e.g. found xyza, expected xyz). + + return True; + + -- Length is completely wrong + + else + return False; + end if; + end Is_Bad_Spelling_Of; + +end GNAT.Spelling_Checker_Generic; diff --git a/gcc/ada/libgnat/g-spchge.ads b/gcc/ada/libgnat/g-spchge.ads new file mode 100644 index 0000000..cc2179e --- /dev/null +++ b/gcc/ada/libgnat/g-spchge.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S P E L L I N G _ C H E C K E R _ G E N E R I C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Spelling checker + +-- This package provides a utility generic routine for checking for bad +-- spellings. This routine must be instantiated with an appropriate array +-- element type, which must represent a character encoding in which the +-- codes for ASCII characters in the range 16#20#..16#7F# have their normal +-- expected encoding values (e.g. the Pos value 16#31# must be digit 1). + +pragma Compiler_Unit_Warning; + +package GNAT.Spelling_Checker_Generic is + pragma Pure; + + generic + type Char_Type is (<>); + -- See above for restrictions on what types can be used here + + type String_Type is array (Positive range <>) of Char_Type; + + function Is_Bad_Spelling_Of + (Found : String_Type; + Expect : String_Type) return Boolean; + -- Determines if the string Found is a plausible misspelling of the string + -- Expect. Returns True for an exact match or a probably misspelling, False + -- if no near match is detected. This routine is case sensitive, so the + -- caller should fold both strings to get a case insensitive match if the + -- character encoding represents upper/lower case. + -- + -- Note: the spec of this routine is deliberately rather vague. This + -- routine is the one used by GNAT itself to detect misspelled keywords + -- and identifiers, and is heuristically adjusted to be appropriate to + -- this usage. It will work well in any similar case of named entities. + +end GNAT.Spelling_Checker_Generic; diff --git a/gcc/ada/libgnat/g-speche.adb b/gcc/ada/libgnat/g-speche.adb new file mode 100644 index 0000000..db6714e --- /dev/null +++ b/gcc/ada/libgnat/g-speche.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S P E L L I N G _ C H E C K E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with GNAT.Spelling_Checker_Generic; + +package body GNAT.Spelling_Checker is + + function IBS is new + GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of + (Character, String); + + ------------------------ + -- Is_Bad_Spelling_Of -- + ------------------------ + + function Is_Bad_Spelling_Of + (Found : String; + Expect : String) return Boolean + renames IBS; + +end GNAT.Spelling_Checker; diff --git a/gcc/ada/libgnat/g-speche.ads b/gcc/ada/libgnat/g-speche.ads new file mode 100644 index 0000000..501ed7b --- /dev/null +++ b/gcc/ada/libgnat/g-speche.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . S P E L L I N G _ C H E C K E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Spelling checker + +-- This package provides a utility routine for checking for bad spellings +-- for the case of String arguments. + +pragma Compiler_Unit_Warning; + +package GNAT.Spelling_Checker is + pragma Pure; + + function Is_Bad_Spelling_Of + (Found : String; + Expect : String) return Boolean; + -- Determines if the string Found is a plausible misspelling of the string + -- Expect. Returns True for an exact match or a probably misspelling, False + -- if no near match is detected. This routine is case sensitive, so the + -- caller should fold both strings to get a case insensitive match. + -- + -- Note: the spec of this routine is deliberately rather vague. It is used + -- by GNAT itself to detect misspelled keywords and identifiers, and is + -- heuristically adjusted to be appropriate to this usage. It will work + -- well in any similar case of named entities. + +end GNAT.Spelling_Checker; diff --git a/gcc/ada/libgnat/g-spipat.adb b/gcc/ada/libgnat/g-spipat.adb new file mode 100644 index 0000000..194a335 --- /dev/null +++ b/gcc/ada/libgnat/g-spipat.adb @@ -0,0 +1,6489 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . P A T T E R N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the data structures and general approach used in this implementation +-- are derived from the original MINIMAL sources for SPITBOL. The code is not +-- a direct translation, but the approach is followed closely. In particular, +-- we use the one stack approach developed in the SPITBOL implementation. + +with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; + +with System; use System; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body GNAT.Spitbol.Patterns is + + ------------------------ + -- Internal Debugging -- + ------------------------ + + Internal_Debug : constant Boolean := False; + -- Set this flag to True to activate some built-in debugging traceback + -- These are all lines output with PutD and Put_LineD. + + procedure New_LineD; + pragma Inline (New_LineD); + -- Output new blank line with New_Line if Internal_Debug is True + + procedure PutD (Str : String); + pragma Inline (PutD); + -- Output string with Put if Internal_Debug is True + + procedure Put_LineD (Str : String); + pragma Inline (Put_LineD); + -- Output string with Put_Line if Internal_Debug is True + + ----------------------------- + -- Local Type Declarations -- + ----------------------------- + + subtype String_Ptr is Ada.Strings.Unbounded.String_Access; + subtype File_Ptr is Ada.Text_IO.File_Access; + + function To_Address is new Ada.Unchecked_Conversion (PE_Ptr, Address); + -- Used only for debugging output purposes + + subtype AFC is Ada.Finalization.Controlled; + + N : constant PE_Ptr := null; + -- Shorthand used to initialize Copy fields to null + + type Natural_Ptr is access all Natural; + type Pattern_Ptr is access all Pattern; + + -------------------------------------------------- + -- Description of Algorithm and Data Structures -- + -------------------------------------------------- + + -- A pattern structure is represented as a linked graph of nodes + -- with the following structure: + + -- +------------------------------------+ + -- I Pcode I + -- +------------------------------------+ + -- I Index I + -- +------------------------------------+ + -- I Pthen I + -- +------------------------------------+ + -- I parameter(s) I + -- +------------------------------------+ + + -- Pcode is a code value indicating the type of the pattern node. This + -- code is used both as the discriminant value for the record, and as + -- the case index in the main match routine that branches to the proper + -- match code for the given element. + + -- Index is a serial index number. The use of these serial index + -- numbers is described in a separate section. + + -- Pthen is a pointer to the successor node, i.e the node to be matched + -- if the attempt to match the node succeeds. If this is the last node + -- of the pattern to be matched, then Pthen points to a dummy node + -- of kind PC_EOP (end of pattern), which initializes pattern exit. + + -- The parameter or parameters are present for certain node types, + -- and the type varies with the pattern code. + + type Pattern_Code is ( + PC_Arb_Y, + PC_Assign, + PC_Bal, + PC_BreakX_X, + PC_Cancel, + PC_EOP, + PC_Fail, + PC_Fence, + PC_Fence_X, + PC_Fence_Y, + PC_R_Enter, + PC_R_Remove, + PC_R_Restore, + PC_Rest, + PC_Succeed, + PC_Unanchored, + + PC_Alt, + PC_Arb_X, + PC_Arbno_S, + PC_Arbno_X, + + PC_Rpat, + + PC_Pred_Func, + + PC_Assign_Imm, + PC_Assign_OnM, + PC_Any_VP, + PC_Break_VP, + PC_BreakX_VP, + PC_NotAny_VP, + PC_NSpan_VP, + PC_Span_VP, + PC_String_VP, + + PC_Write_Imm, + PC_Write_OnM, + + PC_Null, + PC_String, + + PC_String_2, + PC_String_3, + PC_String_4, + PC_String_5, + PC_String_6, + + PC_Setcur, + + PC_Any_CH, + PC_Break_CH, + PC_BreakX_CH, + PC_Char, + PC_NotAny_CH, + PC_NSpan_CH, + PC_Span_CH, + + PC_Any_CS, + PC_Break_CS, + PC_BreakX_CS, + PC_NotAny_CS, + PC_NSpan_CS, + PC_Span_CS, + + PC_Arbno_Y, + PC_Len_Nat, + PC_Pos_Nat, + PC_RPos_Nat, + PC_RTab_Nat, + PC_Tab_Nat, + + PC_Pos_NF, + PC_Len_NF, + PC_RPos_NF, + PC_RTab_NF, + PC_Tab_NF, + + PC_Pos_NP, + PC_Len_NP, + PC_RPos_NP, + PC_RTab_NP, + PC_Tab_NP, + + PC_Any_VF, + PC_Break_VF, + PC_BreakX_VF, + PC_NotAny_VF, + PC_NSpan_VF, + PC_Span_VF, + PC_String_VF); + + type IndexT is range 0 .. +(2 **15 - 1); + + type PE (Pcode : Pattern_Code) is record + + Index : IndexT; + -- Serial index number of pattern element within pattern + + Pthen : PE_Ptr; + -- Successor element, to be matched after this one + + case Pcode is + when PC_Arb_Y + | PC_Assign + | PC_Bal + | PC_BreakX_X + | PC_Cancel + | PC_EOP + | PC_Fail + | PC_Fence + | PC_Fence_X + | PC_Fence_Y + | PC_Null + | PC_R_Enter + | PC_R_Remove + | PC_R_Restore + | PC_Rest + | PC_Succeed + | PC_Unanchored + => + null; + + when PC_Alt + | PC_Arb_X + | PC_Arbno_S + | PC_Arbno_X + => + Alt : PE_Ptr; + + when PC_Rpat => + PP : Pattern_Ptr; + + when PC_Pred_Func => + BF : Boolean_Func; + + when PC_Assign_Imm + | PC_Assign_OnM + | PC_Any_VP + | PC_Break_VP + | PC_BreakX_VP + | PC_NotAny_VP + | PC_NSpan_VP + | PC_Span_VP + | PC_String_VP + => + VP : VString_Ptr; + + when PC_Write_Imm + | PC_Write_OnM + => + FP : File_Ptr; + + when PC_String => + Str : String_Ptr; + + when PC_String_2 => + Str2 : String (1 .. 2); + + when PC_String_3 => + Str3 : String (1 .. 3); + + when PC_String_4 => + Str4 : String (1 .. 4); + + when PC_String_5 => + Str5 : String (1 .. 5); + + when PC_String_6 => + Str6 : String (1 .. 6); + + when PC_Setcur => + Var : Natural_Ptr; + + when PC_Any_CH + | PC_Break_CH + | PC_BreakX_CH + | PC_Char + | PC_NotAny_CH + | PC_NSpan_CH + | PC_Span_CH + => + Char : Character; + + when PC_Any_CS + | PC_Break_CS + | PC_BreakX_CS + | PC_NotAny_CS + | PC_NSpan_CS + | PC_Span_CS + => + CS : Character_Set; + + when PC_Arbno_Y + | PC_Len_Nat + | PC_Pos_Nat + | PC_RPos_Nat + | PC_RTab_Nat + | PC_Tab_Nat + => + Nat : Natural; + + when PC_Pos_NF + | PC_Len_NF + | PC_RPos_NF + | PC_RTab_NF + | PC_Tab_NF + => + NF : Natural_Func; + + when PC_Pos_NP + | PC_Len_NP + | PC_RPos_NP + | PC_RTab_NP + | PC_Tab_NP + => + NP : Natural_Ptr; + + when PC_Any_VF + | PC_Break_VF + | PC_BreakX_VF + | PC_NotAny_VF + | PC_NSpan_VF + | PC_Span_VF + | PC_String_VF + => + VF : VString_Func; + end case; + end record; + + subtype PC_Has_Alt is Pattern_Code range PC_Alt .. PC_Arbno_X; + -- Range of pattern codes that has an Alt field. This is used in the + -- recursive traversals, since these links must be followed. + + EOP_Element : aliased constant PE := (PC_EOP, 0, N); + -- This is the end of pattern element, and is thus the representation of + -- a null pattern. It has a zero index element since it is never placed + -- inside a pattern. Furthermore it does not need a successor, since it + -- marks the end of the pattern, so that no more successors are needed. + + EOP : constant PE_Ptr := EOP_Element'Unrestricted_Access; + -- This is the end of pattern pointer, that is used in the Pthen pointer + -- of other nodes to signal end of pattern. + + -- The following array is used to determine if a pattern used as an + -- argument for Arbno is eligible for treatment using the simple Arbno + -- structure (i.e. it is a pattern that is guaranteed to match at least + -- one character on success, and not to make any entries on the stack. + + OK_For_Simple_Arbno : constant array (Pattern_Code) of Boolean := + (PC_Any_CS | + PC_Any_CH | + PC_Any_VF | + PC_Any_VP | + PC_Char | + PC_Len_Nat | + PC_NotAny_CS | + PC_NotAny_CH | + PC_NotAny_VF | + PC_NotAny_VP | + PC_Span_CS | + PC_Span_CH | + PC_Span_VF | + PC_Span_VP | + PC_String | + PC_String_2 | + PC_String_3 | + PC_String_4 | + PC_String_5 | + PC_String_6 => True, + others => False); + + ------------------------------- + -- The Pattern History Stack -- + ------------------------------- + + -- The pattern history stack is used for controlling backtracking when + -- a match fails. The idea is to stack entries that give a cursor value + -- to be restored, and a node to be reestablished as the current node to + -- attempt an appropriate rematch operation. The processing for a pattern + -- element that has rematch alternatives pushes an appropriate entry or + -- entry on to the stack, and the proceeds. If a match fails at any point, + -- the top element of the stack is popped off, resetting the cursor and + -- the match continues by accessing the node stored with this entry. + + type Stack_Entry is record + + Cursor : Integer; + -- Saved cursor value that is restored when this entry is popped + -- from the stack if a match attempt fails. Occasionally, this + -- field is used to store a history stack pointer instead of a + -- cursor. Such cases are noted in the documentation and the value + -- stored is negative since stack pointer values are always negative. + + Node : PE_Ptr; + -- This pattern element reference is reestablished as the current + -- Node to be matched (which will attempt an appropriate rematch). + + end record; + + subtype Stack_Range is Integer range -Stack_Size .. -1; + + type Stack_Type is array (Stack_Range) of Stack_Entry; + -- The type used for a history stack. The actual instance of the stack + -- is declared as a local variable in the Match routine, to properly + -- handle recursive calls to Match. All stack pointer values are negative + -- to distinguish them from normal cursor values. + + -- Note: the pattern matching stack is used only to handle backtracking. + -- If no backtracking occurs, its entries are never accessed, and never + -- popped off, and in particular it is normal for a successful match + -- to terminate with entries on the stack that are simply discarded. + + -- Note: in subsequent diagrams of the stack, we always place element + -- zero (the deepest element) at the top of the page, then build the + -- stack down on the page with the most recent (top of stack) element + -- being the bottom-most entry on the page. + + -- Stack checking is handled by labeling every pattern with the maximum + -- number of stack entries that are required, so a single check at the + -- start of matching the pattern suffices. There are two exceptions. + + -- First, the count does not include entries for recursive pattern + -- references. Such recursions must therefore perform a specific + -- stack check with respect to the number of stack entries required + -- by the recursive pattern that is accessed and the amount of stack + -- that remains unused. + + -- Second, the count includes only one iteration of an Arbno pattern, + -- so a specific check must be made on subsequent iterations that there + -- is still enough stack space left. The Arbno node has a field that + -- records the number of stack entries required by its argument for + -- this purpose. + + --------------------------------------------------- + -- Use of Serial Index Field in Pattern Elements -- + --------------------------------------------------- + + -- The serial index numbers for the pattern elements are assigned as + -- a pattern is constructed from its constituent elements. Note that there + -- is never any sharing of pattern elements between patterns (copies are + -- always made), so the serial index numbers are unique to a particular + -- pattern as referenced from the P field of a value of type Pattern. + + -- The index numbers meet three separate invariants, which are used for + -- various purposes as described in this section. + + -- First, the numbers uniquely identify the pattern elements within a + -- pattern. If Num is the number of elements in a given pattern, then + -- the serial index numbers for the elements of this pattern will range + -- from 1 .. Num, so that each element has a separate value. + + -- The purpose of this assignment is to provide a convenient auxiliary + -- data structure mechanism during operations which must traverse a + -- pattern (e.g. copy and finalization processing). Once constructed + -- patterns are strictly read only. This is necessary to allow sharing + -- of patterns between tasks. This means that we cannot go marking the + -- pattern (e.g. with a visited bit). Instead we construct a separate + -- vector that contains the necessary information indexed by the Index + -- values in the pattern elements. For this purpose the only requirement + -- is that they be uniquely assigned. + + -- Second, the pattern element referenced directly, i.e. the leading + -- pattern element, is always the maximum numbered element and therefore + -- indicates the total number of elements in the pattern. More precisely, + -- the element referenced by the P field of a pattern value, or the + -- element returned by any of the internal pattern construction routines + -- in the body (that return a value of type PE_Ptr) always is this + -- maximum element, + + -- The purpose of this requirement is to allow an immediate determination + -- of the number of pattern elements within a pattern. This is used to + -- properly size the vectors used to contain auxiliary information for + -- traversal as described above. + + -- Third, as compound pattern structures are constructed, the way in which + -- constituent parts of the pattern are constructed is stylized. This is + -- an automatic consequence of the way that these compound structures + -- are constructed, and basically what we are doing is simply documenting + -- and specifying the natural result of the pattern construction. The + -- section describing compound pattern structures gives details of the + -- numbering of each compound pattern structure. + + -- The purpose of specifying the stylized numbering structures for the + -- compound patterns is to help simplify the processing in the Image + -- function, since it eases the task of retrieving the original recursive + -- structure of the pattern from the flat graph structure of elements. + -- This use in the Image function is the only point at which the code + -- makes use of the stylized structures. + + type Ref_Array is array (IndexT range <>) of PE_Ptr; + -- This type is used to build an array whose N'th entry references the + -- element in a pattern whose Index value is N. See Build_Ref_Array. + + procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array); + -- Given a pattern element which is the leading element of a pattern + -- structure, and a Ref_Array with bounds 1 .. E.Index, fills in the + -- Ref_Array so that its N'th entry references the element of the + -- referenced pattern whose Index value is N. + + ------------------------------- + -- Recursive Pattern Matches -- + ------------------------------- + + -- The pattern primitive (+P) where P is a Pattern_Ptr or Pattern_Func + -- causes a recursive pattern match. This cannot be handled by an actual + -- recursive call to the outer level Match routine, since this would not + -- allow for possible backtracking into the region matched by the inner + -- pattern. Indeed this is the classical clash between recursion and + -- backtracking, and a simple recursive stack structure does not suffice. + + -- This section describes how this recursion and the possible associated + -- backtracking is handled. We still use a single stack, but we establish + -- the concept of nested regions on this stack, each of which has a stack + -- base value pointing to the deepest stack entry of the region. The base + -- value for the outer level is zero. + + -- When a recursive match is established, two special stack entries are + -- made. The first entry is used to save the original node that starts + -- the recursive match. This is saved so that the successor field of + -- this node is accessible at the end of the match, but it is never + -- popped and executed. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the recursive pattern is matched and + -- it can make history stack entries in the normal matter, so now + -- the stack looks like: + + -- (stack entries made by outer level) + + -- (Special entry, node is (+P) successor + -- cursor entry is not used) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack base + -- saved base value for the enclosing region) + + -- (stack entries made by inner level) + + -- If a subsequent failure occurs and pops the PC_R_Remove node, it + -- removes itself and the special entry immediately underneath it, + -- restores the stack base value for the enclosing region, and then + -- again signals failure to look for alternatives that were stacked + -- before the recursion was initiated. + + -- Now we need to consider what happens if the inner pattern succeeds, as + -- signalled by accessing the special PC_EOP pattern primitive. First we + -- recognize the nested case by looking at the Base value. If this Base + -- value is Stack'First, then the entire match has succeeded, but if the + -- base value is greater than Stack'First, then we have successfully + -- matched an inner pattern, and processing continues at the outer level. + + -- There are two cases. The simple case is when the inner pattern has made + -- no stack entries, as recognized by the fact that the current stack + -- pointer is equal to the current base value. In this case it is fine to + -- remove all trace of the recursion by restoring the outer base value and + -- using the special entry to find the appropriate successor node. + + -- The more complex case arises when the inner match does make stack + -- entries. In this case, the PC_EOP processing stacks a special entry + -- whose cursor value saves the saved inner base value (the one that + -- references the corresponding PC_R_Remove value), and whose node + -- pointer references a PC_R_Restore node, so the stack looks like: + + -- (stack entries made by outer level) + + -- (Special entry, node is (+P) successor, + -- cursor entry is not used) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by inner level) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If the entire match succeeds, then these stack entries are, as usual, + -- ignored and abandoned. If on the other hand a subsequent failure + -- causes the PC_Region_Replace entry to be popped, it restores the + -- inner base value from its saved "cursor" value and then fails again. + -- Note that it is OK that the cursor is temporarily clobbered by this + -- pop, since the second failure will reestablish a proper cursor value. + + --------------------------------- + -- Compound Pattern Structures -- + --------------------------------- + + -- This section discusses the compound structures used to represent + -- constructed patterns. It shows the graph structures of pattern + -- elements that are constructed, and in the case of patterns that + -- provide backtracking possibilities, describes how the history + -- stack is used to control the backtracking. Finally, it notes the + -- way in which the Index numbers are assigned to the structure. + + -- In all diagrams, solid lines (built with minus signs or vertical + -- bars, represent successor pointers (Pthen fields) with > or V used + -- to indicate the direction of the pointer. The initial node of the + -- structure is in the upper left of the diagram. A dotted line is an + -- alternative pointer from the element above it to the element below + -- it. See individual sections for details on how alternatives are used. + + ------------------- + -- Concatenation -- + ------------------- + + -- In the pattern structures listed in this section, a line that looks + -- like ----> with nothing to the right indicates an end of pattern + -- (EOP) pointer that represents the end of the match. + + -- When a pattern concatenation (L & R) occurs, the resulting structure + -- is obtained by finding all such EOP pointers in L, and replacing + -- them to point to R. This is the most important flattening that + -- occurs in constructing a pattern, and it means that the pattern + -- matching circuitry does not have to keep track of the structure + -- of a pattern with respect to concatenation, since the appropriate + -- successor is always at hand. + + -- Concatenation itself generates no additional possibilities for + -- backtracking, but the constituent patterns of the concatenated + -- structure will make stack entries as usual. The maximum amount + -- of stack required by the structure is thus simply the sum of the + -- maximums required by L and R. + + -- The index numbering of a concatenation structure works by leaving + -- the numbering of the right hand pattern, R, unchanged and adjusting + -- the numbers in the left hand pattern, L up by the count of elements + -- in R. This ensures that the maximum numbered element is the leading + -- element as required (given that it was the leading element in L). + + ----------------- + -- Alternation -- + ----------------- + + -- A pattern (L or R) constructs the structure: + + -- +---+ +---+ + -- | A |---->| L |----> + -- +---+ +---+ + -- . + -- . + -- +---+ + -- | R |----> + -- +---+ + + -- The A element here is a PC_Alt node, and the dotted line represents + -- the contents of the Alt field. When the PC_Alt element is matched, + -- it stacks a pointer to the leading element of R on the history stack + -- so that on subsequent failure, a match of R is attempted. + + -- The A node is the highest numbered element in the pattern. The + -- original index numbers of R are unchanged, but the index numbers + -- of the L pattern are adjusted up by the count of elements in R. + + -- Note that the difference between the index of the L leading element + -- the index of the R leading element (after building the alt structure) + -- indicates the number of nodes in L, and this is true even after the + -- structure is incorporated into some larger structure. For example, + -- if the A node has index 16, and L has index 15 and R has index + -- 5, then we know that L has 10 (15-5) elements in it. + + -- Suppose that we now concatenate this structure to another pattern + -- with 9 elements in it. We will now have the A node with an index + -- of 25, L with an index of 24 and R with an index of 14. We still + -- know that L has 10 (24-14) elements in it, numbered 15-24, and + -- consequently the successor of the alternation structure has an + -- index with a value less than 15. This is used in Image to figure + -- out the original recursive structure of a pattern. + + -- To clarify the interaction of the alternation and concatenation + -- structures, here is a more complex example of the structure built + -- for the pattern: + + -- (V or W or X) (Y or Z) + + -- where A,B,C,D,E are all single element patterns: + + -- +---+ +---+ +---+ +---+ + -- I A I---->I V I---+-->I A I---->I Y I----> + -- +---+ +---+ I +---+ +---+ + -- . I . + -- . I . + -- +---+ +---+ I +---+ + -- I A I---->I W I-->I I Z I----> + -- +---+ +---+ I +---+ + -- . I + -- . I + -- +---+ I + -- I X I------------>+ + -- +---+ + + -- The numbering of the nodes would be as follows: + + -- +---+ +---+ +---+ +---+ + -- I 8 I---->I 7 I---+-->I 3 I---->I 2 I----> + -- +---+ +---+ I +---+ +---+ + -- . I . + -- . I . + -- +---+ +---+ I +---+ + -- I 6 I---->I 5 I-->I I 1 I----> + -- +---+ +---+ I +---+ + -- . I + -- . I + -- +---+ I + -- I 4 I------------>+ + -- +---+ + + -- Note: The above structure actually corresponds to + + -- (A or (B or C)) (D or E) + + -- rather than + + -- ((A or B) or C) (D or E) + + -- which is the more natural interpretation, but in fact alternation + -- is associative, and the construction of an alternative changes the + -- left grouped pattern to the right grouped pattern in any case, so + -- that the Image function produces a more natural looking output. + + --------- + -- Arb -- + --------- + + -- An Arb pattern builds the structure + + -- +---+ + -- | X |----> + -- +---+ + -- . + -- . + -- +---+ + -- | Y |----> + -- +---+ + + -- The X node is a PC_Arb_X node, which matches null, and stacks a + -- pointer to Y node, which is the PC_Arb_Y node that matches one + -- extra character and restacks itself. + + -- The PC_Arb_X node is numbered 2, and the PC_Arb_Y node is 1 + + ------------------------- + -- Arbno (simple case) -- + ------------------------- + + -- The simple form of Arbno can be used where the pattern always + -- matches at least one character if it succeeds, and it is known + -- not to make any history stack entries. In this case, Arbno (P) + -- can construct the following structure: + + -- +-------------+ + -- | ^ + -- V | + -- +---+ | + -- | S |----> | + -- +---+ | + -- . | + -- . | + -- +---+ | + -- | P |---------->+ + -- +---+ + + -- The S (PC_Arbno_S) node matches null stacking a pointer to the + -- pattern P. If a subsequent failure causes P to be matched and + -- this match succeeds, then node A gets restacked to try another + -- instance if needed by a subsequent failure. + + -- The node numbering of the constituent pattern P is not affected. + -- The S node has a node number of P.Index + 1. + + -------------------------- + -- Arbno (complex case) -- + -------------------------- + + -- A call to Arbno (P), where P can match null (or at least is not + -- known to require a non-null string) and/or P requires pattern stack + -- entries, constructs the following structure: + + -- +--------------------------+ + -- | ^ + -- V | + -- +---+ | + -- | X |----> | + -- +---+ | + -- . | + -- . | + -- +---+ +---+ +---+ | + -- | E |---->| P |---->| Y |--->+ + -- +---+ +---+ +---+ + + -- The node X (PC_Arbno_X) matches null, stacking a pointer to the + -- E-P-X structure used to match one Arbno instance. + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry whose node field is + -- not used at all, and whose cursor field has the initial cursor. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped and + -- it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node Y, the PC_Arbno_Y node, pops + -- the inner region. There are two possibilities. If matching P left + -- no stack entries, then all traces of the inner region can be removed. + -- If there are stack entries, then we push an PC_Region_Replace stack + -- entry whose "cursor" value is the inner stack base value, and then + -- restore the outer stack base value, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- Now that we have matched another instance of the Arbno pattern, + -- we need to move to the successor. There are two cases. If the + -- Arbno pattern matched null, then there is no point in seeking + -- alternatives, since we would just match a whole bunch of nulls. + -- In this case we look through the alternative node, and move + -- directly to its successor (i.e. the successor of the Arbno + -- pattern). If on the other hand a non-null string was matched, + -- we simply follow the successor to the alternative node, which + -- sets up for another possible match of the Arbno pattern. + + -- As noted in the section on stack checking, the stack count (and + -- hence the stack check) for a pattern includes only one iteration + -- of the Arbno pattern. To make sure that multiple iterations do not + -- overflow the stack, the Arbno node saves the stack count required + -- by a single iteration, and the Concat function increments this to + -- include stack entries required by any successor. The PC_Arbno_Y + -- node uses this count to ensure that sufficient stack remains + -- before proceeding after matching each new instance. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the Y node is numbered N + 1, + -- the E node is N + 2, and the X node is N + 3. + + ---------------------- + -- Assign Immediate -- + ---------------------- + + -- Immediate assignment (P * V) constructs the following structure + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry whose node field is + -- not used at all, and whose cursor field has the initial cursor. + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped + -- and it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node A, which is the actual + -- PC_Assign_Imm node, executes the assignment (using the stack + -- base to locate the entry with the saved starting cursor value), + -- and the pops the inner region. There are two possibilities, if + -- matching P left no stack entries, then all traces of the inner + -- region can be removed. If there are stack entries, then we push + -- an PC_Region_Replace stack entry whose "cursor" value is the + -- inner stack base value, and then restore the outer stack base + -- value, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node field not used, + -- used only to save initial cursor) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Region_Replace entry, "cursor" value is the (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure occurs, the PC_Region_Replace node restores + -- the inner stack base value and signals failure to explore rematches + -- of the pattern P. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + --------------------- + -- Assign On Match -- + --------------------- + + -- The assign on match (**) pattern is quite similar to the assign + -- immediate pattern, except that the actual assignment has to be + -- delayed. The following structure is constructed: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The operation of this pattern is identical to that described above + -- for deferred assignment, up to the point where P has been matched. + + -- The A node, which is the PC_Assign_OnM node first pushes a + -- PC_Assign node onto the history stack. This node saves the ending + -- cursor and acts as a flag for the final assignment, as further + -- described below. + + -- It then stores a pointer to itself in the special entry node field. + -- This was otherwise unused, and is now used to retrieve the address + -- of the variable to be assigned at the end of the pattern. + + -- After that the inner region is terminated in the usual manner, + -- by stacking a PC_R_Restore entry as described for the assign + -- immediate case. Note that the optimization of completely + -- removing the inner region does not happen in this case, since + -- we have at least one stack entry (the PC_Assign one we just made). + -- The stack now looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, node points to copy of + -- the PC_Assign_OnM node, and the + -- cursor field saves the initial cursor). + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Assign entry, saves final cursor) + + -- (PC_Region_Replace entry, "cursor" value is (negative) + -- stack pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure causes the PC_Assign node to execute it + -- simply removes itself and propagates the failure. + + -- If the match succeeds, then the history stack is scanned for + -- PC_Assign nodes, and the assignments are executed (examination + -- of the above diagram will show that all the necessary data is + -- at hand for the assignment). + + -- To optimize the common case where no assign-on-match operations + -- are present, a global flag Assign_OnM is maintained which is + -- initialize to False, and gets set True as part of the execution + -- of the PC_Assign_OnM node. The scan of the history stack for + -- PC_Assign entries is done only if this flag is set. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + --------- + -- Bal -- + --------- + + -- Bal builds a single node: + + -- +---+ + -- | B |----> + -- +---+ + + -- The node B is the PC_Bal node which matches a parentheses balanced + -- string, starting at the current cursor position. It then updates + -- the cursor past this matched string, and stacks a pointer to itself + -- with this updated cursor value on the history stack, to extend the + -- matched string on a subsequent failure. + + -- Since this is a single node it is numbered 1 (the reason we include + -- it in the compound patterns section is that it backtracks). + + ------------ + -- BreakX -- + ------------ + + -- BreakX builds the structure + + -- +---+ +---+ + -- | B |---->| A |----> + -- +---+ +---+ + -- ^ . + -- | . + -- | +---+ + -- +<------| X | + -- +---+ + + -- Here the B node is the BreakX_xx node that performs a normal Break + -- function. The A node is an alternative (PC_Alt) node that matches + -- null, but stacks a pointer to node X (the PC_BreakX_X node) which + -- extends the match one character (to eat up the previously detected + -- break character), and then rematches the break. + + -- The B node is numbered 3, the alternative node is 1, and the X + -- node is 2. + + ----------- + -- Fence -- + ----------- + + -- Fence builds a single node: + + -- +---+ + -- | F |----> + -- +---+ + + -- The element F, PC_Fence, matches null, and stacks a pointer to a + -- PC_Cancel element which will abort the match on a subsequent failure. + + -- Since this is a single element it is numbered 1 (the reason we + -- include it in the compound patterns section is that it backtracks). + + -------------------- + -- Fence Function -- + -------------------- + + -- A call to the Fence function builds the structure: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| X |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node which matches null and creates two + -- stack entries. The first is a special entry which is not used at + -- all in the fence case (it is present merely for uniformity with + -- other cases of region enter operations). + + -- The second entry corresponds to a standard new region action. A + -- PC_R_Remove node is stacked, whose cursor field is used to store + -- the outer stack base, and the stack base is reset to point to + -- this PC_R_Remove node. Then the pattern P is matched, and it can + -- make history stack entries in the normal manner, so now the stack + -- looks like: + + -- (stack entries made before fence pattern) + + -- (Special entry, not used at all) + + -- (PC_R_Remove entry, "cursor" value is (negative) <-- Stack Base + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- If the match of P fails, then the PC_R_Remove entry is popped + -- and it removes both itself and the special entry underneath it, + -- restores the outer stack base, and signals failure. + + -- If the match of P succeeds, then node X, the PC_Fence_X node, gets + -- control. One might be tempted to think that at this point, the + -- history stack entries made by matching P can just be removed since + -- they certainly are not going to be used for rematching (that is + -- whole point of Fence after all). However, this is wrong, because + -- it would result in the loss of possible assign-on-match entries + -- for deferred pattern assignments. + + -- Instead what we do is to make a special entry whose node references + -- PC_Fence_Y, and whose cursor saves the inner stack base value, i.e. + -- the pointer to the PC_R_Remove entry. Then the outer stack base + -- pointer is restored, so the stack looks like: + + -- (stack entries made before assign pattern) + + -- (Special entry, not used at all) + + -- (PC_R_Remove entry, "cursor" value is (negative) + -- saved base value for the enclosing region) + + -- (stack entries made by matching P) + + -- (PC_Fence_Y entry, "cursor" value is (negative) stack + -- pointer value referencing the PC_R_Remove entry). + + -- If a subsequent failure occurs, then the PC_Fence_Y entry removes + -- the entire inner region, including all entries made by matching P, + -- and alternatives prior to the Fence pattern are sought. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the X node is numbered N + 1, + -- and the E node is N + 2. + + ------------- + -- Succeed -- + ------------- + + -- Succeed builds a single node: + + -- +---+ + -- | S |----> + -- +---+ + + -- The node S is the PC_Succeed node which matches null, and stacks + -- a pointer to itself on the history stack, so that a subsequent + -- failure repeats the same match. + + -- Since this is a single node it is numbered 1 (the reason we include + -- it in the compound patterns section is that it backtracks). + + --------------------- + -- Write Immediate -- + --------------------- + + -- The structure built for a write immediate operation (P * F, where + -- F is a file access value) is: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node and W is the PC_Write_Imm node. The + -- handling is identical to that described above for Assign Immediate, + -- except that at the point where a successful match occurs, the matched + -- substring is written to the referenced file. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + -------------------- + -- Write On Match -- + -------------------- + + -- The structure built for a write on match operation (P ** F, where + -- F is a file access value) is: + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- Here E is the PC_R_Enter node and W is the PC_Write_OnM node. The + -- handling is identical to that described above for Assign On Match, + -- except that at the point where a successful match has completed, + -- the matched substring is written to the referenced file. + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + ----------------------- + -- Constant Patterns -- + ----------------------- + + -- The following pattern elements are referenced only from the pattern + -- history stack. In each case the processing for the pattern element + -- results in pattern match abort, or further failure, so there is no + -- need for a successor and no need for a node number + + CP_Assign : aliased PE := (PC_Assign, 0, N); + CP_Cancel : aliased PE := (PC_Cancel, 0, N); + CP_Fence_Y : aliased PE := (PC_Fence_Y, 0, N); + CP_R_Remove : aliased PE := (PC_R_Remove, 0, N); + CP_R_Restore : aliased PE := (PC_R_Restore, 0, N); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Alternate (L, R : PE_Ptr) return PE_Ptr; + function "or" (L, R : PE_Ptr) return PE_Ptr renames Alternate; + -- Build pattern structure corresponding to the alternation of L, R. + -- (i.e. try to match L, and if that fails, try to match R). + + function Arbno_Simple (P : PE_Ptr) return PE_Ptr; + -- Build simple Arbno pattern, P is a pattern that is guaranteed to + -- match at least one character if it succeeds and to require no + -- stack entries under all circumstances. The result returned is + -- a simple Arbno structure as previously described. + + function Bracket (E, P, A : PE_Ptr) return PE_Ptr; + -- Given two single node pattern elements E and A, and a (possible + -- complex) pattern P, construct the concatenation E-->P-->A and + -- return a pointer to E. The concatenation does not affect the + -- node numbering in P. A has a number one higher than the maximum + -- number in P, and E has a number two higher than the maximum + -- number in P (see for example the Assign_Immediate structure to + -- understand a typical use of this function). + + function BreakX_Make (B : PE_Ptr) return Pattern; + -- Given a pattern element for a Break pattern, returns the + -- corresponding BreakX compound pattern structure. + + function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr; + -- Creates a pattern element that represents a concatenation of the + -- two given pattern elements (i.e. the pattern L followed by R). + -- The result returned is always the same as L, but the pattern + -- referenced by L is modified to have R as a successor. This + -- procedure does not copy L or R, so if a copy is required, it + -- is the responsibility of the caller. The Incr parameter is an + -- amount to be added to the Nat field of any P_Arbno_Y node that is + -- in the left operand, it represents the additional stack space + -- required by the right operand. + + function C_To_PE (C : PChar) return PE_Ptr; + -- Given a character, constructs a pattern element that matches + -- the single character. + + function Copy (P : PE_Ptr) return PE_Ptr; + -- Creates a copy of the pattern element referenced by the given + -- pattern element reference. This is a deep copy, which means that + -- it follows the Next and Alt pointers. + + function Image (P : PE_Ptr) return String; + -- Returns the image of the address of the referenced pattern element. + -- This is equivalent to Image (To_Address (P)); + + function Is_In (C : Character; Str : String) return Boolean; + pragma Inline (Is_In); + -- Determines if the character C is in string Str + + procedure Logic_Error; + -- Called to raise Program_Error with an appropriate message if an + -- internal logic error is detected. + + function Str_BF (A : Boolean_Func) return String; + function Str_FP (A : File_Ptr) return String; + function Str_NF (A : Natural_Func) return String; + function Str_NP (A : Natural_Ptr) return String; + function Str_PP (A : Pattern_Ptr) return String; + function Str_VF (A : VString_Func) return String; + function Str_VP (A : VString_Ptr) return String; + -- These are debugging routines, which return a representation of the + -- given access value (they are called only by Image and Dump) + + procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr); + -- Adjusts all EOP pointers in Pat to point to Succ. No other changes + -- are made. In particular, Succ is unchanged, and no index numbers + -- are modified. Note that Pat may not be equal to EOP on entry. + + function S_To_PE (Str : PString) return PE_Ptr; + -- Given a string, constructs a pattern element that matches the string + + procedure Uninitialized_Pattern; + pragma No_Return (Uninitialized_Pattern); + -- Called to raise Program_Error with an appropriate error message if + -- an uninitialized pattern is used in any pattern construction or + -- pattern matching operation. + + procedure XMatch + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural); + -- This is the common pattern match routine. It is passed a string and + -- a pattern, and it indicates success or failure, and on success the + -- section of the string matched. It does not perform any assignments + -- to the subject string, so pattern replacement is for the caller. + -- + -- Subject The subject string. The lower bound is always one. In the + -- Match procedures, it is fine to use strings whose lower bound + -- is not one, but we perform a one time conversion before the + -- call to XMatch, so that XMatch does not have to be bothered + -- with strange lower bounds. + -- + -- Pat_P Points to initial pattern element of pattern to be matched + -- + -- Pat_S Maximum required stack entries for pattern to be matched + -- + -- Start If match is successful, starting index of matched section. + -- This value is always non-zero. A value of zero is used to + -- indicate a failed match. + -- + -- Stop If match is successful, ending index of matched section. + -- This can be zero if we match the null string at the start, + -- in which case Start is set to zero, and Stop to one. If the + -- Match fails, then the contents of Stop is undefined. + + procedure XMatchD + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural); + -- Identical in all respects to XMatch, except that trace information is + -- output on Standard_Output during execution of the match. This is the + -- version that is called if the original Match call has Debug => True. + + --------- + -- "&" -- + --------- + + function "&" (L : PString; R : Pattern) return Pattern is + begin + return (AFC with R.Stk, Concat (S_To_PE (L), Copy (R.P), R.Stk)); + end "&"; + + function "&" (L : Pattern; R : PString) return Pattern is + begin + return (AFC with L.Stk, Concat (Copy (L.P), S_To_PE (R), 0)); + end "&"; + + function "&" (L : PChar; R : Pattern) return Pattern is + begin + return (AFC with R.Stk, Concat (C_To_PE (L), Copy (R.P), R.Stk)); + end "&"; + + function "&" (L : Pattern; R : PChar) return Pattern is + begin + return (AFC with L.Stk, Concat (Copy (L.P), C_To_PE (R), 0)); + end "&"; + + function "&" (L : Pattern; R : Pattern) return Pattern is + begin + return (AFC with L.Stk + R.Stk, Concat (Copy (L.P), Copy (R.P), R.Stk)); + end "&"; + + --------- + -- "*" -- + --------- + + -- Assign immediate + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + function "*" (P : Pattern; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, A)); + end "*"; + + function "*" (P : PString; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "*"; + + function "*" (P : PChar; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_Imm, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "*"; + + -- Write immediate + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + function "*" (P : Pattern; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + function "*" (P : PString; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + function "*" (P : PChar; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_Imm, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "*"; + + ---------- + -- "**" -- + ---------- + + -- Assign on match + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| A |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the A node is numbered N + 1, + -- and the E node is N + 2. + + function "**" (P : Pattern; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, A)); + end "**"; + + function "**" (P : PString; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "**"; + + function "**" (P : PChar; Var : VString_Var) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + A : constant PE_Ptr := + new PE'(PC_Assign_OnM, 0, EOP, Var'Unrestricted_Access); + begin + return (AFC with 3, Bracket (E, Pat, A)); + end "**"; + + -- Write on match + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| W |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the W node is numbered N + 1, + -- and the E node is N + 2. + + function "**" (P : Pattern; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + begin + return (AFC with P.Stk + 3, Bracket (E, Pat, W)); + end "**"; + + function "**" (P : PString; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := S_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "**"; + + function "**" (P : PChar; Fil : File_Access) return Pattern is + Pat : constant PE_Ptr := C_To_PE (P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + W : constant PE_Ptr := new PE'(PC_Write_OnM, 0, EOP, Fil); + begin + return (AFC with 3, Bracket (E, Pat, W)); + end "**"; + + --------- + -- "+" -- + --------- + + function "+" (Str : VString_Var) return Pattern is + begin + return + (AFC with 0, + new PE'(PC_String_VP, 1, EOP, Str'Unrestricted_Access)); + end "+"; + + function "+" (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_String_VF, 1, EOP, Str)); + end "+"; + + function "+" (P : Pattern_Var) return Pattern is + begin + return + (AFC with 3, + new PE'(PC_Rpat, 1, EOP, P'Unrestricted_Access)); + end "+"; + + function "+" (P : Boolean_Func) return Pattern is + begin + return (AFC with 3, new PE'(PC_Pred_Func, 1, EOP, P)); + end "+"; + + ---------- + -- "or" -- + ---------- + + function "or" (L : PString; R : Pattern) return Pattern is + begin + return (AFC with R.Stk + 1, S_To_PE (L) or Copy (R.P)); + end "or"; + + function "or" (L : Pattern; R : PString) return Pattern is + begin + return (AFC with L.Stk + 1, Copy (L.P) or S_To_PE (R)); + end "or"; + + function "or" (L : PString; R : PString) return Pattern is + begin + return (AFC with 1, S_To_PE (L) or S_To_PE (R)); + end "or"; + + function "or" (L : Pattern; R : Pattern) return Pattern is + begin + return (AFC with + Natural'Max (L.Stk, R.Stk) + 1, Copy (L.P) or Copy (R.P)); + end "or"; + + function "or" (L : PChar; R : Pattern) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or Copy (R.P)); + end "or"; + + function "or" (L : Pattern; R : PChar) return Pattern is + begin + return (AFC with 1, Copy (L.P) or C_To_PE (R)); + end "or"; + + function "or" (L : PChar; R : PChar) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or C_To_PE (R)); + end "or"; + + function "or" (L : PString; R : PChar) return Pattern is + begin + return (AFC with 1, S_To_PE (L) or C_To_PE (R)); + end "or"; + + function "or" (L : PChar; R : PString) return Pattern is + begin + return (AFC with 1, C_To_PE (L) or S_To_PE (R)); + end "or"; + + ------------ + -- Adjust -- + ------------ + + -- No two patterns share the same pattern elements, so the adjust + -- procedure for a Pattern assignment must do a deep copy of the + -- pattern element structure. + + procedure Adjust (Object : in out Pattern) is + begin + Object.P := Copy (Object.P); + end Adjust; + + --------------- + -- Alternate -- + --------------- + + function Alternate (L, R : PE_Ptr) return PE_Ptr is + begin + -- If the left pattern is null, then we just add the alternation + -- node with an index one greater than the right hand pattern. + + if L = EOP then + return new PE'(PC_Alt, R.Index + 1, EOP, R); + + -- If the left pattern is non-null, then build a reference vector + -- for its elements, and adjust their index values to accommodate + -- the right hand elements. Then add the alternation node. + + else + declare + Refs : Ref_Array (1 .. L.Index); + + begin + Build_Ref_Array (L, Refs); + + for J in Refs'Range loop + Refs (J).Index := Refs (J).Index + R.Index; + end loop; + end; + + return new PE'(PC_Alt, L.Index + 1, L, R); + end if; + end Alternate; + + --------- + -- Any -- + --------- + + function Any (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, To_Set (Str))); + end Any; + + function Any (Str : VString) return Pattern is + begin + return Any (S (Str)); + end Any; + + function Any (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CH, 1, EOP, Str)); + end Any; + + function Any (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_CS, 1, EOP, Str)); + end Any; + + function Any (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_VP, 1, EOP, VString_Ptr (Str))); + end Any; + + function Any (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Any_VF, 1, EOP, Str)); + end Any; + + --------- + -- Arb -- + --------- + + -- +---+ + -- | X |----> + -- +---+ + -- . + -- . + -- +---+ + -- | Y |----> + -- +---+ + + -- The PC_Arb_X element is numbered 2, and the PC_Arb_Y element is 1 + + function Arb return Pattern is + Y : constant PE_Ptr := new PE'(PC_Arb_Y, 1, EOP); + X : constant PE_Ptr := new PE'(PC_Arb_X, 2, EOP, Y); + begin + return (AFC with 1, X); + end Arb; + + ----------- + -- Arbno -- + ----------- + + function Arbno (P : PString) return Pattern is + begin + if P'Length = 0 then + return (AFC with 0, EOP); + else + return (AFC with 0, Arbno_Simple (S_To_PE (P))); + end if; + end Arbno; + + function Arbno (P : PChar) return Pattern is + begin + return (AFC with 0, Arbno_Simple (C_To_PE (P))); + end Arbno; + + function Arbno (P : Pattern) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + + begin + if P.Stk = 0 + and then OK_For_Simple_Arbno (Pat.Pcode) + then + return (AFC with 0, Arbno_Simple (Pat)); + end if; + + -- This is the complex case, either the pattern makes stack entries + -- or it is possible for the pattern to match the null string (more + -- accurately, we don't know that this is not the case). + + -- +--------------------------+ + -- | ^ + -- V | + -- +---+ | + -- | X |----> | + -- +---+ | + -- . | + -- . | + -- +---+ +---+ +---+ | + -- | E |---->| P |---->| Y |--->+ + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the Y node is numbered N + 1, + -- the E node is N + 2, and the X node is N + 3. + + declare + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + X : constant PE_Ptr := new PE'(PC_Arbno_X, 0, EOP, E); + Y : constant PE_Ptr := new PE'(PC_Arbno_Y, 0, X, P.Stk + 3); + EPY : constant PE_Ptr := Bracket (E, Pat, Y); + begin + X.Alt := EPY; + X.Index := EPY.Index + 1; + return (AFC with P.Stk + 3, X); + end; + end Arbno; + + ------------------ + -- Arbno_Simple -- + ------------------ + + -- +-------------+ + -- | ^ + -- V | + -- +---+ | + -- | S |----> | + -- +---+ | + -- . | + -- . | + -- +---+ | + -- | P |---------->+ + -- +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- The S node has a node number of P.Index + 1. + + -- Note that we know that P cannot be EOP, because a null pattern + -- does not meet the requirements for simple Arbno. + + function Arbno_Simple (P : PE_Ptr) return PE_Ptr is + S : constant PE_Ptr := new PE'(PC_Arbno_S, P.Index + 1, EOP, P); + begin + Set_Successor (P, S); + return S; + end Arbno_Simple; + + --------- + -- Bal -- + --------- + + function Bal return Pattern is + begin + return (AFC with 1, new PE'(PC_Bal, 1, EOP)); + end Bal; + + ------------- + -- Bracket -- + ------------- + + function Bracket (E, P, A : PE_Ptr) return PE_Ptr is + begin + if P = EOP then + E.Pthen := A; + E.Index := 2; + A.Index := 1; + + else + E.Pthen := P; + Set_Successor (P, A); + E.Index := P.Index + 2; + A.Index := P.Index + 1; + end if; + + return E; + end Bracket; + + ----------- + -- Break -- + ----------- + + function Break (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, To_Set (Str))); + end Break; + + function Break (Str : VString) return Pattern is + begin + return Break (S (Str)); + end Break; + + function Break (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CH, 1, EOP, Str)); + end Break; + + function Break (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_CS, 1, EOP, Str)); + end Break; + + function Break (Str : not null access VString) return Pattern is + begin + return (AFC with 0, + new PE'(PC_Break_VP, 1, EOP, Str.all'Unchecked_Access)); + end Break; + + function Break (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Break_VF, 1, EOP, Str)); + end Break; + + ------------ + -- BreakX -- + ------------ + + function BreakX (Str : String) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, To_Set (Str))); + end BreakX; + + function BreakX (Str : VString) return Pattern is + begin + return BreakX (S (Str)); + end BreakX; + + function BreakX (Str : Character) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CH, 3, N, Str)); + end BreakX; + + function BreakX (Str : Character_Set) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_CS, 3, N, Str)); + end BreakX; + + function BreakX (Str : not null access VString) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_VP, 3, N, VString_Ptr (Str))); + end BreakX; + + function BreakX (Str : VString_Func) return Pattern is + begin + return BreakX_Make (new PE'(PC_BreakX_VF, 3, N, Str)); + end BreakX; + + ----------------- + -- BreakX_Make -- + ----------------- + + -- +---+ +---+ + -- | B |---->| A |----> + -- +---+ +---+ + -- ^ . + -- | . + -- | +---+ + -- +<------| X | + -- +---+ + + -- The B node is numbered 3, the alternative node is 1, and the X + -- node is 2. + + function BreakX_Make (B : PE_Ptr) return Pattern is + X : constant PE_Ptr := new PE'(PC_BreakX_X, 2, B); + A : constant PE_Ptr := new PE'(PC_Alt, 1, EOP, X); + begin + B.Pthen := A; + return (AFC with 2, B); + end BreakX_Make; + + --------------------- + -- Build_Ref_Array -- + --------------------- + + procedure Build_Ref_Array (E : PE_Ptr; RA : out Ref_Array) is + + procedure Record_PE (E : PE_Ptr); + -- Record given pattern element if not already recorded in RA, + -- and also record any referenced pattern elements recursively. + + --------------- + -- Record_PE -- + --------------- + + procedure Record_PE (E : PE_Ptr) is + begin + PutD (" Record_PE called with PE_Ptr = " & Image (E)); + + if E = EOP or else RA (E.Index) /= null then + Put_LineD (", nothing to do"); + return; + + else + Put_LineD (", recording" & IndexT'Image (E.Index)); + RA (E.Index) := E; + Record_PE (E.Pthen); + + if E.Pcode in PC_Has_Alt then + Record_PE (E.Alt); + end if; + end if; + end Record_PE; + + -- Start of processing for Build_Ref_Array + + begin + New_LineD; + Put_LineD ("Entering Build_Ref_Array"); + Record_PE (E); + New_LineD; + end Build_Ref_Array; + + ------------- + -- C_To_PE -- + ------------- + + function C_To_PE (C : PChar) return PE_Ptr is + begin + return new PE'(PC_Char, 1, EOP, C); + end C_To_PE; + + ------------ + -- Cancel -- + ------------ + + function Cancel return Pattern is + begin + return (AFC with 0, new PE'(PC_Cancel, 1, EOP)); + end Cancel; + + ------------ + -- Concat -- + ------------ + + -- Concat needs to traverse the left operand performing the following + -- set of fixups: + + -- a) Any successor pointers (Pthen fields) that are set to EOP are + -- reset to point to the second operand. + + -- b) Any PC_Arbno_Y node has its stack count field incremented + -- by the parameter Incr provided for this purpose. + + -- d) Num fields of all pattern elements in the left operand are + -- adjusted to include the elements of the right operand. + + -- Note: we do not use Set_Successor in the processing for Concat, since + -- there is no point in doing two traversals, we may as well do everything + -- at the same time. + + function Concat (L, R : PE_Ptr; Incr : Natural) return PE_Ptr is + begin + if L = EOP then + return R; + + elsif R = EOP then + return L; + + else + declare + Refs : Ref_Array (1 .. L.Index); + -- We build a reference array for L whose N'th element points to + -- the pattern element of L whose original Index value is N. + + P : PE_Ptr; + + begin + Build_Ref_Array (L, Refs); + + for J in Refs'Range loop + P := Refs (J); + + P.Index := P.Index + R.Index; + + if P.Pcode = PC_Arbno_Y then + P.Nat := P.Nat + Incr; + end if; + + if P.Pthen = EOP then + P.Pthen := R; + end if; + + if P.Pcode in PC_Has_Alt and then P.Alt = EOP then + P.Alt := R; + end if; + end loop; + end; + + return L; + end if; + end Concat; + + ---------- + -- Copy -- + ---------- + + function Copy (P : PE_Ptr) return PE_Ptr is + begin + if P = null then + Uninitialized_Pattern; + + else + declare + Refs : Ref_Array (1 .. P.Index); + -- References to elements in P, indexed by Index field + + Copy : Ref_Array (1 .. P.Index); + -- Holds copies of elements of P, indexed by Index field + + E : PE_Ptr; + + begin + Build_Ref_Array (P, Refs); + + -- Now copy all nodes + + for J in Refs'Range loop + Copy (J) := new PE'(Refs (J).all); + end loop; + + -- Adjust all internal references + + for J in Copy'Range loop + E := Copy (J); + + -- Adjust successor pointer to point to copy + + if E.Pthen /= EOP then + E.Pthen := Copy (E.Pthen.Index); + end if; + + -- Adjust Alt pointer if there is one to point to copy + + if E.Pcode in PC_Has_Alt and then E.Alt /= EOP then + E.Alt := Copy (E.Alt.Index); + end if; + + -- Copy referenced string + + if E.Pcode = PC_String then + E.Str := new String'(E.Str.all); + end if; + end loop; + + return Copy (P.Index); + end; + end if; + end Copy; + + ---------- + -- Dump -- + ---------- + + procedure Dump (P : Pattern) is + procedure Write_Node_Id (E : PE_Ptr; Cols : Natural); + -- Writes out a string identifying the given pattern element. Cols is + -- the column indentation level. + + ------------------- + -- Write_Node_Id -- + ------------------- + + procedure Write_Node_Id (E : PE_Ptr; Cols : Natural) is + begin + if E = EOP then + Put ("EOP"); + + for J in 4 .. Cols loop + Put (' '); + end loop; + + else + declare + Str : String (1 .. Cols); + N : Natural := Natural (E.Index); + + begin + Put ("#"); + + for J in reverse Str'Range loop + Str (J) := Character'Val (48 + N mod 10); + N := N / 10; + end loop; + + Put (Str); + end; + end if; + end Write_Node_Id; + + -- Local variables + + Cols : Natural := 2; + -- Number of columns used for pattern numbers, minimum is 2 + + E : PE_Ptr; + + subtype Count is Ada.Text_IO.Count; + Scol : Count; + -- Used to keep track of column in dump output + + -- Start of processing for Dump + + begin + New_Line; + Put + ("Pattern Dump Output (pattern at " + & Image (P'Address) + & ", S = " + & Natural'Image (P.Stk) & ')'); + New_Line; + + Scol := Col; + + while Col < Scol loop + Put ('-'); + end loop; + + New_Line; + + -- If uninitialized pattern, dump line and we are done + + if P.P = null then + Put_Line ("Uninitialized pattern value"); + return; + end if; + + -- If null pattern, just dump it and we are all done + + if P.P = EOP then + Put_Line ("EOP (null pattern)"); + return; + end if; + + declare + Refs : Ref_Array (1 .. P.P.Index); + -- We build a reference array whose N'th element points to the + -- pattern element whose Index value is N. + + begin + Build_Ref_Array (P.P, Refs); + + -- Set number of columns required for node numbers + + while 10 ** Cols - 1 < Integer (P.P.Index) loop + Cols := Cols + 1; + end loop; + + -- Now dump the nodes in reverse sequence. We output them in reverse + -- sequence since this corresponds to the natural order used to + -- construct the patterns. + + for J in reverse Refs'Range loop + E := Refs (J); + Write_Node_Id (E, Cols); + Set_Col (Count (Cols) + 4); + Put (Image (E)); + Put (" "); + Put (Pattern_Code'Image (E.Pcode)); + Put (" "); + Set_Col (21 + Count (Cols) + Address_Image_Length); + Write_Node_Id (E.Pthen, Cols); + Set_Col (24 + 2 * Count (Cols) + Address_Image_Length); + + case E.Pcode is + when PC_Alt + | PC_Arb_X + | PC_Arbno_S + | PC_Arbno_X + => + Write_Node_Id (E.Alt, Cols); + + when PC_Rpat => + Put (Str_PP (E.PP)); + + when PC_Pred_Func => + Put (Str_BF (E.BF)); + + when PC_Assign_Imm + | PC_Assign_OnM + | PC_Any_VP + | PC_Break_VP + | PC_BreakX_VP + | PC_NotAny_VP + | PC_NSpan_VP + | PC_Span_VP + | PC_String_VP + => + Put (Str_VP (E.VP)); + + when PC_Write_Imm + | PC_Write_OnM + => + Put (Str_FP (E.FP)); + + when PC_String => + Put (Image (E.Str.all)); + + when PC_String_2 => + Put (Image (E.Str2)); + + when PC_String_3 => + Put (Image (E.Str3)); + + when PC_String_4 => + Put (Image (E.Str4)); + + when PC_String_5 => + Put (Image (E.Str5)); + + when PC_String_6 => + Put (Image (E.Str6)); + + when PC_Setcur => + Put (Str_NP (E.Var)); + + when PC_Any_CH + | PC_Break_CH + | PC_BreakX_CH + | PC_Char + | PC_NotAny_CH + | PC_NSpan_CH + | PC_Span_CH + => + Put (''' & E.Char & '''); + + when PC_Any_CS + | PC_Break_CS + | PC_BreakX_CS + | PC_NotAny_CS + | PC_NSpan_CS + | PC_Span_CS + => + Put ('"' & To_Sequence (E.CS) & '"'); + + when PC_Arbno_Y + | PC_Len_Nat + | PC_Pos_Nat + | PC_RPos_Nat + | PC_RTab_Nat + | PC_Tab_Nat + => + Put (S (E.Nat)); + + when PC_Pos_NF + | PC_Len_NF + | PC_RPos_NF + | PC_RTab_NF + | PC_Tab_NF + => + Put (Str_NF (E.NF)); + + when PC_Pos_NP + | PC_Len_NP + | PC_RPos_NP + | PC_RTab_NP + | PC_Tab_NP + => + Put (Str_NP (E.NP)); + + when PC_Any_VF + | PC_Break_VF + | PC_BreakX_VF + | PC_NotAny_VF + | PC_NSpan_VF + | PC_Span_VF + | PC_String_VF + => + Put (Str_VF (E.VF)); + + when others => + null; + end case; + + New_Line; + end loop; + + New_Line; + end; + end Dump; + + ---------- + -- Fail -- + ---------- + + function Fail return Pattern is + begin + return (AFC with 0, new PE'(PC_Fail, 1, EOP)); + end Fail; + + ----------- + -- Fence -- + ----------- + + -- Simple case + + function Fence return Pattern is + begin + return (AFC with 1, new PE'(PC_Fence, 1, EOP)); + end Fence; + + -- Function case + + -- +---+ +---+ +---+ + -- | E |---->| P |---->| X |----> + -- +---+ +---+ +---+ + + -- The node numbering of the constituent pattern P is not affected. + -- Where N is the number of nodes in P, the X node is numbered N + 1, + -- and the E node is N + 2. + + function Fence (P : Pattern) return Pattern is + Pat : constant PE_Ptr := Copy (P.P); + E : constant PE_Ptr := new PE'(PC_R_Enter, 0, EOP); + X : constant PE_Ptr := new PE'(PC_Fence_X, 0, EOP); + begin + return (AFC with P.Stk + 1, Bracket (E, Pat, X)); + end Fence; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Pattern) is + + procedure Free is new Ada.Unchecked_Deallocation (PE, PE_Ptr); + procedure Free is new Ada.Unchecked_Deallocation (String, String_Ptr); + + begin + -- Nothing to do if already freed + + if Object.P = null then + return; + + -- Otherwise we must free all elements + + else + declare + Refs : Ref_Array (1 .. Object.P.Index); + -- References to elements in pattern to be finalized + + begin + Build_Ref_Array (Object.P, Refs); + + for J in Refs'Range loop + if Refs (J).Pcode = PC_String then + Free (Refs (J).Str); + end if; + + Free (Refs (J)); + end loop; + + Object.P := null; + end; + end if; + end Finalize; + + ----------- + -- Image -- + ----------- + + function Image (P : PE_Ptr) return String is + begin + return Image (To_Address (P)); + end Image; + + function Image (P : Pattern) return String is + begin + return S (Image (P)); + end Image; + + function Image (P : Pattern) return VString is + + Kill_Ampersand : Boolean := False; + -- Set True to delete next & to be output to Result + + Result : VString := Nul; + -- The result is accumulated here, using Append + + Refs : Ref_Array (1 .. P.P.Index); + -- We build a reference array whose N'th element points to the + -- pattern element whose Index value is N. + + procedure Delete_Ampersand; + -- Deletes the ampersand at the end of Result + + procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean); + -- E refers to a pattern structure whose successor is given by Succ. + -- This procedure appends to Result a representation of this pattern. + -- The Paren parameter indicates whether parentheses are required if + -- the output is more than one element. + + procedure Image_One (E : in out PE_Ptr); + -- E refers to a pattern structure. This procedure appends to Result + -- a representation of the single simple or compound pattern structure + -- at the start of E and updates E to point to its successor. + + ---------------------- + -- Delete_Ampersand -- + ---------------------- + + procedure Delete_Ampersand is + L : constant Natural := Length (Result); + begin + if L > 2 then + Delete (Result, L - 1, L); + end if; + end Delete_Ampersand; + + --------------- + -- Image_One -- + --------------- + + procedure Image_One (E : in out PE_Ptr) is + + ER : PE_Ptr := E.Pthen; + -- Successor set as result in E unless reset + + begin + case E.Pcode is + when PC_Cancel => + Append (Result, "Cancel"); + + when PC_Alt => Alt : declare + + Elmts_In_L : constant IndexT := E.Pthen.Index - E.Alt.Index; + -- Number of elements in left pattern of alternation + + Lowest_In_L : constant IndexT := E.Index - Elmts_In_L; + -- Number of lowest index in elements of left pattern + + E1 : PE_Ptr; + + begin + -- The successor of the alternation node must have a lower + -- index than any node that is in the left pattern or a + -- higher index than the alternation node itself. + + while ER /= EOP + and then ER.Index >= Lowest_In_L + and then ER.Index < E.Index + loop + ER := ER.Pthen; + end loop; + + Append (Result, '('); + + E1 := E; + loop + Image_Seq (E1.Pthen, ER, False); + Append (Result, " or "); + E1 := E1.Alt; + exit when E1.Pcode /= PC_Alt; + end loop; + + Image_Seq (E1, ER, False); + Append (Result, ')'); + end Alt; + + when PC_Any_CS => + Append (Result, "Any (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Any_VF => + Append (Result, "Any (" & Str_VF (E.VF) & ')'); + + when PC_Any_VP => + Append (Result, "Any (" & Str_VP (E.VP) & ')'); + + when PC_Arb_X => + Append (Result, "Arb"); + + when PC_Arbno_S => + Append (Result, "Arbno ("); + Image_Seq (E.Alt, E, False); + Append (Result, ')'); + + when PC_Arbno_X => + Append (Result, "Arbno ("); + Image_Seq (E.Alt.Pthen, Refs (E.Index - 2), False); + Append (Result, ')'); + + when PC_Assign_Imm => + Delete_Ampersand; + Append (Result, "* " & Str_VP (Refs (E.Index).VP)); + + when PC_Assign_OnM => + Delete_Ampersand; + Append (Result, "** " & Str_VP (Refs (E.Index).VP)); + + when PC_Any_CH => + Append (Result, "Any ('" & E.Char & "')"); + + when PC_Bal => + Append (Result, "Bal"); + + when PC_Break_CH => + Append (Result, "Break ('" & E.Char & "')"); + + when PC_Break_CS => + Append (Result, "Break (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Break_VF => + Append (Result, "Break (" & Str_VF (E.VF) & ')'); + + when PC_Break_VP => + Append (Result, "Break (" & Str_VP (E.VP) & ')'); + + when PC_BreakX_CH => + Append (Result, "BreakX ('" & E.Char & "')"); + ER := ER.Pthen; + + when PC_BreakX_CS => + Append (Result, "BreakX (" & Image (To_Sequence (E.CS)) & ')'); + ER := ER.Pthen; + + when PC_BreakX_VF => + Append (Result, "BreakX (" & Str_VF (E.VF) & ')'); + ER := ER.Pthen; + + when PC_BreakX_VP => + Append (Result, "BreakX (" & Str_VP (E.VP) & ')'); + ER := ER.Pthen; + + when PC_Char => + Append (Result, ''' & E.Char & '''); + + when PC_Fail => + Append (Result, "Fail"); + + when PC_Fence => + Append (Result, "Fence"); + + when PC_Fence_X => + Append (Result, "Fence ("); + Image_Seq (E.Pthen, Refs (E.Index - 1), False); + Append (Result, ")"); + ER := Refs (E.Index - 1).Pthen; + + when PC_Len_Nat => + Append (Result, "Len (" & E.Nat & ')'); + + when PC_Len_NF => + Append (Result, "Len (" & Str_NF (E.NF) & ')'); + + when PC_Len_NP => + Append (Result, "Len (" & Str_NP (E.NP) & ')'); + + when PC_NotAny_CH => + Append (Result, "NotAny ('" & E.Char & "')"); + + when PC_NotAny_CS => + Append (Result, "NotAny (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_NotAny_VF => + Append (Result, "NotAny (" & Str_VF (E.VF) & ')'); + + when PC_NotAny_VP => + Append (Result, "NotAny (" & Str_VP (E.VP) & ')'); + + when PC_NSpan_CH => + Append (Result, "NSpan ('" & E.Char & "')"); + + when PC_NSpan_CS => + Append (Result, "NSpan (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_NSpan_VF => + Append (Result, "NSpan (" & Str_VF (E.VF) & ')'); + + when PC_NSpan_VP => + Append (Result, "NSpan (" & Str_VP (E.VP) & ')'); + + when PC_Null => + Append (Result, """"""); + + when PC_Pos_Nat => + Append (Result, "Pos (" & E.Nat & ')'); + + when PC_Pos_NF => + Append (Result, "Pos (" & Str_NF (E.NF) & ')'); + + when PC_Pos_NP => + Append (Result, "Pos (" & Str_NP (E.NP) & ')'); + + when PC_R_Enter => + Kill_Ampersand := True; + + when PC_Rest => + Append (Result, "Rest"); + + when PC_Rpat => + Append (Result, "(+ " & Str_PP (E.PP) & ')'); + + when PC_Pred_Func => + Append (Result, "(+ " & Str_BF (E.BF) & ')'); + + when PC_RPos_Nat => + Append (Result, "RPos (" & E.Nat & ')'); + + when PC_RPos_NF => + Append (Result, "RPos (" & Str_NF (E.NF) & ')'); + + when PC_RPos_NP => + Append (Result, "RPos (" & Str_NP (E.NP) & ')'); + + when PC_RTab_Nat => + Append (Result, "RTab (" & E.Nat & ')'); + + when PC_RTab_NF => + Append (Result, "RTab (" & Str_NF (E.NF) & ')'); + + when PC_RTab_NP => + Append (Result, "RTab (" & Str_NP (E.NP) & ')'); + + when PC_Setcur => + Append (Result, "Setcur (" & Str_NP (E.Var) & ')'); + + when PC_Span_CH => + Append (Result, "Span ('" & E.Char & "')"); + + when PC_Span_CS => + Append (Result, "Span (" & Image (To_Sequence (E.CS)) & ')'); + + when PC_Span_VF => + Append (Result, "Span (" & Str_VF (E.VF) & ')'); + + when PC_Span_VP => + Append (Result, "Span (" & Str_VP (E.VP) & ')'); + + when PC_String => + Append (Result, Image (E.Str.all)); + + when PC_String_2 => + Append (Result, Image (E.Str2)); + + when PC_String_3 => + Append (Result, Image (E.Str3)); + + when PC_String_4 => + Append (Result, Image (E.Str4)); + + when PC_String_5 => + Append (Result, Image (E.Str5)); + + when PC_String_6 => + Append (Result, Image (E.Str6)); + + when PC_String_VF => + Append (Result, "(+" & Str_VF (E.VF) & ')'); + + when PC_String_VP => + Append (Result, "(+" & Str_VP (E.VP) & ')'); + + when PC_Succeed => + Append (Result, "Succeed"); + + when PC_Tab_Nat => + Append (Result, "Tab (" & E.Nat & ')'); + + when PC_Tab_NF => + Append (Result, "Tab (" & Str_NF (E.NF) & ')'); + + when PC_Tab_NP => + Append (Result, "Tab (" & Str_NP (E.NP) & ')'); + + when PC_Write_Imm => + Append (Result, '('); + Image_Seq (E, Refs (E.Index - 1), True); + Append (Result, " * " & Str_FP (Refs (E.Index - 1).FP)); + ER := Refs (E.Index - 1).Pthen; + + when PC_Write_OnM => + Append (Result, '('); + Image_Seq (E.Pthen, Refs (E.Index - 1), True); + Append (Result, " ** " & Str_FP (Refs (E.Index - 1).FP)); + ER := Refs (E.Index - 1).Pthen; + + -- Other pattern codes should not appear as leading elements + + when PC_Arb_Y + | PC_Arbno_Y + | PC_Assign + | PC_BreakX_X + | PC_EOP + | PC_Fence_Y + | PC_R_Remove + | PC_R_Restore + | PC_Unanchored + => + Append (Result, "???"); + end case; + + E := ER; + end Image_One; + + --------------- + -- Image_Seq -- + --------------- + + procedure Image_Seq (E : PE_Ptr; Succ : PE_Ptr; Paren : Boolean) is + Indx : constant Natural := Length (Result); + E1 : PE_Ptr := E; + Mult : Boolean := False; + + begin + -- The image of EOP is "" (the null string) + + if E = EOP then + Append (Result, """"""); + + -- Else generate appropriate concatenation sequence + + else + loop + Image_One (E1); + exit when E1 = Succ; + exit when E1 = EOP; + Mult := True; + + if Kill_Ampersand then + Kill_Ampersand := False; + else + Append (Result, " & "); + end if; + end loop; + end if; + + if Mult and Paren then + Insert (Result, Indx + 1, "("); + Append (Result, ")"); + end if; + end Image_Seq; + + -- Start of processing for Image + + begin + Build_Ref_Array (P.P, Refs); + Image_Seq (P.P, EOP, False); + return Result; + end Image; + + ----------- + -- Is_In -- + ----------- + + function Is_In (C : Character; Str : String) return Boolean is + begin + for J in Str'Range loop + if Str (J) = C then + return True; + end if; + end loop; + + return False; + end Is_In; + + --------- + -- Len -- + --------- + + function Len (Count : Natural) return Pattern is + begin + -- Note, the following is not just an optimization, it is needed + -- to ensure that Arbno (Len (0)) does not generate an infinite + -- matching loop (since PC_Len_Nat is OK_For_Simple_Arbno). + + if Count = 0 then + return (AFC with 0, new PE'(PC_Null, 1, EOP)); + + else + return (AFC with 0, new PE'(PC_Len_Nat, 1, EOP, Count)); + end if; + end Len; + + function Len (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Len_NF, 1, EOP, Count)); + end Len; + + function Len (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Len_NP, 1, EOP, Natural_Ptr (Count))); + end Len; + + ----------------- + -- Logic_Error -- + ----------------- + + procedure Logic_Error is + begin + raise Program_Error with + "Internal logic error in GNAT.Spitbol.Patterns"; + end Logic_Error; + + ----------- + -- Match -- + ----------- + + function Match + (Subject : VString; + Pat : Pattern) return Boolean + is + S : Big_String_Access; + L : Natural; + Start : Natural; + Stop : Natural; + pragma Unreferenced (Stop); + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + return Start /= 0; + end Match; + + function Match + (Subject : String; + Pat : Pattern) return Boolean + is + Start, Stop : Natural; + pragma Unreferenced (Stop); + + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + end if; + + return Start /= 0; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : VString) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Get_String (Replace, S, L); + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L)); + return True; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : String) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, Replace); + return True; + end if; + end Match; + + procedure Match + (Subject : VString; + Pat : Pattern) + is + S : Big_String_Access; + L : Natural; + + Start : Natural; + Stop : Natural; + pragma Unreferenced (Start, Stop); + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : String; + Pat : Pattern) + is + Start, Stop : Natural; + pragma Unreferenced (Start, Stop); + + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (String1 (Subject), Pat.P, Pat.Stk, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : VString) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start /= 0 then + Get_String (Replace, S, L); + Replace_Slice (Subject, Start, Stop, S (1 .. L)); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : String) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Replace); + end if; + end Match; + + function Match + (Subject : VString; + Pat : PString) return Boolean + is + Pat_Len : constant Natural := Pat'Length; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Anchored_Mode then + if Pat_Len > L then + return False; + else + return Pat = S (1 .. Pat_Len); + end if; + + else + for J in 1 .. L - Pat_Len + 1 loop + if Pat = S (J .. J + (Pat_Len - 1)) then + return True; + end if; + end loop; + + return False; + end if; + end Match; + + function Match + (Subject : String; + Pat : PString) return Boolean + is + Pat_Len : constant Natural := Pat'Length; + Sub_Len : constant Natural := Subject'Length; + SFirst : constant Natural := Subject'First; + + begin + if Anchored_Mode then + if Pat_Len > Sub_Len then + return False; + else + return Pat = Subject (SFirst .. SFirst + Pat_Len - 1); + end if; + + else + for J in SFirst .. SFirst + Sub_Len - Pat_Len loop + if Pat = Subject (J .. J + (Pat_Len - 1)) then + return True; + end if; + end loop; + + return False; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : VString) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Get_String (Replace, S, L); + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, S (1 .. L)); + return True; + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : String) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start = 0 then + return False; + else + Replace_Slice + (Subject'Unrestricted_Access.all, Start, Stop, Replace); + return True; + end if; + end Match; + + procedure Match + (Subject : VString; + Pat : PString) + is + S : Big_String_Access; + L : Natural; + + Start : Natural; + Stop : Natural; + pragma Unreferenced (Start, Stop); + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : String; + Pat : PString) + is + Start, Stop : Natural; + pragma Unreferenced (Start, Stop); + + subtype String1 is String (1 .. Subject'Length); + + begin + if Debug_Mode then + XMatchD (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (String1 (Subject), S_To_PE (Pat), 0, Start, Stop); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : VString) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start /= 0 then + Get_String (Replace, S, L); + Replace_Slice (Subject, Start, Stop, S (1 .. L)); + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : String) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + else + XMatch (S (1 .. L), S_To_PE (Pat), 0, Start, Stop); + end if; + + if Start /= 0 then + Replace_Slice (Subject, Start, Stop, Replace); + end if; + end Match; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Result : Match_Result_Var) return Boolean + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + Result'Unrestricted_Access.all.Var := null; + return False; + + else + Result'Unrestricted_Access.all.Var := Subject'Unrestricted_Access; + Result'Unrestricted_Access.all.Start := Start; + Result'Unrestricted_Access.all.Stop := Stop; + return True; + end if; + end Match; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Result : out Match_Result) + is + Start : Natural; + Stop : Natural; + S : Big_String_Access; + L : Natural; + + begin + Get_String (Subject, S, L); + + if Debug_Mode then + XMatchD (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + else + XMatch (S (1 .. L), Pat.P, Pat.Stk, Start, Stop); + end if; + + if Start = 0 then + Result.Var := null; + else + Result.Var := Subject'Unrestricted_Access; + Result.Start := Start; + Result.Stop := Stop; + end if; + end Match; + + --------------- + -- New_LineD -- + --------------- + + procedure New_LineD is + begin + if Internal_Debug then + New_Line; + end if; + end New_LineD; + + ------------ + -- NotAny -- + ------------ + + function NotAny (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, To_Set (Str))); + end NotAny; + + function NotAny (Str : VString) return Pattern is + begin + return NotAny (S (Str)); + end NotAny; + + function NotAny (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CH, 1, EOP, Str)); + end NotAny; + + function NotAny (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_CS, 1, EOP, Str)); + end NotAny; + + function NotAny (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_VP, 1, EOP, VString_Ptr (Str))); + end NotAny; + + function NotAny (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_NotAny_VF, 1, EOP, Str)); + end NotAny; + + ----------- + -- NSpan -- + ----------- + + function NSpan (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, To_Set (Str))); + end NSpan; + + function NSpan (Str : VString) return Pattern is + begin + return NSpan (S (Str)); + end NSpan; + + function NSpan (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CH, 1, EOP, Str)); + end NSpan; + + function NSpan (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_CS, 1, EOP, Str)); + end NSpan; + + function NSpan (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_VP, 1, EOP, VString_Ptr (Str))); + end NSpan; + + function NSpan (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_NSpan_VF, 1, EOP, Str)); + end NSpan; + + --------- + -- Pos -- + --------- + + function Pos (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_Nat, 1, EOP, Count)); + end Pos; + + function Pos (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_NF, 1, EOP, Count)); + end Pos; + + function Pos (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Pos_NP, 1, EOP, Natural_Ptr (Count))); + end Pos; + + ---------- + -- PutD -- + ---------- + + procedure PutD (Str : String) is + begin + if Internal_Debug then + Put (Str); + end if; + end PutD; + + --------------- + -- Put_LineD -- + --------------- + + procedure Put_LineD (Str : String) is + begin + if Internal_Debug then + Put_Line (Str); + end if; + end Put_LineD; + + ------------- + -- Replace -- + ------------- + + procedure Replace + (Result : in out Match_Result; + Replace : VString) + is + S : Big_String_Access; + L : Natural; + + begin + Get_String (Replace, S, L); + + if Result.Var /= null then + Replace_Slice (Result.Var.all, Result.Start, Result.Stop, S (1 .. L)); + Result.Var := null; + end if; + end Replace; + + ---------- + -- Rest -- + ---------- + + function Rest return Pattern is + begin + return (AFC with 0, new PE'(PC_Rest, 1, EOP)); + end Rest; + + ---------- + -- Rpos -- + ---------- + + function Rpos (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_Nat, 1, EOP, Count)); + end Rpos; + + function Rpos (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_NF, 1, EOP, Count)); + end Rpos; + + function Rpos (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RPos_NP, 1, EOP, Natural_Ptr (Count))); + end Rpos; + + ---------- + -- Rtab -- + ---------- + + function Rtab (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_Nat, 1, EOP, Count)); + end Rtab; + + function Rtab (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_NF, 1, EOP, Count)); + end Rtab; + + function Rtab (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_RTab_NP, 1, EOP, Natural_Ptr (Count))); + end Rtab; + + ------------- + -- S_To_PE -- + ------------- + + function S_To_PE (Str : PString) return PE_Ptr is + Len : constant Natural := Str'Length; + + begin + case Len is + when 0 => + return new PE'(PC_Null, 1, EOP); + + when 1 => + return new PE'(PC_Char, 1, EOP, Str (Str'First)); + + when 2 => + return new PE'(PC_String_2, 1, EOP, Str); + + when 3 => + return new PE'(PC_String_3, 1, EOP, Str); + + when 4 => + return new PE'(PC_String_4, 1, EOP, Str); + + when 5 => + return new PE'(PC_String_5, 1, EOP, Str); + + when 6 => + return new PE'(PC_String_6, 1, EOP, Str); + + when others => + return new PE'(PC_String, 1, EOP, new String'(Str)); + end case; + end S_To_PE; + + ------------------- + -- Set_Successor -- + ------------------- + + -- Note: this procedure is not used by the normal concatenation circuit, + -- since other fixups are required on the left operand in this case, and + -- they might as well be done all together. + + procedure Set_Successor (Pat : PE_Ptr; Succ : PE_Ptr) is + begin + if Pat = null then + Uninitialized_Pattern; + + elsif Pat = EOP then + Logic_Error; + + else + declare + Refs : Ref_Array (1 .. Pat.Index); + -- We build a reference array for L whose N'th element points to + -- the pattern element of L whose original Index value is N. + + P : PE_Ptr; + + begin + Build_Ref_Array (Pat, Refs); + + for J in Refs'Range loop + P := Refs (J); + + if P.Pthen = EOP then + P.Pthen := Succ; + end if; + + if P.Pcode in PC_Has_Alt and then P.Alt = EOP then + P.Alt := Succ; + end if; + end loop; + end; + end if; + end Set_Successor; + + ------------ + -- Setcur -- + ------------ + + function Setcur (Var : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Setcur, 1, EOP, Natural_Ptr (Var))); + end Setcur; + + ---------- + -- Span -- + ---------- + + function Span (Str : String) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, To_Set (Str))); + end Span; + + function Span (Str : VString) return Pattern is + begin + return Span (S (Str)); + end Span; + + function Span (Str : Character) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CH, 1, EOP, Str)); + end Span; + + function Span (Str : Character_Set) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_CS, 1, EOP, Str)); + end Span; + + function Span (Str : not null access VString) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_VP, 1, EOP, VString_Ptr (Str))); + end Span; + + function Span (Str : VString_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Span_VF, 1, EOP, Str)); + end Span; + + ------------ + -- Str_BF -- + ------------ + + function Str_BF (A : Boolean_Func) return String is + function To_A is new Ada.Unchecked_Conversion (Boolean_Func, Address); + begin + return "BF(" & Image (To_A (A)) & ')'; + end Str_BF; + + ------------ + -- Str_FP -- + ------------ + + function Str_FP (A : File_Ptr) return String is + begin + return "FP(" & Image (A.all'Address) & ')'; + end Str_FP; + + ------------ + -- Str_NF -- + ------------ + + function Str_NF (A : Natural_Func) return String is + function To_A is new Ada.Unchecked_Conversion (Natural_Func, Address); + begin + return "NF(" & Image (To_A (A)) & ')'; + end Str_NF; + + ------------ + -- Str_NP -- + ------------ + + function Str_NP (A : Natural_Ptr) return String is + begin + return "NP(" & Image (A.all'Address) & ')'; + end Str_NP; + + ------------ + -- Str_PP -- + ------------ + + function Str_PP (A : Pattern_Ptr) return String is + begin + return "PP(" & Image (A.all'Address) & ')'; + end Str_PP; + + ------------ + -- Str_VF -- + ------------ + + function Str_VF (A : VString_Func) return String is + function To_A is new Ada.Unchecked_Conversion (VString_Func, Address); + begin + return "VF(" & Image (To_A (A)) & ')'; + end Str_VF; + + ------------ + -- Str_VP -- + ------------ + + function Str_VP (A : VString_Ptr) return String is + begin + return "VP(" & Image (A.all'Address) & ')'; + end Str_VP; + + ------------- + -- Succeed -- + ------------- + + function Succeed return Pattern is + begin + return (AFC with 1, new PE'(PC_Succeed, 1, EOP)); + end Succeed; + + --------- + -- Tab -- + --------- + + function Tab (Count : Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_Nat, 1, EOP, Count)); + end Tab; + + function Tab (Count : Natural_Func) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_NF, 1, EOP, Count)); + end Tab; + + function Tab (Count : not null access Natural) return Pattern is + begin + return (AFC with 0, new PE'(PC_Tab_NP, 1, EOP, Natural_Ptr (Count))); + end Tab; + + --------------------------- + -- Uninitialized_Pattern -- + --------------------------- + + procedure Uninitialized_Pattern is + begin + raise Program_Error with + "uninitialized value of type GNAT.Spitbol.Patterns.Pattern"; + end Uninitialized_Pattern; + + ------------ + -- XMatch -- + ------------ + + procedure XMatch + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural) + is + Node : PE_Ptr; + -- Pointer to current pattern node. Initialized from Pat_P, and then + -- updated as the match proceeds through its constituent elements. + + Length : constant Natural := Subject'Length; + -- Length of string (= Subject'Last, since Subject'First is always 1) + + Cursor : Integer := 0; + -- If the value is non-negative, then this value is the index showing + -- the current position of the match in the subject string. The next + -- character to be matched is at Subject (Cursor + 1). Note that since + -- our view of the subject string in XMatch always has a lower bound + -- of one, regardless of original bounds, that this definition exactly + -- corresponds to the cursor value as referenced by functions like Pos. + -- + -- If the value is negative, then this is a saved stack pointer, + -- typically a base pointer of an inner or outer region. Cursor + -- temporarily holds such a value when it is popped from the stack + -- by Fail. In all cases, Cursor is reset to a proper non-negative + -- cursor value before the match proceeds (e.g. by propagating the + -- failure and popping a "real" cursor value from the stack. + + PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); + -- Dummy pattern element used in the unanchored case + + Stack : Stack_Type; + -- The pattern matching failure stack for this call to Match + + Stack_Ptr : Stack_Range; + -- Current stack pointer. This points to the top element of the stack + -- that is currently in use. At the outer level this is the special + -- entry placed on the stack according to the anchor mode. + + Stack_Init : constant Stack_Range := Stack'First + 1; + -- This is the initial value of the Stack_Ptr and Stack_Base. The + -- initial (Stack'First) element of the stack is not used so that + -- when we pop the last element off, Stack_Ptr is still in range. + + Stack_Base : Stack_Range; + -- This value is the stack base value, i.e. the stack pointer for the + -- first history stack entry in the current stack region. See separate + -- section on handling of recursive pattern matches. + + Assign_OnM : Boolean := False; + -- Set True if assign-on-match or write-on-match operations may be + -- present in the history stack, which must then be scanned on a + -- successful match. + + procedure Pop_Region; + pragma Inline (Pop_Region); + -- Used at the end of processing of an inner region. If the inner + -- region left no stack entries, then all trace of it is removed. + -- Otherwise a PC_Restore_Region entry is pushed to ensure proper + -- handling of alternatives in the inner region. + + procedure Push (Node : PE_Ptr); + pragma Inline (Push); + -- Make entry in pattern matching stack with current cursor value + + procedure Push_Region; + pragma Inline (Push_Region); + -- This procedure makes a new region on the history stack. The + -- caller first establishes the special entry on the stack, but + -- does not push the stack pointer. Then this call stacks a + -- PC_Remove_Region node, on top of this entry, using the cursor + -- field of the PC_Remove_Region entry to save the outer level + -- stack base value, and resets the stack base to point to this + -- PC_Remove_Region node. + + ---------------- + -- Pop_Region -- + ---------------- + + procedure Pop_Region is + begin + -- If nothing was pushed in the inner region, we can just get + -- rid of it entirely, leaving no traces that it was ever there + + if Stack_Ptr = Stack_Base then + Stack_Ptr := Stack_Base - 2; + Stack_Base := Stack (Stack_Ptr + 2).Cursor; + + -- If stuff was pushed in the inner region, then we have to + -- push a PC_R_Restore node so that we properly handle possible + -- rematches within the region. + + else + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Restore'Access; + Stack_Base := Stack (Stack_Base).Cursor; + end if; + end Pop_Region; + + ---------- + -- Push -- + ---------- + + procedure Push (Node : PE_Ptr) is + begin + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Cursor; + Stack (Stack_Ptr).Node := Node; + end Push; + + ----------------- + -- Push_Region -- + ----------------- + + procedure Push_Region is + begin + Stack_Ptr := Stack_Ptr + 2; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Remove'Access; + Stack_Base := Stack_Ptr; + end Push_Region; + + -- Start of processing for XMatch + + begin + if Pat_P = null then + Uninitialized_Pattern; + end if; + + -- Check we have enough stack for this pattern. This check deals with + -- every possibility except a match of a recursive pattern, where we + -- make a check at each recursion level. + + if Pat_S >= Stack_Size - 1 then + raise Pattern_Stack_Overflow; + end if; + + -- In anchored mode, the bottom entry on the stack is an abort entry + + if Anchored_Mode then + Stack (Stack_Init).Node := CP_Cancel'Access; + Stack (Stack_Init).Cursor := 0; + + -- In unanchored more, the bottom entry on the stack references + -- the special pattern element PE_Unanchored, whose Pthen field + -- points to the initial pattern element. The cursor value in this + -- entry is the number of anchor moves so far. + + else + Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; + Stack (Stack_Init).Cursor := 0; + end if; + + Stack_Ptr := Stack_Init; + Stack_Base := Stack_Ptr; + Cursor := 0; + Node := Pat_P; + goto Match; + + ----------------------------------------- + -- Main Pattern Matching State Control -- + ----------------------------------------- + + -- This is a state machine which uses gotos to change state. The + -- initial state is Match, to initiate the matching of the first + -- element, so the goto Match above starts the match. In the + -- following descriptions, we indicate the global values that + -- are relevant for the state transition. + + -- Come here if entire match fails + + <> + Start := 0; + Stop := 0; + return; + + -- Come here if entire match succeeds + + -- Cursor current position in subject string + + <> + Start := Stack (Stack_Init).Cursor + 1; + Stop := Cursor; + + -- Scan history stack for deferred assignments or writes + + if Assign_OnM then + for S in Stack_Init .. Stack_Ptr loop + if Stack (S).Node = CP_Assign'Access then + declare + Inner_Base : constant Stack_Range := + Stack (S + 1).Cursor; + Special_Entry : constant Stack_Range := + Inner_Base - 1; + Node_OnM : constant PE_Ptr := + Stack (Special_Entry).Node; + Start : constant Natural := + Stack (Special_Entry).Cursor + 1; + Stop : constant Natural := Stack (S).Cursor; + + begin + if Node_OnM.Pcode = PC_Assign_OnM then + Set_Unbounded_String + (Node_OnM.VP.all, Subject (Start .. Stop)); + + elsif Node_OnM.Pcode = PC_Write_OnM then + Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); + + else + Logic_Error; + end if; + end; + end if; + end loop; + end if; + + return; + + -- Come here if attempt to match current element fails + + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Cursor := Stack (Stack_Ptr).Cursor; + Node := Stack (Stack_Ptr).Node; + Stack_Ptr := Stack_Ptr - 1; + goto Match; + + -- Come here if attempt to match current element succeeds + + -- Cursor current position in subject string + -- Node pointer to node successfully matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Node := Node.Pthen; + + -- Come here to match the next pattern element + + -- Cursor current position in subject string + -- Node pointer to node to be matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + + -------------------------------------------------- + -- Main Pattern Match Element Matching Routines -- + -------------------------------------------------- + + -- Here is the case statement that processes the current node. The + -- processing for each element does one of five things: + + -- goto Succeed to move to the successor + -- goto Match_Succeed if the entire match succeeds + -- goto Match_Fail if the entire match fails + -- goto Fail to signal failure of current match + + -- Processing is NOT allowed to fall through + + case Node.Pcode is + + -- Cancel + + when PC_Cancel => + goto Match_Fail; + + -- Alternation + + when PC_Alt => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Any (one character case) + + when PC_Any_CH => + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (character set case) + + when PC_Any_CS => + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (string function case) + + when PC_Any_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Any (string pointer case) + + when PC_Any_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Arb (initial match) + + when PC_Arb_X => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arb (extension) + + when PC_Arb_Y => + if Cursor < Length then + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + else + goto Fail; + end if; + + -- Arbno_S (simple Arbno initialize). This is the node that + -- initiates the match of a simple Arbno structure. + + when PC_Arbno_S => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_X (Arbno initialize). This is the node that initiates + -- the match of a complex Arbno structure. + + when PC_Arbno_X => + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_Y (Arbno rematch). This is the node that is executed + -- following successful matching of one instance of a complex + -- Arbno pattern. + + when PC_Arbno_Y => declare + Null_Match : constant Boolean := + Cursor = Stack (Stack_Base - 1).Cursor; + + begin + Pop_Region; + + -- If arbno extension matched null, then immediately fail + + if Null_Match then + goto Fail; + end if; + + -- Here we must do a stack check to make sure enough stack + -- is left. This check will happen once for each instance of + -- the Arbno pattern that is matched. The Nat field of a + -- PC_Arbno pattern contains the maximum stack entries needed + -- for the Arbno with one instance and the successor pattern + + if Stack_Ptr + Node.Nat >= Stack'Last then + raise Pattern_Stack_Overflow; + end if; + + goto Succeed; + end; + + -- Assign. If this node is executed, it means the assign-on-match + -- or write-on-match operation will not happen after all, so we + -- is propagate the failure, removing the PC_Assign node. + + when PC_Assign => + goto Fail; + + -- Assign immediate. This node performs the actual assignment + + when PC_Assign_Imm => + Set_Unbounded_String + (Node.VP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Assign on match. This node sets up for the eventual assignment + + when PC_Assign_OnM => + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + -- Bal + + when PC_Bal => + if Cursor >= Length or else Subject (Cursor + 1) = ')' then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + declare + Paren_Count : Natural := 1; + + begin + loop + Cursor := Cursor + 1; + + if Cursor >= Length then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + Paren_Count := Paren_Count + 1; + + elsif Subject (Cursor + 1) = ')' then + Paren_Count := Paren_Count - 1; + exit when Paren_Count = 0; + end if; + end loop; + end; + end if; + + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + + -- Break (one character case) + + when PC_Break_CH => + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (character set case) + + when PC_Break_CS => + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (string function case) + + when PC_Break_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- Break (string pointer case) + + when PC_Break_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (one character case) + + when PC_BreakX_CH => + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (character set case) + + when PC_BreakX_CS => + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (string function case) + + when PC_BreakX_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (string pointer case) + + when PC_BreakX_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX_X (BreakX extension). See section on "Compound Pattern + -- Structures". This node is the alternative that is stacked to + -- skip past the break character and extend the break. + + when PC_BreakX_X => + Cursor := Cursor + 1; + goto Succeed; + + -- Character (one character string) + + when PC_Char => + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- End of Pattern + + when PC_EOP => + if Stack_Base = Stack_Init then + goto Match_Succeed; + + -- End of recursive inner match. See separate section on + -- handing of recursive pattern matches for details. + + else + Node := Stack (Stack_Base - 1).Node; + Pop_Region; + goto Match; + end if; + + -- Fail + + when PC_Fail => + goto Fail; + + -- Fence (built in pattern) + + when PC_Fence => + Push (CP_Cancel'Access); + goto Succeed; + + -- Fence function node X. This is the node that gets control + -- after a successful match of the fenced pattern. + + when PC_Fence_X => + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_Fence_Y'Access; + Stack_Base := Stack (Stack_Base).Cursor; + goto Succeed; + + -- Fence function node Y. This is the node that gets control on + -- a failure that occurs after the fenced pattern has matched. + + -- Note: the Cursor at this stage is actually the inner stack + -- base value. We don't reset this, but we do use it to strip + -- off all the entries made by the fenced pattern. + + when PC_Fence_Y => + Stack_Ptr := Cursor - 2; + goto Fail; + + -- Len (integer case) + + when PC_Len_Nat => + if Cursor + Node.Nat > Length then + goto Fail; + else + Cursor := Cursor + Node.Nat; + goto Succeed; + end if; + + -- Len (Integer function case) + + when PC_Len_NF => declare + N : constant Natural := Node.NF.all; + begin + if Cursor + N > Length then + goto Fail; + else + Cursor := Cursor + N; + goto Succeed; + end if; + end; + + -- Len (integer pointer case) + + when PC_Len_NP => + if Cursor + Node.NP.all > Length then + goto Fail; + else + Cursor := Cursor + Node.NP.all; + goto Succeed; + end if; + + -- NotAny (one character case) + + when PC_NotAny_CH => + if Cursor < Length + and then Subject (Cursor + 1) /= Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (character set case) + + when PC_NotAny_CS => + if Cursor < Length + and then not Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (string function case) + + when PC_NotAny_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NotAny (string pointer case) + + when PC_NotAny_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NSpan (one character case) + + when PC_NSpan_CH => + while Cursor < Length + and then Subject (Cursor + 1) = Node.Char + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (character set case) + + when PC_NSpan_CS => + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (string function case) + + when PC_NSpan_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- NSpan (string pointer case) + + when PC_NSpan_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- Null string + + when PC_Null => + goto Succeed; + + -- Pos (integer case) + + when PC_Pos_Nat => + if Cursor = Node.Nat then + goto Succeed; + else + goto Fail; + end if; + + -- Pos (Integer function case) + + when PC_Pos_NF => declare + N : constant Natural := Node.NF.all; + begin + if Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- Pos (integer pointer case) + + when PC_Pos_NP => + if Cursor = Node.NP.all then + goto Succeed; + else + goto Fail; + end if; + + -- Predicate function + + when PC_Pred_Func => + if Node.BF.all then + goto Succeed; + else + goto Fail; + end if; + + -- Region Enter. Initiate new pattern history stack region + + when PC_R_Enter => + Stack (Stack_Ptr + 1).Cursor := Cursor; + Push_Region; + goto Succeed; + + -- Region Remove node. This is the node stacked by an R_Enter. + -- It removes the special format stack entry right underneath, and + -- then restores the outer level stack base and signals failure. + + -- Note: the cursor value at this stage is actually the (negative) + -- stack base value for the outer level. + + when PC_R_Remove => + Stack_Base := Cursor; + Stack_Ptr := Stack_Ptr - 1; + goto Fail; + + -- Region restore node. This is the node stacked at the end of an + -- inner level match. Its function is to restore the inner level + -- region, so that alternatives in this region can be sought. + + -- Note: the Cursor at this stage is actually the negative of the + -- inner stack base value, which we use to restore the inner region. + + when PC_R_Restore => + Stack_Base := Cursor; + goto Fail; + + -- Rest + + when PC_Rest => + Cursor := Length; + goto Succeed; + + -- Initiate recursive match (pattern pointer case) + + when PC_Rpat => + Stack (Stack_Ptr + 1).Node := Node.Pthen; + Push_Region; + + if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then + raise Pattern_Stack_Overflow; + else + Node := Node.PP.all.P; + goto Match; + end if; + + -- RPos (integer case) + + when PC_RPos_Nat => + if Cursor = (Length - Node.Nat) then + goto Succeed; + else + goto Fail; + end if; + + -- RPos (integer function case) + + when PC_RPos_NF => declare + N : constant Natural := Node.NF.all; + begin + if Length - Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- RPos (integer pointer case) + + when PC_RPos_NP => + if Cursor = (Length - Node.NP.all) then + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer case) + + when PC_RTab_Nat => + if Cursor <= (Length - Node.Nat) then + Cursor := Length - Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer function case) + + when PC_RTab_NF => declare + N : constant Natural := Node.NF.all; + begin + if Length - Cursor >= N then + Cursor := Length - N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- RTab (integer pointer case) + + when PC_RTab_NP => + if Cursor <= (Length - Node.NP.all) then + Cursor := Length - Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Cursor assignment + + when PC_Setcur => + Node.Var.all := Cursor; + goto Succeed; + + -- Span (one character case) + + when PC_Span_CH => declare + P : Natural; + + begin + P := Cursor; + while P < Length + and then Subject (P + 1) = Node.Char + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (character set case) + + when PC_Span_CS => declare + P : Natural; + + begin + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), Node.CS) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string function case) + + when PC_Span_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string pointer case) + + when PC_Span_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (two character case) + + when PC_String_2 => + if (Length - Cursor) >= 2 + and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 + then + Cursor := Cursor + 2; + goto Succeed; + else + goto Fail; + end if; + + -- String (three character case) + + when PC_String_3 => + if (Length - Cursor) >= 3 + and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 + then + Cursor := Cursor + 3; + goto Succeed; + else + goto Fail; + end if; + + -- String (four character case) + + when PC_String_4 => + if (Length - Cursor) >= 4 + and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 + then + Cursor := Cursor + 4; + goto Succeed; + else + goto Fail; + end if; + + -- String (five character case) + + when PC_String_5 => + if (Length - Cursor) >= 5 + and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 + then + Cursor := Cursor + 5; + goto Succeed; + else + goto Fail; + end if; + + -- String (six character case) + + when PC_String_6 => + if (Length - Cursor) >= 6 + and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 + then + Cursor := Cursor + 6; + goto Succeed; + else + goto Fail; + end if; + + -- String (case of more than six characters) + + when PC_String => declare + Len : constant Natural := Node.Str'Length; + begin + if (Length - Cursor) >= Len + and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (function case) + + when PC_String_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (pointer case) + + when PC_String_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Succeed + + when PC_Succeed => + Push (Node); + goto Succeed; + + -- Tab (integer case) + + when PC_Tab_Nat => + if Cursor <= Node.Nat then + Cursor := Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- Tab (integer function case) + + when PC_Tab_NF => declare + N : constant Natural := Node.NF.all; + begin + if Cursor <= N then + Cursor := N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Tab (integer pointer case) + + when PC_Tab_NP => + if Cursor <= Node.NP.all then + Cursor := Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Unanchored movement + + when PC_Unanchored => + + -- All done if we tried every position + + if Cursor > Length then + goto Match_Fail; + + -- Otherwise extend the anchor point, and restack ourself + + else + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + end if; + + -- Write immediate. This node performs the actual write + + when PC_Write_Imm => + Put_Line + (Node.FP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Write on match. This node sets up for the eventual write + + when PC_Write_OnM => + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + end case; + + -- We are NOT allowed to fall though this case statement, since every + -- match routine must end by executing a goto to the appropriate point + -- in the finite state machine model. + + pragma Warnings (Off); + Logic_Error; + pragma Warnings (On); + end XMatch; + + ------------- + -- XMatchD -- + ------------- + + -- Maintenance note: There is a LOT of code duplication between XMatch + -- and XMatchD. This is quite intentional, the point is to avoid any + -- unnecessary debugging overhead in the XMatch case, but this does mean + -- that any changes to XMatchD must be mirrored in XMatch. In case of + -- any major changes, the proper approach is to delete XMatch, make the + -- changes to XMatchD, and then make a copy of XMatchD, removing all + -- calls to Dout, and all Put and Put_Line operations. This copy becomes + -- the new XMatch. + + procedure XMatchD + (Subject : String; + Pat_P : PE_Ptr; + Pat_S : Natural; + Start : out Natural; + Stop : out Natural) + is + Node : PE_Ptr; + -- Pointer to current pattern node. Initialized from Pat_P, and then + -- updated as the match proceeds through its constituent elements. + + Length : constant Natural := Subject'Length; + -- Length of string (= Subject'Last, since Subject'First is always 1) + + Cursor : Integer := 0; + -- If the value is non-negative, then this value is the index showing + -- the current position of the match in the subject string. The next + -- character to be matched is at Subject (Cursor + 1). Note that since + -- our view of the subject string in XMatch always has a lower bound + -- of one, regardless of original bounds, that this definition exactly + -- corresponds to the cursor value as referenced by functions like Pos. + -- + -- If the value is negative, then this is a saved stack pointer, + -- typically a base pointer of an inner or outer region. Cursor + -- temporarily holds such a value when it is popped from the stack + -- by Fail. In all cases, Cursor is reset to a proper non-negative + -- cursor value before the match proceeds (e.g. by propagating the + -- failure and popping a "real" cursor value from the stack. + + PE_Unanchored : aliased PE := (PC_Unanchored, 0, Pat_P); + -- Dummy pattern element used in the unanchored case + + Region_Level : Natural := 0; + -- Keeps track of recursive region level. This is used only for + -- debugging, it is the number of saved history stack base values. + + Stack : Stack_Type; + -- The pattern matching failure stack for this call to Match + + Stack_Ptr : Stack_Range; + -- Current stack pointer. This points to the top element of the stack + -- that is currently in use. At the outer level this is the special + -- entry placed on the stack according to the anchor mode. + + Stack_Init : constant Stack_Range := Stack'First + 1; + -- This is the initial value of the Stack_Ptr and Stack_Base. The + -- initial (Stack'First) element of the stack is not used so that + -- when we pop the last element off, Stack_Ptr is still in range. + + Stack_Base : Stack_Range; + -- This value is the stack base value, i.e. the stack pointer for the + -- first history stack entry in the current stack region. See separate + -- section on handling of recursive pattern matches. + + Assign_OnM : Boolean := False; + -- Set True if assign-on-match or write-on-match operations may be + -- present in the history stack, which must then be scanned on a + -- successful match. + + procedure Dout (Str : String); + -- Output string to standard error with bars indicating region level + + procedure Dout (Str : String; A : Character); + -- Calls Dout with the string S ('A') + + procedure Dout (Str : String; A : Character_Set); + -- Calls Dout with the string S ("A") + + procedure Dout (Str : String; A : Natural); + -- Calls Dout with the string S (A) + + procedure Dout (Str : String; A : String); + -- Calls Dout with the string S ("A") + + function Img (P : PE_Ptr) return String; + -- Returns a string of the form #nnn where nnn is P.Index + + procedure Pop_Region; + pragma Inline (Pop_Region); + -- Used at the end of processing of an inner region. If the inner + -- region left no stack entries, then all trace of it is removed. + -- Otherwise a PC_Restore_Region entry is pushed to ensure proper + -- handling of alternatives in the inner region. + + procedure Push (Node : PE_Ptr); + pragma Inline (Push); + -- Make entry in pattern matching stack with current cursor value + + procedure Push_Region; + pragma Inline (Push_Region); + -- This procedure makes a new region on the history stack. The + -- caller first establishes the special entry on the stack, but + -- does not push the stack pointer. Then this call stacks a + -- PC_Remove_Region node, on top of this entry, using the cursor + -- field of the PC_Remove_Region entry to save the outer level + -- stack base value, and resets the stack base to point to this + -- PC_Remove_Region node. + + ---------- + -- Dout -- + ---------- + + procedure Dout (Str : String) is + begin + for J in 1 .. Region_Level loop + Put ("| "); + end loop; + + Put_Line (Str); + end Dout; + + procedure Dout (Str : String; A : Character) is + begin + Dout (Str & " ('" & A & "')"); + end Dout; + + procedure Dout (Str : String; A : Character_Set) is + begin + Dout (Str & " (" & Image (To_Sequence (A)) & ')'); + end Dout; + + procedure Dout (Str : String; A : Natural) is + begin + Dout (Str & " (" & A & ')'); + end Dout; + + procedure Dout (Str : String; A : String) is + begin + Dout (Str & " (" & Image (A) & ')'); + end Dout; + + --------- + -- Img -- + --------- + + function Img (P : PE_Ptr) return String is + begin + return "#" & Integer (P.Index) & " "; + end Img; + + ---------------- + -- Pop_Region -- + ---------------- + + procedure Pop_Region is + begin + Region_Level := Region_Level - 1; + + -- If nothing was pushed in the inner region, we can just get + -- rid of it entirely, leaving no traces that it was ever there + + if Stack_Ptr = Stack_Base then + Stack_Ptr := Stack_Base - 2; + Stack_Base := Stack (Stack_Ptr + 2).Cursor; + + -- If stuff was pushed in the inner region, then we have to + -- push a PC_R_Restore node so that we properly handle possible + -- rematches within the region. + + else + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Restore'Access; + Stack_Base := Stack (Stack_Base).Cursor; + end if; + end Pop_Region; + + ---------- + -- Push -- + ---------- + + procedure Push (Node : PE_Ptr) is + begin + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Cursor; + Stack (Stack_Ptr).Node := Node; + end Push; + + ----------------- + -- Push_Region -- + ----------------- + + procedure Push_Region is + begin + Region_Level := Region_Level + 1; + Stack_Ptr := Stack_Ptr + 2; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_R_Remove'Access; + Stack_Base := Stack_Ptr; + end Push_Region; + + -- Start of processing for XMatchD + + begin + New_Line; + Put_Line ("Initiating pattern match, subject = " & Image (Subject)); + Put ("--------------------------------------"); + + for J in 1 .. Length loop + Put ('-'); + end loop; + + New_Line; + Put_Line ("subject length = " & Length); + + if Pat_P = null then + Uninitialized_Pattern; + end if; + + -- Check we have enough stack for this pattern. This check deals with + -- every possibility except a match of a recursive pattern, where we + -- make a check at each recursion level. + + if Pat_S >= Stack_Size - 1 then + raise Pattern_Stack_Overflow; + end if; + + -- In anchored mode, the bottom entry on the stack is an abort entry + + if Anchored_Mode then + Stack (Stack_Init).Node := CP_Cancel'Access; + Stack (Stack_Init).Cursor := 0; + + -- In unanchored more, the bottom entry on the stack references + -- the special pattern element PE_Unanchored, whose Pthen field + -- points to the initial pattern element. The cursor value in this + -- entry is the number of anchor moves so far. + + else + Stack (Stack_Init).Node := PE_Unanchored'Unchecked_Access; + Stack (Stack_Init).Cursor := 0; + end if; + + Stack_Ptr := Stack_Init; + Stack_Base := Stack_Ptr; + Cursor := 0; + Node := Pat_P; + goto Match; + + ----------------------------------------- + -- Main Pattern Matching State Control -- + ----------------------------------------- + + -- This is a state machine which uses gotos to change state. The + -- initial state is Match, to initiate the matching of the first + -- element, so the goto Match above starts the match. In the + -- following descriptions, we indicate the global values that + -- are relevant for the state transition. + + -- Come here if entire match fails + + <> + Dout ("match fails"); + New_Line; + Start := 0; + Stop := 0; + return; + + -- Come here if entire match succeeds + + -- Cursor current position in subject string + + <> + Dout ("match succeeds"); + Start := Stack (Stack_Init).Cursor + 1; + Stop := Cursor; + Dout ("first matched character index = " & Start); + Dout ("last matched character index = " & Stop); + Dout ("matched substring = " & Image (Subject (Start .. Stop))); + + -- Scan history stack for deferred assignments or writes + + if Assign_OnM then + for S in Stack'First .. Stack_Ptr loop + if Stack (S).Node = CP_Assign'Access then + declare + Inner_Base : constant Stack_Range := + Stack (S + 1).Cursor; + Special_Entry : constant Stack_Range := + Inner_Base - 1; + Node_OnM : constant PE_Ptr := + Stack (Special_Entry).Node; + Start : constant Natural := + Stack (Special_Entry).Cursor + 1; + Stop : constant Natural := Stack (S).Cursor; + + begin + if Node_OnM.Pcode = PC_Assign_OnM then + Set_Unbounded_String + (Node_OnM.VP.all, Subject (Start .. Stop)); + Dout + (Img (Stack (S).Node) & + "deferred assignment of " & + Image (Subject (Start .. Stop))); + + elsif Node_OnM.Pcode = PC_Write_OnM then + Put_Line (Node_OnM.FP.all, Subject (Start .. Stop)); + Dout + (Img (Stack (S).Node) & + "deferred write of " & + Image (Subject (Start .. Stop))); + + else + Logic_Error; + end if; + end; + end if; + end loop; + end if; + + New_Line; + return; + + -- Come here if attempt to match current element fails + + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Cursor := Stack (Stack_Ptr).Cursor; + Node := Stack (Stack_Ptr).Node; + Stack_Ptr := Stack_Ptr - 1; + + if Cursor >= 0 then + Dout ("failure, cursor reset to " & Cursor); + end if; + + goto Match; + + -- Come here if attempt to match current element succeeds + + -- Cursor current position in subject string + -- Node pointer to node successfully matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + Dout ("success, cursor = " & Cursor); + Node := Node.Pthen; + + -- Come here to match the next pattern element + + -- Cursor current position in subject string + -- Node pointer to node to be matched + -- Stack_Base current stack base + -- Stack_Ptr current stack pointer + + <> + + -------------------------------------------------- + -- Main Pattern Match Element Matching Routines -- + -------------------------------------------------- + + -- Here is the case statement that processes the current node. The + -- processing for each element does one of five things: + + -- goto Succeed to move to the successor + -- goto Match_Succeed if the entire match succeeds + -- goto Match_Fail if the entire match fails + -- goto Fail to signal failure of current match + + -- Processing is NOT allowed to fall through + + case Node.Pcode is + + -- Cancel + + when PC_Cancel => + Dout (Img (Node) & "matching Cancel"); + goto Match_Fail; + + -- Alternation + + when PC_Alt => + Dout (Img (Node) & "setting up alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Any (one character case) + + when PC_Any_CH => + Dout (Img (Node) & "matching Any", Node.Char); + + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (character set case) + + when PC_Any_CS => + Dout (Img (Node) & "matching Any", Node.CS); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- Any (string function case) + + when PC_Any_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + + Dout (Img (Node) & "matching Any", S (1 .. L)); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Any (string pointer case) + + when PC_Any_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Any", S (1 .. L)); + + if Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Arb (initial match) + + when PC_Arb_X => + Dout (Img (Node) & "matching Arb"); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arb (extension) + + when PC_Arb_Y => + Dout (Img (Node) & "extending Arb"); + + if Cursor < Length then + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + else + goto Fail; + end if; + + -- Arbno_S (simple Arbno initialize). This is the node that + -- initiates the match of a simple Arbno structure. + + when PC_Arbno_S => + Dout (Img (Node) & + "setting up Arbno alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_X (Arbno initialize). This is the node that initiates + -- the match of a complex Arbno structure. + + when PC_Arbno_X => + Dout (Img (Node) & + "setting up Arbno alternative " & Img (Node.Alt)); + Push (Node.Alt); + Node := Node.Pthen; + goto Match; + + -- Arbno_Y (Arbno rematch). This is the node that is executed + -- following successful matching of one instance of a complex + -- Arbno pattern. + + when PC_Arbno_Y => declare + Null_Match : constant Boolean := + Cursor = Stack (Stack_Base - 1).Cursor; + + begin + Dout (Img (Node) & "extending Arbno"); + Pop_Region; + + -- If arbno extension matched null, then immediately fail + + if Null_Match then + Dout ("Arbno extension matched null, so fails"); + goto Fail; + end if; + + -- Here we must do a stack check to make sure enough stack + -- is left. This check will happen once for each instance of + -- the Arbno pattern that is matched. The Nat field of a + -- PC_Arbno pattern contains the maximum stack entries needed + -- for the Arbno with one instance and the successor pattern + + if Stack_Ptr + Node.Nat >= Stack'Last then + raise Pattern_Stack_Overflow; + end if; + + goto Succeed; + end; + + -- Assign. If this node is executed, it means the assign-on-match + -- or write-on-match operation will not happen after all, so we + -- is propagate the failure, removing the PC_Assign node. + + when PC_Assign => + Dout (Img (Node) & "deferred assign/write cancelled"); + goto Fail; + + -- Assign immediate. This node performs the actual assignment + + when PC_Assign_Imm => + Dout + (Img (Node) & "executing immediate assignment of " & + Image (Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor))); + Set_Unbounded_String + (Node.VP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Assign on match. This node sets up for the eventual assignment + + when PC_Assign_OnM => + Dout (Img (Node) & "registering deferred assignment"); + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + + -- Bal + + when PC_Bal => + Dout (Img (Node) & "matching or extending Bal"); + if Cursor >= Length or else Subject (Cursor + 1) = ')' then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + declare + Paren_Count : Natural := 1; + + begin + loop + Cursor := Cursor + 1; + + if Cursor >= Length then + goto Fail; + + elsif Subject (Cursor + 1) = '(' then + Paren_Count := Paren_Count + 1; + + elsif Subject (Cursor + 1) = ')' then + Paren_Count := Paren_Count - 1; + exit when Paren_Count = 0; + end if; + end loop; + end; + end if; + + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + + -- Break (one character case) + + when PC_Break_CH => + Dout (Img (Node) & "matching Break", Node.Char); + + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (character set case) + + when PC_Break_CS => + Dout (Img (Node) & "matching Break", Node.CS); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- Break (string function case) + + when PC_Break_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Break", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- Break (string pointer case) + + when PC_Break_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Break", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (one character case) + + when PC_BreakX_CH => + Dout (Img (Node) & "matching BreakX", Node.Char); + + while Cursor < Length loop + if Subject (Cursor + 1) = Node.Char then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (character set case) + + when PC_BreakX_CS => + Dout (Img (Node) & "matching BreakX", Node.CS); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), Node.CS) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + + -- BreakX (string function case) + + when PC_BreakX_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching BreakX", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX (string pointer case) + + when PC_BreakX_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching BreakX", S (1 .. L)); + + while Cursor < Length loop + if Is_In (Subject (Cursor + 1), S (1 .. L)) then + goto Succeed; + else + Cursor := Cursor + 1; + end if; + end loop; + + goto Fail; + end; + + -- BreakX_X (BreakX extension). See section on "Compound Pattern + -- Structures". This node is the alternative that is stacked + -- to skip past the break character and extend the break. + + when PC_BreakX_X => + Dout (Img (Node) & "extending BreakX"); + Cursor := Cursor + 1; + goto Succeed; + + -- Character (one character string) + + when PC_Char => + Dout (Img (Node) & "matching '" & Node.Char & '''); + + if Cursor < Length + and then Subject (Cursor + 1) = Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- End of Pattern + + when PC_EOP => + if Stack_Base = Stack_Init then + Dout ("end of pattern"); + goto Match_Succeed; + + -- End of recursive inner match. See separate section on + -- handing of recursive pattern matches for details. + + else + Dout ("terminating recursive match"); + Node := Stack (Stack_Base - 1).Node; + Pop_Region; + goto Match; + end if; + + -- Fail + + when PC_Fail => + Dout (Img (Node) & "matching Fail"); + goto Fail; + + -- Fence (built in pattern) + + when PC_Fence => + Dout (Img (Node) & "matching Fence"); + Push (CP_Cancel'Access); + goto Succeed; + + -- Fence function node X. This is the node that gets control + -- after a successful match of the fenced pattern. + + when PC_Fence_X => + Dout (Img (Node) & "matching Fence function"); + Stack_Ptr := Stack_Ptr + 1; + Stack (Stack_Ptr).Cursor := Stack_Base; + Stack (Stack_Ptr).Node := CP_Fence_Y'Access; + Stack_Base := Stack (Stack_Base).Cursor; + Region_Level := Region_Level - 1; + goto Succeed; + + -- Fence function node Y. This is the node that gets control on + -- a failure that occurs after the fenced pattern has matched. + + -- Note: the Cursor at this stage is actually the inner stack + -- base value. We don't reset this, but we do use it to strip + -- off all the entries made by the fenced pattern. + + when PC_Fence_Y => + Dout (Img (Node) & "pattern matched by Fence caused failure"); + Stack_Ptr := Cursor - 2; + goto Fail; + + -- Len (integer case) + + when PC_Len_Nat => + Dout (Img (Node) & "matching Len", Node.Nat); + + if Cursor + Node.Nat > Length then + goto Fail; + else + Cursor := Cursor + Node.Nat; + goto Succeed; + end if; + + -- Len (Integer function case) + + when PC_Len_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Len", N); + + if Cursor + N > Length then + goto Fail; + else + Cursor := Cursor + N; + goto Succeed; + end if; + end; + + -- Len (integer pointer case) + + when PC_Len_NP => + Dout (Img (Node) & "matching Len", Node.NP.all); + + if Cursor + Node.NP.all > Length then + goto Fail; + else + Cursor := Cursor + Node.NP.all; + goto Succeed; + end if; + + -- NotAny (one character case) + + when PC_NotAny_CH => + Dout (Img (Node) & "matching NotAny", Node.Char); + + if Cursor < Length + and then Subject (Cursor + 1) /= Node.Char + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (character set case) + + when PC_NotAny_CS => + Dout (Img (Node) & "matching NotAny", Node.CS); + + if Cursor < Length + and then not Is_In (Subject (Cursor + 1), Node.CS) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + + -- NotAny (string function case) + + when PC_NotAny_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NotAny", S (1 .. L)); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NotAny (string pointer case) + + when PC_NotAny_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NotAny", S (1 .. L)); + + if Cursor < Length + and then + not Is_In (Subject (Cursor + 1), S (1 .. L)) + then + Cursor := Cursor + 1; + goto Succeed; + else + goto Fail; + end if; + end; + + -- NSpan (one character case) + + when PC_NSpan_CH => + Dout (Img (Node) & "matching NSpan", Node.Char); + + while Cursor < Length + and then Subject (Cursor + 1) = Node.Char + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (character set case) + + when PC_NSpan_CS => + Dout (Img (Node) & "matching NSpan", Node.CS); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), Node.CS) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + + -- NSpan (string function case) + + when PC_NSpan_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NSpan", S (1 .. L)); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + -- NSpan (string pointer case) + + when PC_NSpan_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching NSpan", S (1 .. L)); + + while Cursor < Length + and then Is_In (Subject (Cursor + 1), S (1 .. L)) + loop + Cursor := Cursor + 1; + end loop; + + goto Succeed; + end; + + when PC_Null => + Dout (Img (Node) & "matching null"); + goto Succeed; + + -- Pos (integer case) + + when PC_Pos_Nat => + Dout (Img (Node) & "matching Pos", Node.Nat); + + if Cursor = Node.Nat then + goto Succeed; + else + goto Fail; + end if; + + -- Pos (Integer function case) + + when PC_Pos_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Pos", N); + + if Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- Pos (integer pointer case) + + when PC_Pos_NP => + Dout (Img (Node) & "matching Pos", Node.NP.all); + + if Cursor = Node.NP.all then + goto Succeed; + else + goto Fail; + end if; + + -- Predicate function + + when PC_Pred_Func => + Dout (Img (Node) & "matching predicate function"); + + if Node.BF.all then + goto Succeed; + else + goto Fail; + end if; + + -- Region Enter. Initiate new pattern history stack region + + when PC_R_Enter => + Dout (Img (Node) & "starting match of nested pattern"); + Stack (Stack_Ptr + 1).Cursor := Cursor; + Push_Region; + goto Succeed; + + -- Region Remove node. This is the node stacked by an R_Enter. + -- It removes the special format stack entry right underneath, and + -- then restores the outer level stack base and signals failure. + + -- Note: the cursor value at this stage is actually the (negative) + -- stack base value for the outer level. + + when PC_R_Remove => + Dout ("failure, match of nested pattern terminated"); + Stack_Base := Cursor; + Region_Level := Region_Level - 1; + Stack_Ptr := Stack_Ptr - 1; + goto Fail; + + -- Region restore node. This is the node stacked at the end of an + -- inner level match. Its function is to restore the inner level + -- region, so that alternatives in this region can be sought. + + -- Note: the Cursor at this stage is actually the negative of the + -- inner stack base value, which we use to restore the inner region. + + when PC_R_Restore => + Dout ("failure, search for alternatives in nested pattern"); + Region_Level := Region_Level + 1; + Stack_Base := Cursor; + goto Fail; + + -- Rest + + when PC_Rest => + Dout (Img (Node) & "matching Rest"); + Cursor := Length; + goto Succeed; + + -- Initiate recursive match (pattern pointer case) + + when PC_Rpat => + Stack (Stack_Ptr + 1).Node := Node.Pthen; + Push_Region; + Dout (Img (Node) & "initiating recursive match"); + + if Stack_Ptr + Node.PP.all.Stk >= Stack_Size then + raise Pattern_Stack_Overflow; + else + Node := Node.PP.all.P; + goto Match; + end if; + + -- RPos (integer case) + + when PC_RPos_Nat => + Dout (Img (Node) & "matching RPos", Node.Nat); + + if Cursor = (Length - Node.Nat) then + goto Succeed; + else + goto Fail; + end if; + + -- RPos (integer function case) + + when PC_RPos_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching RPos", N); + + if Length - Cursor = N then + goto Succeed; + else + goto Fail; + end if; + end; + + -- RPos (integer pointer case) + + when PC_RPos_NP => + Dout (Img (Node) & "matching RPos", Node.NP.all); + + if Cursor = (Length - Node.NP.all) then + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer case) + + when PC_RTab_Nat => + Dout (Img (Node) & "matching RTab", Node.Nat); + + if Cursor <= (Length - Node.Nat) then + Cursor := Length - Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- RTab (integer function case) + + when PC_RTab_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching RPos", N); + + if Length - Cursor >= N then + Cursor := Length - N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- RTab (integer pointer case) + + when PC_RTab_NP => + Dout (Img (Node) & "matching RPos", Node.NP.all); + + if Cursor <= (Length - Node.NP.all) then + Cursor := Length - Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Cursor assignment + + when PC_Setcur => + Dout (Img (Node) & "matching Setcur"); + Node.Var.all := Cursor; + goto Succeed; + + -- Span (one character case) + + when PC_Span_CH => declare + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Node.Char); + + while P < Length + and then Subject (P + 1) = Node.Char + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (character set case) + + when PC_Span_CS => declare + P : Natural := Cursor; + + begin + Dout (Img (Node) & "matching Span", Node.CS); + + while P < Length + and then Is_In (Subject (P + 1), Node.CS) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string function case) + + when PC_Span_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Span", S (1 .. L)); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Span (string pointer case) + + when PC_Span_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + P : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching Span", S (1 .. L)); + + P := Cursor; + while P < Length + and then Is_In (Subject (P + 1), S (1 .. L)) + loop + P := P + 1; + end loop; + + if P /= Cursor then + Cursor := P; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (two character case) + + when PC_String_2 => + Dout (Img (Node) & "matching " & Image (Node.Str2)); + + if (Length - Cursor) >= 2 + and then Subject (Cursor + 1 .. Cursor + 2) = Node.Str2 + then + Cursor := Cursor + 2; + goto Succeed; + else + goto Fail; + end if; + + -- String (three character case) + + when PC_String_3 => + Dout (Img (Node) & "matching " & Image (Node.Str3)); + + if (Length - Cursor) >= 3 + and then Subject (Cursor + 1 .. Cursor + 3) = Node.Str3 + then + Cursor := Cursor + 3; + goto Succeed; + else + goto Fail; + end if; + + -- String (four character case) + + when PC_String_4 => + Dout (Img (Node) & "matching " & Image (Node.Str4)); + + if (Length - Cursor) >= 4 + and then Subject (Cursor + 1 .. Cursor + 4) = Node.Str4 + then + Cursor := Cursor + 4; + goto Succeed; + else + goto Fail; + end if; + + -- String (five character case) + + when PC_String_5 => + Dout (Img (Node) & "matching " & Image (Node.Str5)); + + if (Length - Cursor) >= 5 + and then Subject (Cursor + 1 .. Cursor + 5) = Node.Str5 + then + Cursor := Cursor + 5; + goto Succeed; + else + goto Fail; + end if; + + -- String (six character case) + + when PC_String_6 => + Dout (Img (Node) & "matching " & Image (Node.Str6)); + + if (Length - Cursor) >= 6 + and then Subject (Cursor + 1 .. Cursor + 6) = Node.Str6 + then + Cursor := Cursor + 6; + goto Succeed; + else + goto Fail; + end if; + + -- String (case of more than six characters) + + when PC_String => declare + Len : constant Natural := Node.Str'Length; + + begin + Dout (Img (Node) & "matching " & Image (Node.Str.all)); + + if (Length - Cursor) >= Len + and then Node.Str.all = Subject (Cursor + 1 .. Cursor + Len) + then + Cursor := Cursor + Len; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (function case) + + when PC_String_VF => declare + U : constant VString := Node.VF.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching " & Image (S (1 .. L))); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- String (vstring pointer case) + + when PC_String_VP => declare + U : constant VString := Node.VP.all; + S : Big_String_Access; + L : Natural; + + begin + Get_String (U, S, L); + Dout (Img (Node) & "matching " & Image (S (1 .. L))); + + if (Length - Cursor) >= L + and then S (1 .. L) = Subject (Cursor + 1 .. Cursor + L) + then + Cursor := Cursor + L; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Succeed + + when PC_Succeed => + Dout (Img (Node) & "matching Succeed"); + Push (Node); + goto Succeed; + + -- Tab (integer case) + + when PC_Tab_Nat => + Dout (Img (Node) & "matching Tab", Node.Nat); + + if Cursor <= Node.Nat then + Cursor := Node.Nat; + goto Succeed; + else + goto Fail; + end if; + + -- Tab (integer function case) + + when PC_Tab_NF => declare + N : constant Natural := Node.NF.all; + + begin + Dout (Img (Node) & "matching Tab ", N); + + if Cursor <= N then + Cursor := N; + goto Succeed; + else + goto Fail; + end if; + end; + + -- Tab (integer pointer case) + + when PC_Tab_NP => + Dout (Img (Node) & "matching Tab ", Node.NP.all); + + if Cursor <= Node.NP.all then + Cursor := Node.NP.all; + goto Succeed; + else + goto Fail; + end if; + + -- Unanchored movement + + when PC_Unanchored => + Dout ("attempting to move anchor point"); + + -- All done if we tried every position + + if Cursor > Length then + goto Match_Fail; + + -- Otherwise extend the anchor point, and restack ourself + + else + Cursor := Cursor + 1; + Push (Node); + goto Succeed; + end if; + + -- Write immediate. This node performs the actual write + + when PC_Write_Imm => + Dout (Img (Node) & "executing immediate write of " & + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + + Put_Line + (Node.FP.all, + Subject (Stack (Stack_Base - 1).Cursor + 1 .. Cursor)); + Pop_Region; + goto Succeed; + + -- Write on match. This node sets up for the eventual write + + when PC_Write_OnM => + Dout (Img (Node) & "registering deferred write"); + Stack (Stack_Base - 1).Node := Node; + Push (CP_Assign'Access); + Pop_Region; + Assign_OnM := True; + goto Succeed; + end case; + + -- We are NOT allowed to fall though this case statement, since every + -- match routine must end by executing a goto to the appropriate point + -- in the finite state machine model. + + pragma Warnings (Off); + Logic_Error; + pragma Warnings (On); + end XMatchD; + +end GNAT.Spitbol.Patterns; diff --git a/gcc/ada/libgnat/g-spipat.ads b/gcc/ada/libgnat/g-spipat.ads new file mode 100644 index 0000000..dc59d29 --- /dev/null +++ b/gcc/ada/libgnat/g-spipat.ads @@ -0,0 +1,1187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . P A T T E R N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL-like pattern construction and matching + +-- This child package of GNAT.SPITBOL provides a complete implementation +-- of the SPITBOL-like pattern construction and matching operations. This +-- package is based on Macro-SPITBOL created by Robert Dewar. + +------------------------------------------------------------ +-- Summary of Pattern Matching Packages in GNAT Hierarchy -- +------------------------------------------------------------ + +-- There are three related packages that perform pattern matching functions. +-- the following is an outline of these packages, to help you determine +-- which is best for your needs. + +-- GNAT.Regexp (files g-regexp.ads/g-regexp.adb) +-- This is a simple package providing Unix-style regular expression +-- matching with the restriction that it matches entire strings. It +-- is particularly useful for file name matching, and in particular +-- it provides "globbing patterns" that are useful in implementing +-- unix or DOS style wild card matching for file names. + +-- GNAT.Regpat (files g-regpat.ads/g-regpat.adb) +-- This is a more complete implementation of Unix-style regular +-- expressions, copied from the original V7 style regular expression +-- library written in C by Henry Spencer. It is functionally the +-- same as this library, and uses the same internal data structures +-- stored in a binary compatible manner. + +-- GNAT.Spitbol.Patterns (files g-spipat.ads/g-spipat.adb) +-- This is a completely general patterm matching package based on the +-- pattern language of SNOBOL4, as implemented in SPITBOL. The pattern +-- language is modeled on context free grammars, with context sensitive +-- extensions that provide full (type 0) computational capabilities. + +with Ada.Strings.Maps; use Ada.Strings.Maps; +with Ada.Text_IO; use Ada.Text_IO; + +package GNAT.Spitbol.Patterns is + pragma Elaborate_Body; + + ------------------------------- + -- Pattern Matching Tutorial -- + ------------------------------- + + -- A pattern matching operation (a call to one of the Match subprograms) + -- takes a subject string and a pattern, and optionally a replacement + -- string. The replacement string option is only allowed if the subject + -- is a variable. + + -- The pattern is matched against the subject string, and either the + -- match fails, or it succeeds matching a contiguous substring. If a + -- replacement string is specified, then the subject string is modified + -- by replacing the matched substring with the given replacement. + + -- Concatenation and Alternation + -- ============================= + + -- A pattern consists of a series of pattern elements. The pattern is + -- built up using either the concatenation operator: + + -- A & B + + -- which means match A followed immediately by matching B, or the + -- alternation operator: + + -- A or B + + -- which means first attempt to match A, and then if that does not + -- succeed, match B. + + -- There is full backtracking, which means that if a given pattern + -- element fails to match, then previous alternatives are matched. + -- For example if we have the pattern: + + -- (A or B) & (C or D) & (E or F) + + -- First we attempt to match A, if that succeeds, then we go on to try + -- to match C, and if that succeeds, we go on to try to match E. If E + -- fails, then we try F. If F fails, then we go back and try matching + -- D instead of C. Let's make this explicit using a specific example, + -- and introducing the simplest kind of pattern element, which is a + -- literal string. The meaning of this pattern element is simply to + -- match the characters that correspond to the string characters. Now + -- let's rewrite the above pattern form with specific string literals + -- as the pattern elements: + + -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") + + -- The following strings will be attempted in sequence: + + -- ABC . DEF . GH + -- ABC . DEF . IJ + -- ABC . CDE . GH + -- ABC . CDE . IJ + -- AB . DEF . GH + -- AB . DEF . IJ + -- AB . CDE . GH + -- AB . CDE . IJ + + -- Here we use the dot simply to separate the pieces of the string + -- matched by the three separate elements. + + -- Moving the Start Point + -- ====================== + + -- A pattern is not required to match starting at the first character + -- of the string, and is not required to match to the end of the string. + -- The first attempt does indeed attempt to match starting at the first + -- character of the string, trying all the possible alternatives. But + -- if all alternatives fail, then the starting point of the match is + -- moved one character, and all possible alternatives are attempted at + -- the new anchor point. + + -- The entire match fails only when every possible starting point has + -- been attempted. As an example, suppose that we had the subject + -- string + + -- "ABABCDEIJKL" + + -- matched using the pattern in the previous example: + + -- ("ABC" or "AB") & ("DEF" or "CDE") & ("GH" or "IJ") + + -- would succeed, after two anchor point moves: + + -- "ABABCDEIJKL" + -- ^^^^^^^ + -- matched + -- section + + -- This mode of pattern matching is called the unanchored mode. It is + -- also possible to put the pattern matcher into anchored mode by + -- setting the global variable Anchored_Mode to True. This will cause + -- all subsequent matches to be performed in anchored mode, where the + -- match is required to start at the first character. + + -- We will also see later how the effect of an anchored match can be + -- obtained for a single specified anchor point if this is desired. + + -- Other Pattern Elements + -- ====================== + + -- In addition to strings (or single characters), there are many special + -- pattern elements that correspond to special predefined alternations: + + -- Arb Matches any string. First it matches the null string, and + -- then on a subsequent failure, matches one character, and + -- then two characters, and so on. It only fails if the + -- entire remaining string is matched. + + -- Bal Matches a non-empty string that is parentheses balanced + -- with respect to ordinary () characters. Examples of + -- balanced strings are "ABC", "A((B)C)", and "A(B)C(D)E". + -- Bal matches the shortest possible balanced string on the + -- first attempt, and if there is a subsequent failure, + -- attempts to extend the string. + + -- Cancel Immediately aborts the entire pattern match, signalling + -- failure. This is a specialized pattern element, which is + -- useful in conjunction with some of the special pattern + -- elements that have side effects. + + -- Fail The null alternation. Matches no possible strings, so it + -- always signals failure. This is a specialized pattern + -- element, which is useful in conjunction with some of the + -- special pattern elements that have side effects. + + -- Fence Matches the null string at first, and then if a failure + -- causes alternatives to be sought, aborts the match (like + -- a Cancel). Note that using Fence at the start of a pattern + -- has the same effect as matching in anchored mode. + + -- Rest Matches from the current point to the last character in + -- the string. This is a specialized pattern element, which + -- is useful in conjunction with some of the special pattern + -- elements that have side effects. + + -- Succeed Repeatedly matches the null string (it is equivalent to + -- the alternation ("" or "" or "" ....). This is a special + -- pattern element, which is useful in conjunction with some + -- of the special pattern elements that have side effects. + + -- Pattern Construction Functions + -- ============================== + + -- The following functions construct additional pattern elements + + -- Any(S) Where S is a string, matches a single character that is + -- any one of the characters in S. Fails if the current + -- character is not one of the given set of characters. + + -- Arbno(P) Where P is any pattern, matches any number of instances + -- of the pattern, starting with zero occurrences. It is + -- thus equivalent to ("" or (P & ("" or (P & ("" ....)))). + -- The pattern P may contain any number of pattern elements + -- including the use of alternation and concatenation. + + -- Break(S) Where S is a string, matches a string of zero or more + -- characters up to but not including a break character + -- that is one of the characters given in the string S. + -- Can match the null string, but cannot match the last + -- character in the string, since a break character is + -- required to be present. + + -- BreakX(S) Where S is a string, behaves exactly like Break(S) when + -- it first matches, but if a string is successfully matched, + -- then a subsequent failure causes an attempt to extend the + -- matched string. + + -- Fence(P) Where P is a pattern, attempts to match the pattern P + -- including trying all possible alternatives of P. If none + -- of these alternatives succeeds, then the Fence pattern + -- fails. If one alternative succeeds, then the pattern + -- match proceeds, but on a subsequent failure, no attempt + -- is made to search for alternative matches of P. The + -- pattern P may contain any number of pattern elements + -- including the use of alternation and concatenation. + + -- Len(N) Where N is a natural number, matches the given number of + -- characters. For example, Len(10) matches any string that + -- is exactly ten characters long. + + -- NotAny(S) Where S is a string, matches a single character that is + -- not one of the characters of S. Fails if the current + -- character is one of the given set of characters. + + -- NSpan(S) Where S is a string, matches a string of zero or more + -- characters that is among the characters given in the + -- string. Always matches the longest possible such string. + -- Always succeeds, since it can match the null string. + + -- Pos(N) Where N is a natural number, matches the null string + -- if exactly N characters have been matched so far, and + -- otherwise fails. + + -- Rpos(N) Where N is a natural number, matches the null string + -- if exactly N characters remain to be matched, and + -- otherwise fails. + + -- Rtab(N) Where N is a natural number, matches characters from + -- the current position until exactly N characters remain + -- to be matched in the string. Fails if fewer than N + -- unmatched characters remain in the string. + + -- Tab(N) Where N is a natural number, matches characters from + -- the current position until exactly N characters have + -- been matched in all. Fails if more than N characters + -- have already been matched. + + -- Span(S) Where S is a string, matches a string of one or more + -- characters that is among the characters given in the + -- string. Always matches the longest possible such string. + -- Fails if the current character is not one of the given + -- set of characters. + + -- Recursive Pattern Matching + -- ========================== + + -- The plus operator (+P) where P is a pattern variable, creates + -- a recursive pattern that will, at pattern matching time, follow + -- the pointer to obtain the referenced pattern, and then match this + -- pattern. This may be used to construct recursive patterns. Consider + -- for example: + + -- P := ("A" or ("B" & (+P))) + + -- On the first attempt, this pattern attempts to match the string "A". + -- If this fails, then the alternative matches a "B", followed by an + -- attempt to match P again. This second attempt first attempts to + -- match "A", and so on. The result is a pattern that will match a + -- string of B's followed by a single A. + + -- This particular example could simply be written as NSpan('B') & 'A', + -- but the use of recursive patterns in the general case can construct + -- complex patterns which could not otherwise be built. + + -- Pattern Assignment Operations + -- ============================= + + -- In addition to the overall result of a pattern match, which indicates + -- success or failure, it is often useful to be able to keep track of + -- the pieces of the subject string that are matched by individual + -- pattern elements, or subsections of the pattern. + + -- The pattern assignment operators allow this capability. The first + -- form is the immediate assignment: + + -- P * S + + -- Here P is an arbitrary pattern, and S is a variable of type VString + -- that will be set to the substring matched by P. This assignment + -- happens during pattern matching, so if P matches more than once, + -- then the assignment happens more than once. + + -- The deferred assignment operation: + + -- P ** S + + -- avoids these multiple assignments by deferring the assignment to the + -- end of the match. If the entire match is successful, and if the + -- pattern P was part of the successful match, then at the end of the + -- matching operation the assignment to S of the string matching P is + -- performed. + + -- The cursor assignment operation: + + -- Setcur(N'Access) + + -- assigns the current cursor position to the natural variable N. The + -- cursor position is defined as the count of characters that have been + -- matched so far (including any start point moves). + + -- Finally the operations * and ** may be used with values of type + -- Text_IO.File_Access. The effect is to do a Put_Line operation of + -- the matched substring. These are particularly useful in debugging + -- pattern matches. + + -- Deferred Matching + -- ================= + + -- The pattern construction functions (such as Len and Any) all permit + -- the use of pointers to natural or string values, or functions that + -- return natural or string values. These forms cause the actual value + -- to be obtained at pattern matching time. This allows interesting + -- possibilities for constructing dynamic patterns as illustrated in + -- the examples section. + + -- In addition the (+S) operator may be used where S is a pointer to + -- string or function returning string, with a similar deferred effect. + + -- A special use of deferred matching is the construction of predicate + -- functions. The element (+P) where P is an access to a function that + -- returns a Boolean value, causes the function to be called at the + -- time the element is matched. If the function returns True, then the + -- null string is matched, if the function returns False, then failure + -- is signalled and previous alternatives are sought. + + -- Deferred Replacement + -- ==================== + + -- The simple model given for pattern replacement (where the matched + -- substring is replaced by the string given as the third argument to + -- Match) works fine in simple cases, but this approach does not work + -- in the case where the expression used as the replacement string is + -- dependent on values set by the match. + + -- For example, suppose we want to find an instance of a parenthesized + -- character, and replace the parentheses with square brackets. At first + -- glance it would seem that: + + -- Match (Subject, '(' & Len (1) * Char & ')', '[' & Char & ']'); + + -- would do the trick, but that does not work, because the third + -- argument to Match gets evaluated too early, before the call to + -- Match, and before the pattern match has had a chance to set Char. + + -- To solve this problem we provide the deferred replacement capability. + -- With this approach, which of course is only needed if the pattern + -- involved has side effects, is to do the match in two stages. The + -- call to Match sets a pattern result in a variable of the private + -- type Match_Result, and then a subsequent Replace operation uses + -- this Match_Result object to perform the required replacement. + + -- Using this approach, we can now write the above operation properly + -- in a manner that will work: + + -- M : Match_Result; + -- ... + -- Match (Subject, '(' & Len (1) * Char & ')', M); + -- Replace (M, '[' & Char & ']'); + + -- As with other Match cases, there is a function and procedure form + -- of this match call. A call to Replace after a failed match has no + -- effect. Note that Subject should not be modified between the calls. + + -- Examples of Pattern Matching + -- ============================ + + -- First a simple example of the use of pattern replacement to remove + -- a line number from the start of a string. We assume that the line + -- number has the form of a string of decimal digits followed by a + -- period, followed by one or more spaces. + + -- Digs : constant Pattern := Span("0123456789"); + + -- Lnum : constant Pattern := Pos(0) & Digs & '.' & Span(' '); + + -- Now to use this pattern we simply do a match with a replacement: + + -- Match (Line, Lnum, ""); + + -- which replaces the line number by the null string. Note that it is + -- also possible to use an Ada.Strings.Maps.Character_Set value as an + -- argument to Span and similar functions, and in particular all the + -- useful constants 'in Ada.Strings.Maps.Constants are available. This + -- means that we could define Digs as: + + -- Digs : constant Pattern := Span(Decimal_Digit_Set); + + -- The style we use here, of defining constant patterns and then using + -- them is typical. It is possible to build up patterns dynamically, + -- but it is usually more efficient to build them in pieces in advance + -- using constant declarations. Note in particular that although it is + -- possible to construct a pattern directly as an argument for the + -- Match routine, it is much more efficient to preconstruct the pattern + -- as we did in this example. + + -- Now let's look at the use of pattern assignment to break a + -- string into sections. Suppose that the input string has two + -- unsigned decimal integers, separated by spaces or a comma, + -- with spaces allowed anywhere. Then we can isolate the two + -- numbers with the following pattern: + + -- Num1, Num2 : aliased VString; + + -- B : constant Pattern := NSpan(' '); + + -- N : constant Pattern := Span("0123456789"); + + -- T : constant Pattern := + -- NSpan(' ') & N * Num1 & Span(" ,") & N * Num2; + + -- The match operation Match (" 124, 257 ", T) would assign the + -- string 124 to Num1 and the string 257 to Num2. + + -- Now let's see how more complex elements can be built from the + -- set of primitive elements. The following pattern matches strings + -- that have the syntax of Ada 95 based literals: + + -- Digs : constant Pattern := Span(Decimal_Digit_Set); + -- UDigs : constant Pattern := Digs & Arbno('_' & Digs); + + -- Edig : constant Pattern := Span(Hexadecimal_Digit_Set); + -- UEdig : constant Pattern := Edig & Arbno('_' & Edig); + + -- Bnum : constant Pattern := Udigs & '#' & UEdig & '#'; + + -- A match against Bnum will now match the desired strings, e.g. + -- it will match 16#123_abc#, but not a#b#. However, this pattern + -- is not quite complete, since it does not allow colons to replace + -- the pound signs. The following is more complete: + + -- Bchar : constant Pattern := Any("#:"); + -- Bnum : constant Pattern := Udigs & Bchar & UEdig & Bchar; + + -- but that is still not quite right, since it allows # and : to be + -- mixed, and they are supposed to be used consistently. We solve + -- this by using a deferred match. + + -- Temp : aliased VString; + + -- Bnum : constant Pattern := + -- Udigs & Bchar * Temp & UEdig & (+Temp) + + -- Here the first instance of the base character is stored in Temp, and + -- then later in the pattern we rematch the value that was assigned. + + -- For an example of a recursive pattern, let's define a pattern + -- that is like the built in Bal, but the string matched is balanced + -- with respect to square brackets or curly brackets. + + -- The language for such strings might be defined in extended BNF as + + -- ELEMENT ::= + -- | '[' BALANCED_STRING ']' + -- | '{' BALANCED_STRING '}' + + -- BALANCED_STRING ::= ELEMENT {ELEMENT} + + -- Here we use {} to indicate zero or more occurrences of a term, as + -- is common practice in extended BNF. Now we can translate the above + -- BNF into recursive patterns as follows: + + -- Element, Balanced_String : aliased Pattern; + -- . + -- . + -- . + -- Element := NotAny ("[]{}") + -- or + -- ('[' & (+Balanced_String) & ']') + -- or + -- ('{' & (+Balanced_String) & '}'); + + -- Balanced_String := Element & Arbno (Element); + + -- Note the important use of + here to refer to a pattern not yet + -- defined. Note also that we use assignments precisely because we + -- cannot refer to as yet undeclared variables in initializations. + + -- Now that this pattern is constructed, we can use it as though it + -- were a new primitive pattern element, and for example, the match: + + -- Match ("xy[ab{cd}]", Balanced_String * Current_Output & Fail); + + -- will generate the output: + + -- x + -- xy + -- xy[ab{cd}] + -- y + -- y[ab{cd}] + -- [ab{cd}] + -- a + -- ab + -- ab{cd} + -- b + -- b{cd} + -- {cd} + -- c + -- cd + -- d + + -- Note that the function of the fail here is simply to force the + -- pattern Balanced_String to match all possible alternatives. Studying + -- the operation of this pattern in detail is highly instructive. + + -- Finally we give a rather elaborate example of the use of deferred + -- matching. The following declarations build up a pattern which will + -- find the longest string of decimal digits in the subject string. + + -- Max, Cur : VString; + -- Loc : Natural; + + -- function GtS return Boolean is + -- begin + -- return Length (Cur) > Length (Max); + -- end GtS; + + -- Digit : constant Character_Set := Decimal_Digit_Set; + + -- Digs : constant Pattern := Span(Digit); + + -- Find : constant Pattern := + -- "" * Max & Fence & -- initialize Max to null + -- BreakX (Digit) & -- scan looking for digits + -- ((Span(Digit) * Cur & -- assign next string to Cur + -- (+GtS'Unrestricted_Access) & -- check size(Cur) > Size(Max) + -- Setcur(Loc'Access)) -- if so, save location + -- * Max) & -- and assign to Max + -- Fail; -- seek all alternatives + + -- As we see from the comments here, complex patterns like this take + -- on aspects of sequential programs. In fact they are sequential + -- programs with general backtracking. In this pattern, we first use + -- a pattern assignment that matches null and assigns it to Max, so + -- that it is initialized for the new match. Now BreakX scans to the + -- next digit. Arb would do here, but BreakX will be more efficient. + -- Once we have found a digit, we scan out the longest string of + -- digits with Span, and assign it to Cur. The deferred call to GtS + -- tests if the string we assigned to Cur is the longest so far. If + -- not, then failure is signalled, and we seek alternatives (this + -- means that BreakX will extend and look for the next digit string). + -- If the call to GtS succeeds then the matched string is assigned + -- as the largest string so far into Max and its location is saved + -- in Loc. Finally Fail forces the match to fail and seek alternatives, + -- so that the entire string is searched. + + -- If the pattern Find is matched against a string, the variable Max + -- at the end of the pattern will have the longest string of digits, + -- and Loc will be the starting character location of the string. For + -- example, Match("ab123cd4657ef23", Find) will assign "4657" to Max + -- and 11 to Loc (indicating that the string ends with the eleventh + -- character of the string). + + -- Note: the use of Unrestricted_Access to reference GtS will not + -- be needed if GtS is defined at the outer level, but definitely + -- will be necessary if GtS is a nested function (in which case of + -- course the scope of the pattern Find will be restricted to this + -- nested scope, and this cannot be checked, i.e. use of the pattern + -- outside this scope is erroneous). Generally it is a good idea to + -- define patterns and the functions they call at the outer level + -- where possible, to avoid such problems. + + -- Correspondence with Pattern Matching in SPITBOL + -- =============================================== + + -- Generally the Ada syntax and names correspond closely to SPITBOL + -- syntax for pattern matching construction. + + -- The basic pattern construction operators are renamed as follows: + + -- Spitbol Ada + + -- (space) & + -- | or + -- $ * + -- . ** + + -- The Ada operators were chosen so that the relative precedences of + -- these operators corresponds to that of the Spitbol operators, but + -- as always, the use of parentheses is advisable to clarify. + + -- The pattern construction operators all have similar names except for + + -- Spitbol Ada + + -- Abort Cancel + -- Rem Rest + + -- where we have clashes with Ada reserved names + + -- Ada requires the use of 'Access to refer to functions used in the + -- pattern match, and often the use of 'Unrestricted_Access may be + -- necessary to get around the scope restrictions if the functions + -- are not declared at the outer level. + + -- The actual pattern matching syntax is modified in Ada as follows: + + -- Spitbol Ada + + -- X Y Match (X, Y); + -- X Y = Z Match (X, Y, Z); + + -- and pattern failure is indicated by returning a Boolean result from + -- the Match function (True for success, False for failure). + + ----------------------- + -- Type Declarations -- + ----------------------- + + type Pattern is private; + -- Type representing a pattern. This package provides a complete set of + -- operations for constructing patterns that can be used in the pattern + -- matching operations provided. + + type Boolean_Func is access function return Boolean; + -- General Boolean function type. When this type is used as a formal + -- parameter type in this package, it indicates a deferred predicate + -- pattern. The function will be called when the pattern element is + -- matched and failure signalled if False is returned. + + type Natural_Func is access function return Natural; + -- General Natural function type. When this type is used as a formal + -- parameter type in this package, it indicates a deferred pattern. + -- The function will be called when the pattern element is matched + -- to obtain the currently referenced Natural value. + + type VString_Func is access function return VString; + -- General VString function type. When this type is used as a formal + -- parameter type in this package, it indicates a deferred pattern. + -- The function will be called when the pattern element is matched + -- to obtain the currently referenced string value. + + subtype PString is String; + -- This subtype is used in the remainder of the package to indicate a + -- formal parameter that is converted to its corresponding pattern, + -- i.e. a pattern that matches the characters of the string. + + subtype PChar is Character; + -- Similarly, this subtype is used in the remainder of the package to + -- indicate a formal parameter that is converted to its corresponding + -- pattern, i.e. a pattern that matches this one character. + + subtype VString_Var is VString; + subtype Pattern_Var is Pattern; + -- These synonyms are used as formal parameter types to a function where, + -- if the language allowed, we would use in out parameters, but we are + -- not allowed to have in out parameters for functions. Instead we pass + -- actuals which must be variables, and with a bit of trickery in the + -- body, manage to interpret them properly as though they were indeed + -- in out parameters. + + pragma Warnings (Off, VString_Var); + pragma Warnings (Off, Pattern_Var); + -- We turn off warnings for these two types so that when variables are used + -- as arguments in this context, warnings about them not being assigned in + -- the source program will be suppressed. + + -------------------------------- + -- Basic Pattern Construction -- + -------------------------------- + + function "&" (L : Pattern; R : Pattern) return Pattern; + function "&" (L : PString; R : Pattern) return Pattern; + function "&" (L : Pattern; R : PString) return Pattern; + function "&" (L : PChar; R : Pattern) return Pattern; + function "&" (L : Pattern; R : PChar) return Pattern; + + -- Pattern concatenation. Matches L followed by R + + function "or" (L : Pattern; R : Pattern) return Pattern; + function "or" (L : PString; R : Pattern) return Pattern; + function "or" (L : Pattern; R : PString) return Pattern; + function "or" (L : PString; R : PString) return Pattern; + function "or" (L : PChar; R : Pattern) return Pattern; + function "or" (L : Pattern; R : PChar) return Pattern; + function "or" (L : PChar; R : PChar) return Pattern; + function "or" (L : PString; R : PChar) return Pattern; + function "or" (L : PChar; R : PString) return Pattern; + -- Pattern alternation. Creates a pattern that will first try to match + -- L and then on a subsequent failure, attempts to match R instead. + + ---------------------------------- + -- Pattern Assignment Functions -- + ---------------------------------- + + function "*" (P : Pattern; Var : VString_Var) return Pattern; + function "*" (P : PString; Var : VString_Var) return Pattern; + function "*" (P : PChar; Var : VString_Var) return Pattern; + -- Matches P, and if the match succeeds, assigns the matched substring + -- to the given VString variable Var. This assignment happens as soon as + -- the substring is matched, and if the pattern P1 is matched more than + -- once during the course of the match, then the assignment will occur + -- more than once. + + function "**" (P : Pattern; Var : VString_Var) return Pattern; + function "**" (P : PString; Var : VString_Var) return Pattern; + function "**" (P : PChar; Var : VString_Var) return Pattern; + -- Like "*" above, except that the assignment happens at most once + -- after the entire match is completed successfully. If the match + -- fails, then no assignment takes place. + + ---------------------------------- + -- Deferred Matching Operations -- + ---------------------------------- + + function "+" (Str : VString_Var) return Pattern; + -- Here Str must be a VString variable. This function constructs a + -- pattern which at pattern matching time will access the current + -- value of this variable, and match against these characters. + + function "+" (Str : VString_Func) return Pattern; + -- Constructs a pattern which at pattern matching time calls the given + -- function, and then matches against the string or character value + -- that is returned by the call. + + function "+" (P : Pattern_Var) return Pattern; + -- Here P must be a Pattern variable. This function constructs a + -- pattern which at pattern matching time will access the current + -- value of this variable, and match against the pattern value. + + function "+" (P : Boolean_Func) return Pattern; + -- Constructs a predicate pattern function that at pattern matching time + -- calls the given function. If True is returned, then the pattern matches. + -- If False is returned, then failure is signalled. + + -------------------------------- + -- Pattern Building Functions -- + -------------------------------- + + function Arb return Pattern; + -- Constructs a pattern that will match any string. On the first attempt, + -- the pattern matches a null string, then on each successive failure, it + -- matches one more character, and only fails if matching the entire rest + -- of the string. + + function Arbno (P : Pattern) return Pattern; + function Arbno (P : PString) return Pattern; + function Arbno (P : PChar) return Pattern; + -- Pattern repetition. First matches null, then on a subsequent failure + -- attempts to match an additional instance of the given pattern. + -- Equivalent to (but more efficient than) P & ("" or (P & ("" or ... + + function Any (Str : String) return Pattern; + function Any (Str : VString) return Pattern; + function Any (Str : Character) return Pattern; + function Any (Str : Character_Set) return Pattern; + function Any (Str : not null access VString) return Pattern; + function Any (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches a single character that is one of + -- the characters in the given argument. The pattern fails if the current + -- character is not in Str. + + function Bal return Pattern; + -- Constructs a pattern that will match any non-empty string that is + -- parentheses balanced with respect to the normal parentheses characters. + -- Attempts to extend the string if a subsequent failure occurs. + + function Break (Str : String) return Pattern; + function Break (Str : VString) return Pattern; + function Break (Str : Character) return Pattern; + function Break (Str : Character_Set) return Pattern; + function Break (Str : not null access VString) return Pattern; + function Break (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches a (possibly null) string which + -- is immediately followed by a character in the given argument. This + -- character is not part of the matched string. The pattern fails if + -- the remaining characters to be matched do not include any of the + -- characters in Str. + + function BreakX (Str : String) return Pattern; + function BreakX (Str : VString) return Pattern; + function BreakX (Str : Character) return Pattern; + function BreakX (Str : Character_Set) return Pattern; + function BreakX (Str : not null access VString) return Pattern; + function BreakX (Str : VString_Func) return Pattern; + -- Like Break, but the pattern attempts to extend on a failure to find + -- the next occurrence of a character in Str, and only fails when the + -- last such instance causes a failure. + + function Cancel return Pattern; + -- Constructs a pattern that immediately aborts the entire match + + function Fail return Pattern; + -- Constructs a pattern that always fails + + function Fence return Pattern; + -- Constructs a pattern that matches null on the first attempt, and then + -- causes the entire match to be aborted if a subsequent failure occurs. + + function Fence (P : Pattern) return Pattern; + -- Constructs a pattern that first matches P. If P fails, then the + -- constructed pattern fails. If P succeeds, then the match proceeds, + -- but if subsequent failure occurs, alternatives in P are not sought. + -- The idea of Fence is that each time the pattern is matched, just + -- one attempt is made to match P, without trying alternatives. + + function Len (Count : Natural) return Pattern; + function Len (Count : not null access Natural) return Pattern; + function Len (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches exactly the given number of + -- characters. The pattern fails if fewer than this number of characters + -- remain to be matched in the string. + + function NotAny (Str : String) return Pattern; + function NotAny (Str : VString) return Pattern; + function NotAny (Str : Character) return Pattern; + function NotAny (Str : Character_Set) return Pattern; + function NotAny (Str : not null access VString) return Pattern; + function NotAny (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches a single character that is not + -- one of the characters in the given argument. The pattern Fails if + -- the current character is in Str. + + function NSpan (Str : String) return Pattern; + function NSpan (Str : VString) return Pattern; + function NSpan (Str : Character) return Pattern; + function NSpan (Str : Character_Set) return Pattern; + function NSpan (Str : not null access VString) return Pattern; + function NSpan (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches the longest possible string + -- consisting entirely of characters from the given argument. The + -- string may be empty, so this pattern always succeeds. + + function Pos (Count : Natural) return Pattern; + function Pos (Count : not null access Natural) return Pattern; + function Pos (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches the null string if exactly Count + -- characters have already been matched, and otherwise fails. + + function Rest return Pattern; + -- Constructs a pattern that always succeeds, matching the remaining + -- unmatched characters in the pattern. + + function Rpos (Count : Natural) return Pattern; + function Rpos (Count : not null access Natural) return Pattern; + function Rpos (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches the null string if exactly Count + -- characters remain to be matched in the string, and otherwise fails. + + function Rtab (Count : Natural) return Pattern; + function Rtab (Count : not null access Natural) return Pattern; + function Rtab (Count : Natural_Func) return Pattern; + -- Constructs a pattern that matches from the current location until + -- exactly Count characters remain to be matched in the string. The + -- pattern fails if fewer than Count characters remain to be matched. + + function Setcur (Var : not null access Natural) return Pattern; + -- Constructs a pattern that matches the null string, and assigns the + -- current cursor position in the string. This value is the number of + -- characters matched so far. So it is zero at the start of the match. + + function Span (Str : String) return Pattern; + function Span (Str : VString) return Pattern; + function Span (Str : Character) return Pattern; + function Span (Str : Character_Set) return Pattern; + function Span (Str : not null access VString) return Pattern; + function Span (Str : VString_Func) return Pattern; + -- Constructs a pattern that matches the longest possible string + -- consisting entirely of characters from the given argument. The + -- string cannot be empty, so the pattern fails if the current + -- character is not one of the characters in Str. + + function Succeed return Pattern; + -- Constructs a pattern that succeeds matching null, both on the first + -- attempt, and on any rematch attempt, i.e. it is equivalent to an + -- infinite alternation of null strings. + + function Tab (Count : Natural) return Pattern; + function Tab (Count : not null access Natural) return Pattern; + function Tab (Count : Natural_Func) return Pattern; + -- Constructs a pattern that from the current location until Count + -- characters have been matched. The pattern fails if more than Count + -- characters have already been matched. + + --------------------------------- + -- Pattern Matching Operations -- + --------------------------------- + + -- The Match function performs an actual pattern matching operation. + -- The versions with three parameters perform a match without modifying + -- the subject string and return a Boolean result indicating if the + -- match is successful or not. The Anchor parameter is set to True to + -- obtain an anchored match in which the pattern is required to match + -- the first character of the string. In an unanchored match, which is + + -- the default, successive attempts are made to match the given pattern + -- at each character of the subject string until a match succeeds, or + -- until all possibilities have failed. + + -- Note that pattern assignment functions in the pattern may generate + -- side effects, so these functions are not necessarily pure. + + Anchored_Mode : Boolean := False; + -- This global variable can be set True to cause all subsequent pattern + -- matches to operate in anchored mode. In anchored mode, no attempt is + -- made to move the anchor point, so that if the match succeeds it must + -- succeed starting at the first character. Note that the effect of + -- anchored mode may be achieved in individual pattern matches by using + -- Fence or Pos(0) at the start of the pattern. + + Pattern_Stack_Overflow : exception; + -- Exception raised if internal pattern matching stack overflows. This + -- is typically the result of runaway pattern recursion. If there is a + -- genuine case of stack overflow, then either the match must be broken + -- down into simpler steps, or the stack limit must be reset. + + Stack_Size : constant Positive := 2000; + -- Size used for internal pattern matching stack. Increase this size if + -- complex patterns cause Pattern_Stack_Overflow to be raised. + + -- Simple match functions. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed, and + -- the returned value indicates whether or not the match succeeded. + + function Match + (Subject : VString; + Pat : Pattern) return Boolean; + + function Match + (Subject : VString; + Pat : PString) return Boolean; + + function Match + (Subject : String; + Pat : Pattern) return Boolean; + + function Match + (Subject : String; + Pat : PString) return Boolean; + + -- Replacement functions. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed, and + -- the returned value indicates whether or not the match succeeded. + -- If the match succeeds, then the matched part of the subject string + -- is replaced by the given Replace string. + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : VString) return Boolean; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : VString) return Boolean; + + function Match + (Subject : VString_Var; + Pat : Pattern; + Replace : String) return Boolean; + + function Match + (Subject : VString_Var; + Pat : PString; + Replace : String) return Boolean; + + -- Simple match procedures. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed. No + -- indication of success or failure is returned. + + procedure Match + (Subject : VString; + Pat : Pattern); + + procedure Match + (Subject : VString; + Pat : PString); + + procedure Match + (Subject : String; + Pat : Pattern); + + procedure Match + (Subject : String; + Pat : PString); + + -- Replacement procedures. The subject is matched against the pattern. + -- Any immediate or deferred assignments or writes are executed. No + -- indication of success or failure is returned. If the match succeeds, + -- then the matched part of the subject string is replaced by the given + -- Replace string. + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : VString); + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : VString); + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Replace : String); + + procedure Match + (Subject : in out VString; + Pat : PString; + Replace : String); + + -- Deferred Replacement + + type Match_Result is private; + -- Type used to record result of pattern match + + subtype Match_Result_Var is Match_Result; + -- This synonyms is used as a formal parameter type to a function where, + -- if the language allowed, we would use an in out parameter, but we are + -- not allowed to have in out parameters for functions. Instead we pass + -- actuals which must be variables, and with a bit of trickery in the + -- body, manage to interpret them properly as though they were indeed + -- in out parameters. + + function Match + (Subject : VString_Var; + Pat : Pattern; + Result : Match_Result_Var) return Boolean; + + procedure Match + (Subject : in out VString; + Pat : Pattern; + Result : out Match_Result); + + procedure Replace + (Result : in out Match_Result; + Replace : VString); + -- Given a previous call to Match which set Result, performs a pattern + -- replacement if the match was successful. Has no effect if the match + -- failed. This call should immediately follow the Match call. + + ------------------------ + -- Debugging Routines -- + ------------------------ + + -- Debugging pattern matching operations can often be quite complex, + -- since there is no obvious way to trace the progress of the match. + -- The declarations in this section provide some debugging assistance. + + Debug_Mode : Boolean := False; + -- This global variable can be set True to generate debugging on all + -- subsequent calls to Match. The debugging output is a full trace of + -- the actions of the pattern matcher, written to Standard_Output. The + -- level of this information is intended to be comprehensible at the + -- abstract level of this package declaration. However, note that the + -- use of this switch often generates large amounts of output. + + function "*" (P : Pattern; Fil : File_Access) return Pattern; + function "*" (P : PString; Fil : File_Access) return Pattern; + function "*" (P : PChar; Fil : File_Access) return Pattern; + function "**" (P : Pattern; Fil : File_Access) return Pattern; + function "**" (P : PString; Fil : File_Access) return Pattern; + function "**" (P : PChar; Fil : File_Access) return Pattern; + -- These are similar to the corresponding pattern assignment operations + -- except that instead of setting the value of a variable, the matched + -- substring is written to the appropriate file. This can be useful in + -- following the progress of a match without generating the full amount + -- of information obtained by setting Debug_Mode to True. + + Terminal : constant File_Access := Standard_Error; + Output : constant File_Access := Standard_Output; + -- Two handy synonyms for use with the above pattern write operations + + -- Finally we have some routines that are useful for determining what + -- patterns are in use, particularly if they are constructed dynamically. + + function Image (P : Pattern) return String; + function Image (P : Pattern) return VString; + -- This procedures yield strings that corresponds to the syntax needed + -- to create the given pattern using the functions in this package. The + -- form of this string is such that it could actually be compiled and + -- evaluated to yield the required pattern except for references to + -- variables and functions, which are output using one of the following + -- forms: + -- + -- access Natural NP(16#...#) + -- access Pattern PP(16#...#) + -- access VString VP(16#...#) + -- + -- Natural_Func NF(16#...#) + -- VString_Func VF(16#...#) + -- + -- where 16#...# is the hex representation of the integer address that + -- corresponds to the given access value + + procedure Dump (P : Pattern); + -- This procedure writes information about the pattern to Standard_Out. + -- The format of this information is keyed to the internal data structures + -- used to implement patterns. The information provided by Dump is thus + -- more precise than that yielded by Image, but is also a bit more obscure + -- (i.e. it cannot be interpreted solely in terms of this spec, you have + -- to know something about the data structures). + + ------------------ + -- Private Part -- + ------------------ + +private + type PE; + -- Pattern element, a pattern is a complex structure of PE's. This type + -- is defined and described in the body of this package. + + type PE_Ptr is access all PE; + -- Pattern reference. PE's use PE_Ptr values to reference other PE's + + type Pattern is new Controlled with record + Stk : Natural := 0; + -- Maximum number of stack entries required for matching this + -- pattern. See description of pattern history stack in body. + + P : PE_Ptr := null; + -- Pointer to initial pattern element for pattern + end record; + + pragma Finalize_Storage_Only (Pattern); + + procedure Adjust (Object : in out Pattern); + -- Adjust routine used to copy pattern objects + + procedure Finalize (Object : in out Pattern); + -- Finalization routine used to release storage allocated for a pattern + + type VString_Ptr is access all VString; + + type Match_Result is record + Var : VString_Ptr; + -- Pointer to subject string. Set to null if match failed + + Start : Natural := 1; + -- Starting index position (1's origin) of matched section of + -- subject string. Only valid if Var is non-null. + + Stop : Natural := 0; + -- Ending index position (1's origin) of matched section of + -- subject string. Only valid if Var is non-null. + + end record; + + pragma Volatile (Match_Result); + -- This ensures that the Result parameter is passed by reference, so + -- that we can play our games with the bogus Match_Result_Var parameter + -- in the function case to treat it as though it were an in out parameter. + +end GNAT.Spitbol.Patterns; diff --git a/gcc/ada/libgnat/g-spitbo.adb b/gcc/ada/libgnat/g-spitbo.adb new file mode 100644 index 0000000..64a4206 --- /dev/null +++ b/gcc/ada/libgnat/g-spitbo.adb @@ -0,0 +1,769 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Strings; use Ada.Strings; +with Ada.Strings.Unbounded.Aux; use Ada.Strings.Unbounded.Aux; + +with GNAT.Debug_Utilities; use GNAT.Debug_Utilities; +with GNAT.IO; use GNAT.IO; + +with System.String_Hash; + +with Ada.Unchecked_Deallocation; + +package body GNAT.Spitbol is + + --------- + -- "&" -- + --------- + + function "&" (Num : Integer; Str : String) return String is + begin + return S (Num) & Str; + end "&"; + + function "&" (Str : String; Num : Integer) return String is + begin + return Str & S (Num); + end "&"; + + function "&" (Num : Integer; Str : VString) return VString is + begin + return S (Num) & Str; + end "&"; + + function "&" (Str : VString; Num : Integer) return VString is + begin + return Str & S (Num); + end "&"; + + ---------- + -- Char -- + ---------- + + function Char (Num : Natural) return Character is + begin + return Character'Val (Num); + end Char; + + ---------- + -- Lpad -- + ---------- + + function Lpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') return VString + is + begin + if Length (Str) >= Len then + return Str; + else + return Tail (Str, Len, Pad); + end if; + end Lpad; + + function Lpad + (Str : String; + Len : Natural; + Pad : Character := ' ') return VString + is + begin + if Str'Length >= Len then + return V (Str); + + else + declare + R : String (1 .. Len); + + begin + for J in 1 .. Len - Str'Length loop + R (J) := Pad; + end loop; + + R (Len - Str'Length + 1 .. Len) := Str; + return V (R); + end; + end if; + end Lpad; + + procedure Lpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' ') + is + begin + if Length (Str) >= Len then + return; + else + Tail (Str, Len, Pad); + end if; + end Lpad; + + ------- + -- N -- + ------- + + function N (Str : VString) return Integer is + S : Big_String_Access; + L : Natural; + begin + Get_String (Str, S, L); + return Integer'Value (S (1 .. L)); + end N; + + -------------------- + -- Reverse_String -- + -------------------- + + function Reverse_String (Str : VString) return VString is + S : Big_String_Access; + L : Natural; + + begin + Get_String (Str, S, L); + + declare + Result : String (1 .. L); + + begin + for J in 1 .. L loop + Result (J) := S (L + 1 - J); + end loop; + + return V (Result); + end; + end Reverse_String; + + function Reverse_String (Str : String) return VString is + Result : String (1 .. Str'Length); + + begin + for J in 1 .. Str'Length loop + Result (J) := Str (Str'Last + 1 - J); + end loop; + + return V (Result); + end Reverse_String; + + procedure Reverse_String (Str : in out VString) is + S : Big_String_Access; + L : Natural; + + begin + Get_String (Str, S, L); + + declare + Result : String (1 .. L); + + begin + for J in 1 .. L loop + Result (J) := S (L + 1 - J); + end loop; + + Set_Unbounded_String (Str, Result); + end; + end Reverse_String; + + ---------- + -- Rpad -- + ---------- + + function Rpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') return VString + is + begin + if Length (Str) >= Len then + return Str; + else + return Head (Str, Len, Pad); + end if; + end Rpad; + + function Rpad + (Str : String; + Len : Natural; + Pad : Character := ' ') return VString + is + begin + if Str'Length >= Len then + return V (Str); + + else + declare + R : String (1 .. Len); + + begin + for J in Str'Length + 1 .. Len loop + R (J) := Pad; + end loop; + + R (1 .. Str'Length) := Str; + return V (R); + end; + end if; + end Rpad; + + procedure Rpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' ') + is + begin + if Length (Str) >= Len then + return; + + else + Head (Str, Len, Pad); + end if; + end Rpad; + + ------- + -- S -- + ------- + + function S (Num : Integer) return String is + Buf : String (1 .. 30); + Ptr : Natural := Buf'Last + 1; + Val : Natural := abs (Num); + + begin + loop + Ptr := Ptr - 1; + Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + exit when Val = 0; + end loop; + + if Num < 0 then + Ptr := Ptr - 1; + Buf (Ptr) := '-'; + end if; + + return Buf (Ptr .. Buf'Last); + end S; + + ------------ + -- Substr -- + ------------ + + function Substr + (Str : VString; + Start : Positive; + Len : Natural) return VString + is + S : Big_String_Access; + L : Natural; + + begin + Get_String (Str, S, L); + + if Start > L then + raise Index_Error; + elsif Start + Len - 1 > L then + raise Length_Error; + else + return V (S (Start .. Start + Len - 1)); + end if; + end Substr; + + function Substr + (Str : String; + Start : Positive; + Len : Natural) return VString + is + begin + if Start > Str'Length then + raise Index_Error; + elsif Start + Len - 1 > Str'Length then + raise Length_Error; + else + return + V (Str (Str'First + Start - 1 .. Str'First + Start + Len - 2)); + end if; + end Substr; + + ----------- + -- Table -- + ----------- + + package body Table is + + procedure Free is new + Ada.Unchecked_Deallocation (Hash_Element, Hash_Element_Ptr); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Hash is new System.String_Hash.Hash + (Character, String, Unsigned_32); + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Object : in out Table) is + Ptr1 : Hash_Element_Ptr; + Ptr2 : Hash_Element_Ptr; + + begin + for J in Object.Elmts'Range loop + Ptr1 := Object.Elmts (J)'Unrestricted_Access; + + if Ptr1.Name /= null then + loop + Ptr1.Name := new String'(Ptr1.Name.all); + exit when Ptr1.Next = null; + Ptr2 := Ptr1.Next; + Ptr1.Next := new Hash_Element'(Ptr2.all); + Ptr1 := Ptr1.Next; + end loop; + end if; + end loop; + end Adjust; + + ----------- + -- Clear -- + ----------- + + procedure Clear (T : in out Table) is + Ptr1 : Hash_Element_Ptr; + Ptr2 : Hash_Element_Ptr; + + begin + for J in T.Elmts'Range loop + if T.Elmts (J).Name /= null then + Free (T.Elmts (J).Name); + T.Elmts (J).Value := Null_Value; + + Ptr1 := T.Elmts (J).Next; + T.Elmts (J).Next := null; + + while Ptr1 /= null loop + Ptr2 := Ptr1.Next; + Free (Ptr1.Name); + Free (Ptr1); + Ptr1 := Ptr2; + end loop; + end if; + end loop; + end Clear; + + ---------------------- + -- Convert_To_Array -- + ---------------------- + + function Convert_To_Array (T : Table) return Table_Array is + Num_Elmts : Natural := 0; + Elmt : Hash_Element_Ptr; + + begin + for J in T.Elmts'Range loop + Elmt := T.Elmts (J)'Unrestricted_Access; + + if Elmt.Name /= null then + loop + Num_Elmts := Num_Elmts + 1; + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + + declare + TA : Table_Array (1 .. Num_Elmts); + P : Natural := 1; + + begin + for J in T.Elmts'Range loop + Elmt := T.Elmts (J)'Unrestricted_Access; + + if Elmt.Name /= null then + loop + Set_Unbounded_String (TA (P).Name, Elmt.Name.all); + TA (P).Value := Elmt.Value; + P := P + 1; + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + + return TA; + end; + end Convert_To_Array; + + ---------- + -- Copy -- + ---------- + + procedure Copy (From : Table; To : in out Table) is + Elmt : Hash_Element_Ptr; + + begin + Clear (To); + + for J in From.Elmts'Range loop + Elmt := From.Elmts (J)'Unrestricted_Access; + if Elmt.Name /= null then + loop + Set (To, Elmt.Name.all, Elmt.Value); + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + end Copy; + + ------------ + -- Delete -- + ------------ + + procedure Delete (T : in out Table; Name : Character) is + begin + Delete (T, String'(1 => Name)); + end Delete; + + procedure Delete (T : in out Table; Name : VString) is + S : Big_String_Access; + L : Natural; + begin + Get_String (Name, S, L); + Delete (T, S (1 .. L)); + end Delete; + + procedure Delete (T : in out Table; Name : String) is + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + Next : Hash_Element_Ptr; + + begin + if Elmt.Name = null then + null; + + elsif Elmt.Name.all = Name then + Free (Elmt.Name); + + if Elmt.Next = null then + Elmt.Value := Null_Value; + return; + + else + Next := Elmt.Next; + Elmt.Name := Next.Name; + Elmt.Value := Next.Value; + Elmt.Next := Next.Next; + Free (Next); + return; + end if; + + else + loop + Next := Elmt.Next; + + if Next = null then + return; + + elsif Next.Name.all = Name then + Free (Next.Name); + Elmt.Next := Next.Next; + Free (Next); + return; + + else + Elmt := Next; + end if; + end loop; + end if; + end Delete; + + ---------- + -- Dump -- + ---------- + + procedure Dump (T : Table; Str : String := "Table") is + Num_Elmts : Natural := 0; + Elmt : Hash_Element_Ptr; + + begin + for J in T.Elmts'Range loop + Elmt := T.Elmts (J)'Unrestricted_Access; + + if Elmt.Name /= null then + loop + Num_Elmts := Num_Elmts + 1; + Put_Line + (Str & '<' & Image (Elmt.Name.all) & "> = " & + Img (Elmt.Value)); + Elmt := Elmt.Next; + exit when Elmt = null; + end loop; + end if; + end loop; + + if Num_Elmts = 0 then + Put_Line (Str & " is empty"); + end if; + end Dump; + + procedure Dump (T : Table_Array; Str : String := "Table_Array") is + begin + if T'Length = 0 then + Put_Line (Str & " is empty"); + + else + for J in T'Range loop + Put_Line + (Str & '(' & Image (To_String (T (J).Name)) & ") = " & + Img (T (J).Value)); + end loop; + end if; + end Dump; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Object : in out Table) is + Ptr1 : Hash_Element_Ptr; + Ptr2 : Hash_Element_Ptr; + + begin + for J in Object.Elmts'Range loop + Ptr1 := Object.Elmts (J).Next; + Free (Object.Elmts (J).Name); + while Ptr1 /= null loop + Ptr2 := Ptr1.Next; + Free (Ptr1.Name); + Free (Ptr1); + Ptr1 := Ptr2; + end loop; + end loop; + end Finalize; + + --------- + -- Get -- + --------- + + function Get (T : Table; Name : Character) return Value_Type is + begin + return Get (T, String'(1 => Name)); + end Get; + + function Get (T : Table; Name : VString) return Value_Type is + S : Big_String_Access; + L : Natural; + begin + Get_String (Name, S, L); + return Get (T, S (1 .. L)); + end Get; + + function Get (T : Table; Name : String) return Value_Type is + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + + begin + if Elmt.Name = null then + return Null_Value; + + else + loop + if Name = Elmt.Name.all then + return Elmt.Value; + + else + Elmt := Elmt.Next; + + if Elmt = null then + return Null_Value; + end if; + end if; + end loop; + end if; + end Get; + + ------------- + -- Present -- + ------------- + + function Present (T : Table; Name : Character) return Boolean is + begin + return Present (T, String'(1 => Name)); + end Present; + + function Present (T : Table; Name : VString) return Boolean is + S : Big_String_Access; + L : Natural; + begin + Get_String (Name, S, L); + return Present (T, S (1 .. L)); + end Present; + + function Present (T : Table; Name : String) return Boolean is + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + + begin + if Elmt.Name = null then + return False; + + else + loop + if Name = Elmt.Name.all then + return True; + + else + Elmt := Elmt.Next; + + if Elmt = null then + return False; + end if; + end if; + end loop; + end if; + end Present; + + --------- + -- Set -- + --------- + + procedure Set (T : in out Table; Name : VString; Value : Value_Type) is + S : Big_String_Access; + L : Natural; + begin + Get_String (Name, S, L); + Set (T, S (1 .. L), Value); + end Set; + + procedure Set (T : in out Table; Name : Character; Value : Value_Type) is + begin + Set (T, String'(1 => Name), Value); + end Set; + + procedure Set + (T : in out Table; + Name : String; + Value : Value_Type) + is + begin + if Value = Null_Value then + Delete (T, Name); + + else + declare + Slot : constant Unsigned_32 := Hash (Name) mod T.N + 1; + Elmt : Hash_Element_Ptr := T.Elmts (Slot)'Unrestricted_Access; + + subtype String1 is String (1 .. Name'Length); + + begin + if Elmt.Name = null then + Elmt.Name := new String'(String1 (Name)); + Elmt.Value := Value; + return; + + else + loop + if Name = Elmt.Name.all then + Elmt.Value := Value; + return; + + elsif Elmt.Next = null then + Elmt.Next := new Hash_Element'( + Name => new String'(String1 (Name)), + Value => Value, + Next => null); + return; + + else + Elmt := Elmt.Next; + end if; + end loop; + end if; + end; + end if; + end Set; + end Table; + + ---------- + -- Trim -- + ---------- + + function Trim (Str : VString) return VString is + begin + return Trim (Str, Right); + end Trim; + + function Trim (Str : String) return VString is + begin + for J in reverse Str'Range loop + if Str (J) /= ' ' then + return V (Str (Str'First .. J)); + end if; + end loop; + + return Nul; + end Trim; + + procedure Trim (Str : in out VString) is + begin + Trim (Str, Right); + end Trim; + + ------- + -- V -- + ------- + + function V (Num : Integer) return VString is + Buf : String (1 .. 30); + Ptr : Natural := Buf'Last + 1; + Val : Natural := abs (Num); + + begin + loop + Ptr := Ptr - 1; + Buf (Ptr) := Character'Val (Val mod 10 + Character'Pos ('0')); + Val := Val / 10; + exit when Val = 0; + end loop; + + if Num < 0 then + Ptr := Ptr - 1; + Buf (Ptr) := '-'; + end if; + + return V (Buf (Ptr .. Buf'Last)); + end V; + +end GNAT.Spitbol; diff --git a/gcc/ada/libgnat/g-spitbo.ads b/gcc/ada/libgnat/g-spitbo.ads new file mode 100644 index 0000000..bfca2e2 --- /dev/null +++ b/gcc/ada/libgnat/g-spitbo.ads @@ -0,0 +1,394 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL-like interface facilities + +-- This package provides a set of interfaces to semantic operations copied +-- from SPITBOL, including a complete implementation of SPITBOL pattern +-- matching. The code is derived from the original SPITBOL MINIMAL sources, +-- created by Robert Dewar. The translation is not exact, but the +-- algorithmic approaches are similar. + +with Ada.Finalization; use Ada.Finalization; +with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; +with Interfaces; use Interfaces; + +package GNAT.Spitbol is + pragma Preelaborate; + + -- The Spitbol package relies heavily on the Unbounded_String package, + -- using the synonym VString for variable length string. The following + -- declarations define this type and other useful abbreviations. + + subtype VString is Ada.Strings.Unbounded.Unbounded_String; + + function V (Source : String) return VString + renames Ada.Strings.Unbounded.To_Unbounded_String; + + function S (Source : VString) return String + renames Ada.Strings.Unbounded.To_String; + + Nul : VString renames Ada.Strings.Unbounded.Null_Unbounded_String; + + ------------------------- + -- Facilities Provided -- + ------------------------- + + -- The SPITBOL support in GNAT consists of this package together with + -- several child packages. In this package, we have first a set of + -- useful string functions, copied exactly from the corresponding + -- SPITBOL functions, except that we had to rename REVERSE because + -- reverse is a reserved word (it is now Reverse_String). + + -- The second element of the parent package is a generic implementation + -- of a table facility. In SPITBOL, the TABLE function allows general + -- mappings from any datatype to any other datatype, and of course, as + -- always, we can freely mix multiple types in the same table. + + -- The Ada version of tables is strongly typed, so the indexing type and + -- the range type are always of a consistent type. In this implementation + -- we only provide VString as an indexing type, since this is by far the + -- most common case. The generic instantiation specifies the range type + -- to be used. + + -- Three child packages provide standard instantiations of this table + -- package for three common datatypes: + + -- GNAT.Spitbol.Table_Boolean (file g-sptabo.ads) + + -- The range type is Boolean. The default value is False. This + -- means that this table is essentially a representation of a set. + + -- GNAT.Spitbol.Table_Integer (file g-sptain.ads) + + -- The range type is Integer. The default value is Integer'First. + -- This provides a general mapping from strings to integers. + + -- GNAT.Spitbol.Table_VString (file g-sptavs.ads) + + -- The range type is VString. The default value is the null string. + -- This provides a general mapping from strings to strings. + + -- Finally there is another child package: + + -- GNAT.Spitbol.Patterns (file g-spipat.ads) + + -- This child package provides a complete implementation of SPITBOL + -- pattern matching. The spec contains a complete tutorial on the + -- use of pattern matching. + + --------------------------------- + -- Standard String Subprograms -- + --------------------------------- + + -- This section contains some operations on unbounded strings that are + -- closely related to those in the package Unbounded.Strings, but they + -- correspond to the SPITBOL semantics for these operations. + + function Char (Num : Natural) return Character; + pragma Inline (Char); + -- Equivalent to Character'Val (Num) + + function Lpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') return VString; + function Lpad + (Str : String; + Len : Natural; + Pad : Character := ' ') return VString; + -- If the length of Str is greater than or equal to Len, then Str is + -- returned unchanged. Otherwise, The value returned is obtained by + -- concatenating Length (Str) - Len instances of the Pad character to + -- the left hand side. + + procedure Lpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' '); + -- The procedure form is identical to the function form, except that + -- the result overwrites the input argument Str. + + function Reverse_String (Str : VString) return VString; + function Reverse_String (Str : String) return VString; + -- Returns result of reversing the string Str, i.e. the result returned + -- is a mirror image (end-for-end reversal) of the input string. + + procedure Reverse_String (Str : in out VString); + -- The procedure form is identical to the function form, except that the + -- result overwrites the input argument Str. + + function Rpad + (Str : VString; + Len : Natural; + Pad : Character := ' ') return VString; + function Rpad + (Str : String; + Len : Natural; + Pad : Character := ' ') return VString; + -- If the length of Str is greater than or equal to Len, then Str is + -- returned unchanged. Otherwise, The value returned is obtained by + -- concatenating Length (Str) - Len instances of the Pad character to + -- the right hand side. + + procedure Rpad + (Str : in out VString; + Len : Natural; + Pad : Character := ' '); + -- The procedure form is identical to the function form, except that the + -- result overwrites the input argument Str. + + function Size (Source : VString) return Natural + renames Ada.Strings.Unbounded.Length; + + function Substr + (Str : VString; + Start : Positive; + Len : Natural) return VString; + function Substr + (Str : String; + Start : Positive; + Len : Natural) return VString; + -- Returns the substring starting at the given character position (which + -- is always counted from the start of the string, regardless of bounds, + -- e.g. 2 means starting with the second character of the string), and + -- with the length (Len) given. Index_Error is raised if the starting + -- position is out of range, and Length_Error is raised if Len is too long. + + function Trim (Str : VString) return VString; + function Trim (Str : String) return VString; + -- Returns the string obtained by removing all spaces from the right + -- hand side of the string Str. + + procedure Trim (Str : in out VString); + -- The procedure form is identical to the function form, except that the + -- result overwrites the input argument Str. + + ----------------------- + -- Utility Functions -- + ----------------------- + + -- In SPITBOL, integer values can be freely treated as strings. The + -- following definitions help provide some of this capability in + -- some common cases. + + function "&" (Num : Integer; Str : String) return String; + function "&" (Str : String; Num : Integer) return String; + function "&" (Num : Integer; Str : VString) return VString; + function "&" (Str : VString; Num : Integer) return VString; + -- In all these concatenation operations, the integer is converted to + -- its corresponding decimal string form, with no leading blank. + + function S (Num : Integer) return String; + function V (Num : Integer) return VString; + -- These operators return the given integer converted to its decimal + -- string form with no leading blank. + + function N (Str : VString) return Integer; + -- Converts string to number (same as Integer'Value (S (Str))) + + ------------------- + -- Table Support -- + ------------------- + + -- So far, we only provide support for tables whose indexing data values + -- are strings (or unbounded strings). The values stored may be of any + -- type, as supplied by the generic formal parameter. + + generic + + type Value_Type is private; + -- Any non-limited type can be used as the value type in the table + + Null_Value : Value_Type; + -- Value used to represent a value that is not present in the table + + with function Img (A : Value_Type) return String; + -- Used to provide image of value in Dump procedure + + with function "=" (A, B : Value_Type) return Boolean is <>; + -- This allows a user-defined equality function to override the + -- predefined equality function. + + package Table is + + ------------------------ + -- Table Declarations -- + ------------------------ + + type Table (N : Unsigned_32) is private; + -- This is the table type itself. A table is a mapping from string + -- values to values of Value_Type. The discriminant is an estimate of + -- the number of values in the table. If the estimate is much too + -- high, some space is wasted, if the estimate is too low, access to + -- table elements is slowed down. The type Table has copy semantics, + -- not reference semantics. This means that if a table is copied + -- using simple assignment, then the two copies refer to entirely + -- separate tables. + + ----------------------------- + -- Table Access Operations -- + ----------------------------- + + function Get (T : Table; Name : VString) return Value_Type; + function Get (T : Table; Name : Character) return Value_Type; + pragma Inline (Get); + function Get (T : Table; Name : String) return Value_Type; + + -- If an entry with the given name exists in the table, then the + -- corresponding Value_Type value is returned. Otherwise Null_Value + -- is returned. + + function Present (T : Table; Name : VString) return Boolean; + function Present (T : Table; Name : Character) return Boolean; + pragma Inline (Present); + function Present (T : Table; Name : String) return Boolean; + -- Determines if an entry with the given name is present in the table. + -- A returned value of True means that it is in the table, otherwise + -- False indicates that it is not in the table. + + procedure Delete (T : in out Table; Name : VString); + procedure Delete (T : in out Table; Name : Character); + pragma Inline (Delete); + procedure Delete (T : in out Table; Name : String); + -- Deletes the table element with the given name from the table. If + -- no element in the table has this name, then the call has no effect. + + procedure Set (T : in out Table; Name : VString; Value : Value_Type); + procedure Set (T : in out Table; Name : Character; Value : Value_Type); + pragma Inline (Set); + procedure Set (T : in out Table; Name : String; Value : Value_Type); + -- Sets the value of the element with the given name to the given + -- value. If Value is equal to Null_Value, the effect is to remove + -- the entry from the table. If no element with the given name is + -- currently in the table, then a new element with the given value + -- is created. + + ---------------------------- + -- Allocation and Copying -- + ---------------------------- + + -- Table is a controlled type, so that all storage associated with + -- tables is properly reclaimed when a Table value is abandoned. + -- Tables have value semantics rather than reference semantics as + -- in Spitbol, i.e. when you assign a copy you end up with two + -- distinct copies of the table, as though COPY had been used in + -- Spitbol. It seems clearly more appropriate in Ada to require + -- the use of explicit pointers for reference semantics. + + procedure Clear (T : in out Table); + -- Clears all the elements of the given table, freeing associated + -- storage. On return T is an empty table with no elements. + + procedure Copy (From : Table; To : in out Table); + -- First all the elements of table To are cleared (as described for + -- the Clear procedure above), then all the elements of table From + -- are copied into To. In the case where the tables From and To have + -- the same declared size (i.e. the same discriminant), the call to + -- Copy has the same effect as the assignment of From to To. The + -- difference is that, unlike the assignment statement, which will + -- cause a Constraint_Error if the source and target are of different + -- sizes, Copy works fine with different sized tables. + + ---------------- + -- Conversion -- + ---------------- + + type Table_Entry is record + Name : VString; + Value : Value_Type; + end record; + + type Table_Array is array (Positive range <>) of Table_Entry; + + function Convert_To_Array (T : Table) return Table_Array; + -- Returns a Table_Array value with a low bound of 1, and a length + -- corresponding to the number of elements in the table. The elements + -- of the array give the elements of the table in unsorted order. + + --------------- + -- Debugging -- + --------------- + + procedure Dump (T : Table; Str : String := "Table"); + -- Dump contents of given table to the standard output file. The + -- string value Str is used as the name of the table in the dump. + + procedure Dump (T : Table_Array; Str : String := "Table_Array"); + -- Dump contents of given table array to the current output file. The + -- string value Str is used as the name of the table array in the dump. + + private + + ------------------ + -- Private Part -- + ------------------ + + -- A Table is a pointer to a hash table which contains the indicated + -- number of hash elements (the number is forced to the next odd value + -- if it is even to improve hashing performance). If more than one + -- of the entries in a table hashes to the same slot, the Next field + -- is used to chain entries from the header. The chains are not kept + -- ordered. A chain is terminated by a null pointer in Next. An unused + -- chain is marked by an element whose Name is null and whose value + -- is Null_Value. + + type Hash_Element; + type Hash_Element_Ptr is access all Hash_Element; + + type Hash_Element is record + Name : String_Access := null; + Value : Value_Type := Null_Value; + Next : Hash_Element_Ptr := null; + end record; + + type Hash_Table is + array (Unsigned_32 range <>) of aliased Hash_Element; + + type Table (N : Unsigned_32) is new Controlled with record + Elmts : Hash_Table (1 .. N); + end record; + + pragma Finalize_Storage_Only (Table); + + overriding procedure Adjust (Object : in out Table); + -- The Adjust procedure does a deep copy of the table structure + -- so that the effect of assignment is, like other assignments + -- in Ada, value-oriented. + + overriding procedure Finalize (Object : in out Table); + -- This is the finalization routine that ensures that all storage + -- associated with a table is properly released when a table object + -- is abandoned and finalized. + + end Table; + +end GNAT.Spitbol; diff --git a/gcc/ada/libgnat/g-sptabo.ads b/gcc/ada/libgnat/g-sptabo.ads new file mode 100644 index 0000000..96d75ab --- /dev/null +++ b/gcc/ada/libgnat/g-sptabo.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . T A B L E _ B O O L E A N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL tables with boolean values (sets) + +-- This package provides a predefined instantiation of the table abstraction +-- for type Standard.Boolean. The null value is False, so the only non-null +-- value is True, i.e. this table acts essentially as a set representation. +-- This package is based on Macro-SPITBOL created by Robert Dewar. + +package GNAT.Spitbol.Table_Boolean is new + GNAT.Spitbol.Table (Boolean, False, Boolean'Image); +pragma Preelaborate (Table_Boolean); diff --git a/gcc/ada/libgnat/g-sptain.ads b/gcc/ada/libgnat/g-sptain.ads new file mode 100644 index 0000000..ac47bb2 --- /dev/null +++ b/gcc/ada/libgnat/g-sptain.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . T A B L E _ I N T E G E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL tables with integer values + +-- This package provides a predefined instantiation of the table abstraction +-- for type Standard.Integer. The largest negative integer is used as the +-- null value for the table. This package is based on Macro-SPITBOL created +-- by Robert Dewar. + +package GNAT.Spitbol.Table_Integer is + new GNAT.Spitbol.Table (Integer, Integer'First, Integer'Image); +pragma Preelaborate (Table_Integer); diff --git a/gcc/ada/libgnat/g-sptavs.ads b/gcc/ada/libgnat/g-sptavs.ads new file mode 100644 index 0000000..4b1801d --- /dev/null +++ b/gcc/ada/libgnat/g-sptavs.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . S P I T B O L . T A B L E _ V S T R I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- SPITBOL tables with vstring (unbounded string) values + +-- This package provides a predefined instantiation of the table abstraction +-- for type VString (Ada.Strings.Unbounded.Unbounded_String). This package +-- is based on Macro-SPITBOL created by Robert Dewar. + +package GNAT.Spitbol.Table_VString is new + GNAT.Spitbol.Table (VString, Nul, To_String); +pragma Preelaborate (Table_VString); diff --git a/gcc/ada/libgnat/g-sse.ads b/gcc/ada/libgnat/g-sse.ads new file mode 100644 index 0000000..7db6644 --- /dev/null +++ b/gcc/ada/libgnat/g-sse.ads @@ -0,0 +1,139 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S S E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is the root of a set aimed at offering Ada bindings to a +-- subset of the Intel(r) Streaming SIMD Extensions with GNAT. The purpose +-- is to allow access from Ada to the SSE facilities defined in the Intel(r) +-- compiler manuals, in particular in the Intrinsics Reference of the C++ +-- Compiler User's Guide, available from http://www.intel.com. + +-- Assuming actual hardware support is available, this capability is +-- currently supported on the following set of targets: + +-- GNU/Linux x86 and x86_64 +-- Windows XP/Vista x86 and x86_64 +-- Solaris x86 +-- Darwin x86_64 + +-- This unit exposes vector _component_ types together with general comments +-- on the binding contents. + +-- One other unit is offered as of today: GNAT.SSE.Vector_Types, which +-- exposes Ada types corresponding to the reference types (__m128 and the +-- like) over which a binding to the SSE GCC builtins may operate. + +-- The exposed Ada types are private. Object initializations or value +-- observations may be performed with unchecked conversions or address +-- overlays, for example: + +-- with Ada.Unchecked_Conversion; +-- with GNAT.SSE.Vector_Types; use GNAT.SSE, GNAT.SSE.Vector_Types; + +-- procedure SSE_Base is + +-- -- Core operations + +-- function ia32_addps (A, B : m128) return m128; +-- pragma Import (Intrinsic, ia32_addps, "__builtin_ia32_addps"); + +-- -- User views & conversions + +-- type Vf32_View is array (1 .. 4) of GNAT.SSE.Float32; +-- for Vf32_View'Alignment use VECTOR_ALIGN; + +-- function To_m128 is new Ada.Unchecked_Conversion (Vf32_View, m128); + +-- Xf32 : constant Vf32_View := (1.0, 1.0, 2.0, 2.0); +-- Yf32 : constant Vf32_View := (2.0, 2.0, 1.0, 1.0); + +-- X128 : constant m128 := To_m128 (Xf32); +-- Y128 : constant m128 := To_m128 (Yf32); + +-- begin +-- -- Operations & overlays + +-- declare +-- Z128 : m128; +-- Zf32 : Vf32_View; +-- for Zf32'Address use Z128'Address; +-- begin +-- Z128 := ia32_addps (X128, Y128); +-- if Zf32 /= (3.0, 3.0, 3.0, 3.0) then +-- raise Program_Error; +-- end if; +-- end; + +-- declare +-- type m128_View_Kind is (SSE, F32); +-- type m128_Object (View : m128_View_Kind := F32) is record +-- case View is +-- when SSE => V128 : m128; +-- when F32 => Vf32 : Vf32_View; +-- end case; +-- end record; +-- pragma Unchecked_Union (m128_Object); + +-- O1 : constant m128_Object := (View => SSE, V128 => X128); +-- begin +-- if O1.Vf32 /= Xf32 then +-- raise Program_Error; +-- end if; +-- end; +-- end SSE_Base; + +package GNAT.SSE is + + ----------------------------------- + -- Common vector characteristics -- + ----------------------------------- + + VECTOR_BYTES : constant := 16; + -- Common size of all the SSE vector types, in bytes. + + VECTOR_ALIGN : constant := 16; + -- Common alignment of all the SSE vector types, in bytes. + + -- Alignment-wise, the reference document reads: + -- << The compiler aligns __m128d and _m128i local and global data to + -- 16-byte boundaries on the stack. >> + -- + -- We apply that consistently to all the Ada vector types, as GCC does + -- for the corresponding C types. + + ---------------------------- + -- Vector component types -- + ---------------------------- + + type Float32 is new Float; + type Float64 is new Long_Float; + type Integer64 is new Long_Long_Integer; + +end GNAT.SSE; diff --git a/gcc/ada/libgnat/g-ssvety.ads b/gcc/ada/libgnat/g-ssvety.ads new file mode 100644 index 0000000..a613106 --- /dev/null +++ b/gcc/ada/libgnat/g-ssvety.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S S E . V E C T O R _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit exposes the Ada __m128 like data types to represent the contents +-- of SSE registers, for use by bindings to the SSE intrinsic operations. + +-- See GNAT.SSE for the list of targets where this facility is supported + +package GNAT.SSE.Vector_Types is + + -- The reference guide states a few usage guidelines for the C types: + + -- Since these new data types are not basic ANSI C data types, you + -- must observe the following usage restrictions: + -- + -- * Use new data types only on either side of an assignment, as a + -- return value, or as a parameter. You cannot use it with other + -- arithmetic expressions ("+", "-", and so on). + -- + -- * Use new data types as objects in aggregates, such as unions to + -- access the byte elements and structures. + -- + -- * Use new data types only with the respective intrinsics described + -- in this documentation. + + type m128 is private; -- SSE >= 1 + type m128d is private; -- SSE >= 2 + type m128i is private; -- SSE >= 2 + +private + -- Each of the m128 types maps to a specific vector_type with an extra + -- "may_alias" attribute as in GCC's definitions for C, for instance in + -- xmmintrin.h: + + -- /* The Intel API is flexible enough that we must allow aliasing + -- with other vector types, and their scalar components. */ + -- typedef float __m128 + -- __attribute__ ((__vector_size__ (16), __may_alias__)); + + -- /* Internal data types for implementing the intrinsics. */ + -- typedef float __v4sf __attribute__ ((__vector_size__ (16))); + + ------------ + -- m128 -- + ------------ + + -- The __m128 data type can hold four 32-bit floating-point values + + type m128 is array (1 .. 4) of Float32; + for m128'Alignment use VECTOR_ALIGN; + pragma Machine_Attribute (m128, "vector_type"); + pragma Machine_Attribute (m128, "may_alias"); + + ------------- + -- m128d -- + ------------- + + -- The __m128d data type can hold two 64-bit floating-point values + + type m128d is array (1 .. 2) of Float64; + for m128d'Alignment use VECTOR_ALIGN; + pragma Machine_Attribute (m128d, "vector_type"); + pragma Machine_Attribute (m128d, "may_alias"); + + ------------- + -- m128i -- + ------------- + + -- The __m128i data type can hold sixteen 8-bit, eight 16-bit, four 32-bit, + -- or two 64-bit integer values. + + type m128i is array (1 .. 2) of Integer64; + for m128i'Alignment use VECTOR_ALIGN; + pragma Machine_Attribute (m128i, "vector_type"); + pragma Machine_Attribute (m128i, "may_alias"); + +end GNAT.SSE.Vector_Types; diff --git a/gcc/ada/libgnat/g-stheme.adb b/gcc/ada/libgnat/g-stheme.adb new file mode 100644 index 0000000..116fc28 --- /dev/null +++ b/gcc/ada/libgnat/g-stheme.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- GNAT.SOCKETS.THIN.HOST_ERROR_MESSAGES -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default implementation of this unit, providing explicit +-- literal messages (we do not use hstrerror from the standard C library, +-- as this function is obsolete). + +separate (GNAT.Sockets.Thin) +package body Host_Error_Messages is + + function Host_Error_Message (H_Errno : Integer) return String is + begin + case H_Errno is + when SOSC.HOST_NOT_FOUND => + return "Host not found"; + when SOSC.TRY_AGAIN => + return "Try again"; + when SOSC.NO_RECOVERY => + return "No recovery"; + when SOSC.NO_DATA => + return "No address"; + when others => + return "Unknown error"; + end case; + end Host_Error_Message; + +end Host_Error_Messages; diff --git a/gcc/ada/libgnat/g-strhas.ads b/gcc/ada/libgnat/g-strhas.ads new file mode 100644 index 0000000..be4e795 --- /dev/null +++ b/gcc/ada/libgnat/g-strhas.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S T R I N G _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 generic hashing function over strings, suitable for +-- use with a string keyed hash table. In particular, it is the basis for the +-- string hash functions in Ada.Containers. +-- +-- The algorithm used here is not appropriate for applications that require +-- cryptographically strong hashes, or for applications that wish to use very +-- wide hash values as pseudo unique identifiers. In such cases please refer +-- to GNAT.SHA1 and GNAT.MD5. + +with System.String_Hash; + +package GNAT.String_Hash renames System.String_Hash; diff --git a/gcc/ada/libgnat/g-string.adb b/gcc/ada/libgnat/g-string.adb new file mode 100644 index 0000000..37c9d06 --- /dev/null +++ b/gcc/ada/libgnat/g-string.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S T R I N G S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-string.ads b/gcc/ada/libgnat/g-string.ads new file mode 100644 index 0000000..a1a0d57 --- /dev/null +++ b/gcc/ada/libgnat/g-string.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S T R I N G S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Common String access types and related subprograms + +-- See file s-string.ads for full documentation of the interface + +with System.Strings; + +package GNAT.Strings renames System.Strings; diff --git a/gcc/ada/libgnat/g-strspl.ads b/gcc/ada/libgnat/g-strspl.ads new file mode 100644 index 0000000..b802f91 --- /dev/null +++ b/gcc/ada/libgnat/g-strspl.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S T R I N G _ S P L I T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Useful string-manipulation routines: given a set of separators, split +-- a string wherever the separators appear, and provide direct access +-- to the resulting slices. See GNAT.Array_Split for full documentation. + +with Ada.Strings.Maps; use Ada.Strings; +with GNAT.Array_Split; + +package GNAT.String_Split is new GNAT.Array_Split + (Element => Character, + Element_Sequence => String, + Element_Set => Maps.Character_Set, + To_Set => Maps.To_Set, + Is_In => Maps.Is_In); diff --git a/gcc/ada/libgnat/g-stseme.adb b/gcc/ada/libgnat/g-stseme.adb new file mode 100644 index 0000000..6f7bd3e --- /dev/null +++ b/gcc/ada/libgnat/g-stseme.adb @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- GNAT.SOCKETS.THIN.SOCKET_ERROR_MESSAGE -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default implementation of this unit, using the standard C +-- library's strerror(3) function. It is used on all platforms except Windows, +-- since on that platform socket errno values are distinct from the system +-- ones: there is a specific variant of this function in g-socthi-mingw.adb. + +separate (GNAT.Sockets.Thin) + +-------------------------- +-- Socket_Error_Message -- +-------------------------- + +function Socket_Error_Message + (Errno : Integer) return String +is +begin + return Errno_Message (Errno, Default => "Unknown system error"); +end Socket_Error_Message; diff --git a/gcc/ada/libgnat/g-stsifd-sockets.adb b/gcc/ada/libgnat/g-stsifd-sockets.adb new file mode 100644 index 0000000..e491e1a --- /dev/null +++ b/gcc/ada/libgnat/g-stsifd-sockets.adb @@ -0,0 +1,234 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . S O C K E T S . T H I N . S I G N A L L I N G _ F D S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Portable sockets-based implementation of GNAT.Sockets.Thin.Signalling_Fds +-- used for platforms that do not support UNIX pipes. + +-- Note: this code used to be in GNAT.Sockets, but has been moved to a +-- platform-specific file. It is now used only for non-UNIX platforms. + +separate (GNAT.Sockets.Thin) +package body Signalling_Fds is + + ----------- + -- Close -- + ----------- + + procedure Close (Sig : C.int) is + Res : C.int; + pragma Unreferenced (Res); + -- Res is assigned but never read, because we purposefully ignore + -- any error returned by the C_Close system call, as per the spec + -- of this procedure. + begin + Res := C_Close (Sig); + end Close; + + ------------ + -- Create -- + ------------ + + function Create (Fds : not null access Fd_Pair) return C.int is + L_Sock, R_Sock, W_Sock : C.int := Failure; + -- Listening socket, read socket and write socket + + Sin : aliased Sockaddr_In; + Len : aliased C.int; + -- Address of listening socket + + Res : C.int; + pragma Warnings (Off, Res); + -- Return status of system calls (usually ignored, hence warnings off) + + begin + Fds.all := (Read_End | Write_End => Failure); + + -- We open two signalling sockets. One of them is used to send data + -- to the other, which is included in a C_Select socket set. The + -- communication is used to force the call to C_Select to complete, + -- and the waiting task to resume its execution. + + loop + -- Retry loop, in case the C_Connect below fails + + -- Create a listening socket + + L_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); + + if L_Sock = Failure then + goto Fail; + end if; + + -- Bind the socket to an available port on localhost + + Set_Family (Sin.Sin_Family, Family_Inet); + Sin.Sin_Addr.S_B1 := 127; + Sin.Sin_Addr.S_B2 := 0; + Sin.Sin_Addr.S_B3 := 0; + Sin.Sin_Addr.S_B4 := 1; + Sin.Sin_Port := 0; + + Len := C.int (Lengths (Family_Inet)); + Res := C_Bind (L_Sock, Sin'Address, Len); + + if Res = Failure then + goto Fail; + end if; + + -- Get assigned port + + Res := C_Getsockname (L_Sock, Sin'Address, Len'Access); + if Res = Failure then + goto Fail; + end if; + + -- Set socket to listen mode, with a backlog of 1 to guarantee that + -- exactly one call to connect(2) succeeds. + + Res := C_Listen (L_Sock, 1); + + if Res = Failure then + goto Fail; + end if; + + -- Create read end (client) socket + + R_Sock := C_Socket (SOSC.AF_INET, SOSC.SOCK_STREAM, 0); + + if R_Sock = Failure then + goto Fail; + end if; + + -- Connect listening socket + + Res := C_Connect (R_Sock, Sin'Address, Len); + + exit when Res /= Failure; + + if Socket_Errno /= SOSC.EADDRINUSE then + goto Fail; + end if; + + -- In rare cases, the above C_Bind chooses a port that is still + -- marked "in use", even though it has been closed (perhaps by some + -- other process that has already exited). This causes the above + -- C_Connect to fail with EADDRINUSE. In this case, we close the + -- ports, and loop back to try again. This mysterious Windows + -- behavior is documented. See, for example: + -- http://msdn2.microsoft.com/en-us/library/ms737625.aspx + -- In an experiment with 2000 calls, 21 required exactly one retry, 7 + -- required two, and none required three or more. Note that no delay + -- is needed between retries; retrying C_Bind will typically produce + -- a different port. + + pragma Assert (Res = Failure + and then + Socket_Errno = SOSC.EADDRINUSE); + Res := C_Close (W_Sock); + W_Sock := Failure; + Res := C_Close (R_Sock); + R_Sock := Failure; + end loop; + + -- Since the call to connect(2) has succeeded and the backlog limit on + -- the listening socket is 1, we know that there is now exactly one + -- pending connection on L_Sock, which is the one from R_Sock. + + W_Sock := C_Accept (L_Sock, Sin'Address, Len'Access); + + if W_Sock = Failure then + goto Fail; + end if; + + -- Set TCP_NODELAY on W_Sock, since we always want to send the data out + -- immediately. + + Set_Socket_Option + (Socket => Socket_Type (W_Sock), + Level => IP_Protocol_For_TCP_Level, + Option => (Name => No_Delay, Enabled => True)); + + -- Close listening socket (ignore exit status) + + Res := C_Close (L_Sock); + + Fds.all := (Read_End => R_Sock, Write_End => W_Sock); + + return Thin_Common.Success; + + <> + declare + Saved_Errno : constant Integer := Socket_Errno; + + begin + if W_Sock /= Failure then + Res := C_Close (W_Sock); + end if; + + if R_Sock /= Failure then + Res := C_Close (R_Sock); + end if; + + if L_Sock /= Failure then + Res := C_Close (L_Sock); + end if; + + Set_Socket_Errno (Saved_Errno); + end; + + return Failure; + end Create; + + ---------- + -- Read -- + ---------- + + function Read (Rsig : C.int) return C.int is + Buf : aliased Character; + begin + return C_Recv (Rsig, Buf'Address, 1, SOSC.MSG_Forced_Flags); + end Read; + + ----------- + -- Write -- + ----------- + + function Write (Wsig : C.int) return C.int is + Buf : aliased Character := ASCII.NUL; + begin + return C_Sendto + (Wsig, Buf'Address, 1, + Flags => SOSC.MSG_Forced_Flags, + To => System.Null_Address, + Tolen => 0); + end Write; + +end Signalling_Fds; diff --git a/gcc/ada/libgnat/g-table.adb b/gcc/ada/libgnat/g-table.adb new file mode 100644 index 0000000..ac33bc3 --- /dev/null +++ b/gcc/ada/libgnat/g-table.adb @@ -0,0 +1,205 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Memory; use System.Memory; + +package body GNAT.Table is + + -------------- + -- Allocate -- + -------------- + + procedure Allocate (Num : Integer := 1) is + begin + Tab.Allocate (The_Instance, Num); + end Allocate; + + function Allocate (Num : Integer := 1) return Valid_Table_Index_Type is + Result : constant Valid_Table_Index_Type := Last + 1; + begin + Allocate (Num); + return Result; + end Allocate; + + ------------ + -- Append -- + ------------ + + procedure Append (New_Val : Table_Component_Type) is + begin + Tab.Append (The_Instance, New_Val); + end Append; + + ---------------- + -- Append_All -- + ---------------- + + procedure Append_All (New_Vals : Table_Type) is + begin + Tab.Append_All (The_Instance, New_Vals); + end Append_All; + + -------------------- + -- Decrement_Last -- + -------------------- + + procedure Decrement_Last is + begin + Tab.Decrement_Last (The_Instance); + end Decrement_Last; + + ----------- + -- First -- + ----------- + + function First return Table_Index_Type is + begin + return Tab.First; + end First; + + -------------- + -- For_Each -- + -------------- + + procedure For_Each is + procedure For_Each is new Tab.For_Each (Action); + begin + For_Each (The_Instance); + end For_Each; + + ---------- + -- Free -- + ---------- + + procedure Free is + begin + Tab.Free (The_Instance); + end Free; + + -------------------- + -- Increment_Last -- + -------------------- + + procedure Increment_Last is + begin + Tab.Increment_Last (The_Instance); + end Increment_Last; + + -------------- + -- Is_Empty -- + -------------- + + function Is_Empty return Boolean is + begin + return Tab.Is_Empty (The_Instance); + end Is_Empty; + + ---------- + -- Init -- + ---------- + + procedure Init is + begin + Tab.Init (The_Instance); + end Init; + + ---------- + -- Last -- + ---------- + + function Last return Table_Last_Type is + begin + return Tab.Last (The_Instance); + end Last; + + ------------- + -- Release -- + ------------- + + procedure Release is + begin + Tab.Release (The_Instance); + end Release; + + ------------- + -- Restore -- + ------------- + + procedure Restore (T : in out Saved_Table) is + begin + Init; + Tab.Move (From => T, To => The_Instance); + end Restore; + + ---------- + -- Save -- + ---------- + + function Save return Saved_Table is + Result : Saved_Table; + begin + Tab.Move (From => The_Instance, To => Result); + return Result; + end Save; + + -------------- + -- Set_Item -- + -------------- + + procedure Set_Item + (Index : Valid_Table_Index_Type; + Item : Table_Component_Type) + is + begin + Tab.Set_Item (The_Instance, Index, Item); + end Set_Item; + + -------------- + -- Set_Last -- + -------------- + + procedure Set_Last (New_Val : Table_Last_Type) is + begin + Tab.Set_Last (The_Instance, New_Val); + end Set_Last; + + ---------------- + -- Sort_Table -- + ---------------- + + procedure Sort_Table is + procedure Sort_Table is new Tab.Sort_Table (Lt); + begin + Sort_Table (The_Instance); + end Sort_Table; + +end GNAT.Table; diff --git a/gcc/ada/libgnat/g-table.ads b/gcc/ada/libgnat/g-table.ads new file mode 100644 index 0000000..ccda39b --- /dev/null +++ b/gcc/ada/libgnat/g-table.ads @@ -0,0 +1,150 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 singleton version of GNAT.Dynamic_Tables +-- (g-dyntab.ads). See that package for documentation. This package just +-- declares a single instance of GNAT.Dynamic_Tables.Instance, and provides +-- wrappers for all the subprograms, passing that single instance. + +-- Note that these three interfaces should remain synchronized to keep as much +-- coherency as possible among these related units: +-- +-- GNAT.Dynamic_Tables +-- GNAT.Table +-- Table (the compiler unit) + +with GNAT.Dynamic_Tables; + +generic + type Table_Component_Type is private; + type Table_Index_Type is range <>; + + Table_Low_Bound : Table_Index_Type := Table_Index_Type'First; + Table_Initial : Positive := 8; + Table_Increment : Natural := 100; + Table_Name : String := ""; -- for debugging printouts + pragma Unreferenced (Table_Name); + Release_Threshold : Natural := 0; + +package GNAT.Table is + pragma Elaborate_Body; + + package Tab is new GNAT.Dynamic_Tables + (Table_Component_Type, + Table_Index_Type, + Table_Low_Bound, + Table_Initial, + Table_Increment, + Release_Threshold); + + subtype Valid_Table_Index_Type is Tab.Valid_Table_Index_Type; + subtype Table_Last_Type is Tab.Table_Last_Type; + subtype Table_Type is Tab.Table_Type; + function "=" (X, Y : Table_Type) return Boolean renames Tab."="; + + subtype Table_Ptr is Tab.Table_Ptr; + + The_Instance : Tab.Instance; + Table : Table_Ptr renames The_Instance.Table; + Locked : Boolean renames The_Instance.Locked; + + function Is_Empty return Boolean; + + procedure Init; + pragma Inline (Init); + procedure Free; + pragma Inline (Free); + + function First return Table_Index_Type; + pragma Inline (First); + + function Last return Table_Last_Type; + pragma Inline (Last); + + procedure Release; + pragma Inline (Release); + + procedure Set_Last (New_Val : Table_Last_Type); + pragma Inline (Set_Last); + + procedure Increment_Last; + pragma Inline (Increment_Last); + + procedure Decrement_Last; + pragma Inline (Decrement_Last); + + procedure Append (New_Val : Table_Component_Type); + pragma Inline (Append); + + procedure Append_All (New_Vals : Table_Type); + pragma Inline (Append_All); + + procedure Set_Item + (Index : Valid_Table_Index_Type; + Item : Table_Component_Type); + pragma Inline (Set_Item); + + subtype Saved_Table is Tab.Instance; + -- Type used for Save/Restore subprograms + + function Save return Saved_Table; + pragma Inline (Save); + -- Resets table to empty, but saves old contents of table in returned + -- value, for possible later restoration by a call to Restore. + + procedure Restore (T : in out Saved_Table); + pragma Inline (Restore); + -- Given a Saved_Table value returned by a prior call to Save, restores + -- the table to the state it was in at the time of the Save call. + + procedure Allocate (Num : Integer := 1); + function Allocate (Num : Integer := 1) return Valid_Table_Index_Type; + pragma Inline (Allocate); + -- Adds Num to Last. The function version also returns the old value of + -- Last + 1. Note that this function has the possible side effect of + -- reallocating the table. This means that a reference X.Table (X.Allocate) + -- is incorrect, since the call to X.Allocate may modify the results of + -- calling X.Table. + + generic + with procedure Action + (Index : Valid_Table_Index_Type; + Item : Table_Component_Type; + Quit : in out Boolean) is <>; + procedure For_Each; + pragma Inline (For_Each); + + generic + with function Lt (Comp1, Comp2 : Table_Component_Type) return Boolean; + procedure Sort_Table; + pragma Inline (Sort_Table); + +end GNAT.Table; diff --git a/gcc/ada/libgnat/g-tasloc.adb b/gcc/ada/libgnat/g-tasloc.adb new file mode 100644 index 0000000..ffd4dcc --- /dev/null +++ b/gcc/ada/libgnat/g-tasloc.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A S K _ L O C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-tasloc.ads b/gcc/ada/libgnat/g-tasloc.ads new file mode 100644 index 0000000..462f64b --- /dev/null +++ b/gcc/ada/libgnat/g-tasloc.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T A S K _ L O C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple task lock and unlock routines + +-- A small package containing a task lock and unlock routines for creating +-- a critical region. The lock involved is a global lock, shared by all +-- tasks, and by all calls to these routines, so these routines should be +-- used with care to avoid unnecessary reduction of concurrency. + +-- These routines may be used in a non-tasking program, and in that case +-- they have no effect (they do NOT cause the tasking runtime to be loaded). + +-- See file s-tasloc.ads for full documentation of the interface + +with System.Task_Lock; + +package GNAT.Task_Lock renames System.Task_Lock; diff --git a/gcc/ada/libgnat/g-timsta.adb b/gcc/ada/libgnat/g-timsta.adb new file mode 100644 index 0000000..316fec7 --- /dev/null +++ b/gcc/ada/libgnat/g-timsta.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T I M E _ S T A M P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; use Interfaces.C; + +package body GNAT.Time_Stamp is + + subtype time_stamp is char_array (0 .. 22); + type time_stamp_ptr is access all time_stamp; + -- The desired ISO 8601 string format has exactly 22 characters. We add + -- one additional character for '\0'. The indexing starts from zero to + -- accommodate the C layout. + + procedure gnat_current_time_string (Value : time_stamp_ptr); + pragma Import (C, gnat_current_time_string, "__gnat_current_time_string"); + + ------------------ + -- Current_Time -- + ------------------ + + function Current_Time return String is + Result : aliased time_stamp; + + begin + gnat_current_time_string (Result'Unchecked_Access); + Result (22) := nul; + + return To_Ada (Result); + end Current_Time; + +end GNAT.Time_Stamp; diff --git a/gcc/ada/libgnat/g-timsta.ads b/gcc/ada/libgnat/g-timsta.ads new file mode 100644 index 0000000..80cbe24 --- /dev/null +++ b/gcc/ada/libgnat/g-timsta.ads @@ -0,0 +1,40 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T I M E _ S T A M P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 lightweight mechanism for obtaining time stamps + +package GNAT.Time_Stamp is + + function Current_Time return String; + -- Return the current local time in the following ISO 8601 string format: + -- YYYY-MM-DD HH:MM:SS.SS + +end GNAT.Time_Stamp; diff --git a/gcc/ada/libgnat/g-traceb.adb b/gcc/ada/libgnat/g-traceb.adb new file mode 100644 index 0000000..2ceef67 --- /dev/null +++ b/gcc/ada/libgnat/g-traceb.adb @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time non-symbolic traceback support + +with System.Traceback; + +package body GNAT.Traceback is + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : out Tracebacks_Array; + Len : out Natural) + is + begin + System.Traceback.Call_Chain (Traceback, Traceback'Length, Len); + end Call_Chain; + +end GNAT.Traceback; diff --git a/gcc/ada/libgnat/g-traceb.ads b/gcc/ada/libgnat/g-traceb.ads new file mode 100644 index 0000000..6256323 --- /dev/null +++ b/gcc/ada/libgnat/g-traceb.ads @@ -0,0 +1,101 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . T R A C E B A C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time non-symbolic traceback support + +-- This package provides a method for generating a traceback of the +-- current execution location. The traceback shows the locations of +-- calls in the call chain, up to either the top or a designated +-- number of levels. + +-- The traceback information is in the form of absolute code locations. +-- These code locations may be converted to corresponding source locations +-- using the external addr2line utility, or from within GDB. + +-- In order to use this facility, in some cases the binder must be invoked +-- with -E switch (store the backtrace with exception occurrence). Please +-- refer to gnatbind documentation for more information. + +-- To analyze the code locations later using addr2line or gdb, the necessary +-- units must be compiled with the debugging switch -g in the usual manner. +-- Note that it is not necessary to compile with -g to use Call_Chain. In +-- other words, the following sequence of steps can be used: + +-- Compile without -g +-- Run the program, and call Call_Chain +-- Recompile with -g +-- Use addr2line to interpret the absolute call locations (note that +-- addr2line expects addresses in hexadecimal format). + +-- This capability is currently supported on the following targets: + +-- AiX PowerPC +-- GNU/Linux x86 +-- GNU/Linux PowerPC +-- LynxOS x86 +-- LynxOS 178 xcoff PowerPC +-- LynxOS 178 elf PowerPC +-- Solaris x86 +-- Solaris sparc +-- VxWorks ARM +-- VxWorks7 ARM +-- VxWorks PowerPC +-- VxWorks x86 +-- Windows XP + +-- Note: see also GNAT.Traceback.Symbolic, a child unit in file g-trasym.ads +-- providing symbolic trace back capability for a subset of the above targets. + +with System; +with Ada.Exceptions.Traceback; + +package GNAT.Traceback is + pragma Elaborate_Body; + + subtype Code_Loc is System.Address; + -- Code location used in building tracebacks + + subtype Tracebacks_Array is Ada.Exceptions.Traceback.Tracebacks_Array; + -- Traceback array used to hold a generated traceback list + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain (Traceback : out Tracebacks_Array; Len : out Natural); + -- Store up to Traceback'Length tracebacks corresponding to the current + -- call chain. The first entry stored corresponds to the deepest level + -- of subprogram calls. Len shows the number of traceback entries stored. + -- It will be equal to Traceback'Length unless the entire traceback is + -- shorter, in which case positions in Traceback past the Len position + -- are undefined on return. + +end GNAT.Traceback; diff --git a/gcc/ada/libgnat/g-trasym.adb b/gcc/ada/libgnat/g-trasym.adb new file mode 100644 index 0000000..fe552aa --- /dev/null +++ b/gcc/ada/libgnat/g-trasym.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- 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-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-trasym.ads b/gcc/ada/libgnat/g-trasym.ads new file mode 100644 index 0000000..f80bfd9 --- /dev/null +++ b/gcc/ada/libgnat/g-trasym.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support + +-- See file s-trasym.ads for full documentation of the interface + +with System.Traceback.Symbolic; +package GNAT.Traceback.Symbolic renames System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/g-tty.adb b/gcc/ada/libgnat/g-tty.adb new file mode 100644 index 0000000..be9e7eb --- /dev/null +++ b/gcc/ada/libgnat/g-tty.adb @@ -0,0 +1,134 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . T T Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C.Strings; use Interfaces.C.Strings; + +package body GNAT.TTY is + + use System; + + procedure Check_TTY (Handle : TTY_Handle); + -- Check the validity of Handle. Raise Program_Error if ttys are not + -- supported. Raise Constraint_Error if Handle is an invalid handle. + + ------------------ + -- Allocate_TTY -- + ------------------ + + procedure Allocate_TTY (Handle : out TTY_Handle) is + function Internal return System.Address; + pragma Import (C, Internal, "__gnat_new_tty"); + + begin + if not TTY_Supported then + raise Program_Error; + end if; + + Handle.Handle := Internal; + end Allocate_TTY; + + --------------- + -- Check_TTY -- + --------------- + + procedure Check_TTY (Handle : TTY_Handle) is + begin + if not TTY_Supported then + raise Program_Error; + elsif Handle.Handle = System.Null_Address then + raise Constraint_Error; + end if; + end Check_TTY; + + --------------- + -- Close_TTY -- + --------------- + + procedure Close_TTY (Handle : in out TTY_Handle) is + procedure Internal (Handle : System.Address); + pragma Import (C, Internal, "__gnat_close_tty"); + begin + Check_TTY (Handle); + Internal (Handle.Handle); + Handle.Handle := System.Null_Address; + end Close_TTY; + + --------------- + -- Reset_TTY -- + --------------- + + procedure Reset_TTY (Handle : TTY_Handle) is + procedure Internal (Handle : System.Address); + pragma Import (C, Internal, "__gnat_reset_tty"); + begin + Check_TTY (Handle); + Internal (Handle.Handle); + end Reset_TTY; + + -------------------- + -- TTY_Descriptor -- + -------------------- + + function TTY_Descriptor + (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor + is + function Internal + (Handle : System.Address) return GNAT.OS_Lib.File_Descriptor; + pragma Import (C, Internal, "__gnat_tty_fd"); + begin + Check_TTY (Handle); + return Internal (Handle.Handle); + end TTY_Descriptor; + + -------------- + -- TTY_Name -- + -------------- + + function TTY_Name (Handle : TTY_Handle) return String is + function Internal (Handle : System.Address) return chars_ptr; + pragma Import (C, Internal, "__gnat_tty_name"); + begin + Check_TTY (Handle); + return Value (Internal (Handle.Handle)); + end TTY_Name; + + ------------------- + -- TTY_Supported -- + ------------------- + + function TTY_Supported return Boolean is + function Internal return Integer; + pragma Import (C, Internal, "__gnat_tty_supported"); + begin + return Internal /= 0; + end TTY_Supported; + +end GNAT.TTY; diff --git a/gcc/ada/libgnat/g-tty.ads b/gcc/ada/libgnat/g-tty.ads new file mode 100644 index 0000000..7fe657b --- /dev/null +++ b/gcc/ada/libgnat/g-tty.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . T T Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides control over pseudo terminals (ttys) + +-- This package is only supported on unix systems. See function TTY_Supported +-- to test dynamically whether other functions of this package can be called. + +with System; + +with GNAT.OS_Lib; + +package GNAT.TTY is + + type TTY_Handle is private; + -- Handle for a tty descriptor + + function TTY_Supported return Boolean; + -- If True, the other functions of this package can be called. Otherwise, + -- all functions in this package will raise Program_Error if called. + + procedure Allocate_TTY (Handle : out TTY_Handle); + -- Allocate a new tty + + procedure Reset_TTY (Handle : TTY_Handle); + -- Reset settings of a given tty + + procedure Close_TTY (Handle : in out TTY_Handle); + -- Close a given tty + + function TTY_Name (Handle : TTY_Handle) return String; + -- Return the external name of a tty. The name depends on the tty handling + -- on the given target. It will typically look like: "/dev/ptya1" + + function TTY_Descriptor + (Handle : TTY_Handle) return GNAT.OS_Lib.File_Descriptor; + -- Return the low level descriptor associated with Handle + +private + + type TTY_Handle is record + Handle : System.Address := System.Null_Address; + end record; + +end GNAT.TTY; diff --git a/gcc/ada/libgnat/g-u3spch.adb b/gcc/ada/libgnat/g-u3spch.adb new file mode 100644 index 0000000..d80c8c5 --- /dev/null +++ b/gcc/ada/libgnat/g-u3spch.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . U T F _ 3 2 _ S P E L L I N G _ C H E C K E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with GNAT.Spelling_Checker_Generic; + +package body GNAT.UTF_32_Spelling_Checker is + + function IBS is new + GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of + (System.WCh_Cnv.UTF_32_Code, System.WCh_Cnv.UTF_32_String); + + ------------------------ + -- Is_Bad_Spelling_Of -- + ------------------------ + + function Is_Bad_Spelling_Of + (Found : System.WCh_Cnv.UTF_32_String; + Expect : System.WCh_Cnv.UTF_32_String) return Boolean + renames IBS; + +end GNAT.UTF_32_Spelling_Checker; diff --git a/gcc/ada/libgnat/g-u3spch.ads b/gcc/ada/libgnat/g-u3spch.ads new file mode 100644 index 0000000..d87890c --- /dev/null +++ b/gcc/ada/libgnat/g-u3spch.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . U T F _ 3 2 _ S P E L L I N G _ C H E C K E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Spelling checker + +-- This package provides a utility routine for checking for bad spellings +-- for the case of System.WCh_Cnv.UTF_32_String arguments. + +pragma Compiler_Unit_Warning; + +with System.WCh_Cnv; + +package GNAT.UTF_32_Spelling_Checker is + pragma Pure; + + function Is_Bad_Spelling_Of + (Found : System.WCh_Cnv.UTF_32_String; + Expect : System.WCh_Cnv.UTF_32_String) return Boolean; + -- Determines if the string Found is a plausible misspelling of the string + -- Expect. Returns True for an exact match or a probably misspelling, False + -- if no near match is detected. This routine is case sensitive, so the + -- caller should fold both strings to get a case insensitive match. + -- + -- Note: the spec of this routine is deliberately rather vague. It is used + -- by GNAT itself to detect misspelled keywords and identifiers, and is + -- heuristically adjusted to be appropriate to this usage. It will work + -- well in any similar case of named entities. + +end GNAT.UTF_32_Spelling_Checker; diff --git a/gcc/ada/libgnat/g-utf_32.adb b/gcc/ada/libgnat/g-utf_32.adb new file mode 100644 index 0000000..ce75555 --- /dev/null +++ b/gcc/ada/libgnat/g-utf_32.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . U T F _ 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/g-utf_32.ads b/gcc/ada/libgnat/g-utf_32.ads new file mode 100644 index 0000000..cbbc5b6 --- /dev/null +++ b/gcc/ada/libgnat/g-utf_32.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . U T F _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is an internal package that provides basic character +-- classification capabilities needed by the compiler for handling full +-- 32-bit wide wide characters. We avoid the use of the actual type +-- Wide_Wide_Character, since we want to use these routines in the compiler +-- itself, and we want to be able to compile the compiler with old versions +-- of GNAT that did not implement Wide_Wide_Character. + +-- This package is available directly for use in application programs, +-- and also serves as the basis for Ada.Wide_Wide_Characters.Unicode and +-- Ada.Wide_Characters.Unicode, which can also be used directly. + +-- See file s-utf_32.ads for full documentation of the interface + +with System.UTF_32; + +package GNAT.UTF_32 renames System.UTF_32; diff --git a/gcc/ada/libgnat/g-wispch.adb b/gcc/ada/libgnat/g-wispch.adb new file mode 100644 index 0000000..b09c1de --- /dev/null +++ b/gcc/ada/libgnat/g-wispch.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . W I D E _ S P E L L I N G _ C H E C K E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Spelling_Checker_Generic; + +package body GNAT.Wide_Spelling_Checker is + + function IBS is new + GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of + (Wide_Character, Wide_String); + + ------------------------ + -- Is_Bad_Spelling_Of -- + ------------------------ + + function Is_Bad_Spelling_Of + (Found : Wide_String; + Expect : Wide_String) return Boolean + renames IBS; + +end GNAT.Wide_Spelling_Checker; diff --git a/gcc/ada/libgnat/g-wispch.ads b/gcc/ada/libgnat/g-wispch.ads new file mode 100644 index 0000000..9e4d760 --- /dev/null +++ b/gcc/ada/libgnat/g-wispch.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . W I D E _ S P E L L I N G _ C H E C K E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Spelling checker + +-- This package provides a utility routine for checking for bad spellings +-- for the case of Wide_String arguments. + +package GNAT.Wide_Spelling_Checker is + pragma Pure; + + function Is_Bad_Spelling_Of + (Found : Wide_String; + Expect : Wide_String) return Boolean; + -- Determines if the string Found is a plausible misspelling of the string + -- Expect. Returns True for an exact match or a probably misspelling, False + -- if no near match is detected. This routine is case sensitive, so the + -- caller should fold both strings to get a case insensitive match. + -- + -- Note: the spec of this routine is deliberately rather vague. It is used + -- by GNAT itself to detect misspelled keywords and identifiers, and is + -- heuristically adjusted to be appropriate to this usage. It will work + -- well in any similar case of named entities. + +end GNAT.Wide_Spelling_Checker; diff --git a/gcc/ada/libgnat/g-wistsp.ads b/gcc/ada/libgnat/g-wistsp.ads new file mode 100644 index 0000000..bc34592 --- /dev/null +++ b/gcc/ada/libgnat/g-wistsp.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . W I D E _ S T R I N G _ S P L I T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Useful wide_string-manipulation routines: given a set of separators, split +-- a wide_string wherever the separators appear, and provide direct access +-- to the resulting slices. See GNAT.Array_Split for full documentation. + +with Ada.Strings.Wide_Maps; use Ada.Strings; +with GNAT.Array_Split; + +package GNAT.Wide_String_Split is new GNAT.Array_Split + (Element => Wide_Character, + Element_Sequence => Wide_String, + Element_Set => Wide_Maps.Wide_Character_Set, + To_Set => Wide_Maps.To_Set, + Is_In => Wide_Maps.Is_In); diff --git a/gcc/ada/libgnat/g-zspche.adb b/gcc/ada/libgnat/g-zspche.adb new file mode 100644 index 0000000..420667d --- /dev/null +++ b/gcc/ada/libgnat/g-zspche.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . W I D E _W I D E _ S P E L L I N G _ C H E C K E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with GNAT.Spelling_Checker_Generic; + +package body GNAT.Wide_Wide_Spelling_Checker is + + function IBS is new + GNAT.Spelling_Checker_Generic.Is_Bad_Spelling_Of + (Wide_Wide_Character, Wide_Wide_String); + + ------------------------ + -- Is_Bad_Spelling_Of -- + ------------------------ + + function Is_Bad_Spelling_Of + (Found : Wide_Wide_String; + Expect : Wide_Wide_String) return Boolean + renames IBS; + +end GNAT.Wide_Wide_Spelling_Checker; diff --git a/gcc/ada/libgnat/g-zspche.ads b/gcc/ada/libgnat/g-zspche.ads new file mode 100644 index 0000000..40fa53f --- /dev/null +++ b/gcc/ada/libgnat/g-zspche.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T . W I D E _ W I D E _ S P E L L I N G _ C H E C K E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Spelling checker + +-- This package provides a utility routine for checking for bad spellings +-- for the case of Wide_Wide_String arguments. + +package GNAT.Wide_Wide_Spelling_Checker is + pragma Pure; + + function Is_Bad_Spelling_Of + (Found : Wide_Wide_String; + Expect : Wide_Wide_String) return Boolean; + -- Determines if the string Found is a plausible misspelling of the string + -- Expect. Returns True for an exact match or a probably misspelling, False + -- if no near match is detected. This routine is case sensitive, so the + -- caller should fold both strings to get a case insensitive match. + -- + -- Note: the spec of this routine is deliberately rather vague. It is used + -- by GNAT itself to detect misspelled keywords and identifiers, and is + -- heuristically adjusted to be appropriate to this usage. It will work + -- well in any similar case of named entities. + +end GNAT.Wide_Wide_Spelling_Checker; diff --git a/gcc/ada/libgnat/g-zstspl.ads b/gcc/ada/libgnat/g-zstspl.ads new file mode 100644 index 0000000..3d45beb --- /dev/null +++ b/gcc/ada/libgnat/g-zstspl.ads @@ -0,0 +1,44 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- G N A T . W I D E _ W I D E _ S T R I N G _ S P L I T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Useful wide_string-manipulation routines: given a set of separators, split +-- a wide_string wherever the separators appear, and provide direct access +-- to the resulting slices. See GNAT.Array_Split for full documentation. + +with Ada.Strings.Wide_Wide_Maps; use Ada.Strings; +with GNAT.Array_Split; + +package GNAT.Wide_Wide_String_Split is new GNAT.Array_Split + (Element => Wide_Wide_Character, + Element_Sequence => Wide_Wide_String, + Element_Set => Wide_Wide_Maps.Wide_Wide_Character_Set, + To_Set => Wide_Wide_Maps.To_Set, + Is_In => Wide_Wide_Maps.Is_In); diff --git a/gcc/ada/libgnat/gnat.ads b/gcc/ada/libgnat/gnat.ads new file mode 100644 index 0000000..8710029 --- /dev/null +++ b/gcc/ada/libgnat/gnat.ads @@ -0,0 +1,37 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- G N A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the parent package for a library of useful units provided with GNAT + +package GNAT is + pragma Pure; + +end GNAT; diff --git a/gcc/ada/libgnat/i-c.adb b/gcc/ada/libgnat/i-c.adb new file mode 100644 index 0000000..26aab1b --- /dev/null +++ b/gcc/ada/libgnat/i-c.adb @@ -0,0 +1,826 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.C is + + ----------------------- + -- Is_Nul_Terminated -- + ----------------------- + + -- Case of char_array + + function Is_Nul_Terminated (Item : char_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of wchar_array + + function Is_Nul_Terminated (Item : wchar_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = wide_nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of char16_array + + function Is_Nul_Terminated (Item : char16_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = char16_nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + -- Case of char32_array + + function Is_Nul_Terminated (Item : char32_array) return Boolean is + begin + for J in Item'Range loop + if Item (J) = char32_nul then + return True; + end if; + end loop; + + return False; + end Is_Nul_Terminated; + + ------------ + -- To_Ada -- + ------------ + + -- Convert char to Character + + function To_Ada (Item : char) return Character is + begin + return Character'Val (char'Pos (Item)); + end To_Ada; + + -- Convert char_array to String (function form) + + function To_Ada + (Item : char_array; + Trim_Nul : Boolean := True) return String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char_array to String (procedure form) + + procedure To_Ada + (Item : char_array; + Target : out String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := Character (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + + end To_Ada; + + -- Convert wchar_t to Wide_Character + + function To_Ada (Item : wchar_t) return Wide_Character is + begin + return Wide_Character (Item); + end To_Ada; + + -- Convert wchar_array to Wide_String (function form) + + function To_Ada + (Item : wchar_array; + Trim_Nul : Boolean := True) return Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : Wide_String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert wchar_array to Wide_String (procedure form) + + procedure To_Ada + (Item : wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = wide_nul then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + -- Convert char16_t to Wide_Character + + function To_Ada (Item : char16_t) return Wide_Character is + begin + return Wide_Character'Val (char16_t'Pos (Item)); + end To_Ada; + + -- Convert char16_array to Wide_String (function form) + + function To_Ada + (Item : char16_array; + Trim_Nul : Boolean := True) return Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char16_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : Wide_String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char16_array to Wide_String (procedure form) + + procedure To_Ada + (Item : char16_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char16_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + -- Convert char32_t to Wide_Wide_Character + + function To_Ada (Item : char32_t) return Wide_Wide_Character is + begin + return Wide_Wide_Character'Val (char32_t'Pos (Item)); + end To_Ada; + + -- Convert char32_array to Wide_Wide_String (function form) + + function To_Ada + (Item : char32_array; + Trim_Nul : Boolean := True) return Wide_Wide_String + is + Count : Natural; + From : size_t; + + begin + if Trim_Nul then + From := Item'First; + + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char32_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + declare + R : Wide_Wide_String (1 .. Count); + + begin + for J in R'Range loop + R (J) := To_Ada (Item (size_t (J) + (Item'First - 1))); + end loop; + + return R; + end; + end To_Ada; + + -- Convert char32_array to Wide_Wide_String (procedure form) + + procedure To_Ada + (Item : char32_array; + Target : out Wide_Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True) + is + From : size_t; + To : Positive; + + begin + if Trim_Nul then + From := Item'First; + loop + if From > Item'Last then + raise Terminator_Error; + elsif Item (From) = char32_t'Val (0) then + exit; + else + From := From + 1; + end if; + end loop; + + Count := Natural (From - Item'First); + + else + Count := Item'Length; + end if; + + if Count > Target'Length then + raise Constraint_Error; + + else + From := Item'First; + To := Target'First; + + for J in 1 .. Count loop + Target (To) := To_Ada (Item (From)); + From := From + 1; + To := To + 1; + end loop; + end if; + end To_Ada; + + ---------- + -- To_C -- + ---------- + + -- Convert Character to char + + function To_C (Item : Character) return char is + begin + return char'Val (Character'Pos (Item)); + end To_C; + + -- Convert String to char_array (function form) + + function To_C + (Item : String; + Append_Nul : Boolean := True) return char_array + is + begin + if Append_Nul then + declare + R : char_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := nul; + return R; + end; + + -- Append_Nul False + + else + -- A nasty case, if the string is null, we must return a null + -- char_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + -- Normal case + + else + declare + R : char_array (0 .. Item'Length - 1); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert String to char_array (procedure form) + + procedure To_C + (Item : String; + Target : out char_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := char (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to wchar_t + + function To_C (Item : Wide_Character) return wchar_t is + begin + return wchar_t (Item); + end To_C; + + -- Convert Wide_String to wchar_array (function form) + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return wchar_array + is + begin + if Append_Nul then + declare + R : wchar_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := wide_nul; + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- wchar_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : wchar_array (0 .. Item'Length - 1); + + begin + for J in size_t range 0 .. Item'Length - 1 loop + R (J) := To_C (Item (Integer (J) + Item'First)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_String to wchar_array (procedure form) + + procedure To_C + (Item : Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := wide_nul; + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to char16_t + + function To_C (Item : Wide_Character) return char16_t is + begin + return char16_t'Val (Wide_Character'Pos (Item)); + end To_C; + + -- Convert Wide_String to char16_array (function form) + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return char16_array + is + begin + if Append_Nul then + declare + R : char16_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := char16_t'Val (0); + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- char16_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. This is also the appropriate behavior in Ada 95, + -- since nothing else makes sense. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : char16_array (0 .. Item'Length - 1); + + begin + for J in size_t range 0 .. Item'Length - 1 loop + R (J) := To_C (Item (Integer (J) + Item'First)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_String to char16_array (procedure form) + + procedure To_C + (Item : Wide_String; + Target : out char16_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := char16_t'Val (0); + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + + -- Convert Wide_Character to char32_t + + function To_C (Item : Wide_Wide_Character) return char32_t is + begin + return char32_t'Val (Wide_Wide_Character'Pos (Item)); + end To_C; + + -- Convert Wide_Wide_String to char32_array (function form) + + function To_C + (Item : Wide_Wide_String; + Append_Nul : Boolean := True) return char32_array + is + begin + if Append_Nul then + declare + R : char32_array (0 .. Item'Length); + + begin + for J in Item'Range loop + R (size_t (J - Item'First)) := To_C (Item (J)); + end loop; + + R (R'Last) := char32_t'Val (0); + return R; + end; + + else + -- A nasty case, if the string is null, we must return a null + -- char32_array. The lower bound of this array is required to be zero + -- (RM B.3(50)) but that is of course impossible given that size_t + -- is unsigned. According to Ada 2005 AI-258, the result is to raise + -- Constraint_Error. + + if Item'Length = 0 then + raise Constraint_Error; + + else + declare + R : char32_array (0 .. Item'Length - 1); + + begin + for J in size_t range 0 .. Item'Length - 1 loop + R (J) := To_C (Item (Integer (J) + Item'First)); + end loop; + + return R; + end; + end if; + end if; + end To_C; + + -- Convert Wide_Wide_String to char32_array (procedure form) + + procedure To_C + (Item : Wide_Wide_String; + Target : out char32_array; + Count : out size_t; + Append_Nul : Boolean := True) + is + To : size_t; + + begin + if Target'Length < Item'Length then + raise Constraint_Error; + + else + To := Target'First; + for From in Item'Range loop + Target (To) := To_C (Item (From)); + To := To + 1; + end loop; + + if Append_Nul then + if To > Target'Last then + raise Constraint_Error; + else + Target (To) := char32_t'Val (0); + Count := Item'Length + 1; + end if; + + else + Count := Item'Length; + end if; + end if; + end To_C; + +end Interfaces.C; diff --git a/gcc/ada/libgnat/i-c.ads b/gcc/ada/libgnat/i-c.ads new file mode 100644 index 0000000..1088836 --- /dev/null +++ b/gcc/ada/libgnat/i-c.ads @@ -0,0 +1,230 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System.Parameters; + +package Interfaces.C is + pragma Pure; + + -- Declaration's based on C's + + CHAR_BIT : constant := 8; + SCHAR_MIN : constant := -128; + SCHAR_MAX : constant := 127; + UCHAR_MAX : constant := 255; + + -- Signed and Unsigned Integers. Note that in GNAT, we have ensured that + -- the standard predefined Ada types correspond to the standard C types + + -- Note: the Integer qualifications used in the declaration of type long + -- avoid ambiguities when compiling in the presence of s-auxdec.ads and + -- a non-private system.address type. + + type int is new Integer; + type short is new Short_Integer; + type long is range -(2 ** (System.Parameters.long_bits - Integer'(1))) + .. +(2 ** (System.Parameters.long_bits - Integer'(1))) - 1; + + type signed_char is range SCHAR_MIN .. SCHAR_MAX; + for signed_char'Size use CHAR_BIT; + + type unsigned is mod 2 ** int'Size; + type unsigned_short is mod 2 ** short'Size; + type unsigned_long is mod 2 ** long'Size; + + type unsigned_char is mod (UCHAR_MAX + 1); + for unsigned_char'Size use CHAR_BIT; + + subtype plain_char is unsigned_char; -- ??? should be parameterized + + -- Note: the Integer qualifications used in the declaration of ptrdiff_t + -- avoid ambiguities when compiling in the presence of s-auxdec.ads and + -- a non-private system.address type. + + type ptrdiff_t is + range -(2 ** (System.Parameters.ptr_bits - Integer'(1))) .. + +(2 ** (System.Parameters.ptr_bits - Integer'(1)) - 1); + + type size_t is mod 2 ** System.Parameters.ptr_bits; + + -- Floating-Point + + type C_float is new Float; + type double is new Standard.Long_Float; + type long_double is new Standard.Long_Long_Float; + + ---------------------------- + -- Characters and Strings -- + ---------------------------- + + type char is new Character; + + nul : constant char := char'First; + + function To_C (Item : Character) return char; + function To_Ada (Item : char) return Character; + + type char_array is array (size_t range <>) of aliased char; + for char_array'Component_Size use CHAR_BIT; + + function Is_Nul_Terminated (Item : char_array) return Boolean; + + function To_C + (Item : String; + Append_Nul : Boolean := True) return char_array; + + function To_Ada + (Item : char_array; + Trim_Nul : Boolean := True) return String; + + procedure To_C + (Item : String; + Target : out char_array; + Count : out size_t; + Append_Nul : Boolean := True); + + procedure To_Ada + (Item : char_array; + Target : out String; + Count : out Natural; + Trim_Nul : Boolean := True); + + ------------------------------------ + -- Wide Character and Wide String -- + ------------------------------------ + + type wchar_t is new Wide_Character; + for wchar_t'Size use Standard'Wchar_T_Size; + + wide_nul : constant wchar_t := wchar_t'First; + + function To_C (Item : Wide_Character) return wchar_t; + function To_Ada (Item : wchar_t) return Wide_Character; + + type wchar_array is array (size_t range <>) of aliased wchar_t; + + function Is_Nul_Terminated (Item : wchar_array) return Boolean; + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return wchar_array; + + function To_Ada + (Item : wchar_array; + Trim_Nul : Boolean := True) return Wide_String; + + procedure To_C + (Item : Wide_String; + Target : out wchar_array; + Count : out size_t; + Append_Nul : Boolean := True); + + procedure To_Ada + (Item : wchar_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True); + + Terminator_Error : exception; + + -- The remaining declarations are for Ada 2005 (AI-285) + + -- ISO/IEC 10646:2003 compatible types defined by SC22/WG14 document N1010 + + type char16_t is new Wide_Character; + pragma Ada_05 (char16_t); + + char16_nul : constant char16_t := char16_t'Val (0); + pragma Ada_05 (char16_nul); + + function To_C (Item : Wide_Character) return char16_t; + pragma Ada_05 (To_C); + + function To_Ada (Item : char16_t) return Wide_Character; + pragma Ada_05 (To_Ada); + + type char16_array is array (size_t range <>) of aliased char16_t; + pragma Ada_05 (char16_array); + + function Is_Nul_Terminated (Item : char16_array) return Boolean; + pragma Ada_05 (Is_Nul_Terminated); + + function To_C + (Item : Wide_String; + Append_Nul : Boolean := True) return char16_array; + pragma Ada_05 (To_C); + + function To_Ada + (Item : char16_array; + Trim_Nul : Boolean := True) return Wide_String; + pragma Ada_05 (To_Ada); + + procedure To_C + (Item : Wide_String; + Target : out char16_array; + Count : out size_t; + Append_Nul : Boolean := True); + pragma Ada_05 (To_C); + + procedure To_Ada + (Item : char16_array; + Target : out Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True); + pragma Ada_05 (To_Ada); + + type char32_t is new Wide_Wide_Character; + pragma Ada_05 (char32_t); + + char32_nul : constant char32_t := char32_t'Val (0); + pragma Ada_05 (char32_nul); + + function To_C (Item : Wide_Wide_Character) return char32_t; + pragma Ada_05 (To_C); + + function To_Ada (Item : char32_t) return Wide_Wide_Character; + pragma Ada_05 (To_Ada); + + type char32_array is array (size_t range <>) of aliased char32_t; + pragma Ada_05 (char32_array); + + function Is_Nul_Terminated (Item : char32_array) return Boolean; + pragma Ada_05 (Is_Nul_Terminated); + + function To_C + (Item : Wide_Wide_String; + Append_Nul : Boolean := True) return char32_array; + pragma Ada_05 (To_C); + + function To_Ada + (Item : char32_array; + Trim_Nul : Boolean := True) return Wide_Wide_String; + pragma Ada_05 (To_Ada); + + procedure To_C + (Item : Wide_Wide_String; + Target : out char32_array; + Count : out size_t; + Append_Nul : Boolean := True); + pragma Ada_05 (To_C); + + procedure To_Ada + (Item : char32_array; + Target : out Wide_Wide_String; + Count : out Natural; + Trim_Nul : Boolean := True); + pragma Ada_05 (To_Ada); + +end Interfaces.C; diff --git a/gcc/ada/libgnat/i-cexten.ads b/gcc/ada/libgnat/i-cexten.ads new file mode 100644 index 0000000..bcbfd98 --- /dev/null +++ b/gcc/ada/libgnat/i-cexten.ads @@ -0,0 +1,458 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . E X T E N S I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains additional C-related definitions, intended for use +-- with either manually or automatically generated bindings to C libraries. + +with System; + +package Interfaces.C.Extensions is + pragma Pure; + + -- Definitions for C "void" and "void *" types + + subtype void is System.Address; + subtype void_ptr is System.Address; + + -- Definitions for C incomplete/unknown structs + + subtype opaque_structure_def is System.Address; + type opaque_structure_def_ptr is access opaque_structure_def; + for opaque_structure_def_ptr'Storage_Size use 0; + + -- Definitions for C++ incomplete/unknown classes + + subtype incomplete_class_def is System.Address; + type incomplete_class_def_ptr is access incomplete_class_def; + for incomplete_class_def_ptr'Storage_Size use 0; + + -- C bool + + subtype bool is plain_char; + + -- 64-bit integer types + + subtype long_long is Long_Long_Integer; + type unsigned_long_long is mod 2 ** 64; + + -- 128-bit integer type available on 64-bit platforms: + -- typedef int signed_128 __attribute__ ((mode (TI))); + + type Signed_128 is record + low, high : unsigned_long_long; + end record; + pragma Convention (C_Pass_By_Copy, Signed_128); + for Signed_128'Alignment use unsigned_long_long'Alignment * 2; + + -- Types for bitfields + + type Unsigned_1 is mod 2 ** 1; + for Unsigned_1'Size use 1; + + type Unsigned_2 is mod 2 ** 2; + for Unsigned_2'Size use 2; + + type Unsigned_3 is mod 2 ** 3; + for Unsigned_3'Size use 3; + + type Unsigned_4 is mod 2 ** 4; + for Unsigned_4'Size use 4; + + type Unsigned_5 is mod 2 ** 5; + for Unsigned_5'Size use 5; + + type Unsigned_6 is mod 2 ** 6; + for Unsigned_6'Size use 6; + + type Unsigned_7 is mod 2 ** 7; + for Unsigned_7'Size use 7; + + type Unsigned_8 is mod 2 ** 8; + for Unsigned_8'Size use 8; + + type Unsigned_9 is mod 2 ** 9; + for Unsigned_9'Size use 9; + + type Unsigned_10 is mod 2 ** 10; + for Unsigned_10'Size use 10; + + type Unsigned_11 is mod 2 ** 11; + for Unsigned_11'Size use 11; + + type Unsigned_12 is mod 2 ** 12; + for Unsigned_12'Size use 12; + + type Unsigned_13 is mod 2 ** 13; + for Unsigned_13'Size use 13; + + type Unsigned_14 is mod 2 ** 14; + for Unsigned_14'Size use 14; + + type Unsigned_15 is mod 2 ** 15; + for Unsigned_15'Size use 15; + + type Unsigned_16 is mod 2 ** 16; + for Unsigned_16'Size use 16; + + type Unsigned_17 is mod 2 ** 17; + for Unsigned_17'Size use 17; + + type Unsigned_18 is mod 2 ** 18; + for Unsigned_18'Size use 18; + + type Unsigned_19 is mod 2 ** 19; + for Unsigned_19'Size use 19; + + type Unsigned_20 is mod 2 ** 20; + for Unsigned_20'Size use 20; + + type Unsigned_21 is mod 2 ** 21; + for Unsigned_21'Size use 21; + + type Unsigned_22 is mod 2 ** 22; + for Unsigned_22'Size use 22; + + type Unsigned_23 is mod 2 ** 23; + for Unsigned_23'Size use 23; + + type Unsigned_24 is mod 2 ** 24; + for Unsigned_24'Size use 24; + + type Unsigned_25 is mod 2 ** 25; + for Unsigned_25'Size use 25; + + type Unsigned_26 is mod 2 ** 26; + for Unsigned_26'Size use 26; + + type Unsigned_27 is mod 2 ** 27; + for Unsigned_27'Size use 27; + + type Unsigned_28 is mod 2 ** 28; + for Unsigned_28'Size use 28; + + type Unsigned_29 is mod 2 ** 29; + for Unsigned_29'Size use 29; + + type Unsigned_30 is mod 2 ** 30; + for Unsigned_30'Size use 30; + + type Unsigned_31 is mod 2 ** 31; + for Unsigned_31'Size use 31; + + type Unsigned_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type Unsigned_33 is mod 2 ** 33; + for Unsigned_33'Size use 33; + + type Unsigned_34 is mod 2 ** 34; + for Unsigned_34'Size use 34; + + type Unsigned_35 is mod 2 ** 35; + for Unsigned_35'Size use 35; + + type Unsigned_36 is mod 2 ** 36; + for Unsigned_36'Size use 36; + + type Unsigned_37 is mod 2 ** 37; + for Unsigned_37'Size use 37; + + type Unsigned_38 is mod 2 ** 38; + for Unsigned_38'Size use 38; + + type Unsigned_39 is mod 2 ** 39; + for Unsigned_39'Size use 39; + + type Unsigned_40 is mod 2 ** 40; + for Unsigned_40'Size use 40; + + type Unsigned_41 is mod 2 ** 41; + for Unsigned_41'Size use 41; + + type Unsigned_42 is mod 2 ** 42; + for Unsigned_42'Size use 42; + + type Unsigned_43 is mod 2 ** 43; + for Unsigned_43'Size use 43; + + type Unsigned_44 is mod 2 ** 44; + for Unsigned_44'Size use 44; + + type Unsigned_45 is mod 2 ** 45; + for Unsigned_45'Size use 45; + + type Unsigned_46 is mod 2 ** 46; + for Unsigned_46'Size use 46; + + type Unsigned_47 is mod 2 ** 47; + for Unsigned_47'Size use 47; + + type Unsigned_48 is mod 2 ** 48; + for Unsigned_48'Size use 48; + + type Unsigned_49 is mod 2 ** 49; + for Unsigned_49'Size use 49; + + type Unsigned_50 is mod 2 ** 50; + for Unsigned_50'Size use 50; + + type Unsigned_51 is mod 2 ** 51; + for Unsigned_51'Size use 51; + + type Unsigned_52 is mod 2 ** 52; + for Unsigned_52'Size use 52; + + type Unsigned_53 is mod 2 ** 53; + for Unsigned_53'Size use 53; + + type Unsigned_54 is mod 2 ** 54; + for Unsigned_54'Size use 54; + + type Unsigned_55 is mod 2 ** 55; + for Unsigned_55'Size use 55; + + type Unsigned_56 is mod 2 ** 56; + for Unsigned_56'Size use 56; + + type Unsigned_57 is mod 2 ** 57; + for Unsigned_57'Size use 57; + + type Unsigned_58 is mod 2 ** 58; + for Unsigned_58'Size use 58; + + type Unsigned_59 is mod 2 ** 59; + for Unsigned_59'Size use 59; + + type Unsigned_60 is mod 2 ** 60; + for Unsigned_60'Size use 60; + + type Unsigned_61 is mod 2 ** 61; + for Unsigned_61'Size use 61; + + type Unsigned_62 is mod 2 ** 62; + for Unsigned_62'Size use 62; + + type Unsigned_63 is mod 2 ** 63; + for Unsigned_63'Size use 63; + + type Unsigned_64 is mod 2 ** 64; + for Unsigned_64'Size use 64; + + type Signed_2 is range -2 ** 1 .. 2 ** 1 - 1; + for Signed_2'Size use 2; + + type Signed_3 is range -2 ** 2 .. 2 ** 2 - 1; + for Signed_3'Size use 3; + + type Signed_4 is range -2 ** 3 .. 2 ** 3 - 1; + for Signed_4'Size use 4; + + type Signed_5 is range -2 ** 4 .. 2 ** 4 - 1; + for Signed_5'Size use 5; + + type Signed_6 is range -2 ** 5 .. 2 ** 5 - 1; + for Signed_6'Size use 6; + + type Signed_7 is range -2 ** 6 .. 2 ** 6 - 1; + for Signed_7'Size use 7; + + type Signed_8 is range -2 ** 7 .. 2 ** 7 - 1; + for Signed_8'Size use 8; + + type Signed_9 is range -2 ** 8 .. 2 ** 8 - 1; + for Signed_9'Size use 9; + + type Signed_10 is range -2 ** 9 .. 2 ** 9 - 1; + for Signed_10'Size use 10; + + type Signed_11 is range -2 ** 10 .. 2 ** 10 - 1; + for Signed_11'Size use 11; + + type Signed_12 is range -2 ** 11 .. 2 ** 11 - 1; + for Signed_12'Size use 12; + + type Signed_13 is range -2 ** 12 .. 2 ** 12 - 1; + for Signed_13'Size use 13; + + type Signed_14 is range -2 ** 13 .. 2 ** 13 - 1; + for Signed_14'Size use 14; + + type Signed_15 is range -2 ** 14 .. 2 ** 14 - 1; + for Signed_15'Size use 15; + + type Signed_16 is range -2 ** 15 .. 2 ** 15 - 1; + for Signed_16'Size use 16; + + type Signed_17 is range -2 ** 16 .. 2 ** 16 - 1; + for Signed_17'Size use 17; + + type Signed_18 is range -2 ** 17 .. 2 ** 17 - 1; + for Signed_18'Size use 18; + + type Signed_19 is range -2 ** 18 .. 2 ** 18 - 1; + for Signed_19'Size use 19; + + type Signed_20 is range -2 ** 19 .. 2 ** 19 - 1; + for Signed_20'Size use 20; + + type Signed_21 is range -2 ** 20 .. 2 ** 20 - 1; + for Signed_21'Size use 21; + + type Signed_22 is range -2 ** 21 .. 2 ** 21 - 1; + for Signed_22'Size use 22; + + type Signed_23 is range -2 ** 22 .. 2 ** 22 - 1; + for Signed_23'Size use 23; + + type Signed_24 is range -2 ** 23 .. 2 ** 23 - 1; + for Signed_24'Size use 24; + + type Signed_25 is range -2 ** 24 .. 2 ** 24 - 1; + for Signed_25'Size use 25; + + type Signed_26 is range -2 ** 25 .. 2 ** 25 - 1; + for Signed_26'Size use 26; + + type Signed_27 is range -2 ** 26 .. 2 ** 26 - 1; + for Signed_27'Size use 27; + + type Signed_28 is range -2 ** 27 .. 2 ** 27 - 1; + for Signed_28'Size use 28; + + type Signed_29 is range -2 ** 28 .. 2 ** 28 - 1; + for Signed_29'Size use 29; + + type Signed_30 is range -2 ** 29 .. 2 ** 29 - 1; + for Signed_30'Size use 30; + + type Signed_31 is range -2 ** 30 .. 2 ** 30 - 1; + for Signed_31'Size use 31; + + type Signed_32 is range -2 ** 31 .. 2 ** 31 - 1; + for Signed_32'Size use 32; + + type Signed_33 is range -2 ** 32 .. 2 ** 32 - 1; + for Signed_33'Size use 33; + + type Signed_34 is range -2 ** 33 .. 2 ** 33 - 1; + for Signed_34'Size use 34; + + type Signed_35 is range -2 ** 34 .. 2 ** 34 - 1; + for Signed_35'Size use 35; + + type Signed_36 is range -2 ** 35 .. 2 ** 35 - 1; + for Signed_36'Size use 36; + + type Signed_37 is range -2 ** 36 .. 2 ** 36 - 1; + for Signed_37'Size use 37; + + type Signed_38 is range -2 ** 37 .. 2 ** 37 - 1; + for Signed_38'Size use 38; + + type Signed_39 is range -2 ** 38 .. 2 ** 38 - 1; + for Signed_39'Size use 39; + + type Signed_40 is range -2 ** 39 .. 2 ** 39 - 1; + for Signed_40'Size use 40; + + type Signed_41 is range -2 ** 40 .. 2 ** 40 - 1; + for Signed_41'Size use 41; + + type Signed_42 is range -2 ** 41 .. 2 ** 41 - 1; + for Signed_42'Size use 42; + + type Signed_43 is range -2 ** 42 .. 2 ** 42 - 1; + for Signed_43'Size use 43; + + type Signed_44 is range -2 ** 43 .. 2 ** 43 - 1; + for Signed_44'Size use 44; + + type Signed_45 is range -2 ** 44 .. 2 ** 44 - 1; + for Signed_45'Size use 45; + + type Signed_46 is range -2 ** 45 .. 2 ** 45 - 1; + for Signed_46'Size use 46; + + type Signed_47 is range -2 ** 46 .. 2 ** 46 - 1; + for Signed_47'Size use 47; + + type Signed_48 is range -2 ** 47 .. 2 ** 47 - 1; + for Signed_48'Size use 48; + + type Signed_49 is range -2 ** 48 .. 2 ** 48 - 1; + for Signed_49'Size use 49; + + type Signed_50 is range -2 ** 49 .. 2 ** 49 - 1; + for Signed_50'Size use 50; + + type Signed_51 is range -2 ** 50 .. 2 ** 50 - 1; + for Signed_51'Size use 51; + + type Signed_52 is range -2 ** 51 .. 2 ** 51 - 1; + for Signed_52'Size use 52; + + type Signed_53 is range -2 ** 52 .. 2 ** 52 - 1; + for Signed_53'Size use 53; + + type Signed_54 is range -2 ** 53 .. 2 ** 53 - 1; + for Signed_54'Size use 54; + + type Signed_55 is range -2 ** 54 .. 2 ** 54 - 1; + for Signed_55'Size use 55; + + type Signed_56 is range -2 ** 55 .. 2 ** 55 - 1; + for Signed_56'Size use 56; + + type Signed_57 is range -2 ** 56 .. 2 ** 56 - 1; + for Signed_57'Size use 57; + + type Signed_58 is range -2 ** 57 .. 2 ** 57 - 1; + for Signed_58'Size use 58; + + type Signed_59 is range -2 ** 58 .. 2 ** 58 - 1; + for Signed_59'Size use 59; + + type Signed_60 is range -2 ** 59 .. 2 ** 59 - 1; + for Signed_60'Size use 60; + + type Signed_61 is range -2 ** 60 .. 2 ** 60 - 1; + for Signed_61'Size use 61; + + type Signed_62 is range -2 ** 61 .. 2 ** 61 - 1; + for Signed_62'Size use 62; + + type Signed_63 is range -2 ** 62 .. 2 ** 62 - 1; + for Signed_63'Size use 63; + + type Signed_64 is range -2 ** 63 .. 2 ** 63 - 1; + for Signed_64'Size use 64; + +end Interfaces.C.Extensions; diff --git a/gcc/ada/libgnat/i-cobol.adb b/gcc/ada/libgnat/i-cobol.adb new file mode 100644 index 0000000..d87c00a --- /dev/null +++ b/gcc/ada/libgnat/i-cobol.adb @@ -0,0 +1,993 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I N T E R F A C E S . C O B O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The body of Interfaces.COBOL is implementation independent (i.e. the same +-- version is used with all versions of GNAT). The specialization to a +-- particular COBOL format is completely contained in the private part of +-- the spec. + +with Interfaces; use Interfaces; +with System; use System; +with Ada.Unchecked_Conversion; + +package body Interfaces.COBOL is + + ----------------------------------------------- + -- Declarations for External Binary Handling -- + ----------------------------------------------- + + subtype B1 is Byte_Array (1 .. 1); + subtype B2 is Byte_Array (1 .. 2); + subtype B4 is Byte_Array (1 .. 4); + subtype B8 is Byte_Array (1 .. 8); + -- Representations for 1,2,4,8 byte binary values + + function To_B1 is new Ada.Unchecked_Conversion (Integer_8, B1); + function To_B2 is new Ada.Unchecked_Conversion (Integer_16, B2); + function To_B4 is new Ada.Unchecked_Conversion (Integer_32, B4); + function To_B8 is new Ada.Unchecked_Conversion (Integer_64, B8); + -- Conversions from native binary to external binary + + function From_B1 is new Ada.Unchecked_Conversion (B1, Integer_8); + function From_B2 is new Ada.Unchecked_Conversion (B2, Integer_16); + function From_B4 is new Ada.Unchecked_Conversion (B4, Integer_32); + function From_B8 is new Ada.Unchecked_Conversion (B8, Integer_64); + -- Conversions from external binary to signed native binary + + function From_B1U is new Ada.Unchecked_Conversion (B1, Unsigned_8); + function From_B2U is new Ada.Unchecked_Conversion (B2, Unsigned_16); + function From_B4U is new Ada.Unchecked_Conversion (B4, Unsigned_32); + function From_B8U is new Ada.Unchecked_Conversion (B8, Unsigned_64); + -- Conversions from external binary to unsigned native binary + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Binary_To_Decimal + (Item : Byte_Array; + Format : Binary_Format) return Integer_64; + -- This function converts a numeric value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + function Numeric_To_Decimal + (Item : Numeric; + Format : Display_Format) return Integer_64; + -- This function converts a numeric value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + function Packed_To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) return Integer_64; + -- This function converts a packed value in the given format to its + -- corresponding integer value. This is the non-generic implementation + -- of Decimal_Conversions.To_Decimal. The generic routine does the + -- final conversion to the fixed-point format. + + procedure Swap (B : in out Byte_Array; F : Binary_Format); + -- Swaps the bytes if required by the binary format F + + function To_Display + (Item : Integer_64; + Format : Display_Format; + Length : Natural) return Numeric; + -- This function converts the given integer value into display format, + -- using the given format, with the length in bytes of the result given + -- by the last parameter. This is the non-generic implementation of + -- Decimal_Conversions.To_Display. The conversion of the item from its + -- original decimal format to Integer_64 is done by the generic routine. + + function To_Packed + (Item : Integer_64; + Format : Packed_Format; + Length : Natural) return Packed_Decimal; + -- This function converts the given integer value into packed format, + -- using the given format, with the length in digits of the result given + -- by the last parameter. This is the non-generic implementation of + -- Decimal_Conversions.To_Display. The conversion of the item from its + -- original decimal format to Integer_64 is done by the generic routine. + + function Valid_Numeric + (Item : Numeric; + Format : Display_Format) return Boolean; + -- This is the non-generic implementation of Decimal_Conversions.Valid + -- for the display case. + + function Valid_Packed + (Item : Packed_Decimal; + Format : Packed_Format) return Boolean; + -- This is the non-generic implementation of Decimal_Conversions.Valid + -- for the packed case. + + ----------------------- + -- Binary_To_Decimal -- + ----------------------- + + function Binary_To_Decimal + (Item : Byte_Array; + Format : Binary_Format) return Integer_64 + is + Len : constant Natural := Item'Length; + + begin + if Len = 1 then + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B1U (Item)); + else + return Integer_64 (From_B1 (Item)); + end if; + + elsif Len = 2 then + declare + R : B2 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B2U (R)); + else + return Integer_64 (From_B2 (R)); + end if; + end; + + elsif Len = 4 then + declare + R : B4 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B4U (R)); + else + return Integer_64 (From_B4 (R)); + end if; + end; + + elsif Len = 8 then + declare + R : B8 := Item; + + begin + Swap (R, Format); + + if Format in Binary_Unsigned_Format then + return Integer_64 (From_B8U (R)); + else + return Integer_64 (From_B8 (R)); + end if; + end; + + -- Length is not 1, 2, 4 or 8 + + else + raise Conversion_Error; + end if; + end Binary_To_Decimal; + + ------------------------ + -- Numeric_To_Decimal -- + ------------------------ + + -- The following assumptions are made in the coding of this routine: + + -- The range of COBOL_Digits is compact and the ten values + -- represent the digits 0-9 in sequence + + -- The range of COBOL_Plus_Digits is compact and the ten values + -- represent the digits 0-9 in sequence with a plus sign. + + -- The range of COBOL_Minus_Digits is compact and the ten values + -- represent the digits 0-9 in sequence with a minus sign. + + -- The COBOL_Minus_Digits set is disjoint from COBOL_Digits + + -- These assumptions are true for all COBOL representations we know of + + function Numeric_To_Decimal + (Item : Numeric; + Format : Display_Format) return Integer_64 + is + pragma Unsuppress (Range_Check); + Sign : COBOL_Character := COBOL_Plus; + Result : Integer_64 := 0; + + begin + if not Valid_Numeric (Item, Format) then + raise Conversion_Error; + end if; + + for J in Item'Range loop + declare + K : constant COBOL_Character := Item (J); + + begin + if K in COBOL_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Digits'First)); + + elsif K in COBOL_Plus_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Plus_Digits'First)); + + elsif K in COBOL_Minus_Digits then + Result := Result * 10 + + (COBOL_Character'Pos (K) - + COBOL_Character'Pos (COBOL_Minus_Digits'First)); + Sign := COBOL_Minus; + + -- Only remaining possibility is COBOL_Plus or COBOL_Minus + + else + Sign := K; + end if; + end; + end loop; + + if Sign = COBOL_Plus then + return Result; + else + return -Result; + end if; + + exception + when Constraint_Error => + raise Conversion_Error; + + end Numeric_To_Decimal; + + ----------------------- + -- Packed_To_Decimal -- + ----------------------- + + function Packed_To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) return Integer_64 + is + pragma Unsuppress (Range_Check); + Result : Integer_64 := 0; + Sign : constant Decimal_Element := Item (Item'Last); + + begin + if not Valid_Packed (Item, Format) then + raise Conversion_Error; + end if; + + case Packed_Representation is + when IBM => + for J in Item'First .. Item'Last - 1 loop + Result := Result * 10 + Integer_64 (Item (J)); + end loop; + + if Sign = 16#0B# or else Sign = 16#0D# then + return -Result; + else + return +Result; + end if; + end case; + + exception + when Constraint_Error => + raise Conversion_Error; + end Packed_To_Decimal; + + ---------- + -- Swap -- + ---------- + + procedure Swap (B : in out Byte_Array; F : Binary_Format) is + Little_Endian : constant Boolean := + System.Default_Bit_Order = System.Low_Order_First; + + begin + -- Return if no swap needed + + case F is + when H | HU => + if not Little_Endian then + return; + end if; + + when L | LU => + if Little_Endian then + return; + end if; + + when N | NU => + return; + end case; + + -- Here a swap is needed + + declare + Len : constant Natural := B'Length; + + begin + for J in 1 .. Len / 2 loop + declare + Temp : constant Byte := B (J); + + begin + B (J) := B (Len + 1 - J); + B (Len + 1 - J) := Temp; + end; + end loop; + end; + end Swap; + + ----------------------- + -- To_Ada (function) -- + ----------------------- + + function To_Ada (Item : Alphanumeric) return String is + Result : String (Item'Range); + + begin + for J in Item'Range loop + Result (J) := COBOL_To_Ada (Item (J)); + end loop; + + return Result; + end To_Ada; + + ------------------------ + -- To_Ada (procedure) -- + ------------------------ + + procedure To_Ada + (Item : Alphanumeric; + Target : out String; + Last : out Natural) + is + Last_Val : Integer; + + begin + if Item'Length > Target'Length then + raise Constraint_Error; + end if; + + Last_Val := Target'First - 1; + for J in Item'Range loop + Last_Val := Last_Val + 1; + Target (Last_Val) := COBOL_To_Ada (Item (J)); + end loop; + + Last := Last_Val; + end To_Ada; + + ------------------------- + -- To_COBOL (function) -- + ------------------------- + + function To_COBOL (Item : String) return Alphanumeric is + Result : Alphanumeric (Item'Range); + + begin + for J in Item'Range loop + Result (J) := Ada_To_COBOL (Item (J)); + end loop; + + return Result; + end To_COBOL; + + -------------------------- + -- To_COBOL (procedure) -- + -------------------------- + + procedure To_COBOL + (Item : String; + Target : out Alphanumeric; + Last : out Natural) + is + Last_Val : Integer; + + begin + if Item'Length > Target'Length then + raise Constraint_Error; + end if; + + Last_Val := Target'First - 1; + for J in Item'Range loop + Last_Val := Last_Val + 1; + Target (Last_Val) := Ada_To_COBOL (Item (J)); + end loop; + + Last := Last_Val; + end To_COBOL; + + ---------------- + -- To_Display -- + ---------------- + + function To_Display + (Item : Integer_64; + Format : Display_Format; + Length : Natural) return Numeric + is + Result : Numeric (1 .. Length); + Val : Integer_64 := Item; + + procedure Convert (First, Last : Natural); + -- Convert the number in Val into COBOL_Digits, storing the result + -- in Result (First .. Last). Raise Conversion_Error if too large. + + procedure Embed_Sign (Loc : Natural); + -- Used for the nonseparate formats to embed the appropriate sign + -- at the specified location (i.e. at Result (Loc)) + + ------------- + -- Convert -- + ------------- + + procedure Convert (First, Last : Natural) is + J : Natural; + + begin + J := Last; + while J >= First loop + Result (J) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Digits'First) + + Integer (Val mod 10)); + Val := Val / 10; + + if Val = 0 then + for K in First .. J - 1 loop + Result (J) := COBOL_Digits'First; + end loop; + + return; + + else + J := J - 1; + end if; + end loop; + + raise Conversion_Error; + end Convert; + + ---------------- + -- Embed_Sign -- + ---------------- + + procedure Embed_Sign (Loc : Natural) is + Digit : Natural range 0 .. 9; + + begin + Digit := COBOL_Character'Pos (Result (Loc)) - + COBOL_Character'Pos (COBOL_Digits'First); + + if Item >= 0 then + Result (Loc) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Plus_Digits'First) + Digit); + else + Result (Loc) := + COBOL_Character'Val + (COBOL_Character'Pos (COBOL_Minus_Digits'First) + Digit); + end if; + end Embed_Sign; + + -- Start of processing for To_Display + + begin + case Format is + when Unsigned => + if Val < 0 then + raise Conversion_Error; + else + Convert (1, Length); + end if; + + when Leading_Separate => + if Val < 0 then + Result (1) := COBOL_Minus; + Val := -Val; + else + Result (1) := COBOL_Plus; + end if; + + Convert (2, Length); + + when Trailing_Separate => + if Val < 0 then + Result (Length) := COBOL_Minus; + Val := -Val; + else + Result (Length) := COBOL_Plus; + end if; + + Convert (1, Length - 1); + + when Leading_Nonseparate => + Val := abs Val; + Convert (1, Length); + Embed_Sign (1); + + when Trailing_Nonseparate => + Val := abs Val; + Convert (1, Length); + Embed_Sign (Length); + end case; + + return Result; + end To_Display; + + --------------- + -- To_Packed -- + --------------- + + function To_Packed + (Item : Integer_64; + Format : Packed_Format; + Length : Natural) return Packed_Decimal + is + Result : Packed_Decimal (1 .. Length); + Val : Integer_64; + + procedure Convert (First, Last : Natural); + -- Convert the number in Val into a sequence of Decimal_Element values, + -- storing the result in Result (First .. Last). Raise Conversion_Error + -- if the value is too large to fit. + + ------------- + -- Convert -- + ------------- + + procedure Convert (First, Last : Natural) is + J : Natural := Last; + + begin + while J >= First loop + Result (J) := Decimal_Element (Val mod 10); + + Val := Val / 10; + + if Val = 0 then + for K in First .. J - 1 loop + Result (K) := 0; + end loop; + + return; + + else + J := J - 1; + end if; + end loop; + + raise Conversion_Error; + end Convert; + + -- Start of processing for To_Packed + + begin + case Packed_Representation is + when IBM => + if Format = Packed_Unsigned then + if Item < 0 then + raise Conversion_Error; + else + Result (Length) := 16#F#; + Val := Item; + end if; + + elsif Item >= 0 then + Result (Length) := 16#C#; + Val := Item; + + else -- Item < 0 + Result (Length) := 16#D#; + Val := -Item; + end if; + + Convert (1, Length - 1); + return Result; + end case; + end To_Packed; + + ------------------- + -- Valid_Numeric -- + ------------------- + + function Valid_Numeric + (Item : Numeric; + Format : Display_Format) return Boolean + is + begin + if Item'Length = 0 then + return False; + end if; + + -- All character positions except first and last must be Digits. + -- This is true for all the formats. + + for J in Item'First + 1 .. Item'Last - 1 loop + if Item (J) not in COBOL_Digits then + return False; + end if; + end loop; + + case Format is + when Unsigned => + return Item (Item'First) in COBOL_Digits + and then Item (Item'Last) in COBOL_Digits; + + when Leading_Separate => + return (Item (Item'First) = COBOL_Plus or else + Item (Item'First) = COBOL_Minus) + and then Item (Item'Last) in COBOL_Digits; + + when Trailing_Separate => + return Item (Item'First) in COBOL_Digits + and then + (Item (Item'Last) = COBOL_Plus or else + Item (Item'Last) = COBOL_Minus); + + when Leading_Nonseparate => + return (Item (Item'First) in COBOL_Plus_Digits or else + Item (Item'First) in COBOL_Minus_Digits) + and then Item (Item'Last) in COBOL_Digits; + + when Trailing_Nonseparate => + return Item (Item'First) in COBOL_Digits + and then + (Item (Item'Last) in COBOL_Plus_Digits or else + Item (Item'Last) in COBOL_Minus_Digits); + + end case; + end Valid_Numeric; + + ------------------ + -- Valid_Packed -- + ------------------ + + function Valid_Packed + (Item : Packed_Decimal; + Format : Packed_Format) return Boolean + is + begin + case Packed_Representation is + when IBM => + for J in Item'First .. Item'Last - 1 loop + if Item (J) > 9 then + return False; + end if; + end loop; + + -- For unsigned, sign digit must be F + + if Format = Packed_Unsigned then + return Item (Item'Last) = 16#F#; + + -- For signed, accept all standard and non-standard signs + + else + return Item (Item'Last) in 16#A# .. 16#F#; + end if; + end case; + end Valid_Packed; + + ------------------------- + -- Decimal_Conversions -- + ------------------------- + + package body Decimal_Conversions is + + --------------------- + -- Length (binary) -- + --------------------- + + -- Note that the tests here are all compile time tests + + function Length (Format : Binary_Format) return Natural is + pragma Unreferenced (Format); + begin + if Num'Digits <= 2 then + return 1; + elsif Num'Digits <= 4 then + return 2; + elsif Num'Digits <= 9 then + return 4; + else -- Num'Digits in 10 .. 18 + return 8; + end if; + end Length; + + ---------------------- + -- Length (display) -- + ---------------------- + + function Length (Format : Display_Format) return Natural is + begin + if Format = Leading_Separate or else Format = Trailing_Separate then + return Num'Digits + 1; + else + return Num'Digits; + end if; + end Length; + + --------------------- + -- Length (packed) -- + --------------------- + + -- Note that the tests here are all compile time checks + + function Length + (Format : Packed_Format) return Natural + is + pragma Unreferenced (Format); + begin + case Packed_Representation is + when IBM => + return (Num'Digits + 2) / 2 * 2; + end case; + end Length; + + --------------- + -- To_Binary -- + --------------- + + function To_Binary + (Item : Num; + Format : Binary_Format) return Byte_Array + is + begin + -- Note: all these tests are compile time tests + + if Num'Digits <= 2 then + return To_B1 (Integer_8'Integer_Value (Item)); + + elsif Num'Digits <= 4 then + declare + R : B2 := To_B2 (Integer_16'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + + elsif Num'Digits <= 9 then + declare + R : B4 := To_B4 (Integer_32'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + + else -- Num'Digits in 10 .. 18 + declare + R : B8 := To_B8 (Integer_64'Integer_Value (Item)); + + begin + Swap (R, Format); + return R; + end; + end if; + + exception + when Constraint_Error => + raise Conversion_Error; + end To_Binary; + + --------------------------------- + -- To_Binary (internal binary) -- + --------------------------------- + + function To_Binary (Item : Num) return Binary is + pragma Unsuppress (Range_Check); + begin + return Binary'Integer_Value (Item); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Binary; + + ------------------------- + -- To_Decimal (binary) -- + ------------------------- + + function To_Decimal + (Item : Byte_Array; + Format : Binary_Format) return Num + is + pragma Unsuppress (Range_Check); + begin + return Num'Fixed_Value (Binary_To_Decimal (Item, Format)); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ---------------------------------- + -- To_Decimal (internal binary) -- + ---------------------------------- + + function To_Decimal (Item : Binary) return Num is + pragma Unsuppress (Range_Check); + begin + return Num'Fixed_Value (Item); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + -------------------------- + -- To_Decimal (display) -- + -------------------------- + + function To_Decimal + (Item : Numeric; + Format : Display_Format) return Num + is + pragma Unsuppress (Range_Check); + + begin + return Num'Fixed_Value (Numeric_To_Decimal (Item, Format)); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + --------------------------------------- + -- To_Decimal (internal long binary) -- + --------------------------------------- + + function To_Decimal (Item : Long_Binary) return Num is + pragma Unsuppress (Range_Check); + begin + return Num'Fixed_Value (Item); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ------------------------- + -- To_Decimal (packed) -- + ------------------------- + + function To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) return Num + is + pragma Unsuppress (Range_Check); + begin + return Num'Fixed_Value (Packed_To_Decimal (Item, Format)); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Decimal; + + ---------------- + -- To_Display -- + ---------------- + + function To_Display + (Item : Num; + Format : Display_Format) return Numeric + is + pragma Unsuppress (Range_Check); + begin + return + To_Display + (Integer_64'Integer_Value (Item), + Format, + Length (Format)); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Display; + + -------------------- + -- To_Long_Binary -- + -------------------- + + function To_Long_Binary (Item : Num) return Long_Binary is + pragma Unsuppress (Range_Check); + begin + return Long_Binary'Integer_Value (Item); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Long_Binary; + + --------------- + -- To_Packed -- + --------------- + + function To_Packed + (Item : Num; + Format : Packed_Format) return Packed_Decimal + is + pragma Unsuppress (Range_Check); + begin + return + To_Packed + (Integer_64'Integer_Value (Item), + Format, + Length (Format)); + exception + when Constraint_Error => + raise Conversion_Error; + end To_Packed; + + -------------------- + -- Valid (binary) -- + -------------------- + + function Valid + (Item : Byte_Array; + Format : Binary_Format) return Boolean + is + Val : Num; + pragma Unreferenced (Val); + begin + Val := To_Decimal (Item, Format); + return True; + exception + when Conversion_Error => + return False; + end Valid; + + --------------------- + -- Valid (display) -- + --------------------- + + function Valid + (Item : Numeric; + Format : Display_Format) return Boolean + is + begin + return Valid_Numeric (Item, Format); + end Valid; + + -------------------- + -- Valid (packed) -- + -------------------- + + function Valid + (Item : Packed_Decimal; + Format : Packed_Format) return Boolean + is + begin + return Valid_Packed (Item, Format); + end Valid; + + end Decimal_Conversions; + +end Interfaces.COBOL; diff --git a/gcc/ada/libgnat/i-cobol.ads b/gcc/ada/libgnat/i-cobol.ads new file mode 100644 index 0000000..31ef99f --- /dev/null +++ b/gcc/ada/libgnat/i-cobol.ads @@ -0,0 +1,553 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C O B O L -- +-- -- +-- S p e c -- +-- (ASCII Version) -- +-- -- +-- Copyright (C) 1993-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of the COBOL interfaces package assumes that the COBOL +-- compiler uses ASCII as its internal representation of characters, i.e. +-- that the type COBOL_Character has the same representation as the Ada +-- type Standard.Character. + +package Interfaces.COBOL is + pragma Preelaborate (COBOL); + + ------------------------------------------------------------ + -- Types And Operations For Internal Data Representations -- + ------------------------------------------------------------ + + type Floating is new Float; + type Long_Floating is new Long_Float; + + type Binary is new Integer; + type Long_Binary is new Long_Long_Integer; + + Max_Digits_Binary : constant := 9; + Max_Digits_Long_Binary : constant := 18; + + type Decimal_Element is mod 2**4; + type Packed_Decimal is array (Positive range <>) of Decimal_Element; + pragma Pack (Packed_Decimal); + + type COBOL_Character is new Character; + + Ada_To_COBOL : array (Standard.Character) of COBOL_Character := ( + COBOL_Character'Val (000), COBOL_Character'Val (001), + COBOL_Character'Val (002), COBOL_Character'Val (003), + COBOL_Character'Val (004), COBOL_Character'Val (005), + COBOL_Character'Val (006), COBOL_Character'Val (007), + COBOL_Character'Val (008), COBOL_Character'Val (009), + COBOL_Character'Val (010), COBOL_Character'Val (011), + COBOL_Character'Val (012), COBOL_Character'Val (013), + COBOL_Character'Val (014), COBOL_Character'Val (015), + COBOL_Character'Val (016), COBOL_Character'Val (017), + COBOL_Character'Val (018), COBOL_Character'Val (019), + COBOL_Character'Val (020), COBOL_Character'Val (021), + COBOL_Character'Val (022), COBOL_Character'Val (023), + COBOL_Character'Val (024), COBOL_Character'Val (025), + COBOL_Character'Val (026), COBOL_Character'Val (027), + COBOL_Character'Val (028), COBOL_Character'Val (029), + COBOL_Character'Val (030), COBOL_Character'Val (031), + COBOL_Character'Val (032), COBOL_Character'Val (033), + COBOL_Character'Val (034), COBOL_Character'Val (035), + COBOL_Character'Val (036), COBOL_Character'Val (037), + COBOL_Character'Val (038), COBOL_Character'Val (039), + COBOL_Character'Val (040), COBOL_Character'Val (041), + COBOL_Character'Val (042), COBOL_Character'Val (043), + COBOL_Character'Val (044), COBOL_Character'Val (045), + COBOL_Character'Val (046), COBOL_Character'Val (047), + COBOL_Character'Val (048), COBOL_Character'Val (049), + COBOL_Character'Val (050), COBOL_Character'Val (051), + COBOL_Character'Val (052), COBOL_Character'Val (053), + COBOL_Character'Val (054), COBOL_Character'Val (055), + COBOL_Character'Val (056), COBOL_Character'Val (057), + COBOL_Character'Val (058), COBOL_Character'Val (059), + COBOL_Character'Val (060), COBOL_Character'Val (061), + COBOL_Character'Val (062), COBOL_Character'Val (063), + COBOL_Character'Val (064), COBOL_Character'Val (065), + COBOL_Character'Val (066), COBOL_Character'Val (067), + COBOL_Character'Val (068), COBOL_Character'Val (069), + COBOL_Character'Val (070), COBOL_Character'Val (071), + COBOL_Character'Val (072), COBOL_Character'Val (073), + COBOL_Character'Val (074), COBOL_Character'Val (075), + COBOL_Character'Val (076), COBOL_Character'Val (077), + COBOL_Character'Val (078), COBOL_Character'Val (079), + COBOL_Character'Val (080), COBOL_Character'Val (081), + COBOL_Character'Val (082), COBOL_Character'Val (083), + COBOL_Character'Val (084), COBOL_Character'Val (085), + COBOL_Character'Val (086), COBOL_Character'Val (087), + COBOL_Character'Val (088), COBOL_Character'Val (089), + COBOL_Character'Val (090), COBOL_Character'Val (091), + COBOL_Character'Val (092), COBOL_Character'Val (093), + COBOL_Character'Val (094), COBOL_Character'Val (095), + COBOL_Character'Val (096), COBOL_Character'Val (097), + COBOL_Character'Val (098), COBOL_Character'Val (099), + COBOL_Character'Val (100), COBOL_Character'Val (101), + COBOL_Character'Val (102), COBOL_Character'Val (103), + COBOL_Character'Val (104), COBOL_Character'Val (105), + COBOL_Character'Val (106), COBOL_Character'Val (107), + COBOL_Character'Val (108), COBOL_Character'Val (109), + COBOL_Character'Val (110), COBOL_Character'Val (111), + COBOL_Character'Val (112), COBOL_Character'Val (113), + COBOL_Character'Val (114), COBOL_Character'Val (115), + COBOL_Character'Val (116), COBOL_Character'Val (117), + COBOL_Character'Val (118), COBOL_Character'Val (119), + COBOL_Character'Val (120), COBOL_Character'Val (121), + COBOL_Character'Val (122), COBOL_Character'Val (123), + COBOL_Character'Val (124), COBOL_Character'Val (125), + COBOL_Character'Val (126), COBOL_Character'Val (127), + COBOL_Character'Val (128), COBOL_Character'Val (129), + COBOL_Character'Val (130), COBOL_Character'Val (131), + COBOL_Character'Val (132), COBOL_Character'Val (133), + COBOL_Character'Val (134), COBOL_Character'Val (135), + COBOL_Character'Val (136), COBOL_Character'Val (137), + COBOL_Character'Val (138), COBOL_Character'Val (139), + COBOL_Character'Val (140), COBOL_Character'Val (141), + COBOL_Character'Val (142), COBOL_Character'Val (143), + COBOL_Character'Val (144), COBOL_Character'Val (145), + COBOL_Character'Val (146), COBOL_Character'Val (147), + COBOL_Character'Val (148), COBOL_Character'Val (149), + COBOL_Character'Val (150), COBOL_Character'Val (151), + COBOL_Character'Val (152), COBOL_Character'Val (153), + COBOL_Character'Val (154), COBOL_Character'Val (155), + COBOL_Character'Val (156), COBOL_Character'Val (157), + COBOL_Character'Val (158), COBOL_Character'Val (159), + COBOL_Character'Val (160), COBOL_Character'Val (161), + COBOL_Character'Val (162), COBOL_Character'Val (163), + COBOL_Character'Val (164), COBOL_Character'Val (165), + COBOL_Character'Val (166), COBOL_Character'Val (167), + COBOL_Character'Val (168), COBOL_Character'Val (169), + COBOL_Character'Val (170), COBOL_Character'Val (171), + COBOL_Character'Val (172), COBOL_Character'Val (173), + COBOL_Character'Val (174), COBOL_Character'Val (175), + COBOL_Character'Val (176), COBOL_Character'Val (177), + COBOL_Character'Val (178), COBOL_Character'Val (179), + COBOL_Character'Val (180), COBOL_Character'Val (181), + COBOL_Character'Val (182), COBOL_Character'Val (183), + COBOL_Character'Val (184), COBOL_Character'Val (185), + COBOL_Character'Val (186), COBOL_Character'Val (187), + COBOL_Character'Val (188), COBOL_Character'Val (189), + COBOL_Character'Val (190), COBOL_Character'Val (191), + COBOL_Character'Val (192), COBOL_Character'Val (193), + COBOL_Character'Val (194), COBOL_Character'Val (195), + COBOL_Character'Val (196), COBOL_Character'Val (197), + COBOL_Character'Val (198), COBOL_Character'Val (199), + COBOL_Character'Val (200), COBOL_Character'Val (201), + COBOL_Character'Val (202), COBOL_Character'Val (203), + COBOL_Character'Val (204), COBOL_Character'Val (205), + COBOL_Character'Val (206), COBOL_Character'Val (207), + COBOL_Character'Val (208), COBOL_Character'Val (209), + COBOL_Character'Val (210), COBOL_Character'Val (211), + COBOL_Character'Val (212), COBOL_Character'Val (213), + COBOL_Character'Val (214), COBOL_Character'Val (215), + COBOL_Character'Val (216), COBOL_Character'Val (217), + COBOL_Character'Val (218), COBOL_Character'Val (219), + COBOL_Character'Val (220), COBOL_Character'Val (221), + COBOL_Character'Val (222), COBOL_Character'Val (223), + COBOL_Character'Val (224), COBOL_Character'Val (225), + COBOL_Character'Val (226), COBOL_Character'Val (227), + COBOL_Character'Val (228), COBOL_Character'Val (229), + COBOL_Character'Val (230), COBOL_Character'Val (231), + COBOL_Character'Val (232), COBOL_Character'Val (233), + COBOL_Character'Val (234), COBOL_Character'Val (235), + COBOL_Character'Val (236), COBOL_Character'Val (237), + COBOL_Character'Val (238), COBOL_Character'Val (239), + COBOL_Character'Val (240), COBOL_Character'Val (241), + COBOL_Character'Val (242), COBOL_Character'Val (243), + COBOL_Character'Val (244), COBOL_Character'Val (245), + COBOL_Character'Val (246), COBOL_Character'Val (247), + COBOL_Character'Val (248), COBOL_Character'Val (249), + COBOL_Character'Val (250), COBOL_Character'Val (251), + COBOL_Character'Val (252), COBOL_Character'Val (253), + COBOL_Character'Val (254), COBOL_Character'Val (255)); + + COBOL_To_Ada : array (COBOL_Character) of Standard.Character := ( + Standard.Character'Val (000), Standard.Character'Val (001), + Standard.Character'Val (002), Standard.Character'Val (003), + Standard.Character'Val (004), Standard.Character'Val (005), + Standard.Character'Val (006), Standard.Character'Val (007), + Standard.Character'Val (008), Standard.Character'Val (009), + Standard.Character'Val (010), Standard.Character'Val (011), + Standard.Character'Val (012), Standard.Character'Val (013), + Standard.Character'Val (014), Standard.Character'Val (015), + Standard.Character'Val (016), Standard.Character'Val (017), + Standard.Character'Val (018), Standard.Character'Val (019), + Standard.Character'Val (020), Standard.Character'Val (021), + Standard.Character'Val (022), Standard.Character'Val (023), + Standard.Character'Val (024), Standard.Character'Val (025), + Standard.Character'Val (026), Standard.Character'Val (027), + Standard.Character'Val (028), Standard.Character'Val (029), + Standard.Character'Val (030), Standard.Character'Val (031), + Standard.Character'Val (032), Standard.Character'Val (033), + Standard.Character'Val (034), Standard.Character'Val (035), + Standard.Character'Val (036), Standard.Character'Val (037), + Standard.Character'Val (038), Standard.Character'Val (039), + Standard.Character'Val (040), Standard.Character'Val (041), + Standard.Character'Val (042), Standard.Character'Val (043), + Standard.Character'Val (044), Standard.Character'Val (045), + Standard.Character'Val (046), Standard.Character'Val (047), + Standard.Character'Val (048), Standard.Character'Val (049), + Standard.Character'Val (050), Standard.Character'Val (051), + Standard.Character'Val (052), Standard.Character'Val (053), + Standard.Character'Val (054), Standard.Character'Val (055), + Standard.Character'Val (056), Standard.Character'Val (057), + Standard.Character'Val (058), Standard.Character'Val (059), + Standard.Character'Val (060), Standard.Character'Val (061), + Standard.Character'Val (062), Standard.Character'Val (063), + Standard.Character'Val (064), Standard.Character'Val (065), + Standard.Character'Val (066), Standard.Character'Val (067), + Standard.Character'Val (068), Standard.Character'Val (069), + Standard.Character'Val (070), Standard.Character'Val (071), + Standard.Character'Val (072), Standard.Character'Val (073), + Standard.Character'Val (074), Standard.Character'Val (075), + Standard.Character'Val (076), Standard.Character'Val (077), + Standard.Character'Val (078), Standard.Character'Val (079), + Standard.Character'Val (080), Standard.Character'Val (081), + Standard.Character'Val (082), Standard.Character'Val (083), + Standard.Character'Val (084), Standard.Character'Val (085), + Standard.Character'Val (086), Standard.Character'Val (087), + Standard.Character'Val (088), Standard.Character'Val (089), + Standard.Character'Val (090), Standard.Character'Val (091), + Standard.Character'Val (092), Standard.Character'Val (093), + Standard.Character'Val (094), Standard.Character'Val (095), + Standard.Character'Val (096), Standard.Character'Val (097), + Standard.Character'Val (098), Standard.Character'Val (099), + Standard.Character'Val (100), Standard.Character'Val (101), + Standard.Character'Val (102), Standard.Character'Val (103), + Standard.Character'Val (104), Standard.Character'Val (105), + Standard.Character'Val (106), Standard.Character'Val (107), + Standard.Character'Val (108), Standard.Character'Val (109), + Standard.Character'Val (110), Standard.Character'Val (111), + Standard.Character'Val (112), Standard.Character'Val (113), + Standard.Character'Val (114), Standard.Character'Val (115), + Standard.Character'Val (116), Standard.Character'Val (117), + Standard.Character'Val (118), Standard.Character'Val (119), + Standard.Character'Val (120), Standard.Character'Val (121), + Standard.Character'Val (122), Standard.Character'Val (123), + Standard.Character'Val (124), Standard.Character'Val (125), + Standard.Character'Val (126), Standard.Character'Val (127), + Standard.Character'Val (128), Standard.Character'Val (129), + Standard.Character'Val (130), Standard.Character'Val (131), + Standard.Character'Val (132), Standard.Character'Val (133), + Standard.Character'Val (134), Standard.Character'Val (135), + Standard.Character'Val (136), Standard.Character'Val (137), + Standard.Character'Val (138), Standard.Character'Val (139), + Standard.Character'Val (140), Standard.Character'Val (141), + Standard.Character'Val (142), Standard.Character'Val (143), + Standard.Character'Val (144), Standard.Character'Val (145), + Standard.Character'Val (146), Standard.Character'Val (147), + Standard.Character'Val (148), Standard.Character'Val (149), + Standard.Character'Val (150), Standard.Character'Val (151), + Standard.Character'Val (152), Standard.Character'Val (153), + Standard.Character'Val (154), Standard.Character'Val (155), + Standard.Character'Val (156), Standard.Character'Val (157), + Standard.Character'Val (158), Standard.Character'Val (159), + Standard.Character'Val (160), Standard.Character'Val (161), + Standard.Character'Val (162), Standard.Character'Val (163), + Standard.Character'Val (164), Standard.Character'Val (165), + Standard.Character'Val (166), Standard.Character'Val (167), + Standard.Character'Val (168), Standard.Character'Val (169), + Standard.Character'Val (170), Standard.Character'Val (171), + Standard.Character'Val (172), Standard.Character'Val (173), + Standard.Character'Val (174), Standard.Character'Val (175), + Standard.Character'Val (176), Standard.Character'Val (177), + Standard.Character'Val (178), Standard.Character'Val (179), + Standard.Character'Val (180), Standard.Character'Val (181), + Standard.Character'Val (182), Standard.Character'Val (183), + Standard.Character'Val (184), Standard.Character'Val (185), + Standard.Character'Val (186), Standard.Character'Val (187), + Standard.Character'Val (188), Standard.Character'Val (189), + Standard.Character'Val (190), Standard.Character'Val (191), + Standard.Character'Val (192), Standard.Character'Val (193), + Standard.Character'Val (194), Standard.Character'Val (195), + Standard.Character'Val (196), Standard.Character'Val (197), + Standard.Character'Val (198), Standard.Character'Val (199), + Standard.Character'Val (200), Standard.Character'Val (201), + Standard.Character'Val (202), Standard.Character'Val (203), + Standard.Character'Val (204), Standard.Character'Val (205), + Standard.Character'Val (206), Standard.Character'Val (207), + Standard.Character'Val (208), Standard.Character'Val (209), + Standard.Character'Val (210), Standard.Character'Val (211), + Standard.Character'Val (212), Standard.Character'Val (213), + Standard.Character'Val (214), Standard.Character'Val (215), + Standard.Character'Val (216), Standard.Character'Val (217), + Standard.Character'Val (218), Standard.Character'Val (219), + Standard.Character'Val (220), Standard.Character'Val (221), + Standard.Character'Val (222), Standard.Character'Val (223), + Standard.Character'Val (224), Standard.Character'Val (225), + Standard.Character'Val (226), Standard.Character'Val (227), + Standard.Character'Val (228), Standard.Character'Val (229), + Standard.Character'Val (230), Standard.Character'Val (231), + Standard.Character'Val (232), Standard.Character'Val (233), + Standard.Character'Val (234), Standard.Character'Val (235), + Standard.Character'Val (236), Standard.Character'Val (237), + Standard.Character'Val (238), Standard.Character'Val (239), + Standard.Character'Val (240), Standard.Character'Val (241), + Standard.Character'Val (242), Standard.Character'Val (243), + Standard.Character'Val (244), Standard.Character'Val (245), + Standard.Character'Val (246), Standard.Character'Val (247), + Standard.Character'Val (248), Standard.Character'Val (249), + Standard.Character'Val (250), Standard.Character'Val (251), + Standard.Character'Val (252), Standard.Character'Val (253), + Standard.Character'Val (254), Standard.Character'Val (255)); + + type Alphanumeric is array (Positive range <>) of COBOL_Character; + -- pragma Pack (Alphanumeric); + + function To_COBOL (Item : String) return Alphanumeric; + function To_Ada (Item : Alphanumeric) return String; + + procedure To_COBOL + (Item : String; + Target : out Alphanumeric; + Last : out Natural); + + procedure To_Ada + (Item : Alphanumeric; + Target : out String; + Last : out Natural); + + type Numeric is array (Positive range <>) of COBOL_Character; + -- pragma Pack (Numeric); + + -------------------------------------------- + -- Formats For COBOL Data Representations -- + -------------------------------------------- + + type Display_Format is private; + + Unsigned : constant Display_Format; + Leading_Separate : constant Display_Format; + Trailing_Separate : constant Display_Format; + Leading_Nonseparate : constant Display_Format; + Trailing_Nonseparate : constant Display_Format; + + type Binary_Format is private; + + High_Order_First : constant Binary_Format; + Low_Order_First : constant Binary_Format; + Native_Binary : constant Binary_Format; + High_Order_First_Unsigned : constant Binary_Format; + Low_Order_First_Unsigned : constant Binary_Format; + Native_Binary_Unsigned : constant Binary_Format; + + type Packed_Format is private; + + Packed_Unsigned : constant Packed_Format; + Packed_Signed : constant Packed_Format; + + ------------------------------------------------------------ + -- Types For External Representation Of COBOL Binary Data -- + ------------------------------------------------------------ + + type Byte is mod 2 ** COBOL_Character'Size; + type Byte_Array is array (Positive range <>) of Byte; + -- pragma Pack (Byte_Array); + + Conversion_Error : exception; + + generic + type Num is delta <> digits <>; + + package Decimal_Conversions is + + -- Display Formats: data values are represented as Numeric + + function Valid + (Item : Numeric; + Format : Display_Format) return Boolean; + + function Length + (Format : Display_Format) return Natural; + + function To_Decimal + (Item : Numeric; + Format : Display_Format) + return Num; + + function To_Display + (Item : Num; + Format : Display_Format) return Numeric; + + -- Packed Formats: data values are represented as Packed_Decimal + + function Valid + (Item : Packed_Decimal; + Format : Packed_Format) return Boolean; + + function Length + (Format : Packed_Format) return Natural; + + function To_Decimal + (Item : Packed_Decimal; + Format : Packed_Format) return Num; + + function To_Packed + (Item : Num; + Format : Packed_Format) return Packed_Decimal; + + -- Binary Formats: external data values are represented as Byte_Array + + function Valid + (Item : Byte_Array; + Format : Binary_Format) return Boolean; + + function Length + (Format : Binary_Format) + return Natural; + + function To_Decimal + (Item : Byte_Array; + Format : Binary_Format) return Num; + + function To_Binary + (Item : Num; + Format : Binary_Format) return Byte_Array; + + -- Internal Binary formats: data values are of type Binary/Long_Binary + + function To_Decimal (Item : Binary) return Num; + function To_Decimal (Item : Long_Binary) return Num; + + function To_Binary (Item : Num) return Binary; + function To_Long_Binary (Item : Num) return Long_Binary; + + private + pragma Inline (Length); + pragma Inline (To_Binary); + pragma Inline (To_Decimal); + pragma Inline (To_Display); + pragma Inline (To_Long_Binary); + pragma Inline (Valid); + + end Decimal_Conversions; + + ------------------------------------------ + -- Implementation Dependent Definitions -- + ------------------------------------------ + + -- The implementation dependent definitions are wholly contained in the + -- private part of this spec (the body is implementation independent) + +private + ------------------- + -- Binary Format -- + ------------------- + + type Binary_Format is (H, L, N, HU, LU, NU); + + subtype Binary_Unsigned_Format is Binary_Format range HU .. NU; + + High_Order_First : constant Binary_Format := H; + Low_Order_First : constant Binary_Format := L; + Native_Binary : constant Binary_Format := N; + High_Order_First_Unsigned : constant Binary_Format := HU; + Low_Order_First_Unsigned : constant Binary_Format := LU; + Native_Binary_Unsigned : constant Binary_Format := NU; + + --------------------------- + -- Packed Decimal Format -- + --------------------------- + + -- Packed decimal numbers use the IBM mainframe format: + + -- dd dd ... dd dd ds + + -- where d are the Digits, in natural left to right order, and s is + -- the sign digit. If the number of Digits os even, then the high + -- order (leftmost) Digits is always a 0. For example, a six digit + -- number has the format: + + -- 0d dd dd ds + + -- The sign digit has the possible values + + -- 16#0A# non-standard plus sign + -- 16#0B# non-standard minus sign + -- 16#0C# standard plus sign + -- 16#0D# standard minus sign + -- 16#0E# non-standard plus sign + -- 16#0F# standard unsigned sign + + -- The non-standard signs are recognized on input, but never generated + -- for output numbers. The 16#0F# distinguishes unsigned numbers from + -- signed positive numbers, but is treated as positive for computational + -- purposes. This format provides distinguished positive and negative + -- zero values, which behave the same in all operations. + + type Packed_Format is (U, S); + + Packed_Unsigned : constant Packed_Format := U; + Packed_Signed : constant Packed_Format := S; + + type Packed_Representation_Type is (IBM); + -- Indicator for format used for packed decimal + + Packed_Representation : constant Packed_Representation_Type := IBM; + -- This version of the spec uses IBM internal format, as described above + + ----------------------------- + -- Display Decimal Formats -- + ----------------------------- + + -- Display numbers are stored in standard ASCII format, as ASCII strings. + -- For the embedded signs, the following codes are used: + + -- 0-9 positive: 16#30# .. 16#39# (i.e. natural ASCII digit code) + -- 0-9 negative: 16#20# .. 16#29# (ASCII digit code - 16#10#) + + type Display_Format is (U, LS, TS, LN, TN); + + Unsigned : constant Display_Format := U; + Leading_Separate : constant Display_Format := LS; + Trailing_Separate : constant Display_Format := TS; + Leading_Nonseparate : constant Display_Format := LN; + Trailing_Nonseparate : constant Display_Format := TN; + + subtype COBOL_Digits is COBOL_Character range '0' .. '9'; + -- Digit values in display decimal + + COBOL_Space : constant COBOL_Character := ' '; + COBOL_Plus : constant COBOL_Character := '+'; + COBOL_Minus : constant COBOL_Character := '-'; + -- Sign values for Leading_Separate and Trailing_Separate formats + + subtype COBOL_Plus_Digits is COBOL_Character + range COBOL_Character'Val (16#30#) .. COBOL_Character'Val (16#39#); + -- Values used for embedded plus signs in nonseparate formats + + subtype COBOL_Minus_Digits is COBOL_Character + range COBOL_Character'Val (16#20#) .. COBOL_Character'Val (16#29#); + -- Values used for embedded minus signs in nonseparate formats + +end Interfaces.COBOL; diff --git a/gcc/ada/libgnat/i-cpoint.adb b/gcc/ada/libgnat/i-cpoint.adb new file mode 100644 index 0000000..6bb8620 --- /dev/null +++ b/gcc/ada/libgnat/i-cpoint.adb @@ -0,0 +1,295 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . P O I N T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C.Strings; use Interfaces.C.Strings; +with System; use System; + +with Ada.Unchecked_Conversion; + +package body Interfaces.C.Pointers is + + type Addr is mod 2 ** System.Parameters.ptr_bits; + + function To_Pointer is new Ada.Unchecked_Conversion (Addr, Pointer); + function To_Addr is new Ada.Unchecked_Conversion (Pointer, Addr); + function To_Addr is new Ada.Unchecked_Conversion (ptrdiff_t, Addr); + function To_Ptrdiff is new Ada.Unchecked_Conversion (Addr, ptrdiff_t); + + Elmt_Size : constant ptrdiff_t := + (Element_Array'Component_Size + + Storage_Unit - 1) / Storage_Unit; + + subtype Index_Base is Index'Base; + + --------- + -- "+" -- + --------- + + function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer is + begin + if Left = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Left) + To_Addr (Elmt_Size * Right)); + end "+"; + + function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer is + begin + if Right = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Elmt_Size * Left) + To_Addr (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer is + begin + if Left = null then + raise Pointer_Error; + end if; + + return To_Pointer (To_Addr (Left) - To_Addr (Right * Elmt_Size)); + end "-"; + + function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t is + begin + if Left = null or else Right = null then + raise Pointer_Error; + end if; + + return To_Ptrdiff (To_Addr (Left) - To_Addr (Right)) / Elmt_Size; + end "-"; + + ---------------- + -- Copy_Array -- + ---------------- + + procedure Copy_Array + (Source : Pointer; + Target : Pointer; + Length : ptrdiff_t) + is + T : Pointer; + S : Pointer; + + begin + if Source = null or else Target = null then + raise Dereference_Error; + + -- Forward copy + + elsif To_Addr (Target) <= To_Addr (Source) then + T := Target; + S := Source; + for J in 1 .. Length loop + T.all := S.all; + Increment (T); + Increment (S); + end loop; + + -- Backward copy + + else + T := Target + Length; + S := Source + Length; + for J in 1 .. Length loop + Decrement (T); + Decrement (S); + T.all := S.all; + end loop; + end if; + end Copy_Array; + + --------------------------- + -- Copy_Terminated_Array -- + --------------------------- + + procedure Copy_Terminated_Array + (Source : Pointer; + Target : Pointer; + Limit : ptrdiff_t := ptrdiff_t'Last; + Terminator : Element := Default_Terminator) + is + L : ptrdiff_t; + S : Pointer := Source; + + begin + if Source = null or Target = null then + raise Dereference_Error; + end if; + + -- Compute array limited length (including the terminator) + + L := 0; + while L < Limit loop + L := L + 1; + exit when S.all = Terminator; + Increment (S); + end loop; + + Copy_Array (Source, Target, L); + end Copy_Terminated_Array; + + --------------- + -- Decrement -- + --------------- + + procedure Decrement (Ref : in out Pointer) is + begin + Ref := Ref - 1; + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Ref : in out Pointer) is + begin + Ref := Ref + 1; + end Increment; + + ----------- + -- Value -- + ----------- + + function Value + (Ref : Pointer; + Terminator : Element := Default_Terminator) return Element_Array + is + P : Pointer; + L : constant Index_Base := Index'First; + H : Index_Base; + + begin + if Ref = null then + raise Dereference_Error; + + else + H := L; + P := Ref; + + loop + exit when P.all = Terminator; + H := Index_Base'Succ (H); + Increment (P); + end loop; + + declare + subtype A is Element_Array (L .. H); + + type PA is access A; + for PA'Size use System.Parameters.ptr_bits; + function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); + + begin + return To_PA (Ref).all; + end; + end if; + end Value; + + function Value + (Ref : Pointer; + Length : ptrdiff_t) return Element_Array + is + L : Index_Base; + H : Index_Base; + + begin + if Ref = null then + raise Dereference_Error; + + -- For length zero, we need to return a null slice, but we can't make + -- the bounds of this slice Index'First, since this could cause a + -- Constraint_Error if Index'First = Index'Base'First. + + elsif Length <= 0 then + declare + pragma Warnings (Off); -- kill warnings since X not assigned + X : Element_Array (Index'Succ (Index'First) .. Index'First); + pragma Warnings (On); + + begin + return X; + end; + + -- Normal case (length non-zero) + + else + L := Index'First; + H := Index'Val (Index'Pos (Index'First) + Length - 1); + + declare + subtype A is Element_Array (L .. H); + + type PA is access A; + for PA'Size use System.Parameters.ptr_bits; + function To_PA is new Ada.Unchecked_Conversion (Pointer, PA); + + begin + return To_PA (Ref).all; + end; + end if; + end Value; + + -------------------- + -- Virtual_Length -- + -------------------- + + function Virtual_Length + (Ref : Pointer; + Terminator : Element := Default_Terminator) return ptrdiff_t + is + P : Pointer; + C : ptrdiff_t; + + begin + if Ref = null then + raise Dereference_Error; + + else + C := 0; + P := Ref; + + while P.all /= Terminator loop + C := C + 1; + Increment (P); + end loop; + + return C; + end if; + end Virtual_Length; + +end Interfaces.C.Pointers; diff --git a/gcc/ada/libgnat/i-cpoint.ads b/gcc/ada/libgnat/i-cpoint.ads new file mode 100644 index 0000000..83eb31d --- /dev/null +++ b/gcc/ada/libgnat/i-cpoint.ads @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . P O I N T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1993-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Parameters; + +generic + type Index is (<>); + type Element is private; + type Element_Array is array (Index range <>) of aliased Element; + Default_Terminator : Element; + +package Interfaces.C.Pointers is + pragma Preelaborate; + + type Pointer is access all Element; + for Pointer'Size use System.Parameters.ptr_bits; + + pragma No_Strict_Aliasing (Pointer); + -- We turn off any strict aliasing assumptions for the pointer type, + -- since it is possible to create "improperly" aliased values. + + function Value + (Ref : Pointer; + Terminator : Element := Default_Terminator) return Element_Array; + + function Value + (Ref : Pointer; + Length : ptrdiff_t) return Element_Array; + + Pointer_Error : exception; + + -------------------------------- + -- C-style Pointer Arithmetic -- + -------------------------------- + + function "+" (Left : Pointer; Right : ptrdiff_t) return Pointer; + function "+" (Left : ptrdiff_t; Right : Pointer) return Pointer; + function "-" (Left : Pointer; Right : ptrdiff_t) return Pointer; + function "-" (Left : Pointer; Right : Pointer) return ptrdiff_t; + + procedure Increment (Ref : in out Pointer); + procedure Decrement (Ref : in out Pointer); + + pragma Convention (Intrinsic, "+"); + pragma Convention (Intrinsic, "-"); + pragma Convention (Intrinsic, Increment); + pragma Convention (Intrinsic, Decrement); + + function Virtual_Length + (Ref : Pointer; + Terminator : Element := Default_Terminator) return ptrdiff_t; + + procedure Copy_Terminated_Array + (Source : Pointer; + Target : Pointer; + Limit : ptrdiff_t := ptrdiff_t'Last; + Terminator : Element := Default_Terminator); + + procedure Copy_Array + (Source : Pointer; + Target : Pointer; + Length : ptrdiff_t); + +private + pragma Inline ("+"); + pragma Inline ("-"); + pragma Inline (Decrement); + pragma Inline (Increment); + +end Interfaces.C.Pointers; diff --git a/gcc/ada/libgnat/i-cstrea.adb b/gcc/ada/libgnat/i-cstrea.adb new file mode 100644 index 0000000..a6ece87 --- /dev/null +++ b/gcc/ada/libgnat/i-cstrea.adb @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C _ S T R E A M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body Interfaces.C_Streams is + + use type System.CRTL.size_t; + + ---------------------------- + -- Interfaced C functions -- + ---------------------------- + + function C_fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + pragma Import (C, C_fread, "fread"); + + function C_fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + pragma Import (C, C_fwrite, "fwrite"); + + function C_setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int; + pragma Import (C, C_setvbuf, "setvbuf"); + + ------------ + -- fread -- + ------------ + + function fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + begin + return C_fread (buffer, size, count, stream); + end fread; + + ------------ + -- fread -- + ------------ + + -- The following declarations should really be nested within fread, but + -- limitations in front end inlining make this undesirable right now ??? + + type Byte_Buffer is array (0 .. size_t'Last / 2 - 1) of Unsigned_8; + -- This should really be 0 .. size_t'last, but there is a problem + -- in gigi in handling such types (introduced in GCC 3 Sep 2001) + -- since the size in bytes of this array overflows ??? + + type Acc_Bytes is access all Byte_Buffer; + + function To_Acc_Bytes is new Ada.Unchecked_Conversion (voids, Acc_Bytes); + + function fread + (buffer : voids; + index : size_t; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + begin + return C_fread + (To_Acc_Bytes (buffer) (index * size)'Address, size, count, stream); + end fread; + + ------------ + -- fwrite -- + ------------ + + function fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t + is + begin + return C_fwrite (buffer, size, count, stream); + end fwrite; + + ------------- + -- setvbuf -- + ------------- + + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int + is + begin + return C_setvbuf (stream, buffer, mode, size); + end setvbuf; + +end Interfaces.C_Streams; diff --git a/gcc/ada/libgnat/i-cstrea.ads b/gcc/ada/libgnat/i-cstrea.ads new file mode 100644 index 0000000..21fc166 --- /dev/null +++ b/gcc/ada/libgnat/i-cstrea.ads @@ -0,0 +1,315 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C _ S T R E A M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is a thin binding to selected functions in the C +-- library that provide a complete interface for handling C streams. + +with System.CRTL; + +package Interfaces.C_Streams is + pragma Preelaborate; + + subtype chars is System.CRTL.chars; + subtype FILEs is System.CRTL.FILEs; + subtype int is System.CRTL.int; + subtype long is System.CRTL.long; + subtype size_t is System.CRTL.size_t; + subtype ssize_t is System.CRTL.ssize_t; + subtype int64 is System.CRTL.int64; + subtype voids is System.Address; + + NULL_Stream : constant FILEs; + -- Value returned (NULL in C) to indicate an fdopen/fopen/tmpfile error + + ---------------------------------- + -- Constants Defined in stdio.h -- + ---------------------------------- + + EOF : constant int; + -- Used by a number of routines to indicate error or end of file + + IOFBF : constant int; + IOLBF : constant int; + IONBF : constant int; + -- Used to indicate buffering mode for setvbuf call + + L_tmpnam : constant int; + -- Maximum length of file name that can be returned by tmpnam + + SEEK_CUR : constant int; + SEEK_END : constant int; + SEEK_SET : constant int; + -- Used to indicate origin for fseek call + + function stdin return FILEs; + function stdout return FILEs; + function stderr return FILEs; + -- Streams associated with standard files + + -------------------------- + -- Standard C functions -- + -------------------------- + + -- The functions selected below are ones that are available in + -- UNIX (but not necessarily in ANSI C). These are very thin + -- interfaces which copy exactly the C headers. For more + -- documentation on these functions, see the Microsoft C "Run-Time + -- Library Reference" (Microsoft Press, 1990, ISBN 1-55615-225-6), + -- which includes useful information on system compatibility. + + procedure clearerr (stream : FILEs) renames System.CRTL.clearerr; + + function fclose (stream : FILEs) return int renames System.CRTL.fclose; + + function fdopen (handle : int; mode : chars) return FILEs + renames System.CRTL.fdopen; + + function feof (stream : FILEs) return int; + + function ferror (stream : FILEs) return int; + + function fflush (stream : FILEs) return int renames System.CRTL.fflush; + + function fgetc (stream : FILEs) return int renames System.CRTL.fgetc; + + function fgets (strng : chars; n : int; stream : FILEs) return chars + renames System.CRTL.fgets; + + function fileno (stream : FILEs) return int; + + function fopen + (filename : chars; + mode : chars; + encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) + return FILEs renames System.CRTL.fopen; + -- Note: to maintain target independence, use text_translation_required, + -- a boolean variable defined in sysdep.c to deal with the target + -- dependent text translation requirement. If this variable is set, + -- then b/t should be appended to the standard mode argument to set + -- the text translation mode off or on as required. + + function fputc (C : int; stream : FILEs) return int + renames System.CRTL.fputc; + + function fputwc (C : int; stream : FILEs) return int + renames System.CRTL.fputwc; + + function fputs (Strng : chars; Stream : FILEs) return int + renames System.CRTL.fputs; + + function fread + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + + function fread + (buffer : voids; + index : size_t; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + -- Same as normal fread, but has a parameter 'index' that indicates + -- the starting index for the read within 'buffer' (which must be the + -- address of the beginning of a whole array object with an assumed + -- zero base). This is needed for systems that do not support taking + -- the address of an element within an array. + + function freopen + (filename : chars; + mode : chars; + stream : FILEs; + encoding : System.CRTL.Filename_Encoding := System.CRTL.UTF8) + return FILEs renames System.CRTL.freopen; + + function fseek + (stream : FILEs; + offset : long; + origin : int) return int + renames System.CRTL.fseek; + + function fseek64 + (stream : FILEs; + offset : int64; + origin : int) return int + renames System.CRTL.fseek64; + + function ftell (stream : FILEs) return long + renames System.CRTL.ftell; + + function ftell64 (stream : FILEs) return int64 + renames System.CRTL.ftell64; + + function fwrite + (buffer : voids; + size : size_t; + count : size_t; + stream : FILEs) return size_t; + + function isatty (handle : int) return int renames System.CRTL.isatty; + + procedure mktemp (template : chars) renames System.CRTL.mktemp; + -- The return value (which is just a pointer to template) is discarded + + procedure rewind (stream : FILEs) renames System.CRTL.rewind; + + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int; + + procedure tmpnam (str : chars) renames System.CRTL.tmpnam; + -- The parameter must be a pointer to a string buffer of at least L_tmpnam + -- bytes (the call with a null parameter is not supported). The returned + -- value, which is just a copy of the input argument, is discarded. + + function tmpfile return FILEs renames System.CRTL.tmpfile; + + function ungetc (c : int; stream : FILEs) return int + renames System.CRTL.ungetc; + + function unlink (filename : chars) return int + renames System.CRTL.unlink; + + --------------------- + -- Extra functions -- + --------------------- + + -- These functions supply slightly thicker bindings than those above. + -- They are derived from functions in the C Run-Time Library, but may + -- do a bit more work than just directly calling one of the Library + -- functions. + + function file_exists (name : chars) return int; + -- Tests if given name corresponds to an existing file + + function is_regular_file (handle : int) return int; + -- Tests if given handle is for a regular file (result 1) or for a + -- non-regular file (pipe or device, result 0). + + --------------------------------- + -- Control of Text/Binary Mode -- + --------------------------------- + + procedure set_binary_mode (handle : int); + procedure set_text_mode (handle : int); + -- If text_translation_required is true, then these two functions may + -- be used to dynamically switch a file from binary to text mode or vice + -- versa. These functions have no effect if text_translation_required is + -- false (e.g. in normal unix mode). Use fileno to get a stream handle. + + type Content_Encoding is (None, Default_Text, Text, U8text, Wtext, U16text); + for Content_Encoding use (0, 1, 2, 3, 4, 5); + pragma Convention (C, Content_Encoding); + -- Content_Encoding describes the text encoding for file content: + -- None : No text encoding, this file is treated as a binary file + -- Default_Text : A text file but not from Text_Translation form string + -- In this mode we are eventually using the system-wide + -- translation if activated. + -- Text : Text encoding activated + -- Wtext : Unicode mode + -- U16text : Unicode UTF-16 encoding + -- U8text : Unicode UTF-8 encoding + -- + -- This encoding is system dependent and only used on Windows systems. + -- + -- Note that modifications to Content_Encoding must be synchronized with + -- sysdep.c:__gnat_set_mode. + + subtype Text_Content_Encoding + is Content_Encoding range Default_Text .. U16text; + + subtype Non_Default_Text_Content_Encoding + is Content_Encoding range Text .. U16text; + + procedure set_mode (handle : int; Mode : Content_Encoding); + -- As above but can set the handle to any mode. On Windows this can be used + -- to have proper 16-bit wide-string output on the console for example. + + ---------------------------- + -- Full Path Name support -- + ---------------------------- + + procedure full_name (nam : chars; buffer : chars); + -- Given a NUL terminated string representing a file name, returns in + -- buffer a NUL terminated string representing the full path name for + -- the file name. On systems where it is relevant the drive is also part + -- of the full path name. It is the responsibility of the caller to + -- pass an actual parameter for buffer that is big enough for any full + -- path name. Use max_path_len given below as the size of buffer. + + max_path_len : constant Integer; + -- Maximum length of an allowable full path name on the system,including a + -- terminating NUL character. Declared as a constant to allow references + -- from other preelaborated GNAT library packages. + +private + -- The following functions are specialized in the body depending on the + -- operating system. + + pragma Inline (fread); + pragma Inline (fwrite); + pragma Inline (setvbuf); + + pragma Import (C, file_exists, "__gnat_file_exists"); + pragma Import (C, is_regular_file, "__gnat_is_regular_file_fd"); + + pragma Import (C, set_binary_mode, "__gnat_set_binary_mode"); + pragma Import (C, set_text_mode, "__gnat_set_text_mode"); + pragma Import (C, set_mode, "__gnat_set_mode"); + + pragma Import (C, max_path_len, "__gnat_max_path_len"); + pragma Import (C, full_name, "__gnat_full_name"); + + -- The following may be implemented as macros, and so are supported + -- via an interface function in the a-cstrea.c file. + + pragma Import (C, feof, "__gnat_feof"); + pragma Import (C, ferror, "__gnat_ferror"); + pragma Import (C, fileno, "__gnat_fileno"); + + pragma Import (C, EOF, "__gnat_constant_eof"); + pragma Import (C, IOFBF, "__gnat_constant_iofbf"); + pragma Import (C, IOLBF, "__gnat_constant_iolbf"); + pragma Import (C, IONBF, "__gnat_constant_ionbf"); + pragma Import (C, SEEK_CUR, "__gnat_constant_seek_cur"); + pragma Import (C, SEEK_END, "__gnat_constant_seek_end"); + pragma Import (C, SEEK_SET, "__gnat_constant_seek_set"); + pragma Import (C, L_tmpnam, "__gnat_constant_l_tmpnam"); + + pragma Import (C, stderr, "__gnat_constant_stderr"); + pragma Import (C, stdin, "__gnat_constant_stdin"); + pragma Import (C, stdout, "__gnat_constant_stdout"); + + NULL_Stream : constant FILEs := System.Null_Address; + +end Interfaces.C_Streams; diff --git a/gcc/ada/libgnat/i-cstrin.adb b/gcc/ada/libgnat/i-cstrin.adb new file mode 100644 index 0000000..5a1f51b --- /dev/null +++ b/gcc/ada/libgnat/i-cstrin.adb @@ -0,0 +1,360 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . S T R I N G S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; + +with Ada.Unchecked_Conversion; + +package body Interfaces.C.Strings is + + -- Note that the type chars_ptr has a pragma No_Strict_Aliasing in the + -- spec, to prevent any assumptions about aliasing for values of this type, + -- since arbitrary addresses can be converted, and it is quite likely that + -- this type will in fact be used for aliasing values of other types. + + function To_chars_ptr is + new Ada.Unchecked_Conversion (System.Parameters.C_Address, chars_ptr); + + function To_Address is + new Ada.Unchecked_Conversion (chars_ptr, System.Parameters.C_Address); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Peek (From : chars_ptr) return char; + pragma Inline (Peek); + -- Given a chars_ptr value, obtain referenced character + + procedure Poke (Value : char; Into : chars_ptr); + pragma Inline (Poke); + -- Given a chars_ptr, modify referenced Character value + + function "+" (Left : chars_ptr; Right : size_t) return chars_ptr; + pragma Inline ("+"); + -- Address arithmetic on chars_ptr value + + function Position_Of_Nul (Into : char_array) return size_t; + -- Returns position of the first Nul in Into or Into'Last + 1 if none + + -- We can't use directly System.Memory because the categorization is not + -- compatible, so we directly import here the malloc and free routines. + + function Memory_Alloc (Size : size_t) return chars_ptr; + pragma Import (C, Memory_Alloc, System.Parameters.C_Malloc_Linkname); + + procedure Memory_Free (Address : chars_ptr); + pragma Import (C, Memory_Free, "__gnat_free"); + + --------- + -- "+" -- + --------- + + function "+" (Left : chars_ptr; Right : size_t) return chars_ptr is + begin + return To_chars_ptr (To_Address (Left) + Storage_Offset (Right)); + end "+"; + + ---------- + -- Free -- + ---------- + + procedure Free (Item : in out chars_ptr) is + begin + if Item = Null_Ptr then + return; + end if; + + Memory_Free (Item); + Item := Null_Ptr; + end Free; + + -------------------- + -- New_Char_Array -- + -------------------- + + function New_Char_Array (Chars : char_array) return chars_ptr is + Index : size_t; + Pointer : chars_ptr; + + begin + -- Get index of position of null. If Index > Chars'Last, + -- nul is absent and must be added explicitly. + + Index := Position_Of_Nul (Into => Chars); + Pointer := Memory_Alloc ((Index - Chars'First + 1)); + + -- If nul is present, transfer string up to and including nul + + if Index <= Chars'Last then + Update (Item => Pointer, + Offset => 0, + Chars => Chars (Chars'First .. Index), + Check => False); + else + -- If original string has no nul, transfer whole string and add + -- terminator explicitly. + + Update (Item => Pointer, + Offset => 0, + Chars => Chars, + Check => False); + Poke (nul, Into => Pointer + size_t'(Chars'Length)); + end if; + + return Pointer; + end New_Char_Array; + + ---------------- + -- New_String -- + ---------------- + + function New_String (Str : String) return chars_ptr is + + -- It's important that this subprogram uses the heap directly to compute + -- the result, and doesn't copy the string on the stack, otherwise its + -- use is limited when used from tasks on large strings. + + Result : constant chars_ptr := Memory_Alloc (Str'Length + 1); + + Result_Array : char_array (1 .. Str'Length + 1); + for Result_Array'Address use To_Address (Result); + pragma Import (Ada, Result_Array); + + Count : size_t; + + begin + To_C + (Item => Str, + Target => Result_Array, + Count => Count, + Append_Nul => True); + return Result; + end New_String; + + ---------- + -- Peek -- + ---------- + + function Peek (From : chars_ptr) return char is + begin + return char (From.all); + end Peek; + + ---------- + -- Poke -- + ---------- + + procedure Poke (Value : char; Into : chars_ptr) is + begin + Into.all := Character (Value); + end Poke; + + --------------------- + -- Position_Of_Nul -- + --------------------- + + function Position_Of_Nul (Into : char_array) return size_t is + begin + for J in Into'Range loop + if Into (J) = nul then + return J; + end if; + end loop; + + return Into'Last + 1; + end Position_Of_Nul; + + ------------ + -- Strlen -- + ------------ + + function Strlen (Item : chars_ptr) return size_t is + Item_Index : size_t := 0; + + begin + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + loop + if Peek (Item + Item_Index) = nul then + return Item_Index; + end if; + + Item_Index := Item_Index + 1; + end loop; + end Strlen; + + ------------------ + -- To_Chars_Ptr -- + ------------------ + + function To_Chars_Ptr + (Item : char_array_access; + Nul_Check : Boolean := False) return chars_ptr + is + begin + if Item = null then + return Null_Ptr; + elsif Nul_Check + and then Position_Of_Nul (Into => Item.all) > Item'Last + then + raise Terminator_Error; + else + return To_chars_ptr (Item (Item'First)'Address); + end if; + end To_Chars_Ptr; + + ------------ + -- Update -- + ------------ + + procedure Update + (Item : chars_ptr; + Offset : size_t; + Chars : char_array; + Check : Boolean := True) + is + Index : chars_ptr := Item + Offset; + + begin + if Check and then Offset + Chars'Length > Strlen (Item) then + raise Update_Error; + end if; + + for J in Chars'Range loop + Poke (Chars (J), Into => Index); + Index := Index + size_t'(1); + end loop; + end Update; + + procedure Update + (Item : chars_ptr; + Offset : size_t; + Str : String; + Check : Boolean := True) + is + begin + -- Note: in RM 95, the Append_Nul => False parameter is omitted. But + -- this has the unintended consequence of truncating the string after + -- an update. As discussed in Ada 2005 AI-242, this was unintended, + -- and should be corrected. Since this is a clear error, it seems + -- appropriate to apply the correction in Ada 95 mode as well. + + Update (Item, Offset, To_C (Str, Append_Nul => False), Check); + end Update; + + ----------- + -- Value -- + ----------- + + function Value (Item : chars_ptr) return char_array is + Result : char_array (0 .. Strlen (Item)); + + begin + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + -- Note that the following loop will also copy the terminating Nul + + for J in Result'Range loop + Result (J) := Peek (Item + J); + end loop; + + return Result; + end Value; + + function Value + (Item : chars_ptr; + Length : size_t) return char_array + is + begin + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + -- ACATS cxb3010 checks that Constraint_Error gets raised when Length + -- is 0. Seems better to check that Length is not null before declaring + -- an array with size_t bounds of 0 .. Length - 1 anyway. + + if Length = 0 then + raise Constraint_Error; + end if; + + declare + Result : char_array (0 .. Length - 1); + + begin + for J in Result'Range loop + Result (J) := Peek (Item + J); + + if Result (J) = nul then + return Result (0 .. J); + end if; + end loop; + + return Result; + end; + end Value; + + function Value (Item : chars_ptr) return String is + begin + return To_Ada (Value (Item)); + end Value; + + function Value (Item : chars_ptr; Length : size_t) return String is + Result : char_array (0 .. Length); + + begin + -- As per AI-00177, this is equivalent to: + + -- To_Ada (Value (Item, Length) & nul); + + if Item = Null_Ptr then + raise Dereference_Error; + end if; + + for J in 0 .. Length - 1 loop + Result (J) := Peek (Item + J); + + if Result (J) = nul then + return To_Ada (Result (0 .. J)); + end if; + end loop; + + Result (Length) := nul; + return To_Ada (Result); + end Value; + +end Interfaces.C.Strings; diff --git a/gcc/ada/libgnat/i-cstrin.ads b/gcc/ada/libgnat/i-cstrin.ads new file mode 100644 index 0000000..5ab8d66 --- /dev/null +++ b/gcc/ada/libgnat/i-cstrin.ads @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . C . S T R I N G S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1993-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package Interfaces.C.Strings is + pragma Preelaborate; + + type char_array_access is access all char_array; + for char_array_access'Size use System.Parameters.ptr_bits; + + pragma No_Strict_Aliasing (char_array_access); + -- Since this type is used for external interfacing, with the pointer + -- coming from who knows where, it seems a good idea to turn off any + -- strict aliasing assumptions for this type. + + type chars_ptr is private; + pragma Preelaborable_Initialization (chars_ptr); + + type chars_ptr_array is array (size_t range <>) of aliased chars_ptr; + + Null_Ptr : constant chars_ptr; + + function To_Chars_Ptr + (Item : char_array_access; + Nul_Check : Boolean := False) return chars_ptr; + + function New_Char_Array (Chars : char_array) return chars_ptr; + + function New_String (Str : String) return chars_ptr; + + procedure Free (Item : in out chars_ptr); + -- When deallocation is prohibited (eg: cert runtimes) this routine + -- will raise Program_Error + + Dereference_Error : exception; + + function Value (Item : chars_ptr) return char_array; + + function Value + (Item : chars_ptr; + Length : size_t) return char_array; + + function Value (Item : chars_ptr) return String; + + function Value + (Item : chars_ptr; + Length : size_t) return String; + + function Strlen (Item : chars_ptr) return size_t; + + procedure Update + (Item : chars_ptr; + Offset : size_t; + Chars : char_array; + Check : Boolean := True); + + procedure Update + (Item : chars_ptr; + Offset : size_t; + Str : String; + Check : Boolean := True); + + Update_Error : exception; + +private + type chars_ptr is access all Character; + for chars_ptr'Size use System.Parameters.ptr_bits; + + pragma No_Strict_Aliasing (chars_ptr); + -- Since this type is used for external interfacing, with the pointer + -- coming from who knows where, it seems a good idea to turn off any + -- strict aliasing assumptions for this type. + + Null_Ptr : constant chars_ptr := null; +end Interfaces.C.Strings; diff --git a/gcc/ada/libgnat/i-fortra.adb b/gcc/ada/libgnat/i-fortra.adb new file mode 100644 index 0000000..b2ead38 --- /dev/null +++ b/gcc/ada/libgnat/i-fortra.adb @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.Fortran is + + ------------ + -- To_Ada -- + ------------ + + -- Single character case + + function To_Ada (Item : Character_Set) return Character is + begin + return Character (Item); + end To_Ada; + + -- String case (function returning converted result) + + function To_Ada (Item : Fortran_Character) return String is + T : String (1 .. Item'Length); + + begin + for J in T'Range loop + T (J) := Character (Item (J - 1 + Item'First)); + end loop; + + return T; + end To_Ada; + + -- String case (procedure copying converted string to given buffer) + + procedure To_Ada + (Item : Fortran_Character; + Target : out String; + Last : out Natural) + is + begin + if Item'Length = 0 then + Last := 0; + return; + + elsif Target'Length = 0 then + raise Constraint_Error; + + else + Last := Target'First - 1; + + for J in Item'Range loop + Last := Last + 1; + + if Last > Target'Last then + raise Constraint_Error; + else + Target (Last) := Character (Item (J)); + end if; + end loop; + end if; + end To_Ada; + + ---------------- + -- To_Fortran -- + ---------------- + + -- Character case + + function To_Fortran (Item : Character) return Character_Set is + begin + return Character_Set (Item); + end To_Fortran; + + -- String case (function returning converted result) + + function To_Fortran (Item : String) return Fortran_Character is + T : Fortran_Character (1 .. Item'Length); + + begin + for J in T'Range loop + T (J) := Character_Set (Item (J - 1 + Item'First)); + end loop; + + return T; + end To_Fortran; + + -- String case (procedure copying converted string to given buffer) + + procedure To_Fortran + (Item : String; + Target : out Fortran_Character; + Last : out Natural) + is + begin + if Item'Length = 0 then + Last := 0; + return; + + elsif Target'Length = 0 then + raise Constraint_Error; + + else + Last := Target'First - 1; + + for J in Item'Range loop + Last := Last + 1; + + if Last > Target'Last then + raise Constraint_Error; + else + Target (Last) := Character_Set (Item (J)); + end if; + end loop; + end if; + end To_Fortran; + +end Interfaces.Fortran; diff --git a/gcc/ada/libgnat/i-fortra.ads b/gcc/ada/libgnat/i-fortra.ads new file mode 100644 index 0000000..5ac9113 --- /dev/null +++ b/gcc/ada/libgnat/i-fortra.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . F O R T R A N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics.Generic_Complex_Types; +pragma Elaborate_All (Ada.Numerics.Generic_Complex_Types); + +package Interfaces.Fortran is + pragma Pure; + + type Fortran_Integer is new Integer; + type Real is new Float; + type Double_Precision is new Long_Float; + + type Logical is new Boolean; + for Logical'Size use Integer'Size; + pragma Convention (Fortran, Logical); + -- As required by Fortran standard, logical allocates same space as + -- an integer. The convention is important, since in Fortran, Booleans + -- are implemented with zero/non-zero semantics for False/True, and the + -- pragma Convention (Fortran) activates the special handling required + -- in this case. + + package Single_Precision_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Real); + + package Double_Precision_Complex_Types is + new Ada.Numerics.Generic_Complex_Types (Double_Precision); + + type Complex is new Single_Precision_Complex_Types.Complex; + + type Double_Complex is new Double_Precision_Complex_Types.Complex; + + subtype Imaginary is Single_Precision_Complex_Types.Imaginary; + i : Imaginary renames Single_Precision_Complex_Types.i; + j : Imaginary renames Single_Precision_Complex_Types.j; + + type Character_Set is new Character; + + type Fortran_Character is array (Positive range <>) of Character_Set; + + -- Additional declarations as permitted by Ada 2012, p.608, paragraph 21. + -- Interoperability with Fortran 77's vendor extension using star + -- notation and Fortran 90's intrinsic types with kind=n parameter. + -- The following assumes that `n' matches the byte size, which + -- most Fortran compiler, including GCC's follow. + + type Integer_Star_1 is new Integer_8; + type Integer_Kind_1 is new Integer_8; + type Integer_Star_2 is new Integer_16; + type Integer_Kind_2 is new Integer_16; + type Integer_Star_4 is new Integer_32; + type Integer_Kind_4 is new Integer_32; + type Integer_Star_8 is new Integer_64; + type Integer_Kind_8 is new Integer_64; + + type Logical_Star_1 is new Boolean with Convention => Fortran, Size => 8; + type Logical_Star_2 is new Boolean with Convention => Fortran, Size => 16; + type Logical_Star_4 is new Boolean with Convention => Fortran, Size => 32; + type Logical_Star_8 is new Boolean with Convention => Fortran, Size => 64; + type Logical_Kind_1 is new Boolean with Convention => Fortran, Size => 8; + type Logical_Kind_2 is new Boolean with Convention => Fortran, Size => 16; + type Logical_Kind_4 is new Boolean with Convention => Fortran, Size => 32; + type Logical_Kind_8 is new Boolean with Convention => Fortran, Size => 64; + + type Real_Star_4 is new Float; + type Real_Kind_4 is new Float; + type Real_Star_8 is new Long_Float; + type Real_Kind_8 is new Long_Float; + -- In the kind syntax, n is the same as the associated real kind + + type Complex_Star_8 is new Complex; + type Complex_Kind_4 is new Complex; + type Complex_Star_16 is new Double_Complex; + type Complex_Kind_8 is new Double_Complex; + -- In the star syntax, n is twice as large (real+imaginary size) + + type Character_Kind_n is new Fortran_Character; + + function To_Fortran (Item : Character) return Character_Set; + function To_Ada (Item : Character_Set) return Character; + + function To_Fortran (Item : String) return Fortran_Character; + function To_Ada (Item : Fortran_Character) return String; + + procedure To_Fortran + (Item : String; + Target : out Fortran_Character; + Last : out Natural); + + procedure To_Ada + (Item : Fortran_Character; + Target : out String; + Last : out Natural); + +end Interfaces.Fortran; diff --git a/gcc/ada/libgnat/i-pacdec.adb b/gcc/ada/libgnat/i-pacdec.adb new file mode 100644 index 0000000..aa2f289 --- /dev/null +++ b/gcc/ada/libgnat/i-pacdec.adb @@ -0,0 +1,352 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . P A C K E D _ D E C I M A L -- +-- -- +-- B o d y -- +-- (Version for IBM Mainframe Packed Decimal Format) -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; + +with Ada.Unchecked_Conversion; + +package body Interfaces.Packed_Decimal is + + type Packed is array (Byte_Length) of Unsigned_8; + -- The type used internally to represent packed decimal + + type Packed_Ptr is access Packed; + function To_Packed_Ptr is + new Ada.Unchecked_Conversion (Address, Packed_Ptr); + + -- The following array is used to convert a value in the range 0-99 to + -- a packed decimal format with two hexadecimal nibbles. It is worth + -- using table look up in this direction because divides are expensive. + + Packed_Byte : constant array (00 .. 99) of Unsigned_8 := + (16#00#, 16#01#, 16#02#, 16#03#, 16#04#, + 16#05#, 16#06#, 16#07#, 16#08#, 16#09#, + 16#10#, 16#11#, 16#12#, 16#13#, 16#14#, + 16#15#, 16#16#, 16#17#, 16#18#, 16#19#, + 16#20#, 16#21#, 16#22#, 16#23#, 16#24#, + 16#25#, 16#26#, 16#27#, 16#28#, 16#29#, + 16#30#, 16#31#, 16#32#, 16#33#, 16#34#, + 16#35#, 16#36#, 16#37#, 16#38#, 16#39#, + 16#40#, 16#41#, 16#42#, 16#43#, 16#44#, + 16#45#, 16#46#, 16#47#, 16#48#, 16#49#, + 16#50#, 16#51#, 16#52#, 16#53#, 16#54#, + 16#55#, 16#56#, 16#57#, 16#58#, 16#59#, + 16#60#, 16#61#, 16#62#, 16#63#, 16#64#, + 16#65#, 16#66#, 16#67#, 16#68#, 16#69#, + 16#70#, 16#71#, 16#72#, 16#73#, 16#74#, + 16#75#, 16#76#, 16#77#, 16#78#, 16#79#, + 16#80#, 16#81#, 16#82#, 16#83#, 16#84#, + 16#85#, 16#86#, 16#87#, 16#88#, 16#89#, + 16#90#, 16#91#, 16#92#, 16#93#, 16#94#, + 16#95#, 16#96#, 16#97#, 16#98#, 16#99#); + + --------------------- + -- Int32_To_Packed -- + --------------------- + + procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32) is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D rem 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + VV : Integer_32 := V; + + begin + -- Deal with sign byte first + + if VV >= 0 then + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#; + VV := VV / 10; + + else + VV := -VV; + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#; + end if; + + for J in reverse B - 1 .. 2 loop + if VV = 0 then + for K in 1 .. J loop + PP (K) := 16#00#; + end loop; + + return; + + else + PP (J) := Packed_Byte (Integer (VV rem 100)); + VV := VV / 100; + end if; + end loop; + + -- Deal with leading byte + + if Empty_Nibble then + if VV > 9 then + raise Constraint_Error; + else + PP (1) := Unsigned_8 (VV); + end if; + + else + if VV > 99 then + raise Constraint_Error; + else + PP (1) := Packed_Byte (Integer (VV)); + end if; + end if; + + end Int32_To_Packed; + + --------------------- + -- Int64_To_Packed -- + --------------------- + + procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64) is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D rem 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + VV : Integer_64 := V; + + begin + -- Deal with sign byte first + + if VV >= 0 then + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#C#; + VV := VV / 10; + + else + VV := -VV; + PP (B) := Unsigned_8 (VV rem 10) * 16 + 16#D#; + end if; + + for J in reverse B - 1 .. 2 loop + if VV = 0 then + for K in 1 .. J loop + PP (K) := 16#00#; + end loop; + + return; + + else + PP (J) := Packed_Byte (Integer (VV rem 100)); + VV := VV / 100; + end if; + end loop; + + -- Deal with leading byte + + if Empty_Nibble then + if VV > 9 then + raise Constraint_Error; + else + PP (1) := Unsigned_8 (VV); + end if; + + else + if VV > 99 then + raise Constraint_Error; + else + PP (1) := Packed_Byte (Integer (VV)); + end if; + end if; + + end Int64_To_Packed; + + --------------------- + -- Packed_To_Int32 -- + --------------------- + + function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32 is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D mod 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + V : Integer_32; + Dig : Unsigned_8; + Sign : Unsigned_8; + J : Positive; + + begin + -- Cases where there is an unused (zero) nibble in the first byte. + -- Deal with the single digit nibble at the right of this byte + + if Empty_Nibble then + V := Integer_32 (PP (1)); + J := 2; + + if V > 9 then + raise Constraint_Error; + end if; + + -- Cases where all nibbles are used + + else + V := 0; + J := 1; + end if; + + -- Loop to process bytes containing two digit nibbles + + while J < B loop + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_32 (Dig); + end if; + + Dig := PP (J) and 16#0F#; + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_32 (Dig); + end if; + + J := J + 1; + end loop; + + -- Deal with digit nibble in sign byte + + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_32 (Dig); + end if; + + Sign := PP (J) and 16#0F#; + + -- Process sign nibble (deal with most common cases first) + + if Sign = 16#C# then + return V; + + elsif Sign = 16#D# then + return -V; + + elsif Sign = 16#B# then + return -V; + + elsif Sign >= 16#A# then + return V; + + else + raise Constraint_Error; + end if; + end Packed_To_Int32; + + --------------------- + -- Packed_To_Int64 -- + --------------------- + + function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64 is + PP : constant Packed_Ptr := To_Packed_Ptr (P); + Empty_Nibble : constant Boolean := ((D mod 2) = 0); + B : constant Byte_Length := (D / 2) + 1; + V : Integer_64; + Dig : Unsigned_8; + Sign : Unsigned_8; + J : Positive; + + begin + -- Cases where there is an unused (zero) nibble in the first byte. + -- Deal with the single digit nibble at the right of this byte + + if Empty_Nibble then + V := Integer_64 (PP (1)); + J := 2; + + if V > 9 then + raise Constraint_Error; + end if; + + -- Cases where all nibbles are used + + else + J := 1; + V := 0; + end if; + + -- Loop to process bytes containing two digit nibbles + + while J < B loop + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_64 (Dig); + end if; + + Dig := PP (J) and 16#0F#; + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_64 (Dig); + end if; + + J := J + 1; + end loop; + + -- Deal with digit nibble in sign byte + + Dig := Shift_Right (PP (J), 4); + + if Dig > 9 then + raise Constraint_Error; + else + V := V * 10 + Integer_64 (Dig); + end if; + + Sign := PP (J) and 16#0F#; + + -- Process sign nibble (deal with most common cases first) + + if Sign = 16#C# then + return V; + + elsif Sign = 16#D# then + return -V; + + elsif Sign = 16#B# then + return -V; + + elsif Sign >= 16#A# then + return V; + + else + raise Constraint_Error; + end if; + end Packed_To_Int64; + +end Interfaces.Packed_Decimal; diff --git a/gcc/ada/libgnat/i-pacdec.ads b/gcc/ada/libgnat/i-pacdec.ads new file mode 100644 index 0000000..1f312b9 --- /dev/null +++ b/gcc/ada/libgnat/i-pacdec.ads @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S . P A C K E D _ D E C I M A L -- +-- -- +-- S p e c -- +-- (Version for IBM Mainframe Packed Decimal Format) -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit defines the packed decimal format used by GNAT in response to +-- a specification of Machine_Radix 10 for a decimal fixed-point type. The +-- format and operations are completely encapsulated in this unit, so all +-- that is necessary to compile using different packed decimal formats is +-- to replace this single unit. + +-- Note that the compiler access the spec of this unit during compilation +-- to obtain the data length that needs allocating, so the correct version +-- of the spec must be available to the compiler, and must correspond to +-- the spec and body made available to the linker, and all units of a given +-- program must be compiled with the same version of the spec and body. +-- This consistency will be enforced automatically using the normal binder +-- consistency checking, since any unit declaring Machine_Radix 10 types or +-- containing operations on such data will implicitly with Packed_Decimal. + +with System; + +package Interfaces.Packed_Decimal is + + ------------------------ + -- Format Description -- + ------------------------ + + -- IBM Mainframe packed decimal format uses a byte string of length one + -- to 10 bytes, with the most significant byte first. Each byte contains + -- two decimal digits (with the high order digit in the left nibble, and + -- the low order four bits contain the sign, using the following code: + + -- 16#A# 2#1010# positive + -- 16#B# 2#1011# negative + -- 16#C# 2#1100# positive (preferred representation) + -- 16#D# 2#1101# negative (preferred representation) + -- 16#E# 2#1110# positive + -- 16#F# 2#1011# positive + + -- In this package, all six sign representations are interpreted as + -- shown above when an operand is read, when an operand is written, + -- the preferred representations are always used. Constraint_Error + -- is raised if any other bit pattern is found in the sign nibble, + -- or if a digit nibble contains an invalid digit code. + + -- Some examples follow: + + -- 05 76 3C +5763 + -- 00 01 1D -11 + -- 00 04 4E +44 (non-standard sign) + -- 00 00 00 invalid (incorrect sign nibble) + -- 0A 01 1C invalid (bad digit) + + ------------------ + -- Length Array -- + ------------------ + + -- The following array must be declared in exactly the form shown, since + -- the compiler accesses the associated tree to determine the size to be + -- allocated to a machine radix 10 type, depending on the number of digits. + + subtype Byte_Length is Positive range 1 .. 10; + -- Range of possible byte lengths + + Packed_Size : constant array (1 .. 18) of Byte_Length := + (01 => 01, -- Length in bytes for digits 1 + 02 => 02, -- Length in bytes for digits 2 + 03 => 02, -- Length in bytes for digits 2 + 04 => 03, -- Length in bytes for digits 2 + 05 => 03, -- Length in bytes for digits 2 + 06 => 04, -- Length in bytes for digits 2 + 07 => 04, -- Length in bytes for digits 2 + 08 => 05, -- Length in bytes for digits 2 + 09 => 05, -- Length in bytes for digits 2 + 10 => 06, -- Length in bytes for digits 2 + 11 => 06, -- Length in bytes for digits 2 + 12 => 07, -- Length in bytes for digits 2 + 13 => 07, -- Length in bytes for digits 2 + 14 => 08, -- Length in bytes for digits 2 + 15 => 08, -- Length in bytes for digits 2 + 16 => 09, -- Length in bytes for digits 2 + 17 => 09, -- Length in bytes for digits 2 + 18 => 10); -- Length in bytes for digits 2 + + ------------------------- + -- Conversion Routines -- + ------------------------- + + subtype D32 is Positive range 1 .. 9; + -- Used to represent number of digits in a packed decimal value that + -- can be represented in a 32-bit binary signed integer form. + + subtype D64 is Positive range 10 .. 18; + -- Used to represent number of digits in a packed decimal value that + -- requires a 64-bit signed binary integer for representing all values. + + function Packed_To_Int32 (P : System.Address; D : D32) return Integer_32; + -- The argument P is the address of a packed decimal value and D is the + -- number of digits (in the range 1 .. 9, as implied by the subtype). + -- The returned result is the corresponding signed binary value. The + -- exception Constraint_Error is raised if the input is invalid. + + function Packed_To_Int64 (P : System.Address; D : D64) return Integer_64; + -- The argument P is the address of a packed decimal value and D is the + -- number of digits (in the range 10 .. 18, as implied by the subtype). + -- The returned result is the corresponding signed binary value. The + -- exception Constraint_Error is raised if the input is invalid. + + procedure Int32_To_Packed (V : Integer_32; P : System.Address; D : D32); + -- The argument V is a signed binary integer, which is converted to + -- packed decimal format and stored using P, the address of a packed + -- decimal item of D digits (D is in the range 1-9). Constraint_Error + -- is raised if V is out of range of this number of digits. + + procedure Int64_To_Packed (V : Integer_64; P : System.Address; D : D64); + -- The argument V is a signed binary integer, which is converted to + -- packed decimal format and stored using P, the address of a packed + -- decimal item of D digits (D is in the range 10-18). Constraint_Error + -- is raised if V is out of range of this number of digits. + +end Interfaces.Packed_Decimal; diff --git a/gcc/ada/libgnat/i-vxwoio.adb b/gcc/ada/libgnat/i-vxwoio.adb new file mode 100644 index 0000000..c908a2b --- /dev/null +++ b/gcc/ada/libgnat/i-vxwoio.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body Interfaces.VxWorks.IO is + + -------------------------- + -- Enable_Get_Immediate -- + -------------------------- + + procedure Enable_Get_Immediate + (File : Interfaces.C_Streams.FILEs; + Success : out Boolean) + is + Status : int; + Fd : int; + + begin + Fd := fileno (File); + Status := ioctl (Fd, FIOSETOPTIONS, OPT_RAW); + + if Status /= int (ERROR) then + Success := True; + else + Success := False; + end if; + end Enable_Get_Immediate; + + --------------------------- + -- Disable_Get_Immediate -- + --------------------------- + + procedure Disable_Get_Immediate + (File : Interfaces.C_Streams.FILEs; + Success : out Boolean) + is + Status : int; + Fd : int; + begin + Fd := fileno (File); + Status := ioctl (Fd, FIOSETOPTIONS, OPT_TERMINAL); + Success := (if Status /= int (ERROR) then True else False); + end Disable_Get_Immediate; + +end Interfaces.VxWorks.IO; diff --git a/gcc/ada/libgnat/i-vxwoio.ads b/gcc/ada/libgnat/i-vxwoio.ads new file mode 100644 index 0000000..9a6929f --- /dev/null +++ b/gcc/ada/libgnat/i-vxwoio.ads @@ -0,0 +1,229 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S . I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a binding to the functions fileno and ioctl +-- in VxWorks, providing a set of definitions of ioctl function codes +-- and options for the use of these functions. + +-- A particular use of this interface is to enable use of Get_Immediate +-- in Ada.Text_IO. There is no way in VxWorks to provide the desired +-- functionality of Get_Immediate (no buffering and no waiting for a +-- line return) without flushing the buffer, which violates the Ada +-- semantic requirements for Ada.Text_IO. + +with Interfaces.C_Streams; + +package Interfaces.VxWorks.IO is + + ------------------------- + -- The ioctl Interface -- + -------------------------- + + type FUNCODE is new int; + -- Type of the function codes in ioctl + + type IOOPT is mod 2 ** int'Size; + -- Type of the option codes in ioctl + + -- ioctl function codes (for more information see ioLib.h) + -- These values could be generated automatically in System.OS_Constants??? + + FIONREAD : constant FUNCODE := 1; + FIOFLUSH : constant FUNCODE := 2; + FIOOPTIONS : constant FUNCODE := 3; + FIOBAUDRATE : constant FUNCODE := 4; + FIODISKFORMAT : constant FUNCODE := 5; + FIODISKINIT : constant FUNCODE := 6; + FIOSEEK : constant FUNCODE := 7; + FIOWHERE : constant FUNCODE := 8; + FIODIRENTRY : constant FUNCODE := 9; + FIORENAME : constant FUNCODE := 10; + FIOREADYCHANGE : constant FUNCODE := 11; + FIONWRITE : constant FUNCODE := 12; + FIODISKCHANGE : constant FUNCODE := 13; + FIOCANCEL : constant FUNCODE := 14; + FIOSQUEEZE : constant FUNCODE := 15; + FIONBIO : constant FUNCODE := 16; + FIONMSGS : constant FUNCODE := 17; + FIOGETNAME : constant FUNCODE := 18; + FIOGETOPTIONS : constant FUNCODE := 19; + FIOSETOPTIONS : constant FUNCODE := FIOOPTIONS; + FIOISATTY : constant FUNCODE := 20; + FIOSYNC : constant FUNCODE := 21; + FIOPROTOHOOK : constant FUNCODE := 22; + FIOPROTOARG : constant FUNCODE := 23; + FIORBUFSET : constant FUNCODE := 24; + FIOWBUFSET : constant FUNCODE := 25; + FIORFLUSH : constant FUNCODE := 26; + FIOWFLUSH : constant FUNCODE := 27; + FIOSELECT : constant FUNCODE := 28; + FIOUNSELECT : constant FUNCODE := 29; + FIONFREE : constant FUNCODE := 30; + FIOMKDIR : constant FUNCODE := 31; + FIORMDIR : constant FUNCODE := 32; + FIOLABELGET : constant FUNCODE := 33; + FIOLABELSET : constant FUNCODE := 34; + FIOATTRIBSE : constant FUNCODE := 35; + FIOCONTIG : constant FUNCODE := 36; + FIOREADDIR : constant FUNCODE := 37; + FIOFSTATGET : constant FUNCODE := 38; + FIOUNMOUNT : constant FUNCODE := 39; + FIOSCSICOMMAND : constant FUNCODE := 40; + FIONCONTIG : constant FUNCODE := 41; + FIOTRUNC : constant FUNCODE := 42; + FIOGETFL : constant FUNCODE := 43; + FIOTIMESET : constant FUNCODE := 44; + FIOINODETONAM : constant FUNCODE := 45; + FIOFSTATFSGE : constant FUNCODE := 46; + + -- ioctl option values + + OPT_ECHO : constant IOOPT := 16#0001#; + OPT_CRMOD : constant IOOPT := 16#0002#; + OPT_TANDEM : constant IOOPT := 16#0004#; + OPT_7_BIT : constant IOOPT := 16#0008#; + OPT_MON_TRAP : constant IOOPT := 16#0010#; + OPT_ABORT : constant IOOPT := 16#0020#; + OPT_LINE : constant IOOPT := 16#0040#; + OPT_RAW : constant IOOPT := 16#0000#; + OPT_TERMINAL : constant IOOPT := OPT_ECHO or + OPT_CRMOD or + OPT_TANDEM or + OPT_MON_TRAP or + OPT_7_BIT or + OPT_ABORT or + OPT_LINE; + + function fileno (Fp : Interfaces.C_Streams.FILEs) return int; + pragma Import (C, fileno, "fileno"); + -- Binding to the C routine fileno + + function ioctl (Fd : int; Function_Code : FUNCODE; Arg : IOOPT) return int; + pragma Import (C, ioctl, "ioctl"); + -- Binding to the C routine ioctl + -- + -- Note: we are taking advantage of the fact that on currently supported + -- VxWorks targets, it is fine to directly bind to a variadic C function. + + ------------------------------ + -- Control of Get_Immediate -- + ------------------------------ + + -- The procedures in this section make use of the interface to ioctl + -- and fileno to provide a mechanism for enabling unbuffered behavior + -- for Get_Immediate in VxWorks. + + -- The situation is that the RM requires that the use of Get_Immediate + -- be identical to Get except that it is desirable (not required) that + -- there be no buffering or line editing. + + -- Unfortunately, in VxWorks, the only way to enable this desired + -- unbuffered behavior involves changing into raw mode. But this + -- transition into raw mode flushes the input buffer, a behavior + -- not permitted by the RM semantics for Get_Immediate. + + -- Given that Get_Immediate cannot be accurately implemented in + -- raw mode, it seems best not to enable it by default, and instead + -- to require specific programmer action, with the programmer being + -- aware that input may be lost. + + -- The following is an example of the use of the two procedures + -- in this section (Enable_Get_Immediate and Disable_Get_Immediate) + + -- with Ada.Text_IO; use Ada.Text_IO; + -- with Ada.Text_IO.C_Streams; use Ada.Text_IO.C_Streams; + -- with Interfaces.VxWorks.IO; use Interfaces.VxWorks.IO; + + -- procedure Example_IO is + -- Input : Character; + -- Available : Boolean; + -- Success : Boolean; + + -- begin + -- Enable_Get_Immediate (C_Stream (Current_Input), Success); + + -- if Success = False then + -- raise Device_Error; + -- end if; + + -- -- Example with the first type of Get_Immediate + -- -- Waits for an entry on the input. Immediately returns + -- -- after having received an character on the input + + -- Put ("Input -> "); + -- Get_Immediate (Input); + -- New_Line; + -- Put_Line ("Character read: " & Input); + + -- -- Example with the second type of Get_Immediate + -- -- This is equivalent to a non blocking read + + -- for J in 1 .. 10 loop + -- Put ("Input -> "); + -- Get_Immediate (Input, Available); + -- New_Line; + + -- if Available = True then + -- Put_Line ("Character read: " & Input); + -- end if; + + -- delay 1.0; + -- end loop; + + -- Disable_Get_Immediate (C_Stream (Current_Input), Success); + + -- if Success = False then + -- raise Device_Error; + -- end if; + + -- exception + -- when Device_Error => + -- Put_Line ("Device Error. Check your configuration"); + -- end Example_IO; + + procedure Enable_Get_Immediate + (File : Interfaces.C_Streams.FILEs; + Success : out Boolean); + -- On VxWorks, a call to this procedure is required before subsequent calls + -- to Get_Immediate have the desired effect of not waiting for a line + -- return. The reason that this call is not automatic on this target is + -- that the call flushes the input buffer, discarding any previous input. + -- Note: Following a call to Enable_Get_Immediate, the only permitted + -- operations on the relevant file are Get_Immediate operations. Any + -- other operations have undefined behavior. + + procedure Disable_Get_Immediate + (File : Interfaces.C_Streams.FILEs; + Success : out Boolean); + -- This procedure resets File to standard mode, and permits subsequent + -- use of the full range of Ada.Text_IO functions + +end Interfaces.VxWorks.IO; diff --git a/gcc/ada/libgnat/i-vxwork-x86.ads b/gcc/ada/libgnat/i-vxwork-x86.ads new file mode 100644 index 0000000..ef515d5 --- /dev/null +++ b/gcc/ada/libgnat/i-vxwork-x86.ads @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the x86 VxWorks version of this package + +-- This package provides a limited binding to the VxWorks API +-- In particular, it interfaces with the VxWorks hardware interrupt +-- facilities, allowing the use of low-latency direct-vectored +-- interrupt handlers. Note that such handlers have a variety of +-- restrictions regarding system calls and language constructs. In particular, +-- the use of exception handlers and functions returning variable-length +-- objects cannot be used. Less restrictive, but higher-latency handlers can +-- be written using Ada protected procedures, Ada 83 style interrupt entries, +-- or by signalling an Ada task from within an interrupt handler using a +-- binary semaphore as described in the VxWorks Programmer's Manual. +-- +-- For complete documentation of the operations in this package, please +-- consult the VxWorks Programmer's Manual and VxWorks Reference Manual. + +pragma Warnings (Off, "*foreign convention*"); +pragma Warnings (Off, "*add Convention pragma*"); + +with System.VxWorks; + +package Interfaces.VxWorks is + pragma Preelaborate; + + ------------------------------------------------------------------------ + -- Here is a complete example that shows how to handle the Interrupt 0x33 + -- with a direct-vectored interrupt handler in Ada using this package: + + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with System; + -- + -- package P is + -- + -- Count : Integer; + -- pragma Atomic (Count); + -- + -- procedure Handler (Parameter : System.Address); + -- + -- end P; + -- + -- package body P is + -- + -- procedure Handler (Parameter : System.Address) is + -- begin + -- Count := Count + 1; + -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); + -- end Handler; + -- end P; + -- + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with Ada.Text_IO; use Ada.Text_IO; + -- with Ada.Interrupts; + -- with Machine_Code; use Machine_Code; + -- + -- with P; use P; + -- procedure Useint is + -- + -- -- Be sure to use a reasonable interrupt number for target board. + -- -- This one is an unreserved interrupt for the Pentium 3 BSP + -- + -- Interrupt : constant := 16#33#; + -- + -- task T; + -- + -- S : STATUS; + -- + -- task body T is + -- begin + -- loop + -- Put_Line ("Generating an interrupt..."); + -- delay 1.0; + -- + -- -- Generate interrupt, using interrupt number + -- + -- Asm ("int %0", + -- Inputs => + -- Ada.Interrupts.Interrupt_ID'Asm_Input + -- ("i", Interrupt)); + -- end loop; + -- end T; + -- + -- begin + -- S := intConnect (INUM_TO_IVEC (Interrupt), Handler'Access); + -- + -- loop + -- delay 2.0; + -- Put_Line ("value of count:" & P.Count'Img); + -- end loop; + -- end Useint; + ------------------------------------- + + subtype int is Integer; + + type STATUS is new int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := -1; + + type VOIDFUNCPTR is access procedure (parameter : System.Address); + type Interrupt_Vector is new System.Address; + type Exception_Vector is new System.Address; + + function intConnect + (vector : Interrupt_Vector; + handler : VOIDFUNCPTR; + parameter : System.Address := System.Null_Address) return STATUS; + -- Binding to the C routine intConnect. Use this to set up an user handler. + -- The routine generates a wrapper around the user handler to save and + -- restore context + + function intContext return int; + -- Binding to the C routine intContext. This function returns 1 only if the + -- current execution state is in interrupt context. + + function intVecGet + (Vector : Interrupt_Vector) return VOIDFUNCPTR; + -- Binding to the C routine intVecGet. Use this to get the existing handler + -- for later restoral + + procedure intVecSet + (Vector : Interrupt_Vector; + Handler : VOIDFUNCPTR); + -- Binding to the C routine intVecSet. Use this to restore a handler + -- obtained using intVecGet + + procedure intVecGet2 + (vector : Interrupt_Vector; + pFunction : out VOIDFUNCPTR; + pIdtGate : not null access int; + pIdtSelector : not null access int); + -- Binding to the C routine intVecGet2. Use this to get the existing + -- handler for later restoral + + procedure intVecSet2 + (vector : Interrupt_Vector; + pFunction : VOIDFUNCPTR; + pIdtGate : not null access int; + pIdtSelector : not null access int); + -- Binding to the C routine intVecSet2. Use this to restore a + -- handler obtained using intVecGet2 + + function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; + -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt + -- number to an interrupt vector + + procedure logMsg + (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); + -- Binding to the C routine logMsg. Note that it is the caller's + -- responsibility to ensure that fmt is a null-terminated string + -- (e.g logMsg ("Interrupt" & ASCII.NUL)) + + type FP_CONTEXT is private; + -- Floating point context save and restore. Handlers using floating point + -- must be bracketed with these calls. The pFpContext parameter should be + -- an object of type FP_CONTEXT that is declared local to the handler. + -- + -- See the VxWorks Intel Architecture Supplement regarding these routines + + procedure fppRestore (pFpContext : in out FP_CONTEXT); + -- Restore floating point context - old style + + procedure fppSave (pFpContext : in out FP_CONTEXT); + -- Save floating point context - old style + + procedure fppXrestore (pFpContext : in out FP_CONTEXT); + -- Restore floating point context - new style + + procedure fppXsave (pFpContext : in out FP_CONTEXT); + -- Save floating point context - new style + +private + + type FP_CONTEXT is new System.VxWorks.FP_CONTEXT; + -- Target-dependent floating point context type + + pragma Import (C, intConnect, "intConnect"); + pragma Import (C, intContext, "intContext"); + pragma Import (C, intVecGet, "intVecGet"); + pragma Import (C, intVecSet, "intVecSet"); + pragma Import (C, intVecGet2, "intVecGet2"); + pragma Import (C, intVecSet2, "intVecSet2"); + pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); + pragma Import (C, logMsg, "logMsg"); + pragma Import (C, fppRestore, "fppRestore"); + pragma Import (C, fppSave, "fppSave"); + pragma Import (C, fppXrestore, "fppXrestore"); + pragma Import (C, fppXsave, "fppXsave"); +end Interfaces.VxWorks; diff --git a/gcc/ada/libgnat/i-vxwork.ads b/gcc/ada/libgnat/i-vxwork.ads new file mode 100644 index 0000000..b6e036b --- /dev/null +++ b/gcc/ada/libgnat/i-vxwork.ads @@ -0,0 +1,216 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- I N T E R F A C E S . V X W O R K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a limited binding to the VxWorks API + +-- In particular, it interfaces with the VxWorks hardware interrupt +-- facilities, allowing the use of low-latency direct-vectored interrupt +-- handlers. Note that such handlers have a variety of restrictions regarding +-- system calls and language constructs. In particular, the use of exception +-- handlers and functions returning variable-length objects cannot be used. +-- Less restrictive, but higher-latency handlers can be written using Ada +-- protected procedures, Ada 83 style interrupt entries, or by signalling +-- an Ada task from within an interrupt handler using a binary semaphore +-- as described in the VxWorks Programmer's Manual. +-- +-- For complete documentation of the operations in this package, please +-- consult the VxWorks Programmer's Manual and VxWorks Reference Manual. + +pragma Warnings (Off, "*foreign convention*"); +pragma Warnings (Off, "*add Convention pragma*"); +-- These are temporary pragmas to suppress warnings about mismatching +-- conventions, which will be a problem when we get rid of trampolines ??? + +with System.VxWorks; + +package Interfaces.VxWorks is + pragma Preelaborate; + + ------------------------------------------------------------------------ + -- Here is a complete example that shows how to handle the Interrupt 0x14 + -- with a direct-vectored interrupt handler in Ada using this package: + + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with System; + -- + -- package P is + -- + -- Count : Integer; + -- pragma Atomic (Count); + -- + -- Level : constant := 1; + -- -- Interrupt level used by this example + -- + -- procedure Handler (parameter : System.Address); + -- + -- end P; + -- + -- package body P is + -- + -- procedure Handler (parameter : System.Address) is + -- S : STATUS; + -- begin + -- Count := Count + 1; + -- logMsg ("received an interrupt" & ASCII.LF & ASCII.NUL); + -- + -- -- Acknowledge VME interrupt + -- + -- S := sysBusIntAck (intLevel => Level); + -- end Handler; + -- end P; + -- + -- with Interfaces.VxWorks; use Interfaces.VxWorks; + -- with Ada.Text_IO; use Ada.Text_IO; + -- + -- with P; use P; + -- procedure Useint is + -- + -- -- Be sure to use a reasonable interrupt number for board. + -- -- This one is the unused VME graphics interrupt on the PPC MV2604 + -- + -- Interrupt : constant := 16#14#; + -- + -- task T; + -- + -- S : STATUS; + -- + -- task body T is + -- begin + -- loop + -- Put_Line ("Generating an interrupt..."); + -- delay 1.0; + -- + -- -- Generate VME interrupt, using interrupt number + -- + -- S := sysBusIntGen (1, Interrupt); + -- end loop; + -- end T; + -- + -- begin + -- S := sysIntEnable (intLevel => Level); + -- S := intConnect (INUM_TO_IVEC (Interrupt), handler'Access); + -- + -- loop + -- delay 2.0; + -- Put_Line ("value of count:" & P.Count'Img); + -- end loop; + -- end Useint; + ------------------------------------- + + subtype int is Integer; + + type STATUS is new int; + -- Equivalent of the C type STATUS + + OK : constant STATUS := 0; + ERROR : constant STATUS := -1; + + type VOIDFUNCPTR is access procedure (parameter : System.Address); + type Interrupt_Vector is new System.Address; + type Exception_Vector is new System.Address; + + function intConnect + (vector : Interrupt_Vector; + handler : VOIDFUNCPTR; + parameter : System.Address := System.Null_Address) return STATUS; + -- Binding to the C routine intConnect. Use this to set up an user handler. + -- The routine generates a wrapper around the user handler to save and + -- restore context + + function intContext return int; + -- Binding to the C routine intContext. This function returns 1 only if the + -- current execution state is in interrupt context. + + function intVecGet + (Vector : Interrupt_Vector) return VOIDFUNCPTR; + -- Binding to the C routine intVecGet. Use this to get the existing handler + -- for later restoral + + procedure intVecSet + (Vector : Interrupt_Vector; + Handler : VOIDFUNCPTR); + -- Binding to the C routine intVecSet. Use this to restore a handler + -- obtained using intVecGet + + function INUM_TO_IVEC (intNum : int) return Interrupt_Vector; + -- Equivalent to the C macro INUM_TO_IVEC used to convert an interrupt + -- number to an interrupt vector + + function sysIntEnable (intLevel : int) return STATUS; + -- Binding to the C routine sysIntEnable + + function sysIntDisable (intLevel : int) return STATUS; + -- Binding to the C routine sysIntDisable + + function sysBusIntAck (intLevel : int) return STATUS; + -- Binding to the C routine sysBusIntAck + + function sysBusIntGen (intLevel : int; Intnum : int) return STATUS; + -- Binding to the C routine sysBusIntGen. Note that the T2 documentation + -- implies that a vector address is the proper argument - it's not. The + -- interrupt number in the range 0 .. 255 (for 68K and PPC) is the correct + -- argument. + + procedure logMsg + (fmt : String; arg1, arg2, arg3, arg4, arg5, arg6 : int := 0); + -- Binding to the C routine logMsg. Note that it is the caller's + -- responsibility to ensure that fmt is a null-terminated string + -- (e.g logMsg ("Interrupt" & ASCII.NUL)) + + type FP_CONTEXT is private; + -- Floating point context save and restore. Handlers using floating point + -- must be bracketed with these calls. The pFpContext parameter should be + -- an object of type FP_CONTEXT that is declared local to the handler. + + procedure fppRestore (pFpContext : in out FP_CONTEXT); + -- Restore floating point context + + procedure fppSave (pFpContext : in out FP_CONTEXT); + -- Save floating point context + +private + + type FP_CONTEXT is new System.VxWorks.FP_CONTEXT; + -- Target-dependent floating point context type + + pragma Import (C, intConnect, "intConnect"); + pragma Import (C, intContext, "intContext"); + pragma Import (C, intVecGet, "intVecGet"); + pragma Import (C, intVecSet, "intVecSet"); + pragma Import (C, INUM_TO_IVEC, "__gnat_inum_to_ivec"); + pragma Import (C, sysIntEnable, "sysIntEnable"); + pragma Import (C, sysIntDisable, "sysIntDisable"); + pragma Import (C, sysBusIntAck, "sysBusIntAck"); + pragma Import (C, sysBusIntGen, "sysBusIntGen"); + pragma Import (C, logMsg, "logMsg"); + pragma Import (C, fppRestore, "fppRestore"); + pragma Import (C, fppSave, "fppSave"); +end Interfaces.VxWorks; diff --git a/gcc/ada/libgnat/interfac.ads b/gcc/ada/libgnat/interfac.ads new file mode 100644 index 0000000..da387f5 --- /dev/null +++ b/gcc/ada/libgnat/interfac.ads @@ -0,0 +1,184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- I N T E R F A C E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the implementation dependent sections of this file. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package Interfaces is + pragma No_Elaboration_Code_All; + pragma Pure; + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + type Integer_8 is range -2 ** 7 .. 2 ** 7 - 1; + for Integer_8'Size use 8; + + type Integer_16 is range -2 ** 15 .. 2 ** 15 - 1; + for Integer_16'Size use 16; + + type Integer_32 is range -2 ** 31 .. 2 ** 31 - 1; + for Integer_32'Size use 32; + + type Integer_64 is new Long_Long_Integer; + for Integer_64'Size use 64; + -- Note: we use Long_Long_Integer'First instead of -2 ** 63 to allow this + -- unit to compile when using custom target configuration files where the + -- maximum integer is 32 bits. This is useful for static analysis tools + -- such as SPARK or CodePeer. In the normal case Long_Long_Integer is + -- always 64-bits so we get the desired 64-bit type. + + type Unsigned_8 is mod 2 ** 8; + for Unsigned_8'Size use 8; + + type Unsigned_16 is mod 2 ** 16; + for Unsigned_16'Size use 16; + + type Unsigned_24 is mod 2 ** 24; + for Unsigned_24'Size use 24; + -- Declare this type for compatibility with legacy Ada compilers. + -- This is particularly useful in the context of CodePeer analysis. + + type Unsigned_32 is mod 2 ** 32; + for Unsigned_32'Size use 32; + + type Unsigned_64 is mod 2 ** Long_Long_Integer'Size; + for Unsigned_64'Size use 64; + -- See comment on Integer_64 above + + function Shift_Left + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8; + + function Shift_Right + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8; + + function Shift_Right_Arithmetic + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8; + + function Rotate_Left + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8; + + function Rotate_Right + (Value : Unsigned_8; + Amount : Natural) return Unsigned_8; + + function Shift_Left + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16; + + function Shift_Right + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16; + + function Shift_Right_Arithmetic + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16; + + function Rotate_Left + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16; + + function Rotate_Right + (Value : Unsigned_16; + Amount : Natural) return Unsigned_16; + + function Shift_Left + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32; + + function Shift_Right + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32; + + function Shift_Right_Arithmetic + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32; + + function Rotate_Left + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32; + + function Rotate_Right + (Value : Unsigned_32; + Amount : Natural) return Unsigned_32; + + function Shift_Left + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64; + + function Shift_Right + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64; + + function Shift_Right_Arithmetic + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64; + + function Rotate_Left + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64; + + function Rotate_Right + (Value : Unsigned_64; + Amount : Natural) return Unsigned_64; + + pragma Import (Intrinsic, Shift_Left); + pragma Import (Intrinsic, Shift_Right); + pragma Import (Intrinsic, Shift_Right_Arithmetic); + pragma Import (Intrinsic, Rotate_Left); + pragma Import (Intrinsic, Rotate_Right); + + -- IEEE Floating point types + + type IEEE_Float_32 is digits 6; + for IEEE_Float_32'Size use 32; + + type IEEE_Float_64 is digits 15; + for IEEE_Float_64'Size use 64; + + -- If there is an IEEE extended float available on the machine, we assume + -- that it is available as Long_Long_Float. + + -- Note: it is harmless, and explicitly permitted, to include additional + -- types in interfaces, so it is not wrong to have IEEE_Extended_Float + -- defined even if the extended format is not available. + + type IEEE_Extended_Float is new Long_Long_Float; + +end Interfaces; diff --git a/gcc/ada/libgnat/ioexcept.ads b/gcc/ada/libgnat/ioexcept.ads new file mode 100644 index 0000000..da46729 --- /dev/null +++ b/gcc/ada/libgnat/ioexcept.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- I O _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and IO_Exceptions is not +-- considered to be an internal unit that is automatically compiled in Ada +-- 2012 mode (since a user is allowed to redeclare IO_Exceptions). + +with Ada.IO_Exceptions; + +package IO_Exceptions renames Ada.IO_Exceptions; diff --git a/gcc/ada/libgnat/machcode.ads b/gcc/ada/libgnat/machcode.ads new file mode 100644 index 0000000..55e1ae5 --- /dev/null +++ b/gcc/ada/libgnat/machcode.ads @@ -0,0 +1,18 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- M A C H I N E _ C O D E -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +with System.Machine_Code; + +package Machine_Code renames System.Machine_Code; diff --git a/gcc/ada/libgnat/memtrack.adb b/gcc/ada/libgnat/memtrack.adb new file mode 100644 index 0000000..bab458d --- /dev/null +++ b/gcc/ada/libgnat/memtrack.adb @@ -0,0 +1,401 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version contains allocation tracking capability + +-- The object file corresponding to this instrumented version is to be found +-- in libgmem. + +-- When enabled, the subsystem logs all the calls to __gnat_malloc and +-- __gnat_free. This log can then be processed by gnatmem to detect +-- dynamic memory leaks. + +-- To use this functionality, you must compile your application with -g +-- and then link with this object file: + +-- gnatmake -g program -largs -lgmem + +-- After compilation, you may use your program as usual except that upon +-- completion, it will generate in the current directory the file gmem.out. + +-- You can then investigate for possible memory leaks and mismatch by calling +-- gnatmem with this file as an input: + +-- gnatmem -i gmem.out program + +-- See gnatmem section in the GNAT User's Guide for more details + +-- NOTE: This capability is currently supported on the following targets: + +-- Windows +-- AIX +-- GNU/Linux +-- HP-UX +-- Solaris + +-- NOTE FOR FUTURE PLATFORMS SUPPORT: It is assumed that type Duration is +-- 64 bit. If the need arises to support architectures where this assumption +-- is incorrect, it will require changing the way timestamps of allocation +-- events are recorded. + +pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb"); + +with Ada.Exceptions; +with System.Soft_Links; +with System.Traceback; +with System.Traceback_Entries; +with GNAT.IO; +with System.OS_Primitives; + +package body System.Memory is + + use Ada.Exceptions; + use System.Soft_Links; + use System.Traceback; + use System.Traceback_Entries; + use GNAT.IO; + + function c_malloc (Size : size_t) return System.Address; + pragma Import (C, c_malloc, "malloc"); + + procedure c_free (Ptr : System.Address); + pragma Import (C, c_free, "free"); + + function c_realloc + (Ptr : System.Address; Size : size_t) return System.Address; + pragma Import (C, c_realloc, "realloc"); + + subtype File_Ptr is System.Address; + + function fopen (Path : String; Mode : String) return File_Ptr; + pragma Import (C, fopen); + + procedure OS_Exit (Status : Integer); + pragma Import (C, OS_Exit, "__gnat_os_exit"); + pragma No_Return (OS_Exit); + + 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); + + procedure Finalize; + pragma Export (C, Finalize, "__gnat_finalize"); + -- Replace the default __gnat_finalize to properly close the log file + + Address_Size : constant := System.Address'Max_Size_In_Storage_Elements; + -- Size in bytes of a pointer + + Max_Call_Stack : constant := 200; + -- Maximum number of frames supported + + Tracebk : Tracebacks_Array (1 .. Max_Call_Stack); + Num_Calls : aliased Integer := 0; + + Gmemfname : constant String := "gmem.out" & ASCII.NUL; + -- Allocation log of a program is saved in a file gmem.out + -- ??? What about Ada.Command_Line.Command_Name & ".out" instead of static + -- gmem.out + + Gmemfile : File_Ptr; + -- Global C file pointer to the allocation log + + Needs_Init : Boolean := True; + -- Reset after first call to Gmem_Initialize + + procedure Gmem_Initialize; + -- Initialization routine; opens the file and writes a header string. This + -- header string is used as a magic-tag to know if the .out file is to be + -- handled by GDB or by the GMEM (instrumented malloc/free) implementation. + + First_Call : Boolean := True; + -- Depending on implementation, some of the traceback routines may + -- themselves do dynamic allocation. We use First_Call flag to avoid + -- infinite recursion + + ----------- + -- Alloc -- + ----------- + + function Alloc (Size : size_t) return System.Address is + Result : aliased System.Address; + Actual_Size : aliased size_t := Size; + Timestamp : aliased Duration; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + -- Change size from zero to non-zero. We still want a proper pointer + -- for the zero case because pointers to zero length objects have to + -- be distinct, but we can't just go ahead and allocate zero bytes, + -- since some malloc's return zero for a zero argument. + + if Size = 0 then + Actual_Size := 1; + end if; + + Lock_Task.all; + + Result := c_malloc (Actual_Size); + + if First_Call then + + -- Logs allocation call + -- format is: + -- 'A' ... + + First_Call := False; + + if Needs_Init then + Gmem_Initialize; + end if; + + Timestamp := System.OS_Primitives.Clock; + Call_Chain + (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); + fputc (Character'Pos ('A'), Gmemfile); + fwrite (Result'Address, Address_Size, 1, Gmemfile); + fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1, + Gmemfile); + fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, + Gmemfile); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + Gmemfile); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + end; + end loop; + + First_Call := True; + + end if; + + Unlock_Task.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Alloc; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize is + begin + if not Needs_Init then + fclose (Gmemfile); + end if; + end Finalize; + + ---------- + -- Free -- + ---------- + + procedure Free (Ptr : System.Address) is + Addr : aliased constant System.Address := Ptr; + Timestamp : aliased Duration; + + begin + Lock_Task.all; + + if First_Call then + + -- Logs deallocation call + -- format is: + -- 'D' ... + + First_Call := False; + + if Needs_Init then + Gmem_Initialize; + end if; + + Call_Chain + (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); + Timestamp := System.OS_Primitives.Clock; + fputc (Character'Pos ('D'), Gmemfile); + fwrite (Addr'Address, Address_Size, 1, Gmemfile); + fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, + Gmemfile); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + Gmemfile); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + end; + end loop; + + c_free (Ptr); + + First_Call := True; + end if; + + Unlock_Task.all; + end Free; + + --------------------- + -- Gmem_Initialize -- + --------------------- + + procedure Gmem_Initialize is + Timestamp : aliased Duration; + + begin + if Needs_Init then + Needs_Init := False; + System.OS_Primitives.Initialize; + Timestamp := System.OS_Primitives.Clock; + Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL); + + if Gmemfile = System.Null_Address then + Put_Line ("Couldn't open gnatmem log file for writing"); + OS_Exit (255); + end if; + + fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile); + fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, + Gmemfile); + end if; + end Gmem_Initialize; + + ------------- + -- Realloc -- + ------------- + + function Realloc + (Ptr : System.Address; + Size : size_t) return System.Address + is + Addr : aliased constant System.Address := Ptr; + Result : aliased System.Address; + Timestamp : aliased Duration; + + begin + -- For the purposes of allocations logging, we treat realloc as a free + -- followed by malloc. This is not exactly accurate, but is a good way + -- to fit it into malloc/free-centered reports. + + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + Abort_Defer.all; + Lock_Task.all; + + if First_Call then + First_Call := False; + + -- We first log deallocation call + + if Needs_Init then + Gmem_Initialize; + end if; + Call_Chain + (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); + Timestamp := System.OS_Primitives.Clock; + fputc (Character'Pos ('D'), Gmemfile); + fwrite (Addr'Address, Address_Size, 1, Gmemfile); + fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, + Gmemfile); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + Gmemfile); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + end; + end loop; + + -- Now perform actual realloc + + Result := c_realloc (Ptr, Size); + + -- Log allocation call using the same backtrace + + fputc (Character'Pos ('A'), Gmemfile); + fwrite (Result'Address, Address_Size, 1, Gmemfile); + fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1, + Gmemfile); + fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, + Gmemfile); + fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, + Gmemfile); + + for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop + declare + Ptr : System.Address := PC_For (Tracebk (J)); + begin + fwrite (Ptr'Address, Address_Size, 1, Gmemfile); + end; + end loop; + + First_Call := True; + end if; + + Unlock_Task.all; + Abort_Undefer.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Realloc; + +end System.Memory; diff --git a/gcc/ada/libgnat/s-addima.adb b/gcc/ada/libgnat/s-addima.adb new file mode 100644 index 0000000..8af3064 --- /dev/null +++ b/gcc/ada/libgnat/s-addima.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ I M A G E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +function System.Address_Image (A : Address) return String is + + Result : String (1 .. 2 * Address'Size / Storage_Unit); + + type Byte is mod 2 ** 8; + for Byte'Size use 8; + + Hexdigs : + constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF"; + + type Bytes is array (1 .. Address'Size / Storage_Unit) of Byte; + for Bytes'Size use Address'Size; + + function To_Bytes is new Ada.Unchecked_Conversion (Address, Bytes); + + Byte_Sequence : constant Bytes := To_Bytes (A); + + LE : constant := Standard'Default_Bit_Order; + BE : constant := 1 - LE; + -- Set to 1/0 for True/False for Little-Endian/Big-Endian + + Start : constant Natural := BE * (1) + LE * (Bytes'Length); + Incr : constant Integer := BE * (1) + LE * (-1); + -- Start and increment for accessing characters of address string + + Ptr : Natural; + -- Scan address string + +begin + Ptr := Start; + for N in Bytes'Range loop + Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16); + Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16); + Ptr := Ptr + Incr; + end loop; + + return Result; + +end System.Address_Image; diff --git a/gcc/ada/libgnat/s-addima.ads b/gcc/ada/libgnat/s-addima.ads new file mode 100644 index 0000000..2dafd3c --- /dev/null +++ b/gcc/ada/libgnat/s-addima.ads @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ I M A G E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a GNAT specific addition which provides a useful debugging +-- procedure that gives an (implementation dependent) string which +-- identifies an address. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +function System.Address_Image (A : Address) return String; +pragma Pure (System.Address_Image); +-- Returns string (hexadecimal digits with upper case letters) representing +-- the address (string is 8/16 bytes for 32/64-bit machines). 'First of the +-- result = 1. diff --git a/gcc/ada/libgnat/s-addope.adb b/gcc/ada/libgnat/s-addope.adb new file mode 100644 index 0000000..a19e40b --- /dev/null +++ b/gcc/ada/libgnat/s-addope.adb @@ -0,0 +1,110 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Conversion; + +package body System.Address_Operations is + + type IA is mod 2 ** Address'Size; + -- The type used to provide the actual desired operations + + function I is new Ada.Unchecked_Conversion (Address, IA); + function A is new Ada.Unchecked_Conversion (IA, Address); + -- The operations are implemented by unchecked conversion to type IA, + -- followed by doing the intrinsic operation on the IA values, followed + -- by converting the result back to type Address. + + ---------- + -- AddA -- + ---------- + + function AddA (Left, Right : Address) return Address is + begin + return A (I (Left) + I (Right)); + end AddA; + + ---------- + -- AndA -- + ---------- + + function AndA (Left, Right : Address) return Address is + begin + return A (I (Left) and I (Right)); + end AndA; + + ---------- + -- DivA -- + ---------- + + function DivA (Left, Right : Address) return Address is + begin + return A (I (Left) / I (Right)); + end DivA; + + ---------- + -- ModA -- + ---------- + + function ModA (Left, Right : Address) return Address is + begin + return A (I (Left) mod I (Right)); + end ModA; + + --------- + -- MulA -- + --------- + + function MulA (Left, Right : Address) return Address is + begin + return A (I (Left) * I (Right)); + end MulA; + + --------- + -- OrA -- + --------- + + function OrA (Left, Right : Address) return Address is + begin + return A (I (Left) or I (Right)); + end OrA; + + ---------- + -- SubA -- + ---------- + + function SubA (Left, Right : Address) return Address is + begin + return A (I (Left) - I (Right)); + end SubA; + +end System.Address_Operations; diff --git a/gcc/ada/libgnat/s-addope.ads b/gcc/ada/libgnat/s-addope.ads new file mode 100644 index 0000000..8a11b69 --- /dev/null +++ b/gcc/ada/libgnat/s-addope.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides arithmetic and logical operations on type Address. +-- It is intended for use by other packages in the System hierarchy. For +-- applications requiring this capability, see System.Storage_Elements or +-- the operations introduced in System.Aux_DEC; + +-- The reason we need this package is that arithmetic operations may not +-- be available in the case where type Address is non-private and the +-- operations have been made abstract in the spec of System (to avoid +-- inappropriate use by applications programs). In addition, the logical +-- operations may not be available if type Address is a signed integer. + +pragma Compiler_Unit_Warning; + +package System.Address_Operations is + pragma Pure; + + -- The semantics of the arithmetic operations are those that apply to + -- a modular type with the same length as Address, i.e. they provide + -- twos complement wrap around arithmetic treating the address value + -- as an unsigned value, with no overflow checking. + + -- Note that we do not use the infix names for these operations to + -- avoid problems with ambiguities coming from declarations in package + -- Standard (which may or may not be visible depending on the exact + -- form of the declaration of type System.Address). + + -- For addition, subtraction, and multiplication, the effect of overflow + -- is 2's complement wrapping (as though the type Address were unsigned). + + -- For division and modulus operations, the caller is responsible for + -- ensuring that the Right argument is non-zero, and the effect of the + -- call is not specified if a zero argument is passed. + + function AddA (Left, Right : Address) return Address; + function SubA (Left, Right : Address) return Address; + function MulA (Left, Right : Address) return Address; + function DivA (Left, Right : Address) return Address; + function ModA (Left, Right : Address) return Address; + + -- The semantics of the logical operations are those that apply to + -- a modular type with the same length as Address, i.e. they provide + -- bit-wise operations on all bits of the value (including the sign + -- bit if Address is a signed integer type). + + function AndA (Left, Right : Address) return Address; + function OrA (Left, Right : Address) return Address; + + pragma Inline_Always (AddA); + pragma Inline_Always (SubA); + pragma Inline_Always (MulA); + pragma Inline_Always (DivA); + pragma Inline_Always (ModA); + pragma Inline_Always (AndA); + pragma Inline_Always (OrA); + +end System.Address_Operations; diff --git a/gcc/ada/libgnat/s-arit64.adb b/gcc/ada/libgnat/s-arit64.adb new file mode 100644 index 0000000..2149486 --- /dev/null +++ b/gcc/ada/libgnat/s-arit64.adb @@ -0,0 +1,605 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 6 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; use Interfaces; + +with Ada.Unchecked_Conversion; + +package body System.Arith_64 is + + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + + subtype Uns64 is Unsigned_64; + function To_Uns is new Ada.Unchecked_Conversion (Int64, Uns64); + function To_Int is new Ada.Unchecked_Conversion (Uns64, Int64); + + subtype Uns32 is Unsigned_32; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "+" (A, B : Uns32) return Uns64 is (Uns64 (A) + Uns64 (B)); + function "+" (A : Uns64; B : Uns32) return Uns64 is (A + Uns64 (B)); + -- Length doubling additions + + function "*" (A, B : Uns32) return Uns64 is (Uns64 (A) * Uns64 (B)); + -- Length doubling multiplication + + function "/" (A : Uns64; B : Uns32) return Uns64 is (A / Uns64 (B)); + -- Length doubling division + + function "&" (Hi, Lo : Uns32) return Uns64 is + (Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo)); + -- Concatenate hi, lo values to form 64-bit result + + function "abs" (X : Int64) return Uns64 is + (if X = Int64'First then 2**63 else Uns64 (Int64'(abs X))); + -- Convert absolute value of X to unsigned. Note that we can't just use + -- the expression of the Else, because it overflows for X = Int64'First. + + function "rem" (A : Uns64; B : Uns32) return Uns64 is (A rem Uns64 (B)); + -- Length doubling remainder + + function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean; + -- Determines if 96 bit value X1&X2&X3 <= Y1&Y2&Y3 + + function Lo (A : Uns64) return Uns32 is (Uns32 (A and 16#FFFF_FFFF#)); + -- Low order half of 64-bit value + + function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); + -- High order half of 64-bit value + + procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32); + -- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 with mod 2**96 wrap + + function To_Neg_Int (A : Uns64) return Int64 with Inline; + -- Convert to negative integer equivalent. If the input is in the range + -- 0 .. 2 ** 63, then the corresponding negative signed integer (obtained + -- by negating the given value) is returned, otherwise constraint error + -- is raised. + + function To_Pos_Int (A : Uns64) return Int64 with Inline; + -- Convert to positive integer equivalent. If the input is in the range + -- 0 .. 2 ** 63-1, then the corresponding non-negative signed integer is + -- returned, otherwise constraint error is raised. + + procedure Raise_Error with Inline; + pragma No_Return (Raise_Error); + -- Raise constraint error with appropriate message + + -------------------------- + -- Add_With_Ovflo_Check -- + -------------------------- + + function Add_With_Ovflo_Check (X, Y : Int64) return Int64 is + R : constant Int64 := To_Int (To_Uns (X) + To_Uns (Y)); + + begin + if X >= 0 then + if Y < 0 or else R >= 0 then + return R; + end if; + + else -- X < 0 + if Y > 0 or else R < 0 then + return R; + end if; + end if; + + Raise_Error; + end Add_With_Ovflo_Check; + + ------------------- + -- Double_Divide -- + ------------------- + + procedure Double_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean) + is + Xu : constant Uns64 := abs X; + Yu : constant Uns64 := abs Y; + + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + Zu : constant Uns64 := abs Z; + Zhi : constant Uns32 := Hi (Zu); + Zlo : constant Uns32 := Lo (Zu); + + T1, T2 : Uns64; + Du, Qu, Ru : Uns64; + Den_Pos : Boolean; + + begin + if Yu = 0 or else Zu = 0 then + Raise_Error; + end if; + + -- Compute Y * Z. Note that if the result overflows 64 bits unsigned, + -- then the rounded result is clearly zero (since the dividend is at + -- most 2**63 - 1, the extra bit of precision is nice here). + + if Yhi /= 0 then + if Zhi /= 0 then + Q := 0; + R := X; + return; + else + T2 := Yhi * Zlo; + end if; + + else + T2 := (if Zhi /= 0 then Ylo * Zhi else 0); + end if; + + T1 := Ylo * Zlo; + T2 := T2 + Hi (T1); + + if Hi (T2) /= 0 then + Q := 0; + R := X; + return; + end if; + + Du := Lo (T2) & Lo (T1); + + -- Set final signs (RM 4.5.5(27-30)) + + Den_Pos := (Y < 0) = (Z < 0); + + -- Check overflow case of largest negative number divided by 1 + + if X = Int64'First and then Du = 1 and then not Den_Pos then + Raise_Error; + end if; + + -- Perform the actual division + + Qu := Xu / Du; + Ru := Xu rem Du; + + -- Deal with rounding case + + if Round and then Ru > (Du - Uns64'(1)) / Uns64'(2) then + Qu := Qu + Uns64'(1); + end if; + + -- Case of dividend (X) sign positive + + if X >= 0 then + R := To_Int (Ru); + Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu)); + + -- Case of dividend (X) sign negative + + else + R := -To_Int (Ru); + Q := (if Den_Pos then -To_Int (Qu) else To_Int (Qu)); + end if; + end Double_Divide; + + --------- + -- Le3 -- + --------- + + function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean is + begin + if X1 < Y1 then + return True; + elsif X1 > Y1 then + return False; + elsif X2 < Y2 then + return True; + elsif X2 > Y2 then + return False; + else + return X3 <= Y3; + end if; + end Le3; + + ------------------------------- + -- Multiply_With_Ovflo_Check -- + ------------------------------- + + function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is + Xu : constant Uns64 := abs X; + Xhi : constant Uns32 := Hi (Xu); + Xlo : constant Uns32 := Lo (Xu); + + Yu : constant Uns64 := abs Y; + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + T1, T2 : Uns64; + + begin + if Xhi /= 0 then + if Yhi /= 0 then + Raise_Error; + else + T2 := Xhi * Ylo; + end if; + + elsif Yhi /= 0 then + T2 := Xlo * Yhi; + + else -- Yhi = Xhi = 0 + T2 := 0; + end if; + + -- Here we have T2 set to the contribution to the upper half of the + -- result from the upper halves of the input values. + + T1 := Xlo * Ylo; + T2 := T2 + Hi (T1); + + if Hi (T2) /= 0 then + Raise_Error; + end if; + + T2 := Lo (T2) & Lo (T1); + + if X >= 0 then + if Y >= 0 then + return To_Pos_Int (T2); + else + return To_Neg_Int (T2); + end if; + else -- X < 0 + if Y < 0 then + return To_Pos_Int (T2); + else + return To_Neg_Int (T2); + end if; + end if; + + end Multiply_With_Ovflo_Check; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error is + begin + raise Constraint_Error with "64-bit arithmetic overflow"; + end Raise_Error; + + ------------------- + -- Scaled_Divide -- + ------------------- + + procedure Scaled_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean) + is + Xu : constant Uns64 := abs X; + Xhi : constant Uns32 := Hi (Xu); + Xlo : constant Uns32 := Lo (Xu); + + Yu : constant Uns64 := abs Y; + Yhi : constant Uns32 := Hi (Yu); + Ylo : constant Uns32 := Lo (Yu); + + Zu : Uns64 := abs Z; + Zhi : Uns32 := Hi (Zu); + Zlo : Uns32 := Lo (Zu); + + D : array (1 .. 4) of Uns32; + -- The dividend, four digits (D(1) is high order) + + Qd : array (1 .. 2) of Uns32; + -- The quotient digits, two digits (Qd(1) is high order) + + S1, S2, S3 : Uns32; + -- Value to subtract, three digits (S1 is high order) + + Qu : Uns64; + Ru : Uns64; + -- Unsigned quotient and remainder + + Scale : Natural; + -- Scaling factor used for multiple-precision divide. Dividend and + -- Divisor are multiplied by 2 ** Scale, and the final remainder is + -- divided by the scaling factor. The reason for this scaling is to + -- allow more accurate estimation of quotient digits. + + T1, T2, T3 : Uns64; + -- Temporary values + + begin + -- First do the multiplication, giving the four digit dividend + + T1 := Xlo * Ylo; + D (4) := Lo (T1); + D (3) := Hi (T1); + + if Yhi /= 0 then + T1 := Xlo * Yhi; + T2 := D (3) + Lo (T1); + D (3) := Lo (T2); + D (2) := Hi (T1) + Hi (T2); + + if Xhi /= 0 then + T1 := Xhi * Ylo; + T2 := D (3) + Lo (T1); + D (3) := Lo (T2); + T3 := D (2) + Hi (T1); + T3 := T3 + Hi (T2); + D (2) := Lo (T3); + D (1) := Hi (T3); + + T1 := (D (1) & D (2)) + Uns64'(Xhi * Yhi); + D (1) := Hi (T1); + D (2) := Lo (T1); + + else + D (1) := 0; + end if; + + else + if Xhi /= 0 then + T1 := Xhi * Ylo; + T2 := D (3) + Lo (T1); + D (3) := Lo (T2); + D (2) := Hi (T1) + Hi (T2); + + else + D (2) := 0; + end if; + + D (1) := 0; + end if; + + -- Now it is time for the dreaded multiple precision division. First an + -- easy case, check for the simple case of a one digit divisor. + + if Zhi = 0 then + if D (1) /= 0 or else D (2) >= Zlo then + Raise_Error; + + -- Here we are dividing at most three digits by one digit + + else + T1 := D (2) & D (3); + T2 := Lo (T1 rem Zlo) & D (4); + + Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); + Ru := T2 rem Zlo; + end if; + + -- If divisor is double digit and too large, raise error + + elsif (D (1) & D (2)) >= Zu then + Raise_Error; + + -- This is the complex case where we definitely have a double digit + -- divisor and a dividend of at least three digits. We use the classical + -- multiple division algorithm (see section (4.3.1) of Knuth's "The Art + -- of Computer Programming", Vol. 2 for a description (algorithm D). + + else + -- First normalize the divisor so that it has the leading bit on. + -- We do this by finding the appropriate left shift amount. + + Scale := 0; + + if (Zhi and 16#FFFF0000#) = 0 then + Scale := 16; + Zu := Shift_Left (Zu, 16); + end if; + + if (Hi (Zu) and 16#FF00_0000#) = 0 then + Scale := Scale + 8; + Zu := Shift_Left (Zu, 8); + end if; + + if (Hi (Zu) and 16#F000_0000#) = 0 then + Scale := Scale + 4; + Zu := Shift_Left (Zu, 4); + end if; + + if (Hi (Zu) and 16#C000_0000#) = 0 then + Scale := Scale + 2; + Zu := Shift_Left (Zu, 2); + end if; + + if (Hi (Zu) and 16#8000_0000#) = 0 then + Scale := Scale + 1; + Zu := Shift_Left (Zu, 1); + end if; + + Zhi := Hi (Zu); + Zlo := Lo (Zu); + + -- Note that when we scale up the dividend, it still fits in four + -- digits, since we already tested for overflow, and scaling does + -- not change the invariant that (D (1) & D (2)) >= Zu. + + T1 := Shift_Left (D (1) & D (2), Scale); + D (1) := Hi (T1); + T2 := Shift_Left (0 & D (3), Scale); + D (2) := Lo (T1) or Hi (T2); + T3 := Shift_Left (0 & D (4), Scale); + D (3) := Lo (T2) or Hi (T3); + D (4) := Lo (T3); + + -- Loop to compute quotient digits, runs twice for Qd(1) and Qd(2) + + for J in 0 .. 1 loop + + -- Compute next quotient digit. We have to divide three digits by + -- two digits. We estimate the quotient by dividing the leading + -- two digits by the leading digit. Given the scaling we did above + -- which ensured the first bit of the divisor is set, this gives + -- an estimate of the quotient that is at most two too high. + + Qd (J + 1) := (if D (J + 1) = Zhi + then 2 ** 32 - 1 + else Lo ((D (J + 1) & D (J + 2)) / Zhi)); + + -- Compute amount to subtract + + T1 := Qd (J + 1) * Zlo; + T2 := Qd (J + 1) * Zhi; + S3 := Lo (T1); + T1 := Hi (T1) + Lo (T2); + S2 := Lo (T1); + S1 := Hi (T1) + Hi (T2); + + -- Adjust quotient digit if it was too high + + loop + exit when Le3 (S1, S2, S3, D (J + 1), D (J + 2), D (J + 3)); + Qd (J + 1) := Qd (J + 1) - 1; + Sub3 (S1, S2, S3, 0, Zhi, Zlo); + end loop; + + -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step + + Sub3 (D (J + 1), D (J + 2), D (J + 3), S1, S2, S3); + end loop; + + -- The two quotient digits are now set, and the remainder of the + -- scaled division is in D3&D4. To get the remainder for the + -- original unscaled division, we rescale this dividend. + + -- We rescale the divisor as well, to make the proper comparison + -- for rounding below. + + Qu := Qd (1) & Qd (2); + Ru := Shift_Right (D (3) & D (4), Scale); + Zu := Shift_Right (Zu, Scale); + end if; + + -- Deal with rounding case + + if Round and then Ru > (Zu - Uns64'(1)) / Uns64'(2) then + Qu := Qu + Uns64 (1); + end if; + + -- Set final signs (RM 4.5.5(27-30)) + + -- Case of dividend (X * Y) sign positive + + if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then + R := To_Pos_Int (Ru); + Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); + + -- Case of dividend (X * Y) sign negative + + else + R := To_Neg_Int (Ru); + Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); + end if; + end Scaled_Divide; + + ---------- + -- Sub3 -- + ---------- + + procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32) is + begin + if Y3 > X3 then + if X2 = 0 then + X1 := X1 - 1; + end if; + + X2 := X2 - 1; + end if; + + X3 := X3 - Y3; + + if Y2 > X2 then + X1 := X1 - 1; + end if; + + X2 := X2 - Y2; + X1 := X1 - Y1; + end Sub3; + + ------------------------------- + -- Subtract_With_Ovflo_Check -- + ------------------------------- + + function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64 is + R : constant Int64 := To_Int (To_Uns (X) - To_Uns (Y)); + + begin + if X >= 0 then + if Y > 0 or else R >= 0 then + return R; + end if; + + else -- X < 0 + if Y <= 0 or else R < 0 then + return R; + end if; + end if; + + Raise_Error; + end Subtract_With_Ovflo_Check; + + ---------------- + -- To_Neg_Int -- + ---------------- + + function To_Neg_Int (A : Uns64) return Int64 is + R : constant Int64 := (if A = 2**63 then Int64'First else -To_Int (A)); + -- Note that we can't just use the expression of the Else, because it + -- overflows for A = 2**63. + begin + if R <= 0 then + return R; + else + Raise_Error; + end if; + end To_Neg_Int; + + ---------------- + -- To_Pos_Int -- + ---------------- + + function To_Pos_Int (A : Uns64) return Int64 is + R : constant Int64 := To_Int (A); + begin + if R >= 0 then + return R; + else + Raise_Error; + end if; + end To_Pos_Int; + +end System.Arith_64; diff --git a/gcc/ada/libgnat/s-arit64.ads b/gcc/ada/libgnat/s-arit64.ads new file mode 100644 index 0000000..921ffcd --- /dev/null +++ b/gcc/ada/libgnat/s-arit64.ads @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A R I T H _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides software routines for doing arithmetic on 64-bit +-- signed integer values in cases where either overflow checking is +-- required, or intermediate results are longer than 64 bits. + +pragma Restrictions (No_Elaboration_Code); +-- Allow direct call from gigi generated code + +with Interfaces; + +package System.Arith_64 is + pragma Pure; + + subtype Int64 is Interfaces.Integer_64; + + function Add_With_Ovflo_Check (X, Y : Int64) return Int64; + -- Raises Constraint_Error if sum of operands overflows 64 bits, + -- otherwise returns the 64-bit signed integer sum. + + function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64; + -- Raises Constraint_Error if difference of operands overflows 64 + -- bits, otherwise returns the 64-bit signed integer difference. + + function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64; + pragma Export (C, Multiply_With_Ovflo_Check, "__gnat_mulv64"); + -- Raises Constraint_Error if product of operands overflows 64 + -- bits, otherwise returns the 64-bit signed integer product. + -- GIGI may also call this routine directly. + + procedure Scaled_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean); + -- Performs the division of (X * Y) / Z, storing the quotient in Q + -- and the remainder in R. Constraint_Error is raised if Z is zero, + -- or if the quotient does not fit in 64-bits. Round indicates if + -- the result should be rounded. If Round is False, then Q, R are + -- the normal quotient and remainder from a truncating division. + -- If Round is True, then Q is the rounded quotient. The remainder + -- R is not affected by the setting of the Round flag. + + procedure Double_Divide + (X, Y, Z : Int64; + Q, R : out Int64; + Round : Boolean); + -- Performs the division X / (Y * Z), storing the quotient in Q and + -- the remainder in R. Constraint_Error is raised if Y or Z is zero, + -- or if the quotient does not fit in 64-bits. Round indicates if the + -- result should be rounded. If Round is False, then Q, R are the normal + -- quotient and remainder from a truncating division. If Round is True, + -- then Q is the rounded quotient. The remainder R is not affected by the + -- setting of the Round flag. + +end System.Arith_64; diff --git a/gcc/ada/libgnat/s-assert.adb b/gcc/ada/libgnat/s-assert.adb new file mode 100644 index 0000000..e02ffd1 --- /dev/null +++ b/gcc/ada/libgnat/s-assert.adb @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A S S E R T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Exceptions; +with System.Exceptions_Debug; + +package body System.Assertions is + + -------------------------- + -- Raise_Assert_Failure -- + -------------------------- + + procedure Raise_Assert_Failure (Msg : String) is + begin + System.Exceptions_Debug.Debug_Raise_Assert_Failure; + Ada.Exceptions.Raise_Exception (Assert_Failure'Identity, Msg); + end Raise_Assert_Failure; + +end System.Assertions; diff --git a/gcc/ada/libgnat/s-assert.ads b/gcc/ada/libgnat/s-assert.ads new file mode 100644 index 0000000..3fe02a7 --- /dev/null +++ b/gcc/ada/libgnat/s-assert.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A S S E R T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides support for assertions (including pragma Assert, +-- pragma Debug, and Precondition/Postcondition/Predicate/Invariant aspects +-- and their corresponding pragmas). + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +pragma Compiler_Unit_Warning; + +package System.Assertions is + + Assert_Failure : exception; + -- Exception raised when assertion fails + + procedure Raise_Assert_Failure (Msg : String); + pragma No_Return (Raise_Assert_Failure); + -- Called to raise Assert_Failure with given message + +end System.Assertions; diff --git a/gcc/ada/libgnat/s-atacco.adb b/gcc/ada/libgnat/s-atacco.adb new file mode 100644 index 0000000..efdc42a --- /dev/null +++ b/gcc/ada/libgnat/s-atacco.adb @@ -0,0 +1,36 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +pragma No_Body; diff --git a/gcc/ada/libgnat/s-atacco.ads b/gcc/ada/libgnat/s-atacco.ads new file mode 100644 index 0000000..f006cb2 --- /dev/null +++ b/gcc/ada/libgnat/s-atacco.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Object (<>) is limited private; + +package System.Address_To_Access_Conversions is + pragma Preelaborate; + + pragma Compile_Time_Warning + (Object'Unconstrained_Array, + "Object is unconstrained array type" & ASCII.LF & + "To_Pointer results may not have bounds"); + + type Object_Pointer is access all Object; + for Object_Pointer'Size use Standard'Address_Size; + + pragma No_Strict_Aliasing (Object_Pointer); + -- Strictly speaking, this routine should not be used to generate pointers + -- to other than proper values of the proper type, but in practice, this + -- is done all the time. This pragma stops the compiler from doing some + -- optimizations that may cause unexpected results based on the assumption + -- of no strict aliasing. + + function To_Pointer (Value : Address) return Object_Pointer; + function To_Address (Value : Object_Pointer) return Address; + + pragma Import (Intrinsic, To_Pointer); + pragma Import (Intrinsic, To_Address); + +end System.Address_To_Access_Conversions; diff --git a/gcc/ada/libgnat/s-atocou-builtin.adb b/gcc/ada/libgnat/s-atocou-builtin.adb new file mode 100644 index 0000000..1b5b66a --- /dev/null +++ b/gcc/ada/libgnat/s-atocou-builtin.adb @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements Atomic_Counter and Atomic_Unsigned operations +-- for platforms where GCC supports __sync_add_and_fetch_4 and +-- __sync_sub_and_fetch_4 builtins. + +package body System.Atomic_Counters is + + procedure Sync_Add_And_Fetch + (Ptr : access Atomic_Unsigned; + Value : Atomic_Unsigned); + pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); + + function Sync_Sub_And_Fetch + (Ptr : access Atomic_Unsigned; + Value : Atomic_Unsigned) return Atomic_Unsigned; + pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); + + --------------- + -- Decrement -- + --------------- + + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then + null; + end if; + end Decrement; + + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is + begin + return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0; + end Decrement; + + function Decrement (Item : in out Atomic_Counter) return Boolean is + begin + -- Note: the use of Unrestricted_Access here is required because we + -- are obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0; + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Item : aliased in out Atomic_Unsigned) is + begin + Sync_Add_And_Fetch (Item'Unrestricted_Access, 1); + end Increment; + + procedure Increment (Item : in out Atomic_Counter) is + begin + -- Note: the use of Unrestricted_Access here is required because we are + -- obtaining an access-to-volatile pointer to a non-volatile object. + -- This is not allowed for [Unchecked_]Access, but is safe in this case + -- because we know that no aliases are being created. + + Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1); + end Increment; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + Item.Value := 1; + end Initialize; + + ------------ + -- Is_One -- + ------------ + + function Is_One (Item : Atomic_Counter) return Boolean is + begin + return Item.Value = 1; + end Is_One; + +end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-atocou-x86.adb b/gcc/ada/libgnat/s-atocou-x86.adb new file mode 100644 index 0000000..eb69a49e --- /dev/null +++ b/gcc/ada/libgnat/s-atocou-x86.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation of the package for x86 processor. GCC can't generate +-- code for atomic builtins for 386 CPU. Only increment/decrement instructions +-- are supported, thus this implementaton uses machine code insertions to +-- access the necessary instructions. + +with System.Machine_Code; + +package body System.Atomic_Counters is + + -- Add comments showing in normal asm language what we generate??? + + --------------- + -- Decrement -- + --------------- + + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is + Aux : Boolean; + + begin + System.Machine_Code.Asm + (Template => + "lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT + & "sete %1", + Outputs => + (Atomic_Unsigned'Asm_Output ("=m", Item), + Boolean'Asm_Output ("=qm", Aux)), + Inputs => Atomic_Unsigned'Asm_Input ("m", Item), + Volatile => True); + + return Aux; + end Decrement; + + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + if Decrement (Item) then + null; + end if; + end Decrement; + + function Decrement (Item : in out Atomic_Counter) return Boolean is + begin + return Decrement (Item.Value); + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Item : aliased in out Atomic_Unsigned) is + begin + System.Machine_Code.Asm + (Template => "lock%; incl" & ASCII.HT & "%0", + Outputs => Atomic_Unsigned'Asm_Output ("=m", Item), + Inputs => Atomic_Unsigned'Asm_Input ("m", Item), + Volatile => True); + end Increment; + + procedure Increment (Item : in out Atomic_Counter) is + begin + Increment (Item.Value); + end Increment; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + Item.Value := 1; + end Initialize; + + ------------ + -- Is_One -- + ------------ + + function Is_One (Item : Atomic_Counter) return Boolean is + begin + return Item.Value = 1; + end Is_One; + +end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-atocou.adb b/gcc/ada/libgnat/s-atocou.adb new file mode 100644 index 0000000..9057c5f --- /dev/null +++ b/gcc/ada/libgnat/s-atocou.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is version of the package, for use on platforms where this capability +-- is not supported. All Atomic_Counter operations raises Program_Error, +-- Atomic_Unsigned operations processed in non-atomic manner. + +package body System.Atomic_Counters is + + --------------- + -- Decrement -- + --------------- + + function Decrement (Item : in out Atomic_Counter) return Boolean is + begin + raise Program_Error; + return False; + end Decrement; + + function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is + begin + -- Could not use Item := Item - 1; because it is disabled in spec. + Item := Atomic_Unsigned'Pred (Item); + return Item = 0; + end Decrement; + + procedure Decrement (Item : aliased in out Atomic_Unsigned) is + begin + Item := Atomic_Unsigned'Pred (Item); + end Decrement; + + --------------- + -- Increment -- + --------------- + + procedure Increment (Item : in out Atomic_Counter) is + begin + raise Program_Error; + end Increment; + + procedure Increment (Item : aliased in out Atomic_Unsigned) is + begin + Item := Atomic_Unsigned'Succ (Item); + end Increment; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Item : out Atomic_Counter) is + begin + raise Program_Error; + end Initialize; + + ------------ + -- Is_One -- + ------------ + + function Is_One (Item : Atomic_Counter) return Boolean is + begin + raise Program_Error; + return False; + end Is_One; + +end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-atocou.ads b/gcc/ada/libgnat/s-atocou.ads new file mode 100644 index 0000000..ddef9ef --- /dev/null +++ b/gcc/ada/libgnat/s-atocou.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ C O U N T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides atomic counter on platforms where it is supported: +-- - all Alpha platforms +-- - all ia64 platforms +-- - all PowerPC platforms +-- - all SPARC V9 platforms +-- - all x86 platforms +-- - all x86_64 platforms + +package System.Atomic_Counters is + + pragma Pure; + pragma Preelaborate; + + type Atomic_Counter is limited private; + -- Type for atomic counter objects. Note, initial value of the counter is + -- one. This allows using an atomic counter as member of record types when + -- object of these types are created at library level in preelaborable + -- compilation units. + -- + -- Atomic_Counter is declared as private limited type to provide highest + -- level of protection from unexpected use. All available operations are + -- declared below, and this set should be as small as possible. + -- Increment/Decrement operations for this type raise Program_Error on + -- platforms not supporting the atomic primitives. + + procedure Increment (Item : in out Atomic_Counter); + pragma Inline_Always (Increment); + -- Increments value of atomic counter. + + function Decrement (Item : in out Atomic_Counter) return Boolean; + pragma Inline_Always (Decrement); + -- Decrements value of atomic counter, returns True when value reach zero + + function Is_One (Item : Atomic_Counter) return Boolean; + pragma Inline_Always (Is_One); + -- Returns True when value of the atomic counter is one + + procedure Initialize (Item : out Atomic_Counter); + pragma Inline_Always (Initialize); + -- Initialize counter by setting its value to one. This subprogram is + -- intended to be used in special cases when the counter object cannot be + -- initialized in standard way. + + type Atomic_Unsigned is mod 2 ** 32 with Default_Value => 0, Atomic; + -- Modular compatible atomic unsigned type. + -- Increment/Decrement operations for this type are atomic only on + -- supported platforms. See top of the file. + + procedure Increment + (Item : aliased in out Atomic_Unsigned) with Inline_Always; + -- Increments value of atomic counter + + function Decrement + (Item : aliased in out Atomic_Unsigned) return Boolean with Inline_Always; + + procedure Decrement + (Item : aliased in out Atomic_Unsigned) with Inline_Always; + -- Decrements value of atomic counter + + -- The "+" and "-" abstract routine provided below to disable BT := BT + 1 + -- constructions. + + function "+" + (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract; + + function "-" + (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract; + +private + + type Atomic_Counter is record + Value : aliased Atomic_Unsigned := 1; + pragma Atomic (Value); + end record; + +end System.Atomic_Counters; diff --git a/gcc/ada/libgnat/s-atopri.adb b/gcc/ada/libgnat/s-atopri.adb new file mode 100644 index 0000000..91a2ba8 --- /dev/null +++ b/gcc/ada/libgnat/s-atopri.adb @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Atomic_Primitives is + + ---------------------- + -- Lock_Free_Read_8 -- + ---------------------- + + function Lock_Free_Read_8 (Ptr : Address) return uint8 is + begin + if uint8'Atomic_Always_Lock_Free then + return Atomic_Load_8 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_8; + + ----------------------- + -- Lock_Free_Read_16 -- + ----------------------- + + function Lock_Free_Read_16 (Ptr : Address) return uint16 is + begin + if uint16'Atomic_Always_Lock_Free then + return Atomic_Load_16 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_16; + + ----------------------- + -- Lock_Free_Read_32 -- + ----------------------- + + function Lock_Free_Read_32 (Ptr : Address) return uint32 is + begin + if uint32'Atomic_Always_Lock_Free then + return Atomic_Load_32 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_32; + + ----------------------- + -- Lock_Free_Read_64 -- + ----------------------- + + function Lock_Free_Read_64 (Ptr : Address) return uint64 is + begin + if uint64'Atomic_Always_Lock_Free then + return Atomic_Load_64 (Ptr, Acquire); + else + raise Program_Error; + end if; + end Lock_Free_Read_64; + + --------------------------- + -- Lock_Free_Try_Write_8 -- + --------------------------- + + function Lock_Free_Try_Write_8 + (Ptr : Address; + Expected : in out uint8; + Desired : uint8) return Boolean + is + Actual : uint8; + + begin + if Expected /= Desired then + + if uint8'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_8 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_8; + + ---------------------------- + -- Lock_Free_Try_Write_16 -- + ---------------------------- + + function Lock_Free_Try_Write_16 + (Ptr : Address; + Expected : in out uint16; + Desired : uint16) return Boolean + is + Actual : uint16; + + begin + if Expected /= Desired then + + if uint16'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_16 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_16; + + ---------------------------- + -- Lock_Free_Try_Write_32 -- + ---------------------------- + + function Lock_Free_Try_Write_32 + (Ptr : Address; + Expected : in out uint32; + Desired : uint32) return Boolean + is + Actual : uint32; + + begin + if Expected /= Desired then + + if uint32'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_32 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_32; + + ---------------------------- + -- Lock_Free_Try_Write_64 -- + ---------------------------- + + function Lock_Free_Try_Write_64 + (Ptr : Address; + Expected : in out uint64; + Desired : uint64) return Boolean + is + Actual : uint64; + + begin + if Expected /= Desired then + + if uint64'Atomic_Always_Lock_Free then + Actual := Sync_Compare_And_Swap_64 (Ptr, Expected, Desired); + else + raise Program_Error; + end if; + + if Actual /= Expected then + Expected := Actual; + return False; + end if; + end if; + + return True; + end Lock_Free_Try_Write_64; +end System.Atomic_Primitives; diff --git a/gcc/ada/libgnat/s-atopri.ads b/gcc/ada/libgnat/s-atopri.ads new file mode 100644 index 0000000..b9c9251 --- /dev/null +++ b/gcc/ada/libgnat/s-atopri.ads @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . A T O M I C _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2012-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains both atomic primitives defined from gcc built-in +-- functions and operations used by the compiler to generate the lock-free +-- implementation of protected objects. + +package System.Atomic_Primitives is + pragma Preelaborate; + + type uint is mod 2 ** Long_Integer'Size; + + type uint8 is mod 2**8 + with Size => 8; + + type uint16 is mod 2**16 + with Size => 16; + + type uint32 is mod 2**32 + with Size => 32; + + type uint64 is mod 2**64 + with Size => 64; + + Relaxed : constant := 0; + Consume : constant := 1; + Acquire : constant := 2; + Release : constant := 3; + Acq_Rel : constant := 4; + Seq_Cst : constant := 5; + Last : constant := 6; + + subtype Mem_Model is Integer range Relaxed .. Last; + + ------------------------------------ + -- GCC built-in atomic primitives -- + ------------------------------------ + + function Atomic_Load_8 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint8; + pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); + + function Atomic_Load_16 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint16; + pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); + + function Atomic_Load_32 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint32; + pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); + + function Atomic_Load_64 + (Ptr : Address; + Model : Mem_Model := Seq_Cst) return uint64; + pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); + + function Sync_Compare_And_Swap_8 + (Ptr : Address; + Expected : uint8; + Desired : uint8) return uint8; + pragma Import (Intrinsic, + Sync_Compare_And_Swap_8, + "__sync_val_compare_and_swap_1"); + + -- ??? Should use __atomic_compare_exchange_1 (doesn't work yet): + -- function Sync_Compare_And_Swap_8 + -- (Ptr : Address; + -- Expected : Address; + -- Desired : uint8; + -- Weak : Boolean := False; + -- Success_Model : Mem_Model := Seq_Cst; + -- Failure_Model : Mem_Model := Seq_Cst) return Boolean; + -- pragma Import (Intrinsic, + -- Sync_Compare_And_Swap_8, + -- "__atomic_compare_exchange_1"); + + function Sync_Compare_And_Swap_16 + (Ptr : Address; + Expected : uint16; + Desired : uint16) return uint16; + pragma Import (Intrinsic, + Sync_Compare_And_Swap_16, + "__sync_val_compare_and_swap_2"); + + function Sync_Compare_And_Swap_32 + (Ptr : Address; + Expected : uint32; + Desired : uint32) return uint32; + pragma Import (Intrinsic, + Sync_Compare_And_Swap_32, + "__sync_val_compare_and_swap_4"); + + function Sync_Compare_And_Swap_64 + (Ptr : Address; + Expected : uint64; + Desired : uint64) return uint64; + pragma Import (Intrinsic, + Sync_Compare_And_Swap_64, + "__sync_val_compare_and_swap_8"); + + -------------------------- + -- Lock-free operations -- + -------------------------- + + -- The lock-free implementation uses two atomic instructions for the + -- expansion of protected operations: + + -- * Lock_Free_Read_N atomically loads the value of the protected component + -- accessed by the current protected operation. + + -- * Lock_Free_Try_Write_N tries to write the Desired value into Ptr only + -- if Expected and Desired mismatch. + + function Lock_Free_Read_8 (Ptr : Address) return uint8; + + function Lock_Free_Read_16 (Ptr : Address) return uint16; + + function Lock_Free_Read_32 (Ptr : Address) return uint32; + + function Lock_Free_Read_64 (Ptr : Address) return uint64; + + function Lock_Free_Try_Write_8 + (Ptr : Address; + Expected : in out uint8; + Desired : uint8) return Boolean; + + function Lock_Free_Try_Write_16 + (Ptr : Address; + Expected : in out uint16; + Desired : uint16) return Boolean; + + function Lock_Free_Try_Write_32 + (Ptr : Address; + Expected : in out uint32; + Desired : uint32) return Boolean; + + function Lock_Free_Try_Write_64 + (Ptr : Address; + Expected : in out uint64; + Desired : uint64) return Boolean; + + pragma Inline (Lock_Free_Read_8); + pragma Inline (Lock_Free_Read_16); + pragma Inline (Lock_Free_Read_32); + pragma Inline (Lock_Free_Read_64); + pragma Inline (Lock_Free_Try_Write_8); + pragma Inline (Lock_Free_Try_Write_16); + pragma Inline (Lock_Free_Try_Write_32); + pragma Inline (Lock_Free_Try_Write_64); +end System.Atomic_Primitives; diff --git a/gcc/ada/libgnat/s-auxdec.adb b/gcc/ada/libgnat/s-auxdec.adb new file mode 100644 index 0000000..5bee94a --- /dev/null +++ b/gcc/ada/libgnat/s-auxdec.adb @@ -0,0 +1,718 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/Or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Style_Checks (All_Checks); +-- Turn off alpha ordering check on subprograms, this unit is laid +-- out to correspond to the declarations in the DEC 83 System unit. + +with System.Soft_Links; + +package body System.Aux_DEC is + + package SSL renames System.Soft_Links; + + ----------------------------------- + -- Operations on Largest_Integer -- + ----------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type LIU is mod 2 ** Largest_Integer'Size; + -- Unsigned type of same length as Largest_Integer + + function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer); + function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU); + + function "not" (Left : Largest_Integer) return Largest_Integer is + begin + return To_LI (not From_LI (Left)); + end "not"; + + function "and" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) and From_LI (Right)); + end "and"; + + function "or" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) or From_LI (Right)); + end "or"; + + function "xor" (Left, Right : Largest_Integer) return Largest_Integer is + begin + return To_LI (From_LI (Left) xor From_LI (Right)); + end "xor"; + + -------------------------------------- + -- Arithmetic Operations on Address -- + -------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + Asiz : constant Integer := Integer (Address'Size) - 1; + + type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1; + -- Signed type of same size as Address + + function To_A is new Ada.Unchecked_Conversion (SA, Address); + function From_A is new Ada.Unchecked_Conversion (Address, SA); + + function "+" (Left : Address; Right : Integer) return Address is + begin + return To_A (From_A (Left) + SA (Right)); + end "+"; + + function "+" (Left : Integer; Right : Address) return Address is + begin + return To_A (SA (Left) + From_A (Right)); + end "+"; + + function "-" (Left : Address; Right : Address) return Integer is + pragma Unsuppress (All_Checks); + -- Because this can raise Constraint_Error for 64-bit addresses + begin + return Integer (From_A (Left) - From_A (Right)); + end "-"; + + function "-" (Left : Address; Right : Integer) return Address is + begin + return To_A (From_A (Left) - SA (Right)); + end "-"; + + ------------------------ + -- Fetch_From_Address -- + ------------------------ + + function Fetch_From_Address (A : Address) return Target is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + return Ptr.all; + end Fetch_From_Address; + + ----------------------- + -- Assign_To_Address -- + ----------------------- + + procedure Assign_To_Address (A : Address; T : Target) is + type T_Ptr is access all Target; + function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); + Ptr : constant T_Ptr := To_T_Ptr (A); + begin + Ptr.all := T; + end Assign_To_Address; + + --------------------------------- + -- Operations on Unsigned_Byte -- + --------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type BU is mod 2 ** Unsigned_Byte'Size; + -- Unsigned type of same length as Unsigned_Byte + + function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte); + function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU); + + function "not" (Left : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (not From_B (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) and From_B (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) or From_B (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is + begin + return To_B (From_B (Left) xor From_B (Right)); + end "xor"; + + --------------------------------- + -- Operations on Unsigned_Word -- + --------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type WU is mod 2 ** Unsigned_Word'Size; + -- Unsigned type of same length as Unsigned_Word + + function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word); + function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU); + + function "not" (Left : Unsigned_Word) return Unsigned_Word is + begin + return To_W (not From_W (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) and From_W (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) or From_W (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is + begin + return To_W (From_W (Left) xor From_W (Right)); + end "xor"; + + ------------------------------------- + -- Operations on Unsigned_Longword -- + ------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type LWU is mod 2 ** Unsigned_Longword'Size; + -- Unsigned type of same length as Unsigned_Longword + + function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword); + function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU); + + function "not" (Left : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (not From_LW (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) and From_LW (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) or From_LW (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is + begin + return To_LW (From_LW (Left) xor From_LW (Right)); + end "xor"; + + ------------------------------- + -- Operations on Unsigned_32 -- + ------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type U32 is mod 2 ** Unsigned_32'Size; + -- Unsigned type of same length as Unsigned_32 + + function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32); + function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32); + + function "not" (Left : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (not From_U32 (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) and From_U32 (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) or From_U32 (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is + begin + return To_U32 (From_U32 (Left) xor From_U32 (Right)); + end "xor"; + + ------------------------------------- + -- Operations on Unsigned_Quadword -- + ------------------------------------- + + -- It would be nice to replace these with intrinsics, but that does + -- not work yet (the back end would be ok, but GNAT itself objects) + + type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size + -- Unsigned type of same length as Unsigned_Quadword + + function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword); + function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU); + + function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (not From_QW (Left)); + end "not"; + + function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) and From_QW (Right)); + end "and"; + + function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) or From_QW (Right)); + end "or"; + + function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is + begin + return To_QW (From_QW (Left) xor From_QW (Right)); + end "xor"; + + ----------------------- + -- Clear_Interlocked -- + ----------------------- + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := False; + SSL.Unlock_Task.all; + end Clear_Interlocked; + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := False; + Success_Flag := True; + SSL.Unlock_Task.all; + end Clear_Interlocked; + + --------------------- + -- Set_Interlocked -- + --------------------- + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean) + is + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := True; + SSL.Unlock_Task.all; + end Set_Interlocked; + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := Bit; + Bit := True; + Success_Flag := True; + SSL.Unlock_Task.all; + end Set_Interlocked; + + --------------------- + -- Add_Interlocked -- + --------------------- + + procedure Add_Interlocked + (Addend : Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer) + is + begin + SSL.Lock_Task.all; + Augend.Value := Augend.Value + Addend; + + if Augend.Value < 0 then + Sign := -1; + elsif Augend.Value > 0 then + Sign := +1; + else + Sign := 0; + end if; + + SSL.Unlock_Task.all; + end Add_Interlocked; + + ---------------- + -- Add_Atomic -- + ---------------- + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer) + is + begin + SSL.Lock_Task.all; + To.Value := To.Value + Amount; + SSL.Unlock_Task.all; + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := To.Value + Amount; + Success_Flag := True; + SSL.Unlock_Task.all; + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer) + is + begin + SSL.Lock_Task.all; + To.Value := To.Value + Amount; + SSL.Unlock_Task.all; + end Add_Atomic; + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := To.Value + Amount; + Success_Flag := True; + SSL.Unlock_Task.all; + end Add_Atomic; + + ---------------- + -- And_Atomic -- + ---------------- + + type IU is mod 2 ** Integer'Size; + type LU is mod 2 ** Long_Integer'Size; + + function To_IU is new Ada.Unchecked_Conversion (Integer, IU); + function From_IU is new Ada.Unchecked_Conversion (IU, Integer); + + function To_LU is new Ada.Unchecked_Conversion (Long_Integer, LU); + function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_IU (To_IU (To.Value) and To_IU (From)); + SSL.Unlock_Task.all; + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_IU (To_IU (To.Value) and To_IU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_LU (To_LU (To.Value) and To_LU (From)); + SSL.Unlock_Task.all; + end And_Atomic; + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_LU (To_LU (To.Value) and To_LU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end And_Atomic; + + --------------- + -- Or_Atomic -- + --------------- + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_IU (To_IU (To.Value) or To_IU (From)); + SSL.Unlock_Task.all; + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_IU (To_IU (To.Value) or To_IU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer) + is + begin + SSL.Lock_Task.all; + To.Value := From_LU (To_LU (To.Value) or To_LU (From)); + SSL.Unlock_Task.all; + end Or_Atomic; + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean) + is + pragma Warnings (Off, Retry_Count); + + begin + SSL.Lock_Task.all; + Old_Value := To.Value; + To.Value := From_LU (To_LU (To.Value) or To_LU (From)); + Success_Flag := True; + SSL.Unlock_Task.all; + end Or_Atomic; + + ------------------------------------ + -- Declarations for Queue Objects -- + ------------------------------------ + + type QR; + + type QR_Ptr is access QR; + + type QR is record + Forward : QR_Ptr; + Backward : QR_Ptr; + end record; + + function To_QR_Ptr is new Ada.Unchecked_Conversion (Address, QR_Ptr); + function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address); + + ------------ + -- Insqhi -- + ------------ + + procedure Insqhi + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Next : constant QR_Ptr := Hedr.Forward; + Itm : constant QR_Ptr := To_QR_Ptr (Item); + + begin + SSL.Lock_Task.all; + + Itm.Forward := Next; + Itm.Backward := Hedr; + Hedr.Forward := Itm; + + if Next = null then + Status := OK_First; + + else + Next.Backward := Itm; + Status := OK_Not_First; + end if; + + SSL.Unlock_Task.all; + end Insqhi; + + ------------ + -- Remqhi -- + ------------ + + procedure Remqhi + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Next : constant QR_Ptr := Hedr.Forward; + + begin + SSL.Lock_Task.all; + + Item := From_QR_Ptr (Next); + + if Next = null then + Status := Fail_Was_Empty; + + else + Hedr.Forward := To_QR_Ptr (Item).Forward; + + if Hedr.Forward = null then + Status := OK_Empty; + + else + Hedr.Forward.Backward := Hedr; + Status := OK_Not_Empty; + end if; + end if; + + SSL.Unlock_Task.all; + end Remqhi; + + ------------ + -- Insqti -- + ------------ + + procedure Insqti + (Item : Address; + Header : Address; + Status : out Insq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Prev : constant QR_Ptr := Hedr.Backward; + Itm : constant QR_Ptr := To_QR_Ptr (Item); + + begin + SSL.Lock_Task.all; + + Itm.Backward := Prev; + Itm.Forward := Hedr; + Hedr.Backward := Itm; + + if Prev = null then + Status := OK_First; + + else + Prev.Forward := Itm; + Status := OK_Not_First; + end if; + + SSL.Unlock_Task.all; + end Insqti; + + ------------ + -- Remqti -- + ------------ + + procedure Remqti + (Header : Address; + Item : out Address; + Status : out Remq_Status) + is + Hedr : constant QR_Ptr := To_QR_Ptr (Header); + Prev : constant QR_Ptr := Hedr.Backward; + + begin + SSL.Lock_Task.all; + + Item := From_QR_Ptr (Prev); + + if Prev = null then + Status := Fail_Was_Empty; + + else + Hedr.Backward := To_QR_Ptr (Item).Backward; + + if Hedr.Backward = null then + Status := OK_Empty; + + else + Hedr.Backward.Forward := Hedr; + Status := OK_Not_Empty; + end if; + end if; + + SSL.Unlock_Task.all; + end Remqti; + +end System.Aux_DEC; diff --git a/gcc/ada/libgnat/s-auxdec.ads b/gcc/ada/libgnat/s-auxdec.ads new file mode 100644 index 0000000..d3086c7 --- /dev/null +++ b/gcc/ada/libgnat/s-auxdec.ads @@ -0,0 +1,656 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . A U X _ D E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains definitions that are designed to be compatible +-- with the extra definitions in package System for DEC Ada implementations. + +-- These definitions can be used directly by withing this package, or merged +-- with System using pragma Extend_System (Aux_DEC) + +with Ada.Unchecked_Conversion; + +package System.Aux_DEC is + pragma Preelaborate; + + subtype Short_Address is Address; + -- For compatibility with systems having short and long addresses + + type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; + for Integer_8'Size use 8; + + type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1; + for Integer_16'Size use 16; + + type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; + for Integer_32'Size use 32; + + type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1; + for Integer_64'Size use 64; + + type Integer_8_Array is array (Integer range <>) of Integer_8; + type Integer_16_Array is array (Integer range <>) of Integer_16; + type Integer_32_Array is array (Integer range <>) of Integer_32; + type Integer_64_Array is array (Integer range <>) of Integer_64; + -- These array types are not in all versions of DEC System, and in fact it + -- is not quite clear why they are in some and not others, but since they + -- definitely appear in some versions, we include them unconditionally. + + type Largest_Integer is range Min_Int .. Max_Int; + + type AST_Handler is private; + + No_AST_Handler : constant AST_Handler; + + type Type_Class is + (Type_Class_Enumeration, + Type_Class_Integer, + Type_Class_Fixed_Point, + Type_Class_Floating_Point, + Type_Class_Array, + Type_Class_Record, + Type_Class_Access, + Type_Class_Task, -- also in Ada 95 protected + Type_Class_Address); + + function "not" (Left : Largest_Integer) return Largest_Integer; + function "and" (Left, Right : Largest_Integer) return Largest_Integer; + function "or" (Left, Right : Largest_Integer) return Largest_Integer; + function "xor" (Left, Right : Largest_Integer) return Largest_Integer; + + Address_Zero : constant Address; + No_Addr : constant Address; + Address_Size : constant := Standard'Address_Size; + Short_Address_Size : constant := Standard'Address_Size; + + function "+" (Left : Address; Right : Integer) return Address; + function "+" (Left : Integer; Right : Address) return Address; + function "-" (Left : Address; Right : Address) return Integer; + function "-" (Left : Address; Right : Integer) return Address; + + generic + type Target is private; + function Fetch_From_Address (A : Address) return Target; + + generic + type Target is private; + procedure Assign_To_Address (A : Address; T : Target); + + -- Floating point type declarations for VAX floating point data types + + type F_Float is digits 6; + type D_Float is digits 9; + type G_Float is digits 15; + -- We provide the type names, but these will be IEEE format, not VAX format + + -- Floating point type declarations for IEEE floating point data types + + type IEEE_Single_Float is digits 6; + type IEEE_Double_Float is digits 15; + + Non_Ada_Error : exception; + + -- Hardware-oriented types and functions + + type Bit_Array is array (Integer range <>) of Boolean; + pragma Pack (Bit_Array); + + subtype Bit_Array_8 is Bit_Array (0 .. 7); + subtype Bit_Array_16 is Bit_Array (0 .. 15); + subtype Bit_Array_32 is Bit_Array (0 .. 31); + subtype Bit_Array_64 is Bit_Array (0 .. 63); + + type Unsigned_Byte is range 0 .. 255; + for Unsigned_Byte'Size use 8; + + function "not" (Left : Unsigned_Byte) return Unsigned_Byte; + function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte; + + function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte; + function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8; + + type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte; + + type Unsigned_Word is range 0 .. 65535; + for Unsigned_Word'Size use 16; + + function "not" (Left : Unsigned_Word) return Unsigned_Word; + function "and" (Left, Right : Unsigned_Word) return Unsigned_Word; + function "or" (Left, Right : Unsigned_Word) return Unsigned_Word; + function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word; + + function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word; + function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16; + + type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word; + + type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647; + for Unsigned_Longword'Size use 32; + + function "not" (Left : Unsigned_Longword) return Unsigned_Longword; + function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword; + + function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword; + function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32; + + type Unsigned_Longword_Array is + array (Integer range <>) of Unsigned_Longword; + + type Unsigned_32 is range 0 .. 4_294_967_295; + for Unsigned_32'Size use 32; + + function "not" (Left : Unsigned_32) return Unsigned_32; + function "and" (Left, Right : Unsigned_32) return Unsigned_32; + function "or" (Left, Right : Unsigned_32) return Unsigned_32; + function "xor" (Left, Right : Unsigned_32) return Unsigned_32; + + function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32; + function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32; + + type Unsigned_Quadword is record + L0 : Unsigned_Longword; + L1 : Unsigned_Longword; + end record; + + for Unsigned_Quadword'Size use 64; + for Unsigned_Quadword'Alignment use + Integer'Min (8, Standard'Maximum_Alignment); + + function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword; + function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; + + function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword; + function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64; + + type Unsigned_Quadword_Array is + array (Integer range <>) of Unsigned_Quadword; + + function To_Address (X : Integer) return Address; + pragma Pure_Function (To_Address); + + function To_Address_Long (X : Unsigned_Longword) return Address; + pragma Pure_Function (To_Address_Long); + + function To_Integer (X : Address) return Integer; + + function To_Unsigned_Longword (X : Address) return Unsigned_Longword; + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; + + -- Conventional names for static subtypes of type UNSIGNED_LONGWORD + + subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1 - 1; + subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2 - 1; + subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3 - 1; + subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4 - 1; + subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5 - 1; + subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6 - 1; + subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7 - 1; + subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8 - 1; + subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9 - 1; + subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10 - 1; + subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11 - 1; + subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12 - 1; + subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13 - 1; + subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14 - 1; + subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15 - 1; + subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16 - 1; + subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17 - 1; + subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18 - 1; + subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19 - 1; + subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20 - 1; + subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21 - 1; + subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22 - 1; + subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23 - 1; + subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24 - 1; + subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25 - 1; + subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26 - 1; + subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27 - 1; + subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28 - 1; + subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29 - 1; + subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30 - 1; + subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31 - 1; + + -- Function for obtaining global symbol values + + function Import_Value (Symbol : String) return Unsigned_Longword; + function Import_Address (Symbol : String) return Address; + function Import_Largest_Value (Symbol : String) return Largest_Integer; + + pragma Import (Intrinsic, Import_Value); + pragma Import (Intrinsic, Import_Address); + pragma Import (Intrinsic, Import_Largest_Value); + + -- For the following declarations, note that the declaration without a + -- Retry_Count parameter means to retry infinitely. A value of zero for + -- the Retry_Count parameter means do not retry. + + -- Interlocked-instruction procedures + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean); + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean); + + type Aligned_Word is record + Value : Short_Integer; + end record; + + for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment); + + procedure Clear_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean); + + procedure Set_Interlocked + (Bit : in out Boolean; + Old_Value : out Boolean; + Retry_Count : Natural; + Success_Flag : out Boolean); + + procedure Add_Interlocked + (Addend : Short_Integer; + Augend : in out Aligned_Word; + Sign : out Integer); + + type Aligned_Integer is record + Value : Integer; + end record; + + for Aligned_Integer'Alignment use + Integer'Min (4, Standard'Maximum_Alignment); + + type Aligned_Long_Integer is record + Value : Long_Integer; + end record; + + for Aligned_Long_Integer'Alignment use + Integer'Min (8, Standard'Maximum_Alignment); + + -- For the following declarations, note that the declaration without a + -- Retry_Count parameter mean to retry infinitely. A value of zero for + -- the Retry_Count means do not retry. + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer); + + procedure Add_Atomic + (To : in out Aligned_Integer; + Amount : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer); + + procedure Add_Atomic + (To : in out Aligned_Long_Integer; + Amount : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer); + + procedure And_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer); + + procedure And_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer); + + procedure Or_Atomic + (To : in out Aligned_Integer; + From : Integer; + Retry_Count : Natural; + Old_Value : out Integer; + Success_Flag : out Boolean); + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer); + + procedure Or_Atomic + (To : in out Aligned_Long_Integer; + From : Long_Integer; + Retry_Count : Natural; + Old_Value : out Long_Integer; + Success_Flag : out Boolean); + + type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First); + + for Insq_Status use + (Fail_No_Lock => -1, + OK_Not_First => 0, + OK_First => +1); + + type Remq_Status is ( + Fail_No_Lock, + Fail_Was_Empty, + OK_Not_Empty, + OK_Empty); + + for Remq_Status use + (Fail_No_Lock => -1, + Fail_Was_Empty => 0, + OK_Not_Empty => +1, + OK_Empty => +2); + + procedure Insqhi + (Item : Address; + Header : Address; + Status : out Insq_Status); + + procedure Remqhi + (Header : Address; + Item : out Address; + Status : out Remq_Status); + + procedure Insqti + (Item : Address; + Header : Address; + Status : out Insq_Status); + + procedure Remqti + (Header : Address; + Item : out Address; + Status : out Remq_Status); + +private + + Address_Zero : constant Address := Null_Address; + No_Addr : constant Address := Null_Address; + + -- An AST_Handler value is from a typing point of view simply a pointer + -- to a procedure taking a single 64 bit parameter. However, this + -- is a bit misleading, because the data that this pointer references is + -- highly stylized. See body of System.AST_Handling for full details. + + type AST_Handler is access procedure (Param : Long_Integer); + No_AST_Handler : constant AST_Handler := null; + + -- Other operators have incorrect profiles. It would be nice to make + -- them intrinsic, since the backend can handle them, but the front + -- end is not prepared to deal with them, so at least inline them. + + pragma Inline_Always ("+"); + pragma Inline_Always ("-"); + pragma Inline_Always ("not"); + pragma Inline_Always ("and"); + pragma Inline_Always ("or"); + pragma Inline_Always ("xor"); + + -- Other inlined subprograms + + pragma Inline_Always (Fetch_From_Address); + pragma Inline_Always (Assign_To_Address); + + -- Synchronization related subprograms. Mechanism is explicitly set + -- so that the critical parameters are passed by reference. + -- Without this, the parameters are passed by copy, creating load/store + -- race conditions. We also inline them, since this seems more in the + -- spirit of the original (hardware intrinsic) routines. + + pragma Export_Procedure + (Clear_Interlocked, + External => "system__aux_dec__clear_interlocked__1", + Parameter_Types => (Boolean, Boolean), + Mechanism => (Reference, Reference)); + pragma Export_Procedure + (Clear_Interlocked, + External => "system__aux_dec__clear_interlocked__2", + Parameter_Types => (Boolean, Boolean, Natural, Boolean), + Mechanism => (Reference, Reference, Value, Reference)); + pragma Inline_Always (Clear_Interlocked); + + pragma Export_Procedure + (Set_Interlocked, + External => "system__aux_dec__set_interlocked__1", + Parameter_Types => (Boolean, Boolean), + Mechanism => (Reference, Reference)); + pragma Export_Procedure + (Set_Interlocked, + External => "system__aux_dec__set_interlocked__2", + Parameter_Types => (Boolean, Boolean, Natural, Boolean), + Mechanism => (Reference, Reference, Value, Reference)); + pragma Inline_Always (Set_Interlocked); + + pragma Export_Procedure + (Add_Interlocked, + External => "system__aux_dec__add_interlocked__1", + Mechanism => (Value, Reference, Reference)); + pragma Inline_Always (Add_Interlocked); + + pragma Export_Procedure + (Add_Atomic, + External => "system__aux_dec__add_atomic__1", + Parameter_Types => (Aligned_Integer, Integer), + Mechanism => (Reference, Value)); + pragma Export_Procedure + (Add_Atomic, + External => "system__aux_dec__add_atomic__2", + Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), + Mechanism => (Reference, Value, Value, Reference, Reference)); + pragma Export_Procedure + (Add_Atomic, + External => "system__aux_dec__add_atomic__3", + Parameter_Types => (Aligned_Long_Integer, Long_Integer), + Mechanism => (Reference, Value)); + pragma Export_Procedure + (Add_Atomic, + External => "system__aux_dec__add_atomic__4", + Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, + Long_Integer, Boolean), + Mechanism => (Reference, Value, Value, Reference, Reference)); + pragma Inline_Always (Add_Atomic); + + pragma Export_Procedure + (And_Atomic, + External => "system__aux_dec__and_atomic__1", + Parameter_Types => (Aligned_Integer, Integer), + Mechanism => (Reference, Value)); + pragma Export_Procedure + (And_Atomic, + External => "system__aux_dec__and_atomic__2", + Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), + Mechanism => (Reference, Value, Value, Reference, Reference)); + pragma Export_Procedure + (And_Atomic, + External => "system__aux_dec__and_atomic__3", + Parameter_Types => (Aligned_Long_Integer, Long_Integer), + Mechanism => (Reference, Value)); + pragma Export_Procedure + (And_Atomic, + External => "system__aux_dec__and_atomic__4", + Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, + Long_Integer, Boolean), + Mechanism => (Reference, Value, Value, Reference, Reference)); + pragma Inline_Always (And_Atomic); + + pragma Export_Procedure + (Or_Atomic, + External => "system__aux_dec__or_atomic__1", + Parameter_Types => (Aligned_Integer, Integer), + Mechanism => (Reference, Value)); + pragma Export_Procedure + (Or_Atomic, + External => "system__aux_dec__or_atomic__2", + Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), + Mechanism => (Reference, Value, Value, Reference, Reference)); + pragma Export_Procedure + (Or_Atomic, + External => "system__aux_dec__or_atomic__3", + Parameter_Types => (Aligned_Long_Integer, Long_Integer), + Mechanism => (Reference, Value)); + pragma Export_Procedure + (Or_Atomic, + External => "system__aux_dec__or_atomic__4", + Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, + Long_Integer, Boolean), + Mechanism => (Reference, Value, Value, Reference, Reference)); + pragma Inline_Always (Or_Atomic); + + -- Provide proper unchecked conversion definitions for transfer + -- functions. Note that we need this level of indirection because + -- the formal parameter name is X and not Source (and this is indeed + -- detectable by a program) + + function To_Unsigned_Byte_A is new + Ada.Unchecked_Conversion (Bit_Array_8, Unsigned_Byte); + + function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte + renames To_Unsigned_Byte_A; + + function To_Bit_Array_8_A is new + Ada.Unchecked_Conversion (Unsigned_Byte, Bit_Array_8); + + function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8 + renames To_Bit_Array_8_A; + + function To_Unsigned_Word_A is new + Ada.Unchecked_Conversion (Bit_Array_16, Unsigned_Word); + + function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word + renames To_Unsigned_Word_A; + + function To_Bit_Array_16_A is new + Ada.Unchecked_Conversion (Unsigned_Word, Bit_Array_16); + + function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16 + renames To_Bit_Array_16_A; + + function To_Unsigned_Longword_A is new + Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_Longword); + + function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + function To_Bit_Array_32_A is new + Ada.Unchecked_Conversion (Unsigned_Longword, Bit_Array_32); + + function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32 + renames To_Bit_Array_32_A; + + function To_Unsigned_32_A is new + Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_32); + + function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32 + renames To_Unsigned_32_A; + + function To_Bit_Array_32_A is new + Ada.Unchecked_Conversion (Unsigned_32, Bit_Array_32); + + function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32 + renames To_Bit_Array_32_A; + + function To_Unsigned_Quadword_A is new + Ada.Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword); + + function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword + renames To_Unsigned_Quadword_A; + + function To_Bit_Array_64_A is new + Ada.Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64); + + function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64 + renames To_Bit_Array_64_A; + + pragma Warnings (Off); + -- Turn warnings off. This is needed for systems with 64-bit integers, + -- where some of these operations are of dubious meaning, but we do not + -- want warnings when we compile on such systems. + + function To_Address_A is new + Ada.Unchecked_Conversion (Integer, Address); + pragma Pure_Function (To_Address_A); + + function To_Address (X : Integer) return Address + renames To_Address_A; + pragma Pure_Function (To_Address); + + function To_Address_Long_A is new + Ada.Unchecked_Conversion (Unsigned_Longword, Address); + pragma Pure_Function (To_Address_Long_A); + + function To_Address_Long (X : Unsigned_Longword) return Address + renames To_Address_Long_A; + pragma Pure_Function (To_Address_Long); + + function To_Integer_A is new + Ada.Unchecked_Conversion (Address, Integer); + + function To_Integer (X : Address) return Integer + renames To_Integer_A; + + function To_Unsigned_Longword_A is new + Ada.Unchecked_Conversion (Address, Unsigned_Longword); + + function To_Unsigned_Longword (X : Address) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + function To_Unsigned_Longword_A is new + Ada.Unchecked_Conversion (AST_Handler, Unsigned_Longword); + + function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword + renames To_Unsigned_Longword_A; + + pragma Warnings (On); + +end System.Aux_DEC; diff --git a/gcc/ada/libgnat/s-bignum.adb b/gcc/ada/libgnat/s-bignum.adb new file mode 100644 index 0000000..3f31a44 --- /dev/null +++ b/gcc/ada/libgnat/s-bignum.adb @@ -0,0 +1,1105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . B I G N U M S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides arbitrary precision signed integer arithmetic for +-- use in computing intermediate values in expressions for the case where +-- pragma Overflow_Check (Eliminate) is in effect. + +with System; use System; +with System.Secondary_Stack; use System.Secondary_Stack; +with System.Storage_Elements; use System.Storage_Elements; + +package body System.Bignums is + + use Interfaces; + -- So that operations on Unsigned_32 are available + + type DD is mod Base ** 2; + -- Double length digit used for intermediate computations + + function MSD (X : DD) return SD is (SD (X / Base)); + function LSD (X : DD) return SD is (SD (X mod Base)); + -- Most significant and least significant digit of double digit value + + function "&" (X, Y : SD) return DD is (DD (X) * Base + DD (Y)); + -- Compose double digit value from two single digit values + + subtype LLI is Long_Long_Integer; + + One_Data : constant Digit_Vector (1 .. 1) := (1 => 1); + -- Constant one + + Zero_Data : constant Digit_Vector (1 .. 0) := (1 .. 0 => 0); + -- Constant zero + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Add + (X, Y : Digit_Vector; + X_Neg : Boolean; + Y_Neg : Boolean) return Bignum + with + Pre => X'First = 1 and then Y'First = 1; + -- This procedure adds two signed numbers returning the Sum, it is used + -- for both addition and subtraction. The value computed is X + Y, with + -- X_Neg and Y_Neg giving the signs of the operands. + + function Allocate_Bignum (Len : Length) return Bignum with + Post => Allocate_Bignum'Result.Len = Len; + -- Allocate Bignum value of indicated length on secondary stack. On return + -- the Neg and D fields are left uninitialized. + + type Compare_Result is (LT, EQ, GT); + -- Indicates result of comparison in following call + + function Compare + (X, Y : Digit_Vector; + X_Neg, Y_Neg : Boolean) return Compare_Result + with + Pre => X'First = 1 and then Y'First = 1; + -- Compare (X with sign X_Neg) with (Y with sign Y_Neg), and return the + -- result of the signed comparison. + + procedure Div_Rem + (X, Y : Bignum; + Quotient : out Bignum; + Remainder : out Bignum; + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False); + -- Returns the Quotient and Remainder from dividing abs (X) by abs (Y). The + -- values of X and Y are not modified. If Discard_Quotient is True, then + -- Quotient is undefined on return, and if Discard_Remainder is True, then + -- Remainder is undefined on return. Service routine for Big_Div/Rem/Mod. + + procedure Free_Bignum (X : Bignum) is null; + -- Called to free a Bignum value used in intermediate computations. In + -- this implementation using the secondary stack, it does nothing at all, + -- because we rely on Mark/Release, but it may be of use for some + -- alternative implementation. + + function Normalize + (X : Digit_Vector; + Neg : Boolean := False) return Bignum; + -- Given a digit vector and sign, allocate and construct a Bignum value. + -- Note that X may have leading zeroes which must be removed, and if the + -- result is zero, the sign is forced positive. + + --------- + -- Add -- + --------- + + function Add + (X, Y : Digit_Vector; + X_Neg : Boolean; + Y_Neg : Boolean) return Bignum + is + begin + -- If signs are the same, we are doing an addition, it is convenient to + -- ensure that the first operand is the longer of the two. + + if X_Neg = Y_Neg then + if X'Last < Y'Last then + return Add (X => Y, Y => X, X_Neg => Y_Neg, Y_Neg => X_Neg); + + -- Here signs are the same, and the first operand is the longer + + else + pragma Assert (X_Neg = Y_Neg and then X'Last >= Y'Last); + + -- Do addition, putting result in Sum (allowing for carry) + + declare + Sum : Digit_Vector (0 .. X'Last); + RD : DD; + + begin + RD := 0; + for J in reverse 1 .. X'Last loop + RD := RD + DD (X (J)); + + if J >= 1 + (X'Last - Y'Last) then + RD := RD + DD (Y (J - (X'Last - Y'Last))); + end if; + + Sum (J) := LSD (RD); + RD := RD / Base; + end loop; + + Sum (0) := SD (RD); + return Normalize (Sum, X_Neg); + end; + end if; + + -- Signs are different so really this is a subtraction, we want to make + -- sure that the largest magnitude operand is the first one, and then + -- the result will have the sign of the first operand. + + else + declare + CR : constant Compare_Result := Compare (X, Y, False, False); + + begin + if CR = EQ then + return Normalize (Zero_Data); + + elsif CR = LT then + return Add (X => Y, Y => X, X_Neg => Y_Neg, Y_Neg => X_Neg); + + else + pragma Assert (X_Neg /= Y_Neg and then CR = GT); + + -- Do subtraction, putting result in Diff + + declare + Diff : Digit_Vector (1 .. X'Length); + RD : DD; + + begin + RD := 0; + for J in reverse 1 .. X'Last loop + RD := RD + DD (X (J)); + + if J >= 1 + (X'Last - Y'Last) then + RD := RD - DD (Y (J - (X'Last - Y'Last))); + end if; + + Diff (J) := LSD (RD); + RD := (if RD < Base then 0 else -1); + end loop; + + return Normalize (Diff, X_Neg); + end; + end if; + end; + end if; + end Add; + + --------------------- + -- Allocate_Bignum -- + --------------------- + + function Allocate_Bignum (Len : Length) return Bignum is + Addr : Address; + + begin + -- Change the if False here to if True to get allocation on the heap + -- instead of the secondary stack, which is convenient for debugging + -- System.Bignum itself. + + if False then + declare + B : Bignum; + begin + B := new Bignum_Data'(Len, False, (others => 0)); + return B; + end; + + -- Normal case of allocation on the secondary stack + + else + -- Note: The approach used here is designed to avoid strict aliasing + -- warnings that appeared previously using unchecked conversion. + + SS_Allocate (Addr, Storage_Offset (4 + 4 * Len)); + + declare + B : Bignum; + for B'Address use Addr'Address; + pragma Import (Ada, B); + + BD : Bignum_Data (Len); + for BD'Address use Addr; + pragma Import (Ada, BD); + + -- Expose a writable view of discriminant BD.Len so that we can + -- initialize it. We need to use the exact layout of the record + -- to ensure that the Length field has 24 bits as expected. + + type Bignum_Data_Header is record + Len : Length; + Neg : Boolean; + end record; + + for Bignum_Data_Header use record + Len at 0 range 0 .. 23; + Neg at 3 range 0 .. 7; + end record; + + BDH : Bignum_Data_Header; + for BDH'Address use BD'Address; + pragma Import (Ada, BDH); + + pragma Assert (BDH.Len'Size = BD.Len'Size); + + begin + BDH.Len := Len; + return B; + end; + end if; + end Allocate_Bignum; + + ------------- + -- Big_Abs -- + ------------- + + function Big_Abs (X : Bignum) return Bignum is + begin + return Normalize (X.D); + end Big_Abs; + + ------------- + -- Big_Add -- + ------------- + + function Big_Add (X, Y : Bignum) return Bignum is + begin + return Add (X.D, Y.D, X.Neg, Y.Neg); + end Big_Add; + + ------------- + -- Big_Div -- + ------------- + + -- This table is excerpted from RM 4.5.5(28-30) and shows how the result + -- varies with the signs of the operands. + + -- A B A/B A B A/B + -- + -- 10 5 2 -10 5 -2 + -- 11 5 2 -11 5 -2 + -- 12 5 2 -12 5 -2 + -- 13 5 2 -13 5 -2 + -- 14 5 2 -14 5 -2 + -- + -- A B A/B A B A/B + -- + -- 10 -5 -2 -10 -5 2 + -- 11 -5 -2 -11 -5 2 + -- 12 -5 -2 -12 -5 2 + -- 13 -5 -2 -13 -5 2 + -- 14 -5 -2 -14 -5 2 + + function Big_Div (X, Y : Bignum) return Bignum is + Q, R : Bignum; + begin + Div_Rem (X, Y, Q, R, Discard_Remainder => True); + Q.Neg := Q.Len > 0 and then (X.Neg xor Y.Neg); + return Q; + end Big_Div; + + ------------- + -- Big_Exp -- + ------------- + + function Big_Exp (X, Y : Bignum) return Bignum is + + function "**" (X : Bignum; Y : SD) return Bignum; + -- Internal routine where we know right operand is one word + + ---------- + -- "**" -- + ---------- + + function "**" (X : Bignum; Y : SD) return Bignum is + begin + case Y is + + -- X ** 0 is 1 + + when 0 => + return Normalize (One_Data); + + -- X ** 1 is X + + when 1 => + return Normalize (X.D); + + -- X ** 2 is X * X + + when 2 => + return Big_Mul (X, X); + + -- For X greater than 2, use the recursion + + -- X even, X ** Y = (X ** (Y/2)) ** 2; + -- X odd, X ** Y = (X ** (Y/2)) ** 2 * X; + + when others => + declare + XY2 : constant Bignum := X ** (Y / 2); + XY2S : constant Bignum := Big_Mul (XY2, XY2); + Res : Bignum; + + begin + Free_Bignum (XY2); + + -- Raise storage error if intermediate value is getting too + -- large, which we arbitrarily define as 200 words for now. + + if XY2S.Len > 200 then + Free_Bignum (XY2S); + raise Storage_Error with + "exponentiation result is too large"; + end if; + + -- Otherwise take care of even/odd cases + + if (Y and 1) = 0 then + return XY2S; + + else + Res := Big_Mul (XY2S, X); + Free_Bignum (XY2S); + return Res; + end if; + end; + end case; + end "**"; + + -- Start of processing for Big_Exp + + begin + -- Error if right operand negative + + if Y.Neg then + raise Constraint_Error with "exponentiation to negative power"; + + -- X ** 0 is always 1 (including 0 ** 0, so do this test first) + + elsif Y.Len = 0 then + return Normalize (One_Data); + + -- 0 ** X is always 0 (for X non-zero) + + elsif X.Len = 0 then + return Normalize (Zero_Data); + + -- (+1) ** Y = 1 + -- (-1) ** Y = +/-1 depending on whether Y is even or odd + + elsif X.Len = 1 and then X.D (1) = 1 then + return Normalize + (X.D, Neg => X.Neg and then ((Y.D (Y.Len) and 1) = 1)); + + -- If the absolute value of the base is greater than 1, then the + -- exponent must not be bigger than one word, otherwise the result + -- is ludicrously large, and we just signal Storage_Error right away. + + elsif Y.Len > 1 then + raise Storage_Error with "exponentiation result is too large"; + + -- Special case (+/-)2 ** K, where K is 1 .. 31 using a shift + + elsif X.Len = 1 and then X.D (1) = 2 and then Y.D (1) < 32 then + declare + D : constant Digit_Vector (1 .. 1) := + (1 => Shift_Left (SD'(1), Natural (Y.D (1)))); + begin + return Normalize (D, X.Neg); + end; + + -- Remaining cases have right operand of one word + + else + return X ** Y.D (1); + end if; + end Big_Exp; + + ------------ + -- Big_EQ -- + ------------ + + function Big_EQ (X, Y : Bignum) return Boolean is + begin + return Compare (X.D, Y.D, X.Neg, Y.Neg) = EQ; + end Big_EQ; + + ------------ + -- Big_GE -- + ------------ + + function Big_GE (X, Y : Bignum) return Boolean is + begin + return Compare (X.D, Y.D, X.Neg, Y.Neg) /= LT; + end Big_GE; + + ------------ + -- Big_GT -- + ------------ + + function Big_GT (X, Y : Bignum) return Boolean is + begin + return Compare (X.D, Y.D, X.Neg, Y.Neg) = GT; + end Big_GT; + + ------------ + -- Big_LE -- + ------------ + + function Big_LE (X, Y : Bignum) return Boolean is + begin + return Compare (X.D, Y.D, X.Neg, Y.Neg) /= GT; + end Big_LE; + + ------------ + -- Big_LT -- + ------------ + + function Big_LT (X, Y : Bignum) return Boolean is + begin + return Compare (X.D, Y.D, X.Neg, Y.Neg) = LT; + end Big_LT; + + ------------- + -- Big_Mod -- + ------------- + + -- This table is excerpted from RM 4.5.5(28-30) and shows how the result + -- of Rem and Mod vary with the signs of the operands. + + -- A B A mod B A rem B A B A mod B A rem B + + -- 10 5 0 0 -10 5 0 0 + -- 11 5 1 1 -11 5 4 -1 + -- 12 5 2 2 -12 5 3 -2 + -- 13 5 3 3 -13 5 2 -3 + -- 14 5 4 4 -14 5 1 -4 + + -- A B A mod B A rem B A B A mod B A rem B + + -- 10 -5 0 0 -10 -5 0 0 + -- 11 -5 -4 1 -11 -5 -1 -1 + -- 12 -5 -3 2 -12 -5 -2 -2 + -- 13 -5 -2 3 -13 -5 -3 -3 + -- 14 -5 -1 4 -14 -5 -4 -4 + + function Big_Mod (X, Y : Bignum) return Bignum is + Q, R : Bignum; + + begin + -- If signs are same, result is same as Rem + + if X.Neg = Y.Neg then + return Big_Rem (X, Y); + + -- Case where Mod is different + + else + -- Do division + + Div_Rem (X, Y, Q, R, Discard_Quotient => True); + + -- Zero result is unchanged + + if R.Len = 0 then + return R; + + -- Otherwise adjust result + + else + declare + T1 : constant Bignum := Big_Sub (Y, R); + begin + T1.Neg := Y.Neg; + Free_Bignum (R); + return T1; + end; + end if; + end if; + end Big_Mod; + + ------------- + -- Big_Mul -- + ------------- + + function Big_Mul (X, Y : Bignum) return Bignum is + Result : Digit_Vector (1 .. X.Len + Y.Len) := (others => 0); + -- Accumulate result (max length of result is sum of operand lengths) + + L : Length; + -- Current result digit + + D : DD; + -- Result digit + + begin + for J in 1 .. X.Len loop + for K in 1 .. Y.Len loop + L := Result'Last - (X.Len - J) - (Y.Len - K); + D := DD (X.D (J)) * DD (Y.D (K)) + DD (Result (L)); + Result (L) := LSD (D); + D := D / Base; + + -- D is carry which must be propagated + + while D /= 0 and then L >= 1 loop + L := L - 1; + D := D + DD (Result (L)); + Result (L) := LSD (D); + D := D / Base; + end loop; + + -- Must not have a carry trying to extend max length + + pragma Assert (D = 0); + end loop; + end loop; + + -- Return result + + return Normalize (Result, X.Neg xor Y.Neg); + end Big_Mul; + + ------------ + -- Big_NE -- + ------------ + + function Big_NE (X, Y : Bignum) return Boolean is + begin + return Compare (X.D, Y.D, X.Neg, Y.Neg) /= EQ; + end Big_NE; + + ------------- + -- Big_Neg -- + ------------- + + function Big_Neg (X : Bignum) return Bignum is + begin + return Normalize (X.D, not X.Neg); + end Big_Neg; + + ------------- + -- Big_Rem -- + ------------- + + -- This table is excerpted from RM 4.5.5(28-30) and shows how the result + -- varies with the signs of the operands. + + -- A B A rem B A B A rem B + + -- 10 5 0 -10 5 0 + -- 11 5 1 -11 5 -1 + -- 12 5 2 -12 5 -2 + -- 13 5 3 -13 5 -3 + -- 14 5 4 -14 5 -4 + + -- A B A rem B A B A rem B + + -- 10 -5 0 -10 -5 0 + -- 11 -5 1 -11 -5 -1 + -- 12 -5 2 -12 -5 -2 + -- 13 -5 3 -13 -5 -3 + -- 14 -5 4 -14 -5 -4 + + function Big_Rem (X, Y : Bignum) return Bignum is + Q, R : Bignum; + begin + Div_Rem (X, Y, Q, R, Discard_Quotient => True); + R.Neg := R.Len > 0 and then X.Neg; + return R; + end Big_Rem; + + ------------- + -- Big_Sub -- + ------------- + + function Big_Sub (X, Y : Bignum) return Bignum is + begin + -- If right operand zero, return left operand (avoiding sharing) + + if Y.Len = 0 then + return Normalize (X.D, X.Neg); + + -- Otherwise add negative of right operand + + else + return Add (X.D, Y.D, X.Neg, not Y.Neg); + end if; + end Big_Sub; + + ------------- + -- Compare -- + ------------- + + function Compare + (X, Y : Digit_Vector; + X_Neg, Y_Neg : Boolean) return Compare_Result + is + begin + -- Signs are different, that's decisive, since 0 is always plus + + if X_Neg /= Y_Neg then + return (if X_Neg then LT else GT); + + -- Lengths are different, that's decisive since no leading zeroes + + elsif X'Last /= Y'Last then + return (if (X'Last > Y'Last) xor X_Neg then GT else LT); + + -- Need to compare data + + else + for J in X'Range loop + if X (J) /= Y (J) then + return (if (X (J) > Y (J)) xor X_Neg then GT else LT); + end if; + end loop; + + return EQ; + end if; + end Compare; + + ------------- + -- Div_Rem -- + ------------- + + procedure Div_Rem + (X, Y : Bignum; + Quotient : out Bignum; + Remainder : out Bignum; + Discard_Quotient : Boolean := False; + Discard_Remainder : Boolean := False) + is + begin + -- Error if division by zero + + if Y.Len = 0 then + raise Constraint_Error with "division by zero"; + end if; + + -- Handle simple cases with special tests + + -- If X < Y then quotient is zero and remainder is X + + if Compare (X.D, Y.D, False, False) = LT then + Remainder := Normalize (X.D); + Quotient := Normalize (Zero_Data); + return; + + -- If both X and Y are less than 2**63-1, we can use Long_Long_Integer + -- arithmetic. Note it is good not to do an accurate range check against + -- Long_Long_Integer since -2**63 / -1 overflows. + + elsif (X.Len <= 1 or else (X.Len = 2 and then X.D (1) < 2**31)) + and then + (Y.Len <= 1 or else (Y.Len = 2 and then Y.D (1) < 2**31)) + then + declare + A : constant LLI := abs (From_Bignum (X)); + B : constant LLI := abs (From_Bignum (Y)); + begin + Quotient := To_Bignum (A / B); + Remainder := To_Bignum (A rem B); + return; + end; + + -- Easy case if divisor is one digit + + elsif Y.Len = 1 then + declare + ND : DD; + Div : constant DD := DD (Y.D (1)); + + Result : Digit_Vector (1 .. X.Len); + Remdr : Digit_Vector (1 .. 1); + + begin + ND := 0; + for J in 1 .. X.Len loop + ND := Base * ND + DD (X.D (J)); + Result (J) := SD (ND / Div); + ND := ND rem Div; + end loop; + + Quotient := Normalize (Result); + Remdr (1) := SD (ND); + Remainder := Normalize (Remdr); + return; + end; + end if; + + -- The complex full multi-precision case. We will employ algorithm + -- D defined in the section "The Classical Algorithms" (sec. 4.3.1) + -- of Donald Knuth's "The Art of Computer Programming", Vol. 2, 2nd + -- edition. The terminology is adjusted for this section to match that + -- reference. + + -- We are dividing X.Len digits of X (called u here) by Y.Len digits + -- of Y (called v here), developing the quotient and remainder. The + -- numbers are represented using Base, which was chosen so that we have + -- the operations of multiplying to single digits (SD) to form a double + -- digit (DD), and dividing a double digit (DD) by a single digit (SD) + -- to give a single digit quotient and a single digit remainder. + + -- Algorithm D from Knuth + + -- Comments here with square brackets are directly from Knuth + + Algorithm_D : declare + + -- The following lower case variables correspond exactly to the + -- terminology used in algorithm D. + + m : constant Length := X.Len - Y.Len; + n : constant Length := Y.Len; + b : constant DD := Base; + + u : Digit_Vector (0 .. m + n); + v : Digit_Vector (1 .. n); + q : Digit_Vector (0 .. m); + r : Digit_Vector (1 .. n); + + u0 : SD renames u (0); + v1 : SD renames v (1); + v2 : SD renames v (2); + + d : DD; + j : Length; + qhat : DD; + rhat : DD; + temp : DD; + + begin + -- Initialize data of left and right operands + + for J in 1 .. m + n loop + u (J) := X.D (J); + end loop; + + for J in 1 .. n loop + v (J) := Y.D (J); + end loop; + + -- [Division of nonnegative integers.] Given nonnegative integers u + -- = (ul,u2..um+n) and v = (v1,v2..vn), where v1 /= 0 and n > 1, we + -- form the quotient u / v = (q0,ql..qm) and the remainder u mod v = + -- (r1,r2..rn). + + pragma Assert (v1 /= 0); + pragma Assert (n > 1); + + -- Dl. [Normalize.] Set d = b/(vl + 1). Then set (u0,u1,u2..um+n) + -- equal to (u1,u2..um+n) times d, and set (v1,v2..vn) equal to + -- (v1,v2..vn) times d. Note the introduction of a new digit position + -- u0 at the left of u1; if d = 1 all we need to do in this step is + -- to set u0 = 0. + + d := b / (DD (v1) + 1); + + if d = 1 then + u0 := 0; + + else + declare + Carry : DD; + Tmp : DD; + + begin + -- Multiply Dividend (u) by d + + Carry := 0; + for J in reverse 1 .. m + n loop + Tmp := DD (u (J)) * d + Carry; + u (J) := LSD (Tmp); + Carry := Tmp / Base; + end loop; + + u0 := SD (Carry); + + -- Multiply Divisor (v) by d + + Carry := 0; + for J in reverse 1 .. n loop + Tmp := DD (v (J)) * d + Carry; + v (J) := LSD (Tmp); + Carry := Tmp / Base; + end loop; + + pragma Assert (Carry = 0); + end; + end if; + + -- D2. [Initialize j.] Set j = 0. The loop on j, steps D2 through D7, + -- will be essentially a division of (uj, uj+1..uj+n) by (v1,v2..vn) + -- to get a single quotient digit qj. + + j := 0; + + -- Loop through digits + + loop + -- Note: In the original printing, step D3 was as follows: + + -- D3. [Calculate qhat.] If uj = v1, set qhat to b-l; otherwise + -- set qhat to (uj,uj+1)/v1. Now test if v2 * qhat is greater than + -- (uj*b + uj+1 - qhat*v1)*b + uj+2. If so, decrease qhat by 1 and + -- repeat this test + + -- This had a bug not discovered till 1995, see Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. Under + -- rare circumstances the expression in the test could overflow. + -- This version was further corrected in 2005, see Vol 2 errata: + -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. + -- The code below is the fixed version of this step. + + -- D3. [Calculate qhat.] Set qhat to (uj,uj+1)/v1 and rhat to + -- to (uj,uj+1) mod v1. + + temp := u (j) & u (j + 1); + qhat := temp / DD (v1); + rhat := temp mod DD (v1); + + -- D3 (continued). Now test if qhat >= b or v2*qhat > (rhat,uj+2): + -- if so, decrease qhat by 1, increase rhat by v1, and repeat this + -- test if rhat < b. [The test on v2 determines at high speed + -- most of the cases in which the trial value qhat is one too + -- large, and eliminates all cases where qhat is two too large.] + + while qhat >= b + or else DD (v2) * qhat > LSD (rhat) & u (j + 2) + loop + qhat := qhat - 1; + rhat := rhat + DD (v1); + exit when rhat >= b; + end loop; + + -- D4. [Multiply and subtract.] Replace (uj,uj+1..uj+n) by + -- (uj,uj+1..uj+n) minus qhat times (v1,v2..vn). This step + -- consists of a simple multiplication by a one-place number, + -- combined with a subtraction. + + -- The digits (uj,uj+1..uj+n) are always kept positive; if the + -- result of this step is actually negative then (uj,uj+1..uj+n) + -- is left as the true value plus b**(n+1), i.e. as the b's + -- complement of the true value, and a "borrow" to the left is + -- remembered. + + declare + Borrow : SD; + Carry : DD; + Temp : DD; + + Negative : Boolean; + -- Records if subtraction causes a negative result, requiring + -- an add back (case where qhat turned out to be 1 too large). + + begin + Borrow := 0; + for K in reverse 1 .. n loop + Temp := qhat * DD (v (K)) + DD (Borrow); + Borrow := MSD (Temp); + + if LSD (Temp) > u (j + K) then + Borrow := Borrow + 1; + end if; + + u (j + K) := u (j + K) - LSD (Temp); + end loop; + + Negative := u (j) < Borrow; + u (j) := u (j) - Borrow; + + -- D5. [Test remainder.] Set qj = qhat. If the result of step + -- D4 was negative, we will do the add back step (step D6). + + q (j) := LSD (qhat); + + if Negative then + + -- D6. [Add back.] Decrease qj by 1, and add (0,v1,v2..vn) + -- to (uj,uj+1,uj+2..uj+n). (A carry will occur to the left + -- of uj, and it is be ignored since it cancels with the + -- borrow that occurred in D4.) + + q (j) := q (j) - 1; + + Carry := 0; + for K in reverse 1 .. n loop + Temp := DD (v (K)) + DD (u (j + K)) + Carry; + u (j + K) := LSD (Temp); + Carry := Temp / Base; + end loop; + + u (j) := u (j) + SD (Carry); + end if; + end; + + -- D7. [Loop on j.] Increase j by one. Now if j <= m, go back to + -- D3 (the start of the loop on j). + + j := j + 1; + exit when not (j <= m); + end loop; + + -- D8. [Unnormalize.] Now (qo,ql..qm) is the desired quotient, and + -- the desired remainder may be obtained by dividing (um+1..um+n) + -- by d. + + if not Discard_Quotient then + Quotient := Normalize (q); + end if; + + if not Discard_Remainder then + declare + Remdr : DD; + + begin + Remdr := 0; + for K in 1 .. n loop + Remdr := Base * Remdr + DD (u (m + K)); + r (K) := SD (Remdr / d); + Remdr := Remdr rem d; + end loop; + + pragma Assert (Remdr = 0); + end; + + Remainder := Normalize (r); + end if; + end Algorithm_D; + end Div_Rem; + + ----------------- + -- From_Bignum -- + ----------------- + + function From_Bignum (X : Bignum) return Long_Long_Integer is + begin + if X.Len = 0 then + return 0; + + elsif X.Len = 1 then + return (if X.Neg then -LLI (X.D (1)) else LLI (X.D (1))); + + elsif X.Len = 2 then + declare + Mag : constant DD := X.D (1) & X.D (2); + begin + if X.Neg and then Mag <= 2 ** 63 then + return -LLI (Mag); + elsif Mag < 2 ** 63 then + return LLI (Mag); + end if; + end; + end if; + + raise Constraint_Error with "expression value out of range"; + end From_Bignum; + + ------------------------- + -- Bignum_In_LLI_Range -- + ------------------------- + + function Bignum_In_LLI_Range (X : Bignum) return Boolean is + begin + -- If length is 0 or 1, definitely fits + + if X.Len <= 1 then + return True; + + -- If length is greater than 2, definitely does not fit + + elsif X.Len > 2 then + return False; + + -- Length is 2, more tests needed + + else + declare + Mag : constant DD := X.D (1) & X.D (2); + begin + return Mag < 2 ** 63 or else (X.Neg and then Mag = 2 ** 63); + end; + end if; + end Bignum_In_LLI_Range; + + --------------- + -- Normalize -- + --------------- + + function Normalize + (X : Digit_Vector; + Neg : Boolean := False) return Bignum + is + B : Bignum; + J : Length; + + begin + J := X'First; + while J <= X'Last and then X (J) = 0 loop + J := J + 1; + end loop; + + B := Allocate_Bignum (X'Last - J + 1); + B.Neg := B.Len > 0 and then Neg; + B.D := X (J .. X'Last); + return B; + end Normalize; + + --------------- + -- To_Bignum -- + --------------- + + function To_Bignum (X : Long_Long_Integer) return Bignum is + R : Bignum; + + begin + if X = 0 then + R := Allocate_Bignum (0); + + -- One word result + + elsif X in -(2 ** 32 - 1) .. +(2 ** 32 - 1) then + R := Allocate_Bignum (1); + R.D (1) := SD (abs (X)); + + -- Largest negative number annoyance + + elsif X = Long_Long_Integer'First then + R := Allocate_Bignum (2); + R.D (1) := 2 ** 31; + R.D (2) := 0; + + -- Normal two word case + + else + R := Allocate_Bignum (2); + R.D (2) := SD (abs (X) mod Base); + R.D (1) := SD (abs (X) / Base); + end if; + + R.Neg := X < 0; + return R; + end To_Bignum; + +end System.Bignums; diff --git a/gcc/ada/libgnat/s-bignum.ads b/gcc/ada/libgnat/s-bignum.ads new file mode 100644 index 0000000..dd559b3 --- /dev/null +++ b/gcc/ada/libgnat/s-bignum.ads @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . B I G N U M S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2012-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides arbitrary precision signed integer arithmetic for +-- use in computing intermediate values in expressions for the case where +-- pragma Overflow_Check (Eliminated) is in effect. + +with Interfaces; + +package System.Bignums is + + pragma Assert (Long_Long_Integer'Size = 64); + -- This package assumes that Long_Long_Integer size is 64 bit (i.e. that it + -- has a range of -2**63 to 2**63-1). The front end ensures that the mode + -- ELIMINATED is not allowed for overflow checking if this is not the case. + + subtype Length is Natural range 0 .. 2 ** 23 - 1; + -- Represent number of words in Digit_Vector + + Base : constant := 2 ** 32; + -- Digit vectors use this base + + subtype SD is Interfaces.Unsigned_32; + -- Single length digit + + type Digit_Vector is array (Length range <>) of SD; + -- Represent digits of a number (most significant digit first) + + type Bignum_Data (Len : Length) is record + Neg : Boolean; + -- Set if value is negative, never set for zero + + D : Digit_Vector (1 .. Len); + -- Digits of number, most significant first, represented in base + -- 2**Base. No leading zeroes are stored, and the value of zero is + -- represented using an empty vector for D. + end record; + + for Bignum_Data use record + Len at 0 range 0 .. 23; + Neg at 3 range 0 .. 7; + end record; + + type Bignum is access all Bignum_Data; + -- This is the type that is used externally. Possibly this could be a + -- private type, but we leave the structure exposed for now. For one + -- thing it helps with debugging. Note that this package never shares + -- an allocated Bignum value, so for example for X + 0, a copy of X is + -- returned, not X itself. + + -- Note: none of the subprograms in this package modify the Bignum_Data + -- records referenced by Bignum arguments of mode IN. + + function Big_Add (X, Y : Bignum) return Bignum; -- "+" + function Big_Sub (X, Y : Bignum) return Bignum; -- "-" + function Big_Mul (X, Y : Bignum) return Bignum; -- "*" + function Big_Div (X, Y : Bignum) return Bignum; -- "/" + function Big_Exp (X, Y : Bignum) return Bignum; -- "**" + function Big_Mod (X, Y : Bignum) return Bignum; -- "mod" + function Big_Rem (X, Y : Bignum) return Bignum; -- "rem" + function Big_Neg (X : Bignum) return Bignum; -- "-" + function Big_Abs (X : Bignum) return Bignum; -- "abs" + -- Perform indicated arithmetic operation on bignum values. No exception + -- raised except for Div/Mod/Rem by 0 which raises Constraint_Error with + -- an appropriate message. + + function Big_EQ (X, Y : Bignum) return Boolean; -- "=" + function Big_NE (X, Y : Bignum) return Boolean; -- "/=" + function Big_GE (X, Y : Bignum) return Boolean; -- ">=" + function Big_LE (X, Y : Bignum) return Boolean; -- "<=" + function Big_GT (X, Y : Bignum) return Boolean; -- ">" + function Big_LT (X, Y : Bignum) return Boolean; -- "<" + -- Perform indicated comparison on bignums, returning result as Boolean. + -- No exception raised for any input arguments. + + function Bignum_In_LLI_Range (X : Bignum) return Boolean; + -- Returns True if the Bignum value is in the range of Long_Long_Integer, + -- so that a call to From_Bignum is guaranteed not to raise an exception. + + function To_Bignum (X : Long_Long_Integer) return Bignum; + -- Convert Long_Long_Integer to Bignum. No exception can be raised for any + -- input argument. + + function From_Bignum (X : Bignum) return Long_Long_Integer; + -- Convert Bignum to Long_Long_Integer. Constraint_Error raised with + -- appropriate message if value is out of range of Long_Long_Integer. + +end System.Bignums; diff --git a/gcc/ada/libgnat/s-bitops.adb b/gcc/ada/libgnat/s-bitops.adb new file mode 100644 index 0000000..effc046 --- /dev/null +++ b/gcc/ada/libgnat/s-bitops.adb @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . B I T _ O P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System; use System; +with System.Unsigned_Types; use System.Unsigned_Types; + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Unchecked_Conversion; + +package body System.Bit_Ops is + + subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive); + -- Dummy array type used to interpret the address values. We use the + -- unaligned version always, since this will handle both the aligned and + -- unaligned cases, and we always do these operations by bytes anyway. + -- Note: we use a ones origin array here so that the computations of the + -- length in bytes work correctly (give a non-negative value) for the + -- case of zero length bit strings). Note that we never allocate any + -- objects of this type (we can't because they would be absurdly big). + + type Bits is access Bits_Array; + -- This is the actual type into which address values are converted + + function To_Bits is new Ada.Unchecked_Conversion (Address, Bits); + + LE : constant := Standard'Default_Bit_Order; + -- Static constant set to 0 for big-endian, 1 for little-endian + + -- The following is an array of masks used to mask the final byte, either + -- at the high end (big-endian case) or the low end (little-endian case). + + Masks : constant array (1 .. 7) of Packed_Byte := ( + (1 - LE) * 2#1000_0000# + LE * 2#0000_0001#, + (1 - LE) * 2#1100_0000# + LE * 2#0000_0011#, + (1 - LE) * 2#1110_0000# + LE * 2#0000_0111#, + (1 - LE) * 2#1111_0000# + LE * 2#0000_1111#, + (1 - LE) * 2#1111_1000# + LE * 2#0001_1111#, + (1 - LE) * 2#1111_1100# + LE * 2#0011_1111#, + (1 - LE) * 2#1111_1110# + LE * 2#0111_1111#); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Raise_Error; + pragma No_Return (Raise_Error); + -- Raise Constraint_Error, complaining about unequal lengths + + ------------- + -- Bit_And -- + ------------- + + procedure Bit_And + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : Address) + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + ResultB : constant Bits := To_Bits (Result); + + begin + if Llen /= Rlen then + Raise_Error; + end if; + + for J in 1 .. (Rlen + 7) / 8 loop + ResultB (J) := LeftB (J) and RightB (J); + end loop; + end Bit_And; + + ------------ + -- Bit_Eq -- + ------------ + + function Bit_Eq + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural) return Boolean + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + + begin + if Llen /= Rlen then + return False; + + else + declare + BLen : constant Natural := Llen / 8; + Bitc : constant Natural := Llen mod 8; + + begin + if LeftB (1 .. BLen) /= RightB (1 .. BLen) then + return False; + + elsif Bitc /= 0 then + return + ((LeftB (BLen + 1) xor RightB (BLen + 1)) + and Masks (Bitc)) = 0; + + else -- Bitc = 0 + return True; + end if; + end; + end if; + end Bit_Eq; + + ------------- + -- Bit_Not -- + ------------- + + procedure Bit_Not + (Opnd : System.Address; + Len : Natural; + Result : System.Address) + is + OpndB : constant Bits := To_Bits (Opnd); + ResultB : constant Bits := To_Bits (Result); + + begin + for J in 1 .. (Len + 7) / 8 loop + ResultB (J) := not OpndB (J); + end loop; + end Bit_Not; + + ------------ + -- Bit_Or -- + ------------ + + procedure Bit_Or + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : Address) + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + ResultB : constant Bits := To_Bits (Result); + + begin + if Llen /= Rlen then + Raise_Error; + end if; + + for J in 1 .. (Rlen + 7) / 8 loop + ResultB (J) := LeftB (J) or RightB (J); + end loop; + end Bit_Or; + + ------------- + -- Bit_Xor -- + ------------- + + procedure Bit_Xor + (Left : Address; + Llen : Natural; + Right : Address; + Rlen : Natural; + Result : Address) + is + LeftB : constant Bits := To_Bits (Left); + RightB : constant Bits := To_Bits (Right); + ResultB : constant Bits := To_Bits (Result); + + begin + if Llen /= Rlen then + Raise_Error; + end if; + + for J in 1 .. (Rlen + 7) / 8 loop + ResultB (J) := LeftB (J) xor RightB (J); + end loop; + end Bit_Xor; + + ----------------- + -- Raise_Error -- + ----------------- + + procedure Raise_Error is + begin + Raise_Exception + (Constraint_Error'Identity, "operand lengths are unequal"); + end Raise_Error; + +end System.Bit_Ops; diff --git a/gcc/ada/libgnat/s-bitops.ads b/gcc/ada/libgnat/s-bitops.ads new file mode 100644 index 0000000..1b6b3ba --- /dev/null +++ b/gcc/ada/libgnat/s-bitops.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . B I T _ O P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Operations on packed bit strings + +pragma Compiler_Unit_Warning; + +with System; + +package System.Bit_Ops is + + -- Note: in all the following routines, the System.Address parameters + -- represent the address of the first byte of an array used to represent + -- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4}) + -- The length in bits is passed as a separate parameter. Note that all + -- addresses must be of byte aligned arrays. + + procedure Bit_And + (Left : System.Address; + Llen : Natural; + Right : System.Address; + Rlen : Natural; + Result : System.Address); + -- Bitwise "and" of given bit string with result being placed in Result. + -- The and operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Left, Right + -- and Result always have the same length in bits (Len). + + function Bit_Eq + (Left : System.Address; + Llen : Natural; + Right : System.Address; + Rlen : Natural) return Boolean; + -- Left and Right are the addresses of two bit packed arrays with Llen + -- and Rlen being the respective length in bits. The routine compares the + -- two bit strings for equality, being careful not to include the unused + -- bits in the final byte. Note that the result is always False if Rlen + -- is not equal to Llen. + + procedure Bit_Not + (Opnd : System.Address; + Len : Natural; + Result : System.Address); + -- Bitwise "not" of given bit string with result being placed in Result. + -- The not operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Result and + -- Opnd always have the same length in bits (Len). + + procedure Bit_Or + (Left : System.Address; + Llen : Natural; + Right : System.Address; + Rlen : Natural; + Result : System.Address); + -- Bitwise "or" of given bit string with result being placed in Result. + -- The or operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Left, Right + -- and Result always have the same length in bits (Len). + + procedure Bit_Xor + (Left : System.Address; + Llen : Natural; + Right : System.Address; + Rlen : Natural; + Result : System.Address); + -- Bitwise "xor" of given bit string with result being placed in Result. + -- The xor operation is allowed to destroy unused bits in the last byte, + -- i.e. to leave them set in an undefined manner. Note that Left, Right + -- and Result always have the same length in bits (Len). + +end System.Bit_Ops; diff --git a/gcc/ada/libgnat/s-boarop.ads b/gcc/ada/libgnat/s-boarop.ads new file mode 100644 index 0000000..06cc4a9 --- /dev/null +++ b/gcc/ada/libgnat/s-boarop.ads @@ -0,0 +1,65 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . B O O L E A N _ A R R A Y _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime operations on boolean arrays + +with System.Generic_Vector_Operations; +with System.Vectors.Boolean_Operations; + +package System.Boolean_Array_Operations is + pragma Pure; + + type Boolean_Array is array (Integer range <>) of Boolean; + + package Boolean_Operations renames System.Vectors.Boolean_Operations; + + package Vector_Operations is + new Generic_Vector_Operations (Boolean, Integer, Boolean_Array); + + generic procedure Binary_Operation + renames Vector_Operations.Binary_Operation; + + generic procedure Unary_Operation + renames Vector_Operations.Unary_Operation; + + procedure Vector_Not is + new Unary_Operation ("not", Boolean_Operations."not"); + procedure Vector_And is new Binary_Operation ("and", System.Vectors."and"); + procedure Vector_Or is new Binary_Operation ("or", System.Vectors."or"); + procedure Vector_Xor is new Binary_Operation ("xor", System.Vectors."xor"); + + procedure Vector_Nand is + new Binary_Operation (Boolean_Operations.Nand, Boolean_Operations.Nand); + procedure Vector_Nor is + new Binary_Operation (Boolean_Operations.Nor, Boolean_Operations.Nor); + procedure Vector_Nxor is + new Binary_Operation (Boolean_Operations.Nxor, Boolean_Operations.Nxor); +end System.Boolean_Array_Operations; diff --git a/gcc/ada/libgnat/s-boustr.adb b/gcc/ada/libgnat/s-boustr.adb new file mode 100644 index 0000000..1fba479 --- /dev/null +++ b/gcc/ada/libgnat/s-boustr.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . B O U N D E D _ S T R I N G S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2016-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; + +package body System.Bounded_Strings is + + ------------ + -- Append -- + ------------ + + procedure Append (X : in out Bounded_String; C : Character) is + begin + -- If we have too many characters to fit, simply drop them + + if X.Length < X.Max_Length then + X.Length := X.Length + 1; + X.Chars (X.Length) := C; + end if; + end Append; + + procedure Append (X : in out Bounded_String; S : String) is + begin + for C of S loop + Append (X, C); + end loop; + end Append; + + -------------------- + -- Append_Address -- + -------------------- + + procedure Append_Address (X : in out Bounded_String; A : Address) + is + S : String (1 .. 18); + P : Natural; + use System.Storage_Elements; + N : Integer_Address; + + H : constant array (Integer range 0 .. 15) of Character := + "0123456789abcdef"; + begin + P := S'Last; + N := To_Integer (A); + loop + S (P) := H (Integer (N mod 16)); + P := P - 1; + N := N / 16; + exit when N = 0; + end loop; + + S (P - 1) := '0'; + S (P) := 'x'; + + Append (X, S (P - 1 .. S'Last)); + end Append_Address; + + ------------- + -- Is_Full -- + ------------- + + function Is_Full (X : Bounded_String) return Boolean is + begin + return X.Length >= X.Max_Length; + end Is_Full; + + --------------- + -- To_String -- + --------------- + + function To_String (X : Bounded_String) return String is + begin + return X.Chars (1 .. X.Length); + end To_String; + +end System.Bounded_Strings; diff --git a/gcc/ada/libgnat/s-boustr.ads b/gcc/ada/libgnat/s-boustr.ads new file mode 100644 index 0000000..458678a --- /dev/null +++ b/gcc/ada/libgnat/s-boustr.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . B O U N D E D _ S T R I N G S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2016-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- A very simple implentation of bounded strings, used by tracebacks + +package System.Bounded_Strings is + type Bounded_String (Max_Length : Natural) is limited private; + -- A string whose length is bounded by Max_Length. The bounded string is + -- empty at initialization. + + procedure Append (X : in out Bounded_String; C : Character); + procedure Append (X : in out Bounded_String; S : String); + -- Append a character or a string to X. If the bounded string is full, + -- extra characters are simply dropped. + + function To_String (X : Bounded_String) return String; + function "+" (X : Bounded_String) return String renames To_String; + -- Convert to a normal string + + procedure Append_Address (X : in out Bounded_String; A : Address); + -- Append an address to X + + function Is_Full (X : Bounded_String) return Boolean; + -- Return True iff X is full and any character or string will be dropped + -- if appended. +private + type Bounded_String (Max_Length : Natural) is limited record + Length : Natural := 0; + -- Current length of the string + + Chars : String (1 .. Max_Length); + -- String content + end record; +end System.Bounded_Strings; diff --git a/gcc/ada/libgnat/s-bytswa.ads b/gcc/ada/libgnat/s-bytswa.ads new file mode 100644 index 0000000..ab1e5d0 --- /dev/null +++ b/gcc/ada/libgnat/s-bytswa.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . B Y T E _ S W A P P I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Intrinsic routines for byte swapping. These are used by the expanded code +-- (supporting alternative byte ordering), and by the GNAT.Byte_Swapping run +-- time package which provides user level routines for byte swapping. + +package System.Byte_Swapping is + + pragma Pure; + + type U16 is mod 2**16; + type U32 is mod 2**32; + type U64 is mod 2**64; + + function Bswap_16 (X : U16) return U16; + pragma Import (Intrinsic, Bswap_16, "__builtin_bswap16"); + + function Bswap_32 (X : U32) return U32; + pragma Import (Intrinsic, Bswap_32, "__builtin_bswap32"); + + function Bswap_64 (X : U64) return U64; + pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64"); + +end System.Byte_Swapping; diff --git a/gcc/ada/libgnat/s-carsi8.adb b/gcc/ada/libgnat/s-carsi8.adb new file mode 100644 index 0000000..303d873 --- /dev/null +++ b/gcc/ada/libgnat/s-carsi8.adb @@ -0,0 +1,143 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Signed_8 is + + type Word is mod 2 ** 32; + -- Used to process operands by words + + type Big_Words is array (Natural) of Word; + type Big_Words_Ptr is access Big_Words; + for Big_Words_Ptr'Storage_Size use 0; + -- Array type used to access by words + + type Byte is range -128 .. +127; + for Byte'Size use 8; + -- Used to process operands by bytes + + type Big_Bytes is array (Natural) of Byte; + type Big_Bytes_Ptr is access Big_Bytes; + for Big_Bytes_Ptr'Storage_Size use 0; + -- Array type used to access by bytes + + function To_Big_Words is new + Ada.Unchecked_Conversion (System.Address, Big_Words_Ptr); + + function To_Big_Bytes is new + Ada.Unchecked_Conversion (System.Address, Big_Bytes_Ptr); + + ---------------------- + -- Compare_Array_S8 -- + ---------------------- + + function Compare_Array_S8 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); + + begin + -- If operands are non-aligned, or length is too short, go by bytes + + if ModA (OrA (Left, Right), 4) /= 0 or else Compare_Len < 4 then + return Compare_Array_S8_Unaligned (Left, Right, Left_Len, Right_Len); + end if; + + -- Here we can go by words + + declare + LeftP : constant Big_Words_Ptr := + To_Big_Words (Left); + RightP : constant Big_Words_Ptr := + To_Big_Words (Right); + Words_To_Compare : constant Natural := Compare_Len / 4; + Bytes_Compared_As_Words : constant Natural := Words_To_Compare * 4; + + begin + for J in 0 .. Words_To_Compare - 1 loop + if LeftP (J) /= RightP (J) then + return Compare_Array_S8_Unaligned + (AddA (Left, Address (4 * J)), + AddA (Right, Address (4 * J)), + 4, 4); + end if; + end loop; + + return Compare_Array_S8_Unaligned + (AddA (Left, Address (Bytes_Compared_As_Words)), + AddA (Right, Address (Bytes_Compared_As_Words)), + Left_Len - Bytes_Compared_As_Words, + Right_Len - Bytes_Compared_As_Words); + end; + end Compare_Array_S8; + + -------------------------------- + -- Compare_Array_S8_Unaligned -- + -------------------------------- + + function Compare_Array_S8_Unaligned + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); + + LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left); + RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right); + + begin + for J in 0 .. Compare_Len - 1 loop + if LeftP (J) /= RightP (J) then + if LeftP (J) > RightP (J) then + return +1; + else + return -1; + end if; + end if; + end loop; + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_S8_Unaligned; + +end System.Compare_Array_Signed_8; diff --git a/gcc/ada/libgnat/s-carsi8.ads b/gcc/ada/libgnat/s-carsi8.ads new file mode 100644 index 0000000..6aedc54 --- /dev/null +++ b/gcc/ada/libgnat/s-carsi8.ads @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 8-bit discrete type values to be treated as signed. + +package System.Compare_Array_Signed_8 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_S8 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words + -- if the operands are aligned on 4-byte boundaries and long enough. + + function Compare_Array_S8_Unaligned + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Same functionality as Compare_Array_S8 but always proceeds by + -- bytes. Used when the caller knows that the operands are unaligned, + -- or short enough that it makes no sense to go by words. + +end System.Compare_Array_Signed_8; diff --git a/gcc/ada/libgnat/s-carun8.adb b/gcc/ada/libgnat/s-carun8.adb new file mode 100644 index 0000000..65c867c --- /dev/null +++ b/gcc/ada/libgnat/s-carun8.adb @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Unsigned_8 is + + type Word is mod 2 ** 32; + -- Used to process operands by words + + type Big_Words is array (Natural) of Word; + type Big_Words_Ptr is access Big_Words; + for Big_Words_Ptr'Storage_Size use 0; + -- Array type used to access by words + + type Byte is mod 2 ** 8; + -- Used to process operands by bytes + + type Big_Bytes is array (Natural) of Byte; + type Big_Bytes_Ptr is access Big_Bytes; + for Big_Bytes_Ptr'Storage_Size use 0; + -- Array type used to access by bytes + + function To_Big_Words is new + Ada.Unchecked_Conversion (System.Address, Big_Words_Ptr); + + function To_Big_Bytes is new + Ada.Unchecked_Conversion (System.Address, Big_Bytes_Ptr); + + ---------------------- + -- Compare_Array_U8 -- + ---------------------- + + function Compare_Array_U8 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); + + begin + -- If operands are non-aligned, or length is too short, go by bytes + + if (ModA (OrA (Left, Right), 4) /= 0) or else Compare_Len < 4 then + return Compare_Array_U8_Unaligned (Left, Right, Left_Len, Right_Len); + end if; + + -- Here we can go by words + + declare + LeftP : constant Big_Words_Ptr := + To_Big_Words (Left); + RightP : constant Big_Words_Ptr := + To_Big_Words (Right); + Words_To_Compare : constant Natural := Compare_Len / 4; + Bytes_Compared_As_Words : constant Natural := Words_To_Compare * 4; + + begin + for J in 0 .. Words_To_Compare - 1 loop + if LeftP (J) /= RightP (J) then + return Compare_Array_U8_Unaligned + (AddA (Left, Address (4 * J)), + AddA (Right, Address (4 * J)), + 4, 4); + end if; + end loop; + + return Compare_Array_U8_Unaligned + (AddA (Left, Address (Bytes_Compared_As_Words)), + AddA (Right, Address (Bytes_Compared_As_Words)), + Left_Len - Bytes_Compared_As_Words, + Right_Len - Bytes_Compared_As_Words); + end; + end Compare_Array_U8; + + -------------------------------- + -- Compare_Array_U8_Unaligned -- + -------------------------------- + + function Compare_Array_U8_Unaligned + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); + + LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left); + RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right); + + begin + for J in 0 .. Compare_Len - 1 loop + if LeftP (J) /= RightP (J) then + if LeftP (J) > RightP (J) then + return +1; + else + return -1; + end if; + end if; + end loop; + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_U8_Unaligned; + +end System.Compare_Array_Unsigned_8; diff --git a/gcc/ada/libgnat/s-carun8.ads b/gcc/ada/libgnat/s-carun8.ads new file mode 100644 index 0000000..f2328a1 --- /dev/null +++ b/gcc/ada/libgnat/s-carun8.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 8-bit discrete type values to be treated as unsigned. + +pragma Compiler_Unit_Warning; + +package System.Compare_Array_Unsigned_8 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_U8 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len with the + -- array starting at address Right of length Right_Len. The comparison is + -- in the normal Ada semantic sense of array comparison. The result is -1, + -- 0, +1 for Left < Right, Left = Right, Left > Right respectively. This + -- function works with 4 byte words if the operands are aligned on 4-byte + -- boundaries and long enough. + + function Compare_Array_U8_Unaligned + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Same functionality as Compare_Array_U8 but always proceeds by bytes. + -- Used when the caller knows that the operands are unaligned, or short + -- enough that it makes no sense to go by words. + +end System.Compare_Array_Unsigned_8; diff --git a/gcc/ada/libgnat/s-casi16.adb b/gcc/ada/libgnat/s-casi16.adb new file mode 100644 index 0000000..01f788e --- /dev/null +++ b/gcc/ada/libgnat/s-casi16.adb @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Signed_16 is + + type Word is mod 2 ** 32; + -- Used to process operands by words + + type Half is range -(2 ** 15) .. (2 ** 15) - 1; + for Half'Size use 16; + -- Used to process operands by half words + + type Uhalf is new Half; + for Uhalf'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type HP is access Half; + type UP is access Uhalf; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function H is new Ada.Unchecked_Conversion (Address, HP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ----------------------- + -- Compare_Array_S16 -- + ----------------------- + + function Compare_Array_S16 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Go by words if possible + + if ModA (OrA (Left, Right), 4) = 0 then + while Clen > 1 + and then W (L).all = W (R).all + loop + Clen := Clen - 2; + L := AddA (L, 4); + R := AddA (R, 4); + end loop; + end if; + + -- Case of going by aligned half words + + if ModA (OrA (Left, Right), 2) = 0 then + while Clen /= 0 loop + if H (L).all /= H (R).all then + if H (L).all > H (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 2); + R := AddA (R, 2); + end loop; + + -- Case of going by unaligned half words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 2); + R := AddA (R, 2); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_S16; + +end System.Compare_Array_Signed_16; diff --git a/gcc/ada/libgnat/s-casi16.ads b/gcc/ada/libgnat/s-casi16.ads new file mode 100644 index 0000000..bf2be62 --- /dev/null +++ b/gcc/ada/libgnat/s-casi16.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 16-bit discrete type values to be treated as signed. + +package System.Compare_Array_Signed_16 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_S16 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words + -- if the operands are aligned on 4-byte boundaries and long enough. + +end System.Compare_Array_Signed_16; diff --git a/gcc/ada/libgnat/s-casi32.adb b/gcc/ada/libgnat/s-casi32.adb new file mode 100644 index 0000000..6cfebeb --- /dev/null +++ b/gcc/ada/libgnat/s-casi32.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Signed_32 is + + type Word is range -2**31 .. 2**31 - 1; + for Word'Size use 32; + -- Used to process operands by words + + type Uword is new Word; + for Uword'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type UP is access Uword; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ----------------------- + -- Compare_Array_S32 -- + ----------------------- + + function Compare_Array_S32 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Case of going by aligned words + + if ModA (OrA (Left, Right), 4) = 0 then + while Clen /= 0 loop + if W (L).all /= W (R).all then + if W (L).all > W (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 4); + R := AddA (R, 4); + end loop; + + -- Case of going by unaligned words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 4); + R := AddA (R, 4); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_S32; + +end System.Compare_Array_Signed_32; diff --git a/gcc/ada/libgnat/s-casi32.ads b/gcc/ada/libgnat/s-casi32.ads new file mode 100644 index 0000000..27afe68 --- /dev/null +++ b/gcc/ada/libgnat/s-casi32.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 32-bit discrete type values to be treated as signed. + +package System.Compare_Array_Signed_32 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_S32 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) + return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for LeftRight respectively. + +end System.Compare_Array_Signed_32; diff --git a/gcc/ada/libgnat/s-casi64.adb b/gcc/ada/libgnat/s-casi64.adb new file mode 100644 index 0000000..84c08e4 --- /dev/null +++ b/gcc/ada/libgnat/s-casi64.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 6 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Signed_64 is + + type Word is range -2**63 .. 2**63 - 1; + for Word'Size use 64; + -- Used to process operands by words + + type Uword is new Word; + for Uword'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type UP is access Uword; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ----------------------- + -- Compare_Array_S64 -- + ----------------------- + + function Compare_Array_S64 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Case of going by aligned double words + + if ModA (OrA (Left, Right), 8) = 0 then + while Clen /= 0 loop + if W (L).all /= W (R).all then + if W (L).all > W (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 8); + R := AddA (R, 8); + end loop; + + -- Case of going by unaligned double words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 8); + R := AddA (R, 8); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_S64; + +end System.Compare_Array_Signed_64; diff --git a/gcc/ada/libgnat/s-casi64.ads b/gcc/ada/libgnat/s-casi64.ads new file mode 100644 index 0000000..8d9f387 --- /dev/null +++ b/gcc/ada/libgnat/s-casi64.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 64-bit discrete type values to be treated as signed. + +package System.Compare_Array_Signed_64 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_S64 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for LeftRight respectively. + +end System.Compare_Array_Signed_64; diff --git a/gcc/ada/libgnat/s-casuti.adb b/gcc/ada/libgnat/s-casuti.adb new file mode 100644 index 0000000..96cc9ab --- /dev/null +++ b/gcc/ada/libgnat/s-casuti.adb @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . C A S E _ U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.Case_Util is + + -------------- + -- To_Lower -- + -------------- + + function To_Lower (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); + + begin + if A in 'A' .. 'Z' + or else A_Val in 16#C0# .. 16#D6# + or else A_Val in 16#D8# .. 16#DE# + then + return Character'Val (A_Val + 16#20#); + else + return A; + end if; + end To_Lower; + + procedure To_Lower (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Lower (A (J)); + end loop; + end To_Lower; + + -------------- + -- To_Mixed -- + -------------- + + procedure To_Mixed (A : in out String) is + Ucase : Boolean := True; + + begin + for J in A'Range loop + if Ucase then + A (J) := To_Upper (A (J)); + else + A (J) := To_Lower (A (J)); + end if; + + Ucase := A (J) = '_'; + end loop; + end To_Mixed; + + -------------- + -- To_Upper -- + -------------- + + function To_Upper (A : Character) return Character is + A_Val : constant Natural := Character'Pos (A); + + begin + if A in 'a' .. 'z' + or else A_Val in 16#E0# .. 16#F6# + or else A_Val in 16#F8# .. 16#FE# + then + return Character'Val (A_Val - 16#20#); + else + return A; + end if; + end To_Upper; + + procedure To_Upper (A : in out String) is + begin + for J in A'Range loop + A (J) := To_Upper (A (J)); + end loop; + end To_Upper; + +end System.Case_Util; diff --git a/gcc/ada/libgnat/s-casuti.ads b/gcc/ada/libgnat/s-casuti.ads new file mode 100644 index 0000000..6b37c95 --- /dev/null +++ b/gcc/ada/libgnat/s-casuti.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . C A S E _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple casing functions + +-- This package provides simple casing functions that do not require the +-- overhead of the full casing tables found in Ada.Characters.Handling. + +-- Note that all the routines in this package are available to the user +-- via GNAT.Case_Util, which imports all the entities from this package. + +pragma Compiler_Unit_Warning; + +package System.Case_Util is + pragma Pure; + + -- Note: all the following functions handle the full Latin-1 set + + function To_Upper (A : Character) return Character; + -- Converts A to upper case if it is a lower case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Upper (A : in out String); + -- Folds all characters of string A to upper case + + function To_Lower (A : Character) return Character; + -- Converts A to lower case if it is an upper case letter, otherwise + -- returns the input argument unchanged. + + procedure To_Lower (A : in out String); + -- Folds all characters of string A to lower case + + procedure To_Mixed (A : in out String); + -- Converts A to mixed case (i.e. lower case, except for initial + -- character and any character after an underscore, which are + -- converted to upper case. + +end System.Case_Util; diff --git a/gcc/ada/libgnat/s-caun16.adb b/gcc/ada/libgnat/s-caun16.adb new file mode 100644 index 0000000..720febd --- /dev/null +++ b/gcc/ada/libgnat/s-caun16.adb @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Unsigned_16 is + + type Word is mod 2 ** 32; + -- Used to process operands by words + + type Half is mod 2 ** 16; + for Half'Size use 16; + -- Used to process operands by half words + + type Uhalf is new Half; + for Uhalf'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type HP is access Half; + type UP is access Uhalf; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function H is new Ada.Unchecked_Conversion (Address, HP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ----------------------- + -- Compare_Array_U16 -- + ----------------------- + + function Compare_Array_U16 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Go by words if possible + + if ModA (OrA (Left, Right), 4) = 0 then + while Clen > 1 + and then W (L).all = W (R).all + loop + Clen := Clen - 2; + L := AddA (L, 4); + R := AddA (R, 4); + end loop; + end if; + + -- Case of going by aligned half words + + if ModA (OrA (Left, Right), 2) = 0 then + while Clen /= 0 loop + if H (L).all /= H (R).all then + if H (L).all > H (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 2); + R := AddA (R, 2); + end loop; + + -- Case of going by unaligned half words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 2); + R := AddA (R, 2); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_U16; + +end System.Compare_Array_Unsigned_16; diff --git a/gcc/ada/libgnat/s-caun16.ads b/gcc/ada/libgnat/s-caun16.ads new file mode 100644 index 0000000..73f14b4 --- /dev/null +++ b/gcc/ada/libgnat/s-caun16.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 16-bit discrete type values to be treated as unsigned. + +package System.Compare_Array_Unsigned_16 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_U16 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words + -- if the operands are aligned on 4-byte boundaries and long enough. + +end System.Compare_Array_Unsigned_16; diff --git a/gcc/ada/libgnat/s-caun32.adb b/gcc/ada/libgnat/s-caun32.adb new file mode 100644 index 0000000..c61a97a --- /dev/null +++ b/gcc/ada/libgnat/s-caun32.adb @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Unsigned_32 is + + type Word is mod 2 ** 32; + for Word'Size use 32; + -- Used to process operands by words + + type Uword is new Word; + for Uword'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type UP is access Uword; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ----------------------- + -- Compare_Array_U32 -- + ----------------------- + + function Compare_Array_U32 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Case of going by aligned words + + if ModA (OrA (Left, Right), 4) = 0 then + while Clen /= 0 loop + if W (L).all /= W (R).all then + if W (L).all > W (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 4); + R := AddA (R, 4); + end loop; + + -- Case of going by unaligned words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 4); + R := AddA (R, 4); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_U32; + +end System.Compare_Array_Unsigned_32; diff --git a/gcc/ada/libgnat/s-caun32.ads b/gcc/ada/libgnat/s-caun32.ads new file mode 100644 index 0000000..64fad02 --- /dev/null +++ b/gcc/ada/libgnat/s-caun32.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 32-bit discrete type values to be treated as unsigned. + +package System.Compare_Array_Unsigned_32 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_U32 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for LeftRight respectively. + +end System.Compare_Array_Unsigned_32; diff --git a/gcc/ada/libgnat/s-caun64.adb b/gcc/ada/libgnat/s-caun64.adb new file mode 100644 index 0000000..43076f5 --- /dev/null +++ b/gcc/ada/libgnat/s-caun64.adb @@ -0,0 +1,115 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 6 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Address_Operations; use System.Address_Operations; + +with Ada.Unchecked_Conversion; + +package body System.Compare_Array_Unsigned_64 is + + type Word is mod 2 ** 64; + -- Used to process operands by words + + type Uword is new Word; + for Uword'Alignment use 1; + -- Used to process operands when unaligned + + type WP is access Word; + type UP is access Uword; + + function W is new Ada.Unchecked_Conversion (Address, WP); + function U is new Ada.Unchecked_Conversion (Address, UP); + + ----------------------- + -- Compare_Array_U64 -- + ----------------------- + + function Compare_Array_U64 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Clen : Natural := Natural'Min (Left_Len, Right_Len); + -- Number of elements left to compare + + L : Address := Left; + R : Address := Right; + -- Pointers to next elements to compare + + begin + -- Case of going by aligned double words + + if ModA (OrA (Left, Right), 8) = 0 then + while Clen /= 0 loop + if W (L).all /= W (R).all then + if W (L).all > W (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 8); + R := AddA (R, 8); + end loop; + + -- Case of going by unaligned double words + + else + while Clen /= 0 loop + if U (L).all /= U (R).all then + if U (L).all > U (R).all then + return +1; + else + return -1; + end if; + end if; + + Clen := Clen - 1; + L := AddA (L, 8); + R := AddA (R, 8); + end loop; + end if; + + -- Here if common section equal, result decided by lengths + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Compare_Array_U64; + +end System.Compare_Array_Unsigned_64; diff --git a/gcc/ada/libgnat/s-caun64.ads b/gcc/ada/libgnat/s-caun64.ads new file mode 100644 index 0000000..0322dd2 --- /dev/null +++ b/gcc/ada/libgnat/s-caun64.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 6 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on arrays whose +-- elements are 64-bit discrete type values to be treated as unsigned. + +package System.Compare_Array_Unsigned_64 is + + -- Note: although the functions in this package are in a sense Pure, the + -- package cannot be declared as Pure, since the arguments are addresses, + -- not the data, and the result is not pure wrt the address values. + + function Compare_Array_U64 + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the array starting at address Left of length Left_Len + -- with the array starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of array + -- comparison. The result is -1,0,+1 for LeftRight respectively. + +end System.Compare_Array_Unsigned_64; diff --git a/gcc/ada/libgnat/s-chepoo.ads b/gcc/ada/libgnat/s-chepoo.ads new file mode 100644 index 0000000..9e68d3b --- /dev/null +++ b/gcc/ada/libgnat/s-chepoo.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . C H E C K E D _ P O O L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Storage_Pools; + +package System.Checked_Pools is + + type Checked_Pool is abstract + new System.Storage_Pools.Root_Storage_Pool with private; + -- Equivalent of storage pools with the addition that Dereference is + -- called on each implicit or explicit dereference of a pointer which + -- has such a storage pool. + + procedure Dereference + (Pool : in out Checked_Pool; + Storage_Address : Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is abstract; + -- Called implicitly each time a pointer to a checked pool is dereferenced + -- All parameters in the profile are compatible with the profile of + -- Allocate/Deallocate: the Storage_Address corresponds to the address of + -- the dereferenced object, Size_in_Storage_Elements is its dynamic size + -- (and thus may involve an implicit dispatching call to size) and + -- Alignment is the alignment of the object. + +private + type Checked_Pool is abstract + new System.Storage_Pools.Root_Storage_Pool with null record; +end System.Checked_Pools; diff --git a/gcc/ada/libgnat/s-commun.adb b/gcc/ada/libgnat/s-commun.adb new file mode 100644 index 0000000..671c6de --- /dev/null +++ b/gcc/ada/libgnat/s-commun.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . C O M M U N I C A T I O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Communication is + + subtype SEO is Ada.Streams.Stream_Element_Offset; + + ---------------- + -- Last_Index -- + ---------------- + + function Last_Index + (First : Ada.Streams.Stream_Element_Offset; + Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset + is + use type Ada.Streams.Stream_Element_Offset; + use type System.CRTL.size_t; + begin + if First = SEO'First and then Count = 0 then + raise Constraint_Error with + "last index out of range (no element transferred)"; + else + return First + SEO (Count) - 1; + end if; + end Last_Index; + +end System.Communication; diff --git a/gcc/ada/libgnat/s-commun.ads b/gcc/ada/libgnat/s-commun.ads new file mode 100644 index 0000000..7c8a757 --- /dev/null +++ b/gcc/ada/libgnat/s-commun.ads @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . C O M M U N I C A T I O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Common support unit for GNAT.Sockets and GNAT.Serial_Communication + +with Ada.Streams; +with System.CRTL; + +package System.Communication is + pragma Preelaborate; + + function Last_Index + (First : Ada.Streams.Stream_Element_Offset; + Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset; + -- Compute the Last OUT parameter for the various Read / Receive + -- subprograms: returns First + Count - 1. + -- + -- When First = Stream_Element_Offset'First and Res = 0, Constraint_Error + -- is raised. This is consistent with the semantics of stream operations + -- as clarified in AI95-227. + +end System.Communication; diff --git a/gcc/ada/libgnat/s-conca2.adb b/gcc/ada/libgnat/s-conca2.adb new file mode 100644 index 0000000..89c9ee0 --- /dev/null +++ b/gcc/ada/libgnat/s-conca2.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.Concat_2 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_2 -- + ------------------ + + procedure Str_Concat_2 (R : out String; S1, S2 : String) is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := R'Last; + R (F .. L) := S2; + end Str_Concat_2; + + ------------------------- + -- Str_Concat_Bounds_2 -- + ------------------------- + + procedure Str_Concat_Bounds_2 + (Lo, Hi : out Natural; + S1, S2 : String) + is + begin + if S1 = "" then + Lo := S2'First; + Hi := S2'Last; + else + Lo := S1'First; + Hi := S1'Last + S2'Length; + end if; + end Str_Concat_Bounds_2; + +end System.Concat_2; diff --git a/gcc/ada/libgnat/s-conca2.ads b/gcc/ada/libgnat/s-conca2.ads new file mode 100644 index 0000000..b950f0b --- /dev/null +++ b/gcc/ada/libgnat/s-conca2.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of two string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_2 is + + procedure Str_Concat_2 (R : out String; S1, S2 : String); + -- Performs the operation R := S1 & S2. The bounds of R are known to be + -- correct (usually set by a call to the Str_Concat_Bounds_2 procedure + -- below), so no bounds checks are required, and it is known that none of + -- the input operands overlaps R. No assumptions can be made about the + -- lower bounds of any of the operands. + + procedure Str_Concat_Bounds_2 + (Lo, Hi : out Natural; + S1, S2 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the two + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_2; diff --git a/gcc/ada/libgnat/s-conca3.adb b/gcc/ada/libgnat/s-conca3.adb new file mode 100644 index 0000000..06f8ec2 --- /dev/null +++ b/gcc/ada/libgnat/s-conca3.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Concat_2; + +package body System.Concat_3 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_3 -- + ------------------ + + procedure Str_Concat_3 (R : out String; S1, S2, S3 : String) is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := F + S2'Length - 1; + R (F .. L) := S2; + + F := L + 1; + L := R'Last; + R (F .. L) := S3; + end Str_Concat_3; + + ------------------------- + -- Str_Concat_Bounds_3 -- + ------------------------- + + procedure Str_Concat_Bounds_3 + (Lo, Hi : out Natural; + S1, S2, S3 : String) + is + begin + System.Concat_2.Str_Concat_Bounds_2 (Lo, Hi, S2, S3); + + if S1 /= "" then + Hi := S1'Last + Hi - Lo + 1; + Lo := S1'First; + end if; + end Str_Concat_Bounds_3; + +end System.Concat_3; diff --git a/gcc/ada/libgnat/s-conca3.ads b/gcc/ada/libgnat/s-conca3.ads new file mode 100644 index 0000000..c24df14 --- /dev/null +++ b/gcc/ada/libgnat/s-conca3.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of three string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_3 is + + procedure Str_Concat_3 (R : out String; S1, S2, S3 : String); + -- Performs the operation R := S1 & S2 & S3. The bounds of R are known to + -- be correct (usually set by a call to the Str_Concat_Bounds_3 procedure + -- below), so no bounds checks are required, and it is known that none of + -- the input operands overlaps R. No assumptions can be made about the + -- lower bounds of any of the operands. + + procedure Str_Concat_Bounds_3 + (Lo, Hi : out Natural; + S1, S2, S3 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the three + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_3; diff --git a/gcc/ada/libgnat/s-conca4.adb b/gcc/ada/libgnat/s-conca4.adb new file mode 100644 index 0000000..f081cf2 --- /dev/null +++ b/gcc/ada/libgnat/s-conca4.adb @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Concat_3; + +package body System.Concat_4 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_4 -- + ------------------ + + procedure Str_Concat_4 (R : out String; S1, S2, S3, S4 : String) is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := F + S2'Length - 1; + R (F .. L) := S2; + + F := L + 1; + L := F + S3'Length - 1; + R (F .. L) := S3; + + F := L + 1; + L := R'Last; + R (F .. L) := S4; + end Str_Concat_4; + + ------------------------- + -- Str_Concat_Bounds_4 -- + ------------------------- + + procedure Str_Concat_Bounds_4 + (Lo, Hi : out Natural; + S1, S2, S3, S4 : String) + is + begin + System.Concat_3.Str_Concat_Bounds_3 (Lo, Hi, S2, S3, S4); + + if S1 /= "" then + Hi := S1'Last + Hi - Lo + 1; + Lo := S1'First; + end if; + end Str_Concat_Bounds_4; + +end System.Concat_4; diff --git a/gcc/ada/libgnat/s-conca4.ads b/gcc/ada/libgnat/s-conca4.ads new file mode 100644 index 0000000..33194e0 --- /dev/null +++ b/gcc/ada/libgnat/s-conca4.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of four string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_4 is + + procedure Str_Concat_4 (R : out String; S1, S2, S3, S4 : String); + -- Performs the operation R := S1 & S2 & S3 & S4. The bounds + -- of R are known to be correct (usually set by a call to the + -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, + -- and it is known that none of the input operands overlaps R. No + -- assumptions can be made about the lower bounds of any of the operands. + + procedure Str_Concat_Bounds_4 + (Lo, Hi : out Natural; + S1, S2, S3, S4 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the four + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_4; diff --git a/gcc/ada/libgnat/s-conca5.adb b/gcc/ada/libgnat/s-conca5.adb new file mode 100644 index 0000000..085420e --- /dev/null +++ b/gcc/ada/libgnat/s-conca5.adb @@ -0,0 +1,86 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Concat_4; + +package body System.Concat_5 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_5 -- + ------------------ + + procedure Str_Concat_5 (R : out String; S1, S2, S3, S4, S5 : String) is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := F + S2'Length - 1; + R (F .. L) := S2; + + F := L + 1; + L := F + S3'Length - 1; + R (F .. L) := S3; + + F := L + 1; + L := F + S4'Length - 1; + R (F .. L) := S4; + + F := L + 1; + L := R'Last; + R (F .. L) := S5; + end Str_Concat_5; + + ------------------------- + -- Str_Concat_Bounds_5 -- + ------------------------- + + procedure Str_Concat_Bounds_5 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5 : String) + is + begin + System.Concat_4.Str_Concat_Bounds_4 (Lo, Hi, S2, S3, S4, S5); + + if S1 /= "" then + Hi := S1'Last + Hi - Lo + 1; + Lo := S1'First; + end if; + end Str_Concat_Bounds_5; + +end System.Concat_5; diff --git a/gcc/ada/libgnat/s-conca5.ads b/gcc/ada/libgnat/s-conca5.ads new file mode 100644 index 0000000..ac45d5b --- /dev/null +++ b/gcc/ada/libgnat/s-conca5.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of five string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_5 is + + procedure Str_Concat_5 (R : out String; S1, S2, S3, S4, S5 : String); + -- Performs the operation R := S1 & S2 & S3 & S4 & S5. The bounds + -- of R are known to be correct (usually set by a call to the + -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, + -- and it is known that none of the input operands overlaps R. No + -- assumptions can be made about the lower bounds of any of the operands. + + procedure Str_Concat_Bounds_5 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the five + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_5; diff --git a/gcc/ada/libgnat/s-conca6.adb b/gcc/ada/libgnat/s-conca6.adb new file mode 100644 index 0000000..8773e0d --- /dev/null +++ b/gcc/ada/libgnat/s-conca6.adb @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Concat_5; + +package body System.Concat_6 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_6 -- + ------------------ + + procedure Str_Concat_6 (R : out String; S1, S2, S3, S4, S5, S6 : String) is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := F + S2'Length - 1; + R (F .. L) := S2; + + F := L + 1; + L := F + S3'Length - 1; + R (F .. L) := S3; + + F := L + 1; + L := F + S4'Length - 1; + R (F .. L) := S4; + + F := L + 1; + L := F + S5'Length - 1; + R (F .. L) := S5; + + F := L + 1; + L := R'Last; + R (F .. L) := S6; + end Str_Concat_6; + + ------------------------- + -- Str_Concat_Bounds_6 -- + ------------------------- + + procedure Str_Concat_Bounds_6 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6 : String) + is + begin + System.Concat_5.Str_Concat_Bounds_5 (Lo, Hi, S2, S3, S4, S5, S6); + + if S1 /= "" then + Hi := S1'Last + Hi - Lo + 1; + Lo := S1'First; + end if; + end Str_Concat_Bounds_6; + +end System.Concat_6; diff --git a/gcc/ada/libgnat/s-conca6.ads b/gcc/ada/libgnat/s-conca6.ads new file mode 100644 index 0000000..acbb8a6 --- /dev/null +++ b/gcc/ada/libgnat/s-conca6.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of six string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_6 is + + procedure Str_Concat_6 (R : out String; S1, S2, S3, S4, S5, S6 : String); + -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6. The + -- bounds of R are known to be correct (usually set by a call to the + -- Str_Concat_Bounds_6 procedure below), so no bounds checks are required, + -- and it is known that none of the input operands overlaps R. No + -- assumptions can be made about the lower bounds of any of the operands. + + procedure Str_Concat_Bounds_6 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the six + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_6; diff --git a/gcc/ada/libgnat/s-conca7.adb b/gcc/ada/libgnat/s-conca7.adb new file mode 100644 index 0000000..df45785 --- /dev/null +++ b/gcc/ada/libgnat/s-conca7.adb @@ -0,0 +1,97 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Concat_6; + +package body System.Concat_7 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_7 -- + ------------------ + + procedure Str_Concat_7 + (R : out String; + S1, S2, S3, S4, S5, S6, S7 : String) + is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := F + S2'Length - 1; + R (F .. L) := S2; + + F := L + 1; + L := F + S3'Length - 1; + R (F .. L) := S3; + + F := L + 1; + L := F + S4'Length - 1; + R (F .. L) := S4; + + F := L + 1; + L := F + S5'Length - 1; + R (F .. L) := S5; + + F := L + 1; + L := F + S6'Length - 1; + R (F .. L) := S6; + + F := L + 1; + L := R'Last; + R (F .. L) := S7; + end Str_Concat_7; + + ------------------------- + -- Str_Concat_Bounds_7 -- + ------------------------- + + procedure Str_Concat_Bounds_7 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6, S7 : String) + is + begin + System.Concat_6.Str_Concat_Bounds_6 (Lo, Hi, S2, S3, S4, S5, S6, S7); + + if S1 /= "" then + Hi := S1'Last + Hi - Lo + 1; + Lo := S1'First; + end if; + end Str_Concat_Bounds_7; + +end System.Concat_7; diff --git a/gcc/ada/libgnat/s-conca7.ads b/gcc/ada/libgnat/s-conca7.ads new file mode 100644 index 0000000..601c6c0 --- /dev/null +++ b/gcc/ada/libgnat/s-conca7.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of seven string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_7 is + + procedure Str_Concat_7 + (R : out String; + S1, S2, S3, S4, S5, S6, S7 : String); + -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7. The + -- bounds of R are known to be correct (usually set by a call to the + -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, + -- and it is known that none of the input operands overlaps R. No + -- assumptions can be made about the lower bounds of any of the operands. + + procedure Str_Concat_Bounds_7 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6, S7 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the seven + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_7; diff --git a/gcc/ada/libgnat/s-conca8.adb b/gcc/ada/libgnat/s-conca8.adb new file mode 100644 index 0000000..c81fd24 --- /dev/null +++ b/gcc/ada/libgnat/s-conca8.adb @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Concat_7; + +package body System.Concat_8 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_8 -- + ------------------ + + procedure Str_Concat_8 + (R : out String; + S1, S2, S3, S4, S5, S6, S7, S8 : String) + is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := F + S2'Length - 1; + R (F .. L) := S2; + + F := L + 1; + L := F + S3'Length - 1; + R (F .. L) := S3; + + F := L + 1; + L := F + S4'Length - 1; + R (F .. L) := S4; + + F := L + 1; + L := F + S5'Length - 1; + R (F .. L) := S5; + + F := L + 1; + L := F + S6'Length - 1; + R (F .. L) := S6; + + F := L + 1; + L := F + S7'Length - 1; + R (F .. L) := S7; + + F := L + 1; + L := R'Last; + R (F .. L) := S8; + end Str_Concat_8; + + ------------------------- + -- Str_Concat_Bounds_8 -- + ------------------------- + + procedure Str_Concat_Bounds_8 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6, S7, S8 : String) + is + begin + System.Concat_7.Str_Concat_Bounds_7 + (Lo, Hi, S2, S3, S4, S5, S6, S7, S8); + + if S1 /= "" then + Hi := S1'Last + Hi - Lo + 1; + Lo := S1'First; + end if; + end Str_Concat_Bounds_8; + +end System.Concat_8; diff --git a/gcc/ada/libgnat/s-conca8.ads b/gcc/ada/libgnat/s-conca8.ads new file mode 100644 index 0000000..19948d4 --- /dev/null +++ b/gcc/ada/libgnat/s-conca8.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of eight string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_8 is + + procedure Str_Concat_8 + (R : out String; + S1, S2, S3, S4, S5, S6, S7, S8 : String); + -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8. + -- The bounds of R are known to be correct (usually set by a call to the + -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, + -- and it is known that none of the input operands overlaps R. No + -- assumptions can be made about the lower bounds of any of the operands. + + procedure Str_Concat_Bounds_8 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6, S7, S8 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the eight + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_8; diff --git a/gcc/ada/libgnat/s-conca9.adb b/gcc/ada/libgnat/s-conca9.adb new file mode 100644 index 0000000..b71d63a --- /dev/null +++ b/gcc/ada/libgnat/s-conca9.adb @@ -0,0 +1,106 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Concat_8; + +package body System.Concat_9 is + + pragma Suppress (All_Checks); + + ------------------ + -- Str_Concat_9 -- + ------------------ + + procedure Str_Concat_9 + (R : out String; + S1, S2, S3, S4, S5, S6, S7, S8, S9 : String) + is + F, L : Natural; + + begin + F := R'First; + L := F + S1'Length - 1; + R (F .. L) := S1; + + F := L + 1; + L := F + S2'Length - 1; + R (F .. L) := S2; + + F := L + 1; + L := F + S3'Length - 1; + R (F .. L) := S3; + + F := L + 1; + L := F + S4'Length - 1; + R (F .. L) := S4; + + F := L + 1; + L := F + S5'Length - 1; + R (F .. L) := S5; + + F := L + 1; + L := F + S6'Length - 1; + R (F .. L) := S6; + + F := L + 1; + L := F + S7'Length - 1; + R (F .. L) := S7; + + F := L + 1; + L := F + S8'Length - 1; + R (F .. L) := S8; + + F := L + 1; + L := R'Last; + R (F .. L) := S9; + end Str_Concat_9; + + ------------------------- + -- Str_Concat_Bounds_9 -- + ------------------------- + + procedure Str_Concat_Bounds_9 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6, S7, S8, S9 : String) + is + begin + System.Concat_8.Str_Concat_Bounds_8 + (Lo, Hi, S2, S3, S4, S5, S6, S7, S8, S9); + + if S1 /= "" then + Hi := S1'Last + Hi - Lo + 1; + Lo := S1'First; + end if; + end Str_Concat_Bounds_9; + +end System.Concat_9; diff --git a/gcc/ada/libgnat/s-conca9.ads b/gcc/ada/libgnat/s-conca9.ads new file mode 100644 index 0000000..f2f862f --- /dev/null +++ b/gcc/ada/libgnat/s-conca9.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . C O N C A T _ 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a procedure for runtime concatenation of eight string +-- operands. It is used when we want to save space in the generated code. + +pragma Compiler_Unit_Warning; + +package System.Concat_9 is + + procedure Str_Concat_9 + (R : out String; + S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); + -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8 & S9. + -- The bounds of R are known to be correct (usually set by a call to the + -- Str_Concat_Bounds_9 procedure below), so no bounds checks are required, + -- and it is known that none of the input operands overlaps R. No + -- assumptions can be made about the lower bounds of any of the operands. + + procedure Str_Concat_Bounds_9 + (Lo, Hi : out Natural; + S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); + -- Assigns to Lo..Hi the bounds of the result of concatenating the nine + -- given strings, following the rules in the RM regarding null operands. + +end System.Concat_9; diff --git a/gcc/ada/libgnat/s-crc32.adb b/gcc/ada/libgnat/s-crc32.adb new file mode 100644 index 0000000..c542855 --- /dev/null +++ b/gcc/ada/libgnat/s-crc32.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C R C 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.CRC32 is + + Init : constant CRC32 := 16#FFFF_FFFF#; -- Initial value + XorOut : constant CRC32 := 16#FFFF_FFFF#; -- To compute final result. + + -- The following table contains precomputed values for contributions + -- from various possible byte values. Doing a table lookup is quicker + -- than processing the byte bit by bit. + + Table : constant array (CRC32 range 0 .. 255) of CRC32 := + (16#0000_0000#, 16#7707_3096#, 16#EE0E_612C#, 16#9909_51BA#, + 16#076D_C419#, 16#706A_F48F#, 16#E963_A535#, 16#9E64_95A3#, + 16#0EDB_8832#, 16#79DC_B8A4#, 16#E0D5_E91E#, 16#97D2_D988#, + 16#09B6_4C2B#, 16#7EB1_7CBD#, 16#E7B8_2D07#, 16#90BF_1D91#, + 16#1DB7_1064#, 16#6AB0_20F2#, 16#F3B9_7148#, 16#84BE_41DE#, + 16#1ADA_D47D#, 16#6DDD_E4EB#, 16#F4D4_B551#, 16#83D3_85C7#, + 16#136C_9856#, 16#646B_A8C0#, 16#FD62_F97A#, 16#8A65_C9EC#, + 16#1401_5C4F#, 16#6306_6CD9#, 16#FA0F_3D63#, 16#8D08_0DF5#, + 16#3B6E_20C8#, 16#4C69_105E#, 16#D560_41E4#, 16#A267_7172#, + 16#3C03_E4D1#, 16#4B04_D447#, 16#D20D_85FD#, 16#A50A_B56B#, + 16#35B5_A8FA#, 16#42B2_986C#, 16#DBBB_C9D6#, 16#ACBC_F940#, + 16#32D8_6CE3#, 16#45DF_5C75#, 16#DCD6_0DCF#, 16#ABD1_3D59#, + 16#26D9_30AC#, 16#51DE_003A#, 16#C8D7_5180#, 16#BFD0_6116#, + 16#21B4_F4B5#, 16#56B3_C423#, 16#CFBA_9599#, 16#B8BD_A50F#, + 16#2802_B89E#, 16#5F05_8808#, 16#C60C_D9B2#, 16#B10B_E924#, + 16#2F6F_7C87#, 16#5868_4C11#, 16#C161_1DAB#, 16#B666_2D3D#, + 16#76DC_4190#, 16#01DB_7106#, 16#98D2_20BC#, 16#EFD5_102A#, + 16#71B1_8589#, 16#06B6_B51F#, 16#9FBF_E4A5#, 16#E8B8_D433#, + 16#7807_C9A2#, 16#0F00_F934#, 16#9609_A88E#, 16#E10E_9818#, + 16#7F6A_0DBB#, 16#086D_3D2D#, 16#9164_6C97#, 16#E663_5C01#, + 16#6B6B_51F4#, 16#1C6C_6162#, 16#8565_30D8#, 16#F262_004E#, + 16#6C06_95ED#, 16#1B01_A57B#, 16#8208_F4C1#, 16#F50F_C457#, + 16#65B0_D9C6#, 16#12B7_E950#, 16#8BBE_B8EA#, 16#FCB9_887C#, + 16#62DD_1DDF#, 16#15DA_2D49#, 16#8CD3_7CF3#, 16#FBD4_4C65#, + 16#4DB2_6158#, 16#3AB5_51CE#, 16#A3BC_0074#, 16#D4BB_30E2#, + 16#4ADF_A541#, 16#3DD8_95D7#, 16#A4D1_C46D#, 16#D3D6_F4FB#, + 16#4369_E96A#, 16#346E_D9FC#, 16#AD67_8846#, 16#DA60_B8D0#, + 16#4404_2D73#, 16#3303_1DE5#, 16#AA0A_4C5F#, 16#DD0D_7CC9#, + 16#5005_713C#, 16#2702_41AA#, 16#BE0B_1010#, 16#C90C_2086#, + 16#5768_B525#, 16#206F_85B3#, 16#B966_D409#, 16#CE61_E49F#, + 16#5EDE_F90E#, 16#29D9_C998#, 16#B0D0_9822#, 16#C7D7_A8B4#, + 16#59B3_3D17#, 16#2EB4_0D81#, 16#B7BD_5C3B#, 16#C0BA_6CAD#, + 16#EDB8_8320#, 16#9ABF_B3B6#, 16#03B6_E20C#, 16#74B1_D29A#, + 16#EAD5_4739#, 16#9DD2_77AF#, 16#04DB_2615#, 16#73DC_1683#, + 16#E363_0B12#, 16#9464_3B84#, 16#0D6D_6A3E#, 16#7A6A_5AA8#, + 16#E40E_CF0B#, 16#9309_FF9D#, 16#0A00_AE27#, 16#7D07_9EB1#, + 16#F00F_9344#, 16#8708_A3D2#, 16#1E01_F268#, 16#6906_C2FE#, + 16#F762_575D#, 16#8065_67CB#, 16#196C_3671#, 16#6E6B_06E7#, + 16#FED4_1B76#, 16#89D3_2BE0#, 16#10DA_7A5A#, 16#67DD_4ACC#, + 16#F9B9_DF6F#, 16#8EBE_EFF9#, 16#17B7_BE43#, 16#60B0_8ED5#, + 16#D6D6_A3E8#, 16#A1D1_937E#, 16#38D8_C2C4#, 16#4FDF_F252#, + 16#D1BB_67F1#, 16#A6BC_5767#, 16#3FB5_06DD#, 16#48B2_364B#, + 16#D80D_2BDA#, 16#AF0A_1B4C#, 16#3603_4AF6#, 16#4104_7A60#, + 16#DF60_EFC3#, 16#A867_DF55#, 16#316E_8EEF#, 16#4669_BE79#, + 16#CB61_B38C#, 16#BC66_831A#, 16#256F_D2A0#, 16#5268_E236#, + 16#CC0C_7795#, 16#BB0B_4703#, 16#2202_16B9#, 16#5505_262F#, + 16#C5BA_3BBE#, 16#B2BD_0B28#, 16#2BB4_5A92#, 16#5CB3_6A04#, + 16#C2D7_FFA7#, 16#B5D0_CF31#, 16#2CD9_9E8B#, 16#5BDE_AE1D#, + 16#9B64_C2B0#, 16#EC63_F226#, 16#756A_A39C#, 16#026D_930A#, + 16#9C09_06A9#, 16#EB0E_363F#, 16#7207_6785#, 16#0500_5713#, + 16#95BF_4A82#, 16#E2B8_7A14#, 16#7BB1_2BAE#, 16#0CB6_1B38#, + 16#92D2_8E9B#, 16#E5D5_BE0D#, 16#7CDC_EFB7#, 16#0BDB_DF21#, + 16#86D3_D2D4#, 16#F1D4_E242#, 16#68DD_B3F8#, 16#1FDA_836E#, + 16#81BE_16CD#, 16#F6B9_265B#, 16#6FB0_77E1#, 16#18B7_4777#, + 16#8808_5AE6#, 16#FF0F_6A70#, 16#6606_3BCA#, 16#1101_0B5C#, + 16#8F65_9EFF#, 16#F862_AE69#, 16#616B_FFD3#, 16#166C_CF45#, + 16#A00A_E278#, 16#D70D_D2EE#, 16#4E04_8354#, 16#3903_B3C2#, + 16#A767_2661#, 16#D060_16F7#, 16#4969_474D#, 16#3E6E_77DB#, + 16#AED1_6A4A#, 16#D9D6_5ADC#, 16#40DF_0B66#, 16#37D8_3BF0#, + 16#A9BC_AE53#, 16#DEBB_9EC5#, 16#47B2_CF7F#, 16#30B5_FFE9#, + 16#BDBD_F21C#, 16#CABA_C28A#, 16#53B3_9330#, 16#24B4_A3A6#, + 16#BAD0_3605#, 16#CDD7_0693#, 16#54DE_5729#, 16#23D9_67BF#, + 16#B366_7A2E#, 16#C461_4AB8#, 16#5D68_1B02#, 16#2A6F_2B94#, + 16#B40B_BE37#, 16#C30C_8EA1#, 16#5A05_DF1B#, 16#2D02_EF8D#); + + --------------- + -- Get_Value -- + --------------- + + function Get_Value (C : CRC32) return Interfaces.Unsigned_32 is + begin + return Interfaces.Unsigned_32 (C xor XorOut); + end Get_Value; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (C : out CRC32) is + begin + C := Init; + end Initialize; + + ------------ + -- Update -- + ------------ + + procedure Update (C : in out CRC32; Value : Character) is + V : constant CRC32 := CRC32 (Character'Pos (Value)); + begin + C := Shift_Right (C, 8) xor Table (V xor (C and 16#0000_00FF#)); + end Update; + +end System.CRC32; diff --git a/gcc/ada/libgnat/s-crc32.ads b/gcc/ada/libgnat/s-crc32.ads new file mode 100644 index 0000000..7459c9e --- /dev/null +++ b/gcc/ada/libgnat/s-crc32.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . C R C 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines for computing a commonly used checksum +-- called CRC-32. This is a checksum based on treating the binary data +-- as a polynomial over a binary field, and the exact specifications of +-- the CRC-32 algorithm are as follows: +-- +-- Name : "CRC-32" +-- Width : 32 +-- Poly : 04C11DB7 +-- Init : FFFFFFFF +-- RefIn : True +-- RefOut : True +-- XorOut : FFFFFFFF +-- Check : CBF43926 +-- +-- Note that this is the algorithm used by PKZip, Ethernet and FDDI. +-- +-- For more information about this algorithm see: +-- +-- ftp://ftp.rocksoft.com/papers/crc_v3.txt + +-- "A Painless Guide to CRC Error Detection Algorithms", Ross N. Williams +-- +-- "Computation of Cyclic Redundancy Checks via Table Look-Up", Communications +-- of the ACM, Vol. 31 No. 8, pp.1008-1013 Aug. 1988. Sarwate, D.V. + +pragma Compiler_Unit_Warning; + +with Interfaces; + +package System.CRC32 is + + type CRC32 is new Interfaces.Unsigned_32; + -- Used to represent CRC32 values, which are 32 bit bit-strings + + procedure Initialize (C : out CRC32); + pragma Inline (Initialize); + -- Initialize CRC value by assigning the standard Init value (16#FFFF_FFFF) + + procedure Update + (C : in out CRC32; + Value : Character); + pragma Inline (Update); + -- Evolve CRC by including the contribution from Character'Pos (Value) + + function Get_Value (C : CRC32) return Interfaces.Unsigned_32; + pragma Inline (Get_Value); + -- Get_Value computes the CRC32 value by performing an XOR with the + -- standard XorOut value (16#FFFF_FFFF). Note that this does not + -- change the value of C, so it may be used to retrieve intermediate + -- values of the CRC32 value during a sequence of Update calls. + +end System.CRC32; diff --git a/gcc/ada/libgnat/s-crtl.ads b/gcc/ada/libgnat/s-crtl.ads new file mode 100644 index 0000000..b5a2838 --- /dev/null +++ b/gcc/ada/libgnat/s-crtl.ads @@ -0,0 +1,241 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . C R T L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the low level interface to the C runtime library + +pragma Compiler_Unit_Warning; + +with System.Parameters; + +package System.CRTL is + pragma Preelaborate; + + subtype chars is System.Address; + -- Pointer to null-terminated array of characters + -- Should use Interfaces.C.Strings types instead, but this causes bootstrap + -- issues as i-c contains Ada 2005 specific features, not compatible with + -- older, Ada 95-only base compilers??? + + subtype DIRs is System.Address; + -- Corresponds to the C type DIR* + + subtype FILEs is System.Address; + -- Corresponds to the C type FILE* + + subtype int is Integer; + + type long is range -(2 ** (System.Parameters.long_bits - 1)) + .. +(2 ** (System.Parameters.long_bits - 1)) - 1; + + subtype off_t is Long_Integer; + + type size_t is mod 2 ** Standard'Address_Size; + + type ssize_t is range -(2 ** (Standard'Address_Size - 1)) + .. +(2 ** (Standard'Address_Size - 1)) - 1; + + type int64 is new Long_Long_Integer; + -- Note: we use Long_Long_Integer'First instead of -2 ** 63 to allow this + -- unit to compile when using custom target configuration files where the + -- maximum integer is 32 bits. This is useful for static analysis tools + -- such as SPARK or CodePeer. In the normal case, Long_Long_Integer is + -- always 64-bits so there is no difference. + + type Filename_Encoding is (UTF8, ASCII_8bits, Unspecified); + for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1, Unspecified => 2); + pragma Convention (C, Filename_Encoding); + -- Describes the filename's encoding + + -------------------- + -- GCC intrinsics -- + -------------------- + + -- The following functions are imported with convention Intrinsic so that + -- we take advantage of back-end builtins if present (else we fall back + -- to C library functions by the same names). + + function strlen (A : System.Address) return size_t; + pragma Import (Intrinsic, strlen, "strlen"); + + procedure strncpy (dest, src : System.Address; n : size_t); + pragma Import (Intrinsic, strncpy, "strncpy"); + + ------------------------------- + -- Other C runtime functions -- + ------------------------------- + + function atoi (A : System.Address) return Integer; + pragma Import (C, atoi, "atoi"); + + procedure clearerr (stream : FILEs); + pragma Import (C, clearerr, "clearerr"); + + function dup (handle : int) return int; + pragma Import (C, dup, "dup"); + + function dup2 (from, to : int) return int; + pragma Import (C, dup2, "dup2"); + + function fclose (stream : FILEs) return int; + pragma Import (C, fclose, "fclose"); + + function fdopen (handle : int; mode : chars) return FILEs; + pragma Import (C, fdopen, "fdopen"); + + function fflush (stream : FILEs) return int; + pragma Import (C, fflush, "fflush"); + + function fgetc (stream : FILEs) return int; + pragma Import (C, fgetc, "fgetc"); + + function fgets (strng : chars; n : int; stream : FILEs) return chars; + pragma Import (C, fgets, "fgets"); + + function fopen + (filename : chars; + mode : chars; + encoding : Filename_Encoding := Unspecified) return FILEs; + pragma Import (C, fopen, "__gnat_fopen"); + + function fputc (C : int; stream : FILEs) return int; + pragma Import (C, fputc, "fputc"); + + function fputwc (C : int; stream : FILEs) return int; + pragma Import (C, fputwc, "__gnat_fputwc"); + + function fputs (Strng : chars; Stream : FILEs) return int; + pragma Import (C, fputs, "fputs"); + + procedure free (Ptr : System.Address); + pragma Import (C, free, "free"); + + function freopen + (filename : chars; + mode : chars; + stream : FILEs; + encoding : Filename_Encoding := Unspecified) return FILEs; + pragma Import (C, freopen, "__gnat_freopen"); + + function fseek + (stream : FILEs; + offset : long; + origin : int) return int; + pragma Import (C, fseek, "fseek"); + + function fseek64 + (stream : FILEs; + offset : int64; + origin : int) return int; + pragma Import (C, fseek64, "__gnat_fseek64"); + + function ftell (stream : FILEs) return long; + pragma Import (C, ftell, "ftell"); + + function ftell64 (stream : FILEs) return int64; + pragma Import (C, ftell64, "__gnat_ftell64"); + + function getenv (S : String) return System.Address; + pragma Import (C, getenv, "getenv"); + + function isatty (handle : int) return int; + pragma Import (C, isatty, "isatty"); + + function lseek (fd : int; offset : off_t; direction : int) return off_t; + pragma Import (C, lseek, "lseek"); + + function malloc (Size : size_t) return System.Address; + pragma Import (C, malloc, "malloc"); + + procedure memcpy (S1 : System.Address; S2 : System.Address; N : size_t); + pragma Import (C, memcpy, "memcpy"); + + procedure memmove (S1 : System.Address; S2 : System.Address; N : size_t); + pragma Import (C, memmove, "memmove"); + + procedure mktemp (template : chars); + pragma Import (C, mktemp, "mktemp"); + + function pclose (stream : System.Address) return int; + pragma Import (C, pclose, "pclose"); + + function popen (command, mode : System.Address) return System.Address; + pragma Import (C, popen, "popen"); + + function realloc + (Ptr : System.Address; Size : size_t) return System.Address; + pragma Import (C, realloc, "realloc"); + + procedure rewind (stream : FILEs); + pragma Import (C, rewind, "rewind"); + + function rmdir (dir_name : String) return int; + pragma Import (C, rmdir, "__gnat_rmdir"); + + function chdir (dir_name : String) return int; + pragma Import (C, chdir, "__gnat_chdir"); + + function mkdir + (dir_name : String; + encoding : Filename_Encoding := Unspecified) return int; + pragma Import (C, mkdir, "__gnat_mkdir"); + + function setvbuf + (stream : FILEs; + buffer : chars; + mode : int; + size : size_t) return int; + pragma Import (C, setvbuf, "setvbuf"); + + procedure tmpnam (str : chars); + pragma Import (C, tmpnam, "tmpnam"); + + function tmpfile return FILEs; + pragma Import (C, tmpfile, "tmpfile"); + + function ungetc (c : int; stream : FILEs) return int; + pragma Import (C, ungetc, "ungetc"); + + function unlink (filename : chars) return int; + pragma Import (C, unlink, "__gnat_unlink"); + + function open (filename : chars; oflag : int) return int; + pragma Import (C, open, "__gnat_open"); + + function close (fd : int) return int; + pragma Import (C, close, "close"); + + function read (fd : int; buffer : chars; count : size_t) return ssize_t; + pragma Import (C, read, "read"); + + function write (fd : int; buffer : chars; count : size_t) return ssize_t; + pragma Import (C, write, "write"); + +end System.CRTL; diff --git a/gcc/ada/libgnat/s-diflio.adb b/gcc/ada/libgnat/s-diflio.adb new file mode 100644 index 0000000..4c8f46c --- /dev/null +++ b/gcc/ada/libgnat/s-diflio.adb @@ -0,0 +1,132 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Dim.Float_IO is + + package Num_Dim_Float_IO is new Ada.Text_IO.Float_IO (Num_Dim_Float); + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") + is + begin + Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp); + Ada.Text_IO.Put (File, Symbol); + end Put; + + procedure Put + (Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") + is + begin + Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp); + Ada.Text_IO.Put (Symbol); + end Put; + + procedure Put + (To : out String; + Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") + is + Ptr : constant Natural := Symbol'Length; + + begin + Num_Dim_Float_IO.Put (To (To'First .. To'Last - Ptr), Item, Aft, Exp); + To (To'Last - Ptr + 1 .. To'Last) := Symbol; + end Put; + + ---------------- + -- Put_Dim_Of -- + ---------------- + + pragma Warnings (Off); + -- kill warnings on unreferenced formals + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Float; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (File, Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (Item : Num_Dim_Float; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Float; + Symbol : String := "") + is + begin + To (1 .. Symbol'Length) := Symbol; + end Put_Dim_Of; + + ----------- + -- Image -- + ----------- + + function Image + (Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") return String + is + Buffer : String (1 .. 50); + + begin + Put (Buffer, Item, Aft, Exp); + for I in Buffer'Range loop + if Buffer (I) /= ' ' then + return Buffer (I .. Buffer'Last) & Symbol; + end if; + end loop; + end Image; +end System.Dim.Float_IO; diff --git a/gcc/ada/libgnat/s-diflio.ads b/gcc/ada/libgnat/s-diflio.ads new file mode 100644 index 0000000..223f5a2 --- /dev/null +++ b/gcc/ada/libgnat/s-diflio.ads @@ -0,0 +1,184 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . F L O A T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides output routines for float dimensioned types. All Put +-- routines are modeled after those in package Ada.Text_IO.Float_IO with the +-- addition of an extra default parameter. All Put_Dim_Of routines +-- output the dimension of Item in a symbolic manner. + +-- Parameter Symbol may be used in the following manner (all the examples are +-- based on the MKS system of units defined in package System.Dim.Mks): + +-- type Mks_Type is new Long_Long_Float +-- with +-- Dimension_System => ( +-- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), +-- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), +-- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), +-- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), +-- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), +-- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), +-- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); + +-- Case 1. A value is supplied for Symbol + +-- * Put : The string appears as a suffix of Item + +-- * Put_Dim_Of : The string appears alone + +-- Obj : Mks_Type := 2.6; +-- Put (Obj, 1, 1, 0, " dimensionless"); +-- Put_Dim_Of (Obj, "dimensionless"); + +-- The corresponding outputs are: +-- $2.6 dimensionless +-- $dimensionless + +-- Case 2. No value is supplied for Symbol and Item is dimensionless + +-- * Put : Item appears without a suffix + +-- * Put_Dim_Of : the output is [] + +-- Obj : Mks_Type := 2.6; +-- Put (Obj, 1, 1, 0); +-- Put_Dim_Of (Obj); + +-- The corresponding outputs are: +-- $2.6 +-- $[] + +-- Case 3. No value is supplied for Symbol and Item has a dimension + +-- * Put : If the type of Item is a dimensioned subtype whose +-- symbol is not empty, then the symbol appears as a suffix. +-- Otherwise, a new string is created and appears as a +-- suffix of Item. This string results in the successive +-- concatenations between each unit symbol raised by its +-- corresponding dimension power from the dimensions of Item. + +-- * Put_Dim_Of : The output is a new string resulting in the successive +-- concatenations between each dimension symbol raised by its +-- corresponding dimension power from the dimensions of Item. + +-- subtype Length is Mks_Type +-- with +-- Dimension => ('m', +-- Meter => 1, +-- others => 0); + +-- Obj : Length := 2.3 * dm; +-- Put (Obj, 1, 2, 0); +-- Put_Dim_Of (Obj); + +-- The corresponding outputs are: +-- $0.23 m +-- $[L] + +-- subtype Random is Mks_Type +-- with +-- Dimension => ( +-- Meter => 3, +-- Candela => -1, +-- others => 0); + +-- Obj : Random := 5.0; +-- Put (Obj); +-- Put_Dim_Of (Obj); + +-- The corresponding outputs are: +-- $5.0 m**3.cd**(-1) +-- $[l**3.J**(-1)] + +-- Put (3.3 * km * dm * min, 5, 1, 0); +-- Put_Dim_Of (3.3 * km * dm * min); + +-- The corresponding outputs are: +-- $19800.0 m**2.s +-- $[L**2.T] + +with Ada.Text_IO; use Ada.Text_IO; + +generic + type Num_Dim_Float is digits <>; + +package System.Dim.Float_IO is + + Default_Fore : Field := 2; + Default_Aft : Field := Num_Dim_Float'Digits - 1; + Default_Exp : Field := 3; + + procedure Put + (File : File_Type; + Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := ""); + + procedure Put + (Item : Num_Dim_Float; + Fore : Field := Default_Fore; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := ""); + + procedure Put + (To : out String; + Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := ""); + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Float; + Symbol : String := ""); + + procedure Put_Dim_Of + (Item : Num_Dim_Float; + Symbol : String := ""); + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Float; + Symbol : String := ""); + + pragma Inline (Put); + pragma Inline (Put_Dim_Of); + + function Image + (Item : Num_Dim_Float; + Aft : Field := Default_Aft; + Exp : Field := Default_Exp; + Symbol : String := "") return String; + +end System.Dim.Float_IO; diff --git a/gcc/ada/libgnat/s-diinio.adb b/gcc/ada/libgnat/s-diinio.adb new file mode 100644 index 0000000..2411962 --- /dev/null +++ b/gcc/ada/libgnat/s-diinio.adb @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . I N T E G E R _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Dim.Integer_IO is + + package Num_Dim_Integer_IO is new Ada.Text_IO.Integer_IO (Num_Dim_Integer); + + --------- + -- Put -- + --------- + + procedure Put + (File : File_Type; + Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := "") + + is + begin + Num_Dim_Integer_IO.Put (File, Item, Width, Base); + Ada.Text_IO.Put (File, Symbol); + end Put; + + procedure Put + (Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := "") + + is + begin + Num_Dim_Integer_IO.Put (Item, Width, Base); + Ada.Text_IO.Put (Symbol); + end Put; + + procedure Put + (To : out String; + Item : Num_Dim_Integer; + Base : Number_Base := Default_Base; + Symbol : String := "") + + is + begin + Num_Dim_Integer_IO.Put (To, Item, Base); + To := To & Symbol; + end Put; + + ---------------- + -- Put_Dim_Of -- + ---------------- + + pragma Warnings (Off); + -- kill warnings on unreferenced formals + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Integer; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (File, Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (Item : Num_Dim_Integer; + Symbol : String := "") + is + begin + Ada.Text_IO.Put (Symbol); + end Put_Dim_Of; + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Integer; + Symbol : String := "") + is + begin + To := Symbol; + end Put_Dim_Of; +end System.Dim.Integer_IO; diff --git a/gcc/ada/libgnat/s-diinio.ads b/gcc/ada/libgnat/s-diinio.ads new file mode 100644 index 0000000..babcc16 --- /dev/null +++ b/gcc/ada/libgnat/s-diinio.ads @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . I N T E G E R _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides output routines for integer dimensioned types. All +-- Put routines are modeled after those in package Ada.Text_IO.Integer_IO +-- with the addition of an extra default parameter. All Put_Dim_Of routines +-- output the dimension of Item in a symbolic manner. + +-- Parameter Symbol may be used in the following manner (all the examples are +-- based on the MKS system of units as defined in package System.Dim.Mks): + +-- type Mks_Type is new Integer +-- with +-- Dimension_System => ( +-- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), +-- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), +-- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), +-- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), +-- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), +-- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), +-- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); + +-- Case 1. A value is supplied for Symbol + +-- * Put : The string appears as a suffix of Item + +-- * Put_Dim_Of : The string appears alone + +-- Obj : Mks_Type := 2; +-- Put (Obj, Symbols => "dimensionless"); +-- Put_Dim_Of (Obj, Symbols => "dimensionless"); + +-- The corresponding outputs are: +-- $2 dimensionless +-- $dimensionless + +-- Case 2. No value is supplied for Symbol and Item is dimensionless + +-- * Put : Item appears without a suffix + +-- * Put_Dim_Of : the output is [] + +-- Obj : Mks_Type := 2; +-- Put (Obj); +-- Put_Dim_Of (Obj); + +-- The corresponding outputs are: +-- $2 +-- $[] + +-- Case 3. No value is supplied for Symbol and Item has a dimension + +-- * Put : If the type of Item is a dimensioned subtype whose +-- symbol is not empty, then the symbol appears as a suffix. +-- Otherwise, a new string is created and appears as a +-- suffix of Item. This string results in the successive +-- concatenations between each unit symbol raised by its +-- corresponding dimension power from the dimensions of Item. + +-- * Put_Dim_Of : The output is a new string resulting in the successive +-- concatenations between each dimension symbol raised by its +-- corresponding dimension power from the dimensions of Item. + +-- subtype Length is Mks_Type +-- with +-- Dimension => ('m', +-- Meter => 1, +-- others => 0); + +-- Obj : Length := 2; +-- Put (Obj); +-- Put_Dim_Of (Obj); + +-- The corresponding outputs are: +-- $2 m +-- $[L] + +-- subtype Random is Mks_Type +-- with +-- Dimension => ("", +-- Meter => 3, +-- Candela => 2, +-- others => 0); + +-- Obj : Random := 5; +-- Put (Obj); +-- Put_Dim_Of (Obj); + +-- The corresponding outputs are: +-- $5 m**3.cd**2 +-- $[L**3.J**2] + +with Ada.Text_IO; use Ada.Text_IO; + +generic + type Num_Dim_Integer is range <>; + +package System.Dim.Integer_IO is + + Default_Width : Field := Num_Dim_Integer'Width; + Default_Base : Number_Base := 10; + + procedure Put + (File : File_Type; + Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := ""); + + procedure Put + (Item : Num_Dim_Integer; + Width : Field := Default_Width; + Base : Number_Base := Default_Base; + Symbol : String := ""); + + procedure Put + (To : out String; + Item : Num_Dim_Integer; + Base : Number_Base := Default_Base; + Symbol : String := ""); + + procedure Put_Dim_Of + (File : File_Type; + Item : Num_Dim_Integer; + Symbol : String := ""); + + procedure Put_Dim_Of + (Item : Num_Dim_Integer; + Symbol : String := ""); + + procedure Put_Dim_Of + (To : out String; + Item : Num_Dim_Integer; + Symbol : String := ""); + + pragma Inline (Put); + pragma Inline (Put_Dim_Of); + +end System.Dim.Integer_IO; diff --git a/gcc/ada/libgnat/s-dim.ads b/gcc/ada/libgnat/s-dim.ads new file mode 100644 index 0000000..d914330 --- /dev/null +++ b/gcc/ada/libgnat/s-dim.ads @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2012-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Defines the dimension terminology + +--------------------------- +-- Dimension Terminology -- +--------------------------- + +-- * Dimensioned type + +-- A dimensioned type is a type (more accurately a first subtype) to which +-- the aspect Dimension_System applies to. + +-- type Mks_Type is new Long_Long_Float +-- with +-- Dimension_System => ( +-- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), +-- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), +-- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), +-- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), +-- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), +-- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), +-- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); + +-- * Dimensioned subtype + +-- A dimensioned subtype is a subtype directly defined from the dimensioned +-- type and to which the aspect Dimension applies to. + +-- subtype Length is Mks_Type +-- with +-- Dimension => (Symbol => 'm', +-- Meter => 1, +-- others => 0); + +package System.Dim is + pragma Pure; + +end System.Dim; diff --git a/gcc/ada/libgnat/s-dimkio.ads b/gcc/ada/libgnat/s-dimkio.ads new file mode 100644 index 0000000..7fd39b3 --- /dev/null +++ b/gcc/ada/libgnat/s-dimkio.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . M K S _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Provides output facilities for the MKS dimension system (see System.Dim.Mks +-- and System.Dim.Float_IO). + +with System.Dim.Mks; use System.Dim.Mks; +with System.Dim.Float_IO; + +package System.Dim.Mks_IO is new System.Dim.Float_IO (Mks_Type); diff --git a/gcc/ada/libgnat/s-dimmks.ads b/gcc/ada/libgnat/s-dimmks.ads new file mode 100644 index 0000000..fddca86 --- /dev/null +++ b/gcc/ada/libgnat/s-dimmks.ads @@ -0,0 +1,393 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . M K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Defines the MKS dimension system which is the SI system of units + +-- Some other prefixes of this system are defined in a child package (see +-- System.Dim_Mks.Other_Prefixes) in order to avoid too many constant +-- declarations in this package. + +-- The dimension terminology is defined in System.Dim_IO package + +with Ada.Numerics; + +package System.Dim.Mks is + + e : constant := Ada.Numerics.e; + Pi : constant := Ada.Numerics.Pi; + + -- Dimensioned type Mks_Type + + type Mks_Type is new Long_Long_Float + with + Dimension_System => ( + (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), + (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), + (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), + (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), + (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), + (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), + (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); + + -- SI Base dimensioned subtypes + + subtype Length is Mks_Type + with + Dimension => (Symbol => 'm', + Meter => 1, + others => 0); + + subtype Mass is Mks_Type + with + Dimension => (Symbol => "kg", + Kilogram => 1, + others => 0); + + subtype Time is Mks_Type + with + Dimension => (Symbol => 's', + Second => 1, + others => 0); + + subtype Electric_Current is Mks_Type + with + Dimension => (Symbol => 'A', + Ampere => 1, + others => 0); + + subtype Thermodynamic_Temperature is Mks_Type + with + Dimension => (Symbol => 'K', + Kelvin => 1, + others => 0); + + subtype Amount_Of_Substance is Mks_Type + with + Dimension => (Symbol => "mol", + Mole => 1, + others => 0); + + subtype Luminous_Intensity is Mks_Type + with + Dimension => (Symbol => "cd", + Candela => 1, + others => 0); + + -- Initialize SI Base unit values + + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes (we can't assign 1.0*m to m). + + pragma Warnings (Off, "*assumed to be*"); + + m : constant Length := 1.0; + kg : constant Mass := 1.0; + s : constant Time := 1.0; + A : constant Electric_Current := 1.0; + K : constant Thermodynamic_Temperature := 1.0; + mol : constant Amount_Of_Substance := 1.0; + cd : constant Luminous_Intensity := 1.0; + + pragma Warnings (On, "*assumed to be*"); + + -- SI Derived dimensioned subtypes + + subtype Absorbed_Dose is Mks_Type + with + Dimension => (Symbol => "Gy", + Meter => 2, + Second => -2, + others => 0); + + subtype Angle is Mks_Type + with + Dimension => (Symbol => "rad", + others => 0); + + subtype Area is Mks_Type + with + Dimension => ( + Meter => 2, + others => 0); + + subtype Catalytic_Activity is Mks_Type + with + Dimension => (Symbol => "kat", + Second => -1, + Mole => 1, + others => 0); + + subtype Celsius_Temperature is Mks_Type + with + Dimension => (Symbol => "°C", + Kelvin => 1, + others => 0); + + subtype Electric_Capacitance is Mks_Type + with + Dimension => (Symbol => 'F', + Meter => -2, + Kilogram => -1, + Second => 4, + Ampere => 2, + others => 0); + + subtype Electric_Charge is Mks_Type + with + Dimension => (Symbol => 'C', + Second => 1, + Ampere => 1, + others => 0); + + subtype Electric_Conductance is Mks_Type + with + Dimension => (Symbol => 'S', + Meter => -2, + Kilogram => -1, + Second => 3, + Ampere => 2, + others => 0); + + subtype Electric_Potential_Difference is Mks_Type + with + Dimension => (Symbol => 'V', + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -1, + others => 0); + + -- Note the type punning below. The Symbol is a single "ohm" character + -- encoded in UTF-8 (ce a9 in hexadecimal), but this file is not compiled + -- with -gnatW8, so we're treating the string literal as a two-character + -- String. + + subtype Electric_Resistance is Mks_Type + with + Dimension => (Symbol => "Ω", + Meter => 2, + Kilogram => 1, + Second => -3, + Ampere => -2, + others => 0); + + subtype Energy is Mks_Type + with + Dimension => (Symbol => 'J', + Meter => 2, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Equivalent_Dose is Mks_Type + with + Dimension => (Symbol => "Sv", + Meter => 2, + Second => -2, + others => 0); + + subtype Force is Mks_Type + with + Dimension => (Symbol => 'N', + Meter => 1, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Frequency is Mks_Type + with + Dimension => (Symbol => "Hz", + Second => -1, + others => 0); + + subtype Illuminance is Mks_Type + with + Dimension => (Symbol => "lx", + Meter => -2, + Candela => 1, + others => 0); + + subtype Inductance is Mks_Type + with + Dimension => (Symbol => 'H', + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -2, + others => 0); + + subtype Luminous_Flux is Mks_Type + with + Dimension => (Symbol => "lm", + Candela => 1, + others => 0); + + subtype Magnetic_Flux is Mks_Type + with + Dimension => (Symbol => "Wb", + Meter => 2, + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); + + subtype Magnetic_Flux_Density is Mks_Type + with + Dimension => (Symbol => 'T', + Kilogram => 1, + Second => -2, + Ampere => -1, + others => 0); + + subtype Power is Mks_Type + with + Dimension => (Symbol => 'W', + Meter => 2, + Kilogram => 1, + Second => -3, + others => 0); + + subtype Pressure is Mks_Type + with + Dimension => (Symbol => "Pa", + Meter => -1, + Kilogram => 1, + Second => -2, + others => 0); + + subtype Radioactivity is Mks_Type + with + Dimension => (Symbol => "Bq", + Second => -1, + others => 0); + + subtype Solid_Angle is Mks_Type + with + Dimension => (Symbol => "sr", + others => 0); + + subtype Speed is Mks_Type + with + Dimension => ( + Meter => 1, + Second => -1, + others => 0); + + subtype Volume is Mks_Type + with + Dimension => ( + Meter => 3, + others => 0); + + -- Initialize derived dimension values + + -- Turn off the all the dimension warnings for these basic assignments + -- since otherwise we would get complaints about assigning dimensionless + -- values to dimensioned subtypes. + + pragma Warnings (Off, "*assumed to be*"); + + rad : constant Angle := 1.0; + sr : constant Solid_Angle := 1.0; + Hz : constant Frequency := 1.0; + N : constant Force := 1.0; + Pa : constant Pressure := 1.0; + J : constant Energy := 1.0; + W : constant Power := 1.0; + C : constant Electric_Charge := 1.0; + V : constant Electric_Potential_Difference := 1.0; + F : constant Electric_Capacitance := 1.0; + Ohm : constant Electric_Resistance := 1.0; + Si : constant Electric_Conductance := 1.0; + Wb : constant Magnetic_Flux := 1.0; + T : constant Magnetic_Flux_Density := 1.0; + H : constant Inductance := 1.0; + dC : constant Celsius_Temperature := 273.15; + lm : constant Luminous_Flux := 1.0; + lx : constant Illuminance := 1.0; + Bq : constant Radioactivity := 1.0; + Gy : constant Absorbed_Dose := 1.0; + Sv : constant Equivalent_Dose := 1.0; + kat : constant Catalytic_Activity := 1.0; + + -- SI prefixes for Meter + + um : constant Length := 1.0E-06; -- micro (u) + mm : constant Length := 1.0E-03; -- milli + cm : constant Length := 1.0E-02; -- centi + dm : constant Length := 1.0E-01; -- deci + dam : constant Length := 1.0E+01; -- deka + hm : constant Length := 1.0E+02; -- hecto + km : constant Length := 1.0E+03; -- kilo + Mem : constant Length := 1.0E+06; -- mega + + -- SI prefixes for Kilogram + + ug : constant Mass := 1.0E-09; -- micro (u) + mg : constant Mass := 1.0E-06; -- milli + cg : constant Mass := 1.0E-05; -- centi + dg : constant Mass := 1.0E-04; -- deci + g : constant Mass := 1.0E-03; -- gram + dag : constant Mass := 1.0E-02; -- deka + hg : constant Mass := 1.0E-01; -- hecto + Meg : constant Mass := 1.0E+03; -- mega + + -- SI prefixes for Second + + us : constant Time := 1.0E-06; -- micro (u) + ms : constant Time := 1.0E-03; -- milli + cs : constant Time := 1.0E-02; -- centi + ds : constant Time := 1.0E-01; -- deci + das : constant Time := 1.0E+01; -- deka + hs : constant Time := 1.0E+02; -- hecto + ks : constant Time := 1.0E+03; -- kilo + Mes : constant Time := 1.0E+06; -- mega + + -- Other constants for Second + + min : constant Time := 60.0 * s; + hour : constant Time := 60.0 * min; + day : constant Time := 24.0 * hour; + year : constant Time := 365.25 * day; + + -- SI prefixes for Ampere + + mA : constant Electric_Current := 1.0E-03; -- milli + cA : constant Electric_Current := 1.0E-02; -- centi + dA : constant Electric_Current := 1.0E-01; -- deci + daA : constant Electric_Current := 1.0E+01; -- deka + hA : constant Electric_Current := 1.0E+02; -- hecto + kA : constant Electric_Current := 1.0E+03; -- kilo + MeA : constant Electric_Current := 1.0E+06; -- mega + + pragma Warnings (On, "*assumed to be*"); +end System.Dim.Mks; diff --git a/gcc/ada/libgnat/s-direio.adb b/gcc/ada/libgnat/s-direio.adb new file mode 100644 index 0000000..bd28526 --- /dev/null +++ b/gcc/ada/libgnat/s-direio.adb @@ -0,0 +1,399 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I R E C T _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Unchecked_Deallocation; +with Interfaces.C_Streams; use Interfaces.C_Streams; +with System; use System; +with System.CRTL; +with System.File_IO; +with System.Soft_Links; + +package body System.Direct_IO is + + package FIO renames System.File_IO; + package SSL renames System.Soft_Links; + + subtype AP is FCB.AFCB_Ptr; + use type FCB.Shared_Status_Type; + + use type System.CRTL.int64; + use type System.CRTL.size_t; + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set_Position (File : File_Type); + -- Sets file position pointer according to value of current index + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is + pragma Unreferenced (Control_Block); + begin + return new Direct_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + -- No special processing required for Direct_IO close + + procedure AFCB_Close (File : not null access Direct_AFCB) is + pragma Unreferenced (File); + begin + null; + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Direct_AFCB) is + + type FCB_Ptr is access all Direct_AFCB; + + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new + Ada.Unchecked_Deallocation (Direct_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : FCB.File_Mode := FCB.Inout_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Direct_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag is used for + -- dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'D', + Creat => True, + Text => False); + end Create; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : File_Type) return Boolean is + begin + FIO.Check_Read_Status (AP (File)); + return File.Index > Size (File); + end End_Of_File; + + ----------- + -- Index -- + ----------- + + function Index (File : File_Type) return Positive_Count is + begin + FIO.Check_File_Open (AP (File)); + return File.Index; + end Index; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : FCB.File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Direct_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag is used for + -- dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'D', + Creat => False, + Text => False); + end Open; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : File_Type; + Item : Address; + Size : Interfaces.C_Streams.size_t; + From : Positive_Count) + is + begin + Set_Index (File, From); + Read (File, Item, Size); + end Read; + + procedure Read + (File : File_Type; + Item : Address; + Size : Interfaces.C_Streams.size_t) + is + begin + FIO.Check_Read_Status (AP (File)); + + -- If last operation was not a read, or if in file sharing mode, + -- then reset the physical pointer of the file to match the index + -- We lock out task access over the two operations in this case. + + if File.Last_Op /= Op_Read + or else File.Shared_Status = FCB.Yes + then + if End_Of_File (File) then + raise End_Error; + end if; + + Locked_Processing : begin + SSL.Lock_Task.all; + Set_Position (File); + FIO.Read_Buf (AP (File), Item, Size); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + else + FIO.Read_Buf (AP (File), Item, Size); + end if; + + File.Index := File.Index + 1; + + -- Set last operation to read, unless we did not read a full record + -- (happens with the variant record case) in which case we set the + -- last operation as other, to force the file position to be reset + -- on the next read. + + File.Last_Op := (if File.Bytes = Size then Op_Read else Op_Other); + end Read; + + -- The following is the required overriding for Stream.Read, which is + -- not used, since we do not do Stream operations on Direct_IO files. + + procedure Read + (File : in out Direct_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + raise Program_Error; + end Read; + + ----------- + -- Reset -- + ----------- + + procedure Reset (File : in out File_Type; Mode : FCB.File_Mode) is + pragma Warnings (Off, File); + -- File is actually modified via Unrestricted_Access below, but + -- GNAT will generate a warning anyway. + -- + -- Note that we do not use pragma Unmodified here, since in -gnatc mode, + -- GNAT will complain that File is modified for "File.Index := 1;" + begin + FIO.Reset (AP (File)'Unrestricted_Access, Mode); + File.Index := 1; + File.Last_Op := Op_Read; + end Reset; + + procedure Reset (File : in out File_Type) is + pragma Warnings (Off, File); + -- See above (other Reset procedure) for explanations on this pragma + begin + FIO.Reset (AP (File)'Unrestricted_Access); + File.Index := 1; + File.Last_Op := Op_Read; + end Reset; + + --------------- + -- Set_Index -- + --------------- + + procedure Set_Index (File : File_Type; To : Positive_Count) is + begin + FIO.Check_File_Open (AP (File)); + File.Index := Count (To); + File.Last_Op := Op_Other; + end Set_Index; + + ------------------ + -- Set_Position -- + ------------------ + + procedure Set_Position (File : File_Type) is + R : int; + begin + R := + fseek64 + (File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET); + + if R /= 0 then + raise Use_Error; + end if; + end Set_Position; + + ---------- + -- Size -- + ---------- + + function Size (File : File_Type) return Count is + Pos : int64; + + begin + FIO.Check_File_Open (AP (File)); + File.Last_Op := Op_Other; + + if fseek64 (File.Stream, 0, SEEK_END) /= 0 then + raise Device_Error; + end if; + + Pos := ftell64 (File.Stream); + + if Pos = -1 then + raise Use_Error; + end if; + + return Count (Pos / int64 (File.Bytes)); + end Size; + + ----------- + -- Write -- + ----------- + + procedure Write + (File : File_Type; + Item : Address; + Size : Interfaces.C_Streams.size_t; + Zeroes : System.Storage_Elements.Storage_Array) + + is + procedure Do_Write; + -- Do the actual write + + -------------- + -- Do_Write -- + -------------- + + procedure Do_Write is + begin + FIO.Write_Buf (AP (File), Item, Size); + + -- If we did not write the whole record (happens with the variant + -- record case), then fill out the rest of the record with zeroes. + -- This is cleaner in any case, and is required for the last + -- record, since otherwise the length of the file is wrong. + + if File.Bytes > Size then + FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size); + end if; + end Do_Write; + + -- Start of processing for Write + + begin + FIO.Check_Write_Status (AP (File)); + + -- If last operation was not a write, or if in file sharing mode, + -- then reset the physical pointer of the file to match the index + -- We lock out task access over the two operations in this case. + + if File.Last_Op /= Op_Write + or else File.Shared_Status = FCB.Yes + then + Locked_Processing : begin + SSL.Lock_Task.all; + Set_Position (File); + Do_Write; + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + else + Do_Write; + end if; + + File.Index := File.Index + 1; + + -- Set last operation to write, unless we did not read a full record + -- (happens with the variant record case) in which case we set the + -- last operation as other, to force the file position to be reset + -- on the next write. + + File.Last_Op := (if File.Bytes = Size then Op_Write else Op_Other); + end Write; + + -- The following is the required overriding for Stream.Write, which is + -- not used, since we do not do Stream operations on Direct_IO files. + + procedure Write + (File : in out Direct_AFCB; + Item : Ada.Streams.Stream_Element_Array) + is + begin + raise Program_Error; + end Write; + +end System.Direct_IO; diff --git a/gcc/ada/libgnat/s-direio.ads b/gcc/ada/libgnat/s-direio.ads new file mode 100644 index 0000000..5bda65f --- /dev/null +++ b/gcc/ada/libgnat/s-direio.ads @@ -0,0 +1,142 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I R E C T _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the declaration of the control block used for +-- Direct_IO. This must be declared at the outer library level. It also +-- contains code that is shared between instances of Direct_IO. + +with Interfaces.C_Streams; +with Ada.Streams; +with System.File_Control_Block; +with System.Storage_Elements; + +package System.Direct_IO is + + package FCB renames System.File_Control_Block; + + type Operation is (Op_Read, Op_Write, Op_Other); + -- Type used to record last operation (to optimize sequential operations) + + subtype Count is Interfaces.C_Streams.int64; + -- The Count type in each instantiation is derived from this type + + subtype Positive_Count is Count range 1 .. Count'Last; + + type Direct_AFCB is new FCB.AFCB with record + Index : Count := 1; + -- Current Index value + + Bytes : Interfaces.C_Streams.size_t; + -- Length of item in bytes (set from inside generic template) + + Last_Op : Operation := Op_Other; + -- Last operation performed on file, used to avoid unnecessary + -- repositioning between successive read or write operations. + end record; + + function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : not null access Direct_AFCB); + procedure AFCB_Free (File : not null access Direct_AFCB); + + procedure Read + (File : in out Direct_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Required overriding of Read, not actually used for Direct_IO + + procedure Write + (File : in out Direct_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Required overriding of Write, not actually used for Direct_IO + + type File_Type is access all Direct_AFCB; + -- File_Type in individual instantiations is derived from this type + + procedure Create + (File : in out File_Type; + Mode : FCB.File_Mode := FCB.Inout_File; + Name : String := ""; + Form : String := ""); + + function End_Of_File (File : File_Type) return Boolean; + + function Index (File : File_Type) return Positive_Count; + + procedure Open + (File : in out File_Type; + Mode : FCB.File_Mode; + Name : String; + Form : String := ""); + + procedure Read + (File : File_Type; + Item : System.Address; + Size : Interfaces.C_Streams.size_t; + From : Positive_Count); + + procedure Read + (File : File_Type; + Item : System.Address; + Size : Interfaces.C_Streams.size_t); + + procedure Reset (File : in out File_Type; Mode : FCB.File_Mode); + procedure Reset (File : in out File_Type); + + procedure Set_Index (File : File_Type; To : Positive_Count); + + function Size (File : File_Type) return Count; + + procedure Write + (File : File_Type; + Item : System.Address; + Size : Interfaces.C_Streams.size_t; + Zeroes : System.Storage_Elements.Storage_Array); + -- Note: Zeroes is the buffer of zeroes used to fill out partial records + + -- The following procedures have a File_Type formal of mode IN OUT because + -- they may close the original file. The Close operation may raise an + -- exception, but in that case we want any assignment to the formal to + -- be effective anyway, so it must be passed by reference (or the caller + -- will be left with a dangling pointer). + + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type), + Mechanism => Reference); + pragma Export_Procedure + (Internal => Reset, + External => "", + Parameter_Types => (File_Type, FCB.File_Mode), + Mechanism => (File => Reference)); + +end System.Direct_IO; diff --git a/gcc/ada/libgnat/s-dmotpr.ads b/gcc/ada/libgnat/s-dmotpr.ads new file mode 100644 index 0000000..c17e55e --- /dev/null +++ b/gcc/ada/libgnat/s-dmotpr.ads @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D I M . M K S . O T H E R _ P R E F I X E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Package that defines some other prefixes for the MKS base unit system. + +-- These prefixes have been defined in a child package in order to avoid too +-- many constant declarations in System.Dim_Mks. + +package System.Dim.Mks.Other_Prefixes is + + -- SI prefixes for Meter + + pragma Warnings (Off); + -- Turn off the all the dimension warnings + + ym : constant Length := 1.0E-24; -- yocto + zm : constant Length := 1.0E-21; -- zepto + am : constant Length := 1.0E-18; -- atto + fm : constant Length := 1.0E-15; -- femto + pm : constant Length := 1.0E-12; -- pico + nm : constant Length := 1.0E-09; -- nano + Gm : constant Length := 1.0E+09; -- giga + Tm : constant Length := 1.0E+12; -- tera + Pem : constant Length := 1.0E+15; -- peta + Em : constant Length := 1.0E+18; -- exa + Zem : constant Length := 1.0E+21; -- zetta + Yom : constant Length := 1.0E+24; -- yotta + + -- SI prefixes for Kilogram + + yg : constant Mass := 1.0E-27; -- yocto + zg : constant Mass := 1.0E-24; -- zepto + ag : constant Mass := 1.0E-21; -- atto + fg : constant Mass := 1.0E-18; -- femto + pg : constant Mass := 1.0E-15; -- pico + ng : constant Mass := 1.0E-12; -- nano + Gg : constant Mass := 1.0E+06; -- giga + Tg : constant Mass := 1.0E+09; -- tera + Peg : constant Mass := 1.0E+13; -- peta + Eg : constant Mass := 1.0E+15; -- exa + Zeg : constant Mass := 1.0E+18; -- zetta + Yog : constant Mass := 1.0E+21; -- yotta + + -- SI prefixes for Second + + ys : constant Time := 1.0E-24; -- yocto + zs : constant Time := 1.0E-21; -- zepto + as : constant Time := 1.0E-18; -- atto + fs : constant Time := 1.0E-15; -- femto + ps : constant Time := 1.0E-12; -- pico + ns : constant Time := 1.0E-09; -- nano + Gs : constant Time := 1.0E+09; -- giga + Ts : constant Time := 1.0E+12; -- tera + Pes : constant Time := 1.0E+15; -- peta + Es : constant Time := 1.0E+18; -- exa + Zes : constant Time := 1.0E+21; -- zetta + Yos : constant Time := 1.0E+24; -- yotta + + -- SI prefixes for Ampere + + yA : constant Electric_Current := 1.0E-24; -- yocto + zA : constant Electric_Current := 1.0E-21; -- zepto + aA : constant Electric_Current := 1.0E-18; -- atto + fA : constant Electric_Current := 1.0E-15; -- femto + nA : constant Electric_Current := 1.0E-09; -- nano + uA : constant Electric_Current := 1.0E-06; -- micro (u) + GA : constant Electric_Current := 1.0E+09; -- giga + TA : constant Electric_Current := 1.0E+12; -- tera + PeA : constant Electric_Current := 1.0E+15; -- peta + EA : constant Electric_Current := 1.0E+18; -- exa + ZeA : constant Electric_Current := 1.0E+21; -- zetta + YoA : constant Electric_Current := 1.0E+24; -- yotta + + -- SI prefixes for Kelvin + + yK : constant Thermodynamic_Temperature := 1.0E-24; -- yocto + zK : constant Thermodynamic_Temperature := 1.0E-21; -- zepto + aK : constant Thermodynamic_Temperature := 1.0E-18; -- atto + fK : constant Thermodynamic_Temperature := 1.0E-15; -- femto + pK : constant Thermodynamic_Temperature := 1.0E-12; -- pico + nK : constant Thermodynamic_Temperature := 1.0E-09; -- nano + uK : constant Thermodynamic_Temperature := 1.0E-06; -- micro (u) + mK : constant Thermodynamic_Temperature := 1.0E-03; -- milli + cK : constant Thermodynamic_Temperature := 1.0E-02; -- centi + dK : constant Thermodynamic_Temperature := 1.0E-01; -- deci + daK : constant Thermodynamic_Temperature := 1.0E+01; -- deka + hK : constant Thermodynamic_Temperature := 1.0E+02; -- hecto + kK : constant Thermodynamic_Temperature := 1.0E+03; -- kilo + MeK : constant Thermodynamic_Temperature := 1.0E+06; -- mega + GK : constant Thermodynamic_Temperature := 1.0E+09; -- giga + TK : constant Thermodynamic_Temperature := 1.0E+12; -- tera + PeK : constant Thermodynamic_Temperature := 1.0E+15; -- peta + EK : constant Thermodynamic_Temperature := 1.0E+18; -- exa + ZeK : constant Thermodynamic_Temperature := 1.0E+21; -- zetta + YoK : constant Thermodynamic_Temperature := 1.0E+24; -- yotta + + -- SI prefixes for Mole + + ymol : constant Amount_Of_Substance := 1.0E-24; -- yocto + zmol : constant Amount_Of_Substance := 1.0E-21; -- zepto + amol : constant Amount_Of_Substance := 1.0E-18; -- atto + fmol : constant Amount_Of_Substance := 1.0E-15; -- femto + pmol : constant Amount_Of_Substance := 1.0E-12; -- pico + nmol : constant Amount_Of_Substance := 1.0E-09; -- nano + umol : constant Amount_Of_Substance := 1.0E-06; -- micro (u) + mmol : constant Amount_Of_Substance := 1.0E-03; -- milli + cmol : constant Amount_Of_Substance := 1.0E-02; -- centi + dmol : constant Amount_Of_Substance := 1.0E-01; -- deci + damol : constant Amount_Of_Substance := 1.0E+01; -- deka + hmol : constant Amount_Of_Substance := 1.0E+02; -- hecto + kmol : constant Amount_Of_Substance := 1.0E+03; -- kilo + Memol : constant Amount_Of_Substance := 1.0E+06; -- mega + Gmol : constant Amount_Of_Substance := 1.0E+09; -- giga + Tmol : constant Amount_Of_Substance := 1.0E+12; -- tera + Pemol : constant Amount_Of_Substance := 1.0E+15; -- peta + Emol : constant Amount_Of_Substance := 1.0E+18; -- exa + Zemol : constant Amount_Of_Substance := 1.0E+21; -- zetta + Yomol : constant Amount_Of_Substance := 1.0E+24; -- yotta + + -- SI prefixes for Candela + + ycd : constant Luminous_Intensity := 1.0E-24; -- yocto + zcd : constant Luminous_Intensity := 1.0E-21; -- zepto + acd : constant Luminous_Intensity := 1.0E-18; -- atto + fcd : constant Luminous_Intensity := 1.0E-15; -- femto + pcd : constant Luminous_Intensity := 1.0E-12; -- pico + ncd : constant Luminous_Intensity := 1.0E-09; -- nano + ucd : constant Luminous_Intensity := 1.0E-06; -- micro (u) + mcd : constant Luminous_Intensity := 1.0E-03; -- milli + ccd : constant Luminous_Intensity := 1.0E-02; -- centi + dcd : constant Luminous_Intensity := 1.0E-01; -- deci + dacd : constant Luminous_Intensity := 1.0E+01; -- deka + hcd : constant Luminous_Intensity := 1.0E+02; -- hecto + kcd : constant Luminous_Intensity := 1.0E+03; -- kilo + Mecd : constant Luminous_Intensity := 1.0E+06; -- mega + Gcd : constant Luminous_Intensity := 1.0E+09; -- giga + Tcd : constant Luminous_Intensity := 1.0E+12; -- tera + Pecd : constant Luminous_Intensity := 1.0E+15; -- peta + Ecd : constant Luminous_Intensity := 1.0E+18; -- exa + Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta + Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta + + pragma Warnings (On); +end System.Dim.Mks.Other_Prefixes; diff --git a/gcc/ada/libgnat/s-dsaser.ads b/gcc/ada/libgnat/s-dsaser.ads new file mode 100644 index 0000000..5191e24 --- /dev/null +++ b/gcc/ada/libgnat/s-dsaser.ads @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . D S A _ S E R V I C E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is for distributed system annex services, which require the +-- partition communication sub-system to be initialized before they are used. + +with System.Partition_Interface; +with System.RPC; + +package System.DSA_Services is + + function Get_Active_Partition_ID + (Name : Partition_Interface.Unit_Name) return RPC.Partition_ID + renames Partition_Interface.Get_Active_Partition_ID; + -- Return the partition ID of the partition in which unit Name resides + + function Get_Local_Partition_ID return RPC.Partition_ID + renames Partition_Interface.Get_Local_Partition_ID; + -- Return the Partition_ID of the current partition + + function Get_Passive_Partition_ID + (Name : Partition_Interface.Unit_Name) return RPC.Partition_ID + renames Partition_Interface.Get_Passive_Partition_ID; + -- Return the Partition_ID of the given shared passive partition + +end System.DSA_Services; diff --git a/gcc/ada/libgnat/s-dwalin.adb b/gcc/ada/libgnat/s-dwalin.adb new file mode 100644 index 0000000..1791b2d --- /dev/null +++ b/gcc/ada/libgnat/s-dwalin.adb @@ -0,0 +1,1627 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . D W A R F _ L I N E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on + +with Ada.Characters.Handling; +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with Ada.Unchecked_Deallocation; +with Ada.Containers.Generic_Array_Sort; + +with Interfaces; use Interfaces; + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; +with System.Address_Image; +with System.IO; use System.IO; +with System.Object_Reader; use System.Object_Reader; +with System.Traceback_Entries; use System.Traceback_Entries; +with System.Mmap; use System.Mmap; +with System.Bounded_Strings; use System.Bounded_Strings; + +package body System.Dwarf_Lines is + + SSU : constant := System.Storage_Unit; + + function String_Length (Str : Str_Access) return Natural; + -- Return the length of the C string Str + + --------------------------------- + -- DWARF Parser Implementation -- + --------------------------------- + + procedure Read_Initial_Length + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : out Boolean); + -- Read initial length as specified by Dwarf-4 7.2.2 + + procedure Read_Section_Offset + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : Boolean); + -- Read a section offset, as specified by Dwarf-4 7.4 + + procedure Read_Aranges_Entry + (C : in out Dwarf_Context; + Start : out Integer_Address; + Len : out Storage_Count); + -- Read a single .debug_aranges pair + + procedure Read_Aranges_Header + (C : in out Dwarf_Context; + Info_Offset : out Offset; + Success : out Boolean); + -- Read .debug_aranges header + + procedure Aranges_Lookup + (C : in out Dwarf_Context; + Addr : Address; + Info_Offset : out Offset; + Success : out Boolean); + -- Search for Addr in .debug_aranges and return offset Info_Offset in + -- .debug_info. + + procedure Skip_Form + (S : in out Mapped_Stream; + Form : uint32; + Is64 : Boolean; + Ptr_Sz : uint8); + -- Advance offset in S for Form. + + procedure Seek_Abbrev + (C : in out Dwarf_Context; + Abbrev_Offset : Offset; + Abbrev_Num : uint32); + -- Seek to abbrev Abbrev_Num (starting from Abbrev_Offset) + + procedure Debug_Info_Lookup + (C : in out Dwarf_Context; + Info_Offset : Offset; + Line_Offset : out Offset; + Success : out Boolean); + -- Search for stmt_list tag in Info_Offset and set Line_Offset to the + -- offset in .debug_lines. Only look at the first DIE, which should be + -- a compilation unit. + + procedure Initialize_Pass (C : in out Dwarf_Context); + -- Seek to the first byte of the first prologue and prepare to make a pass + -- over the line number entries. + + procedure Initialize_State_Machine (C : in out Dwarf_Context); + -- Set all state machine registers to their specified initial values + + procedure Parse_Prologue (C : in out Dwarf_Context); + -- Decode a DWARF statement program prologue + + procedure Read_And_Execute_Isn + (C : in out Dwarf_Context; + Done : out Boolean); + -- Read an execute a statement program instruction + + function To_File_Name + (C : in out Dwarf_Context; + Code : uint32) return String; + -- Extract a file name from the prologue + + type Callback is access procedure (C : in out Dwarf_Context); + procedure For_Each_Row (C : in out Dwarf_Context; F : Callback); + -- Traverse each .debug_line entry with a callback + + procedure Dump_Row (C : in out Dwarf_Context); + -- Dump a single row + + function "<" (Left, Right : Search_Entry) return Boolean; + -- For sorting Search_Entry + + procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort + (Index_Type => Natural, + Element_Type => Search_Entry, + Array_Type => Search_Array); + + procedure Symbolic_Address + (C : in out Dwarf_Context; + Addr : Address; + Dir_Name : out Str_Access; + File_Name : out Str_Access; + Subprg_Name : out String_Ptr_Len; + Line_Num : out Natural); + -- Symbolize one address + + ----------------------- + -- DWARF constants -- + ----------------------- + + -- 6.2.5.2 Standard Opcodes + + DW_LNS_copy : constant := 1; + DW_LNS_advance_pc : constant := 2; + DW_LNS_advance_line : constant := 3; + DW_LNS_set_file : constant := 4; + DW_LNS_set_column : constant := 5; + DW_LNS_negate_stmt : constant := 6; + DW_LNS_set_basic_block : constant := 7; + DW_LNS_const_add_pc : constant := 8; + DW_LNS_fixed_advance_pc : constant := 9; + DW_LNS_set_prologue_end : constant := 10; + DW_LNS_set_epilogue_begin : constant := 11; + DW_LNS_set_isa : constant := 12; + + -- 6.2.5.3 Extended Opcodes + + DW_LNE_end_sequence : constant := 1; + DW_LNE_set_address : constant := 2; + DW_LNE_define_file : constant := 3; + + -- From the DWARF version 4 public review draft + + DW_LNE_set_discriminator : constant := 4; + + -- Attribute encodings + + DW_TAG_Compile_Unit : constant := 16#11#; + + DW_AT_Stmt_List : constant := 16#10#; + + DW_FORM_addr : constant := 16#01#; + DW_FORM_block2 : constant := 16#03#; + DW_FORM_block4 : constant := 16#04#; + DW_FORM_data2 : constant := 16#05#; + DW_FORM_data4 : constant := 16#06#; + DW_FORM_data8 : constant := 16#07#; + DW_FORM_string : constant := 16#08#; + DW_FORM_block : constant := 16#09#; + DW_FORM_block1 : constant := 16#0a#; + DW_FORM_data1 : constant := 16#0b#; + DW_FORM_flag : constant := 16#0c#; + DW_FORM_sdata : constant := 16#0d#; + DW_FORM_strp : constant := 16#0e#; + DW_FORM_udata : constant := 16#0f#; + DW_FORM_ref_addr : constant := 16#10#; + DW_FORM_ref1 : constant := 16#11#; + DW_FORM_ref2 : constant := 16#12#; + DW_FORM_ref4 : constant := 16#13#; + DW_FORM_ref8 : constant := 16#14#; + DW_FORM_ref_udata : constant := 16#15#; + DW_FORM_indirect : constant := 16#16#; + DW_FORM_sec_offset : constant := 16#17#; + DW_FORM_exprloc : constant := 16#18#; + DW_FORM_flag_present : constant := 16#19#; + DW_FORM_ref_sig8 : constant := 16#20#; + + --------- + -- "<" -- + --------- + + function "<" (Left, Right : Search_Entry) return Boolean is + begin + return Left.First < Right.First; + end "<"; + + ----------- + -- Close -- + ----------- + + procedure Close (C : in out Dwarf_Context) is + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Object_File, + Object_File_Access); + procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation + (Search_Array, + Search_Array_Access); + begin + if C.Has_Debug then + Close (C.Lines); + Close (C.Abbrev); + Close (C.Info); + Close (C.Aranges); + end if; + + Close (C.Obj.all); + Unchecked_Deallocation (C.Obj); + + Unchecked_Deallocation (C.Cache); + end Close; + + ---------- + -- Dump -- + ---------- + + procedure Dump (C : in out Dwarf_Context) is + begin + For_Each_Row (C, Dump_Row'Access); + end Dump; + + -------------- + -- Dump_Row -- + -------------- + + procedure Dump_Row (C : in out Dwarf_Context) is + PC : constant Integer_Address := Integer_Address (C.Registers.Address); + Off : Offset; + begin + Tell (C.Lines, Off); + + Put (System.Address_Image (To_Address (PC))); + Put (" "); + Put (To_File_Name (C, C.Registers.File)); + Put (":"); + + declare + Image : constant String := uint32'Image (C.Registers.Line); + begin + Put_Line (Image (2 .. Image'Last)); + end; + + Seek (C.Lines, Off); + end Dump_Row; + + procedure Dump_Cache (C : Dwarf_Context) is + Cache : constant Search_Array_Access := C.Cache; + S : Object_Symbol; + Name : String_Ptr_Len; + begin + if Cache = null then + Put_Line ("No cache"); + return; + end if; + for I in Cache'Range loop + Put (System.Address_Image (C.Low + Storage_Count (Cache (I).First))); + Put (" - "); + Put + (System.Address_Image + (C.Low + Storage_Count (Cache (I).First + Cache (I).Size))); + Put (" l@"); + Put + (System.Address_Image + (To_Address (Integer_Address (Cache (I).Line)))); + Put (": "); + S := Read_Symbol (C.Obj.all, Offset (Cache (I).Sym)); + Name := Object_Reader.Name (C.Obj.all, S); + Put (String (Name.Ptr (1 .. Name.Len))); + New_Line; + end loop; + end Dump_Cache; + + ------------------ + -- For_Each_Row -- + ------------------ + + procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is + Done : Boolean; + + begin + Initialize_Pass (C); + + loop + Read_And_Execute_Isn (C, Done); + + if C.Registers.Is_Row then + F.all (C); + end if; + + exit when Done; + end loop; + end For_Each_Row; + + --------------------- + -- Initialize_Pass -- + --------------------- + + procedure Initialize_Pass (C : in out Dwarf_Context) is + begin + Seek (C.Lines, 0); + C.Next_Prologue := 0; + + Initialize_State_Machine (C); + end Initialize_Pass; + + ------------------------------ + -- Initialize_State_Machine -- + ------------------------------ + + procedure Initialize_State_Machine (C : in out Dwarf_Context) is + begin + C.Registers := + (Address => 0, + File => 1, + Line => 1, + Column => 0, + Is_Stmt => C.Prologue.Default_Is_Stmt = 0, + Basic_Block => False, + End_Sequence => False, + Prologue_End => False, + Epilogue_Begin => False, + ISA => 0, + Is_Row => False); + end Initialize_State_Machine; + + --------------- + -- Is_Inside -- + --------------- + + function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is + begin + return Addr >= C.Low and Addr <= C.High; + end Is_Inside; + + --------- + -- Low -- + --------- + + function Low (C : Dwarf_Context) return Address is + begin + return C.Low; + end Low; + + ---------- + -- Open -- + ---------- + + procedure Open + (File_Name : String; + C : out Dwarf_Context; + Success : out Boolean) + is + Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section; + Hi, Lo : uint64; + begin + -- Not a success by default + + Success := False; + + -- Open file + + C.Obj := Open (File_Name, C.In_Exception); + + if C.Obj = null then + return; + end if; + + Success := True; + + -- Get memory bounds + + Get_Memory_Bounds (C.Obj.all, Lo, Hi); + C.Low := Address (Lo); + C.High := Address (Hi); + + -- Create a stream for debug sections + + if Format (C.Obj.all) = XCOFF32 then + Line_Sec := Get_Section (C.Obj.all, ".dwline"); + Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev"); + Info_Sec := Get_Section (C.Obj.all, ".dwinfo"); + Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge"); + else + Line_Sec := Get_Section (C.Obj.all, ".debug_line"); + Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev"); + Info_Sec := Get_Section (C.Obj.all, ".debug_info"); + Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges"); + end if; + + if Line_Sec = Null_Section + or else Abbrev_Sec = Null_Section + or else Info_Sec = Null_Section + or else Aranges_Sec = Null_Section + then + C.Has_Debug := False; + return; + end if; + + C.Lines := Create_Stream (C.Obj.all, Line_Sec); + C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec); + C.Info := Create_Stream (C.Obj.all, Info_Sec); + C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec); + + -- All operations are successful, context is valid + + C.Has_Debug := True; + end Open; + + -------------------- + -- Parse_Prologue -- + -------------------- + + procedure Parse_Prologue (C : in out Dwarf_Context) is + Char : uint8; + Prev : uint8; + -- The most recently read character and the one preceding it + + Dummy : uint32; + -- Destination for reads we don't care about + + Buf : Buffer; + Off : Offset; + + First_Byte_Of_Prologue : Offset; + Last_Byte_Of_Prologue : Offset; + + Max_Op_Per_Insn : uint8; + pragma Unreferenced (Max_Op_Per_Insn); + + Prologue : Line_Info_Prologue renames C.Prologue; + + begin + Tell (C.Lines, First_Byte_Of_Prologue); + Prologue.Unit_Length := Read (C.Lines); + Tell (C.Lines, Off); + C.Next_Prologue := Off + Offset (Prologue.Unit_Length); + + Prologue.Version := Read (C.Lines); + Prologue.Prologue_Length := Read (C.Lines); + Tell (C.Lines, Last_Byte_Of_Prologue); + Last_Byte_Of_Prologue := + Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1; + + Prologue.Min_Isn_Length := Read (C.Lines); + + if Prologue.Version >= 4 then + Max_Op_Per_Insn := Read (C.Lines); + end if; + + Prologue.Default_Is_Stmt := Read (C.Lines); + Prologue.Line_Base := Read (C.Lines); + Prologue.Line_Range := Read (C.Lines); + Prologue.Opcode_Base := Read (C.Lines); + + -- Opcode_Lengths is an array of Opcode_Base bytes specifying the number + -- of LEB128 operands for each of the standard opcodes. + + for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop + Prologue.Opcode_Lengths (J) := Read (C.Lines); + end loop; + + -- The include directories table follows. This is a list of null + -- terminated strings terminated by a double null. We only store + -- its offset for later decoding. + + Tell (C.Lines, Prologue.Includes_Offset); + Char := Read (C.Lines); + + if Char /= 0 then + loop + Prev := Char; + Char := Read (C.Lines); + exit when Char = 0 and Prev = 0; + end loop; + end if; + + -- The file_names table is next. Each record is a null terminated string + -- for the file name, an unsigned LEB128 directory index, an unsigned + -- LEB128 modification time, and an LEB128 file length. The table is + -- terminated by a null byte. + + Tell (C.Lines, Prologue.File_Names_Offset); + + loop + -- Read the filename + + Read_C_String (C.Lines, Buf); + exit when Buf (0) = 0; + Dummy := Read_LEB128 (C.Lines); -- Skip the directory index. + Dummy := Read_LEB128 (C.Lines); -- Skip the modification time. + Dummy := Read_LEB128 (C.Lines); -- Skip the file length. + end loop; + + -- Check we're where we think we are. This sanity check ensures we think + -- the prologue ends where the prologue says it does. It we aren't then + -- we've probably gotten out of sync somewhere. + + Tell (C.Lines, Off); + + if Prologue.Unit_Length /= 0 + and then Off /= Last_Byte_Of_Prologue + 1 + then + raise Dwarf_Error with "Parse error reading DWARF information"; + end if; + end Parse_Prologue; + + -------------------------- + -- Read_And_Execute_Isn -- + -------------------------- + + procedure Read_And_Execute_Isn + (C : in out Dwarf_Context; + Done : out Boolean) + is + Opcode : uint8; + Extended_Opcode : uint8; + uint32_Operand : uint32; + int32_Operand : int32; + uint16_Operand : uint16; + Off : Offset; + + Extended_Length : uint32; + pragma Unreferenced (Extended_Length); + + Obj : Object_File renames C.Obj.all; + Registers : Line_Info_Registers renames C.Registers; + Prologue : Line_Info_Prologue renames C.Prologue; + + begin + Done := False; + Registers.Is_Row := False; + + if Registers.End_Sequence then + Initialize_State_Machine (C); + end if; + + -- Read the next prologue + + Tell (C.Lines, Off); + while Off = C.Next_Prologue loop + Initialize_State_Machine (C); + Parse_Prologue (C); + Tell (C.Lines, Off); + exit when Off + 4 >= Length (C.Lines); + end loop; + + -- Test whether we're done + + Tell (C.Lines, Off); + + -- We are finished when we either reach the end of the section, or we + -- have reached zero padding at the end of the section. + + if Prologue.Unit_Length = 0 or else Off + 4 >= Length (C.Lines) then + Done := True; + return; + end if; + + -- Read and interpret an instruction + + Opcode := Read (C.Lines); + + -- Extended opcodes + + if Opcode = 0 then + Extended_Length := Read_LEB128 (C.Lines); + Extended_Opcode := Read (C.Lines); + + case Extended_Opcode is + when DW_LNE_end_sequence => + + -- Mark the end of a sequence of source locations + + Registers.End_Sequence := True; + Registers.Is_Row := True; + + when DW_LNE_set_address => + + -- Set the program counter to a word + + Registers.Address := Read_Address (Obj, C.Lines); + + when DW_LNE_define_file => + + -- Not implemented + + raise Dwarf_Error with "DWARF operator not implemented"; + + when DW_LNE_set_discriminator => + + -- Ignored + + int32_Operand := Read_LEB128 (C.Lines); + + when others => + + -- Fail on an unrecognized opcode + + raise Dwarf_Error with "DWARF operator not implemented"; + end case; + + -- Standard opcodes + + elsif Opcode < Prologue.Opcode_Base then + case Opcode is + + -- Append a row to the line info matrix + + when DW_LNS_copy => + Registers.Basic_Block := False; + Registers.Is_Row := True; + + -- Add an unsigned word to the program counter + + when DW_LNS_advance_pc => + uint32_Operand := Read_LEB128 (C.Lines); + Registers.Address := + Registers.Address + + uint64 (uint32_Operand * uint32 (Prologue.Min_Isn_Length)); + + -- Add a signed word to the current source line + + when DW_LNS_advance_line => + int32_Operand := Read_LEB128 (C.Lines); + Registers.Line := + uint32 (int32 (Registers.Line) + int32_Operand); + + -- Set the current source file + + when DW_LNS_set_file => + uint32_Operand := Read_LEB128 (C.Lines); + Registers.File := uint32_Operand; + + -- Set the current source column + + when DW_LNS_set_column => + uint32_Operand := Read_LEB128 (C.Lines); + Registers.Column := uint32_Operand; + + -- Toggle the "is statement" flag. GCC doesn't seem to set this??? + + when DW_LNS_negate_stmt => + Registers.Is_Stmt := not Registers.Is_Stmt; + + -- Mark the beginning of a basic block + + when DW_LNS_set_basic_block => + Registers.Basic_Block := True; + + -- Advance the program counter as by the special opcode 255 + + when DW_LNS_const_add_pc => + Registers.Address := + Registers.Address + + uint64 + (((255 - Prologue.Opcode_Base) / Prologue.Line_Range) * + Prologue.Min_Isn_Length); + + -- Advance the program counter by a constant + + when DW_LNS_fixed_advance_pc => + uint16_Operand := Read (C.Lines); + Registers.Address := + Registers.Address + uint64 (uint16_Operand); + + -- The following are not implemented and ignored + + when DW_LNS_set_prologue_end => + null; + + when DW_LNS_set_epilogue_begin => + null; + + when DW_LNS_set_isa => + null; + + -- Anything else is an error + + when others => + raise Dwarf_Error with "DWARF operator not implemented"; + end case; + + -- Decode a special opcode. This is a line and address increment encoded + -- in a single byte 'special opcode' as described in 6.2.5.1. + + else + declare + Address_Increment : int32; + Line_Increment : int32; + + begin + Opcode := Opcode - Prologue.Opcode_Base; + + -- The adjusted opcode is a uint8 encoding an address increment + -- and a signed line increment. The upperbound is allowed to be + -- greater than int8'last so we decode using int32 directly to + -- prevent overflows. + + Address_Increment := + int32 (Opcode / Prologue.Line_Range) * + int32 (Prologue.Min_Isn_Length); + Line_Increment := + int32 (Prologue.Line_Base) + + int32 (Opcode mod Prologue.Line_Range); + + Registers.Address := + Registers.Address + uint64 (Address_Increment); + Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment); + Registers.Basic_Block := False; + Registers.Prologue_End := False; + Registers.Epilogue_Begin := False; + Registers.Is_Row := True; + end; + end if; + + exception + when Dwarf_Error => + + -- In case of errors during parse, just stop reading + + Registers.Is_Row := False; + Done := True; + end Read_And_Execute_Isn; + + ---------------------- + -- Set_Load_Address -- + ---------------------- + + procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is + begin + if Addr = Null_Address then + return; + else + C.Load_Slide := + To_Integer (Addr) - Integer_Address (Get_Load_Address (C.Obj.all)); + + C.Low := To_Address (To_Integer (C.Low) + C.Load_Slide); + C.High := To_Address (To_Integer (C.High) + C.Load_Slide); + end if; + end Set_Load_Address; + + ------------------ + -- To_File_Name -- + ------------------ + + function To_File_Name + (C : in out Dwarf_Context; + Code : uint32) return String + is + Buf : Buffer; + J : uint32; + + Dir_Idx : uint32; + pragma Unreferenced (Dir_Idx); + + Mod_Time : uint32; + pragma Unreferenced (Mod_Time); + + Length : uint32; + pragma Unreferenced (Length); + + begin + Seek (C.Lines, C.Prologue.File_Names_Offset); + + -- Find the entry + + J := 0; + loop + J := J + 1; + Read_C_String (C.Lines, Buf); + + if Buf (Buf'First) = 0 then + return "???"; + end if; + + Dir_Idx := Read_LEB128 (C.Lines); + Mod_Time := Read_LEB128 (C.Lines); + Length := Read_LEB128 (C.Lines); + exit when J = Code; + end loop; + + return To_String (Buf); + end To_File_Name; + + ------------------------- + -- Read_Initial_Length -- + ------------------------- + + procedure Read_Initial_Length + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : out Boolean) + is + Len32 : uint32; + Len64 : uint64; + begin + Len32 := Read (S); + if Len32 < 16#ffff_fff0# then + Is64 := False; + Len := Offset (Len32); + elsif Len32 < 16#ffff_ffff# then + -- Invalid length + raise Constraint_Error; + else + Is64 := True; + Len64 := Read (S); + Len := Offset (Len64); + end if; + end Read_Initial_Length; + + ------------------------- + -- Read_Section_Offset -- + ------------------------- + + procedure Read_Section_Offset + (S : in out Mapped_Stream; + Len : out Offset; + Is64 : Boolean) + is + begin + if Is64 then + Len := Offset (uint64'(Read (S))); + else + Len := Offset (uint32'(Read (S))); + end if; + end Read_Section_Offset; + + -------------------- + -- Aranges_Lookup -- + -------------------- + + procedure Aranges_Lookup + (C : in out Dwarf_Context; + Addr : Address; + Info_Offset : out Offset; + Success : out Boolean) + is + begin + Seek (C.Aranges, 0); + + while Tell (C.Aranges) < Length (C.Aranges) loop + Read_Aranges_Header (C, Info_Offset, Success); + exit when not Success; + + loop + declare + Start : Integer_Address; + Len : Storage_Count; + begin + Read_Aranges_Entry (C, Start, Len); + exit when Start = 0 and Len = 0; + if Addr >= To_Address (Start) + and then Addr < To_Address (Start) + Len + then + Success := True; + return; + end if; + end; + end loop; + end loop; + Success := False; + end Aranges_Lookup; + + --------------- + -- Skip_Form -- + --------------- + + procedure Skip_Form + (S : in out Mapped_Stream; + Form : uint32; + Is64 : Boolean; + Ptr_Sz : uint8) + is + Skip : Offset; + begin + case Form is + when DW_FORM_addr => + Skip := Offset (Ptr_Sz); + when DW_FORM_block2 => + Skip := Offset (uint16'(Read (S))); + when DW_FORM_block4 => + Skip := Offset (uint32'(Read (S))); + when DW_FORM_data2 | DW_FORM_ref2 => + Skip := 2; + when DW_FORM_data4 | DW_FORM_ref4 => + Skip := 4; + when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 => + Skip := 8; + when DW_FORM_string => + while uint8'(Read (S)) /= 0 loop + null; + end loop; + return; + when DW_FORM_block | DW_FORM_exprloc => + Skip := Offset (uint32'(Read_LEB128 (S))); + when DW_FORM_block1 | DW_FORM_ref1 => + Skip := Offset (uint8'(Read (S))); + when DW_FORM_data1 | DW_FORM_flag => + Skip := 1; + when DW_FORM_sdata => + declare + Val : constant int32 := Read_LEB128 (S); + pragma Unreferenced (Val); + begin + return; + end; + when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset => + Skip := (if Is64 then 8 else 4); + when DW_FORM_udata | DW_FORM_ref_udata => + declare + Val : constant uint32 := Read_LEB128 (S); + pragma Unreferenced (Val); + begin + return; + end; + when DW_FORM_flag_present => + return; + when DW_FORM_indirect => + raise Constraint_Error; + when others => + raise Constraint_Error; + end case; + Seek (S, Tell (S) + Skip); + end Skip_Form; + + ----------------- + -- Seek_Abbrev -- + ----------------- + + procedure Seek_Abbrev + (C : in out Dwarf_Context; + Abbrev_Offset : Offset; + Abbrev_Num : uint32) + is + Num : uint32; + Abbrev : uint32; + Tag : uint32; + Has_Child : uint8; + pragma Unreferenced (Abbrev, Tag, Has_Child); + begin + Seek (C.Abbrev, Abbrev_Offset); + + Num := 1; + + loop + exit when Num = Abbrev_Num; + + Abbrev := Read_LEB128 (C.Abbrev); + Tag := Read_LEB128 (C.Abbrev); + Has_Child := Read (C.Abbrev); + + loop + declare + Name : constant uint32 := Read_LEB128 (C.Abbrev); + Form : constant uint32 := Read_LEB128 (C.Abbrev); + begin + exit when Name = 0 and Form = 0; + end; + end loop; + + Num := Num + 1; + end loop; + end Seek_Abbrev; + + ----------------------- + -- Debug_Info_Lookup -- + ----------------------- + + procedure Debug_Info_Lookup + (C : in out Dwarf_Context; + Info_Offset : Offset; + Line_Offset : out Offset; + Success : out Boolean) + is + Unit_Length : Offset; + Is64 : Boolean; + Version : uint16; + Abbrev_Offset : Offset; + Addr_Sz : uint8; + Abbrev : uint32; + Has_Child : uint8; + pragma Unreferenced (Has_Child); + begin + Success := False; + + Seek (C.Info, Info_Offset); + + Read_Initial_Length (C.Info, Unit_Length, Is64); + + Version := Read (C.Info); + if Version not in 2 .. 4 then + return; + end if; + + Read_Section_Offset (C.Info, Abbrev_Offset, Is64); + + Addr_Sz := Read (C.Info); + if Addr_Sz /= (Address'Size / SSU) then + return; + end if; + + -- Read DIEs + + loop + Abbrev := Read_LEB128 (C.Info); + exit when Abbrev /= 0; + end loop; + + -- Read abbrev table + + Seek_Abbrev (C, Abbrev_Offset, Abbrev); + + -- First ULEB128 is the abbrev code + + if Read_LEB128 (C.Abbrev) /= Abbrev then + -- Ill formed abbrev table + return; + end if; + + -- Then the tag + + if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then + -- Expect compile unit + return; + end if; + + -- Then the has child flag + + Has_Child := Read (C.Abbrev); + + loop + declare + Name : constant uint32 := Read_LEB128 (C.Abbrev); + Form : constant uint32 := Read_LEB128 (C.Abbrev); + begin + exit when Name = 0 and Form = 0; + if Name = DW_AT_Stmt_List then + case Form is + when DW_FORM_sec_offset => + Read_Section_Offset (C.Info, Line_Offset, Is64); + when DW_FORM_data4 => + Line_Offset := Offset (uint32'(Read (C.Info))); + when DW_FORM_data8 => + Line_Offset := Offset (uint64'(Read (C.Info))); + when others => + -- Unhandled form + return; + end case; + + Success := True; + return; + else + Skip_Form (C.Info, Form, Is64, Addr_Sz); + end if; + end; + end loop; + + return; + end Debug_Info_Lookup; + + ------------------------- + -- Read_Aranges_Header -- + ------------------------- + + procedure Read_Aranges_Header + (C : in out Dwarf_Context; + Info_Offset : out Offset; + Success : out Boolean) + is + Unit_Length : Offset; + Is64 : Boolean; + Version : uint16; + Sz : uint8; + begin + Success := False; + + Read_Initial_Length (C.Aranges, Unit_Length, Is64); + + Version := Read (C.Aranges); + if Version /= 2 then + return; + end if; + + Read_Section_Offset (C.Aranges, Info_Offset, Is64); + + -- Read address_size (ubyte) + + Sz := Read (C.Aranges); + if Sz /= (Address'Size / SSU) then + return; + end if; + + -- Read segment_size (ubyte) + + Sz := Read (C.Aranges); + if Sz /= 0 then + return; + end if; + + -- Handle alignment on twice the address size + declare + Cur_Off : constant Offset := Tell (C.Aranges); + Align : constant Offset := 2 * Address'Size / SSU; + Space : constant Offset := Cur_Off mod Align; + begin + if Space /= 0 then + Seek (C.Aranges, Cur_Off + Align - Space); + end if; + end; + + Success := True; + end Read_Aranges_Header; + + ------------------------ + -- Read_Aranges_Entry -- + ------------------------ + + procedure Read_Aranges_Entry + (C : in out Dwarf_Context; + Start : out Integer_Address; + Len : out Storage_Count) + is + begin + -- Read table + if Address'Size = 32 then + declare + S, L : uint32; + begin + S := Read (C.Aranges); + L := Read (C.Aranges); + Start := Integer_Address (S); + Len := Storage_Count (L); + end; + elsif Address'Size = 64 then + declare + S, L : uint64; + begin + S := Read (C.Aranges); + L := Read (C.Aranges); + Start := Integer_Address (S); + Len := Storage_Count (L); + end; + else + raise Constraint_Error; + end if; + end Read_Aranges_Entry; + + ------------------ + -- Enable_Cache -- + ------------------ + + procedure Enable_Cache (C : in out Dwarf_Context) is + Cache : Search_Array_Access; + begin + -- Phase 1: count number of symbols. Phase 2: fill the cache. + declare + S : Object_Symbol; + Sz : uint32; + Addr, Prev_Addr : uint32; + Nbr_Symbols : Natural; + begin + for Phase in 1 .. 2 loop + Nbr_Symbols := 0; + S := First_Symbol (C.Obj.all); + Prev_Addr := uint32'Last; + while S /= Null_Symbol loop + -- Discard symbols whose length is 0 + Sz := uint32 (Size (S)); + + -- Try to filter symbols at the same address. This is a best + -- effort as they might not be consecutive. + Addr := uint32 (Value (S) - uint64 (C.Low)); + if Sz > 0 and then Addr /= Prev_Addr then + Nbr_Symbols := Nbr_Symbols + 1; + Prev_Addr := Addr; + + if Phase = 2 then + C.Cache (Nbr_Symbols) := + (First => Addr, + Size => Sz, + Sym => uint32 (Off (S)), + Line => 0); + end if; + end if; + + S := Next_Symbol (C.Obj.all, S); + end loop; + + if Phase = 1 then + -- Allocate the cache + Cache := new Search_Array (1 .. Nbr_Symbols); + C.Cache := Cache; + end if; + end loop; + pragma Assert (Nbr_Symbols = C.Cache'Last); + end; + + -- Sort the cache. + Sort_Search_Array (C.Cache.all); + + -- Set line offsets + if not C.Has_Debug then + return; + end if; + declare + Info_Offset : Offset; + Line_Offset : Offset; + Success : Boolean; + Ar_Start : Integer_Address; + Ar_Len : Storage_Count; + Start, Len : uint32; + First, Last : Natural; + Mid : Natural; + begin + Seek (C.Aranges, 0); + + while Tell (C.Aranges) < Length (C.Aranges) loop + Read_Aranges_Header (C, Info_Offset, Success); + exit when not Success; + + Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); + exit when not Success; + + -- Read table + loop + Read_Aranges_Entry (C, Ar_Start, Ar_Len); + exit when Ar_Start = 0 and Ar_Len = 0; + + Len := uint32 (Ar_Len); + Start := uint32 (Ar_Start - To_Integer (C.Low)); + + -- Search START in the array + First := Cache'First; + Last := Cache'Last; + Mid := First; -- In case of array with one element + while First < Last loop + Mid := First + (Last - First) / 2; + if Start < Cache (Mid).First then + Last := Mid - 1; + elsif Start >= Cache (Mid).First + Cache (Mid).Size then + First := Mid + 1; + else + exit; + end if; + end loop; + + -- Fill info. + + -- There can be overlapping symbols + while Mid > Cache'First + and then Cache (Mid - 1).First <= Start + and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start + loop + Mid := Mid - 1; + end loop; + while Mid <= Cache'Last loop + if Start < Cache (Mid).First + Cache (Mid).Size + and then Start + Len > Cache (Mid).First + then + -- MID is within the bounds + Cache (Mid).Line := uint32 (Line_Offset); + elsif Start + Len <= Cache (Mid).First then + -- Over + exit; + end if; + Mid := Mid + 1; + end loop; + end loop; + end loop; + end; + end Enable_Cache; + + ---------------------- + -- Symbolic_Address -- + ---------------------- + + procedure Symbolic_Address + (C : in out Dwarf_Context; + Addr : Address; + Dir_Name : out Str_Access; + File_Name : out Str_Access; + Subprg_Name : out String_Ptr_Len; + Line_Num : out Natural) + is + procedure Set_Result (Match : Line_Info_Registers); + -- Set results using match + + procedure Set_Result (Match : Line_Info_Registers) is + Dir_Idx : uint32; + J : uint32; + + Mod_Time : uint32; + pragma Unreferenced (Mod_Time); + + Length : uint32; + pragma Unreferenced (Length); + + begin + Seek (C.Lines, C.Prologue.File_Names_Offset); + + -- Find the entry + + J := 0; + loop + J := J + 1; + File_Name := Read_C_String (C.Lines); + + if File_Name (File_Name'First) = ASCII.NUL then + -- End of file list, so incorrect entry + return; + end if; + + Dir_Idx := Read_LEB128 (C.Lines); + Mod_Time := Read_LEB128 (C.Lines); + Length := Read_LEB128 (C.Lines); + exit when J = Match.File; + end loop; + + if Dir_Idx = 0 then + -- No directory + Dir_Name := null; + + else + Seek (C.Lines, C.Prologue.Includes_Offset); + + J := 0; + loop + J := J + 1; + Dir_Name := Read_C_String (C.Lines); + + if Dir_Name (Dir_Name'First) = ASCII.NUL then + -- End of directory list, so ill-formed table + return; + end if; + + exit when J = Dir_Idx; + + end loop; + end if; + + Line_Num := Natural (Match.Line); + end Set_Result; + + Addr_Int : constant Integer_Address := To_Integer (Addr); + Previous_Row : Line_Info_Registers; + Info_Offset : Offset; + Line_Offset : Offset; + Success : Boolean; + Done : Boolean; + S : Object_Symbol; + begin + -- Initialize result + Dir_Name := null; + File_Name := null; + Subprg_Name := (null, 0); + Line_Num := 0; + + if C.Cache /= null then + -- Look in the cache + declare + Addr_Off : constant uint32 := uint32 (Addr - C.Low); + First, Last, Mid : Natural; + begin + First := C.Cache'First; + Last := C.Cache'Last; + while First <= Last loop + Mid := First + (Last - First) / 2; + if Addr_Off < C.Cache (Mid).First then + Last := Mid - 1; + elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then + First := Mid + 1; + else + exit; + end if; + end loop; + if Addr_Off >= C.Cache (Mid).First + and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size + then + Line_Offset := Offset (C.Cache (Mid).Line); + S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym)); + Subprg_Name := Object_Reader.Name (C.Obj.all, S); + else + -- Not found + return; + end if; + end; + else + -- Search symbol + S := First_Symbol (C.Obj.all); + while S /= Null_Symbol loop + if Spans (S, uint64 (Addr_Int)) then + Subprg_Name := Object_Reader.Name (C.Obj.all, S); + exit; + end if; + + S := Next_Symbol (C.Obj.all, S); + end loop; + + -- Search address in aranges table + + Aranges_Lookup (C, Addr, Info_Offset, Success); + if not Success then + return; + end if; + + -- Search stmt_list in info table + + Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); + if not Success then + return; + end if; + end if; + + Seek (C.Lines, Line_Offset); + C.Next_Prologue := 0; + Initialize_State_Machine (C); + Parse_Prologue (C); + + -- Advance to the first entry + + loop + Read_And_Execute_Isn (C, Done); + + if C.Registers.Is_Row then + Previous_Row := C.Registers; + exit; + end if; + + exit when Done; + end loop; + + -- Read the rest of the entries + + while Tell (C.Lines) < C.Next_Prologue loop + Read_And_Execute_Isn (C, Done); + + if C.Registers.Is_Row then + if not Previous_Row.End_Sequence + and then Addr_Int >= Integer_Address (Previous_Row.Address) + and then Addr_Int < Integer_Address (C.Registers.Address) + then + Set_Result (Previous_Row); + return; + + elsif Addr_Int = Integer_Address (C.Registers.Address) then + Set_Result (C.Registers); + return; + end if; + + Previous_Row := C.Registers; + end if; + + exit when Done; + end loop; + end Symbolic_Address; + + ------------------- + -- String_Length -- + ------------------- + + function String_Length (Str : Str_Access) return Natural is + begin + for I in Str'Range loop + if Str (I) = ASCII.NUL then + return I - Str'First; + end if; + end loop; + return Str'Last; + end String_Length; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + procedure Symbolic_Traceback + (Cin : Dwarf_Context; + Traceback : AET.Tracebacks_Array; + Suppress_Hex : Boolean; + Symbol_Found : in out Boolean; + Res : in out System.Bounded_Strings.Bounded_String) + is + use Ada.Characters.Handling; + C : Dwarf_Context := Cin; + Addr : Address; + + Dir_Name : Str_Access; + File_Name : Str_Access; + Subprg_Name : String_Ptr_Len; + Line_Num : Natural; + Off : Natural; + begin + if not C.Has_Debug then + Symbol_Found := False; + return; + else + Symbol_Found := True; + end if; + + for J in Traceback'Range loop + -- If the buffer is full, no need to do any useless work + exit when Is_Full (Res); + + Addr := PC_For (Traceback (J)); + Symbolic_Address + (C, + To_Address (To_Integer (Addr) + C.Load_Slide), + Dir_Name, + File_Name, + Subprg_Name, + Line_Num); + + if File_Name /= null then + declare + Last : constant Natural := String_Length (File_Name); + Is_Ada : constant Boolean := + Last > 3 + and then + To_Upper (String (File_Name (Last - 3 .. Last - 1))) = + ".AD"; + -- True if this is an Ada file. This doesn't take into account + -- nonstandard file-naming conventions, but that's OK; this is + -- purely cosmetic. It covers at least .ads, .adb, and .ada. + + Line_Image : constant String := Natural'Image (Line_Num); + begin + if Subprg_Name.Len /= 0 then + -- For Ada code, Symbol_Image is in all lower case; we don't + -- have the case from the original source code. But the best + -- guess is Mixed_Case, so convert to that. + + if Is_Ada then + declare + Symbol_Image : String := + Object_Reader.Decoded_Ada_Name + (C.Obj.all, + Subprg_Name); + begin + for K in Symbol_Image'Range loop + if K = Symbol_Image'First + or else not + (Is_Letter (Symbol_Image (K - 1)) + or else Is_Digit (Symbol_Image (K - 1))) + then + Symbol_Image (K) := To_Upper (Symbol_Image (K)); + end if; + end loop; + Append (Res, Symbol_Image); + end; + else + Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); + + Append + (Res, + String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); + end if; + Append (Res, ' '); + end if; + + Append (Res, "at "); + Append (Res, String (File_Name (1 .. Last))); + Append (Res, ':'); + Append (Res, Line_Image (2 .. Line_Image'Last)); + end; + else + if Suppress_Hex then + Append (Res, "..."); + else + Append_Address (Res, Addr); + end if; + + if Subprg_Name.Len > 0 then + Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); + + Append (Res, ' '); + Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); + end if; + + Append (Res, " at ???"); + end if; + + Append (Res, ASCII.LF); + end loop; + end Symbolic_Traceback; +end System.Dwarf_Lines; diff --git a/gcc/ada/libgnat/s-dwalin.ads b/gcc/ada/libgnat/s-dwalin.ads new file mode 100644 index 0000000..3608fef --- /dev/null +++ b/gcc/ada/libgnat/s-dwalin.ads @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . D W A R F _ L I N E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides routines to read DWARF line number information from +-- a generic object file with as little overhead as possible. This allows +-- conversions from PC addresses to human readable source locations. +-- +-- Objects must be built with debugging information, however only the +-- .debug_line section of the object file is referenced. In cases where object +-- size is a consideration it's possible to strip all other .debug sections, +-- which will decrease the size of the object significantly. + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on + +with Ada.Exceptions.Traceback; + +with System.Object_Reader; +with System.Storage_Elements; +with System.Bounded_Strings; + +package System.Dwarf_Lines is + + package AET renames Ada.Exceptions.Traceback; + package SOR renames System.Object_Reader; + + type Dwarf_Context (In_Exception : Boolean := False) is private; + -- Type encapsulation the state of the Dwarf reader. When In_Exception + -- is True we are parsing as part of a exception handler decorator, we do + -- not want an exception to be raised, the parsing is done safely skipping + -- DWARF file that cannot be read or with stripped debug section for + -- example. + + procedure Open + (File_Name : String; + C : out Dwarf_Context; + Success : out Boolean); + procedure Close (C : in out Dwarf_Context); + -- Open and close files + + procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address); + -- Set the load address of a file. This is used to rebase PIE (Position + -- Independant Executable) binaries. + + function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean; + pragma Inline (Is_Inside); + -- Return true iff Addr is within the module + + function Low (C : Dwarf_Context) return Address; + pragma Inline (Low); + -- Return the lowest address of C + + procedure Dump (C : in out Dwarf_Context); + -- Dump each row found in the object's .debug_lines section to standard out + + procedure Dump_Cache (C : Dwarf_Context); + -- Dump the cache (if present) + + procedure Enable_Cache (C : in out Dwarf_Context); + -- Read symbols information to speed up Symbolic_Traceback. + + procedure Symbolic_Traceback + (Cin : Dwarf_Context; + Traceback : AET.Tracebacks_Array; + Suppress_Hex : Boolean; + Symbol_Found : in out Boolean; + Res : in out System.Bounded_Strings.Bounded_String); + -- Generate a string for a traceback suitable for displaying to the user. + -- If one or more symbols are found, Symbol_Found is set to True. This + -- allows the caller to fall back to hexadecimal addresses. + + Dwarf_Error : exception; + -- Raised if a problem is encountered parsing DWARF information. Can be a + -- result of a logic error or malformed DWARF information. + +private + -- The following section numbers reference + + -- "DWARF Debugging Information Format, Version 3" + + -- published by the Standards Group, http://freestandards.org. + + -- 6.2.2 State Machine Registers + + type Line_Info_Registers is record + Address : SOR.uint64; + File : SOR.uint32; + Line : SOR.uint32; + Column : SOR.uint32; + Is_Stmt : Boolean; + Basic_Block : Boolean; + End_Sequence : Boolean; + Prologue_End : Boolean; + Epilogue_Begin : Boolean; + ISA : SOR.uint32; + Is_Row : Boolean; + end record; + + -- 6.2.4 The Line Number Program Prologue + + MAX_OPCODE_LENGTHS : constant := 256; + + type Opcodes_Lengths_Array is + array (SOR.uint32 range 1 .. MAX_OPCODE_LENGTHS) of SOR.uint8; + + type Line_Info_Prologue is record + Unit_Length : SOR.uint32; + Version : SOR.uint16; + Prologue_Length : SOR.uint32; + Min_Isn_Length : SOR.uint8; + Default_Is_Stmt : SOR.uint8; + Line_Base : SOR.int8; + Line_Range : SOR.uint8; + Opcode_Base : SOR.uint8; + Opcode_Lengths : Opcodes_Lengths_Array; + Includes_Offset : SOR.Offset; + File_Names_Offset : SOR.Offset; + end record; + + type Search_Entry is record + First : SOR.uint32; + Size : SOR.uint32; + -- Function bounds as offset to the base address. + + Sym : SOR.uint32; + -- Symbol offset to get the name. + + Line : SOR.uint32; + -- Dwarf line offset. + end record; + + type Search_Array is array (Natural range <>) of Search_Entry; + + type Search_Array_Access is access Search_Array; + + type Dwarf_Context (In_Exception : Boolean := False) is record + Load_Slide : System.Storage_Elements.Integer_Address := 0; + Low, High : Address; + -- Bounds of the module + + Obj : SOR.Object_File_Access; + -- The object file containing dwarf sections + + Has_Debug : Boolean; + -- True if all debug sections are available + + Cache : Search_Array_Access; + -- Quick access to symbol and debug info (when present). + + Lines : SOR.Mapped_Stream; + Aranges : SOR.Mapped_Stream; + Info : SOR.Mapped_Stream; + Abbrev : SOR.Mapped_Stream; + -- Dwarf line, aranges, info and abbrev sections + + Prologue : Line_Info_Prologue; + Registers : Line_Info_Registers; + Next_Prologue : SOR.Offset; + -- State for lines + end record; + +end System.Dwarf_Lines; diff --git a/gcc/ada/libgnat/s-elaall.adb b/gcc/ada/libgnat/s-elaall.adb new file mode 100644 index 0000000..4ed92be --- /dev/null +++ b/gcc/ada/libgnat/s-elaall.adb @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E L A B O R A T I O N _ A L L O C A T O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Elaboration_Allocators is + + Elaboration_In_Progress : Boolean; + pragma Atomic (Elaboration_In_Progress); + -- Flag to show if elaboration is active. We don't attempt to initialize + -- this because we want to be sure it gets reset if we are in a multiple + -- elaboration situation of some kind. Make it atomic to prevent race + -- conditions of any kind (not clearly necessary, but harmless!) + + ------------------------------ + -- Check_Standard_Allocator -- + ------------------------------ + + procedure Check_Standard_Allocator is + begin + if not Elaboration_In_Progress then + raise Program_Error with + "standard allocator after elaboration is complete is not allowed " + & "(No_Standard_Allocators_After_Elaboration restriction active)"; + end if; + end Check_Standard_Allocator; + + ----------------------------- + -- Mark_End_Of_Elaboration -- + ----------------------------- + + procedure Mark_End_Of_Elaboration is + begin + Elaboration_In_Progress := False; + end Mark_End_Of_Elaboration; + + ------------------------------- + -- Mark_Start_Of_Elaboration -- + ------------------------------- + + procedure Mark_Start_Of_Elaboration is + begin + Elaboration_In_Progress := True; + end Mark_Start_Of_Elaboration; + +end System.Elaboration_Allocators; diff --git a/gcc/ada/libgnat/s-elaall.ads b/gcc/ada/libgnat/s-elaall.ads new file mode 100644 index 0000000..7dc47a0 --- /dev/null +++ b/gcc/ada/libgnat/s-elaall.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E L A B O R A T I O N _ A L L O C A T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2014-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the interfaces for proper handling of restriction +-- No_Standard_Allocators_After_Elaboration. It is used only by programs +-- which use this restriction. + +package System.Elaboration_Allocators is + pragma Preelaborate; + + procedure Mark_Start_Of_Elaboration; + -- Called right at the start of main elaboration if the program activates + -- restriction No_Standard_Allocators_After_Elaboration. We don't want to + -- rely on the normal elaboration mechanism for marking this event, since + -- that would require us to be sure to elaborate this first, which would + -- be awkward, and it is convenient to have this package be Preelaborate. + + procedure Mark_End_Of_Elaboration; + -- Called when main elaboration is complete if the program has activated + -- restriction No_Standard_Allocators_After_Elaboration. This is the point + -- beyond which any standard allocator use will violate the restriction. + + procedure Check_Standard_Allocator; + -- Called as part of every allocator in a program for which the restriction + -- No_Standard_Allocators_After_Elaboration is active. This will raise an + -- exception (Program_Error with an appropriate message) if it is called + -- after the call to Mark_End_Of_Elaboration. + +end System.Elaboration_Allocators; diff --git a/gcc/ada/libgnat/s-excdeb.adb b/gcc/ada/libgnat/s-excdeb.adb new file mode 100644 index 0000000..7eef8e1 --- /dev/null +++ b/gcc/ada/libgnat/s-excdeb.adb @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S _ D E B U G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.Exceptions_Debug is + + --------------------------- + -- Debug_Raise_Exception -- + --------------------------- + + procedure Debug_Raise_Exception + (E : SSL.Exception_Data_Ptr; Message : String) + is + pragma Inspection_Point (E, Message); + begin + null; + end Debug_Raise_Exception; + + ------------------------------- + -- Debug_unhandled_Exception -- + ------------------------------- + + procedure Debug_Unhandled_Exception (E : SSL.Exception_Data_Ptr) is + pragma Inspection_Point (E); + begin + null; + end Debug_Unhandled_Exception; + + -------------------------------- + -- Debug_Raise_Assert_Failure -- + -------------------------------- + + procedure Debug_Raise_Assert_Failure is + begin + null; + end Debug_Raise_Assert_Failure; + + ----------------- + -- Local_Raise -- + ----------------- + + procedure Local_Raise (Excep : System.Address) is + pragma Warnings (Off, Excep); + begin + return; + end Local_Raise; + +end System.Exceptions_Debug; diff --git a/gcc/ada/libgnat/s-excdeb.ads b/gcc/ada/libgnat/s-excdeb.ads new file mode 100644 index 0000000..5d9533e --- /dev/null +++ b/gcc/ada/libgnat/s-excdeb.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S _ D E B U G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains internal routines used as debugger helpers. +-- It should be compiled without optimization to let debuggers inspect +-- parameter values reliably from breakpoints on the routines. + +pragma Compiler_Unit_Warning; + +with System.Standard_Library; + +package System.Exceptions_Debug is + + pragma Preelaborate; + -- To let Ada.Exceptions "with" us and let us "with" Standard_Library + + package SSL renames System.Standard_Library; + -- To let some of the hooks below have formal parameters typed in + -- accordance with what GDB expects. + + procedure Debug_Raise_Exception + (E : SSL.Exception_Data_Ptr; Message : String); + pragma Export + (Ada, Debug_Raise_Exception, "__gnat_debug_raise_exception"); + -- Hook called at a "raise" point for an exception E, when it is + -- just about to be propagated. + + procedure Debug_Unhandled_Exception (E : SSL.Exception_Data_Ptr); + pragma Export + (Ada, Debug_Unhandled_Exception, "__gnat_unhandled_exception"); + -- Hook called during the propagation process of an exception E, as soon + -- as it is known to be unhandled. + + procedure Debug_Raise_Assert_Failure; + pragma Export + (Ada, Debug_Raise_Assert_Failure, "__gnat_debug_raise_assert_failure"); + -- Hook called when an assertion failed. This is used by the debugger to + -- intercept assertion failures, and treat them specially. + + procedure Local_Raise (Excep : System.Address); + pragma Export (Ada, Local_Raise); + -- This is a dummy routine, used only by the debugger for the purpose of + -- logging local raise statements that were transformed into a direct goto + -- to the handler code. The compiler in this case generates: + -- + -- Local_Raise (exception_data'address); + -- goto Handler + -- + -- The argument is the address of the exception data +end System.Exceptions_Debug; diff --git a/gcc/ada/libgnat/s-except.adb b/gcc/ada/libgnat/s-except.adb new file mode 100644 index 0000000..e48d060 --- /dev/null +++ b/gcc/ada/libgnat/s-except.adb @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package does not require a body, since it is a package renaming. We +-- provide a dummy file containing a No_Body pragma so that previous versions +-- of the body (which did exist) will not interfere. + +-- pragma No_Body; + +-- The above pragma is commented out, since for now we can't use No_Body in +-- a unit marked as a Compiler_Unit, since this requires GNAT 6.1, and we +-- do not yet require this for bootstrapping. So instead we use a dummy Taft +-- amendment type to require the body: + +package body System.Exceptions is + type Require_Body is new Integer; +end System.Exceptions; diff --git a/gcc/ada/libgnat/s-except.ads b/gcc/ada/libgnat/s-except.ads new file mode 100644 index 0000000..d33bea6 --- /dev/null +++ b/gcc/ada/libgnat/s-except.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package System.Exceptions is + + pragma Preelaborate; + -- To let Ada.Exceptions "with" us and let us "with" Standard_Library + + ZCX_By_Default : constant Boolean; + -- Visible copy to allow Ada.Exceptions to know the exception model + +private + + type Require_Body; + -- Dummy Taft-amendment type to make it legal (and required) to provide + -- a body for this package. + -- + -- We do this because this unit used to have a body in earlier versions + -- of GNAT, and it causes various bootstrap path problems etc if we remove + -- a body, since we may pick up old unwanted bodies. + -- + -- Note: we use this standard Ada method of requiring a body rather + -- than the cleaner pragma No_Body because System.Exceptions is a compiler + -- unit, and older bootstrap compilers do not support pragma No_Body. This + -- type can be removed, and s-except.adb can be replaced by a source + -- containing just that pragma, when we decide to move to a 2008 compiler + -- as the minimal bootstrap compiler version. ??? + + ZCX_By_Default : constant Boolean := System.ZCX_By_Default; + + Foreign_Exception : exception; + pragma Unreferenced (Foreign_Exception); + -- This hidden exception is used to represent non-Ada exception to + -- Ada handlers. It is in fact referenced by its linking name. + +end System.Exceptions; diff --git a/gcc/ada/libgnat/s-excmac-arm.adb b/gcc/ada/libgnat/s-excmac-arm.adb new file mode 100644 index 0000000..cfaa853 --- /dev/null +++ b/gcc/ada/libgnat/s-excmac-arm.adb @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exceptions.Machine is + function New_Occurrence return GNAT_GCC_Exception_Access is + Res : GNAT_GCC_Exception_Access; + begin + Res := new GNAT_GCC_Exception; + Res.Header.Class := GNAT_Exception_Class; + Res.Header.Unwinder_Cache. Reserved1 := 0; + return Res; + end New_Occurrence; + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac-arm.ads b/gcc/ada/libgnat/s-excmac-arm.ads new file mode 100644 index 0000000..195d337 --- /dev/null +++ b/gcc/ada/libgnat/s-excmac-arm.ads @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Declaration of the machine exception and some associated facilities. The +-- machine exception is the object that is propagated by low level routines +-- and that contains the Ada exception occurrence. + +-- This is the version using the ARM EHABI mechanism + +with Ada.Unchecked_Conversion; +with Ada.Exceptions; + +package System.Exceptions.Machine is + pragma Preelaborate; + + ------------------------------------------------ + -- Entities to interface with the GCC runtime -- + ------------------------------------------------ + + -- Return codes from GCC runtime functions used to propagate an exception + + type Unwind_Reason_Code is + (URC_OK, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_Unused2, + URC_Unused3, + URC_Unused4, + URC_Unused5, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND, + URC_FAILURE); + + pragma Unreferenced + (URC_OK, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_Unused2, + URC_Unused3, + URC_Unused4, + URC_Unused5, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND, + URC_FAILURE); + + pragma Convention (C, Unwind_Reason_Code); + subtype Unwind_Action is Unwind_Reason_Code; + -- Phase identifiers + + type uint32_t is mod 2**32; + pragma Convention (C, uint32_t); + + type uint32_t_array is array (Natural range <>) of uint32_t; + pragma Convention (C, uint32_t_array); + + type Unwind_State is new uint32_t; + pragma Convention (C, Unwind_State); + + US_VIRTUAL_UNWIND_FRAME : constant Unwind_State := 0; + US_UNWIND_FRAME_STARTING : constant Unwind_State := 1; + US_UNWIND_FRAME_RESUME : constant Unwind_State := 2; + + pragma Unreferenced + (US_VIRTUAL_UNWIND_FRAME, + US_UNWIND_FRAME_STARTING, + US_UNWIND_FRAME_RESUME); + + -- Mandatory common header for any exception object handled by the + -- GCC unwinding runtime. + + type Exception_Class is array (0 .. 7) of Character; + + GNAT_Exception_Class : constant Exception_Class := "GNU-Ada" & ASCII.NUL; + -- "GNU-Ada\0" + + type Unwinder_Cache_Type is record + Reserved1 : uint32_t; + Reserved2 : uint32_t; + Reserved3 : uint32_t; + Reserved4 : uint32_t; + Reserved5 : uint32_t; + end record; + + type Barrier_Cache_Type is record + Sp : uint32_t; + Bitpattern : uint32_t_array (0 .. 4); + end record; + + type Cleanup_Cache_Type is record + Bitpattern : uint32_t_array (0 .. 3); + end record; + + type Pr_Cache_Type is record + Fnstart : uint32_t; + Ehtp : System.Address; + Additional : uint32_t; + Reserved1 : uint32_t; + end record; + + type Unwind_Control_Block is record + Class : Exception_Class; + Cleanup : System.Address; + + -- Caches + Unwinder_Cache : Unwinder_Cache_Type; + Barrier_Cache : Barrier_Cache_Type; + Cleanup_Cache : Cleanup_Cache_Type; + Pr_Cache : Pr_Cache_Type; + end record; + pragma Convention (C, Unwind_Control_Block); + for Unwind_Control_Block'Alignment use 8; + -- Map the GCC struct used for exception handling + + type Unwind_Control_Block_Access is access all Unwind_Control_Block; + subtype GCC_Exception_Access is Unwind_Control_Block_Access; + -- Pointer to a UCB + + procedure Unwind_DeleteException + (Ucbp : not null Unwind_Control_Block_Access); + pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); + -- Procedure to free any GCC exception + + -------------------------------------------------------------- + -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- + -------------------------------------------------------------- + + -- A GNAT exception object to be dealt with by the personality routine + -- called by the GCC unwinding runtime. + + type GNAT_GCC_Exception is record + Header : Unwind_Control_Block; + -- ABI Exception header first + + Occurrence : aliased Ada.Exceptions.Exception_Occurrence; + -- The Ada occurrence + end record; + + pragma Convention (C, GNAT_GCC_Exception); + + type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; + + function To_GCC_Exception is new + Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); + + function To_GNAT_GCC_Exception is new + Ada.Unchecked_Conversion + (GCC_Exception_Access, GNAT_GCC_Exception_Access); + + function New_Occurrence return GNAT_GCC_Exception_Access; + -- Allocate and initialize a machine occurrence + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac-gcc.adb b/gcc/ada/libgnat/s-excmac-gcc.adb new file mode 100644 index 0000000..7d39651 --- /dev/null +++ b/gcc/ada/libgnat/s-excmac-gcc.adb @@ -0,0 +1,43 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exceptions.Machine is + function New_Occurrence return GNAT_GCC_Exception_Access is + Res : GNAT_GCC_Exception_Access; + begin + Res := new GNAT_GCC_Exception; + Res.Header := (Class => GNAT_Exception_Class, + Cleanup => Null_Address, + others => 0); + return Res; + end New_Occurrence; + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-excmac-gcc.ads b/gcc/ada/libgnat/s-excmac-gcc.ads new file mode 100644 index 0000000..dabf8b6 --- /dev/null +++ b/gcc/ada/libgnat/s-excmac-gcc.ads @@ -0,0 +1,185 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N S . M A C H I N E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Declaration of the machine exception and some associated facilities. The +-- machine exception is the object that is propagated by low level routines +-- and that contains the Ada exception occurrence. + +-- This is the version using the GCC EH mechanism + +with Ada.Unchecked_Conversion; +with Ada.Exceptions; + +package System.Exceptions.Machine is + pragma Preelaborate; + + ------------------------------------------------ + -- Entities to interface with the GCC runtime -- + ------------------------------------------------ + + -- These come from "C++ ABI for Itanium: Exception handling", which is + -- the reference for GCC. + + -- Return codes from the GCC runtime functions used to propagate + -- an exception. + + type Unwind_Reason_Code is + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Unreferenced + (URC_NO_REASON, + URC_FOREIGN_EXCEPTION_CAUGHT, + URC_PHASE2_ERROR, + URC_PHASE1_ERROR, + URC_NORMAL_STOP, + URC_END_OF_STACK, + URC_HANDLER_FOUND, + URC_INSTALL_CONTEXT, + URC_CONTINUE_UNWIND); + + pragma Convention (C, Unwind_Reason_Code); + + -- Phase identifiers + + type Unwind_Action is new Integer; + pragma Convention (C, Unwind_Action); + + UA_SEARCH_PHASE : constant Unwind_Action := 1; + UA_CLEANUP_PHASE : constant Unwind_Action := 2; + UA_HANDLER_FRAME : constant Unwind_Action := 4; + UA_FORCE_UNWIND : constant Unwind_Action := 8; + UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension + + pragma Unreferenced + (UA_SEARCH_PHASE, + UA_CLEANUP_PHASE, + UA_HANDLER_FRAME, + UA_FORCE_UNWIND, + UA_END_OF_STACK); + + -- Mandatory common header for any exception object handled by the + -- GCC unwinding runtime. + + type Exception_Class is mod 2 ** 64; + + GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#; + -- "GNU-Ada\0" + + type Unwind_Word is mod 2 ** System.Word_Size; + for Unwind_Word'Size use System.Word_Size; + -- Map the corresponding C type used in Unwind_Exception below + + type Unwind_Exception is record + Class : Exception_Class; + Cleanup : System.Address; + Private1 : Unwind_Word; + Private2 : Unwind_Word; + + -- Usual exception structure has only two private fields, but the SEH + -- one has six. To avoid making this file more complex, we use six + -- fields on all platforms, wasting a few bytes on some. + + Private3 : Unwind_Word; + Private4 : Unwind_Word; + Private5 : Unwind_Word; + Private6 : Unwind_Word; + end record; + pragma Convention (C, Unwind_Exception); + -- Map the GCC struct used for exception handling + + for Unwind_Exception'Alignment use Standard'Maximum_Alignment; + -- The C++ ABI mandates the common exception header to be at least + -- doubleword aligned, and the libGCC implementation actually makes it + -- maximally aligned (see unwind.h). See additional comments on the + -- alignment below. + + -- There is a subtle issue with the common header alignment, since the C + -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on + -- Standard'Maximum_Alignment, and those two values don't quite represent + -- the same concepts and so may be decoupled someday. One typical reason + -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system + -- allocator guarantees, and there are extra costs involved in allocating + -- objects aligned to such factors. + + -- To deal with the potential alignment differences between the C and Ada + -- representations, the Ada part of the whole structure is only accessed + -- by the personality routine through accessors. Ada specific fields are + -- thus always accessed through consistent layout, and we expect the + -- actual alignment to always be large enough to avoid traps from the C + -- accesses to the common header. Besides, accessors alleviate the need + -- for a C struct whole counterpart, both painful and error-prone to + -- maintain anyway. + + type GCC_Exception_Access is access all Unwind_Exception; + -- Pointer to a GCC exception + + procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); + pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); + -- Procedure to free any GCC exception + + -------------------------------------------------------------- + -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- + -------------------------------------------------------------- + + -- A GNAT exception object to be dealt with by the personality routine + -- called by the GCC unwinding runtime. + + type GNAT_GCC_Exception is record + Header : Unwind_Exception; + -- ABI Exception header first + + Occurrence : aliased Ada.Exceptions.Exception_Occurrence; + -- The Ada occurrence + end record; + + pragma Convention (C, GNAT_GCC_Exception); + + type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; + + function To_GCC_Exception is new + Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); + + function To_GNAT_GCC_Exception is new + Ada.Unchecked_Conversion + (GCC_Exception_Access, GNAT_GCC_Exception_Access); + + function New_Occurrence return GNAT_GCC_Exception_Access; + -- Allocate and initialize a machine occurrence + +end System.Exceptions.Machine; diff --git a/gcc/ada/libgnat/s-exctab.adb b/gcc/ada/libgnat/s-exctab.adb new file mode 100644 index 0000000..adbf1f4 --- /dev/null +++ b/gcc/ada/libgnat/s-exctab.adb @@ -0,0 +1,339 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N _ T A B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Soft_Links; use System.Soft_Links; + +package body System.Exception_Table is + + use System.Standard_Library; + + type Hash_Val is mod 2 ** 8; + subtype Hash_Idx is Hash_Val range 1 .. 37; + + HTable : array (Hash_Idx) of aliased Exception_Data_Ptr; + -- Actual hash table containing all registered exceptions + -- + -- The table is very small and the hash function weak, as looking up + -- registered exceptions is rare and minimizing space and time overhead + -- of registration is more important. In addition, it is expected that the + -- exceptions that need to be looked up are registered dynamically, and + -- therefore will be at the begin of the hash chains. + -- + -- The table differs from System.HTable.Static_HTable in that the final + -- element of each chain is not marked by null, but by a pointer to self. + -- This way it is possible to defend against the same entry being inserted + -- twice, without having to do a lookup which is relatively expensive for + -- programs with large number + -- + -- All non-local subprograms use the global Task_Lock to protect against + -- concurrent use of the exception table. This is needed as local + -- exceptions may be declared concurrently with those declared at the + -- library level. + + -- Local Subprograms + + generic + with procedure Process (T : Exception_Data_Ptr; More : out Boolean); + procedure Iterate; + -- Iterate over all + + function Lookup (Name : String) return Exception_Data_Ptr; + -- Find and return the Exception_Data of the exception with the given Name + -- (which must be in all uppercase), or null if none was registered. + + procedure Register (Item : Exception_Data_Ptr); + -- Register an exception with the given Exception_Data in the table. + + function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean; + -- Return True iff Item.Full_Name and Name are equal. Both names are + -- assumed to be in all uppercase and end with ASCII.NUL. + + function Hash (S : String) return Hash_Idx; + -- Return the index in the hash table for S, which is assumed to be all + -- uppercase and end with ASCII.NUL. + + -------------- + -- Has_Name -- + -------------- + + function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean + is + S : constant Big_String_Ptr := To_Ptr (Item.Full_Name); + J : Integer := S'First; + + begin + for K in Name'Range loop + + -- Note that as both items are terminated with ASCII.NUL, the + -- comparison below must fail for strings of different lengths. + + if S (J) /= Name (K) then + return False; + end if; + + J := J + 1; + end loop; + + return True; + end Has_Name; + + ------------ + -- Lookup -- + ------------ + + function Lookup (Name : String) return Exception_Data_Ptr is + Prev : Exception_Data_Ptr; + Curr : Exception_Data_Ptr; + + begin + Curr := HTable (Hash (Name)); + Prev := null; + while Curr /= Prev loop + if Has_Name (Curr, Name) then + return Curr; + end if; + + Prev := Curr; + Curr := Curr.HTable_Ptr; + end loop; + + return null; + end Lookup; + + ---------- + -- Hash -- + ---------- + + function Hash (S : String) return Hash_Idx is + Hash : Hash_Val := 0; + + begin + for J in S'Range loop + exit when S (J) = ASCII.NUL; + Hash := Hash xor Character'Pos (S (J)); + end loop; + + return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1); + end Hash; + + ------------- + -- Iterate -- + ------------- + + procedure Iterate is + More : Boolean; + Prev, Curr : Exception_Data_Ptr; + + begin + Outer : for Idx in HTable'Range loop + Prev := null; + Curr := HTable (Idx); + + while Curr /= Prev loop + Process (Curr, More); + + exit Outer when not More; + + Prev := Curr; + Curr := Curr.HTable_Ptr; + end loop; + end loop Outer; + end Iterate; + + -------------- + -- Register -- + -------------- + + procedure Register (Item : Exception_Data_Ptr) is + begin + if Item.HTable_Ptr = null then + Prepend_To_Chain : declare + Chain : Exception_Data_Ptr + renames HTable (Hash (To_Ptr (Item.Full_Name).all)); + + begin + if Chain = null then + Item.HTable_Ptr := Item; + else + Item.HTable_Ptr := Chain; + end if; + + Chain := Item; + end Prepend_To_Chain; + end if; + end Register; + + ------------------------------- + -- Get_Registered_Exceptions -- + ------------------------------- + + procedure Get_Registered_Exceptions + (List : out Exception_Data_Array; + Last : out Integer) + is + procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean); + -- Add Item to List (List'First .. Last) by first incrementing Last + -- and storing Item in List (Last). Last should be in List'First - 1 + -- and List'Last. + + procedure Get_All is new Iterate (Get_One); + -- Store all registered exceptions in List, updating Last + + ------------- + -- Get_One -- + ------------- + + procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is + begin + if Last < List'Last then + Last := Last + 1; + List (Last) := Item; + More := True; + + else + More := False; + end if; + end Get_One; + + begin + -- In this routine the invariant is that List (List'First .. Last) + -- contains the registered exceptions retrieved so far. + + Last := List'First - 1; + + Lock_Task.all; + Get_All; + Unlock_Task.all; + end Get_Registered_Exceptions; + + ------------------------ + -- Internal_Exception -- + ------------------------ + + function Internal_Exception + (X : String; + Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr + is + -- If X was not yet registered and Create_if_Not_Exist is True, + -- dynamically allocate and register a new exception. + + type String_Ptr is access all String; + + Dyn_Copy : String_Ptr; + Copy : aliased String (X'First .. X'Last + 1); + Result : Exception_Data_Ptr; + + begin + Lock_Task.all; + + Copy (X'Range) := X; + Copy (Copy'Last) := ASCII.NUL; + Result := Lookup (Copy); + + -- If unknown exception, create it on the heap. This is a legitimate + -- situation in the distributed case when an exception is defined + -- only in a partition + + if Result = null and then Create_If_Not_Exist then + Dyn_Copy := new String'(Copy); + + Result := + new Exception_Data' + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Copy'Length, + Full_Name => Dyn_Copy.all'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Register (Result); + end if; + + Unlock_Task.all; + + return Result; + end Internal_Exception; + + ------------------------ + -- Register_Exception -- + ------------------------ + + procedure Register_Exception (X : Exception_Data_Ptr) is + begin + Lock_Task.all; + Register (X); + Unlock_Task.all; + end Register_Exception; + + --------------------------------- + -- Registered_Exceptions_Count -- + --------------------------------- + + function Registered_Exceptions_Count return Natural is + Count : Natural := 0; + + procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean); + -- Update Count for given Item + + procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is + pragma Unreferenced (Item); + begin + Count := Count + 1; + More := Count < Natural'Last; + end Count_Item; + + procedure Count_All is new Iterate (Count_Item); + + begin + Lock_Task.all; + Count_All; + Unlock_Task.all; + + return Count; + end Registered_Exceptions_Count; + +begin + -- Register the standard exceptions at elaboration time + + -- We don't need to use the locking version here as the elaboration + -- will not be concurrent and no tasks can call any subprograms of this + -- unit before it has been elaborated. + + Register (Abort_Signal_Def'Access); + Register (Tasking_Error_Def'Access); + Register (Storage_Error_Def'Access); + Register (Program_Error_Def'Access); + Register (Numeric_Error_Def'Access); + Register (Constraint_Error_Def'Access); +end System.Exception_Table; diff --git a/gcc/ada/libgnat/s-exctab.ads b/gcc/ada/libgnat/s-exctab.ads new file mode 100644 index 0000000..e3c8a1a --- /dev/null +++ b/gcc/ada/libgnat/s-exctab.ads @@ -0,0 +1,75 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N _ T A B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements the interface used to maintain a table of +-- registered exception names, for the implementation of the mapping +-- of names to exceptions (used for exception streams and attributes) + +pragma Compiler_Unit_Warning; + +with System.Standard_Library; + +package System.Exception_Table is + pragma Elaborate_Body; + + package SSL renames System.Standard_Library; + + procedure Register_Exception (X : SSL.Exception_Data_Ptr); + pragma Inline (Register_Exception); + -- Register an exception in the hash table mapping. This function is + -- called during elaboration of library packages. For exceptions that + -- are declared within subprograms, the registration occurs the first + -- time that an exception is elaborated during a call of the subprogram. + -- + -- Note: all calls to Register_Exception other than those to register the + -- predefined exceptions are suppressed if the application is compiled + -- with pragma Restrictions (No_Exception_Registration). + + function Internal_Exception + (X : String; + Create_If_Not_Exist : Boolean := True) return SSL.Exception_Data_Ptr; + -- Given an exception_name X, returns a pointer to the actual internal + -- exception data. A new entry is created in the table if X does not + -- exist yet and Create_If_Not_Exist is True. If it is false and X + -- does not exist yet, null is returned. + + function Registered_Exceptions_Count return Natural; + -- Return the number of currently registered exceptions + + type Exception_Data_Array is array (Natural range <>) + of SSL.Exception_Data_Ptr; + + procedure Get_Registered_Exceptions + (List : out Exception_Data_Array; + Last : out Integer); + -- Return the list of registered exceptions + +end System.Exception_Table; diff --git a/gcc/ada/libgnat/s-exctra.adb b/gcc/ada/libgnat/s-exctra.adb new file mode 100644 index 0000000..e1c8995 --- /dev/null +++ b/gcc/ada/libgnat/s-exctra.adb @@ -0,0 +1,124 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N _ T R A C E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with System.Standard_Library; use System.Standard_Library; +with System.Soft_Links; use System.Soft_Links; + +package body System.Exception_Traces is + + -- Calling the decorator directly from where it is needed would require + -- introducing nasty dependencies upon the spec of this package (typically + -- in a-except.adb). We also have to deal with the fact that the traceback + -- array within an exception occurrence and the one the decorator accepts + -- are of different types. These are two reasons for which a wrapper with + -- a System.Address argument is indeed used to call the decorator provided + -- by the user of this package. This wrapper is called via a soft-link, + -- which either is null when no decorator is in place or "points to" the + -- following function otherwise. + + function Decorator_Wrapper + (Traceback : System.Address; + Len : Natural) return String; + -- The wrapper to be called when a decorator is in place for exception + -- backtraces. + -- + -- Traceback is the address of the call chain array as stored in the + -- exception occurrence and Len is the number of significant addresses + -- contained in this array. + + Current_Decorator : Traceback_Decorator := null; + -- The decorator to be called by the wrapper when it is not null, as set + -- by Set_Trace_Decorator. When this access is null, the wrapper is null + -- also and shall then not be called. + + ----------------------- + -- Decorator_Wrapper -- + ----------------------- + + function Decorator_Wrapper + (Traceback : System.Address; + Len : Natural) return String + is + subtype Trace_Array is Traceback_Entries.Tracebacks_Array (1 .. Len); + type Trace_Array_Access is access all Trace_Array; + + function To_Trace_Array is new + Ada.Unchecked_Conversion (Address, Trace_Array_Access); + + Decorator_Traceback : constant Trace_Array_Access := + To_Trace_Array (Traceback); + + begin + return Current_Decorator.all (Decorator_Traceback.all); + end Decorator_Wrapper; + + ------------------------- + -- Set_Trace_Decorator -- + ------------------------- + + procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is + begin + Current_Decorator := Decorator; + Traceback_Decorator_Wrapper := + (if Current_Decorator /= null + then Decorator_Wrapper'Access else null); + end Set_Trace_Decorator; + + --------------- + -- Trace_Off -- + --------------- + + procedure Trace_Off is + begin + Exception_Trace := RM_Convention; + end Trace_Off; + + -------------- + -- Trace_On -- + -------------- + + procedure Trace_On (Kind : Trace_Kind) is + begin + case Kind is + when Every_Raise => + Exception_Trace := Every_Raise; + + when Unhandled_Raise => + Exception_Trace := Unhandled_Raise; + + when Unhandled_Raise_In_Main => + Exception_Trace := Unhandled_Raise_In_Main; + end case; + end Trace_On; + +end System.Exception_Traces; diff --git a/gcc/ada/libgnat/s-exctra.ads b/gcc/ada/libgnat/s-exctra.ads new file mode 100644 index 0000000..e840f49 --- /dev/null +++ b/gcc/ada/libgnat/s-exctra.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X C E P T I O N _ T R A C E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface allowing to control *automatic* output +-- to standard error upon exception occurrences (as opposed to explicit +-- generation of traceback information using System.Traceback). + +-- This output includes the basic information associated with the exception +-- (name, message) as well as a backtrace of the call chain at the point +-- where the exception occurred. This backtrace is only output if the call +-- chain information is available, depending if the binder switch dedicated +-- to that purpose has been used or not. + +-- The default backtrace is in the form of absolute code locations which may +-- be converted to corresponding source locations using the addr2line utility +-- or from within GDB. Please refer to System.Traceback for information about +-- what is necessary to be able to exploit this possibility. + +-- The backtrace output can also be customized by way of a "decorator" which +-- may return any string output in association with a provided call chain. +-- The decorator replaces the default backtrace mentioned above. + +-- On systems that use DWARF debugging output, then if the "-g" compiler +-- switch and the "-Es" binder switch are used, the decorator is automatically +-- set to Symbolic_Traceback. + +with System.Traceback_Entries; + +package System.Exception_Traces is + + -- The following defines the exact situations in which raises will + -- cause automatic output of trace information. + + type Trace_Kind is + (Every_Raise, + -- Denotes the initial raise event for any exception occurrence, either + -- explicit or due to a specific language rule, within the context of a + -- task or not. + + Unhandled_Raise, + -- Denotes the raise events corresponding to exceptions for which there + -- is no user defined handler. This includes unhandled exceptions in + -- task bodies. + + Unhandled_Raise_In_Main + -- Same as Unhandled_Raise, except exceptions in task bodies are not + -- included. + ); + + -- The following procedures can be used to activate and deactivate + -- traces identified by the above trace kind values. + + procedure Trace_On (Kind : Trace_Kind); + -- Activate the traces denoted by Kind + + procedure Trace_Off; + -- Stop the tracing requested by the last call to Trace_On. + -- Has no effect if no such call has ever occurred. + + -- The following provide the backtrace decorating facilities + + type Traceback_Decorator is access + function (Traceback : Traceback_Entries.Tracebacks_Array) return String; + -- A backtrace decorator is a function which returns the string to be + -- output for a call chain provided by way of a tracebacks array. + + procedure Set_Trace_Decorator (Decorator : Traceback_Decorator); + -- Set the decorator to be used for future automatic outputs. Restore the + -- default behavior if the provided access value is null. + -- + -- Note: System.Traceback.Symbolic.Symbolic_Traceback may be used as the + -- Decorator, to get a symbolic traceback. This will cause a significant + -- cpu and memory overhead on some platforms. + -- + -- Note: The Decorator is called when constructing the + -- Exception_Information; that needs to be taken into account + -- if the Decorator has any side effects. + +end System.Exception_Traces; diff --git a/gcc/ada/libgnat/s-exnint.adb b/gcc/ada/libgnat/s-exnint.adb new file mode 100644 index 0000000..f4dd970 --- /dev/null +++ b/gcc/ada/libgnat/s-exnint.adb @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ I N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exn_Int is + + ----------------- + -- Exn_Integer -- + ----------------- + + function Exn_Integer (Left : Integer; Right : Natural) return Integer is + pragma Suppress (Division_Check); + pragma Suppress (Overflow_Check); + + Result : Integer := 1; + Factor : Integer := Left; + Exp : Natural := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing base values -1, 0, +1 since + -- the expander does this when the base is a literal, and other cases + -- will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; + end Exn_Integer; + +end System.Exn_Int; diff --git a/gcc/ada/libgnat/s-exnint.ads b/gcc/ada/libgnat/s-exnint.ads new file mode 100644 index 0000000..a42648f --- /dev/null +++ b/gcc/ada/libgnat/s-exnint.ads @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ I N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Integer exponentiation (checks off) + +package System.Exn_Int is + pragma Pure; + + function Exn_Integer (Left : Integer; Right : Natural) return Integer; + +end System.Exn_Int; diff --git a/gcc/ada/libgnat/s-exnllf.adb b/gcc/ada/libgnat/s-exnllf.adb new file mode 100644 index 0000000..885fbe1 --- /dev/null +++ b/gcc/ada/libgnat/s-exnllf.adb @@ -0,0 +1,182 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L F -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: the reason for treating exponents in the range 0 .. 4 specially is +-- to ensure identical results to the static inline expansion in the case of +-- a compile time known exponent in this range. The use of Float'Machine and +-- Long_Float'Machine is to avoid unwanted extra precision in the results. + +-- Note that for a negative exponent in Left ** Right, we compute the result +-- as: + +-- 1.0 / (Left ** (-Right)) + +-- Note that the case of Left being zero is not special, it will simply result +-- in a division by zero at the end, yielding a correctly signed infinity, or +-- possibly generating an overflow. + +-- Note on overflow: This coding assumes that the target generates infinities +-- with standard IEEE semantics. If this is not the case, then the code +-- for negative exponent may raise Constraint_Error. This follows the +-- implementation permission given in RM 4.5.6(12). + +package body System.Exn_LLF is + + subtype Negative is Integer range Integer'First .. -1; + + function Exp + (Left : Long_Long_Float; + Right : Natural) return Long_Long_Float; + -- Common routine used if Right is greater or equal to 5 + + --------------- + -- Exn_Float -- + --------------- + + function Exn_Float + (Left : Float; + Right : Integer) return Float + is + Temp : Float; + begin + case Right is + when 0 => + return 1.0; + when 1 => + return Left; + when 2 => + return Float'Machine (Left * Left); + when 3 => + return Float'Machine (Left * Left * Left); + when 4 => + Temp := Float'Machine (Left * Left); + return Float'Machine (Temp * Temp); + when Negative => + return Float'Machine (1.0 / Exn_Float (Left, -Right)); + when others => + return + Float'Machine + (Float (Exp (Long_Long_Float (Left), Right))); + end case; + end Exn_Float; + + -------------------- + -- Exn_Long_Float -- + -------------------- + + function Exn_Long_Float + (Left : Long_Float; + Right : Integer) return Long_Float + is + Temp : Long_Float; + begin + case Right is + when 0 => + return 1.0; + when 1 => + return Left; + when 2 => + return Long_Float'Machine (Left * Left); + when 3 => + return Long_Float'Machine (Left * Left * Left); + when 4 => + Temp := Long_Float'Machine (Left * Left); + return Long_Float'Machine (Temp * Temp); + when Negative => + return Long_Float'Machine (1.0 / Exn_Long_Float (Left, -Right)); + when others => + return + Long_Float'Machine + (Long_Float (Exp (Long_Long_Float (Left), Right))); + end case; + end Exn_Long_Float; + + ------------------------- + -- Exn_Long_Long_Float -- + ------------------------- + + function Exn_Long_Long_Float + (Left : Long_Long_Float; + Right : Integer) return Long_Long_Float + is + Temp : Long_Long_Float; + begin + case Right is + when 0 => + return 1.0; + when 1 => + return Left; + when 2 => + return Left * Left; + when 3 => + return Left * Left * Left; + when 4 => + Temp := Left * Left; + return Temp * Temp; + when Negative => + return 1.0 / Exn_Long_Long_Float (Left, -Right); + when others => + return Exp (Left, Right); + end case; + end Exn_Long_Long_Float; + + --------- + -- Exp -- + --------- + + function Exp + (Left : Long_Long_Float; + Right : Natural) return Long_Long_Float + is + Result : Long_Long_Float := 1.0; + Factor : Long_Long_Float := Left; + Exp : Natural := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. If the low order bit or Exp is + -- set, multiply the result by this factor. + + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + + return Result; + end Exp; + +end System.Exn_LLF; diff --git a/gcc/ada/libgnat/s-exnllf.ads b/gcc/ada/libgnat/s-exnllf.ads new file mode 100644 index 0000000..a58ca74 --- /dev/null +++ b/gcc/ada/libgnat/s-exnllf.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L F -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- [Long_[Long_]]Float exponentiation (checks off) + +package System.Exn_LLF is + pragma Pure; + + function Exn_Float + (Left : Float; + Right : Integer) return Float; + + function Exn_Long_Float + (Left : Long_Float; + Right : Integer) return Long_Float; + + function Exn_Long_Long_Float + (Left : Long_Long_Float; + Right : Integer) return Long_Long_Float; + +end System.Exn_LLF; diff --git a/gcc/ada/libgnat/s-exnlli.adb b/gcc/ada/libgnat/s-exnlli.adb new file mode 100644 index 0000000..701a031 --- /dev/null +++ b/gcc/ada/libgnat/s-exnlli.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exn_LLI is + + --------------------------- + -- Exn_Long_Long_Integer -- + --------------------------- + + function Exn_Long_Long_Integer + (Left : Long_Long_Integer; + Right : Natural) + return Long_Long_Integer + is + pragma Suppress (Division_Check); + pragma Suppress (Overflow_Check); + + Result : Long_Long_Integer := 1; + Factor : Long_Long_Integer := Left; + Exp : Natural := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing base values -1, 0, +1 since + -- the expander does this when the base is a literal, and other cases + -- will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; + end Exn_Long_Long_Integer; + +end System.Exn_LLI; diff --git a/gcc/ada/libgnat/s-exnlli.ads b/gcc/ada/libgnat/s-exnlli.ads new file mode 100644 index 0000000..06b895d --- /dev/null +++ b/gcc/ada/libgnat/s-exnlli.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X N _ L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Integer exponentiation (checks off) + +package System.Exn_LLI is + pragma Pure; + + function Exn_Long_Long_Integer + (Left : Long_Long_Integer; + Right : Natural) + return Long_Long_Integer; + +end System.Exn_LLI; diff --git a/gcc/ada/libgnat/s-expint.adb b/gcc/ada/libgnat/s-expint.adb new file mode 100644 index 0000000..49b98e0 --- /dev/null +++ b/gcc/ada/libgnat/s-expint.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P I N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exp_Int is + + ----------------- + -- Exp_Integer -- + ----------------- + + -- Note that negative exponents get a constraint error because the + -- subtype of the Right argument (the exponent) is Natural. + + function Exp_Integer + (Left : Integer; + Right : Natural) + return Integer + is + Result : Integer := 1; + Factor : Integer := Left; + Exp : Natural := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing base values -1, 0, +1 since + -- the expander does this when the base is a literal, and other cases + -- will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (All_Checks); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + + declare + pragma Unsuppress (All_Checks); + begin + Factor := Factor * Factor; + end; + end loop; + end if; + + return Result; + end Exp_Integer; + +end System.Exp_Int; diff --git a/gcc/ada/libgnat/s-expint.ads b/gcc/ada/libgnat/s-expint.ads new file mode 100644 index 0000000..103325d --- /dev/null +++ b/gcc/ada/libgnat/s-expint.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P I N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Integer exponentiation (checks on) + +package System.Exp_Int is + pragma Pure; + + function Exp_Integer + (Left : Integer; + Right : Natural) + return Integer; + +end System.Exp_Int; diff --git a/gcc/ada/libgnat/s-explli.adb b/gcc/ada/libgnat/s-explli.adb new file mode 100644 index 0000000..4d7dc47 --- /dev/null +++ b/gcc/ada/libgnat/s-explli.adb @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P L L I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exp_LLI is + + --------------------------- + -- Exp_Long_Long_Integer -- + --------------------------- + + -- Note that negative exponents get a constraint error because the + -- subtype of the Right argument (the exponent) is Natural. + + function Exp_Long_Long_Integer + (Left : Long_Long_Integer; + Right : Natural) + return Long_Long_Integer + is + Result : Long_Long_Integer := 1; + Factor : Long_Long_Integer := Left; + Exp : Natural := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing base values -1, 0, +1 since + -- the expander does this when the base is a literal, and other cases + -- will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + declare + pragma Unsuppress (All_Checks); + begin + Result := Result * Factor; + end; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + + declare + pragma Unsuppress (All_Checks); + begin + Factor := Factor * Factor; + end; + end loop; + end if; + + return Result; + end Exp_Long_Long_Integer; + +end System.Exp_LLI; diff --git a/gcc/ada/libgnat/s-explli.ads b/gcc/ada/libgnat/s-explli.ads new file mode 100644 index 0000000..74858ee --- /dev/null +++ b/gcc/ada/libgnat/s-explli.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Long_Long_Integer exponentiation + +package System.Exp_LLI is + pragma Pure; + + function Exp_Long_Long_Integer + (Left : Long_Long_Integer; + Right : Natural) + return Long_Long_Integer; + +end System.Exp_LLI; diff --git a/gcc/ada/libgnat/s-expllu.adb b/gcc/ada/libgnat/s-expllu.adb new file mode 100644 index 0000000..3875806 --- /dev/null +++ b/gcc/ada/libgnat/s-expllu.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . X P _ B M L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Exp_LLU is + + ---------------------------- + -- Exp_Long_Long_Unsigned -- + ---------------------------- + + function Exp_Long_Long_Unsigned + (Left : Long_Long_Unsigned; + Right : Natural) + return Long_Long_Unsigned + is + Result : Long_Long_Unsigned := 1; + Factor : Long_Long_Unsigned := Left; + Exp : Natural := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; + + end Exp_Long_Long_Unsigned; + +end System.Exp_LLU; diff --git a/gcc/ada/libgnat/s-expllu.ads b/gcc/ada/libgnat/s-expllu.ads new file mode 100644 index 0000000..d23bd2b --- /dev/null +++ b/gcc/ada/libgnat/s-expllu.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This function performs exponentiation of unsigned types (with binary +-- modulus values exceeding that of Unsigned_Types.Unsigned). The result +-- is always full width, the caller must do a masking operation if the +-- modulus is less than 2 ** (Long_Long_Unsigned'Size). + +with System.Unsigned_Types; + +package System.Exp_LLU is + pragma Pure; + + function Exp_Long_Long_Unsigned + (Left : System.Unsigned_Types.Long_Long_Unsigned; + Right : Natural) + return System.Unsigned_Types.Long_Long_Unsigned; + +end System.Exp_LLU; diff --git a/gcc/ada/libgnat/s-expmod.adb b/gcc/ada/libgnat/s-expmod.adb new file mode 100644 index 0000000..2c2e857 --- /dev/null +++ b/gcc/ada/libgnat/s-expmod.adb @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ M O D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Exp_Mod is + use System.Unsigned_Types; + + ----------------- + -- Exp_Modular -- + ----------------- + + function Exp_Modular + (Left : Unsigned; + Modulus : Unsigned; + Right : Natural) return Unsigned + is + Result : Unsigned := 1; + Factor : Unsigned := Left; + Exp : Natural := Right; + + function Mult (X, Y : Unsigned) return Unsigned is + (Unsigned (Long_Long_Unsigned (X) * Long_Long_Unsigned (Y) + mod Long_Long_Unsigned (Modulus))); + -- Modular multiplication. Note that we can't take advantage of the + -- compiler's circuit, because the modulus is not known statically. + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Mult (Result, Factor); + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Mult (Factor, Factor); + end loop; + end if; + + return Result; + + end Exp_Modular; + +end System.Exp_Mod; diff --git a/gcc/ada/libgnat/s-expmod.ads b/gcc/ada/libgnat/s-expmod.ads new file mode 100644 index 0000000..49ace2d --- /dev/null +++ b/gcc/ada/libgnat/s-expmod.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ M O D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This function performs exponentiation of a modular type with nonbinary +-- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit +-- accounting for the modulus value which is passed as the second argument. +-- Note that 1 is a binary modulus (2**0), so the compiler should not (and +-- will not) call this function with Modulus equal to 1. + +with System.Unsigned_Types; + +package System.Exp_Mod is + pragma Pure; + use type System.Unsigned_Types.Unsigned; + + subtype Power_Of_2 is System.Unsigned_Types.Unsigned with + Dynamic_Predicate => + Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0; + + function Exp_Modular + (Left : System.Unsigned_Types.Unsigned; + Modulus : System.Unsigned_Types.Unsigned; + Right : Natural) return System.Unsigned_Types.Unsigned + with + Pre => Modulus /= 0 and then Modulus not in Power_Of_2, + Post => Exp_Modular'Result = Left ** Right mod Modulus; + +end System.Exp_Mod; diff --git a/gcc/ada/libgnat/s-expuns.adb b/gcc/ada/libgnat/s-expuns.adb new file mode 100644 index 0000000..ad0c3bd --- /dev/null +++ b/gcc/ada/libgnat/s-expuns.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ U N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Exp_Uns is + + ------------------ + -- Exp_Unsigned -- + ------------------ + + function Exp_Unsigned + (Left : Unsigned; + Right : Natural) + return Unsigned + is + Result : Unsigned := 1; + Factor : Unsigned := Left; + Exp : Natural := Right; + + begin + -- We use the standard logarithmic approach, Exp gets shifted right + -- testing successive low order bits and Factor is the value of the + -- base raised to the next power of 2. + + -- Note: it is not worth special casing the cases of base values -1,0,+1 + -- since the expander does this when the base is a literal, and other + -- cases will be extremely rare. + + if Exp /= 0 then + loop + if Exp rem 2 /= 0 then + Result := Result * Factor; + end if; + + Exp := Exp / 2; + exit when Exp = 0; + Factor := Factor * Factor; + end loop; + end if; + + return Result; + end Exp_Unsigned; + +end System.Exp_Uns; diff --git a/gcc/ada/libgnat/s-expuns.ads b/gcc/ada/libgnat/s-expuns.ads new file mode 100644 index 0000000..b0f3dc3 --- /dev/null +++ b/gcc/ada/libgnat/s-expuns.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . E X P _ U N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This function performs exponentiation of unsigned types (with binary +-- modulus values up to and including that of Unsigned_Types.Unsigned). +-- The result is always full width, the caller must do a masking operation +-- the modulus is less than 2 ** (Unsigned'Size). + +with System.Unsigned_Types; + +package System.Exp_Uns is + pragma Pure; + + function Exp_Unsigned + (Left : System.Unsigned_Types.Unsigned; + Right : Natural) + return System.Unsigned_Types.Unsigned; + +end System.Exp_Uns; diff --git a/gcc/ada/libgnat/s-fatflt.ads b/gcc/ada/libgnat/s-fatflt.ads new file mode 100644 index 0000000..d6e0818 --- /dev/null +++ b/gcc/ada/libgnat/s-fatflt.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ F L T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains an instantiation of the floating-point attribute +-- runtime routines for the type Float. + +with System.Fat_Gen; + +package System.Fat_Flt is + pragma Pure; + + -- Note the only entity from this package that is accessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Attr_Float is new System.Fat_Gen (Float); + +end System.Fat_Flt; diff --git a/gcc/ada/libgnat/s-fatgen.adb b/gcc/ada/libgnat/s-fatgen.adb new file mode 100644 index 0000000..fdb34f2 --- /dev/null +++ b/gcc/ada/libgnat/s-fatgen.adb @@ -0,0 +1,931 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ G E N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- The implementation here is portable to any IEEE implementation. It does +-- not handle nonbinary radix, and also assumes that model numbers and +-- machine numbers are basically identical, which is not true of all possible +-- floating-point implementations. On a non-IEEE machine, this body must be +-- specialized appropriately, or better still, its generic instantiations +-- should be replaced by efficient machine-specific code. + +with Ada.Unchecked_Conversion; +with System; +package body System.Fat_Gen is + + Float_Radix : constant T := T (T'Machine_Radix); + Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1); + + pragma Assert (T'Machine_Radix = 2); + -- This version does not handle radix 16 + + -- Constants for Decompose and Scaling + + Rad : constant T := T (T'Machine_Radix); + Invrad : constant T := 1.0 / Rad; + + subtype Expbits is Integer range 0 .. 6; + -- 2 ** (2 ** 7) might overflow. How big can radix-16 exponents get? + + Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64); + + R_Power : constant array (Expbits) of T := + (Rad ** 1, + Rad ** 2, + Rad ** 4, + Rad ** 8, + Rad ** 16, + Rad ** 32, + Rad ** 64); + + R_Neg_Power : constant array (Expbits) of T := + (Invrad ** 1, + Invrad ** 2, + Invrad ** 4, + Invrad ** 8, + Invrad ** 16, + Invrad ** 32, + Invrad ** 64); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Decompose (XX : T; Frac : out T; Expo : out UI); + -- Decomposes a floating-point number into fraction and exponent parts. + -- Both results are signed, with Frac having the sign of XX, and UI has + -- the sign of the exponent. The absolute value of Frac is in the range + -- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero. + + function Gradual_Scaling (Adjustment : UI) return T; + -- Like Scaling with a first argument of 1.0, but returns the smallest + -- denormal rather than zero when the adjustment is smaller than + -- Machine_Emin. Used for Succ and Pred. + + -------------- + -- Adjacent -- + -------------- + + function Adjacent (X, Towards : T) return T is + begin + if Towards = X then + return X; + elsif Towards > X then + return Succ (X); + else + return Pred (X); + end if; + end Adjacent; + + ------------- + -- Ceiling -- + ------------- + + function Ceiling (X : T) return T is + XT : constant T := Truncation (X); + begin + if X <= 0.0 then + return XT; + elsif X = XT then + return X; + else + return XT + 1.0; + end if; + end Ceiling; + + ------------- + -- Compose -- + ------------- + + function Compose (Fraction : T; Exponent : UI) return T is + Arg_Frac : T; + Arg_Exp : UI; + pragma Unreferenced (Arg_Exp); + begin + Decompose (Fraction, Arg_Frac, Arg_Exp); + return Scaling (Arg_Frac, Exponent); + end Compose; + + --------------- + -- Copy_Sign -- + --------------- + + function Copy_Sign (Value, Sign : T) return T is + Result : T; + + function Is_Negative (V : T) return Boolean; + pragma Import (Intrinsic, Is_Negative); + + begin + Result := abs Value; + + if Is_Negative (Sign) then + return -Result; + else + return Result; + end if; + end Copy_Sign; + + --------------- + -- Decompose -- + --------------- + + procedure Decompose (XX : T; Frac : out T; Expo : out UI) is + X : constant T := T'Machine (XX); + + begin + if X = 0.0 then + + -- The normalized exponent of zero is zero, see RM A.5.2(15) + + Frac := X; + Expo := 0; + + -- Check for infinities, transfinites, whatnot + + elsif X > T'Safe_Last then + Frac := Invrad; + Expo := T'Machine_Emax + 1; + + elsif X < T'Safe_First then + Frac := -Invrad; + Expo := T'Machine_Emax + 2; -- how many extra negative values? + + else + -- Case of nonzero finite x. Essentially, we just multiply + -- by Rad ** (+-2**N) to reduce the range. + + declare + Ax : T := abs X; + Ex : UI := 0; + + -- Ax * Rad ** Ex is invariant + + begin + if Ax >= 1.0 then + while Ax >= R_Power (Expbits'Last) loop + Ax := Ax * R_Neg_Power (Expbits'Last); + Ex := Ex + Log_Power (Expbits'Last); + end loop; + + -- Ax < Rad ** 64 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ax >= R_Power (N) then + Ax := Ax * R_Neg_Power (N); + Ex := Ex + Log_Power (N); + end if; + + -- Ax < R_Power (N) + + end loop; + + -- 1 <= Ax < Rad + + Ax := Ax * Invrad; + Ex := Ex + 1; + + else + -- 0 < ax < 1 + + while Ax < R_Neg_Power (Expbits'Last) loop + Ax := Ax * R_Power (Expbits'Last); + Ex := Ex - Log_Power (Expbits'Last); + end loop; + + -- Rad ** -64 <= Ax < 1 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ax < R_Neg_Power (N) then + Ax := Ax * R_Power (N); + Ex := Ex - Log_Power (N); + end if; + + -- R_Neg_Power (N) <= Ax < 1 + + end loop; + end if; + + Frac := (if X > 0.0 then Ax else -Ax); + Expo := Ex; + end; + end if; + end Decompose; + + -------------- + -- Exponent -- + -------------- + + function Exponent (X : T) return UI is + X_Frac : T; + X_Exp : UI; + pragma Unreferenced (X_Frac); + begin + Decompose (X, X_Frac, X_Exp); + return X_Exp; + end Exponent; + + ----------- + -- Floor -- + ----------- + + function Floor (X : T) return T is + XT : constant T := Truncation (X); + begin + if X >= 0.0 then + return XT; + elsif XT = X then + return X; + else + return XT - 1.0; + end if; + end Floor; + + -------------- + -- Fraction -- + -------------- + + function Fraction (X : T) return T is + X_Frac : T; + X_Exp : UI; + pragma Unreferenced (X_Exp); + begin + Decompose (X, X_Frac, X_Exp); + return X_Frac; + end Fraction; + + --------------------- + -- Gradual_Scaling -- + --------------------- + + function Gradual_Scaling (Adjustment : UI) return T is + Y : T; + Y1 : T; + Ex : UI := Adjustment; + + begin + if Adjustment < T'Machine_Emin - 1 then + Y := 2.0 ** T'Machine_Emin; + Y1 := Y; + Ex := Ex - T'Machine_Emin; + while Ex < 0 loop + Y := T'Machine (Y / 2.0); + + if Y = 0.0 then + return Y1; + end if; + + Ex := Ex + 1; + Y1 := Y; + end loop; + + return Y1; + + else + return Scaling (1.0, Adjustment); + end if; + end Gradual_Scaling; + + ------------------ + -- Leading_Part -- + ------------------ + + function Leading_Part (X : T; Radix_Digits : UI) return T is + L : UI; + Y, Z : T; + + begin + if Radix_Digits >= T'Machine_Mantissa then + return X; + + elsif Radix_Digits <= 0 then + raise Constraint_Error; + + else + L := Exponent (X) - Radix_Digits; + Y := Truncation (Scaling (X, -L)); + Z := Scaling (Y, L); + return Z; + end if; + end Leading_Part; + + ------------- + -- Machine -- + ------------- + + -- The trick with Machine is to force the compiler to store the result + -- in memory so that we do not have extra precision used. The compiler + -- is clever, so we have to outwit its possible optimizations. We do + -- this by using an intermediate pragma Volatile location. + + function Machine (X : T) return T is + Temp : T; + pragma Volatile (Temp); + begin + Temp := X; + return Temp; + end Machine; + + ---------------------- + -- Machine_Rounding -- + ---------------------- + + -- For now, the implementation is identical to that of Rounding, which is + -- a permissible behavior, but is not the most efficient possible approach. + + function Machine_Rounding (X : T) return T is + Result : T; + Tail : T; + + begin + Result := Truncation (abs X); + Tail := abs X - Result; + + if Tail >= 0.5 then + Result := Result + 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end Machine_Rounding; + + ----------- + -- Model -- + ----------- + + -- We treat Model as identical to Machine. This is true of IEEE and other + -- nice floating-point systems, but not necessarily true of all systems. + + function Model (X : T) return T is + begin + return Machine (X); + end Model; + + ---------- + -- Pred -- + ---------- + + function Pred (X : T) return T is + X_Frac : T; + X_Exp : UI; + + begin + -- Zero has to be treated specially, since its exponent is zero + + if X = 0.0 then + return -Succ (X); + + -- Special treatment for most negative number + + elsif X = T'First then + + -- If not generating infinities, we raise a constraint error + + if T'Machine_Overflows then + raise Constraint_Error with "Pred of largest negative number"; + + -- Otherwise generate a negative infinity + + else + return X / (X - X); + end if; + + -- For infinities, return unchanged + + elsif X < T'First or else X > T'Last then + return X; + + -- Subtract from the given number a number equivalent to the value + -- of its least significant bit. Given that the most significant bit + -- represents a value of 1.0 * radix ** (exp - 1), the value we want + -- is obtained by shifting this by (mantissa-1) bits to the right, + -- i.e. decreasing the exponent by that amount. + + else + Decompose (X, X_Frac, X_Exp); + + -- A special case, if the number we had was a positive power of + -- two, then we want to subtract half of what we would otherwise + -- subtract, since the exponent is going to be reduced. + + -- Note that X_Frac has the same sign as X, so if X_Frac is 0.5, + -- then we know that we have a positive number (and hence a + -- positive power of 2). + + if X_Frac = 0.5 then + return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); + + -- Otherwise the exponent is unchanged + + else + return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa); + end if; + end if; + end Pred; + + --------------- + -- Remainder -- + --------------- + + function Remainder (X, Y : T) return T is + A : T; + B : T; + Arg : T; + P : T; + P_Frac : T; + Sign_X : T; + IEEE_Rem : T; + Arg_Exp : UI; + P_Exp : UI; + K : UI; + P_Even : Boolean; + + Arg_Frac : T; + pragma Unreferenced (Arg_Frac); + + begin + if Y = 0.0 then + raise Constraint_Error; + end if; + + if X > 0.0 then + Sign_X := 1.0; + Arg := X; + else + Sign_X := -1.0; + Arg := -X; + end if; + + P := abs Y; + + if Arg < P then + P_Even := True; + IEEE_Rem := Arg; + P_Exp := Exponent (P); + + else + Decompose (Arg, Arg_Frac, Arg_Exp); + Decompose (P, P_Frac, P_Exp); + + P := Compose (P_Frac, Arg_Exp); + K := Arg_Exp - P_Exp; + P_Even := True; + IEEE_Rem := Arg; + + for Cnt in reverse 0 .. K loop + if IEEE_Rem >= P then + P_Even := False; + IEEE_Rem := IEEE_Rem - P; + else + P_Even := True; + end if; + + P := P * 0.5; + end loop; + end if; + + -- That completes the calculation of modulus remainder. The final + -- step is get the IEEE remainder. Here we need to compare Rem with + -- (abs Y) / 2. We must be careful of unrepresentable Y/2 value + -- caused by subnormal numbers + + if P_Exp >= 0 then + A := IEEE_Rem; + B := abs Y * 0.5; + + else + A := IEEE_Rem * 2.0; + B := abs Y; + end if; + + if A > B or else (A = B and then not P_Even) then + IEEE_Rem := IEEE_Rem - abs Y; + end if; + + return Sign_X * IEEE_Rem; + end Remainder; + + -------------- + -- Rounding -- + -------------- + + function Rounding (X : T) return T is + Result : T; + Tail : T; + + begin + Result := Truncation (abs X); + Tail := abs X - Result; + + if Tail >= 0.5 then + Result := Result + 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end Rounding; + + ------------- + -- Scaling -- + ------------- + + -- Return x * rad ** adjustment quickly, or quietly underflow to zero, + -- or overflow naturally. + + function Scaling (X : T; Adjustment : UI) return T is + begin + if X = 0.0 or else Adjustment = 0 then + return X; + end if; + + -- Nonzero x essentially, just multiply repeatedly by Rad ** (+-2**n) + + declare + Y : T := X; + Ex : UI := Adjustment; + + -- Y * Rad ** Ex is invariant + + begin + if Ex < 0 then + while Ex <= -Log_Power (Expbits'Last) loop + Y := Y * R_Neg_Power (Expbits'Last); + Ex := Ex + Log_Power (Expbits'Last); + end loop; + + -- -64 < Ex <= 0 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ex <= -Log_Power (N) then + Y := Y * R_Neg_Power (N); + Ex := Ex + Log_Power (N); + end if; + + -- -Log_Power (N) < Ex <= 0 + + end loop; + + -- Ex = 0 + + else + -- Ex >= 0 + + while Ex >= Log_Power (Expbits'Last) loop + Y := Y * R_Power (Expbits'Last); + Ex := Ex - Log_Power (Expbits'Last); + end loop; + + -- 0 <= Ex < 64 + + for N in reverse Expbits'First .. Expbits'Last - 1 loop + if Ex >= Log_Power (N) then + Y := Y * R_Power (N); + Ex := Ex - Log_Power (N); + end if; + + -- 0 <= Ex < Log_Power (N) + + end loop; + + -- Ex = 0 + + end if; + + return Y; + end; + end Scaling; + + ---------- + -- Succ -- + ---------- + + function Succ (X : T) return T is + X_Frac : T; + X_Exp : UI; + X1, X2 : T; + + begin + -- Treat zero specially since it has a zero exponent + + if X = 0.0 then + X1 := 2.0 ** T'Machine_Emin; + + -- Following loop generates smallest denormal + + loop + X2 := T'Machine (X1 / 2.0); + exit when X2 = 0.0; + X1 := X2; + end loop; + + return X1; + + -- Special treatment for largest positive number + + elsif X = T'Last then + + -- If not generating infinities, we raise a constraint error + + if T'Machine_Overflows then + raise Constraint_Error with "Succ of largest negative number"; + + -- Otherwise generate a positive infinity + + else + return X / (X - X); + end if; + + -- For infinities, return unchanged + + elsif X < T'First or else X > T'Last then + return X; + + -- Add to the given number a number equivalent to the value + -- of its least significant bit. Given that the most significant bit + -- represents a value of 1.0 * radix ** (exp - 1), the value we want + -- is obtained by shifting this by (mantissa-1) bits to the right, + -- i.e. decreasing the exponent by that amount. + + else + Decompose (X, X_Frac, X_Exp); + + -- A special case, if the number we had was a negative power of two, + -- then we want to add half of what we would otherwise add, since the + -- exponent is going to be reduced. + + -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, + -- then we know that we have a negative number (and hence a negative + -- power of 2). + + if X_Frac = -0.5 then + return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); + + -- Otherwise the exponent is unchanged + + else + return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa); + end if; + end if; + end Succ; + + ---------------- + -- Truncation -- + ---------------- + + -- The basic approach is to compute + + -- T'Machine (RM1 + N) - RM1 + + -- where N >= 0.0 and RM1 = radix ** (mantissa - 1) + + -- This works provided that the intermediate result (RM1 + N) does not + -- have extra precision (which is why we call Machine). When we compute + -- RM1 + N, the exponent of N will be normalized and the mantissa shifted + -- appropriately so the lower order bits, which cannot contribute to the + -- integer part of N, fall off on the right. When we subtract RM1 again, + -- the significant bits of N are shifted to the left, and what we have is + -- an integer, because only the first e bits are different from zero + -- (assuming binary radix here). + + function Truncation (X : T) return T is + Result : T; + + begin + Result := abs X; + + if Result >= Radix_To_M_Minus_1 then + return Machine (X); + + else + Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1; + + if Result > abs X then + Result := Result - 1.0; + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end if; + end Truncation; + + ----------------------- + -- Unbiased_Rounding -- + ----------------------- + + function Unbiased_Rounding (X : T) return T is + Abs_X : constant T := abs X; + Result : T; + Tail : T; + + begin + Result := Truncation (Abs_X); + Tail := Abs_X - Result; + + if Tail > 0.5 then + Result := Result + 1.0; + + elsif Tail = 0.5 then + Result := 2.0 * Truncation ((Result / 2.0) + 0.5); + end if; + + if X > 0.0 then + return Result; + + elsif X < 0.0 then + return -Result; + + -- For zero case, make sure sign of zero is preserved + + else + return X; + end if; + end Unbiased_Rounding; + + ----------- + -- Valid -- + ----------- + + function Valid (X : not null access T) return Boolean is + IEEE_Emin : constant Integer := T'Machine_Emin - 1; + IEEE_Emax : constant Integer := T'Machine_Emax - 1; + + IEEE_Bias : constant Integer := -(IEEE_Emin - 1); + + subtype IEEE_Exponent_Range is + Integer range IEEE_Emin - 1 .. IEEE_Emax + 1; + + -- The implementation of this floating point attribute uses a + -- representation type Float_Rep that allows direct access to the + -- exponent and mantissa parts of a floating point number. + + -- The Float_Rep type is an array of Float_Word elements. This + -- representation is chosen to make it possible to size the type based + -- on a generic parameter. Since the array size is known at compile + -- time, efficient code can still be generated. The size of Float_Word + -- elements should be large enough to allow accessing the exponent in + -- one read, but small enough so that all floating point object sizes + -- are a multiple of the Float_Word'Size. + + -- The following conditions must be met for all possible instantiations + -- of the attributes package: + + -- - T'Size is an integral multiple of Float_Word'Size + + -- - The exponent and sign are completely contained in a single + -- component of Float_Rep, named Most_Significant_Word (MSW). + + -- - The sign occupies the most significant bit of the MSW and the + -- exponent is in the following bits. Unused bits (if any) are in + -- the least significant part. + + type Float_Word is mod 2**Positive'Min (System.Word_Size, 32); + type Rep_Index is range 0 .. 7; + + Rep_Words : constant Positive := + (T'Size + Float_Word'Size - 1) / Float_Word'Size; + Rep_Last : constant Rep_Index := + Rep_Index'Min + (Rep_Index (Rep_Words - 1), + (T'Mantissa + 16) / Float_Word'Size); + -- Determine the number of Float_Words needed for representing the + -- entire floating-point value. Do not take into account excessive + -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 + -- bits. In general, the exponent field cannot be larger than 15 bits, + -- even for 128-bit floating-point types, so the final format size + -- won't be larger than T'Mantissa + 16. + + type Float_Rep is + array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word; + + pragma Suppress_Initialization (Float_Rep); + -- This pragma suppresses the generation of an initialization procedure + -- for type Float_Rep when operating in Initialize/Normalize_Scalars + -- mode. This is not just a matter of efficiency, but of functionality, + -- since Valid has a pragma Inline_Always, which is not permitted if + -- there are nested subprograms present. + + Most_Significant_Word : constant Rep_Index := + Rep_Last * Standard'Default_Bit_Order; + -- Finding the location of the Exponent_Word is a bit tricky. In general + -- we assume Word_Order = Bit_Order. + + Exponent_Factor : constant Float_Word := + 2**(Float_Word'Size - 1) / + Float_Word (IEEE_Emax - IEEE_Emin + 3) * + Boolean'Pos (Most_Significant_Word /= 2) + + Boolean'Pos (Most_Significant_Word = 2); + -- Factor that the extracted exponent needs to be divided by to be in + -- range 0 .. IEEE_Emax - IEEE_Emin + 2. Special case: Exponent_Factor + -- is 1 for x86/IA64 double extended (GCC adds unused bits to the type). + + Exponent_Mask : constant Float_Word := + Float_Word (IEEE_Emax - IEEE_Emin + 2) * + Exponent_Factor; + -- Value needed to mask out the exponent field. This assumes that the + -- range IEEE_Emin - 1 .. IEEE_Emax + contains 2**N values, for some N + -- in Natural. + + function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T); + + type Float_Access is access all T; + function To_Address is + new Ada.Unchecked_Conversion (Float_Access, System.Address); + + XA : constant System.Address := To_Address (Float_Access (X)); + + R : Float_Rep; + pragma Import (Ada, R); + for R'Address use XA; + -- R is a view of the input floating-point parameter. Note that we + -- must avoid copying the actual bits of this parameter in float + -- form (since it may be a signalling NaN). + + E : constant IEEE_Exponent_Range := + Integer ((R (Most_Significant_Word) and Exponent_Mask) / + Exponent_Factor) + - IEEE_Bias; + -- Mask/Shift T to only get bits from the exponent. Then convert biased + -- value to integer value. + + SR : Float_Rep; + -- Float_Rep representation of significant of X.all + + begin + if T'Denorm then + + -- All denormalized numbers are valid, so the only invalid numbers + -- are overflows and NaNs, both with exponent = Emax + 1. + + return E /= IEEE_Emax + 1; + + end if; + + -- All denormalized numbers except 0.0 are invalid + + -- Set exponent of X to zero, so we end up with the significand, which + -- definitely is a valid number and can be converted back to a float. + + SR := R; + SR (Most_Significant_Word) := + (SR (Most_Significant_Word) + and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor; + + return (E in IEEE_Emin .. IEEE_Emax) or else + ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0); + end Valid; + +end System.Fat_Gen; diff --git a/gcc/ada/libgnat/s-fatgen.ads b/gcc/ada/libgnat/s-fatgen.ads new file mode 100644 index 0000000..b9f3790 --- /dev/null +++ b/gcc/ada/libgnat/s-fatgen.ads @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ G E N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This generic package provides a target independent implementation of the +-- floating-point attributes that denote functions. The implementations here +-- are portable, but very slow. The runtime contains a set of instantiations +-- of this package for all predefined floating-point types, and these should +-- be replaced by efficient assembly language code where possible. + +generic + type T is digits <>; + +package System.Fat_Gen is + pragma Pure; + + subtype UI is Integer; + -- The runtime representation of universal integer for the purposes of + -- this package is integer. The expander generates conversions for the + -- actual type used. For functions returning universal integer, there + -- is no problem, since the result always is in range of integer. For + -- input arguments, the expander has to do some special casing to deal + -- with the (very annoying) cases of out of range values. If we used + -- Long_Long_Integer to represent universal, then there would be no + -- problem, but the resulting inefficiency would be annoying. + + function Adjacent (X, Towards : T) return T; + + function Ceiling (X : T) return T; + + function Compose (Fraction : T; Exponent : UI) return T; + + function Copy_Sign (Value, Sign : T) return T; + + function Exponent (X : T) return UI; + + function Floor (X : T) return T; + + function Fraction (X : T) return T; + + function Leading_Part (X : T; Radix_Digits : UI) return T; + + function Machine (X : T) return T; + + function Machine_Rounding (X : T) return T; + + function Model (X : T) return T; + + function Pred (X : T) return T; + + function Remainder (X, Y : T) return T; + + function Rounding (X : T) return T; + + function Scaling (X : T; Adjustment : UI) return T; + + function Succ (X : T) return T; + + function Truncation (X : T) return T; + + function Unbiased_Rounding (X : T) return T; + + function Valid (X : not null access T) return Boolean; + -- This function checks if the object of type T referenced by X is valid, + -- and returns True/False accordingly. The parameter is passed by reference + -- (access) here, as the object of type T may be an abnormal value that + -- cannot be passed in a floating-point register, and the whole point of + -- 'Valid is to prevent exceptions. Note that the object of type T must + -- have the natural alignment for type T. + + type S is new String (1 .. T'Size / Character'Size); + type P is access all S with Storage_Size => 0; + -- Buffer and access types used to initialize temporaries for validity + -- checks, if the value to be checked has reverse scalar storage order, or + -- is not known to be properly aligned (for example it appears in a packed + -- record). In this case, we cannot call Valid since Valid assumes proper + -- full alignment. Instead, we copy the value to a temporary location using + -- type S (we cannot simply do a copy of a T value, because the value might + -- be invalid, in which case it might not be possible to copy it through a + -- floating point register). + +private + pragma Inline (Machine); + pragma Inline (Model); + + -- Note: previously the validity checking subprograms (Unaligned_Valid and + -- Valid) were also inlined, but this was changed since there were some + -- problems with this inlining in optimized mode, and in any case it seems + -- better to avoid this inlining (space and robustness considerations). + +end System.Fat_Gen; diff --git a/gcc/ada/libgnat/s-fatlfl.ads b/gcc/ada/libgnat/s-fatlfl.ads new file mode 100644 index 0000000..4cdce24 --- /dev/null +++ b/gcc/ada/libgnat/s-fatlfl.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ L F L T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains an instantiation of the floating-point attribute +-- runtime routines for the type Long_Float. + +with System.Fat_Gen; + +package System.Fat_LFlt is + pragma Pure; + + -- Note the only entity from this package that is accessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Attr_Long_Float is new System.Fat_Gen (Long_Float); + +end System.Fat_LFlt; diff --git a/gcc/ada/libgnat/s-fatllf.ads b/gcc/ada/libgnat/s-fatllf.ads new file mode 100644 index 0000000..46ab4ec --- /dev/null +++ b/gcc/ada/libgnat/s-fatllf.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ L L F -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains an instantiation of the floating-point attribute +-- runtime routines for the type Long_Long_Float. + +with System.Fat_Gen; + +package System.Fat_LLF is + pragma Pure; + + -- Note the only entity from this package that is accessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Attr_Long_Long_Float is new System.Fat_Gen (Long_Long_Float); + +end System.Fat_LLF; diff --git a/gcc/ada/libgnat/s-fatsfl.ads b/gcc/ada/libgnat/s-fatsfl.ads new file mode 100644 index 0000000..c863a13 --- /dev/null +++ b/gcc/ada/libgnat/s-fatsfl.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F A T _ S F L T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains an instantiation of the floating-point attribute +-- runtime routines for the type Short_Float. + +with System.Fat_Gen; + +package System.Fat_SFlt is + pragma Pure; + + -- Note the only entity from this package that is accessed by Rtsfind + -- is the name of the package instantiation. Entities within this package + -- (i.e. the individual floating-point attribute routines) are accessed + -- by name using selected notation. + + package Attr_Short_Float is new System.Fat_Gen (Short_Float); + +end System.Fat_SFlt; diff --git a/gcc/ada/libgnat/s-ficobl.ads b/gcc/ada/libgnat/s-ficobl.ads new file mode 100644 index 0000000..abe894c --- /dev/null +++ b/gcc/ada/libgnat/s-ficobl.ads @@ -0,0 +1,159 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ C O N T R O L _ B L O C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the declaration of the basic file control block +-- shared between Text_IO, Sequential_IO, Direct_IO and Streams.Stream_IO. +-- The actual control blocks are derived from this block by extension. The +-- control block is itself derived from Ada.Streams.Root_Stream_Type which +-- facilitates implementation of Stream_IO.Stream and Text_Streams.Stream. + +with Ada.Streams; +with Interfaces.C_Streams; +with System.CRTL; + +package System.File_Control_Block is + pragma Preelaborate; + + ---------------------------- + -- Ada File Control Block -- + ---------------------------- + + -- The Ada file control block is an abstract extension of the root + -- stream type. This allows a file to be treated directly as a stream + -- for the purposes of Stream_IO, or stream operations on a text file. + -- The individual I/O packages extend this type with package specific + -- fields to create the concrete types to which the routines in this + -- package can be applied. + + -- The type File_Type in the individual packages is an access to the + -- extended file control block. The value is null if the file is not + -- open, and a pointer to the control block if the file is open. + + type Pstring is access all String; + -- Used to hold name and form strings + + type File_Mode is (In_File, Inout_File, Out_File, Append_File); + subtype Read_File_Mode is File_Mode range In_File .. Inout_File; + -- File mode (union of file modes permitted by individual packages, + -- the types File_Mode in the individual packages are declared to + -- allow easy conversion to and from this general type. + + type Shared_Status_Type is (Yes, No, None); + -- This type is used to define the sharing status of a file. The default + -- setting of None is used if no "shared=xxx" appears in the form string + -- when a file is created or opened. For a file with Shared_Status set to + -- None, Use_Error will be raised if any other file is opened or created + -- with the same full name. Yes/No are set in response to the presence + -- of "shared=yes" or "shared=no" in the form string. In either case it + -- is permissible to have multiple files opened with the same full name. + -- All files opened simultaneously with "shared=yes" will share the same + -- stream with the semantics specified in the RM for file sharing. All + -- files opened with "shared=no" will have their own stream. + + type AFCB is tagged; + type AFCB_Ptr is access all AFCB'Class; + + type AFCB is abstract new Ada.Streams.Root_Stream_Type with record + + Stream : Interfaces.C_Streams.FILEs; + -- The file descriptor + + Name : Pstring; + -- A pointer to the file name. The file name is null for temporary + -- files, and also for standard files (stdin, stdout, stderr). The + -- name is always NUL-terminated if it is non-null. + + Encoding : System.CRTL.Filename_Encoding; + -- Encoding used to specified the filename + + Form : Pstring; + -- A pointer to the form string. This is the string used in the + -- fopen call, and must be supplied by the caller (there are no + -- defaults at this level). The string is always null-terminated. + + Mode : File_Mode; + -- The file mode. No checks are made that the mode is consistent + -- with the form used to fopen the file. + + Is_Regular_File : Boolean; + -- A flag indicating if the file is a regular file + + Is_Temporary_File : Boolean; + -- A flag set only for temporary files (i.e. files created using the + -- Create function with a null name parameter). + + Is_System_File : Boolean; + -- A flag set only for system files (stdin, stdout, stderr) + + Text_Encoding : Interfaces.C_Streams.Content_Encoding; + -- A flag set to describe file content encoding + + Shared_Status : Shared_Status_Type; + -- Indicates sharing status of file, see description of type above + + Access_Method : Character; + -- Set to 'Q', 'S', 'T', 'D' for Sequential_IO, Stream_IO, Text_IO, + -- Direct_IO file (used to validate file sharing request). + + Next : AFCB_Ptr; + Prev : AFCB_Ptr; + -- All open files are kept on a doubly linked chain, with these + -- pointers used to maintain the next and previous pointers. + + end record; + + ---------------------------------- + -- Primitive Operations of AFCB -- + ---------------------------------- + + -- Note that we inherit the abstract operations Read and Write from + -- the base type. These must be overridden by the individual file + -- access methods to provide Stream Read/Write access. + + function AFCB_Allocate (Control_Block : AFCB) return AFCB_Ptr is abstract; + -- Given a control block, allocate space for a control block of the same + -- type on the heap, and return the pointer to this allocated block. Note + -- that the argument Control_Block is not used other than as the argument + -- that controls which version of AFCB_Allocate is called. + + procedure AFCB_Close (File : not null access AFCB) is abstract; + -- Performs any specialized close actions on a file before the file is + -- actually closed at the system level. This is called by Close, and + -- the reason we need the primitive operation is for the automatic + -- close operations done as part of finalization. + + procedure AFCB_Free (File : not null access AFCB) is abstract; + -- Frees the AFCB referenced by the given parameter. It is not necessary + -- to free the strings referenced by the Form and Name fields, but if the + -- extension has any other heap objects, they must be freed as well. This + -- procedure must be overridden by each individual file package. + +end System.File_Control_Block; diff --git a/gcc/ada/libgnat/s-filatt.ads b/gcc/ada/libgnat/s-filatt.ads new file mode 100644 index 0000000..9cfc55a --- /dev/null +++ b/gcc/ada/libgnat/s-filatt.ads @@ -0,0 +1,71 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ A T T R I B U T E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 binding to the GNAT file attribute query functions + +with System.OS_Constants; +with System.Storage_Elements; + +package System.File_Attributes is + + type File_Attributes is private; + + procedure Reset_Attributes (A : access File_Attributes); + + function Error_Attributes (A : access File_Attributes) return Integer; + + function File_Exists_Attr + (N : System.Address; + A : access File_Attributes) return Integer; + + function Is_Regular_File_Attr + (N : System.Address; + A : access File_Attributes) return Integer; + + function Is_Directory_Attr + (N : System.Address; + A : access File_Attributes) return Integer; + +private + package SOSC renames System.OS_Constants; + + type File_Attributes is new + System.Storage_Elements.Storage_Array + (1 .. SOSC.SIZEOF_struct_file_attributes); + for File_Attributes'Alignment use Standard'Maximum_Alignment; + + pragma Import (C, Reset_Attributes, "__gnat_reset_attributes"); + pragma Import (C, Error_Attributes, "__gnat_error_attributes"); + pragma Import (C, File_Exists_Attr, "__gnat_file_exists_attr"); + pragma Import (C, Is_Regular_File_Attr, "__gnat_is_regular_file_attr"); + pragma Import (C, Is_Directory_Attr, "__gnat_is_directory_attr"); + +end System.File_Attributes; diff --git a/gcc/ada/libgnat/s-fileio.adb b/gcc/ada/libgnat/s-fileio.adb new file mode 100644 index 0000000..c8b44bd --- /dev/null +++ b/gcc/ada/libgnat/s-fileio.adb @@ -0,0 +1,1322 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; use Ada.Finalization; +with Ada.IO_Exceptions; use Ada.IO_Exceptions; +with Ada.Unchecked_Deallocation; + +with Interfaces.C_Streams; use Interfaces.C_Streams; + +with System.Case_Util; use System.Case_Util; +with System.CRTL; +with System.OS_Lib; +with System.Soft_Links; + +package body System.File_IO is + + use System.File_Control_Block; + + package SSL renames System.Soft_Links; + + use type CRTL.size_t; + + ---------------------- + -- Global Variables -- + ---------------------- + + Open_Files : AFCB_Ptr; + -- This points to a list of AFCB's for all open files. This is a doubly + -- linked list, with the Prev pointer of the first entry, and the Next + -- pointer of the last entry containing null. Note that this global + -- variable must be properly protected to provide thread safety. + + type Temp_File_Record; + type Temp_File_Record_Ptr is access all Temp_File_Record; + + type Temp_File_Record is record + File : AFCB_Ptr; + Next : aliased Temp_File_Record_Ptr; + Name : String (1 .. max_path_len + 1); + end record; + -- One of these is allocated for each temporary file created + + Temp_Files : aliased Temp_File_Record_Ptr; + -- Points to list of names of temporary files. Note that this global + -- variable must be properly protected to provide thread safety. + + procedure Free is new Ada.Unchecked_Deallocation + (Temp_File_Record, Temp_File_Record_Ptr); + + type File_IO_Clean_Up_Type is new Limited_Controlled with null record; + -- The closing of all open files and deletion of temporary files is an + -- action that takes place at the end of execution of the main program. + -- This action is implemented using a library level object that gets + -- finalized at the end of program execution. Note that the type is + -- limited, in order to stop the compiler optimizing away the declaration + -- which would be allowed in the non-limited case. + + procedure Finalize (V : in out File_IO_Clean_Up_Type); + -- This is the finalize operation that is used to do the cleanup + + File_IO_Clean_Up_Object : File_IO_Clean_Up_Type; + pragma Warnings (Off, File_IO_Clean_Up_Object); + -- This is the single object of the type that triggers the finalization + -- call. Since it is at the library level, this happens just before the + -- environment task is finalized. + + text_translation_required : Boolean; + for text_translation_required'Size use Character'Size; + pragma Import + (C, text_translation_required, "__gnat_text_translation_required"); + -- If true, add appropriate suffix to control string for Open + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring); + + subtype Fopen_String is String (1 .. 4); + -- Holds open string (longest is "w+b" & nul) + + procedure Fopen_Mode + (Namestr : String; + Mode : File_Mode; + Text : Boolean; + Creat : Boolean; + Amethod : Character; + Fopstr : out Fopen_String); + -- Determines proper open mode for a file to be opened in the given Ada + -- mode. Namestr is the NUL-terminated file name. Text is true for a text + -- file and false otherwise, and Creat is true for a create call, and False + -- for an open call. The value stored in Fopstr is a nul-terminated string + -- suitable for a call to fopen or freopen. Amethod is the character + -- designating the access method from the Access_Method field of the FCB. + + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String; + -- Return Errno_Message for Errno, with file name prepended + + procedure Raise_Device_Error + (File : AFCB_Ptr; + Errno : Integer := OS_Lib.Errno); + pragma No_Return (Raise_Device_Error); + -- Clear error indication on File and raise Device_Error with an exception + -- message providing errno information. + + ---------------- + -- Append_Set -- + ---------------- + + procedure Append_Set (File : AFCB_Ptr) is + begin + if File.Mode = Append_File then + if fseek (File.Stream, 0, SEEK_END) /= 0 then + Raise_Device_Error (File); + end if; + end if; + end Append_Set; + + ---------------- + -- Chain_File -- + ---------------- + + procedure Chain_File (File : AFCB_Ptr) is + begin + -- Take a task lock, to protect the global data value Open_Files + + SSL.Lock_Task.all; + + -- Do the chaining operation locked + + File.Next := Open_Files; + File.Prev := null; + Open_Files := File; + + if File.Next /= null then + File.Next.Prev := File; + end if; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Chain_File; + + --------------------- + -- Check_File_Open -- + --------------------- + + procedure Check_File_Open (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error with "file not open"; + end if; + end Check_File_Open; + + ----------------------- + -- Check_Read_Status -- + ----------------------- + + procedure Check_Read_Status (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error with "file not open"; + elsif File.Mode not in Read_File_Mode then + raise Mode_Error with "file not readable"; + end if; + end Check_Read_Status; + + ------------------------ + -- Check_Write_Status -- + ------------------------ + + procedure Check_Write_Status (File : AFCB_Ptr) is + begin + if File = null then + raise Status_Error with "file not open"; + elsif File.Mode = In_File then + raise Mode_Error with "file not writable"; + end if; + end Check_Write_Status; + + ----------- + -- Close -- + ----------- + + procedure Close (File_Ptr : access AFCB_Ptr) is + Close_Status : int := 0; + Dup_Strm : Boolean := False; + Errno : Integer := 0; + + File : AFCB_Ptr renames File_Ptr.all; + + begin + -- Take a task lock, to protect the global variables Open_Files and + -- Temp_Files, and the chains they point to. + + SSL.Lock_Task.all; + + Check_File_Open (File); + AFCB_Close (File); + + -- Sever the association between the given file and its associated + -- external file. The given file is left closed. Do not perform system + -- closes on the standard input, output and error files and also do not + -- attempt to close a stream that does not exist (signalled by a null + -- stream value -- happens in some error situations). + + if not File.Is_System_File and then File.Stream /= NULL_Stream then + + -- Do not do an fclose if this is a shared file and there is at least + -- one other instance of the stream that is open. + + if File.Shared_Status = Yes then + declare + P : AFCB_Ptr; + + begin + P := Open_Files; + while P /= null loop + if P /= File and then File.Stream = P.Stream then + Dup_Strm := True; + exit; + end if; + + P := P.Next; + end loop; + end; + end if; + + -- Do the fclose unless this was a duplicate in the shared case + + if not Dup_Strm then + Close_Status := fclose (File.Stream); + + if Close_Status /= 0 then + Errno := OS_Lib.Errno; + end if; + end if; + end if; + + -- Dechain file from list of open files and then free the storage + + if File.Prev = null then + Open_Files := File.Next; + else + File.Prev.Next := File.Next; + end if; + + if File.Next /= null then + File.Next.Prev := File.Prev; + end if; + + -- If it's a temp file, remove the corresponding record from Temp_Files, + -- and delete the file. There are unlikely to be large numbers of temp + -- files open, so a linear search is sufficiently efficient. Note that + -- we don't need to check for end of list, because the file must be + -- somewhere on the list. Note that as for Finalize, we ignore any + -- errors while attempting the unlink operation. + + if File.Is_Temporary_File then + declare + Temp : access Temp_File_Record_Ptr := Temp_Files'Access; + -- Note the double indirection here + + Discard : int; + New_Temp : Temp_File_Record_Ptr; + + begin + while Temp.all.all.File /= File loop + Temp := Temp.all.all.Next'Access; + end loop; + + Discard := unlink (Temp.all.all.Name'Address); + New_Temp := Temp.all.all.Next; + Free (Temp.all); + Temp.all := New_Temp; + end; + end if; + + -- Deallocate some parts of the file structure that were kept in heap + -- storage with the exception of system files (standard input, output + -- and error) since they had some information allocated in the stack. + + if not File.Is_System_File then + Free_String (File.Name); + Free_String (File.Form); + AFCB_Free (File); + end if; + + File := null; + + if Close_Status /= 0 then + Raise_Device_Error (null, Errno); + end if; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Close; + + ------------ + -- Delete -- + ------------ + + procedure Delete (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; + + begin + Check_File_Open (File); + + if not File.Is_Regular_File then + raise Use_Error with "cannot delete non-regular file"; + end if; + + declare + Filename : aliased constant String := File.Name.all; + Is_Temporary_File : constant Boolean := File.Is_Temporary_File; + + begin + Close (File_Ptr); + + -- Now unlink the external file. Note that we use the full name in + -- this unlink, because the working directory may have changed since + -- we did the open, and we want to unlink the right file. However, if + -- it's a temporary file, then closing it already unlinked it. + + if not Is_Temporary_File then + if unlink (Filename'Address) = -1 then + raise Use_Error with OS_Lib.Errno_Message; + end if; + end if; + end; + end Delete; + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File (File : AFCB_Ptr) return Boolean is + begin + Check_File_Open (File); + + if feof (File.Stream) /= 0 then + return True; + + else + Check_Read_Status (File); + + if ungetc (fgetc (File.Stream), File.Stream) = EOF then + clearerr (File.Stream); + return True; + else + return False; + end if; + end if; + end End_Of_File; + + ------------------- + -- Errno_Message -- + ------------------- + + function Errno_Message + (Name : String; + Errno : Integer := OS_Lib.Errno) return String + is + begin + return Name & ": " & OS_Lib.Errno_Message (Err => Errno); + end Errno_Message; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (V : in out File_IO_Clean_Up_Type) is + pragma Warnings (Off, V); + + Fptr1 : aliased AFCB_Ptr; + Fptr2 : AFCB_Ptr; + + Discard : int; + + begin + -- Take a lock to protect global Open_Files data structure + + SSL.Lock_Task.all; + + -- First close all open files (the slightly complex form of this loop is + -- required because Close nulls out its argument). + + Fptr1 := Open_Files; + while Fptr1 /= null loop + Fptr2 := Fptr1.Next; + Close (Fptr1'Access); + Fptr1 := Fptr2; + end loop; + + -- Now unlink all temporary files. We do not bother to free the blocks + -- because we are just about to terminate the program. We also ignore + -- any errors while attempting these unlink operations. + + while Temp_Files /= null loop + Discard := unlink (Temp_Files.Name'Address); + Temp_Files := Temp_Files.Next; + end loop; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Finalize; + + ----------- + -- Flush -- + ----------- + + procedure Flush (File : AFCB_Ptr) is + begin + Check_Write_Status (File); + + if fflush (File.Stream) /= 0 then + Raise_Device_Error (File); + end if; + end Flush; + + ---------------- + -- Fopen_Mode -- + ---------------- + + -- The fopen mode to be used is shown by the following table: + + -- OPEN CREATE + -- Append_File "r+" "w+" + -- In_File "r" "w+" + -- Out_File (Direct_IO, Stream_IO) "r+" [*] "w" + -- Out_File (others) "w" "w" + -- Inout_File "r+" "w+" + + -- [*] Except that for Out_File, if the file exists and is a fifo (i.e. a + -- named pipe), we use "w" instead of "r+". This is necessary to make a + -- write to the fifo block until a reader is ready. + + -- Note: we do not use "a" or "a+" for Append_File, since this would not + -- work in the case of stream files, where even if in append file mode, + -- you can reset to earlier points in the file. The caller must use the + -- Append_Set routine to deal with the necessary positioning. + + -- Note: in several cases, the fopen mode used allows reading and writing, + -- but the setting of the Ada mode is more restrictive. For instance, + -- Create in In_File mode uses "w+" which allows writing, but the Ada mode + -- In_File will cause any write operations to be rejected with Mode_Error + -- in any case. + + -- Note: for the Out_File/Open cases for other than the Direct_IO case, an + -- initial call will be made by the caller to first open the file in "r" + -- mode to be sure that it exists. The real open, in "w" mode, will then + -- destroy this file. This is peculiar, but that's what Ada semantics + -- require and the ACATS tests insist on. + + -- If text file translation is required, then either "b" or "t" is appended + -- to the mode, depending on the setting of Text. + + procedure Fopen_Mode + (Namestr : String; + Mode : File_Mode; + Text : Boolean; + Creat : Boolean; + Amethod : Character; + Fopstr : out Fopen_String) + is + Fptr : Positive; + + function is_fifo (Path : Address) return Integer; + pragma Import (C, is_fifo, "__gnat_is_fifo"); + + begin + case Mode is + when In_File => + if Creat then + Fopstr (1) := 'w'; + Fopstr (2) := '+'; + Fptr := 3; + else + Fopstr (1) := 'r'; + Fptr := 2; + end if; + + when Out_File => + if Amethod in 'D' | 'S' + and then not Creat + and then is_fifo (Namestr'Address) = 0 + then + Fopstr (1) := 'r'; + Fopstr (2) := '+'; + Fptr := 3; + else + Fopstr (1) := 'w'; + Fptr := 2; + end if; + + when Append_File + | Inout_File + => + Fopstr (1) := (if Creat then 'w' else 'r'); + Fopstr (2) := '+'; + Fptr := 3; + end case; + + -- If text_translation_required is true then we need to append either a + -- "t" or "b" to the string to get the right mode. + + if text_translation_required then + Fopstr (Fptr) := (if Text then 't' else 'b'); + Fptr := Fptr + 1; + end if; + + Fopstr (Fptr) := ASCII.NUL; + end Fopen_Mode; + + ---------- + -- Form -- + ---------- + + function Form (File : AFCB_Ptr) return String is + begin + if File = null then + raise Status_Error with "Form: file not open"; + else + return File.Form.all (1 .. File.Form'Length - 1); + end if; + end Form; + + ------------------ + -- Form_Boolean -- + ------------------ + + function Form_Boolean + (Form : String; + Keyword : String; + Default : Boolean) return Boolean + is + V1, V2 : Natural; + pragma Unreferenced (V2); + + begin + Form_Parameter (Form, Keyword, V1, V2); + + if V1 = 0 then + return Default; + elsif Form (V1) = 'y' then + return True; + elsif Form (V1) = 'n' then + return False; + else + raise Use_Error with "invalid Form"; + end if; + end Form_Boolean; + + ------------------ + -- Form_Integer -- + ------------------ + + function Form_Integer + (Form : String; + Keyword : String; + Default : Integer) return Integer + is + V1, V2 : Natural; + V : Integer; + + begin + Form_Parameter (Form, Keyword, V1, V2); + + if V1 = 0 then + return Default; + + else + V := 0; + + for J in V1 .. V2 loop + if Form (J) not in '0' .. '9' then + raise Use_Error with "invalid Form"; + else + V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0'); + end if; + + if V > 999_999 then + raise Use_Error with "invalid Form"; + end if; + end loop; + + return V; + end if; + end Form_Integer; + + -------------------- + -- Form_Parameter -- + -------------------- + + procedure Form_Parameter + (Form : String; + Keyword : String; + Start : out Natural; + Stop : out Natural) + is + Klen : constant Integer := Keyword'Length; + + begin + for J in Form'First + Klen .. Form'Last - 1 loop + if Form (J) = '=' + and then Form (J - Klen .. J - 1) = Keyword + then + Start := J + 1; + Stop := Start - 1; + while Form (Stop + 1) /= ASCII.NUL + and then Form (Stop + 1) /= ',' + loop + Stop := Stop + 1; + end loop; + + return; + end if; + end loop; + + Start := 0; + Stop := 0; + end Form_Parameter; + + ------------- + -- Is_Open -- + ------------- + + function Is_Open (File : AFCB_Ptr) return Boolean is + begin + -- We return True if the file is open, and the underlying file stream is + -- usable. In particular on Windows an application linked with -mwindows + -- option set does not have a console attached. In this case standard + -- files (Current_Output, Current_Error, Current_Input) are not created. + -- We want Is_Open (Current_Output) to return False in this case. + + return File /= null and then fileno (File.Stream) /= -1; + end Is_Open; + + ------------------- + -- Make_Buffered -- + ------------------- + + procedure Make_Buffered + (File : AFCB_Ptr; + Buf_Siz : Interfaces.C_Streams.size_t) + is + status : Integer; + pragma Unreferenced (status); + + begin + status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz); + end Make_Buffered; + + ------------------------ + -- Make_Line_Buffered -- + ------------------------ + + procedure Make_Line_Buffered + (File : AFCB_Ptr; + Line_Siz : Interfaces.C_Streams.size_t) + is + status : Integer; + pragma Unreferenced (status); + + begin + status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); + -- No error checking??? + end Make_Line_Buffered; + + --------------------- + -- Make_Unbuffered -- + --------------------- + + procedure Make_Unbuffered (File : AFCB_Ptr) is + status : Integer; + pragma Unreferenced (status); + + begin + status := setvbuf (File.Stream, Null_Address, IONBF, 0); + -- No error checking??? + end Make_Unbuffered; + + ---------- + -- Mode -- + ---------- + + function Mode (File : AFCB_Ptr) return File_Mode is + begin + if File = null then + raise Status_Error with "Mode: file not open"; + else + return File.Mode; + end if; + end Mode; + + ---------- + -- Name -- + ---------- + + function Name (File : AFCB_Ptr) return String is + begin + if File = null then + raise Status_Error with "Name: file not open"; + else + return File.Name.all (1 .. File.Name'Length - 1); + end if; + end Name; + + ---------- + -- Open -- + ---------- + + procedure Open + (File_Ptr : in out AFCB_Ptr; + Dummy_FCB : AFCB'Class; + Mode : File_Mode; + Name : String; + Form : String; + Amethod : Character; + Creat : Boolean; + Text : Boolean; + C_Stream : FILEs := NULL_Stream) + is + pragma Warnings (Off, Dummy_FCB); + -- Yes we know this is never assigned a value. That's intended, since + -- all we ever use of this value is the tag for dispatching purposes. + + procedure Tmp_Name (Buffer : Address); + pragma Import (C, Tmp_Name, "__gnat_tmp_name"); + -- Set buffer (a String address) with a temporary filename + + function Get_Case_Sensitive return Integer; + pragma Import (C, Get_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + procedure Record_AFCB; + -- Create and record new AFCB into the runtime, note that the + -- implementation uses the variables below which corresponds to the + -- status of the opened file. + + File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; + -- Set to indicate whether the operating system convention is for file + -- names to be case sensitive (e.g., in Unix, set True), or not case + -- sensitive (e.g., in Windows, set False). Declared locally to avoid + -- breaking the Preelaborate rule that disallows function calls at the + -- library level. + + Stream : FILEs := C_Stream; + -- Stream which we open in response to this request + + Shared : Shared_Status_Type; + -- Setting of Shared_Status field for file + + Fopstr : aliased Fopen_String; + -- Mode string used in fopen call + + Formstr : aliased String (1 .. Form'Length + 1); + -- Form string with ASCII.NUL appended, folded to lower case + + Text_Encoding : Content_Encoding; + + Tempfile : constant Boolean := Name = ""; + -- Indicates temporary file case, which is indicated by an empty file + -- name. + + Namelen : constant Integer := max_path_len; + -- Length required for file name, not including final ASCII.NUL. + -- Note that we used to reference L_tmpnam here, which is not reliable + -- since __gnat_tmp_name does not always use tmpnam. + + Namestr : aliased String (1 .. Namelen + 1); + -- Name as given or temporary file name with ASCII.NUL appended + + Fullname : aliased String (1 .. max_path_len + 1); + -- Full name (as required for Name function, and as stored in the + -- control block in the Name field) with ASCII.NUL appended. + + Full_Name_Len : Integer; + -- Length of name actually stored in Fullname + + Encoding : CRTL.Filename_Encoding; + -- Filename encoding specified into the form parameter + + ----------------- + -- Record_AFCB -- + ----------------- + + procedure Record_AFCB is + begin + File_Ptr := AFCB_Allocate (Dummy_FCB); + + -- Note that we cannot use an aggregate here as File_Ptr is a + -- class-wide access to a limited type (Root_Stream_Type). + + File_Ptr.Is_Regular_File := is_regular_file (fileno (Stream)) /= 0; + File_Ptr.Is_System_File := False; + File_Ptr.Text_Encoding := Text_Encoding; + File_Ptr.Shared_Status := Shared; + File_Ptr.Access_Method := Amethod; + File_Ptr.Stream := Stream; + File_Ptr.Form := new String'(Formstr); + File_Ptr.Name := new String'(Fullname + (1 .. Full_Name_Len)); + File_Ptr.Mode := Mode; + File_Ptr.Is_Temporary_File := Tempfile; + File_Ptr.Encoding := Encoding; + + Chain_File (File_Ptr); + Append_Set (File_Ptr); + end Record_AFCB; + + -- Start of processing for Open + + begin + if File_Ptr /= null then + raise Status_Error with "file already open"; + end if; + + -- Acquire form string, setting required NUL terminator + + Formstr (1 .. Form'Length) := Form; + Formstr (Formstr'Last) := ASCII.NUL; + + -- Convert form string to lower case + + for J in Formstr'Range loop + if Formstr (J) in 'A' .. 'Z' then + Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32); + end if; + end loop; + + -- Acquire setting of shared parameter + + declare + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "shared", V1, V2); + + if V1 = 0 then + Shared := None; + elsif Formstr (V1 .. V2) = "yes" then + Shared := Yes; + elsif Formstr (V1 .. V2) = "no" then + Shared := No; + else + raise Use_Error with "invalid Form"; + end if; + end; + + -- Acquire setting of encoding parameter + + declare + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "encoding", V1, V2); + + if V1 = 0 then + Encoding := CRTL.Unspecified; + elsif Formstr (V1 .. V2) = "utf8" then + Encoding := CRTL.UTF8; + elsif Formstr (V1 .. V2) = "8bits" then + Encoding := CRTL.ASCII_8bits; + else + raise Use_Error with "invalid Form"; + end if; + end; + + -- Acquire setting of text_translation parameter. Only needed if this is + -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but + -- if the Form says Text_Translation=No, we use binary mode, so new-line + -- will be just LF, even on Windows. + + if Text then + Text_Encoding := Default_Text; + else + Text_Encoding := None; + end if; + + if Text_Encoding in Text_Content_Encoding then + declare + V1, V2 : Natural; + + begin + Form_Parameter (Formstr, "text_translation", V1, V2); + + if V1 = 0 then + null; + elsif Formstr (V1 .. V2) = "no" then + Text_Encoding := None; + elsif Formstr (V1 .. V2) = "text" + or else Formstr (V1 .. V2) = "yes" + then + Text_Encoding := Interfaces.C_Streams.Text; + elsif Formstr (V1 .. V2) = "wtext" then + Text_Encoding := Wtext; + elsif Formstr (V1 .. V2) = "u8text" then + Text_Encoding := U8text; + elsif Formstr (V1 .. V2) = "u16text" then + Text_Encoding := U16text; + else + raise Use_Error with "invalid Form"; + end if; + end; + end if; + + -- If we were given a stream (call from xxx.C_Streams.Open), then set + -- the full name to the given one, and skip to end of processing. + + if Stream /= NULL_Stream then + Full_Name_Len := Name'Length + 1; + Fullname (1 .. Full_Name_Len - 1) := Name; + Fullname (Full_Name_Len) := ASCII.NUL; + + -- Normal case of Open or Create + + else + -- If temporary file case, get temporary file name and add to the + -- list of temporary files to be deleted on exit. + + if Tempfile then + if not Creat then + raise Name_Error with "opening temp file without creating it"; + end if; + + Tmp_Name (Namestr'Address); + + if Namestr (1) = ASCII.NUL then + raise Use_Error with "invalid temp file name"; + end if; + + -- Normal case of non-empty name given (i.e. not a temp file) + + else + if Name'Length > Namelen then + raise Name_Error with "file name too long"; + end if; + + Namestr (1 .. Name'Length) := Name; + Namestr (Name'Length + 1) := ASCII.NUL; + end if; + + -- Get full name in accordance with the advice of RM A.8.2(22) + + full_name (Namestr'Address, Fullname'Address); + + if Fullname (1) = ASCII.NUL then + raise Use_Error with Errno_Message (Name); + end if; + + Full_Name_Len := 1; + while Full_Name_Len < Fullname'Last + and then Fullname (Full_Name_Len) /= ASCII.NUL + loop + Full_Name_Len := Full_Name_Len + 1; + end loop; + + -- Fullname is generated by calling system's full_name. The problem + -- is, full_name does nothing about the casing, so a file name + -- comparison may generally speaking not be valid on non-case- + -- sensitive systems, and in particular we get unexpected failures + -- on Windows/Vista because of this. So we use s-casuti to force + -- the name to lower case. + + if not File_Names_Case_Sensitive then + To_Lower (Fullname (1 .. Full_Name_Len)); + end if; + + -- If Shared=None or Shared=Yes, then check for the existence of + -- another file with exactly the same full name. + + if Shared /= No then + declare + P : AFCB_Ptr; + + begin + -- Take a task lock to protect Open_Files + + SSL.Lock_Task.all; + + -- Search list of open files + + P := Open_Files; + while P /= null loop + if Fullname (1 .. Full_Name_Len) = P.Name.all then + + -- If we get a match, and either file has Shared=None, + -- then raise Use_Error, since we don't allow two files + -- of the same name to be opened unless they specify the + -- required sharing mode. + + if Shared = None + or else P.Shared_Status = None + then + raise Use_Error with "reopening shared file"; + + -- If both files have Shared=Yes, then we acquire the + -- stream from the located file to use as our stream. + + elsif Shared = Yes + and then P.Shared_Status = Yes + then + Stream := P.Stream; + + Record_AFCB; + pragma Assert (not Tempfile); + + exit; + + -- Otherwise one of the files has Shared=Yes and one has + -- Shared=No. If the current file has Shared=No then all + -- is well but we don't want to share any other file's + -- stream. If the current file has Shared=Yes, we would + -- like to share a stream, but not from a file that has + -- Shared=No, so either way, we just continue the search. + + else + null; + end if; + end if; + + P := P.Next; + end loop; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end; + end if; + + -- Open specified file if we did not find an existing stream, + -- otherwise we just return as there is nothing more to be done. + + if Stream /= NULL_Stream then + return; + + else + Fopen_Mode + (Namestr => Namestr, + Mode => Mode, + Text => Text_Encoding in Text_Content_Encoding, + Creat => Creat, + Amethod => Amethod, + Fopstr => Fopstr); + + -- A special case, if we are opening (OPEN case) a file and the + -- mode returned by Fopen_Mode is not "r" or "r+", then we first + -- make sure that the file exists as required by Ada semantics. + + if not Creat and then Fopstr (1) /= 'r' then + if file_exists (Namestr'Address) = 0 then + raise Name_Error with Errno_Message (Name); + end if; + end if; + + -- Now open the file. Note that we use the name as given in the + -- original Open call for this purpose, since that seems the + -- clearest implementation of the intent. It would presumably + -- work to use the full name here, but if there is any difference, + -- then we should use the name used in the call. + + -- Note: for a corresponding delete, we will use the full name, + -- since by the time of the delete, the current working directory + -- may have changed and we do not want to delete a different file. + + Stream := + fopen (Namestr'Address, Fopstr'Address, Encoding); + + if Stream = NULL_Stream then + + -- Raise Name_Error if trying to open a non-existent file. + -- Otherwise raise Use_Error. + + -- Should we raise Device_Error for ENOSPC??? + + declare + function Is_File_Not_Found_Error + (Errno_Value : Integer) return Integer; + pragma Import + (C, Is_File_Not_Found_Error, + "__gnat_is_file_not_found_error"); + -- Non-zero when the given errno value indicates a non- + -- existing file. + + Errno : constant Integer := OS_Lib.Errno; + Message : constant String := Errno_Message (Name, Errno); + + begin + if Is_File_Not_Found_Error (Errno) /= 0 then + raise Name_Error with Message; + else + raise Use_Error with Message; + end if; + end; + end if; + end if; + end if; + + -- Stream has been successfully located or opened, so now we are + -- committed to completing the opening of the file. Allocate block on + -- heap and fill in its fields. + + Record_AFCB; + + if Tempfile then + -- Chain to temp file list, ensuring thread safety with a lock + + begin + SSL.Lock_Task.all; + Temp_Files := + new Temp_File_Record' + (File => File_Ptr, Name => Namestr, Next => Temp_Files); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end; + end if; + end Open; + + ------------------------ + -- Raise_Device_Error -- + ------------------------ + + procedure Raise_Device_Error + (File : AFCB_Ptr; + Errno : Integer := OS_Lib.Errno) + is + begin + -- Clear error status so that the same error is not reported twice + + if File /= null then + clearerr (File.Stream); + end if; + + raise Device_Error with OS_Lib.Errno_Message (Err => Errno); + end Raise_Device_Error; + + -------------- + -- Read_Buf -- + -------------- + + procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is + Nread : size_t; + + begin + Nread := fread (Buf, 1, Siz, File.Stream); + + if Nread = Siz then + return; + + elsif ferror (File.Stream) /= 0 then + Raise_Device_Error (File); + + elsif Nread = 0 then + raise End_Error; + + else -- 0 < Nread < Siz + raise Data_Error with "not enough data read"; + end if; + end Read_Buf; + + procedure Read_Buf + (File : AFCB_Ptr; + Buf : Address; + Siz : Interfaces.C_Streams.size_t; + Count : out Interfaces.C_Streams.size_t) + is + begin + Count := fread (Buf, 1, Siz, File.Stream); + + if Count = 0 and then ferror (File.Stream) /= 0 then + Raise_Device_Error (File); + end if; + end Read_Buf; + + ----------- + -- Reset -- + ----------- + + -- The reset which does not change the mode simply does a rewind + + procedure Reset (File_Ptr : access AFCB_Ptr) is + File : AFCB_Ptr renames File_Ptr.all; + begin + Check_File_Open (File); + Reset (File_Ptr, File.Mode); + end Reset; + + -- The reset with a change in mode is done using freopen, and is not + -- permitted except for regular files (since otherwise there is no name for + -- the freopen, and in any case it seems meaningless). + + procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is + File : AFCB_Ptr renames File_Ptr.all; + Fopstr : aliased Fopen_String; + + begin + Check_File_Open (File); + + -- Change of mode not allowed for shared file or file with no name or + -- file that is not a regular file, or for a system file. Note that we + -- allow the "change" of mode if it is not in fact doing a change. + + if Mode /= File.Mode then + if File.Shared_Status = Yes then + raise Use_Error with "cannot change mode of shared file"; + elsif File.Name'Length <= 1 then + raise Use_Error with "cannot change mode of temp file"; + elsif File.Is_System_File then + raise Use_Error with "cannot change mode of system file"; + elsif not File.Is_Regular_File then + raise Use_Error with "cannot change mode of non-regular file"; + end if; + end if; + + -- For In_File or Inout_File for a regular file, we can just do a rewind + -- if the mode is unchanged, which is more efficient than doing a full + -- reopen. + + if Mode = File.Mode + and then Mode in Read_File_Mode + then + rewind (File.Stream); + + -- Here the change of mode is permitted, we do it by reopening the file + -- in the new mode and replacing the stream with a new stream. + + else + Fopen_Mode + (Namestr => File.Name.all, + Mode => Mode, + Text => File.Text_Encoding in Text_Content_Encoding, + Creat => False, + Amethod => File.Access_Method, + Fopstr => Fopstr); + + File.Stream := freopen + (File.Name.all'Address, Fopstr'Address, File.Stream, + File.Encoding); + + if File.Stream = NULL_Stream then + Close (File_Ptr); + raise Use_Error; + else + File.Mode := Mode; + Append_Set (File); + end if; + end if; + end Reset; + + --------------- + -- Write_Buf -- + --------------- + + procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is + begin + -- Note: for most purposes, the Siz and 1 parameters in the fwrite call + -- could be reversed, but we have encountered systems where this is a + -- better choice, since for some file formats, reversing the parameters + -- results in records of one byte each. + + SSL.Abort_Defer.all; + + if fwrite (Buf, Siz, 1, File.Stream) /= 1 then + if Siz /= 0 then + SSL.Abort_Undefer.all; + Raise_Device_Error (File); + end if; + end if; + + SSL.Abort_Undefer.all; + end Write_Buf; + +end System.File_IO; diff --git a/gcc/ada/libgnat/s-fileio.ads b/gcc/ada/libgnat/s-fileio.ads new file mode 100644 index 0000000..bcd2e6c --- /dev/null +++ b/gcc/ada/libgnat/s-fileio.ads @@ -0,0 +1,255 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F I L E _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides support for the routines described in (RM A.8.2) +-- which are common to Text_IO, Direct_IO, Sequential_IO and Stream_IO. + +with Interfaces.C_Streams; + +with System.File_Control_Block; + +package System.File_IO is + pragma Preelaborate; + + package FCB renames System.File_Control_Block; + package ICS renames Interfaces.C_Streams; + + --------------------- + -- File Management -- + --------------------- + + procedure Open + (File_Ptr : in out FCB.AFCB_Ptr; + Dummy_FCB : FCB.AFCB'Class; + Mode : FCB.File_Mode; + Name : String; + Form : String; + Amethod : Character; + Creat : Boolean; + Text : Boolean; + C_Stream : ICS.FILEs := ICS.NULL_Stream); + -- This routine is used for both Open and Create calls: + -- + -- File_Ptr is the file type, which must be null on entry + -- (i.e. the file must be closed before the call). + -- + -- Dummy_FCB is a default initialized file control block of appropriate + -- type. Note that the tag of this record indicates the type and length + -- of the control block. This control block is used only for the purpose + -- of providing the controlling argument for calling the write version + -- of Allocate_AFCB. It has no other purpose, and its fields are never + -- read or written. + -- + -- Mode is the required mode + -- + -- Name is the file name, with a null string indicating that a temporary + -- file is to be created (only permitted in create mode, not open mode). + -- + -- Creat is True for a create call, and false for an open call + -- + -- Text is set True to open the file in text mode (w+t or r+t) instead + -- of the usual binary mode open (w+b or r+b). + -- + -- Form is the form string given in the open or create call, this is + -- stored in the AFCB. + -- + -- Amethod indicates the access method: + -- + -- D = Direct_IO + -- Q = Sequential_IO + -- S = Stream_IO + -- T = Text_IO + -- W = Wide_Text_IO + -- ??? Wide_Wide_Text_IO ??? + -- + -- C_Stream is left at its default value for the normal case of an + -- Open or Create call as defined in the RM. The only time this is + -- non-null is for the Open call from Ada.xxx_IO.C_Streams.Open. + -- + -- On return, if the open/create succeeds, then the fields of File are + -- filled in, and this value is copied to the heap. File_Ptr points to + -- this allocated file control block. If the open/create fails, then the + -- fields of File are undefined, and File_Ptr is unchanged. + + procedure Close (File_Ptr : access FCB.AFCB_Ptr); + -- The file is closed, all storage associated with it is released, and + -- File is set to null. Note that this routine calls AFCB_Close to perform + -- any specialized close actions, then closes the file at the system level, + -- then frees the mode and form strings, and finally calls AFCB_Free to + -- free the file control block itself, setting File.all to null. Note that + -- for this assignment to be done in all cases, including those where + -- an exception is raised, we can't use an IN OUT parameter (which would + -- not be copied back in case of abnormal return). + + procedure Delete (File_Ptr : access FCB.AFCB_Ptr); + -- The indicated file is unlinked + + procedure Reset (File_Ptr : access FCB.AFCB_Ptr; Mode : FCB.File_Mode); + -- The file is reset, and the mode changed as indicated + + procedure Reset (File_Ptr : access FCB.AFCB_Ptr); + -- The files is reset, and the mode is unchanged + + function Mode (File : FCB.AFCB_Ptr) return FCB.File_Mode; + -- Returns the mode as supplied by create, open or reset + + function Name (File : FCB.AFCB_Ptr) return String; + -- Returns the file name as supplied by Open or Create. Raises Use_Error + -- if used with temporary files or standard files. + + function Form (File : FCB.AFCB_Ptr) return String; + -- Returns the form as supplied by create, open or reset The string is + -- normalized to all lower case letters. + + function Is_Open (File : FCB.AFCB_Ptr) return Boolean; + -- Determines if file is open or not + + ---------------------- + -- Utility Routines -- + ---------------------- + + -- Some internal routines not defined in A.8.2. These are routines which + -- provide required common functionality shared by separate packages. + + procedure Chain_File (File : FCB.AFCB_Ptr); + -- Used to chain the given file into the list of open files. Normally this + -- is done implicitly by Open. Chain_File is used for the special cases of + -- the system files defined by Text_IO (stdin, stdout, stderr) which are + -- not opened in the normal manner. Note that the caller is responsible + -- for task lock out to protect the global data structures if this is + -- necessary (it is needed for the calls from within this unit itself, + -- but not required for the calls from Text_IO and [Wide_]Wide_Text_IO + -- that are made during elaboration of the environment task). + + procedure Check_File_Open (File : FCB.AFCB_Ptr); + -- If the current file is not open, then Status_Error is raised. Otherwise + -- control returns normally (with File pointing to the control block for + -- the open file. + + procedure Check_Read_Status (File : FCB.AFCB_Ptr); + -- If the current file is not open, then Status_Error is raised. If the + -- file is open, then the mode is checked to make sure that reading is + -- permitted, and if not Mode_Error is raised, otherwise control returns + -- normally. + + procedure Check_Write_Status (File : FCB.AFCB_Ptr); + -- If the current file is not open, then Status_Error is raised. If the + -- file is open, then the mode is checked to ensure that writing is + -- permitted, and if not Mode_Error is raised, otherwise control returns + -- normally. + + function End_Of_File (File : FCB.AFCB_Ptr) return Boolean; + -- File must be opened in read mode. True is returned if the stream is + -- currently positioned at the end of file, otherwise False is returned. + -- The position of the stream is not affected. + + procedure Flush (File : FCB.AFCB_Ptr); + -- Flushes the stream associated with the given file. The file must be open + -- and in write mode (if not, an appropriate exception is raised) + + function Form_Boolean + (Form : String; + Keyword : String; + Default : Boolean) return Boolean; + -- Searches form string for an entry of the form keyword=xx where xx is + -- either yes/no or y/n. Returns True if yes or y is found, False if no or + -- n is found. If the keyword parameter is not found, returns the value + -- given as Default. May raise Use_Error if a form string syntax error is + -- detected. Keyword and Form must be in lower case. + + function Form_Integer + (Form : String; + Keyword : String; + Default : Integer) return Integer; + -- Searches form string for an entry of the form Keyword=xx where xx is an + -- unsigned decimal integer in the range 0 to 999_999. Returns this integer + -- value if it is found. If the keyword parameter is not found, returns the + -- value given as Default. Raise Use_Error if a form string syntax error is + -- detected. Keyword and Form must be in lower case. + + procedure Form_Parameter + (Form : String; + Keyword : String; + Start : out Natural; + Stop : out Natural); + -- Searches form string for an entry of the form Keyword=xx and if found + -- Sets Start and Stop to the first and last characters of xx. Keyword + -- and Form must be in lower case. If no entry matches, then Start and + -- Stop are set to zero on return. Use_Error is raised if a malformed + -- string is detected, but there is no guarantee of full syntax checking. + + procedure Read_Buf + (File : FCB.AFCB_Ptr; + Buf : Address; + Siz : Interfaces.C_Streams.size_t); + -- Reads Siz bytes from File.Stream into Buf. The caller has checked + -- that the file is open in read mode. Raises an exception if Siz bytes + -- cannot be read (End_Error if no data was read, Data_Error if a partial + -- buffer was read, Device_Error if an error occurs). + + procedure Read_Buf + (File : FCB.AFCB_Ptr; + Buf : Address; + Siz : Interfaces.C_Streams.size_t; + Count : out Interfaces.C_Streams.size_t); + -- Reads Siz bytes from File.Stream into Buf. The caller has checked that + -- the file is open in read mode. Device Error is raised if an error + -- occurs. Count is the actual number of bytes read, which may be less + -- than Siz if the end of file is encountered. + + procedure Append_Set (File : FCB.AFCB_Ptr); + -- If the mode of the file is Append_File, then the file is positioned at + -- the end of file using fseek, otherwise this call has no effect. + + procedure Write_Buf + (File : FCB.AFCB_Ptr; + Buf : Address; + Siz : Interfaces.C_Streams.size_t); + -- Writes size_t bytes to File.Stream from Buf. The caller has checked that + -- the file is open in write mode. Raises Device_Error if the complete + -- buffer cannot be written. + + procedure Make_Unbuffered (File : FCB.AFCB_Ptr); + + procedure Make_Line_Buffered + (File : FCB.AFCB_Ptr; + Line_Siz : Interfaces.C_Streams.size_t); + + procedure Make_Buffered + (File : FCB.AFCB_Ptr; + Buf_Siz : Interfaces.C_Streams.size_t); + +private + pragma Inline (Check_Read_Status); + pragma Inline (Check_Write_Status); + pragma Inline (Mode); + +end System.File_IO; diff --git a/gcc/ada/libgnat/s-finmas.adb b/gcc/ada/libgnat/s-finmas.adb new file mode 100644 index 0000000..85ee481 --- /dev/null +++ b/gcc/ada/libgnat/s-finmas.adb @@ -0,0 +1,554 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; + +with System.Address_Image; +with System.HTable; use System.HTable; +with System.IO; use System.IO; +with System.Soft_Links; use System.Soft_Links; +with System.Storage_Elements; use System.Storage_Elements; + +package body System.Finalization_Masters is + + -- Finalize_Address hash table types. In general, masters are homogeneous + -- collections of controlled objects. Rare cases such as allocations on a + -- subpool require heterogeneous masters. The following table provides a + -- relation between object address and its Finalize_Address routine. + + type Header_Num is range 0 .. 127; + + function Hash (Key : System.Address) return Header_Num; + + -- Address --> Finalize_Address_Ptr + + package Finalize_Address_Table is new Simple_HTable + (Header_Num => Header_Num, + Element => Finalize_Address_Ptr, + No_Element => null, + Key => System.Address, + Hash => Hash, + Equal => "="); + + --------------------------- + -- Add_Offset_To_Address -- + --------------------------- + + function Add_Offset_To_Address + (Addr : System.Address; + Offset : System.Storage_Elements.Storage_Offset) return System.Address + is + begin + return System.Storage_Elements."+" (Addr, Offset); + end Add_Offset_To_Address; + + ------------ + -- Attach -- + ------------ + + procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is + begin + Lock_Task.all; + Attach_Unprotected (N, L); + Unlock_Task.all; + + -- Note: No need to unlock in case of an exception because the above + -- code can never raise one. + end Attach; + + ------------------------ + -- Attach_Unprotected -- + ------------------------ + + procedure Attach_Unprotected + (N : not null FM_Node_Ptr; + L : not null FM_Node_Ptr) + is + begin + L.Next.Prev := N; + N.Next := L.Next; + L.Next := N; + N.Prev := L; + end Attach_Unprotected; + + --------------- + -- Base_Pool -- + --------------- + + function Base_Pool + (Master : Finalization_Master) return Any_Storage_Pool_Ptr + is + begin + return Master.Base_Pool; + end Base_Pool; + + ----------------------------------------- + -- Delete_Finalize_Address_Unprotected -- + ----------------------------------------- + + procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is + begin + Finalize_Address_Table.Remove (Obj); + end Delete_Finalize_Address_Unprotected; + + ------------ + -- Detach -- + ------------ + + procedure Detach (N : not null FM_Node_Ptr) is + begin + Lock_Task.all; + Detach_Unprotected (N); + Unlock_Task.all; + + -- Note: No need to unlock in case of an exception because the above + -- code can never raise one. + end Detach; + + ------------------------ + -- Detach_Unprotected -- + ------------------------ + + procedure Detach_Unprotected (N : not null FM_Node_Ptr) is + begin + if N.Prev /= null and then N.Next /= null then + N.Prev.Next := N.Next; + N.Next.Prev := N.Prev; + N.Prev := null; + N.Next := null; + end if; + end Detach_Unprotected; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Master : in out Finalization_Master) is + Cleanup : Finalize_Address_Ptr; + Curr_Ptr : FM_Node_Ptr; + Ex_Occur : Exception_Occurrence; + Obj_Addr : Address; + Raised : Boolean := False; + + function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean; + -- Determine whether a list contains only one element, the dummy head + + ------------------- + -- Is_Empty_List -- + ------------------- + + function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is + begin + return L.Next = L and then L.Prev = L; + end Is_Empty_List; + + -- Start of processing for Finalize + + begin + Lock_Task.all; + + -- Synchronization: + -- Read - allocation, finalization + -- Write - finalization + + if Master.Finalization_Started then + Unlock_Task.all; + + -- Double finalization may occur during the handling of stand alone + -- libraries or the finalization of a pool with subpools. Due to the + -- potential aliasing of masters in these two cases, do not process + -- the same master twice. + + return; + end if; + + -- Lock the master to prevent any allocations while the objects are + -- being finalized. The master remains locked because either the master + -- is explicitly deallocated or the associated access type is about to + -- go out of scope. + + -- Synchronization: + -- Read - allocation, finalization + -- Write - finalization + + Master.Finalization_Started := True; + + while not Is_Empty_List (Master.Objects'Unchecked_Access) loop + Curr_Ptr := Master.Objects.Next; + + -- Synchronization: + -- Write - allocation, deallocation, finalization + + Detach_Unprotected (Curr_Ptr); + + -- Skip the list header in order to offer proper object layout for + -- finalization. + + Obj_Addr := Curr_Ptr.all'Address + Header_Size; + + -- Retrieve TSS primitive Finalize_Address depending on the master's + -- mode of operation. + + -- Synchronization: + -- Read - allocation, finalization + -- Write - outside + + if Master.Is_Homogeneous then + + -- Synchronization: + -- Read - finalization + -- Write - allocation, outside + + Cleanup := Master.Finalize_Address; + + else + -- Synchronization: + -- Read - finalization + -- Write - allocation, deallocation + + Cleanup := Finalize_Address_Unprotected (Obj_Addr); + end if; + + begin + Cleanup (Obj_Addr); + exception + when Fin_Occur : others => + if not Raised then + Raised := True; + Save_Occurrence (Ex_Occur, Fin_Occur); + end if; + end; + + -- When the master is a heterogeneous collection, destroy the object + -- - Finalize_Address pair since it is no longer needed. + + -- Synchronization: + -- Read - finalization + -- Write - outside + + if not Master.Is_Homogeneous then + + -- Synchronization: + -- Read - finalization + -- Write - allocation, deallocation, finalization + + Delete_Finalize_Address_Unprotected (Obj_Addr); + end if; + end loop; + + Unlock_Task.all; + + -- If the finalization of a particular object failed or Finalize_Address + -- was not set, reraise the exception now. + + if Raised then + Reraise_Occurrence (Ex_Occur); + end if; + end Finalize; + + ---------------------- + -- Finalize_Address -- + ---------------------- + + function Finalize_Address + (Master : Finalization_Master) return Finalize_Address_Ptr + is + begin + return Master.Finalize_Address; + end Finalize_Address; + + ---------------------------------- + -- Finalize_Address_Unprotected -- + ---------------------------------- + + function Finalize_Address_Unprotected + (Obj : System.Address) return Finalize_Address_Ptr + is + begin + return Finalize_Address_Table.Get (Obj); + end Finalize_Address_Unprotected; + + -------------------------- + -- Finalization_Started -- + -------------------------- + + function Finalization_Started + (Master : Finalization_Master) return Boolean + is + begin + return Master.Finalization_Started; + end Finalization_Started; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : System.Address) return Header_Num is + begin + return + Header_Num + (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length)); + end Hash; + + ----------------- + -- Header_Size -- + ----------------- + + function Header_Size return System.Storage_Elements.Storage_Count is + begin + return FM_Node'Size / Storage_Unit; + end Header_Size; + + ---------------- + -- Initialize -- + ---------------- + + overriding procedure Initialize (Master : in out Finalization_Master) is + begin + -- The dummy head must point to itself in both directions + + Master.Objects.Next := Master.Objects'Unchecked_Access; + Master.Objects.Prev := Master.Objects'Unchecked_Access; + end Initialize; + + -------------------- + -- Is_Homogeneous -- + -------------------- + + function Is_Homogeneous (Master : Finalization_Master) return Boolean is + begin + return Master.Is_Homogeneous; + end Is_Homogeneous; + + ------------- + -- Objects -- + ------------- + + function Objects (Master : Finalization_Master) return FM_Node_Ptr is + begin + return Master.Objects'Unrestricted_Access; + end Objects; + + ------------------ + -- Print_Master -- + ------------------ + + procedure Print_Master (Master : Finalization_Master) is + Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; + Head_Seen : Boolean := False; + N_Ptr : FM_Node_Ptr; + + begin + -- Output the basic contents of a master + + -- Master : 0x123456789 + -- Is_Hmgen : TURE FALSE + -- Base_Pool: null 0x123456789 + -- Fin_Addr : null 0x123456789 + -- Fin_Start: TRUE FALSE + + Put ("Master : "); + Put_Line (Address_Image (Master'Address)); + + Put ("Is_Hmgen : "); + Put_Line (Master.Is_Homogeneous'Img); + + Put ("Base_Pool: "); + if Master.Base_Pool = null then + Put_Line ("null"); + else + Put_Line (Address_Image (Master.Base_Pool'Address)); + end if; + + Put ("Fin_Addr : "); + if Master.Finalize_Address = null then + Put_Line ("null"); + else + Put_Line (Address_Image (Master.Finalize_Address'Address)); + end if; + + Put ("Fin_Start: "); + Put_Line (Master.Finalization_Started'Img); + + -- Output all chained elements. The format is the following: + + -- ^ ? null + -- |Header: 0x123456789 (dummy head) + -- | Prev: 0x123456789 + -- | Next: 0x123456789 + -- V + + -- ^ - the current element points back to the correct element + -- ? - the current element points back to an erroneous element + -- n - the current element points back to null + + -- Header - the address of the list header + -- Prev - the address of the list header which the current element + -- points back to + -- Next - the address of the list header which the current element + -- points to + -- (dummy head) - present if dummy head + + N_Ptr := Head; + while N_Ptr /= null loop -- Should never be null + Put_Line ("V"); + + -- We see the head initially; we want to exit when we see the head a + -- second time. + + if N_Ptr = Head then + exit when Head_Seen; + + Head_Seen := True; + end if; + + -- The current element is null. This should never happen since the + -- list is circular. + + if N_Ptr.Prev = null then + Put_Line ("null (ERROR)"); + + -- The current element points back to the correct element + + elsif N_Ptr.Prev.Next = N_Ptr then + Put_Line ("^"); + + -- The current element points to an erroneous element + + else + Put_Line ("? (ERROR)"); + end if; + + -- Output the header and fields + + Put ("|Header: "); + Put (Address_Image (N_Ptr.all'Address)); + + -- Detect the dummy head + + if N_Ptr = Head then + Put_Line (" (dummy head)"); + else + Put_Line (""); + end if; + + Put ("| Prev: "); + + if N_Ptr.Prev = null then + Put_Line ("null"); + else + Put_Line (Address_Image (N_Ptr.Prev.all'Address)); + end if; + + Put ("| Next: "); + + if N_Ptr.Next = null then + Put_Line ("null"); + else + Put_Line (Address_Image (N_Ptr.Next.all'Address)); + end if; + + N_Ptr := N_Ptr.Next; + end loop; + end Print_Master; + + ------------------- + -- Set_Base_Pool -- + ------------------- + + procedure Set_Base_Pool + (Master : in out Finalization_Master; + Pool_Ptr : Any_Storage_Pool_Ptr) + is + begin + Master.Base_Pool := Pool_Ptr; + end Set_Base_Pool; + + -------------------------- + -- Set_Finalize_Address -- + -------------------------- + + procedure Set_Finalize_Address + (Master : in out Finalization_Master; + Fin_Addr_Ptr : Finalize_Address_Ptr) + is + begin + -- Synchronization: + -- Read - finalization + -- Write - allocation, outside + + Lock_Task.all; + Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr); + Unlock_Task.all; + end Set_Finalize_Address; + + -------------------------------------- + -- Set_Finalize_Address_Unprotected -- + -------------------------------------- + + procedure Set_Finalize_Address_Unprotected + (Master : in out Finalization_Master; + Fin_Addr_Ptr : Finalize_Address_Ptr) + is + begin + if Master.Finalize_Address = null then + Master.Finalize_Address := Fin_Addr_Ptr; + end if; + end Set_Finalize_Address_Unprotected; + + ---------------------------------------------------- + -- Set_Heterogeneous_Finalize_Address_Unprotected -- + ---------------------------------------------------- + + procedure Set_Heterogeneous_Finalize_Address_Unprotected + (Obj : System.Address; + Fin_Addr_Ptr : Finalize_Address_Ptr) + is + begin + Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); + end Set_Heterogeneous_Finalize_Address_Unprotected; + + -------------------------- + -- Set_Is_Heterogeneous -- + -------------------------- + + procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is + begin + -- Synchronization: + -- Read - finalization + -- Write - outside + + Lock_Task.all; + Master.Is_Homogeneous := False; + Unlock_Task.all; + end Set_Is_Heterogeneous; + +end System.Finalization_Masters; diff --git a/gcc/ada/libgnat/s-finmas.ads b/gcc/ada/libgnat/s-finmas.ads new file mode 100644 index 0000000..28f862f --- /dev/null +++ b/gcc/ada/libgnat/s-finmas.ads @@ -0,0 +1,206 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System.Storage_Elements; +with System.Storage_Pools; + +pragma Compiler_Unit_Warning; + +package System.Finalization_Masters is + pragma Preelaborate; + + -- A reference to primitive Finalize_Address. The expander generates an + -- implementation of this procedure for each controlled and class-wide + -- type. Since controlled objects are simply viewed as addresses once + -- allocated through a master, Finalize_Address provides a backward + -- indirection from an address to a type-specific context. + + type Finalize_Address_Ptr is access procedure (Obj : System.Address); + + -- Heterogeneous collection type structure + + type FM_Node is private; + type FM_Node_Ptr is access all FM_Node; + pragma No_Strict_Aliasing (FM_Node_Ptr); + + -- A reference to any derivation from Root_Storage_Pool. Since this type + -- may not be used to allocate objects, its storage size is zero. + + type Any_Storage_Pool_Ptr is + access System.Storage_Pools.Root_Storage_Pool'Class; + for Any_Storage_Pool_Ptr'Storage_Size use 0; + + -- Finalization master type structure. A unique master is associated with + -- each access-to-controlled or access-to-class-wide type. Masters also act + -- as components of subpools. By default, a master contains objects of the + -- same designated type but it may also accommodate heterogeneous objects. + + type Finalization_Master is + new Ada.Finalization.Limited_Controlled with private; + + -- A reference to a finalization master. Since this type may not be used + -- to allocate objects, its storage size is zero. + + type Finalization_Master_Ptr is access all Finalization_Master; + for Finalization_Master_Ptr'Storage_Size use 0; + + procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr); + -- Compiler interface, do not call from withing the run-time. Prepend a + -- node to a specific finalization master. + + procedure Attach_Unprotected + (N : not null FM_Node_Ptr; + L : not null FM_Node_Ptr); + -- Prepend a node to a specific finalization master + + procedure Delete_Finalize_Address_Unprotected (Obj : System.Address); + -- Destroy the relation pair object - Finalize_Address from the internal + -- hash table. + + procedure Detach (N : not null FM_Node_Ptr); + -- Compiler interface, do not call from within the run-time. Remove a node + -- from an arbitrary finalization master. + + procedure Detach_Unprotected (N : not null FM_Node_Ptr); + -- Remove a node from an arbitrary finalization master + + overriding procedure Finalize (Master : in out Finalization_Master); + -- Lock the master to prevent allocations during finalization. Iterate over + -- the list of allocated controlled objects, finalizing each one by calling + -- its specific Finalize_Address. In the end, deallocate the dummy head. + + function Finalize_Address + (Master : Finalization_Master) return Finalize_Address_Ptr; + -- Return a reference to the TSS primitive Finalize_Address associated with + -- a master. + + function Finalize_Address_Unprotected + (Obj : System.Address) return Finalize_Address_Ptr; + -- Retrieve the Finalize_Address primitive associated with a particular + -- object. + + function Finalization_Started (Master : Finalization_Master) return Boolean; + -- Return the finalization status of a master + + function Header_Size return System.Storage_Elements.Storage_Count; + -- Return the size of type FM_Node as Storage_Count + + function Is_Homogeneous (Master : Finalization_Master) return Boolean; + -- Return the behavior flag of a master + + function Objects (Master : Finalization_Master) return FM_Node_Ptr; + -- Return the header of the doubly-linked list of controlled objects + + procedure Print_Master (Master : Finalization_Master); + -- Debug routine, outputs the contents of a master + + procedure Set_Finalize_Address + (Master : in out Finalization_Master; + Fin_Addr_Ptr : Finalize_Address_Ptr); + -- Compiler interface, do not call from within the run-time. Set the clean + -- up routine of a finalization master + + procedure Set_Finalize_Address_Unprotected + (Master : in out Finalization_Master; + Fin_Addr_Ptr : Finalize_Address_Ptr); + -- Set the clean up routine of a finalization master + + procedure Set_Heterogeneous_Finalize_Address_Unprotected + (Obj : System.Address; + Fin_Addr_Ptr : Finalize_Address_Ptr); + -- Add a relation pair object - Finalize_Address to the internal hash + -- table. This is done in the context of allocation on a heterogeneous + -- finalization master where a single master services multiple anonymous + -- access-to-controlled types. + + procedure Set_Is_Heterogeneous (Master : in out Finalization_Master); + -- Mark the master as being a heterogeneous collection of objects + +private + -- Heterogeneous collection type structure + + type FM_Node is record + Prev : FM_Node_Ptr := null; + Next : FM_Node_Ptr := null; + end record; + + -- Finalization master type structure. A unique master is associated with + -- each access-to-controlled or access-to-class-wide type. Masters also act + -- as components of subpools. By default, a master contains objects of the + -- same designated type but it may also accommodate heterogeneous objects. + + type Finalization_Master is + new Ada.Finalization.Limited_Controlled with + record + Is_Homogeneous : Boolean := True; + -- A flag which controls the behavior of the master. A value of False + -- denotes a heterogeneous collection. + + Base_Pool : Any_Storage_Pool_Ptr := null; + -- A reference to the pool which this finalization master services. This + -- field is used in conjunction with the build-in-place machinery. + + Objects : aliased FM_Node; + -- A doubly linked list which contains the headers of all controlled + -- objects allocated in a [sub]pool. + + Finalize_Address : Finalize_Address_Ptr := null; + -- A reference to the routine reponsible for object finalization. This + -- is used only when the master is in homogeneous mode. + + Finalization_Started : Boolean := False; + -- A flag used to detect allocations which occur during the finalization + -- of a master. The allocations must raise Program_Error. This scenario + -- may arise in a multitask environment. + end record; + + -- Since RTSfind cannot contain names of the form RE_"+", the following + -- routine serves as a wrapper around System.Storage_Elements."+". + + function Add_Offset_To_Address + (Addr : System.Address; + Offset : System.Storage_Elements.Storage_Offset) return System.Address; + + function Base_Pool + (Master : Finalization_Master) return Any_Storage_Pool_Ptr; + -- Return a reference to the underlying storage pool on which the master + -- operates. + + overriding procedure Initialize (Master : in out Finalization_Master); + -- Initialize the dummy head of a finalization master + + procedure Set_Base_Pool + (Master : in out Finalization_Master; + Pool_Ptr : Any_Storage_Pool_Ptr); + -- Set the underlying pool of a finalization master + +end System.Finalization_Masters; diff --git a/gcc/ada/libgnat/s-finroo.adb b/gcc/ada/libgnat/s-finroo.adb new file mode 100644 index 0000000..6b65bd8 --- /dev/null +++ b/gcc/ada/libgnat/s-finroo.adb @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ R O O T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Finalization_Root is + + -- It should not be possible to call any of these subprograms + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (Object : in out Root_Controlled) is + begin + raise Program_Error; + end Adjust; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Object : in out Root_Controlled) is + begin + raise Program_Error; + end Finalize; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Object : in out Root_Controlled) is + begin + raise Program_Error; + end Initialize; + +end System.Finalization_Root; diff --git a/gcc/ada/libgnat/s-finroo.ads b/gcc/ada/libgnat/s-finroo.ads new file mode 100644 index 0000000..83d3227 --- /dev/null +++ b/gcc/ada/libgnat/s-finroo.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . F I N A L I Z A T I O N _ R O O T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit provides the basic support for controlled (finalizable) types + +package System.Finalization_Root is + pragma Preelaborate; + + -- The base for types Controlled and Limited_Controlled declared in Ada. + -- Finalization. + + type Root_Controlled is abstract tagged null record; + + procedure Adjust (Object : in out Root_Controlled); + procedure Finalize (Object : in out Root_Controlled); + procedure Initialize (Object : in out Root_Controlled); + +end System.Finalization_Root; diff --git a/gcc/ada/libgnat/s-flocon-none.adb b/gcc/ada/libgnat/s-flocon-none.adb new file mode 100644 index 0000000..5826237 --- /dev/null +++ b/gcc/ada/libgnat/s-flocon-none.adb @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F L O A T _ C O N T R O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation does nothing and can be used when the floating point +-- unit is fully under control. + +package body System.Float_Control is + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + null; + end Reset; + +end System.Float_Control; diff --git a/gcc/ada/libgnat/s-flocon.adb b/gcc/ada/libgnat/s-flocon.adb new file mode 100644 index 0000000..31669d5 --- /dev/null +++ b/gcc/ada/libgnat/s-flocon.adb @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F L O A T _ C O N T R O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation calls an imported function. + +package body System.Float_Control is + + ----------- + -- Reset -- + ----------- + + procedure Reset is + procedure Init_Float; + pragma Import (C, Init_Float, "__gnat_init_float"); + begin + Init_Float; + end Reset; + +end System.Float_Control; diff --git a/gcc/ada/libgnat/s-flocon.ads b/gcc/ada/libgnat/s-flocon.ads new file mode 100644 index 0000000..1033e8e --- /dev/null +++ b/gcc/ada/libgnat/s-flocon.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F L O A T _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Control functions for floating-point unit + +package System.Float_Control is + pragma Pure; + -- This is not fully correct, but this unit is with-ed by pure units + -- (eg s-imgrea). + + procedure Reset; + pragma Inline (Reset); + -- Reset the floating-point processor to the default state needed to get + -- correct Ada semantics for the target. Some third party tools change + -- the settings for the floating-point processor. Reset can be called + -- to reset the floating-point processor into the mode required by GNAT + -- for correct operation. Use this call after a call to foreign code if + -- you suspect incorrect floating-point operation after the call. + -- + -- For example under Windows NT some system DLL calls change the default + -- FPU arithmetic to 64 bit precision mode. However, since in Ada 95 it + -- is required to provide full access to the floating-point types of the + -- architecture, GNAT requires full 80-bit precision mode, and Reset makes + -- sure this mode is established. + -- + -- Similarly on the PPC processor, it is important that overflow and + -- underflow exceptions be disabled. + -- + -- The call to Reset simply has no effect if the target environment + -- does not give rise to such concerns. +end System.Float_Control; diff --git a/gcc/ada/libgnat/s-fore.adb b/gcc/ada/libgnat/s-fore.adb new file mode 100644 index 0000000..9d1933c --- /dev/null +++ b/gcc/ada/libgnat/s-fore.adb @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Fore is + + ---------- + -- Fore -- + ---------- + + function Fore (Lo, Hi : Long_Long_Float) return Natural is + T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi); + R : Natural; + + begin + -- Initial value of 2 allows for sign and mandatory single digit + + R := 2; + + -- Loop to increase Fore as needed to include full range of values + + while T >= 10.0 loop + T := T / 10.0; + R := R + 1; + end loop; + + return R; + end Fore; +end System.Fore; diff --git a/gcc/ada/libgnat/s-fore.ads b/gcc/ada/libgnat/s-fore.ads new file mode 100644 index 0000000..f7e252e --- /dev/null +++ b/gcc/ada/libgnat/s-fore.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . F O R E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for the 'Fore attribute + +package System.Fore is + pragma Pure; + + function Fore (Lo, Hi : Long_Long_Float) return Natural; + -- Compute Fore attribute value for a fixed-point type. The parameters + -- are the low and high bounds values, converted to Long_Long_Float. + +end System.Fore; diff --git a/gcc/ada/libgnat/s-gearop.adb b/gcc/ada/libgnat/s-gearop.adb new file mode 100644 index 0000000..5368028 --- /dev/null +++ b/gcc/ada/libgnat/s-gearop.adb @@ -0,0 +1,934 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ A R R A Y _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Numerics; use Ada.Numerics; +package body System.Generic_Array_Operations is + function Check_Unit_Last + (Index : Integer; + Order : Positive; + First : Integer) return Integer; + pragma Inline_Always (Check_Unit_Last); + -- Compute index of last element returned by Unit_Vector or Unit_Matrix. + -- A separate function is needed to allow raising Constraint_Error before + -- declaring the function result variable. The result variable needs to be + -- declared first, to allow front-end inlining. + + -------------- + -- Diagonal -- + -------------- + + function Diagonal (A : Matrix) return Vector is + N : constant Natural := Natural'Min (A'Length (1), A'Length (2)); + begin + return R : Vector (A'First (1) .. A'First (1) + N - 1) do + for J in 0 .. N - 1 loop + R (R'First + J) := A (A'First (1) + J, A'First (2) + J); + end loop; + end return; + end Diagonal; + + -------------------------- + -- Square_Matrix_Length -- + -------------------------- + + function Square_Matrix_Length (A : Matrix) return Natural is + begin + if A'Length (1) /= A'Length (2) then + raise Constraint_Error with "matrix is not square"; + else + return A'Length (1); + end if; + end Square_Matrix_Length; + + --------------------- + -- Check_Unit_Last -- + --------------------- + + function Check_Unit_Last + (Index : Integer; + Order : Positive; + First : Integer) return Integer + is + begin + -- Order the tests carefully to avoid overflow + + if Index < First + or else First > Integer'Last - Order + 1 + or else Index > First + (Order - 1) + then + raise Constraint_Error; + end if; + + return First + (Order - 1); + end Check_Unit_Last; + + --------------------- + -- Back_Substitute -- + --------------------- + + procedure Back_Substitute (M, N : in out Matrix) is + pragma Assert (M'First (1) = N'First (1) + and then + M'Last (1) = N'Last (1)); + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar); + -- Elementary row operation that subtracts Factor * M (Source, <>) from + -- M (Target, <>) + + ------------- + -- Sub_Row -- + ------------- + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar) + is + begin + for J in M'Range (2) loop + M (Target, J) := M (Target, J) - Factor * M (Source, J); + end loop; + end Sub_Row; + + -- Local declarations + + Max_Col : Integer := M'Last (2); + + -- Start of processing for Back_Substitute + + begin + Do_Rows : for Row in reverse M'Range (1) loop + Find_Non_Zero : for Col in reverse M'First (2) .. Max_Col loop + if Is_Non_Zero (M (Row, Col)) then + + -- Found first non-zero element, so subtract a multiple of this + -- element from all higher rows, to reduce all other elements + -- in this column to zero. + + declare + -- We can't use a for loop, as we'd need to iterate to + -- Row - 1, but that expression will overflow if M'First + -- equals Integer'First, which is true for aggregates + -- without explicit bounds.. + + J : Integer := M'First (1); + + begin + while J < Row loop + Sub_Row (N, J, Row, (M (J, Col) / M (Row, Col))); + Sub_Row (M, J, Row, (M (J, Col) / M (Row, Col))); + J := J + 1; + end loop; + end; + + -- Avoid potential overflow in the subtraction below + + exit Do_Rows when Col = M'First (2); + + Max_Col := Col - 1; + + exit Find_Non_Zero; + end if; + end loop Find_Non_Zero; + end loop Do_Rows; + end Back_Substitute; + + ----------------------- + -- Forward_Eliminate -- + ----------------------- + + procedure Forward_Eliminate + (M : in out Matrix; + N : in out Matrix; + Det : out Scalar) + is + pragma Assert (M'First (1) = N'First (1) + and then + M'Last (1) = N'Last (1)); + + -- The following are variations of the elementary matrix row operations: + -- row switching, row multiplication and row addition. Because in this + -- algorithm the addition factor is always a negated value, we chose to + -- use row subtraction instead. Similarly, instead of multiplying by + -- a reciprocal, we divide. + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar); + -- Subtrace Factor * M (Source, <>) from M (Target, <>) + + procedure Divide_Row + (M, N : in out Matrix; + Row : Integer; + Scale : Scalar); + -- Divide M (Row) and N (Row) by Scale, and update Det + + procedure Switch_Row + (M, N : in out Matrix; + Row_1 : Integer; + Row_2 : Integer); + -- Exchange M (Row_1) and N (Row_1) with M (Row_2) and N (Row_2), + -- negating Det in the process. + + ------------- + -- Sub_Row -- + ------------- + + procedure Sub_Row + (M : in out Matrix; + Target : Integer; + Source : Integer; + Factor : Scalar) + is + begin + for J in M'Range (2) loop + M (Target, J) := M (Target, J) - Factor * M (Source, J); + end loop; + end Sub_Row; + + ---------------- + -- Divide_Row -- + ---------------- + + procedure Divide_Row + (M, N : in out Matrix; + Row : Integer; + Scale : Scalar) + is + begin + Det := Det * Scale; + + for J in M'Range (2) loop + M (Row, J) := M (Row, J) / Scale; + end loop; + + for J in N'Range (2) loop + N (Row - M'First (1) + N'First (1), J) := + N (Row - M'First (1) + N'First (1), J) / Scale; + end loop; + end Divide_Row; + + ---------------- + -- Switch_Row -- + ---------------- + + procedure Switch_Row + (M, N : in out Matrix; + Row_1 : Integer; + Row_2 : Integer) + is + procedure Swap (X, Y : in out Scalar); + -- Exchange the values of X and Y + + ---------- + -- Swap -- + ---------- + + procedure Swap (X, Y : in out Scalar) is + T : constant Scalar := X; + begin + X := Y; + Y := T; + end Swap; + + -- Start of processing for Switch_Row + + begin + if Row_1 /= Row_2 then + Det := Zero - Det; + + for J in M'Range (2) loop + Swap (M (Row_1, J), M (Row_2, J)); + end loop; + + for J in N'Range (2) loop + Swap (N (Row_1 - M'First (1) + N'First (1), J), + N (Row_2 - M'First (1) + N'First (1), J)); + end loop; + end if; + end Switch_Row; + + -- Local declarations + + Row : Integer := M'First (1); + + -- Start of processing for Forward_Eliminate + + begin + Det := One; + + for J in M'Range (2) loop + declare + Max_Row : Integer := Row; + Max_Abs : Real'Base := 0.0; + + begin + -- Find best pivot in column J, starting in row Row + + for K in Row .. M'Last (1) loop + declare + New_Abs : constant Real'Base := abs M (K, J); + begin + if Max_Abs < New_Abs then + Max_Abs := New_Abs; + Max_Row := K; + end if; + end; + end loop; + + if Max_Abs > 0.0 then + Switch_Row (M, N, Row, Max_Row); + + -- The temporaries below are necessary to force a copy of the + -- value and avoid improper aliasing. + + declare + Scale : constant Scalar := M (Row, J); + begin + Divide_Row (M, N, Row, Scale); + end; + + for U in Row + 1 .. M'Last (1) loop + declare + Factor : constant Scalar := M (U, J); + begin + Sub_Row (N, U, Row, Factor); + Sub_Row (M, U, Row, Factor); + end; + end loop; + + exit when Row >= M'Last (1); + + Row := Row + 1; + + else + -- Set zero (note that we do not have literals) + + Det := Zero; + end if; + end; + end loop; + end Forward_Eliminate; + + ------------------- + -- Inner_Product -- + ------------------- + + function Inner_Product + (Left : Left_Vector; + Right : Right_Vector) return Result_Scalar + is + R : Result_Scalar := Zero; + + begin + if Left'Length /= Right'Length then + raise Constraint_Error with + "vectors are of different length in inner product"; + end if; + + for J in Left'Range loop + R := R + Left (J) * Right (J - Left'First + Right'First); + end loop; + + return R; + end Inner_Product; + + ------------- + -- L2_Norm -- + ------------- + + function L2_Norm (X : X_Vector) return Result_Real'Base is + Sum : Result_Real'Base := 0.0; + + begin + for J in X'Range loop + Sum := Sum + Result_Real'Base (abs X (J))**2; + end loop; + + return Sqrt (Sum); + end L2_Norm; + + ---------------------------------- + -- Matrix_Elementwise_Operation -- + ---------------------------------- + + function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is + begin + return R : Result_Matrix (X'Range (1), X'Range (2)) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Operation (X (J, K)); + end loop; + end loop; + end return; + end Matrix_Elementwise_Operation; + + ---------------------------------- + -- Vector_Elementwise_Operation -- + ---------------------------------- + + function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector is + begin + return R : Result_Vector (X'Range) do + for J in R'Range loop + R (J) := Operation (X (J)); + end loop; + end return; + end Vector_Elementwise_Operation; + + ----------------------------------------- + -- Matrix_Matrix_Elementwise_Operation -- + ----------------------------------------- + + function Matrix_Matrix_Elementwise_Operation + (Left : Left_Matrix; + Right : Right_Matrix) return Result_Matrix + is + begin + return R : Result_Matrix (Left'Range (1), Left'Range (2)) do + if Left'Length (1) /= Right'Length (1) + or else + Left'Length (2) /= Right'Length (2) + then + raise Constraint_Error with + "matrices are of different dimension in elementwise operation"; + end if; + + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := + Operation + (Left (J, K), + Right + (J - R'First (1) + Right'First (1), + K - R'First (2) + Right'First (2))); + end loop; + end loop; + end return; + end Matrix_Matrix_Elementwise_Operation; + + ------------------------------------------------ + -- Matrix_Matrix_Scalar_Elementwise_Operation -- + ------------------------------------------------ + + function Matrix_Matrix_Scalar_Elementwise_Operation + (X : X_Matrix; + Y : Y_Matrix; + Z : Z_Scalar) return Result_Matrix + is + begin + return R : Result_Matrix (X'Range (1), X'Range (2)) do + if X'Length (1) /= Y'Length (1) + or else + X'Length (2) /= Y'Length (2) + then + raise Constraint_Error with + "matrices are of different dimension in elementwise operation"; + end if; + + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := + Operation + (X (J, K), + Y (J - R'First (1) + Y'First (1), + K - R'First (2) + Y'First (2)), + Z); + end loop; + end loop; + end return; + end Matrix_Matrix_Scalar_Elementwise_Operation; + + ----------------------------------------- + -- Vector_Vector_Elementwise_Operation -- + ----------------------------------------- + + function Vector_Vector_Elementwise_Operation + (Left : Left_Vector; + Right : Right_Vector) return Result_Vector + is + begin + return R : Result_Vector (Left'Range) do + if Left'Length /= Right'Length then + raise Constraint_Error with + "vectors are of different length in elementwise operation"; + end if; + + for J in R'Range loop + R (J) := Operation (Left (J), Right (J - R'First + Right'First)); + end loop; + end return; + end Vector_Vector_Elementwise_Operation; + + ------------------------------------------------ + -- Vector_Vector_Scalar_Elementwise_Operation -- + ------------------------------------------------ + + function Vector_Vector_Scalar_Elementwise_Operation + (X : X_Vector; + Y : Y_Vector; + Z : Z_Scalar) return Result_Vector is + begin + return R : Result_Vector (X'Range) do + if X'Length /= Y'Length then + raise Constraint_Error with + "vectors are of different length in elementwise operation"; + end if; + + for J in R'Range loop + R (J) := Operation (X (J), Y (J - X'First + Y'First), Z); + end loop; + end return; + end Vector_Vector_Scalar_Elementwise_Operation; + + ----------------------------------------- + -- Matrix_Scalar_Elementwise_Operation -- + ----------------------------------------- + + function Matrix_Scalar_Elementwise_Operation + (Left : Left_Matrix; + Right : Right_Scalar) return Result_Matrix + is + begin + return R : Result_Matrix (Left'Range (1), Left'Range (2)) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Operation (Left (J, K), Right); + end loop; + end loop; + end return; + end Matrix_Scalar_Elementwise_Operation; + + ----------------------------------------- + -- Vector_Scalar_Elementwise_Operation -- + ----------------------------------------- + + function Vector_Scalar_Elementwise_Operation + (Left : Left_Vector; + Right : Right_Scalar) return Result_Vector + is + begin + return R : Result_Vector (Left'Range) do + for J in R'Range loop + R (J) := Operation (Left (J), Right); + end loop; + end return; + end Vector_Scalar_Elementwise_Operation; + + ----------------------------------------- + -- Scalar_Matrix_Elementwise_Operation -- + ----------------------------------------- + + function Scalar_Matrix_Elementwise_Operation + (Left : Left_Scalar; + Right : Right_Matrix) return Result_Matrix + is + begin + return R : Result_Matrix (Right'Range (1), Right'Range (2)) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Operation (Left, Right (J, K)); + end loop; + end loop; + end return; + end Scalar_Matrix_Elementwise_Operation; + + ----------------------------------------- + -- Scalar_Vector_Elementwise_Operation -- + ----------------------------------------- + + function Scalar_Vector_Elementwise_Operation + (Left : Left_Scalar; + Right : Right_Vector) return Result_Vector + is + begin + return R : Result_Vector (Right'Range) do + for J in R'Range loop + R (J) := Operation (Left, Right (J)); + end loop; + end return; + end Scalar_Vector_Elementwise_Operation; + + ---------- + -- Sqrt -- + ---------- + + function Sqrt (X : Real'Base) return Real'Base is + Root, Next : Real'Base; + + begin + -- Be defensive: any comparisons with NaN values will yield False. + + if not (X > 0.0) then + if X = 0.0 then + return X; + else + raise Argument_Error; + end if; + + elsif X > Real'Base'Last then + + -- X is infinity, which is its own square root + + return X; + end if; + + -- Compute an initial estimate based on: + + -- X = M * R**E and Sqrt (X) = Sqrt (M) * R**(E / 2.0), + + -- where M is the mantissa, R is the radix and E the exponent. + + -- By ignoring the mantissa and ignoring the case of an odd + -- exponent, we get a final error that is at most R. In other words, + -- the result has about a single bit precision. + + Root := Real'Base (Real'Machine_Radix) ** (Real'Exponent (X) / 2); + + -- Because of the poor initial estimate, use the Babylonian method of + -- computing the square root, as it is stable for all inputs. Every step + -- will roughly double the precision of the result. Just a few steps + -- suffice in most cases. Eight iterations should give about 2**8 bits + -- of precision. + + for J in 1 .. 8 loop + Next := (Root + X / Root) / 2.0; + exit when Root = Next; + Root := Next; + end loop; + + return Root; + end Sqrt; + + --------------------------- + -- Matrix_Matrix_Product -- + --------------------------- + + function Matrix_Matrix_Product + (Left : Left_Matrix; + Right : Right_Matrix) return Result_Matrix + is + begin + return R : Result_Matrix (Left'Range (1), Right'Range (2)) do + if Left'Length (2) /= Right'Length (1) then + raise Constraint_Error with + "incompatible dimensions in matrix multiplication"; + end if; + + for J in R'Range (1) loop + for K in R'Range (2) loop + declare + S : Result_Scalar := Zero; + + begin + for M in Left'Range (2) loop + S := S + Left (J, M) * + Right + (M - Left'First (2) + Right'First (1), K); + end loop; + + R (J, K) := S; + end; + end loop; + end loop; + end return; + end Matrix_Matrix_Product; + + ---------------------------- + -- Matrix_Vector_Solution -- + ---------------------------- + + function Matrix_Vector_Solution (A : Matrix; X : Vector) return Vector is + N : constant Natural := A'Length (1); + MA : Matrix := A; + MX : Matrix (A'Range (1), 1 .. 1); + R : Vector (A'Range (2)); + Det : Scalar; + + begin + if A'Length (2) /= N then + raise Constraint_Error with "matrix is not square"; + end if; + + if X'Length /= N then + raise Constraint_Error with "incompatible vector length"; + end if; + + for J in 0 .. MX'Length (1) - 1 loop + MX (MX'First (1) + J, 1) := X (X'First + J); + end loop; + + Forward_Eliminate (MA, MX, Det); + + if Det = Zero then + raise Constraint_Error with "matrix is singular"; + end if; + + Back_Substitute (MA, MX); + + for J in 0 .. R'Length - 1 loop + R (R'First + J) := MX (MX'First (1) + J, 1); + end loop; + + return R; + end Matrix_Vector_Solution; + + ---------------------------- + -- Matrix_Matrix_Solution -- + ---------------------------- + + function Matrix_Matrix_Solution (A, X : Matrix) return Matrix is + N : constant Natural := A'Length (1); + MA : Matrix (A'Range (2), A'Range (2)); + MB : Matrix (A'Range (2), X'Range (2)); + Det : Scalar; + + begin + if A'Length (2) /= N then + raise Constraint_Error with "matrix is not square"; + end if; + + if X'Length (1) /= N then + raise Constraint_Error with "matrices have unequal number of rows"; + end if; + + for J in 0 .. A'Length (1) - 1 loop + for K in MA'Range (2) loop + MA (MA'First (1) + J, K) := A (A'First (1) + J, K); + end loop; + + for K in MB'Range (2) loop + MB (MB'First (1) + J, K) := X (X'First (1) + J, K); + end loop; + end loop; + + Forward_Eliminate (MA, MB, Det); + + if Det = Zero then + raise Constraint_Error with "matrix is singular"; + end if; + + Back_Substitute (MA, MB); + + return MB; + end Matrix_Matrix_Solution; + + --------------------------- + -- Matrix_Vector_Product -- + --------------------------- + + function Matrix_Vector_Product + (Left : Matrix; + Right : Right_Vector) return Result_Vector + is + begin + return R : Result_Vector (Left'Range (1)) do + if Left'Length (2) /= Right'Length then + raise Constraint_Error with + "incompatible dimensions in matrix-vector multiplication"; + end if; + + for J in Left'Range (1) loop + declare + S : Result_Scalar := Zero; + + begin + for K in Left'Range (2) loop + S := S + Left (J, K) + * Right (K - Left'First (2) + Right'First); + end loop; + + R (J) := S; + end; + end loop; + end return; + end Matrix_Vector_Product; + + ------------------- + -- Outer_Product -- + ------------------- + + function Outer_Product + (Left : Left_Vector; + Right : Right_Vector) return Matrix + is + begin + return R : Matrix (Left'Range, Right'Range) do + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := Left (J) * Right (K); + end loop; + end loop; + end return; + end Outer_Product; + + ----------------- + -- Swap_Column -- + ----------------- + + procedure Swap_Column (A : in out Matrix; Left, Right : Integer) is + Temp : Scalar; + begin + for J in A'Range (1) loop + Temp := A (J, Left); + A (J, Left) := A (J, Right); + A (J, Right) := Temp; + end loop; + end Swap_Column; + + --------------- + -- Transpose -- + --------------- + + procedure Transpose (A : Matrix; R : out Matrix) is + begin + for J in R'Range (1) loop + for K in R'Range (2) loop + R (J, K) := A (K - R'First (2) + A'First (1), + J - R'First (1) + A'First (2)); + end loop; + end loop; + end Transpose; + + ------------------------------- + -- Update_Matrix_With_Matrix -- + ------------------------------- + + procedure Update_Matrix_With_Matrix (X : in out X_Matrix; Y : Y_Matrix) is + begin + if X'Length (1) /= Y'Length (1) + or else + X'Length (2) /= Y'Length (2) + then + raise Constraint_Error with + "matrices are of different dimension in update operation"; + end if; + + for J in X'Range (1) loop + for K in X'Range (2) loop + Update (X (J, K), Y (J - X'First (1) + Y'First (1), + K - X'First (2) + Y'First (2))); + end loop; + end loop; + end Update_Matrix_With_Matrix; + + ------------------------------- + -- Update_Vector_With_Vector -- + ------------------------------- + + procedure Update_Vector_With_Vector (X : in out X_Vector; Y : Y_Vector) is + begin + if X'Length /= Y'Length then + raise Constraint_Error with + "vectors are of different length in update operation"; + end if; + + for J in X'Range loop + Update (X (J), Y (J - X'First + Y'First)); + end loop; + end Update_Vector_With_Vector; + + ----------------- + -- Unit_Matrix -- + ----------------- + + function Unit_Matrix + (Order : Positive; + First_1 : Integer := 1; + First_2 : Integer := 1) return Matrix + is + begin + return R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1), + First_2 .. Check_Unit_Last (First_2, Order, First_2)) + do + R := (others => (others => Zero)); + + for J in 0 .. Order - 1 loop + R (First_1 + J, First_2 + J) := One; + end loop; + end return; + end Unit_Matrix; + + ----------------- + -- Unit_Vector -- + ----------------- + + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Vector + is + begin + return R : Vector (First .. Check_Unit_Last (Index, Order, First)) do + R := (others => Zero); + R (Index) := One; + end return; + end Unit_Vector; + + --------------------------- + -- Vector_Matrix_Product -- + --------------------------- + + function Vector_Matrix_Product + (Left : Left_Vector; + Right : Matrix) return Result_Vector + is + begin + return R : Result_Vector (Right'Range (2)) do + if Left'Length /= Right'Length (1) then + raise Constraint_Error with + "incompatible dimensions in vector-matrix multiplication"; + end if; + + for J in Right'Range (2) loop + declare + S : Result_Scalar := Zero; + + begin + for K in Right'Range (1) loop + S := S + Left (K - Right'First (1) + + Left'First) * Right (K, J); + end loop; + + R (J) := S; + end; + end loop; + end return; + end Vector_Matrix_Product; + +end System.Generic_Array_Operations; diff --git a/gcc/ada/libgnat/s-gearop.ads b/gcc/ada/libgnat/s-gearop.ads new file mode 100644 index 0000000..cde4d13 --- /dev/null +++ b/gcc/ada/libgnat/s-gearop.ads @@ -0,0 +1,502 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ A R R A Y _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2006-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System.Generic_Array_Operations is +pragma Pure (Generic_Array_Operations); + + --------------------- + -- Back_Substitute -- + --------------------- + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + with function "-" (Left, Right : Scalar) return Scalar is <>; + with function "*" (Left, Right : Scalar) return Scalar is <>; + with function "/" (Left, Right : Scalar) return Scalar is <>; + with function Is_Non_Zero (X : Scalar) return Boolean is <>; + procedure Back_Substitute (M, N : in out Matrix); + + -------------- + -- Diagonal -- + -------------- + + generic + type Scalar is private; + type Vector is array (Integer range <>) of Scalar; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + function Diagonal (A : Matrix) return Vector; + + ----------------------- + -- Forward_Eliminate -- + ----------------------- + + -- Use elementary row operations to put square matrix M in row echolon + -- form. Identical row operations are performed on matrix N, must have the + -- same number of rows as M. + + generic + type Scalar is private; + type Real is digits <>; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + with function "abs" (Right : Scalar) return Real'Base is <>; + with function "-" (Left, Right : Scalar) return Scalar is <>; + with function "*" (Left, Right : Scalar) return Scalar is <>; + with function "/" (Left, Right : Scalar) return Scalar is <>; + Zero : Scalar; + One : Scalar; + procedure Forward_Eliminate + (M : in out Matrix; + N : in out Matrix; + Det : out Scalar); + + -------------------------- + -- Square_Matrix_Length -- + -------------------------- + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + function Square_Matrix_Length (A : Matrix) return Natural; + -- If A is non-square, raise Constraint_Error, else return its dimension + + ---------------------------------- + -- Vector_Elementwise_Operation -- + ---------------------------------- + + generic + type X_Scalar is private; + type Result_Scalar is private; + type X_Vector is array (Integer range <>) of X_Scalar; + type Result_Vector is array (Integer range <>) of Result_Scalar; + with function Operation (X : X_Scalar) return Result_Scalar; + function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector; + + ---------------------------------- + -- Matrix_Elementwise_Operation -- + ---------------------------------- + + generic + type X_Scalar is private; + type Result_Scalar is private; + type X_Matrix is array (Integer range <>, Integer range <>) of X_Scalar; + type Result_Matrix is array (Integer range <>, Integer range <>) + of Result_Scalar; + with function Operation (X : X_Scalar) return Result_Scalar; + function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix; + + ----------------------------------------- + -- Vector_Vector_Elementwise_Operation -- + ----------------------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Vector is array (Integer range <>) of Left_Scalar; + type Right_Vector is array (Integer range <>) of Right_Scalar; + type Result_Vector is array (Integer range <>) of Result_Scalar; + with function Operation + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar; + function Vector_Vector_Elementwise_Operation + (Left : Left_Vector; + Right : Right_Vector) return Result_Vector; + + ------------------------------------------------ + -- Vector_Vector_Scalar_Elementwise_Operation -- + ------------------------------------------------ + + generic + type X_Scalar is private; + type Y_Scalar is private; + type Z_Scalar is private; + type Result_Scalar is private; + type X_Vector is array (Integer range <>) of X_Scalar; + type Y_Vector is array (Integer range <>) of Y_Scalar; + type Result_Vector is array (Integer range <>) of Result_Scalar; + with function Operation + (X : X_Scalar; + Y : Y_Scalar; + Z : Z_Scalar) return Result_Scalar; + function Vector_Vector_Scalar_Elementwise_Operation + (X : X_Vector; + Y : Y_Vector; + Z : Z_Scalar) return Result_Vector; + + ----------------------------------------- + -- Matrix_Matrix_Elementwise_Operation -- + ----------------------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Matrix is array (Integer range <>, Integer range <>) + of Left_Scalar; + type Right_Matrix is array (Integer range <>, Integer range <>) + of Right_Scalar; + type Result_Matrix is array (Integer range <>, Integer range <>) + of Result_Scalar; + with function Operation + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar; + function Matrix_Matrix_Elementwise_Operation + (Left : Left_Matrix; + Right : Right_Matrix) return Result_Matrix; + + ------------------------------------------------ + -- Matrix_Matrix_Scalar_Elementwise_Operation -- + ------------------------------------------------ + + generic + type X_Scalar is private; + type Y_Scalar is private; + type Z_Scalar is private; + type Result_Scalar is private; + type X_Matrix is array (Integer range <>, Integer range <>) of X_Scalar; + type Y_Matrix is array (Integer range <>, Integer range <>) of Y_Scalar; + type Result_Matrix is array (Integer range <>, Integer range <>) + of Result_Scalar; + with function Operation + (X : X_Scalar; + Y : Y_Scalar; + Z : Z_Scalar) return Result_Scalar; + function Matrix_Matrix_Scalar_Elementwise_Operation + (X : X_Matrix; + Y : Y_Matrix; + Z : Z_Scalar) return Result_Matrix; + + ----------------------------------------- + -- Vector_Scalar_Elementwise_Operation -- + ----------------------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Vector is array (Integer range <>) of Left_Scalar; + type Result_Vector is array (Integer range <>) of Result_Scalar; + with function Operation + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar; + function Vector_Scalar_Elementwise_Operation + (Left : Left_Vector; + Right : Right_Scalar) return Result_Vector; + + ----------------------------------------- + -- Matrix_Scalar_Elementwise_Operation -- + ----------------------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Matrix is array (Integer range <>, Integer range <>) + of Left_Scalar; + type Result_Matrix is array (Integer range <>, Integer range <>) + of Result_Scalar; + with function Operation + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar; + function Matrix_Scalar_Elementwise_Operation + (Left : Left_Matrix; + Right : Right_Scalar) return Result_Matrix; + + ----------------------------------------- + -- Scalar_Vector_Elementwise_Operation -- + ----------------------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Right_Vector is array (Integer range <>) of Right_Scalar; + type Result_Vector is array (Integer range <>) of Result_Scalar; + with function Operation + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar; + function Scalar_Vector_Elementwise_Operation + (Left : Left_Scalar; + Right : Right_Vector) return Result_Vector; + + ----------------------------------------- + -- Scalar_Matrix_Elementwise_Operation -- + ----------------------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Right_Matrix is array (Integer range <>, Integer range <>) + of Right_Scalar; + type Result_Matrix is array (Integer range <>, Integer range <>) + of Result_Scalar; + with function Operation + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar; + function Scalar_Matrix_Elementwise_Operation + (Left : Left_Scalar; + Right : Right_Matrix) return Result_Matrix; + + ------------------- + -- Inner_Product -- + ------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Vector is array (Integer range <>) of Left_Scalar; + type Right_Vector is array (Integer range <>) of Right_Scalar; + Zero : Result_Scalar; + with function "*" + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar is <>; + with function "+" + (Left : Result_Scalar; + Right : Result_Scalar) return Result_Scalar is <>; + function Inner_Product + (Left : Left_Vector; + Right : Right_Vector) return Result_Scalar; + + ------------- + -- L2_Norm -- + ------------- + + generic + type X_Scalar is private; + type Result_Real is digits <>; + type X_Vector is array (Integer range <>) of X_Scalar; + with function "abs" (Right : X_Scalar) return Result_Real is <>; + with function Sqrt (X : Result_Real'Base) return Result_Real'Base is <>; + function L2_Norm (X : X_Vector) return Result_Real'Base; + + ------------------- + -- Outer_Product -- + ------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Vector is array (Integer range <>) of Left_Scalar; + type Right_Vector is array (Integer range <>) of Right_Scalar; + type Matrix is array (Integer range <>, Integer range <>) + of Result_Scalar; + with function "*" + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar is <>; + function Outer_Product + (Left : Left_Vector; + Right : Right_Vector) return Matrix; + + --------------------------- + -- Matrix_Vector_Product -- + --------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) + of Left_Scalar; + type Right_Vector is array (Integer range <>) of Right_Scalar; + type Result_Vector is array (Integer range <>) of Result_Scalar; + Zero : Result_Scalar; + with function "*" + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar is <>; + with function "+" + (Left : Result_Scalar; + Right : Result_Scalar) return Result_Scalar is <>; + function Matrix_Vector_Product + (Left : Matrix; + Right : Right_Vector) return Result_Vector; + + --------------------------- + -- Vector_Matrix_Product -- + --------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Vector is array (Integer range <>) of Left_Scalar; + type Matrix is array (Integer range <>, Integer range <>) + of Right_Scalar; + type Result_Vector is array (Integer range <>) of Result_Scalar; + Zero : Result_Scalar; + with function "*" + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar is <>; + with function "+" + (Left : Result_Scalar; + Right : Result_Scalar) return Result_Scalar is <>; + function Vector_Matrix_Product + (Left : Left_Vector; + Right : Matrix) return Result_Vector; + + --------------------------- + -- Matrix_Matrix_Product -- + --------------------------- + + generic + type Left_Scalar is private; + type Right_Scalar is private; + type Result_Scalar is private; + type Left_Matrix is array (Integer range <>, Integer range <>) + of Left_Scalar; + type Right_Matrix is array (Integer range <>, Integer range <>) + of Right_Scalar; + type Result_Matrix is array (Integer range <>, Integer range <>) + of Result_Scalar; + Zero : Result_Scalar; + with function "*" + (Left : Left_Scalar; + Right : Right_Scalar) return Result_Scalar is <>; + with function "+" + (Left : Result_Scalar; + Right : Result_Scalar) return Result_Scalar is <>; + function Matrix_Matrix_Product + (Left : Left_Matrix; + Right : Right_Matrix) return Result_Matrix; + + ---------------------------- + -- Matrix_Vector_Solution -- + ---------------------------- + + generic + type Scalar is private; + Zero : Scalar; + type Vector is array (Integer range <>) of Scalar; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + with procedure Back_Substitute (M, N : in out Matrix) is <>; + with procedure Forward_Eliminate + (M : in out Matrix; + N : in out Matrix; + Det : out Scalar) is <>; + function Matrix_Vector_Solution (A : Matrix; X : Vector) return Vector; + + ---------------------------- + -- Matrix_Matrix_Solution -- + ---------------------------- + + generic + type Scalar is private; + Zero : Scalar; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + with procedure Back_Substitute (M, N : in out Matrix) is <>; + with procedure Forward_Eliminate + (M : in out Matrix; + N : in out Matrix; + Det : out Scalar) is <>; + function Matrix_Matrix_Solution (A : Matrix; X : Matrix) return Matrix; + + ---------- + -- Sqrt -- + ---------- + + generic + type Real is digits <>; + function Sqrt (X : Real'Base) return Real'Base; + + ----------------- + -- Swap_Column -- + ----------------- + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + procedure Swap_Column (A : in out Matrix; Left, Right : Integer); + + --------------- + -- Transpose -- + --------------- + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + procedure Transpose (A : Matrix; R : out Matrix); + + ------------------------------- + -- Update_Vector_With_Vector -- + ------------------------------- + + generic + type X_Scalar is private; + type Y_Scalar is private; + type X_Vector is array (Integer range <>) of X_Scalar; + type Y_Vector is array (Integer range <>) of Y_Scalar; + with procedure Update (X : in out X_Scalar; Y : Y_Scalar); + procedure Update_Vector_With_Vector (X : in out X_Vector; Y : Y_Vector); + + ------------------------------- + -- Update_Matrix_With_Matrix -- + ------------------------------- + + generic + type X_Scalar is private; + type Y_Scalar is private; + type X_Matrix is array (Integer range <>, Integer range <>) of X_Scalar; + type Y_Matrix is array (Integer range <>, Integer range <>) of Y_Scalar; + with procedure Update (X : in out X_Scalar; Y : Y_Scalar); + procedure Update_Matrix_With_Matrix (X : in out X_Matrix; Y : Y_Matrix); + + ----------------- + -- Unit_Matrix -- + ----------------- + + generic + type Scalar is private; + type Matrix is array (Integer range <>, Integer range <>) of Scalar; + Zero : Scalar; + One : Scalar; + function Unit_Matrix + (Order : Positive; + First_1 : Integer := 1; + First_2 : Integer := 1) return Matrix; + + ----------------- + -- Unit_Vector -- + ----------------- + + generic + type Scalar is private; + type Vector is array (Integer range <>) of Scalar; + Zero : Scalar; + One : Scalar; + function Unit_Vector + (Index : Integer; + Order : Positive; + First : Integer := 1) return Vector; + +end System.Generic_Array_Operations; diff --git a/gcc/ada/libgnat/s-geveop.adb b/gcc/ada/libgnat/s-geveop.adb new file mode 100644 index 0000000..a5ebc78 --- /dev/null +++ b/gcc/ada/libgnat/s-geveop.adb @@ -0,0 +1,133 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ V E C T O R _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; use System; +with System.Address_Operations; use System.Address_Operations; +with System.Storage_Elements; use System.Storage_Elements; + +with Ada.Unchecked_Conversion; + +package body System.Generic_Vector_Operations is + + IU : constant Integer := Integer (Storage_Unit); + VU : constant Address := Address (Vectors.Vector'Size / IU); + EU : constant Address := Address (Element_Array'Component_Size / IU); + + ---------------------- + -- Binary_Operation -- + ---------------------- + + procedure Binary_Operation + (R, X, Y : System.Address; + Length : System.Storage_Elements.Storage_Count) + is + RA : Address := R; + XA : Address := X; + YA : Address := Y; + -- Address of next element to process in R, X and Y + + VI : constant Integer_Address := To_Integer (VU); + + Unaligned : constant Integer_Address := + Boolean'Pos (ModA (OrA (OrA (RA, XA), YA), VU) /= 0) - 1; + -- Zero iff one or more argument addresses is not aligned, else all 1's + + type Vector_Ptr is access all Vectors.Vector; + type Element_Ptr is access all Element; + + function VP is new Ada.Unchecked_Conversion (Address, Vector_Ptr); + function EP is new Ada.Unchecked_Conversion (Address, Element_Ptr); + + SA : constant Address := + AddA (XA, To_Address + ((Integer_Address (Length) / VI * VI) and Unaligned)); + -- First address of argument X to start serial processing + + begin + while XA < SA loop + VP (RA).all := Vector_Op (VP (XA).all, VP (YA).all); + XA := AddA (XA, VU); + YA := AddA (YA, VU); + RA := AddA (RA, VU); + end loop; + + while XA < X + Length loop + EP (RA).all := Element_Op (EP (XA).all, EP (YA).all); + XA := AddA (XA, EU); + YA := AddA (YA, EU); + RA := AddA (RA, EU); + end loop; + end Binary_Operation; + + ---------------------- + -- Unary_Operation -- + ---------------------- + + procedure Unary_Operation + (R, X : System.Address; + Length : System.Storage_Elements.Storage_Count) + is + RA : Address := R; + XA : Address := X; + -- Address of next element to process in R and X + + VI : constant Integer_Address := To_Integer (VU); + + Unaligned : constant Integer_Address := + Boolean'Pos (ModA (OrA (RA, XA), VU) /= 0) - 1; + -- Zero iff one or more argument addresses is not aligned, else all 1's + + type Vector_Ptr is access all Vectors.Vector; + type Element_Ptr is access all Element; + + function VP is new Ada.Unchecked_Conversion (Address, Vector_Ptr); + function EP is new Ada.Unchecked_Conversion (Address, Element_Ptr); + + SA : constant Address := + AddA (XA, To_Address + ((Integer_Address (Length) / VI * VI) and Unaligned)); + -- First address of argument X to start serial processing + + begin + while XA < SA loop + VP (RA).all := Vector_Op (VP (XA).all); + XA := AddA (XA, VU); + RA := AddA (RA, VU); + end loop; + + while XA < X + Length loop + EP (RA).all := Element_Op (EP (XA).all); + XA := AddA (XA, EU); + RA := AddA (RA, EU); + end loop; + end Unary_Operation; + +end System.Generic_Vector_Operations; diff --git a/gcc/ada/libgnat/s-geveop.ads b/gcc/ada/libgnat/s-geveop.ads new file mode 100644 index 0000000..26e5888 --- /dev/null +++ b/gcc/ada/libgnat/s-geveop.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . G E N E R I C _ V E C T O R _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains generic procedures for vector operations on arrays. +-- If the arguments are aligned on word boundaries and the word size is a +-- multiple M of the element size, the operations will be done M elements +-- at a time using vector operations on a word. + +-- All routines assume argument arrays have the same length, and arguments +-- with mode "in" do not alias arguments with mode "out" or "in out". +-- If the number N of elements to be processed is not a multiple of M +-- the final N rem M elements will be processed one item at a time. + +with System.Vectors; +with System.Storage_Elements; + +generic + type Element is (<>); + type Index is (<>); + type Element_Array is array (Index range <>) of Element; + +package System.Generic_Vector_Operations is + pragma Pure; + + generic + with function Element_Op (X, Y : Element) return Element; + with function Vector_Op (X, Y : Vectors.Vector) return Vectors.Vector; + procedure Binary_Operation + (R, X, Y : System.Address; + Length : System.Storage_Elements.Storage_Count); + + generic + with function Element_Op (X : Element) return Element; + with function Vector_Op (X : Vectors.Vector) return Vectors.Vector; + procedure Unary_Operation + (R, X : System.Address; + Length : System.Storage_Elements.Storage_Count); +end System.Generic_Vector_Operations; diff --git a/gcc/ada/libgnat/s-gloloc-mingw.adb b/gcc/ada/libgnat/s-gloloc-mingw.adb new file mode 100644 index 0000000..404f1c8 --- /dev/null +++ b/gcc/ada/libgnat/s-gloloc-mingw.adb @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . G L O B A L _ L O C K S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This implementation is specific to NT + +with System.OS_Interface; +with System.Task_Lock; +with System.Win32; + +with Interfaces.C.Strings; + +package body System.Global_Locks is + + package TSL renames System.Task_Lock; + package OSI renames System.OS_Interface; + package ICS renames Interfaces.C.Strings; + + subtype Lock_File_Entry is Win32.HANDLE; + + Last_Lock : Lock_Type := Null_Lock; + Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; + + ----------------- + -- Create_Lock -- + ----------------- + + procedure Create_Lock (Lock : out Lock_Type; Name : String) is + L : Lock_Type; + + begin + TSL.Lock; + Last_Lock := Last_Lock + 1; + L := Last_Lock; + TSL.Unlock; + + if L > Lock_Table'Last then + raise Lock_Error; + end if; + + Lock_Table (L) := + OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name)); + Lock := L; + end Create_Lock; + + ------------------ + -- Acquire_Lock -- + ------------------ + + procedure Acquire_Lock (Lock : in out Lock_Type) is + use type Win32.DWORD; + + Res : Win32.DWORD; + + begin + Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); + + if Res = OSI.WAIT_FAILED then + raise Lock_Error; + end if; + end Acquire_Lock; + + ------------------ + -- Release_Lock -- + ------------------ + + procedure Release_Lock (Lock : in out Lock_Type) is + use type Win32.BOOL; + + Res : Win32.BOOL; + + begin + Res := OSI.ReleaseMutex (Lock_Table (Lock)); + + if Res = Win32.FALSE then + raise Lock_Error; + end if; + end Release_Lock; + +end System.Global_Locks; diff --git a/gcc/ada/libgnat/s-gloloc.adb b/gcc/ada/libgnat/s-gloloc.adb new file mode 100644 index 0000000..7646c52 --- /dev/null +++ b/gcc/ada/libgnat/s-gloloc.adb @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . G L O B A L _ L O C K S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Soft_Links; + +package body System.Global_Locks is + + type String_Access is access String; + + Dir_Separator : Character; + pragma Import (C, Dir_Separator, "__gnat_dir_separator"); + + type Lock_File_Entry is record + Dir : String_Access; + File : String_Access; + end record; + + Last_Lock : Lock_Type := Null_Lock; + Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; + + procedure Lock_File + (Dir : String; + File : String; + Wait : Duration := 0.1; + Retries : Natural := Natural'Last); + -- Create a lock file File in directory Dir. If the file cannot be + -- locked because someone already owns the lock, this procedure + -- waits Wait seconds and retries at most Retries times. If the file + -- still cannot be locked, Lock_Error is raised. The default is to try + -- every second, almost forever (Natural'Last times). + + ------------------ + -- Acquire_Lock -- + ------------------ + + procedure Acquire_Lock (Lock : in out Lock_Type) is + begin + Lock_File + (Lock_Table (Lock).Dir.all, + Lock_Table (Lock).File.all); + end Acquire_Lock; + + ----------------- + -- Create_Lock -- + ----------------- + + procedure Create_Lock (Lock : out Lock_Type; Name : String) is + L : Lock_Type; + + begin + System.Soft_Links.Lock_Task.all; + Last_Lock := Last_Lock + 1; + L := Last_Lock; + System.Soft_Links.Unlock_Task.all; + + if L > Lock_Table'Last then + raise Lock_Error; + end if; + + for J in reverse Name'Range loop + if Name (J) = Dir_Separator then + Lock_Table (L).Dir := new String'(Name (Name'First .. J - 1)); + Lock_Table (L).File := new String'(Name (J + 1 .. Name'Last)); + exit; + end if; + end loop; + + if Lock_Table (L).Dir = null then + Lock_Table (L).Dir := new String'("."); + Lock_Table (L).File := new String'(Name); + end if; + + Lock := L; + end Create_Lock; + + --------------- + -- Lock_File -- + --------------- + + procedure Lock_File + (Dir : String; + File : String; + Wait : Duration := 0.1; + Retries : Natural := Natural'Last) + is + C_Dir : aliased String := Dir & ASCII.NUL; + C_File : aliased String := File & ASCII.NUL; + + function Try_Lock (Dir, File : System.Address) return Integer; + pragma Import (C, Try_Lock, "__gnat_try_lock"); + + begin + for I in 0 .. Retries loop + if Try_Lock (C_Dir'Address, C_File'Address) = 1 then + return; + end if; + + exit when I = Retries; + delay Wait; + end loop; + + raise Lock_Error; + end Lock_File; + + ------------------ + -- Release_Lock -- + ------------------ + + procedure Release_Lock (Lock : in out Lock_Type) is + S : aliased String := + Lock_Table (Lock).Dir.all & Dir_Separator & + Lock_Table (Lock).File.all & ASCII.NUL; + + procedure unlink (A : System.Address); + pragma Import (C, unlink, "unlink"); + + begin + unlink (S'Address); + end Release_Lock; + +end System.Global_Locks; diff --git a/gcc/ada/libgnat/s-gloloc.ads b/gcc/ada/libgnat/s-gloloc.ads new file mode 100644 index 0000000..f85247f --- /dev/null +++ b/gcc/ada/libgnat/s-gloloc.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . G L O B A L _ L O C K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + + -- This package contains the necessary routines to provide + -- reliable system wide locking capability. + +package System.Global_Locks is + + Lock_Error : exception; + -- Exception raised if a request cannot be executed on a lock + + type Lock_Type is private; + -- Such a lock is a global lock between partitions. This lock is + -- uniquely defined between the partitions because of its name. + + Null_Lock : constant Lock_Type; + -- This needs comments ??? + + procedure Create_Lock (Lock : out Lock_Type; Name : String); + -- Create or retrieve a global lock for the current partition using + -- its Name. + + procedure Acquire_Lock (Lock : in out Lock_Type); + -- If the lock cannot be acquired because someone already owns it, this + -- procedure is supposed to wait and retry forever. + + procedure Release_Lock (Lock : in out Lock_Type); + +private + + type Lock_Type is new Natural; + + Null_Lock : constant Lock_Type := 0; + +end System.Global_Locks; diff --git a/gcc/ada/libgnat/s-htable.adb b/gcc/ada/libgnat/s-htable.adb new file mode 100644 index 0000000..f72b6492 --- /dev/null +++ b/gcc/ada/libgnat/s-htable.adb @@ -0,0 +1,412 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . H T A B L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Deallocation; +with System.String_Hash; + +package body System.HTable is + + ------------------- + -- Static_HTable -- + ------------------- + + package body Static_HTable is + + Table : array (Header_Num) of Elmt_Ptr; + + Iterator_Index : Header_Num; + Iterator_Ptr : Elmt_Ptr; + Iterator_Started : Boolean := False; + + function Get_Non_Null return Elmt_Ptr; + -- Returns Null_Ptr if Iterator_Started is false or the Table is empty. + -- Returns Iterator_Ptr if non null, or the next non null element in + -- table if any. + + --------- + -- Get -- + --------- + + function Get (K : Key) return Elmt_Ptr is + Elmt : Elmt_Ptr; + + begin + Elmt := Table (Hash (K)); + loop + if Elmt = Null_Ptr then + return Null_Ptr; + + elsif Equal (Get_Key (Elmt), K) then + return Elmt; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First return Elmt_Ptr is + begin + Iterator_Started := True; + Iterator_Index := Table'First; + Iterator_Ptr := Table (Iterator_Index); + return Get_Non_Null; + end Get_First; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next return Elmt_Ptr is + begin + if not Iterator_Started then + return Null_Ptr; + else + Iterator_Ptr := Next (Iterator_Ptr); + return Get_Non_Null; + end if; + end Get_Next; + + ------------------ + -- Get_Non_Null -- + ------------------ + + function Get_Non_Null return Elmt_Ptr is + begin + while Iterator_Ptr = Null_Ptr loop + if Iterator_Index = Table'Last then + Iterator_Started := False; + return Null_Ptr; + end if; + + Iterator_Index := Iterator_Index + 1; + Iterator_Ptr := Table (Iterator_Index); + end loop; + + return Iterator_Ptr; + end Get_Non_Null; + + ------------- + -- Present -- + ------------- + + function Present (K : Key) return Boolean is + begin + return Get (K) /= Null_Ptr; + end Present; + + ------------ + -- Remove -- + ------------ + + procedure Remove (K : Key) is + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr; + Next_Elmt : Elmt_Ptr; + + begin + Elmt := Table (Index); + + if Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Elmt), K) then + Table (Index) := Next (Elmt); + + else + loop + Next_Elmt := Next (Elmt); + + if Next_Elmt = Null_Ptr then + return; + + elsif Equal (Get_Key (Next_Elmt), K) then + Set_Next (Elmt, Next (Next_Elmt)); + return; + + else + Elmt := Next_Elmt; + end if; + end loop; + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + begin + -- Use an aggregate for efficiency reasons + + Table := (others => Null_Ptr); + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (E : Elmt_Ptr) is + Index : Header_Num; + begin + Index := Hash (Get_Key (E)); + Set_Next (E, Table (Index)); + Table (Index) := E; + end Set; + + ------------------------ + -- Set_If_Not_Present -- + ------------------------ + + function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is + K : Key renames Get_Key (E); + -- Note that it is important to use a renaming here rather than + -- define a constant initialized by the call, because the latter + -- construct runs into bootstrap problems with earlier versions + -- of the GNAT compiler. + + Index : constant Header_Num := Hash (K); + Elmt : Elmt_Ptr; + + begin + Elmt := Table (Index); + loop + if Elmt = Null_Ptr then + Set_Next (E, Table (Index)); + Table (Index) := E; + return True; + + elsif Equal (Get_Key (Elmt), K) then + return False; + + else + Elmt := Next (Elmt); + end if; + end loop; + end Set_If_Not_Present; + + end Static_HTable; + + ------------------- + -- Simple_HTable -- + ------------------- + + package body Simple_HTable is + + type Element_Wrapper; + type Elmt_Ptr is access all Element_Wrapper; + type Element_Wrapper is record + K : Key; + E : Element; + Next : Elmt_Ptr; + end record; + + procedure Free is new + Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + function Next (E : Elmt_Ptr) return Elmt_Ptr; + function Get_Key (E : Elmt_Ptr) return Key; + + package Tab is new Static_HTable ( + Header_Num => Header_Num, + Element => Element_Wrapper, + Elmt_Ptr => Elmt_Ptr, + Null_Ptr => null, + Set_Next => Set_Next, + Next => Next, + Key => Key, + Get_Key => Get_Key, + Hash => Hash, + Equal => Equal); + + --------- + -- Get -- + --------- + + function Get (K : Key) return Element is + Tmp : constant Elmt_Ptr := Tab.Get (K); + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get; + + --------------- + -- Get_First -- + --------------- + + function Get_First return Element is + Tmp : constant Elmt_Ptr := Tab.Get_First; + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_First; + + procedure Get_First (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_First; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_First; + + ------------- + -- Get_Key -- + ------------- + + function Get_Key (E : Elmt_Ptr) return Key is + begin + return E.K; + end Get_Key; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next return Element is + Tmp : constant Elmt_Ptr := Tab.Get_Next; + begin + if Tmp = null then + return No_Element; + else + return Tmp.E; + end if; + end Get_Next; + + procedure Get_Next (K : in out Key; E : out Element) is + Tmp : constant Elmt_Ptr := Tab.Get_Next; + begin + if Tmp = null then + E := No_Element; + else + K := Tmp.K; + E := Tmp.E; + end if; + end Get_Next; + + ---------- + -- Next -- + ---------- + + function Next (E : Elmt_Ptr) return Elmt_Ptr is + begin + return E.Next; + end Next; + + ------------ + -- Remove -- + ------------ + + procedure Remove (K : Key) is + Tmp : Elmt_Ptr; + + begin + Tmp := Tab.Get (K); + + if Tmp /= null then + Tab.Remove (K); + Free (Tmp); + end if; + end Remove; + + ----------- + -- Reset -- + ----------- + + procedure Reset is + E1, E2 : Elmt_Ptr; + + begin + E1 := Tab.Get_First; + while E1 /= null loop + E2 := Tab.Get_Next; + Free (E1); + E1 := E2; + end loop; + + Tab.Reset; + end Reset; + + --------- + -- Set -- + --------- + + procedure Set (K : Key; E : Element) is + Tmp : constant Elmt_Ptr := Tab.Get (K); + begin + if Tmp = null then + Tab.Set (new Element_Wrapper'(K, E, null)); + else + Tmp.E := E; + end if; + end Set; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is + begin + E.Next := Next; + end Set_Next; + end Simple_HTable; + + ---------- + -- Hash -- + ---------- + + function Hash (Key : String) return Header_Num is + type Uns is mod 2 ** 32; + + function Hash_Fun is + new System.String_Hash.Hash (Character, String, Uns); + + begin + return Header_Num'First + + Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length); + end Hash; + +end System.HTable; diff --git a/gcc/ada/libgnat/s-htable.ads b/gcc/ada/libgnat/s-htable.ads new file mode 100644 index 0000000..b6d9960 --- /dev/null +++ b/gcc/ada/libgnat/s-htable.ads @@ -0,0 +1,222 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . H T A B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Hash table searching routines + +-- This package contains two separate packages. The Simple_HTable package +-- provides a very simple abstraction that associates one element to one +-- key value and takes care of all allocations automatically using the heap. +-- The Static_HTable package provides a more complex interface that allows +-- complete control over allocation. + +pragma Compiler_Unit_Warning; + +package System.HTable is + pragma Preelaborate; + + ------------------- + -- Simple_HTable -- + ------------------- + + -- A simple hash table abstraction, easy to instantiate, easy to use. + -- The table associates one element to one key with the procedure Set. + -- Get retrieves the Element stored for a given Key. The efficiency of + -- retrieval is function of the size of the Table parameterized by + -- Header_Num and the hashing function Hash. + + generic + type Header_Num is range <>; + -- An integer type indicating the number and range of hash headers + + type Element is private; + -- The type of element to be stored + + No_Element : Element; + -- The object that is returned by Get when no element has been set for + -- a given key + + type Key is private; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Simple_HTable is + + procedure Set (K : Key; E : Element); + -- Associates an element with a given key. Overrides any previously + -- associated element. + + procedure Reset; + -- Removes and frees all elements in the table + + function Get (K : Key) return Element; + -- Returns the Element associated with a key or No_Element if the + -- given key has no associated element. + + procedure Remove (K : Key); + -- Removes the latest inserted element pointer associated with the + -- given key if any, does nothing if none. + + function Get_First return Element; + -- Returns No_Element if the HTable is empty, otherwise returns one + -- non specified element. There is no guarantee that two calls to this + -- function will return the same element. + + function Get_Next return Element; + -- Returns a non-specified element that has not been returned by the + -- same function since the last call to Get_First or No_Element if + -- there is no such element. If there is no call to Set in between + -- Get_Next calls, all the elements of the HTable will be traversed. + + procedure Get_First (K : in out Key; E : out Element); + -- This version of the iterator returns a key/element pair. A non- + -- specified entry is returned, and there is no guarantee that two + -- calls to this procedure will return the same element. If the table + -- is empty, E is set to No_Element, and K is unchanged, otherwise + -- K and E are set to the first returned entry. + + procedure Get_Next (K : in out Key; E : out Element); + -- This version of the iterator returns a key/element pair. It returns + -- a non-specified element that has not been returned since the last + -- call to Get_First. If there is no remaining element, then E is set + -- to No_Element, and the value in K is unchanged, otherwise K and E + -- are set to the next entry. If there is no call to Set in between + -- Get_Next calls, all the elements of the HTable will be traversed. + + end Simple_HTable; + + ------------------- + -- Static_HTable -- + ------------------- + + -- A low-level Hash-Table abstraction, not as easy to instantiate as + -- Simple_HTable but designed to allow complete control over the + -- allocation of necessary data structures. Particularly useful when + -- dynamic allocation is not desired. The model is that each Element + -- contains its own Key that can be retrieved by Get_Key. Furthermore, + -- Element provides a link that can be used by the HTable for linking + -- elements with same hash codes: + + -- Element + + -- +-------------------+ + -- | Key | + -- +-------------------+ + -- : other data : + -- +-------------------+ + -- | Next Elmt | + -- +-------------------+ + + generic + type Header_Num is range <>; + -- An integer type indicating the number and range of hash headers + + type Element (<>) is limited private; + -- The type of element to be stored. This is historically part of the + -- interface, even though it is not used at all in the operations of + -- the package. + + pragma Warnings (Off, Element); + -- We have to kill warnings here, because Element is and always + -- has been unreferenced, but we cannot remove it at this stage, + -- since this unit is in wide use, and it certainly seems harmless. + + type Elmt_Ptr is private; + -- The type used to reference an element (will usually be an access + -- type, but could be some other form of type such as an integer type). + + Null_Ptr : Elmt_Ptr; + -- The null value of the Elmt_Ptr type + + with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); + with function Next (E : Elmt_Ptr) return Elmt_Ptr; + -- The type must provide an internal link for the sake of the + -- staticness of the HTable. + + type Key is limited private; + with function Get_Key (E : Elmt_Ptr) return Key; + with function Hash (F : Key) return Header_Num; + with function Equal (F1, F2 : Key) return Boolean; + + package Static_HTable is + + procedure Reset; + -- Resets the hash table by setting all its elements to Null_Ptr. The + -- effect is to clear the hash table so that it can be reused. For the + -- most common case where Elmt_Ptr is an access type, and Null_Ptr is + -- null, this is only needed if the same table is reused in a new + -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is + -- other than null, then Reset must be called before the first use + -- of the hash table. + + procedure Set (E : Elmt_Ptr); + -- Insert the element pointer in the HTable + + function Get (K : Key) return Elmt_Ptr; + -- Returns the latest inserted element pointer with the given Key + -- or null if none. + + function Present (K : Key) return Boolean; + -- True if an element whose Get_Key is K is in the table + + function Set_If_Not_Present (E : Elmt_Ptr) return Boolean; + -- If Present (Get_Key (E)), returns False. Otherwise, does Set (E), and + -- then returns True. Present (Get_Key (E)) is always True afterward, + -- and the result True indicates E is newly Set. + + procedure Remove (K : Key); + -- Removes the latest inserted element pointer associated with the + -- given key if any, does nothing if none. + + function Get_First return Elmt_Ptr; + -- Returns Null_Ptr if the HTable is empty, otherwise returns one + -- non specified element. There is no guarantee that two calls to this + -- function will return the same element. + + function Get_Next return Elmt_Ptr; + -- Returns a non-specified element that has not been returned by the + -- same function since the last call to Get_First or Null_Ptr if + -- there is no such element or Get_First has never been called. If + -- there is no call to 'Set' in between Get_Next calls, all the + -- elements of the HTable will be traversed. + + end Static_HTable; + + ---------- + -- Hash -- + ---------- + + -- A generic hashing function working on String keys + + generic + type Header_Num is range <>; + function Hash (Key : String) return Header_Num; + +end System.HTable; diff --git a/gcc/ada/libgnat/s-imenne.adb b/gcc/ada/libgnat/s-imenne.adb new file mode 100644 index 0000000..c57e66b --- /dev/null +++ b/gcc/ada/libgnat/s-imenne.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ N E W -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Conversion; + +package body System.Img_Enum_New is + + ------------------------- + -- Image_Enumeration_8 -- + ------------------------- + + procedure Image_Enumeration_8 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + is + pragma Assert (S'First = 1); + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : constant Natural := Natural (IndexesT (Pos)); + Next : constant Natural := Natural (IndexesT (Pos + 1)); + + begin + S (1 .. Next - Start) := Names (Start .. Next - 1); + P := Next - Start; + end Image_Enumeration_8; + + -------------------------- + -- Image_Enumeration_16 -- + -------------------------- + + procedure Image_Enumeration_16 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + is + pragma Assert (S'First = 1); + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : constant Natural := Natural (IndexesT (Pos)); + Next : constant Natural := Natural (IndexesT (Pos + 1)); + + begin + S (1 .. Next - Start) := Names (Start .. Next - 1); + P := Next - Start; + end Image_Enumeration_16; + + -------------------------- + -- Image_Enumeration_32 -- + -------------------------- + + procedure Image_Enumeration_32 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address) + is + pragma Assert (S'First = 1); + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : constant Natural := Natural (IndexesT (Pos)); + Next : constant Natural := Natural (IndexesT (Pos + 1)); + + begin + S (1 .. Next - Start) := Names (Start .. Next - 1); + P := Next - Start; + end Image_Enumeration_32; + +end System.Img_Enum_New; diff --git a/gcc/ada/libgnat/s-imenne.ads b/gcc/ada/libgnat/s-imenne.ads new file mode 100644 index 0000000..8d169e3 --- /dev/null +++ b/gcc/ada/libgnat/s-imenne.ads @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M _ N E W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Enumeration_Type'Image for all enumeration types except those in package +-- Standard (where we have no opportunity to build image tables), and in +-- package System (where it is too early to start building image tables). +-- Special routines exist for the enumeration types in these packages. + +-- This is the new version of the package, for use by compilers built after +-- Nov 21st, 2007, which provides procedures that avoid using the secondary +-- stack. The original package System.Img_Enum is maintained in the sources +-- for bootstrapping with older versions of the compiler which expect to find +-- functions in this package. + +pragma Compiler_Unit_Warning; + +package System.Img_Enum_New is + pragma Pure; + + procedure Image_Enumeration_8 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address); + -- Used to compute Enum'Image (Str) where Enum is some enumeration type + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address of + -- an array of type array (0 .. N) of Natural_8, where N is the number of + -- enumeration literals in the type. The Indexes values are the starting + -- subscript of each enumeration literal, indexed by Pos values, with an + -- extra entry at the end containing Names'Length + 1. The reason that + -- Indexes is passed by address is that the actual type is created on the + -- fly by the expander. The desired 'Image value is stored in S (1 .. P) + -- and P is set on return. The caller guarantees that S is long enough to + -- hold the result and that the lower bound is 1. + + procedure Image_Enumeration_16 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address); + -- Identical to Set_Image_Enumeration_8 except that it handles types using + -- array (0 .. Num) of Natural_16 for the Indexes table. + + procedure Image_Enumeration_32 + (Pos : Natural; + S : in out String; + P : out Natural; + Names : String; + Indexes : System.Address); + -- Identical to Set_Image_Enumeration_8 except that it handles types using + -- array (0 .. Num) of Natural_32 for the Indexes table. + +end System.Img_Enum_New; diff --git a/gcc/ada/libgnat/s-imgbiu.adb b/gcc/ada/libgnat/s-imgbiu.adb new file mode 100644 index 0000000..b0aa714 --- /dev/null +++ b/gcc/ada/libgnat/s-imgbiu.adb @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B I U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_BIU is + + ----------------------------- + -- Set_Image_Based_Integer -- + ----------------------------- + + procedure Set_Image_Based_Integer + (V : Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Based_Integer; + + ------------------------------ + -- Set_Image_Based_Unsigned -- + ------------------------------ + + procedure Set_Image_Based_Unsigned + (V : Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + BU : constant Unsigned := Unsigned (B); + Hex : constant array + (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF"; + + procedure Set_Digits (T : Unsigned); + -- Set digits of absolute value of T + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Unsigned) is + begin + if T >= BU then + Set_Digits (T / BU); + P := P + 1; + S (P) := Hex (T mod BU); + else + P := P + 1; + S (P) := Hex (T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Based_Unsigned + + begin + + if B >= 10 then + P := P + 1; + S (P) := '1'; + end if; + + P := P + 1; + S (P) := Character'Val (Character'Pos ('0') + B mod 10); + + P := P + 1; + S (P) := '#'; + + Set_Digits (V); + + P := P + 1; + S (P) := '#'; + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := Start + W; + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Based_Unsigned; + +end System.Img_BIU; diff --git a/gcc/ada/libgnat/s-imgbiu.ads b/gcc/ada/libgnat/s-imgbiu.ads new file mode 100644 index 0000000..4a1a5cc --- /dev/null +++ b/gcc/ada/libgnat/s-imgbiu.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B I U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image in based format of signed and +-- unsigned integers whose size <= Integer'Size for use by Text_IO.Integer_IO +-- and Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_BIU is + pragma Pure; + + procedure Set_Image_Based_Integer + (V : Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes a leading minus sign if necessary, but no leading + -- spaces unless W is positive, in which case leading spaces are output if + -- necessary to ensure that the output string is no less than W characters + -- long. The caller promises that the buffer is large enough and no check + -- is made for this. Constraint_Error will not necessarily be raised if + -- this is violated, since it is perfectly valid to compile this unit with + -- checks off. + + procedure Set_Image_Based_Unsigned + (V : System.Unsigned_Types.Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes no leading spaces unless W is positive, in which case + -- leading spaces are output if necessary to ensure that the output string + -- is no less than W characters long. The caller promises that the buffer + -- is large enough and no check is made for this. Constraint_Error will not + -- necessarily be raised if this is violated, since it is perfectly valid + -- to compile this unit with checks off). + +end System.Img_BIU; diff --git a/gcc/ada/libgnat/s-imgboo.adb b/gcc/ada/libgnat/s-imgboo.adb new file mode 100644 index 0000000..618d0aa --- /dev/null +++ b/gcc/ada/libgnat/s-imgboo.adb @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B O O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Img_Bool is + + ------------------- + -- Image_Boolean -- + ------------------- + + procedure Image_Boolean + (V : Boolean; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + begin + if V then + S (1 .. 4) := "TRUE"; + P := 4; + else + S (1 .. 5) := "FALSE"; + P := 5; + end if; + end Image_Boolean; + +end System.Img_Bool; diff --git a/gcc/ada/libgnat/s-imgboo.ads b/gcc/ada/libgnat/s-imgboo.ads new file mode 100644 index 0000000..8b27511 --- /dev/null +++ b/gcc/ada/libgnat/s-imgboo.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ B O O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Boolean'Image + +package System.Img_Bool is + pragma Pure; + + procedure Image_Boolean + (V : Boolean; + S : in out String; + P : out Natural); + -- Computes Boolean'Image (V) and stores the result in S (1 .. P) + -- setting the resulting value of P. The caller guarantees that S + -- is long enough to hold the result, and that S'First is 1. + +end System.Img_Bool; diff --git a/gcc/ada/libgnat/s-imgcha.adb b/gcc/ada/libgnat/s-imgcha.adb new file mode 100644 index 0000000..30b0388 --- /dev/null +++ b/gcc/ada/libgnat/s-imgcha.adb @@ -0,0 +1,180 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Img_Char is + + --------------------- + -- Image_Character -- + --------------------- + + procedure Image_Character + (V : Character; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + + subtype Cname is String (1 .. 3); + + subtype C0_Range is Character + range Character'Val (16#00#) .. Character'Val (16#1F#); + + C0 : constant array (C0_Range) of Cname := + (Character'Val (16#00#) => "NUL", + Character'Val (16#01#) => "SOH", + Character'Val (16#02#) => "STX", + Character'Val (16#03#) => "ETX", + Character'Val (16#04#) => "EOT", + Character'Val (16#05#) => "ENQ", + Character'Val (16#06#) => "ACK", + Character'Val (16#07#) => "BEL", + Character'Val (16#08#) => "BS ", + Character'Val (16#09#) => "HT ", + Character'Val (16#0A#) => "LF ", + Character'Val (16#0B#) => "VT ", + Character'Val (16#0C#) => "FF ", + Character'Val (16#0D#) => "CR ", + Character'Val (16#0E#) => "SO ", + Character'Val (16#0F#) => "SI ", + Character'Val (16#10#) => "DLE", + Character'Val (16#11#) => "DC1", + Character'Val (16#12#) => "DC2", + Character'Val (16#13#) => "DC3", + Character'Val (16#14#) => "DC4", + Character'Val (16#15#) => "NAK", + Character'Val (16#16#) => "SYN", + Character'Val (16#17#) => "ETB", + Character'Val (16#18#) => "CAN", + Character'Val (16#19#) => "EM ", + Character'Val (16#1A#) => "SUB", + Character'Val (16#1B#) => "ESC", + Character'Val (16#1C#) => "FS ", + Character'Val (16#1D#) => "GS ", + Character'Val (16#1E#) => "RS ", + Character'Val (16#1F#) => "US "); + + subtype C1_Range is Character + range Character'Val (16#7F#) .. Character'Val (16#9F#); + + C1 : constant array (C1_Range) of Cname := + (Character'Val (16#7F#) => "DEL", + Character'Val (16#80#) => "res", + Character'Val (16#81#) => "res", + Character'Val (16#82#) => "BPH", + Character'Val (16#83#) => "NBH", + Character'Val (16#84#) => "res", + Character'Val (16#85#) => "NEL", + Character'Val (16#86#) => "SSA", + Character'Val (16#87#) => "ESA", + Character'Val (16#88#) => "HTS", + Character'Val (16#89#) => "HTJ", + Character'Val (16#8A#) => "VTS", + Character'Val (16#8B#) => "PLD", + Character'Val (16#8C#) => "PLU", + Character'Val (16#8D#) => "RI ", + Character'Val (16#8E#) => "SS2", + Character'Val (16#8F#) => "SS3", + Character'Val (16#90#) => "DCS", + Character'Val (16#91#) => "PU1", + Character'Val (16#92#) => "PU2", + Character'Val (16#93#) => "STS", + Character'Val (16#94#) => "CCH", + Character'Val (16#95#) => "MW ", + Character'Val (16#96#) => "SPA", + Character'Val (16#97#) => "EPA", + Character'Val (16#98#) => "SOS", + Character'Val (16#99#) => "res", + Character'Val (16#9A#) => "SCI", + Character'Val (16#9B#) => "CSI", + Character'Val (16#9C#) => "ST ", + Character'Val (16#9D#) => "OSC", + Character'Val (16#9E#) => "PM ", + Character'Val (16#9F#) => "APC"); + + begin + -- Control characters are represented by their names (RM 3.5(32)) + + if V in C0_Range then + S (1 .. 3) := C0 (V); + P := (if S (3) = ' ' then 2 else 3); + + elsif V in C1_Range then + S (1 .. 3) := C1 (V); + + if S (1) /= 'r' then + P := (if S (3) = ' ' then 2 else 3); + + -- Special case, res means RESERVED_nnn where nnn is the three digit + -- decimal value corresponding to the code position (more efficient + -- to compute than to store). + + else + declare + VP : constant Natural := Character'Pos (V); + begin + S (1 .. 9) := "RESERVED_"; + S (10) := Character'Val (48 + VP / 100); + S (11) := Character'Val (48 + (VP / 10) mod 10); + S (12) := Character'Val (48 + VP mod 10); + P := 12; + end; + end if; + + -- Normal characters yield the character enclosed in quotes (RM 3.5(32)) + + else + S (1) := '''; + S (2) := V; + S (3) := '''; + P := 3; + end if; + end Image_Character; + + ------------------------ + -- Image_Character_05 -- + ------------------------ + + procedure Image_Character_05 + (V : Character; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + begin + if V = Character'Val (16#00AD#) then + P := 11; + S (1 .. P) := "SOFT_HYPHEN"; + else + Image_Character (V, S, P); + end if; + end Image_Character_05; + +end System.Img_Char; diff --git a/gcc/ada/libgnat/s-imgcha.ads b/gcc/ada/libgnat/s-imgcha.ads new file mode 100644 index 0000000..604bc88 --- /dev/null +++ b/gcc/ada/libgnat/s-imgcha.ads @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Character'Image + +package System.Img_Char is + pragma Pure; + + procedure Image_Character + (V : Character; + S : in out String; + P : out Natural); + -- Computes Character'Image (V) and stores the result in S (1 .. P) + -- setting the resulting value of P. The caller guarantees that S is + -- long enough to hold the result, and that S'First is 1. + + procedure Image_Character_05 + (V : Character; + S : in out String; + P : out Natural); + -- Computes Character'Image (V) and stores the result in S (1 .. P) + -- setting the resulting value of P. The caller guarantees that S is + -- long enough to hold the result, and that S'First is 1. This version + -- is for use in Ada 2005 and beyond, where soft hyphen is a non-graphic + -- and results in "SOFT_HYPHEN" as the output. + +end System.Img_Char; diff --git a/gcc/ada/libgnat/s-imgdec.adb b/gcc/ada/libgnat/s-imgdec.adb new file mode 100644 index 0000000..765a7e8 --- /dev/null +++ b/gcc/ada/libgnat/s-imgdec.adb @@ -0,0 +1,420 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ D E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Img_Int; use System.Img_Int; + +package body System.Img_Dec is + + ------------------- + -- Image_Decimal -- + ------------------- + + procedure Image_Decimal + (V : Integer; + S : in out String; + P : out Natural; + Scale : Integer) + is + pragma Assert (S'First = 1); + + begin + -- Add space at start for non-negative numbers + + if V >= 0 then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); + end Image_Decimal; + + ------------------------ + -- Set_Decimal_Digits -- + ------------------------ + + procedure Set_Decimal_Digits + (Digs : in out String; + NDigs : Natural; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + Minus : constant Boolean := (Digs (Digs'First) = '-'); + -- Set True if input is negative + + Zero : Boolean := (Digs (Digs'First + 1) = '0'); + -- Set True if input is exactly zero (only case when a leading zero + -- is permitted in the input string given to this procedure). This + -- flag can get set later if rounding causes the value to become zero. + + FD : Natural := 2; + -- First digit position of digits remaining to be processed + + LD : Natural := NDigs; + -- Last digit position of digits remaining to be processed + + ND : Natural := NDigs - 1; + -- Number of digits remaining to be processed (LD - FD + 1) + + Digits_Before_Point : Integer := ND - Scale; + -- Number of digits before decimal point in the input value. This + -- value can be negative if the input value is less than 0.1, so + -- it is an indication of the current exponent. Digits_Before_Point + -- is adjusted if the rounding step generates an extra digit. + + Digits_After_Point : constant Natural := Integer'Max (1, Aft); + -- Digit positions after decimal point in result string + + Expon : Integer; + -- Integer value of exponent + + procedure Round (N : Integer); + -- Round the number in Digs. N is the position of the last digit to be + -- retained in the rounded position (rounding is based on Digs (N + 1) + -- FD, LD, ND are reset as necessary if required. Note that if the + -- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be + -- placed in the sign position as a result of the rounding, this is + -- the case in which FD is adjusted. The call to Round has no effect + -- if N is outside the range FD .. LD. + + procedure Set (C : Character); + pragma Inline (Set); + -- Sets character C in output buffer + + procedure Set_Blanks_And_Sign (N : Integer); + -- Sets leading blanks and minus sign if needed. N is the number of + -- positions to be filled (a minus sign is output even if N is zero + -- or negative, For a positive value, if N is non-positive, then + -- a leading blank is filled. + + procedure Set_Digits (S, E : Natural); + pragma Inline (Set_Digits); + -- Set digits S through E from Digs, no effect if S > E + + procedure Set_Zeroes (N : Integer); + pragma Inline (Set_Zeroes); + -- Set N zeroes, no effect if N is negative + + ----------- + -- Round -- + ----------- + + procedure Round (N : Integer) is + D : Character; + + begin + -- Nothing to do if rounding past the last digit we have + + if N >= LD then + return; + + -- Cases of rounding before the initial digit + + elsif N < FD then + + -- The result is zero, unless we are rounding just before + -- the first digit, and the first digit is five or more. + + if N = 1 and then Digs (Digs'First + 1) >= '5' then + Digs (Digs'First) := '1'; + else + Digs (Digs'First) := '0'; + Zero := True; + end if; + + Digits_Before_Point := Digits_Before_Point + 1; + FD := 1; + LD := 1; + ND := 1; + + -- Normal case of rounding an existing digit + + else + LD := N; + ND := LD - 1; + + if Digs (N + 1) >= '5' then + for J in reverse 2 .. N loop + D := Character'Succ (Digs (J)); + + if D <= '9' then + Digs (J) := D; + return; + else + Digs (J) := '0'; + end if; + end loop; + + -- Here the rounding overflows into the sign position. That's + -- OK, because we already captured the value of the sign and + -- we are in any case destroying the value in the Digs buffer + + Digs (Digs'First) := '1'; + FD := 1; + ND := ND + 1; + Digits_Before_Point := Digits_Before_Point + 1; + end if; + end if; + end Round; + + --------- + -- Set -- + --------- + + procedure Set (C : Character) is + begin + P := P + 1; + S (P) := C; + end Set; + + ------------------------- + -- Set_Blanks_And_Sign -- + ------------------------- + + procedure Set_Blanks_And_Sign (N : Integer) is + W : Integer := N; + + begin + if Minus then + W := W - 1; + + for J in 1 .. W loop + Set (' '); + end loop; + + Set ('-'); + + else + for J in 1 .. W loop + Set (' '); + end loop; + end if; + end Set_Blanks_And_Sign; + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (S, E : Natural) is + begin + for J in S .. E loop + Set (Digs (J)); + end loop; + end Set_Digits; + + ---------------- + -- Set_Zeroes -- + ---------------- + + procedure Set_Zeroes (N : Integer) is + begin + for J in 1 .. N loop + Set ('0'); + end loop; + end Set_Zeroes; + + -- Start of processing for Set_Decimal_Digits + + begin + -- Case of exponent given + + if Exp > 0 then + Set_Blanks_And_Sign (Fore - 1); + Round (Digits_After_Point + 2); + Set (Digs (FD)); + FD := FD + 1; + ND := ND - 1; + Set ('.'); + + if ND >= Digits_After_Point then + Set_Digits (FD, FD + Digits_After_Point - 1); + else + Set_Digits (FD, LD); + Set_Zeroes (Digits_After_Point - ND); + end if; + + -- Calculate exponent. The number of digits before the decimal point + -- in the input is Digits_Before_Point, and the number of digits + -- before the decimal point in the output is 1, so we can get the + -- exponent as the difference between these two values. The one + -- exception is for the value zero, which by convention has an + -- exponent of +0. + + Expon := (if Zero then 0 else Digits_Before_Point - 1); + Set ('E'); + ND := 0; + + if Expon >= 0 then + Set ('+'); + Set_Image_Integer (Expon, Digs, ND); + else + Set ('-'); + Set_Image_Integer (-Expon, Digs, ND); + end if; + + Set_Zeroes (Exp - ND - 1); + Set_Digits (1, ND); + return; + + -- Case of no exponent given. To make these cases clear, we use + -- examples. For all the examples, we assume Fore = 2, Aft = 3. + -- A P in the example input string is an implied zero position, + -- not included in the input string. + + else + -- Round at correct position + -- Input: 4PP => unchanged + -- Input: 400.03 => unchanged + -- Input 3.4567 => 3.457 + -- Input: 9.9999 => 10.000 + -- Input: 0.PPP5 => 0.001 + -- Input: 0.PPP4 => 0 + -- Input: 0.00003 => 0 + + Round (LD - (Scale - Digits_After_Point)); + + -- No digits before point in input + -- Input: .123 Output: 0.123 + -- Input: .PP3 Output: 0.003 + + if Digits_Before_Point <= 0 then + Set_Blanks_And_Sign (Fore - 1); + Set ('0'); + Set ('.'); + + declare + DA : Natural := Digits_After_Point; + -- Digits remaining to output after point + + LZ : constant Integer := Integer'Min (DA, -Digits_Before_Point); + -- Number of leading zeroes after point. Note: there used to be + -- a Max of this result with zero, but that's redundant, since + -- we know DA is positive, and because of the test above, we + -- know that -Digits_Before_Point >= 0. + + begin + Set_Zeroes (LZ); + DA := DA - LZ; + + if DA < ND then + + -- Note: it is definitely possible for the above condition + -- to be True, for example: + + -- V => 1234, Scale => 5, Fore => 0, After => 1, Exp => 0 + + -- but in this case DA = 0, ND = 1, FD = 1, FD + DA-1 = 0 + -- so the arguments in the call are (1, 0) meaning that no + -- digits are output. + + -- No obvious example exists where the following call to + -- Set_Digits actually outputs some digits, but we lack a + -- proof that no such example exists. + + -- So it is safer to retain this call, even though as a + -- result it is hard (or perhaps impossible) to create a + -- coverage test for the inlined code of the call. + + Set_Digits (FD, FD + DA - 1); + + else + Set_Digits (FD, LD); + Set_Zeroes (DA - ND); + end if; + end; + + -- At least one digit before point in input + + else + -- Less digits in input than are needed before point + -- Input: 1PP Output: 100.000 + + if ND < Digits_Before_Point then + + -- Special case, if the input is the single digit 0, then we + -- do not want 000.000, but instead 0.000. + + if ND = 1 and then Digs (FD) = '0' then + Set_Blanks_And_Sign (Fore - 1); + Set ('0'); + + -- Normal case where we need to output scaling zeroes + + else + Set_Blanks_And_Sign (Fore - Digits_Before_Point); + Set_Digits (FD, LD); + Set_Zeroes (Digits_Before_Point - ND); + end if; + + -- Set period and zeroes after the period + + Set ('.'); + Set_Zeroes (Digits_After_Point); + + -- Input has full amount of digits before decimal point + + else + Set_Blanks_And_Sign (Fore - Digits_Before_Point); + Set_Digits (FD, FD + Digits_Before_Point - 1); + Set ('.'); + Set_Digits (FD + Digits_Before_Point, LD); + Set_Zeroes (Digits_After_Point - (ND - Digits_Before_Point)); + end if; + end if; + end if; + end Set_Decimal_Digits; + + ----------------------- + -- Set_Image_Decimal -- + ----------------------- + + procedure Set_Image_Decimal + (V : Integer; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + Digs : String := Integer'Image (V); + -- Sign and digits of decimal value + + begin + Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); + end Set_Image_Decimal; + +end System.Img_Dec; diff --git a/gcc/ada/libgnat/s-imgdec.ads b/gcc/ada/libgnat/s-imgdec.ads new file mode 100644 index 0000000..9534952 --- /dev/null +++ b/gcc/ada/libgnat/s-imgdec.ads @@ -0,0 +1,83 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ D E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Image for decimal fixed types where the size of the corresponding integer +-- type does not exceed Integer'Size (also used for Text_IO.Decimal_IO output) + +package System.Img_Dec is + pragma Pure; + + procedure Image_Decimal + (V : Integer; + S : in out String; + P : out Natural; + Scale : Integer); + -- Computes fixed_type'Image (V), where V is the integer value (in units of + -- delta) of a decimal type whose Scale is as given and stores the result + -- S (1 .. P), updating P to the value of L. The image is given by the + -- rules in RM 3.5(34) for fixed-point type image functions. The caller + -- guarantees that S is long enough to hold the result. S need not have a + -- lower bound of 1. + + procedure Set_Image_Decimal + (V : Integer; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of V, where V is the integer value (in units of delta) + -- of a decimal type with the given Scale, starting at S (P + 1), updating + -- P to point to the last character stored, the caller promises that the + -- buffer is large enough and no check is made for this. Constraint_Error + -- will not necessarily be raised if this requirement is violated, since + -- it is perfectly valid to compile this unit with checks off. The Fore, + -- Aft and Exp values can be set to any valid values for the case of use + -- by Text_IO.Decimal_IO. Note that there is no leading space stored. + + procedure Set_Decimal_Digits + (Digs : in out String; + NDigs : Natural; + S : out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- This procedure has the same semantics as Set_Image_Decimal, except that + -- the value in Digs (1 .. NDigs) is given as a string of decimal digits + -- preceded by either a minus sign or a space (i.e. the integer image of + -- the value in units of delta). The call may destroy the value in Digs, + -- which is why Digs is in-out (this happens if rounding is required). + -- Set_Decimal_Digits is shared by all the decimal image routines. + +end System.Img_Dec; diff --git a/gcc/ada/libgnat/s-imgenu.adb b/gcc/ada/libgnat/s-imgenu.adb new file mode 100644 index 0000000..7efad43 --- /dev/null +++ b/gcc/ada/libgnat/s-imgenu.adb @@ -0,0 +1,128 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Conversion; + +package body System.Img_Enum is + + ------------------------- + -- Image_Enumeration_8 -- + ------------------------- + + function Image_Enumeration_8 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String + is + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : constant Natural := Natural (IndexesT (Pos)); + Next : constant Natural := Natural (IndexesT (Pos + 1)); + + subtype Result_Type is String (1 .. Next - Start); + -- We need this result type to force the result to have the + -- required lower bound of 1, rather than the slice bounds. + + begin + return Result_Type (Names (Start .. Next - 1)); + end Image_Enumeration_8; + + -------------------------- + -- Image_Enumeration_16 -- + -------------------------- + + function Image_Enumeration_16 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String + is + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : constant Natural := Natural (IndexesT (Pos)); + Next : constant Natural := Natural (IndexesT (Pos + 1)); + + subtype Result_Type is String (1 .. Next - Start); + -- We need this result type to force the result to have the + -- required lower bound of 1, rather than the slice bounds. + + begin + return Result_Type (Names (Start .. Next - 1)); + end Image_Enumeration_16; + + -------------------------- + -- Image_Enumeration_32 -- + -------------------------- + + function Image_Enumeration_32 + (Pos : Natural; + Names : String; + Indexes : System.Address) + return String + is + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + Start : constant Natural := Natural (IndexesT (Pos)); + Next : constant Natural := Natural (IndexesT (Pos + 1)); + + subtype Result_Type is String (1 .. Next - Start); + -- We need this result type to force the result to have the + -- required lower bound of 1, rather than the slice bounds. + + begin + return Result_Type (Names (Start .. Next - 1)); + end Image_Enumeration_32; + +end System.Img_Enum; diff --git a/gcc/ada/libgnat/s-imgenu.ads b/gcc/ada/libgnat/s-imgenu.ads new file mode 100644 index 0000000..716328c --- /dev/null +++ b/gcc/ada/libgnat/s-imgenu.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Enumeration_Type'Image for all enumeration types except those in package +-- Standard (where we have no opportunity to build image tables), and in +-- package System (where it is too early to start building image tables). +-- Special routines exist for the enumeration types in these packages. + +-- Note: this is an obsolete package, replaced by System.Img_Enum_New, which +-- provides procedures instead of functions for these enumeration image calls. +-- The reason we maintain this package is that when bootstrapping with old +-- compilers, the old compiler will search for this unit, expecting to find +-- these functions. The new compiler will search for procedures in the new +-- version of the unit. + +pragma Compiler_Unit_Warning; + +package System.Img_Enum is + pragma Pure; + + function Image_Enumeration_8 + (Pos : Natural; + Names : String; + Indexes : System.Address) return String; + -- Used to compute Enum'Image (Str) where Enum is some enumeration type + -- other than those defined in package Standard. Names is a string with a + -- lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address of an + -- array of type array (0 .. N) of Natural_8, where N is the number of + -- enumeration literals in the type. The Indexes values are the starting + -- subscript of each enumeration literal, indexed by Pos values, with an + -- extra entry at the end containing Names'Length + 1. The reason that + -- Indexes is passed by address is that the actual type is created on the + -- fly by the expander. The value returned is the desired 'Image value. + + function Image_Enumeration_16 + (Pos : Natural; + Names : String; + Indexes : System.Address) return String; + -- Identical to Image_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Image_Enumeration_32 + (Pos : Natural; + Names : String; + Indexes : System.Address) return String; + -- Identical to Image_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + +end System.Img_Enum; diff --git a/gcc/ada/libgnat/s-imgint.adb b/gcc/ada/libgnat/s-imgint.adb new file mode 100644 index 0000000..551a9e8 --- /dev/null +++ b/gcc/ada/libgnat/s-imgint.adb @@ -0,0 +1,103 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ I N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Img_Int is + + procedure Set_Digits + (T : Integer; + S : in out String; + P : in out Natural); + -- Set digits of absolute value of T, which is zero or negative. We work + -- with the negative of the value so that the largest negative number is + -- not a special case. + + ------------------- + -- Image_Integer -- + ------------------- + + procedure Image_Integer + (V : Integer; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + + begin + if V >= 0 then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Integer (V, S, P); + end Image_Integer; + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits + (T : Integer; + S : in out String; + P : in out Natural) + is + begin + if T <= -10 then + Set_Digits (T / 10, S, P); + P := P + 1; + S (P) := Character'Val (48 - (T rem 10)); + else + P := P + 1; + S (P) := Character'Val (48 - T); + end if; + end Set_Digits; + + ----------------------- + -- Set_Image_Integer -- + ----------------------- + + procedure Set_Image_Integer + (V : Integer; + S : in out String; + P : in out Natural) + is + begin + if V >= 0 then + Set_Digits (-V, S, P); + else + P := P + 1; + S (P) := '-'; + Set_Digits (V, S, P); + end if; + end Set_Image_Integer; + +end System.Img_Int; diff --git a/gcc/ada/libgnat/s-imgint.ads b/gcc/ada/libgnat/s-imgint.ads new file mode 100644 index 0000000..d1cfcdc --- /dev/null +++ b/gcc/ada/libgnat/s-imgint.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ I N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- signed integer types up to Size Integer'Size, and also for conversion +-- operations required in Text_IO.Integer_IO for such types. + +package System.Img_Int is + pragma Pure; + + procedure Image_Integer + (V : Integer; + S : in out String; + P : out Natural); + -- Computes Integer'Image (V) and stores the result in S (1 .. P) + -- setting the resulting value of P. The caller guarantees that S + -- is long enough to hold the result, and that S'First is 1. + + procedure Set_Image_Integer + (V : Integer; + S : in out String; + P : in out Natural); + -- Stores the image of V in S starting at S (P + 1), P is updated to point + -- to the last character stored. The value stored is identical to the value + -- of Integer'Image (V) except that no leading space is stored when V is + -- non-negative. The caller guarantees that S is long enough to hold the + -- result. S need not have a lower bound of 1. + +end System.Img_Int; diff --git a/gcc/ada/libgnat/s-imgllb.adb b/gcc/ada/libgnat/s-imgllb.adb new file mode 100644 index 0000000..769ad23 --- /dev/null +++ b/gcc/ada/libgnat/s-imgllb.adb @@ -0,0 +1,161 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_LLB is + + --------------------------------------- + -- Set_Image_Based_Long_Long_Integer -- + --------------------------------------- + + procedure Set_Image_Based_Long_Long_Integer + (V : Long_Long_Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Based_Long_Long_Unsigned + (Long_Long_Unsigned (V), B, W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Based_Long_Long_Unsigned + (Long_Long_Unsigned (-V), B, W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Based_Long_Long_Integer; + + ---------------------------------------- + -- Set_Image_Based_Long_Long_Unsigned -- + ---------------------------------------- + + procedure Set_Image_Based_Long_Long_Unsigned + (V : Long_Long_Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + BU : constant Long_Long_Unsigned := Long_Long_Unsigned (B); + Hex : constant array + (Long_Long_Unsigned range 0 .. 15) of Character := + "0123456789ABCDEF"; + + procedure Set_Digits (T : Long_Long_Unsigned); + -- Set digits of absolute value of T + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Long_Long_Unsigned) is + begin + if T >= BU then + Set_Digits (T / BU); + P := P + 1; + S (P) := Hex (T mod BU); + else + P := P + 1; + S (P) := Hex (T); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Based_Long_Long_Unsigned + + begin + + if B >= 10 then + P := P + 1; + S (P) := '1'; + end if; + + P := P + 1; + S (P) := Character'Val (Character'Pos ('0') + B mod 10); + + P := P + 1; + S (P) := '#'; + + Set_Digits (V); + + P := P + 1; + S (P) := '#'; + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := Start + W; + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Based_Long_Long_Unsigned; + +end System.Img_LLB; diff --git a/gcc/ada/libgnat/s-imgllb.ads b/gcc/ada/libgnat/s-imgllb.ads new file mode 100644 index 0000000..a569a2f --- /dev/null +++ b/gcc/ada/libgnat/s-imgllb.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image in based format of signed and +-- unsigned integers whose size > Integer'Size for use by Text_IO.Integer_IO +-- and Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_LLB is + pragma Preelaborate; + + procedure Set_Image_Based_Long_Long_Integer + (V : Long_Long_Integer; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes a leading minus sign if necessary, but no leading + -- spaces unless W is positive, in which case leading spaces are output if + -- necessary to ensure that the output string is no less than W characters + -- long. The caller promises that the buffer is large enough and no check + -- is made for this. Constraint_Error will not necessarily be raised if + -- this is violated, since it is perfectly valid to compile this unit with + -- checks off. + + procedure Set_Image_Based_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + B : Natural; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in based format, using base value B (2..16) + -- starting at S (P + 1), updating P to point to the last character stored. + -- The image includes no leading spaces unless W is positive, in which case + -- leading spaces are output if necessary to ensure that the output string + -- is no less than W characters long. The caller promises that the buffer + -- is large enough and no check is made for this. Constraint_Error will not + -- necessarily be raised if this is violated, since it is perfectly valid + -- to compile this unit with checks off). + +end System.Img_LLB; diff --git a/gcc/ada/libgnat/s-imglld.adb b/gcc/ada/libgnat/s-imglld.adb new file mode 100644 index 0000000..a76b2b0 --- /dev/null +++ b/gcc/ada/libgnat/s-imglld.adb @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Img_Dec; use System.Img_Dec; + +package body System.Img_LLD is + + ----------------------------- + -- Image_Long_Long_Decimal -- + ---------------------------- + + procedure Image_Long_Long_Decimal + (V : Long_Long_Integer; + S : in out String; + P : out Natural; + Scale : Integer) + is + pragma Assert (S'First = 1); + + begin + -- Add space at start for non-negative numbers + + if V >= 0 then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Long_Long_Decimal + (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); + end Image_Long_Long_Decimal; + + --------------------------------- + -- Set_Image_Long_Long_Decimal -- + --------------------------------- + + procedure Set_Image_Long_Long_Decimal + (V : Long_Long_Integer; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + Digs : String := Long_Long_Integer'Image (V); + -- Sign and digits of decimal value + + begin + Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); + end Set_Image_Long_Long_Decimal; + +end System.Img_LLD; diff --git a/gcc/ada/libgnat/s-imglld.ads b/gcc/ada/libgnat/s-imglld.ads new file mode 100644 index 0000000..58d0405 --- /dev/null +++ b/gcc/ada/libgnat/s-imglld.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Image for decimal fixed types where the size of the corresponding integer +-- type does exceeds Integer'Size (also used for Text_IO.Decimal_IO output) + +package System.Img_LLD is + pragma Pure; + + procedure Image_Long_Long_Decimal + (V : Long_Long_Integer; + S : in out String; + P : out Natural; + Scale : Integer); + -- Computes fixed_type'Image (V), where V is the integer value (in units of + -- delta) of a decimal type whose Scale is as given and store the result in + -- S (P + 1 .. L), updating P to the value of L. The image is given by the + -- rules in RM 3.5(34) for fixed-point type image functions. The caller + -- guarantees that S is long enough to hold the result. S need not have a + -- lower bound of 1. + + procedure Set_Image_Long_Long_Decimal + (V : Long_Long_Integer; + S : in out String; + P : in out Natural; + Scale : Integer; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of V, where V is the integer value (in units of delta) + -- of a decimal type with the given Scale, starting at S (P + 1), updating + -- P to point to the last character stored, the caller promises that the + -- buffer is large enough and no check is made for this. Constraint_Error + -- will not necessarily be raised if this requirement is violated, since + -- it is perfectly valid to compile this unit with checks off. The Fore, + -- Aft and Exp values can be set to any valid values for the case of use + -- by Text_IO.Decimal_IO. Note that there is no leading space stored. + +end System.Img_LLD; diff --git a/gcc/ada/libgnat/s-imglli.adb b/gcc/ada/libgnat/s-imglli.adb new file mode 100644 index 0000000..b2dc8f6 --- /dev/null +++ b/gcc/ada/libgnat/s-imglli.adb @@ -0,0 +1,102 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Img_LLI is + + procedure Set_Digits + (T : Long_Long_Integer; + S : in out String; + P : in out Natural); + -- Set digits of absolute value of T, which is zero or negative. We work + -- with the negative of the value so that the largest negative number is + -- not a special case. + + ----------------------------- + -- Image_Long_Long_Integer -- + ----------------------------- + + procedure Image_Long_Long_Integer + (V : Long_Long_Integer; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + + begin + if V >= 0 then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Long_Long_Integer (V, S, P); + end Image_Long_Long_Integer; + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits + (T : Long_Long_Integer; + S : in out String; + P : in out Natural) + is + begin + if T <= -10 then + Set_Digits (T / 10, S, P); + P := P + 1; + S (P) := Character'Val (48 - (T rem 10)); + else + P := P + 1; + S (P) := Character'Val (48 - T); + end if; + end Set_Digits; + + --------------------------------- + -- Set_Image_Long_Long_Integer -- + -------------------------------- + + procedure Set_Image_Long_Long_Integer + (V : Long_Long_Integer; + S : in out String; + P : in out Natural) is + begin + if V >= 0 then + Set_Digits (-V, S, P); + else + P := P + 1; + S (P) := '-'; + Set_Digits (V, S, P); + end if; + end Set_Image_Long_Long_Integer; + +end System.Img_LLI; diff --git a/gcc/ada/libgnat/s-imglli.ads b/gcc/ada/libgnat/s-imglli.ads new file mode 100644 index 0000000..5354b8c --- /dev/null +++ b/gcc/ada/libgnat/s-imglli.ads @@ -0,0 +1,57 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- signed integer types larger than Size Integer'Size, and also for conversion +-- operations required in Text_IO.Integer_IO for such types. + +package System.Img_LLI is + pragma Pure; + + procedure Image_Long_Long_Integer + (V : Long_Long_Integer; + S : in out String; + P : out Natural); + -- Computes Long_Long_Integer'Image (V) and stores the result in + -- S (1 .. P) setting the resulting value of P. The caller guarantees + -- that S is long enough to hold the result, and that S'First is 1. + + procedure Set_Image_Long_Long_Integer + (V : Long_Long_Integer; + S : in out String; + P : in out Natural); + -- Stores the image of V in S starting at S (P + 1), P is updated to point + -- to the last character stored. The value stored is identical to the value + -- of Long_Long_Integer'Image (V) except that no leading space is stored + -- when V is non-negative. The caller guarantees that S is long enough to + -- hold the result. S need not have a lower bound of 1. + +end System.Img_LLI; diff --git a/gcc/ada/libgnat/s-imgllu.adb b/gcc/ada/libgnat/s-imgllu.adb new file mode 100644 index 0000000..d14a5da --- /dev/null +++ b/gcc/ada/libgnat/s-imgllu.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_LLU is + + ------------------------------ + -- Image_Long_Long_Unsigned -- + ------------------------------ + + procedure Image_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + begin + S (1) := ' '; + P := 1; + Set_Image_Long_Long_Unsigned (V, S, P); + end Image_Long_Long_Unsigned; + + ---------------------------------- + -- Set_Image_Long_Long_Unsigned -- + ---------------------------------- + + procedure Set_Image_Long_Long_Unsigned + (V : Long_Long_Unsigned; + S : in out String; + P : in out Natural) + is + begin + if V >= 10 then + Set_Image_Long_Long_Unsigned (V / 10, S, P); + P := P + 1; + S (P) := Character'Val (48 + (V rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 + V); + end if; + end Set_Image_Long_Long_Unsigned; + +end System.Img_LLU; diff --git a/gcc/ada/libgnat/s-imgllu.ads b/gcc/ada/libgnat/s-imgllu.ads new file mode 100644 index 0000000..bc39892 --- /dev/null +++ b/gcc/ada/libgnat/s-imgllu.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- unsigned (modular) integer types larger than Size Unsigned'Size, and also +-- for conversion operations required in Text_IO.Modular_IO for such types. + +with System.Unsigned_Types; + +package System.Img_LLU is + pragma Pure; + + procedure Image_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + S : in out String; + P : out Natural); + pragma Inline (Image_Long_Long_Unsigned); + + -- Computes Long_Long_Unsigned'Image (V) and stores the result in + -- S (1 .. P) setting the resulting value of P. The caller guarantees + -- that S is long enough to hold the result, and that S'First is 1. + + procedure Set_Image_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + S : in out String; + P : in out Natural); + -- Stores the image of V in S starting at S (P + 1), P is updated to point + -- to the last character stored. The value stored is identical to the value + -- of Long_Long_Unsigned'Image (V) except that no leading space is stored. + -- The caller guarantees that S is long enough to hold the result. S need + -- not have a lower bound of 1. + +end System.Img_LLU; diff --git a/gcc/ada/libgnat/s-imgllw.adb b/gcc/ada/libgnat/s-imgllw.adb new file mode 100644 index 0000000..b0236db --- /dev/null +++ b/gcc/ada/libgnat/s-imgllw.adb @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L W -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_LLW is + + --------------------------------------- + -- Set_Image_Width_Long_Long_Integer -- + --------------------------------------- + + procedure Set_Image_Width_Long_Long_Integer + (V : Long_Long_Integer; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Width_Long_Long_Unsigned + (Long_Long_Unsigned (V), W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Width_Long_Long_Unsigned + (Long_Long_Unsigned (-V), W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Width_Long_Long_Integer; + + ---------------------------------------- + -- Set_Image_Width_Long_Long_Unsigned -- + ---------------------------------------- + + procedure Set_Image_Width_Long_Long_Unsigned + (V : Long_Long_Unsigned; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + + procedure Set_Digits (T : Long_Long_Unsigned); + -- Set digits of absolute value of T + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Long_Long_Unsigned) is + begin + if T >= 10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (T mod 10 + Character'Pos ('0')); + else + P := P + 1; + S (P) := Character'Val (T + Character'Pos ('0')); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Width_Long_Long_Unsigned + + begin + Set_Digits (V); + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := P + (W - (P - Start)); + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Width_Long_Long_Unsigned; + +end System.Img_LLW; diff --git a/gcc/ada/libgnat/s-imgllw.ads b/gcc/ada/libgnat/s-imgllw.ads new file mode 100644 index 0000000..ce11d34 --- /dev/null +++ b/gcc/ada/libgnat/s-imgllw.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ L L W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image of signed and unsigned +-- integers whose size > Integer'Size for use by Text_IO.Integer_IO, +-- Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_LLW is + pragma Pure; + + procedure Set_Image_Width_Long_Long_Integer + (V : Long_Long_Integer; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes + -- a leading minus sign if necessary, but no leading spaces unless W is + -- positive, in which case leading spaces are output if necessary to ensure + -- that the output string is no less than W characters long. The caller + -- promises that the buffer is large enough and no check is made for this. + -- Constraint_Error will not necessarily be raised if this is violated, + -- since it is perfectly valid to compile this unit with checks off. + + procedure Set_Image_Width_Long_Long_Unsigned + (V : System.Unsigned_Types.Long_Long_Unsigned; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes no + -- leading spaces unless W is positive, in which case leading spaces are + -- output if necessary to ensure that the output string is no less than + -- W characters long. The caller promises that the buffer is large enough + -- and no check is made for this. Constraint_Error will not necessarily be + -- raised if this is violated, since it is perfectly valid to compile this + -- unit with checks off. + +end System.Img_LLW; diff --git a/gcc/ada/libgnat/s-imgrea.adb b/gcc/ada/libgnat/s-imgrea.adb new file mode 100644 index 0000000..61b32c8 --- /dev/null +++ b/gcc/ada/libgnat/s-imgrea.adb @@ -0,0 +1,699 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ R E A L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Img_LLU; use System.Img_LLU; +with System.Img_Uns; use System.Img_Uns; +with System.Powten_Table; use System.Powten_Table; +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Float_Control; + +package body System.Img_Real is + + -- The following defines the maximum number of digits that we can convert + -- accurately. This is limited by the precision of Long_Long_Float, and + -- also by the number of digits we can hold in Long_Long_Unsigned, which + -- is the integer type we use as an intermediate for the result. + + -- We assume that in practice, the limitation will come from the digits + -- value, rather than the integer value. This is true for typical IEEE + -- implementations, and at worst, the only loss is for some precision + -- in very high precision floating-point output. + + -- Note that in the following, the "-2" accounts for the sign and one + -- extra digits, since we need the maximum number of 9's that can be + -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width + -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits, + -- but the maximum number of 9's that can be supported is 19. + + Maxdigs : constant := + Natural'Min + (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits); + + Unsdigs : constant := Unsigned'Width - 2; + -- Number of digits that can be converted using type Unsigned + -- See above for the explanation of the -2. + + Maxscaling : constant := 5000; + -- Max decimal scaling required during conversion of floating-point + -- numbers to decimal. This is used to defend against infinite + -- looping in the conversion, as can be caused by erroneous executions. + -- The largest exponent used on any current system is 2**16383, which + -- is approximately 10**4932, and the highest number of decimal digits + -- is about 35 for 128-bit floating-point formats, so 5000 leaves + -- enough room for scaling such values + + function Is_Negative (V : Long_Long_Float) return Boolean; + pragma Import (Intrinsic, Is_Negative); + + -------------------------- + -- Image_Floating_Point -- + -------------------------- + + procedure Image_Floating_Point + (V : Long_Long_Float; + S : in out String; + P : out Natural; + Digs : Natural) + is + pragma Assert (S'First = 1); + + begin + -- Decide whether a blank should be prepended before the call to + -- Set_Image_Real. We generate a blank for positive values, and + -- also for positive zeroes. For negative zeroes, we generate a + -- space only if Signed_Zeroes is True (the RM only permits the + -- output of -0.0 on targets where this is the case). We can of + -- course still see a -0.0 on a target where Signed_Zeroes is + -- False (since this attribute refers to the proper handling of + -- negative zeroes, not to their existence). We do not generate + -- a blank for positive infinity, since we output an explicit +. + + if (not Is_Negative (V) and then V <= Long_Long_Float'Last) + or else (not Long_Long_Float'Signed_Zeros and then V = -0.0) + then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Real (V, S, P, 1, Digs - 1, 3); + end Image_Floating_Point; + + -------------------------------- + -- Image_Ordinary_Fixed_Point -- + -------------------------------- + + procedure Image_Ordinary_Fixed_Point + (V : Long_Long_Float; + S : in out String; + P : out Natural; + Aft : Natural) + is + pragma Assert (S'First = 1); + + begin + -- Output space at start if non-negative + + if V >= 0.0 then + S (1) := ' '; + P := 1; + else + P := 0; + end if; + + Set_Image_Real (V, S, P, 1, Aft, 0); + end Image_Ordinary_Fixed_Point; + + -------------------- + -- Set_Image_Real -- + -------------------- + + procedure Set_Image_Real + (V : Long_Long_Float; + S : out String; + P : in out Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural) + is + NFrac : constant Natural := Natural'Max (Aft, 1); + Sign : Character; + X : Long_Long_Float; + Scale : Integer; + Expon : Integer; + + Field_Max : constant := 255; + -- This should be the same value as Ada.[Wide_]Text_IO.Field'Last. + -- It is not worth dragging in Ada.Text_IO to pick up this value, + -- since it really should never be necessary to change it. + + Digs : String (1 .. 2 * Field_Max + 16); + -- Array used to hold digits of converted integer value. This is a + -- large enough buffer to accommodate ludicrous values of Fore and Aft. + + Ndigs : Natural; + -- Number of digits stored in Digs (and also subscript of last digit) + + procedure Adjust_Scale (S : Natural); + -- Adjusts the value in X by multiplying or dividing by a power of + -- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes + -- adding 0.5 to round the result, readjusting if the rounding causes + -- the result to wander out of the range. Scale is adjusted to reflect + -- the power of ten used to divide the result (i.e. one is added to + -- the scale value for each division by 10.0, or one is subtracted + -- for each multiplication by 10.0). + + procedure Convert_Integer; + -- Takes the value in X, outputs integer digits into Digs. On return, + -- Ndigs is set to the number of digits stored. The digits are stored + -- in Digs (1 .. Ndigs), + + procedure Set (C : Character); + -- Sets character C in output buffer + + procedure Set_Blanks_And_Sign (N : Integer); + -- Sets leading blanks and minus sign if needed. N is the number of + -- positions to be filled (a minus sign is output even if N is zero + -- or negative, but for a positive value, if N is non-positive, then + -- the call has no effect). + + procedure Set_Digs (S, E : Natural); + -- Set digits S through E from Digs buffer. No effect if S > E + + procedure Set_Special_Fill (N : Natural); + -- After outputting +Inf, -Inf or NaN, this routine fills out the + -- rest of the field with * characters. The argument is the number + -- of characters output so far (either 3 or 4) + + procedure Set_Zeros (N : Integer); + -- Set N zeros, no effect if N is negative + + pragma Inline (Set); + pragma Inline (Set_Digs); + pragma Inline (Set_Zeros); + + ------------------ + -- Adjust_Scale -- + ------------------ + + procedure Adjust_Scale (S : Natural) is + Lo : Natural; + Hi : Natural; + Mid : Natural; + XP : Long_Long_Float; + + begin + -- Cases where scaling up is required + + if X < Powten (S - 1) then + + -- What we are looking for is a power of ten to multiply X by + -- so that the result lies within the required range. + + loop + XP := X * Powten (Maxpow); + exit when XP >= Powten (S - 1) or else Scale < -Maxscaling; + X := XP; + Scale := Scale - Maxpow; + end loop; + + -- The following exception is only raised in case of erroneous + -- execution, where a number was considered valid but still + -- fails to scale up. One situation where this can happen is + -- when a system which is supposed to be IEEE-compliant, but + -- has been reconfigured to flush denormals to zero. + + if Scale < -Maxscaling then + raise Constraint_Error; + end if; + + -- Here we know that we must multiply by at least 10**1 and that + -- 10**Maxpow takes us too far: binary search to find right one. + + -- Because of roundoff errors, it is possible for the value + -- of XP to be just outside of the interval when Lo >= Hi. In + -- that case we adjust explicitly by a factor of 10. This + -- can only happen with a value that is very close to an + -- exact power of 10. + + Lo := 1; + Hi := Maxpow; + + loop + Mid := (Lo + Hi) / 2; + XP := X * Powten (Mid); + + if XP < Powten (S - 1) then + + if Lo >= Hi then + Mid := Mid + 1; + XP := XP * 10.0; + exit; + + else + Lo := Mid + 1; + end if; + + elsif XP >= Powten (S) then + + if Lo >= Hi then + Mid := Mid - 1; + XP := XP / 10.0; + exit; + + else + Hi := Mid - 1; + end if; + + else + exit; + end if; + end loop; + + X := XP; + Scale := Scale - Mid; + + -- Cases where scaling down is required + + elsif X >= Powten (S) then + + -- What we are looking for is a power of ten to divide X by + -- so that the result lies within the required range. + + loop + XP := X / Powten (Maxpow); + exit when XP < Powten (S) or else Scale > Maxscaling; + X := XP; + Scale := Scale + Maxpow; + end loop; + + -- The following exception is only raised in case of erroneous + -- execution, where a number was considered valid but still + -- fails to scale up. One situation where this can happen is + -- when a system which is supposed to be IEEE-compliant, but + -- has been reconfigured to flush denormals to zero. + + if Scale > Maxscaling then + raise Constraint_Error; + end if; + + -- Here we know that we must divide by at least 10**1 and that + -- 10**Maxpow takes us too far, binary search to find right one. + + Lo := 1; + Hi := Maxpow; + + loop + Mid := (Lo + Hi) / 2; + XP := X / Powten (Mid); + + if XP < Powten (S - 1) then + + if Lo >= Hi then + XP := XP * 10.0; + Mid := Mid - 1; + exit; + + else + Hi := Mid - 1; + end if; + + elsif XP >= Powten (S) then + + if Lo >= Hi then + XP := XP / 10.0; + Mid := Mid + 1; + exit; + + else + Lo := Mid + 1; + end if; + + else + exit; + end if; + end loop; + + X := XP; + Scale := Scale + Mid; + + -- Here we are already scaled right + + else + null; + end if; + + -- Round, readjusting scale if needed. Note that if a readjustment + -- occurs, then it is never necessary to round again, because there + -- is no possibility of such a second rounding causing a change. + + X := X + 0.5; + + if X >= Powten (S) then + X := X / 10.0; + Scale := Scale + 1; + end if; + + end Adjust_Scale; + + --------------------- + -- Convert_Integer -- + --------------------- + + procedure Convert_Integer is + begin + -- Use Unsigned routine if possible, since on many machines it will + -- be significantly more efficient than the Long_Long_Unsigned one. + + if X < Powten (Unsdigs) then + Ndigs := 0; + Set_Image_Unsigned + (Unsigned (Long_Long_Float'Truncation (X)), + Digs, Ndigs); + + -- But if we want more digits than fit in Unsigned, we have to use + -- the Long_Long_Unsigned routine after all. + + else + Ndigs := 0; + Set_Image_Long_Long_Unsigned + (Long_Long_Unsigned (Long_Long_Float'Truncation (X)), + Digs, Ndigs); + end if; + end Convert_Integer; + + --------- + -- Set -- + --------- + + procedure Set (C : Character) is + begin + P := P + 1; + S (P) := C; + end Set; + + ------------------------- + -- Set_Blanks_And_Sign -- + ------------------------- + + procedure Set_Blanks_And_Sign (N : Integer) is + begin + if Sign = '-' then + for J in 1 .. N - 1 loop + Set (' '); + end loop; + + Set ('-'); + + else + for J in 1 .. N loop + Set (' '); + end loop; + end if; + end Set_Blanks_And_Sign; + + -------------- + -- Set_Digs -- + -------------- + + procedure Set_Digs (S, E : Natural) is + begin + for J in S .. E loop + Set (Digs (J)); + end loop; + end Set_Digs; + + ---------------------- + -- Set_Special_Fill -- + ---------------------- + + procedure Set_Special_Fill (N : Natural) is + F : Natural; + + begin + F := Fore + 1 + Aft - N; + + if Exp /= 0 then + F := F + Exp + 1; + end if; + + for J in 1 .. F loop + Set ('*'); + end loop; + end Set_Special_Fill; + + --------------- + -- Set_Zeros -- + --------------- + + procedure Set_Zeros (N : Integer) is + begin + for J in 1 .. N loop + Set ('0'); + end loop; + end Set_Zeros; + + -- Start of processing for Set_Image_Real + + begin + -- We call the floating-point processor reset routine so that we can + -- be sure the floating-point processor is properly set for conversion + -- calls. This is notably need on Windows, where calls to the operating + -- system randomly reset the processor into 64-bit mode. + + System.Float_Control.Reset; + + Scale := 0; + + -- Deal with invalid values first, + + if not V'Valid then + + -- Note that we're taking our chances here, as V might be + -- an invalid bit pattern resulting from erroneous execution + -- (caused by using uninitialized variables for example). + + -- No matter what, we'll at least get reasonable behavior, + -- converting to infinity or some other value, or causing an + -- exception to be raised is fine. + + -- If the following test succeeds, then we definitely have + -- an infinite value, so we print Inf. + + if V > Long_Long_Float'Last then + Set ('+'); + Set ('I'); + Set ('n'); + Set ('f'); + Set_Special_Fill (4); + + -- In all other cases we print NaN + + elsif V < Long_Long_Float'First then + Set ('-'); + Set ('I'); + Set ('n'); + Set ('f'); + Set_Special_Fill (4); + + else + Set ('N'); + Set ('a'); + Set ('N'); + Set_Special_Fill (3); + end if; + + return; + end if; + + -- Positive values + + if V > 0.0 then + X := V; + Sign := '+'; + + -- Negative values + + elsif V < 0.0 then + X := -V; + Sign := '-'; + + -- Zero values + + elsif V = 0.0 then + if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then + Sign := '-'; + else + Sign := '+'; + end if; + + Set_Blanks_And_Sign (Fore - 1); + Set ('0'); + Set ('.'); + Set_Zeros (NFrac); + + if Exp /= 0 then + Set ('E'); + Set ('+'); + Set_Zeros (Natural'Max (1, Exp - 1)); + end if; + + return; + + else + -- It should not be possible for a NaN to end up here. + -- Either the 'Valid test has failed, or we have some form + -- of erroneous execution. Raise Constraint_Error instead of + -- attempting to go ahead printing the value. + + raise Constraint_Error; + end if; + + -- X and Sign are set here, and X is known to be a valid, + -- non-zero floating-point number. + + -- Case of non-zero value with Exp = 0 + + if Exp = 0 then + + -- First step is to multiply by 10 ** Nfrac to get an integer + -- value to be output, an then add 0.5 to round the result. + + declare + NF : Natural := NFrac; + + begin + loop + -- If we are larger than Powten (Maxdigs) now, then + -- we have too many significant digits, and we have + -- not even finished multiplying by NFrac (NF shows + -- the number of unaccounted-for digits). + + if X >= Powten (Maxdigs) then + + -- In this situation, we only to generate a reasonable + -- number of significant digits, and then zeroes after. + -- So first we rescale to get: + + -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs + + -- and then convert the resulting integer + + Adjust_Scale (Maxdigs); + Convert_Integer; + + -- If that caused rescaling, then add zeros to the end + -- of the number to account for this scaling. Also add + -- zeroes to account for the undone multiplications + + for J in 1 .. Scale + NF loop + Ndigs := Ndigs + 1; + Digs (Ndigs) := '0'; + end loop; + + exit; + + -- If multiplication is complete, then convert the resulting + -- integer after rounding (note that X is non-negative) + + elsif NF = 0 then + X := X + 0.5; + Convert_Integer; + exit; + + -- Otherwise we can go ahead with the multiplication. If it + -- can be done in one step, then do it in one step. + + elsif NF < Maxpow then + X := X * Powten (NF); + NF := 0; + + -- If it cannot be done in one step, then do partial scaling + + else + X := X * Powten (Maxpow); + NF := NF - Maxpow; + end if; + end loop; + end; + + -- If number of available digits is less or equal to NFrac, + -- then we need an extra zero before the decimal point. + + if Ndigs <= NFrac then + Set_Blanks_And_Sign (Fore - 1); + Set ('0'); + Set ('.'); + Set_Zeros (NFrac - Ndigs); + Set_Digs (1, Ndigs); + + -- Normal case with some digits before the decimal point + + else + Set_Blanks_And_Sign (Fore - (Ndigs - NFrac)); + Set_Digs (1, Ndigs - NFrac); + Set ('.'); + Set_Digs (Ndigs - NFrac + 1, Ndigs); + end if; + + -- Case of non-zero value with non-zero Exp value + + else + -- If NFrac is less than Maxdigs, then all the fraction digits are + -- significant, so we can scale the resulting integer accordingly. + + if NFrac < Maxdigs then + Adjust_Scale (NFrac + 1); + Convert_Integer; + + -- Otherwise, we get the maximum number of digits available + + else + Adjust_Scale (Maxdigs); + Convert_Integer; + + for J in 1 .. NFrac - Maxdigs + 1 loop + Ndigs := Ndigs + 1; + Digs (Ndigs) := '0'; + Scale := Scale - 1; + end loop; + end if; + + Set_Blanks_And_Sign (Fore - 1); + Set (Digs (1)); + Set ('.'); + Set_Digs (2, Ndigs); + + -- The exponent is the scaling factor adjusted for the digits + -- that we output after the decimal point, since these were + -- included in the scaled digits that we output. + + Expon := Scale + NFrac; + + Set ('E'); + Ndigs := 0; + + if Expon >= 0 then + Set ('+'); + Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs); + else + Set ('-'); + Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs); + end if; + + Set_Zeros (Exp - Ndigs - 1); + Set_Digs (1, Ndigs); + end if; + + end Set_Image_Real; + +end System.Img_Real; diff --git a/gcc/ada/libgnat/s-imgrea.ads b/gcc/ada/libgnat/s-imgrea.ads new file mode 100644 index 0000000..baefd9a --- /dev/null +++ b/gcc/ada/libgnat/s-imgrea.ads @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ R E A L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Image for fixed and float types (also used for Float_IO/Fixed_IO output) + +package System.Img_Real is + pragma Pure; + + procedure Image_Ordinary_Fixed_Point + (V : Long_Long_Float; + S : in out String; + P : out Natural; + Aft : Natural); + -- Computes fixed_type'Image (V) and returns the result in S (1 .. P) + -- updating P on return. The result is computed according to the rules for + -- image for fixed-point types (RM 3.5(34)), where Aft is the value of the + -- Aft attribute for the fixed-point type. This function is used only for + -- ordinary fixed point (see package System.Img_Dec for handling of decimal + -- fixed-point). The caller guarantees that S is long enough to hold the + -- result and has a lower bound of 1. + + procedure Image_Floating_Point + (V : Long_Long_Float; + S : in out String; + P : out Natural; + Digs : Natural); + -- Computes fixed_type'Image (V) and returns the result in S (1 .. P) + -- updating P on return. The result is computed according to the rules for + -- image for floating-point types (RM 3.5(33)), where Digs is the value of + -- the Digits attribute for the floating-point type. The caller guarantees + -- that S is long enough to hold the result and has a lower bound of 1. + + procedure Set_Image_Real + (V : Long_Long_Float; + S : out String; + P : in out Natural; + Fore : Natural; + Aft : Natural; + Exp : Natural); + -- Sets the image of V starting at S (P + 1), updating P to point to the + -- last character stored, the caller promises that the buffer is large + -- enough and no check is made for this. Constraint_Error will not + -- necessarily be raised if this is violated, since it is perfectly valid + -- to compile this unit with checks off). The Fore, Aft and Exp values + -- can be set to any valid values for the case of use from Text_IO. Note + -- that no space is stored at the start for non-negative values. + +end System.Img_Real; diff --git a/gcc/ada/libgnat/s-imguns.adb b/gcc/ada/libgnat/s-imguns.adb new file mode 100644 index 0000000..c6d467b --- /dev/null +++ b/gcc/ada/libgnat/s-imguns.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ U N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_Uns is + + -------------------- + -- Image_Unsigned -- + -------------------- + + procedure Image_Unsigned + (V : System.Unsigned_Types.Unsigned; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + begin + S (1) := ' '; + P := 1; + Set_Image_Unsigned (V, S, P); + end Image_Unsigned; + + ------------------------ + -- Set_Image_Unsigned -- + ------------------------ + + procedure Set_Image_Unsigned + (V : Unsigned; + S : in out String; + P : in out Natural) + is + begin + if V >= 10 then + Set_Image_Unsigned (V / 10, S, P); + P := P + 1; + S (P) := Character'Val (48 + (V rem 10)); + + else + P := P + 1; + S (P) := Character'Val (48 + V); + end if; + end Set_Image_Unsigned; + +end System.Img_Uns; diff --git a/gcc/ada/libgnat/s-imguns.ads b/gcc/ada/libgnat/s-imguns.ads new file mode 100644 index 0000000..8348c60 --- /dev/null +++ b/gcc/ada/libgnat/s-imguns.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ U N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines for supporting the Image attribute for +-- modular integer types up to size Unsigned'Size, and also for conversion +-- operations required in Text_IO.Modular_IO for such types. + +with System.Unsigned_Types; + +package System.Img_Uns is + pragma Pure; + + procedure Image_Unsigned + (V : System.Unsigned_Types.Unsigned; + S : in out String; + P : out Natural); + pragma Inline (Image_Unsigned); + -- Computes Unsigned'Image (V) and stores the result in S (1 .. P) setting + -- the resulting value of P. The caller guarantees that S is long enough to + -- hold the result, and that S'First is 1. + + procedure Set_Image_Unsigned + (V : System.Unsigned_Types.Unsigned; + S : in out String; + P : in out Natural); + -- Stores the image of V in S starting at S (P + 1), P is updated to point + -- to the last character stored. The value stored is identical to the value + -- of Unsigned'Image (V) except that no leading space is stored. The caller + -- guarantees that S is long enough to hold the result. S need not have a + -- lower bound of 1. + +end System.Img_Uns; diff --git a/gcc/ada/libgnat/s-imgwch.adb b/gcc/ada/libgnat/s-imgwch.adb new file mode 100644 index 0000000..4025d18 --- /dev/null +++ b/gcc/ada/libgnat/s-imgwch.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; use Interfaces; + +with System.Img_Char; use System.Img_Char; + +package body System.Img_WChar is + + -------------------------- + -- Image_Wide_Character -- + -------------------------- + + procedure Image_Wide_Character + (V : Wide_Character; + S : in out String; + P : out Natural; + Ada_2005 : Boolean) + is + pragma Assert (S'First = 1); + + begin + -- Annoying Ada 95 incompatibility with FFFE/FFFF + + if V >= Wide_Character'Val (16#FFFE#) + and then not Ada_2005 + then + if V = Wide_Character'Val (16#FFFE#) then + S (1 .. 4) := "FFFE"; + else + S (1 .. 4) := "FFFF"; + end if; + + P := 4; + + -- Deal with annoying Ada 95 incompatibility with soft hyphen + + elsif V = Wide_Character'Val (16#00AD#) + and then not Ada_2005 + then + P := 3; + S (1) := '''; + S (2) := Character'Val (16#00AD#); + S (3) := '''; + + -- Normal case, same as Wide_Wide_Character + + else + Image_Wide_Wide_Character + (Wide_Wide_Character'Val (Wide_Character'Pos (V)), S, P); + end if; + end Image_Wide_Character; + + ------------------------------- + -- Image_Wide_Wide_Character -- + ------------------------------- + + procedure Image_Wide_Wide_Character + (V : Wide_Wide_Character; + S : in out String; + P : out Natural) + is + pragma Assert (S'First = 1); + + Val : Unsigned_32 := Wide_Wide_Character'Pos (V); + + begin + -- If in range of standard Character, use Character routine. Use the + -- Ada 2005 version, since either we are called directly in Ada 2005 + -- mode for Wide_Wide_Character, or this is the Wide_Character case + -- which already took care of the Soft_Hyphen glitch. + + if Val <= 16#FF# then + Image_Character_05 + (Character'Val (Wide_Wide_Character'Pos (V)), S, P); + + -- Otherwise value returned is Hex_hhhhhhhh + + else + declare + Hex : constant array (Unsigned_32 range 0 .. 15) of Character := + "0123456789ABCDEF"; + + begin + S (1 .. 4) := "Hex_"; + + for J in reverse 5 .. 12 loop + S (J) := Hex (Val mod 16); + Val := Val / 16; + end loop; + + P := 12; + end; + end if; + end Image_Wide_Wide_Character; + +end System.Img_WChar; diff --git a/gcc/ada/libgnat/s-imgwch.ads b/gcc/ada/libgnat/s-imgwch.ads new file mode 100644 index 0000000..ce5c9eb --- /dev/null +++ b/gcc/ada/libgnat/s-imgwch.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Wide_[Wide_]Character'Image + +package System.Img_WChar is + pragma Pure; + + procedure Image_Wide_Character + (V : Wide_Character; + S : in out String; + P : out Natural; + Ada_2005 : Boolean); + -- Computes Wide_Character'Image (V) and stores the result in S (1 .. P) + -- setting the resulting value of P. The caller guarantees that S is long + -- enough to hold the result, and that S'First is 1. The parameter Ada_2005 + -- is True if operating in Ada 2005 mode (or beyond). This is required to + -- deal with the annoying FFFE/FFFF incompatibility. + + procedure Image_Wide_Wide_Character + (V : Wide_Wide_Character; + S : in out String; + P : out Natural); + -- Computes Wide_Wide_Character'Image (V) and stores the result in + -- S (1 .. P) setting the resulting value of P. The caller guarantees + -- that S is long enough to hold the result, and that S'First is 1. + +end System.Img_WChar; diff --git a/gcc/ada/libgnat/s-imgwiu.adb b/gcc/ada/libgnat/s-imgwiu.adb new file mode 100644 index 0000000..fbb92ef --- /dev/null +++ b/gcc/ada/libgnat/s-imgwiu.adb @@ -0,0 +1,138 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W I U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Img_WIU is + + ----------------------------- + -- Set_Image_Width_Integer -- + ----------------------------- + + procedure Set_Image_Width_Integer + (V : Integer; + W : Integer; + S : out String; + P : in out Natural) + is + Start : Natural; + + begin + -- Positive case can just use the unsigned circuit directly + + if V >= 0 then + Set_Image_Width_Unsigned (Unsigned (V), W, S, P); + + -- Negative case has to set a minus sign. Note also that we have to be + -- careful not to generate overflow with the largest negative number. + + else + P := P + 1; + S (P) := ' '; + Start := P; + + declare + pragma Suppress (Overflow_Check); + pragma Suppress (Range_Check); + begin + Set_Image_Width_Unsigned (Unsigned (-V), W - 1, S, P); + end; + + -- Set minus sign in last leading blank location. Because of the + -- code above, there must be at least one such location. + + while S (Start + 1) = ' ' loop + Start := Start + 1; + end loop; + + S (Start) := '-'; + end if; + + end Set_Image_Width_Integer; + + ------------------------------ + -- Set_Image_Width_Unsigned -- + ------------------------------ + + procedure Set_Image_Width_Unsigned + (V : Unsigned; + W : Integer; + S : out String; + P : in out Natural) + is + Start : constant Natural := P; + F, T : Natural; + + procedure Set_Digits (T : Unsigned); + -- Set digits of absolute value of T + + ---------------- + -- Set_Digits -- + ---------------- + + procedure Set_Digits (T : Unsigned) is + begin + if T >= 10 then + Set_Digits (T / 10); + P := P + 1; + S (P) := Character'Val (T mod 10 + Character'Pos ('0')); + else + P := P + 1; + S (P) := Character'Val (T + Character'Pos ('0')); + end if; + end Set_Digits; + + -- Start of processing for Set_Image_Width_Unsigned + + begin + Set_Digits (V); + + -- Add leading spaces if required by width parameter + + if P - Start < W then + F := P; + P := P + (W - (P - Start)); + T := P; + + while F > Start loop + S (T) := S (F); + T := T - 1; + F := F - 1; + end loop; + + for J in Start + 1 .. T loop + S (J) := ' '; + end loop; + end if; + + end Set_Image_Width_Unsigned; + +end System.Img_WIU; diff --git a/gcc/ada/libgnat/s-imgwiu.ads b/gcc/ada/libgnat/s-imgwiu.ads new file mode 100644 index 0000000..8fb23a2 --- /dev/null +++ b/gcc/ada/libgnat/s-imgwiu.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I M G _ W I U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Contains the routine for computing the image of signed and unsigned +-- integers whose size <= Integer'Size for use by Text_IO.Integer_IO +-- and Text_IO.Modular_IO. + +with System.Unsigned_Types; + +package System.Img_WIU is + pragma Pure; + + procedure Set_Image_Width_Integer + (V : Integer; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the signed image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes + -- a leading minus sign if necessary, but no leading spaces unless W is + -- positive, in which case leading spaces are output if necessary to ensure + -- that the output string is no less than W characters long. The caller + -- promises that the buffer is large enough and no check is made for this. + -- Constraint_Error will not necessarily be raised if this is violated, + -- since it is perfectly valid to compile this unit with checks off. + + procedure Set_Image_Width_Unsigned + (V : System.Unsigned_Types.Unsigned; + W : Integer; + S : out String; + P : in out Natural); + -- Sets the unsigned image of V in decimal format, starting at S (P + 1), + -- updating P to point to the last character stored. The image includes no + -- leading spaces unless W is positive, in which case leading spaces are + -- output if necessary to ensure that the output string is no less than + -- W characters long. The caller promises that the buffer is large enough + -- and no check is made for this. Constraint_Error will not necessarily be + -- raised if this is violated, since it is perfectly valid to compile this + -- unit with checks off. + +end System.Img_WIU; diff --git a/gcc/ada/libgnat/s-io.adb b/gcc/ada/libgnat/s-io.adb new file mode 100644 index 0000000..7f45d5d --- /dev/null +++ b/gcc/ada/libgnat/s-io.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.IO is + + Current_Out : File_Type := Stdout; + pragma Atomic (Current_Out); + -- Current output file (modified by Set_Output) + + -------------- + -- New_Line -- + -------------- + + procedure New_Line (Spacing : Positive := 1) is + begin + for J in 1 .. Spacing loop + Put (ASCII.LF); + end loop; + end New_Line; + + --------- + -- Put -- + --------- + + procedure Put (X : Integer) is + procedure Put_Int (X : Integer); + pragma Import (C, Put_Int, "put_int"); + + procedure Put_Int_Err (X : Integer); + pragma Import (C, Put_Int_Err, "put_int_stderr"); + + begin + case Current_Out is + when Stdout => Put_Int (X); + when Stderr => Put_Int_Err (X); + end case; + end Put; + + procedure Put (C : Character) is + procedure Put_Char (C : Character); + pragma Import (C, Put_Char, "put_char"); + + procedure Put_Char_Stderr (C : Character); + pragma Import (C, Put_Char_Stderr, "put_char_stderr"); + + begin + case Current_Out is + when Stdout => Put_Char (C); + when Stderr => Put_Char_Stderr (C); + end case; + end Put; + + procedure Put (S : String) is + begin + for J in S'Range loop + Put (S (J)); + end loop; + end Put; + + -------------- + -- Put_Line -- + -------------- + + procedure Put_Line (S : String) is + begin + Put (S); + New_Line; + end Put_Line; + + --------------------- + -- Standard_Output -- + --------------------- + + function Standard_Output return File_Type is + begin + return Stdout; + end Standard_Output; + + -------------------- + -- Standard_Error -- + -------------------- + + function Standard_Error return File_Type is + begin + return Stderr; + end Standard_Error; + + ---------------- + -- Set_Output -- + ---------------- + + procedure Set_Output (File : File_Type) is + begin + Current_Out := File; + end Set_Output; + +end System.IO; diff --git a/gcc/ada/libgnat/s-io.ads b/gcc/ada/libgnat/s-io.ads new file mode 100644 index 0000000..9186de2 --- /dev/null +++ b/gcc/ada/libgnat/s-io.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- A simple text I/O package, used for diagnostic output in the runtime, +-- This package is also preelaborated, unlike Text_Io, and can thus be +-- with'ed by preelaborated library units. It includes only Put routines +-- for character, integer, string and a new line function + +package System.IO is + pragma Preelaborate; + + procedure Put (X : Integer); + + procedure Put (C : Character); + + procedure Put (S : String); + procedure Put_Line (S : String); + + procedure New_Line (Spacing : Positive := 1); + + type File_Type is limited private; + + function Standard_Error return File_Type; + function Standard_Output return File_Type; + + procedure Set_Output (File : File_Type); + +private + + type File_Type is (Stdout, Stderr); + -- Stdout = Standard_Output, Stderr = Standard_Error + + pragma Inline (Standard_Error); + pragma Inline (Standard_Output); + +end System.IO; diff --git a/gcc/ada/libgnat/s-llflex.ads b/gcc/ada/libgnat/s-llflex.ads new file mode 100644 index 0000000..8ada509 --- /dev/null +++ b/gcc/ada/libgnat/s-llflex.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . L O N G _ L O N G _ F L O A T _ E X P O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains an instantiation of the exponentiation operator +-- between two long long floats. + +with Ada.Numerics.Long_Long_Elementary_Functions; + +package System.Long_Long_Float_Expon is + + function Expon_LLF (Left, Right : Long_Long_Float) return Long_Long_Float + renames Ada.Numerics.Long_Long_Elementary_Functions."**"; + +end System.Long_Long_Float_Expon; diff --git a/gcc/ada/libgnat/s-maccod.ads b/gcc/ada/libgnat/s-maccod.ads new file mode 100644 index 0000000..37bc7b4 --- /dev/null +++ b/gcc/ada/libgnat/s-maccod.ads @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . M A C H I N E _ C O D E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides machine code support, both for intrinsic machine +-- operations, and also for machine code statements. See GNAT documentation +-- for full details. + +package System.Machine_Code is + pragma No_Elaboration_Code_All; + pragma Pure; + + -- All identifiers in this unit are implementation defined + + pragma Implementation_Defined; + + type Asm_Input_Operand is private; + type Asm_Output_Operand is private; + -- These types are never used directly, they are declared only so that + -- the calls to Asm are type correct according to Ada semantic rules. + + No_Input_Operands : constant Asm_Input_Operand; + No_Output_Operands : constant Asm_Output_Operand; + + type Asm_Input_Operand_List is + array (Integer range <>) of Asm_Input_Operand; + + type Asm_Output_Operand_List is + array (Integer range <>) of Asm_Output_Operand; + + type Asm_Insn is private; + -- This type is not used directly. It is declared only so that the + -- aggregates used in code statements are type correct by Ada rules. + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False); + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False); + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False); + + procedure Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False); + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False) return Asm_Insn; + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand_List; + Clobber : String := ""; + Volatile : Boolean := False) return Asm_Insn; + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand_List; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False) return Asm_Insn; + + function Asm ( + Template : String; + Outputs : Asm_Output_Operand := No_Output_Operands; + Inputs : Asm_Input_Operand := No_Input_Operands; + Clobber : String := ""; + Volatile : Boolean := False) return Asm_Insn; + + pragma Import (Intrinsic, Asm); + +private + + type Asm_Input_Operand is new Integer; + type Asm_Output_Operand is new Integer; + type Asm_Insn is new Integer; + -- All three of these types are dummy types, to meet the requirements of + -- type consistency. No values of these types are ever referenced. + + No_Input_Operands : constant Asm_Input_Operand := 0; + No_Output_Operands : constant Asm_Output_Operand := 0; + +end System.Machine_Code; diff --git a/gcc/ada/libgnat/s-mantis.adb b/gcc/ada/libgnat/s-mantis.adb new file mode 100644 index 0000000..8e2f7b6 --- /dev/null +++ b/gcc/ada/libgnat/s-mantis.adb @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M A N T I S S A -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Mantissa is + + -------------------- + -- Mantissa_Value -- + -------------------- + + function Mantissa_Value (First, Last : Integer) return Natural is + Result : Natural := 0; + + Val : Integer := Integer'Max (abs First - 1, abs Last); + -- Note: First-1 allows for twos complement largest neg number + + begin + while Val /= 0 loop + Val := Val / 2; + Result := Result + 1; + end loop; + + return Result; + end Mantissa_Value; + +end System.Mantissa; diff --git a/gcc/ada/libgnat/s-mantis.ads b/gcc/ada/libgnat/s-mantis.ads new file mode 100644 index 0000000..424589b --- /dev/null +++ b/gcc/ada/libgnat/s-mantis.ads @@ -0,0 +1,42 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M A N T I S S A -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for typ'Mantissa where typ is a +-- fixed-point type with non-static bounds. + +package System.Mantissa is + pragma Pure; + + function Mantissa_Value (First, Last : Integer) return Natural; + -- Compute Mantissa value from the given arguments, which are the First + -- and Last value of the fixed-point type, in Integer'Integer_Value form. + +end System.Mantissa; diff --git a/gcc/ada/libgnat/s-mastop.adb b/gcc/ada/libgnat/s-mastop.adb new file mode 100644 index 0000000..8b84495 --- /dev/null +++ b/gcc/ada/libgnat/s-mastop.adb @@ -0,0 +1,108 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- B o d y -- +-- (Dummy version) -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This dummy version of System.Machine_State_Operations is used on targets +-- for which zero cost exception handling is not implemented. + +pragma Compiler_Unit_Warning; + +package body System.Machine_State_Operations is + + -- Turn off warnings since many unused parameters + + pragma Warnings (Off); + + ---------------------------- + -- Allocate_Machine_State -- + ---------------------------- + + function Allocate_Machine_State return Machine_State is + begin + return Machine_State (Null_Address); + end Allocate_Machine_State; + + ---------------- + -- Fetch_Code -- + ---------------- + + function Fetch_Code (Loc : Code_Loc) return Code_Loc is + begin + return Loc; + end Fetch_Code; + + ------------------------ + -- Free_Machine_State -- + ------------------------ + + procedure Free_Machine_State (M : in out Machine_State) is + begin + M := Machine_State (Null_Address); + end Free_Machine_State; + + ------------------ + -- Get_Code_Loc -- + ------------------ + + function Get_Code_Loc (M : Machine_State) return Code_Loc is + begin + return Null_Address; + end Get_Code_Loc; + + -------------------------- + -- Machine_State_Length -- + -------------------------- + + function Machine_State_Length + return System.Storage_Elements.Storage_Offset is + begin + return 0; + end Machine_State_Length; + + --------------- + -- Pop_Frame -- + --------------- + + procedure Pop_Frame (M : Machine_State) is + begin + null; + end Pop_Frame; + + ----------------------- + -- Set_Machine_State -- + ----------------------- + + procedure Set_Machine_State (M : Machine_State) is + begin + null; + end Set_Machine_State; + +end System.Machine_State_Operations; diff --git a/gcc/ada/libgnat/s-mastop.ads b/gcc/ada/libgnat/s-mastop.ads new file mode 100644 index 0000000..19b8689 --- /dev/null +++ b/gcc/ada/libgnat/s-mastop.ads @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.MACHINE_STATE_OPERATIONS -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +with System.Storage_Elements; + +package System.Machine_State_Operations is + + subtype Code_Loc is System.Address; + -- Code location used in building exception tables and for call addresses + -- when propagating an exception (also traceback table) Values of this + -- type are created by using Label'Address or extracted from machine + -- states using Get_Code_Loc. + + type Machine_State is new System.Address; + -- The table based exception handling approach (see a-except.adb) isolates + -- the target dependent aspects using an abstract data type interface + -- to the type Machine_State, which is represented as a System.Address + -- value (presumably implemented as a pointer to an appropriate record + -- structure). + + function Machine_State_Length return System.Storage_Elements.Storage_Offset; + -- Function to determine the length of the Storage_Array needed to hold + -- a machine state. The machine state will always be maximally aligned. + -- The value returned is a constant that will be used to allocate space + -- for a machine state value. + + function Allocate_Machine_State return Machine_State; + -- Allocate the required space for a Machine_State + + procedure Free_Machine_State (M : in out Machine_State); + -- Free the dynamic memory taken by Machine_State + + -- The initial value of type Machine_State is created by the low level + -- routine that actually raises an exception using the special builtin + -- _builtin_machine_state. This value will typically encode the value of + -- the program counter, and relevant registers. The following operations + -- are defined on Machine_State values: + + function Get_Code_Loc (M : Machine_State) return Code_Loc; + -- This function extracts the program counter value from a machine state, + -- which the caller uses for searching the exception tables, and also for + -- recording entries in the traceback table. The call returns a value of + -- Null_Loc if the machine state represents the outer level, or some other + -- frame for which no information can be provided. + + procedure Pop_Frame (M : Machine_State); + -- This procedure pops the machine state M so that it represents the + -- call point, as though the current subprogram had returned. It changes + -- only the value referenced by M, and does not affect the current stack + -- environment. + + function Fetch_Code (Loc : Code_Loc) return Code_Loc; + -- Some architectures (notably HPUX) use a descriptor to describe a + -- subprogram address. This function computes the actual starting + -- address of the code from Loc. + -- + -- Do not add pragma Inline to this function: there is a curious + -- interaction between rtsfind and front-end inlining. The exception + -- declaration in s-auxdec calls rtsfind, which forces several other system + -- packages to be compiled. Some of those have a pragma Inline, and we + -- compile the corresponding bodies so that inlining can take place. One + -- of these packages is s-mastop, which depends on s-auxdec, which is still + -- being compiled: we have not seen all the declarations in it yet, so we + -- get confused semantic errors ??? + + procedure Set_Machine_State (M : Machine_State); + -- This routine sets M from the current machine state. It is called when an + -- exception is initially signalled to initialize the state. + +end System.Machine_State_Operations; diff --git a/gcc/ada/libgnat/s-memcop.ads b/gcc/ada/libgnat/s-memcop.ads new file mode 100644 index 0000000..d96fd1f --- /dev/null +++ b/gcc/ada/libgnat/s-memcop.ads @@ -0,0 +1,72 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y _ C O P Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides general block copy mechanisms analogous to those +-- provided by the C routines memcpy and memmove allowing for copies with +-- and without possible overlap of the operands. + +-- The idea is to allow a configurable run-time to provide this capability +-- for use by the compiler without dragging in C-run time routines. + +with System.CRTL; +-- The above with is contrary to the intent ??? + +package System.Memory_Copy is + pragma Preelaborate; + + procedure memcpy (S1 : Address; S2 : Address; N : System.CRTL.size_t) + renames System.CRTL.memcpy; + -- Copies N storage units from area starting at S2 to area starting + -- at S1 without any check for buffer overflow. The memory areas + -- must not overlap, or the result of this call is undefined. + + procedure memmove (S1 : Address; S2 : Address; N : System.CRTL.size_t) + renames System.CRTL.memmove; + -- Copies N storage units from area starting at S2 to area starting + -- at S1 without any check for buffer overflow. The difference between + -- this memmove and memcpy is that with memmove, the storage areas may + -- overlap (forwards or backwards) and the result is correct (i.e. it + -- is as if S2 is first moved to a temporary area, and then this area + -- is copied to S1 in a separate step). + + -- In the standard library, these are just interfaced to the C routines. + -- But in the HI-E (high integrity version) they may be reprogrammed to + -- meet certification requirements (and marked High_Integrity). + + -- Note that in high integrity mode these routines are by default not + -- available, and the HI-E compiler will as a result generate implicit + -- loops (which will violate the restriction No_Implicit_Loops). + +end System.Memory_Copy; diff --git a/gcc/ada/libgnat/s-memory-mingw.adb b/gcc/ada/libgnat/s-memory-mingw.adb new file mode 100644 index 0000000..f7e5ff8 --- /dev/null +++ b/gcc/ada/libgnat/s-memory-mingw.adb @@ -0,0 +1,221 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version provides ways to limit the amount of used memory for systems +-- that do not have OS support for that. + +-- The amount of available memory available for dynamic allocation is limited +-- by setting the environment variable GNAT_MEMORY_LIMIT to the number of +-- kilobytes that can be used. +-- +-- Windows is currently using this version. + +with Ada.Exceptions; +with System.Soft_Links; + +package body System.Memory is + + use Ada.Exceptions; + use System.Soft_Links; + + function c_malloc (Size : size_t) return System.Address; + pragma Import (C, c_malloc, "malloc"); + + procedure c_free (Ptr : System.Address); + pragma Import (C, c_free, "free"); + + function c_realloc + (Ptr : System.Address; Size : size_t) return System.Address; + pragma Import (C, c_realloc, "realloc"); + + function msize (Ptr : System.Address) return size_t; + pragma Import (C, msize, "_msize"); + + function getenv (Str : String) return System.Address; + pragma Import (C, getenv); + + function atoi (Str : System.Address) return Integer; + pragma Import (C, atoi); + + Available_Memory : size_t := 0; + -- Amount of memory that is available for heap allocations. + -- A value of 0 means that the amount is not yet initialized. + + Msize_Accuracy : constant := 4096; + -- Defines the amount of memory to add to requested allocation sizes, + -- because malloc may return a bigger block than requested. As msize + -- is used when by Free, it must be used on allocation as well. To + -- prevent underflow of available_memory we need to use a reserve. + + procedure Check_Available_Memory (Size : size_t); + -- This routine must be called while holding the task lock. When the + -- memory limit is not yet initialized, it will be set to the value of + -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that + -- does not exist. If the size is larger than the amount of available + -- memory, the task lock will be freed and a storage_error exception + -- will be raised. + + ----------- + -- Alloc -- + ----------- + + function Alloc (Size : size_t) return System.Address is + Result : System.Address; + Actual_Size : size_t := Size; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + -- Change size from zero to non-zero. We still want a proper pointer + -- for the zero case because pointers to zero length objects have to + -- be distinct, but we can't just go ahead and allocate zero bytes, + -- since some malloc's return zero for a zero argument. + + if Size = 0 then + Actual_Size := 1; + end if; + + Lock_Task.all; + + if Actual_Size + Msize_Accuracy >= Available_Memory then + Check_Available_Memory (Size + Msize_Accuracy); + end if; + + Result := c_malloc (Actual_Size); + + if Result /= System.Null_Address then + Available_Memory := Available_Memory - msize (Result); + end if; + + Unlock_Task.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Alloc; + + ---------------------------- + -- Check_Available_Memory -- + ---------------------------- + + procedure Check_Available_Memory (Size : size_t) is + Gnat_Memory_Limit : System.Address; + + begin + if Available_Memory = 0 then + + -- The amount of available memory hasn't been initialized yet + + Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); + + if Gnat_Memory_Limit /= System.Null_Address then + Available_Memory := + size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; + else + Available_Memory := size_t'Last; + end if; + end if; + + if Size >= Available_Memory then + + -- There is a memory overflow + + Unlock_Task.all; + Raise_Exception + (Storage_Error'Identity, "heap memory limit exceeded"); + end if; + end Check_Available_Memory; + + ---------- + -- Free -- + ---------- + + procedure Free (Ptr : System.Address) is + begin + Lock_Task.all; + + if Ptr /= System.Null_Address then + Available_Memory := Available_Memory + msize (Ptr); + end if; + + c_free (Ptr); + + Unlock_Task.all; + end Free; + + ------------- + -- Realloc -- + ------------- + + function Realloc + (Ptr : System.Address; + Size : size_t) + return System.Address + is + Result : System.Address; + Actual_Size : constant size_t := Size; + Old_Size : size_t; + + begin + if Size = size_t'Last then + Raise_Exception (Storage_Error'Identity, "object too large"); + end if; + + Lock_Task.all; + + Old_Size := msize (Ptr); + + -- Conservative check - no need to try to be precise here + + if Size + Msize_Accuracy >= Available_Memory then + Check_Available_Memory (Size + Msize_Accuracy); + end if; + + Result := c_realloc (Ptr, Actual_Size); + + if Result /= System.Null_Address then + Available_Memory := Available_Memory + Old_Size - msize (Result); + end if; + + Unlock_Task.all; + + if Result = System.Null_Address then + Raise_Exception (Storage_Error'Identity, "heap exhausted"); + end if; + + return Result; + end Realloc; + +end System.Memory; diff --git a/gcc/ada/libgnat/s-memory.adb b/gcc/ada/libgnat/s-memory.adb new file mode 100644 index 0000000..28b5817 --- /dev/null +++ b/gcc/ada/libgnat/s-memory.adb @@ -0,0 +1,163 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default implementation of this package + +-- This implementation assumes that the underlying malloc/free/realloc +-- implementation is thread safe, and thus, no additional lock is required. +-- Note that we still need to defer abort because on most systems, an +-- asynchronous signal (as used for implementing asynchronous abort of +-- task) cannot safely be handled while malloc is executing. + +-- If you are not using Ada constructs containing the "abort" keyword, then +-- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from +-- this unit. + +pragma Compiler_Unit_Warning; + +with System.CRTL; +with System.Parameters; +with System.Soft_Links; + +package body System.Memory is + + use System.Soft_Links; + + function c_malloc (Size : System.CRTL.size_t) return System.Address + renames System.CRTL.malloc; + + procedure c_free (Ptr : System.Address) + renames System.CRTL.free; + + function c_realloc + (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address + renames System.CRTL.realloc; + + ----------- + -- Alloc -- + ----------- + + function Alloc (Size : size_t) return System.Address is + Result : System.Address; + begin + -- A previous version moved the check for size_t'Last below, into the + -- "if Result = System.Null_Address...". So malloc(size_t'Last) should + -- return Null_Address, and then we can check for that special value. + -- However, that doesn't work on VxWorks, because malloc(size_t'Last) + -- prints an unwanted warning message before returning Null_Address. + -- Note that the branch is correctly predicted on modern hardware, so + -- there is negligible overhead. + + if Size = size_t'Last then + raise Storage_Error with "object too large"; + end if; + + if Parameters.No_Abort then + Result := c_malloc (System.CRTL.size_t (Size)); + else + Abort_Defer.all; + Result := c_malloc (System.CRTL.size_t (Size)); + Abort_Undefer.all; + end if; + + if Result = System.Null_Address then + + -- If Size = 0, we can't allocate 0 bytes, because then two different + -- allocators, one of which has Size = 0, could return pointers that + -- compare equal, which is wrong. (Nonnull pointers compare equal if + -- and only if they designate the same object, and two different + -- allocators allocate two different objects). + + -- malloc(0) is defined to allocate a non-zero-sized object (in which + -- case we won't get here, and all is well) or NULL, in which case we + -- get here. We also get here in case of error. So check for the + -- zero-size case, and allocate 1 byte. Otherwise, raise + -- Storage_Error. + + -- We check for zero size here, rather than at the start, for + -- efficiency. + + if Size = 0 then + return Alloc (1); + end if; + + raise Storage_Error with "heap exhausted"; + end if; + + return Result; + end Alloc; + + ---------- + -- Free -- + ---------- + + procedure Free (Ptr : System.Address) is + begin + if Parameters.No_Abort then + c_free (Ptr); + else + Abort_Defer.all; + c_free (Ptr); + Abort_Undefer.all; + end if; + end Free; + + ------------- + -- Realloc -- + ------------- + + function Realloc + (Ptr : System.Address; + Size : size_t) + return System.Address + is + Result : System.Address; + begin + if Size = size_t'Last then + raise Storage_Error with "object too large"; + end if; + + if Parameters.No_Abort then + Result := c_realloc (Ptr, System.CRTL.size_t (Size)); + else + Abort_Defer.all; + Result := c_realloc (Ptr, System.CRTL.size_t (Size)); + Abort_Undefer.all; + end if; + + if Result = System.Null_Address then + raise Storage_Error with "heap exhausted"; + end if; + + return Result; + end Realloc; + +end System.Memory; diff --git a/gcc/ada/libgnat/s-memory.ads b/gcc/ada/libgnat/s-memory.ads new file mode 100644 index 0000000..a911ce7 --- /dev/null +++ b/gcc/ada/libgnat/s-memory.ads @@ -0,0 +1,107 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M E M O R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the low level memory allocation/deallocation +-- mechanisms used by GNAT. + +-- To provide an alternate implementation, simply recompile the modified +-- body of this package with gnatmake -u -a -g s-memory.adb and make sure +-- that the ali and object files for this unit are found in the object +-- search path. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +pragma Compiler_Unit_Warning; + +package System.Memory is + pragma Elaborate_Body; + + type size_t is mod 2 ** Standard'Address_Size; + -- Note: the reason we redefine this here instead of using the + -- definition in Interfaces.C is that we do not want to drag in + -- all of Interfaces.C just because System.Memory is used. + + function Alloc (Size : size_t) return System.Address; + -- This is the low level allocation routine. Given a size in storage + -- units, it returns the address of a maximally aligned block of + -- memory. The implementation of this routine is guaranteed to be + -- task safe, and also aborts are deferred if necessary. + -- + -- If Size is set to size_t'Last on entry, then a Storage_Error + -- exception is raised with a message "object too large". + -- + -- If Size is set to zero on entry, then a minimal (but non-zero) + -- size block is allocated. + -- + -- Note: this is roughly equivalent to the standard C malloc call + -- with the additional semantics as described above. + + procedure Free (Ptr : System.Address); + -- This is the low level free routine. It frees a block previously + -- allocated with a call to Alloc. As in the case of Alloc, this + -- call is guaranteed task safe, and aborts are deferred. + -- + -- Note: this is roughly equivalent to the standard C free call + -- with the additional semantics as described above. + + function Realloc + (Ptr : System.Address; + Size : size_t) return System.Address; + -- This is the low level reallocation routine. It takes an existing + -- block address returned by a previous call to Alloc or Realloc, + -- and reallocates the block. The size can either be increased or + -- decreased. If possible the reallocation is done in place, so that + -- the returned result is the same as the value of Ptr on entry. + -- However, it may be necessary to relocate the block to another + -- address, in which case the information is copied to the new + -- block, and the old block is freed. The implementation of this + -- routine is guaranteed to be task safe, and also aborts are + -- deferred as necessary. + -- + -- If Size is set to size_t'Last on entry, then a Storage_Error + -- exception is raised with a message "object too large". + -- + -- If Size is set to zero on entry, then a minimal (but non-zero) + -- size block is allocated. + -- + -- Note: this is roughly equivalent to the standard C realloc call + -- with the additional semantics as described above. + +private + + -- The following names are used from the generated compiler code + + pragma Export (C, Alloc, "__gnat_malloc"); + pragma Export (C, Free, "__gnat_free"); + pragma Export (C, Realloc, "__gnat_realloc"); + +end System.Memory; diff --git a/gcc/ada/libgnat/s-mmap.adb b/gcc/ada/libgnat/s-mmap.adb new file mode 100644 index 0000000..6c8fbc2 --- /dev/null +++ b/gcc/ada/libgnat/s-mmap.adb @@ -0,0 +1,576 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +with System.Strings; use System.Strings; + +with System.Mmap.OS_Interface; use System.Mmap.OS_Interface; + +package body System.Mmap is + + type Mapped_File_Record is record + Current_Region : Mapped_Region; + -- The legacy API enables only one region to be mapped, directly + -- associated with the mapped file. This references this region. + + File : System_File; + -- Underlying OS-level file + end record; + + type Mapped_Region_Record is record + File : Mapped_File; + -- The file this region comes from. Be careful: for reading file, it is + -- valid to have it closed before one of its regions is free'd. + + Write : Boolean; + -- Whether the file this region comes from is open for writing. + + Data : Str_Access; + -- Unbounded access to the mapped content. + + System_Offset : File_Size; + -- Position in the file of the first byte actually mapped in memory + + User_Offset : File_Size; + -- Position in the file of the first byte requested by the user + + System_Size : File_Size; + -- Size of the region actually mapped in memory + + User_Size : File_Size; + -- Size of the region requested by the user + + Mapped : Boolean; + -- Whether this region is actually memory mapped + + Mutable : Boolean; + -- If the file is opened for reading, wheter this region is writable + + Buffer : System.Strings.String_Access; + -- When this region is not actually memory mapped, contains the + -- requested bytes. + + Mapping : System_Mapping; + -- Underlying OS-level data for the mapping, if any + end record; + + Invalid_Mapped_Region_Record : constant Mapped_Region_Record := + (null, False, null, 0, 0, 0, 0, False, False, null, + Invalid_System_Mapping); + Invalid_Mapped_File_Record : constant Mapped_File_Record := + (Invalid_Mapped_Region, Invalid_System_File); + + Empty_String : constant String := ""; + -- Used to provide a valid empty Data for empty files, for instanc. + + procedure Dispose is new Ada.Unchecked_Deallocation + (Mapped_File_Record, Mapped_File); + procedure Dispose is new Ada.Unchecked_Deallocation + (Mapped_Region_Record, Mapped_Region); + + function Convert is new Ada.Unchecked_Conversion + (Standard.System.Address, Str_Access); + + procedure Compute_Data (Region : Mapped_Region); + -- Fill the Data field according to system and user offsets. The region + -- must actually be mapped or bufferized. + + procedure From_Disk (Region : Mapped_Region); + -- Read a region of some file from the disk + + procedure To_Disk (Region : Mapped_Region); + -- Write the region of the file back to disk if necessary, and free memory + + ---------------------------- + -- Open_Read_No_Exception -- + ---------------------------- + + function Open_Read_No_Exception + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File + is + File : constant System_File := + Open_Read (Filename, Use_Mmap_If_Available); + begin + if File = Invalid_System_File then + return Invalid_Mapped_File; + end if; + + return new Mapped_File_Record' + (Current_Region => Invalid_Mapped_Region, + File => File); + end Open_Read_No_Exception; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File + is + Res : constant Mapped_File := + Open_Read_No_Exception (Filename, Use_Mmap_If_Available); + begin + if Res = Invalid_Mapped_File then + raise Ada.IO_Exceptions.Name_Error + with "Cannot open " & Filename; + else + return Res; + end if; + end Open_Read; + + ---------------- + -- Open_Write -- + ---------------- + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File + is + File : constant System_File := + Open_Write (Filename, Use_Mmap_If_Available); + begin + if File = Invalid_System_File then + raise Ada.IO_Exceptions.Name_Error + with "Cannot open " & Filename; + else + return new Mapped_File_Record' + (Current_Region => Invalid_Mapped_Region, + File => File); + end if; + end Open_Write; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out Mapped_File) is + begin + -- Closing a closed file is allowed and should do nothing + + if File = Invalid_Mapped_File then + return; + end if; + + if File.Current_Region /= null then + Free (File.Current_Region); + end if; + + if File.File /= Invalid_System_File then + Close (File.File); + end if; + + Dispose (File); + end Close; + + ---------- + -- Free -- + ---------- + + procedure Free (Region : in out Mapped_Region) is + Ignored : Integer; + pragma Unreferenced (Ignored); + begin + -- Freeing an already free'd file is allowed and should do nothing + + if Region = Invalid_Mapped_Region then + return; + end if; + + if Region.Mapping /= Invalid_System_Mapping then + Dispose_Mapping (Region.Mapping); + end if; + To_Disk (Region); + Dispose (Region); + end Free; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : Mapped_File; + Region : in out Mapped_Region; + Offset : File_Size := 0; + Length : File_Size := 0; + Mutable : Boolean := False) + is + File_Length : constant File_Size := Mmap.Length (File); + + Req_Offset : constant File_Size := Offset; + Req_Length : File_Size := Length; + -- Offset and Length of the region to map, used to adjust mapping + -- bounds, reflecting what the user will see. + + Region_Allocated : Boolean := False; + begin + -- If this region comes from another file, or simply if the file is + -- writeable, we cannot re-use this mapping: free it first. + + if Region /= Invalid_Mapped_Region + and then + (Region.File /= File or else File.File.Write) + then + Free (Region); + end if; + + if Region = Invalid_Mapped_Region then + Region := new Mapped_Region_Record'(Invalid_Mapped_Region_Record); + Region_Allocated := True; + end if; + + Region.File := File; + + if Req_Offset >= File_Length then + -- If the requested offset goes beyond file size, map nothing + + Req_Length := 0; + + elsif Length = 0 + or else + Length > File_Length - Req_Offset + then + -- If Length is 0 or goes beyond file size, map till end of file + + Req_Length := File_Length - Req_Offset; + + else + Req_Length := Length; + end if; + + -- Past this point, the offset/length the user will see is fixed. On the + -- other hand, the system offset/length is either already defined, from + -- a previous mapping, or it is set to 0. In the latter case, the next + -- step will set them according to the mapping. + + Region.User_Offset := Req_Offset; + Region.User_Size := Req_Length; + + -- If the requested region is inside an already mapped region, adjust + -- user-requested data and do nothing else. + + if (File.File.Write or else Region.Mutable = Mutable) + and then + Req_Offset >= Region.System_Offset + and then + (Req_Offset + Req_Length + <= Region.System_Offset + Region.System_Size) + then + Region.User_Offset := Req_Offset; + Compute_Data (Region); + return; + + elsif Region.Buffer /= null then + -- Otherwise, as we are not going to re-use the buffer, free it + + System.Strings.Free (Region.Buffer); + Region.Buffer := null; + + elsif Region.Mapping /= Invalid_System_Mapping then + -- Otherwise, there is a memory mapping that we need to unmap. + Dispose_Mapping (Region.Mapping); + end if; + + -- mmap() will sometimes return NULL when the file exists but is empty, + -- which is not what we want, so in the case of a zero length file we + -- fall back to read(2)/write(2)-based mode. + + if File_Length > 0 and then File.File.Mapped then + + Region.System_Offset := Req_Offset; + Region.System_Size := Req_Length; + Create_Mapping + (File.File, + Region.System_Offset, Region.System_Size, + Mutable, + Region.Mapping); + Region.Mapped := True; + Region.Mutable := Mutable; + + else + -- There is no alignment requirement when manually reading the file. + + Region.System_Offset := Req_Offset; + Region.System_Size := Req_Length; + Region.Mapped := False; + Region.Mutable := True; + From_Disk (Region); + end if; + + Region.Write := File.File.Write; + Compute_Data (Region); + + exception + when others => + -- Before propagating any exception, free any region we allocated + -- here. + + if Region_Allocated then + Dispose (Region); + end if; + raise; + end Read; + + ---------- + -- Read -- + ---------- + + procedure Read + (File : Mapped_File; + Offset : File_Size := 0; + Length : File_Size := 0; + Mutable : Boolean := False) + is + begin + Read (File, File.Current_Region, Offset, Length, Mutable); + end Read; + + ---------- + -- Read -- + ---------- + + function Read + (File : Mapped_File; + Offset : File_Size := 0; + Length : File_Size := 0; + Mutable : Boolean := False) return Mapped_Region + is + Region : Mapped_Region := Invalid_Mapped_Region; + begin + Read (File, Region, Offset, Length, Mutable); + return Region; + end Read; + + ------------ + -- Length -- + ------------ + + function Length (File : Mapped_File) return File_Size is + begin + return File.File.Length; + end Length; + + ------------ + -- Offset -- + ------------ + + function Offset (Region : Mapped_Region) return File_Size is + begin + return Region.User_Offset; + end Offset; + + ------------ + -- Offset -- + ------------ + + function Offset (File : Mapped_File) return File_Size is + begin + return Offset (File.Current_Region); + end Offset; + + ---------- + -- Last -- + ---------- + + function Last (Region : Mapped_Region) return Integer is + begin + return Integer (Region.User_Size); + end Last; + + ---------- + -- Last -- + ---------- + + function Last (File : Mapped_File) return Integer is + begin + return Last (File.Current_Region); + end Last; + + ------------------- + -- To_Str_Access -- + ------------------- + + function To_Str_Access + (Str : System.Strings.String_Access) return Str_Access is + begin + if Str = null then + return null; + else + return Convert (Str.all'Address); + end if; + end To_Str_Access; + + ---------- + -- Data -- + ---------- + + function Data (Region : Mapped_Region) return Str_Access is + begin + return Region.Data; + end Data; + + ---------- + -- Data -- + ---------- + + function Data (File : Mapped_File) return Str_Access is + begin + return Data (File.Current_Region); + end Data; + + ---------------- + -- Is_Mutable -- + ---------------- + + function Is_Mutable (Region : Mapped_Region) return Boolean is + begin + return Region.Mutable or Region.Write; + end Is_Mutable; + + ---------------- + -- Is_Mmapped -- + ---------------- + + function Is_Mmapped (File : Mapped_File) return Boolean is + begin + return File.File.Mapped; + end Is_Mmapped; + + ------------------- + -- Get_Page_Size -- + ------------------- + + function Get_Page_Size return Integer is + Result : constant File_Size := Get_Page_Size; + begin + return Integer (Result); + end Get_Page_Size; + + --------------------- + -- Read_Whole_File -- + --------------------- + + function Read_Whole_File + (Filename : String; + Empty_If_Not_Found : Boolean := False) + return System.Strings.String_Access + is + File : Mapped_File := Open_Read (Filename); + Region : Mapped_Region renames File.Current_Region; + Result : String_Access; + begin + Read (File); + + if Region.Data /= null then + Result := new String'(String + (Region.Data (1 .. Last (Region)))); + + elsif Region.Buffer /= null then + Result := Region.Buffer; + Region.Buffer := null; -- So that it is not deallocated + end if; + + Close (File); + + return Result; + + exception + when Ada.IO_Exceptions.Name_Error => + if Empty_If_Not_Found then + return new String'(""); + else + return null; + end if; + + when others => + Close (File); + return null; + end Read_Whole_File; + + --------------- + -- From_Disk -- + --------------- + + procedure From_Disk (Region : Mapped_Region) is + begin + pragma Assert (Region.File.all /= Invalid_Mapped_File_Record); + pragma Assert (Region.Buffer = null); + + Region.Buffer := Read_From_Disk + (Region.File.File, Region.User_Offset, Region.User_Size); + Region.Mapped := False; + end From_Disk; + + ------------- + -- To_Disk -- + ------------- + + procedure To_Disk (Region : Mapped_Region) is + begin + if Region.Write and then Region.Buffer /= null then + pragma Assert (Region.File.all /= Invalid_Mapped_File_Record); + Write_To_Disk + (Region.File.File, + Region.User_Offset, Region.User_Size, + Region.Buffer); + end if; + + System.Strings.Free (Region.Buffer); + Region.Buffer := null; + end To_Disk; + + ------------------ + -- Compute_Data -- + ------------------ + + procedure Compute_Data (Region : Mapped_Region) is + Base_Data : Str_Access; + -- Address of the first byte actually mapped in memory + + Data_Shift : constant Integer := + Integer (Region.User_Offset - Region.System_Offset); + begin + if Region.User_Size = 0 then + Region.Data := Convert (Empty_String'Address); + return; + elsif Region.Mapped then + Base_Data := Convert (Region.Mapping.Address); + else + Base_Data := Convert (Region.Buffer.all'Address); + end if; + Region.Data := Convert (Base_Data (Data_Shift + 1)'Address); + end Compute_Data; + +end System.Mmap; diff --git a/gcc/ada/libgnat/s-mmap.ads b/gcc/ada/libgnat/s-mmap.ads new file mode 100644 index 0000000..4ab2ffc --- /dev/null +++ b/gcc/ada/libgnat/s-mmap.ads @@ -0,0 +1,283 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides memory mapping of files. Depending on your operating +-- system, this might provide a more efficient method for accessing the +-- contents of files. +-- A description of memory-mapping is available on the sqlite page, at: +-- http://www.sqlite.org/mmap.html +-- +-- The traditional method for reading a file is to allocate a buffer in the +-- application address space, then open the file and copy its contents. When +-- memory mapping is available though, the application asks the operating +-- system to return a pointer to the requested page, if possible. If the +-- requested page has been or can be mapped into the application address +-- space, the system returns a pointer to that page for the application to +-- use without having to copy anything. Skipping the copy step is what makes +-- memory mapped I/O faster. +-- +-- When memory mapping is not available, this package automatically falls +-- back to the traditional copy method. +-- +-- Example of use for this package, when reading a file that can be fully +-- mapped +-- +-- declare +-- File : Mapped_File; +-- Str : Str_Access; +-- begin +-- File := Open_Read ("/tmp/file_on_disk"); +-- Read (File); -- read the whole file +-- Str := Data (File); +-- for S in 1 .. Last (File) loop +-- Put (Str (S)); +-- end loop; +-- Close (File); +-- end; +-- +-- When the file is big, or you only want to access part of it at a given +-- time, you can use the following type of code. + +-- declare +-- File : Mapped_File; +-- Str : Str_Access; +-- Offs : File_Size := 0; +-- Page : constant Integer := Get_Page_Size; +-- begin +-- File := Open_Read ("/tmp/file_on_disk"); +-- while Offs < Length (File) loop +-- Read (File, Offs, Length => Long_Integer (Page) * 4); +-- Str := Data (File); +-- +-- -- Print characters for this chunk: +-- for S in Integer (Offs - Offset (File)) + 1 .. Last (File) loop +-- Put (Str (S)); +-- end loop; +-- +-- -- Since we are reading multiples of Get_Page_Size, we can simplify +-- -- with +-- -- for S in 1 .. Last (File) loop ... +-- +-- Offs := Offs + Long_Integer (Last (File)); +-- end loop; + +with Interfaces.C; + +with System.Strings; + +package System.Mmap is + + type Mapped_File is private; + -- File to be mapped in memory. + + -- This package will use the fastest possible algorithm to load the + -- file in memory. On systems that support it, the file is not really + -- loaded in memory. Instead, a call to the mmap() system call (or + -- CreateFileMapping()) will keep the file on disk, but make it + -- accessible as if it was in memory. + + -- When the system does not support it, the file is actually loaded in + -- memory through calls to read(), and written back with write() when you + -- close it. This is of course much slower. + + -- Legacy: each mapped file has a "default" mapped region in it. + + type Mapped_Region is private; + -- A representation of part of a file in memory. Actual reading/writing + -- is done through a mapped region. After being returned by Read, a mapped + -- region must be free'd when done. If the original Mapped_File was open + -- for reading, it can be closed before the mapped region is free'd. + + Invalid_Mapped_File : constant Mapped_File; + Invalid_Mapped_Region : constant Mapped_Region; + + type Unconstrained_String is new String (Positive); + type Str_Access is access all Unconstrained_String; + pragma No_Strict_Aliasing (Str_Access); + + type File_Size is new Interfaces.C.size_t; + + function To_Str_Access + (Str : System.Strings.String_Access) return Str_Access; + -- Convert Str. The returned value points to the same memory block, but no + -- longer includes the bounds, which you need to manage yourself + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File; + -- Open a file for reading. The same file can be shared by multiple + -- processes, that will see each others's changes as they occur. + -- Any attempt to write the data might result in a segmentation fault, + -- depending on how the file is open. + -- Name_Error is raised if the file does not exist. + -- Filename should be compatible with the filesystem. + + function Open_Read_No_Exception + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File; + -- Like Open_Read but return Invalid_Mapped_File in case of error + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return Mapped_File; + -- Open a file for writing. + -- You cannot change the length of the file. + -- Name_Error is raised if the file does not exist + -- Filename should be compatible with the filesystem. + + procedure Close (File : in out Mapped_File); + -- Close the file, and unmap the memory that is used for the region + -- contained in File. If the system does not support the unmmap() system + -- call or equivalent, or these were not available for the file itself, + -- then the file is written back to the disk if it was opened for writing. + + procedure Free (Region : in out Mapped_Region); + -- Unmap the memory that is used for this region and deallocate the region + + procedure Read + (File : Mapped_File; + Region : in out Mapped_Region; + Offset : File_Size := 0; + Length : File_Size := 0; + Mutable : Boolean := False); + -- Read a specific part of File and set Region to the corresponding mapped + -- region, or re-use it if possible. + -- Offset is the number of bytes since the beginning of the file at which + -- we should start reading. Length is the number of bytes that should be + -- read. If set to 0, as much of the file as possible is read (presumably + -- the whole file unless you are reading a _huge_ file). + -- Note that no (un)mapping is is done if that part of the file is already + -- available through Region. + -- If the file was opened for writing, any modification you do to the + -- data stored in File will be stored on disk (either immediately when the + -- file is opened through a mmap() system call, or when the file is closed + -- otherwise). + -- Mutable is processed only for reading files. If set to True, the + -- data can be modified, even through it will not be carried through the + -- underlying file, nor it is guaranteed to be carried through remapping. + -- This function takes care of page size alignment issues. The accessors + -- below only expose the region that has been requested by this call, even + -- if more bytes were actually mapped by this function. + -- TODO??? Enable to have a private copy for readable files + + function Read + (File : Mapped_File; + Offset : File_Size := 0; + Length : File_Size := 0; + Mutable : Boolean := False) return Mapped_Region; + -- Likewise, return a new mapped region + + procedure Read + (File : Mapped_File; + Offset : File_Size := 0; + Length : File_Size := 0; + Mutable : Boolean := False); + -- Likewise, use the legacy "default" region in File + + function Length (File : Mapped_File) return File_Size; + -- Size of the file on the disk + + function Offset (Region : Mapped_Region) return File_Size; + -- Return the offset, in the physical file on disk, corresponding to the + -- requested mapped region. The first byte in the file has offest 0. + + function Offset (File : Mapped_File) return File_Size; + -- Likewise for the region contained in File + + function Last (Region : Mapped_Region) return Integer; + -- Return the number of requested bytes mapped in this region. It is + -- erroneous to access Data for indices outside 1 .. Last (Region). + -- Such accesses may cause Storage_Error to be raised. + + function Last (File : Mapped_File) return Integer; + -- Return the number of requested bytes mapped in the region contained in + -- File. It is erroneous to access Data for indices outside of 1 .. Last + -- (File); such accesses may cause Storage_Error to be raised. + + function Data (Region : Mapped_Region) return Str_Access; + pragma Inline (Data); + -- The data mapped in Region as requested. The result is an unconstrained + -- string, so you cannot use the usual 'First and 'Last attributes. + -- Instead, these are respectively 1 and Size. + + function Data (File : Mapped_File) return Str_Access; + pragma Inline (Data); + -- Likewise for the region contained in File + + function Is_Mutable (Region : Mapped_Region) return Boolean; + -- Return whether it is safe to change bytes in Data (Region). This is true + -- for regions from writeable files, for regions mapped with the "Mutable" + -- flag set, and for regions that are copied in a buffer. Note that it is + -- not specified whether empty regions are mutable or not, since there is + -- no byte no modify. + + function Is_Mmapped (File : Mapped_File) return Boolean; + -- Whether regions for this file are opened through an mmap() system call + -- or equivalent. This is in general irrelevant to your application, unless + -- the file can be accessed by multiple concurrent processes or tasks. In + -- such a case, and if the file is indeed mmap-ed, then the various parts + -- of the file can be written simulatenously, and thus you cannot ensure + -- the integrity of the file. If the file is not mmapped, the latest + -- process to Close it overwrite what other processes have done. + + function Get_Page_Size return Integer; + -- Returns the number of bytes in a page. Once a file is mapped from the + -- disk, its offset and Length should be multiples of this page size (which + -- is ensured by this package in any case). Knowing this page size allows + -- you to map as much memory as possible at once, thus potentially reducing + -- the number of system calls to read the file by chunks. + + function Read_Whole_File + (Filename : String; + Empty_If_Not_Found : Boolean := False) + return System.Strings.String_Access; + -- Returns the whole contents of the file. + -- The returned string must be freed by the user. + -- This is a convenience function, which is of course slower than the ones + -- above since we also need to allocate some memory, actually read the file + -- and copy the bytes. + -- If the file does not exist, null is returned. However, if + -- Empty_If_Not_Found is True, then the empty string is returned instead. + -- Filename should be compatible with the filesystem. + +private + pragma Inline (Data, Length, Last, Offset, Is_Mmapped, To_Str_Access); + + type Mapped_File_Record; + type Mapped_File is access Mapped_File_Record; + + type Mapped_Region_Record; + type Mapped_Region is access Mapped_Region_Record; + + Invalid_Mapped_File : constant Mapped_File := null; + Invalid_Mapped_Region : constant Mapped_Region := null; + +end System.Mmap; diff --git a/gcc/ada/libgnat/s-mmauni-long.ads b/gcc/ada/libgnat/s-mmauni-long.ads new file mode 100644 index 0000000..8a1f94a --- /dev/null +++ b/gcc/ada/libgnat/s-mmauni-long.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . U N I X -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Declaration of off_t/mmap/munmap. This particular implementation +-- supposes off_t is long. + +with System.OS_Lib; +with Interfaces.C; + +package System.Mmap.Unix is + + type Mmap_Prot is new Interfaces.C.int; +-- PROT_NONE : constant Mmap_Prot := 16#00#; +-- PROT_EXEC : constant Mmap_Prot := 16#04#; + PROT_READ : constant Mmap_Prot := 16#01#; + PROT_WRITE : constant Mmap_Prot := 16#02#; + + type Mmap_Flags is new Interfaces.C.int; +-- MAP_NONE : constant Mmap_Flags := 16#00#; +-- MAP_FIXED : constant Mmap_Flags := 16#10#; + MAP_SHARED : constant Mmap_Flags := 16#01#; + MAP_PRIVATE : constant Mmap_Flags := 16#02#; + + type off_t is new Long_Integer; + + function Mmap (Start : Address := Null_Address; + Length : Interfaces.C.size_t; + Prot : Mmap_Prot := PROT_READ; + Flags : Mmap_Flags := MAP_PRIVATE; + Fd : System.OS_Lib.File_Descriptor; + Offset : off_t) return Address; + pragma Import (C, Mmap, "mmap"); + + function Munmap (Start : Address; + Length : Interfaces.C.size_t) return Integer; + pragma Import (C, Munmap, "munmap"); + + function Is_Mapping_Available return Boolean is (True); + -- Wheter memory mapping is actually available on this system. It is an + -- error to use Create_Mapping and Dispose_Mapping if this is False. +end System.Mmap.Unix; diff --git a/gcc/ada/libgnat/s-mmosin-mingw.adb b/gcc/ada/libgnat/s-mmosin-mingw.adb new file mode 100644 index 0000000..f32e540 --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin-mingw.adb @@ -0,0 +1,345 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System.Strings; use System.Strings; + +with System.OS_Lib; +pragma Unreferenced (System.OS_Lib); +-- Only used to generate same runtime dependencies and same binder file on +-- GNU/Linux and Windows. + +package body System.Mmap.OS_Interface is + + use Win; + + function Align + (Addr : File_Size) return File_Size; + -- Align some offset/length to the lowest page boundary + + function Open_Common + (Filename : String; + Use_Mmap_If_Available : Boolean; + Write : Boolean) return System_File; + + function From_UTF8 (Path : String) return Wide_String; + -- Convert from UTF-8 to Wide_String + + --------------- + -- From_UTF8 -- + --------------- + + function From_UTF8 (Path : String) return Wide_String is + function MultiByteToWideChar + (Codepage : Interfaces.C.unsigned; + Flags : Interfaces.C.unsigned; + Mbstr : Address; + Mb : Natural; + Wcstr : Address; + Wc : Natural) return Integer; + pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar"); + + Current_Codepage : Interfaces.C.unsigned; + pragma Import (C, Current_Codepage, "__gnat_current_codepage"); + + Len : Natural; + begin + -- Compute length of the result + Len := MultiByteToWideChar + (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0); + if Len = 0 then + raise Constraint_Error; + end if; + + declare + -- Declare result + Res : Wide_String (1 .. Len); + begin + -- And compute it + Len := MultiByteToWideChar + (Current_Codepage, 0, + Path'Address, Path'Length, + Res'Address, Len); + if Len = 0 then + raise Constraint_Error; + end if; + return Res; + end; + end From_UTF8; + + ----------------- + -- Open_Common -- + ----------------- + + function Open_Common + (Filename : String; + Use_Mmap_If_Available : Boolean; + Write : Boolean) return System_File + is + dwDesiredAccess, dwShareMode : DWORD; + PageFlags : DWORD; + + W_Filename : constant Wide_String := + From_UTF8 (Filename) & Wide_Character'Val (0); + File_Handle, Mapping_Handle : HANDLE; + + SizeH : aliased DWORD; + Size : File_Size; + begin + if Write then + dwDesiredAccess := GENERIC_READ + GENERIC_WRITE; + dwShareMode := 0; + PageFlags := Win.PAGE_READWRITE; + else + dwDesiredAccess := GENERIC_READ; + dwShareMode := Win.FILE_SHARE_READ; + PageFlags := Win.PAGE_READONLY; + end if; + + -- Actually open the file + + File_Handle := CreateFile + (W_Filename'Address, dwDesiredAccess, dwShareMode, + null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0); + + if File_Handle = Win.INVALID_HANDLE_VALUE then + return Invalid_System_File; + end if; + + -- Compute its size + + Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access)); + + if Size = Win.INVALID_FILE_SIZE then + return Invalid_System_File; + end if; + + if SizeH /= 0 and then File_Size'Size > 32 then + Size := Size + (File_Size (SizeH) * 2 ** 32); + end if; + + -- Then create a mapping object, if needed. On Win32, file memory + -- mapping is always available. + + if Use_Mmap_If_Available then + Mapping_Handle := + Win.CreateFileMapping + (File_Handle, null, PageFlags, + 0, DWORD (Size), Standard.System.Null_Address); + else + Mapping_Handle := Win.INVALID_HANDLE_VALUE; + end if; + + return + (Handle => File_Handle, + Mapped => Use_Mmap_If_Available, + Mapping_Handle => Mapping_Handle, + Write => Write, + Length => Size); + end Open_Common; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + begin + return Open_Common (Filename, Use_Mmap_If_Available, False); + end Open_Read; + + ---------------- + -- Open_Write -- + ---------------- + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + begin + return Open_Common (Filename, Use_Mmap_If_Available, True); + end Open_Write; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out System_File) is + Ignored : BOOL; + pragma Unreferenced (Ignored); + begin + Ignored := CloseHandle (File.Mapping_Handle); + Ignored := CloseHandle (File.Handle); + File.Handle := Win.INVALID_HANDLE_VALUE; + File.Mapping_Handle := Win.INVALID_HANDLE_VALUE; + end Close; + + -------------------- + -- Read_From_Disk -- + -------------------- + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access + is + Buffer : String_Access := new String (1 .. Integer (Length)); + + Pos : DWORD; + NbRead : aliased DWORD; + pragma Unreferenced (Pos); + begin + Pos := Win.SetFilePointer + (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); + + if Win.ReadFile + (File.Handle, Buffer.all'Address, + DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE + then + System.Strings.Free (Buffer); + raise Ada.IO_Exceptions.Device_Error; + end if; + return Buffer; + end Read_From_Disk; + + ------------------- + -- Write_To_Disk -- + ------------------- + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access) + is + Pos : DWORD; + NbWritten : aliased DWORD; + pragma Unreferenced (Pos); + begin + pragma Assert (File.Write); + Pos := Win.SetFilePointer + (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); + + if Win.WriteFile + (File.Handle, Buffer.all'Address, + DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE + then + raise Ada.IO_Exceptions.Device_Error; + end if; + end Write_To_Disk; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping) + is + Flags : DWORD; + begin + if File.Write then + Flags := Win.FILE_MAP_WRITE; + elsif Mutable then + Flags := Win.FILE_MAP_COPY; + else + Flags := Win.FILE_MAP_READ; + end if; + + -- Adjust offset and mapping length to account for the required + -- alignment of offset on page boundary. + + declare + Queried_Offset : constant File_Size := Offset; + begin + Offset := Align (Offset); + + -- First extend the length to compensate the offset shift, then align + -- it on the upper page boundary, so that the whole queried area is + -- covered. + + Length := Length + Queried_Offset - Offset; + Length := Align (Length + Get_Page_Size - 1); + + -- But do not exceed the length of the file + if Offset + Length > File.Length then + Length := File.Length - Offset; + end if; + end; + + if Length > File_Size (Integer'Last) then + raise Ada.IO_Exceptions.Device_Error; + else + Mapping := Invalid_System_Mapping; + Mapping.Address := + Win.MapViewOfFile + (File.Mapping_Handle, Flags, + 0, DWORD (Offset), SIZE_T (Length)); + Mapping.Length := Length; + end if; + end Create_Mapping; + + --------------------- + -- Dispose_Mapping -- + --------------------- + + procedure Dispose_Mapping + (Mapping : in out System_Mapping) + is + Ignored : BOOL; + pragma Unreferenced (Ignored); + begin + Ignored := Win.UnmapViewOfFile (Mapping.Address); + Mapping := Invalid_System_Mapping; + end Dispose_Mapping; + + ------------------- + -- Get_Page_Size -- + ------------------- + + function Get_Page_Size return File_Size is + SystemInfo : aliased SYSTEM_INFO; + begin + GetSystemInfo (SystemInfo'Unchecked_Access); + return File_Size (SystemInfo.dwAllocationGranularity); + end Get_Page_Size; + + ----------- + -- Align -- + ----------- + + function Align + (Addr : File_Size) return File_Size is + begin + return Addr - Addr mod Get_Page_Size; + end Align; + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin-mingw.ads b/gcc/ada/libgnat/s-mmosin-mingw.ads new file mode 100644 index 0000000..3610065 --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin-mingw.ads @@ -0,0 +1,235 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- OS pecularities abstraction package for Win32 systems. + +package System.Mmap.OS_Interface is + + -- The Win package contains copy of definition found in recent System.Win32 + -- unit provided with the GNAT compiler. The copy is needed to be able to + -- compile this unit with older compilers. Note that this internal Win + -- package can be removed when GNAT 6.1.0 is not supported anymore. + + package Win is + + subtype PVOID is Standard.System.Address; + + type HANDLE is new Interfaces.C.ptrdiff_t; + + type WORD is new Interfaces.C.unsigned_short; + type DWORD is new Interfaces.C.unsigned_long; + type LONG is new Interfaces.C.long; + type SIZE_T is new Interfaces.C.size_t; + + type BOOL is new Interfaces.C.int; + for BOOL'Size use Interfaces.C.int'Size; + + FALSE : constant := 0; + + GENERIC_READ : constant := 16#80000000#; + GENERIC_WRITE : constant := 16#40000000#; + OPEN_EXISTING : constant := 3; + + type OVERLAPPED is record + Internal : DWORD; + InternalHigh : DWORD; + Offset : DWORD; + OffsetHigh : DWORD; + hEvent : HANDLE; + end record; + + type SECURITY_ATTRIBUTES is record + nLength : DWORD; + pSecurityDescriptor : PVOID; + bInheritHandle : BOOL; + end record; + + type SYSTEM_INFO is record + dwOemId : DWORD; + dwPageSize : DWORD; + lpMinimumApplicationAddress : PVOID; + lpMaximumApplicationAddress : PVOID; + dwActiveProcessorMask : PVOID; + dwNumberOfProcessors : DWORD; + dwProcessorType : DWORD; + dwAllocationGranularity : DWORD; + wProcessorLevel : WORD; + wProcessorRevision : WORD; + end record; + type LP_SYSTEM_INFO is access all SYSTEM_INFO; + + INVALID_HANDLE_VALUE : constant HANDLE := -1; + FILE_BEGIN : constant := 0; + FILE_SHARE_READ : constant := 16#00000001#; + FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#; + FILE_MAP_COPY : constant := 1; + FILE_MAP_READ : constant := 4; + FILE_MAP_WRITE : constant := 2; + PAGE_READONLY : constant := 16#0002#; + PAGE_READWRITE : constant := 16#0004#; + INVALID_FILE_SIZE : constant := 16#FFFFFFFF#; + + function CreateFile + (lpFileName : Standard.System.Address; + dwDesiredAccess : DWORD; + dwShareMode : DWORD; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + dwCreationDisposition : DWORD; + dwFlagsAndAttributes : DWORD; + hTemplateFile : HANDLE) return HANDLE; + pragma Import (Stdcall, CreateFile, "CreateFileW"); + + function WriteFile + (hFile : HANDLE; + lpBuffer : Standard.System.Address; + nNumberOfBytesToWrite : DWORD; + lpNumberOfBytesWritten : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, WriteFile, "WriteFile"); + + function ReadFile + (hFile : HANDLE; + lpBuffer : Standard.System.Address; + nNumberOfBytesToRead : DWORD; + lpNumberOfBytesRead : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, ReadFile, "ReadFile"); + + function CloseHandle (hObject : HANDLE) return BOOL; + pragma Import (Stdcall, CloseHandle, "CloseHandle"); + + function GetFileSize + (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD; + pragma Import (Stdcall, GetFileSize, "GetFileSize"); + + function SetFilePointer + (hFile : HANDLE; + lDistanceToMove : LONG; + lpDistanceToMoveHigh : access LONG; + dwMoveMethod : DWORD) return DWORD; + pragma Import (Stdcall, SetFilePointer, "SetFilePointer"); + + function CreateFileMapping + (hFile : HANDLE; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + flProtect : DWORD; + dwMaximumSizeHigh : DWORD; + dwMaximumSizeLow : DWORD; + lpName : Standard.System.Address) return HANDLE; + pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW"); + + function MapViewOfFile + (hFileMappingObject : HANDLE; + dwDesiredAccess : DWORD; + dwFileOffsetHigh : DWORD; + dwFileOffsetLow : DWORD; + dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address; + pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile"); + + function UnmapViewOfFile + (lpBaseAddress : Standard.System.Address) return BOOL; + pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile"); + + procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO); + pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); + + end Win; + + type System_File is record + Handle : Win.HANDLE; + + Mapped : Boolean; + -- Whether mapping is requested by the user and available on the system + + Mapping_Handle : Win.HANDLE; + + Write : Boolean; + -- Whether this file can be written to + + Length : File_Size; + -- Length of the file. Used to know what can be mapped in the file + end record; + + type System_Mapping is record + Address : Standard.System.Address; + Length : File_Size; + end record; + + Invalid_System_File : constant System_File := + (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0); + Invalid_System_Mapping : constant System_Mapping := + (Standard.System.Null_Address, 0); + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Open a file for reading and return the corresponding System_File. Return + -- Invalid_System_File if unsuccessful. + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Likewise for writing to a file + + procedure Close (File : in out System_File); + -- Close a system file + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access; + -- Read a fragment of a file. It is up to the caller to free the result + -- when done with it. + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access); + -- Write some content to a fragment of a file + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping); + -- Create a memory mapping for the given File, for the area starting at + -- Offset and containing Length bytes. Store it to Mapping. + -- Note that Offset and Length may be modified according to the system + -- needs (for boudaries, for instance). The caller must cope with actually + -- wider mapped areas. + + procedure Dispose_Mapping + (Mapping : in out System_Mapping); + -- Unmap a previously-created mapping + + function Get_Page_Size return File_Size; + -- Return the number of bytes in a system page. + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin-unix.adb b/gcc/ada/libgnat/s-mmosin-unix.adb new file mode 100644 index 0000000..aec2538 --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin-unix.adb @@ -0,0 +1,229 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with System; use System; + +with System.OS_Lib; use System.OS_Lib; +with System.Mmap.Unix; use System.Mmap.Unix; + +package body System.Mmap.OS_Interface is + + function Align + (Addr : File_Size) return File_Size; + -- Align some offset/length to the lowest page boundary + + function Is_Mapping_Available return Boolean renames + System.Mmap.Unix.Is_Mapping_Available; + -- Wheter memory mapping is actually available on this system. It is an + -- error to use Create_Mapping and Dispose_Mapping if this is False. + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + Fd : constant File_Descriptor := + Open_Read (Filename, Binary); + begin + if Fd = Invalid_FD then + return Invalid_System_File; + end if; + return + (Fd => Fd, + Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, + Write => False, + Length => File_Size (File_Length (Fd))); + end Open_Read; + + ---------------- + -- Open_Write -- + ---------------- + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File is + Fd : constant File_Descriptor := + Open_Read_Write (Filename, Binary); + begin + if Fd = Invalid_FD then + return Invalid_System_File; + end if; + return + (Fd => Fd, + Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, + Write => True, + Length => File_Size (File_Length (Fd))); + end Open_Write; + + ----------- + -- Close -- + ----------- + + procedure Close (File : in out System_File) is + begin + Close (File.Fd); + File.Fd := Invalid_FD; + end Close; + + -------------------- + -- Read_From_Disk -- + -------------------- + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access + is + Buffer : String_Access := new String (1 .. Integer (Length)); + begin + -- ??? Lseek offset should be a size_t instead of a Long_Integer + + Lseek (File.Fd, Long_Integer (Offset), Seek_Set); + if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length)) + /= Integer (Length) + then + System.Strings.Free (Buffer); + raise Ada.IO_Exceptions.Device_Error; + end if; + return Buffer; + end Read_From_Disk; + + ------------------- + -- Write_To_Disk -- + ------------------- + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access) is + begin + pragma Assert (File.Write); + Lseek (File.Fd, Long_Integer (Offset), Seek_Set); + if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length)) + /= Integer (Length) + then + raise Ada.IO_Exceptions.Device_Error; + end if; + end Write_To_Disk; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping) + is + Prot : Mmap_Prot; + Flags : Mmap_Flags; + begin + if File.Write then + Prot := PROT_READ + PROT_WRITE; + Flags := MAP_SHARED; + else + Prot := PROT_READ; + if Mutable then + Prot := Prot + PROT_WRITE; + end if; + Flags := MAP_PRIVATE; + end if; + + -- Adjust offset and mapping length to account for the required + -- alignment of offset on page boundary. + + declare + Queried_Offset : constant File_Size := Offset; + begin + Offset := Align (Offset); + + -- First extend the length to compensate the offset shift, then align + -- it on the upper page boundary, so that the whole queried area is + -- covered. + + Length := Length + Queried_Offset - Offset; + Length := Align (Length + Get_Page_Size - 1); + end; + + if Length > File_Size (Integer'Last) then + raise Ada.IO_Exceptions.Device_Error; + else + Mapping := + (Address => System.Mmap.Unix.Mmap + (Offset => off_t (Offset), + Length => Interfaces.C.size_t (Length), + Prot => Prot, + Flags => Flags, + Fd => File.Fd), + Length => Length); + end if; + end Create_Mapping; + + --------------------- + -- Dispose_Mapping -- + --------------------- + + procedure Dispose_Mapping + (Mapping : in out System_Mapping) + is + Ignored : Integer; + pragma Unreferenced (Ignored); + begin + Ignored := Munmap + (Mapping.Address, Interfaces.C.size_t (Mapping.Length)); + Mapping := Invalid_System_Mapping; + end Dispose_Mapping; + + ------------------- + -- Get_Page_Size -- + ------------------- + + function Get_Page_Size return File_Size is + function Internal return Integer; + pragma Import (C, Internal, "getpagesize"); + begin + return File_Size (Internal); + end Get_Page_Size; + + ----------- + -- Align -- + ----------- + + function Align + (Addr : File_Size) return File_Size is + begin + return Addr - Addr mod Get_Page_Size; + end Align; + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-mmosin-unix.ads b/gcc/ada/libgnat/s-mmosin-unix.ads new file mode 100644 index 0000000..7162ddc --- /dev/null +++ b/gcc/ada/libgnat/s-mmosin-unix.ads @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . M M A P . O S _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, AdaCore -- +-- -- +-- This library is free software; you can redistribute it and/or modify it -- +-- under terms of the GNU General Public License as published by the Free -- +-- Software Foundation; either version 3, or (at your option) any later -- +-- version. This library is distributed in the hope that it will be useful, -- +-- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- +-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.OS_Lib; + +-- OS pecularities abstraction package for Unix systems. + +package System.Mmap.OS_Interface is + + type System_File is record + Fd : System.OS_Lib.File_Descriptor; + + Mapped : Boolean; + -- Whether mapping is requested by the user and available on the system + + Write : Boolean; + -- Whether this file can be written to + + Length : File_Size; + -- Length of the file. Used to know what can be mapped in the file + end record; + + type System_Mapping is record + Address : Standard.System.Address; + Length : File_Size; + end record; + + Invalid_System_File : constant System_File := + (System.OS_Lib.Invalid_FD, False, False, 0); + Invalid_System_Mapping : constant System_Mapping := + (Standard.System.Null_Address, 0); + + function Open_Read + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Open a file for reading and return the corresponding System_File. Return + -- Invalid_System_File if unsuccessful. + + function Open_Write + (Filename : String; + Use_Mmap_If_Available : Boolean := True) return System_File; + -- Likewise for writing to a file + + procedure Close (File : in out System_File); + -- Close a system file + + function Read_From_Disk + (File : System_File; + Offset, Length : File_Size) return System.Strings.String_Access; + -- Read a fragment of a file. It is up to the caller to free the result + -- when done with it. + + procedure Write_To_Disk + (File : System_File; + Offset, Length : File_Size; + Buffer : System.Strings.String_Access); + -- Write some content to a fragment of a file + + procedure Create_Mapping + (File : System_File; + Offset, Length : in out File_Size; + Mutable : Boolean; + Mapping : out System_Mapping); + -- Create a memory mapping for the given File, for the area starting at + -- Offset and containing Length bytes. Store it to Mapping. + -- Note that Offset and Length may be modified according to the system + -- needs (for boudaries, for instance). The caller must cope with actually + -- wider mapped areas. + + procedure Dispose_Mapping + (Mapping : in out System_Mapping); + -- Unmap a previously-created mapping + + function Get_Page_Size return File_Size; + -- Return the number of bytes in a system page. + +end System.Mmap.OS_Interface; diff --git a/gcc/ada/libgnat/s-multip.adb b/gcc/ada/libgnat/s-multip.adb new file mode 100644 index 0000000..166cf30 --- /dev/null +++ b/gcc/ada/libgnat/s-multip.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . M U L T I P R O C E S S O R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2010-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces.C; use Interfaces.C; + +package body System.Multiprocessors is + + -------------------- + -- Number_Of_CPUs -- + -------------------- + + function Number_Of_CPUs return CPU is + begin + if CPU'Last = 1 then + return 1; + else + declare + function Gnat_Number_Of_CPUs return int; + pragma Import (C, Gnat_Number_Of_CPUs, "__gnat_number_of_cpus"); + begin + return CPU (Gnat_Number_Of_CPUs); + end; + end if; + end Number_Of_CPUs; + +end System.Multiprocessors; diff --git a/gcc/ada/libgnat/s-multip.ads b/gcc/ada/libgnat/s-multip.ads new file mode 100644 index 0000000..7eb8dd6 --- /dev/null +++ b/gcc/ada/libgnat/s-multip.ads @@ -0,0 +1,28 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . M U L T I P R O C E S S O R S -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +package System.Multiprocessors is + pragma Preelaborate (Multiprocessors); + + type CPU_Range is range 0 .. 2 ** 16 - 1; + + subtype CPU is CPU_Range range 1 .. CPU_Range'Last; + + Not_A_Specific_CPU : constant CPU_Range := 0; + + function Number_Of_CPUs return CPU; + -- Number of available CPUs + +end System.Multiprocessors; diff --git a/gcc/ada/libgnat/s-objrea.adb b/gcc/ada/libgnat/s-objrea.adb new file mode 100644 index 0000000..451abcd --- /dev/null +++ b/gcc/ada/libgnat/s-objrea.adb @@ -0,0 +1,2246 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O B J E C T _ R E A D E R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +with System.CRTL; + +package body System.Object_Reader is + use Interfaces; + use Interfaces.C; + use System.Mmap; + + SSU : constant := System.Storage_Unit; + + function To_int32 is new Ada.Unchecked_Conversion (uint32, int32); + + function Trim_Trailing_Nuls (Str : String) return String; + -- Return a copy of a string with any trailing NUL characters truncated + + procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32); + -- Check that the SIZE bytes at the current offset are still in the stream + + ------------------------------------- + -- ELF object file format handling -- + ------------------------------------- + + generic + type uword is mod <>; + + package ELF_Ops is + + -- ELF version codes + + ELFCLASS32 : constant := 1; -- 32 bit ELF + ELFCLASS64 : constant := 2; -- 64 bit ELF + + -- ELF machine codes + + EM_NONE : constant := 0; -- No machine + EM_SPARC : constant := 2; -- SUN SPARC + EM_386 : constant := 3; -- Intel 80386 + EM_MIPS : constant := 8; -- MIPS RS3000 Big-Endian + EM_MIPS_RS3_LE : constant := 10; -- MIPS RS3000 Little-Endian + EM_SPARC32PLUS : constant := 18; -- Sun SPARC 32+ + EM_PPC : constant := 20; -- PowerPC + EM_PPC64 : constant := 21; -- PowerPC 64-bit + EM_ARM : constant := 40; -- ARM + EM_SPARCV9 : constant := 43; -- SPARC v9 64-bit + EM_IA_64 : constant := 50; -- Intel Merced + EM_X86_64 : constant := 62; -- AMD x86-64 architecture + + EN_NIDENT : constant := 16; + + type E_Ident_Type is array (0 .. EN_NIDENT - 1) of uint8; + + type Header is record + E_Ident : E_Ident_Type; -- Magic number and other info + E_Type : uint16; -- Object file type + E_Machine : uint16; -- Architecture + E_Version : uint32; -- Object file version + E_Entry : uword; -- Entry point virtual address + E_Phoff : uword; -- Program header table file offset + E_Shoff : uword; -- Section header table file offset + E_Flags : uint32; -- Processor-specific flags + E_Ehsize : uint16; -- ELF header size in bytes + E_Phentsize : uint16; -- Program header table entry size + E_Phnum : uint16; -- Program header table entry count + E_Shentsize : uint16; -- Section header table entry size + E_Shnum : uint16; -- Section header table entry count + E_Shstrndx : uint16; -- Section header string table index + end record; + + type Section_Header is record + Sh_Name : uint32; -- Section name string table index + Sh_Type : uint32; -- Section type + Sh_Flags : uword; -- Section flags + Sh_Addr : uword; -- Section virtual addr at execution + Sh_Offset : uword; -- Section file offset + Sh_Size : uword; -- Section size in bytes + Sh_Link : uint32; -- Link to another section + Sh_Info : uint32; -- Additional section information + Sh_Addralign : uword; -- Section alignment + Sh_Entsize : uword; -- Entry size if section holds table + end record; + + SHF_ALLOC : constant := 2; + + type Symtab_Entry32 is record + St_Name : uint32; -- Name (string table index) + St_Value : uint32; -- Value + St_Size : uint32; -- Size in bytes + St_Info : uint8; -- Type and binding attributes + St_Other : uint8; -- Undefined + St_Shndx : uint16; -- Defining section + end record; + + type Symtab_Entry64 is record + St_Name : uint32; -- Name (string table index) + St_Info : uint8; -- Type and binding attributes + St_Other : uint8; -- Undefined + St_Shndx : uint16; -- Defining section + St_Value : uint64; -- Value + St_Size : uint64; -- Size in bytes + end record; + + function Read_Header (F : in out Mapped_Stream) return Header; + -- Read a header from an ELF format object + + function First_Symbol + (Obj : in out ELF_Object_File) return Object_Symbol; + -- Return the first element in the symbol table, or Null_Symbol if the + -- symbol table is empty. + + function Read_Symbol + (Obj : in out ELF_Object_File; + Off : Offset) return Object_Symbol; + -- Read a symbol at offset Off + + function Name + (Obj : in out ELF_Object_File; + Sym : Object_Symbol) return String_Ptr_Len; + -- Return the name of the symbol + + function Name + (Obj : in out ELF_Object_File; + Sec : Object_Section) return String; + -- Return the name of a section + + function Get_Section + (Obj : in out ELF_Object_File; + Shnum : uint32) return Object_Section; + -- Fetch a section by index from zero + + function Initialize + (F : Mapped_File; + Hdr : Header; + In_Exception : Boolean) return ELF_Object_File; + -- Initialize an object file + + end ELF_Ops; + + ----------------------------------- + -- PECOFF object format handling -- + ----------------------------------- + + package PECOFF_Ops is + + -- Constants and data layout are taken from the document "Microsoft + -- Portable Executable and Common Object File Format Specification" + -- Revision 8.1. + + Signature_Loc_Offset : constant := 16#3C#; + -- Offset of pointer to the file signature + + Size_Of_Standard_Header_Fields : constant := 16#18#; + -- Length in bytes of the standard header record + + Function_Symbol_Type : constant := 16#20#; + -- Type field value indicating a symbol refers to a function + + Not_Function_Symbol_Type : constant := 16#00#; + -- Type field value indicating a symbol does not refer to a function + + type Magic_Array is array (0 .. 3) of uint8; + -- Array of magic numbers from the header + + -- Magic numbers for PECOFF variants + + VARIANT_PE32 : constant := 16#010B#; + VARIANT_PE32_PLUS : constant := 16#020B#; + + -- PECOFF machine codes + + IMAGE_FILE_MACHINE_I386 : constant := 16#014C#; + IMAGE_FILE_MACHINE_IA64 : constant := 16#0200#; + IMAGE_FILE_MACHINE_AMD64 : constant := 16#8664#; + + -- PECOFF Data layout + + type Header is record + Magics : Magic_Array; + Machine : uint16; + NumberOfSections : uint16; + TimeDateStamp : uint32; + PointerToSymbolTable : uint32; + NumberOfSymbols : uint32; + SizeOfOptionalHeader : uint16; + Characteristics : uint16; + Variant : uint16; + end record; + + pragma Pack (Header); + + type Optional_Header_PE32 is record + Magic : uint16; + MajorLinkerVersion : uint8; + MinorLinkerVersion : uint8; + SizeOfCode : uint32; + SizeOfInitializedData : uint32; + SizeOfUninitializedData : uint32; + AddressOfEntryPoint : uint32; + BaseOfCode : uint32; + BaseOfData : uint32; -- Note: not in PE32+ + ImageBase : uint32; + SectionAlignment : uint32; + FileAlignment : uint32; + MajorOperatingSystemVersion : uint16; + MinorOperationSystemVersion : uint16; + MajorImageVersion : uint16; + MinorImageVersion : uint16; + MajorSubsystemVersion : uint16; + MinorSubsystemVersion : uint16; + Win32VersionValue : uint32; + SizeOfImage : uint32; + SizeOfHeaders : uint32; + Checksum : uint32; + Subsystem : uint16; + DllCharacteristics : uint16; + SizeOfStackReserve : uint32; + SizeOfStackCommit : uint32; + SizeOfHeapReserve : uint32; + SizeOfHeapCommit : uint32; + LoaderFlags : uint32; + NumberOfRvaAndSizes : uint32; + end record; + pragma Pack (Optional_Header_PE32); + pragma Assert (Optional_Header_PE32'Size = 96 * SSU); + + type Optional_Header_PE64 is record + Magic : uint16; + MajorLinkerVersion : uint8; + MinorLinkerVersion : uint8; + SizeOfCode : uint32; + SizeOfInitializedData : uint32; + SizeOfUninitializedData : uint32; + AddressOfEntryPoint : uint32; + BaseOfCode : uint32; + ImageBase : uint64; + SectionAlignment : uint32; + FileAlignment : uint32; + MajorOperatingSystemVersion : uint16; + MinorOperationSystemVersion : uint16; + MajorImageVersion : uint16; + MinorImageVersion : uint16; + MajorSubsystemVersion : uint16; + MinorSubsystemVersion : uint16; + Win32VersionValue : uint32; + SizeOfImage : uint32; + SizeOfHeaders : uint32; + Checksum : uint32; + Subsystem : uint16; + DllCharacteristics : uint16; + SizeOfStackReserve : uint64; + SizeOfStackCommit : uint64; + SizeOfHeapReserve : uint64; + SizeOfHeapCommit : uint64; + LoaderFlags : uint32; + NumberOfRvaAndSizes : uint32; + end record; + pragma Pack (Optional_Header_PE64); + pragma Assert (Optional_Header_PE64'Size = 112 * SSU); + + subtype Name_Str is String (1 .. 8); + + type Section_Header is record + Name : Name_Str; + VirtualSize : uint32; + VirtualAddress : uint32; + SizeOfRawData : uint32; + PointerToRawData : uint32; + PointerToRelocations : uint32; + PointerToLinenumbers : uint32; + NumberOfRelocations : uint16; + NumberOfLinenumbers : uint16; + Characteristics : uint32; + end record; + + pragma Pack (Section_Header); + + IMAGE_SCN_CNT_CODE : constant := 16#0020#; + + type Symtab_Entry is record + Name : Name_Str; + Value : uint32; + SectionNumber : int16; + TypeField : uint16; + StorageClass : uint8; + NumberOfAuxSymbols : uint8; + end record; + + pragma Pack (Symtab_Entry); + + type Auxent_Section is record + Length : uint32; + NumberOfRelocations : uint16; + NumberOfLinenumbers : uint16; + CheckSum : uint32; + Number : uint16; + Selection : uint8; + Unused1 : uint8; + Unused2 : uint8; + Unused3 : uint8; + end record; + + for Auxent_Section'Size use 18 * 8; + + function Read_Header (F : in out Mapped_Stream) return Header; + -- Read the object file header + + function First_Symbol + (Obj : in out PECOFF_Object_File) return Object_Symbol; + -- Return the first element in the symbol table, or Null_Symbol if the + -- symbol table is empty. + + function Read_Symbol + (Obj : in out PECOFF_Object_File; + Off : Offset) return Object_Symbol; + -- Read a symbol at offset Off + + function Name + (Obj : in out PECOFF_Object_File; + Sym : Object_Symbol) return String_Ptr_Len; + -- Return the name of the symbol + + function Name + (Obj : in out PECOFF_Object_File; + Sec : Object_Section) return String; + -- Return the name of a section + + function Get_Section + (Obj : in out PECOFF_Object_File; + Index : uint32) return Object_Section; + -- Fetch a section by index from zero + + function Initialize + (F : Mapped_File; + Hdr : Header; + In_Exception : Boolean) return PECOFF_Object_File; + -- Initialize an object file + + end PECOFF_Ops; + + ------------------------------------- + -- XCOFF-32 object format handling -- + ------------------------------------- + + package XCOFF32_Ops is + + -- XCOFF Data layout + + type Header is record + f_magic : uint16; + f_nscns : uint16; + f_timdat : uint32; + f_symptr : uint32; + f_nsyms : uint32; + f_opthdr : uint16; + f_flags : uint16; + end record; + + type Auxiliary_Header is record + o_mflag : uint16; + o_vstamp : uint16; + o_tsize : uint32; + o_dsize : uint32; + o_bsize : uint32; + o_entry : uint32; + o_text_start : uint32; + o_data_start : uint32; + o_toc : uint32; + o_snentry : uint16; + o_sntext : uint16; + o_sndata : uint16; + o_sntoc : uint16; + o_snloader : uint16; + o_snbss : uint16; + o_algntext : uint16; + o_algndata : uint16; + o_modtype : uint16; + o_cpuflag : uint8; + o_cputype : uint8; + o_maxstack : uint32; + o_maxdata : uint32; + o_debugger : uint32; + o_flags : uint8; + o_sntdata : uint16; + o_sntbss : uint16; + end record; + pragma Unreferenced (Auxiliary_Header); + -- Not used, but not removed (just in case) + + subtype Name_Str is String (1 .. 8); + + type Section_Header is record + s_name : Name_Str; + s_paddr : uint32; + s_vaddr : uint32; + s_size : uint32; + s_scnptr : uint32; + s_relptr : uint32; + s_lnnoptr : uint32; + s_nreloc : uint16; + s_nlnno : uint16; + s_flags : uint32; + end record; + + pragma Pack (Section_Header); + + STYP_TEXT : constant := 16#0020#; + + type Symbol_Entry is record + n_name : Name_Str; + n_value : uint32; + n_scnum : uint16; + n_type : uint16; + n_sclass : uint8; + n_numaux : uint8; + end record; + for Symbol_Entry'Size use 18 * 8; + + type Aux_Entry is record + x_scnlen : uint32; + x_parmhash : uint32; + x_snhash : uint16; + x_smtyp : uint8; + x_smclass : uint8; + x_stab : uint32; + x_snstab : uint16; + end record; + for Aux_Entry'Size use 18 * 8; + + pragma Pack (Aux_Entry); + + C_EXT : constant := 2; + C_HIDEXT : constant := 107; + C_WEAKEXT : constant := 111; + + XTY_LD : constant := 2; + -- Magic constant should be documented, especially since it's changed??? + + function Read_Header (F : in out Mapped_Stream) return Header; + -- Read the object file header + + function First_Symbol + (Obj : in out XCOFF32_Object_File) return Object_Symbol; + -- Return the first element in the symbol table, or Null_Symbol if the + -- symbol table is empty. + + function Read_Symbol + (Obj : in out XCOFF32_Object_File; + Off : Offset) return Object_Symbol; + -- Read a symbol at offset Off + + function Name + (Obj : in out XCOFF32_Object_File; + Sym : Object_Symbol) return String_Ptr_Len; + -- Return the name of the symbol + + function Name + (Obj : in out XCOFF32_Object_File; + Sec : Object_Section) return String; + -- Return the name of a section + + function Initialize + (F : Mapped_File; + Hdr : Header; + In_Exception : Boolean) return XCOFF32_Object_File; + -- Initialize an object file + + function Get_Section + (Obj : in out XCOFF32_Object_File; + Index : uint32) return Object_Section; + -- Fetch a section by index from zero + + end XCOFF32_Ops; + + ------------- + -- ELF_Ops -- + ------------- + + package body ELF_Ops is + + function Get_String_Table (Obj : in out ELF_Object_File) + return Object_Section; + -- Fetch the section containing the string table + + function Get_Symbol_Table (Obj : in out ELF_Object_File) + return Object_Section; + -- Fetch the section containing the symbol table + + function Read_Section_Header + (Obj : in out ELF_Object_File; + Shnum : uint32) return Section_Header; + -- Read the header for an ELF format object section indexed from zero + + ------------------ + -- First_Symbol -- + ------------------ + + function First_Symbol + (Obj : in out ELF_Object_File) return Object_Symbol + is + begin + if Obj.Symtab_Last = 0 then + return Null_Symbol; + else + return Read_Symbol (Obj, 0); + end if; + end First_Symbol; + + ----------------- + -- Get_Section -- + ----------------- + + function Get_Section + (Obj : in out ELF_Object_File; + Shnum : uint32) return Object_Section + is + SHdr : constant Section_Header := Read_Section_Header (Obj, Shnum); + begin + return (Shnum, + Offset (SHdr.Sh_Offset), + uint64 (SHdr.Sh_Addr), + uint64 (SHdr.Sh_Size), + (SHdr.Sh_Flags and SHF_ALLOC) /= 0); + end Get_Section; + + ------------------------ + -- Get_String_Table -- + ------------------------ + + function Get_String_Table + (Obj : in out ELF_Object_File) return Object_Section + is + begin + -- All cases except MIPS IRIX, string table located in .strtab + + if Obj.Arch /= MIPS then + return Get_Section (Obj, ".strtab"); + + -- On IRIX only .dynstr is available + + else + return Get_Section (Obj, ".dynstr"); + end if; + end Get_String_Table; + + ------------------------ + -- Get_Symbol_Table -- + ------------------------ + + function Get_Symbol_Table + (Obj : in out ELF_Object_File) return Object_Section + is + begin + -- All cases except MIPS IRIX, symbol table located in .symtab + + if Obj.Arch /= MIPS then + return Get_Section (Obj, ".symtab"); + + -- On IRIX, symbol table located somewhere other than .symtab + + else + return Get_Section (Obj, ".dynsym"); + end if; + end Get_Symbol_Table; + + ---------------- + -- Initialize -- + ---------------- + + function Initialize + (F : Mapped_File; + Hdr : Header; + In_Exception : Boolean) return ELF_Object_File + is + Res : ELF_Object_File + (Format => (case uword'Size is + when 64 => ELF64, + when 32 => ELF32, + when others => raise Program_Error)); + Sec : Object_Section; + begin + Res.MF := F; + Res.In_Exception := In_Exception; + Res.Num_Sections := uint32 (Hdr.E_Shnum); + + case Hdr.E_Machine is + when EM_SPARC + | EM_SPARC32PLUS + => + Res.Arch := SPARC; + + when EM_386 => + Res.Arch := i386; + + when EM_MIPS + | EM_MIPS_RS3_LE + => + Res.Arch := MIPS; + + when EM_PPC => + Res.Arch := PPC; + + when EM_PPC64 => + Res.Arch := PPC64; + + when EM_SPARCV9 => + Res.Arch := SPARC64; + + when EM_IA_64 => + Res.Arch := IA64; + + when EM_X86_64 => + Res.Arch := x86_64; + + when others => + raise Format_Error with "unrecognized architecture"; + end case; + + -- Map section table and section string table + Res.Sectab_Stream := Create_Stream + (F, File_Size (Hdr.E_Shoff), + File_Size (Hdr.E_Shnum) * File_Size (Hdr.E_Shentsize)); + Sec := Get_Section (Res, uint32 (Hdr.E_Shstrndx)); + Res.Secstr_Stream := Create_Stream (Res, Sec); + + -- Map symbol and string table + Sec := Get_Symbol_Table (Res); + Res.Symtab_Stream := Create_Stream (Res, Sec); + Res.Symtab_Last := Offset (Sec.Size); + + Sec := Get_String_Table (Res); + Res.Symstr_Stream := Create_Stream (Res, Sec); + + return Res; + end Initialize; + + ----------------- + -- Read_Header -- + ----------------- + + function Read_Header (F : in out Mapped_Stream) return Header is + Hdr : Header; + begin + Seek (F, 0); + Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); + return Hdr; + end Read_Header; + + ------------------------- + -- Read_Section_Header -- + ------------------------- + + function Read_Section_Header + (Obj : in out ELF_Object_File; + Shnum : uint32) return Section_Header + is + Shdr : Section_Header; + begin + Seek (Obj.Sectab_Stream, Offset (Shnum * Section_Header'Size / SSU)); + Read_Raw (Obj.Sectab_Stream, Shdr'Address, Section_Header'Size / SSU); + return Shdr; + end Read_Section_Header; + + ----------------- + -- Read_Symbol -- + ----------------- + + function Read_Symbol + (Obj : in out ELF_Object_File; + Off : Offset) return Object_Symbol + is + ST_Entry32 : Symtab_Entry32; + ST_Entry64 : Symtab_Entry64; + Res : Object_Symbol; + + begin + Seek (Obj.Symtab_Stream, Off); + + case uword'Size is + when 32 => + Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address, + uint32 (ST_Entry32'Size / SSU)); + Res := (Off, + Off + ST_Entry32'Size / SSU, + uint64 (ST_Entry32.St_Value), + uint64 (ST_Entry32.St_Size)); + + when 64 => + Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address, + uint32 (ST_Entry64'Size / SSU)); + Res := (Off, + Off + ST_Entry64'Size / SSU, + ST_Entry64.St_Value, + ST_Entry64.St_Size); + + when others => + raise Program_Error; + end case; + + return Res; + end Read_Symbol; + + ---------- + -- Name -- + ---------- + + function Name + (Obj : in out ELF_Object_File; + Sec : Object_Section) return String + is + SHdr : Section_Header; + begin + SHdr := Read_Section_Header (Obj, Sec.Num); + return Offset_To_String (Obj.Secstr_Stream, Offset (SHdr.Sh_Name)); + end Name; + + function Name + (Obj : in out ELF_Object_File; + Sym : Object_Symbol) return String_Ptr_Len + is + ST_Entry32 : Symtab_Entry32; + ST_Entry64 : Symtab_Entry64; + Name_Off : Offset; + + begin + -- Test that this symbol is not null + + if Sym = Null_Symbol then + return (null, 0); + end if; + + -- Read the symbol table entry + + Seek (Obj.Symtab_Stream, Sym.Off); + + case uword'Size is + when 32 => + Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address, + uint32 (ST_Entry32'Size / SSU)); + Name_Off := Offset (ST_Entry32.St_Name); + + when 64 => + Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address, + uint32 (ST_Entry64'Size / SSU)); + Name_Off := Offset (ST_Entry64.St_Name); + + when others => + raise Program_Error; + end case; + + -- Fetch the name from the string table + + Seek (Obj.Symstr_Stream, Name_Off); + return Read (Obj.Symstr_Stream); + end Name; + + end ELF_Ops; + + package ELF32_Ops is new ELF_Ops (uint32); + package ELF64_Ops is new ELF_Ops (uint64); + + ---------------- + -- PECOFF_Ops -- + ---------------- + + package body PECOFF_Ops is + + function Decode_Name + (Obj : in out PECOFF_Object_File; + Raw_Name : String) return String; + -- A section name is an 8 byte field padded on the right with null + -- characters, or a '\' followed by an ASCII decimal string indicating + -- an offset in to the string table. This routine decodes this + + function Get_Section_Virtual_Address + (Obj : in out PECOFF_Object_File; + Index : uint32) return uint64; + -- Fetch the address at which a section is loaded + + function Read_Section_Header + (Obj : in out PECOFF_Object_File; + Index : uint32) return Section_Header; + -- Read a header from section table + + function String_Table + (Obj : in out PECOFF_Object_File; + Index : Offset) return String; + -- Return an entry from the string table + + ----------------- + -- Decode_Name -- + ----------------- + + function Decode_Name + (Obj : in out PECOFF_Object_File; + Raw_Name : String) return String + is + Name_Or_Ref : constant String := Trim_Trailing_Nuls (Raw_Name); + Off : Offset; + + begin + -- We should never find a symbol with a zero length name. If we do it + -- probably means we are not parsing the symbol table correctly. If + -- this happens we raise a fatal error. + + if Name_Or_Ref'Length = 0 then + raise Format_Error with + "found zero length symbol in symbol table"; + end if; + + if Name_Or_Ref (1) /= '/' then + return Name_Or_Ref; + else + Off := Offset'Value (Name_Or_Ref (2 .. Name_Or_Ref'Last)); + return String_Table (Obj, Off); + end if; + end Decode_Name; + + ------------------ + -- First_Symbol -- + ------------------ + + function First_Symbol + (Obj : in out PECOFF_Object_File) return Object_Symbol is + begin + -- Return Null_Symbol in the case that the symbol table is empty + + if Obj.Symtab_Last = 0 then + return Null_Symbol; + end if; + + return Read_Symbol (Obj, 0); + end First_Symbol; + + ----------------- + -- Get_Section -- + ----------------- + + function Get_Section + (Obj : in out PECOFF_Object_File; + Index : uint32) return Object_Section + is + Sec : constant Section_Header := Read_Section_Header (Obj, Index); + begin + -- Use VirtualSize instead of SizeOfRawData. The latter is rounded to + -- the page size, so it may add garbage to the content. On the other + -- side, the former may be larger than the latter in case of 0 + -- padding. + + return (Index, + Offset (Sec.PointerToRawData), + uint64 (Sec.VirtualAddress) + Obj.ImageBase, + uint64 (Sec.VirtualSize), + (Sec.Characteristics and IMAGE_SCN_CNT_CODE) /= 0); + end Get_Section; + + --------------------------------- + -- Get_Section_Virtual_Address -- + --------------------------------- + + function Get_Section_Virtual_Address + (Obj : in out PECOFF_Object_File; + Index : uint32) return uint64 + is + Sec : Section_Header; + + begin + -- Try cache + + if Index = Obj.GSVA_Sec then + return Obj.GSVA_Addr; + end if; + + Obj.GSVA_Sec := Index; + Sec := Read_Section_Header (Obj, Index); + Obj.GSVA_Addr := Obj.ImageBase + uint64 (Sec.VirtualAddress); + return Obj.GSVA_Addr; + end Get_Section_Virtual_Address; + + ---------------- + -- Initialize -- + ---------------- + + function Initialize + (F : Mapped_File; + Hdr : Header; + In_Exception : Boolean) return PECOFF_Object_File + is + Res : PECOFF_Object_File + (Format => (case Hdr.Variant is + when PECOFF_Ops.VARIANT_PE32 => PECOFF, + when PECOFF_Ops.VARIANT_PE32_PLUS => PECOFF_PLUS, + when others => raise Program_Error + with "unrecognized PECOFF variant")); + Symtab_Size : constant Offset := + Offset (Hdr.NumberOfSymbols) * (Symtab_Entry'Size / SSU); + Strtab_Size : uint32; + Hdr_Offset : Offset; + Opt_Offset : File_Size; + Opt_Stream : Mapped_Stream; + begin + Res.MF := F; + Res.In_Exception := In_Exception; + + case Hdr.Machine is + when PECOFF_Ops.IMAGE_FILE_MACHINE_I386 => + Res.Arch := i386; + when PECOFF_Ops.IMAGE_FILE_MACHINE_IA64 => + Res.Arch := IA64; + when PECOFF_Ops.IMAGE_FILE_MACHINE_AMD64 => + Res.Arch := x86_64; + when others => + raise Format_Error with "unrecognized architecture"; + end case; + + Res.Num_Sections := uint32 (Hdr.NumberOfSections); + + -- Map symbol table and the first following word (which is the length + -- of the string table). + + Res.Symtab_Last := Symtab_Size; + Res.Symtab_Stream := Create_Stream + (F, + File_Size (Hdr.PointerToSymbolTable), + File_Size (Symtab_Size + 4)); + + -- Map string table. The first 4 bytes are the length of the string + -- table and are part of it. + + Seek (Res.Symtab_Stream, Symtab_Size); + Strtab_Size := Read (Res.Symtab_Stream); + Res.Symstr_Stream := Create_Stream + (F, + File_Size (Hdr.PointerToSymbolTable) + File_Size (Symtab_Size), + File_Size (Strtab_Size)); + + -- Map section table + + Opt_Stream := Create_Stream (Res.Mf, Signature_Loc_Offset, 4); + Hdr_Offset := Offset (uint32'(Read (Opt_Stream))); + Close (Opt_Stream); + Res.Sectab_Stream := Create_Stream + (F, + File_Size (Hdr_Offset + + Size_Of_Standard_Header_Fields + + Offset (Hdr.SizeOfOptionalHeader)), + File_Size (Res.Num_Sections) + * File_Size (Section_Header'Size / SSU)); + + -- Read optional header and extract image base + + Opt_Offset := File_Size (Hdr_Offset + Size_Of_Standard_Header_Fields); + + if Res.Format = PECOFF then + declare + Opt_32 : Optional_Header_PE32; + begin + Opt_Stream := Create_Stream + (Res.Mf, Opt_Offset, Opt_32'Size / SSU); + Read_Raw + (Opt_Stream, Opt_32'Address, uint32 (Opt_32'Size / SSU)); + Res.ImageBase := uint64 (Opt_32.ImageBase); + Close (Opt_Stream); + end; + + else + declare + Opt_64 : Optional_Header_PE64; + begin + Opt_Stream := Create_Stream + (Res.Mf, Opt_Offset, Opt_64'Size / SSU); + Read_Raw + (Opt_Stream, Opt_64'Address, uint32 (Opt_64'Size / SSU)); + Res.ImageBase := Opt_64.ImageBase; + Close (Opt_Stream); + end; + end if; + + return Res; + end Initialize; + + ----------------- + -- Read_Symbol -- + ----------------- + + function Read_Symbol + (Obj : in out PECOFF_Object_File; + Off : Offset) return Object_Symbol + is + ST_Entry : Symtab_Entry; + ST_Last : Symtab_Entry; + Aux_Entry : Auxent_Section; + Sz : constant Offset := ST_Entry'Size / SSU; + Result : Object_Symbol; + Noff : Offset; + Sym_Off : Offset; + + begin + -- Seek to the successor of Prev + + Noff := Off; + + loop + Sym_Off := Noff; + + Seek (Obj.Symtab_Stream, Sym_Off); + Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, uint32 (Sz)); + + -- Skip AUX entries + + Noff := Noff + Offset (1 + ST_Entry.NumberOfAuxSymbols) * Sz; + + exit when ST_Entry.TypeField = Function_Symbol_Type + and then ST_Entry.SectionNumber > 0; + + if Noff >= Obj.Symtab_Last then + return Null_Symbol; + end if; + end loop; + + -- Construct the symbol + + Result := + (Off => Sym_Off, + Next => Noff, + Value => uint64 (ST_Entry.Value), + Size => 0); + + -- Set the size as accurately as possible + + -- The size of a symbol is not directly available so we try scanning + -- to the next function and assuming the code ends there. + + loop + -- Read symbol and AUX entries + + Sym_Off := Noff; + Seek (Obj.Symtab_Stream, Sym_Off); + Read_Raw (Obj.Symtab_Stream, ST_Last'Address, uint32 (Sz)); + + for I in 1 .. ST_Last.NumberOfAuxSymbols loop + Read_Raw (Obj.Symtab_Stream, Aux_Entry'Address, uint32 (Sz)); + end loop; + + Noff := Noff + Offset (1 + ST_Last.NumberOfAuxSymbols) * Sz; + + if ST_Last.TypeField = Function_Symbol_Type then + if ST_Last.SectionNumber = ST_Entry.SectionNumber + and then ST_Last.Value >= ST_Entry.Value + then + -- Symbol is a function past ST_Entry + + Result.Size := uint64 (ST_Last.Value - ST_Entry.Value); + + else + -- Not correlated function + + Result.Next := Sym_Off; + end if; + + exit; + + elsif ST_Last.SectionNumber = ST_Entry.SectionNumber + and then ST_Last.TypeField = Not_Function_Symbol_Type + and then ST_Last.StorageClass = 3 + and then ST_Last.NumberOfAuxSymbols = 1 + then + -- Symbol is a section + + Result.Size := uint64 (ST_Last.Value + Aux_Entry.Length + - ST_Entry.Value); + Result.Next := Noff; + exit; + end if; + + exit when Noff >= Obj.Symtab_Last; + end loop; + + -- Relocate the address + + Result.Value := + Result.Value + Get_Section_Virtual_Address + (Obj, uint32 (ST_Entry.SectionNumber - 1)); + + return Result; + end Read_Symbol; + + ------------------ + -- Read_Header -- + ------------------ + + function Read_Header (F : in out Mapped_Stream) return Header is + Hdr : Header; + Off : int32; + + begin + -- Skip the MSDOS stub, and seek directly to the file offset + + Seek (F, Signature_Loc_Offset); + Off := Read (F); + + -- Read the COFF file header + + Seek (F, Offset (Off)); + Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); + return Hdr; + end Read_Header; + + ------------------------- + -- Read_Section_Header -- + ------------------------- + + function Read_Section_Header + (Obj : in out PECOFF_Object_File; + Index : uint32) return Section_Header + is + Sec : Section_Header; + begin + Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU)); + Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU); + return Sec; + end Read_Section_Header; + + ---------- + -- Name -- + ---------- + + function Name + (Obj : in out PECOFF_Object_File; + Sec : Object_Section) return String + is + Shdr : constant Section_Header := Read_Section_Header (Obj, Sec.Num); + begin + return Decode_Name (Obj, Shdr.Name); + end Name; + + ------------------- + -- String_Table -- + ------------------- + + function String_Table + (Obj : in out PECOFF_Object_File; + Index : Offset) return String is + begin + -- An index of zero is used to represent an empty string, as the + -- first word of the string table is specified to contain the length + -- of the table rather than its contents. + + if Index = 0 then + return ""; + + else + return Offset_To_String (Obj.Symstr_Stream, Index); + end if; + end String_Table; + + ---------- + -- Name -- + ---------- + + function Name + (Obj : in out PECOFF_Object_File; + Sym : Object_Symbol) return String_Ptr_Len + is + ST_Entry : Symtab_Entry; + + begin + Seek (Obj.Symtab_Stream, Sym.Off); + Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, ST_Entry'Size / SSU); + + declare + -- Symbol table entries are packed and Table_Entry.Name may not be + -- sufficiently aligned to interpret as a 32 bit word, so it is + -- copied to a temporary + + Aligned_Name : Name_Str := ST_Entry.Name; + for Aligned_Name'Alignment use 4; + + First_Word : uint32; + pragma Import (Ada, First_Word); + -- Suppress initialization in Normalized_Scalars mode + for First_Word'Address use Aligned_Name (1)'Address; + + Second_Word : uint32; + pragma Import (Ada, Second_Word); + -- Suppress initialization in Normalized_Scalars mode + for Second_Word'Address use Aligned_Name (5)'Address; + + begin + if First_Word = 0 then + -- Second word is an offset in the symbol table + if Second_Word = 0 then + return (null, 0); + else + Seek (Obj.Symstr_Stream, int64 (Second_Word)); + return Read (Obj.Symstr_Stream); + end if; + else + -- Inlined symbol name + Seek (Obj.Symtab_Stream, Sym.Off); + return To_String_Ptr_Len (Read (Obj.Symtab_Stream), 8); + end if; + end; + end Name; + + end PECOFF_Ops; + + ----------------- + -- XCOFF32_Ops -- + ----------------- + + package body XCOFF32_Ops is + + function Read_Section_Header + (Obj : in out XCOFF32_Object_File; + Index : uint32) return Section_Header; + -- Read a header from section table + + ----------------- + -- Read_Symbol -- + ----------------- + + function Read_Symbol + (Obj : in out XCOFF32_Object_File; + Off : Offset) return Object_Symbol + is + Sym : Symbol_Entry; + Sz : constant Offset := Symbol_Entry'Size / SSU; + Aux : Aux_Entry; + Result : Object_Symbol; + Noff : Offset; + Sym_Off : Offset; + + procedure Read_LD_Symbol; + -- Read the next LD symbol + + -------------------- + -- Read_LD_Symbol -- + -------------------- + + procedure Read_LD_Symbol is + begin + loop + Sym_Off := Noff; + + Read_Raw (Obj.Symtab_Stream, Sym'Address, uint32 (Sz)); + + Noff := Noff + Offset (1 + Sym.n_numaux) * Sz; + + for J in 1 .. Sym.n_numaux loop + Read_Raw (Obj.Symtab_Stream, Aux'Address, uint32 (Sz)); + end loop; + + exit when Noff >= Obj.Symtab_Last; + + exit when Sym.n_numaux = 1 + and then Sym.n_scnum /= 0 + and then (Sym.n_sclass = C_EXT + or else Sym.n_sclass = C_HIDEXT + or else Sym.n_sclass = C_WEAKEXT) + and then Aux.x_smtyp = XTY_LD; + end loop; + end Read_LD_Symbol; + + -- Start of processing for Read_Symbol + + begin + Seek (Obj.Symtab_Stream, Off); + Noff := Off; + Read_LD_Symbol; + + if Noff >= Obj.Symtab_Last then + return Null_Symbol; + end if; + + -- Construct the symbol + + Result := (Off => Sym_Off, + Next => Noff, + Value => uint64 (Sym.n_value), + Size => 0); + + -- Look for the next symbol to compute the size + + Read_LD_Symbol; + + if Noff >= Obj.Symtab_Last then + return Null_Symbol; + end if; + + Result.Size := uint64 (Sym.n_value) - Result.Value; + Result.Next := Sym_Off; + return Result; + end Read_Symbol; + + ------------------ + -- First_Symbol -- + ------------------ + + function First_Symbol + (Obj : in out XCOFF32_Object_File) return Object_Symbol + is + begin + -- Return Null_Symbol in the case that the symbol table is empty + + if Obj.Symtab_Last = 0 then + return Null_Symbol; + end if; + + return Read_Symbol (Obj, 0); + end First_Symbol; + + ---------------- + -- Initialize -- + ---------------- + + function Initialize + (F : Mapped_File; + Hdr : Header; + In_Exception : Boolean) return XCOFF32_Object_File + is + Res : XCOFF32_Object_File (Format => XCOFF32); + Strtab_Sz : uint32; + begin + Res.Mf := F; + Res.In_Exception := In_Exception; + + Res.Arch := PPC; + + -- Map sections table + Res.Num_Sections := uint32 (Hdr.f_nscns); + Res.Sectab_Stream := Create_Stream + (F, + File_Size (Header'Size / SSU) + File_Size (Hdr.f_opthdr), + File_Size (Hdr.f_nscns) * (Section_Header'Size / SSU)); + + -- Map symbols table + Res.Symtab_Last := Offset (Hdr.f_nscns) * (Symbol_Entry'Size / SSU); + Res.Symtab_Stream := Create_Stream + (F, + File_Size (Hdr.f_symptr), + File_Size (Res.Symtab_Last) + 4); + + -- Map string table + Seek (Res.Symtab_Stream, Res.Symtab_Last); + Strtab_Sz := Read (Res.Symtab_Stream); + Res.Symstr_Stream := Create_Stream + (F, + File_Size (Res.Symtab_Last) + 4, + File_Size (Strtab_Sz) - 4); + + return Res; + end Initialize; + + ----------------- + -- Get_Section -- + ----------------- + + function Get_Section + (Obj : in out XCOFF32_Object_File; + Index : uint32) return Object_Section + is + Sec : constant Section_Header := Read_Section_Header (Obj, Index); + begin + return (Index, Offset (Sec.s_scnptr), + uint64 (Sec.s_vaddr), + uint64 (Sec.s_size), + (Sec.s_flags and STYP_TEXT) /= 0); + end Get_Section; + + ----------------- + -- Read_Header -- + ----------------- + + function Read_Header (F : in out Mapped_Stream) return Header is + Hdr : Header; + begin + Seek (F, 0); + Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); + return Hdr; + end Read_Header; + + ------------------------- + -- Read_Section_Header -- + ------------------------- + + function Read_Section_Header + (Obj : in out XCOFF32_Object_File; + Index : uint32) return Section_Header + is + Sec : Section_Header; + + begin + -- Seek to the end of the object header + + Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU)); + + -- Read the section + + Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU); + + return Sec; + end Read_Section_Header; + + ---------- + -- Name -- + ---------- + + function Name + (Obj : in out XCOFF32_Object_File; + Sec : Object_Section) return String + is + Hdr : Section_Header; + begin + Hdr := Read_Section_Header (Obj, Sec.Num); + return Trim_Trailing_Nuls (Hdr.s_name); + end Name; + + ---------- + -- Name -- + ---------- + + function Name + (Obj : in out XCOFF32_Object_File; + Sym : Object_Symbol) return String_Ptr_Len + is + Symbol : Symbol_Entry; + + begin + Seek (Obj.Symtab_Stream, Sym.Off); + Read_Raw (Obj.Symtab_Stream, Symbol'Address, Symbol'Size / SSU); + + declare + First_Word : uint32; + pragma Import (Ada, First_Word); + -- Suppress initialization in Normalized_Scalars mode + for First_Word'Address use Symbol.n_name (1)'Address; + + Second_Word : uint32; + pragma Import (Ada, Second_Word); + -- Suppress initialization in Normalized_Scalars mode + for Second_Word'Address use Symbol.n_name (5)'Address; + + begin + if First_Word = 0 then + if Second_Word = 0 then + return (null, 0); + else + Seek (Obj.Symstr_Stream, int64 (Second_Word)); + return Read (Obj.Symstr_Stream); + end if; + else + Seek (Obj.Symtab_Stream, Sym.Off); + return To_String_Ptr_Len (Read (Obj.Symstr_Stream), 8); + end if; + end; + end Name; + end XCOFF32_Ops; + + ---------- + -- Arch -- + ---------- + + function Arch (Obj : Object_File) return Object_Arch is + begin + return Obj.Arch; + end Arch; + + function Create_Stream + (Mf : Mapped_File; + File_Offset : File_Size; + File_Length : File_Size) + return Mapped_Stream + is + Region : Mapped_Region; + begin + Read (Mf, Region, File_Offset, File_Length, False); + return (Region, 0, Offset (File_Length)); + end Create_Stream; + + function Create_Stream + (Obj : Object_File; + Sec : Object_Section) return Mapped_Stream is + begin + return Create_Stream (Obj.Mf, File_Size (Sec.Off), File_Size (Sec.Size)); + end Create_Stream; + + procedure Tell (Obj : in out Mapped_Stream; Off : out Offset) is + begin + Off := Obj.Off; + end Tell; + + function Tell (Obj : Mapped_Stream) return Offset is + begin + return Obj.Off; + end Tell; + + function Length (Obj : Mapped_Stream) return Offset is + begin + return Obj.Len; + end Length; + + ----------- + -- Close -- + ----------- + + procedure Close (S : in out Mapped_Stream) is + begin + Free (S.Region); + end Close; + + procedure Close (Obj : in out Object_File) is + begin + Close (Obj.Symtab_Stream); + Close (Obj.Symstr_Stream); + Close (Obj.Sectab_Stream); + + case Obj.Format is + when ELF => + Close (Obj.Secstr_Stream); + when Any_PECOFF => + null; + when XCOFF32 => + null; + end case; + + Close (Obj.Mf); + end Close; + + ------------------------ + -- Strip_Leading_Char -- + ------------------------ + + function Strip_Leading_Char + (Obj : in out Object_File; + Sym : String_Ptr_Len) return Positive is + begin + if (Obj.Format = PECOFF and then Sym.Ptr (1) = '_') + or else + (Obj.Format = XCOFF32 and then Sym.Ptr (1) = '.') + then + return 2; + else + return 1; + end if; + end Strip_Leading_Char; + + ---------------------- + -- Decoded_Ada_Name -- + ---------------------- + + function Decoded_Ada_Name + (Obj : in out Object_File; + Sym : String_Ptr_Len) return String + is + procedure gnat_decode + (Coded_Name_Addr : Address; + Ada_Name_Addr : Address; + Verbose : int); + pragma Import (C, gnat_decode, "__gnat_decode"); + + subtype size_t is Interfaces.C.size_t; + + Sym_Name : constant String := + String (Sym.Ptr (1 .. Sym.Len)) & ASCII.NUL; + Decoded : char_array (0 .. size_t (Sym.Len) * 2 + 60); + Off : Natural; + begin + -- In the PECOFF case most but not all symbol table entries have an + -- extra leading underscore. In this case we trim it. + + Off := Strip_Leading_Char (Obj, Sym); + + gnat_decode (Sym_Name (Off)'Address, Decoded'Address, 0); + + return To_Ada (Decoded); + end Decoded_Ada_Name; + + ------------------ + -- First_Symbol -- + ------------------ + + function First_Symbol (Obj : in out Object_File) return Object_Symbol is + begin + case Obj.Format is + when ELF32 => return ELF32_Ops.First_Symbol (Obj); + when ELF64 => return ELF64_Ops.First_Symbol (Obj); + when Any_PECOFF => return PECOFF_Ops.First_Symbol (Obj); + when XCOFF32 => return XCOFF32_Ops.First_Symbol (Obj); + end case; + end First_Symbol; + + ------------ + -- Format -- + ------------ + + function Format (Obj : Object_File) return Object_Format is + begin + return Obj.Format; + end Format; + + ---------------------- + -- Get_Load_Address -- + ---------------------- + + function Get_Load_Address (Obj : Object_File) return uint64 is + begin + raise Format_Error with "Get_Load_Address not implemented"; + return 0; + end Get_Load_Address; + + ----------------- + -- Get_Section -- + ----------------- + + function Get_Section + (Obj : in out Object_File; + Shnum : uint32) return Object_Section is + begin + case Obj.Format is + when ELF32 => return ELF32_Ops.Get_Section (Obj, Shnum); + when ELF64 => return ELF64_Ops.Get_Section (Obj, Shnum); + when Any_PECOFF => return PECOFF_Ops.Get_Section (Obj, Shnum); + when XCOFF32 => return XCOFF32_Ops.Get_Section (Obj, Shnum); + end case; + end Get_Section; + + function Get_Section + (Obj : in out Object_File; + Sec_Name : String) return Object_Section + is + Sec : Object_Section; + + begin + for J in 0 .. Obj.Num_Sections - 1 loop + Sec := Get_Section (Obj, J); + + if Name (Obj, Sec) = Sec_Name then + return Sec; + end if; + end loop; + + if Obj.In_Exception then + return Null_Section; + else + raise Format_Error with "could not find section in object file"; + end if; + end Get_Section; + + ----------------------- + -- Get_Memory_Bounds -- + ----------------------- + + procedure Get_Memory_Bounds + (Obj : in out Object_File; + Low, High : out uint64) is + Sec : Object_Section; + begin + -- First set as an empty range + Low := uint64'Last; + High := uint64'First; + + for Idx in 1 .. Num_Sections (Obj) loop + Sec := Get_Section (Obj, Idx - 1); + if Sec.Flag_Alloc then + if Sec.Addr < Low then + Low := Sec.Addr; + end if; + if Sec.Addr + Sec.Size > High then + High := Sec.Addr + Sec.Size; + end if; + end if; + end loop; + end Get_Memory_Bounds; + + ---------- + -- Name -- + ---------- + + function Name + (Obj : in out Object_File; + Sec : Object_Section) return String is + begin + case Obj.Format is + when ELF32 => return ELF32_Ops.Name (Obj, Sec); + when ELF64 => return ELF64_Ops.Name (Obj, Sec); + when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sec); + when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sec); + end case; + end Name; + + function Name + (Obj : in out Object_File; + Sym : Object_Symbol) return String_Ptr_Len is + begin + case Obj.Format is + when ELF32 => return ELF32_Ops.Name (Obj, Sym); + when ELF64 => return ELF64_Ops.Name (Obj, Sym); + when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sym); + when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sym); + end case; + end Name; + + ----------------- + -- Next_Symbol -- + ----------------- + + function Next_Symbol + (Obj : in out Object_File; + Prev : Object_Symbol) return Object_Symbol is + begin + -- Test whether we've reached the end of the symbol table + + if Prev.Next >= Obj.Symtab_Last then + return Null_Symbol; + end if; + + return Read_Symbol (Obj, Prev.Next); + end Next_Symbol; + + --------- + -- Num -- + --------- + + function Num (Sec : Object_Section) return uint32 is + begin + return Sec.Num; + end Num; + + ------------------ + -- Num_Sections -- + ------------------ + + function Num_Sections (Obj : Object_File) return uint32 is + begin + return Obj.Num_Sections; + end Num_Sections; + + --------- + -- Off -- + --------- + + function Off (Sec : Object_Section) return Offset is + begin + return Sec.Off; + end Off; + + function Off (Sym : Object_Symbol) return Offset is + begin + return Sym.Off; + end Off; + + ---------------------- + -- Offset_To_String -- + ---------------------- + + function Offset_To_String + (S : in out Mapped_Stream; + Off : Offset) return String + is + Buf : Buffer; + begin + Seek (S, Off); + Read_C_String (S, Buf); + return To_String (Buf); + end Offset_To_String; + + ---------- + -- Open -- + ---------- + + function Open + (File_Name : String; + In_Exception : Boolean := False) return Object_File_Access + is + F : Mapped_File; + Hdr_Stream : Mapped_Stream; + + begin + -- Open the file + + F := Open_Read_No_Exception (File_Name); + + if F = Invalid_Mapped_File then + if In_Exception then + return null; + else + raise IO_Error with "could not open object file"; + end if; + end if; + + Hdr_Stream := Create_Stream (F, 0, 4096); + + declare + Hdr : constant ELF32_Ops.Header := ELF32_Ops.Read_Header (Hdr_Stream); + + begin + -- Look for the magic numbers for the ELF case + + if Hdr.E_Ident (0) = 16#7F# and then + Hdr.E_Ident (1) = Character'Pos ('E') and then + Hdr.E_Ident (2) = Character'Pos ('L') and then + Hdr.E_Ident (3) = Character'Pos ('F') and then + Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS32 + then + Close (Hdr_Stream); + return new Object_File' + (ELF32_Ops.Initialize (F, Hdr, In_Exception)); + end if; + end; + + declare + Hdr : constant ELF64_Ops.Header := + ELF64_Ops.Read_Header (Hdr_Stream); + + begin + -- Look for the magic numbers for the ELF case + + if Hdr.E_Ident (0) = 16#7F# and then + Hdr.E_Ident (1) = Character'Pos ('E') and then + Hdr.E_Ident (2) = Character'Pos ('L') and then + Hdr.E_Ident (3) = Character'Pos ('F') and then + Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS64 + then + Close (Hdr_Stream); + return new Object_File' + (ELF64_Ops.Initialize (F, Hdr, In_Exception)); + end if; + end; + + declare + Hdr : constant PECOFF_Ops.Header := + PECOFF_Ops.Read_Header (Hdr_Stream); + + begin + -- Test the magic numbers + + if Hdr.Magics (0) = Character'Pos ('P') and then + Hdr.Magics (1) = Character'Pos ('E') and then + Hdr.Magics (2) = 0 and then + Hdr.Magics (3) = 0 + then + Close (Hdr_Stream); + return new Object_File' + (PECOFF_Ops.Initialize (F, Hdr, In_Exception)); + end if; + + exception + -- If this is not a PECOFF file then we've done a seek and read to a + -- random address, possibly raising IO_Error + + when IO_Error => + null; + end; + + declare + Hdr : constant XCOFF32_Ops.Header := + XCOFF32_Ops.Read_Header (Hdr_Stream); + + begin + -- Test the magic numbers + + if Hdr.f_magic = 8#0737# then + Close (Hdr_Stream); + return new Object_File' + (XCOFF32_Ops.Initialize (F, Hdr, In_Exception)); + end if; + end; + + Close (Hdr_Stream); + + if In_Exception then + return null; + else + raise Format_Error with "unrecognized object format"; + end if; + end Open; + + ---------- + -- Read -- + ---------- + + function Read (S : in out Mapped_Stream) return Mmap.Str_Access + is + function To_Str_Access is + new Ada.Unchecked_Conversion (Address, Str_Access); + begin + return To_Str_Access (Data (S.Region) (Natural (S.Off + 1))'Address); + end Read; + + function Read (S : in out Mapped_Stream) return String_Ptr_Len is + begin + return To_String_Ptr_Len (Read (S)); + end Read; + + procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32) is + begin + if S.Off + Offset (Size) > Offset (Last (S.Region)) then + raise IO_Error with "could not read from object file"; + end if; + end Check_Read_Offset; + + procedure Read_Raw + (S : in out Mapped_Stream; + Addr : Address; + Size : uint32) + is + function To_Str_Access is + new Ada.Unchecked_Conversion (Address, Str_Access); + + Sz : constant Offset := Offset (Size); + begin + -- Check size + + pragma Debug (Check_Read_Offset (S, Size)); + + -- Copy data + + To_Str_Access (Addr) (1 .. Positive (Sz)) := + Data (S.Region) (Positive (S.Off + 1) .. Positive (S.Off + Sz)); + + -- Update offset + + S.Off := S.Off + Sz; + end Read_Raw; + + function Read (S : in out Mapped_Stream) return uint8 is + Data : uint8; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + function Read (S : in out Mapped_Stream) return uint16 is + Data : uint16; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + function Read (S : in out Mapped_Stream) return uint32 is + Data : uint32; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + function Read (S : in out Mapped_Stream) return uint64 is + Data : uint64; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + function Read (S : in out Mapped_Stream) return int8 is + Data : int8; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + function Read (S : in out Mapped_Stream) return int16 is + Data : int16; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + function Read (S : in out Mapped_Stream) return int32 is + Data : int32; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + function Read (S : in out Mapped_Stream) return int64 is + Data : int64; + begin + Read_Raw (S, Data'Address, Data'Size / SSU); + return Data; + end Read; + + ------------------ + -- Read_Address -- + ------------------ + + function Read_Address + (Obj : Object_File; S : in out Mapped_Stream) return uint64 is + Address_32 : uint32; + Address_64 : uint64; + + begin + case Obj.Arch is + when i386 + | MIPS + | PPC + | SPARC + => + Address_32 := Read (S); + return uint64 (Address_32); + + when IA64 + | PPC64 + | SPARC64 + | x86_64 + => + Address_64 := Read (S); + return Address_64; + + when Unknown => + raise Format_Error with "unrecognized machine architecture"; + end case; + end Read_Address; + + ------------------- + -- Read_C_String -- + ------------------- + + procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer) is + J : Integer := 0; + + begin + loop + -- Handle overflow case + + if J = B'Last then + B (J) := 0; + exit; + end if; + + B (J) := Read (S); + exit when B (J) = 0; + J := J + 1; + end loop; + end Read_C_String; + + ------------------- + -- Read_C_String -- + ------------------- + + function Read_C_String (S : in out Mapped_Stream) return Str_Access is + Res : constant Str_Access := Read (S); + + begin + for J in Res'Range loop + if S.Off + Offset (J - 1) > Offset (Last (S.Region)) then + raise IO_Error with "could not read from object file"; + end if; + + if Res (J) = ASCII.NUL then + S.Off := S.Off + Offset (J); + return Res; + end if; + end loop; + + -- Overflow case + raise Constraint_Error; + end Read_C_String; + + ----------------- + -- Read_LEB128 -- + ----------------- + + function Read_LEB128 (S : in out Mapped_Stream) return uint32 is + B : uint8; + Shift : Integer := 0; + Res : uint32 := 0; + + begin + loop + B := Read (S); + Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift); + exit when (B and 16#80#) = 0; + Shift := Shift + 7; + end loop; + + return Res; + end Read_LEB128; + + function Read_LEB128 (S : in out Mapped_Stream) return int32 is + B : uint8; + Shift : Integer := 0; + Res : uint32 := 0; + + begin + loop + B := Read (S); + Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift); + Shift := Shift + 7; + exit when (B and 16#80#) = 0; + end loop; + + if Shift < 32 and then (Res and Shift_Left (1, Shift - 1)) /= 0 then + Res := Res or Shift_Left (-1, Shift); + end if; + + return To_int32 (Res); + end Read_LEB128; + + ----------------- + -- Read_Symbol -- + ----------------- + + function Read_Symbol + (Obj : in out Object_File; + Off : Offset) return Object_Symbol is + begin + case Obj.Format is + when ELF32 => return ELF32_Ops.Read_Symbol (Obj, Off); + when ELF64 => return ELF64_Ops.Read_Symbol (Obj, Off); + when Any_PECOFF => return PECOFF_Ops.Read_Symbol (Obj, Off); + when XCOFF32 => return XCOFF32_Ops.Read_Symbol (Obj, Off); + end case; + end Read_Symbol; + + ---------- + -- Seek -- + ---------- + + procedure Seek (S : in out Mapped_Stream; Off : Offset) is + begin + if Off < 0 or else Off > Offset (Last (S.Region)) then + raise IO_Error with "could not seek to offset in object file"; + end if; + + S.Off := Off; + end Seek; + + ---------- + -- Size -- + ---------- + + function Size (Sec : Object_Section) return uint64 is + begin + return Sec.Size; + end Size; + + function Size (Sym : Object_Symbol) return uint64 is + begin + return Sym.Size; + end Size; + + ------------ + -- Strlen -- + ------------ + + function Strlen (Buf : Buffer) return int32 is + begin + return int32 (CRTL.strlen (Buf'Address)); + end Strlen; + + ----------- + -- Spans -- + ----------- + + function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean is + begin + return Addr >= Sym.Value and then Addr < Sym.Value + Sym.Size; + end Spans; + + --------------- + -- To_String -- + --------------- + + function To_String (Buf : Buffer) return String is + Result : String (1 .. Integer (CRTL.strlen (Buf'Address))); + for Result'Address use Buf'Address; + pragma Import (Ada, Result); + + begin + return Result; + end To_String; + + ----------------------- + -- To_String_Ptr_Len -- + ----------------------- + + function To_String_Ptr_Len + (Ptr : Mmap.Str_Access; + Max_Len : Natural := Natural'Last) return String_Ptr_Len is + begin + for I in 1 .. Max_Len loop + if Ptr (I) = ASCII.NUL then + return (Ptr, I - 1); + end if; + end loop; + return (Ptr, Max_Len); + end To_String_Ptr_Len; + + ------------------------ + -- Trim_Trailing_Nuls -- + ------------------------ + + function Trim_Trailing_Nuls (Str : String) return String is + begin + for J in Str'Range loop + if Str (J) = ASCII.NUL then + return Str (Str'First .. J - 1); + end if; + end loop; + + return Str; + end Trim_Trailing_Nuls; + + ----------- + -- Value -- + ----------- + + function Value (Sym : Object_Symbol) return uint64 is + begin + return Sym.Value; + end Value; + +end System.Object_Reader; diff --git a/gcc/ada/libgnat/s-objrea.ads b/gcc/ada/libgnat/s-objrea.ads new file mode 100644 index 0000000..1d48536 --- /dev/null +++ b/gcc/ada/libgnat/s-objrea.ads @@ -0,0 +1,451 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O B J E C T _ R E A D E R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements a simple, minimal overhead reader for object files +-- composed of sections of untyped heterogeneous binary data. + +with Interfaces; +with System.Mmap; + +package System.Object_Reader is + + -------------- + -- Limits -- + -------------- + + BUFFER_SIZE : constant := 8 * 1024; + + ------------------ + -- Object files -- + ------------------ + + type Object_File (<>) is private; + + type Object_File_Access is access Object_File; + + --------------------- + -- Object sections -- + ---------------------- + + type Object_Section is private; + + Null_Section : constant Object_Section; + + -------------------- + -- Object symbols -- + -------------------- + + type Object_Symbol is private; + + ------------------------ + -- Object format type -- + ------------------------ + + type Object_Format is + (ELF32, + -- Object format is 32-bit ELF + + ELF64, + -- Object format is 64-bit ELF + + PECOFF, + -- Object format is Microsoft PECOFF + + PECOFF_PLUS, + -- Object format is Microsoft PECOFF+ + + XCOFF32); + -- Object format is AIX 32-bit XCOFF + + -- PECOFF | PECOFF_PLUS appears so often as a case choice, would + -- seem a good idea to have a subtype name covering these two choices ??? + + ------------------------------ + -- Object architecture type -- + ------------------------------ + + type Object_Arch is + (Unknown, + -- The target architecture has not yet been determined + + SPARC, + -- 32-bit SPARC + + SPARC64, + -- 64-bit SPARC + + i386, + -- Intel IA32 + + MIPS, + -- MIPS Technologies MIPS + + x86_64, + -- x86-64 (64-bit AMD/Intel) + + IA64, + -- Intel IA64 + + PPC, + -- 32-bit PowerPC + + PPC64); + -- 64-bit PowerPC + + ------------------ + -- Target types -- + ------------------ + + subtype Offset is Interfaces.Integer_64; + + subtype uint8 is Interfaces.Unsigned_8; + subtype uint16 is Interfaces.Unsigned_16; + subtype uint32 is Interfaces.Unsigned_32; + subtype uint64 is Interfaces.Unsigned_64; + + subtype int8 is Interfaces.Integer_8; + subtype int16 is Interfaces.Integer_16; + subtype int32 is Interfaces.Integer_32; + subtype int64 is Interfaces.Integer_64; + + type Buffer is array (0 .. BUFFER_SIZE - 1) of uint8; + + type String_Ptr_Len is record + Ptr : Mmap.Str_Access; + Len : Natural; + end record; + -- A string made from a pointer and a length. Not all strings for name + -- are C strings: COFF inlined symbol names have a max length of 8. + + ------------------------------------------- + -- Operations on buffers of untyped data -- + ------------------------------------------- + + function To_String (Buf : Buffer) return String; + -- Construct string from C style null-terminated string stored in a buffer + + function To_String_Ptr_Len + (Ptr : Mmap.Str_Access; + Max_Len : Natural := Natural'Last) return String_Ptr_Len; + -- Convert PTR to a String_Ptr_Len. + + function Strlen (Buf : Buffer) return int32; + -- Return the length of a C style null-terminated string + + ------------------------- + -- Opening and closing -- + ------------------------- + + function Open + (File_Name : String; + In_Exception : Boolean := False) return Object_File_Access; + -- Open the object file and initialize the reader. In_Exception is true + -- when the parsing is done as part of an exception handler decorator. In + -- this mode we do not want to raise an exception. + + procedure Close (Obj : in out Object_File); + -- Close the object file + + ----------------------- + -- Sequential access -- + ----------------------- + + type Mapped_Stream is private; + -- Provide an abstraction of a stream on a memory mapped file + + function Create_Stream (Mf : System.Mmap.Mapped_File; + File_Offset : System.Mmap.File_Size; + File_Length : System.Mmap.File_Size) + return Mapped_Stream; + -- Create a stream from Mf + + procedure Close (S : in out Mapped_Stream); + -- Close the stream (deallocate memory) + + procedure Read_Raw + (S : in out Mapped_Stream; + Addr : Address; + Size : uint32); + pragma Inline (Read_Raw); + -- Read a number of fixed sized records + + procedure Seek (S : in out Mapped_Stream; Off : Offset); + -- Seek to an absolute offset in bytes + + procedure Tell (Obj : in out Mapped_Stream; Off : out Offset) + with Inline; + function Tell (Obj : Mapped_Stream) return Offset + with Inline; + -- Fetch the current offset + + function Length (Obj : Mapped_Stream) return Offset + with Inline; + -- Length of the stream + + function Read (S : in out Mapped_Stream) return Mmap.Str_Access; + -- Provide a pointer in memory at the current offset + + function Read (S : in out Mapped_Stream) return String_Ptr_Len; + -- Provide a pointer in memory at the current offset + + function Read (S : in out Mapped_Stream) return uint8; + function Read (S : in out Mapped_Stream) return uint16; + function Read (S : in out Mapped_Stream) return uint32; + function Read (S : in out Mapped_Stream) return uint64; + function Read (S : in out Mapped_Stream) return int8; + function Read (S : in out Mapped_Stream) return int16; + function Read (S : in out Mapped_Stream) return int32; + function Read (S : in out Mapped_Stream) return int64; + -- Read a scalar + + function Read_Address + (Obj : Object_File; S : in out Mapped_Stream) return uint64; + -- Read either a 64 or 32 bit address from the file stream depending on the + -- address size of the target architecture and promote it to a 64 bit type. + + function Read_LEB128 (S : in out Mapped_Stream) return uint32; + function Read_LEB128 (S : in out Mapped_Stream) return int32; + -- Read a value encoding in Little-Endian Base 128 format + + procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer); + function Read_C_String (S : in out Mapped_Stream) return Mmap.Str_Access; + -- Read a C style NULL terminated string + + function Offset_To_String + (S : in out Mapped_Stream; + Off : Offset) return String; + -- Construct a string from a C style NULL terminated string located at an + -- offset into the object file. + + ------------------------ + -- Object information -- + ------------------------ + + function Arch (Obj : Object_File) return Object_Arch; + -- Return the object architecture + + function Format (Obj : Object_File) return Object_Format; + -- Return the object file format + + function Get_Load_Address (Obj : Object_File) return uint64; + -- Return the load address defined in Obj. May raise Format_Error if not + -- implemented + + function Num_Sections (Obj : Object_File) return uint32; + -- Return the number of sections composing the object file + + function Get_Section + (Obj : in out Object_File; + Shnum : uint32) return Object_Section; + -- Return the Nth section (numbered from zero) + + function Get_Section + (Obj : in out Object_File; + Sec_Name : String) return Object_Section; + -- Return a section by name + + function Create_Stream + (Obj : Object_File; + Sec : Object_Section) return Mapped_Stream; + -- Create a stream for section Sec + + procedure Get_Memory_Bounds + (Obj : in out Object_File; + Low, High : out uint64); + -- Return the low and high addresses of the code for the object file. Can + -- be used to check if an address in within this object file. This + -- procedure is not efficient and the result should be saved to avoid + -- recomputation. + + ------------------------- + -- Section information -- + ------------------------- + + function Name + (Obj : in out Object_File; + Sec : Object_Section) return String; + -- Return the name of a section as a string + + function Size (Sec : Object_Section) return uint64; + -- Return the size of a section in bytes + + function Num (Sec : Object_Section) return uint32; + -- Return the index of a section from zero + + function Off (Sec : Object_Section) return Offset; + -- Return the byte offset of the section within the object + + ------------------------------ + -- Symbol table information -- + ------------------------------ + + Null_Symbol : constant Object_Symbol; + -- An empty symbol table entry. + + function First_Symbol (Obj : in out Object_File) return Object_Symbol; + -- Return the first element in the symbol table or Null_Symbol if the + -- symbol table is empty. + + function Next_Symbol + (Obj : in out Object_File; + Prev : Object_Symbol) return Object_Symbol; + -- Return the element following Prev in the symbol table, or Null_Symbol if + -- Prev is the last symbol in the table. + + function Read_Symbol + (Obj : in out Object_File; + Off : Offset) return Object_Symbol; + -- Read symbol at Off + + function Name + (Obj : in out Object_File; + Sym : Object_Symbol) return String_Ptr_Len; + -- Return the name of the symbol + + function Decoded_Ada_Name + (Obj : in out Object_File; + Sym : String_Ptr_Len) return String; + -- Return the decoded name of a symbol encoded as per exp_dbug.ads + + function Strip_Leading_Char + (Obj : in out Object_File; + Sym : String_Ptr_Len) return Positive; + -- Return the index of the first character to decode the name. This can + -- strip one character for ABI with a prefix (like x86 for PECOFF). + + function Value (Sym : Object_Symbol) return uint64; + -- Return the name of the symbol + + function Size (Sym : Object_Symbol) return uint64; + -- Return the size of the symbol in bytes + + function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean; + -- Determine whether a particular address corresponds to the range + -- referenced by this symbol. + + function Off (Sym : Object_Symbol) return Offset; + -- Return the offset of the symbol. + + ---------------- + -- Exceptions -- + ---------------- + + IO_Error : exception; + -- Input/Output error reading file + + Format_Error : exception; + -- Encountered a problem parsing the object + +private + type Mapped_Stream is record + Region : System.Mmap.Mapped_Region; + Off : Offset; + Len : Offset; + end record; + + subtype ELF is Object_Format range ELF32 .. ELF64; + subtype Any_PECOFF is Object_Format range PECOFF .. PECOFF_PLUS; + + type Object_File (Format : Object_Format) is record + Mf : System.Mmap.Mapped_File := + System.Mmap.Invalid_Mapped_File; + Arch : Object_Arch := Unknown; + + Num_Sections : uint32 := 0; + -- Number of sections + + Symtab_Last : Offset; -- Last offset of symbol table + + In_Exception : Boolean := False; + -- True if the parsing is done as part of an exception handler + + Sectab_Stream : Mapped_Stream; + -- Section table + + Symtab_Stream : Mapped_Stream; + -- Symbol table + + Symstr_Stream : Mapped_Stream; + -- Symbol strings + + case Format is + when ELF => + Secstr_Stream : Mapped_Stream; + -- Section strings + when Any_PECOFF => + ImageBase : uint64; -- ImageBase value from header + + -- Cache for latest result of Get_Section_Virtual_Address + + GSVA_Sec : uint32 := uint32'Last; + GSVA_Addr : uint64; + when XCOFF32 => + null; + end case; + end record; + + subtype ELF_Object_File is Object_File; -- with + -- Predicate => ELF_Object_File.Format in ELF; + subtype PECOFF_Object_File is Object_File; -- with + -- Predicate => PECOFF_Object_File.Format in Any_PECOFF; + subtype XCOFF32_Object_File is Object_File; -- with + -- Predicate => XCOFF32_Object_File.Format in XCOFF32; + -- ???Above predicates cause the compiler to crash when instantiating + -- ELF64_Ops (see package body). + + type Object_Section is record + Num : uint32 := 0; + -- Section index in the section table + + Off : Offset := 0; + -- First byte of the section in the object file + + Addr : uint64 := 0; + -- Load address of the section. Valid only when Flag_Alloc is true. + + Size : uint64 := 0; + -- Length of the section in bytes + + Flag_Alloc : Boolean := False; + -- True if the section is mapped in memory by the OS loader + end record; + + Null_Section : constant Object_Section := (0, 0, 0, 0, False); + + type Object_Symbol is record + Off : Offset := 0; -- Offset of underlying symbol on disk + Next : Offset := 0; -- Offset of the following symbol + Value : uint64 := 0; -- Value associated with this symbol + Size : uint64 := 0; -- Size of the referenced entity + end record; + + Null_Symbol : constant Object_Symbol := (0, 0, 0, 0); +end System.Object_Reader; diff --git a/gcc/ada/libgnat/s-os_lib.adb b/gcc/ada/libgnat/s-os_lib.adb new file mode 100644 index 0000000..da357e7 --- /dev/null +++ b/gcc/ada/libgnat/s-os_lib.adb @@ -0,0 +1,3083 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O S _ L I B -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; +with System; use System; +with System.Case_Util; +with System.CRTL; +with System.Soft_Links; + +package body System.OS_Lib is + + subtype size_t is CRTL.size_t; + + procedure Strncpy (dest, src : System.Address; n : size_t) + renames CRTL.strncpy; + + -- Imported procedures Dup and Dup2 are used in procedures Spawn and + -- Non_Blocking_Spawn. + + function Dup (Fd : File_Descriptor) return File_Descriptor; + pragma Import (C, Dup, "__gnat_dup"); + + procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); + pragma Import (C, Dup2, "__gnat_dup2"); + + function Copy_Attributes + (From : System.Address; + To : System.Address; + Mode : Integer) return Integer; + pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); + -- Mode = 0 - copy only time stamps. + -- Mode = 1 - copy time stamps and read/write/execute attributes + -- Mode = 2 - copy read/write/execute attributes + + On_Windows : constant Boolean := Directory_Separator = '\'; + -- An indication that we are on Windows. Used in Normalize_Pathname, to + -- deal with drive letters in the beginning of absolute paths. + + package SSL renames System.Soft_Links; + + -- The following are used by Create_Temp_File + + First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP"; + -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit + + Current_Temp_File_Name : String := First_Temp_File_Name; + -- Name of the temp file last created + + Temp_File_Name_Last_Digit : constant Positive := + First_Temp_File_Name'Last - 4; + -- Position of the last digit in Current_Temp_File_Name + + Max_Attempts : constant := 100; + -- The maximum number of attempts to create a new temp file + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Args_Length (Args : Argument_List) return Natural; + -- Returns total number of characters needed to create a string of all Args + -- terminated by ASCII.NUL characters. + + procedure Create_Temp_File_Internal + (FD : out File_Descriptor; + Name : out String_Access; + Stdout : Boolean); + -- Internal routine to implement two Create_Temp_File routines. If Stdout + -- is set to True the created descriptor is stdout-compatible, otherwise + -- it might not be depending on the OS. The first two parameters are as + -- in Create_Temp_File. + + function C_String_Length (S : Address) return Integer; + -- Returns the length of C (null-terminated) string at S, or 0 for + -- Null_Address. + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean); + -- Internal routine to implement the two Spawn (blocking/non blocking) + -- routines. If Blocking is set to True then the spawn is blocking + -- otherwise it is non blocking. In this latter case the Pid contains the + -- process id number. The first three parameters are as in Spawn. Note that + -- Spawn_Internal normalizes the argument list before calling the low level + -- system spawn routines (see Normalize_Arguments). + -- + -- Note: Normalize_Arguments is designed to do nothing if it is called more + -- than once, so calling Normalize_Arguments before calling one of the + -- spawn routines is fine. + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) return String_Access; + -- Converts a C String to an Ada String. We could do this making use of + -- Interfaces.C.Strings but we prefer not to import that entire package + + --------- + -- "<" -- + --------- + + function "<" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) < Long_Integer (Y); + end "<"; + + ---------- + -- "<=" -- + ---------- + + function "<=" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) <= Long_Integer (Y); + end "<="; + + --------- + -- ">" -- + --------- + + function ">" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) > Long_Integer (Y); + end ">"; + + ---------- + -- ">=" -- + ---------- + + function ">=" (X, Y : OS_Time) return Boolean is + begin + return Long_Integer (X) >= Long_Integer (Y); + end ">="; + + ----------------- + -- Args_Length -- + ----------------- + + function Args_Length (Args : Argument_List) return Natural is + Len : Natural := 0; + + begin + for J in Args'Range loop + Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL + end loop; + + return Len; + end Args_Length; + + ----------------------------- + -- Argument_String_To_List -- + ----------------------------- + + function Argument_String_To_List + (Arg_String : String) return Argument_List_Access + is + Max_Args : constant Integer := Arg_String'Length; + New_Argv : Argument_List (1 .. Max_Args); + Idx : Integer; + New_Argc : Natural := 0; + + Cleaned : String (1 .. Arg_String'Length); + Cleaned_Idx : Natural; + -- A cleaned up version of the argument. This function is taking + -- backslash escapes when computing the bounds for arguments. It is + -- then removing the extra backslashes from the argument. + + Backslash_Is_Sep : constant Boolean := Directory_Separator = '\'; + -- Whether '\' is a directory separator (as on Windows), or a way to + -- quote special characters. + + begin + Idx := Arg_String'First; + + loop + exit when Idx > Arg_String'Last; + + declare + Backqd : Boolean := False; + Quoted : Boolean := False; + + begin + Cleaned_Idx := Cleaned'First; + + loop + -- An unquoted space is the end of an argument + + if not (Backqd or Quoted) + and then Arg_String (Idx) = ' ' + then + exit; + + -- Start of a quoted string + + elsif not (Backqd or Quoted) + and then Arg_String (Idx) = '"' + then + Quoted := True; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + + -- End of a quoted string and end of an argument + + elsif (Quoted and not Backqd) + and then Arg_String (Idx) = '"' + then + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + Idx := Idx + 1; + exit; + + -- Turn off backquoting after advancing one character + + elsif Backqd then + Backqd := False; + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + + -- Following character is backquoted + + elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then + Backqd := True; + + else + Cleaned (Cleaned_Idx) := Arg_String (Idx); + Cleaned_Idx := Cleaned_Idx + 1; + end if; + + Idx := Idx + 1; + exit when Idx > Arg_String'Last; + end loop; + + -- Found an argument + + New_Argc := New_Argc + 1; + New_Argv (New_Argc) := + new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1)); + + -- Skip extraneous spaces + + while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop + Idx := Idx + 1; + end loop; + end; + end loop; + + return new Argument_List'(New_Argv (1 .. New_Argc)); + end Argument_String_To_List; + + --------------------- + -- C_String_Length -- + --------------------- + + function C_String_Length (S : Address) return Integer is + begin + if S = Null_Address then + return 0; + else + return Integer (CRTL.strlen (S)); + end if; + end C_String_Length; + + ----------- + -- Close -- + ----------- + + procedure Close (FD : File_Descriptor) is + use CRTL; + Discard : constant int := close (int (FD)); + begin + null; + end Close; + + procedure Close (FD : File_Descriptor; Status : out Boolean) is + use CRTL; + begin + Status := (close (int (FD)) = 0); + end Close; + + --------------- + -- Copy_File -- + --------------- + + procedure Copy_File + (Name : String; + Pathname : String; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps) + is + From : File_Descriptor; + To : File_Descriptor; + + Copy_Error : exception; + -- Internal exception raised to signal error in copy + + function Build_Path (Dir : String; File : String) return String; + -- Returns pathname Dir concatenated with File adding the directory + -- separator only if needed. + + procedure Copy (From : File_Descriptor; To : File_Descriptor); + -- Read data from From and place them into To. In both cases the + -- operations uses the current file position. Raises Constraint_Error + -- if a problem occurs during the copy. + + procedure Copy_To (To_Name : String); + -- Does a straight copy from source to designated destination file + + ---------------- + -- Build_Path -- + ---------------- + + function Build_Path (Dir : String; File : String) return String is + function Is_Dirsep (C : Character) return Boolean; + pragma Inline (Is_Dirsep); + -- Returns True if C is a directory separator. On Windows we + -- handle both styles of directory separator. + + --------------- + -- Is_Dirsep -- + --------------- + + function Is_Dirsep (C : Character) return Boolean is + begin + return C = Directory_Separator or else C = '/'; + end Is_Dirsep; + + -- Local variables + + Base_File_Ptr : Integer; + -- The base file name is File (Base_File_Ptr + 1 .. File'Last) + + Res : String (1 .. Dir'Length + File'Length + 1); + + -- Start of processing for Build_Path + + begin + -- Find base file name + + Base_File_Ptr := File'Last; + while Base_File_Ptr >= File'First loop + exit when Is_Dirsep (File (Base_File_Ptr)); + Base_File_Ptr := Base_File_Ptr - 1; + end loop; + + declare + Base_File : String renames + File (Base_File_Ptr + 1 .. File'Last); + + begin + Res (1 .. Dir'Length) := Dir; + + if Is_Dirsep (Dir (Dir'Last)) then + Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) := + Base_File; + return Res (1 .. Dir'Length + Base_File'Length); + + else + Res (Dir'Length + 1) := Directory_Separator; + Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) := + Base_File; + return Res (1 .. Dir'Length + 1 + Base_File'Length); + end if; + end; + end Build_Path; + + ---------- + -- Copy -- + ---------- + + procedure Copy (From : File_Descriptor; To : File_Descriptor) is + Buf_Size : constant := 200_000; + type Buf is array (1 .. Buf_Size) of Character; + type Buf_Ptr is access Buf; + + Buffer : Buf_Ptr; + R : Integer; + W : Integer; + + Status_From : Boolean; + Status_To : Boolean; + -- Statuses for the calls to Close + + procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr); + + begin + -- Check for invalid descriptors, making sure that we do not + -- accidentally leave an open file descriptor around. + + if From = Invalid_FD then + if To /= Invalid_FD then + Close (To, Status_To); + end if; + + raise Copy_Error; + + elsif To = Invalid_FD then + Close (From, Status_From); + raise Copy_Error; + end if; + + -- Allocate the buffer on the heap + + Buffer := new Buf; + + loop + R := Read (From, Buffer (1)'Address, Buf_Size); + + -- On some systems, the buffer may not be full. So, we need to try + -- again until there is nothing to read. + + exit when R = 0; + + W := Write (To, Buffer (1)'Address, R); + + if W < R then + + -- Problem writing data, could be a disk full. Close files + -- without worrying about status, since we are raising a + -- Copy_Error exception in any case. + + Close (From, Status_From); + Close (To, Status_To); + + Free (Buffer); + + raise Copy_Error; + end if; + end loop; + + Close (From, Status_From); + Close (To, Status_To); + + Free (Buffer); + + if not (Status_From and Status_To) then + raise Copy_Error; + end if; + end Copy; + + ------------- + -- Copy_To -- + ------------- + + procedure Copy_To (To_Name : String) is + C_From : String (1 .. Name'Length + 1); + C_To : String (1 .. To_Name'Length + 1); + + begin + From := Open_Read (Name, Binary); + + -- Do not clobber destination file if source file could not be opened + + if From /= Invalid_FD then + To := Create_File (To_Name, Binary); + end if; + + Copy (From, To); + + -- Copy attributes + + C_From (1 .. Name'Length) := Name; + C_From (C_From'Last) := ASCII.NUL; + + C_To (1 .. To_Name'Length) := To_Name; + C_To (C_To'Last) := ASCII.NUL; + + case Preserve is + when Time_Stamps => + if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then + raise Copy_Error; + end if; + + when Full => + if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then + raise Copy_Error; + end if; + + when None => + null; + end case; + end Copy_To; + + -- Start of processing for Copy_File + + begin + Success := True; + + -- The source file must exist + + if not Is_Regular_File (Name) then + raise Copy_Error; + end if; + + -- The source file exists + + case Mode is + + -- Copy case, target file must not exist + + when Copy => + + -- If the target file exists, we have an error + + if Is_Regular_File (Pathname) then + raise Copy_Error; + + -- Case of target is a directory + + elsif Is_Directory (Pathname) then + declare + Dest : constant String := Build_Path (Pathname, Name); + + begin + -- If target file exists, we have an error, else do copy + + if Is_Regular_File (Dest) then + raise Copy_Error; + else + Copy_To (Dest); + end if; + end; + + -- Case of normal copy to file (destination does not exist) + + else + Copy_To (Pathname); + end if; + + -- Overwrite case (destination file may or may not exist) + + when Overwrite => + if Is_Directory (Pathname) then + Copy_To (Build_Path (Pathname, Name)); + else + Copy_To (Pathname); + end if; + + -- Append case (destination file may or may not exist) + + when Append => + + -- Appending to existing file + + if Is_Regular_File (Pathname) then + + -- Append mode and destination file exists, append data at the + -- end of Pathname. But if we fail to open source file, do not + -- touch destination file at all. + + From := Open_Read (Name, Binary); + if From /= Invalid_FD then + To := Open_Read_Write (Pathname, Binary); + end if; + + Lseek (To, 0, Seek_End); + + Copy (From, To); + + -- Appending to directory, not allowed + + elsif Is_Directory (Pathname) then + raise Copy_Error; + + -- Appending when target file does not exist + + else + Copy_To (Pathname); + end if; + end case; + + -- All error cases are caught here + + exception + when Copy_Error => + Success := False; + end Copy_File; + + procedure Copy_File + (Name : C_File_Name; + Pathname : C_File_Name; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps) + is + Ada_Name : String_Access := + To_Path_String_Access + (Name, C_String_Length (Name)); + Ada_Pathname : String_Access := + To_Path_String_Access + (Pathname, C_String_Length (Pathname)); + + begin + Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); + Free (Ada_Name); + Free (Ada_Pathname); + end Copy_File; + + -------------------------- + -- Copy_File_Attributes -- + -------------------------- + + procedure Copy_File_Attributes + (From : String; + To : String; + Success : out Boolean; + Copy_Timestamp : Boolean := True; + Copy_Permissions : Boolean := True) + is + F : aliased String (1 .. From'Length + 1); + T : aliased String (1 .. To'Length + 1); + + Mode : Integer; + + begin + if Copy_Timestamp then + if Copy_Permissions then + Mode := 1; + else + Mode := 0; + end if; + else + if Copy_Permissions then + Mode := 2; + else + Success := True; + return; -- nothing to do + end if; + end if; + + F (1 .. From'Length) := From; + F (F'Last) := ASCII.NUL; + + T (1 .. To'Length) := To; + T (T'Last) := ASCII.NUL; + + Success := Copy_Attributes (F'Address, T'Address, Mode) /= -1; + end Copy_File_Attributes; + + ---------------------- + -- Copy_Time_Stamps -- + ---------------------- + + procedure Copy_Time_Stamps + (Source : String; + Dest : String; + Success : out Boolean) + is + begin + if Is_Regular_File (Source) and then Is_Writable_File (Dest) then + declare + C_Source : String (1 .. Source'Length + 1); + C_Dest : String (1 .. Dest'Length + 1); + + begin + C_Source (1 .. Source'Length) := Source; + C_Source (C_Source'Last) := ASCII.NUL; + + C_Dest (1 .. Dest'Length) := Dest; + C_Dest (C_Dest'Last) := ASCII.NUL; + + if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then + Success := False; + else + Success := True; + end if; + end; + + else + Success := False; + end if; + end Copy_Time_Stamps; + + procedure Copy_Time_Stamps + (Source : C_File_Name; + Dest : C_File_Name; + Success : out Boolean) + is + Ada_Source : String_Access := + To_Path_String_Access + (Source, C_String_Length (Source)); + Ada_Dest : String_Access := + To_Path_String_Access + (Dest, C_String_Length (Dest)); + + begin + Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); + Free (Ada_Source); + Free (Ada_Dest); + end Copy_Time_Stamps; + + ----------------- + -- Create_File -- + ----------------- + + function Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_open_create"); + begin + return C_Create_File (Name, Fmode); + end Create_File; + + function Create_File + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_File (C_Name (C_Name'First)'Address, Fmode); + end Create_File; + + --------------------- + -- Create_New_File -- + --------------------- + + function Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Create_New_File, "__gnat_open_new"); + begin + return C_Create_New_File (Name, Fmode); + end Create_New_File; + + function Create_New_File + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Create_New_File (C_Name (C_Name'First)'Address, Fmode); + end Create_New_File; + + ----------------------------- + -- Create_Output_Text_File -- + ----------------------------- + + function Create_Output_Text_File (Name : String) return File_Descriptor is + function C_Create_File (Name : C_File_Name) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_create_output_file"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_Create_File (C_Name (C_Name'First)'Address); + end Create_Output_Text_File; + + ---------------------- + -- Create_Temp_File -- + ---------------------- + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Temp_File_Name) + is + function Open_New_Temp + (Name : System.Address; + Fmode : Mode) return File_Descriptor; + pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); + + begin + FD := Open_New_Temp (Name'Address, Binary); + end Create_Temp_File; + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out String_Access) + is + begin + Create_Temp_File_Internal (FD, Name, Stdout => False); + end Create_Temp_File; + + ----------------------------- + -- Create_Temp_Output_File -- + ----------------------------- + + procedure Create_Temp_Output_File + (FD : out File_Descriptor; + Name : out String_Access) + is + begin + Create_Temp_File_Internal (FD, Name, Stdout => True); + end Create_Temp_Output_File; + + ------------------------------- + -- Create_Temp_File_Internal -- + ------------------------------- + + procedure Create_Temp_File_Internal + (FD : out File_Descriptor; + Name : out String_Access; + Stdout : Boolean) + is + Pos : Positive; + Attempts : Natural := 0; + Current : String (Current_Temp_File_Name'Range); + + function Create_New_Output_Text_File + (Name : String) return File_Descriptor; + -- Similar to Create_Output_Text_File, except it fails if the file + -- already exists. We need this behavior to ensure we don't accidentally + -- open a temp file that has just been created by a concurrently running + -- process. There is no point exposing this function, as it's generally + -- not particularly useful. + + --------------------------------- + -- Create_New_Output_Text_File -- + --------------------------------- + + function Create_New_Output_Text_File + (Name : String) return File_Descriptor + is + function C_Create_File (Name : C_File_Name) return File_Descriptor; + pragma Import (C, C_Create_File, "__gnat_create_output_file_new"); + + C_Name : String (1 .. Name'Length + 1); + + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return C_Create_File (C_Name (C_Name'First)'Address); + end Create_New_Output_Text_File; + + -- Start of processing for Create_Temp_File_Internal + + begin + -- Loop until a new temp file can be created + + File_Loop : loop + Locked : begin + + -- We need to protect global variable Current_Temp_File_Name + -- against concurrent access by different tasks. + + SSL.Lock_Task.all; + + -- Start at the last digit + + Pos := Temp_File_Name_Last_Digit; + + Digit_Loop : + loop + -- Increment the digit by one + + case Current_Temp_File_Name (Pos) is + when '0' .. '8' => + Current_Temp_File_Name (Pos) := + Character'Succ (Current_Temp_File_Name (Pos)); + exit Digit_Loop; + + when '9' => + + -- For 9, set the digit to 0 and go to the previous digit + + Current_Temp_File_Name (Pos) := '0'; + Pos := Pos - 1; + + when others => + + -- If it is not a digit, then there are no available + -- temp file names. Return Invalid_FD. There is almost no + -- chance that this code will be ever be executed, since + -- it would mean that there are one million temp files in + -- the same directory. + + SSL.Unlock_Task.all; + FD := Invalid_FD; + Name := null; + exit File_Loop; + end case; + end loop Digit_Loop; + + Current := Current_Temp_File_Name; + + -- We can now release the lock, because we are no longer accessing + -- Current_Temp_File_Name. + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked; + + -- Attempt to create the file + + if Stdout then + FD := Create_New_Output_Text_File (Current); + else + FD := Create_New_File (Current, Binary); + end if; + + if FD /= Invalid_FD then + Name := new String'(Current); + exit File_Loop; + end if; + + if not Is_Regular_File (Current) then + + -- If the file does not already exist and we are unable to create + -- it, we give up after Max_Attempts. Otherwise, we try again with + -- the next available file name. + + Attempts := Attempts + 1; + + if Attempts >= Max_Attempts then + FD := Invalid_FD; + Name := null; + exit File_Loop; + end if; + end if; + end loop File_Loop; + end Create_Temp_File_Internal; + + ------------------------- + -- Current_Time_String -- + ------------------------- + + function Current_Time_String return String is + subtype S23 is String (1 .. 23); + -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL + + procedure Current_Time_String (Time : System.Address); + pragma Import (C, Current_Time_String, "__gnat_current_time_string"); + -- Puts current time into Time in above ISO 8601 format + + Result23 : aliased S23; + -- Current time in ISO 8601 format + + begin + Current_Time_String (Result23'Address); + return Result23 (1 .. 19); + end Current_Time_String; + + ----------------- + -- Delete_File -- + ----------------- + + procedure Delete_File (Name : Address; Success : out Boolean) is + R : Integer; + begin + R := System.CRTL.unlink (Name); + Success := (R = 0); + end Delete_File; + + procedure Delete_File (Name : String; Success : out Boolean) is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + Delete_File (C_Name'Address, Success); + end Delete_File; + + ------------------- + -- Errno_Message -- + ------------------- + + function Errno_Message + (Err : Integer := Errno; + Default : String := "") return String + is + function strerror (errnum : Integer) return System.Address; + pragma Import (C, strerror, "strerror"); + + C_Msg : constant System.Address := strerror (Err); + + begin + if C_Msg = Null_Address then + if Default /= "" then + return Default; + + else + -- Note: for bootstrap reasons, it is impractical + -- to use Integer'Image here. + + declare + Val : Integer; + First : Integer; + + Buf : String (1 .. 20); + -- Buffer large enough to hold image of largest Integer values + + begin + Val := abs Err; + First := Buf'Last; + loop + Buf (First) := + Character'Val (Character'Pos ('0') + Val mod 10); + Val := Val / 10; + exit when Val = 0; + First := First - 1; + end loop; + + if Err < 0 then + First := First - 1; + Buf (First) := '-'; + end if; + + return "errno = " & Buf (First .. Buf'Last); + end; + end if; + + else + declare + Msg : String (1 .. Integer (CRTL.strlen (C_Msg))); + for Msg'Address use C_Msg; + pragma Import (Ada, Msg); + begin + return Msg; + end; + end if; + end Errno_Message; + + --------------------- + -- File_Time_Stamp -- + --------------------- + + function File_Time_Stamp (FD : File_Descriptor) return OS_Time is + function File_Time (FD : File_Descriptor) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_fd"); + begin + return File_Time (FD); + end File_Time_Stamp; + + function File_Time_Stamp (Name : C_File_Name) return OS_Time is + function File_Time (Name : Address) return OS_Time; + pragma Import (C, File_Time, "__gnat_file_time_name"); + begin + return File_Time (Name); + end File_Time_Stamp; + + function File_Time_Stamp (Name : String) return OS_Time is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return File_Time_Stamp (F_Name'Address); + end File_Time_Stamp; + + --------------------------- + -- Get_Debuggable_Suffix -- + --------------------------- + + function Get_Debuggable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); + + Result : String_Access; + Suffix_Length : Integer; + Suffix_Ptr : Address; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length)); + end if; + + return Result; + end Get_Debuggable_Suffix; + + --------------------------- + -- Get_Executable_Suffix -- + --------------------------- + + function Get_Executable_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); + + Result : String_Access; + Suffix_Length : Integer; + Suffix_Ptr : Address; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length)); + end if; + + return Result; + end Get_Executable_Suffix; + + ----------------------- + -- Get_Object_Suffix -- + ----------------------- + + function Get_Object_Suffix return String_Access is + procedure Get_Suffix_Ptr (Length, Ptr : Address); + pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); + + Result : String_Access; + Suffix_Length : Integer; + Suffix_Ptr : Address; + + begin + Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length)); + end if; + + return Result; + end Get_Object_Suffix; + + ---------------------------------- + -- Get_Target_Debuggable_Suffix -- + ---------------------------------- + + function Get_Target_Debuggable_Suffix return String_Access is + Target_Exec_Ext_Ptr : Address; + pragma Import + (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension"); + + Result : String_Access; + Suffix_Length : Integer; + + begin + Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr)); + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy + (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length)); + end if; + + return Result; + end Get_Target_Debuggable_Suffix; + + ---------------------------------- + -- Get_Target_Executable_Suffix -- + ---------------------------------- + + function Get_Target_Executable_Suffix return String_Access is + Target_Exec_Ext_Ptr : Address; + pragma Import + (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension"); + + Result : String_Access; + Suffix_Length : Integer; + + begin + Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr)); + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy + (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length)); + end if; + + return Result; + end Get_Target_Executable_Suffix; + + ------------------------------ + -- Get_Target_Object_Suffix -- + ------------------------------ + + function Get_Target_Object_Suffix return String_Access is + Target_Object_Ext_Ptr : Address; + pragma Import + (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension"); + + Result : String_Access; + Suffix_Length : Integer; + + begin + Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr)); + Result := new String (1 .. Suffix_Length); + + if Suffix_Length > 0 then + Strncpy + (Result.all'Address, Target_Object_Ext_Ptr, size_t (Suffix_Length)); + end if; + + return Result; + end Get_Target_Object_Suffix; + + ------------ + -- Getenv -- + ------------ + + function Getenv (Name : String) return String_Access is + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + Env_Value_Ptr : aliased Address; + Env_Value_Length : aliased Integer; + F_Name : aliased String (1 .. Name'Length + 1); + Result : String_Access; + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + Get_Env_Value_Ptr + (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + Result := new String (1 .. Env_Value_Length); + + if Env_Value_Length > 0 then + Strncpy + (Result.all'Address, Env_Value_Ptr, size_t (Env_Value_Length)); + end if; + + return Result; + end Getenv; + + ------------ + -- GM_Day -- + ------------ + + function GM_Day (Date : OS_Time) return Day_Type is + D : Day_Type; + + Y : Year_Type; + Mo : Month_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Unreferenced (Y, Mo, H, Mn, S); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return D; + end GM_Day; + + ------------- + -- GM_Hour -- + ------------- + + function GM_Hour (Date : OS_Time) return Hour_Type is + H : Hour_Type; + + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Unreferenced (Y, Mo, D, Mn, S); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return H; + end GM_Hour; + + --------------- + -- GM_Minute -- + --------------- + + function GM_Minute (Date : OS_Time) return Minute_Type is + Mn : Minute_Type; + + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + S : Second_Type; + pragma Unreferenced (Y, Mo, D, H, S); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mn; + end GM_Minute; + + -------------- + -- GM_Month -- + -------------- + + function GM_Month (Date : OS_Time) return Month_Type is + Mo : Month_Type; + + Y : Year_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Unreferenced (Y, D, H, Mn, S); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Mo; + end GM_Month; + + --------------- + -- GM_Second -- + --------------- + + function GM_Second (Date : OS_Time) return Second_Type is + S : Second_Type; + + Y : Year_Type; + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + pragma Unreferenced (Y, Mo, D, H, Mn); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return S; + end GM_Second; + + -------------- + -- GM_Split -- + -------------- + + procedure GM_Split + (Date : OS_Time; + Year : out Year_Type; + Month : out Month_Type; + Day : out Day_Type; + Hour : out Hour_Type; + Minute : out Minute_Type; + Second : out Second_Type) + is + procedure To_GM_Time + (P_Time_T : Address; + P_Year : Address; + P_Month : Address; + P_Day : Address; + P_Hours : Address; + P_Mins : Address; + P_Secs : Address); + pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); + + T : OS_Time := Date; + Y : Integer; + Mo : Integer; + D : Integer; + H : Integer; + Mn : Integer; + S : Integer; + + begin + -- Use the global lock because To_GM_Time is not thread safe + + Locked_Processing : begin + SSL.Lock_Task.all; + To_GM_Time + (P_Time_T => T'Address, + P_Year => Y'Address, + P_Month => Mo'Address, + P_Day => D'Address, + P_Hours => H'Address, + P_Mins => Mn'Address, + P_Secs => S'Address); + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Locked_Processing; + + Year := Y + 1900; + Month := Mo + 1; + Day := D; + Hour := H; + Minute := Mn; + Second := S; + end GM_Split; + + ---------------- + -- GM_Time_Of -- + ---------------- + + function GM_Time_Of + (Year : Year_Type; + Month : Month_Type; + Day : Day_Type; + Hour : Hour_Type; + Minute : Minute_Type; + Second : Second_Type) return OS_Time + is + procedure To_OS_Time + (P_Time_T : Address; + P_Year : Integer; + P_Month : Integer; + P_Day : Integer; + P_Hours : Integer; + P_Mins : Integer; + P_Secs : Integer); + pragma Import (C, To_OS_Time, "__gnat_to_os_time"); + + Result : OS_Time; + + begin + To_OS_Time + (P_Time_T => Result'Address, + P_Year => Year - 1900, + P_Month => Month - 1, + P_Day => Day, + P_Hours => Hour, + P_Mins => Minute, + P_Secs => Second); + return Result; + end GM_Time_Of; + + ------------- + -- GM_Year -- + ------------- + + function GM_Year (Date : OS_Time) return Year_Type is + Y : Year_Type; + + Mo : Month_Type; + D : Day_Type; + H : Hour_Type; + Mn : Minute_Type; + S : Second_Type; + pragma Unreferenced (Mo, D, H, Mn, S); + + begin + GM_Split (Date, Y, Mo, D, H, Mn, S); + return Y; + end GM_Year; + + ---------------------- + -- Is_Absolute_Path -- + ---------------------- + + function Is_Absolute_Path (Name : String) return Boolean is + function Is_Absolute_Path + (Name : Address; + Length : Integer) return Integer; + pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); + begin + return Is_Absolute_Path (Name'Address, Name'Length) /= 0; + end Is_Absolute_Path; + + ------------------ + -- Is_Directory -- + ------------------ + + function Is_Directory (Name : C_File_Name) return Boolean is + function Is_Directory (Name : Address) return Integer; + pragma Import (C, Is_Directory, "__gnat_is_directory"); + begin + return Is_Directory (Name) /= 0; + end Is_Directory; + + function Is_Directory (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Directory (F_Name'Address); + end Is_Directory; + + ----------------------------- + -- Is_Read_Accessible_File -- + ----------------------------- + + function Is_Read_Accessible_File (Name : String) return Boolean is + function Is_Read_Accessible_File (Name : Address) return Integer; + pragma Import + (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file"); + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Read_Accessible_File (F_Name'Address) /= 0; + end Is_Read_Accessible_File; + + ---------------------------- + -- Is_Owner_Readable_File -- + ---------------------------- + + function Is_Owner_Readable_File (Name : C_File_Name) return Boolean is + function Is_Readable_File (Name : Address) return Integer; + pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); + begin + return Is_Readable_File (Name) /= 0; + end Is_Owner_Readable_File; + + function Is_Owner_Readable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Owner_Readable_File (F_Name'Address); + end Is_Owner_Readable_File; + + ------------------------ + -- Is_Executable_File -- + ------------------------ + + function Is_Executable_File (Name : C_File_Name) return Boolean is + function Is_Executable_File (Name : Address) return Integer; + pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); + begin + return Is_Executable_File (Name) /= 0; + end Is_Executable_File; + + function Is_Executable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Executable_File (F_Name'Address); + end Is_Executable_File; + + --------------------- + -- Is_Regular_File -- + --------------------- + + function Is_Regular_File (Name : C_File_Name) return Boolean is + function Is_Regular_File (Name : Address) return Integer; + pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); + begin + return Is_Regular_File (Name) /= 0; + end Is_Regular_File; + + function Is_Regular_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Regular_File (F_Name'Address); + end Is_Regular_File; + + ---------------------- + -- Is_Symbolic_Link -- + ---------------------- + + function Is_Symbolic_Link (Name : C_File_Name) return Boolean is + function Is_Symbolic_Link (Name : Address) return Integer; + pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link"); + begin + return Is_Symbolic_Link (Name) /= 0; + end Is_Symbolic_Link; + + function Is_Symbolic_Link (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Symbolic_Link (F_Name'Address); + end Is_Symbolic_Link; + + ------------------------------ + -- Is_Write_Accessible_File -- + ------------------------------ + + function Is_Write_Accessible_File (Name : String) return Boolean is + function Is_Write_Accessible_File (Name : Address) return Integer; + pragma Import + (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file"); + F_Name : String (1 .. Name'Length + 1); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Write_Accessible_File (F_Name'Address) /= 0; + end Is_Write_Accessible_File; + + ---------------------------- + -- Is_Owner_Writable_File -- + ---------------------------- + + function Is_Owner_Writable_File (Name : C_File_Name) return Boolean is + function Is_Writable_File (Name : Address) return Integer; + pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); + begin + return Is_Writable_File (Name) /= 0; + end Is_Owner_Writable_File; + + function Is_Owner_Writable_File (Name : String) return Boolean is + F_Name : String (1 .. Name'Length + 1); + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + return Is_Owner_Writable_File (F_Name'Address); + end Is_Owner_Writable_File; + + ---------- + -- Kill -- + ---------- + + procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True) is + SIGKILL : constant := 9; + SIGINT : constant := 2; + + procedure C_Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); + pragma Import (C, C_Kill, "__gnat_kill"); + + begin + if Hard_Kill then + C_Kill (Pid, SIGKILL, 1); + else + C_Kill (Pid, SIGINT, 1); + end if; + end Kill; + + ----------------------- + -- Kill_Process_Tree -- + ----------------------- + + procedure Kill_Process_Tree + (Pid : Process_Id; Hard_Kill : Boolean := True) + is + SIGKILL : constant := 9; + SIGINT : constant := 2; + + procedure C_Kill_PT (Pid : Process_Id; Sig_Num : Integer); + pragma Import (C, C_Kill_PT, "__gnat_killprocesstree"); + + begin + if Hard_Kill then + C_Kill_PT (Pid, SIGKILL); + else + C_Kill_PT (Pid, SIGINT); + end if; + end Kill_Process_Tree; + + ------------------------- + -- Locate_Exec_On_Path -- + ------------------------- + + function Locate_Exec_On_Path + (Exec_Name : String) return String_Access + is + function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; + pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); + + C_Exec_Name : String (1 .. Exec_Name'Length + 1); + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; + C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; + + Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + CRTL.free (Path_Addr); + + -- Always return an absolute path name + + if not Is_Absolute_Path (Result.all) then + declare + Absolute_Path : constant String := + Normalize_Pathname (Result.all, Resolve_Links => False); + begin + Free (Result); + Result := new String'(Absolute_Path); + end; + end if; + + return Result; + end if; + end Locate_Exec_On_Path; + + ------------------------- + -- Locate_Regular_File -- + ------------------------- + + function Locate_Regular_File + (File_Name : C_File_Name; + Path : C_File_Name) return String_Access + is + function Locate_Regular_File + (C_File_Name, Path_Val : Address) return Address; + pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); + + Path_Addr : Address; + Path_Len : Integer; + Result : String_Access; + + begin + Path_Addr := Locate_Regular_File (File_Name, Path); + Path_Len := C_String_Length (Path_Addr); + + if Path_Len = 0 then + return null; + + else + Result := To_Path_String_Access (Path_Addr, Path_Len); + CRTL.free (Path_Addr); + return Result; + end if; + end Locate_Regular_File; + + function Locate_Regular_File + (File_Name : String; + Path : String) return String_Access + is + C_File_Name : String (1 .. File_Name'Length + 1); + C_Path : String (1 .. Path'Length + 1); + Result : String_Access; + + begin + C_File_Name (1 .. File_Name'Length) := File_Name; + C_File_Name (C_File_Name'Last) := ASCII.NUL; + + C_Path (1 .. Path'Length) := Path; + C_Path (C_Path'Last) := ASCII.NUL; + + Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address); + + -- Always return an absolute path name + + if Result /= null and then not Is_Absolute_Path (Result.all) then + declare + Absolute_Path : constant String := Normalize_Pathname (Result.all); + begin + Free (Result); + Result := new String'(Absolute_Path); + end; + end if; + + return Result; + end Locate_Regular_File; + + ------------------------ + -- Non_Blocking_Spawn -- + ------------------------ + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) return Process_Id + is + Junk : Integer; + pragma Warnings (Off, Junk); + Pid : Process_Id; + + begin + Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); + return Pid; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) return Process_Id + is + Pid : Process_Id; + Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning + Saved_Output : File_Descriptor; + + begin + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + end if; + + -- Set standard output and, if specified, error to the temporary file + + Saved_Output := Dup (Standout); + Dup2 (Output_File_Descriptor, Standout); + + if Err_To_Out then + Saved_Error := Dup (Standerr); + Dup2 (Output_File_Descriptor, Standerr); + end if; + + -- Spawn the program + + Pid := Non_Blocking_Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + + if Err_To_Out then + Dup2 (Saved_Error, Standerr); + end if; + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + + if Err_To_Out then + Close (Saved_Error); + end if; + + return Pid; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) return Process_Id + is + Output_File_Descriptor : constant File_Descriptor := + Create_Output_Text_File (Output_File); + Result : Process_Id; + + begin + -- Do not attempt to spawn if the output file could not be created + + if Output_File_Descriptor = Invalid_FD then + return Invalid_Pid; + + else + Result := + Non_Blocking_Spawn + (Program_Name, Args, Output_File_Descriptor, Err_To_Out); + + -- Close the file just created for the output, as the file descriptor + -- cannot be used anywhere, being a local value. It is safe to do + -- that, as the file descriptor has been duplicated to form + -- standard output and error of the spawned process. + + Close (Output_File_Descriptor); + + return Result; + end if; + end Non_Blocking_Spawn; + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Stdout_File : String; + Stderr_File : String) return Process_Id + is + Stderr_FD : constant File_Descriptor := + Create_Output_Text_File (Stderr_File); + Stdout_FD : constant File_Descriptor := + Create_Output_Text_File (Stdout_File); + + Result : Process_Id; + Saved_Error : File_Descriptor; + Saved_Output : File_Descriptor; + + Dummy_Status : Boolean; + + begin + -- Do not attempt to spawn if the output files could not be created + + if Stdout_FD = Invalid_FD or else Stderr_FD = Invalid_FD then + return Invalid_Pid; + end if; + + -- Set standard output and error to the specified files + + Saved_Output := Dup (Standout); + Dup2 (Stdout_FD, Standout); + + Saved_Error := Dup (Standerr); + Dup2 (Stderr_FD, Standerr); + + Set_Close_On_Exec (Saved_Output, True, Dummy_Status); + Set_Close_On_Exec (Saved_Error, True, Dummy_Status); + + -- Close the files just created for the output, as the file descriptors + -- cannot be used anywhere, being local values. It is safe to do that, + -- as the file descriptors have been duplicated to form standard output + -- and standard error of the spawned process. + + Close (Stdout_FD); + Close (Stderr_FD); + + -- Spawn the program + + Result := Non_Blocking_Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + Dup2 (Saved_Error, Standerr); + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + Close (Saved_Error); + + return Result; + end Non_Blocking_Spawn; + + ------------------------------- + -- Non_Blocking_Wait_Process -- + ------------------------------- + + procedure Non_Blocking_Wait_Process + (Pid : out Process_Id; Success : out Boolean) + is + Status : Integer; + + function Portable_No_Block_Wait (S : Address) return Process_Id; + pragma Import + (C, Portable_No_Block_Wait, "__gnat_portable_no_block_wait"); + + begin + Pid := Portable_No_Block_Wait (Status'Address); + Success := (Status = 0); + + if Pid = 0 then + Pid := Invalid_Pid; + end if; + end Non_Blocking_Wait_Process; + + ------------------------- + -- Normalize_Arguments -- + ------------------------- + + procedure Normalize_Arguments (Args : in out Argument_List) is + procedure Quote_Argument (Arg : in out String_Access); + -- Add quote around argument if it contains spaces (or HT characters) + + C_Argument_Needs_Quote : Integer; + pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote"); + Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0; + + -------------------- + -- Quote_Argument -- + -------------------- + + procedure Quote_Argument (Arg : in out String_Access) is + J : Positive := 1; + Quote_Needed : Boolean := False; + Res : String (1 .. Arg'Length * 2); + + begin + if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then + + -- Starting quote + + Res (J) := '"'; + + for K in Arg'Range loop + + J := J + 1; + + if Arg (K) = '"' then + Res (J) := '\'; + J := J + 1; + Res (J) := '"'; + Quote_Needed := True; + + elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then + Res (J) := Arg (K); + Quote_Needed := True; + + else + Res (J) := Arg (K); + end if; + end loop; + + if Quote_Needed then + + -- Case of null terminated string + + if Res (J) = ASCII.NUL then + + -- If the string ends with \, double it + + if Res (J - 1) = '\' then + Res (J) := '\'; + J := J + 1; + end if; + + -- Put a quote just before the null at the end + + Res (J) := '"'; + J := J + 1; + Res (J) := ASCII.NUL; + + -- If argument is terminated by '\', then double it. Otherwise + -- the ending quote will be taken as-is. This is quite strange + -- spawn behavior from Windows, but this is what we see. + + else + if Res (J) = '\' then + J := J + 1; + Res (J) := '\'; + end if; + + -- Ending quote + + J := J + 1; + Res (J) := '"'; + end if; + + declare + Old : String_Access := Arg; + + begin + Arg := new String'(Res (1 .. J)); + Free (Old); + end; + end if; + + end if; + end Quote_Argument; + + -- Start of processing for Normalize_Arguments + + begin + if Argument_Needs_Quote then + for K in Args'Range loop + if Args (K) /= null and then Args (K)'Length /= 0 then + Quote_Argument (Args (K)); + end if; + end loop; + end if; + end Normalize_Arguments; + + ------------------------ + -- Normalize_Pathname -- + ------------------------ + + function Normalize_Pathname + (Name : String; + Directory : String := ""; + Resolve_Links : Boolean := True; + Case_Sensitive : Boolean := True) return String + is + procedure Get_Current_Dir + (Dir : System.Address; + Length : System.Address); + pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); + + function Get_File_Names_Case_Sensitive return Integer; + pragma Import + (C, Get_File_Names_Case_Sensitive, + "__gnat_get_file_names_case_sensitive"); + + Max_Path : Integer; + pragma Import (C, Max_Path, "__gnat_max_path_len"); + -- Maximum length of a path name + + function Readlink + (Path : System.Address; + Buf : System.Address; + Bufsiz : size_t) return Integer; + pragma Import (C, Readlink, "__gnat_readlink"); + + function To_Canonical_File_Spec + (Host_File : System.Address) return System.Address; + pragma Import + (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); + -- Convert possible foreign file syntax to canonical form + + Fold_To_Lower_Case : constant Boolean := + not Case_Sensitive + and then Get_File_Names_Case_Sensitive = 0; + + function Final_Value (S : String) return String; + -- Make final adjustment to the returned string. This function strips + -- trailing directory separators, and folds returned string to lower + -- case if required. + + function Get_Directory (Dir : String) return String; + -- If Dir is not empty, return it, adding a directory separator + -- if not already present, otherwise return current working directory + -- with terminating directory separator. + + ----------------- + -- Final_Value -- + ----------------- + + function Final_Value (S : String) return String is + S1 : String := S; + -- We may need to fold S to lower case, so we need a variable + + Last : Natural; + + begin + if Fold_To_Lower_Case then + System.Case_Util.To_Lower (S1); + end if; + + -- Remove trailing directory separator, if any + + Last := S1'Last; + + if Last > 1 + and then (S1 (Last) = '/' + or else + S1 (Last) = Directory_Separator) + then + -- Special case for Windows: C:\ + + if Last = 3 + and then S1 (1) /= Directory_Separator + and then S1 (2) = ':' + then + null; + + else + Last := Last - 1; + end if; + end if; + + return S1 (1 .. Last); + end Final_Value; + + ------------------- + -- Get_Directory -- + ------------------- + + function Get_Directory (Dir : String) return String is + begin + -- Directory given, add directory separator if needed + + if Dir'Length > 0 then + declare + Result : String := + Normalize_Pathname + (Dir, "", Resolve_Links, Case_Sensitive) & + Directory_Separator; + Last : Positive := Result'Last - 1; + + begin + -- On Windows, change all '/' to '\' + + if On_Windows then + for J in Result'First .. Last - 1 loop + if Result (J) = '/' then + Result (J) := Directory_Separator; + end if; + end loop; + end if; + + -- Include additional directory separator, if needed + + if Result (Last) /= Directory_Separator then + Last := Last + 1; + end if; + + return Result (Result'First .. Last); + end; + + -- Directory name not given, get current directory + + else + declare + Buffer : String (1 .. Max_Path + 2); + Path_Len : Natural := Max_Path; + + begin + Get_Current_Dir (Buffer'Address, Path_Len'Address); + + if Path_Len = 0 then + raise Program_Error; + end if; + + if Buffer (Path_Len) /= Directory_Separator then + Path_Len := Path_Len + 1; + Buffer (Path_Len) := Directory_Separator; + end if; + + -- By default, the drive letter on Windows is in upper case + + if On_Windows + and then Path_Len >= 2 + and then Buffer (2) = ':' + then + System.Case_Util.To_Upper (Buffer (1 .. 1)); + end if; + + return Buffer (1 .. Path_Len); + end; + end if; + end Get_Directory; + + -- Local variables + + Max_Iterations : constant := 500; + + Canonical_File_Addr : System.Address; + Canonical_File_Len : Integer; + + End_Path : Natural := 0; + Finish : Positive; + Last : Positive; + Link_Buffer : String (1 .. Max_Path + 2); + Path_Buffer : String (1 .. Max_Path + Max_Path + 2); + Start : Natural; + Status : Integer; + The_Name : String (1 .. Name'Length + 1); + + -- Start of processing for Normalize_Pathname + + begin + -- Special case, return null if name is null, or if it is bigger than + -- the biggest name allowed. + + if Name'Length = 0 or else Name'Length > Max_Path then + return ""; + end if; + + -- First, convert possible foreign file spec to Unix file spec. If no + -- conversion is required, all this does is put Name at the beginning + -- of Path_Buffer unchanged. + + File_Name_Conversion : begin + The_Name (1 .. Name'Length) := Name; + The_Name (The_Name'Last) := ASCII.NUL; + + Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); + Canonical_File_Len := Integer (CRTL.strlen (Canonical_File_Addr)); + + -- If syntax conversion has failed, return an empty string to + -- indicate the failure. + + if Canonical_File_Len = 0 then + return ""; + end if; + + declare + subtype Path_String is String (1 .. Canonical_File_Len); + Canonical_File : Path_String; + for Canonical_File'Address use Canonical_File_Addr; + pragma Import (Ada, Canonical_File); + + begin + Path_Buffer (1 .. Canonical_File_Len) := Canonical_File; + End_Path := Canonical_File_Len; + Last := 1; + end; + end File_Name_Conversion; + + -- Replace all '/' by Directory Separators (this is for Windows) + + if Directory_Separator /= '/' then + for Index in 1 .. End_Path loop + if Path_Buffer (Index) = '/' then + Path_Buffer (Index) := Directory_Separator; + end if; + end loop; + end if; + + -- Resolve directory names for Windows + + if On_Windows then + + -- On Windows, if we have an absolute path starting with a directory + -- separator, we need to have the drive letter appended in front. + + -- On Windows, Get_Current_Dir will return a suitable directory name + -- (path starting with a drive letter on Windows). So we take this + -- drive letter and prepend it to the current path. + + if Path_Buffer (1) = Directory_Separator + and then Path_Buffer (2) /= Directory_Separator + then + declare + Cur_Dir : constant String := Get_Directory (""); + -- Get the current directory to get the drive letter + + begin + if Cur_Dir'Length > 2 + and then Cur_Dir (Cur_Dir'First + 1) = ':' + then + Path_Buffer (3 .. End_Path + 2) := + Path_Buffer (1 .. End_Path); + Path_Buffer (1 .. 2) := + Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); + End_Path := End_Path + 2; + end if; + end; + + -- We have a drive letter, ensure it is upper-case + + elsif Path_Buffer (1) in 'a' .. 'z' + and then Path_Buffer (2) = ':' + then + System.Case_Util.To_Upper (Path_Buffer (1 .. 1)); + end if; + end if; + + -- On Windows, remove all double-quotes that are possibly part of the + -- path but can cause problems with other methods. + + if On_Windows then + declare + Index : Natural; + + begin + Index := Path_Buffer'First; + for Current in Path_Buffer'First .. End_Path loop + if Path_Buffer (Current) /= '"' then + Path_Buffer (Index) := Path_Buffer (Current); + Index := Index + 1; + end if; + end loop; + + End_Path := Index - 1; + end; + end if; + + -- Start the conversions + + -- If this is not finished after Max_Iterations, give up and return an + -- empty string. + + for J in 1 .. Max_Iterations loop + + -- If we don't have an absolute pathname, prepend the directory + -- Reference_Dir. + + if Last = 1 + and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) + then + declare + Reference_Dir : constant String := Get_Directory (Directory); + Ref_Dir_Len : constant Natural := Reference_Dir'Length; + -- Current directory name specified and its length + + begin + Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) := + Path_Buffer (1 .. End_Path); + End_Path := Ref_Dir_Len + End_Path; + Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir; + Last := Ref_Dir_Len; + end; + end if; + + Start := Last + 1; + Finish := Last; + + -- Ensure that Windows network drives are kept, e.g: \\server\drive-c + + if Start = 2 + and then Directory_Separator = '\' + and then Path_Buffer (1 .. 2) = "\\" + then + Start := 3; + end if; + + -- If we have traversed the full pathname, return it + + if Start > End_Path then + return Final_Value (Path_Buffer (1 .. End_Path)); + end if; + + -- Remove duplicate directory separators + + while Path_Buffer (Start) = Directory_Separator loop + if Start = End_Path then + return Final_Value (Path_Buffer (1 .. End_Path - 1)); + + else + Path_Buffer (Start .. End_Path - 1) := + Path_Buffer (Start + 1 .. End_Path); + End_Path := End_Path - 1; + end if; + end loop; + + -- Find the end of the current field: last character or the one + -- preceding the next directory separator. + + while Finish < End_Path + and then Path_Buffer (Finish + 1) /= Directory_Separator + loop + Finish := Finish + 1; + end loop; + + -- Remove "." field + + if Start = Finish and then Path_Buffer (Start) = '.' then + if Start = End_Path then + if Last = 1 then + return (1 => Directory_Separator); + else + if Fold_To_Lower_Case then + System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); + end if; + + return Path_Buffer (1 .. Last - 1); + end if; + else + Path_Buffer (Last + 1 .. End_Path - 2) := + Path_Buffer (Last + 3 .. End_Path); + End_Path := End_Path - 2; + end if; + + -- Remove ".." fields + + elsif Finish = Start + 1 + and then Path_Buffer (Start .. Finish) = ".." + then + Start := Last; + loop + Start := Start - 1; + exit when Start < 1 + or else Path_Buffer (Start) = Directory_Separator; + end loop; + + if Start <= 1 then + if Finish = End_Path then + return (1 => Directory_Separator); + + else + Path_Buffer (1 .. End_Path - Finish) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish; + Last := 1; + end if; + + else + if Finish = End_Path then + return Final_Value (Path_Buffer (1 .. Start - 1)); + + else + Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := + Path_Buffer (Finish + 2 .. End_Path); + End_Path := Start + End_Path - Finish - 1; + Last := Start; + end if; + end if; + + -- Check if current field is a symbolic link + + elsif Resolve_Links then + declare + Saved : constant Character := Path_Buffer (Finish + 1); + + begin + Path_Buffer (Finish + 1) := ASCII.NUL; + Status := + Readlink + (Path => Path_Buffer'Address, + Buf => Link_Buffer'Address, + Bufsiz => Link_Buffer'Length); + Path_Buffer (Finish + 1) := Saved; + end; + + -- Not a symbolic link, move to the next field, if any + + if Status <= 0 then + Last := Finish + 1; + + -- Replace symbolic link with its value + + else + if Is_Absolute_Path (Link_Buffer (1 .. Status)) then + Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - (Finish - Status); + Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); + Last := 1; + + else + Path_Buffer + (Last + Status + 1 .. End_Path - Finish + Last + Status) := + Path_Buffer (Finish + 1 .. End_Path); + End_Path := End_Path - Finish + Last + Status; + Path_Buffer (Last + 1 .. Last + Status) := + Link_Buffer (1 .. Status); + end if; + end if; + + else + Last := Finish + 1; + end if; + end loop; + + -- Too many iterations: give up + + -- This can happen when there is a circularity in the symbolic links: A + -- is a symbolic link for B, which itself is a symbolic link, and the + -- target of B or of another symbolic link target of B is A. In this + -- case, we return an empty string to indicate failure to resolve. + + return ""; + end Normalize_Pathname; + + ----------------- + -- Open_Append -- + ----------------- + + function Open_Append + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Append + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Append, "__gnat_open_append"); + begin + return C_Open_Append (Name, Fmode); + end Open_Append; + + function Open_Append + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Append (C_Name (C_Name'First)'Address, Fmode); + end Open_Append; + + --------------- + -- Open_Read -- + --------------- + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Read, "__gnat_open_read"); + begin + return C_Open_Read (Name, Fmode); + end Open_Read; + + function Open_Read + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read (C_Name (C_Name'First)'Address, Fmode); + end Open_Read; + + --------------------- + -- Open_Read_Write -- + --------------------- + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor + is + function C_Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); + begin + return C_Open_Read_Write (Name, Fmode); + end Open_Read_Write; + + function Open_Read_Write + (Name : String; + Fmode : Mode) return File_Descriptor + is + C_Name : String (1 .. Name'Length + 1); + begin + C_Name (1 .. Name'Length) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); + end Open_Read_Write; + + ------------- + -- OS_Exit -- + ------------- + + procedure OS_Exit (Status : Integer) is + begin + OS_Exit_Ptr (Status); + raise Program_Error; + end OS_Exit; + + --------------------- + -- OS_Exit_Default -- + --------------------- + + procedure OS_Exit_Default (Status : Integer) is + procedure GNAT_OS_Exit (Status : Integer); + pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit"); + pragma No_Return (GNAT_OS_Exit); + begin + GNAT_OS_Exit (Status); + end OS_Exit_Default; + + -------------------- + -- Pid_To_Integer -- + -------------------- + + function Pid_To_Integer (Pid : Process_Id) return Integer is + begin + return Integer (Pid); + end Pid_To_Integer; + + ---------- + -- Read -- + ---------- + + function Read + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer + is + begin + return + Integer (System.CRTL.read + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); + end Read; + + ----------------- + -- Rename_File -- + ----------------- + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean) + is + function rename (From, To : Address) return Integer; + pragma Import (C, rename, "__gnat_rename"); + R : Integer; + + begin + R := rename (Old_Name, New_Name); + Success := (R = 0); + end Rename_File; + + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean) + is + C_Old_Name : String (1 .. Old_Name'Length + 1); + C_New_Name : String (1 .. New_Name'Length + 1); + + begin + C_Old_Name (1 .. Old_Name'Length) := Old_Name; + C_Old_Name (C_Old_Name'Last) := ASCII.NUL; + C_New_Name (1 .. New_Name'Length) := New_Name; + C_New_Name (C_New_Name'Last) := ASCII.NUL; + Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); + end Rename_File; + + ----------------------- + -- Set_Close_On_Exec -- + ----------------------- + + procedure Set_Close_On_Exec + (FD : File_Descriptor; + Close_On_Exec : Boolean; + Status : out Boolean) + is + function C_Set_Close_On_Exec + (FD : File_Descriptor; Close_On_Exec : System.CRTL.int) + return System.CRTL.int; + pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); + begin + Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0; + end Set_Close_On_Exec; + + -------------------- + -- Set_Executable -- + -------------------- + + procedure Set_Executable (Name : String; Mode : Positive := S_Owner) is + procedure C_Set_Executable (Name : C_File_Name; Mode : Integer); + pragma Import (C, C_Set_Executable, "__gnat_set_executable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Executable (C_Name (C_Name'First)'Address, Mode); + end Set_Executable; + + ------------------------------------- + -- Set_File_Last_Modify_Time_Stamp -- + ------------------------------------- + + procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time) is + procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time); + pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name"); + C_Name : aliased String (Name'First .. Name'Last + 1); + + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_File_Time (C_Name'Address, Time); + end Set_File_Last_Modify_Time_Stamp; + + ---------------------- + -- Set_Non_Readable -- + ---------------------- + + procedure Set_Non_Readable (Name : String) is + procedure C_Set_Non_Readable (Name : C_File_Name); + pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Non_Readable (C_Name (C_Name'First)'Address); + end Set_Non_Readable; + + ---------------------- + -- Set_Non_Writable -- + ---------------------- + + procedure Set_Non_Writable (Name : String) is + procedure C_Set_Non_Writable (Name : C_File_Name); + pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Non_Writable (C_Name (C_Name'First)'Address); + end Set_Non_Writable; + + ------------------ + -- Set_Readable -- + ------------------ + + procedure Set_Readable (Name : String) is + procedure C_Set_Readable (Name : C_File_Name); + pragma Import (C, C_Set_Readable, "__gnat_set_readable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Readable (C_Name (C_Name'First)'Address); + end Set_Readable; + + -------------------- + -- Set_Writable -- + -------------------- + + procedure Set_Writable (Name : String) is + procedure C_Set_Writable (Name : C_File_Name); + pragma Import (C, C_Set_Writable, "__gnat_set_writable"); + C_Name : aliased String (Name'First .. Name'Last + 1); + + begin + C_Name (Name'Range) := Name; + C_Name (C_Name'Last) := ASCII.NUL; + C_Set_Writable (C_Name (C_Name'First)'Address); + end Set_Writable; + + ------------ + -- Setenv -- + ------------ + + procedure Setenv (Name : String; Value : String) is + F_Name : String (1 .. Name'Length + 1); + F_Value : String (1 .. Value'Length + 1); + + procedure Set_Env_Value (Name, Value : System.Address); + pragma Import (C, Set_Env_Value, "__gnat_setenv"); + + begin + F_Name (1 .. Name'Length) := Name; + F_Name (F_Name'Last) := ASCII.NUL; + + F_Value (1 .. Value'Length) := Value; + F_Value (F_Value'Last) := ASCII.NUL; + + Set_Env_Value (F_Name'Address, F_Value'Address); + end Setenv; + + ----------- + -- Spawn -- + ----------- + + function Spawn + (Program_Name : String; + Args : Argument_List) return Integer + is + Junk : Process_Id; + pragma Warnings (Off, Junk); + Result : Integer; + + begin + Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); + return Result; + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Success : out Boolean) + is + begin + Success := (Spawn (Program_Name, Args) = 0); + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Return_Code : out Integer; + Err_To_Out : Boolean := True) + is + Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning + Saved_Output : File_Descriptor; + + begin + -- Set standard output and error to the temporary file + + Saved_Output := Dup (Standout); + Dup2 (Output_File_Descriptor, Standout); + + if Err_To_Out then + Saved_Error := Dup (Standerr); + Dup2 (Output_File_Descriptor, Standerr); + end if; + + -- Spawn the program + + Return_Code := Spawn (Program_Name, Args); + + -- Restore the standard output and error + + Dup2 (Saved_Output, Standout); + + if Err_To_Out then + Dup2 (Saved_Error, Standerr); + end if; + + -- And close the saved standard output and error file descriptors + + Close (Saved_Output); + + if Err_To_Out then + Close (Saved_Error); + end if; + end Spawn; + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Success : out Boolean; + Return_Code : out Integer; + Err_To_Out : Boolean := True) + is + FD : File_Descriptor; + + begin + Success := True; + Return_Code := 0; + + FD := Create_Output_Text_File (Output_File); + + if FD = Invalid_FD then + Success := False; + return; + end if; + + Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out); + + Close (FD, Success); + end Spawn; + + -------------------- + -- Spawn_Internal -- + -------------------- + + procedure Spawn_Internal + (Program_Name : String; + Args : Argument_List; + Result : out Integer; + Pid : out Process_Id; + Blocking : Boolean) + is + procedure Spawn (Args : Argument_List); + -- Call Spawn with given argument list + + N_Args : Argument_List (Args'Range); + -- Normalized arguments + + ----------- + -- Spawn -- + ----------- + + procedure Spawn (Args : Argument_List) is + type Chars is array (Positive range <>) of aliased Character; + type Char_Ptr is access constant Character; + + Command_Len : constant Positive := + Program_Name'Length + 1 + Args_Length (Args); + Command_Last : Natural := 0; + Command : aliased Chars (1 .. Command_Len); + -- Command contains all characters of the Program_Name and Args, all + -- terminated by ASCII.NUL characters. + + Arg_List_Len : constant Positive := Args'Length + 2; + Arg_List_Last : Natural := 0; + Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; + -- List with pointers to NUL-terminated strings of the Program_Name + -- and the Args and terminated with a null pointer. We rely on the + -- default initialization for the last null pointer. + + procedure Add_To_Command (S : String); + -- Add S and a NUL character to Command, updating Last + + function Portable_Spawn (Args : Address) return Integer; + pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); + + function Portable_No_Block_Spawn (Args : Address) return Process_Id; + pragma Import + (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); + + -------------------- + -- Add_To_Command -- + -------------------- + + procedure Add_To_Command (S : String) is + First : constant Natural := Command_Last + 1; + + begin + Command_Last := Command_Last + S'Length; + + -- Move characters one at a time, because Command has aliased + -- components. + + -- But not volatile, so why is this necessary ??? + + for J in S'Range loop + Command (First + J - S'First) := S (J); + end loop; + + Command_Last := Command_Last + 1; + Command (Command_Last) := ASCII.NUL; + + Arg_List_Last := Arg_List_Last + 1; + Arg_List (Arg_List_Last) := Command (First)'Access; + end Add_To_Command; + + -- Start of processing for Spawn + + begin + Add_To_Command (Program_Name); + + for J in Args'Range loop + Add_To_Command (Args (J).all); + end loop; + + if Blocking then + Pid := Invalid_Pid; + Result := Portable_Spawn (Arg_List'Address); + else + Pid := Portable_No_Block_Spawn (Arg_List'Address); + Result := Boolean'Pos (Pid /= Invalid_Pid); + end if; + end Spawn; + + -- Start of processing for Spawn_Internal + + begin + -- Copy arguments into a local structure + + for K in N_Args'Range loop + N_Args (K) := new String'(Args (K).all); + end loop; + + -- Normalize those arguments + + Normalize_Arguments (N_Args); + + -- Call spawn using the normalized arguments + + Spawn (N_Args); + + -- Free arguments list + + for K in N_Args'Range loop + Free (N_Args (K)); + end loop; + end Spawn_Internal; + + --------------------------- + -- To_Path_String_Access -- + --------------------------- + + function To_Path_String_Access + (Path_Addr : Address; + Path_Len : Integer) return String_Access + is + subtype Path_String is String (1 .. Path_Len); + type Path_String_Access is access Path_String; + + function Address_To_Access is new Ada.Unchecked_Conversion + (Source => Address, Target => Path_String_Access); + + Path_Access : constant Path_String_Access := + Address_To_Access (Path_Addr); + + Return_Val : String_Access; + + begin + Return_Val := new String (1 .. Path_Len); + + for J in 1 .. Path_Len loop + Return_Val (J) := Path_Access (J); + end loop; + + return Return_Val; + end To_Path_String_Access; + + ------------------ + -- Wait_Process -- + ------------------ + + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is + Status : Integer; + + function Portable_Wait (S : Address) return Process_Id; + pragma Import (C, Portable_Wait, "__gnat_portable_wait"); + + begin + Pid := Portable_Wait (Status'Address); + Success := (Status = 0); + end Wait_Process; + + ----------- + -- Write -- + ----------- + + function Write + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer + is + begin + return + Integer (System.CRTL.write + (System.CRTL.int (FD), + System.CRTL.chars (A), + System.CRTL.size_t (N))); + end Write; + +end System.OS_Lib; diff --git a/gcc/ada/libgnat/s-os_lib.ads b/gcc/ada/libgnat/s-os_lib.ads new file mode 100644 index 0000000..5fba00a --- /dev/null +++ b/gcc/ada/libgnat/s-os_lib.ads @@ -0,0 +1,1111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . O S _ L I B -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Operating system interface facilities + +-- This package contains types and procedures for interfacing to the +-- underlying OS. It is used by the GNAT compiler and by tools associated +-- with the GNAT compiler, and therefore works for the various operating +-- systems to which GNAT has been ported. This package will undoubtedly grow +-- as new services are needed by various tools. + +-- This package tends to use fairly low-level Ada in order to not bring in +-- large portions of the RTL. For example, functions return access to string +-- as part of avoiding functions returning unconstrained types. + +-- Except where specifically noted, these routines are portable across all +-- GNAT implementations on all supported operating systems. + +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.OS_Lib (file g-os_lib.ads). + +pragma Compiler_Unit_Warning; + +with System; +with System.Strings; + +package System.OS_Lib is + pragma Preelaborate; + + ----------------------- + -- String Operations -- + ----------------------- + + -- These are reexported from package Strings (which was introduced to + -- avoid different packages declaring different types unnecessarily). + -- See package System.Strings for details. + + subtype String_Access is Strings.String_Access; + + function "=" (Left : String_Access; Right : String_Access) return Boolean + renames Strings."="; + + procedure Free (X : in out String_Access) renames Strings.Free; + + subtype String_List is Strings.String_List; + + function "=" (Left : String_List; Right : String_List) return Boolean + renames Strings."="; + + function "&" (Left : String_Access; Right : String_Access) + return String_List renames Strings."&"; + function "&" (Left : String_Access; Right : String_List) + return String_List renames Strings."&"; + function "&" (Left : String_List; Right : String_Access) + return String_List renames Strings."&"; + function "&" (Left : String_List; Right : String_List) + return String_List renames Strings."&"; + + subtype String_List_Access is Strings.String_List_Access; + + function "=" + (Left : String_List_Access; + Right : String_List_Access) return Boolean renames Strings."="; + + procedure Free (Arg : in out String_List_Access) renames Strings.Free; + + --------------------- + -- Time/Date Stuff -- + --------------------- + + type OS_Time is private; + -- The OS's notion of time is represented by the private type OS_Time. This + -- is the type returned by the File_Time_Stamp functions to obtain the time + -- stamp of a specified file. Functions and a procedure (modeled after the + -- similar subprograms in package Calendar) are provided for extracting + -- information from a value of this type. Although these are called GM, the + -- intention in the case of time stamps is not that they provide GMT times + -- in all cases but rather the actual (time-zone independent) time stamp of + -- the file (of course in Unix systems, this *is* in GMT form). + + Invalid_Time : constant OS_Time; + -- A special unique value used to flag an invalid time stamp value + + function "<" (X : OS_Time; Y : OS_Time) return Boolean; + function ">" (X : OS_Time; Y : OS_Time) return Boolean; + function ">=" (X : OS_Time; Y : OS_Time) return Boolean; + function "<=" (X : OS_Time; Y : OS_Time) return Boolean; + -- Basic comparison operators on OS_Time with obvious meanings. Note that + -- these have Intrinsic convention, so for example it is not permissible + -- to create accesses to any of these functions. + + subtype Year_Type is Integer range 1900 .. 2099; + subtype Month_Type is Integer range 1 .. 12; + subtype Day_Type is Integer range 1 .. 31; + subtype Hour_Type is Integer range 0 .. 23; + subtype Minute_Type is Integer range 0 .. 59; + subtype Second_Type is Integer range 0 .. 59; + -- Declarations similar to those in Calendar, breaking down the time + + function Current_Time return OS_Time; + -- Return the system clock value as OS_Time + + function Current_Time_String return String; + -- Returns current local time in the form YYYY-MM-DD HH:MM:SS. The result + -- has bounds 1 .. 19. + + function GM_Year (Date : OS_Time) return Year_Type; + function GM_Month (Date : OS_Time) return Month_Type; + function GM_Day (Date : OS_Time) return Day_Type; + function GM_Hour (Date : OS_Time) return Hour_Type; + function GM_Minute (Date : OS_Time) return Minute_Type; + function GM_Second (Date : OS_Time) return Second_Type; + -- Functions to extract information from OS_Time value in GMT form + + procedure GM_Split + (Date : OS_Time; + Year : out Year_Type; + Month : out Month_Type; + Day : out Day_Type; + Hour : out Hour_Type; + Minute : out Minute_Type; + Second : out Second_Type); + -- Analogous to the Split routine in Ada.Calendar, takes an OS_Time and + -- provides a representation of it as a set of component parts, to be + -- interpreted as a date point in UTC. + + function GM_Time_Of + (Year : Year_Type; + Month : Month_Type; + Day : Day_Type; + Hour : Hour_Type; + Minute : Minute_Type; + Second : Second_Type) return OS_Time; + -- Analogous to the Time_Of routine in Ada.Calendar, takes a set of time + -- component parts to be interpreted in the local time zone, and returns + -- an OS_Time. Returns Invalid_Time if the creation fails. + + ---------------- + -- File Stuff -- + ---------------- + + -- These routines give access to the open/creat/close/read/write level of + -- I/O routines in the typical C library (these functions are not part of + -- the ANSI C standard, but are typically available in all systems). See + -- also package Interfaces.C_Streams for access to the stream level + -- routines. + + -- Note on file names. If a file name is passed as type String in any of + -- the following specifications, then the name is a normal Ada string and + -- need not be NUL-terminated. However, a trailing NUL character is + -- permitted, and will be ignored (more accurately, the NUL and any + -- characters that follow it will be ignored). + + type File_Descriptor is new Integer; + -- Corresponds to the int file handle values used in the C routines + + Standin : constant File_Descriptor := 0; + Standout : constant File_Descriptor := 1; + Standerr : constant File_Descriptor := 2; + -- File descriptors for standard input output files + + Invalid_FD : constant File_Descriptor := -1; + -- File descriptor returned when error in opening/creating file + + procedure Close (FD : File_Descriptor; Status : out Boolean); + -- Close file referenced by FD. Status is False if the underlying service + -- failed. Reasons for failure include: disk full, disk quotas exceeded + -- and invalid file descriptor (the file may have been closed twice). + + procedure Close (FD : File_Descriptor); + -- Close file referenced by FD. This form is used when the caller wants to + -- ignore any possible error (see above for error cases). + + type Copy_Mode is + (Copy, + -- Copy the file. It is an error if the target file already exists. The + -- time stamps and other file attributes are preserved in the copy. + + Overwrite, + -- If the target file exists, the file is replaced otherwise the file + -- is just copied. The time stamps and other file attributes are + -- preserved in the copy. + + Append); + -- If the target file exists, the contents of the source file is + -- appended at the end. Otherwise the source file is just copied. The + -- time stamps and other file attributes are preserved if the + -- destination file does not exist. + + type Attribute is + (Time_Stamps, + -- Copy time stamps from source file to target file. All other + -- attributes are set to normal default values for file creation. + + Full, + -- All attributes are copied from the source file to the target file. + -- This includes the timestamps, and for example also includes + -- read/write/execute attributes in Unix systems. + + None); + -- No attributes are copied. All attributes including the time stamp + -- values are set to normal default values for file creation. + + -- Note: The default is Time_Stamps, which corresponds to the normal + -- default on Windows style systems. Full corresponds to the typical + -- effect of "cp -p" on Unix systems, and None corresponds to the typical + -- effect of "cp" on Unix systems. + + -- Note: Time_Stamps and Full are not supported on VxWorks 5 + + procedure Copy_File + (Name : String; + Pathname : String; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps); + -- Copy a file. Name must designate a single file (no wild cards allowed). + -- Pathname can be a filename or directory name. In the latter case Name + -- is copied into the directory preserving the same file name. Mode + -- defines the kind of copy, see above with the default being a normal + -- copy in which the target file must not already exist. Success is set to + -- True or False indicating if the copy is successful (depending on the + -- specified Mode). + + procedure Copy_File_Attributes + (From : String; + To : String; + Success : out Boolean; + Copy_Timestamp : Boolean := True; + Copy_Permissions : Boolean := True); + -- Copy some of the file attributes from one file to another. Both files + -- must exist, or Success is set to False. + + procedure Copy_Time_Stamps + (Source : String; + Dest : String; + Success : out Boolean); + -- Copy Source file time stamps (last modification and last access time + -- stamps) to Dest file. Source and Dest must be valid filenames, + -- furthermore Dest must be writable. Success will be set to True if the + -- operation was successful and False otherwise. + -- + -- Note: this procedure is not supported on VxWorks 5. On this platform, + -- Success is always set to False. + + type Mode is (Binary, Text); + for Mode'Size use Integer'Size; + for Mode use (Binary => 0, Text => 1); + -- Used in all the Open and Create calls to specify if the file is to be + -- opened in binary mode or text mode. In systems like Unix, this has no + -- effect, but in systems capable of text mode translation, the use of + -- Text as the mode parameter causes the system to do CR/LF translation + -- and also to recognize the DOS end of file character on input. The use + -- of Text where appropriate allows programs to take a portable Unix view + -- of DOS-format files and process them appropriately. + + function Create_File + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Creates new file with given name for writing, returning file descriptor + -- for subsequent use in Write calls. If the file already exists, it is + -- overwritten. File descriptor returned is Invalid_FD if file cannot be + -- successfully created. + + function Create_New_File + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Create new file with given name for writing, returning file descriptor + -- for subsequent use in Write calls. This differs from Create_File in + -- that it fails if the file already exists. File descriptor returned is + -- Invalid_FD if the file exists or cannot be created. + + function Create_Output_Text_File (Name : String) return File_Descriptor; + -- Creates new text file with given name suitable to redirect standard + -- output, returning file descriptor. File descriptor returned is + -- Invalid_FD if file cannot be successfully created. + + Temp_File_Len : constant Integer := 12; + -- Length of name returned by Create_Temp_File call (GNAT-XXXXXX & NUL) + + subtype Temp_File_Name is String (1 .. Temp_File_Len); + -- String subtype set by Create_Temp_File + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out Temp_File_Name); + -- Create and open for writing a temporary file in the current working + -- directory. The name of the file and the File Descriptor are returned. + -- The File Descriptor returned is Invalid_FD in the case of failure. No + -- mode parameter is provided. Since this is a temporary file, there is no + -- point in doing text translation on it. + -- + -- On some operating systems, the maximum number of temp files that can be + -- created with this procedure may be limited. When the maximum is reached, + -- this procedure returns Invalid_FD. On some operating systems, there may + -- be a race condition between processes trying to create temp files at the + -- same time in the same directory using this procedure. + + procedure Create_Temp_File + (FD : out File_Descriptor; + Name : out String_Access); + -- Create and open for writing a temporary file in the current working + -- directory. The name of the file and the File Descriptor are returned. + -- It is the responsibility of the caller to deallocate the access value + -- returned in Name. + -- + -- The file is opened in binary mode (no text translation). + -- + -- This procedure will always succeed if the current working directory is + -- writable. If the current working directory is not writable, then + -- Invalid_FD is returned for the file descriptor and null for the Name. + -- There is no race condition problem between processes trying to create + -- temp files at the same time in the same directory. + + procedure Create_Temp_Output_File + (FD : out File_Descriptor; + Name : out String_Access); + -- Create and open for writing a temporary file in the current working + -- directory suitable to redirect standard output. The name of the file and + -- the File Descriptor are returned. It is the responsibility of the caller + -- to deallocate the access value returned in Name. + -- + -- The file is opened in text mode + -- + -- This procedure will always succeed if the current working directory is + -- writable. If the current working directory is not writable, then + -- Invalid_FD is returned for the file descriptor and null for the Name. + -- There is no race condition problem between processes trying to create + -- temp files at the same time in the same directory. + + procedure Delete_File (Name : String; Success : out Boolean); + -- Deletes file. Success is set True or False indicating if the delete is + -- successful. + + function File_Length (FD : File_Descriptor) return Long_Integer; + pragma Import (C, File_Length, "__gnat_file_length_long"); + + type Large_File_Size is range -2**63 .. 2**63 - 1; + -- Maximum supported size for a file (8 exabytes = 8 million terabytes, + -- should be enough to accommodate all possible needs for quite a while). + + function File_Length64 (FD : File_Descriptor) return Large_File_Size; + pragma Import (C, File_Length64, "__gnat_file_length"); + -- Get length of file from file descriptor FD + + function File_Time_Stamp (Name : String) return OS_Time; + -- Given the name of a file or directory, Name, obtains and returns the + -- time stamp. This function can be used for an unopened file. Returns + -- Invalid_Time if Name doesn't correspond to an existing file. + + function File_Time_Stamp (FD : File_Descriptor) return OS_Time; + -- Get time stamp of file from file descriptor FD Returns Invalid_Time is + -- FD doesn't correspond to an existing file. + + function Get_Debuggable_Suffix return String_Access; + -- Return the debuggable suffix convention. Usually this is the same as + -- the convention for Get_Executable_Suffix. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. + + function Get_Executable_Suffix return String_Access; + -- Return the executable suffix convention. The result is allocated on the + -- heap and should be freed after use to avoid storage leaks. + + function Get_Object_Suffix return String_Access; + -- Return the object suffix convention. The result is allocated on the heap + -- and should be freed after use to avoid storage leaks. + + function Get_Target_Debuggable_Suffix return String_Access; + -- Return the target debuggable suffix convention. Usually this is the same + -- as the convention for Get_Executable_Suffix. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. + + function Get_Target_Executable_Suffix return String_Access; + -- Return the target executable suffix convention. The result is allocated + -- on the heap and should be freed after use to avoid storage leaks. + + function Get_Target_Object_Suffix return String_Access; + -- Return the target object suffix convention. The result is allocated on + -- the heap and should be freed after use to avoid storage leaks. + + function Is_Absolute_Path (Name : String) return Boolean; + -- Returns True if Name is an absolute path name, i.e. it designates a + -- file or directory absolutely rather than relative to another directory. + + function Is_Directory (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of a directory. + -- Returns True if so, False otherwise. Name may be an absolute path + -- name or a relative path name, including a simple file name. If it is + -- a relative path name, it is relative to the current working directory. + + function Is_Executable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is executable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + + function Is_Owner_Readable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is readable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be readable due to some other process having exclusive + -- access. + + function Is_Regular_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing + -- regular file. Returns True if so, False otherwise. Name may be an + -- absolute path name or a relative path name, including a simple file + -- name. If it is a relative path name, it is relative to the current + -- working directory. + + function Is_Symbolic_Link (Name : String) return Boolean; + -- Determines if the given string, Name, is the path of a symbolic link on + -- systems that support it. Returns True if so, False if the path is not a + -- symbolic link or if the system does not support symbolic links. + -- + -- A symbolic link is an indirect pointer to a file; its directory entry + -- contains the name of the file to which it is linked. Symbolic links may + -- span file systems and may refer to directories. + + function Is_Owner_Writable_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is writable. Returns True if so, False otherwise. Note that this + -- function simply interrogates the file attributes (e.g. using the C + -- function stat), so it does not indicate a situation in which a file may + -- not actually be writable due to some other process having exclusive + -- access. + + function Is_Read_Accessible_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is readable. Returns True if so, False otherwise. + + function Is_Write_Accessible_File (Name : String) return Boolean; + -- Determines if the given string, Name, is the name of an existing file + -- that is writable. Returns True if so, False otherwise. + + function Is_Readable_File (Name : String) return Boolean + renames Is_Read_Accessible_File; + function Is_Writable_File (Name : String) return Boolean + renames Is_Write_Accessible_File; + -- These subprograms provided for backward compatibility and should not be + -- used. Use Is_Owner_Readable_File/Is_Owner_Writable_File or + -- Is_Read_Accessible_File/Is_Write_Accessible_File instead. + + function Locate_Exec_On_Path (Exec_Name : String) return String_Access; + -- Try to locate an executable whose name is given by Exec_Name in the + -- directories listed in the environment Path. If the Exec_Name does not + -- have the executable suffix, it will be appended before the search. + -- Otherwise works like Locate_Regular_File below. If the executable is + -- not found, null is returned. + -- + -- Note that this function allocates memory for the returned value. This + -- memory needs to be deallocated after use. + + function Locate_Regular_File + (File_Name : String; + Path : String) return String_Access; + -- Try to locate a regular file whose name is given by File_Name in the + -- directories listed in Path. If a file is found, its full pathname is + -- returned; otherwise, a null pointer is returned. If the File_Name given + -- is an absolute pathname, then Locate_Regular_File just checks that the + -- file exists and is a regular file. Otherwise, if the File_Name given + -- includes directory information, Locate_Regular_File first checks if the + -- file exists relative to the current directory. If it does not, or if + -- the File_Name given is a simple file name, the Path argument is parsed + -- according to OS conventions, and for each directory in the Path a check + -- is made if File_Name is a relative pathname of a regular file from that + -- directory. + -- + -- Note that this function allocates some memory for the returned value. + -- This memory needs to be deallocated after use. + + Seek_Cur : constant := 1; + Seek_End : constant := 2; + Seek_Set : constant := 0; + -- Used to indicate origin for Lseek call + + procedure Lseek + (FD : File_Descriptor; + offset : Long_Integer; + origin : Integer); + pragma Import (C, Lseek, "__gnat_lseek"); + -- Sets the current file pointer to the indicated offset value, relative + -- to the current position (origin = SEEK_CUR), end of file (origin = + -- SEEK_END), or start of file (origin = SEEK_SET). + + function Normalize_Pathname + (Name : String; + Directory : String := ""; + Resolve_Links : Boolean := True; + Case_Sensitive : Boolean := True) return String; + -- Returns a file name as an absolute path name, resolving all relative + -- directories, and symbolic links. If Name is a relative path, it is + -- interpreted relative to Directory, or to the current directory if + -- Directory is the empty string (the default). The result returned is + -- the normalized name of the file, containing no "." or ".." components, + -- and no duplicated directory separators. For most cases, if two file + -- names designate the same file through different paths, + -- Normalize_Pathname will return the same canonical name in both cases. + -- However, there are cases when this is not true; for example, this is + -- not true in Unix for two hard links designating the same file. + -- + -- On Windows, the returned path will start with a drive letter. If + -- Directory is empty (the default) and Name is a relative path or an + -- absolute path without drive letter, the letter of the current drive + -- will start the returned path. If Case_Sensitive is True (the default), + -- then this drive letter will be forced to upper case ("C:\..."). + -- + -- If Resolve_Links is set to True, then the symbolic links, on systems + -- that support them, will be fully converted to the name of the file or + -- directory pointed to. This is slightly less efficient, since it + -- requires system calls. + -- + -- If Name cannot be resolved, is invalid (for example if it is too big) or + -- is null on entry (for example if there is symbolic link circularity, + -- e.g. A is a symbolic link for B, and B is a symbolic link for A), then + -- Normalize_Pathname returns an empty string. + -- + -- For case-sensitive file systems, the value of Case_Sensitive parameter + -- is ignored. For file systems that are not case-sensitive, such as + -- Windows, if this parameter is set to False, then the file and directory + -- names are folded to lower case. This allows checking whether two files + -- are the same by applying this function to their names and comparing the + -- results. If Case_Sensitive is set to True, this function does not change + -- the casing of file and directory names. + + function Open_Append + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Opens file Name for appending, returning its file descriptor. File + -- descriptor returned is Invalid_FD if the file cannot be successfully + -- opened. + + function Open_Read + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Open file Name for reading, returning its file descriptor. File + -- descriptor returned is Invalid_FD if the file cannot be opened. + + function Open_Read_Write + (Name : String; + Fmode : Mode) return File_Descriptor; + -- Open file Name for both reading and writing, returning its file + -- descriptor. File descriptor returned is Invalid_FD if the file + -- cannot be opened. + + function Read + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + -- Read N bytes to address A from file referenced by FD. Returned value is + -- count of bytes actually read, which can be less than N at EOF. + + procedure Rename_File + (Old_Name : String; + New_Name : String; + Success : out Boolean); + -- Rename a file. Success is set True or False indicating if the rename is + -- successful or not. + -- + -- WARNING: In one very important respect, this function is significantly + -- non-portable. If New_Name already exists then on Unix systems, the call + -- deletes the existing file, and the call signals success. On Windows, the + -- call fails, without doing the rename operation. See also the procedure + -- Ada.Directories.Rename, which portably provides the windows semantics, + -- i.e. fails if the output file already exists. + + -- The following defines the mode for the Copy_File procedure below. Note + -- that "time stamps and other file attributes" in the descriptions below + -- refers to the creation and last modification times, and also the file + -- access (read/write/execute) status flags. + + procedure Set_Close_On_Exec + (FD : File_Descriptor; + Close_On_Exec : Boolean; + Status : out Boolean); + -- When Close_On_Exec is True, mark FD to be closed automatically when new + -- program is executed by the calling process (i.e. prevent FD from being + -- inherited by child processes). When Close_On_Exec is False, mark FD to + -- not be closed on exec (i.e. allow it to be inherited). Status is False + -- if the operation could not be performed. + + S_Owner : constant := 1; + S_Group : constant := 2; + S_Others : constant := 4; + -- Constants for use in Mode parameter to Set_Executable + + procedure Set_Executable (Name : String; Mode : Positive := S_Owner); + -- Change permissions on the file given by Name to make it executable + -- for its owner, group or others, according to the setting of Mode. + -- As indicated, the default if no Mode parameter is given is owner. + + procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time); + -- Given the name of a file or directory, Name, set the last modification + -- time stamp. This function must be used for an unopened file. + + procedure Set_Non_Readable (Name : String); + -- Change permissions on the named file to make it non-readable for + -- its owner. The writable and executable permissions are not + -- modified. + + procedure Set_Non_Writable (Name : String); + -- Change permissions on the named file to make it non-writable for its + -- owner. The readable and executable permissions are not modified. + + procedure Set_Read_Only (Name : String) renames Set_Non_Writable; + -- This renaming is provided for backwards compatibility with previous + -- versions. The use of Set_Non_Writable is preferred (clearer name). + + procedure Set_Readable (Name : String); + -- Change permissions on the named file to make it readable for its + -- owner. + + procedure Set_Writable (Name : String); + -- Change permissions on the named file to make it writable for its owner + + function Write + (FD : File_Descriptor; + A : System.Address; + N : Integer) return Integer; + -- Write N bytes from address A to file referenced by FD. The returned + -- value is the number of bytes written, which can be less than N if a + -- disk full condition was detected. + + -- The following section contains low-level routines using addresses to + -- pass file name and executable name. In each routine the name must be + -- Nul-Terminated. For complete documentation refer to the equivalent + -- routine (using String in place of C_File_Name) defined above. + + subtype C_File_Name is System.Address; + -- This subtype is used to document that a parameter is the address of a + -- null-terminated string containing the name of a file. + + procedure Copy_File + (Name : C_File_Name; + Pathname : C_File_Name; + Success : out Boolean; + Mode : Copy_Mode := Copy; + Preserve : Attribute := Time_Stamps); + + procedure Copy_Time_Stamps + (Source : C_File_Name; + Dest : C_File_Name; + Success : out Boolean); + + function Create_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Create_New_File + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + procedure Delete_File (Name : C_File_Name; Success : out Boolean); + + function File_Time_Stamp (Name : C_File_Name) return OS_Time; + + function Is_Directory (Name : C_File_Name) return Boolean; + function Is_Executable_File (Name : C_File_Name) return Boolean; + function Is_Owner_Readable_File (Name : C_File_Name) return Boolean; + function Is_Regular_File (Name : C_File_Name) return Boolean; + function Is_Symbolic_Link (Name : C_File_Name) return Boolean; + function Is_Owner_Writable_File (Name : C_File_Name) return Boolean; + + function Locate_Regular_File + (File_Name : C_File_Name; + Path : C_File_Name) return String_Access; + + function Open_Append + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Open_Read + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + function Open_Read_Write + (Name : C_File_Name; + Fmode : Mode) return File_Descriptor; + + procedure Rename_File + (Old_Name : C_File_Name; + New_Name : C_File_Name; + Success : out Boolean); + + ------------------ + -- Subprocesses -- + ------------------ + + subtype Argument_List is String_List; + -- Type used for argument list in call to Spawn. The lower bound of the + -- array should be 1, and the length of the array indicates the number of + -- arguments. + + subtype Argument_List_Access is String_List_Access; + -- Type used to return Argument_List without dragging in secondary stack. + -- Note that there is a Free procedure declared for this subtype which + -- frees the array and all referenced strings. + + type Process_Id is private; + -- A private type used to identify a process activated by the following + -- non-blocking calls. The only meaningful operation on this type is a + -- comparison for equality. + + Invalid_Pid : constant Process_Id; + -- A special value used to indicate errors, as described below + + function Current_Process_Id return Process_Id; + -- Returns the current process id or Invalid_Pid if not supported by the + -- runtime. + + function Argument_String_To_List + (Arg_String : String) return Argument_List_Access; + -- Take a string that is a program and its arguments and parse it into an + -- Argument_List. Note that the result is allocated on the heap, and must + -- be freed by the programmer (when it is no longer needed) to avoid + -- memory leaks. + -- On Windows, backslashes are used as directory separators. On Unix, + -- however, they are used to escape the following character, so that for + -- instance "-d=name\ with\ space" is a single argument. In the result + -- list, the backslashes have been cleaned up when needed. The previous + -- example will thus result a single-element array, where the element is + -- "-d=name with space" (Unix) or "-d=name\ with\ space" (windows). + + procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True); + -- Kill the process designated by Pid. Does nothing if Pid is Invalid_Pid + -- or on platforms where it is not supported, such as VxWorks. Hard_Kill + -- is True by default, and when True the process is terminated immediately. + -- If Hard_Kill is False, then a signal SIGINT is sent to the process on + -- POSIX OS or a ctrl-C event on Windows, allowing the process a chance to + -- terminate properly using a corresponding handler. + + procedure Kill_Process_Tree (Pid : Process_Id; Hard_Kill : Boolean := True); + -- Kill the process designated by Pid and all it's children processes. + -- Does nothing if Pid is Invalid_Pid or on platforms where it is not + -- supported, such as VxWorks. Hard_Kill is True by default, and when True + -- the processes are terminated immediately. If Hard_Kill is False, then a + -- signal SIGINT is sent to the processes on POSIX OS or a ctrl-C event + -- on Windows, allowing the processes a chance to terminate properly + -- using a corresponding handler. + -- + -- Note that this routine is not atomic and is supported only on Linux + -- and Windows. On other OS it will only kill the process identified by + -- Pid. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List) return Process_Id; + -- This is a non blocking call. The Process_Id of the spawned process is + -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is + -- returned the program could not be spawned. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Err_To_Out : Boolean := True) return Process_Id; + -- Similar to the procedure above, but redirects the output to the file + -- designated by Output_File_Descriptor. If Err_To_Out is True, then the + -- Standard Error output is also redirected. Invalid_Pid is returned + -- if the program could not be spawned successfully. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Err_To_Out : Boolean := True) return Process_Id; + -- Similar to the procedure above, but saves the output of the command to + -- a file with the name Output_File. + -- + -- Invalid_Pid is returned if the output file could not be created or if + -- the program could not be spawned successfully. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- This function will always return Invalid_Pid under VxWorks, since there + -- is no notion of executables under this OS. + + function Non_Blocking_Spawn + (Program_Name : String; + Args : Argument_List; + Stdout_File : String; + Stderr_File : String) return Process_Id; + -- Similar to the procedure above, but saves the standard output of the + -- command to a file with the name Stdout_File and the standard output + -- of the command to a file with the name Stderr_File. + + procedure Normalize_Arguments (Args : in out Argument_List); + -- Normalize all arguments in the list. This ensure that the argument list + -- is compatible with the running OS and will works fine with Spawn and + -- Non_Blocking_Spawn for example. If Normalize_Arguments is called twice + -- on the same list it will do nothing the second time. Note that Spawn + -- and Non_Blocking_Spawn call Normalize_Arguments automatically, but + -- since there is a guarantee that a second call does nothing, this + -- internal call will have no effect if Normalize_Arguments is called + -- before calling Spawn. The call to Normalize_Arguments assumes that the + -- individual referenced arguments in Argument_List are on the heap, and + -- may free them and reallocate if they are modified. + + function Pid_To_Integer (Pid : Process_Id) return Integer; + -- Convert a process id to an Integer. Useful for writing hash functions + -- for type Process_Id or to compare two Process_Id (e.g. for sorting). + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Success : out Boolean); + -- This procedure spawns a program with a given list of arguments. The + -- first parameter of is the name of the executable. The second parameter + -- contains the arguments to be passed to this program. Success is False + -- if the named program could not be spawned or its execution completed + -- unsuccessfully. Note that the caller will be blocked until the + -- execution of the spawned program is complete. For maximum portability, + -- use a full path name for the Program_Name argument. On some systems + -- (notably Unix systems) a simple file name may also work (if the + -- executable can be located in the path). + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + -- + -- Note: Arguments in Args that contain spaces and/or quotes such as + -- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all + -- operating systems, and would not have the desired effect if they were + -- passed directly to the operating system. To avoid this problem, Spawn + -- makes an internal call to Normalize_Arguments, which ensures that such + -- arguments are modified in a manner that ensures that the desired effect + -- is obtained on all operating systems. The caller may call + -- Normalize_Arguments explicitly before the call (e.g. to print out the + -- exact form of arguments passed to the operating system). In this case + -- the guarantee a second call to Normalize_Arguments has no effect + -- ensures that the internal call will not affect the result. Note that + -- the implicit call to Normalize_Arguments may free and reallocate some + -- of the individual arguments. + -- + -- This function will always set Success to False under VxWorks and other + -- similar operating systems which have no notion of the concept of + -- dynamically executable file. Otherwise Success is set True if the exit + -- status of the spawned process is zero. + + function Spawn + (Program_Name : String; + Args : Argument_List) return Integer; + -- Similar to the above procedure, but returns the actual status returned + -- by the operating system, or -1 under VxWorks and any other similar + -- operating systems which have no notion of separately spawnable programs. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File_Descriptor : File_Descriptor; + Return_Code : out Integer; + Err_To_Out : Boolean := True); + -- Similar to the procedure above, but redirects the output to the file + -- designated by Output_File_Descriptor. If Err_To_Out is True, then the + -- Standard Error output is also redirected. + -- Return_Code is set to the status code returned by the operating system + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + + procedure Spawn + (Program_Name : String; + Args : Argument_List; + Output_File : String; + Success : out Boolean; + Return_Code : out Integer; + Err_To_Out : Boolean := True); + -- Similar to the procedure above, but saves the output of the command to + -- a file with the name Output_File. + -- + -- Success is set to True if the command is executed and its output + -- successfully written to the file. If Success is True, then Return_Code + -- will be set to the status code returned by the operating system. + -- Otherwise, Return_Code is undefined. + -- + -- Spawning processes from tasking programs is not recommended. See + -- "NOTE: Spawn in tasking programs" below. + + procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); + -- Wait for the completion of any of the processes created by previous + -- calls to Non_Blocking_Spawn. The caller will be suspended until one of + -- these processes terminates (normally or abnormally). If any of these + -- subprocesses terminates prior to the call to Wait_Process (and has not + -- been returned by a previous call to Wait_Process), then the call to + -- Wait_Process is immediate. Pid identifies the process that has + -- terminated (matching the value returned from Non_Blocking_Spawn). + -- Success is set to True if this sub-process terminated successfully. If + -- Pid = Invalid_Pid, there were no subprocesses left to wait on. + -- + -- This function will always set success to False under VxWorks, since + -- there is no notion of executables under this OS. + + procedure Non_Blocking_Wait_Process + (Pid : out Process_Id; Success : out Boolean); + -- Same as Wait_Process, except if there are no completed child processes, + -- return immediately without blocking, and return Invalid_Pid in Pid. + -- Not supported on all platforms; Success = False if not supported. + + ------------------------------------- + -- NOTE: Spawn in Tasking Programs -- + ------------------------------------- + + -- Spawning processes in tasking programs using the above Spawn and + -- Non_Blocking_Spawn subprograms is not recommended, because there are + -- subtle interactions between creating a process and signals/locks that + -- can cause trouble. These issues are not specific to Ada; they depend + -- primarily on the operating system. + + -- If you need to spawn processes in a tasking program, you will need to + -- understand the semantics of your operating system, and you are likely to + -- write non-portable code, because operating systems differ in this area. + + -- The Spawn and Non_Blocking_Spawn subprograms call the following + -- operating system functions: + + -- On Windows: spawnvp (blocking) or CreateProcess (non-blocking) + + -- On Solaris: fork1, followed in the child process by execv + + -- On other Unix-like systems: fork, followed in the child + -- process by execv. + + -- On vxworks, spawning of processes is not supported + + -- For details, look at the functions __gnat_portable_spawn and + -- __gnat_portable_no_block_spawn in adaint.c. + + -- You should read the operating-system-specific documentation for the + -- above functions, paying special attention to subtle interactions with + -- threading, signals, locks, and file descriptors. Most of the issues are + -- related to the fact that on Unix, there is a window of time between fork + -- and execv; Windows does not have this problem, because spawning is done + -- in a single operation. + + -- On Posix-compliant systems, such as Linux, fork duplicates just the + -- calling thread. (On Solaris, fork1 is the Posix-compliant version of + -- fork.) + + -- You should avoid using signals while spawning. This includes signals + -- used internally by the Ada run-time system, such as timer signals used + -- to implement delay statements. + + -- It is best to spawn any subprocesses very early, before the parent + -- process creates tasks, locks, or installs signal handlers. Certainly + -- avoid doing simultaneous spawns from multiple threads of the same + -- process. + + -- There is no problem spawning a subprocess that uses tasking: the + -- problems are caused only by tasking in the parent. + + -- If the parent is using tasking, and needs to spawn subprocesses at + -- arbitrary times, one technique is for the parent to spawn (very early) + -- a particular spawn-manager subprocess whose job is to spawn other + -- processes. The spawn-manager must avoid tasking. The parent sends + -- messages to the spawn-manager requesting it to spawn processes, using + -- whatever inter-process communication mechanism you like, such as + -- sockets. + + -- In short, mixing spawning of subprocesses with tasking is a tricky + -- business, and should be avoided if possible, but if it is necessary, + -- the above guidelines should be followed, and you should beware of + -- portability problems. + + ------------------- + -- Miscellaneous -- + ------------------- + + function Errno return Integer; + pragma Import (C, Errno, "__get_errno"); + -- Return the task-safe last error number + + function Errno_Message + (Err : Integer := Errno; + Default : String := "") return String; + -- Return a message describing the given Errno value. If none is provided + -- by the system, return Default if not empty, else return a generic + -- message indicating the numeric errno value. + + function Getenv (Name : String) return String_Access; + -- Get the value of the environment variable. Returns an access to the + -- empty string if the environment variable does not exist or has an + -- explicit null value (in some operating systems these are distinct + -- cases, in others they are not; this interface abstracts away that + -- difference. The argument is allocated on the heap (even in the null + -- case), and needs to be freed explicitly when no longer needed to avoid + -- memory leaks. + + procedure OS_Abort; + pragma Import (C, OS_Abort, "abort"); + pragma No_Return (OS_Abort); + -- Exit to OS signalling an abort (traceback or other appropriate + -- diagnostic information should be given if possible, or entry made to + -- the debugger if that is possible). + + procedure OS_Exit (Status : Integer); + pragma No_Return (OS_Exit); + -- Exit to OS with given status code (program is terminated). Note that + -- this is abrupt termination. All tasks are immediately terminated. There + -- are no finalization or other Ada-specific cleanup actions performed. On + -- systems with atexit handlers (such as Unix and Windows), atexit handlers + -- are called. + + type OS_Exit_Subprogram is access procedure (Status : Integer); + + procedure OS_Exit_Default (Status : Integer); + pragma No_Return (OS_Exit_Default); + -- Default implementation of procedure OS_Exit + + OS_Exit_Ptr : OS_Exit_Subprogram := OS_Exit_Default'Access; + -- OS_Exit is implemented through this access value. It it then possible to + -- change the implementation of OS_Exit by redirecting OS_Exit_Ptr to an + -- other implementation. + + procedure Set_Errno (Errno : Integer); + pragma Import (C, Set_Errno, "__set_errno"); + -- Set the task-safe error number + + procedure Setenv (Name : String; Value : String); + -- Set the value of the environment variable Name to Value. This call + -- modifies the current environment, but does not modify the parent + -- process environment. After a call to Setenv, Getenv (Name) will always + -- return a String_Access referencing the same String as Value. This is + -- true also for the null string case (the actual effect may be to either + -- set an explicit null as the value, or to remove the entry, this is + -- operating system dependent). Note that any following calls to Spawn + -- will pass an environment to the spawned process that includes the + -- changes made by Setenv calls. + + Directory_Separator : constant Character; + -- The character that is used to separate parts of a pathname + + Path_Separator : constant Character; + -- The character to separate paths in an environment variable value + +private + pragma Import (C, Path_Separator, "__gnat_path_separator"); + pragma Import (C, Directory_Separator, "__gnat_dir_separator"); + pragma Import (C, Current_Time, "__gnat_current_time"); + pragma Import (C, Current_Process_Id, "__gnat_current_process_id"); + + type OS_Time is + range -(2 ** (Standard'Address_Size - Integer'(1))) .. + +(2 ** (Standard'Address_Size - Integer'(1)) - 1); + -- Type used for timestamps in the compiler. This type is used to hold + -- time stamps, but may have a different representation than C's time_t. + -- This type needs to match the declaration of OS_Time in adaint.h. + + -- Add pragma Inline statements for comparison operations on OS_Time. It + -- would actually be nice to use pragma Import (Intrinsic) here, but this + -- was not properly supported till GNAT 3.15a, so that would cause + -- bootstrap path problems. To be changed later ??? + + Invalid_Time : constant OS_Time := -1; + -- This value should match the return value from __gnat_file_time_* + + pragma Inline ("<"); + pragma Inline (">"); + pragma Inline ("<="); + pragma Inline (">="); + + type Process_Id is new Integer; + Invalid_Pid : constant Process_Id := -1; + +end System.OS_Lib; diff --git a/gcc/ada/libgnat/s-osprim-darwin.adb b/gcc/ada/libgnat/s-osprim-darwin.adb new file mode 100644 index 0000000..b0f5fff --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-darwin.adb @@ -0,0 +1,169 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for darwin + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type struct_timezone is record + tz_minuteswest : Integer; + tz_dsttime : Integer; + end record; + pragma Convention (C, struct_timezone); + type struct_timezone_ptr is access all struct_timezone; + + type time_t is new Long_Integer; + + type struct_timeval is record + tv_sec : time_t; + tv_usec : Integer; + end record; + pragma Convention (C, struct_timeval); + + function gettimeofday + (tv : not null access struct_timeval; + tz : struct_timezone_ptr) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + Result : Integer; + pragma Unreferenced (Result); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, null); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-mingw.adb b/gcc/ada/libgnat/s-osprim-mingw.adb new file mode 100644 index 0000000..d729d85 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-mingw.adb @@ -0,0 +1,413 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the NT version of this package + +with System.Task_Lock; +with System.Win32.Ext; + +package body System.OS_Primitives is + + use System.Task_Lock; + use System.Win32; + use System.Win32.Ext; + + ---------------------------------------- + -- Data for the high resolution clock -- + ---------------------------------------- + + Tick_Frequency : aliased LARGE_INTEGER; + -- Holds frequency of high-performance counter used by Clock + -- Windows NT uses a 1_193_182 Hz counter on PCs. + + Base_Monotonic_Ticks : LARGE_INTEGER; + -- Holds the Tick count for the base monotonic time + + Base_Monotonic_Clock : Duration; + -- Holds the current clock for monotonic clock's base time + + type Clock_Data is record + Base_Ticks : LARGE_INTEGER; + -- Holds the Tick count for the base time + + Base_Time : Long_Long_Integer; + -- Holds the base time used to check for system time change, used with + -- the standard clock. + + Base_Clock : Duration; + -- Holds the current clock for the standard clock's base time + end record; + + type Clock_Data_Access is access all Clock_Data; + + -- Two base clock buffers. This is used to be able to update a buffer while + -- the other buffer is read. The point is that we do not want to use a lock + -- inside the Clock routine for performance reasons. We still use a lock + -- in the Get_Base_Time which is called very rarely. Current is a pointer, + -- the pragma Atomic is there to ensure that the value can be set or read + -- atomically. That's it, when Get_Base_Time has updated a buffer the + -- switch to the new value is done by changing Current pointer. + + First, Second : aliased Clock_Data; + + Current : Clock_Data_Access := First'Access; + pragma Atomic (Current); + + -- The following signature is to detect change on the base clock data + -- above. The signature is a modular type, it will wrap around without + -- raising an exception. We would need to have exactly 2**32 updates of + -- the base data for the changes to get undetected. + + type Signature_Type is mod 2**32; + Signature : Signature_Type := 0; + pragma Atomic (Signature); + + function Monotonic_Clock return Duration; + pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock"); + -- Return "absolute" time, represented as an offset relative to "the Unix + -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is + -- immune to the system's clock changes. Export this function so that it + -- can be imported from s-taprop-mingw.adb without changing the shared + -- spec (s-osprim.ads). + + procedure Get_Base_Time (Data : in out Clock_Data); + -- Retrieve the base time and base ticks. These values will be used by + -- clock to compute the current time by adding to it a fraction of the + -- performance counter. This is for the implementation of a high-resolution + -- clock. Note that this routine does not change the base monotonic values + -- used by the monotonic clock. + + ----------- + -- Clock -- + ----------- + + -- This implementation of clock provides high resolution timer values + -- using QueryPerformanceCounter. This call return a 64 bits values (based + -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182 + -- times per seconds. The call to QueryPerformanceCounter takes 6 + -- microsecs to complete. + + function Clock return Duration is + Max_Shift : constant Duration := 2.0; + Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; + Data : Clock_Data; + Current_Ticks : aliased LARGE_INTEGER; + Elap_Secs_Tick : Duration; + Elap_Secs_Sys : Duration; + Now : aliased Long_Long_Integer; + Sig1, Sig2 : Signature_Type; + + begin + -- Try ten times to get a coherent set of base data. For this we just + -- check that the signature hasn't changed during the copy of the + -- current data. + -- + -- This loop will always be done once if there is no interleaved call + -- to Get_Base_Time. + + for K in 1 .. 10 loop + Sig1 := Signature; + Data := Current.all; + Sig2 := Signature; + exit when Sig1 = Sig2; + end loop; + + if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then + return 0.0; + end if; + + GetSystemTimeAsFileTime (Now'Access); + + Elap_Secs_Sys := + Duration (Long_Long_Float (abs (Now - Data.Base_Time)) / + Hundreds_Nano_In_Sec); + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / + Long_Long_Float (Tick_Frequency)); + + -- If we have a shift of more than Max_Shift seconds we resynchronize + -- the Clock. This is probably due to a manual Clock adjustment, a DST + -- adjustment or an NTP synchronisation. And we want to adjust the time + -- for this system (non-monotonic) clock. + + if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then + Get_Base_Time (Data); + + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / + Long_Long_Float (Tick_Frequency)); + end if; + + return Data.Base_Clock + Elap_Secs_Tick; + end Clock; + + ------------------- + -- Get_Base_Time -- + ------------------- + + procedure Get_Base_Time (Data : in out Clock_Data) is + + -- The resolution for GetSystemTime is 1 millisecond + + -- The time to get both base times should take less than 1 millisecond. + -- Therefore, the elapsed time reported by GetSystemTime between both + -- actions should be null. + + epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch + system_time_ns : constant := 100; -- 100 ns per tick + Sec_Unit : constant := 10#1#E9; + + Max_Elapsed : constant LARGE_INTEGER := + LARGE_INTEGER (Tick_Frequency / 100_000); + -- Look for a precision of 0.01 ms + + Sig : constant Signature_Type := Signature; + + Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER; + Loc_Time, Ctrl_Time : aliased Long_Long_Integer; + Elapsed : LARGE_INTEGER; + Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last; + New_Data : Clock_Data_Access; + + begin + -- Here we must be sure that both of these calls are done in a short + -- amount of time. Both are base time and should in theory be taken + -- at the very same time. + + -- The goal of the following loop is to synchronize the system time + -- with the Win32 performance counter by getting a base offset for both. + -- Using these offsets it is then possible to compute actual time using + -- a performance counter which has a better precision than the Win32 + -- time API. + + -- Try at most 10 times to reach the best synchronisation (below 1 + -- millisecond) otherwise the runtime will use the best value reached + -- during the runs. + + Lock; + + -- First check that the current value has not been updated. This + -- could happen if another task has called Clock at the same time + -- and that Max_Shift has been reached too. + -- + -- But if the current value has been changed just before we entered + -- into the critical section, we can safely return as the current + -- base data (time, clock, ticks) have already been updated. + + if Sig /= Signature then + Unlock; + return; + end if; + + -- Check for the unused data buffer and set New_Data to point to it + + if Current = First'Access then + New_Data := Second'Access; + else + New_Data := First'Access; + end if; + + for K in 1 .. 10 loop + if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then + pragma Assert + (Standard.False, + "Could not query high performance counter in Clock"); + null; + end if; + + GetSystemTimeAsFileTime (Ctrl_Time'Access); + + -- Scan for clock tick, will take up to 16ms/1ms depending on PC. + -- This cannot be an infinite loop or the system hardware is badly + -- damaged. + + loop + GetSystemTimeAsFileTime (Loc_Time'Access); + + if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then + pragma Assert + (Standard.False, + "Could not query high performance counter in Clock"); + null; + end if; + + exit when Loc_Time /= Ctrl_Time; + Loc_Ticks := Ctrl_Ticks; + end loop; + + -- Check elapsed Performance Counter between samples + -- to choose the best one. + + Elapsed := Ctrl_Ticks - Loc_Ticks; + + if Elapsed < Current_Max then + New_Data.Base_Time := Loc_Time; + New_Data.Base_Ticks := Loc_Ticks; + Current_Max := Elapsed; + + -- Exit the loop when we have reached the expected precision + + exit when Elapsed <= Max_Elapsed; + end if; + end loop; + + New_Data.Base_Clock := + Duration + (Long_Long_Float + ((New_Data.Base_Time - epoch_1970) * system_time_ns) / + Long_Long_Float (Sec_Unit)); + + -- At this point all the base values have been set into the new data + -- record. Change the pointer (atomic operation) to these new values. + + Current := New_Data; + Data := New_Data.all; + + -- Set new signature for this data set + + Signature := Signature + 1; + + Unlock; + + exception + when others => + Unlock; + raise; + end Get_Base_Time; + + --------------------- + -- Monotonic_Clock -- + --------------------- + + function Monotonic_Clock return Duration is + Current_Ticks : aliased LARGE_INTEGER; + Elap_Secs_Tick : Duration; + + begin + if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then + return 0.0; + + else + Elap_Secs_Tick := + Duration (Long_Long_Float (Current_Ticks - Base_Monotonic_Ticks) / + Long_Long_Float (Tick_Frequency)); + return Base_Monotonic_Clock + Elap_Secs_Tick; + end if; + end Monotonic_Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay (Time : Duration; Mode : Integer) is + function Mode_Clock return Duration; + pragma Inline (Mode_Clock); + -- Return the current clock value using either the monotonic clock or + -- standard clock depending on the Mode value. + + ---------------- + -- Mode_Clock -- + ---------------- + + function Mode_Clock return Duration is + begin + case Mode is + when Absolute_RT => return Monotonic_Clock; + when others => return Clock; + end case; + end Mode_Clock; + + -- Local Variables + + Base_Time : constant Duration := Mode_Clock; + -- Base_Time is used to detect clock set backward, in this case we + -- cannot ensure the delay accuracy. + + Rel_Time : Duration; + Abs_Time : Duration; + Check_Time : Duration := Base_Time; + + -- Start of processing for Timed Delay + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Sleep (DWORD (Rel_Time * 1000.0)); + Check_Time := Mode_Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + Initialized : Boolean := False; + + procedure Initialize is + begin + if Initialized then + return; + end if; + + Initialized := True; + + -- Get starting time as base + + if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then + raise Program_Error with + "cannot get high performance counter frequency"; + end if; + + Get_Base_Time (Current.all); + + -- Keep base clock and ticks for the monotonic clock. These values + -- should never be changed to ensure proper behavior of the monotonic + -- clock. + + Base_Monotonic_Clock := Current.Base_Clock; + Base_Monotonic_Ticks := Current.Base_Ticks; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-posix.adb b/gcc/ada/libgnat/s-osprim-posix.adb new file mode 100644 index 0000000..8911b16 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-posix.adb @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for POSIX-like operating systems + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type time_t is new Long_Integer; + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + + type timeval is array (1 .. 3) of Long_Integer; + -- The timeval array is sized to contain Long_Long_Integer sec and + -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then + -- it will be overly large but that will not effect the implementation + -- since it is not accessed directly. + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access Long_Long_Integer; + usec : not null access Long_Integer); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased Long_Long_Integer; + usec : aliased Long_Integer; + TV : aliased timeval; + Result : Integer; + pragma Unreferenced (Result); + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, System.Null_Address); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-posix2008.adb b/gcc/ada/libgnat/s-osprim-posix2008.adb new file mode 100644 index 0000000..dd977a8 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-posix2008.adb @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for POSIX.1-2008-like operating systems + +with System.CRTL; +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface because + -- we don't want to depend on any package. Consider removing these + -- declarations in System.OS_Interface and move these ones to the spec. + + type time_t is new System.CRTL.int64; + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + + type timeval is array (1 .. 3) of Long_Integer; + -- The timeval array is sized to contain Long_Long_Integer sec and + -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then + -- it will be overly large but that will not effect the implementation + -- since it is not accessed directly. + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access Long_Long_Integer; + usec : not null access Long_Integer); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased Long_Long_Integer; + usec : aliased Long_Integer; + TV : aliased timeval; + Result : Integer; + pragma Unreferenced (Result); + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, System.Null_Address); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9))); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-solaris.adb b/gcc/ada/libgnat/s-osprim-solaris.adb new file mode 100644 index 0000000..c1c7e75 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-solaris.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version uses gettimeofday and select +-- This file is suitable for Solaris (32 and 64 bits). + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type struct_timeval is record + tv_sec : Long_Integer; + tv_usec : Long_Integer; + end record; + pragma Convention (C, struct_timeval); + + procedure gettimeofday + (tv : not null access struct_timeval; + tz : Address := Null_Address); + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure C_select + (n : Integer := 0; + readfds, + writefds, + exceptfds : Address := Null_Address; + timeout : not null access struct_timeval); + pragma Import (C, C_select, "select"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + begin + gettimeofday (TV'Access); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + timeval : aliased struct_timeval; + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + timeval.tv_sec := Long_Integer (Rel_Time); + + if Duration (timeval.tv_sec) > Rel_Time then + timeval.tv_sec := timeval.tv_sec - 1; + end if; + + timeval.tv_usec := + Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); + + C_select (timeout => timeval'Unchecked_Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-unix.adb b/gcc/ada/libgnat/s-osprim-unix.adb new file mode 100644 index 0000000..f273df6 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-unix.adb @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version uses gettimeofday and select +-- This file is suitable for OpenNT, Dec Unix and SCO UnixWare. + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type struct_timeval is record + tv_sec : Integer; + tv_usec : Integer; + end record; + pragma Convention (C, struct_timeval); + + procedure gettimeofday + (tv : not null access struct_timeval; + tz : Address := Null_Address); + pragma Import (C, gettimeofday, "gettimeofday"); + + procedure C_select + (n : Integer := 0; + readfds, + writefds, + exceptfds : Address := Null_Address; + timeout : not null access struct_timeval); + pragma Import (C, C_select, "select"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TV : aliased struct_timeval; + + begin + gettimeofday (TV'Access); + return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; + end Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + timeval : aliased struct_timeval; + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + timeval.tv_sec := Integer (Rel_Time); + + if Duration (timeval.tv_sec) > Rel_Time then + timeval.tv_sec := timeval.tv_sec - 1; + end if; + + timeval.tv_usec := + Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); + + C_select (timeout => timeval'Unchecked_Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-vxworks.adb b/gcc/ada/libgnat/s-osprim-vxworks.adb new file mode 100644 index 0000000..2fa6cfe --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-vxworks.adb @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for VxWorks targets + +with System.OS_Interface; +-- Since the thread library is part of the VxWorks kernel, using OS_Interface +-- is not a problem here, as long as we only use System.OS_Interface as a +-- set of C imported routines: using Ada routines from this package would +-- create a dependency on libgnarl in libgnat, which is not desirable. + +with System.OS_Constants; +with Interfaces.C; + +package body System.OS_Primitives is + + use System.OS_Interface; + use type Interfaces.C.int; + + package OSC renames System.OS_Constants; + + ------------------------ + -- Internal functions -- + ------------------------ + + function To_Clock_Ticks (D : Duration) return int; + -- Convert a duration value (in seconds) into clock ticks. + -- Note that this routine is duplicated from System.OS_Interface since + -- as explained above, we do not want to depend on libgnarl + + function To_Clock_Ticks (D : Duration) return int is + Ticks : Long_Long_Integer; + Rate_Duration : Duration; + Ticks_Duration : Duration; + + begin + if D < 0.0 then + return -1; + end if; + + -- Ensure that the duration can be converted to ticks + -- at the current clock tick rate without overflowing. + + Rate_Duration := Duration (sysClkRateGet); + + if D > (Duration'Last / Rate_Duration) then + Ticks := Long_Long_Integer (int'Last); + else + Ticks_Duration := D * Rate_Duration; + Ticks := Long_Long_Integer (Ticks_Duration); + + if Ticks_Duration > Duration (Ticks) then + Ticks := Ticks + 1; + end if; + + if Ticks > Long_Long_Integer (int'Last) then + Ticks := Long_Long_Integer (int'Last); + end if; + end if; + + return int (Ticks); + end To_Clock_Ticks; + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + TS : aliased timespec; + Result : int; + begin + Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); + pragma Assert (Result = 0); + return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; + end Clock; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + Ticks : int; + + Result : int; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Ticks := To_Clock_Ticks (Rel_Time); + + if Mode = Relative and then Ticks < int'Last then + -- The first tick will delay anytime between 0 and + -- 1 / sysClkRateGet seconds, so we need to add one to + -- be on the safe side. + + Ticks := Ticks + 1; + end if; + + Result := taskDelay (Ticks); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim-x32.adb b/gcc/ada/libgnat/s-osprim-x32.adb new file mode 100644 index 0000000..809e163 --- /dev/null +++ b/gcc/ada/libgnat/s-osprim-x32.adb @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2013-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version is for Linux/x32 + +package body System.OS_Primitives is + + -- ??? These definitions are duplicated from System.OS_Interface + -- because we don't want to depend on any package. Consider removing + -- these declarations in System.OS_Interface and move these ones in + -- the spec. + + type time_t is new Long_Long_Integer; + + type timespec is record + tv_sec : time_t; + tv_nsec : Long_Long_Integer; + end record; + pragma Convention (C, timespec); + + function nanosleep (rqtp, rmtp : not null access timespec) return Integer; + pragma Import (C, nanosleep, "nanosleep"); + + ----------- + -- Clock -- + ----------- + + function Clock return Duration is + type timeval is array (1 .. 2) of Long_Long_Integer; + + procedure timeval_to_duration + (T : not null access timeval; + sec : not null access Long_Integer; + usec : not null access Long_Integer); + pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); + + Micro : constant := 10**6; + sec : aliased Long_Integer; + usec : aliased Long_Integer; + TV : aliased timeval; + Result : Integer; + pragma Unreferenced (Result); + + function gettimeofday + (Tv : access timeval; + Tz : System.Address := System.Null_Address) return Integer; + pragma Import (C, gettimeofday, "gettimeofday"); + + begin + -- The return codes for gettimeofday are as follows (from man pages): + -- EPERM settimeofday is called by someone other than the superuser + -- EINVAL Timezone (or something else) is invalid + -- EFAULT One of tv or tz pointed outside accessible address space + + -- None of these codes signal a potential clock skew, hence the return + -- value is never checked. + + Result := gettimeofday (TV'Access, System.Null_Address); + timeval_to_duration (TV'Access, sec'Access, usec'Access); + return Duration (sec) + Duration (usec) / Micro; + end Clock; + + ----------------- + -- To_Timespec -- + ----------------- + + function To_Timespec (D : Duration) return 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_Integer (F * 10#1#E9)); + end To_Timespec; + + ----------------- + -- Timed_Delay -- + ----------------- + + procedure Timed_Delay + (Time : Duration; + Mode : Integer) + is + Request : aliased timespec; + Remaind : aliased timespec; + Rel_Time : Duration; + Abs_Time : Duration; + Base_Time : constant Duration := Clock; + Check_Time : Duration := Base_Time; + + Result : Integer; + pragma Unreferenced (Result); + + begin + if Mode = Relative then + Rel_Time := Time; + Abs_Time := Time + Check_Time; + else + Rel_Time := Time - Check_Time; + Abs_Time := Time; + end if; + + if Rel_Time > 0.0 then + loop + Request := To_Timespec (Rel_Time); + Result := nanosleep (Request'Access, Remaind'Access); + Check_Time := Clock; + + exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; + + Rel_Time := Abs_Time - Check_Time; + end loop; + end if; + end Timed_Delay; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + begin + null; + end Initialize; + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-osprim.ads b/gcc/ada/libgnat/s-osprim.ads new file mode 100644 index 0000000..074a92d --- /dev/null +++ b/gcc/ada/libgnat/s-osprim.ads @@ -0,0 +1,85 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . O S _ P R I M I T I V E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides low level primitives used to implement clock and +-- delays in non tasking applications. + +-- The choice of the real clock/delay implementation (depending on whether +-- tasking is involved or not) is done via soft links (see s-soflin.ads) + +-- NEVER add any dependency to tasking packages here + +package System.OS_Primitives is + pragma Preelaborate; + + Max_Sensible_Delay : constant Duration := + Duration'Min (183 * 24 * 60 * 60.0, + Duration'Last); + -- Max of half a year delay, needed to prevent exceptions for large delay + -- values. It seems unlikely that any test will notice this restriction, + -- except in the case of applications setting the clock at run time (see + -- s-tastim.adb). Also note that a larger value might cause problems (e.g + -- overflow, or more likely OS limitation in the primitives used). In the + -- case where half a year is too long (which occurs in high integrity mode + -- with 32-bit words, and possibly on some specific ports of GNAT), + -- Duration'Last is used instead. + + procedure Initialize; + -- Initialize global settings related to this package. This procedure + -- should be called before any other subprograms in this package. Note + -- that this procedure can be called several times. + + function Clock return Duration; + pragma Inline (Clock); + -- Returns "absolute" time, represented as an offset relative to "the + -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This + -- implementation is affected by system's clock changes. + + Relative : constant := 0; + Absolute_Calendar : constant := 1; + Absolute_RT : constant := 2; + -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies + -- on these values. So any change here must be reflected in corresponding + -- changes in the compiler. + + procedure Timed_Delay (Time : Duration; Mode : Integer); + -- Implements the semantics of the delay statement when no tasking is used + -- in the application. + -- + -- Mode is one of the three values above + -- + -- Time is a relative or absolute duration value, depending on Mode. + -- + -- Note that currently Ada.Real_Time always uses the tasking run time, + -- so this procedure should never be called with Mode set to Absolute_RT. + -- This may change in future or bare board implementations. + +end System.OS_Primitives; diff --git a/gcc/ada/libgnat/s-pack03.adb b/gcc/ada/libgnat/s-pack03.adb new file mode 100644 index 0000000..c31381c --- /dev/null +++ b/gcc/ada/libgnat/s-pack03.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_03 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_03; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_03 -- + ------------ + + function Get_03 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_03 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_03; + + ------------ + -- Set_03 -- + ------------ + + procedure Set_03 + (Arr : System.Address; + N : Natural; + E : Bits_03; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_03; + +end System.Pack_03; diff --git a/gcc/ada/libgnat/s-pack03.ads b/gcc/ada/libgnat/s-pack03.ads new file mode 100644 index 0000000..4dbe904 --- /dev/null +++ b/gcc/ada/libgnat/s-pack03.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 3 + +package System.Pack_03 is + pragma Preelaborate; + + Bits : constant := 3; + + type Bits_03 is mod 2 ** Bits; + for Bits_03'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_03 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_03 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_03 + (Arr : System.Address; + N : Natural; + E : Bits_03; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_03; diff --git a/gcc/ada/libgnat/s-pack05.adb b/gcc/ada/libgnat/s-pack05.adb new file mode 100644 index 0000000..d262bdd --- /dev/null +++ b/gcc/ada/libgnat/s-pack05.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_05 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_05; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_05 -- + ------------ + + function Get_05 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_05 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_05; + + ------------ + -- Set_05 -- + ------------ + + procedure Set_05 + (Arr : System.Address; + N : Natural; + E : Bits_05; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_05; + +end System.Pack_05; diff --git a/gcc/ada/libgnat/s-pack05.ads b/gcc/ada/libgnat/s-pack05.ads new file mode 100644 index 0000000..b22796e --- /dev/null +++ b/gcc/ada/libgnat/s-pack05.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 5 + +package System.Pack_05 is + pragma Preelaborate; + + Bits : constant := 5; + + type Bits_05 is mod 2 ** Bits; + for Bits_05'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_05 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_05 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_05 + (Arr : System.Address; + N : Natural; + E : Bits_05; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_05; diff --git a/gcc/ada/libgnat/s-pack06.adb b/gcc/ada/libgnat/s-pack06.adb new file mode 100644 index 0000000..f7211e3 --- /dev/null +++ b/gcc/ada/libgnat/s-pack06.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_06 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_06; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_06 or SetU_06 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_06 -- + ------------ + + function Get_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_06; + + ------------- + -- GetU_06 -- + ------------- + + function GetU_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_06; + + ------------ + -- Set_06 -- + ------------ + + procedure Set_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_06; + + ------------- + -- SetU_06 -- + ------------- + + procedure SetU_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_06; + +end System.Pack_06; diff --git a/gcc/ada/libgnat/s-pack06.ads b/gcc/ada/libgnat/s-pack06.ads new file mode 100644 index 0000000..92e5793 --- /dev/null +++ b/gcc/ada/libgnat/s-pack06.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 6 + +package System.Pack_06 is + pragma Preelaborate; + + Bits : constant := 6; + + type Bits_06 is mod 2 ** Bits; + for Bits_06'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_06 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_06 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_06 + (Arr : System.Address; + N : Natural; + E : Bits_06; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_06; diff --git a/gcc/ada/libgnat/s-pack07.adb b/gcc/ada/libgnat/s-pack07.adb new file mode 100644 index 0000000..ec5b806 --- /dev/null +++ b/gcc/ada/libgnat/s-pack07.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_07 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_07; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_07 -- + ------------ + + function Get_07 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_07 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_07; + + ------------ + -- Set_07 -- + ------------ + + procedure Set_07 + (Arr : System.Address; + N : Natural; + E : Bits_07; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_07; + +end System.Pack_07; diff --git a/gcc/ada/libgnat/s-pack07.ads b/gcc/ada/libgnat/s-pack07.ads new file mode 100644 index 0000000..b907c98 --- /dev/null +++ b/gcc/ada/libgnat/s-pack07.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 7 + +package System.Pack_07 is + pragma Preelaborate; + + Bits : constant := 7; + + type Bits_07 is mod 2 ** Bits; + for Bits_07'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_07 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_07 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_07 + (Arr : System.Address; + N : Natural; + E : Bits_07; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_07; diff --git a/gcc/ada/libgnat/s-pack09.adb b/gcc/ada/libgnat/s-pack09.adb new file mode 100644 index 0000000..3a605d2 --- /dev/null +++ b/gcc/ada/libgnat/s-pack09.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_09 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_09; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_09 -- + ------------ + + function Get_09 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_09 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_09; + + ------------ + -- Set_09 -- + ------------ + + procedure Set_09 + (Arr : System.Address; + N : Natural; + E : Bits_09; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_09; + +end System.Pack_09; diff --git a/gcc/ada/libgnat/s-pack09.ads b/gcc/ada/libgnat/s-pack09.ads new file mode 100644 index 0000000..faa061f --- /dev/null +++ b/gcc/ada/libgnat/s-pack09.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 0 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 9 + +package System.Pack_09 is + pragma Preelaborate; + + Bits : constant := 9; + + type Bits_09 is mod 2 ** Bits; + for Bits_09'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_09 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_09 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_09 + (Arr : System.Address; + N : Natural; + E : Bits_09; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_09; diff --git a/gcc/ada/libgnat/s-pack10.adb b/gcc/ada/libgnat/s-pack10.adb new file mode 100644 index 0000000..1fc22a6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack10.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_10 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_10; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_10 or SetU_10 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_10 -- + ------------ + + function Get_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_10; + + ------------- + -- GetU_10 -- + ------------- + + function GetU_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_10; + + ------------ + -- Set_10 -- + ------------ + + procedure Set_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_10; + + ------------- + -- SetU_10 -- + ------------- + + procedure SetU_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_10; + +end System.Pack_10; diff --git a/gcc/ada/libgnat/s-pack10.ads b/gcc/ada/libgnat/s-pack10.ads new file mode 100644 index 0000000..2382fd6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack10.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 10 + +package System.Pack_10 is + pragma Preelaborate; + + Bits : constant := 10; + + type Bits_10 is mod 2 ** Bits; + for Bits_10'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_10 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_10 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_10 + (Arr : System.Address; + N : Natural; + E : Bits_10; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_10; diff --git a/gcc/ada/libgnat/s-pack11.adb b/gcc/ada/libgnat/s-pack11.adb new file mode 100644 index 0000000..5be409b --- /dev/null +++ b/gcc/ada/libgnat/s-pack11.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_11 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_11; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_11 -- + ------------ + + function Get_11 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_11 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_11; + + ------------ + -- Set_11 -- + ------------ + + procedure Set_11 + (Arr : System.Address; + N : Natural; + E : Bits_11; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_11; + +end System.Pack_11; diff --git a/gcc/ada/libgnat/s-pack11.ads b/gcc/ada/libgnat/s-pack11.ads new file mode 100644 index 0000000..f759a70 --- /dev/null +++ b/gcc/ada/libgnat/s-pack11.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 11 + +package System.Pack_11 is + pragma Preelaborate; + + Bits : constant := 11; + + type Bits_11 is mod 2 ** Bits; + for Bits_11'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_11 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_11 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_11 + (Arr : System.Address; + N : Natural; + E : Bits_11; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_11; diff --git a/gcc/ada/libgnat/s-pack12.adb b/gcc/ada/libgnat/s-pack12.adb new file mode 100644 index 0000000..a5f9f86 --- /dev/null +++ b/gcc/ada/libgnat/s-pack12.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_12 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_12; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_12 or SetU_12 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_12 -- + ------------ + + function Get_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_12; + + ------------- + -- GetU_12 -- + ------------- + + function GetU_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_12; + + ------------ + -- Set_12 -- + ------------ + + procedure Set_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_12; + + ------------- + -- SetU_12 -- + ------------- + + procedure SetU_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_12; + +end System.Pack_12; diff --git a/gcc/ada/libgnat/s-pack12.ads b/gcc/ada/libgnat/s-pack12.ads new file mode 100644 index 0000000..75e733a --- /dev/null +++ b/gcc/ada/libgnat/s-pack12.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 12 + +package System.Pack_12 is + pragma Preelaborate; + + Bits : constant := 12; + + type Bits_12 is mod 2 ** Bits; + for Bits_12'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_12 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_12 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_12 + (Arr : System.Address; + N : Natural; + E : Bits_12; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_12; diff --git a/gcc/ada/libgnat/s-pack13.adb b/gcc/ada/libgnat/s-pack13.adb new file mode 100644 index 0000000..7698fb2 --- /dev/null +++ b/gcc/ada/libgnat/s-pack13.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_13 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_13; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_13 -- + ------------ + + function Get_13 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_13 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_13; + + ------------ + -- Set_13 -- + ------------ + + procedure Set_13 + (Arr : System.Address; + N : Natural; + E : Bits_13; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_13; + +end System.Pack_13; diff --git a/gcc/ada/libgnat/s-pack13.ads b/gcc/ada/libgnat/s-pack13.ads new file mode 100644 index 0000000..ec2ae9d0 --- /dev/null +++ b/gcc/ada/libgnat/s-pack13.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 13 + +package System.Pack_13 is + pragma Preelaborate; + + Bits : constant := 13; + + type Bits_13 is mod 2 ** Bits; + for Bits_13'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_13 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_13 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_13 + (Arr : System.Address; + N : Natural; + E : Bits_13; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_13; diff --git a/gcc/ada/libgnat/s-pack14.adb b/gcc/ada/libgnat/s-pack14.adb new file mode 100644 index 0000000..4594fb3 --- /dev/null +++ b/gcc/ada/libgnat/s-pack14.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_14 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_14; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_14 or SetU_14 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_14 -- + ------------ + + function Get_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_14; + + ------------- + -- GetU_14 -- + ------------- + + function GetU_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_14; + + ------------ + -- Set_14 -- + ------------ + + procedure Set_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_14; + + ------------- + -- SetU_14 -- + ------------- + + procedure SetU_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_14; + +end System.Pack_14; diff --git a/gcc/ada/libgnat/s-pack14.ads b/gcc/ada/libgnat/s-pack14.ads new file mode 100644 index 0000000..ac172c9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack14.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 14 + +package System.Pack_14 is + pragma Preelaborate; + + Bits : constant := 14; + + type Bits_14 is mod 2 ** Bits; + for Bits_14'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_14 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_14 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_14 + (Arr : System.Address; + N : Natural; + E : Bits_14; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_14; diff --git a/gcc/ada/libgnat/s-pack15.adb b/gcc/ada/libgnat/s-pack15.adb new file mode 100644 index 0000000..151c227 --- /dev/null +++ b/gcc/ada/libgnat/s-pack15.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_15 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_15; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_15 -- + ------------ + + function Get_15 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_15 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_15; + + ------------ + -- Set_15 -- + ------------ + + procedure Set_15 + (Arr : System.Address; + N : Natural; + E : Bits_15; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_15; + +end System.Pack_15; diff --git a/gcc/ada/libgnat/s-pack15.ads b/gcc/ada/libgnat/s-pack15.ads new file mode 100644 index 0000000..b38230b --- /dev/null +++ b/gcc/ada/libgnat/s-pack15.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 15 + +package System.Pack_15 is + pragma Preelaborate; + + Bits : constant := 15; + + type Bits_15 is mod 2 ** Bits; + for Bits_15'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_15 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_15 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_15 + (Arr : System.Address; + N : Natural; + E : Bits_15; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_15; diff --git a/gcc/ada/libgnat/s-pack17.adb b/gcc/ada/libgnat/s-pack17.adb new file mode 100644 index 0000000..d761f84 --- /dev/null +++ b/gcc/ada/libgnat/s-pack17.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_17 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_17; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_17 -- + ------------ + + function Get_17 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_17 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_17; + + ------------ + -- Set_17 -- + ------------ + + procedure Set_17 + (Arr : System.Address; + N : Natural; + E : Bits_17; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_17; + +end System.Pack_17; diff --git a/gcc/ada/libgnat/s-pack17.ads b/gcc/ada/libgnat/s-pack17.ads new file mode 100644 index 0000000..f7d9a49 --- /dev/null +++ b/gcc/ada/libgnat/s-pack17.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 17 + +package System.Pack_17 is + pragma Preelaborate; + + Bits : constant := 17; + + type Bits_17 is mod 2 ** Bits; + for Bits_17'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_17 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_17 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_17 + (Arr : System.Address; + N : Natural; + E : Bits_17; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_17; diff --git a/gcc/ada/libgnat/s-pack18.adb b/gcc/ada/libgnat/s-pack18.adb new file mode 100644 index 0000000..a6ca62b --- /dev/null +++ b/gcc/ada/libgnat/s-pack18.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_18 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_18; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_18 or SetU_18 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_18 -- + ------------ + + function Get_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_18; + + ------------- + -- GetU_18 -- + ------------- + + function GetU_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_18; + + ------------ + -- Set_18 -- + ------------ + + procedure Set_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_18; + + ------------- + -- SetU_18 -- + ------------- + + procedure SetU_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_18; + +end System.Pack_18; diff --git a/gcc/ada/libgnat/s-pack18.ads b/gcc/ada/libgnat/s-pack18.ads new file mode 100644 index 0000000..7eabf52 --- /dev/null +++ b/gcc/ada/libgnat/s-pack18.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 18 + +package System.Pack_18 is + pragma Preelaborate; + + Bits : constant := 18; + + type Bits_18 is mod 2 ** Bits; + for Bits_18'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_18 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_18 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_18 + (Arr : System.Address; + N : Natural; + E : Bits_18; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_18; diff --git a/gcc/ada/libgnat/s-pack19.adb b/gcc/ada/libgnat/s-pack19.adb new file mode 100644 index 0000000..35913b4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack19.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_19 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_19; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_19 -- + ------------ + + function Get_19 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_19 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_19; + + ------------ + -- Set_19 -- + ------------ + + procedure Set_19 + (Arr : System.Address; + N : Natural; + E : Bits_19; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_19; + +end System.Pack_19; diff --git a/gcc/ada/libgnat/s-pack19.ads b/gcc/ada/libgnat/s-pack19.ads new file mode 100644 index 0000000..5801fb2 --- /dev/null +++ b/gcc/ada/libgnat/s-pack19.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 1 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 19 + +package System.Pack_19 is + pragma Preelaborate; + + Bits : constant := 19; + + type Bits_19 is mod 2 ** Bits; + for Bits_19'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_19 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_19 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_19 + (Arr : System.Address; + N : Natural; + E : Bits_19; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_19; diff --git a/gcc/ada/libgnat/s-pack20.adb b/gcc/ada/libgnat/s-pack20.adb new file mode 100644 index 0000000..b3f7b0b --- /dev/null +++ b/gcc/ada/libgnat/s-pack20.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_20 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_20; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_20 or SetU_20 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_20 -- + ------------ + + function Get_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_20; + + ------------- + -- GetU_20 -- + ------------- + + function GetU_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_20; + + ------------ + -- Set_20 -- + ------------ + + procedure Set_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_20; + + ------------- + -- SetU_20 -- + ------------- + + procedure SetU_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_20; + +end System.Pack_20; diff --git a/gcc/ada/libgnat/s-pack20.ads b/gcc/ada/libgnat/s-pack20.ads new file mode 100644 index 0000000..cfcf13b --- /dev/null +++ b/gcc/ada/libgnat/s-pack20.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 20 + +package System.Pack_20 is + pragma Preelaborate; + + Bits : constant := 20; + + type Bits_20 is mod 2 ** Bits; + for Bits_20'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_20 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_20 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_20 + (Arr : System.Address; + N : Natural; + E : Bits_20; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_20; diff --git a/gcc/ada/libgnat/s-pack21.adb b/gcc/ada/libgnat/s-pack21.adb new file mode 100644 index 0000000..067c4de --- /dev/null +++ b/gcc/ada/libgnat/s-pack21.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_21 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_21; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_21 -- + ------------ + + function Get_21 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_21 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_21; + + ------------ + -- Set_21 -- + ------------ + + procedure Set_21 + (Arr : System.Address; + N : Natural; + E : Bits_21; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_21; + +end System.Pack_21; diff --git a/gcc/ada/libgnat/s-pack21.ads b/gcc/ada/libgnat/s-pack21.ads new file mode 100644 index 0000000..4958e88 --- /dev/null +++ b/gcc/ada/libgnat/s-pack21.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 21 + +package System.Pack_21 is + pragma Preelaborate; + + Bits : constant := 21; + + type Bits_21 is mod 2 ** Bits; + for Bits_21'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_21 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_21 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_21 + (Arr : System.Address; + N : Natural; + E : Bits_21; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_21; diff --git a/gcc/ada/libgnat/s-pack22.adb b/gcc/ada/libgnat/s-pack22.adb new file mode 100644 index 0000000..c7816fc --- /dev/null +++ b/gcc/ada/libgnat/s-pack22.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_22 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_22; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_22 or SetU_22 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_22 -- + ------------ + + function Get_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_22; + + ------------- + -- GetU_22 -- + ------------- + + function GetU_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_22; + + ------------ + -- Set_22 -- + ------------ + + procedure Set_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_22; + + ------------- + -- SetU_22 -- + ------------- + + procedure SetU_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_22; + +end System.Pack_22; diff --git a/gcc/ada/libgnat/s-pack22.ads b/gcc/ada/libgnat/s-pack22.ads new file mode 100644 index 0000000..8a080be --- /dev/null +++ b/gcc/ada/libgnat/s-pack22.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 22 + +package System.Pack_22 is + pragma Preelaborate; + + Bits : constant := 22; + + type Bits_22 is mod 2 ** Bits; + for Bits_22'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_22 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_22 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_22 + (Arr : System.Address; + N : Natural; + E : Bits_22; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_22; diff --git a/gcc/ada/libgnat/s-pack23.adb b/gcc/ada/libgnat/s-pack23.adb new file mode 100644 index 0000000..9cb6e5b --- /dev/null +++ b/gcc/ada/libgnat/s-pack23.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_23 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_23; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_23 -- + ------------ + + function Get_23 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_23 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_23; + + ------------ + -- Set_23 -- + ------------ + + procedure Set_23 + (Arr : System.Address; + N : Natural; + E : Bits_23; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_23; + +end System.Pack_23; diff --git a/gcc/ada/libgnat/s-pack23.ads b/gcc/ada/libgnat/s-pack23.ads new file mode 100644 index 0000000..b993f54 --- /dev/null +++ b/gcc/ada/libgnat/s-pack23.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 23 + +package System.Pack_23 is + pragma Preelaborate; + + Bits : constant := 23; + + type Bits_23 is mod 2 ** Bits; + for Bits_23'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_23 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_23 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_23 + (Arr : System.Address; + N : Natural; + E : Bits_23; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_23; diff --git a/gcc/ada/libgnat/s-pack24.adb b/gcc/ada/libgnat/s-pack24.adb new file mode 100644 index 0000000..be006a9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack24.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_24 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_24; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_24 or SetU_24 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_24 -- + ------------ + + function Get_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_24; + + ------------- + -- GetU_24 -- + ------------- + + function GetU_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_24; + + ------------ + -- Set_24 -- + ------------ + + procedure Set_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_24; + + ------------- + -- SetU_24 -- + ------------- + + procedure SetU_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_24; + +end System.Pack_24; diff --git a/gcc/ada/libgnat/s-pack24.ads b/gcc/ada/libgnat/s-pack24.ads new file mode 100644 index 0000000..c5da2ab7 --- /dev/null +++ b/gcc/ada/libgnat/s-pack24.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 24 + +package System.Pack_24 is + pragma Preelaborate; + + Bits : constant := 24; + + type Bits_24 is mod 2 ** Bits; + for Bits_24'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_24 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_24 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_24 + (Arr : System.Address; + N : Natural; + E : Bits_24; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_24; diff --git a/gcc/ada/libgnat/s-pack25.adb b/gcc/ada/libgnat/s-pack25.adb new file mode 100644 index 0000000..e22472f --- /dev/null +++ b/gcc/ada/libgnat/s-pack25.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_25 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_25; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_25 -- + ------------ + + function Get_25 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_25 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_25; + + ------------ + -- Set_25 -- + ------------ + + procedure Set_25 + (Arr : System.Address; + N : Natural; + E : Bits_25; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_25; + +end System.Pack_25; diff --git a/gcc/ada/libgnat/s-pack25.ads b/gcc/ada/libgnat/s-pack25.ads new file mode 100644 index 0000000..b915fb3 --- /dev/null +++ b/gcc/ada/libgnat/s-pack25.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 25 + +package System.Pack_25 is + pragma Preelaborate; + + Bits : constant := 25; + + type Bits_25 is mod 2 ** Bits; + for Bits_25'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_25 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_25 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_25 + (Arr : System.Address; + N : Natural; + E : Bits_25; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_25; diff --git a/gcc/ada/libgnat/s-pack26.adb b/gcc/ada/libgnat/s-pack26.adb new file mode 100644 index 0000000..c4b4542 --- /dev/null +++ b/gcc/ada/libgnat/s-pack26.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_26 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_26; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_26 or SetU_26 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_26 -- + ------------ + + function Get_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_26; + + ------------- + -- GetU_26 -- + ------------- + + function GetU_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_26; + + ------------ + -- Set_26 -- + ------------ + + procedure Set_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_26; + + ------------- + -- SetU_26 -- + ------------- + + procedure SetU_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_26; + +end System.Pack_26; diff --git a/gcc/ada/libgnat/s-pack26.ads b/gcc/ada/libgnat/s-pack26.ads new file mode 100644 index 0000000..bc0d863 --- /dev/null +++ b/gcc/ada/libgnat/s-pack26.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 26 + +package System.Pack_26 is + pragma Preelaborate; + + Bits : constant := 26; + + type Bits_26 is mod 2 ** Bits; + for Bits_26'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_26 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_26 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_26 + (Arr : System.Address; + N : Natural; + E : Bits_26; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_26; diff --git a/gcc/ada/libgnat/s-pack27.adb b/gcc/ada/libgnat/s-pack27.adb new file mode 100644 index 0000000..bba4537 --- /dev/null +++ b/gcc/ada/libgnat/s-pack27.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_27 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_27; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_27 -- + ------------ + + function Get_27 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_27 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_27; + + ------------ + -- Set_27 -- + ------------ + + procedure Set_27 + (Arr : System.Address; + N : Natural; + E : Bits_27; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_27; + +end System.Pack_27; diff --git a/gcc/ada/libgnat/s-pack27.ads b/gcc/ada/libgnat/s-pack27.ads new file mode 100644 index 0000000..f760043 --- /dev/null +++ b/gcc/ada/libgnat/s-pack27.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 27 + +package System.Pack_27 is + pragma Preelaborate; + + Bits : constant := 27; + + type Bits_27 is mod 2 ** Bits; + for Bits_27'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_27 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_27 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_27 + (Arr : System.Address; + N : Natural; + E : Bits_27; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_27; diff --git a/gcc/ada/libgnat/s-pack28.adb b/gcc/ada/libgnat/s-pack28.adb new file mode 100644 index 0000000..3d1522a --- /dev/null +++ b/gcc/ada/libgnat/s-pack28.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_28 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_28; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_28 or SetU_28 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_28 -- + ------------ + + function Get_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_28; + + ------------- + -- GetU_28 -- + ------------- + + function GetU_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_28; + + ------------ + -- Set_28 -- + ------------ + + procedure Set_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_28; + + ------------- + -- SetU_28 -- + ------------- + + procedure SetU_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_28; + +end System.Pack_28; diff --git a/gcc/ada/libgnat/s-pack28.ads b/gcc/ada/libgnat/s-pack28.ads new file mode 100644 index 0000000..3345716 --- /dev/null +++ b/gcc/ada/libgnat/s-pack28.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 28 + +package System.Pack_28 is + pragma Preelaborate; + + Bits : constant := 28; + + type Bits_28 is mod 2 ** Bits; + for Bits_28'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_28 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_28 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_28 + (Arr : System.Address; + N : Natural; + E : Bits_28; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_28; diff --git a/gcc/ada/libgnat/s-pack29.adb b/gcc/ada/libgnat/s-pack29.adb new file mode 100644 index 0000000..a8315d4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack29.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_29 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_29; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_29 -- + ------------ + + function Get_29 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_29 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_29; + + ------------ + -- Set_29 -- + ------------ + + procedure Set_29 + (Arr : System.Address; + N : Natural; + E : Bits_29; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_29; + +end System.Pack_29; diff --git a/gcc/ada/libgnat/s-pack29.ads b/gcc/ada/libgnat/s-pack29.ads new file mode 100644 index 0000000..fb408ef --- /dev/null +++ b/gcc/ada/libgnat/s-pack29.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 2 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 29 + +package System.Pack_29 is + pragma Preelaborate; + + Bits : constant := 29; + + type Bits_29 is mod 2 ** Bits; + for Bits_29'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_29 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_29 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_29 + (Arr : System.Address; + N : Natural; + E : Bits_29; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_29; diff --git a/gcc/ada/libgnat/s-pack30.adb b/gcc/ada/libgnat/s-pack30.adb new file mode 100644 index 0000000..baff460 --- /dev/null +++ b/gcc/ada/libgnat/s-pack30.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_30 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_30; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_30 or SetU_30 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_30 -- + ------------ + + function Get_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_30; + + ------------- + -- GetU_30 -- + ------------- + + function GetU_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_30; + + ------------ + -- Set_30 -- + ------------ + + procedure Set_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_30; + + ------------- + -- SetU_30 -- + ------------- + + procedure SetU_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_30; + +end System.Pack_30; diff --git a/gcc/ada/libgnat/s-pack30.ads b/gcc/ada/libgnat/s-pack30.ads new file mode 100644 index 0000000..5679368 --- /dev/null +++ b/gcc/ada/libgnat/s-pack30.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 30 + +package System.Pack_30 is + pragma Preelaborate; + + Bits : constant := 30; + + type Bits_30 is mod 2 ** Bits; + for Bits_30'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_30 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_30 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_30 + (Arr : System.Address; + N : Natural; + E : Bits_30; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_30; diff --git a/gcc/ada/libgnat/s-pack31.adb b/gcc/ada/libgnat/s-pack31.adb new file mode 100644 index 0000000..c9c04dc --- /dev/null +++ b/gcc/ada/libgnat/s-pack31.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_31 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_31; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_31 -- + ------------ + + function Get_31 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_31 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_31; + + ------------ + -- Set_31 -- + ------------ + + procedure Set_31 + (Arr : System.Address; + N : Natural; + E : Bits_31; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_31; + +end System.Pack_31; diff --git a/gcc/ada/libgnat/s-pack31.ads b/gcc/ada/libgnat/s-pack31.ads new file mode 100644 index 0000000..86337ac --- /dev/null +++ b/gcc/ada/libgnat/s-pack31.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 31 + +package System.Pack_31 is + pragma Preelaborate; + + Bits : constant := 31; + + type Bits_31 is mod 2 ** Bits; + for Bits_31'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_31 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_31 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_31 + (Arr : System.Address; + N : Natural; + E : Bits_31; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_31; diff --git a/gcc/ada/libgnat/s-pack33.adb b/gcc/ada/libgnat/s-pack33.adb new file mode 100644 index 0000000..4218670 --- /dev/null +++ b/gcc/ada/libgnat/s-pack33.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_33 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_33; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_33 -- + ------------ + + function Get_33 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_33 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_33; + + ------------ + -- Set_33 -- + ------------ + + procedure Set_33 + (Arr : System.Address; + N : Natural; + E : Bits_33; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_33; + +end System.Pack_33; diff --git a/gcc/ada/libgnat/s-pack33.ads b/gcc/ada/libgnat/s-pack33.ads new file mode 100644 index 0000000..5a9e6cf --- /dev/null +++ b/gcc/ada/libgnat/s-pack33.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 33 + +package System.Pack_33 is + pragma Preelaborate; + + Bits : constant := 33; + + type Bits_33 is mod 2 ** Bits; + for Bits_33'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_33 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_33 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_33 + (Arr : System.Address; + N : Natural; + E : Bits_33; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_33; diff --git a/gcc/ada/libgnat/s-pack34.adb b/gcc/ada/libgnat/s-pack34.adb new file mode 100644 index 0000000..79b3c4a --- /dev/null +++ b/gcc/ada/libgnat/s-pack34.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_34 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_34; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_34 or SetU_34 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_34 -- + ------------ + + function Get_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_34; + + ------------- + -- GetU_34 -- + ------------- + + function GetU_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_34; + + ------------ + -- Set_34 -- + ------------ + + procedure Set_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_34; + + ------------- + -- SetU_34 -- + ------------- + + procedure SetU_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_34; + +end System.Pack_34; diff --git a/gcc/ada/libgnat/s-pack34.ads b/gcc/ada/libgnat/s-pack34.ads new file mode 100644 index 0000000..7aac4bb --- /dev/null +++ b/gcc/ada/libgnat/s-pack34.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 34 + +package System.Pack_34 is + pragma Preelaborate; + + Bits : constant := 34; + + type Bits_34 is mod 2 ** Bits; + for Bits_34'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_34 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_34 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_34 + (Arr : System.Address; + N : Natural; + E : Bits_34; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_34; diff --git a/gcc/ada/libgnat/s-pack35.adb b/gcc/ada/libgnat/s-pack35.adb new file mode 100644 index 0000000..1a5d19d --- /dev/null +++ b/gcc/ada/libgnat/s-pack35.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_35 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_35; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_35 -- + ------------ + + function Get_35 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_35 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_35; + + ------------ + -- Set_35 -- + ------------ + + procedure Set_35 + (Arr : System.Address; + N : Natural; + E : Bits_35; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_35; + +end System.Pack_35; diff --git a/gcc/ada/libgnat/s-pack35.ads b/gcc/ada/libgnat/s-pack35.ads new file mode 100644 index 0000000..c38e8a6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack35.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 35 + +package System.Pack_35 is + pragma Preelaborate; + + Bits : constant := 35; + + type Bits_35 is mod 2 ** Bits; + for Bits_35'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_35 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_35 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_35 + (Arr : System.Address; + N : Natural; + E : Bits_35; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_35; diff --git a/gcc/ada/libgnat/s-pack36.adb b/gcc/ada/libgnat/s-pack36.adb new file mode 100644 index 0000000..c539e20 --- /dev/null +++ b/gcc/ada/libgnat/s-pack36.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_36 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_36; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_36 or SetU_36 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_36 -- + ------------ + + function Get_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_36; + + ------------- + -- GetU_36 -- + ------------- + + function GetU_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_36; + + ------------ + -- Set_36 -- + ------------ + + procedure Set_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_36; + + ------------- + -- SetU_36 -- + ------------- + + procedure SetU_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_36; + +end System.Pack_36; diff --git a/gcc/ada/libgnat/s-pack36.ads b/gcc/ada/libgnat/s-pack36.ads new file mode 100644 index 0000000..f4b2a10 --- /dev/null +++ b/gcc/ada/libgnat/s-pack36.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 36 + +package System.Pack_36 is + pragma Preelaborate; + + Bits : constant := 36; + + type Bits_36 is mod 2 ** Bits; + for Bits_36'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_36 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_36 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_36 + (Arr : System.Address; + N : Natural; + E : Bits_36; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_36; diff --git a/gcc/ada/libgnat/s-pack37.adb b/gcc/ada/libgnat/s-pack37.adb new file mode 100644 index 0000000..ba477a4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack37.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_37 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_37; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_37 -- + ------------ + + function Get_37 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_37 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_37; + + ------------ + -- Set_37 -- + ------------ + + procedure Set_37 + (Arr : System.Address; + N : Natural; + E : Bits_37; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_37; + +end System.Pack_37; diff --git a/gcc/ada/libgnat/s-pack37.ads b/gcc/ada/libgnat/s-pack37.ads new file mode 100644 index 0000000..e8da8cf --- /dev/null +++ b/gcc/ada/libgnat/s-pack37.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 37 + +package System.Pack_37 is + pragma Preelaborate; + + Bits : constant := 37; + + type Bits_37 is mod 2 ** Bits; + for Bits_37'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_37 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_37 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_37 + (Arr : System.Address; + N : Natural; + E : Bits_37; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_37; diff --git a/gcc/ada/libgnat/s-pack38.adb b/gcc/ada/libgnat/s-pack38.adb new file mode 100644 index 0000000..47c4368 --- /dev/null +++ b/gcc/ada/libgnat/s-pack38.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_38 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_38; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_38 or SetU_38 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_38 -- + ------------ + + function Get_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_38; + + ------------- + -- GetU_38 -- + ------------- + + function GetU_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_38; + + ------------ + -- Set_38 -- + ------------ + + procedure Set_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_38; + + ------------- + -- SetU_38 -- + ------------- + + procedure SetU_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_38; + +end System.Pack_38; diff --git a/gcc/ada/libgnat/s-pack38.ads b/gcc/ada/libgnat/s-pack38.ads new file mode 100644 index 0000000..0814487 --- /dev/null +++ b/gcc/ada/libgnat/s-pack38.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 38 + +package System.Pack_38 is + pragma Preelaborate; + + Bits : constant := 38; + + type Bits_38 is mod 2 ** Bits; + for Bits_38'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_38 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_38 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_38 + (Arr : System.Address; + N : Natural; + E : Bits_38; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_38; diff --git a/gcc/ada/libgnat/s-pack39.adb b/gcc/ada/libgnat/s-pack39.adb new file mode 100644 index 0000000..beb675a --- /dev/null +++ b/gcc/ada/libgnat/s-pack39.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_39 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_39; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_39 -- + ------------ + + function Get_39 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_39 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_39; + + ------------ + -- Set_39 -- + ------------ + + procedure Set_39 + (Arr : System.Address; + N : Natural; + E : Bits_39; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_39; + +end System.Pack_39; diff --git a/gcc/ada/libgnat/s-pack39.ads b/gcc/ada/libgnat/s-pack39.ads new file mode 100644 index 0000000..e3cf836 --- /dev/null +++ b/gcc/ada/libgnat/s-pack39.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 3 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 39 + +package System.Pack_39 is + pragma Preelaborate; + + Bits : constant := 39; + + type Bits_39 is mod 2 ** Bits; + for Bits_39'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_39 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_39 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_39 + (Arr : System.Address; + N : Natural; + E : Bits_39; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_39; diff --git a/gcc/ada/libgnat/s-pack40.adb b/gcc/ada/libgnat/s-pack40.adb new file mode 100644 index 0000000..f0056b9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack40.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_40 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_40; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_40 or SetU_40 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_40 -- + ------------ + + function Get_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_40; + + ------------- + -- GetU_40 -- + ------------- + + function GetU_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_40; + + ------------ + -- Set_40 -- + ------------ + + procedure Set_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_40; + + ------------- + -- SetU_40 -- + ------------- + + procedure SetU_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_40; + +end System.Pack_40; diff --git a/gcc/ada/libgnat/s-pack40.ads b/gcc/ada/libgnat/s-pack40.ads new file mode 100644 index 0000000..3f43040 --- /dev/null +++ b/gcc/ada/libgnat/s-pack40.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 40 + +package System.Pack_40 is + pragma Preelaborate; + + Bits : constant := 40; + + type Bits_40 is mod 2 ** Bits; + for Bits_40'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_40 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_40 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_40 + (Arr : System.Address; + N : Natural; + E : Bits_40; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_40; diff --git a/gcc/ada/libgnat/s-pack41.adb b/gcc/ada/libgnat/s-pack41.adb new file mode 100644 index 0000000..2d7b47b --- /dev/null +++ b/gcc/ada/libgnat/s-pack41.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_41 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_41; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_41 -- + ------------ + + function Get_41 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_41 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_41; + + ------------ + -- Set_41 -- + ------------ + + procedure Set_41 + (Arr : System.Address; + N : Natural; + E : Bits_41; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_41; + +end System.Pack_41; diff --git a/gcc/ada/libgnat/s-pack41.ads b/gcc/ada/libgnat/s-pack41.ads new file mode 100644 index 0000000..0416557 --- /dev/null +++ b/gcc/ada/libgnat/s-pack41.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 41 + +package System.Pack_41 is + pragma Preelaborate; + + Bits : constant := 41; + + type Bits_41 is mod 2 ** Bits; + for Bits_41'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_41 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_41 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_41 + (Arr : System.Address; + N : Natural; + E : Bits_41; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_41; diff --git a/gcc/ada/libgnat/s-pack42.adb b/gcc/ada/libgnat/s-pack42.adb new file mode 100644 index 0000000..0377604 --- /dev/null +++ b/gcc/ada/libgnat/s-pack42.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_42 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_42; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_42 or SetU_42 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_42 -- + ------------ + + function Get_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_42; + + ------------- + -- GetU_42 -- + ------------- + + function GetU_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_42; + + ------------ + -- Set_42 -- + ------------ + + procedure Set_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_42; + + ------------- + -- SetU_42 -- + ------------- + + procedure SetU_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_42; + +end System.Pack_42; diff --git a/gcc/ada/libgnat/s-pack42.ads b/gcc/ada/libgnat/s-pack42.ads new file mode 100644 index 0000000..ed468a8 --- /dev/null +++ b/gcc/ada/libgnat/s-pack42.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 42 + +package System.Pack_42 is + pragma Preelaborate; + + Bits : constant := 42; + + type Bits_42 is mod 2 ** Bits; + for Bits_42'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_42 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_42 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_42 + (Arr : System.Address; + N : Natural; + E : Bits_42; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_42; diff --git a/gcc/ada/libgnat/s-pack43.adb b/gcc/ada/libgnat/s-pack43.adb new file mode 100644 index 0000000..ea96d32 --- /dev/null +++ b/gcc/ada/libgnat/s-pack43.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_43 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_43; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_43 -- + ------------ + + function Get_43 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_43 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_43; + + ------------ + -- Set_43 -- + ------------ + + procedure Set_43 + (Arr : System.Address; + N : Natural; + E : Bits_43; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_43; + +end System.Pack_43; diff --git a/gcc/ada/libgnat/s-pack43.ads b/gcc/ada/libgnat/s-pack43.ads new file mode 100644 index 0000000..d37616b --- /dev/null +++ b/gcc/ada/libgnat/s-pack43.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 43 + +package System.Pack_43 is + pragma Preelaborate; + + Bits : constant := 43; + + type Bits_43 is mod 2 ** Bits; + for Bits_43'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_43 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_43 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_43 + (Arr : System.Address; + N : Natural; + E : Bits_43; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_43; diff --git a/gcc/ada/libgnat/s-pack44.adb b/gcc/ada/libgnat/s-pack44.adb new file mode 100644 index 0000000..7088cf8 --- /dev/null +++ b/gcc/ada/libgnat/s-pack44.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_44 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_44; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_44 or SetU_44 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_44 -- + ------------ + + function Get_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_44; + + ------------- + -- GetU_44 -- + ------------- + + function GetU_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_44; + + ------------ + -- Set_44 -- + ------------ + + procedure Set_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_44; + + ------------- + -- SetU_44 -- + ------------- + + procedure SetU_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_44; + +end System.Pack_44; diff --git a/gcc/ada/libgnat/s-pack44.ads b/gcc/ada/libgnat/s-pack44.ads new file mode 100644 index 0000000..20fd41b --- /dev/null +++ b/gcc/ada/libgnat/s-pack44.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 44 + +package System.Pack_44 is + pragma Preelaborate; + + Bits : constant := 44; + + type Bits_44 is mod 2 ** Bits; + for Bits_44'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_44 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_44 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_44 + (Arr : System.Address; + N : Natural; + E : Bits_44; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_44; diff --git a/gcc/ada/libgnat/s-pack45.adb b/gcc/ada/libgnat/s-pack45.adb new file mode 100644 index 0000000..9b81ccc --- /dev/null +++ b/gcc/ada/libgnat/s-pack45.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_45 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_45; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_45 -- + ------------ + + function Get_45 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_45 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_45; + + ------------ + -- Set_45 -- + ------------ + + procedure Set_45 + (Arr : System.Address; + N : Natural; + E : Bits_45; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_45; + +end System.Pack_45; diff --git a/gcc/ada/libgnat/s-pack45.ads b/gcc/ada/libgnat/s-pack45.ads new file mode 100644 index 0000000..b406c20 --- /dev/null +++ b/gcc/ada/libgnat/s-pack45.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 45 + +package System.Pack_45 is + pragma Preelaborate; + + Bits : constant := 45; + + type Bits_45 is mod 2 ** Bits; + for Bits_45'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_45 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_45 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_45 + (Arr : System.Address; + N : Natural; + E : Bits_45; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_45; diff --git a/gcc/ada/libgnat/s-pack46.adb b/gcc/ada/libgnat/s-pack46.adb new file mode 100644 index 0000000..fc5d60b --- /dev/null +++ b/gcc/ada/libgnat/s-pack46.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_46 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_46; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_46 or SetU_46 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_46 -- + ------------ + + function Get_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_46; + + ------------- + -- GetU_46 -- + ------------- + + function GetU_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_46; + + ------------ + -- Set_46 -- + ------------ + + procedure Set_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_46; + + ------------- + -- SetU_46 -- + ------------- + + procedure SetU_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_46; + +end System.Pack_46; diff --git a/gcc/ada/libgnat/s-pack46.ads b/gcc/ada/libgnat/s-pack46.ads new file mode 100644 index 0000000..60a7f27 --- /dev/null +++ b/gcc/ada/libgnat/s-pack46.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 46 + +package System.Pack_46 is + pragma Preelaborate; + + Bits : constant := 46; + + type Bits_46 is mod 2 ** Bits; + for Bits_46'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_46 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_46 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_46 + (Arr : System.Address; + N : Natural; + E : Bits_46; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_46; diff --git a/gcc/ada/libgnat/s-pack47.adb b/gcc/ada/libgnat/s-pack47.adb new file mode 100644 index 0000000..3354a03 --- /dev/null +++ b/gcc/ada/libgnat/s-pack47.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_47 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_47; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_47 -- + ------------ + + function Get_47 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_47 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_47; + + ------------ + -- Set_47 -- + ------------ + + procedure Set_47 + (Arr : System.Address; + N : Natural; + E : Bits_47; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_47; + +end System.Pack_47; diff --git a/gcc/ada/libgnat/s-pack47.ads b/gcc/ada/libgnat/s-pack47.ads new file mode 100644 index 0000000..a29399e --- /dev/null +++ b/gcc/ada/libgnat/s-pack47.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 47 + +package System.Pack_47 is + pragma Preelaborate; + + Bits : constant := 47; + + type Bits_47 is mod 2 ** Bits; + for Bits_47'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_47 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_47 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_47 + (Arr : System.Address; + N : Natural; + E : Bits_47; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_47; diff --git a/gcc/ada/libgnat/s-pack48.adb b/gcc/ada/libgnat/s-pack48.adb new file mode 100644 index 0000000..26e3165 --- /dev/null +++ b/gcc/ada/libgnat/s-pack48.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_48 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_48; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_48 or SetU_48 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_48 -- + ------------ + + function Get_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_48; + + ------------- + -- GetU_48 -- + ------------- + + function GetU_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_48; + + ------------ + -- Set_48 -- + ------------ + + procedure Set_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_48; + + ------------- + -- SetU_48 -- + ------------- + + procedure SetU_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_48; + +end System.Pack_48; diff --git a/gcc/ada/libgnat/s-pack48.ads b/gcc/ada/libgnat/s-pack48.ads new file mode 100644 index 0000000..68c5562 --- /dev/null +++ b/gcc/ada/libgnat/s-pack48.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 48 + +package System.Pack_48 is + pragma Preelaborate; + + Bits : constant := 48; + + type Bits_48 is mod 2 ** Bits; + for Bits_48'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_48 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_48 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_48 + (Arr : System.Address; + N : Natural; + E : Bits_48; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_48; diff --git a/gcc/ada/libgnat/s-pack49.adb b/gcc/ada/libgnat/s-pack49.adb new file mode 100644 index 0000000..0a13077 --- /dev/null +++ b/gcc/ada/libgnat/s-pack49.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_49 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_49; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_49 -- + ------------ + + function Get_49 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_49 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_49; + + ------------ + -- Set_49 -- + ------------ + + procedure Set_49 + (Arr : System.Address; + N : Natural; + E : Bits_49; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_49; + +end System.Pack_49; diff --git a/gcc/ada/libgnat/s-pack49.ads b/gcc/ada/libgnat/s-pack49.ads new file mode 100644 index 0000000..3c1f74b --- /dev/null +++ b/gcc/ada/libgnat/s-pack49.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 4 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 49 + +package System.Pack_49 is + pragma Preelaborate; + + Bits : constant := 49; + + type Bits_49 is mod 2 ** Bits; + for Bits_49'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_49 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_49 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_49 + (Arr : System.Address; + N : Natural; + E : Bits_49; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_49; diff --git a/gcc/ada/libgnat/s-pack50.adb b/gcc/ada/libgnat/s-pack50.adb new file mode 100644 index 0000000..845630c --- /dev/null +++ b/gcc/ada/libgnat/s-pack50.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_50 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_50; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_50 or SetU_50 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_50 -- + ------------ + + function Get_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_50; + + ------------- + -- GetU_50 -- + ------------- + + function GetU_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_50; + + ------------ + -- Set_50 -- + ------------ + + procedure Set_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_50; + + ------------- + -- SetU_50 -- + ------------- + + procedure SetU_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_50; + +end System.Pack_50; diff --git a/gcc/ada/libgnat/s-pack50.ads b/gcc/ada/libgnat/s-pack50.ads new file mode 100644 index 0000000..7b952d6 --- /dev/null +++ b/gcc/ada/libgnat/s-pack50.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 50 + +package System.Pack_50 is + pragma Preelaborate; + + Bits : constant := 50; + + type Bits_50 is mod 2 ** Bits; + for Bits_50'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_50 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_50 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_50 + (Arr : System.Address; + N : Natural; + E : Bits_50; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_50; diff --git a/gcc/ada/libgnat/s-pack51.adb b/gcc/ada/libgnat/s-pack51.adb new file mode 100644 index 0000000..217e230 --- /dev/null +++ b/gcc/ada/libgnat/s-pack51.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_51 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_51; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_51 -- + ------------ + + function Get_51 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_51 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_51; + + ------------ + -- Set_51 -- + ------------ + + procedure Set_51 + (Arr : System.Address; + N : Natural; + E : Bits_51; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_51; + +end System.Pack_51; diff --git a/gcc/ada/libgnat/s-pack51.ads b/gcc/ada/libgnat/s-pack51.ads new file mode 100644 index 0000000..d95dd42 --- /dev/null +++ b/gcc/ada/libgnat/s-pack51.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 51 + +package System.Pack_51 is + pragma Preelaborate; + + Bits : constant := 51; + + type Bits_51 is mod 2 ** Bits; + for Bits_51'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_51 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_51 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_51 + (Arr : System.Address; + N : Natural; + E : Bits_51; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_51; diff --git a/gcc/ada/libgnat/s-pack52.adb b/gcc/ada/libgnat/s-pack52.adb new file mode 100644 index 0000000..37b583f --- /dev/null +++ b/gcc/ada/libgnat/s-pack52.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_52 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_52; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_52 or SetU_52 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_52 -- + ------------ + + function Get_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_52; + + ------------- + -- GetU_52 -- + ------------- + + function GetU_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_52; + + ------------ + -- Set_52 -- + ------------ + + procedure Set_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_52; + + ------------- + -- SetU_52 -- + ------------- + + procedure SetU_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_52; + +end System.Pack_52; diff --git a/gcc/ada/libgnat/s-pack52.ads b/gcc/ada/libgnat/s-pack52.ads new file mode 100644 index 0000000..27a5b93 --- /dev/null +++ b/gcc/ada/libgnat/s-pack52.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 52 + +package System.Pack_52 is + pragma Preelaborate; + + Bits : constant := 52; + + type Bits_52 is mod 2 ** Bits; + for Bits_52'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_52 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_52 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_52 + (Arr : System.Address; + N : Natural; + E : Bits_52; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_52; diff --git a/gcc/ada/libgnat/s-pack53.adb b/gcc/ada/libgnat/s-pack53.adb new file mode 100644 index 0000000..f5e8712 --- /dev/null +++ b/gcc/ada/libgnat/s-pack53.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_53 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_53; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_53 -- + ------------ + + function Get_53 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_53 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_53; + + ------------ + -- Set_53 -- + ------------ + + procedure Set_53 + (Arr : System.Address; + N : Natural; + E : Bits_53; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_53; + +end System.Pack_53; diff --git a/gcc/ada/libgnat/s-pack53.ads b/gcc/ada/libgnat/s-pack53.ads new file mode 100644 index 0000000..89badf4 --- /dev/null +++ b/gcc/ada/libgnat/s-pack53.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 53 + +package System.Pack_53 is + pragma Preelaborate; + + Bits : constant := 53; + + type Bits_53 is mod 2 ** Bits; + for Bits_53'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_53 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_53 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_53 + (Arr : System.Address; + N : Natural; + E : Bits_53; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_53; diff --git a/gcc/ada/libgnat/s-pack54.adb b/gcc/ada/libgnat/s-pack54.adb new file mode 100644 index 0000000..45fdfdc --- /dev/null +++ b/gcc/ada/libgnat/s-pack54.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_54 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_54; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_54 or SetU_54 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_54 -- + ------------ + + function Get_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_54; + + ------------- + -- GetU_54 -- + ------------- + + function GetU_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_54; + + ------------ + -- Set_54 -- + ------------ + + procedure Set_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_54; + + ------------- + -- SetU_54 -- + ------------- + + procedure SetU_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_54; + +end System.Pack_54; diff --git a/gcc/ada/libgnat/s-pack54.ads b/gcc/ada/libgnat/s-pack54.ads new file mode 100644 index 0000000..936c391 --- /dev/null +++ b/gcc/ada/libgnat/s-pack54.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 54 + +package System.Pack_54 is + pragma Preelaborate; + + Bits : constant := 54; + + type Bits_54 is mod 2 ** Bits; + for Bits_54'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_54 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_54 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_54 + (Arr : System.Address; + N : Natural; + E : Bits_54; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_54; diff --git a/gcc/ada/libgnat/s-pack55.adb b/gcc/ada/libgnat/s-pack55.adb new file mode 100644 index 0000000..3b9d26b --- /dev/null +++ b/gcc/ada/libgnat/s-pack55.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_55 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_55; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_55 -- + ------------ + + function Get_55 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_55 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_55; + + ------------ + -- Set_55 -- + ------------ + + procedure Set_55 + (Arr : System.Address; + N : Natural; + E : Bits_55; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_55; + +end System.Pack_55; diff --git a/gcc/ada/libgnat/s-pack55.ads b/gcc/ada/libgnat/s-pack55.ads new file mode 100644 index 0000000..de587f9 --- /dev/null +++ b/gcc/ada/libgnat/s-pack55.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 55 + +package System.Pack_55 is + pragma Preelaborate; + + Bits : constant := 55; + + type Bits_55 is mod 2 ** Bits; + for Bits_55'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_55 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_55 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_55 + (Arr : System.Address; + N : Natural; + E : Bits_55; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_55; diff --git a/gcc/ada/libgnat/s-pack56.adb b/gcc/ada/libgnat/s-pack56.adb new file mode 100644 index 0000000..f6dd750 --- /dev/null +++ b/gcc/ada/libgnat/s-pack56.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 6 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_56 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_56; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_56 or SetU_56 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_56 -- + ------------ + + function Get_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_56; + + ------------- + -- GetU_56 -- + ------------- + + function GetU_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_56; + + ------------ + -- Set_56 -- + ------------ + + procedure Set_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_56; + + ------------- + -- SetU_56 -- + ------------- + + procedure SetU_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_56; + +end System.Pack_56; diff --git a/gcc/ada/libgnat/s-pack56.ads b/gcc/ada/libgnat/s-pack56.ads new file mode 100644 index 0000000..ef354ba --- /dev/null +++ b/gcc/ada/libgnat/s-pack56.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 6 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 56 + +package System.Pack_56 is + pragma Preelaborate; + + Bits : constant := 56; + + type Bits_56 is mod 2 ** Bits; + for Bits_56'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_56 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_56 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_56 + (Arr : System.Address; + N : Natural; + E : Bits_56; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_56; diff --git a/gcc/ada/libgnat/s-pack57.adb b/gcc/ada/libgnat/s-pack57.adb new file mode 100644 index 0000000..7cc5813 --- /dev/null +++ b/gcc/ada/libgnat/s-pack57.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 7 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_57 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_57; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_57 -- + ------------ + + function Get_57 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_57 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_57; + + ------------ + -- Set_57 -- + ------------ + + procedure Set_57 + (Arr : System.Address; + N : Natural; + E : Bits_57; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_57; + +end System.Pack_57; diff --git a/gcc/ada/libgnat/s-pack57.ads b/gcc/ada/libgnat/s-pack57.ads new file mode 100644 index 0000000..75272e7 --- /dev/null +++ b/gcc/ada/libgnat/s-pack57.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 7 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 57 + +package System.Pack_57 is + pragma Preelaborate; + + Bits : constant := 57; + + type Bits_57 is mod 2 ** Bits; + for Bits_57'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_57 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_57 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_57 + (Arr : System.Address; + N : Natural; + E : Bits_57; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_57; diff --git a/gcc/ada/libgnat/s-pack58.adb b/gcc/ada/libgnat/s-pack58.adb new file mode 100644 index 0000000..3ed545b --- /dev/null +++ b/gcc/ada/libgnat/s-pack58.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 8 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_58 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_58; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_58 or SetU_58 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_58 -- + ------------ + + function Get_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_58; + + ------------- + -- GetU_58 -- + ------------- + + function GetU_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_58; + + ------------ + -- Set_58 -- + ------------ + + procedure Set_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_58; + + ------------- + -- SetU_58 -- + ------------- + + procedure SetU_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_58; + +end System.Pack_58; diff --git a/gcc/ada/libgnat/s-pack58.ads b/gcc/ada/libgnat/s-pack58.ads new file mode 100644 index 0000000..eb45a42 --- /dev/null +++ b/gcc/ada/libgnat/s-pack58.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 8 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 58 + +package System.Pack_58 is + pragma Preelaborate; + + Bits : constant := 58; + + type Bits_58 is mod 2 ** Bits; + for Bits_58'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_58 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_58 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_58 + (Arr : System.Address; + N : Natural; + E : Bits_58; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_58; diff --git a/gcc/ada/libgnat/s-pack59.adb b/gcc/ada/libgnat/s-pack59.adb new file mode 100644 index 0000000..312177f --- /dev/null +++ b/gcc/ada/libgnat/s-pack59.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 9 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_59 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_59; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_59 -- + ------------ + + function Get_59 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_59 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_59; + + ------------ + -- Set_59 -- + ------------ + + procedure Set_59 + (Arr : System.Address; + N : Natural; + E : Bits_59; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_59; + +end System.Pack_59; diff --git a/gcc/ada/libgnat/s-pack59.ads b/gcc/ada/libgnat/s-pack59.ads new file mode 100644 index 0000000..c52fb20 --- /dev/null +++ b/gcc/ada/libgnat/s-pack59.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 5 9 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 59 + +package System.Pack_59 is + pragma Preelaborate; + + Bits : constant := 59; + + type Bits_59 is mod 2 ** Bits; + for Bits_59'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_59 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_59 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_59 + (Arr : System.Address; + N : Natural; + E : Bits_59; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_59; diff --git a/gcc/ada/libgnat/s-pack60.adb b/gcc/ada/libgnat/s-pack60.adb new file mode 100644 index 0000000..4ca53b5 --- /dev/null +++ b/gcc/ada/libgnat/s-pack60.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 0 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_60 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_60; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_60 or SetU_60 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_60 -- + ------------ + + function Get_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_60; + + ------------- + -- GetU_60 -- + ------------- + + function GetU_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_60; + + ------------ + -- Set_60 -- + ------------ + + procedure Set_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_60; + + ------------- + -- SetU_60 -- + ------------- + + procedure SetU_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_60; + +end System.Pack_60; diff --git a/gcc/ada/libgnat/s-pack60.ads b/gcc/ada/libgnat/s-pack60.ads new file mode 100644 index 0000000..cd30299 --- /dev/null +++ b/gcc/ada/libgnat/s-pack60.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 0 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 60 + +package System.Pack_60 is + pragma Preelaborate; + + Bits : constant := 60; + + type Bits_60 is mod 2 ** Bits; + for Bits_60'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_60 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_60 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_60 + (Arr : System.Address; + N : Natural; + E : Bits_60; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_60; diff --git a/gcc/ada/libgnat/s-pack61.adb b/gcc/ada/libgnat/s-pack61.adb new file mode 100644 index 0000000..62224b1 --- /dev/null +++ b/gcc/ada/libgnat/s-pack61.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 1 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_61 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_61; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_61 -- + ------------ + + function Get_61 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_61 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_61; + + ------------ + -- Set_61 -- + ------------ + + procedure Set_61 + (Arr : System.Address; + N : Natural; + E : Bits_61; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_61; + +end System.Pack_61; diff --git a/gcc/ada/libgnat/s-pack61.ads b/gcc/ada/libgnat/s-pack61.ads new file mode 100644 index 0000000..c247233 --- /dev/null +++ b/gcc/ada/libgnat/s-pack61.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 1 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 61 + +package System.Pack_61 is + pragma Preelaborate; + + Bits : constant := 61; + + type Bits_61 is mod 2 ** Bits; + for Bits_61'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_61 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_61 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_61 + (Arr : System.Address; + N : Natural; + E : Bits_61; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_61; diff --git a/gcc/ada/libgnat/s-pack62.adb b/gcc/ada/libgnat/s-pack62.adb new file mode 100644 index 0000000..f0e774f --- /dev/null +++ b/gcc/ada/libgnat/s-pack62.adb @@ -0,0 +1,250 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_62 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_62; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + -- The following declarations are for the case where the address + -- passed to GetU_62 or SetU_62 is not guaranteed to be aligned. + -- These routines are used when the packed array is itself a + -- component of a packed record, and therefore may not be aligned. + + type ClusterU is new Cluster; + for ClusterU'Alignment use 1; + + type ClusterU_Ref is access ClusterU; + + type Rev_ClusterU is new ClusterU + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_ClusterU_Ref is access Rev_ClusterU; + + ------------ + -- Get_62 -- + ------------ + + function Get_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_62; + + ------------- + -- GetU_62 -- + ------------- + + function GetU_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end GetU_62; + + ------------ + -- Set_62 -- + ------------ + + procedure Set_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_62; + + ------------- + -- SetU_62 -- + ------------- + + procedure SetU_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : ClusterU_Ref with Address => A'Address, Import; + RC : Rev_ClusterU_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end SetU_62; + +end System.Pack_62; diff --git a/gcc/ada/libgnat/s-pack62.ads b/gcc/ada/libgnat/s-pack62.ads new file mode 100644 index 0000000..c019532 --- /dev/null +++ b/gcc/ada/libgnat/s-pack62.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 62 + +package System.Pack_62 is + pragma Preelaborate; + + Bits : constant := 62; + + type Bits_62 is mod 2 ** Bits; + for Bits_62'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + + function GetU_62 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_62 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. This version + -- is used when Arr may represent an unaligned address. + + procedure SetU_62 + (Arr : System.Address; + N : Natural; + E : Bits_62; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. This version + -- is used when Arr may represent an unaligned address + +end System.Pack_62; diff --git a/gcc/ada/libgnat/s-pack63.adb b/gcc/ada/libgnat/s-pack63.adb new file mode 100644 index 0000000..bbaf914 --- /dev/null +++ b/gcc/ada/libgnat/s-pack63.adb @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Elements; +with System.Unsigned_Types; + +package body System.Pack_63 is + + subtype Bit_Order is System.Bit_Order; + Reverse_Bit_Order : constant Bit_Order := + Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); + + subtype Ofs is System.Storage_Elements.Storage_Offset; + subtype Uns is System.Unsigned_Types.Unsigned; + subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; + + use type System.Storage_Elements.Storage_Offset; + use type System.Unsigned_Types.Unsigned; + + type Cluster is record + E0, E1, E2, E3, E4, E5, E6, E7 : Bits_63; + end record; + + for Cluster use record + E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; + E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; + E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; + E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; + E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; + E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; + E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; + E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; + end record; + + for Cluster'Size use Bits * 8; + + for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, + 1 + + 1 * Boolean'Pos (Bits mod 2 = 0) + + 2 * Boolean'Pos (Bits mod 4 = 0)); + -- Use maximum possible alignment, given the bit field size, since this + -- will result in the most efficient code possible for the field. + + type Cluster_Ref is access Cluster; + + type Rev_Cluster is new Cluster + with Bit_Order => Reverse_Bit_Order, + Scalar_Storage_Order => Reverse_Bit_Order; + type Rev_Cluster_Ref is access Rev_Cluster; + + ------------ + -- Get_63 -- + ------------ + + function Get_63 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_63 + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => return RC.E0; + when 1 => return RC.E1; + when 2 => return RC.E2; + when 3 => return RC.E3; + when 4 => return RC.E4; + when 5 => return RC.E5; + when 6 => return RC.E6; + when 7 => return RC.E7; + end case; + + else + case N07 (Uns (N) mod 8) is + when 0 => return C.E0; + when 1 => return C.E1; + when 2 => return C.E2; + when 3 => return C.E3; + when 4 => return C.E4; + when 5 => return C.E5; + when 6 => return C.E6; + when 7 => return C.E7; + end case; + end if; + end Get_63; + + ------------ + -- Set_63 -- + ------------ + + procedure Set_63 + (Arr : System.Address; + N : Natural; + E : Bits_63; + Rev_SSO : Boolean) + is + A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); + C : Cluster_Ref with Address => A'Address, Import; + RC : Rev_Cluster_Ref with Address => A'Address, Import; + begin + if Rev_SSO then + case N07 (Uns (N) mod 8) is + when 0 => RC.E0 := E; + when 1 => RC.E1 := E; + when 2 => RC.E2 := E; + when 3 => RC.E3 := E; + when 4 => RC.E4 := E; + when 5 => RC.E5 := E; + when 6 => RC.E6 := E; + when 7 => RC.E7 := E; + end case; + else + case N07 (Uns (N) mod 8) is + when 0 => C.E0 := E; + when 1 => C.E1 := E; + when 2 => C.E2 := E; + when 3 => C.E3 := E; + when 4 => C.E4 := E; + when 5 => C.E5 := E; + when 6 => C.E6 := E; + when 7 => C.E7 := E; + end case; + end if; + end Set_63; + +end System.Pack_63; diff --git a/gcc/ada/libgnat/s-pack63.ads b/gcc/ada/libgnat/s-pack63.ads new file mode 100644 index 0000000..e0872c3 --- /dev/null +++ b/gcc/ada/libgnat/s-pack63.ads @@ -0,0 +1,60 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A C K _ 6 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Handling of packed arrays with Component_Size = 63 + +package System.Pack_63 is + pragma Preelaborate; + + Bits : constant := 63; + + type Bits_63 is mod 2 ** Bits; + for Bits_63'Size use Bits; + + -- In all subprograms below, Rev_SSO is set True if the array has the + -- non-default scalar storage order. + + function Get_63 + (Arr : System.Address; + N : Natural; + Rev_SSO : Boolean) return Bits_63 with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is extracted and returned. + + procedure Set_63 + (Arr : System.Address; + N : Natural; + E : Bits_63; + Rev_SSO : Boolean) with Inline; + -- Arr is the address of the packed array, N is the zero-based + -- subscript. This element is set to the given value. + +end System.Pack_63; diff --git a/gcc/ada/libgnat/s-parame-hpux.ads b/gcc/ada/libgnat/s-parame-hpux.ads new file mode 100644 index 0000000..f20cfbe --- /dev/null +++ b/gcc/ada/libgnat/s-parame-hpux.ads @@ -0,0 +1,199 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the HP version of this package + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Percentage is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Percentage : constant Percentage := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := False; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of Types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this may not be true + -- of all targets. + + ptr_bits : constant := Standard'Address_Size; + subtype C_Address is System.Address; + -- Number of bits in Interfaces.C pointers, normally a standard address + + C_Malloc_Linkname : constant String := "__gnat_malloc"; + -- Name of runtime function used to allocate such a pointer + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Max_Attribute_Count : constant := 32; + -- Number of task attributes stored in the task control block + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame-rtems.adb b/gcc/ada/libgnat/s-parame-rtems.adb new file mode 100644 index 0000000..aa13114 --- /dev/null +++ b/gcc/ada/libgnat/s-parame-rtems.adb @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS specific version + +with Interfaces.C; + +package body System.Parameters is + + function ada_pthread_minimum_stack_size return Interfaces.C.size_t; + pragma Import (C, ada_pthread_minimum_stack_size, + "_ada_pthread_minimum_stack_size"); + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + begin + return Size_Type (ada_pthread_minimum_stack_size); + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + + begin + return Size_Type (ada_pthread_minimum_stack_size); + end Minimum_Stack_Size; + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + + else + return Size; + end if; + end Adjust_Storage_Size; + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame-vxworks.adb b/gcc/ada/libgnat/s-parame-vxworks.adb new file mode 100644 index 0000000..325aa2e --- /dev/null +++ b/gcc/ada/libgnat/s-parame-vxworks.adb @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version used on all VxWorks targets + +package body System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + Default_Stack_Size : Integer; + pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); + begin + if Default_Stack_Size = -1 then + if Stack_Check_Limits then + return 32 * 1024; + -- Extra stack to allow for 12K exception area. + else + return 20 * 1024; + end if; + else + return Size_Type (Default_Stack_Size); + end if; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + return 8 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame-vxworks.ads b/gcc/ada/libgnat/s-parame-vxworks.ads new file mode 100644 index 0000000..919361a --- /dev/null +++ b/gcc/ada/libgnat/s-parame-vxworks.ads @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default VxWorks version of the package + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Percentage is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Percentage : constant Percentage := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 14_336; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + -- This value is chosen as the VxWorks default stack size is 20kB, + -- and a little more than 4kB is necessary for the run time. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this may not be true + -- of all targets. + + ptr_bits : constant := Standard'Address_Size; + subtype C_Address is System.Address; + -- Number of bits in Interfaces.C pointers, normally a standard address + + C_Malloc_Linkname : constant String := "__gnat_malloc"; + -- Name of runtime function used to allocate such a pointer + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Max_Attribute_Count : constant := 16; + -- Number of task attributes stored in the task control block + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 32; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame.adb b/gcc/ada/libgnat/s-parame.adb new file mode 100644 index 0000000..0f4d45f --- /dev/null +++ b/gcc/ada/libgnat/s-parame.adb @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default (used on all native platforms) version of this package + +pragma Compiler_Unit_Warning; + +package body System.Parameters is + + ------------------------- + -- Adjust_Storage_Size -- + ------------------------- + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type is + begin + if Size = Unspecified_Size then + return Default_Stack_Size; + elsif Size < Minimum_Stack_Size then + return Minimum_Stack_Size; + else + return Size; + end if; + end Adjust_Storage_Size; + + ------------------------ + -- Default_Stack_Size -- + ------------------------ + + function Default_Stack_Size return Size_Type is + Default_Stack_Size : Integer; + pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); + begin + if Default_Stack_Size = -1 then + return 2 * 1024 * 1024; + else + return Size_Type (Default_Stack_Size); + end if; + end Default_Stack_Size; + + ------------------------ + -- Minimum_Stack_Size -- + ------------------------ + + function Minimum_Stack_Size return Size_Type is + begin + -- 12K is required for stack-checking to work reliably on most platforms + -- when using the GCC scheme to propagate an exception in the ZCX case. + -- 16K is the value of PTHREAD_STACK_MIN under Linux, so is a reasonable + -- default. + + return 16 * 1024; + end Minimum_Stack_Size; + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parame.ads b/gcc/ada/libgnat/s-parame.ads new file mode 100644 index 0000000..f48c7e0 --- /dev/null +++ b/gcc/ada/libgnat/s-parame.ads @@ -0,0 +1,201 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P A R A M E T E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Default version used when no target-specific version is provided + +-- This package defines some system dependent parameters for GNAT. These +-- are values that are referenced by the runtime library and are therefore +-- relevant to the target machine. + +-- The parameters whose value is defined in the spec are not generally +-- expected to be changed. If they are changed, it will be necessary to +-- recompile the run-time library. + +-- The parameters which are defined by functions can be changed by modifying +-- the body of System.Parameters in file s-parame.adb. A change to this body +-- requires only rebinding and relinking of the application. + +-- Note: do not introduce any pragma Inline statements into this unit, since +-- otherwise the relinking and rebinding capability would be deactivated. + +pragma Compiler_Unit_Warning; + +package System.Parameters is + pragma Pure; + + --------------------------------------- + -- Task And Stack Allocation Control -- + --------------------------------------- + + type Task_Storage_Size is new Integer; + -- Type used in tasking units for task storage size + + type Size_Type is new Task_Storage_Size; + -- Type used to provide task storage size to runtime + + Unspecified_Size : constant Size_Type := Size_Type'First; + -- Value used to indicate that no size type is set + + subtype Percentage is Size_Type range -1 .. 100; + Dynamic : constant Size_Type := -1; + -- The secondary stack ratio is a constant between 0 and 100 which + -- determines the percentage of the allocated task stack that is + -- used by the secondary stack (the rest being the primary stack). + -- The special value of minus one indicates that the secondary + -- stack is to be allocated from the heap instead. + + Sec_Stack_Percentage : constant Percentage := Dynamic; + -- This constant defines the handling of the secondary stack + + Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + -- Convenient Boolean for testing for dynamic secondary stack + + function Default_Stack_Size return Size_Type; + -- Default task stack size used if none is specified + + function Minimum_Stack_Size return Size_Type; + -- Minimum task stack size permitted + + function Adjust_Storage_Size (Size : Size_Type) return Size_Type; + -- Given the storage size stored in the TCB, return the Storage_Size + -- value required by the RM for the Storage_Size attribute. The + -- required adjustment is as follows: + -- + -- when Size = Unspecified_Size, return Default_Stack_Size + -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size + -- otherwise return given Size + + Default_Env_Stack_Size : constant Size_Type := 8_192_000; + -- Assumed size of the environment task, if no other information + -- is available. This value is used when stack checking is + -- enabled and no GNAT_STACK_LIMIT environment variable is set. + + Stack_Grows_Down : constant Boolean := True; + -- This constant indicates whether the stack grows up (False) or + -- down (True) in memory as functions are called. It is used for + -- proper implementation of the stack overflow check. + + ---------------------------------------------- + -- Characteristics of types in Interfaces.C -- + ---------------------------------------------- + + long_bits : constant := Long_Integer'Size; + -- Number of bits in type long and unsigned_long. The normal convention + -- is that this is the same as type Long_Integer, but this may not be true + -- of all targets. + + ptr_bits : constant := Standard'Address_Size; + subtype C_Address is System.Address; + -- Number of bits in Interfaces.C pointers, normally a standard address + + C_Malloc_Linkname : constant String := "__gnat_malloc"; + -- Name of runtime function used to allocate such a pointer + + ---------------------------------------------- + -- Behavior of Pragma Finalize_Storage_Only -- + ---------------------------------------------- + + -- Garbage_Collected is a Boolean constant whose value indicates the + -- effect of the pragma Finalize_Storage_Entry on a controlled type. + + -- Garbage_Collected = False + + -- The system releases all storage on program termination only, + -- but not other garbage collection occurs, so finalization calls + -- are omitted only for outer level objects can be omitted if + -- pragma Finalize_Storage_Only is used. + + -- Garbage_Collected = True + + -- The system provides full garbage collection, so it is never + -- necessary to release storage for controlled objects for which + -- a pragma Finalize_Storage_Only is used. + + Garbage_Collected : constant Boolean := False; + -- The storage mode for this system (release on program exit) + + --------------------- + -- Tasking Profile -- + --------------------- + + -- In the following sections, constant parameters are defined to + -- allow some optimizations and fine tuning within the tasking run time + -- based on restrictions on the tasking features. + + ---------------------- + -- Locking Strategy -- + ---------------------- + + Single_Lock : constant Boolean := False; + -- Indicates whether a single lock should be used within the tasking + -- run-time to protect internal structures. If True, a single lock + -- will be used, meaning less locking/unlocking operations, but also + -- more global contention. In general, Single_Lock should be set to + -- True on single processor machines, and to False to multi-processor + -- systems, but this can vary from application to application and also + -- depends on the scheduling policy. + + ------------------- + -- Task Abortion -- + ------------------- + + No_Abort : constant Boolean := False; + -- This constant indicates whether abort statements and asynchronous + -- transfer of control (ATC) are disallowed. If set to True, it is + -- assumed that neither construct is used, and the run time does not + -- need to defer/undefer abort and check for pending actions at + -- completion points. A value of True for No_Abort corresponds to: + -- pragma Restrictions (No_Abort_Statements); + -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); + + --------------------- + -- Task Attributes -- + --------------------- + + Max_Attribute_Count : constant := 32; + -- Number of task attributes stored in the task control block + + ----------------------- + -- Task Image Length -- + ----------------------- + + Max_Task_Image_Length : constant := 256; + -- This constant specifies the maximum length of a task's image + + ------------------------------ + -- Exception Message Length -- + ------------------------------ + + Default_Exception_Msg_Max_Length : constant := 200; + -- This constant specifies the default number of characters to allow + -- in an exception message (200 is minimum required by RM 11.4.1(18)). + +end System.Parameters; diff --git a/gcc/ada/libgnat/s-parint.adb b/gcc/ada/libgnat/s-parint.adb new file mode 100644 index 0000000..8d2e83a --- /dev/null +++ b/gcc/ada/libgnat/s-parint.adb @@ -0,0 +1,320 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- +-- -- +-- B o d y -- +-- (Dummy body for non-distributed case) -- +-- -- +-- Copyright (C) 1995-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Partition_Interface is + + pragma Warnings (Off); -- suppress warnings for unreferenced formals + + M : constant := 7; + + type String_Access is access String; + + -- To have a minimal implementation of U'Partition_ID + + type Pkg_Node; + type Pkg_List is access Pkg_Node; + type Pkg_Node is record + Name : String_Access; + Subp_Info : System.Address; + Subp_Info_Len : Integer; + Next : Pkg_List; + end record; + + Pkg_Head : Pkg_List; + Pkg_Tail : Pkg_List; + + function getpid return Integer; + pragma Import (C, getpid); + + PID : constant Integer := getpid; + + function Lower (S : String) return String; + + Passive_Prefix : constant String := "SP__"; + -- String prepended in top of shared passive packages + + procedure Check + (Name : Unit_Name; + Version : String; + RCI : Boolean := True) + is + begin + null; + end Check; + + ----------------------------- + -- Get_Active_Partition_Id -- + ----------------------------- + + function Get_Active_Partition_ID + (Name : Unit_Name) return System.RPC.Partition_ID + is + P : Pkg_List := Pkg_Head; + N : String := Lower (Name); + + begin + while P /= null loop + if P.Name.all = N then + return Get_Local_Partition_ID; + end if; + + P := P.Next; + end loop; + + return M; + end Get_Active_Partition_ID; + + ------------------------ + -- Get_Active_Version -- + ------------------------ + + function Get_Active_Version (Name : Unit_Name) return String is + begin + return ""; + end Get_Active_Version; + + ---------------------------- + -- Get_Local_Partition_Id -- + ---------------------------- + + function Get_Local_Partition_ID return System.RPC.Partition_ID is + begin + return System.RPC.Partition_ID (PID mod M); + end Get_Local_Partition_ID; + + ------------------------------ + -- Get_Passive_Partition_ID -- + ------------------------------ + + function Get_Passive_Partition_ID + (Name : Unit_Name) return System.RPC.Partition_ID + is + begin + return Get_Local_Partition_ID; + end Get_Passive_Partition_ID; + + ------------------------- + -- Get_Passive_Version -- + ------------------------- + + function Get_Passive_Version (Name : Unit_Name) return String is + begin + return ""; + end Get_Passive_Version; + + ------------------ + -- Get_RAS_Info -- + ------------------ + + procedure Get_RAS_Info + (Name : Unit_Name; + Subp_Id : Subprogram_Id; + Proxy_Address : out Interfaces.Unsigned_64) + is + LName : constant String := Lower (Name); + N : Pkg_List; + begin + N := Pkg_Head; + while N /= null loop + if N.Name.all = LName then + declare + subtype Subprogram_Array is RCI_Subp_Info_Array + (First_RCI_Subprogram_Id .. + First_RCI_Subprogram_Id + N.Subp_Info_Len - 1); + Subprograms : Subprogram_Array; + for Subprograms'Address use N.Subp_Info; + pragma Import (Ada, Subprograms); + begin + Proxy_Address := + Interfaces.Unsigned_64 (Subprograms (Integer (Subp_Id)).Addr); + return; + end; + end if; + N := N.Next; + end loop; + Proxy_Address := 0; + end Get_RAS_Info; + + ------------------------------ + -- Get_RCI_Package_Receiver -- + ------------------------------ + + function Get_RCI_Package_Receiver + (Name : Unit_Name) return Interfaces.Unsigned_64 + is + begin + return 0; + end Get_RCI_Package_Receiver; + + ------------------------------- + -- Get_Unique_Remote_Pointer -- + ------------------------------- + + procedure Get_Unique_Remote_Pointer + (Handler : in out RACW_Stub_Type_Access) + is + begin + null; + end Get_Unique_Remote_Pointer; + + ----------- + -- Lower -- + ----------- + + function Lower (S : String) return String is + T : String := S; + + begin + for J in T'Range loop + if T (J) in 'A' .. 'Z' then + T (J) := Character'Val (Character'Pos (T (J)) - + Character'Pos ('A') + + Character'Pos ('a')); + end if; + end loop; + + return T; + end Lower; + + ------------------------------------- + -- Raise_Program_Error_Unknown_Tag -- + ------------------------------------- + + procedure Raise_Program_Error_Unknown_Tag + (E : Ada.Exceptions.Exception_Occurrence) + is + begin + raise Program_Error with Ada.Exceptions.Exception_Message (E); + end Raise_Program_Error_Unknown_Tag; + + ----------------- + -- RCI_Locator -- + ----------------- + + package body RCI_Locator is + + ----------------------------- + -- Get_Active_Partition_ID -- + ----------------------------- + + function Get_Active_Partition_ID return System.RPC.Partition_ID is + P : Pkg_List := Pkg_Head; + N : String := Lower (RCI_Name); + + begin + while P /= null loop + if P.Name.all = N then + return Get_Local_Partition_ID; + end if; + + P := P.Next; + end loop; + + return M; + end Get_Active_Partition_ID; + + ------------------------------ + -- Get_RCI_Package_Receiver -- + ------------------------------ + + function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is + begin + return 0; + end Get_RCI_Package_Receiver; + + end RCI_Locator; + + ------------------------------ + -- Register_Passive_Package -- + ------------------------------ + + procedure Register_Passive_Package + (Name : Unit_Name; + Version : String := "") + is + begin + Register_Receiving_Stub + (Passive_Prefix & Name, null, Version, System.Null_Address, 0); + end Register_Passive_Package; + + ----------------------------- + -- Register_Receiving_Stub -- + ----------------------------- + + procedure Register_Receiving_Stub + (Name : Unit_Name; + Receiver : RPC_Receiver; + Version : String := ""; + Subp_Info : System.Address; + Subp_Info_Len : Integer) + is + N : constant Pkg_List := + new Pkg_Node'(new String'(Lower (Name)), + Subp_Info, Subp_Info_Len, + Next => null); + begin + if Pkg_Tail = null then + Pkg_Head := N; + else + Pkg_Tail.Next := N; + end if; + Pkg_Tail := N; + end Register_Receiving_Stub; + + --------- + -- Run -- + --------- + + procedure Run + (Main : Main_Subprogram_Type := null) + is + begin + if Main /= null then + Main.all; + end if; + end Run; + + -------------------- + -- Same_Partition -- + -------------------- + + function Same_Partition + (Left : not null access RACW_Stub_Type; + Right : not null access RACW_Stub_Type) return Boolean + is + pragma Unreferenced (Left); + pragma Unreferenced (Right); + begin + return True; + end Same_Partition; + +end System.Partition_Interface; diff --git a/gcc/ada/libgnat/s-parint.ads b/gcc/ada/libgnat/s-parint.ads new file mode 100644 index 0000000..b64d456 --- /dev/null +++ b/gcc/ada/libgnat/s-parint.ads @@ -0,0 +1,191 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +with Ada.Exceptions; +with Ada.Streams; +with Interfaces; +with System.RPC; + +package System.Partition_Interface is + pragma Elaborate_Body; + + type DSA_Implementation_Name is (No_DSA, GARLIC_DSA, PolyORB_DSA); + DSA_Implementation : constant DSA_Implementation_Name := No_DSA; + -- Identification of this DSA implementation variant + + PCS_Version : constant := 1; + -- Version of the PCS API (for Exp_Dist consistency check) + -- + -- This version number is matched against corresponding element of + -- Exp_Dist.PCS_Version_Number to ensure that the versions of Exp_Dist + -- and the PCS are consistent. + + -- RCI receiving stubs contain a table of descriptors for all user + -- subprograms exported by the unit. + + type Subprogram_Id is new Natural; + First_RCI_Subprogram_Id : constant := 2; + + type RCI_Subp_Info is record + Addr : System.Address; + -- Local address of the proxy object + end record; + + type RCI_Subp_Info_Access is access all RCI_Subp_Info; + type RCI_Subp_Info_Array is array (Integer range <>) of + aliased RCI_Subp_Info; + + subtype Unit_Name is String; + -- Name of Ada units + + type Main_Subprogram_Type is access procedure; + + type RACW_Stub_Type is tagged record + Origin : RPC.Partition_ID; + Receiver : Interfaces.Unsigned_64; + Addr : Interfaces.Unsigned_64; + Asynchronous : Boolean; + end record; + + type RACW_Stub_Type_Access is access RACW_Stub_Type; + -- This type is used by the expansion to implement distributed objects. + -- Do not change its definition or its layout without updating + -- exp_dist.adb. + + type RAS_Proxy_Type is tagged limited record + All_Calls_Remote : Boolean; + Receiver : System.Address; + Subp_Id : Subprogram_Id; + end record; + + type RAS_Proxy_Type_Access is access RAS_Proxy_Type; + pragma No_Strict_Aliasing (RAS_Proxy_Type_Access); + -- This type is used by the expansion to implement distributed objects. + -- Do not change its definition or its layout without updating + -- Exp_Dist.Build_Remote_Subprogram_Proxy_Type. + + -- The Request_Access type is used for communication between the PCS + -- and the RPC receiver generated by the compiler: it contains all the + -- necessary information for the receiver to process an incoming call. + + type RST_Access is access all Ada.Streams.Root_Stream_Type'Class; + type Request_Access is record + Params : RST_Access; + -- A stream describing the called subprogram and its parameters + + Result : RST_Access; + -- A stream where the result, raised exception, or out values, + -- are marshalled. + end record; + + procedure Check + (Name : Unit_Name; + Version : String; + RCI : Boolean := True); + -- Use by the main subprogram to check that a remote receiver + -- unit has the same version than the caller's one. + + function Same_Partition + (Left : not null access RACW_Stub_Type; + Right : not null access RACW_Stub_Type) return Boolean; + -- Determine whether Left and Right correspond to objects instantiated + -- on the same partition, for enforcement of E.4(19). + + function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID; + -- Similar in some respects to RCI_Locator.Get_Active_Partition_ID + + function Get_Active_Version (Name : Unit_Name) return String; + -- Similar in some respects to Get_Active_Partition_ID + + function Get_Local_Partition_ID return RPC.Partition_ID; + -- Return the Partition_ID of the current partition + + function Get_Passive_Partition_ID + (Name : Unit_Name) return RPC.Partition_ID; + -- Return the Partition_ID of the given shared passive partition + + function Get_Passive_Version (Name : Unit_Name) return String; + -- Return the version corresponding to a shared passive unit + + function Get_RCI_Package_Receiver + (Name : Unit_Name) return Interfaces.Unsigned_64; + -- Similar in some respects to RCI_Locator.Get_RCI_Package_Receiver + + procedure Get_Unique_Remote_Pointer + (Handler : in out RACW_Stub_Type_Access); + -- Get a unique pointer on a remote object + + procedure Raise_Program_Error_Unknown_Tag + (E : Ada.Exceptions.Exception_Occurrence); + pragma No_Return (Raise_Program_Error_Unknown_Tag); + -- Raise Program_Error with the same message as E one + + type RPC_Receiver is access procedure (R : Request_Access); + procedure Register_Receiving_Stub + (Name : Unit_Name; + Receiver : RPC_Receiver; + Version : String := ""; + Subp_Info : System.Address; + Subp_Info_Len : Integer); + -- Register the fact that the Name receiving stub is now elaborated. + -- Register the access value to the package RPC_Receiver procedure. + + procedure Get_RAS_Info + (Name : Unit_Name; + Subp_Id : Subprogram_Id; + Proxy_Address : out Interfaces.Unsigned_64); + -- Look up the address of the proxy object for the given subprogram + -- in the named unit, or Null_Address if not present on the local + -- partition. + + procedure Register_Passive_Package + (Name : Unit_Name; + Version : String := ""); + -- Register a passive package + + generic + RCI_Name : String; + Version : String; + package RCI_Locator is + pragma Unreferenced (Version); + + function Get_RCI_Package_Receiver return Interfaces.Unsigned_64; + function Get_Active_Partition_ID return RPC.Partition_ID; + end RCI_Locator; + -- RCI package information caching + + procedure Run (Main : Main_Subprogram_Type := null); + -- Run the main subprogram + +end System.Partition_Interface; diff --git a/gcc/ada/libgnat/s-pooglo.adb b/gcc/ada/libgnat/s-pooglo.adb new file mode 100644 index 0000000..109dff0 --- /dev/null +++ b/gcc/ada/libgnat/s-pooglo.adb @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ G L O B A L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Pools; use System.Storage_Pools; +with System.Memory; + +package body System.Pool_Global is + + package SSE renames System.Storage_Elements; + + -------------- + -- Allocate -- + -------------- + + overriding procedure Allocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + use SSE; + pragma Warnings (Off, Pool); + + Aligned_Size : Storage_Count := Storage_Size; + Aligned_Address : System.Address; + Allocated : System.Address; + + begin + if Alignment > Standard'System_Allocator_Alignment then + Aligned_Size := Aligned_Size + Alignment; + end if; + + Allocated := Memory.Alloc (Memory.size_t (Aligned_Size)); + + -- The call to Alloc returns an address whose alignment is compatible + -- with the worst case alignment requirement for the machine; thus the + -- Alignment argument can be safely ignored. + + if Allocated = Null_Address then + raise Storage_Error; + end if; + + -- Case where alignment requested is greater than the alignment that is + -- guaranteed to be provided by the system allocator. + + if Alignment > Standard'System_Allocator_Alignment then + + -- Realign the returned address + + Aligned_Address := To_Address + (To_Integer (Allocated) + Integer_Address (Alignment) + - (To_Integer (Allocated) mod Integer_Address (Alignment))); + + -- Save the block address + + declare + Saved_Address : System.Address; + pragma Import (Ada, Saved_Address); + for Saved_Address'Address use + Aligned_Address + - Storage_Offset (System.Address'Size / Storage_Unit); + begin + Saved_Address := Allocated; + end; + + Address := Aligned_Address; + + else + Address := Allocated; + end if; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + overriding procedure Deallocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + use System.Storage_Elements; + pragma Warnings (Off, Pool); + pragma Warnings (Off, Storage_Size); + + begin + -- Case where the alignment of the block exceeds the guaranteed + -- alignment required by the system storage allocator, meaning that + -- this was specially wrapped at allocation time. + + if Alignment > Standard'System_Allocator_Alignment then + + -- Retrieve the block address + + declare + Saved_Address : System.Address; + pragma Import (Ada, Saved_Address); + for Saved_Address'Address use + Address - Storage_Offset (System.Address'Size / Storage_Unit); + begin + Memory.Free (Saved_Address); + end; + + else + Memory.Free (Address); + end if; + end Deallocate; + + ------------------ + -- Storage_Size -- + ------------------ + + overriding function Storage_Size + (Pool : Unbounded_No_Reclaim_Pool) + return SSE.Storage_Count + is + pragma Warnings (Off, Pool); + + begin + -- Intuitively, should return System.Memory_Size. But on Sun/Alsys, + -- System.Memory_Size > System.Max_Int, which means all you can do with + -- it is raise CONSTRAINT_ERROR... + + return SSE.Storage_Count'Last; + end Storage_Size; + +end System.Pool_Global; diff --git a/gcc/ada/libgnat/s-pooglo.ads b/gcc/ada/libgnat/s-pooglo.ads new file mode 100644 index 0000000..294f4eb --- /dev/null +++ b/gcc/ada/libgnat/s-pooglo.ads @@ -0,0 +1,79 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ G L O B A L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Storage pool corresponding to default global storage pool used for types +-- for which no storage pool is specified. + +with System; +with System.Storage_Pools; +with System.Storage_Elements; + +package System.Pool_Global is + pragma Elaborate_Body; + -- Needed to ensure that library routines can execute allocators + + -- Allocation strategy: + + -- Call to malloc/free for each Allocate/Deallocate + -- No user specifiable size + -- No automatic reclaim + -- Minimal overhead + + -- Pool simulating the allocation/deallocation strategy used by the + -- compiler for access types globally declared. + + type Unbounded_No_Reclaim_Pool is new + System.Storage_Pools.Root_Storage_Pool with null record; + + overriding function Storage_Size + (Pool : Unbounded_No_Reclaim_Pool) + return System.Storage_Elements.Storage_Count; + + overriding procedure Allocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + overriding procedure Deallocate + (Pool : in out Unbounded_No_Reclaim_Pool; + Address : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + -- Pool object used by the compiler when implicit Storage Pool objects are + -- explicitly referred to. For instance when writing something like: + -- for T'Storage_Pool use Q'Storage_Pool; + -- and Q'Storage_Pool hasn't been defined explicitly. + + Global_Pool_Object : aliased Unbounded_No_Reclaim_Pool; + +end System.Pool_Global; diff --git a/gcc/ada/libgnat/s-pooloc.adb b/gcc/ada/libgnat/s-pooloc.adb new file mode 100644 index 0000000..4611667 --- /dev/null +++ b/gcc/ada/libgnat/s-pooloc.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ L O C A L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Memory; + +with Ada.Unchecked_Conversion; + +package body System.Pool_Local is + + package SSE renames System.Storage_Elements; + use type SSE.Storage_Offset; + + Pointer_Size : constant SSE.Storage_Offset := Address'Size / Storage_Unit; + Pointers_Size : constant SSE.Storage_Offset := 2 * Pointer_Size; + + type Acc_Address is access all Address; + function To_Acc_Address is + new Ada.Unchecked_Conversion (Address, Acc_Address); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Next (A : Address) return Acc_Address; + pragma Inline (Next); + -- Given an address of a block, return an access to the next block + + function Prev (A : Address) return Acc_Address; + pragma Inline (Prev); + -- Given an address of a block, return an access to the previous block + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + pragma Warnings (Off, Alignment); + + Allocated : constant System.Address := + Memory.Alloc + (Memory.size_t (Storage_Size + Pointers_Size)); + + begin + -- The call to Alloc returns an address whose alignment is compatible + -- with the worst case alignment requirement for the machine; thus the + -- Alignment argument can be safely ignored. + + if Allocated = Null_Address then + raise Storage_Error; + else + Address := Allocated + Pointers_Size; + Next (Allocated).all := Pool.First; + Prev (Allocated).all := Null_Address; + + if Pool.First /= Null_Address then + Prev (Pool.First).all := Allocated; + end if; + + Pool.First := Allocated; + end if; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + pragma Warnings (Off, Storage_Size); + pragma Warnings (Off, Alignment); + + Allocated : constant System.Address := Address - Pointers_Size; + + begin + if Prev (Allocated).all = Null_Address then + Pool.First := Next (Allocated).all; + + -- Comment needed + + if Pool.First /= Null_Address then + Prev (Pool.First).all := Null_Address; + end if; + else + Next (Prev (Allocated).all).all := Next (Allocated).all; + end if; + + if Next (Allocated).all /= Null_Address then + Prev (Next (Allocated).all).all := Prev (Allocated).all; + end if; + + Memory.Free (Allocated); + end Deallocate; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (Pool : in out Unbounded_Reclaim_Pool) is + N : System.Address := Pool.First; + Allocated : System.Address; + + begin + while N /= Null_Address loop + Allocated := N; + N := Next (N).all; + Memory.Free (Allocated); + end loop; + end Finalize; + + ---------- + -- Next -- + ---------- + + function Next (A : Address) return Acc_Address is + begin + return To_Acc_Address (A); + end Next; + + ---------- + -- Prev -- + ---------- + + function Prev (A : Address) return Acc_Address is + begin + return To_Acc_Address (A + Pointer_Size); + end Prev; + +end System.Pool_Local; diff --git a/gcc/ada/libgnat/s-pooloc.ads b/gcc/ada/libgnat/s-pooloc.ads new file mode 100644 index 0000000..3891c2e --- /dev/null +++ b/gcc/ada/libgnat/s-pooloc.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ L O C A L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Storage pool for use with local objects with automatic reclaim + +with System.Storage_Elements; +with System.Pool_Global; + +package System.Pool_Local is + pragma Elaborate_Body; + -- Needed to ensure that library routines can execute allocators + + ---------------------------- + -- Unbounded_Reclaim_Pool -- + ---------------------------- + + -- Allocation strategy: + + -- Call to malloc/free for each Allocate/Deallocate + -- No user specifiable size + -- Space of allocated objects is reclaimed at pool finalization + -- Manages a list of allocated objects + + type Unbounded_Reclaim_Pool is new + System.Pool_Global.Unbounded_No_Reclaim_Pool with + record + First : System.Address := Null_Address; + end record; + + -- function Storage_Size is inherited + + procedure Allocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Deallocate + (Pool : in out Unbounded_Reclaim_Pool; + Address : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Finalize (Pool : in out Unbounded_Reclaim_Pool); + +end System.Pool_Local; diff --git a/gcc/ada/libgnat/s-poosiz.adb b/gcc/ada/libgnat/s-poosiz.adb new file mode 100644 index 0000000..8b268d0 --- /dev/null +++ b/gcc/ada/libgnat/s-poosiz.adb @@ -0,0 +1,412 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ S I Z E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Soft_Links; + +with Ada.Unchecked_Conversion; + +package body System.Pool_Size is + + package SSE renames System.Storage_Elements; + use type SSE.Storage_Offset; + + -- Even though these storage pools are typically only used by a single + -- task, if multiple tasks are declared at the same or a more nested scope + -- as the storage pool, there still may be concurrent access. The current + -- implementation of Stack_Bounded_Pool always uses a global lock for + -- protecting access. This should eventually be replaced by an atomic + -- linked list implementation for efficiency reasons. + + package SSL renames System.Soft_Links; + + type Storage_Count_Access is access SSE.Storage_Count; + function To_Storage_Count_Access is + new Ada.Unchecked_Conversion (Address, Storage_Count_Access); + + SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit; + + package Variable_Size_Management is + + -- Embedded pool that manages allocation of variable-size data + + -- This pool is used as soon as the Elmt_Size of the pool object is 0 + + -- Allocation is done on the first chunk long enough for the request. + -- Deallocation just puts the freed chunk at the beginning of the list. + + procedure Initialize (Pool : in out Stack_Bounded_Pool); + procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count); + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count); + end Variable_Size_Management; + + package Vsize renames Variable_Size_Management; + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + begin + SSL.Lock_Task.all; + + if Pool.Elmt_Size = 0 then + Vsize.Allocate (Pool, Address, Storage_Size, Alignment); + + elsif Pool.First_Free /= 0 then + Address := Pool.The_Pool (Pool.First_Free)'Address; + Pool.First_Free := To_Storage_Count_Access (Address).all; + + elsif + Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1) + then + Address := Pool.The_Pool (Pool.First_Empty)'Address; + Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size; + + else + raise Storage_Error; + end if; + + SSL.Unlock_Task.all; + + exception + when others => + SSL.Unlock_Task.all; + raise; + end Allocate; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + begin + SSL.Lock_Task.all; + + if Pool.Elmt_Size = 0 then + Vsize.Deallocate (Pool, Address, Storage_Size, Alignment); + + else + To_Storage_Count_Access (Address).all := Pool.First_Free; + Pool.First_Free := Address - Pool.The_Pool'Address + 1; + end if; + + SSL.Unlock_Task.all; + exception + when others => + SSL.Unlock_Task.all; + raise; + end Deallocate; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Pool : in out Stack_Bounded_Pool) is + + -- Define the appropriate alignment for allocations. This is the + -- maximum of the requested alignment, and the alignment required + -- for Storage_Count values. The latter test is to ensure that we + -- can properly reference the linked list pointers for free lists. + + Align : constant SSE.Storage_Count := + SSE.Storage_Count'Max + (SSE.Storage_Count'Alignment, Pool.Alignment); + + begin + if Pool.Elmt_Size = 0 then + Vsize.Initialize (Pool); + + else + Pool.First_Free := 0; + Pool.First_Empty := 1; + + -- Compute the size to allocate given the size of the element and + -- the possible alignment requirement as defined above. + + Pool.Aligned_Elmt_Size := + SSE.Storage_Count'Max (SC_Size, + ((Pool.Elmt_Size + Align - 1) / Align) * Align); + end if; + end Initialize; + + ------------------ + -- Storage_Size -- + ------------------ + + function Storage_Size + (Pool : Stack_Bounded_Pool) return SSE.Storage_Count + is + begin + return Pool.Pool_Size; + end Storage_Size; + + ------------------------------ + -- Variable_Size_Management -- + ------------------------------ + + package body Variable_Size_Management is + + Minimum_Size : constant := 2 * SC_Size; + + procedure Set_Size + (Pool : Stack_Bounded_Pool; + Chunk, Size : SSE.Storage_Count); + -- Update the field 'size' of a chunk of available storage + + procedure Set_Next + (Pool : Stack_Bounded_Pool; + Chunk, Next : SSE.Storage_Count); + -- Update the field 'next' of a chunk of available storage + + function Size + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) return SSE.Storage_Count; + -- Fetch the field 'size' of a chunk of available storage + + function Next + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) return SSE.Storage_Count; + -- Fetch the field 'next' of a chunk of available storage + + function Chunk_Of + (Pool : Stack_Bounded_Pool; + Addr : System.Address) return SSE.Storage_Count; + -- Give the chunk number in the pool from its Address + + -------------- + -- Allocate -- + -------------- + + procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + Chunk : SSE.Storage_Count; + New_Chunk : SSE.Storage_Count; + Prev_Chunk : SSE.Storage_Count; + Our_Align : constant SSE.Storage_Count := + SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, + Alignment); + Align_Size : constant SSE.Storage_Count := + SSE.Storage_Count'Max ( + Minimum_Size, + ((Storage_Size + Our_Align - 1) / Our_Align) * + Our_Align); + + begin + -- Look for the first big enough chunk + + Prev_Chunk := Pool.First_Free; + Chunk := Next (Pool, Prev_Chunk); + + while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop + Prev_Chunk := Chunk; + Chunk := Next (Pool, Chunk); + end loop; + + -- Raise storage_error if no big enough chunk available + + if Chunk = 0 then + raise Storage_Error; + end if; + + -- When the chunk is bigger than what is needed, take appropriate + -- amount and build a new shrinked chunk with the remainder. + + if Size (Pool, Chunk) - Align_Size > Minimum_Size then + New_Chunk := Chunk + Align_Size; + Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size); + Set_Next (Pool, New_Chunk, Next (Pool, Chunk)); + Set_Next (Pool, Prev_Chunk, New_Chunk); + + -- If the chunk is the right size, just delete it from the chain + + else + Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk)); + end if; + + Address := Pool.The_Pool (Chunk)'Address; + end Allocate; + + -------------- + -- Chunk_Of -- + -------------- + + function Chunk_Of + (Pool : Stack_Bounded_Pool; + Addr : System.Address) return SSE.Storage_Count + is + begin + return 1 + abs (Addr - Pool.The_Pool (1)'Address); + end Chunk_Of; + + ---------------- + -- Deallocate -- + ---------------- + + procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : SSE.Storage_Count; + Alignment : SSE.Storage_Count) + is + pragma Warnings (Off, Pool); + + Align_Size : constant SSE.Storage_Count := + ((Storage_Size + Alignment - 1) / Alignment) * + Alignment; + Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address); + + begin + -- Attach the freed chunk to the chain + + Set_Size (Pool, Chunk, + SSE.Storage_Count'Max (Align_Size, Minimum_Size)); + Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free)); + Set_Next (Pool, Pool.First_Free, Chunk); + + end Deallocate; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Pool : in out Stack_Bounded_Pool) is + begin + Pool.First_Free := 1; + + if Pool.Pool_Size > Minimum_Size then + Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size); + Set_Size (Pool, Pool.First_Free, 0); + Set_Size (Pool, Pool.First_Free + Minimum_Size, + Pool.Pool_Size - Minimum_Size); + Set_Next (Pool, Pool.First_Free + Minimum_Size, 0); + end if; + end Initialize; + + ---------- + -- Next -- + ---------- + + function Next + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) return SSE.Storage_Count + is + begin + pragma Warnings (Off); + -- Kill alignment warnings, we are careful to make sure + -- that the alignment is correct. + + return To_Storage_Count_Access + (Pool.The_Pool (Chunk + SC_Size)'Address).all; + + pragma Warnings (On); + end Next; + + -------------- + -- Set_Next -- + -------------- + + procedure Set_Next + (Pool : Stack_Bounded_Pool; + Chunk, Next : SSE.Storage_Count) + is + begin + pragma Warnings (Off); + -- Kill alignment warnings, we are careful to make sure + -- that the alignment is correct. + + To_Storage_Count_Access + (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next; + + pragma Warnings (On); + end Set_Next; + + -------------- + -- Set_Size -- + -------------- + + procedure Set_Size + (Pool : Stack_Bounded_Pool; + Chunk, Size : SSE.Storage_Count) + is + begin + pragma Warnings (Off); + -- Kill alignment warnings, we are careful to make sure + -- that the alignment is correct. + + To_Storage_Count_Access + (Pool.The_Pool (Chunk)'Address).all := Size; + + pragma Warnings (On); + end Set_Size; + + ---------- + -- Size -- + ---------- + + function Size + (Pool : Stack_Bounded_Pool; + Chunk : SSE.Storage_Count) return SSE.Storage_Count + is + begin + pragma Warnings (Off); + -- Kill alignment warnings, we are careful to make sure + -- that the alignment is correct. + + return To_Storage_Count_Access (Pool.The_Pool (Chunk)'Address).all; + + pragma Warnings (On); + end Size; + + end Variable_Size_Management; +end System.Pool_Size; diff --git a/gcc/ada/libgnat/s-poosiz.ads b/gcc/ada/libgnat/s-poosiz.ads new file mode 100644 index 0000000..092548e --- /dev/null +++ b/gcc/ada/libgnat/s-poosiz.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O O L _ S I Z E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Storage_Pools; +with System.Storage_Elements; + +package System.Pool_Size is + pragma Elaborate_Body; + -- Needed to ensure that library routines can execute allocators + + ------------------------ + -- Stack_Bounded_Pool -- + ------------------------ + + -- Allocation strategy: + + -- Pool is a regular stack array, no use of malloc + -- user specified size + -- Space of pool is globally reclaimed by normal stack management + + -- Used in the compiler for access types with 'STORAGE_SIZE rep. clause + -- Only used for allocating objects of the same type. + + type Stack_Bounded_Pool + (Pool_Size : System.Storage_Elements.Storage_Count; + Elmt_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is + new System.Storage_Pools.Root_Storage_Pool with record + First_Free : System.Storage_Elements.Storage_Count; + First_Empty : System.Storage_Elements.Storage_Count; + Aligned_Elmt_Size : System.Storage_Elements.Storage_Count; + The_Pool : System.Storage_Elements.Storage_Array + (1 .. Pool_Size); + end record; + + overriding function Storage_Size + (Pool : Stack_Bounded_Pool) return System.Storage_Elements.Storage_Count; + + overriding procedure Allocate + (Pool : in out Stack_Bounded_Pool; + Address : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + overriding procedure Deallocate + (Pool : in out Stack_Bounded_Pool; + Address : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + overriding procedure Initialize (Pool : in out Stack_Bounded_Pool); + +end System.Pool_Size; diff --git a/gcc/ada/libgnat/s-powtab.ads b/gcc/ada/libgnat/s-powtab.ads new file mode 100644 index 0000000..a41fc60 --- /dev/null +++ b/gcc/ada/libgnat/s-powtab.ads @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . P O W T E N _ T A B L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 powers of ten table used for real conversions + +package System.Powten_Table is + pragma Pure; + + Maxpow : constant := 22; + -- The number of entries in this table is chosen to include powers of ten + -- that are exactly representable with long_long_float. Assuming that on + -- all targets we have 53 bits of mantissa for the type, the upper bound is + -- given by 53/(log 5). If the scaling factor for a string is greater than + -- Maxpow, it can be obtained by several multiplications, which is less + -- efficient than with a bigger table, but avoids anomalies at end points. + + Powten : constant array (0 .. Maxpow) of Long_Long_Float := + (00 => 1.0E+00, + 01 => 1.0E+01, + 02 => 1.0E+02, + 03 => 1.0E+03, + 04 => 1.0E+04, + 05 => 1.0E+05, + 06 => 1.0E+06, + 07 => 1.0E+07, + 08 => 1.0E+08, + 09 => 1.0E+09, + 10 => 1.0E+10, + 11 => 1.0E+11, + 12 => 1.0E+12, + 13 => 1.0E+13, + 14 => 1.0E+14, + 15 => 1.0E+15, + 16 => 1.0E+16, + 17 => 1.0E+17, + 18 => 1.0E+18, + 19 => 1.0E+19, + 20 => 1.0E+20, + 21 => 1.0E+21, + 22 => 1.0E+22); + +end System.Powten_Table; diff --git a/gcc/ada/libgnat/s-purexc.ads b/gcc/ada/libgnat/s-purexc.ads new file mode 100644 index 0000000..946d21d --- /dev/null +++ b/gcc/ada/libgnat/s-purexc.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . P U R E _ E X C E P T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides an interface for raising predefined exceptions with +-- an exception message. It can be used from Pure units. This unit is for +-- internal use only, it is not generally available to applications. + +pragma Compiler_Unit_Warning; + +package System.Pure_Exceptions is + pragma Pure; + + type Exception_Type is limited null record; + -- Type used to specify which exception to raise + + -- Really Exception_Type is Exception_Id, but Exception_Id can't be + -- used directly since it is declared in the non-pure unit Ada.Exceptions, + + -- Exception_Id is in fact simply a pointer to the type Exception_Data + -- declared in System.Standard_Library (which is also non-pure). So what + -- we do is to define it here as a by reference type (any by reference + -- type would do), and then Import the definitions from Standard_Library. + -- Since this is a by reference type, these will be passed by reference, + -- which has the same effect as passing a pointer. + + -- This type is not private because keeping it by reference would require + -- defining it in a way (e.g. using a tagged type) that would drag in other + -- run-time files, which is unwanted in the case of e.g. Ravenscar, where + -- we want to minimize the number of run-time files needed by default. + + CE : constant Exception_Type; -- Constraint_Error + PE : constant Exception_Type; -- Program_Error + SE : constant Exception_Type; -- Storage_Error + TE : constant Exception_Type; -- Tasking_Error + -- One of these constants is used in the call to specify the exception + + procedure Raise_Exception (E : Exception_Type; Message : String); + pragma Import (Ada, Raise_Exception, "__gnat_raise_exception"); + pragma No_Return (Raise_Exception); + -- Raise specified exception with specified message + +private + pragma Import (C, CE, "constraint_error"); + pragma Import (C, PE, "program_error"); + pragma Import (C, SE, "storage_error"); + pragma Import (C, TE, "tasking_error"); + -- References to the exception structures in the standard library + +end System.Pure_Exceptions; diff --git a/gcc/ada/libgnat/s-rannum.adb b/gcc/ada/libgnat/s-rannum.adb new file mode 100644 index 0000000..002cf0c --- /dev/null +++ b/gcc/ada/libgnat/s-rannum.adb @@ -0,0 +1,693 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ N U M B E R S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- -- +-- The implementation here is derived from a C-program for MT19937, with -- +-- initialization improved 2002/1/26. As required, the following notice is -- +-- copied from the original program. -- +-- -- +-- Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, -- +-- All rights reserved. -- +-- -- +-- Redistribution and use in source and binary forms, with or without -- +-- modification, are permitted provided that the following conditions -- +-- are met: -- +-- -- +-- 1. Redistributions of source code must retain the above copyright -- +-- notice, this list of conditions and the following disclaimer. -- +-- -- +-- 2. Redistributions in binary form must reproduce the above copyright -- +-- notice, this list of conditions and the following disclaimer in the -- +-- documentation and/or other materials provided with the distribution.-- +-- -- +-- 3. The names of its contributors may not be used to endorse or promote -- +-- products derived from this software without specific prior written -- +-- permission. -- +-- -- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- +-- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- +-- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- +-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- +-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- +-- -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- -- +-- This is an implementation of the Mersenne Twister, twisted generalized -- +-- feedback shift register of rational normal form, with state-bit -- +-- reflection and tempering. This version generates 32-bit integers with a -- +-- period of 2**19937 - 1 (a Mersenne prime, hence the name). For -- +-- applications requiring more than 32 bits (up to 64), we concatenate two -- +-- 32-bit numbers. -- +-- -- +-- See http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html for -- +-- details. -- +-- -- +-- In contrast to the original code, we do not generate random numbers in -- +-- batches of N. Measurement seems to show this has very little if any -- +-- effect on performance, and it may be marginally better for real-time -- +-- applications with hard deadlines. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with System.Random_Seed; + +with Interfaces; use Interfaces; + +use Ada; + +package body System.Random_Numbers with + SPARK_Mode => Off +is + Image_Numeral_Length : constant := Max_Image_Width / N; + + subtype Image_String is String (1 .. Max_Image_Width); + + ---------------------------- + -- Algorithmic Parameters -- + ---------------------------- + + Lower_Mask : constant := 2**31 - 1; + Upper_Mask : constant := 2**31; + + Matrix_A : constant array (State_Val range 0 .. 1) of State_Val + := (0, 16#9908b0df#); + -- The twist transformation is represented by a matrix of the form + -- + -- [ 0 I(31) ] + -- [ _a ] + -- + -- where 0 is a 31x31 block of 0s, I(31) is the 31x31 identity matrix and + -- _a is a particular bit row-vector, represented here by a 32-bit integer. + -- If integer x represents a row vector of bits (with x(0), the units bit, + -- last), then + -- x * A = [0 x(31..1)] xor Matrix_A(x(0)). + + U : constant := 11; + S : constant := 7; + B_Mask : constant := 16#9d2c5680#; + T : constant := 15; + C_Mask : constant := 16#efc60000#; + L : constant := 18; + -- The tempering shifts and bit masks, in the order applied + + Seed0 : constant := 5489; + -- Default seed, used to initialize the state vector when Reset not called + + Seed1 : constant := 19650218; + -- Seed used to initialize the state vector when calling Reset with an + -- initialization vector. + + Mult0 : constant := 1812433253; + -- Multiplier for a modified linear congruential generator used to + -- initialize the state vector when calling Reset with a single integer + -- seed. + + Mult1 : constant := 1664525; + Mult2 : constant := 1566083941; + -- Multipliers for two modified linear congruential generators used to + -- initialize the state vector when calling Reset with an initialization + -- vector. + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Init (Gen : Generator; Initiator : Unsigned_32); + -- Perform a default initialization of the state of Gen. The resulting + -- state is identical for identical values of Initiator. + + procedure Insert_Image + (S : in out Image_String; + Index : Integer; + V : State_Val); + -- Insert image of V into S, in the Index'th 11-character substring + + function Extract_Value (S : String; Index : Integer) return State_Val; + -- Treat S as a sequence of 11-character decimal numerals and return + -- the result of converting numeral #Index (numbering from 0) + + function To_Unsigned is + new Unchecked_Conversion (Integer_32, Unsigned_32); + function To_Unsigned is + new Unchecked_Conversion (Integer_64, Unsigned_64); + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Unsigned_32 is + G : Generator renames Gen.Writable.Self.all; + Y : State_Val; + I : Integer; -- should avoid use of identifier I ??? + + begin + I := G.I; + + if I < N - M then + Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); + Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); + I := I + 1; + + elsif I < N - 1 then + Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); + Y := G.S (I + (M - N)) + xor Shift_Right (Y, 1) + xor Matrix_A (Y and 1); + I := I + 1; + + elsif I = N - 1 then + Y := (G.S (I) and Upper_Mask) or (G.S (0) and Lower_Mask); + Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); + I := 0; + + else + Init (G, Seed0); + return Random (Gen); + end if; + + G.S (G.I) := Y; + G.I := I; + + Y := Y xor Shift_Right (Y, U); + Y := Y xor (Shift_Left (Y, S) and B_Mask); + Y := Y xor (Shift_Left (Y, T) and C_Mask); + Y := Y xor Shift_Right (Y, L); + + return Y; + end Random; + + generic + type Unsigned is mod <>; + type Real is digits <>; + with function Random (G : Generator) return Unsigned is <>; + function Random_Float_Template (Gen : Generator) return Real; + pragma Inline (Random_Float_Template); + -- Template for a random-number generator implementation that delivers + -- values of type Real in the range [0 .. 1], using values from Gen, + -- assuming that Unsigned is large enough to hold the bits of a mantissa + -- for type Real. + + --------------------------- + -- Random_Float_Template -- + --------------------------- + + function Random_Float_Template (Gen : Generator) return Real is + + pragma Compile_Time_Error + (Unsigned'Last <= 2**(Real'Machine_Mantissa - 1), + "insufficiently large modular type used to hold mantissa"); + + begin + -- This code generates random floating-point numbers from unsigned + -- integers. Assuming that Real'Machine_Radix = 2, it can deliver all + -- machine values of type Real (as implied by Real'Machine_Mantissa and + -- Real'Machine_Emin), which is not true of the standard method (to + -- which we fall back for nonbinary radix): computing Real() / (+1). To do so, we first extract an + -- (M-1)-bit significand (where M is Real'Machine_Mantissa), and then + -- decide on a normalized exponent by repeated coin flips, decrementing + -- from 0 as long as we flip heads (1 bits). This process yields the + -- proper geometric distribution for the exponent: in a uniformly + -- distributed set of floating-point numbers, 1/2 of them will be in + -- (0.5, 1], 1/4 will be in (0.25, 0.5], and so forth. It makes a + -- further adjustment at binade boundaries (see comments below) to give + -- the effect of selecting a uniformly distributed real deviate in + -- [0..1] and then rounding to the nearest representable floating-point + -- number. The algorithm attempts to be stingy with random integers. In + -- the worst case, it can consume roughly -Real'Machine_Emin/32 32-bit + -- integers, but this case occurs with probability around + -- 2**Machine_Emin, and the expected number of calls to integer-valued + -- Random is 1. For another discussion of the issues addressed by this + -- process, see Allen Downey's unpublished paper at + -- http://allendowney.com/research/rand/downey07randfloat.pdf. + + if Real'Machine_Radix /= 2 then + return Real'Machine + (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); + + else + declare + type Bit_Count is range 0 .. 4; + + subtype T is Real'Base; + + Trailing_Ones : constant array (Unsigned_32 range 0 .. 15) + of Bit_Count := + (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, + 2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3, + 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, + 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4); + + Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real + := (0 => 2.0**(0 - T'Machine_Mantissa), + 1 => 2.0**(-1 - T'Machine_Mantissa), + 2 => 2.0**(-2 - T'Machine_Mantissa), + 3 => 2.0**(-3 - T'Machine_Mantissa)); + + Extra_Bits : constant Natural := + (Unsigned'Size - T'Machine_Mantissa + 1); + -- Random bits left over after selecting mantissa + + Mantissa : Unsigned; + + X : Real; -- Scaled mantissa + R : Unsigned_32; -- Supply of random bits + R_Bits : Natural; -- Number of bits left in R + K : Bit_Count; -- Next decrement to exponent + + begin + Mantissa := Random (Gen) / 2**Extra_Bits; + R := Unsigned_32 (Mantissa mod 2**Extra_Bits); + R_Bits := Extra_Bits; + X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact + + if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then + + -- We got lucky and got a zero in our few extra bits + + K := Trailing_Ones (R); + + else + Find_Zero : loop + + -- R has R_Bits unprocessed random bits, a multiple of 4. + -- X needs to be halved for each trailing one bit. The + -- process stops as soon as a 0 bit is found. If R_Bits + -- becomes zero, reload R. + + -- Process 4 bits at a time for speed: the two iterations + -- on average with three tests each was still too slow, + -- probably because the branches are not predictable. + -- This loop now will only execute once 94% of the cases, + -- doing more bits at a time will not help. + + while R_Bits >= 4 loop + K := Trailing_Ones (R mod 16); + + exit Find_Zero when K < 4; -- Exits 94% of the time + + R_Bits := R_Bits - 4; + X := X / 16.0; + R := R / 16; + end loop; + + -- Do not allow us to loop endlessly even in the (very + -- unlikely) case that Random (Gen) keeps yielding all ones. + + exit Find_Zero when X = 0.0; + R := Random (Gen); + R_Bits := 32; + end loop Find_Zero; + end if; + + -- K has the count of trailing ones not reflected yet in X. The + -- following multiplication takes care of that, as well as the + -- correction to move the radix point to the left of the mantissa. + -- Doing it at the end avoids repeated rounding errors in the + -- exceedingly unlikely case of ever having a subnormal result. + + X := X * Pow_Tab (K); + + -- The smallest value in each binade is rounded to by 0.75 of + -- the span of real numbers as its next larger neighbor, and + -- 1.0 is rounded to by half of the span of real numbers as its + -- next smaller neighbor. To account for this, when we encounter + -- the smallest number in a binade, we substitute the smallest + -- value in the next larger binade with probability 1/2. + + if Mantissa = 0 and then Unsigned_32'(Random (Gen)) mod 2 = 0 then + X := 2.0 * X; + end if; + + return X; + end; + end if; + end Random_Float_Template; + + ------------ + -- Random -- + ------------ + + function Random (Gen : Generator) return Float is + function F is new Random_Float_Template (Unsigned_32, Float); + begin + return F (Gen); + end Random; + + function Random (Gen : Generator) return Long_Float is + function F is new Random_Float_Template (Unsigned_64, Long_Float); + begin + return F (Gen); + end Random; + + function Random (Gen : Generator) return Unsigned_64 is + begin + return Shift_Left (Unsigned_64 (Unsigned_32'(Random (Gen))), 32) + or Unsigned_64 (Unsigned_32'(Random (Gen))); + end Random; + + --------------------- + -- Random_Discrete -- + --------------------- + + function Random_Discrete + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype + is + begin + if Max = Min then + return Max; + + elsif Max < Min then + raise Constraint_Error; + + elsif Result_Subtype'Base'Size > 32 then + declare + -- In the 64-bit case, we have to be careful, since not all 64-bit + -- unsigned values are representable in GNAT's root_integer type. + -- Ignore different-size warnings here since GNAT's handling + -- is correct. + + pragma Warnings ("Z"); + function Conv_To_Unsigned is + new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64); + function Conv_To_Result is + new Unchecked_Conversion (Unsigned_64, Result_Subtype'Base); + pragma Warnings ("z"); + + N : constant Unsigned_64 := + Conv_To_Unsigned (Max) - Conv_To_Unsigned (Min) + 1; + + X, Slop : Unsigned_64; + + begin + if N = 0 then + return Conv_To_Result (Conv_To_Unsigned (Min) + Random (Gen)); + + else + Slop := Unsigned_64'Last rem N + 1; + + loop + X := Random (Gen); + exit when Slop = N or else X <= Unsigned_64'Last - Slop; + end loop; + + return Conv_To_Result (Conv_To_Unsigned (Min) + X rem N); + end if; + end; + + elsif Result_Subtype'Pos (Max) - Result_Subtype'Pos (Min) = + 2 ** 32 - 1 + then + return Result_Subtype'Val + (Result_Subtype'Pos (Min) + Unsigned_32'Pos (Random (Gen))); + else + declare + N : constant Unsigned_32 := + Unsigned_32 (Result_Subtype'Pos (Max) - + Result_Subtype'Pos (Min) + 1); + Slop : constant Unsigned_32 := Unsigned_32'Last rem N + 1; + X : Unsigned_32; + + begin + loop + X := Random (Gen); + exit when Slop = N or else X <= Unsigned_32'Last - Slop; + end loop; + + return + Result_Subtype'Val + (Result_Subtype'Pos (Min) + Unsigned_32'Pos (X rem N)); + end; + end if; + end Random_Discrete; + + ------------------ + -- Random_Float -- + ------------------ + + function Random_Float (Gen : Generator) return Result_Subtype is + begin + if Result_Subtype'Base'Digits > Float'Digits then + return Result_Subtype'Machine (Result_Subtype + (Long_Float'(Random (Gen)))); + else + return Result_Subtype'Machine (Result_Subtype + (Float'(Random (Gen)))); + end if; + end Random_Float; + + ----------- + -- Reset -- + ----------- + + procedure Reset (Gen : Generator) is + begin + Init (Gen, Unsigned_32'Mod (Random_Seed.Get_Seed)); + end Reset; + + procedure Reset (Gen : Generator; Initiator : Integer_32) is + begin + Init (Gen, To_Unsigned (Initiator)); + end Reset; + + procedure Reset (Gen : Generator; Initiator : Unsigned_32) is + begin + Init (Gen, Initiator); + end Reset; + + procedure Reset (Gen : Generator; Initiator : Integer) is + begin + -- This is probably an unnecessary precaution against future change, but + -- since the test is a static expression, no extra code is involved. + + if Integer'Size <= 32 then + Init (Gen, To_Unsigned (Integer_32 (Initiator))); + + else + declare + Initiator1 : constant Unsigned_64 := + To_Unsigned (Integer_64 (Initiator)); + Init0 : constant Unsigned_32 := + Unsigned_32 (Initiator1 mod 2 ** 32); + Init1 : constant Unsigned_32 := + Unsigned_32 (Shift_Right (Initiator1, 32)); + begin + Reset (Gen, Initialization_Vector'(Init0, Init1)); + end; + end if; + end Reset; + + procedure Reset (Gen : Generator; Initiator : Initialization_Vector) is + G : Generator renames Gen.Writable.Self.all; + I, J : Integer; + + begin + Init (G, Seed1); + I := 1; + J := 0; + + if Initiator'Length > 0 then + for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult1)) + + Initiator (J + Initiator'First) + Unsigned_32 (J); + + I := I + 1; + J := J + 1; + + if I >= N then + G.S (0) := G.S (N - 1); + I := 1; + end if; + + if J >= Initiator'Length then + J := 0; + end if; + end loop; + end if; + + for K in reverse 1 .. N - 1 loop + G.S (I) := + (G.S (I) xor ((G.S (I - 1) + xor Shift_Right (G.S (I - 1), 30)) * Mult2)) + - Unsigned_32 (I); + I := I + 1; + + if I >= N then + G.S (0) := G.S (N - 1); + I := 1; + end if; + end loop; + + G.S (0) := Upper_Mask; + end Reset; + + procedure Reset (Gen : Generator; From_State : Generator) is + G : Generator renames Gen.Writable.Self.all; + begin + G.S := From_State.S; + G.I := From_State.I; + end Reset; + + procedure Reset (Gen : Generator; From_State : State) is + G : Generator renames Gen.Writable.Self.all; + begin + G.I := 0; + G.S := From_State; + end Reset; + + procedure Reset (Gen : Generator; From_Image : String) is + G : Generator renames Gen.Writable.Self.all; + begin + G.I := 0; + + for J in 0 .. N - 1 loop + G.S (J) := Extract_Value (From_Image, J); + end loop; + end Reset; + + ---------- + -- Save -- + ---------- + + procedure Save (Gen : Generator; To_State : out State) is + Gen2 : Generator; + + begin + if Gen.I = N then + Init (Gen2, 5489); + To_State := Gen2.S; + + else + To_State (0 .. N - 1 - Gen.I) := Gen.S (Gen.I .. N - 1); + To_State (N - Gen.I .. N - 1) := Gen.S (0 .. Gen.I - 1); + end if; + end Save; + + ----------- + -- Image -- + ----------- + + function Image (Of_State : State) return String is + Result : Image_String; + + begin + Result := (others => ' '); + + for J in Of_State'Range loop + Insert_Image (Result, J, Of_State (J)); + end loop; + + return Result; + end Image; + + function Image (Gen : Generator) return String is + Result : Image_String; + + begin + Result := (others => ' '); + for J in 0 .. N - 1 loop + Insert_Image (Result, J, Gen.S ((J + Gen.I) mod N)); + end loop; + + return Result; + end Image; + + ----------- + -- Value -- + ----------- + + function Value (Coded_State : String) return State is + Gen : Generator; + S : State; + begin + Reset (Gen, Coded_State); + Save (Gen, S); + return S; + end Value; + + ---------- + -- Init -- + ---------- + + procedure Init (Gen : Generator; Initiator : Unsigned_32) is + G : Generator renames Gen.Writable.Self.all; + begin + G.S (0) := Initiator; + + for I in 1 .. N - 1 loop + G.S (I) := + (G.S (I - 1) xor Shift_Right (G.S (I - 1), 30)) * Mult0 + + Unsigned_32 (I); + end loop; + + G.I := 0; + end Init; + + ------------------ + -- Insert_Image -- + ------------------ + + procedure Insert_Image + (S : in out Image_String; + Index : Integer; + V : State_Val) + is + Value : constant String := State_Val'Image (V); + begin + S (Index * 11 + 1 .. Index * 11 + Value'Length) := Value; + end Insert_Image; + + ------------------- + -- Extract_Value -- + ------------------- + + function Extract_Value (S : String; Index : Integer) return State_Val is + Start : constant Integer := S'First + Index * Image_Numeral_Length; + begin + return State_Val'Value (S (Start .. Start + Image_Numeral_Length - 1)); + end Extract_Value; + +end System.Random_Numbers; diff --git a/gcc/ada/libgnat/s-rannum.ads b/gcc/ada/libgnat/s-rannum.ads new file mode 100644 index 0000000..e76a56d --- /dev/null +++ b/gcc/ada/libgnat/s-rannum.ads @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ N U M B E R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Extended pseudo-random number generation + +-- This package provides a type representing pseudo-random number generators, +-- and subprograms to extract various uniform distributions of numbers +-- from them. It also provides types for representing initialization values +-- and snapshots of internal generator state, which permit reproducible +-- pseudo-random streams. + +-- The generator currently provided by this package has an extremely long +-- period (at least 2**19937-1), and passes the Big Crush test suite, with the +-- exception of the two linear complexity tests. Therefore, it is suitable +-- for simulations, but should not be used as a cryptographic pseudo-random +-- source without additional processing. + +-- Note: this package is in the System hierarchy so that it can be directly +-- used by other predefined packages. User access to this package is via +-- the package GNAT.Random_Numbers (file g-rannum.ads), which also extends +-- its capabilities. The interfaces are different so as to include in +-- System.Random_Numbers only the definitions necessary to implement the +-- standard random-number packages Ada.Numerics.Float_Random and +-- Ada.Numerics.Discrete_Random. + +-- Note: this package is marked SPARK_Mode Off, because functions Random work +-- by side-effect to change the value of the generator, hence they should not +-- be called from SPARK code. + +with Interfaces; + +package System.Random_Numbers with + SPARK_Mode => Off +is + type Generator is limited private; + -- Generator encodes the current state of a random number stream, it is + -- provided as input to produce the next random number, and updated so + -- that it is ready to produce the next one. + + type State is private; + -- A non-limited version of a Generator's internal state + + function Random (Gen : Generator) return Float; + function Random (Gen : Generator) return Long_Float; + -- Return pseudo-random numbers uniformly distributed on [0.0 .. 1.0) + + function Random (Gen : Generator) return Interfaces.Unsigned_32; + function Random (Gen : Generator) return Interfaces.Unsigned_64; + -- Return pseudo-random numbers uniformly distributed on T'First .. T'Last + -- for builtin integer types. + + generic + type Result_Subtype is (<>); + Default_Min : Result_Subtype := Result_Subtype'Val (0); + function Random_Discrete + (Gen : Generator; + Min : Result_Subtype := Default_Min; + Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; + -- Returns pseudo-random numbers uniformly distributed on Min .. Max + + generic + type Result_Subtype is digits <>; + function Random_Float (Gen : Generator) return Result_Subtype; + -- Returns pseudo-random numbers uniformly distributed on [0 .. 1) + + type Initialization_Vector is + array (Integer range <>) of Interfaces.Unsigned_32; + -- Provides the most general initialization values for a generator (used + -- in Reset). In general, there is little point in providing more than + -- a certain number of values (currently 624). + + procedure Reset (Gen : Generator); + -- Re-initialize the state of Gen from the time of day + + procedure Reset (Gen : Generator; Initiator : Initialization_Vector); + procedure Reset (Gen : Generator; Initiator : Interfaces.Integer_32); + procedure Reset (Gen : Generator; Initiator : Interfaces.Unsigned_32); + procedure Reset (Gen : Generator; Initiator : Integer); + -- Re-initialize Gen based on the Initiator in various ways. Identical + -- values of Initiator cause identical sequences of values. + + procedure Reset (Gen : Generator; From_State : Generator); + -- Causes the state of Gen to be identical to that of From_State; Gen + -- and From_State will produce identical sequences of values subsequently. + + procedure Reset (Gen : Generator; From_State : State); + procedure Save (Gen : Generator; To_State : out State); + -- The sequence + -- Save (Gen2, S); Reset (Gen1, S) + -- has the same effect as Reset (Gen2, Gen1). + + procedure Reset (Gen : Generator; From_Image : String); + function Image (Gen : Generator) return String; + -- The call + -- Reset (Gen2, Image (Gen1)) + -- has the same effect as Reset (Gen2, Gen1); + + Max_Image_Width : constant := 11 * 624; + -- Maximum possible length of result of Image (...) + + function Image (Of_State : State) return String; + -- A String representation of Of_State. Identical to the result of + -- Image (Gen), if Of_State has been set with Save (Gen, Of_State). + + function Value (Coded_State : String) return State; + -- Inverse of Image on States + +private + + N : constant := 624; + -- The number of 32-bit integers in the shift register + + M : constant := 397; + -- Feedback distance from the current position + + subtype State_Val is Interfaces.Unsigned_32; + type State is array (0 .. N - 1) of State_Val; + + type Writable_Access (Self : access Generator) is limited null record; + -- Auxiliary type to make Generator a self-referential type + + type Generator is limited record + Writable : Writable_Access (Generator'Access); + -- This self reference allows functions to modify Generator arguments + + S : State := (others => 0); + -- The shift register, a circular buffer + + I : Integer := N; + -- Current starting position in shift register S (N means uninitialized) + -- We should avoid using the identifier I here ??? + end record; + +end System.Random_Numbers; diff --git a/gcc/ada/libgnat/s-ransee.adb b/gcc/ada/libgnat/s-ransee.adb new file mode 100644 index 0000000..e563952 --- /dev/null +++ b/gcc/ada/libgnat/s-ransee.adb @@ -0,0 +1,55 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ S E E D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Version used on all systems except Ravenscar where Calendar is unavailable + +with Ada.Calendar; use Ada.Calendar; +with Ada.Unchecked_Conversion; + +package body System.Random_Seed is + + Y2K : constant Time := + Time_Of (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); + -- First day of Year 2000, to get a duration + + function To_U64 is + new Ada.Unchecked_Conversion (Duration, Interfaces.Unsigned_64); + + -------------- + -- Get_Seed -- + -------------- + + function Get_Seed return Interfaces.Unsigned_64 is + begin + return To_U64 (Clock - Y2K); + end Get_Seed; + +end System.Random_Seed; diff --git a/gcc/ada/libgnat/s-ransee.ads b/gcc/ada/libgnat/s-ransee.ads new file mode 100644 index 0000000..ff76ed0 --- /dev/null +++ b/gcc/ada/libgnat/s-ransee.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R A N D O M _ S E E D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provide a seed for pseudo-random number generation using +-- the clock. + +-- There are two separate implementations of this package: +-- o one based on Ada.Calendar +-- o one based on Ada.Real_Time + +-- This is required because Ada.Calendar cannot be used on Ravenscar, but +-- Ada.Real_Time drags in the whole tasking runtime on regular platforms. + +with Interfaces; + +package System.Random_Seed is + + function Get_Seed return Interfaces.Unsigned_64; + -- Get a seed based on the clock + +end System.Random_Seed; diff --git a/gcc/ada/libgnat/s-regexp.adb b/gcc/ada/libgnat/s-regexp.adb new file mode 100644 index 0000000..58a63a2 --- /dev/null +++ b/gcc/ada/libgnat/s-regexp.adb @@ -0,0 +1,1729 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R E G E X P -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; +with System.Case_Util; + +package body System.Regexp is + + Initial_Max_States_In_Primary_Table : constant := 100; + -- Initial size for the number of states in the indefinite state + -- machine. The number of states will be increased as needed. + -- + -- This is also used as the maximal number of meta states (groups of + -- states) in the secondary table. + + Open_Paren : constant Character := '('; + Close_Paren : constant Character := ')'; + Open_Bracket : constant Character := '['; + Close_Bracket : constant Character := ']'; + + type State_Index is new Natural; + type Column_Index is new Natural; + + type Regexp_Array is array + (State_Index range <>, Column_Index range <>) of State_Index; + -- First index is for the state number. Second index is for the character + -- type. Contents is the new State. + + type Regexp_Array_Access is access Regexp_Array; + -- Use this type through the functions Set below, so that it can grow + -- dynamically depending on the needs. + + type Mapping is array (Character'Range) of Column_Index; + -- Mapping between characters and column in the Regexp_Array + + type Boolean_Array is array (State_Index range <>) of Boolean; + + type Regexp_Value + (Alphabet_Size : Column_Index; + Num_States : State_Index) is + record + Map : Mapping; + Case_Sensitive : Boolean; + States : Regexp_Array (1 .. Num_States, 0 .. Alphabet_Size); + Is_Final : Boolean_Array (1 .. Num_States); + end record; + -- Deterministic finite-state machine + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Set + (Table : in out Regexp_Array_Access; + State : State_Index; + Column : Column_Index; + Value : State_Index); + -- Sets a value in the table. If the table is too small, reallocate it + -- dynamically so that (State, Column) is a valid index in it. + + function Get + (Table : Regexp_Array_Access; + State : State_Index; + Column : Column_Index) return State_Index; + -- Returns the value in the table at (State, Column). If this index does + -- not exist in the table, returns zero. + + procedure Free is new Ada.Unchecked_Deallocation + (Regexp_Array, Regexp_Array_Access); + + ------------ + -- Adjust -- + ------------ + + procedure Adjust (R : in out Regexp) is + Tmp : Regexp_Access; + begin + if R.R /= null then + Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size, + Num_States => R.R.Num_States); + Tmp.all := R.R.all; + R.R := Tmp; + end if; + end Adjust; + + ------------- + -- Compile -- + ------------- + + function Compile + (Pattern : String; + Glob : Boolean := False; + Case_Sensitive : Boolean := True) return Regexp + is + S : String := Pattern; + -- The pattern which is really compiled (when the pattern is case + -- insensitive, we convert this string to lower-cases + + Map : Mapping := (others => 0); + -- Mapping between characters and columns in the tables + + Alphabet_Size : Column_Index := 0; + -- Number of significant characters in the regular expression. + -- This total does not include special operators, such as *, (, ... + + procedure Check_Well_Formed_Pattern; + -- Check that the pattern to compile is well-formed, so that subsequent + -- code can rely on this without performing each time the checks to + -- avoid accessing the pattern outside its bounds. However, not all + -- well-formedness rules are checked. In particular, rules about special + -- characters not being treated as regular characters are not checked. + + procedure Create_Mapping; + -- Creates a mapping between characters in the regexp and columns + -- in the tables representing the regexp. Test that the regexp is + -- well-formed Modifies Alphabet_Size and Map + + procedure Create_Primary_Table + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index); + -- Creates the first version of the regexp (this is a non deterministic + -- finite state machine, which is unadapted for a fast pattern + -- matching algorithm). We use a recursive algorithm to process the + -- parenthesis sub-expressions. + -- + -- Table : at the end of the procedure : Column 0 is for any character + -- ('.') and the last columns are for no character (closure). Num_States + -- is set to the number of states in the table Start_State is the number + -- of the starting state in the regexp End_State is the number of the + -- final state when the regexp matches. + + procedure Create_Primary_Table_Glob + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index); + -- Same function as above, but it deals with the second possible + -- grammar for 'globbing pattern', which is a kind of subset of the + -- whole regular expression grammar. + + function Create_Secondary_Table + (First_Table : Regexp_Array_Access; + Start_State : State_Index; + End_State : State_Index) return Regexp; + -- Creates the definitive table representing the regular expression + -- This is actually a transformation of the primary table First_Table, + -- where every state is grouped with the states in its 'no-character' + -- columns. The transitions between the new states are then recalculated + -- and if necessary some new states are created. + -- + -- Note that the resulting finite-state machine is not optimized in + -- terms of the number of states : it would be more time-consuming to + -- add a third pass to reduce the number of states in the machine, with + -- no speed improvement... + + procedure Raise_Exception (M : String; Index : Integer); + pragma No_Return (Raise_Exception); + -- Raise an exception, indicating an error at character Index in S + + ------------------------------- + -- Check_Well_Formed_Pattern -- + ------------------------------- + + procedure Check_Well_Formed_Pattern is + J : Integer; + + Past_Elmt : Boolean := False; + -- Set to True everywhere an elmt has been parsed, if Glob=False, + -- meaning there can be now an occurrence of '*', '+' and '?'. + + Past_Term : Boolean := False; + -- Set to True everywhere a term has been parsed, if Glob=False, + -- meaning there can be now an occurrence of '|'. + + Parenthesis_Level : Integer := 0; + Curly_Level : Integer := 0; + + Last_Open : Integer := S'First - 1; + -- The last occurrence of an opening parenthesis, if Glob=False, + -- or the last occurrence of an opening curly brace, if Glob=True. + + procedure Raise_Exception_If_No_More_Chars (K : Integer := 0); + -- If no more characters are raised, call Raise_Exception + + -------------------------------------- + -- Raise_Exception_If_No_More_Chars -- + -------------------------------------- + + procedure Raise_Exception_If_No_More_Chars (K : Integer := 0) is + begin + if J + K > S'Last then + Raise_Exception ("Ill-formed pattern while parsing", J); + end if; + end Raise_Exception_If_No_More_Chars; + + -- Start of processing for Check_Well_Formed_Pattern + + begin + J := S'First; + while J <= S'Last loop + case S (J) is + when Open_Bracket => + J := J + 1; + Raise_Exception_If_No_More_Chars; + + if not Glob then + if S (J) = '^' then + J := J + 1; + Raise_Exception_If_No_More_Chars; + end if; + end if; + + -- The first character never has a special meaning + + if S (J) = ']' or else S (J) = '-' then + J := J + 1; + Raise_Exception_If_No_More_Chars; + end if; + + -- The set of characters cannot be empty + + if S (J) = ']' then + Raise_Exception + ("Set of characters cannot be empty in regular " + & "expression", J); + end if; + + declare + Possible_Range_Start : Boolean := True; + -- Set True everywhere a range character '-' can occur + + begin + loop + exit when S (J) = Close_Bracket; + + -- The current character should be followed by a + -- closing bracket. + + Raise_Exception_If_No_More_Chars (1); + + if S (J) = '-' + and then S (J + 1) /= Close_Bracket + then + if not Possible_Range_Start then + Raise_Exception + ("No mix of ranges is allowed in " + & "regular expression", J); + end if; + + J := J + 1; + Raise_Exception_If_No_More_Chars; + + -- Range cannot be followed by '-' character, + -- except as last character in the set. + + Possible_Range_Start := False; + + else + Possible_Range_Start := True; + end if; + + if S (J) = '\' then + J := J + 1; + Raise_Exception_If_No_More_Chars; + end if; + + J := J + 1; + end loop; + end; + + -- A closing bracket can end an elmt or term + + Past_Elmt := True; + Past_Term := True; + + when Close_Bracket => + + -- A close bracket must follow a open_bracket, and cannot be + -- found alone on the line. + + Raise_Exception + ("Incorrect character ']' in regular expression", J); + + when '\' => + if J < S'Last then + J := J + 1; + + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + + else + -- \ not allowed at the end of the regexp + + Raise_Exception + ("Incorrect character '\' in regular expression", J); + end if; + + when Open_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level + 1; + Last_Open := J; + + -- An open parenthesis does not end an elmt or term + + Past_Elmt := False; + Past_Term := False; + end if; + + when Close_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level - 1; + + if Parenthesis_Level < 0 then + Raise_Exception + ("')' is not associated with '(' in regular " + & "expression", J); + end if; + + if J = Last_Open + 1 then + Raise_Exception + ("Empty parentheses not allowed in regular " + & "expression", J); + end if; + + if not Past_Term then + Raise_Exception + ("Closing parenthesis not allowed here in regular " + & "expression", J); + end if; + + -- A closing parenthesis can end an elmt or term + + Past_Elmt := True; + Past_Term := True; + end if; + + when '{' => + if Glob then + Curly_Level := Curly_Level + 1; + Last_Open := J; + + else + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + end if; + + -- No need to check for ',' as the code always accepts them + + when '}' => + if Glob then + Curly_Level := Curly_Level - 1; + + if Curly_Level < 0 then + Raise_Exception + ("'}' is not associated with '{' in regular " + & "expression", J); + end if; + + if J = Last_Open + 1 then + Raise_Exception + ("Empty curly braces not allowed in regular " + & "expression", J); + end if; + + else + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + end if; + + when '*' | '?' | '+' => + if not Glob then + + -- These operators must apply to an elmt sub-expression, + -- and cannot be found if one has not just been parsed. + + if not Past_Elmt then + Raise_Exception + ("'*', '+' and '?' operators must be " + & "applied to an element in regular expression", J); + end if; + + Past_Elmt := False; + Past_Term := True; + end if; + + when '|' => + if not Glob then + + -- This operator must apply to a term sub-expression, + -- and cannot be found if one has not just been parsed. + + if not Past_Term then + Raise_Exception + ("'|' operator must be " + & "applied to a term in regular expression", J); + end if; + + Past_Elmt := False; + Past_Term := False; + end if; + + when others => + if not Glob then + + -- Any character can be an elmt or a term + + Past_Elmt := True; + Past_Term := True; + end if; + end case; + + J := J + 1; + end loop; + + -- A closing parenthesis must follow an open parenthesis + + if Parenthesis_Level /= 0 then + Raise_Exception + ("'(' must always be associated with a ')'", J); + end if; + + -- A closing curly brace must follow an open curly brace + + if Curly_Level /= 0 then + Raise_Exception + ("'{' must always be associated with a '}'", J); + end if; + end Check_Well_Formed_Pattern; + + -------------------- + -- Create_Mapping -- + -------------------- + + procedure Create_Mapping is + + procedure Add_In_Map (C : Character); + -- Add a character in the mapping, if it is not already defined + + ---------------- + -- Add_In_Map -- + ---------------- + + procedure Add_In_Map (C : Character) is + begin + if Map (C) = 0 then + Alphabet_Size := Alphabet_Size + 1; + Map (C) := Alphabet_Size; + end if; + end Add_In_Map; + + J : Integer := S'First; + Parenthesis_Level : Integer := 0; + Curly_Level : Integer := 0; + Last_Open : Integer := S'First - 1; + + -- Start of processing for Create_Mapping + + begin + while J <= S'Last loop + case S (J) is + when Open_Bracket => + J := J + 1; + + if S (J) = '^' then + J := J + 1; + end if; + + if S (J) = ']' or else S (J) = '-' then + J := J + 1; + end if; + + -- The first character never has a special meaning + + loop + if J > S'Last then + Raise_Exception + ("Ran out of characters while parsing ", J); + end if; + + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= Close_Bracket + then + declare + Start : constant Integer := J - 1; + + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Add_In_Map (Char); + end loop; + end; + else + if S (J) = '\' then + J := J + 1; + end if; + + Add_In_Map (S (J)); + end if; + + J := J + 1; + end loop; + + -- A close bracket must follow a open_bracket and cannot be + -- found alone on the line + + when Close_Bracket => + Raise_Exception + ("Incorrect character ']' in regular expression", J); + + when '\' => + if J < S'Last then + J := J + 1; + Add_In_Map (S (J)); + + else + -- Back slash \ not allowed at the end of the regexp + + Raise_Exception + ("Incorrect character '\' in regular expression", J); + end if; + + when Open_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level + 1; + Last_Open := J; + else + Add_In_Map (Open_Paren); + end if; + + when Close_Paren => + if not Glob then + Parenthesis_Level := Parenthesis_Level - 1; + + if Parenthesis_Level < 0 then + Raise_Exception + ("')' is not associated with '(' in regular " + & "expression", J); + end if; + + if J = Last_Open + 1 then + Raise_Exception + ("Empty parenthesis not allowed in regular " + & "expression", J); + end if; + + else + Add_In_Map (Close_Paren); + end if; + + when '.' => + if Glob then + Add_In_Map ('.'); + end if; + + when '{' => + if not Glob then + Add_In_Map (S (J)); + else + Curly_Level := Curly_Level + 1; + end if; + + when '}' => + if not Glob then + Add_In_Map (S (J)); + else + Curly_Level := Curly_Level - 1; + end if; + + when '*' | '?' => + if not Glob then + if J = S'First then + Raise_Exception + ("'*', '+', '?' and '|' operators cannot be in " + & "first position in regular expression", J); + end if; + end if; + + when '|' | '+' => + if not Glob then + if J = S'First then + + -- These operators must apply to a sub-expression, + -- and cannot be found at the beginning of the line + + Raise_Exception + ("'*', '+', '?' and '|' operators cannot be in " + & "first position in regular expression", J); + end if; + + else + Add_In_Map (S (J)); + end if; + + when others => + Add_In_Map (S (J)); + end case; + + J := J + 1; + end loop; + + -- A closing parenthesis must follow an open parenthesis + + if Parenthesis_Level /= 0 then + Raise_Exception + ("'(' must always be associated with a ')'", J); + end if; + + if Curly_Level /= 0 then + Raise_Exception + ("'{' must always be associated with a '}'", J); + end if; + end Create_Mapping; + + -------------------------- + -- Create_Primary_Table -- + -------------------------- + + procedure Create_Primary_Table + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index) + is + Empty_Char : constant Column_Index := Alphabet_Size + 1; + + Current_State : State_Index := 0; + -- Index of the last created state + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index); + -- Add a empty-character transition from State to To_State + + procedure Create_Repetition + (Repetition : Character; + Start_Prev : State_Index; + End_Prev : State_Index; + New_Start : out State_Index; + New_End : in out State_Index); + -- Create the table in case we have a '*', '+' or '?'. + -- Start_Prev .. End_Prev should indicate respectively the start and + -- end index of the previous expression, to which '*', '+' or '?' is + -- applied. + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index); + -- Fill the table for the regexp Simple. This is the recursive + -- procedure called to handle () expressions If End_State = 0, then + -- the call to Create_Simple creates an independent regexp, not a + -- concatenation Start_Index .. End_Index is the starting index in + -- the string S. + -- + -- Warning: it may look like we are creating too many empty-string + -- transitions, but they are needed to get the correct regexp. + -- The table is filled as follow ( s means start-state, e means + -- end-state) : + -- + -- regexp state_num | a b * empty_string + -- ------- ------------------------------ + -- a 1 (s) | 2 - - - + -- 2 (e) | - - - - + -- + -- ab 1 (s) | 2 - - - + -- 2 | - - - 3 + -- 3 | - 4 - - + -- 4 (e) | - - - - + -- + -- a|b 1 | 2 - - - + -- 2 | - - - 6 + -- 3 | - 4 - - + -- 4 | - - - 6 + -- 5 (s) | - - - 1,3 + -- 6 (e) | - - - - + -- + -- a* 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1,4 + -- 4 (e) | - - - 3 + -- + -- (a) 1 (s) | 2 - - - + -- 2 (e) | - - - - + -- + -- a+ 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1 + -- 4 (e) | - - - 3 + -- + -- a? 1 | 2 - - - + -- 2 | - - - 4 + -- 3 (s) | - - - 1,4 + -- 4 (e) | - - - - + -- + -- . 1 (s) | 2 2 2 - + -- 2 (e) | - - - - + + function Next_Sub_Expression + (Start_Index : Integer; + End_Index : Integer) return Integer; + -- Returns the index of the last character of the next sub-expression + -- in Simple. Index cannot be greater than End_Index. + + -------------------- + -- Add_Empty_Char -- + -------------------- + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index) + is + J : Column_Index := Empty_Char; + + begin + while Get (Table, State, J) /= 0 loop + J := J + 1; + end loop; + + Set (Table, State, J, To_State); + end Add_Empty_Char; + + ----------------------- + -- Create_Repetition -- + ----------------------- + + procedure Create_Repetition + (Repetition : Character; + Start_Prev : State_Index; + End_Prev : State_Index; + New_Start : out State_Index; + New_End : in out State_Index) + is + begin + New_Start := Current_State + 1; + + if New_End /= 0 then + Add_Empty_Char (New_End, New_Start); + end if; + + Current_State := Current_State + 2; + New_End := Current_State; + + Add_Empty_Char (End_Prev, New_End); + Add_Empty_Char (New_Start, Start_Prev); + + if Repetition /= '+' then + Add_Empty_Char (New_Start, New_End); + end if; + + if Repetition /= '?' then + Add_Empty_Char (New_End, New_Start); + end if; + end Create_Repetition; + + ------------------- + -- Create_Simple -- + ------------------- + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index) + is + J : Integer := Start_Index; + Last_Start : State_Index := 0; + + begin + Start_State := 0; + End_State := 0; + while J <= End_Index loop + case S (J) is + when Open_Paren => + declare + J_Start : constant Integer := J + 1; + Next_Start : State_Index; + Next_End : State_Index; + + begin + J := Next_Sub_Expression (J, End_Index); + Create_Simple (J_Start, J - 1, Next_Start, Next_End); + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Next_Start, + Next_End, + Last_Start, + End_State); + + else + Last_Start := Next_Start; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Next_End; + end if; + end; + + when '|' => + declare + Start_Prev : constant State_Index := Start_State; + End_Prev : constant State_Index := End_State; + Start_J : constant Integer := J + 1; + Start_Next : State_Index := 0; + End_Next : State_Index := 0; + + begin + J := Next_Sub_Expression (J, End_Index); + + -- Create a new state for the start of the alternative + + Current_State := Current_State + 1; + Last_Start := Current_State; + Start_State := Last_Start; + + -- Create the tree for the second part of alternative + + Create_Simple (Start_J, J, Start_Next, End_Next); + + -- Create the end state + + Add_Empty_Char (Last_Start, Start_Next); + Add_Empty_Char (Last_Start, Start_Prev); + Current_State := Current_State + 1; + End_State := Current_State; + Add_Empty_Char (End_Prev, End_State); + Add_Empty_Char (End_Next, End_State); + end; + + when Open_Bracket => + Current_State := Current_State + 1; + + declare + Next_State : State_Index := Current_State + 1; + + begin + J := J + 1; + + if S (J) = '^' then + J := J + 1; + + Next_State := 0; + + for Column in 0 .. Alphabet_Size loop + Set (Table, Current_State, Column, + Value => Current_State + 1); + end loop; + end if; + + -- Automatically add the first character + + if S (J) = '-' or else S (J) = ']' then + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + J := J + 1; + end if; + + -- Loop till closing bracket found + + loop + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= ']' + then + declare + Start : constant Integer := J - 1; + + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Set (Table, Current_State, Map (Char), + Value => Next_State); + end loop; + end; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + end if; + J := J + 1; + end loop; + end; + + Current_State := Current_State + 1; + + -- If the next symbol is a special symbol + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Current_State - 1, + Current_State, + Last_Start, + End_State); + + else + Last_Start := Current_State - 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + end if; + + when Close_Bracket + | Close_Paren + | '*' | '+' | '?' + => + Raise_Exception + ("Incorrect character in regular expression :", J); + + when others => + Current_State := Current_State + 1; + + -- Create the state for the symbol S (J) + + if S (J) = '.' then + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Current_State + 1); + end if; + + Current_State := Current_State + 1; + + -- If the next symbol is a special symbol + + if J < End_Index + and then (S (J + 1) = '*' or else + S (J + 1) = '+' or else + S (J + 1) = '?') + then + J := J + 1; + Create_Repetition + (S (J), + Current_State - 1, + Current_State, + Last_Start, + End_State); + + else + Last_Start := Current_State - 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + end if; + end case; + + if Start_State = 0 then + Start_State := Last_Start; + end if; + + J := J + 1; + end loop; + end Create_Simple; + + ------------------------- + -- Next_Sub_Expression -- + ------------------------- + + function Next_Sub_Expression + (Start_Index : Integer; + End_Index : Integer) return Integer + is + J : Integer := Start_Index; + Start_On_Alter : Boolean := False; + + begin + if S (J) = '|' then + Start_On_Alter := True; + end if; + + loop + exit when J = End_Index; + J := J + 1; + + case S (J) is + when '\' => + J := J + 1; + + when Open_Bracket => + loop + J := J + 1; + exit when S (J) = Close_Bracket; + + if S (J) = '\' then + J := J + 1; + end if; + end loop; + + when Open_Paren => + J := Next_Sub_Expression (J, End_Index); + + when Close_Paren => + return J; + + when '|' => + if Start_On_Alter then + return J - 1; + end if; + + when others => + null; + end case; + end loop; + + return J; + end Next_Sub_Expression; + + -- Start of processing for Create_Primary_Table + + begin + Table.all := (others => (others => 0)); + Create_Simple (S'First, S'Last, Start_State, End_State); + Num_States := Current_State; + end Create_Primary_Table; + + ------------------------------- + -- Create_Primary_Table_Glob -- + ------------------------------- + + procedure Create_Primary_Table_Glob + (Table : out Regexp_Array_Access; + Num_States : out State_Index; + Start_State : out State_Index; + End_State : out State_Index) + is + Empty_Char : constant Column_Index := Alphabet_Size + 1; + + Current_State : State_Index := 0; + -- Index of the last created state + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index); + -- Add a empty-character transition from State to To_State + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index); + -- Fill the table for the S (Start_Index .. End_Index). + -- This is the recursive procedure called to handle () expressions + + -------------------- + -- Add_Empty_Char -- + -------------------- + + procedure Add_Empty_Char + (State : State_Index; + To_State : State_Index) + is + J : Column_Index; + + begin + J := Empty_Char; + while Get (Table, State, J) /= 0 loop + J := J + 1; + end loop; + + Set (Table, State, J, Value => To_State); + end Add_Empty_Char; + + ------------------- + -- Create_Simple -- + ------------------- + + procedure Create_Simple + (Start_Index : Integer; + End_Index : Integer; + Start_State : out State_Index; + End_State : out State_Index) + is + J : Integer; + Last_Start : State_Index := 0; + + begin + Start_State := 0; + End_State := 0; + + J := Start_Index; + while J <= End_Index loop + case S (J) is + when Open_Bracket => + Current_State := Current_State + 1; + + declare + Next_State : State_Index := Current_State + 1; + + begin + J := J + 1; + + if S (J) = '^' then + J := J + 1; + Next_State := 0; + + for Column in 0 .. Alphabet_Size loop + Set (Table, Current_State, Column, + Value => Current_State + 1); + end loop; + end if; + + -- Automatically add the first character + + if S (J) = '-' or else S (J) = ']' then + Set (Table, Current_State, Map (S (J)), + Value => Current_State); + J := J + 1; + end if; + + -- Loop till closing bracket found + + loop + exit when S (J) = Close_Bracket; + + if S (J) = '-' + and then S (J + 1) /= ']' + then + declare + Start : constant Integer := J - 1; + + begin + J := J + 1; + + if S (J) = '\' then + J := J + 1; + end if; + + for Char in S (Start) .. S (J) loop + Set (Table, Current_State, Map (Char), + Value => Next_State); + end loop; + end; + + else + if S (J) = '\' then + J := J + 1; + end if; + + Set (Table, Current_State, Map (S (J)), + Value => Next_State); + end if; + J := J + 1; + end loop; + end; + + Last_Start := Current_State; + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + + when '{' => + declare + End_Sub : Integer; + Start_Regexp_Sub : State_Index; + End_Regexp_Sub : State_Index; + Create_Start : State_Index := 0; + + Create_End : State_Index := 0; + -- Initialized to avoid junk warning + + begin + while S (J) /= '}' loop + + -- First step : find sub pattern + + End_Sub := J + 1; + while S (End_Sub) /= ',' + and then S (End_Sub) /= '}' + loop + End_Sub := End_Sub + 1; + end loop; + + -- Second step : create a sub pattern + + Create_Simple + (J + 1, + End_Sub - 1, + Start_Regexp_Sub, + End_Regexp_Sub); + + J := End_Sub; + + -- Third step : create an alternative + + if Create_Start = 0 then + Current_State := Current_State + 1; + Create_Start := Current_State; + Add_Empty_Char (Create_Start, Start_Regexp_Sub); + Current_State := Current_State + 1; + Create_End := Current_State; + Add_Empty_Char (End_Regexp_Sub, Create_End); + + else + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Create_Start); + Create_Start := Current_State; + Add_Empty_Char (Create_Start, Start_Regexp_Sub); + Add_Empty_Char (End_Regexp_Sub, Create_End); + end if; + end loop; + + if End_State /= 0 then + Add_Empty_Char (End_State, Create_Start); + end if; + + End_State := Create_End; + Last_Start := Create_Start; + end; + + when '*' => + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Current_State); + end if; + + Add_Empty_Char (Current_State, Current_State + 1); + Add_Empty_Char (Current_State, Current_State + 3); + Last_Start := Current_State; + + Current_State := Current_State + 1; + + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Current_State + 1); + + Current_State := Current_State + 1; + Add_Empty_Char (Current_State, Last_Start); + End_State := Current_State; + + when others => + Current_State := Current_State + 1; + + if S (J) = '?' then + for K in 0 .. Alphabet_Size loop + Set (Table, Current_State, K, + Value => Current_State + 1); + end loop; + + else + if S (J) = '\' then + J := J + 1; + end if; + + -- Create the state for the symbol S (J) + + Set (Table, Current_State, Map (S (J)), + Value => Current_State + 1); + end if; + + Last_Start := Current_State; + Current_State := Current_State + 1; + + if End_State /= 0 then + Add_Empty_Char (End_State, Last_Start); + end if; + + End_State := Current_State; + end case; + + if Start_State = 0 then + Start_State := Last_Start; + end if; + + J := J + 1; + end loop; + end Create_Simple; + + -- Start of processing for Create_Primary_Table_Glob + + begin + Table.all := (others => (others => 0)); + Create_Simple (S'First, S'Last, Start_State, End_State); + Num_States := Current_State; + end Create_Primary_Table_Glob; + + ---------------------------- + -- Create_Secondary_Table -- + ---------------------------- + + function Create_Secondary_Table + (First_Table : Regexp_Array_Access; + Start_State : State_Index; + End_State : State_Index) return Regexp + is + Last_Index : constant State_Index := First_Table'Last (1); + + type Meta_State is array (0 .. Last_Index) of Boolean; + pragma Pack (Meta_State); + -- Whether a state from first_table belongs to a metastate. + + No_States : constant Meta_State := (others => False); + + type Meta_States_Array is array (State_Index range <>) of Meta_State; + type Meta_States_List is access all Meta_States_Array; + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Meta_States_Array, Meta_States_List); + Meta_States : Meta_States_List; + -- Components of meta-states. A given state might belong to + -- several meta-states. + -- This array grows dynamically. + + type Char_To_State is array (0 .. Alphabet_Size) of State_Index; + type Meta_States_Transition_Arr is + array (State_Index range <>) of Char_To_State; + type Meta_States_Transition is access all Meta_States_Transition_Arr; + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Meta_States_Transition_Arr, Meta_States_Transition); + Table : Meta_States_Transition; + -- Documents the transitions between each meta-state. The + -- first index is the meta-state, the second column is the + -- character seen in the input, the value is the new meta-state. + + Temp_State_Not_Null : Boolean; + + Current_State : State_Index := 1; + -- The current meta-state we are creating + + Nb_State : State_Index := 1; + -- The total number of meta-states created so far. + + procedure Closure + (Meta_State : State_Index; + State : State_Index); + -- Compute the closure of the state (that is every other state which + -- has a empty-character transition) and add it to the state + + procedure Ensure_Meta_State (Meta : State_Index); + -- grows the Meta_States array as needed to make sure that there + -- is enough space to store the new meta state. + + ----------------------- + -- Ensure_Meta_State -- + ----------------------- + + procedure Ensure_Meta_State (Meta : State_Index) is + Tmp : Meta_States_List := Meta_States; + Tmp2 : Meta_States_Transition := Table; + + begin + if Meta_States = null then + Meta_States := new Meta_States_Array + (1 .. State_Index'Max (Last_Index, Meta) + 1); + Meta_States (Meta_States'Range) := (others => No_States); + + Table := new Meta_States_Transition_Arr + (1 .. State_Index'Max (Last_Index, Meta) + 1); + Table.all := (others => (others => 0)); + + elsif Meta > Meta_States'Last then + Meta_States := new Meta_States_Array + (1 .. State_Index'Max (2 * Tmp'Last, Meta)); + Meta_States (Tmp'Range) := Tmp.all; + Meta_States (Tmp'Last + 1 .. Meta_States'Last) := + (others => No_States); + Unchecked_Free (Tmp); + + Table := new Meta_States_Transition_Arr + (1 .. State_Index'Max (2 * Tmp2'Last, Meta) + 1); + Table (Tmp2'Range) := Tmp2.all; + Table (Tmp2'Last + 1 .. Table'Last) := + (others => (others => 0)); + Unchecked_Free (Tmp2); + end if; + end Ensure_Meta_State; + + ------------- + -- Closure -- + ------------- + + procedure Closure + (Meta_State : State_Index; + State : State_Index) + is + begin + if not Meta_States (Meta_State)(State) then + Meta_States (Meta_State)(State) := True; + + -- For each transition on empty-character + + for Column in Alphabet_Size + 1 .. First_Table'Last (2) loop + exit when First_Table (State, Column) = 0; + Closure (Meta_State, First_Table (State, Column)); + end loop; + end if; + end Closure; + + -- Start of processing for Create_Secondary_Table + + begin + -- Create a new state + + Ensure_Meta_State (Current_State); + Closure (Current_State, Start_State); + + while Current_State <= Nb_State loop + + -- We will be trying, below, to create the next meta-state + + Ensure_Meta_State (Nb_State + 1); + + -- For every character in the regexp, calculate the possible + -- transitions from Current_State. + + for Column in 0 .. Alphabet_Size loop + Temp_State_Not_Null := False; + + for K in Meta_States (Current_State)'Range loop + if Meta_States (Current_State)(K) + and then First_Table (K, Column) /= 0 + then + Closure (Nb_State + 1, First_Table (K, Column)); + Temp_State_Not_Null := True; + end if; + end loop; + + -- If at least one transition existed + + if Temp_State_Not_Null then + + -- Check if this new state corresponds to an old one + + for K in 1 .. Nb_State loop + if Meta_States (K) = Meta_States (Nb_State + 1) then + Table (Current_State)(Column) := K; + + -- Reset data, for the next time we try that state + + Meta_States (Nb_State + 1) := No_States; + exit; + end if; + end loop; + + -- If not, create a new state + + if Table (Current_State)(Column) = 0 then + Nb_State := Nb_State + 1; + Ensure_Meta_State (Nb_State + 1); + Table (Current_State)(Column) := Nb_State; + end if; + end if; + end loop; + + Current_State := Current_State + 1; + end loop; + + -- Returns the regexp + + declare + R : Regexp_Access; + + begin + R := new Regexp_Value (Alphabet_Size => Alphabet_Size, + Num_States => Nb_State); + R.Map := Map; + R.Case_Sensitive := Case_Sensitive; + + for S in 1 .. Nb_State loop + R.Is_Final (S) := Meta_States (S)(End_State); + end loop; + + for State in 1 .. Nb_State loop + for K in 0 .. Alphabet_Size loop + R.States (State, K) := Table (State)(K); + end loop; + end loop; + + Unchecked_Free (Meta_States); + Unchecked_Free (Table); + + return (Ada.Finalization.Controlled with R => R); + end; + end Create_Secondary_Table; + + --------------------- + -- Raise_Exception -- + --------------------- + + procedure Raise_Exception (M : String; Index : Integer) is + begin + raise Error_In_Regexp with M & " at offset" & Index'Img; + end Raise_Exception; + + -- Start of processing for Compile + + begin + -- Special case for the empty string: it always matches, and the + -- following processing would fail on it. + + if S = "" then + return (Ada.Finalization.Controlled with + R => new Regexp_Value' + (Alphabet_Size => 0, + Num_States => 1, + Map => (others => 0), + States => (others => (others => 1)), + Is_Final => (others => True), + Case_Sensitive => True)); + end if; + + if not Case_Sensitive then + System.Case_Util.To_Lower (S); + end if; + + -- Check the pattern is well-formed before any treatment + + Check_Well_Formed_Pattern; + + Create_Mapping; + + -- Creates the primary table + + declare + Table : Regexp_Array_Access; + Num_States : State_Index; + Start_State : State_Index; + End_State : State_Index; + R : Regexp; + + begin + Table := new Regexp_Array (1 .. Initial_Max_States_In_Primary_Table, + 0 .. Alphabet_Size + 10); + if not Glob then + Create_Primary_Table (Table, Num_States, Start_State, End_State); + else + Create_Primary_Table_Glob + (Table, Num_States, Start_State, End_State); + end if; + + -- Creates the secondary table + + R := Create_Secondary_Table (Table, Start_State, End_State); + Free (Table); + return R; + end; + end Compile; + + -------------- + -- Finalize -- + -------------- + + procedure Finalize (R : in out Regexp) is + procedure Free is new + Ada.Unchecked_Deallocation (Regexp_Value, Regexp_Access); + begin + Free (R.R); + end Finalize; + + --------- + -- Get -- + --------- + + function Get + (Table : Regexp_Array_Access; + State : State_Index; + Column : Column_Index) return State_Index + is + begin + if State <= Table'Last (1) + and then Column <= Table'Last (2) + then + return Table (State, Column); + else + return 0; + end if; + end Get; + + ----------- + -- Match -- + ----------- + + function Match (S : String; R : Regexp) return Boolean is + Current_State : State_Index := 1; + + begin + if R.R = null then + raise Constraint_Error; + end if; + + for Char in S'Range loop + + if R.R.Case_Sensitive then + Current_State := R.R.States (Current_State, R.R.Map (S (Char))); + else + Current_State := + R.R.States (Current_State, + R.R.Map (System.Case_Util.To_Lower (S (Char)))); + end if; + + if Current_State = 0 then + return False; + end if; + + end loop; + + return R.R.Is_Final (Current_State); + end Match; + + --------- + -- Set -- + --------- + + procedure Set + (Table : in out Regexp_Array_Access; + State : State_Index; + Column : Column_Index; + Value : State_Index) + is + New_Lines : State_Index; + New_Columns : Column_Index; + New_Table : Regexp_Array_Access; + + begin + if State <= Table'Last (1) + and then Column <= Table'Last (2) + then + Table (State, Column) := Value; + else + -- Doubles the size of the table until it is big enough that + -- (State, Column) is a valid index. + + New_Lines := Table'Last (1) * (State / Table'Last (1) + 1); + New_Columns := Table'Last (2) * (Column / Table'Last (2) + 1); + New_Table := new Regexp_Array (Table'First (1) .. New_Lines, + Table'First (2) .. New_Columns); + New_Table.all := (others => (others => 0)); + + for J in Table'Range (1) loop + for K in Table'Range (2) loop + New_Table (J, K) := Table (J, K); + end loop; + end loop; + + Free (Table); + Table := New_Table; + Table (State, Column) := Value; + end if; + end Set; + +end System.Regexp; diff --git a/gcc/ada/libgnat/s-regexp.ads b/gcc/ada/libgnat/s-regexp.ads new file mode 100644 index 0000000..0155b43 --- /dev/null +++ b/gcc/ada/libgnat/s-regexp.ads @@ -0,0 +1,141 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R E G E X P -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple Regular expression matching + +-- This package provides a simple implementation of a regular expression +-- pattern matching algorithm, using a subset of the syntax of regular +-- expressions copied from familiar Unix style utilities. + +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.Regexp (file g-regexp.ads). + +with Ada.Finalization; + +package System.Regexp is + + -- The regular expression must first be compiled, using the Compile + -- function, which creates a finite state matching table, allowing + -- very fast matching once the expression has been compiled. + + -- The following is the form of a regular expression, expressed in Ada + -- reference manual style BNF is as follows + + -- regexp ::= term + + -- regexp ::= term | term -- alternation (term or term ...) + + -- term ::= item + + -- term ::= item item ... -- concatenation (item then item) + + -- item ::= elmt -- match elmt + -- item ::= elmt * -- zero or more elmt's + -- item ::= elmt + -- one or more elmt's + -- item ::= elmt ? -- matches elmt or nothing + + -- elmt ::= nchr -- matches given character + -- elmt ::= [nchr nchr ...] -- matches any character listed + -- elmt ::= [^ nchr nchr ...] -- matches any character not listed + -- elmt ::= [char - char] -- matches chars in given range + -- elmt ::= . -- matches any single character + -- elmt ::= ( regexp ) -- parens used for grouping + + -- char ::= any character, including special characters + -- nchr ::= any character except \()[].*+?^ or \char to match char + -- ... is used to indication repetition (one or more terms) + + -- See also regexp(1) man page on Unix systems for further details + + -- A second kind of regular expressions is provided. This one is more + -- like the wild card patterns used in file names by the Unix shell (or + -- DOS prompt) command lines. The grammar is the following: + + -- regexp ::= term + + -- term ::= elmt + -- term ::= elmt elmt ... -- concatenation (elmt then elmt) + -- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt) + + -- elmt ::= * -- any string of 0 or more characters + -- elmt ::= ? -- matches any character + -- elmt ::= char + -- elmt ::= [^ char char ...] -- matches any character not listed + -- elmt ::= [char char ...] -- matches any character listed + -- elmt ::= [char - char] -- matches any character in given range + + -- \char is also supported by this grammar. + + -- Important note : This package was mainly intended to match regular + -- expressions against file names. The whole string has to match the + -- regular expression. If only a substring matches, then the function + -- Match will return False. + + type Regexp is private; + -- Private type used to represent a regular expression + + Error_In_Regexp : exception; + -- Exception raised when an error is found in the regular expression + + function Compile + (Pattern : String; + Glob : Boolean := False; + Case_Sensitive : Boolean := True) return Regexp; + -- Compiles a regular expression S. If the syntax of the given + -- expression is invalid (does not match above grammar), Error_In_Regexp + -- is raised. If Glob is True, the pattern is considered as a 'globbing + -- pattern', that is a pattern as given by the second grammar above. + -- As a special case, if Pattern is the empty string it will always + -- match. + + function Match (S : String; R : Regexp) return Boolean; + -- True if S matches R, otherwise False. Raises Constraint_Error if + -- R is an uninitialized regular expression value. + +private + type Regexp_Value; + + type Regexp_Access is access Regexp_Value; + + type Regexp is new Ada.Finalization.Controlled with record + R : Regexp_Access := null; + end record; + + pragma Finalize_Storage_Only (Regexp); + + procedure Finalize (R : in out Regexp); + -- Free the memory occupied by R + + procedure Adjust (R : in out Regexp); + -- Called after an assignment (do a copy of the Regexp_Access.all) + +end System.Regexp; diff --git a/gcc/ada/libgnat/s-regpat.adb b/gcc/ada/libgnat/s-regpat.adb new file mode 100644 index 0000000..9ea4e36 --- /dev/null +++ b/gcc/ada/libgnat/s-regpat.adb @@ -0,0 +1,3754 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- G N A T . R E G P A T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1986 by University of Toronto. -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is an altered Ada 95 version of the original V8 style regular +-- expression library written in C by Henry Spencer. Apart from the +-- translation to Ada, the interface has been considerably changed to +-- use the Ada String type instead of C-style nul-terminated strings. + +-- Beware that some of this code is subtly aware of the way operator +-- precedence is structured in regular expressions. Serious changes in +-- regular-expression syntax might require a total rethink. + +with System.IO; use System.IO; +with Ada.Characters.Handling; use Ada.Characters.Handling; +with Ada.Unchecked_Conversion; + +package body System.Regpat is + + Debug : constant Boolean := False; + -- Set to True to activate debug traces. This is normally set to constant + -- False to simply delete all the trace code. It is to be edited to True + -- for internal debugging of the package. + + ---------------------------- + -- Implementation details -- + ---------------------------- + + -- This is essentially a linear encoding of a nondeterministic + -- finite-state machine, also known as syntax charts or + -- "railroad normal form" in parsing technology. + + -- Each node is an opcode plus a "next" pointer, possibly plus an + -- operand. "Next" pointers of all nodes except BRANCH implement + -- concatenation; a "next" pointer with a BRANCH on both ends of it + -- is connecting two alternatives. + + -- The operand of some types of node is a literal string; for others, + -- it is a node leading into a sub-FSM. In particular, the operand of + -- a BRANCH node is the first node of the branch. + -- (NB this is *not* a tree structure: the tail of the branch connects + -- to the thing following the set of BRANCHes). + + -- You can see the exact byte-compiled version by using the Dump + -- subprogram. However, here are a few examples: + + -- (a|b): 1 : BRANCH (next at 9) + -- 4 : EXACT (next at 17) operand=a + -- 9 : BRANCH (next at 17) + -- 12 : EXACT (next at 17) operand=b + -- 17 : EOP (next at 0) + -- + -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767} + -- 8 : OPEN 1 (next at 12) + -- 12 : EXACT (next at 18) operand=ab + -- 18 : CLOSE 1 (next at 22) + -- 22 : WHILEM (next at 0) + -- 25 : NOTHING (next at 28) + -- 28 : EOP (next at 0) + + -- The opcodes are: + + type Opcode is + + -- Name Operand? Meaning + + (EOP, -- no End of program + MINMOD, -- no Next operator is not greedy + + -- Classes of characters + + ANY, -- no Match any one character except newline + SANY, -- no Match any character, including new line + ANYOF, -- class Match any character in this class + EXACT, -- str Match this string exactly + EXACTF, -- str Match this string (case-folding is one) + NOTHING, -- no Match empty string + SPACE, -- no Match any whitespace character + NSPACE, -- no Match any non-whitespace character + DIGIT, -- no Match any numeric character + NDIGIT, -- no Match any non-numeric character + ALNUM, -- no Match any alphanumeric character + NALNUM, -- no Match any non-alphanumeric character + + -- Branches + + BRANCH, -- node Match this alternative, or the next + + -- Simple loops (when the following node is one character in length) + + STAR, -- node Match this simple thing 0 or more times + PLUS, -- node Match this simple thing 1 or more times + CURLY, -- 2num node Match this simple thing between n and m times. + + -- Complex loops + + CURLYX, -- 2num node Match this complex thing {n,m} times + -- The nums are coded on two characters each + + WHILEM, -- no Do curly processing and see if rest matches + + -- Matches after or before a word + + BOL, -- no Match "" at beginning of line + MBOL, -- no Same, assuming multiline (match after \n) + SBOL, -- no Same, assuming single line (don't match at \n) + EOL, -- no Match "" at end of line + MEOL, -- no Same, assuming multiline (match before \n) + SEOL, -- no Same, assuming single line (don't match at \n) + + BOUND, -- no Match "" at any word boundary + NBOUND, -- no Match "" at any word non-boundary + + -- Parenthesis groups handling + + REFF, -- num Match some already matched string, folded + OPEN, -- num Mark this point in input as start of #n + CLOSE); -- num Analogous to OPEN + + for Opcode'Size use 8; + + -- Opcode notes: + + -- BRANCH + -- The set of branches constituting a single choice are hooked + -- together with their "next" pointers, since precedence prevents + -- anything being concatenated to any individual branch. The + -- "next" pointer of the last BRANCH in a choice points to the + -- thing following the whole choice. This is also where the + -- final "next" pointer of each individual branch points; each + -- branch starts with the operand node of a BRANCH node. + + -- STAR,PLUS + -- '?', and complex '*' and '+', are implemented with CURLYX. + -- branches. Simple cases (one character per match) are implemented with + -- STAR and PLUS for speed and to minimize recursive plunges. + + -- OPEN,CLOSE + -- ...are numbered at compile time. + + -- EXACT, EXACTF + -- There are in fact two arguments, the first one is the length (minus + -- one of the string argument), coded on one character, the second + -- argument is the string itself, coded on length + 1 characters. + + -- A node is one char of opcode followed by two chars of "next" pointer. + -- "Next" pointers are stored as two 8-bit pieces, high order first. The + -- value is a positive offset from the opcode of the node containing it. + -- An operand, if any, simply follows the node. (Note that much of the + -- code generation knows about this implicit relationship.) + + -- Using two bytes for the "next" pointer is vast overkill for most + -- things, but allows patterns to get big without disasters. + + Next_Pointer_Bytes : constant := 3; + -- Points after the "next pointer" data. An instruction is therefore: + -- 1 byte: instruction opcode + -- 2 bytes: pointer to next instruction + -- * bytes: optional data for the instruction + + ----------------------- + -- Character classes -- + ----------------------- + -- This is the implementation for character classes ([...]) in the + -- syntax for regular expressions. Each character (0..256) has an + -- entry into the table. This makes for a very fast matching + -- algorithm. + + type Class_Byte is mod 256; + type Character_Class is array (Class_Byte range 0 .. 31) of Class_Byte; + + type Bit_Conversion_Array is array (Class_Byte range 0 .. 7) of Class_Byte; + Bit_Conversion : constant Bit_Conversion_Array := + (1, 2, 4, 8, 16, 32, 64, 128); + + type Std_Class is (ANYOF_NONE, + ANYOF_ALNUM, -- Alphanumeric class [a-zA-Z0-9] + ANYOF_NALNUM, + ANYOF_SPACE, -- Space class [ \t\n\r\f] + ANYOF_NSPACE, + ANYOF_DIGIT, -- Digit class [0-9] + ANYOF_NDIGIT, + ANYOF_ALNUMC, -- Alphanumeric class [a-zA-Z0-9] + ANYOF_NALNUMC, + ANYOF_ALPHA, -- Alpha class [a-zA-Z] + ANYOF_NALPHA, + ANYOF_ASCII, -- Ascii class (7 bits) 0..127 + ANYOF_NASCII, + ANYOF_CNTRL, -- Control class + ANYOF_NCNTRL, + ANYOF_GRAPH, -- Graphic class + ANYOF_NGRAPH, + ANYOF_LOWER, -- Lower case class [a-z] + ANYOF_NLOWER, + ANYOF_PRINT, -- printable class + ANYOF_NPRINT, + ANYOF_PUNCT, -- + ANYOF_NPUNCT, + ANYOF_UPPER, -- Upper case class [A-Z] + ANYOF_NUPPER, + ANYOF_XDIGIT, -- Hexadecimal digit + ANYOF_NXDIGIT + ); + + procedure Set_In_Class + (Bitmap : in out Character_Class; + C : Character); + -- Set the entry to True for C in the class Bitmap + + function Get_From_Class + (Bitmap : Character_Class; + C : Character) return Boolean; + -- Return True if the entry is set for C in the class Bitmap + + procedure Reset_Class (Bitmap : out Character_Class); + -- Clear all the entries in the class Bitmap + + pragma Inline (Set_In_Class); + pragma Inline (Get_From_Class); + pragma Inline (Reset_Class); + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function "=" (Left : Character; Right : Opcode) return Boolean; + + function Is_Alnum (C : Character) return Boolean; + -- Return True if C is an alphanum character or an underscore ('_') + + function Is_White_Space (C : Character) return Boolean; + -- Return True if C is a whitespace character + + function Is_Printable (C : Character) return Boolean; + -- Return True if C is a printable character + + function Operand (P : Pointer) return Pointer; + -- Return a pointer to the first operand of the node at P + + function String_Length + (Program : Program_Data; + P : Pointer) return Program_Size; + -- Return the length of the string argument of the node at P + + function String_Operand (P : Pointer) return Pointer; + -- Return a pointer to the string argument of the node at P + + procedure Bitmap_Operand + (Program : Program_Data; + P : Pointer; + Op : out Character_Class); + -- Return a pointer to the string argument of the node at P + + function Get_Next + (Program : Program_Data; + IP : Pointer) return Pointer; + -- Dig the next instruction pointer out of a node + + procedure Optimize (Self : in out Pattern_Matcher); + -- Optimize a Pattern_Matcher by noting certain special cases + + function Read_Natural + (Program : Program_Data; + IP : Pointer) return Natural; + -- Return the 2-byte natural coded at position IP + + -- All of the subprograms above are tiny and should be inlined + + pragma Inline ("="); + pragma Inline (Is_Alnum); + pragma Inline (Is_White_Space); + pragma Inline (Get_Next); + pragma Inline (Operand); + pragma Inline (Read_Natural); + pragma Inline (String_Length); + pragma Inline (String_Operand); + + type Expression_Flags is record + Has_Width, -- Known never to match null string + Simple, -- Simple enough to be STAR/PLUS operand + SP_Start : Boolean; -- Starts with * or + + end record; + + Worst_Expression : constant Expression_Flags := (others => False); + -- Worst case + + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True); + -- Dump the program until the node Till (not included) is met. Every line + -- is indented with Index spaces at the beginning Dumps till the end if + -- Till is 0. + + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural); + -- Same as above, but only dumps a single operation, and compute its + -- indentation from the program. + + --------- + -- "=" -- + --------- + + function "=" (Left : Character; Right : Opcode) return Boolean is + begin + return Character'Pos (Left) = Opcode'Pos (Right); + end "="; + + -------------------- + -- Bitmap_Operand -- + -------------------- + + procedure Bitmap_Operand + (Program : Program_Data; + P : Pointer; + Op : out Character_Class) + is + function Convert is new Ada.Unchecked_Conversion + (Program_Data, Character_Class); + + begin + Op (0 .. 31) := Convert (Program (P + Next_Pointer_Bytes .. P + 34)); + end Bitmap_Operand; + + ------------- + -- Compile -- + ------------- + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Final_Code_Size : out Program_Size; + Flags : Regexp_Flags := No_Flags) + is + -- We can't allocate space until we know how big the compiled form + -- will be, but we can't compile it (and thus know how big it is) + -- until we've got a place to put the code. So we cheat: we compile + -- it twice, once with code generation turned off and size counting + -- turned on, and once "for real". + + -- This also means that we don't allocate space until we are sure + -- that the thing really will compile successfully, and we never + -- have to move the code and thus invalidate pointers into it. + + -- Beware that the optimization-preparation code in here knows + -- about some of the structure of the compiled regexp. + + PM : Pattern_Matcher renames Matcher; + Program : Program_Data renames PM.Program; + + Emit_Ptr : Pointer := Program_First; + + Parse_Pos : Natural := Expression'First; -- Input-scan pointer + Parse_End : constant Natural := Expression'Last; + + ---------------------------- + -- Subprograms for Create -- + ---------------------------- + + procedure Emit (B : Character); + -- Output the Character B to the Program. If code-generation is + -- disabled, simply increments the program counter. + + function Emit_Node (Op : Opcode) return Pointer; + -- If code-generation is enabled, Emit_Node outputs the + -- opcode Op and reserves space for a pointer to the next node. + -- Return value is the location of new opcode, i.e. old Emit_Ptr. + + procedure Emit_Natural (IP : Pointer; N : Natural); + -- Split N on two characters at position IP + + procedure Emit_Class (Bitmap : Character_Class); + -- Emits a character class + + procedure Case_Emit (C : Character); + -- Emit C, after converting is to lower-case if the regular + -- expression is case insensitive. + + procedure Parse + (Parenthesized : Boolean; + Capturing : Boolean; + Flags : out Expression_Flags; + IP : out Pointer); + -- Parse regular expression, i.e. main body or parenthesized thing. + -- Caller must absorb opening parenthesis. Capturing should be set to + -- True when we have an open parenthesis from which we want the user + -- to extra text. + + procedure Parse_Branch + (Flags : out Expression_Flags; + First : Boolean; + IP : out Pointer); + -- Implements the concatenation operator and handles '|'. + -- First should be true if this is the first item of the alternative. + + procedure Parse_Piece + (Expr_Flags : out Expression_Flags; + IP : out Pointer); + -- Parse something followed by possible [*+?] + + procedure Parse_Atom + (Expr_Flags : out Expression_Flags; + IP : out Pointer); + -- Parse_Atom is the lowest level parse procedure. + -- + -- Optimization: Gobbles an entire sequence of ordinary characters so + -- that it can turn them into a single node, which is smaller to store + -- and faster to run. Backslashed characters are exceptions, each + -- becoming a separate node; the code is simpler that way and it's + -- not worth fixing. + + procedure Insert_Operator + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean := True); + -- Insert_Operator inserts an operator in front of an already-emitted + -- operand and relocates the operand. This applies to PLUS and STAR. + -- If Minmod is True, then the operator is non-greedy. + + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer; + -- Insert an operator before Operand (and move the latter forward in the + -- program). Opsize is the size needed to represent the operator. This + -- returns the position at which the operator was inserted, and moves + -- Emit_Ptr after the new position of the operand. + + procedure Insert_Curly_Operator + (Op : Opcode; + Min : Natural; + Max : Natural; + Operand : Pointer; + Greedy : Boolean := True); + -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}). + -- If Minmod is True, then the operator is non-greedy. + + procedure Link_Tail (P, Val : Pointer); + -- Link_Tail sets the next-pointer at the end of a node chain + + procedure Link_Operand_Tail (P, Val : Pointer); + -- Link_Tail on operand of first argument; noop if operand-less + + procedure Fail (M : String); + pragma No_Return (Fail); + -- Fail with a diagnostic message, if possible + + function Is_Curly_Operator (IP : Natural) return Boolean; + -- Return True if IP is looking at a '{' that is the beginning + -- of a curly operator, i.e. it matches {\d+,?\d*} + + function Is_Mult (IP : Natural) return Boolean; + -- Return True if C is a regexp multiplier: '+', '*' or '?' + + procedure Get_Curly_Arguments + (IP : Natural; + Min : out Natural; + Max : out Natural; + Greedy : out Boolean); + -- Parse the argument list for a curly operator. + -- It is assumed that IP is indeed pointing at a valid operator. + -- So what is IP and how come IP is not referenced in the body ??? + + procedure Parse_Character_Class (IP : out Pointer); + -- Parse a character class. + -- The calling subprogram should consume the opening '[' before. + + procedure Parse_Literal + (Expr_Flags : out Expression_Flags; + IP : out Pointer); + -- Parse_Literal encodes a string of characters to be matched exactly + + function Parse_Posix_Character_Class return Std_Class; + -- Parse a posix character class, like [:alpha:] or [:^alpha:]. + -- The caller is supposed to absorb the opening [. + + pragma Inline (Is_Mult); + pragma Inline (Emit_Natural); + pragma Inline (Parse_Character_Class); -- since used only once + + --------------- + -- Case_Emit -- + --------------- + + procedure Case_Emit (C : Character) is + begin + if (Flags and Case_Insensitive) /= 0 then + Emit (To_Lower (C)); + + else + -- Dump current character + + Emit (C); + end if; + end Case_Emit; + + ---------- + -- Emit -- + ---------- + + procedure Emit (B : Character) is + begin + if Emit_Ptr <= PM.Size then + Program (Emit_Ptr) := B; + end if; + + Emit_Ptr := Emit_Ptr + 1; + end Emit; + + ---------------- + -- Emit_Class -- + ---------------- + + procedure Emit_Class (Bitmap : Character_Class) is + subtype Program31 is Program_Data (0 .. 31); + + function Convert is new Ada.Unchecked_Conversion + (Character_Class, Program31); + + begin + -- What is the mysterious constant 31 here??? Can't it be expressed + -- symbolically (size of integer - 1 or some such???). In any case + -- it should be declared as a constant (and referenced presumably + -- as this constant + 1 below. + + if Emit_Ptr + 31 <= PM.Size then + Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); + end if; + + Emit_Ptr := Emit_Ptr + 32; + end Emit_Class; + + ------------------ + -- Emit_Natural -- + ------------------ + + procedure Emit_Natural (IP : Pointer; N : Natural) is + begin + if IP + 1 <= PM.Size then + Program (IP + 1) := Character'Val (N / 256); + Program (IP) := Character'Val (N mod 256); + end if; + end Emit_Natural; + + --------------- + -- Emit_Node -- + --------------- + + function Emit_Node (Op : Opcode) return Pointer is + Result : constant Pointer := Emit_Ptr; + + begin + if Emit_Ptr + 2 <= PM.Size then + Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); + Program (Emit_Ptr + 1) := ASCII.NUL; + Program (Emit_Ptr + 2) := ASCII.NUL; + end if; + + Emit_Ptr := Emit_Ptr + Next_Pointer_Bytes; + return Result; + end Emit_Node; + + ---------- + -- Fail -- + ---------- + + procedure Fail (M : String) is + begin + raise Expression_Error with M; + end Fail; + + ------------------------- + -- Get_Curly_Arguments -- + ------------------------- + + procedure Get_Curly_Arguments + (IP : Natural; + Min : out Natural; + Max : out Natural; + Greedy : out Boolean) + is + pragma Unreferenced (IP); + + Save_Pos : Natural := Parse_Pos + 1; + + begin + Min := 0; + Max := Max_Curly_Repeat; + + while Expression (Parse_Pos) /= '}' + and then Expression (Parse_Pos) /= ',' + loop + Parse_Pos := Parse_Pos + 1; + end loop; + + Min := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); + + if Expression (Parse_Pos) = ',' then + Save_Pos := Parse_Pos + 1; + while Expression (Parse_Pos) /= '}' loop + Parse_Pos := Parse_Pos + 1; + end loop; + + if Save_Pos /= Parse_Pos then + Max := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); + end if; + + else + Max := Min; + end if; + + if Parse_Pos < Expression'Last + and then Expression (Parse_Pos + 1) = '?' + then + Greedy := False; + Parse_Pos := Parse_Pos + 1; + + else + Greedy := True; + end if; + end Get_Curly_Arguments; + + --------------------------- + -- Insert_Curly_Operator -- + --------------------------- + + procedure Insert_Curly_Operator + (Op : Opcode; + Min : Natural; + Max : Natural; + Operand : Pointer; + Greedy : Boolean := True) + is + Old : Pointer; + begin + Old := Insert_Operator_Before (Op, Operand, Greedy, Opsize => 7); + Emit_Natural (Old + Next_Pointer_Bytes, Min); + Emit_Natural (Old + Next_Pointer_Bytes + 2, Max); + end Insert_Curly_Operator; + + ---------------------------- + -- Insert_Operator_Before -- + ---------------------------- + + function Insert_Operator_Before + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean; + Opsize : Pointer) return Pointer + is + Dest : constant Pointer := Emit_Ptr; + Old : Pointer; + Size : Pointer := Opsize; + + begin + -- If not greedy, we have to emit another opcode first + + if not Greedy then + Size := Size + Next_Pointer_Bytes; + end if; + + -- Move the operand in the byte-compilation, so that we can insert + -- the operator before it. + + if Emit_Ptr + Size <= PM.Size then + Program (Operand + Size .. Emit_Ptr + Size) := + Program (Operand .. Emit_Ptr); + end if; + + -- Insert the operator at the position previously occupied by the + -- operand. + + Emit_Ptr := Operand; + + if not Greedy then + Old := Emit_Node (MINMOD); + Link_Tail (Old, Old + Next_Pointer_Bytes); + end if; + + Old := Emit_Node (Op); + Emit_Ptr := Dest + Size; + return Old; + end Insert_Operator_Before; + + --------------------- + -- Insert_Operator -- + --------------------- + + procedure Insert_Operator + (Op : Opcode; + Operand : Pointer; + Greedy : Boolean := True) + is + Discard : Pointer; + pragma Warnings (Off, Discard); + begin + Discard := Insert_Operator_Before + (Op, Operand, Greedy, Opsize => Next_Pointer_Bytes); + end Insert_Operator; + + ----------------------- + -- Is_Curly_Operator -- + ----------------------- + + function Is_Curly_Operator (IP : Natural) return Boolean is + Scan : Natural := IP; + + begin + if Expression (Scan) /= '{' + or else Scan + 2 > Expression'Last + or else not Is_Digit (Expression (Scan + 1)) + then + return False; + end if; + + Scan := Scan + 1; + + -- The first digit + + loop + Scan := Scan + 1; + + if Scan > Expression'Last then + return False; + end if; + + exit when not Is_Digit (Expression (Scan)); + end loop; + + if Expression (Scan) = ',' then + loop + Scan := Scan + 1; + + if Scan > Expression'Last then + return False; + end if; + + exit when not Is_Digit (Expression (Scan)); + end loop; + end if; + + return Expression (Scan) = '}'; + end Is_Curly_Operator; + + ------------- + -- Is_Mult -- + ------------- + + function Is_Mult (IP : Natural) return Boolean is + C : constant Character := Expression (IP); + + begin + return C = '*' + or else C = '+' + or else C = '?' + or else (C = '{' and then Is_Curly_Operator (IP)); + end Is_Mult; + + ----------------------- + -- Link_Operand_Tail -- + ----------------------- + + procedure Link_Operand_Tail (P, Val : Pointer) is + begin + if P <= PM.Size and then Program (P) = BRANCH then + Link_Tail (Operand (P), Val); + end if; + end Link_Operand_Tail; + + --------------- + -- Link_Tail -- + --------------- + + procedure Link_Tail (P, Val : Pointer) is + Scan : Pointer; + Temp : Pointer; + Offset : Pointer; + + begin + -- Find last node (the size of the pattern matcher might be too + -- small, so don't try to read past its end). + + Scan := P; + while Scan + Next_Pointer_Bytes <= PM.Size loop + Temp := Get_Next (Program, Scan); + exit when Temp = Scan; + Scan := Temp; + end loop; + + Offset := Val - Scan; + + Emit_Natural (Scan + 1, Natural (Offset)); + end Link_Tail; + + ----------- + -- Parse -- + ----------- + + -- Combining parenthesis handling with the base level of regular + -- expression is a trifle forced, but the need to tie the tails of the + -- the branches to what follows makes it hard to avoid. + + procedure Parse + (Parenthesized : Boolean; + Capturing : Boolean; + Flags : out Expression_Flags; + IP : out Pointer) + is + E : String renames Expression; + Br, Br2 : Pointer; + Ender : Pointer; + Par_No : Natural; + New_Flags : Expression_Flags; + Have_Branch : Boolean := False; + + begin + Flags := (Has_Width => True, others => False); -- Tentatively + + -- Make an OPEN node, if parenthesized + + if Parenthesized and then Capturing then + if Matcher.Paren_Count > Max_Paren_Count then + Fail ("too many ()"); + end if; + + Par_No := Matcher.Paren_Count + 1; + Matcher.Paren_Count := Matcher.Paren_Count + 1; + IP := Emit_Node (OPEN); + Emit (Character'Val (Par_No)); + else + IP := 0; + Par_No := 0; + end if; + + -- Pick up the branches, linking them together + + Parse_Branch (New_Flags, True, Br); + + if Br = 0 then + IP := 0; + return; + end if; + + if Parse_Pos <= Parse_End + and then E (Parse_Pos) = '|' + then + Insert_Operator (BRANCH, Br); + Have_Branch := True; + end if; + + if IP /= 0 then + Link_Tail (IP, Br); -- OPEN -> first + else + IP := Br; + end if; + + if not New_Flags.Has_Width then + Flags.Has_Width := False; + end if; + + Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; + + while Parse_Pos <= Parse_End + and then (E (Parse_Pos) = '|') + loop + Parse_Pos := Parse_Pos + 1; + Parse_Branch (New_Flags, False, Br); + + if Br = 0 then + IP := 0; + return; + end if; + + Link_Tail (IP, Br); -- BRANCH -> BRANCH + + if not New_Flags.Has_Width then + Flags.Has_Width := False; + end if; + + Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; + end loop; + + -- Make a closing node, and hook it on the end + + if Parenthesized then + if Capturing then + Ender := Emit_Node (CLOSE); + Emit (Character'Val (Par_No)); + Link_Tail (IP, Ender); + + else + -- Need to keep looking after the closing parenthesis + Ender := Emit_Ptr; + end if; + + else + Ender := Emit_Node (EOP); + Link_Tail (IP, Ender); + end if; + + if Have_Branch and then Emit_Ptr <= PM.Size + 1 then + + -- Hook the tails of the branches to the closing node + + Br := IP; + loop + Link_Operand_Tail (Br, Ender); + Br2 := Get_Next (Program, Br); + exit when Br2 = Br; + Br := Br2; + end loop; + end if; + + -- Check for proper termination + + if Parenthesized then + if Parse_Pos > Parse_End or else E (Parse_Pos) /= ')' then + Fail ("unmatched ()"); + end if; + + Parse_Pos := Parse_Pos + 1; + + elsif Parse_Pos <= Parse_End then + if E (Parse_Pos) = ')' then + Fail ("unmatched ')'"); + else + Fail ("junk on end"); -- "Can't happen" + end if; + end if; + end Parse; + + ---------------- + -- Parse_Atom -- + ---------------- + + procedure Parse_Atom + (Expr_Flags : out Expression_Flags; + IP : out Pointer) + is + C : Character; + + begin + -- Tentatively set worst expression case + + Expr_Flags := Worst_Expression; + + C := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + case (C) is + when '^' => + IP := + Emit_Node + (if (Flags and Multiple_Lines) /= 0 then MBOL + elsif (Flags and Single_Line) /= 0 then SBOL + else BOL); + + when '$' => + IP := + Emit_Node + (if (Flags and Multiple_Lines) /= 0 then MEOL + elsif (Flags and Single_Line) /= 0 then SEOL + else EOL); + + when '.' => + IP := + Emit_Node + (if (Flags and Single_Line) /= 0 then SANY else ANY); + + Expr_Flags.Has_Width := True; + Expr_Flags.Simple := True; + + when '[' => + Parse_Character_Class (IP); + Expr_Flags.Has_Width := True; + Expr_Flags.Simple := True; + + when '(' => + declare + New_Flags : Expression_Flags; + + begin + if Parse_Pos <= Parse_End - 1 + and then Expression (Parse_Pos) = '?' + and then Expression (Parse_Pos + 1) = ':' + then + Parse_Pos := Parse_Pos + 2; + + -- Non-capturing parenthesis + + Parse (True, False, New_Flags, IP); + + else + -- Capturing parenthesis + + Parse (True, True, New_Flags, IP); + Expr_Flags.Has_Width := + Expr_Flags.Has_Width or else New_Flags.Has_Width; + Expr_Flags.SP_Start := + Expr_Flags.SP_Start or else New_Flags.SP_Start; + if IP = 0 then + return; + end if; + end if; + end; + + when '|' | ASCII.LF | ')' => + Fail ("internal urp"); -- Supposed to be caught earlier + + when '?' | '+' | '*' => + Fail (C & " follows nothing"); + + when '{' => + if Is_Curly_Operator (Parse_Pos - 1) then + Fail (C & " follows nothing"); + else + Parse_Literal (Expr_Flags, IP); + end if; + + when '\' => + if Parse_Pos > Parse_End then + Fail ("trailing \"); + end if; + + Parse_Pos := Parse_Pos + 1; + + case Expression (Parse_Pos - 1) is + when 'b' => + IP := Emit_Node (BOUND); + + when 'B' => + IP := Emit_Node (NBOUND); + + when 's' => + IP := Emit_Node (SPACE); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'S' => + IP := Emit_Node (NSPACE); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'd' => + IP := Emit_Node (DIGIT); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'D' => + IP := Emit_Node (NDIGIT); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'w' => + IP := Emit_Node (ALNUM); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'W' => + IP := Emit_Node (NALNUM); + Expr_Flags.Simple := True; + Expr_Flags.Has_Width := True; + + when 'A' => + IP := Emit_Node (SBOL); + + when 'G' => + IP := Emit_Node (SEOL); + + when '0' .. '9' => + IP := Emit_Node (REFF); + + declare + Save : constant Natural := Parse_Pos - 1; + + begin + while Parse_Pos <= Expression'Last + and then Is_Digit (Expression (Parse_Pos)) + loop + Parse_Pos := Parse_Pos + 1; + end loop; + + Emit (Character'Val (Natural'Value + (Expression (Save .. Parse_Pos - 1)))); + end; + + when others => + Parse_Pos := Parse_Pos - 1; + Parse_Literal (Expr_Flags, IP); + end case; + + when others => + Parse_Literal (Expr_Flags, IP); + end case; + end Parse_Atom; + + ------------------ + -- Parse_Branch -- + ------------------ + + procedure Parse_Branch + (Flags : out Expression_Flags; + First : Boolean; + IP : out Pointer) + is + E : String renames Expression; + Chain : Pointer; + Last : Pointer; + New_Flags : Expression_Flags; + + Discard : Pointer; + pragma Warnings (Off, Discard); + + begin + Flags := Worst_Expression; -- Tentatively + IP := (if First then Emit_Ptr else Emit_Node (BRANCH)); + + Chain := 0; + while Parse_Pos <= Parse_End + and then E (Parse_Pos) /= ')' + and then E (Parse_Pos) /= ASCII.LF + and then E (Parse_Pos) /= '|' + loop + Parse_Piece (New_Flags, Last); + + if Last = 0 then + IP := 0; + return; + end if; + + Flags.Has_Width := Flags.Has_Width or else New_Flags.Has_Width; + + if Chain = 0 then -- First piece + Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; + else + Link_Tail (Chain, Last); + end if; + + Chain := Last; + end loop; + + -- Case where loop ran zero CURLY + + if Chain = 0 then + Discard := Emit_Node (NOTHING); + end if; + end Parse_Branch; + + --------------------------- + -- Parse_Character_Class -- + --------------------------- + + procedure Parse_Character_Class (IP : out Pointer) is + Bitmap : Character_Class; + Invert : Boolean := False; + In_Range : Boolean := False; + Named_Class : Std_Class := ANYOF_NONE; + Value : Character; + Last_Value : Character := ASCII.NUL; + + begin + Reset_Class (Bitmap); + + -- Do we have an invert character class ? + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = '^' + then + Invert := True; + Parse_Pos := Parse_Pos + 1; + end if; + + -- First character can be ] or - without closing the class + + if Parse_Pos <= Parse_End + and then (Expression (Parse_Pos) = ']' + or else Expression (Parse_Pos) = '-') + then + Set_In_Class (Bitmap, Expression (Parse_Pos)); + Parse_Pos := Parse_Pos + 1; + end if; + + -- While we don't have the end of the class + + while Parse_Pos <= Parse_End + and then Expression (Parse_Pos) /= ']' + loop + Named_Class := ANYOF_NONE; + Value := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + -- Do we have a Posix character class + if Value = '[' then + Named_Class := Parse_Posix_Character_Class; + + elsif Value = '\' then + if Parse_Pos = Parse_End then + Fail ("Trailing \"); + end if; + Value := Expression (Parse_Pos); + Parse_Pos := Parse_Pos + 1; + + case Value is + when 'w' => Named_Class := ANYOF_ALNUM; + when 'W' => Named_Class := ANYOF_NALNUM; + when 's' => Named_Class := ANYOF_SPACE; + when 'S' => Named_Class := ANYOF_NSPACE; + when 'd' => Named_Class := ANYOF_DIGIT; + when 'D' => Named_Class := ANYOF_NDIGIT; + when 'n' => Value := ASCII.LF; + when 'r' => Value := ASCII.CR; + when 't' => Value := ASCII.HT; + when 'f' => Value := ASCII.FF; + when 'e' => Value := ASCII.ESC; + when 'a' => Value := ASCII.BEL; + + -- when 'x' => ??? hexadecimal value + -- when 'c' => ??? control character + -- when '0'..'9' => ??? octal character + + when others => null; + end case; + end if; + + -- Do we have a character class? + + if Named_Class /= ANYOF_NONE then + + -- A range like 'a-\d' or 'a-[:digit:] is not a range + + if In_Range then + Set_In_Class (Bitmap, Last_Value); + Set_In_Class (Bitmap, '-'); + In_Range := False; + end if; + + -- Expand the range + + case Named_Class is + when ANYOF_NONE => null; + + when ANYOF_ALNUM | ANYOF_ALNUMC => + for Value in Class_Byte'Range loop + if Is_Alnum (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NALNUM | ANYOF_NALNUMC => + for Value in Class_Byte'Range loop + if not Is_Alnum (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_SPACE => + for Value in Class_Byte'Range loop + if Is_White_Space (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NSPACE => + for Value in Class_Byte'Range loop + if not Is_White_Space (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_DIGIT => + for Value in Class_Byte'Range loop + if Is_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NDIGIT => + for Value in Class_Byte'Range loop + if not Is_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_ALPHA => + for Value in Class_Byte'Range loop + if Is_Letter (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NALPHA => + for Value in Class_Byte'Range loop + if not Is_Letter (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_ASCII => + for Value in 0 .. 127 loop + Set_In_Class (Bitmap, Character'Val (Value)); + end loop; + + when ANYOF_NASCII => + for Value in 128 .. 255 loop + Set_In_Class (Bitmap, Character'Val (Value)); + end loop; + + when ANYOF_CNTRL => + for Value in Class_Byte'Range loop + if Is_Control (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NCNTRL => + for Value in Class_Byte'Range loop + if not Is_Control (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_GRAPH => + for Value in Class_Byte'Range loop + if Is_Graphic (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NGRAPH => + for Value in Class_Byte'Range loop + if not Is_Graphic (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_LOWER => + for Value in Class_Byte'Range loop + if Is_Lower (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NLOWER => + for Value in Class_Byte'Range loop + if not Is_Lower (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_PRINT => + for Value in Class_Byte'Range loop + if Is_Printable (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NPRINT => + for Value in Class_Byte'Range loop + if not Is_Printable (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_PUNCT => + for Value in Class_Byte'Range loop + if Is_Printable (Character'Val (Value)) + and then not Is_White_Space (Character'Val (Value)) + and then not Is_Alnum (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NPUNCT => + for Value in Class_Byte'Range loop + if not Is_Printable (Character'Val (Value)) + or else Is_White_Space (Character'Val (Value)) + or else Is_Alnum (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_UPPER => + for Value in Class_Byte'Range loop + if Is_Upper (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NUPPER => + for Value in Class_Byte'Range loop + if not Is_Upper (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_XDIGIT => + for Value in Class_Byte'Range loop + if Is_Hexadecimal_Digit (Character'Val (Value)) then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + when ANYOF_NXDIGIT => + for Value in Class_Byte'Range loop + if not Is_Hexadecimal_Digit + (Character'Val (Value)) + then + Set_In_Class (Bitmap, Character'Val (Value)); + end if; + end loop; + + end case; + + -- Not a character range + + elsif not In_Range then + Last_Value := Value; + + if Parse_Pos > Expression'Last then + Fail ("Empty character class []"); + end if; + + if Expression (Parse_Pos) = '-' + and then Parse_Pos < Parse_End + and then Expression (Parse_Pos + 1) /= ']' + then + Parse_Pos := Parse_Pos + 1; + + -- Do we have a range like '\d-a' and '[:space:]-a' + -- which is not a real range + + if Named_Class /= ANYOF_NONE then + Set_In_Class (Bitmap, '-'); + else + In_Range := True; + end if; + + else + Set_In_Class (Bitmap, Value); + + end if; + + -- Else in a character range + + else + if Last_Value > Value then + Fail ("Invalid Range [" & Last_Value'Img + & "-" & Value'Img & "]"); + end if; + + while Last_Value <= Value loop + Set_In_Class (Bitmap, Last_Value); + Last_Value := Character'Succ (Last_Value); + end loop; + + In_Range := False; + + end if; + + end loop; + + -- Optimize case-insensitive ranges (put the upper case or lower + -- case character into the bitmap) + + if (Flags and Case_Insensitive) /= 0 then + for C in Character'Range loop + if Get_From_Class (Bitmap, C) then + Set_In_Class (Bitmap, To_Lower (C)); + Set_In_Class (Bitmap, To_Upper (C)); + end if; + end loop; + end if; + + -- Optimize inverted classes + + if Invert then + for J in Bitmap'Range loop + Bitmap (J) := not Bitmap (J); + end loop; + end if; + + Parse_Pos := Parse_Pos + 1; + + -- Emit the class + + IP := Emit_Node (ANYOF); + Emit_Class (Bitmap); + end Parse_Character_Class; + + ------------------- + -- Parse_Literal -- + ------------------- + + -- This is a bit tricky due to quoted chars and due to + -- the multiplier characters '*', '+', and '?' that + -- take the SINGLE char previous as their operand. + + -- On entry, the character at Parse_Pos - 1 is going to go + -- into the string, no matter what it is. It could be + -- following a \ if Parse_Atom was entered from the '\' case. + + -- Basic idea is to pick up a good char in C and examine + -- the next char. If Is_Mult (C) then twiddle, if it's a \ + -- then frozzle and if it's another magic char then push C and + -- terminate the string. If none of the above, push C on the + -- string and go around again. + + -- Start_Pos is used to remember where "the current character" + -- starts in the string, if due to an Is_Mult we need to back + -- up and put the current char in a separate 1-character string. + -- When Start_Pos is 0, C is the only char in the string; + -- this is used in Is_Mult handling, and in setting the SIMPLE + -- flag at the end. + + procedure Parse_Literal + (Expr_Flags : out Expression_Flags; + IP : out Pointer) + is + Start_Pos : Natural := 0; + C : Character; + Length_Ptr : Pointer; + + Has_Special_Operator : Boolean := False; + + begin + Parse_Pos := Parse_Pos - 1; -- Look at current character + + IP := + Emit_Node + (if (Flags and Case_Insensitive) /= 0 then EXACTF else EXACT); + + Length_Ptr := Emit_Ptr; + Emit_Ptr := String_Operand (IP); + + Parse_Loop : + loop + C := Expression (Parse_Pos); -- Get current character + + case C is + when '.' | '[' | '(' | ')' | '|' | ASCII.LF | '$' | '^' => + + if Start_Pos = 0 then + Start_Pos := Parse_Pos; + Emit (C); -- First character is always emitted + else + exit Parse_Loop; -- Else we are done + end if; + + when '?' | '+' | '*' | '{' => + + if Start_Pos = 0 then + Start_Pos := Parse_Pos; + Emit (C); -- First character is always emitted + + -- Are we looking at an operator, or is this + -- simply a normal character ? + + elsif not Is_Mult (Parse_Pos) then + Start_Pos := Parse_Pos; + Case_Emit (C); + + else + -- We've got something like "abc?d". Mark this as a + -- special case. What we want to emit is a first + -- constant string for "ab", then one for "c" that will + -- ultimately be transformed with a CURLY operator, A + -- special case has to be handled for "a?", since there + -- is no initial string to emit. + + Has_Special_Operator := True; + exit Parse_Loop; + end if; + + when '\' => + Start_Pos := Parse_Pos; + + if Parse_Pos = Parse_End then + Fail ("Trailing \"); + + else + case Expression (Parse_Pos + 1) is + when 'b' | 'B' | 's' | 'S' | 'd' | 'D' + | 'w' | 'W' | '0' .. '9' | 'G' | 'A' + => exit Parse_Loop; + when 'n' => Emit (ASCII.LF); + when 't' => Emit (ASCII.HT); + when 'r' => Emit (ASCII.CR); + when 'f' => Emit (ASCII.FF); + when 'e' => Emit (ASCII.ESC); + when 'a' => Emit (ASCII.BEL); + when others => Emit (Expression (Parse_Pos + 1)); + end case; + + Parse_Pos := Parse_Pos + 1; + end if; + + when others => + Start_Pos := Parse_Pos; + Case_Emit (C); + end case; + + Parse_Pos := Parse_Pos + 1; + exit Parse_Loop when Parse_Pos > Parse_End + or else Emit_Ptr - Length_Ptr = 254; + end loop Parse_Loop; + + -- Is the string followed by a '*+?{' operator ? If yes, and if there + -- is an initial string to emit, do it now. + + if Has_Special_Operator + and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes + then + Emit_Ptr := Emit_Ptr - 1; + Parse_Pos := Start_Pos; + end if; + + if Length_Ptr <= PM.Size then + Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); + end if; + + Expr_Flags.Has_Width := True; + + -- Slight optimization when there is a single character + + if Emit_Ptr = Length_Ptr + 2 then + Expr_Flags.Simple := True; + end if; + end Parse_Literal; + + ----------------- + -- Parse_Piece -- + ----------------- + + -- Note that the branching code sequences used for '?' and the + -- general cases of '*' and + are somewhat optimized: they use + -- the same NOTHING node as both the endmarker for their branch + -- list and the body of the last branch. It might seem that + -- this node could be dispensed with entirely, but the endmarker + -- role is not redundant. + + procedure Parse_Piece + (Expr_Flags : out Expression_Flags; + IP : out Pointer) + is + Op : Character; + New_Flags : Expression_Flags; + Greedy : Boolean := True; + + begin + Parse_Atom (New_Flags, IP); + + if IP = 0 then + return; + end if; + + if Parse_Pos > Parse_End + or else not Is_Mult (Parse_Pos) + then + Expr_Flags := New_Flags; + return; + end if; + + Op := Expression (Parse_Pos); + + Expr_Flags := + (if Op /= '+' + then (SP_Start => True, others => False) + else (Has_Width => True, others => False)); + + -- Detect non greedy operators in the easy cases + + if Op /= '{' + and then Parse_Pos + 1 <= Parse_End + and then Expression (Parse_Pos + 1) = '?' + then + Greedy := False; + Parse_Pos := Parse_Pos + 1; + end if; + + -- Generate the byte code + + case Op is + when '*' => + + if New_Flags.Simple then + Insert_Operator (STAR, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator + (CURLYX, 0, Max_Curly_Repeat, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '+' => + + if New_Flags.Simple then + Insert_Operator (PLUS, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator + (CURLYX, 1, Max_Curly_Repeat, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '?' => + if New_Flags.Simple then + Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + + when '{' => + declare + Min, Max : Natural; + + begin + Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy); + + if New_Flags.Simple then + Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy); + else + Link_Tail (IP, Emit_Node (WHILEM)); + Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy); + Link_Tail (IP, Emit_Node (NOTHING)); + end if; + end; + + when others => + null; + end case; + + Parse_Pos := Parse_Pos + 1; + + if Parse_Pos <= Parse_End + and then Is_Mult (Parse_Pos) + then + Fail ("nested *+{"); + end if; + end Parse_Piece; + + --------------------------------- + -- Parse_Posix_Character_Class -- + --------------------------------- + + function Parse_Posix_Character_Class return Std_Class is + Invert : Boolean := False; + Class : Std_Class := ANYOF_NONE; + E : String renames Expression; + + -- Class names. Note that code assumes that the length of all + -- classes starting with the same letter have the same length. + + Alnum : constant String := "alnum:]"; + Alpha : constant String := "alpha:]"; + Ascii_C : constant String := "ascii:]"; + Cntrl : constant String := "cntrl:]"; + Digit : constant String := "digit:]"; + Graph : constant String := "graph:]"; + Lower : constant String := "lower:]"; + Print : constant String := "print:]"; + Punct : constant String := "punct:]"; + Space : constant String := "space:]"; + Upper : constant String := "upper:]"; + Word : constant String := "word:]"; + Xdigit : constant String := "xdigit:]"; + + begin + -- Case of character class specified + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = ':' + then + Parse_Pos := Parse_Pos + 1; + + -- Do we have something like: [[:^alpha:]] + + if Parse_Pos <= Parse_End + and then Expression (Parse_Pos) = '^' + then + Invert := True; + Parse_Pos := Parse_Pos + 1; + end if; + + -- Check for class names based on first letter + + case Expression (Parse_Pos) is + when 'a' => + + -- All 'a' classes have the same length (Alnum'Length) + + if Parse_Pos + Alnum'Length - 1 <= Parse_End then + if + E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum + then + Class := + (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC); + Parse_Pos := Parse_Pos + Alnum'Length; + + elsif + E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha + then + Class := + (if Invert then ANYOF_NALPHA else ANYOF_ALPHA); + Parse_Pos := Parse_Pos + Alpha'Length; + + elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) = + Ascii_C + then + Class := + (if Invert then ANYOF_NASCII else ANYOF_ASCII); + Parse_Pos := Parse_Pos + Ascii_C'Length; + else + Fail ("Invalid character class: " & E); + end if; + + else + Fail ("Invalid character class: " & E); + end if; + + when 'c' => + if Parse_Pos + Cntrl'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl + then + Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL); + Parse_Pos := Parse_Pos + Cntrl'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'd' => + if Parse_Pos + Digit'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit + then + Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT); + Parse_Pos := Parse_Pos + Digit'Length; + end if; + + when 'g' => + if Parse_Pos + Graph'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph + then + Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH); + Parse_Pos := Parse_Pos + Graph'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'l' => + if Parse_Pos + Lower'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower + then + Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER); + Parse_Pos := Parse_Pos + Lower'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'p' => + + -- All 'p' classes have the same length + + if Parse_Pos + Print'Length - 1 <= Parse_End then + if + E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print + then + Class := + (if Invert then ANYOF_NPRINT else ANYOF_PRINT); + Parse_Pos := Parse_Pos + Print'Length; + + elsif + E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct + then + Class := + (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT); + Parse_Pos := Parse_Pos + Punct'Length; + + else + Fail ("Invalid character class: " & E); + end if; + + else + Fail ("Invalid character class: " & E); + end if; + + when 's' => + if Parse_Pos + Space'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space + then + Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE); + Parse_Pos := Parse_Pos + Space'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'u' => + if Parse_Pos + Upper'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper + then + Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER); + Parse_Pos := Parse_Pos + Upper'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'w' => + if Parse_Pos + Word'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word + then + Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM); + Parse_Pos := Parse_Pos + Word'Length; + else + Fail ("Invalid character class: " & E); + end if; + + when 'x' => + if Parse_Pos + Xdigit'Length - 1 <= Parse_End + and then + E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit + then + Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT); + Parse_Pos := Parse_Pos + Xdigit'Length; + + else + Fail ("Invalid character class: " & E); + end if; + + when others => + Fail ("Invalid character class: " & E); + end case; + + -- Character class not specified + + else + return ANYOF_NONE; + end if; + + return Class; + end Parse_Posix_Character_Class; + + -- Local Declarations + + Result : Pointer; + + Expr_Flags : Expression_Flags; + pragma Unreferenced (Expr_Flags); + + -- Start of processing for Compile + + begin + Parse (False, False, Expr_Flags, Result); + + if Result = 0 then + Fail ("Couldn't compile expression"); + end if; + + Final_Code_Size := Emit_Ptr - 1; + + -- Do we want to actually compile the expression, or simply get the + -- code size ??? + + if Emit_Ptr <= PM.Size then + Optimize (PM); + end if; + + PM.Flags := Flags; + end Compile; + + function Compile + (Expression : String; + Flags : Regexp_Flags := No_Flags) return Pattern_Matcher + is + -- Assume the compiled regexp will fit in 1000 chars. If it does not we + -- will have to compile a second time once the correct size is known. If + -- it fits, we save a significant amount of time by avoiding the second + -- compilation. + + Dummy : Pattern_Matcher (1000); + Size : Program_Size; + + begin + Compile (Dummy, Expression, Size, Flags); + + if Size <= Dummy.Size then + return Pattern_Matcher' + (Size => Size, + First => Dummy.First, + Anchored => Dummy.Anchored, + Must_Have => Dummy.Must_Have, + Must_Have_Length => Dummy.Must_Have_Length, + Paren_Count => Dummy.Paren_Count, + Flags => Dummy.Flags, + Program => + Dummy.Program + (Dummy.Program'First .. Dummy.Program'First + Size - 1)); + else + -- We have to recompile now that we know the size + -- ??? Can we use Ada 2005's return construct ? + + declare + Result : Pattern_Matcher (Size); + begin + Compile (Result, Expression, Size, Flags); + return Result; + end; + end if; + end Compile; + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Flags : Regexp_Flags := No_Flags) + is + Size : Program_Size; + + begin + Compile (Matcher, Expression, Size, Flags); + + if Size > Matcher.Size then + raise Expression_Error with "Pattern_Matcher is too small"; + end if; + end Compile; + + -------------------- + -- Dump_Operation -- + -------------------- + + procedure Dump_Operation + (Program : Program_Data; + Index : Pointer; + Indent : Natural) + is + Current : Pointer := Index; + begin + Dump_Until (Program, Current, Current + 1, Indent); + end Dump_Operation; + + ---------------- + -- Dump_Until -- + ---------------- + + procedure Dump_Until + (Program : Program_Data; + Index : in out Pointer; + Till : Pointer; + Indent : Natural; + Do_Print : Boolean := True) + is + function Image (S : String) return String; + -- Remove leading space + + ----------- + -- Image -- + ----------- + + function Image (S : String) return String is + begin + if S (S'First) = ' ' then + return S (S'First + 1 .. S'Last); + else + return S; + end if; + end Image; + + -- Local variables + + Op : Opcode; + Next : Pointer; + Length : Pointer; + Local_Indent : Natural := Indent; + + -- Start of processing for Dump_Until + + begin + while Index < Till loop + Op := Opcode'Val (Character'Pos ((Program (Index)))); + Next := Get_Next (Program, Index); + + if Do_Print then + declare + Point : constant String := Pointer'Image (Index); + begin + Put ((1 .. 4 - Point'Length => ' ') + & Point & ":" + & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op)); + end; + + -- Print the parenthesis number + + if Op = OPEN or else Op = CLOSE or else Op = REFF then + Put (Image (Natural'Image + (Character'Pos + (Program (Index + Next_Pointer_Bytes))))); + end if; + + if Next = Index then + Put (" (-)"); + else + Put (" (" & Image (Pointer'Image (Next)) & ")"); + end if; + end if; + + case Op is + when ANYOF => + declare + Bitmap : Character_Class; + Last : Character := ASCII.NUL; + Current : Natural := 0; + Current_Char : Character; + + begin + Bitmap_Operand (Program, Index, Bitmap); + + if Do_Print then + Put ("["); + + while Current <= 255 loop + Current_Char := Character'Val (Current); + + -- First item in a range + + if Get_From_Class (Bitmap, Current_Char) then + Last := Current_Char; + + -- Search for the last item in the range + + loop + Current := Current + 1; + exit when Current > 255; + Current_Char := Character'Val (Current); + exit when + not Get_From_Class (Bitmap, Current_Char); + end loop; + + if not Is_Graphic (Last) then + Put (Last'Img); + else + Put (Last); + end if; + + if Character'Succ (Last) /= Current_Char then + Put ("\-" & Character'Pred (Current_Char)); + end if; + + else + Current := Current + 1; + end if; + end loop; + + Put_Line ("]"); + end if; + + Index := Index + Next_Pointer_Bytes + Bitmap'Length; + end; + + when EXACT | EXACTF => + Length := String_Length (Program, Index); + if Do_Print then + Put (" (" & Image (Program_Size'Image (Length + 1)) + & " chars) <" + & String (Program (String_Operand (Index) + .. String_Operand (Index) + + Length))); + Put_Line (">"); + end if; + + Index := String_Operand (Index) + Length + 1; + + -- Node operand + + when BRANCH | STAR | PLUS => + if Do_Print then + New_Line; + end if; + + Index := Index + Next_Pointer_Bytes; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); + + when CURLY | CURLYX => + if Do_Print then + Put_Line + (" {" + & Image (Natural'Image + (Read_Natural (Program, Index + Next_Pointer_Bytes))) + & "," + & Image (Natural'Image (Read_Natural (Program, Index + 5))) + & "}"); + end if; + + Index := Index + 7; + Dump_Until (Program, Index, Pointer'Min (Next, Till), + Local_Indent + 1, Do_Print); + + when OPEN => + if Do_Print then + New_Line; + end if; + + Index := Index + 4; + Local_Indent := Local_Indent + 1; + + when CLOSE | REFF => + if Do_Print then + New_Line; + end if; + + Index := Index + 4; + + if Op = CLOSE then + Local_Indent := Local_Indent - 1; + end if; + + when others => + Index := Index + Next_Pointer_Bytes; + + if Do_Print then + New_Line; + end if; + + exit when Op = EOP; + end case; + end loop; + end Dump_Until; + + ---------- + -- Dump -- + ---------- + + procedure Dump (Self : Pattern_Matcher) is + Program : Program_Data renames Self.Program; + Index : Pointer := Program'First; + + -- Start of processing for Dump + + begin + Put_Line ("Must start with (Self.First) = " + & Character'Image (Self.First)); + + if (Self.Flags and Case_Insensitive) /= 0 then + Put_Line (" Case_Insensitive mode"); + end if; + + if (Self.Flags and Single_Line) /= 0 then + Put_Line (" Single_Line mode"); + end if; + + if (Self.Flags and Multiple_Lines) /= 0 then + Put_Line (" Multiple_Lines mode"); + end if; + + Dump_Until (Program, Index, Self.Program'Last + 1, 0); + end Dump; + + -------------------- + -- Get_From_Class -- + -------------------- + + function Get_From_Class + (Bitmap : Character_Class; + C : Character) return Boolean + is + Value : constant Class_Byte := Character'Pos (C); + begin + return + (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0; + end Get_From_Class; + + -------------- + -- Get_Next -- + -------------- + + function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is + begin + return IP + Pointer (Read_Natural (Program, IP + 1)); + end Get_Next; + + -------------- + -- Is_Alnum -- + -------------- + + function Is_Alnum (C : Character) return Boolean is + begin + return Is_Alphanumeric (C) or else C = '_'; + end Is_Alnum; + + ------------------ + -- Is_Printable -- + ------------------ + + function Is_Printable (C : Character) return Boolean is + begin + -- Printable if space or graphic character or other whitespace + -- Other white space includes (HT/LF/VT/FF/CR = codes 9-13) + + return C in Character'Val (32) .. Character'Val (126) + or else C in ASCII.HT .. ASCII.CR; + end Is_Printable; + + -------------------- + -- Is_White_Space -- + -------------------- + + function Is_White_Space (C : Character) return Boolean is + begin + -- Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13 + + return C = ' ' or else C in ASCII.HT .. ASCII.CR; + end Is_White_Space; + + ----------- + -- Match -- + ----------- + + procedure Match + (Self : Pattern_Matcher; + Data : String; + Matches : out Match_Array; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) + is + Program : Program_Data renames Self.Program; -- Shorter notation + + First_In_Data : constant Integer := Integer'Max (Data_First, Data'First); + Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last); + + -- Global work variables + + Input_Pos : Natural; -- String-input pointer + BOL_Pos : Natural; -- Beginning of input, for ^ check + Matched : Boolean := False; -- Until proven True + + Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count, + Matches'Last)); + -- Stores the value of all the parenthesis pairs. + -- We do not use directly Matches, so that we can also use back + -- references (REFF) even if Matches is too small. + + type Natural_Array is array (Match_Count range <>) of Natural; + Matches_Tmp : Natural_Array (Matches_Full'Range); + -- Save the opening position of parenthesis + + Last_Paren : Natural := 0; + -- Last parenthesis seen + + Greedy : Boolean := True; + -- True if the next operator should be greedy + + type Current_Curly_Record; + type Current_Curly_Access is access all Current_Curly_Record; + type Current_Curly_Record is record + Paren_Floor : Natural; -- How far back to strip parenthesis data + Cur : Integer; -- How many instances of scan we've matched + Min : Natural; -- Minimal number of scans to match + Max : Natural; -- Maximal number of scans to match + Greedy : Boolean; -- Whether to work our way up or down + Scan : Pointer; -- The thing to match + Next : Pointer; -- What has to match after it + Lastloc : Natural; -- Where we started matching this scan + Old_Cc : Current_Curly_Access; -- Before we started this one + end record; + -- Data used to handle the curly operator and the plus and star + -- operators for complex expressions. + + Current_Curly : Current_Curly_Access := null; + -- The curly currently being processed + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Index (Start : Positive; C : Character) return Natural; + -- Find character C in Data starting at Start and return position + + function Repeat + (IP : Pointer; + Max : Natural := Natural'Last) return Natural; + -- Repeatedly match something simple, report how many + -- It only matches on things of length 1. + -- Starting from Input_Pos, it matches at most Max CURLY. + + function Try (Pos : Positive) return Boolean; + -- Try to match at specific point + + function Match (IP : Pointer) return Boolean; + -- This is the main matching routine. Conceptually the strategy + -- is simple: check to see whether the current node matches, + -- call self recursively to see whether the rest matches, + -- and then act accordingly. + -- + -- In practice Match makes some effort to avoid recursion, in + -- particular by going through "ordinary" nodes (that don't + -- need to know whether the rest of the match failed) by + -- using a loop instead of recursion. + -- Why is the above comment part of the spec rather than body ??? + + function Match_Whilem return Boolean; + -- Return True if a WHILEM matches the Current_Curly + + function Recurse_Match (IP : Pointer; From : Natural) return Boolean; + pragma Inline (Recurse_Match); + -- Calls Match recursively. It saves and restores the parenthesis + -- status and location in the input stream correctly, so that + -- backtracking is possible + + function Match_Simple_Operator + (Op : Opcode; + Scan : Pointer; + Next : Pointer; + Greedy : Boolean) return Boolean; + -- Return True it the simple operator (possibly non-greedy) matches + + Dump_Indent : Integer := -1; + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True); + procedure Dump_Error (Msg : String); + -- Debug: print the current context + + pragma Inline (Index); + pragma Inline (Repeat); + + -- These are two complex functions, but used only once + + pragma Inline (Match_Whilem); + pragma Inline (Match_Simple_Operator); + + ----------- + -- Index -- + ----------- + + function Index (Start : Positive; C : Character) return Natural is + begin + for J in Start .. Last_In_Data loop + if Data (J) = C then + return J; + end if; + end loop; + + return 0; + end Index; + + ------------------- + -- Recurse_Match -- + ------------------- + + function Recurse_Match (IP : Pointer; From : Natural) return Boolean is + L : constant Natural := Last_Paren; + Tmp_F : constant Match_Array := + Matches_Full (From + 1 .. Matches_Full'Last); + Start : constant Natural_Array := + Matches_Tmp (From + 1 .. Matches_Tmp'Last); + Input : constant Natural := Input_Pos; + + Dump_Indent_Save : constant Integer := Dump_Indent; + + begin + if Match (IP) then + return True; + end if; + + Last_Paren := L; + Matches_Full (Tmp_F'Range) := Tmp_F; + Matches_Tmp (Start'Range) := Start; + Input_Pos := Input; + Dump_Indent := Dump_Indent_Save; + return False; + end Recurse_Match; + + ------------------ + -- Dump_Current -- + ------------------ + + procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is + Length : constant := 10; + Pos : constant String := Integer'Image (Input_Pos); + + begin + if Prefix then + Put ((1 .. 5 - Pos'Length => ' ')); + Put (Pos & " <" + & Data (Input_Pos + .. Integer'Min (Last_In_Data, Input_Pos + Length - 1))); + Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' ')); + Put ("> |"); + + else + Put (" "); + end if; + + Dump_Operation (Program, Scan, Indent => Dump_Indent); + end Dump_Current; + + ---------------- + -- Dump_Error -- + ---------------- + + procedure Dump_Error (Msg : String) is + begin + Put (" | "); + Put ((1 .. Dump_Indent * 2 => ' ')); + Put_Line (Msg); + end Dump_Error; + + ----------- + -- Match -- + ----------- + + function Match (IP : Pointer) return Boolean is + Scan : Pointer := IP; + Next : Pointer; + Op : Opcode; + Result : Boolean; + + begin + Dump_Indent := Dump_Indent + 1; + + State_Machine : + loop + pragma Assert (Scan /= 0); + + -- Determine current opcode and count its usage in debug mode + + Op := Opcode'Val (Character'Pos (Program (Scan))); + + -- Calculate offset of next instruction. Second character is most + -- significant in Program_Data. + + Next := Get_Next (Program, Scan); + + if Debug then + Dump_Current (Scan); + end if; + + case Op is + when EOP => + Dump_Indent := Dump_Indent - 1; + return True; -- Success + + when BRANCH => + if Program (Next) /= BRANCH then + Next := Operand (Scan); -- No choice, avoid recursion + + else + loop + if Recurse_Match (Operand (Scan), 0) then + Dump_Indent := Dump_Indent - 1; + return True; + end if; + + Scan := Get_Next (Program, Scan); + exit when Scan = 0 or else Program (Scan) /= BRANCH; + end loop; + + exit State_Machine; + end if; + + when NOTHING => + null; + + when BOL => + exit State_Machine when Input_Pos /= BOL_Pos + and then ((Self.Flags and Multiple_Lines) = 0 + or else Data (Input_Pos - 1) /= ASCII.LF); + + when MBOL => + exit State_Machine when Input_Pos /= BOL_Pos + and then Data (Input_Pos - 1) /= ASCII.LF; + + when SBOL => + exit State_Machine when Input_Pos /= BOL_Pos; + + when EOL => + + -- A combination of MEOL and SEOL + + if (Self.Flags and Multiple_Lines) = 0 then + + -- Single line mode + + exit State_Machine when Input_Pos <= Data'Last; + + elsif Input_Pos <= Last_In_Data then + exit State_Machine when Data (Input_Pos) /= ASCII.LF; + else + exit State_Machine when Last_In_Data /= Data'Last; + end if; + + when MEOL => + if Input_Pos <= Last_In_Data then + exit State_Machine when Data (Input_Pos) /= ASCII.LF; + else + exit State_Machine when Last_In_Data /= Data'Last; + end if; + + when SEOL => + + -- If there is a character before Data'Last (even if + -- Last_In_Data stops before then), we can't have the + -- end of the line. + + exit State_Machine when Input_Pos <= Data'Last; + + when BOUND | NBOUND => + + -- Was last char in word ? + + declare + N : Boolean := False; + Ln : Boolean := False; + + begin + if Input_Pos /= First_In_Data then + N := Is_Alnum (Data (Input_Pos - 1)); + end if; + + Ln := + (if Input_Pos > Last_In_Data + then False + else Is_Alnum (Data (Input_Pos))); + + if Op = BOUND then + if N = Ln then + exit State_Machine; + end if; + else + if N /= Ln then + exit State_Machine; + end if; + end if; + end; + + when SPACE => + exit State_Machine when Input_Pos > Last_In_Data + or else not Is_White_Space (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NSPACE => + exit State_Machine when Input_Pos > Last_In_Data + or else Is_White_Space (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when DIGIT => + exit State_Machine when Input_Pos > Last_In_Data + or else not Is_Digit (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NDIGIT => + exit State_Machine when Input_Pos > Last_In_Data + or else Is_Digit (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when ALNUM => + exit State_Machine when Input_Pos > Last_In_Data + or else not Is_Alnum (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when NALNUM => + exit State_Machine when Input_Pos > Last_In_Data + or else Is_Alnum (Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + + when ANY => + exit State_Machine when Input_Pos > Last_In_Data + or else Data (Input_Pos) = ASCII.LF; + Input_Pos := Input_Pos + 1; + + when SANY => + exit State_Machine when Input_Pos > Last_In_Data; + Input_Pos := Input_Pos + 1; + + when EXACT => + declare + Opnd : Pointer := String_Operand (Scan); + Current : Positive := Input_Pos; + Last : constant Pointer := + Opnd + String_Length (Program, Scan); + + begin + while Opnd <= Last loop + exit State_Machine when Current > Last_In_Data + or else Program (Opnd) /= Data (Current); + Current := Current + 1; + Opnd := Opnd + 1; + end loop; + + Input_Pos := Current; + end; + + when EXACTF => + declare + Opnd : Pointer := String_Operand (Scan); + Current : Positive := Input_Pos; + + Last : constant Pointer := + Opnd + String_Length (Program, Scan); + + begin + while Opnd <= Last loop + exit State_Machine when Current > Last_In_Data + or else Program (Opnd) /= To_Lower (Data (Current)); + Current := Current + 1; + Opnd := Opnd + 1; + end loop; + + Input_Pos := Current; + end; + + when ANYOF => + declare + Bitmap : Character_Class; + begin + Bitmap_Operand (Program, Scan, Bitmap); + exit State_Machine when Input_Pos > Last_In_Data + or else not Get_From_Class (Bitmap, Data (Input_Pos)); + Input_Pos := Input_Pos + 1; + end; + + when OPEN => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + begin + Matches_Tmp (No) := Input_Pos; + end; + + when CLOSE => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + + begin + Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1); + + if Last_Paren < No then + Last_Paren := No; + end if; + end; + + when REFF => + declare + No : constant Natural := + Character'Pos (Program (Operand (Scan))); + + Data_Pos : Natural; + + begin + -- If we haven't seen that parenthesis yet + + if Last_Paren < No then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + + return False; + end if; + + Data_Pos := Matches_Full (No).First; + + while Data_Pos <= Matches_Full (No).Last loop + if Input_Pos > Last_In_Data + or else Data (Input_Pos) /= Data (Data_Pos) + then + Dump_Indent := Dump_Indent - 1; + + if Debug then + Dump_Error ("REFF: No match, backtracking"); + end if; + + return False; + end if; + + Input_Pos := Input_Pos + 1; + Data_Pos := Data_Pos + 1; + end loop; + end; + + when MINMOD => + Greedy := False; + + when STAR | PLUS | CURLY => + declare + Greed : constant Boolean := Greedy; + begin + Greedy := True; + Result := Match_Simple_Operator (Op, Scan, Next, Greed); + Dump_Indent := Dump_Indent - 1; + return Result; + end; + + when CURLYX => + + -- Looking at something like: + + -- 1: CURLYX {n,m} (->4) + -- 2: code for complex thing (->3) + -- 3: WHILEM (->0) + -- 4: NOTHING + + declare + Min : constant Natural := + Read_Natural (Program, Scan + Next_Pointer_Bytes); + Max : constant Natural := + Read_Natural + (Program, Scan + Next_Pointer_Bytes + 2); + Cc : aliased Current_Curly_Record; + + Has_Match : Boolean; + + begin + Cc := (Paren_Floor => Last_Paren, + Cur => -1, + Min => Min, + Max => Max, + Greedy => Greedy, + Scan => Scan + 7, + Next => Next, + Lastloc => 0, + Old_Cc => Current_Curly); + Greedy := True; + Current_Curly := Cc'Unchecked_Access; + + Has_Match := Match (Next - Next_Pointer_Bytes); + + -- Start on the WHILEM + + Current_Curly := Cc.Old_Cc; + Dump_Indent := Dump_Indent - 1; + + if not Has_Match then + if Debug then + Dump_Error ("CURLYX failed..."); + end if; + end if; + + return Has_Match; + end; + + when WHILEM => + Result := Match_Whilem; + Dump_Indent := Dump_Indent - 1; + + if Debug and then not Result then + Dump_Error ("WHILEM: no match, backtracking"); + end if; + + return Result; + end case; + + Scan := Next; + end loop State_Machine; + + if Debug then + Dump_Error ("failed..."); + Dump_Indent := Dump_Indent - 1; + end if; + + -- If we get here, there is no match. For successful matches when EOP + -- is the terminating point. + + return False; + end Match; + + --------------------------- + -- Match_Simple_Operator -- + --------------------------- + + function Match_Simple_Operator + (Op : Opcode; + Scan : Pointer; + Next : Pointer; + Greedy : Boolean) return Boolean + is + Next_Char : Character := ASCII.NUL; + Next_Char_Known : Boolean := False; + No : Integer; -- Can be negative + Min : Natural; + Max : Natural := Natural'Last; + Operand_Code : Pointer; + Old : Natural; + Last_Pos : Natural; + Save : constant Natural := Input_Pos; + + begin + -- Lookahead to avoid useless match attempts when we know what + -- character comes next. + + if Program (Next) = EXACT then + Next_Char := Program (String_Operand (Next)); + Next_Char_Known := True; + end if; + + -- Find the minimal and maximal values for the operator + + case Op is + when STAR => + Min := 0; + Operand_Code := Operand (Scan); + + when PLUS => + Min := 1; + Operand_Code := Operand (Scan); + + when others => + Min := Read_Natural (Program, Scan + Next_Pointer_Bytes); + Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2); + Operand_Code := Scan + 7; + end case; + + if Debug then + Dump_Current (Operand_Code, Prefix => False); + end if; + + -- Non greedy operators + + if not Greedy then + + -- Test we can repeat at least Min times + + if Min /= 0 then + No := Repeat (Operand_Code, Min); + + if No < Min then + if Debug then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; + + return False; + end if; + end if; + + Old := Input_Pos; + + -- Find the place where 'next' could work + + if Next_Char_Known then + + -- Last position to check + + if Max = Natural'Last then + Last_Pos := Last_In_Data; + else + Last_Pos := Input_Pos + Max; + + if Last_Pos > Last_In_Data then + Last_Pos := Last_In_Data; + end if; + end if; + + -- Look for the first possible opportunity + + if Debug then + Dump_Error ("Next_Char must be " & Next_Char); + end if; + + loop + -- Find the next possible position + + while Input_Pos <= Last_Pos + and then Data (Input_Pos) /= Next_Char + loop + Input_Pos := Input_Pos + 1; + end loop; + + if Input_Pos > Last_Pos then + return False; + end if; + + -- Check that we still match if we stop at the position we + -- just found. + + declare + Num : constant Natural := Input_Pos - Old; + + begin + Input_Pos := Old; + + if Debug then + Dump_Error ("Would we still match at that position?"); + end if; + + if Repeat (Operand_Code, Num) < Num then + return False; + end if; + end; + + -- Input_Pos now points to the new position + + if Match (Get_Next (Program, Scan)) then + return True; + end if; + + Old := Input_Pos; + Input_Pos := Input_Pos + 1; + end loop; + + -- We do not know what the next character is + + else + while Max >= Min loop + if Debug then + Dump_Error ("Non-greedy repeat, N=" & Min'Img); + Dump_Error ("Do we still match Next if we stop here?"); + end if; + + -- If the next character matches + + if Recurse_Match (Next, 1) then + return True; + end if; + + Input_Pos := Save + Min; + + -- Could not or did not match -- move forward + + if Repeat (Operand_Code, 1) /= 0 then + Min := Min + 1; + else + if Debug then + Dump_Error ("Non-greedy repeat failed..."); + end if; + + return False; + end if; + end loop; + end if; + + return False; + + -- Greedy operators + + else + No := Repeat (Operand_Code, Max); + + if Debug and then No < Min then + Dump_Error ("failed... matched" & No'Img & " times"); + end if; + + -- ??? Perl has some special code here in case the next + -- instruction is of type EOL, since $ and \Z can match before + -- *and* after newline at the end. + + -- ??? Perl has some special code here in case (paren) is True + + -- Else, if we don't have any parenthesis + + while No >= Min loop + if not Next_Char_Known + or else (Input_Pos <= Last_In_Data + and then Data (Input_Pos) = Next_Char) + then + if Match (Next) then + return True; + end if; + end if; + + -- Could not or did not work, we back up + + No := No - 1; + Input_Pos := Save + No; + end loop; + + return False; + end if; + end Match_Simple_Operator; + + ------------------ + -- Match_Whilem -- + ------------------ + + -- This is really hard to understand, because after we match what we + -- are trying to match, we must make sure the rest of the REx is going + -- to match for sure, and to do that we have to go back UP the parse + -- tree by recursing ever deeper. And if it fails, we have to reset + -- our parent's current state that we can try again after backing off. + + function Match_Whilem return Boolean is + Cc : constant Current_Curly_Access := Current_Curly; + + N : constant Natural := Cc.Cur + 1; + Ln : Natural := 0; + + Lastloc : constant Natural := Cc.Lastloc; + -- Detection of 0-len + + begin + -- If degenerate scan matches "", assume scan done + + if Input_Pos = Cc.Lastloc + and then N >= Cc.Min + then + -- Temporarily restore the old context, and check that we + -- match was comes after CURLYX. + + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Match (Cc.Next) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + return False; + end if; + + -- First, just match a string of min scans + + if N < Cc.Min then + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Debug then + Dump_Error + ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img); + end if; + + if Match (Cc.Scan) then + return True; + end if; + + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + + return False; + end if; + + -- Prefer next over scan for minimal matching + + if not Cc.Greedy then + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Recurse_Match (Cc.Next, Cc.Paren_Floor) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + + -- Maximum greed exceeded ? + + if N >= Cc.Max then + if Debug then + Dump_Error ("failed..."); + end if; + return False; + end if; + + -- Try scanning more and see if it helps + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Debug then + Dump_Error ("Next failed, what about Current?"); + end if; + + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then + return True; + end if; + + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + return False; + end if; + + -- Prefer scan over next for maximal matching + + if N < Cc.Max then -- more greed allowed ? + Cc.Cur := N; + Cc.Lastloc := Input_Pos; + + if Debug then + Dump_Error ("Recurse at current position"); + end if; + + if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then + return True; + end if; + end if; + + -- Failed deeper matches of scan, so see if this one works + + Current_Curly := Cc.Old_Cc; + + if Current_Curly /= null then + Ln := Current_Curly.Cur; + end if; + + if Debug then + Dump_Error ("Failed matching for later positions"); + end if; + + if Match (Cc.Next) then + return True; + end if; + + if Current_Curly /= null then + Current_Curly.Cur := Ln; + end if; + + Current_Curly := Cc; + Cc.Cur := N - 1; + Cc.Lastloc := Lastloc; + + if Debug then + Dump_Error ("failed..."); + end if; + + return False; + end Match_Whilem; + + ------------ + -- Repeat -- + ------------ + + function Repeat + (IP : Pointer; + Max : Natural := Natural'Last) return Natural + is + Scan : Natural := Input_Pos; + Last : Natural; + Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP))); + Count : Natural; + C : Character; + Is_First : Boolean := True; + Bitmap : Character_Class; + + begin + if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then + Last := Last_In_Data; + else + Last := Scan + Max - 1; + end if; + + case Op is + when ANY => + while Scan <= Last + and then Data (Scan) /= ASCII.LF + loop + Scan := Scan + 1; + end loop; + + when SANY => + Scan := Last + 1; + + when EXACT => + + -- The string has only one character if Repeat was called + + C := Program (String_Operand (IP)); + while Scan <= Last + and then C = Data (Scan) + loop + Scan := Scan + 1; + end loop; + + when EXACTF => + + -- The string has only one character if Repeat was called + + C := Program (String_Operand (IP)); + while Scan <= Last + and then To_Lower (C) = Data (Scan) + loop + Scan := Scan + 1; + end loop; + + when ANYOF => + if Is_First then + Bitmap_Operand (Program, IP, Bitmap); + Is_First := False; + end if; + + while Scan <= Last + and then Get_From_Class (Bitmap, Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when ALNUM => + while Scan <= Last + and then Is_Alnum (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NALNUM => + while Scan <= Last + and then not Is_Alnum (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when SPACE => + while Scan <= Last + and then Is_White_Space (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NSPACE => + while Scan <= Last + and then not Is_White_Space (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when DIGIT => + while Scan <= Last + and then Is_Digit (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when NDIGIT => + while Scan <= Last + and then not Is_Digit (Data (Scan)) + loop + Scan := Scan + 1; + end loop; + + when others => + raise Program_Error; + end case; + + Count := Scan - Input_Pos; + Input_Pos := Scan; + return Count; + end Repeat; + + --------- + -- Try -- + --------- + + function Try (Pos : Positive) return Boolean is + begin + Input_Pos := Pos; + Last_Paren := 0; + Matches_Full := (others => No_Match); + + if Match (Program_First) then + Matches_Full (0) := (Pos, Input_Pos - 1); + return True; + end if; + + return False; + end Try; + + -- Start of processing for Match + + begin + -- Do we have the regexp Never_Match? + + if Self.Size = 0 then + Matches := (others => No_Match); + return; + end if; + + -- If there is a "must appear" string, look for it + + if Self.Must_Have_Length > 0 then + declare + First : constant Character := Program (Self.Must_Have); + Must_First : constant Pointer := Self.Must_Have; + Must_Last : constant Pointer := + Must_First + Pointer (Self.Must_Have_Length - 1); + Next_Try : Natural := Index (First_In_Data, First); + + begin + while Next_Try /= 0 + and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1) + = String (Program (Must_First .. Must_Last)) + loop + Next_Try := Index (Next_Try + 1, First); + end loop; + + if Next_Try = 0 then + Matches := (others => No_Match); + return; -- Not present + end if; + end; + end if; + + -- Mark beginning of line for ^ + + BOL_Pos := Data'First; + + -- Simplest case first: an anchored match need be tried only once + + if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then + Matched := Try (First_In_Data); + + elsif Self.Anchored then + declare + Next_Try : Natural := First_In_Data; + begin + -- Test the first position in the buffer + Matched := Try (Next_Try); + + -- Else only test after newlines + + if not Matched then + while Next_Try <= Last_In_Data loop + while Next_Try <= Last_In_Data + and then Data (Next_Try) /= ASCII.LF + loop + Next_Try := Next_Try + 1; + end loop; + + Next_Try := Next_Try + 1; + + if Next_Try <= Last_In_Data then + Matched := Try (Next_Try); + exit when Matched; + end if; + end loop; + end if; + end; + + elsif Self.First /= ASCII.NUL then + -- We know what char it must start with + + declare + Next_Try : Natural := Index (First_In_Data, Self.First); + + begin + while Next_Try /= 0 loop + Matched := Try (Next_Try); + exit when Matched; + Next_Try := Index (Next_Try + 1, Self.First); + end loop; + end; + + else + -- Messy cases: try all locations (including for the empty string) + + Matched := Try (First_In_Data); + + if not Matched then + for S in First_In_Data + 1 .. Last_In_Data loop + Matched := Try (S); + exit when Matched; + end loop; + end if; + end if; + + -- Matched has its value + + for J in Last_Paren + 1 .. Matches'Last loop + Matches_Full (J) := No_Match; + end loop; + + Matches := Matches_Full (Matches'Range); + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (Self : Pattern_Matcher; + Data : String; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural + is + Matches : Match_Array (0 .. 0); + + begin + Match (Self, Data, Matches, Data_First, Data_Last); + if Matches (0) = No_Match then + return Data'First - 1; + else + return Matches (0).First; + end if; + end Match; + + function Match + (Self : Pattern_Matcher; + Data : String; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean + is + Matches : Match_Array (0 .. 0); + + begin + Match (Self, Data, Matches, Data_First, Data_Last); + return Matches (0).First >= Data'First; + end Match; + + procedure Match + (Expression : String; + Data : String; + Matches : out Match_Array; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) + is + PM : Pattern_Matcher (Size); + Finalize_Size : Program_Size; + pragma Unreferenced (Finalize_Size); + begin + if Size = 0 then + Match (Compile (Expression), Data, Matches, Data_First, Data_Last); + else + Compile (PM, Expression, Finalize_Size); + Match (PM, Data, Matches, Data_First, Data_Last); + end if; + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (Expression : String; + Data : String; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural + is + PM : Pattern_Matcher (Size); + Final_Size : Program_Size; + pragma Unreferenced (Final_Size); + begin + if Size = 0 then + return Match (Compile (Expression), Data, Data_First, Data_Last); + else + Compile (PM, Expression, Final_Size); + return Match (PM, Data, Data_First, Data_Last); + end if; + end Match; + + ----------- + -- Match -- + ----------- + + function Match + (Expression : String; + Data : String; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean + is + Matches : Match_Array (0 .. 0); + PM : Pattern_Matcher (Size); + Final_Size : Program_Size; + pragma Unreferenced (Final_Size); + begin + if Size = 0 then + Match (Compile (Expression), Data, Matches, Data_First, Data_Last); + else + Compile (PM, Expression, Final_Size); + Match (PM, Data, Matches, Data_First, Data_Last); + end if; + + return Matches (0).First >= Data'First; + end Match; + + ------------- + -- Operand -- + ------------- + + function Operand (P : Pointer) return Pointer is + begin + return P + Next_Pointer_Bytes; + end Operand; + + -------------- + -- Optimize -- + -------------- + + procedure Optimize (Self : in out Pattern_Matcher) is + Scan : Pointer; + Program : Program_Data renames Self.Program; + + begin + -- Start with safe defaults (no optimization): + -- * No known first character of match + -- * Does not necessarily start at beginning of line + -- * No string known that has to appear in data + + Self.First := ASCII.NUL; + Self.Anchored := False; + Self.Must_Have := Program'Last + 1; + Self.Must_Have_Length := 0; + + Scan := Program_First; -- First instruction (can be anything) + + if Program (Scan) = EXACT then + Self.First := Program (String_Operand (Scan)); + + elsif Program (Scan) = BOL + or else Program (Scan) = SBOL + or else Program (Scan) = MBOL + then + Self.Anchored := True; + end if; + end Optimize; + + ----------------- + -- Paren_Count -- + ----------------- + + function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is + begin + return Regexp.Paren_Count; + end Paren_Count; + + ----------- + -- Quote -- + ----------- + + function Quote (Str : String) return String is + S : String (1 .. Str'Length * 2); + Last : Natural := 0; + + begin + for J in Str'Range loop + case Str (J) is + when '^' | '$' | '|' | '*' | '+' | '?' | '{' | + '}' | '[' | ']' | '(' | ')' | '\' | '.' => + + S (Last + 1) := '\'; + S (Last + 2) := Str (J); + Last := Last + 2; + + when others => + S (Last + 1) := Str (J); + Last := Last + 1; + end case; + end loop; + + return S (1 .. Last); + end Quote; + + ------------------ + -- Read_Natural -- + ------------------ + + function Read_Natural + (Program : Program_Data; + IP : Pointer) return Natural + is + begin + return Character'Pos (Program (IP)) + + 256 * Character'Pos (Program (IP + 1)); + end Read_Natural; + + ----------------- + -- Reset_Class -- + ----------------- + + procedure Reset_Class (Bitmap : out Character_Class) is + begin + Bitmap := (others => 0); + end Reset_Class; + + ------------------ + -- Set_In_Class -- + ------------------ + + procedure Set_In_Class + (Bitmap : in out Character_Class; + C : Character) + is + Value : constant Class_Byte := Character'Pos (C); + begin + Bitmap (Value / 8) := Bitmap (Value / 8) + or Bit_Conversion (Value mod 8); + end Set_In_Class; + + ------------------- + -- String_Length -- + ------------------- + + function String_Length + (Program : Program_Data; + P : Pointer) return Program_Size + is + begin + pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); + return Character'Pos (Program (P + Next_Pointer_Bytes)); + end String_Length; + + -------------------- + -- String_Operand -- + -------------------- + + function String_Operand (P : Pointer) return Pointer is + begin + return P + 4; + end String_Operand; + +end System.Regpat; diff --git a/gcc/ada/libgnat/s-regpat.ads b/gcc/ada/libgnat/s-regpat.ads new file mode 100644 index 0000000..9f44d1d --- /dev/null +++ b/gcc/ada/libgnat/s-regpat.ads @@ -0,0 +1,649 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . R E G P A T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1986 by University of Toronto. -- +-- Copyright (C) 1996-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package implements roughly the same set of regular expressions as +-- are available in the Perl or Python programming languages. + +-- This is an extension of the original V7 style regular expression library +-- written in C by Henry Spencer. Apart from the translation to Ada, the +-- interface has been considerably changed to use the Ada String type +-- instead of C-style nul-terminated strings. + +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.Regpat (file g-regpat.ads). + +package System.Regpat is + pragma Preelaborate; + + -- The grammar is the following: + + -- regexp ::= expr + -- ::= ^ expr -- anchor at the beginning of string + -- ::= expr $ -- anchor at the end of string + + -- expr ::= term + -- ::= term | term -- alternation (term or term ...) + + -- term ::= item + -- ::= item item ... -- concatenation (item then item) + + -- item ::= elmt -- match elmt + -- ::= elmt * -- zero or more elmt's + -- ::= elmt + -- one or more elmt's + -- ::= elmt ? -- matches elmt or nothing + -- ::= elmt *? -- zero or more times, minimum number + -- ::= elmt +? -- one or more times, minimum number + -- ::= elmt ?? -- zero or one time, minimum number + -- ::= elmt { num } -- matches elmt exactly num times + -- ::= elmt { num , } -- matches elmt at least num times + -- ::= elmt { num , num2 } -- matches between num and num2 times + -- ::= elmt { num }? -- matches elmt exactly num times + -- ::= elmt { num , }? -- matches elmt at least num times + -- non-greedy version + -- ::= elmt { num , num2 }? -- matches between num and num2 times + -- non-greedy version + + -- elmt ::= nchr -- matches given character + -- ::= [range range ...] -- matches any character listed + -- ::= [^ range range ...] -- matches any character not listed + -- ::= . -- matches any single character + -- -- except newlines + -- ::= ( expr ) -- parenthesis used for grouping + -- ::= (?: expr ) -- non-capturing parenthesis + -- ::= \ num -- reference to num-th capturing + -- parenthesis + + -- range ::= char - char -- matches chars in given range + -- ::= nchr + -- ::= [: posix :] -- any character in the POSIX range + -- ::= [:^ posix :] -- not in the POSIX range + + -- posix ::= alnum -- alphanumeric characters + -- ::= alpha -- alphabetic characters + -- ::= ascii -- ascii characters (0 .. 127) + -- ::= cntrl -- control chars (0..31, 127..159) + -- ::= digit -- digits ('0' .. '9') + -- ::= graph -- graphic chars (32..126, 160..255) + -- ::= lower -- lower case characters + -- ::= print -- printable characters (32..127) + -- -- and whitespaces (9 .. 13) + -- ::= punct -- printable, except alphanumeric + -- ::= space -- space characters + -- ::= upper -- upper case characters + -- ::= word -- alphanumeric characters + -- ::= xdigit -- hexadecimal chars (0..9, a..f) + + -- char ::= any character, including special characters + -- ASCII.NUL is not supported. + + -- nchr ::= any character except \()[].*+?^ or \char to match char + -- \n means a newline (ASCII.LF) + -- \t means a tab (ASCII.HT) + -- \r means a return (ASCII.CR) + -- \b matches the empty string at the beginning or end of a + -- word. A word is defined as a set of alphanumerical + -- characters (see \w below). + -- \B matches the empty string only when *not* at the + -- beginning or end of a word. + -- \d matches any digit character ([0-9]) + -- \D matches any non digit character ([^0-9]) + -- \s matches any white space character. This is equivalent + -- to [ \t\n\r\f\v] (tab, form-feed, vertical-tab,... + -- \S matches any non-white space character. + -- \w matches any alphanumeric character or underscore. + -- This include accented letters, as defined in the + -- package Ada.Characters.Handling. + -- \W matches any non-alphanumeric character. + -- \A match the empty string only at the beginning of the + -- string, whatever flags are used for Compile (the + -- behavior of ^ can change, see Regexp_Flags below). + -- \G match the empty string only at the end of the + -- string, whatever flags are used for Compile (the + -- behavior of $ can change, see Regexp_Flags below). + -- ... ::= is used to indication repetition (one or more terms) + + -- Embedded newlines are not matched by the ^ operator. + -- It is possible to retrieve the substring matched a parenthesis + -- expression. Although the depth of parenthesis is not limited in the + -- regexp, only the first 9 substrings can be retrieved. + + -- The highest value possible for the arguments to the curly operator ({}) + -- are given by the constant Max_Curly_Repeat below. + + -- The operators '*', '+', '?' and '{}' always match the longest possible + -- substring. They all have a non-greedy version (with an extra ? after the + -- operator), which matches the shortest possible substring. + + -- For instance: + -- regexp="<.*>" string="

title

" matches="

title

" + -- regexp="<.*?>" string="

title

" matches="

" + -- + -- '{' and '}' are only considered as special characters if they appear + -- in a substring that looks exactly like '{n}', '{n,m}' or '{n,}', where + -- n and m are digits. No space is allowed. In other contexts, the curly + -- braces will simply be treated as normal characters. + + -- Compiling Regular Expressions + -- ============================= + + -- To use this package, you first need to compile the regular expression + -- (a string) into a byte-code program, in a Pattern_Matcher structure. + -- This first step checks that the regexp is valid, and optimizes the + -- matching algorithms of the second step. + + -- Two versions of the Compile subprogram are given: one in which this + -- package will compute itself the best possible size to allocate for the + -- byte code; the other where you must allocate enough memory yourself. An + -- exception is raised if there is not enough memory. + + -- declare + -- Regexp : String := "a|b"; + + -- Matcher : Pattern_Matcher := Compile (Regexp); + -- -- The size for matcher is automatically allocated + + -- Matcher2 : Pattern_Matcher (1000); + -- -- Some space is allocated directly. + + -- begin + -- Compile (Matcher2, Regexp); + -- ... + -- end; + + -- Note that the second version is significantly faster, since with the + -- first version the regular expression has in fact to be compiled twice + -- (first to compute the size, then to generate the byte code). + + -- Note also that you cannot use the function version of Compile if you + -- specify the size of the Pattern_Matcher, since the discriminants will + -- most probably be different and you will get a Constraint_Error + + -- Matching Strings + -- ================ + + -- Once the regular expression has been compiled, you can use it as often + -- as needed to match strings. + + -- Several versions of the Match subprogram are provided, with different + -- parameters and return results. + + -- See the description under each of these subprograms + + -- Here is a short example showing how to get the substring matched by + -- the first parenthesis pair. + + -- declare + -- Matches : Match_Array (0 .. 1); + -- Regexp : String := "a(b|c)d"; + -- Str : String := "gacdg"; + + -- begin + -- Match (Compile (Regexp), Str, Matches); + -- return Str (Matches (1).First .. Matches (1).Last); + -- -- returns 'c' + -- end; + + -- Finding all occurrences + -- ======================= + + -- Finding all the occurrences of a regular expression in a string cannot + -- be done by simply passing a slice of the string. This wouldn't work for + -- anchored regular expressions (the ones starting with "^" or ending with + -- "$"). + -- Instead, you need to use the last parameter to Match (Data_First), as in + -- the following loop: + + -- declare + -- Str : String := + -- "-- first line" & ASCII.LF & "-- second line"; + -- Matches : Match_Array (0 .. 0); + -- Regexp : Pattern_Matcher := Compile ("^--", Multiple_Lines); + -- Current : Natural := Str'First; + -- begin + -- loop + -- Match (Regexp, Str, Matches, Current); + -- exit when Matches (0) = No_Match; + -- + -- -- Process the match at position Matches (0).First + -- + -- Current := Matches (0).Last + 1; + -- end loop; + -- end; + + -- String Substitution + -- =================== + + -- No subprogram is currently provided for string substitution. + -- However, this is easy to simulate with the parenthesis groups, as + -- shown below. + + -- This example swaps the first two words of the string: + + -- declare + -- Regexp : String := "([a-z]+) +([a-z]+)"; + -- Str : String := " first second third "; + -- Matches : Match_Array (0 .. 2); + + -- begin + -- Match (Compile (Regexp), Str, Matches); + -- return Str (Str'First .. Matches (1).First - 1) + -- & Str (Matches (2).First .. Matches (2).Last) + -- & " " + -- & Str (Matches (1).First .. Matches (1).Last) + -- & Str (Matches (2).Last + 1 .. Str'Last); + -- -- returns " second first third " + -- end; + + --------------- + -- Constants -- + --------------- + + Expression_Error : exception; + -- This exception is raised when trying to compile an invalid regular + -- expression. All subprograms taking an expression as parameter may raise + -- Expression_Error. + + Max_Paren_Count : constant := 255; + -- Maximum number of parenthesis in a regular expression. This is limited + -- by the size of a Character, as found in the byte-compiled version of + -- regular expressions. + + Max_Curly_Repeat : constant := 32767; + -- Maximum number of repetition for the curly operator. The digits in the + -- {n}, {n,} and {n,m } operators cannot be higher than this constant, + -- since they have to fit on two characters in the byte-compiled version of + -- regular expressions. + + Max_Program_Size : constant := 2**15 - 1; + -- Maximum size that can be allocated for a program + + type Program_Size is range 0 .. Max_Program_Size; + for Program_Size'Size use 16; + -- Number of bytes allocated for the byte-compiled version of a regular + -- expression. The size required depends on the complexity of the regular + -- expression in a complex manner that is undocumented (other than in the + -- body of the Compile procedure). Normally the size is automatically set + -- and the programmer need not be concerned about it. There are two + -- exceptions to this. First in the calls to Match, it is possible to + -- specify a non-zero size that is known to be large enough. This can + -- slightly increase the efficiency by avoiding a copy. Second, in the case + -- of calling compile, it is possible using the procedural form of Compile + -- to use a single Pattern_Matcher variable for several different + -- expressions by setting its size sufficiently large. + + Auto_Size : constant := 0; + -- Used in calls to Match to indicate that the Size should be set to + -- a value appropriate to the expression being used automatically. + + type Regexp_Flags is mod 256; + for Regexp_Flags'Size use 8; + -- Flags that can be given at compile time to specify default + -- properties for the regular expression. + + No_Flags : constant Regexp_Flags; + Case_Insensitive : constant Regexp_Flags; + -- The automaton is optimized so that the matching is done in a case + -- insensitive manner (upper case characters and lower case characters + -- are all treated the same way). + + Single_Line : constant Regexp_Flags; + -- Treat the Data we are matching as a single line. This means that + -- ^ and $ will ignore \n (unless Multiple_Lines is also specified), + -- and that '.' will match \n. + + Multiple_Lines : constant Regexp_Flags; + -- Treat the Data as multiple lines. This means that ^ and $ will also + -- match on internal newlines (ASCII.LF), in addition to the beginning + -- and end of the string. + -- + -- This can be combined with Single_Line. + + ----------------- + -- Match_Array -- + ----------------- + + subtype Match_Count is Natural range 0 .. Max_Paren_Count; + + type Match_Location is record + First : Natural := 0; + Last : Natural := 0; + end record; + + type Match_Array is array (Match_Count range <>) of Match_Location; + -- Used for regular expressions that can contain parenthesized + -- subexpressions. Certain Match subprograms below produce Matches of type + -- Match_Array. Each component of Matches is set to the subrange of the + -- matches substring, or to No_Match if no match. Matches (N) is for the + -- N'th parenthesized subexpressions; Matches (0) is for the whole + -- expression. + -- + -- Non-capturing parenthesis (introduced with (?:...)) can not be + -- retrieved and do not count in the match array index. + -- + -- For instance, if your regular expression is: "a((b*)c+)(d+)", then + -- 12 3 + -- Matches (0) is for "a((b*)c+)(d+)" (the entire expression) + -- Matches (1) is for "(b*)c+" + -- Matches (2) is for "b*" + -- Matches (3) is for "d+" + -- + -- The number of parenthesis groups that can be retrieved is limited only + -- by Max_Paren_Count. + -- + -- Normally, the bounds of the Matches actual parameter will be + -- 0 .. Paren_Count (Regexp), to get all the matches. However, it is fine + -- if Matches is shorter than that on either end; missing components will + -- be ignored. Thus, in the above example, you could use 2 .. 2 if all you + -- care about it the second parenthesis pair "b*". Likewise, if + -- Matches'Last > Paren_Count (Regexp), the extra components will be set to + -- No_Match. + + No_Match : constant Match_Location := (First => 0, Last => 0); + -- The No_Match constant is (0, 0) to differentiate between matching a null + -- string at position 1, which uses (1, 0) and no match at all. + + --------------------------------- + -- Pattern_Matcher Compilation -- + --------------------------------- + + -- The subprograms here are used to precompile regular expressions for use + -- in subsequent Match calls. Precompilation improves efficiency if the + -- same regular expression is to be used in more than one Match call. + + type Pattern_Matcher (Size : Program_Size) is private; + -- Type used to represent a regular expression compiled into byte code + + Never_Match : constant Pattern_Matcher; + -- A regular expression that never matches anything + + function Compile + (Expression : String; + Flags : Regexp_Flags := No_Flags) return Pattern_Matcher; + -- Compile a regular expression into internal code + -- + -- Raises Expression_Error if Expression is not a legal regular expression + -- + -- The appropriate size is calculated automatically to correspond to the + -- provided expression. This is the normal default method of compilation. + -- Note that it is generally not possible to assign the result of two + -- different calls to this Compile function to the same Pattern_Matcher + -- variable, since the sizes will differ. + -- + -- Flags is the default value to use to set properties for Expression + -- (e.g. case sensitivity,...). + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Final_Code_Size : out Program_Size; + Flags : Regexp_Flags := No_Flags); + -- Compile a regular expression into internal code + + -- This procedure is significantly faster than the Compile function since + -- it avoids the extra step of precomputing the required size. + -- + -- However, it requires the user to provide a Pattern_Matcher variable + -- whose size is preset to a large enough value. One advantage of this + -- approach, in addition to the improved efficiency, is that the same + -- Pattern_Matcher variable can be used to hold the compiled code for + -- several different regular expressions by setting a size that is large + -- enough to accommodate all possibilities. + -- + -- In this version of the procedure call, the actual required code size is + -- returned. Also if Matcher.Size is zero on entry, then the resulting code + -- is not stored. A call with Matcher.Size set to Auto_Size can thus be + -- used to determine the space required for compiling the given regular + -- expression. + -- + -- This function raises Storage_Error if Matcher is too small to hold + -- the resulting code (i.e. Matcher.Size has too small a value). + -- + -- Expression_Error is raised if the string Expression does not contain + -- a valid regular expression. + -- + -- Flags is the default value to use to set properties for Expression (case + -- sensitivity,...). + + procedure Compile + (Matcher : out Pattern_Matcher; + Expression : String; + Flags : Regexp_Flags := No_Flags); + -- Same procedure as above, expect it does not return the final + -- program size, and Matcher.Size cannot be Auto_Size. + + function Paren_Count (Regexp : Pattern_Matcher) return Match_Count; + pragma Inline (Paren_Count); + -- Return the number of parenthesis pairs in Regexp. + -- + -- This is the maximum index that will be filled if a Match_Array is + -- used as an argument to Match. + -- + -- Thus, if you want to be sure to get all the parenthesis, you should + -- do something like: + -- + -- declare + -- Regexp : Pattern_Matcher := Compile ("a(b*)(c+)"); + -- Matched : Match_Array (0 .. Paren_Count (Regexp)); + -- begin + -- Match (Regexp, "a string", Matched); + -- end; + + ------------- + -- Quoting -- + ------------- + + function Quote (Str : String) return String; + -- Return a version of Str so that every special character is quoted. + -- The resulting string can be used in a regular expression to match + -- exactly Str, whatever character was present in Str. + + -------------- + -- Matching -- + -------------- + + -- The Match subprograms are given a regular expression in string + -- form, and perform the corresponding match. The following parameters + -- are present in all forms of the Match call. + + -- Expression contains the regular expression to be matched as a string + + -- Data contains the string to be matched + + -- Data_First is the lower bound for the match, i.e. Data (Data_First) + -- will be the first character to be examined. If Data_First is set to + -- the special value of -1 (the default), then the first character to + -- be examined is Data (Data_First). However, the regular expression + -- character ^ (start of string) still refers to the first character + -- of the full string (Data (Data'First)), which is why there is a + -- separate mechanism for specifying Data_First. + + -- Data_Last is the upper bound for the match, i.e. Data (Data_Last) + -- will be the last character to be examined. If Data_Last is set to + -- the special value of Positive'Last (the default), then the last + -- character to be examined is Data (Data_Last). However, the regular + -- expression character $ (end of string) still refers to the last + -- character of the full string (Data (Data'Last)), which is why there + -- is a separate mechanism for specifying Data_Last. + + -- Note: the use of Data_First and Data_Last is not equivalent to + -- simply passing a slice as Expression because of the handling of + -- regular expression characters ^ and $. + + -- Size is the size allocated for the compiled byte code. Normally + -- this is defaulted to Auto_Size which means that the appropriate + -- size is allocated automatically. It is possible to specify an + -- explicit size, which must be sufficiently large. This slightly + -- increases the efficiency by avoiding the extra step of computing + -- the appropriate size. + + -- The following exceptions can be raised in calls to Match + -- + -- Storage_Error is raised if a non-zero value is given for Size + -- and it is too small to hold the compiled byte code. + -- + -- Expression_Error is raised if the given expression is not a legal + -- regular expression. + + procedure Match + (Expression : String; + Data : String; + Matches : out Match_Array; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last); + -- This version returns the result of the match stored in Match_Array; + -- see comments under Match_Array above for details. + + function Match + (Expression : String; + Data : String; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural; + -- This version returns the position where Data matches, or if there is + -- no match, then the value Data'First - 1. + + function Match + (Expression : String; + Data : String; + Size : Program_Size := Auto_Size; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean; + -- This version returns True if the match succeeds, False otherwise + + ------------------------------------------------ + -- Matching a Pre-Compiled Regular Expression -- + ------------------------------------------------ + + -- The following functions are significantly faster if you need to reuse + -- the same regular expression multiple times, since you only have to + -- compile it once. For these functions you must first compile the + -- expression with a call to Compile as previously described. + + -- The parameters Data, Data_First and Data_Last are as described + -- in the previous section. + + function Match + (Self : Pattern_Matcher; + Data : String; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Natural; + -- Match Data using the given pattern matcher. Returns the position + -- where Data matches, or (Data'First - 1) if there is no match. + + function Match + (Self : Pattern_Matcher; + Data : String; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last) return Boolean; + -- Return True if Data matches using the given pattern matcher + + pragma Inline (Match); + -- All except the last one below + + procedure Match + (Self : Pattern_Matcher; + Data : String; + Matches : out Match_Array; + Data_First : Integer := -1; + Data_Last : Positive := Positive'Last); + -- Match Data using the given pattern matcher and store result in Matches; + -- see comments under Match_Array above for details. + + ----------- + -- Debug -- + ----------- + + procedure Dump (Self : Pattern_Matcher); + -- Dump the compiled version of the regular expression matched by Self + +-------------------------- +-- Private Declarations -- +-------------------------- + +private + + subtype Pointer is Program_Size; + -- The Pointer type is used to point into Program_Data + + -- Note that the pointer type is not necessarily 2 bytes + -- although it is stored in the program using 2 bytes + + type Program_Data is array (Pointer range <>) of Character; + + Program_First : constant := 1; + + -- The "internal use only" fields in regexp are present to pass info from + -- compile to execute that permits the execute phase to run lots faster on + -- simple cases. They are: + + -- First character that must begin a match or ASCII.NUL + -- Anchored true iff match must start at beginning of line + -- Must_Have pointer to string that match must include or null + -- Must_Have_Length length of Must_Have string + + -- First and Anchored permit very fast decisions on suitable starting + -- points for a match, cutting down the work a lot. Must_Have permits fast + -- rejection of lines that cannot possibly match. + + -- The Must_Have tests are costly enough that Optimize supplies a Must_Have + -- only if the r.e. contains something potentially expensive (at present, + -- the only such thing detected is * or at the start of the r.e., which can + -- involve a lot of backup). The length is supplied because the test in + -- Execute needs it and Optimize is computing it anyway. + + -- The initialization is meant to fail-safe in case the user of this + -- package tries to use an uninitialized matcher. This takes advantage + -- of the knowledge that ASCII.NUL translates to the end-of-program (EOP) + -- instruction code of the state machine. + + No_Flags : constant Regexp_Flags := 0; + Case_Insensitive : constant Regexp_Flags := 1; + Single_Line : constant Regexp_Flags := 2; + Multiple_Lines : constant Regexp_Flags := 4; + + type Pattern_Matcher (Size : Pointer) is record + First : Character := ASCII.NUL; -- internal use only + Anchored : Boolean := False; -- internal use only + Must_Have : Pointer := 0; -- internal use only + Must_Have_Length : Natural := 0; -- internal use only + Paren_Count : Natural := 0; -- # paren groups + Flags : Regexp_Flags := No_Flags; + Program : Program_Data (Program_First .. Size) := + (others => ASCII.NUL); + end record; + + Never_Match : constant Pattern_Matcher := + (0, ASCII.NUL, False, 0, 0, 0, No_Flags, (others => ASCII.NUL)); + +end System.Regpat; diff --git a/gcc/ada/libgnat/s-resfil.adb b/gcc/ada/libgnat/s-resfil.adb new file mode 100644 index 0000000..b36ff94 --- /dev/null +++ b/gcc/ada/libgnat/s-resfil.adb @@ -0,0 +1,525 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R E S P O N S E _ F I L E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Deallocation; + +with System.OS_Lib; use System.OS_Lib; + +package body System.Response_File is + + type File_Rec; + type File_Ptr is access File_Rec; + type File_Rec is record + Name : String_Access; + Next : File_Ptr; + Prev : File_Ptr; + end record; + -- To build a stack of response file names + + procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr); + + type Argument_List_Access is access Argument_List; + procedure Free is new Ada.Unchecked_Deallocation + (Argument_List, Argument_List_Access); + -- Free only the allocated Argument_List, not allocated String components + + -------------------- + -- Arguments_From -- + -------------------- + + function Arguments_From + (Response_File_Name : String; + Recursive : Boolean := False; + Ignore_Non_Existing_Files : Boolean := False) + return Argument_List + is + First_File : File_Ptr := null; + Last_File : File_Ptr := null; + -- The stack of response files + + Arguments : Argument_List_Access := new Argument_List (1 .. 4); + Last_Arg : Natural := 0; + + procedure Add_Argument (Arg : String); + -- Add argument Arg to argument list Arguments, increasing Arguments + -- if necessary. + + procedure Recurse (File_Name : String); + -- Get the arguments from the file and call itself recursively if one of + -- the arguments starts with character '@'. + + ------------------ + -- Add_Argument -- + ------------------ + + procedure Add_Argument (Arg : String) is + begin + if Last_Arg = Arguments'Last then + declare + New_Arguments : constant Argument_List_Access := + new Argument_List (1 .. Arguments'Last * 2); + begin + New_Arguments (Arguments'Range) := Arguments.all; + Arguments.all := (others => null); + Free (Arguments); + Arguments := New_Arguments; + end; + end if; + + Last_Arg := Last_Arg + 1; + Arguments (Last_Arg) := new String'(Arg); + end Add_Argument; + + ------------- + -- Recurse -- + ------------- + + procedure Recurse (File_Name : String) is + -- Open the response file. If not found, fail or report a warning, + -- depending on the value of Ignore_Non_Existing_Files. + + FD : constant File_Descriptor := Open_Read (File_Name, Text); + + Buffer_Size : constant := 1500; + Buffer : String (1 .. Buffer_Size); + + Buffer_Length : Natural; + + Buffer_Cursor : Natural; + + End_Of_File_Reached : Boolean; + + Line : String (1 .. Max_Line_Length + 1); + Last : Natural; + + First_Char : Positive; + -- Index of the first character of an argument in Line + + Last_Char : Natural; + -- Index of the last character of an argument in Line + + In_String : Boolean; + -- True when inside a quoted string + + Arg : Positive; + + function End_Of_File return Boolean; + -- True when the end of the response file has been reached + + procedure Get_Buffer; + -- Read one buffer from the response file + + procedure Get_Line; + -- Get one line from the response file + + ----------------- + -- End_Of_File -- + ----------------- + + function End_Of_File return Boolean is + begin + return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length; + end End_Of_File; + + ---------------- + -- Get_Buffer -- + ---------------- + + procedure Get_Buffer is + begin + Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length); + End_Of_File_Reached := Buffer_Length < Buffer'Length; + Buffer_Cursor := 1; + end Get_Buffer; + + -------------- + -- Get_Line -- + -------------- + + procedure Get_Line is + Ch : Character; + + begin + Last := 0; + + if End_Of_File then + return; + end if; + + loop + Ch := Buffer (Buffer_Cursor); + + exit when Ch = ASCII.CR or else + Ch = ASCII.LF or else + Ch = ASCII.FF; + + Last := Last + 1; + Line (Last) := Ch; + + if Last = Line'Last then + return; + end if; + + Buffer_Cursor := Buffer_Cursor + 1; + + if Buffer_Cursor > Buffer_Length then + Get_Buffer; + + if End_Of_File then + return; + end if; + end if; + end loop; + + loop + Ch := Buffer (Buffer_Cursor); + + exit when Ch /= ASCII.HT and then + Ch /= ASCII.LF and then + Ch /= ASCII.FF; + + Buffer_Cursor := Buffer_Cursor + 1; + + if Buffer_Cursor > Buffer_Length then + Get_Buffer; + + if End_Of_File then + return; + end if; + end if; + end loop; + end Get_Line; + + -- Start of processing for Recurse + + begin + Last_Arg := 0; + + if FD = Invalid_FD then + if Ignore_Non_Existing_Files then + return; + else + raise File_Does_Not_Exist; + end if; + end if; + + -- Put the response file name on the stack + + if First_File = null then + First_File := + new File_Rec' + (Name => new String'(File_Name), + Next => null, + Prev => null); + Last_File := First_File; + + else + declare + Current : File_Ptr := First_File; + + begin + loop + if Current.Name.all = File_Name then + raise Circularity_Detected; + end if; + + Current := Current.Next; + exit when Current = null; + end loop; + + Last_File.Next := + new File_Rec' + (Name => new String'(File_Name), + Next => null, + Prev => Last_File); + Last_File := Last_File.Next; + end; + end if; + + End_Of_File_Reached := False; + Get_Buffer; + + -- Read the response file line by line + + Line_Loop : + while not End_Of_File loop + Get_Line; + + if Last = Line'Last then + raise Line_Too_Long; + end if; + + First_Char := 1; + + -- Get each argument on the line + + Arg_Loop : + loop + -- First, skip any white space + + while First_Char <= Last loop + exit when Line (First_Char) /= ' ' and then + Line (First_Char) /= ASCII.HT; + First_Char := First_Char + 1; + end loop; + + exit Arg_Loop when First_Char > Last; + + Last_Char := First_Char; + In_String := False; + + -- Get the character one by one + + Character_Loop : + while Last_Char <= Last loop + + -- Inside a string, check only for '"' + + if In_String then + if Line (Last_Char) = '"' then + + -- Remove the '"' + + Line (Last_Char .. Last - 1) := + Line (Last_Char + 1 .. Last); + Last := Last - 1; + + -- End of string is end of argument + + if Last_Char > Last or else + Line (Last_Char) = ' ' or else + Line (Last_Char) = ASCII.HT + then + In_String := False; + + Last_Char := Last_Char - 1; + exit Character_Loop; + + else + -- If there are two consecutive '"', the quoted + -- string is not closed + + In_String := Line (Last_Char) = '"'; + + if In_String then + Last_Char := Last_Char + 1; + end if; + end if; + + else + Last_Char := Last_Char + 1; + end if; + + elsif Last_Char = Last then + + -- An opening '"' at the end of the line is an error + + if Line (Last) = '"' then + raise No_Closing_Quote; + + else + -- The argument ends with the line + + exit Character_Loop; + end if; + + elsif Line (Last_Char) = '"' then + + -- Entering a quoted string: remove the '"' + + In_String := True; + Line (Last_Char .. Last - 1) := + Line (Last_Char + 1 .. Last); + Last := Last - 1; + + else + -- Outside quoted strings, white space ends the argument + + exit Character_Loop + when Line (Last_Char + 1) = ' ' or else + Line (Last_Char + 1) = ASCII.HT; + + Last_Char := Last_Char + 1; + end if; + end loop Character_Loop; + + -- It is an error to not close a quoted string before the end + -- of the line. + + if In_String then + raise No_Closing_Quote; + end if; + + -- Add the argument to the list + + declare + Arg : String (1 .. Last_Char - First_Char + 1); + begin + Arg := Line (First_Char .. Last_Char); + Add_Argument (Arg); + end; + + -- Next argument, if line is not finished + + First_Char := Last_Char + 1; + end loop Arg_Loop; + end loop Line_Loop; + + Close (FD); + + -- If Recursive is True, check for any argument starting with '@' + + if Recursive then + Arg := 1; + while Arg <= Last_Arg loop + + if Arguments (Arg)'Length > 0 and then + Arguments (Arg) (1) = '@' + then + -- Ignore argument '@' with no file name + + if Arguments (Arg)'Length = 1 then + Arguments (Arg .. Last_Arg - 1) := + Arguments (Arg + 1 .. Last_Arg); + Last_Arg := Last_Arg - 1; + + else + -- Save the current arguments and get those in the new + -- response file. + + declare + Inc_File_Name : constant String := + Arguments (Arg) (2 .. Arguments (Arg)'Last); + Current_Arguments : constant Argument_List := + Arguments (1 .. Last_Arg); + begin + Recurse (Inc_File_Name); + + -- Insert the new arguments where the new response + -- file was imported. + + declare + New_Arguments : constant Argument_List := + Arguments (1 .. Last_Arg); + New_Last_Arg : constant Positive := + Current_Arguments'Length + + New_Arguments'Length - 1; + + begin + -- Grow Arguments if it is not large enough + + if Arguments'Last < New_Last_Arg then + Last_Arg := Arguments'Last; + Free (Arguments); + + while Last_Arg < New_Last_Arg loop + Last_Arg := Last_Arg * 2; + end loop; + + Arguments := new Argument_List (1 .. Last_Arg); + end if; + + Last_Arg := New_Last_Arg; + + Arguments (1 .. Last_Arg) := + Current_Arguments (1 .. Arg - 1) & + New_Arguments & + Current_Arguments + (Arg + 1 .. Current_Arguments'Last); + + Arg := Arg + New_Arguments'Length; + end; + end; + end if; + + else + Arg := Arg + 1; + end if; + end loop; + end if; + + -- Remove the response file name from the stack + + if First_File = Last_File then + System.Strings.Free (First_File.Name); + Free (First_File); + First_File := null; + Last_File := null; + + else + System.Strings.Free (Last_File.Name); + Last_File := Last_File.Prev; + Free (Last_File.Next); + end if; + + exception + when others => + Close (FD); + + raise; + end Recurse; + + -- Start of processing for Arguments_From + + begin + -- The job is done by procedure Recurse + + Recurse (Response_File_Name); + + -- Free Arguments before returning the result + + declare + Result : constant Argument_List := Arguments (1 .. Last_Arg); + begin + Free (Arguments); + return Result; + end; + + exception + when others => + + -- When an exception occurs, deallocate everything + + Free (Arguments); + + while First_File /= null loop + Last_File := First_File.Next; + System.Strings.Free (First_File.Name); + Free (First_File); + First_File := Last_File; + end loop; + + raise; + end Arguments_From; + +end System.Response_File; diff --git a/gcc/ada/libgnat/s-resfil.ads b/gcc/ada/libgnat/s-resfil.ads new file mode 100644 index 0000000..fbb7f7af --- /dev/null +++ b/gcc/ada/libgnat/s-resfil.ads @@ -0,0 +1,99 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R E S P O N S E _ F I L E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities for getting command line arguments +-- from a text file, called a "response file". +-- +-- Using a response file allow passing a set of arguments to an executable +-- longer than the maximum allowed by the system on the command line. + +pragma Compiler_Unit_Warning; + +with System.Strings; + +package System.Response_File is + + subtype String_Access is System.Strings.String_Access; + -- type String_Access is access all String; + + procedure Free (S : in out String_Access) renames System.Strings.Free; + -- To deallocate a String + + subtype Argument_List is System.Strings.String_List; + -- type String_List is array (Positive range <>) of String_Access; + + Max_Line_Length : constant := 4096; + -- The maximum length of lines in a response file + + File_Does_Not_Exist : exception; + -- Raise by Arguments_From when a response file cannot be found + + Line_Too_Long : exception; + -- Raise by Arguments_From when a line in the response file is longer than + -- Max_Line_Length. + + No_Closing_Quote : exception; + -- Raise by Arguments_From when a quoted string does not end before the + -- end of the line. + + Circularity_Detected : exception; + -- Raise by Arguments_From when Recursive is True and the same response + -- file is reading itself, either directly or indirectly. + + function Arguments_From + (Response_File_Name : String; + Recursive : Boolean := False; + Ignore_Non_Existing_Files : Boolean := False) + return Argument_List; + -- Read response file with name Response_File_Name and return the argument + -- it contains as an Argument_List. It is the responsibility of the caller + -- to deallocate the strings in the Argument_List if desired. When + -- Recursive is True, any argument of the form @file_name indicates the + -- name of another response file and is replaced by the arguments in this + -- response file. + -- + -- Each nonempty line of the response file contains one or several + -- arguments separated by white space. Empty lines or lines containing only + -- white space are ignored. Arguments containing white space or a double + -- quote ('"')must be quoted. A double quote inside a quote string is + -- indicated by two consecutive double quotes. Example: "-Idir with quote + -- "" and spaces". Non-white-space characters immediately before or after a + -- quoted string are part of the same argument. Ex: -Idir" with "spaces + -- + -- When a response file cannot be found, exception File_Does_Not_Exist is + -- raised if Ignore_Non_Existing_Files is False, otherwise the response + -- file is ignored. Exception Line_Too_Long is raised when a line of a + -- response file is longer than Max_Line_Length. Exception No_Closing_Quote + -- is raised when a quoted argument is not closed before the end of the + -- line. Exception Circularity_Detected is raised when a Recursive is True + -- and a response file is reading itself, either directly or indirectly. + +end System.Response_File; diff --git a/gcc/ada/libgnat/s-restri.adb b/gcc/ada/libgnat/s-restri.adb new file mode 100644 index 0000000..bef2f00 --- /dev/null +++ b/gcc/ada/libgnat/s-restri.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R E S T R I C T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.Restrictions is + use Rident; + + ------------------- + -- Abort_Allowed -- + ------------------- + + function Abort_Allowed return Boolean is + begin + return Run_Time_Restrictions.Violated (No_Abort_Statements) + or else + Run_Time_Restrictions.Violated (Max_Asynchronous_Select_Nesting); + end Abort_Allowed; + + --------------------- + -- Tasking_Allowed -- + --------------------- + + function Tasking_Allowed return Boolean is + begin + return Run_Time_Restrictions.Violated (Max_Tasks) + or else + Run_Time_Restrictions.Violated (No_Tasking); + end Tasking_Allowed; + +end System.Restrictions; diff --git a/gcc/ada/libgnat/s-restri.ads b/gcc/ada/libgnat/s-restri.ads new file mode 100644 index 0000000..82b5e88 --- /dev/null +++ b/gcc/ada/libgnat/s-restri.ads @@ -0,0 +1,77 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R E S T R I C T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 run-time interface for checking the set of +-- restrictions that applies to the current partition. The information +-- comes both from explicit restriction pragmas present, and also from +-- compile time checking. + +-- The package simply contains an instantiation of System.Rident, but +-- with names discarded, so that we do not have image tables for the +-- large restriction enumeration types at run time. + +pragma Compiler_Unit_Warning; + +with System.Rident; + +package System.Restrictions is + pragma Preelaborate; + + pragma Discard_Names; + package Rident is new System.Rident; + -- Instantiate a copy of System.Rident without enumeration image names + + Run_Time_Restrictions : Rident.Restrictions_Info; + -- Restrictions as set by the user, or detected by the binder. See details + -- in package System.Rident for what restrictions are included in the list + -- and the format of the information. + -- + -- Note that a restriction which is both Set and Violated at run-time means + -- that the violation was detected as part of the Ada run-time and not as + -- part of user code. + + ------------------ + -- Subprograms -- + ----------------- + + function Abort_Allowed return Boolean; + pragma Inline (Abort_Allowed); + -- Tests to see if abort is allowed by the current restrictions settings. + -- For abort to be allowed, either No_Abort_Statements must be False, or + -- Max_Asynchronous_Select_Nesting must be non-zero. + + function Tasking_Allowed return Boolean; + pragma Inline (Tasking_Allowed); + -- Tests to see if tasking operations are allowed by the current + -- restrictions settings. For tasking to be allowed, No_Tasking must + -- be False, and Max_Tasks must not be set to zero. + +end System.Restrictions; diff --git a/gcc/ada/libgnat/s-rident.ads b/gcc/ada/libgnat/s-rident.ads new file mode 100644 index 0000000..cd88593 --- /dev/null +++ b/gcc/ada/libgnat/s-rident.ads @@ -0,0 +1,642 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R I D E N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the set of restriction identifiers. It is a generic +-- package that is instantiated by the compiler/binder in package Rident, and +-- is instantiated in package System.Restrictions for use at run-time. + +-- The reason that we make this a generic package is so that in the case of +-- the instantiation in Rident for use at compile time and bind time, we can +-- generate normal image tables for the enumeration types, which are needed +-- for diagnostic and informational messages. At run-time we really do not +-- want to waste the space for these image tables, and they are not needed, +-- so we can do the instantiation under control of Discard_Names to remove +-- the tables. + +--------------------------------------------------- +-- Note On Compile/Run-Time Consistency Checking -- +--------------------------------------------------- + +-- This unit is with'ed by the run-time (to make System.Restrictions which is +-- used for run-time access to restriction information), by the compiler (to +-- determine what restrictions are implemented and what their category is) and +-- by the binder (in processing ali files, and generating the information used +-- at run-time to access restriction information). + +-- Normally the version of System.Rident referenced in all three contexts +-- should be the same. However, problems could arise in certain inconsistent +-- builds that used inconsistent versions of the compiler and run-time. This +-- sort of thing is not strictly correct, but it does arise when short-cuts +-- are taken in build procedures. + +-- Previously, this kind of inconsistency could cause a significant problem. +-- If versions of System.Rident accessed by the compiler and binder differed, +-- then the binder could fail to recognize the R (restrictions line) in the +-- ali file, leading to bind errors when restrictions were added or removed. + +-- The latest implementation avoids both this problem by using a named +-- scheme for recording restrictions, rather than a positional scheme which +-- fails completely if restrictions are added or subtracted. Now the worst +-- that happens at bind time in inconsistent builds is that unrecognized +-- restrictions are ignored, and the consistency checking for restrictions +-- might be incomplete, which is no big deal. + +pragma Compiler_Unit_Warning; + +generic +package System.Rident is + pragma Preelaborate; + + -- The following enumeration type defines the set of restriction + -- identifiers that are implemented in GNAT. + + -- To add a new restriction identifier, add an entry with the name to be + -- used in the pragma, and add calls to the Restrict.Check_Restriction + -- routine as appropriate. + + type Restriction_Id is + + -- The following cases are checked for consistency in the binder. The + -- binder will check that every unit either has the restriction set, or + -- does not violate the restriction. + + (Simple_Barriers, -- Ada 2012 (D.7 (10.9/3)) + Pure_Barriers, -- GNAT + No_Abort_Statements, -- (RM D.7(5), H.4(3)) + No_Access_Parameter_Allocators, -- Ada 2012 (RM H.4 (8.3/3)) + No_Access_Subprograms, -- (RM H.4(17)) + No_Allocators, -- (RM H.4(7)) + No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1)) + No_Asynchronous_Control, -- (RM J.13(3/2) + No_Calendar, -- GNAT + No_Coextensions, -- Ada 2012 (RM H.4(8.2/3)) + No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2)) + No_Delay, -- (RM H.4(21)) + No_Direct_Boolean_Operators, -- GNAT + No_Dispatch, -- (RM H.4(19)) + No_Dispatching_Calls, -- GNAT + No_Dynamic_Attachment, -- Ada 2012 (RM E.7(10/3)) + No_Dynamic_Priorities, -- (RM D.9(9)) + No_Enumeration_Maps, -- GNAT + No_Entry_Calls_In_Elaboration_Code, -- GNAT + No_Entry_Queue, -- GNAT (Ravenscar) + No_Exception_Handlers, -- GNAT + No_Exception_Propagation, -- GNAT + No_Exception_Registration, -- GNAT + No_Exceptions, -- (RM H.4(12)) + No_Finalization, -- GNAT + No_Fixed_IO, -- GNAT + No_Fixed_Point, -- (RM H.4(15)) + No_Floating_Point, -- (RM H.4(14)) + No_IO, -- (RM H.4(20)) + No_Implicit_Conditionals, -- GNAT + No_Implicit_Dynamic_Code, -- GNAT + No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) + No_Implicit_Task_Allocations, -- GNAT + No_Implicit_Protected_Object_Allocations, -- GNAT + No_Initialize_Scalars, -- GNAT + No_Local_Allocators, -- (RM H.4(8)) + No_Local_Timing_Events, -- (RM D.7(10.2/2)) + No_Local_Protected_Objects, -- Ada 2012 (D.7(10/1.3)) + No_Long_Long_Integers, -- GNAT + No_Multiple_Elaboration, -- GNAT + No_Nested_Finalization, -- (RM D.7(4)) + No_Protected_Type_Allocators, -- Ada 2012 (D.7 (10.3/2)) + No_Protected_Types, -- (RM H.4(5)) + No_Recursion, -- (RM H.4(22)) + No_Reentrancy, -- (RM H.4(23)) + No_Relative_Delay, -- Ada 2012 (D.7 (10.5/3)) + No_Requeue_Statements, -- Ada 2012 (D.7 (10.6/3)) + No_Secondary_Stack, -- GNAT + No_Select_Statements, -- Ada 2012 (D.7 (10.7/4)) + No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) + No_Standard_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2)) + No_Standard_Storage_Pools, -- GNAT + No_Stream_Optimizations, -- GNAT + No_Streams, -- GNAT + No_Task_Allocators, -- (RM D.7(7)) + No_Task_Attributes_Package, -- GNAT + No_Task_At_Interrupt_Priority, -- GNAT + No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) + No_Task_Termination, -- GNAT (Ravenscar) + No_Tasking, -- GNAT + No_Terminate_Alternatives, -- (RM D.7(6)) + No_Unchecked_Access, -- (RM H.4(18)) + No_Unchecked_Conversion, -- (RM J.13(4/2)) + No_Unchecked_Deallocation, -- (RM J.13(5/2)) + Static_Priorities, -- GNAT + Static_Storage_Size, -- GNAT + + -- The following require consistency checking with special rules. See + -- individual routines in unit Bcheck for details of what is required. + + No_Default_Initialization, -- GNAT + + -- The following cases do not require consistency checking and if used + -- as a configuration pragma within a specific unit, apply only to that + -- unit (e.g. if used in the package spec, do not apply to the body) + + -- Note: No_Elaboration_Code is handled specially. Like the other + -- non-partition-wide restrictions, it can only be set in a unit that + -- is part of the extended main source unit (body/spec/subunits). But + -- it is sticky, in that if it is found anywhere within any of these + -- units, it applies to all units in this extended main source. + + Immediate_Reclamation, -- (RM H.4(10)) + No_Dynamic_Sized_Objects, -- GNAT + No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 + No_Implementation_Attributes, -- Ada 2005 AI-257 + No_Implementation_Identifiers, -- Ada 2012 AI-246 + No_Implementation_Pragmas, -- Ada 2005 AI-257 + No_Implementation_Restrictions, -- GNAT + No_Implementation_Units, -- Ada 2012 AI-242 + No_Implicit_Aliasing, -- GNAT + No_Implicit_Loops, -- GNAT + No_Elaboration_Code, -- GNAT + No_Obsolescent_Features, -- Ada 2005 AI-368 + No_Wide_Characters, -- GNAT + SPARK_05, -- GNAT + + -- The following cases require a parameter value + + No_Specification_Of_Aspect, -- 2012 (RM 13.12.1 (6.1/3)) + No_Use_Of_Attribute, -- 2012 (RM 13.12.1 (6.2/3)) + No_Use_Of_Pragma, -- 2012 (RM 13.12.1 (6.3/3)) + + -- The following entries are fully checked at compile/bind time, which + -- means that the compiler can in general tell the minimum value which + -- could be used with a restrictions pragma. The binder can deduce the + -- appropriate minimum value for the partition by taking the maximum + -- value required by any unit. + + Max_Protected_Entries, -- (RM D.7(14)) + Max_Select_Alternatives, -- (RM D.7(12)) + Max_Task_Entries, -- (RM D.7(13), H.4(3)) + + -- The following entries are also fully checked at compile/bind time, + -- and the compiler can also at least in some cases tell the minimum + -- value which could be used with a restriction pragma. The difference + -- is that the contributions are additive, so the binder deduces this + -- value by adding the unit contributions. + + Max_Tasks, -- (RM D.7(19), H.4(3)) + + -- The following entries are checked at compile time only for zero/ + -- nonzero entries. This means that the compiler can tell at compile + -- time if a restriction value of zero is (would be) violated, but that + -- the compiler cannot distinguish between different non-zero values. + + Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) + Max_Entry_Queue_Length, -- Ada 2012 (RM D.7 (19.1/2)) + + -- The remaining entries are not checked at compile/bind time + + Max_Storage_At_Blocking, -- (RM D.7(17)) + + Not_A_Restriction_Id); + + -- Synonyms permitted for historical purposes of compatibility. + -- Must be coordinated with Restrict.Process_Restriction_Synonym. + + Boolean_Entry_Barriers : Restriction_Id renames Simple_Barriers; + Max_Entry_Queue_Depth : Restriction_Id renames Max_Entry_Queue_Length; + No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment; + No_Requeue : Restriction_Id renames No_Requeue_Statements; + No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package; + SPARK : Restriction_Id renames SPARK_05; + + subtype All_Restrictions is Restriction_Id range + Simple_Barriers .. Max_Storage_At_Blocking; + -- All restrictions (excluding only Not_A_Restriction_Id) + + subtype All_Boolean_Restrictions is Restriction_Id range + Simple_Barriers .. SPARK_05; + -- All restrictions which do not take a parameter + + subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range + Simple_Barriers .. Static_Storage_Size; + -- Boolean restrictions that are checked for partition consistency. + -- Note that all parameter restrictions are checked for partition + -- consistency by default, so this distinction is only needed in the + -- case of Boolean restrictions. + + subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range + Immediate_Reclamation .. SPARK_05; + -- Boolean restrictions that are not checked for partition consistency + -- and that thus apply only to the current unit. Note that for these + -- restrictions, the compiler does not apply restrictions found in + -- with'ed units, parent specs etc. to the main unit, and vice versa. + + subtype All_Parameter_Restrictions is + Restriction_Id range + No_Specification_Of_Aspect .. Max_Storage_At_Blocking; + -- All restrictions that take a parameter + + subtype Integer_Parameter_Restrictions is + Restriction_Id range + Max_Protected_Entries .. Max_Storage_At_Blocking; + -- All restrictions taking an integer parameter + + subtype Checked_Parameter_Restrictions is + All_Parameter_Restrictions range + Max_Protected_Entries .. Max_Entry_Queue_Length; + -- These are the parameter restrictions that can be at least partially + -- checked at compile/binder time. Minimally, the compiler can detect + -- violations of a restriction pragma with a value of zero reliably. + + subtype Checked_Max_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Protected_Entries .. Max_Task_Entries; + -- Restrictions with parameters that can be checked in some cases by + -- maximizing among statically detected instances where the compiler + -- can determine the count. + + subtype Checked_Add_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Tasks .. Max_Tasks; + -- Restrictions with parameters that can be checked in some cases by + -- summing the statically detected instances where the compiler can + -- determine the count. + + subtype Checked_Val_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Protected_Entries .. Max_Tasks; + -- Restrictions with parameter where the count is known at least in some + -- cases by the compiler/binder. + + subtype Checked_Zero_Parameter_Restrictions is + Checked_Parameter_Restrictions range + Max_Asynchronous_Select_Nesting .. Max_Entry_Queue_Length; + -- Restrictions with parameters where the compiler can detect the use of + -- the feature, and hence violations of a restriction specifying a value + -- of zero, but cannot detect specific values other than zero/nonzero. + + subtype Unchecked_Parameter_Restrictions is + All_Parameter_Restrictions range + Max_Storage_At_Blocking .. Max_Storage_At_Blocking; + -- Restrictions with parameters where the compiler cannot ever detect + -- corresponding compile time usage, so the binder and compiler never + -- detect violations of any restriction. + + ------------------------------------- + -- Restriction Status Declarations -- + ------------------------------------- + + -- The following declarations are used to record the current status or + -- restrictions (for the current unit, or related units, at compile time, + -- and for all units in a partition at bind time or run time). + + type Restriction_Flags is array (All_Restrictions) of Boolean; + type Restriction_Values is array (All_Parameter_Restrictions) of Natural; + type Parameter_Flags is array (All_Parameter_Restrictions) of Boolean; + + type Restrictions_Info is record + Set : Restriction_Flags; + -- An entry is True in the Set array if a restrictions pragma has been + -- encountered for the given restriction. If the value is True for a + -- parameter restriction, then the corresponding entry in the Value + -- array gives the minimum value encountered for any such restriction. + + Value : Restriction_Values; + -- If the entry for a parameter restriction in Set is True (i.e. a + -- restrictions pragma for the restriction has been encountered), then + -- the corresponding entry in the Value array is the minimum value + -- specified by any such restrictions pragma. Note that a restrictions + -- pragma specifying a value greater than Int'Last is simply ignored. + + Violated : Restriction_Flags; + -- An entry is True in the violations array if the compiler has detected + -- a violation of the restriction. For a parameter restriction, the + -- Count and Unknown arrays have additional information. + + Count : Restriction_Values; + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Count array may record additional + -- information. If the actual minimum count is known (by taking + -- maximums, or sums, depending on the restriction), it will be + -- recorded in this array. If not, then the value will remain zero. + -- The value is also zero for a non-violated restriction. + + Unknown : Parameter_Flags; + -- If an entry for a parameter restriction is True in Violated, the + -- corresponding entry in the Unknown array may record additional + -- information. If the actual count is not known by the compiler (but + -- is known to be non-zero), then the entry in Unknown will be True. + -- This indicates that the value in Count is not known to be exact, + -- and the actual violation count may be higher. + + -- Note: If Violated (K) is True, then either Count (K) > 0 or + -- Unknown (K) = True. It is possible for both these to be set. + -- For example, if Count (K) = 3 and Unknown (K) is True, it means + -- that the actual violation count is at least 3 but might be higher. + end record; + + No_Restrictions : constant Restrictions_Info := + (Set => (others => False), + Value => (others => 0), + Violated => (others => False), + Count => (others => 0), + Unknown => (others => False)); + -- Used to initialize Restrictions_Info variables + + ---------------------------------- + -- Profile Definitions and Data -- + ---------------------------------- + + -- Note: to add a profile, modify the following declarations appropriately, + -- add Name_xxx to Snames, and add a branch to the conditions for pragmas + -- Profile and Profile_Warnings in the body of Sem_Prag. + + type Profile_Name is + (No_Profile, + No_Implementation_Extensions, + Restricted_Tasking, + Restricted, + Ravenscar, + GNAT_Extended_Ravenscar, + GNAT_Ravenscar_EDF); + -- Names of recognized profiles. No_Profile is used to indicate that a + -- restriction came from pragma Restrictions[_Warning], as opposed to + -- pragma Profile[_Warning]. Restricted_Tasking is a non-user profile that + -- contaings the minimal set of restrictions to trigger the user of the + -- restricted tasking runtime. Restricted is the corresponding user profile + -- that also restrict protected types. + + subtype Profile_Name_Actual is Profile_Name + range No_Implementation_Extensions .. Profile_Name'Last; + -- Actual used profile names + + type Profile_Data is record + Set : Restriction_Flags; + -- Set to True if given restriction must be set for the profile, and + -- False if it need not be set (False does not mean that it must not be + -- set, just that it need not be set). If the flag is True for a + -- parameter restriction, then the Value array gives the maximum value + -- permitted by the profile. + + Value : Restriction_Values; + -- An entry in this array is meaningful only if the corresponding flag + -- in Set is True. In that case, the value in this array is the maximum + -- value of the parameter permitted by the profile. + end record; + + Profile_Info : constant array (Profile_Name_Actual) of Profile_Data := ( + + -- No_Implementation_Extensions profile + + No_Implementation_Extensions => + + (Set => + (No_Implementation_Aspect_Specifications => True, + No_Implementation_Attributes => True, + No_Implementation_Identifiers => True, + No_Implementation_Pragmas => True, + No_Implementation_Units => True, + others => False), + + -- Value settings for Restricted profile (none + + Value => + (others => 0)), + + -- Restricted_Tasking Profile + + Restricted_Tasking => + + -- Restrictions for Restricted_Tasking profile + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + others => False), + + -- Value settings for Restricted_Tasking profile + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0)), + + -- Restricted Profile + + Restricted => + + -- Restrictions for Restricted profile + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Entry_Queue => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Protected_Entries => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + others => False), + + -- Value settings for Restricted profile + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Protected_Entries => 1, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0)), + + -- Ravenscar Profile + + -- Note: the table entries here only represent the + -- required restriction profile for Ravenscar. The + -- full Ravenscar profile also requires: + + -- pragma Dispatching_Policy (FIFO_Within_Priorities); + -- pragma Locking_Policy (Ceiling_Locking); + -- pragma Detect_Blocking; + + Ravenscar => + + -- Restrictions for Ravenscar = Restricted profile .. + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Entry_Queue => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Protected_Entries => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + + -- plus these additional restrictions: + + No_Calendar => True, + No_Implicit_Heap_Allocations => True, + No_Local_Timing_Events => True, + No_Relative_Delay => True, + No_Select_Statements => True, + No_Specific_Termination_Handlers => True, + No_Task_Termination => True, + Simple_Barriers => True, + others => False), + + -- Value settings for Ravenscar (same as Restricted) + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Protected_Entries => 1, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0)), + + GNAT_Extended_Ravenscar => + + -- Restrictions for GNAT_Extended_Ravenscar = + -- Restricted profile .. + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + + -- plus these additional restrictions: + + No_Implicit_Task_Allocations => True, + No_Implicit_Protected_Object_Allocations + => True, + No_Local_Timing_Events => True, + No_Select_Statements => True, + No_Specific_Termination_Handlers => True, + No_Task_Termination => True, + Pure_Barriers => True, + others => False), + + -- Value settings for Ravenscar (same as Restricted) + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0)), + + -- GNAT_Ravenscar_EDF Profile + + -- Note: the table entries here only represent the + -- required restriction profile for GNAT_Ravenscar_EDF. + -- The full GNAT_Ravenscar_EDF profile also requires: + + -- pragma Dispatching_Policy (EDF_Across_Priorities); + -- pragma Locking_Policy (Ceiling_Locking); + -- pragma Detect_Blocking; + + GNAT_Ravenscar_EDF => + + -- Restrictions for Ravenscar = Restricted profile .. + + (Set => + (No_Abort_Statements => True, + No_Asynchronous_Control => True, + No_Dynamic_Attachment => True, + No_Dynamic_Priorities => True, + No_Entry_Queue => True, + No_Local_Protected_Objects => True, + No_Protected_Type_Allocators => True, + No_Requeue_Statements => True, + No_Task_Allocators => True, + No_Task_Attributes_Package => True, + No_Task_Hierarchy => True, + No_Terminate_Alternatives => True, + Max_Asynchronous_Select_Nesting => True, + Max_Protected_Entries => True, + Max_Select_Alternatives => True, + Max_Task_Entries => True, + + -- plus these additional restrictions: + + No_Calendar => True, + No_Implicit_Heap_Allocations => True, + No_Local_Timing_Events => True, + No_Relative_Delay => True, + No_Select_Statements => True, + No_Specific_Termination_Handlers => True, + No_Task_Termination => True, + Simple_Barriers => True, + others => False), + + -- Value settings for Ravenscar (same as Restricted) + + Value => + (Max_Asynchronous_Select_Nesting => 0, + Max_Protected_Entries => 1, + Max_Select_Alternatives => 0, + Max_Task_Entries => 0, + others => 0))); + +end System.Rident; diff --git a/gcc/ada/libgnat/s-rpc.adb b/gcc/ada/libgnat/s-rpc.adb new file mode 100644 index 0000000..ac15c33 --- /dev/null +++ b/gcc/ada/libgnat/s-rpc.adb @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . R P C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: this is a dummy implementation which does not support distribution. +-- All the bodies but one therefore raise an exception as defined below. +-- Establish_RPC_Receiver is callable, so that the ACVC scripts can simulate +-- the presence of a master partition to run a test which is otherwise not +-- distributed. + +-- The GLADE distribution package includes a replacement for this file + +package body System.RPC is + + CRLF : constant String := ASCII.CR & ASCII.LF; + + Msg : constant String := + CRLF & "Distribution support not installed in your environment" & + CRLF & "For information on GLADE, contact Ada Core Technologies"; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out Params_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + raise Program_Error with Msg; + end Read; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out Params_Stream_Type; + Item : Ada.Streams.Stream_Element_Array) + is + begin + raise Program_Error with Msg; + end Write; + + ------------ + -- Do_RPC -- + ------------ + + procedure Do_RPC + (Partition : Partition_ID; + Params : access Params_Stream_Type; + Result : access Params_Stream_Type) + is + begin + raise Program_Error with Msg; + end Do_RPC; + + ------------ + -- Do_APC -- + ------------ + + procedure Do_APC + (Partition : Partition_ID; + Params : access Params_Stream_Type) + is + begin + raise Program_Error with Msg; + end Do_APC; + + ---------------------------- + -- Establish_RPC_Receiver -- + ---------------------------- + + procedure Establish_RPC_Receiver + (Partition : Partition_ID; + Receiver : RPC_Receiver) + is + pragma Unreferenced (Partition, Receiver); + begin + null; + end Establish_RPC_Receiver; + +end System.RPC; diff --git a/gcc/ada/libgnat/s-rpc.ads b/gcc/ada/libgnat/s-rpc.ads new file mode 100644 index 0000000..f0bb8d0 --- /dev/null +++ b/gcc/ada/libgnat/s-rpc.ads @@ -0,0 +1,91 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . R P C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Note: this is a dummy implementation which does not support distribution. +-- The GLADE distribution package includes a replacement for this file which +-- has a different private + +with Ada.Streams; + +package System.RPC is + + type Partition_ID is range 0 .. Integer'Last; + + Communication_Error : exception; + + type Params_Stream_Type + (Initial_Size : Ada.Streams.Stream_Element_Count) is new + Ada.Streams.Root_Stream_Type with private; + + overriding procedure Read + (Stream : in out Params_Stream_Type; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + + overriding procedure Write + (Stream : in out Params_Stream_Type; + Item : Ada.Streams.Stream_Element_Array); + + -- Synchronous call + + procedure Do_RPC + (Partition : Partition_ID; + Params : access Params_Stream_Type; + Result : access Params_Stream_Type); + + -- Asynchronous call + + procedure Do_APC + (Partition : Partition_ID; + Params : access Params_Stream_Type); + + -- The handler for incoming RPCs + + type RPC_Receiver is + access procedure + (Params : access Params_Stream_Type; + Result : access Params_Stream_Type); + + procedure Establish_RPC_Receiver ( + Partition : Partition_ID; + Receiver : RPC_Receiver); + +private + + type Params_Stream_Type + (Initial_Size : Ada.Streams.Stream_Element_Count) is new + Ada.Streams.Root_Stream_Type with null record; + +end System.RPC; diff --git a/gcc/ada/libgnat/s-scaval.adb b/gcc/ada/libgnat/s-scaval.adb new file mode 100644 index 0000000..c3492b0 --- /dev/null +++ b/gcc/ada/libgnat/s-scaval.adb @@ -0,0 +1,328 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S C A L A R _ V A L U E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Scalar_Values is + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Mode1 : Character; Mode2 : Character) is + C1 : Character := Mode1; + C2 : Character := Mode2; + + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + subtype String2 is String (1 .. 2); + type String2_Ptr is access all String2; + + Env_Value_Ptr : aliased String2_Ptr; + Env_Value_Length : aliased Integer; + + EV_Val : aliased constant String := + "GNAT_INIT_SCALARS" & ASCII.NUL; + + B : Byte1; + + EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size; + -- Set True if we are on an x86 with 96-bit floats for extended + + AFloat : constant Boolean := + Long_Float'Size = 48 and then Long_Long_Float'Size = 48; + -- Set True if we are on an AAMP with 48-bit extended floating point + + type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1; + + for ByteLF'Component_Size use 8; + + -- Type used to hold Long_Float values on all targets and to initialize + -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes. + -- On other targets the type is 8 bytes, and type Byte8 is used for + -- values that are then converted to ByteLF. + + pragma Warnings (Off); -- why ??? + function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF); + pragma Warnings (On); + + type ByteLLF is + array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat)) + of Byte1; + + for ByteLLF'Component_Size use 8; + + -- Type used to initialize Long_Long_Float values used on x86 and + -- any other target with the same 80-bit floating-point values that + -- GCC always stores in 96-bits. Note that we are assuming Intel + -- format little-endian addressing for this type. On non-Intel + -- architectures, this is the same length as Byte8 and holds + -- a Long_Float value. + + -- The following variables are used to initialize the float values + -- by overlay. We can't assign directly to the float values, since + -- we may be assigning signalling Nan's that will cause a trap if + -- loaded into a floating-point register. + + IV_Isf : aliased Byte4; -- Initialize short float + IV_Ifl : aliased Byte4; -- Initialize float + IV_Ilf : aliased ByteLF; -- Initialize long float + IV_Ill : aliased ByteLLF; -- Initialize long long float + + for IV_Isf'Address use IS_Isf'Address; + for IV_Ifl'Address use IS_Ifl'Address; + for IV_Ilf'Address use IS_Ilf'Address; + for IV_Ill'Address use IS_Ill'Address; + + -- The following pragmas are used to suppress initialization + + pragma Import (Ada, IV_Isf); + pragma Import (Ada, IV_Ifl); + pragma Import (Ada, IV_Ilf); + pragma Import (Ada, IV_Ill); + + begin + -- Acquire environment variable value if necessary + + if C1 = 'E' and then C2 = 'V' then + Get_Env_Value_Ptr + (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); + + -- Ignore if length is not 2 + + if Env_Value_Length /= 2 then + C1 := 'I'; + C2 := 'N'; + + -- Length is 2, see if it is a valid value + + else + -- Acquire two characters and fold to upper case + + C1 := Env_Value_Ptr (1); + C2 := Env_Value_Ptr (2); + + if C1 in 'a' .. 'z' then + C1 := Character'Val (Character'Pos (C1) - 32); + end if; + + if C2 in 'a' .. 'z' then + C2 := Character'Val (Character'Pos (C2) - 32); + end if; + + -- IN/LO/HI are ok values + + if (C1 = 'I' and then C2 = 'N') + or else + (C1 = 'L' and then C2 = 'O') + or else + (C1 = 'H' and then C2 = 'I') + then + null; + + -- Try for valid hex digits + + elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z') + or else + (C2 in '0' .. '9' or else C2 in 'A' .. 'Z') + then + null; + + -- Otherwise environment value is bad, ignore and use IN (invalid) + + else + C1 := 'I'; + C2 := 'N'; + end if; + end if; + end if; + + -- IN (invalid value) + + if C1 = 'I' and then C2 = 'N' then + IS_Is1 := 16#80#; + IS_Is2 := 16#8000#; + IS_Is4 := 16#8000_0000#; + IS_Is8 := 16#8000_0000_0000_0000#; + + IS_Iu1 := 16#FF#; + IS_Iu2 := 16#FFFF#; + IS_Iu4 := 16#FFFF_FFFF#; + IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; + + IS_Iz1 := 16#00#; + IS_Iz2 := 16#0000#; + IS_Iz4 := 16#0000_0000#; + IS_Iz8 := 16#0000_0000_0000_0000#; + + if AFloat then + IV_Isf := 16#FFFF_FF00#; + IV_Ifl := 16#FFFF_FF00#; + IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#); + + else + IV_Isf := IS_Iu4; + IV_Ifl := IS_Iu4; + IV_Ilf := To_ByteLF (IS_Iu8); + end if; + + if EFloat then + IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0); + end if; + + -- LO (Low values) + + elsif C1 = 'L' and then C2 = 'O' then + IS_Is1 := 16#80#; + IS_Is2 := 16#8000#; + IS_Is4 := 16#8000_0000#; + IS_Is8 := 16#8000_0000_0000_0000#; + + IS_Iu1 := 16#00#; + IS_Iu2 := 16#0000#; + IS_Iu4 := 16#0000_0000#; + IS_Iu8 := 16#0000_0000_0000_0000#; + + IS_Iz1 := 16#00#; + IS_Iz2 := 16#0000#; + IS_Iz4 := 16#0000_0000#; + IS_Iz8 := 16#0000_0000_0000_0000#; + + if AFloat then + IV_Isf := 16#0000_0001#; + IV_Ifl := 16#0000_0001#; + IV_Ilf := (1, 0, 0, 0, 0, 0); + + else + IV_Isf := 16#FF80_0000#; + IV_Ifl := 16#FF80_0000#; + IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#); + end if; + + if EFloat then + IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0); + end if; + + -- HI (High values) + + elsif C1 = 'H' and then C2 = 'I' then + IS_Is1 := 16#7F#; + IS_Is2 := 16#7FFF#; + IS_Is4 := 16#7FFF_FFFF#; + IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#; + + IS_Iu1 := 16#FF#; + IS_Iu2 := 16#FFFF#; + IS_Iu4 := 16#FFFF_FFFF#; + IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; + + IS_Iz1 := 16#FF#; + IS_Iz2 := 16#FFFF#; + IS_Iz4 := 16#FFFF_FFFF#; + IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#; + + if AFloat then + IV_Isf := 16#7FFF_FFFF#; + IV_Ifl := 16#7FFF_FFFF#; + IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#); + + else + IV_Isf := 16#7F80_0000#; + IV_Ifl := 16#7F80_0000#; + IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#); + end if; + + if EFloat then + IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0); + end if; + + -- -Shh (hex byte) + + else + -- Convert the two hex digits (we know they are valid here) + + B := 16 * (Character'Pos (C1) + - (if C1 in '0' .. '9' + then Character'Pos ('0') + else Character'Pos ('A') - 10)) + + (Character'Pos (C2) + - (if C2 in '0' .. '9' + then Character'Pos ('0') + else Character'Pos ('A') - 10)); + + -- Initialize data values from the hex value + + IS_Is1 := B; + IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1); + IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2); + IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4); + + IS_Iu1 := IS_Is1; + IS_Iu2 := IS_Is2; + IS_Iu4 := IS_Is4; + IS_Iu8 := IS_Is8; + + IS_Iz1 := IS_Is1; + IS_Iz2 := IS_Is2; + IS_Iz4 := IS_Is4; + IS_Iz8 := IS_Is8; + + IV_Isf := IS_Is4; + IV_Ifl := IS_Is4; + + if AFloat then + IV_Ill := (B, B, B, B, B, B); + else + IV_Ilf := To_ByteLF (IS_Is8); + end if; + + if EFloat then + IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B); + end if; + end if; + + -- If no separate Long_Long_Float, then use Long_Float value as + -- Long_Long_Float initial value. + + if not EFloat then + declare + pragma Warnings (Off); -- why??? + function To_ByteLLF is + new Ada.Unchecked_Conversion (ByteLF, ByteLLF); + pragma Warnings (On); + begin + IV_Ill := To_ByteLLF (IV_Ilf); + end; + end if; + end Initialize; + +end System.Scalar_Values; diff --git a/gcc/ada/libgnat/s-scaval.ads b/gcc/ada/libgnat/s-scaval.ads new file mode 100644 index 0000000..9292dcd --- /dev/null +++ b/gcc/ada/libgnat/s-scaval.ads @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S C A L A R _ V A L U E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2001-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the constants used for initializing scalar values +-- when pragma Initialize_Scalars is used. The actual values are defined +-- in the binder generated file. This package contains the Ada names that +-- are used by the generated code, which are linked to the actual values +-- by the use of pragma Import. + +package System.Scalar_Values is + + -- Note: logically this package should be Pure since it can be accessed + -- from pure units, but the IS_xxx variables below get set at run time, + -- so they have to be library level variables. In fact we only ever + -- access this from generated code, and the compiler knows that it is + -- OK to access this unit from generated code. + + type Byte1 is mod 2 ** 8; + type Byte2 is mod 2 ** 16; + type Byte4 is mod 2 ** 32; + type Byte8 is mod 2 ** 64; + + -- The explicit initializations here are not really required, since these + -- variables are always set by System.Scalar_Values.Initialize. + + IS_Is1 : Byte1 := 0; -- Initialize 1 byte signed + IS_Is2 : Byte2 := 0; -- Initialize 2 byte signed + IS_Is4 : Byte4 := 0; -- Initialize 4 byte signed + IS_Is8 : Byte8 := 0; -- Initialize 8 byte signed + -- For the above cases, the undefined value (set by the binder -Sin switch) + -- is the largest negative number (1 followed by all zero bits). + + IS_Iu1 : Byte1 := 0; -- Initialize 1 byte unsigned + IS_Iu2 : Byte2 := 0; -- Initialize 2 byte unsigned + IS_Iu4 : Byte4 := 0; -- Initialize 4 byte unsigned + IS_Iu8 : Byte8 := 0; -- Initialize 8 byte unsigned + -- For the above cases, the undefined value (set by the binder -Sin switch) + -- is the largest unsigned number (all 1 bits). + + IS_Iz1 : Byte1 := 0; -- Initialize 1 byte zeroes + IS_Iz2 : Byte2 := 0; -- Initialize 2 byte zeroes + IS_Iz4 : Byte4 := 0; -- Initialize 4 byte zeroes + IS_Iz8 : Byte8 := 0; -- Initialize 8 byte zeroes + -- For the above cases, the undefined value (set by the binder -Sin switch) + -- is the zero (all 0 bits). This is used when zero is known to be an + -- invalid value. + + -- The float definitions are aliased, because we use overlays to set them + + IS_Isf : aliased Short_Float := 0.0; -- Initialize short float + IS_Ifl : aliased Float := 0.0; -- Initialize float + IS_Ilf : aliased Long_Float := 0.0; -- Initialize long float + IS_Ill : aliased Long_Long_Float := 0.0; -- Initialize long long float + + procedure Initialize (Mode1 : Character; Mode2 : Character); + -- This procedure is called from the binder when Initialize_Scalars mode + -- is active. The arguments are the two characters from the -S switch, + -- with letters forced upper case. So for example if -S5a is given, then + -- Mode1 will be '5' and Mode2 will be 'A'. If the parameters are EV, + -- then this routine reads the environment variable GNAT_INIT_SCALARS. + -- The possible settings are the same as those for the -S switch (except + -- for EV), i.e. IN/LO/HO/xx, xx = 2 hex digits. If no -S switch is given + -- then the default of IN (invalid values) is passed on the call. + +end System.Scalar_Values; diff --git a/gcc/ada/libgnat/s-secsta.adb b/gcc/ada/libgnat/s-secsta.adb new file mode 100644 index 0000000..0449ee4 --- /dev/null +++ b/gcc/ada/libgnat/s-secsta.adb @@ -0,0 +1,547 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S E C O N D A R Y _ S T A C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Soft_Links; +with System.Parameters; + +with Ada.Unchecked_Conversion; +with Ada.Unchecked_Deallocation; + +package body System.Secondary_Stack is + + package SSL renames System.Soft_Links; + + use type SSE.Storage_Offset; + use type System.Parameters.Size_Type; + + SS_Ratio_Dynamic : constant Boolean := + Parameters.Sec_Stack_Percentage = Parameters.Dynamic; + -- There are two entirely different implementations of the secondary + -- stack mechanism in this unit, and this Boolean is used to select + -- between them (at compile time, so the generated code will contain + -- only the code for the desired variant). If SS_Ratio_Dynamic is + -- True, then the secondary stack is dynamically allocated from the + -- heap in a linked list of chunks. If SS_Ration_Dynamic is False, + -- then the secondary stack is allocated statically by grabbing a + -- section of the primary stack and using it for this purpose. + + type Memory is array (SS_Ptr range <>) of SSE.Storage_Element; + for Memory'Alignment use Standard'Maximum_Alignment; + -- This is the type used for actual allocation of secondary stack + -- areas. We require maximum alignment for all such allocations. + + --------------------------------------------------------------- + -- Data Structures for Dynamically Allocated Secondary Stack -- + --------------------------------------------------------------- + + -- The following is a diagram of the data structures used for the + -- case of a dynamically allocated secondary stack, where the stack + -- is allocated as a linked list of chunks allocated from the heap. + + -- +------------------+ + -- | Next | + -- +------------------+ + -- | | Last (200) + -- | | + -- | | + -- | | + -- | | + -- | | + -- | | First (101) + -- +------------------+ + -- +----------> | | | + -- | +--------- | ------+ + -- | ^ | + -- | | | + -- | | V + -- | +------ | ---------+ + -- | | | | + -- | +------------------+ + -- | | | Last (100) + -- | | C | + -- | | H | + -- +-----------------+ | +------->| U | + -- | Current_Chunk ----+ | | N | + -- +-----------------+ | | K | + -- | Top --------+ | | First (1) + -- +-----------------+ +------------------+ + -- | Default_Size | | Prev | + -- +-----------------+ +------------------+ + -- + + type Chunk_Id (First, Last : SS_Ptr); + type Chunk_Ptr is access all Chunk_Id; + + type Chunk_Id (First, Last : SS_Ptr) is record + Prev, Next : Chunk_Ptr; + Mem : Memory (First .. Last); + end record; + + type Stack_Id is record + Top : SS_Ptr; + Default_Size : SSE.Storage_Count; + Current_Chunk : Chunk_Ptr; + end record; + + type Stack_Ptr is access Stack_Id; + -- Pointer to record used to represent a dynamically allocated secondary + -- stack descriptor for a secondary stack chunk. + + procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); + -- Free a dynamically allocated chunk + + function To_Stack_Ptr is new + Ada.Unchecked_Conversion (Address, Stack_Ptr); + function To_Addr is new + Ada.Unchecked_Conversion (Stack_Ptr, Address); + -- Convert to and from address stored in task data structures + + -------------------------------------------------------------- + -- Data Structures for Statically Allocated Secondary Stack -- + -------------------------------------------------------------- + + -- For the static case, the secondary stack is a single contiguous + -- chunk of storage, carved out of the primary stack, and represented + -- by the following data structure + + type Fixed_Stack_Id is record + Top : SS_Ptr; + -- Index of next available location in Mem. This is initialized to + -- 0, and then incremented on Allocate, and Decremented on Release. + + Last : SS_Ptr; + -- Length of usable Mem array, which is thus the index past the + -- last available location in Mem. Mem (Last-1) can be used. This + -- is used to check that the stack does not overflow. + + Max : SS_Ptr; + -- Maximum value of Top. Initialized to 0, and then may be incremented + -- on Allocate, but is never Decremented. The last used location will + -- be Mem (Max - 1), so Max is the maximum count of used stack space. + + Mem : Memory (0 .. 0); + -- This is the area that is actually used for the secondary stack. + -- Note that the upper bound is a dummy value properly defined by + -- the value of Last. We never actually allocate objects of type + -- Fixed_Stack_Id, so the bounds declared here do not matter. + end record; + + Dummy_Fixed_Stack : Fixed_Stack_Id; + pragma Warnings (Off, Dummy_Fixed_Stack); + -- Well it is not quite true that we never allocate an object of the + -- type. This dummy object is allocated for the purpose of getting the + -- offset of the Mem field via the 'Position attribute (such a nuisance + -- that we cannot apply this to a field of a type). + + type Fixed_Stack_Ptr is access Fixed_Stack_Id; + -- Pointer to record used to describe statically allocated sec stack + + function To_Fixed_Stack_Ptr is new + Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr); + -- Convert from address stored in task data structures + + ---------------------------------- + -- Minimum_Secondary_Stack_Size -- + ---------------------------------- + + function Minimum_Secondary_Stack_Size return Natural is + begin + return Dummy_Fixed_Stack.Mem'Position; + end Minimum_Secondary_Stack_Size; + + -------------- + -- Allocate -- + -------------- + + procedure SS_Allocate + (Addr : out Address; + Storage_Size : SSE.Storage_Count) + is + Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment); + Max_Size : constant SS_Ptr := + ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) * + Max_Align; + + begin + -- Case of fixed allocation secondary stack + + if not SS_Ratio_Dynamic then + declare + Fixed_Stack : constant Fixed_Stack_Ptr := + To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + + begin + -- Check if max stack usage is increasing + + if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then + + -- If so, check if max size is exceeded + + if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then + raise Storage_Error; + end if; + + -- Record new max usage + + Fixed_Stack.Max := Fixed_Stack.Top + Max_Size; + end if; + + -- Set resulting address and update top of stack pointer + + Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; + Fixed_Stack.Top := Fixed_Stack.Top + Max_Size; + end; + + -- Case of dynamically allocated secondary stack + + else + declare + Stack : constant Stack_Ptr := + To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + Chunk : Chunk_Ptr; + + To_Be_Released_Chunk : Chunk_Ptr; + + begin + Chunk := Stack.Current_Chunk; + + -- The Current_Chunk may not be the good one if a lot of release + -- operations have taken place. Go down the stack if necessary. + + while Chunk.First > Stack.Top loop + Chunk := Chunk.Prev; + end loop; + + -- Find out if the available memory in the current chunk is + -- sufficient, if not, go to the next one and eventually create + -- the necessary room. + + while Chunk.Last - Stack.Top + 1 < Max_Size loop + if Chunk.Next /= null then + + -- Release unused non-first empty chunk + + if Chunk.Prev /= null and then Chunk.First = Stack.Top then + To_Be_Released_Chunk := Chunk; + Chunk := Chunk.Prev; + Chunk.Next := To_Be_Released_Chunk.Next; + To_Be_Released_Chunk.Next.Prev := Chunk; + Free (To_Be_Released_Chunk); + end if; + + -- Create new chunk of default size unless it is not sufficient + -- to satisfy the current request. + + elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then + Chunk.Next := + new Chunk_Id + (First => Chunk.Last + 1, + Last => Chunk.Last + SS_Ptr (Stack.Default_Size)); + + Chunk.Next.Prev := Chunk; + + -- Otherwise create new chunk of requested size + + else + Chunk.Next := + new Chunk_Id + (First => Chunk.Last + 1, + Last => Chunk.Last + Max_Size); + + Chunk.Next.Prev := Chunk; + end if; + + Chunk := Chunk.Next; + Stack.Top := Chunk.First; + end loop; + + -- Resulting address is the address pointed by Stack.Top + + Addr := Chunk.Mem (Stack.Top)'Address; + Stack.Top := Stack.Top + Max_Size; + Stack.Current_Chunk := Chunk; + end; + end if; + end SS_Allocate; + + ------------- + -- SS_Free -- + ------------- + + procedure SS_Free (Stk : in out Address) is + begin + -- Case of statically allocated secondary stack, nothing to free + + if not SS_Ratio_Dynamic then + return; + + -- Case of dynamically allocated secondary stack + + else + declare + Stack : Stack_Ptr := To_Stack_Ptr (Stk); + Chunk : Chunk_Ptr; + + procedure Free is + new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr); + + begin + Chunk := Stack.Current_Chunk; + + while Chunk.Prev /= null loop + Chunk := Chunk.Prev; + end loop; + + while Chunk.Next /= null loop + Chunk := Chunk.Next; + Free (Chunk.Prev); + end loop; + + Free (Chunk); + Free (Stack); + Stk := Null_Address; + end; + end if; + end SS_Free; + + ---------------- + -- SS_Get_Max -- + ---------------- + + function SS_Get_Max return Long_Long_Integer is + begin + if SS_Ratio_Dynamic then + return -1; + else + declare + Fixed_Stack : constant Fixed_Stack_Ptr := + To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + begin + return Long_Long_Integer (Fixed_Stack.Max); + end; + end if; + end SS_Get_Max; + + ------------- + -- SS_Info -- + ------------- + + procedure SS_Info is + begin + Put_Line ("Secondary Stack information:"); + + -- Case of fixed secondary stack + + if not SS_Ratio_Dynamic then + declare + Fixed_Stack : constant Fixed_Stack_Ptr := + To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + + begin + Put_Line (" Total size : " + & SS_Ptr'Image (Fixed_Stack.Last) + & " bytes"); + + Put_Line (" Current allocated space : " + & SS_Ptr'Image (Fixed_Stack.Top) + & " bytes"); + end; + + -- Case of dynamically allocated secondary stack + + else + declare + Stack : constant Stack_Ptr := + To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); + Nb_Chunks : Integer := 1; + Chunk : Chunk_Ptr := Stack.Current_Chunk; + + begin + while Chunk.Prev /= null loop + Chunk := Chunk.Prev; + end loop; + + while Chunk.Next /= null loop + Nb_Chunks := Nb_Chunks + 1; + Chunk := Chunk.Next; + end loop; + + -- Current Chunk information + + -- Note that First of each chunk is one more than Last of the + -- previous one, so Chunk.Last is the total size of all chunks; we + -- don't need to walk all the chunks to compute the total size. + + Put_Line (" Total size : " + & SS_Ptr'Image (Chunk.Last) + & " bytes"); + + Put_Line (" Current allocated space : " + & SS_Ptr'Image (Stack.Top - 1) + & " bytes"); + + Put_Line (" Number of Chunks : " + & Integer'Image (Nb_Chunks)); + + Put_Line (" Default size of Chunks : " + & SSE.Storage_Count'Image (Stack.Default_Size)); + end; + end if; + end SS_Info; + + ------------- + -- SS_Init -- + ------------- + + procedure SS_Init + (Stk : in out Address; + Size : Natural := Default_Secondary_Stack_Size) + is + begin + -- Case of fixed size secondary stack + + if not SS_Ratio_Dynamic then + declare + Fixed_Stack : constant Fixed_Stack_Ptr := + To_Fixed_Stack_Ptr (Stk); + + begin + Fixed_Stack.Top := 0; + Fixed_Stack.Max := 0; + + if Size <= Dummy_Fixed_Stack.Mem'Position then + Fixed_Stack.Last := 0; + else + Fixed_Stack.Last := + SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position; + end if; + end; + + -- Case of dynamically allocated secondary stack + + else + declare + Stack : Stack_Ptr; + begin + Stack := new Stack_Id; + Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size)); + Stack.Top := 1; + Stack.Default_Size := SSE.Storage_Count (Size); + Stk := To_Addr (Stack); + end; + end if; + end SS_Init; + + ------------- + -- SS_Mark -- + ------------- + + function SS_Mark return Mark_Id is + Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all; + begin + if SS_Ratio_Dynamic then + return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top); + else + return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top); + end if; + end SS_Mark; + + ---------------- + -- SS_Release -- + ---------------- + + procedure SS_Release (M : Mark_Id) is + begin + if SS_Ratio_Dynamic then + To_Stack_Ptr (M.Sstk).Top := M.Sptr; + else + To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr; + end if; + end SS_Release; + + ------------------------- + -- Package Elaboration -- + ------------------------- + + -- Allocate a secondary stack for the main program to use + + -- We make sure that the stack has maximum alignment. Some systems require + -- this (e.g. Sparc), and in any case it is a good idea for efficiency. + + Stack : aliased Stack_Id; + for Stack'Alignment use Standard'Maximum_Alignment; + + Static_Secondary_Stack_Size : constant := 10 * 1024; + -- Static_Secondary_Stack_Size must be static so that Chunk is allocated + -- statically, and not via dynamic memory allocation. + + Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size); + for Chunk'Alignment use Standard'Maximum_Alignment; + -- Default chunk used, unless gnatbind -D is specified with a value greater + -- than Static_Secondary_Stack_Size. + +begin + declare + Chunk_Address : Address; + Chunk_Access : Chunk_Ptr; + + begin + if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then + + -- Normally we allocate the secondary stack for the main program + -- statically, using the default secondary stack size. + + Chunk_Access := Chunk'Access; + + else + -- Default_Secondary_Stack_Size was increased via gnatbind -D, so we + -- need to allocate a chunk dynamically. + + Chunk_Access := + new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size)); + end if; + + if SS_Ratio_Dynamic then + Stack.Top := 1; + Stack.Current_Chunk := Chunk_Access; + Stack.Default_Size := + SSE.Storage_Offset (Default_Secondary_Stack_Size); + System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address); + + else + Chunk_Address := Chunk_Access.all'Address; + SS_Init (Chunk_Address, Default_Secondary_Stack_Size); + System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address); + end if; + end; +end System.Secondary_Stack; diff --git a/gcc/ada/libgnat/s-secsta.ads b/gcc/ada/libgnat/s-secsta.ads new file mode 100644 index 0000000..534708d --- /dev/null +++ b/gcc/ada/libgnat/s-secsta.ads @@ -0,0 +1,123 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S E C O N D A R Y _ S T A C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with System.Storage_Elements; + +package System.Secondary_Stack is + + package SSE renames System.Storage_Elements; + + Default_Secondary_Stack_Size : Natural := 10 * 1024; + -- Default size of a secondary stack. May be modified by binder -D switch + -- which causes the binder to generate an appropriate assignment in the + -- binder generated file. + + function Minimum_Secondary_Stack_Size return Natural; + -- The minimum size of the secondary stack so that the internal + -- requirements of the stack are met. + + procedure SS_Init + (Stk : in out Address; + Size : Natural := Default_Secondary_Stack_Size); + -- Initialize the secondary stack with a main stack of the given Size. + -- + -- If System.Parameters.Sec_Stack_Percentage equals Dynamic, Stk is really + -- an OUT parameter that will be allocated on the heap. Then all further + -- allocations which do not overflow the main stack will not generate + -- dynamic (de)allocation calls. If the main Stack overflows, a new + -- chuck of at least the same size will be allocated and linked to the + -- previous chunk. + -- + -- Otherwise (Sec_Stack_Percentage between 0 and 100), Stk is an IN + -- parameter that is already pointing to a Stack_Id. The secondary stack + -- in this case is fixed, and any attempt to allocate more than the initial + -- size will result in a Storage_Error being raised. + -- + -- Note: the reason that Stk is passed is that SS_Init is called before + -- the proper interface is established to obtain the address of the + -- stack using System.Soft_Links.Get_Sec_Stack_Addr. + + procedure SS_Allocate + (Addr : out Address; + Storage_Size : SSE.Storage_Count); + -- Allocate enough space for a 'Storage_Size' bytes object with Maximum + -- alignment. The address of the allocated space is returned in Addr. + + procedure SS_Free (Stk : in out Address); + -- Release the memory allocated for the Secondary Stack. That is + -- to say, all the allocated chunks. Upon return, Stk will be set + -- to System.Null_Address. + + type Mark_Id is private; + -- Type used to mark the stack for mark/release processing + + function SS_Mark return Mark_Id; + -- Return the Mark corresponding to the current state of the stack + + procedure SS_Release (M : Mark_Id); + -- Restore the state of the stack corresponding to the mark M. If an + -- additional chunk have been allocated, it will never be freed during a + -- ??? missing comment here + + function SS_Get_Max return Long_Long_Integer; + -- Return maximum used space in storage units for the current secondary + -- stack. For a dynamically allocated secondary stack, the returned + -- result is always -1. For a statically allocated secondary stack, + -- the returned value shows the largest amount of space allocated so + -- far during execution of the program to the current secondary stack, + -- i.e. the secondary stack for the current task. + + generic + with procedure Put_Line (S : String); + procedure SS_Info; + -- Debugging procedure used to print out secondary Stack allocation + -- information. This procedure is generic in order to avoid a direct + -- dependance on a particular IO package. + +private + SS_Pool : Integer; + -- Unused entity that is just present to ease the sharing of the pool + -- mechanism for specific allocation/deallocation in the compiler + + type SS_Ptr is new SSE.Integer_Address; + -- Stack pointer value for secondary stack + + type Mark_Id is record + Sstk : System.Address; + Sptr : SS_Ptr; + end record; + -- A mark value contains the address of the secondary stack structure, + -- as returned by System.Soft_Links.Get_Sec_Stack_Addr, and a stack + -- pointer value corresponding to the point of the mark call. + +end System.Secondary_Stack; diff --git a/gcc/ada/libgnat/s-sequio.adb b/gcc/ada/libgnat/s-sequio.adb new file mode 100644 index 0000000..b5616ae --- /dev/null +++ b/gcc/ada/libgnat/s-sequio.adb @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S E Q U E N T I A L _ I O -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.File_IO; +with Ada.Unchecked_Deallocation; + +package body System.Sequential_IO is + + subtype AP is FCB.AFCB_Ptr; + + package FIO renames System.File_IO; + + ------------------- + -- AFCB_Allocate -- + ------------------- + + function AFCB_Allocate + (Control_Block : Sequential_AFCB) return FCB.AFCB_Ptr + is + pragma Warnings (Off, Control_Block); + + begin + return new Sequential_AFCB; + end AFCB_Allocate; + + ---------------- + -- AFCB_Close -- + ---------------- + + -- No special processing required for Sequential_IO close + + procedure AFCB_Close (File : not null access Sequential_AFCB) is + pragma Warnings (Off, File); + + begin + null; + end AFCB_Close; + + --------------- + -- AFCB_Free -- + --------------- + + procedure AFCB_Free (File : not null access Sequential_AFCB) is + + type FCB_Ptr is access all Sequential_AFCB; + + FT : FCB_Ptr := FCB_Ptr (File); + + procedure Free is new + Ada.Unchecked_Deallocation (Sequential_AFCB, FCB_Ptr); + + begin + Free (FT); + end AFCB_Free; + + ------------ + -- Create -- + ------------ + + procedure Create + (File : in out File_Type; + Mode : FCB.File_Mode := FCB.Out_File; + Name : String := ""; + Form : String := "") + is + Dummy_File_Control_Block : Sequential_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'Q', + Creat => True, + Text => False); + end Create; + + ---------- + -- Open -- + ---------- + + procedure Open + (File : in out File_Type; + Mode : FCB.File_Mode; + Name : String; + Form : String := "") + is + Dummy_File_Control_Block : Sequential_AFCB; + pragma Warnings (Off, Dummy_File_Control_Block); + -- Yes, we know this is never assigned a value, only the tag + -- is used for dispatching purposes, so that's expected. + + begin + FIO.Open (File_Ptr => AP (File), + Dummy_FCB => Dummy_File_Control_Block, + Mode => Mode, + Name => Name, + Form => Form, + Amethod => 'Q', + Creat => False, + Text => False); + end Open; + + ---------- + -- Read -- + ---------- + + -- Not used, since Sequential_IO files are not used as streams + + procedure Read + (File : in out Sequential_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset) + is + begin + raise Program_Error; + end Read; + + ----------- + -- Write -- + ----------- + + -- Not used, since Sequential_IO files are not used as streams + + procedure Write + (File : in out Sequential_AFCB; + Item : Ada.Streams.Stream_Element_Array) + is + begin + raise Program_Error; + end Write; + +end System.Sequential_IO; diff --git a/gcc/ada/libgnat/s-sequio.ads b/gcc/ada/libgnat/s-sequio.ads new file mode 100644 index 0000000..4d7f19e --- /dev/null +++ b/gcc/ada/libgnat/s-sequio.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S E Q U E N T I A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the declaration of the control block used for +-- Sequential_IO. This must be declared at the outer library level. It also +-- contains code that is shared between instances of Sequential_IO. + +with System.File_Control_Block; +with Ada.Streams; + +package System.Sequential_IO is + + package FCB renames System.File_Control_Block; + + type Sequential_AFCB is new FCB.AFCB with null record; + -- No additional fields required for Sequential_IO + + function AFCB_Allocate + (Control_Block : Sequential_AFCB) return FCB.AFCB_Ptr; + + procedure AFCB_Close (File : not null access Sequential_AFCB); + procedure AFCB_Free (File : not null access Sequential_AFCB); + + procedure Read + (File : in out Sequential_AFCB; + Item : out Ada.Streams.Stream_Element_Array; + Last : out Ada.Streams.Stream_Element_Offset); + -- Required overriding of Read, not actually used for Sequential_IO + + procedure Write + (File : in out Sequential_AFCB; + Item : Ada.Streams.Stream_Element_Array); + -- Required overriding of Write, not actually used for Sequential_IO + + type File_Type is access all Sequential_AFCB; + -- File_Type in individual instantiations is derived from this type + + procedure Create + (File : in out File_Type; + Mode : FCB.File_Mode := FCB.Out_File; + Name : String := ""; + Form : String := ""); + + procedure Open + (File : in out File_Type; + Mode : FCB.File_Mode; + Name : String; + Form : String := ""); + +end System.Sequential_IO; diff --git a/gcc/ada/libgnat/s-shasto.adb b/gcc/ada/libgnat/s-shasto.adb new file mode 100644 index 0000000..9395e3f --- /dev/null +++ b/gcc/ada/libgnat/s-shasto.adb @@ -0,0 +1,588 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S H A R E D _ M E M O R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with Ada.Streams; +with Ada.Streams.Stream_IO; + +with System.Global_Locks; +with System.Soft_Links; + +with System; +with System.CRTL; +with System.File_Control_Block; +with System.File_IO; +with System.HTable; + +with Ada.Unchecked_Deallocation; +with Ada.Unchecked_Conversion; + +package body System.Shared_Storage is + + package AS renames Ada.Streams; + + package IOX renames Ada.IO_Exceptions; + + package FCB renames System.File_Control_Block; + + package SFI renames System.File_IO; + + package SIO renames Ada.Streams.Stream_IO; + + type String_Access is access String; + procedure Free is new Ada.Unchecked_Deallocation + (Object => String, Name => String_Access); + + Dir : String_Access; + -- Holds the directory + + ------------------------------------------------ + -- Variables for Shared Variable Access Files -- + ------------------------------------------------ + + Max_Shared_Var_Files : constant := 20; + -- Maximum number of lock files that can be open + + Shared_Var_Files_Open : Natural := 0; + -- Number of shared variable access files currently open + + type File_Stream_Type is new AS.Root_Stream_Type with record + File : SIO.File_Type; + end record; + type File_Stream_Access is access all File_Stream_Type'Class; + + procedure Read + (Stream : in out File_Stream_Type; + Item : out AS.Stream_Element_Array; + Last : out AS.Stream_Element_Offset); + + procedure Write + (Stream : in out File_Stream_Type; + Item : AS.Stream_Element_Array); + + subtype Hash_Header is Natural range 0 .. 30; + -- Number of hash headers, related (for efficiency purposes only) to the + -- maximum number of lock files. + + type Shared_Var_File_Entry; + type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; + + type Shared_Var_File_Entry is record + Name : String_Access; + -- Name of variable, as passed to Read_File/Write_File routines + + Stream : File_Stream_Access; + -- Stream_IO file for the shared variable file + + Next : Shared_Var_File_Entry_Ptr; + Prev : Shared_Var_File_Entry_Ptr; + -- Links for LRU chain + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Object => Shared_Var_File_Entry, + Name => Shared_Var_File_Entry_Ptr); + + procedure Free is new Ada.Unchecked_Deallocation + (Object => File_Stream_Type'Class, + Name => File_Stream_Access); + + function To_AFCB_Ptr is + new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr); + + LRU_Head : Shared_Var_File_Entry_Ptr; + LRU_Tail : Shared_Var_File_Entry_Ptr; + -- As lock files are opened, they are organized into a least recently + -- used chain, which is a doubly linked list using the Next and Prev + -- fields of Shared_Var_File_Entry records. The field LRU_Head points + -- to the least recently used entry, whose prev pointer is null, and + -- LRU_Tail points to the most recently used entry, whose next pointer + -- is null. These pointers are null only if the list is empty. + + function Hash (F : String_Access) return Hash_Header; + function Equal (F1, F2 : String_Access) return Boolean; + -- Hash and equality functions for hash table + + package SFT is new System.HTable.Simple_HTable + (Header_Num => Hash_Header, + Element => Shared_Var_File_Entry_Ptr, + No_Element => null, + Key => String_Access, + Hash => Hash, + Equal => Equal); + + -------------------------------- + -- Variables for Lock Control -- + -------------------------------- + + Global_Lock : Global_Locks.Lock_Type; + + Lock_Count : Natural := 0; + -- Counts nesting of lock calls, 0 means lock is not held + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Initialize; + -- Called to initialize data structures for this package. + -- Has no effect except on the first call. + + procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String); + -- The first parameter is a pointer to a newly allocated SFE, whose + -- File field is already set appropriately. Fname is the name of the + -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE + -- completes the SFE value, and enters it into the hash table. If the + -- hash table is already full, the least recently used entry is first + -- closed and discarded. + + function Retrieve (File : String) return Shared_Var_File_Entry_Ptr; + -- Given a file name, this function searches the hash table to see if + -- the file is currently open. If so, then a pointer to the already + -- created entry is returned, after first moving it to the head of + -- the LRU chain. If not, then null is returned. + + function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns null if the + -- corresponding shared storage does not exist, and otherwise, if + -- the storage does exist, a Stream_Access value that references + -- the shared storage, ready to read the current value. + + function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; + -- As described above, this routine returns a Stream_Access value + -- that references the shared storage, ready to write the new + -- value. The storage is created by this call if it does not + -- already exist. + + procedure Shared_Var_Close (Var : SIO.Stream_Access); + -- This routine signals the end of a read/assign operation. It can + -- be useful to embrace a read/write operation between a call to + -- open and a call to close which protect the whole operation. + -- Otherwise, two simultaneous operations can result in the + -- raising of exception Data_Error by setting the access mode of + -- the variable in an incorrect mode. + + --------------- + -- Enter_SFE -- + --------------- + + procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is + Freed : Shared_Var_File_Entry_Ptr; + + begin + SFE.Name := new String'(Fname); + + -- Release least recently used entry if we have to + + if Shared_Var_Files_Open = Max_Shared_Var_Files then + Freed := LRU_Head; + + if Freed.Next /= null then + Freed.Next.Prev := null; + end if; + + LRU_Head := Freed.Next; + SFT.Remove (Freed.Name); + SIO.Close (Freed.Stream.File); + Free (Freed.Name); + Free (Freed.Stream); + Free (Freed); + + else + Shared_Var_Files_Open := Shared_Var_Files_Open + 1; + end if; + + -- Add new entry to hash table + + SFT.Set (SFE.Name, SFE); + + -- Add new entry at end of LRU chain + + if LRU_Head = null then + LRU_Head := SFE; + LRU_Tail := SFE; + + else + SFE.Prev := LRU_Tail; + LRU_Tail.Next := SFE; + LRU_Tail := SFE; + end if; + end Enter_SFE; + + ----------- + -- Equal -- + ----------- + + function Equal (F1, F2 : String_Access) return Boolean is + begin + return F1.all = F2.all; + end Equal; + + ---------- + -- Hash -- + ---------- + + function Hash (F : String_Access) return Hash_Header is + N : Natural := 0; + + begin + -- Add up characters of name, mod our table size + + for J in F'Range loop + N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); + end loop; + + return N; + end Hash; + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize is + procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); + pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); + + subtype size_t is CRTL.size_t; + + procedure Strncpy (dest, src : System.Address; n : size_t) + renames CRTL.strncpy; + + Dir_Name : aliased constant String := + "SHARED_MEMORY_DIRECTORY" & ASCII.NUL; + + Env_Value_Ptr : aliased Address; + Env_Value_Len : aliased Integer; + + begin + if Dir = null then + Get_Env_Value_Ptr + (Dir_Name'Address, Env_Value_Len'Address, Env_Value_Ptr'Address); + + Dir := new String (1 .. Env_Value_Len); + + if Env_Value_Len > 0 then + Strncpy (Dir.all'Address, Env_Value_Ptr, size_t (Env_Value_Len)); + end if; + + System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock"); + end if; + end Initialize; + + ---------- + -- Read -- + ---------- + + procedure Read + (Stream : in out File_Stream_Type; + Item : out AS.Stream_Element_Array; + Last : out AS.Stream_Element_Offset) + is + begin + SIO.Read (Stream.File, Item, Last); + + exception when others => + Last := Item'Last; + end Read; + + -------------- + -- Retrieve -- + -------------- + + function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is + SFE : Shared_Var_File_Entry_Ptr; + + begin + Initialize; + SFE := SFT.Get (File'Unrestricted_Access); + + if SFE /= null then + + -- Move to head of LRU chain + + if SFE = LRU_Tail then + null; + + elsif SFE = LRU_Head then + LRU_Head := LRU_Head.Next; + LRU_Head.Prev := null; + + else + SFE.Next.Prev := SFE.Prev; + SFE.Prev.Next := SFE.Next; + end if; + + SFE.Next := null; + SFE.Prev := LRU_Tail; + LRU_Tail.Next := SFE; + LRU_Tail := SFE; + end if; + + return SFE; + end Retrieve; + + ---------------------- + -- Shared_Var_Close -- + ---------------------- + + procedure Shared_Var_Close (Var : SIO.Stream_Access) is + pragma Warnings (Off, Var); + + begin + System.Soft_Links.Unlock_Task.all; + end Shared_Var_Close; + + --------------------- + -- Shared_Var_Lock -- + --------------------- + + procedure Shared_Var_Lock (Var : String) is + pragma Warnings (Off, Var); + + begin + System.Soft_Links.Lock_Task.all; + Initialize; + + if Lock_Count /= 0 then + Lock_Count := Lock_Count + 1; + System.Soft_Links.Unlock_Task.all; + + else + Lock_Count := 1; + System.Soft_Links.Unlock_Task.all; + System.Global_Locks.Acquire_Lock (Global_Lock); + end if; + + exception + when others => + System.Soft_Links.Unlock_Task.all; + raise; + end Shared_Var_Lock; + + ---------------------- + -- Shared_Var_Procs -- + ---------------------- + + package body Shared_Var_Procs is + + use type SIO.Stream_Access; + + ---------- + -- Read -- + ---------- + + procedure Read is + S : SIO.Stream_Access := null; + begin + S := Shared_Var_ROpen (Full_Name); + if S /= null then + Typ'Read (S, V); + Shared_Var_Close (S); + end if; + end Read; + + ------------ + -- Write -- + ------------ + + procedure Write is + S : SIO.Stream_Access := null; + begin + S := Shared_Var_WOpen (Full_Name); + Typ'Write (S, V); + Shared_Var_Close (S); + return; + end Write; + + end Shared_Var_Procs; + + ---------------------- + -- Shared_Var_ROpen -- + ---------------------- + + function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is + SFE : Shared_Var_File_Entry_Ptr; + + use type Ada.Streams.Stream_IO.File_Mode; + + begin + System.Soft_Links.Lock_Task.all; + SFE := Retrieve (Var); + + -- Here if file is not already open, try to open it + + if SFE = null then + declare + S : aliased constant String := Dir.all & Var; + + begin + SFE := new Shared_Var_File_Entry; + SFE.Stream := new File_Stream_Type; + SIO.Open (SFE.Stream.File, SIO.In_File, Name => S); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + + -- File opened successfully, put new entry in hash table. Note + -- that in this case, file is positioned correctly for read. + + Enter_SFE (SFE, Var); + + exception + -- If we get an exception, it means that the file does not + -- exist, and in this case, we don't need the SFE and we + -- return null; + + when IOX.Name_Error => + Free (SFE); + System.Soft_Links.Unlock_Task.all; + return null; + end; + + -- Here if file is already open, set file for reading + + else + if SIO.Mode (SFE.Stream.File) /= SIO.In_File then + SIO.Set_Mode (SFE.Stream.File, SIO.In_File); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + end if; + + SIO.Set_Index (SFE.Stream.File, 1); + end if; + + return SIO.Stream_Access (SFE.Stream); + + exception + when others => + System.Soft_Links.Unlock_Task.all; + raise; + end Shared_Var_ROpen; + + ----------------------- + -- Shared_Var_Unlock -- + ----------------------- + + procedure Shared_Var_Unlock (Var : String) is + pragma Warnings (Off, Var); + + begin + System.Soft_Links.Lock_Task.all; + Initialize; + Lock_Count := Lock_Count - 1; + + if Lock_Count = 0 then + System.Global_Locks.Release_Lock (Global_Lock); + end if; + System.Soft_Links.Unlock_Task.all; + + exception + when others => + System.Soft_Links.Unlock_Task.all; + raise; + end Shared_Var_Unlock; + + --------------------- + -- Share_Var_WOpen -- + --------------------- + + function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is + SFE : Shared_Var_File_Entry_Ptr; + + use type Ada.Streams.Stream_IO.File_Mode; + + begin + System.Soft_Links.Lock_Task.all; + SFE := Retrieve (Var); + + if SFE = null then + declare + S : aliased constant String := Dir.all & Var; + + begin + SFE := new Shared_Var_File_Entry; + SFE.Stream := new File_Stream_Type; + SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + + exception + -- If we get an exception, it means that the file does not + -- exist, and in this case, we create the file. + + when IOX.Name_Error => + + begin + SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S); + + exception + -- Error if we cannot create the file + + when others => + raise Program_Error with + "cannot create shared variable file for """ & S & '"'; + end; + end; + + -- Make new hash table entry for opened/created file. Note that + -- in both cases, the file is already in write mode at the start + -- of the file, ready to be written. + + Enter_SFE (SFE, Var); + + -- Here if file is already open, set file for writing + + else + if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then + SIO.Set_Mode (SFE.Stream.File, SIO.Out_File); + SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); + end if; + + SIO.Set_Index (SFE.Stream.File, 1); + end if; + + return SIO.Stream_Access (SFE.Stream); + + exception + when others => + System.Soft_Links.Unlock_Task.all; + raise; + end Shared_Var_WOpen; + + ----------- + -- Write -- + ----------- + + procedure Write + (Stream : in out File_Stream_Type; + Item : AS.Stream_Element_Array) + is + begin + SIO.Write (Stream.File, Item); + end Write; + +end System.Shared_Storage; diff --git a/gcc/ada/libgnat/s-shasto.ads b/gcc/ada/libgnat/s-shasto.ads new file mode 100644 index 0000000..febaf43 --- /dev/null +++ b/gcc/ada/libgnat/s-shasto.ads @@ -0,0 +1,179 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S H A R E D _ S T O R A G E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package manages the shared/persistent storage required for +-- full implementation of variables in Shared_Passive packages, more +-- precisely variables whose enclosing dynamic scope is a shared +-- passive package. This implementation is specific to GNAT and GLADE +-- provides a more general implementation not dedicated to file +-- storage. + +-- -------------------------- +-- -- Shared Storage Model -- +-- -------------------------- + +-- The basic model used is that each partition that references the +-- Shared_Passive package has a local copy of the package data that +-- is initialized in accordance with the declarations of the package +-- in the normal manner. The routines in System.Shared_Storage are +-- then used to ensure that the values in these separate copies are +-- properly synchronized with the state of the overall system. + +-- In the GNAT implementation, this synchronization is ensured by +-- maintaining a set of files, in a designated directory. The +-- directory is designated by setting the environment variable +-- SHARED_MEMORY_DIRECTORY. This variable must be set for all +-- partitions. If the environment variable is not defined, then the +-- current directory is used. + +-- There is one storage for each variable. The name is the fully +-- qualified name of the variable with all letters forced to lower +-- case. For example, the variable Var in the shared passive package +-- Pkg results in the storage name pkg.var. + +-- If the storage does not exist, it indicates that no partition has +-- assigned a new value, so that the initial value is the correct +-- one. This is the critical component of the model. It means that +-- there is no system-wide synchronization required for initializing +-- the package, since the shared storages need not (and do not) +-- reflect the initial state. There is therefore no issue of +-- synchronizing initialization and read/write access. + +-- ----------------------- +-- -- Read/Write Access -- +-- ----------------------- + +-- The approach is as follows: + +-- For each shared variable, var, an instantiation of the below generic +-- package is created which provides Read and Write supporting procedures. + +-- The routine Read in package System.Shared_Storage.Shared_Var_Procs +-- ensures to assign variable V to the last written value among processes +-- referencing it. A call to this procedure is generated by the expander +-- before each read access to the shared variable. + +-- The routine Write in package System.Shared_Storage.Shared_Var_Proc +-- set a new value to the shared variable and, according to the used +-- implementation, propagate this value among processes referencing it. +-- A call to this procedure is generated by the expander after each +-- assignment of the shared variable. + +-- Note: a special circuit allows the use of stream attributes Read and +-- Write for limited types (using the corresponding attribute for the +-- full type), but there are limitations on the data that can be placed +-- in shared passive partitions. See sem_smem.ads/adb for details. + +-- ---------------------------------------------------------------- +-- -- Handling of Protected Objects in Shared Passive Partitions -- +-- ---------------------------------------------------------------- + +-- In the context of GNAT, during the execution of a protected +-- subprogram call, access is locked out using a locking mechanism +-- per protected object, as provided by the GNAT.Lock_Files +-- capability in the specific case of GNAT. This package contains the +-- lock and unlock calls, and the expander generates a call to the +-- lock routine before the protected call and a call to the unlock +-- routine after the protected call. + +-- Within the code of the protected subprogram, the access to the +-- protected object itself uses the local copy, without any special +-- synchronization. Since global access is locked out, no other task +-- or partition can attempt to read or write this data as long as the +-- lock is held. + +-- The data in the local copy does however need synchronizing with +-- the global values in the shared storage. This is achieved as +-- follows: + +-- The protected object generates a read and assignment routine as +-- described for other shared passive variables. The code for the +-- 'Read and 'Write attributes (not normally allowed, but allowed +-- in this special case) simply reads or writes the values of the +-- components in the protected record. + +-- The lock call is followed by a call to the shared read routine to +-- synchronize the local copy to contain the proper global value. + +-- The unlock call in the procedure case only is preceded by a call +-- to the shared assign routine to synchronize the global shared +-- storages with the (possibly modified) local copy. + +-- These calls to the read and assign routines, as well as the lock +-- and unlock routines, are inserted by the expander (see exp_smem.adb). + +package System.Shared_Storage is + + procedure Shared_Var_Lock (Var : String); + -- This procedure claims the shared storage lock. It is used for + -- protected types in shared passive packages. A call to this + -- locking routine is generated as the first operation in the code + -- for the body of a protected subprogram, and it busy waits if + -- the lock is busy. + + procedure Shared_Var_Unlock (Var : String); + -- This procedure releases the shared storage lock obtained by a + -- prior call to the Shared_Var_Lock procedure, and is to be + -- generated as the last operation in the body of a protected + -- subprogram. + + -- This generic package is instantiated for each shared passive + -- variable. It provides supporting procedures called upon each + -- read or write access by the expanded code. + + generic + + type Typ is limited private; + -- Shared passive variable type + + V : in out Typ; + -- Shared passive variable + + Full_Name : String; + -- Shared passive variable storage name + + package Shared_Var_Procs is + + procedure Read; + -- Shared passive variable access routine. Each reference to the + -- shared variable, V, is preceded by a call to the corresponding + -- Read procedure, which either leaves the initial value unchanged + -- if the storage does not exist, or reads the current value from + -- the shared storage. + + procedure Write; + -- Shared passive variable assignment routine. Each assignment to + -- the shared variable, V, is followed by a call to the corresponding + -- Write procedure, which writes the new value to the shared storage. + + end Shared_Var_Procs; + +end System.Shared_Storage; diff --git a/gcc/ada/libgnat/s-soflin.adb b/gcc/ada/libgnat/s-soflin.adb new file mode 100644 index 0000000..f604f4d --- /dev/null +++ b/gcc/ada/libgnat/s-soflin.adb @@ -0,0 +1,312 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get an +-- infinite loop from the code within the Poll routine itself. + +with System.Parameters; + +pragma Warnings (Off); +-- Disable warnings since System.Secondary_Stack is currently not Preelaborate +with System.Secondary_Stack; +pragma Warnings (On); + +package body System.Soft_Links is + + package SST renames System.Secondary_Stack; + + NT_TSD : TSD; + -- Note: we rely on the default initialization of NT_TSD + + -- Needed for Vx6Cert (Vx653mc) GOS cert and ravenscar-cert runtimes, + -- VxMILS cert, ravenscar-cert and full runtimes, Vx 5 default runtime + Stack_Limit : aliased System.Address := System.Null_Address; + + pragma Export (C, Stack_Limit, "__gnat_stack_limit"); + + -------------------- + -- Abort_Defer_NT -- + -------------------- + + procedure Abort_Defer_NT is + begin + null; + end Abort_Defer_NT; + + ---------------------- + -- Abort_Handler_NT -- + ---------------------- + + procedure Abort_Handler_NT is + begin + null; + end Abort_Handler_NT; + + ---------------------- + -- Abort_Undefer_NT -- + ---------------------- + + procedure Abort_Undefer_NT is + begin + null; + end Abort_Undefer_NT; + + ----------------- + -- Adafinal_NT -- + ----------------- + + procedure Adafinal_NT is + begin + -- Handle normal task termination by the environment task, but only + -- for the normal task termination. In the case of Abnormal and + -- Unhandled_Exception they must have been handled before, and the + -- task termination soft link must have been changed so the task + -- termination routine is not executed twice. + + Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); + + -- Finalize all library-level controlled objects if needed + + if Finalize_Library_Objects /= null then + Finalize_Library_Objects.all; + end if; + end Adafinal_NT; + + --------------------------- + -- Check_Abort_Status_NT -- + --------------------------- + + function Check_Abort_Status_NT return Integer is + begin + return Boolean'Pos (False); + end Check_Abort_Status_NT; + + ------------------------ + -- Complete_Master_NT -- + ------------------------ + + procedure Complete_Master_NT is + begin + null; + end Complete_Master_NT; + + ---------------- + -- Create_TSD -- + ---------------- + + procedure Create_TSD (New_TSD : in out TSD) is + use Parameters; + SS_Ratio_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; + begin + if SS_Ratio_Dynamic then + SST.SS_Init + (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size); + end if; + end Create_TSD; + + ----------------------- + -- Current_Master_NT -- + ----------------------- + + function Current_Master_NT return Integer is + begin + return 0; + end Current_Master_NT; + + ----------------- + -- Destroy_TSD -- + ----------------- + + procedure Destroy_TSD (Old_TSD : in out TSD) is + begin + SST.SS_Free (Old_TSD.Sec_Stack_Addr); + end Destroy_TSD; + + --------------------- + -- Enter_Master_NT -- + --------------------- + + procedure Enter_Master_NT is + begin + null; + end Enter_Master_NT; + + -------------------------- + -- Get_Current_Excep_NT -- + -------------------------- + + function Get_Current_Excep_NT return EOA is + begin + return NT_TSD.Current_Excep'Access; + end Get_Current_Excep_NT; + + ------------------------ + -- Get_GNAT_Exception -- + ------------------------ + + function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is + begin + return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all); + end Get_GNAT_Exception; + + --------------------------- + -- Get_Jmpbuf_Address_NT -- + --------------------------- + + function Get_Jmpbuf_Address_NT return Address is + begin + return NT_TSD.Jmpbuf_Address; + end Get_Jmpbuf_Address_NT; + + ----------------------------- + -- Get_Jmpbuf_Address_Soft -- + ----------------------------- + + function Get_Jmpbuf_Address_Soft return Address is + begin + return Get_Jmpbuf_Address.all; + end Get_Jmpbuf_Address_Soft; + + --------------------------- + -- Get_Sec_Stack_Addr_NT -- + --------------------------- + + function Get_Sec_Stack_Addr_NT return Address is + begin + return NT_TSD.Sec_Stack_Addr; + end Get_Sec_Stack_Addr_NT; + + ----------------------------- + -- Get_Sec_Stack_Addr_Soft -- + ----------------------------- + + function Get_Sec_Stack_Addr_Soft return Address is + begin + return Get_Sec_Stack_Addr.all; + end Get_Sec_Stack_Addr_Soft; + + ----------------------- + -- Get_Stack_Info_NT -- + ----------------------- + + function Get_Stack_Info_NT return Stack_Checking.Stack_Access is + begin + return NT_TSD.Pri_Stack_Info'Access; + end Get_Stack_Info_NT; + + ----------------------------- + -- Save_Library_Occurrence -- + ----------------------------- + + procedure Save_Library_Occurrence (E : EOA) is + use Ada.Exceptions; + begin + if not Library_Exception_Set then + Library_Exception_Set := True; + if E /= null then + Ada.Exceptions.Save_Occurrence (Library_Exception, E.all); + end if; + end if; + end Save_Library_Occurrence; + + --------------------------- + -- Set_Jmpbuf_Address_NT -- + --------------------------- + + procedure Set_Jmpbuf_Address_NT (Addr : Address) is + begin + NT_TSD.Jmpbuf_Address := Addr; + end Set_Jmpbuf_Address_NT; + + procedure Set_Jmpbuf_Address_Soft (Addr : Address) is + begin + Set_Jmpbuf_Address (Addr); + end Set_Jmpbuf_Address_Soft; + + --------------------------- + -- Set_Sec_Stack_Addr_NT -- + --------------------------- + + procedure Set_Sec_Stack_Addr_NT (Addr : Address) is + begin + NT_TSD.Sec_Stack_Addr := Addr; + end Set_Sec_Stack_Addr_NT; + + ----------------------------- + -- Set_Sec_Stack_Addr_Soft -- + ----------------------------- + + procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is + begin + Set_Sec_Stack_Addr (Addr); + end Set_Sec_Stack_Addr_Soft; + + ------------------ + -- Task_Lock_NT -- + ------------------ + + procedure Task_Lock_NT is + begin + null; + end Task_Lock_NT; + + ------------------ + -- Task_Name_NT -- + ------------------- + + function Task_Name_NT return String is + begin + return "main_task"; + end Task_Name_NT; + + ------------------------- + -- Task_Termination_NT -- + ------------------------- + + procedure Task_Termination_NT (Excep : EO) is + pragma Unreferenced (Excep); + begin + null; + end Task_Termination_NT; + + -------------------- + -- Task_Unlock_NT -- + -------------------- + + procedure Task_Unlock_NT is + begin + null; + end Task_Unlock_NT; + +end System.Soft_Links; diff --git a/gcc/ada/libgnat/s-soflin.ads b/gcc/ada/libgnat/s-soflin.ads new file mode 100644 index 0000000..402ea84 --- /dev/null +++ b/gcc/ada/libgnat/s-soflin.ads @@ -0,0 +1,399 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S O F T _ L I N K S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains a set of subprogram access variables that access +-- some low-level primitives that are different depending whether tasking is +-- involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a +-- different value for each task). To avoid dragging in the tasking runtimes +-- all the time, we use a system of soft links where the links are +-- initialized to non-tasking versions, and then if the tasking support is +-- initialized, they are set to the real tasking versions. + +pragma Compiler_Unit_Warning; + +with Ada.Exceptions; +with System.Stack_Checking; + +package System.Soft_Links is + pragma Preelaborate; + + subtype EOA is Ada.Exceptions.Exception_Occurrence_Access; + subtype EO is Ada.Exceptions.Exception_Occurrence; + + function Current_Target_Exception return EO; + pragma Import + (Ada, Current_Target_Exception, "__gnat_current_target_exception"); + -- Import this subprogram from the private part of Ada.Exceptions + + -- First we have the access subprogram types used to establish the links. + -- The approach is to establish variables containing access subprogram + -- values, which by default point to dummy no tasking versions of routines. + + type No_Param_Proc is access procedure; + pragma Favor_Top_Level (No_Param_Proc); + pragma Suppress_Initialization (No_Param_Proc); + -- Some uninitialized objects of that type are initialized by the Binder + -- so it is important that such objects are not reset to null during + -- elaboration. + + type Addr_Param_Proc is access procedure (Addr : Address); + pragma Favor_Top_Level (Addr_Param_Proc); + type EO_Param_Proc is access procedure (Excep : EO); + pragma Favor_Top_Level (EO_Param_Proc); + + type Get_Address_Call is access function return Address; + pragma Favor_Top_Level (Get_Address_Call); + type Set_Address_Call is access procedure (Addr : Address); + pragma Favor_Top_Level (Set_Address_Call); + type Set_Address_Call2 is access procedure + (Self_ID : Address; Addr : Address); + pragma Favor_Top_Level (Set_Address_Call2); + + type Get_Integer_Call is access function return Integer; + pragma Favor_Top_Level (Get_Integer_Call); + type Set_Integer_Call is access procedure (Len : Integer); + pragma Favor_Top_Level (Set_Integer_Call); + + type Get_EOA_Call is access function return EOA; + pragma Favor_Top_Level (Get_EOA_Call); + type Set_EOA_Call is access procedure (Excep : EOA); + pragma Favor_Top_Level (Set_EOA_Call); + type Set_EO_Call is access procedure (Excep : EO); + pragma Favor_Top_Level (Set_EO_Call); + + type Special_EO_Call is access + procedure (Excep : EO := Current_Target_Exception); + pragma Favor_Top_Level (Special_EO_Call); + + type Timed_Delay_Call is access + procedure (Time : Duration; Mode : Integer); + pragma Favor_Top_Level (Timed_Delay_Call); + + type Get_Stack_Access_Call is access + function return Stack_Checking.Stack_Access; + pragma Favor_Top_Level (Get_Stack_Access_Call); + + type Task_Name_Call is access + function return String; + pragma Favor_Top_Level (Task_Name_Call); + + -- Suppress checks on all these types, since we know the corresponding + -- values can never be null (the soft links are always initialized). + + pragma Suppress (Access_Check, No_Param_Proc); + pragma Suppress (Access_Check, Addr_Param_Proc); + pragma Suppress (Access_Check, EO_Param_Proc); + pragma Suppress (Access_Check, Get_Address_Call); + pragma Suppress (Access_Check, Set_Address_Call); + pragma Suppress (Access_Check, Set_Address_Call2); + pragma Suppress (Access_Check, Get_Integer_Call); + pragma Suppress (Access_Check, Set_Integer_Call); + pragma Suppress (Access_Check, Get_EOA_Call); + pragma Suppress (Access_Check, Set_EOA_Call); + pragma Suppress (Access_Check, Timed_Delay_Call); + pragma Suppress (Access_Check, Get_Stack_Access_Call); + pragma Suppress (Access_Check, Task_Name_Call); + + -- The following one is not related to tasking/no-tasking but to the + -- traceback decorators for exceptions. + + type Traceback_Decorator_Wrapper_Call is access + function (Traceback : System.Address; + Len : Natural) + return String; + pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call); + + -- Declarations for the no tasking versions of the required routines + + procedure Abort_Defer_NT; + -- Defer task abort (non-tasking case, does nothing) + + procedure Abort_Undefer_NT; + -- Undefer task abort (non-tasking case, does nothing) + + procedure Abort_Handler_NT; + -- Handle task abort (non-tasking case, does nothing). Currently, no port + -- makes use of this, but we retain the interface for possible future use. + + function Check_Abort_Status_NT return Integer; + -- Returns Boolean'Pos (True) iff abort signal should raise + -- Standard'Abort_Signal. + + procedure Task_Lock_NT; + -- Lock out other tasks (non-tasking case, does nothing) + + procedure Task_Unlock_NT; + -- Release lock set by Task_Lock (non-tasking case, does nothing) + + procedure Task_Termination_NT (Excep : EO); + -- Handle task termination routines for the environment task (non-tasking + -- case, does nothing). + + procedure Adafinal_NT; + -- Shuts down the runtime system (non-tasking case) + + Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; + pragma Suppress (Access_Check, Abort_Defer); + -- Defer task abort (task/non-task case as appropriate) + + Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; + pragma Suppress (Access_Check, Abort_Undefer); + -- Undefer task abort (task/non-task case as appropriate) + + Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; + -- Handle task abort (task/non-task case as appropriate) + + Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; + -- Called when Abort_Signal is delivered to the process. Checks to + -- see if signal should result in raising Standard'Abort_Signal. + + Lock_Task : No_Param_Proc := Task_Lock_NT'Access; + -- Locks out other tasks. Preceding a section of code by Task_Lock and + -- following it by Task_Unlock creates a critical region. This is used + -- for ensuring that a region of non-tasking code (such as code used to + -- allocate memory) is tasking safe. Note that it is valid for calls to + -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. + -- only the corresponding outer level Task_Unlock will actually unlock. + -- This routine also prevents against asynchronous aborts (abort is + -- deferred). + + Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access; + -- Releases lock previously set by call to Lock_Task. In the nested case, + -- all nested locks must be released before other tasks competing for the + -- tasking lock are released. + -- + -- In the non nested case, this routine terminates the protection against + -- asynchronous aborts introduced by Lock_Task (unless abort was already + -- deferred before the call to Lock_Task (e.g in a protected procedures). + -- + -- Note: the recommended protocol for using Lock_Task and Unlock_Task + -- is as follows: + -- + -- Locked_Processing : begin + -- System.Soft_Links.Lock_Task.all; + -- ... + -- System.Soft_Links.Unlock_Task.all; + -- + -- exception + -- when others => + -- System.Soft_Links.Unlock_Task.all; + -- raise; + -- end Locked_Processing; + -- + -- This ensures that the lock is not left set if an exception is raised + -- explicitly or implicitly during the critical locked region. + + Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access; + -- Handle task termination routines (task/non-task case as appropriate) + + Finalize_Library_Objects : No_Param_Proc; + pragma Export (C, Finalize_Library_Objects, + "__gnat_finalize_library_objects"); + -- Will be initialized by the binder + + Adafinal : No_Param_Proc := Adafinal_NT'Access; + -- Performs the finalization of the Ada Runtime + + function Get_Jmpbuf_Address_NT return Address; + procedure Set_Jmpbuf_Address_NT (Addr : Address); + + Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access; + Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access; + + function Get_Sec_Stack_Addr_NT return Address; + procedure Set_Sec_Stack_Addr_NT (Addr : Address); + + Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; + Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; + + function Get_Current_Excep_NT return EOA; + + Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access; + + function Get_Stack_Info_NT return Stack_Checking.Stack_Access; + + Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access; + + -------------------------- + -- Master_Id Soft-Links -- + -------------------------- + + -- Soft-Links are used for procedures that manipulate Master_Ids because + -- a Master_Id must be generated for access to limited class-wide types, + -- whose root may be extended with task components. + + function Current_Master_NT return Integer; + procedure Enter_Master_NT; + procedure Complete_Master_NT; + + Current_Master : Get_Integer_Call := Current_Master_NT'Access; + Enter_Master : No_Param_Proc := Enter_Master_NT'Access; + Complete_Master : No_Param_Proc := Complete_Master_NT'Access; + + ---------------------- + -- Delay Soft-Links -- + ---------------------- + + -- Soft-Links are used for procedures that manipulate time to avoid + -- dragging the tasking run time when using delay statements. + + Timed_Delay : Timed_Delay_Call; + + -------------------------- + -- Task Name Soft-Links -- + -------------------------- + + function Task_Name_NT return String; + + Task_Name : Task_Name_Call := Task_Name_NT'Access; + + ------------------------------------- + -- Exception Tracebacks Soft-Links -- + ------------------------------------- + + Library_Exception : EO; + -- Library-level finalization routines use this common reference to store + -- the first library-level exception which occurs during finalization. + + Library_Exception_Set : Boolean := False; + -- Used in conjunction with Library_Exception, set when an exception has + -- been stored. + + Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call; + -- Wrapper to the possible user specified traceback decorator to be + -- called during automatic output of exception data. + + -- The null value of this wrapper correspond sto the null value of the + -- current actual decorator. This is ensured first by the null initial + -- value of the corresponding variables, and then by Set_Trace_Decorator + -- in g-exctra.adb. + + pragma Atomic (Traceback_Decorator_Wrapper); + -- Since concurrent read/write operations may occur on this variable. + -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for + -- a more detailed description of the potential problems. + + procedure Save_Library_Occurrence (E : EOA); + -- When invoked, this routine saves an exception occurrence into a hidden + -- reference. Subsequent calls will have no effect. + + ------------------------ + -- Task Specific Data -- + ------------------------ + + -- Here we define a single type that encapsulates the various task + -- specific data. This type is used to store the necessary data into the + -- Task_Control_Block or into a global variable in the non tasking case. + + type TSD is record + Pri_Stack_Info : aliased Stack_Checking.Stack_Info; + -- Information on stack (Base/Limit/Size) used by System.Stack_Checking. + -- If this TSD does not belong to the environment task, the Size field + -- must be initialized to the tasks requested stack size before the task + -- can do its first stack check. + + pragma Warnings (Off); + -- Needed because we are giving a non-static default to an object in + -- a preelaborated unit, which is formally not permitted, but OK here. + + Jmpbuf_Address : System.Address := System.Null_Address; + -- Address of jump buffer used to store the address of the current + -- longjmp/setjmp buffer for exception management. These buffers are + -- threaded into a stack, and the address here is the top of the stack. + -- A null address means that no exception handler is currently active. + + Sec_Stack_Addr : System.Address := System.Null_Address; + pragma Warnings (On); + -- Address of currently allocated secondary stack + + Current_Excep : aliased EO; + -- Exception occurrence that contains the information for the current + -- exception. Note that any exception in the same task destroys this + -- information, so the data in this variable must be copied out before + -- another exception can occur. + -- + -- Also act as a list of the active exceptions in the case of the GCC + -- exception mechanism, organized as a stack with the most recent first. + end record; + + procedure Create_TSD (New_TSD : in out TSD); + pragma Inline (Create_TSD); + -- Called from s-tassta when a new thread is created to perform + -- any required initialization of the TSD. + + procedure Destroy_TSD (Old_TSD : in out TSD); + pragma Inline (Destroy_TSD); + -- Called from s-tassta just before a thread is destroyed to perform + -- any required finalization. + + function Get_GNAT_Exception return Ada.Exceptions.Exception_Id; + pragma Inline (Get_GNAT_Exception); + -- This function obtains the Exception_Id from the Exception_Occurrence + -- referenced by the Current_Excep field of the task specific data, i.e. + -- the call is equivalent to + -- Exception_Identity (Get_Current_Exception.all) + + -- Export the Get/Set routines for the various Task Specific Data (TSD) + -- elements as callable subprograms instead of objects of access to + -- subprogram types. + + function Get_Jmpbuf_Address_Soft return Address; + procedure Set_Jmpbuf_Address_Soft (Addr : Address); + pragma Inline (Get_Jmpbuf_Address_Soft); + pragma Inline (Set_Jmpbuf_Address_Soft); + + function Get_Sec_Stack_Addr_Soft return Address; + procedure Set_Sec_Stack_Addr_Soft (Addr : Address); + pragma Inline (Get_Sec_Stack_Addr_Soft); + pragma Inline (Set_Sec_Stack_Addr_Soft); + + -- The following is a dummy record designed to mimic Communication_Block as + -- defined in s-tpobop.ads: + + -- type Communication_Block is record + -- Self : Task_Id; -- An access type + -- Enqueued : Boolean := True; + -- Cancelled : Boolean := False; + -- end record; + + -- The record is used in the construction of the predefined dispatching + -- primitive _disp_asynchronous_select in order to avoid the import of + -- System.Tasking.Protected_Objects.Operations. Note that this package + -- is always imported in the presence of interfaces since the dispatch + -- table uses entities from here. + + type Dummy_Communication_Block is record + Comp_1 : Address; -- Address and access have the same size + Comp_2 : Boolean; + Comp_3 : Boolean; + end record; + +end System.Soft_Links; diff --git a/gcc/ada/libgnat/s-sopco3.adb b/gcc/ada/libgnat/s-sopco3.adb new file mode 100644 index 0000000..85c183c --- /dev/null +++ b/gcc/ada/libgnat/s-sopco3.adb @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 3 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package body System.String_Ops_Concat_3 is + + ------------------ + -- Str_Concat_3 -- + ------------------ + + function Str_Concat_3 (S1, S2, S3 : String) return String is + begin + if S1'Length = 0 then + return S2 & S3; + + else + declare + L12 : constant Natural := S1'Length + S2'Length; + L13 : constant Natural := L12 + S3'Length; + R : String (S1'First .. S1'First + L13 - 1); + + begin + R (S1'First .. S1'Last) := S1; + R (S1'Last + 1 .. S1'First + L12 - 1) := S2; + R (S1'First + L12 .. R'Last) := S3; + return R; + end; + end if; + end Str_Concat_3; + +end System.String_Ops_Concat_3; diff --git a/gcc/ada/libgnat/s-sopco3.ads b/gcc/ada/libgnat/s-sopco3.ads new file mode 100644 index 0000000..eee4667 --- /dev/null +++ b/gcc/ada/libgnat/s-sopco3.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 3 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the function for concatenating three strings + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package System.String_Ops_Concat_3 is + pragma Pure; + + function Str_Concat_3 (S1, S2, S3 : String) return String; + -- Concatenate three strings and return resulting string + +end System.String_Ops_Concat_3; diff --git a/gcc/ada/libgnat/s-sopco4.adb b/gcc/ada/libgnat/s-sopco4.adb new file mode 100644 index 0000000..a6dcb03 --- /dev/null +++ b/gcc/ada/libgnat/s-sopco4.adb @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 4 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package body System.String_Ops_Concat_4 is + + ------------------ + -- Str_Concat_4 -- + ------------------ + + function Str_Concat_4 (S1, S2, S3, S4 : String) return String is + begin + if S1'Length = 0 then + return S2 & S3 & S4; + + else + declare + L12 : constant Natural := S1'Length + S2'Length; + L13 : constant Natural := L12 + S3'Length; + L14 : constant Natural := L13 + S4'Length; + R : String (S1'First .. S1'First + L14 - 1); + + begin + R (S1'First .. S1'Last) := S1; + R (S1'Last + 1 .. S1'First + L12 - 1) := S2; + R (S1'First + L12 .. S1'First + L13 - 1) := S3; + R (S1'First + L13 .. R'Last) := S4; + return R; + end; + end if; + end Str_Concat_4; + +end System.String_Ops_Concat_4; diff --git a/gcc/ada/libgnat/s-sopco4.ads b/gcc/ada/libgnat/s-sopco4.ads new file mode 100644 index 0000000..3020cca --- /dev/null +++ b/gcc/ada/libgnat/s-sopco4.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 4 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the function for concatenating four strings + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package System.String_Ops_Concat_4 is + pragma Pure; + + function Str_Concat_4 (S1, S2, S3, S4 : String) return String; + -- Concatenate four strings and return resulting string + +end System.String_Ops_Concat_4; diff --git a/gcc/ada/libgnat/s-sopco5.adb b/gcc/ada/libgnat/s-sopco5.adb new file mode 100644 index 0000000..8765b53 --- /dev/null +++ b/gcc/ada/libgnat/s-sopco5.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 5 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package body System.String_Ops_Concat_5 is + + ------------------ + -- Str_Concat_5 -- + ------------------ + + function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String is + begin + if S1'Length = 0 then + return S2 & S3 & S4 & S5; + + else + declare + L12 : constant Natural := S1'Length + S2'Length; + L13 : constant Natural := L12 + S3'Length; + L14 : constant Natural := L13 + S4'Length; + L15 : constant Natural := L14 + S5'Length; + R : String (S1'First .. S1'First + L15 - 1); + + begin + R (S1'First .. S1'Last) := S1; + R (S1'Last + 1 .. S1'First + L12 - 1) := S2; + R (S1'First + L12 .. S1'First + L13 - 1) := S3; + R (S1'First + L13 .. S1'First + L14 - 1) := S4; + R (S1'First + L14 .. R'Last) := S5; + return R; + end; + end if; + end Str_Concat_5; + +end System.String_Ops_Concat_5; diff --git a/gcc/ada/libgnat/s-sopco5.ads b/gcc/ada/libgnat/s-sopco5.ads new file mode 100644 index 0000000..180503e --- /dev/null +++ b/gcc/ada/libgnat/s-sopco5.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 5 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the function for concatenating five strings + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package System.String_Ops_Concat_5 is + pragma Pure; + + function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String; + -- Concatenate five strings and return resulting string + +end System.String_Ops_Concat_5; diff --git a/gcc/ada/libgnat/s-spsufi.adb b/gcc/ada/libgnat/s-spsufi.adb new file mode 100644 index 0000000..11846c9 --- /dev/null +++ b/gcc/ada/libgnat/s-spsufi.adb @@ -0,0 +1,89 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.STORAGE_POOLS.SUBPOOLS.FINALIZATION -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Deallocation; + +with System.Finalization_Masters; use System.Finalization_Masters; + +package body System.Storage_Pools.Subpools.Finalization is + + ----------------------------- + -- Finalize_And_Deallocate -- + ----------------------------- + + procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is + procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr); + + begin + -- Do nothing if the subpool was never created or never used. The latter + -- case may arise with an array of subpool implementations. + + if Subpool = null + or else Subpool.Owner = null + or else Subpool.Node = null + then + return; + end if; + + -- Clean up all controlled objects chained on the subpool's master + + Finalize (Subpool.Master); + + -- Remove the subpool from its owner's list of subpools + + Detach (Subpool.Node); + + -- Destroy the associated doubly linked list node which was created in + -- Set_Pool_Of_Subpools. + + Free (Subpool.Node); + + -- Dispatch to the user-defined implementation of Deallocate_Subpool. It + -- is important to first set Subpool.Owner to null, because RM-13.11.5 + -- requires that "The subpool no longer belongs to any pool" BEFORE + -- calling Deallocate_Subpool. The actual dispatching call required is: + -- + -- Deallocate_Subpool(Pool_of_Subpool(Subpool).all, Subpool); + -- + -- but that can't be taken literally, because Pool_of_Subpool will + -- return null. + + declare + Owner : constant Any_Storage_Pool_With_Subpools_Ptr := Subpool.Owner; + begin + Subpool.Owner := null; + Deallocate_Subpool (Owner.all, Subpool); + end; + + Subpool := null; + end Finalize_And_Deallocate; + +end System.Storage_Pools.Subpools.Finalization; diff --git a/gcc/ada/libgnat/s-spsufi.ads b/gcc/ada/libgnat/s-spsufi.ads new file mode 100644 index 0000000..e4091ac --- /dev/null +++ b/gcc/ada/libgnat/s-spsufi.ads @@ -0,0 +1,48 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- SYSTEM.STORAGE_POOLS.SUBPOOLS.FINALIZATION -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package System.Storage_Pools.Subpools.Finalization is + + -- The pragma is needed because package System.Storage_Pools.Subpools which + -- is already preelaborated now depends on this unit. + + pragma Preelaborate; + + procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle); + -- This routine performs the following actions: + -- 1) Finalize all objects chained on the subpool's master + -- 2) Remove the subpool from the owner's list of subpools + -- 3) Deallocate the doubly linked list node associated with the subpool + -- 4) Call Deallocate_Subpool + +end System.Storage_Pools.Subpools.Finalization; diff --git a/gcc/ada/libgnat/s-stache.adb b/gcc/ada/libgnat/s-stache.adb new file mode 100644 index 0000000..8be4293 --- /dev/null +++ b/gcc/ada/libgnat/s-stache.adb @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +-- As noted in the spec, this dummy body is present because otherwise we +-- have bootstrapping path problems (there used to be a real body). + +package body System.Stack_Checking is +end System.Stack_Checking; diff --git a/gcc/ada/libgnat/s-stache.ads b/gcc/ada/libgnat/s-stache.ads new file mode 100644 index 0000000..8f3060f --- /dev/null +++ b/gcc/ada/libgnat/s-stache.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a system-independent implementation of stack +-- checking using comparison with stack base and limit. + +-- This package defines basic types and objects. Operations related to +-- stack checking can be found in package System.Stack_Checking.Operations. + +pragma Compiler_Unit_Warning; + +with System.Storage_Elements; + +package System.Stack_Checking is + pragma Preelaborate; + pragma Elaborate_Body; + -- This unit has a junk null body. The reason is that historically we + -- used to have a real body, and it causes bootstrapping path problems + -- to eliminate it, since the old body may still be present in the + -- compilation environment for a build. + + type Stack_Info is record + Limit : System.Address := System.Null_Address; + Base : System.Address := System.Null_Address; + Size : System.Storage_Elements.Storage_Offset := 0; + end record; + -- This record may be part of a larger data structure like the + -- task control block in the tasking case. + -- This specific layout has the advantage of being compatible with the + -- Intel x86 BOUNDS instruction. + + type Stack_Access is access all Stack_Info; + -- Unique local storage associated with a specific task. This storage is + -- used for the stack base and limit, and is returned by Checked_Self. + -- Only self may write this information, it may be read by any task. + -- At no time the address range Limit .. Base (or Base .. Limit for + -- upgrowing stack) may contain any address that is part of another stack. + -- The Stack_Access may be part of a larger data structure. + + Multi_Processor : constant Boolean := False; -- Not supported yet + +private + + Null_Stack_Info : aliased Stack_Info := + (Limit => System.Null_Address, + Base => System.Null_Address, + Size => 0); + -- Use explicit assignment to avoid elaboration code (call to init proc) + + Null_Stack : constant Stack_Access := Null_Stack_Info'Access; + -- Stack_Access value that will return a Stack_Base and Stack_Limit + -- that fail any stack check. + +end System.Stack_Checking; diff --git a/gcc/ada/libgnat/s-stalib.adb b/gcc/ada/libgnat/s-stalib.adb new file mode 100644 index 0000000..07fb21a --- /dev/null +++ b/gcc/ada/libgnat/s-stalib.adb @@ -0,0 +1,105 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T A N D A R D _ L I B R A R Y -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +-- The purpose of this body is simply to ensure that the two with'ed units +-- are properly included in the link. They are not with'ed from the spec +-- of System.Standard_Library, since this would cause order of elaboration +-- problems (Elaborate_Body would have the same problem). + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions if polling is on. + +pragma Warnings (Off); +-- Kill warnings from unused withs. These unused with's are here to make +-- sure the relevant units are loaded and properly elaborated. + +with System.Soft_Links; +-- Referenced directly from generated code using external symbols so it +-- must always be present in a build, even if no unit has a direct with +-- of this unit. Also referenced from exception handling routines. +-- This is needed for programs that don't use exceptions explicitly but +-- direct calls to Ada.Exceptions are generated by gigi (for example, +-- by calling __gnat_raise_constraint_error directly). + +with System.Memory; +-- Referenced directly from generated code using external symbols, so it +-- must always be present in a build, even if no unit has a direct with +-- of this unit. + +pragma Warnings (On); + +package body System.Standard_Library is + + Runtime_Finalized : Boolean := False; + -- Set to True when adafinal is called. Used to ensure that subsequent + -- calls to adafinal after the first have no effect. + + -------------------------- + -- Abort_Undefer_Direct -- + -------------------------- + + procedure Abort_Undefer_Direct is + begin + System.Soft_Links.Abort_Undefer.all; + end Abort_Undefer_Direct; + + -------------- + -- Adafinal -- + -------------- + + procedure Adafinal is + begin + if not Runtime_Finalized then + Runtime_Finalized := True; + System.Soft_Links.Adafinal.all; + end if; + end Adafinal; + + ----------------- + -- Break_Start -- + ----------------- + + procedure Break_Start; + pragma Export (C, Break_Start, "__gnat_break_start"); + -- This is a dummy procedure that is called at the start of execution. + -- Its sole purpose is to provide a well defined point for the placement + -- of a main program breakpoint. This is not used anymore but kept for + -- bootstrapping issues (still referenced by old gnatbind generated files). + + procedure Break_Start is + begin + null; + end Break_Start; + +end System.Standard_Library; diff --git a/gcc/ada/libgnat/s-stalib.ads b/gcc/ada/libgnat/s-stalib.ads new file mode 100644 index 0000000..d066b0d --- /dev/null +++ b/gcc/ada/libgnat/s-stalib.ads @@ -0,0 +1,263 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T A N D A R D _ L I B R A R Y -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is included in all programs. It contains declarations that +-- are required to be part of every Ada program. A special mechanism is +-- required to ensure that these are loaded, since it may be the case in +-- some programs that the only references to these required packages are +-- from C code or from code generated directly by Gigi, and in both cases +-- the binder is not aware of such references. + +-- System.Standard_Library also includes data that must be present in every +-- program, in particular data for all the standard exceptions, and also some +-- subprograms that must be present in every program. + +-- The binder unconditionally includes s-stalib.ali, which ensures that this +-- package and the packages it references are included in all Ada programs, +-- together with the included data. + +pragma Compiler_Unit_Warning; + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions if polling is on. + +with Ada.Unchecked_Conversion; + +package System.Standard_Library is + + -- Historical note: pragma Preelaborate was surrounded by a pair of pragma + -- Warnings (Off/On) to circumvent a bootstrap issue. + + pragma Preelaborate; + + subtype Big_String is String (1 .. Positive'Last); + pragma Suppress_Initialization (Big_String); + -- Type used to obtain string access to given address. Initialization is + -- suppressed, since we never want to have variables of this type, and + -- we never want to attempt initialiazation of virtual variables of this + -- type (e.g. when pragma Normalize_Scalars is used). + + type Big_String_Ptr is access all Big_String; + for Big_String_Ptr'Storage_Size use 0; + -- We use this access type to pass a pointer to an area of storage to be + -- accessed as a string. Of course when this pointer is used, it is the + -- responsibility of the accessor to ensure proper bounds. The storage + -- size clause ensures we do not allocate variables of this type. + + function To_Ptr is + new Ada.Unchecked_Conversion (System.Address, Big_String_Ptr); + + ------------------------------------- + -- Exception Declarations and Data -- + ------------------------------------- + + type Raise_Action is access procedure; + -- A pointer to a procedure used in the Raise_Hook field + + type Exception_Data; + type Exception_Data_Ptr is access all Exception_Data; + -- An equivalent of Exception_Id that is public + + -- The following record defines the underlying representation of exceptions + + -- WARNING: Any changes to this may need to be reflected in the following + -- locations in the compiler and runtime code: + + -- 1. The Internal_Exception routine in s-exctab.adb + -- 2. The processing in gigi that tests Not_Handled_By_Others + -- 3. Expand_N_Exception_Declaration in Exp_Ch11 + -- 4. The construction of the exception type in Cstand + + type Exception_Data is record + Not_Handled_By_Others : Boolean; + -- Normally set False, indicating that the exception is handled in the + -- usual way by others (i.e. an others handler handles the exception). + -- Set True to indicate that this exception is not caught by others + -- handlers, but must be explicitly named in a handler. This latter + -- setting is currently used by the Abort_Signal. + + Lang : Character; + -- A character indicating the language raising the exception. + -- Set to "A" for exceptions defined by an Ada program. + -- Set to "C" for imported C++ exceptions. + + Name_Length : Natural; + -- Length of fully expanded name of exception + + Full_Name : System.Address; + -- Fully expanded name of exception, null terminated + -- You can use To_Ptr to convert this to a string. + + HTable_Ptr : Exception_Data_Ptr; + -- Hash table pointer used to link entries together in the hash table + -- built (by Register_Exception in s-exctab.adb) for converting between + -- identities and names. + + Foreign_Data : Address; + -- Data for imported exceptions. Not used in the Ada case. This + -- represents the address of the RTTI for the C++ case. + + Raise_Hook : Raise_Action; + -- This field can be used to place a "hook" on an exception. If the + -- value is non-null, then it points to a procedure which is called + -- whenever the exception is raised. This call occurs immediately, + -- before any other actions taken by the raise (and in particular + -- before any unwinding of the stack occurs). + end record; + + -- Definitions for standard predefined exceptions defined in Standard, + + -- Why are the NULs necessary here, seems like they should not be + -- required, since Gigi is supposed to add a Nul to each name ??? + + Constraint_Error_Name : constant String := "CONSTRAINT_ERROR" & ASCII.NUL; + Program_Error_Name : constant String := "PROGRAM_ERROR" & ASCII.NUL; + Storage_Error_Name : constant String := "STORAGE_ERROR" & ASCII.NUL; + Tasking_Error_Name : constant String := "TASKING_ERROR" & ASCII.NUL; + Abort_Signal_Name : constant String := "_ABORT_SIGNAL" & ASCII.NUL; + + Numeric_Error_Name : constant String := "NUMERIC_ERROR" & ASCII.NUL; + -- This is used only in the Ada 83 case, but it is not worth having a + -- separate version of s-stalib.ads for use in Ada 83 mode. + + Constraint_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Constraint_Error_Name'Length, + Full_Name => Constraint_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Numeric_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Numeric_Error_Name'Length, + Full_Name => Numeric_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Program_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Program_Error_Name'Length, + Full_Name => Program_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Storage_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Storage_Error_Name'Length, + Full_Name => Storage_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Tasking_Error_Def : aliased Exception_Data := + (Not_Handled_By_Others => False, + Lang => 'A', + Name_Length => Tasking_Error_Name'Length, + Full_Name => Tasking_Error_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + Abort_Signal_Def : aliased Exception_Data := + (Not_Handled_By_Others => True, + Lang => 'A', + Name_Length => Abort_Signal_Name'Length, + Full_Name => Abort_Signal_Name'Address, + HTable_Ptr => null, + Foreign_Data => Null_Address, + Raise_Hook => null); + + pragma Export (C, Constraint_Error_Def, "constraint_error"); + pragma Export (C, Numeric_Error_Def, "numeric_error"); + pragma Export (C, Program_Error_Def, "program_error"); + pragma Export (C, Storage_Error_Def, "storage_error"); + pragma Export (C, Tasking_Error_Def, "tasking_error"); + pragma Export (C, Abort_Signal_Def, "_abort_signal"); + + Local_Partition_ID : Natural := 0; + -- This variable contains the local Partition_ID that will be used when + -- building exception occurrences. In distributed mode, it will be + -- set by each partition to the correct value during the elaboration. + + type Exception_Trace_Kind is + (RM_Convention, + -- No particular trace is requested, only unhandled exceptions + -- in the environment task (following the RM) will be printed. + -- This is the default behavior. + + Every_Raise, + -- Denotes the initial raise event for any exception occurrence, either + -- explicit or due to a specific language rule, within the context of a + -- task or not. + + Unhandled_Raise, + -- Denotes the raise events corresponding to exceptions for which there + -- is no user defined handler. This includes unhandled exceptions in + -- task bodies. + + Unhandled_Raise_In_Main + -- Same as Unhandled_Raise, except exceptions in task bodies are not + -- included. Same as RM_Convention, except (1) the message is printed as + -- soon as the environment task completes due to an unhandled exception + -- (before awaiting the termination of dependent tasks, and before + -- library-level finalization), and (2) a symbolic traceback is given + -- if possible. This is the default behavior if the binder switch -E is + -- used. + ); + -- Provide a way to denote different kinds of automatic traces related + -- to exceptions that can be requested. + + Exception_Trace : Exception_Trace_Kind := RM_Convention; + pragma Atomic (Exception_Trace); + -- By default, follow the RM convention + + ----------------- + -- Subprograms -- + ----------------- + + procedure Abort_Undefer_Direct; + pragma Inline (Abort_Undefer_Direct); + -- A little procedure that just calls Abort_Undefer.all, for use in + -- clean up procedures, which only permit a simple subprogram name. + + procedure Adafinal; + -- Performs the Ada Runtime finalization the first time it is invoked. + -- All subsequent calls are ignored. + +end System.Standard_Library; diff --git a/gcc/ada/libgnat/s-stausa.adb b/gcc/ada/libgnat/s-stausa.adb new file mode 100644 index 0000000..f652e7a --- /dev/null +++ b/gcc/ada/libgnat/s-stausa.adb @@ -0,0 +1,566 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M - S T A C K _ U S A G E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Parameters; +with System.CRTL; +with System.IO; + +package body System.Stack_Usage is + use System.Storage_Elements; + use System; + use System.IO; + use Interfaces; + + ----------------- + -- Stack_Slots -- + ----------------- + + -- Stackl_Slots is an internal data type to represent a sequence of real + -- stack slots initialized with a provided pattern, with operations to + -- abstract away the target call stack growth direction. + + type Stack_Slots is array (Integer range <>) of Pattern_Type; + for Stack_Slots'Component_Size use Pattern_Type'Object_Size; + + -- We will carefully handle the initializations ourselves and might want + -- to remap an initialized overlay later on with an address clause. + + pragma Suppress_Initialization (Stack_Slots); + + -- The abstract Stack_Slots operations all operate over the simple array + -- memory model: + + -- memory addresses increasing ----> + + -- Slots('First) Slots('Last) + -- | | + -- V V + -- +------------------------------------------------------------------+ + -- |####| |####| + -- +------------------------------------------------------------------+ + + -- What we call Top or Bottom always denotes call chain leaves or entry + -- points respectively, and their relative positions in the stack array + -- depends on the target stack growth direction: + + -- Stack_Grows_Down + + -- <----- calls push frames towards decreasing addresses + + -- Top(most) Slot Bottom(most) Slot + -- | | + -- V V + -- +------------------------------------------------------------------+ + -- |####| | leaf frame | ... | entry frame | + -- +------------------------------------------------------------------+ + + -- Stack_Grows_Up + + -- calls push frames towards increasing addresses -----> + + -- Bottom(most) Slot Top(most) Slot + -- | | + -- V V + -- +------------------------------------------------------------------+ + -- | entry frame | ... | leaf frame | |####| + -- +------------------------------------------------------------------+ + + ------------------- + -- Unit Services -- + ------------------- + + -- Now the implementation of the services offered by this unit, on top of + -- the Stack_Slots abstraction above. + + Index_Str : constant String := "Index"; + Task_Name_Str : constant String := "Task Name"; + Stack_Size_Str : constant String := "Stack Size"; + Actual_Size_Str : constant String := "Stack usage"; + + procedure Output_Result + (Result_Id : Natural; + Result : Task_Result; + Max_Stack_Size_Len : Natural; + Max_Actual_Use_Len : Natural); + -- Prints the result on the standard output. Result Id is the number of + -- the result in the array, and Result the contents of the actual result. + -- Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the + -- proper layout. They hold the maximum length of the string representing + -- the Stack_Size and Actual_Use values. + + ---------------- + -- Initialize -- + ---------------- + + procedure Initialize (Buffer_Size : Natural) is + Stack_Size_Chars : System.Address; + + begin + -- Initialize the buffered result array + + Result_Array := new Result_Array_Type (1 .. Buffer_Size); + Result_Array.all := + (others => + (Task_Name => (others => ASCII.NUL), + Value => 0, + Stack_Size => 0)); + + -- Set the Is_Enabled flag to true, so that the task wrapper knows that + -- it has to handle dynamic stack analysis + + Is_Enabled := True; + + Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL); + + -- If variable GNAT_STACK_LIMIT is set, then we will take care of the + -- environment task, using GNAT_STASK_LIMIT as the size of the stack. + -- It doesn't make sens to process the stack when no bound is set (e.g. + -- limit is typically up to 4 GB). + + if Stack_Size_Chars /= Null_Address then + declare + My_Stack_Size : Integer; + + begin + My_Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024; + + Initialize_Analyzer + (Environment_Task_Analyzer, + "ENVIRONMENT TASK", + My_Stack_Size, + 0, + My_Stack_Size); + + Fill_Stack (Environment_Task_Analyzer); + + Compute_Environment_Task := True; + end; + + -- GNAT_STACK_LIMIT not set + + else + Compute_Environment_Task := False; + end if; + end Initialize; + + ---------------- + -- Fill_Stack -- + ---------------- + + procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is + + -- Change the local variables and parameters of this function with + -- super-extra care. The more the stack frame size of this function is + -- big, the more an "instrumentation threshold at writing" error is + -- likely to happen. + + Current_Stack_Level : aliased Integer; + + Guard : constant := 256; + -- Guard space between the Current_Stack_Level'Address and the last + -- allocated byte on the stack. + begin + if Parameters.Stack_Grows_Down then + if Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size) > + To_Stack_Address (Current_Stack_Level'Address) - Guard + then + -- No room for a pattern + + Analyzer.Pattern_Size := 0; + return; + end if; + + Analyzer.Pattern_Limit := + Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size); + + if Analyzer.Stack_Base > + To_Stack_Address (Current_Stack_Level'Address) - Guard + then + -- Reduce pattern size to prevent local frame overwrite + + Analyzer.Pattern_Size := + Integer (To_Stack_Address (Current_Stack_Level'Address) - Guard + - Analyzer.Pattern_Limit); + end if; + + Analyzer.Pattern_Overlay_Address := + To_Address (Analyzer.Pattern_Limit); + else + if Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size) < + To_Stack_Address (Current_Stack_Level'Address) + Guard + then + -- No room for a pattern + + Analyzer.Pattern_Size := 0; + return; + end if; + + Analyzer.Pattern_Limit := + Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size); + + if Analyzer.Stack_Base < + To_Stack_Address (Current_Stack_Level'Address) + Guard + then + -- Reduce pattern size to prevent local frame overwrite + + Analyzer.Pattern_Size := + Integer + (Analyzer.Pattern_Limit - + (To_Stack_Address (Current_Stack_Level'Address) + Guard)); + end if; + + Analyzer.Pattern_Overlay_Address := + To_Address (Analyzer.Pattern_Limit - + Stack_Address (Analyzer.Pattern_Size)); + end if; + + -- Declare and fill the pattern buffer + + declare + Pattern : aliased Stack_Slots + (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + for Pattern'Address use Analyzer.Pattern_Overlay_Address; + + begin + if System.Parameters.Stack_Grows_Down then + for J in reverse Pattern'Range loop + Pattern (J) := Analyzer.Pattern; + end loop; + + else + for J in Pattern'Range loop + Pattern (J) := Analyzer.Pattern; + end loop; + end if; + end; + end Fill_Stack; + + ------------------------- + -- Initialize_Analyzer -- + ------------------------- + + procedure Initialize_Analyzer + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + Stack_Size : Natural; + Stack_Base : Stack_Address; + Pattern_Size : Natural; + Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#) + is + begin + -- Initialize the analyzer fields + + Analyzer.Stack_Base := Stack_Base; + Analyzer.Stack_Size := Stack_Size; + Analyzer.Pattern_Size := Pattern_Size; + Analyzer.Pattern := Pattern; + Analyzer.Result_Id := Next_Id; + Analyzer.Task_Name := (others => ' '); + + -- Compute the task name, and truncate if bigger than Task_Name_Length + + if Task_Name'Length <= Task_Name_Length then + Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name; + else + Analyzer.Task_Name := + Task_Name (Task_Name'First .. + Task_Name'First + Task_Name_Length - 1); + end if; + + Next_Id := Next_Id + 1; + end Initialize_Analyzer; + + ---------------- + -- Stack_Size -- + ---------------- + + function Stack_Size + (SP_Low : Stack_Address; + SP_High : Stack_Address) return Natural + is + begin + if SP_Low > SP_High then + return Natural (SP_Low - SP_High); + else + return Natural (SP_High - SP_Low); + end if; + end Stack_Size; + + -------------------- + -- Compute_Result -- + -------------------- + + procedure Compute_Result (Analyzer : in out Stack_Analyzer) is + + -- Change the local variables and parameters of this function with + -- super-extra care. The larger the stack frame size of this function + -- is, the more an "instrumentation threshold at reading" error is + -- likely to happen. + + Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); + for Stack'Address use Analyzer.Pattern_Overlay_Address; + + begin + -- Value if the pattern was not modified + + if Parameters.Stack_Grows_Down then + Analyzer.Topmost_Touched_Mark := + Analyzer.Pattern_Limit + Stack_Address (Analyzer.Pattern_Size); + else + Analyzer.Topmost_Touched_Mark := + Analyzer.Pattern_Limit - Stack_Address (Analyzer.Pattern_Size); + end if; + + if Analyzer.Pattern_Size = 0 then + return; + end if; + + -- Look backward from the topmost possible end of the marked stack to + -- the bottom of it. The first index not equals to the patterns marks + -- the beginning of the used stack. + + if System.Parameters.Stack_Grows_Down then + for J in Stack'Range loop + if Stack (J) /= Analyzer.Pattern then + Analyzer.Topmost_Touched_Mark := + To_Stack_Address (Stack (J)'Address); + exit; + end if; + end loop; + + else + for J in reverse Stack'Range loop + if Stack (J) /= Analyzer.Pattern then + Analyzer.Topmost_Touched_Mark := + To_Stack_Address (Stack (J)'Address); + exit; + end if; + end loop; + + end if; + end Compute_Result; + + --------------------- + -- Output_Result -- + --------------------- + + procedure Output_Result + (Result_Id : Natural; + Result : Task_Result; + Max_Stack_Size_Len : Natural; + Max_Actual_Use_Len : Natural) + is + Result_Id_Str : constant String := Natural'Image (Result_Id); + Stack_Size_Str : constant String := Natural'Image (Result.Stack_Size); + Actual_Use_Str : constant String := Natural'Image (Result.Value); + + Result_Id_Blanks : constant + String (1 .. Index_Str'Length - Result_Id_Str'Length) := + (others => ' '); + + Stack_Size_Blanks : constant + String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) := + (others => ' '); + + Actual_Use_Blanks : constant + String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) := + (others => ' '); + + begin + Set_Output (Standard_Error); + Put (Result_Id_Blanks & Natural'Image (Result_Id)); + Put (" | "); + Put (Result.Task_Name); + Put (" | "); + Put (Stack_Size_Blanks & Stack_Size_Str); + Put (" | "); + Put (Actual_Use_Blanks & Actual_Use_Str); + New_Line; + end Output_Result; + + --------------------- + -- Output_Results -- + --------------------- + + procedure Output_Results is + Max_Stack_Size : Natural := 0; + Max_Stack_Usage : Natural := 0; + Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0; + + Task_Name_Blanks : constant + String + (1 .. Task_Name_Length - Task_Name_Str'Length) := + (others => ' '); + + begin + Set_Output (Standard_Error); + + if Compute_Environment_Task then + Compute_Result (Environment_Task_Analyzer); + Report_Result (Environment_Task_Analyzer); + end if; + + if Result_Array'Length > 0 then + + -- Computes the size of the largest strings that will get displayed, + -- in order to do correct column alignment. + + for J in Result_Array'Range loop + exit when J >= Next_Id; + + if Result_Array (J).Value > Max_Stack_Usage then + Max_Stack_Usage := Result_Array (J).Value; + end if; + + if Result_Array (J).Stack_Size > Max_Stack_Size then + Max_Stack_Size := Result_Array (J).Stack_Size; + end if; + end loop; + + Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length; + + Max_Actual_Use_Len := Natural'Image (Max_Stack_Usage)'Length; + + -- Display the output header. Blanks will be added in front of the + -- labels if needed. + + declare + Stack_Size_Blanks : constant + String (1 .. Max_Stack_Size_Len - + Stack_Size_Str'Length) := + (others => ' '); + + Stack_Usage_Blanks : constant + String (1 .. Max_Actual_Use_Len - + Actual_Size_Str'Length) := + (others => ' '); + + begin + if Stack_Size_Str'Length > Max_Stack_Size_Len then + Max_Stack_Size_Len := Stack_Size_Str'Length; + end if; + + if Actual_Size_Str'Length > Max_Actual_Use_Len then + Max_Actual_Use_Len := Actual_Size_Str'Length; + end if; + + Put + (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | " + & Stack_Size_Str & Stack_Size_Blanks & " | " + & Stack_Usage_Blanks & Actual_Size_Str); + end; + + New_Line; + + -- Now display the individual results + + for J in Result_Array'Range loop + exit when J >= Next_Id; + Output_Result + (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len); + end loop; + + -- Case of no result stored, still display the labels + + else + Put + (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | " + & Stack_Size_Str & " | " & Actual_Size_Str); + New_Line; + end if; + end Output_Results; + + ------------------- + -- Report_Result -- + ------------------- + + procedure Report_Result (Analyzer : Stack_Analyzer) is + Result : Task_Result := (Task_Name => Analyzer.Task_Name, + Stack_Size => Analyzer.Stack_Size, + Value => 0); + begin + if Analyzer.Pattern_Size = 0 then + + -- If we have that result, it means that we didn't do any computation + -- at all (i.e. we used at least everything (and possibly more). + + Result.Value := Analyzer.Stack_Size; + + else + Result.Value := Stack_Size (Analyzer.Topmost_Touched_Mark, + Analyzer.Stack_Base); + end if; + + if Analyzer.Result_Id in Result_Array'Range then + + -- If the result can be stored, then store it in Result_Array + + Result_Array (Analyzer.Result_Id) := Result; + + else + -- If the result cannot be stored, then we display it right away + + declare + Result_Str_Len : constant Natural := + Natural'Image (Result.Value)'Length; + Size_Str_Len : constant Natural := + Natural'Image (Analyzer.Stack_Size)'Length; + + Max_Stack_Size_Len : Natural; + Max_Actual_Use_Len : Natural; + + begin + -- Take either the label size or the number image size for the + -- size of the column "Stack Size". + + Max_Stack_Size_Len := + (if Size_Str_Len > Stack_Size_Str'Length + then Size_Str_Len + else Stack_Size_Str'Length); + + -- Take either the label size or the number image size for the + -- size of the column "Stack Usage". + + Max_Actual_Use_Len := + (if Result_Str_Len > Actual_Size_Str'Length + then Result_Str_Len + else Actual_Size_Str'Length); + + Output_Result + (Analyzer.Result_Id, + Result, + Max_Stack_Size_Len, + Max_Actual_Use_Len); + end; + end if; + end Report_Result; + +end System.Stack_Usage; diff --git a/gcc/ada/libgnat/s-stausa.ads b/gcc/ada/libgnat/s-stausa.ads new file mode 100644 index 0000000..34615e2 --- /dev/null +++ b/gcc/ada/libgnat/s-stausa.ads @@ -0,0 +1,339 @@ +------------------------------------------------------------------------------ +-- -- +-- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M - S T A C K _ U S A G E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2004-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System; +with System.Storage_Elements; +with System.Address_To_Access_Conversions; +with Interfaces; + +package System.Stack_Usage is + pragma Preelaborate; + + package SSE renames System.Storage_Elements; + + subtype Stack_Address is SSE.Integer_Address; + -- Address on the stack + + function To_Stack_Address + (Value : System.Address) return Stack_Address + renames System.Storage_Elements.To_Integer; + + Task_Name_Length : constant := 32; + -- The maximum length of task name displayed. + -- ??? Consider merging this variable with Max_Task_Image_Length. + + type Task_Result is record + Task_Name : String (1 .. Task_Name_Length); + + Value : Natural; + -- Amount of stack used. The value is calculated on the basis of the + -- mechanism used by GNAT to allocate it, and it is NOT a precise value. + + Stack_Size : Natural; + -- Size of the stack + end record; + + type Result_Array_Type is array (Positive range <>) of Task_Result; + + type Stack_Analyzer is private; + -- Type of the stack analyzer tool. It is used to fill a portion of the + -- stack with Pattern, and to compute the stack used after some execution. + + -- Usage: + + -- A typical use of the package is something like: + + -- A : Stack_Analyzer; + + -- task T is + -- pragma Storage_Size (A_Storage_Size); + -- end T; + + -- [...] + + -- Bottom_Of_Stack : aliased Integer; + -- -- Bottom_Of_Stack'Address will be used as an approximation of + -- -- the bottom of stack. A good practise is to avoid allocating + -- -- other local variables on this stack, as it would degrade + -- -- the quality of this approximation. + + -- begin + -- Initialize_Analyzer (A, + -- "Task t", + -- A_Storage_Size, + -- 0, + -- A_Storage_Size - A_Guard, + -- To_Stack_Address (Bottom_Of_Stack'Address)); + -- Fill_Stack (A); + -- Some_User_Code; + -- Compute_Result (A); + -- Report_Result (A); + -- end T; + + -- Errors: + -- + -- We are instrumenting the code to measure the stack used by the user + -- code. This method has a number of systematic errors, but several methods + -- can be used to evaluate or reduce those errors. Here are those errors + -- and the strategy that we use to deal with them: + + -- Bottom offset: + + -- Description: The procedure used to fill the stack with a given + -- pattern will itself have a stack frame. The value of the stack + -- pointer in this procedure is, therefore, different from the value + -- before the call to the instrumentation procedure. + + -- Strategy: The user of this package should measure the bottom of stack + -- before the call to Fill_Stack and pass it in parameter. The impact + -- is very minor unless the stack used is very small, but in this case + -- you aren't very interested by the figure. + + -- Instrumentation threshold at writing: + + -- Description: The procedure used to fill the stack with a given + -- pattern will itself have a stack frame. Therefore, it will + -- fill the stack after this stack frame. This part of the stack will + -- appear as used in the final measure. + + -- Strategy: As the user passes the value of the bottom of stack to + -- the instrumentation to deal with the bottom offset error, and as + -- the instrumentation procedure knows where the pattern filling start + -- on the stack, the difference between the two values is the minimum + -- stack usage that the method can measure. If, when the results are + -- computed, the pattern zone has been left untouched, we conclude + -- that the stack usage is inferior to this minimum stack usage. + + -- Instrumentation threshold at reading: + + -- Description: The procedure used to read the stack at the end of the + -- execution clobbers the stack by allocating its stack frame. If this + -- stack frame is bigger than the total stack used by the user code at + -- this point, it will increase the measured stack size. + + -- Strategy: We could augment this stack frame and see if it changes the + -- measure. However, this error should be negligible. + + -- Pattern zone overflow: + + -- Description: The stack grows outer than the topmost bound of the + -- pattern zone. In that case, the topmost region modified in the + -- pattern is not the maximum value of the stack pointer during the + -- execution. + + -- Strategy: At the end of the execution, the difference between the + -- topmost memory region modified in the pattern zone and the + -- topmost bound of the pattern zone can be understood as the + -- biggest allocation that the method could have detect, provided + -- that there is no "Untouched allocated zone" error and no "Pattern + -- usage in user code" error. If no object in the user code is likely + -- to have this size, this is not likely to happen. + + -- Pattern usage in user code: + + -- Description: The pattern can be found in the object of the user code. + -- Therefore, the address space where this object has been allocated + -- will appear as untouched. + + -- Strategy: Choose a pattern that is uncommon. 16#0000_0000# is the + -- worst choice; 16#DEAD_BEEF# can be a good one. A good choice is an + -- address which is not a multiple of 2, and which is not in the + -- target address space. You can also change the pattern to see if it + -- changes the measure. Note that this error *very* rarely influence + -- the measure of the total stack usage: to have some influence, the + -- pattern has to be used in the object that has been allocated on the + -- topmost address of the used stack. + + -- Stack overflow: + + -- Description: The pattern zone does not fit on the stack. This may + -- lead to an erroneous execution. + + -- Strategy: Specify a storage size that is bigger than the size of the + -- pattern. 2 times bigger should be enough. + + -- Augmentation of the user stack frames: + + -- Description: The use of instrumentation object or procedure may + -- augment the stack frame of the caller. + + -- Strategy: Do *not* inline the instrumentation procedures. Do *not* + -- allocate the Stack_Analyzer object on the stack. + + -- Untouched allocated zone: + + -- Description: The user code may allocate objects that it will never + -- touch. In that case, the pattern will not be changed. + + -- Strategy: There are no way to detect this error. Fortunately, this + -- error is really rare, and it is most probably a bug in the user + -- code, e.g. some uninitialized variable. It is (most of the time) + -- harmless: it influences the measure only if the untouched allocated + -- zone happens to be located at the topmost value of the stack + -- pointer for the whole execution. + + procedure Initialize (Buffer_Size : Natural); + pragma Export (C, Initialize, "__gnat_stack_usage_initialize"); + -- Initializes the size of the buffer that stores the results. Only the + -- first Buffer_Size results are stored. Any results that do not fit in + -- this buffer will be displayed on the fly. + + procedure Fill_Stack (Analyzer : in out Stack_Analyzer); + -- Fill an area of the stack with the pattern Analyzer.Pattern. The size + -- of this area is Analyzer.Size. After the call to this procedure, + -- the memory will look like that: + -- + -- Stack growing + -- ----------------------------------------------------------------------> + -- |<--------------------->|<----------------------------------->| + -- | Stack frames to | Memory filled with Analyzer.Pattern | + -- | Fill_Stack | | + -- ^ | ^ + -- Analyzer.Stack_Base | Analyzer.Pattern_Limit + -- ^ + -- Analyzer.Pattern_Limit +/- Analyzer.Pattern_Size + -- + + procedure Initialize_Analyzer + (Analyzer : in out Stack_Analyzer; + Task_Name : String; + Stack_Size : Natural; + Stack_Base : Stack_Address; + Pattern_Size : Natural; + Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); + -- Should be called before any use of a Stack_Analyzer, to initialize it. + -- Max_Pattern_Size is the size of the pattern zone, might be smaller than + -- the full stack size Stack_Size in order to take into account e.g. the + -- secondary stack and a guard against overflow. The actual size taken + -- will be readjusted with data already used at the time the stack is + -- actually filled. + + Is_Enabled : Boolean := False; + -- When this flag is true, then stack analysis is enabled + + procedure Compute_Result (Analyzer : in out Stack_Analyzer); + -- Read the pattern zone and deduce the stack usage. It should be called + -- from the same frame as Fill_Stack. If Analyzer.Probe is not null, an + -- array of Unsigned_32 with Analyzer.Probe elements is allocated on + -- Compute_Result's stack frame. Probe can be used to detect the error: + -- "instrumentation threshold at reading". See above. After the call + -- to this procedure, the memory will look like: + -- + -- Stack growing + -- -----------------------------------------------------------------------> + -- |<---------------------->|<-------------->|<--------->|<--------->| + -- | Stack frames | Array of | used | Memory | + -- | to Compute_Result | Analyzer.Probe | during | filled | + -- | | elements | the | with | + -- | | | execution | pattern | + -- | | | + -- |<----------------------------------------------------> | + -- Stack used ^ + -- Pattern_Limit + + procedure Report_Result (Analyzer : Stack_Analyzer); + -- Store the results of the computation in memory, at the address + -- corresponding to the symbol __gnat_stack_usage_results. This is not + -- done inside Compute_Result in order to use as less stack as possible + -- within a task. + + procedure Output_Results; + -- Print the results computed so far on the standard output. Should be + -- called when all tasks are dead. + + pragma Export (C, Output_Results, "__gnat_stack_usage_output_results"); + +private + + package Unsigned_32_Addr is + new System.Address_To_Access_Conversions (Interfaces.Unsigned_32); + + subtype Pattern_Type is Interfaces.Unsigned_32; + Bytes_Per_Pattern : constant := Pattern_Type'Object_Size / Storage_Unit; + + type Stack_Analyzer is record + Task_Name : String (1 .. Task_Name_Length); + -- Name of the task + + Stack_Base : Stack_Address; + -- Address of the base of the stack, as given by the caller of + -- Initialize_Analyzer. + + Stack_Size : Natural; + -- Entire size of the analyzed stack + + Pattern_Size : Natural; + -- Size of the pattern zone + + Pattern : Pattern_Type; + -- Pattern used to recognize untouched memory + + Pattern_Limit : Stack_Address; + -- Bound of the pattern area farthest to the base + + Topmost_Touched_Mark : Stack_Address; + -- Topmost address of the pattern area whose value it is pointing + -- at has been modified during execution. If the systematic error are + -- compensated, it is the topmost value of the stack pointer during + -- the execution. + + Pattern_Overlay_Address : System.Address; + -- Address of the stack abstraction object we overlay over a + -- task's real stack, typically a pattern-initialized array. + + Result_Id : Positive; + -- Id of the result. If less than value given to gnatbind -u corresponds + -- to the location in the result array of result for the current task. + end record; + + Environment_Task_Analyzer : Stack_Analyzer; + + Compute_Environment_Task : Boolean; + + type Result_Array_Ptr is access all Result_Array_Type; + + Result_Array : Result_Array_Ptr; + pragma Export (C, Result_Array, "__gnat_stack_usage_results"); + -- Exported in order to have an easy accessible symbol in when debugging + + Next_Id : Positive := 1; + -- Id of the next stack analyzer + + function Stack_Size + (SP_Low : Stack_Address; + SP_High : Stack_Address) return Natural; + pragma Inline (Stack_Size); + -- Return the size of a portion of stack delimited by SP_High and SP_Low + -- (), i.e. the difference between SP_High and SP_Low. The storage element + -- pointed by SP_Low is not included in the size. Inlined to reduce the + -- size of the stack used by the instrumentation code. + +end System.Stack_Usage; diff --git a/gcc/ada/libgnat/s-stchop-limit.ads b/gcc/ada/libgnat/s-stchop-limit.ads new file mode 100644 index 0000000..6ab2f0a --- /dev/null +++ b/gcc/ada/libgnat/s-stchop-limit.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of this package is for implementations which use +-- the stack limit approach (the limit of the stack is stored into a per +-- thread variable). + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the binder +-- does not handle references to this package. + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during stack +-- checking operations. It causes infinite loops and other problems. + +package System.Stack_Checking.Operations is + pragma Preelaborate; + + procedure Initialize_Stack_Limit; + pragma Export (C, Initialize_Stack_Limit, + "__gnat_initialize_stack_limit"); + -- This procedure is called before elaboration to setup the stack limit + -- for the environment task and to register the hook to be called at + -- task creation. +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop-rtems.adb b/gcc/ada/libgnat/s-stchop-rtems.adb new file mode 100644 index 0000000..ac0cfd0 --- /dev/null +++ b/gcc/ada/libgnat/s-stchop-rtems.adb @@ -0,0 +1,113 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2009, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the RTEMS version of this package. +-- This file should be kept synchronized with the general implementation +-- provided by s-stchop.adb. + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the +-- binder does not handle references to this package. + +with Ada.Exceptions; + +with Interfaces.C; use Interfaces.C; + +package body System.Stack_Checking.Operations is + + ---------------------------- + -- Invalidate_Stack_Cache -- + ---------------------------- + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is + pragma Warnings (Off, Any_Stack); + begin + Cache := Null_Stack; + end Invalidate_Stack_Cache; + + ----------------------------- + -- Notify_Stack_Attributes -- + ----------------------------- + + procedure Notify_Stack_Attributes + (Initial_SP : System.Address; + Size : System.Storage_Elements.Storage_Offset) + is + + -- RTEMS keeps all the information we need. + + pragma Unreferenced (Size); + pragma Unreferenced (Initial_SP); + + begin + null; + end Notify_Stack_Attributes; + + ----------------- + -- Stack_Check -- + ----------------- + + function Stack_Check + (Stack_Address : System.Address) return Stack_Access + is + pragma Unreferenced (Stack_Address); + + -- RTEMS has a routine to check if the stack is blown. + -- It returns a C99 bool. + function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char; + pragma Import (C, + rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); + + begin + -- RTEMS has a routine to check this. So use it. + + if rtems_stack_checker_is_blown /= 0 then + Ada.Exceptions.Raise_Exception + (E => Storage_Error'Identity, + Message => "stack overflow detected"); + end if; + + return null; + + end Stack_Check; + + ------------------------ + -- Update_Stack_Cache -- + ------------------------ + + procedure Update_Stack_Cache (Stack : Stack_Access) is + begin + if not Multi_Processor then + Cache := Stack; + end if; + end Update_Stack_Cache; + +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop-vxworks.adb b/gcc/ada/libgnat/s-stchop-vxworks.adb new file mode 100644 index 0000000..25b07db --- /dev/null +++ b/gcc/ada/libgnat/s-stchop-vxworks.adb @@ -0,0 +1,145 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the verson for VxWorks 5, VxWorks 6 Cert and VxWorks MILS + +-- This file should be kept synchronized with the general implementation +-- provided by s-stchop.adb. + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the +-- binder does not handle references to this package. + +with System.Storage_Elements; use System.Storage_Elements; +with System.Parameters; use System.Parameters; +with Interfaces.C; + +package body System.Stack_Checking.Operations is + + -- In order to have stack checking working appropriately on VxWorks we need + -- to extract the stack size information from the VxWorks kernel itself. + + -- For VxWorks 5 & 6 the library for showing task-related information + -- needs to be linked into the VxWorks system, when using stack checking. + -- The taskShow library can be linked into the VxWorks system by either: + + -- * defining INCLUDE_SHOW_ROUTINES in config.h when using + -- configuration header files, or + + -- * selecting INCLUDE_TASK_SHOW when using the Tornado project + -- facility. + + -- VxWorks MILS includes the necessary routine in taskLib, so nothing + -- special needs to be done there. + + Stack_Limit : Address; + + pragma Import (C, Stack_Limit, "__gnat_stack_limit"); + + -- Stack_Limit contains the limit of the stack. This variable is later made + -- a task variable (by calling taskVarAdd) and then correctly set to the + -- stack limit of the task. Before being so initialized its value must be + -- valid so that any subprogram with stack checking enabled will run. We + -- use extreme values according to the direction of the stack. + + type Set_Stack_Limit_Proc_Acc is access procedure; + pragma Convention (C, Set_Stack_Limit_Proc_Acc); + + Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; + pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); + -- Procedure to be called when a task is created to set stack + -- limit. + + procedure Set_Stack_Limit_For_Current_Task; + pragma Convention (C, Set_Stack_Limit_For_Current_Task); + -- Register Initial_SP as the initial stack pointer value for the current + -- task when it starts and Size as the associated stack area size. This + -- should be called once, after the soft-links have been initialized? + + ----------------------------- + -- Initialize_Stack_Limit -- + ----------------------------- + + procedure Initialize_Stack_Limit is + begin + + Set_Stack_Limit_For_Current_Task; + + -- Will be called by every created task + + Set_Stack_Limit_Hook := Set_Stack_Limit_For_Current_Task'Access; + end Initialize_Stack_Limit; + + -------------------------------------- + -- Set_Stack_Limit_For_Current_Task -- + -------------------------------------- + + procedure Set_Stack_Limit_For_Current_Task is + use Interfaces.C; + + type OS_Stack_Info is record + Size : Interfaces.C.int; + Base : System.Address; + Limit : System.Address; + end record; + pragma Convention (C, OS_Stack_Info); + -- Type representing the information that we want to extract from the + -- underlying kernel. + + procedure Get_Stack_Info (Stack : not null access OS_Stack_Info); + pragma Import (C, Get_Stack_Info, "__gnat_get_stack_info"); + -- Procedure that fills the stack information associated to the + -- currently executing task. + + Stack_Info : aliased OS_Stack_Info; + + Limit : System.Address; + + begin + + -- Get stack bounds from VxWorks + + Get_Stack_Info (Stack_Info'Access); + + if Stack_Grows_Down then + Limit := + Stack_Info.Base - Storage_Offset (Stack_Info.Size) + + Storage_Offset'(12_000); + else + Limit := + Stack_Info.Base + Storage_Offset (Stack_Info.Size) - + Storage_Offset'(12_000); + end if; + + Stack_Limit := Limit; + + end Set_Stack_Limit_For_Current_Task; +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop.adb b/gcc/ada/libgnat/s-stchop.adb new file mode 100644 index 0000000..3bae051 --- /dev/null +++ b/gcc/ada/libgnat/s-stchop.adb @@ -0,0 +1,279 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the general implementation of this package. There is a VxWorks +-- specific version of this package (s-stchop-vxworks.adb). This file should +-- be kept synchronized with it. + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the +-- binder does not handle references to this package. + +with System.Storage_Elements; use System.Storage_Elements; +with System.Parameters; use System.Parameters; +with System.Soft_Links; +with System.CRTL; + +package body System.Stack_Checking.Operations is + + Kilobyte : constant := 1024; + + function Set_Stack_Info + (Stack : not null access Stack_Access) return Stack_Access; + -- The function Set_Stack_Info is the actual function that updates the + -- cache containing a pointer to the Stack_Info. It may also be used for + -- detecting asynchronous abort in combination with Invalidate_Self_Cache. + -- + -- Set_Stack_Info should do the following things in order: + -- 1) Get the Stack_Access value for the current task + -- 2) Set Stack.all to the value obtained in 1) + -- 3) Optionally Poll to check for asynchronous abort + -- + -- This order is important because if at any time a write to the stack + -- cache is pending, that write should be followed by a Poll to prevent + -- losing signals. + -- + -- Note: This function must be compiled with Polling turned off + -- + -- Note: on systems with real thread-local storage, Set_Stack_Info should + -- return an access value for such local storage. In those cases the cache + -- will always be up-to-date. + + ---------------------------- + -- Invalidate_Stack_Cache -- + ---------------------------- + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is + pragma Warnings (Off, Any_Stack); + begin + Cache := Null_Stack; + end Invalidate_Stack_Cache; + + ----------------------------- + -- Notify_Stack_Attributes -- + ----------------------------- + + procedure Notify_Stack_Attributes + (Initial_SP : System.Address; + Size : System.Storage_Elements.Storage_Offset) + is + My_Stack : constant Stack_Access := Soft_Links.Get_Stack_Info.all; + + -- We piggyback on the 'Limit' field to store what will be used as the + -- 'Base' and leave the 'Size' alone to not interfere with the logic in + -- Set_Stack_Info below. + + pragma Unreferenced (Size); + + begin + My_Stack.Limit := Initial_SP; + end Notify_Stack_Attributes; + + -------------------- + -- Set_Stack_Info -- + -------------------- + + function Set_Stack_Info + (Stack : not null access Stack_Access) return Stack_Access + is + type Frame_Mark is null record; + Frame_Location : Frame_Mark; + Frame_Address : constant Address := Frame_Location'Address; + + My_Stack : Stack_Access; + Limit_Chars : System.Address; + Limit : Integer; + + begin + -- The order of steps 1 .. 3 is important, see specification + + -- 1) Get the Stack_Access value for the current task + + My_Stack := Soft_Links.Get_Stack_Info.all; + + if My_Stack.Base = Null_Address then + + -- First invocation, initialize based on the assumption that there + -- are Environment_Stack_Size bytes available beyond the current + -- frame address. + + if My_Stack.Size = 0 then + My_Stack.Size := Storage_Offset (Default_Env_Stack_Size); + + -- When the environment variable GNAT_STACK_LIMIT is set, set + -- Environment_Stack_Size to that number of kB. + + Limit_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL); + + if Limit_Chars /= Null_Address then + Limit := System.CRTL.atoi (Limit_Chars); + + if Limit >= 0 then + My_Stack.Size := Storage_Offset (Limit) * Kilobyte; + end if; + end if; + end if; + + -- If a stack base address has been registered, honor it. Fallback to + -- the address of a local object otherwise. + + My_Stack.Base := + (if My_Stack.Limit /= System.Null_Address + then My_Stack.Limit else Frame_Address); + + if Stack_Grows_Down then + + -- Prevent wrap-around on too big stack sizes + + My_Stack.Limit := My_Stack.Base - My_Stack.Size; + + if My_Stack.Limit > My_Stack.Base then + My_Stack.Limit := Address'First; + end if; + + else + My_Stack.Limit := My_Stack.Base + My_Stack.Size; + + -- Prevent wrap-around on too big stack sizes + + if My_Stack.Limit < My_Stack.Base then + My_Stack.Limit := Address'Last; + end if; + end if; + end if; + + -- 2) Set Stack.all to the value obtained in 1) + + Stack.all := My_Stack; + + -- 3) Optionally Poll to check for asynchronous abort + + if Soft_Links.Check_Abort_Status.all /= 0 then + raise Standard'Abort_Signal; + end if; + + -- Never trust the cached value, but return local copy + + return My_Stack; + end Set_Stack_Info; + + ----------------- + -- Stack_Check -- + ----------------- + + function Stack_Check + (Stack_Address : System.Address) return Stack_Access + is + type Frame_Marker is null record; + Marker : Frame_Marker; + Cached_Stack : constant Stack_Access := Cache; + Frame_Address : constant System.Address := Marker'Address; + + begin + -- The parameter may have wrapped around in System.Address arithmetics. + -- In that case, we have no other choices than raising the exception. + + if (Stack_Grows_Down and then + Stack_Address > Frame_Address) + or else + (not Stack_Grows_Down and then + Stack_Address < Frame_Address) + then + raise Storage_Error with "stack overflow detected"; + end if; + + -- This function first does a "cheap" check which is correct if it + -- succeeds. In case of failure, the full check is done. Ideally the + -- cheap check should be done in an optimized manner, or be inlined. + + if (Stack_Grows_Down and then + (Frame_Address <= Cached_Stack.Base + and then + Stack_Address > Cached_Stack.Limit)) + or else + (not Stack_Grows_Down and then + (Frame_Address >= Cached_Stack.Base + and then + Stack_Address < Cached_Stack.Limit)) + then + -- Cached_Stack is valid as it passed the stack check + + return Cached_Stack; + end if; + + Full_Check : + declare + My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access); + -- At this point Stack.all might already be invalid, so + -- it is essential to use our local copy of Stack. + + begin + if (Stack_Grows_Down and then + (not (Frame_Address <= My_Stack.Base))) + or else + (not Stack_Grows_Down and then + (not (Frame_Address >= My_Stack.Base))) + then + -- The returned Base is lower than the stored one, so assume that + -- the original one wasn't right and use the current Frame_Address + -- as new one. This allows Base to be initialized with the + -- Frame_Address as approximation. During initialization the + -- Frame_Address will be close to the stack base anyway: the + -- difference should be compensated for in the stack reserve. + + My_Stack.Base := Frame_Address; + end if; + + if (Stack_Grows_Down + and then Stack_Address < My_Stack.Limit) + or else + (not Stack_Grows_Down + and then Stack_Address > My_Stack.Limit) + then + raise Storage_Error with "stack overflow detected"; + end if; + + return My_Stack; + end Full_Check; + end Stack_Check; + + ------------------------ + -- Update_Stack_Cache -- + ------------------------ + + procedure Update_Stack_Cache (Stack : Stack_Access) is + begin + if not Multi_Processor then + Cache := Stack; + end if; + end Update_Stack_Cache; + +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stchop.ads b/gcc/ada/libgnat/s-stchop.ads new file mode 100644 index 0000000..16a3939 --- /dev/null +++ b/gcc/ada/libgnat/s-stchop.ads @@ -0,0 +1,82 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNARL was developed by the GNARL team at Florida State University. -- +-- Extensive contributions were provided by Ada Core Technologies, Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides a implementation of stack checking operations using +-- comparison with stack base and limit. + +pragma Restrictions (No_Elaboration_Code); +-- We want to guarantee the absence of elaboration code because the binder +-- does not handle references to this package. + +pragma Polling (Off); +-- Turn off polling, we do not want polling to take place during stack +-- checking operations. It causes infinite loops and other problems. + +with System.Storage_Elements; + +package System.Stack_Checking.Operations is + pragma Preelaborate; + + procedure Update_Stack_Cache (Stack : Stack_Access); + -- Set the stack cache for the current task. Note that this is only for + -- optimization purposes, nothing can be assumed about the contents of the + -- cache at any time, see Set_Stack_Info. + -- + -- The stack cache should contain the bounds of the current task. But + -- because the RTS is not aware of task switches, the stack cache may be + -- incorrect. So when the stack pointer is not within the bounds of the + -- stack cache, Stack_Check first update the cache (which is a costly + -- operation hence the need of a cache). + + procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access); + -- Invalidate cache entries for the task T that owns Any_Stack. This causes + -- the Set_Stack_Info function to be called during the next stack check + -- done by T. This can be used to interrupt task T asynchronously. + -- Stack_Check should be called in loops for this to work reliably. + + function Stack_Check (Stack_Address : System.Address) return Stack_Access; + -- This version of Stack_Check should not be inlined + + procedure Notify_Stack_Attributes + (Initial_SP : System.Address; + Size : System.Storage_Elements.Storage_Offset); + -- Register Initial_SP as the initial stack pointer value for the current + -- task when it starts and Size as the associated stack area size. This + -- should be called once, after the soft-links have been initialized and + -- prior to the first "Stack_Check" call. + +private + Cache : aliased Stack_Access := Null_Stack; + + pragma Export (C, Cache, "_gnat_stack_cache"); + pragma Export (C, Stack_Check, "_gnat_stack_check"); + +end System.Stack_Checking.Operations; diff --git a/gcc/ada/libgnat/s-stoele.adb b/gcc/ada/libgnat/s-stoele.adb new file mode 100644 index 0000000..e517f70 --- /dev/null +++ b/gcc/ada/libgnat/s-stoele.adb @@ -0,0 +1,131 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ E L E M E N T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Conversion; + +package body System.Storage_Elements is + + pragma Suppress (All_Checks); + + -- Conversion to/from address + + -- Note qualification below of To_Address to avoid ambiguities systems + -- where Address is a visible integer type. + + function To_Address is + new Ada.Unchecked_Conversion (Storage_Offset, Address); + function To_Offset is + new Ada.Unchecked_Conversion (Address, Storage_Offset); + + -- Conversion to/from integers + + -- These functions must be place first because they are inlined_always + -- and are used and inlined in other subprograms defined in this unit. + + ---------------- + -- To_Address -- + ---------------- + + function To_Address (Value : Integer_Address) return Address is + begin + return Address (Value); + end To_Address; + + ---------------- + -- To_Integer -- + ---------------- + + function To_Integer (Value : Address) return Integer_Address is + begin + return Integer_Address (Value); + end To_Integer; + + -- Address arithmetic + + --------- + -- "+" -- + --------- + + function "+" (Left : Address; Right : Storage_Offset) return Address is + begin + return Storage_Elements.To_Address + (To_Integer (Left) + To_Integer (To_Address (Right))); + end "+"; + + function "+" (Left : Storage_Offset; Right : Address) return Address is + begin + return Storage_Elements.To_Address + (To_Integer (To_Address (Left)) + To_Integer (Right)); + end "+"; + + --------- + -- "-" -- + --------- + + function "-" (Left : Address; Right : Storage_Offset) return Address is + begin + return Storage_Elements.To_Address + (To_Integer (Left) - To_Integer (To_Address (Right))); + end "-"; + + function "-" (Left, Right : Address) return Storage_Offset is + begin + return To_Offset (Storage_Elements.To_Address + (To_Integer (Left) - To_Integer (Right))); + end "-"; + + ----------- + -- "mod" -- + ----------- + + function "mod" + (Left : Address; + Right : Storage_Offset) return Storage_Offset + is + begin + if Right > 0 then + return Storage_Offset + (To_Integer (Left) mod Integer_Address (Right)); + + -- The negative case makes no sense since it is a case of a mod where + -- the left argument is unsigned and the right argument is signed. In + -- accordance with the (spirit of the) permission of RM 13.7.1(16), + -- we raise CE, and also include the zero case here. Yes, the RM says + -- PE, but this really is so obviously more like a constraint error. + + else + raise Constraint_Error; + end if; + end "mod"; + +end System.Storage_Elements; diff --git a/gcc/ada/libgnat/s-stoele.ads b/gcc/ada/libgnat/s-stoele.ads new file mode 100644 index 0000000..c553540 --- /dev/null +++ b/gcc/ada/libgnat/s-stoele.ads @@ -0,0 +1,117 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ E L E M E N T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. The copyright notice above, and the license provisions that follow -- +-- apply solely to the implementation dependent sections of this file. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Warning: declarations in this package are ambiguous with respect to the +-- extra declarations that can be introduced into System using Extend_System. +-- It is a good idea to avoid use clauses for this package. + +pragma Compiler_Unit_Warning; + +package System.Storage_Elements is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, + -- this is Pure in any case (AI-362). + + -- We also add the pragma Pure_Function to the operations in this package, + -- because otherwise functions with parameters derived from Address are + -- treated as non-pure by the back-end (see exp_ch6.adb). This is because + -- in many cases such a parameter is used to hide read/out access to + -- objects, and it would be unsafe to treat such functions as pure. + + type Storage_Offset is range + -(2 ** (Integer'(Standard'Address_Size) - 1)) .. + +(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1); + -- Note: the reason for the Long_Long_Integer qualification here is to + -- avoid a bogus ambiguity when this unit is analyzed in an rtsfind + -- context. It may be possible to remove this in the future, but it is + -- certainly harmless in any case ??? + + subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last; + + type Storage_Element is mod 2 ** Storage_Unit; + for Storage_Element'Size use Storage_Unit; + + pragma Universal_Aliasing (Storage_Element); + -- This type is used by the expander to implement aggregate copy + + type Storage_Array is + array (Storage_Offset range <>) of aliased Storage_Element; + for Storage_Array'Component_Size use Storage_Unit; + + -- Address arithmetic + + function "+" (Left : Address; Right : Storage_Offset) return Address; + pragma Convention (Intrinsic, "+"); + pragma Inline_Always ("+"); + pragma Pure_Function ("+"); + + function "+" (Left : Storage_Offset; Right : Address) return Address; + pragma Convention (Intrinsic, "+"); + pragma Inline_Always ("+"); + pragma Pure_Function ("+"); + + function "-" (Left : Address; Right : Storage_Offset) return Address; + pragma Convention (Intrinsic, "-"); + pragma Inline_Always ("-"); + pragma Pure_Function ("-"); + + function "-" (Left, Right : Address) return Storage_Offset; + pragma Convention (Intrinsic, "-"); + pragma Inline_Always ("-"); + pragma Pure_Function ("-"); + + function "mod" + (Left : Address; + Right : Storage_Offset) return Storage_Offset; + pragma Convention (Intrinsic, "mod"); + pragma Inline_Always ("mod"); + pragma Pure_Function ("mod"); + + -- Conversion to/from integers + + type Integer_Address is mod Memory_Size; + + function To_Address (Value : Integer_Address) return Address; + pragma Convention (Intrinsic, To_Address); + pragma Inline_Always (To_Address); + pragma Pure_Function (To_Address); + + function To_Integer (Value : Address) return Integer_Address; + pragma Convention (Intrinsic, To_Integer); + pragma Inline_Always (To_Integer); + pragma Pure_Function (To_Integer); + +end System.Storage_Elements; diff --git a/gcc/ada/libgnat/s-stopoo.adb b/gcc/ada/libgnat/s-stopoo.adb new file mode 100644 index 0000000..1033f86 --- /dev/null +++ b/gcc/ada/libgnat/s-stopoo.adb @@ -0,0 +1,62 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ P O O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Storage_Pools is + + ------------------ + -- Allocate_Any -- + ------------------ + + procedure Allocate_Any + (Pool : in out Root_Storage_Pool'Class; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is + begin + Allocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment); + end Allocate_Any; + + -------------------- + -- Deallocate_Any -- + -------------------- + + procedure Deallocate_Any + (Pool : in out Root_Storage_Pool'Class; + Storage_Address : System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is + begin + Deallocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment); + end Deallocate_Any; + +end System.Storage_Pools; diff --git a/gcc/ada/libgnat/s-stopoo.ads b/gcc/ada/libgnat/s-stopoo.ads new file mode 100644 index 0000000..4d5ce9b --- /dev/null +++ b/gcc/ada/libgnat/s-stopoo.ads @@ -0,0 +1,100 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ P O O L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System.Storage_Elements; + +package System.Storage_Pools is + pragma Preelaborate; + + type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with private; + pragma Preelaborable_Initialization (Root_Storage_Pool); + + procedure Allocate + (Pool : in out Root_Storage_Pool; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is abstract; + + procedure Deallocate + (Pool : in out Root_Storage_Pool; + Storage_Address : System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is abstract; + + function Storage_Size + (Pool : Root_Storage_Pool) + return System.Storage_Elements.Storage_Count + is abstract; + +private + type Root_Storage_Pool is abstract + new Ada.Finalization.Limited_Controlled with null record; + + type Root_Storage_Pool_Ptr is access all Root_Storage_Pool'Class; + for Root_Storage_Pool_Ptr'Storage_Size use 0; + -- Type of the BIP_Storage_Pool extra parameter (see Exp_Ch6). The + -- Storage_Size clause is necessary, because otherwise we have a + -- chicken&egg problem; we can't be creating collection finalization code + -- in this low-level package, because that involves Pool_Global, which + -- imports this package. + + -- ??? Are these two still needed? It might be possible to use Subpools. + -- Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled + -- objects. + + -- The following two procedures support the use of class-wide pool + -- objects in storage pools. When a local type is given a class-wide + -- storage pool, allocation and deallocation for the type must dispatch + -- to the operation of the specific pool, which is achieved by a call + -- to these procedures. (When the pool type is specific, the back-end + -- generates a call to the statically identified operation of the type). + + procedure Allocate_Any + (Pool : in out Root_Storage_Pool'Class; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + + procedure Deallocate_Any + (Pool : in out Root_Storage_Pool'Class; + Storage_Address : System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + +end System.Storage_Pools; diff --git a/gcc/ada/libgnat/s-stposu.adb b/gcc/ada/libgnat/s-stposu.adb new file mode 100644 index 0000000..abf2013 --- /dev/null +++ b/gcc/ada/libgnat/s-stposu.adb @@ -0,0 +1,828 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Exceptions; use Ada.Exceptions; +with Ada.Unchecked_Conversion; + +with System.Address_Image; +with System.Finalization_Masters; use System.Finalization_Masters; +with System.IO; use System.IO; +with System.Soft_Links; use System.Soft_Links; +with System.Storage_Elements; use System.Storage_Elements; + +with System.Storage_Pools.Subpools.Finalization; +use System.Storage_Pools.Subpools.Finalization; + +package body System.Storage_Pools.Subpools is + + Finalize_Address_Table_In_Use : Boolean := False; + -- This flag should be set only when a successful allocation on a subpool + -- has been performed and the associated Finalize_Address has been added to + -- the hash table in System.Finalization_Masters. + + function Address_To_FM_Node_Ptr is + new Ada.Unchecked_Conversion (Address, FM_Node_Ptr); + + procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr); + -- Attach a subpool node to a pool + + ----------------------------------- + -- Adjust_Controlled_Dereference -- + ----------------------------------- + + procedure Adjust_Controlled_Dereference + (Addr : in out System.Address; + Storage_Size : in out System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is + Header_And_Padding : constant Storage_Offset := + Header_Size_With_Padding (Alignment); + begin + -- Expose the two hidden pointers by shifting the address from the + -- start of the object to the FM_Node equivalent of the pointers. + + Addr := Addr - Header_And_Padding; + + -- Update the size of the object to include the two pointers + + Storage_Size := Storage_Size + Header_And_Padding; + end Adjust_Controlled_Dereference; + + -------------- + -- Allocate -- + -------------- + + overriding procedure Allocate + (Pool : in out Root_Storage_Pool_With_Subpools; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is + begin + -- Dispatch to the user-defined implementations of Allocate_From_Subpool + -- and Default_Subpool_For_Pool. + + Allocate_From_Subpool + (Root_Storage_Pool_With_Subpools'Class (Pool), + Storage_Address, + Size_In_Storage_Elements, + Alignment, + Default_Subpool_For_Pool + (Root_Storage_Pool_With_Subpools'Class (Pool))); + end Allocate; + + ----------------------------- + -- Allocate_Any_Controlled -- + ----------------------------- + + procedure Allocate_Any_Controlled + (Pool : in out Root_Storage_Pool'Class; + Context_Subpool : Subpool_Handle; + Context_Master : Finalization_Masters.Finalization_Master_Ptr; + Fin_Address : Finalization_Masters.Finalize_Address_Ptr; + Addr : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Is_Controlled : Boolean; + On_Subpool : Boolean) + is + Is_Subpool_Allocation : constant Boolean := + Pool in Root_Storage_Pool_With_Subpools'Class; + + Master : Finalization_Master_Ptr := null; + N_Addr : Address; + N_Ptr : FM_Node_Ptr; + N_Size : Storage_Count; + Subpool : Subpool_Handle := null; + + Header_And_Padding : Storage_Offset; + -- This offset includes the size of a FM_Node plus any additional + -- padding due to a larger alignment. + + begin + -- Step 1: Pool-related runtime checks + + -- Allocation on a pool_with_subpools. In this scenario there is a + -- master for each subpool. The master of the access type is ignored. + + if Is_Subpool_Allocation then + + -- Case of an allocation without a Subpool_Handle. Dispatch to the + -- implementation of Default_Subpool_For_Pool. + + if Context_Subpool = null then + Subpool := + Default_Subpool_For_Pool + (Root_Storage_Pool_With_Subpools'Class (Pool)); + + -- Allocation with a Subpool_Handle + + else + Subpool := Context_Subpool; + end if; + + -- Ensure proper ownership and chaining of the subpool + + if Subpool.Owner /= + Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access + or else Subpool.Node = null + or else Subpool.Node.Prev = null + or else Subpool.Node.Next = null + then + raise Program_Error with "incorrect owner of subpool"; + end if; + + Master := Subpool.Master'Unchecked_Access; + + -- Allocation on a simple pool. In this scenario there is a master for + -- each access-to-controlled type. No context subpool should be present. + + else + -- If the master is missing, then the expansion of the access type + -- failed to create one. This is a compiler bug. + + pragma Assert + (Context_Master /= null, "missing master in pool allocation"); + + -- If a subpool is present, then this is the result of erroneous + -- allocator expansion. This is not a serious error, but it should + -- still be detected. + + if Context_Subpool /= null then + raise Program_Error + with "subpool not required in pool allocation"; + end if; + + -- If the allocation is intended to be on a subpool, but the access + -- type's pool does not support subpools, then this is the result of + -- incorrect end-user code. + + if On_Subpool then + raise Program_Error + with "pool of access type does not support subpools"; + end if; + + Master := Context_Master; + end if; + + -- Step 2: Master, Finalize_Address-related runtime checks and size + -- calculations. + + -- Allocation of a descendant from [Limited_]Controlled, a class-wide + -- object or a record with controlled components. + + if Is_Controlled then + + -- Synchronization: + -- Read - allocation, finalization + -- Write - finalization + + Lock_Task.all; + + -- Do not allow the allocation of controlled objects while the + -- associated master is being finalized. + + if Finalization_Started (Master.all) then + raise Program_Error with "allocation after finalization started"; + end if; + + -- Check whether primitive Finalize_Address is available. If it is + -- not, then either the expansion of the designated type failed or + -- the expansion of the allocator failed. This is a compiler bug. + + pragma Assert + (Fin_Address /= null, "primitive Finalize_Address not available"); + + -- The size must account for the hidden header preceding the object. + -- Account for possible padding space before the header due to a + -- larger alignment. + + Header_And_Padding := Header_Size_With_Padding (Alignment); + + N_Size := Storage_Size + Header_And_Padding; + + -- Non-controlled allocation + + else + N_Size := Storage_Size; + end if; + + -- Step 3: Allocation of object + + -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the + -- implementation of Allocate_From_Subpool. + + if Is_Subpool_Allocation then + Allocate_From_Subpool + (Root_Storage_Pool_With_Subpools'Class (Pool), + N_Addr, N_Size, Alignment, Subpool); + + -- For descendants of Root_Storage_Pool, dispatch to the implementation + -- of Allocate. + + else + Allocate (Pool, N_Addr, N_Size, Alignment); + end if; + + -- Step 4: Attachment + + if Is_Controlled then + + -- Note that we already did "Lock_Task.all;" in Step 2 above + + -- Map the allocated memory into a FM_Node record. This converts the + -- top of the allocated bits into a list header. If there is padding + -- due to larger alignment, the header is placed right next to the + -- object: + + -- N_Addr N_Ptr + -- | | + -- V V + -- +-------+---------------+----------------------+ + -- |Padding| Header | Object | + -- +-------+---------------+----------------------+ + -- ^ ^ ^ + -- | +- Header_Size -+ + -- | | + -- +- Header_And_Padding --+ + + N_Ptr := + Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size); + + -- Prepend the allocated object to the finalization master + + -- Synchronization: + -- Write - allocation, deallocation, finalization + + Attach_Unprotected (N_Ptr, Objects (Master.all)); + + -- Move the address from the hidden list header to the start of the + -- object. This operation effectively hides the list header. + + Addr := N_Addr + Header_And_Padding; + + -- Homogeneous masters service the following: + + -- 1) Allocations on / Deallocations from regular pools + -- 2) Named access types + -- 3) Most cases of anonymous access types usage + + -- Synchronization: + -- Read - allocation, finalization + -- Write - outside + + if Master.Is_Homogeneous then + + -- Synchronization: + -- Read - finalization + -- Write - allocation, outside + + Set_Finalize_Address_Unprotected (Master.all, Fin_Address); + + -- Heterogeneous masters service the following: + + -- 1) Allocations on / Deallocations from subpools + -- 2) Certain cases of anonymous access types usage + + else + -- Synchronization: + -- Read - finalization + -- Write - allocation, deallocation + + Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address); + Finalize_Address_Table_In_Use := True; + end if; + + Unlock_Task.all; + + -- Non-controlled allocation + + else + Addr := N_Addr; + end if; + + exception + when others => + + -- Unlock the task in case the allocation step failed and reraise the + -- exception. + + if Is_Controlled then + Unlock_Task.all; + end if; + + raise; + end Allocate_Any_Controlled; + + ------------ + -- Attach -- + ------------ + + procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is + begin + -- Ensure that the node has not been attached already + + pragma Assert (N.Prev = null and then N.Next = null); + + Lock_Task.all; + + L.Next.Prev := N; + N.Next := L.Next; + L.Next := N; + N.Prev := L; + + Unlock_Task.all; + + -- Note: No need to unlock in case of an exception because the above + -- code can never raise one. + end Attach; + + ------------------------------- + -- Deallocate_Any_Controlled -- + ------------------------------- + + procedure Deallocate_Any_Controlled + (Pool : in out Root_Storage_Pool'Class; + Addr : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Is_Controlled : Boolean) + is + N_Addr : Address; + N_Ptr : FM_Node_Ptr; + N_Size : Storage_Count; + + Header_And_Padding : Storage_Offset; + -- This offset includes the size of a FM_Node plus any additional + -- padding due to a larger alignment. + + begin + -- Step 1: Detachment + + if Is_Controlled then + Lock_Task.all; + + begin + -- Destroy the relation pair object - Finalize_Address since it is + -- no longer needed. + + if Finalize_Address_Table_In_Use then + + -- Synchronization: + -- Read - finalization + -- Write - allocation, deallocation + + Delete_Finalize_Address_Unprotected (Addr); + end if; + + -- Account for possible padding space before the header due to a + -- larger alignment. + + Header_And_Padding := Header_Size_With_Padding (Alignment); + + -- N_Addr N_Ptr Addr (from input) + -- | | | + -- V V V + -- +-------+---------------+----------------------+ + -- |Padding| Header | Object | + -- +-------+---------------+----------------------+ + -- ^ ^ ^ + -- | +- Header_Size -+ + -- | | + -- +- Header_And_Padding --+ + + -- Convert the bits preceding the object into a list header + + N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size); + + -- Detach the object from the related finalization master. This + -- action does not need to know the prior context used during + -- allocation. + + -- Synchronization: + -- Write - allocation, deallocation, finalization + + Detach_Unprotected (N_Ptr); + + -- Move the address from the object to the beginning of the list + -- header. + + N_Addr := Addr - Header_And_Padding; + + -- The size of the deallocated object must include the size of the + -- hidden list header. + + N_Size := Storage_Size + Header_And_Padding; + + Unlock_Task.all; + + exception + when others => + + -- Unlock the task in case the computations performed above + -- fail for some reason. + + Unlock_Task.all; + raise; + end; + else + N_Addr := Addr; + N_Size := Storage_Size; + end if; + + -- Step 2: Deallocation + + -- Dispatch to the proper implementation of Deallocate. This action + -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools + -- implementations. + + Deallocate (Pool, N_Addr, N_Size, Alignment); + end Deallocate_Any_Controlled; + + ------------------------------ + -- Default_Subpool_For_Pool -- + ------------------------------ + + function Default_Subpool_For_Pool + (Pool : in out Root_Storage_Pool_With_Subpools) + return not null Subpool_Handle + is + pragma Unreferenced (Pool); + begin + return raise Program_Error with + "default Default_Subpool_For_Pool called; must be overridden"; + end Default_Subpool_For_Pool; + + ------------ + -- Detach -- + ------------ + + procedure Detach (N : not null SP_Node_Ptr) is + begin + -- Ensure that the node is attached to some list + + pragma Assert (N.Next /= null and then N.Prev /= null); + + Lock_Task.all; + + N.Prev.Next := N.Next; + N.Next.Prev := N.Prev; + N.Prev := null; + N.Next := null; + + Unlock_Task.all; + + -- Note: No need to unlock in case of an exception because the above + -- code can never raise one. + end Detach; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Controller : in out Pool_Controller) is + begin + Finalize_Pool (Controller.Enclosing_Pool.all); + end Finalize; + + ------------------- + -- Finalize_Pool -- + ------------------- + + procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is + Curr_Ptr : SP_Node_Ptr; + Ex_Occur : Exception_Occurrence; + Raised : Boolean := False; + + function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean; + -- Determine whether a list contains only one element, the dummy head + + ------------------- + -- Is_Empty_List -- + ------------------- + + function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is + begin + return L.Next = L and then L.Prev = L; + end Is_Empty_List; + + -- Start of processing for Finalize_Pool + + begin + -- It is possible for multiple tasks to cause the finalization of a + -- common pool. Allow only one task to finalize the contents. + + if Pool.Finalization_Started then + return; + end if; + + -- Lock the pool to prevent the creation of additional subpools while + -- the available ones are finalized. The pool remains locked because + -- either it is about to be deallocated or the associated access type + -- is about to go out of scope. + + Pool.Finalization_Started := True; + + while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop + Curr_Ptr := Pool.Subpools.Next; + + -- Perform the following actions: + + -- 1) Finalize all objects chained on the subpool's master + -- 2) Remove the subpool from the owner's list of subpools + -- 3) Deallocate the doubly linked list node associated with the + -- subpool. + -- 4) Call Deallocate_Subpool + + begin + Finalize_And_Deallocate (Curr_Ptr.Subpool); + + exception + when Fin_Occur : others => + if not Raised then + Raised := True; + Save_Occurrence (Ex_Occur, Fin_Occur); + end if; + end; + end loop; + + -- If the finalization of a particular master failed, reraise the + -- exception now. + + if Raised then + Reraise_Occurrence (Ex_Occur); + end if; + end Finalize_Pool; + + ------------------------------ + -- Header_Size_With_Padding -- + ------------------------------ + + function Header_Size_With_Padding + (Alignment : System.Storage_Elements.Storage_Count) + return System.Storage_Elements.Storage_Count + is + Size : constant Storage_Count := Header_Size; + + begin + if Size mod Alignment = 0 then + return Size; + + -- Add enough padding to reach the nearest multiple of the alignment + -- rounding up. + + else + return ((Size + Alignment - 1) / Alignment) * Alignment; + end if; + end Header_Size_With_Padding; + + ---------------- + -- Initialize -- + ---------------- + + overriding procedure Initialize (Controller : in out Pool_Controller) is + begin + Initialize_Pool (Controller.Enclosing_Pool.all); + end Initialize; + + --------------------- + -- Initialize_Pool -- + --------------------- + + procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is + begin + -- The dummy head must point to itself in both directions + + Pool.Subpools.Next := Pool.Subpools'Unchecked_Access; + Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access; + end Initialize_Pool; + + --------------------- + -- Pool_Of_Subpool -- + --------------------- + + function Pool_Of_Subpool + (Subpool : not null Subpool_Handle) + return access Root_Storage_Pool_With_Subpools'Class + is + begin + return Subpool.Owner; + end Pool_Of_Subpool; + + ---------------- + -- Print_Pool -- + ---------------- + + procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is + Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access; + Head_Seen : Boolean := False; + SP_Ptr : SP_Node_Ptr; + + begin + -- Output the contents of the pool + + -- Pool : 0x123456789 + -- Subpools : 0x123456789 + -- Fin_Start : TRUE FALSE + -- Controller: OK NOK + + Put ("Pool : "); + Put_Line (Address_Image (Pool'Address)); + + Put ("Subpools : "); + Put_Line (Address_Image (Pool.Subpools'Address)); + + Put ("Fin_Start : "); + Put_Line (Pool.Finalization_Started'Img); + + Put ("Controlled: "); + if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then + Put_Line ("OK"); + else + Put_Line ("NOK (ERROR)"); + end if; + + SP_Ptr := Head; + while SP_Ptr /= null loop -- Should never be null + Put_Line ("V"); + + -- We see the head initially; we want to exit when we see the head a + -- second time. + + if SP_Ptr = Head then + exit when Head_Seen; + + Head_Seen := True; + end if; + + -- The current element is null. This should never happend since the + -- list is circular. + + if SP_Ptr.Prev = null then + Put_Line ("null (ERROR)"); + + -- The current element points back to the correct element + + elsif SP_Ptr.Prev.Next = SP_Ptr then + Put_Line ("^"); + + -- The current element points to an erroneous element + + else + Put_Line ("? (ERROR)"); + end if; + + -- Output the contents of the node + + Put ("|Header: "); + Put (Address_Image (SP_Ptr.all'Address)); + if SP_Ptr = Head then + Put_Line (" (dummy head)"); + else + Put_Line (""); + end if; + + Put ("| Prev: "); + + if SP_Ptr.Prev = null then + Put_Line ("null"); + else + Put_Line (Address_Image (SP_Ptr.Prev.all'Address)); + end if; + + Put ("| Next: "); + + if SP_Ptr.Next = null then + Put_Line ("null"); + else + Put_Line (Address_Image (SP_Ptr.Next.all'Address)); + end if; + + Put ("| Subp: "); + + if SP_Ptr.Subpool = null then + Put_Line ("null"); + else + Put_Line (Address_Image (SP_Ptr.Subpool.all'Address)); + end if; + + SP_Ptr := SP_Ptr.Next; + end loop; + end Print_Pool; + + ------------------- + -- Print_Subpool -- + ------------------- + + procedure Print_Subpool (Subpool : Subpool_Handle) is + begin + if Subpool = null then + Put_Line ("null"); + return; + end if; + + -- Output the contents of a subpool + + -- Owner : 0x123456789 + -- Master: 0x123456789 + -- Node : 0x123456789 + + Put ("Owner : "); + if Subpool.Owner = null then + Put_Line ("null"); + else + Put_Line (Address_Image (Subpool.Owner'Address)); + end if; + + Put ("Master: "); + Put_Line (Address_Image (Subpool.Master'Address)); + + Put ("Node : "); + if Subpool.Node = null then + Put ("null"); + + if Subpool.Owner = null then + Put_Line (" OK"); + else + Put_Line (" (ERROR)"); + end if; + else + Put_Line (Address_Image (Subpool.Node'Address)); + end if; + + Print_Master (Subpool.Master); + end Print_Subpool; + + ------------------------- + -- Set_Pool_Of_Subpool -- + ------------------------- + + procedure Set_Pool_Of_Subpool + (Subpool : not null Subpool_Handle; + To : in out Root_Storage_Pool_With_Subpools'Class) + is + N_Ptr : SP_Node_Ptr; + + begin + -- If the subpool is already owned, raise Program_Error. This is a + -- direct violation of the RM rules. + + if Subpool.Owner /= null then + raise Program_Error with "subpool already belongs to a pool"; + end if; + + -- Prevent the creation of a new subpool while the owner is being + -- finalized. This is a serious error. + + if To.Finalization_Started then + raise Program_Error + with "subpool creation after finalization started"; + end if; + + Subpool.Owner := To'Unchecked_Access; + + -- Create a subpool node and decorate it. Since this node is not + -- allocated on the owner's pool, it must be explicitly destroyed by + -- Finalize_And_Detach. + + N_Ptr := new SP_Node; + N_Ptr.Subpool := Subpool; + Subpool.Node := N_Ptr; + + Attach (N_Ptr, To.Subpools'Unchecked_Access); + + -- Mark the subpool's master as being a heterogeneous collection of + -- controlled objects. + + Set_Is_Heterogeneous (Subpool.Master); + end Set_Pool_Of_Subpool; + +end System.Storage_Pools.Subpools; diff --git a/gcc/ada/libgnat/s-stposu.ads b/gcc/ada/libgnat/s-stposu.ads new file mode 100644 index 0000000..165542d --- /dev/null +++ b/gcc/ada/libgnat/s-stposu.ads @@ -0,0 +1,358 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2011-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System.Finalization_Masters; +with System.Storage_Elements; + +package System.Storage_Pools.Subpools is + pragma Preelaborate; + + type Root_Storage_Pool_With_Subpools is abstract + new Root_Storage_Pool with private; + -- The base for all implementations of Storage_Pool_With_Subpools. This + -- type is Limited_Controlled by derivation. To use subpools, an access + -- type must be associated with an implementation descending from type + -- Root_Storage_Pool_With_Subpools. + + type Root_Subpool is abstract tagged limited private; + -- The base for all implementations of Subpool. Objects of this type are + -- managed by the pool_with_subpools. + + type Subpool_Handle is access all Root_Subpool'Class; + for Subpool_Handle'Storage_Size use 0; + -- Since subpools are limited types by definition, a handle is instead used + -- to manage subpool abstractions. + + overriding procedure Allocate + (Pool : in out Root_Storage_Pool_With_Subpools; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + -- Allocate an object described by Size_In_Storage_Elements and Alignment + -- on the default subpool of Pool. Controlled types allocated through this + -- routine will NOT be handled properly. + + procedure Allocate_From_Subpool + (Pool : in out Root_Storage_Pool_With_Subpools; + Storage_Address : out System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Subpool : not null Subpool_Handle) is abstract; + + -- ??? This precondition causes errors in simple tests, disabled for now + + -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; + -- This routine requires implementation. Allocate an object described by + -- Size_In_Storage_Elements and Alignment on a subpool. + + function Create_Subpool + (Pool : in out Root_Storage_Pool_With_Subpools) + return not null Subpool_Handle is abstract; + -- This routine requires implementation. Create a subpool within the given + -- pool_with_subpools. + + overriding procedure Deallocate + (Pool : in out Root_Storage_Pool_With_Subpools; + Storage_Address : System.Address; + Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count) + is null; + + procedure Deallocate_Subpool + (Pool : in out Root_Storage_Pool_With_Subpools; + Subpool : in out Subpool_Handle) + is abstract; + -- This precondition causes errors in simple tests, disabled for now??? + -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; + + -- This routine requires implementation. Reclaim the storage a particular + -- subpool occupies in a pool_with_subpools. This routine is called by + -- Ada.Unchecked_Deallocate_Subpool. + + function Default_Subpool_For_Pool + (Pool : in out Root_Storage_Pool_With_Subpools) + return not null Subpool_Handle; + -- Return a common subpool which is used for object allocations without a + -- Subpool_Handle_Name in the allocator. The default implementation of this + -- routine raises Program_Error. + + function Pool_Of_Subpool + (Subpool : not null Subpool_Handle) + return access Root_Storage_Pool_With_Subpools'Class; + -- Return the owner of the subpool + + procedure Set_Pool_Of_Subpool + (Subpool : not null Subpool_Handle; + To : in out Root_Storage_Pool_With_Subpools'Class); + -- Set the owner of the subpool. This is intended to be called from + -- Create_Subpool or similar subpool constructors. Raises Program_Error + -- if the subpool already belongs to a pool. + + overriding function Storage_Size + (Pool : Root_Storage_Pool_With_Subpools) + return System.Storage_Elements.Storage_Count + is + (System.Storage_Elements.Storage_Count'Last); + +private + -- Model + -- Pool_With_Subpools SP_Node SP_Node SP_Node + -- +-->+--------------------+ +-----+ +-----+ +-----+ + -- | | Subpools -------->| ------->| ------->| -------> + -- | +--------------------+ +-----+ +-----+ +-----+ + -- | |Finalization_Started|<------ |<------- |<------- |<--- + -- | +--------------------+ +-----+ +-----+ +-----+ + -- +--- Controller.Encl_Pool| | nul | | + | | + | + -- | +--------------------+ +-----+ +--|--+ +--:--+ + -- | : : Dummy | ^ : + -- | : : | | : + -- | Root_Subpool V | + -- | +-------------+ | + -- +-------------------------------- Owner | | + -- FM_Node FM_Node +-------------+ | + -- +-----+ +-----+<-- Master.Objects| | + -- <------ |<------ | +-------------+ | + -- +-----+ +-----+ | Node -------+ + -- | ------>| -----> +-------------+ + -- +-----+ +-----+ : : + -- |ctrl | Dummy : : + -- | obj | + -- +-----+ + -- + -- SP_Nodes are created on the heap. FM_Nodes and associated objects are + -- created on the pool_with_subpools. + + type Any_Storage_Pool_With_Subpools_Ptr + is access all Root_Storage_Pool_With_Subpools'Class; + for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0; + + -- A pool controller is a special controlled object which ensures the + -- proper initialization and finalization of the enclosing pool. + + type Pool_Controller (Enclosing_Pool : Any_Storage_Pool_With_Subpools_Ptr) + is new Ada.Finalization.Limited_Controlled with null record; + + -- Subpool list types. Each pool_with_subpools contains a list of subpools. + -- This is an indirect doubly linked list since subpools are not supposed + -- to be allocatable by language design. + + type SP_Node; + type SP_Node_Ptr is access all SP_Node; + + type SP_Node is record + Prev : SP_Node_Ptr := null; + Next : SP_Node_Ptr := null; + Subpool : Subpool_Handle := null; + end record; + + -- Root_Storage_Pool_With_Subpools internal structure. The type uses a + -- special controller to perform initialization and finalization actions + -- on itself. This is necessary because the end user of this package may + -- decide to override Initialize and Finalize, thus disabling the desired + -- behavior. + + -- Pool_With_Subpools SP_Node SP_Node SP_Node + -- +-->+--------------------+ +-----+ +-----+ +-----+ + -- | | Subpools -------->| ------->| ------->| -------> + -- | +--------------------+ +-----+ +-----+ +-----+ + -- | |Finalization_Started| : : : : : : + -- | +--------------------+ + -- +--- Controller.Encl_Pool| + -- +--------------------+ + -- : End-user : + -- : components : + + type Root_Storage_Pool_With_Subpools is abstract + new Root_Storage_Pool with + record + Subpools : aliased SP_Node; + -- A doubly linked list of subpools + + Finalization_Started : Boolean := False; + pragma Atomic (Finalization_Started); + -- A flag which prevents the creation of new subpools while the master + -- pool is being finalized. The flag needs to be atomic because it is + -- accessed without Lock_Task / Unlock_Task. + + Controller : Pool_Controller + (Root_Storage_Pool_With_Subpools'Unchecked_Access); + -- A component which ensures that the enclosing pool is initialized and + -- finalized at the appropriate places. + end record; + + -- A subpool is an abstraction layer which sits on top of a pool. It + -- contains links to all controlled objects allocated on a particular + -- subpool. + + -- Pool_With_Subpools SP_Node SP_Node SP_Node + -- +-->+----------------+ +-----+ +-----+ +-----+ + -- | | Subpools ------>| ------->| ------->| -------> + -- | +----------------+ +-----+ +-----+ +-----+ + -- | : :<------ |<------- |<------- | + -- | : : +-----+ +-----+ +-----+ + -- | |null | | + | | + | + -- | +-----+ +--|--+ +--:--+ + -- | | ^ : + -- | Root_Subpool V | + -- | +-------------+ | + -- +---------------------------- Owner | | + -- +-------------+ | + -- .......... Master | | + -- +-------------+ | + -- | Node -------+ + -- +-------------+ + -- : End-user : + -- : components : + + type Root_Subpool is abstract tagged limited record + Owner : Any_Storage_Pool_With_Subpools_Ptr := null; + -- A reference to the master pool_with_subpools + + Master : aliased System.Finalization_Masters.Finalization_Master; + -- A heterogeneous collection of controlled objects + + Node : SP_Node_Ptr := null; + -- A link to the doubly linked list node which contains the subpool. + -- This back pointer is used in subpool deallocation. + end record; + + procedure Adjust_Controlled_Dereference + (Addr : in out System.Address; + Storage_Size : in out System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count); + -- Given the memory attributes of a heap-allocated object that is known to + -- be controlled, adjust the address and size of the object to include the + -- two hidden pointers inserted by the finalization machinery. + + -- ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed + -- to Allocate_Any. + + procedure Allocate_Any_Controlled + (Pool : in out Root_Storage_Pool'Class; + Context_Subpool : Subpool_Handle; + Context_Master : Finalization_Masters.Finalization_Master_Ptr; + Fin_Address : Finalization_Masters.Finalize_Address_Ptr; + Addr : out System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Is_Controlled : Boolean; + On_Subpool : Boolean); + -- Compiler interface. This version of Allocate handles all possible cases, + -- either on a pool or a pool_with_subpools, regardless of the controlled + -- status of the allocated object. Parameter usage: + -- + -- * Pool - The pool associated with the access type. Pool can be any + -- derivation from Root_Storage_Pool, including a pool_with_subpools. + -- + -- * Context_Subpool - The subpool handle name of an allocator. If no + -- subpool handle is present at the point of allocation, the actual + -- would be null. + -- + -- * Context_Master - The finalization master associated with the access + -- type. If the access type's designated type is not controlled, the + -- actual would be null. + -- + -- * Fin_Address - TSS routine Finalize_Address of the designated type. + -- If the designated type is not controlled, the actual would be null. + -- + -- * Addr - The address of the allocated object. + -- + -- * Storage_Size - The size of the allocated object. + -- + -- * Alignment - The alignment of the allocated object. + -- + -- * Is_Controlled - A flag which determines whether the allocated object + -- is controlled. When set to True, the machinery generates additional + -- data. + -- + -- * On_Subpool - A flag which determines whether the a subpool handle + -- name is present at the point of allocation. This is used for error + -- diagnostics. + + procedure Deallocate_Any_Controlled + (Pool : in out Root_Storage_Pool'Class; + Addr : System.Address; + Storage_Size : System.Storage_Elements.Storage_Count; + Alignment : System.Storage_Elements.Storage_Count; + Is_Controlled : Boolean); + -- Compiler interface. This version of Deallocate handles all possible + -- cases, either from a pool or a pool_with_subpools, regardless of the + -- controlled status of the deallocated object. Parameter usage: + -- + -- * Pool - The pool associated with the access type. Pool can be any + -- derivation from Root_Storage_Pool, including a pool_with_subpools. + -- + -- * Addr - The address of the allocated object. + -- + -- * Storage_Size - The size of the allocated object. + -- + -- * Alignment - The alignment of the allocated object. + -- + -- * Is_Controlled - A flag which determines whether the allocated object + -- is controlled. When set to True, the machinery generates additional + -- data. + + procedure Detach (N : not null SP_Node_Ptr); + -- Unhook a subpool node from an arbitrary subpool list + + overriding procedure Finalize (Controller : in out Pool_Controller); + -- Buffer routine, calls Finalize_Pool + + procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools); + -- Iterate over all subpools of Pool, detach them one by one and finalize + -- their masters. This action first detaches a controlled object from a + -- particular master, then invokes its Finalize_Address primitive. + + function Header_Size_With_Padding + (Alignment : System.Storage_Elements.Storage_Count) + return System.Storage_Elements.Storage_Count; + -- Given an arbitrary alignment, calculate the size of the header which + -- precedes a controlled object as the nearest multiple rounded up of the + -- alignment. + + overriding procedure Initialize (Controller : in out Pool_Controller); + -- Buffer routine, calls Initialize_Pool + + procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools); + -- Setup the doubly linked list of subpools + + procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools); + -- Debug routine, output the contents of a pool_with_subpools + + procedure Print_Subpool (Subpool : Subpool_Handle); + -- Debug routine, output the contents of a subpool + +end System.Storage_Pools.Subpools; diff --git a/gcc/ada/libgnat/s-stratt-xdr.adb b/gcc/ada/libgnat/s-stratt-xdr.adb new file mode 100644 index 0000000..f7c63ce --- /dev/null +++ b/gcc/ada/libgnat/s-stratt-xdr.adb @@ -0,0 +1,1901 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R E A M _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1996-2017, Free Software Foundation, Inc. -- +-- -- +-- GARLIC is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This file is an alternate version of s-stratt.adb based on the XDR +-- standard. It is especially useful for exchanging streams between two +-- different systems with different basic type representations and endianness. + +pragma Warnings (Off, "*not allowed in compiler unit"); +-- This body is used only when rebuilding the runtime library, not when +-- building the compiler, so it's OK to depend on features that would +-- otherwise break bootstrap (e.g. IF-expressions). + +with Ada.IO_Exceptions; +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Conversion; + +package body System.Stream_Attributes is + + pragma Suppress (Range_Check); + pragma Suppress (Overflow_Check); + + use UST; + + Data_Error : exception renames Ada.IO_Exceptions.End_Error; + -- Exception raised if insufficient data read (End_Error is mandated by + -- AI95-00132). + + SU : constant := System.Storage_Unit; + -- The code in this body assumes that SU = 8 + + BB : constant := 2 ** SU; -- Byte base + BL : constant := 2 ** SU - 1; -- Byte last + BS : constant := 2 ** (SU - 1); -- Byte sign + + US : constant := Unsigned'Size; -- Unsigned size + UB : constant := (US - 1) / SU + 1; -- Unsigned byte + UL : constant := 2 ** US - 1; -- Unsigned last + + subtype SE is Ada.Streams.Stream_Element; + subtype SEA is Ada.Streams.Stream_Element_Array; + subtype SEO is Ada.Streams.Stream_Element_Offset; + + generic function UC renames Ada.Unchecked_Conversion; + + type Field_Type is + record + E_Size : Integer; -- Exponent bit size + E_Bias : Integer; -- Exponent bias + F_Size : Integer; -- Fraction bit size + E_Last : Integer; -- Max exponent value + F_Mask : SE; -- Mask to apply on first fraction byte + E_Bytes : SEO; -- N. of exponent bytes completely used + F_Bytes : SEO; -- N. of fraction bytes completely used + F_Bits : Integer; -- N. of bits used on first fraction word + end record; + + type Precision is (Single, Double, Quadruple); + + Fields : constant array (Precision) of Field_Type := ( + + -- Single precision + + (E_Size => 8, + E_Bias => 127, + F_Size => 23, + E_Last => 2 ** 8 - 1, + F_Mask => 16#7F#, -- 2 ** 7 - 1, + E_Bytes => 2, + F_Bytes => 3, + F_Bits => 23 mod US), + + -- Double precision + + (E_Size => 11, + E_Bias => 1023, + F_Size => 52, + E_Last => 2 ** 11 - 1, + F_Mask => 16#0F#, -- 2 ** 4 - 1, + E_Bytes => 2, + F_Bytes => 7, + F_Bits => 52 mod US), + + -- Quadruple precision + + (E_Size => 15, + E_Bias => 16383, + F_Size => 112, + E_Last => 2 ** 8 - 1, + F_Mask => 16#FF#, -- 2 ** 8 - 1, + E_Bytes => 2, + F_Bytes => 14, + F_Bits => 112 mod US)); + + -- The representation of all items requires a multiple of four bytes + -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes + -- are read or written to some byte stream such that byte m always + -- precedes byte m+1. If the n bytes needed to contain the data are not + -- a multiple of four, then the n bytes are followed by enough (0 to 3) + -- residual zero bytes, r, to make the total byte count a multiple of 4. + + -- An XDR signed integer is a 32-bit datum that encodes an integer + -- in the range [-2147483648,2147483647]. The integer is represented + -- in two's complement notation. The most and least significant bytes + -- are 0 and 3, respectively. Integers are declared as follows: + + -- (MSB) (LSB) + -- +-------+-------+-------+-------+ + -- |byte 0 |byte 1 |byte 2 |byte 3 | + -- +-------+-------+-------+-------+ + -- <------------32 bits------------> + + SSI_L : constant := 1; + SI_L : constant := 2; + I_L : constant := 4; + LI_L : constant := 8; + LLI_L : constant := 8; + + subtype XDR_S_SSI is SEA (1 .. SSI_L); + subtype XDR_S_SI is SEA (1 .. SI_L); + subtype XDR_S_I is SEA (1 .. I_L); + subtype XDR_S_LI is SEA (1 .. LI_L); + subtype XDR_S_LLI is SEA (1 .. LLI_L); + + function Short_Short_Integer_To_XDR_S_SSI is + new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI); + function XDR_S_SSI_To_Short_Short_Integer is + new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer); + + function Short_Integer_To_XDR_S_SI is + new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI); + function XDR_S_SI_To_Short_Integer is + new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer); + + function Integer_To_XDR_S_I is + new Ada.Unchecked_Conversion (Integer, XDR_S_I); + function XDR_S_I_To_Integer is + new Ada.Unchecked_Conversion (XDR_S_I, Integer); + + function Long_Long_Integer_To_XDR_S_LI is + new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI); + function XDR_S_LI_To_Long_Long_Integer is + new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer); + + function Long_Long_Integer_To_XDR_S_LLI is + new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI); + function XDR_S_LLI_To_Long_Long_Integer is + new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer); + + -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative + -- integer in the range [0,4294967295]. It is represented by an unsigned + -- binary number whose most and least significant bytes are 0 and 3, + -- respectively. An unsigned integer is declared as follows: + + -- (MSB) (LSB) + -- +-------+-------+-------+-------+ + -- |byte 0 |byte 1 |byte 2 |byte 3 | + -- +-------+-------+-------+-------+ + -- <------------32 bits------------> + + SSU_L : constant := 1; + SU_L : constant := 2; + U_L : constant := 4; + LU_L : constant := 8; + LLU_L : constant := 8; + + subtype XDR_S_SSU is SEA (1 .. SSU_L); + subtype XDR_S_SU is SEA (1 .. SU_L); + subtype XDR_S_U is SEA (1 .. U_L); + subtype XDR_S_LU is SEA (1 .. LU_L); + subtype XDR_S_LLU is SEA (1 .. LLU_L); + + type XDR_SSU is mod BB ** SSU_L; + type XDR_SU is mod BB ** SU_L; + type XDR_U is mod BB ** U_L; + + function Short_Unsigned_To_XDR_S_SU is + new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU); + function XDR_S_SU_To_Short_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned); + + function Unsigned_To_XDR_S_U is + new Ada.Unchecked_Conversion (Unsigned, XDR_S_U); + function XDR_S_U_To_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_U, Unsigned); + + function Long_Long_Unsigned_To_XDR_S_LU is + new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU); + function XDR_S_LU_To_Long_Long_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned); + + function Long_Long_Unsigned_To_XDR_S_LLU is + new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU); + function XDR_S_LLU_To_Long_Long_Unsigned is + new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned); + + -- The standard defines the floating-point data type "float" (32 bits + -- or 4 bytes). The encoding used is the IEEE standard for normalized + -- single-precision floating-point numbers. + + -- The standard defines the encoding used for the double-precision + -- floating-point data type "double" (64 bits or 8 bytes). The encoding + -- used is the IEEE standard for normalized double-precision floating-point + -- numbers. + + SF_L : constant := 4; -- Single precision + F_L : constant := 4; -- Single precision + LF_L : constant := 8; -- Double precision + LLF_L : constant := 16; -- Quadruple precision + + TM_L : constant := 8; + subtype XDR_S_TM is SEA (1 .. TM_L); + type XDR_TM is mod BB ** TM_L; + + type XDR_SA is mod 2 ** Standard'Address_Size; + function To_XDR_SA is new UC (System.Address, XDR_SA); + function To_XDR_SA is new UC (XDR_SA, System.Address); + + -- Enumerations have the same representation as signed integers. + -- Enumerations are handy for describing subsets of the integers. + + -- Booleans are important enough and occur frequently enough to warrant + -- their own explicit type in the standard. Booleans are declared as + -- an enumeration, with FALSE = 0 and TRUE = 1. + + -- The standard defines a string of n (numbered 0 through n-1) ASCII + -- bytes to be the number n encoded as an unsigned integer (as described + -- above), and followed by the n bytes of the string. Byte m of the string + -- always precedes byte m+1 of the string, and byte 0 of the string always + -- follows the string's length. If n is not a multiple of four, then the + -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make + -- the total byte count a multiple of four. + + -- To fit with XDR string, do not consider character as an enumeration + -- type. + + C_L : constant := 1; + subtype XDR_S_C is SEA (1 .. C_L); + + -- Consider Wide_Character as an enumeration type + + WC_L : constant := 4; + subtype XDR_S_WC is SEA (1 .. WC_L); + type XDR_WC is mod BB ** WC_L; + + -- Consider Wide_Wide_Character as an enumeration type + + WWC_L : constant := 8; + subtype XDR_S_WWC is SEA (1 .. WWC_L); + type XDR_WWC is mod BB ** WWC_L; + + -- Optimization: if we already have the correct Bit_Order, then some + -- computations can be avoided since the source and the target will be + -- identical anyway. They will be replaced by direct unchecked + -- conversions. + + Optimize_Integers : constant Boolean := + Default_Bit_Order = High_Order_First; + + ----------------- + -- Block_IO_OK -- + ----------------- + + -- We must inhibit Block_IO, because in XDR mode, each element is output + -- according to XDR requirements, which is not at all the same as writing + -- the whole array in one block. + + function Block_IO_OK return Boolean is + begin + return False; + end Block_IO_OK; + + ---------- + -- I_AD -- + ---------- + + function I_AD (Stream : not null access RST) return Fat_Pointer is + FP : Fat_Pointer; + + begin + FP.P1 := I_AS (Stream).P1; + FP.P2 := I_AS (Stream).P1; + + return FP; + end I_AD; + + ---------- + -- I_AS -- + ---------- + + function I_AS (Stream : not null access RST) return Thin_Pointer is + S : XDR_S_TM; + L : SEO; + U : XDR_TM := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_TM (S (N)); + end loop; + + return (P1 => To_XDR_SA (XDR_SA (U))); + end if; + end I_AS; + + --------- + -- I_B -- + --------- + + function I_B (Stream : not null access RST) return Boolean is + begin + case I_SSU (Stream) is + when 0 => return False; + when 1 => return True; + when others => raise Data_Error; + end case; + end I_B; + + --------- + -- I_C -- + --------- + + function I_C (Stream : not null access RST) return Character is + S : XDR_S_C; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + -- Use Ada requirements on Character representation clause + + return Character'Val (S (1)); + end if; + end I_C; + + --------- + -- I_F -- + --------- + + function I_F (Stream : not null access RST) return Float is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Is_Positive : Boolean; + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Result : Float; + S : SEA (1 .. F_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask); + for N in F_L + 2 - F_Bytes .. F_L loop + Fraction := Fraction * BB + Long_Unsigned (S (N)); + end loop; + Result := Float'Scaling (Float (Fraction), -F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_F; + + --------- + -- I_I -- + --------- + + function I_I (Stream : not null access RST) return Integer is + S : XDR_S_I; + L : SEO; + U : XDR_U := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_I_To_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_U (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Integer (U); + + else + return Integer (-((XDR_U'Last xor U) + 1)); + end if; + end if; + end I_I; + + ---------- + -- I_LF -- + ---------- + + function I_LF (Stream : not null access RST) return Long_Float is + I : constant Precision := Double; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Is_Positive : Boolean; + Exponent : Long_Unsigned; + Fraction : Long_Long_Unsigned; + Result : Long_Float; + S : SEA (1 .. LF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask); + for N in LF_L + 2 - F_Bytes .. LF_L loop + Fraction := Fraction * BB + Long_Long_Unsigned (S (N)); + end loop; + + Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Long_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Long_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_LF; + + ---------- + -- I_LI -- + ---------- + + function I_LI (Stream : not null access RST) return Long_Integer is + S : XDR_S_LI; + L : SEO; + U : Unsigned := 0; + X : Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S)); + + else + + -- Compute using machine unsigned + -- rather than long_long_unsigned + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Unsigned (U); + U := 0; + end if; + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Long_Integer (X); + else + return Long_Integer (-((Long_Unsigned'Last xor X) + 1)); + end if; + + end if; + end I_LI; + + ----------- + -- I_LLF -- + ----------- + + function I_LLF (Stream : not null access RST) return Long_Long_Float is + I : constant Precision := Quadruple; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Is_Positive : Boolean; + Exponent : Long_Unsigned; + Fraction_1 : Long_Long_Unsigned := 0; + Fraction_2 : Long_Long_Unsigned := 0; + Result : Long_Long_Float; + HF : constant Natural := F_Size / 2; + S : SEA (1 .. LLF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop + Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I)); + end loop; + + for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop + Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I)); + end loop; + + Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF); + Result := Long_Long_Float (Fraction_1) + Result; + Result := Long_Long_Float'Scaling (Result, HF - F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction_1 = 0 and then Fraction_2 = 0 then + null; + + -- Denormalized float + + else + Result := Long_Long_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Long_Long_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_LLF; + + ----------- + -- I_LLI -- + ----------- + + function I_LLI (Stream : not null access RST) return Long_Long_Integer is + S : XDR_S_LLI; + L : SEO; + U : Unsigned := 0; + X : Long_Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_LLI_To_Long_Long_Integer (S); + + else + -- Compute using machine unsigned for computing + -- rather than long_long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Long_Unsigned (U); + U := 0; + end if; + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Long_Long_Integer (X); + else + return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1)); + end if; + end if; + end I_LLI; + + ----------- + -- I_LLU -- + ----------- + + function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is + S : XDR_S_LLU; + L : SEO; + U : Unsigned := 0; + X : Long_Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_LLU_To_Long_Long_Unsigned (S); + + else + -- Compute using machine unsigned + -- rather than long_long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Long_Unsigned (U); + U := 0; + end if; + end loop; + + return X; + end if; + end I_LLU; + + ---------- + -- I_LU -- + ---------- + + function I_LU (Stream : not null access RST) return Long_Unsigned is + S : XDR_S_LU; + L : SEO; + U : Unsigned := 0; + X : Long_Unsigned := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); + + else + -- Compute using machine unsigned + -- rather than long_unsigned. + + for N in S'Range loop + U := U * BB + Unsigned (S (N)); + + -- We have filled an unsigned + + if N mod UB = 0 then + X := Shift_Left (X, US) + Long_Unsigned (U); + U := 0; + end if; + end loop; + + return X; + end if; + end I_LU; + + ---------- + -- I_SF -- + ---------- + + function I_SF (Stream : not null access RST) return Short_Float is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Last : Integer renames Fields (I).E_Last; + F_Mask : SE renames Fields (I).F_Mask; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + Result : Short_Float; + S : SEA (1 .. SF_L); + L : SEO; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + end if; + + -- Extract Fraction, Sign and Exponent + + Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask); + for N in SF_L + 2 - F_Bytes .. SF_L loop + Fraction := Fraction * BB + Long_Unsigned (S (N)); + end loop; + Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); + + if BS <= S (1) then + Is_Positive := False; + Exponent := Long_Unsigned (S (1) - BS); + else + Is_Positive := True; + Exponent := Long_Unsigned (S (1)); + end if; + + for N in 2 .. E_Bytes loop + Exponent := Exponent * BB + Long_Unsigned (S (N)); + end loop; + Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + + -- NaN or Infinities + + if Integer (Exponent) = E_Last then + raise Constraint_Error; + + elsif Exponent = 0 then + + -- Signed zeros + + if Fraction = 0 then + null; + + -- Denormalized float + + else + Result := Short_Float'Scaling (Result, 1 - E_Bias); + end if; + + -- Normalized float + + else + Result := Short_Float'Scaling + (1.0 + Result, Integer (Exponent) - E_Bias); + end if; + + if not Is_Positive then + Result := -Result; + end if; + + return Result; + end I_SF; + + ---------- + -- I_SI -- + ---------- + + function I_SI (Stream : not null access RST) return Short_Integer is + S : XDR_S_SI; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SI_To_Short_Integer (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Integer (U); + else + return Short_Integer (-((XDR_SU'Last xor U) + 1)); + end if; + end if; + end I_SI; + + ----------- + -- I_SSI -- + ----------- + + function I_SSI (Stream : not null access RST) return Short_Short_Integer is + S : XDR_S_SSI; + L : SEO; + U : XDR_SSU; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SSI_To_Short_Short_Integer (S); + + else + U := XDR_SSU (S (1)); + + -- Test sign and apply two complement notation + + if S (1) < BL then + return Short_Short_Integer (U); + else + return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); + end if; + end if; + end I_SSI; + + ----------- + -- I_SSU -- + ----------- + + function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is + S : XDR_S_SSU; + L : SEO; + U : XDR_SSU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + U := XDR_SSU (S (1)); + return Short_Short_Unsigned (U); + end if; + end I_SSU; + + ---------- + -- I_SU -- + ---------- + + function I_SU (Stream : not null access RST) return Short_Unsigned is + S : XDR_S_SU; + L : SEO; + U : XDR_SU := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_SU_To_Short_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_SU (S (N)); + end loop; + + return Short_Unsigned (U); + end if; + end I_SU; + + --------- + -- I_U -- + --------- + + function I_U (Stream : not null access RST) return Unsigned is + S : XDR_S_U; + L : SEO; + U : XDR_U := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + elsif Optimize_Integers then + return XDR_S_U_To_Unsigned (S); + + else + for N in S'Range loop + U := U * BB + XDR_U (S (N)); + end loop; + + return Unsigned (U); + end if; + end I_U; + + ---------- + -- I_WC -- + ---------- + + function I_WC (Stream : not null access RST) return Wide_Character is + S : XDR_S_WC; + L : SEO; + U : XDR_WC := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_WC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Character representation clause + + return Wide_Character'Val (U); + end if; + end I_WC; + + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + S : XDR_S_WWC; + L : SEO; + U : XDR_WWC := 0; + + begin + Ada.Streams.Read (Stream.all, S, L); + + if L /= S'Last then + raise Data_Error; + + else + for N in S'Range loop + U := U * BB + XDR_WWC (S (N)); + end loop; + + -- Use Ada requirements on Wide_Wide_Character representation clause + + return Wide_Wide_Character'Val (U); + end if; + end I_WWC; + + ---------- + -- W_AD -- + ---------- + + procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is + S : XDR_S_TM; + U : XDR_TM; + + begin + U := XDR_TM (To_XDR_SA (Item.P1)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + U := XDR_TM (To_XDR_SA (Item.P2)); + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AD; + + ---------- + -- W_AS -- + ---------- + + procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is + S : XDR_S_TM; + U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); + + begin + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_AS; + + --------- + -- W_B -- + --------- + + procedure W_B (Stream : not null access RST; Item : Boolean) is + begin + if Item then + W_SSU (Stream, 1); + else + W_SSU (Stream, 0); + end if; + end W_B; + + --------- + -- W_C -- + --------- + + procedure W_C (Stream : not null access RST; Item : Character) is + S : XDR_S_C; + + pragma Assert (C_L = 1); + + begin + -- Use Ada requirements on Character representation clause + + S (1) := SE (Character'Pos (Item)); + + Ada.Streams.Write (Stream.all, S); + end W_C; + + --------- + -- W_F -- + --------- + + procedure W_F (Stream : not null access RST; Item : Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Float; + S : SEA (1 .. F_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Float'Scaling (F, F_Size + E_Bias - 1); + E := -E_Bias; + else + F := Float'Scaling (Float'Fraction (F), F_Size + 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse F_L - F_Bytes + 1 .. F_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_F; + + --------- + -- W_I -- + --------- + + procedure W_I (Stream : not null access RST; Item : Integer) is + S : XDR_S_I; + U : XDR_U; + + begin + if Optimize_Integers then + S := Integer_To_XDR_S_I (Item); + + else + -- Test sign and apply two complement notation + + U := (if Item < 0 + then XDR_U'Last xor XDR_U (-(Item + 1)) + else XDR_U (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_I; + + ---------- + -- W_LF -- + ---------- + + procedure W_LF (Stream : not null access RST; Item : Long_Float) is + I : constant Precision := Double; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Long_Float; + S : SEA (1 .. LF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Long_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Long_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse LF_L - F_Bytes + 1 .. LF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LF; + + ---------- + -- W_LI -- + ---------- + + procedure W_LI (Stream : not null access RST; Item : Long_Integer) is + S : XDR_S_LI; + U : Unsigned; + X : Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); + else + X := Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LI; + + ----------- + -- W_LLF -- + ----------- + + procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is + I : constant Precision := Quadruple; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + + HFS : constant Integer := F_Size / 2; + + Exponent : Long_Unsigned; + Fraction_1 : Long_Long_Unsigned; + Fraction_2 : Long_Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Long_Long_Float := Item; + S : SEA (1 .. LLF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + + if F < 0.0 then + F := -Item; + end if; + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction_1 := 0; + Fraction_2 := 0; + + else + E := Long_Long_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + F := Long_Long_Float'Scaling (F, E_Bias - 1); + E := -E_Bias; + else + F := Long_Long_Float'Scaling + (Long_Long_Float'Fraction (F), 1); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + F := Long_Long_Float'Scaling (F, F_Size - HFS); + Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + F := F - Long_Long_Float (Fraction_1); + F := Long_Long_Float'Scaling (F, HFS); + Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); + end if; + + -- Store Fraction_1 + + for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop + S (I) := SE (Fraction_1 mod BB); + Fraction_1 := Fraction_1 / BB; + end loop; + + -- Store Fraction_2 + + for I in reverse LLF_L - 6 .. LLF_L loop + S (SEO (I)) := SE (Fraction_2 mod BB); + Fraction_2 := Fraction_2 / BB; + end loop; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLF; + + ----------- + -- W_LLI -- + ----------- + + procedure W_LLI + (Stream : not null access RST; + Item : Long_Long_Integer) + is + S : XDR_S_LLI; + U : Unsigned; + X : Long_Long_Unsigned; + + begin + if Optimize_Integers then + S := Long_Long_Integer_To_XDR_S_LLI (Item); + + else + -- Test sign and apply two complement notation + + if Item < 0 then + X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); + else + X := Long_Long_Unsigned (Item); + end if; + + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLI; + + ----------- + -- W_LLU -- + ----------- + + procedure W_LLU + (Stream : not null access RST; + Item : Long_Long_Unsigned) + is + S : XDR_S_LLU; + U : Unsigned; + X : Long_Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LLU (Item); + + else + -- Compute using machine unsigned rather than long_long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LLU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LLU; + + ---------- + -- W_LU -- + ---------- + + procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is + S : XDR_S_LU; + U : Unsigned; + X : Long_Unsigned := Item; + + begin + if Optimize_Integers then + S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); + + else + -- Compute using machine unsigned rather than long_unsigned + + for N in reverse S'Range loop + + -- We have filled an unsigned + + if (LU_L - N) mod UB = 0 then + U := Unsigned (X and UL); + X := Shift_Right (X, US); + end if; + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_LU; + + ---------- + -- W_SF -- + ---------- + + procedure W_SF (Stream : not null access RST; Item : Short_Float) is + I : constant Precision := Single; + E_Size : Integer renames Fields (I).E_Size; + E_Bias : Integer renames Fields (I).E_Bias; + E_Bytes : SEO renames Fields (I).E_Bytes; + F_Bytes : SEO renames Fields (I).F_Bytes; + F_Size : Integer renames Fields (I).F_Size; + F_Mask : SE renames Fields (I).F_Mask; + + Exponent : Long_Unsigned; + Fraction : Long_Unsigned; + Is_Positive : Boolean; + E : Integer; + F : Short_Float; + S : SEA (1 .. SF_L) := (others => 0); + + begin + if not Item'Valid then + raise Constraint_Error; + end if; + + -- Compute Sign + + Is_Positive := (0.0 <= Item); + F := abs (Item); + + -- Signed zero + + if F = 0.0 then + Exponent := 0; + Fraction := 0; + + else + E := Short_Float'Exponent (F) - 1; + + -- Denormalized float + + if E <= -E_Bias then + E := -E_Bias; + F := Short_Float'Scaling (F, F_Size + E_Bias - 1); + else + F := Short_Float'Scaling (F, F_Size - E); + end if; + + -- Compute Exponent and Fraction + + Exponent := Long_Unsigned (E + E_Bias); + Fraction := Long_Unsigned (F * 2.0) / 2; + end if; + + -- Store Fraction + + for I in reverse SF_L - F_Bytes + 1 .. SF_L loop + S (I) := SE (Fraction mod BB); + Fraction := Fraction / BB; + end loop; + + -- Remove implicit bit + + S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; + + -- Store Exponent (not always at the beginning of a byte) + + Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); + for N in reverse 1 .. E_Bytes loop + S (N) := SE (Exponent mod BB) + S (N); + Exponent := Exponent / BB; + end loop; + + -- Store Sign + + if not Is_Positive then + S (1) := S (1) + BS; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SF; + + ---------- + -- W_SI -- + ---------- + + procedure W_SI (Stream : not null access RST; Item : Short_Integer) is + S : XDR_S_SI; + U : XDR_SU; + + begin + if Optimize_Integers then + S := Short_Integer_To_XDR_S_SI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SU'Last xor XDR_SU (-(Item + 1)) + else XDR_SU (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SI; + + ----------- + -- W_SSI -- + ----------- + + procedure W_SSI + (Stream : not null access RST; + Item : Short_Short_Integer) + is + S : XDR_S_SSI; + U : XDR_SSU; + + begin + if Optimize_Integers then + S := Short_Short_Integer_To_XDR_S_SSI (Item); + + else + -- Test sign and apply two complement's notation + + U := (if Item < 0 + then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) + else XDR_SSU (Item)); + + S (1) := SE (U); + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SSI; + + ----------- + -- W_SSU -- + ----------- + + procedure W_SSU + (Stream : not null access RST; + Item : Short_Short_Unsigned) + is + U : constant XDR_SSU := XDR_SSU (Item); + S : XDR_S_SSU; + + begin + S (1) := SE (U); + Ada.Streams.Write (Stream.all, S); + end W_SSU; + + ---------- + -- W_SU -- + ---------- + + procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is + S : XDR_S_SU; + U : XDR_SU := XDR_SU (Item); + + begin + if Optimize_Integers then + S := Short_Unsigned_To_XDR_S_SU (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_SU; + + --------- + -- W_U -- + --------- + + procedure W_U (Stream : not null access RST; Item : Unsigned) is + S : XDR_S_U; + U : XDR_U := XDR_U (Item); + + begin + if Optimize_Integers then + S := Unsigned_To_XDR_S_U (Item); + + else + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + if U /= 0 then + raise Data_Error; + end if; + end if; + + Ada.Streams.Write (Stream.all, S); + end W_U; + + ---------- + -- W_WC -- + ---------- + + procedure W_WC (Stream : not null access RST; Item : Wide_Character) is + S : XDR_S_WC; + U : XDR_WC; + + begin + -- Use Ada requirements on Wide_Character representation clause + + U := XDR_WC (Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WC; + + ----------- + -- W_WWC -- + ----------- + + procedure W_WWC + (Stream : not null access RST; Item : Wide_Wide_Character) + is + S : XDR_S_WWC; + U : XDR_WWC; + + begin + -- Use Ada requirements on Wide_Wide_Character representation clause + + U := XDR_WWC (Wide_Wide_Character'Pos (Item)); + + for N in reverse S'Range loop + S (N) := SE (U mod BB); + U := U / BB; + end loop; + + Ada.Streams.Write (Stream.all, S); + + if U /= 0 then + raise Data_Error; + end if; + end W_WWC; + +end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-stratt.adb b/gcc/ada/libgnat/s-stratt.adb new file mode 100644 index 0000000..91196f7 --- /dev/null +++ b/gcc/ada/libgnat/s-stratt.adb @@ -0,0 +1,708 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R E A M _ A T T R I B U T E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.IO_Exceptions; +with Ada.Streams; use Ada.Streams; +with Ada.Unchecked_Conversion; + +package body System.Stream_Attributes is + + Err : exception renames Ada.IO_Exceptions.End_Error; + -- Exception raised if insufficient data read (note that the RM implies + -- that Data_Error might be the appropriate choice, but AI95-00132 + -- decides with a binding interpretation that End_Error is preferred). + + SU : constant := System.Storage_Unit; + + subtype SEA is Ada.Streams.Stream_Element_Array; + subtype SEO is Ada.Streams.Stream_Element_Offset; + + generic function UC renames Ada.Unchecked_Conversion; + + -- Subtypes used to define Stream_Element_Array values that map + -- into the elementary types, using unchecked conversion. + + Thin_Pointer_Size : constant := System.Address'Size; + Fat_Pointer_Size : constant := System.Address'Size * 2; + + subtype S_AD is SEA (1 .. (Fat_Pointer_Size + SU - 1) / SU); + subtype S_AS is SEA (1 .. (Thin_Pointer_Size + SU - 1) / SU); + subtype S_B is SEA (1 .. (Boolean'Size + SU - 1) / SU); + subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU); + subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU); + subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU); + subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU); + subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU); + subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU); + subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size + SU - 1) / SU); + subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size + SU - 1) / SU); + subtype S_LU is SEA (1 .. (UST.Long_Unsigned'Size + SU - 1) / SU); + subtype S_SF is SEA (1 .. (Short_Float'Size + SU - 1) / SU); + subtype S_SI is SEA (1 .. (Short_Integer'Size + SU - 1) / SU); + subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size + SU - 1) / SU); + subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU); + subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU); + subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU); + subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU); + subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size + SU - 1) / SU); + + -- Unchecked conversions from the elementary type to the stream type + + function From_AD is new UC (Fat_Pointer, S_AD); + function From_AS is new UC (Thin_Pointer, S_AS); + function From_F is new UC (Float, S_F); + function From_I is new UC (Integer, S_I); + function From_LF is new UC (Long_Float, S_LF); + function From_LI is new UC (Long_Integer, S_LI); + function From_LLF is new UC (Long_Long_Float, S_LLF); + function From_LLI is new UC (Long_Long_Integer, S_LLI); + function From_LLU is new UC (UST.Long_Long_Unsigned, S_LLU); + function From_LU is new UC (UST.Long_Unsigned, S_LU); + function From_SF is new UC (Short_Float, S_SF); + function From_SI is new UC (Short_Integer, S_SI); + function From_SSI is new UC (Short_Short_Integer, S_SSI); + function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU); + function From_SU is new UC (UST.Short_Unsigned, S_SU); + function From_U is new UC (UST.Unsigned, S_U); + function From_WC is new UC (Wide_Character, S_WC); + function From_WWC is new UC (Wide_Wide_Character, S_WWC); + + -- Unchecked conversions from the stream type to elementary type + + function To_AD is new UC (S_AD, Fat_Pointer); + function To_AS is new UC (S_AS, Thin_Pointer); + function To_F is new UC (S_F, Float); + function To_I is new UC (S_I, Integer); + function To_LF is new UC (S_LF, Long_Float); + function To_LI is new UC (S_LI, Long_Integer); + function To_LLF is new UC (S_LLF, Long_Long_Float); + function To_LLI is new UC (S_LLI, Long_Long_Integer); + function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned); + function To_LU is new UC (S_LU, UST.Long_Unsigned); + function To_SF is new UC (S_SF, Short_Float); + function To_SI is new UC (S_SI, Short_Integer); + function To_SSI is new UC (S_SSI, Short_Short_Integer); + function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned); + function To_SU is new UC (S_SU, UST.Short_Unsigned); + function To_U is new UC (S_U, UST.Unsigned); + function To_WC is new UC (S_WC, Wide_Character); + function To_WWC is new UC (S_WWC, Wide_Wide_Character); + + ----------------- + -- Block_IO_OK -- + ----------------- + + function Block_IO_OK return Boolean is + begin + return True; + end Block_IO_OK; + + ---------- + -- I_AD -- + ---------- + + function I_AD (Stream : not null access RST) return Fat_Pointer is + T : S_AD; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_AD (T); + end if; + end I_AD; + + ---------- + -- I_AS -- + ---------- + + function I_AS (Stream : not null access RST) return Thin_Pointer is + T : S_AS; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_AS (T); + end if; + end I_AS; + + --------- + -- I_B -- + --------- + + function I_B (Stream : not null access RST) return Boolean is + T : S_B; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return Boolean'Val (T (1)); + end if; + end I_B; + + --------- + -- I_C -- + --------- + + function I_C (Stream : not null access RST) return Character is + T : S_C; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return Character'Val (T (1)); + end if; + end I_C; + + --------- + -- I_F -- + --------- + + function I_F (Stream : not null access RST) return Float is + T : S_F; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_F (T); + end if; + end I_F; + + --------- + -- I_I -- + --------- + + function I_I (Stream : not null access RST) return Integer is + T : S_I; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_I (T); + end if; + end I_I; + + ---------- + -- I_LF -- + ---------- + + function I_LF (Stream : not null access RST) return Long_Float is + T : S_LF; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LF (T); + end if; + end I_LF; + + ---------- + -- I_LI -- + ---------- + + function I_LI (Stream : not null access RST) return Long_Integer is + T : S_LI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LI (T); + end if; + end I_LI; + + ----------- + -- I_LLF -- + ----------- + + function I_LLF (Stream : not null access RST) return Long_Long_Float is + T : S_LLF; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LLF (T); + end if; + end I_LLF; + + ----------- + -- I_LLI -- + ----------- + + function I_LLI (Stream : not null access RST) return Long_Long_Integer is + T : S_LLI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LLI (T); + end if; + end I_LLI; + + ----------- + -- I_LLU -- + ----------- + + function I_LLU + (Stream : not null access RST) return UST.Long_Long_Unsigned + is + T : S_LLU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LLU (T); + end if; + end I_LLU; + + ---------- + -- I_LU -- + ---------- + + function I_LU (Stream : not null access RST) return UST.Long_Unsigned is + T : S_LU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_LU (T); + end if; + end I_LU; + + ---------- + -- I_SF -- + ---------- + + function I_SF (Stream : not null access RST) return Short_Float is + T : S_SF; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SF (T); + end if; + end I_SF; + + ---------- + -- I_SI -- + ---------- + + function I_SI (Stream : not null access RST) return Short_Integer is + T : S_SI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SI (T); + end if; + end I_SI; + + ----------- + -- I_SSI -- + ----------- + + function I_SSI (Stream : not null access RST) return Short_Short_Integer is + T : S_SSI; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SSI (T); + end if; + end I_SSI; + + ----------- + -- I_SSU -- + ----------- + + function I_SSU + (Stream : not null access RST) return UST.Short_Short_Unsigned + is + T : S_SSU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SSU (T); + end if; + end I_SSU; + + ---------- + -- I_SU -- + ---------- + + function I_SU (Stream : not null access RST) return UST.Short_Unsigned is + T : S_SU; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_SU (T); + end if; + end I_SU; + + --------- + -- I_U -- + --------- + + function I_U (Stream : not null access RST) return UST.Unsigned is + T : S_U; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_U (T); + end if; + end I_U; + + ---------- + -- I_WC -- + ---------- + + function I_WC (Stream : not null access RST) return Wide_Character is + T : S_WC; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_WC (T); + end if; + end I_WC; + + ----------- + -- I_WWC -- + ----------- + + function I_WWC (Stream : not null access RST) return Wide_Wide_Character is + T : S_WWC; + L : SEO; + + begin + Ada.Streams.Read (Stream.all, T, L); + + if L < T'Last then + raise Err; + else + return To_WWC (T); + end if; + end I_WWC; + + ---------- + -- W_AD -- + ---------- + + procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is + T : constant S_AD := From_AD (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_AD; + + ---------- + -- W_AS -- + ---------- + + procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is + T : constant S_AS := From_AS (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_AS; + + --------- + -- W_B -- + --------- + + procedure W_B (Stream : not null access RST; Item : Boolean) is + T : S_B; + begin + T (1) := Boolean'Pos (Item); + Ada.Streams.Write (Stream.all, T); + end W_B; + + --------- + -- W_C -- + --------- + + procedure W_C (Stream : not null access RST; Item : Character) is + T : S_C; + begin + T (1) := Character'Pos (Item); + Ada.Streams.Write (Stream.all, T); + end W_C; + + --------- + -- W_F -- + --------- + + procedure W_F (Stream : not null access RST; Item : Float) is + T : constant S_F := From_F (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_F; + + --------- + -- W_I -- + --------- + + procedure W_I (Stream : not null access RST; Item : Integer) is + T : constant S_I := From_I (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_I; + + ---------- + -- W_LF -- + ---------- + + procedure W_LF (Stream : not null access RST; Item : Long_Float) is + T : constant S_LF := From_LF (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_LF; + + ---------- + -- W_LI -- + ---------- + + procedure W_LI (Stream : not null access RST; Item : Long_Integer) is + T : constant S_LI := From_LI (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_LI; + + ----------- + -- W_LLF -- + ----------- + + procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is + T : constant S_LLF := From_LLF (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_LLF; + + ----------- + -- W_LLI -- + ----------- + + procedure W_LLI + (Stream : not null access RST; Item : Long_Long_Integer) + is + T : constant S_LLI := From_LLI (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_LLI; + + ----------- + -- W_LLU -- + ----------- + + procedure W_LLU + (Stream : not null access RST; Item : UST.Long_Long_Unsigned) + is + T : constant S_LLU := From_LLU (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_LLU; + + ---------- + -- W_LU -- + ---------- + + procedure W_LU + (Stream : not null access RST; Item : UST.Long_Unsigned) + is + T : constant S_LU := From_LU (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_LU; + + ---------- + -- W_SF -- + ---------- + + procedure W_SF (Stream : not null access RST; Item : Short_Float) is + T : constant S_SF := From_SF (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_SF; + + ---------- + -- W_SI -- + ---------- + + procedure W_SI (Stream : not null access RST; Item : Short_Integer) is + T : constant S_SI := From_SI (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_SI; + + ----------- + -- W_SSI -- + ----------- + + procedure W_SSI + (Stream : not null access RST; Item : Short_Short_Integer) + is + T : constant S_SSI := From_SSI (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_SSI; + + ----------- + -- W_SSU -- + ----------- + + procedure W_SSU + (Stream : not null access RST; Item : UST.Short_Short_Unsigned) + is + T : constant S_SSU := From_SSU (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_SSU; + + ---------- + -- W_SU -- + ---------- + + procedure W_SU + (Stream : not null access RST; Item : UST.Short_Unsigned) + is + T : constant S_SU := From_SU (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_SU; + + --------- + -- W_U -- + --------- + + procedure W_U (Stream : not null access RST; Item : UST.Unsigned) is + T : constant S_U := From_U (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_U; + + ---------- + -- W_WC -- + ---------- + + procedure W_WC (Stream : not null access RST; Item : Wide_Character) is + T : constant S_WC := From_WC (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_WC; + + ----------- + -- W_WWC -- + ----------- + + procedure W_WWC + (Stream : not null access RST; Item : Wide_Wide_Character) + is + T : constant S_WWC := From_WWC (Item); + begin + Ada.Streams.Write (Stream.all, T); + end W_WWC; + +end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-stratt.ads b/gcc/ada/libgnat/s-stratt.ads new file mode 100644 index 0000000..ce0dfa2 --- /dev/null +++ b/gcc/ada/libgnat/s-stratt.ads @@ -0,0 +1,207 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . S T R E A M _ A T T R I B U T E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the implementations of the stream attributes for +-- elementary types. These are the subprograms that are directly accessed +-- by occurrences of the stream attributes where the type is elementary. + +-- We only provide the subprograms for the standard base types. For user +-- defined types, the subprogram for the corresponding root type is called +-- with an appropriate conversion. + +with System; +with System.Unsigned_Types; +with Ada.Streams; + +package System.Stream_Attributes is + pragma Preelaborate; + + pragma Suppress (Accessibility_Check, Stream_Attributes); + -- No need to check accessibility on arguments of subprograms + + package UST renames System.Unsigned_Types; + + subtype RST is Ada.Streams.Root_Stream_Type'Class; + + subtype SEC is Ada.Streams.Stream_Element_Count; + + -- Enumeration types are usually transferred using the routine for the + -- corresponding integer. The exception is that special routines are + -- provided for Boolean and the character types, in case the protocol + -- in use provides specially for these types. + + -- Access types use either a thin pointer (single address) or fat pointer + -- (double address) form. The following types are used to hold access + -- values using unchecked conversions. + + type Thin_Pointer is record + P1 : System.Address; + end record; + + type Fat_Pointer is record + P1 : System.Address; + P2 : System.Address; + end record; + + ------------------------------------ + -- Treatment of enumeration types -- + ------------------------------------ + + -- In this interface, there are no specific routines for general input + -- or output of enumeration types. Generally, enumeration types whose + -- representation is unsigned (no negative representation values) are + -- treated as unsigned integers, and enumeration types that do have + -- negative representation values are treated as signed integers. + + -- An exception is that there are specialized routines for Boolean, + -- Character, and Wide_Character types, but these specialized routines + -- are used only if the type in question has a standard representation. + -- For the case of a non-standard representation (one where the size of + -- the first subtype is specified, or where an enumeration representation + -- clause is given), these three types are treated like any other cases + -- of enumeration types, as described above. + + --------------------- + -- Input Functions -- + --------------------- + + -- Functions for S'Input attribute. These functions are also used for + -- S'Read, with the obvious transformation, since the input operation + -- is the same for all elementary types (no bounds or discriminants + -- are involved). + + function I_AD (Stream : not null access RST) return Fat_Pointer; + function I_AS (Stream : not null access RST) return Thin_Pointer; + function I_B (Stream : not null access RST) return Boolean; + function I_C (Stream : not null access RST) return Character; + function I_F (Stream : not null access RST) return Float; + function I_I (Stream : not null access RST) return Integer; + function I_LF (Stream : not null access RST) return Long_Float; + function I_LI (Stream : not null access RST) return Long_Integer; + function I_LLF (Stream : not null access RST) return Long_Long_Float; + function I_LLI (Stream : not null access RST) return Long_Long_Integer; + function I_LLU (Stream : not null access RST) return UST.Long_Long_Unsigned; + function I_LU (Stream : not null access RST) return UST.Long_Unsigned; + function I_SF (Stream : not null access RST) return Short_Float; + function I_SI (Stream : not null access RST) return Short_Integer; + function I_SSI (Stream : not null access RST) return Short_Short_Integer; + function I_SSU (Stream : not null access RST) return + UST.Short_Short_Unsigned; + function I_SU (Stream : not null access RST) return UST.Short_Unsigned; + function I_U (Stream : not null access RST) return UST.Unsigned; + function I_WC (Stream : not null access RST) return Wide_Character; + function I_WWC (Stream : not null access RST) return Wide_Wide_Character; + + ----------------------- + -- Output Procedures -- + ----------------------- + + -- Procedures for S'Write attribute. These procedures are also used for + -- 'Output, since for elementary types there is no difference between + -- 'Write and 'Output because there are no discriminants or bounds to + -- be written. + + procedure W_AD (Stream : not null access RST; Item : Fat_Pointer); + procedure W_AS (Stream : not null access RST; Item : Thin_Pointer); + procedure W_B (Stream : not null access RST; Item : Boolean); + procedure W_C (Stream : not null access RST; Item : Character); + procedure W_F (Stream : not null access RST; Item : Float); + procedure W_I (Stream : not null access RST; Item : Integer); + procedure W_LF (Stream : not null access RST; Item : Long_Float); + procedure W_LI (Stream : not null access RST; Item : Long_Integer); + procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float); + procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer); + procedure W_LLU (Stream : not null access RST; Item : + UST.Long_Long_Unsigned); + procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned); + procedure W_SF (Stream : not null access RST; Item : Short_Float); + procedure W_SI (Stream : not null access RST; Item : Short_Integer); + procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer); + procedure W_SSU (Stream : not null access RST; Item : + UST.Short_Short_Unsigned); + procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned); + procedure W_U (Stream : not null access RST; Item : UST.Unsigned); + procedure W_WC (Stream : not null access RST; Item : Wide_Character); + procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character); + + function Block_IO_OK return Boolean; + -- Package System.Stream_Attributes has several bodies - the default one + -- distributed with GNAT, and s-stratt-xdr.adb, which is based on the XDR + -- standard. Both bodies share the same spec. The role of this function is + -- to indicate whether the current version of System.Stream_Attributes + -- supports block IO. See System.Strings.Stream_Ops (s-ststop) for details. + +private + pragma Inline (I_AD); + pragma Inline (I_AS); + pragma Inline (I_B); + pragma Inline (I_C); + pragma Inline (I_F); + pragma Inline (I_I); + pragma Inline (I_LF); + pragma Inline (I_LI); + pragma Inline (I_LLF); + pragma Inline (I_LLI); + pragma Inline (I_LLU); + pragma Inline (I_LU); + pragma Inline (I_SF); + pragma Inline (I_SI); + pragma Inline (I_SSI); + pragma Inline (I_SSU); + pragma Inline (I_SU); + pragma Inline (I_U); + pragma Inline (I_WC); + pragma Inline (I_WWC); + + pragma Inline (W_AD); + pragma Inline (W_AS); + pragma Inline (W_B); + pragma Inline (W_C); + pragma Inline (W_F); + pragma Inline (W_I); + pragma Inline (W_LF); + pragma Inline (W_LI); + pragma Inline (W_LLF); + pragma Inline (W_LLI); + pragma Inline (W_LLU); + pragma Inline (W_LU); + pragma Inline (W_SF); + pragma Inline (W_SI); + pragma Inline (W_SSI); + pragma Inline (W_SSU); + pragma Inline (W_SU); + pragma Inline (W_U); + pragma Inline (W_WC); + pragma Inline (W_WWC); + + pragma Inline (Block_IO_OK); + +end System.Stream_Attributes; diff --git a/gcc/ada/libgnat/s-strcom.adb b/gcc/ada/libgnat/s-strcom.adb new file mode 100644 index 0000000..1ac7e08 --- /dev/null +++ b/gcc/ada/libgnat/s-strcom.adb @@ -0,0 +1,140 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ C O M P A R E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Conversion; + +package body System.String_Compare is + + type Word is mod 2 ** 32; + -- Used to process operands by words + + type Big_Words is array (Natural) of Word; + type Big_Words_Ptr is access Big_Words; + for Big_Words_Ptr'Storage_Size use 0; + -- Array type used to access by words + + type Byte is mod 2 ** 8; + -- Used to process operands by bytes + + type Big_Bytes is array (Natural) of Byte; + type Big_Bytes_Ptr is access Big_Bytes; + for Big_Bytes_Ptr'Storage_Size use 0; + -- Array type used to access by bytes + + function To_Big_Words is new + Ada.Unchecked_Conversion (System.Address, Big_Words_Ptr); + + function To_Big_Bytes is new + Ada.Unchecked_Conversion (System.Address, Big_Bytes_Ptr); + + ----------------- + -- Str_Compare -- + ----------------- + + function Str_Compare + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); + + begin + -- If operands are non-aligned, or length is too short, go by bytes + + if (((Left or Right) and 2#11#) /= 0) or else Compare_Len < 4 then + return Str_Compare_Bytes (Left, Right, Left_Len, Right_Len); + end if; + + -- Here we can go by words + + declare + LeftP : constant Big_Words_Ptr := To_Big_Words (Left); + RightP : constant Big_Words_Ptr := To_Big_Words (Right); + Clen4 : constant Natural := Compare_Len / 4 - 1; + Clen4F : constant Natural := Clen4 * 4; + + begin + for J in 0 .. Clen4 loop + if LeftP (J) /= RightP (J) then + return Str_Compare_Bytes + (Left + Address (4 * J), + Right + Address (4 * J), + 4, 4); + end if; + end loop; + + return Str_Compare_Bytes + (Left + Address (Clen4F), + Right + Address (Clen4F), + Left_Len - Clen4F, + Right_Len - Clen4F); + end; + end Str_Compare; + + ----------------------- + -- Str_Compare_Bytes -- + ----------------------- + + function Str_Compare_Bytes + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer + is + Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); + + LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left); + RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right); + + begin + for J in 0 .. Compare_Len - 1 loop + if LeftP (J) /= RightP (J) then + if LeftP (J) > RightP (J) then + return +1; + else + return -1; + end if; + end if; + end loop; + + if Left_Len = Right_Len then + return 0; + elsif Left_Len > Right_Len then + return +1; + else + return -1; + end if; + end Str_Compare_Bytes; + +end System.String_Compare; diff --git a/gcc/ada/libgnat/s-strcom.ads b/gcc/ada/libgnat/s-strcom.ads new file mode 100644 index 0000000..8315f37 --- /dev/null +++ b/gcc/ada/libgnat/s-strcom.ads @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ C O M P A R E -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime comparisons on strings + +pragma Compiler_Unit_Warning; + +package System.String_Compare is + + function Str_Compare + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Compare the string starting at address Left of length Left_Len + -- with the string starting at address Right of length Right_Len. + -- The comparison is in the normal Ada semantic sense of string + -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words + -- if the operands are aligned on 4-byte boundaries and long enough. + + function Str_Compare_Bytes + (Left : System.Address; + Right : System.Address; + Left_Len : Natural; + Right_Len : Natural) return Integer; + -- Same functionality as Str_Compare but always proceeds by bytes. + -- Used when the caller knows that the operands are unaligned, or + -- short enough that it makes no sense to go by words. + +end System.String_Compare; diff --git a/gcc/ada/libgnat/s-strhas.adb b/gcc/ada/libgnat/s-strhas.adb new file mode 100644 index 0000000..98bc154 --- /dev/null +++ b/gcc/ada/libgnat/s-strhas.adb @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.String_Hash is + + -- Compute a hash value for a key. The approach here follows the algorithm + -- introduced in the ndbm substitute SDBM by Ozan Yigit and then reused in + -- GNU Awk (where they are implemented as a Duff's device). + + ---------- + -- Hash -- + ---------- + + function Hash (Key : Key_Type) return Hash_Type is + + pragma Compile_Time_Error + (Hash_Type'Modulus /= 2 ** 32 + or else Hash_Type'First /= 0 + or else Hash_Type'Last /= 2 ** 32 - 1, + "Hash_Type must be 32-bit modular with range 0 .. 2**32-1"); + + function Shift_Left + (Value : Hash_Type; + Amount : Natural) return Hash_Type; + pragma Import (Intrinsic, Shift_Left); + + H : Hash_Type; + + begin + H := 0; + for J in Key'Range loop + H := Char_Type'Pos (Key (J)) + + Shift_Left (H, 6) + Shift_Left (H, 16) - H; + end loop; + + return H; + end Hash; + +end System.String_Hash; diff --git a/gcc/ada/libgnat/s-strhas.ads b/gcc/ada/libgnat/s-strhas.ads new file mode 100644 index 0000000..444d7fe --- /dev/null +++ b/gcc/ada/libgnat/s-strhas.ads @@ -0,0 +1,64 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ H A S H -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 generic hashing function over strings, suitable for +-- use with a string keyed hash table. In particular, it is the basis for the +-- string hash functions in Ada.Containers. +-- +-- The algorithm used here is not appropriate for applications that require +-- cryptographically strong hashes, or for application which wish to use very +-- wide hash values as pseudo unique identifiers. In such cases please refer +-- to GNAT.SHA1 and GNAT.MD5. +-- +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.String_Hash (file g-strhas.ads). + +package System.String_Hash is + pragma Pure; + + generic + type Char_Type is (<>); + -- The character type composing the key string type + + type Key_Type is array (Positive range <>) of Char_Type; + -- The string type to use as a hash key + + type Hash_Type is mod <>; + -- The type to be returned as a hash value. This must be a 32-bit + -- unsigned type with full range 0 .. 2**32-1, no other type is allowed + -- for this instantiation (checked in the body by Compile_Time_Error). + + function Hash (Key : Key_Type) return Hash_Type; + pragma Inline (Hash); + -- Compute a hash value for a key + +end System.String_Hash; diff --git a/gcc/ada/libgnat/s-string.adb b/gcc/ada/libgnat/s-string.adb new file mode 100644 index 0000000..92b55d7 --- /dev/null +++ b/gcc/ada/libgnat/s-string.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.Strings is + + ---------- + -- Free -- + ---------- + + procedure Free (Arg : in out String_List_Access) is + + procedure Free_Array is new Ada.Unchecked_Deallocation + (Object => String_List, Name => String_List_Access); + + begin + -- First free all the String_Access components if any + + if Arg /= null then + for J in Arg'Range loop + Free (Arg (J)); + end loop; + end if; + + -- Now free the allocated array + + Free_Array (Arg); + end Free; + +end System.Strings; diff --git a/gcc/ada/libgnat/s-string.ads b/gcc/ada/libgnat/s-string.ads new file mode 100644 index 0000000..d6fff14 --- /dev/null +++ b/gcc/ada/libgnat/s-string.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Common String access types and related subprograms + +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.String (file g-string.ads). + +pragma Compiler_Unit_Warning; + +with Ada.Unchecked_Deallocation; + +package System.Strings is + pragma Preelaborate; + + type String_Access is access all String; + -- General purpose string access type. Note that the caller is + -- responsible for freeing allocated strings to avoid memory leaks. + + procedure Free is new Ada.Unchecked_Deallocation + (Object => String, Name => String_Access); + -- This procedure is provided for freeing allocated values of type + -- String_Access. + + type String_List is array (Positive range <>) of String_Access; + type String_List_Access is access all String_List; + -- General purpose array and pointer for list of string accesses + + procedure Free (Arg : in out String_List_Access); + -- Frees the given array and all strings that its elements reference, + -- and then sets the argument to null. Provided for freeing allocated + -- values of this type. + +end System.Strings; diff --git a/gcc/ada/libgnat/s-strops.adb b/gcc/ada/libgnat/s-strops.adb new file mode 100644 index 0000000..3665cf1 --- /dev/null +++ b/gcc/ada/libgnat/s-strops.adb @@ -0,0 +1,109 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package body System.String_Ops is + + ---------------- + -- Str_Concat -- + ---------------- + + function Str_Concat (X, Y : String) return String is + begin + if X'Length = 0 then + return Y; + + else + declare + L : constant Natural := X'Length + Y'Length; + R : String (X'First .. X'First + L - 1); + + begin + R (X'Range) := X; + R (X'First + X'Length .. R'Last) := Y; + return R; + end; + end if; + end Str_Concat; + + ------------------- + -- Str_Concat_CC -- + ------------------- + + function Str_Concat_CC (X, Y : Character) return String is + R : String (1 .. 2); + + begin + R (1) := X; + R (2) := Y; + return R; + end Str_Concat_CC; + + ------------------- + -- Str_Concat_CS -- + ------------------- + + function Str_Concat_CS (X : Character; Y : String) return String is + R : String (1 .. Y'Length + 1); + + begin + R (1) := X; + R (2 .. R'Last) := Y; + return R; + end Str_Concat_CS; + + ------------------- + -- Str_Concat_SC -- + ------------------- + + function Str_Concat_SC (X : String; Y : Character) return String is + begin + if X'Length = 0 then + return (1 => Y); + + else + declare + R : String (X'First .. X'Last + 1); + + begin + R (X'Range) := X; + R (R'Last) := Y; + return R; + end; + end if; + end Str_Concat_SC; + +end System.String_Ops; diff --git a/gcc/ada/libgnat/s-strops.ads b/gcc/ada/libgnat/s-strops.ads new file mode 100644 index 0000000..78a5b25 --- /dev/null +++ b/gcc/ada/libgnat/s-strops.ads @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G _ O P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime operations on strings +-- (other than runtime comparison, found in s-strcom.ads). + +-- NOTE: This package is obsolescent. It is no longer used by the compiler +-- which now generates concatenation inline. It is retained only because +-- it may be used during bootstrapping using old versions of the compiler. + +pragma Compiler_Unit_Warning; + +package System.String_Ops is + pragma Pure; + + function Str_Concat (X, Y : String) return String; + -- Concatenate two strings and return resulting string + + function Str_Concat_SC (X : String; Y : Character) return String; + -- Concatenate string and character + + function Str_Concat_CS (X : Character; Y : String) return String; + -- Concatenate character and string + + function Str_Concat_CC (X, Y : Character) return String; + -- Concatenate two characters + +end System.String_Ops; diff --git a/gcc/ada/libgnat/s-ststop.adb b/gcc/ada/libgnat/s-ststop.adb new file mode 100644 index 0000000..ea02065 --- /dev/null +++ b/gcc/ada/libgnat/s-ststop.adb @@ -0,0 +1,915 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Ada.Streams; use Ada.Streams; +with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; +with Ada.Unchecked_Conversion; + +with System; use System; +with System.Storage_Elements; use System.Storage_Elements; +with System.Stream_Attributes; + +package body System.Strings.Stream_Ops is + + -- The following type describes the low-level IO mechanism used in package + -- Stream_Ops_Internal. + + type IO_Kind is (Byte_IO, Block_IO); + + -- The following package provides an IO framework for strings. Depending + -- on the version of System.Stream_Attributes as well as the size of + -- formal parameter Element_Type, the package will either utilize block + -- IO or element-by-element IO. + + generic + type Element_Type is private; + type Index_Type is range <>; + type Array_Type is array (Index_Type range <>) of Element_Type; + + package Stream_Ops_Internal is + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind; + Max_Length : Long_Integer := Long_Integer'Last) return Array_Type; + -- Raises an exception if you try to read a String that is longer than + -- Max_Length. See expansion of Attribute_Input in Exp_Attr for details. + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : Array_Type; + IO : IO_Kind); + + procedure Read + (Strm : access Root_Stream_Type'Class; + Item : out Array_Type; + IO : IO_Kind); + + procedure Write + (Strm : access Root_Stream_Type'Class; + Item : Array_Type; + IO : IO_Kind); + end Stream_Ops_Internal; + + ------------------------- + -- Stream_Ops_Internal -- + ------------------------- + + package body Stream_Ops_Internal is + + -- The following value represents the number of BITS allocated for the + -- default block used in string IO. The sizes of all other types are + -- calculated relative to this value. + + Default_Block_Size : constant := 512 * 8; + + -- Shorthand notation for stream element and element type sizes + + ET_Size : constant Integer := Element_Type'Size; + SE_Size : constant Integer := Stream_Element'Size; + + -- The following constants describe the number of array elements or + -- stream elements that can fit into a default block. + + AE_In_Default_Block : constant Index_Type := + Index_Type (Default_Block_Size / ET_Size); + -- Number of array elements in a default block + + SE_In_Default_Block : constant Integer := Default_Block_Size / SE_Size; + -- Number of storage elements in a default block + + -- Buffer types + + subtype Default_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (SE_In_Default_Block)); + + subtype Array_Block is + Array_Type (Index_Type range 1 .. AE_In_Default_Block); + + -- Conversions to and from Default_Block + + function To_Default_Block is + new Ada.Unchecked_Conversion (Array_Block, Default_Block); + + function To_Array_Block is + new Ada.Unchecked_Conversion (Default_Block, Array_Block); + + ----------- + -- Input -- + ----------- + + function Input + (Strm : access Root_Stream_Type'Class; + IO : IO_Kind; + Max_Length : Long_Integer := Long_Integer'Last) return Array_Type + is + pragma Unsuppress (All_Checks); + -- The above makes T'Class'Input robust in the case of bad data. The + -- declaration of Item below could raise Storage_Error if the length + -- is too big. + + begin + if Strm = null then + raise Constraint_Error; + end if; + + declare + Low, High : Index_Type'Base; + begin + -- Read the bounds of the string. Note that they could be out of + -- range of Index_Type in the case of empty arrays. + + Index_Type'Read (Strm, Low); + Index_Type'Read (Strm, High); + + if Long_Integer (High) - Long_Integer (Low) > Max_Length then + raise Constraint_Error; + end if; + + -- Read the character content of the string + + declare + Item : Array_Type (Low .. High); + begin + Read (Strm, Item, IO); + return Item; + end; + end; + end Input; + + ------------ + -- Output -- + ------------ + + procedure Output + (Strm : access Root_Stream_Type'Class; + Item : Array_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Write the bounds of the string + + Index_Type'Write (Strm, Item'First); + Index_Type'Write (Strm, Item'Last); + + -- Write the character content of the string + + Write (Strm, Item, IO); + end Output; + + ---------- + -- Read -- + ---------- + + procedure Read + (Strm : access Root_Stream_Type'Class; + Item : out Array_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Nothing to do if the desired string is empty + + if Item'Length = 0 then + return; + end if; + + -- Block IO + + if IO = Block_IO and then Stream_Attributes.Block_IO_OK then + declare + -- Determine the size in BITS of the block necessary to contain + -- the whole string. + + Block_Size : constant Natural := + Integer (Item'Last - Item'First + 1) * ET_Size; + + -- Item can be larger than what the default block can store, + -- determine the number of whole reads necessary to read the + -- string. + + Blocks : constant Natural := Block_Size / Default_Block_Size; + + -- The size of Item may not be a multiple of the default block + -- size, determine the size of the remaining chunk in BITS. + + Rem_Size : constant Natural := + Block_Size mod Default_Block_Size; + + -- String indexes + + Low : Index_Type := Item'First; + High : Index_Type := Low + AE_In_Default_Block - 1; + + -- End of stream error detection + + Last : Stream_Element_Offset := 0; + Sum : Stream_Element_Offset := 0; + + begin + -- Step 1: If the string is too large, read in individual + -- chunks the size of the default block. + + if Blocks > 0 then + declare + Block : Default_Block; + + begin + for Counter in 1 .. Blocks loop + Read (Strm.all, Block, Last); + Item (Low .. High) := To_Array_Block (Block); + + Low := High + 1; + High := Low + AE_In_Default_Block - 1; + Sum := Sum + Last; + Last := 0; + end loop; + end; + end if; + + -- Step 2: Read in any remaining elements + + if Rem_Size > 0 then + declare + subtype Rem_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); + + subtype Rem_Array_Block is + Array_Type (Index_Type range + 1 .. Index_Type (Rem_Size / ET_Size)); + + function To_Rem_Array_Block is new + Ada.Unchecked_Conversion (Rem_Block, Rem_Array_Block); + + Block : Rem_Block; + + begin + Read (Strm.all, Block, Last); + Item (Low .. Item'Last) := To_Rem_Array_Block (Block); + + Sum := Sum + Last; + end; + end if; + + -- Step 3: Potential error detection. The sum of all the + -- chunks is less than we initially wanted to read. In other + -- words, the stream does not contain enough elements to fully + -- populate Item. + + if (Integer (Sum) * SE_Size) / ET_Size < Item'Length then + raise End_Error; + end if; + end; + + -- Byte IO + + else + declare + E : Element_Type; + begin + for Index in Item'First .. Item'Last loop + Element_Type'Read (Strm, E); + Item (Index) := E; + end loop; + end; + end if; + end Read; + + ----------- + -- Write -- + ----------- + + procedure Write + (Strm : access Root_Stream_Type'Class; + Item : Array_Type; + IO : IO_Kind) + is + begin + if Strm = null then + raise Constraint_Error; + end if; + + -- Nothing to do if the input string is empty + + if Item'Length = 0 then + return; + end if; + + -- Block IO + + if IO = Block_IO and then Stream_Attributes.Block_IO_OK then + declare + -- Determine the size in BITS of the block necessary to contain + -- the whole string. + + Block_Size : constant Natural := Item'Length * ET_Size; + + -- Item can be larger than what the default block can store, + -- determine the number of whole writes necessary to output the + -- string. + + Blocks : constant Natural := Block_Size / Default_Block_Size; + + -- The size of Item may not be a multiple of the default block + -- size, determine the size of the remaining chunk. + + Rem_Size : constant Natural := + Block_Size mod Default_Block_Size; + + -- String indexes + + Low : Index_Type := Item'First; + High : Index_Type := Low + AE_In_Default_Block - 1; + + begin + -- Step 1: If the string is too large, write out individual + -- chunks the size of the default block. + + for Counter in 1 .. Blocks loop + Write (Strm.all, To_Default_Block (Item (Low .. High))); + Low := High + 1; + High := Low + AE_In_Default_Block - 1; + end loop; + + -- Step 2: Write out any remaining elements + + if Rem_Size > 0 then + declare + subtype Rem_Block is Stream_Element_Array + (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); + + subtype Rem_Array_Block is + Array_Type (Index_Type range + 1 .. Index_Type (Rem_Size / ET_Size)); + + function To_Rem_Block is new + Ada.Unchecked_Conversion (Rem_Array_Block, Rem_Block); + + begin + Write (Strm.all, To_Rem_Block (Item (Low .. Item'Last))); + end; + end if; + end; + + -- Byte IO + + else + for Index in Item'First .. Item'Last loop + Element_Type'Write (Strm, Item (Index)); + end loop; + end if; + end Write; + end Stream_Ops_Internal; + + -- Specific instantiations for all Ada array types handled + + package Storage_Array_Ops is + new Stream_Ops_Internal + (Element_Type => Storage_Element, + Index_Type => Storage_Offset, + Array_Type => Storage_Array); + + package Stream_Element_Array_Ops is + new Stream_Ops_Internal + (Element_Type => Stream_Element, + Index_Type => Stream_Element_Offset, + Array_Type => Stream_Element_Array); + + package String_Ops is + new Stream_Ops_Internal + (Element_Type => Character, + Index_Type => Positive, + Array_Type => String); + + package Wide_String_Ops is + new Stream_Ops_Internal + (Element_Type => Wide_Character, + Index_Type => Positive, + Array_Type => Wide_String); + + package Wide_Wide_String_Ops is + new Stream_Ops_Internal + (Element_Type => Wide_Wide_Character, + Index_Type => Positive, + Array_Type => Wide_Wide_String); + + ------------------------- + -- Storage_Array_Input -- + ------------------------- + + function Storage_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Storage_Array + is + begin + return Storage_Array_Ops.Input (Strm, Byte_IO); + end Storage_Array_Input; + + -------------------------------- + -- Storage_Array_Input_Blk_IO -- + -------------------------------- + + function Storage_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Storage_Array + is + begin + return Storage_Array_Ops.Input (Strm, Block_IO); + end Storage_Array_Input_Blk_IO; + + -------------------------- + -- Storage_Array_Output -- + -------------------------- + + procedure Storage_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Output (Strm, Item, Byte_IO); + end Storage_Array_Output; + + --------------------------------- + -- Storage_Array_Output_Blk_IO -- + --------------------------------- + + procedure Storage_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Output (Strm, Item, Block_IO); + end Storage_Array_Output_Blk_IO; + + ------------------------ + -- Storage_Array_Read -- + ------------------------ + + procedure Storage_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Storage_Array) + is + begin + Storage_Array_Ops.Read (Strm, Item, Byte_IO); + end Storage_Array_Read; + + ------------------------------- + -- Storage_Array_Read_Blk_IO -- + ------------------------------- + + procedure Storage_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Storage_Array) + is + begin + Storage_Array_Ops.Read (Strm, Item, Block_IO); + end Storage_Array_Read_Blk_IO; + + ------------------------- + -- Storage_Array_Write -- + ------------------------- + + procedure Storage_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Write (Strm, Item, Byte_IO); + end Storage_Array_Write; + + -------------------------------- + -- Storage_Array_Write_Blk_IO -- + -------------------------------- + + procedure Storage_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Storage_Array) + is + begin + Storage_Array_Ops.Write (Strm, Item, Block_IO); + end Storage_Array_Write_Blk_IO; + + -------------------------------- + -- Stream_Element_Array_Input -- + -------------------------------- + + function Stream_Element_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Stream_Element_Array + is + begin + return Stream_Element_Array_Ops.Input (Strm, Byte_IO); + end Stream_Element_Array_Input; + + --------------------------------------- + -- Stream_Element_Array_Input_Blk_IO -- + --------------------------------------- + + function Stream_Element_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Stream_Element_Array + is + begin + return Stream_Element_Array_Ops.Input (Strm, Block_IO); + end Stream_Element_Array_Input_Blk_IO; + + --------------------------------- + -- Stream_Element_Array_Output -- + --------------------------------- + + procedure Stream_Element_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Output (Strm, Item, Byte_IO); + end Stream_Element_Array_Output; + + ---------------------------------------- + -- Stream_Element_Array_Output_Blk_IO -- + ---------------------------------------- + + procedure Stream_Element_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Output (Strm, Item, Block_IO); + end Stream_Element_Array_Output_Blk_IO; + + ------------------------------- + -- Stream_Element_Array_Read -- + ------------------------------- + + procedure Stream_Element_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Read (Strm, Item, Byte_IO); + end Stream_Element_Array_Read; + + -------------------------------------- + -- Stream_Element_Array_Read_Blk_IO -- + -------------------------------------- + + procedure Stream_Element_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Read (Strm, Item, Block_IO); + end Stream_Element_Array_Read_Blk_IO; + + -------------------------------- + -- Stream_Element_Array_Write -- + -------------------------------- + + procedure Stream_Element_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Write (Strm, Item, Byte_IO); + end Stream_Element_Array_Write; + + --------------------------------------- + -- Stream_Element_Array_Write_Blk_IO -- + --------------------------------------- + + procedure Stream_Element_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Stream_Element_Array) + is + begin + Stream_Element_Array_Ops.Write (Strm, Item, Block_IO); + end Stream_Element_Array_Write_Blk_IO; + + ------------------ + -- String_Input -- + ------------------ + + function String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Byte_IO); + end String_Input; + + ------------------------- + -- String_Input_Blk_IO -- + ------------------------- + + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Block_IO); + end String_Input_Blk_IO; + + ------------------------- + -- String_Input_Tag -- + ------------------------- + + function String_Input_Tag + (Strm : access Ada.Streams.Root_Stream_Type'Class) return String + is + begin + return String_Ops.Input (Strm, Block_IO, Max_Length => 10_000); + end String_Input_Tag; + + ------------------- + -- String_Output -- + ------------------- + + procedure String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Output (Strm, Item, Byte_IO); + end String_Output; + + -------------------------- + -- String_Output_Blk_IO -- + -------------------------- + + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Output (Strm, Item, Block_IO); + end String_Output_Blk_IO; + + ----------------- + -- String_Read -- + ----------------- + + procedure String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String) + is + begin + String_Ops.Read (Strm, Item, Byte_IO); + end String_Read; + + ------------------------ + -- String_Read_Blk_IO -- + ------------------------ + + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String) + is + begin + String_Ops.Read (Strm, Item, Block_IO); + end String_Read_Blk_IO; + + ------------------ + -- String_Write -- + ------------------ + + procedure String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Write (Strm, Item, Byte_IO); + end String_Write; + + ------------------------- + -- String_Write_Blk_IO -- + ------------------------- + + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String) + is + begin + String_Ops.Write (Strm, Item, Block_IO); + end String_Write_Blk_IO; + + ----------------------- + -- Wide_String_Input -- + ----------------------- + + function Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String + is + begin + return Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_String_Input; + + ------------------------------ + -- Wide_String_Input_Blk_IO -- + ------------------------------ + + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String + is + begin + return Wide_String_Ops.Input (Strm, Block_IO); + end Wide_String_Input_Blk_IO; + + ------------------------ + -- Wide_String_Output -- + ------------------------ + + procedure Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_String_Output; + + ------------------------------- + -- Wide_String_Output_Blk_IO -- + ------------------------------- + + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_String_Output_Blk_IO; + + ---------------------- + -- Wide_String_Read -- + ---------------------- + + procedure Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String) + is + begin + Wide_String_Ops.Read (Strm, Item, Byte_IO); + end Wide_String_Read; + + ----------------------------- + -- Wide_String_Read_Blk_IO -- + ----------------------------- + + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String) + is + begin + Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_String_Read_Blk_IO; + + ----------------------- + -- Wide_String_Write -- + ----------------------- + + procedure Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Write (Strm, Item, Byte_IO); + end Wide_String_Write; + + ------------------------------ + -- Wide_String_Write_Blk_IO -- + ------------------------------ + + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String) + is + begin + Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_String_Write_Blk_IO; + + ---------------------------- + -- Wide_Wide_String_Input -- + ---------------------------- + + function Wide_Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String + is + begin + return Wide_Wide_String_Ops.Input (Strm, Byte_IO); + end Wide_Wide_String_Input; + + ----------------------------------- + -- Wide_Wide_String_Input_Blk_IO -- + ----------------------------------- + + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String + is + begin + return Wide_Wide_String_Ops.Input (Strm, Block_IO); + end Wide_Wide_String_Input_Blk_IO; + + ----------------------------- + -- Wide_Wide_String_Output -- + ----------------------------- + + procedure Wide_Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Output (Strm, Item, Byte_IO); + end Wide_Wide_String_Output; + + ------------------------------------ + -- Wide_Wide_String_Output_Blk_IO -- + ------------------------------------ + + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Output (Strm, Item, Block_IO); + end Wide_Wide_String_Output_Blk_IO; + + --------------------------- + -- Wide_Wide_String_Read -- + --------------------------- + + procedure Wide_Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Read (Strm, Item, Byte_IO); + end Wide_Wide_String_Read; + + ---------------------------------- + -- Wide_Wide_String_Read_Blk_IO -- + ---------------------------------- + + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Read (Strm, Item, Block_IO); + end Wide_Wide_String_Read_Blk_IO; + + ---------------------------- + -- Wide_Wide_String_Write -- + ---------------------------- + + procedure Wide_Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Write (Strm, Item, Byte_IO); + end Wide_Wide_String_Write; + + ----------------------------------- + -- Wide_Wide_String_Write_Blk_IO -- + ----------------------------------- + + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String) + is + begin + Wide_Wide_String_Ops.Write (Strm, Item, Block_IO); + end Wide_Wide_String_Write_Blk_IO; + +end System.Strings.Stream_Ops; diff --git a/gcc/ada/libgnat/s-ststop.ads b/gcc/ada/libgnat/s-ststop.ads new file mode 100644 index 0000000..f816400 --- /dev/null +++ b/gcc/ada/libgnat/s-ststop.ads @@ -0,0 +1,260 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides subprogram implementations of stream attributes for +-- the following types using a "block IO" approach in which the entire data +-- item is written in one operation, instead of writing individual characters. + +-- Ada.Stream_Element_Array +-- Ada.String +-- Ada.Wide_String +-- Ada.Wide_Wide_String +-- System.Storage_Array + +-- Note: this routine is in Ada.Strings because historically it handled only +-- the string types. It is not worth moving it at this stage. + +-- The compiler will generate references to the subprograms in this package +-- when expanding stream attributes for the above mentioned types. Example: + +-- String'Output (Some_Stream, Some_String); + +-- will be expanded into: + +-- String_Output (Some_Stream, Some_String); +-- or +-- String_Output_Blk_IO (Some_Stream, Some_String); + +-- String_Output form is used if pragma Restrictions (No_String_Optimziations) +-- is active, which requires element by element operations. The BLK_IO form +-- is used if this restriction is not set, allowing block optimization. + +-- Note that if System.Stream_Attributes.Block_IO_OK is False, then the BLK_IO +-- form is treated as equivalent to the normal case, so that the optimization +-- is inhibited anyway, regardless of the setting of the restriction. This +-- handles versions of System.Stream_Attributes (in particular the XDR version +-- found in s-stratt-xdr) which do not permit block io optimization. + +pragma Compiler_Unit_Warning; + +with Ada.Streams; + +with System.Storage_Elements; + +package System.Strings.Stream_Ops is + + ------------------------------------- + -- Storage_Array stream operations -- + ------------------------------------- + + function Storage_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return System.Storage_Elements.Storage_Array; + + function Storage_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return System.Storage_Elements.Storage_Array; + + procedure Storage_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + procedure Storage_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : System.Storage_Elements.Storage_Array); + + -------------------------------------------- + -- Stream_Element_Array stream operations -- + -------------------------------------------- + + function Stream_Element_Array_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Ada.Streams.Stream_Element_Array; + + function Stream_Element_Array_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Ada.Streams.Stream_Element_Array; + + procedure Stream_Element_Array_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + + procedure Stream_Element_Array_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Ada.Streams.Stream_Element_Array); + + ------------------------------ + -- String stream operations -- + ------------------------------ + + function String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + + function String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + + function String_Input_Tag + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return String; + -- Same as String_Input_Blk_IO, except raises an exception for overly long + -- Strings. See expansion of Attribute_Input in Exp_Attr for details. + + procedure String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String); + + procedure String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out String); + + procedure String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + procedure String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : String); + + ----------------------------------- + -- Wide_String stream operations -- + ----------------------------------- + + function Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_String; + + function Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_String; + + procedure Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String); + + procedure Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_String); + + procedure Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + procedure Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_String); + + ---------------------------------------- + -- Wide_Wide_String stream operations -- + ---------------------------------------- + + function Wide_Wide_String_Input + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_Wide_String; + + function Wide_Wide_String_Input_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class) + return Wide_Wide_String; + + procedure Wide_Wide_String_Output + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Output_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Read + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String); + + procedure Wide_Wide_String_Read_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : out Wide_Wide_String); + + procedure Wide_Wide_String_Write + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + + procedure Wide_Wide_String_Write_Blk_IO + (Strm : access Ada.Streams.Root_Stream_Type'Class; + Item : Wide_Wide_String); + +end System.Strings.Stream_Ops; diff --git a/gcc/ada/libgnat/s-tasloc.adb b/gcc/ada/libgnat/s-tasloc.adb new file mode 100644 index 0000000..943f419 --- /dev/null +++ b/gcc/ada/libgnat/s-tasloc.adb @@ -0,0 +1,54 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ L O C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1997-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Soft_Links; + +package body System.Task_Lock is + + ---------- + -- Lock -- + ---------- + + procedure Lock is + begin + System.Soft_Links.Lock_Task.all; + end Lock; + + ------------ + -- Unlock -- + ------------ + + procedure Unlock is + begin + System.Soft_Links.Unlock_Task.all; + end Unlock; + +end System.Task_Lock; diff --git a/gcc/ada/libgnat/s-tasloc.ads b/gcc/ada/libgnat/s-tasloc.ads new file mode 100644 index 0000000..18a4570 --- /dev/null +++ b/gcc/ada/libgnat/s-tasloc.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T A S K _ L O C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1998-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Simple task lock and unlock routines + +-- A small package containing a task lock and unlock routines for creating +-- a critical region. The lock involved is a global lock, shared by all +-- tasks, and by all calls to these routines, so these routines should be +-- used with care to avoid unnecessary reduction of concurrency. + +-- These routines may be used in a non-tasking program, and in that case +-- they have no effect (they do NOT cause the tasking runtime to be loaded). + +-- Note: this package is in the System hierarchy so that it can be directly +-- be used by other predefined packages. User access to this package is via +-- a renaming of this package in GNAT.Task_Lock (file g-tasloc.ads). + +package System.Task_Lock is + pragma Preelaborate; + + procedure Lock; + pragma Inline (Lock); + -- Acquires the global lock, starts the execution of a critical region + -- which no other task can enter until the locking task calls Unlock + + procedure Unlock; + pragma Inline (Unlock); + -- Releases the global lock, allowing another task to successfully + -- complete a Lock operation. Terminates the critical region. + -- + -- The recommended protocol for using these two procedures is as + -- follows: + -- + -- Locked_Processing : begin + -- Lock; + -- ... + -- TSL.Unlock; + -- + -- exception + -- when others => + -- Unlock; + -- raise; + -- end Locked_Processing; + -- + -- This ensures that the lock is not left set if an exception is raised + -- explicitly or implicitly during the critical locked region. + -- + -- Note on multiple calls to Lock: It is permissible to call Lock + -- more than once with no intervening Unlock from a single task, + -- and the lock will not be released until the corresponding number + -- of Unlock operations has been performed. For example: + -- + -- System.Task_Lock.Lock; -- acquires lock + -- System.Task_Lock.Lock; -- no effect + -- System.Task_Lock.Lock; -- no effect + -- System.Task_Lock.Unlock; -- no effect + -- System.Task_Lock.Unlock; -- no effect + -- System.Task_Lock.Unlock; -- releases lock + -- + -- However, as previously noted, the Task_Lock facility should only + -- be used for very local locks where the probability of conflict is + -- low, so usually this kind of nesting is not a good idea in any case. + -- In more complex locking situations, it is more appropriate to define + -- an appropriate protected type to provide the required locking. + -- + -- It is an error to call Unlock when there has been no prior call to + -- Lock. The effect of such an erroneous call is undefined, and may + -- result in deadlock, or other malfunction of the run-time system. + +end System.Task_Lock; diff --git a/gcc/ada/libgnat/s-thread.ads b/gcc/ada/libgnat/s-thread.ads new file mode 100644 index 0000000..cd4faae --- /dev/null +++ b/gcc/ada/libgnat/s-thread.ads @@ -0,0 +1,90 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T H R E A D S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides facilities to register a thread to the runtime, +-- and allocate its task specific datas. + +-- This package is currently implemented for: + +-- VxWorks AE653 rts-cert +-- VxWorks AE653 rts-full (not rts-kernel) + +with Ada.Exceptions; +with Ada.Unchecked_Conversion; + +with Interfaces.C; + +with System.Soft_Links; + +package System.Threads is + + type ATSD is limited private; + -- Type of the Ada thread specific data. It contains datas needed + -- by the GNAT runtime. + + type ATSD_Access is access ATSD; + function From_Address is + new Ada.Unchecked_Conversion (Address, ATSD_Access); + + subtype STATUS is Interfaces.C.int; + -- Equivalent of the C type STATUS + + type t_id is new Interfaces.C.long; + subtype Thread_Id is t_id; + + function Register (T : Thread_Id) return STATUS; + -- Create the task specific data necessary for Ada language support + + -------------------------- + -- Thread Body Handling -- + -------------------------- + + -- The subprograms in this section are called from the process body + -- wrapper in the APEX process registration package. + + procedure Thread_Body_Enter + (Sec_Stack_Address : System.Address; + Sec_Stack_Size : Natural; + Process_ATSD_Address : System.Address); + -- Enter thread body, see above for details + + procedure Thread_Body_Leave; + -- Leave thread body (normally), see above for details + + procedure Thread_Body_Exceptional_Exit + (EO : Ada.Exceptions.Exception_Occurrence); + -- Leave thread body (abnormally on exception), see above for details + +private + + type ATSD is new System.Soft_Links.TSD; + +end System.Threads; diff --git a/gcc/ada/libgnat/s-traceb-hpux.adb b/gcc/ada/libgnat/s-traceb-hpux.adb new file mode 100644 index 0000000..a261104 --- /dev/null +++ b/gcc/ada/libgnat/s-traceb-hpux.adb @@ -0,0 +1,627 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- (HP/UX Version) -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Traceback is + + -- This package implements the backtracing facility by way of a dedicated + -- HP library for stack unwinding described in the "Runtime Architecture + -- Document". + + pragma Linker_Options ("/usr/lib/libcl.a"); + + -- The library basically offers services to fetch information about a + -- "previous" frame based on information about a "current" one. + + type Current_Frame_Descriptor is record + cur_fsz : Address; -- Frame size of current routine. + cur_sp : Address; -- The current value of stack pointer. + cur_rls : Address; -- PC-space of the caller. + cur_rlo : Address; -- PC-offset of the caller. + cur_dp : Address; -- Data Pointer of the current routine. + top_rp : Address; -- Initial value of RP. + top_mrp : Address; -- Initial value of MRP. + top_sr0 : Address; -- Initial value of sr0. + top_sr4 : Address; -- Initial value of sr4. + top_r3 : Address; -- Initial value of gr3. + cur_r19 : Address; -- GR19 value of the calling routine. + top_r4 : Address; -- Initial value of gr4. + dummy : Address; -- Reserved. + out_rlo : Address; -- PC-offset of the caller after get_previous. + end record; + + type Previous_Frame_Descriptor is record + prev_fsz : Address; -- frame size of calling routine. + prev_sp : Address; -- SP of calling routine. + prev_rls : Address; -- PC_space of calling routine's caller. + prev_rlo : Address; -- PC_offset of calling routine's caller. + prev_dp : Address; -- DP of calling routine. + udescr0 : Address; -- low word of calling routine's unwind desc. + udescr1 : Address; -- high word of calling routine's unwind desc. + ustart : Address; -- start of the unwind region. + uend : Address; -- end of the unwind region. + uw_index : Address; -- index into the unwind table. + prev_r19 : Address; -- GR19 value of the caller's caller. + top_r3 : Address; -- Caller's initial gr3. + top_r4 : Address; -- Caller's initial gr4. + end record; + + -- Provide useful shortcuts for the names + + subtype CFD is Current_Frame_Descriptor; + subtype PFD is Previous_Frame_Descriptor; + + -- Frames with dynamic stack allocation are handled using the associated + -- frame pointer, but HP compilers and GCC setup this pointer differently. + -- HP compilers set it to point at the top (highest address) of the static + -- part of the frame, whereas GCC sets it to point at the bottom of this + -- region. We have to fake the unwinder to compensate for this difference, + -- for which we'll need to access some subprograms unwind descriptors. + + type Bits_2_Value is mod 2 ** 2; + for Bits_2_Value'Size use 2; + + type Bits_4_Value is mod 2 ** 4; + for Bits_4_Value'Size use 4; + + type Bits_5_Value is mod 2 ** 5; + for Bits_5_Value'Size use 5; + + type Bits_27_Value is mod 2 ** 27; + for Bits_27_Value'Size use 27; + + type Unwind_Descriptor is record + cannot_unwind : Boolean; + mcode : Boolean; + mcode_save_restore : Boolean; + region_desc : Bits_2_Value; + reserved0 : Boolean; + entry_sr : Boolean; + entry_fr : Bits_4_Value; + entry_gr : Bits_5_Value; + + args_stored : Boolean; + variable_frame : Boolean; + separate_package_body : Boolean; + frame_extension_mcode : Boolean; + + stack_overflow_check : Boolean; + two_steps_sp_adjust : Boolean; + sr4_export : Boolean; + cxx_info : Boolean; + + cxx_try_catch : Boolean; + sched_entry_seq : Boolean; + reserved1 : Boolean; + save_sp : Boolean; + + save_rp : Boolean; + save_mrp : Boolean; + save_r19 : Boolean; + cleanups : Boolean; + + hpe_interrupt_marker : Boolean; + hpux_interrupt_marker : Boolean; + large_frame : Boolean; + alloca_frame : Boolean; + + reserved2 : Boolean; + frame_size : Bits_27_Value; + end record; + + for Unwind_Descriptor'Size use 64; + + for Unwind_Descriptor use record + cannot_unwind at 0 range 0 .. 0; + mcode at 0 range 1 .. 1; + mcode_save_restore at 0 range 2 .. 2; + region_desc at 0 range 3 .. 4; + reserved0 at 0 range 5 .. 5; + entry_sr at 0 range 6 .. 6; + entry_fr at 0 range 7 .. 10; + + entry_gr at 1 range 3 .. 7; + + args_stored at 2 range 0 .. 0; + variable_frame at 2 range 1 .. 1; + separate_package_body at 2 range 2 .. 2; + frame_extension_mcode at 2 range 3 .. 3; + stack_overflow_check at 2 range 4 .. 4; + two_steps_sp_adjust at 2 range 5 .. 5; + sr4_export at 2 range 6 .. 6; + cxx_info at 2 range 7 .. 7; + + cxx_try_catch at 3 range 0 .. 0; + sched_entry_seq at 3 range 1 .. 1; + reserved1 at 3 range 2 .. 2; + save_sp at 3 range 3 .. 3; + save_rp at 3 range 4 .. 4; + save_mrp at 3 range 5 .. 5; + save_r19 at 3 range 6 .. 6; + cleanups at 3 range 7 .. 7; + + hpe_interrupt_marker at 4 range 0 .. 0; + hpux_interrupt_marker at 4 range 1 .. 1; + large_frame at 4 range 2 .. 2; + alloca_frame at 4 range 3 .. 3; + + reserved2 at 4 range 4 .. 4; + frame_size at 4 range 5 .. 31; + end record; + + subtype UWD is Unwind_Descriptor; + type UWD_Ptr is access all UWD; + + function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr); + + -- The descriptor associated with a given code location is retrieved + -- using functions imported from the HP library, requiring the definition + -- of additional structures. + + type Unwind_Table_Region is record + Table_Start : Address; + Table_End : Address; + end record; + -- An Unwind Table region, which is a memory area containing Unwind + -- Descriptors. + + subtype UWT is Unwind_Table_Region; + + -- The subprograms imported below are provided by the HP library + + function U_get_unwind_table return UWT; + pragma Import (C, U_get_unwind_table, "U_get_unwind_table"); + -- Get the unwind table region associated with the current executable. + -- This function is actually documented as having an argument, but which + -- is only used for the MPE/iX targets. + + function U_get_shLib_unwind_table (r19 : Address) return UWT; + pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl"); + -- Return the unwind table region associated with a possible shared + -- library, as determined by the provided r19 value. + + function U_get_shLib_text_addr (r19 : Address) return Address; + pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr"); + -- Return the address at which the code for a shared library begins, or + -- -1 if the value provided for r19 does not identify shared library code. + + function U_get_unwind_entry + (Pc : Address; + Space : Address; + Table_Start : Address; + Table_End : Address) return Address; + pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); + -- Given the bounds of an unwind table, return the address of the + -- unwind descriptor associated with a code location/space. In the case + -- of shared library code, the offset from the beginning of the library + -- is expected as Pc. + + procedure U_init_frame_record (Frame : not null access CFD); + pragma Import (C, U_init_frame_record, "U_init_frame_record"); + + procedure U_prep_frame_rec_for_unwind (Frame : not null access CFD); + pragma Import (C, U_prep_frame_rec_for_unwind, + "U_prep_frame_rec_for_unwind"); + + -- Fetch the description data of the frame in which these two procedures + -- are called. + + function U_get_u_rlo + (Cur : not null access CFD; Prev : not null access PFD) return Integer; + pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX"); + -- From a complete current frame with a return location possibly located + -- into a linker generated stub, and basic information about the previous + -- frame, place the first non stub return location into the current frame. + -- Return -1 if something went wrong during the computation. + + function U_is_shared_pc (rlo : Address; r19 : Address) return Address; + pragma Import (C, U_is_shared_pc, "U_is_shared_pc"); + -- Return 0 if the provided return location does not correspond to code + -- in a shared library, or something non null otherwise. + + function U_get_previous_frame_x + (current_frame : not null access CFD; + previous_frame : not null access PFD; + previous_size : Integer) return Integer; + pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); + -- Fetch the data describing the "previous" frame relatively to the + -- "current" one. "previous_size" should be the size of the "previous" + -- frame descriptor provided. + -- + -- The library provides a simpler interface without the size parameter + -- but it is not usable when frames with dynamically allocated space are + -- on the way. + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address + + ------------------ + -- C_Call_Chain -- + ------------------ + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) return Natural + is + Val : Natural; + begin + Call_Chain (Traceback, Max_Len, Val); + return Val; + end C_Call_Chain; + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + type Tracebacks_Array is array (1 .. Max_Len) of System.Address; + pragma Suppress_Initialization (Tracebacks_Array); + + -- The code location returned by the unwinder is a return location but + -- what we need is a call point. Under HP-UX call instructions are 4 + -- bytes long and the return point they specify is 4 bytes beyond the + -- next instruction because of the delay slot. + + Call_Size : constant := 4; + DSlot_Size : constant := 4; + Rlo_Offset : constant := Call_Size + DSlot_Size; + + -- Moreover, the return point is passed via a register which two least + -- significant bits specify a privilege level that we will have to mask. + + Priv_Mask : constant := 16#00000003#; + + Frame : aliased CFD; + Code : System.Address; + J : Natural := 1; + Pop_Success : Boolean; + Trace : Tracebacks_Array; + for Trace'Address use Traceback; + + -- The backtracing process needs a set of subprograms : + + function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr; + -- Return an access to the unwind descriptor for the caller of + -- a given frame, using only the provided return location. + + function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr; + -- Return an access to the unwind descriptor for the user code caller + -- of a given frame, or null if the information is not available. + + function Pop_Frame (Frame : not null access CFD) return Boolean; + -- Update the provided machine state structure so that it reflects + -- the state one call frame "above" the initial one. + -- + -- Return True if the operation has been successful, False otherwise. + -- Failure typically occurs when the top of the call stack has been + -- reached. + + function Prepare_For_Unwind_Of + (Frame : not null access CFD) return Boolean; + -- Perform the necessary adaptations to the machine state before + -- calling the unwinder. Currently used for the specific case of + -- dynamically sized previous frames. + -- + -- Return True if everything went fine, or False otherwise. + + Program_UWT : constant UWT := U_get_unwind_table; + + --------------- + -- Pop_Frame -- + --------------- + + function Pop_Frame (Frame : not null access CFD) return Boolean is + Up_Frame : aliased PFD; + State_Ready : Boolean; + + begin + -- Check/adapt the state before calling the unwinder and return + -- if anything went wrong. + + State_Ready := Prepare_For_Unwind_Of (Frame); + + if not State_Ready then + return False; + end if; + + -- Now, safely call the unwinder and use the results + + if U_get_previous_frame_x (Frame, + Up_Frame'Access, + Up_Frame'Size) /= 0 + then + return False; + end if; + + -- In case a stub is on the way, the usual previous return location + -- (the one in prev_rlo) is the one in the stub and the "real" one + -- is placed in the "current" record, so let's take this one into + -- account. + + Frame.out_rlo := Frame.cur_rlo; + + Frame.cur_fsz := Up_Frame.prev_fsz; + Frame.cur_sp := Up_Frame.prev_sp; + Frame.cur_rls := Up_Frame.prev_rls; + Frame.cur_rlo := Up_Frame.prev_rlo; + Frame.cur_dp := Up_Frame.prev_dp; + Frame.cur_r19 := Up_Frame.prev_r19; + Frame.top_r3 := Up_Frame.top_r3; + Frame.top_r4 := Up_Frame.top_r4; + + return True; + end Pop_Frame; + + --------------------------------- + -- Prepare_State_For_Unwind_Of -- + --------------------------------- + + function Prepare_For_Unwind_Of + (Frame : not null access CFD) return Boolean + is + Caller_UWD : UWD_Ptr; + FP_Adjustment : Integer; + + begin + -- No need to bother doing anything if the stack is already fully + -- unwound. + + if Frame.cur_rlo = 0 then + return False; + end if; + + -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder + -- uses the value provided in current.top_r3 or current.top_r4 as + -- a frame pointer to compute the size of the frame. What decides + -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with + -- r4 chosen if the bit is set. + + -- The size computed by the unwinder is STATIC_PART + (SP - FP), + -- which is correct with HP's frame pointer convention, but not + -- with GCC's one since we end up with the static part accounted + -- for twice. + + -- We have to compute r4 when it is required because the unwinder + -- has looked for it at a place where it was not if we went through + -- GCC frames. + + -- The size of the static part of a frame can be found in the + -- associated unwind descriptor. + + Caller_UWD := UWD_For_Caller_Of (Frame); + + -- If we cannot get it, we are unable to compute the potentially + -- necessary adjustments. We'd better not try to go on then. + + if Caller_UWD = null then + return False; + end if; + + -- If the caller frame is a GCC one, r3 is its frame pointer and + -- points to the bottom of the frame. The value to provide for r4 + -- can then be computed directly from the one of r3, compensating + -- for the static part of the frame. + + -- If the caller frame is an HP one, r3 is used to locate the + -- previous frame marker, that is it also points to the bottom of + -- the frame (this is why r3 cannot be used as the frame pointer in + -- the HP sense for large frames). The value to provide for r4 can + -- then also be computed from the one of r3 with the compensation + -- for the static part of the frame. + + FP_Adjustment := Integer (Caller_UWD.frame_size * 8); + Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment); + + return True; + end Prepare_For_Unwind_Of; + + ----------------------- + -- UWD_For_Caller_Of -- + ----------------------- + + function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr + is + UWD_Access : UWD_Ptr; + + begin + -- First try the most direct path, using the return location data + -- associated with the frame. + + UWD_Access := UWD_For_RLO_Of (Frame); + + if UWD_Access /= null then + return UWD_Access; + end if; + + -- If we did not get a result, we might face an in-stub return + -- address. In this case U_get_previous_frame can tell us what the + -- first not-in-stub return point is. We cannot call it directly, + -- though, because we haven't computed the potentially necessary + -- frame pointer adjustments, which might lead to SEGV in some + -- circumstances. Instead, we directly call the libcl routine which + -- is called by U_get_previous_frame and which only requires few + -- information. Take care, however, that the information is provided + -- in the "current" argument, so we need to work on a copy to avoid + -- disturbing our caller. + + declare + U_Current : aliased CFD := Frame.all; + U_Previous : aliased PFD; + + begin + U_Previous.prev_dp := U_Current.cur_dp; + U_Previous.prev_rls := U_Current.cur_rls; + U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz; + + if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then + UWD_Access := UWD_For_RLO_Of (U_Current'Access); + end if; + end; + + return UWD_Access; + end UWD_For_Caller_Of; + + -------------------- + -- UWD_For_RLO_Of -- + -------------------- + + function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr + is + UWD_Address : Address; + + -- The addresses returned by the library point to full descriptors + -- including the frame information bits but also the applicable PC + -- range. We need to account for this. + + Frame_Info_Offset : constant := 8; + + begin + -- First try to locate the descriptor in the program's unwind table + + UWD_Address := U_get_unwind_entry (Frame.cur_rlo, + Frame.cur_rls, + Program_UWT.Table_Start, + Program_UWT.Table_End); + + -- If we did not get it, we might have a frame from code in a + -- stub or shared library. For code in stub we would have to + -- compute the first non-stub return location but this is not + -- the role of this subprogram, so let's just try to see if we + -- can get a result from the tables in shared libraries. + + if UWD_Address = -1 + and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 + then + declare + Shlib_UWT : constant UWT := + U_get_shLib_unwind_table (Frame.cur_r19); + Shlib_Start : constant Address := + U_get_shLib_text_addr (Frame.cur_r19); + Rlo_Offset : constant Address := + Frame.cur_rlo - Shlib_Start; + begin + UWD_Address := U_get_unwind_entry (Rlo_Offset, + Frame.cur_rls, + Shlib_UWT.Table_Start, + Shlib_UWT.Table_End); + end; + end if; + + if UWD_Address /= -1 then + return To_UWD_Access (UWD_Address + Frame_Info_Offset); + else + return null; + end if; + end UWD_For_RLO_Of; + + -- Start of processing for Call_Chain + + begin + -- Fetch the state for this subprogram's frame and pop it so that we + -- start with an initial out_rlo "here". + + U_init_frame_record (Frame'Access); + Frame.top_sr0 := 0; + Frame.top_sr4 := 0; + + U_prep_frame_rec_for_unwind (Frame'Access); + + Pop_Success := Pop_Frame (Frame'Access); + + -- Skip the requested number of frames + + for I in 1 .. Skip_Frames loop + Pop_Success := Pop_Frame (Frame'Access); + end loop; + + -- Loop popping frames and storing locations until either a problem + -- occurs, or the top of the call chain is reached, or the provided + -- array is full. + + loop + -- We have to test some conditions against the return location + -- as it is returned, so get it as is first. + + Code := Frame.out_rlo; + + exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1; + + -- Compute the call point from the retrieved return location : + -- Mask the privilege bits and account for the delta between the + -- call site and the return point. + + Code := (Code and not Priv_Mask) - Rlo_Offset; + + if Code < Exclude_Min or else Code > Exclude_Max then + Trace (J) := Code; + J := J + 1; + end if; + + Pop_Success := Pop_Frame (Frame'Access); + end loop; + + Len := J - 1; + end Call_Chain; + + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + +end System.Traceback; diff --git a/gcc/ada/libgnat/s-traceb-mastop.adb b/gcc/ada/libgnat/s-traceb-mastop.adb new file mode 100644 index 0000000..422d5c5 --- /dev/null +++ b/gcc/ada/libgnat/s-traceb-mastop.adb @@ -0,0 +1,137 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version uses System.Machine_State_Operations routines + +with System.Machine_State_Operations; + +package body System.Traceback is + + use System.Machine_State_Operations; + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc; + pragma Suppress_Initialization (Tracebacks_Array); + + M : Machine_State; + Code : Code_Loc; + + Trace : Tracebacks_Array; + for Trace'Address use Traceback; + + N_Skips : Natural := 0; + + begin + M := Allocate_Machine_State; + Set_Machine_State (M); + + -- Skip the requested number of frames + + loop + Code := Get_Code_Loc (M); + exit when Code = Null_Address or else N_Skips = Skip_Frames; + + Pop_Frame (M); + N_Skips := N_Skips + 1; + end loop; + + -- Now, record the frames outside the exclusion bounds, updating + -- the Len output value along the way. + + Len := 0; + loop + Code := Get_Code_Loc (M); + exit when Code = Null_Address or else Len = Max_Len; + + if Code < Exclude_Min or else Code > Exclude_Max then + Len := Len + 1; + Trace (Len) := Code; + end if; + + Pop_Frame (M); + end loop; + + Free_Machine_State (M); + end Call_Chain; + + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + + ------------------ + -- C_Call_Chain -- + ------------------ + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) return Natural + is + Val : Natural; + begin + Call_Chain (Traceback, Max_Len, Val); + return Val; + end C_Call_Chain; + +end System.Traceback; diff --git a/gcc/ada/libgnat/s-traceb.adb b/gcc/ada/libgnat/s-traceb.adb new file mode 100644 index 0000000..c923a61 --- /dev/null +++ b/gcc/ada/libgnat/s-traceb.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version of this package + +-- Note: this unit must be compiled using -fno-optimize-sibling-calls. +-- See comment below in body of Call_Chain for details on the reason. + +pragma Compiler_Unit_Warning; + +package body System.Traceback is + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Same as the exported version, but takes Traceback as an Address + + ------------------ + -- C_Call_Chain -- + ------------------ + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) return Natural + is + Val : Natural; + begin + Call_Chain (Traceback, Max_Len, Val); + return Val; + end C_Call_Chain; + + ---------------- + -- Call_Chain -- + ---------------- + + function Backtrace + (Traceback : System.Address; + Len : Integer; + Exclude_Min : System.Address; + Exclude_Max : System.Address; + Skip_Frames : Integer) + return Integer; + pragma Import (C, Backtrace, "__gnat_backtrace"); + + procedure Call_Chain + (Traceback : System.Address; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + -- Note: Backtrace relies on the following call actually creating a + -- stack frame. To ensure that this is the case, it is essential to + -- compile this unit without sibling call optimization. + + -- We want the underlying engine to skip its own frame plus the + -- ones we have been requested to skip ourselves. + + Len := Backtrace (Traceback => Traceback, + Len => Max_Len, + Exclude_Min => Exclude_Min, + Exclude_Max => Exclude_Max, + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1) + is + begin + Call_Chain + (Traceback'Address, Max_Len, Len, + Exclude_Min, Exclude_Max, + + -- Skip one extra frame to skip the other Call_Chain entry as well + + Skip_Frames => Skip_Frames + 1); + end Call_Chain; + +end System.Traceback; diff --git a/gcc/ada/libgnat/s-traceb.ads b/gcc/ada/libgnat/s-traceb.ads new file mode 100644 index 0000000..81ab8f9 --- /dev/null +++ b/gcc/ada/libgnat/s-traceb.ads @@ -0,0 +1,87 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 method for generating a traceback of the current +-- execution location. The traceback shows the locations of calls in the call +-- chain, up to either the top or a designated number of levels. + +pragma Compiler_Unit_Warning; + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with System.Exception_Tables. + +with System.Traceback_Entries; + +package System.Traceback is + + ---------------- + -- Call_Chain -- + ---------------- + + procedure Call_Chain + (Traceback : in out System.Traceback_Entries.Tracebacks_Array; + Max_Len : Natural; + Len : out Natural; + Exclude_Min : System.Address := System.Null_Address; + Exclude_Max : System.Address := System.Null_Address; + Skip_Frames : Natural := 1); + -- Store up to Max_Len code locations in Traceback, corresponding to the + -- current call chain. + -- + -- Traceback is an array of addresses where the result will be stored. + -- + -- Max_Len is the length of the Traceback array. If the call chain is + -- longer than this, then additional entries are discarded, and the + -- traceback is missing some of the highest level entries. + -- + -- Len is the number of addresses returned in the Traceback array + -- + -- Exclude_Min/Exclude_Max, if non null, provide a range of addresses + -- to ignore from the computation of the traceback. + -- + -- Skip_Frames says how many of the most recent calls should at least + -- be excluded from the result, regardless of the exclusion bounds and + -- starting with this procedure itself: 1 means exclude the frame for + -- this procedure, 2 means 1 + exclude the frame for this procedure's + -- caller, ... + -- + -- On return, the Traceback array is filled in, and Len indicates the + -- number of stored entries. The first entry is the most recent call, + -- and the last entry is the highest level call. + + function C_Call_Chain + (Traceback : System.Address; + Max_Len : Natural) return Natural; + pragma Export (C, C_Call_Chain, "system__traceback__c_call_chain"); + -- Version that can be used directly from C + +end System.Traceback; diff --git a/gcc/ada/libgnat/s-traent.adb b/gcc/ada/libgnat/s-traent.adb new file mode 100644 index 0000000..c9c037b --- /dev/null +++ b/gcc/ada/libgnat/s-traent.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K _ E N T R I E S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2003-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions. + +pragma Compiler_Unit_Warning; + +package body System.Traceback_Entries is + + ------------ + -- PC_For -- + ------------ + + function PC_For (TB_Entry : Traceback_Entry) return System.Address is + begin + return TB_Entry; + end PC_For; + + ------------------ + -- TB_Entry_For -- + ------------------ + + function TB_Entry_For (PC : System.Address) return Traceback_Entry is + begin + return PC; + end TB_Entry_For; + +end System.Traceback_Entries; diff --git a/gcc/ada/libgnat/s-traent.ads b/gcc/ada/libgnat/s-traent.ads new file mode 100644 index 0000000..fe4349e --- /dev/null +++ b/gcc/ada/libgnat/s-traent.ads @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K _ E N T R I E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2003-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package offers an abstraction of what is stored in traceback arrays +-- for call-chain computation purposes. By default, as defined in this +-- version of the package, an entry is a mere code location representing the +-- address of a call instruction part of the call-chain. + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we get +-- elaboration circularities with Ada.Exceptions. + +pragma Compiler_Unit_Warning; + +package System.Traceback_Entries is + pragma Preelaborate; + + subtype Traceback_Entry is System.Address; + -- This subtype defines what each traceback array entry contains + + Null_TB_Entry : constant Traceback_Entry := System.Null_Address; + -- This is the value to be used when initializing an entry + + type Tracebacks_Array is array (Positive range <>) of Traceback_Entry; + + function PC_For (TB_Entry : Traceback_Entry) return System.Address; + pragma Inline (PC_For); + -- Returns the address of the call instruction associated with the + -- provided entry. + + function TB_Entry_For (PC : System.Address) return Traceback_Entry; + pragma Inline (TB_Entry_For); + -- Returns an entry representing a frame for a call instruction at PC + +end System.Traceback_Entries; diff --git a/gcc/ada/libgnat/s-trasym-dwarf.adb b/gcc/ada/libgnat/s-trasym-dwarf.adb new file mode 100644 index 0000000..9655722 --- /dev/null +++ b/gcc/ada/libgnat/s-trasym-dwarf.adb @@ -0,0 +1,689 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support for targets using DWARF debug data + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on. + +with Ada.Unchecked_Deallocation; + +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with Ada.Containers.Generic_Array_Sort; + +with System.Address_To_Access_Conversions; +with System.Soft_Links; +with System.CRTL; +with System.Dwarf_Lines; +with System.Exception_Traces; +with System.Standard_Library; +with System.Traceback_Entries; +with System.Strings; +with System.Bounded_Strings; + +package body System.Traceback.Symbolic is + + use System.Bounded_Strings; + use System.Dwarf_Lines; + + subtype Big_String is String (Positive); + -- To deal with C strings + + package Big_String_Conv is new System.Address_To_Access_Conversions + (Big_String); + + type Module_Cache; + type Module_Cache_Acc is access all Module_Cache; + + type Module_Cache is record + Name : Strings.String_Access; + -- Name of the module + + C : Dwarf_Context (In_Exception => True); + -- Context to symbolize an address within this module + + Chain : Module_Cache_Acc; + end record; + + procedure Free is new Ada.Unchecked_Deallocation + (Module_Cache, + Module_Cache_Acc); + + Cache_Chain : Module_Cache_Acc; + -- Simply linked list of modules + + type Module_Array is array (Natural range <>) of Module_Cache_Acc; + type Module_Array_Acc is access Module_Array; + + Modules_Cache : Module_Array_Acc; + -- Sorted array of cached modules (if not null) + + Exec_Module : aliased Module_Cache; + -- Context for the executable + + type Init_State is (Uninitialized, Initialized, Failed); + Exec_Module_State : Init_State := Uninitialized; + -- How Exec_Module is initialized + + procedure Init_Exec_Module; + -- Initialize Exec_Module if not already initialized + + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array; + Suppress_Hex : Boolean) return String; + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence; + Suppress_Hex : Boolean) return String; + -- Suppress_Hex means do not print any hexadecimal addresses, even if the + -- symbol is not available. + + function Lt (Left, Right : Module_Cache_Acc) return Boolean; + -- Sort function for Module_Cache + + procedure Init_Module + (Module : out Module_Cache; + Success : out Boolean; + Module_Name : String; + Load_Address : Address := Null_Address); + -- Initialize Module + + procedure Close_Module (Module : in out Module_Cache); + -- Finalize Module + + function Value (Item : System.Address) return String; + -- Return the String contained in Item, up until the first NUL character + + pragma Warnings (Off, "*Add_Module_To_Cache*"); + procedure Add_Module_To_Cache (Module_Name : String); + -- To be called by Build_Cache_For_All_Modules to add a new module to the + -- list. May not be referenced. + + package Module_Name is + + procedure Build_Cache_For_All_Modules; + -- Create the cache for all current modules + + function Get (Addr : access System.Address) return String; + -- Returns the module name for the given address, Addr may be updated + -- to be set relative to a shared library. This depends on the platform. + -- Returns an empty string for the main executable. + + function Is_Supported return Boolean; + pragma Inline (Is_Supported); + -- Returns True if Module_Name is supported, so if the traceback is + -- supported for shared libraries. + + end Module_Name; + + package body Module_Name is separate; + + function Executable_Name return String; + -- Returns the executable name as reported by argv[0]. If gnat_argv not + -- initialized or if argv[0] executable not found in path, function returns + -- an empty string. + + function Get_Executable_Load_Address return System.Address; + pragma Import + (C, + Get_Executable_Load_Address, + "__gnat_get_executable_load_address"); + -- Get the load address of the executable, or Null_Address if not known + + procedure Hexa_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Non-symbolic traceback (simply write addresses in hexa) + + procedure Symbolic_Traceback_No_Lock + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Like the public Symbolic_Traceback_No_Lock except there is no provision + -- against concurrent accesses. + + procedure Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Returns the Traceback for a given module + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Build string containing symbolic traceback for the given call chain + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String); + -- Likewise but using Module + + Max_String_Length : constant := 4096; + -- Arbitrary limit on Bounded_Str length + + ----------- + -- Value -- + ----------- + + function Value (Item : System.Address) return String is + begin + if Item /= Null_Address then + for J in Big_String'Range loop + if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then + return Big_String_Conv.To_Pointer (Item) (1 .. J - 1); + end if; + end loop; + end if; + + return ""; + end Value; + + ------------------------- + -- Add_Module_To_Cache -- + ------------------------- + + procedure Add_Module_To_Cache (Module_Name : String) is + Module : Module_Cache_Acc; + Success : Boolean; + begin + Module := new Module_Cache; + Init_Module (Module.all, Success, Module_Name); + if not Success then + Free (Module); + return; + end if; + Module.Chain := Cache_Chain; + Cache_Chain := Module; + end Add_Module_To_Cache; + + ---------------------- + -- Init_Exec_Module -- + ---------------------- + + procedure Init_Exec_Module is + begin + if Exec_Module_State = Uninitialized then + declare + Exec_Path : constant String := Executable_Name; + Exec_Load : constant Address := Get_Executable_Load_Address; + Success : Boolean; + begin + Init_Module (Exec_Module, Success, Exec_Path, Exec_Load); + + if Success then + Exec_Module_State := Initialized; + else + Exec_Module_State := Failed; + end if; + end; + end if; + end Init_Exec_Module; + + -------- + -- Lt -- + -------- + + function Lt (Left, Right : Module_Cache_Acc) return Boolean is + begin + return Low (Left.C) < Low (Right.C); + end Lt; + + ----------------------------- + -- Module_Cache_Array_Sort -- + ----------------------------- + + procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort + (Natural, + Module_Cache_Acc, + Module_Array, + Lt); + + ------------------ + -- Enable_Cache -- + ------------------ + + procedure Enable_Cache (Include_Modules : Boolean := False) is + begin + -- Can be called at most once + if Cache_Chain /= null then + return; + end if; + + -- Add all modules + Init_Exec_Module; + Cache_Chain := Exec_Module'Access; + + if Include_Modules then + Module_Name.Build_Cache_For_All_Modules; + end if; + + -- Build and fill the array of modules + declare + Count : Natural; + Module : Module_Cache_Acc; + begin + for Phase in 1 .. 2 loop + Count := 0; + Module := Cache_Chain; + while Module /= null loop + Count := Count + 1; + + if Phase = 1 then + Enable_Cache (Module.C); + else + Modules_Cache (Count) := Module; + end if; + Module := Module.Chain; + end loop; + + if Phase = 1 then + Modules_Cache := new Module_Array (1 .. Count); + end if; + end loop; + end; + + -- Sort the array + Module_Cache_Array_Sort (Modules_Cache.all); + end Enable_Cache; + + --------------------- + -- Executable_Name -- + --------------------- + + function Executable_Name return String is + -- We have to import gnat_argv as an Address to match the type of + -- gnat_argv in the binder generated file. Otherwise, we get spurious + -- warnings about type mismatch when LTO is turned on. + + Gnat_Argv : System.Address; + pragma Import (C, Gnat_Argv, "gnat_argv"); + + type Argv_Array is array (0 .. 0) of System.Address; + package Conv is new System.Address_To_Access_Conversions (Argv_Array); + + function locate_exec_on_path (A : System.Address) return System.Address; + pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path"); + + begin + if Gnat_Argv = Null_Address then + return ""; + end if; + + declare + Addr : constant System.Address := + locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0)); + Result : constant String := Value (Addr); + + begin + -- The buffer returned by locate_exec_on_path was allocated using + -- malloc, so we should use free to release the memory. + + if Addr /= Null_Address then + System.CRTL.free (Addr); + end if; + + return Result; + end; + end Executable_Name; + + ------------------ + -- Close_Module -- + ------------------ + + procedure Close_Module (Module : in out Module_Cache) is + begin + Close (Module.C); + Strings.Free (Module.Name); + end Close_Module; + + ----------------- + -- Init_Module -- + ----------------- + + procedure Init_Module + (Module : out Module_Cache; + Success : out Boolean; + Module_Name : String; + Load_Address : Address := Null_Address) + is + begin + -- Early return if the module is not known + + if Module_Name = "" then + Success := False; + return; + end if; + + Open (Module_Name, Module.C, Success); + + -- If a module can't be opened just return now, we just cannot give more + -- information in this case. + + if not Success then + return; + end if; + + Set_Load_Address (Module.C, Load_Address); + + Module.Name := new String'(Module_Name); + end Init_Module; + + ------------------------------- + -- Module_Symbolic_Traceback -- + ------------------------------- + + procedure Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + Success : Boolean := False; + begin + if Symbolic.Module_Name.Is_Supported then + Append (Res, '['); + Append (Res, Module.Name.all); + Append (Res, ']' & ASCII.LF); + end if; + + Dwarf_Lines.Symbolic_Traceback + (Module.C, + Traceback, + Suppress_Hex, + Success, + Res); + + if not Success then + Hexa_Traceback (Traceback, Suppress_Hex, Res); + end if; + + -- We must not allow an unhandled exception here, since this function + -- may be installed as a decorator for all automatic exceptions. + + exception + when others => + return; + end Module_Symbolic_Traceback; + + ------------------------------------- + -- Multi_Module_Symbolic_Traceback -- + ------------------------------------- + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + F : constant Natural := Traceback'First; + begin + if Traceback'Length = 0 or else Is_Full (Res) then + return; + end if; + + if Modules_Cache /= null then + -- Search in the cache + + declare + Addr : constant Address := Traceback (F); + Hi, Lo, Mid : Natural; + begin + Lo := Modules_Cache'First; + Hi := Modules_Cache'Last; + while Lo <= Hi loop + Mid := (Lo + Hi) / 2; + if Addr < Low (Modules_Cache (Mid).C) then + Hi := Mid - 1; + elsif Is_Inside (Modules_Cache (Mid).C, Addr) then + Multi_Module_Symbolic_Traceback + (Traceback, + Modules_Cache (Mid).all, + Suppress_Hex, + Res); + return; + else + Lo := Mid + 1; + end if; + end loop; + + -- Not found + Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); + Multi_Module_Symbolic_Traceback + (Traceback (F + 1 .. Traceback'Last), + Suppress_Hex, + Res); + end; + else + + -- First try the executable + if Is_Inside (Exec_Module.C, Traceback (F)) then + Multi_Module_Symbolic_Traceback + (Traceback, + Exec_Module, + Suppress_Hex, + Res); + return; + end if; + + -- Otherwise, try a shared library + declare + Addr : aliased System.Address := Traceback (F); + M_Name : constant String := Module_Name.Get (Addr'Access); + Module : Module_Cache; + Success : Boolean; + begin + Init_Module (Module, Success, M_Name, System.Null_Address); + if Success then + Multi_Module_Symbolic_Traceback + (Traceback, + Module, + Suppress_Hex, + Res); + Close_Module (Module); + else + -- Module not found + Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); + Multi_Module_Symbolic_Traceback + (Traceback (F + 1 .. Traceback'Last), + Suppress_Hex, + Res); + end if; + end; + end if; + end Multi_Module_Symbolic_Traceback; + + procedure Multi_Module_Symbolic_Traceback + (Traceback : Tracebacks_Array; + Module : Module_Cache; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + Pos : Positive; + begin + -- Will symbolize the first address... + + Pos := Traceback'First + 1; + + -- ... and all addresses in the same module + + Same_Module : + loop + exit Same_Module when Pos > Traceback'Last; + + -- Get address to check for corresponding module name + + exit Same_Module when not Is_Inside (Module.C, Traceback (Pos)); + + Pos := Pos + 1; + end loop Same_Module; + + Module_Symbolic_Traceback + (Traceback (Traceback'First .. Pos - 1), + Module, + Suppress_Hex, + Res); + Multi_Module_Symbolic_Traceback + (Traceback (Pos .. Traceback'Last), + Suppress_Hex, + Res); + end Multi_Module_Symbolic_Traceback; + + -------------------- + -- Hexa_Traceback -- + -------------------- + + procedure Hexa_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + use System.Traceback_Entries; + begin + if Suppress_Hex then + Append (Res, "..."); + Append (Res, ASCII.LF); + else + for J in Traceback'Range loop + Append_Address (Res, PC_For (Traceback (J))); + Append (Res, ASCII.LF); + end loop; + end if; + end Hexa_Traceback; + + -------------------------------- + -- Symbolic_Traceback_No_Lock -- + -------------------------------- + + procedure Symbolic_Traceback_No_Lock + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean; + Res : in out Bounded_String) + is + begin + if Symbolic.Module_Name.Is_Supported then + Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res); + else + if Exec_Module_State = Failed then + Append (Res, "Call stack traceback locations:" & ASCII.LF); + Hexa_Traceback (Traceback, Suppress_Hex, Res); + else + Module_Symbolic_Traceback + (Traceback, + Exec_Module, + Suppress_Hex, + Res); + end if; + end if; + end Symbolic_Traceback_No_Lock; + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback + (Traceback : Tracebacks_Array; + Suppress_Hex : Boolean) return String + is + Res : Bounded_String (Max_Length => Max_String_Length); + begin + System.Soft_Links.Lock_Task.all; + Init_Exec_Module; + Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); + System.Soft_Links.Unlock_Task.all; + + return To_String (Res); + + exception + when others => + System.Soft_Links.Unlock_Task.all; + raise; + end Symbolic_Traceback; + + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is + begin + return Symbolic_Traceback (Traceback, Suppress_Hex => False); + end Symbolic_Traceback; + + function Symbolic_Traceback_No_Hex + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is + begin + return Symbolic_Traceback (Traceback, Suppress_Hex => True); + end Symbolic_Traceback_No_Hex; + + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence; + Suppress_Hex : Boolean) return String + is + begin + return Symbolic_Traceback + (Ada.Exceptions.Traceback.Tracebacks (E), + Suppress_Hex); + end Symbolic_Traceback; + + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence) return String + is + begin + return Symbolic_Traceback (E, Suppress_Hex => False); + end Symbolic_Traceback; + + function Symbolic_Traceback_No_Hex + (E : Ada.Exceptions.Exception_Occurrence) return String is + begin + return Symbolic_Traceback (E, Suppress_Hex => True); + end Symbolic_Traceback_No_Hex; + + Exception_Tracebacks_Symbolic : Integer; + pragma Import + (C, + Exception_Tracebacks_Symbolic, + "__gl_exception_tracebacks_symbolic"); + -- Boolean indicating whether symbolic tracebacks should be generated. + + use Standard_Library; +begin + -- If this version of this package is available, and the binder switch -Es + -- was given, then we want to use this as the decorator by default, and we + -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user + -- cannot have already set Exception_Trace, because the runtime library is + -- elaborated before user-defined code. + + if Exception_Tracebacks_Symbolic /= 0 then + Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access); + pragma Assert (Exception_Trace = RM_Convention); + Exception_Trace := Unhandled_Raise_In_Main; + end if; +end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-trasym.adb b/gcc/ada/libgnat/s-trasym.adb new file mode 100644 index 0000000..070f9a9 --- /dev/null +++ b/gcc/ada/libgnat/s-trasym.adb @@ -0,0 +1,112 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default implementation for platforms where the full capability +-- is not supported. It returns tracebacks as lists of hexadecimal addresses +-- of the form "0x...". + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on. + +with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; +with System.Address_Image; + +package body System.Traceback.Symbolic is + + -- Note that Suppress_Hex is ignored in this version of this package. + + ------------------------ + -- Symbolic_Traceback -- + ------------------------ + + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String + is + begin + if Traceback'Length = 0 then + return ""; + + else + declare + Img : String := System.Address_Image (Traceback (Traceback'First)); + + Result : String (1 .. (Img'Length + 3) * Traceback'Length); + Last : Natural := 0; + + begin + for J in Traceback'Range loop + Img := System.Address_Image (Traceback (J)); + Result (Last + 1 .. Last + 2) := "0x"; + Last := Last + 2; + Result (Last + 1 .. Last + Img'Length) := Img; + Last := Last + Img'Length + 1; + Result (Last) := ' '; + end loop; + + Result (Last) := ASCII.LF; + return Result (1 .. Last); + end; + end if; + end Symbolic_Traceback; + + -- "No_Hex" is ignored in this version, because otherwise we have nothing + -- at all to print. + + function Symbolic_Traceback_No_Hex + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is + begin + return Symbolic_Traceback (Traceback); + end Symbolic_Traceback_No_Hex; + + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence) return String + is + begin + return Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E)); + end Symbolic_Traceback; + + function Symbolic_Traceback_No_Hex + (E : Ada.Exceptions.Exception_Occurrence) return String is + begin + return Symbolic_Traceback (E); + end Symbolic_Traceback_No_Hex; + + ------------------ + -- Enable_Cache -- + ------------------ + + procedure Enable_Cache (Include_Modules : Boolean := False) is + begin + null; + end Enable_Cache; + +end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-trasym.ads b/gcc/ada/libgnat/s-trasym.ads new file mode 100644 index 0000000..04b9be8 --- /dev/null +++ b/gcc/ada/libgnat/s-trasym.ads @@ -0,0 +1,111 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1999-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Run-time symbolic traceback support + +-- The full capability is currently supported on the following targets: + +-- GNU/Linux x86, x86_64, ia64 + +-- Note: on targets other than those listed above, a dummy implementation +-- of the body returns a series of LF separated strings of the form "0x..." +-- corresponding to the addresses. + +-- The routines provided in this package assume that your application has been +-- compiled with debugging information turned on, since this information is +-- used to build a symbolic traceback. + +-- If you want to retrieve tracebacks from exception occurrences, it is also +-- necessary to invoke the binder with -E switch. Please refer to the gnatbind +-- documentation for more information. + +-- Note that it is also possible (and often recommended) to compute symbolic +-- traceback outside the program execution, which in addition allows you to +-- distribute the executable with no debug info: +-- +-- - build your executable with debug info +-- - archive this executable +-- - strip a copy of the executable and distribute/deploy this version +-- - at run time, compute absolute traceback (-bargs -E) from your +-- executable and log it using Ada.Exceptions.Exception_Information +-- - off line, compute the symbolic traceback using the executable archived +-- with debug info and addr2line or gdb (using info line *) on the +-- absolute addresses logged by your application. + +-- In order to retrieve symbolic information, functions in this package will +-- read on disk all the debug information of the executable file (found via +-- Argument (0), and looked in the PATH if needed) or shared libraries using +-- OS facilities, and load them in memory, causing a significant cpu and +-- memory overhead. + +-- Symbolic traceback from shared libraries is only supported for Windows and +-- Linux. On other targets symbolic tracebacks are only supported for the main +-- executable. You should consider using gdb to obtain symbolic traceback in +-- such cases. + +pragma Polling (Off); +-- We must turn polling off for this unit, because otherwise we can get +-- elaboration circularities when polling is turned on. + +with Ada.Exceptions; + +package System.Traceback.Symbolic is + pragma Elaborate_Body; + + function Symbolic_Traceback + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String; + function Symbolic_Traceback_No_Hex + (Traceback : System.Traceback_Entries.Tracebacks_Array) return String; + -- Build a string containing a symbolic traceback of the given call + -- chain. Note: These procedures may be installed by Set_Trace_Decorator, + -- to get a symbolic traceback on all exceptions raised (see + -- System.Exception_Traces). + + function Symbolic_Traceback + (E : Ada.Exceptions.Exception_Occurrence) return String; + function Symbolic_Traceback_No_Hex + (E : Ada.Exceptions.Exception_Occurrence) return String; + -- Build string containing symbolic traceback of given exception occurrence + + -- In the above, _No_Hex means do not print any hexadecimal addresses, even + -- if the symbol is not available. This is useful for getting deterministic + -- output from tests. + + procedure Enable_Cache (Include_Modules : Boolean := False); + -- Read symbolic information from binary files and cache them in memory. + -- This will speed up the above functions but will require more memory. If + -- Include_Modules is true, shared modules (or DLL) will also be cached. + -- This procedure may do nothing if not supported. The profile of this + -- subprogram may change in the future (new parameters can be added + -- with default value), but backward compatibility for direct calls + -- is supported. + +end System.Traceback.Symbolic; diff --git a/gcc/ada/libgnat/s-tsmona-linux.adb b/gcc/ada/libgnat/s-tsmona-linux.adb new file mode 100644 index 0000000..8c1f8b4 --- /dev/null +++ b/gcc/ada/libgnat/s-tsmona-linux.adb @@ -0,0 +1,190 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . M O D U L E _ N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the GNU/Linux specific version of this package +with Interfaces.C; use Interfaces.C; + +with System.Address_Operations; use System.Address_Operations; + +separate (System.Traceback.Symbolic) + +package body Module_Name is + + use System; + + pragma Linker_Options ("-ldl"); + + function Is_Shared_Lib (Base : Address) return Boolean; + -- Returns True if a shared library + + -- The principle is: + + -- 1. We get information about the module containing the address. + + -- 2. We check that the full pathname is pointing to a shared library. + + -- 3. for shared libraries, we return the non relocated address (so + -- the absolute address in the shared library). + + -- 4. we also return the full pathname of the module containing this + -- address. + + ------------------- + -- Is_Shared_Lib -- + ------------------- + + function Is_Shared_Lib (Base : Address) return Boolean is + EI_NIDENT : constant := 16; + type u16 is mod 2 ** 16; + + -- Just declare the needed header information, we just need to read the + -- type encoded in the second field. + + type Elf32_Ehdr is record + e_ident : char_array (1 .. EI_NIDENT); + e_type : u16; + end record; + + ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN + + Header : Elf32_Ehdr; + pragma Import (Ada, Header); + -- Suppress initialization in Normalized_Scalars mode + for Header'Address use Base; + + begin + return Header.e_type = ET_DYN; + exception + when others => + return False; + end Is_Shared_Lib; + + --------------------------------- + -- Build_Cache_For_All_Modules -- + --------------------------------- + + procedure Build_Cache_For_All_Modules is + type link_map; + type link_map_acc is access all link_map; + pragma Convention (C, link_map_acc); + + type link_map is record + l_addr : Address; + -- Base address of the shared object + + l_name : Address; + -- Null-terminated absolute file name + + l_ld : Address; + -- Dynamic section + + l_next, l_prev : link_map_acc; + -- Chain + end record; + pragma Convention (C, link_map); + + type r_debug_type is record + r_version : Integer; + r_map : link_map_acc; + end record; + pragma Convention (C, r_debug_type); + + r_debug : r_debug_type; + pragma Import (C, r_debug, "_r_debug"); + + lm : link_map_acc; + begin + lm := r_debug.r_map; + while lm /= null loop + if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then + -- Discard non-file (like the executable itself or the gate). + Add_Module_To_Cache (Value (lm.l_name)); + end if; + lm := lm.l_next; + end loop; + end Build_Cache_For_All_Modules; + + --------- + -- Get -- + --------- + + function Get (Addr : access System.Address) return String is + + -- Dl_info record for Linux, used to get sym reloc offset + + type Dl_info is record + dli_fname : System.Address; + dli_fbase : System.Address; + dli_sname : System.Address; + dli_saddr : System.Address; + end record; + + function dladdr + (addr : System.Address; + info : not null access Dl_info) return int; + pragma Import (C, dladdr, "dladdr"); + -- This is a Linux extension and not POSIX + + info : aliased Dl_info; + + begin + if dladdr (Addr.all, info'Access) /= 0 then + + -- If we have a shared library we need to adjust the address to + -- be relative to the base address of the library. + + if Is_Shared_Lib (info.dli_fbase) then + Addr.all := SubA (Addr.all, info.dli_fbase); + end if; + + return Value (info.dli_fname); + + -- Not found, fallback to executable name + + else + return ""; + end if; + + exception + when others => + return ""; + end Get; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported return Boolean is + begin + return True; + end Is_Supported; + +end Module_Name; diff --git a/gcc/ada/libgnat/s-tsmona-mingw.adb b/gcc/ada/libgnat/s-tsmona-mingw.adb new file mode 100644 index 0000000..46c35cd --- /dev/null +++ b/gcc/ada/libgnat/s-tsmona-mingw.adb @@ -0,0 +1,93 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . M O D U L E _ N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the Windows specific version of this package + +with System.Win32; use System.Win32; + +separate (System.Traceback.Symbolic) + +package body Module_Name is + + use System; + + --------------------------------- + -- Build_Cache_For_All_Modules -- + --------------------------------- + + procedure Build_Cache_For_All_Modules is + begin + null; + end Build_Cache_For_All_Modules; + + --------- + -- Get -- + --------- + + function Get (Addr : access System.Address) return String is + Res : DWORD; + hModule : aliased HANDLE; + Path : String (1 .. 1_024); + + begin + if GetModuleHandleEx + (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, + Addr.all, + hModule'Access) = Win32.TRUE + then + Res := GetModuleFileName (hModule, Path'Address, Path'Length); + + if FreeLibrary (hModule) = Win32.FALSE then + null; + end if; + + if Res > 0 then + return Path (1 .. Positive (Res)); + end if; + end if; + + return ""; + + exception + when others => + return ""; + end Get; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported return Boolean is + begin + return True; + end Is_Supported; + +end Module_Name; diff --git a/gcc/ada/libgnat/s-tsmona.adb b/gcc/ada/libgnat/s-tsmona.adb new file mode 100644 index 0000000..95edb6b --- /dev/null +++ b/gcc/ada/libgnat/s-tsmona.adb @@ -0,0 +1,67 @@ +------------------------------------------------------------------------------ +-- -- +-- 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 . M O D U L E _ N A M E -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2012-2017, AdaCore -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the default version of this package + +separate (System.Traceback.Symbolic) + +package body Module_Name is + + --------------------------------- + -- Build_Cache_For_All_Modules -- + --------------------------------- + + procedure Build_Cache_For_All_Modules is + begin + null; + end Build_Cache_For_All_Modules; + + --------- + -- Get -- + --------- + + function Get (Addr : access System.Address) return String is + pragma Unreferenced (Addr); + + begin + return ""; + end Get; + + ------------------ + -- Is_Supported -- + ------------------ + + function Is_Supported return Boolean is + begin + return False; + end Is_Supported; + +end Module_Name; diff --git a/gcc/ada/libgnat/s-unstyp.ads b/gcc/ada/libgnat/s-unstyp.ads new file mode 100644 index 0000000..97bd337 --- /dev/null +++ b/gcc/ada/libgnat/s-unstyp.ads @@ -0,0 +1,215 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . U N S I G N E D _ T Y P E S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains definitions of standard unsigned types that +-- correspond in size to the standard signed types declared in Standard, +-- and (unlike the types in Interfaces) have corresponding names. It +-- also contains some related definitions for other specialized types +-- used by the compiler in connection with packed array types. + +pragma Compiler_Unit_Warning; + +package System.Unsigned_Types is + pragma Pure; + pragma No_Elaboration_Code_All; + + type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size; + type Short_Unsigned is mod 2 ** Short_Integer'Size; + type Unsigned is mod 2 ** Integer'Size; + type Long_Unsigned is mod 2 ** Long_Integer'Size; + type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; + + type Float_Unsigned is mod 2 ** Float'Size; + -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr) + + type Packed_Byte is mod 2 ** 8; + pragma Universal_Aliasing (Packed_Byte); + for Packed_Byte'Size use 8; + -- Component type for Packed_Bytes1, Packed_Bytes2 and Packed_Byte4 arrays. + -- As this type is used by the compiler to implement operations on user + -- packed array, it needs to be able to alias any type. + + type Packed_Bytes1 is array (Natural range <>) of aliased Packed_Byte; + for Packed_Bytes1'Alignment use 1; + for Packed_Bytes1'Component_Size use Packed_Byte'Size; + pragma Suppress_Initialization (Packed_Bytes1); + -- This is the type used to implement packed arrays where no alignment + -- is required. This includes the cases of 1,2,4 (where we use direct + -- masking operations), and all odd component sizes (where the clusters + -- are not aligned anyway, see, e.g. System.Pack_07 in file s-pack07 + -- for details. + + type Packed_Bytes2 is new Packed_Bytes1; + for Packed_Bytes2'Alignment use Integer'Min (2, Standard'Maximum_Alignment); + pragma Suppress_Initialization (Packed_Bytes2); + -- This is the type used to implement packed arrays where an alignment + -- of 2 (is possible) is helpful for maximum efficiency of the get and + -- set routines in the corresponding library unit. This is true of all + -- component sizes that are even but not divisible by 4 (other than 2 for + -- which we use direct masking operations). In such cases, the clusters + -- can be assumed to be 2-byte aligned if the array is aligned. See for + -- example System.Pack_10 in file s-pack10). + + type Packed_Bytes4 is new Packed_Bytes1; + for Packed_Bytes4'Alignment use Integer'Min (4, Standard'Maximum_Alignment); + pragma Suppress_Initialization (Packed_Bytes4); + -- This is the type used to implement packed arrays where an alignment + -- of 4 (if possible) is helpful for maximum efficiency of the get and + -- set routines in the corresponding library unit. This is true of all + -- component sizes that are divisible by 4 (other than powers of 2, which + -- are either handled by direct masking or not packed at all). In such + -- cases the clusters can be assumed to be 4-byte aligned if the array + -- is aligned (see System.Pack_12 in file s-pack12 as an example). + + type Bits_1 is mod 2**1; + type Bits_2 is mod 2**2; + type Bits_4 is mod 2**4; + -- Types used for packed array conversions + + subtype Bytes_F is Packed_Bytes4 (1 .. Float'Size / 8); + -- Type used in implementation of Is_Negative intrinsic (see Exp_Intr) + + function Shift_Left + (Value : Short_Short_Unsigned; + Amount : Natural) return Short_Short_Unsigned; + + function Shift_Right + (Value : Short_Short_Unsigned; + Amount : Natural) return Short_Short_Unsigned; + + function Shift_Right_Arithmetic + (Value : Short_Short_Unsigned; + Amount : Natural) return Short_Short_Unsigned; + + function Rotate_Left + (Value : Short_Short_Unsigned; + Amount : Natural) return Short_Short_Unsigned; + + function Rotate_Right + (Value : Short_Short_Unsigned; + Amount : Natural) return Short_Short_Unsigned; + + function Shift_Left + (Value : Short_Unsigned; + Amount : Natural) return Short_Unsigned; + + function Shift_Right + (Value : Short_Unsigned; + Amount : Natural) return Short_Unsigned; + + function Shift_Right_Arithmetic + (Value : Short_Unsigned; + Amount : Natural) return Short_Unsigned; + + function Rotate_Left + (Value : Short_Unsigned; + Amount : Natural) return Short_Unsigned; + + function Rotate_Right + (Value : Short_Unsigned; + Amount : Natural) return Short_Unsigned; + + function Shift_Left + (Value : Unsigned; + Amount : Natural) return Unsigned; + + function Shift_Right + (Value : Unsigned; + Amount : Natural) return Unsigned; + + function Shift_Right_Arithmetic + (Value : Unsigned; + Amount : Natural) return Unsigned; + + function Rotate_Left + (Value : Unsigned; + Amount : Natural) return Unsigned; + + function Rotate_Right + (Value : Unsigned; + Amount : Natural) return Unsigned; + + function Shift_Left + (Value : Long_Unsigned; + Amount : Natural) return Long_Unsigned; + + function Shift_Right + (Value : Long_Unsigned; + Amount : Natural) return Long_Unsigned; + + function Shift_Right_Arithmetic + (Value : Long_Unsigned; + Amount : Natural) return Long_Unsigned; + + function Rotate_Left + (Value : Long_Unsigned; + Amount : Natural) return Long_Unsigned; + + function Rotate_Right + (Value : Long_Unsigned; + Amount : Natural) return Long_Unsigned; + + function Shift_Left + (Value : Long_Long_Unsigned; + Amount : Natural) return Long_Long_Unsigned; + + function Shift_Right + (Value : Long_Long_Unsigned; + Amount : Natural) return Long_Long_Unsigned; + + function Shift_Right_Arithmetic + (Value : Long_Long_Unsigned; + Amount : Natural) return Long_Long_Unsigned; + + function Rotate_Left + (Value : Long_Long_Unsigned; + Amount : Natural) return Long_Long_Unsigned; + + function Rotate_Right + (Value : Long_Long_Unsigned; + Amount : Natural) return Long_Long_Unsigned; + + pragma Import (Intrinsic, Shift_Left); + pragma Import (Intrinsic, Shift_Right); + pragma Import (Intrinsic, Shift_Right_Arithmetic); + pragma Import (Intrinsic, Rotate_Left); + pragma Import (Intrinsic, Rotate_Right); + + -- The following definitions are obsolescent. They were needed by the + -- previous version of the compiler and runtime, but are not needed + -- by the current version. We retain them to help with bootstrap path + -- problems. Also they seem harmless, and if any user programs have + -- been using these types, why discombobulate them? + + subtype Packed_Bytes is Packed_Bytes4; + subtype Packed_Bytes_Unaligned is Packed_Bytes1; + +end System.Unsigned_Types; diff --git a/gcc/ada/libgnat/s-utf_32.adb b/gcc/ada/libgnat/s-utf_32.adb new file mode 100644 index 0000000..8871a56 --- /dev/null +++ b/gcc/ada/libgnat/s-utf_32.adb @@ -0,0 +1,6356 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . U T F _ 3 2 -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +pragma Style_Checks (Off); +-- Allow long lines in this unit. Note this could be more specific, but we +-- keep this simple form because of bootstrap constraints ??? + +-- pragma Warnings (Off, "non-static constant in preelaborated unit"); +-- We need this to be pure, and the three constants in question are not a +-- real problem, they are completely known at compile time. This pragma +-- is commented out for now, because we still want to be able to bootstrap +-- with old versions of the compiler that did not support this form. We +-- have added additional pragma Warnings (Off/On) for now ??? + +package body System.UTF_32 is + + ---------------------- + -- Character Tables -- + ---------------------- + + -- Note these tables are derived from those given in AI-285. For details + -- see //www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00285.TXT?rev=1.22. + + type UTF_32_Range is record + Lo : UTF_32; + Hi : UTF_32; + end record; + + type UTF_32_Ranges is array (Positive range <>) of UTF_32_Range; + + -- The following array includes ranges for all codes with defined unicode + -- categories (a group of characters is in the same range if and only if + -- they share the same category, indicated in the comment). + + -- Note that we do not try to take care of FFFE/FFFF cases in this table + + Unicode_Ranges : constant UTF_32_Ranges := ( + (16#00000#, 16#0001F#), -- (Cc) .. + (16#00020#, 16#00020#), -- (Zs) SPACE .. SPACE + (16#00021#, 16#00023#), -- (Po) EXCLAMATION MARK .. NUMBER SIGN + (16#00024#, 16#00024#), -- (Sc) DOLLAR SIGN .. DOLLAR SIGN + (16#00025#, 16#00027#), -- (Po) PERCENT SIGN .. APOSTROPHE + (16#00028#, 16#00028#), -- (Ps) LEFT PARENTHESIS .. LEFT PARENTHESIS + (16#00029#, 16#00029#), -- (Pe) RIGHT PARENTHESIS .. RIGHT PARENTHESIS + (16#0002A#, 16#0002A#), -- (Po) ASTERISK .. ASTERISK + (16#0002B#, 16#0002B#), -- (Sm) PLUS SIGN .. PLUS SIGN + (16#0002C#, 16#0002C#), -- (Po) COMMA .. COMMA + (16#0002D#, 16#0002D#), -- (Pd) HYPHEN-MINUS .. HYPHEN-MINUS + (16#0002E#, 16#0002F#), -- (Po) FULL STOP .. SOLIDUS + (16#00030#, 16#00039#), -- (Nd) DIGIT ZERO .. DIGIT NINE + (16#0003A#, 16#0003B#), -- (Po) COLON .. SEMICOLON + (16#0003C#, 16#0003E#), -- (Sm) LESS-THAN SIGN .. GREATER-THAN SIGN + (16#0003F#, 16#00040#), -- (Po) QUESTION MARK .. COMMERCIAL AT + (16#00041#, 16#0005A#), -- (Lu) LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z + (16#0005B#, 16#0005B#), -- (Ps) LEFT SQUARE BRACKET .. LEFT SQUARE BRACKET + (16#0005C#, 16#0005C#), -- (Po) REVERSE SOLIDUS .. REVERSE SOLIDUS + (16#0005D#, 16#0005D#), -- (Pe) RIGHT SQUARE BRACKET .. RIGHT SQUARE BRACKET + (16#0005E#, 16#0005E#), -- (Sk) CIRCUMFLEX ACCENT .. CIRCUMFLEX ACCENT + (16#0005F#, 16#0005F#), -- (Pc) LOW LINE .. LOW LINE + (16#00060#, 16#00060#), -- (Sk) GRAVE ACCENT .. GRAVE ACCENT + (16#00061#, 16#0007A#), -- (Ll) LATIN SMALL LETTER A .. LATIN SMALL LETTER Z + (16#0007B#, 16#0007B#), -- (Ps) LEFT CURLY BRACKET .. LEFT CURLY BRACKET + (16#0007C#, 16#0007C#), -- (Sm) VERTICAL LINE .. VERTICAL LINE + (16#0007D#, 16#0007D#), -- (Pe) RIGHT CURLY BRACKET .. RIGHT CURLY BRACKET + (16#0007E#, 16#0007E#), -- (Sm) TILDE .. TILDE + (16#0007F#, 16#0009F#), -- (Cc) .. + (16#000A0#, 16#000A0#), -- (Zs) NO-BREAK SPACE .. NO-BREAK SPACE + (16#000A1#, 16#000A1#), -- (Po) INVERTED EXCLAMATION MARK .. INVERTED EXCLAMATION MARK + (16#000A2#, 16#000A5#), -- (Sc) CENT SIGN .. YEN SIGN + (16#000A6#, 16#000A7#), -- (So) BROKEN BAR .. SECTION SIGN + (16#000A8#, 16#000A8#), -- (Sk) DIAERESIS .. DIAERESIS + (16#000A9#, 16#000A9#), -- (So) COPYRIGHT SIGN .. COPYRIGHT SIGN + (16#000AA#, 16#000AA#), -- (Ll) FEMININE ORDINAL INDICATOR .. FEMININE ORDINAL INDICATOR + (16#000AB#, 16#000AB#), -- (Pi) LEFT-POINTING DOUBLE ANGLE QUOTATION MARK .. LEFT-POINTING DOUBLE ANGLE QUOTATION MARK + (16#000AC#, 16#000AC#), -- (Sm) NOT SIGN .. NOT SIGN + (16#000AD#, 16#000AD#), -- (Cf) SOFT HYPHEN .. SOFT HYPHEN + (16#000AE#, 16#000AE#), -- (So) REGISTERED SIGN .. REGISTERED SIGN + (16#000AF#, 16#000AF#), -- (Sk) MACRON .. MACRON + (16#000B0#, 16#000B0#), -- (So) DEGREE SIGN .. DEGREE SIGN + (16#000B1#, 16#000B1#), -- (Sm) PLUS-MINUS SIGN .. PLUS-MINUS SIGN + (16#000B2#, 16#000B3#), -- (No) SUPERSCRIPT TWO .. SUPERSCRIPT THREE + (16#000B4#, 16#000B4#), -- (Sk) ACUTE ACCENT .. ACUTE ACCENT + (16#000B5#, 16#000B5#), -- (Ll) MICRO SIGN .. MICRO SIGN + (16#000B6#, 16#000B6#), -- (So) PILCROW SIGN .. PILCROW SIGN + (16#000B7#, 16#000B7#), -- (Po) MIDDLE DOT .. MIDDLE DOT + (16#000B8#, 16#000B8#), -- (Sk) CEDILLA .. CEDILLA + (16#000B9#, 16#000B9#), -- (No) SUPERSCRIPT ONE .. SUPERSCRIPT ONE + (16#000BA#, 16#000BA#), -- (Ll) MASCULINE ORDINAL INDICATOR .. MASCULINE ORDINAL INDICATOR + (16#000BB#, 16#000BB#), -- (Pf) RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK .. RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK + (16#000BC#, 16#000BE#), -- (No) VULGAR FRACTION ONE QUARTER .. VULGAR FRACTION THREE QUARTERS + (16#000BF#, 16#000BF#), -- (Po) INVERTED QUESTION MARK .. INVERTED QUESTION MARK + (16#000C0#, 16#000D6#), -- (Lu) LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS + (16#000D7#, 16#000D7#), -- (Sm) MULTIPLICATION SIGN .. MULTIPLICATION SIGN + (16#000D8#, 16#000DE#), -- (Lu) LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN + (16#000DF#, 16#000F6#), -- (Ll) LATIN SMALL LETTER SHARP S .. LATIN SMALL LETTER O WITH DIAERESIS + (16#000F7#, 16#000F7#), -- (Sm) DIVISION SIGN .. DIVISION SIGN + (16#000F8#, 16#000FF#), -- (Ll) LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER Y WITH DIAERESIS + (16#00100#, 16#00100#), -- (Lu) LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON + (16#00101#, 16#00101#), -- (Ll) LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON + (16#00102#, 16#00102#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE + (16#00103#, 16#00103#), -- (Ll) LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE + (16#00104#, 16#00104#), -- (Lu) LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK + (16#00105#, 16#00105#), -- (Ll) LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK + (16#00106#, 16#00106#), -- (Lu) LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE + (16#00107#, 16#00107#), -- (Ll) LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE + (16#00108#, 16#00108#), -- (Lu) LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX + (16#00109#, 16#00109#), -- (Ll) LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX + (16#0010A#, 16#0010A#), -- (Lu) LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE + (16#0010B#, 16#0010B#), -- (Ll) LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE + (16#0010C#, 16#0010C#), -- (Lu) LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON + (16#0010D#, 16#0010D#), -- (Ll) LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON + (16#0010E#, 16#0010E#), -- (Lu) LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON + (16#0010F#, 16#0010F#), -- (Ll) LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON + (16#00110#, 16#00110#), -- (Lu) LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE + (16#00111#, 16#00111#), -- (Ll) LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE + (16#00112#, 16#00112#), -- (Lu) LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON + (16#00113#, 16#00113#), -- (Ll) LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON + (16#00114#, 16#00114#), -- (Lu) LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE + (16#00115#, 16#00115#), -- (Ll) LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE + (16#00116#, 16#00116#), -- (Lu) LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE + (16#00117#, 16#00117#), -- (Ll) LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE + (16#00118#, 16#00118#), -- (Lu) LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK + (16#00119#, 16#00119#), -- (Ll) LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK + (16#0011A#, 16#0011A#), -- (Lu) LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON + (16#0011B#, 16#0011B#), -- (Ll) LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON + (16#0011C#, 16#0011C#), -- (Lu) LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX + (16#0011D#, 16#0011D#), -- (Ll) LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX + (16#0011E#, 16#0011E#), -- (Lu) LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE + (16#0011F#, 16#0011F#), -- (Ll) LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE + (16#00120#, 16#00120#), -- (Lu) LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE + (16#00121#, 16#00121#), -- (Ll) LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE + (16#00122#, 16#00122#), -- (Lu) LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA + (16#00123#, 16#00123#), -- (Ll) LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA + (16#00124#, 16#00124#), -- (Lu) LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX + (16#00125#, 16#00125#), -- (Ll) LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX + (16#00126#, 16#00126#), -- (Lu) LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE + (16#00127#, 16#00127#), -- (Ll) LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE + (16#00128#, 16#00128#), -- (Lu) LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE + (16#00129#, 16#00129#), -- (Ll) LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE + (16#0012A#, 16#0012A#), -- (Lu) LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON + (16#0012B#, 16#0012B#), -- (Ll) LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON + (16#0012C#, 16#0012C#), -- (Lu) LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE + (16#0012D#, 16#0012D#), -- (Ll) LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE + (16#0012E#, 16#0012E#), -- (Lu) LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK + (16#0012F#, 16#0012F#), -- (Ll) LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK + (16#00130#, 16#00130#), -- (Lu) LATIN CAPITAL LETTER I WITH DOT ABOVE .. LATIN CAPITAL LETTER I WITH DOT ABOVE + (16#00131#, 16#00131#), -- (Ll) LATIN SMALL LETTER DOTLESS I .. LATIN SMALL LETTER DOTLESS I + (16#00132#, 16#00132#), -- (Lu) LATIN CAPITAL LIGATURE IJ .. LATIN CAPITAL LIGATURE IJ + (16#00133#, 16#00133#), -- (Ll) LATIN SMALL LIGATURE IJ .. LATIN SMALL LIGATURE IJ + (16#00134#, 16#00134#), -- (Lu) LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX + (16#00135#, 16#00135#), -- (Ll) LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX + (16#00136#, 16#00136#), -- (Lu) LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA + (16#00137#, 16#00138#), -- (Ll) LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER KRA + (16#00139#, 16#00139#), -- (Lu) LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE + (16#0013A#, 16#0013A#), -- (Ll) LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE + (16#0013B#, 16#0013B#), -- (Lu) LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA + (16#0013C#, 16#0013C#), -- (Ll) LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA + (16#0013D#, 16#0013D#), -- (Lu) LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON + (16#0013E#, 16#0013E#), -- (Ll) LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON + (16#0013F#, 16#0013F#), -- (Lu) LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT + (16#00140#, 16#00140#), -- (Ll) LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT + (16#00141#, 16#00141#), -- (Lu) LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE + (16#00142#, 16#00142#), -- (Ll) LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE + (16#00143#, 16#00143#), -- (Lu) LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE + (16#00144#, 16#00144#), -- (Ll) LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE + (16#00145#, 16#00145#), -- (Lu) LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA + (16#00146#, 16#00146#), -- (Ll) LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA + (16#00147#, 16#00147#), -- (Lu) LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON + (16#00148#, 16#00149#), -- (Ll) LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N PRECEDED BY APOSTROPHE + (16#0014A#, 16#0014A#), -- (Lu) LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG + (16#0014B#, 16#0014B#), -- (Ll) LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG + (16#0014C#, 16#0014C#), -- (Lu) LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON + (16#0014D#, 16#0014D#), -- (Ll) LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON + (16#0014E#, 16#0014E#), -- (Lu) LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE + (16#0014F#, 16#0014F#), -- (Ll) LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE + (16#00150#, 16#00150#), -- (Lu) LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE + (16#00151#, 16#00151#), -- (Ll) LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE + (16#00152#, 16#00152#), -- (Lu) LATIN CAPITAL LIGATURE OE .. LATIN CAPITAL LIGATURE OE + (16#00153#, 16#00153#), -- (Ll) LATIN SMALL LIGATURE OE .. LATIN SMALL LIGATURE OE + (16#00154#, 16#00154#), -- (Lu) LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE + (16#00155#, 16#00155#), -- (Ll) LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE + (16#00156#, 16#00156#), -- (Lu) LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA + (16#00157#, 16#00157#), -- (Ll) LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA + (16#00158#, 16#00158#), -- (Lu) LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON + (16#00159#, 16#00159#), -- (Ll) LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON + (16#0015A#, 16#0015A#), -- (Lu) LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE + (16#0015B#, 16#0015B#), -- (Ll) LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE + (16#0015C#, 16#0015C#), -- (Lu) LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX + (16#0015D#, 16#0015D#), -- (Ll) LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX + (16#0015E#, 16#0015E#), -- (Lu) LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA + (16#0015F#, 16#0015F#), -- (Ll) LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA + (16#00160#, 16#00160#), -- (Lu) LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON + (16#00161#, 16#00161#), -- (Ll) LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON + (16#00162#, 16#00162#), -- (Lu) LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA + (16#00163#, 16#00163#), -- (Ll) LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA + (16#00164#, 16#00164#), -- (Lu) LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON + (16#00165#, 16#00165#), -- (Ll) LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON + (16#00166#, 16#00166#), -- (Lu) LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE + (16#00167#, 16#00167#), -- (Ll) LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE + (16#00168#, 16#00168#), -- (Lu) LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE + (16#00169#, 16#00169#), -- (Ll) LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE + (16#0016A#, 16#0016A#), -- (Lu) LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON + (16#0016B#, 16#0016B#), -- (Ll) LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON + (16#0016C#, 16#0016C#), -- (Lu) LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE + (16#0016D#, 16#0016D#), -- (Ll) LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE + (16#0016E#, 16#0016E#), -- (Lu) LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE + (16#0016F#, 16#0016F#), -- (Ll) LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE + (16#00170#, 16#00170#), -- (Lu) LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE + (16#00171#, 16#00171#), -- (Ll) LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE + (16#00172#, 16#00172#), -- (Lu) LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK + (16#00173#, 16#00173#), -- (Ll) LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK + (16#00174#, 16#00174#), -- (Lu) LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX + (16#00175#, 16#00175#), -- (Ll) LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX + (16#00176#, 16#00176#), -- (Lu) LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX + (16#00177#, 16#00177#), -- (Ll) LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX + (16#00178#, 16#00179#), -- (Lu) LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Z WITH ACUTE + (16#0017A#, 16#0017A#), -- (Ll) LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE + (16#0017B#, 16#0017B#), -- (Lu) LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE + (16#0017C#, 16#0017C#), -- (Ll) LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE + (16#0017D#, 16#0017D#), -- (Lu) LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON + (16#0017E#, 16#00180#), -- (Ll) LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER B WITH STROKE + (16#00181#, 16#00182#), -- (Lu) LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH TOPBAR + (16#00183#, 16#00183#), -- (Ll) LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR + (16#00184#, 16#00184#), -- (Lu) LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX + (16#00185#, 16#00185#), -- (Ll) LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX + (16#00186#, 16#00187#), -- (Lu) LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER C WITH HOOK + (16#00188#, 16#00188#), -- (Ll) LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK + (16#00189#, 16#0018B#), -- (Lu) LATIN CAPITAL LETTER AFRICAN D .. LATIN CAPITAL LETTER D WITH TOPBAR + (16#0018C#, 16#0018D#), -- (Ll) LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER TURNED DELTA + (16#0018E#, 16#00191#), -- (Lu) LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER F WITH HOOK + (16#00192#, 16#00192#), -- (Ll) LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK + (16#00193#, 16#00194#), -- (Lu) LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER GAMMA + (16#00195#, 16#00195#), -- (Ll) LATIN SMALL LETTER HV .. LATIN SMALL LETTER HV + (16#00196#, 16#00198#), -- (Lu) LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER K WITH HOOK + (16#00199#, 16#0019B#), -- (Ll) LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER LAMBDA WITH STROKE + (16#0019C#, 16#0019D#), -- (Lu) LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER N WITH LEFT HOOK + (16#0019E#, 16#0019E#), -- (Ll) LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG + (16#0019F#, 16#001A0#), -- (Lu) LATIN CAPITAL LETTER O WITH MIDDLE TILDE .. LATIN CAPITAL LETTER O WITH HORN + (16#001A1#, 16#001A1#), -- (Ll) LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN + (16#001A2#, 16#001A2#), -- (Lu) LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI + (16#001A3#, 16#001A3#), -- (Ll) LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI + (16#001A4#, 16#001A4#), -- (Lu) LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK + (16#001A5#, 16#001A5#), -- (Ll) LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK + (16#001A6#, 16#001A7#), -- (Lu) LATIN LETTER YR .. LATIN CAPITAL LETTER TONE TWO + (16#001A8#, 16#001A8#), -- (Ll) LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO + (16#001A9#, 16#001A9#), -- (Lu) LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH + (16#001AA#, 16#001AB#), -- (Ll) LATIN LETTER REVERSED ESH LOOP .. LATIN SMALL LETTER T WITH PALATAL HOOK + (16#001AC#, 16#001AC#), -- (Lu) LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK + (16#001AD#, 16#001AD#), -- (Ll) LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK + (16#001AE#, 16#001AF#), -- (Lu) LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER U WITH HORN + (16#001B0#, 16#001B0#), -- (Ll) LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN + (16#001B1#, 16#001B3#), -- (Lu) LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER Y WITH HOOK + (16#001B4#, 16#001B4#), -- (Ll) LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK + (16#001B5#, 16#001B5#), -- (Lu) LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE + (16#001B6#, 16#001B6#), -- (Ll) LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE + (16#001B7#, 16#001B8#), -- (Lu) LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH REVERSED + (16#001B9#, 16#001BA#), -- (Ll) LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH WITH TAIL + (16#001BB#, 16#001BB#), -- (Lo) LATIN LETTER TWO WITH STROKE .. LATIN LETTER TWO WITH STROKE + (16#001BC#, 16#001BC#), -- (Lu) LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE + (16#001BD#, 16#001BF#), -- (Ll) LATIN SMALL LETTER TONE FIVE .. LATIN LETTER WYNN + (16#001C0#, 16#001C3#), -- (Lo) LATIN LETTER DENTAL CLICK .. LATIN LETTER RETROFLEX CLICK + (16#001C4#, 16#001C4#), -- (Lu) LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON + (16#001C5#, 16#001C5#), -- (Lt) LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON + (16#001C6#, 16#001C6#), -- (Ll) LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON + (16#001C7#, 16#001C7#), -- (Lu) LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ + (16#001C8#, 16#001C8#), -- (Lt) LATIN CAPITAL LETTER L WITH SMALL LETTER J .. LATIN CAPITAL LETTER L WITH SMALL LETTER J + (16#001C9#, 16#001C9#), -- (Ll) LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ + (16#001CA#, 16#001CA#), -- (Lu) LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ + (16#001CB#, 16#001CB#), -- (Lt) LATIN CAPITAL LETTER N WITH SMALL LETTER J .. LATIN CAPITAL LETTER N WITH SMALL LETTER J + (16#001CC#, 16#001CC#), -- (Ll) LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ + (16#001CD#, 16#001CD#), -- (Lu) LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON + (16#001CE#, 16#001CE#), -- (Ll) LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON + (16#001CF#, 16#001CF#), -- (Lu) LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON + (16#001D0#, 16#001D0#), -- (Ll) LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON + (16#001D1#, 16#001D1#), -- (Lu) LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON + (16#001D2#, 16#001D2#), -- (Ll) LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON + (16#001D3#, 16#001D3#), -- (Lu) LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON + (16#001D4#, 16#001D4#), -- (Ll) LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON + (16#001D5#, 16#001D5#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON + (16#001D6#, 16#001D6#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON + (16#001D7#, 16#001D7#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE + (16#001D8#, 16#001D8#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE + (16#001D9#, 16#001D9#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON + (16#001DA#, 16#001DA#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON + (16#001DB#, 16#001DB#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE + (16#001DC#, 16#001DD#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER TURNED E + (16#001DE#, 16#001DE#), -- (Lu) LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON + (16#001DF#, 16#001DF#), -- (Ll) LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON + (16#001E0#, 16#001E0#), -- (Lu) LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON + (16#001E1#, 16#001E1#), -- (Ll) LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON + (16#001E2#, 16#001E2#), -- (Lu) LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON + (16#001E3#, 16#001E3#), -- (Ll) LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON + (16#001E4#, 16#001E4#), -- (Lu) LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE + (16#001E5#, 16#001E5#), -- (Ll) LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE + (16#001E6#, 16#001E6#), -- (Lu) LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON + (16#001E7#, 16#001E7#), -- (Ll) LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON + (16#001E8#, 16#001E8#), -- (Lu) LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON + (16#001E9#, 16#001E9#), -- (Ll) LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON + (16#001EA#, 16#001EA#), -- (Lu) LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK + (16#001EB#, 16#001EB#), -- (Ll) LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK + (16#001EC#, 16#001EC#), -- (Lu) LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON + (16#001ED#, 16#001ED#), -- (Ll) LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON + (16#001EE#, 16#001EE#), -- (Lu) LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON + (16#001EF#, 16#001F0#), -- (Ll) LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER J WITH CARON + (16#001F1#, 16#001F1#), -- (Lu) LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ + (16#001F2#, 16#001F2#), -- (Lt) LATIN CAPITAL LETTER D WITH SMALL LETTER Z .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z + (16#001F3#, 16#001F3#), -- (Ll) LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ + (16#001F4#, 16#001F4#), -- (Lu) LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE + (16#001F5#, 16#001F5#), -- (Ll) LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE + (16#001F6#, 16#001F8#), -- (Lu) LATIN CAPITAL LETTER HWAIR .. LATIN CAPITAL LETTER N WITH GRAVE + (16#001F9#, 16#001F9#), -- (Ll) LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE + (16#001FA#, 16#001FA#), -- (Lu) LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE + (16#001FB#, 16#001FB#), -- (Ll) LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE + (16#001FC#, 16#001FC#), -- (Lu) LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE + (16#001FD#, 16#001FD#), -- (Ll) LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE + (16#001FE#, 16#001FE#), -- (Lu) LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE + (16#001FF#, 16#001FF#), -- (Ll) LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE + (16#00200#, 16#00200#), -- (Lu) LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE + (16#00201#, 16#00201#), -- (Ll) LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE + (16#00202#, 16#00202#), -- (Lu) LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE + (16#00203#, 16#00203#), -- (Ll) LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE + (16#00204#, 16#00204#), -- (Lu) LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE + (16#00205#, 16#00205#), -- (Ll) LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE + (16#00206#, 16#00206#), -- (Lu) LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE + (16#00207#, 16#00207#), -- (Ll) LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE + (16#00208#, 16#00208#), -- (Lu) LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE + (16#00209#, 16#00209#), -- (Ll) LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE + (16#0020A#, 16#0020A#), -- (Lu) LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE + (16#0020B#, 16#0020B#), -- (Ll) LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE + (16#0020C#, 16#0020C#), -- (Lu) LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE + (16#0020D#, 16#0020D#), -- (Ll) LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE + (16#0020E#, 16#0020E#), -- (Lu) LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE + (16#0020F#, 16#0020F#), -- (Ll) LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE + (16#00210#, 16#00210#), -- (Lu) LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE + (16#00211#, 16#00211#), -- (Ll) LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE + (16#00212#, 16#00212#), -- (Lu) LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE + (16#00213#, 16#00213#), -- (Ll) LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE + (16#00214#, 16#00214#), -- (Lu) LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE + (16#00215#, 16#00215#), -- (Ll) LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE + (16#00216#, 16#00216#), -- (Lu) LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE + (16#00217#, 16#00217#), -- (Ll) LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE + (16#00218#, 16#00218#), -- (Lu) LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW + (16#00219#, 16#00219#), -- (Ll) LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW + (16#0021A#, 16#0021A#), -- (Lu) LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW + (16#0021B#, 16#0021B#), -- (Ll) LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW + (16#0021C#, 16#0021C#), -- (Lu) LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH + (16#0021D#, 16#0021D#), -- (Ll) LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH + (16#0021E#, 16#0021E#), -- (Lu) LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON + (16#0021F#, 16#0021F#), -- (Ll) LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON + (16#00220#, 16#00220#), -- (Lu) LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG + (16#00221#, 16#00221#), -- (Ll) LATIN SMALL LETTER D WITH CURL .. LATIN SMALL LETTER D WITH CURL + (16#00222#, 16#00222#), -- (Lu) LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU + (16#00223#, 16#00223#), -- (Ll) LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU + (16#00224#, 16#00224#), -- (Lu) LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK + (16#00225#, 16#00225#), -- (Ll) LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK + (16#00226#, 16#00226#), -- (Lu) LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE + (16#00227#, 16#00227#), -- (Ll) LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE + (16#00228#, 16#00228#), -- (Lu) LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA + (16#00229#, 16#00229#), -- (Ll) LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA + (16#0022A#, 16#0022A#), -- (Lu) LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON + (16#0022B#, 16#0022B#), -- (Ll) LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON + (16#0022C#, 16#0022C#), -- (Lu) LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON + (16#0022D#, 16#0022D#), -- (Ll) LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON + (16#0022E#, 16#0022E#), -- (Lu) LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE + (16#0022F#, 16#0022F#), -- (Ll) LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE + (16#00230#, 16#00230#), -- (Lu) LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON + (16#00231#, 16#00231#), -- (Ll) LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON + (16#00232#, 16#00232#), -- (Lu) LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON + (16#00233#, 16#00236#), -- (Ll) LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER T WITH CURL + (16#00250#, 16#002AF#), -- (Ll) LATIN SMALL LETTER TURNED A .. LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL + (16#002B0#, 16#002C1#), -- (Lm) MODIFIER LETTER SMALL H .. MODIFIER LETTER REVERSED GLOTTAL STOP + (16#002C2#, 16#002C5#), -- (Sk) MODIFIER LETTER LEFT ARROWHEAD .. MODIFIER LETTER DOWN ARROWHEAD + (16#002C6#, 16#002D1#), -- (Lm) MODIFIER LETTER CIRCUMFLEX ACCENT .. MODIFIER LETTER HALF TRIANGULAR COLON + (16#002D2#, 16#002DF#), -- (Sk) MODIFIER LETTER CENTRED RIGHT HALF RING .. MODIFIER LETTER CROSS ACCENT + (16#002E0#, 16#002E4#), -- (Lm) MODIFIER LETTER SMALL GAMMA .. MODIFIER LETTER SMALL REVERSED GLOTTAL STOP + (16#002E5#, 16#002ED#), -- (Sk) MODIFIER LETTER EXTRA-HIGH TONE BAR .. MODIFIER LETTER UNASPIRATED + (16#002EE#, 16#002EE#), -- (Lm) MODIFIER LETTER DOUBLE APOSTROPHE .. MODIFIER LETTER DOUBLE APOSTROPHE + (16#002EF#, 16#002FF#), -- (Sk) MODIFIER LETTER LOW DOWN ARROWHEAD .. MODIFIER LETTER LOW LEFT ARROW + (16#00300#, 16#00357#), -- (Mn) COMBINING GRAVE ACCENT .. COMBINING RIGHT HALF RING ABOVE + (16#0035D#, 16#0036F#), -- (Mn) COMBINING DOUBLE BREVE .. COMBINING LATIN SMALL LETTER X + (16#00374#, 16#00375#), -- (Sk) GREEK NUMERAL SIGN .. GREEK LOWER NUMERAL SIGN + (16#0037A#, 16#0037A#), -- (Lm) GREEK YPOGEGRAMMENI .. GREEK YPOGEGRAMMENI + (16#0037E#, 16#0037E#), -- (Po) GREEK QUESTION MARK .. GREEK QUESTION MARK + (16#00384#, 16#00385#), -- (Sk) GREEK TONOS .. GREEK DIALYTIKA TONOS + (16#00386#, 16#00386#), -- (Lu) GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS + (16#00387#, 16#00387#), -- (Po) GREEK ANO TELEIA .. GREEK ANO TELEIA + (16#00388#, 16#0038A#), -- (Lu) GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS + (16#0038C#, 16#0038C#), -- (Lu) GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS + (16#0038E#, 16#0038F#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS + (16#00390#, 16#00390#), -- (Ll) GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS + (16#00391#, 16#003A1#), -- (Lu) GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO + (16#003A3#, 16#003AB#), -- (Lu) GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA + (16#003AC#, 16#003CE#), -- (Ll) GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS + (16#003D0#, 16#003D1#), -- (Ll) GREEK BETA SYMBOL .. GREEK THETA SYMBOL + (16#003D2#, 16#003D4#), -- (Lu) GREEK UPSILON WITH HOOK SYMBOL .. GREEK UPSILON WITH DIAERESIS AND HOOK SYMBOL + (16#003D5#, 16#003D7#), -- (Ll) GREEK PHI SYMBOL .. GREEK KAI SYMBOL + (16#003D8#, 16#003D8#), -- (Lu) GREEK LETTER ARCHAIC KOPPA .. GREEK LETTER ARCHAIC KOPPA + (16#003D9#, 16#003D9#), -- (Ll) GREEK SMALL LETTER ARCHAIC KOPPA .. GREEK SMALL LETTER ARCHAIC KOPPA + (16#003DA#, 16#003DA#), -- (Lu) GREEK LETTER STIGMA .. GREEK LETTER STIGMA + (16#003DB#, 16#003DB#), -- (Ll) GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA + (16#003DC#, 16#003DC#), -- (Lu) GREEK LETTER DIGAMMA .. GREEK LETTER DIGAMMA + (16#003DD#, 16#003DD#), -- (Ll) GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA + (16#003DE#, 16#003DE#), -- (Lu) GREEK LETTER KOPPA .. GREEK LETTER KOPPA + (16#003DF#, 16#003DF#), -- (Ll) GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA + (16#003E0#, 16#003E0#), -- (Lu) GREEK LETTER SAMPI .. GREEK LETTER SAMPI + (16#003E1#, 16#003E1#), -- (Ll) GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI + (16#003E2#, 16#003E2#), -- (Lu) COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI + (16#003E3#, 16#003E3#), -- (Ll) COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI + (16#003E4#, 16#003E4#), -- (Lu) COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI + (16#003E5#, 16#003E5#), -- (Ll) COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI + (16#003E6#, 16#003E6#), -- (Lu) COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI + (16#003E7#, 16#003E7#), -- (Ll) COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI + (16#003E8#, 16#003E8#), -- (Lu) COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI + (16#003E9#, 16#003E9#), -- (Ll) COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI + (16#003EA#, 16#003EA#), -- (Lu) COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA + (16#003EB#, 16#003EB#), -- (Ll) COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA + (16#003EC#, 16#003EC#), -- (Lu) COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA + (16#003ED#, 16#003ED#), -- (Ll) COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA + (16#003EE#, 16#003EE#), -- (Lu) COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI + (16#003EF#, 16#003F3#), -- (Ll) COPTIC SMALL LETTER DEI .. GREEK LETTER YOT + (16#003F4#, 16#003F4#), -- (Lu) GREEK CAPITAL THETA SYMBOL .. GREEK CAPITAL THETA SYMBOL + (16#003F5#, 16#003F5#), -- (Ll) GREEK LUNATE EPSILON SYMBOL .. GREEK LUNATE EPSILON SYMBOL + (16#003F6#, 16#003F6#), -- (Sm) GREEK REVERSED LUNATE EPSILON SYMBOL .. GREEK REVERSED LUNATE EPSILON SYMBOL + (16#003F7#, 16#003F7#), -- (Lu) GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO + (16#003F8#, 16#003F8#), -- (Ll) GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO + (16#003F9#, 16#003FA#), -- (Lu) GREEK CAPITAL LUNATE SIGMA SYMBOL .. GREEK CAPITAL LETTER SAN + (16#003FB#, 16#003FB#), -- (Ll) GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN + (16#00400#, 16#0042F#), -- (Lu) CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER YA + (16#00430#, 16#0045F#), -- (Ll) CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER DZHE + (16#00460#, 16#00460#), -- (Lu) CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA + (16#00461#, 16#00461#), -- (Ll) CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA + (16#00462#, 16#00462#), -- (Lu) CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT + (16#00463#, 16#00463#), -- (Ll) CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT + (16#00464#, 16#00464#), -- (Lu) CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E + (16#00465#, 16#00465#), -- (Ll) CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E + (16#00466#, 16#00466#), -- (Lu) CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS + (16#00467#, 16#00467#), -- (Ll) CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS + (16#00468#, 16#00468#), -- (Lu) CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS + (16#00469#, 16#00469#), -- (Ll) CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS + (16#0046A#, 16#0046A#), -- (Lu) CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS + (16#0046B#, 16#0046B#), -- (Ll) CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS + (16#0046C#, 16#0046C#), -- (Lu) CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS + (16#0046D#, 16#0046D#), -- (Ll) CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS + (16#0046E#, 16#0046E#), -- (Lu) CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI + (16#0046F#, 16#0046F#), -- (Ll) CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI + (16#00470#, 16#00470#), -- (Lu) CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI + (16#00471#, 16#00471#), -- (Ll) CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI + (16#00472#, 16#00472#), -- (Lu) CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA + (16#00473#, 16#00473#), -- (Ll) CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA + (16#00474#, 16#00474#), -- (Lu) CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA + (16#00475#, 16#00475#), -- (Ll) CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA + (16#00476#, 16#00476#), -- (Lu) CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + (16#00477#, 16#00477#), -- (Ll) CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + (16#00478#, 16#00478#), -- (Lu) CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK + (16#00479#, 16#00479#), -- (Ll) CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK + (16#0047A#, 16#0047A#), -- (Lu) CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA + (16#0047B#, 16#0047B#), -- (Ll) CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA + (16#0047C#, 16#0047C#), -- (Lu) CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO + (16#0047D#, 16#0047D#), -- (Ll) CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO + (16#0047E#, 16#0047E#), -- (Lu) CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT + (16#0047F#, 16#0047F#), -- (Ll) CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT + (16#00480#, 16#00480#), -- (Lu) CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA + (16#00481#, 16#00481#), -- (Ll) CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA + (16#00482#, 16#00482#), -- (So) CYRILLIC THOUSANDS SIGN .. CYRILLIC THOUSANDS SIGN + (16#00483#, 16#00486#), -- (Mn) COMBINING CYRILLIC TITLO .. COMBINING CYRILLIC PSILI PNEUMATA + (16#00488#, 16#00489#), -- (Me) COMBINING CYRILLIC HUNDRED THOUSANDS SIGN .. COMBINING CYRILLIC MILLIONS SIGN + (16#0048A#, 16#0048A#), -- (Lu) CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL + (16#0048B#, 16#0048B#), -- (Ll) CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL + (16#0048C#, 16#0048C#), -- (Lu) CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN + (16#0048D#, 16#0048D#), -- (Ll) CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN + (16#0048E#, 16#0048E#), -- (Lu) CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK + (16#0048F#, 16#0048F#), -- (Ll) CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK + (16#00490#, 16#00490#), -- (Lu) CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN + (16#00491#, 16#00491#), -- (Ll) CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN + (16#00492#, 16#00492#), -- (Lu) CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE + (16#00493#, 16#00493#), -- (Ll) CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE + (16#00494#, 16#00494#), -- (Lu) CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK + (16#00495#, 16#00495#), -- (Ll) CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK + (16#00496#, 16#00496#), -- (Lu) CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER + (16#00497#, 16#00497#), -- (Ll) CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER + (16#00498#, 16#00498#), -- (Lu) CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER + (16#00499#, 16#00499#), -- (Ll) CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER + (16#0049A#, 16#0049A#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER + (16#0049B#, 16#0049B#), -- (Ll) CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER + (16#0049C#, 16#0049C#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE + (16#0049D#, 16#0049D#), -- (Ll) CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE + (16#0049E#, 16#0049E#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE + (16#0049F#, 16#0049F#), -- (Ll) CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE + (16#004A0#, 16#004A0#), -- (Lu) CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA + (16#004A1#, 16#004A1#), -- (Ll) CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA + (16#004A2#, 16#004A2#), -- (Lu) CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER + (16#004A3#, 16#004A3#), -- (Ll) CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER + (16#004A4#, 16#004A4#), -- (Lu) CYRILLIC CAPITAL LIGATURE EN GHE .. CYRILLIC CAPITAL LIGATURE EN GHE + (16#004A5#, 16#004A5#), -- (Ll) CYRILLIC SMALL LIGATURE EN GHE .. CYRILLIC SMALL LIGATURE EN GHE + (16#004A6#, 16#004A6#), -- (Lu) CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK + (16#004A7#, 16#004A7#), -- (Ll) CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK + (16#004A8#, 16#004A8#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA + (16#004A9#, 16#004A9#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA + (16#004AA#, 16#004AA#), -- (Lu) CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER + (16#004AB#, 16#004AB#), -- (Ll) CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER + (16#004AC#, 16#004AC#), -- (Lu) CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER + (16#004AD#, 16#004AD#), -- (Ll) CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER + (16#004AE#, 16#004AE#), -- (Lu) CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U + (16#004AF#, 16#004AF#), -- (Ll) CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U + (16#004B0#, 16#004B0#), -- (Lu) CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE + (16#004B1#, 16#004B1#), -- (Ll) CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE + (16#004B2#, 16#004B2#), -- (Lu) CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER + (16#004B3#, 16#004B3#), -- (Ll) CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER + (16#004B4#, 16#004B4#), -- (Lu) CYRILLIC CAPITAL LIGATURE TE TSE .. CYRILLIC CAPITAL LIGATURE TE TSE + (16#004B5#, 16#004B5#), -- (Ll) CYRILLIC SMALL LIGATURE TE TSE .. CYRILLIC SMALL LIGATURE TE TSE + (16#004B6#, 16#004B6#), -- (Lu) CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER + (16#004B7#, 16#004B7#), -- (Ll) CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER + (16#004B8#, 16#004B8#), -- (Lu) CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE + (16#004B9#, 16#004B9#), -- (Ll) CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE + (16#004BA#, 16#004BA#), -- (Lu) CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA + (16#004BB#, 16#004BB#), -- (Ll) CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA + (16#004BC#, 16#004BC#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE + (16#004BD#, 16#004BD#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE + (16#004BE#, 16#004BE#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER + (16#004BF#, 16#004BF#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER + (16#004C0#, 16#004C1#), -- (Lu) CYRILLIC LETTER PALOCHKA .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE + (16#004C2#, 16#004C2#), -- (Ll) CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE + (16#004C3#, 16#004C3#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK + (16#004C4#, 16#004C4#), -- (Ll) CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK + (16#004C5#, 16#004C5#), -- (Lu) CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL + (16#004C6#, 16#004C6#), -- (Ll) CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL + (16#004C7#, 16#004C7#), -- (Lu) CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK + (16#004C8#, 16#004C8#), -- (Ll) CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK + (16#004C9#, 16#004C9#), -- (Lu) CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL + (16#004CA#, 16#004CA#), -- (Ll) CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL + (16#004CB#, 16#004CB#), -- (Lu) CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE + (16#004CC#, 16#004CC#), -- (Ll) CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE + (16#004CD#, 16#004CD#), -- (Lu) CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL + (16#004CE#, 16#004CE#), -- (Ll) CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL + (16#004D0#, 16#004D0#), -- (Lu) CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE + (16#004D1#, 16#004D1#), -- (Ll) CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE + (16#004D2#, 16#004D2#), -- (Lu) CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS + (16#004D3#, 16#004D3#), -- (Ll) CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS + (16#004D4#, 16#004D4#), -- (Lu) CYRILLIC CAPITAL LIGATURE A IE .. CYRILLIC CAPITAL LIGATURE A IE + (16#004D5#, 16#004D5#), -- (Ll) CYRILLIC SMALL LIGATURE A IE .. CYRILLIC SMALL LIGATURE A IE + (16#004D6#, 16#004D6#), -- (Lu) CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE + (16#004D7#, 16#004D7#), -- (Ll) CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE + (16#004D8#, 16#004D8#), -- (Lu) CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA + (16#004D9#, 16#004D9#), -- (Ll) CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA + (16#004DA#, 16#004DA#), -- (Lu) CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS + (16#004DB#, 16#004DB#), -- (Ll) CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS + (16#004DC#, 16#004DC#), -- (Lu) CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS + (16#004DD#, 16#004DD#), -- (Ll) CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS + (16#004DE#, 16#004DE#), -- (Lu) CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS + (16#004DF#, 16#004DF#), -- (Ll) CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS + (16#004E0#, 16#004E0#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE + (16#004E1#, 16#004E1#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE + (16#004E2#, 16#004E2#), -- (Lu) CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON + (16#004E3#, 16#004E3#), -- (Ll) CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON + (16#004E4#, 16#004E4#), -- (Lu) CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS + (16#004E5#, 16#004E5#), -- (Ll) CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS + (16#004E6#, 16#004E6#), -- (Lu) CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS + (16#004E7#, 16#004E7#), -- (Ll) CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS + (16#004E8#, 16#004E8#), -- (Lu) CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O + (16#004E9#, 16#004E9#), -- (Ll) CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O + (16#004EA#, 16#004EA#), -- (Lu) CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS + (16#004EB#, 16#004EB#), -- (Ll) CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS + (16#004EC#, 16#004EC#), -- (Lu) CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS + (16#004ED#, 16#004ED#), -- (Ll) CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS + (16#004EE#, 16#004EE#), -- (Lu) CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON + (16#004EF#, 16#004EF#), -- (Ll) CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON + (16#004F0#, 16#004F0#), -- (Lu) CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS + (16#004F1#, 16#004F1#), -- (Ll) CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS + (16#004F2#, 16#004F2#), -- (Lu) CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE + (16#004F3#, 16#004F3#), -- (Ll) CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE + (16#004F4#, 16#004F4#), -- (Lu) CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS + (16#004F5#, 16#004F5#), -- (Ll) CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS + (16#004F8#, 16#004F8#), -- (Lu) CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS + (16#004F9#, 16#004F9#), -- (Ll) CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS + (16#00500#, 16#00500#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE + (16#00501#, 16#00501#), -- (Ll) CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE + (16#00502#, 16#00502#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE + (16#00503#, 16#00503#), -- (Ll) CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE + (16#00504#, 16#00504#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE + (16#00505#, 16#00505#), -- (Ll) CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE + (16#00506#, 16#00506#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE + (16#00507#, 16#00507#), -- (Ll) CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE + (16#00508#, 16#00508#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE + (16#00509#, 16#00509#), -- (Ll) CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE + (16#0050A#, 16#0050A#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE + (16#0050B#, 16#0050B#), -- (Ll) CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE + (16#0050C#, 16#0050C#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE + (16#0050D#, 16#0050D#), -- (Ll) CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE + (16#0050E#, 16#0050E#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE + (16#0050F#, 16#0050F#), -- (Ll) CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE + (16#00531#, 16#00556#), -- (Lu) ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH + (16#00559#, 16#00559#), -- (Lm) ARMENIAN MODIFIER LETTER LEFT HALF RING .. ARMENIAN MODIFIER LETTER LEFT HALF RING + (16#0055A#, 16#0055F#), -- (Po) ARMENIAN APOSTROPHE .. ARMENIAN ABBREVIATION MARK + (16#00561#, 16#00587#), -- (Ll) ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LIGATURE ECH YIWN + (16#00589#, 16#00589#), -- (Po) ARMENIAN FULL STOP .. ARMENIAN FULL STOP + (16#0058A#, 16#0058A#), -- (Pd) ARMENIAN HYPHEN .. ARMENIAN HYPHEN + (16#00591#, 16#005A1#), -- (Mn) HEBREW ACCENT ETNAHTA .. HEBREW ACCENT PAZER + (16#005A3#, 16#005B9#), -- (Mn) HEBREW ACCENT MUNAH .. HEBREW POINT HOLAM + (16#005BB#, 16#005BD#), -- (Mn) HEBREW POINT QUBUTS .. HEBREW POINT METEG + (16#005BE#, 16#005BE#), -- (Po) HEBREW PUNCTUATION MAQAF .. HEBREW PUNCTUATION MAQAF + (16#005BF#, 16#005BF#), -- (Mn) HEBREW POINT RAFE .. HEBREW POINT RAFE + (16#005C0#, 16#005C0#), -- (Po) HEBREW PUNCTUATION PASEQ .. HEBREW PUNCTUATION PASEQ + (16#005C1#, 16#005C2#), -- (Mn) HEBREW POINT SHIN DOT .. HEBREW POINT SIN DOT + (16#005C3#, 16#005C3#), -- (Po) HEBREW PUNCTUATION SOF PASUQ .. HEBREW PUNCTUATION SOF PASUQ + (16#005C4#, 16#005C4#), -- (Mn) HEBREW MARK UPPER DOT .. HEBREW MARK UPPER DOT + (16#005D0#, 16#005EA#), -- (Lo) HEBREW LETTER ALEF .. HEBREW LETTER TAV + (16#005F0#, 16#005F2#), -- (Lo) HEBREW LIGATURE YIDDISH DOUBLE VAV .. HEBREW LIGATURE YIDDISH DOUBLE YOD + (16#005F3#, 16#005F4#), -- (Po) HEBREW PUNCTUATION GERESH .. HEBREW PUNCTUATION GERSHAYIM + (16#00600#, 16#00603#), -- (Cf) ARABIC NUMBER SIGN .. ARABIC SIGN SAFHA + (16#0060C#, 16#0060D#), -- (Po) ARABIC COMMA .. ARABIC DATE SEPARATOR + (16#0060E#, 16#0060F#), -- (So) ARABIC POETIC VERSE SIGN .. ARABIC SIGN MISRA + (16#00610#, 16#00615#), -- (Mn) ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM .. ARABIC SMALL HIGH TAH + (16#0061B#, 16#0061B#), -- (Po) ARABIC SEMICOLON .. ARABIC SEMICOLON + (16#0061F#, 16#0061F#), -- (Po) ARABIC QUESTION MARK .. ARABIC QUESTION MARK + (16#00621#, 16#0063A#), -- (Lo) ARABIC LETTER HAMZA .. ARABIC LETTER GHAIN + (16#00640#, 16#00640#), -- (Lm) ARABIC TATWEEL .. ARABIC TATWEEL + (16#00641#, 16#0064A#), -- (Lo) ARABIC LETTER FEH .. ARABIC LETTER YEH + (16#0064B#, 16#00658#), -- (Mn) ARABIC FATHATAN .. ARABIC MARK NOON GHUNNA + (16#00660#, 16#00669#), -- (Nd) ARABIC-INDIC DIGIT ZERO .. ARABIC-INDIC DIGIT NINE + (16#0066A#, 16#0066D#), -- (Po) ARABIC PERCENT SIGN .. ARABIC FIVE POINTED STAR + (16#0066E#, 16#0066F#), -- (Lo) ARABIC LETTER DOTLESS BEH .. ARABIC LETTER DOTLESS QAF + (16#00670#, 16#00670#), -- (Mn) ARABIC LETTER SUPERSCRIPT ALEF .. ARABIC LETTER SUPERSCRIPT ALEF + (16#00671#, 16#006D3#), -- (Lo) ARABIC LETTER ALEF WASLA .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE + (16#006D4#, 16#006D4#), -- (Po) ARABIC FULL STOP .. ARABIC FULL STOP + (16#006D5#, 16#006D5#), -- (Lo) ARABIC LETTER AE .. ARABIC LETTER AE + (16#006D6#, 16#006DC#), -- (Mn) ARABIC SMALL HIGH LIGATURE SAD WITH LAM WITH ALEF MAKSURA .. ARABIC SMALL HIGH SEEN + (16#006DD#, 16#006DD#), -- (Cf) ARABIC END OF AYAH .. ARABIC END OF AYAH + (16#006DE#, 16#006DE#), -- (Me) ARABIC START OF RUB EL HIZB .. ARABIC START OF RUB EL HIZB + (16#006DF#, 16#006E4#), -- (Mn) ARABIC SMALL HIGH ROUNDED ZERO .. ARABIC SMALL HIGH MADDA + (16#006E5#, 16#006E6#), -- (Lm) ARABIC SMALL WAW .. ARABIC SMALL YEH + (16#006E7#, 16#006E8#), -- (Mn) ARABIC SMALL HIGH YEH .. ARABIC SMALL HIGH NOON + (16#006E9#, 16#006E9#), -- (So) ARABIC PLACE OF SAJDAH .. ARABIC PLACE OF SAJDAH + (16#006EA#, 16#006ED#), -- (Mn) ARABIC EMPTY CENTRE LOW STOP .. ARABIC SMALL LOW MEEM + (16#006EE#, 16#006EF#), -- (Lo) ARABIC LETTER DAL WITH INVERTED V .. ARABIC LETTER REH WITH INVERTED V + (16#006F0#, 16#006F9#), -- (Nd) EXTENDED ARABIC-INDIC DIGIT ZERO .. EXTENDED ARABIC-INDIC DIGIT NINE + (16#006FA#, 16#006FC#), -- (Lo) ARABIC LETTER SHEEN WITH DOT BELOW .. ARABIC LETTER GHAIN WITH DOT BELOW + (16#006FD#, 16#006FE#), -- (So) ARABIC SIGN SINDHI AMPERSAND .. ARABIC SIGN SINDHI POSTPOSITION MEN + (16#006FF#, 16#006FF#), -- (Lo) ARABIC LETTER HEH WITH INVERTED V .. ARABIC LETTER HEH WITH INVERTED V + (16#00700#, 16#0070D#), -- (Po) SYRIAC END OF PARAGRAPH .. SYRIAC HARKLEAN ASTERISCUS + (16#0070F#, 16#0070F#), -- (Cf) SYRIAC ABBREVIATION MARK .. SYRIAC ABBREVIATION MARK + (16#00710#, 16#00710#), -- (Lo) SYRIAC LETTER ALAPH .. SYRIAC LETTER ALAPH + (16#00711#, 16#00711#), -- (Mn) SYRIAC LETTER SUPERSCRIPT ALAPH .. SYRIAC LETTER SUPERSCRIPT ALAPH + (16#00712#, 16#0072F#), -- (Lo) SYRIAC LETTER BETH .. SYRIAC LETTER PERSIAN DHALATH + (16#00730#, 16#0074A#), -- (Mn) SYRIAC PTHAHA ABOVE .. SYRIAC BARREKH + (16#0074D#, 16#0074F#), -- (Lo) SYRIAC LETTER SOGDIAN ZHAIN .. SYRIAC LETTER SOGDIAN FE + (16#00780#, 16#007A5#), -- (Lo) THAANA LETTER HAA .. THAANA LETTER WAAVU + (16#007A6#, 16#007B0#), -- (Mn) THAANA ABAFILI .. THAANA SUKUN + (16#007B1#, 16#007B1#), -- (Lo) THAANA LETTER NAA .. THAANA LETTER NAA + (16#00901#, 16#00902#), -- (Mn) DEVANAGARI SIGN CANDRABINDU .. DEVANAGARI SIGN ANUSVARA + (16#00903#, 16#00903#), -- (Mc) DEVANAGARI SIGN VISARGA .. DEVANAGARI SIGN VISARGA + (16#00904#, 16#00939#), -- (Lo) DEVANAGARI LETTER SHORT A .. DEVANAGARI LETTER HA + (16#0093C#, 16#0093C#), -- (Mn) DEVANAGARI SIGN NUKTA .. DEVANAGARI SIGN NUKTA + (16#0093D#, 16#0093D#), -- (Lo) DEVANAGARI SIGN AVAGRAHA .. DEVANAGARI SIGN AVAGRAHA + (16#0093E#, 16#00940#), -- (Mc) DEVANAGARI VOWEL SIGN AA .. DEVANAGARI VOWEL SIGN II + (16#00941#, 16#00948#), -- (Mn) DEVANAGARI VOWEL SIGN U .. DEVANAGARI VOWEL SIGN AI + (16#00949#, 16#0094C#), -- (Mc) DEVANAGARI VOWEL SIGN CANDRA O .. DEVANAGARI VOWEL SIGN AU + (16#0094D#, 16#0094D#), -- (Mn) DEVANAGARI SIGN VIRAMA .. DEVANAGARI SIGN VIRAMA + (16#00950#, 16#00950#), -- (Lo) DEVANAGARI OM .. DEVANAGARI OM + (16#00951#, 16#00954#), -- (Mn) DEVANAGARI STRESS SIGN UDATTA .. DEVANAGARI ACUTE ACCENT + (16#00958#, 16#00961#), -- (Lo) DEVANAGARI LETTER QA .. DEVANAGARI LETTER VOCALIC LL + (16#00962#, 16#00963#), -- (Mn) DEVANAGARI VOWEL SIGN VOCALIC L .. DEVANAGARI VOWEL SIGN VOCALIC LL + (16#00964#, 16#00965#), -- (Po) DEVANAGARI DANDA .. DEVANAGARI DOUBLE DANDA + (16#00966#, 16#0096F#), -- (Nd) DEVANAGARI DIGIT ZERO .. DEVANAGARI DIGIT NINE + (16#00970#, 16#00970#), -- (Po) DEVANAGARI ABBREVIATION SIGN .. DEVANAGARI ABBREVIATION SIGN + (16#00981#, 16#00981#), -- (Mn) BENGALI SIGN CANDRABINDU .. BENGALI SIGN CANDRABINDU + (16#00982#, 16#00983#), -- (Mc) BENGALI SIGN ANUSVARA .. BENGALI SIGN VISARGA + (16#00985#, 16#0098C#), -- (Lo) BENGALI LETTER A .. BENGALI LETTER VOCALIC L + (16#0098F#, 16#00990#), -- (Lo) BENGALI LETTER E .. BENGALI LETTER AI + (16#00993#, 16#009A8#), -- (Lo) BENGALI LETTER O .. BENGALI LETTER NA + (16#009AA#, 16#009B0#), -- (Lo) BENGALI LETTER PA .. BENGALI LETTER RA + (16#009B2#, 16#009B2#), -- (Lo) BENGALI LETTER LA .. BENGALI LETTER LA + (16#009B6#, 16#009B9#), -- (Lo) BENGALI LETTER SHA .. BENGALI LETTER HA + (16#009BC#, 16#009BC#), -- (Mn) BENGALI SIGN NUKTA .. BENGALI SIGN NUKTA + (16#009BD#, 16#009BD#), -- (Lo) BENGALI SIGN AVAGRAHA .. BENGALI SIGN AVAGRAHA + (16#009BE#, 16#009C0#), -- (Mc) BENGALI VOWEL SIGN AA .. BENGALI VOWEL SIGN II + (16#009C1#, 16#009C4#), -- (Mn) BENGALI VOWEL SIGN U .. BENGALI VOWEL SIGN VOCALIC RR + (16#009C7#, 16#009C8#), -- (Mc) BENGALI VOWEL SIGN E .. BENGALI VOWEL SIGN AI + (16#009CB#, 16#009CC#), -- (Mc) BENGALI VOWEL SIGN O .. BENGALI VOWEL SIGN AU + (16#009CD#, 16#009CD#), -- (Mn) BENGALI SIGN VIRAMA .. BENGALI SIGN VIRAMA + (16#009D7#, 16#009D7#), -- (Mc) BENGALI AU LENGTH MARK .. BENGALI AU LENGTH MARK + (16#009DC#, 16#009DD#), -- (Lo) BENGALI LETTER RRA .. BENGALI LETTER RHA + (16#009DF#, 16#009E1#), -- (Lo) BENGALI LETTER YYA .. BENGALI LETTER VOCALIC LL + (16#009E2#, 16#009E3#), -- (Mn) BENGALI VOWEL SIGN VOCALIC L .. BENGALI VOWEL SIGN VOCALIC LL + (16#009E6#, 16#009EF#), -- (Nd) BENGALI DIGIT ZERO .. BENGALI DIGIT NINE + (16#009F0#, 16#009F1#), -- (Lo) BENGALI LETTER RA WITH MIDDLE DIAGONAL .. BENGALI LETTER RA WITH LOWER DIAGONAL + (16#009F2#, 16#009F3#), -- (Sc) BENGALI RUPEE MARK .. BENGALI RUPEE SIGN + (16#009F4#, 16#009F9#), -- (No) BENGALI CURRENCY NUMERATOR ONE .. BENGALI CURRENCY DENOMINATOR SIXTEEN + (16#009FA#, 16#009FA#), -- (So) BENGALI ISSHAR .. BENGALI ISSHAR + (16#00A01#, 16#00A02#), -- (Mn) GURMUKHI SIGN ADAK BINDI .. GURMUKHI SIGN BINDI + (16#00A03#, 16#00A03#), -- (Mc) GURMUKHI SIGN VISARGA .. GURMUKHI SIGN VISARGA + (16#00A05#, 16#00A0A#), -- (Lo) GURMUKHI LETTER A .. GURMUKHI LETTER UU + (16#00A0F#, 16#00A10#), -- (Lo) GURMUKHI LETTER EE .. GURMUKHI LETTER AI + (16#00A13#, 16#00A28#), -- (Lo) GURMUKHI LETTER OO .. GURMUKHI LETTER NA + (16#00A2A#, 16#00A30#), -- (Lo) GURMUKHI LETTER PA .. GURMUKHI LETTER RA + (16#00A32#, 16#00A33#), -- (Lo) GURMUKHI LETTER LA .. GURMUKHI LETTER LLA + (16#00A35#, 16#00A36#), -- (Lo) GURMUKHI LETTER VA .. GURMUKHI LETTER SHA + (16#00A38#, 16#00A39#), -- (Lo) GURMUKHI LETTER SA .. GURMUKHI LETTER HA + (16#00A3C#, 16#00A3C#), -- (Mn) GURMUKHI SIGN NUKTA .. GURMUKHI SIGN NUKTA + (16#00A3E#, 16#00A40#), -- (Mc) GURMUKHI VOWEL SIGN AA .. GURMUKHI VOWEL SIGN II + (16#00A41#, 16#00A42#), -- (Mn) GURMUKHI VOWEL SIGN U .. GURMUKHI VOWEL SIGN UU + (16#00A47#, 16#00A48#), -- (Mn) GURMUKHI VOWEL SIGN EE .. GURMUKHI VOWEL SIGN AI + (16#00A4B#, 16#00A4D#), -- (Mn) GURMUKHI VOWEL SIGN OO .. GURMUKHI SIGN VIRAMA + (16#00A59#, 16#00A5C#), -- (Lo) GURMUKHI LETTER KHHA .. GURMUKHI LETTER RRA + (16#00A5E#, 16#00A5E#), -- (Lo) GURMUKHI LETTER FA .. GURMUKHI LETTER FA + (16#00A66#, 16#00A6F#), -- (Nd) GURMUKHI DIGIT ZERO .. GURMUKHI DIGIT NINE + (16#00A70#, 16#00A71#), -- (Mn) GURMUKHI TIPPI .. GURMUKHI ADDAK + (16#00A72#, 16#00A74#), -- (Lo) GURMUKHI IRI .. GURMUKHI EK ONKAR + (16#00A81#, 16#00A82#), -- (Mn) GUJARATI SIGN CANDRABINDU .. GUJARATI SIGN ANUSVARA + (16#00A83#, 16#00A83#), -- (Mc) GUJARATI SIGN VISARGA .. GUJARATI SIGN VISARGA + (16#00A85#, 16#00A8D#), -- (Lo) GUJARATI LETTER A .. GUJARATI VOWEL CANDRA E + (16#00A8F#, 16#00A91#), -- (Lo) GUJARATI LETTER E .. GUJARATI VOWEL CANDRA O + (16#00A93#, 16#00AA8#), -- (Lo) GUJARATI LETTER O .. GUJARATI LETTER NA + (16#00AAA#, 16#00AB0#), -- (Lo) GUJARATI LETTER PA .. GUJARATI LETTER RA + (16#00AB2#, 16#00AB3#), -- (Lo) GUJARATI LETTER LA .. GUJARATI LETTER LLA + (16#00AB5#, 16#00AB9#), -- (Lo) GUJARATI LETTER VA .. GUJARATI LETTER HA + (16#00ABC#, 16#00ABC#), -- (Mn) GUJARATI SIGN NUKTA .. GUJARATI SIGN NUKTA + (16#00ABD#, 16#00ABD#), -- (Lo) GUJARATI SIGN AVAGRAHA .. GUJARATI SIGN AVAGRAHA + (16#00ABE#, 16#00AC0#), -- (Mc) GUJARATI VOWEL SIGN AA .. GUJARATI VOWEL SIGN II + (16#00AC1#, 16#00AC5#), -- (Mn) GUJARATI VOWEL SIGN U .. GUJARATI VOWEL SIGN CANDRA E + (16#00AC7#, 16#00AC8#), -- (Mn) GUJARATI VOWEL SIGN E .. GUJARATI VOWEL SIGN AI + (16#00AC9#, 16#00AC9#), -- (Mc) GUJARATI VOWEL SIGN CANDRA O .. GUJARATI VOWEL SIGN CANDRA O + (16#00ACB#, 16#00ACC#), -- (Mc) GUJARATI VOWEL SIGN O .. GUJARATI VOWEL SIGN AU + (16#00ACD#, 16#00ACD#), -- (Mn) GUJARATI SIGN VIRAMA .. GUJARATI SIGN VIRAMA + (16#00AD0#, 16#00AD0#), -- (Lo) GUJARATI OM .. GUJARATI OM + (16#00AE0#, 16#00AE1#), -- (Lo) GUJARATI LETTER VOCALIC RR .. GUJARATI LETTER VOCALIC LL + (16#00AE2#, 16#00AE3#), -- (Mn) GUJARATI VOWEL SIGN VOCALIC L .. GUJARATI VOWEL SIGN VOCALIC LL + (16#00AE6#, 16#00AEF#), -- (Nd) GUJARATI DIGIT ZERO .. GUJARATI DIGIT NINE + (16#00AF1#, 16#00AF1#), -- (Sc) GUJARATI RUPEE SIGN .. GUJARATI RUPEE SIGN + (16#00B01#, 16#00B01#), -- (Mn) ORIYA SIGN CANDRABINDU .. ORIYA SIGN CANDRABINDU + (16#00B02#, 16#00B03#), -- (Mc) ORIYA SIGN ANUSVARA .. ORIYA SIGN VISARGA + (16#00B05#, 16#00B0C#), -- (Lo) ORIYA LETTER A .. ORIYA LETTER VOCALIC L + (16#00B0F#, 16#00B10#), -- (Lo) ORIYA LETTER E .. ORIYA LETTER AI + (16#00B13#, 16#00B28#), -- (Lo) ORIYA LETTER O .. ORIYA LETTER NA + (16#00B2A#, 16#00B30#), -- (Lo) ORIYA LETTER PA .. ORIYA LETTER RA + (16#00B32#, 16#00B33#), -- (Lo) ORIYA LETTER LA .. ORIYA LETTER LLA + (16#00B35#, 16#00B39#), -- (Lo) ORIYA LETTER VA .. ORIYA LETTER HA + (16#00B3C#, 16#00B3C#), -- (Mn) ORIYA SIGN NUKTA .. ORIYA SIGN NUKTA + (16#00B3D#, 16#00B3D#), -- (Lo) ORIYA SIGN AVAGRAHA .. ORIYA SIGN AVAGRAHA + (16#00B3E#, 16#00B3E#), -- (Mc) ORIYA VOWEL SIGN AA .. ORIYA VOWEL SIGN AA + (16#00B3F#, 16#00B3F#), -- (Mn) ORIYA VOWEL SIGN I .. ORIYA VOWEL SIGN I + (16#00B40#, 16#00B40#), -- (Mc) ORIYA VOWEL SIGN II .. ORIYA VOWEL SIGN II + (16#00B41#, 16#00B43#), -- (Mn) ORIYA VOWEL SIGN U .. ORIYA VOWEL SIGN VOCALIC R + (16#00B47#, 16#00B48#), -- (Mc) ORIYA VOWEL SIGN E .. ORIYA VOWEL SIGN AI + (16#00B4B#, 16#00B4C#), -- (Mc) ORIYA VOWEL SIGN O .. ORIYA VOWEL SIGN AU + (16#00B4D#, 16#00B4D#), -- (Mn) ORIYA SIGN VIRAMA .. ORIYA SIGN VIRAMA + (16#00B56#, 16#00B56#), -- (Mn) ORIYA AI LENGTH MARK .. ORIYA AI LENGTH MARK + (16#00B57#, 16#00B57#), -- (Mc) ORIYA AU LENGTH MARK .. ORIYA AU LENGTH MARK + (16#00B5C#, 16#00B5D#), -- (Lo) ORIYA LETTER RRA .. ORIYA LETTER RHA + (16#00B5F#, 16#00B61#), -- (Lo) ORIYA LETTER YYA .. ORIYA LETTER VOCALIC LL + (16#00B66#, 16#00B6F#), -- (Nd) ORIYA DIGIT ZERO .. ORIYA DIGIT NINE + (16#00B70#, 16#00B70#), -- (So) ORIYA ISSHAR .. ORIYA ISSHAR + (16#00B71#, 16#00B71#), -- (Lo) ORIYA LETTER WA .. ORIYA LETTER WA + (16#00B82#, 16#00B82#), -- (Mn) TAMIL SIGN ANUSVARA .. TAMIL SIGN ANUSVARA + (16#00B83#, 16#00B83#), -- (Lo) TAMIL SIGN VISARGA .. TAMIL SIGN VISARGA + (16#00B85#, 16#00B8A#), -- (Lo) TAMIL LETTER A .. TAMIL LETTER UU + (16#00B8E#, 16#00B90#), -- (Lo) TAMIL LETTER E .. TAMIL LETTER AI + (16#00B92#, 16#00B95#), -- (Lo) TAMIL LETTER O .. TAMIL LETTER KA + (16#00B99#, 16#00B9A#), -- (Lo) TAMIL LETTER NGA .. TAMIL LETTER CA + (16#00B9C#, 16#00B9C#), -- (Lo) TAMIL LETTER JA .. TAMIL LETTER JA + (16#00B9E#, 16#00B9F#), -- (Lo) TAMIL LETTER NYA .. TAMIL LETTER TTA + (16#00BA3#, 16#00BA4#), -- (Lo) TAMIL LETTER NNA .. TAMIL LETTER TA + (16#00BA8#, 16#00BAA#), -- (Lo) TAMIL LETTER NA .. TAMIL LETTER PA + (16#00BAE#, 16#00BB5#), -- (Lo) TAMIL LETTER MA .. TAMIL LETTER VA + (16#00BB7#, 16#00BB9#), -- (Lo) TAMIL LETTER SSA .. TAMIL LETTER HA + (16#00BBE#, 16#00BBF#), -- (Mc) TAMIL VOWEL SIGN AA .. TAMIL VOWEL SIGN I + (16#00BC0#, 16#00BC0#), -- (Mn) TAMIL VOWEL SIGN II .. TAMIL VOWEL SIGN II + (16#00BC1#, 16#00BC2#), -- (Mc) TAMIL VOWEL SIGN U .. TAMIL VOWEL SIGN UU + (16#00BC6#, 16#00BC8#), -- (Mc) TAMIL VOWEL SIGN E .. TAMIL VOWEL SIGN AI + (16#00BCA#, 16#00BCC#), -- (Mc) TAMIL VOWEL SIGN O .. TAMIL VOWEL SIGN AU + (16#00BCD#, 16#00BCD#), -- (Mn) TAMIL SIGN VIRAMA .. TAMIL SIGN VIRAMA + (16#00BD7#, 16#00BD7#), -- (Mc) TAMIL AU LENGTH MARK .. TAMIL AU LENGTH MARK + (16#00BE7#, 16#00BEF#), -- (Nd) TAMIL DIGIT ONE .. TAMIL DIGIT NINE + (16#00BF0#, 16#00BF2#), -- (No) TAMIL NUMBER TEN .. TAMIL NUMBER ONE THOUSAND + (16#00BF3#, 16#00BF8#), -- (So) TAMIL DAY SIGN .. TAMIL AS ABOVE SIGN + (16#00BF9#, 16#00BF9#), -- (Sc) TAMIL RUPEE SIGN .. TAMIL RUPEE SIGN + (16#00BFA#, 16#00BFA#), -- (So) TAMIL NUMBER SIGN .. TAMIL NUMBER SIGN + (16#00C01#, 16#00C03#), -- (Mc) TELUGU SIGN CANDRABINDU .. TELUGU SIGN VISARGA + (16#00C05#, 16#00C0C#), -- (Lo) TELUGU LETTER A .. TELUGU LETTER VOCALIC L + (16#00C0E#, 16#00C10#), -- (Lo) TELUGU LETTER E .. TELUGU LETTER AI + (16#00C12#, 16#00C28#), -- (Lo) TELUGU LETTER O .. TELUGU LETTER NA + (16#00C2A#, 16#00C33#), -- (Lo) TELUGU LETTER PA .. TELUGU LETTER LLA + (16#00C35#, 16#00C39#), -- (Lo) TELUGU LETTER VA .. TELUGU LETTER HA + (16#00C3E#, 16#00C40#), -- (Mn) TELUGU VOWEL SIGN AA .. TELUGU VOWEL SIGN II + (16#00C41#, 16#00C44#), -- (Mc) TELUGU VOWEL SIGN U .. TELUGU VOWEL SIGN VOCALIC RR + (16#00C46#, 16#00C48#), -- (Mn) TELUGU VOWEL SIGN E .. TELUGU VOWEL SIGN AI + (16#00C4A#, 16#00C4D#), -- (Mn) TELUGU VOWEL SIGN O .. TELUGU SIGN VIRAMA + (16#00C55#, 16#00C56#), -- (Mn) TELUGU LENGTH MARK .. TELUGU AI LENGTH MARK + (16#00C60#, 16#00C61#), -- (Lo) TELUGU LETTER VOCALIC RR .. TELUGU LETTER VOCALIC LL + (16#00C66#, 16#00C6F#), -- (Nd) TELUGU DIGIT ZERO .. TELUGU DIGIT NINE + (16#00C82#, 16#00C83#), -- (Mc) KANNADA SIGN ANUSVARA .. KANNADA SIGN VISARGA + (16#00C85#, 16#00C8C#), -- (Lo) KANNADA LETTER A .. KANNADA LETTER VOCALIC L + (16#00C8E#, 16#00C90#), -- (Lo) KANNADA LETTER E .. KANNADA LETTER AI + (16#00C92#, 16#00CA8#), -- (Lo) KANNADA LETTER O .. KANNADA LETTER NA + (16#00CAA#, 16#00CB3#), -- (Lo) KANNADA LETTER PA .. KANNADA LETTER LLA + (16#00CB5#, 16#00CB9#), -- (Lo) KANNADA LETTER VA .. KANNADA LETTER HA + (16#00CBC#, 16#00CBC#), -- (Mn) KANNADA SIGN NUKTA .. KANNADA SIGN NUKTA + (16#00CBD#, 16#00CBD#), -- (Lo) KANNADA SIGN AVAGRAHA .. KANNADA SIGN AVAGRAHA + (16#00CBE#, 16#00CBE#), -- (Mc) KANNADA VOWEL SIGN AA .. KANNADA VOWEL SIGN AA + (16#00CBF#, 16#00CBF#), -- (Mn) KANNADA VOWEL SIGN I .. KANNADA VOWEL SIGN I + (16#00CC0#, 16#00CC4#), -- (Mc) KANNADA VOWEL SIGN II .. KANNADA VOWEL SIGN VOCALIC RR + (16#00CC6#, 16#00CC6#), -- (Mn) KANNADA VOWEL SIGN E .. KANNADA VOWEL SIGN E + (16#00CC7#, 16#00CC8#), -- (Mc) KANNADA VOWEL SIGN EE .. KANNADA VOWEL SIGN AI + (16#00CCA#, 16#00CCB#), -- (Mc) KANNADA VOWEL SIGN O .. KANNADA VOWEL SIGN OO + (16#00CCC#, 16#00CCD#), -- (Mn) KANNADA VOWEL SIGN AU .. KANNADA SIGN VIRAMA + (16#00CD5#, 16#00CD6#), -- (Mc) KANNADA LENGTH MARK .. KANNADA AI LENGTH MARK + (16#00CDE#, 16#00CDE#), -- (Lo) KANNADA LETTER FA .. KANNADA LETTER FA + (16#00CE0#, 16#00CE1#), -- (Lo) KANNADA LETTER VOCALIC RR .. KANNADA LETTER VOCALIC LL + (16#00CE6#, 16#00CEF#), -- (Nd) KANNADA DIGIT ZERO .. KANNADA DIGIT NINE + (16#00D02#, 16#00D03#), -- (Mc) MALAYALAM SIGN ANUSVARA .. MALAYALAM SIGN VISARGA + (16#00D05#, 16#00D0C#), -- (Lo) MALAYALAM LETTER A .. MALAYALAM LETTER VOCALIC L + (16#00D0E#, 16#00D10#), -- (Lo) MALAYALAM LETTER E .. MALAYALAM LETTER AI + (16#00D12#, 16#00D28#), -- (Lo) MALAYALAM LETTER O .. MALAYALAM LETTER NA + (16#00D2A#, 16#00D39#), -- (Lo) MALAYALAM LETTER PA .. MALAYALAM LETTER HA + (16#00D3E#, 16#00D40#), -- (Mc) MALAYALAM VOWEL SIGN AA .. MALAYALAM VOWEL SIGN II + (16#00D41#, 16#00D43#), -- (Mn) MALAYALAM VOWEL SIGN U .. MALAYALAM VOWEL SIGN VOCALIC R + (16#00D46#, 16#00D48#), -- (Mc) MALAYALAM VOWEL SIGN E .. MALAYALAM VOWEL SIGN AI + (16#00D4A#, 16#00D4C#), -- (Mc) MALAYALAM VOWEL SIGN O .. MALAYALAM VOWEL SIGN AU + (16#00D4D#, 16#00D4D#), -- (Mn) MALAYALAM SIGN VIRAMA .. MALAYALAM SIGN VIRAMA + (16#00D57#, 16#00D57#), -- (Mc) MALAYALAM AU LENGTH MARK .. MALAYALAM AU LENGTH MARK + (16#00D60#, 16#00D61#), -- (Lo) MALAYALAM LETTER VOCALIC RR .. MALAYALAM LETTER VOCALIC LL + (16#00D66#, 16#00D6F#), -- (Nd) MALAYALAM DIGIT ZERO .. MALAYALAM DIGIT NINE + (16#00D82#, 16#00D83#), -- (Mc) SINHALA SIGN ANUSVARAYA .. SINHALA SIGN VISARGAYA + (16#00D85#, 16#00D96#), -- (Lo) SINHALA LETTER AYANNA .. SINHALA LETTER AUYANNA + (16#00D9A#, 16#00DB1#), -- (Lo) SINHALA LETTER ALPAPRAANA KAYANNA .. SINHALA LETTER DANTAJA NAYANNA + (16#00DB3#, 16#00DBB#), -- (Lo) SINHALA LETTER SANYAKA DAYANNA .. SINHALA LETTER RAYANNA + (16#00DBD#, 16#00DBD#), -- (Lo) SINHALA LETTER DANTAJA LAYANNA .. SINHALA LETTER DANTAJA LAYANNA + (16#00DC0#, 16#00DC6#), -- (Lo) SINHALA LETTER VAYANNA .. SINHALA LETTER FAYANNA + (16#00DCA#, 16#00DCA#), -- (Mn) SINHALA SIGN AL-LAKUNA .. SINHALA SIGN AL-LAKUNA + (16#00DCF#, 16#00DD1#), -- (Mc) SINHALA VOWEL SIGN AELA-PILLA .. SINHALA VOWEL SIGN DIGA AEDA-PILLA + (16#00DD2#, 16#00DD4#), -- (Mn) SINHALA VOWEL SIGN KETTI IS-PILLA .. SINHALA VOWEL SIGN KETTI PAA-PILLA + (16#00DD6#, 16#00DD6#), -- (Mn) SINHALA VOWEL SIGN DIGA PAA-PILLA .. SINHALA VOWEL SIGN DIGA PAA-PILLA + (16#00DD8#, 16#00DDF#), -- (Mc) SINHALA VOWEL SIGN GAETTA-PILLA .. SINHALA VOWEL SIGN GAYANUKITTA + (16#00DF2#, 16#00DF3#), -- (Mc) SINHALA VOWEL SIGN DIGA GAETTA-PILLA .. SINHALA VOWEL SIGN DIGA GAYANUKITTA + (16#00DF4#, 16#00DF4#), -- (Po) SINHALA PUNCTUATION KUNDDALIYA .. SINHALA PUNCTUATION KUNDDALIYA + (16#00E01#, 16#00E30#), -- (Lo) THAI CHARACTER KO KAI .. THAI CHARACTER SARA A + (16#00E31#, 16#00E31#), -- (Mn) THAI CHARACTER MAI HAN-AKAT .. THAI CHARACTER MAI HAN-AKAT + (16#00E32#, 16#00E33#), -- (Lo) THAI CHARACTER SARA AA .. THAI CHARACTER SARA AM + (16#00E34#, 16#00E3A#), -- (Mn) THAI CHARACTER SARA I .. THAI CHARACTER PHINTHU + (16#00E3F#, 16#00E3F#), -- (Sc) THAI CURRENCY SYMBOL BAHT .. THAI CURRENCY SYMBOL BAHT + (16#00E40#, 16#00E45#), -- (Lo) THAI CHARACTER SARA E .. THAI CHARACTER LAKKHANGYAO + (16#00E46#, 16#00E46#), -- (Lm) THAI CHARACTER MAIYAMOK .. THAI CHARACTER MAIYAMOK + (16#00E47#, 16#00E4E#), -- (Mn) THAI CHARACTER MAITAIKHU .. THAI CHARACTER YAMAKKAN + (16#00E4F#, 16#00E4F#), -- (Po) THAI CHARACTER FONGMAN .. THAI CHARACTER FONGMAN + (16#00E50#, 16#00E59#), -- (Nd) THAI DIGIT ZERO .. THAI DIGIT NINE + (16#00E5A#, 16#00E5B#), -- (Po) THAI CHARACTER ANGKHANKHU .. THAI CHARACTER KHOMUT + (16#00E81#, 16#00E82#), -- (Lo) LAO LETTER KO .. LAO LETTER KHO SUNG + (16#00E84#, 16#00E84#), -- (Lo) LAO LETTER KHO TAM .. LAO LETTER KHO TAM + (16#00E87#, 16#00E88#), -- (Lo) LAO LETTER NGO .. LAO LETTER CO + (16#00E8A#, 16#00E8A#), -- (Lo) LAO LETTER SO TAM .. LAO LETTER SO TAM + (16#00E8D#, 16#00E8D#), -- (Lo) LAO LETTER NYO .. LAO LETTER NYO + (16#00E94#, 16#00E97#), -- (Lo) LAO LETTER DO .. LAO LETTER THO TAM + (16#00E99#, 16#00E9F#), -- (Lo) LAO LETTER NO .. LAO LETTER FO SUNG + (16#00EA1#, 16#00EA3#), -- (Lo) LAO LETTER MO .. LAO LETTER LO LING + (16#00EA5#, 16#00EA5#), -- (Lo) LAO LETTER LO LOOT .. LAO LETTER LO LOOT + (16#00EA7#, 16#00EA7#), -- (Lo) LAO LETTER WO .. LAO LETTER WO + (16#00EAA#, 16#00EAB#), -- (Lo) LAO LETTER SO SUNG .. LAO LETTER HO SUNG + (16#00EAD#, 16#00EB0#), -- (Lo) LAO LETTER O .. LAO VOWEL SIGN A + (16#00EB1#, 16#00EB1#), -- (Mn) LAO VOWEL SIGN MAI KAN .. LAO VOWEL SIGN MAI KAN + (16#00EB2#, 16#00EB3#), -- (Lo) LAO VOWEL SIGN AA .. LAO VOWEL SIGN AM + (16#00EB4#, 16#00EB9#), -- (Mn) LAO VOWEL SIGN I .. LAO VOWEL SIGN UU + (16#00EBB#, 16#00EBC#), -- (Mn) LAO VOWEL SIGN MAI KON .. LAO SEMIVOWEL SIGN LO + (16#00EBD#, 16#00EBD#), -- (Lo) LAO SEMIVOWEL SIGN NYO .. LAO SEMIVOWEL SIGN NYO + (16#00EC0#, 16#00EC4#), -- (Lo) LAO VOWEL SIGN E .. LAO VOWEL SIGN AI + (16#00EC6#, 16#00EC6#), -- (Lm) LAO KO LA .. LAO KO LA + (16#00EC8#, 16#00ECD#), -- (Mn) LAO TONE MAI EK .. LAO NIGGAHITA + (16#00ED0#, 16#00ED9#), -- (Nd) LAO DIGIT ZERO .. LAO DIGIT NINE + (16#00EDC#, 16#00EDD#), -- (Lo) LAO HO NO .. LAO HO MO + (16#00F00#, 16#00F00#), -- (Lo) TIBETAN SYLLABLE OM .. TIBETAN SYLLABLE OM + (16#00F01#, 16#00F03#), -- (So) TIBETAN MARK GTER YIG MGO TRUNCATED A .. TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA + (16#00F04#, 16#00F12#), -- (Po) TIBETAN MARK INITIAL YIG MGO MDUN MA .. TIBETAN MARK RGYA GRAM SHAD + (16#00F13#, 16#00F17#), -- (So) TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN .. TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS + (16#00F18#, 16#00F19#), -- (Mn) TIBETAN ASTROLOGICAL SIGN -KHYUD PA .. TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS + (16#00F1A#, 16#00F1F#), -- (So) TIBETAN SIGN RDEL DKAR GCIG .. TIBETAN SIGN RDEL DKAR RDEL NAG + (16#00F20#, 16#00F29#), -- (Nd) TIBETAN DIGIT ZERO .. TIBETAN DIGIT NINE + (16#00F2A#, 16#00F33#), -- (No) TIBETAN DIGIT HALF ONE .. TIBETAN DIGIT HALF ZERO + (16#00F34#, 16#00F34#), -- (So) TIBETAN MARK BSDUS RTAGS .. TIBETAN MARK BSDUS RTAGS + (16#00F35#, 16#00F35#), -- (Mn) TIBETAN MARK NGAS BZUNG NYI ZLA .. TIBETAN MARK NGAS BZUNG NYI ZLA + (16#00F36#, 16#00F36#), -- (So) TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN .. TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN + (16#00F37#, 16#00F37#), -- (Mn) TIBETAN MARK NGAS BZUNG SGOR RTAGS .. TIBETAN MARK NGAS BZUNG SGOR RTAGS + (16#00F38#, 16#00F38#), -- (So) TIBETAN MARK CHE MGO .. TIBETAN MARK CHE MGO + (16#00F39#, 16#00F39#), -- (Mn) TIBETAN MARK TSA -PHRU .. TIBETAN MARK TSA -PHRU + (16#00F3A#, 16#00F3A#), -- (Ps) TIBETAN MARK GUG RTAGS GYON .. TIBETAN MARK GUG RTAGS GYON + (16#00F3B#, 16#00F3B#), -- (Pe) TIBETAN MARK GUG RTAGS GYAS .. TIBETAN MARK GUG RTAGS GYAS + (16#00F3C#, 16#00F3C#), -- (Ps) TIBETAN MARK ANG KHANG GYON .. TIBETAN MARK ANG KHANG GYON + (16#00F3D#, 16#00F3D#), -- (Pe) TIBETAN MARK ANG KHANG GYAS .. TIBETAN MARK ANG KHANG GYAS + (16#00F3E#, 16#00F3F#), -- (Mc) TIBETAN SIGN YAR TSHES .. TIBETAN SIGN MAR TSHES + (16#00F40#, 16#00F47#), -- (Lo) TIBETAN LETTER KA .. TIBETAN LETTER JA + (16#00F49#, 16#00F6A#), -- (Lo) TIBETAN LETTER NYA .. TIBETAN LETTER FIXED-FORM RA + (16#00F71#, 16#00F7E#), -- (Mn) TIBETAN VOWEL SIGN AA .. TIBETAN SIGN RJES SU NGA RO + (16#00F7F#, 16#00F7F#), -- (Mc) TIBETAN SIGN RNAM BCAD .. TIBETAN SIGN RNAM BCAD + (16#00F80#, 16#00F84#), -- (Mn) TIBETAN VOWEL SIGN REVERSED I .. TIBETAN MARK HALANTA + (16#00F85#, 16#00F85#), -- (Po) TIBETAN MARK PALUTA .. TIBETAN MARK PALUTA + (16#00F86#, 16#00F87#), -- (Mn) TIBETAN SIGN LCI RTAGS .. TIBETAN SIGN YANG RTAGS + (16#00F88#, 16#00F8B#), -- (Lo) TIBETAN SIGN LCE TSA CAN .. TIBETAN SIGN GRU MED RGYINGS + (16#00F90#, 16#00F97#), -- (Mn) TIBETAN SUBJOINED LETTER KA .. TIBETAN SUBJOINED LETTER JA + (16#00F99#, 16#00FBC#), -- (Mn) TIBETAN SUBJOINED LETTER NYA .. TIBETAN SUBJOINED LETTER FIXED-FORM RA + (16#00FBE#, 16#00FC5#), -- (So) TIBETAN KU RU KHA .. TIBETAN SYMBOL RDO RJE + (16#00FC6#, 16#00FC6#), -- (Mn) TIBETAN SYMBOL PADMA GDAN .. TIBETAN SYMBOL PADMA GDAN + (16#00FC7#, 16#00FCC#), -- (So) TIBETAN SYMBOL RDO RJE RGYA GRAM .. TIBETAN SYMBOL NOR BU BZHI -KHYIL + (16#00FCF#, 16#00FCF#), -- (So) TIBETAN SIGN RDEL NAG GSUM .. TIBETAN SIGN RDEL NAG GSUM + (16#01000#, 16#01021#), -- (Lo) MYANMAR LETTER KA .. MYANMAR LETTER A + (16#01023#, 16#01027#), -- (Lo) MYANMAR LETTER I .. MYANMAR LETTER E + (16#01029#, 16#0102A#), -- (Lo) MYANMAR LETTER O .. MYANMAR LETTER AU + (16#0102C#, 16#0102C#), -- (Mc) MYANMAR VOWEL SIGN AA .. MYANMAR VOWEL SIGN AA + (16#0102D#, 16#01030#), -- (Mn) MYANMAR VOWEL SIGN I .. MYANMAR VOWEL SIGN UU + (16#01031#, 16#01031#), -- (Mc) MYANMAR VOWEL SIGN E .. MYANMAR VOWEL SIGN E + (16#01032#, 16#01032#), -- (Mn) MYANMAR VOWEL SIGN AI .. MYANMAR VOWEL SIGN AI + (16#01036#, 16#01037#), -- (Mn) MYANMAR SIGN ANUSVARA .. MYANMAR SIGN DOT BELOW + (16#01038#, 16#01038#), -- (Mc) MYANMAR SIGN VISARGA .. MYANMAR SIGN VISARGA + (16#01039#, 16#01039#), -- (Mn) MYANMAR SIGN VIRAMA .. MYANMAR SIGN VIRAMA + (16#01040#, 16#01049#), -- (Nd) MYANMAR DIGIT ZERO .. MYANMAR DIGIT NINE + (16#0104A#, 16#0104F#), -- (Po) MYANMAR SIGN LITTLE SECTION .. MYANMAR SYMBOL GENITIVE + (16#01050#, 16#01055#), -- (Lo) MYANMAR LETTER SHA .. MYANMAR LETTER VOCALIC LL + (16#01056#, 16#01057#), -- (Mc) MYANMAR VOWEL SIGN VOCALIC R .. MYANMAR VOWEL SIGN VOCALIC RR + (16#01058#, 16#01059#), -- (Mn) MYANMAR VOWEL SIGN VOCALIC L .. MYANMAR VOWEL SIGN VOCALIC LL + (16#010A0#, 16#010C5#), -- (Lu) GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE + (16#010D0#, 16#010F8#), -- (Lo) GEORGIAN LETTER AN .. GEORGIAN LETTER ELIFI + (16#010FB#, 16#010FB#), -- (Po) GEORGIAN PARAGRAPH SEPARATOR .. GEORGIAN PARAGRAPH SEPARATOR + (16#01100#, 16#01159#), -- (Lo) HANGUL CHOSEONG KIYEOK .. HANGUL CHOSEONG YEORINHIEUH + (16#0115F#, 16#011A2#), -- (Lo) HANGUL CHOSEONG FILLER .. HANGUL JUNGSEONG SSANGARAEA + (16#011A8#, 16#011F9#), -- (Lo) HANGUL JONGSEONG KIYEOK .. HANGUL JONGSEONG YEORINHIEUH + (16#01200#, 16#01206#), -- (Lo) ETHIOPIC SYLLABLE HA .. ETHIOPIC SYLLABLE HO + (16#01208#, 16#01246#), -- (Lo) ETHIOPIC SYLLABLE LA .. ETHIOPIC SYLLABLE QO + (16#01248#, 16#01248#), -- (Lo) ETHIOPIC SYLLABLE QWA .. ETHIOPIC SYLLABLE QWA + (16#0124A#, 16#0124D#), -- (Lo) ETHIOPIC SYLLABLE QWI .. ETHIOPIC SYLLABLE QWE + (16#01250#, 16#01256#), -- (Lo) ETHIOPIC SYLLABLE QHA .. ETHIOPIC SYLLABLE QHO + (16#01258#, 16#01258#), -- (Lo) ETHIOPIC SYLLABLE QHWA .. ETHIOPIC SYLLABLE QHWA + (16#0125A#, 16#0125D#), -- (Lo) ETHIOPIC SYLLABLE QHWI .. ETHIOPIC SYLLABLE QHWE + (16#01260#, 16#01286#), -- (Lo) ETHIOPIC SYLLABLE BA .. ETHIOPIC SYLLABLE XO + (16#01288#, 16#01288#), -- (Lo) ETHIOPIC SYLLABLE XWA .. ETHIOPIC SYLLABLE XWA + (16#0128A#, 16#0128D#), -- (Lo) ETHIOPIC SYLLABLE XWI .. ETHIOPIC SYLLABLE XWE + (16#01290#, 16#012AE#), -- (Lo) ETHIOPIC SYLLABLE NA .. ETHIOPIC SYLLABLE KO + (16#012B0#, 16#012B0#), -- (Lo) ETHIOPIC SYLLABLE KWA .. ETHIOPIC SYLLABLE KWA + (16#012B2#, 16#012B5#), -- (Lo) ETHIOPIC SYLLABLE KWI .. ETHIOPIC SYLLABLE KWE + (16#012B8#, 16#012BE#), -- (Lo) ETHIOPIC SYLLABLE KXA .. ETHIOPIC SYLLABLE KXO + (16#012C0#, 16#012C0#), -- (Lo) ETHIOPIC SYLLABLE KXWA .. ETHIOPIC SYLLABLE KXWA + (16#012C2#, 16#012C5#), -- (Lo) ETHIOPIC SYLLABLE KXWI .. ETHIOPIC SYLLABLE KXWE + (16#012C8#, 16#012CE#), -- (Lo) ETHIOPIC SYLLABLE WA .. ETHIOPIC SYLLABLE WO + (16#012D0#, 16#012D6#), -- (Lo) ETHIOPIC SYLLABLE PHARYNGEAL A .. ETHIOPIC SYLLABLE PHARYNGEAL O + (16#012D8#, 16#012EE#), -- (Lo) ETHIOPIC SYLLABLE ZA .. ETHIOPIC SYLLABLE YO + (16#012F0#, 16#0130E#), -- (Lo) ETHIOPIC SYLLABLE DA .. ETHIOPIC SYLLABLE GO + (16#01310#, 16#01310#), -- (Lo) ETHIOPIC SYLLABLE GWA .. ETHIOPIC SYLLABLE GWA + (16#01312#, 16#01315#), -- (Lo) ETHIOPIC SYLLABLE GWI .. ETHIOPIC SYLLABLE GWE + (16#01318#, 16#0131E#), -- (Lo) ETHIOPIC SYLLABLE GGA .. ETHIOPIC SYLLABLE GGO + (16#01320#, 16#01346#), -- (Lo) ETHIOPIC SYLLABLE THA .. ETHIOPIC SYLLABLE TZO + (16#01348#, 16#0135A#), -- (Lo) ETHIOPIC SYLLABLE FA .. ETHIOPIC SYLLABLE FYA + (16#01361#, 16#01368#), -- (Po) ETHIOPIC WORDSPACE .. ETHIOPIC PARAGRAPH SEPARATOR + (16#01369#, 16#01371#), -- (Nd) ETHIOPIC DIGIT ONE .. ETHIOPIC DIGIT NINE + (16#01372#, 16#0137C#), -- (No) ETHIOPIC NUMBER TEN .. ETHIOPIC NUMBER TEN THOUSAND + (16#013A0#, 16#013F4#), -- (Lo) CHEROKEE LETTER A .. CHEROKEE LETTER YV + (16#01401#, 16#0166C#), -- (Lo) CANADIAN SYLLABICS E .. CANADIAN SYLLABICS CARRIER TTSA + (16#0166D#, 16#0166E#), -- (Po) CANADIAN SYLLABICS CHI SIGN .. CANADIAN SYLLABICS FULL STOP + (16#0166F#, 16#01676#), -- (Lo) CANADIAN SYLLABICS QAI .. CANADIAN SYLLABICS NNGAA + (16#01680#, 16#01680#), -- (Zs) OGHAM SPACE MARK .. OGHAM SPACE MARK + (16#01681#, 16#0169A#), -- (Lo) OGHAM LETTER BEITH .. OGHAM LETTER PEITH + (16#0169B#, 16#0169B#), -- (Ps) OGHAM FEATHER MARK .. OGHAM FEATHER MARK + (16#0169C#, 16#0169C#), -- (Pe) OGHAM REVERSED FEATHER MARK .. OGHAM REVERSED FEATHER MARK + (16#016A0#, 16#016EA#), -- (Lo) RUNIC LETTER FEHU FEOH FE F .. RUNIC LETTER X + (16#016EB#, 16#016ED#), -- (Po) RUNIC SINGLE PUNCTUATION .. RUNIC CROSS PUNCTUATION + (16#016EE#, 16#016F0#), -- (Nl) RUNIC ARLAUG SYMBOL .. RUNIC BELGTHOR SYMBOL + (16#01700#, 16#0170C#), -- (Lo) TAGALOG LETTER A .. TAGALOG LETTER YA + (16#0170E#, 16#01711#), -- (Lo) TAGALOG LETTER LA .. TAGALOG LETTER HA + (16#01712#, 16#01714#), -- (Mn) TAGALOG VOWEL SIGN I .. TAGALOG SIGN VIRAMA + (16#01720#, 16#01731#), -- (Lo) HANUNOO LETTER A .. HANUNOO LETTER HA + (16#01732#, 16#01734#), -- (Mn) HANUNOO VOWEL SIGN I .. HANUNOO SIGN PAMUDPOD + (16#01735#, 16#01736#), -- (Po) PHILIPPINE SINGLE PUNCTUATION .. PHILIPPINE DOUBLE PUNCTUATION + (16#01740#, 16#01751#), -- (Lo) BUHID LETTER A .. BUHID LETTER HA + (16#01752#, 16#01753#), -- (Mn) BUHID VOWEL SIGN I .. BUHID VOWEL SIGN U + (16#01760#, 16#0176C#), -- (Lo) TAGBANWA LETTER A .. TAGBANWA LETTER YA + (16#0176E#, 16#01770#), -- (Lo) TAGBANWA LETTER LA .. TAGBANWA LETTER SA + (16#01772#, 16#01773#), -- (Mn) TAGBANWA VOWEL SIGN I .. TAGBANWA VOWEL SIGN U + (16#01780#, 16#017B3#), -- (Lo) KHMER LETTER KA .. KHMER INDEPENDENT VOWEL QAU + (16#017B4#, 16#017B5#), -- (Cf) KHMER VOWEL INHERENT AQ .. KHMER VOWEL INHERENT AA + (16#017B6#, 16#017B6#), -- (Mc) KHMER VOWEL SIGN AA .. KHMER VOWEL SIGN AA + (16#017B7#, 16#017BD#), -- (Mn) KHMER VOWEL SIGN I .. KHMER VOWEL SIGN UA + (16#017BE#, 16#017C5#), -- (Mc) KHMER VOWEL SIGN OE .. KHMER VOWEL SIGN AU + (16#017C6#, 16#017C6#), -- (Mn) KHMER SIGN NIKAHIT .. KHMER SIGN NIKAHIT + (16#017C7#, 16#017C8#), -- (Mc) KHMER SIGN REAHMUK .. KHMER SIGN YUUKALEAPINTU + (16#017C9#, 16#017D3#), -- (Mn) KHMER SIGN MUUSIKATOAN .. KHMER SIGN BATHAMASAT + (16#017D4#, 16#017D6#), -- (Po) KHMER SIGN KHAN .. KHMER SIGN CAMNUC PII KUUH + (16#017D7#, 16#017D7#), -- (Lm) KHMER SIGN LEK TOO .. KHMER SIGN LEK TOO + (16#017D8#, 16#017DA#), -- (Po) KHMER SIGN BEYYAL .. KHMER SIGN KOOMUUT + (16#017DB#, 16#017DB#), -- (Sc) KHMER CURRENCY SYMBOL RIEL .. KHMER CURRENCY SYMBOL RIEL + (16#017DC#, 16#017DC#), -- (Lo) KHMER SIGN AVAKRAHASANYA .. KHMER SIGN AVAKRAHASANYA + (16#017DD#, 16#017DD#), -- (Mn) KHMER SIGN ATTHACAN .. KHMER SIGN ATTHACAN + (16#017E0#, 16#017E9#), -- (Nd) KHMER DIGIT ZERO .. KHMER DIGIT NINE + (16#017F0#, 16#017F9#), -- (No) KHMER SYMBOL LEK ATTAK SON .. KHMER SYMBOL LEK ATTAK PRAM-BUON + (16#01800#, 16#01805#), -- (Po) MONGOLIAN BIRGA .. MONGOLIAN FOUR DOTS + (16#01806#, 16#01806#), -- (Pd) MONGOLIAN TODO SOFT HYPHEN .. MONGOLIAN TODO SOFT HYPHEN + (16#01807#, 16#0180A#), -- (Po) MONGOLIAN SIBE SYLLABLE BOUNDARY MARKER .. MONGOLIAN NIRUGU + (16#0180B#, 16#0180D#), -- (Mn) MONGOLIAN FREE VARIATION SELECTOR ONE .. MONGOLIAN FREE VARIATION SELECTOR THREE + (16#0180E#, 16#0180E#), -- (Zs) MONGOLIAN VOWEL SEPARATOR .. MONGOLIAN VOWEL SEPARATOR + (16#01810#, 16#01819#), -- (Nd) MONGOLIAN DIGIT ZERO .. MONGOLIAN DIGIT NINE + (16#01820#, 16#01842#), -- (Lo) MONGOLIAN LETTER A .. MONGOLIAN LETTER CHI + (16#01843#, 16#01843#), -- (Lm) MONGOLIAN LETTER TODO LONG VOWEL SIGN .. MONGOLIAN LETTER TODO LONG VOWEL SIGN + (16#01844#, 16#01877#), -- (Lo) MONGOLIAN LETTER TODO E .. MONGOLIAN LETTER MANCHU ZHA + (16#01880#, 16#018A8#), -- (Lo) MONGOLIAN LETTER ALI GALI ANUSVARA ONE .. MONGOLIAN LETTER MANCHU ALI GALI BHA + (16#018A9#, 16#018A9#), -- (Mn) MONGOLIAN LETTER ALI GALI DAGALGA .. MONGOLIAN LETTER ALI GALI DAGALGA + (16#01900#, 16#0191C#), -- (Lo) LIMBU VOWEL-CARRIER LETTER .. LIMBU LETTER HA + (16#01920#, 16#01922#), -- (Mn) LIMBU VOWEL SIGN A .. LIMBU VOWEL SIGN U + (16#01923#, 16#01926#), -- (Mc) LIMBU VOWEL SIGN EE .. LIMBU VOWEL SIGN AU + (16#01927#, 16#01928#), -- (Mn) LIMBU VOWEL SIGN E .. LIMBU VOWEL SIGN O + (16#01929#, 16#0192B#), -- (Mc) LIMBU SUBJOINED LETTER YA .. LIMBU SUBJOINED LETTER WA + (16#01930#, 16#01931#), -- (Mc) LIMBU SMALL LETTER KA .. LIMBU SMALL LETTER NGA + (16#01932#, 16#01932#), -- (Mn) LIMBU SMALL LETTER ANUSVARA .. LIMBU SMALL LETTER ANUSVARA + (16#01933#, 16#01938#), -- (Mc) LIMBU SMALL LETTER TA .. LIMBU SMALL LETTER LA + (16#01939#, 16#0193B#), -- (Mn) LIMBU SIGN MUKPHRENG .. LIMBU SIGN SA-I + (16#01940#, 16#01940#), -- (So) LIMBU SIGN LOO .. LIMBU SIGN LOO + (16#01944#, 16#01945#), -- (Po) LIMBU EXCLAMATION MARK .. LIMBU QUESTION MARK + (16#01946#, 16#0194F#), -- (Nd) LIMBU DIGIT ZERO .. LIMBU DIGIT NINE + (16#01950#, 16#0196D#), -- (Lo) TAI LE LETTER KA .. TAI LE LETTER AI + (16#01970#, 16#01974#), -- (Lo) TAI LE LETTER TONE-2 .. TAI LE LETTER TONE-6 + (16#019E0#, 16#019FF#), -- (So) KHMER SYMBOL PATHAMASAT .. KHMER SYMBOL DAP-PRAM ROC + (16#01D00#, 16#01D2B#), -- (Ll) LATIN LETTER SMALL CAPITAL A .. CYRILLIC LETTER SMALL CAPITAL EL + (16#01D2C#, 16#01D61#), -- (Lm) MODIFIER LETTER CAPITAL A .. MODIFIER LETTER SMALL CHI + (16#01D62#, 16#01D6B#), -- (Ll) LATIN SUBSCRIPT SMALL LETTER I .. LATIN SMALL LETTER UE + (16#01E00#, 16#01E00#), -- (Lu) LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW + (16#01E01#, 16#01E01#), -- (Ll) LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW + (16#01E02#, 16#01E02#), -- (Lu) LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE + (16#01E03#, 16#01E03#), -- (Ll) LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE + (16#01E04#, 16#01E04#), -- (Lu) LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW + (16#01E05#, 16#01E05#), -- (Ll) LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW + (16#01E06#, 16#01E06#), -- (Lu) LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW + (16#01E07#, 16#01E07#), -- (Ll) LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW + (16#01E08#, 16#01E08#), -- (Lu) LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE + (16#01E09#, 16#01E09#), -- (Ll) LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE + (16#01E0A#, 16#01E0A#), -- (Lu) LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE + (16#01E0B#, 16#01E0B#), -- (Ll) LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE + (16#01E0C#, 16#01E0C#), -- (Lu) LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW + (16#01E0D#, 16#01E0D#), -- (Ll) LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW + (16#01E0E#, 16#01E0E#), -- (Lu) LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW + (16#01E0F#, 16#01E0F#), -- (Ll) LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW + (16#01E10#, 16#01E10#), -- (Lu) LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA + (16#01E11#, 16#01E11#), -- (Ll) LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA + (16#01E12#, 16#01E12#), -- (Lu) LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW + (16#01E13#, 16#01E13#), -- (Ll) LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW + (16#01E14#, 16#01E14#), -- (Lu) LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE + (16#01E15#, 16#01E15#), -- (Ll) LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE + (16#01E16#, 16#01E16#), -- (Lu) LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE + (16#01E17#, 16#01E17#), -- (Ll) LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE + (16#01E18#, 16#01E18#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW + (16#01E19#, 16#01E19#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW + (16#01E1A#, 16#01E1A#), -- (Lu) LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW + (16#01E1B#, 16#01E1B#), -- (Ll) LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW + (16#01E1C#, 16#01E1C#), -- (Lu) LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE + (16#01E1D#, 16#01E1D#), -- (Ll) LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE + (16#01E1E#, 16#01E1E#), -- (Lu) LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE + (16#01E1F#, 16#01E1F#), -- (Ll) LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE + (16#01E20#, 16#01E20#), -- (Lu) LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON + (16#01E21#, 16#01E21#), -- (Ll) LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON + (16#01E22#, 16#01E22#), -- (Lu) LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE + (16#01E23#, 16#01E23#), -- (Ll) LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE + (16#01E24#, 16#01E24#), -- (Lu) LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW + (16#01E25#, 16#01E25#), -- (Ll) LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW + (16#01E26#, 16#01E26#), -- (Lu) LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS + (16#01E27#, 16#01E27#), -- (Ll) LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS + (16#01E28#, 16#01E28#), -- (Lu) LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA + (16#01E29#, 16#01E29#), -- (Ll) LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA + (16#01E2A#, 16#01E2A#), -- (Lu) LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW + (16#01E2B#, 16#01E2B#), -- (Ll) LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW + (16#01E2C#, 16#01E2C#), -- (Lu) LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW + (16#01E2D#, 16#01E2D#), -- (Ll) LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW + (16#01E2E#, 16#01E2E#), -- (Lu) LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE + (16#01E2F#, 16#01E2F#), -- (Ll) LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE + (16#01E30#, 16#01E30#), -- (Lu) LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE + (16#01E31#, 16#01E31#), -- (Ll) LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE + (16#01E32#, 16#01E32#), -- (Lu) LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW + (16#01E33#, 16#01E33#), -- (Ll) LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW + (16#01E34#, 16#01E34#), -- (Lu) LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW + (16#01E35#, 16#01E35#), -- (Ll) LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW + (16#01E36#, 16#01E36#), -- (Lu) LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW + (16#01E37#, 16#01E37#), -- (Ll) LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW + (16#01E38#, 16#01E38#), -- (Lu) LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON + (16#01E39#, 16#01E39#), -- (Ll) LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON + (16#01E3A#, 16#01E3A#), -- (Lu) LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW + (16#01E3B#, 16#01E3B#), -- (Ll) LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW + (16#01E3C#, 16#01E3C#), -- (Lu) LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW + (16#01E3D#, 16#01E3D#), -- (Ll) LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW + (16#01E3E#, 16#01E3E#), -- (Lu) LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE + (16#01E3F#, 16#01E3F#), -- (Ll) LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE + (16#01E40#, 16#01E40#), -- (Lu) LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE + (16#01E41#, 16#01E41#), -- (Ll) LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE + (16#01E42#, 16#01E42#), -- (Lu) LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW + (16#01E43#, 16#01E43#), -- (Ll) LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW + (16#01E44#, 16#01E44#), -- (Lu) LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE + (16#01E45#, 16#01E45#), -- (Ll) LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE + (16#01E46#, 16#01E46#), -- (Lu) LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW + (16#01E47#, 16#01E47#), -- (Ll) LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW + (16#01E48#, 16#01E48#), -- (Lu) LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW + (16#01E49#, 16#01E49#), -- (Ll) LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW + (16#01E4A#, 16#01E4A#), -- (Lu) LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW + (16#01E4B#, 16#01E4B#), -- (Ll) LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW + (16#01E4C#, 16#01E4C#), -- (Lu) LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE + (16#01E4D#, 16#01E4D#), -- (Ll) LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE + (16#01E4E#, 16#01E4E#), -- (Lu) LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS + (16#01E4F#, 16#01E4F#), -- (Ll) LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS + (16#01E50#, 16#01E50#), -- (Lu) LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE + (16#01E51#, 16#01E51#), -- (Ll) LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE + (16#01E52#, 16#01E52#), -- (Lu) LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE + (16#01E53#, 16#01E53#), -- (Ll) LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE + (16#01E54#, 16#01E54#), -- (Lu) LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE + (16#01E55#, 16#01E55#), -- (Ll) LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE + (16#01E56#, 16#01E56#), -- (Lu) LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE + (16#01E57#, 16#01E57#), -- (Ll) LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE + (16#01E58#, 16#01E58#), -- (Lu) LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE + (16#01E59#, 16#01E59#), -- (Ll) LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE + (16#01E5A#, 16#01E5A#), -- (Lu) LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW + (16#01E5B#, 16#01E5B#), -- (Ll) LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW + (16#01E5C#, 16#01E5C#), -- (Lu) LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON + (16#01E5D#, 16#01E5D#), -- (Ll) LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON + (16#01E5E#, 16#01E5E#), -- (Lu) LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW + (16#01E5F#, 16#01E5F#), -- (Ll) LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW + (16#01E60#, 16#01E60#), -- (Lu) LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE + (16#01E61#, 16#01E61#), -- (Ll) LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE + (16#01E62#, 16#01E62#), -- (Lu) LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW + (16#01E63#, 16#01E63#), -- (Ll) LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW + (16#01E64#, 16#01E64#), -- (Lu) LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE + (16#01E65#, 16#01E65#), -- (Ll) LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE + (16#01E66#, 16#01E66#), -- (Lu) LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE + (16#01E67#, 16#01E67#), -- (Ll) LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE + (16#01E68#, 16#01E68#), -- (Lu) LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE + (16#01E69#, 16#01E69#), -- (Ll) LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE + (16#01E6A#, 16#01E6A#), -- (Lu) LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE + (16#01E6B#, 16#01E6B#), -- (Ll) LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE + (16#01E6C#, 16#01E6C#), -- (Lu) LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW + (16#01E6D#, 16#01E6D#), -- (Ll) LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW + (16#01E6E#, 16#01E6E#), -- (Lu) LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW + (16#01E6F#, 16#01E6F#), -- (Ll) LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW + (16#01E70#, 16#01E70#), -- (Lu) LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW + (16#01E71#, 16#01E71#), -- (Ll) LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW + (16#01E72#, 16#01E72#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW + (16#01E73#, 16#01E73#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW + (16#01E74#, 16#01E74#), -- (Lu) LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW + (16#01E75#, 16#01E75#), -- (Ll) LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW + (16#01E76#, 16#01E76#), -- (Lu) LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW + (16#01E77#, 16#01E77#), -- (Ll) LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW + (16#01E78#, 16#01E78#), -- (Lu) LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE + (16#01E79#, 16#01E79#), -- (Ll) LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE + (16#01E7A#, 16#01E7A#), -- (Lu) LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS + (16#01E7B#, 16#01E7B#), -- (Ll) LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS + (16#01E7C#, 16#01E7C#), -- (Lu) LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE + (16#01E7D#, 16#01E7D#), -- (Ll) LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE + (16#01E7E#, 16#01E7E#), -- (Lu) LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW + (16#01E7F#, 16#01E7F#), -- (Ll) LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW + (16#01E80#, 16#01E80#), -- (Lu) LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE + (16#01E81#, 16#01E81#), -- (Ll) LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE + (16#01E82#, 16#01E82#), -- (Lu) LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE + (16#01E83#, 16#01E83#), -- (Ll) LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE + (16#01E84#, 16#01E84#), -- (Lu) LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS + (16#01E85#, 16#01E85#), -- (Ll) LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS + (16#01E86#, 16#01E86#), -- (Lu) LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE + (16#01E87#, 16#01E87#), -- (Ll) LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE + (16#01E88#, 16#01E88#), -- (Lu) LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW + (16#01E89#, 16#01E89#), -- (Ll) LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW + (16#01E8A#, 16#01E8A#), -- (Lu) LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE + (16#01E8B#, 16#01E8B#), -- (Ll) LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE + (16#01E8C#, 16#01E8C#), -- (Lu) LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS + (16#01E8D#, 16#01E8D#), -- (Ll) LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS + (16#01E8E#, 16#01E8E#), -- (Lu) LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE + (16#01E8F#, 16#01E8F#), -- (Ll) LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE + (16#01E90#, 16#01E90#), -- (Lu) LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX + (16#01E91#, 16#01E91#), -- (Ll) LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX + (16#01E92#, 16#01E92#), -- (Lu) LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW + (16#01E93#, 16#01E93#), -- (Ll) LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW + (16#01E94#, 16#01E94#), -- (Lu) LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW + (16#01E95#, 16#01E9B#), -- (Ll) LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER LONG S WITH DOT ABOVE + (16#01EA0#, 16#01EA0#), -- (Lu) LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW + (16#01EA1#, 16#01EA1#), -- (Ll) LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW + (16#01EA2#, 16#01EA2#), -- (Lu) LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE + (16#01EA3#, 16#01EA3#), -- (Ll) LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE + (16#01EA4#, 16#01EA4#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE + (16#01EA5#, 16#01EA5#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE + (16#01EA6#, 16#01EA6#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE + (16#01EA7#, 16#01EA7#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE + (16#01EA8#, 16#01EA8#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EA9#, 16#01EA9#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EAA#, 16#01EAA#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE + (16#01EAB#, 16#01EAB#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE + (16#01EAC#, 16#01EAC#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW + (16#01EAD#, 16#01EAD#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW + (16#01EAE#, 16#01EAE#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE + (16#01EAF#, 16#01EAF#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE + (16#01EB0#, 16#01EB0#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE + (16#01EB1#, 16#01EB1#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE + (16#01EB2#, 16#01EB2#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE + (16#01EB3#, 16#01EB3#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE + (16#01EB4#, 16#01EB4#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE + (16#01EB5#, 16#01EB5#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE + (16#01EB6#, 16#01EB6#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW + (16#01EB7#, 16#01EB7#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW + (16#01EB8#, 16#01EB8#), -- (Lu) LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW + (16#01EB9#, 16#01EB9#), -- (Ll) LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW + (16#01EBA#, 16#01EBA#), -- (Lu) LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE + (16#01EBB#, 16#01EBB#), -- (Ll) LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE + (16#01EBC#, 16#01EBC#), -- (Lu) LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE + (16#01EBD#, 16#01EBD#), -- (Ll) LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE + (16#01EBE#, 16#01EBE#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE + (16#01EBF#, 16#01EBF#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE + (16#01EC0#, 16#01EC0#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE + (16#01EC1#, 16#01EC1#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE + (16#01EC2#, 16#01EC2#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EC3#, 16#01EC3#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EC4#, 16#01EC4#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE + (16#01EC5#, 16#01EC5#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE + (16#01EC6#, 16#01EC6#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW + (16#01EC7#, 16#01EC7#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW + (16#01EC8#, 16#01EC8#), -- (Lu) LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE + (16#01EC9#, 16#01EC9#), -- (Ll) LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE + (16#01ECA#, 16#01ECA#), -- (Lu) LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW + (16#01ECB#, 16#01ECB#), -- (Ll) LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW + (16#01ECC#, 16#01ECC#), -- (Lu) LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW + (16#01ECD#, 16#01ECD#), -- (Ll) LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW + (16#01ECE#, 16#01ECE#), -- (Lu) LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE + (16#01ECF#, 16#01ECF#), -- (Ll) LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE + (16#01ED0#, 16#01ED0#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE + (16#01ED1#, 16#01ED1#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE + (16#01ED2#, 16#01ED2#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE + (16#01ED3#, 16#01ED3#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE + (16#01ED4#, 16#01ED4#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + (16#01ED5#, 16#01ED5#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + (16#01ED6#, 16#01ED6#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE + (16#01ED7#, 16#01ED7#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE + (16#01ED8#, 16#01ED8#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW + (16#01ED9#, 16#01ED9#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW + (16#01EDA#, 16#01EDA#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE + (16#01EDB#, 16#01EDB#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE + (16#01EDC#, 16#01EDC#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE + (16#01EDD#, 16#01EDD#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE + (16#01EDE#, 16#01EDE#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE + (16#01EDF#, 16#01EDF#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE + (16#01EE0#, 16#01EE0#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE + (16#01EE1#, 16#01EE1#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE + (16#01EE2#, 16#01EE2#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW + (16#01EE3#, 16#01EE3#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW + (16#01EE4#, 16#01EE4#), -- (Lu) LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW + (16#01EE5#, 16#01EE5#), -- (Ll) LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW + (16#01EE6#, 16#01EE6#), -- (Lu) LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE + (16#01EE7#, 16#01EE7#), -- (Ll) LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE + (16#01EE8#, 16#01EE8#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE + (16#01EE9#, 16#01EE9#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE + (16#01EEA#, 16#01EEA#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE + (16#01EEB#, 16#01EEB#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE + (16#01EEC#, 16#01EEC#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE + (16#01EED#, 16#01EED#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE + (16#01EEE#, 16#01EEE#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE + (16#01EEF#, 16#01EEF#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE + (16#01EF0#, 16#01EF0#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW + (16#01EF1#, 16#01EF1#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW + (16#01EF2#, 16#01EF2#), -- (Lu) LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE + (16#01EF3#, 16#01EF3#), -- (Ll) LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE + (16#01EF4#, 16#01EF4#), -- (Lu) LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW + (16#01EF5#, 16#01EF5#), -- (Ll) LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW + (16#01EF6#, 16#01EF6#), -- (Lu) LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE + (16#01EF7#, 16#01EF7#), -- (Ll) LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE + (16#01EF8#, 16#01EF8#), -- (Lu) LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE + (16#01EF9#, 16#01EF9#), -- (Ll) LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE + (16#01F00#, 16#01F07#), -- (Ll) GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI + (16#01F08#, 16#01F0F#), -- (Lu) GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI + (16#01F10#, 16#01F15#), -- (Ll) GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA + (16#01F18#, 16#01F1D#), -- (Lu) GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA + (16#01F20#, 16#01F27#), -- (Ll) GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI + (16#01F28#, 16#01F2F#), -- (Lu) GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI + (16#01F30#, 16#01F37#), -- (Ll) GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI + (16#01F38#, 16#01F3F#), -- (Lu) GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI + (16#01F40#, 16#01F45#), -- (Ll) GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA + (16#01F48#, 16#01F4D#), -- (Lu) GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA + (16#01F50#, 16#01F57#), -- (Ll) GREEK SMALL LETTER UPSILON WITH PSILI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI + (16#01F59#, 16#01F59#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA + (16#01F5B#, 16#01F5B#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA + (16#01F5D#, 16#01F5D#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA + (16#01F5F#, 16#01F5F#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI + (16#01F60#, 16#01F67#), -- (Ll) GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI + (16#01F68#, 16#01F6F#), -- (Lu) GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI + (16#01F70#, 16#01F7D#), -- (Ll) GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA + (16#01F80#, 16#01F87#), -- (Ll) GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + (16#01F88#, 16#01F8F#), -- (Lt) GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + (16#01F90#, 16#01F97#), -- (Ll) GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + (16#01F98#, 16#01F9F#), -- (Lt) GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + (16#01FA0#, 16#01FA7#), -- (Ll) GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + (16#01FA8#, 16#01FAF#), -- (Lt) GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + (16#01FB0#, 16#01FB4#), -- (Ll) GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI + (16#01FB6#, 16#01FB7#), -- (Ll) GREEK SMALL LETTER ALPHA WITH PERISPOMENI .. GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI + (16#01FB8#, 16#01FBB#), -- (Lu) GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH OXIA + (16#01FBC#, 16#01FBC#), -- (Lt) GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI + (16#01FBD#, 16#01FBD#), -- (Sk) GREEK KORONIS .. GREEK KORONIS + (16#01FBE#, 16#01FBE#), -- (Ll) GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI + (16#01FBF#, 16#01FC1#), -- (Sk) GREEK PSILI .. GREEK DIALYTIKA AND PERISPOMENI + (16#01FC2#, 16#01FC4#), -- (Ll) GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI + (16#01FC6#, 16#01FC7#), -- (Ll) GREEK SMALL LETTER ETA WITH PERISPOMENI .. GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI + (16#01FC8#, 16#01FCB#), -- (Lu) GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA + (16#01FCC#, 16#01FCC#), -- (Lt) GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI + (16#01FCD#, 16#01FCF#), -- (Sk) GREEK PSILI AND VARIA .. GREEK PSILI AND PERISPOMENI + (16#01FD0#, 16#01FD3#), -- (Ll) GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA + (16#01FD6#, 16#01FD7#), -- (Ll) GREEK SMALL LETTER IOTA WITH PERISPOMENI .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI + (16#01FD8#, 16#01FDB#), -- (Lu) GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH OXIA + (16#01FDD#, 16#01FDF#), -- (Sk) GREEK DASIA AND VARIA .. GREEK DASIA AND PERISPOMENI + (16#01FE0#, 16#01FE7#), -- (Ll) GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI + (16#01FE8#, 16#01FEC#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER RHO WITH DASIA + (16#01FED#, 16#01FEF#), -- (Sk) GREEK DIALYTIKA AND VARIA .. GREEK VARIA + (16#01FF2#, 16#01FF4#), -- (Ll) GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI + (16#01FF6#, 16#01FF7#), -- (Ll) GREEK SMALL LETTER OMEGA WITH PERISPOMENI .. GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI + (16#01FF8#, 16#01FFB#), -- (Lu) GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA + (16#01FFC#, 16#01FFC#), -- (Lt) GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI + (16#01FFD#, 16#01FFE#), -- (Sk) GREEK OXIA .. GREEK DASIA + (16#02000#, 16#0200B#), -- (Zs) EN QUAD .. ZERO WIDTH SPACE + (16#0200C#, 16#0200F#), -- (Cf) ZERO WIDTH NON-JOINER .. RIGHT-TO-LEFT MARK + (16#02010#, 16#02015#), -- (Pd) HYPHEN .. HORIZONTAL BAR + (16#02016#, 16#02017#), -- (Po) DOUBLE VERTICAL LINE .. DOUBLE LOW LINE + (16#02018#, 16#02018#), -- (Pi) LEFT SINGLE QUOTATION MARK .. LEFT SINGLE QUOTATION MARK + (16#02019#, 16#02019#), -- (Pf) RIGHT SINGLE QUOTATION MARK .. RIGHT SINGLE QUOTATION MARK + (16#0201A#, 16#0201A#), -- (Ps) SINGLE LOW-9 QUOTATION MARK .. SINGLE LOW-9 QUOTATION MARK + (16#0201B#, 16#0201C#), -- (Pi) SINGLE HIGH-REVERSED-9 QUOTATION MARK .. LEFT DOUBLE QUOTATION MARK + (16#0201D#, 16#0201D#), -- (Pf) RIGHT DOUBLE QUOTATION MARK .. RIGHT DOUBLE QUOTATION MARK + (16#0201E#, 16#0201E#), -- (Ps) DOUBLE LOW-9 QUOTATION MARK .. DOUBLE LOW-9 QUOTATION MARK + (16#0201F#, 16#0201F#), -- (Pi) DOUBLE HIGH-REVERSED-9 QUOTATION MARK .. DOUBLE HIGH-REVERSED-9 QUOTATION MARK + (16#02020#, 16#02027#), -- (Po) DAGGER .. HYPHENATION POINT + (16#02028#, 16#02028#), -- (Zl) LINE SEPARATOR .. LINE SEPARATOR + (16#02029#, 16#02029#), -- (Zp) PARAGRAPH SEPARATOR .. PARAGRAPH SEPARATOR + (16#0202A#, 16#0202E#), -- (Cf) LEFT-TO-RIGHT EMBEDDING .. RIGHT-TO-LEFT OVERRIDE + (16#0202F#, 16#0202F#), -- (Zs) NARROW NO-BREAK SPACE .. NARROW NO-BREAK SPACE + (16#02030#, 16#02038#), -- (Po) PER MILLE SIGN .. CARET + (16#02039#, 16#02039#), -- (Pi) SINGLE LEFT-POINTING ANGLE QUOTATION MARK .. SINGLE LEFT-POINTING ANGLE QUOTATION MARK + (16#0203A#, 16#0203A#), -- (Pf) SINGLE RIGHT-POINTING ANGLE QUOTATION MARK .. SINGLE RIGHT-POINTING ANGLE QUOTATION MARK + (16#0203B#, 16#0203E#), -- (Po) REFERENCE MARK .. OVERLINE + (16#0203F#, 16#02040#), -- (Pc) UNDERTIE .. CHARACTER TIE + (16#02041#, 16#02043#), -- (Po) CARET INSERTION POINT .. HYPHEN BULLET + (16#02044#, 16#02044#), -- (Sm) FRACTION SLASH .. FRACTION SLASH + (16#02045#, 16#02045#), -- (Ps) LEFT SQUARE BRACKET WITH QUILL .. LEFT SQUARE BRACKET WITH QUILL + (16#02046#, 16#02046#), -- (Pe) RIGHT SQUARE BRACKET WITH QUILL .. RIGHT SQUARE BRACKET WITH QUILL + (16#02047#, 16#02051#), -- (Po) DOUBLE QUESTION MARK .. TWO ASTERISKS ALIGNED VERTICALLY + (16#02052#, 16#02052#), -- (Sm) COMMERCIAL MINUS SIGN .. COMMERCIAL MINUS SIGN + (16#02053#, 16#02053#), -- (Po) SWUNG DASH .. SWUNG DASH + (16#02054#, 16#02054#), -- (Pc) INVERTED UNDERTIE .. INVERTED UNDERTIE + (16#02057#, 16#02057#), -- (Po) QUADRUPLE PRIME .. QUADRUPLE PRIME + (16#0205F#, 16#0205F#), -- (Zs) MEDIUM MATHEMATICAL SPACE .. MEDIUM MATHEMATICAL SPACE + (16#02060#, 16#02063#), -- (Cf) WORD JOINER .. INVISIBLE SEPARATOR + (16#0206A#, 16#0206F#), -- (Cf) INHIBIT SYMMETRIC SWAPPING .. NOMINAL DIGIT SHAPES + (16#02070#, 16#02070#), -- (No) SUPERSCRIPT ZERO .. SUPERSCRIPT ZERO + (16#02071#, 16#02071#), -- (Ll) SUPERSCRIPT LATIN SMALL LETTER I .. SUPERSCRIPT LATIN SMALL LETTER I + (16#02074#, 16#02079#), -- (No) SUPERSCRIPT FOUR .. SUPERSCRIPT NINE + (16#0207A#, 16#0207C#), -- (Sm) SUPERSCRIPT PLUS SIGN .. SUPERSCRIPT EQUALS SIGN + (16#0207D#, 16#0207D#), -- (Ps) SUPERSCRIPT LEFT PARENTHESIS .. SUPERSCRIPT LEFT PARENTHESIS + (16#0207E#, 16#0207E#), -- (Pe) SUPERSCRIPT RIGHT PARENTHESIS .. SUPERSCRIPT RIGHT PARENTHESIS + (16#0207F#, 16#0207F#), -- (Ll) SUPERSCRIPT LATIN SMALL LETTER N .. SUPERSCRIPT LATIN SMALL LETTER N + (16#02080#, 16#02089#), -- (No) SUBSCRIPT ZERO .. SUBSCRIPT NINE + (16#0208A#, 16#0208C#), -- (Sm) SUBSCRIPT PLUS SIGN .. SUBSCRIPT EQUALS SIGN + (16#0208D#, 16#0208D#), -- (Ps) SUBSCRIPT LEFT PARENTHESIS .. SUBSCRIPT LEFT PARENTHESIS + (16#0208E#, 16#0208E#), -- (Pe) SUBSCRIPT RIGHT PARENTHESIS .. SUBSCRIPT RIGHT PARENTHESIS + (16#020A0#, 16#020B1#), -- (Sc) EURO-CURRENCY SIGN .. PESO SIGN + (16#020D0#, 16#020DC#), -- (Mn) COMBINING LEFT HARPOON ABOVE .. COMBINING FOUR DOTS ABOVE + (16#020DD#, 16#020E0#), -- (Me) COMBINING ENCLOSING CIRCLE .. COMBINING ENCLOSING CIRCLE BACKSLASH + (16#020E1#, 16#020E1#), -- (Mn) COMBINING LEFT RIGHT ARROW ABOVE .. COMBINING LEFT RIGHT ARROW ABOVE + (16#020E2#, 16#020E4#), -- (Me) COMBINING ENCLOSING SCREEN .. COMBINING ENCLOSING UPWARD POINTING TRIANGLE + (16#020E5#, 16#020EA#), -- (Mn) COMBINING REVERSE SOLIDUS OVERLAY .. COMBINING LEFTWARDS ARROW OVERLAY + (16#02100#, 16#02101#), -- (So) ACCOUNT OF .. ADDRESSED TO THE SUBJECT + (16#02102#, 16#02102#), -- (Lu) DOUBLE-STRUCK CAPITAL C .. DOUBLE-STRUCK CAPITAL C + (16#02103#, 16#02106#), -- (So) DEGREE CELSIUS .. CADA UNA + (16#02107#, 16#02107#), -- (Lu) EULER CONSTANT .. EULER CONSTANT + (16#02108#, 16#02109#), -- (So) SCRUPLE .. DEGREE FAHRENHEIT + (16#0210A#, 16#0210A#), -- (Ll) SCRIPT SMALL G .. SCRIPT SMALL G + (16#0210B#, 16#0210D#), -- (Lu) SCRIPT CAPITAL H .. DOUBLE-STRUCK CAPITAL H + (16#0210E#, 16#0210F#), -- (Ll) PLANCK CONSTANT .. PLANCK CONSTANT OVER TWO PI + (16#02110#, 16#02112#), -- (Lu) SCRIPT CAPITAL I .. SCRIPT CAPITAL L + (16#02113#, 16#02113#), -- (Ll) SCRIPT SMALL L .. SCRIPT SMALL L + (16#02114#, 16#02114#), -- (So) L B BAR SYMBOL .. L B BAR SYMBOL + (16#02115#, 16#02115#), -- (Lu) DOUBLE-STRUCK CAPITAL N .. DOUBLE-STRUCK CAPITAL N + (16#02116#, 16#02118#), -- (So) NUMERO SIGN .. SCRIPT CAPITAL P + (16#02119#, 16#0211D#), -- (Lu) DOUBLE-STRUCK CAPITAL P .. DOUBLE-STRUCK CAPITAL R + (16#0211E#, 16#02123#), -- (So) PRESCRIPTION TAKE .. VERSICLE + (16#02124#, 16#02124#), -- (Lu) DOUBLE-STRUCK CAPITAL Z .. DOUBLE-STRUCK CAPITAL Z + (16#02125#, 16#02125#), -- (So) OUNCE SIGN .. OUNCE SIGN + (16#02126#, 16#02126#), -- (Lu) OHM SIGN .. OHM SIGN + (16#02127#, 16#02127#), -- (So) INVERTED OHM SIGN .. INVERTED OHM SIGN + (16#02128#, 16#02128#), -- (Lu) BLACK-LETTER CAPITAL Z .. BLACK-LETTER CAPITAL Z + (16#02129#, 16#02129#), -- (So) TURNED GREEK SMALL LETTER IOTA .. TURNED GREEK SMALL LETTER IOTA + (16#0212A#, 16#0212D#), -- (Lu) KELVIN SIGN .. BLACK-LETTER CAPITAL C + (16#0212E#, 16#0212E#), -- (So) ESTIMATED SYMBOL .. ESTIMATED SYMBOL + (16#0212F#, 16#0212F#), -- (Ll) SCRIPT SMALL E .. SCRIPT SMALL E + (16#02130#, 16#02131#), -- (Lu) SCRIPT CAPITAL E .. SCRIPT CAPITAL F + (16#02132#, 16#02132#), -- (So) TURNED CAPITAL F .. TURNED CAPITAL F + (16#02133#, 16#02133#), -- (Lu) SCRIPT CAPITAL M .. SCRIPT CAPITAL M + (16#02134#, 16#02134#), -- (Ll) SCRIPT SMALL O .. SCRIPT SMALL O + (16#02135#, 16#02138#), -- (Lo) ALEF SYMBOL .. DALET SYMBOL + (16#02139#, 16#02139#), -- (Ll) INFORMATION SOURCE .. INFORMATION SOURCE + (16#0213A#, 16#0213B#), -- (So) ROTATED CAPITAL Q .. FACSIMILE SIGN + (16#0213D#, 16#0213D#), -- (Ll) DOUBLE-STRUCK SMALL GAMMA .. DOUBLE-STRUCK SMALL GAMMA + (16#0213E#, 16#0213F#), -- (Lu) DOUBLE-STRUCK CAPITAL GAMMA .. DOUBLE-STRUCK CAPITAL PI + (16#02140#, 16#02144#), -- (Sm) DOUBLE-STRUCK N-ARY SUMMATION .. TURNED SANS-SERIF CAPITAL Y + (16#02145#, 16#02145#), -- (Lu) DOUBLE-STRUCK ITALIC CAPITAL D .. DOUBLE-STRUCK ITALIC CAPITAL D + (16#02146#, 16#02149#), -- (Ll) DOUBLE-STRUCK ITALIC SMALL D .. DOUBLE-STRUCK ITALIC SMALL J + (16#0214A#, 16#0214A#), -- (So) PROPERTY LINE .. PROPERTY LINE + (16#0214B#, 16#0214B#), -- (Sm) TURNED AMPERSAND .. TURNED AMPERSAND + (16#02153#, 16#0215F#), -- (No) VULGAR FRACTION ONE THIRD .. FRACTION NUMERATOR ONE + (16#02160#, 16#02183#), -- (Nl) ROMAN NUMERAL ONE .. ROMAN NUMERAL REVERSED ONE HUNDRED + (16#02190#, 16#02194#), -- (Sm) LEFTWARDS ARROW .. LEFT RIGHT ARROW + (16#02195#, 16#02199#), -- (So) UP DOWN ARROW .. SOUTH WEST ARROW + (16#0219A#, 16#0219B#), -- (Sm) LEFTWARDS ARROW WITH STROKE .. RIGHTWARDS ARROW WITH STROKE + (16#0219C#, 16#0219F#), -- (So) LEFTWARDS WAVE ARROW .. UPWARDS TWO HEADED ARROW + (16#021A0#, 16#021A0#), -- (Sm) RIGHTWARDS TWO HEADED ARROW .. RIGHTWARDS TWO HEADED ARROW + (16#021A1#, 16#021A2#), -- (So) DOWNWARDS TWO HEADED ARROW .. LEFTWARDS ARROW WITH TAIL + (16#021A3#, 16#021A3#), -- (Sm) RIGHTWARDS ARROW WITH TAIL .. RIGHTWARDS ARROW WITH TAIL + (16#021A4#, 16#021A5#), -- (So) LEFTWARDS ARROW FROM BAR .. UPWARDS ARROW FROM BAR + (16#021A6#, 16#021A6#), -- (Sm) RIGHTWARDS ARROW FROM BAR .. RIGHTWARDS ARROW FROM BAR + (16#021A7#, 16#021AD#), -- (So) DOWNWARDS ARROW FROM BAR .. LEFT RIGHT WAVE ARROW + (16#021AE#, 16#021AE#), -- (Sm) LEFT RIGHT ARROW WITH STROKE .. LEFT RIGHT ARROW WITH STROKE + (16#021AF#, 16#021CD#), -- (So) DOWNWARDS ZIGZAG ARROW .. LEFTWARDS DOUBLE ARROW WITH STROKE + (16#021CE#, 16#021CF#), -- (Sm) LEFT RIGHT DOUBLE ARROW WITH STROKE .. RIGHTWARDS DOUBLE ARROW WITH STROKE + (16#021D0#, 16#021D1#), -- (So) LEFTWARDS DOUBLE ARROW .. UPWARDS DOUBLE ARROW + (16#021D2#, 16#021D2#), -- (Sm) RIGHTWARDS DOUBLE ARROW .. RIGHTWARDS DOUBLE ARROW + (16#021D3#, 16#021D3#), -- (So) DOWNWARDS DOUBLE ARROW .. DOWNWARDS DOUBLE ARROW + (16#021D4#, 16#021D4#), -- (Sm) LEFT RIGHT DOUBLE ARROW .. LEFT RIGHT DOUBLE ARROW + (16#021D5#, 16#021F3#), -- (So) UP DOWN DOUBLE ARROW .. UP DOWN WHITE ARROW + (16#021F4#, 16#022FF#), -- (Sm) RIGHT ARROW WITH SMALL CIRCLE .. Z NOTATION BAG MEMBERSHIP + (16#02300#, 16#02307#), -- (So) DIAMETER SIGN .. WAVY LINE + (16#02308#, 16#0230B#), -- (Sm) LEFT CEILING .. RIGHT FLOOR + (16#0230C#, 16#0231F#), -- (So) BOTTOM RIGHT CROP .. BOTTOM RIGHT CORNER + (16#02320#, 16#02321#), -- (Sm) TOP HALF INTEGRAL .. BOTTOM HALF INTEGRAL + (16#02322#, 16#02328#), -- (So) FROWN .. KEYBOARD + (16#02329#, 16#02329#), -- (Ps) LEFT-POINTING ANGLE BRACKET .. LEFT-POINTING ANGLE BRACKET + (16#0232A#, 16#0232A#), -- (Pe) RIGHT-POINTING ANGLE BRACKET .. RIGHT-POINTING ANGLE BRACKET + (16#0232B#, 16#0237B#), -- (So) ERASE TO THE LEFT .. NOT CHECK MARK + (16#0237C#, 16#0237C#), -- (Sm) RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW .. RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW + (16#0237D#, 16#0239A#), -- (So) SHOULDERED OPEN BOX .. CLEAR SCREEN SYMBOL + (16#0239B#, 16#023B3#), -- (Sm) LEFT PARENTHESIS UPPER HOOK .. SUMMATION BOTTOM + (16#023B4#, 16#023B4#), -- (Ps) TOP SQUARE BRACKET .. TOP SQUARE BRACKET + (16#023B5#, 16#023B5#), -- (Pe) BOTTOM SQUARE BRACKET .. BOTTOM SQUARE BRACKET + (16#023B6#, 16#023B6#), -- (Po) BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET .. BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET + (16#023B7#, 16#023D0#), -- (So) RADICAL SYMBOL BOTTOM .. VERTICAL LINE EXTENSION + (16#02400#, 16#02426#), -- (So) SYMBOL FOR NULL .. SYMBOL FOR SUBSTITUTE FORM TWO + (16#02440#, 16#0244A#), -- (So) OCR HOOK .. OCR DOUBLE BACKSLASH + (16#02460#, 16#0249B#), -- (No) CIRCLED DIGIT ONE .. NUMBER TWENTY FULL STOP + (16#0249C#, 16#024E9#), -- (So) PARENTHESIZED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z + (16#024EA#, 16#024FF#), -- (No) CIRCLED DIGIT ZERO .. NEGATIVE CIRCLED DIGIT ZERO + (16#02500#, 16#025B6#), -- (So) BOX DRAWINGS LIGHT HORIZONTAL .. BLACK RIGHT-POINTING TRIANGLE + (16#025B7#, 16#025B7#), -- (Sm) WHITE RIGHT-POINTING TRIANGLE .. WHITE RIGHT-POINTING TRIANGLE + (16#025B8#, 16#025C0#), -- (So) BLACK RIGHT-POINTING SMALL TRIANGLE .. BLACK LEFT-POINTING TRIANGLE + (16#025C1#, 16#025C1#), -- (Sm) WHITE LEFT-POINTING TRIANGLE .. WHITE LEFT-POINTING TRIANGLE + (16#025C2#, 16#025F7#), -- (So) BLACK LEFT-POINTING SMALL TRIANGLE .. WHITE CIRCLE WITH UPPER RIGHT QUADRANT + (16#025F8#, 16#025FF#), -- (Sm) UPPER LEFT TRIANGLE .. LOWER RIGHT TRIANGLE + (16#02600#, 16#02617#), -- (So) BLACK SUN WITH RAYS .. BLACK SHOGI PIECE + (16#02619#, 16#0266E#), -- (So) REVERSED ROTATED FLORAL HEART BULLET .. MUSIC NATURAL SIGN + (16#0266F#, 16#0266F#), -- (Sm) MUSIC SHARP SIGN .. MUSIC SHARP SIGN + (16#02670#, 16#0267D#), -- (So) WEST SYRIAC CROSS .. PARTIALLY-RECYCLED PAPER SYMBOL + (16#02680#, 16#02691#), -- (So) DIE FACE-1 .. BLACK FLAG + (16#026A0#, 16#026A1#), -- (So) WARNING SIGN .. HIGH VOLTAGE SIGN + (16#02701#, 16#02704#), -- (So) UPPER BLADE SCISSORS .. WHITE SCISSORS + (16#02706#, 16#02709#), -- (So) TELEPHONE LOCATION SIGN .. ENVELOPE + (16#0270C#, 16#02727#), -- (So) VICTORY HAND .. WHITE FOUR POINTED STAR + (16#02729#, 16#0274B#), -- (So) STRESS OUTLINED WHITE STAR .. HEAVY EIGHT TEARDROP-SPOKED PROPELLER ASTERISK + (16#0274D#, 16#0274D#), -- (So) SHADOWED WHITE CIRCLE .. SHADOWED WHITE CIRCLE + (16#0274F#, 16#02752#), -- (So) LOWER RIGHT DROP-SHADOWED WHITE SQUARE .. UPPER RIGHT SHADOWED WHITE SQUARE + (16#02756#, 16#02756#), -- (So) BLACK DIAMOND MINUS WHITE X .. BLACK DIAMOND MINUS WHITE X + (16#02758#, 16#0275E#), -- (So) LIGHT VERTICAL BAR .. HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT + (16#02761#, 16#02767#), -- (So) CURVED STEM PARAGRAPH SIGN ORNAMENT .. ROTATED FLORAL HEART BULLET + (16#02768#, 16#02768#), -- (Ps) MEDIUM LEFT PARENTHESIS ORNAMENT .. MEDIUM LEFT PARENTHESIS ORNAMENT + (16#02769#, 16#02769#), -- (Pe) MEDIUM RIGHT PARENTHESIS ORNAMENT .. MEDIUM RIGHT PARENTHESIS ORNAMENT + (16#0276A#, 16#0276A#), -- (Ps) MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT + (16#0276B#, 16#0276B#), -- (Pe) MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT + (16#0276C#, 16#0276C#), -- (Ps) MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT + (16#0276D#, 16#0276D#), -- (Pe) MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT + (16#0276E#, 16#0276E#), -- (Ps) HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT + (16#0276F#, 16#0276F#), -- (Pe) HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT + (16#02770#, 16#02770#), -- (Ps) HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT + (16#02771#, 16#02771#), -- (Pe) HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT + (16#02772#, 16#02772#), -- (Ps) LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT + (16#02773#, 16#02773#), -- (Pe) LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT + (16#02774#, 16#02774#), -- (Ps) MEDIUM LEFT CURLY BRACKET ORNAMENT .. MEDIUM LEFT CURLY BRACKET ORNAMENT + (16#02775#, 16#02775#), -- (Pe) MEDIUM RIGHT CURLY BRACKET ORNAMENT .. MEDIUM RIGHT CURLY BRACKET ORNAMENT + (16#02776#, 16#02793#), -- (No) DINGBAT NEGATIVE CIRCLED DIGIT ONE .. DINGBAT NEGATIVE CIRCLED SANS-SERIF NUMBER TEN + (16#02794#, 16#02794#), -- (So) HEAVY WIDE-HEADED RIGHTWARDS ARROW .. HEAVY WIDE-HEADED RIGHTWARDS ARROW + (16#02798#, 16#027AF#), -- (So) HEAVY SOUTH EAST ARROW .. NOTCHED LOWER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW + (16#027B1#, 16#027BE#), -- (So) NOTCHED UPPER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW .. OPEN-OUTLINED RIGHTWARDS ARROW + (16#027D0#, 16#027E5#), -- (Sm) WHITE DIAMOND WITH CENTRED DOT .. WHITE SQUARE WITH RIGHTWARDS TICK + (16#027E6#, 16#027E6#), -- (Ps) MATHEMATICAL LEFT WHITE SQUARE BRACKET .. MATHEMATICAL LEFT WHITE SQUARE BRACKET + (16#027E7#, 16#027E7#), -- (Pe) MATHEMATICAL RIGHT WHITE SQUARE BRACKET .. MATHEMATICAL RIGHT WHITE SQUARE BRACKET + (16#027E8#, 16#027E8#), -- (Ps) MATHEMATICAL LEFT ANGLE BRACKET .. MATHEMATICAL LEFT ANGLE BRACKET + (16#027E9#, 16#027E9#), -- (Pe) MATHEMATICAL RIGHT ANGLE BRACKET .. MATHEMATICAL RIGHT ANGLE BRACKET + (16#027EA#, 16#027EA#), -- (Ps) MATHEMATICAL LEFT DOUBLE ANGLE BRACKET .. MATHEMATICAL LEFT DOUBLE ANGLE BRACKET + (16#027EB#, 16#027EB#), -- (Pe) MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET .. MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET + (16#027F0#, 16#027FF#), -- (Sm) UPWARDS QUADRUPLE ARROW .. LONG RIGHTWARDS SQUIGGLE ARROW + (16#02800#, 16#028FF#), -- (So) BRAILLE PATTERN BLANK .. BRAILLE PATTERN DOTS-12345678 + (16#02900#, 16#02982#), -- (Sm) RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE .. Z NOTATION TYPE COLON + (16#02983#, 16#02983#), -- (Ps) LEFT WHITE CURLY BRACKET .. LEFT WHITE CURLY BRACKET + (16#02984#, 16#02984#), -- (Pe) RIGHT WHITE CURLY BRACKET .. RIGHT WHITE CURLY BRACKET + (16#02985#, 16#02985#), -- (Ps) LEFT WHITE PARENTHESIS .. LEFT WHITE PARENTHESIS + (16#02986#, 16#02986#), -- (Pe) RIGHT WHITE PARENTHESIS .. RIGHT WHITE PARENTHESIS + (16#02987#, 16#02987#), -- (Ps) Z NOTATION LEFT IMAGE BRACKET .. Z NOTATION LEFT IMAGE BRACKET + (16#02988#, 16#02988#), -- (Pe) Z NOTATION RIGHT IMAGE BRACKET .. Z NOTATION RIGHT IMAGE BRACKET + (16#02989#, 16#02989#), -- (Ps) Z NOTATION LEFT BINDING BRACKET .. Z NOTATION LEFT BINDING BRACKET + (16#0298A#, 16#0298A#), -- (Pe) Z NOTATION RIGHT BINDING BRACKET .. Z NOTATION RIGHT BINDING BRACKET + (16#0298B#, 16#0298B#), -- (Ps) LEFT SQUARE BRACKET WITH UNDERBAR .. LEFT SQUARE BRACKET WITH UNDERBAR + (16#0298C#, 16#0298C#), -- (Pe) RIGHT SQUARE BRACKET WITH UNDERBAR .. RIGHT SQUARE BRACKET WITH UNDERBAR + (16#0298D#, 16#0298D#), -- (Ps) LEFT SQUARE BRACKET WITH TICK IN TOP CORNER .. LEFT SQUARE BRACKET WITH TICK IN TOP CORNER + (16#0298E#, 16#0298E#), -- (Pe) RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER + (16#0298F#, 16#0298F#), -- (Ps) LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER + (16#02990#, 16#02990#), -- (Pe) RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER .. RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER + (16#02991#, 16#02991#), -- (Ps) LEFT ANGLE BRACKET WITH DOT .. LEFT ANGLE BRACKET WITH DOT + (16#02992#, 16#02992#), -- (Pe) RIGHT ANGLE BRACKET WITH DOT .. RIGHT ANGLE BRACKET WITH DOT + (16#02993#, 16#02993#), -- (Ps) LEFT ARC LESS-THAN BRACKET .. LEFT ARC LESS-THAN BRACKET + (16#02994#, 16#02994#), -- (Pe) RIGHT ARC GREATER-THAN BRACKET .. RIGHT ARC GREATER-THAN BRACKET + (16#02995#, 16#02995#), -- (Ps) DOUBLE LEFT ARC GREATER-THAN BRACKET .. DOUBLE LEFT ARC GREATER-THAN BRACKET + (16#02996#, 16#02996#), -- (Pe) DOUBLE RIGHT ARC LESS-THAN BRACKET .. DOUBLE RIGHT ARC LESS-THAN BRACKET + (16#02997#, 16#02997#), -- (Ps) LEFT BLACK TORTOISE SHELL BRACKET .. LEFT BLACK TORTOISE SHELL BRACKET + (16#02998#, 16#02998#), -- (Pe) RIGHT BLACK TORTOISE SHELL BRACKET .. RIGHT BLACK TORTOISE SHELL BRACKET + (16#02999#, 16#029D7#), -- (Sm) DOTTED FENCE .. BLACK HOURGLASS + (16#029D8#, 16#029D8#), -- (Ps) LEFT WIGGLY FENCE .. LEFT WIGGLY FENCE + (16#029D9#, 16#029D9#), -- (Pe) RIGHT WIGGLY FENCE .. RIGHT WIGGLY FENCE + (16#029DA#, 16#029DA#), -- (Ps) LEFT DOUBLE WIGGLY FENCE .. LEFT DOUBLE WIGGLY FENCE + (16#029DB#, 16#029DB#), -- (Pe) RIGHT DOUBLE WIGGLY FENCE .. RIGHT DOUBLE WIGGLY FENCE + (16#029DC#, 16#029FB#), -- (Sm) INCOMPLETE INFINITY .. TRIPLE PLUS + (16#029FC#, 16#029FC#), -- (Ps) LEFT-POINTING CURVED ANGLE BRACKET .. LEFT-POINTING CURVED ANGLE BRACKET + (16#029FD#, 16#029FD#), -- (Pe) RIGHT-POINTING CURVED ANGLE BRACKET .. RIGHT-POINTING CURVED ANGLE BRACKET + (16#029FE#, 16#02AFF#), -- (Sm) TINY .. N-ARY WHITE VERTICAL BAR + (16#02B00#, 16#02B0D#), -- (So) NORTH EAST WHITE ARROW .. UP DOWN BLACK ARROW + (16#02E80#, 16#02E99#), -- (So) CJK RADICAL REPEAT .. CJK RADICAL RAP + (16#02E9B#, 16#02EF3#), -- (So) CJK RADICAL CHOKE .. CJK RADICAL C-SIMPLIFIED TURTLE + (16#02F00#, 16#02FD5#), -- (So) KANGXI RADICAL ONE .. KANGXI RADICAL FLUTE + (16#02FF0#, 16#02FFB#), -- (So) IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT .. IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID + (16#03000#, 16#03000#), -- (Zs) IDEOGRAPHIC SPACE .. IDEOGRAPHIC SPACE + (16#03001#, 16#03003#), -- (Po) IDEOGRAPHIC COMMA .. DITTO MARK + (16#03004#, 16#03004#), -- (So) JAPANESE INDUSTRIAL STANDARD SYMBOL .. JAPANESE INDUSTRIAL STANDARD SYMBOL + (16#03005#, 16#03005#), -- (Lm) IDEOGRAPHIC ITERATION MARK .. IDEOGRAPHIC ITERATION MARK + (16#03006#, 16#03006#), -- (Lo) IDEOGRAPHIC CLOSING MARK .. IDEOGRAPHIC CLOSING MARK + (16#03007#, 16#03007#), -- (Nl) IDEOGRAPHIC NUMBER ZERO .. IDEOGRAPHIC NUMBER ZERO + (16#03008#, 16#03008#), -- (Ps) LEFT ANGLE BRACKET .. LEFT ANGLE BRACKET + (16#03009#, 16#03009#), -- (Pe) RIGHT ANGLE BRACKET .. RIGHT ANGLE BRACKET + (16#0300A#, 16#0300A#), -- (Ps) LEFT DOUBLE ANGLE BRACKET .. LEFT DOUBLE ANGLE BRACKET + (16#0300B#, 16#0300B#), -- (Pe) RIGHT DOUBLE ANGLE BRACKET .. RIGHT DOUBLE ANGLE BRACKET + (16#0300C#, 16#0300C#), -- (Ps) LEFT CORNER BRACKET .. LEFT CORNER BRACKET + (16#0300D#, 16#0300D#), -- (Pe) RIGHT CORNER BRACKET .. RIGHT CORNER BRACKET + (16#0300E#, 16#0300E#), -- (Ps) LEFT WHITE CORNER BRACKET .. LEFT WHITE CORNER BRACKET + (16#0300F#, 16#0300F#), -- (Pe) RIGHT WHITE CORNER BRACKET .. RIGHT WHITE CORNER BRACKET + (16#03010#, 16#03010#), -- (Ps) LEFT BLACK LENTICULAR BRACKET .. LEFT BLACK LENTICULAR BRACKET + (16#03011#, 16#03011#), -- (Pe) RIGHT BLACK LENTICULAR BRACKET .. RIGHT BLACK LENTICULAR BRACKET + (16#03012#, 16#03013#), -- (So) POSTAL MARK .. GETA MARK + (16#03014#, 16#03014#), -- (Ps) LEFT TORTOISE SHELL BRACKET .. LEFT TORTOISE SHELL BRACKET + (16#03015#, 16#03015#), -- (Pe) RIGHT TORTOISE SHELL BRACKET .. RIGHT TORTOISE SHELL BRACKET + (16#03016#, 16#03016#), -- (Ps) LEFT WHITE LENTICULAR BRACKET .. LEFT WHITE LENTICULAR BRACKET + (16#03017#, 16#03017#), -- (Pe) RIGHT WHITE LENTICULAR BRACKET .. RIGHT WHITE LENTICULAR BRACKET + (16#03018#, 16#03018#), -- (Ps) LEFT WHITE TORTOISE SHELL BRACKET .. LEFT WHITE TORTOISE SHELL BRACKET + (16#03019#, 16#03019#), -- (Pe) RIGHT WHITE TORTOISE SHELL BRACKET .. RIGHT WHITE TORTOISE SHELL BRACKET + (16#0301A#, 16#0301A#), -- (Ps) LEFT WHITE SQUARE BRACKET .. LEFT WHITE SQUARE BRACKET + (16#0301B#, 16#0301B#), -- (Pe) RIGHT WHITE SQUARE BRACKET .. RIGHT WHITE SQUARE BRACKET + (16#0301C#, 16#0301C#), -- (Pd) WAVE DASH .. WAVE DASH + (16#0301D#, 16#0301D#), -- (Ps) REVERSED DOUBLE PRIME QUOTATION MARK .. REVERSED DOUBLE PRIME QUOTATION MARK + (16#0301E#, 16#0301F#), -- (Pe) DOUBLE PRIME QUOTATION MARK .. LOW DOUBLE PRIME QUOTATION MARK + (16#03020#, 16#03020#), -- (So) POSTAL MARK FACE .. POSTAL MARK FACE + (16#03021#, 16#03029#), -- (Nl) HANGZHOU NUMERAL ONE .. HANGZHOU NUMERAL NINE + (16#0302A#, 16#0302F#), -- (Mn) IDEOGRAPHIC LEVEL TONE MARK .. HANGUL DOUBLE DOT TONE MARK + (16#03030#, 16#03030#), -- (Pd) WAVY DASH .. WAVY DASH + (16#03031#, 16#03035#), -- (Lm) VERTICAL KANA REPEAT MARK .. VERTICAL KANA REPEAT MARK LOWER HALF + (16#03036#, 16#03037#), -- (So) CIRCLED POSTAL MARK .. IDEOGRAPHIC TELEGRAPH LINE FEED SEPARATOR SYMBOL + (16#03038#, 16#0303A#), -- (Nl) HANGZHOU NUMERAL TEN .. HANGZHOU NUMERAL THIRTY + (16#0303B#, 16#0303B#), -- (Lm) VERTICAL IDEOGRAPHIC ITERATION MARK .. VERTICAL IDEOGRAPHIC ITERATION MARK + (16#0303C#, 16#0303C#), -- (Lo) MASU MARK .. MASU MARK + (16#0303D#, 16#0303D#), -- (Po) PART ALTERNATION MARK .. PART ALTERNATION MARK + (16#0303E#, 16#0303F#), -- (So) IDEOGRAPHIC VARIATION INDICATOR .. IDEOGRAPHIC HALF FILL SPACE + (16#03041#, 16#03096#), -- (Lo) HIRAGANA LETTER SMALL A .. HIRAGANA LETTER SMALL KE + (16#03099#, 16#0309A#), -- (Mn) COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK .. COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK + (16#0309B#, 16#0309C#), -- (Sk) KATAKANA-HIRAGANA VOICED SOUND MARK .. KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK + (16#0309D#, 16#0309E#), -- (Lm) HIRAGANA ITERATION MARK .. HIRAGANA VOICED ITERATION MARK + (16#0309F#, 16#0309F#), -- (Lo) HIRAGANA DIGRAPH YORI .. HIRAGANA DIGRAPH YORI + (16#030A0#, 16#030A0#), -- (Pd) KATAKANA-HIRAGANA DOUBLE HYPHEN .. KATAKANA-HIRAGANA DOUBLE HYPHEN + (16#030A1#, 16#030FA#), -- (Lo) KATAKANA LETTER SMALL A .. KATAKANA LETTER VO + (16#030FB#, 16#030FB#), -- (Pc) KATAKANA MIDDLE DOT .. KATAKANA MIDDLE DOT + (16#030FC#, 16#030FE#), -- (Lm) KATAKANA-HIRAGANA PROLONGED SOUND MARK .. KATAKANA VOICED ITERATION MARK + (16#030FF#, 16#030FF#), -- (Lo) KATAKANA DIGRAPH KOTO .. KATAKANA DIGRAPH KOTO + (16#03105#, 16#0312C#), -- (Lo) BOPOMOFO LETTER B .. BOPOMOFO LETTER GN + (16#03131#, 16#0318E#), -- (Lo) HANGUL LETTER KIYEOK .. HANGUL LETTER ARAEAE + (16#03190#, 16#03191#), -- (So) IDEOGRAPHIC ANNOTATION LINKING MARK .. IDEOGRAPHIC ANNOTATION REVERSE MARK + (16#03192#, 16#03195#), -- (No) IDEOGRAPHIC ANNOTATION ONE MARK .. IDEOGRAPHIC ANNOTATION FOUR MARK + (16#03196#, 16#0319F#), -- (So) IDEOGRAPHIC ANNOTATION TOP MARK .. IDEOGRAPHIC ANNOTATION MAN MARK + (16#031A0#, 16#031B7#), -- (Lo) BOPOMOFO LETTER BU .. BOPOMOFO FINAL LETTER H + (16#031F0#, 16#031FF#), -- (Lo) KATAKANA LETTER SMALL KU .. KATAKANA LETTER SMALL RO + (16#03200#, 16#0321E#), -- (So) PARENTHESIZED HANGUL KIYEOK .. PARENTHESIZED KOREAN CHARACTER O HU + (16#03220#, 16#03229#), -- (No) PARENTHESIZED IDEOGRAPH ONE .. PARENTHESIZED IDEOGRAPH TEN + (16#0322A#, 16#03243#), -- (So) PARENTHESIZED IDEOGRAPH MOON .. PARENTHESIZED IDEOGRAPH REACH + (16#03250#, 16#03250#), -- (So) PARTNERSHIP SIGN .. PARTNERSHIP SIGN + (16#03251#, 16#0325F#), -- (No) CIRCLED NUMBER TWENTY ONE .. CIRCLED NUMBER THIRTY FIVE + (16#03260#, 16#0327D#), -- (So) CIRCLED HANGUL KIYEOK .. CIRCLED KOREAN CHARACTER JUEUI + (16#0327F#, 16#0327F#), -- (So) KOREAN STANDARD SYMBOL .. KOREAN STANDARD SYMBOL + (16#03280#, 16#03289#), -- (No) CIRCLED IDEOGRAPH ONE .. CIRCLED IDEOGRAPH TEN + (16#0328A#, 16#032B0#), -- (So) CIRCLED IDEOGRAPH MOON .. CIRCLED IDEOGRAPH NIGHT + (16#032B1#, 16#032BF#), -- (No) CIRCLED NUMBER THIRTY SIX .. CIRCLED NUMBER FIFTY + (16#032C0#, 16#032FE#), -- (So) IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY .. CIRCLED KATAKANA WO + (16#03300#, 16#033FF#), -- (So) SQUARE APAATO .. SQUARE GAL + (16#03400#, 16#04DB5#), -- (Lo) .. + (16#04DC0#, 16#04DFF#), -- (So) HEXAGRAM FOR THE CREATIVE HEAVEN .. HEXAGRAM FOR BEFORE COMPLETION + (16#04E00#, 16#09FA5#), -- (Lo) .. + (16#0A000#, 16#0A48C#), -- (Lo) YI SYLLABLE IT .. YI SYLLABLE YYR + (16#0A490#, 16#0A4C6#), -- (So) YI RADICAL QOT .. YI RADICAL KE + (16#0AC00#, 16#0D7A3#), -- (Lo) .. + (16#0D800#, 16#0F8FF#), -- (Cs) .. + (16#0F900#, 16#0FA2D#), -- (Lo) CJK COMPATIBILITY IDEOGRAPH-F900 .. CJK COMPATIBILITY IDEOGRAPH-FA2D + (16#0FA30#, 16#0FA6A#), -- (Lo) CJK COMPATIBILITY IDEOGRAPH-FA30 .. CJK COMPATIBILITY IDEOGRAPH-FA6A + (16#0FB00#, 16#0FB06#), -- (Ll) LATIN SMALL LIGATURE FF .. LATIN SMALL LIGATURE ST + (16#0FB13#, 16#0FB17#), -- (Ll) ARMENIAN SMALL LIGATURE MEN NOW .. ARMENIAN SMALL LIGATURE MEN XEH + (16#0FB1D#, 16#0FB1D#), -- (Lo) HEBREW LETTER YOD WITH HIRIQ .. HEBREW LETTER YOD WITH HIRIQ + (16#0FB1E#, 16#0FB1E#), -- (Mn) HEBREW POINT JUDEO-SPANISH VARIKA .. HEBREW POINT JUDEO-SPANISH VARIKA + (16#0FB1F#, 16#0FB28#), -- (Lo) HEBREW LIGATURE YIDDISH YOD YOD PATAH .. HEBREW LETTER WIDE TAV + (16#0FB29#, 16#0FB29#), -- (Sm) HEBREW LETTER ALTERNATIVE PLUS SIGN .. HEBREW LETTER ALTERNATIVE PLUS SIGN + (16#0FB2A#, 16#0FB36#), -- (Lo) HEBREW LETTER SHIN WITH SHIN DOT .. HEBREW LETTER ZAYIN WITH DAGESH + (16#0FB38#, 16#0FB3C#), -- (Lo) HEBREW LETTER TET WITH DAGESH .. HEBREW LETTER LAMED WITH DAGESH + (16#0FB3E#, 16#0FB3E#), -- (Lo) HEBREW LETTER MEM WITH DAGESH .. HEBREW LETTER MEM WITH DAGESH + (16#0FB40#, 16#0FB41#), -- (Lo) HEBREW LETTER NUN WITH DAGESH .. HEBREW LETTER SAMEKH WITH DAGESH + (16#0FB43#, 16#0FB44#), -- (Lo) HEBREW LETTER FINAL PE WITH DAGESH .. HEBREW LETTER PE WITH DAGESH + (16#0FB46#, 16#0FBB1#), -- (Lo) HEBREW LETTER TSADI WITH DAGESH .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM + (16#0FBD3#, 16#0FD3D#), -- (Lo) ARABIC LETTER NG ISOLATED FORM .. ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM + (16#0FD3E#, 16#0FD3E#), -- (Ps) ORNATE LEFT PARENTHESIS .. ORNATE LEFT PARENTHESIS + (16#0FD3F#, 16#0FD3F#), -- (Pe) ORNATE RIGHT PARENTHESIS .. ORNATE RIGHT PARENTHESIS + (16#0FD50#, 16#0FD8F#), -- (Lo) ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM .. ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM + (16#0FD92#, 16#0FDC7#), -- (Lo) ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM .. ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM + (16#0FDF0#, 16#0FDFB#), -- (Lo) ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM .. ARABIC LIGATURE JALLAJALALOUHOU + (16#0FDFC#, 16#0FDFC#), -- (Sc) RIAL SIGN .. RIAL SIGN + (16#0FDFD#, 16#0FDFD#), -- (So) ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM .. ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM + (16#0FE00#, 16#0FE0F#), -- (Mn) VARIATION SELECTOR-1 .. VARIATION SELECTOR-16 + (16#0FE20#, 16#0FE23#), -- (Mn) COMBINING LIGATURE LEFT HALF .. COMBINING DOUBLE TILDE RIGHT HALF + (16#0FE30#, 16#0FE30#), -- (Po) PRESENTATION FORM FOR VERTICAL TWO DOT LEADER .. PRESENTATION FORM FOR VERTICAL TWO DOT LEADER + (16#0FE31#, 16#0FE32#), -- (Pd) PRESENTATION FORM FOR VERTICAL EM DASH .. PRESENTATION FORM FOR VERTICAL EN DASH + (16#0FE33#, 16#0FE34#), -- (Pc) PRESENTATION FORM FOR VERTICAL LOW LINE .. PRESENTATION FORM FOR VERTICAL WAVY LOW LINE + (16#0FE35#, 16#0FE35#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS + (16#0FE36#, 16#0FE36#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS + (16#0FE37#, 16#0FE37#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET + (16#0FE38#, 16#0FE38#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET + (16#0FE39#, 16#0FE39#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET + (16#0FE3A#, 16#0FE3A#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET + (16#0FE3B#, 16#0FE3B#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET + (16#0FE3C#, 16#0FE3C#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET + (16#0FE3D#, 16#0FE3D#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET + (16#0FE3E#, 16#0FE3E#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET + (16#0FE3F#, 16#0FE3F#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET + (16#0FE40#, 16#0FE40#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET + (16#0FE41#, 16#0FE41#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET + (16#0FE42#, 16#0FE42#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET + (16#0FE43#, 16#0FE43#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET + (16#0FE44#, 16#0FE44#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET + (16#0FE45#, 16#0FE46#), -- (Po) SESAME DOT .. WHITE SESAME DOT + (16#0FE47#, 16#0FE47#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET + (16#0FE48#, 16#0FE48#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET + (16#0FE49#, 16#0FE4C#), -- (Po) DASHED OVERLINE .. DOUBLE WAVY OVERLINE + (16#0FE4D#, 16#0FE4F#), -- (Pc) DASHED LOW LINE .. WAVY LOW LINE + (16#0FE50#, 16#0FE52#), -- (Po) SMALL COMMA .. SMALL FULL STOP + (16#0FE54#, 16#0FE57#), -- (Po) SMALL SEMICOLON .. SMALL EXCLAMATION MARK + (16#0FE58#, 16#0FE58#), -- (Pd) SMALL EM DASH .. SMALL EM DASH + (16#0FE59#, 16#0FE59#), -- (Ps) SMALL LEFT PARENTHESIS .. SMALL LEFT PARENTHESIS + (16#0FE5A#, 16#0FE5A#), -- (Pe) SMALL RIGHT PARENTHESIS .. SMALL RIGHT PARENTHESIS + (16#0FE5B#, 16#0FE5B#), -- (Ps) SMALL LEFT CURLY BRACKET .. SMALL LEFT CURLY BRACKET + (16#0FE5C#, 16#0FE5C#), -- (Pe) SMALL RIGHT CURLY BRACKET .. SMALL RIGHT CURLY BRACKET + (16#0FE5D#, 16#0FE5D#), -- (Ps) SMALL LEFT TORTOISE SHELL BRACKET .. SMALL LEFT TORTOISE SHELL BRACKET + (16#0FE5E#, 16#0FE5E#), -- (Pe) SMALL RIGHT TORTOISE SHELL BRACKET .. SMALL RIGHT TORTOISE SHELL BRACKET + (16#0FE5F#, 16#0FE61#), -- (Po) SMALL NUMBER SIGN .. SMALL ASTERISK + (16#0FE62#, 16#0FE62#), -- (Sm) SMALL PLUS SIGN .. SMALL PLUS SIGN + (16#0FE63#, 16#0FE63#), -- (Pd) SMALL HYPHEN-MINUS .. SMALL HYPHEN-MINUS + (16#0FE64#, 16#0FE66#), -- (Sm) SMALL LESS-THAN SIGN .. SMALL EQUALS SIGN + (16#0FE68#, 16#0FE68#), -- (Po) SMALL REVERSE SOLIDUS .. SMALL REVERSE SOLIDUS + (16#0FE69#, 16#0FE69#), -- (Sc) SMALL DOLLAR SIGN .. SMALL DOLLAR SIGN + (16#0FE6A#, 16#0FE6B#), -- (Po) SMALL PERCENT SIGN .. SMALL COMMERCIAL AT + (16#0FE70#, 16#0FE74#), -- (Lo) ARABIC FATHATAN ISOLATED FORM .. ARABIC KASRATAN ISOLATED FORM + (16#0FE76#, 16#0FEFC#), -- (Lo) ARABIC FATHA ISOLATED FORM .. ARABIC LIGATURE LAM WITH ALEF FINAL FORM + (16#0FEFF#, 16#0FEFF#), -- (Cf) ZERO WIDTH NO-BREAK SPACE .. ZERO WIDTH NO-BREAK SPACE + (16#0FF01#, 16#0FF03#), -- (Po) FULLWIDTH EXCLAMATION MARK .. FULLWIDTH NUMBER SIGN + (16#0FF04#, 16#0FF04#), -- (Sc) FULLWIDTH DOLLAR SIGN .. FULLWIDTH DOLLAR SIGN + (16#0FF05#, 16#0FF07#), -- (Po) FULLWIDTH PERCENT SIGN .. FULLWIDTH APOSTROPHE + (16#0FF08#, 16#0FF08#), -- (Ps) FULLWIDTH LEFT PARENTHESIS .. FULLWIDTH LEFT PARENTHESIS + (16#0FF09#, 16#0FF09#), -- (Pe) FULLWIDTH RIGHT PARENTHESIS .. FULLWIDTH RIGHT PARENTHESIS + (16#0FF0A#, 16#0FF0A#), -- (Po) FULLWIDTH ASTERISK .. FULLWIDTH ASTERISK + (16#0FF0B#, 16#0FF0B#), -- (Sm) FULLWIDTH PLUS SIGN .. FULLWIDTH PLUS SIGN + (16#0FF0C#, 16#0FF0C#), -- (Po) FULLWIDTH COMMA .. FULLWIDTH COMMA + (16#0FF0D#, 16#0FF0D#), -- (Pd) FULLWIDTH HYPHEN-MINUS .. FULLWIDTH HYPHEN-MINUS + (16#0FF0E#, 16#0FF0F#), -- (Po) FULLWIDTH FULL STOP .. FULLWIDTH SOLIDUS + (16#0FF10#, 16#0FF19#), -- (Nd) FULLWIDTH DIGIT ZERO .. FULLWIDTH DIGIT NINE + (16#0FF1A#, 16#0FF1B#), -- (Po) FULLWIDTH COLON .. FULLWIDTH SEMICOLON + (16#0FF1C#, 16#0FF1E#), -- (Sm) FULLWIDTH LESS-THAN SIGN .. FULLWIDTH GREATER-THAN SIGN + (16#0FF1F#, 16#0FF20#), -- (Po) FULLWIDTH QUESTION MARK .. FULLWIDTH COMMERCIAL AT + (16#0FF21#, 16#0FF3A#), -- (Lu) FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z + (16#0FF3B#, 16#0FF3B#), -- (Ps) FULLWIDTH LEFT SQUARE BRACKET .. FULLWIDTH LEFT SQUARE BRACKET + (16#0FF3C#, 16#0FF3C#), -- (Po) FULLWIDTH REVERSE SOLIDUS .. FULLWIDTH REVERSE SOLIDUS + (16#0FF3D#, 16#0FF3D#), -- (Pe) FULLWIDTH RIGHT SQUARE BRACKET .. FULLWIDTH RIGHT SQUARE BRACKET + (16#0FF3E#, 16#0FF3E#), -- (Sk) FULLWIDTH CIRCUMFLEX ACCENT .. FULLWIDTH CIRCUMFLEX ACCENT + (16#0FF3F#, 16#0FF3F#), -- (Pc) FULLWIDTH LOW LINE .. FULLWIDTH LOW LINE + (16#0FF40#, 16#0FF40#), -- (Sk) FULLWIDTH GRAVE ACCENT .. FULLWIDTH GRAVE ACCENT + (16#0FF41#, 16#0FF5A#), -- (Ll) FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z + (16#0FF5B#, 16#0FF5B#), -- (Ps) FULLWIDTH LEFT CURLY BRACKET .. FULLWIDTH LEFT CURLY BRACKET + (16#0FF5C#, 16#0FF5C#), -- (Sm) FULLWIDTH VERTICAL LINE .. FULLWIDTH VERTICAL LINE + (16#0FF5D#, 16#0FF5D#), -- (Pe) FULLWIDTH RIGHT CURLY BRACKET .. FULLWIDTH RIGHT CURLY BRACKET + (16#0FF5E#, 16#0FF5E#), -- (Sm) FULLWIDTH TILDE .. FULLWIDTH TILDE + (16#0FF5F#, 16#0FF5F#), -- (Ps) FULLWIDTH LEFT WHITE PARENTHESIS .. FULLWIDTH LEFT WHITE PARENTHESIS + (16#0FF60#, 16#0FF60#), -- (Pe) FULLWIDTH RIGHT WHITE PARENTHESIS .. FULLWIDTH RIGHT WHITE PARENTHESIS + (16#0FF61#, 16#0FF61#), -- (Po) HALFWIDTH IDEOGRAPHIC FULL STOP .. HALFWIDTH IDEOGRAPHIC FULL STOP + (16#0FF62#, 16#0FF62#), -- (Ps) HALFWIDTH LEFT CORNER BRACKET .. HALFWIDTH LEFT CORNER BRACKET + (16#0FF63#, 16#0FF63#), -- (Pe) HALFWIDTH RIGHT CORNER BRACKET .. HALFWIDTH RIGHT CORNER BRACKET + (16#0FF64#, 16#0FF64#), -- (Po) HALFWIDTH IDEOGRAPHIC COMMA .. HALFWIDTH IDEOGRAPHIC COMMA + (16#0FF65#, 16#0FF65#), -- (Pc) HALFWIDTH KATAKANA MIDDLE DOT .. HALFWIDTH KATAKANA MIDDLE DOT + (16#0FF66#, 16#0FF6F#), -- (Lo) HALFWIDTH KATAKANA LETTER WO .. HALFWIDTH KATAKANA LETTER SMALL TU + (16#0FF70#, 16#0FF70#), -- (Lm) HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK .. HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK + (16#0FF71#, 16#0FF9D#), -- (Lo) HALFWIDTH KATAKANA LETTER A .. HALFWIDTH KATAKANA LETTER N + (16#0FF9E#, 16#0FF9F#), -- (Lm) HALFWIDTH KATAKANA VOICED SOUND MARK .. HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK + (16#0FFA0#, 16#0FFBE#), -- (Lo) HALFWIDTH HANGUL FILLER .. HALFWIDTH HANGUL LETTER HIEUH + (16#0FFC2#, 16#0FFC7#), -- (Lo) HALFWIDTH HANGUL LETTER A .. HALFWIDTH HANGUL LETTER E + (16#0FFCA#, 16#0FFCF#), -- (Lo) HALFWIDTH HANGUL LETTER YEO .. HALFWIDTH HANGUL LETTER OE + (16#0FFD2#, 16#0FFD7#), -- (Lo) HALFWIDTH HANGUL LETTER YO .. HALFWIDTH HANGUL LETTER YU + (16#0FFDA#, 16#0FFDC#), -- (Lo) HALFWIDTH HANGUL LETTER EU .. HALFWIDTH HANGUL LETTER I + (16#0FFE0#, 16#0FFE1#), -- (Sc) FULLWIDTH CENT SIGN .. FULLWIDTH POUND SIGN + (16#0FFE2#, 16#0FFE2#), -- (Sm) FULLWIDTH NOT SIGN .. FULLWIDTH NOT SIGN + (16#0FFE3#, 16#0FFE3#), -- (Sk) FULLWIDTH MACRON .. FULLWIDTH MACRON + (16#0FFE4#, 16#0FFE4#), -- (So) FULLWIDTH BROKEN BAR .. FULLWIDTH BROKEN BAR + (16#0FFE5#, 16#0FFE6#), -- (Sc) FULLWIDTH YEN SIGN .. FULLWIDTH WON SIGN + (16#0FFE8#, 16#0FFE8#), -- (So) HALFWIDTH FORMS LIGHT VERTICAL .. HALFWIDTH FORMS LIGHT VERTICAL + (16#0FFE9#, 16#0FFEC#), -- (Sm) HALFWIDTH LEFTWARDS ARROW .. HALFWIDTH DOWNWARDS ARROW + (16#0FFED#, 16#0FFEE#), -- (So) HALFWIDTH BLACK SQUARE .. HALFWIDTH WHITE CIRCLE + (16#0FFF9#, 16#0FFFB#), -- (Cf) INTERLINEAR ANNOTATION ANCHOR .. INTERLINEAR ANNOTATION TERMINATOR + (16#0FFFC#, 16#0FFFD#), -- (So) OBJECT REPLACEMENT CHARACTER .. REPLACEMENT CHARACTER + (16#10000#, 16#1000B#), -- (Lo) LINEAR B SYLLABLE B008 A .. LINEAR B SYLLABLE B046 JE + (16#1000D#, 16#10026#), -- (Lo) LINEAR B SYLLABLE B036 JO .. LINEAR B SYLLABLE B032 QO + (16#10028#, 16#1003A#), -- (Lo) LINEAR B SYLLABLE B060 RA .. LINEAR B SYLLABLE B042 WO + (16#1003C#, 16#1003D#), -- (Lo) LINEAR B SYLLABLE B017 ZA .. LINEAR B SYLLABLE B074 ZE + (16#1003F#, 16#1004D#), -- (Lo) LINEAR B SYLLABLE B020 ZO .. LINEAR B SYLLABLE B091 TWO + (16#10050#, 16#1005D#), -- (Lo) LINEAR B SYMBOL B018 .. LINEAR B SYMBOL B089 + (16#10080#, 16#100FA#), -- (Lo) LINEAR B IDEOGRAM B100 MAN .. LINEAR B IDEOGRAM VESSEL B305 + (16#10100#, 16#10101#), -- (Po) AEGEAN WORD SEPARATOR LINE .. AEGEAN WORD SEPARATOR DOT + (16#10102#, 16#10102#), -- (So) AEGEAN CHECK MARK .. AEGEAN CHECK MARK + (16#10107#, 16#10133#), -- (No) AEGEAN NUMBER ONE .. AEGEAN NUMBER NINETY THOUSAND + (16#10137#, 16#1013F#), -- (So) AEGEAN WEIGHT BASE UNIT .. AEGEAN MEASURE THIRD SUBUNIT + (16#10300#, 16#1031E#), -- (Lo) OLD ITALIC LETTER A .. OLD ITALIC LETTER UU + (16#10320#, 16#10323#), -- (No) OLD ITALIC NUMERAL ONE .. OLD ITALIC NUMERAL FIFTY + (16#10330#, 16#10349#), -- (Lo) GOTHIC LETTER AHSA .. GOTHIC LETTER OTHAL + (16#1034A#, 16#1034A#), -- (Nl) GOTHIC LETTER NINE HUNDRED .. GOTHIC LETTER NINE HUNDRED + (16#10380#, 16#1039D#), -- (Lo) UGARITIC LETTER ALPA .. UGARITIC LETTER SSU + (16#1039F#, 16#1039F#), -- (Po) UGARITIC WORD DIVIDER .. UGARITIC WORD DIVIDER + (16#10400#, 16#10427#), -- (Lu) DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW + (16#10428#, 16#1044F#), -- (Ll) DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW + (16#10450#, 16#1049D#), -- (Lo) SHAVIAN LETTER PEEP .. OSMANYA LETTER OO + (16#104A0#, 16#104A9#), -- (Nd) OSMANYA DIGIT ZERO .. OSMANYA DIGIT NINE + (16#10800#, 16#10805#), -- (Lo) CYPRIOT SYLLABLE A .. CYPRIOT SYLLABLE JA + (16#10808#, 16#10808#), -- (Lo) CYPRIOT SYLLABLE JO .. CYPRIOT SYLLABLE JO + (16#1080A#, 16#10835#), -- (Lo) CYPRIOT SYLLABLE KA .. CYPRIOT SYLLABLE WO + (16#10837#, 16#10838#), -- (Lo) CYPRIOT SYLLABLE XA .. CYPRIOT SYLLABLE XE + (16#1083C#, 16#1083C#), -- (Lo) CYPRIOT SYLLABLE ZA .. CYPRIOT SYLLABLE ZA + (16#1083F#, 16#1083F#), -- (Lo) CYPRIOT SYLLABLE ZO .. CYPRIOT SYLLABLE ZO + (16#1D000#, 16#1D0F5#), -- (So) BYZANTINE MUSICAL SYMBOL PSILI .. BYZANTINE MUSICAL SYMBOL GORGON NEO KATO + (16#1D100#, 16#1D126#), -- (So) MUSICAL SYMBOL SINGLE BARLINE .. MUSICAL SYMBOL DRUM CLEF-2 + (16#1D12A#, 16#1D164#), -- (So) MUSICAL SYMBOL DOUBLE SHARP .. MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE + (16#1D165#, 16#1D166#), -- (Mc) MUSICAL SYMBOL COMBINING STEM .. MUSICAL SYMBOL COMBINING SPRECHGESANG STEM + (16#1D167#, 16#1D169#), -- (Mn) MUSICAL SYMBOL COMBINING TREMOLO-1 .. MUSICAL SYMBOL COMBINING TREMOLO-3 + (16#1D16A#, 16#1D16C#), -- (So) MUSICAL SYMBOL FINGERED TREMOLO-1 .. MUSICAL SYMBOL FINGERED TREMOLO-3 + (16#1D16D#, 16#1D172#), -- (Mc) MUSICAL SYMBOL COMBINING AUGMENTATION DOT .. MUSICAL SYMBOL COMBINING FLAG-5 + (16#1D173#, 16#1D17A#), -- (Cf) MUSICAL SYMBOL BEGIN BEAM .. MUSICAL SYMBOL END PHRASE + (16#1D17B#, 16#1D182#), -- (Mn) MUSICAL SYMBOL COMBINING ACCENT .. MUSICAL SYMBOL COMBINING LOURE + (16#1D183#, 16#1D184#), -- (So) MUSICAL SYMBOL ARPEGGIATO UP .. MUSICAL SYMBOL ARPEGGIATO DOWN + (16#1D185#, 16#1D18B#), -- (Mn) MUSICAL SYMBOL COMBINING DOIT .. MUSICAL SYMBOL COMBINING TRIPLE TONGUE + (16#1D18C#, 16#1D1A9#), -- (So) MUSICAL SYMBOL RINFORZANDO .. MUSICAL SYMBOL DEGREE SLASH + (16#1D1AA#, 16#1D1AD#), -- (Mn) MUSICAL SYMBOL COMBINING DOWN BOW .. MUSICAL SYMBOL COMBINING SNAP PIZZICATO + (16#1D1AE#, 16#1D1DD#), -- (So) MUSICAL SYMBOL PEDAL MARK .. MUSICAL SYMBOL PES SUBPUNCTIS + (16#1D300#, 16#1D356#), -- (So) MONOGRAM FOR EARTH .. TETRAGRAM FOR FOSTERING + (16#1D400#, 16#1D419#), -- (Lu) MATHEMATICAL BOLD CAPITAL A .. MATHEMATICAL BOLD CAPITAL Z + (16#1D41A#, 16#1D433#), -- (Ll) MATHEMATICAL BOLD SMALL A .. MATHEMATICAL BOLD SMALL Z + (16#1D434#, 16#1D44D#), -- (Lu) MATHEMATICAL ITALIC CAPITAL A .. MATHEMATICAL ITALIC CAPITAL Z + (16#1D44E#, 16#1D454#), -- (Ll) MATHEMATICAL ITALIC SMALL A .. MATHEMATICAL ITALIC SMALL G + (16#1D456#, 16#1D467#), -- (Ll) MATHEMATICAL ITALIC SMALL I .. MATHEMATICAL ITALIC SMALL Z + (16#1D468#, 16#1D481#), -- (Lu) MATHEMATICAL BOLD ITALIC CAPITAL A .. MATHEMATICAL BOLD ITALIC CAPITAL Z + (16#1D482#, 16#1D49B#), -- (Ll) MATHEMATICAL BOLD ITALIC SMALL A .. MATHEMATICAL BOLD ITALIC SMALL Z + (16#1D49C#, 16#1D49C#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL A .. MATHEMATICAL SCRIPT CAPITAL A + (16#1D49E#, 16#1D49F#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL C .. MATHEMATICAL SCRIPT CAPITAL D + (16#1D4A2#, 16#1D4A2#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL G .. MATHEMATICAL SCRIPT CAPITAL G + (16#1D4A5#, 16#1D4A6#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL J .. MATHEMATICAL SCRIPT CAPITAL K + (16#1D4A9#, 16#1D4AC#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL N .. MATHEMATICAL SCRIPT CAPITAL Q + (16#1D4AE#, 16#1D4B5#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL S .. MATHEMATICAL SCRIPT CAPITAL Z + (16#1D4B6#, 16#1D4B9#), -- (Ll) MATHEMATICAL SCRIPT SMALL A .. MATHEMATICAL SCRIPT SMALL D + (16#1D4BB#, 16#1D4BB#), -- (Ll) MATHEMATICAL SCRIPT SMALL F .. MATHEMATICAL SCRIPT SMALL F + (16#1D4BD#, 16#1D4C3#), -- (Ll) MATHEMATICAL SCRIPT SMALL H .. MATHEMATICAL SCRIPT SMALL N + (16#1D4C5#, 16#1D4CF#), -- (Ll) MATHEMATICAL SCRIPT SMALL P .. MATHEMATICAL SCRIPT SMALL Z + (16#1D4D0#, 16#1D4E9#), -- (Lu) MATHEMATICAL BOLD SCRIPT CAPITAL A .. MATHEMATICAL BOLD SCRIPT CAPITAL Z + (16#1D4EA#, 16#1D503#), -- (Ll) MATHEMATICAL BOLD SCRIPT SMALL A .. MATHEMATICAL BOLD SCRIPT SMALL Z + (16#1D504#, 16#1D505#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL A .. MATHEMATICAL FRAKTUR CAPITAL B + (16#1D507#, 16#1D50A#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL D .. MATHEMATICAL FRAKTUR CAPITAL G + (16#1D50D#, 16#1D514#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL J .. MATHEMATICAL FRAKTUR CAPITAL Q + (16#1D516#, 16#1D51C#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL S .. MATHEMATICAL FRAKTUR CAPITAL Y + (16#1D51E#, 16#1D537#), -- (Ll) MATHEMATICAL FRAKTUR SMALL A .. MATHEMATICAL FRAKTUR SMALL Z + (16#1D538#, 16#1D539#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL A .. MATHEMATICAL DOUBLE-STRUCK CAPITAL B + (16#1D53B#, 16#1D53E#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL D .. MATHEMATICAL DOUBLE-STRUCK CAPITAL G + (16#1D540#, 16#1D544#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL I .. MATHEMATICAL DOUBLE-STRUCK CAPITAL M + (16#1D546#, 16#1D546#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL O .. MATHEMATICAL DOUBLE-STRUCK CAPITAL O + (16#1D54A#, 16#1D550#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL S .. MATHEMATICAL DOUBLE-STRUCK CAPITAL Y + (16#1D552#, 16#1D56B#), -- (Ll) MATHEMATICAL DOUBLE-STRUCK SMALL A .. MATHEMATICAL DOUBLE-STRUCK SMALL Z + (16#1D56C#, 16#1D585#), -- (Lu) MATHEMATICAL BOLD FRAKTUR CAPITAL A .. MATHEMATICAL BOLD FRAKTUR CAPITAL Z + (16#1D586#, 16#1D59F#), -- (Ll) MATHEMATICAL BOLD FRAKTUR SMALL A .. MATHEMATICAL BOLD FRAKTUR SMALL Z + (16#1D5A0#, 16#1D5B9#), -- (Lu) MATHEMATICAL SANS-SERIF CAPITAL A .. MATHEMATICAL SANS-SERIF CAPITAL Z + (16#1D5BA#, 16#1D5D3#), -- (Ll) MATHEMATICAL SANS-SERIF SMALL A .. MATHEMATICAL SANS-SERIF SMALL Z + (16#1D5D4#, 16#1D5ED#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD CAPITAL Z + (16#1D5EE#, 16#1D607#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD SMALL A .. MATHEMATICAL SANS-SERIF BOLD SMALL Z + (16#1D608#, 16#1D621#), -- (Lu) MATHEMATICAL SANS-SERIF ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF ITALIC CAPITAL Z + (16#1D622#, 16#1D63B#), -- (Ll) MATHEMATICAL SANS-SERIF ITALIC SMALL A .. MATHEMATICAL SANS-SERIF ITALIC SMALL Z + (16#1D63C#, 16#1D655#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL Z + (16#1D656#, 16#1D66F#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL Z + (16#1D670#, 16#1D689#), -- (Lu) MATHEMATICAL MONOSPACE CAPITAL A .. MATHEMATICAL MONOSPACE CAPITAL Z + (16#1D68A#, 16#1D6A3#), -- (Ll) MATHEMATICAL MONOSPACE SMALL A .. MATHEMATICAL MONOSPACE SMALL Z + (16#1D6A8#, 16#1D6C0#), -- (Lu) MATHEMATICAL BOLD CAPITAL ALPHA .. MATHEMATICAL BOLD CAPITAL OMEGA + (16#1D6C1#, 16#1D6C1#), -- (Sm) MATHEMATICAL BOLD NABLA .. MATHEMATICAL BOLD NABLA + (16#1D6C2#, 16#1D6DA#), -- (Ll) MATHEMATICAL BOLD SMALL ALPHA .. MATHEMATICAL BOLD SMALL OMEGA + (16#1D6DB#, 16#1D6DB#), -- (Sm) MATHEMATICAL BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD PARTIAL DIFFERENTIAL + (16#1D6DC#, 16#1D6E1#), -- (Ll) MATHEMATICAL BOLD EPSILON SYMBOL .. MATHEMATICAL BOLD PI SYMBOL + (16#1D6E2#, 16#1D6FA#), -- (Lu) MATHEMATICAL ITALIC CAPITAL ALPHA .. MATHEMATICAL ITALIC CAPITAL OMEGA + (16#1D6FB#, 16#1D6FB#), -- (Sm) MATHEMATICAL ITALIC NABLA .. MATHEMATICAL ITALIC NABLA + (16#1D6FC#, 16#1D714#), -- (Ll) MATHEMATICAL ITALIC SMALL ALPHA .. MATHEMATICAL ITALIC SMALL OMEGA + (16#1D715#, 16#1D715#), -- (Sm) MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL + (16#1D716#, 16#1D71B#), -- (Ll) MATHEMATICAL ITALIC EPSILON SYMBOL .. MATHEMATICAL ITALIC PI SYMBOL + (16#1D71C#, 16#1D734#), -- (Lu) MATHEMATICAL BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL BOLD ITALIC CAPITAL OMEGA + (16#1D735#, 16#1D735#), -- (Sm) MATHEMATICAL BOLD ITALIC NABLA .. MATHEMATICAL BOLD ITALIC NABLA + (16#1D736#, 16#1D74E#), -- (Ll) MATHEMATICAL BOLD ITALIC SMALL ALPHA .. MATHEMATICAL BOLD ITALIC SMALL OMEGA + (16#1D74F#, 16#1D74F#), -- (Sm) MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL + (16#1D750#, 16#1D755#), -- (Ll) MATHEMATICAL BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL BOLD ITALIC PI SYMBOL + (16#1D756#, 16#1D76E#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA + (16#1D76F#, 16#1D76F#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD NABLA .. MATHEMATICAL SANS-SERIF BOLD NABLA + (16#1D770#, 16#1D788#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA + (16#1D789#, 16#1D789#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL + (16#1D78A#, 16#1D78F#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD PI SYMBOL + (16#1D790#, 16#1D7A8#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA + (16#1D7A9#, 16#1D7A9#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA .. MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA + (16#1D7AA#, 16#1D7C2#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA + (16#1D7C3#, 16#1D7C3#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL + (16#1D7C4#, 16#1D7C9#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL + (16#1D7CE#, 16#1D7FF#), -- (Nd) MATHEMATICAL BOLD DIGIT ZERO .. MATHEMATICAL MONOSPACE DIGIT NINE + (16#20000#, 16#2A6D6#), -- (Lo) .. + (16#2F800#, 16#2FA1D#), -- (Lo) CJK COMPATIBILITY IDEOGRAPH-2F800 .. CJK COMPATIBILITY IDEOGRAPH-2FA1D + (16#E0001#, 16#E0001#), -- (Cf) LANGUAGE TAG .. LANGUAGE TAG + (16#E0020#, 16#E007F#), -- (Cf) TAG SPACE .. CANCEL TAG + (16#E0100#, 16#E01EF#), -- (Mn) VARIATION SELECTOR-17 .. VARIATION SELECTOR-256 + (16#F0000#, 16#FFFFD#), -- (Co) .. + (16#100000#, 16#10FFFD#)); -- (Co) .. + + pragma Warnings (Off); + -- Temporary, until pragma at start can be activated ??? + + -- The following array is parallel to the Unicode_Ranges table above. For + -- each entry in the Unicode_Ranges table, there is a corresponding entry + -- in the following table indicating the corresponding unicode category. + + Unicode_Categories : constant array (Unicode_Ranges'Range) of Category := ( + Cc, -- (16#00000#, 16#0001F#) .. + Zs, -- (16#00020#, 16#00020#) SPACE .. SPACE + Po, -- (16#00021#, 16#00023#) EXCLAMATION MARK .. NUMBER SIGN + Sc, -- (16#00024#, 16#00024#) DOLLAR SIGN .. DOLLAR SIGN + Po, -- (16#00025#, 16#00027#) PERCENT SIGN .. APOSTROPHE + Ps, -- (16#00028#, 16#00028#) LEFT PARENTHESIS .. LEFT PARENTHESIS + Pe, -- (16#00029#, 16#00029#) RIGHT PARENTHESIS .. RIGHT PARENTHESIS + Po, -- (16#0002A#, 16#0002A#) ASTERISK .. ASTERISK + Sm, -- (16#0002B#, 16#0002B#) PLUS SIGN .. PLUS SIGN + Po, -- (16#0002C#, 16#0002C#) COMMA .. COMMA + Pd, -- (16#0002D#, 16#0002D#) HYPHEN-MINUS .. HYPHEN-MINUS + Po, -- (16#0002E#, 16#0002F#) FULL STOP .. SOLIDUS + Nd, -- (16#00030#, 16#00039#) DIGIT ZERO .. DIGIT NINE + Po, -- (16#0003A#, 16#0003B#) COLON .. SEMICOLON + Sm, -- (16#0003C#, 16#0003E#) LESS-THAN SIGN .. GREATER-THAN SIGN + Po, -- (16#0003F#, 16#00040#) QUESTION MARK .. COMMERCIAL AT + Lu, -- (16#00041#, 16#0005A#) LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z + Ps, -- (16#0005B#, 16#0005B#) LEFT SQUARE BRACKET .. LEFT SQUARE BRACKET + Po, -- (16#0005C#, 16#0005C#) REVERSE SOLIDUS .. REVERSE SOLIDUS + Pe, -- (16#0005D#, 16#0005D#) RIGHT SQUARE BRACKET .. RIGHT SQUARE BRACKET + Sk, -- (16#0005E#, 16#0005E#) CIRCUMFLEX ACCENT .. CIRCUMFLEX ACCENT + Pc, -- (16#0005F#, 16#0005F#) LOW LINE .. LOW LINE + Sk, -- (16#00060#, 16#00060#) GRAVE ACCENT .. GRAVE ACCENT + Ll, -- (16#00061#, 16#0007A#) LATIN SMALL LETTER A .. LATIN SMALL LETTER Z + Ps, -- (16#0007B#, 16#0007B#) LEFT CURLY BRACKET .. LEFT CURLY BRACKET + Sm, -- (16#0007C#, 16#0007C#) VERTICAL LINE .. VERTICAL LINE + Pe, -- (16#0007D#, 16#0007D#) RIGHT CURLY BRACKET .. RIGHT CURLY BRACKET + Sm, -- (16#0007E#, 16#0007E#) TILDE .. TILDE + Cc, -- (16#0007F#, 16#0009F#) .. + Zs, -- (16#000A0#, 16#000A0#) NO-BREAK SPACE .. NO-BREAK SPACE + Po, -- (16#000A1#, 16#000A1#) INVERTED EXCLAMATION MARK .. INVERTED EXCLAMATION MARK + Sc, -- (16#000A2#, 16#000A5#) CENT SIGN .. YEN SIGN + So, -- (16#000A6#, 16#000A7#) BROKEN BAR .. SECTION SIGN + Sk, -- (16#000A8#, 16#000A8#) DIAERESIS .. DIAERESIS + So, -- (16#000A9#, 16#000A9#) COPYRIGHT SIGN .. COPYRIGHT SIGN + Ll, -- (16#000AA#, 16#000AA#) FEMININE ORDINAL INDICATOR .. FEMININE ORDINAL INDICATOR + Pi, -- (16#000AB#, 16#000AB#) LEFT-POINTING DOUBLE ANGLE QUOTATION MARK .. LEFT-POINTING DOUBLE ANGLE QUOTATION MARK + Sm, -- (16#000AC#, 16#000AC#) NOT SIGN .. NOT SIGN + Cf, -- (16#000AD#, 16#000AD#) SOFT HYPHEN .. SOFT HYPHEN + So, -- (16#000AE#, 16#000AE#) REGISTERED SIGN .. REGISTERED SIGN + Sk, -- (16#000AF#, 16#000AF#) MACRON .. MACRON + So, -- (16#000B0#, 16#000B0#) DEGREE SIGN .. DEGREE SIGN + Sm, -- (16#000B1#, 16#000B1#) PLUS-MINUS SIGN .. PLUS-MINUS SIGN + No, -- (16#000B2#, 16#000B3#) SUPERSCRIPT TWO .. SUPERSCRIPT THREE + Sk, -- (16#000B4#, 16#000B4#) ACUTE ACCENT .. ACUTE ACCENT + Ll, -- (16#000B5#, 16#000B5#) MICRO SIGN .. MICRO SIGN + So, -- (16#000B6#, 16#000B6#) PILCROW SIGN .. PILCROW SIGN + Po, -- (16#000B7#, 16#000B7#) MIDDLE DOT .. MIDDLE DOT + Sk, -- (16#000B8#, 16#000B8#) CEDILLA .. CEDILLA + No, -- (16#000B9#, 16#000B9#) SUPERSCRIPT ONE .. SUPERSCRIPT ONE + Ll, -- (16#000BA#, 16#000BA#) MASCULINE ORDINAL INDICATOR .. MASCULINE ORDINAL INDICATOR + Pf, -- (16#000BB#, 16#000BB#) RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK .. RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK + No, -- (16#000BC#, 16#000BE#) VULGAR FRACTION ONE QUARTER .. VULGAR FRACTION THREE QUARTERS + Po, -- (16#000BF#, 16#000BF#) INVERTED QUESTION MARK .. INVERTED QUESTION MARK + Lu, -- (16#000C0#, 16#000D6#) LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS + Sm, -- (16#000D7#, 16#000D7#) MULTIPLICATION SIGN .. MULTIPLICATION SIGN + Lu, -- (16#000D8#, 16#000DE#) LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN + Ll, -- (16#000DF#, 16#000F6#) LATIN SMALL LETTER SHARP S .. LATIN SMALL LETTER O WITH DIAERESIS + Sm, -- (16#000F7#, 16#000F7#) DIVISION SIGN .. DIVISION SIGN + Ll, -- (16#000F8#, 16#000FF#) LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER Y WITH DIAERESIS + Lu, -- (16#00100#, 16#00100#) LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON + Ll, -- (16#00101#, 16#00101#) LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON + Lu, -- (16#00102#, 16#00102#) LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE + Ll, -- (16#00103#, 16#00103#) LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE + Lu, -- (16#00104#, 16#00104#) LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK + Ll, -- (16#00105#, 16#00105#) LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK + Lu, -- (16#00106#, 16#00106#) LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE + Ll, -- (16#00107#, 16#00107#) LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE + Lu, -- (16#00108#, 16#00108#) LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX + Ll, -- (16#00109#, 16#00109#) LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX + Lu, -- (16#0010A#, 16#0010A#) LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE + Ll, -- (16#0010B#, 16#0010B#) LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE + Lu, -- (16#0010C#, 16#0010C#) LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON + Ll, -- (16#0010D#, 16#0010D#) LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON + Lu, -- (16#0010E#, 16#0010E#) LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON + Ll, -- (16#0010F#, 16#0010F#) LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON + Lu, -- (16#00110#, 16#00110#) LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE + Ll, -- (16#00111#, 16#00111#) LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE + Lu, -- (16#00112#, 16#00112#) LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON + Ll, -- (16#00113#, 16#00113#) LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON + Lu, -- (16#00114#, 16#00114#) LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE + Ll, -- (16#00115#, 16#00115#) LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE + Lu, -- (16#00116#, 16#00116#) LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE + Ll, -- (16#00117#, 16#00117#) LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE + Lu, -- (16#00118#, 16#00118#) LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK + Ll, -- (16#00119#, 16#00119#) LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK + Lu, -- (16#0011A#, 16#0011A#) LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON + Ll, -- (16#0011B#, 16#0011B#) LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON + Lu, -- (16#0011C#, 16#0011C#) LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX + Ll, -- (16#0011D#, 16#0011D#) LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX + Lu, -- (16#0011E#, 16#0011E#) LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE + Ll, -- (16#0011F#, 16#0011F#) LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE + Lu, -- (16#00120#, 16#00120#) LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE + Ll, -- (16#00121#, 16#00121#) LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE + Lu, -- (16#00122#, 16#00122#) LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA + Ll, -- (16#00123#, 16#00123#) LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA + Lu, -- (16#00124#, 16#00124#) LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX + Ll, -- (16#00125#, 16#00125#) LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX + Lu, -- (16#00126#, 16#00126#) LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE + Ll, -- (16#00127#, 16#00127#) LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE + Lu, -- (16#00128#, 16#00128#) LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE + Ll, -- (16#00129#, 16#00129#) LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE + Lu, -- (16#0012A#, 16#0012A#) LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON + Ll, -- (16#0012B#, 16#0012B#) LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON + Lu, -- (16#0012C#, 16#0012C#) LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE + Ll, -- (16#0012D#, 16#0012D#) LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE + Lu, -- (16#0012E#, 16#0012E#) LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK + Ll, -- (16#0012F#, 16#0012F#) LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK + Lu, -- (16#00130#, 16#00130#) LATIN CAPITAL LETTER I WITH DOT ABOVE .. LATIN CAPITAL LETTER I WITH DOT ABOVE + Ll, -- (16#00131#, 16#00131#) LATIN SMALL LETTER DOTLESS I .. LATIN SMALL LETTER DOTLESS I + Lu, -- (16#00132#, 16#00132#) LATIN CAPITAL LIGATURE IJ .. LATIN CAPITAL LIGATURE IJ + Ll, -- (16#00133#, 16#00133#) LATIN SMALL LIGATURE IJ .. LATIN SMALL LIGATURE IJ + Lu, -- (16#00134#, 16#00134#) LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX + Ll, -- (16#00135#, 16#00135#) LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX + Lu, -- (16#00136#, 16#00136#) LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA + Ll, -- (16#00137#, 16#00138#) LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER KRA + Lu, -- (16#00139#, 16#00139#) LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE + Ll, -- (16#0013A#, 16#0013A#) LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE + Lu, -- (16#0013B#, 16#0013B#) LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA + Ll, -- (16#0013C#, 16#0013C#) LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA + Lu, -- (16#0013D#, 16#0013D#) LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON + Ll, -- (16#0013E#, 16#0013E#) LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON + Lu, -- (16#0013F#, 16#0013F#) LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT + Ll, -- (16#00140#, 16#00140#) LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT + Lu, -- (16#00141#, 16#00141#) LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE + Ll, -- (16#00142#, 16#00142#) LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE + Lu, -- (16#00143#, 16#00143#) LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE + Ll, -- (16#00144#, 16#00144#) LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE + Lu, -- (16#00145#, 16#00145#) LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA + Ll, -- (16#00146#, 16#00146#) LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA + Lu, -- (16#00147#, 16#00147#) LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON + Ll, -- (16#00148#, 16#00149#) LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N PRECEDED BY APOSTROPHE + Lu, -- (16#0014A#, 16#0014A#) LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG + Ll, -- (16#0014B#, 16#0014B#) LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG + Lu, -- (16#0014C#, 16#0014C#) LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON + Ll, -- (16#0014D#, 16#0014D#) LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON + Lu, -- (16#0014E#, 16#0014E#) LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE + Ll, -- (16#0014F#, 16#0014F#) LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE + Lu, -- (16#00150#, 16#00150#) LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE + Ll, -- (16#00151#, 16#00151#) LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE + Lu, -- (16#00152#, 16#00152#) LATIN CAPITAL LIGATURE OE .. LATIN CAPITAL LIGATURE OE + Ll, -- (16#00153#, 16#00153#) LATIN SMALL LIGATURE OE .. LATIN SMALL LIGATURE OE + Lu, -- (16#00154#, 16#00154#) LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE + Ll, -- (16#00155#, 16#00155#) LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE + Lu, -- (16#00156#, 16#00156#) LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA + Ll, -- (16#00157#, 16#00157#) LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA + Lu, -- (16#00158#, 16#00158#) LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON + Ll, -- (16#00159#, 16#00159#) LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON + Lu, -- (16#0015A#, 16#0015A#) LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE + Ll, -- (16#0015B#, 16#0015B#) LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE + Lu, -- (16#0015C#, 16#0015C#) LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX + Ll, -- (16#0015D#, 16#0015D#) LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX + Lu, -- (16#0015E#, 16#0015E#) LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA + Ll, -- (16#0015F#, 16#0015F#) LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA + Lu, -- (16#00160#, 16#00160#) LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON + Ll, -- (16#00161#, 16#00161#) LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON + Lu, -- (16#00162#, 16#00162#) LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA + Ll, -- (16#00163#, 16#00163#) LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA + Lu, -- (16#00164#, 16#00164#) LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON + Ll, -- (16#00165#, 16#00165#) LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON + Lu, -- (16#00166#, 16#00166#) LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE + Ll, -- (16#00167#, 16#00167#) LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE + Lu, -- (16#00168#, 16#00168#) LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE + Ll, -- (16#00169#, 16#00169#) LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE + Lu, -- (16#0016A#, 16#0016A#) LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON + Ll, -- (16#0016B#, 16#0016B#) LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON + Lu, -- (16#0016C#, 16#0016C#) LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE + Ll, -- (16#0016D#, 16#0016D#) LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE + Lu, -- (16#0016E#, 16#0016E#) LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE + Ll, -- (16#0016F#, 16#0016F#) LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE + Lu, -- (16#00170#, 16#00170#) LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE + Ll, -- (16#00171#, 16#00171#) LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE + Lu, -- (16#00172#, 16#00172#) LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK + Ll, -- (16#00173#, 16#00173#) LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK + Lu, -- (16#00174#, 16#00174#) LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX + Ll, -- (16#00175#, 16#00175#) LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX + Lu, -- (16#00176#, 16#00176#) LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX + Ll, -- (16#00177#, 16#00177#) LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX + Lu, -- (16#00178#, 16#00179#) LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Z WITH ACUTE + Ll, -- (16#0017A#, 16#0017A#) LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE + Lu, -- (16#0017B#, 16#0017B#) LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE + Ll, -- (16#0017C#, 16#0017C#) LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE + Lu, -- (16#0017D#, 16#0017D#) LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON + Ll, -- (16#0017E#, 16#00180#) LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER B WITH STROKE + Lu, -- (16#00181#, 16#00182#) LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH TOPBAR + Ll, -- (16#00183#, 16#00183#) LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR + Lu, -- (16#00184#, 16#00184#) LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX + Ll, -- (16#00185#, 16#00185#) LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX + Lu, -- (16#00186#, 16#00187#) LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER C WITH HOOK + Ll, -- (16#00188#, 16#00188#) LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK + Lu, -- (16#00189#, 16#0018B#) LATIN CAPITAL LETTER AFRICAN D .. LATIN CAPITAL LETTER D WITH TOPBAR + Ll, -- (16#0018C#, 16#0018D#) LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER TURNED DELTA + Lu, -- (16#0018E#, 16#00191#) LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER F WITH HOOK + Ll, -- (16#00192#, 16#00192#) LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK + Lu, -- (16#00193#, 16#00194#) LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER GAMMA + Ll, -- (16#00195#, 16#00195#) LATIN SMALL LETTER HV .. LATIN SMALL LETTER HV + Lu, -- (16#00196#, 16#00198#) LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER K WITH HOOK + Ll, -- (16#00199#, 16#0019B#) LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER LAMBDA WITH STROKE + Lu, -- (16#0019C#, 16#0019D#) LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER N WITH LEFT HOOK + Ll, -- (16#0019E#, 16#0019E#) LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG + Lu, -- (16#0019F#, 16#001A0#) LATIN CAPITAL LETTER O WITH MIDDLE TILDE .. LATIN CAPITAL LETTER O WITH HORN + Ll, -- (16#001A1#, 16#001A1#) LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN + Lu, -- (16#001A2#, 16#001A2#) LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI + Ll, -- (16#001A3#, 16#001A3#) LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI + Lu, -- (16#001A4#, 16#001A4#) LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK + Ll, -- (16#001A5#, 16#001A5#) LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK + Lu, -- (16#001A6#, 16#001A7#) LATIN LETTER YR .. LATIN CAPITAL LETTER TONE TWO + Ll, -- (16#001A8#, 16#001A8#) LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO + Lu, -- (16#001A9#, 16#001A9#) LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH + Ll, -- (16#001AA#, 16#001AB#) LATIN LETTER REVERSED ESH LOOP .. LATIN SMALL LETTER T WITH PALATAL HOOK + Lu, -- (16#001AC#, 16#001AC#) LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK + Ll, -- (16#001AD#, 16#001AD#) LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK + Lu, -- (16#001AE#, 16#001AF#) LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER U WITH HORN + Ll, -- (16#001B0#, 16#001B0#) LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN + Lu, -- (16#001B1#, 16#001B3#) LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER Y WITH HOOK + Ll, -- (16#001B4#, 16#001B4#) LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK + Lu, -- (16#001B5#, 16#001B5#) LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE + Ll, -- (16#001B6#, 16#001B6#) LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE + Lu, -- (16#001B7#, 16#001B8#) LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH REVERSED + Ll, -- (16#001B9#, 16#001BA#) LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH WITH TAIL + Lo, -- (16#001BB#, 16#001BB#) LATIN LETTER TWO WITH STROKE .. LATIN LETTER TWO WITH STROKE + Lu, -- (16#001BC#, 16#001BC#) LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE + Ll, -- (16#001BD#, 16#001BF#) LATIN SMALL LETTER TONE FIVE .. LATIN LETTER WYNN + Lo, -- (16#001C0#, 16#001C3#) LATIN LETTER DENTAL CLICK .. LATIN LETTER RETROFLEX CLICK + Lu, -- (16#001C4#, 16#001C4#) LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON + Lt, -- (16#001C5#, 16#001C5#) LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON + Ll, -- (16#001C6#, 16#001C6#) LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON + Lu, -- (16#001C7#, 16#001C7#) LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ + Lt, -- (16#001C8#, 16#001C8#) LATIN CAPITAL LETTER L WITH SMALL LETTER J .. LATIN CAPITAL LETTER L WITH SMALL LETTER J + Ll, -- (16#001C9#, 16#001C9#) LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ + Lu, -- (16#001CA#, 16#001CA#) LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ + Lt, -- (16#001CB#, 16#001CB#) LATIN CAPITAL LETTER N WITH SMALL LETTER J .. LATIN CAPITAL LETTER N WITH SMALL LETTER J + Ll, -- (16#001CC#, 16#001CC#) LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ + Lu, -- (16#001CD#, 16#001CD#) LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON + Ll, -- (16#001CE#, 16#001CE#) LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON + Lu, -- (16#001CF#, 16#001CF#) LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON + Ll, -- (16#001D0#, 16#001D0#) LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON + Lu, -- (16#001D1#, 16#001D1#) LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON + Ll, -- (16#001D2#, 16#001D2#) LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON + Lu, -- (16#001D3#, 16#001D3#) LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON + Ll, -- (16#001D4#, 16#001D4#) LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON + Lu, -- (16#001D5#, 16#001D5#) LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON + Ll, -- (16#001D6#, 16#001D6#) LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON + Lu, -- (16#001D7#, 16#001D7#) LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE + Ll, -- (16#001D8#, 16#001D8#) LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE + Lu, -- (16#001D9#, 16#001D9#) LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON + Ll, -- (16#001DA#, 16#001DA#) LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON + Lu, -- (16#001DB#, 16#001DB#) LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE + Ll, -- (16#001DC#, 16#001DD#) LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER TURNED E + Lu, -- (16#001DE#, 16#001DE#) LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON + Ll, -- (16#001DF#, 16#001DF#) LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON + Lu, -- (16#001E0#, 16#001E0#) LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON + Ll, -- (16#001E1#, 16#001E1#) LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON + Lu, -- (16#001E2#, 16#001E2#) LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON + Ll, -- (16#001E3#, 16#001E3#) LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON + Lu, -- (16#001E4#, 16#001E4#) LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE + Ll, -- (16#001E5#, 16#001E5#) LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE + Lu, -- (16#001E6#, 16#001E6#) LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON + Ll, -- (16#001E7#, 16#001E7#) LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON + Lu, -- (16#001E8#, 16#001E8#) LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON + Ll, -- (16#001E9#, 16#001E9#) LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON + Lu, -- (16#001EA#, 16#001EA#) LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK + Ll, -- (16#001EB#, 16#001EB#) LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK + Lu, -- (16#001EC#, 16#001EC#) LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON + Ll, -- (16#001ED#, 16#001ED#) LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON + Lu, -- (16#001EE#, 16#001EE#) LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON + Ll, -- (16#001EF#, 16#001F0#) LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER J WITH CARON + Lu, -- (16#001F1#, 16#001F1#) LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ + Lt, -- (16#001F2#, 16#001F2#) LATIN CAPITAL LETTER D WITH SMALL LETTER Z .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z + Ll, -- (16#001F3#, 16#001F3#) LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ + Lu, -- (16#001F4#, 16#001F4#) LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE + Ll, -- (16#001F5#, 16#001F5#) LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE + Lu, -- (16#001F6#, 16#001F8#) LATIN CAPITAL LETTER HWAIR .. LATIN CAPITAL LETTER N WITH GRAVE + Ll, -- (16#001F9#, 16#001F9#) LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE + Lu, -- (16#001FA#, 16#001FA#) LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE + Ll, -- (16#001FB#, 16#001FB#) LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE + Lu, -- (16#001FC#, 16#001FC#) LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE + Ll, -- (16#001FD#, 16#001FD#) LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE + Lu, -- (16#001FE#, 16#001FE#) LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE + Ll, -- (16#001FF#, 16#001FF#) LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE + Lu, -- (16#00200#, 16#00200#) LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE + Ll, -- (16#00201#, 16#00201#) LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE + Lu, -- (16#00202#, 16#00202#) LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE + Ll, -- (16#00203#, 16#00203#) LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE + Lu, -- (16#00204#, 16#00204#) LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE + Ll, -- (16#00205#, 16#00205#) LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE + Lu, -- (16#00206#, 16#00206#) LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE + Ll, -- (16#00207#, 16#00207#) LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE + Lu, -- (16#00208#, 16#00208#) LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE + Ll, -- (16#00209#, 16#00209#) LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE + Lu, -- (16#0020A#, 16#0020A#) LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE + Ll, -- (16#0020B#, 16#0020B#) LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE + Lu, -- (16#0020C#, 16#0020C#) LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE + Ll, -- (16#0020D#, 16#0020D#) LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE + Lu, -- (16#0020E#, 16#0020E#) LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE + Ll, -- (16#0020F#, 16#0020F#) LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE + Lu, -- (16#00210#, 16#00210#) LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE + Ll, -- (16#00211#, 16#00211#) LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE + Lu, -- (16#00212#, 16#00212#) LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE + Ll, -- (16#00213#, 16#00213#) LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE + Lu, -- (16#00214#, 16#00214#) LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE + Ll, -- (16#00215#, 16#00215#) LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE + Lu, -- (16#00216#, 16#00216#) LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE + Ll, -- (16#00217#, 16#00217#) LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE + Lu, -- (16#00218#, 16#00218#) LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW + Ll, -- (16#00219#, 16#00219#) LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW + Lu, -- (16#0021A#, 16#0021A#) LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW + Ll, -- (16#0021B#, 16#0021B#) LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW + Lu, -- (16#0021C#, 16#0021C#) LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH + Ll, -- (16#0021D#, 16#0021D#) LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH + Lu, -- (16#0021E#, 16#0021E#) LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON + Ll, -- (16#0021F#, 16#0021F#) LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON + Lu, -- (16#00220#, 16#00220#) LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG + Ll, -- (16#00221#, 16#00221#) LATIN SMALL LETTER D WITH CURL .. LATIN SMALL LETTER D WITH CURL + Lu, -- (16#00222#, 16#00222#) LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU + Ll, -- (16#00223#, 16#00223#) LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU + Lu, -- (16#00224#, 16#00224#) LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK + Ll, -- (16#00225#, 16#00225#) LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK + Lu, -- (16#00226#, 16#00226#) LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE + Ll, -- (16#00227#, 16#00227#) LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE + Lu, -- (16#00228#, 16#00228#) LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA + Ll, -- (16#00229#, 16#00229#) LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA + Lu, -- (16#0022A#, 16#0022A#) LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON + Ll, -- (16#0022B#, 16#0022B#) LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON + Lu, -- (16#0022C#, 16#0022C#) LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON + Ll, -- (16#0022D#, 16#0022D#) LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON + Lu, -- (16#0022E#, 16#0022E#) LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE + Ll, -- (16#0022F#, 16#0022F#) LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE + Lu, -- (16#00230#, 16#00230#) LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON + Ll, -- (16#00231#, 16#00231#) LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON + Lu, -- (16#00232#, 16#00232#) LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON + Ll, -- (16#00233#, 16#00236#) LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER T WITH CURL + Ll, -- (16#00250#, 16#002AF#) LATIN SMALL LETTER TURNED A .. LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL + Lm, -- (16#002B0#, 16#002C1#) MODIFIER LETTER SMALL H .. MODIFIER LETTER REVERSED GLOTTAL STOP + Sk, -- (16#002C2#, 16#002C5#) MODIFIER LETTER LEFT ARROWHEAD .. MODIFIER LETTER DOWN ARROWHEAD + Lm, -- (16#002C6#, 16#002D1#) MODIFIER LETTER CIRCUMFLEX ACCENT .. MODIFIER LETTER HALF TRIANGULAR COLON + Sk, -- (16#002D2#, 16#002DF#) MODIFIER LETTER CENTRED RIGHT HALF RING .. MODIFIER LETTER CROSS ACCENT + Lm, -- (16#002E0#, 16#002E4#) MODIFIER LETTER SMALL GAMMA .. MODIFIER LETTER SMALL REVERSED GLOTTAL STOP + Sk, -- (16#002E5#, 16#002ED#) MODIFIER LETTER EXTRA-HIGH TONE BAR .. MODIFIER LETTER UNASPIRATED + Lm, -- (16#002EE#, 16#002EE#) MODIFIER LETTER DOUBLE APOSTROPHE .. MODIFIER LETTER DOUBLE APOSTROPHE + Sk, -- (16#002EF#, 16#002FF#) MODIFIER LETTER LOW DOWN ARROWHEAD .. MODIFIER LETTER LOW LEFT ARROW + Mn, -- (16#00300#, 16#00357#) COMBINING GRAVE ACCENT .. COMBINING RIGHT HALF RING ABOVE + Mn, -- (16#0035D#, 16#0036F#) COMBINING DOUBLE BREVE .. COMBINING LATIN SMALL LETTER X + Sk, -- (16#00374#, 16#00375#) GREEK NUMERAL SIGN .. GREEK LOWER NUMERAL SIGN + Lm, -- (16#0037A#, 16#0037A#) GREEK YPOGEGRAMMENI .. GREEK YPOGEGRAMMENI + Po, -- (16#0037E#, 16#0037E#) GREEK QUESTION MARK .. GREEK QUESTION MARK + Sk, -- (16#00384#, 16#00385#) GREEK TONOS .. GREEK DIALYTIKA TONOS + Lu, -- (16#00386#, 16#00386#) GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS + Po, -- (16#00387#, 16#00387#) GREEK ANO TELEIA .. GREEK ANO TELEIA + Lu, -- (16#00388#, 16#0038A#) GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS + Lu, -- (16#0038C#, 16#0038C#) GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS + Lu, -- (16#0038E#, 16#0038F#) GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS + Ll, -- (16#00390#, 16#00390#) GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS + Lu, -- (16#00391#, 16#003A1#) GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO + Lu, -- (16#003A3#, 16#003AB#) GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA + Ll, -- (16#003AC#, 16#003CE#) GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS + Ll, -- (16#003D0#, 16#003D1#) GREEK BETA SYMBOL .. GREEK THETA SYMBOL + Lu, -- (16#003D2#, 16#003D4#) GREEK UPSILON WITH HOOK SYMBOL .. GREEK UPSILON WITH DIAERESIS AND HOOK SYMBOL + Ll, -- (16#003D5#, 16#003D7#) GREEK PHI SYMBOL .. GREEK KAI SYMBOL + Lu, -- (16#003D8#, 16#003D8#) GREEK LETTER ARCHAIC KOPPA .. GREEK LETTER ARCHAIC KOPPA + Ll, -- (16#003D9#, 16#003D9#) GREEK SMALL LETTER ARCHAIC KOPPA .. GREEK SMALL LETTER ARCHAIC KOPPA + Lu, -- (16#003DA#, 16#003DA#) GREEK LETTER STIGMA .. GREEK LETTER STIGMA + Ll, -- (16#003DB#, 16#003DB#) GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA + Lu, -- (16#003DC#, 16#003DC#) GREEK LETTER DIGAMMA .. GREEK LETTER DIGAMMA + Ll, -- (16#003DD#, 16#003DD#) GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA + Lu, -- (16#003DE#, 16#003DE#) GREEK LETTER KOPPA .. GREEK LETTER KOPPA + Ll, -- (16#003DF#, 16#003DF#) GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA + Lu, -- (16#003E0#, 16#003E0#) GREEK LETTER SAMPI .. GREEK LETTER SAMPI + Ll, -- (16#003E1#, 16#003E1#) GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI + Lu, -- (16#003E2#, 16#003E2#) COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI + Ll, -- (16#003E3#, 16#003E3#) COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI + Lu, -- (16#003E4#, 16#003E4#) COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI + Ll, -- (16#003E5#, 16#003E5#) COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI + Lu, -- (16#003E6#, 16#003E6#) COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI + Ll, -- (16#003E7#, 16#003E7#) COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI + Lu, -- (16#003E8#, 16#003E8#) COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI + Ll, -- (16#003E9#, 16#003E9#) COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI + Lu, -- (16#003EA#, 16#003EA#) COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA + Ll, -- (16#003EB#, 16#003EB#) COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA + Lu, -- (16#003EC#, 16#003EC#) COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA + Ll, -- (16#003ED#, 16#003ED#) COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA + Lu, -- (16#003EE#, 16#003EE#) COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI + Ll, -- (16#003EF#, 16#003F3#) COPTIC SMALL LETTER DEI .. GREEK LETTER YOT + Lu, -- (16#003F4#, 16#003F4#) GREEK CAPITAL THETA SYMBOL .. GREEK CAPITAL THETA SYMBOL + Ll, -- (16#003F5#, 16#003F5#) GREEK LUNATE EPSILON SYMBOL .. GREEK LUNATE EPSILON SYMBOL + Sm, -- (16#003F6#, 16#003F6#) GREEK REVERSED LUNATE EPSILON SYMBOL .. GREEK REVERSED LUNATE EPSILON SYMBOL + Lu, -- (16#003F7#, 16#003F7#) GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO + Ll, -- (16#003F8#, 16#003F8#) GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO + Lu, -- (16#003F9#, 16#003FA#) GREEK CAPITAL LUNATE SIGMA SYMBOL .. GREEK CAPITAL LETTER SAN + Ll, -- (16#003FB#, 16#003FB#) GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN + Lu, -- (16#00400#, 16#0042F#) CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER YA + Ll, -- (16#00430#, 16#0045F#) CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER DZHE + Lu, -- (16#00460#, 16#00460#) CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA + Ll, -- (16#00461#, 16#00461#) CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA + Lu, -- (16#00462#, 16#00462#) CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT + Ll, -- (16#00463#, 16#00463#) CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT + Lu, -- (16#00464#, 16#00464#) CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E + Ll, -- (16#00465#, 16#00465#) CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E + Lu, -- (16#00466#, 16#00466#) CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS + Ll, -- (16#00467#, 16#00467#) CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS + Lu, -- (16#00468#, 16#00468#) CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS + Ll, -- (16#00469#, 16#00469#) CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS + Lu, -- (16#0046A#, 16#0046A#) CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS + Ll, -- (16#0046B#, 16#0046B#) CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS + Lu, -- (16#0046C#, 16#0046C#) CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS + Ll, -- (16#0046D#, 16#0046D#) CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS + Lu, -- (16#0046E#, 16#0046E#) CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI + Ll, -- (16#0046F#, 16#0046F#) CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI + Lu, -- (16#00470#, 16#00470#) CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI + Ll, -- (16#00471#, 16#00471#) CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI + Lu, -- (16#00472#, 16#00472#) CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA + Ll, -- (16#00473#, 16#00473#) CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA + Lu, -- (16#00474#, 16#00474#) CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA + Ll, -- (16#00475#, 16#00475#) CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA + Lu, -- (16#00476#, 16#00476#) CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + Ll, -- (16#00477#, 16#00477#) CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + Lu, -- (16#00478#, 16#00478#) CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK + Ll, -- (16#00479#, 16#00479#) CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK + Lu, -- (16#0047A#, 16#0047A#) CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA + Ll, -- (16#0047B#, 16#0047B#) CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA + Lu, -- (16#0047C#, 16#0047C#) CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO + Ll, -- (16#0047D#, 16#0047D#) CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO + Lu, -- (16#0047E#, 16#0047E#) CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT + Ll, -- (16#0047F#, 16#0047F#) CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT + Lu, -- (16#00480#, 16#00480#) CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA + Ll, -- (16#00481#, 16#00481#) CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA + So, -- (16#00482#, 16#00482#) CYRILLIC THOUSANDS SIGN .. CYRILLIC THOUSANDS SIGN + Mn, -- (16#00483#, 16#00486#) COMBINING CYRILLIC TITLO .. COMBINING CYRILLIC PSILI PNEUMATA + Me, -- (16#00488#, 16#00489#) COMBINING CYRILLIC HUNDRED THOUSANDS SIGN .. COMBINING CYRILLIC MILLIONS SIGN + Lu, -- (16#0048A#, 16#0048A#) CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL + Ll, -- (16#0048B#, 16#0048B#) CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL + Lu, -- (16#0048C#, 16#0048C#) CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN + Ll, -- (16#0048D#, 16#0048D#) CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN + Lu, -- (16#0048E#, 16#0048E#) CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK + Ll, -- (16#0048F#, 16#0048F#) CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK + Lu, -- (16#00490#, 16#00490#) CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN + Ll, -- (16#00491#, 16#00491#) CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN + Lu, -- (16#00492#, 16#00492#) CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE + Ll, -- (16#00493#, 16#00493#) CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE + Lu, -- (16#00494#, 16#00494#) CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK + Ll, -- (16#00495#, 16#00495#) CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK + Lu, -- (16#00496#, 16#00496#) CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER + Ll, -- (16#00497#, 16#00497#) CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER + Lu, -- (16#00498#, 16#00498#) CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER + Ll, -- (16#00499#, 16#00499#) CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER + Lu, -- (16#0049A#, 16#0049A#) CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER + Ll, -- (16#0049B#, 16#0049B#) CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER + Lu, -- (16#0049C#, 16#0049C#) CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE + Ll, -- (16#0049D#, 16#0049D#) CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE + Lu, -- (16#0049E#, 16#0049E#) CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE + Ll, -- (16#0049F#, 16#0049F#) CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE + Lu, -- (16#004A0#, 16#004A0#) CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA + Ll, -- (16#004A1#, 16#004A1#) CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA + Lu, -- (16#004A2#, 16#004A2#) CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER + Ll, -- (16#004A3#, 16#004A3#) CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER + Lu, -- (16#004A4#, 16#004A4#) CYRILLIC CAPITAL LIGATURE EN GHE .. CYRILLIC CAPITAL LIGATURE EN GHE + Ll, -- (16#004A5#, 16#004A5#) CYRILLIC SMALL LIGATURE EN GHE .. CYRILLIC SMALL LIGATURE EN GHE + Lu, -- (16#004A6#, 16#004A6#) CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK + Ll, -- (16#004A7#, 16#004A7#) CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK + Lu, -- (16#004A8#, 16#004A8#) CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA + Ll, -- (16#004A9#, 16#004A9#) CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA + Lu, -- (16#004AA#, 16#004AA#) CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER + Ll, -- (16#004AB#, 16#004AB#) CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER + Lu, -- (16#004AC#, 16#004AC#) CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER + Ll, -- (16#004AD#, 16#004AD#) CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER + Lu, -- (16#004AE#, 16#004AE#) CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U + Ll, -- (16#004AF#, 16#004AF#) CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U + Lu, -- (16#004B0#, 16#004B0#) CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE + Ll, -- (16#004B1#, 16#004B1#) CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE + Lu, -- (16#004B2#, 16#004B2#) CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER + Ll, -- (16#004B3#, 16#004B3#) CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER + Lu, -- (16#004B4#, 16#004B4#) CYRILLIC CAPITAL LIGATURE TE TSE .. CYRILLIC CAPITAL LIGATURE TE TSE + Ll, -- (16#004B5#, 16#004B5#) CYRILLIC SMALL LIGATURE TE TSE .. CYRILLIC SMALL LIGATURE TE TSE + Lu, -- (16#004B6#, 16#004B6#) CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER + Ll, -- (16#004B7#, 16#004B7#) CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER + Lu, -- (16#004B8#, 16#004B8#) CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE + Ll, -- (16#004B9#, 16#004B9#) CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE + Lu, -- (16#004BA#, 16#004BA#) CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA + Ll, -- (16#004BB#, 16#004BB#) CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA + Lu, -- (16#004BC#, 16#004BC#) CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE + Ll, -- (16#004BD#, 16#004BD#) CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE + Lu, -- (16#004BE#, 16#004BE#) CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER + Ll, -- (16#004BF#, 16#004BF#) CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER + Lu, -- (16#004C0#, 16#004C1#) CYRILLIC LETTER PALOCHKA .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE + Ll, -- (16#004C2#, 16#004C2#) CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE + Lu, -- (16#004C3#, 16#004C3#) CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK + Ll, -- (16#004C4#, 16#004C4#) CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK + Lu, -- (16#004C5#, 16#004C5#) CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL + Ll, -- (16#004C6#, 16#004C6#) CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL + Lu, -- (16#004C7#, 16#004C7#) CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK + Ll, -- (16#004C8#, 16#004C8#) CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK + Lu, -- (16#004C9#, 16#004C9#) CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL + Ll, -- (16#004CA#, 16#004CA#) CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL + Lu, -- (16#004CB#, 16#004CB#) CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE + Ll, -- (16#004CC#, 16#004CC#) CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE + Lu, -- (16#004CD#, 16#004CD#) CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL + Ll, -- (16#004CE#, 16#004CE#) CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL + Lu, -- (16#004D0#, 16#004D0#) CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE + Ll, -- (16#004D1#, 16#004D1#) CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE + Lu, -- (16#004D2#, 16#004D2#) CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS + Ll, -- (16#004D3#, 16#004D3#) CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS + Lu, -- (16#004D4#, 16#004D4#) CYRILLIC CAPITAL LIGATURE A IE .. CYRILLIC CAPITAL LIGATURE A IE + Ll, -- (16#004D5#, 16#004D5#) CYRILLIC SMALL LIGATURE A IE .. CYRILLIC SMALL LIGATURE A IE + Lu, -- (16#004D6#, 16#004D6#) CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE + Ll, -- (16#004D7#, 16#004D7#) CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE + Lu, -- (16#004D8#, 16#004D8#) CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA + Ll, -- (16#004D9#, 16#004D9#) CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA + Lu, -- (16#004DA#, 16#004DA#) CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS + Ll, -- (16#004DB#, 16#004DB#) CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS + Lu, -- (16#004DC#, 16#004DC#) CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS + Ll, -- (16#004DD#, 16#004DD#) CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS + Lu, -- (16#004DE#, 16#004DE#) CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS + Ll, -- (16#004DF#, 16#004DF#) CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS + Lu, -- (16#004E0#, 16#004E0#) CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE + Ll, -- (16#004E1#, 16#004E1#) CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE + Lu, -- (16#004E2#, 16#004E2#) CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON + Ll, -- (16#004E3#, 16#004E3#) CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON + Lu, -- (16#004E4#, 16#004E4#) CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS + Ll, -- (16#004E5#, 16#004E5#) CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS + Lu, -- (16#004E6#, 16#004E6#) CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS + Ll, -- (16#004E7#, 16#004E7#) CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS + Lu, -- (16#004E8#, 16#004E8#) CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O + Ll, -- (16#004E9#, 16#004E9#) CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O + Lu, -- (16#004EA#, 16#004EA#) CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS + Ll, -- (16#004EB#, 16#004EB#) CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS + Lu, -- (16#004EC#, 16#004EC#) CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS + Ll, -- (16#004ED#, 16#004ED#) CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS + Lu, -- (16#004EE#, 16#004EE#) CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON + Ll, -- (16#004EF#, 16#004EF#) CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON + Lu, -- (16#004F0#, 16#004F0#) CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS + Ll, -- (16#004F1#, 16#004F1#) CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS + Lu, -- (16#004F2#, 16#004F2#) CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE + Ll, -- (16#004F3#, 16#004F3#) CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE + Lu, -- (16#004F4#, 16#004F4#) CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS + Ll, -- (16#004F5#, 16#004F5#) CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS + Lu, -- (16#004F8#, 16#004F8#) CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS + Ll, -- (16#004F9#, 16#004F9#) CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS + Lu, -- (16#00500#, 16#00500#) CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE + Ll, -- (16#00501#, 16#00501#) CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE + Lu, -- (16#00502#, 16#00502#) CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE + Ll, -- (16#00503#, 16#00503#) CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE + Lu, -- (16#00504#, 16#00504#) CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE + Ll, -- (16#00505#, 16#00505#) CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE + Lu, -- (16#00506#, 16#00506#) CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE + Ll, -- (16#00507#, 16#00507#) CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE + Lu, -- (16#00508#, 16#00508#) CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE + Ll, -- (16#00509#, 16#00509#) CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE + Lu, -- (16#0050A#, 16#0050A#) CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE + Ll, -- (16#0050B#, 16#0050B#) CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE + Lu, -- (16#0050C#, 16#0050C#) CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE + Ll, -- (16#0050D#, 16#0050D#) CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE + Lu, -- (16#0050E#, 16#0050E#) CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE + Ll, -- (16#0050F#, 16#0050F#) CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE + Lu, -- (16#00531#, 16#00556#) ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH + Lm, -- (16#00559#, 16#00559#) ARMENIAN MODIFIER LETTER LEFT HALF RING .. ARMENIAN MODIFIER LETTER LEFT HALF RING + Po, -- (16#0055A#, 16#0055F#) ARMENIAN APOSTROPHE .. ARMENIAN ABBREVIATION MARK + Ll, -- (16#00561#, 16#00587#) ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LIGATURE ECH YIWN + Po, -- (16#00589#, 16#00589#) ARMENIAN FULL STOP .. ARMENIAN FULL STOP + Pd, -- (16#0058A#, 16#0058A#) ARMENIAN HYPHEN .. ARMENIAN HYPHEN + Mn, -- (16#00591#, 16#005A1#) HEBREW ACCENT ETNAHTA .. HEBREW ACCENT PAZER + Mn, -- (16#005A3#, 16#005B9#) HEBREW ACCENT MUNAH .. HEBREW POINT HOLAM + Mn, -- (16#005BB#, 16#005BD#) HEBREW POINT QUBUTS .. HEBREW POINT METEG + Po, -- (16#005BE#, 16#005BE#) HEBREW PUNCTUATION MAQAF .. HEBREW PUNCTUATION MAQAF + Mn, -- (16#005BF#, 16#005BF#) HEBREW POINT RAFE .. HEBREW POINT RAFE + Po, -- (16#005C0#, 16#005C0#) HEBREW PUNCTUATION PASEQ .. HEBREW PUNCTUATION PASEQ + Mn, -- (16#005C1#, 16#005C2#) HEBREW POINT SHIN DOT .. HEBREW POINT SIN DOT + Po, -- (16#005C3#, 16#005C3#) HEBREW PUNCTUATION SOF PASUQ .. HEBREW PUNCTUATION SOF PASUQ + Mn, -- (16#005C4#, 16#005C4#) HEBREW MARK UPPER DOT .. HEBREW MARK UPPER DOT + Lo, -- (16#005D0#, 16#005EA#) HEBREW LETTER ALEF .. HEBREW LETTER TAV + Lo, -- (16#005F0#, 16#005F2#) HEBREW LIGATURE YIDDISH DOUBLE VAV .. HEBREW LIGATURE YIDDISH DOUBLE YOD + Po, -- (16#005F3#, 16#005F4#) HEBREW PUNCTUATION GERESH .. HEBREW PUNCTUATION GERSHAYIM + Cf, -- (16#00600#, 16#00603#) ARABIC NUMBER SIGN .. ARABIC SIGN SAFHA + Po, -- (16#0060C#, 16#0060D#) ARABIC COMMA .. ARABIC DATE SEPARATOR + So, -- (16#0060E#, 16#0060F#) ARABIC POETIC VERSE SIGN .. ARABIC SIGN MISRA + Mn, -- (16#00610#, 16#00615#) ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM .. ARABIC SMALL HIGH TAH + Po, -- (16#0061B#, 16#0061B#) ARABIC SEMICOLON .. ARABIC SEMICOLON + Po, -- (16#0061F#, 16#0061F#) ARABIC QUESTION MARK .. ARABIC QUESTION MARK + Lo, -- (16#00621#, 16#0063A#) ARABIC LETTER HAMZA .. ARABIC LETTER GHAIN + Lm, -- (16#00640#, 16#00640#) ARABIC TATWEEL .. ARABIC TATWEEL + Lo, -- (16#00641#, 16#0064A#) ARABIC LETTER FEH .. ARABIC LETTER YEH + Mn, -- (16#0064B#, 16#00658#) ARABIC FATHATAN .. ARABIC MARK NOON GHUNNA + Nd, -- (16#00660#, 16#00669#) ARABIC-INDIC DIGIT ZERO .. ARABIC-INDIC DIGIT NINE + Po, -- (16#0066A#, 16#0066D#) ARABIC PERCENT SIGN .. ARABIC FIVE POINTED STAR + Lo, -- (16#0066E#, 16#0066F#) ARABIC LETTER DOTLESS BEH .. ARABIC LETTER DOTLESS QAF + Mn, -- (16#00670#, 16#00670#) ARABIC LETTER SUPERSCRIPT ALEF .. ARABIC LETTER SUPERSCRIPT ALEF + Lo, -- (16#00671#, 16#006D3#) ARABIC LETTER ALEF WASLA .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE + Po, -- (16#006D4#, 16#006D4#) ARABIC FULL STOP .. ARABIC FULL STOP + Lo, -- (16#006D5#, 16#006D5#) ARABIC LETTER AE .. ARABIC LETTER AE + Mn, -- (16#006D6#, 16#006DC#) ARABIC SMALL HIGH LIGATURE SAD WITH LAM WITH ALEF MAKSURA .. ARABIC SMALL HIGH SEEN + Cf, -- (16#006DD#, 16#006DD#) ARABIC END OF AYAH .. ARABIC END OF AYAH + Me, -- (16#006DE#, 16#006DE#) ARABIC START OF RUB EL HIZB .. ARABIC START OF RUB EL HIZB + Mn, -- (16#006DF#, 16#006E4#) ARABIC SMALL HIGH ROUNDED ZERO .. ARABIC SMALL HIGH MADDA + Lm, -- (16#006E5#, 16#006E6#) ARABIC SMALL WAW .. ARABIC SMALL YEH + Mn, -- (16#006E7#, 16#006E8#) ARABIC SMALL HIGH YEH .. ARABIC SMALL HIGH NOON + So, -- (16#006E9#, 16#006E9#) ARABIC PLACE OF SAJDAH .. ARABIC PLACE OF SAJDAH + Mn, -- (16#006EA#, 16#006ED#) ARABIC EMPTY CENTRE LOW STOP .. ARABIC SMALL LOW MEEM + Lo, -- (16#006EE#, 16#006EF#) ARABIC LETTER DAL WITH INVERTED V .. ARABIC LETTER REH WITH INVERTED V + Nd, -- (16#006F0#, 16#006F9#) EXTENDED ARABIC-INDIC DIGIT ZERO .. EXTENDED ARABIC-INDIC DIGIT NINE + Lo, -- (16#006FA#, 16#006FC#) ARABIC LETTER SHEEN WITH DOT BELOW .. ARABIC LETTER GHAIN WITH DOT BELOW + So, -- (16#006FD#, 16#006FE#) ARABIC SIGN SINDHI AMPERSAND .. ARABIC SIGN SINDHI POSTPOSITION MEN + Lo, -- (16#006FF#, 16#006FF#) ARABIC LETTER HEH WITH INVERTED V .. ARABIC LETTER HEH WITH INVERTED V + Po, -- (16#00700#, 16#0070D#) SYRIAC END OF PARAGRAPH .. SYRIAC HARKLEAN ASTERISCUS + Cf, -- (16#0070F#, 16#0070F#) SYRIAC ABBREVIATION MARK .. SYRIAC ABBREVIATION MARK + Lo, -- (16#00710#, 16#00710#) SYRIAC LETTER ALAPH .. SYRIAC LETTER ALAPH + Mn, -- (16#00711#, 16#00711#) SYRIAC LETTER SUPERSCRIPT ALAPH .. SYRIAC LETTER SUPERSCRIPT ALAPH + Lo, -- (16#00712#, 16#0072F#) SYRIAC LETTER BETH .. SYRIAC LETTER PERSIAN DHALATH + Mn, -- (16#00730#, 16#0074A#) SYRIAC PTHAHA ABOVE .. SYRIAC BARREKH + Lo, -- (16#0074D#, 16#0074F#) SYRIAC LETTER SOGDIAN ZHAIN .. SYRIAC LETTER SOGDIAN FE + Lo, -- (16#00780#, 16#007A5#) THAANA LETTER HAA .. THAANA LETTER WAAVU + Mn, -- (16#007A6#, 16#007B0#) THAANA ABAFILI .. THAANA SUKUN + Lo, -- (16#007B1#, 16#007B1#) THAANA LETTER NAA .. THAANA LETTER NAA + Mn, -- (16#00901#, 16#00902#) DEVANAGARI SIGN CANDRABINDU .. DEVANAGARI SIGN ANUSVARA + Mc, -- (16#00903#, 16#00903#) DEVANAGARI SIGN VISARGA .. DEVANAGARI SIGN VISARGA + Lo, -- (16#00904#, 16#00939#) DEVANAGARI LETTER SHORT A .. DEVANAGARI LETTER HA + Mn, -- (16#0093C#, 16#0093C#) DEVANAGARI SIGN NUKTA .. DEVANAGARI SIGN NUKTA + Lo, -- (16#0093D#, 16#0093D#) DEVANAGARI SIGN AVAGRAHA .. DEVANAGARI SIGN AVAGRAHA + Mc, -- (16#0093E#, 16#00940#) DEVANAGARI VOWEL SIGN AA .. DEVANAGARI VOWEL SIGN II + Mn, -- (16#00941#, 16#00948#) DEVANAGARI VOWEL SIGN U .. DEVANAGARI VOWEL SIGN AI + Mc, -- (16#00949#, 16#0094C#) DEVANAGARI VOWEL SIGN CANDRA O .. DEVANAGARI VOWEL SIGN AU + Mn, -- (16#0094D#, 16#0094D#) DEVANAGARI SIGN VIRAMA .. DEVANAGARI SIGN VIRAMA + Lo, -- (16#00950#, 16#00950#) DEVANAGARI OM .. DEVANAGARI OM + Mn, -- (16#00951#, 16#00954#) DEVANAGARI STRESS SIGN UDATTA .. DEVANAGARI ACUTE ACCENT + Lo, -- (16#00958#, 16#00961#) DEVANAGARI LETTER QA .. DEVANAGARI LETTER VOCALIC LL + Mn, -- (16#00962#, 16#00963#) DEVANAGARI VOWEL SIGN VOCALIC L .. DEVANAGARI VOWEL SIGN VOCALIC LL + Po, -- (16#00964#, 16#00965#) DEVANAGARI DANDA .. DEVANAGARI DOUBLE DANDA + Nd, -- (16#00966#, 16#0096F#) DEVANAGARI DIGIT ZERO .. DEVANAGARI DIGIT NINE + Po, -- (16#00970#, 16#00970#) DEVANAGARI ABBREVIATION SIGN .. DEVANAGARI ABBREVIATION SIGN + Mn, -- (16#00981#, 16#00981#) BENGALI SIGN CANDRABINDU .. BENGALI SIGN CANDRABINDU + Mc, -- (16#00982#, 16#00983#) BENGALI SIGN ANUSVARA .. BENGALI SIGN VISARGA + Lo, -- (16#00985#, 16#0098C#) BENGALI LETTER A .. BENGALI LETTER VOCALIC L + Lo, -- (16#0098F#, 16#00990#) BENGALI LETTER E .. BENGALI LETTER AI + Lo, -- (16#00993#, 16#009A8#) BENGALI LETTER O .. BENGALI LETTER NA + Lo, -- (16#009AA#, 16#009B0#) BENGALI LETTER PA .. BENGALI LETTER RA + Lo, -- (16#009B2#, 16#009B2#) BENGALI LETTER LA .. BENGALI LETTER LA + Lo, -- (16#009B6#, 16#009B9#) BENGALI LETTER SHA .. BENGALI LETTER HA + Mn, -- (16#009BC#, 16#009BC#) BENGALI SIGN NUKTA .. BENGALI SIGN NUKTA + Lo, -- (16#009BD#, 16#009BD#) BENGALI SIGN AVAGRAHA .. BENGALI SIGN AVAGRAHA + Mc, -- (16#009BE#, 16#009C0#) BENGALI VOWEL SIGN AA .. BENGALI VOWEL SIGN II + Mn, -- (16#009C1#, 16#009C4#) BENGALI VOWEL SIGN U .. BENGALI VOWEL SIGN VOCALIC RR + Mc, -- (16#009C7#, 16#009C8#) BENGALI VOWEL SIGN E .. BENGALI VOWEL SIGN AI + Mc, -- (16#009CB#, 16#009CC#) BENGALI VOWEL SIGN O .. BENGALI VOWEL SIGN AU + Mn, -- (16#009CD#, 16#009CD#) BENGALI SIGN VIRAMA .. BENGALI SIGN VIRAMA + Mc, -- (16#009D7#, 16#009D7#) BENGALI AU LENGTH MARK .. BENGALI AU LENGTH MARK + Lo, -- (16#009DC#, 16#009DD#) BENGALI LETTER RRA .. BENGALI LETTER RHA + Lo, -- (16#009DF#, 16#009E1#) BENGALI LETTER YYA .. BENGALI LETTER VOCALIC LL + Mn, -- (16#009E2#, 16#009E3#) BENGALI VOWEL SIGN VOCALIC L .. BENGALI VOWEL SIGN VOCALIC LL + Nd, -- (16#009E6#, 16#009EF#) BENGALI DIGIT ZERO .. BENGALI DIGIT NINE + Lo, -- (16#009F0#, 16#009F1#) BENGALI LETTER RA WITH MIDDLE DIAGONAL .. BENGALI LETTER RA WITH LOWER DIAGONAL + Sc, -- (16#009F2#, 16#009F3#) BENGALI RUPEE MARK .. BENGALI RUPEE SIGN + No, -- (16#009F4#, 16#009F9#) BENGALI CURRENCY NUMERATOR ONE .. BENGALI CURRENCY DENOMINATOR SIXTEEN + So, -- (16#009FA#, 16#009FA#) BENGALI ISSHAR .. BENGALI ISSHAR + Mn, -- (16#00A01#, 16#00A02#) GURMUKHI SIGN ADAK BINDI .. GURMUKHI SIGN BINDI + Mc, -- (16#00A03#, 16#00A03#) GURMUKHI SIGN VISARGA .. GURMUKHI SIGN VISARGA + Lo, -- (16#00A05#, 16#00A0A#) GURMUKHI LETTER A .. GURMUKHI LETTER UU + Lo, -- (16#00A0F#, 16#00A10#) GURMUKHI LETTER EE .. GURMUKHI LETTER AI + Lo, -- (16#00A13#, 16#00A28#) GURMUKHI LETTER OO .. GURMUKHI LETTER NA + Lo, -- (16#00A2A#, 16#00A30#) GURMUKHI LETTER PA .. GURMUKHI LETTER RA + Lo, -- (16#00A32#, 16#00A33#) GURMUKHI LETTER LA .. GURMUKHI LETTER LLA + Lo, -- (16#00A35#, 16#00A36#) GURMUKHI LETTER VA .. GURMUKHI LETTER SHA + Lo, -- (16#00A38#, 16#00A39#) GURMUKHI LETTER SA .. GURMUKHI LETTER HA + Mn, -- (16#00A3C#, 16#00A3C#) GURMUKHI SIGN NUKTA .. GURMUKHI SIGN NUKTA + Mc, -- (16#00A3E#, 16#00A40#) GURMUKHI VOWEL SIGN AA .. GURMUKHI VOWEL SIGN II + Mn, -- (16#00A41#, 16#00A42#) GURMUKHI VOWEL SIGN U .. GURMUKHI VOWEL SIGN UU + Mn, -- (16#00A47#, 16#00A48#) GURMUKHI VOWEL SIGN EE .. GURMUKHI VOWEL SIGN AI + Mn, -- (16#00A4B#, 16#00A4D#) GURMUKHI VOWEL SIGN OO .. GURMUKHI SIGN VIRAMA + Lo, -- (16#00A59#, 16#00A5C#) GURMUKHI LETTER KHHA .. GURMUKHI LETTER RRA + Lo, -- (16#00A5E#, 16#00A5E#) GURMUKHI LETTER FA .. GURMUKHI LETTER FA + Nd, -- (16#00A66#, 16#00A6F#) GURMUKHI DIGIT ZERO .. GURMUKHI DIGIT NINE + Mn, -- (16#00A70#, 16#00A71#) GURMUKHI TIPPI .. GURMUKHI ADDAK + Lo, -- (16#00A72#, 16#00A74#) GURMUKHI IRI .. GURMUKHI EK ONKAR + Mn, -- (16#00A81#, 16#00A82#) GUJARATI SIGN CANDRABINDU .. GUJARATI SIGN ANUSVARA + Mc, -- (16#00A83#, 16#00A83#) GUJARATI SIGN VISARGA .. GUJARATI SIGN VISARGA + Lo, -- (16#00A85#, 16#00A8D#) GUJARATI LETTER A .. GUJARATI VOWEL CANDRA E + Lo, -- (16#00A8F#, 16#00A91#) GUJARATI LETTER E .. GUJARATI VOWEL CANDRA O + Lo, -- (16#00A93#, 16#00AA8#) GUJARATI LETTER O .. GUJARATI LETTER NA + Lo, -- (16#00AAA#, 16#00AB0#) GUJARATI LETTER PA .. GUJARATI LETTER RA + Lo, -- (16#00AB2#, 16#00AB3#) GUJARATI LETTER LA .. GUJARATI LETTER LLA + Lo, -- (16#00AB5#, 16#00AB9#) GUJARATI LETTER VA .. GUJARATI LETTER HA + Mn, -- (16#00ABC#, 16#00ABC#) GUJARATI SIGN NUKTA .. GUJARATI SIGN NUKTA + Lo, -- (16#00ABD#, 16#00ABD#) GUJARATI SIGN AVAGRAHA .. GUJARATI SIGN AVAGRAHA + Mc, -- (16#00ABE#, 16#00AC0#) GUJARATI VOWEL SIGN AA .. GUJARATI VOWEL SIGN II + Mn, -- (16#00AC1#, 16#00AC5#) GUJARATI VOWEL SIGN U .. GUJARATI VOWEL SIGN CANDRA E + Mn, -- (16#00AC7#, 16#00AC8#) GUJARATI VOWEL SIGN E .. GUJARATI VOWEL SIGN AI + Mc, -- (16#00AC9#, 16#00AC9#) GUJARATI VOWEL SIGN CANDRA O .. GUJARATI VOWEL SIGN CANDRA O + Mc, -- (16#00ACB#, 16#00ACC#) GUJARATI VOWEL SIGN O .. GUJARATI VOWEL SIGN AU + Mn, -- (16#00ACD#, 16#00ACD#) GUJARATI SIGN VIRAMA .. GUJARATI SIGN VIRAMA + Lo, -- (16#00AD0#, 16#00AD0#) GUJARATI OM .. GUJARATI OM + Lo, -- (16#00AE0#, 16#00AE1#) GUJARATI LETTER VOCALIC RR .. GUJARATI LETTER VOCALIC LL + Mn, -- (16#00AE2#, 16#00AE3#) GUJARATI VOWEL SIGN VOCALIC L .. GUJARATI VOWEL SIGN VOCALIC LL + Nd, -- (16#00AE6#, 16#00AEF#) GUJARATI DIGIT ZERO .. GUJARATI DIGIT NINE + Sc, -- (16#00AF1#, 16#00AF1#) GUJARATI RUPEE SIGN .. GUJARATI RUPEE SIGN + Mn, -- (16#00B01#, 16#00B01#) ORIYA SIGN CANDRABINDU .. ORIYA SIGN CANDRABINDU + Mc, -- (16#00B02#, 16#00B03#) ORIYA SIGN ANUSVARA .. ORIYA SIGN VISARGA + Lo, -- (16#00B05#, 16#00B0C#) ORIYA LETTER A .. ORIYA LETTER VOCALIC L + Lo, -- (16#00B0F#, 16#00B10#) ORIYA LETTER E .. ORIYA LETTER AI + Lo, -- (16#00B13#, 16#00B28#) ORIYA LETTER O .. ORIYA LETTER NA + Lo, -- (16#00B2A#, 16#00B30#) ORIYA LETTER PA .. ORIYA LETTER RA + Lo, -- (16#00B32#, 16#00B33#) ORIYA LETTER LA .. ORIYA LETTER LLA + Lo, -- (16#00B35#, 16#00B39#) ORIYA LETTER VA .. ORIYA LETTER HA + Mn, -- (16#00B3C#, 16#00B3C#) ORIYA SIGN NUKTA .. ORIYA SIGN NUKTA + Lo, -- (16#00B3D#, 16#00B3D#) ORIYA SIGN AVAGRAHA .. ORIYA SIGN AVAGRAHA + Mc, -- (16#00B3E#, 16#00B3E#) ORIYA VOWEL SIGN AA .. ORIYA VOWEL SIGN AA + Mn, -- (16#00B3F#, 16#00B3F#) ORIYA VOWEL SIGN I .. ORIYA VOWEL SIGN I + Mc, -- (16#00B40#, 16#00B40#) ORIYA VOWEL SIGN II .. ORIYA VOWEL SIGN II + Mn, -- (16#00B41#, 16#00B43#) ORIYA VOWEL SIGN U .. ORIYA VOWEL SIGN VOCALIC R + Mc, -- (16#00B47#, 16#00B48#) ORIYA VOWEL SIGN E .. ORIYA VOWEL SIGN AI + Mc, -- (16#00B4B#, 16#00B4C#) ORIYA VOWEL SIGN O .. ORIYA VOWEL SIGN AU + Mn, -- (16#00B4D#, 16#00B4D#) ORIYA SIGN VIRAMA .. ORIYA SIGN VIRAMA + Mn, -- (16#00B56#, 16#00B56#) ORIYA AI LENGTH MARK .. ORIYA AI LENGTH MARK + Mc, -- (16#00B57#, 16#00B57#) ORIYA AU LENGTH MARK .. ORIYA AU LENGTH MARK + Lo, -- (16#00B5C#, 16#00B5D#) ORIYA LETTER RRA .. ORIYA LETTER RHA + Lo, -- (16#00B5F#, 16#00B61#) ORIYA LETTER YYA .. ORIYA LETTER VOCALIC LL + Nd, -- (16#00B66#, 16#00B6F#) ORIYA DIGIT ZERO .. ORIYA DIGIT NINE + So, -- (16#00B70#, 16#00B70#) ORIYA ISSHAR .. ORIYA ISSHAR + Lo, -- (16#00B71#, 16#00B71#) ORIYA LETTER WA .. ORIYA LETTER WA + Mn, -- (16#00B82#, 16#00B82#) TAMIL SIGN ANUSVARA .. TAMIL SIGN ANUSVARA + Lo, -- (16#00B83#, 16#00B83#) TAMIL SIGN VISARGA .. TAMIL SIGN VISARGA + Lo, -- (16#00B85#, 16#00B8A#) TAMIL LETTER A .. TAMIL LETTER UU + Lo, -- (16#00B8E#, 16#00B90#) TAMIL LETTER E .. TAMIL LETTER AI + Lo, -- (16#00B92#, 16#00B95#) TAMIL LETTER O .. TAMIL LETTER KA + Lo, -- (16#00B99#, 16#00B9A#) TAMIL LETTER NGA .. TAMIL LETTER CA + Lo, -- (16#00B9C#, 16#00B9C#) TAMIL LETTER JA .. TAMIL LETTER JA + Lo, -- (16#00B9E#, 16#00B9F#) TAMIL LETTER NYA .. TAMIL LETTER TTA + Lo, -- (16#00BA3#, 16#00BA4#) TAMIL LETTER NNA .. TAMIL LETTER TA + Lo, -- (16#00BA8#, 16#00BAA#) TAMIL LETTER NA .. TAMIL LETTER PA + Lo, -- (16#00BAE#, 16#00BB5#) TAMIL LETTER MA .. TAMIL LETTER VA + Lo, -- (16#00BB7#, 16#00BB9#) TAMIL LETTER SSA .. TAMIL LETTER HA + Mc, -- (16#00BBE#, 16#00BBF#) TAMIL VOWEL SIGN AA .. TAMIL VOWEL SIGN I + Mn, -- (16#00BC0#, 16#00BC0#) TAMIL VOWEL SIGN II .. TAMIL VOWEL SIGN II + Mc, -- (16#00BC1#, 16#00BC2#) TAMIL VOWEL SIGN U .. TAMIL VOWEL SIGN UU + Mc, -- (16#00BC6#, 16#00BC8#) TAMIL VOWEL SIGN E .. TAMIL VOWEL SIGN AI + Mc, -- (16#00BCA#, 16#00BCC#) TAMIL VOWEL SIGN O .. TAMIL VOWEL SIGN AU + Mn, -- (16#00BCD#, 16#00BCD#) TAMIL SIGN VIRAMA .. TAMIL SIGN VIRAMA + Mc, -- (16#00BD7#, 16#00BD7#) TAMIL AU LENGTH MARK .. TAMIL AU LENGTH MARK + Nd, -- (16#00BE7#, 16#00BEF#) TAMIL DIGIT ONE .. TAMIL DIGIT NINE + No, -- (16#00BF0#, 16#00BF2#) TAMIL NUMBER TEN .. TAMIL NUMBER ONE THOUSAND + So, -- (16#00BF3#, 16#00BF8#) TAMIL DAY SIGN .. TAMIL AS ABOVE SIGN + Sc, -- (16#00BF9#, 16#00BF9#) TAMIL RUPEE SIGN .. TAMIL RUPEE SIGN + So, -- (16#00BFA#, 16#00BFA#) TAMIL NUMBER SIGN .. TAMIL NUMBER SIGN + Mc, -- (16#00C01#, 16#00C03#) TELUGU SIGN CANDRABINDU .. TELUGU SIGN VISARGA + Lo, -- (16#00C05#, 16#00C0C#) TELUGU LETTER A .. TELUGU LETTER VOCALIC L + Lo, -- (16#00C0E#, 16#00C10#) TELUGU LETTER E .. TELUGU LETTER AI + Lo, -- (16#00C12#, 16#00C28#) TELUGU LETTER O .. TELUGU LETTER NA + Lo, -- (16#00C2A#, 16#00C33#) TELUGU LETTER PA .. TELUGU LETTER LLA + Lo, -- (16#00C35#, 16#00C39#) TELUGU LETTER VA .. TELUGU LETTER HA + Mn, -- (16#00C3E#, 16#00C40#) TELUGU VOWEL SIGN AA .. TELUGU VOWEL SIGN II + Mc, -- (16#00C41#, 16#00C44#) TELUGU VOWEL SIGN U .. TELUGU VOWEL SIGN VOCALIC RR + Mn, -- (16#00C46#, 16#00C48#) TELUGU VOWEL SIGN E .. TELUGU VOWEL SIGN AI + Mn, -- (16#00C4A#, 16#00C4D#) TELUGU VOWEL SIGN O .. TELUGU SIGN VIRAMA + Mn, -- (16#00C55#, 16#00C56#) TELUGU LENGTH MARK .. TELUGU AI LENGTH MARK + Lo, -- (16#00C60#, 16#00C61#) TELUGU LETTER VOCALIC RR .. TELUGU LETTER VOCALIC LL + Nd, -- (16#00C66#, 16#00C6F#) TELUGU DIGIT ZERO .. TELUGU DIGIT NINE + Mc, -- (16#00C82#, 16#00C83#) KANNADA SIGN ANUSVARA .. KANNADA SIGN VISARGA + Lo, -- (16#00C85#, 16#00C8C#) KANNADA LETTER A .. KANNADA LETTER VOCALIC L + Lo, -- (16#00C8E#, 16#00C90#) KANNADA LETTER E .. KANNADA LETTER AI + Lo, -- (16#00C92#, 16#00CA8#) KANNADA LETTER O .. KANNADA LETTER NA + Lo, -- (16#00CAA#, 16#00CB3#) KANNADA LETTER PA .. KANNADA LETTER LLA + Lo, -- (16#00CB5#, 16#00CB9#) KANNADA LETTER VA .. KANNADA LETTER HA + Mn, -- (16#00CBC#, 16#00CBC#) KANNADA SIGN NUKTA .. KANNADA SIGN NUKTA + Lo, -- (16#00CBD#, 16#00CBD#) KANNADA SIGN AVAGRAHA .. KANNADA SIGN AVAGRAHA + Mc, -- (16#00CBE#, 16#00CBE#) KANNADA VOWEL SIGN AA .. KANNADA VOWEL SIGN AA + Mn, -- (16#00CBF#, 16#00CBF#) KANNADA VOWEL SIGN I .. KANNADA VOWEL SIGN I + Mc, -- (16#00CC0#, 16#00CC4#) KANNADA VOWEL SIGN II .. KANNADA VOWEL SIGN VOCALIC RR + Mn, -- (16#00CC6#, 16#00CC6#) KANNADA VOWEL SIGN E .. KANNADA VOWEL SIGN E + Mc, -- (16#00CC7#, 16#00CC8#) KANNADA VOWEL SIGN EE .. KANNADA VOWEL SIGN AI + Mc, -- (16#00CCA#, 16#00CCB#) KANNADA VOWEL SIGN O .. KANNADA VOWEL SIGN OO + Mn, -- (16#00CCC#, 16#00CCD#) KANNADA VOWEL SIGN AU .. KANNADA SIGN VIRAMA + Mc, -- (16#00CD5#, 16#00CD6#) KANNADA LENGTH MARK .. KANNADA AI LENGTH MARK + Lo, -- (16#00CDE#, 16#00CDE#) KANNADA LETTER FA .. KANNADA LETTER FA + Lo, -- (16#00CE0#, 16#00CE1#) KANNADA LETTER VOCALIC RR .. KANNADA LETTER VOCALIC LL + Nd, -- (16#00CE6#, 16#00CEF#) KANNADA DIGIT ZERO .. KANNADA DIGIT NINE + Mc, -- (16#00D02#, 16#00D03#) MALAYALAM SIGN ANUSVARA .. MALAYALAM SIGN VISARGA + Lo, -- (16#00D05#, 16#00D0C#) MALAYALAM LETTER A .. MALAYALAM LETTER VOCALIC L + Lo, -- (16#00D0E#, 16#00D10#) MALAYALAM LETTER E .. MALAYALAM LETTER AI + Lo, -- (16#00D12#, 16#00D28#) MALAYALAM LETTER O .. MALAYALAM LETTER NA + Lo, -- (16#00D2A#, 16#00D39#) MALAYALAM LETTER PA .. MALAYALAM LETTER HA + Mc, -- (16#00D3E#, 16#00D40#) MALAYALAM VOWEL SIGN AA .. MALAYALAM VOWEL SIGN II + Mn, -- (16#00D41#, 16#00D43#) MALAYALAM VOWEL SIGN U .. MALAYALAM VOWEL SIGN VOCALIC R + Mc, -- (16#00D46#, 16#00D48#) MALAYALAM VOWEL SIGN E .. MALAYALAM VOWEL SIGN AI + Mc, -- (16#00D4A#, 16#00D4C#) MALAYALAM VOWEL SIGN O .. MALAYALAM VOWEL SIGN AU + Mn, -- (16#00D4D#, 16#00D4D#) MALAYALAM SIGN VIRAMA .. MALAYALAM SIGN VIRAMA + Mc, -- (16#00D57#, 16#00D57#) MALAYALAM AU LENGTH MARK .. MALAYALAM AU LENGTH MARK + Lo, -- (16#00D60#, 16#00D61#) MALAYALAM LETTER VOCALIC RR .. MALAYALAM LETTER VOCALIC LL + Nd, -- (16#00D66#, 16#00D6F#) MALAYALAM DIGIT ZERO .. MALAYALAM DIGIT NINE + Mc, -- (16#00D82#, 16#00D83#) SINHALA SIGN ANUSVARAYA .. SINHALA SIGN VISARGAYA + Lo, -- (16#00D85#, 16#00D96#) SINHALA LETTER AYANNA .. SINHALA LETTER AUYANNA + Lo, -- (16#00D9A#, 16#00DB1#) SINHALA LETTER ALPAPRAANA KAYANNA .. SINHALA LETTER DANTAJA NAYANNA + Lo, -- (16#00DB3#, 16#00DBB#) SINHALA LETTER SANYAKA DAYANNA .. SINHALA LETTER RAYANNA + Lo, -- (16#00DBD#, 16#00DBD#) SINHALA LETTER DANTAJA LAYANNA .. SINHALA LETTER DANTAJA LAYANNA + Lo, -- (16#00DC0#, 16#00DC6#) SINHALA LETTER VAYANNA .. SINHALA LETTER FAYANNA + Mn, -- (16#00DCA#, 16#00DCA#) SINHALA SIGN AL-LAKUNA .. SINHALA SIGN AL-LAKUNA + Mc, -- (16#00DCF#, 16#00DD1#) SINHALA VOWEL SIGN AELA-PILLA .. SINHALA VOWEL SIGN DIGA AEDA-PILLA + Mn, -- (16#00DD2#, 16#00DD4#) SINHALA VOWEL SIGN KETTI IS-PILLA .. SINHALA VOWEL SIGN KETTI PAA-PILLA + Mn, -- (16#00DD6#, 16#00DD6#) SINHALA VOWEL SIGN DIGA PAA-PILLA .. SINHALA VOWEL SIGN DIGA PAA-PILLA + Mc, -- (16#00DD8#, 16#00DDF#) SINHALA VOWEL SIGN GAETTA-PILLA .. SINHALA VOWEL SIGN GAYANUKITTA + Mc, -- (16#00DF2#, 16#00DF3#) SINHALA VOWEL SIGN DIGA GAETTA-PILLA .. SINHALA VOWEL SIGN DIGA GAYANUKITTA + Po, -- (16#00DF4#, 16#00DF4#) SINHALA PUNCTUATION KUNDDALIYA .. SINHALA PUNCTUATION KUNDDALIYA + Lo, -- (16#00E01#, 16#00E30#) THAI CHARACTER KO KAI .. THAI CHARACTER SARA A + Mn, -- (16#00E31#, 16#00E31#) THAI CHARACTER MAI HAN-AKAT .. THAI CHARACTER MAI HAN-AKAT + Lo, -- (16#00E32#, 16#00E33#) THAI CHARACTER SARA AA .. THAI CHARACTER SARA AM + Mn, -- (16#00E34#, 16#00E3A#) THAI CHARACTER SARA I .. THAI CHARACTER PHINTHU + Sc, -- (16#00E3F#, 16#00E3F#) THAI CURRENCY SYMBOL BAHT .. THAI CURRENCY SYMBOL BAHT + Lo, -- (16#00E40#, 16#00E45#) THAI CHARACTER SARA E .. THAI CHARACTER LAKKHANGYAO + Lm, -- (16#00E46#, 16#00E46#) THAI CHARACTER MAIYAMOK .. THAI CHARACTER MAIYAMOK + Mn, -- (16#00E47#, 16#00E4E#) THAI CHARACTER MAITAIKHU .. THAI CHARACTER YAMAKKAN + Po, -- (16#00E4F#, 16#00E4F#) THAI CHARACTER FONGMAN .. THAI CHARACTER FONGMAN + Nd, -- (16#00E50#, 16#00E59#) THAI DIGIT ZERO .. THAI DIGIT NINE + Po, -- (16#00E5A#, 16#00E5B#) THAI CHARACTER ANGKHANKHU .. THAI CHARACTER KHOMUT + Lo, -- (16#00E81#, 16#00E82#) LAO LETTER KO .. LAO LETTER KHO SUNG + Lo, -- (16#00E84#, 16#00E84#) LAO LETTER KHO TAM .. LAO LETTER KHO TAM + Lo, -- (16#00E87#, 16#00E88#) LAO LETTER NGO .. LAO LETTER CO + Lo, -- (16#00E8A#, 16#00E8A#) LAO LETTER SO TAM .. LAO LETTER SO TAM + Lo, -- (16#00E8D#, 16#00E8D#) LAO LETTER NYO .. LAO LETTER NYO + Lo, -- (16#00E94#, 16#00E97#) LAO LETTER DO .. LAO LETTER THO TAM + Lo, -- (16#00E99#, 16#00E9F#) LAO LETTER NO .. LAO LETTER FO SUNG + Lo, -- (16#00EA1#, 16#00EA3#) LAO LETTER MO .. LAO LETTER LO LING + Lo, -- (16#00EA5#, 16#00EA5#) LAO LETTER LO LOOT .. LAO LETTER LO LOOT + Lo, -- (16#00EA7#, 16#00EA7#) LAO LETTER WO .. LAO LETTER WO + Lo, -- (16#00EAA#, 16#00EAB#) LAO LETTER SO SUNG .. LAO LETTER HO SUNG + Lo, -- (16#00EAD#, 16#00EB0#) LAO LETTER O .. LAO VOWEL SIGN A + Mn, -- (16#00EB1#, 16#00EB1#) LAO VOWEL SIGN MAI KAN .. LAO VOWEL SIGN MAI KAN + Lo, -- (16#00EB2#, 16#00EB3#) LAO VOWEL SIGN AA .. LAO VOWEL SIGN AM + Mn, -- (16#00EB4#, 16#00EB9#) LAO VOWEL SIGN I .. LAO VOWEL SIGN UU + Mn, -- (16#00EBB#, 16#00EBC#) LAO VOWEL SIGN MAI KON .. LAO SEMIVOWEL SIGN LO + Lo, -- (16#00EBD#, 16#00EBD#) LAO SEMIVOWEL SIGN NYO .. LAO SEMIVOWEL SIGN NYO + Lo, -- (16#00EC0#, 16#00EC4#) LAO VOWEL SIGN E .. LAO VOWEL SIGN AI + Lm, -- (16#00EC6#, 16#00EC6#) LAO KO LA .. LAO KO LA + Mn, -- (16#00EC8#, 16#00ECD#) LAO TONE MAI EK .. LAO NIGGAHITA + Nd, -- (16#00ED0#, 16#00ED9#) LAO DIGIT ZERO .. LAO DIGIT NINE + Lo, -- (16#00EDC#, 16#00EDD#) LAO HO NO .. LAO HO MO + Lo, -- (16#00F00#, 16#00F00#) TIBETAN SYLLABLE OM .. TIBETAN SYLLABLE OM + So, -- (16#00F01#, 16#00F03#) TIBETAN MARK GTER YIG MGO TRUNCATED A .. TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA + Po, -- (16#00F04#, 16#00F12#) TIBETAN MARK INITIAL YIG MGO MDUN MA .. TIBETAN MARK RGYA GRAM SHAD + So, -- (16#00F13#, 16#00F17#) TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN .. TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS + Mn, -- (16#00F18#, 16#00F19#) TIBETAN ASTROLOGICAL SIGN -KHYUD PA .. TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS + So, -- (16#00F1A#, 16#00F1F#) TIBETAN SIGN RDEL DKAR GCIG .. TIBETAN SIGN RDEL DKAR RDEL NAG + Nd, -- (16#00F20#, 16#00F29#) TIBETAN DIGIT ZERO .. TIBETAN DIGIT NINE + No, -- (16#00F2A#, 16#00F33#) TIBETAN DIGIT HALF ONE .. TIBETAN DIGIT HALF ZERO + So, -- (16#00F34#, 16#00F34#) TIBETAN MARK BSDUS RTAGS .. TIBETAN MARK BSDUS RTAGS + Mn, -- (16#00F35#, 16#00F35#) TIBETAN MARK NGAS BZUNG NYI ZLA .. TIBETAN MARK NGAS BZUNG NYI ZLA + So, -- (16#00F36#, 16#00F36#) TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN .. TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN + Mn, -- (16#00F37#, 16#00F37#) TIBETAN MARK NGAS BZUNG SGOR RTAGS .. TIBETAN MARK NGAS BZUNG SGOR RTAGS + So, -- (16#00F38#, 16#00F38#) TIBETAN MARK CHE MGO .. TIBETAN MARK CHE MGO + Mn, -- (16#00F39#, 16#00F39#) TIBETAN MARK TSA -PHRU .. TIBETAN MARK TSA -PHRU + Ps, -- (16#00F3A#, 16#00F3A#) TIBETAN MARK GUG RTAGS GYON .. TIBETAN MARK GUG RTAGS GYON + Pe, -- (16#00F3B#, 16#00F3B#) TIBETAN MARK GUG RTAGS GYAS .. TIBETAN MARK GUG RTAGS GYAS + Ps, -- (16#00F3C#, 16#00F3C#) TIBETAN MARK ANG KHANG GYON .. TIBETAN MARK ANG KHANG GYON + Pe, -- (16#00F3D#, 16#00F3D#) TIBETAN MARK ANG KHANG GYAS .. TIBETAN MARK ANG KHANG GYAS + Mc, -- (16#00F3E#, 16#00F3F#) TIBETAN SIGN YAR TSHES .. TIBETAN SIGN MAR TSHES + Lo, -- (16#00F40#, 16#00F47#) TIBETAN LETTER KA .. TIBETAN LETTER JA + Lo, -- (16#00F49#, 16#00F6A#) TIBETAN LETTER NYA .. TIBETAN LETTER FIXED-FORM RA + Mn, -- (16#00F71#, 16#00F7E#) TIBETAN VOWEL SIGN AA .. TIBETAN SIGN RJES SU NGA RO + Mc, -- (16#00F7F#, 16#00F7F#) TIBETAN SIGN RNAM BCAD .. TIBETAN SIGN RNAM BCAD + Mn, -- (16#00F80#, 16#00F84#) TIBETAN VOWEL SIGN REVERSED I .. TIBETAN MARK HALANTA + Po, -- (16#00F85#, 16#00F85#) TIBETAN MARK PALUTA .. TIBETAN MARK PALUTA + Mn, -- (16#00F86#, 16#00F87#) TIBETAN SIGN LCI RTAGS .. TIBETAN SIGN YANG RTAGS + Lo, -- (16#00F88#, 16#00F8B#) TIBETAN SIGN LCE TSA CAN .. TIBETAN SIGN GRU MED RGYINGS + Mn, -- (16#00F90#, 16#00F97#) TIBETAN SUBJOINED LETTER KA .. TIBETAN SUBJOINED LETTER JA + Mn, -- (16#00F99#, 16#00FBC#) TIBETAN SUBJOINED LETTER NYA .. TIBETAN SUBJOINED LETTER FIXED-FORM RA + So, -- (16#00FBE#, 16#00FC5#) TIBETAN KU RU KHA .. TIBETAN SYMBOL RDO RJE + Mn, -- (16#00FC6#, 16#00FC6#) TIBETAN SYMBOL PADMA GDAN .. TIBETAN SYMBOL PADMA GDAN + So, -- (16#00FC7#, 16#00FCC#) TIBETAN SYMBOL RDO RJE RGYA GRAM .. TIBETAN SYMBOL NOR BU BZHI -KHYIL + So, -- (16#00FCF#, 16#00FCF#) TIBETAN SIGN RDEL NAG GSUM .. TIBETAN SIGN RDEL NAG GSUM + Lo, -- (16#01000#, 16#01021#) MYANMAR LETTER KA .. MYANMAR LETTER A + Lo, -- (16#01023#, 16#01027#) MYANMAR LETTER I .. MYANMAR LETTER E + Lo, -- (16#01029#, 16#0102A#) MYANMAR LETTER O .. MYANMAR LETTER AU + Mc, -- (16#0102C#, 16#0102C#) MYANMAR VOWEL SIGN AA .. MYANMAR VOWEL SIGN AA + Mn, -- (16#0102D#, 16#01030#) MYANMAR VOWEL SIGN I .. MYANMAR VOWEL SIGN UU + Mc, -- (16#01031#, 16#01031#) MYANMAR VOWEL SIGN E .. MYANMAR VOWEL SIGN E + Mn, -- (16#01032#, 16#01032#) MYANMAR VOWEL SIGN AI .. MYANMAR VOWEL SIGN AI + Mn, -- (16#01036#, 16#01037#) MYANMAR SIGN ANUSVARA .. MYANMAR SIGN DOT BELOW + Mc, -- (16#01038#, 16#01038#) MYANMAR SIGN VISARGA .. MYANMAR SIGN VISARGA + Mn, -- (16#01039#, 16#01039#) MYANMAR SIGN VIRAMA .. MYANMAR SIGN VIRAMA + Nd, -- (16#01040#, 16#01049#) MYANMAR DIGIT ZERO .. MYANMAR DIGIT NINE + Po, -- (16#0104A#, 16#0104F#) MYANMAR SIGN LITTLE SECTION .. MYANMAR SYMBOL GENITIVE + Lo, -- (16#01050#, 16#01055#) MYANMAR LETTER SHA .. MYANMAR LETTER VOCALIC LL + Mc, -- (16#01056#, 16#01057#) MYANMAR VOWEL SIGN VOCALIC R .. MYANMAR VOWEL SIGN VOCALIC RR + Mn, -- (16#01058#, 16#01059#) MYANMAR VOWEL SIGN VOCALIC L .. MYANMAR VOWEL SIGN VOCALIC LL + Lu, -- (16#010A0#, 16#010C5#) GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE + Lo, -- (16#010D0#, 16#010F8#) GEORGIAN LETTER AN .. GEORGIAN LETTER ELIFI + Po, -- (16#010FB#, 16#010FB#) GEORGIAN PARAGRAPH SEPARATOR .. GEORGIAN PARAGRAPH SEPARATOR + Lo, -- (16#01100#, 16#01159#) HANGUL CHOSEONG KIYEOK .. HANGUL CHOSEONG YEORINHIEUH + Lo, -- (16#0115F#, 16#011A2#) HANGUL CHOSEONG FILLER .. HANGUL JUNGSEONG SSANGARAEA + Lo, -- (16#011A8#, 16#011F9#) HANGUL JONGSEONG KIYEOK .. HANGUL JONGSEONG YEORINHIEUH + Lo, -- (16#01200#, 16#01206#) ETHIOPIC SYLLABLE HA .. ETHIOPIC SYLLABLE HO + Lo, -- (16#01208#, 16#01246#) ETHIOPIC SYLLABLE LA .. ETHIOPIC SYLLABLE QO + Lo, -- (16#01248#, 16#01248#) ETHIOPIC SYLLABLE QWA .. ETHIOPIC SYLLABLE QWA + Lo, -- (16#0124A#, 16#0124D#) ETHIOPIC SYLLABLE QWI .. ETHIOPIC SYLLABLE QWE + Lo, -- (16#01250#, 16#01256#) ETHIOPIC SYLLABLE QHA .. ETHIOPIC SYLLABLE QHO + Lo, -- (16#01258#, 16#01258#) ETHIOPIC SYLLABLE QHWA .. ETHIOPIC SYLLABLE QHWA + Lo, -- (16#0125A#, 16#0125D#) ETHIOPIC SYLLABLE QHWI .. ETHIOPIC SYLLABLE QHWE + Lo, -- (16#01260#, 16#01286#) ETHIOPIC SYLLABLE BA .. ETHIOPIC SYLLABLE XO + Lo, -- (16#01288#, 16#01288#) ETHIOPIC SYLLABLE XWA .. ETHIOPIC SYLLABLE XWA + Lo, -- (16#0128A#, 16#0128D#) ETHIOPIC SYLLABLE XWI .. ETHIOPIC SYLLABLE XWE + Lo, -- (16#01290#, 16#012AE#) ETHIOPIC SYLLABLE NA .. ETHIOPIC SYLLABLE KO + Lo, -- (16#012B0#, 16#012B0#) ETHIOPIC SYLLABLE KWA .. ETHIOPIC SYLLABLE KWA + Lo, -- (16#012B2#, 16#012B5#) ETHIOPIC SYLLABLE KWI .. ETHIOPIC SYLLABLE KWE + Lo, -- (16#012B8#, 16#012BE#) ETHIOPIC SYLLABLE KXA .. ETHIOPIC SYLLABLE KXO + Lo, -- (16#012C0#, 16#012C0#) ETHIOPIC SYLLABLE KXWA .. ETHIOPIC SYLLABLE KXWA + Lo, -- (16#012C2#, 16#012C5#) ETHIOPIC SYLLABLE KXWI .. ETHIOPIC SYLLABLE KXWE + Lo, -- (16#012C8#, 16#012CE#) ETHIOPIC SYLLABLE WA .. ETHIOPIC SYLLABLE WO + Lo, -- (16#012D0#, 16#012D6#) ETHIOPIC SYLLABLE PHARYNGEAL A .. ETHIOPIC SYLLABLE PHARYNGEAL O + Lo, -- (16#012D8#, 16#012EE#) ETHIOPIC SYLLABLE ZA .. ETHIOPIC SYLLABLE YO + Lo, -- (16#012F0#, 16#0130E#) ETHIOPIC SYLLABLE DA .. ETHIOPIC SYLLABLE GO + Lo, -- (16#01310#, 16#01310#) ETHIOPIC SYLLABLE GWA .. ETHIOPIC SYLLABLE GWA + Lo, -- (16#01312#, 16#01315#) ETHIOPIC SYLLABLE GWI .. ETHIOPIC SYLLABLE GWE + Lo, -- (16#01318#, 16#0131E#) ETHIOPIC SYLLABLE GGA .. ETHIOPIC SYLLABLE GGO + Lo, -- (16#01320#, 16#01346#) ETHIOPIC SYLLABLE THA .. ETHIOPIC SYLLABLE TZO + Lo, -- (16#01348#, 16#0135A#) ETHIOPIC SYLLABLE FA .. ETHIOPIC SYLLABLE FYA + Po, -- (16#01361#, 16#01368#) ETHIOPIC WORDSPACE .. ETHIOPIC PARAGRAPH SEPARATOR + Nd, -- (16#01369#, 16#01371#) ETHIOPIC DIGIT ONE .. ETHIOPIC DIGIT NINE + No, -- (16#01372#, 16#0137C#) ETHIOPIC NUMBER TEN .. ETHIOPIC NUMBER TEN THOUSAND + Lo, -- (16#013A0#, 16#013F4#) CHEROKEE LETTER A .. CHEROKEE LETTER YV + Lo, -- (16#01401#, 16#0166C#) CANADIAN SYLLABICS E .. CANADIAN SYLLABICS CARRIER TTSA + Po, -- (16#0166D#, 16#0166E#) CANADIAN SYLLABICS CHI SIGN .. CANADIAN SYLLABICS FULL STOP + Lo, -- (16#0166F#, 16#01676#) CANADIAN SYLLABICS QAI .. CANADIAN SYLLABICS NNGAA + Zs, -- (16#01680#, 16#01680#) OGHAM SPACE MARK .. OGHAM SPACE MARK + Lo, -- (16#01681#, 16#0169A#) OGHAM LETTER BEITH .. OGHAM LETTER PEITH + Ps, -- (16#0169B#, 16#0169B#) OGHAM FEATHER MARK .. OGHAM FEATHER MARK + Pe, -- (16#0169C#, 16#0169C#) OGHAM REVERSED FEATHER MARK .. OGHAM REVERSED FEATHER MARK + Lo, -- (16#016A0#, 16#016EA#) RUNIC LETTER FEHU FEOH FE F .. RUNIC LETTER X + Po, -- (16#016EB#, 16#016ED#) RUNIC SINGLE PUNCTUATION .. RUNIC CROSS PUNCTUATION + Nl, -- (16#016EE#, 16#016F0#) RUNIC ARLAUG SYMBOL .. RUNIC BELGTHOR SYMBOL + Lo, -- (16#01700#, 16#0170C#) TAGALOG LETTER A .. TAGALOG LETTER YA + Lo, -- (16#0170E#, 16#01711#) TAGALOG LETTER LA .. TAGALOG LETTER HA + Mn, -- (16#01712#, 16#01714#) TAGALOG VOWEL SIGN I .. TAGALOG SIGN VIRAMA + Lo, -- (16#01720#, 16#01731#) HANUNOO LETTER A .. HANUNOO LETTER HA + Mn, -- (16#01732#, 16#01734#) HANUNOO VOWEL SIGN I .. HANUNOO SIGN PAMUDPOD + Po, -- (16#01735#, 16#01736#) PHILIPPINE SINGLE PUNCTUATION .. PHILIPPINE DOUBLE PUNCTUATION + Lo, -- (16#01740#, 16#01751#) BUHID LETTER A .. BUHID LETTER HA + Mn, -- (16#01752#, 16#01753#) BUHID VOWEL SIGN I .. BUHID VOWEL SIGN U + Lo, -- (16#01760#, 16#0176C#) TAGBANWA LETTER A .. TAGBANWA LETTER YA + Lo, -- (16#0176E#, 16#01770#) TAGBANWA LETTER LA .. TAGBANWA LETTER SA + Mn, -- (16#01772#, 16#01773#) TAGBANWA VOWEL SIGN I .. TAGBANWA VOWEL SIGN U + Lo, -- (16#01780#, 16#017B3#) KHMER LETTER KA .. KHMER INDEPENDENT VOWEL QAU + Cf, -- (16#017B4#, 16#017B5#) KHMER VOWEL INHERENT AQ .. KHMER VOWEL INHERENT AA + Mc, -- (16#017B6#, 16#017B6#) KHMER VOWEL SIGN AA .. KHMER VOWEL SIGN AA + Mn, -- (16#017B7#, 16#017BD#) KHMER VOWEL SIGN I .. KHMER VOWEL SIGN UA + Mc, -- (16#017BE#, 16#017C5#) KHMER VOWEL SIGN OE .. KHMER VOWEL SIGN AU + Mn, -- (16#017C6#, 16#017C6#) KHMER SIGN NIKAHIT .. KHMER SIGN NIKAHIT + Mc, -- (16#017C7#, 16#017C8#) KHMER SIGN REAHMUK .. KHMER SIGN YUUKALEAPINTU + Mn, -- (16#017C9#, 16#017D3#) KHMER SIGN MUUSIKATOAN .. KHMER SIGN BATHAMASAT + Po, -- (16#017D4#, 16#017D6#) KHMER SIGN KHAN .. KHMER SIGN CAMNUC PII KUUH + Lm, -- (16#017D7#, 16#017D7#) KHMER SIGN LEK TOO .. KHMER SIGN LEK TOO + Po, -- (16#017D8#, 16#017DA#) KHMER SIGN BEYYAL .. KHMER SIGN KOOMUUT + Sc, -- (16#017DB#, 16#017DB#) KHMER CURRENCY SYMBOL RIEL .. KHMER CURRENCY SYMBOL RIEL + Lo, -- (16#017DC#, 16#017DC#) KHMER SIGN AVAKRAHASANYA .. KHMER SIGN AVAKRAHASANYA + Mn, -- (16#017DD#, 16#017DD#) KHMER SIGN ATTHACAN .. KHMER SIGN ATTHACAN + Nd, -- (16#017E0#, 16#017E9#) KHMER DIGIT ZERO .. KHMER DIGIT NINE + No, -- (16#017F0#, 16#017F9#) KHMER SYMBOL LEK ATTAK SON .. KHMER SYMBOL LEK ATTAK PRAM-BUON + Po, -- (16#01800#, 16#01805#) MONGOLIAN BIRGA .. MONGOLIAN FOUR DOTS + Pd, -- (16#01806#, 16#01806#) MONGOLIAN TODO SOFT HYPHEN .. MONGOLIAN TODO SOFT HYPHEN + Po, -- (16#01807#, 16#0180A#) MONGOLIAN SIBE SYLLABLE BOUNDARY MARKER .. MONGOLIAN NIRUGU + Mn, -- (16#0180B#, 16#0180D#) MONGOLIAN FREE VARIATION SELECTOR ONE .. MONGOLIAN FREE VARIATION SELECTOR THREE + Zs, -- (16#0180E#, 16#0180E#) MONGOLIAN VOWEL SEPARATOR .. MONGOLIAN VOWEL SEPARATOR + Nd, -- (16#01810#, 16#01819#) MONGOLIAN DIGIT ZERO .. MONGOLIAN DIGIT NINE + Lo, -- (16#01820#, 16#01842#) MONGOLIAN LETTER A .. MONGOLIAN LETTER CHI + Lm, -- (16#01843#, 16#01843#) MONGOLIAN LETTER TODO LONG VOWEL SIGN .. MONGOLIAN LETTER TODO LONG VOWEL SIGN + Lo, -- (16#01844#, 16#01877#) MONGOLIAN LETTER TODO E .. MONGOLIAN LETTER MANCHU ZHA + Lo, -- (16#01880#, 16#018A8#) MONGOLIAN LETTER ALI GALI ANUSVARA ONE .. MONGOLIAN LETTER MANCHU ALI GALI BHA + Mn, -- (16#018A9#, 16#018A9#) MONGOLIAN LETTER ALI GALI DAGALGA .. MONGOLIAN LETTER ALI GALI DAGALGA + Lo, -- (16#01900#, 16#0191C#) LIMBU VOWEL-CARRIER LETTER .. LIMBU LETTER HA + Mn, -- (16#01920#, 16#01922#) LIMBU VOWEL SIGN A .. LIMBU VOWEL SIGN U + Mc, -- (16#01923#, 16#01926#) LIMBU VOWEL SIGN EE .. LIMBU VOWEL SIGN AU + Mn, -- (16#01927#, 16#01928#) LIMBU VOWEL SIGN E .. LIMBU VOWEL SIGN O + Mc, -- (16#01929#, 16#0192B#) LIMBU SUBJOINED LETTER YA .. LIMBU SUBJOINED LETTER WA + Mc, -- (16#01930#, 16#01931#) LIMBU SMALL LETTER KA .. LIMBU SMALL LETTER NGA + Mn, -- (16#01932#, 16#01932#) LIMBU SMALL LETTER ANUSVARA .. LIMBU SMALL LETTER ANUSVARA + Mc, -- (16#01933#, 16#01938#) LIMBU SMALL LETTER TA .. LIMBU SMALL LETTER LA + Mn, -- (16#01939#, 16#0193B#) LIMBU SIGN MUKPHRENG .. LIMBU SIGN SA-I + So, -- (16#01940#, 16#01940#) LIMBU SIGN LOO .. LIMBU SIGN LOO + Po, -- (16#01944#, 16#01945#) LIMBU EXCLAMATION MARK .. LIMBU QUESTION MARK + Nd, -- (16#01946#, 16#0194F#) LIMBU DIGIT ZERO .. LIMBU DIGIT NINE + Lo, -- (16#01950#, 16#0196D#) TAI LE LETTER KA .. TAI LE LETTER AI + Lo, -- (16#01970#, 16#01974#) TAI LE LETTER TONE-2 .. TAI LE LETTER TONE-6 + So, -- (16#019E0#, 16#019FF#) KHMER SYMBOL PATHAMASAT .. KHMER SYMBOL DAP-PRAM ROC + Ll, -- (16#01D00#, 16#01D2B#) LATIN LETTER SMALL CAPITAL A .. CYRILLIC LETTER SMALL CAPITAL EL + Lm, -- (16#01D2C#, 16#01D61#) MODIFIER LETTER CAPITAL A .. MODIFIER LETTER SMALL CHI + Ll, -- (16#01D62#, 16#01D6B#) LATIN SUBSCRIPT SMALL LETTER I .. LATIN SMALL LETTER UE + Lu, -- (16#01E00#, 16#01E00#) LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW + Ll, -- (16#01E01#, 16#01E01#) LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW + Lu, -- (16#01E02#, 16#01E02#) LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE + Ll, -- (16#01E03#, 16#01E03#) LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE + Lu, -- (16#01E04#, 16#01E04#) LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW + Ll, -- (16#01E05#, 16#01E05#) LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW + Lu, -- (16#01E06#, 16#01E06#) LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW + Ll, -- (16#01E07#, 16#01E07#) LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW + Lu, -- (16#01E08#, 16#01E08#) LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE + Ll, -- (16#01E09#, 16#01E09#) LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE + Lu, -- (16#01E0A#, 16#01E0A#) LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE + Ll, -- (16#01E0B#, 16#01E0B#) LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE + Lu, -- (16#01E0C#, 16#01E0C#) LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW + Ll, -- (16#01E0D#, 16#01E0D#) LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW + Lu, -- (16#01E0E#, 16#01E0E#) LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW + Ll, -- (16#01E0F#, 16#01E0F#) LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW + Lu, -- (16#01E10#, 16#01E10#) LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA + Ll, -- (16#01E11#, 16#01E11#) LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA + Lu, -- (16#01E12#, 16#01E12#) LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW + Ll, -- (16#01E13#, 16#01E13#) LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW + Lu, -- (16#01E14#, 16#01E14#) LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE + Ll, -- (16#01E15#, 16#01E15#) LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE + Lu, -- (16#01E16#, 16#01E16#) LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE + Ll, -- (16#01E17#, 16#01E17#) LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE + Lu, -- (16#01E18#, 16#01E18#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW + Ll, -- (16#01E19#, 16#01E19#) LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW + Lu, -- (16#01E1A#, 16#01E1A#) LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW + Ll, -- (16#01E1B#, 16#01E1B#) LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW + Lu, -- (16#01E1C#, 16#01E1C#) LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE + Ll, -- (16#01E1D#, 16#01E1D#) LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE + Lu, -- (16#01E1E#, 16#01E1E#) LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE + Ll, -- (16#01E1F#, 16#01E1F#) LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE + Lu, -- (16#01E20#, 16#01E20#) LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON + Ll, -- (16#01E21#, 16#01E21#) LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON + Lu, -- (16#01E22#, 16#01E22#) LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE + Ll, -- (16#01E23#, 16#01E23#) LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE + Lu, -- (16#01E24#, 16#01E24#) LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW + Ll, -- (16#01E25#, 16#01E25#) LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW + Lu, -- (16#01E26#, 16#01E26#) LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS + Ll, -- (16#01E27#, 16#01E27#) LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS + Lu, -- (16#01E28#, 16#01E28#) LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA + Ll, -- (16#01E29#, 16#01E29#) LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA + Lu, -- (16#01E2A#, 16#01E2A#) LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW + Ll, -- (16#01E2B#, 16#01E2B#) LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW + Lu, -- (16#01E2C#, 16#01E2C#) LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW + Ll, -- (16#01E2D#, 16#01E2D#) LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW + Lu, -- (16#01E2E#, 16#01E2E#) LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE + Ll, -- (16#01E2F#, 16#01E2F#) LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE + Lu, -- (16#01E30#, 16#01E30#) LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE + Ll, -- (16#01E31#, 16#01E31#) LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE + Lu, -- (16#01E32#, 16#01E32#) LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW + Ll, -- (16#01E33#, 16#01E33#) LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW + Lu, -- (16#01E34#, 16#01E34#) LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW + Ll, -- (16#01E35#, 16#01E35#) LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW + Lu, -- (16#01E36#, 16#01E36#) LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW + Ll, -- (16#01E37#, 16#01E37#) LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW + Lu, -- (16#01E38#, 16#01E38#) LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON + Ll, -- (16#01E39#, 16#01E39#) LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON + Lu, -- (16#01E3A#, 16#01E3A#) LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW + Ll, -- (16#01E3B#, 16#01E3B#) LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW + Lu, -- (16#01E3C#, 16#01E3C#) LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW + Ll, -- (16#01E3D#, 16#01E3D#) LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW + Lu, -- (16#01E3E#, 16#01E3E#) LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE + Ll, -- (16#01E3F#, 16#01E3F#) LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE + Lu, -- (16#01E40#, 16#01E40#) LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE + Ll, -- (16#01E41#, 16#01E41#) LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE + Lu, -- (16#01E42#, 16#01E42#) LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW + Ll, -- (16#01E43#, 16#01E43#) LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW + Lu, -- (16#01E44#, 16#01E44#) LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE + Ll, -- (16#01E45#, 16#01E45#) LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE + Lu, -- (16#01E46#, 16#01E46#) LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW + Ll, -- (16#01E47#, 16#01E47#) LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW + Lu, -- (16#01E48#, 16#01E48#) LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW + Ll, -- (16#01E49#, 16#01E49#) LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW + Lu, -- (16#01E4A#, 16#01E4A#) LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW + Ll, -- (16#01E4B#, 16#01E4B#) LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW + Lu, -- (16#01E4C#, 16#01E4C#) LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE + Ll, -- (16#01E4D#, 16#01E4D#) LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE + Lu, -- (16#01E4E#, 16#01E4E#) LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS + Ll, -- (16#01E4F#, 16#01E4F#) LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS + Lu, -- (16#01E50#, 16#01E50#) LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE + Ll, -- (16#01E51#, 16#01E51#) LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE + Lu, -- (16#01E52#, 16#01E52#) LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE + Ll, -- (16#01E53#, 16#01E53#) LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE + Lu, -- (16#01E54#, 16#01E54#) LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE + Ll, -- (16#01E55#, 16#01E55#) LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE + Lu, -- (16#01E56#, 16#01E56#) LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE + Ll, -- (16#01E57#, 16#01E57#) LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE + Lu, -- (16#01E58#, 16#01E58#) LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE + Ll, -- (16#01E59#, 16#01E59#) LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE + Lu, -- (16#01E5A#, 16#01E5A#) LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW + Ll, -- (16#01E5B#, 16#01E5B#) LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW + Lu, -- (16#01E5C#, 16#01E5C#) LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON + Ll, -- (16#01E5D#, 16#01E5D#) LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON + Lu, -- (16#01E5E#, 16#01E5E#) LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW + Ll, -- (16#01E5F#, 16#01E5F#) LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW + Lu, -- (16#01E60#, 16#01E60#) LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE + Ll, -- (16#01E61#, 16#01E61#) LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE + Lu, -- (16#01E62#, 16#01E62#) LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW + Ll, -- (16#01E63#, 16#01E63#) LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW + Lu, -- (16#01E64#, 16#01E64#) LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE + Ll, -- (16#01E65#, 16#01E65#) LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE + Lu, -- (16#01E66#, 16#01E66#) LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE + Ll, -- (16#01E67#, 16#01E67#) LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE + Lu, -- (16#01E68#, 16#01E68#) LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE + Ll, -- (16#01E69#, 16#01E69#) LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE + Lu, -- (16#01E6A#, 16#01E6A#) LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE + Ll, -- (16#01E6B#, 16#01E6B#) LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE + Lu, -- (16#01E6C#, 16#01E6C#) LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW + Ll, -- (16#01E6D#, 16#01E6D#) LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW + Lu, -- (16#01E6E#, 16#01E6E#) LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW + Ll, -- (16#01E6F#, 16#01E6F#) LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW + Lu, -- (16#01E70#, 16#01E70#) LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW + Ll, -- (16#01E71#, 16#01E71#) LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW + Lu, -- (16#01E72#, 16#01E72#) LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW + Ll, -- (16#01E73#, 16#01E73#) LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW + Lu, -- (16#01E74#, 16#01E74#) LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW + Ll, -- (16#01E75#, 16#01E75#) LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW + Lu, -- (16#01E76#, 16#01E76#) LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW + Ll, -- (16#01E77#, 16#01E77#) LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW + Lu, -- (16#01E78#, 16#01E78#) LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE + Ll, -- (16#01E79#, 16#01E79#) LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE + Lu, -- (16#01E7A#, 16#01E7A#) LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS + Ll, -- (16#01E7B#, 16#01E7B#) LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS + Lu, -- (16#01E7C#, 16#01E7C#) LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE + Ll, -- (16#01E7D#, 16#01E7D#) LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE + Lu, -- (16#01E7E#, 16#01E7E#) LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW + Ll, -- (16#01E7F#, 16#01E7F#) LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW + Lu, -- (16#01E80#, 16#01E80#) LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE + Ll, -- (16#01E81#, 16#01E81#) LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE + Lu, -- (16#01E82#, 16#01E82#) LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE + Ll, -- (16#01E83#, 16#01E83#) LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE + Lu, -- (16#01E84#, 16#01E84#) LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS + Ll, -- (16#01E85#, 16#01E85#) LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS + Lu, -- (16#01E86#, 16#01E86#) LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE + Ll, -- (16#01E87#, 16#01E87#) LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE + Lu, -- (16#01E88#, 16#01E88#) LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW + Ll, -- (16#01E89#, 16#01E89#) LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW + Lu, -- (16#01E8A#, 16#01E8A#) LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE + Ll, -- (16#01E8B#, 16#01E8B#) LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE + Lu, -- (16#01E8C#, 16#01E8C#) LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS + Ll, -- (16#01E8D#, 16#01E8D#) LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS + Lu, -- (16#01E8E#, 16#01E8E#) LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE + Ll, -- (16#01E8F#, 16#01E8F#) LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE + Lu, -- (16#01E90#, 16#01E90#) LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX + Ll, -- (16#01E91#, 16#01E91#) LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX + Lu, -- (16#01E92#, 16#01E92#) LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW + Ll, -- (16#01E93#, 16#01E93#) LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW + Lu, -- (16#01E94#, 16#01E94#) LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW + Ll, -- (16#01E95#, 16#01E9B#) LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER LONG S WITH DOT ABOVE + Lu, -- (16#01EA0#, 16#01EA0#) LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW + Ll, -- (16#01EA1#, 16#01EA1#) LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW + Lu, -- (16#01EA2#, 16#01EA2#) LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE + Ll, -- (16#01EA3#, 16#01EA3#) LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE + Lu, -- (16#01EA4#, 16#01EA4#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE + Ll, -- (16#01EA5#, 16#01EA5#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE + Lu, -- (16#01EA6#, 16#01EA6#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE + Ll, -- (16#01EA7#, 16#01EA7#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE + Lu, -- (16#01EA8#, 16#01EA8#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + Ll, -- (16#01EA9#, 16#01EA9#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + Lu, -- (16#01EAA#, 16#01EAA#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE + Ll, -- (16#01EAB#, 16#01EAB#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE + Lu, -- (16#01EAC#, 16#01EAC#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW + Ll, -- (16#01EAD#, 16#01EAD#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW + Lu, -- (16#01EAE#, 16#01EAE#) LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE + Ll, -- (16#01EAF#, 16#01EAF#) LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE + Lu, -- (16#01EB0#, 16#01EB0#) LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE + Ll, -- (16#01EB1#, 16#01EB1#) LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE + Lu, -- (16#01EB2#, 16#01EB2#) LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE + Ll, -- (16#01EB3#, 16#01EB3#) LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE + Lu, -- (16#01EB4#, 16#01EB4#) LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE + Ll, -- (16#01EB5#, 16#01EB5#) LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE + Lu, -- (16#01EB6#, 16#01EB6#) LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW + Ll, -- (16#01EB7#, 16#01EB7#) LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW + Lu, -- (16#01EB8#, 16#01EB8#) LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW + Ll, -- (16#01EB9#, 16#01EB9#) LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW + Lu, -- (16#01EBA#, 16#01EBA#) LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE + Ll, -- (16#01EBB#, 16#01EBB#) LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE + Lu, -- (16#01EBC#, 16#01EBC#) LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE + Ll, -- (16#01EBD#, 16#01EBD#) LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE + Lu, -- (16#01EBE#, 16#01EBE#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE + Ll, -- (16#01EBF#, 16#01EBF#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE + Lu, -- (16#01EC0#, 16#01EC0#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE + Ll, -- (16#01EC1#, 16#01EC1#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE + Lu, -- (16#01EC2#, 16#01EC2#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + Ll, -- (16#01EC3#, 16#01EC3#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + Lu, -- (16#01EC4#, 16#01EC4#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE + Ll, -- (16#01EC5#, 16#01EC5#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE + Lu, -- (16#01EC6#, 16#01EC6#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW + Ll, -- (16#01EC7#, 16#01EC7#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW + Lu, -- (16#01EC8#, 16#01EC8#) LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE + Ll, -- (16#01EC9#, 16#01EC9#) LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE + Lu, -- (16#01ECA#, 16#01ECA#) LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW + Ll, -- (16#01ECB#, 16#01ECB#) LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW + Lu, -- (16#01ECC#, 16#01ECC#) LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW + Ll, -- (16#01ECD#, 16#01ECD#) LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW + Lu, -- (16#01ECE#, 16#01ECE#) LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE + Ll, -- (16#01ECF#, 16#01ECF#) LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE + Lu, -- (16#01ED0#, 16#01ED0#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE + Ll, -- (16#01ED1#, 16#01ED1#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE + Lu, -- (16#01ED2#, 16#01ED2#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE + Ll, -- (16#01ED3#, 16#01ED3#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE + Lu, -- (16#01ED4#, 16#01ED4#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + Ll, -- (16#01ED5#, 16#01ED5#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + Lu, -- (16#01ED6#, 16#01ED6#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE + Ll, -- (16#01ED7#, 16#01ED7#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE + Lu, -- (16#01ED8#, 16#01ED8#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW + Ll, -- (16#01ED9#, 16#01ED9#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW + Lu, -- (16#01EDA#, 16#01EDA#) LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE + Ll, -- (16#01EDB#, 16#01EDB#) LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE + Lu, -- (16#01EDC#, 16#01EDC#) LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE + Ll, -- (16#01EDD#, 16#01EDD#) LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE + Lu, -- (16#01EDE#, 16#01EDE#) LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE + Ll, -- (16#01EDF#, 16#01EDF#) LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE + Lu, -- (16#01EE0#, 16#01EE0#) LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE + Ll, -- (16#01EE1#, 16#01EE1#) LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE + Lu, -- (16#01EE2#, 16#01EE2#) LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW + Ll, -- (16#01EE3#, 16#01EE3#) LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW + Lu, -- (16#01EE4#, 16#01EE4#) LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW + Ll, -- (16#01EE5#, 16#01EE5#) LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW + Lu, -- (16#01EE6#, 16#01EE6#) LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE + Ll, -- (16#01EE7#, 16#01EE7#) LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE + Lu, -- (16#01EE8#, 16#01EE8#) LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE + Ll, -- (16#01EE9#, 16#01EE9#) LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE + Lu, -- (16#01EEA#, 16#01EEA#) LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE + Ll, -- (16#01EEB#, 16#01EEB#) LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE + Lu, -- (16#01EEC#, 16#01EEC#) LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE + Ll, -- (16#01EED#, 16#01EED#) LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE + Lu, -- (16#01EEE#, 16#01EEE#) LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE + Ll, -- (16#01EEF#, 16#01EEF#) LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE + Lu, -- (16#01EF0#, 16#01EF0#) LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW + Ll, -- (16#01EF1#, 16#01EF1#) LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW + Lu, -- (16#01EF2#, 16#01EF2#) LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE + Ll, -- (16#01EF3#, 16#01EF3#) LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE + Lu, -- (16#01EF4#, 16#01EF4#) LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW + Ll, -- (16#01EF5#, 16#01EF5#) LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW + Lu, -- (16#01EF6#, 16#01EF6#) LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE + Ll, -- (16#01EF7#, 16#01EF7#) LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE + Lu, -- (16#01EF8#, 16#01EF8#) LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE + Ll, -- (16#01EF9#, 16#01EF9#) LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE + Ll, -- (16#01F00#, 16#01F07#) GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI + Lu, -- (16#01F08#, 16#01F0F#) GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI + Ll, -- (16#01F10#, 16#01F15#) GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA + Lu, -- (16#01F18#, 16#01F1D#) GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA + Ll, -- (16#01F20#, 16#01F27#) GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI + Lu, -- (16#01F28#, 16#01F2F#) GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI + Ll, -- (16#01F30#, 16#01F37#) GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI + Lu, -- (16#01F38#, 16#01F3F#) GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI + Ll, -- (16#01F40#, 16#01F45#) GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA + Lu, -- (16#01F48#, 16#01F4D#) GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA + Ll, -- (16#01F50#, 16#01F57#) GREEK SMALL LETTER UPSILON WITH PSILI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI + Lu, -- (16#01F59#, 16#01F59#) GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA + Lu, -- (16#01F5B#, 16#01F5B#) GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA + Lu, -- (16#01F5D#, 16#01F5D#) GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA + Lu, -- (16#01F5F#, 16#01F5F#) GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI + Ll, -- (16#01F60#, 16#01F67#) GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI + Lu, -- (16#01F68#, 16#01F6F#) GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI + Ll, -- (16#01F70#, 16#01F7D#) GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA + Ll, -- (16#01F80#, 16#01F87#) GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + Lt, -- (16#01F88#, 16#01F8F#) GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + Ll, -- (16#01F90#, 16#01F97#) GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + Lt, -- (16#01F98#, 16#01F9F#) GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + Ll, -- (16#01FA0#, 16#01FA7#) GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + Lt, -- (16#01FA8#, 16#01FAF#) GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + Ll, -- (16#01FB0#, 16#01FB4#) GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI + Ll, -- (16#01FB6#, 16#01FB7#) GREEK SMALL LETTER ALPHA WITH PERISPOMENI .. GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI + Lu, -- (16#01FB8#, 16#01FBB#) GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH OXIA + Lt, -- (16#01FBC#, 16#01FBC#) GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI + Sk, -- (16#01FBD#, 16#01FBD#) GREEK KORONIS .. GREEK KORONIS + Ll, -- (16#01FBE#, 16#01FBE#) GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI + Sk, -- (16#01FBF#, 16#01FC1#) GREEK PSILI .. GREEK DIALYTIKA AND PERISPOMENI + Ll, -- (16#01FC2#, 16#01FC4#) GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI + Ll, -- (16#01FC6#, 16#01FC7#) GREEK SMALL LETTER ETA WITH PERISPOMENI .. GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI + Lu, -- (16#01FC8#, 16#01FCB#) GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA + Lt, -- (16#01FCC#, 16#01FCC#) GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI + Sk, -- (16#01FCD#, 16#01FCF#) GREEK PSILI AND VARIA .. GREEK PSILI AND PERISPOMENI + Ll, -- (16#01FD0#, 16#01FD3#) GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA + Ll, -- (16#01FD6#, 16#01FD7#) GREEK SMALL LETTER IOTA WITH PERISPOMENI .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI + Lu, -- (16#01FD8#, 16#01FDB#) GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH OXIA + Sk, -- (16#01FDD#, 16#01FDF#) GREEK DASIA AND VARIA .. GREEK DASIA AND PERISPOMENI + Ll, -- (16#01FE0#, 16#01FE7#) GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI + Lu, -- (16#01FE8#, 16#01FEC#) GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER RHO WITH DASIA + Sk, -- (16#01FED#, 16#01FEF#) GREEK DIALYTIKA AND VARIA .. GREEK VARIA + Ll, -- (16#01FF2#, 16#01FF4#) GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI + Ll, -- (16#01FF6#, 16#01FF7#) GREEK SMALL LETTER OMEGA WITH PERISPOMENI .. GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI + Lu, -- (16#01FF8#, 16#01FFB#) GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA + Lt, -- (16#01FFC#, 16#01FFC#) GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI + Sk, -- (16#01FFD#, 16#01FFE#) GREEK OXIA .. GREEK DASIA + Zs, -- (16#02000#, 16#0200B#) EN QUAD .. ZERO WIDTH SPACE + Cf, -- (16#0200C#, 16#0200F#) ZERO WIDTH NON-JOINER .. RIGHT-TO-LEFT MARK + Pd, -- (16#02010#, 16#02015#) HYPHEN .. HORIZONTAL BAR + Po, -- (16#02016#, 16#02017#) DOUBLE VERTICAL LINE .. DOUBLE LOW LINE + Pi, -- (16#02018#, 16#02018#) LEFT SINGLE QUOTATION MARK .. LEFT SINGLE QUOTATION MARK + Pf, -- (16#02019#, 16#02019#) RIGHT SINGLE QUOTATION MARK .. RIGHT SINGLE QUOTATION MARK + Ps, -- (16#0201A#, 16#0201A#) SINGLE LOW-9 QUOTATION MARK .. SINGLE LOW-9 QUOTATION MARK + Pi, -- (16#0201B#, 16#0201C#) SINGLE HIGH-REVERSED-9 QUOTATION MARK .. LEFT DOUBLE QUOTATION MARK + Pf, -- (16#0201D#, 16#0201D#) RIGHT DOUBLE QUOTATION MARK .. RIGHT DOUBLE QUOTATION MARK + Ps, -- (16#0201E#, 16#0201E#) DOUBLE LOW-9 QUOTATION MARK .. DOUBLE LOW-9 QUOTATION MARK + Pi, -- (16#0201F#, 16#0201F#) DOUBLE HIGH-REVERSED-9 QUOTATION MARK .. DOUBLE HIGH-REVERSED-9 QUOTATION MARK + Po, -- (16#02020#, 16#02027#) DAGGER .. HYPHENATION POINT + Zl, -- (16#02028#, 16#02028#) LINE SEPARATOR .. LINE SEPARATOR + Zp, -- (16#02029#, 16#02029#) PARAGRAPH SEPARATOR .. PARAGRAPH SEPARATOR + Cf, -- (16#0202A#, 16#0202E#) LEFT-TO-RIGHT EMBEDDING .. RIGHT-TO-LEFT OVERRIDE + Zs, -- (16#0202F#, 16#0202F#) NARROW NO-BREAK SPACE .. NARROW NO-BREAK SPACE + Po, -- (16#02030#, 16#02038#) PER MILLE SIGN .. CARET + Pi, -- (16#02039#, 16#02039#) SINGLE LEFT-POINTING ANGLE QUOTATION MARK .. SINGLE LEFT-POINTING ANGLE QUOTATION MARK + Pf, -- (16#0203A#, 16#0203A#) SINGLE RIGHT-POINTING ANGLE QUOTATION MARK .. SINGLE RIGHT-POINTING ANGLE QUOTATION MARK + Po, -- (16#0203B#, 16#0203E#) REFERENCE MARK .. OVERLINE + Pc, -- (16#0203F#, 16#02040#) UNDERTIE .. CHARACTER TIE + Po, -- (16#02041#, 16#02043#) CARET INSERTION POINT .. HYPHEN BULLET + Sm, -- (16#02044#, 16#02044#) FRACTION SLASH .. FRACTION SLASH + Ps, -- (16#02045#, 16#02045#) LEFT SQUARE BRACKET WITH QUILL .. LEFT SQUARE BRACKET WITH QUILL + Pe, -- (16#02046#, 16#02046#) RIGHT SQUARE BRACKET WITH QUILL .. RIGHT SQUARE BRACKET WITH QUILL + Po, -- (16#02047#, 16#02051#) DOUBLE QUESTION MARK .. TWO ASTERISKS ALIGNED VERTICALLY + Sm, -- (16#02052#, 16#02052#) COMMERCIAL MINUS SIGN .. COMMERCIAL MINUS SIGN + Po, -- (16#02053#, 16#02053#) SWUNG DASH .. SWUNG DASH + Pc, -- (16#02054#, 16#02054#) INVERTED UNDERTIE .. INVERTED UNDERTIE + Po, -- (16#02057#, 16#02057#) QUADRUPLE PRIME .. QUADRUPLE PRIME + Zs, -- (16#0205F#, 16#0205F#) MEDIUM MATHEMATICAL SPACE .. MEDIUM MATHEMATICAL SPACE + Cf, -- (16#02060#, 16#02063#) WORD JOINER .. INVISIBLE SEPARATOR + Cf, -- (16#0206A#, 16#0206F#) INHIBIT SYMMETRIC SWAPPING .. NOMINAL DIGIT SHAPES + No, -- (16#02070#, 16#02070#) SUPERSCRIPT ZERO .. SUPERSCRIPT ZERO + Ll, -- (16#02071#, 16#02071#) SUPERSCRIPT LATIN SMALL LETTER I .. SUPERSCRIPT LATIN SMALL LETTER I + No, -- (16#02074#, 16#02079#) SUPERSCRIPT FOUR .. SUPERSCRIPT NINE + Sm, -- (16#0207A#, 16#0207C#) SUPERSCRIPT PLUS SIGN .. SUPERSCRIPT EQUALS SIGN + Ps, -- (16#0207D#, 16#0207D#) SUPERSCRIPT LEFT PARENTHESIS .. SUPERSCRIPT LEFT PARENTHESIS + Pe, -- (16#0207E#, 16#0207E#) SUPERSCRIPT RIGHT PARENTHESIS .. SUPERSCRIPT RIGHT PARENTHESIS + Ll, -- (16#0207F#, 16#0207F#) SUPERSCRIPT LATIN SMALL LETTER N .. SUPERSCRIPT LATIN SMALL LETTER N + No, -- (16#02080#, 16#02089#) SUBSCRIPT ZERO .. SUBSCRIPT NINE + Sm, -- (16#0208A#, 16#0208C#) SUBSCRIPT PLUS SIGN .. SUBSCRIPT EQUALS SIGN + Ps, -- (16#0208D#, 16#0208D#) SUBSCRIPT LEFT PARENTHESIS .. SUBSCRIPT LEFT PARENTHESIS + Pe, -- (16#0208E#, 16#0208E#) SUBSCRIPT RIGHT PARENTHESIS .. SUBSCRIPT RIGHT PARENTHESIS + Sc, -- (16#020A0#, 16#020B1#) EURO-CURRENCY SIGN .. PESO SIGN + Mn, -- (16#020D0#, 16#020DC#) COMBINING LEFT HARPOON ABOVE .. COMBINING FOUR DOTS ABOVE + Me, -- (16#020DD#, 16#020E0#) COMBINING ENCLOSING CIRCLE .. COMBINING ENCLOSING CIRCLE BACKSLASH + Mn, -- (16#020E1#, 16#020E1#) COMBINING LEFT RIGHT ARROW ABOVE .. COMBINING LEFT RIGHT ARROW ABOVE + Me, -- (16#020E2#, 16#020E4#) COMBINING ENCLOSING SCREEN .. COMBINING ENCLOSING UPWARD POINTING TRIANGLE + Mn, -- (16#020E5#, 16#020EA#) COMBINING REVERSE SOLIDUS OVERLAY .. COMBINING LEFTWARDS ARROW OVERLAY + So, -- (16#02100#, 16#02101#) ACCOUNT OF .. ADDRESSED TO THE SUBJECT + Lu, -- (16#02102#, 16#02102#) DOUBLE-STRUCK CAPITAL C .. DOUBLE-STRUCK CAPITAL C + So, -- (16#02103#, 16#02106#) DEGREE CELSIUS .. CADA UNA + Lu, -- (16#02107#, 16#02107#) EULER CONSTANT .. EULER CONSTANT + So, -- (16#02108#, 16#02109#) SCRUPLE .. DEGREE FAHRENHEIT + Ll, -- (16#0210A#, 16#0210A#) SCRIPT SMALL G .. SCRIPT SMALL G + Lu, -- (16#0210B#, 16#0210D#) SCRIPT CAPITAL H .. DOUBLE-STRUCK CAPITAL H + Ll, -- (16#0210E#, 16#0210F#) PLANCK CONSTANT .. PLANCK CONSTANT OVER TWO PI + Lu, -- (16#02110#, 16#02112#) SCRIPT CAPITAL I .. SCRIPT CAPITAL L + Ll, -- (16#02113#, 16#02113#) SCRIPT SMALL L .. SCRIPT SMALL L + So, -- (16#02114#, 16#02114#) L B BAR SYMBOL .. L B BAR SYMBOL + Lu, -- (16#02115#, 16#02115#) DOUBLE-STRUCK CAPITAL N .. DOUBLE-STRUCK CAPITAL N + So, -- (16#02116#, 16#02118#) NUMERO SIGN .. SCRIPT CAPITAL P + Lu, -- (16#02119#, 16#0211D#) DOUBLE-STRUCK CAPITAL P .. DOUBLE-STRUCK CAPITAL R + So, -- (16#0211E#, 16#02123#) PRESCRIPTION TAKE .. VERSICLE + Lu, -- (16#02124#, 16#02124#) DOUBLE-STRUCK CAPITAL Z .. DOUBLE-STRUCK CAPITAL Z + So, -- (16#02125#, 16#02125#) OUNCE SIGN .. OUNCE SIGN + Lu, -- (16#02126#, 16#02126#) OHM SIGN .. OHM SIGN + So, -- (16#02127#, 16#02127#) INVERTED OHM SIGN .. INVERTED OHM SIGN + Lu, -- (16#02128#, 16#02128#) BLACK-LETTER CAPITAL Z .. BLACK-LETTER CAPITAL Z + So, -- (16#02129#, 16#02129#) TURNED GREEK SMALL LETTER IOTA .. TURNED GREEK SMALL LETTER IOTA + Lu, -- (16#0212A#, 16#0212D#) KELVIN SIGN .. BLACK-LETTER CAPITAL C + So, -- (16#0212E#, 16#0212E#) ESTIMATED SYMBOL .. ESTIMATED SYMBOL + Ll, -- (16#0212F#, 16#0212F#) SCRIPT SMALL E .. SCRIPT SMALL E + Lu, -- (16#02130#, 16#02131#) SCRIPT CAPITAL E .. SCRIPT CAPITAL F + So, -- (16#02132#, 16#02132#) TURNED CAPITAL F .. TURNED CAPITAL F + Lu, -- (16#02133#, 16#02133#) SCRIPT CAPITAL M .. SCRIPT CAPITAL M + Ll, -- (16#02134#, 16#02134#) SCRIPT SMALL O .. SCRIPT SMALL O + Lo, -- (16#02135#, 16#02138#) ALEF SYMBOL .. DALET SYMBOL + Ll, -- (16#02139#, 16#02139#) INFORMATION SOURCE .. INFORMATION SOURCE + So, -- (16#0213A#, 16#0213B#) ROTATED CAPITAL Q .. FACSIMILE SIGN + Ll, -- (16#0213D#, 16#0213D#) DOUBLE-STRUCK SMALL GAMMA .. DOUBLE-STRUCK SMALL GAMMA + Lu, -- (16#0213E#, 16#0213F#) DOUBLE-STRUCK CAPITAL GAMMA .. DOUBLE-STRUCK CAPITAL PI + Sm, -- (16#02140#, 16#02144#) DOUBLE-STRUCK N-ARY SUMMATION .. TURNED SANS-SERIF CAPITAL Y + Lu, -- (16#02145#, 16#02145#) DOUBLE-STRUCK ITALIC CAPITAL D .. DOUBLE-STRUCK ITALIC CAPITAL D + Ll, -- (16#02146#, 16#02149#) DOUBLE-STRUCK ITALIC SMALL D .. DOUBLE-STRUCK ITALIC SMALL J + So, -- (16#0214A#, 16#0214A#) PROPERTY LINE .. PROPERTY LINE + Sm, -- (16#0214B#, 16#0214B#) TURNED AMPERSAND .. TURNED AMPERSAND + No, -- (16#02153#, 16#0215F#) VULGAR FRACTION ONE THIRD .. FRACTION NUMERATOR ONE + Nl, -- (16#02160#, 16#02183#) ROMAN NUMERAL ONE .. ROMAN NUMERAL REVERSED ONE HUNDRED + Sm, -- (16#02190#, 16#02194#) LEFTWARDS ARROW .. LEFT RIGHT ARROW + So, -- (16#02195#, 16#02199#) UP DOWN ARROW .. SOUTH WEST ARROW + Sm, -- (16#0219A#, 16#0219B#) LEFTWARDS ARROW WITH STROKE .. RIGHTWARDS ARROW WITH STROKE + So, -- (16#0219C#, 16#0219F#) LEFTWARDS WAVE ARROW .. UPWARDS TWO HEADED ARROW + Sm, -- (16#021A0#, 16#021A0#) RIGHTWARDS TWO HEADED ARROW .. RIGHTWARDS TWO HEADED ARROW + So, -- (16#021A1#, 16#021A2#) DOWNWARDS TWO HEADED ARROW .. LEFTWARDS ARROW WITH TAIL + Sm, -- (16#021A3#, 16#021A3#) RIGHTWARDS ARROW WITH TAIL .. RIGHTWARDS ARROW WITH TAIL + So, -- (16#021A4#, 16#021A5#) LEFTWARDS ARROW FROM BAR .. UPWARDS ARROW FROM BAR + Sm, -- (16#021A6#, 16#021A6#) RIGHTWARDS ARROW FROM BAR .. RIGHTWARDS ARROW FROM BAR + So, -- (16#021A7#, 16#021AD#) DOWNWARDS ARROW FROM BAR .. LEFT RIGHT WAVE ARROW + Sm, -- (16#021AE#, 16#021AE#) LEFT RIGHT ARROW WITH STROKE .. LEFT RIGHT ARROW WITH STROKE + So, -- (16#021AF#, 16#021CD#) DOWNWARDS ZIGZAG ARROW .. LEFTWARDS DOUBLE ARROW WITH STROKE + Sm, -- (16#021CE#, 16#021CF#) LEFT RIGHT DOUBLE ARROW WITH STROKE .. RIGHTWARDS DOUBLE ARROW WITH STROKE + So, -- (16#021D0#, 16#021D1#) LEFTWARDS DOUBLE ARROW .. UPWARDS DOUBLE ARROW + Sm, -- (16#021D2#, 16#021D2#) RIGHTWARDS DOUBLE ARROW .. RIGHTWARDS DOUBLE ARROW + So, -- (16#021D3#, 16#021D3#) DOWNWARDS DOUBLE ARROW .. DOWNWARDS DOUBLE ARROW + Sm, -- (16#021D4#, 16#021D4#) LEFT RIGHT DOUBLE ARROW .. LEFT RIGHT DOUBLE ARROW + So, -- (16#021D5#, 16#021F3#) UP DOWN DOUBLE ARROW .. UP DOWN WHITE ARROW + Sm, -- (16#021F4#, 16#022FF#) RIGHT ARROW WITH SMALL CIRCLE .. Z NOTATION BAG MEMBERSHIP + So, -- (16#02300#, 16#02307#) DIAMETER SIGN .. WAVY LINE + Sm, -- (16#02308#, 16#0230B#) LEFT CEILING .. RIGHT FLOOR + So, -- (16#0230C#, 16#0231F#) BOTTOM RIGHT CROP .. BOTTOM RIGHT CORNER + Sm, -- (16#02320#, 16#02321#) TOP HALF INTEGRAL .. BOTTOM HALF INTEGRAL + So, -- (16#02322#, 16#02328#) FROWN .. KEYBOARD + Ps, -- (16#02329#, 16#02329#) LEFT-POINTING ANGLE BRACKET .. LEFT-POINTING ANGLE BRACKET + Pe, -- (16#0232A#, 16#0232A#) RIGHT-POINTING ANGLE BRACKET .. RIGHT-POINTING ANGLE BRACKET + So, -- (16#0232B#, 16#0237B#) ERASE TO THE LEFT .. NOT CHECK MARK + Sm, -- (16#0237C#, 16#0237C#) RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW .. RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW + So, -- (16#0237D#, 16#0239A#) SHOULDERED OPEN BOX .. CLEAR SCREEN SYMBOL + Sm, -- (16#0239B#, 16#023B3#) LEFT PARENTHESIS UPPER HOOK .. SUMMATION BOTTOM + Ps, -- (16#023B4#, 16#023B4#) TOP SQUARE BRACKET .. TOP SQUARE BRACKET + Pe, -- (16#023B5#, 16#023B5#) BOTTOM SQUARE BRACKET .. BOTTOM SQUARE BRACKET + Po, -- (16#023B6#, 16#023B6#) BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET .. BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET + So, -- (16#023B7#, 16#023D0#) RADICAL SYMBOL BOTTOM .. VERTICAL LINE EXTENSION + So, -- (16#02400#, 16#02426#) SYMBOL FOR NULL .. SYMBOL FOR SUBSTITUTE FORM TWO + So, -- (16#02440#, 16#0244A#) OCR HOOK .. OCR DOUBLE BACKSLASH + No, -- (16#02460#, 16#0249B#) CIRCLED DIGIT ONE .. NUMBER TWENTY FULL STOP + So, -- (16#0249C#, 16#024E9#) PARENTHESIZED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z + No, -- (16#024EA#, 16#024FF#) CIRCLED DIGIT ZERO .. NEGATIVE CIRCLED DIGIT ZERO + So, -- (16#02500#, 16#025B6#) BOX DRAWINGS LIGHT HORIZONTAL .. BLACK RIGHT-POINTING TRIANGLE + Sm, -- (16#025B7#, 16#025B7#) WHITE RIGHT-POINTING TRIANGLE .. WHITE RIGHT-POINTING TRIANGLE + So, -- (16#025B8#, 16#025C0#) BLACK RIGHT-POINTING SMALL TRIANGLE .. BLACK LEFT-POINTING TRIANGLE + Sm, -- (16#025C1#, 16#025C1#) WHITE LEFT-POINTING TRIANGLE .. WHITE LEFT-POINTING TRIANGLE + So, -- (16#025C2#, 16#025F7#) BLACK LEFT-POINTING SMALL TRIANGLE .. WHITE CIRCLE WITH UPPER RIGHT QUADRANT + Sm, -- (16#025F8#, 16#025FF#) UPPER LEFT TRIANGLE .. LOWER RIGHT TRIANGLE + So, -- (16#02600#, 16#02617#) BLACK SUN WITH RAYS .. BLACK SHOGI PIECE + So, -- (16#02619#, 16#0266E#) REVERSED ROTATED FLORAL HEART BULLET .. MUSIC NATURAL SIGN + Sm, -- (16#0266F#, 16#0266F#) MUSIC SHARP SIGN .. MUSIC SHARP SIGN + So, -- (16#02670#, 16#0267D#) WEST SYRIAC CROSS .. PARTIALLY-RECYCLED PAPER SYMBOL + So, -- (16#02680#, 16#02691#) DIE FACE-1 .. BLACK FLAG + So, -- (16#026A0#, 16#026A1#) WARNING SIGN .. HIGH VOLTAGE SIGN + So, -- (16#02701#, 16#02704#) UPPER BLADE SCISSORS .. WHITE SCISSORS + So, -- (16#02706#, 16#02709#) TELEPHONE LOCATION SIGN .. ENVELOPE + So, -- (16#0270C#, 16#02727#) VICTORY HAND .. WHITE FOUR POINTED STAR + So, -- (16#02729#, 16#0274B#) STRESS OUTLINED WHITE STAR .. HEAVY EIGHT TEARDROP-SPOKED PROPELLER ASTERISK + So, -- (16#0274D#, 16#0274D#) SHADOWED WHITE CIRCLE .. SHADOWED WHITE CIRCLE + So, -- (16#0274F#, 16#02752#) LOWER RIGHT DROP-SHADOWED WHITE SQUARE .. UPPER RIGHT SHADOWED WHITE SQUARE + So, -- (16#02756#, 16#02756#) BLACK DIAMOND MINUS WHITE X .. BLACK DIAMOND MINUS WHITE X + So, -- (16#02758#, 16#0275E#) LIGHT VERTICAL BAR .. HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT + So, -- (16#02761#, 16#02767#) CURVED STEM PARAGRAPH SIGN ORNAMENT .. ROTATED FLORAL HEART BULLET + Ps, -- (16#02768#, 16#02768#) MEDIUM LEFT PARENTHESIS ORNAMENT .. MEDIUM LEFT PARENTHESIS ORNAMENT + Pe, -- (16#02769#, 16#02769#) MEDIUM RIGHT PARENTHESIS ORNAMENT .. MEDIUM RIGHT PARENTHESIS ORNAMENT + Ps, -- (16#0276A#, 16#0276A#) MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT + Pe, -- (16#0276B#, 16#0276B#) MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT + Ps, -- (16#0276C#, 16#0276C#) MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT + Pe, -- (16#0276D#, 16#0276D#) MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT + Ps, -- (16#0276E#, 16#0276E#) HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT + Pe, -- (16#0276F#, 16#0276F#) HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT + Ps, -- (16#02770#, 16#02770#) HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT + Pe, -- (16#02771#, 16#02771#) HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT + Ps, -- (16#02772#, 16#02772#) LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT + Pe, -- (16#02773#, 16#02773#) LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT + Ps, -- (16#02774#, 16#02774#) MEDIUM LEFT CURLY BRACKET ORNAMENT .. MEDIUM LEFT CURLY BRACKET ORNAMENT + Pe, -- (16#02775#, 16#02775#) MEDIUM RIGHT CURLY BRACKET ORNAMENT .. MEDIUM RIGHT CURLY BRACKET ORNAMENT + No, -- (16#02776#, 16#02793#) DINGBAT NEGATIVE CIRCLED DIGIT ONE .. DINGBAT NEGATIVE CIRCLED SANS-SERIF NUMBER TEN + So, -- (16#02794#, 16#02794#) HEAVY WIDE-HEADED RIGHTWARDS ARROW .. HEAVY WIDE-HEADED RIGHTWARDS ARROW + So, -- (16#02798#, 16#027AF#) HEAVY SOUTH EAST ARROW .. NOTCHED LOWER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW + So, -- (16#027B1#, 16#027BE#) NOTCHED UPPER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW .. OPEN-OUTLINED RIGHTWARDS ARROW + Sm, -- (16#027D0#, 16#027E5#) WHITE DIAMOND WITH CENTRED DOT .. WHITE SQUARE WITH RIGHTWARDS TICK + Ps, -- (16#027E6#, 16#027E6#) MATHEMATICAL LEFT WHITE SQUARE BRACKET .. MATHEMATICAL LEFT WHITE SQUARE BRACKET + Pe, -- (16#027E7#, 16#027E7#) MATHEMATICAL RIGHT WHITE SQUARE BRACKET .. MATHEMATICAL RIGHT WHITE SQUARE BRACKET + Ps, -- (16#027E8#, 16#027E8#) MATHEMATICAL LEFT ANGLE BRACKET .. MATHEMATICAL LEFT ANGLE BRACKET + Pe, -- (16#027E9#, 16#027E9#) MATHEMATICAL RIGHT ANGLE BRACKET .. MATHEMATICAL RIGHT ANGLE BRACKET + Ps, -- (16#027EA#, 16#027EA#) MATHEMATICAL LEFT DOUBLE ANGLE BRACKET .. MATHEMATICAL LEFT DOUBLE ANGLE BRACKET + Pe, -- (16#027EB#, 16#027EB#) MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET .. MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET + Sm, -- (16#027F0#, 16#027FF#) UPWARDS QUADRUPLE ARROW .. LONG RIGHTWARDS SQUIGGLE ARROW + So, -- (16#02800#, 16#028FF#) BRAILLE PATTERN BLANK .. BRAILLE PATTERN DOTS-12345678 + Sm, -- (16#02900#, 16#02982#) RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE .. Z NOTATION TYPE COLON + Ps, -- (16#02983#, 16#02983#) LEFT WHITE CURLY BRACKET .. LEFT WHITE CURLY BRACKET + Pe, -- (16#02984#, 16#02984#) RIGHT WHITE CURLY BRACKET .. RIGHT WHITE CURLY BRACKET + Ps, -- (16#02985#, 16#02985#) LEFT WHITE PARENTHESIS .. LEFT WHITE PARENTHESIS + Pe, -- (16#02986#, 16#02986#) RIGHT WHITE PARENTHESIS .. RIGHT WHITE PARENTHESIS + Ps, -- (16#02987#, 16#02987#) Z NOTATION LEFT IMAGE BRACKET .. Z NOTATION LEFT IMAGE BRACKET + Pe, -- (16#02988#, 16#02988#) Z NOTATION RIGHT IMAGE BRACKET .. Z NOTATION RIGHT IMAGE BRACKET + Ps, -- (16#02989#, 16#02989#) Z NOTATION LEFT BINDING BRACKET .. Z NOTATION LEFT BINDING BRACKET + Pe, -- (16#0298A#, 16#0298A#) Z NOTATION RIGHT BINDING BRACKET .. Z NOTATION RIGHT BINDING BRACKET + Ps, -- (16#0298B#, 16#0298B#) LEFT SQUARE BRACKET WITH UNDERBAR .. LEFT SQUARE BRACKET WITH UNDERBAR + Pe, -- (16#0298C#, 16#0298C#) RIGHT SQUARE BRACKET WITH UNDERBAR .. RIGHT SQUARE BRACKET WITH UNDERBAR + Ps, -- (16#0298D#, 16#0298D#) LEFT SQUARE BRACKET WITH TICK IN TOP CORNER .. LEFT SQUARE BRACKET WITH TICK IN TOP CORNER + Pe, -- (16#0298E#, 16#0298E#) RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER + Ps, -- (16#0298F#, 16#0298F#) LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER + Pe, -- (16#02990#, 16#02990#) RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER .. RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER + Ps, -- (16#02991#, 16#02991#) LEFT ANGLE BRACKET WITH DOT .. LEFT ANGLE BRACKET WITH DOT + Pe, -- (16#02992#, 16#02992#) RIGHT ANGLE BRACKET WITH DOT .. RIGHT ANGLE BRACKET WITH DOT + Ps, -- (16#02993#, 16#02993#) LEFT ARC LESS-THAN BRACKET .. LEFT ARC LESS-THAN BRACKET + Pe, -- (16#02994#, 16#02994#) RIGHT ARC GREATER-THAN BRACKET .. RIGHT ARC GREATER-THAN BRACKET + Ps, -- (16#02995#, 16#02995#) DOUBLE LEFT ARC GREATER-THAN BRACKET .. DOUBLE LEFT ARC GREATER-THAN BRACKET + Pe, -- (16#02996#, 16#02996#) DOUBLE RIGHT ARC LESS-THAN BRACKET .. DOUBLE RIGHT ARC LESS-THAN BRACKET + Ps, -- (16#02997#, 16#02997#) LEFT BLACK TORTOISE SHELL BRACKET .. LEFT BLACK TORTOISE SHELL BRACKET + Pe, -- (16#02998#, 16#02998#) RIGHT BLACK TORTOISE SHELL BRACKET .. RIGHT BLACK TORTOISE SHELL BRACKET + Sm, -- (16#02999#, 16#029D7#) DOTTED FENCE .. BLACK HOURGLASS + Ps, -- (16#029D8#, 16#029D8#) LEFT WIGGLY FENCE .. LEFT WIGGLY FENCE + Pe, -- (16#029D9#, 16#029D9#) RIGHT WIGGLY FENCE .. RIGHT WIGGLY FENCE + Ps, -- (16#029DA#, 16#029DA#) LEFT DOUBLE WIGGLY FENCE .. LEFT DOUBLE WIGGLY FENCE + Pe, -- (16#029DB#, 16#029DB#) RIGHT DOUBLE WIGGLY FENCE .. RIGHT DOUBLE WIGGLY FENCE + Sm, -- (16#029DC#, 16#029FB#) INCOMPLETE INFINITY .. TRIPLE PLUS + Ps, -- (16#029FC#, 16#029FC#) LEFT-POINTING CURVED ANGLE BRACKET .. LEFT-POINTING CURVED ANGLE BRACKET + Pe, -- (16#029FD#, 16#029FD#) RIGHT-POINTING CURVED ANGLE BRACKET .. RIGHT-POINTING CURVED ANGLE BRACKET + Sm, -- (16#029FE#, 16#02AFF#) TINY .. N-ARY WHITE VERTICAL BAR + So, -- (16#02B00#, 16#02B0D#) NORTH EAST WHITE ARROW .. UP DOWN BLACK ARROW + So, -- (16#02E80#, 16#02E99#) CJK RADICAL REPEAT .. CJK RADICAL RAP + So, -- (16#02E9B#, 16#02EF3#) CJK RADICAL CHOKE .. CJK RADICAL C-SIMPLIFIED TURTLE + So, -- (16#02F00#, 16#02FD5#) KANGXI RADICAL ONE .. KANGXI RADICAL FLUTE + So, -- (16#02FF0#, 16#02FFB#) IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT .. IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID + Zs, -- (16#03000#, 16#03000#) IDEOGRAPHIC SPACE .. IDEOGRAPHIC SPACE + Po, -- (16#03001#, 16#03003#) IDEOGRAPHIC COMMA .. DITTO MARK + So, -- (16#03004#, 16#03004#) JAPANESE INDUSTRIAL STANDARD SYMBOL .. JAPANESE INDUSTRIAL STANDARD SYMBOL + Lm, -- (16#03005#, 16#03005#) IDEOGRAPHIC ITERATION MARK .. IDEOGRAPHIC ITERATION MARK + Lo, -- (16#03006#, 16#03006#) IDEOGRAPHIC CLOSING MARK .. IDEOGRAPHIC CLOSING MARK + Nl, -- (16#03007#, 16#03007#) IDEOGRAPHIC NUMBER ZERO .. IDEOGRAPHIC NUMBER ZERO + Ps, -- (16#03008#, 16#03008#) LEFT ANGLE BRACKET .. LEFT ANGLE BRACKET + Pe, -- (16#03009#, 16#03009#) RIGHT ANGLE BRACKET .. RIGHT ANGLE BRACKET + Ps, -- (16#0300A#, 16#0300A#) LEFT DOUBLE ANGLE BRACKET .. LEFT DOUBLE ANGLE BRACKET + Pe, -- (16#0300B#, 16#0300B#) RIGHT DOUBLE ANGLE BRACKET .. RIGHT DOUBLE ANGLE BRACKET + Ps, -- (16#0300C#, 16#0300C#) LEFT CORNER BRACKET .. LEFT CORNER BRACKET + Pe, -- (16#0300D#, 16#0300D#) RIGHT CORNER BRACKET .. RIGHT CORNER BRACKET + Ps, -- (16#0300E#, 16#0300E#) LEFT WHITE CORNER BRACKET .. LEFT WHITE CORNER BRACKET + Pe, -- (16#0300F#, 16#0300F#) RIGHT WHITE CORNER BRACKET .. RIGHT WHITE CORNER BRACKET + Ps, -- (16#03010#, 16#03010#) LEFT BLACK LENTICULAR BRACKET .. LEFT BLACK LENTICULAR BRACKET + Pe, -- (16#03011#, 16#03011#) RIGHT BLACK LENTICULAR BRACKET .. RIGHT BLACK LENTICULAR BRACKET + So, -- (16#03012#, 16#03013#) POSTAL MARK .. GETA MARK + Ps, -- (16#03014#, 16#03014#) LEFT TORTOISE SHELL BRACKET .. LEFT TORTOISE SHELL BRACKET + Pe, -- (16#03015#, 16#03015#) RIGHT TORTOISE SHELL BRACKET .. RIGHT TORTOISE SHELL BRACKET + Ps, -- (16#03016#, 16#03016#) LEFT WHITE LENTICULAR BRACKET .. LEFT WHITE LENTICULAR BRACKET + Pe, -- (16#03017#, 16#03017#) RIGHT WHITE LENTICULAR BRACKET .. RIGHT WHITE LENTICULAR BRACKET + Ps, -- (16#03018#, 16#03018#) LEFT WHITE TORTOISE SHELL BRACKET .. LEFT WHITE TORTOISE SHELL BRACKET + Pe, -- (16#03019#, 16#03019#) RIGHT WHITE TORTOISE SHELL BRACKET .. RIGHT WHITE TORTOISE SHELL BRACKET + Ps, -- (16#0301A#, 16#0301A#) LEFT WHITE SQUARE BRACKET .. LEFT WHITE SQUARE BRACKET + Pe, -- (16#0301B#, 16#0301B#) RIGHT WHITE SQUARE BRACKET .. RIGHT WHITE SQUARE BRACKET + Pd, -- (16#0301C#, 16#0301C#) WAVE DASH .. WAVE DASH + Ps, -- (16#0301D#, 16#0301D#) REVERSED DOUBLE PRIME QUOTATION MARK .. REVERSED DOUBLE PRIME QUOTATION MARK + Pe, -- (16#0301E#, 16#0301F#) DOUBLE PRIME QUOTATION MARK .. LOW DOUBLE PRIME QUOTATION MARK + So, -- (16#03020#, 16#03020#) POSTAL MARK FACE .. POSTAL MARK FACE + Nl, -- (16#03021#, 16#03029#) HANGZHOU NUMERAL ONE .. HANGZHOU NUMERAL NINE + Mn, -- (16#0302A#, 16#0302F#) IDEOGRAPHIC LEVEL TONE MARK .. HANGUL DOUBLE DOT TONE MARK + Pd, -- (16#03030#, 16#03030#) WAVY DASH .. WAVY DASH + Lm, -- (16#03031#, 16#03035#) VERTICAL KANA REPEAT MARK .. VERTICAL KANA REPEAT MARK LOWER HALF + So, -- (16#03036#, 16#03037#) CIRCLED POSTAL MARK .. IDEOGRAPHIC TELEGRAPH LINE FEED SEPARATOR SYMBOL + Nl, -- (16#03038#, 16#0303A#) HANGZHOU NUMERAL TEN .. HANGZHOU NUMERAL THIRTY + Lm, -- (16#0303B#, 16#0303B#) VERTICAL IDEOGRAPHIC ITERATION MARK .. VERTICAL IDEOGRAPHIC ITERATION MARK + Lo, -- (16#0303C#, 16#0303C#) MASU MARK .. MASU MARK + Po, -- (16#0303D#, 16#0303D#) PART ALTERNATION MARK .. PART ALTERNATION MARK + So, -- (16#0303E#, 16#0303F#) IDEOGRAPHIC VARIATION INDICATOR .. IDEOGRAPHIC HALF FILL SPACE + Lo, -- (16#03041#, 16#03096#) HIRAGANA LETTER SMALL A .. HIRAGANA LETTER SMALL KE + Mn, -- (16#03099#, 16#0309A#) COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK .. COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK + Sk, -- (16#0309B#, 16#0309C#) KATAKANA-HIRAGANA VOICED SOUND MARK .. KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK + Lm, -- (16#0309D#, 16#0309E#) HIRAGANA ITERATION MARK .. HIRAGANA VOICED ITERATION MARK + Lo, -- (16#0309F#, 16#0309F#) HIRAGANA DIGRAPH YORI .. HIRAGANA DIGRAPH YORI + Pd, -- (16#030A0#, 16#030A0#) KATAKANA-HIRAGANA DOUBLE HYPHEN .. KATAKANA-HIRAGANA DOUBLE HYPHEN + Lo, -- (16#030A1#, 16#030FA#) KATAKANA LETTER SMALL A .. KATAKANA LETTER VO + Pc, -- (16#030FB#, 16#030FB#) KATAKANA MIDDLE DOT .. KATAKANA MIDDLE DOT + Lm, -- (16#030FC#, 16#030FE#) KATAKANA-HIRAGANA PROLONGED SOUND MARK .. KATAKANA VOICED ITERATION MARK + Lo, -- (16#030FF#, 16#030FF#) KATAKANA DIGRAPH KOTO .. KATAKANA DIGRAPH KOTO + Lo, -- (16#03105#, 16#0312C#) BOPOMOFO LETTER B .. BOPOMOFO LETTER GN + Lo, -- (16#03131#, 16#0318E#) HANGUL LETTER KIYEOK .. HANGUL LETTER ARAEAE + So, -- (16#03190#, 16#03191#) IDEOGRAPHIC ANNOTATION LINKING MARK .. IDEOGRAPHIC ANNOTATION REVERSE MARK + No, -- (16#03192#, 16#03195#) IDEOGRAPHIC ANNOTATION ONE MARK .. IDEOGRAPHIC ANNOTATION FOUR MARK + So, -- (16#03196#, 16#0319F#) IDEOGRAPHIC ANNOTATION TOP MARK .. IDEOGRAPHIC ANNOTATION MAN MARK + Lo, -- (16#031A0#, 16#031B7#) BOPOMOFO LETTER BU .. BOPOMOFO FINAL LETTER H + Lo, -- (16#031F0#, 16#031FF#) KATAKANA LETTER SMALL KU .. KATAKANA LETTER SMALL RO + So, -- (16#03200#, 16#0321E#) PARENTHESIZED HANGUL KIYEOK .. PARENTHESIZED KOREAN CHARACTER O HU + No, -- (16#03220#, 16#03229#) PARENTHESIZED IDEOGRAPH ONE .. PARENTHESIZED IDEOGRAPH TEN + So, -- (16#0322A#, 16#03243#) PARENTHESIZED IDEOGRAPH MOON .. PARENTHESIZED IDEOGRAPH REACH + So, -- (16#03250#, 16#03250#) PARTNERSHIP SIGN .. PARTNERSHIP SIGN + No, -- (16#03251#, 16#0325F#) CIRCLED NUMBER TWENTY ONE .. CIRCLED NUMBER THIRTY FIVE + So, -- (16#03260#, 16#0327D#) CIRCLED HANGUL KIYEOK .. CIRCLED KOREAN CHARACTER JUEUI + So, -- (16#0327F#, 16#0327F#) KOREAN STANDARD SYMBOL .. KOREAN STANDARD SYMBOL + No, -- (16#03280#, 16#03289#) CIRCLED IDEOGRAPH ONE .. CIRCLED IDEOGRAPH TEN + So, -- (16#0328A#, 16#032B0#) CIRCLED IDEOGRAPH MOON .. CIRCLED IDEOGRAPH NIGHT + No, -- (16#032B1#, 16#032BF#) CIRCLED NUMBER THIRTY SIX .. CIRCLED NUMBER FIFTY + So, -- (16#032C0#, 16#032FE#) IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY .. CIRCLED KATAKANA WO + So, -- (16#03300#, 16#033FF#) SQUARE APAATO .. SQUARE GAL + Lo, -- (16#03400#, 16#04DB5#) .. + So, -- (16#04DC0#, 16#04DFF#) HEXAGRAM FOR THE CREATIVE HEAVEN .. HEXAGRAM FOR BEFORE COMPLETION + Lo, -- (16#04E00#, 16#09FA5#) .. + Lo, -- (16#0A000#, 16#0A48C#) YI SYLLABLE IT .. YI SYLLABLE YYR + So, -- (16#0A490#, 16#0A4C6#) YI RADICAL QOT .. YI RADICAL KE + Lo, -- (16#0AC00#, 16#0D7A3#) .. + Cs, -- (16#0D800#, 16#0F8FF#) .. + Lo, -- (16#0F900#, 16#0FA2D#) CJK COMPATIBILITY IDEOGRAPH-F900 .. CJK COMPATIBILITY IDEOGRAPH-FA2D + Lo, -- (16#0FA30#, 16#0FA6A#) CJK COMPATIBILITY IDEOGRAPH-FA30 .. CJK COMPATIBILITY IDEOGRAPH-FA6A + Ll, -- (16#0FB00#, 16#0FB06#) LATIN SMALL LIGATURE FF .. LATIN SMALL LIGATURE ST + Ll, -- (16#0FB13#, 16#0FB17#) ARMENIAN SMALL LIGATURE MEN NOW .. ARMENIAN SMALL LIGATURE MEN XEH + Lo, -- (16#0FB1D#, 16#0FB1D#) HEBREW LETTER YOD WITH HIRIQ .. HEBREW LETTER YOD WITH HIRIQ + Mn, -- (16#0FB1E#, 16#0FB1E#) HEBREW POINT JUDEO-SPANISH VARIKA .. HEBREW POINT JUDEO-SPANISH VARIKA + Lo, -- (16#0FB1F#, 16#0FB28#) HEBREW LIGATURE YIDDISH YOD YOD PATAH .. HEBREW LETTER WIDE TAV + Sm, -- (16#0FB29#, 16#0FB29#) HEBREW LETTER ALTERNATIVE PLUS SIGN .. HEBREW LETTER ALTERNATIVE PLUS SIGN + Lo, -- (16#0FB2A#, 16#0FB36#) HEBREW LETTER SHIN WITH SHIN DOT .. HEBREW LETTER ZAYIN WITH DAGESH + Lo, -- (16#0FB38#, 16#0FB3C#) HEBREW LETTER TET WITH DAGESH .. HEBREW LETTER LAMED WITH DAGESH + Lo, -- (16#0FB3E#, 16#0FB3E#) HEBREW LETTER MEM WITH DAGESH .. HEBREW LETTER MEM WITH DAGESH + Lo, -- (16#0FB40#, 16#0FB41#) HEBREW LETTER NUN WITH DAGESH .. HEBREW LETTER SAMEKH WITH DAGESH + Lo, -- (16#0FB43#, 16#0FB44#) HEBREW LETTER FINAL PE WITH DAGESH .. HEBREW LETTER PE WITH DAGESH + Lo, -- (16#0FB46#, 16#0FBB1#) HEBREW LETTER TSADI WITH DAGESH .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM + Lo, -- (16#0FBD3#, 16#0FD3D#) ARABIC LETTER NG ISOLATED FORM .. ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM + Ps, -- (16#0FD3E#, 16#0FD3E#) ORNATE LEFT PARENTHESIS .. ORNATE LEFT PARENTHESIS + Pe, -- (16#0FD3F#, 16#0FD3F#) ORNATE RIGHT PARENTHESIS .. ORNATE RIGHT PARENTHESIS + Lo, -- (16#0FD50#, 16#0FD8F#) ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM .. ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM + Lo, -- (16#0FD92#, 16#0FDC7#) ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM .. ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM + Lo, -- (16#0FDF0#, 16#0FDFB#) ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM .. ARABIC LIGATURE JALLAJALALOUHOU + Sc, -- (16#0FDFC#, 16#0FDFC#) RIAL SIGN .. RIAL SIGN + So, -- (16#0FDFD#, 16#0FDFD#) ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM .. ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM + Mn, -- (16#0FE00#, 16#0FE0F#) VARIATION SELECTOR-1 .. VARIATION SELECTOR-16 + Mn, -- (16#0FE20#, 16#0FE23#) COMBINING LIGATURE LEFT HALF .. COMBINING DOUBLE TILDE RIGHT HALF + Po, -- (16#0FE30#, 16#0FE30#) PRESENTATION FORM FOR VERTICAL TWO DOT LEADER .. PRESENTATION FORM FOR VERTICAL TWO DOT LEADER + Pd, -- (16#0FE31#, 16#0FE32#) PRESENTATION FORM FOR VERTICAL EM DASH .. PRESENTATION FORM FOR VERTICAL EN DASH + Pc, -- (16#0FE33#, 16#0FE34#) PRESENTATION FORM FOR VERTICAL LOW LINE .. PRESENTATION FORM FOR VERTICAL WAVY LOW LINE + Ps, -- (16#0FE35#, 16#0FE35#) PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS + Pe, -- (16#0FE36#, 16#0FE36#) PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS + Ps, -- (16#0FE37#, 16#0FE37#) PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET + Pe, -- (16#0FE38#, 16#0FE38#) PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET + Ps, -- (16#0FE39#, 16#0FE39#) PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET + Pe, -- (16#0FE3A#, 16#0FE3A#) PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET + Ps, -- (16#0FE3B#, 16#0FE3B#) PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET + Pe, -- (16#0FE3C#, 16#0FE3C#) PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET + Ps, -- (16#0FE3D#, 16#0FE3D#) PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET + Pe, -- (16#0FE3E#, 16#0FE3E#) PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET + Ps, -- (16#0FE3F#, 16#0FE3F#) PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET + Pe, -- (16#0FE40#, 16#0FE40#) PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET + Ps, -- (16#0FE41#, 16#0FE41#) PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET + Pe, -- (16#0FE42#, 16#0FE42#) PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET + Ps, -- (16#0FE43#, 16#0FE43#) PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET + Pe, -- (16#0FE44#, 16#0FE44#) PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET + Po, -- (16#0FE45#, 16#0FE46#) SESAME DOT .. WHITE SESAME DOT + Ps, -- (16#0FE47#, 16#0FE47#) PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET + Pe, -- (16#0FE48#, 16#0FE48#) PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET + Po, -- (16#0FE49#, 16#0FE4C#) DASHED OVERLINE .. DOUBLE WAVY OVERLINE + Pc, -- (16#0FE4D#, 16#0FE4F#) DASHED LOW LINE .. WAVY LOW LINE + Po, -- (16#0FE50#, 16#0FE52#) SMALL COMMA .. SMALL FULL STOP + Po, -- (16#0FE54#, 16#0FE57#) SMALL SEMICOLON .. SMALL EXCLAMATION MARK + Pd, -- (16#0FE58#, 16#0FE58#) SMALL EM DASH .. SMALL EM DASH + Ps, -- (16#0FE59#, 16#0FE59#) SMALL LEFT PARENTHESIS .. SMALL LEFT PARENTHESIS + Pe, -- (16#0FE5A#, 16#0FE5A#) SMALL RIGHT PARENTHESIS .. SMALL RIGHT PARENTHESIS + Ps, -- (16#0FE5B#, 16#0FE5B#) SMALL LEFT CURLY BRACKET .. SMALL LEFT CURLY BRACKET + Pe, -- (16#0FE5C#, 16#0FE5C#) SMALL RIGHT CURLY BRACKET .. SMALL RIGHT CURLY BRACKET + Ps, -- (16#0FE5D#, 16#0FE5D#) SMALL LEFT TORTOISE SHELL BRACKET .. SMALL LEFT TORTOISE SHELL BRACKET + Pe, -- (16#0FE5E#, 16#0FE5E#) SMALL RIGHT TORTOISE SHELL BRACKET .. SMALL RIGHT TORTOISE SHELL BRACKET + Po, -- (16#0FE5F#, 16#0FE61#) SMALL NUMBER SIGN .. SMALL ASTERISK + Sm, -- (16#0FE62#, 16#0FE62#) SMALL PLUS SIGN .. SMALL PLUS SIGN + Pd, -- (16#0FE63#, 16#0FE63#) SMALL HYPHEN-MINUS .. SMALL HYPHEN-MINUS + Sm, -- (16#0FE64#, 16#0FE66#) SMALL LESS-THAN SIGN .. SMALL EQUALS SIGN + Po, -- (16#0FE68#, 16#0FE68#) SMALL REVERSE SOLIDUS .. SMALL REVERSE SOLIDUS + Sc, -- (16#0FE69#, 16#0FE69#) SMALL DOLLAR SIGN .. SMALL DOLLAR SIGN + Po, -- (16#0FE6A#, 16#0FE6B#) SMALL PERCENT SIGN .. SMALL COMMERCIAL AT + Lo, -- (16#0FE70#, 16#0FE74#) ARABIC FATHATAN ISOLATED FORM .. ARABIC KASRATAN ISOLATED FORM + Lo, -- (16#0FE76#, 16#0FEFC#) ARABIC FATHA ISOLATED FORM .. ARABIC LIGATURE LAM WITH ALEF FINAL FORM + Cf, -- (16#0FEFF#, 16#0FEFF#) ZERO WIDTH NO-BREAK SPACE .. ZERO WIDTH NO-BREAK SPACE + Po, -- (16#0FF01#, 16#0FF03#) FULLWIDTH EXCLAMATION MARK .. FULLWIDTH NUMBER SIGN + Sc, -- (16#0FF04#, 16#0FF04#) FULLWIDTH DOLLAR SIGN .. FULLWIDTH DOLLAR SIGN + Po, -- (16#0FF05#, 16#0FF07#) FULLWIDTH PERCENT SIGN .. FULLWIDTH APOSTROPHE + Ps, -- (16#0FF08#, 16#0FF08#) FULLWIDTH LEFT PARENTHESIS .. FULLWIDTH LEFT PARENTHESIS + Pe, -- (16#0FF09#, 16#0FF09#) FULLWIDTH RIGHT PARENTHESIS .. FULLWIDTH RIGHT PARENTHESIS + Po, -- (16#0FF0A#, 16#0FF0A#) FULLWIDTH ASTERISK .. FULLWIDTH ASTERISK + Sm, -- (16#0FF0B#, 16#0FF0B#) FULLWIDTH PLUS SIGN .. FULLWIDTH PLUS SIGN + Po, -- (16#0FF0C#, 16#0FF0C#) FULLWIDTH COMMA .. FULLWIDTH COMMA + Pd, -- (16#0FF0D#, 16#0FF0D#) FULLWIDTH HYPHEN-MINUS .. FULLWIDTH HYPHEN-MINUS + Po, -- (16#0FF0E#, 16#0FF0F#) FULLWIDTH FULL STOP .. FULLWIDTH SOLIDUS + Nd, -- (16#0FF10#, 16#0FF19#) FULLWIDTH DIGIT ZERO .. FULLWIDTH DIGIT NINE + Po, -- (16#0FF1A#, 16#0FF1B#) FULLWIDTH COLON .. FULLWIDTH SEMICOLON + Sm, -- (16#0FF1C#, 16#0FF1E#) FULLWIDTH LESS-THAN SIGN .. FULLWIDTH GREATER-THAN SIGN + Po, -- (16#0FF1F#, 16#0FF20#) FULLWIDTH QUESTION MARK .. FULLWIDTH COMMERCIAL AT + Lu, -- (16#0FF21#, 16#0FF3A#) FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z + Ps, -- (16#0FF3B#, 16#0FF3B#) FULLWIDTH LEFT SQUARE BRACKET .. FULLWIDTH LEFT SQUARE BRACKET + Po, -- (16#0FF3C#, 16#0FF3C#) FULLWIDTH REVERSE SOLIDUS .. FULLWIDTH REVERSE SOLIDUS + Pe, -- (16#0FF3D#, 16#0FF3D#) FULLWIDTH RIGHT SQUARE BRACKET .. FULLWIDTH RIGHT SQUARE BRACKET + Sk, -- (16#0FF3E#, 16#0FF3E#) FULLWIDTH CIRCUMFLEX ACCENT .. FULLWIDTH CIRCUMFLEX ACCENT + Pc, -- (16#0FF3F#, 16#0FF3F#) FULLWIDTH LOW LINE .. FULLWIDTH LOW LINE + Sk, -- (16#0FF40#, 16#0FF40#) FULLWIDTH GRAVE ACCENT .. FULLWIDTH GRAVE ACCENT + Ll, -- (16#0FF41#, 16#0FF5A#) FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z + Ps, -- (16#0FF5B#, 16#0FF5B#) FULLWIDTH LEFT CURLY BRACKET .. FULLWIDTH LEFT CURLY BRACKET + Sm, -- (16#0FF5C#, 16#0FF5C#) FULLWIDTH VERTICAL LINE .. FULLWIDTH VERTICAL LINE + Pe, -- (16#0FF5D#, 16#0FF5D#) FULLWIDTH RIGHT CURLY BRACKET .. FULLWIDTH RIGHT CURLY BRACKET + Sm, -- (16#0FF5E#, 16#0FF5E#) FULLWIDTH TILDE .. FULLWIDTH TILDE + Ps, -- (16#0FF5F#, 16#0FF5F#) FULLWIDTH LEFT WHITE PARENTHESIS .. FULLWIDTH LEFT WHITE PARENTHESIS + Pe, -- (16#0FF60#, 16#0FF60#) FULLWIDTH RIGHT WHITE PARENTHESIS .. FULLWIDTH RIGHT WHITE PARENTHESIS + Po, -- (16#0FF61#, 16#0FF61#) HALFWIDTH IDEOGRAPHIC FULL STOP .. HALFWIDTH IDEOGRAPHIC FULL STOP + Ps, -- (16#0FF62#, 16#0FF62#) HALFWIDTH LEFT CORNER BRACKET .. HALFWIDTH LEFT CORNER BRACKET + Pe, -- (16#0FF63#, 16#0FF63#) HALFWIDTH RIGHT CORNER BRACKET .. HALFWIDTH RIGHT CORNER BRACKET + Po, -- (16#0FF64#, 16#0FF64#) HALFWIDTH IDEOGRAPHIC COMMA .. HALFWIDTH IDEOGRAPHIC COMMA + Pc, -- (16#0FF65#, 16#0FF65#) HALFWIDTH KATAKANA MIDDLE DOT .. HALFWIDTH KATAKANA MIDDLE DOT + Lo, -- (16#0FF66#, 16#0FF6F#) HALFWIDTH KATAKANA LETTER WO .. HALFWIDTH KATAKANA LETTER SMALL TU + Lm, -- (16#0FF70#, 16#0FF70#) HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK .. HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK + Lo, -- (16#0FF71#, 16#0FF9D#) HALFWIDTH KATAKANA LETTER A .. HALFWIDTH KATAKANA LETTER N + Lm, -- (16#0FF9E#, 16#0FF9F#) HALFWIDTH KATAKANA VOICED SOUND MARK .. HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK + Lo, -- (16#0FFA0#, 16#0FFBE#) HALFWIDTH HANGUL FILLER .. HALFWIDTH HANGUL LETTER HIEUH + Lo, -- (16#0FFC2#, 16#0FFC7#) HALFWIDTH HANGUL LETTER A .. HALFWIDTH HANGUL LETTER E + Lo, -- (16#0FFCA#, 16#0FFCF#) HALFWIDTH HANGUL LETTER YEO .. HALFWIDTH HANGUL LETTER OE + Lo, -- (16#0FFD2#, 16#0FFD7#) HALFWIDTH HANGUL LETTER YO .. HALFWIDTH HANGUL LETTER YU + Lo, -- (16#0FFDA#, 16#0FFDC#) HALFWIDTH HANGUL LETTER EU .. HALFWIDTH HANGUL LETTER I + Sc, -- (16#0FFE0#, 16#0FFE1#) FULLWIDTH CENT SIGN .. FULLWIDTH POUND SIGN + Sm, -- (16#0FFE2#, 16#0FFE2#) FULLWIDTH NOT SIGN .. FULLWIDTH NOT SIGN + Sk, -- (16#0FFE3#, 16#0FFE3#) FULLWIDTH MACRON .. FULLWIDTH MACRON + So, -- (16#0FFE4#, 16#0FFE4#) FULLWIDTH BROKEN BAR .. FULLWIDTH BROKEN BAR + Sc, -- (16#0FFE5#, 16#0FFE6#) FULLWIDTH YEN SIGN .. FULLWIDTH WON SIGN + So, -- (16#0FFE8#, 16#0FFE8#) HALFWIDTH FORMS LIGHT VERTICAL .. HALFWIDTH FORMS LIGHT VERTICAL + Sm, -- (16#0FFE9#, 16#0FFEC#) HALFWIDTH LEFTWARDS ARROW .. HALFWIDTH DOWNWARDS ARROW + So, -- (16#0FFED#, 16#0FFEE#) HALFWIDTH BLACK SQUARE .. HALFWIDTH WHITE CIRCLE + Cf, -- (16#0FFF9#, 16#0FFFB#) INTERLINEAR ANNOTATION ANCHOR .. INTERLINEAR ANNOTATION TERMINATOR + So, -- (16#0FFFC#, 16#0FFFD#) OBJECT REPLACEMENT CHARACTER .. REPLACEMENT CHARACTER + Lo, -- (16#10000#, 16#1000B#) LINEAR B SYLLABLE B008 A .. LINEAR B SYLLABLE B046 JE + Lo, -- (16#1000D#, 16#10026#) LINEAR B SYLLABLE B036 JO .. LINEAR B SYLLABLE B032 QO + Lo, -- (16#10028#, 16#1003A#) LINEAR B SYLLABLE B060 RA .. LINEAR B SYLLABLE B042 WO + Lo, -- (16#1003C#, 16#1003D#) LINEAR B SYLLABLE B017 ZA .. LINEAR B SYLLABLE B074 ZE + Lo, -- (16#1003F#, 16#1004D#) LINEAR B SYLLABLE B020 ZO .. LINEAR B SYLLABLE B091 TWO + Lo, -- (16#10050#, 16#1005D#) LINEAR B SYMBOL B018 .. LINEAR B SYMBOL B089 + Lo, -- (16#10080#, 16#100FA#) LINEAR B IDEOGRAM B100 MAN .. LINEAR B IDEOGRAM VESSEL B305 + Po, -- (16#10100#, 16#10101#) AEGEAN WORD SEPARATOR LINE .. AEGEAN WORD SEPARATOR DOT + So, -- (16#10102#, 16#10102#) AEGEAN CHECK MARK .. AEGEAN CHECK MARK + No, -- (16#10107#, 16#10133#) AEGEAN NUMBER ONE .. AEGEAN NUMBER NINETY THOUSAND + So, -- (16#10137#, 16#1013F#) AEGEAN WEIGHT BASE UNIT .. AEGEAN MEASURE THIRD SUBUNIT + Lo, -- (16#10300#, 16#1031E#) OLD ITALIC LETTER A .. OLD ITALIC LETTER UU + No, -- (16#10320#, 16#10323#) OLD ITALIC NUMERAL ONE .. OLD ITALIC NUMERAL FIFTY + Lo, -- (16#10330#, 16#10349#) GOTHIC LETTER AHSA .. GOTHIC LETTER OTHAL + Nl, -- (16#1034A#, 16#1034A#) GOTHIC LETTER NINE HUNDRED .. GOTHIC LETTER NINE HUNDRED + Lo, -- (16#10380#, 16#1039D#) UGARITIC LETTER ALPA .. UGARITIC LETTER SSU + Po, -- (16#1039F#, 16#1039F#) UGARITIC WORD DIVIDER .. UGARITIC WORD DIVIDER + Lu, -- (16#10400#, 16#10427#) DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW + Ll, -- (16#10428#, 16#1044F#) DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW + Lo, -- (16#10450#, 16#1049D#) SHAVIAN LETTER PEEP .. OSMANYA LETTER OO + Nd, -- (16#104A0#, 16#104A9#) OSMANYA DIGIT ZERO .. OSMANYA DIGIT NINE + Lo, -- (16#10800#, 16#10805#) CYPRIOT SYLLABLE A .. CYPRIOT SYLLABLE JA + Lo, -- (16#10808#, 16#10808#) CYPRIOT SYLLABLE JO .. CYPRIOT SYLLABLE JO + Lo, -- (16#1080A#, 16#10835#) CYPRIOT SYLLABLE KA .. CYPRIOT SYLLABLE WO + Lo, -- (16#10837#, 16#10838#) CYPRIOT SYLLABLE XA .. CYPRIOT SYLLABLE XE + Lo, -- (16#1083C#, 16#1083C#) CYPRIOT SYLLABLE ZA .. CYPRIOT SYLLABLE ZA + Lo, -- (16#1083F#, 16#1083F#) CYPRIOT SYLLABLE ZO .. CYPRIOT SYLLABLE ZO + So, -- (16#1D000#, 16#1D0F5#) BYZANTINE MUSICAL SYMBOL PSILI .. BYZANTINE MUSICAL SYMBOL GORGON NEO KATO + So, -- (16#1D100#, 16#1D126#) MUSICAL SYMBOL SINGLE BARLINE .. MUSICAL SYMBOL DRUM CLEF-2 + So, -- (16#1D12A#, 16#1D164#) MUSICAL SYMBOL DOUBLE SHARP .. MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE + Mc, -- (16#1D165#, 16#1D166#) MUSICAL SYMBOL COMBINING STEM .. MUSICAL SYMBOL COMBINING SPRECHGESANG STEM + Mn, -- (16#1D167#, 16#1D169#) MUSICAL SYMBOL COMBINING TREMOLO-1 .. MUSICAL SYMBOL COMBINING TREMOLO-3 + So, -- (16#1D16A#, 16#1D16C#) MUSICAL SYMBOL FINGERED TREMOLO-1 .. MUSICAL SYMBOL FINGERED TREMOLO-3 + Mc, -- (16#1D16D#, 16#1D172#) MUSICAL SYMBOL COMBINING AUGMENTATION DOT .. MUSICAL SYMBOL COMBINING FLAG-5 + Cf, -- (16#1D173#, 16#1D17A#) MUSICAL SYMBOL BEGIN BEAM .. MUSICAL SYMBOL END PHRASE + Mn, -- (16#1D17B#, 16#1D182#) MUSICAL SYMBOL COMBINING ACCENT .. MUSICAL SYMBOL COMBINING LOURE + So, -- (16#1D183#, 16#1D184#) MUSICAL SYMBOL ARPEGGIATO UP .. MUSICAL SYMBOL ARPEGGIATO DOWN + Mn, -- (16#1D185#, 16#1D18B#) MUSICAL SYMBOL COMBINING DOIT .. MUSICAL SYMBOL COMBINING TRIPLE TONGUE + So, -- (16#1D18C#, 16#1D1A9#) MUSICAL SYMBOL RINFORZANDO .. MUSICAL SYMBOL DEGREE SLASH + Mn, -- (16#1D1AA#, 16#1D1AD#) MUSICAL SYMBOL COMBINING DOWN BOW .. MUSICAL SYMBOL COMBINING SNAP PIZZICATO + So, -- (16#1D1AE#, 16#1D1DD#) MUSICAL SYMBOL PEDAL MARK .. MUSICAL SYMBOL PES SUBPUNCTIS + So, -- (16#1D300#, 16#1D356#) MONOGRAM FOR EARTH .. TETRAGRAM FOR FOSTERING + Lu, -- (16#1D400#, 16#1D419#) MATHEMATICAL BOLD CAPITAL A .. MATHEMATICAL BOLD CAPITAL Z + Ll, -- (16#1D41A#, 16#1D433#) MATHEMATICAL BOLD SMALL A .. MATHEMATICAL BOLD SMALL Z + Lu, -- (16#1D434#, 16#1D44D#) MATHEMATICAL ITALIC CAPITAL A .. MATHEMATICAL ITALIC CAPITAL Z + Ll, -- (16#1D44E#, 16#1D454#) MATHEMATICAL ITALIC SMALL A .. MATHEMATICAL ITALIC SMALL G + Ll, -- (16#1D456#, 16#1D467#) MATHEMATICAL ITALIC SMALL I .. MATHEMATICAL ITALIC SMALL Z + Lu, -- (16#1D468#, 16#1D481#) MATHEMATICAL BOLD ITALIC CAPITAL A .. MATHEMATICAL BOLD ITALIC CAPITAL Z + Ll, -- (16#1D482#, 16#1D49B#) MATHEMATICAL BOLD ITALIC SMALL A .. MATHEMATICAL BOLD ITALIC SMALL Z + Lu, -- (16#1D49C#, 16#1D49C#) MATHEMATICAL SCRIPT CAPITAL A .. MATHEMATICAL SCRIPT CAPITAL A + Lu, -- (16#1D49E#, 16#1D49F#) MATHEMATICAL SCRIPT CAPITAL C .. MATHEMATICAL SCRIPT CAPITAL D + Lu, -- (16#1D4A2#, 16#1D4A2#) MATHEMATICAL SCRIPT CAPITAL G .. MATHEMATICAL SCRIPT CAPITAL G + Lu, -- (16#1D4A5#, 16#1D4A6#) MATHEMATICAL SCRIPT CAPITAL J .. MATHEMATICAL SCRIPT CAPITAL K + Lu, -- (16#1D4A9#, 16#1D4AC#) MATHEMATICAL SCRIPT CAPITAL N .. MATHEMATICAL SCRIPT CAPITAL Q + Lu, -- (16#1D4AE#, 16#1D4B5#) MATHEMATICAL SCRIPT CAPITAL S .. MATHEMATICAL SCRIPT CAPITAL Z + Ll, -- (16#1D4B6#, 16#1D4B9#) MATHEMATICAL SCRIPT SMALL A .. MATHEMATICAL SCRIPT SMALL D + Ll, -- (16#1D4BB#, 16#1D4BB#) MATHEMATICAL SCRIPT SMALL F .. MATHEMATICAL SCRIPT SMALL F + Ll, -- (16#1D4BD#, 16#1D4C3#) MATHEMATICAL SCRIPT SMALL H .. MATHEMATICAL SCRIPT SMALL N + Ll, -- (16#1D4C5#, 16#1D4CF#) MATHEMATICAL SCRIPT SMALL P .. MATHEMATICAL SCRIPT SMALL Z + Lu, -- (16#1D4D0#, 16#1D4E9#) MATHEMATICAL BOLD SCRIPT CAPITAL A .. MATHEMATICAL BOLD SCRIPT CAPITAL Z + Ll, -- (16#1D4EA#, 16#1D503#) MATHEMATICAL BOLD SCRIPT SMALL A .. MATHEMATICAL BOLD SCRIPT SMALL Z + Lu, -- (16#1D504#, 16#1D505#) MATHEMATICAL FRAKTUR CAPITAL A .. MATHEMATICAL FRAKTUR CAPITAL B + Lu, -- (16#1D507#, 16#1D50A#) MATHEMATICAL FRAKTUR CAPITAL D .. MATHEMATICAL FRAKTUR CAPITAL G + Lu, -- (16#1D50D#, 16#1D514#) MATHEMATICAL FRAKTUR CAPITAL J .. MATHEMATICAL FRAKTUR CAPITAL Q + Lu, -- (16#1D516#, 16#1D51C#) MATHEMATICAL FRAKTUR CAPITAL S .. MATHEMATICAL FRAKTUR CAPITAL Y + Ll, -- (16#1D51E#, 16#1D537#) MATHEMATICAL FRAKTUR SMALL A .. MATHEMATICAL FRAKTUR SMALL Z + Lu, -- (16#1D538#, 16#1D539#) MATHEMATICAL DOUBLE-STRUCK CAPITAL A .. MATHEMATICAL DOUBLE-STRUCK CAPITAL B + Lu, -- (16#1D53B#, 16#1D53E#) MATHEMATICAL DOUBLE-STRUCK CAPITAL D .. MATHEMATICAL DOUBLE-STRUCK CAPITAL G + Lu, -- (16#1D540#, 16#1D544#) MATHEMATICAL DOUBLE-STRUCK CAPITAL I .. MATHEMATICAL DOUBLE-STRUCK CAPITAL M + Lu, -- (16#1D546#, 16#1D546#) MATHEMATICAL DOUBLE-STRUCK CAPITAL O .. MATHEMATICAL DOUBLE-STRUCK CAPITAL O + Lu, -- (16#1D54A#, 16#1D550#) MATHEMATICAL DOUBLE-STRUCK CAPITAL S .. MATHEMATICAL DOUBLE-STRUCK CAPITAL Y + Ll, -- (16#1D552#, 16#1D56B#) MATHEMATICAL DOUBLE-STRUCK SMALL A .. MATHEMATICAL DOUBLE-STRUCK SMALL Z + Lu, -- (16#1D56C#, 16#1D585#) MATHEMATICAL BOLD FRAKTUR CAPITAL A .. MATHEMATICAL BOLD FRAKTUR CAPITAL Z + Ll, -- (16#1D586#, 16#1D59F#) MATHEMATICAL BOLD FRAKTUR SMALL A .. MATHEMATICAL BOLD FRAKTUR SMALL Z + Lu, -- (16#1D5A0#, 16#1D5B9#) MATHEMATICAL SANS-SERIF CAPITAL A .. MATHEMATICAL SANS-SERIF CAPITAL Z + Ll, -- (16#1D5BA#, 16#1D5D3#) MATHEMATICAL SANS-SERIF SMALL A .. MATHEMATICAL SANS-SERIF SMALL Z + Lu, -- (16#1D5D4#, 16#1D5ED#) MATHEMATICAL SANS-SERIF BOLD CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD CAPITAL Z + Ll, -- (16#1D5EE#, 16#1D607#) MATHEMATICAL SANS-SERIF BOLD SMALL A .. MATHEMATICAL SANS-SERIF BOLD SMALL Z + Lu, -- (16#1D608#, 16#1D621#) MATHEMATICAL SANS-SERIF ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF ITALIC CAPITAL Z + Ll, -- (16#1D622#, 16#1D63B#) MATHEMATICAL SANS-SERIF ITALIC SMALL A .. MATHEMATICAL SANS-SERIF ITALIC SMALL Z + Lu, -- (16#1D63C#, 16#1D655#) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL Z + Ll, -- (16#1D656#, 16#1D66F#) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL Z + Lu, -- (16#1D670#, 16#1D689#) MATHEMATICAL MONOSPACE CAPITAL A .. MATHEMATICAL MONOSPACE CAPITAL Z + Ll, -- (16#1D68A#, 16#1D6A3#) MATHEMATICAL MONOSPACE SMALL A .. MATHEMATICAL MONOSPACE SMALL Z + Lu, -- (16#1D6A8#, 16#1D6C0#) MATHEMATICAL BOLD CAPITAL ALPHA .. MATHEMATICAL BOLD CAPITAL OMEGA + Sm, -- (16#1D6C1#, 16#1D6C1#) MATHEMATICAL BOLD NABLA .. MATHEMATICAL BOLD NABLA + Ll, -- (16#1D6C2#, 16#1D6DA#) MATHEMATICAL BOLD SMALL ALPHA .. MATHEMATICAL BOLD SMALL OMEGA + Sm, -- (16#1D6DB#, 16#1D6DB#) MATHEMATICAL BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD PARTIAL DIFFERENTIAL + Ll, -- (16#1D6DC#, 16#1D6E1#) MATHEMATICAL BOLD EPSILON SYMBOL .. MATHEMATICAL BOLD PI SYMBOL + Lu, -- (16#1D6E2#, 16#1D6FA#) MATHEMATICAL ITALIC CAPITAL ALPHA .. MATHEMATICAL ITALIC CAPITAL OMEGA + Sm, -- (16#1D6FB#, 16#1D6FB#) MATHEMATICAL ITALIC NABLA .. MATHEMATICAL ITALIC NABLA + Ll, -- (16#1D6FC#, 16#1D714#) MATHEMATICAL ITALIC SMALL ALPHA .. MATHEMATICAL ITALIC SMALL OMEGA + Sm, -- (16#1D715#, 16#1D715#) MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL + Ll, -- (16#1D716#, 16#1D71B#) MATHEMATICAL ITALIC EPSILON SYMBOL .. MATHEMATICAL ITALIC PI SYMBOL + Lu, -- (16#1D71C#, 16#1D734#) MATHEMATICAL BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL BOLD ITALIC CAPITAL OMEGA + Sm, -- (16#1D735#, 16#1D735#) MATHEMATICAL BOLD ITALIC NABLA .. MATHEMATICAL BOLD ITALIC NABLA + Ll, -- (16#1D736#, 16#1D74E#) MATHEMATICAL BOLD ITALIC SMALL ALPHA .. MATHEMATICAL BOLD ITALIC SMALL OMEGA + Sm, -- (16#1D74F#, 16#1D74F#) MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL + Ll, -- (16#1D750#, 16#1D755#) MATHEMATICAL BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL BOLD ITALIC PI SYMBOL + Lu, -- (16#1D756#, 16#1D76E#) MATHEMATICAL SANS-SERIF BOLD CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA + Sm, -- (16#1D76F#, 16#1D76F#) MATHEMATICAL SANS-SERIF BOLD NABLA .. MATHEMATICAL SANS-SERIF BOLD NABLA + Ll, -- (16#1D770#, 16#1D788#) MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA + Sm, -- (16#1D789#, 16#1D789#) MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL + Ll, -- (16#1D78A#, 16#1D78F#) MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD PI SYMBOL + Lu, -- (16#1D790#, 16#1D7A8#) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA + Sm, -- (16#1D7A9#, 16#1D7A9#) MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA .. MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA + Ll, -- (16#1D7AA#, 16#1D7C2#) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA + Sm, -- (16#1D7C3#, 16#1D7C3#) MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL + Ll, -- (16#1D7C4#, 16#1D7C9#) MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL + Nd, -- (16#1D7CE#, 16#1D7FF#) MATHEMATICAL BOLD DIGIT ZERO .. MATHEMATICAL MONOSPACE DIGIT NINE + Lo, -- (16#20000#, 16#2A6D6#) .. + Lo, -- (16#2F800#, 16#2FA1D#) CJK COMPATIBILITY IDEOGRAPH-2F800 .. CJK COMPATIBILITY IDEOGRAPH-2FA1D + Cf, -- (16#E0001#, 16#E0001#) LANGUAGE TAG .. LANGUAGE TAG + Cf, -- (16#E0020#, 16#E007F#) TAG SPACE .. CANCEL TAG + Mn, -- (16#E0100#, 16#E01EF#) VARIATION SELECTOR-17 .. VARIATION SELECTOR-256 + Co, -- (16#F0000#, 16#FFFFD#) .. + Co); -- (16#100000#, 16#10FFFD#) .. + + -- The following array includes all characters considered digits, i.e. + -- all characters from the Unicode table with categories: + + -- Number, Decimal Digit (Nd) + + UTF_32_Digits : constant UTF_32_Ranges := ( + (16#00030#, 16#00039#), -- DIGIT ZERO .. DIGIT NINE + (16#00660#, 16#00669#), -- ARABIC-INDIC DIGIT ZERO .. ARABIC-INDIC DIGIT NINE + (16#006F0#, 16#006F9#), -- EXTENDED ARABIC-INDIC DIGIT ZERO .. EXTENDED ARABIC-INDIC DIGIT NINE + (16#00966#, 16#0096F#), -- DEVANAGARI DIGIT ZERO .. DEVANAGARI DIGIT NINE + (16#009E6#, 16#009EF#), -- BENGALI DIGIT ZERO .. BENGALI DIGIT NINE + (16#00A66#, 16#00A6F#), -- GURMUKHI DIGIT ZERO .. GURMUKHI DIGIT NINE + (16#00AE6#, 16#00AEF#), -- GUJARATI DIGIT ZERO .. GUJARATI DIGIT NINE + (16#00B66#, 16#00B6F#), -- ORIYA DIGIT ZERO .. ORIYA DIGIT NINE + (16#00BE7#, 16#00BEF#), -- TAMIL DIGIT ONE .. TAMIL DIGIT NINE + (16#00C66#, 16#00C6F#), -- TELUGU DIGIT ZERO .. TELUGU DIGIT NINE + (16#00CE6#, 16#00CEF#), -- KANNADA DIGIT ZERO .. KANNADA DIGIT NINE + (16#00D66#, 16#00D6F#), -- MALAYALAM DIGIT ZERO .. MALAYALAM DIGIT NINE + (16#00E50#, 16#00E59#), -- THAI DIGIT ZERO .. THAI DIGIT NINE + (16#00ED0#, 16#00ED9#), -- LAO DIGIT ZERO .. LAO DIGIT NINE + (16#00F20#, 16#00F29#), -- TIBETAN DIGIT ZERO .. TIBETAN DIGIT NINE + (16#01040#, 16#01049#), -- MYANMAR DIGIT ZERO .. MYANMAR DIGIT NINE + (16#01369#, 16#01371#), -- ETHIOPIC DIGIT ONE .. ETHIOPIC DIGIT NINE + (16#017E0#, 16#017E9#), -- KHMER DIGIT ZERO .. KHMER DIGIT NINE + (16#01810#, 16#01819#), -- MONGOLIAN DIGIT ZERO .. MONGOLIAN DIGIT NINE + (16#01946#, 16#0194F#), -- LIMBU DIGIT ZERO .. LIMBU DIGIT NINE + (16#0FF10#, 16#0FF19#), -- FULLWIDTH DIGIT ZERO .. FULLWIDTH DIGIT NINE + (16#104A0#, 16#104A9#), -- OSMANYA DIGIT ZERO .. OSMANYA DIGIT NINE + (16#1D7CE#, 16#1D7FF#)); -- MATHEMATICAL BOLD DIGIT ZERO .. MATHEMATICAL MONOSPACE DIGIT NINE + + -- The following table includes all characters considered letters, i.e. + -- all characters from the Unicode table with categories: + + -- Letter, Uppercase (Lu) + -- Letter, Lowercase (Ll) + -- Letter, Titlecase (Lt) + -- Letter, Modifier (Lm) + -- Letter, Other (Lo) + -- Number, Letter (Nl) + + UTF_32_Letters : constant UTF_32_Ranges := ( + (16#00041#, 16#0005A#), -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z + (16#00061#, 16#0007A#), -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z + (16#000AA#, 16#000AA#), -- FEMININE ORDINAL INDICATOR .. FEMININE ORDINAL INDICATOR + (16#000B5#, 16#000B5#), -- MICRO SIGN .. MICRO SIGN + (16#000BA#, 16#000BA#), -- MASCULINE ORDINAL INDICATOR .. MASCULINE ORDINAL INDICATOR + (16#000C0#, 16#000D6#), -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS + (16#000D8#, 16#000F6#), -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN SMALL LETTER O WITH DIAERESIS + (16#000F8#, 16#00236#), -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER T WITH CURL + (16#00250#, 16#002C1#), -- LATIN SMALL LETTER TURNED A .. MODIFIER LETTER REVERSED GLOTTAL STOP + (16#002C6#, 16#002D1#), -- MODIFIER LETTER CIRCUMFLEX ACCENT .. MODIFIER LETTER HALF TRIANGULAR COLON + (16#002E0#, 16#002E4#), -- MODIFIER LETTER SMALL GAMMA .. MODIFIER LETTER SMALL REVERSED GLOTTAL STOP + (16#002EE#, 16#002EE#), -- MODIFIER LETTER DOUBLE APOSTROPHE .. MODIFIER LETTER DOUBLE APOSTROPHE + (16#0037A#, 16#0037A#), -- GREEK YPOGEGRAMMENI .. GREEK YPOGEGRAMMENI + (16#00386#, 16#00386#), -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS + (16#00388#, 16#0038A#), -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS + (16#0038C#, 16#0038C#), -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS + (16#0038E#, 16#003A1#), -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER RHO + (16#003A3#, 16#003CE#), -- GREEK CAPITAL LETTER SIGMA .. GREEK SMALL LETTER OMEGA WITH TONOS + (16#003D0#, 16#003F5#), -- GREEK BETA SYMBOL .. GREEK LUNATE EPSILON SYMBOL + (16#003F7#, 16#003FB#), -- GREEK CAPITAL LETTER SHO .. GREEK SMALL LETTER SAN + (16#00400#, 16#00481#), -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER KOPPA + (16#0048A#, 16#004CE#), -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL + (16#004D0#, 16#004F5#), -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS + (16#004F8#, 16#004F9#), -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS + (16#00500#, 16#0050F#), -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI TJE + (16#00531#, 16#00556#), -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH + (16#00559#, 16#00559#), -- ARMENIAN MODIFIER LETTER LEFT HALF RING .. ARMENIAN MODIFIER LETTER LEFT HALF RING + (16#00561#, 16#00587#), -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LIGATURE ECH YIWN + (16#005D0#, 16#005EA#), -- HEBREW LETTER ALEF .. HEBREW LETTER TAV + (16#005F0#, 16#005F2#), -- HEBREW LIGATURE YIDDISH DOUBLE VAV .. HEBREW LIGATURE YIDDISH DOUBLE YOD + (16#00621#, 16#0063A#), -- ARABIC LETTER HAMZA .. ARABIC LETTER GHAIN + (16#00640#, 16#0064A#), -- ARABIC TATWEEL .. ARABIC LETTER YEH + (16#0066E#, 16#0066F#), -- ARABIC LETTER DOTLESS BEH .. ARABIC LETTER DOTLESS QAF + (16#00671#, 16#006D3#), -- ARABIC LETTER ALEF WASLA .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE + (16#006D5#, 16#006D5#), -- ARABIC LETTER AE .. ARABIC LETTER AE + (16#006E5#, 16#006E6#), -- ARABIC SMALL WAW .. ARABIC SMALL YEH + (16#006EE#, 16#006EF#), -- ARABIC LETTER DAL WITH INVERTED V .. ARABIC LETTER REH WITH INVERTED V + (16#006FA#, 16#006FC#), -- ARABIC LETTER SHEEN WITH DOT BELOW .. ARABIC LETTER GHAIN WITH DOT BELOW + (16#006FF#, 16#006FF#), -- ARABIC LETTER HEH WITH INVERTED V .. ARABIC LETTER HEH WITH INVERTED V + (16#00710#, 16#00710#), -- SYRIAC LETTER ALAPH .. SYRIAC LETTER ALAPH + (16#00712#, 16#0072F#), -- SYRIAC LETTER BETH .. SYRIAC LETTER PERSIAN DHALATH + (16#0074D#, 16#0074F#), -- SYRIAC LETTER SOGDIAN ZHAIN .. SYRIAC LETTER SOGDIAN FE + (16#00780#, 16#007A5#), -- THAANA LETTER HAA .. THAANA LETTER WAAVU + (16#007B1#, 16#007B1#), -- THAANA LETTER NAA .. THAANA LETTER NAA + (16#00904#, 16#00939#), -- DEVANAGARI LETTER SHORT A .. DEVANAGARI LETTER HA + (16#0093D#, 16#0093D#), -- DEVANAGARI SIGN AVAGRAHA .. DEVANAGARI SIGN AVAGRAHA + (16#00950#, 16#00950#), -- DEVANAGARI OM .. DEVANAGARI OM + (16#00958#, 16#00961#), -- DEVANAGARI LETTER QA .. DEVANAGARI LETTER VOCALIC LL + (16#00985#, 16#0098C#), -- BENGALI LETTER A .. BENGALI LETTER VOCALIC L + (16#0098F#, 16#00990#), -- BENGALI LETTER E .. BENGALI LETTER AI + (16#00993#, 16#009A8#), -- BENGALI LETTER O .. BENGALI LETTER NA + (16#009AA#, 16#009B0#), -- BENGALI LETTER PA .. BENGALI LETTER RA + (16#009B2#, 16#009B2#), -- BENGALI LETTER LA .. BENGALI LETTER LA + (16#009B6#, 16#009B9#), -- BENGALI LETTER SHA .. BENGALI LETTER HA + (16#009BD#, 16#009BD#), -- BENGALI SIGN AVAGRAHA .. BENGALI SIGN AVAGRAHA + (16#009DC#, 16#009DD#), -- BENGALI LETTER RRA .. BENGALI LETTER RHA + (16#009DF#, 16#009E1#), -- BENGALI LETTER YYA .. BENGALI LETTER VOCALIC LL + (16#009F0#, 16#009F1#), -- BENGALI LETTER RA WITH MIDDLE DIAGONAL .. BENGALI LETTER RA WITH LOWER DIAGONAL + (16#00A05#, 16#00A0A#), -- GURMUKHI LETTER A .. GURMUKHI LETTER UU + (16#00A0F#, 16#00A10#), -- GURMUKHI LETTER EE .. GURMUKHI LETTER AI + (16#00A13#, 16#00A28#), -- GURMUKHI LETTER OO .. GURMUKHI LETTER NA + (16#00A2A#, 16#00A30#), -- GURMUKHI LETTER PA .. GURMUKHI LETTER RA + (16#00A32#, 16#00A33#), -- GURMUKHI LETTER LA .. GURMUKHI LETTER LLA + (16#00A35#, 16#00A36#), -- GURMUKHI LETTER VA .. GURMUKHI LETTER SHA + (16#00A38#, 16#00A39#), -- GURMUKHI LETTER SA .. GURMUKHI LETTER HA + (16#00A59#, 16#00A5C#), -- GURMUKHI LETTER KHHA .. GURMUKHI LETTER RRA + (16#00A5E#, 16#00A5E#), -- GURMUKHI LETTER FA .. GURMUKHI LETTER FA + (16#00A72#, 16#00A74#), -- GURMUKHI IRI .. GURMUKHI EK ONKAR + (16#00A85#, 16#00A8D#), -- GUJARATI LETTER A .. GUJARATI VOWEL CANDRA E + (16#00A8F#, 16#00A91#), -- GUJARATI LETTER E .. GUJARATI VOWEL CANDRA O + (16#00A93#, 16#00AA8#), -- GUJARATI LETTER O .. GUJARATI LETTER NA + (16#00AAA#, 16#00AB0#), -- GUJARATI LETTER PA .. GUJARATI LETTER RA + (16#00AB2#, 16#00AB3#), -- GUJARATI LETTER LA .. GUJARATI LETTER LLA + (16#00AB5#, 16#00AB9#), -- GUJARATI LETTER VA .. GUJARATI LETTER HA + (16#00ABD#, 16#00ABD#), -- GUJARATI SIGN AVAGRAHA .. GUJARATI SIGN AVAGRAHA + (16#00AD0#, 16#00AD0#), -- GUJARATI OM .. GUJARATI OM + (16#00AE0#, 16#00AE1#), -- GUJARATI LETTER VOCALIC RR .. GUJARATI LETTER VOCALIC LL + (16#00B05#, 16#00B0C#), -- ORIYA LETTER A .. ORIYA LETTER VOCALIC L + (16#00B0F#, 16#00B10#), -- ORIYA LETTER E .. ORIYA LETTER AI + (16#00B13#, 16#00B28#), -- ORIYA LETTER O .. ORIYA LETTER NA + (16#00B2A#, 16#00B30#), -- ORIYA LETTER PA .. ORIYA LETTER RA + (16#00B32#, 16#00B33#), -- ORIYA LETTER LA .. ORIYA LETTER LLA + (16#00B35#, 16#00B39#), -- ORIYA LETTER VA .. ORIYA LETTER HA + (16#00B3D#, 16#00B3D#), -- ORIYA SIGN AVAGRAHA .. ORIYA SIGN AVAGRAHA + (16#00B5C#, 16#00B5D#), -- ORIYA LETTER RRA .. ORIYA LETTER RHA + (16#00B5F#, 16#00B61#), -- ORIYA LETTER YYA .. ORIYA LETTER VOCALIC LL + (16#00B71#, 16#00B71#), -- ORIYA LETTER WA .. ORIYA LETTER WA + (16#00B83#, 16#00B83#), -- TAMIL SIGN VISARGA .. TAMIL SIGN VISARGA + (16#00B85#, 16#00B8A#), -- TAMIL LETTER A .. TAMIL LETTER UU + (16#00B8E#, 16#00B90#), -- TAMIL LETTER E .. TAMIL LETTER AI + (16#00B92#, 16#00B95#), -- TAMIL LETTER O .. TAMIL LETTER KA + (16#00B99#, 16#00B9A#), -- TAMIL LETTER NGA .. TAMIL LETTER CA + (16#00B9C#, 16#00B9C#), -- TAMIL LETTER JA .. TAMIL LETTER JA + (16#00B9E#, 16#00B9F#), -- TAMIL LETTER NYA .. TAMIL LETTER TTA + (16#00BA3#, 16#00BA4#), -- TAMIL LETTER NNA .. TAMIL LETTER TA + (16#00BA8#, 16#00BAA#), -- TAMIL LETTER NA .. TAMIL LETTER PA + (16#00BAE#, 16#00BB5#), -- TAMIL LETTER MA .. TAMIL LETTER VA + (16#00BB7#, 16#00BB9#), -- TAMIL LETTER SSA .. TAMIL LETTER HA + (16#00C05#, 16#00C0C#), -- TELUGU LETTER A .. TELUGU LETTER VOCALIC L + (16#00C0E#, 16#00C10#), -- TELUGU LETTER E .. TELUGU LETTER AI + (16#00C12#, 16#00C28#), -- TELUGU LETTER O .. TELUGU LETTER NA + (16#00C2A#, 16#00C33#), -- TELUGU LETTER PA .. TELUGU LETTER LLA + (16#00C35#, 16#00C39#), -- TELUGU LETTER VA .. TELUGU LETTER HA + (16#00C60#, 16#00C61#), -- TELUGU LETTER VOCALIC RR .. TELUGU LETTER VOCALIC LL + (16#00C85#, 16#00C8C#), -- KANNADA LETTER A .. KANNADA LETTER VOCALIC L + (16#00C8E#, 16#00C90#), -- KANNADA LETTER E .. KANNADA LETTER AI + (16#00C92#, 16#00CA8#), -- KANNADA LETTER O .. KANNADA LETTER NA + (16#00CAA#, 16#00CB3#), -- KANNADA LETTER PA .. KANNADA LETTER LLA + (16#00CB5#, 16#00CB9#), -- KANNADA LETTER VA .. KANNADA LETTER HA + (16#00CBD#, 16#00CBD#), -- KANNADA SIGN AVAGRAHA .. KANNADA SIGN AVAGRAHA + (16#00CDE#, 16#00CDE#), -- KANNADA LETTER FA .. KANNADA LETTER FA + (16#00CE0#, 16#00CE1#), -- KANNADA LETTER VOCALIC RR .. KANNADA LETTER VOCALIC LL + (16#00D05#, 16#00D0C#), -- MALAYALAM LETTER A .. MALAYALAM LETTER VOCALIC L + (16#00D0E#, 16#00D10#), -- MALAYALAM LETTER E .. MALAYALAM LETTER AI + (16#00D12#, 16#00D28#), -- MALAYALAM LETTER O .. MALAYALAM LETTER NA + (16#00D2A#, 16#00D39#), -- MALAYALAM LETTER PA .. MALAYALAM LETTER HA + (16#00D60#, 16#00D61#), -- MALAYALAM LETTER VOCALIC RR .. MALAYALAM LETTER VOCALIC LL + (16#00D85#, 16#00D96#), -- SINHALA LETTER AYANNA .. SINHALA LETTER AUYANNA + (16#00D9A#, 16#00DB1#), -- SINHALA LETTER ALPAPRAANA KAYANNA .. SINHALA LETTER DANTAJA NAYANNA + (16#00DB3#, 16#00DBB#), -- SINHALA LETTER SANYAKA DAYANNA .. SINHALA LETTER RAYANNA + (16#00DBD#, 16#00DBD#), -- SINHALA LETTER DANTAJA LAYANNA .. SINHALA LETTER DANTAJA LAYANNA + (16#00DC0#, 16#00DC6#), -- SINHALA LETTER VAYANNA .. SINHALA LETTER FAYANNA + (16#00E01#, 16#00E30#), -- THAI CHARACTER KO KAI .. THAI CHARACTER SARA A + (16#00E32#, 16#00E33#), -- THAI CHARACTER SARA AA .. THAI CHARACTER SARA AM + (16#00E40#, 16#00E46#), -- THAI CHARACTER SARA E .. THAI CHARACTER MAIYAMOK + (16#00E81#, 16#00E82#), -- LAO LETTER KO .. LAO LETTER KHO SUNG + (16#00E84#, 16#00E84#), -- LAO LETTER KHO TAM .. LAO LETTER KHO TAM + (16#00E87#, 16#00E88#), -- LAO LETTER NGO .. LAO LETTER CO + (16#00E8A#, 16#00E8A#), -- LAO LETTER SO TAM .. LAO LETTER SO TAM + (16#00E8D#, 16#00E8D#), -- LAO LETTER NYO .. LAO LETTER NYO + (16#00E94#, 16#00E97#), -- LAO LETTER DO .. LAO LETTER THO TAM + (16#00E99#, 16#00E9F#), -- LAO LETTER NO .. LAO LETTER FO SUNG + (16#00EA1#, 16#00EA3#), -- LAO LETTER MO .. LAO LETTER LO LING + (16#00EA5#, 16#00EA5#), -- LAO LETTER LO LOOT .. LAO LETTER LO LOOT + (16#00EA7#, 16#00EA7#), -- LAO LETTER WO .. LAO LETTER WO + (16#00EAA#, 16#00EAB#), -- LAO LETTER SO SUNG .. LAO LETTER HO SUNG + (16#00EAD#, 16#00EB0#), -- LAO LETTER O .. LAO VOWEL SIGN A + (16#00EB2#, 16#00EB3#), -- LAO VOWEL SIGN AA .. LAO VOWEL SIGN AM + (16#00EBD#, 16#00EBD#), -- LAO SEMIVOWEL SIGN NYO .. LAO SEMIVOWEL SIGN NYO + (16#00EC0#, 16#00EC4#), -- LAO VOWEL SIGN E .. LAO VOWEL SIGN AI + (16#00EC6#, 16#00EC6#), -- LAO KO LA .. LAO KO LA + (16#00EDC#, 16#00EDD#), -- LAO HO NO .. LAO HO MO + (16#00F00#, 16#00F00#), -- TIBETAN SYLLABLE OM .. TIBETAN SYLLABLE OM + (16#00F40#, 16#00F47#), -- TIBETAN LETTER KA .. TIBETAN LETTER JA + (16#00F49#, 16#00F6A#), -- TIBETAN LETTER NYA .. TIBETAN LETTER FIXED-FORM RA + (16#00F88#, 16#00F8B#), -- TIBETAN SIGN LCE TSA CAN .. TIBETAN SIGN GRU MED RGYINGS + (16#01000#, 16#01021#), -- MYANMAR LETTER KA .. MYANMAR LETTER A + (16#01023#, 16#01027#), -- MYANMAR LETTER I .. MYANMAR LETTER E + (16#01029#, 16#0102A#), -- MYANMAR LETTER O .. MYANMAR LETTER AU + (16#01050#, 16#01055#), -- MYANMAR LETTER SHA .. MYANMAR LETTER VOCALIC LL + (16#010A0#, 16#010C5#), -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE + (16#010D0#, 16#010F8#), -- GEORGIAN LETTER AN .. GEORGIAN LETTER ELIFI + (16#01100#, 16#01159#), -- HANGUL CHOSEONG KIYEOK .. HANGUL CHOSEONG YEORINHIEUH + (16#0115F#, 16#011A2#), -- HANGUL CHOSEONG FILLER .. HANGUL JUNGSEONG SSANGARAEA + (16#011A8#, 16#011F9#), -- HANGUL JONGSEONG KIYEOK .. HANGUL JONGSEONG YEORINHIEUH + (16#01200#, 16#01206#), -- ETHIOPIC SYLLABLE HA .. ETHIOPIC SYLLABLE HO + (16#01208#, 16#01246#), -- ETHIOPIC SYLLABLE LA .. ETHIOPIC SYLLABLE QO + (16#01248#, 16#01248#), -- ETHIOPIC SYLLABLE QWA .. ETHIOPIC SYLLABLE QWA + (16#0124A#, 16#0124D#), -- ETHIOPIC SYLLABLE QWI .. ETHIOPIC SYLLABLE QWE + (16#01250#, 16#01256#), -- ETHIOPIC SYLLABLE QHA .. ETHIOPIC SYLLABLE QHO + (16#01258#, 16#01258#), -- ETHIOPIC SYLLABLE QHWA .. ETHIOPIC SYLLABLE QHWA + (16#0125A#, 16#0125D#), -- ETHIOPIC SYLLABLE QHWI .. ETHIOPIC SYLLABLE QHWE + (16#01260#, 16#01286#), -- ETHIOPIC SYLLABLE BA .. ETHIOPIC SYLLABLE XO + (16#01288#, 16#01288#), -- ETHIOPIC SYLLABLE XWA .. ETHIOPIC SYLLABLE XWA + (16#0128A#, 16#0128D#), -- ETHIOPIC SYLLABLE XWI .. ETHIOPIC SYLLABLE XWE + (16#01290#, 16#012AE#), -- ETHIOPIC SYLLABLE NA .. ETHIOPIC SYLLABLE KO + (16#012B0#, 16#012B0#), -- ETHIOPIC SYLLABLE KWA .. ETHIOPIC SYLLABLE KWA + (16#012B2#, 16#012B5#), -- ETHIOPIC SYLLABLE KWI .. ETHIOPIC SYLLABLE KWE + (16#012B8#, 16#012BE#), -- ETHIOPIC SYLLABLE KXA .. ETHIOPIC SYLLABLE KXO + (16#012C0#, 16#012C0#), -- ETHIOPIC SYLLABLE KXWA .. ETHIOPIC SYLLABLE KXWA + (16#012C2#, 16#012C5#), -- ETHIOPIC SYLLABLE KXWI .. ETHIOPIC SYLLABLE KXWE + (16#012C8#, 16#012CE#), -- ETHIOPIC SYLLABLE WA .. ETHIOPIC SYLLABLE WO + (16#012D0#, 16#012D6#), -- ETHIOPIC SYLLABLE PHARYNGEAL A .. ETHIOPIC SYLLABLE PHARYNGEAL O + (16#012D8#, 16#012EE#), -- ETHIOPIC SYLLABLE ZA .. ETHIOPIC SYLLABLE YO + (16#012F0#, 16#0130E#), -- ETHIOPIC SYLLABLE DA .. ETHIOPIC SYLLABLE GO + (16#01310#, 16#01310#), -- ETHIOPIC SYLLABLE GWA .. ETHIOPIC SYLLABLE GWA + (16#01312#, 16#01315#), -- ETHIOPIC SYLLABLE GWI .. ETHIOPIC SYLLABLE GWE + (16#01318#, 16#0131E#), -- ETHIOPIC SYLLABLE GGA .. ETHIOPIC SYLLABLE GGO + (16#01320#, 16#01346#), -- ETHIOPIC SYLLABLE THA .. ETHIOPIC SYLLABLE TZO + (16#01348#, 16#0135A#), -- ETHIOPIC SYLLABLE FA .. ETHIOPIC SYLLABLE FYA + (16#013A0#, 16#013F4#), -- CHEROKEE LETTER A .. CHEROKEE LETTER YV + (16#01401#, 16#0166C#), -- CANADIAN SYLLABICS E .. CANADIAN SYLLABICS CARRIER TTSA + (16#0166F#, 16#01676#), -- CANADIAN SYLLABICS QAI .. CANADIAN SYLLABICS NNGAA + (16#01681#, 16#0169A#), -- OGHAM LETTER BEITH .. OGHAM LETTER PEITH + (16#016A0#, 16#016EA#), -- RUNIC LETTER FEHU FEOH FE F .. RUNIC LETTER X + (16#016EE#, 16#016F0#), -- RUNIC ARLAUG SYMBOL .. RUNIC BELGTHOR SYMBOL + (16#01700#, 16#0170C#), -- TAGALOG LETTER A .. TAGALOG LETTER YA + (16#0170E#, 16#01711#), -- TAGALOG LETTER LA .. TAGALOG LETTER HA + (16#01720#, 16#01731#), -- HANUNOO LETTER A .. HANUNOO LETTER HA + (16#01740#, 16#01751#), -- BUHID LETTER A .. BUHID LETTER HA + (16#01760#, 16#0176C#), -- TAGBANWA LETTER A .. TAGBANWA LETTER YA + (16#0176E#, 16#01770#), -- TAGBANWA LETTER LA .. TAGBANWA LETTER SA + (16#01780#, 16#017B3#), -- KHMER LETTER KA .. KHMER INDEPENDENT VOWEL QAU + (16#017D7#, 16#017D7#), -- KHMER SIGN LEK TOO .. KHMER SIGN LEK TOO + (16#017DC#, 16#017DC#), -- KHMER SIGN AVAKRAHASANYA .. KHMER SIGN AVAKRAHASANYA + (16#01820#, 16#01877#), -- MONGOLIAN LETTER A .. MONGOLIAN LETTER MANCHU ZHA + (16#01880#, 16#018A8#), -- MONGOLIAN LETTER ALI GALI ANUSVARA ONE .. MONGOLIAN LETTER MANCHU ALI GALI BHA + (16#01900#, 16#0191C#), -- LIMBU VOWEL-CARRIER LETTER .. LIMBU LETTER HA + (16#01950#, 16#0196D#), -- TAI LE LETTER KA .. TAI LE LETTER AI + (16#01970#, 16#01974#), -- TAI LE LETTER TONE-2 .. TAI LE LETTER TONE-6 + (16#01D00#, 16#01D6B#), -- LATIN LETTER SMALL CAPITAL A .. LATIN SMALL LETTER UE + (16#01E00#, 16#01E9B#), -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN SMALL LETTER LONG S WITH DOT ABOVE + (16#01EA0#, 16#01EF9#), -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER Y WITH TILDE + (16#01F00#, 16#01F15#), -- GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA + (16#01F18#, 16#01F1D#), -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA + (16#01F20#, 16#01F45#), -- GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA + (16#01F48#, 16#01F4D#), -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA + (16#01F50#, 16#01F57#), -- GREEK SMALL LETTER UPSILON WITH PSILI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI + (16#01F59#, 16#01F59#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA + (16#01F5B#, 16#01F5B#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA + (16#01F5D#, 16#01F5D#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA + (16#01F5F#, 16#01F7D#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK SMALL LETTER OMEGA WITH OXIA + (16#01F80#, 16#01FB4#), -- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI + (16#01FB6#, 16#01FBC#), -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI .. GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI + (16#01FBE#, 16#01FBE#), -- GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI + (16#01FC2#, 16#01FC4#), -- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI + (16#01FC6#, 16#01FCC#), -- GREEK SMALL LETTER ETA WITH PERISPOMENI .. GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI + (16#01FD0#, 16#01FD3#), -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA + (16#01FD6#, 16#01FDB#), -- GREEK SMALL LETTER IOTA WITH PERISPOMENI .. GREEK CAPITAL LETTER IOTA WITH OXIA + (16#01FE0#, 16#01FEC#), -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER RHO WITH DASIA + (16#01FF2#, 16#01FF4#), -- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI + (16#01FF6#, 16#01FFC#), -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI .. GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI + (16#02071#, 16#02071#), -- SUPERSCRIPT LATIN SMALL LETTER I .. SUPERSCRIPT LATIN SMALL LETTER I + (16#0207F#, 16#0207F#), -- SUPERSCRIPT LATIN SMALL LETTER N .. SUPERSCRIPT LATIN SMALL LETTER N + (16#02102#, 16#02102#), -- DOUBLE-STRUCK CAPITAL C .. DOUBLE-STRUCK CAPITAL C + (16#02107#, 16#02107#), -- EULER CONSTANT .. EULER CONSTANT + (16#0210A#, 16#02113#), -- SCRIPT SMALL G .. SCRIPT SMALL L + (16#02115#, 16#02115#), -- DOUBLE-STRUCK CAPITAL N .. DOUBLE-STRUCK CAPITAL N + (16#02119#, 16#0211D#), -- DOUBLE-STRUCK CAPITAL P .. DOUBLE-STRUCK CAPITAL R + (16#02124#, 16#02124#), -- DOUBLE-STRUCK CAPITAL Z .. DOUBLE-STRUCK CAPITAL Z + (16#02126#, 16#02126#), -- OHM SIGN .. OHM SIGN + (16#02128#, 16#02128#), -- BLACK-LETTER CAPITAL Z .. BLACK-LETTER CAPITAL Z + (16#0212A#, 16#0212D#), -- KELVIN SIGN .. BLACK-LETTER CAPITAL C + (16#0212F#, 16#02131#), -- SCRIPT SMALL E .. SCRIPT CAPITAL F + (16#02133#, 16#02139#), -- SCRIPT CAPITAL M .. INFORMATION SOURCE + (16#0213D#, 16#0213F#), -- DOUBLE-STRUCK SMALL GAMMA .. DOUBLE-STRUCK CAPITAL PI + (16#02145#, 16#02149#), -- DOUBLE-STRUCK ITALIC CAPITAL D .. DOUBLE-STRUCK ITALIC SMALL J + (16#02160#, 16#02183#), -- ROMAN NUMERAL ONE .. ROMAN NUMERAL REVERSED ONE HUNDRED + (16#03005#, 16#03007#), -- IDEOGRAPHIC ITERATION MARK .. IDEOGRAPHIC NUMBER ZERO + (16#03021#, 16#03029#), -- HANGZHOU NUMERAL ONE .. HANGZHOU NUMERAL NINE + (16#03031#, 16#03035#), -- VERTICAL KANA REPEAT MARK .. VERTICAL KANA REPEAT MARK LOWER HALF + (16#03038#, 16#0303C#), -- HANGZHOU NUMERAL TEN .. MASU MARK + (16#03041#, 16#03096#), -- HIRAGANA LETTER SMALL A .. HIRAGANA LETTER SMALL KE + (16#0309D#, 16#0309F#), -- HIRAGANA ITERATION MARK .. HIRAGANA DIGRAPH YORI + (16#030A1#, 16#030FA#), -- KATAKANA LETTER SMALL A .. KATAKANA LETTER VO + (16#030FC#, 16#030FF#), -- KATAKANA-HIRAGANA PROLONGED SOUND MARK .. KATAKANA DIGRAPH KOTO + (16#03105#, 16#0312C#), -- BOPOMOFO LETTER B .. BOPOMOFO LETTER GN + (16#03131#, 16#0318E#), -- HANGUL LETTER KIYEOK .. HANGUL LETTER ARAEAE + (16#031A0#, 16#031B7#), -- BOPOMOFO LETTER BU .. BOPOMOFO FINAL LETTER H + (16#031F0#, 16#031FF#), -- KATAKANA LETTER SMALL KU .. KATAKANA LETTER SMALL RO + (16#03400#, 16#04DB5#), -- .. + (16#04E00#, 16#09FA5#), -- .. + (16#0A000#, 16#0A48C#), -- YI SYLLABLE IT .. YI SYLLABLE YYR + (16#0AC00#, 16#0D7A3#), -- .. + (16#0F900#, 16#0FA2D#), -- CJK COMPATIBILITY IDEOGRAPH-F900 .. CJK COMPATIBILITY IDEOGRAPH-FA2D + (16#0FA30#, 16#0FA6A#), -- CJK COMPATIBILITY IDEOGRAPH-FA30 .. CJK COMPATIBILITY IDEOGRAPH-FA6A + (16#0FB00#, 16#0FB06#), -- LATIN SMALL LIGATURE FF .. LATIN SMALL LIGATURE ST + (16#0FB13#, 16#0FB17#), -- ARMENIAN SMALL LIGATURE MEN NOW .. ARMENIAN SMALL LIGATURE MEN XEH + (16#0FB1D#, 16#0FB1D#), -- HEBREW LETTER YOD WITH HIRIQ .. HEBREW LETTER YOD WITH HIRIQ + (16#0FB1F#, 16#0FB28#), -- HEBREW LIGATURE YIDDISH YOD YOD PATAH .. HEBREW LETTER WIDE TAV + (16#0FB2A#, 16#0FB36#), -- HEBREW LETTER SHIN WITH SHIN DOT .. HEBREW LETTER ZAYIN WITH DAGESH + (16#0FB38#, 16#0FB3C#), -- HEBREW LETTER TET WITH DAGESH .. HEBREW LETTER LAMED WITH DAGESH + (16#0FB3E#, 16#0FB3E#), -- HEBREW LETTER MEM WITH DAGESH .. HEBREW LETTER MEM WITH DAGESH + (16#0FB40#, 16#0FB41#), -- HEBREW LETTER NUN WITH DAGESH .. HEBREW LETTER SAMEKH WITH DAGESH + (16#0FB43#, 16#0FB44#), -- HEBREW LETTER FINAL PE WITH DAGESH .. HEBREW LETTER PE WITH DAGESH + (16#0FB46#, 16#0FBB1#), -- HEBREW LETTER TSADI WITH DAGESH .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM + (16#0FBD3#, 16#0FD3D#), -- ARABIC LETTER NG ISOLATED FORM .. ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM + (16#0FD50#, 16#0FD8F#), -- ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM .. ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM + (16#0FD92#, 16#0FDC7#), -- ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM .. ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM + (16#0FDF0#, 16#0FDFB#), -- ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM .. ARABIC LIGATURE JALLAJALALOUHOU + (16#0FE70#, 16#0FE74#), -- ARABIC FATHATAN ISOLATED FORM .. ARABIC KASRATAN ISOLATED FORM + (16#0FE76#, 16#0FEFC#), -- ARABIC FATHA ISOLATED FORM .. ARABIC LIGATURE LAM WITH ALEF FINAL FORM + (16#0FF21#, 16#0FF3A#), -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z + (16#0FF41#, 16#0FF5A#), -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z + (16#0FF66#, 16#0FFBE#), -- HALFWIDTH KATAKANA LETTER WO .. HALFWIDTH HANGUL LETTER HIEUH + (16#0FFC2#, 16#0FFC7#), -- HALFWIDTH HANGUL LETTER A .. HALFWIDTH HANGUL LETTER E + (16#0FFCA#, 16#0FFCF#), -- HALFWIDTH HANGUL LETTER YEO .. HALFWIDTH HANGUL LETTER OE + (16#0FFD2#, 16#0FFD7#), -- HALFWIDTH HANGUL LETTER YO .. HALFWIDTH HANGUL LETTER YU + (16#0FFDA#, 16#0FFDC#), -- HALFWIDTH HANGUL LETTER EU .. HALFWIDTH HANGUL LETTER I + (16#10000#, 16#1000B#), -- LINEAR B SYLLABLE B008 A .. LINEAR B SYLLABLE B046 JE + (16#1000D#, 16#10026#), -- LINEAR B SYLLABLE B036 JO .. LINEAR B SYLLABLE B032 QO + (16#10028#, 16#1003A#), -- LINEAR B SYLLABLE B060 RA .. LINEAR B SYLLABLE B042 WO + (16#1003C#, 16#1003D#), -- LINEAR B SYLLABLE B017 ZA .. LINEAR B SYLLABLE B074 ZE + (16#1003F#, 16#1004D#), -- LINEAR B SYLLABLE B020 ZO .. LINEAR B SYLLABLE B091 TWO + (16#10050#, 16#1005D#), -- LINEAR B SYMBOL B018 .. LINEAR B SYMBOL B089 + (16#10080#, 16#100FA#), -- LINEAR B IDEOGRAM B100 MAN .. LINEAR B IDEOGRAM VESSEL B305 + (16#10300#, 16#1031E#), -- OLD ITALIC LETTER A .. OLD ITALIC LETTER UU + (16#10330#, 16#1034A#), -- GOTHIC LETTER AHSA .. GOTHIC LETTER NINE HUNDRED + (16#10380#, 16#1039D#), -- UGARITIC LETTER ALPA .. UGARITIC LETTER SSU + (16#10400#, 16#1049D#), -- DESERET CAPITAL LETTER LONG I .. OSMANYA LETTER OO + (16#10800#, 16#10805#), -- CYPRIOT SYLLABLE A .. CYPRIOT SYLLABLE JA + (16#10808#, 16#10808#), -- CYPRIOT SYLLABLE JO .. CYPRIOT SYLLABLE JO + (16#1080A#, 16#10835#), -- CYPRIOT SYLLABLE KA .. CYPRIOT SYLLABLE WO + (16#10837#, 16#10838#), -- CYPRIOT SYLLABLE XA .. CYPRIOT SYLLABLE XE + (16#1083C#, 16#1083C#), -- CYPRIOT SYLLABLE ZA .. CYPRIOT SYLLABLE ZA + (16#1083F#, 16#1083F#), -- CYPRIOT SYLLABLE ZO .. CYPRIOT SYLLABLE ZO + (16#1D400#, 16#1D454#), -- MATHEMATICAL BOLD CAPITAL A .. MATHEMATICAL ITALIC SMALL G + (16#1D456#, 16#1D49C#), -- MATHEMATICAL ITALIC SMALL I .. MATHEMATICAL SCRIPT CAPITAL A + (16#1D49E#, 16#1D49F#), -- MATHEMATICAL SCRIPT CAPITAL C .. MATHEMATICAL SCRIPT CAPITAL D + (16#1D4A2#, 16#1D4A2#), -- MATHEMATICAL SCRIPT CAPITAL G .. MATHEMATICAL SCRIPT CAPITAL G + (16#1D4A5#, 16#1D4A6#), -- MATHEMATICAL SCRIPT CAPITAL J .. MATHEMATICAL SCRIPT CAPITAL K + (16#1D4A9#, 16#1D4AC#), -- MATHEMATICAL SCRIPT CAPITAL N .. MATHEMATICAL SCRIPT CAPITAL Q + (16#1D4AE#, 16#1D4B9#), -- MATHEMATICAL SCRIPT CAPITAL S .. MATHEMATICAL SCRIPT SMALL D + (16#1D4BB#, 16#1D4BB#), -- MATHEMATICAL SCRIPT SMALL F .. MATHEMATICAL SCRIPT SMALL F + (16#1D4BD#, 16#1D4C3#), -- MATHEMATICAL SCRIPT SMALL H .. MATHEMATICAL SCRIPT SMALL N + (16#1D4C5#, 16#1D505#), -- MATHEMATICAL SCRIPT SMALL P .. MATHEMATICAL FRAKTUR CAPITAL B + (16#1D507#, 16#1D50A#), -- MATHEMATICAL FRAKTUR CAPITAL D .. MATHEMATICAL FRAKTUR CAPITAL G + (16#1D50D#, 16#1D514#), -- MATHEMATICAL FRAKTUR CAPITAL J .. MATHEMATICAL FRAKTUR CAPITAL Q + (16#1D516#, 16#1D51C#), -- MATHEMATICAL FRAKTUR CAPITAL S .. MATHEMATICAL FRAKTUR CAPITAL Y + (16#1D51E#, 16#1D539#), -- MATHEMATICAL FRAKTUR SMALL A .. MATHEMATICAL DOUBLE-STRUCK CAPITAL B + (16#1D53B#, 16#1D53E#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL D .. MATHEMATICAL DOUBLE-STRUCK CAPITAL G + (16#1D540#, 16#1D544#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL I .. MATHEMATICAL DOUBLE-STRUCK CAPITAL M + (16#1D546#, 16#1D546#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL O .. MATHEMATICAL DOUBLE-STRUCK CAPITAL O + (16#1D54A#, 16#1D550#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL S .. MATHEMATICAL DOUBLE-STRUCK CAPITAL Y + (16#1D552#, 16#1D6A3#), -- MATHEMATICAL DOUBLE-STRUCK SMALL A .. MATHEMATICAL MONOSPACE SMALL Z + (16#1D6A8#, 16#1D6C0#), -- MATHEMATICAL BOLD CAPITAL ALPHA .. MATHEMATICAL BOLD CAPITAL OMEGA + (16#1D6C2#, 16#1D6DA#), -- MATHEMATICAL BOLD SMALL ALPHA .. MATHEMATICAL BOLD SMALL OMEGA + (16#1D6DC#, 16#1D6FA#), -- MATHEMATICAL BOLD EPSILON SYMBOL .. MATHEMATICAL ITALIC CAPITAL OMEGA + (16#1D6FC#, 16#1D714#), -- MATHEMATICAL ITALIC SMALL ALPHA .. MATHEMATICAL ITALIC SMALL OMEGA + (16#1D716#, 16#1D734#), -- MATHEMATICAL ITALIC EPSILON SYMBOL .. MATHEMATICAL BOLD ITALIC CAPITAL OMEGA + (16#1D736#, 16#1D74E#), -- MATHEMATICAL BOLD ITALIC SMALL ALPHA .. MATHEMATICAL BOLD ITALIC SMALL OMEGA + (16#1D750#, 16#1D76E#), -- MATHEMATICAL BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA + (16#1D770#, 16#1D788#), -- MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA + (16#1D78A#, 16#1D7A8#), -- MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA + (16#1D7AA#, 16#1D7C2#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA + (16#1D7C4#, 16#1D7C9#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL + (16#20000#, 16#2A6D6#), -- .. + (16#2F800#, 16#2FA1D#)); -- CJK COMPATIBILITY IDEOGRAPH-2F800 .. CJK COMPATIBILITY IDEOGRAPH-2FA1D + + -- The following table includes all characters considered spaces, i.e. + -- all characters from the Unicode table with categories: + + -- Separator, Space (Zs) + + UTF_32_Spaces : constant UTF_32_Ranges := ( + (16#00020#, 16#00020#), -- SPACE .. SPACE + (16#000A0#, 16#000A0#), -- NO-BREAK SPACE .. NO-BREAK SPACE + (16#01680#, 16#01680#), -- OGHAM SPACE MARK .. OGHAM SPACE MARK + (16#0180E#, 16#0180E#), -- MONGOLIAN VOWEL SEPARATOR .. MONGOLIAN VOWEL SEPARATOR + (16#02000#, 16#0200B#), -- EN QUAD .. ZERO WIDTH SPACE + (16#0202F#, 16#0202F#), -- NARROW NO-BREAK SPACE .. NARROW NO-BREAK SPACE + (16#0205F#, 16#0205F#), -- MEDIUM MATHEMATICAL SPACE .. MEDIUM MATHEMATICAL SPACE + (16#03000#, 16#03000#)); -- IDEOGRAPHIC SPACE .. IDEOGRAPHIC SPACE + + -- The following table includes all characters considered punctuation, + -- i.e. all characters from the Unicode table with categories: + + -- Punctuation, Connector (Pc) + + UTF_32_Punctuation : constant UTF_32_Ranges := ( + (16#0005F#, 16#0005F#), -- LOW LINE .. LOW LINE + (16#0203F#, 16#02040#), -- UNDERTIE .. CHARACTER TIE + (16#02054#, 16#02054#), -- INVERTED UNDERTIE .. INVERTED UNDERTIE + (16#030FB#, 16#030FB#), -- KATAKANA MIDDLE DOT .. KATAKANA MIDDLE DOT + (16#0FE33#, 16#0FE34#), -- PRESENTATION FORM FOR VERTICAL LOW LINE .. PRESENTATION FORM FOR VERTICAL WAVY LOW LINE + (16#0FE4D#, 16#0FE4F#), -- DASHED LOW LINE .. WAVY LOW LINE + (16#0FF3F#, 16#0FF3F#), -- FULLWIDTH LOW LINE .. FULLWIDTH LOW LINE + (16#0FF65#, 16#0FF65#)); -- HALFWIDTH KATAKANA MIDDLE DOT .. HALFWIDTH KATAKANA MIDDLE DOT + + -- The following table includes all characters considered as other format, + -- i.e. all characters from the Unicode table with categories: + + -- Other, Format (Cf) + + UTF_32_Other_Format : constant UTF_32_Ranges := ( + (16#000AD#, 16#000AD#), -- SOFT HYPHEN .. SOFT HYPHEN + (16#00600#, 16#00603#), -- ARABIC NUMBER SIGN .. ARABIC SIGN SAFHA + (16#006DD#, 16#006DD#), -- ARABIC END OF AYAH .. ARABIC END OF AYAH + (16#0070F#, 16#0070F#), -- SYRIAC ABBREVIATION MARK .. SYRIAC ABBREVIATION MARK + (16#017B4#, 16#017B5#), -- KHMER VOWEL INHERENT AQ .. KHMER VOWEL INHERENT AA + (16#0200C#, 16#0200F#), -- ZERO WIDTH NON-JOINER .. RIGHT-TO-LEFT MARK + (16#0202A#, 16#0202E#), -- LEFT-TO-RIGHT EMBEDDING .. RIGHT-TO-LEFT OVERRIDE + (16#02060#, 16#02063#), -- WORD JOINER .. INVISIBLE SEPARATOR + (16#0206A#, 16#0206F#), -- INHIBIT SYMMETRIC SWAPPING .. NOMINAL DIGIT SHAPES + (16#0FEFF#, 16#0FEFF#), -- ZERO WIDTH NO-BREAK SPACE .. ZERO WIDTH NO-BREAK SPACE + (16#0FFF9#, 16#0FFFB#), -- INTERLINEAR ANNOTATION ANCHOR .. INTERLINEAR ANNOTATION TERMINATOR + (16#1D173#, 16#1D17A#), -- MUSICAL SYMBOL BEGIN BEAM .. MUSICAL SYMBOL END PHRASE + (16#E0001#, 16#E0001#), -- LANGUAGE TAG .. LANGUAGE TAG + (16#E0020#, 16#E007F#)); -- TAG SPACE .. CANCEL TAG + + -- The following table includes all characters considered marks i.e. + -- all characters from the Unicode table with categories: + + -- Mark, Nonspacing (Mn) + -- Mark, Spacing Combining (Mc) + + UTF_32_Marks : constant UTF_32_Ranges := ( + (16#00300#, 16#00357#), -- COMBINING GRAVE ACCENT .. COMBINING RIGHT HALF RING ABOVE + (16#0035D#, 16#0036F#), -- COMBINING DOUBLE BREVE .. COMBINING LATIN SMALL LETTER X + (16#00483#, 16#00486#), -- COMBINING CYRILLIC TITLO .. COMBINING CYRILLIC PSILI PNEUMATA + (16#00591#, 16#005A1#), -- HEBREW ACCENT ETNAHTA .. HEBREW ACCENT PAZER + (16#005A3#, 16#005B9#), -- HEBREW ACCENT MUNAH .. HEBREW POINT HOLAM + (16#005BB#, 16#005BD#), -- HEBREW POINT QUBUTS .. HEBREW POINT METEG + (16#005BF#, 16#005BF#), -- HEBREW POINT RAFE .. HEBREW POINT RAFE + (16#005C1#, 16#005C2#), -- HEBREW POINT SHIN DOT .. HEBREW POINT SIN DOT + (16#005C4#, 16#005C4#), -- HEBREW MARK UPPER DOT .. HEBREW MARK UPPER DOT + (16#00610#, 16#00615#), -- ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM .. ARABIC SMALL HIGH TAH + (16#0064B#, 16#00658#), -- ARABIC FATHATAN .. ARABIC MARK NOON GHUNNA + (16#00670#, 16#00670#), -- ARABIC LETTER SUPERSCRIPT ALEF .. ARABIC LETTER SUPERSCRIPT ALEF + (16#006D6#, 16#006DC#), -- ARABIC SMALL HIGH LIGATURE SAD WITH LAM WITH ALEF MAKSURA .. ARABIC SMALL HIGH SEEN + (16#006DF#, 16#006E4#), -- ARABIC SMALL HIGH ROUNDED ZERO .. ARABIC SMALL HIGH MADDA + (16#006E7#, 16#006E8#), -- ARABIC SMALL HIGH YEH .. ARABIC SMALL HIGH NOON + (16#006EA#, 16#006ED#), -- ARABIC EMPTY CENTRE LOW STOP .. ARABIC SMALL LOW MEEM + (16#00711#, 16#00711#), -- SYRIAC LETTER SUPERSCRIPT ALAPH .. SYRIAC LETTER SUPERSCRIPT ALAPH + (16#00730#, 16#0074A#), -- SYRIAC PTHAHA ABOVE .. SYRIAC BARREKH + (16#007A6#, 16#007B0#), -- THAANA ABAFILI .. THAANA SUKUN + (16#00901#, 16#00903#), -- DEVANAGARI SIGN CANDRABINDU .. DEVANAGARI SIGN VISARGA + (16#0093C#, 16#0093C#), -- DEVANAGARI SIGN NUKTA .. DEVANAGARI SIGN NUKTA + (16#0093E#, 16#0094D#), -- DEVANAGARI VOWEL SIGN AA .. DEVANAGARI SIGN VIRAMA + (16#00951#, 16#00954#), -- DEVANAGARI STRESS SIGN UDATTA .. DEVANAGARI ACUTE ACCENT + (16#00962#, 16#00963#), -- DEVANAGARI VOWEL SIGN VOCALIC L .. DEVANAGARI VOWEL SIGN VOCALIC LL + (16#00981#, 16#00983#), -- BENGALI SIGN CANDRABINDU .. BENGALI SIGN VISARGA + (16#009BC#, 16#009BC#), -- BENGALI SIGN NUKTA .. BENGALI SIGN NUKTA + (16#009BE#, 16#009C4#), -- BENGALI VOWEL SIGN AA .. BENGALI VOWEL SIGN VOCALIC RR + (16#009C7#, 16#009C8#), -- BENGALI VOWEL SIGN E .. BENGALI VOWEL SIGN AI + (16#009CB#, 16#009CD#), -- BENGALI VOWEL SIGN O .. BENGALI SIGN VIRAMA + (16#009D7#, 16#009D7#), -- BENGALI AU LENGTH MARK .. BENGALI AU LENGTH MARK + (16#009E2#, 16#009E3#), -- BENGALI VOWEL SIGN VOCALIC L .. BENGALI VOWEL SIGN VOCALIC LL + (16#00A01#, 16#00A03#), -- GURMUKHI SIGN ADAK BINDI .. GURMUKHI SIGN VISARGA + (16#00A3C#, 16#00A3C#), -- GURMUKHI SIGN NUKTA .. GURMUKHI SIGN NUKTA + (16#00A3E#, 16#00A42#), -- GURMUKHI VOWEL SIGN AA .. GURMUKHI VOWEL SIGN UU + (16#00A47#, 16#00A48#), -- GURMUKHI VOWEL SIGN EE .. GURMUKHI VOWEL SIGN AI + (16#00A4B#, 16#00A4D#), -- GURMUKHI VOWEL SIGN OO .. GURMUKHI SIGN VIRAMA + (16#00A70#, 16#00A71#), -- GURMUKHI TIPPI .. GURMUKHI ADDAK + (16#00A81#, 16#00A83#), -- GUJARATI SIGN CANDRABINDU .. GUJARATI SIGN VISARGA + (16#00ABC#, 16#00ABC#), -- GUJARATI SIGN NUKTA .. GUJARATI SIGN NUKTA + (16#00ABE#, 16#00AC5#), -- GUJARATI VOWEL SIGN AA .. GUJARATI VOWEL SIGN CANDRA E + (16#00AC7#, 16#00AC9#), -- GUJARATI VOWEL SIGN E .. GUJARATI VOWEL SIGN CANDRA O + (16#00ACB#, 16#00ACD#), -- GUJARATI VOWEL SIGN O .. GUJARATI SIGN VIRAMA + (16#00AE2#, 16#00AE3#), -- GUJARATI VOWEL SIGN VOCALIC L .. GUJARATI VOWEL SIGN VOCALIC LL + (16#00B01#, 16#00B03#), -- ORIYA SIGN CANDRABINDU .. ORIYA SIGN VISARGA + (16#00B3C#, 16#00B3C#), -- ORIYA SIGN NUKTA .. ORIYA SIGN NUKTA + (16#00B3E#, 16#00B43#), -- ORIYA VOWEL SIGN AA .. ORIYA VOWEL SIGN VOCALIC R + (16#00B47#, 16#00B48#), -- ORIYA VOWEL SIGN E .. ORIYA VOWEL SIGN AI + (16#00B4B#, 16#00B4D#), -- ORIYA VOWEL SIGN O .. ORIYA SIGN VIRAMA + (16#00B56#, 16#00B57#), -- ORIYA AI LENGTH MARK .. ORIYA AU LENGTH MARK + (16#00B82#, 16#00B82#), -- TAMIL SIGN ANUSVARA .. TAMIL SIGN ANUSVARA + (16#00BBE#, 16#00BC2#), -- TAMIL VOWEL SIGN AA .. TAMIL VOWEL SIGN UU + (16#00BC6#, 16#00BC8#), -- TAMIL VOWEL SIGN E .. TAMIL VOWEL SIGN AI + (16#00BCA#, 16#00BCD#), -- TAMIL VOWEL SIGN O .. TAMIL SIGN VIRAMA + (16#00BD7#, 16#00BD7#), -- TAMIL AU LENGTH MARK .. TAMIL AU LENGTH MARK + (16#00C01#, 16#00C03#), -- TELUGU SIGN CANDRABINDU .. TELUGU SIGN VISARGA + (16#00C3E#, 16#00C44#), -- TELUGU VOWEL SIGN AA .. TELUGU VOWEL SIGN VOCALIC RR + (16#00C46#, 16#00C48#), -- TELUGU VOWEL SIGN E .. TELUGU VOWEL SIGN AI + (16#00C4A#, 16#00C4D#), -- TELUGU VOWEL SIGN O .. TELUGU SIGN VIRAMA + (16#00C55#, 16#00C56#), -- TELUGU LENGTH MARK .. TELUGU AI LENGTH MARK + (16#00C82#, 16#00C83#), -- KANNADA SIGN ANUSVARA .. KANNADA SIGN VISARGA + (16#00CBC#, 16#00CBC#), -- KANNADA SIGN NUKTA .. KANNADA SIGN NUKTA + (16#00CBE#, 16#00CC4#), -- KANNADA VOWEL SIGN AA .. KANNADA VOWEL SIGN VOCALIC RR + (16#00CC6#, 16#00CC8#), -- KANNADA VOWEL SIGN E .. KANNADA VOWEL SIGN AI + (16#00CCA#, 16#00CCD#), -- KANNADA VOWEL SIGN O .. KANNADA SIGN VIRAMA + (16#00CD5#, 16#00CD6#), -- KANNADA LENGTH MARK .. KANNADA AI LENGTH MARK + (16#00D02#, 16#00D03#), -- MALAYALAM SIGN ANUSVARA .. MALAYALAM SIGN VISARGA + (16#00D3E#, 16#00D43#), -- MALAYALAM VOWEL SIGN AA .. MALAYALAM VOWEL SIGN VOCALIC R + (16#00D46#, 16#00D48#), -- MALAYALAM VOWEL SIGN E .. MALAYALAM VOWEL SIGN AI + (16#00D4A#, 16#00D4D#), -- MALAYALAM VOWEL SIGN O .. MALAYALAM SIGN VIRAMA + (16#00D57#, 16#00D57#), -- MALAYALAM AU LENGTH MARK .. MALAYALAM AU LENGTH MARK + (16#00D82#, 16#00D83#), -- SINHALA SIGN ANUSVARAYA .. SINHALA SIGN VISARGAYA + (16#00DCA#, 16#00DCA#), -- SINHALA SIGN AL-LAKUNA .. SINHALA SIGN AL-LAKUNA + (16#00DCF#, 16#00DD4#), -- SINHALA VOWEL SIGN AELA-PILLA .. SINHALA VOWEL SIGN KETTI PAA-PILLA + (16#00DD6#, 16#00DD6#), -- SINHALA VOWEL SIGN DIGA PAA-PILLA .. SINHALA VOWEL SIGN DIGA PAA-PILLA + (16#00DD8#, 16#00DDF#), -- SINHALA VOWEL SIGN GAETTA-PILLA .. SINHALA VOWEL SIGN GAYANUKITTA + (16#00DF2#, 16#00DF3#), -- SINHALA VOWEL SIGN DIGA GAETTA-PILLA .. SINHALA VOWEL SIGN DIGA GAYANUKITTA + (16#00E31#, 16#00E31#), -- THAI CHARACTER MAI HAN-AKAT .. THAI CHARACTER MAI HAN-AKAT + (16#00E34#, 16#00E3A#), -- THAI CHARACTER SARA I .. THAI CHARACTER PHINTHU + (16#00E47#, 16#00E4E#), -- THAI CHARACTER MAITAIKHU .. THAI CHARACTER YAMAKKAN + (16#00EB1#, 16#00EB1#), -- LAO VOWEL SIGN MAI KAN .. LAO VOWEL SIGN MAI KAN + (16#00EB4#, 16#00EB9#), -- LAO VOWEL SIGN I .. LAO VOWEL SIGN UU + (16#00EBB#, 16#00EBC#), -- LAO VOWEL SIGN MAI KON .. LAO SEMIVOWEL SIGN LO + (16#00EC8#, 16#00ECD#), -- LAO TONE MAI EK .. LAO NIGGAHITA + (16#00F18#, 16#00F19#), -- TIBETAN ASTROLOGICAL SIGN -KHYUD PA .. TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS + (16#00F35#, 16#00F35#), -- TIBETAN MARK NGAS BZUNG NYI ZLA .. TIBETAN MARK NGAS BZUNG NYI ZLA + (16#00F37#, 16#00F37#), -- TIBETAN MARK NGAS BZUNG SGOR RTAGS .. TIBETAN MARK NGAS BZUNG SGOR RTAGS + (16#00F39#, 16#00F39#), -- TIBETAN MARK TSA -PHRU .. TIBETAN MARK TSA -PHRU + (16#00F3E#, 16#00F3F#), -- TIBETAN SIGN YAR TSHES .. TIBETAN SIGN MAR TSHES + (16#00F71#, 16#00F84#), -- TIBETAN VOWEL SIGN AA .. TIBETAN MARK HALANTA + (16#00F86#, 16#00F87#), -- TIBETAN SIGN LCI RTAGS .. TIBETAN SIGN YANG RTAGS + (16#00F90#, 16#00F97#), -- TIBETAN SUBJOINED LETTER KA .. TIBETAN SUBJOINED LETTER JA + (16#00F99#, 16#00FBC#), -- TIBETAN SUBJOINED LETTER NYA .. TIBETAN SUBJOINED LETTER FIXED-FORM RA + (16#00FC6#, 16#00FC6#), -- TIBETAN SYMBOL PADMA GDAN .. TIBETAN SYMBOL PADMA GDAN + (16#0102C#, 16#01032#), -- MYANMAR VOWEL SIGN AA .. MYANMAR VOWEL SIGN AI + (16#01036#, 16#01039#), -- MYANMAR SIGN ANUSVARA .. MYANMAR SIGN VIRAMA + (16#01056#, 16#01059#), -- MYANMAR VOWEL SIGN VOCALIC R .. MYANMAR VOWEL SIGN VOCALIC LL + (16#01712#, 16#01714#), -- TAGALOG VOWEL SIGN I .. TAGALOG SIGN VIRAMA + (16#01732#, 16#01734#), -- HANUNOO VOWEL SIGN I .. HANUNOO SIGN PAMUDPOD + (16#01752#, 16#01753#), -- BUHID VOWEL SIGN I .. BUHID VOWEL SIGN U + (16#01772#, 16#01773#), -- TAGBANWA VOWEL SIGN I .. TAGBANWA VOWEL SIGN U + (16#017B6#, 16#017D3#), -- KHMER VOWEL SIGN AA .. KHMER SIGN BATHAMASAT + (16#017DD#, 16#017DD#), -- KHMER SIGN ATTHACAN .. KHMER SIGN ATTHACAN + (16#0180B#, 16#0180D#), -- MONGOLIAN FREE VARIATION SELECTOR ONE .. MONGOLIAN FREE VARIATION SELECTOR THREE + (16#018A9#, 16#018A9#), -- MONGOLIAN LETTER ALI GALI DAGALGA .. MONGOLIAN LETTER ALI GALI DAGALGA + (16#01920#, 16#0192B#), -- LIMBU VOWEL SIGN A .. LIMBU SUBJOINED LETTER WA + (16#01930#, 16#0193B#), -- LIMBU SMALL LETTER KA .. LIMBU SIGN SA-I + (16#020D0#, 16#020DC#), -- COMBINING LEFT HARPOON ABOVE .. COMBINING FOUR DOTS ABOVE + (16#020E1#, 16#020E1#), -- COMBINING LEFT RIGHT ARROW ABOVE .. COMBINING LEFT RIGHT ARROW ABOVE + (16#020E5#, 16#020EA#), -- COMBINING REVERSE SOLIDUS OVERLAY .. COMBINING LEFTWARDS ARROW OVERLAY + (16#0302A#, 16#0302F#), -- IDEOGRAPHIC LEVEL TONE MARK .. HANGUL DOUBLE DOT TONE MARK + (16#03099#, 16#0309A#), -- COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK .. COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK + (16#0FB1E#, 16#0FB1E#), -- HEBREW POINT JUDEO-SPANISH VARIKA .. HEBREW POINT JUDEO-SPANISH VARIKA + (16#0FE00#, 16#0FE0F#), -- VARIATION SELECTOR-1 .. VARIATION SELECTOR-16 + (16#0FE20#, 16#0FE23#), -- COMBINING LIGATURE LEFT HALF .. COMBINING DOUBLE TILDE RIGHT HALF + (16#1D165#, 16#1D169#), -- MUSICAL SYMBOL COMBINING STEM .. MUSICAL SYMBOL COMBINING TREMOLO-3 + (16#1D16D#, 16#1D172#), -- MUSICAL SYMBOL COMBINING AUGMENTATION DOT .. MUSICAL SYMBOL COMBINING FLAG-5 + (16#1D17B#, 16#1D182#), -- MUSICAL SYMBOL COMBINING ACCENT .. MUSICAL SYMBOL COMBINING LOURE + (16#1D185#, 16#1D18B#), -- MUSICAL SYMBOL COMBINING DOIT .. MUSICAL SYMBOL COMBINING TRIPLE TONGUE + (16#1D1AA#, 16#1D1AD#), -- MUSICAL SYMBOL COMBINING DOWN BOW .. MUSICAL SYMBOL COMBINING SNAP PIZZICATO + (16#E0100#, 16#E01EF#)); -- VARIATION SELECTOR-17 .. VARIATION SELECTOR-256 + + -- The following table includes all characters considered non-graphic, + -- i.e. all characters from the Unicode table with categories: + + -- Other, Control (Cc) + -- Other, Private Use (Co) + -- Other, Surrogate (Cs) + -- Separator, Line (Zl) + -- Separator, Paragraph (Zp) + + -- Note that characters with relative positions FFFE and FFFF in their + -- planes are not included in this table (we really don't want to add + -- 32K entries for this purpose). Instead we handle these positions in + -- a completely different manner. + + -- Note: unassigned characters (category Cn) are deliberately NOT included + -- in the set of non-graphics, since the idea is that if any of these are + -- defined in the future, we don't want to have to modify the standard. + + -- Note that Other, Format (Cf) is also quite deliberately not included + -- in the list of categories above. This means that these characters can + -- be included in character and string literals. + + UTF_32_Non_Graphic : constant UTF_32_Ranges := ( + (16#00000#, 16#0001F#), -- .. + (16#0007F#, 16#0009F#), -- .. + (16#02028#, 16#02029#), -- LINE SEPARATOR .. PARAGRAPH SEPARATOR + (16#0D800#, 16#0DB7F#), -- .. + (16#0DB80#, 16#0DBFF#), -- .. + (16#0DC00#, 16#0DFFF#), -- .. + (16#0E000#, 16#0F8FF#), -- .. + (16#F0000#, 16#FFFFD#), -- .. + (16#100000#, 16#10FFFD#)); -- .. + + -- The following two tables define the mapping to upper case. The first + -- table gives the ranges of lower case letters. The corresponding entry + -- in Uppercase_Adjust shows the amount to be added to (or subtracted from + -- if the value is negative) the code value to get the corresponding upper + -- case letter. + -- + -- An entry is in this table if its 10646 has the string SMALL LETTER + -- the name, and there is a corresponding entry which has the string + -- CAPITAL LETTER in its name. + + Lower_Case_Letters : constant UTF_32_Ranges := ( + (16#00061#, 16#0007A#), -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z + (16#000E0#, 16#000F6#), -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS + (16#000F8#, 16#000FE#), -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN + (16#000FF#, 16#000FF#), -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS + (16#00101#, 16#00101#), -- LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON + (16#00103#, 16#00103#), -- LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE + (16#00105#, 16#00105#), -- LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK + (16#00107#, 16#00107#), -- LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE + (16#00109#, 16#00109#), -- LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX + (16#0010B#, 16#0010B#), -- LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE + (16#0010D#, 16#0010D#), -- LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON + (16#0010F#, 16#0010F#), -- LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON + (16#00111#, 16#00111#), -- LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE + (16#00113#, 16#00113#), -- LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON + (16#00115#, 16#00115#), -- LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE + (16#00117#, 16#00117#), -- LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE + (16#00119#, 16#00119#), -- LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK + (16#0011B#, 16#0011B#), -- LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON + (16#0011D#, 16#0011D#), -- LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX + (16#0011F#, 16#0011F#), -- LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE + (16#00121#, 16#00121#), -- LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE + (16#00123#, 16#00123#), -- LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA + (16#00125#, 16#00125#), -- LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX + (16#00127#, 16#00127#), -- LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE + (16#00129#, 16#00129#), -- LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE + (16#0012B#, 16#0012B#), -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON + (16#0012D#, 16#0012D#), -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE + (16#0012F#, 16#0012F#), -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK + (16#00133#, 16#00133#), -- LATIN SMALL LETTER I J .. LATIN SMALL LETTER I J + (16#00135#, 16#00135#), -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX + (16#00137#, 16#00137#), -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA + (16#0013A#, 16#0013A#), -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE + (16#0013C#, 16#0013C#), -- LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA + (16#0013E#, 16#0013E#), -- LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON + (16#00140#, 16#00140#), -- LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT + (16#00142#, 16#00142#), -- LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE + (16#00144#, 16#00144#), -- LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE + (16#00146#, 16#00146#), -- LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA + (16#00148#, 16#00148#), -- LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N WITH CARON + (16#0014B#, 16#0014B#), -- LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG + (16#0014D#, 16#0014D#), -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON + (16#0014F#, 16#0014F#), -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE + (16#00151#, 16#00151#), -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE + (16#00153#, 16#00153#), -- LATIN SMALL LETTER O E .. LATIN SMALL LETTER O E + (16#00155#, 16#00155#), -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE + (16#00157#, 16#00157#), -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA + (16#00159#, 16#00159#), -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON + (16#0015B#, 16#0015B#), -- LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE + (16#0015D#, 16#0015D#), -- LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX + (16#0015F#, 16#0015F#), -- LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA + (16#00161#, 16#00161#), -- LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON + (16#00163#, 16#00163#), -- LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA + (16#00165#, 16#00165#), -- LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON + (16#00167#, 16#00167#), -- LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE + (16#00169#, 16#00169#), -- LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE + (16#0016B#, 16#0016B#), -- LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON + (16#0016D#, 16#0016D#), -- LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE + (16#0016F#, 16#0016F#), -- LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE + (16#00171#, 16#00171#), -- LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE + (16#00173#, 16#00173#), -- LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK + (16#00175#, 16#00175#), -- LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX + (16#00177#, 16#00177#), -- LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX + (16#0017A#, 16#0017A#), -- LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE + (16#0017C#, 16#0017C#), -- LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE + (16#0017E#, 16#0017E#), -- LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER Z WITH CARON + (16#00183#, 16#00183#), -- LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR + (16#00185#, 16#00185#), -- LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX + (16#00188#, 16#00188#), -- LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK + (16#0018C#, 16#0018C#), -- LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER D WITH TOPBAR + (16#00192#, 16#00192#), -- LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK + (16#00199#, 16#00199#), -- LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER K WITH HOOK + (16#0019E#, 16#0019E#), -- LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG + (16#001A1#, 16#001A1#), -- LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN + (16#001A3#, 16#001A3#), -- LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI + (16#001A5#, 16#001A5#), -- LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK + (16#001A8#, 16#001A8#), -- LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO + (16#001AD#, 16#001AD#), -- LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK + (16#001B0#, 16#001B0#), -- LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN + (16#001B4#, 16#001B4#), -- LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK + (16#001B6#, 16#001B6#), -- LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE + (16#001B9#, 16#001B9#), -- LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH REVERSED + (16#001BD#, 16#001BD#), -- LATIN SMALL LETTER TONE FIVE .. LATIN SMALL LETTER TONE FIVE + (16#001C6#, 16#001C6#), -- LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON + (16#001C9#, 16#001C9#), -- LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ + (16#001CC#, 16#001CC#), -- LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ + (16#001CE#, 16#001CE#), -- LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON + (16#001D0#, 16#001D0#), -- LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON + (16#001D2#, 16#001D2#), -- LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON + (16#001D4#, 16#001D4#), -- LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON + (16#001D6#, 16#001D6#), -- LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON + (16#001D8#, 16#001D8#), -- LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE + (16#001DA#, 16#001DA#), -- LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON + (16#001DC#, 16#001DC#), -- LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE + (16#001DF#, 16#001DF#), -- LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON + (16#001E1#, 16#001E1#), -- LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON + (16#001E3#, 16#001E3#), -- LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON + (16#001E5#, 16#001E5#), -- LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE + (16#001E7#, 16#001E7#), -- LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON + (16#001E9#, 16#001E9#), -- LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON + (16#001EB#, 16#001EB#), -- LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK + (16#001ED#, 16#001ED#), -- LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON + (16#001EF#, 16#001EF#), -- LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER EZH WITH CARON + (16#001F3#, 16#001F3#), -- LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ + (16#001F5#, 16#001F5#), -- LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE + (16#001F9#, 16#001F9#), -- LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE + (16#001FB#, 16#001FB#), -- LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE + (16#001FD#, 16#001FD#), -- LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE + (16#001FF#, 16#001FF#), -- LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE + (16#00201#, 16#00201#), -- LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE + (16#00203#, 16#00203#), -- LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE + (16#00205#, 16#00205#), -- LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE + (16#00207#, 16#00207#), -- LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE + (16#00209#, 16#00209#), -- LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE + (16#0020B#, 16#0020B#), -- LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE + (16#0020D#, 16#0020D#), -- LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE + (16#0020F#, 16#0020F#), -- LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE + (16#00211#, 16#00211#), -- LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE + (16#00213#, 16#00213#), -- LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE + (16#00215#, 16#00215#), -- LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE + (16#00217#, 16#00217#), -- LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE + (16#00219#, 16#00219#), -- LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW + (16#0021B#, 16#0021B#), -- LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW + (16#0021D#, 16#0021D#), -- LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH + (16#0021F#, 16#0021F#), -- LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON + (16#00223#, 16#00223#), -- LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU + (16#00225#, 16#00225#), -- LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK + (16#00227#, 16#00227#), -- LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE + (16#00229#, 16#00229#), -- LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA + (16#0022B#, 16#0022B#), -- LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON + (16#0022D#, 16#0022D#), -- LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON + (16#0022F#, 16#0022F#), -- LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE + (16#00231#, 16#00231#), -- LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON + (16#00233#, 16#00233#), -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON + (16#00253#, 16#00253#), -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK + (16#00254#, 16#00254#), -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O + (16#00257#, 16#00257#), -- LATIN SMALL LETTER D WITH HOOK .. LATIN SMALL LETTER D WITH HOOK + (16#00258#, 16#00259#), -- LATIN SMALL LETTER REVERSED E .. LATIN SMALL LETTER SCHWA + (16#0025B#, 16#0025B#), -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E + (16#00260#, 16#00260#), -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK + (16#00263#, 16#00263#), -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA + (16#00268#, 16#00268#), -- LATIN SMALL LETTER I WITH STROKE .. LATIN SMALL LETTER I WITH STROKE + (16#00269#, 16#00269#), -- LATIN SMALL LETTER IOTA .. LATIN SMALL LETTER IOTA + (16#0026F#, 16#0026F#), -- LATIN SMALL LETTER TURNED M .. LATIN SMALL LETTER TURNED M + (16#00272#, 16#00272#), -- LATIN SMALL LETTER N WITH LEFT HOOK .. LATIN SMALL LETTER N WITH LEFT HOOK + (16#00283#, 16#00283#), -- LATIN SMALL LETTER ESH .. LATIN SMALL LETTER ESH + (16#00288#, 16#00288#), -- LATIN SMALL LETTER T WITH RETROFLEX HOOK .. LATIN SMALL LETTER T WITH RETROFLEX HOOK + (16#0028A#, 16#0028B#), -- LATIN SMALL LETTER UPSILON .. LATIN SMALL LETTER V WITH HOOK + (16#00292#, 16#00292#), -- LATIN SMALL LETTER EZH .. LATIN SMALL LETTER EZH + (16#003AC#, 16#003AC#), -- GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER ALPHA WITH TONOS + (16#003AD#, 16#003AF#), -- GREEK SMALL LETTER EPSILON WITH TONOS .. GREEK SMALL LETTER IOTA WITH TONOS + (16#003B1#, 16#003C1#), -- GREEK SMALL LETTER ALPHA .. GREEK SMALL LETTER RHO + (16#003C3#, 16#003CB#), -- GREEK SMALL LETTER SIGMA .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA + (16#003CC#, 16#003CC#), -- GREEK SMALL LETTER OMICRON WITH TONOS .. GREEK SMALL LETTER OMICRON WITH TONOS + (16#003CD#, 16#003CE#), -- GREEK SMALL LETTER UPSILON WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS + (16#003DB#, 16#003DB#), -- GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA + (16#003DD#, 16#003DD#), -- GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA + (16#003DF#, 16#003DF#), -- GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA + (16#003E1#, 16#003E1#), -- GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI + (16#003E3#, 16#003E3#), -- COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI + (16#003E5#, 16#003E5#), -- COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI + (16#003E7#, 16#003E7#), -- COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI + (16#003E9#, 16#003E9#), -- COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI + (16#003EB#, 16#003EB#), -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA + (16#003ED#, 16#003ED#), -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA + (16#003EF#, 16#003EF#), -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI + (16#003F8#, 16#003F8#), -- GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO + (16#003FB#, 16#003FB#), -- GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN + (16#00430#, 16#0044F#), -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA + (16#00450#, 16#0045F#), -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE + (16#00461#, 16#00461#), -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA + (16#00463#, 16#00463#), -- CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT + (16#00465#, 16#00465#), -- CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E + (16#00467#, 16#00467#), -- CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS + (16#00469#, 16#00469#), -- CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS + (16#0046B#, 16#0046B#), -- CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS + (16#0046D#, 16#0046D#), -- CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS + (16#0046F#, 16#0046F#), -- CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI + (16#00471#, 16#00471#), -- CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI + (16#00473#, 16#00473#), -- CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA + (16#00475#, 16#00475#), -- CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA + (16#00477#, 16#00477#), -- CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + (16#00479#, 16#00479#), -- CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK + (16#0047B#, 16#0047B#), -- CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA + (16#0047D#, 16#0047D#), -- CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO + (16#0047F#, 16#0047F#), -- CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT + (16#00481#, 16#00481#), -- CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA + (16#0048B#, 16#0048B#), -- CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL + (16#0048D#, 16#0048D#), -- CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN + (16#0048F#, 16#0048F#), -- CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK + (16#00491#, 16#00491#), -- CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN + (16#00493#, 16#00493#), -- CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE + (16#00495#, 16#00495#), -- CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK + (16#00497#, 16#00497#), -- CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER + (16#00499#, 16#00499#), -- CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER + (16#0049B#, 16#0049B#), -- CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER + (16#0049D#, 16#0049D#), -- CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE + (16#0049F#, 16#0049F#), -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE + (16#004A1#, 16#004A1#), -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA + (16#004A3#, 16#004A3#), -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER + (16#004A5#, 16#004A5#), -- CYRILLIC SMALL LETTER EN GE .. CYRILLIC SMALL LETTER EN GE + (16#004A7#, 16#004A7#), -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK + (16#004A9#, 16#004A9#), -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA + (16#004AB#, 16#004AB#), -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER + (16#004AD#, 16#004AD#), -- CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER + (16#004AF#, 16#004AF#), -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U + (16#004B1#, 16#004B1#), -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE + (16#004B3#, 16#004B3#), -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER + (16#004B5#, 16#004B5#), -- CYRILLIC SMALL LETTER TE TSE .. CYRILLIC SMALL LETTER TE TSE + (16#004B7#, 16#004B7#), -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER + (16#004B9#, 16#004B9#), -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE + (16#004BB#, 16#004BB#), -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA + (16#004BD#, 16#004BD#), -- CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE + (16#004BF#, 16#004BF#), -- CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER + (16#004C2#, 16#004C2#), -- CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE + (16#004C4#, 16#004C4#), -- CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK + (16#004C6#, 16#004C6#), -- CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL + (16#004C8#, 16#004C8#), -- CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK + (16#004CA#, 16#004CA#), -- CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL + (16#004CC#, 16#004CC#), -- CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE + (16#004CE#, 16#004CE#), -- CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL + (16#004D1#, 16#004D1#), -- CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE + (16#004D3#, 16#004D3#), -- CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS + (16#004D7#, 16#004D7#), -- CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE + (16#004D9#, 16#004D9#), -- CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA + (16#004DB#, 16#004DB#), -- CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS + (16#004DD#, 16#004DD#), -- CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS + (16#004DF#, 16#004DF#), -- CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS + (16#004E1#, 16#004E1#), -- CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE + (16#004E3#, 16#004E3#), -- CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON + (16#004E5#, 16#004E5#), -- CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS + (16#004E7#, 16#004E7#), -- CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS + (16#004E9#, 16#004E9#), -- CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O + (16#004EB#, 16#004EB#), -- CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS + (16#004ED#, 16#004ED#), -- CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS + (16#004EF#, 16#004EF#), -- CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON + (16#004F1#, 16#004F1#), -- CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS + (16#004F3#, 16#004F3#), -- CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE + (16#004F5#, 16#004F5#), -- CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS + (16#004F9#, 16#004F9#), -- CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS + (16#00501#, 16#00501#), -- CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE + (16#00503#, 16#00503#), -- CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE + (16#00505#, 16#00505#), -- CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE + (16#00507#, 16#00507#), -- CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE + (16#00509#, 16#00509#), -- CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE + (16#0050B#, 16#0050B#), -- CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE + (16#0050D#, 16#0050D#), -- CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE + (16#0050F#, 16#0050F#), -- CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE + (16#00561#, 16#00586#), -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LETTER FEH + (16#010D0#, 16#010F5#), -- GEORGIAN SMALL LETTER AN .. GEORGIAN SMALL LETTER HOE + (16#01E01#, 16#01E01#), -- LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW + (16#01E03#, 16#01E03#), -- LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE + (16#01E05#, 16#01E05#), -- LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW + (16#01E07#, 16#01E07#), -- LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW + (16#01E09#, 16#01E09#), -- LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE + (16#01E0B#, 16#01E0B#), -- LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE + (16#01E0D#, 16#01E0D#), -- LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW + (16#01E0F#, 16#01E0F#), -- LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW + (16#01E11#, 16#01E11#), -- LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA + (16#01E13#, 16#01E13#), -- LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW + (16#01E15#, 16#01E15#), -- LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE + (16#01E17#, 16#01E17#), -- LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE + (16#01E19#, 16#01E19#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW + (16#01E1B#, 16#01E1B#), -- LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW + (16#01E1D#, 16#01E1D#), -- LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE + (16#01E1F#, 16#01E1F#), -- LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE + (16#01E21#, 16#01E21#), -- LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON + (16#01E23#, 16#01E23#), -- LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE + (16#01E25#, 16#01E25#), -- LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW + (16#01E27#, 16#01E27#), -- LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS + (16#01E29#, 16#01E29#), -- LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA + (16#01E2B#, 16#01E2B#), -- LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW + (16#01E2D#, 16#01E2D#), -- LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW + (16#01E2F#, 16#01E2F#), -- LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE + (16#01E31#, 16#01E31#), -- LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE + (16#01E33#, 16#01E33#), -- LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW + (16#01E35#, 16#01E35#), -- LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW + (16#01E37#, 16#01E37#), -- LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW + (16#01E39#, 16#01E39#), -- LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON + (16#01E3B#, 16#01E3B#), -- LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW + (16#01E3D#, 16#01E3D#), -- LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW + (16#01E3F#, 16#01E3F#), -- LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE + (16#01E41#, 16#01E41#), -- LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE + (16#01E43#, 16#01E43#), -- LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW + (16#01E45#, 16#01E45#), -- LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE + (16#01E47#, 16#01E47#), -- LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW + (16#01E49#, 16#01E49#), -- LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW + (16#01E4B#, 16#01E4B#), -- LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW + (16#01E4D#, 16#01E4D#), -- LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE + (16#01E4F#, 16#01E4F#), -- LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS + (16#01E51#, 16#01E51#), -- LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE + (16#01E53#, 16#01E53#), -- LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE + (16#01E55#, 16#01E55#), -- LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE + (16#01E57#, 16#01E57#), -- LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE + (16#01E59#, 16#01E59#), -- LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE + (16#01E5B#, 16#01E5B#), -- LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW + (16#01E5D#, 16#01E5D#), -- LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON + (16#01E5F#, 16#01E5F#), -- LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW + (16#01E61#, 16#01E61#), -- LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE + (16#01E63#, 16#01E63#), -- LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW + (16#01E65#, 16#01E65#), -- LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE + (16#01E67#, 16#01E67#), -- LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE + (16#01E69#, 16#01E69#), -- LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE + (16#01E6B#, 16#01E6B#), -- LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE + (16#01E6D#, 16#01E6D#), -- LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW + (16#01E6F#, 16#01E6F#), -- LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW + (16#01E71#, 16#01E71#), -- LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW + (16#01E73#, 16#01E73#), -- LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW + (16#01E75#, 16#01E75#), -- LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW + (16#01E77#, 16#01E77#), -- LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW + (16#01E79#, 16#01E79#), -- LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE + (16#01E7B#, 16#01E7B#), -- LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS + (16#01E7D#, 16#01E7D#), -- LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE + (16#01E7F#, 16#01E7F#), -- LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW + (16#01E81#, 16#01E81#), -- LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE + (16#01E83#, 16#01E83#), -- LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE + (16#01E85#, 16#01E85#), -- LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS + (16#01E87#, 16#01E87#), -- LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE + (16#01E89#, 16#01E89#), -- LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW + (16#01E8B#, 16#01E8B#), -- LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE + (16#01E8D#, 16#01E8D#), -- LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS + (16#01E8F#, 16#01E8F#), -- LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE + (16#01E91#, 16#01E91#), -- LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX + (16#01E93#, 16#01E93#), -- LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW + (16#01E95#, 16#01E95#), -- LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER Z WITH LINE BELOW + (16#01EA1#, 16#01EA1#), -- LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW + (16#01EA3#, 16#01EA3#), -- LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE + (16#01EA5#, 16#01EA5#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE + (16#01EA7#, 16#01EA7#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE + (16#01EA9#, 16#01EA9#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EAB#, 16#01EAB#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE + (16#01EAD#, 16#01EAD#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW + (16#01EAF#, 16#01EAF#), -- LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE + (16#01EB1#, 16#01EB1#), -- LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE + (16#01EB3#, 16#01EB3#), -- LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE + (16#01EB5#, 16#01EB5#), -- LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE + (16#01EB7#, 16#01EB7#), -- LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW + (16#01EB9#, 16#01EB9#), -- LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW + (16#01EBB#, 16#01EBB#), -- LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE + (16#01EBD#, 16#01EBD#), -- LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE + (16#01EBF#, 16#01EBF#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE + (16#01EC1#, 16#01EC1#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE + (16#01EC3#, 16#01EC3#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EC5#, 16#01EC5#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE + (16#01EC7#, 16#01EC7#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW + (16#01EC9#, 16#01EC9#), -- LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE + (16#01ECB#, 16#01ECB#), -- LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW + (16#01ECD#, 16#01ECD#), -- LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW + (16#01ECF#, 16#01ECF#), -- LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE + (16#01ED1#, 16#01ED1#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE + (16#01ED3#, 16#01ED3#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE + (16#01ED5#, 16#01ED5#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + (16#01ED7#, 16#01ED7#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE + (16#01ED9#, 16#01ED9#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW + (16#01EDB#, 16#01EDB#), -- LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE + (16#01EDD#, 16#01EDD#), -- LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE + (16#01EDF#, 16#01EDF#), -- LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE + (16#01EE1#, 16#01EE1#), -- LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE + (16#01EE3#, 16#01EE3#), -- LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW + (16#01EE5#, 16#01EE5#), -- LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW + (16#01EE7#, 16#01EE7#), -- LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE + (16#01EE9#, 16#01EE9#), -- LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE + (16#01EEB#, 16#01EEB#), -- LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE + (16#01EED#, 16#01EED#), -- LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE + (16#01EEF#, 16#01EEF#), -- LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE + (16#01EF1#, 16#01EF1#), -- LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW + (16#01EF3#, 16#01EF3#), -- LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE + (16#01EF5#, 16#01EF5#), -- LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW + (16#01EF7#, 16#01EF7#), -- LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE + (16#01EF9#, 16#01EF9#), -- LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE + (16#01F00#, 16#01F07#), -- GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI + (16#01F10#, 16#01F15#), -- GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA + (16#01F20#, 16#01F27#), -- GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI + (16#01F30#, 16#01F37#), -- GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI + (16#01F40#, 16#01F45#), -- GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA + (16#01F51#, 16#01F51#), -- GREEK SMALL LETTER UPSILON WITH DASIA .. GREEK SMALL LETTER UPSILON WITH DASIA + (16#01F53#, 16#01F53#), -- GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA + (16#01F55#, 16#01F55#), -- GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA + (16#01F57#, 16#01F57#), -- GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI + (16#01F60#, 16#01F67#), -- GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI + (16#01F70#, 16#01F71#), -- GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER ALPHA WITH OXIA + (16#01F72#, 16#01F75#), -- GREEK SMALL LETTER EPSILON WITH VARIA .. GREEK SMALL LETTER ETA WITH OXIA + (16#01F76#, 16#01F77#), -- GREEK SMALL LETTER IOTA WITH VARIA .. GREEK SMALL LETTER IOTA WITH OXIA + (16#01F78#, 16#01F79#), -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA + (16#01F7A#, 16#01F7B#), -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA + (16#01F7C#, 16#01F7D#), -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA + (16#01FB0#, 16#01FB1#), -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON + (16#01FD0#, 16#01FD1#), -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON + (16#01FE0#, 16#01FE1#), -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON + (16#01FE5#, 16#01FE5#), -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA + (16#024D0#, 16#024E9#), -- CIRCLED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z + (16#0FF41#, 16#0FF5A#), -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z + (16#10428#, 16#1044F#), -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW + (16#E0061#, 16#E007A#)); -- TAG LATIN SMALL LETTER A .. TAG LATIN SMALL LETTER Z + + Lower_Case_Adjust : constant array (Lower_Case_Letters'Range) + of UTF_32'Base := ( + -32, -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z + -32, -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS + -32, -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN + 121, -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS + -1, -- LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON + -1, -- LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE + -1, -- LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK + -1, -- LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE + -1, -- LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE + -1, -- LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON + -1, -- LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON + -1, -- LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE + -1, -- LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON + -1, -- LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE + -1, -- LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE + -1, -- LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK + -1, -- LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON + -1, -- LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE + -1, -- LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE + -1, -- LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA + -1, -- LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE + -1, -- LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE + -1, -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON + -1, -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE + -1, -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK + -1, -- LATIN SMALL LETTER I J .. LATIN SMALL LETTER I J + -1, -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA + -1, -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE + -1, -- LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA + -1, -- LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON + -1, -- LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT + -1, -- LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE + -1, -- LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE + -1, -- LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA + -1, -- LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N WITH CARON + -1, -- LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG + -1, -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON + -1, -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE + -1, -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE + -1, -- LATIN SMALL LETTER O E .. LATIN SMALL LETTER O E + -1, -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE + -1, -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA + -1, -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON + -1, -- LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE + -1, -- LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA + -1, -- LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON + -1, -- LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA + -1, -- LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON + -1, -- LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE + -1, -- LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE + -1, -- LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON + -1, -- LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE + -1, -- LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE + -1, -- LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE + -1, -- LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK + -1, -- LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE + -1, -- LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE + -1, -- LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER Z WITH CARON + -1, -- LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR + -1, -- LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX + -1, -- LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK + -1, -- LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER D WITH TOPBAR + -1, -- LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK + -1, -- LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER K WITH HOOK + 130, -- LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG + -1, -- LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN + -1, -- LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI + -1, -- LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK + -1, -- LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO + -1, -- LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK + -1, -- LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN + -1, -- LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK + -1, -- LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE + -1, -- LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH REVERSED + -1, -- LATIN SMALL LETTER TONE FIVE .. LATIN SMALL LETTER TONE FIVE + -2, -- LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON + -2, -- LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ + -2, -- LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ + -1, -- LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON + -1, -- LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON + -1, -- LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON + -1, -- LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON + -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON + -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE + -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON + -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE + -1, -- LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON + -1, -- LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON + -1, -- LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON + -1, -- LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE + -1, -- LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON + -1, -- LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON + -1, -- LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK + -1, -- LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON + -1, -- LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER EZH WITH CARON + -2, -- LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ + -1, -- LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE + -1, -- LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE + -1, -- LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE + -1, -- LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE + -1, -- LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE + -1, -- LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE + -1, -- LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE + -1, -- LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE + -1, -- LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE + -1, -- LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE + -1, -- LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE + -1, -- LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE + -1, -- LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE + -1, -- LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE + -1, -- LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE + -1, -- LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE + -1, -- LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE + -1, -- LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW + -1, -- LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW + -1, -- LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH + -1, -- LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON + -1, -- LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU + -1, -- LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK + -1, -- LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE + -1, -- LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA + -1, -- LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON + -1, -- LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON + -1, -- LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE + -1, -- LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON + -1, -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON + -210, -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK + -206, -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O + -205, -- LATIN SMALL LETTER D WITH HOOK .. LATIN SMALL LETTER D WITH HOOK + -202, -- LATIN SMALL LETTER REVERSED E .. LATIN SMALL LETTER SCHWA + -203, -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E + -205, -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK + -207, -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA + -209, -- LATIN SMALL LETTER I WITH STROKE .. LATIN SMALL LETTER I WITH STROKE + -211, -- LATIN SMALL LETTER IOTA .. LATIN SMALL LETTER IOTA + -211, -- LATIN SMALL LETTER TURNED M .. LATIN SMALL LETTER TURNED M + -213, -- LATIN SMALL LETTER N WITH LEFT HOOK .. LATIN SMALL LETTER N WITH LEFT HOOK + -218, -- LATIN SMALL LETTER ESH .. LATIN SMALL LETTER ESH + -218, -- LATIN SMALL LETTER T WITH RETROFLEX HOOK .. LATIN SMALL LETTER T WITH RETROFLEX HOOK + -217, -- LATIN SMALL LETTER UPSILON .. LATIN SMALL LETTER V WITH HOOK + -219, -- LATIN SMALL LETTER EZH .. LATIN SMALL LETTER EZH + -38, -- GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER ALPHA WITH TONOS + -37, -- GREEK SMALL LETTER EPSILON WITH TONOS .. GREEK SMALL LETTER IOTA WITH TONOS + -32, -- GREEK SMALL LETTER ALPHA .. GREEK SMALL LETTER RHO + -32, -- GREEK SMALL LETTER SIGMA .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA + -64, -- GREEK SMALL LETTER OMICRON WITH TONOS .. GREEK SMALL LETTER OMICRON WITH TONOS + -63, -- GREEK SMALL LETTER UPSILON WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS + -1, -- GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA + -1, -- GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA + -1, -- GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA + -1, -- GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI + -1, -- COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI + -1, -- COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI + -1, -- COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI + -1, -- COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI + -1, -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA + -1, -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA + -1, -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI + -1, -- GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO + -1, -- GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN + -32, -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA + -80, -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE + -1, -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA + -1, -- CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT + -1, -- CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E + -1, -- CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS + -1, -- CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS + -1, -- CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS + -1, -- CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS + -1, -- CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI + -1, -- CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI + -1, -- CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA + -1, -- CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA + -1, -- CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + -1, -- CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK + -1, -- CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA + -1, -- CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO + -1, -- CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT + -1, -- CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA + -1, -- CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL + -1, -- CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN + -1, -- CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK + -1, -- CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN + -1, -- CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE + -1, -- CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK + -1, -- CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE + -1, -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE + -1, -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA + -1, -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER EN GE .. CYRILLIC SMALL LETTER EN GE + -1, -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK + -1, -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA + -1, -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U + -1, -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE + -1, -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER TE TSE .. CYRILLIC SMALL LETTER TE TSE + -1, -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE + -1, -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA + -1, -- CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE + -1, -- CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER + -1, -- CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE + -1, -- CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK + -1, -- CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL + -1, -- CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK + -1, -- CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL + -1, -- CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE + -1, -- CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL + -1, -- CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE + -1, -- CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE + -1, -- CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA + -1, -- CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE + -1, -- CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON + -1, -- CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O + -1, -- CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON + -1, -- CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE + -1, -- CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS + -1, -- CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE + -1, -- CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE + -1, -- CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE + -1, -- CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE + -1, -- CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE + -1, -- CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE + -1, -- CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE + -1, -- CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE + -48, -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LETTER FEH + -48, -- GEORGIAN SMALL LETTER AN .. GEORGIAN SMALL LETTER HOE + -1, -- LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW + -1, -- LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE + -1, -- LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW + -1, -- LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW + -1, -- LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE + -1, -- LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE + -1, -- LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW + -1, -- LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW + -1, -- LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA + -1, -- LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW + -1, -- LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE + -1, -- LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE + -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW + -1, -- LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW + -1, -- LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE + -1, -- LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE + -1, -- LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON + -1, -- LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE + -1, -- LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW + -1, -- LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS + -1, -- LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA + -1, -- LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW + -1, -- LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW + -1, -- LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE + -1, -- LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE + -1, -- LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW + -1, -- LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW + -1, -- LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW + -1, -- LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON + -1, -- LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW + -1, -- LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW + -1, -- LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE + -1, -- LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE + -1, -- LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW + -1, -- LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE + -1, -- LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW + -1, -- LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW + -1, -- LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW + -1, -- LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE + -1, -- LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS + -1, -- LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE + -1, -- LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE + -1, -- LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE + -1, -- LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE + -1, -- LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE + -1, -- LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW + -1, -- LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON + -1, -- LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW + -1, -- LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE + -1, -- LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW + -1, -- LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE + -1, -- LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE + -1, -- LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE + -1, -- LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE + -1, -- LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW + -1, -- LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW + -1, -- LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW + -1, -- LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW + -1, -- LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW + -1, -- LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW + -1, -- LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE + -1, -- LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS + -1, -- LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE + -1, -- LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW + -1, -- LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE + -1, -- LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE + -1, -- LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS + -1, -- LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE + -1, -- LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW + -1, -- LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE + -1, -- LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS + -1, -- LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE + -1, -- LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX + -1, -- LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW + -1, -- LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER Z WITH LINE BELOW + -1, -- LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW + -1, -- LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE + -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE + -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE + -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE + -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW + -1, -- LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE + -1, -- LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE + -1, -- LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE + -1, -- LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE + -1, -- LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW + -1, -- LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW + -1, -- LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE + -1, -- LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE + -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE + -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE + -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE + -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW + -1, -- LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE + -1, -- LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW + -1, -- LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW + -1, -- LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE + -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE + -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE + -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE + -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW + -1, -- LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE + -1, -- LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE + -1, -- LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE + -1, -- LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE + -1, -- LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW + -1, -- LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW + -1, -- LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE + -1, -- LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE + -1, -- LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE + -1, -- LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE + -1, -- LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE + -1, -- LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW + -1, -- LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE + -1, -- LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW + -1, -- LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE + -1, -- LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE + 8, -- GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI + 8, -- GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA + 8, -- GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI + 8, -- GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI + 8, -- GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA + 8, -- GREEK SMALL LETTER UPSILON WITH DASIA .. GREEK SMALL LETTER UPSILON WITH DASIA + 8, -- GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA + 8, -- GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA + 8, -- GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI + 8, -- GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI + 74, -- GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER ALPHA WITH OXIA + 86, -- GREEK SMALL LETTER EPSILON WITH VARIA .. GREEK SMALL LETTER ETA WITH OXIA + 100, -- GREEK SMALL LETTER IOTA WITH VARIA .. GREEK SMALL LETTER IOTA WITH OXIA + 128, -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA + 112, -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA + 126, -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA + 8, -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON + 8, -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON + 8, -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON + 7, -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA + -26, -- CIRCLED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z + -32, -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z + -40, -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW + -32); -- TAG LATIN SMALL LETTER A .. TAG LATIN SMALL LETTER Z + + -- The following is a list of the 10646 names for SMALL LETTER entries + -- that have no matching CAPITAL LETTER entry and are thus not folded + + -- LATIN SMALL LETTER SHARP S + -- LATIN SMALL LETTER DOTLESS I + -- LATIN SMALL LETTER KRA + -- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE + -- LATIN SMALL LETTER LONG S + -- LATIN SMALL LETTER B WITH STROKE + -- LATIN SMALL LETTER TURNED DELTA + -- LATIN SMALL LETTER HV + -- LATIN SMALL LETTER L WITH BAR + -- LATIN SMALL LETTER LAMBDA WITH STROKE + -- LATIN SMALL LETTER T WITH PALATAL HOOK + -- LATIN SMALL LETTER EZH WITH TAIL + -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON + -- LATIN CAPITAL LETTER L WITH SMALL LETTER J + -- LATIN CAPITAL LETTER N WITH SMALL LETTER J + -- LATIN SMALL LETTER TURNED E + -- LATIN SMALL LETTER J WITH CARON + -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z + -- LATIN SMALL LETTER D WITH CURL + -- LATIN SMALL LETTER L WITH CURL + -- LATIN SMALL LETTER N WITH CURL + -- LATIN SMALL LETTER T WITH CURL + -- LATIN SMALL LETTER TURNED A + -- LATIN SMALL LETTER ALPHA + -- LATIN SMALL LETTER TURNED ALPHA + -- LATIN SMALL LETTER C WITH CURL + -- LATIN SMALL LETTER D WITH TAIL + -- LATIN SMALL LETTER SCHWA WITH HOOK + -- LATIN SMALL LETTER REVERSED OPEN E + -- LATIN SMALL LETTER REVERSED OPEN E WITH HOOK + -- LATIN SMALL LETTER CLOSED REVERSED OPEN E + -- LATIN SMALL LETTER DOTLESS J WITH STROKE + -- LATIN SMALL LETTER SCRIPT G + -- LATIN SMALL LETTER RAMS HORN + -- LATIN SMALL LETTER TURNED H + -- LATIN SMALL LETTER H WITH HOOK + -- LATIN SMALL LETTER HENG WITH HOOK + -- LATIN SMALL LETTER L WITH MIDDLE TILDE + -- LATIN SMALL LETTER L WITH BELT + -- LATIN SMALL LETTER L WITH RETROFLEX HOOK + -- LATIN SMALL LETTER LEZH + -- LATIN SMALL LETTER TURNED M WITH LONG LEG + -- LATIN SMALL LETTER M WITH HOOK + -- LATIN SMALL LETTER N WITH RETROFLEX HOOK + -- LATIN SMALL LETTER BARRED O + -- LATIN SMALL LETTER CLOSED OMEGA + -- LATIN SMALL LETTER PHI + -- LATIN SMALL LETTER TURNED R + -- LATIN SMALL LETTER TURNED R WITH LONG LEG + -- LATIN SMALL LETTER TURNED R WITH HOOK + -- LATIN SMALL LETTER R WITH LONG LEG + -- LATIN SMALL LETTER R WITH TAIL + -- LATIN SMALL LETTER R WITH FISHHOOK + -- LATIN SMALL LETTER REVERSED R WITH FISHHOOK + -- LATIN SMALL LETTER S WITH HOOK + -- LATIN SMALL LETTER DOTLESS J WITH STROKE AND HOOK + -- LATIN SMALL LETTER SQUAT REVERSED ESH + -- LATIN SMALL LETTER ESH WITH CURL + -- LATIN SMALL LETTER TURNED T + -- LATIN SMALL LETTER U BAR + -- LATIN SMALL LETTER TURNED V + -- LATIN SMALL LETTER TURNED W + -- LATIN SMALL LETTER TURNED Y + -- LATIN SMALL LETTER Z WITH RETROFLEX HOOK + -- LATIN SMALL LETTER Z WITH CURL + -- LATIN SMALL LETTER EZH WITH CURL + -- LATIN SMALL LETTER CLOSED OPEN E + -- LATIN SMALL LETTER J WITH CROSSED-TAIL + -- LATIN SMALL LETTER TURNED K + -- LATIN SMALL LETTER Q WITH HOOK + -- LATIN SMALL LETTER DZ DIGRAPH + -- LATIN SMALL LETTER DEZH DIGRAPH + -- LATIN SMALL LETTER DZ DIGRAPH WITH CURL + -- LATIN SMALL LETTER TS DIGRAPH + -- LATIN SMALL LETTER TESH DIGRAPH + -- LATIN SMALL LETTER TC DIGRAPH WITH CURL + -- LATIN SMALL LETTER FENG DIGRAPH + -- LATIN SMALL LETTER LS DIGRAPH + -- LATIN SMALL LETTER LZ DIGRAPH + -- LATIN SMALL LETTER TURNED H WITH FISHHOOK + -- LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL + -- COMBINING LATIN SMALL LETTER A + -- COMBINING LATIN SMALL LETTER E + -- COMBINING LATIN SMALL LETTER I + -- COMBINING LATIN SMALL LETTER O + -- COMBINING LATIN SMALL LETTER U + -- COMBINING LATIN SMALL LETTER C + -- COMBINING LATIN SMALL LETTER D + -- COMBINING LATIN SMALL LETTER H + -- COMBINING LATIN SMALL LETTER M + -- COMBINING LATIN SMALL LETTER R + -- COMBINING LATIN SMALL LETTER T + -- COMBINING LATIN SMALL LETTER V + -- COMBINING LATIN SMALL LETTER X + -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS + -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS + -- GREEK SMALL LETTER FINAL SIGMA + -- GREEK SMALL LETTER CURLED BETA + -- GREEK SMALL LETTER SCRIPT THETA + -- GREEK SMALL LETTER SCRIPT PHI + -- GREEK SMALL LETTER OMEGA PI + -- GREEK SMALL LETTER ARCHAIC KOPPA + -- GREEK SMALL LETTER SCRIPT KAPPA + -- GREEK SMALL LETTER TAILED RHO + -- GREEK SMALL LETTER LUNATE SIGMA + -- GEORGIAN SMALL LETTER FI + -- LIMBU SMALL LETTER KA + -- LIMBU SMALL LETTER NGA + -- LIMBU SMALL LETTER ANUSVARA + -- LIMBU SMALL LETTER TA + -- LIMBU SMALL LETTER NA + -- LIMBU SMALL LETTER PA + -- LIMBU SMALL LETTER MA + -- LIMBU SMALL LETTER RA + -- LIMBU SMALL LETTER LA + -- LATIN SMALL LETTER TURNED AE + -- LATIN SMALL LETTER TURNED OPEN E + -- LATIN SMALL LETTER TURNED I + -- LATIN SMALL LETTER SIDEWAYS O + -- LATIN SMALL LETTER SIDEWAYS OPEN O + -- LATIN SMALL LETTER SIDEWAYS O WITH STROKE + -- LATIN SMALL LETTER TURNED OE + -- LATIN SMALL LETTER TOP HALF O + -- LATIN SMALL LETTER BOTTOM HALF O + -- LATIN SMALL LETTER SIDEWAYS U + -- LATIN SMALL LETTER SIDEWAYS DIAERESIZED U + -- LATIN SMALL LETTER SIDEWAYS TURNED M + -- LATIN SUBSCRIPT SMALL LETTER I + -- LATIN SUBSCRIPT SMALL LETTER R + -- LATIN SUBSCRIPT SMALL LETTER U + -- LATIN SUBSCRIPT SMALL LETTER V + -- GREEK SUBSCRIPT SMALL LETTER BETA + -- GREEK SUBSCRIPT SMALL LETTER GAMMA + -- GREEK SUBSCRIPT SMALL LETTER RHO + -- GREEK SUBSCRIPT SMALL LETTER PHI + -- GREEK SUBSCRIPT SMALL LETTER CHI + -- LATIN SMALL LETTER UE + -- LATIN SMALL LETTER H WITH LINE BELOW + -- LATIN SMALL LETTER T WITH DIAERESIS + -- LATIN SMALL LETTER W WITH RING ABOVE + -- LATIN SMALL LETTER Y WITH RING ABOVE + -- LATIN SMALL LETTER A WITH RIGHT HALF RING + -- LATIN SMALL LETTER LONG S WITH DOT ABOVE + -- GREEK SMALL LETTER UPSILON WITH PSILI + -- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA + -- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA + -- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI + -- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI + -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER ETA WITH PERISPOMENI + -- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI + -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA + -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA + -- GREEK SMALL LETTER IOTA WITH PERISPOMENI + -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI + -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA + -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA + -- GREEK SMALL LETTER RHO WITH PSILI + -- GREEK SMALL LETTER UPSILON WITH PERISPOMENI + -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI + -- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI + -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI + -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI + -- SUPERSCRIPT LATIN SMALL LETTER I + -- SUPERSCRIPT LATIN SMALL LETTER N + -- TURNED GREEK SMALL LETTER IOTA + -- PARENTHESIZED LATIN SMALL LETTER A + -- PARENTHESIZED LATIN SMALL LETTER B + -- PARENTHESIZED LATIN SMALL LETTER C + -- PARENTHESIZED LATIN SMALL LETTER D + -- PARENTHESIZED LATIN SMALL LETTER E + -- PARENTHESIZED LATIN SMALL LETTER F + -- PARENTHESIZED LATIN SMALL LETTER G + -- PARENTHESIZED LATIN SMALL LETTER H + -- PARENTHESIZED LATIN SMALL LETTER I + -- PARENTHESIZED LATIN SMALL LETTER J + -- PARENTHESIZED LATIN SMALL LETTER K + -- PARENTHESIZED LATIN SMALL LETTER L + -- PARENTHESIZED LATIN SMALL LETTER M + -- PARENTHESIZED LATIN SMALL LETTER N + -- PARENTHESIZED LATIN SMALL LETTER O + -- PARENTHESIZED LATIN SMALL LETTER P + -- PARENTHESIZED LATIN SMALL LETTER Q + -- PARENTHESIZED LATIN SMALL LETTER R + -- PARENTHESIZED LATIN SMALL LETTER S + -- PARENTHESIZED LATIN SMALL LETTER T + -- PARENTHESIZED LATIN SMALL LETTER U + -- PARENTHESIZED LATIN SMALL LETTER V + -- PARENTHESIZED LATIN SMALL LETTER W + -- PARENTHESIZED LATIN SMALL LETTER X + -- PARENTHESIZED LATIN SMALL LETTER Y + -- PARENTHESIZED LATIN SMALL LETTER Z + + -- The following two tables define the mapping to lower case. The first + -- table gives the ranges of upper case letters. The corresponding entry + -- in Lower_Case_Adjust shows the amount to be added to (or subtracted from + -- if the value is negative) the code value to get the corresponding lower + -- case letter. + + -- An entry is in this table if its 10646 has the string CAPITAL LETTER + -- the name, and there is a corresponding entry which has the string + -- SMALL LETTER in its name. + + Upper_Case_Letters : constant UTF_32_Ranges := ( + (16#00041#, 16#0005A#), -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z + (16#000C0#, 16#000D6#), -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS + (16#000D8#, 16#000DE#), -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN + (16#00100#, 16#00100#), -- LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON + (16#00102#, 16#00102#), -- LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE + (16#00104#, 16#00104#), -- LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK + (16#00106#, 16#00106#), -- LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE + (16#00108#, 16#00108#), -- LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX + (16#0010A#, 16#0010A#), -- LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE + (16#0010C#, 16#0010C#), -- LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON + (16#0010E#, 16#0010E#), -- LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON + (16#00110#, 16#00110#), -- LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE + (16#00112#, 16#00112#), -- LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON + (16#00114#, 16#00114#), -- LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE + (16#00116#, 16#00116#), -- LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE + (16#00118#, 16#00118#), -- LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK + (16#0011A#, 16#0011A#), -- LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON + (16#0011C#, 16#0011C#), -- LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX + (16#0011E#, 16#0011E#), -- LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE + (16#00120#, 16#00120#), -- LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE + (16#00122#, 16#00122#), -- LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA + (16#00124#, 16#00124#), -- LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX + (16#00126#, 16#00126#), -- LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE + (16#00128#, 16#00128#), -- LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE + (16#0012A#, 16#0012A#), -- LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON + (16#0012C#, 16#0012C#), -- LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE + (16#0012E#, 16#0012E#), -- LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK + (16#00132#, 16#00132#), -- LATIN CAPITAL LETTER I J .. LATIN CAPITAL LETTER I J + (16#00134#, 16#00134#), -- LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX + (16#00136#, 16#00136#), -- LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA + (16#00139#, 16#00139#), -- LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE + (16#0013B#, 16#0013B#), -- LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA + (16#0013D#, 16#0013D#), -- LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON + (16#0013F#, 16#0013F#), -- LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT + (16#00141#, 16#00141#), -- LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE + (16#00143#, 16#00143#), -- LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE + (16#00145#, 16#00145#), -- LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA + (16#00147#, 16#00147#), -- LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON + (16#0014A#, 16#0014A#), -- LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG + (16#0014C#, 16#0014C#), -- LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON + (16#0014E#, 16#0014E#), -- LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE + (16#00150#, 16#00150#), -- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE + (16#00152#, 16#00152#), -- LATIN CAPITAL LETTER O E .. LATIN CAPITAL LETTER O E + (16#00154#, 16#00154#), -- LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE + (16#00156#, 16#00156#), -- LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA + (16#00158#, 16#00158#), -- LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON + (16#0015A#, 16#0015A#), -- LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE + (16#0015C#, 16#0015C#), -- LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX + (16#0015E#, 16#0015E#), -- LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA + (16#00160#, 16#00160#), -- LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON + (16#00162#, 16#00162#), -- LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA + (16#00164#, 16#00164#), -- LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON + (16#00166#, 16#00166#), -- LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE + (16#00168#, 16#00168#), -- LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE + (16#0016A#, 16#0016A#), -- LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON + (16#0016C#, 16#0016C#), -- LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE + (16#0016E#, 16#0016E#), -- LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE + (16#00170#, 16#00170#), -- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE + (16#00172#, 16#00172#), -- LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK + (16#00174#, 16#00174#), -- LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX + (16#00176#, 16#00176#), -- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX + (16#00178#, 16#00178#), -- LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Y WITH DIAERESIS + (16#00179#, 16#00179#), -- LATIN CAPITAL LETTER Z WITH ACUTE .. LATIN CAPITAL LETTER Z WITH ACUTE + (16#0017B#, 16#0017B#), -- LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE + (16#0017D#, 16#0017D#), -- LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON + (16#00181#, 16#00181#), -- LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH HOOK + (16#00182#, 16#00182#), -- LATIN CAPITAL LETTER B WITH TOPBAR .. LATIN CAPITAL LETTER B WITH TOPBAR + (16#00184#, 16#00184#), -- LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX + (16#00186#, 16#00186#), -- LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER OPEN O + (16#00187#, 16#00187#), -- LATIN CAPITAL LETTER C WITH HOOK .. LATIN CAPITAL LETTER C WITH HOOK + (16#0018A#, 16#0018A#), -- LATIN CAPITAL LETTER D WITH HOOK .. LATIN CAPITAL LETTER D WITH HOOK + (16#0018B#, 16#0018B#), -- LATIN CAPITAL LETTER D WITH TOPBAR .. LATIN CAPITAL LETTER D WITH TOPBAR + (16#0018E#, 16#0018F#), -- LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER SCHWA + (16#00190#, 16#00190#), -- LATIN CAPITAL LETTER OPEN E .. LATIN CAPITAL LETTER OPEN E + (16#00191#, 16#00191#), -- LATIN CAPITAL LETTER F WITH HOOK .. LATIN CAPITAL LETTER F WITH HOOK + (16#00193#, 16#00193#), -- LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER G WITH HOOK + (16#00194#, 16#00194#), -- LATIN CAPITAL LETTER GAMMA .. LATIN CAPITAL LETTER GAMMA + (16#00196#, 16#00196#), -- LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER IOTA + (16#00197#, 16#00197#), -- LATIN CAPITAL LETTER I WITH STROKE .. LATIN CAPITAL LETTER I WITH STROKE + (16#00198#, 16#00198#), -- LATIN CAPITAL LETTER K WITH HOOK .. LATIN CAPITAL LETTER K WITH HOOK + (16#0019C#, 16#0019C#), -- LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER TURNED M + (16#0019D#, 16#0019D#), -- LATIN CAPITAL LETTER N WITH LEFT HOOK .. LATIN CAPITAL LETTER N WITH LEFT HOOK + (16#001A0#, 16#001A0#), -- LATIN CAPITAL LETTER O WITH HORN .. LATIN CAPITAL LETTER O WITH HORN + (16#001A2#, 16#001A2#), -- LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI + (16#001A4#, 16#001A4#), -- LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK + (16#001A7#, 16#001A7#), -- LATIN CAPITAL LETTER TONE TWO .. LATIN CAPITAL LETTER TONE TWO + (16#001A9#, 16#001A9#), -- LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH + (16#001AC#, 16#001AC#), -- LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK + (16#001AE#, 16#001AE#), -- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER T WITH RETROFLEX HOOK + (16#001AF#, 16#001AF#), -- LATIN CAPITAL LETTER U WITH HORN .. LATIN CAPITAL LETTER U WITH HORN + (16#001B1#, 16#001B2#), -- LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER V WITH HOOK + (16#001B3#, 16#001B3#), -- LATIN CAPITAL LETTER Y WITH HOOK .. LATIN CAPITAL LETTER Y WITH HOOK + (16#001B5#, 16#001B5#), -- LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE + (16#001B7#, 16#001B7#), -- LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH + (16#001B8#, 16#001B8#), -- LATIN CAPITAL LETTER EZH REVERSED .. LATIN CAPITAL LETTER EZH REVERSED + (16#001BC#, 16#001BC#), -- LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE + (16#001C4#, 16#001C4#), -- LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON + (16#001C7#, 16#001C7#), -- LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ + (16#001CA#, 16#001CA#), -- LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ + (16#001CD#, 16#001CD#), -- LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON + (16#001CF#, 16#001CF#), -- LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON + (16#001D1#, 16#001D1#), -- LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON + (16#001D3#, 16#001D3#), -- LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON + (16#001D5#, 16#001D5#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON + (16#001D7#, 16#001D7#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE + (16#001D9#, 16#001D9#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON + (16#001DB#, 16#001DB#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE + (16#001DE#, 16#001DE#), -- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON + (16#001E0#, 16#001E0#), -- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON + (16#001E2#, 16#001E2#), -- LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON + (16#001E4#, 16#001E4#), -- LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE + (16#001E6#, 16#001E6#), -- LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON + (16#001E8#, 16#001E8#), -- LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON + (16#001EA#, 16#001EA#), -- LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK + (16#001EC#, 16#001EC#), -- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON + (16#001EE#, 16#001EE#), -- LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON + (16#001F1#, 16#001F1#), -- LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ + (16#001F4#, 16#001F4#), -- LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE + (16#001F8#, 16#001F8#), -- LATIN CAPITAL LETTER N WITH GRAVE .. LATIN CAPITAL LETTER N WITH GRAVE + (16#001FA#, 16#001FA#), -- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE + (16#001FC#, 16#001FC#), -- LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE + (16#001FE#, 16#001FE#), -- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE + (16#00200#, 16#00200#), -- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE + (16#00202#, 16#00202#), -- LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE + (16#00204#, 16#00204#), -- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE + (16#00206#, 16#00206#), -- LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE + (16#00208#, 16#00208#), -- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE + (16#0020A#, 16#0020A#), -- LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE + (16#0020C#, 16#0020C#), -- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE + (16#0020E#, 16#0020E#), -- LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE + (16#00210#, 16#00210#), -- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE + (16#00212#, 16#00212#), -- LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE + (16#00214#, 16#00214#), -- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE + (16#00216#, 16#00216#), -- LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE + (16#00218#, 16#00218#), -- LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW + (16#0021A#, 16#0021A#), -- LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW + (16#0021C#, 16#0021C#), -- LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH + (16#0021E#, 16#0021E#), -- LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON + (16#00220#, 16#00220#), -- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG + (16#00222#, 16#00222#), -- LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU + (16#00224#, 16#00224#), -- LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK + (16#00226#, 16#00226#), -- LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE + (16#00228#, 16#00228#), -- LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA + (16#0022A#, 16#0022A#), -- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON + (16#0022C#, 16#0022C#), -- LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON + (16#0022E#, 16#0022E#), -- LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE + (16#00230#, 16#00230#), -- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON + (16#00232#, 16#00232#), -- LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON + (16#00386#, 16#00386#), -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS + (16#00388#, 16#0038A#), -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS + (16#0038C#, 16#0038C#), -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS + (16#0038E#, 16#0038F#), -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS + (16#00391#, 16#003A1#), -- GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO + (16#003A3#, 16#003AB#), -- GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA + (16#003DA#, 16#003DA#), -- GREEK CAPITAL LETTER STIGMA .. GREEK CAPITAL LETTER STIGMA + (16#003DC#, 16#003DC#), -- GREEK CAPITAL LETTER DIGAMMA .. GREEK CAPITAL LETTER DIGAMMA + (16#003DE#, 16#003DE#), -- GREEK CAPITAL LETTER KOPPA .. GREEK CAPITAL LETTER KOPPA + (16#003E0#, 16#003E0#), -- GREEK CAPITAL LETTER SAMPI .. GREEK CAPITAL LETTER SAMPI + (16#003E2#, 16#003E2#), -- COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI + (16#003E4#, 16#003E4#), -- COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI + (16#003E6#, 16#003E6#), -- COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI + (16#003E8#, 16#003E8#), -- COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI + (16#003EA#, 16#003EA#), -- COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA + (16#003EC#, 16#003EC#), -- COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA + (16#003EE#, 16#003EE#), -- COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI + (16#003F7#, 16#003F7#), -- GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO + (16#003FA#, 16#003FA#), -- GREEK CAPITAL LETTER SAN .. GREEK CAPITAL LETTER SAN + (16#00400#, 16#0040F#), -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER DZHE + (16#00410#, 16#0042F#), -- CYRILLIC CAPITAL LETTER A .. CYRILLIC CAPITAL LETTER YA + (16#00460#, 16#00460#), -- CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA + (16#00462#, 16#00462#), -- CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT + (16#00464#, 16#00464#), -- CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E + (16#00466#, 16#00466#), -- CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS + (16#00468#, 16#00468#), -- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS + (16#0046A#, 16#0046A#), -- CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS + (16#0046C#, 16#0046C#), -- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS + (16#0046E#, 16#0046E#), -- CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI + (16#00470#, 16#00470#), -- CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI + (16#00472#, 16#00472#), -- CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA + (16#00474#, 16#00474#), -- CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA + (16#00476#, 16#00476#), -- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + (16#00478#, 16#00478#), -- CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK + (16#0047A#, 16#0047A#), -- CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA + (16#0047C#, 16#0047C#), -- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO + (16#0047E#, 16#0047E#), -- CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT + (16#00480#, 16#00480#), -- CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA + (16#0048A#, 16#0048A#), -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL + (16#0048C#, 16#0048C#), -- CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN + (16#0048E#, 16#0048E#), -- CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK + (16#00490#, 16#00490#), -- CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN + (16#00492#, 16#00492#), -- CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE + (16#00494#, 16#00494#), -- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK + (16#00496#, 16#00496#), -- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER + (16#00498#, 16#00498#), -- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER + (16#0049A#, 16#0049A#), -- CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER + (16#0049C#, 16#0049C#), -- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE + (16#0049E#, 16#0049E#), -- CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE + (16#004A0#, 16#004A0#), -- CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA + (16#004A2#, 16#004A2#), -- CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER + (16#004A4#, 16#004A4#), -- CYRILLIC CAPITAL LETTER EN GE .. CYRILLIC CAPITAL LETTER EN GE + (16#004A6#, 16#004A6#), -- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK + (16#004A8#, 16#004A8#), -- CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA + (16#004AA#, 16#004AA#), -- CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER + (16#004AC#, 16#004AC#), -- CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER + (16#004AE#, 16#004AE#), -- CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U + (16#004B0#, 16#004B0#), -- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE + (16#004B2#, 16#004B2#), -- CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER + (16#004B4#, 16#004B4#), -- CYRILLIC CAPITAL LETTER TE TSE .. CYRILLIC CAPITAL LETTER TE TSE + (16#004B6#, 16#004B6#), -- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER + (16#004B8#, 16#004B8#), -- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE + (16#004BA#, 16#004BA#), -- CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA + (16#004BC#, 16#004BC#), -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE + (16#004BE#, 16#004BE#), -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER + (16#004C1#, 16#004C1#), -- CYRILLIC CAPITAL LETTER ZHE WITH BREVE .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE + (16#004C3#, 16#004C3#), -- CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK + (16#004C5#, 16#004C5#), -- CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL + (16#004C7#, 16#004C7#), -- CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK + (16#004C9#, 16#004C9#), -- CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL + (16#004CB#, 16#004CB#), -- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE + (16#004CD#, 16#004CD#), -- CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL + (16#004D0#, 16#004D0#), -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE + (16#004D2#, 16#004D2#), -- CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS + (16#004D6#, 16#004D6#), -- CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE + (16#004D8#, 16#004D8#), -- CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA + (16#004DA#, 16#004DA#), -- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS + (16#004DC#, 16#004DC#), -- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS + (16#004DE#, 16#004DE#), -- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS + (16#004E0#, 16#004E0#), -- CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE + (16#004E2#, 16#004E2#), -- CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON + (16#004E4#, 16#004E4#), -- CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS + (16#004E6#, 16#004E6#), -- CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS + (16#004E8#, 16#004E8#), -- CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O + (16#004EA#, 16#004EA#), -- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS + (16#004EC#, 16#004EC#), -- CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS + (16#004EE#, 16#004EE#), -- CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON + (16#004F0#, 16#004F0#), -- CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS + (16#004F2#, 16#004F2#), -- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE + (16#004F4#, 16#004F4#), -- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS + (16#004F8#, 16#004F8#), -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS + (16#00500#, 16#00500#), -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE + (16#00502#, 16#00502#), -- CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE + (16#00504#, 16#00504#), -- CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE + (16#00506#, 16#00506#), -- CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE + (16#00508#, 16#00508#), -- CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE + (16#0050A#, 16#0050A#), -- CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE + (16#0050C#, 16#0050C#), -- CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE + (16#0050E#, 16#0050E#), -- CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE + (16#00531#, 16#00556#), -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH + (16#010A0#, 16#010C5#), -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE + (16#01E00#, 16#01E00#), -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW + (16#01E02#, 16#01E02#), -- LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE + (16#01E04#, 16#01E04#), -- LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW + (16#01E06#, 16#01E06#), -- LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW + (16#01E08#, 16#01E08#), -- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE + (16#01E0A#, 16#01E0A#), -- LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE + (16#01E0C#, 16#01E0C#), -- LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW + (16#01E0E#, 16#01E0E#), -- LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW + (16#01E10#, 16#01E10#), -- LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA + (16#01E12#, 16#01E12#), -- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW + (16#01E14#, 16#01E14#), -- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE + (16#01E16#, 16#01E16#), -- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE + (16#01E18#, 16#01E18#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW + (16#01E1A#, 16#01E1A#), -- LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW + (16#01E1C#, 16#01E1C#), -- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE + (16#01E1E#, 16#01E1E#), -- LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE + (16#01E20#, 16#01E20#), -- LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON + (16#01E22#, 16#01E22#), -- LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE + (16#01E24#, 16#01E24#), -- LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW + (16#01E26#, 16#01E26#), -- LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS + (16#01E28#, 16#01E28#), -- LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA + (16#01E2A#, 16#01E2A#), -- LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW + (16#01E2C#, 16#01E2C#), -- LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW + (16#01E2E#, 16#01E2E#), -- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE + (16#01E30#, 16#01E30#), -- LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE + (16#01E32#, 16#01E32#), -- LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW + (16#01E34#, 16#01E34#), -- LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW + (16#01E36#, 16#01E36#), -- LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW + (16#01E38#, 16#01E38#), -- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON + (16#01E3A#, 16#01E3A#), -- LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW + (16#01E3C#, 16#01E3C#), -- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW + (16#01E3E#, 16#01E3E#), -- LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE + (16#01E40#, 16#01E40#), -- LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE + (16#01E42#, 16#01E42#), -- LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW + (16#01E44#, 16#01E44#), -- LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE + (16#01E46#, 16#01E46#), -- LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW + (16#01E48#, 16#01E48#), -- LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW + (16#01E4A#, 16#01E4A#), -- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW + (16#01E4C#, 16#01E4C#), -- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE + (16#01E4E#, 16#01E4E#), -- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS + (16#01E50#, 16#01E50#), -- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE + (16#01E52#, 16#01E52#), -- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE + (16#01E54#, 16#01E54#), -- LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE + (16#01E56#, 16#01E56#), -- LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE + (16#01E58#, 16#01E58#), -- LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE + (16#01E5A#, 16#01E5A#), -- LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW + (16#01E5C#, 16#01E5C#), -- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON + (16#01E5E#, 16#01E5E#), -- LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW + (16#01E60#, 16#01E60#), -- LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE + (16#01E62#, 16#01E62#), -- LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW + (16#01E64#, 16#01E64#), -- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE + (16#01E66#, 16#01E66#), -- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE + (16#01E68#, 16#01E68#), -- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE + (16#01E6A#, 16#01E6A#), -- LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE + (16#01E6C#, 16#01E6C#), -- LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW + (16#01E6E#, 16#01E6E#), -- LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW + (16#01E70#, 16#01E70#), -- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW + (16#01E72#, 16#01E72#), -- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW + (16#01E74#, 16#01E74#), -- LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW + (16#01E76#, 16#01E76#), -- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW + (16#01E78#, 16#01E78#), -- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE + (16#01E7A#, 16#01E7A#), -- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS + (16#01E7C#, 16#01E7C#), -- LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE + (16#01E7E#, 16#01E7E#), -- LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW + (16#01E80#, 16#01E80#), -- LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE + (16#01E82#, 16#01E82#), -- LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE + (16#01E84#, 16#01E84#), -- LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS + (16#01E86#, 16#01E86#), -- LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE + (16#01E88#, 16#01E88#), -- LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW + (16#01E8A#, 16#01E8A#), -- LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE + (16#01E8C#, 16#01E8C#), -- LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS + (16#01E8E#, 16#01E8E#), -- LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE + (16#01E90#, 16#01E90#), -- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX + (16#01E92#, 16#01E92#), -- LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW + (16#01E94#, 16#01E94#), -- LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW + (16#01EA0#, 16#01EA0#), -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW + (16#01EA2#, 16#01EA2#), -- LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE + (16#01EA4#, 16#01EA4#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE + (16#01EA6#, 16#01EA6#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE + (16#01EA8#, 16#01EA8#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EAA#, 16#01EAA#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE + (16#01EAC#, 16#01EAC#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW + (16#01EAE#, 16#01EAE#), -- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE + (16#01EB0#, 16#01EB0#), -- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE + (16#01EB2#, 16#01EB2#), -- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE + (16#01EB4#, 16#01EB4#), -- LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE + (16#01EB6#, 16#01EB6#), -- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW + (16#01EB8#, 16#01EB8#), -- LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW + (16#01EBA#, 16#01EBA#), -- LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE + (16#01EBC#, 16#01EBC#), -- LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE + (16#01EBE#, 16#01EBE#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE + (16#01EC0#, 16#01EC0#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE + (16#01EC2#, 16#01EC2#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + (16#01EC4#, 16#01EC4#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE + (16#01EC6#, 16#01EC6#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW + (16#01EC8#, 16#01EC8#), -- LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE + (16#01ECA#, 16#01ECA#), -- LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW + (16#01ECC#, 16#01ECC#), -- LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW + (16#01ECE#, 16#01ECE#), -- LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE + (16#01ED0#, 16#01ED0#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE + (16#01ED2#, 16#01ED2#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE + (16#01ED4#, 16#01ED4#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + (16#01ED6#, 16#01ED6#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE + (16#01ED8#, 16#01ED8#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW + (16#01EDA#, 16#01EDA#), -- LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE + (16#01EDC#, 16#01EDC#), -- LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE + (16#01EDE#, 16#01EDE#), -- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE + (16#01EE0#, 16#01EE0#), -- LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE + (16#01EE2#, 16#01EE2#), -- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW + (16#01EE4#, 16#01EE4#), -- LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW + (16#01EE6#, 16#01EE6#), -- LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE + (16#01EE8#, 16#01EE8#), -- LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE + (16#01EEA#, 16#01EEA#), -- LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE + (16#01EEC#, 16#01EEC#), -- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE + (16#01EEE#, 16#01EEE#), -- LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE + (16#01EF0#, 16#01EF0#), -- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW + (16#01EF2#, 16#01EF2#), -- LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE + (16#01EF4#, 16#01EF4#), -- LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW + (16#01EF6#, 16#01EF6#), -- LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE + (16#01EF8#, 16#01EF8#), -- LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE + (16#01F08#, 16#01F0F#), -- GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI + (16#01F18#, 16#01F1D#), -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA + (16#01F28#, 16#01F2F#), -- GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI + (16#01F38#, 16#01F3F#), -- GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI + (16#01F48#, 16#01F4D#), -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA + (16#01F59#, 16#01F59#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA + (16#01F5B#, 16#01F5B#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA + (16#01F5D#, 16#01F5D#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA + (16#01F5F#, 16#01F5F#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI + (16#01F68#, 16#01F6F#), -- GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI + (16#01FB8#, 16#01FB9#), -- GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH MACRON + (16#01FBA#, 16#01FBB#), -- GREEK CAPITAL LETTER ALPHA WITH VARIA .. GREEK CAPITAL LETTER ALPHA WITH OXIA + (16#01FC8#, 16#01FCB#), -- GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA + (16#01FD8#, 16#01FD9#), -- GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH MACRON + (16#01FDA#, 16#01FDB#), -- GREEK CAPITAL LETTER IOTA WITH VARIA .. GREEK CAPITAL LETTER IOTA WITH OXIA + (16#01FE8#, 16#01FE9#), -- GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER UPSILON WITH MACRON + (16#01FEA#, 16#01FEB#), -- GREEK CAPITAL LETTER UPSILON WITH VARIA .. GREEK CAPITAL LETTER UPSILON WITH OXIA + (16#01FEC#, 16#01FEC#), -- GREEK CAPITAL LETTER RHO WITH DASIA .. GREEK CAPITAL LETTER RHO WITH DASIA + (16#01FF8#, 16#01FF9#), -- GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMICRON WITH OXIA + (16#01FFA#, 16#01FFB#), -- GREEK CAPITAL LETTER OMEGA WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA + (16#024B6#, 16#024CF#), -- CIRCLED LATIN CAPITAL LETTER A .. CIRCLED LATIN CAPITAL LETTER Z + (16#0FF21#, 16#0FF3A#), -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z + (16#10400#, 16#10427#), -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW + (16#E0041#, 16#E005A#)); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z + + Upper_Case_Adjust : constant array (Lower_Case_Letters'Range) + of UTF_32'Base := ( + 32, -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z + 32, -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS + 32, -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN + 1, -- LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON + 1, -- LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE + 1, -- LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK + 1, -- LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE + 1, -- LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON + 1, -- LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON + 1, -- LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE + 1, -- LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON + 1, -- LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE + 1, -- LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK + 1, -- LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON + 1, -- LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE + 1, -- LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA + 1, -- LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE + 1, -- LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE + 1, -- LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON + 1, -- LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE + 1, -- LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK + 1, -- LATIN CAPITAL LETTER I J .. LATIN CAPITAL LETTER I J + 1, -- LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA + 1, -- LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE + 1, -- LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA + 1, -- LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON + 1, -- LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT + 1, -- LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE + 1, -- LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE + 1, -- LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA + 1, -- LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON + 1, -- LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG + 1, -- LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON + 1, -- LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE + 1, -- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE + 1, -- LATIN CAPITAL LETTER O E .. LATIN CAPITAL LETTER O E + 1, -- LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE + 1, -- LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA + 1, -- LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON + 1, -- LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE + 1, -- LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA + 1, -- LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON + 1, -- LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA + 1, -- LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON + 1, -- LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE + 1, -- LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE + 1, -- LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON + 1, -- LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE + 1, -- LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE + 1, -- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE + 1, -- LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK + 1, -- LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX + -121, -- LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Y WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER Z WITH ACUTE .. LATIN CAPITAL LETTER Z WITH ACUTE + 1, -- LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON + 210, -- LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH HOOK + 1, -- LATIN CAPITAL LETTER B WITH TOPBAR .. LATIN CAPITAL LETTER B WITH TOPBAR + 1, -- LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX + 206, -- LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER OPEN O + 1, -- LATIN CAPITAL LETTER C WITH HOOK .. LATIN CAPITAL LETTER C WITH HOOK + 205, -- LATIN CAPITAL LETTER D WITH HOOK .. LATIN CAPITAL LETTER D WITH HOOK + 1, -- LATIN CAPITAL LETTER D WITH TOPBAR .. LATIN CAPITAL LETTER D WITH TOPBAR + 202, -- LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER SCHWA + 203, -- LATIN CAPITAL LETTER OPEN E .. LATIN CAPITAL LETTER OPEN E + 1, -- LATIN CAPITAL LETTER F WITH HOOK .. LATIN CAPITAL LETTER F WITH HOOK + 205, -- LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER G WITH HOOK + 207, -- LATIN CAPITAL LETTER GAMMA .. LATIN CAPITAL LETTER GAMMA + 211, -- LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER IOTA + 209, -- LATIN CAPITAL LETTER I WITH STROKE .. LATIN CAPITAL LETTER I WITH STROKE + 1, -- LATIN CAPITAL LETTER K WITH HOOK .. LATIN CAPITAL LETTER K WITH HOOK + 211, -- LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER TURNED M + 213, -- LATIN CAPITAL LETTER N WITH LEFT HOOK .. LATIN CAPITAL LETTER N WITH LEFT HOOK + 1, -- LATIN CAPITAL LETTER O WITH HORN .. LATIN CAPITAL LETTER O WITH HORN + 1, -- LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI + 1, -- LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK + 1, -- LATIN CAPITAL LETTER TONE TWO .. LATIN CAPITAL LETTER TONE TWO + 218, -- LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH + 1, -- LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK + 218, -- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER T WITH RETROFLEX HOOK + 1, -- LATIN CAPITAL LETTER U WITH HORN .. LATIN CAPITAL LETTER U WITH HORN + 217, -- LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER V WITH HOOK + 1, -- LATIN CAPITAL LETTER Y WITH HOOK .. LATIN CAPITAL LETTER Y WITH HOOK + 1, -- LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE + 219, -- LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH + 1, -- LATIN CAPITAL LETTER EZH REVERSED .. LATIN CAPITAL LETTER EZH REVERSED + 1, -- LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE + 2, -- LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON + 2, -- LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ + 2, -- LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ + 1, -- LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON + 1, -- LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON + 1, -- LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON + 1, -- LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE + 1, -- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON + 1, -- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON + 1, -- LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON + 1, -- LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE + 1, -- LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON + 1, -- LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON + 1, -- LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK + 1, -- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON + 1, -- LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON + 2, -- LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ + 1, -- LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE + 1, -- LATIN CAPITAL LETTER N WITH GRAVE .. LATIN CAPITAL LETTER N WITH GRAVE + 1, -- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE + 1, -- LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE + 1, -- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE + 1, -- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE + 1, -- LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE + 1, -- LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW + 1, -- LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW + 1, -- LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH + 1, -- LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON + -130, -- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG + 1, -- LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU + 1, -- LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK + 1, -- LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA + 1, -- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON + 1, -- LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON + 1, -- LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON + 1, -- LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON + 38, -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS + 37, -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS + 64, -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS + 63, -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS + 32, -- GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO + 32, -- GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA + 1, -- GREEK CAPITAL LETTER STIGMA .. GREEK CAPITAL LETTER STIGMA + 1, -- GREEK CAPITAL LETTER DIGAMMA .. GREEK CAPITAL LETTER DIGAMMA + 1, -- GREEK CAPITAL LETTER KOPPA .. GREEK CAPITAL LETTER KOPPA + 1, -- GREEK CAPITAL LETTER SAMPI .. GREEK CAPITAL LETTER SAMPI + 1, -- COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI + 1, -- COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI + 1, -- COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI + 1, -- COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI + 1, -- COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA + 1, -- COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA + 1, -- COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI + 1, -- GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO + 1, -- GREEK CAPITAL LETTER SAN .. GREEK CAPITAL LETTER SAN + 80, -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER DZHE + 32, -- CYRILLIC CAPITAL LETTER A .. CYRILLIC CAPITAL LETTER YA + 1, -- CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA + 1, -- CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT + 1, -- CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E + 1, -- CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS + 1, -- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS + 1, -- CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS + 1, -- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS + 1, -- CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI + 1, -- CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI + 1, -- CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA + 1, -- CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA + 1, -- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT + 1, -- CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK + 1, -- CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA + 1, -- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO + 1, -- CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT + 1, -- CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA + 1, -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN + 1, -- CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK + 1, -- CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN + 1, -- CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE + 1, -- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK + 1, -- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE + 1, -- CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE + 1, -- CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA + 1, -- CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER EN GE .. CYRILLIC CAPITAL LETTER EN GE + 1, -- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA + 1, -- CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U + 1, -- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE + 1, -- CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER TE TSE .. CYRILLIC CAPITAL LETTER TE TSE + 1, -- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE + 1, -- CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER + 1, -- CYRILLIC CAPITAL LETTER ZHE WITH BREVE .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE + 1, -- CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK + 1, -- CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK + 1, -- CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE + 1, -- CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL + 1, -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE + 1, -- CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE + 1, -- CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA + 1, -- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE + 1, -- CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON + 1, -- CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O + 1, -- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON + 1, -- CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE + 1, -- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS + 1, -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE + 1, -- CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE + 1, -- CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE + 1, -- CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE + 1, -- CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE + 1, -- CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE + 1, -- CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE + 1, -- CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE + 48, -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH + 48, -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE + 1, -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW + 1, -- LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE + 1, -- LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA + 1, -- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE + 1, -- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW + 1, -- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE + 1, -- LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON + 1, -- LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA + 1, -- LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW + 1, -- LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW + 1, -- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE + 1, -- LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE + 1, -- LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON + 1, -- LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE + 1, -- LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE + 1, -- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS + 1, -- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE + 1, -- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE + 1, -- LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE + 1, -- LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON + 1, -- LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE + 1, -- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE + 1, -- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE + 1, -- LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW + 1, -- LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW + 1, -- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW + 1, -- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE + 1, -- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS + 1, -- LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE + 1, -- LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE + 1, -- LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE + 1, -- LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS + 1, -- LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE + 1, -- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX + 1, -- LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW + 1, -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE + 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE + 1, -- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW + 1, -- LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE + 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW + 1, -- LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE + 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW + 1, -- LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE + 1, -- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW + 1, -- LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE + 1, -- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW + 1, -- LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE + 1, -- LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW + 1, -- LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE + 1, -- LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE + -8, -- GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA + -8, -- GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI + -8, -- GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH MACRON + -74, -- GREEK CAPITAL LETTER ALPHA WITH VARIA .. GREEK CAPITAL LETTER ALPHA WITH OXIA + -86, -- GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA + -8, -- GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH MACRON + -100, -- GREEK CAPITAL LETTER IOTA WITH VARIA .. GREEK CAPITAL LETTER IOTA WITH OXIA + -8, -- GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER UPSILON WITH MACRON + -112, -- GREEK CAPITAL LETTER UPSILON WITH VARIA .. GREEK CAPITAL LETTER UPSILON WITH OXIA + -7, -- GREEK CAPITAL LETTER RHO WITH DASIA .. GREEK CAPITAL LETTER RHO WITH DASIA + -128, -- GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMICRON WITH OXIA + -126, -- GREEK CAPITAL LETTER OMEGA WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA + 26, -- CIRCLED LATIN CAPITAL LETTER A .. CIRCLED LATIN CAPITAL LETTER Z + 32, -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z + 40, -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW + 32); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z + + pragma Warnings (On); + -- Temporary until pragma Warnings at start can be activated ??? + + -- The following is a list of the 10646 names for CAPITAL LETTER entries + -- that have no matching SMALL LETTER entry and are thus not folded + + -- LATIN CAPITAL LETTER I WITH DOT ABOVE + -- LATIN CAPITAL LETTER AFRICAN D + -- LATIN CAPITAL LETTER O WITH MIDDLE TILDE + -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON + -- LATIN CAPITAL LETTER L WITH SMALL LETTER J + -- LATIN CAPITAL LETTER N WITH SMALL LETTER J + -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z + -- LATIN CAPITAL LETTER HWAIR + -- LATIN CAPITAL LETTER WYNN + -- GREEK CAPITAL LETTER UPSILON HOOK + -- GREEK CAPITAL LETTER UPSILON HOOK TONOS + -- GREEK CAPITAL LETTER UPSILON HOOK DIAERESIS + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI + -- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI + -- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI + + ----------------------- + -- Local Subprograms -- + ----------------------- + + function Range_Search (U : UTF_32; R : UTF_32_Ranges) return Natural; + -- Searches the given ranges (which must be in ascending order by Lo value) + -- and returns the index of the matching range in R if U matches one of the + -- ranges. If U matches none of the ranges, returns zero. + + ------------------ + -- Get_Category -- + ------------------ + + function Get_Category (U : UTF_32) return Category is + begin + -- Deal with FFFE/FFFF cases + + if U mod 16#1_0000# >= 16#FFFE# then + return Fe; + + -- Otherwise search table + + else + declare + Index : constant Integer := Range_Search (U, Unicode_Ranges); + begin + if Index = 0 then + return Cn; + else + return Unicode_Categories (Index); + end if; + end; + end if; + end Get_Category; + + --------------------- + -- Is_UTF_32_Digit -- + --------------------- + + function Is_UTF_32_Digit (U : UTF_32) return Boolean is + begin + return Range_Search (U, UTF_32_Digits) /= 0; + end Is_UTF_32_Digit; + + function Is_UTF_32_Digit (C : Category) return Boolean is + begin + return C = Nd; + end Is_UTF_32_Digit; + + ---------------------- + -- Is_UTF_32_Letter -- + ---------------------- + + function Is_UTF_32_Letter (U : UTF_32) return Boolean is + begin + return Range_Search (U, UTF_32_Letters) /= 0; + end Is_UTF_32_Letter; + + Letter : constant array (Category) of Boolean := + (Lu => True, + Ll => True, + Lt => True, + Lm => True, + Lo => True, + Nl => True, + others => False); + + function Is_UTF_32_Letter (C : Category) return Boolean is + begin + return Letter (C); + end Is_UTF_32_Letter; + + ------------------------------- + -- Is_UTF_32_Line_Terminator -- + ------------------------------- + + function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean is + begin + return U in 10 .. 13 -- Ascii.LF Ascii.VT Ascii.FF Ascii.CR + or else U = 16#00085# -- NEL + or else U = 16#02028# -- LINE SEPARATOR + or else U = 16#02029#; -- PARAGRAPH SEPARATOR + end Is_UTF_32_Line_Terminator; + + -------------------- + -- Is_UTF_32_Mark -- + -------------------- + + function Is_UTF_32_Mark (U : UTF_32) return Boolean is + begin + return Range_Search (U, UTF_32_Marks) /= 0; + end Is_UTF_32_Mark; + + function Is_UTF_32_Mark (C : Category) return Boolean is + begin + return C = Mn or else C = Mc; + end Is_UTF_32_Mark; + + --------------------------- + -- Is_UTF_32_Non_Graphic -- + --------------------------- + + function Is_UTF_32_Non_Graphic (U : UTF_32) return Boolean is + begin + -- We have to deal with FFFE/FFFF specially + + if U mod 16#1_0000# >= 16#FFFE# then + return True; + + -- Otherwise we can use the table + + else + return Range_Search (U, UTF_32_Non_Graphic) /= 0; + end if; + end Is_UTF_32_Non_Graphic; + + Non_Graphic : constant array (Category) of Boolean := + (Cc => True, + Co => True, + Cs => True, + Zl => True, + Zp => True, + Fe => True, + others => False); + + function Is_UTF_32_Non_Graphic (C : Category) return Boolean is + begin + return Non_Graphic (C); + end Is_UTF_32_Non_Graphic; + + --------------------- + -- Is_UTF_32_Other -- + --------------------- + + function Is_UTF_32_Other (U : UTF_32) return Boolean is + begin + return Range_Search (U, UTF_32_Other_Format) /= 0; + end Is_UTF_32_Other; + + function Is_UTF_32_Other (C : Category) return Boolean is + begin + return C = Cf; + end Is_UTF_32_Other; + + --------------------------- + -- Is_UTF_32_Punctuation -- + --------------------------- + + function Is_UTF_32_Punctuation (U : UTF_32) return Boolean is + begin + return Range_Search (U, UTF_32_Punctuation) /= 0; + end Is_UTF_32_Punctuation; + + function Is_UTF_32_Punctuation (C : Category) return Boolean is + begin + return C = Pc; + end Is_UTF_32_Punctuation; + + --------------------- + -- Is_UTF_32_Space -- + --------------------- + + function Is_UTF_32_Space (U : UTF_32) return Boolean is + begin + return Range_Search (U, UTF_32_Spaces) /= 0; + end Is_UTF_32_Space; + + function Is_UTF_32_Space (C : Category) return Boolean is + begin + return C = Zs; + end Is_UTF_32_Space; + + ------------------ + -- Range_Search -- + ------------------ + + function Range_Search (U : UTF_32; R : UTF_32_Ranges) return Natural is + Lo : Integer; + Hi : Integer; + Mid : Integer; + + begin + Lo := R'First; + Hi := R'Last; + + loop + Mid := (Lo + Hi) / 2; + + if U < R (Mid).Lo then + Hi := Mid - 1; + + if Hi < Lo then + return 0; + end if; + + elsif R (Mid).Hi < U then + Lo := Mid + 1; + + if Hi < Lo then + return 0; + end if; + + else + return Mid; + end if; + end loop; + end Range_Search; + + -------------------------- + -- UTF_32_To_Lower_Case -- + -------------------------- + + function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32 is + Index : constant Integer := Range_Search (U, Upper_Case_Letters); + begin + if Index = 0 then + return U; + else + return U + Upper_Case_Adjust (Index); + end if; + end UTF_32_To_Lower_Case; + + -------------------------- + -- UTF_32_To_Upper_Case -- + -------------------------- + + function UTF_32_To_Upper_Case (U : UTF_32) return UTF_32 is + Index : constant Integer := Range_Search (U, Lower_Case_Letters); + begin + if Index = 0 then + return U; + else + return U + Lower_Case_Adjust (Index); + end if; + end UTF_32_To_Upper_Case; + +end System.UTF_32; diff --git a/gcc/ada/libgnat/s-utf_32.ads b/gcc/ada/libgnat/s-utf_32.ads new file mode 100644 index 0000000..bfff8a8 --- /dev/null +++ b/gcc/ada/libgnat/s-utf_32.ads @@ -0,0 +1,212 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . U T F _ 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package is an internal package that provides basic character +-- classification capabilities needed by the compiler for handling full +-- 32-bit wide wide characters. We avoid the use of the actual type +-- Wide_Wide_Character, since we want to use these routines in the compiler +-- itself, and we want to be able to compile the compiler with old versions +-- of GNAT that did not implement Wide_Wide_Character. + +-- System.UTF_32 should not be directly used from an application program, but +-- an equivalent package GNAT.UTF_32 can be used directly and provides exactly +-- the same services. The reason this package is in System is so that it can +-- with'ed by other packages in the Ada and System hierarchies. + +pragma Compiler_Unit_Warning; + +package System.UTF_32 is + pragma Pure; + + type UTF_32 is range 0 .. 16#7FFF_FFFF#; + -- So far, the only defined character codes are in 0 .. 16#01_FFFF# + + -- The following type defines the categories from the unicode definitions. + -- The one addition we make is Fe, which represents the characters FFFE + -- and FFFF in any of the planes. + + type Category is ( + Cc, -- Other, Control + Cf, -- Other, Format + Cn, -- Other, Not Assigned + Co, -- Other, Private Use + Cs, -- Other, Surrogate + Ll, -- Letter, Lowercase + Lm, -- Letter, Modifier + Lo, -- Letter, Other + Lt, -- Letter, Titlecase + Lu, -- Letter, Uppercase + Mc, -- Mark, Spacing Combining + Me, -- Mark, Enclosing + Mn, -- Mark, Nonspacing + Nd, -- Number, Decimal Digit + Nl, -- Number, Letter + No, -- Number, Other + Pc, -- Punctuation, Connector + Pd, -- Punctuation, Dash + Pe, -- Punctuation, Close + Pf, -- Punctuation, Final quote + Pi, -- Punctuation, Initial quote + Po, -- Punctuation, Other + Ps, -- Punctuation, Open + Sc, -- Symbol, Currency + Sk, -- Symbol, Modifier + Sm, -- Symbol, Math + So, -- Symbol, Other + Zl, -- Separator, Line + Zp, -- Separator, Paragraph + Zs, -- Separator, Space + Fe); -- relative position FFFE/FFFF in any plane + + function Get_Category (U : UTF_32) return Category; + -- Given a UTF32 code, returns corresponding Category, or Cn if + -- the code does not have an assigned unicode category. + + -- The following functions perform category tests corresponding to lexical + -- classes defined in the Ada standard. There are two interfaces for each + -- function. The second takes a Category (e.g. returned by Get_Category). + -- The first takes a UTF_32 code. The form taking the UTF_32 code is + -- typically more efficient than calling Get_Category, but if several + -- different tests are to be performed on the same code, it is more + -- efficient to use Get_Category to get the category, then test the + -- resulting category. + + function Is_UTF_32_Letter (U : UTF_32) return Boolean; + function Is_UTF_32_Letter (C : Category) return Boolean; + pragma Inline (Is_UTF_32_Letter); + -- Returns true iff U is a letter that can be used to start an identifier, + -- or if C is one of the corresponding categories, which are the following: + -- Letter, Uppercase (Lu) + -- Letter, Lowercase (Ll) + -- Letter, Titlecase (Lt) + -- Letter, Modifier (Lm) + -- Letter, Other (Lo) + -- Number, Letter (Nl) + + function Is_UTF_32_Digit (U : UTF_32) return Boolean; + function Is_UTF_32_Digit (C : Category) return Boolean; + pragma Inline (Is_UTF_32_Digit); + -- Returns true iff U is a digit that can be used to extend an identifier, + -- or if C is one of the corresponding categories, which are the following: + -- Number, Decimal_Digit (Nd) + + function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean; + pragma Inline (Is_UTF_32_Line_Terminator); + -- Returns true iff U is an allowed line terminator for source programs, + -- if U is in the category Zp (Separator, Paragraph), or Zl (Separator, + -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). + -- There is no category version for this function, since the set of + -- characters does not correspond to a set of Unicode categories. + + function Is_UTF_32_Mark (U : UTF_32) return Boolean; + function Is_UTF_32_Mark (C : Category) return Boolean; + pragma Inline (Is_UTF_32_Mark); + -- Returns true iff U is a mark character which can be used to extend an + -- identifier, or if C is one of the corresponding categories, which are + -- the following: + -- Mark, Non-Spacing (Mn) + -- Mark, Spacing Combining (Mc) + + function Is_UTF_32_Other (U : UTF_32) return Boolean; + function Is_UTF_32_Other (C : Category) return Boolean; + pragma Inline (Is_UTF_32_Other); + -- Returns true iff U is an other format character, which means that it + -- can be used to extend an identifier, but is ignored for the purposes of + -- matching of identifiers, or if C is one of the corresponding categories, + -- which are the following: + -- Other, Format (Cf) + + function Is_UTF_32_Punctuation (U : UTF_32) return Boolean; + function Is_UTF_32_Punctuation (C : Category) return Boolean; + pragma Inline (Is_UTF_32_Punctuation); + -- Returns true iff U is a punctuation character that can be used to + -- separate pieces of an identifier, or if C is one of the corresponding + -- categories, which are the following: + -- Punctuation, Connector (Pc) + + function Is_UTF_32_Space (U : UTF_32) return Boolean; + function Is_UTF_32_Space (C : Category) return Boolean; + pragma Inline (Is_UTF_32_Space); + -- Returns true iff U is considered a space to be ignored, or if C is one + -- of the corresponding categories, which are the following: + -- Separator, Space (Zs) + + function Is_UTF_32_Non_Graphic (U : UTF_32) return Boolean; + function Is_UTF_32_Non_Graphic (C : Category) return Boolean; + pragma Inline (Is_UTF_32_Non_Graphic); + -- Returns true iff U is considered to be a non-graphic character, or if C + -- is one of the corresponding categories, which are the following: + -- Other, Control (Cc) + -- Other, Private Use (Co) + -- Other, Surrogate (Cs) + -- Separator, Line (Zl) + -- Separator, Paragraph (Zp) + -- FFFE or FFFF positions in any plane (Fe) + -- + -- Note that the Ada category format effector is subsumed by the above + -- list of Unicode categories. + -- + -- Note that Other, Unassigned (Cn) is quite deliberately not included + -- in the list of categories above. This means that should any of these + -- code positions be defined in future with graphic characters they will + -- be allowed without a need to change implementations or the standard. + -- + -- Note that Other, Format (Cf) is also quite deliberately not included + -- in the list of categories above. This means that these characters can + -- be included in character and string literals. + + -- The following function is used to fold to upper case, as required by + -- the Ada 2005 standard rules for identifier case folding. Two + -- identifiers are equivalent if they are identical after folding all + -- letters to upper case using this routine. A corresponding routine to + -- fold to lower case is also provided. + + function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32; + pragma Inline (UTF_32_To_Lower_Case); + -- If U represents an upper case letter, returns the corresponding lower + -- case letter, otherwise U is returned unchanged. The folding rule is + -- simply that if the code corresponds to a 10646 entry whose name contains + -- the string CAPITAL LETTER, and there is a corresponding entry whose name + -- is the same but with CAPITAL LETTER replaced by SMALL LETTER, then the + -- code is folded to this SMALL LETTER code. Otherwise the input code is + -- returned unchanged. + + function UTF_32_To_Upper_Case (U : UTF_32) return UTF_32; + pragma Inline (UTF_32_To_Upper_Case); + -- If U represents a lower case letter, returns the corresponding lower + -- case letter, otherwise U is returned unchanged. The folding rule is + -- simply that if the code corresponds to a 10646 entry whose name contains + -- the string SMALL LETTER, and there is a corresponding entry whose name + -- is the same but with SMALL LETTER replaced by CAPITAL LETTER, then the + -- code is folded to this CAPITAL LETTER code. Otherwise the input code is + -- returned unchanged. + +end System.UTF_32; diff --git a/gcc/ada/libgnat/s-valboo.adb b/gcc/ada/libgnat/s-valboo.adb new file mode 100644 index 0000000..05aa904 --- /dev/null +++ b/gcc/ada/libgnat/s-valboo.adb @@ -0,0 +1,59 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ B O O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Val_Util; use System.Val_Util; + +package body System.Val_Bool is + + ------------------- + -- Value_Boolean -- + ------------------- + + function Value_Boolean (Str : String) return Boolean is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + begin + Normalize_String (S, F, L); + + if S (F .. L) = "TRUE" then + return True; + + elsif S (F .. L) = "FALSE" then + return False; + + else + Bad_Value (Str); + end if; + end Value_Boolean; + +end System.Val_Bool; diff --git a/gcc/ada/libgnat/s-valboo.ads b/gcc/ada/libgnat/s-valboo.ads new file mode 100644 index 0000000..16d5199 --- /dev/null +++ b/gcc/ada/libgnat/s-valboo.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ B O O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System.Val_Bool is + pragma Pure; + + function Value_Boolean (Str : String) return Boolean; + -- Computes Boolean'Value (Str) + +end System.Val_Bool; diff --git a/gcc/ada/libgnat/s-valcha.adb b/gcc/ada/libgnat/s-valcha.adb new file mode 100644 index 0000000..1a12a8b --- /dev/null +++ b/gcc/ada/libgnat/s-valcha.adb @@ -0,0 +1,76 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Val_Util; use System.Val_Util; + +package body System.Val_Char is + + --------------------- + -- Value_Character -- + --------------------- + + function Value_Character (Str : String) return Character is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + begin + Normalize_String (S, F, L); + + -- Accept any single character enclosed in quotes + + if L - F = 2 and then S (F) = ''' and then S (L) = ''' then + return Character'Val (Character'Pos (S (F + 1))); + + -- Check control character cases + + else + for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop + if S (F .. L) = Character'Image (C) then + return C; + end if; + end loop; + + for C in Character'Val (16#7F#) .. Character'Val (16#9F#) loop + if S (F .. L) = Character'Image (C) then + return C; + end if; + end loop; + + if S (F .. L) = "SOFT_HYPHEN" then + return Character'Val (16#AD#); + end if; + + Bad_Value (Str); + end if; + end Value_Character; + +end System.Val_Char; diff --git a/gcc/ada/libgnat/s-valcha.ads b/gcc/ada/libgnat/s-valcha.ads new file mode 100644 index 0000000..d7d50b5 --- /dev/null +++ b/gcc/ada/libgnat/s-valcha.ads @@ -0,0 +1,38 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System.Val_Char is + pragma Pure; + + function Value_Character (Str : String) return Character; + -- Computes Character'Value (Str) + +end System.Val_Char; diff --git a/gcc/ada/libgnat/s-valdec.adb b/gcc/ada/libgnat/s-valdec.adb new file mode 100644 index 0000000..63f79d6 --- /dev/null +++ b/gcc/ada/libgnat/s-valdec.adb @@ -0,0 +1,68 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ D E C -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Val_Real; use System.Val_Real; + +package body System.Val_Dec is + + ------------------ + -- Scan_Decimal -- + ------------------ + + -- For decimal types where Size < Integer'Size, it is fine to use + -- the floating-point circuit, since it certainly has sufficient + -- precision for any reasonable hardware, and we just don't support + -- things on junk hardware. + + function Scan_Decimal + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Integer + is + Val : Long_Long_Float; + begin + Val := Scan_Real (Str, Ptr, Max); + return Integer (Val * 10.0 ** Scale); + end Scan_Decimal; + + ------------------- + -- Value_Decimal -- + ------------------- + + -- Again, we use the real circuit for this purpose + + function Value_Decimal (Str : String; Scale : Integer) return Integer is + begin + return Integer (Value_Real (Str) * 10.0 ** Scale); + end Value_Decimal; + +end System.Val_Dec; diff --git a/gcc/ada/libgnat/s-valdec.ads b/gcc/ada/libgnat/s-valdec.ads new file mode 100644 index 0000000..759dc72 --- /dev/null +++ b/gcc/ada/libgnat/s-valdec.ads @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ D E C -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning decimal values where the size +-- of the type is no greater than Standard.Integer'Size, for use in Text_IO. +-- Decimal_IO, and the Value attribute for such decimal types. + +package System.Val_Dec is + pragma Pure; + + function Scan_Decimal + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- real literal according to the syntax described in (RM 3.5(43)). The + -- substring scanned extends no further than Str (Max). There are three + -- cases for the return: + -- + -- If a valid real literal is found after scanning past any initial spaces, + -- then Ptr.all is updated past the last character of the literal (but + -- trailing spaces are not scanned out). The value returned is the value + -- Integer'Integer_Value (decimal-literal-value), using the given Scale + -- to determine this value. + -- + -- If no valid real literal is found, then Ptr.all points either to an + -- initial non-digit character, or to Max + 1 if the field is all spaces + -- and the exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the + -- pointer positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Decimal (Str : String; Scale : Integer) return Integer; + -- Used in computing X'Value (Str) where X is a decimal fixed-point type + -- whose size does not exceed Standard.Integer'Size. Str is the string + -- argument of the attribute. Constraint_Error is raised if the string + -- is malformed or if the value is out of range of Integer (not the + -- range of the fixed-point type, that check must be done by the caller. + -- Otherwise the value returned is the value Integer'Integer_Value + -- (decimal-literal-value), using Scale to determine this value. + +end System.Val_Dec; diff --git a/gcc/ada/libgnat/s-valenu.adb b/gcc/ada/libgnat/s-valenu.adb new file mode 100644 index 0000000..d52b054 --- /dev/null +++ b/gcc/ada/libgnat/s-valenu.adb @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ E N U M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +with System.Val_Util; use System.Val_Util; + +package body System.Val_Enum is + + ------------------------- + -- Value_Enumeration_8 -- + ------------------------- + + function Value_Enumeration_8 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + Normalize_String (S, F, L); + + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = S (F .. L) + then + return J; + end if; + end loop; + + Bad_Value (Str); + end Value_Enumeration_8; + + -------------------------- + -- Value_Enumeration_16 -- + -------------------------- + + function Value_Enumeration_16 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + Normalize_String (S, F, L); + + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = S (F .. L) + then + return J; + end if; + end loop; + + Bad_Value (Str); + end Value_Enumeration_16; + + -------------------------- + -- Value_Enumeration_32 -- + -------------------------- + + function Value_Enumeration_32 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + Normalize_String (S, F, L); + + for J in 0 .. Num loop + if Names + (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1) = S (F .. L) + then + return J; + end if; + end loop; + + Bad_Value (Str); + end Value_Enumeration_32; + +end System.Val_Enum; diff --git a/gcc/ada/libgnat/s-valenu.ads b/gcc/ada/libgnat/s-valenu.ads new file mode 100644 index 0000000..3f88f9c --- /dev/null +++ b/gcc/ada/libgnat/s-valenu.ads @@ -0,0 +1,80 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 compute the Value attribute for enumeration types +-- other than those in packages Standard and System. See unit Exp_Imgv for +-- details of the format of constructed image tables. + +package System.Val_Enum is + pragma Pure; + + function Value_Enumeration_8 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural; + -- Used to compute Enum'Value (Str) where Enum is some enumeration type + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address + -- of an array of type array (0 .. N) of Natural_8, where N is the + -- number of enumeration literals in the type. The Indexes values are + -- the starting subscript of each enumeration literal, indexed by Pos + -- values, with an extra entry at the end containing Names'Length + 1. + -- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)). + -- The reason that Indexes is passed by address is that the actual type + -- is created on the fly by the expander. + -- + -- Str is the argument of the attribute function, and may have leading + -- and trailing spaces, and letters can be upper or lower case or mixed. + -- If the image is found in Names, then the corresponding Pos value is + -- returned. If not, Constraint_Error is raised. + + function Value_Enumeration_16 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural; + -- Identical to Value_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Value_Enumeration_32 + (Names : String; + Indexes : System.Address; + Num : Natural; + Str : String) + return Natural; + -- Identical to Value_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + +end System.Val_Enum; diff --git a/gcc/ada/libgnat/s-valint.adb b/gcc/ada/libgnat/s-valint.adb new file mode 100644 index 0000000..8958661 --- /dev/null +++ b/gcc/ada/libgnat/s-valint.adb @@ -0,0 +1,118 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ I N T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Uns; use System.Val_Uns; +with System.Val_Util; use System.Val_Util; + +package body System.Val_Int is + + ------------------ + -- Scan_Integer -- + ------------------ + + function Scan_Integer + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Integer + is + Uval : Unsigned; + -- Unsigned result + + Minus : Boolean := False; + -- Set to True if minus sign is present, otherwise to False + + Start : Positive; + -- Saves location of first non-blank (not used in this case) + + begin + Scan_Sign (Str, Ptr, Max, Minus, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + Bad_Value (Str); + end if; + + Uval := Scan_Raw_Unsigned (Str, Ptr, Max); + + -- Deal with overflow cases, and also with maximum negative number + + if Uval > Unsigned (Integer'Last) then + if Minus and then Uval = Unsigned (-(Integer'First)) then + return Integer'First; + else + Bad_Value (Str); + end if; + + -- Negative values + + elsif Minus then + return -(Integer (Uval)); + + -- Positive values + + else + return Integer (Uval); + end if; + end Scan_Integer; + + ------------------- + -- Value_Integer -- + ------------------- + + function Value_Integer (Str : String) return Integer is + begin + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Integer (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Integer; + P : aliased Integer := Str'First; + begin + V := Scan_Integer (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Integer; + +end System.Val_Int; diff --git a/gcc/ada/libgnat/s-valint.ads b/gcc/ada/libgnat/s-valint.ads new file mode 100644 index 0000000..4f651be --- /dev/null +++ b/gcc/ada/libgnat/s-valint.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ I N T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning signed Integer values for use +-- in Text_IO.Integer_IO, and the Value attribute. + +package System.Val_Int is + pragma Pure; + + function Scan_Integer + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). There are three cases for the + -- return: + -- + -- If a valid integer is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the integer (but trailing + -- spaces are not scanned out). + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Integer (Str : String) return Integer; + -- Used in computing X'Value (Str) where X is a signed integer type whose + -- base range does not exceed the base range of Integer. Str is the string + -- argument of the attribute. Constraint_Error is raised if the string is + -- malformed, or if the value is out of range. + +end System.Val_Int; diff --git a/gcc/ada/libgnat/s-vallld.adb b/gcc/ada/libgnat/s-vallld.adb new file mode 100644 index 0000000..b1cf678 --- /dev/null +++ b/gcc/ada/libgnat/s-vallld.adb @@ -0,0 +1,70 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L D -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Val_Real; use System.Val_Real; + +package body System.Val_LLD is + + ---------------------------- + -- Scan_Long_Long_Decimal -- + ---------------------------- + + -- We use the floating-point circuit for now, this will be OK on a PC, + -- but definitely does NOT have the required precision if the longest + -- float type is IEEE double. This must be fixed in the future ??? + + function Scan_Long_Long_Decimal + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Long_Long_Integer + is + Val : Long_Long_Float; + begin + Val := Scan_Real (Str, Ptr, Max); + return Long_Long_Integer (Val * 10.0 ** Scale); + end Scan_Long_Long_Decimal; + + ----------------------------- + -- Value_Long_Long_Decimal -- + ----------------------------- + + -- Again we cheat and use floating-point ??? + + function Value_Long_Long_Decimal + (Str : String; + Scale : Integer) return Long_Long_Integer + is + begin + return Long_Long_Integer (Value_Real (Str) * 10.0 ** Scale); + end Value_Long_Long_Decimal; + +end System.Val_LLD; diff --git a/gcc/ada/libgnat/s-vallld.ads b/gcc/ada/libgnat/s-vallld.ads new file mode 100644 index 0000000..d2cde62 --- /dev/null +++ b/gcc/ada/libgnat/s-vallld.ads @@ -0,0 +1,81 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L D -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning decimal values where the size +-- of the type is greater than Standard.Integer'Size, for use in Text_IO. +-- Decimal_IO, and the Value attribute for such decimal types. + +package System.Val_LLD is + pragma Pure; + + function Scan_Long_Long_Decimal + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Scale : Integer) return Long_Long_Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- real literal according to the syntax described in (RM 3.5(43)). The + -- substring scanned extends no further than Str (Max). There are three + -- cases for the return: + -- + -- If a valid real literal is found after scanning past any initial spaces, + -- then Ptr.all is updated past the last character of the literal (but + -- trailing spaces are not scanned out). The value returned is the value + -- Long_Long_Integer'Integer_Value (decimal-literal-value), using the given + -- Scale to determine this value. + -- + -- If no valid real literal is found, then Ptr.all points either to an + -- initial non-digit character, or to Max + 1 if the field is all spaces + -- and the exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the + -- pointer positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Long_Long_Decimal + (Str : String; + Scale : Integer) return Long_Long_Integer; + -- Used in computing X'Value (Str) where X is a decimal types whose size + -- exceeds Standard.Integer'Size. Str is the string argument of the + -- attribute. Constraint_Error is raised if the string is malformed + -- or if the value is out of range, otherwise the value returned is the + -- value Long_Long_Integer'Integer_Value (decimal-literal-value), using + -- the given Scale to determine this value. + +end System.Val_LLD; diff --git a/gcc/ada/libgnat/s-vallli.adb b/gcc/ada/libgnat/s-vallli.adb new file mode 100644 index 0000000..0d1dfd5 --- /dev/null +++ b/gcc/ada/libgnat/s-vallli.adb @@ -0,0 +1,120 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_LLU; use System.Val_LLU; +with System.Val_Util; use System.Val_Util; + +package body System.Val_LLI is + + ---------------------------- + -- Scan_Long_Long_Integer -- + ---------------------------- + + function Scan_Long_Long_Integer + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Integer + is + Uval : Long_Long_Unsigned; + -- Unsigned result + + Minus : Boolean := False; + -- Set to True if minus sign is present, otherwise to False + + Start : Positive; + -- Saves location of first non-blank + + begin + Scan_Sign (Str, Ptr, Max, Minus, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + Bad_Value (Str); + end if; + + Uval := Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); + + -- Deal with overflow cases, and also with maximum negative number + + if Uval > Long_Long_Unsigned (Long_Long_Integer'Last) then + if Minus + and then Uval = Long_Long_Unsigned (-(Long_Long_Integer'First)) + then + return Long_Long_Integer'First; + else + Bad_Value (Str); + end if; + + -- Negative values + + elsif Minus then + return -(Long_Long_Integer (Uval)); + + -- Positive values + + else + return Long_Long_Integer (Uval); + end if; + end Scan_Long_Long_Integer; + + ----------------------------- + -- Value_Long_Long_Integer -- + ----------------------------- + + function Value_Long_Long_Integer (Str : String) return Long_Long_Integer is + begin + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Long_Long_Integer (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Long_Long_Integer; + P : aliased Integer := Str'First; + begin + V := Scan_Long_Long_Integer (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Long_Long_Integer; + +end System.Val_LLI; diff --git a/gcc/ada/libgnat/s-vallli.ads b/gcc/ada/libgnat/s-vallli.ads new file mode 100644 index 0000000..c7333b5 --- /dev/null +++ b/gcc/ada/libgnat/s-vallli.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning signed Long_Long_Integer +-- values for use in Text_IO.Integer_IO, and the Value attribute. + +package System.Val_LLI is + pragma Pure; + + function Scan_Long_Long_Integer + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Integer; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). There are three cases for the + -- return: + -- + -- If a valid integer is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the integer (but trailing + -- spaces are not scanned out). + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + + function Value_Long_Long_Integer (Str : String) return Long_Long_Integer; + -- Used in computing X'Value (Str) where X is a signed integer type whose + -- base range exceeds the base range of Integer. Str is the string argument + -- of the attribute. Constraint_Error is raised if the string is malformed, + -- or if the value is out of range. + +end System.Val_LLI; diff --git a/gcc/ada/libgnat/s-valllu.adb b/gcc/ada/libgnat/s-valllu.adb new file mode 100644 index 0000000..3b14e6a --- /dev/null +++ b/gcc/ada/libgnat/s-valllu.adb @@ -0,0 +1,330 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; + +package body System.Val_LLU is + + --------------------------------- + -- Scan_Raw_Long_Long_Unsigned -- + --------------------------------- + + function Scan_Raw_Long_Long_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Unsigned + is + P : Integer; + -- Local copy of the pointer + + Uval : Long_Long_Unsigned; + -- Accumulated unsigned integer result + + Expon : Integer; + -- Exponent value + + Overflow : Boolean := False; + -- Set True if overflow is detected at any point + + Base_Char : Character; + -- Base character (# or :) in based case + + Base : Long_Long_Unsigned := 10; + -- Base value (reset in based case) + + Digit : Long_Long_Unsigned; + -- Digit value + + begin + -- We do not tolerate strings with Str'Last = Positive'Last + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + P := Ptr.all; + Uval := Character'Pos (Str (P)) - Character'Pos ('0'); + P := P + 1; + + -- Scan out digits of what is either the number or the base. + -- In either case, we are definitely scanning out in base 10. + + declare + Umax : constant := (Long_Long_Unsigned'Last - 9) / 10; + -- Max value which cannot overflow on accumulating next digit + + Umax10 : constant := Long_Long_Unsigned'Last / 10; + -- Numbers bigger than Umax10 overflow if multiplied by 10 + + begin + -- Loop through decimal digits + loop + exit when P > Max; + + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + -- Non-digit encountered + + if Digit > 9 then + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit; + end if; + + -- Accumulate result, checking for overflow + + else + if Uval <= Umax then + Uval := 10 * Uval + Digit; + + elsif Uval > Umax10 then + Overflow := True; + + else + Uval := 10 * Uval + Digit; + + if Uval < Umax10 then + Overflow := True; + end if; + end if; + + P := P + 1; + end if; + end loop; + end; + + Ptr.all := P; + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + if P < Max and then (Str (P) = '#' or else Str (P) = ':') then + Base_Char := Str (P); + P := P + 1; + Base := Uval; + Uval := 0; + + -- Check base value. Overflow is set True if we find a bad base, or + -- a digit that is out of range of the base. That way, we scan out + -- the numeral that is still syntactically correct, though illegal. + -- We use a safe base of 16 for this scan, to avoid zero divide. + + if Base not in 2 .. 16 then + Overflow := True; + Base := 16; + end if; + + -- Scan out based integer + + declare + Umax : constant Long_Long_Unsigned := + (Long_Long_Unsigned'Last - Base + 1) / Base; + -- Max value which cannot overflow on accumulating next digit + + UmaxB : constant Long_Long_Unsigned := + Long_Long_Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + -- Loop to scan out based integer value + + loop + -- We require a digit at this stage + + if Str (P) in '0' .. '9' then + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + elsif Str (P) in 'A' .. 'F' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('A') - 10); + + elsif Str (P) in 'a' .. 'f' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('a') - 10); + + -- If we don't have a digit, then this is not a based number + -- after all, so we use the value we scanned out as the base + -- (now in Base), and the pointer to the base character was + -- already stored in Ptr.all. + + else + Uval := Base; + exit; + end if; + + -- If digit is too large, just signal overflow and continue. + -- The idea here is to keep scanning as long as the input is + -- syntactically valid, even if we have detected overflow + + if Digit >= Base then + Overflow := True; + + -- Here we accumulate the value, checking overflow + + elsif Uval <= Umax then + Uval := Base * Uval + Digit; + + elsif Uval > UmaxB then + Overflow := True; + + else + Uval := Base * Uval + Digit; + + if Uval < UmaxB then + Overflow := True; + end if; + end if; + + -- If at end of string with no base char, not a based number + -- but we signal Constraint_Error and set the pointer past + -- the end of the field, since this is what the ACVC tests + -- seem to require, see CE3704N, line 204. + + P := P + 1; + + if P > Max then + Ptr.all := P; + Bad_Value (Str); + end if; + + -- If terminating base character, we are done with loop + + if Str (P) = Base_Char then + Ptr.all := P + 1; + exit; + + -- Deal with underscore + + elsif Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, True); + end if; + + end loop; + end; + end if; + + -- Come here with scanned unsigned value in Uval. The only remaining + -- required step is to deal with exponent if one is present. + + Expon := Scan_Exponent (Str, Ptr, Max); + + if Expon /= 0 and then Uval /= 0 then + + -- For non-zero value, scale by exponent value. No need to do this + -- efficiently, since use of exponent in integer literals is rare, + -- and in any case the exponent cannot be very large. + + declare + UmaxB : constant Long_Long_Unsigned := + Long_Long_Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + for J in 1 .. Expon loop + if Uval > UmaxB then + Overflow := True; + exit; + end if; + + Uval := Uval * Base; + end loop; + end; + end if; + + -- Return result, dealing with sign and overflow + + if Overflow then + Bad_Value (Str); + else + return Uval; + end if; + end Scan_Raw_Long_Long_Unsigned; + + ----------------------------- + -- Scan_Long_Long_Unsigned -- + ----------------------------- + + function Scan_Long_Long_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Unsigned + is + Start : Positive; + -- Save location of first non-blank character + + begin + Scan_Plus_Sign (Str, Ptr, Max, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + raise Constraint_Error; + end if; + + return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); + end Scan_Long_Long_Unsigned; + + ------------------------------ + -- Value_Long_Long_Unsigned -- + ------------------------------ + + function Value_Long_Long_Unsigned + (Str : String) return Long_Long_Unsigned + is + begin + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Long_Long_Unsigned (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Long_Long_Unsigned; + P : aliased Integer := Str'First; + begin + V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Long_Long_Unsigned; + +end System.Val_LLU; diff --git a/gcc/ada/libgnat/s-valllu.ads b/gcc/ada/libgnat/s-valllu.ads new file mode 100644 index 0000000..127cb06 --- /dev/null +++ b/gcc/ada/libgnat/s-valllu.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning modular Long_Long_Unsigned +-- values for use in Text_IO.Modular_IO, and the Value attribute. + +with System.Unsigned_Types; + +package System.Val_LLU is + pragma Pure; + + function Scan_Raw_Long_Long_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). Note: this does not scan + -- leading or trailing blanks, nor leading sign. + -- + -- There are three cases for the return: + -- + -- If a valid integer is found, then Ptr.all is updated past the last + -- character of the integer. + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_IO.Get. Note that the rules as stated in the RM would + -- seem to imply that for a case like: + -- + -- 8#12345670009# + -- + -- the pointer should be left at the first # having scanned out the longest + -- valid integer literal (8), but in fact in this case the pointer points + -- past the final # and Constraint_Error is raised. This is the behavior + -- expected for Text_IO and enforced by the ACATS tests. + -- + -- If a based literal is malformed in that a character other than a valid + -- hexadecimal digit is encountered during scanning out the digits after + -- the # (this includes the case of using the wrong terminator, : instead + -- of # or vice versa) there are two cases. If all the digits before the + -- non-digit are in range of the base, as in + -- + -- 8#100x00# + -- 8#100: + -- + -- then in this case, the "base" value before the initial # is returned as + -- the result, and the pointer points to the initial # character on return. + -- + -- If an out of range digit has been detected before the invalid character, + -- as in: + -- + -- 8#900x00# + -- 8#900: + -- + -- then the pointer is also left at the initial # character, but constraint + -- error is raised reflecting the encounter of an out of range digit. + -- + -- Finally if we have an unterminated fixed-point constant where the final + -- # or : character is missing, Constraint_Error is raised and the pointer + -- is left pointing past the last digit, as in: + -- + -- 8#22 + -- + -- This string results in a Constraint_Error with the pointer pointing + -- past the second 2. + -- + -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + -- + -- Note: this routine should not be called with Str'Last = Positive'Last. + -- If this occurs Program_Error is raised with a message noting that this + -- case is not supported. Most such cases are eliminated by the caller. + + function Scan_Long_Long_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; + -- Same as Scan_Raw_Long_Long_Unsigned, except scans optional leading + -- blanks, and an optional leading plus sign. + -- + -- Note: if a minus sign is present, Constraint_Error will be raised. + -- Note: trailing blanks are not scanned. + + function Value_Long_Long_Unsigned + (Str : String) return System.Unsigned_Types.Long_Long_Unsigned; + -- Used in computing X'Value (Str) where X is a modular integer type whose + -- modulus exceeds the range of System.Unsigned_Types.Unsigned. Str is the + -- string argument of the attribute. Constraint_Error is raised if the + -- string is malformed, or if the value is out of range. + +end System.Val_LLU; diff --git a/gcc/ada/libgnat/s-valrea.adb b/gcc/ada/libgnat/s-valrea.adb new file mode 100644 index 0000000..c5c905f --- /dev/null +++ b/gcc/ada/libgnat/s-valrea.adb @@ -0,0 +1,415 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ R E A L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Powten_Table; use System.Powten_Table; +with System.Val_Util; use System.Val_Util; +with System.Float_Control; + +package body System.Val_Real is + + --------------- + -- Scan_Real -- + --------------- + + function Scan_Real + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Float + is + P : Integer; + -- Local copy of string pointer + + Base : Long_Long_Float; + -- Base value + + Uval : Long_Long_Float; + -- Accumulated float result + + subtype Digs is Character range '0' .. '9'; + -- Used to check for decimal digit + + Scale : Integer := 0; + -- Power of Base to multiply result by + + Start : Positive; + -- Position of starting non-blank character + + Minus : Boolean; + -- Set to True if minus sign is present, otherwise to False + + Bad_Base : Boolean := False; + -- Set True if Base out of range or if out of range digit + + After_Point : Natural := 0; + -- Set to 1 after the point + + Num_Saved_Zeroes : Natural := 0; + -- This counts zeroes after the decimal point. A non-zero value means + -- that this number of previously scanned digits are zero. If the end + -- of the number is reached, these zeroes are simply discarded, which + -- ensures that trailing zeroes after the point never affect the value + -- (which might otherwise happen as a result of rounding). With this + -- processing in place, we can ensure that, for example, we get the + -- same exact result from 1.0E+49 and 1.0000000E+49. This is not + -- necessarily required in a case like this where the result is not + -- a machine number, but it is certainly a desirable behavior. + + procedure Scanf; + -- Scans integer literal value starting at current character position. + -- For each digit encountered, Uval is multiplied by 10.0, and the new + -- digit value is incremented. In addition Scale is decremented for each + -- digit encountered if we are after the point (After_Point = 1). The + -- longest possible syntactically valid numeral is scanned out, and on + -- return P points past the last character. On entry, the current + -- character is known to be a digit, so a numeral is definitely present. + + ----------- + -- Scanf -- + ----------- + + procedure Scanf is + Digit : Natural; + + begin + loop + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + P := P + 1; + + -- Save up trailing zeroes after the decimal point + + if Digit = 0 and then After_Point = 1 then + Num_Saved_Zeroes := Num_Saved_Zeroes + 1; + + -- Here for a non-zero digit + + else + -- First deal with any previously saved zeroes + + if Num_Saved_Zeroes /= 0 then + while Num_Saved_Zeroes > Maxpow loop + Uval := Uval * Powten (Maxpow); + Num_Saved_Zeroes := Num_Saved_Zeroes - Maxpow; + Scale := Scale - Maxpow; + end loop; + + Uval := Uval * Powten (Num_Saved_Zeroes); + Scale := Scale - Num_Saved_Zeroes; + + Num_Saved_Zeroes := 0; + end if; + + -- Accumulate new digit + + Uval := Uval * 10.0 + Long_Long_Float (Digit); + Scale := Scale - After_Point; + end if; + + -- Done if end of input field + + if P > Max then + return; + + -- Check next character + + elsif Str (P) not in Digs then + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + return; + end if; + end if; + end loop; + end Scanf; + + -- Start of processing for System.Scan_Real + + begin + -- We do not tolerate strings with Str'Last = Positive'Last + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + -- We call the floating-point processor reset routine so that we can + -- be sure the floating-point processor is properly set for conversion + -- calls. This is notably need on Windows, where calls to the operating + -- system randomly reset the processor into 64-bit mode. + + System.Float_Control.Reset; + + Scan_Sign (Str, Ptr, Max, Minus, Start); + P := Ptr.all; + Ptr.all := Start; + + -- If digit, scan numeral before point + + if Str (P) in Digs then + Uval := 0.0; + Scanf; + + -- Initial point, allowed only if followed by digit (RM 3.5(47)) + + elsif Str (P) = '.' + and then P < Max + and then Str (P + 1) in Digs + then + Uval := 0.0; + + -- Any other initial character is an error + + else + Bad_Value (Str); + end if; + + -- Deal with based case. We reognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + if P < Max and then (Str (P) = '#' or else Str (P) = ':') then + declare + Base_Char : constant Character := Str (P); + Digit : Natural; + Fdigit : Long_Long_Float; + + begin + -- Set bad base if out of range, and use safe base of 16.0, + -- to guard against division by zero in the loop below. + + if Uval < 2.0 or else Uval > 16.0 then + Bad_Base := True; + Uval := 16.0; + end if; + + Base := Uval; + Uval := 0.0; + P := P + 1; + + -- Special check to allow initial point (RM 3.5(49)) + + if Str (P) = '.' then + After_Point := 1; + P := P + 1; + end if; + + -- Loop to scan digits of based number. On entry to the loop we + -- must have a valid digit. If we don't, then we have an illegal + -- floating-point value, and we raise Constraint_Error, note that + -- Ptr at this stage was reset to the proper (Start) value. + + loop + if P > Max then + Bad_Value (Str); + + elsif Str (P) in Digs then + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + elsif Str (P) in 'A' .. 'F' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('A') - 10); + + elsif Str (P) in 'a' .. 'f' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('a') - 10); + + else + Bad_Value (Str); + end if; + + -- Save up trailing zeroes after the decimal point + + if Digit = 0 and then After_Point = 1 then + Num_Saved_Zeroes := Num_Saved_Zeroes + 1; + + -- Here for a non-zero digit + + else + -- First deal with any previously saved zeroes + + if Num_Saved_Zeroes /= 0 then + Uval := Uval * Base ** Num_Saved_Zeroes; + Scale := Scale - Num_Saved_Zeroes; + Num_Saved_Zeroes := 0; + end if; + + -- Now accumulate the new digit + + Fdigit := Long_Long_Float (Digit); + + if Fdigit >= Base then + Bad_Base := True; + else + Scale := Scale - After_Point; + Uval := Uval * Base + Fdigit; + end if; + end if; + + P := P + 1; + + if P > Max then + Bad_Value (Str); + + elsif Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, True); + + else + -- Skip past period after digit. Note that the processing + -- here will permit either a digit after the period, or the + -- terminating base character, as allowed in (RM 3.5(48)) + + if Str (P) = '.' and then After_Point = 0 then + P := P + 1; + After_Point := 1; + + if P > Max then + Bad_Value (Str); + end if; + end if; + + exit when Str (P) = Base_Char; + end if; + end loop; + + -- Based number successfully scanned out (point was found) + + Ptr.all := P + 1; + end; + + -- Non-based case, check for being at decimal point now. Note that + -- in Ada 95, we do not insist on a decimal point being present + + else + Base := 10.0; + After_Point := 1; + + if P <= Max and then Str (P) = '.' then + P := P + 1; + + -- Scan digits after point if any are present (RM 3.5(46)) + + if P <= Max and then Str (P) in Digs then + Scanf; + end if; + end if; + + Ptr.all := P; + end if; + + -- At this point, we have Uval containing the digits of the value as + -- an integer, and Scale indicates the negative of the number of digits + -- after the point. Base contains the base value (an integral value in + -- the range 2.0 .. 16.0). Test for exponent, must be at least one + -- character after the E for the exponent to be valid. + + Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True); + + -- At this point the exponent has been scanned if one is present and + -- Scale is adjusted to include the exponent value. Uval contains the + -- the integral value which is to be multiplied by Base ** Scale. + + -- If base is not 10, use exponentiation for scaling + + if Base /= 10.0 then + Uval := Uval * Base ** Scale; + + -- For base 10, use power of ten table, repeatedly if necessary + + elsif Scale > 0 then + while Scale > Maxpow loop + Uval := Uval * Powten (Maxpow); + Scale := Scale - Maxpow; + end loop; + + -- Note that we still know that Scale > 0, since the loop + -- above leaves Scale in the range 1 .. Maxpow. + + Uval := Uval * Powten (Scale); + + elsif Scale < 0 then + while (-Scale) > Maxpow loop + Uval := Uval / Powten (Maxpow); + Scale := Scale + Maxpow; + end loop; + + -- Note that we still know that Scale < 0, since the loop + -- above leaves Scale in the range -Maxpow .. -1. + + Uval := Uval / Powten (-Scale); + end if; + + -- Here is where we check for a bad based number + + if Bad_Base then + Bad_Value (Str); + + -- If OK, then deal with initial minus sign, note that this processing + -- is done even if Uval is zero, so that -0.0 is correctly interpreted. + + else + if Minus then + return -Uval; + else + return Uval; + end if; + end if; + end Scan_Real; + + ---------------- + -- Value_Real -- + ---------------- + + function Value_Real (Str : String) return Long_Long_Float is + begin + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Real (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Long_Long_Float; + P : aliased Integer := Str'First; + begin + V := Scan_Real (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Real; + +end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valrea.ads b/gcc/ada/libgnat/s-valrea.ads new file mode 100644 index 0000000..2e2bb64 --- /dev/null +++ b/gcc/ada/libgnat/s-valrea.ads @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ R E A L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package System.Val_Real is + pragma Pure; + + function Scan_Real + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Long_Long_Float; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- real literal according to the syntax described in (RM 3.5(43)). The + -- substring scanned extends no further than Str (Max). There are three + -- cases for the return: + -- + -- If a valid real is found after scanning past any initial spaces, then + -- Ptr.all is updated past the last character of the real (but trailing + -- spaces are not scanned out). + -- + -- If no valid real is found, then Ptr.all points either to an initial + -- non-blank character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid real is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the real literal, + -- and Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the + -- pointer positioned in Text_Io.Get + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + -- + -- Note: this routine should not be called with Str'Last = Positive'Last. + -- If this occurs Program_Error is raised with a message noting that this + -- case is not supported. Most such cases are eliminated by the caller. + + function Value_Real (Str : String) return Long_Long_Float; + -- Used in computing X'Value (Str) where X is a floating-point type or an + -- ordinary fixed-point type. Str is the string argument of the attribute. + -- Constraint_Error is raised if the string is malformed, or if the value + -- out of range of Long_Long_Float. + +end System.Val_Real; diff --git a/gcc/ada/libgnat/s-valuns.adb b/gcc/ada/libgnat/s-valuns.adb new file mode 100644 index 0000000..b0d3790 --- /dev/null +++ b/gcc/ada/libgnat/s-valuns.adb @@ -0,0 +1,325 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; +with System.Val_Util; use System.Val_Util; + +package body System.Val_Uns is + + ----------------------- + -- Scan_Raw_Unsigned -- + ----------------------- + + function Scan_Raw_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Unsigned + is + P : Integer; + -- Local copy of the pointer + + Uval : Unsigned; + -- Accumulated unsigned integer result + + Expon : Integer; + -- Exponent value + + Overflow : Boolean := False; + -- Set True if overflow is detected at any point + + Base_Char : Character; + -- Base character (# or :) in based case + + Base : Unsigned := 10; + -- Base value (reset in based case) + + Digit : Unsigned; + -- Digit value + + begin + -- We do not tolerate strings with Str'Last = Positive'Last + + if Str'Last = Positive'Last then + raise Program_Error with + "string upper bound is Positive'Last, not supported"; + end if; + + P := Ptr.all; + Uval := Character'Pos (Str (P)) - Character'Pos ('0'); + P := P + 1; + + -- Scan out digits of what is either the number or the base. + -- In either case, we are definitely scanning out in base 10. + + declare + Umax : constant := (Unsigned'Last - 9) / 10; + -- Max value which cannot overflow on accumulating next digit + + Umax10 : constant := Unsigned'Last / 10; + -- Numbers bigger than Umax10 overflow if multiplied by 10 + + begin + -- Loop through decimal digits + loop + exit when P > Max; + + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + -- Non-digit encountered + + if Digit > 9 then + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit; + end if; + + -- Accumulate result, checking for overflow + + else + if Uval <= Umax then + Uval := 10 * Uval + Digit; + + elsif Uval > Umax10 then + Overflow := True; + + else + Uval := 10 * Uval + Digit; + + if Uval < Umax10 then + Overflow := True; + end if; + end if; + + P := P + 1; + end if; + end loop; + end; + + Ptr.all := P; + + -- Deal with based case. We recognize either the standard '#' or the + -- allowed alternative replacement ':' (see RM J.2(3)). + + if P < Max and then (Str (P) = '#' or else Str (P) = ':') then + Base_Char := Str (P); + P := P + 1; + Base := Uval; + Uval := 0; + + -- Check base value. Overflow is set True if we find a bad base, or + -- a digit that is out of range of the base. That way, we scan out + -- the numeral that is still syntactically correct, though illegal. + -- We use a safe base of 16 for this scan, to avoid zero divide. + + if Base not in 2 .. 16 then + Overflow := True; + Base := 16; + end if; + + -- Scan out based integer + + declare + Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base; + -- Max value which cannot overflow on accumulating next digit + + UmaxB : constant Unsigned := Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + -- Loop to scan out based integer value + + loop + -- We require a digit at this stage + + if Str (P) in '0' .. '9' then + Digit := Character'Pos (Str (P)) - Character'Pos ('0'); + + elsif Str (P) in 'A' .. 'F' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('A') - 10); + + elsif Str (P) in 'a' .. 'f' then + Digit := + Character'Pos (Str (P)) - (Character'Pos ('a') - 10); + + -- If we don't have a digit, then this is not a based number + -- after all, so we use the value we scanned out as the base + -- (now in Base), and the pointer to the base character was + -- already stored in Ptr.all. + + else + Uval := Base; + exit; + end if; + + -- If digit is too large, just signal overflow and continue. + -- The idea here is to keep scanning as long as the input is + -- syntactically valid, even if we have detected overflow + + if Digit >= Base then + Overflow := True; + + -- Here we accumulate the value, checking overflow + + elsif Uval <= Umax then + Uval := Base * Uval + Digit; + + elsif Uval > UmaxB then + Overflow := True; + + else + Uval := Base * Uval + Digit; + + if Uval < UmaxB then + Overflow := True; + end if; + end if; + + -- If at end of string with no base char, not a based number + -- but we signal Constraint_Error and set the pointer past + -- the end of the field, since this is what the ACVC tests + -- seem to require, see CE3704N, line 204. + + P := P + 1; + + if P > Max then + Ptr.all := P; + Bad_Value (Str); + end if; + + -- If terminating base character, we are done with loop + + if Str (P) = Base_Char then + Ptr.all := P + 1; + exit; + + -- Deal with underscore + + elsif Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, True); + end if; + + end loop; + end; + end if; + + -- Come here with scanned unsigned value in Uval. The only remaining + -- required step is to deal with exponent if one is present. + + Expon := Scan_Exponent (Str, Ptr, Max); + + if Expon /= 0 and then Uval /= 0 then + + -- For non-zero value, scale by exponent value. No need to do this + -- efficiently, since use of exponent in integer literals is rare, + -- and in any case the exponent cannot be very large. + + declare + UmaxB : constant Unsigned := Unsigned'Last / Base; + -- Numbers bigger than UmaxB overflow if multiplied by base + + begin + for J in 1 .. Expon loop + if Uval > UmaxB then + Overflow := True; + exit; + end if; + + Uval := Uval * Base; + end loop; + end; + end if; + + -- Return result, dealing with sign and overflow + + if Overflow then + Bad_Value (Str); + else + return Uval; + end if; + end Scan_Raw_Unsigned; + + ------------------- + -- Scan_Unsigned -- + ------------------- + + function Scan_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return Unsigned + is + Start : Positive; + -- Save location of first non-blank character + + begin + Scan_Plus_Sign (Str, Ptr, Max, Start); + + if Str (Ptr.all) not in '0' .. '9' then + Ptr.all := Start; + Bad_Value (Str); + end if; + + return Scan_Raw_Unsigned (Str, Ptr, Max); + end Scan_Unsigned; + + -------------------- + -- Value_Unsigned -- + -------------------- + + function Value_Unsigned (Str : String) return Unsigned is + begin + -- We have to special case Str'Last = Positive'Last because the normal + -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We + -- deal with this by converting to a subtype which fixes the bounds. + + if Str'Last = Positive'Last then + declare + subtype NT is String (1 .. Str'Length); + begin + return Value_Unsigned (NT (Str)); + end; + + -- Normal case where Str'Last < Positive'Last + + else + declare + V : Unsigned; + P : aliased Integer := Str'First; + begin + V := Scan_Unsigned (Str, P'Access, Str'Last); + Scan_Trailing_Blanks (Str, P); + return V; + end; + end if; + end Value_Unsigned; + +end System.Val_Uns; diff --git a/gcc/ada/libgnat/s-valuns.ads b/gcc/ada/libgnat/s-valuns.ads new file mode 100644 index 0000000..244733b --- /dev/null +++ b/gcc/ada/libgnat/s-valuns.ads @@ -0,0 +1,129 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for scanning modular Unsigned +-- values for use in Text_IO.Modular_IO, and the Value attribute. + +with System.Unsigned_Types; + +package System.Val_Uns is + pragma Pure; + + function Scan_Raw_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return System.Unsigned_Types.Unsigned; + -- This function scans the string starting at Str (Ptr.all) for a valid + -- integer according to the syntax described in (RM 3.5(43)). The substring + -- scanned extends no further than Str (Max). Note: this does not scan + -- leading or trailing blanks, nor leading sign. + -- + -- There are three cases for the return: + -- + -- If a valid integer is found, then Ptr.all is updated past the last + -- character of the integer. + -- + -- If no valid integer is found, then Ptr.all points either to an initial + -- non-digit character, or to Max + 1 if the field is all spaces and the + -- exception Constraint_Error is raised. + -- + -- If a syntactically valid integer is scanned, but the value is out of + -- range, or, in the based case, the base value is out of range or there + -- is an out of range digit, then Ptr.all points past the integer, and + -- Constraint_Error is raised. + -- + -- Note: these rules correspond to the requirements for leaving the pointer + -- positioned in Text_IO.Get. Note that the rules as stated in the RM would + -- seem to imply that for a case like: + -- + -- 8#12345670009# + -- + -- the pointer should be left at the first # having scanned out the longest + -- valid integer literal (8), but in fact in this case the pointer points + -- past the final # and Constraint_Error is raised. This is the behavior + -- expected for Text_IO and enforced by the ACATS tests. + -- + -- If a based literal is malformed in that a character other than a valid + -- hexadecimal digit is encountered during scanning out the digits after + -- the # (this includes the case of using the wrong terminator, : instead + -- of # or vice versa) there are two cases. If all the digits before the + -- non-digit are in range of the base, as in + -- + -- 8#100x00# + -- 8#100: + -- + -- then in this case, the "base" value before the initial # is returned as + -- the result, and the pointer points to the initial # character on return. + -- + -- If an out of range digit has been detected before the invalid character, + -- as in: + -- + -- 8#900x00# + -- 8#900: + -- + -- then the pointer is also left at the initial # character, but constraint + -- error is raised reflecting the encounter of an out of range digit. + -- + -- Finally if we have an unterminated fixed-point constant where the final + -- # or : character is missing, Constraint_Error is raised and the pointer + -- is left pointing past the last digit, as in: + -- + -- 8#22 + -- + -- This string results in a Constraint_Error with the pointer pointing + -- past the second 2. + -- + -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. + -- + -- Note: this routine should not be called with Str'Last = Positive'Last. + -- If this occurs Program_Error is raised with a message noting that this + -- case is not supported. Most such cases are eliminated by the caller. + + function Scan_Unsigned + (Str : String; + Ptr : not null access Integer; + Max : Integer) return System.Unsigned_Types.Unsigned; + -- Same as Scan_Raw_Unsigned, except scans optional leading + -- blanks, and an optional leading plus sign. + -- + -- Note: if a minus sign is present, Constraint_Error will be raised. + -- Note: trailing blanks are not scanned. + + function Value_Unsigned + (Str : String) return System.Unsigned_Types.Unsigned; + -- Used in computing X'Value (Str) where X is a modular integer type whose + -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str + -- is the string argument of the attribute. Constraint_Error is raised if + -- the string is malformed, or if the value is out of range. + +end System.Val_Uns; diff --git a/gcc/ada/libgnat/s-valuti.adb b/gcc/ada/libgnat/s-valuti.adb new file mode 100644 index 0000000..72df4d5 --- /dev/null +++ b/gcc/ada/libgnat/s-valuti.adb @@ -0,0 +1,334 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U T I L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Case_Util; use System.Case_Util; + +package body System.Val_Util is + + --------------- + -- Bad_Value -- + --------------- + + procedure Bad_Value (S : String) is + begin + raise Constraint_Error with "bad input for 'Value: """ & S & '"'; + end Bad_Value; + + ---------------------- + -- Normalize_String -- + ---------------------- + + procedure Normalize_String + (S : in out String; + F, L : out Integer) + is + begin + F := S'First; + L := S'Last; + + -- Scan for leading spaces + + while F <= L and then S (F) = ' ' loop + F := F + 1; + end loop; + + -- Check for case when the string contained no characters + + if F > L then + Bad_Value (S); + end if; + + -- Scan for trailing spaces + + while S (L) = ' ' loop + L := L - 1; + end loop; + + -- Except in the case of a character literal, convert to upper case + + if S (F) /= ''' then + for J in F .. L loop + S (J) := To_Upper (S (J)); + end loop; + end if; + end Normalize_String; + + ------------------- + -- Scan_Exponent -- + ------------------- + + function Scan_Exponent + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Real : Boolean := False) return Integer + is + P : Natural := Ptr.all; + M : Boolean; + X : Integer; + + begin + if P >= Max + or else (Str (P) /= 'E' and then Str (P) /= 'e') + then + return 0; + end if; + + -- We have an E/e, see if sign follows + + P := P + 1; + + if Str (P) = '+' then + P := P + 1; + + if P > Max then + return 0; + else + M := False; + end if; + + elsif Str (P) = '-' then + P := P + 1; + + if P > Max or else not Real then + return 0; + else + M := True; + end if; + + else + M := False; + end if; + + if Str (P) not in '0' .. '9' then + return 0; + end if; + + -- Scan out the exponent value as an unsigned integer. Values larger + -- than (Integer'Last / 10) are simply considered large enough here. + -- This assumption is correct for all machines we know of (e.g. in the + -- case of 16 bit integers it allows exponents up to 3276, which is + -- large enough for the largest floating types in base 2.) + + X := 0; + + loop + if X < (Integer'Last / 10) then + X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); + end if; + + P := P + 1; + + exit when P > Max; + + if Str (P) = '_' then + Scan_Underscore (Str, P, Ptr, Max, False); + else + exit when Str (P) not in '0' .. '9'; + end if; + end loop; + + if M then + X := -X; + end if; + + Ptr.all := P; + return X; + end Scan_Exponent; + + -------------------- + -- Scan_Plus_Sign -- + -------------------- + + procedure Scan_Plus_Sign + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Start : out Positive) + is + P : Natural := Ptr.all; + + begin + if P > Max then + Bad_Value (Str); + end if; + + -- Scan past initial blanks + + while Str (P) = ' ' loop + P := P + 1; + + if P > Max then + Ptr.all := P; + Bad_Value (Str); + end if; + end loop; + + Start := P; + + -- Skip past an initial plus sign + + if Str (P) = '+' then + P := P + 1; + + if P > Max then + Ptr.all := Start; + Bad_Value (Str); + end if; + end if; + + Ptr.all := P; + end Scan_Plus_Sign; + + --------------- + -- Scan_Sign -- + --------------- + + procedure Scan_Sign + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Minus : out Boolean; + Start : out Positive) + is + P : Natural := Ptr.all; + + begin + -- Deal with case of null string (all blanks). As per spec, we raise + -- constraint error, with Ptr unchanged, and thus > Max. + + if P > Max then + Bad_Value (Str); + end if; + + -- Scan past initial blanks + + while Str (P) = ' ' loop + P := P + 1; + + if P > Max then + Ptr.all := P; + Bad_Value (Str); + end if; + end loop; + + Start := P; + + -- Remember an initial minus sign + + if Str (P) = '-' then + Minus := True; + P := P + 1; + + if P > Max then + Ptr.all := Start; + Bad_Value (Str); + end if; + + -- Skip past an initial plus sign + + elsif Str (P) = '+' then + Minus := False; + P := P + 1; + + if P > Max then + Ptr.all := Start; + Bad_Value (Str); + end if; + + else + Minus := False; + end if; + + Ptr.all := P; + end Scan_Sign; + + -------------------------- + -- Scan_Trailing_Blanks -- + -------------------------- + + procedure Scan_Trailing_Blanks (Str : String; P : Positive) is + begin + for J in P .. Str'Last loop + if Str (J) /= ' ' then + Bad_Value (Str); + end if; + end loop; + end Scan_Trailing_Blanks; + + --------------------- + -- Scan_Underscore -- + --------------------- + + procedure Scan_Underscore + (Str : String; + P : in out Natural; + Ptr : not null access Integer; + Max : Integer; + Ext : Boolean) + is + C : Character; + + begin + P := P + 1; + + -- If underscore is at the end of string, then this is an error and we + -- raise Constraint_Error, leaving the pointer past the underscore. This + -- seems a bit strange. It means e.g. that if the field is: + + -- 345_ + + -- that Constraint_Error is raised. You might think that the RM in this + -- case would scan out the 345 as a valid integer, leaving the pointer + -- at the underscore, but the ACVC suite clearly requires an error in + -- this situation (see for example CE3704M). + + if P > Max then + Ptr.all := P; + Bad_Value (Str); + end if; + + -- Similarly, if no digit follows the underscore raise an error. This + -- also catches the case of double underscore which is also an error. + + C := Str (P); + + if C in '0' .. '9' + or else (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f')) + then + return; + else + Ptr.all := P; + Bad_Value (Str); + end if; + end Scan_Underscore; + +end System.Val_Util; diff --git a/gcc/ada/libgnat/s-valuti.ads b/gcc/ada/libgnat/s-valuti.ads new file mode 100644 index 0000000..c7b3533 --- /dev/null +++ b/gcc/ada/libgnat/s-valuti.ads @@ -0,0 +1,126 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ U T I L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides some common utilities used by the s-valxxx files + +package System.Val_Util is + pragma Pure; + + procedure Bad_Value (S : String); + pragma No_Return (Bad_Value); + -- Raises constraint error with message: bad input for 'Value: "xxx" + + procedure Normalize_String + (S : in out String; + F, L : out Integer); + -- This procedure scans the string S setting F to be the index of the first + -- non-blank character of S and L to be the index of the last non-blank + -- character of S. Any lower case characters present in S will be folded to + -- their upper case equivalent except for character literals. If S consists + -- of entirely blanks then Constraint_Error is raised. + -- + -- Note: if S is the null string, F is set to S'First, L to S'Last + + procedure Scan_Sign + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Minus : out Boolean; + Start : out Positive); + -- The Str, Ptr, Max parameters are as for the scan routines (Str is the + -- string to be scanned starting at Ptr.all, and Max is the index of the + -- last character in the string). Scan_Sign first scans out any initial + -- blanks, raising Constraint_Error if the field is all blank. It then + -- checks for and skips an initial plus or minus, requiring a non-blank + -- character to follow (Constraint_Error is raised if plus or minus appears + -- at the end of the string or with a following blank). Minus is set True + -- if a minus sign was skipped, and False otherwise. On exit Ptr.all points + -- to the character after the sign, or to the first non-blank character + -- if no sign is present. Start is set to the point to the first non-blank + -- character (sign or digit after it). + -- + -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a + -- special case of an all-blank string, and Ptr is unchanged, and hence + -- is greater than Max as required in this case. Constraint_Error is also + -- raised in this case. + -- + -- This routine must not be called with Str'Last = Positive'Last. There is + -- no check for this case, the caller must ensure this condition is met. + + procedure Scan_Plus_Sign + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Start : out Positive); + -- Same as Scan_Sign, but allows only plus, not minus. This is used for + -- modular types. + + function Scan_Exponent + (Str : String; + Ptr : not null access Integer; + Max : Integer; + Real : Boolean := False) return Integer; + -- Called to scan a possible exponent. Str, Ptr, Max are as described above + -- for Scan_Sign. If Ptr.all < Max and Str (Ptr.all) = 'E' or 'e', then an + -- exponent is scanned out, with the exponent value returned in Exp, and + -- Ptr.all updated to point past the exponent. If the exponent field is + -- incorrectly formed or not present, then Ptr.all is unchanged, and the + -- returned exponent value is zero. Real indicates whether a minus sign + -- is permitted (True = permitted). Very large exponents are handled by + -- returning a suitable large value. If the base is zero, then any value + -- is allowed, and otherwise the large value will either cause underflow + -- or overflow during the scaling process which is fine. + -- + -- This routine must not be called with Str'Last = Positive'Last. There is + -- no check for this case, the caller must ensure this condition is met. + + procedure Scan_Trailing_Blanks (Str : String; P : Positive); + -- Checks that the remainder of the field Str (P .. Str'Last) is all + -- blanks. Raises Constraint_Error if a non-blank character is found. + + procedure Scan_Underscore + (Str : String; + P : in out Natural; + Ptr : not null access Integer; + Max : Integer; + Ext : Boolean); + -- Called if an underscore is encountered while scanning digits. Str (P) + -- contains the underscore. Ptr it the pointer to be returned to the + -- ultimate caller of the scan routine, Max is the maximum subscript in + -- Str, and Ext indicates if extended digits are allowed. In the case + -- where the underscore is invalid, Constraint_Error is raised with Ptr + -- set appropriately, otherwise control returns with P incremented past + -- the underscore. + -- + -- This routine must not be called with Str'Last = Positive'Last. There is + -- no check for this case, the caller must ensure this condition is met. + +end System.Val_Util; diff --git a/gcc/ada/libgnat/s-valwch.adb b/gcc/ada/libgnat/s-valwch.adb new file mode 100644 index 0000000..7ae423b --- /dev/null +++ b/gcc/ada/libgnat/s-valwch.adb @@ -0,0 +1,175 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ W C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; use Interfaces; +with System.Val_Util; use System.Val_Util; +with System.WCh_Cnv; use System.WCh_Cnv; +with System.WCh_Con; use System.WCh_Con; + +package body System.Val_WChar is + + -------------------------- + -- Value_Wide_Character -- + -------------------------- + + function Value_Wide_Character + (Str : String; + EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character + is + WC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str, EM); + WV : constant Unsigned_32 := Wide_Wide_Character'Pos (WC); + begin + if WV > 16#FFFF# then + Bad_Value (Str); + else + return Wide_Character'Val (WV); + end if; + end Value_Wide_Character; + + ------------------------------- + -- Value_Wide_Wide_Character -- + ------------------------------- + + function Value_Wide_Wide_Character + (Str : String; + EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character + is + F : Natural; + L : Natural; + S : String (Str'Range) := Str; + + begin + Normalize_String (S, F, L); + + -- Character literal case + + if S (F) = ''' and then S (L) = ''' then + + -- Must be at least three characters + + if L - F < 2 then + Bad_Value (Str); + + -- If just three characters, simple character case + + elsif L - F = 2 then + return Wide_Wide_Character'Val (Character'Pos (S (F + 1))); + + -- Only other possibility for quoted string is wide char sequence + + else + declare + P : Natural; + W : Wide_Wide_Character; + + function In_Char return Character; + -- Function for instantiations of Char_Sequence_To_UTF_32 + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + begin + P := P + 1; + + if P = Str'Last then + Bad_Value (Str); + end if; + + return Str (P); + end In_Char; + + function UTF_32 is + new Char_Sequence_To_UTF_32 (In_Char); + + begin + P := F + 1; + + -- Brackets encoding + + if S (F + 1) = '[' then + W := Wide_Wide_Character'Val (UTF_32 ('[', WCEM_Brackets)); + else + W := Wide_Wide_Character'Val (UTF_32 (S (F + 1), EM)); + end if; + + if P /= L - 1 then + Bad_Value (Str); + end if; + + return W; + end; + end if; + + -- Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases + + elsif Str'Length = 12 + and then Str (Str'First .. Str'First + 3) = "Hex_" + then + declare + W : Unsigned_32 := 0; + + begin + for J in Str'First + 4 .. Str'First + 11 loop + W := W * 16 + Character'Pos (Str (J)); + + if Str (J) in '0' .. '9' then + W := W - Character'Pos ('0'); + elsif Str (J) in 'A' .. 'F' then + W := W - Character'Pos ('A') + 10; + elsif Str (J) in 'a' .. 'f' then + W := W - Character'Pos ('a') + 10; + else + Bad_Value (Str); + end if; + end loop; + + if W > 16#7FFF_FFFF# then + Bad_Value (Str); + else + return Wide_Wide_Character'Val (W); + end if; + end; + + -- Otherwise must be one of the special names for Character + + else + return + Wide_Wide_Character'Val (Character'Pos (Character'Value (Str))); + end if; + + exception + when Constraint_Error => + Bad_Value (Str); + end Value_Wide_Wide_Character; + +end System.Val_WChar; diff --git a/gcc/ada/libgnat/s-valwch.ads b/gcc/ada/libgnat/s-valwch.ads new file mode 100644 index 0000000..b503157 --- /dev/null +++ b/gcc/ada/libgnat/s-valwch.ads @@ -0,0 +1,53 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . V A L _ W C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Processing for Wide_[Wide_]Value attribute + +with System.WCh_Con; + +package System.Val_WChar is + pragma Pure; + + function Value_Wide_Character + (Str : String; + EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character; + -- Computes Wide_Character'Value (Str). The parameter EM is the encoding + -- method used for any Wide_Character sequences in Str. Note that brackets + -- notation is always permitted. + + function Value_Wide_Wide_Character + (Str : String; + EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character; + -- Computes Wide_Character'Value (Str). The parameter EM is the encoding + -- method used for any wide_character sequences in Str. Note that brackets + -- notation is always permitted. + +end System.Val_WChar; diff --git a/gcc/ada/libgnat/s-veboop.adb b/gcc/ada/libgnat/s-veboop.adb new file mode 100644 index 0000000..104f73a --- /dev/null +++ b/gcc/ada/libgnat/s-veboop.adb @@ -0,0 +1,125 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V E C T O R S . B O O L E A N _ O P E R A T I O N S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Vectors.Boolean_Operations is + + SU : constant := Storage_Unit; + -- Convenient short hand, used throughout + + -- The coding of this unit depends on the fact that the Component_Size + -- of a normally declared array of Boolean is equal to Storage_Unit. We + -- can't use the Component_Size directly since it is non-static. The + -- following declaration checks that this declaration is correct + + type Boolean_Array is array (Integer range <>) of Boolean; + pragma Compile_Time_Error + (Boolean_Array'Component_Size /= SU, "run time compile failure"); + + -- NOTE: The boolean literals must be qualified here to avoid visibility + -- anomalies when this package is compiled through Rtsfind, in a context + -- that includes a user-defined type derived from boolean. + + True_Val : constant Vector := Standard.True'Enum_Rep + + Standard.True'Enum_Rep * 2**SU + + Standard.True'Enum_Rep * 2**(SU * 2) + + Standard.True'Enum_Rep * 2**(SU * 3) + + Standard.True'Enum_Rep * 2**(SU * 4) + + Standard.True'Enum_Rep * 2**(SU * 5) + + Standard.True'Enum_Rep * 2**(SU * 6) + + Standard.True'Enum_Rep * 2**(SU * 7); + -- This constant represents the bits to be flipped to perform a logical + -- "not" on a vector of booleans, independent of the actual + -- representation of True. + + -- The representations of (False, True) are assumed to be zero/one and + -- the maximum number of unpacked booleans per Vector is assumed to be 8. + + pragma Assert (Standard.False'Enum_Rep = 0); + pragma Assert (Standard.True'Enum_Rep = 1); + pragma Assert (Vector'Size / Storage_Unit <= 8); + + -- The reason we need to do these gymnastics is that no call to + -- Unchecked_Conversion can be made at the library level since this + -- unit is pure. Also a conversion from the array type to the Vector type + -- inside the body of "not" is inefficient because of alignment issues. + + ----------- + -- "not" -- + ----------- + + function "not" (Item : Vectors.Vector) return Vectors.Vector is + begin + return Item xor True_Val; + end "not"; + + ---------- + -- Nand -- + ---------- + + function Nand (Left, Right : Boolean) return Boolean is + begin + return not (Left and Right); + end Nand; + + function Nand (Left, Right : Vectors.Vector) return Vectors.Vector is + begin + return not (Left and Right); + end Nand; + + --------- + -- Nor -- + --------- + + function Nor (Left, Right : Boolean) return Boolean is + begin + return not (Left or Right); + end Nor; + + function Nor (Left, Right : Vectors.Vector) return Vectors.Vector is + begin + return not (Left or Right); + end Nor; + + ---------- + -- Nxor -- + ---------- + + function Nxor (Left, Right : Boolean) return Boolean is + begin + return not (Left xor Right); + end Nxor; + + function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector is + begin + return not (Left xor Right); + end Nxor; + +end System.Vectors.Boolean_Operations; diff --git a/gcc/ada/libgnat/s-veboop.ads b/gcc/ada/libgnat/s-veboop.ads new file mode 100644 index 0000000..27e6f4f --- /dev/null +++ b/gcc/ada/libgnat/s-veboop.ads @@ -0,0 +1,66 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V E C T O R S . B O O L E A N _ O P E R A T I O N S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains functions for runtime operations on boolean vectors + +package System.Vectors.Boolean_Operations is + pragma Pure; + + -- Although in general the boolean operations on arrays of booleans are + -- identical to operations on arrays of unsigned words of the same size, + -- for the "not" operator this is not the case as False is typically + -- represented by 0 and true by 1. + + function "not" (Item : Vectors.Vector) return Vectors.Vector; + + -- The three boolean operations "nand", "nor" and "nxor" are needed + -- for cases where the compiler moves boolean array operations into + -- the body of the loop that iterates over the array elements. + + -- Note the following equivalences: + -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) + -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) + -- (not X) xor (not Y) = X xor Y + -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) + + function Nand (Left, Right : Boolean) return Boolean; + function Nor (Left, Right : Boolean) return Boolean; + function Nxor (Left, Right : Boolean) return Boolean; + + function Nand (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nor (Left, Right : Vectors.Vector) return Vectors.Vector; + function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector; + + pragma Inline_Always ("not"); + pragma Inline_Always (Nand); + pragma Inline_Always (Nor); + pragma Inline_Always (Nxor); +end System.Vectors.Boolean_Operations; diff --git a/gcc/ada/libgnat/s-vector.ads b/gcc/ada/libgnat/s-vector.ads new file mode 100644 index 0000000..94e1040 --- /dev/null +++ b/gcc/ada/libgnat/s-vector.ads @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- +-- -- +-- S Y S T E M . V E C T O R S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2002-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines a datatype which is most efficient for performing +-- logical operations on large arrays. See System.Generic_Vector_Operations. + +-- In the future this package may also define operations such as element-wise +-- addition, subtraction, multiplication, minimum and maximum of vector-sized +-- packed arrays of Unsigned_8, Unsigned_16 and Unsigned_32 values. These +-- operations could be implemented as system intrinsics on platforms with +-- direct processor support for them. + +package System.Vectors is + pragma Pure; + + type Vector is mod 2**System.Word_Size; + for Vector'Alignment use Integer'Min + (Standard'Maximum_Alignment, System.Word_Size / System.Storage_Unit); + for Vector'Size use System.Word_Size; + +end System.Vectors; diff --git a/gcc/ada/libgnat/s-vercon.adb b/gcc/ada/libgnat/s-vercon.adb new file mode 100644 index 0000000..ddecc16c --- /dev/null +++ b/gcc/ada/libgnat/s-vercon.adb @@ -0,0 +1,58 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V E R S I O N _ C O N T R O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Version_Control is + + ------------------------ + -- Get_Version_String -- + ------------------------ + + function Get_Version_String + (V : System.Unsigned_Types.Unsigned) + return Version_String + is + S : Version_String; + D : Unsigned := V; + H : constant array (Unsigned range 0 .. 15) of Character := + "0123456789abcdef"; + + begin + for J in reverse 1 .. 8 loop + S (J) := H (D mod 16); + D := D / 16; + end loop; + + return S; + end Get_Version_String; + +end System.Version_Control; diff --git a/gcc/ada/libgnat/s-vercon.ads b/gcc/ada/libgnat/s-vercon.ads new file mode 100644 index 0000000..903c4a6 --- /dev/null +++ b/gcc/ada/libgnat/s-vercon.ads @@ -0,0 +1,52 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . V E R S I O N _ C O N T R O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This module contains the runtime routine for implementation of the +-- Version and Body_Version attributes, as well as the string type that +-- is returned as a result of using these attributes. + +with System.Unsigned_Types; + +package System.Version_Control is + pragma Pure; + + subtype Version_String is String (1 .. 8); + -- Eight character string returned by Get_version_String; + + function Get_Version_String + (V : System.Unsigned_Types.Unsigned) + return Version_String; + -- The version information in the executable file is stored as unsigned + -- integers. This routine converts the unsigned integer into an eight + -- character string containing its hexadecimal digits (with lower case + -- letters). + +end System.Version_Control; diff --git a/gcc/ada/libgnat/s-wchcnv.adb b/gcc/ada/libgnat/s-wchcnv.adb new file mode 100644 index 0000000..97ef6a1 --- /dev/null +++ b/gcc/ada/libgnat/s-wchcnv.adb @@ -0,0 +1,465 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C N V -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +with Interfaces; use Interfaces; +with System.WCh_Con; use System.WCh_Con; +with System.WCh_JIS; use System.WCh_JIS; + +package body System.WCh_Cnv is + + ----------------------------- + -- Char_Sequence_To_UTF_32 -- + ----------------------------- + + function Char_Sequence_To_UTF_32 + (C : Character; + EM : System.WCh_Con.WC_Encoding_Method) return UTF_32_Code + is + B1 : Unsigned_32; + C1 : Character; + U : Unsigned_32; + W : Unsigned_32; + + procedure Get_Hex (N : Character); + -- If N is a hex character, then set B1 to 16 * B1 + character N. + -- Raise Constraint_Error if character N is not a hex character. + + procedure Get_UTF_Byte; + pragma Inline (Get_UTF_Byte); + -- Used to interpret a 2#10xxxxxx# continuation byte in UTF-8 mode. + -- Reads a byte, and raises CE if the first two bits are not 10. + -- Otherwise shifts W 6 bits left and or's in the 6 xxxxxx bits. + + ------------- + -- Get_Hex -- + ------------- + + procedure Get_Hex (N : Character) is + B2 : constant Unsigned_32 := Character'Pos (N); + begin + if B2 in Character'Pos ('0') .. Character'Pos ('9') then + B1 := B1 * 16 + B2 - Character'Pos ('0'); + elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then + B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10); + elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then + B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10); + else + raise Constraint_Error; + end if; + end Get_Hex; + + ------------------ + -- Get_UTF_Byte -- + ------------------ + + procedure Get_UTF_Byte is + begin + U := Unsigned_32 (Character'Pos (In_Char)); + + if (U and 2#11000000#) /= 2#10_000000# then + raise Constraint_Error; + end if; + + W := Shift_Left (W, 6) or (U and 2#00111111#); + end Get_UTF_Byte; + + -- Start of processing for Char_Sequence_To_UTF_32 + + begin + case EM is + when WCEM_Hex => + if C /= ASCII.ESC then + return Character'Pos (C); + + else + B1 := 0; + Get_Hex (In_Char); + Get_Hex (In_Char); + Get_Hex (In_Char); + Get_Hex (In_Char); + + return UTF_32_Code (B1); + end if; + + when WCEM_Upper => + if C > ASCII.DEL then + return 256 * Character'Pos (C) + Character'Pos (In_Char); + else + return Character'Pos (C); + end if; + + when WCEM_Shift_JIS => + if C > ASCII.DEL then + return Wide_Character'Pos (Shift_JIS_To_JIS (C, In_Char)); + else + return Character'Pos (C); + end if; + + when WCEM_EUC => + if C > ASCII.DEL then + return Wide_Character'Pos (EUC_To_JIS (C, In_Char)); + else + return Character'Pos (C); + end if; + + when WCEM_UTF8 => + + -- Note: for details of UTF8 encoding see RFC 3629 + + U := Unsigned_32 (Character'Pos (C)); + + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + if (U and 2#10000000#) = 2#00000000# then + return Character'Pos (C); + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + elsif (U and 2#11100000#) = 2#110_00000# then + W := U and 2#00011111#; + Get_UTF_Byte; + return UTF_32_Code (W); + + -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11110000#) = 2#1110_0000# then + W := U and 2#00001111#; + Get_UTF_Byte; + Get_UTF_Byte; + return UTF_32_Code (W); + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11111000#) = 2#11110_000# then + W := U and 2#00000111#; + + for K in 1 .. 3 loop + Get_UTF_Byte; + end loop; + + return UTF_32_Code (W); + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + elsif (U and 2#11111100#) = 2#111110_00# then + W := U and 2#00000011#; + + for K in 1 .. 4 loop + Get_UTF_Byte; + end loop; + + return UTF_32_Code (W); + + -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx 10xxxxxx + + elsif (U and 2#11111110#) = 2#1111110_0# then + W := U and 2#00000001#; + + for K in 1 .. 5 loop + Get_UTF_Byte; + end loop; + + return UTF_32_Code (W); + + else + raise Constraint_Error; + end if; + + when WCEM_Brackets => + if C /= '[' then + return Character'Pos (C); + end if; + + if In_Char /= '"' then + raise Constraint_Error; + end if; + + B1 := 0; + Get_Hex (In_Char); + Get_Hex (In_Char); + + C1 := In_Char; + + if C1 /= '"' then + Get_Hex (C1); + Get_Hex (In_Char); + + C1 := In_Char; + + if C1 /= '"' then + Get_Hex (C1); + Get_Hex (In_Char); + + C1 := In_Char; + + if C1 /= '"' then + Get_Hex (C1); + Get_Hex (In_Char); + + if B1 > Unsigned_32 (UTF_32_Code'Last) then + raise Constraint_Error; + end if; + + if In_Char /= '"' then + raise Constraint_Error; + end if; + end if; + end if; + end if; + + if In_Char /= ']' then + raise Constraint_Error; + end if; + + return UTF_32_Code (B1); + end case; + end Char_Sequence_To_UTF_32; + + -------------------------------- + -- Char_Sequence_To_Wide_Char -- + -------------------------------- + + function Char_Sequence_To_Wide_Char + (C : Character; + EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character + is + function Char_Sequence_To_UTF is new Char_Sequence_To_UTF_32 (In_Char); + + U : constant UTF_32_Code := Char_Sequence_To_UTF (C, EM); + + begin + if U > 16#FFFF# then + raise Constraint_Error; + else + return Wide_Character'Val (U); + end if; + end Char_Sequence_To_Wide_Char; + + ----------------------------- + -- UTF_32_To_Char_Sequence -- + ----------------------------- + + procedure UTF_32_To_Char_Sequence + (Val : UTF_32_Code; + EM : System.WCh_Con.WC_Encoding_Method) + is + Hexc : constant array (UTF_32_Code range 0 .. 15) of Character := + "0123456789ABCDEF"; + + C1, C2 : Character; + U : Unsigned_32; + + begin + -- Raise CE for invalid UTF_32_Code + + if not Val'Valid then + raise Constraint_Error; + end if; + + -- Processing depends on encoding mode + + case EM is + when WCEM_Hex => + if Val < 256 then + Out_Char (Character'Val (Val)); + elsif Val <= 16#FFFF# then + Out_Char (ASCII.ESC); + Out_Char (Hexc (Val / (16**3))); + Out_Char (Hexc ((Val / (16**2)) mod 16)); + Out_Char (Hexc ((Val / 16) mod 16)); + Out_Char (Hexc (Val mod 16)); + else + raise Constraint_Error; + end if; + + when WCEM_Upper => + if Val < 128 then + Out_Char (Character'Val (Val)); + elsif Val < 16#8000# or else Val > 16#FFFF# then + raise Constraint_Error; + else + Out_Char (Character'Val (Val / 256)); + Out_Char (Character'Val (Val mod 256)); + end if; + + when WCEM_Shift_JIS => + if Val < 128 then + Out_Char (Character'Val (Val)); + elsif Val <= 16#FFFF# then + JIS_To_Shift_JIS (Wide_Character'Val (Val), C1, C2); + Out_Char (C1); + Out_Char (C2); + else + raise Constraint_Error; + end if; + + when WCEM_EUC => + if Val < 128 then + Out_Char (Character'Val (Val)); + elsif Val <= 16#FFFF# then + JIS_To_EUC (Wide_Character'Val (Val), C1, C2); + Out_Char (C1); + Out_Char (C2); + else + raise Constraint_Error; + end if; + + when WCEM_UTF8 => + + -- Note: for details of UTF8 encoding see RFC 3629 + + U := Unsigned_32 (Val); + + -- 16#00_0000#-16#00_007F#: 0xxxxxxx + + if U <= 16#00_007F# then + Out_Char (Character'Val (U)); + + -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx + + elsif U <= 16#00_07FF# then + Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx + + elsif U <= 16#00_FFFF# then + Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx + + elsif U <= 16#10_FFFF# then + Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx + + elsif U <= 16#03FF_FFFF# then + Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx + -- 10xxxxxx 10xxxxxx 10xxxxxx + + elsif U <= 16#7FFF_FFFF# then + Out_Char (Character'Val (2#11111100# or Shift_Right (U, 30))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 24) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) + and 2#00111111#))); + Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); + + else + raise Constraint_Error; + end if; + + when WCEM_Brackets => + + -- Values in the range 0-255 are directly output. Note that there + -- is an issue with [ (16#5B#) since this will cause confusion + -- if the resulting string is interpreted using brackets encoding. + + -- One possibility would be to always output [ as ["5B"] but in + -- practice this is undesirable, since for example normal use of + -- Wide_Text_IO for output (much more common than input), really + -- does want to be able to say something like + + -- Put_Line ("Start of output [first run]"); + + -- and have it come out as intended, rather than contaminated by + -- a ["5B"] sequence in place of the left bracket. + + if Val < 256 then + Out_Char (Character'Val (Val)); + + -- Otherwise use brackets notation for vales greater than 255 + + else + Out_Char ('['); + Out_Char ('"'); + + if Val > 16#FFFF# then + if Val > 16#00FF_FFFF# then + Out_Char (Hexc (Val / 16 ** 7)); + Out_Char (Hexc ((Val / 16 ** 6) mod 16)); + end if; + + Out_Char (Hexc ((Val / 16 ** 5) mod 16)); + Out_Char (Hexc ((Val / 16 ** 4) mod 16)); + end if; + + Out_Char (Hexc ((Val / 16 ** 3) mod 16)); + Out_Char (Hexc ((Val / 16 ** 2) mod 16)); + Out_Char (Hexc ((Val / 16) mod 16)); + Out_Char (Hexc (Val mod 16)); + + Out_Char ('"'); + Out_Char (']'); + end if; + end case; + end UTF_32_To_Char_Sequence; + + -------------------------------- + -- Wide_Char_To_Char_Sequence -- + -------------------------------- + + procedure Wide_Char_To_Char_Sequence + (WC : Wide_Character; + EM : System.WCh_Con.WC_Encoding_Method) + is + procedure UTF_To_Char_Sequence is new UTF_32_To_Char_Sequence (Out_Char); + begin + UTF_To_Char_Sequence (Wide_Character'Pos (WC), EM); + end Wide_Char_To_Char_Sequence; + +end System.WCh_Cnv; diff --git a/gcc/ada/libgnat/s-wchcnv.ads b/gcc/ada/libgnat/s-wchcnv.ads new file mode 100644 index 0000000..e807bb4 --- /dev/null +++ b/gcc/ada/libgnat/s-wchcnv.ads @@ -0,0 +1,116 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C N V -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains generic subprograms used for converting between +-- sequences of Character and Wide_Character. Wide_Wide_Character values +-- are also handled, but represented using integer range types defined in +-- this package, so that this package can be used from applications that +-- are restricted to Ada 95 compatibility (such as the compiler itself). + +-- All the algorithms for encoding and decoding are isolated in this package +-- and in System.WCh_JIS and should not be duplicated elsewhere. The only +-- exception to this is that GNAT.Decode_String and GNAT.Encode_String have +-- their own circuits for UTF-8 conversions, for improved efficiency. + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +pragma Compiler_Unit_Warning; + +with System.WCh_Con; + +package System.WCh_Cnv is + pragma Pure; + + type UTF_32_Code is range 0 .. 16#7FFF_FFFF#; + for UTF_32_Code'Size use 32; + -- Range of allowed UTF-32 encoding values + + type UTF_32_String is array (Positive range <>) of UTF_32_Code; + + generic + with function In_Char return Character; + function Char_Sequence_To_Wide_Char + (C : Character; + EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character; + -- C is the first character of a sequence of one or more characters which + -- represent a wide character sequence. Calling the function In_Char for + -- additional characters as required, Char_To_Wide_Char returns the + -- corresponding wide character value. Constraint_Error is raised if the + -- sequence of characters encountered is not a valid wide character + -- sequence for the given encoding method. + -- + -- Note on the use of brackets encoding (WCEM_Brackets). The brackets + -- encoding method is ambiguous in the context of this function, since + -- there is no way to tell if ["1234"] is eight unencoded characters or + -- one encoded character. In the context of Ada sources, any sequence + -- starting [" must be the start of an encoding (since that sequence is + -- not valid in Ada source otherwise). The routines in this package use + -- the same approach. If the input string contains the sequence [" then + -- this is assumed to be the start of a brackets encoding sequence, and + -- if it does not match the syntax, an error is raised. + + generic + with function In_Char return Character; + function Char_Sequence_To_UTF_32 + (C : Character; + EM : System.WCh_Con.WC_Encoding_Method) return UTF_32_Code; + -- This is similar to the above, but the function returns a code from + -- the full UTF_32 code set, which covers the full range of possible + -- values in Wide_Wide_Character. The result can be converted to + -- Wide_Wide_Character form using Wide_Wide_Character'Val. + + generic + with procedure Out_Char (C : Character); + procedure Wide_Char_To_Char_Sequence + (WC : Wide_Character; + EM : System.WCh_Con.WC_Encoding_Method); + -- Given a wide character, converts it into a sequence of one or + -- more characters, calling the given Out_Char procedure for each. + -- Constraint_Error is raised if the given wide character value is + -- not a valid value for the given encoding method. + -- + -- Note on brackets encoding (WCEM_Brackets). For the input routines above, + -- upper half characters can be represented as ["hh"] but this procedure + -- will only use brackets encodings for codes higher than 16#FF#, so upper + -- half characters will be output as single Character values. + + generic + with procedure Out_Char (C : Character); + procedure UTF_32_To_Char_Sequence + (Val : UTF_32_Code; + EM : System.WCh_Con.WC_Encoding_Method); + -- This is similar to the above, but the input value is a code from the + -- full UTF_32 code set, which covers the full range of possible values + -- in Wide_Wide_Character. To convert a Wide_Wide_Character value, the + -- caller can use Wide_Wide_Character'Pos in the call. + +end System.WCh_Cnv; diff --git a/gcc/ada/libgnat/s-wchcon.adb b/gcc/ada/libgnat/s-wchcon.adb new file mode 100644 index 0000000..560ec84 --- /dev/null +++ b/gcc/ada/libgnat/s-wchcon.adb @@ -0,0 +1,84 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C O N -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2005-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.WCh_Con is + + ---------------------------- + -- Get_WC_Encoding_Method -- + ---------------------------- + + function Get_WC_Encoding_Method (C : Character) return WC_Encoding_Method is + begin + for Method in WC_Encoding_Method loop + if C = WC_Encoding_Letters (Method) then + return Method; + end if; + end loop; + + raise Constraint_Error; + end Get_WC_Encoding_Method; + + function Get_WC_Encoding_Method (S : String) return WC_Encoding_Method is + begin + if S = "hex" then + return WCEM_Hex; + elsif S = "upper" then + return WCEM_Upper; + elsif S = "shift_jis" then + return WCEM_Shift_JIS; + elsif S = "euc" then + return WCEM_EUC; + elsif S = "utf8" then + return WCEM_UTF8; + elsif S = "brackets" then + return WCEM_Brackets; + else + raise Constraint_Error; + end if; + end Get_WC_Encoding_Method; + + -------------------------- + -- Is_Start_Of_Encoding -- + -------------------------- + + function Is_Start_Of_Encoding + (C : Character; + EM : WC_Encoding_Method) return Boolean + is + begin + return (EM in WC_Upper_Half_Encoding_Method + and then Character'Pos (C) >= 16#80#) + or else (EM in WC_ESC_Encoding_Method and then C = ASCII.ESC); + end Is_Start_Of_Encoding; + +end System.WCh_Con; diff --git a/gcc/ada/libgnat/s-wchcon.ads b/gcc/ada/libgnat/s-wchcon.ads new file mode 100644 index 0000000..ca40d91 --- /dev/null +++ b/gcc/ada/libgnat/s-wchcon.ads @@ -0,0 +1,220 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ C O N -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package defines the codes used to identify the encoding method for +-- wide characters in string and character constants. This is needed both +-- at compile time and at runtime (for the wide character runtime routines) + +-- This unit may be used directly from an application program by providing +-- an appropriate WITH, and the interface can be expected to remain stable. + +pragma Compiler_Unit_Warning; + +package System.WCh_Con is + pragma Pure; + + ------------------------------------- + -- Wide_Character Encoding Methods -- + ------------------------------------- + + -- A wide character encoding method is a method for uniquely representing + -- a Wide_Character or Wide_Wide_Character value using a one or more + -- Character values. Three types of encoding method are supported by GNAT: + + -- An escape encoding method uses ESC as the first character of the + -- sequence, and subsequent characters determine the wide character + -- value that is represented. Any character other than ESC stands + -- for itself as a single byte (i.e. any character in Latin-1, other + -- than ESC itself, is represented as a single character: itself). + + -- An upper half encoding method uses a character in the upper half + -- range (i.e. in the range 16#80# .. 16#FF#) as the first byte of + -- a wide character encoding sequence. Subsequent characters are + -- used to determine the wide character value that is represented. + -- Any character in the lower half (16#00# .. 16#7F#) represents + -- itself as a single character. + + -- The brackets notation, where a wide character is represented by the + -- sequence ["xx"] or ["xxxx"] or ["xxxxxx"] where xx are hexadecimal + -- characters. Note that currently this is the only encoding that + -- supports the full UTF-32 range. + + -- Note that GNAT does not currently support escape-in, escape-out + -- encoding methods, where an escape sequence is used to set a mode + -- used to recognize subsequent characters. All encoding methods use + -- individual character-by-character encodings, so that a sequence of + -- wide characters is represented by a sequence of encodings. + + -- To add new encoding methods, the following steps are required: + + -- 1. Define a code for a new value of type WC_Encoding_Method + -- 2. Adjust the definition of WC_Encoding_Method accordingly + -- 3. Provide appropriate conversion routines in System.WCh_Cnv + -- 4. Adjust definition of WC_Longest_Sequence if necessary + -- 5. Add an entry in WC_Encoding_Letters for the new method + -- 6. Add proper code to s-wchstw.adb, s-wchwts.adb, s-widwch.adb + -- 7. Update documentation (remember section on form strings) + + -- Note that the WC_Encoding_Method values must be kept ordered so that + -- the definitions of the subtypes WC_Upper_Half_Encoding_Method and + -- WC_ESC_Encoding_Method are still correct. + + --------------------------------- + -- Encoding Method Definitions -- + --------------------------------- + + type WC_Encoding_Method is range 1 .. 6; + -- Type covering the range of values used to represent wide character + -- encoding methods. An enumeration type might be a little neater, but + -- more trouble than it's worth, given the need to pass these values + -- from the compiler to the backend, and to record them in the ALI file. + + WCEM_Hex : constant WC_Encoding_Method := 1; + -- The wide character with code 16#abcd# is represented by the escape + -- sequence ESC a b c d (five characters, where abcd are ASCII hex + -- characters, using upper case for letters). This method is easy + -- to deal with in external environments that do not support wide + -- characters, and covers the whole 16-bit BMP. Codes larger than + -- 16#FFFF# are not representable using this encoding method. + + WCEM_Upper : constant WC_Encoding_Method := 2; + -- The wide character with encoding 16#abcd#, where the upper bit is on + -- (i.e. a is in the range 8-F) is represented as two bytes 16#ab# and + -- 16#cd#. The second byte may never be a format control character, but + -- is not required to be in the upper half. This method can be also used + -- for shift-JIS or EUC where the internal coding matches the external + -- coding. Codes larger than 16#FFFF# are not representable using this + -- encoding method. + + WCEM_Shift_JIS : constant WC_Encoding_Method := 3; + -- A wide character is represented by a two character sequence 16#ab# + -- and 16#cd#, with the restrictions described for upper half encoding + -- as described above. The internal character code is the corresponding + -- JIS character according to the standard algorithm for Shift-JIS + -- conversion. See the body of package System.JIS_Conversions for + -- further details. Codes larger than 16#FFFF are not representable + -- using this encoding method. + + WCEM_EUC : constant WC_Encoding_Method := 4; + -- A wide character is represented by a two character sequence 16#ab# and + -- 16#cd#, with both characters being in the upper half set. The internal + -- character code is the corresponding JIS character according to the EUC + -- encoding algorithm. See the body of package System.JIS_Conversions for + -- further details. Codes larger than 16#FFFF# are not representable using + -- this encoding method. + + WCEM_UTF8 : constant WC_Encoding_Method := 5; + -- An ISO 10646-1 BMP/Unicode wide character is represented in UCS + -- Transformation Format 8 (UTF-8), as defined in Annex R of ISO + -- 10646-1/Am.2. Depending on the character value, a Unicode character + -- is represented as the one to six byte sequence. + -- + -- 16#0000_0000#-16#0000_007f#: 2#0xxxxxxx# + -- 16#0000_0080#-16#0000_07ff#: 2#110xxxxx# 2#10xxxxxx# + -- 16#0000_0800#-16#0000_ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# + -- 16#0001_0000#-16#001F_FFFF#: 2#11110xxx# 2#10xxxxxx# 2#10xxxxxx# + -- 2#10xxxxxx# + -- 16#0020_0000#-16#03FF_FFFF#: 2#111110xx# 2#10xxxxxx# 2#10xxxxxx# + -- 2#10xxxxxx# 2#10xxxxxx# + -- 16#0400_0000#-16#7FFF_FFFF#: 2#1111110x# 2#10xxxxxx# 2#10xxxxxx# + -- 2#10xxxxxx# 2#10xxxxxx# 2#10xxxxxx# + -- + -- where the xxx bits correspond to the left-padded bits of the + -- 16-bit character value. Note that all lower half ASCII characters + -- are represented as ASCII bytes and all upper half characters and + -- other wide characters are represented as sequences of upper-half. This + -- encoding method can represent the entire range of Wide_Wide_Character. + + WCEM_Brackets : constant WC_Encoding_Method := 6; + -- A wide character is represented using one of the following sequences: + -- + -- ["xx"] + -- ["xxxx"] + -- ["xxxxxx"] + -- ["xxxxxxxx"] + -- + -- where xx are hexadecimal digits representing the character code. This + -- encoding method can represent the entire range of Wide_Wide_Character + -- but in the general case results in ambiguous representations (there is + -- no ambiguity in Ada sources, since the above sequences are illegal Ada). + + WC_Encoding_Letters : constant array (WC_Encoding_Method) of Character := + (WCEM_Hex => 'h', + WCEM_Upper => 'u', + WCEM_Shift_JIS => 's', + WCEM_EUC => 'e', + WCEM_UTF8 => '8', + WCEM_Brackets => 'b'); + -- Letters used for selection of wide character encoding method in the + -- compiler options (-gnatW? switch) and for Wide_Text_IO (WCEM parameter + -- in the form string). + + subtype WC_ESC_Encoding_Method is + WC_Encoding_Method range WCEM_Hex .. WCEM_Hex; + -- Encoding methods using an ESC character at the start of the sequence + + subtype WC_Upper_Half_Encoding_Method is + WC_Encoding_Method range WCEM_Upper .. WCEM_UTF8; + -- Encoding methods using an upper half character (16#80#..16#FF) at + -- the start of the sequence. + + WC_Longest_Sequence : constant := 12; + -- The longest number of characters that can be used for a wide character + -- or wide wide character sequence for any of the active encoding methods. + + WC_Longest_Sequences : constant array (WC_Encoding_Method) of Natural := + (WCEM_Hex => 5, + WCEM_Upper => 2, + WCEM_Shift_JIS => 2, + WCEM_EUC => 2, + WCEM_UTF8 => 6, + WCEM_Brackets => 12); + -- The longest number of characters that can be used for a wide character + -- or wide wide character sequence using the given encoding method. + + function Get_WC_Encoding_Method (C : Character) return WC_Encoding_Method; + -- Given a character C, returns corresponding encoding method (see array + -- WC_Encoding_Letters above). Raises Constraint_Error if not in list. + + function Get_WC_Encoding_Method (S : String) return WC_Encoding_Method; + -- Given a lower case string that is one of hex, upper, shift_jis, euc, + -- utf8, brackets, return the corresponding encoding method. Raises + -- Constraint_Error if not in list. + + function Is_Start_Of_Encoding + (C : Character; + EM : WC_Encoding_Method) return Boolean; + pragma Inline (Is_Start_Of_Encoding); + -- Returns True if the Character C is the start of a multi-character + -- encoding sequence for the given encoding method EM. If EM is set to + -- WCEM_Brackets, this function always returns False. + +end System.WCh_Con; diff --git a/gcc/ada/libgnat/s-wchjis.adb b/gcc/ada/libgnat/s-wchjis.adb new file mode 100644 index 0000000..8b2da76 --- /dev/null +++ b/gcc/ada/libgnat/s-wchjis.adb @@ -0,0 +1,189 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ J I S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +pragma Compiler_Unit_Warning; + +package body System.WCh_JIS is + + type Byte is mod 256; + + EUC_Hankaku_Kana : constant Byte := 16#8E#; + -- Prefix byte in EUC for Hankaku Kana (small Katakana). Such characters + -- in EUC are represented by a prefix byte followed by the code, which + -- is in the upper half (the corresponding JIS internal code is in the + -- range 16#0080# - 16#00FF#). + + function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character is + EUC1B : constant Byte := Character'Pos (EUC1); + EUC2B : constant Byte := Character'Pos (EUC2); + + begin + if EUC2B not in 16#A0# .. 16#FE# then + raise Constraint_Error; + end if; + + if EUC1B = EUC_Hankaku_Kana then + return Wide_Character'Val (EUC2B); + + else + if EUC1B not in 16#A0# .. 16#FE# then + raise Constraint_Error; + else + return Wide_Character'Val + (256 * Natural (EUC1B and 16#7F#) + Natural (EUC2B and 16#7F#)); + end if; + end if; + end EUC_To_JIS; + + ---------------- + -- JIS_To_EUC -- + ---------------- + + procedure JIS_To_EUC + (J : Wide_Character; + EUC1 : out Character; + EUC2 : out Character) + is + JIS1 : constant Natural := Wide_Character'Pos (J) / 256; + JIS2 : constant Natural := Wide_Character'Pos (J) rem 256; + + begin + -- Special case of small Katakana + + if JIS1 = 0 then + + -- The value must be in the range 16#80# to 16#FF# so that the upper + -- bit is set in both bytes. + + if JIS2 < 16#80# then + raise Constraint_Error; + end if; + + EUC1 := Character'Val (EUC_Hankaku_Kana); + EUC2 := Character'Val (JIS2); + + -- The upper bit of both characters must be clear, or this is not + -- a valid character for representation in EUC form. + + elsif JIS1 > 16#7F# or else JIS2 > 16#7F# then + raise Constraint_Error; + + -- Result is just the two characters with upper bits set + + else + EUC1 := Character'Val (JIS1 + 16#80#); + EUC2 := Character'Val (JIS2 + 16#80#); + end if; + end JIS_To_EUC; + + ---------------------- + -- JIS_To_Shift_JIS -- + ---------------------- + + procedure JIS_To_Shift_JIS + (J : Wide_Character; + SJ1 : out Character; + SJ2 : out Character) + is + JIS1 : Byte; + JIS2 : Byte; + + begin + -- The following is the required algorithm, it's hard to make any + -- more intelligent comments. This was copied from a public domain + -- C program called etos.c (author unknown). + + JIS1 := Byte (Natural (Wide_Character'Pos (J) / 256)); + JIS2 := Byte (Natural (Wide_Character'Pos (J) rem 256)); + + if JIS1 > 16#5F# then + JIS1 := JIS1 + 16#80#; + end if; + + if (JIS1 mod 2) = 0 then + SJ1 := Character'Val ((JIS1 - 16#30#) / 2 + 16#88#); + SJ2 := Character'Val (JIS2 + 16#7E#); + + else + if JIS2 >= 16#60# then + JIS2 := JIS2 + 16#01#; + end if; + + SJ1 := Character'Val ((JIS1 - 16#31#) / 2 + 16#89#); + SJ2 := Character'Val (JIS2 + 16#1F#); + end if; + end JIS_To_Shift_JIS; + + ---------------------- + -- Shift_JIS_To_JIS -- + ---------------------- + + function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character is + SJIS1 : Byte; + SJIS2 : Byte; + JIS1 : Byte; + JIS2 : Byte; + + begin + -- The following is the required algorithm, it's hard to make any + -- more intelligent comments. This was copied from a public domain + -- C program called stoj.c written by shige@csk.JUNET. + + SJIS1 := Character'Pos (SJ1); + SJIS2 := Character'Pos (SJ2); + + if SJIS1 >= 16#E0# then + SJIS1 := SJIS1 - 16#40#; + end if; + + if SJIS2 >= 16#9F# then + JIS1 := (SJIS1 - 16#88#) * 2 + 16#30#; + JIS2 := SJIS2 - 16#7E#; + + else + if SJIS2 >= 16#7F# then + SJIS2 := SJIS2 - 16#01#; + end if; + + JIS1 := (SJIS1 - 16#89#) * 2 + 16#31#; + JIS2 := SJIS2 - 16#1F#; + end if; + + if JIS1 not in 16#20# .. 16#7E# + or else JIS2 not in 16#20# .. 16#7E# + then + raise Constraint_Error; + else + return Wide_Character'Val (256 * Natural (JIS1) + Natural (JIS2)); + end if; + end Shift_JIS_To_JIS; + +end System.WCh_JIS; diff --git a/gcc/ada/libgnat/s-wchjis.ads b/gcc/ada/libgnat/s-wchjis.ads new file mode 100644 index 0000000..772845d --- /dev/null +++ b/gcc/ada/libgnat/s-wchjis.ads @@ -0,0 +1,78 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ J I S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines used for converting between internal +-- JIS codes and the two external forms we support (EUC and Shift-JIS) + +pragma Compiler_Unit_Warning; + +package System.WCh_JIS is + pragma Pure; + + function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character; + -- Given the two bytes of a EUC representation, return the + -- corresponding JIS code wide character. Raises Constraint_Error + -- if the two characters are not a valid EUC encoding. + + procedure JIS_To_EUC + (J : Wide_Character; + EUC1 : out Character; + EUC2 : out Character); + + -- Given a wide character in JIS form, produce the corresponding + -- two bytes of the EUC representation of this character. This is + -- only used if J is not in the normal ASCII range, i.e. on entry + -- we know that Wide_Character'Pos (J) >= 16#0080# and that we + -- thus require a two byte EUC representation (ASCII codes appear + -- unchanged as a single byte in EUC). No error checking is performed, + -- the input code is assumed to be in an appropriate range. + + procedure JIS_To_Shift_JIS + (J : Wide_Character; + SJ1 : out Character; + SJ2 : out Character); + -- Given a wide character code in JIS form, produce the corresponding + -- two bytes of the Shift-JIS representation of this character. This + -- is only used if J is not in the normal ASCII range, i.e. on entry + -- we know that Wide_Character'Pos (J) >= 16#0080# and that we + -- thus require a two byte EUC representation (ASCII codes appear + -- unchanged as a single byte in EUC). No error checking is performed, + -- the input code is assumed to be in an appropriate range (note in + -- particular that input codes in the range 16#0080#-16#00FF#, i.e. + -- Hankaku Kana, do not appear, since Shift JIS has no representation + -- for such codes. + + function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character; + -- Given the two bytes of a Shift-JIS representation, return the + -- corresponding JIS code wide character. Raises Constraint_Error if + -- the two characters are not a valid shift-JIS encoding. + +end System.WCh_JIS; diff --git a/gcc/ada/libgnat/s-wchstw.adb b/gcc/ada/libgnat/s-wchstw.adb new file mode 100644 index 0000000..f55808b --- /dev/null +++ b/gcc/ada/libgnat/s-wchstw.adb @@ -0,0 +1,173 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ S T W -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_Cnv; use System.WCh_Cnv; + +package body System.WCh_StW is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Get_Next_Code + (S : String; + P : in out Natural; + V : out UTF_32_Code; + EM : WC_Encoding_Method); + -- Scans next character starting at S(P) and returns its value in V. On + -- exit P is updated past the last character read. Raises Constraint_Error + -- if the string is not well formed. Raises Constraint_Error if the code + -- value is greater than 16#7FFF_FFFF#. On entry P <= S'Last. + + ------------------- + -- Get_Next_Code -- + ------------------- + + procedure Get_Next_Code + (S : String; + P : in out Natural; + V : out UTF_32_Code; + EM : WC_Encoding_Method) + is + function In_Char return Character; + -- Function to return a character, bumping P, raises Constraint_Error + -- if P > S'Last on entry. + + function Get_UTF_32 is new Char_Sequence_To_UTF_32 (In_Char); + -- Function to get next UFT_32 value + + ------------- + -- In_Char -- + ------------- + + function In_Char return Character is + begin + if P > S'Last then + raise Constraint_Error with "badly formed wide character code"; + else + P := P + 1; + return S (P - 1); + end if; + end In_Char; + + -- Start of processing for Get_Next_Code + + begin + -- Check for wide character encoding + + case EM is + when WCEM_Hex => + if S (P) = ASCII.ESC then + V := Get_UTF_32 (In_Char, EM); + return; + end if; + + when WCEM_Upper | WCEM_Shift_JIS | WCEM_EUC | WCEM_UTF8 => + if S (P) >= Character'Val (16#80#) then + V := Get_UTF_32 (In_Char, EM); + return; + end if; + + when WCEM_Brackets => + if P + 2 <= S'Last + and then S (P) = '[' + and then S (P + 1) = '"' + and then S (P + 2) /= '"' + then + V := Get_UTF_32 (In_Char, EM); + return; + end if; + end case; + + -- If it is not a wide character code, just get it + + V := Character'Pos (S (P)); + P := P + 1; + end Get_Next_Code; + + --------------------------- + -- String_To_Wide_String -- + --------------------------- + + procedure String_To_Wide_String + (S : String; + R : out Wide_String; + L : out Natural; + EM : System.WCh_Con.WC_Encoding_Method) + is + SP : Natural; + V : UTF_32_Code; + + begin + pragma Assert (S'First = 1); + + SP := S'First; + L := 0; + while SP <= S'Last loop + Get_Next_Code (S, SP, V, EM); + + if V > 16#FFFF# then + raise Constraint_Error with + "out of range value for wide character"; + end if; + + L := L + 1; + R (L) := Wide_Character'Val (V); + end loop; + end String_To_Wide_String; + + -------------------------------- + -- String_To_Wide_Wide_String -- + -------------------------------- + + procedure String_To_Wide_Wide_String + (S : String; + R : out Wide_Wide_String; + L : out Natural; + EM : System.WCh_Con.WC_Encoding_Method) + is + pragma Assert (S'First = 1); + + SP : Natural; + V : UTF_32_Code; + + begin + SP := S'First; + L := 0; + while SP <= S'Last loop + Get_Next_Code (S, SP, V, EM); + L := L + 1; + R (L) := Wide_Wide_Character'Val (V); + end loop; + end String_To_Wide_Wide_String; + +end System.WCh_StW; diff --git a/gcc/ada/libgnat/s-wchstw.ads b/gcc/ada/libgnat/s-wchstw.ads new file mode 100644 index 0000000..4240571 --- /dev/null +++ b/gcc/ada/libgnat/s-wchstw.ads @@ -0,0 +1,69 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ S T W -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used to convert strings to wide (wide) +-- strings for use by wide (wide) image attribute. + +with System.WCh_Con; + +package System.WCh_StW is + pragma Pure; + + procedure String_To_Wide_String + (S : String; + R : out Wide_String; + L : out Natural; + EM : System.WCh_Con.WC_Encoding_Method); + -- This routine simply takes its argument and converts it to wide string + -- format, storing the result in R (1 .. L), with L being set appropriately + -- on return. The caller guarantees that R is long enough to accommodate + -- the result. This is used in the context of the Wide_Image attribute, + -- where the argument is the corresponding 'Image attribute. Any wide + -- character escape sequences in the string are converted to the + -- corresponding wide character value. No syntax checks are made, it is + -- assumed that any such sequences are validly formed (this must be assured + -- by the caller), and results from the fact that Wide_Image is only used + -- on strings that have been built by the compiler, such as images of + -- enumeration literals. If the method for encoding is a shift-in, + -- shift-out convention, then it is assumed that normal (non-wide + -- character) mode holds at the start and end of the argument string. EM + -- indicates the wide character encoding method. + -- Note: in the WCEM_Brackets case, the brackets escape sequence is used + -- only for codes greater than 16#FF#. + + procedure String_To_Wide_Wide_String + (S : String; + R : out Wide_Wide_String; + L : out Natural; + EM : System.WCh_Con.WC_Encoding_Method); + -- Same function with Wide_Wide_String output + +end System.WCh_StW; diff --git a/gcc/ada/libgnat/s-wchwts.adb b/gcc/ada/libgnat/s-wchwts.adb new file mode 100644 index 0000000..4c116ed --- /dev/null +++ b/gcc/ada/libgnat/s-wchwts.adb @@ -0,0 +1,122 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ W T S -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.WCh_Con; use System.WCh_Con; +with System.WCh_Cnv; use System.WCh_Cnv; + +package body System.WCh_WtS is + + ----------------------- + -- Local Subprograms -- + ----------------------- + + procedure Store_UTF_32_Character + (U : UTF_32_Code; + S : out String; + P : in out Integer; + EM : WC_Encoding_Method); + -- Stores the string representation of the wide or wide wide character + -- whose code is given as U, starting at S (P + 1). P is incremented to + -- point to the last character stored. Raises CE if character cannot be + -- stored using the given encoding method. + + ---------------------------- + -- Store_UTF_32_Character -- + ---------------------------- + + procedure Store_UTF_32_Character + (U : UTF_32_Code; + S : out String; + P : in out Integer; + EM : WC_Encoding_Method) + is + procedure Out_Char (C : Character); + pragma Inline (Out_Char); + -- Procedure to increment P and store C at S (P) + + procedure Store_Chars is new UTF_32_To_Char_Sequence (Out_Char); + + -------------- + -- Out_Char -- + -------------- + + procedure Out_Char (C : Character) is + begin + P := P + 1; + S (P) := C; + end Out_Char; + + begin + Store_Chars (U, EM); + end Store_UTF_32_Character; + + --------------------------- + -- Wide_String_To_String -- + --------------------------- + + function Wide_String_To_String + (S : Wide_String; + EM : WC_Encoding_Method) return String + is + R : String (S'First .. S'First + 5 * S'Length); -- worst case length + RP : Natural; + + begin + RP := R'First - 1; + for SP in S'Range loop + Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM); + end loop; + + return R (R'First .. RP); + end Wide_String_To_String; + + -------------------------------- + -- Wide_Wide_String_To_String -- + -------------------------------- + + function Wide_Wide_String_To_String + (S : Wide_Wide_String; + EM : WC_Encoding_Method) return String + is + R : String (S'First .. S'First + 7 * S'Length); -- worst case length + RP : Natural; + + begin + RP := R'First - 1; + + for SP in S'Range loop + Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM); + end loop; + + return R (R'First .. RP); + end Wide_Wide_String_To_String; + +end System.WCh_WtS; diff --git a/gcc/ada/libgnat/s-wchwts.ads b/gcc/ada/libgnat/s-wchwts.ads new file mode 100644 index 0000000..670d241 --- /dev/null +++ b/gcc/ada/libgnat/s-wchwts.ads @@ -0,0 +1,63 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W C H _ W T S -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used to convert wide strings and wide +-- wide strings to strings for use by wide and wide wide character attributes +-- (value, image etc.) and also by the numeric IO subpackages of +-- Ada.Text_IO.Wide_Text_IO and Ada.Text_IO.Wide_Wide_Text_IO. + +with System.WCh_Con; + +package System.WCh_WtS is + pragma Pure; + + function Wide_String_To_String + (S : Wide_String; + EM : System.WCh_Con.WC_Encoding_Method) return String; + -- This routine simply takes its argument and converts it to a string, + -- using the internal compiler escape sequence convention (defined in + -- package Widechar) to translate characters that are out of range + -- of type String. In the context of the Wide_Value attribute, the + -- argument is the original attribute argument, and the result is used + -- in a call to the corresponding Value attribute function. If the method + -- for encoding is a shift-in, shift-out convention, then it is assumed + -- that normal (non-wide character) mode holds at the start and end of + -- the result string. EM indicates the wide character encoding method. + -- Note: in the WCEM_Brackets case, we only use the brackets encoding + -- for characters greater than 16#FF#. The lowest index of the returned + -- String is equal to S'First. + + function Wide_Wide_String_To_String + (S : Wide_Wide_String; + EM : System.WCh_Con.WC_Encoding_Method) return String; + -- Same processing, except for Wide_Wide_String + +end System.WCh_WtS; diff --git a/gcc/ada/libgnat/s-widboo.adb b/gcc/ada/libgnat/s-widboo.adb new file mode 100644 index 0000000..648d7bd --- /dev/null +++ b/gcc/ada/libgnat/s-widboo.adb @@ -0,0 +1,51 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ B O O L -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Wid_Bool is + + ------------------- + -- Width_Boolean -- + ------------------- + + function Width_Boolean (Lo, Hi : Boolean) return Natural is + begin + if Lo > Hi then + return 0; + + elsif Lo = False then + return 5; + + else + return 4; + end if; + end Width_Boolean; + +end System.Wid_Bool; diff --git a/gcc/ada/libgnat/s-widboo.ads b/gcc/ada/libgnat/s-widboo.ads new file mode 100644 index 0000000..09c6a49 --- /dev/null +++ b/gcc/ada/libgnat/s-widboo.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ B O O L -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Boolean'Width + +package System.Wid_Bool is + pragma Pure; + + function Width_Boolean (Lo, Hi : Boolean) return Natural; + -- Compute Width attribute for non-static type derived from Boolean. + -- The arguments are the low and high bounds for the type. + +end System.Wid_Bool; diff --git a/gcc/ada/libgnat/s-widcha.adb b/gcc/ada/libgnat/s-widcha.adb new file mode 100644 index 0000000..95cd31a --- /dev/null +++ b/gcc/ada/libgnat/s-widcha.adb @@ -0,0 +1,56 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Wid_Char is + + --------------------- + -- Width_Character -- + --------------------- + + function Width_Character (Lo, Hi : Character) return Natural is + W : Natural; + + begin + W := 0; + + for C in Lo .. Hi loop + declare + S : constant String := Character'Image (C); + + begin + W := Natural'Max (W, S'Length); + end; + end loop; + + return W; + end Width_Character; + +end System.Wid_Char; diff --git a/gcc/ada/libgnat/s-widcha.ads b/gcc/ada/libgnat/s-widcha.ads new file mode 100644 index 0000000..5f238c9 --- /dev/null +++ b/gcc/ada/libgnat/s-widcha.ads @@ -0,0 +1,41 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Character'Width + +package System.Wid_Char is + pragma Pure; + + function Width_Character (Lo, Hi : Character) return Natural; + -- Compute Width attribute for non-static type derived from Character. + -- The arguments are the low and high bounds for the type. + +end System.Wid_Char; diff --git a/gcc/ada/libgnat/s-widenu.adb b/gcc/ada/libgnat/s-widenu.adb new file mode 100644 index 0000000..d2daf57 --- /dev/null +++ b/gcc/ada/libgnat/s-widenu.adb @@ -0,0 +1,135 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ E N U M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Ada.Unchecked_Conversion; + +package body System.Wid_Enum is + + ------------------------- + -- Width_Enumeration_8 -- + ------------------------- + + function Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural + is + pragma Warnings (Off, Names); + + W : Natural; + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); + end loop; + + return W; + end Width_Enumeration_8; + + -------------------------- + -- Width_Enumeration_16 -- + -------------------------- + + function Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural + is + pragma Warnings (Off, Names); + + W : Natural; + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); + end loop; + + return W; + end Width_Enumeration_16; + + -------------------------- + -- Width_Enumeration_32 -- + -------------------------- + + function Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural + is + pragma Warnings (Off, Names); + + W : Natural; + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + + for J in Lo .. Hi loop + W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); + end loop; + + return W; + end Width_Enumeration_32; + +end System.Wid_Enum; diff --git a/gcc/ada/libgnat/s-widenu.ads b/gcc/ada/libgnat/s-widenu.ads new file mode 100644 index 0000000..7e1d18b --- /dev/null +++ b/gcc/ada/libgnat/s-widenu.ads @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Enumeration_Type'Width + +package System.Wid_Enum is + pragma Pure; + + function Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural; + -- Used to compute Enum'Width where Enum is some enumeration subtype + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address + -- of an array of type array (0 .. N) of Natural_8, where N is the + -- number of enumeration literals in the type. The Indexes values are + -- the starting subscript of each enumeration literal, indexed by Pos + -- values, with an extra entry at the end containing Names'Length + 1. + -- The reason that Indexes is passed by address is that the actual type + -- is created on the fly by the expander. + -- + -- Lo and Hi are the Pos values of the lower and upper bounds of the + -- subtype. The result is the value of Width, i.e. the maximum value + -- of the length of any enumeration literal in the given range. + + function Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural; + -- Identical to Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural) + return Natural; + -- Identical to Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + +end System.Wid_Enum; diff --git a/gcc/ada/libgnat/s-widlli.adb b/gcc/ada/libgnat/s-widlli.adb new file mode 100644 index 0000000..947ab6a --- /dev/null +++ b/gcc/ada/libgnat/s-widlli.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L I -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Wid_LLI is + + ----------------------------- + -- Width_Long_Long_Integer -- + ----------------------------- + + function Width_Long_Long_Integer + (Lo, Hi : Long_Long_Integer) + return Natural + is + W : Natural; + T : Long_Long_Integer; + + begin + if Lo > Hi then + return 0; + + else + -- Minimum value is 2, one for sign, one for digit + + W := 2; + + -- Get max of absolute values, but avoid bomb if we have the maximum + -- negative number (note that First + 1 has same digits as First) + + T := Long_Long_Integer'Max ( + abs (Long_Long_Integer'Max (Lo, Long_Long_Integer'First + 1)), + abs (Long_Long_Integer'Max (Hi, Long_Long_Integer'First + 1))); + + -- Increase value if more digits required + + while T >= 10 loop + T := T / 10; + W := W + 1; + end loop; + + return W; + end if; + + end Width_Long_Long_Integer; + +end System.Wid_LLI; diff --git a/gcc/ada/libgnat/s-widlli.ads b/gcc/ada/libgnat/s-widlli.ads new file mode 100644 index 0000000..ec778eb --- /dev/null +++ b/gcc/ada/libgnat/s-widlli.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L I -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Width attribute for all +-- non-static signed integer subtypes. Note we only have one routine, +-- since this seems a fairly marginal function. + +package System.Wid_LLI is + pragma Pure; + + function Width_Long_Long_Integer + (Lo, Hi : Long_Long_Integer) + return Natural; + -- Compute Width attribute for non-static type derived from a signed + -- Integer type. The arguments Lo, Hi are the bounds of the type. + +end System.Wid_LLI; diff --git a/gcc/ada/libgnat/s-widllu.adb b/gcc/ada/libgnat/s-widllu.adb new file mode 100644 index 0000000..898ff8f --- /dev/null +++ b/gcc/ada/libgnat/s-widllu.adb @@ -0,0 +1,73 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L U -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.Unsigned_Types; use System.Unsigned_Types; + +package body System.Wid_LLU is + + ------------------------------ + -- Width_Long_Long_Unsigned -- + ------------------------------ + + function Width_Long_Long_Unsigned + (Lo, Hi : Long_Long_Unsigned) + return Natural + is + W : Natural; + T : Long_Long_Unsigned; + + begin + if Lo > Hi then + return 0; + + else + -- Minimum value is 2, one for sign, one for digit + + W := 2; + + -- Get max of absolute values, but avoid bomb if we have the maximum + -- negative number (note that First + 1 has same digits as First) + + T := Long_Long_Unsigned'Max (Lo, Hi); + + -- Increase value if more digits required + + while T >= 10 loop + T := T / 10; + W := W + 1; + end loop; + + return W; + end if; + + end Width_Long_Long_Unsigned; + +end System.Wid_LLU; diff --git a/gcc/ada/libgnat/s-widllu.ads b/gcc/ada/libgnat/s-widllu.ads new file mode 100644 index 0000000..f719163 --- /dev/null +++ b/gcc/ada/libgnat/s-widllu.ads @@ -0,0 +1,47 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ L L U -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Width attribute for all +-- non-static unsigned integer (modular integer) subtypes. Note we only +-- have one routine, since this seems a fairly marginal function. + +with System.Unsigned_Types; + +package System.Wid_LLU is + pragma Pure; + + function Width_Long_Long_Unsigned + (Lo, Hi : System.Unsigned_Types.Long_Long_Unsigned) + return Natural; + -- Compute Width attribute for non-static type derived from a modular + -- integer type. The arguments Lo, Hi are the bounds of the type. + +end System.Wid_LLU; diff --git a/gcc/ada/libgnat/s-widwch.adb b/gcc/ada/libgnat/s-widwch.adb new file mode 100644 index 0000000..5b91b56 --- /dev/null +++ b/gcc/ada/libgnat/s-widwch.adb @@ -0,0 +1,104 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ W C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.Wid_WChar is + + -------------------------- + -- Width_Wide_Character -- + -------------------------- + + function Width_Wide_Character + (Lo, Hi : Wide_Character) return Natural + is + W : Natural; + P : Natural; + + begin + W := 0; + for C in Lo .. Hi loop + P := Wide_Character'Pos (C); + + -- Here if we find a character in wide character range + -- Width is max value (12) for Hex_hhhhhhhh + + if P > 16#FF# then + return 12; + + -- If we are in character range then use length of character image + + else + declare + S : constant String := Character'Image (Character'Val (P)); + begin + W := Natural'Max (W, S'Length); + end; + end if; + end loop; + + return W; + end Width_Wide_Character; + + ------------------------------- + -- Width_Wide_Wide_Character -- + ------------------------------- + + function Width_Wide_Wide_Character + (Lo, Hi : Wide_Wide_Character) return Natural + is + W : Natural; + P : Natural; + + begin + W := 0; + for C in Lo .. Hi loop + P := Wide_Wide_Character'Pos (C); + + -- Here if we find a character in wide wide character range. + -- Width is max value (12) for Hex_hhhhhhhh + + if P > 16#FF# then + W := 12; + + -- If we are in character range then use length of character image + + else + declare + S : constant String := Character'Image (Character'Val (P)); + begin + W := Natural'Max (W, S'Length); + end; + end if; + end loop; + + return W; + end Width_Wide_Wide_Character; + +end System.Wid_WChar; diff --git a/gcc/ada/libgnat/s-widwch.ads b/gcc/ada/libgnat/s-widwch.ads new file mode 100644 index 0000000..812496e --- /dev/null +++ b/gcc/ada/libgnat/s-widwch.ads @@ -0,0 +1,46 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I D _ W C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routines used for Wide_[Wide_]Character'Width + +package System.Wid_WChar is + pragma Pure; + + function Width_Wide_Character + (Lo, Hi : Wide_Character) return Natural; + -- Compute Width attribute for non-static type derived from Wide_Character. + -- The arguments are the low and high bounds for the type. + + function Width_Wide_Wide_Character + (Lo, Hi : Wide_Wide_Character) return Natural; + -- Same function for type derived from Wide_Wide_Character + +end System.Wid_WChar; diff --git a/gcc/ada/libgnat/s-win32.ads b/gcc/ada/libgnat/s-win32.ads new file mode 100644 index 0000000..b23ad84 --- /dev/null +++ b/gcc/ada/libgnat/s-win32.ads @@ -0,0 +1,342 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I N 3 2 -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package plus its child provide the low level interface to the Win32 +-- API. The core part of the Win32 API (common to RTX and Win32) is in this +-- package, and an additional part of the Win32 API which is not supported by +-- RTX is in package System.Win32.Ext. + +with Interfaces.C; + +package System.Win32 is + pragma Pure; + + ------------------- + -- General Types -- + ------------------- + + -- The LARGE_INTEGER type is actually a fixed point type + -- that only can represent integers. The reason for this is + -- easier conversion to Duration or other fixed point types. + -- (See System.OS_Primitives.Clock, mingw and rtx versions.) + + type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; + + subtype PVOID is Address; + + type HANDLE is new Interfaces.C.ptrdiff_t; + + INVALID_HANDLE_VALUE : constant HANDLE := -1; + INVALID_FILE_SIZE : constant := 16#FFFFFFFF#; + + type DWORD is new Interfaces.C.unsigned_long; + type WORD is new Interfaces.C.unsigned_short; + type BYTE is new Interfaces.C.unsigned_char; + type LONG is new Interfaces.C.long; + type CHAR is new Interfaces.C.char; + + type BOOL is new Interfaces.C.int; + for BOOL'Size use Interfaces.C.int'Size; + + type Bits1 is range 0 .. 2 ** 1 - 1; + type Bits2 is range 0 .. 2 ** 2 - 1; + type Bits17 is range 0 .. 2 ** 17 - 1; + for Bits1'Size use 1; + for Bits2'Size use 2; + for Bits17'Size use 17; + + -- Note that the following clashes with standard names are to stay + -- compatible with the historical choice of following the C names. + + pragma Warnings (Off); + FALSE : constant := 0; + TRUE : constant := 1; + pragma Warnings (On); + + function GetLastError return DWORD; + pragma Import (Stdcall, GetLastError, "GetLastError"); + + ----------- + -- Files -- + ----------- + + CP_UTF8 : constant := 65001; + CP_ACP : constant := 0; + + GENERIC_READ : constant := 16#80000000#; + GENERIC_WRITE : constant := 16#40000000#; + + CREATE_NEW : constant := 1; + CREATE_ALWAYS : constant := 2; + OPEN_EXISTING : constant := 3; + OPEN_ALWAYS : constant := 4; + TRUNCATE_EXISTING : constant := 5; + + FILE_SHARE_DELETE : constant := 16#00000004#; + FILE_SHARE_READ : constant := 16#00000001#; + FILE_SHARE_WRITE : constant := 16#00000002#; + + FILE_BEGIN : constant := 0; + FILE_CURRENT : constant := 1; + FILE_END : constant := 2; + + PAGE_NOACCESS : constant := 16#0001#; + PAGE_READONLY : constant := 16#0002#; + PAGE_READWRITE : constant := 16#0004#; + PAGE_WRITECOPY : constant := 16#0008#; + PAGE_EXECUTE : constant := 16#0010#; + + FILE_MAP_ALL_ACCESS : constant := 16#F001f#; + FILE_MAP_READ : constant := 4; + FILE_MAP_WRITE : constant := 2; + FILE_MAP_COPY : constant := 1; + + FILE_ADD_FILE : constant := 16#0002#; + FILE_ADD_SUBDIRECTORY : constant := 16#0004#; + FILE_APPEND_DATA : constant := 16#0004#; + FILE_CREATE_PIPE_INSTANCE : constant := 16#0004#; + FILE_DELETE_CHILD : constant := 16#0040#; + FILE_EXECUTE : constant := 16#0020#; + FILE_LIST_DIRECTORY : constant := 16#0001#; + FILE_READ_ATTRIBUTES : constant := 16#0080#; + FILE_READ_DATA : constant := 16#0001#; + FILE_READ_EA : constant := 16#0008#; + FILE_TRAVERSE : constant := 16#0020#; + FILE_WRITE_ATTRIBUTES : constant := 16#0100#; + FILE_WRITE_DATA : constant := 16#0002#; + FILE_WRITE_EA : constant := 16#0010#; + STANDARD_RIGHTS_READ : constant := 16#20000#; + STANDARD_RIGHTS_WRITE : constant := 16#20000#; + SYNCHRONIZE : constant := 16#100000#; + + FILE_ATTRIBUTE_READONLY : constant := 16#00000001#; + FILE_ATTRIBUTE_HIDDEN : constant := 16#00000002#; + FILE_ATTRIBUTE_SYSTEM : constant := 16#00000004#; + FILE_ATTRIBUTE_DIRECTORY : constant := 16#00000010#; + FILE_ATTRIBUTE_ARCHIVE : constant := 16#00000020#; + FILE_ATTRIBUTE_DEVICE : constant := 16#00000040#; + FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#; + FILE_ATTRIBUTE_TEMPORARY : constant := 16#00000100#; + FILE_ATTRIBUTE_SPARSE_FILE : constant := 16#00000200#; + FILE_ATTRIBUTE_REPARSE_POINT : constant := 16#00000400#; + FILE_ATTRIBUTE_COMPRESSED : constant := 16#00000800#; + FILE_ATTRIBUTE_OFFLINE : constant := 16#00001000#; + FILE_ATTRIBUTE_NOT_CONTENT_INDEXED : constant := 16#00002000#; + FILE_ATTRIBUTE_ENCRYPTED : constant := 16#00004000#; + FILE_ATTRIBUTE_VALID_FLAGS : constant := 16#00007fb7#; + FILE_ATTRIBUTE_VALID_SET_FLAGS : constant := 16#000031a7#; + + GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS : constant := 16#00000004#; + + type OVERLAPPED is record + Internal : DWORD; + InternalHigh : DWORD; + Offset : DWORD; + OffsetHigh : DWORD; + hEvent : HANDLE; + end record; + + type SECURITY_ATTRIBUTES is record + nLength : DWORD; + pSecurityDescriptor : PVOID; + bInheritHandle : BOOL; + end record; + + function CreateFileA + (lpFileName : Address; + dwDesiredAccess : DWORD; + dwShareMode : DWORD; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + dwCreationDisposition : DWORD; + dwFlagsAndAttributes : DWORD; + hTemplateFile : HANDLE) return HANDLE; + pragma Import (Stdcall, CreateFileA, "CreateFileA"); + + function CreateFile + (lpFileName : Address; + dwDesiredAccess : DWORD; + dwShareMode : DWORD; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + dwCreationDisposition : DWORD; + dwFlagsAndAttributes : DWORD; + hTemplateFile : HANDLE) return HANDLE; + pragma Import (Stdcall, CreateFile, "CreateFileW"); + + function GetFileSize + (hFile : HANDLE; + lpFileSizeHigh : access DWORD) return BOOL; + pragma Import (Stdcall, GetFileSize, "GetFileSize"); + + function SetFilePointer + (hFile : HANDLE; + lDistanceToMove : LONG; + lpDistanceToMoveHigh : access LONG; + dwMoveMethod : DWORD) return DWORD; + pragma Import (Stdcall, SetFilePointer, "SetFilePointer"); + + function WriteFile + (hFile : HANDLE; + lpBuffer : Address; + nNumberOfBytesToWrite : DWORD; + lpNumberOfBytesWritten : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, WriteFile, "WriteFile"); + + function ReadFile + (hFile : HANDLE; + lpBuffer : Address; + nNumberOfBytesToRead : DWORD; + lpNumberOfBytesRead : access DWORD; + lpOverlapped : access OVERLAPPED) return BOOL; + pragma Import (Stdcall, ReadFile, "ReadFile"); + + function CloseHandle (hObject : HANDLE) return BOOL; + pragma Import (Stdcall, CloseHandle, "CloseHandle"); + + function CreateFileMapping + (hFile : HANDLE; + lpSecurityAttributes : access SECURITY_ATTRIBUTES; + flProtect : DWORD; + dwMaximumSizeHigh : DWORD; + dwMaximumSizeLow : DWORD; + lpName : Address) return HANDLE; + pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingA"); + + function MapViewOfFile + (hFileMappingObject : HANDLE; + dwDesiredAccess : DWORD; + dwFileOffsetHigh : DWORD; + dwFileOffsetLow : DWORD; + dwNumberOfBytesToMap : DWORD) return System.Address; + pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile"); + + function UnmapViewOfFile (lpBaseAddress : System.Address) return BOOL; + pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile"); + + function MultiByteToWideChar + (CodePage : WORD; + dwFlags : DWORD; + lpMultiByteStr : System.Address; + cchMultiByte : WORD; + lpWideCharStr : System.Address; + cchWideChar : WORD) return WORD; + pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar"); + + ------------------------ + -- System Information -- + ------------------------ + + subtype ProcessorId is DWORD; + + type SYSTEM_INFO is record + dwOemId : DWORD; + dwPageSize : DWORD; + lpMinimumApplicationAddress : PVOID; + lpMaximumApplicationAddress : PVOID; + dwActiveProcessorMask : DWORD; + dwNumberOfProcessors : DWORD; + dwProcessorType : DWORD; + dwAllocationGranularity : DWORD; + dwReserved : DWORD; + end record; + + procedure GetSystemInfo (SI : access SYSTEM_INFO); + pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); + + --------------------- + -- Time Management -- + --------------------- + + type SYSTEMTIME is record + wYear : WORD; + wMonth : WORD; + wDayOfWeek : WORD; + wDay : WORD; + wHour : WORD; + wMinute : WORD; + wSecond : WORD; + wMilliseconds : WORD; + end record; + + procedure GetSystemTime (pSystemTime : access SYSTEMTIME); + pragma Import (Stdcall, GetSystemTime, "GetSystemTime"); + + procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); + pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); + + function FileTimeToSystemTime + (lpFileTime : access Long_Long_Integer; + lpSystemTime : access SYSTEMTIME) return BOOL; + pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime"); + + function SystemTimeToFileTime + (lpSystemTime : access SYSTEMTIME; + lpFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime"); + + function FileTimeToLocalFileTime + (lpFileTime : access Long_Long_Integer; + lpLocalFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime"); + + function LocalFileTimeToFileTime + (lpFileTime : access Long_Long_Integer; + lpLocalFileTime : access Long_Long_Integer) return BOOL; + pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime"); + + procedure Sleep (dwMilliseconds : DWORD); + pragma Import (Stdcall, Sleep, External_Name => "Sleep"); + + function QueryPerformanceCounter + (lpPerformanceCount : access LARGE_INTEGER) return BOOL; + pragma Import + (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); + + ------------ + -- Module -- + ------------ + + function GetModuleHandleEx + (dwFlags : DWORD; + lpModuleName : Address; + phModule : access HANDLE) return BOOL; + pragma Import (Stdcall, GetModuleHandleEx, "GetModuleHandleExA"); + + function GetModuleFileName + (hModule : HANDLE; + lpFilename : Address; + nSize : DWORD) return DWORD; + pragma Import (Stdcall, GetModuleFileName, "GetModuleFileNameA"); + + function FreeLibrary (hModule : HANDLE) return BOOL; + pragma Import (Stdcall, FreeLibrary, "FreeLibrary"); + +end System.Win32; diff --git a/gcc/ada/libgnat/s-winext.ads b/gcc/ada/libgnat/s-winext.ads new file mode 100644 index 0000000..2404994 --- /dev/null +++ b/gcc/ada/libgnat/s-winext.ads @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W I N 3 2 . E X T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package provides the part of the low level Win32 interface which is +-- not supported by RTX (but supported by regular Windows platforms). + +package System.Win32.Ext is + pragma Pure; + + --------------------- + -- Time Management -- + --------------------- + + function QueryPerformanceFrequency + (lpFrequency : access LARGE_INTEGER) return Win32.BOOL; + pragma Import + (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); + + --------------- + -- Processor -- + --------------- + + function SetThreadIdealProcessor + (hThread : HANDLE; + dwIdealProcessor : ProcessorId) return DWORD; + pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor"); + + function SetThreadAffinityMask + (hThread : HANDLE; + dwThreadAffinityMask : DWORD) return DWORD; + pragma Import (Stdcall, SetThreadAffinityMask, "SetThreadAffinityMask"); + + -------------- + -- Com Port -- + -------------- + + DTR_CONTROL_DISABLE : constant := 16#0#; + RTS_CONTROL_DISABLE : constant := 16#0#; + NOPARITY : constant := 0; + ODDPARITY : constant := 1; + EVENPARITY : constant := 2; + ONESTOPBIT : constant := 0; + TWOSTOPBITS : constant := 2; + + type DCB is record + DCBLENGTH : DWORD; + BaudRate : DWORD; + fBinary : Bits1; + fParity : Bits1; + fOutxCtsFlow : Bits1; + fOutxDsrFlow : Bits1; + fDtrControl : Bits2; + fDsrSensitivity : Bits1; + fTXContinueOnXoff : Bits1; + fOutX : Bits1; + fInX : Bits1; + fErrorChar : Bits1; + fNull : Bits1; + fRtsControl : Bits2; + fAbortOnError : Bits1; + fDummy2 : Bits17; + wReserved : WORD; + XonLim : WORD; + XoffLim : WORD; + ByteSize : BYTE; + Parity : BYTE; + StopBits : BYTE; + XonChar : CHAR; + XoffChar : CHAR; + ErrorChar : CHAR; + EofChar : CHAR; + EvtChar : CHAR; + wReserved1 : WORD; + end record; + pragma Convention (C, DCB); + pragma Pack (DCB); + + type COMMTIMEOUTS is record + ReadIntervalTimeout : DWORD; + ReadTotalTimeoutMultiplier : DWORD; + ReadTotalTimeoutConstant : DWORD; + WriteTotalTimeoutMultiplier : DWORD; + WriteTotalTimeoutConstant : DWORD; + end record; + pragma Convention (C, COMMTIMEOUTS); + + function GetCommState + (hFile : HANDLE; + lpDCB : access DCB) return BOOL; + pragma Import (Stdcall, GetCommState, "GetCommState"); + + function SetCommState + (hFile : HANDLE; + lpDCB : access DCB) return BOOL; + pragma Import (Stdcall, SetCommState, "SetCommState"); + + function SetCommTimeouts + (hFile : HANDLE; + lpCommTimeouts : access COMMTIMEOUTS) return BOOL; + pragma Import (Stdcall, SetCommTimeouts, "SetCommTimeouts"); + +end System.Win32.Ext; diff --git a/gcc/ada/libgnat/s-wwdcha.adb b/gcc/ada/libgnat/s-wwdcha.adb new file mode 100644 index 0000000..b206952 --- /dev/null +++ b/gcc/ada/libgnat/s-wwdcha.adb @@ -0,0 +1,74 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +package body System.WWd_Char is + + -------------------------- + -- Wide_Width_Character -- + -------------------------- + + function Wide_Width_Character (Lo, Hi : Character) return Natural is + W : Natural; + + begin + W := 0; + for C in Lo .. Hi loop + declare + S : constant Wide_String := Character'Wide_Image (C); + begin + W := Natural'Max (W, S'Length); + end; + end loop; + + return W; + end Wide_Width_Character; + + ------------------------------- + -- Wide_Wide_Width_Character -- + ------------------------------- + + function Wide_Wide_Width_Character (Lo, Hi : Character) return Natural is + W : Natural; + + begin + W := 0; + for C in Lo .. Hi loop + declare + S : constant String := Character'Image (C); + begin + W := Natural'Max (W, S'Length); + end; + end loop; + + return W; + end Wide_Wide_Width_Character; + +end System.WWd_Char; diff --git a/gcc/ada/libgnat/s-wwdcha.ads b/gcc/ada/libgnat/s-wwdcha.ads new file mode 100644 index 0000000..34046aa --- /dev/null +++ b/gcc/ada/libgnat/s-wwdcha.ads @@ -0,0 +1,45 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains the routine used for Character'Wide_[Wide_]Width + +package System.WWd_Char is + pragma Pure; + + function Wide_Width_Character (Lo, Hi : Character) return Natural; + -- Compute Wide_Width attribute for non-static type derived from + -- Character. The arguments are the low and high bounds for the type. + + function Wide_Wide_Width_Character (Lo, Hi : Character) return Natural; + -- Compute Wide_Wide_Width attribute for non-static type derived from + -- Character. The arguments are the low and high bounds for the type. + +end System.WWd_Char; diff --git a/gcc/ada/libgnat/s-wwdenu.adb b/gcc/ada/libgnat/s-wwdenu.adb new file mode 100644 index 0000000..ce06eda --- /dev/null +++ b/gcc/ada/libgnat/s-wwdenu.adb @@ -0,0 +1,273 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ E N U M -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with System.WCh_StW; use System.WCh_StW; +with System.WCh_Con; use System.WCh_Con; + +with Ada.Unchecked_Conversion; + +package body System.WWd_Enum is + + ----------------------------------- + -- Wide_Wide_Width_Enumeration_8 -- + ----------------------------------- + + function Wide_Wide_Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) return Natural + is + W : Natural; + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + for J in Lo .. Hi loop + declare + S : constant String := + Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1); + WS : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String (S, WS, L, EM); + W := Natural'Max (W, L); + end; + end loop; + + return W; + end Wide_Wide_Width_Enumeration_8; + + ------------------------------------ + -- Wide_Wide_Width_Enumeration_16 -- + ------------------------------------ + + function Wide_Wide_Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) return Natural + is + W : Natural; + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + for J in Lo .. Hi loop + declare + S : constant String := + Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1); + WS : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String (S, WS, L, EM); + W := Natural'Max (W, L); + end; + end loop; + + return W; + end Wide_Wide_Width_Enumeration_16; + + ------------------------------------ + -- Wide_Wide_Width_Enumeration_32 -- + ------------------------------------ + + function Wide_Wide_Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) return Natural + is + W : Natural; + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + for J in Lo .. Hi loop + declare + S : constant String := + Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1); + WS : Wide_Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_Wide_String (S, WS, L, EM); + W := Natural'Max (W, L); + end; + end loop; + + return W; + end Wide_Wide_Width_Enumeration_32; + + ------------------------------ + -- Wide_Width_Enumeration_8 -- + ------------------------------ + + function Wide_Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) return Natural + is + W : Natural; + + type Natural_8 is range 0 .. 2 ** 7 - 1; + type Index_Table is array (Natural) of Natural_8; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + for J in Lo .. Hi loop + declare + S : constant String := + Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1); + WS : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String (S, WS, L, EM); + W := Natural'Max (W, L); + end; + end loop; + + return W; + end Wide_Width_Enumeration_8; + + ------------------------------- + -- Wide_Width_Enumeration_16 -- + ------------------------------- + + function Wide_Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) return Natural + is + W : Natural; + + type Natural_16 is range 0 .. 2 ** 15 - 1; + type Index_Table is array (Natural) of Natural_16; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + for J in Lo .. Hi loop + declare + S : constant String := + Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1); + WS : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String (S, WS, L, EM); + W := Natural'Max (W, L); + end; + end loop; + + return W; + end Wide_Width_Enumeration_16; + + ------------------------------- + -- Wide_Width_Enumeration_32 -- + ------------------------------- + + function Wide_Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : WC_Encoding_Method) return Natural + is + W : Natural; + + type Natural_32 is range 0 .. 2 ** 31 - 1; + type Index_Table is array (Natural) of Natural_32; + type Index_Table_Ptr is access Index_Table; + + function To_Index_Table_Ptr is + new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); + + IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); + + begin + W := 0; + for J in Lo .. Hi loop + declare + S : constant String := + Names (Natural (IndexesT (J)) .. + Natural (IndexesT (J + 1)) - 1); + WS : Wide_String (1 .. S'Length); + L : Natural; + begin + String_To_Wide_String (S, WS, L, EM); + W := Natural'Max (W, L); + end; + end loop; + + return W; + end Wide_Width_Enumeration_32; + +end System.WWd_Enum; diff --git a/gcc/ada/libgnat/s-wwdenu.ads b/gcc/ada/libgnat/s-wwdenu.ads new file mode 100644 index 0000000..47ec49d --- /dev/null +++ b/gcc/ada/libgnat/s-wwdenu.ads @@ -0,0 +1,98 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ E N U M -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines used for Enumeration_Type'Wide_[Wide_]Width + +with System.WCh_Con; + +package System.WWd_Enum is + pragma Pure; + + function Wide_Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) return Natural; + -- Used to compute Enum'Wide_Width where Enum is an enumeration subtype + -- other than those defined in package Standard. Names is a string with + -- a lower bound of 1 containing the characters of all the enumeration + -- literals concatenated together in sequence. Indexes is the address + -- of an array of type array (0 .. N) of Natural_8, where N is the + -- number of enumeration literals in the type. The Indexes values are + -- the starting subscript of each enumeration literal, indexed by Pos + -- values, with an extra entry at the end containing Names'Length + 1. + -- The reason that Indexes is passed by address is that the actual type + -- is created on the fly by the expander. + -- + -- Lo and Hi are the Pos values of the lower and upper bounds of the + -- subtype. The result is the value of Width, i.e. the maximum value + -- of the length of any enumeration literal in the given range. The + -- fifth parameter, EM, is the wide character encoding method used in + -- the Names table. + + function Wide_Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) return Natural; + -- Identical to Wide_Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_16 for the Indexes table. + + function Wide_Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) return Natural; + -- Identical to Wide_Width_Enumeration_8 except that it handles types + -- using array (0 .. Num) of Natural_32 for the Indexes table. + + function Wide_Wide_Width_Enumeration_8 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) return Natural; + -- Same function for Wide_Wide_Width attribute + + function Wide_Wide_Width_Enumeration_16 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) return Natural; + -- Same function for Wide_Wide_Width attribute + + function Wide_Wide_Width_Enumeration_32 + (Names : String; + Indexes : System.Address; + Lo, Hi : Natural; + EM : System.WCh_Con.WC_Encoding_Method) return Natural; + -- Same function for Wide_Wide_Width attribute + +end System.WWd_Enum; diff --git a/gcc/ada/libgnat/s-wwdwch.adb b/gcc/ada/libgnat/s-wwdwch.adb new file mode 100644 index 0000000..abccb03 --- /dev/null +++ b/gcc/ada/libgnat/s-wwdwch.adb @@ -0,0 +1,130 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ W C H A R -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Interfaces; use Interfaces; + +with System.WWd_Char; + +package body System.Wwd_WChar is + + ------------------------------------ + -- Wide_Wide_Width_Wide_Character -- + ------------------------------------ + + -- This is the case where we are talking about the Wide_Wide_Image of + -- a Wide_Character, which is always the same character sequence as the + -- Wide_Image of the same Wide_Character. + + function Wide_Wide_Width_Wide_Character + (Lo, Hi : Wide_Character) return Natural + is + begin + return Wide_Width_Wide_Character (Lo, Hi); + end Wide_Wide_Width_Wide_Character; + + ------------------------------------ + -- Wide_Wide_Width_Wide_Wide_Char -- + ------------------------------------ + + function Wide_Wide_Width_Wide_Wide_Char + (Lo, Hi : Wide_Wide_Character) return Natural + is + LV : constant Unsigned_32 := Wide_Wide_Character'Pos (Lo); + HV : constant Unsigned_32 := Wide_Wide_Character'Pos (Hi); + + begin + -- Return zero if empty range + + if LV > HV then + return 0; + + -- Return max value (12) for wide character (Hex_hhhhhhhh) + + elsif HV > 255 then + return 12; + + -- If any characters in normal character range, then use normal + -- Wide_Wide_Width attribute on this range to find out a starting point. + -- Otherwise start with zero. + + else + return + System.WWd_Char.Wide_Wide_Width_Character + (Lo => Character'Val (LV), + Hi => Character'Val (Unsigned_32'Min (255, HV))); + end if; + end Wide_Wide_Width_Wide_Wide_Char; + + ------------------------------- + -- Wide_Width_Wide_Character -- + ------------------------------- + + function Wide_Width_Wide_Character + (Lo, Hi : Wide_Character) return Natural + is + LV : constant Unsigned_32 := Wide_Character'Pos (Lo); + HV : constant Unsigned_32 := Wide_Character'Pos (Hi); + + begin + -- Return zero if empty range + + if LV > HV then + return 0; + + -- Return max value (12) for wide character (Hex_hhhhhhhh) + + elsif HV > 255 then + return 12; + + -- If any characters in normal character range, then use normal + -- Wide_Wide_Width attribute on this range to find out a starting point. + -- Otherwise start with zero. + + else + return + System.WWd_Char.Wide_Width_Character + (Lo => Character'Val (LV), + Hi => Character'Val (Unsigned_32'Min (255, HV))); + end if; + end Wide_Width_Wide_Character; + + ------------------------------------ + -- Wide_Width_Wide_Wide_Character -- + ------------------------------------ + + function Wide_Width_Wide_Wide_Character + (Lo, Hi : Wide_Wide_Character) return Natural + is + begin + return Wide_Wide_Width_Wide_Wide_Char (Lo, Hi); + end Wide_Width_Wide_Wide_Character; + +end System.Wwd_WChar; diff --git a/gcc/ada/libgnat/s-wwdwch.ads b/gcc/ada/libgnat/s-wwdwch.ads new file mode 100644 index 0000000..f50bba5 --- /dev/null +++ b/gcc/ada/libgnat/s-wwdwch.ads @@ -0,0 +1,61 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M . W W D _ W C H A R -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This package contains routines for [Wide_]Wide_Character'[Wide_]Wide_Width + +package System.Wwd_WChar is + pragma Pure; + + function Wide_Width_Wide_Character + (Lo, Hi : Wide_Character) return Natural; + -- Compute Wide_Width attribute for non-static type derived from + -- Wide_Character. The arguments are the low and high bounds for + -- the type. EM is the wide-character encoding method. + + function Wide_Width_Wide_Wide_Character + (Lo, Hi : Wide_Wide_Character) return Natural; + -- Compute Wide_Width attribute for non-static type derived from + -- Wide_Wide_Character. The arguments are the low and high bounds for + -- the type. EM is the wide-character encoding method. + + function Wide_Wide_Width_Wide_Character + (Lo, Hi : Wide_Character) return Natural; + -- Compute Wide_Wide_Width attribute for non-static type derived from + -- Wide_Character. The arguments are the low and high bounds for + -- the type. EM is the wide-character encoding method. + + function Wide_Wide_Width_Wide_Wide_Char + (Lo, Hi : Wide_Wide_Character) return Natural; + -- Compute Wide_Wide_Width attribute for non-static type derived from + -- Wide_Wide_Character. The arguments are the low and high bounds for + -- the type. EM is the wide-character encoding method. + +end System.Wwd_WChar; diff --git a/gcc/ada/libgnat/sequenio.ads b/gcc/ada/libgnat/sequenio.ads new file mode 100644 index 0000000..ad1d7fa1 --- /dev/null +++ b/gcc/ada/libgnat/sequenio.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S E Q U E N T I A L _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and Sequential_IO is not +-- considered to be an internal unit that is automatically compiled in Ada +-- 2012 mode (since a user is allowed to redeclare Sequential_IO). + +with Ada.Sequential_IO; + +generic package Sequential_IO renames Ada.Sequential_IO; diff --git a/gcc/ada/libgnat/system-aix.ads b/gcc/ada/libgnat/system-aix.ads new file mode 100644 index 0000000..3a38143 --- /dev/null +++ b/gcc/ada/libgnat/system-aix.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (AIX/PPC Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 126 corresponds to the system priority range 1 .. 127. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and that is the only value ever passed to the system, regardless of + -- how priorities are set by user programs. + + Max_Priority : constant Positive := 125; + Max_Interrupt_Priority : constant Positive := 126; + + subtype Any_Priority is Integer range 0 .. 126; + subtype Priority is Any_Priority range 0 .. 125; + subtype Interrupt_Priority is Any_Priority range 126 .. 126; + + Default_Priority : constant Priority := + (Priority'First + Priority'Last) / 2; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-darwin-arm.ads b/gcc/ada/libgnat/system-darwin-arm.ads new file mode 100644 index 0000000..620ff1b --- /dev/null +++ b/gcc/ada/libgnat/system-darwin-arm.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/ARM Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- The values defined here are derived from the following Darwin + -- sources: + -- + -- Libc/pthreads/pthread.c + -- pthread_init calls host_info to retrieve the HOST_PRIORITY_INFO. + -- This file includes "pthread_internals". + -- Libc/pthreads/pthread_internals.h + -- This file includes . + -- xnu/osfmk/mach/mach.h + -- This file includes . + -- xnu/osfmk/mach/mach_types.h + -- This file includes . + -- xnu/osfmk/mach/host_info.h + -- This file contains the definition of the host_info_t data structure + -- and the function prototype for host_info. + -- xnu/osfmk/kern/host.c + -- This file defines the function host_info which sets the + -- priority_info field of struct host_info_t. This file includes + -- . + -- xnu/osfmk/kern/processor.h + -- This file includes . + -- xnu/osfmk/kern/sched.h + -- This file defines the values for each level of priority. + + Max_Interrupt_Priority : constant Positive := 63; + Max_Priority : constant Positive := Max_Interrupt_Priority - 1; + + subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; + subtype Priority is Any_Priority range 0 .. Max_Priority; + subtype Interrupt_Priority is Any_Priority + range Priority'Last + 1 .. Max_Interrupt_Priority; + + Default_Priority : constant Priority := + (Priority'Last - Priority'First) / 2; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-darwin-ppc.ads b/gcc/ada/libgnat/system-darwin-ppc.ads new file mode 100644 index 0000000..675402f --- /dev/null +++ b/gcc/ada/libgnat/system-darwin-ppc.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/PPC Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- The values defined here are derived from the following Darwin + -- sources: + -- + -- Libc/pthreads/pthread.c + -- pthread_init calls host_info to retrieve the HOST_PRIORITY_INFO. + -- This file includes "pthread_internals". + -- Libc/pthreads/pthread_internals.h + -- This file includes . + -- xnu/osfmk/mach/mach.h + -- This file includes . + -- xnu/osfmk/mach/mach_types.h + -- This file includes . + -- xnu/osfmk/mach/host_info.h + -- This file contains the definition of the host_info_t data structure + -- and the function prototype for host_info. + -- xnu/osfmk/kern/host.c + -- This file defines the function host_info which sets the + -- priority_info field of struct host_info_t. This file includes + -- . + -- xnu/osfmk/kern/processor.h + -- This file includes . + -- xnu/osfmk/kern/sched.h + -- This file defines the values for each level of priority. + + Max_Interrupt_Priority : constant Positive := 63; + Max_Priority : constant Positive := Max_Interrupt_Priority - 1; + + subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; + subtype Priority is Any_Priority range 0 .. Max_Priority; + subtype Interrupt_Priority is Any_Priority + range Priority'Last + 1 .. Max_Interrupt_Priority; + + Default_Priority : constant Priority := + (Priority'Last - Priority'First) / 2; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := Word_Size = 64; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-darwin-x86.ads b/gcc/ada/libgnat/system-darwin-x86.ads new file mode 100644 index 0000000..7f3b350 --- /dev/null +++ b/gcc/ada/libgnat/system-darwin-x86.ads @@ -0,0 +1,174 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Darwin/x86 Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- The values defined here are derived from the following Darwin + -- sources: + -- + -- Libc/pthreads/pthread.c + -- pthread_init calls host_info to retrieve the HOST_PRIORITY_INFO. + -- This file includes "pthread_internals". + -- Libc/pthreads/pthread_internals.h + -- This file includes . + -- xnu/osfmk/mach/mach.h + -- This file includes . + -- xnu/osfmk/mach/mach_types.h + -- This file includes . + -- xnu/osfmk/mach/host_info.h + -- This file contains the definition of the host_info_t data structure + -- and the function prototype for host_info. + -- xnu/osfmk/kern/host.c + -- This file defines the function host_info which sets the + -- priority_info field of struct host_info_t. This file includes + -- . + -- xnu/osfmk/kern/processor.h + -- This file includes . + -- xnu/osfmk/kern/sched.h + -- This file defines the values for each level of priority. + + Max_Interrupt_Priority : constant Positive := 63; + Max_Priority : constant Positive := Max_Interrupt_Priority - 1; + + subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; + subtype Priority is Any_Priority range 0 .. Max_Priority; + subtype Interrupt_Priority is Any_Priority + range Priority'Last + 1 .. Max_Interrupt_Priority; + + Default_Priority : constant Priority := + (Priority'Last - Priority'First) / 2; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-djgpp.ads b/gcc/ada/libgnat/system-djgpp.ads new file mode 100644 index 0000000..4b0ecd9 --- /dev/null +++ b/gcc/ada/libgnat/system-djgpp.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (DJGPP Version) -- +-- -- +-- Copyright (C) 1992-2016, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := False; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-dragonfly-x86_64.ads b/gcc/ada/libgnat/system-dragonfly-x86_64.ads new file mode 100644 index 0000000..2648b20 --- /dev/null +++ b/gcc/ada/libgnat/system-dragonfly-x86_64.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (DragonFly BSD/x86_64 Version) -- +-- -- +-- Copyright (C) 1992-2015, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-freebsd.ads b/gcc/ada/libgnat/system-freebsd.ads new file mode 100644 index 0000000..4b71e38 --- /dev/null +++ b/gcc/ada/libgnat/system-freebsd.ads @@ -0,0 +1,149 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (FreeBSD Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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 := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-hpux-ia64.ads b/gcc/ada/libgnat/system-hpux-ia64.ads new file mode 100644 index 0000000..975ce90 --- /dev/null +++ b/gcc/ada/libgnat/system-hpux-ia64.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (HP-UX/ia64 Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-hpux.ads b/gcc/ada/libgnat/system-hpux.ads new file mode 100644 index 0000000..c068c92 --- /dev/null +++ b/gcc/ada/libgnat/system-hpux.ads @@ -0,0 +1,223 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (HP-UX Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + -------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + -- For HP/UX DCE Threads, we use the full range of 31 priorities + -- in the Ada model, but map them by compression onto the more limited + -- range of priorities available in HP/UX. + -- For POSIX Threads, this table is ignored. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile with the command: + + -- $ gcc -c -O2 -gnatpgn system.ads + + -- then recompile the run-time parts that depend on this package: + + -- $ gnatmake -a -gnatn -O2 + + -- then force rebuilding your application if you need different options: + + -- $ gnatmake -f + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + + (Priority'First => 16, + + 1 => 17, + 2 => 18, + 3 => 18, + 4 => 18, + 5 => 18, + 6 => 19, + 7 => 19, + 8 => 19, + 9 => 20, + 10 => 20, + 11 => 21, + 12 => 21, + 13 => 22, + 14 => 23, + + Default_Priority => 24, + + 16 => 25, + 17 => 25, + 18 => 25, + 19 => 26, + 20 => 26, + 21 => 26, + 22 => 27, + 23 => 27, + 24 => 27, + 25 => 28, + 26 => 28, + 27 => 29, + 28 => 29, + 29 => 30, + + Priority'Last => 30, + + Interrupt_Priority => 31); + +end System; diff --git a/gcc/ada/libgnat/system-linux-alpha.ads b/gcc/ada/libgnat/system-linux-alpha.ads new file mode 100644 index 0000000..274e894 --- /dev/null +++ b/gcc/ada/libgnat/system-linux-alpha.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/alpha Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 / 1024.0; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-arm.ads b/gcc/ada/libgnat/system-linux-arm.ads new file mode 100644 index 0000000..e36f38d --- /dev/null +++ b/gcc/ada/libgnat/system-linux-arm.ads @@ -0,0 +1,157 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/ARM Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Long_Integer'Size; + + -- 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 := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-hppa.ads b/gcc/ada/libgnat/system-linux-hppa.ads new file mode 100644 index 0000000..5a7c80b --- /dev/null +++ b/gcc/ada/libgnat/system-linux-hppa.ads @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU/Linux-HPPA Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-ia64.ads b/gcc/ada/libgnat/system-linux-ia64.ads new file mode 100644 index 0000000..65d2a77 --- /dev/null +++ b/gcc/ada/libgnat/system-linux-ia64.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/ia64 Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-m68k.ads b/gcc/ada/libgnat/system-linux-m68k.ads new file mode 100644 index 0000000..71d4f57 --- /dev/null +++ b/gcc/ada/libgnat/system-linux-m68k.ads @@ -0,0 +1,158 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU/Linux/m68k Version) -- +-- -- +-- Copyright (C) 2014-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Is the following actually true for GNU/Linux/m68k? + -- + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-mips.ads b/gcc/ada/libgnat/system-linux-mips.ads new file mode 100644 index 0000000..f165c94 --- /dev/null +++ b/gcc/ada/libgnat/system-linux-mips.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/MIPS Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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 := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-ppc.ads b/gcc/ada/libgnat/system-linux-ppc.ads new file mode 100644 index 0000000..367d09f --- /dev/null +++ b/gcc/ada/libgnat/system-linux-ppc.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/PPC Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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 := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-s390.ads b/gcc/ada/libgnat/system-linux-s390.ads new file mode 100644 index 0000000..9bf8375 --- /dev/null +++ b/gcc/ada/libgnat/system-linux-s390.ads @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/s390 Version) -- +-- -- +-- Copyright (C) 1992-2016, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Long_Integer'Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-sh4.ads b/gcc/ada/libgnat/system-linux-sh4.ads new file mode 100644 index 0000000..43828bf --- /dev/null +++ b/gcc/ada/libgnat/system-linux-sh4.ads @@ -0,0 +1,155 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/sh4 Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-sparc.ads b/gcc/ada/libgnat/system-linux-sparc.ads new file mode 100644 index 0000000..8227a0d --- /dev/null +++ b/gcc/ada/libgnat/system-linux-sparc.ads @@ -0,0 +1,147 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU/Linux-SPARC Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-linux-x86.ads b/gcc/ada/libgnat/system-linux-x86.ads new file mode 100644 index 0000000..533d94e --- /dev/null +++ b/gcc/ada/libgnat/system-linux-x86.ads @@ -0,0 +1,156 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (GNU-Linux/x86 Version) -- +-- -- +-- Copyright (C) 1992-2016, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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.000_001; + + -- Storage-related Declarations + + type Address is private; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Long_Integer'Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- 0 .. 98 corresponds to the system priority range 1 .. 99. + -- + -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use + -- of the entire range provided by the system. + -- + -- If the scheduling policy is SCHED_OTHER the only valid system priority + -- is 1 and other values are simply ignored. + + Max_Priority : constant Positive := 97; + Max_Interrupt_Priority : constant Positive := 98; + + subtype Any_Priority is Integer range 0 .. 98; + subtype Priority is Any_Priority range 0 .. 97; + subtype Interrupt_Priority is Any_Priority range 98 .. 98; + + Default_Priority : constant Priority := 48; + +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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-mingw.ads b/gcc/ada/libgnat/system-mingw.ads new file mode 100644 index 0000000..3aeaa23 --- /dev/null +++ b/gcc/ada/libgnat/system-mingw.ads @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Windows Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + --------------------------- + -- Underlying Priorities -- + --------------------------- + + -- Important note: this section of the file must come AFTER the + -- definition of the system implementation parameters to ensure + -- that the value of these parameters is available for analysis + -- of the declarations here (using Rtsfind at compile time). + + -- The underlying priorities table provides a generalized mechanism + -- for mapping from Ada priorities to system priorities. In some + -- cases a 1-1 mapping is not the convenient or optimal choice. + + type Priorities_Mapping is array (Any_Priority) of Integer; + pragma Suppress_Initialization (Priorities_Mapping); + -- Suppress initialization in case gnat.adc specifies Normalize_Scalars + + Underlying_Priorities : constant Priorities_Mapping := + (Priority'First .. + Default_Priority - 8 => -15, + Default_Priority - 7 => -7, + Default_Priority - 6 => -6, + Default_Priority - 5 => -5, + Default_Priority - 4 => -4, + Default_Priority - 3 => -3, + Default_Priority - 2 => -2, + Default_Priority - 1 => -1, + Default_Priority => 0, + Default_Priority + 1 => 1, + Default_Priority + 2 => 2, + Default_Priority + 3 => 3, + Default_Priority + 4 => 4, + Default_Priority + 5 => 5, + Default_Priority + 6 .. + Priority'Last => 6, + Interrupt_Priority => 15); + -- The default mapping preserves the standard 31 priorities of the Ada + -- model, but maps them using compression onto the 7 priority levels + -- available in NT and on the 16 priority levels available in 2000/XP. + + -- To replace the default values of the Underlying_Priorities mapping, + -- copy this source file into your build directory, edit the file to + -- reflect your desired behavior, and recompile using Makefile.adalib + -- which can be found under the adalib directory of your gnat installation + + pragma Linker_Options ("-Wl,--stack=0x2000000"); + -- This is used to change the default stack (32 MB) size for non tasking + -- programs. We change this value for GNAT on Windows here because the + -- binutils on this platform have switched to a too low value for Ada + -- programs. Note that we also set the stack size for tasking programs in + -- System.Task_Primitives.Operations. + +end System; diff --git a/gcc/ada/libgnat/system-rtems.ads b/gcc/ada/libgnat/system-rtems.ads new file mode 100644 index 0000000..ce1ce2b --- /dev/null +++ b/gcc/ada/libgnat/system-rtems.ads @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Compiler Version) -- +-- -- +-- Copyright (C) 1992-2016 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 RTEMS. It is based as closely as possible on the +-- generic version with the following exceptions: +-- + priority definitions + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := Standard'Storage_Unit; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Standard'Address_Size; + + -- 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 := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- RTEMS POSIX threads support 256 priority levels with 255 being + -- logically the most important. Levels 0 and 255 are reserved. + -- + -- 255 is reserved for RTEMS system tasks + -- 247 - 254 correspond to hardware interrupt levels 0 .. 7 + -- 246 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. + -- 245 is used by the Interrupt_Manager task + -- 0 is reserved for the RTEMS IDLE task and really should not + -- be accessible from Ada but GNAT initializes + -- Current_Priority to 0 so it must be valid + + Max_Priority : constant Positive := 244; + Max_Interrupt_Priority : constant Positive := 254; + + subtype Any_Priority is Integer range 0 .. 254; + subtype Priority is Any_Priority range 0 .. 244; + subtype Interrupt_Priority is Any_Priority range 245 .. 254; + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + +end System; diff --git a/gcc/ada/libgnat/system-solaris-sparc.ads b/gcc/ada/libgnat/system-solaris-sparc.ads new file mode 100644 index 0000000..7391ca6 --- /dev/null +++ b/gcc/ada/libgnat/system-solaris-sparc.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (SUN Solaris Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-solaris-x86.ads b/gcc/ada/libgnat/system-solaris-x86.ads new file mode 100644 index 0000000..f600aec --- /dev/null +++ b/gcc/ada/libgnat/system-solaris-x86.ads @@ -0,0 +1,148 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (x86 Solaris Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads new file mode 100644 index 0000000..b51f998 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-arm-rtp-smp.ads @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6.x ARM RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-smp-arm-link.spec"); + pragma Linker_Options ("--specs=vxworks-arm-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-arm-rtp.ads b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads new file mode 100644 index 0000000..c29bc00 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-arm-rtp.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6.x ARM RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-arm-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-arm.ads b/gcc/ada/libgnat/system-vxworks-arm.ads new file mode 100644 index 0000000..8088444 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-arm.ads @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version ARM) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-e500-kernel.ads b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads new file mode 100644 index 0000000..7fa7cc5 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-e500-kernel.ads @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6 Kernel Version E500) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + -- MPC8548ECE Chip Errata Rev 8: signed zero not reliable + Signed_Zeros : constant Boolean := False; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads new file mode 100644 index 0000000..b739d12 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-e500-rtp-smp.ads @@ -0,0 +1,173 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6.x SMP E500 RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks SMP version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-smp-e500-link.spec"); + pragma Linker_Options ("--specs=vxworks-e500-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + -- MPC8548ECE Chip Errata Rev 8: signed zero not reliable + Signed_Zeros : constant Boolean := False; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-e500-rtp.ads b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads new file mode 100644 index 0000000..c308a45 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-e500-rtp.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6.x E500 RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-e500-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-e500-vthread.ads b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads new file mode 100644 index 0000000..2579f47 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-e500-vthread.ads @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks e500 AE653 vThreads) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 the AE653/e500v2 vThreads full run-time + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads new file mode 100644 index 0000000..4ac597e --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-ppc-kernel.ads @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6 Kernel Version PPC) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads new file mode 100644 index 0000000..24d7e46 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-ppc-ravenscar.ads @@ -0,0 +1,187 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks/HIE Ravenscar Version PPC) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is a Ravenscar VxWorks version of this package for PowerPC targets + +pragma Restrictions (No_Exception_Propagation); +-- Only local exception handling is supported in this profile + +pragma Restrictions (No_Exception_Registration); +-- Disable exception name registration. This capability is not used because +-- it is only required by exception stream attributes which are not supported +-- in this run time. + +pragma Restrictions (No_Implicit_Dynamic_Code); +-- Pointers to nested subprograms are not allowed in this run time, in order +-- to prevent the compiler from building "trampolines". + +pragma Restrictions (No_Finalization); +-- Controlled types are not supported in this run time + +pragma Profile (Ravenscar); +-- This is a Ravenscar run time + +pragma Discard_Names; +-- Disable explicitly the generation of names associated with entities in +-- order to reduce the amount of storage used. These names are not used anyway +-- (attributes such as 'Image and 'Value are not supported in this run time). + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := True; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := True; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads new file mode 100644 index 0000000..7d2cd51 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp-smp.ads @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6.x SMP PPC RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks SMP version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-smp-ppc-link.spec"); + pragma Linker_Options ("--specs=vxworks-ppc-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads new file mode 100644 index 0000000..a427f8d --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-ppc-rtp.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6.x PPC RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-ppc-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads new file mode 100644 index 0000000..cad1268 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-ppc-vthread.ads @@ -0,0 +1,164 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks PPC AE653 vThreads) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 the AE653 vThreads full run-time + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := True; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc.ads b/gcc/ada/libgnat/system-vxworks-ppc.ads new file mode 100644 index 0000000..9299485 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-ppc.ads @@ -0,0 +1,169 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 5 Version PPC) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-ppc-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-ppc64-kernel.ads b/gcc/ada/libgnat/system-vxworks-ppc64-kernel.ads new file mode 100644 index 0000000..be4aebf --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-ppc64-kernel.ads @@ -0,0 +1,168 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7.x PPC64 Kernel) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks 7.x version of this package for PPC64 Kernel + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads new file mode 100644 index 0000000..aeac6c5 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-x86-kernel.ads @@ -0,0 +1,170 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 6 Kernel Version x86) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-x86-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads new file mode 100644 index 0000000..5e385be --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-x86-rtp-smp.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version x86 for SMP RTPs) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-smp-x86-link.spec"); + pragma Linker_Options ("--specs=vxworks-x86-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86-rtp.ads b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads new file mode 100644 index 0000000..8600123 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-x86-rtp.ads @@ -0,0 +1,170 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version x86 for RTPs) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks-x86-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86-vthread.ads b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads new file mode 100644 index 0000000..cb74f23 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-x86-vthread.ads @@ -0,0 +1,165 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 653 x86 vThreads) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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 the AE653 vThreads full run-time + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := True; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := False; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks-x86.ads b/gcc/ada/libgnat/system-vxworks-x86.ads new file mode 100644 index 0000000..30e7be5 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks-x86.ads @@ -0,0 +1,166 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 5 Version x86) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-x86-link.spec"); + -- Setup proper set of -L's for this configuration + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : constant Boolean := True; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := True; + ZCX_By_Default : constant Boolean := False; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads new file mode 100644 index 0000000..8b96e23 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-arm-rtp-smp.ads @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7 ARM RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- In particular, you can freely distribute your programs built with the -- +-- GNAT Pro compiler, including any required library run-time units, using -- +-- any licensing terms of your choosing. See the AdaCore Software License -- +-- for full details. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks7-rtp-base-link.spec"); + -- Define the symbol wrs_rtp_base + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-arm.ads b/gcc/ada/libgnat/system-vxworks7-arm.ads new file mode 100644 index 0000000..51c7e75 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-arm.ads @@ -0,0 +1,162 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks Version ARM) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads new file mode 100644 index 0000000..83708da --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-e500-rtp-smp.ads @@ -0,0 +1,172 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7.x E500 RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks7-rtp-base-link.spec"); + -- Define the symbol wrs_rtp_base + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + -- MPC8548ECE Chip Errata Rev 8: signed zero not reliable + Signed_Zeros : constant Boolean := False; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads new file mode 100644 index 0000000..63603fc --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-ppc-rtp-smp.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7.x PPC RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks version of this package for RTPs + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks7-rtp-base-link.spec"); + -- Define the symbol wrs_rtp_base + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads new file mode 100644 index 0000000..8a97086 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-ppc64-rtp-smp.ads @@ -0,0 +1,171 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7.x PPC64 RTP) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This is the VxWorks 7.x version of this package for PPC64 RTP + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := 64; + Memory_Size : constant := 2 ** 64; + + -- Address comparison + + function "<" (Left, Right : Address) return Boolean; + function "<=" (Left, Right : Address) return Boolean; + function ">" (Left, Right : Address) return Boolean; + function ">=" (Left, Right : Address) return Boolean; + function "=" (Left, Right : Address) return Boolean; + + pragma Import (Intrinsic, "<"); + pragma Import (Intrinsic, "<="); + pragma Import (Intrinsic, ">"); + pragma Import (Intrinsic, ">="); + pragma Import (Intrinsic, "="); + + -- Other System-Dependent Declarations + + type Bit_Order is (High_Order_First, Low_Order_First); + Default_Bit_Order : constant Bit_Order := High_Order_First; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks7-ppc64-rtp-base-link.spec"); + -- Define the symbol wrs_rtp_base + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads new file mode 100644 index 0000000..e186023 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-x86-kernel.ads @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7 Kernel Version x86) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads new file mode 100644 index 0000000..a5ea929 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-x86-rtp-smp.ads @@ -0,0 +1,170 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7 Version x86 for RTPs) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks7-x86-rtp-base-link.spec"); + -- Define the symbol wrs_rtp_base + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads new file mode 100644 index 0000000..257ef26 --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-kernel.ads @@ -0,0 +1,167 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7 Kernel Version x86_64) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := True; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".out"; + +end System; diff --git a/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads new file mode 100644 index 0000000..e97588e --- /dev/null +++ b/gcc/ada/libgnat/system-vxworks7-x86_64-rtp-smp.ads @@ -0,0 +1,170 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (VxWorks 7 Version x86_64 for RTPs) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- 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; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + pragma Preelaborable_Initialization (Address); + Null_Address : constant Address; + + Storage_Unit : constant := 8; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Word_Size; + + -- 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; + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- Priority-related Declarations (RM D.1) + + -- Ada priorities are mapped to VxWorks priorities using the following + -- transformation: 255 - Ada Priority + + -- Ada priorities are used as follows: + + -- 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 + + pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); + -- Pull in crtbegin/crtend objects and register exceptions for ZCX. + -- This is commented out by our Makefile for SJLJ runtimes. + + pragma Linker_Options ("--specs=vxworks7-x86_64-rtp-base-link.spec"); + -- Define the symbol wrs_rtp_base + + 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. + + Backend_Divide_Checks : constant Boolean := False; + Backend_Overflow_Checks : constant Boolean := True; + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := True; + Stack_Check_Limits : constant Boolean := False; + Support_Aggregates : constant Boolean := True; + Support_Atomic_Primitives : constant Boolean := True; + Support_Composite_Assign : constant Boolean := True; + Support_Composite_Compare : constant Boolean := True; + Support_Long_Shifts : constant Boolean := True; + Always_Compatible_Rep : constant Boolean := False; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + Executable_Extension : constant String := ".vxe"; + +end System; diff --git a/gcc/ada/libgnat/system.ads b/gcc/ada/libgnat/system.ads new file mode 100644 index 0000000..c35ee7c --- /dev/null +++ b/gcc/ada/libgnat/system.ads @@ -0,0 +1,178 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- S Y S T E M -- +-- -- +-- S p e c -- +-- (Compiler Version) -- +-- -- +-- Copyright (C) 1992-2017, 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 3, 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. -- +-- -- +-- As a special exception under Section 7 of GPL version 3, you are granted -- +-- additional permissions described in the GCC Runtime Library Exception, -- +-- version 3.1, as published by the Free Software Foundation. -- +-- -- +-- You should have received a copy of the GNU General Public License and -- +-- a copy of the GCC Runtime Library Exception along with this program; -- +-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- +-- . -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- This version of System is a generic version that is used in building the +-- compiler. Right now, we have a host/target problem if we try to use the +-- "proper" System, and since the compiler itself does not care about most +-- System parameters, this generic version works fine. + +pragma Restrictions (No_Implicit_Dynamic_Code); +-- We want to avoid trampolines in the compiler, so it can be used in systems +-- which prevent execution of code on the stack, e.g. in windows environments +-- with DEP (Data Execution Protection) enabled. + +package System is + pragma Pure; + -- Note that we take advantage of the implementation permission to make + -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada + -- 2005, this is Pure in any case (AI-362). + + pragma No_Elaboration_Code_All; + -- Allow the use of that restriction in units that WITH this unit + + 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 := 2 ** Integer'Size - 1; + + 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; + -- Note that we do NOT add pragma Preelaborable_Initialization in this + -- version of System, since it is used for the compiler only, and typical + -- earlier bootstrap compilers don't support this pragma. We don't need + -- it in this context, so there is no problem in omitting it. + Null_Address : constant Address; + + Storage_Unit : constant := Standard'Storage_Unit; + Word_Size : constant := Standard'Word_Size; + Memory_Size : constant := 2 ** Standard'Address_Size; + + -- 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 := + Bit_Order'Val (Standard'Default_Bit_Order); + pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning + + -- 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. + + -- This version of system.ads is used only for building the compiler. + -- We really ought to use the proper target system (i.e. the one that + -- corresponds to the host for the compiler), but that causes as yet + -- unsolved makefile problems. For the most part the setting of these + -- parameters is not too critical for the compiler version (e.g. we + -- do not use floating-point anyway in the compiler). + + 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; + Machine_Overflows : constant Boolean := False; + Machine_Rounds : constant Boolean := True; + Preallocated_Stacks : constant Boolean := False; + Signed_Zeros : constant Boolean := True; + Stack_Check_Default : constant Boolean := False; + Stack_Check_Probes : constant Boolean := False; + Stack_Check_Limits : 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; + Always_Compatible_Rep : constant Boolean := True; + Suppress_Standard_Library : constant Boolean := False; + Use_Ada_Main_Program_Name : constant Boolean := False; + Frontend_Exceptions : constant Boolean := False; + ZCX_By_Default : constant Boolean := True; + + -- Obsolete entries, to be removed eventually (bootstrap issues) + + Front_End_ZCX_Support : constant Boolean := False; + High_Integrity_Mode : constant Boolean := False; + Long_Shifts_Inlined : constant Boolean := True; + Functions_Return_By_DSP : constant Boolean := False; + Support_64_Bit_Divides : constant Boolean := True; + GCC_ZCX_Support : constant Boolean := True; + +end System; diff --git a/gcc/ada/libgnat/text_io.ads b/gcc/ada/libgnat/text_io.ads new file mode 100644 index 0000000..4c67d8d --- /dev/null +++ b/gcc/ada/libgnat/text_io.ads @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT RUN-TIME COMPONENTS -- +-- -- +-- T E X T _ I O -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +pragma Ada_2012; +-- Explicit setting of Ada 2012 mode is required here, since we want to with a +-- child unit (not possible in Ada 83 mode), and Text_IO is not considered to +-- be an internal unit that is automatically compiled in Ada 2012 mode (since +-- a user is allowed to redeclare Text_IO). + +with Ada.Text_IO; + +package Text_IO renames Ada.Text_IO; diff --git a/gcc/ada/libgnat/unchconv.ads b/gcc/ada/libgnat/unchconv.ads new file mode 100644 index 0000000..7937020 --- /dev/null +++ b/gcc/ada/libgnat/unchconv.ads @@ -0,0 +1,22 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N C H E C K E D _ C O N V E R S I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Source (<>) is limited private; + type Target (<>) is limited private; + +function Unchecked_Conversion (S : Source) return Target; +pragma Import (Intrinsic, Unchecked_Conversion); +pragma Pure (Unchecked_Conversion); diff --git a/gcc/ada/libgnat/unchdeal.ads b/gcc/ada/libgnat/unchdeal.ads new file mode 100644 index 0000000..4735a52 --- /dev/null +++ b/gcc/ada/libgnat/unchdeal.ads @@ -0,0 +1,21 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- U N C H E C K E D _ D E A L L O C A T I O N -- +-- -- +-- S p e c -- +-- -- +-- This specification is derived from the Ada Reference Manual for use with -- +-- GNAT. In accordance with the copyright of that document, you can freely -- +-- copy and modify this specification, provided that if you redistribute a -- +-- modified version, any changes that you have made are clearly indicated. -- +-- -- +------------------------------------------------------------------------------ + +generic + type Object (<>) is limited private; + type Name is access Object; + +procedure Unchecked_Deallocation (X : in out Name); +pragma Import (Intrinsic, Unchecked_Deallocation); diff --git a/gcc/ada/machcode.ads b/gcc/ada/machcode.ads deleted file mode 100644 index 55e1ae5..0000000 --- a/gcc/ada/machcode.ads +++ /dev/null @@ -1,18 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- M A C H I N E _ C O D E -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -with System.Machine_Code; - -package Machine_Code renames System.Machine_Code; diff --git a/gcc/ada/memtrack.adb b/gcc/ada/memtrack.adb deleted file mode 100644 index 869990d..0000000 --- a/gcc/ada/memtrack.adb +++ /dev/null @@ -1,401 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version contains allocation tracking capability - --- The object file corresponding to this instrumented version is to be found --- in libgmem. - --- When enabled, the subsystem logs all the calls to __gnat_malloc and --- __gnat_free. This log can then be processed by gnatmem to detect --- dynamic memory leaks. - --- To use this functionality, you must compile your application with -g --- and then link with this object file: - --- gnatmake -g program -largs -lgmem - --- After compilation, you may use your program as usual except that upon --- completion, it will generate in the current directory the file gmem.out. - --- You can then investigate for possible memory leaks and mismatch by calling --- gnatmem with this file as an input: - --- gnatmem -i gmem.out program - --- See gnatmem section in the GNAT User's Guide for more details - --- NOTE: This capability is currently supported on the following targets: - --- Windows --- AIX --- GNU/Linux --- HP-UX --- Solaris - --- NOTE FOR FUTURE PLATFORMS SUPPORT: It is assumed that type Duration is --- 64 bit. If the need arises to support architectures where this assumption --- is incorrect, it will require changing the way timestamps of allocation --- events are recorded. - -pragma Source_File_Name (System.Memory, Body_File_Name => "memtrack.adb"); - -with Ada.Exceptions; -with System.Soft_Links; -with System.Traceback; -with System.Traceback_Entries; -with GNAT.IO; -with System.OS_Primitives; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - use System.Traceback; - use System.Traceback_Entries; - use GNAT.IO; - - function c_malloc (Size : size_t) return System.Address; - pragma Import (C, c_malloc, "malloc"); - - procedure c_free (Ptr : System.Address); - pragma Import (C, c_free, "free"); - - function c_realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, c_realloc, "realloc"); - - subtype File_Ptr is System.Address; - - function fopen (Path : String; Mode : String) return File_Ptr; - pragma Import (C, fopen); - - procedure OS_Exit (Status : Integer); - pragma Import (C, OS_Exit, "__gnat_os_exit"); - pragma No_Return (OS_Exit); - - 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); - - procedure Finalize; - pragma Export (C, Finalize, "__gnat_finalize"); - -- Replace the default __gnat_finalize to properly close the log file - - Address_Size : constant := System.Address'Max_Size_In_Storage_Elements; - -- Size in bytes of a pointer - - Max_Call_Stack : constant := 200; - -- Maximum number of frames supported - - Tracebk : Tracebacks_Array (1 .. Max_Call_Stack); - Num_Calls : aliased Integer := 0; - - Gmemfname : constant String := "gmem.out" & ASCII.NUL; - -- Allocation log of a program is saved in a file gmem.out - -- ??? What about Ada.Command_Line.Command_Name & ".out" instead of static - -- gmem.out - - Gmemfile : File_Ptr; - -- Global C file pointer to the allocation log - - Needs_Init : Boolean := True; - -- Reset after first call to Gmem_Initialize - - procedure Gmem_Initialize; - -- Initialization routine; opens the file and writes a header string. This - -- header string is used as a magic-tag to know if the .out file is to be - -- handled by GDB or by the GMEM (instrumented malloc/free) implementation. - - First_Call : Boolean := True; - -- Depending on implementation, some of the traceback routines may - -- themselves do dynamic allocation. We use First_Call flag to avoid - -- infinite recursion - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : aliased System.Address; - Actual_Size : aliased size_t := Size; - Timestamp : aliased Duration; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - Lock_Task.all; - - Result := c_malloc (Actual_Size); - - if First_Call then - - -- Logs allocation call - -- format is: - -- 'A' ... - - First_Call := False; - - if Needs_Init then - Gmem_Initialize; - end if; - - Timestamp := System.OS_Primitives.Clock; - Call_Chain - (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); - fputc (Character'Pos ('A'), Gmemfile); - fwrite (Result'Address, Address_Size, 1, Gmemfile); - fwrite (Actual_Size'Address, size_t'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); - - for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop - declare - Ptr : System.Address := PC_For (Tracebk (J)); - begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); - end; - end loop; - - First_Call := True; - - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize is - begin - if not Needs_Init then - fclose (Gmemfile); - end if; - end Finalize; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - Addr : aliased constant System.Address := Ptr; - Timestamp : aliased Duration; - - begin - Lock_Task.all; - - if First_Call then - - -- Logs deallocation call - -- format is: - -- 'D' ... - - First_Call := False; - - if Needs_Init then - Gmem_Initialize; - end if; - - Call_Chain - (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); - Timestamp := System.OS_Primitives.Clock; - fputc (Character'Pos ('D'), Gmemfile); - fwrite (Addr'Address, Address_Size, 1, Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); - - for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop - declare - Ptr : System.Address := PC_For (Tracebk (J)); - begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); - end; - end loop; - - c_free (Ptr); - - First_Call := True; - end if; - - Unlock_Task.all; - end Free; - - --------------------- - -- Gmem_Initialize -- - --------------------- - - procedure Gmem_Initialize is - Timestamp : aliased Duration; - - begin - if Needs_Init then - Needs_Init := False; - System.OS_Primitives.Initialize; - Timestamp := System.OS_Primitives.Clock; - Gmemfile := fopen (Gmemfname, "wb" & ASCII.NUL); - - if Gmemfile = System.Null_Address then - Put_Line ("Couldn't open gnatmem log file for writing"); - OS_Exit (255); - end if; - - fwrite ("GMEM DUMP" & ASCII.LF, 10, 1, Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - end if; - end Gmem_Initialize; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) return System.Address - is - Addr : aliased constant System.Address := Ptr; - Result : aliased System.Address; - Timestamp : aliased Duration; - - begin - -- For the purposes of allocations logging, we treat realloc as a free - -- followed by malloc. This is not exactly accurate, but is a good way - -- to fit it into malloc/free-centered reports. - - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - Abort_Defer.all; - Lock_Task.all; - - if First_Call then - First_Call := False; - - -- We first log deallocation call - - if Needs_Init then - Gmem_Initialize; - end if; - Call_Chain - (Tracebk, Max_Call_Stack, Num_Calls, Skip_Frames => 2); - Timestamp := System.OS_Primitives.Clock; - fputc (Character'Pos ('D'), Gmemfile); - fwrite (Addr'Address, Address_Size, 1, Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); - - for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop - declare - Ptr : System.Address := PC_For (Tracebk (J)); - begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); - end; - end loop; - - -- Now perform actual realloc - - Result := c_realloc (Ptr, Size); - - -- Log allocation call using the same backtrace - - fputc (Character'Pos ('A'), Gmemfile); - fwrite (Result'Address, Address_Size, 1, Gmemfile); - fwrite (Size'Address, size_t'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Timestamp'Address, Duration'Max_Size_In_Storage_Elements, 1, - Gmemfile); - fwrite (Num_Calls'Address, Integer'Max_Size_In_Storage_Elements, 1, - Gmemfile); - - for J in Tracebk'First .. Tracebk'First + Num_Calls - 1 loop - declare - Ptr : System.Address := PC_For (Tracebk (J)); - begin - fwrite (Ptr'Address, Address_Size, 1, Gmemfile); - end; - end loop; - - First_Call := True; - end if; - - Unlock_Task.all; - Abort_Undefer.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc; - -end System.Memory; diff --git a/gcc/ada/s-addima.adb b/gcc/ada/s-addima.adb deleted file mode 100644 index cfde5c1..0000000 --- a/gcc/ada/s-addima.adb +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A D D R E S S _ I M A G E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -function System.Address_Image (A : Address) return String is - - Result : String (1 .. 2 * Address'Size / Storage_Unit); - - type Byte is mod 2 ** 8; - for Byte'Size use 8; - - Hexdigs : - constant array (Byte range 0 .. 15) of Character := "0123456789ABCDEF"; - - type Bytes is array (1 .. Address'Size / Storage_Unit) of Byte; - for Bytes'Size use Address'Size; - - function To_Bytes is new Ada.Unchecked_Conversion (Address, Bytes); - - Byte_Sequence : constant Bytes := To_Bytes (A); - - LE : constant := Standard'Default_Bit_Order; - BE : constant := 1 - LE; - -- Set to 1/0 for True/False for Little-Endian/Big-Endian - - Start : constant Natural := BE * (1) + LE * (Bytes'Length); - Incr : constant Integer := BE * (1) + LE * (-1); - -- Start and increment for accessing characters of address string - - Ptr : Natural; - -- Scan address string - -begin - Ptr := Start; - for N in Bytes'Range loop - Result (2 * N - 1) := Hexdigs (Byte_Sequence (Ptr) / 16); - Result (2 * N) := Hexdigs (Byte_Sequence (Ptr) mod 16); - Ptr := Ptr + Incr; - end loop; - - return Result; - -end System.Address_Image; diff --git a/gcc/ada/s-addima.ads b/gcc/ada/s-addima.ads deleted file mode 100644 index c81c229..0000000 --- a/gcc/ada/s-addima.ads +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A D D R E S S _ I M A G E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is a GNAT specific addition which provides a useful debugging --- procedure that gives an (implementation dependent) string which --- identifies an address. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -function System.Address_Image (A : Address) return String; -pragma Pure (System.Address_Image); --- Returns string (hexadecimal digits with upper case letters) representing --- the address (string is 8/16 bytes for 32/64-bit machines). 'First of the --- result = 1. diff --git a/gcc/ada/s-addope.adb b/gcc/ada/s-addope.adb deleted file mode 100644 index e38fba4..0000000 --- a/gcc/ada/s-addope.adb +++ /dev/null @@ -1,110 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A D D R E S S _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; - -package body System.Address_Operations is - - type IA is mod 2 ** Address'Size; - -- The type used to provide the actual desired operations - - function I is new Ada.Unchecked_Conversion (Address, IA); - function A is new Ada.Unchecked_Conversion (IA, Address); - -- The operations are implemented by unchecked conversion to type IA, - -- followed by doing the intrinsic operation on the IA values, followed - -- by converting the result back to type Address. - - ---------- - -- AddA -- - ---------- - - function AddA (Left, Right : Address) return Address is - begin - return A (I (Left) + I (Right)); - end AddA; - - ---------- - -- AndA -- - ---------- - - function AndA (Left, Right : Address) return Address is - begin - return A (I (Left) and I (Right)); - end AndA; - - ---------- - -- DivA -- - ---------- - - function DivA (Left, Right : Address) return Address is - begin - return A (I (Left) / I (Right)); - end DivA; - - ---------- - -- ModA -- - ---------- - - function ModA (Left, Right : Address) return Address is - begin - return A (I (Left) mod I (Right)); - end ModA; - - --------- - -- MulA -- - --------- - - function MulA (Left, Right : Address) return Address is - begin - return A (I (Left) * I (Right)); - end MulA; - - --------- - -- OrA -- - --------- - - function OrA (Left, Right : Address) return Address is - begin - return A (I (Left) or I (Right)); - end OrA; - - ---------- - -- SubA -- - ---------- - - function SubA (Left, Right : Address) return Address is - begin - return A (I (Left) - I (Right)); - end SubA; - -end System.Address_Operations; diff --git a/gcc/ada/s-addope.ads b/gcc/ada/s-addope.ads deleted file mode 100644 index 7d1866b..0000000 --- a/gcc/ada/s-addope.ads +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A D D R E S S _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides arithmetic and logical operations on type Address. --- It is intended for use by other packages in the System hierarchy. For --- applications requiring this capability, see System.Storage_Elements or --- the operations introduced in System.Aux_DEC; - --- The reason we need this package is that arithmetic operations may not --- be available in the case where type Address is non-private and the --- operations have been made abstract in the spec of System (to avoid --- inappropriate use by applications programs). In addition, the logical --- operations may not be available if type Address is a signed integer. - -pragma Compiler_Unit_Warning; - -package System.Address_Operations is - pragma Pure; - - -- The semantics of the arithmetic operations are those that apply to - -- a modular type with the same length as Address, i.e. they provide - -- twos complement wrap around arithmetic treating the address value - -- as an unsigned value, with no overflow checking. - - -- Note that we do not use the infix names for these operations to - -- avoid problems with ambiguities coming from declarations in package - -- Standard (which may or may not be visible depending on the exact - -- form of the declaration of type System.Address). - - -- For addition, subtraction, and multiplication, the effect of overflow - -- is 2's complement wrapping (as though the type Address were unsigned). - - -- For division and modulus operations, the caller is responsible for - -- ensuring that the Right argument is non-zero, and the effect of the - -- call is not specified if a zero argument is passed. - - function AddA (Left, Right : Address) return Address; - function SubA (Left, Right : Address) return Address; - function MulA (Left, Right : Address) return Address; - function DivA (Left, Right : Address) return Address; - function ModA (Left, Right : Address) return Address; - - -- The semantics of the logical operations are those that apply to - -- a modular type with the same length as Address, i.e. they provide - -- bit-wise operations on all bits of the value (including the sign - -- bit if Address is a signed integer type). - - function AndA (Left, Right : Address) return Address; - function OrA (Left, Right : Address) return Address; - - pragma Inline_Always (AddA); - pragma Inline_Always (SubA); - pragma Inline_Always (MulA); - pragma Inline_Always (DivA); - pragma Inline_Always (ModA); - pragma Inline_Always (AndA); - pragma Inline_Always (OrA); - -end System.Address_Operations; diff --git a/gcc/ada/s-arit64.adb b/gcc/ada/s-arit64.adb deleted file mode 100644 index cbefe31..0000000 --- a/gcc/ada/s-arit64.adb +++ /dev/null @@ -1,605 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A R I T H _ 6 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces; use Interfaces; - -with Ada.Unchecked_Conversion; - -package body System.Arith_64 is - - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - - subtype Uns64 is Unsigned_64; - function To_Uns is new Ada.Unchecked_Conversion (Int64, Uns64); - function To_Int is new Ada.Unchecked_Conversion (Uns64, Int64); - - subtype Uns32 is Unsigned_32; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function "+" (A, B : Uns32) return Uns64 is (Uns64 (A) + Uns64 (B)); - function "+" (A : Uns64; B : Uns32) return Uns64 is (A + Uns64 (B)); - -- Length doubling additions - - function "*" (A, B : Uns32) return Uns64 is (Uns64 (A) * Uns64 (B)); - -- Length doubling multiplication - - function "/" (A : Uns64; B : Uns32) return Uns64 is (A / Uns64 (B)); - -- Length doubling division - - function "&" (Hi, Lo : Uns32) return Uns64 is - (Shift_Left (Uns64 (Hi), 32) or Uns64 (Lo)); - -- Concatenate hi, lo values to form 64-bit result - - function "abs" (X : Int64) return Uns64 is - (if X = Int64'First then 2**63 else Uns64 (Int64'(abs X))); - -- Convert absolute value of X to unsigned. Note that we can't just use - -- the expression of the Else, because it overflows for X = Int64'First. - - function "rem" (A : Uns64; B : Uns32) return Uns64 is (A rem Uns64 (B)); - -- Length doubling remainder - - function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean; - -- Determines if 96 bit value X1&X2&X3 <= Y1&Y2&Y3 - - function Lo (A : Uns64) return Uns32 is (Uns32 (A and 16#FFFF_FFFF#)); - -- Low order half of 64-bit value - - function Hi (A : Uns64) return Uns32 is (Uns32 (Shift_Right (A, 32))); - -- High order half of 64-bit value - - procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32); - -- Computes X1&X2&X3 := X1&X2&X3 - Y1&Y1&Y3 with mod 2**96 wrap - - function To_Neg_Int (A : Uns64) return Int64 with Inline; - -- Convert to negative integer equivalent. If the input is in the range - -- 0 .. 2 ** 63, then the corresponding negative signed integer (obtained - -- by negating the given value) is returned, otherwise constraint error - -- is raised. - - function To_Pos_Int (A : Uns64) return Int64 with Inline; - -- Convert to positive integer equivalent. If the input is in the range - -- 0 .. 2 ** 63-1, then the corresponding non-negative signed integer is - -- returned, otherwise constraint error is raised. - - procedure Raise_Error with Inline; - pragma No_Return (Raise_Error); - -- Raise constraint error with appropriate message - - -------------------------- - -- Add_With_Ovflo_Check -- - -------------------------- - - function Add_With_Ovflo_Check (X, Y : Int64) return Int64 is - R : constant Int64 := To_Int (To_Uns (X) + To_Uns (Y)); - - begin - if X >= 0 then - if Y < 0 or else R >= 0 then - return R; - end if; - - else -- X < 0 - if Y > 0 or else R < 0 then - return R; - end if; - end if; - - Raise_Error; - end Add_With_Ovflo_Check; - - ------------------- - -- Double_Divide -- - ------------------- - - procedure Double_Divide - (X, Y, Z : Int64; - Q, R : out Int64; - Round : Boolean) - is - Xu : constant Uns64 := abs X; - Yu : constant Uns64 := abs Y; - - Yhi : constant Uns32 := Hi (Yu); - Ylo : constant Uns32 := Lo (Yu); - - Zu : constant Uns64 := abs Z; - Zhi : constant Uns32 := Hi (Zu); - Zlo : constant Uns32 := Lo (Zu); - - T1, T2 : Uns64; - Du, Qu, Ru : Uns64; - Den_Pos : Boolean; - - begin - if Yu = 0 or else Zu = 0 then - Raise_Error; - end if; - - -- Compute Y * Z. Note that if the result overflows 64 bits unsigned, - -- then the rounded result is clearly zero (since the dividend is at - -- most 2**63 - 1, the extra bit of precision is nice here). - - if Yhi /= 0 then - if Zhi /= 0 then - Q := 0; - R := X; - return; - else - T2 := Yhi * Zlo; - end if; - - else - T2 := (if Zhi /= 0 then Ylo * Zhi else 0); - end if; - - T1 := Ylo * Zlo; - T2 := T2 + Hi (T1); - - if Hi (T2) /= 0 then - Q := 0; - R := X; - return; - end if; - - Du := Lo (T2) & Lo (T1); - - -- Set final signs (RM 4.5.5(27-30)) - - Den_Pos := (Y < 0) = (Z < 0); - - -- Check overflow case of largest negative number divided by 1 - - if X = Int64'First and then Du = 1 and then not Den_Pos then - Raise_Error; - end if; - - -- Perform the actual division - - Qu := Xu / Du; - Ru := Xu rem Du; - - -- Deal with rounding case - - if Round and then Ru > (Du - Uns64'(1)) / Uns64'(2) then - Qu := Qu + Uns64'(1); - end if; - - -- Case of dividend (X) sign positive - - if X >= 0 then - R := To_Int (Ru); - Q := (if Den_Pos then To_Int (Qu) else -To_Int (Qu)); - - -- Case of dividend (X) sign negative - - else - R := -To_Int (Ru); - Q := (if Den_Pos then -To_Int (Qu) else To_Int (Qu)); - end if; - end Double_Divide; - - --------- - -- Le3 -- - --------- - - function Le3 (X1, X2, X3 : Uns32; Y1, Y2, Y3 : Uns32) return Boolean is - begin - if X1 < Y1 then - return True; - elsif X1 > Y1 then - return False; - elsif X2 < Y2 then - return True; - elsif X2 > Y2 then - return False; - else - return X3 <= Y3; - end if; - end Le3; - - ------------------------------- - -- Multiply_With_Ovflo_Check -- - ------------------------------- - - function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64 is - Xu : constant Uns64 := abs X; - Xhi : constant Uns32 := Hi (Xu); - Xlo : constant Uns32 := Lo (Xu); - - Yu : constant Uns64 := abs Y; - Yhi : constant Uns32 := Hi (Yu); - Ylo : constant Uns32 := Lo (Yu); - - T1, T2 : Uns64; - - begin - if Xhi /= 0 then - if Yhi /= 0 then - Raise_Error; - else - T2 := Xhi * Ylo; - end if; - - elsif Yhi /= 0 then - T2 := Xlo * Yhi; - - else -- Yhi = Xhi = 0 - T2 := 0; - end if; - - -- Here we have T2 set to the contribution to the upper half of the - -- result from the upper halves of the input values. - - T1 := Xlo * Ylo; - T2 := T2 + Hi (T1); - - if Hi (T2) /= 0 then - Raise_Error; - end if; - - T2 := Lo (T2) & Lo (T1); - - if X >= 0 then - if Y >= 0 then - return To_Pos_Int (T2); - else - return To_Neg_Int (T2); - end if; - else -- X < 0 - if Y < 0 then - return To_Pos_Int (T2); - else - return To_Neg_Int (T2); - end if; - end if; - - end Multiply_With_Ovflo_Check; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error is - begin - raise Constraint_Error with "64-bit arithmetic overflow"; - end Raise_Error; - - ------------------- - -- Scaled_Divide -- - ------------------- - - procedure Scaled_Divide - (X, Y, Z : Int64; - Q, R : out Int64; - Round : Boolean) - is - Xu : constant Uns64 := abs X; - Xhi : constant Uns32 := Hi (Xu); - Xlo : constant Uns32 := Lo (Xu); - - Yu : constant Uns64 := abs Y; - Yhi : constant Uns32 := Hi (Yu); - Ylo : constant Uns32 := Lo (Yu); - - Zu : Uns64 := abs Z; - Zhi : Uns32 := Hi (Zu); - Zlo : Uns32 := Lo (Zu); - - D : array (1 .. 4) of Uns32; - -- The dividend, four digits (D(1) is high order) - - Qd : array (1 .. 2) of Uns32; - -- The quotient digits, two digits (Qd(1) is high order) - - S1, S2, S3 : Uns32; - -- Value to subtract, three digits (S1 is high order) - - Qu : Uns64; - Ru : Uns64; - -- Unsigned quotient and remainder - - Scale : Natural; - -- Scaling factor used for multiple-precision divide. Dividend and - -- Divisor are multiplied by 2 ** Scale, and the final remainder is - -- divided by the scaling factor. The reason for this scaling is to - -- allow more accurate estimation of quotient digits. - - T1, T2, T3 : Uns64; - -- Temporary values - - begin - -- First do the multiplication, giving the four digit dividend - - T1 := Xlo * Ylo; - D (4) := Lo (T1); - D (3) := Hi (T1); - - if Yhi /= 0 then - T1 := Xlo * Yhi; - T2 := D (3) + Lo (T1); - D (3) := Lo (T2); - D (2) := Hi (T1) + Hi (T2); - - if Xhi /= 0 then - T1 := Xhi * Ylo; - T2 := D (3) + Lo (T1); - D (3) := Lo (T2); - T3 := D (2) + Hi (T1); - T3 := T3 + Hi (T2); - D (2) := Lo (T3); - D (1) := Hi (T3); - - T1 := (D (1) & D (2)) + Uns64'(Xhi * Yhi); - D (1) := Hi (T1); - D (2) := Lo (T1); - - else - D (1) := 0; - end if; - - else - if Xhi /= 0 then - T1 := Xhi * Ylo; - T2 := D (3) + Lo (T1); - D (3) := Lo (T2); - D (2) := Hi (T1) + Hi (T2); - - else - D (2) := 0; - end if; - - D (1) := 0; - end if; - - -- Now it is time for the dreaded multiple precision division. First an - -- easy case, check for the simple case of a one digit divisor. - - if Zhi = 0 then - if D (1) /= 0 or else D (2) >= Zlo then - Raise_Error; - - -- Here we are dividing at most three digits by one digit - - else - T1 := D (2) & D (3); - T2 := Lo (T1 rem Zlo) & D (4); - - Qu := Lo (T1 / Zlo) & Lo (T2 / Zlo); - Ru := T2 rem Zlo; - end if; - - -- If divisor is double digit and too large, raise error - - elsif (D (1) & D (2)) >= Zu then - Raise_Error; - - -- This is the complex case where we definitely have a double digit - -- divisor and a dividend of at least three digits. We use the classical - -- multiple division algorithm (see section (4.3.1) of Knuth's "The Art - -- of Computer Programming", Vol. 2 for a description (algorithm D). - - else - -- First normalize the divisor so that it has the leading bit on. - -- We do this by finding the appropriate left shift amount. - - Scale := 0; - - if (Zhi and 16#FFFF0000#) = 0 then - Scale := 16; - Zu := Shift_Left (Zu, 16); - end if; - - if (Hi (Zu) and 16#FF00_0000#) = 0 then - Scale := Scale + 8; - Zu := Shift_Left (Zu, 8); - end if; - - if (Hi (Zu) and 16#F000_0000#) = 0 then - Scale := Scale + 4; - Zu := Shift_Left (Zu, 4); - end if; - - if (Hi (Zu) and 16#C000_0000#) = 0 then - Scale := Scale + 2; - Zu := Shift_Left (Zu, 2); - end if; - - if (Hi (Zu) and 16#8000_0000#) = 0 then - Scale := Scale + 1; - Zu := Shift_Left (Zu, 1); - end if; - - Zhi := Hi (Zu); - Zlo := Lo (Zu); - - -- Note that when we scale up the dividend, it still fits in four - -- digits, since we already tested for overflow, and scaling does - -- not change the invariant that (D (1) & D (2)) >= Zu. - - T1 := Shift_Left (D (1) & D (2), Scale); - D (1) := Hi (T1); - T2 := Shift_Left (0 & D (3), Scale); - D (2) := Lo (T1) or Hi (T2); - T3 := Shift_Left (0 & D (4), Scale); - D (3) := Lo (T2) or Hi (T3); - D (4) := Lo (T3); - - -- Loop to compute quotient digits, runs twice for Qd(1) and Qd(2) - - for J in 0 .. 1 loop - - -- Compute next quotient digit. We have to divide three digits by - -- two digits. We estimate the quotient by dividing the leading - -- two digits by the leading digit. Given the scaling we did above - -- which ensured the first bit of the divisor is set, this gives - -- an estimate of the quotient that is at most two too high. - - Qd (J + 1) := (if D (J + 1) = Zhi - then 2 ** 32 - 1 - else Lo ((D (J + 1) & D (J + 2)) / Zhi)); - - -- Compute amount to subtract - - T1 := Qd (J + 1) * Zlo; - T2 := Qd (J + 1) * Zhi; - S3 := Lo (T1); - T1 := Hi (T1) + Lo (T2); - S2 := Lo (T1); - S1 := Hi (T1) + Hi (T2); - - -- Adjust quotient digit if it was too high - - loop - exit when Le3 (S1, S2, S3, D (J + 1), D (J + 2), D (J + 3)); - Qd (J + 1) := Qd (J + 1) - 1; - Sub3 (S1, S2, S3, 0, Zhi, Zlo); - end loop; - - -- Now subtract S1&S2&S3 from D1&D2&D3 ready for next step - - Sub3 (D (J + 1), D (J + 2), D (J + 3), S1, S2, S3); - end loop; - - -- The two quotient digits are now set, and the remainder of the - -- scaled division is in D3&D4. To get the remainder for the - -- original unscaled division, we rescale this dividend. - - -- We rescale the divisor as well, to make the proper comparison - -- for rounding below. - - Qu := Qd (1) & Qd (2); - Ru := Shift_Right (D (3) & D (4), Scale); - Zu := Shift_Right (Zu, Scale); - end if; - - -- Deal with rounding case - - if Round and then Ru > (Zu - Uns64'(1)) / Uns64'(2) then - Qu := Qu + Uns64 (1); - end if; - - -- Set final signs (RM 4.5.5(27-30)) - - -- Case of dividend (X * Y) sign positive - - if (X >= 0 and then Y >= 0) or else (X < 0 and then Y < 0) then - R := To_Pos_Int (Ru); - Q := (if Z > 0 then To_Pos_Int (Qu) else To_Neg_Int (Qu)); - - -- Case of dividend (X * Y) sign negative - - else - R := To_Neg_Int (Ru); - Q := (if Z > 0 then To_Neg_Int (Qu) else To_Pos_Int (Qu)); - end if; - end Scaled_Divide; - - ---------- - -- Sub3 -- - ---------- - - procedure Sub3 (X1, X2, X3 : in out Uns32; Y1, Y2, Y3 : Uns32) is - begin - if Y3 > X3 then - if X2 = 0 then - X1 := X1 - 1; - end if; - - X2 := X2 - 1; - end if; - - X3 := X3 - Y3; - - if Y2 > X2 then - X1 := X1 - 1; - end if; - - X2 := X2 - Y2; - X1 := X1 - Y1; - end Sub3; - - ------------------------------- - -- Subtract_With_Ovflo_Check -- - ------------------------------- - - function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64 is - R : constant Int64 := To_Int (To_Uns (X) - To_Uns (Y)); - - begin - if X >= 0 then - if Y > 0 or else R >= 0 then - return R; - end if; - - else -- X < 0 - if Y <= 0 or else R < 0 then - return R; - end if; - end if; - - Raise_Error; - end Subtract_With_Ovflo_Check; - - ---------------- - -- To_Neg_Int -- - ---------------- - - function To_Neg_Int (A : Uns64) return Int64 is - R : constant Int64 := (if A = 2**63 then Int64'First else -To_Int (A)); - -- Note that we can't just use the expression of the Else, because it - -- overflows for A = 2**63. - begin - if R <= 0 then - return R; - else - Raise_Error; - end if; - end To_Neg_Int; - - ---------------- - -- To_Pos_Int -- - ---------------- - - function To_Pos_Int (A : Uns64) return Int64 is - R : constant Int64 := To_Int (A); - begin - if R >= 0 then - return R; - else - Raise_Error; - end if; - end To_Pos_Int; - -end System.Arith_64; diff --git a/gcc/ada/s-arit64.ads b/gcc/ada/s-arit64.ads deleted file mode 100644 index 4eb1153..0000000 --- a/gcc/ada/s-arit64.ads +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A R I T H _ 6 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit provides software routines for doing arithmetic on 64-bit --- signed integer values in cases where either overflow checking is --- required, or intermediate results are longer than 64 bits. - -pragma Restrictions (No_Elaboration_Code); --- Allow direct call from gigi generated code - -with Interfaces; - -package System.Arith_64 is - pragma Pure; - - subtype Int64 is Interfaces.Integer_64; - - function Add_With_Ovflo_Check (X, Y : Int64) return Int64; - -- Raises Constraint_Error if sum of operands overflows 64 bits, - -- otherwise returns the 64-bit signed integer sum. - - function Subtract_With_Ovflo_Check (X, Y : Int64) return Int64; - -- Raises Constraint_Error if difference of operands overflows 64 - -- bits, otherwise returns the 64-bit signed integer difference. - - function Multiply_With_Ovflo_Check (X, Y : Int64) return Int64; - pragma Export (C, Multiply_With_Ovflo_Check, "__gnat_mulv64"); - -- Raises Constraint_Error if product of operands overflows 64 - -- bits, otherwise returns the 64-bit signed integer product. - -- GIGI may also call this routine directly. - - procedure Scaled_Divide - (X, Y, Z : Int64; - Q, R : out Int64; - Round : Boolean); - -- Performs the division of (X * Y) / Z, storing the quotient in Q - -- and the remainder in R. Constraint_Error is raised if Z is zero, - -- or if the quotient does not fit in 64-bits. Round indicates if - -- the result should be rounded. If Round is False, then Q, R are - -- the normal quotient and remainder from a truncating division. - -- If Round is True, then Q is the rounded quotient. The remainder - -- R is not affected by the setting of the Round flag. - - procedure Double_Divide - (X, Y, Z : Int64; - Q, R : out Int64; - Round : Boolean); - -- Performs the division X / (Y * Z), storing the quotient in Q and - -- the remainder in R. Constraint_Error is raised if Y or Z is zero, - -- or if the quotient does not fit in 64-bits. Round indicates if the - -- result should be rounded. If Round is False, then Q, R are the normal - -- quotient and remainder from a truncating division. If Round is True, - -- then Q is the rounded quotient. The remainder R is not affected by the - -- setting of the Round flag. - -end System.Arith_64; diff --git a/gcc/ada/s-assert.adb b/gcc/ada/s-assert.adb deleted file mode 100644 index 3828cc1..0000000 --- a/gcc/ada/s-assert.adb +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S S E R T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Exceptions; -with System.Exceptions_Debug; - -package body System.Assertions is - - -------------------------- - -- Raise_Assert_Failure -- - -------------------------- - - procedure Raise_Assert_Failure (Msg : String) is - begin - System.Exceptions_Debug.Debug_Raise_Assert_Failure; - Ada.Exceptions.Raise_Exception (Assert_Failure'Identity, Msg); - end Raise_Assert_Failure; - -end System.Assertions; diff --git a/gcc/ada/s-assert.ads b/gcc/ada/s-assert.ads deleted file mode 100644 index 38cab86..0000000 --- a/gcc/ada/s-assert.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A S S E R T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides support for assertions (including pragma Assert, --- pragma Debug, and Precondition/Postcondition/Predicate/Invariant aspects --- and their corresponding pragmas). - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -pragma Compiler_Unit_Warning; - -package System.Assertions is - - Assert_Failure : exception; - -- Exception raised when assertion fails - - procedure Raise_Assert_Failure (Msg : String); - pragma No_Return (Raise_Assert_Failure); - -- Called to raise Assert_Failure with given message - -end System.Assertions; diff --git a/gcc/ada/s-atacco.adb b/gcc/ada/s-atacco.adb deleted file mode 100644 index f1998fa..0000000 --- a/gcc/ada/s-atacco.adb +++ /dev/null @@ -1,36 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - -pragma No_Body; diff --git a/gcc/ada/s-atacco.ads b/gcc/ada/s-atacco.ads deleted file mode 100644 index fb6232d..0000000 --- a/gcc/ada/s-atacco.ads +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A D D R E S S _ T O _ A C C E S S _ C O N V E R S I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -generic - type Object (<>) is limited private; - -package System.Address_To_Access_Conversions is - pragma Preelaborate; - - pragma Compile_Time_Warning - (Object'Unconstrained_Array, - "Object is unconstrained array type" & ASCII.LF & - "To_Pointer results may not have bounds"); - - type Object_Pointer is access all Object; - for Object_Pointer'Size use Standard'Address_Size; - - pragma No_Strict_Aliasing (Object_Pointer); - -- Strictly speaking, this routine should not be used to generate pointers - -- to other than proper values of the proper type, but in practice, this - -- is done all the time. This pragma stops the compiler from doing some - -- optimizations that may cause unexpected results based on the assumption - -- of no strict aliasing. - - function To_Pointer (Value : Address) return Object_Pointer; - function To_Address (Value : Object_Pointer) return Address; - - pragma Import (Intrinsic, To_Pointer); - pragma Import (Intrinsic, To_Address); - -end System.Address_To_Access_Conversions; diff --git a/gcc/ada/s-atocou-builtin.adb b/gcc/ada/s-atocou-builtin.adb deleted file mode 100644 index 36a939f..0000000 --- a/gcc/ada/s-atocou-builtin.adb +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ C O U N T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements Atomic_Counter and Atomic_Unsigned operations --- for platforms where GCC supports __sync_add_and_fetch_4 and --- __sync_sub_and_fetch_4 builtins. - -package body System.Atomic_Counters is - - procedure Sync_Add_And_Fetch - (Ptr : access Atomic_Unsigned; - Value : Atomic_Unsigned); - pragma Import (Intrinsic, Sync_Add_And_Fetch, "__sync_add_and_fetch_4"); - - function Sync_Sub_And_Fetch - (Ptr : access Atomic_Unsigned; - Value : Atomic_Unsigned) return Atomic_Unsigned; - pragma Import (Intrinsic, Sync_Sub_And_Fetch, "__sync_sub_and_fetch_4"); - - --------------- - -- Decrement -- - --------------- - - procedure Decrement (Item : aliased in out Atomic_Unsigned) is - begin - if Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0 then - null; - end if; - end Decrement; - - function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is - begin - return Sync_Sub_And_Fetch (Item'Unrestricted_Access, 1) = 0; - end Decrement; - - function Decrement (Item : in out Atomic_Counter) return Boolean is - begin - -- Note: the use of Unrestricted_Access here is required because we - -- are obtaining an access-to-volatile pointer to a non-volatile object. - -- This is not allowed for [Unchecked_]Access, but is safe in this case - -- because we know that no aliases are being created. - - return Sync_Sub_And_Fetch (Item.Value'Unrestricted_Access, 1) = 0; - end Decrement; - - --------------- - -- Increment -- - --------------- - - procedure Increment (Item : aliased in out Atomic_Unsigned) is - begin - Sync_Add_And_Fetch (Item'Unrestricted_Access, 1); - end Increment; - - procedure Increment (Item : in out Atomic_Counter) is - begin - -- Note: the use of Unrestricted_Access here is required because we are - -- obtaining an access-to-volatile pointer to a non-volatile object. - -- This is not allowed for [Unchecked_]Access, but is safe in this case - -- because we know that no aliases are being created. - - Sync_Add_And_Fetch (Item.Value'Unrestricted_Access, 1); - end Increment; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Item : out Atomic_Counter) is - begin - Item.Value := 1; - end Initialize; - - ------------ - -- Is_One -- - ------------ - - function Is_One (Item : Atomic_Counter) return Boolean is - begin - return Item.Value = 1; - end Is_One; - -end System.Atomic_Counters; diff --git a/gcc/ada/s-atocou-x86.adb b/gcc/ada/s-atocou-x86.adb deleted file mode 100644 index bee6755..0000000 --- a/gcc/ada/s-atocou-x86.adb +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ C O U N T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation of the package for x86 processor. GCC can't generate --- code for atomic builtins for 386 CPU. Only increment/decrement instructions --- are supported, thus this implementaton uses machine code insertions to --- access the necessary instructions. - -with System.Machine_Code; - -package body System.Atomic_Counters is - - -- Add comments showing in normal asm language what we generate??? - - --------------- - -- Decrement -- - --------------- - - function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is - Aux : Boolean; - - begin - System.Machine_Code.Asm - (Template => - "lock%; decl" & ASCII.HT & "%0" & ASCII.LF & ASCII.HT - & "sete %1", - Outputs => - (Atomic_Unsigned'Asm_Output ("=m", Item), - Boolean'Asm_Output ("=qm", Aux)), - Inputs => Atomic_Unsigned'Asm_Input ("m", Item), - Volatile => True); - - return Aux; - end Decrement; - - procedure Decrement (Item : aliased in out Atomic_Unsigned) is - begin - if Decrement (Item) then - null; - end if; - end Decrement; - - function Decrement (Item : in out Atomic_Counter) return Boolean is - begin - return Decrement (Item.Value); - end Decrement; - - --------------- - -- Increment -- - --------------- - - procedure Increment (Item : aliased in out Atomic_Unsigned) is - begin - System.Machine_Code.Asm - (Template => "lock%; incl" & ASCII.HT & "%0", - Outputs => Atomic_Unsigned'Asm_Output ("=m", Item), - Inputs => Atomic_Unsigned'Asm_Input ("m", Item), - Volatile => True); - end Increment; - - procedure Increment (Item : in out Atomic_Counter) is - begin - Increment (Item.Value); - end Increment; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Item : out Atomic_Counter) is - begin - Item.Value := 1; - end Initialize; - - ------------ - -- Is_One -- - ------------ - - function Is_One (Item : Atomic_Counter) return Boolean is - begin - return Item.Value = 1; - end Is_One; - -end System.Atomic_Counters; diff --git a/gcc/ada/s-atocou.adb b/gcc/ada/s-atocou.adb deleted file mode 100644 index 2897c6c..0000000 --- a/gcc/ada/s-atocou.adb +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ C O U N T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is version of the package, for use on platforms where this capability --- is not supported. All Atomic_Counter operations raises Program_Error, --- Atomic_Unsigned operations processed in non-atomic manner. - -package body System.Atomic_Counters is - - --------------- - -- Decrement -- - --------------- - - function Decrement (Item : in out Atomic_Counter) return Boolean is - begin - raise Program_Error; - return False; - end Decrement; - - function Decrement (Item : aliased in out Atomic_Unsigned) return Boolean is - begin - -- Could not use Item := Item - 1; because it is disabled in spec. - Item := Atomic_Unsigned'Pred (Item); - return Item = 0; - end Decrement; - - procedure Decrement (Item : aliased in out Atomic_Unsigned) is - begin - Item := Atomic_Unsigned'Pred (Item); - end Decrement; - - --------------- - -- Increment -- - --------------- - - procedure Increment (Item : in out Atomic_Counter) is - begin - raise Program_Error; - end Increment; - - procedure Increment (Item : aliased in out Atomic_Unsigned) is - begin - Item := Atomic_Unsigned'Succ (Item); - end Increment; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Item : out Atomic_Counter) is - begin - raise Program_Error; - end Initialize; - - ------------ - -- Is_One -- - ------------ - - function Is_One (Item : Atomic_Counter) return Boolean is - begin - raise Program_Error; - return False; - end Is_One; - -end System.Atomic_Counters; diff --git a/gcc/ada/s-atocou.ads b/gcc/ada/s-atocou.ads deleted file mode 100644 index 1147de7..0000000 --- a/gcc/ada/s-atocou.ads +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ C O U N T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides atomic counter on platforms where it is supported: --- - all Alpha platforms --- - all ia64 platforms --- - all PowerPC platforms --- - all SPARC V9 platforms --- - all x86 platforms --- - all x86_64 platforms - -package System.Atomic_Counters is - - pragma Pure; - pragma Preelaborate; - - type Atomic_Counter is limited private; - -- Type for atomic counter objects. Note, initial value of the counter is - -- one. This allows using an atomic counter as member of record types when - -- object of these types are created at library level in preelaborable - -- compilation units. - -- - -- Atomic_Counter is declared as private limited type to provide highest - -- level of protection from unexpected use. All available operations are - -- declared below, and this set should be as small as possible. - -- Increment/Decrement operations for this type raise Program_Error on - -- platforms not supporting the atomic primitives. - - procedure Increment (Item : in out Atomic_Counter); - pragma Inline_Always (Increment); - -- Increments value of atomic counter. - - function Decrement (Item : in out Atomic_Counter) return Boolean; - pragma Inline_Always (Decrement); - -- Decrements value of atomic counter, returns True when value reach zero - - function Is_One (Item : Atomic_Counter) return Boolean; - pragma Inline_Always (Is_One); - -- Returns True when value of the atomic counter is one - - procedure Initialize (Item : out Atomic_Counter); - pragma Inline_Always (Initialize); - -- Initialize counter by setting its value to one. This subprogram is - -- intended to be used in special cases when the counter object cannot be - -- initialized in standard way. - - type Atomic_Unsigned is mod 2 ** 32 with Default_Value => 0, Atomic; - -- Modular compatible atomic unsigned type. - -- Increment/Decrement operations for this type are atomic only on - -- supported platforms. See top of the file. - - procedure Increment - (Item : aliased in out Atomic_Unsigned) with Inline_Always; - -- Increments value of atomic counter - - function Decrement - (Item : aliased in out Atomic_Unsigned) return Boolean with Inline_Always; - - procedure Decrement - (Item : aliased in out Atomic_Unsigned) with Inline_Always; - -- Decrements value of atomic counter - - -- The "+" and "-" abstract routine provided below to disable BT := BT + 1 - -- constructions. - - function "+" - (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract; - - function "-" - (Left, Right : Atomic_Unsigned) return Atomic_Unsigned is abstract; - -private - - type Atomic_Counter is record - Value : aliased Atomic_Unsigned := 1; - pragma Atomic (Value); - end record; - -end System.Atomic_Counters; diff --git a/gcc/ada/s-atopri.adb b/gcc/ada/s-atopri.adb deleted file mode 100644 index 145cbb6..0000000 --- a/gcc/ada/s-atopri.adb +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Atomic_Primitives is - - ---------------------- - -- Lock_Free_Read_8 -- - ---------------------- - - function Lock_Free_Read_8 (Ptr : Address) return uint8 is - begin - if uint8'Atomic_Always_Lock_Free then - return Atomic_Load_8 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_8; - - ----------------------- - -- Lock_Free_Read_16 -- - ----------------------- - - function Lock_Free_Read_16 (Ptr : Address) return uint16 is - begin - if uint16'Atomic_Always_Lock_Free then - return Atomic_Load_16 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_16; - - ----------------------- - -- Lock_Free_Read_32 -- - ----------------------- - - function Lock_Free_Read_32 (Ptr : Address) return uint32 is - begin - if uint32'Atomic_Always_Lock_Free then - return Atomic_Load_32 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_32; - - ----------------------- - -- Lock_Free_Read_64 -- - ----------------------- - - function Lock_Free_Read_64 (Ptr : Address) return uint64 is - begin - if uint64'Atomic_Always_Lock_Free then - return Atomic_Load_64 (Ptr, Acquire); - else - raise Program_Error; - end if; - end Lock_Free_Read_64; - - --------------------------- - -- Lock_Free_Try_Write_8 -- - --------------------------- - - function Lock_Free_Try_Write_8 - (Ptr : Address; - Expected : in out uint8; - Desired : uint8) return Boolean - is - Actual : uint8; - - begin - if Expected /= Desired then - - if uint8'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_8 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_8; - - ---------------------------- - -- Lock_Free_Try_Write_16 -- - ---------------------------- - - function Lock_Free_Try_Write_16 - (Ptr : Address; - Expected : in out uint16; - Desired : uint16) return Boolean - is - Actual : uint16; - - begin - if Expected /= Desired then - - if uint16'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_16 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_16; - - ---------------------------- - -- Lock_Free_Try_Write_32 -- - ---------------------------- - - function Lock_Free_Try_Write_32 - (Ptr : Address; - Expected : in out uint32; - Desired : uint32) return Boolean - is - Actual : uint32; - - begin - if Expected /= Desired then - - if uint32'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_32 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_32; - - ---------------------------- - -- Lock_Free_Try_Write_64 -- - ---------------------------- - - function Lock_Free_Try_Write_64 - (Ptr : Address; - Expected : in out uint64; - Desired : uint64) return Boolean - is - Actual : uint64; - - begin - if Expected /= Desired then - - if uint64'Atomic_Always_Lock_Free then - Actual := Sync_Compare_And_Swap_64 (Ptr, Expected, Desired); - else - raise Program_Error; - end if; - - if Actual /= Expected then - Expected := Actual; - return False; - end if; - end if; - - return True; - end Lock_Free_Try_Write_64; -end System.Atomic_Primitives; diff --git a/gcc/ada/s-atopri.ads b/gcc/ada/s-atopri.ads deleted file mode 100644 index ba4b733..0000000 --- a/gcc/ada/s-atopri.ads +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . A T O M I C _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains both atomic primitives defined from gcc built-in --- functions and operations used by the compiler to generate the lock-free --- implementation of protected objects. - -package System.Atomic_Primitives is - pragma Preelaborate; - - type uint is mod 2 ** Long_Integer'Size; - - type uint8 is mod 2**8 - with Size => 8; - - type uint16 is mod 2**16 - with Size => 16; - - type uint32 is mod 2**32 - with Size => 32; - - type uint64 is mod 2**64 - with Size => 64; - - Relaxed : constant := 0; - Consume : constant := 1; - Acquire : constant := 2; - Release : constant := 3; - Acq_Rel : constant := 4; - Seq_Cst : constant := 5; - Last : constant := 6; - - subtype Mem_Model is Integer range Relaxed .. Last; - - ------------------------------------ - -- GCC built-in atomic primitives -- - ------------------------------------ - - function Atomic_Load_8 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint8; - pragma Import (Intrinsic, Atomic_Load_8, "__atomic_load_1"); - - function Atomic_Load_16 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint16; - pragma Import (Intrinsic, Atomic_Load_16, "__atomic_load_2"); - - function Atomic_Load_32 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint32; - pragma Import (Intrinsic, Atomic_Load_32, "__atomic_load_4"); - - function Atomic_Load_64 - (Ptr : Address; - Model : Mem_Model := Seq_Cst) return uint64; - pragma Import (Intrinsic, Atomic_Load_64, "__atomic_load_8"); - - function Sync_Compare_And_Swap_8 - (Ptr : Address; - Expected : uint8; - Desired : uint8) return uint8; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_8, - "__sync_val_compare_and_swap_1"); - - -- ??? Should use __atomic_compare_exchange_1 (doesn't work yet): - -- function Sync_Compare_And_Swap_8 - -- (Ptr : Address; - -- Expected : Address; - -- Desired : uint8; - -- Weak : Boolean := False; - -- Success_Model : Mem_Model := Seq_Cst; - -- Failure_Model : Mem_Model := Seq_Cst) return Boolean; - -- pragma Import (Intrinsic, - -- Sync_Compare_And_Swap_8, - -- "__atomic_compare_exchange_1"); - - function Sync_Compare_And_Swap_16 - (Ptr : Address; - Expected : uint16; - Desired : uint16) return uint16; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_16, - "__sync_val_compare_and_swap_2"); - - function Sync_Compare_And_Swap_32 - (Ptr : Address; - Expected : uint32; - Desired : uint32) return uint32; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_32, - "__sync_val_compare_and_swap_4"); - - function Sync_Compare_And_Swap_64 - (Ptr : Address; - Expected : uint64; - Desired : uint64) return uint64; - pragma Import (Intrinsic, - Sync_Compare_And_Swap_64, - "__sync_val_compare_and_swap_8"); - - -------------------------- - -- Lock-free operations -- - -------------------------- - - -- The lock-free implementation uses two atomic instructions for the - -- expansion of protected operations: - - -- * Lock_Free_Read_N atomically loads the value of the protected component - -- accessed by the current protected operation. - - -- * Lock_Free_Try_Write_N tries to write the Desired value into Ptr only - -- if Expected and Desired mismatch. - - function Lock_Free_Read_8 (Ptr : Address) return uint8; - - function Lock_Free_Read_16 (Ptr : Address) return uint16; - - function Lock_Free_Read_32 (Ptr : Address) return uint32; - - function Lock_Free_Read_64 (Ptr : Address) return uint64; - - function Lock_Free_Try_Write_8 - (Ptr : Address; - Expected : in out uint8; - Desired : uint8) return Boolean; - - function Lock_Free_Try_Write_16 - (Ptr : Address; - Expected : in out uint16; - Desired : uint16) return Boolean; - - function Lock_Free_Try_Write_32 - (Ptr : Address; - Expected : in out uint32; - Desired : uint32) return Boolean; - - function Lock_Free_Try_Write_64 - (Ptr : Address; - Expected : in out uint64; - Desired : uint64) return Boolean; - - pragma Inline (Lock_Free_Read_8); - pragma Inline (Lock_Free_Read_16); - pragma Inline (Lock_Free_Read_32); - pragma Inline (Lock_Free_Read_64); - pragma Inline (Lock_Free_Try_Write_8); - pragma Inline (Lock_Free_Try_Write_16); - pragma Inline (Lock_Free_Try_Write_32); - pragma Inline (Lock_Free_Try_Write_64); -end System.Atomic_Primitives; diff --git a/gcc/ada/s-auxdec.adb b/gcc/ada/s-auxdec.adb deleted file mode 100644 index bfb4894..0000000 --- a/gcc/ada/s-auxdec.adb +++ /dev/null @@ -1,718 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/Or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Style_Checks (All_Checks); --- Turn off alpha ordering check on subprograms, this unit is laid --- out to correspond to the declarations in the DEC 83 System unit. - -with System.Soft_Links; - -package body System.Aux_DEC is - - package SSL renames System.Soft_Links; - - ----------------------------------- - -- Operations on Largest_Integer -- - ----------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type LIU is mod 2 ** Largest_Integer'Size; - -- Unsigned type of same length as Largest_Integer - - function To_LI is new Ada.Unchecked_Conversion (LIU, Largest_Integer); - function From_LI is new Ada.Unchecked_Conversion (Largest_Integer, LIU); - - function "not" (Left : Largest_Integer) return Largest_Integer is - begin - return To_LI (not From_LI (Left)); - end "not"; - - function "and" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) and From_LI (Right)); - end "and"; - - function "or" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) or From_LI (Right)); - end "or"; - - function "xor" (Left, Right : Largest_Integer) return Largest_Integer is - begin - return To_LI (From_LI (Left) xor From_LI (Right)); - end "xor"; - - -------------------------------------- - -- Arithmetic Operations on Address -- - -------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - Asiz : constant Integer := Integer (Address'Size) - 1; - - type SA is range -(2 ** Asiz) .. 2 ** Asiz - 1; - -- Signed type of same size as Address - - function To_A is new Ada.Unchecked_Conversion (SA, Address); - function From_A is new Ada.Unchecked_Conversion (Address, SA); - - function "+" (Left : Address; Right : Integer) return Address is - begin - return To_A (From_A (Left) + SA (Right)); - end "+"; - - function "+" (Left : Integer; Right : Address) return Address is - begin - return To_A (SA (Left) + From_A (Right)); - end "+"; - - function "-" (Left : Address; Right : Address) return Integer is - pragma Unsuppress (All_Checks); - -- Because this can raise Constraint_Error for 64-bit addresses - begin - return Integer (From_A (Left) - From_A (Right)); - end "-"; - - function "-" (Left : Address; Right : Integer) return Address is - begin - return To_A (From_A (Left) - SA (Right)); - end "-"; - - ------------------------ - -- Fetch_From_Address -- - ------------------------ - - function Fetch_From_Address (A : Address) return Target is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - return Ptr.all; - end Fetch_From_Address; - - ----------------------- - -- Assign_To_Address -- - ----------------------- - - procedure Assign_To_Address (A : Address; T : Target) is - type T_Ptr is access all Target; - function To_T_Ptr is new Ada.Unchecked_Conversion (Address, T_Ptr); - Ptr : constant T_Ptr := To_T_Ptr (A); - begin - Ptr.all := T; - end Assign_To_Address; - - --------------------------------- - -- Operations on Unsigned_Byte -- - --------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type BU is mod 2 ** Unsigned_Byte'Size; - -- Unsigned type of same length as Unsigned_Byte - - function To_B is new Ada.Unchecked_Conversion (BU, Unsigned_Byte); - function From_B is new Ada.Unchecked_Conversion (Unsigned_Byte, BU); - - function "not" (Left : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (not From_B (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) and From_B (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) or From_B (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte is - begin - return To_B (From_B (Left) xor From_B (Right)); - end "xor"; - - --------------------------------- - -- Operations on Unsigned_Word -- - --------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type WU is mod 2 ** Unsigned_Word'Size; - -- Unsigned type of same length as Unsigned_Word - - function To_W is new Ada.Unchecked_Conversion (WU, Unsigned_Word); - function From_W is new Ada.Unchecked_Conversion (Unsigned_Word, WU); - - function "not" (Left : Unsigned_Word) return Unsigned_Word is - begin - return To_W (not From_W (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) and From_W (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) or From_W (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word is - begin - return To_W (From_W (Left) xor From_W (Right)); - end "xor"; - - ------------------------------------- - -- Operations on Unsigned_Longword -- - ------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type LWU is mod 2 ** Unsigned_Longword'Size; - -- Unsigned type of same length as Unsigned_Longword - - function To_LW is new Ada.Unchecked_Conversion (LWU, Unsigned_Longword); - function From_LW is new Ada.Unchecked_Conversion (Unsigned_Longword, LWU); - - function "not" (Left : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (not From_LW (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) and From_LW (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) or From_LW (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword is - begin - return To_LW (From_LW (Left) xor From_LW (Right)); - end "xor"; - - ------------------------------- - -- Operations on Unsigned_32 -- - ------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type U32 is mod 2 ** Unsigned_32'Size; - -- Unsigned type of same length as Unsigned_32 - - function To_U32 is new Ada.Unchecked_Conversion (U32, Unsigned_32); - function From_U32 is new Ada.Unchecked_Conversion (Unsigned_32, U32); - - function "not" (Left : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (not From_U32 (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) and From_U32 (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) or From_U32 (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_32) return Unsigned_32 is - begin - return To_U32 (From_U32 (Left) xor From_U32 (Right)); - end "xor"; - - ------------------------------------- - -- Operations on Unsigned_Quadword -- - ------------------------------------- - - -- It would be nice to replace these with intrinsics, but that does - -- not work yet (the back end would be ok, but GNAT itself objects) - - type QWU is mod 2 ** 64; -- 64 = Unsigned_Quadword'Size - -- Unsigned type of same length as Unsigned_Quadword - - function To_QW is new Ada.Unchecked_Conversion (QWU, Unsigned_Quadword); - function From_QW is new Ada.Unchecked_Conversion (Unsigned_Quadword, QWU); - - function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (not From_QW (Left)); - end "not"; - - function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) and From_QW (Right)); - end "and"; - - function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) or From_QW (Right)); - end "or"; - - function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword is - begin - return To_QW (From_QW (Left) xor From_QW (Right)); - end "xor"; - - ----------------------- - -- Clear_Interlocked -- - ----------------------- - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := False; - SSL.Unlock_Task.all; - end Clear_Interlocked; - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := False; - Success_Flag := True; - SSL.Unlock_Task.all; - end Clear_Interlocked; - - --------------------- - -- Set_Interlocked -- - --------------------- - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean) - is - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := True; - SSL.Unlock_Task.all; - end Set_Interlocked; - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := Bit; - Bit := True; - Success_Flag := True; - SSL.Unlock_Task.all; - end Set_Interlocked; - - --------------------- - -- Add_Interlocked -- - --------------------- - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer) - is - begin - SSL.Lock_Task.all; - Augend.Value := Augend.Value + Addend; - - if Augend.Value < 0 then - Sign := -1; - elsif Augend.Value > 0 then - Sign := +1; - else - Sign := 0; - end if; - - SSL.Unlock_Task.all; - end Add_Interlocked; - - ---------------- - -- Add_Atomic -- - ---------------- - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer) - is - begin - SSL.Lock_Task.all; - To.Value := To.Value + Amount; - SSL.Unlock_Task.all; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := To.Value + Amount; - Success_Flag := True; - SSL.Unlock_Task.all; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer) - is - begin - SSL.Lock_Task.all; - To.Value := To.Value + Amount; - SSL.Unlock_Task.all; - end Add_Atomic; - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := To.Value + Amount; - Success_Flag := True; - SSL.Unlock_Task.all; - end Add_Atomic; - - ---------------- - -- And_Atomic -- - ---------------- - - type IU is mod 2 ** Integer'Size; - type LU is mod 2 ** Long_Integer'Size; - - function To_IU is new Ada.Unchecked_Conversion (Integer, IU); - function From_IU is new Ada.Unchecked_Conversion (IU, Integer); - - function To_LU is new Ada.Unchecked_Conversion (Long_Integer, LU); - function From_LU is new Ada.Unchecked_Conversion (LU, Long_Integer); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_IU (To_IU (To.Value) and To_IU (From)); - SSL.Unlock_Task.all; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_IU (To_IU (To.Value) and To_IU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_LU (To_LU (To.Value) and To_LU (From)); - SSL.Unlock_Task.all; - end And_Atomic; - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_LU (To_LU (To.Value) and To_LU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end And_Atomic; - - --------------- - -- Or_Atomic -- - --------------- - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_IU (To_IU (To.Value) or To_IU (From)); - SSL.Unlock_Task.all; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_IU (To_IU (To.Value) or To_IU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer) - is - begin - SSL.Lock_Task.all; - To.Value := From_LU (To_LU (To.Value) or To_LU (From)); - SSL.Unlock_Task.all; - end Or_Atomic; - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean) - is - pragma Warnings (Off, Retry_Count); - - begin - SSL.Lock_Task.all; - Old_Value := To.Value; - To.Value := From_LU (To_LU (To.Value) or To_LU (From)); - Success_Flag := True; - SSL.Unlock_Task.all; - end Or_Atomic; - - ------------------------------------ - -- Declarations for Queue Objects -- - ------------------------------------ - - type QR; - - type QR_Ptr is access QR; - - type QR is record - Forward : QR_Ptr; - Backward : QR_Ptr; - end record; - - function To_QR_Ptr is new Ada.Unchecked_Conversion (Address, QR_Ptr); - function From_QR_Ptr is new Ada.Unchecked_Conversion (QR_Ptr, Address); - - ------------ - -- Insqhi -- - ------------ - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Next : constant QR_Ptr := Hedr.Forward; - Itm : constant QR_Ptr := To_QR_Ptr (Item); - - begin - SSL.Lock_Task.all; - - Itm.Forward := Next; - Itm.Backward := Hedr; - Hedr.Forward := Itm; - - if Next = null then - Status := OK_First; - - else - Next.Backward := Itm; - Status := OK_Not_First; - end if; - - SSL.Unlock_Task.all; - end Insqhi; - - ------------ - -- Remqhi -- - ------------ - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Next : constant QR_Ptr := Hedr.Forward; - - begin - SSL.Lock_Task.all; - - Item := From_QR_Ptr (Next); - - if Next = null then - Status := Fail_Was_Empty; - - else - Hedr.Forward := To_QR_Ptr (Item).Forward; - - if Hedr.Forward = null then - Status := OK_Empty; - - else - Hedr.Forward.Backward := Hedr; - Status := OK_Not_Empty; - end if; - end if; - - SSL.Unlock_Task.all; - end Remqhi; - - ------------ - -- Insqti -- - ------------ - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Prev : constant QR_Ptr := Hedr.Backward; - Itm : constant QR_Ptr := To_QR_Ptr (Item); - - begin - SSL.Lock_Task.all; - - Itm.Backward := Prev; - Itm.Forward := Hedr; - Hedr.Backward := Itm; - - if Prev = null then - Status := OK_First; - - else - Prev.Forward := Itm; - Status := OK_Not_First; - end if; - - SSL.Unlock_Task.all; - end Insqti; - - ------------ - -- Remqti -- - ------------ - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status) - is - Hedr : constant QR_Ptr := To_QR_Ptr (Header); - Prev : constant QR_Ptr := Hedr.Backward; - - begin - SSL.Lock_Task.all; - - Item := From_QR_Ptr (Prev); - - if Prev = null then - Status := Fail_Was_Empty; - - else - Hedr.Backward := To_QR_Ptr (Item).Backward; - - if Hedr.Backward = null then - Status := OK_Empty; - - else - Hedr.Backward.Forward := Hedr; - Status := OK_Not_Empty; - end if; - end if; - - SSL.Unlock_Task.all; - end Remqti; - -end System.Aux_DEC; diff --git a/gcc/ada/s-auxdec.ads b/gcc/ada/s-auxdec.ads deleted file mode 100644 index 6ce87bd..0000000 --- a/gcc/ada/s-auxdec.ads +++ /dev/null @@ -1,654 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . A U X _ D E C -- --- -- --- S p e c -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains definitions that are designed to be compatible --- with the extra definitions in package System for DEC Ada implementations. - --- These definitions can be used directly by withing this package, or merged --- with System using pragma Extend_System (Aux_DEC) - -with Ada.Unchecked_Conversion; - -package System.Aux_DEC is - pragma Preelaborate; - - subtype Short_Address is Address; - -- For compatibility with systems having short and long addresses - - type Integer_8 is range -2 ** (8 - 1) .. +2 ** (8 - 1) - 1; - for Integer_8'Size use 8; - - type Integer_16 is range -2 ** (16 - 1) .. +2 ** (16 - 1) - 1; - for Integer_16'Size use 16; - - type Integer_32 is range -2 ** (32 - 1) .. +2 ** (32 - 1) - 1; - for Integer_32'Size use 32; - - type Integer_64 is range -2 ** (64 - 1) .. +2 ** (64 - 1) - 1; - for Integer_64'Size use 64; - - type Integer_8_Array is array (Integer range <>) of Integer_8; - type Integer_16_Array is array (Integer range <>) of Integer_16; - type Integer_32_Array is array (Integer range <>) of Integer_32; - type Integer_64_Array is array (Integer range <>) of Integer_64; - -- These array types are not in all versions of DEC System, and in fact it - -- is not quite clear why they are in some and not others, but since they - -- definitely appear in some versions, we include them unconditionally. - - type Largest_Integer is range Min_Int .. Max_Int; - - type AST_Handler is private; - - No_AST_Handler : constant AST_Handler; - - type Type_Class is - (Type_Class_Enumeration, - Type_Class_Integer, - Type_Class_Fixed_Point, - Type_Class_Floating_Point, - Type_Class_Array, - Type_Class_Record, - Type_Class_Access, - Type_Class_Task, -- also in Ada 95 protected - Type_Class_Address); - - function "not" (Left : Largest_Integer) return Largest_Integer; - function "and" (Left, Right : Largest_Integer) return Largest_Integer; - function "or" (Left, Right : Largest_Integer) return Largest_Integer; - function "xor" (Left, Right : Largest_Integer) return Largest_Integer; - - Address_Zero : constant Address; - No_Addr : constant Address; - Address_Size : constant := Standard'Address_Size; - Short_Address_Size : constant := Standard'Address_Size; - - function "+" (Left : Address; Right : Integer) return Address; - function "+" (Left : Integer; Right : Address) return Address; - function "-" (Left : Address; Right : Address) return Integer; - function "-" (Left : Address; Right : Integer) return Address; - - generic - type Target is private; - function Fetch_From_Address (A : Address) return Target; - - generic - type Target is private; - procedure Assign_To_Address (A : Address; T : Target); - - -- Floating point type declarations for VAX floating point data types - - type F_Float is digits 6; - type D_Float is digits 9; - type G_Float is digits 15; - -- We provide the type names, but these will be IEEE format, not VAX format - - -- Floating point type declarations for IEEE floating point data types - - type IEEE_Single_Float is digits 6; - type IEEE_Double_Float is digits 15; - - Non_Ada_Error : exception; - - -- Hardware-oriented types and functions - - type Bit_Array is array (Integer range <>) of Boolean; - pragma Pack (Bit_Array); - - subtype Bit_Array_8 is Bit_Array (0 .. 7); - subtype Bit_Array_16 is Bit_Array (0 .. 15); - subtype Bit_Array_32 is Bit_Array (0 .. 31); - subtype Bit_Array_64 is Bit_Array (0 .. 63); - - type Unsigned_Byte is range 0 .. 255; - for Unsigned_Byte'Size use 8; - - function "not" (Left : Unsigned_Byte) return Unsigned_Byte; - function "and" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - function "or" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - function "xor" (Left, Right : Unsigned_Byte) return Unsigned_Byte; - - function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte; - function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8; - - type Unsigned_Byte_Array is array (Integer range <>) of Unsigned_Byte; - - type Unsigned_Word is range 0 .. 65535; - for Unsigned_Word'Size use 16; - - function "not" (Left : Unsigned_Word) return Unsigned_Word; - function "and" (Left, Right : Unsigned_Word) return Unsigned_Word; - function "or" (Left, Right : Unsigned_Word) return Unsigned_Word; - function "xor" (Left, Right : Unsigned_Word) return Unsigned_Word; - - function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word; - function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16; - - type Unsigned_Word_Array is array (Integer range <>) of Unsigned_Word; - - type Unsigned_Longword is range -2_147_483_648 .. 2_147_483_647; - for Unsigned_Longword'Size use 32; - - function "not" (Left : Unsigned_Longword) return Unsigned_Longword; - function "and" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - function "or" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - function "xor" (Left, Right : Unsigned_Longword) return Unsigned_Longword; - - function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword; - function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32; - - type Unsigned_Longword_Array is - array (Integer range <>) of Unsigned_Longword; - - type Unsigned_32 is range 0 .. 4_294_967_295; - for Unsigned_32'Size use 32; - - function "not" (Left : Unsigned_32) return Unsigned_32; - function "and" (Left, Right : Unsigned_32) return Unsigned_32; - function "or" (Left, Right : Unsigned_32) return Unsigned_32; - function "xor" (Left, Right : Unsigned_32) return Unsigned_32; - - function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32; - function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32; - - type Unsigned_Quadword is record - L0 : Unsigned_Longword; - L1 : Unsigned_Longword; - end record; - - for Unsigned_Quadword'Size use 64; - for Unsigned_Quadword'Alignment use - Integer'Min (8, Standard'Maximum_Alignment); - - function "not" (Left : Unsigned_Quadword) return Unsigned_Quadword; - function "and" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - function "or" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - function "xor" (Left, Right : Unsigned_Quadword) return Unsigned_Quadword; - - function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword; - function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64; - - type Unsigned_Quadword_Array is - array (Integer range <>) of Unsigned_Quadword; - - function To_Address (X : Integer) return Address; - pragma Pure_Function (To_Address); - - function To_Address_Long (X : Unsigned_Longword) return Address; - pragma Pure_Function (To_Address_Long); - - function To_Integer (X : Address) return Integer; - - function To_Unsigned_Longword (X : Address) return Unsigned_Longword; - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword; - - -- Conventional names for static subtypes of type UNSIGNED_LONGWORD - - subtype Unsigned_1 is Unsigned_Longword range 0 .. 2** 1 - 1; - subtype Unsigned_2 is Unsigned_Longword range 0 .. 2** 2 - 1; - subtype Unsigned_3 is Unsigned_Longword range 0 .. 2** 3 - 1; - subtype Unsigned_4 is Unsigned_Longword range 0 .. 2** 4 - 1; - subtype Unsigned_5 is Unsigned_Longword range 0 .. 2** 5 - 1; - subtype Unsigned_6 is Unsigned_Longword range 0 .. 2** 6 - 1; - subtype Unsigned_7 is Unsigned_Longword range 0 .. 2** 7 - 1; - subtype Unsigned_8 is Unsigned_Longword range 0 .. 2** 8 - 1; - subtype Unsigned_9 is Unsigned_Longword range 0 .. 2** 9 - 1; - subtype Unsigned_10 is Unsigned_Longword range 0 .. 2**10 - 1; - subtype Unsigned_11 is Unsigned_Longword range 0 .. 2**11 - 1; - subtype Unsigned_12 is Unsigned_Longword range 0 .. 2**12 - 1; - subtype Unsigned_13 is Unsigned_Longword range 0 .. 2**13 - 1; - subtype Unsigned_14 is Unsigned_Longword range 0 .. 2**14 - 1; - subtype Unsigned_15 is Unsigned_Longword range 0 .. 2**15 - 1; - subtype Unsigned_16 is Unsigned_Longword range 0 .. 2**16 - 1; - subtype Unsigned_17 is Unsigned_Longword range 0 .. 2**17 - 1; - subtype Unsigned_18 is Unsigned_Longword range 0 .. 2**18 - 1; - subtype Unsigned_19 is Unsigned_Longword range 0 .. 2**19 - 1; - subtype Unsigned_20 is Unsigned_Longword range 0 .. 2**20 - 1; - subtype Unsigned_21 is Unsigned_Longword range 0 .. 2**21 - 1; - subtype Unsigned_22 is Unsigned_Longword range 0 .. 2**22 - 1; - subtype Unsigned_23 is Unsigned_Longword range 0 .. 2**23 - 1; - subtype Unsigned_24 is Unsigned_Longword range 0 .. 2**24 - 1; - subtype Unsigned_25 is Unsigned_Longword range 0 .. 2**25 - 1; - subtype Unsigned_26 is Unsigned_Longword range 0 .. 2**26 - 1; - subtype Unsigned_27 is Unsigned_Longword range 0 .. 2**27 - 1; - subtype Unsigned_28 is Unsigned_Longword range 0 .. 2**28 - 1; - subtype Unsigned_29 is Unsigned_Longword range 0 .. 2**29 - 1; - subtype Unsigned_30 is Unsigned_Longword range 0 .. 2**30 - 1; - subtype Unsigned_31 is Unsigned_Longword range 0 .. 2**31 - 1; - - -- Function for obtaining global symbol values - - function Import_Value (Symbol : String) return Unsigned_Longword; - function Import_Address (Symbol : String) return Address; - function Import_Largest_Value (Symbol : String) return Largest_Integer; - - pragma Import (Intrinsic, Import_Value); - pragma Import (Intrinsic, Import_Address); - pragma Import (Intrinsic, Import_Largest_Value); - - -- For the following declarations, note that the declaration without a - -- Retry_Count parameter means to retry infinitely. A value of zero for - -- the Retry_Count parameter means do not retry. - - -- Interlocked-instruction procedures - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean); - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean); - - type Aligned_Word is record - Value : Short_Integer; - end record; - - for Aligned_Word'Alignment use Integer'Min (2, Standard'Maximum_Alignment); - - procedure Clear_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean); - - procedure Set_Interlocked - (Bit : in out Boolean; - Old_Value : out Boolean; - Retry_Count : Natural; - Success_Flag : out Boolean); - - procedure Add_Interlocked - (Addend : Short_Integer; - Augend : in out Aligned_Word; - Sign : out Integer); - - type Aligned_Integer is record - Value : Integer; - end record; - - for Aligned_Integer'Alignment use - Integer'Min (4, Standard'Maximum_Alignment); - - type Aligned_Long_Integer is record - Value : Long_Integer; - end record; - - for Aligned_Long_Integer'Alignment use - Integer'Min (8, Standard'Maximum_Alignment); - - -- For the following declarations, note that the declaration without a - -- Retry_Count parameter mean to retry infinitely. A value of zero for - -- the Retry_Count means do not retry. - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer); - - procedure Add_Atomic - (To : in out Aligned_Integer; - Amount : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer); - - procedure Add_Atomic - (To : in out Aligned_Long_Integer; - Amount : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer); - - procedure And_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer); - - procedure And_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer); - - procedure Or_Atomic - (To : in out Aligned_Integer; - From : Integer; - Retry_Count : Natural; - Old_Value : out Integer; - Success_Flag : out Boolean); - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer); - - procedure Or_Atomic - (To : in out Aligned_Long_Integer; - From : Long_Integer; - Retry_Count : Natural; - Old_Value : out Long_Integer; - Success_Flag : out Boolean); - - type Insq_Status is (Fail_No_Lock, OK_Not_First, OK_First); - - for Insq_Status use - (Fail_No_Lock => -1, - OK_Not_First => 0, - OK_First => +1); - - type Remq_Status is ( - Fail_No_Lock, - Fail_Was_Empty, - OK_Not_Empty, - OK_Empty); - - for Remq_Status use - (Fail_No_Lock => -1, - Fail_Was_Empty => 0, - OK_Not_Empty => +1, - OK_Empty => +2); - - procedure Insqhi - (Item : Address; - Header : Address; - Status : out Insq_Status); - - procedure Remqhi - (Header : Address; - Item : out Address; - Status : out Remq_Status); - - procedure Insqti - (Item : Address; - Header : Address; - Status : out Insq_Status); - - procedure Remqti - (Header : Address; - Item : out Address; - Status : out Remq_Status); - -private - - Address_Zero : constant Address := Null_Address; - No_Addr : constant Address := Null_Address; - - -- An AST_Handler value is from a typing point of view simply a pointer - -- to a procedure taking a single 64 bit parameter. However, this - -- is a bit misleading, because the data that this pointer references is - -- highly stylized. See body of System.AST_Handling for full details. - - type AST_Handler is access procedure (Param : Long_Integer); - No_AST_Handler : constant AST_Handler := null; - - -- Other operators have incorrect profiles. It would be nice to make - -- them intrinsic, since the backend can handle them, but the front - -- end is not prepared to deal with them, so at least inline them. - - pragma Inline_Always ("+"); - pragma Inline_Always ("-"); - pragma Inline_Always ("not"); - pragma Inline_Always ("and"); - pragma Inline_Always ("or"); - pragma Inline_Always ("xor"); - - -- Other inlined subprograms - - pragma Inline_Always (Fetch_From_Address); - pragma Inline_Always (Assign_To_Address); - - -- Synchronization related subprograms. Mechanism is explicitly set - -- so that the critical parameters are passed by reference. - -- Without this, the parameters are passed by copy, creating load/store - -- race conditions. We also inline them, since this seems more in the - -- spirit of the original (hardware intrinsic) routines. - - pragma Export_Procedure - (Clear_Interlocked, - External => "system__aux_dec__clear_interlocked__1", - Parameter_Types => (Boolean, Boolean), - Mechanism => (Reference, Reference)); - pragma Export_Procedure - (Clear_Interlocked, - External => "system__aux_dec__clear_interlocked__2", - Parameter_Types => (Boolean, Boolean, Natural, Boolean), - Mechanism => (Reference, Reference, Value, Reference)); - pragma Inline_Always (Clear_Interlocked); - - pragma Export_Procedure - (Set_Interlocked, - External => "system__aux_dec__set_interlocked__1", - Parameter_Types => (Boolean, Boolean), - Mechanism => (Reference, Reference)); - pragma Export_Procedure - (Set_Interlocked, - External => "system__aux_dec__set_interlocked__2", - Parameter_Types => (Boolean, Boolean, Natural, Boolean), - Mechanism => (Reference, Reference, Value, Reference)); - pragma Inline_Always (Set_Interlocked); - - pragma Export_Procedure - (Add_Interlocked, - External => "system__aux_dec__add_interlocked__1", - Mechanism => (Value, Reference, Reference)); - pragma Inline_Always (Add_Interlocked); - - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Add_Atomic, - External => "system__aux_dec__add_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (Add_Atomic); - - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (And_Atomic, - External => "system__aux_dec__and_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (And_Atomic); - - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__1", - Parameter_Types => (Aligned_Integer, Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__2", - Parameter_Types => (Aligned_Integer, Integer, Natural, Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__3", - Parameter_Types => (Aligned_Long_Integer, Long_Integer), - Mechanism => (Reference, Value)); - pragma Export_Procedure - (Or_Atomic, - External => "system__aux_dec__or_atomic__4", - Parameter_Types => (Aligned_Long_Integer, Long_Integer, Natural, - Long_Integer, Boolean), - Mechanism => (Reference, Value, Value, Reference, Reference)); - pragma Inline_Always (Or_Atomic); - - -- Provide proper unchecked conversion definitions for transfer - -- functions. Note that we need this level of indirection because - -- the formal parameter name is X and not Source (and this is indeed - -- detectable by a program) - - function To_Unsigned_Byte_A is new - Ada.Unchecked_Conversion (Bit_Array_8, Unsigned_Byte); - - function To_Unsigned_Byte (X : Bit_Array_8) return Unsigned_Byte - renames To_Unsigned_Byte_A; - - function To_Bit_Array_8_A is new - Ada.Unchecked_Conversion (Unsigned_Byte, Bit_Array_8); - - function To_Bit_Array_8 (X : Unsigned_Byte) return Bit_Array_8 - renames To_Bit_Array_8_A; - - function To_Unsigned_Word_A is new - Ada.Unchecked_Conversion (Bit_Array_16, Unsigned_Word); - - function To_Unsigned_Word (X : Bit_Array_16) return Unsigned_Word - renames To_Unsigned_Word_A; - - function To_Bit_Array_16_A is new - Ada.Unchecked_Conversion (Unsigned_Word, Bit_Array_16); - - function To_Bit_Array_16 (X : Unsigned_Word) return Bit_Array_16 - renames To_Bit_Array_16_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_Longword); - - function To_Unsigned_Longword (X : Bit_Array_32) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - function To_Bit_Array_32_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Bit_Array_32); - - function To_Bit_Array_32 (X : Unsigned_Longword) return Bit_Array_32 - renames To_Bit_Array_32_A; - - function To_Unsigned_32_A is new - Ada.Unchecked_Conversion (Bit_Array_32, Unsigned_32); - - function To_Unsigned_32 (X : Bit_Array_32) return Unsigned_32 - renames To_Unsigned_32_A; - - function To_Bit_Array_32_A is new - Ada.Unchecked_Conversion (Unsigned_32, Bit_Array_32); - - function To_Bit_Array_32 (X : Unsigned_32) return Bit_Array_32 - renames To_Bit_Array_32_A; - - function To_Unsigned_Quadword_A is new - Ada.Unchecked_Conversion (Bit_Array_64, Unsigned_Quadword); - - function To_Unsigned_Quadword (X : Bit_Array_64) return Unsigned_Quadword - renames To_Unsigned_Quadword_A; - - function To_Bit_Array_64_A is new - Ada.Unchecked_Conversion (Unsigned_Quadword, Bit_Array_64); - - function To_Bit_Array_64 (X : Unsigned_Quadword) return Bit_Array_64 - renames To_Bit_Array_64_A; - - pragma Warnings (Off); - -- Turn warnings off. This is needed for systems with 64-bit integers, - -- where some of these operations are of dubious meaning, but we do not - -- want warnings when we compile on such systems. - - function To_Address_A is new - Ada.Unchecked_Conversion (Integer, Address); - pragma Pure_Function (To_Address_A); - - function To_Address (X : Integer) return Address - renames To_Address_A; - pragma Pure_Function (To_Address); - - function To_Address_Long_A is new - Ada.Unchecked_Conversion (Unsigned_Longword, Address); - pragma Pure_Function (To_Address_Long_A); - - function To_Address_Long (X : Unsigned_Longword) return Address - renames To_Address_Long_A; - pragma Pure_Function (To_Address_Long); - - function To_Integer_A is new - Ada.Unchecked_Conversion (Address, Integer); - - function To_Integer (X : Address) return Integer - renames To_Integer_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (Address, Unsigned_Longword); - - function To_Unsigned_Longword (X : Address) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - function To_Unsigned_Longword_A is new - Ada.Unchecked_Conversion (AST_Handler, Unsigned_Longword); - - function To_Unsigned_Longword (X : AST_Handler) return Unsigned_Longword - renames To_Unsigned_Longword_A; - - pragma Warnings (On); - -end System.Aux_DEC; diff --git a/gcc/ada/s-bignum.adb b/gcc/ada/s-bignum.adb deleted file mode 100644 index 18f62c7..0000000 --- a/gcc/ada/s-bignum.adb +++ /dev/null @@ -1,1105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . B I G N U M S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2012-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides arbitrary precision signed integer arithmetic for --- use in computing intermediate values in expressions for the case where --- pragma Overflow_Check (Eliminate) is in effect. - -with System; use System; -with System.Secondary_Stack; use System.Secondary_Stack; -with System.Storage_Elements; use System.Storage_Elements; - -package body System.Bignums is - - use Interfaces; - -- So that operations on Unsigned_32 are available - - type DD is mod Base ** 2; - -- Double length digit used for intermediate computations - - function MSD (X : DD) return SD is (SD (X / Base)); - function LSD (X : DD) return SD is (SD (X mod Base)); - -- Most significant and least significant digit of double digit value - - function "&" (X, Y : SD) return DD is (DD (X) * Base + DD (Y)); - -- Compose double digit value from two single digit values - - subtype LLI is Long_Long_Integer; - - One_Data : constant Digit_Vector (1 .. 1) := (1 => 1); - -- Constant one - - Zero_Data : constant Digit_Vector (1 .. 0) := (1 .. 0 => 0); - -- Constant zero - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Add - (X, Y : Digit_Vector; - X_Neg : Boolean; - Y_Neg : Boolean) return Bignum - with - Pre => X'First = 1 and then Y'First = 1; - -- This procedure adds two signed numbers returning the Sum, it is used - -- for both addition and subtraction. The value computed is X + Y, with - -- X_Neg and Y_Neg giving the signs of the operands. - - function Allocate_Bignum (Len : Length) return Bignum with - Post => Allocate_Bignum'Result.Len = Len; - -- Allocate Bignum value of indicated length on secondary stack. On return - -- the Neg and D fields are left uninitialized. - - type Compare_Result is (LT, EQ, GT); - -- Indicates result of comparison in following call - - function Compare - (X, Y : Digit_Vector; - X_Neg, Y_Neg : Boolean) return Compare_Result - with - Pre => X'First = 1 and then Y'First = 1; - -- Compare (X with sign X_Neg) with (Y with sign Y_Neg), and return the - -- result of the signed comparison. - - procedure Div_Rem - (X, Y : Bignum; - Quotient : out Bignum; - Remainder : out Bignum; - Discard_Quotient : Boolean := False; - Discard_Remainder : Boolean := False); - -- Returns the Quotient and Remainder from dividing abs (X) by abs (Y). The - -- values of X and Y are not modified. If Discard_Quotient is True, then - -- Quotient is undefined on return, and if Discard_Remainder is True, then - -- Remainder is undefined on return. Service routine for Big_Div/Rem/Mod. - - procedure Free_Bignum (X : Bignum) is null; - -- Called to free a Bignum value used in intermediate computations. In - -- this implementation using the secondary stack, it does nothing at all, - -- because we rely on Mark/Release, but it may be of use for some - -- alternative implementation. - - function Normalize - (X : Digit_Vector; - Neg : Boolean := False) return Bignum; - -- Given a digit vector and sign, allocate and construct a Bignum value. - -- Note that X may have leading zeroes which must be removed, and if the - -- result is zero, the sign is forced positive. - - --------- - -- Add -- - --------- - - function Add - (X, Y : Digit_Vector; - X_Neg : Boolean; - Y_Neg : Boolean) return Bignum - is - begin - -- If signs are the same, we are doing an addition, it is convenient to - -- ensure that the first operand is the longer of the two. - - if X_Neg = Y_Neg then - if X'Last < Y'Last then - return Add (X => Y, Y => X, X_Neg => Y_Neg, Y_Neg => X_Neg); - - -- Here signs are the same, and the first operand is the longer - - else - pragma Assert (X_Neg = Y_Neg and then X'Last >= Y'Last); - - -- Do addition, putting result in Sum (allowing for carry) - - declare - Sum : Digit_Vector (0 .. X'Last); - RD : DD; - - begin - RD := 0; - for J in reverse 1 .. X'Last loop - RD := RD + DD (X (J)); - - if J >= 1 + (X'Last - Y'Last) then - RD := RD + DD (Y (J - (X'Last - Y'Last))); - end if; - - Sum (J) := LSD (RD); - RD := RD / Base; - end loop; - - Sum (0) := SD (RD); - return Normalize (Sum, X_Neg); - end; - end if; - - -- Signs are different so really this is a subtraction, we want to make - -- sure that the largest magnitude operand is the first one, and then - -- the result will have the sign of the first operand. - - else - declare - CR : constant Compare_Result := Compare (X, Y, False, False); - - begin - if CR = EQ then - return Normalize (Zero_Data); - - elsif CR = LT then - return Add (X => Y, Y => X, X_Neg => Y_Neg, Y_Neg => X_Neg); - - else - pragma Assert (X_Neg /= Y_Neg and then CR = GT); - - -- Do subtraction, putting result in Diff - - declare - Diff : Digit_Vector (1 .. X'Length); - RD : DD; - - begin - RD := 0; - for J in reverse 1 .. X'Last loop - RD := RD + DD (X (J)); - - if J >= 1 + (X'Last - Y'Last) then - RD := RD - DD (Y (J - (X'Last - Y'Last))); - end if; - - Diff (J) := LSD (RD); - RD := (if RD < Base then 0 else -1); - end loop; - - return Normalize (Diff, X_Neg); - end; - end if; - end; - end if; - end Add; - - --------------------- - -- Allocate_Bignum -- - --------------------- - - function Allocate_Bignum (Len : Length) return Bignum is - Addr : Address; - - begin - -- Change the if False here to if True to get allocation on the heap - -- instead of the secondary stack, which is convenient for debugging - -- System.Bignum itself. - - if False then - declare - B : Bignum; - begin - B := new Bignum_Data'(Len, False, (others => 0)); - return B; - end; - - -- Normal case of allocation on the secondary stack - - else - -- Note: The approach used here is designed to avoid strict aliasing - -- warnings that appeared previously using unchecked conversion. - - SS_Allocate (Addr, Storage_Offset (4 + 4 * Len)); - - declare - B : Bignum; - for B'Address use Addr'Address; - pragma Import (Ada, B); - - BD : Bignum_Data (Len); - for BD'Address use Addr; - pragma Import (Ada, BD); - - -- Expose a writable view of discriminant BD.Len so that we can - -- initialize it. We need to use the exact layout of the record - -- to ensure that the Length field has 24 bits as expected. - - type Bignum_Data_Header is record - Len : Length; - Neg : Boolean; - end record; - - for Bignum_Data_Header use record - Len at 0 range 0 .. 23; - Neg at 3 range 0 .. 7; - end record; - - BDH : Bignum_Data_Header; - for BDH'Address use BD'Address; - pragma Import (Ada, BDH); - - pragma Assert (BDH.Len'Size = BD.Len'Size); - - begin - BDH.Len := Len; - return B; - end; - end if; - end Allocate_Bignum; - - ------------- - -- Big_Abs -- - ------------- - - function Big_Abs (X : Bignum) return Bignum is - begin - return Normalize (X.D); - end Big_Abs; - - ------------- - -- Big_Add -- - ------------- - - function Big_Add (X, Y : Bignum) return Bignum is - begin - return Add (X.D, Y.D, X.Neg, Y.Neg); - end Big_Add; - - ------------- - -- Big_Div -- - ------------- - - -- This table is excerpted from RM 4.5.5(28-30) and shows how the result - -- varies with the signs of the operands. - - -- A B A/B A B A/B - -- - -- 10 5 2 -10 5 -2 - -- 11 5 2 -11 5 -2 - -- 12 5 2 -12 5 -2 - -- 13 5 2 -13 5 -2 - -- 14 5 2 -14 5 -2 - -- - -- A B A/B A B A/B - -- - -- 10 -5 -2 -10 -5 2 - -- 11 -5 -2 -11 -5 2 - -- 12 -5 -2 -12 -5 2 - -- 13 -5 -2 -13 -5 2 - -- 14 -5 -2 -14 -5 2 - - function Big_Div (X, Y : Bignum) return Bignum is - Q, R : Bignum; - begin - Div_Rem (X, Y, Q, R, Discard_Remainder => True); - Q.Neg := Q.Len > 0 and then (X.Neg xor Y.Neg); - return Q; - end Big_Div; - - ------------- - -- Big_Exp -- - ------------- - - function Big_Exp (X, Y : Bignum) return Bignum is - - function "**" (X : Bignum; Y : SD) return Bignum; - -- Internal routine where we know right operand is one word - - ---------- - -- "**" -- - ---------- - - function "**" (X : Bignum; Y : SD) return Bignum is - begin - case Y is - - -- X ** 0 is 1 - - when 0 => - return Normalize (One_Data); - - -- X ** 1 is X - - when 1 => - return Normalize (X.D); - - -- X ** 2 is X * X - - when 2 => - return Big_Mul (X, X); - - -- For X greater than 2, use the recursion - - -- X even, X ** Y = (X ** (Y/2)) ** 2; - -- X odd, X ** Y = (X ** (Y/2)) ** 2 * X; - - when others => - declare - XY2 : constant Bignum := X ** (Y / 2); - XY2S : constant Bignum := Big_Mul (XY2, XY2); - Res : Bignum; - - begin - Free_Bignum (XY2); - - -- Raise storage error if intermediate value is getting too - -- large, which we arbitrarily define as 200 words for now. - - if XY2S.Len > 200 then - Free_Bignum (XY2S); - raise Storage_Error with - "exponentiation result is too large"; - end if; - - -- Otherwise take care of even/odd cases - - if (Y and 1) = 0 then - return XY2S; - - else - Res := Big_Mul (XY2S, X); - Free_Bignum (XY2S); - return Res; - end if; - end; - end case; - end "**"; - - -- Start of processing for Big_Exp - - begin - -- Error if right operand negative - - if Y.Neg then - raise Constraint_Error with "exponentiation to negative power"; - - -- X ** 0 is always 1 (including 0 ** 0, so do this test first) - - elsif Y.Len = 0 then - return Normalize (One_Data); - - -- 0 ** X is always 0 (for X non-zero) - - elsif X.Len = 0 then - return Normalize (Zero_Data); - - -- (+1) ** Y = 1 - -- (-1) ** Y = +/-1 depending on whether Y is even or odd - - elsif X.Len = 1 and then X.D (1) = 1 then - return Normalize - (X.D, Neg => X.Neg and then ((Y.D (Y.Len) and 1) = 1)); - - -- If the absolute value of the base is greater than 1, then the - -- exponent must not be bigger than one word, otherwise the result - -- is ludicrously large, and we just signal Storage_Error right away. - - elsif Y.Len > 1 then - raise Storage_Error with "exponentiation result is too large"; - - -- Special case (+/-)2 ** K, where K is 1 .. 31 using a shift - - elsif X.Len = 1 and then X.D (1) = 2 and then Y.D (1) < 32 then - declare - D : constant Digit_Vector (1 .. 1) := - (1 => Shift_Left (SD'(1), Natural (Y.D (1)))); - begin - return Normalize (D, X.Neg); - end; - - -- Remaining cases have right operand of one word - - else - return X ** Y.D (1); - end if; - end Big_Exp; - - ------------ - -- Big_EQ -- - ------------ - - function Big_EQ (X, Y : Bignum) return Boolean is - begin - return Compare (X.D, Y.D, X.Neg, Y.Neg) = EQ; - end Big_EQ; - - ------------ - -- Big_GE -- - ------------ - - function Big_GE (X, Y : Bignum) return Boolean is - begin - return Compare (X.D, Y.D, X.Neg, Y.Neg) /= LT; - end Big_GE; - - ------------ - -- Big_GT -- - ------------ - - function Big_GT (X, Y : Bignum) return Boolean is - begin - return Compare (X.D, Y.D, X.Neg, Y.Neg) = GT; - end Big_GT; - - ------------ - -- Big_LE -- - ------------ - - function Big_LE (X, Y : Bignum) return Boolean is - begin - return Compare (X.D, Y.D, X.Neg, Y.Neg) /= GT; - end Big_LE; - - ------------ - -- Big_LT -- - ------------ - - function Big_LT (X, Y : Bignum) return Boolean is - begin - return Compare (X.D, Y.D, X.Neg, Y.Neg) = LT; - end Big_LT; - - ------------- - -- Big_Mod -- - ------------- - - -- This table is excerpted from RM 4.5.5(28-30) and shows how the result - -- of Rem and Mod vary with the signs of the operands. - - -- A B A mod B A rem B A B A mod B A rem B - - -- 10 5 0 0 -10 5 0 0 - -- 11 5 1 1 -11 5 4 -1 - -- 12 5 2 2 -12 5 3 -2 - -- 13 5 3 3 -13 5 2 -3 - -- 14 5 4 4 -14 5 1 -4 - - -- A B A mod B A rem B A B A mod B A rem B - - -- 10 -5 0 0 -10 -5 0 0 - -- 11 -5 -4 1 -11 -5 -1 -1 - -- 12 -5 -3 2 -12 -5 -2 -2 - -- 13 -5 -2 3 -13 -5 -3 -3 - -- 14 -5 -1 4 -14 -5 -4 -4 - - function Big_Mod (X, Y : Bignum) return Bignum is - Q, R : Bignum; - - begin - -- If signs are same, result is same as Rem - - if X.Neg = Y.Neg then - return Big_Rem (X, Y); - - -- Case where Mod is different - - else - -- Do division - - Div_Rem (X, Y, Q, R, Discard_Quotient => True); - - -- Zero result is unchanged - - if R.Len = 0 then - return R; - - -- Otherwise adjust result - - else - declare - T1 : constant Bignum := Big_Sub (Y, R); - begin - T1.Neg := Y.Neg; - Free_Bignum (R); - return T1; - end; - end if; - end if; - end Big_Mod; - - ------------- - -- Big_Mul -- - ------------- - - function Big_Mul (X, Y : Bignum) return Bignum is - Result : Digit_Vector (1 .. X.Len + Y.Len) := (others => 0); - -- Accumulate result (max length of result is sum of operand lengths) - - L : Length; - -- Current result digit - - D : DD; - -- Result digit - - begin - for J in 1 .. X.Len loop - for K in 1 .. Y.Len loop - L := Result'Last - (X.Len - J) - (Y.Len - K); - D := DD (X.D (J)) * DD (Y.D (K)) + DD (Result (L)); - Result (L) := LSD (D); - D := D / Base; - - -- D is carry which must be propagated - - while D /= 0 and then L >= 1 loop - L := L - 1; - D := D + DD (Result (L)); - Result (L) := LSD (D); - D := D / Base; - end loop; - - -- Must not have a carry trying to extend max length - - pragma Assert (D = 0); - end loop; - end loop; - - -- Return result - - return Normalize (Result, X.Neg xor Y.Neg); - end Big_Mul; - - ------------ - -- Big_NE -- - ------------ - - function Big_NE (X, Y : Bignum) return Boolean is - begin - return Compare (X.D, Y.D, X.Neg, Y.Neg) /= EQ; - end Big_NE; - - ------------- - -- Big_Neg -- - ------------- - - function Big_Neg (X : Bignum) return Bignum is - begin - return Normalize (X.D, not X.Neg); - end Big_Neg; - - ------------- - -- Big_Rem -- - ------------- - - -- This table is excerpted from RM 4.5.5(28-30) and shows how the result - -- varies with the signs of the operands. - - -- A B A rem B A B A rem B - - -- 10 5 0 -10 5 0 - -- 11 5 1 -11 5 -1 - -- 12 5 2 -12 5 -2 - -- 13 5 3 -13 5 -3 - -- 14 5 4 -14 5 -4 - - -- A B A rem B A B A rem B - - -- 10 -5 0 -10 -5 0 - -- 11 -5 1 -11 -5 -1 - -- 12 -5 2 -12 -5 -2 - -- 13 -5 3 -13 -5 -3 - -- 14 -5 4 -14 -5 -4 - - function Big_Rem (X, Y : Bignum) return Bignum is - Q, R : Bignum; - begin - Div_Rem (X, Y, Q, R, Discard_Quotient => True); - R.Neg := R.Len > 0 and then X.Neg; - return R; - end Big_Rem; - - ------------- - -- Big_Sub -- - ------------- - - function Big_Sub (X, Y : Bignum) return Bignum is - begin - -- If right operand zero, return left operand (avoiding sharing) - - if Y.Len = 0 then - return Normalize (X.D, X.Neg); - - -- Otherwise add negative of right operand - - else - return Add (X.D, Y.D, X.Neg, not Y.Neg); - end if; - end Big_Sub; - - ------------- - -- Compare -- - ------------- - - function Compare - (X, Y : Digit_Vector; - X_Neg, Y_Neg : Boolean) return Compare_Result - is - begin - -- Signs are different, that's decisive, since 0 is always plus - - if X_Neg /= Y_Neg then - return (if X_Neg then LT else GT); - - -- Lengths are different, that's decisive since no leading zeroes - - elsif X'Last /= Y'Last then - return (if (X'Last > Y'Last) xor X_Neg then GT else LT); - - -- Need to compare data - - else - for J in X'Range loop - if X (J) /= Y (J) then - return (if (X (J) > Y (J)) xor X_Neg then GT else LT); - end if; - end loop; - - return EQ; - end if; - end Compare; - - ------------- - -- Div_Rem -- - ------------- - - procedure Div_Rem - (X, Y : Bignum; - Quotient : out Bignum; - Remainder : out Bignum; - Discard_Quotient : Boolean := False; - Discard_Remainder : Boolean := False) - is - begin - -- Error if division by zero - - if Y.Len = 0 then - raise Constraint_Error with "division by zero"; - end if; - - -- Handle simple cases with special tests - - -- If X < Y then quotient is zero and remainder is X - - if Compare (X.D, Y.D, False, False) = LT then - Remainder := Normalize (X.D); - Quotient := Normalize (Zero_Data); - return; - - -- If both X and Y are less than 2**63-1, we can use Long_Long_Integer - -- arithmetic. Note it is good not to do an accurate range check against - -- Long_Long_Integer since -2**63 / -1 overflows. - - elsif (X.Len <= 1 or else (X.Len = 2 and then X.D (1) < 2**31)) - and then - (Y.Len <= 1 or else (Y.Len = 2 and then Y.D (1) < 2**31)) - then - declare - A : constant LLI := abs (From_Bignum (X)); - B : constant LLI := abs (From_Bignum (Y)); - begin - Quotient := To_Bignum (A / B); - Remainder := To_Bignum (A rem B); - return; - end; - - -- Easy case if divisor is one digit - - elsif Y.Len = 1 then - declare - ND : DD; - Div : constant DD := DD (Y.D (1)); - - Result : Digit_Vector (1 .. X.Len); - Remdr : Digit_Vector (1 .. 1); - - begin - ND := 0; - for J in 1 .. X.Len loop - ND := Base * ND + DD (X.D (J)); - Result (J) := SD (ND / Div); - ND := ND rem Div; - end loop; - - Quotient := Normalize (Result); - Remdr (1) := SD (ND); - Remainder := Normalize (Remdr); - return; - end; - end if; - - -- The complex full multi-precision case. We will employ algorithm - -- D defined in the section "The Classical Algorithms" (sec. 4.3.1) - -- of Donald Knuth's "The Art of Computer Programming", Vol. 2, 2nd - -- edition. The terminology is adjusted for this section to match that - -- reference. - - -- We are dividing X.Len digits of X (called u here) by Y.Len digits - -- of Y (called v here), developing the quotient and remainder. The - -- numbers are represented using Base, which was chosen so that we have - -- the operations of multiplying to single digits (SD) to form a double - -- digit (DD), and dividing a double digit (DD) by a single digit (SD) - -- to give a single digit quotient and a single digit remainder. - - -- Algorithm D from Knuth - - -- Comments here with square brackets are directly from Knuth - - Algorithm_D : declare - - -- The following lower case variables correspond exactly to the - -- terminology used in algorithm D. - - m : constant Length := X.Len - Y.Len; - n : constant Length := Y.Len; - b : constant DD := Base; - - u : Digit_Vector (0 .. m + n); - v : Digit_Vector (1 .. n); - q : Digit_Vector (0 .. m); - r : Digit_Vector (1 .. n); - - u0 : SD renames u (0); - v1 : SD renames v (1); - v2 : SD renames v (2); - - d : DD; - j : Length; - qhat : DD; - rhat : DD; - temp : DD; - - begin - -- Initialize data of left and right operands - - for J in 1 .. m + n loop - u (J) := X.D (J); - end loop; - - for J in 1 .. n loop - v (J) := Y.D (J); - end loop; - - -- [Division of nonnegative integers.] Given nonnegative integers u - -- = (ul,u2..um+n) and v = (v1,v2..vn), where v1 /= 0 and n > 1, we - -- form the quotient u / v = (q0,ql..qm) and the remainder u mod v = - -- (r1,r2..rn). - - pragma Assert (v1 /= 0); - pragma Assert (n > 1); - - -- Dl. [Normalize.] Set d = b/(vl + 1). Then set (u0,u1,u2..um+n) - -- equal to (u1,u2..um+n) times d, and set (v1,v2..vn) equal to - -- (v1,v2..vn) times d. Note the introduction of a new digit position - -- u0 at the left of u1; if d = 1 all we need to do in this step is - -- to set u0 = 0. - - d := b / (DD (v1) + 1); - - if d = 1 then - u0 := 0; - - else - declare - Carry : DD; - Tmp : DD; - - begin - -- Multiply Dividend (u) by d - - Carry := 0; - for J in reverse 1 .. m + n loop - Tmp := DD (u (J)) * d + Carry; - u (J) := LSD (Tmp); - Carry := Tmp / Base; - end loop; - - u0 := SD (Carry); - - -- Multiply Divisor (v) by d - - Carry := 0; - for J in reverse 1 .. n loop - Tmp := DD (v (J)) * d + Carry; - v (J) := LSD (Tmp); - Carry := Tmp / Base; - end loop; - - pragma Assert (Carry = 0); - end; - end if; - - -- D2. [Initialize j.] Set j = 0. The loop on j, steps D2 through D7, - -- will be essentially a division of (uj, uj+1..uj+n) by (v1,v2..vn) - -- to get a single quotient digit qj. - - j := 0; - - -- Loop through digits - - loop - -- Note: In the original printing, step D3 was as follows: - - -- D3. [Calculate qhat.] If uj = v1, set qhat to b-l; otherwise - -- set qhat to (uj,uj+1)/v1. Now test if v2 * qhat is greater than - -- (uj*b + uj+1 - qhat*v1)*b + uj+2. If so, decrease qhat by 1 and - -- repeat this test - - -- This had a bug not discovered till 1995, see Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/err2-2e.ps.gz. Under - -- rare circumstances the expression in the test could overflow. - -- This version was further corrected in 2005, see Vol 2 errata: - -- http://www-cs-faculty.stanford.edu/~uno/all2-pre.ps.gz. - -- The code below is the fixed version of this step. - - -- D3. [Calculate qhat.] Set qhat to (uj,uj+1)/v1 and rhat to - -- to (uj,uj+1) mod v1. - - temp := u (j) & u (j + 1); - qhat := temp / DD (v1); - rhat := temp mod DD (v1); - - -- D3 (continued). Now test if qhat >= b or v2*qhat > (rhat,uj+2): - -- if so, decrease qhat by 1, increase rhat by v1, and repeat this - -- test if rhat < b. [The test on v2 determines at high speed - -- most of the cases in which the trial value qhat is one too - -- large, and eliminates all cases where qhat is two too large.] - - while qhat >= b - or else DD (v2) * qhat > LSD (rhat) & u (j + 2) - loop - qhat := qhat - 1; - rhat := rhat + DD (v1); - exit when rhat >= b; - end loop; - - -- D4. [Multiply and subtract.] Replace (uj,uj+1..uj+n) by - -- (uj,uj+1..uj+n) minus qhat times (v1,v2..vn). This step - -- consists of a simple multiplication by a one-place number, - -- combined with a subtraction. - - -- The digits (uj,uj+1..uj+n) are always kept positive; if the - -- result of this step is actually negative then (uj,uj+1..uj+n) - -- is left as the true value plus b**(n+1), i.e. as the b's - -- complement of the true value, and a "borrow" to the left is - -- remembered. - - declare - Borrow : SD; - Carry : DD; - Temp : DD; - - Negative : Boolean; - -- Records if subtraction causes a negative result, requiring - -- an add back (case where qhat turned out to be 1 too large). - - begin - Borrow := 0; - for K in reverse 1 .. n loop - Temp := qhat * DD (v (K)) + DD (Borrow); - Borrow := MSD (Temp); - - if LSD (Temp) > u (j + K) then - Borrow := Borrow + 1; - end if; - - u (j + K) := u (j + K) - LSD (Temp); - end loop; - - Negative := u (j) < Borrow; - u (j) := u (j) - Borrow; - - -- D5. [Test remainder.] Set qj = qhat. If the result of step - -- D4 was negative, we will do the add back step (step D6). - - q (j) := LSD (qhat); - - if Negative then - - -- D6. [Add back.] Decrease qj by 1, and add (0,v1,v2..vn) - -- to (uj,uj+1,uj+2..uj+n). (A carry will occur to the left - -- of uj, and it is be ignored since it cancels with the - -- borrow that occurred in D4.) - - q (j) := q (j) - 1; - - Carry := 0; - for K in reverse 1 .. n loop - Temp := DD (v (K)) + DD (u (j + K)) + Carry; - u (j + K) := LSD (Temp); - Carry := Temp / Base; - end loop; - - u (j) := u (j) + SD (Carry); - end if; - end; - - -- D7. [Loop on j.] Increase j by one. Now if j <= m, go back to - -- D3 (the start of the loop on j). - - j := j + 1; - exit when not (j <= m); - end loop; - - -- D8. [Unnormalize.] Now (qo,ql..qm) is the desired quotient, and - -- the desired remainder may be obtained by dividing (um+1..um+n) - -- by d. - - if not Discard_Quotient then - Quotient := Normalize (q); - end if; - - if not Discard_Remainder then - declare - Remdr : DD; - - begin - Remdr := 0; - for K in 1 .. n loop - Remdr := Base * Remdr + DD (u (m + K)); - r (K) := SD (Remdr / d); - Remdr := Remdr rem d; - end loop; - - pragma Assert (Remdr = 0); - end; - - Remainder := Normalize (r); - end if; - end Algorithm_D; - end Div_Rem; - - ----------------- - -- From_Bignum -- - ----------------- - - function From_Bignum (X : Bignum) return Long_Long_Integer is - begin - if X.Len = 0 then - return 0; - - elsif X.Len = 1 then - return (if X.Neg then -LLI (X.D (1)) else LLI (X.D (1))); - - elsif X.Len = 2 then - declare - Mag : constant DD := X.D (1) & X.D (2); - begin - if X.Neg and then Mag <= 2 ** 63 then - return -LLI (Mag); - elsif Mag < 2 ** 63 then - return LLI (Mag); - end if; - end; - end if; - - raise Constraint_Error with "expression value out of range"; - end From_Bignum; - - ------------------------- - -- Bignum_In_LLI_Range -- - ------------------------- - - function Bignum_In_LLI_Range (X : Bignum) return Boolean is - begin - -- If length is 0 or 1, definitely fits - - if X.Len <= 1 then - return True; - - -- If length is greater than 2, definitely does not fit - - elsif X.Len > 2 then - return False; - - -- Length is 2, more tests needed - - else - declare - Mag : constant DD := X.D (1) & X.D (2); - begin - return Mag < 2 ** 63 or else (X.Neg and then Mag = 2 ** 63); - end; - end if; - end Bignum_In_LLI_Range; - - --------------- - -- Normalize -- - --------------- - - function Normalize - (X : Digit_Vector; - Neg : Boolean := False) return Bignum - is - B : Bignum; - J : Length; - - begin - J := X'First; - while J <= X'Last and then X (J) = 0 loop - J := J + 1; - end loop; - - B := Allocate_Bignum (X'Last - J + 1); - B.Neg := B.Len > 0 and then Neg; - B.D := X (J .. X'Last); - return B; - end Normalize; - - --------------- - -- To_Bignum -- - --------------- - - function To_Bignum (X : Long_Long_Integer) return Bignum is - R : Bignum; - - begin - if X = 0 then - R := Allocate_Bignum (0); - - -- One word result - - elsif X in -(2 ** 32 - 1) .. +(2 ** 32 - 1) then - R := Allocate_Bignum (1); - R.D (1) := SD (abs (X)); - - -- Largest negative number annoyance - - elsif X = Long_Long_Integer'First then - R := Allocate_Bignum (2); - R.D (1) := 2 ** 31; - R.D (2) := 0; - - -- Normal two word case - - else - R := Allocate_Bignum (2); - R.D (2) := SD (abs (X) mod Base); - R.D (1) := SD (abs (X) / Base); - end if; - - R.Neg := X < 0; - return R; - end To_Bignum; - -end System.Bignums; diff --git a/gcc/ada/s-bignum.ads b/gcc/ada/s-bignum.ads deleted file mode 100644 index 7cc7526..0000000 --- a/gcc/ada/s-bignum.ads +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . B I G N U M S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides arbitrary precision signed integer arithmetic for --- use in computing intermediate values in expressions for the case where --- pragma Overflow_Check (Eliminated) is in effect. - -with Interfaces; - -package System.Bignums is - - pragma Assert (Long_Long_Integer'Size = 64); - -- This package assumes that Long_Long_Integer size is 64 bit (i.e. that it - -- has a range of -2**63 to 2**63-1). The front end ensures that the mode - -- ELIMINATED is not allowed for overflow checking if this is not the case. - - subtype Length is Natural range 0 .. 2 ** 23 - 1; - -- Represent number of words in Digit_Vector - - Base : constant := 2 ** 32; - -- Digit vectors use this base - - subtype SD is Interfaces.Unsigned_32; - -- Single length digit - - type Digit_Vector is array (Length range <>) of SD; - -- Represent digits of a number (most significant digit first) - - type Bignum_Data (Len : Length) is record - Neg : Boolean; - -- Set if value is negative, never set for zero - - D : Digit_Vector (1 .. Len); - -- Digits of number, most significant first, represented in base - -- 2**Base. No leading zeroes are stored, and the value of zero is - -- represented using an empty vector for D. - end record; - - for Bignum_Data use record - Len at 0 range 0 .. 23; - Neg at 3 range 0 .. 7; - end record; - - type Bignum is access all Bignum_Data; - -- This is the type that is used externally. Possibly this could be a - -- private type, but we leave the structure exposed for now. For one - -- thing it helps with debugging. Note that this package never shares - -- an allocated Bignum value, so for example for X + 0, a copy of X is - -- returned, not X itself. - - -- Note: none of the subprograms in this package modify the Bignum_Data - -- records referenced by Bignum arguments of mode IN. - - function Big_Add (X, Y : Bignum) return Bignum; -- "+" - function Big_Sub (X, Y : Bignum) return Bignum; -- "-" - function Big_Mul (X, Y : Bignum) return Bignum; -- "*" - function Big_Div (X, Y : Bignum) return Bignum; -- "/" - function Big_Exp (X, Y : Bignum) return Bignum; -- "**" - function Big_Mod (X, Y : Bignum) return Bignum; -- "mod" - function Big_Rem (X, Y : Bignum) return Bignum; -- "rem" - function Big_Neg (X : Bignum) return Bignum; -- "-" - function Big_Abs (X : Bignum) return Bignum; -- "abs" - -- Perform indicated arithmetic operation on bignum values. No exception - -- raised except for Div/Mod/Rem by 0 which raises Constraint_Error with - -- an appropriate message. - - function Big_EQ (X, Y : Bignum) return Boolean; -- "=" - function Big_NE (X, Y : Bignum) return Boolean; -- "/=" - function Big_GE (X, Y : Bignum) return Boolean; -- ">=" - function Big_LE (X, Y : Bignum) return Boolean; -- "<=" - function Big_GT (X, Y : Bignum) return Boolean; -- ">" - function Big_LT (X, Y : Bignum) return Boolean; -- "<" - -- Perform indicated comparison on bignums, returning result as Boolean. - -- No exception raised for any input arguments. - - function Bignum_In_LLI_Range (X : Bignum) return Boolean; - -- Returns True if the Bignum value is in the range of Long_Long_Integer, - -- so that a call to From_Bignum is guaranteed not to raise an exception. - - function To_Bignum (X : Long_Long_Integer) return Bignum; - -- Convert Long_Long_Integer to Bignum. No exception can be raised for any - -- input argument. - - function From_Bignum (X : Bignum) return Long_Long_Integer; - -- Convert Bignum to Long_Long_Integer. Constraint_Error raised with - -- appropriate message if value is out of range of Long_Long_Integer. - -end System.Bignums; diff --git a/gcc/ada/s-bitops.adb b/gcc/ada/s-bitops.adb deleted file mode 100644 index e1129db..0000000 --- a/gcc/ada/s-bitops.adb +++ /dev/null @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . B I T _ O P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System; use System; -with System.Unsigned_Types; use System.Unsigned_Types; - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Unchecked_Conversion; - -package body System.Bit_Ops is - - subtype Bits_Array is System.Unsigned_Types.Packed_Bytes1 (Positive); - -- Dummy array type used to interpret the address values. We use the - -- unaligned version always, since this will handle both the aligned and - -- unaligned cases, and we always do these operations by bytes anyway. - -- Note: we use a ones origin array here so that the computations of the - -- length in bytes work correctly (give a non-negative value) for the - -- case of zero length bit strings). Note that we never allocate any - -- objects of this type (we can't because they would be absurdly big). - - type Bits is access Bits_Array; - -- This is the actual type into which address values are converted - - function To_Bits is new Ada.Unchecked_Conversion (Address, Bits); - - LE : constant := Standard'Default_Bit_Order; - -- Static constant set to 0 for big-endian, 1 for little-endian - - -- The following is an array of masks used to mask the final byte, either - -- at the high end (big-endian case) or the low end (little-endian case). - - Masks : constant array (1 .. 7) of Packed_Byte := ( - (1 - LE) * 2#1000_0000# + LE * 2#0000_0001#, - (1 - LE) * 2#1100_0000# + LE * 2#0000_0011#, - (1 - LE) * 2#1110_0000# + LE * 2#0000_0111#, - (1 - LE) * 2#1111_0000# + LE * 2#0000_1111#, - (1 - LE) * 2#1111_1000# + LE * 2#0001_1111#, - (1 - LE) * 2#1111_1100# + LE * 2#0011_1111#, - (1 - LE) * 2#1111_1110# + LE * 2#0111_1111#); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Raise_Error; - pragma No_Return (Raise_Error); - -- Raise Constraint_Error, complaining about unequal lengths - - ------------- - -- Bit_And -- - ------------- - - procedure Bit_And - (Left : Address; - Llen : Natural; - Right : Address; - Rlen : Natural; - Result : Address) - is - LeftB : constant Bits := To_Bits (Left); - RightB : constant Bits := To_Bits (Right); - ResultB : constant Bits := To_Bits (Result); - - begin - if Llen /= Rlen then - Raise_Error; - end if; - - for J in 1 .. (Rlen + 7) / 8 loop - ResultB (J) := LeftB (J) and RightB (J); - end loop; - end Bit_And; - - ------------ - -- Bit_Eq -- - ------------ - - function Bit_Eq - (Left : Address; - Llen : Natural; - Right : Address; - Rlen : Natural) return Boolean - is - LeftB : constant Bits := To_Bits (Left); - RightB : constant Bits := To_Bits (Right); - - begin - if Llen /= Rlen then - return False; - - else - declare - BLen : constant Natural := Llen / 8; - Bitc : constant Natural := Llen mod 8; - - begin - if LeftB (1 .. BLen) /= RightB (1 .. BLen) then - return False; - - elsif Bitc /= 0 then - return - ((LeftB (BLen + 1) xor RightB (BLen + 1)) - and Masks (Bitc)) = 0; - - else -- Bitc = 0 - return True; - end if; - end; - end if; - end Bit_Eq; - - ------------- - -- Bit_Not -- - ------------- - - procedure Bit_Not - (Opnd : System.Address; - Len : Natural; - Result : System.Address) - is - OpndB : constant Bits := To_Bits (Opnd); - ResultB : constant Bits := To_Bits (Result); - - begin - for J in 1 .. (Len + 7) / 8 loop - ResultB (J) := not OpndB (J); - end loop; - end Bit_Not; - - ------------ - -- Bit_Or -- - ------------ - - procedure Bit_Or - (Left : Address; - Llen : Natural; - Right : Address; - Rlen : Natural; - Result : Address) - is - LeftB : constant Bits := To_Bits (Left); - RightB : constant Bits := To_Bits (Right); - ResultB : constant Bits := To_Bits (Result); - - begin - if Llen /= Rlen then - Raise_Error; - end if; - - for J in 1 .. (Rlen + 7) / 8 loop - ResultB (J) := LeftB (J) or RightB (J); - end loop; - end Bit_Or; - - ------------- - -- Bit_Xor -- - ------------- - - procedure Bit_Xor - (Left : Address; - Llen : Natural; - Right : Address; - Rlen : Natural; - Result : Address) - is - LeftB : constant Bits := To_Bits (Left); - RightB : constant Bits := To_Bits (Right); - ResultB : constant Bits := To_Bits (Result); - - begin - if Llen /= Rlen then - Raise_Error; - end if; - - for J in 1 .. (Rlen + 7) / 8 loop - ResultB (J) := LeftB (J) xor RightB (J); - end loop; - end Bit_Xor; - - ----------------- - -- Raise_Error -- - ----------------- - - procedure Raise_Error is - begin - Raise_Exception - (Constraint_Error'Identity, "operand lengths are unequal"); - end Raise_Error; - -end System.Bit_Ops; diff --git a/gcc/ada/s-bitops.ads b/gcc/ada/s-bitops.ads deleted file mode 100644 index edc6035..0000000 --- a/gcc/ada/s-bitops.ads +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . B I T _ O P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Operations on packed bit strings - -pragma Compiler_Unit_Warning; - -with System; - -package System.Bit_Ops is - - -- Note: in all the following routines, the System.Address parameters - -- represent the address of the first byte of an array used to represent - -- a packed array (of type System.Unsigned_Types.Packed_Bytes{1,2,4}) - -- The length in bits is passed as a separate parameter. Note that all - -- addresses must be of byte aligned arrays. - - procedure Bit_And - (Left : System.Address; - Llen : Natural; - Right : System.Address; - Rlen : Natural; - Result : System.Address); - -- Bitwise "and" of given bit string with result being placed in Result. - -- The and operation is allowed to destroy unused bits in the last byte, - -- i.e. to leave them set in an undefined manner. Note that Left, Right - -- and Result always have the same length in bits (Len). - - function Bit_Eq - (Left : System.Address; - Llen : Natural; - Right : System.Address; - Rlen : Natural) return Boolean; - -- Left and Right are the addresses of two bit packed arrays with Llen - -- and Rlen being the respective length in bits. The routine compares the - -- two bit strings for equality, being careful not to include the unused - -- bits in the final byte. Note that the result is always False if Rlen - -- is not equal to Llen. - - procedure Bit_Not - (Opnd : System.Address; - Len : Natural; - Result : System.Address); - -- Bitwise "not" of given bit string with result being placed in Result. - -- The not operation is allowed to destroy unused bits in the last byte, - -- i.e. to leave them set in an undefined manner. Note that Result and - -- Opnd always have the same length in bits (Len). - - procedure Bit_Or - (Left : System.Address; - Llen : Natural; - Right : System.Address; - Rlen : Natural; - Result : System.Address); - -- Bitwise "or" of given bit string with result being placed in Result. - -- The or operation is allowed to destroy unused bits in the last byte, - -- i.e. to leave them set in an undefined manner. Note that Left, Right - -- and Result always have the same length in bits (Len). - - procedure Bit_Xor - (Left : System.Address; - Llen : Natural; - Right : System.Address; - Rlen : Natural; - Result : System.Address); - -- Bitwise "xor" of given bit string with result being placed in Result. - -- The xor operation is allowed to destroy unused bits in the last byte, - -- i.e. to leave them set in an undefined manner. Note that Left, Right - -- and Result always have the same length in bits (Len). - -end System.Bit_Ops; diff --git a/gcc/ada/s-boarop.ads b/gcc/ada/s-boarop.ads deleted file mode 100644 index bc8b4a6..0000000 --- a/gcc/ada/s-boarop.ads +++ /dev/null @@ -1,65 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . B O O L E A N _ A R R A Y _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime operations on boolean arrays - -with System.Generic_Vector_Operations; -with System.Vectors.Boolean_Operations; - -package System.Boolean_Array_Operations is - pragma Pure; - - type Boolean_Array is array (Integer range <>) of Boolean; - - package Boolean_Operations renames System.Vectors.Boolean_Operations; - - package Vector_Operations is - new Generic_Vector_Operations (Boolean, Integer, Boolean_Array); - - generic procedure Binary_Operation - renames Vector_Operations.Binary_Operation; - - generic procedure Unary_Operation - renames Vector_Operations.Unary_Operation; - - procedure Vector_Not is - new Unary_Operation ("not", Boolean_Operations."not"); - procedure Vector_And is new Binary_Operation ("and", System.Vectors."and"); - procedure Vector_Or is new Binary_Operation ("or", System.Vectors."or"); - procedure Vector_Xor is new Binary_Operation ("xor", System.Vectors."xor"); - - procedure Vector_Nand is - new Binary_Operation (Boolean_Operations.Nand, Boolean_Operations.Nand); - procedure Vector_Nor is - new Binary_Operation (Boolean_Operations.Nor, Boolean_Operations.Nor); - procedure Vector_Nxor is - new Binary_Operation (Boolean_Operations.Nxor, Boolean_Operations.Nxor); -end System.Boolean_Array_Operations; diff --git a/gcc/ada/s-boustr.adb b/gcc/ada/s-boustr.adb deleted file mode 100644 index 1eb168d..0000000 --- a/gcc/ada/s-boustr.adb +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . B O U N D E D _ S T R I N G S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; - -package body System.Bounded_Strings is - - ------------ - -- Append -- - ------------ - - procedure Append (X : in out Bounded_String; C : Character) is - begin - -- If we have too many characters to fit, simply drop them - - if X.Length < X.Max_Length then - X.Length := X.Length + 1; - X.Chars (X.Length) := C; - end if; - end Append; - - procedure Append (X : in out Bounded_String; S : String) is - begin - for C of S loop - Append (X, C); - end loop; - end Append; - - -------------------- - -- Append_Address -- - -------------------- - - procedure Append_Address (X : in out Bounded_String; A : Address) - is - S : String (1 .. 18); - P : Natural; - use System.Storage_Elements; - N : Integer_Address; - - H : constant array (Integer range 0 .. 15) of Character := - "0123456789abcdef"; - begin - P := S'Last; - N := To_Integer (A); - loop - S (P) := H (Integer (N mod 16)); - P := P - 1; - N := N / 16; - exit when N = 0; - end loop; - - S (P - 1) := '0'; - S (P) := 'x'; - - Append (X, S (P - 1 .. S'Last)); - end Append_Address; - - ------------- - -- Is_Full -- - ------------- - - function Is_Full (X : Bounded_String) return Boolean is - begin - return X.Length >= X.Max_Length; - end Is_Full; - - --------------- - -- To_String -- - --------------- - - function To_String (X : Bounded_String) return String is - begin - return X.Chars (1 .. X.Length); - end To_String; - -end System.Bounded_Strings; diff --git a/gcc/ada/s-boustr.ads b/gcc/ada/s-boustr.ads deleted file mode 100644 index 0cc2cce..0000000 --- a/gcc/ada/s-boustr.ads +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . B O U N D E D _ S T R I N G S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- A very simple implentation of bounded strings, used by tracebacks - -package System.Bounded_Strings is - type Bounded_String (Max_Length : Natural) is limited private; - -- A string whose length is bounded by Max_Length. The bounded string is - -- empty at initialization. - - procedure Append (X : in out Bounded_String; C : Character); - procedure Append (X : in out Bounded_String; S : String); - -- Append a character or a string to X. If the bounded string is full, - -- extra characters are simply dropped. - - function To_String (X : Bounded_String) return String; - function "+" (X : Bounded_String) return String renames To_String; - -- Convert to a normal string - - procedure Append_Address (X : in out Bounded_String; A : Address); - -- Append an address to X - - function Is_Full (X : Bounded_String) return Boolean; - -- Return True iff X is full and any character or string will be dropped - -- if appended. -private - type Bounded_String (Max_Length : Natural) is limited record - Length : Natural := 0; - -- Current length of the string - - Chars : String (1 .. Max_Length); - -- String content - end record; -end System.Bounded_Strings; diff --git a/gcc/ada/s-bytswa.ads b/gcc/ada/s-bytswa.ads deleted file mode 100644 index 675e7d8..0000000 --- a/gcc/ada/s-bytswa.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . B Y T E _ S W A P P I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2012, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Intrinsic routines for byte swapping. These are used by the expanded code --- (supporting alternative byte ordering), and by the GNAT.Byte_Swapping run --- time package which provides user level routines for byte swapping. - -package System.Byte_Swapping is - - pragma Pure; - - type U16 is mod 2**16; - type U32 is mod 2**32; - type U64 is mod 2**64; - - function Bswap_16 (X : U16) return U16; - pragma Import (Intrinsic, Bswap_16, "__builtin_bswap16"); - - function Bswap_32 (X : U32) return U32; - pragma Import (Intrinsic, Bswap_32, "__builtin_bswap32"); - - function Bswap_64 (X : U64) return U64; - pragma Import (Intrinsic, Bswap_64, "__builtin_bswap64"); - -end System.Byte_Swapping; diff --git a/gcc/ada/s-carsi8.adb b/gcc/ada/s-carsi8.adb deleted file mode 100644 index 6e4fd42..0000000 --- a/gcc/ada/s-carsi8.adb +++ /dev/null @@ -1,143 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Signed_8 is - - type Word is mod 2 ** 32; - -- Used to process operands by words - - type Big_Words is array (Natural) of Word; - type Big_Words_Ptr is access Big_Words; - for Big_Words_Ptr'Storage_Size use 0; - -- Array type used to access by words - - type Byte is range -128 .. +127; - for Byte'Size use 8; - -- Used to process operands by bytes - - type Big_Bytes is array (Natural) of Byte; - type Big_Bytes_Ptr is access Big_Bytes; - for Big_Bytes_Ptr'Storage_Size use 0; - -- Array type used to access by bytes - - function To_Big_Words is new - Ada.Unchecked_Conversion (System.Address, Big_Words_Ptr); - - function To_Big_Bytes is new - Ada.Unchecked_Conversion (System.Address, Big_Bytes_Ptr); - - ---------------------- - -- Compare_Array_S8 -- - ---------------------- - - function Compare_Array_S8 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); - - begin - -- If operands are non-aligned, or length is too short, go by bytes - - if ModA (OrA (Left, Right), 4) /= 0 or else Compare_Len < 4 then - return Compare_Array_S8_Unaligned (Left, Right, Left_Len, Right_Len); - end if; - - -- Here we can go by words - - declare - LeftP : constant Big_Words_Ptr := - To_Big_Words (Left); - RightP : constant Big_Words_Ptr := - To_Big_Words (Right); - Words_To_Compare : constant Natural := Compare_Len / 4; - Bytes_Compared_As_Words : constant Natural := Words_To_Compare * 4; - - begin - for J in 0 .. Words_To_Compare - 1 loop - if LeftP (J) /= RightP (J) then - return Compare_Array_S8_Unaligned - (AddA (Left, Address (4 * J)), - AddA (Right, Address (4 * J)), - 4, 4); - end if; - end loop; - - return Compare_Array_S8_Unaligned - (AddA (Left, Address (Bytes_Compared_As_Words)), - AddA (Right, Address (Bytes_Compared_As_Words)), - Left_Len - Bytes_Compared_As_Words, - Right_Len - Bytes_Compared_As_Words); - end; - end Compare_Array_S8; - - -------------------------------- - -- Compare_Array_S8_Unaligned -- - -------------------------------- - - function Compare_Array_S8_Unaligned - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); - - LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left); - RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right); - - begin - for J in 0 .. Compare_Len - 1 loop - if LeftP (J) /= RightP (J) then - if LeftP (J) > RightP (J) then - return +1; - else - return -1; - end if; - end if; - end loop; - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_S8_Unaligned; - -end System.Compare_Array_Signed_8; diff --git a/gcc/ada/s-carsi8.ads b/gcc/ada/s-carsi8.ads deleted file mode 100644 index c12ff1e..0000000 --- a/gcc/ada/s-carsi8.ads +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 8-bit discrete type values to be treated as signed. - -package System.Compare_Array_Signed_8 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_S8 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words - -- if the operands are aligned on 4-byte boundaries and long enough. - - function Compare_Array_S8_Unaligned - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Same functionality as Compare_Array_S8 but always proceeds by - -- bytes. Used when the caller knows that the operands are unaligned, - -- or short enough that it makes no sense to go by words. - -end System.Compare_Array_Signed_8; diff --git a/gcc/ada/s-carun8.adb b/gcc/ada/s-carun8.adb deleted file mode 100644 index f8d498a..0000000 --- a/gcc/ada/s-carun8.adb +++ /dev/null @@ -1,144 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Unsigned_8 is - - type Word is mod 2 ** 32; - -- Used to process operands by words - - type Big_Words is array (Natural) of Word; - type Big_Words_Ptr is access Big_Words; - for Big_Words_Ptr'Storage_Size use 0; - -- Array type used to access by words - - type Byte is mod 2 ** 8; - -- Used to process operands by bytes - - type Big_Bytes is array (Natural) of Byte; - type Big_Bytes_Ptr is access Big_Bytes; - for Big_Bytes_Ptr'Storage_Size use 0; - -- Array type used to access by bytes - - function To_Big_Words is new - Ada.Unchecked_Conversion (System.Address, Big_Words_Ptr); - - function To_Big_Bytes is new - Ada.Unchecked_Conversion (System.Address, Big_Bytes_Ptr); - - ---------------------- - -- Compare_Array_U8 -- - ---------------------- - - function Compare_Array_U8 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); - - begin - -- If operands are non-aligned, or length is too short, go by bytes - - if (ModA (OrA (Left, Right), 4) /= 0) or else Compare_Len < 4 then - return Compare_Array_U8_Unaligned (Left, Right, Left_Len, Right_Len); - end if; - - -- Here we can go by words - - declare - LeftP : constant Big_Words_Ptr := - To_Big_Words (Left); - RightP : constant Big_Words_Ptr := - To_Big_Words (Right); - Words_To_Compare : constant Natural := Compare_Len / 4; - Bytes_Compared_As_Words : constant Natural := Words_To_Compare * 4; - - begin - for J in 0 .. Words_To_Compare - 1 loop - if LeftP (J) /= RightP (J) then - return Compare_Array_U8_Unaligned - (AddA (Left, Address (4 * J)), - AddA (Right, Address (4 * J)), - 4, 4); - end if; - end loop; - - return Compare_Array_U8_Unaligned - (AddA (Left, Address (Bytes_Compared_As_Words)), - AddA (Right, Address (Bytes_Compared_As_Words)), - Left_Len - Bytes_Compared_As_Words, - Right_Len - Bytes_Compared_As_Words); - end; - end Compare_Array_U8; - - -------------------------------- - -- Compare_Array_U8_Unaligned -- - -------------------------------- - - function Compare_Array_U8_Unaligned - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); - - LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left); - RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right); - - begin - for J in 0 .. Compare_Len - 1 loop - if LeftP (J) /= RightP (J) then - if LeftP (J) > RightP (J) then - return +1; - else - return -1; - end if; - end if; - end loop; - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_U8_Unaligned; - -end System.Compare_Array_Unsigned_8; diff --git a/gcc/ada/s-carun8.ads b/gcc/ada/s-carun8.ads deleted file mode 100644 index 7d9466e..0000000 --- a/gcc/ada/s-carun8.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 8-bit discrete type values to be treated as unsigned. - -pragma Compiler_Unit_Warning; - -package System.Compare_Array_Unsigned_8 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_U8 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len with the - -- array starting at address Right of length Right_Len. The comparison is - -- in the normal Ada semantic sense of array comparison. The result is -1, - -- 0, +1 for Left < Right, Left = Right, Left > Right respectively. This - -- function works with 4 byte words if the operands are aligned on 4-byte - -- boundaries and long enough. - - function Compare_Array_U8_Unaligned - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Same functionality as Compare_Array_U8 but always proceeds by bytes. - -- Used when the caller knows that the operands are unaligned, or short - -- enough that it makes no sense to go by words. - -end System.Compare_Array_Unsigned_8; diff --git a/gcc/ada/s-casi16.adb b/gcc/ada/s-casi16.adb deleted file mode 100644 index 88a758a..0000000 --- a/gcc/ada/s-casi16.adb +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Signed_16 is - - type Word is mod 2 ** 32; - -- Used to process operands by words - - type Half is range -(2 ** 15) .. (2 ** 15) - 1; - for Half'Size use 16; - -- Used to process operands by half words - - type Uhalf is new Half; - for Uhalf'Alignment use 1; - -- Used to process operands when unaligned - - type WP is access Word; - type HP is access Half; - type UP is access Uhalf; - - function W is new Ada.Unchecked_Conversion (Address, WP); - function H is new Ada.Unchecked_Conversion (Address, HP); - function U is new Ada.Unchecked_Conversion (Address, UP); - - ----------------------- - -- Compare_Array_S16 -- - ----------------------- - - function Compare_Array_S16 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Clen : Natural := Natural'Min (Left_Len, Right_Len); - -- Number of elements left to compare - - L : Address := Left; - R : Address := Right; - -- Pointers to next elements to compare - - begin - -- Go by words if possible - - if ModA (OrA (Left, Right), 4) = 0 then - while Clen > 1 - and then W (L).all = W (R).all - loop - Clen := Clen - 2; - L := AddA (L, 4); - R := AddA (R, 4); - end loop; - end if; - - -- Case of going by aligned half words - - if ModA (OrA (Left, Right), 2) = 0 then - while Clen /= 0 loop - if H (L).all /= H (R).all then - if H (L).all > H (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 2); - R := AddA (R, 2); - end loop; - - -- Case of going by unaligned half words - - else - while Clen /= 0 loop - if U (L).all /= U (R).all then - if U (L).all > U (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 2); - R := AddA (R, 2); - end loop; - end if; - - -- Here if common section equal, result decided by lengths - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_S16; - -end System.Compare_Array_Signed_16; diff --git a/gcc/ada/s-casi16.ads b/gcc/ada/s-casi16.ads deleted file mode 100644 index b970b7b..0000000 --- a/gcc/ada/s-casi16.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 1 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 16-bit discrete type values to be treated as signed. - -package System.Compare_Array_Signed_16 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_S16 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words - -- if the operands are aligned on 4-byte boundaries and long enough. - -end System.Compare_Array_Signed_16; diff --git a/gcc/ada/s-casi32.adb b/gcc/ada/s-casi32.adb deleted file mode 100644 index 0416114..0000000 --- a/gcc/ada/s-casi32.adb +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 3 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Signed_32 is - - type Word is range -2**31 .. 2**31 - 1; - for Word'Size use 32; - -- Used to process operands by words - - type Uword is new Word; - for Uword'Alignment use 1; - -- Used to process operands when unaligned - - type WP is access Word; - type UP is access Uword; - - function W is new Ada.Unchecked_Conversion (Address, WP); - function U is new Ada.Unchecked_Conversion (Address, UP); - - ----------------------- - -- Compare_Array_S32 -- - ----------------------- - - function Compare_Array_S32 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Clen : Natural := Natural'Min (Left_Len, Right_Len); - -- Number of elements left to compare - - L : Address := Left; - R : Address := Right; - -- Pointers to next elements to compare - - begin - -- Case of going by aligned words - - if ModA (OrA (Left, Right), 4) = 0 then - while Clen /= 0 loop - if W (L).all /= W (R).all then - if W (L).all > W (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 4); - R := AddA (R, 4); - end loop; - - -- Case of going by unaligned words - - else - while Clen /= 0 loop - if U (L).all /= U (R).all then - if U (L).all > U (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 4); - R := AddA (R, 4); - end loop; - end if; - - -- Here if common section equal, result decided by lengths - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_S32; - -end System.Compare_Array_Signed_32; diff --git a/gcc/ada/s-casi32.ads b/gcc/ada/s-casi32.ads deleted file mode 100644 index 8c3a208..0000000 --- a/gcc/ada/s-casi32.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 32-bit discrete type values to be treated as signed. - -package System.Compare_Array_Signed_32 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_S32 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) - return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for LeftRight respectively. - -end System.Compare_Array_Signed_32; diff --git a/gcc/ada/s-casi64.adb b/gcc/ada/s-casi64.adb deleted file mode 100644 index 858a22f..0000000 --- a/gcc/ada/s-casi64.adb +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 6 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Signed_64 is - - type Word is range -2**63 .. 2**63 - 1; - for Word'Size use 64; - -- Used to process operands by words - - type Uword is new Word; - for Uword'Alignment use 1; - -- Used to process operands when unaligned - - type WP is access Word; - type UP is access Uword; - - function W is new Ada.Unchecked_Conversion (Address, WP); - function U is new Ada.Unchecked_Conversion (Address, UP); - - ----------------------- - -- Compare_Array_S64 -- - ----------------------- - - function Compare_Array_S64 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Clen : Natural := Natural'Min (Left_Len, Right_Len); - -- Number of elements left to compare - - L : Address := Left; - R : Address := Right; - -- Pointers to next elements to compare - - begin - -- Case of going by aligned double words - - if ModA (OrA (Left, Right), 8) = 0 then - while Clen /= 0 loop - if W (L).all /= W (R).all then - if W (L).all > W (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 8); - R := AddA (R, 8); - end loop; - - -- Case of going by unaligned double words - - else - while Clen /= 0 loop - if U (L).all /= U (R).all then - if U (L).all > U (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 8); - R := AddA (R, 8); - end loop; - end if; - - -- Here if common section equal, result decided by lengths - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_S64; - -end System.Compare_Array_Signed_64; diff --git a/gcc/ada/s-casi64.ads b/gcc/ada/s-casi64.ads deleted file mode 100644 index e8a28bd..0000000 --- a/gcc/ada/s-casi64.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ S I G N E D _ 6 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 64-bit discrete type values to be treated as signed. - -package System.Compare_Array_Signed_64 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_S64 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for LeftRight respectively. - -end System.Compare_Array_Signed_64; diff --git a/gcc/ada/s-casuti.adb b/gcc/ada/s-casuti.adb deleted file mode 100644 index 229db4e..0000000 --- a/gcc/ada/s-casuti.adb +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . C A S E _ U T I L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.Case_Util is - - -------------- - -- To_Lower -- - -------------- - - function To_Lower (A : Character) return Character is - A_Val : constant Natural := Character'Pos (A); - - begin - if A in 'A' .. 'Z' - or else A_Val in 16#C0# .. 16#D6# - or else A_Val in 16#D8# .. 16#DE# - then - return Character'Val (A_Val + 16#20#); - else - return A; - end if; - end To_Lower; - - procedure To_Lower (A : in out String) is - begin - for J in A'Range loop - A (J) := To_Lower (A (J)); - end loop; - end To_Lower; - - -------------- - -- To_Mixed -- - -------------- - - procedure To_Mixed (A : in out String) is - Ucase : Boolean := True; - - begin - for J in A'Range loop - if Ucase then - A (J) := To_Upper (A (J)); - else - A (J) := To_Lower (A (J)); - end if; - - Ucase := A (J) = '_'; - end loop; - end To_Mixed; - - -------------- - -- To_Upper -- - -------------- - - function To_Upper (A : Character) return Character is - A_Val : constant Natural := Character'Pos (A); - - begin - if A in 'a' .. 'z' - or else A_Val in 16#E0# .. 16#F6# - or else A_Val in 16#F8# .. 16#FE# - then - return Character'Val (A_Val - 16#20#); - else - return A; - end if; - end To_Upper; - - procedure To_Upper (A : in out String) is - begin - for J in A'Range loop - A (J) := To_Upper (A (J)); - end loop; - end To_Upper; - -end System.Case_Util; diff --git a/gcc/ada/s-casuti.ads b/gcc/ada/s-casuti.ads deleted file mode 100644 index 9c6150a..0000000 --- a/gcc/ada/s-casuti.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . C A S E _ U T I L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Simple casing functions - --- This package provides simple casing functions that do not require the --- overhead of the full casing tables found in Ada.Characters.Handling. - --- Note that all the routines in this package are available to the user --- via GNAT.Case_Util, which imports all the entities from this package. - -pragma Compiler_Unit_Warning; - -package System.Case_Util is - pragma Pure; - - -- Note: all the following functions handle the full Latin-1 set - - function To_Upper (A : Character) return Character; - -- Converts A to upper case if it is a lower case letter, otherwise - -- returns the input argument unchanged. - - procedure To_Upper (A : in out String); - -- Folds all characters of string A to upper case - - function To_Lower (A : Character) return Character; - -- Converts A to lower case if it is an upper case letter, otherwise - -- returns the input argument unchanged. - - procedure To_Lower (A : in out String); - -- Folds all characters of string A to lower case - - procedure To_Mixed (A : in out String); - -- Converts A to mixed case (i.e. lower case, except for initial - -- character and any character after an underscore, which are - -- converted to upper case. - -end System.Case_Util; diff --git a/gcc/ada/s-caun16.adb b/gcc/ada/s-caun16.adb deleted file mode 100644 index 37abb9c..0000000 --- a/gcc/ada/s-caun16.adb +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Unsigned_16 is - - type Word is mod 2 ** 32; - -- Used to process operands by words - - type Half is mod 2 ** 16; - for Half'Size use 16; - -- Used to process operands by half words - - type Uhalf is new Half; - for Uhalf'Alignment use 1; - -- Used to process operands when unaligned - - type WP is access Word; - type HP is access Half; - type UP is access Uhalf; - - function W is new Ada.Unchecked_Conversion (Address, WP); - function H is new Ada.Unchecked_Conversion (Address, HP); - function U is new Ada.Unchecked_Conversion (Address, UP); - - ----------------------- - -- Compare_Array_U16 -- - ----------------------- - - function Compare_Array_U16 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Clen : Natural := Natural'Min (Left_Len, Right_Len); - -- Number of elements left to compare - - L : Address := Left; - R : Address := Right; - -- Pointers to next elements to compare - - begin - -- Go by words if possible - - if ModA (OrA (Left, Right), 4) = 0 then - while Clen > 1 - and then W (L).all = W (R).all - loop - Clen := Clen - 2; - L := AddA (L, 4); - R := AddA (R, 4); - end loop; - end if; - - -- Case of going by aligned half words - - if ModA (OrA (Left, Right), 2) = 0 then - while Clen /= 0 loop - if H (L).all /= H (R).all then - if H (L).all > H (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 2); - R := AddA (R, 2); - end loop; - - -- Case of going by unaligned half words - - else - while Clen /= 0 loop - if U (L).all /= U (R).all then - if U (L).all > U (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 2); - R := AddA (R, 2); - end loop; - end if; - - -- Here if common section equal, result decided by lengths - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_U16; - -end System.Compare_Array_Unsigned_16; diff --git a/gcc/ada/s-caun16.ads b/gcc/ada/s-caun16.ads deleted file mode 100644 index 31c0e09..0000000 --- a/gcc/ada/s-caun16.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 1 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 16-bit discrete type values to be treated as unsigned. - -package System.Compare_Array_Unsigned_16 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_U16 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words - -- if the operands are aligned on 4-byte boundaries and long enough. - -end System.Compare_Array_Unsigned_16; diff --git a/gcc/ada/s-caun32.adb b/gcc/ada/s-caun32.adb deleted file mode 100644 index 070df3a..0000000 --- a/gcc/ada/s-caun32.adb +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 3 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Unsigned_32 is - - type Word is mod 2 ** 32; - for Word'Size use 32; - -- Used to process operands by words - - type Uword is new Word; - for Uword'Alignment use 1; - -- Used to process operands when unaligned - - type WP is access Word; - type UP is access Uword; - - function W is new Ada.Unchecked_Conversion (Address, WP); - function U is new Ada.Unchecked_Conversion (Address, UP); - - ----------------------- - -- Compare_Array_U32 -- - ----------------------- - - function Compare_Array_U32 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Clen : Natural := Natural'Min (Left_Len, Right_Len); - -- Number of elements left to compare - - L : Address := Left; - R : Address := Right; - -- Pointers to next elements to compare - - begin - -- Case of going by aligned words - - if ModA (OrA (Left, Right), 4) = 0 then - while Clen /= 0 loop - if W (L).all /= W (R).all then - if W (L).all > W (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 4); - R := AddA (R, 4); - end loop; - - -- Case of going by unaligned words - - else - while Clen /= 0 loop - if U (L).all /= U (R).all then - if U (L).all > U (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 4); - R := AddA (R, 4); - end loop; - end if; - - -- Here if common section equal, result decided by lengths - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_U32; - -end System.Compare_Array_Unsigned_32; diff --git a/gcc/ada/s-caun32.ads b/gcc/ada/s-caun32.ads deleted file mode 100644 index 61ff421..0000000 --- a/gcc/ada/s-caun32.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 32-bit discrete type values to be treated as unsigned. - -package System.Compare_Array_Unsigned_32 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_U32 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for LeftRight respectively. - -end System.Compare_Array_Unsigned_32; diff --git a/gcc/ada/s-caun64.adb b/gcc/ada/s-caun64.adb deleted file mode 100644 index e4f35ab..0000000 --- a/gcc/ada/s-caun64.adb +++ /dev/null @@ -1,115 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 6 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Address_Operations; use System.Address_Operations; - -with Ada.Unchecked_Conversion; - -package body System.Compare_Array_Unsigned_64 is - - type Word is mod 2 ** 64; - -- Used to process operands by words - - type Uword is new Word; - for Uword'Alignment use 1; - -- Used to process operands when unaligned - - type WP is access Word; - type UP is access Uword; - - function W is new Ada.Unchecked_Conversion (Address, WP); - function U is new Ada.Unchecked_Conversion (Address, UP); - - ----------------------- - -- Compare_Array_U64 -- - ----------------------- - - function Compare_Array_U64 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Clen : Natural := Natural'Min (Left_Len, Right_Len); - -- Number of elements left to compare - - L : Address := Left; - R : Address := Right; - -- Pointers to next elements to compare - - begin - -- Case of going by aligned double words - - if ModA (OrA (Left, Right), 8) = 0 then - while Clen /= 0 loop - if W (L).all /= W (R).all then - if W (L).all > W (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 8); - R := AddA (R, 8); - end loop; - - -- Case of going by unaligned double words - - else - while Clen /= 0 loop - if U (L).all /= U (R).all then - if U (L).all > U (R).all then - return +1; - else - return -1; - end if; - end if; - - Clen := Clen - 1; - L := AddA (L, 8); - R := AddA (R, 8); - end loop; - end if; - - -- Here if common section equal, result decided by lengths - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Compare_Array_U64; - -end System.Compare_Array_Unsigned_64; diff --git a/gcc/ada/s-caun64.ads b/gcc/ada/s-caun64.ads deleted file mode 100644 index c225516..0000000 --- a/gcc/ada/s-caun64.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C O M P A R E _ A R R A Y _ U N S I G N E D _ 6 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on arrays whose --- elements are 64-bit discrete type values to be treated as unsigned. - -package System.Compare_Array_Unsigned_64 is - - -- Note: although the functions in this package are in a sense Pure, the - -- package cannot be declared as Pure, since the arguments are addresses, - -- not the data, and the result is not pure wrt the address values. - - function Compare_Array_U64 - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the array starting at address Left of length Left_Len - -- with the array starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of array - -- comparison. The result is -1,0,+1 for LeftRight respectively. - -end System.Compare_Array_Unsigned_64; diff --git a/gcc/ada/s-chepoo.ads b/gcc/ada/s-chepoo.ads deleted file mode 100644 index a4a717f..0000000 --- a/gcc/ada/s-chepoo.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . C H E C K E D _ P O O L S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Storage_Pools; - -package System.Checked_Pools is - - type Checked_Pool is abstract - new System.Storage_Pools.Root_Storage_Pool with private; - -- Equivalent of storage pools with the addition that Dereference is - -- called on each implicit or explicit dereference of a pointer which - -- has such a storage pool. - - procedure Dereference - (Pool : in out Checked_Pool; - Storage_Address : Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is abstract; - -- Called implicitly each time a pointer to a checked pool is dereferenced - -- All parameters in the profile are compatible with the profile of - -- Allocate/Deallocate: the Storage_Address corresponds to the address of - -- the dereferenced object, Size_in_Storage_Elements is its dynamic size - -- (and thus may involve an implicit dispatching call to size) and - -- Alignment is the alignment of the object. - -private - type Checked_Pool is abstract - new System.Storage_Pools.Root_Storage_Pool with null record; -end System.Checked_Pools; diff --git a/gcc/ada/s-commun.adb b/gcc/ada/s-commun.adb deleted file mode 100644 index afeec6d..0000000 --- a/gcc/ada/s-commun.adb +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . C O M M U N I C A T I O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2009, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Communication is - - subtype SEO is Ada.Streams.Stream_Element_Offset; - - ---------------- - -- Last_Index -- - ---------------- - - function Last_Index - (First : Ada.Streams.Stream_Element_Offset; - Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset - is - use type Ada.Streams.Stream_Element_Offset; - use type System.CRTL.size_t; - begin - if First = SEO'First and then Count = 0 then - raise Constraint_Error with - "last index out of range (no element transferred)"; - else - return First + SEO (Count) - 1; - end if; - end Last_Index; - -end System.Communication; diff --git a/gcc/ada/s-commun.ads b/gcc/ada/s-commun.ads deleted file mode 100644 index 1255efd..0000000 --- a/gcc/ada/s-commun.ads +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . C O M M U N I C A T I O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2012, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Common support unit for GNAT.Sockets and GNAT.Serial_Communication - -with Ada.Streams; -with System.CRTL; - -package System.Communication is - pragma Preelaborate; - - function Last_Index - (First : Ada.Streams.Stream_Element_Offset; - Count : CRTL.size_t) return Ada.Streams.Stream_Element_Offset; - -- Compute the Last OUT parameter for the various Read / Receive - -- subprograms: returns First + Count - 1. - -- - -- When First = Stream_Element_Offset'First and Res = 0, Constraint_Error - -- is raised. This is consistent with the semantics of stream operations - -- as clarified in AI95-227. - -end System.Communication; diff --git a/gcc/ada/s-conca2.adb b/gcc/ada/s-conca2.adb deleted file mode 100644 index 42562dc..0000000 --- a/gcc/ada/s-conca2.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.Concat_2 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_2 -- - ------------------ - - procedure Str_Concat_2 (R : out String; S1, S2 : String) is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := R'Last; - R (F .. L) := S2; - end Str_Concat_2; - - ------------------------- - -- Str_Concat_Bounds_2 -- - ------------------------- - - procedure Str_Concat_Bounds_2 - (Lo, Hi : out Natural; - S1, S2 : String) - is - begin - if S1 = "" then - Lo := S2'First; - Hi := S2'Last; - else - Lo := S1'First; - Hi := S1'Last + S2'Length; - end if; - end Str_Concat_Bounds_2; - -end System.Concat_2; diff --git a/gcc/ada/s-conca2.ads b/gcc/ada/s-conca2.ads deleted file mode 100644 index 6a1a061..0000000 --- a/gcc/ada/s-conca2.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of two string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_2 is - - procedure Str_Concat_2 (R : out String; S1, S2 : String); - -- Performs the operation R := S1 & S2. The bounds of R are known to be - -- correct (usually set by a call to the Str_Concat_Bounds_2 procedure - -- below), so no bounds checks are required, and it is known that none of - -- the input operands overlaps R. No assumptions can be made about the - -- lower bounds of any of the operands. - - procedure Str_Concat_Bounds_2 - (Lo, Hi : out Natural; - S1, S2 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the two - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_2; diff --git a/gcc/ada/s-conca3.adb b/gcc/ada/s-conca3.adb deleted file mode 100644 index 27236ee..0000000 --- a/gcc/ada/s-conca3.adb +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Concat_2; - -package body System.Concat_3 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_3 -- - ------------------ - - procedure Str_Concat_3 (R : out String; S1, S2, S3 : String) is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := F + S2'Length - 1; - R (F .. L) := S2; - - F := L + 1; - L := R'Last; - R (F .. L) := S3; - end Str_Concat_3; - - ------------------------- - -- Str_Concat_Bounds_3 -- - ------------------------- - - procedure Str_Concat_Bounds_3 - (Lo, Hi : out Natural; - S1, S2, S3 : String) - is - begin - System.Concat_2.Str_Concat_Bounds_2 (Lo, Hi, S2, S3); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_3; - -end System.Concat_3; diff --git a/gcc/ada/s-conca3.ads b/gcc/ada/s-conca3.ads deleted file mode 100644 index 8b89f30..0000000 --- a/gcc/ada/s-conca3.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of three string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_3 is - - procedure Str_Concat_3 (R : out String; S1, S2, S3 : String); - -- Performs the operation R := S1 & S2 & S3. The bounds of R are known to - -- be correct (usually set by a call to the Str_Concat_Bounds_3 procedure - -- below), so no bounds checks are required, and it is known that none of - -- the input operands overlaps R. No assumptions can be made about the - -- lower bounds of any of the operands. - - procedure Str_Concat_Bounds_3 - (Lo, Hi : out Natural; - S1, S2, S3 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the three - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_3; diff --git a/gcc/ada/s-conca4.adb b/gcc/ada/s-conca4.adb deleted file mode 100644 index 559bd7b0..0000000 --- a/gcc/ada/s-conca4.adb +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Concat_3; - -package body System.Concat_4 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_4 -- - ------------------ - - procedure Str_Concat_4 (R : out String; S1, S2, S3, S4 : String) is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := F + S2'Length - 1; - R (F .. L) := S2; - - F := L + 1; - L := F + S3'Length - 1; - R (F .. L) := S3; - - F := L + 1; - L := R'Last; - R (F .. L) := S4; - end Str_Concat_4; - - ------------------------- - -- Str_Concat_Bounds_4 -- - ------------------------- - - procedure Str_Concat_Bounds_4 - (Lo, Hi : out Natural; - S1, S2, S3, S4 : String) - is - begin - System.Concat_3.Str_Concat_Bounds_3 (Lo, Hi, S2, S3, S4); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_4; - -end System.Concat_4; diff --git a/gcc/ada/s-conca4.ads b/gcc/ada/s-conca4.ads deleted file mode 100644 index f4c5015..0000000 --- a/gcc/ada/s-conca4.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of four string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_4 is - - procedure Str_Concat_4 (R : out String; S1, S2, S3, S4 : String); - -- Performs the operation R := S1 & S2 & S3 & S4. The bounds - -- of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No - -- assumptions can be made about the lower bounds of any of the operands. - - procedure Str_Concat_Bounds_4 - (Lo, Hi : out Natural; - S1, S2, S3, S4 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the four - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_4; diff --git a/gcc/ada/s-conca5.adb b/gcc/ada/s-conca5.adb deleted file mode 100644 index 891452a..0000000 --- a/gcc/ada/s-conca5.adb +++ /dev/null @@ -1,86 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Concat_4; - -package body System.Concat_5 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_5 -- - ------------------ - - procedure Str_Concat_5 (R : out String; S1, S2, S3, S4, S5 : String) is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := F + S2'Length - 1; - R (F .. L) := S2; - - F := L + 1; - L := F + S3'Length - 1; - R (F .. L) := S3; - - F := L + 1; - L := F + S4'Length - 1; - R (F .. L) := S4; - - F := L + 1; - L := R'Last; - R (F .. L) := S5; - end Str_Concat_5; - - ------------------------- - -- Str_Concat_Bounds_5 -- - ------------------------- - - procedure Str_Concat_Bounds_5 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5 : String) - is - begin - System.Concat_4.Str_Concat_Bounds_4 (Lo, Hi, S2, S3, S4, S5); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_5; - -end System.Concat_5; diff --git a/gcc/ada/s-conca5.ads b/gcc/ada/s-conca5.ads deleted file mode 100644 index c8e2aab..0000000 --- a/gcc/ada/s-conca5.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of five string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_5 is - - procedure Str_Concat_5 (R : out String; S1, S2, S3, S4, S5 : String); - -- Performs the operation R := S1 & S2 & S3 & S4 & S5. The bounds - -- of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_5 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No - -- assumptions can be made about the lower bounds of any of the operands. - - procedure Str_Concat_Bounds_5 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the five - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_5; diff --git a/gcc/ada/s-conca6.adb b/gcc/ada/s-conca6.adb deleted file mode 100644 index 8b5fb30..0000000 --- a/gcc/ada/s-conca6.adb +++ /dev/null @@ -1,90 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Concat_5; - -package body System.Concat_6 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_6 -- - ------------------ - - procedure Str_Concat_6 (R : out String; S1, S2, S3, S4, S5, S6 : String) is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := F + S2'Length - 1; - R (F .. L) := S2; - - F := L + 1; - L := F + S3'Length - 1; - R (F .. L) := S3; - - F := L + 1; - L := F + S4'Length - 1; - R (F .. L) := S4; - - F := L + 1; - L := F + S5'Length - 1; - R (F .. L) := S5; - - F := L + 1; - L := R'Last; - R (F .. L) := S6; - end Str_Concat_6; - - ------------------------- - -- Str_Concat_Bounds_6 -- - ------------------------- - - procedure Str_Concat_Bounds_6 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6 : String) - is - begin - System.Concat_5.Str_Concat_Bounds_5 (Lo, Hi, S2, S3, S4, S5, S6); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_6; - -end System.Concat_6; diff --git a/gcc/ada/s-conca6.ads b/gcc/ada/s-conca6.ads deleted file mode 100644 index 77af8d3..0000000 --- a/gcc/ada/s-conca6.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of six string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_6 is - - procedure Str_Concat_6 (R : out String; S1, S2, S3, S4, S5, S6 : String); - -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6. The - -- bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_6 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No - -- assumptions can be made about the lower bounds of any of the operands. - - procedure Str_Concat_Bounds_6 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the six - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_6; diff --git a/gcc/ada/s-conca7.adb b/gcc/ada/s-conca7.adb deleted file mode 100644 index f2c43a0..0000000 --- a/gcc/ada/s-conca7.adb +++ /dev/null @@ -1,97 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 7 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Concat_6; - -package body System.Concat_7 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_7 -- - ------------------ - - procedure Str_Concat_7 - (R : out String; - S1, S2, S3, S4, S5, S6, S7 : String) - is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := F + S2'Length - 1; - R (F .. L) := S2; - - F := L + 1; - L := F + S3'Length - 1; - R (F .. L) := S3; - - F := L + 1; - L := F + S4'Length - 1; - R (F .. L) := S4; - - F := L + 1; - L := F + S5'Length - 1; - R (F .. L) := S5; - - F := L + 1; - L := F + S6'Length - 1; - R (F .. L) := S6; - - F := L + 1; - L := R'Last; - R (F .. L) := S7; - end Str_Concat_7; - - ------------------------- - -- Str_Concat_Bounds_7 -- - ------------------------- - - procedure Str_Concat_Bounds_7 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7 : String) - is - begin - System.Concat_6.Str_Concat_Bounds_6 (Lo, Hi, S2, S3, S4, S5, S6, S7); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_7; - -end System.Concat_7; diff --git a/gcc/ada/s-conca7.ads b/gcc/ada/s-conca7.ads deleted file mode 100644 index 9aaf855..0000000 --- a/gcc/ada/s-conca7.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 7 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of seven string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_7 is - - procedure Str_Concat_7 - (R : out String; - S1, S2, S3, S4, S5, S6, S7 : String); - -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7. The - -- bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No - -- assumptions can be made about the lower bounds of any of the operands. - - procedure Str_Concat_Bounds_7 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the seven - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_7; diff --git a/gcc/ada/s-conca8.adb b/gcc/ada/s-conca8.adb deleted file mode 100644 index 71bb3fc..0000000 --- a/gcc/ada/s-conca8.adb +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Concat_7; - -package body System.Concat_8 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_8 -- - ------------------ - - procedure Str_Concat_8 - (R : out String; - S1, S2, S3, S4, S5, S6, S7, S8 : String) - is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := F + S2'Length - 1; - R (F .. L) := S2; - - F := L + 1; - L := F + S3'Length - 1; - R (F .. L) := S3; - - F := L + 1; - L := F + S4'Length - 1; - R (F .. L) := S4; - - F := L + 1; - L := F + S5'Length - 1; - R (F .. L) := S5; - - F := L + 1; - L := F + S6'Length - 1; - R (F .. L) := S6; - - F := L + 1; - L := F + S7'Length - 1; - R (F .. L) := S7; - - F := L + 1; - L := R'Last; - R (F .. L) := S8; - end Str_Concat_8; - - ------------------------- - -- Str_Concat_Bounds_8 -- - ------------------------- - - procedure Str_Concat_Bounds_8 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8 : String) - is - begin - System.Concat_7.Str_Concat_Bounds_7 - (Lo, Hi, S2, S3, S4, S5, S6, S7, S8); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_8; - -end System.Concat_8; diff --git a/gcc/ada/s-conca8.ads b/gcc/ada/s-conca8.ads deleted file mode 100644 index d128ba4..0000000 --- a/gcc/ada/s-conca8.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of eight string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_8 is - - procedure Str_Concat_8 - (R : out String; - S1, S2, S3, S4, S5, S6, S7, S8 : String); - -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8. - -- The bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_8 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No - -- assumptions can be made about the lower bounds of any of the operands. - - procedure Str_Concat_Bounds_8 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the eight - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_8; diff --git a/gcc/ada/s-conca9.adb b/gcc/ada/s-conca9.adb deleted file mode 100644 index bb66da1..0000000 --- a/gcc/ada/s-conca9.adb +++ /dev/null @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 9 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Concat_8; - -package body System.Concat_9 is - - pragma Suppress (All_Checks); - - ------------------ - -- Str_Concat_9 -- - ------------------ - - procedure Str_Concat_9 - (R : out String; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String) - is - F, L : Natural; - - begin - F := R'First; - L := F + S1'Length - 1; - R (F .. L) := S1; - - F := L + 1; - L := F + S2'Length - 1; - R (F .. L) := S2; - - F := L + 1; - L := F + S3'Length - 1; - R (F .. L) := S3; - - F := L + 1; - L := F + S4'Length - 1; - R (F .. L) := S4; - - F := L + 1; - L := F + S5'Length - 1; - R (F .. L) := S5; - - F := L + 1; - L := F + S6'Length - 1; - R (F .. L) := S6; - - F := L + 1; - L := F + S7'Length - 1; - R (F .. L) := S7; - - F := L + 1; - L := F + S8'Length - 1; - R (F .. L) := S8; - - F := L + 1; - L := R'Last; - R (F .. L) := S9; - end Str_Concat_9; - - ------------------------- - -- Str_Concat_Bounds_9 -- - ------------------------- - - procedure Str_Concat_Bounds_9 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String) - is - begin - System.Concat_8.Str_Concat_Bounds_8 - (Lo, Hi, S2, S3, S4, S5, S6, S7, S8, S9); - - if S1 /= "" then - Hi := S1'Last + Hi - Lo + 1; - Lo := S1'First; - end if; - end Str_Concat_Bounds_9; - -end System.Concat_9; diff --git a/gcc/ada/s-conca9.ads b/gcc/ada/s-conca9.ads deleted file mode 100644 index bd14a34..0000000 --- a/gcc/ada/s-conca9.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . C O N C A T _ 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a procedure for runtime concatenation of eight string --- operands. It is used when we want to save space in the generated code. - -pragma Compiler_Unit_Warning; - -package System.Concat_9 is - - procedure Str_Concat_9 - (R : out String; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); - -- Performs the operation R := S1 & S2 & S3 & S4 & S5 & S6 & S7 & S8 & S9. - -- The bounds of R are known to be correct (usually set by a call to the - -- Str_Concat_Bounds_9 procedure below), so no bounds checks are required, - -- and it is known that none of the input operands overlaps R. No - -- assumptions can be made about the lower bounds of any of the operands. - - procedure Str_Concat_Bounds_9 - (Lo, Hi : out Natural; - S1, S2, S3, S4, S5, S6, S7, S8, S9 : String); - -- Assigns to Lo..Hi the bounds of the result of concatenating the nine - -- given strings, following the rules in the RM regarding null operands. - -end System.Concat_9; diff --git a/gcc/ada/s-crc32.adb b/gcc/ada/s-crc32.adb deleted file mode 100644 index 4335580..0000000 --- a/gcc/ada/s-crc32.adb +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C R C 3 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.CRC32 is - - Init : constant CRC32 := 16#FFFF_FFFF#; -- Initial value - XorOut : constant CRC32 := 16#FFFF_FFFF#; -- To compute final result. - - -- The following table contains precomputed values for contributions - -- from various possible byte values. Doing a table lookup is quicker - -- than processing the byte bit by bit. - - Table : constant array (CRC32 range 0 .. 255) of CRC32 := - (16#0000_0000#, 16#7707_3096#, 16#EE0E_612C#, 16#9909_51BA#, - 16#076D_C419#, 16#706A_F48F#, 16#E963_A535#, 16#9E64_95A3#, - 16#0EDB_8832#, 16#79DC_B8A4#, 16#E0D5_E91E#, 16#97D2_D988#, - 16#09B6_4C2B#, 16#7EB1_7CBD#, 16#E7B8_2D07#, 16#90BF_1D91#, - 16#1DB7_1064#, 16#6AB0_20F2#, 16#F3B9_7148#, 16#84BE_41DE#, - 16#1ADA_D47D#, 16#6DDD_E4EB#, 16#F4D4_B551#, 16#83D3_85C7#, - 16#136C_9856#, 16#646B_A8C0#, 16#FD62_F97A#, 16#8A65_C9EC#, - 16#1401_5C4F#, 16#6306_6CD9#, 16#FA0F_3D63#, 16#8D08_0DF5#, - 16#3B6E_20C8#, 16#4C69_105E#, 16#D560_41E4#, 16#A267_7172#, - 16#3C03_E4D1#, 16#4B04_D447#, 16#D20D_85FD#, 16#A50A_B56B#, - 16#35B5_A8FA#, 16#42B2_986C#, 16#DBBB_C9D6#, 16#ACBC_F940#, - 16#32D8_6CE3#, 16#45DF_5C75#, 16#DCD6_0DCF#, 16#ABD1_3D59#, - 16#26D9_30AC#, 16#51DE_003A#, 16#C8D7_5180#, 16#BFD0_6116#, - 16#21B4_F4B5#, 16#56B3_C423#, 16#CFBA_9599#, 16#B8BD_A50F#, - 16#2802_B89E#, 16#5F05_8808#, 16#C60C_D9B2#, 16#B10B_E924#, - 16#2F6F_7C87#, 16#5868_4C11#, 16#C161_1DAB#, 16#B666_2D3D#, - 16#76DC_4190#, 16#01DB_7106#, 16#98D2_20BC#, 16#EFD5_102A#, - 16#71B1_8589#, 16#06B6_B51F#, 16#9FBF_E4A5#, 16#E8B8_D433#, - 16#7807_C9A2#, 16#0F00_F934#, 16#9609_A88E#, 16#E10E_9818#, - 16#7F6A_0DBB#, 16#086D_3D2D#, 16#9164_6C97#, 16#E663_5C01#, - 16#6B6B_51F4#, 16#1C6C_6162#, 16#8565_30D8#, 16#F262_004E#, - 16#6C06_95ED#, 16#1B01_A57B#, 16#8208_F4C1#, 16#F50F_C457#, - 16#65B0_D9C6#, 16#12B7_E950#, 16#8BBE_B8EA#, 16#FCB9_887C#, - 16#62DD_1DDF#, 16#15DA_2D49#, 16#8CD3_7CF3#, 16#FBD4_4C65#, - 16#4DB2_6158#, 16#3AB5_51CE#, 16#A3BC_0074#, 16#D4BB_30E2#, - 16#4ADF_A541#, 16#3DD8_95D7#, 16#A4D1_C46D#, 16#D3D6_F4FB#, - 16#4369_E96A#, 16#346E_D9FC#, 16#AD67_8846#, 16#DA60_B8D0#, - 16#4404_2D73#, 16#3303_1DE5#, 16#AA0A_4C5F#, 16#DD0D_7CC9#, - 16#5005_713C#, 16#2702_41AA#, 16#BE0B_1010#, 16#C90C_2086#, - 16#5768_B525#, 16#206F_85B3#, 16#B966_D409#, 16#CE61_E49F#, - 16#5EDE_F90E#, 16#29D9_C998#, 16#B0D0_9822#, 16#C7D7_A8B4#, - 16#59B3_3D17#, 16#2EB4_0D81#, 16#B7BD_5C3B#, 16#C0BA_6CAD#, - 16#EDB8_8320#, 16#9ABF_B3B6#, 16#03B6_E20C#, 16#74B1_D29A#, - 16#EAD5_4739#, 16#9DD2_77AF#, 16#04DB_2615#, 16#73DC_1683#, - 16#E363_0B12#, 16#9464_3B84#, 16#0D6D_6A3E#, 16#7A6A_5AA8#, - 16#E40E_CF0B#, 16#9309_FF9D#, 16#0A00_AE27#, 16#7D07_9EB1#, - 16#F00F_9344#, 16#8708_A3D2#, 16#1E01_F268#, 16#6906_C2FE#, - 16#F762_575D#, 16#8065_67CB#, 16#196C_3671#, 16#6E6B_06E7#, - 16#FED4_1B76#, 16#89D3_2BE0#, 16#10DA_7A5A#, 16#67DD_4ACC#, - 16#F9B9_DF6F#, 16#8EBE_EFF9#, 16#17B7_BE43#, 16#60B0_8ED5#, - 16#D6D6_A3E8#, 16#A1D1_937E#, 16#38D8_C2C4#, 16#4FDF_F252#, - 16#D1BB_67F1#, 16#A6BC_5767#, 16#3FB5_06DD#, 16#48B2_364B#, - 16#D80D_2BDA#, 16#AF0A_1B4C#, 16#3603_4AF6#, 16#4104_7A60#, - 16#DF60_EFC3#, 16#A867_DF55#, 16#316E_8EEF#, 16#4669_BE79#, - 16#CB61_B38C#, 16#BC66_831A#, 16#256F_D2A0#, 16#5268_E236#, - 16#CC0C_7795#, 16#BB0B_4703#, 16#2202_16B9#, 16#5505_262F#, - 16#C5BA_3BBE#, 16#B2BD_0B28#, 16#2BB4_5A92#, 16#5CB3_6A04#, - 16#C2D7_FFA7#, 16#B5D0_CF31#, 16#2CD9_9E8B#, 16#5BDE_AE1D#, - 16#9B64_C2B0#, 16#EC63_F226#, 16#756A_A39C#, 16#026D_930A#, - 16#9C09_06A9#, 16#EB0E_363F#, 16#7207_6785#, 16#0500_5713#, - 16#95BF_4A82#, 16#E2B8_7A14#, 16#7BB1_2BAE#, 16#0CB6_1B38#, - 16#92D2_8E9B#, 16#E5D5_BE0D#, 16#7CDC_EFB7#, 16#0BDB_DF21#, - 16#86D3_D2D4#, 16#F1D4_E242#, 16#68DD_B3F8#, 16#1FDA_836E#, - 16#81BE_16CD#, 16#F6B9_265B#, 16#6FB0_77E1#, 16#18B7_4777#, - 16#8808_5AE6#, 16#FF0F_6A70#, 16#6606_3BCA#, 16#1101_0B5C#, - 16#8F65_9EFF#, 16#F862_AE69#, 16#616B_FFD3#, 16#166C_CF45#, - 16#A00A_E278#, 16#D70D_D2EE#, 16#4E04_8354#, 16#3903_B3C2#, - 16#A767_2661#, 16#D060_16F7#, 16#4969_474D#, 16#3E6E_77DB#, - 16#AED1_6A4A#, 16#D9D6_5ADC#, 16#40DF_0B66#, 16#37D8_3BF0#, - 16#A9BC_AE53#, 16#DEBB_9EC5#, 16#47B2_CF7F#, 16#30B5_FFE9#, - 16#BDBD_F21C#, 16#CABA_C28A#, 16#53B3_9330#, 16#24B4_A3A6#, - 16#BAD0_3605#, 16#CDD7_0693#, 16#54DE_5729#, 16#23D9_67BF#, - 16#B366_7A2E#, 16#C461_4AB8#, 16#5D68_1B02#, 16#2A6F_2B94#, - 16#B40B_BE37#, 16#C30C_8EA1#, 16#5A05_DF1B#, 16#2D02_EF8D#); - - --------------- - -- Get_Value -- - --------------- - - function Get_Value (C : CRC32) return Interfaces.Unsigned_32 is - begin - return Interfaces.Unsigned_32 (C xor XorOut); - end Get_Value; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (C : out CRC32) is - begin - C := Init; - end Initialize; - - ------------ - -- Update -- - ------------ - - procedure Update (C : in out CRC32; Value : Character) is - V : constant CRC32 := CRC32 (Character'Pos (Value)); - begin - C := Shift_Right (C, 8) xor Table (V xor (C and 16#0000_00FF#)); - end Update; - -end System.CRC32; diff --git a/gcc/ada/s-crc32.ads b/gcc/ada/s-crc32.ads deleted file mode 100644 index 7d9e158..0000000 --- a/gcc/ada/s-crc32.ads +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- S Y S T E M . C R C 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides routines for computing a commonly used checksum --- called CRC-32. This is a checksum based on treating the binary data --- as a polynomial over a binary field, and the exact specifications of --- the CRC-32 algorithm are as follows: --- --- Name : "CRC-32" --- Width : 32 --- Poly : 04C11DB7 --- Init : FFFFFFFF --- RefIn : True --- RefOut : True --- XorOut : FFFFFFFF --- Check : CBF43926 --- --- Note that this is the algorithm used by PKZip, Ethernet and FDDI. --- --- For more information about this algorithm see: --- --- ftp://ftp.rocksoft.com/papers/crc_v3.txt - --- "A Painless Guide to CRC Error Detection Algorithms", Ross N. Williams --- --- "Computation of Cyclic Redundancy Checks via Table Look-Up", Communications --- of the ACM, Vol. 31 No. 8, pp.1008-1013 Aug. 1988. Sarwate, D.V. - -pragma Compiler_Unit_Warning; - -with Interfaces; - -package System.CRC32 is - - type CRC32 is new Interfaces.Unsigned_32; - -- Used to represent CRC32 values, which are 32 bit bit-strings - - procedure Initialize (C : out CRC32); - pragma Inline (Initialize); - -- Initialize CRC value by assigning the standard Init value (16#FFFF_FFFF) - - procedure Update - (C : in out CRC32; - Value : Character); - pragma Inline (Update); - -- Evolve CRC by including the contribution from Character'Pos (Value) - - function Get_Value (C : CRC32) return Interfaces.Unsigned_32; - pragma Inline (Get_Value); - -- Get_Value computes the CRC32 value by performing an XOR with the - -- standard XorOut value (16#FFFF_FFFF). Note that this does not - -- change the value of C, so it may be used to retrieve intermediate - -- values of the CRC32 value during a sequence of Update calls. - -end System.CRC32; diff --git a/gcc/ada/s-crtl.ads b/gcc/ada/s-crtl.ads deleted file mode 100644 index 217b5b6..0000000 --- a/gcc/ada/s-crtl.ads +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . C R T L -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the low level interface to the C runtime library - -pragma Compiler_Unit_Warning; - -with System.Parameters; - -package System.CRTL is - pragma Preelaborate; - - subtype chars is System.Address; - -- Pointer to null-terminated array of characters - -- Should use Interfaces.C.Strings types instead, but this causes bootstrap - -- issues as i-c contains Ada 2005 specific features, not compatible with - -- older, Ada 95-only base compilers??? - - subtype DIRs is System.Address; - -- Corresponds to the C type DIR* - - subtype FILEs is System.Address; - -- Corresponds to the C type FILE* - - subtype int is Integer; - - type long is range -(2 ** (System.Parameters.long_bits - 1)) - .. +(2 ** (System.Parameters.long_bits - 1)) - 1; - - subtype off_t is Long_Integer; - - type size_t is mod 2 ** Standard'Address_Size; - - type ssize_t is range -(2 ** (Standard'Address_Size - 1)) - .. +(2 ** (Standard'Address_Size - 1)) - 1; - - type int64 is new Long_Long_Integer; - -- Note: we use Long_Long_Integer'First instead of -2 ** 63 to allow this - -- unit to compile when using custom target configuration files where the - -- maximum integer is 32 bits. This is useful for static analysis tools - -- such as SPARK or CodePeer. In the normal case, Long_Long_Integer is - -- always 64-bits so there is no difference. - - type Filename_Encoding is (UTF8, ASCII_8bits, Unspecified); - for Filename_Encoding use (UTF8 => 0, ASCII_8bits => 1, Unspecified => 2); - pragma Convention (C, Filename_Encoding); - -- Describes the filename's encoding - - -------------------- - -- GCC intrinsics -- - -------------------- - - -- The following functions are imported with convention Intrinsic so that - -- we take advantage of back-end builtins if present (else we fall back - -- to C library functions by the same names). - - function strlen (A : System.Address) return size_t; - pragma Import (Intrinsic, strlen, "strlen"); - - procedure strncpy (dest, src : System.Address; n : size_t); - pragma Import (Intrinsic, strncpy, "strncpy"); - - ------------------------------- - -- Other C runtime functions -- - ------------------------------- - - function atoi (A : System.Address) return Integer; - pragma Import (C, atoi, "atoi"); - - procedure clearerr (stream : FILEs); - pragma Import (C, clearerr, "clearerr"); - - function dup (handle : int) return int; - pragma Import (C, dup, "dup"); - - function dup2 (from, to : int) return int; - pragma Import (C, dup2, "dup2"); - - function fclose (stream : FILEs) return int; - pragma Import (C, fclose, "fclose"); - - function fdopen (handle : int; mode : chars) return FILEs; - pragma Import (C, fdopen, "fdopen"); - - function fflush (stream : FILEs) return int; - pragma Import (C, fflush, "fflush"); - - function fgetc (stream : FILEs) return int; - pragma Import (C, fgetc, "fgetc"); - - function fgets (strng : chars; n : int; stream : FILEs) return chars; - pragma Import (C, fgets, "fgets"); - - function fopen - (filename : chars; - mode : chars; - encoding : Filename_Encoding := Unspecified) return FILEs; - pragma Import (C, fopen, "__gnat_fopen"); - - function fputc (C : int; stream : FILEs) return int; - pragma Import (C, fputc, "fputc"); - - function fputwc (C : int; stream : FILEs) return int; - pragma Import (C, fputwc, "__gnat_fputwc"); - - function fputs (Strng : chars; Stream : FILEs) return int; - pragma Import (C, fputs, "fputs"); - - procedure free (Ptr : System.Address); - pragma Import (C, free, "free"); - - function freopen - (filename : chars; - mode : chars; - stream : FILEs; - encoding : Filename_Encoding := Unspecified) return FILEs; - pragma Import (C, freopen, "__gnat_freopen"); - - function fseek - (stream : FILEs; - offset : long; - origin : int) return int; - pragma Import (C, fseek, "fseek"); - - function fseek64 - (stream : FILEs; - offset : int64; - origin : int) return int; - pragma Import (C, fseek64, "__gnat_fseek64"); - - function ftell (stream : FILEs) return long; - pragma Import (C, ftell, "ftell"); - - function ftell64 (stream : FILEs) return int64; - pragma Import (C, ftell64, "__gnat_ftell64"); - - function getenv (S : String) return System.Address; - pragma Import (C, getenv, "getenv"); - - function isatty (handle : int) return int; - pragma Import (C, isatty, "isatty"); - - function lseek (fd : int; offset : off_t; direction : int) return off_t; - pragma Import (C, lseek, "lseek"); - - function malloc (Size : size_t) return System.Address; - pragma Import (C, malloc, "malloc"); - - procedure memcpy (S1 : System.Address; S2 : System.Address; N : size_t); - pragma Import (C, memcpy, "memcpy"); - - procedure memmove (S1 : System.Address; S2 : System.Address; N : size_t); - pragma Import (C, memmove, "memmove"); - - procedure mktemp (template : chars); - pragma Import (C, mktemp, "mktemp"); - - function pclose (stream : System.Address) return int; - pragma Import (C, pclose, "pclose"); - - function popen (command, mode : System.Address) return System.Address; - pragma Import (C, popen, "popen"); - - function realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, realloc, "realloc"); - - procedure rewind (stream : FILEs); - pragma Import (C, rewind, "rewind"); - - function rmdir (dir_name : String) return int; - pragma Import (C, rmdir, "__gnat_rmdir"); - - function chdir (dir_name : String) return int; - pragma Import (C, chdir, "__gnat_chdir"); - - function mkdir - (dir_name : String; - encoding : Filename_Encoding := Unspecified) return int; - pragma Import (C, mkdir, "__gnat_mkdir"); - - function setvbuf - (stream : FILEs; - buffer : chars; - mode : int; - size : size_t) return int; - pragma Import (C, setvbuf, "setvbuf"); - - procedure tmpnam (str : chars); - pragma Import (C, tmpnam, "tmpnam"); - - function tmpfile return FILEs; - pragma Import (C, tmpfile, "tmpfile"); - - function ungetc (c : int; stream : FILEs) return int; - pragma Import (C, ungetc, "ungetc"); - - function unlink (filename : chars) return int; - pragma Import (C, unlink, "__gnat_unlink"); - - function open (filename : chars; oflag : int) return int; - pragma Import (C, open, "__gnat_open"); - - function close (fd : int) return int; - pragma Import (C, close, "close"); - - function read (fd : int; buffer : chars; count : size_t) return ssize_t; - pragma Import (C, read, "read"); - - function write (fd : int; buffer : chars; count : size_t) return ssize_t; - pragma Import (C, write, "write"); - -end System.CRTL; diff --git a/gcc/ada/s-diflio.adb b/gcc/ada/s-diflio.adb deleted file mode 100644 index 5c553a0..0000000 --- a/gcc/ada/s-diflio.adb +++ /dev/null @@ -1,132 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M . F L O A T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Dim.Float_IO is - - package Num_Dim_Float_IO is new Ada.Text_IO.Float_IO (Num_Dim_Float); - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := "") - is - begin - Num_Dim_Float_IO.Put (File, Item, Fore, Aft, Exp); - Ada.Text_IO.Put (File, Symbol); - end Put; - - procedure Put - (Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := "") - is - begin - Num_Dim_Float_IO.Put (Item, Fore, Aft, Exp); - Ada.Text_IO.Put (Symbol); - end Put; - - procedure Put - (To : out String; - Item : Num_Dim_Float; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := "") - is - Ptr : constant Natural := Symbol'Length; - - begin - Num_Dim_Float_IO.Put (To (To'First .. To'Last - Ptr), Item, Aft, Exp); - To (To'Last - Ptr + 1 .. To'Last) := Symbol; - end Put; - - ---------------- - -- Put_Dim_Of -- - ---------------- - - pragma Warnings (Off); - -- kill warnings on unreferenced formals - - procedure Put_Dim_Of - (File : File_Type; - Item : Num_Dim_Float; - Symbol : String := "") - is - begin - Ada.Text_IO.Put (File, Symbol); - end Put_Dim_Of; - - procedure Put_Dim_Of - (Item : Num_Dim_Float; - Symbol : String := "") - is - begin - Ada.Text_IO.Put (Symbol); - end Put_Dim_Of; - - procedure Put_Dim_Of - (To : out String; - Item : Num_Dim_Float; - Symbol : String := "") - is - begin - To (1 .. Symbol'Length) := Symbol; - end Put_Dim_Of; - - ----------- - -- Image -- - ----------- - - function Image - (Item : Num_Dim_Float; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := "") return String - is - Buffer : String (1 .. 50); - - begin - Put (Buffer, Item, Aft, Exp); - for I in Buffer'Range loop - if Buffer (I) /= ' ' then - return Buffer (I .. Buffer'Last) & Symbol; - end if; - end loop; - end Image; -end System.Dim.Float_IO; diff --git a/gcc/ada/s-diflio.ads b/gcc/ada/s-diflio.ads deleted file mode 100644 index 223f5a2..0000000 --- a/gcc/ada/s-diflio.ads +++ /dev/null @@ -1,184 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M . F L O A T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides output routines for float dimensioned types. All Put --- routines are modeled after those in package Ada.Text_IO.Float_IO with the --- addition of an extra default parameter. All Put_Dim_Of routines --- output the dimension of Item in a symbolic manner. - --- Parameter Symbol may be used in the following manner (all the examples are --- based on the MKS system of units defined in package System.Dim.Mks): - --- type Mks_Type is new Long_Long_Float --- with --- Dimension_System => ( --- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), --- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), --- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), --- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), --- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), --- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), --- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); - --- Case 1. A value is supplied for Symbol - --- * Put : The string appears as a suffix of Item - --- * Put_Dim_Of : The string appears alone - --- Obj : Mks_Type := 2.6; --- Put (Obj, 1, 1, 0, " dimensionless"); --- Put_Dim_Of (Obj, "dimensionless"); - --- The corresponding outputs are: --- $2.6 dimensionless --- $dimensionless - --- Case 2. No value is supplied for Symbol and Item is dimensionless - --- * Put : Item appears without a suffix - --- * Put_Dim_Of : the output is [] - --- Obj : Mks_Type := 2.6; --- Put (Obj, 1, 1, 0); --- Put_Dim_Of (Obj); - --- The corresponding outputs are: --- $2.6 --- $[] - --- Case 3. No value is supplied for Symbol and Item has a dimension - --- * Put : If the type of Item is a dimensioned subtype whose --- symbol is not empty, then the symbol appears as a suffix. --- Otherwise, a new string is created and appears as a --- suffix of Item. This string results in the successive --- concatenations between each unit symbol raised by its --- corresponding dimension power from the dimensions of Item. - --- * Put_Dim_Of : The output is a new string resulting in the successive --- concatenations between each dimension symbol raised by its --- corresponding dimension power from the dimensions of Item. - --- subtype Length is Mks_Type --- with --- Dimension => ('m', --- Meter => 1, --- others => 0); - --- Obj : Length := 2.3 * dm; --- Put (Obj, 1, 2, 0); --- Put_Dim_Of (Obj); - --- The corresponding outputs are: --- $0.23 m --- $[L] - --- subtype Random is Mks_Type --- with --- Dimension => ( --- Meter => 3, --- Candela => -1, --- others => 0); - --- Obj : Random := 5.0; --- Put (Obj); --- Put_Dim_Of (Obj); - --- The corresponding outputs are: --- $5.0 m**3.cd**(-1) --- $[l**3.J**(-1)] - --- Put (3.3 * km * dm * min, 5, 1, 0); --- Put_Dim_Of (3.3 * km * dm * min); - --- The corresponding outputs are: --- $19800.0 m**2.s --- $[L**2.T] - -with Ada.Text_IO; use Ada.Text_IO; - -generic - type Num_Dim_Float is digits <>; - -package System.Dim.Float_IO is - - Default_Fore : Field := 2; - Default_Aft : Field := Num_Dim_Float'Digits - 1; - Default_Exp : Field := 3; - - procedure Put - (File : File_Type; - Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := ""); - - procedure Put - (Item : Num_Dim_Float; - Fore : Field := Default_Fore; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := ""); - - procedure Put - (To : out String; - Item : Num_Dim_Float; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := ""); - - procedure Put_Dim_Of - (File : File_Type; - Item : Num_Dim_Float; - Symbol : String := ""); - - procedure Put_Dim_Of - (Item : Num_Dim_Float; - Symbol : String := ""); - - procedure Put_Dim_Of - (To : out String; - Item : Num_Dim_Float; - Symbol : String := ""); - - pragma Inline (Put); - pragma Inline (Put_Dim_Of); - - function Image - (Item : Num_Dim_Float; - Aft : Field := Default_Aft; - Exp : Field := Default_Exp; - Symbol : String := "") return String; - -end System.Dim.Float_IO; diff --git a/gcc/ada/s-diinio.adb b/gcc/ada/s-diinio.adb deleted file mode 100644 index d8f4fcc..0000000 --- a/gcc/ada/s-diinio.adb +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M . I N T E G E R _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Dim.Integer_IO is - - package Num_Dim_Integer_IO is new Ada.Text_IO.Integer_IO (Num_Dim_Integer); - - --------- - -- Put -- - --------- - - procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbol : String := "") - - is - begin - Num_Dim_Integer_IO.Put (File, Item, Width, Base); - Ada.Text_IO.Put (File, Symbol); - end Put; - - procedure Put - (Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbol : String := "") - - is - begin - Num_Dim_Integer_IO.Put (Item, Width, Base); - Ada.Text_IO.Put (Symbol); - end Put; - - procedure Put - (To : out String; - Item : Num_Dim_Integer; - Base : Number_Base := Default_Base; - Symbol : String := "") - - is - begin - Num_Dim_Integer_IO.Put (To, Item, Base); - To := To & Symbol; - end Put; - - ---------------- - -- Put_Dim_Of -- - ---------------- - - pragma Warnings (Off); - -- kill warnings on unreferenced formals - - procedure Put_Dim_Of - (File : File_Type; - Item : Num_Dim_Integer; - Symbol : String := "") - is - begin - Ada.Text_IO.Put (File, Symbol); - end Put_Dim_Of; - - procedure Put_Dim_Of - (Item : Num_Dim_Integer; - Symbol : String := "") - is - begin - Ada.Text_IO.Put (Symbol); - end Put_Dim_Of; - - procedure Put_Dim_Of - (To : out String; - Item : Num_Dim_Integer; - Symbol : String := "") - is - begin - To := Symbol; - end Put_Dim_Of; -end System.Dim.Integer_IO; diff --git a/gcc/ada/s-diinio.ads b/gcc/ada/s-diinio.ads deleted file mode 100644 index babcc16..0000000 --- a/gcc/ada/s-diinio.ads +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M . I N T E G E R _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides output routines for integer dimensioned types. All --- Put routines are modeled after those in package Ada.Text_IO.Integer_IO --- with the addition of an extra default parameter. All Put_Dim_Of routines --- output the dimension of Item in a symbolic manner. - --- Parameter Symbol may be used in the following manner (all the examples are --- based on the MKS system of units as defined in package System.Dim.Mks): - --- type Mks_Type is new Integer --- with --- Dimension_System => ( --- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), --- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), --- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), --- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), --- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), --- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), --- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); - --- Case 1. A value is supplied for Symbol - --- * Put : The string appears as a suffix of Item - --- * Put_Dim_Of : The string appears alone - --- Obj : Mks_Type := 2; --- Put (Obj, Symbols => "dimensionless"); --- Put_Dim_Of (Obj, Symbols => "dimensionless"); - --- The corresponding outputs are: --- $2 dimensionless --- $dimensionless - --- Case 2. No value is supplied for Symbol and Item is dimensionless - --- * Put : Item appears without a suffix - --- * Put_Dim_Of : the output is [] - --- Obj : Mks_Type := 2; --- Put (Obj); --- Put_Dim_Of (Obj); - --- The corresponding outputs are: --- $2 --- $[] - --- Case 3. No value is supplied for Symbol and Item has a dimension - --- * Put : If the type of Item is a dimensioned subtype whose --- symbol is not empty, then the symbol appears as a suffix. --- Otherwise, a new string is created and appears as a --- suffix of Item. This string results in the successive --- concatenations between each unit symbol raised by its --- corresponding dimension power from the dimensions of Item. - --- * Put_Dim_Of : The output is a new string resulting in the successive --- concatenations between each dimension symbol raised by its --- corresponding dimension power from the dimensions of Item. - --- subtype Length is Mks_Type --- with --- Dimension => ('m', --- Meter => 1, --- others => 0); - --- Obj : Length := 2; --- Put (Obj); --- Put_Dim_Of (Obj); - --- The corresponding outputs are: --- $2 m --- $[L] - --- subtype Random is Mks_Type --- with --- Dimension => ("", --- Meter => 3, --- Candela => 2, --- others => 0); - --- Obj : Random := 5; --- Put (Obj); --- Put_Dim_Of (Obj); - --- The corresponding outputs are: --- $5 m**3.cd**2 --- $[L**3.J**2] - -with Ada.Text_IO; use Ada.Text_IO; - -generic - type Num_Dim_Integer is range <>; - -package System.Dim.Integer_IO is - - Default_Width : Field := Num_Dim_Integer'Width; - Default_Base : Number_Base := 10; - - procedure Put - (File : File_Type; - Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbol : String := ""); - - procedure Put - (Item : Num_Dim_Integer; - Width : Field := Default_Width; - Base : Number_Base := Default_Base; - Symbol : String := ""); - - procedure Put - (To : out String; - Item : Num_Dim_Integer; - Base : Number_Base := Default_Base; - Symbol : String := ""); - - procedure Put_Dim_Of - (File : File_Type; - Item : Num_Dim_Integer; - Symbol : String := ""); - - procedure Put_Dim_Of - (Item : Num_Dim_Integer; - Symbol : String := ""); - - procedure Put_Dim_Of - (To : out String; - Item : Num_Dim_Integer; - Symbol : String := ""); - - pragma Inline (Put); - pragma Inline (Put_Dim_Of); - -end System.Dim.Integer_IO; diff --git a/gcc/ada/s-dim.ads b/gcc/ada/s-dim.ads deleted file mode 100644 index f4b1003..0000000 --- a/gcc/ada/s-dim.ads +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M -- --- -- --- S p e c -- --- -- --- Copyright (C) 2012-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Defines the dimension terminology - ---------------------------- --- Dimension Terminology -- ---------------------------- - --- * Dimensioned type - --- A dimensioned type is a type (more accurately a first subtype) to which --- the aspect Dimension_System applies to. - --- type Mks_Type is new Long_Long_Float --- with --- Dimension_System => ( --- (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), --- (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), --- (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), --- (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), --- (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => "Θ"), --- (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), --- (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); - --- * Dimensioned subtype - --- A dimensioned subtype is a subtype directly defined from the dimensioned --- type and to which the aspect Dimension applies to. - --- subtype Length is Mks_Type --- with --- Dimension => (Symbol => 'm', --- Meter => 1, --- others => 0); - -package System.Dim is - pragma Pure; - -end System.Dim; diff --git a/gcc/ada/s-dimkio.ads b/gcc/ada/s-dimkio.ads deleted file mode 100644 index b7f4de9..0000000 --- a/gcc/ada/s-dimkio.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M . M K S _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Provides output facilities for the MKS dimension system (see System.Dim.Mks --- and System.Dim.Float_IO). - -with System.Dim.Mks; use System.Dim.Mks; -with System.Dim.Float_IO; - -package System.Dim.Mks_IO is new System.Dim.Float_IO (Mks_Type); diff --git a/gcc/ada/s-dimmks.ads b/gcc/ada/s-dimmks.ads deleted file mode 100644 index 1b131c4..0000000 --- a/gcc/ada/s-dimmks.ads +++ /dev/null @@ -1,393 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M . M K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Defines the MKS dimension system which is the SI system of units - --- Some other prefixes of this system are defined in a child package (see --- System.Dim_Mks.Other_Prefixes) in order to avoid too many constant --- declarations in this package. - --- The dimension terminology is defined in System.Dim_IO package - -with Ada.Numerics; - -package System.Dim.Mks is - - e : constant := Ada.Numerics.e; - Pi : constant := Ada.Numerics.Pi; - - -- Dimensioned type Mks_Type - - type Mks_Type is new Long_Long_Float - with - Dimension_System => ( - (Unit_Name => Meter, Unit_Symbol => 'm', Dim_Symbol => 'L'), - (Unit_Name => Kilogram, Unit_Symbol => "kg", Dim_Symbol => 'M'), - (Unit_Name => Second, Unit_Symbol => 's', Dim_Symbol => 'T'), - (Unit_Name => Ampere, Unit_Symbol => 'A', Dim_Symbol => 'I'), - (Unit_Name => Kelvin, Unit_Symbol => 'K', Dim_Symbol => '@'), - (Unit_Name => Mole, Unit_Symbol => "mol", Dim_Symbol => 'N'), - (Unit_Name => Candela, Unit_Symbol => "cd", Dim_Symbol => 'J')); - - -- SI Base dimensioned subtypes - - subtype Length is Mks_Type - with - Dimension => (Symbol => 'm', - Meter => 1, - others => 0); - - subtype Mass is Mks_Type - with - Dimension => (Symbol => "kg", - Kilogram => 1, - others => 0); - - subtype Time is Mks_Type - with - Dimension => (Symbol => 's', - Second => 1, - others => 0); - - subtype Electric_Current is Mks_Type - with - Dimension => (Symbol => 'A', - Ampere => 1, - others => 0); - - subtype Thermodynamic_Temperature is Mks_Type - with - Dimension => (Symbol => 'K', - Kelvin => 1, - others => 0); - - subtype Amount_Of_Substance is Mks_Type - with - Dimension => (Symbol => "mol", - Mole => 1, - others => 0); - - subtype Luminous_Intensity is Mks_Type - with - Dimension => (Symbol => "cd", - Candela => 1, - others => 0); - - -- Initialize SI Base unit values - - -- Turn off the all the dimension warnings for these basic assignments - -- since otherwise we would get complaints about assigning dimensionless - -- values to dimensioned subtypes (we can't assign 1.0*m to m). - - pragma Warnings (Off, "*assumed to be*"); - - m : constant Length := 1.0; - kg : constant Mass := 1.0; - s : constant Time := 1.0; - A : constant Electric_Current := 1.0; - K : constant Thermodynamic_Temperature := 1.0; - mol : constant Amount_Of_Substance := 1.0; - cd : constant Luminous_Intensity := 1.0; - - pragma Warnings (On, "*assumed to be*"); - - -- SI Derived dimensioned subtypes - - subtype Absorbed_Dose is Mks_Type - with - Dimension => (Symbol => "Gy", - Meter => 2, - Second => -2, - others => 0); - - subtype Angle is Mks_Type - with - Dimension => (Symbol => "rad", - others => 0); - - subtype Area is Mks_Type - with - Dimension => ( - Meter => 2, - others => 0); - - subtype Catalytic_Activity is Mks_Type - with - Dimension => (Symbol => "kat", - Second => -1, - Mole => 1, - others => 0); - - subtype Celsius_Temperature is Mks_Type - with - Dimension => (Symbol => "°C", - Kelvin => 1, - others => 0); - - subtype Electric_Capacitance is Mks_Type - with - Dimension => (Symbol => 'F', - Meter => -2, - Kilogram => -1, - Second => 4, - Ampere => 2, - others => 0); - - subtype Electric_Charge is Mks_Type - with - Dimension => (Symbol => 'C', - Second => 1, - Ampere => 1, - others => 0); - - subtype Electric_Conductance is Mks_Type - with - Dimension => (Symbol => 'S', - Meter => -2, - Kilogram => -1, - Second => 3, - Ampere => 2, - others => 0); - - subtype Electric_Potential_Difference is Mks_Type - with - Dimension => (Symbol => 'V', - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -1, - others => 0); - - -- Note the type punning below. The Symbol is a single "ohm" character - -- encoded in UTF-8 (ce a9 in hexadecimal), but this file is not compiled - -- with -gnatW8, so we're treating the string literal as a two-character - -- String. - - subtype Electric_Resistance is Mks_Type - with - Dimension => (Symbol => "Ω", - Meter => 2, - Kilogram => 1, - Second => -3, - Ampere => -2, - others => 0); - - subtype Energy is Mks_Type - with - Dimension => (Symbol => 'J', - Meter => 2, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Equivalent_Dose is Mks_Type - with - Dimension => (Symbol => "Sv", - Meter => 2, - Second => -2, - others => 0); - - subtype Force is Mks_Type - with - Dimension => (Symbol => 'N', - Meter => 1, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Frequency is Mks_Type - with - Dimension => (Symbol => "Hz", - Second => -1, - others => 0); - - subtype Illuminance is Mks_Type - with - Dimension => (Symbol => "lx", - Meter => -2, - Candela => 1, - others => 0); - - subtype Inductance is Mks_Type - with - Dimension => (Symbol => 'H', - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -2, - others => 0); - - subtype Luminous_Flux is Mks_Type - with - Dimension => (Symbol => "lm", - Candela => 1, - others => 0); - - subtype Magnetic_Flux is Mks_Type - with - Dimension => (Symbol => "Wb", - Meter => 2, - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); - - subtype Magnetic_Flux_Density is Mks_Type - with - Dimension => (Symbol => 'T', - Kilogram => 1, - Second => -2, - Ampere => -1, - others => 0); - - subtype Power is Mks_Type - with - Dimension => (Symbol => 'W', - Meter => 2, - Kilogram => 1, - Second => -3, - others => 0); - - subtype Pressure is Mks_Type - with - Dimension => (Symbol => "Pa", - Meter => -1, - Kilogram => 1, - Second => -2, - others => 0); - - subtype Radioactivity is Mks_Type - with - Dimension => (Symbol => "Bq", - Second => -1, - others => 0); - - subtype Solid_Angle is Mks_Type - with - Dimension => (Symbol => "sr", - others => 0); - - subtype Speed is Mks_Type - with - Dimension => ( - Meter => 1, - Second => -1, - others => 0); - - subtype Volume is Mks_Type - with - Dimension => ( - Meter => 3, - others => 0); - - -- Initialize derived dimension values - - -- Turn off the all the dimension warnings for these basic assignments - -- since otherwise we would get complaints about assigning dimensionless - -- values to dimensioned subtypes. - - pragma Warnings (Off, "*assumed to be*"); - - rad : constant Angle := 1.0; - sr : constant Solid_Angle := 1.0; - Hz : constant Frequency := 1.0; - N : constant Force := 1.0; - Pa : constant Pressure := 1.0; - J : constant Energy := 1.0; - W : constant Power := 1.0; - C : constant Electric_Charge := 1.0; - V : constant Electric_Potential_Difference := 1.0; - F : constant Electric_Capacitance := 1.0; - Ohm : constant Electric_Resistance := 1.0; - Si : constant Electric_Conductance := 1.0; - Wb : constant Magnetic_Flux := 1.0; - T : constant Magnetic_Flux_Density := 1.0; - H : constant Inductance := 1.0; - dC : constant Celsius_Temperature := 273.15; - lm : constant Luminous_Flux := 1.0; - lx : constant Illuminance := 1.0; - Bq : constant Radioactivity := 1.0; - Gy : constant Absorbed_Dose := 1.0; - Sv : constant Equivalent_Dose := 1.0; - kat : constant Catalytic_Activity := 1.0; - - -- SI prefixes for Meter - - um : constant Length := 1.0E-06; -- micro (u) - mm : constant Length := 1.0E-03; -- milli - cm : constant Length := 1.0E-02; -- centi - dm : constant Length := 1.0E-01; -- deci - dam : constant Length := 1.0E+01; -- deka - hm : constant Length := 1.0E+02; -- hecto - km : constant Length := 1.0E+03; -- kilo - Mem : constant Length := 1.0E+06; -- mega - - -- SI prefixes for Kilogram - - ug : constant Mass := 1.0E-09; -- micro (u) - mg : constant Mass := 1.0E-06; -- milli - cg : constant Mass := 1.0E-05; -- centi - dg : constant Mass := 1.0E-04; -- deci - g : constant Mass := 1.0E-03; -- gram - dag : constant Mass := 1.0E-02; -- deka - hg : constant Mass := 1.0E-01; -- hecto - Meg : constant Mass := 1.0E+03; -- mega - - -- SI prefixes for Second - - us : constant Time := 1.0E-06; -- micro (u) - ms : constant Time := 1.0E-03; -- milli - cs : constant Time := 1.0E-02; -- centi - ds : constant Time := 1.0E-01; -- deci - das : constant Time := 1.0E+01; -- deka - hs : constant Time := 1.0E+02; -- hecto - ks : constant Time := 1.0E+03; -- kilo - Mes : constant Time := 1.0E+06; -- mega - - -- Other constants for Second - - min : constant Time := 60.0 * s; - hour : constant Time := 60.0 * min; - day : constant Time := 24.0 * hour; - year : constant Time := 365.25 * day; - - -- SI prefixes for Ampere - - mA : constant Electric_Current := 1.0E-03; -- milli - cA : constant Electric_Current := 1.0E-02; -- centi - dA : constant Electric_Current := 1.0E-01; -- deci - daA : constant Electric_Current := 1.0E+01; -- deka - hA : constant Electric_Current := 1.0E+02; -- hecto - kA : constant Electric_Current := 1.0E+03; -- kilo - MeA : constant Electric_Current := 1.0E+06; -- mega - - pragma Warnings (On, "*assumed to be*"); -end System.Dim.Mks; diff --git a/gcc/ada/s-direio.adb b/gcc/ada/s-direio.adb deleted file mode 100644 index e4ccf36..0000000 --- a/gcc/ada/s-direio.adb +++ /dev/null @@ -1,399 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I R E C T _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; use Ada.IO_Exceptions; -with Ada.Unchecked_Deallocation; -with Interfaces.C_Streams; use Interfaces.C_Streams; -with System; use System; -with System.CRTL; -with System.File_IO; -with System.Soft_Links; - -package body System.Direct_IO is - - package FIO renames System.File_IO; - package SSL renames System.Soft_Links; - - subtype AP is FCB.AFCB_Ptr; - use type FCB.Shared_Status_Type; - - use type System.CRTL.int64; - use type System.CRTL.size_t; - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Set_Position (File : File_Type); - -- Sets file position pointer according to value of current index - - ------------------- - -- AFCB_Allocate -- - ------------------- - - function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr is - pragma Unreferenced (Control_Block); - begin - return new Direct_AFCB; - end AFCB_Allocate; - - ---------------- - -- AFCB_Close -- - ---------------- - - -- No special processing required for Direct_IO close - - procedure AFCB_Close (File : not null access Direct_AFCB) is - pragma Unreferenced (File); - begin - null; - end AFCB_Close; - - --------------- - -- AFCB_Free -- - --------------- - - procedure AFCB_Free (File : not null access Direct_AFCB) is - - type FCB_Ptr is access all Direct_AFCB; - - FT : FCB_Ptr := FCB_Ptr (File); - - procedure Free is new - Ada.Unchecked_Deallocation (Direct_AFCB, FCB_Ptr); - - begin - Free (FT); - end AFCB_Free; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : FCB.File_Mode := FCB.Inout_File; - Name : String := ""; - Form : String := "") - is - Dummy_File_Control_Block : Direct_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag is used for - -- dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => Mode, - Name => Name, - Form => Form, - Amethod => 'D', - Creat => True, - Text => False); - end Create; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : File_Type) return Boolean is - begin - FIO.Check_Read_Status (AP (File)); - return File.Index > Size (File); - end End_Of_File; - - ----------- - -- Index -- - ----------- - - function Index (File : File_Type) return Positive_Count is - begin - FIO.Check_File_Open (AP (File)); - return File.Index; - end Index; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : FCB.File_Mode; - Name : String; - Form : String := "") - is - Dummy_File_Control_Block : Direct_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag is used for - -- dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => Mode, - Name => Name, - Form => Form, - Amethod => 'D', - Creat => False, - Text => False); - end Open; - - ---------- - -- Read -- - ---------- - - procedure Read - (File : File_Type; - Item : Address; - Size : Interfaces.C_Streams.size_t; - From : Positive_Count) - is - begin - Set_Index (File, From); - Read (File, Item, Size); - end Read; - - procedure Read - (File : File_Type; - Item : Address; - Size : Interfaces.C_Streams.size_t) - is - begin - FIO.Check_Read_Status (AP (File)); - - -- If last operation was not a read, or if in file sharing mode, - -- then reset the physical pointer of the file to match the index - -- We lock out task access over the two operations in this case. - - if File.Last_Op /= Op_Read - or else File.Shared_Status = FCB.Yes - then - if End_Of_File (File) then - raise End_Error; - end if; - - Locked_Processing : begin - SSL.Lock_Task.all; - Set_Position (File); - FIO.Read_Buf (AP (File), Item, Size); - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked_Processing; - - else - FIO.Read_Buf (AP (File), Item, Size); - end if; - - File.Index := File.Index + 1; - - -- Set last operation to read, unless we did not read a full record - -- (happens with the variant record case) in which case we set the - -- last operation as other, to force the file position to be reset - -- on the next read. - - File.Last_Op := (if File.Bytes = Size then Op_Read else Op_Other); - end Read; - - -- The following is the required overriding for Stream.Read, which is - -- not used, since we do not do Stream operations on Direct_IO files. - - procedure Read - (File : in out Direct_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - begin - raise Program_Error; - end Read; - - ----------- - -- Reset -- - ----------- - - procedure Reset (File : in out File_Type; Mode : FCB.File_Mode) is - pragma Warnings (Off, File); - -- File is actually modified via Unrestricted_Access below, but - -- GNAT will generate a warning anyway. - -- - -- Note that we do not use pragma Unmodified here, since in -gnatc mode, - -- GNAT will complain that File is modified for "File.Index := 1;" - begin - FIO.Reset (AP (File)'Unrestricted_Access, Mode); - File.Index := 1; - File.Last_Op := Op_Read; - end Reset; - - procedure Reset (File : in out File_Type) is - pragma Warnings (Off, File); - -- See above (other Reset procedure) for explanations on this pragma - begin - FIO.Reset (AP (File)'Unrestricted_Access); - File.Index := 1; - File.Last_Op := Op_Read; - end Reset; - - --------------- - -- Set_Index -- - --------------- - - procedure Set_Index (File : File_Type; To : Positive_Count) is - begin - FIO.Check_File_Open (AP (File)); - File.Index := Count (To); - File.Last_Op := Op_Other; - end Set_Index; - - ------------------ - -- Set_Position -- - ------------------ - - procedure Set_Position (File : File_Type) is - R : int; - begin - R := - fseek64 - (File.Stream, int64 (File.Bytes) * int64 (File.Index - 1), SEEK_SET); - - if R /= 0 then - raise Use_Error; - end if; - end Set_Position; - - ---------- - -- Size -- - ---------- - - function Size (File : File_Type) return Count is - Pos : int64; - - begin - FIO.Check_File_Open (AP (File)); - File.Last_Op := Op_Other; - - if fseek64 (File.Stream, 0, SEEK_END) /= 0 then - raise Device_Error; - end if; - - Pos := ftell64 (File.Stream); - - if Pos = -1 then - raise Use_Error; - end if; - - return Count (Pos / int64 (File.Bytes)); - end Size; - - ----------- - -- Write -- - ----------- - - procedure Write - (File : File_Type; - Item : Address; - Size : Interfaces.C_Streams.size_t; - Zeroes : System.Storage_Elements.Storage_Array) - - is - procedure Do_Write; - -- Do the actual write - - -------------- - -- Do_Write -- - -------------- - - procedure Do_Write is - begin - FIO.Write_Buf (AP (File), Item, Size); - - -- If we did not write the whole record (happens with the variant - -- record case), then fill out the rest of the record with zeroes. - -- This is cleaner in any case, and is required for the last - -- record, since otherwise the length of the file is wrong. - - if File.Bytes > Size then - FIO.Write_Buf (AP (File), Zeroes'Address, File.Bytes - Size); - end if; - end Do_Write; - - -- Start of processing for Write - - begin - FIO.Check_Write_Status (AP (File)); - - -- If last operation was not a write, or if in file sharing mode, - -- then reset the physical pointer of the file to match the index - -- We lock out task access over the two operations in this case. - - if File.Last_Op /= Op_Write - or else File.Shared_Status = FCB.Yes - then - Locked_Processing : begin - SSL.Lock_Task.all; - Set_Position (File); - Do_Write; - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked_Processing; - - else - Do_Write; - end if; - - File.Index := File.Index + 1; - - -- Set last operation to write, unless we did not read a full record - -- (happens with the variant record case) in which case we set the - -- last operation as other, to force the file position to be reset - -- on the next write. - - File.Last_Op := (if File.Bytes = Size then Op_Write else Op_Other); - end Write; - - -- The following is the required overriding for Stream.Write, which is - -- not used, since we do not do Stream operations on Direct_IO files. - - procedure Write - (File : in out Direct_AFCB; - Item : Ada.Streams.Stream_Element_Array) - is - begin - raise Program_Error; - end Write; - -end System.Direct_IO; diff --git a/gcc/ada/s-direio.ads b/gcc/ada/s-direio.ads deleted file mode 100644 index 4a60ee7..0000000 --- a/gcc/ada/s-direio.ads +++ /dev/null @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I R E C T _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the declaration of the control block used for --- Direct_IO. This must be declared at the outer library level. It also --- contains code that is shared between instances of Direct_IO. - -with Interfaces.C_Streams; -with Ada.Streams; -with System.File_Control_Block; -with System.Storage_Elements; - -package System.Direct_IO is - - package FCB renames System.File_Control_Block; - - type Operation is (Op_Read, Op_Write, Op_Other); - -- Type used to record last operation (to optimize sequential operations) - - subtype Count is Interfaces.C_Streams.int64; - -- The Count type in each instantiation is derived from this type - - subtype Positive_Count is Count range 1 .. Count'Last; - - type Direct_AFCB is new FCB.AFCB with record - Index : Count := 1; - -- Current Index value - - Bytes : Interfaces.C_Streams.size_t; - -- Length of item in bytes (set from inside generic template) - - Last_Op : Operation := Op_Other; - -- Last operation performed on file, used to avoid unnecessary - -- repositioning between successive read or write operations. - end record; - - function AFCB_Allocate (Control_Block : Direct_AFCB) return FCB.AFCB_Ptr; - - procedure AFCB_Close (File : not null access Direct_AFCB); - procedure AFCB_Free (File : not null access Direct_AFCB); - - procedure Read - (File : in out Direct_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Required overriding of Read, not actually used for Direct_IO - - procedure Write - (File : in out Direct_AFCB; - Item : Ada.Streams.Stream_Element_Array); - -- Required overriding of Write, not actually used for Direct_IO - - type File_Type is access all Direct_AFCB; - -- File_Type in individual instantiations is derived from this type - - procedure Create - (File : in out File_Type; - Mode : FCB.File_Mode := FCB.Inout_File; - Name : String := ""; - Form : String := ""); - - function End_Of_File (File : File_Type) return Boolean; - - function Index (File : File_Type) return Positive_Count; - - procedure Open - (File : in out File_Type; - Mode : FCB.File_Mode; - Name : String; - Form : String := ""); - - procedure Read - (File : File_Type; - Item : System.Address; - Size : Interfaces.C_Streams.size_t; - From : Positive_Count); - - procedure Read - (File : File_Type; - Item : System.Address; - Size : Interfaces.C_Streams.size_t); - - procedure Reset (File : in out File_Type; Mode : FCB.File_Mode); - procedure Reset (File : in out File_Type); - - procedure Set_Index (File : File_Type; To : Positive_Count); - - function Size (File : File_Type) return Count; - - procedure Write - (File : File_Type; - Item : System.Address; - Size : Interfaces.C_Streams.size_t; - Zeroes : System.Storage_Elements.Storage_Array); - -- Note: Zeroes is the buffer of zeroes used to fill out partial records - - -- The following procedures have a File_Type formal of mode IN OUT because - -- they may close the original file. The Close operation may raise an - -- exception, but in that case we want any assignment to the formal to - -- be effective anyway, so it must be passed by reference (or the caller - -- will be left with a dangling pointer). - - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type), - Mechanism => Reference); - pragma Export_Procedure - (Internal => Reset, - External => "", - Parameter_Types => (File_Type, FCB.File_Mode), - Mechanism => (File => Reference)); - -end System.Direct_IO; diff --git a/gcc/ada/s-dmotpr.ads b/gcc/ada/s-dmotpr.ads deleted file mode 100644 index 902341c..0000000 --- a/gcc/ada/s-dmotpr.ads +++ /dev/null @@ -1,172 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D I M . M K S . O T H E R _ P R E F I X E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Package that defines some other prefixes for the MKS base unit system. - --- These prefixes have been defined in a child package in order to avoid too --- many constant declarations in System.Dim_Mks. - -package System.Dim.Mks.Other_Prefixes is - - -- SI prefixes for Meter - - pragma Warnings (Off); - -- Turn off the all the dimension warnings - - ym : constant Length := 1.0E-24; -- yocto - zm : constant Length := 1.0E-21; -- zepto - am : constant Length := 1.0E-18; -- atto - fm : constant Length := 1.0E-15; -- femto - pm : constant Length := 1.0E-12; -- pico - nm : constant Length := 1.0E-09; -- nano - Gm : constant Length := 1.0E+09; -- giga - Tm : constant Length := 1.0E+12; -- tera - Pem : constant Length := 1.0E+15; -- peta - Em : constant Length := 1.0E+18; -- exa - Zem : constant Length := 1.0E+21; -- zetta - Yom : constant Length := 1.0E+24; -- yotta - - -- SI prefixes for Kilogram - - yg : constant Mass := 1.0E-27; -- yocto - zg : constant Mass := 1.0E-24; -- zepto - ag : constant Mass := 1.0E-21; -- atto - fg : constant Mass := 1.0E-18; -- femto - pg : constant Mass := 1.0E-15; -- pico - ng : constant Mass := 1.0E-12; -- nano - Gg : constant Mass := 1.0E+06; -- giga - Tg : constant Mass := 1.0E+09; -- tera - Peg : constant Mass := 1.0E+13; -- peta - Eg : constant Mass := 1.0E+15; -- exa - Zeg : constant Mass := 1.0E+18; -- zetta - Yog : constant Mass := 1.0E+21; -- yotta - - -- SI prefixes for Second - - ys : constant Time := 1.0E-24; -- yocto - zs : constant Time := 1.0E-21; -- zepto - as : constant Time := 1.0E-18; -- atto - fs : constant Time := 1.0E-15; -- femto - ps : constant Time := 1.0E-12; -- pico - ns : constant Time := 1.0E-09; -- nano - Gs : constant Time := 1.0E+09; -- giga - Ts : constant Time := 1.0E+12; -- tera - Pes : constant Time := 1.0E+15; -- peta - Es : constant Time := 1.0E+18; -- exa - Zes : constant Time := 1.0E+21; -- zetta - Yos : constant Time := 1.0E+24; -- yotta - - -- SI prefixes for Ampere - - yA : constant Electric_Current := 1.0E-24; -- yocto - zA : constant Electric_Current := 1.0E-21; -- zepto - aA : constant Electric_Current := 1.0E-18; -- atto - fA : constant Electric_Current := 1.0E-15; -- femto - nA : constant Electric_Current := 1.0E-09; -- nano - uA : constant Electric_Current := 1.0E-06; -- micro (u) - GA : constant Electric_Current := 1.0E+09; -- giga - TA : constant Electric_Current := 1.0E+12; -- tera - PeA : constant Electric_Current := 1.0E+15; -- peta - EA : constant Electric_Current := 1.0E+18; -- exa - ZeA : constant Electric_Current := 1.0E+21; -- zetta - YoA : constant Electric_Current := 1.0E+24; -- yotta - - -- SI prefixes for Kelvin - - yK : constant Thermodynamic_Temperature := 1.0E-24; -- yocto - zK : constant Thermodynamic_Temperature := 1.0E-21; -- zepto - aK : constant Thermodynamic_Temperature := 1.0E-18; -- atto - fK : constant Thermodynamic_Temperature := 1.0E-15; -- femto - pK : constant Thermodynamic_Temperature := 1.0E-12; -- pico - nK : constant Thermodynamic_Temperature := 1.0E-09; -- nano - uK : constant Thermodynamic_Temperature := 1.0E-06; -- micro (u) - mK : constant Thermodynamic_Temperature := 1.0E-03; -- milli - cK : constant Thermodynamic_Temperature := 1.0E-02; -- centi - dK : constant Thermodynamic_Temperature := 1.0E-01; -- deci - daK : constant Thermodynamic_Temperature := 1.0E+01; -- deka - hK : constant Thermodynamic_Temperature := 1.0E+02; -- hecto - kK : constant Thermodynamic_Temperature := 1.0E+03; -- kilo - MeK : constant Thermodynamic_Temperature := 1.0E+06; -- mega - GK : constant Thermodynamic_Temperature := 1.0E+09; -- giga - TK : constant Thermodynamic_Temperature := 1.0E+12; -- tera - PeK : constant Thermodynamic_Temperature := 1.0E+15; -- peta - EK : constant Thermodynamic_Temperature := 1.0E+18; -- exa - ZeK : constant Thermodynamic_Temperature := 1.0E+21; -- zetta - YoK : constant Thermodynamic_Temperature := 1.0E+24; -- yotta - - -- SI prefixes for Mole - - ymol : constant Amount_Of_Substance := 1.0E-24; -- yocto - zmol : constant Amount_Of_Substance := 1.0E-21; -- zepto - amol : constant Amount_Of_Substance := 1.0E-18; -- atto - fmol : constant Amount_Of_Substance := 1.0E-15; -- femto - pmol : constant Amount_Of_Substance := 1.0E-12; -- pico - nmol : constant Amount_Of_Substance := 1.0E-09; -- nano - umol : constant Amount_Of_Substance := 1.0E-06; -- micro (u) - mmol : constant Amount_Of_Substance := 1.0E-03; -- milli - cmol : constant Amount_Of_Substance := 1.0E-02; -- centi - dmol : constant Amount_Of_Substance := 1.0E-01; -- deci - damol : constant Amount_Of_Substance := 1.0E+01; -- deka - hmol : constant Amount_Of_Substance := 1.0E+02; -- hecto - kmol : constant Amount_Of_Substance := 1.0E+03; -- kilo - Memol : constant Amount_Of_Substance := 1.0E+06; -- mega - Gmol : constant Amount_Of_Substance := 1.0E+09; -- giga - Tmol : constant Amount_Of_Substance := 1.0E+12; -- tera - Pemol : constant Amount_Of_Substance := 1.0E+15; -- peta - Emol : constant Amount_Of_Substance := 1.0E+18; -- exa - Zemol : constant Amount_Of_Substance := 1.0E+21; -- zetta - Yomol : constant Amount_Of_Substance := 1.0E+24; -- yotta - - -- SI prefixes for Candela - - ycd : constant Luminous_Intensity := 1.0E-24; -- yocto - zcd : constant Luminous_Intensity := 1.0E-21; -- zepto - acd : constant Luminous_Intensity := 1.0E-18; -- atto - fcd : constant Luminous_Intensity := 1.0E-15; -- femto - pcd : constant Luminous_Intensity := 1.0E-12; -- pico - ncd : constant Luminous_Intensity := 1.0E-09; -- nano - ucd : constant Luminous_Intensity := 1.0E-06; -- micro (u) - mcd : constant Luminous_Intensity := 1.0E-03; -- milli - ccd : constant Luminous_Intensity := 1.0E-02; -- centi - dcd : constant Luminous_Intensity := 1.0E-01; -- deci - dacd : constant Luminous_Intensity := 1.0E+01; -- deka - hcd : constant Luminous_Intensity := 1.0E+02; -- hecto - kcd : constant Luminous_Intensity := 1.0E+03; -- kilo - Mecd : constant Luminous_Intensity := 1.0E+06; -- mega - Gcd : constant Luminous_Intensity := 1.0E+09; -- giga - Tcd : constant Luminous_Intensity := 1.0E+12; -- tera - Pecd : constant Luminous_Intensity := 1.0E+15; -- peta - Ecd : constant Luminous_Intensity := 1.0E+18; -- exa - Zecd : constant Luminous_Intensity := 1.0E+21; -- zetta - Yocd : constant Luminous_Intensity := 1.0E+24; -- yotta - - pragma Warnings (On); -end System.Dim.Mks.Other_Prefixes; diff --git a/gcc/ada/s-dsaser.ads b/gcc/ada/s-dsaser.ads deleted file mode 100644 index c87e384..0000000 --- a/gcc/ada/s-dsaser.ads +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . D S A _ S E R V I C E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is for distributed system annex services, which require the --- partition communication sub-system to be initialized before they are used. - -with System.Partition_Interface; -with System.RPC; - -package System.DSA_Services is - - function Get_Active_Partition_ID - (Name : Partition_Interface.Unit_Name) return RPC.Partition_ID - renames Partition_Interface.Get_Active_Partition_ID; - -- Return the partition ID of the partition in which unit Name resides - - function Get_Local_Partition_ID return RPC.Partition_ID - renames Partition_Interface.Get_Local_Partition_ID; - -- Return the Partition_ID of the current partition - - function Get_Passive_Partition_ID - (Name : Partition_Interface.Unit_Name) return RPC.Partition_ID - renames Partition_Interface.Get_Passive_Partition_ID; - -- Return the Partition_ID of the given shared passive partition - -end System.DSA_Services; diff --git a/gcc/ada/s-dwalin.adb b/gcc/ada/s-dwalin.adb deleted file mode 100644 index 1791b2d..0000000 --- a/gcc/ada/s-dwalin.adb +++ /dev/null @@ -1,1627 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . D W A R F _ L I N E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on - -with Ada.Characters.Handling; -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with Ada.Unchecked_Deallocation; -with Ada.Containers.Generic_Array_Sort; - -with Interfaces; use Interfaces; - -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; -with System.Address_Image; -with System.IO; use System.IO; -with System.Object_Reader; use System.Object_Reader; -with System.Traceback_Entries; use System.Traceback_Entries; -with System.Mmap; use System.Mmap; -with System.Bounded_Strings; use System.Bounded_Strings; - -package body System.Dwarf_Lines is - - SSU : constant := System.Storage_Unit; - - function String_Length (Str : Str_Access) return Natural; - -- Return the length of the C string Str - - --------------------------------- - -- DWARF Parser Implementation -- - --------------------------------- - - procedure Read_Initial_Length - (S : in out Mapped_Stream; - Len : out Offset; - Is64 : out Boolean); - -- Read initial length as specified by Dwarf-4 7.2.2 - - procedure Read_Section_Offset - (S : in out Mapped_Stream; - Len : out Offset; - Is64 : Boolean); - -- Read a section offset, as specified by Dwarf-4 7.4 - - procedure Read_Aranges_Entry - (C : in out Dwarf_Context; - Start : out Integer_Address; - Len : out Storage_Count); - -- Read a single .debug_aranges pair - - procedure Read_Aranges_Header - (C : in out Dwarf_Context; - Info_Offset : out Offset; - Success : out Boolean); - -- Read .debug_aranges header - - procedure Aranges_Lookup - (C : in out Dwarf_Context; - Addr : Address; - Info_Offset : out Offset; - Success : out Boolean); - -- Search for Addr in .debug_aranges and return offset Info_Offset in - -- .debug_info. - - procedure Skip_Form - (S : in out Mapped_Stream; - Form : uint32; - Is64 : Boolean; - Ptr_Sz : uint8); - -- Advance offset in S for Form. - - procedure Seek_Abbrev - (C : in out Dwarf_Context; - Abbrev_Offset : Offset; - Abbrev_Num : uint32); - -- Seek to abbrev Abbrev_Num (starting from Abbrev_Offset) - - procedure Debug_Info_Lookup - (C : in out Dwarf_Context; - Info_Offset : Offset; - Line_Offset : out Offset; - Success : out Boolean); - -- Search for stmt_list tag in Info_Offset and set Line_Offset to the - -- offset in .debug_lines. Only look at the first DIE, which should be - -- a compilation unit. - - procedure Initialize_Pass (C : in out Dwarf_Context); - -- Seek to the first byte of the first prologue and prepare to make a pass - -- over the line number entries. - - procedure Initialize_State_Machine (C : in out Dwarf_Context); - -- Set all state machine registers to their specified initial values - - procedure Parse_Prologue (C : in out Dwarf_Context); - -- Decode a DWARF statement program prologue - - procedure Read_And_Execute_Isn - (C : in out Dwarf_Context; - Done : out Boolean); - -- Read an execute a statement program instruction - - function To_File_Name - (C : in out Dwarf_Context; - Code : uint32) return String; - -- Extract a file name from the prologue - - type Callback is access procedure (C : in out Dwarf_Context); - procedure For_Each_Row (C : in out Dwarf_Context; F : Callback); - -- Traverse each .debug_line entry with a callback - - procedure Dump_Row (C : in out Dwarf_Context); - -- Dump a single row - - function "<" (Left, Right : Search_Entry) return Boolean; - -- For sorting Search_Entry - - procedure Sort_Search_Array is new Ada.Containers.Generic_Array_Sort - (Index_Type => Natural, - Element_Type => Search_Entry, - Array_Type => Search_Array); - - procedure Symbolic_Address - (C : in out Dwarf_Context; - Addr : Address; - Dir_Name : out Str_Access; - File_Name : out Str_Access; - Subprg_Name : out String_Ptr_Len; - Line_Num : out Natural); - -- Symbolize one address - - ----------------------- - -- DWARF constants -- - ----------------------- - - -- 6.2.5.2 Standard Opcodes - - DW_LNS_copy : constant := 1; - DW_LNS_advance_pc : constant := 2; - DW_LNS_advance_line : constant := 3; - DW_LNS_set_file : constant := 4; - DW_LNS_set_column : constant := 5; - DW_LNS_negate_stmt : constant := 6; - DW_LNS_set_basic_block : constant := 7; - DW_LNS_const_add_pc : constant := 8; - DW_LNS_fixed_advance_pc : constant := 9; - DW_LNS_set_prologue_end : constant := 10; - DW_LNS_set_epilogue_begin : constant := 11; - DW_LNS_set_isa : constant := 12; - - -- 6.2.5.3 Extended Opcodes - - DW_LNE_end_sequence : constant := 1; - DW_LNE_set_address : constant := 2; - DW_LNE_define_file : constant := 3; - - -- From the DWARF version 4 public review draft - - DW_LNE_set_discriminator : constant := 4; - - -- Attribute encodings - - DW_TAG_Compile_Unit : constant := 16#11#; - - DW_AT_Stmt_List : constant := 16#10#; - - DW_FORM_addr : constant := 16#01#; - DW_FORM_block2 : constant := 16#03#; - DW_FORM_block4 : constant := 16#04#; - DW_FORM_data2 : constant := 16#05#; - DW_FORM_data4 : constant := 16#06#; - DW_FORM_data8 : constant := 16#07#; - DW_FORM_string : constant := 16#08#; - DW_FORM_block : constant := 16#09#; - DW_FORM_block1 : constant := 16#0a#; - DW_FORM_data1 : constant := 16#0b#; - DW_FORM_flag : constant := 16#0c#; - DW_FORM_sdata : constant := 16#0d#; - DW_FORM_strp : constant := 16#0e#; - DW_FORM_udata : constant := 16#0f#; - DW_FORM_ref_addr : constant := 16#10#; - DW_FORM_ref1 : constant := 16#11#; - DW_FORM_ref2 : constant := 16#12#; - DW_FORM_ref4 : constant := 16#13#; - DW_FORM_ref8 : constant := 16#14#; - DW_FORM_ref_udata : constant := 16#15#; - DW_FORM_indirect : constant := 16#16#; - DW_FORM_sec_offset : constant := 16#17#; - DW_FORM_exprloc : constant := 16#18#; - DW_FORM_flag_present : constant := 16#19#; - DW_FORM_ref_sig8 : constant := 16#20#; - - --------- - -- "<" -- - --------- - - function "<" (Left, Right : Search_Entry) return Boolean is - begin - return Left.First < Right.First; - end "<"; - - ----------- - -- Close -- - ----------- - - procedure Close (C : in out Dwarf_Context) is - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Object_File, - Object_File_Access); - procedure Unchecked_Deallocation is new Ada.Unchecked_Deallocation - (Search_Array, - Search_Array_Access); - begin - if C.Has_Debug then - Close (C.Lines); - Close (C.Abbrev); - Close (C.Info); - Close (C.Aranges); - end if; - - Close (C.Obj.all); - Unchecked_Deallocation (C.Obj); - - Unchecked_Deallocation (C.Cache); - end Close; - - ---------- - -- Dump -- - ---------- - - procedure Dump (C : in out Dwarf_Context) is - begin - For_Each_Row (C, Dump_Row'Access); - end Dump; - - -------------- - -- Dump_Row -- - -------------- - - procedure Dump_Row (C : in out Dwarf_Context) is - PC : constant Integer_Address := Integer_Address (C.Registers.Address); - Off : Offset; - begin - Tell (C.Lines, Off); - - Put (System.Address_Image (To_Address (PC))); - Put (" "); - Put (To_File_Name (C, C.Registers.File)); - Put (":"); - - declare - Image : constant String := uint32'Image (C.Registers.Line); - begin - Put_Line (Image (2 .. Image'Last)); - end; - - Seek (C.Lines, Off); - end Dump_Row; - - procedure Dump_Cache (C : Dwarf_Context) is - Cache : constant Search_Array_Access := C.Cache; - S : Object_Symbol; - Name : String_Ptr_Len; - begin - if Cache = null then - Put_Line ("No cache"); - return; - end if; - for I in Cache'Range loop - Put (System.Address_Image (C.Low + Storage_Count (Cache (I).First))); - Put (" - "); - Put - (System.Address_Image - (C.Low + Storage_Count (Cache (I).First + Cache (I).Size))); - Put (" l@"); - Put - (System.Address_Image - (To_Address (Integer_Address (Cache (I).Line)))); - Put (": "); - S := Read_Symbol (C.Obj.all, Offset (Cache (I).Sym)); - Name := Object_Reader.Name (C.Obj.all, S); - Put (String (Name.Ptr (1 .. Name.Len))); - New_Line; - end loop; - end Dump_Cache; - - ------------------ - -- For_Each_Row -- - ------------------ - - procedure For_Each_Row (C : in out Dwarf_Context; F : Callback) is - Done : Boolean; - - begin - Initialize_Pass (C); - - loop - Read_And_Execute_Isn (C, Done); - - if C.Registers.Is_Row then - F.all (C); - end if; - - exit when Done; - end loop; - end For_Each_Row; - - --------------------- - -- Initialize_Pass -- - --------------------- - - procedure Initialize_Pass (C : in out Dwarf_Context) is - begin - Seek (C.Lines, 0); - C.Next_Prologue := 0; - - Initialize_State_Machine (C); - end Initialize_Pass; - - ------------------------------ - -- Initialize_State_Machine -- - ------------------------------ - - procedure Initialize_State_Machine (C : in out Dwarf_Context) is - begin - C.Registers := - (Address => 0, - File => 1, - Line => 1, - Column => 0, - Is_Stmt => C.Prologue.Default_Is_Stmt = 0, - Basic_Block => False, - End_Sequence => False, - Prologue_End => False, - Epilogue_Begin => False, - ISA => 0, - Is_Row => False); - end Initialize_State_Machine; - - --------------- - -- Is_Inside -- - --------------- - - function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean is - begin - return Addr >= C.Low and Addr <= C.High; - end Is_Inside; - - --------- - -- Low -- - --------- - - function Low (C : Dwarf_Context) return Address is - begin - return C.Low; - end Low; - - ---------- - -- Open -- - ---------- - - procedure Open - (File_Name : String; - C : out Dwarf_Context; - Success : out Boolean) - is - Line_Sec, Info_Sec, Abbrev_Sec, Aranges_Sec : Object_Section; - Hi, Lo : uint64; - begin - -- Not a success by default - - Success := False; - - -- Open file - - C.Obj := Open (File_Name, C.In_Exception); - - if C.Obj = null then - return; - end if; - - Success := True; - - -- Get memory bounds - - Get_Memory_Bounds (C.Obj.all, Lo, Hi); - C.Low := Address (Lo); - C.High := Address (Hi); - - -- Create a stream for debug sections - - if Format (C.Obj.all) = XCOFF32 then - Line_Sec := Get_Section (C.Obj.all, ".dwline"); - Abbrev_Sec := Get_Section (C.Obj.all, ".dwabrev"); - Info_Sec := Get_Section (C.Obj.all, ".dwinfo"); - Aranges_Sec := Get_Section (C.Obj.all, ".dwarnge"); - else - Line_Sec := Get_Section (C.Obj.all, ".debug_line"); - Abbrev_Sec := Get_Section (C.Obj.all, ".debug_abbrev"); - Info_Sec := Get_Section (C.Obj.all, ".debug_info"); - Aranges_Sec := Get_Section (C.Obj.all, ".debug_aranges"); - end if; - - if Line_Sec = Null_Section - or else Abbrev_Sec = Null_Section - or else Info_Sec = Null_Section - or else Aranges_Sec = Null_Section - then - C.Has_Debug := False; - return; - end if; - - C.Lines := Create_Stream (C.Obj.all, Line_Sec); - C.Abbrev := Create_Stream (C.Obj.all, Abbrev_Sec); - C.Info := Create_Stream (C.Obj.all, Info_Sec); - C.Aranges := Create_Stream (C.Obj.all, Aranges_Sec); - - -- All operations are successful, context is valid - - C.Has_Debug := True; - end Open; - - -------------------- - -- Parse_Prologue -- - -------------------- - - procedure Parse_Prologue (C : in out Dwarf_Context) is - Char : uint8; - Prev : uint8; - -- The most recently read character and the one preceding it - - Dummy : uint32; - -- Destination for reads we don't care about - - Buf : Buffer; - Off : Offset; - - First_Byte_Of_Prologue : Offset; - Last_Byte_Of_Prologue : Offset; - - Max_Op_Per_Insn : uint8; - pragma Unreferenced (Max_Op_Per_Insn); - - Prologue : Line_Info_Prologue renames C.Prologue; - - begin - Tell (C.Lines, First_Byte_Of_Prologue); - Prologue.Unit_Length := Read (C.Lines); - Tell (C.Lines, Off); - C.Next_Prologue := Off + Offset (Prologue.Unit_Length); - - Prologue.Version := Read (C.Lines); - Prologue.Prologue_Length := Read (C.Lines); - Tell (C.Lines, Last_Byte_Of_Prologue); - Last_Byte_Of_Prologue := - Last_Byte_Of_Prologue + Offset (Prologue.Prologue_Length) - 1; - - Prologue.Min_Isn_Length := Read (C.Lines); - - if Prologue.Version >= 4 then - Max_Op_Per_Insn := Read (C.Lines); - end if; - - Prologue.Default_Is_Stmt := Read (C.Lines); - Prologue.Line_Base := Read (C.Lines); - Prologue.Line_Range := Read (C.Lines); - Prologue.Opcode_Base := Read (C.Lines); - - -- Opcode_Lengths is an array of Opcode_Base bytes specifying the number - -- of LEB128 operands for each of the standard opcodes. - - for J in 1 .. uint32 (Prologue.Opcode_Base - 1) loop - Prologue.Opcode_Lengths (J) := Read (C.Lines); - end loop; - - -- The include directories table follows. This is a list of null - -- terminated strings terminated by a double null. We only store - -- its offset for later decoding. - - Tell (C.Lines, Prologue.Includes_Offset); - Char := Read (C.Lines); - - if Char /= 0 then - loop - Prev := Char; - Char := Read (C.Lines); - exit when Char = 0 and Prev = 0; - end loop; - end if; - - -- The file_names table is next. Each record is a null terminated string - -- for the file name, an unsigned LEB128 directory index, an unsigned - -- LEB128 modification time, and an LEB128 file length. The table is - -- terminated by a null byte. - - Tell (C.Lines, Prologue.File_Names_Offset); - - loop - -- Read the filename - - Read_C_String (C.Lines, Buf); - exit when Buf (0) = 0; - Dummy := Read_LEB128 (C.Lines); -- Skip the directory index. - Dummy := Read_LEB128 (C.Lines); -- Skip the modification time. - Dummy := Read_LEB128 (C.Lines); -- Skip the file length. - end loop; - - -- Check we're where we think we are. This sanity check ensures we think - -- the prologue ends where the prologue says it does. It we aren't then - -- we've probably gotten out of sync somewhere. - - Tell (C.Lines, Off); - - if Prologue.Unit_Length /= 0 - and then Off /= Last_Byte_Of_Prologue + 1 - then - raise Dwarf_Error with "Parse error reading DWARF information"; - end if; - end Parse_Prologue; - - -------------------------- - -- Read_And_Execute_Isn -- - -------------------------- - - procedure Read_And_Execute_Isn - (C : in out Dwarf_Context; - Done : out Boolean) - is - Opcode : uint8; - Extended_Opcode : uint8; - uint32_Operand : uint32; - int32_Operand : int32; - uint16_Operand : uint16; - Off : Offset; - - Extended_Length : uint32; - pragma Unreferenced (Extended_Length); - - Obj : Object_File renames C.Obj.all; - Registers : Line_Info_Registers renames C.Registers; - Prologue : Line_Info_Prologue renames C.Prologue; - - begin - Done := False; - Registers.Is_Row := False; - - if Registers.End_Sequence then - Initialize_State_Machine (C); - end if; - - -- Read the next prologue - - Tell (C.Lines, Off); - while Off = C.Next_Prologue loop - Initialize_State_Machine (C); - Parse_Prologue (C); - Tell (C.Lines, Off); - exit when Off + 4 >= Length (C.Lines); - end loop; - - -- Test whether we're done - - Tell (C.Lines, Off); - - -- We are finished when we either reach the end of the section, or we - -- have reached zero padding at the end of the section. - - if Prologue.Unit_Length = 0 or else Off + 4 >= Length (C.Lines) then - Done := True; - return; - end if; - - -- Read and interpret an instruction - - Opcode := Read (C.Lines); - - -- Extended opcodes - - if Opcode = 0 then - Extended_Length := Read_LEB128 (C.Lines); - Extended_Opcode := Read (C.Lines); - - case Extended_Opcode is - when DW_LNE_end_sequence => - - -- Mark the end of a sequence of source locations - - Registers.End_Sequence := True; - Registers.Is_Row := True; - - when DW_LNE_set_address => - - -- Set the program counter to a word - - Registers.Address := Read_Address (Obj, C.Lines); - - when DW_LNE_define_file => - - -- Not implemented - - raise Dwarf_Error with "DWARF operator not implemented"; - - when DW_LNE_set_discriminator => - - -- Ignored - - int32_Operand := Read_LEB128 (C.Lines); - - when others => - - -- Fail on an unrecognized opcode - - raise Dwarf_Error with "DWARF operator not implemented"; - end case; - - -- Standard opcodes - - elsif Opcode < Prologue.Opcode_Base then - case Opcode is - - -- Append a row to the line info matrix - - when DW_LNS_copy => - Registers.Basic_Block := False; - Registers.Is_Row := True; - - -- Add an unsigned word to the program counter - - when DW_LNS_advance_pc => - uint32_Operand := Read_LEB128 (C.Lines); - Registers.Address := - Registers.Address + - uint64 (uint32_Operand * uint32 (Prologue.Min_Isn_Length)); - - -- Add a signed word to the current source line - - when DW_LNS_advance_line => - int32_Operand := Read_LEB128 (C.Lines); - Registers.Line := - uint32 (int32 (Registers.Line) + int32_Operand); - - -- Set the current source file - - when DW_LNS_set_file => - uint32_Operand := Read_LEB128 (C.Lines); - Registers.File := uint32_Operand; - - -- Set the current source column - - when DW_LNS_set_column => - uint32_Operand := Read_LEB128 (C.Lines); - Registers.Column := uint32_Operand; - - -- Toggle the "is statement" flag. GCC doesn't seem to set this??? - - when DW_LNS_negate_stmt => - Registers.Is_Stmt := not Registers.Is_Stmt; - - -- Mark the beginning of a basic block - - when DW_LNS_set_basic_block => - Registers.Basic_Block := True; - - -- Advance the program counter as by the special opcode 255 - - when DW_LNS_const_add_pc => - Registers.Address := - Registers.Address + - uint64 - (((255 - Prologue.Opcode_Base) / Prologue.Line_Range) * - Prologue.Min_Isn_Length); - - -- Advance the program counter by a constant - - when DW_LNS_fixed_advance_pc => - uint16_Operand := Read (C.Lines); - Registers.Address := - Registers.Address + uint64 (uint16_Operand); - - -- The following are not implemented and ignored - - when DW_LNS_set_prologue_end => - null; - - when DW_LNS_set_epilogue_begin => - null; - - when DW_LNS_set_isa => - null; - - -- Anything else is an error - - when others => - raise Dwarf_Error with "DWARF operator not implemented"; - end case; - - -- Decode a special opcode. This is a line and address increment encoded - -- in a single byte 'special opcode' as described in 6.2.5.1. - - else - declare - Address_Increment : int32; - Line_Increment : int32; - - begin - Opcode := Opcode - Prologue.Opcode_Base; - - -- The adjusted opcode is a uint8 encoding an address increment - -- and a signed line increment. The upperbound is allowed to be - -- greater than int8'last so we decode using int32 directly to - -- prevent overflows. - - Address_Increment := - int32 (Opcode / Prologue.Line_Range) * - int32 (Prologue.Min_Isn_Length); - Line_Increment := - int32 (Prologue.Line_Base) + - int32 (Opcode mod Prologue.Line_Range); - - Registers.Address := - Registers.Address + uint64 (Address_Increment); - Registers.Line := uint32 (int32 (Registers.Line) + Line_Increment); - Registers.Basic_Block := False; - Registers.Prologue_End := False; - Registers.Epilogue_Begin := False; - Registers.Is_Row := True; - end; - end if; - - exception - when Dwarf_Error => - - -- In case of errors during parse, just stop reading - - Registers.Is_Row := False; - Done := True; - end Read_And_Execute_Isn; - - ---------------------- - -- Set_Load_Address -- - ---------------------- - - procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address) is - begin - if Addr = Null_Address then - return; - else - C.Load_Slide := - To_Integer (Addr) - Integer_Address (Get_Load_Address (C.Obj.all)); - - C.Low := To_Address (To_Integer (C.Low) + C.Load_Slide); - C.High := To_Address (To_Integer (C.High) + C.Load_Slide); - end if; - end Set_Load_Address; - - ------------------ - -- To_File_Name -- - ------------------ - - function To_File_Name - (C : in out Dwarf_Context; - Code : uint32) return String - is - Buf : Buffer; - J : uint32; - - Dir_Idx : uint32; - pragma Unreferenced (Dir_Idx); - - Mod_Time : uint32; - pragma Unreferenced (Mod_Time); - - Length : uint32; - pragma Unreferenced (Length); - - begin - Seek (C.Lines, C.Prologue.File_Names_Offset); - - -- Find the entry - - J := 0; - loop - J := J + 1; - Read_C_String (C.Lines, Buf); - - if Buf (Buf'First) = 0 then - return "???"; - end if; - - Dir_Idx := Read_LEB128 (C.Lines); - Mod_Time := Read_LEB128 (C.Lines); - Length := Read_LEB128 (C.Lines); - exit when J = Code; - end loop; - - return To_String (Buf); - end To_File_Name; - - ------------------------- - -- Read_Initial_Length -- - ------------------------- - - procedure Read_Initial_Length - (S : in out Mapped_Stream; - Len : out Offset; - Is64 : out Boolean) - is - Len32 : uint32; - Len64 : uint64; - begin - Len32 := Read (S); - if Len32 < 16#ffff_fff0# then - Is64 := False; - Len := Offset (Len32); - elsif Len32 < 16#ffff_ffff# then - -- Invalid length - raise Constraint_Error; - else - Is64 := True; - Len64 := Read (S); - Len := Offset (Len64); - end if; - end Read_Initial_Length; - - ------------------------- - -- Read_Section_Offset -- - ------------------------- - - procedure Read_Section_Offset - (S : in out Mapped_Stream; - Len : out Offset; - Is64 : Boolean) - is - begin - if Is64 then - Len := Offset (uint64'(Read (S))); - else - Len := Offset (uint32'(Read (S))); - end if; - end Read_Section_Offset; - - -------------------- - -- Aranges_Lookup -- - -------------------- - - procedure Aranges_Lookup - (C : in out Dwarf_Context; - Addr : Address; - Info_Offset : out Offset; - Success : out Boolean) - is - begin - Seek (C.Aranges, 0); - - while Tell (C.Aranges) < Length (C.Aranges) loop - Read_Aranges_Header (C, Info_Offset, Success); - exit when not Success; - - loop - declare - Start : Integer_Address; - Len : Storage_Count; - begin - Read_Aranges_Entry (C, Start, Len); - exit when Start = 0 and Len = 0; - if Addr >= To_Address (Start) - and then Addr < To_Address (Start) + Len - then - Success := True; - return; - end if; - end; - end loop; - end loop; - Success := False; - end Aranges_Lookup; - - --------------- - -- Skip_Form -- - --------------- - - procedure Skip_Form - (S : in out Mapped_Stream; - Form : uint32; - Is64 : Boolean; - Ptr_Sz : uint8) - is - Skip : Offset; - begin - case Form is - when DW_FORM_addr => - Skip := Offset (Ptr_Sz); - when DW_FORM_block2 => - Skip := Offset (uint16'(Read (S))); - when DW_FORM_block4 => - Skip := Offset (uint32'(Read (S))); - when DW_FORM_data2 | DW_FORM_ref2 => - Skip := 2; - when DW_FORM_data4 | DW_FORM_ref4 => - Skip := 4; - when DW_FORM_data8 | DW_FORM_ref8 | DW_FORM_ref_sig8 => - Skip := 8; - when DW_FORM_string => - while uint8'(Read (S)) /= 0 loop - null; - end loop; - return; - when DW_FORM_block | DW_FORM_exprloc => - Skip := Offset (uint32'(Read_LEB128 (S))); - when DW_FORM_block1 | DW_FORM_ref1 => - Skip := Offset (uint8'(Read (S))); - when DW_FORM_data1 | DW_FORM_flag => - Skip := 1; - when DW_FORM_sdata => - declare - Val : constant int32 := Read_LEB128 (S); - pragma Unreferenced (Val); - begin - return; - end; - when DW_FORM_strp | DW_FORM_ref_addr | DW_FORM_sec_offset => - Skip := (if Is64 then 8 else 4); - when DW_FORM_udata | DW_FORM_ref_udata => - declare - Val : constant uint32 := Read_LEB128 (S); - pragma Unreferenced (Val); - begin - return; - end; - when DW_FORM_flag_present => - return; - when DW_FORM_indirect => - raise Constraint_Error; - when others => - raise Constraint_Error; - end case; - Seek (S, Tell (S) + Skip); - end Skip_Form; - - ----------------- - -- Seek_Abbrev -- - ----------------- - - procedure Seek_Abbrev - (C : in out Dwarf_Context; - Abbrev_Offset : Offset; - Abbrev_Num : uint32) - is - Num : uint32; - Abbrev : uint32; - Tag : uint32; - Has_Child : uint8; - pragma Unreferenced (Abbrev, Tag, Has_Child); - begin - Seek (C.Abbrev, Abbrev_Offset); - - Num := 1; - - loop - exit when Num = Abbrev_Num; - - Abbrev := Read_LEB128 (C.Abbrev); - Tag := Read_LEB128 (C.Abbrev); - Has_Child := Read (C.Abbrev); - - loop - declare - Name : constant uint32 := Read_LEB128 (C.Abbrev); - Form : constant uint32 := Read_LEB128 (C.Abbrev); - begin - exit when Name = 0 and Form = 0; - end; - end loop; - - Num := Num + 1; - end loop; - end Seek_Abbrev; - - ----------------------- - -- Debug_Info_Lookup -- - ----------------------- - - procedure Debug_Info_Lookup - (C : in out Dwarf_Context; - Info_Offset : Offset; - Line_Offset : out Offset; - Success : out Boolean) - is - Unit_Length : Offset; - Is64 : Boolean; - Version : uint16; - Abbrev_Offset : Offset; - Addr_Sz : uint8; - Abbrev : uint32; - Has_Child : uint8; - pragma Unreferenced (Has_Child); - begin - Success := False; - - Seek (C.Info, Info_Offset); - - Read_Initial_Length (C.Info, Unit_Length, Is64); - - Version := Read (C.Info); - if Version not in 2 .. 4 then - return; - end if; - - Read_Section_Offset (C.Info, Abbrev_Offset, Is64); - - Addr_Sz := Read (C.Info); - if Addr_Sz /= (Address'Size / SSU) then - return; - end if; - - -- Read DIEs - - loop - Abbrev := Read_LEB128 (C.Info); - exit when Abbrev /= 0; - end loop; - - -- Read abbrev table - - Seek_Abbrev (C, Abbrev_Offset, Abbrev); - - -- First ULEB128 is the abbrev code - - if Read_LEB128 (C.Abbrev) /= Abbrev then - -- Ill formed abbrev table - return; - end if; - - -- Then the tag - - if Read_LEB128 (C.Abbrev) /= uint32'(DW_TAG_Compile_Unit) then - -- Expect compile unit - return; - end if; - - -- Then the has child flag - - Has_Child := Read (C.Abbrev); - - loop - declare - Name : constant uint32 := Read_LEB128 (C.Abbrev); - Form : constant uint32 := Read_LEB128 (C.Abbrev); - begin - exit when Name = 0 and Form = 0; - if Name = DW_AT_Stmt_List then - case Form is - when DW_FORM_sec_offset => - Read_Section_Offset (C.Info, Line_Offset, Is64); - when DW_FORM_data4 => - Line_Offset := Offset (uint32'(Read (C.Info))); - when DW_FORM_data8 => - Line_Offset := Offset (uint64'(Read (C.Info))); - when others => - -- Unhandled form - return; - end case; - - Success := True; - return; - else - Skip_Form (C.Info, Form, Is64, Addr_Sz); - end if; - end; - end loop; - - return; - end Debug_Info_Lookup; - - ------------------------- - -- Read_Aranges_Header -- - ------------------------- - - procedure Read_Aranges_Header - (C : in out Dwarf_Context; - Info_Offset : out Offset; - Success : out Boolean) - is - Unit_Length : Offset; - Is64 : Boolean; - Version : uint16; - Sz : uint8; - begin - Success := False; - - Read_Initial_Length (C.Aranges, Unit_Length, Is64); - - Version := Read (C.Aranges); - if Version /= 2 then - return; - end if; - - Read_Section_Offset (C.Aranges, Info_Offset, Is64); - - -- Read address_size (ubyte) - - Sz := Read (C.Aranges); - if Sz /= (Address'Size / SSU) then - return; - end if; - - -- Read segment_size (ubyte) - - Sz := Read (C.Aranges); - if Sz /= 0 then - return; - end if; - - -- Handle alignment on twice the address size - declare - Cur_Off : constant Offset := Tell (C.Aranges); - Align : constant Offset := 2 * Address'Size / SSU; - Space : constant Offset := Cur_Off mod Align; - begin - if Space /= 0 then - Seek (C.Aranges, Cur_Off + Align - Space); - end if; - end; - - Success := True; - end Read_Aranges_Header; - - ------------------------ - -- Read_Aranges_Entry -- - ------------------------ - - procedure Read_Aranges_Entry - (C : in out Dwarf_Context; - Start : out Integer_Address; - Len : out Storage_Count) - is - begin - -- Read table - if Address'Size = 32 then - declare - S, L : uint32; - begin - S := Read (C.Aranges); - L := Read (C.Aranges); - Start := Integer_Address (S); - Len := Storage_Count (L); - end; - elsif Address'Size = 64 then - declare - S, L : uint64; - begin - S := Read (C.Aranges); - L := Read (C.Aranges); - Start := Integer_Address (S); - Len := Storage_Count (L); - end; - else - raise Constraint_Error; - end if; - end Read_Aranges_Entry; - - ------------------ - -- Enable_Cache -- - ------------------ - - procedure Enable_Cache (C : in out Dwarf_Context) is - Cache : Search_Array_Access; - begin - -- Phase 1: count number of symbols. Phase 2: fill the cache. - declare - S : Object_Symbol; - Sz : uint32; - Addr, Prev_Addr : uint32; - Nbr_Symbols : Natural; - begin - for Phase in 1 .. 2 loop - Nbr_Symbols := 0; - S := First_Symbol (C.Obj.all); - Prev_Addr := uint32'Last; - while S /= Null_Symbol loop - -- Discard symbols whose length is 0 - Sz := uint32 (Size (S)); - - -- Try to filter symbols at the same address. This is a best - -- effort as they might not be consecutive. - Addr := uint32 (Value (S) - uint64 (C.Low)); - if Sz > 0 and then Addr /= Prev_Addr then - Nbr_Symbols := Nbr_Symbols + 1; - Prev_Addr := Addr; - - if Phase = 2 then - C.Cache (Nbr_Symbols) := - (First => Addr, - Size => Sz, - Sym => uint32 (Off (S)), - Line => 0); - end if; - end if; - - S := Next_Symbol (C.Obj.all, S); - end loop; - - if Phase = 1 then - -- Allocate the cache - Cache := new Search_Array (1 .. Nbr_Symbols); - C.Cache := Cache; - end if; - end loop; - pragma Assert (Nbr_Symbols = C.Cache'Last); - end; - - -- Sort the cache. - Sort_Search_Array (C.Cache.all); - - -- Set line offsets - if not C.Has_Debug then - return; - end if; - declare - Info_Offset : Offset; - Line_Offset : Offset; - Success : Boolean; - Ar_Start : Integer_Address; - Ar_Len : Storage_Count; - Start, Len : uint32; - First, Last : Natural; - Mid : Natural; - begin - Seek (C.Aranges, 0); - - while Tell (C.Aranges) < Length (C.Aranges) loop - Read_Aranges_Header (C, Info_Offset, Success); - exit when not Success; - - Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); - exit when not Success; - - -- Read table - loop - Read_Aranges_Entry (C, Ar_Start, Ar_Len); - exit when Ar_Start = 0 and Ar_Len = 0; - - Len := uint32 (Ar_Len); - Start := uint32 (Ar_Start - To_Integer (C.Low)); - - -- Search START in the array - First := Cache'First; - Last := Cache'Last; - Mid := First; -- In case of array with one element - while First < Last loop - Mid := First + (Last - First) / 2; - if Start < Cache (Mid).First then - Last := Mid - 1; - elsif Start >= Cache (Mid).First + Cache (Mid).Size then - First := Mid + 1; - else - exit; - end if; - end loop; - - -- Fill info. - - -- There can be overlapping symbols - while Mid > Cache'First - and then Cache (Mid - 1).First <= Start - and then Cache (Mid - 1).First + Cache (Mid - 1).Size > Start - loop - Mid := Mid - 1; - end loop; - while Mid <= Cache'Last loop - if Start < Cache (Mid).First + Cache (Mid).Size - and then Start + Len > Cache (Mid).First - then - -- MID is within the bounds - Cache (Mid).Line := uint32 (Line_Offset); - elsif Start + Len <= Cache (Mid).First then - -- Over - exit; - end if; - Mid := Mid + 1; - end loop; - end loop; - end loop; - end; - end Enable_Cache; - - ---------------------- - -- Symbolic_Address -- - ---------------------- - - procedure Symbolic_Address - (C : in out Dwarf_Context; - Addr : Address; - Dir_Name : out Str_Access; - File_Name : out Str_Access; - Subprg_Name : out String_Ptr_Len; - Line_Num : out Natural) - is - procedure Set_Result (Match : Line_Info_Registers); - -- Set results using match - - procedure Set_Result (Match : Line_Info_Registers) is - Dir_Idx : uint32; - J : uint32; - - Mod_Time : uint32; - pragma Unreferenced (Mod_Time); - - Length : uint32; - pragma Unreferenced (Length); - - begin - Seek (C.Lines, C.Prologue.File_Names_Offset); - - -- Find the entry - - J := 0; - loop - J := J + 1; - File_Name := Read_C_String (C.Lines); - - if File_Name (File_Name'First) = ASCII.NUL then - -- End of file list, so incorrect entry - return; - end if; - - Dir_Idx := Read_LEB128 (C.Lines); - Mod_Time := Read_LEB128 (C.Lines); - Length := Read_LEB128 (C.Lines); - exit when J = Match.File; - end loop; - - if Dir_Idx = 0 then - -- No directory - Dir_Name := null; - - else - Seek (C.Lines, C.Prologue.Includes_Offset); - - J := 0; - loop - J := J + 1; - Dir_Name := Read_C_String (C.Lines); - - if Dir_Name (Dir_Name'First) = ASCII.NUL then - -- End of directory list, so ill-formed table - return; - end if; - - exit when J = Dir_Idx; - - end loop; - end if; - - Line_Num := Natural (Match.Line); - end Set_Result; - - Addr_Int : constant Integer_Address := To_Integer (Addr); - Previous_Row : Line_Info_Registers; - Info_Offset : Offset; - Line_Offset : Offset; - Success : Boolean; - Done : Boolean; - S : Object_Symbol; - begin - -- Initialize result - Dir_Name := null; - File_Name := null; - Subprg_Name := (null, 0); - Line_Num := 0; - - if C.Cache /= null then - -- Look in the cache - declare - Addr_Off : constant uint32 := uint32 (Addr - C.Low); - First, Last, Mid : Natural; - begin - First := C.Cache'First; - Last := C.Cache'Last; - while First <= Last loop - Mid := First + (Last - First) / 2; - if Addr_Off < C.Cache (Mid).First then - Last := Mid - 1; - elsif Addr_Off >= C.Cache (Mid).First + C.Cache (Mid).Size then - First := Mid + 1; - else - exit; - end if; - end loop; - if Addr_Off >= C.Cache (Mid).First - and then Addr_Off < C.Cache (Mid).First + C.Cache (Mid).Size - then - Line_Offset := Offset (C.Cache (Mid).Line); - S := Read_Symbol (C.Obj.all, Offset (C.Cache (Mid).Sym)); - Subprg_Name := Object_Reader.Name (C.Obj.all, S); - else - -- Not found - return; - end if; - end; - else - -- Search symbol - S := First_Symbol (C.Obj.all); - while S /= Null_Symbol loop - if Spans (S, uint64 (Addr_Int)) then - Subprg_Name := Object_Reader.Name (C.Obj.all, S); - exit; - end if; - - S := Next_Symbol (C.Obj.all, S); - end loop; - - -- Search address in aranges table - - Aranges_Lookup (C, Addr, Info_Offset, Success); - if not Success then - return; - end if; - - -- Search stmt_list in info table - - Debug_Info_Lookup (C, Info_Offset, Line_Offset, Success); - if not Success then - return; - end if; - end if; - - Seek (C.Lines, Line_Offset); - C.Next_Prologue := 0; - Initialize_State_Machine (C); - Parse_Prologue (C); - - -- Advance to the first entry - - loop - Read_And_Execute_Isn (C, Done); - - if C.Registers.Is_Row then - Previous_Row := C.Registers; - exit; - end if; - - exit when Done; - end loop; - - -- Read the rest of the entries - - while Tell (C.Lines) < C.Next_Prologue loop - Read_And_Execute_Isn (C, Done); - - if C.Registers.Is_Row then - if not Previous_Row.End_Sequence - and then Addr_Int >= Integer_Address (Previous_Row.Address) - and then Addr_Int < Integer_Address (C.Registers.Address) - then - Set_Result (Previous_Row); - return; - - elsif Addr_Int = Integer_Address (C.Registers.Address) then - Set_Result (C.Registers); - return; - end if; - - Previous_Row := C.Registers; - end if; - - exit when Done; - end loop; - end Symbolic_Address; - - ------------------- - -- String_Length -- - ------------------- - - function String_Length (Str : Str_Access) return Natural is - begin - for I in Str'Range loop - if Str (I) = ASCII.NUL then - return I - Str'First; - end if; - end loop; - return Str'Last; - end String_Length; - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - procedure Symbolic_Traceback - (Cin : Dwarf_Context; - Traceback : AET.Tracebacks_Array; - Suppress_Hex : Boolean; - Symbol_Found : in out Boolean; - Res : in out System.Bounded_Strings.Bounded_String) - is - use Ada.Characters.Handling; - C : Dwarf_Context := Cin; - Addr : Address; - - Dir_Name : Str_Access; - File_Name : Str_Access; - Subprg_Name : String_Ptr_Len; - Line_Num : Natural; - Off : Natural; - begin - if not C.Has_Debug then - Symbol_Found := False; - return; - else - Symbol_Found := True; - end if; - - for J in Traceback'Range loop - -- If the buffer is full, no need to do any useless work - exit when Is_Full (Res); - - Addr := PC_For (Traceback (J)); - Symbolic_Address - (C, - To_Address (To_Integer (Addr) + C.Load_Slide), - Dir_Name, - File_Name, - Subprg_Name, - Line_Num); - - if File_Name /= null then - declare - Last : constant Natural := String_Length (File_Name); - Is_Ada : constant Boolean := - Last > 3 - and then - To_Upper (String (File_Name (Last - 3 .. Last - 1))) = - ".AD"; - -- True if this is an Ada file. This doesn't take into account - -- nonstandard file-naming conventions, but that's OK; this is - -- purely cosmetic. It covers at least .ads, .adb, and .ada. - - Line_Image : constant String := Natural'Image (Line_Num); - begin - if Subprg_Name.Len /= 0 then - -- For Ada code, Symbol_Image is in all lower case; we don't - -- have the case from the original source code. But the best - -- guess is Mixed_Case, so convert to that. - - if Is_Ada then - declare - Symbol_Image : String := - Object_Reader.Decoded_Ada_Name - (C.Obj.all, - Subprg_Name); - begin - for K in Symbol_Image'Range loop - if K = Symbol_Image'First - or else not - (Is_Letter (Symbol_Image (K - 1)) - or else Is_Digit (Symbol_Image (K - 1))) - then - Symbol_Image (K) := To_Upper (Symbol_Image (K)); - end if; - end loop; - Append (Res, Symbol_Image); - end; - else - Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); - - Append - (Res, - String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); - end if; - Append (Res, ' '); - end if; - - Append (Res, "at "); - Append (Res, String (File_Name (1 .. Last))); - Append (Res, ':'); - Append (Res, Line_Image (2 .. Line_Image'Last)); - end; - else - if Suppress_Hex then - Append (Res, "..."); - else - Append_Address (Res, Addr); - end if; - - if Subprg_Name.Len > 0 then - Off := Strip_Leading_Char (C.Obj.all, Subprg_Name); - - Append (Res, ' '); - Append (Res, String (Subprg_Name.Ptr (Off .. Subprg_Name.Len))); - end if; - - Append (Res, " at ???"); - end if; - - Append (Res, ASCII.LF); - end loop; - end Symbolic_Traceback; -end System.Dwarf_Lines; diff --git a/gcc/ada/s-dwalin.ads b/gcc/ada/s-dwalin.ads deleted file mode 100644 index 3608fef..0000000 --- a/gcc/ada/s-dwalin.ads +++ /dev/null @@ -1,191 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . D W A R F _ L I N E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides routines to read DWARF line number information from --- a generic object file with as little overhead as possible. This allows --- conversions from PC addresses to human readable source locations. --- --- Objects must be built with debugging information, however only the --- .debug_line section of the object file is referenced. In cases where object --- size is a consideration it's possible to strip all other .debug sections, --- which will decrease the size of the object significantly. - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on - -with Ada.Exceptions.Traceback; - -with System.Object_Reader; -with System.Storage_Elements; -with System.Bounded_Strings; - -package System.Dwarf_Lines is - - package AET renames Ada.Exceptions.Traceback; - package SOR renames System.Object_Reader; - - type Dwarf_Context (In_Exception : Boolean := False) is private; - -- Type encapsulation the state of the Dwarf reader. When In_Exception - -- is True we are parsing as part of a exception handler decorator, we do - -- not want an exception to be raised, the parsing is done safely skipping - -- DWARF file that cannot be read or with stripped debug section for - -- example. - - procedure Open - (File_Name : String; - C : out Dwarf_Context; - Success : out Boolean); - procedure Close (C : in out Dwarf_Context); - -- Open and close files - - procedure Set_Load_Address (C : in out Dwarf_Context; Addr : Address); - -- Set the load address of a file. This is used to rebase PIE (Position - -- Independant Executable) binaries. - - function Is_Inside (C : Dwarf_Context; Addr : Address) return Boolean; - pragma Inline (Is_Inside); - -- Return true iff Addr is within the module - - function Low (C : Dwarf_Context) return Address; - pragma Inline (Low); - -- Return the lowest address of C - - procedure Dump (C : in out Dwarf_Context); - -- Dump each row found in the object's .debug_lines section to standard out - - procedure Dump_Cache (C : Dwarf_Context); - -- Dump the cache (if present) - - procedure Enable_Cache (C : in out Dwarf_Context); - -- Read symbols information to speed up Symbolic_Traceback. - - procedure Symbolic_Traceback - (Cin : Dwarf_Context; - Traceback : AET.Tracebacks_Array; - Suppress_Hex : Boolean; - Symbol_Found : in out Boolean; - Res : in out System.Bounded_Strings.Bounded_String); - -- Generate a string for a traceback suitable for displaying to the user. - -- If one or more symbols are found, Symbol_Found is set to True. This - -- allows the caller to fall back to hexadecimal addresses. - - Dwarf_Error : exception; - -- Raised if a problem is encountered parsing DWARF information. Can be a - -- result of a logic error or malformed DWARF information. - -private - -- The following section numbers reference - - -- "DWARF Debugging Information Format, Version 3" - - -- published by the Standards Group, http://freestandards.org. - - -- 6.2.2 State Machine Registers - - type Line_Info_Registers is record - Address : SOR.uint64; - File : SOR.uint32; - Line : SOR.uint32; - Column : SOR.uint32; - Is_Stmt : Boolean; - Basic_Block : Boolean; - End_Sequence : Boolean; - Prologue_End : Boolean; - Epilogue_Begin : Boolean; - ISA : SOR.uint32; - Is_Row : Boolean; - end record; - - -- 6.2.4 The Line Number Program Prologue - - MAX_OPCODE_LENGTHS : constant := 256; - - type Opcodes_Lengths_Array is - array (SOR.uint32 range 1 .. MAX_OPCODE_LENGTHS) of SOR.uint8; - - type Line_Info_Prologue is record - Unit_Length : SOR.uint32; - Version : SOR.uint16; - Prologue_Length : SOR.uint32; - Min_Isn_Length : SOR.uint8; - Default_Is_Stmt : SOR.uint8; - Line_Base : SOR.int8; - Line_Range : SOR.uint8; - Opcode_Base : SOR.uint8; - Opcode_Lengths : Opcodes_Lengths_Array; - Includes_Offset : SOR.Offset; - File_Names_Offset : SOR.Offset; - end record; - - type Search_Entry is record - First : SOR.uint32; - Size : SOR.uint32; - -- Function bounds as offset to the base address. - - Sym : SOR.uint32; - -- Symbol offset to get the name. - - Line : SOR.uint32; - -- Dwarf line offset. - end record; - - type Search_Array is array (Natural range <>) of Search_Entry; - - type Search_Array_Access is access Search_Array; - - type Dwarf_Context (In_Exception : Boolean := False) is record - Load_Slide : System.Storage_Elements.Integer_Address := 0; - Low, High : Address; - -- Bounds of the module - - Obj : SOR.Object_File_Access; - -- The object file containing dwarf sections - - Has_Debug : Boolean; - -- True if all debug sections are available - - Cache : Search_Array_Access; - -- Quick access to symbol and debug info (when present). - - Lines : SOR.Mapped_Stream; - Aranges : SOR.Mapped_Stream; - Info : SOR.Mapped_Stream; - Abbrev : SOR.Mapped_Stream; - -- Dwarf line, aranges, info and abbrev sections - - Prologue : Line_Info_Prologue; - Registers : Line_Info_Registers; - Next_Prologue : SOR.Offset; - -- State for lines - end record; - -end System.Dwarf_Lines; diff --git a/gcc/ada/s-elaall.adb b/gcc/ada/s-elaall.adb deleted file mode 100644 index 8160cf3..0000000 --- a/gcc/ada/s-elaall.adb +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E L A B O R A T I O N _ A L L O C A T O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Elaboration_Allocators is - - Elaboration_In_Progress : Boolean; - pragma Atomic (Elaboration_In_Progress); - -- Flag to show if elaboration is active. We don't attempt to initialize - -- this because we want to be sure it gets reset if we are in a multiple - -- elaboration situation of some kind. Make it atomic to prevent race - -- conditions of any kind (not clearly necessary, but harmless!) - - ------------------------------ - -- Check_Standard_Allocator -- - ------------------------------ - - procedure Check_Standard_Allocator is - begin - if not Elaboration_In_Progress then - raise Program_Error with - "standard allocator after elaboration is complete is not allowed " - & "(No_Standard_Allocators_After_Elaboration restriction active)"; - end if; - end Check_Standard_Allocator; - - ----------------------------- - -- Mark_End_Of_Elaboration -- - ----------------------------- - - procedure Mark_End_Of_Elaboration is - begin - Elaboration_In_Progress := False; - end Mark_End_Of_Elaboration; - - ------------------------------- - -- Mark_Start_Of_Elaboration -- - ------------------------------- - - procedure Mark_Start_Of_Elaboration is - begin - Elaboration_In_Progress := True; - end Mark_Start_Of_Elaboration; - -end System.Elaboration_Allocators; diff --git a/gcc/ada/s-elaall.ads b/gcc/ada/s-elaall.ads deleted file mode 100644 index f1cf620..0000000 --- a/gcc/ada/s-elaall.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E L A B O R A T I O N _ A L L O C A T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the interfaces for proper handling of restriction --- No_Standard_Allocators_After_Elaboration. It is used only by programs --- which use this restriction. - -package System.Elaboration_Allocators is - pragma Preelaborate; - - procedure Mark_Start_Of_Elaboration; - -- Called right at the start of main elaboration if the program activates - -- restriction No_Standard_Allocators_After_Elaboration. We don't want to - -- rely on the normal elaboration mechanism for marking this event, since - -- that would require us to be sure to elaborate this first, which would - -- be awkward, and it is convenient to have this package be Preelaborate. - - procedure Mark_End_Of_Elaboration; - -- Called when main elaboration is complete if the program has activated - -- restriction No_Standard_Allocators_After_Elaboration. This is the point - -- beyond which any standard allocator use will violate the restriction. - - procedure Check_Standard_Allocator; - -- Called as part of every allocator in a program for which the restriction - -- No_Standard_Allocators_After_Elaboration is active. This will raise an - -- exception (Program_Error with an appropriate message) if it is called - -- after the call to Mark_End_Of_Elaboration. - -end System.Elaboration_Allocators; diff --git a/gcc/ada/s-excdeb.adb b/gcc/ada/s-excdeb.adb deleted file mode 100644 index d9410f0..0000000 --- a/gcc/ada/s-excdeb.adb +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S _ D E B U G -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.Exceptions_Debug is - - --------------------------- - -- Debug_Raise_Exception -- - --------------------------- - - procedure Debug_Raise_Exception - (E : SSL.Exception_Data_Ptr; Message : String) - is - pragma Inspection_Point (E, Message); - begin - null; - end Debug_Raise_Exception; - - ------------------------------- - -- Debug_unhandled_Exception -- - ------------------------------- - - procedure Debug_Unhandled_Exception (E : SSL.Exception_Data_Ptr) is - pragma Inspection_Point (E); - begin - null; - end Debug_Unhandled_Exception; - - -------------------------------- - -- Debug_Raise_Assert_Failure -- - -------------------------------- - - procedure Debug_Raise_Assert_Failure is - begin - null; - end Debug_Raise_Assert_Failure; - - ----------------- - -- Local_Raise -- - ----------------- - - procedure Local_Raise (Excep : System.Address) is - pragma Warnings (Off, Excep); - begin - return; - end Local_Raise; - -end System.Exceptions_Debug; diff --git a/gcc/ada/s-excdeb.ads b/gcc/ada/s-excdeb.ads deleted file mode 100644 index 21e6b52..0000000 --- a/gcc/ada/s-excdeb.ads +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S _ D E B U G -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains internal routines used as debugger helpers. --- It should be compiled without optimization to let debuggers inspect --- parameter values reliably from breakpoints on the routines. - -pragma Compiler_Unit_Warning; - -with System.Standard_Library; - -package System.Exceptions_Debug is - - pragma Preelaborate; - -- To let Ada.Exceptions "with" us and let us "with" Standard_Library - - package SSL renames System.Standard_Library; - -- To let some of the hooks below have formal parameters typed in - -- accordance with what GDB expects. - - procedure Debug_Raise_Exception - (E : SSL.Exception_Data_Ptr; Message : String); - pragma Export - (Ada, Debug_Raise_Exception, "__gnat_debug_raise_exception"); - -- Hook called at a "raise" point for an exception E, when it is - -- just about to be propagated. - - procedure Debug_Unhandled_Exception (E : SSL.Exception_Data_Ptr); - pragma Export - (Ada, Debug_Unhandled_Exception, "__gnat_unhandled_exception"); - -- Hook called during the propagation process of an exception E, as soon - -- as it is known to be unhandled. - - procedure Debug_Raise_Assert_Failure; - pragma Export - (Ada, Debug_Raise_Assert_Failure, "__gnat_debug_raise_assert_failure"); - -- Hook called when an assertion failed. This is used by the debugger to - -- intercept assertion failures, and treat them specially. - - procedure Local_Raise (Excep : System.Address); - pragma Export (Ada, Local_Raise); - -- This is a dummy routine, used only by the debugger for the purpose of - -- logging local raise statements that were transformed into a direct goto - -- to the handler code. The compiler in this case generates: - -- - -- Local_Raise (exception_data'address); - -- goto Handler - -- - -- The argument is the address of the exception data -end System.Exceptions_Debug; diff --git a/gcc/ada/s-except.adb b/gcc/ada/s-except.adb deleted file mode 100644 index b30c925..0000000 --- a/gcc/ada/s-except.adb +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package does not require a body, since it is a package renaming. We --- provide a dummy file containing a No_Body pragma so that previous versions --- of the body (which did exist) will not interfere. - --- pragma No_Body; - --- The above pragma is commented out, since for now we can't use No_Body in --- a unit marked as a Compiler_Unit, since this requires GNAT 6.1, and we --- do not yet require this for bootstrapping. So instead we use a dummy Taft --- amendment type to require the body: - -package body System.Exceptions is - type Require_Body is new Integer; -end System.Exceptions; diff --git a/gcc/ada/s-except.ads b/gcc/ada/s-except.ads deleted file mode 100644 index e88a157..0000000 --- a/gcc/ada/s-except.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package System.Exceptions is - - pragma Preelaborate; - -- To let Ada.Exceptions "with" us and let us "with" Standard_Library - - ZCX_By_Default : constant Boolean; - -- Visible copy to allow Ada.Exceptions to know the exception model - -private - - type Require_Body; - -- Dummy Taft-amendment type to make it legal (and required) to provide - -- a body for this package. - -- - -- We do this because this unit used to have a body in earlier versions - -- of GNAT, and it causes various bootstrap path problems etc if we remove - -- a body, since we may pick up old unwanted bodies. - -- - -- Note: we use this standard Ada method of requiring a body rather - -- than the cleaner pragma No_Body because System.Exceptions is a compiler - -- unit, and older bootstrap compilers do not support pragma No_Body. This - -- type can be removed, and s-except.adb can be replaced by a source - -- containing just that pragma, when we decide to move to a 2008 compiler - -- as the minimal bootstrap compiler version. ??? - - ZCX_By_Default : constant Boolean := System.ZCX_By_Default; - - Foreign_Exception : exception; - pragma Unreferenced (Foreign_Exception); - -- This hidden exception is used to represent non-Ada exception to - -- Ada handlers. It is in fact referenced by its linking name. - -end System.Exceptions; diff --git a/gcc/ada/s-excmac-arm.adb b/gcc/ada/s-excmac-arm.adb deleted file mode 100644 index cfaa853..0000000 --- a/gcc/ada/s-excmac-arm.adb +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exceptions.Machine is - function New_Occurrence return GNAT_GCC_Exception_Access is - Res : GNAT_GCC_Exception_Access; - begin - Res := new GNAT_GCC_Exception; - Res.Header.Class := GNAT_Exception_Class; - Res.Header.Unwinder_Cache. Reserved1 := 0; - return Res; - end New_Occurrence; - -end System.Exceptions.Machine; diff --git a/gcc/ada/s-excmac-arm.ads b/gcc/ada/s-excmac-arm.ads deleted file mode 100644 index 195d337..0000000 --- a/gcc/ada/s-excmac-arm.ads +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Declaration of the machine exception and some associated facilities. The --- machine exception is the object that is propagated by low level routines --- and that contains the Ada exception occurrence. - --- This is the version using the ARM EHABI mechanism - -with Ada.Unchecked_Conversion; -with Ada.Exceptions; - -package System.Exceptions.Machine is - pragma Preelaborate; - - ------------------------------------------------ - -- Entities to interface with the GCC runtime -- - ------------------------------------------------ - - -- Return codes from GCC runtime functions used to propagate an exception - - type Unwind_Reason_Code is - (URC_OK, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_Unused2, - URC_Unused3, - URC_Unused4, - URC_Unused5, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND, - URC_FAILURE); - - pragma Unreferenced - (URC_OK, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_Unused2, - URC_Unused3, - URC_Unused4, - URC_Unused5, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND, - URC_FAILURE); - - pragma Convention (C, Unwind_Reason_Code); - subtype Unwind_Action is Unwind_Reason_Code; - -- Phase identifiers - - type uint32_t is mod 2**32; - pragma Convention (C, uint32_t); - - type uint32_t_array is array (Natural range <>) of uint32_t; - pragma Convention (C, uint32_t_array); - - type Unwind_State is new uint32_t; - pragma Convention (C, Unwind_State); - - US_VIRTUAL_UNWIND_FRAME : constant Unwind_State := 0; - US_UNWIND_FRAME_STARTING : constant Unwind_State := 1; - US_UNWIND_FRAME_RESUME : constant Unwind_State := 2; - - pragma Unreferenced - (US_VIRTUAL_UNWIND_FRAME, - US_UNWIND_FRAME_STARTING, - US_UNWIND_FRAME_RESUME); - - -- Mandatory common header for any exception object handled by the - -- GCC unwinding runtime. - - type Exception_Class is array (0 .. 7) of Character; - - GNAT_Exception_Class : constant Exception_Class := "GNU-Ada" & ASCII.NUL; - -- "GNU-Ada\0" - - type Unwinder_Cache_Type is record - Reserved1 : uint32_t; - Reserved2 : uint32_t; - Reserved3 : uint32_t; - Reserved4 : uint32_t; - Reserved5 : uint32_t; - end record; - - type Barrier_Cache_Type is record - Sp : uint32_t; - Bitpattern : uint32_t_array (0 .. 4); - end record; - - type Cleanup_Cache_Type is record - Bitpattern : uint32_t_array (0 .. 3); - end record; - - type Pr_Cache_Type is record - Fnstart : uint32_t; - Ehtp : System.Address; - Additional : uint32_t; - Reserved1 : uint32_t; - end record; - - type Unwind_Control_Block is record - Class : Exception_Class; - Cleanup : System.Address; - - -- Caches - Unwinder_Cache : Unwinder_Cache_Type; - Barrier_Cache : Barrier_Cache_Type; - Cleanup_Cache : Cleanup_Cache_Type; - Pr_Cache : Pr_Cache_Type; - end record; - pragma Convention (C, Unwind_Control_Block); - for Unwind_Control_Block'Alignment use 8; - -- Map the GCC struct used for exception handling - - type Unwind_Control_Block_Access is access all Unwind_Control_Block; - subtype GCC_Exception_Access is Unwind_Control_Block_Access; - -- Pointer to a UCB - - procedure Unwind_DeleteException - (Ucbp : not null Unwind_Control_Block_Access); - pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); - -- Procedure to free any GCC exception - - -------------------------------------------------------------- - -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- - -------------------------------------------------------------- - - -- A GNAT exception object to be dealt with by the personality routine - -- called by the GCC unwinding runtime. - - type GNAT_GCC_Exception is record - Header : Unwind_Control_Block; - -- ABI Exception header first - - Occurrence : aliased Ada.Exceptions.Exception_Occurrence; - -- The Ada occurrence - end record; - - pragma Convention (C, GNAT_GCC_Exception); - - type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; - - function To_GCC_Exception is new - Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); - - function To_GNAT_GCC_Exception is new - Ada.Unchecked_Conversion - (GCC_Exception_Access, GNAT_GCC_Exception_Access); - - function New_Occurrence return GNAT_GCC_Exception_Access; - -- Allocate and initialize a machine occurrence - -end System.Exceptions.Machine; diff --git a/gcc/ada/s-excmac-gcc.adb b/gcc/ada/s-excmac-gcc.adb deleted file mode 100644 index 7d39651..0000000 --- a/gcc/ada/s-excmac-gcc.adb +++ /dev/null @@ -1,43 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exceptions.Machine is - function New_Occurrence return GNAT_GCC_Exception_Access is - Res : GNAT_GCC_Exception_Access; - begin - Res := new GNAT_GCC_Exception; - Res.Header := (Class => GNAT_Exception_Class, - Cleanup => Null_Address, - others => 0); - return Res; - end New_Occurrence; - -end System.Exceptions.Machine; diff --git a/gcc/ada/s-excmac-gcc.ads b/gcc/ada/s-excmac-gcc.ads deleted file mode 100644 index dabf8b6..0000000 --- a/gcc/ada/s-excmac-gcc.ads +++ /dev/null @@ -1,185 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N S . M A C H I N E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Declaration of the machine exception and some associated facilities. The --- machine exception is the object that is propagated by low level routines --- and that contains the Ada exception occurrence. - --- This is the version using the GCC EH mechanism - -with Ada.Unchecked_Conversion; -with Ada.Exceptions; - -package System.Exceptions.Machine is - pragma Preelaborate; - - ------------------------------------------------ - -- Entities to interface with the GCC runtime -- - ------------------------------------------------ - - -- These come from "C++ ABI for Itanium: Exception handling", which is - -- the reference for GCC. - - -- Return codes from the GCC runtime functions used to propagate - -- an exception. - - type Unwind_Reason_Code is - (URC_NO_REASON, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_PHASE2_ERROR, - URC_PHASE1_ERROR, - URC_NORMAL_STOP, - URC_END_OF_STACK, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND); - - pragma Unreferenced - (URC_NO_REASON, - URC_FOREIGN_EXCEPTION_CAUGHT, - URC_PHASE2_ERROR, - URC_PHASE1_ERROR, - URC_NORMAL_STOP, - URC_END_OF_STACK, - URC_HANDLER_FOUND, - URC_INSTALL_CONTEXT, - URC_CONTINUE_UNWIND); - - pragma Convention (C, Unwind_Reason_Code); - - -- Phase identifiers - - type Unwind_Action is new Integer; - pragma Convention (C, Unwind_Action); - - UA_SEARCH_PHASE : constant Unwind_Action := 1; - UA_CLEANUP_PHASE : constant Unwind_Action := 2; - UA_HANDLER_FRAME : constant Unwind_Action := 4; - UA_FORCE_UNWIND : constant Unwind_Action := 8; - UA_END_OF_STACK : constant Unwind_Action := 16; -- GCC extension - - pragma Unreferenced - (UA_SEARCH_PHASE, - UA_CLEANUP_PHASE, - UA_HANDLER_FRAME, - UA_FORCE_UNWIND, - UA_END_OF_STACK); - - -- Mandatory common header for any exception object handled by the - -- GCC unwinding runtime. - - type Exception_Class is mod 2 ** 64; - - GNAT_Exception_Class : constant Exception_Class := 16#474e552d41646100#; - -- "GNU-Ada\0" - - type Unwind_Word is mod 2 ** System.Word_Size; - for Unwind_Word'Size use System.Word_Size; - -- Map the corresponding C type used in Unwind_Exception below - - type Unwind_Exception is record - Class : Exception_Class; - Cleanup : System.Address; - Private1 : Unwind_Word; - Private2 : Unwind_Word; - - -- Usual exception structure has only two private fields, but the SEH - -- one has six. To avoid making this file more complex, we use six - -- fields on all platforms, wasting a few bytes on some. - - Private3 : Unwind_Word; - Private4 : Unwind_Word; - Private5 : Unwind_Word; - Private6 : Unwind_Word; - end record; - pragma Convention (C, Unwind_Exception); - -- Map the GCC struct used for exception handling - - for Unwind_Exception'Alignment use Standard'Maximum_Alignment; - -- The C++ ABI mandates the common exception header to be at least - -- doubleword aligned, and the libGCC implementation actually makes it - -- maximally aligned (see unwind.h). See additional comments on the - -- alignment below. - - -- There is a subtle issue with the common header alignment, since the C - -- version is aligned on BIGGEST_ALIGNMENT, the Ada version is aligned on - -- Standard'Maximum_Alignment, and those two values don't quite represent - -- the same concepts and so may be decoupled someday. One typical reason - -- is that BIGGEST_ALIGNMENT may be larger than what the underlying system - -- allocator guarantees, and there are extra costs involved in allocating - -- objects aligned to such factors. - - -- To deal with the potential alignment differences between the C and Ada - -- representations, the Ada part of the whole structure is only accessed - -- by the personality routine through accessors. Ada specific fields are - -- thus always accessed through consistent layout, and we expect the - -- actual alignment to always be large enough to avoid traps from the C - -- accesses to the common header. Besides, accessors alleviate the need - -- for a C struct whole counterpart, both painful and error-prone to - -- maintain anyway. - - type GCC_Exception_Access is access all Unwind_Exception; - -- Pointer to a GCC exception - - procedure Unwind_DeleteException (Excp : not null GCC_Exception_Access); - pragma Import (C, Unwind_DeleteException, "_Unwind_DeleteException"); - -- Procedure to free any GCC exception - - -------------------------------------------------------------- - -- GNAT Specific Entities To Deal With The GCC EH Circuitry -- - -------------------------------------------------------------- - - -- A GNAT exception object to be dealt with by the personality routine - -- called by the GCC unwinding runtime. - - type GNAT_GCC_Exception is record - Header : Unwind_Exception; - -- ABI Exception header first - - Occurrence : aliased Ada.Exceptions.Exception_Occurrence; - -- The Ada occurrence - end record; - - pragma Convention (C, GNAT_GCC_Exception); - - type GNAT_GCC_Exception_Access is access all GNAT_GCC_Exception; - - function To_GCC_Exception is new - Ada.Unchecked_Conversion (System.Address, GCC_Exception_Access); - - function To_GNAT_GCC_Exception is new - Ada.Unchecked_Conversion - (GCC_Exception_Access, GNAT_GCC_Exception_Access); - - function New_Occurrence return GNAT_GCC_Exception_Access; - -- Allocate and initialize a machine occurrence - -end System.Exceptions.Machine; diff --git a/gcc/ada/s-exctab.adb b/gcc/ada/s-exctab.adb deleted file mode 100644 index 23a4815..0000000 --- a/gcc/ada/s-exctab.adb +++ /dev/null @@ -1,339 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N _ T A B L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Soft_Links; use System.Soft_Links; - -package body System.Exception_Table is - - use System.Standard_Library; - - type Hash_Val is mod 2 ** 8; - subtype Hash_Idx is Hash_Val range 1 .. 37; - - HTable : array (Hash_Idx) of aliased Exception_Data_Ptr; - -- Actual hash table containing all registered exceptions - -- - -- The table is very small and the hash function weak, as looking up - -- registered exceptions is rare and minimizing space and time overhead - -- of registration is more important. In addition, it is expected that the - -- exceptions that need to be looked up are registered dynamically, and - -- therefore will be at the begin of the hash chains. - -- - -- The table differs from System.HTable.Static_HTable in that the final - -- element of each chain is not marked by null, but by a pointer to self. - -- This way it is possible to defend against the same entry being inserted - -- twice, without having to do a lookup which is relatively expensive for - -- programs with large number - -- - -- All non-local subprograms use the global Task_Lock to protect against - -- concurrent use of the exception table. This is needed as local - -- exceptions may be declared concurrently with those declared at the - -- library level. - - -- Local Subprograms - - generic - with procedure Process (T : Exception_Data_Ptr; More : out Boolean); - procedure Iterate; - -- Iterate over all - - function Lookup (Name : String) return Exception_Data_Ptr; - -- Find and return the Exception_Data of the exception with the given Name - -- (which must be in all uppercase), or null if none was registered. - - procedure Register (Item : Exception_Data_Ptr); - -- Register an exception with the given Exception_Data in the table. - - function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean; - -- Return True iff Item.Full_Name and Name are equal. Both names are - -- assumed to be in all uppercase and end with ASCII.NUL. - - function Hash (S : String) return Hash_Idx; - -- Return the index in the hash table for S, which is assumed to be all - -- uppercase and end with ASCII.NUL. - - -------------- - -- Has_Name -- - -------------- - - function Has_Name (Item : Exception_Data_Ptr; Name : String) return Boolean - is - S : constant Big_String_Ptr := To_Ptr (Item.Full_Name); - J : Integer := S'First; - - begin - for K in Name'Range loop - - -- Note that as both items are terminated with ASCII.NUL, the - -- comparison below must fail for strings of different lengths. - - if S (J) /= Name (K) then - return False; - end if; - - J := J + 1; - end loop; - - return True; - end Has_Name; - - ------------ - -- Lookup -- - ------------ - - function Lookup (Name : String) return Exception_Data_Ptr is - Prev : Exception_Data_Ptr; - Curr : Exception_Data_Ptr; - - begin - Curr := HTable (Hash (Name)); - Prev := null; - while Curr /= Prev loop - if Has_Name (Curr, Name) then - return Curr; - end if; - - Prev := Curr; - Curr := Curr.HTable_Ptr; - end loop; - - return null; - end Lookup; - - ---------- - -- Hash -- - ---------- - - function Hash (S : String) return Hash_Idx is - Hash : Hash_Val := 0; - - begin - for J in S'Range loop - exit when S (J) = ASCII.NUL; - Hash := Hash xor Character'Pos (S (J)); - end loop; - - return Hash_Idx'First + Hash mod (Hash_Idx'Last - Hash_Idx'First + 1); - end Hash; - - ------------- - -- Iterate -- - ------------- - - procedure Iterate is - More : Boolean; - Prev, Curr : Exception_Data_Ptr; - - begin - Outer : for Idx in HTable'Range loop - Prev := null; - Curr := HTable (Idx); - - while Curr /= Prev loop - Process (Curr, More); - - exit Outer when not More; - - Prev := Curr; - Curr := Curr.HTable_Ptr; - end loop; - end loop Outer; - end Iterate; - - -------------- - -- Register -- - -------------- - - procedure Register (Item : Exception_Data_Ptr) is - begin - if Item.HTable_Ptr = null then - Prepend_To_Chain : declare - Chain : Exception_Data_Ptr - renames HTable (Hash (To_Ptr (Item.Full_Name).all)); - - begin - if Chain = null then - Item.HTable_Ptr := Item; - else - Item.HTable_Ptr := Chain; - end if; - - Chain := Item; - end Prepend_To_Chain; - end if; - end Register; - - ------------------------------- - -- Get_Registered_Exceptions -- - ------------------------------- - - procedure Get_Registered_Exceptions - (List : out Exception_Data_Array; - Last : out Integer) - is - procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean); - -- Add Item to List (List'First .. Last) by first incrementing Last - -- and storing Item in List (Last). Last should be in List'First - 1 - -- and List'Last. - - procedure Get_All is new Iterate (Get_One); - -- Store all registered exceptions in List, updating Last - - ------------- - -- Get_One -- - ------------- - - procedure Get_One (Item : Exception_Data_Ptr; More : out Boolean) is - begin - if Last < List'Last then - Last := Last + 1; - List (Last) := Item; - More := True; - - else - More := False; - end if; - end Get_One; - - begin - -- In this routine the invariant is that List (List'First .. Last) - -- contains the registered exceptions retrieved so far. - - Last := List'First - 1; - - Lock_Task.all; - Get_All; - Unlock_Task.all; - end Get_Registered_Exceptions; - - ------------------------ - -- Internal_Exception -- - ------------------------ - - function Internal_Exception - (X : String; - Create_If_Not_Exist : Boolean := True) return Exception_Data_Ptr - is - -- If X was not yet registered and Create_if_Not_Exist is True, - -- dynamically allocate and register a new exception. - - type String_Ptr is access all String; - - Dyn_Copy : String_Ptr; - Copy : aliased String (X'First .. X'Last + 1); - Result : Exception_Data_Ptr; - - begin - Lock_Task.all; - - Copy (X'Range) := X; - Copy (Copy'Last) := ASCII.NUL; - Result := Lookup (Copy); - - -- If unknown exception, create it on the heap. This is a legitimate - -- situation in the distributed case when an exception is defined - -- only in a partition - - if Result = null and then Create_If_Not_Exist then - Dyn_Copy := new String'(Copy); - - Result := - new Exception_Data' - (Not_Handled_By_Others => False, - Lang => 'A', - Name_Length => Copy'Length, - Full_Name => Dyn_Copy.all'Address, - HTable_Ptr => null, - Foreign_Data => Null_Address, - Raise_Hook => null); - - Register (Result); - end if; - - Unlock_Task.all; - - return Result; - end Internal_Exception; - - ------------------------ - -- Register_Exception -- - ------------------------ - - procedure Register_Exception (X : Exception_Data_Ptr) is - begin - Lock_Task.all; - Register (X); - Unlock_Task.all; - end Register_Exception; - - --------------------------------- - -- Registered_Exceptions_Count -- - --------------------------------- - - function Registered_Exceptions_Count return Natural is - Count : Natural := 0; - - procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean); - -- Update Count for given Item - - procedure Count_Item (Item : Exception_Data_Ptr; More : out Boolean) is - pragma Unreferenced (Item); - begin - Count := Count + 1; - More := Count < Natural'Last; - end Count_Item; - - procedure Count_All is new Iterate (Count_Item); - - begin - Lock_Task.all; - Count_All; - Unlock_Task.all; - - return Count; - end Registered_Exceptions_Count; - -begin - -- Register the standard exceptions at elaboration time - - -- We don't need to use the locking version here as the elaboration - -- will not be concurrent and no tasks can call any subprograms of this - -- unit before it has been elaborated. - - Register (Abort_Signal_Def'Access); - Register (Tasking_Error_Def'Access); - Register (Storage_Error_Def'Access); - Register (Program_Error_Def'Access); - Register (Numeric_Error_Def'Access); - Register (Constraint_Error_Def'Access); -end System.Exception_Table; diff --git a/gcc/ada/s-exctab.ads b/gcc/ada/s-exctab.ads deleted file mode 100644 index 3434fd8..0000000 --- a/gcc/ada/s-exctab.ads +++ /dev/null @@ -1,75 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N _ T A B L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements the interface used to maintain a table of --- registered exception names, for the implementation of the mapping --- of names to exceptions (used for exception streams and attributes) - -pragma Compiler_Unit_Warning; - -with System.Standard_Library; - -package System.Exception_Table is - pragma Elaborate_Body; - - package SSL renames System.Standard_Library; - - procedure Register_Exception (X : SSL.Exception_Data_Ptr); - pragma Inline (Register_Exception); - -- Register an exception in the hash table mapping. This function is - -- called during elaboration of library packages. For exceptions that - -- are declared within subprograms, the registration occurs the first - -- time that an exception is elaborated during a call of the subprogram. - -- - -- Note: all calls to Register_Exception other than those to register the - -- predefined exceptions are suppressed if the application is compiled - -- with pragma Restrictions (No_Exception_Registration). - - function Internal_Exception - (X : String; - Create_If_Not_Exist : Boolean := True) return SSL.Exception_Data_Ptr; - -- Given an exception_name X, returns a pointer to the actual internal - -- exception data. A new entry is created in the table if X does not - -- exist yet and Create_If_Not_Exist is True. If it is false and X - -- does not exist yet, null is returned. - - function Registered_Exceptions_Count return Natural; - -- Return the number of currently registered exceptions - - type Exception_Data_Array is array (Natural range <>) - of SSL.Exception_Data_Ptr; - - procedure Get_Registered_Exceptions - (List : out Exception_Data_Array; - Last : out Integer); - -- Return the list of registered exceptions - -end System.Exception_Table; diff --git a/gcc/ada/s-exctra.adb b/gcc/ada/s-exctra.adb deleted file mode 100644 index 343a723..0000000 --- a/gcc/ada/s-exctra.adb +++ /dev/null @@ -1,124 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N _ T R A C E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2016, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -with System.Standard_Library; use System.Standard_Library; -with System.Soft_Links; use System.Soft_Links; - -package body System.Exception_Traces is - - -- Calling the decorator directly from where it is needed would require - -- introducing nasty dependencies upon the spec of this package (typically - -- in a-except.adb). We also have to deal with the fact that the traceback - -- array within an exception occurrence and the one the decorator accepts - -- are of different types. These are two reasons for which a wrapper with - -- a System.Address argument is indeed used to call the decorator provided - -- by the user of this package. This wrapper is called via a soft-link, - -- which either is null when no decorator is in place or "points to" the - -- following function otherwise. - - function Decorator_Wrapper - (Traceback : System.Address; - Len : Natural) return String; - -- The wrapper to be called when a decorator is in place for exception - -- backtraces. - -- - -- Traceback is the address of the call chain array as stored in the - -- exception occurrence and Len is the number of significant addresses - -- contained in this array. - - Current_Decorator : Traceback_Decorator := null; - -- The decorator to be called by the wrapper when it is not null, as set - -- by Set_Trace_Decorator. When this access is null, the wrapper is null - -- also and shall then not be called. - - ----------------------- - -- Decorator_Wrapper -- - ----------------------- - - function Decorator_Wrapper - (Traceback : System.Address; - Len : Natural) return String - is - subtype Trace_Array is Traceback_Entries.Tracebacks_Array (1 .. Len); - type Trace_Array_Access is access all Trace_Array; - - function To_Trace_Array is new - Ada.Unchecked_Conversion (Address, Trace_Array_Access); - - Decorator_Traceback : constant Trace_Array_Access := - To_Trace_Array (Traceback); - - begin - return Current_Decorator.all (Decorator_Traceback.all); - end Decorator_Wrapper; - - ------------------------- - -- Set_Trace_Decorator -- - ------------------------- - - procedure Set_Trace_Decorator (Decorator : Traceback_Decorator) is - begin - Current_Decorator := Decorator; - Traceback_Decorator_Wrapper := - (if Current_Decorator /= null - then Decorator_Wrapper'Access else null); - end Set_Trace_Decorator; - - --------------- - -- Trace_Off -- - --------------- - - procedure Trace_Off is - begin - Exception_Trace := RM_Convention; - end Trace_Off; - - -------------- - -- Trace_On -- - -------------- - - procedure Trace_On (Kind : Trace_Kind) is - begin - case Kind is - when Every_Raise => - Exception_Trace := Every_Raise; - - when Unhandled_Raise => - Exception_Trace := Unhandled_Raise; - - when Unhandled_Raise_In_Main => - Exception_Trace := Unhandled_Raise_In_Main; - end case; - end Trace_On; - -end System.Exception_Traces; diff --git a/gcc/ada/s-exctra.ads b/gcc/ada/s-exctra.ads deleted file mode 100644 index ae6936e..0000000 --- a/gcc/ada/s-exctra.ads +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X C E P T I O N _ T R A C E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2015, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface allowing to control *automatic* output --- to standard error upon exception occurrences (as opposed to explicit --- generation of traceback information using System.Traceback). - --- This output includes the basic information associated with the exception --- (name, message) as well as a backtrace of the call chain at the point --- where the exception occurred. This backtrace is only output if the call --- chain information is available, depending if the binder switch dedicated --- to that purpose has been used or not. - --- The default backtrace is in the form of absolute code locations which may --- be converted to corresponding source locations using the addr2line utility --- or from within GDB. Please refer to System.Traceback for information about --- what is necessary to be able to exploit this possibility. - --- The backtrace output can also be customized by way of a "decorator" which --- may return any string output in association with a provided call chain. --- The decorator replaces the default backtrace mentioned above. - --- On systems that use DWARF debugging output, then if the "-g" compiler --- switch and the "-Es" binder switch are used, the decorator is automatically --- set to Symbolic_Traceback. - -with System.Traceback_Entries; - -package System.Exception_Traces is - - -- The following defines the exact situations in which raises will - -- cause automatic output of trace information. - - type Trace_Kind is - (Every_Raise, - -- Denotes the initial raise event for any exception occurrence, either - -- explicit or due to a specific language rule, within the context of a - -- task or not. - - Unhandled_Raise, - -- Denotes the raise events corresponding to exceptions for which there - -- is no user defined handler. This includes unhandled exceptions in - -- task bodies. - - Unhandled_Raise_In_Main - -- Same as Unhandled_Raise, except exceptions in task bodies are not - -- included. - ); - - -- The following procedures can be used to activate and deactivate - -- traces identified by the above trace kind values. - - procedure Trace_On (Kind : Trace_Kind); - -- Activate the traces denoted by Kind - - procedure Trace_Off; - -- Stop the tracing requested by the last call to Trace_On. - -- Has no effect if no such call has ever occurred. - - -- The following provide the backtrace decorating facilities - - type Traceback_Decorator is access - function (Traceback : Traceback_Entries.Tracebacks_Array) return String; - -- A backtrace decorator is a function which returns the string to be - -- output for a call chain provided by way of a tracebacks array. - - procedure Set_Trace_Decorator (Decorator : Traceback_Decorator); - -- Set the decorator to be used for future automatic outputs. Restore the - -- default behavior if the provided access value is null. - -- - -- Note: System.Traceback.Symbolic.Symbolic_Traceback may be used as the - -- Decorator, to get a symbolic traceback. This will cause a significant - -- cpu and memory overhead on some platforms. - -- - -- Note: The Decorator is called when constructing the - -- Exception_Information; that needs to be taken into account - -- if the Decorator has any side effects. - -end System.Exception_Traces; diff --git a/gcc/ada/s-exnint.adb b/gcc/ada/s-exnint.adb deleted file mode 100644 index 5b4f967..0000000 --- a/gcc/ada/s-exnint.adb +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X N _ I N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exn_Int is - - ----------------- - -- Exn_Integer -- - ----------------- - - function Exn_Integer (Left : Integer; Right : Natural) return Integer is - pragma Suppress (Division_Check); - pragma Suppress (Overflow_Check); - - Result : Integer := 1; - Factor : Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - end Exn_Integer; - -end System.Exn_Int; diff --git a/gcc/ada/s-exnint.ads b/gcc/ada/s-exnint.ads deleted file mode 100644 index 79773e8..0000000 --- a/gcc/ada/s-exnint.ads +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X N _ I N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Integer exponentiation (checks off) - -package System.Exn_Int is - pragma Pure; - - function Exn_Integer (Left : Integer; Right : Natural) return Integer; - -end System.Exn_Int; diff --git a/gcc/ada/s-exnllf.adb b/gcc/ada/s-exnllf.adb deleted file mode 100644 index be16b07..0000000 --- a/gcc/ada/s-exnllf.adb +++ /dev/null @@ -1,182 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X N _ L L F -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: the reason for treating exponents in the range 0 .. 4 specially is --- to ensure identical results to the static inline expansion in the case of --- a compile time known exponent in this range. The use of Float'Machine and --- Long_Float'Machine is to avoid unwanted extra precision in the results. - --- Note that for a negative exponent in Left ** Right, we compute the result --- as: - --- 1.0 / (Left ** (-Right)) - --- Note that the case of Left being zero is not special, it will simply result --- in a division by zero at the end, yielding a correctly signed infinity, or --- possibly generating an overflow. - --- Note on overflow: This coding assumes that the target generates infinities --- with standard IEEE semantics. If this is not the case, then the code --- for negative exponent may raise Constraint_Error. This follows the --- implementation permission given in RM 4.5.6(12). - -package body System.Exn_LLF is - - subtype Negative is Integer range Integer'First .. -1; - - function Exp - (Left : Long_Long_Float; - Right : Natural) return Long_Long_Float; - -- Common routine used if Right is greater or equal to 5 - - --------------- - -- Exn_Float -- - --------------- - - function Exn_Float - (Left : Float; - Right : Integer) return Float - is - Temp : Float; - begin - case Right is - when 0 => - return 1.0; - when 1 => - return Left; - when 2 => - return Float'Machine (Left * Left); - when 3 => - return Float'Machine (Left * Left * Left); - when 4 => - Temp := Float'Machine (Left * Left); - return Float'Machine (Temp * Temp); - when Negative => - return Float'Machine (1.0 / Exn_Float (Left, -Right)); - when others => - return - Float'Machine - (Float (Exp (Long_Long_Float (Left), Right))); - end case; - end Exn_Float; - - -------------------- - -- Exn_Long_Float -- - -------------------- - - function Exn_Long_Float - (Left : Long_Float; - Right : Integer) return Long_Float - is - Temp : Long_Float; - begin - case Right is - when 0 => - return 1.0; - when 1 => - return Left; - when 2 => - return Long_Float'Machine (Left * Left); - when 3 => - return Long_Float'Machine (Left * Left * Left); - when 4 => - Temp := Long_Float'Machine (Left * Left); - return Long_Float'Machine (Temp * Temp); - when Negative => - return Long_Float'Machine (1.0 / Exn_Long_Float (Left, -Right)); - when others => - return - Long_Float'Machine - (Long_Float (Exp (Long_Long_Float (Left), Right))); - end case; - end Exn_Long_Float; - - ------------------------- - -- Exn_Long_Long_Float -- - ------------------------- - - function Exn_Long_Long_Float - (Left : Long_Long_Float; - Right : Integer) return Long_Long_Float - is - Temp : Long_Long_Float; - begin - case Right is - when 0 => - return 1.0; - when 1 => - return Left; - when 2 => - return Left * Left; - when 3 => - return Left * Left * Left; - when 4 => - Temp := Left * Left; - return Temp * Temp; - when Negative => - return 1.0 / Exn_Long_Long_Float (Left, -Right); - when others => - return Exp (Left, Right); - end case; - end Exn_Long_Long_Float; - - --------- - -- Exp -- - --------- - - function Exp - (Left : Long_Long_Float; - Right : Natural) return Long_Long_Float - is - Result : Long_Long_Float := 1.0; - Factor : Long_Long_Float := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. If the low order bit or Exp is - -- set, multiply the result by this factor. - - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - - return Result; - end Exp; - -end System.Exn_LLF; diff --git a/gcc/ada/s-exnllf.ads b/gcc/ada/s-exnllf.ads deleted file mode 100644 index dcbbae5..0000000 --- a/gcc/ada/s-exnllf.ads +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X N _ L L F -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- [Long_[Long_]]Float exponentiation (checks off) - -package System.Exn_LLF is - pragma Pure; - - function Exn_Float - (Left : Float; - Right : Integer) return Float; - - function Exn_Long_Float - (Left : Long_Float; - Right : Integer) return Long_Float; - - function Exn_Long_Long_Float - (Left : Long_Long_Float; - Right : Integer) return Long_Long_Float; - -end System.Exn_LLF; diff --git a/gcc/ada/s-exnlli.adb b/gcc/ada/s-exnlli.adb deleted file mode 100644 index e89c12b..0000000 --- a/gcc/ada/s-exnlli.adb +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X N _ L L I -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exn_LLI is - - --------------------------- - -- Exn_Long_Long_Integer -- - --------------------------- - - function Exn_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer - is - pragma Suppress (Division_Check); - pragma Suppress (Overflow_Check); - - Result : Long_Long_Integer := 1; - Factor : Long_Long_Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - end Exn_Long_Long_Integer; - -end System.Exn_LLI; diff --git a/gcc/ada/s-exnlli.ads b/gcc/ada/s-exnlli.ads deleted file mode 100644 index 0c733f8..0000000 --- a/gcc/ada/s-exnlli.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X N _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Long_Long_Integer exponentiation (checks off) - -package System.Exn_LLI is - pragma Pure; - - function Exn_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer; - -end System.Exn_LLI; diff --git a/gcc/ada/s-expint.adb b/gcc/ada/s-expint.adb deleted file mode 100644 index 0e90705..0000000 --- a/gcc/ada/s-expint.adb +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P I N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exp_Int is - - ----------------- - -- Exp_Integer -- - ----------------- - - -- Note that negative exponents get a constraint error because the - -- subtype of the Right argument (the exponent) is Natural. - - function Exp_Integer - (Left : Integer; - Right : Natural) - return Integer - is - Result : Integer := 1; - Factor : Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - declare - pragma Unsuppress (All_Checks); - begin - Result := Result * Factor; - end; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - - declare - pragma Unsuppress (All_Checks); - begin - Factor := Factor * Factor; - end; - end loop; - end if; - - return Result; - end Exp_Integer; - -end System.Exp_Int; diff --git a/gcc/ada/s-expint.ads b/gcc/ada/s-expint.ads deleted file mode 100644 index 6b41670..0000000 --- a/gcc/ada/s-expint.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P I N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Integer exponentiation (checks on) - -package System.Exp_Int is - pragma Pure; - - function Exp_Integer - (Left : Integer; - Right : Natural) - return Integer; - -end System.Exp_Int; diff --git a/gcc/ada/s-explli.adb b/gcc/ada/s-explli.adb deleted file mode 100644 index 32aae1a..0000000 --- a/gcc/ada/s-explli.adb +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P L L I -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exp_LLI is - - --------------------------- - -- Exp_Long_Long_Integer -- - --------------------------- - - -- Note that negative exponents get a constraint error because the - -- subtype of the Right argument (the exponent) is Natural. - - function Exp_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer - is - Result : Long_Long_Integer := 1; - Factor : Long_Long_Integer := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing base values -1, 0, +1 since - -- the expander does this when the base is a literal, and other cases - -- will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - declare - pragma Unsuppress (All_Checks); - begin - Result := Result * Factor; - end; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - - declare - pragma Unsuppress (All_Checks); - begin - Factor := Factor * Factor; - end; - end loop; - end if; - - return Result; - end Exp_Long_Long_Integer; - -end System.Exp_LLI; diff --git a/gcc/ada/s-explli.ads b/gcc/ada/s-explli.ads deleted file mode 100644 index 9c4f292..0000000 --- a/gcc/ada/s-explli.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Long_Long_Integer exponentiation - -package System.Exp_LLI is - pragma Pure; - - function Exp_Long_Long_Integer - (Left : Long_Long_Integer; - Right : Natural) - return Long_Long_Integer; - -end System.Exp_LLI; diff --git a/gcc/ada/s-expllu.adb b/gcc/ada/s-expllu.adb deleted file mode 100644 index 47192b9..0000000 --- a/gcc/ada/s-expllu.adb +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . X P _ B M L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Exp_LLU is - - ---------------------------- - -- Exp_Long_Long_Unsigned -- - ---------------------------- - - function Exp_Long_Long_Unsigned - (Left : Long_Long_Unsigned; - Right : Natural) - return Long_Long_Unsigned - is - Result : Long_Long_Unsigned := 1; - Factor : Long_Long_Unsigned := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing the cases of base values -1,0,+1 - -- since the expander does this when the base is a literal, and other - -- cases will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - - end Exp_Long_Long_Unsigned; - -end System.Exp_LLU; diff --git a/gcc/ada/s-expllu.ads b/gcc/ada/s-expllu.ads deleted file mode 100644 index d99215a..0000000 --- a/gcc/ada/s-expllu.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P _ L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This function performs exponentiation of unsigned types (with binary --- modulus values exceeding that of Unsigned_Types.Unsigned). The result --- is always full width, the caller must do a masking operation if the --- modulus is less than 2 ** (Long_Long_Unsigned'Size). - -with System.Unsigned_Types; - -package System.Exp_LLU is - pragma Pure; - - function Exp_Long_Long_Unsigned - (Left : System.Unsigned_Types.Long_Long_Unsigned; - Right : Natural) - return System.Unsigned_Types.Long_Long_Unsigned; - -end System.Exp_LLU; diff --git a/gcc/ada/s-expmod.adb b/gcc/ada/s-expmod.adb deleted file mode 100644 index aa1aa11..0000000 --- a/gcc/ada/s-expmod.adb +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P _ M O D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Exp_Mod is - use System.Unsigned_Types; - - ----------------- - -- Exp_Modular -- - ----------------- - - function Exp_Modular - (Left : Unsigned; - Modulus : Unsigned; - Right : Natural) return Unsigned - is - Result : Unsigned := 1; - Factor : Unsigned := Left; - Exp : Natural := Right; - - function Mult (X, Y : Unsigned) return Unsigned is - (Unsigned (Long_Long_Unsigned (X) * Long_Long_Unsigned (Y) - mod Long_Long_Unsigned (Modulus))); - -- Modular multiplication. Note that we can't take advantage of the - -- compiler's circuit, because the modulus is not known statically. - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing the cases of base values -1,0,+1 - -- since the expander does this when the base is a literal, and other - -- cases will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Mult (Result, Factor); - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Mult (Factor, Factor); - end loop; - end if; - - return Result; - - end Exp_Modular; - -end System.Exp_Mod; diff --git a/gcc/ada/s-expmod.ads b/gcc/ada/s-expmod.ads deleted file mode 100644 index be7851b..0000000 --- a/gcc/ada/s-expmod.ads +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P _ M O D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This function performs exponentiation of a modular type with nonbinary --- modulus values. Arithmetic is done in Long_Long_Unsigned, with explicit --- accounting for the modulus value which is passed as the second argument. --- Note that 1 is a binary modulus (2**0), so the compiler should not (and --- will not) call this function with Modulus equal to 1. - -with System.Unsigned_Types; - -package System.Exp_Mod is - pragma Pure; - use type System.Unsigned_Types.Unsigned; - - subtype Power_Of_2 is System.Unsigned_Types.Unsigned with - Dynamic_Predicate => - Power_Of_2 /= 0 and then (Power_Of_2 and (Power_Of_2 - 1)) = 0; - - function Exp_Modular - (Left : System.Unsigned_Types.Unsigned; - Modulus : System.Unsigned_Types.Unsigned; - Right : Natural) return System.Unsigned_Types.Unsigned - with - Pre => Modulus /= 0 and then Modulus not in Power_Of_2, - Post => Exp_Modular'Result = Left ** Right mod Modulus; - -end System.Exp_Mod; diff --git a/gcc/ada/s-expuns.adb b/gcc/ada/s-expuns.adb deleted file mode 100644 index 47581b0..0000000 --- a/gcc/ada/s-expuns.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P _ U N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Exp_Uns is - - ------------------ - -- Exp_Unsigned -- - ------------------ - - function Exp_Unsigned - (Left : Unsigned; - Right : Natural) - return Unsigned - is - Result : Unsigned := 1; - Factor : Unsigned := Left; - Exp : Natural := Right; - - begin - -- We use the standard logarithmic approach, Exp gets shifted right - -- testing successive low order bits and Factor is the value of the - -- base raised to the next power of 2. - - -- Note: it is not worth special casing the cases of base values -1,0,+1 - -- since the expander does this when the base is a literal, and other - -- cases will be extremely rare. - - if Exp /= 0 then - loop - if Exp rem 2 /= 0 then - Result := Result * Factor; - end if; - - Exp := Exp / 2; - exit when Exp = 0; - Factor := Factor * Factor; - end loop; - end if; - - return Result; - end Exp_Unsigned; - -end System.Exp_Uns; diff --git a/gcc/ada/s-expuns.ads b/gcc/ada/s-expuns.ads deleted file mode 100644 index 824327f..0000000 --- a/gcc/ada/s-expuns.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . E X P _ U N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This function performs exponentiation of unsigned types (with binary --- modulus values up to and including that of Unsigned_Types.Unsigned). --- The result is always full width, the caller must do a masking operation --- the modulus is less than 2 ** (Unsigned'Size). - -with System.Unsigned_Types; - -package System.Exp_Uns is - pragma Pure; - - function Exp_Unsigned - (Left : System.Unsigned_Types.Unsigned; - Right : Natural) - return System.Unsigned_Types.Unsigned; - -end System.Exp_Uns; diff --git a/gcc/ada/s-fatflt.ads b/gcc/ada/s-fatflt.ads deleted file mode 100644 index 5897128..0000000 --- a/gcc/ada/s-fatflt.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ F L T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for the type Float. - -with System.Fat_Gen; - -package System.Fat_Flt is - pragma Pure; - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_Float is new System.Fat_Gen (Float); - -end System.Fat_Flt; diff --git a/gcc/ada/s-fatgen.adb b/gcc/ada/s-fatgen.adb deleted file mode 100644 index fdb34f2..0000000 --- a/gcc/ada/s-fatgen.adb +++ /dev/null @@ -1,931 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ G E N -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- The implementation here is portable to any IEEE implementation. It does --- not handle nonbinary radix, and also assumes that model numbers and --- machine numbers are basically identical, which is not true of all possible --- floating-point implementations. On a non-IEEE machine, this body must be --- specialized appropriately, or better still, its generic instantiations --- should be replaced by efficient machine-specific code. - -with Ada.Unchecked_Conversion; -with System; -package body System.Fat_Gen is - - Float_Radix : constant T := T (T'Machine_Radix); - Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1); - - pragma Assert (T'Machine_Radix = 2); - -- This version does not handle radix 16 - - -- Constants for Decompose and Scaling - - Rad : constant T := T (T'Machine_Radix); - Invrad : constant T := 1.0 / Rad; - - subtype Expbits is Integer range 0 .. 6; - -- 2 ** (2 ** 7) might overflow. How big can radix-16 exponents get? - - Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64); - - R_Power : constant array (Expbits) of T := - (Rad ** 1, - Rad ** 2, - Rad ** 4, - Rad ** 8, - Rad ** 16, - Rad ** 32, - Rad ** 64); - - R_Neg_Power : constant array (Expbits) of T := - (Invrad ** 1, - Invrad ** 2, - Invrad ** 4, - Invrad ** 8, - Invrad ** 16, - Invrad ** 32, - Invrad ** 64); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Decompose (XX : T; Frac : out T; Expo : out UI); - -- Decomposes a floating-point number into fraction and exponent parts. - -- Both results are signed, with Frac having the sign of XX, and UI has - -- the sign of the exponent. The absolute value of Frac is in the range - -- 0.0 <= Frac < 1.0. If Frac = 0.0 or -0.0, then Expo is always zero. - - function Gradual_Scaling (Adjustment : UI) return T; - -- Like Scaling with a first argument of 1.0, but returns the smallest - -- denormal rather than zero when the adjustment is smaller than - -- Machine_Emin. Used for Succ and Pred. - - -------------- - -- Adjacent -- - -------------- - - function Adjacent (X, Towards : T) return T is - begin - if Towards = X then - return X; - elsif Towards > X then - return Succ (X); - else - return Pred (X); - end if; - end Adjacent; - - ------------- - -- Ceiling -- - ------------- - - function Ceiling (X : T) return T is - XT : constant T := Truncation (X); - begin - if X <= 0.0 then - return XT; - elsif X = XT then - return X; - else - return XT + 1.0; - end if; - end Ceiling; - - ------------- - -- Compose -- - ------------- - - function Compose (Fraction : T; Exponent : UI) return T is - Arg_Frac : T; - Arg_Exp : UI; - pragma Unreferenced (Arg_Exp); - begin - Decompose (Fraction, Arg_Frac, Arg_Exp); - return Scaling (Arg_Frac, Exponent); - end Compose; - - --------------- - -- Copy_Sign -- - --------------- - - function Copy_Sign (Value, Sign : T) return T is - Result : T; - - function Is_Negative (V : T) return Boolean; - pragma Import (Intrinsic, Is_Negative); - - begin - Result := abs Value; - - if Is_Negative (Sign) then - return -Result; - else - return Result; - end if; - end Copy_Sign; - - --------------- - -- Decompose -- - --------------- - - procedure Decompose (XX : T; Frac : out T; Expo : out UI) is - X : constant T := T'Machine (XX); - - begin - if X = 0.0 then - - -- The normalized exponent of zero is zero, see RM A.5.2(15) - - Frac := X; - Expo := 0; - - -- Check for infinities, transfinites, whatnot - - elsif X > T'Safe_Last then - Frac := Invrad; - Expo := T'Machine_Emax + 1; - - elsif X < T'Safe_First then - Frac := -Invrad; - Expo := T'Machine_Emax + 2; -- how many extra negative values? - - else - -- Case of nonzero finite x. Essentially, we just multiply - -- by Rad ** (+-2**N) to reduce the range. - - declare - Ax : T := abs X; - Ex : UI := 0; - - -- Ax * Rad ** Ex is invariant - - begin - if Ax >= 1.0 then - while Ax >= R_Power (Expbits'Last) loop - Ax := Ax * R_Neg_Power (Expbits'Last); - Ex := Ex + Log_Power (Expbits'Last); - end loop; - - -- Ax < Rad ** 64 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ax >= R_Power (N) then - Ax := Ax * R_Neg_Power (N); - Ex := Ex + Log_Power (N); - end if; - - -- Ax < R_Power (N) - - end loop; - - -- 1 <= Ax < Rad - - Ax := Ax * Invrad; - Ex := Ex + 1; - - else - -- 0 < ax < 1 - - while Ax < R_Neg_Power (Expbits'Last) loop - Ax := Ax * R_Power (Expbits'Last); - Ex := Ex - Log_Power (Expbits'Last); - end loop; - - -- Rad ** -64 <= Ax < 1 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ax < R_Neg_Power (N) then - Ax := Ax * R_Power (N); - Ex := Ex - Log_Power (N); - end if; - - -- R_Neg_Power (N) <= Ax < 1 - - end loop; - end if; - - Frac := (if X > 0.0 then Ax else -Ax); - Expo := Ex; - end; - end if; - end Decompose; - - -------------- - -- Exponent -- - -------------- - - function Exponent (X : T) return UI is - X_Frac : T; - X_Exp : UI; - pragma Unreferenced (X_Frac); - begin - Decompose (X, X_Frac, X_Exp); - return X_Exp; - end Exponent; - - ----------- - -- Floor -- - ----------- - - function Floor (X : T) return T is - XT : constant T := Truncation (X); - begin - if X >= 0.0 then - return XT; - elsif XT = X then - return X; - else - return XT - 1.0; - end if; - end Floor; - - -------------- - -- Fraction -- - -------------- - - function Fraction (X : T) return T is - X_Frac : T; - X_Exp : UI; - pragma Unreferenced (X_Exp); - begin - Decompose (X, X_Frac, X_Exp); - return X_Frac; - end Fraction; - - --------------------- - -- Gradual_Scaling -- - --------------------- - - function Gradual_Scaling (Adjustment : UI) return T is - Y : T; - Y1 : T; - Ex : UI := Adjustment; - - begin - if Adjustment < T'Machine_Emin - 1 then - Y := 2.0 ** T'Machine_Emin; - Y1 := Y; - Ex := Ex - T'Machine_Emin; - while Ex < 0 loop - Y := T'Machine (Y / 2.0); - - if Y = 0.0 then - return Y1; - end if; - - Ex := Ex + 1; - Y1 := Y; - end loop; - - return Y1; - - else - return Scaling (1.0, Adjustment); - end if; - end Gradual_Scaling; - - ------------------ - -- Leading_Part -- - ------------------ - - function Leading_Part (X : T; Radix_Digits : UI) return T is - L : UI; - Y, Z : T; - - begin - if Radix_Digits >= T'Machine_Mantissa then - return X; - - elsif Radix_Digits <= 0 then - raise Constraint_Error; - - else - L := Exponent (X) - Radix_Digits; - Y := Truncation (Scaling (X, -L)); - Z := Scaling (Y, L); - return Z; - end if; - end Leading_Part; - - ------------- - -- Machine -- - ------------- - - -- The trick with Machine is to force the compiler to store the result - -- in memory so that we do not have extra precision used. The compiler - -- is clever, so we have to outwit its possible optimizations. We do - -- this by using an intermediate pragma Volatile location. - - function Machine (X : T) return T is - Temp : T; - pragma Volatile (Temp); - begin - Temp := X; - return Temp; - end Machine; - - ---------------------- - -- Machine_Rounding -- - ---------------------- - - -- For now, the implementation is identical to that of Rounding, which is - -- a permissible behavior, but is not the most efficient possible approach. - - function Machine_Rounding (X : T) return T is - Result : T; - Tail : T; - - begin - Result := Truncation (abs X); - Tail := abs X - Result; - - if Tail >= 0.5 then - Result := Result + 1.0; - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end Machine_Rounding; - - ----------- - -- Model -- - ----------- - - -- We treat Model as identical to Machine. This is true of IEEE and other - -- nice floating-point systems, but not necessarily true of all systems. - - function Model (X : T) return T is - begin - return Machine (X); - end Model; - - ---------- - -- Pred -- - ---------- - - function Pred (X : T) return T is - X_Frac : T; - X_Exp : UI; - - begin - -- Zero has to be treated specially, since its exponent is zero - - if X = 0.0 then - return -Succ (X); - - -- Special treatment for most negative number - - elsif X = T'First then - - -- If not generating infinities, we raise a constraint error - - if T'Machine_Overflows then - raise Constraint_Error with "Pred of largest negative number"; - - -- Otherwise generate a negative infinity - - else - return X / (X - X); - end if; - - -- For infinities, return unchanged - - elsif X < T'First or else X > T'Last then - return X; - - -- Subtract from the given number a number equivalent to the value - -- of its least significant bit. Given that the most significant bit - -- represents a value of 1.0 * radix ** (exp - 1), the value we want - -- is obtained by shifting this by (mantissa-1) bits to the right, - -- i.e. decreasing the exponent by that amount. - - else - Decompose (X, X_Frac, X_Exp); - - -- A special case, if the number we had was a positive power of - -- two, then we want to subtract half of what we would otherwise - -- subtract, since the exponent is going to be reduced. - - -- Note that X_Frac has the same sign as X, so if X_Frac is 0.5, - -- then we know that we have a positive number (and hence a - -- positive power of 2). - - if X_Frac = 0.5 then - return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); - - -- Otherwise the exponent is unchanged - - else - return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa); - end if; - end if; - end Pred; - - --------------- - -- Remainder -- - --------------- - - function Remainder (X, Y : T) return T is - A : T; - B : T; - Arg : T; - P : T; - P_Frac : T; - Sign_X : T; - IEEE_Rem : T; - Arg_Exp : UI; - P_Exp : UI; - K : UI; - P_Even : Boolean; - - Arg_Frac : T; - pragma Unreferenced (Arg_Frac); - - begin - if Y = 0.0 then - raise Constraint_Error; - end if; - - if X > 0.0 then - Sign_X := 1.0; - Arg := X; - else - Sign_X := -1.0; - Arg := -X; - end if; - - P := abs Y; - - if Arg < P then - P_Even := True; - IEEE_Rem := Arg; - P_Exp := Exponent (P); - - else - Decompose (Arg, Arg_Frac, Arg_Exp); - Decompose (P, P_Frac, P_Exp); - - P := Compose (P_Frac, Arg_Exp); - K := Arg_Exp - P_Exp; - P_Even := True; - IEEE_Rem := Arg; - - for Cnt in reverse 0 .. K loop - if IEEE_Rem >= P then - P_Even := False; - IEEE_Rem := IEEE_Rem - P; - else - P_Even := True; - end if; - - P := P * 0.5; - end loop; - end if; - - -- That completes the calculation of modulus remainder. The final - -- step is get the IEEE remainder. Here we need to compare Rem with - -- (abs Y) / 2. We must be careful of unrepresentable Y/2 value - -- caused by subnormal numbers - - if P_Exp >= 0 then - A := IEEE_Rem; - B := abs Y * 0.5; - - else - A := IEEE_Rem * 2.0; - B := abs Y; - end if; - - if A > B or else (A = B and then not P_Even) then - IEEE_Rem := IEEE_Rem - abs Y; - end if; - - return Sign_X * IEEE_Rem; - end Remainder; - - -------------- - -- Rounding -- - -------------- - - function Rounding (X : T) return T is - Result : T; - Tail : T; - - begin - Result := Truncation (abs X); - Tail := abs X - Result; - - if Tail >= 0.5 then - Result := Result + 1.0; - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end Rounding; - - ------------- - -- Scaling -- - ------------- - - -- Return x * rad ** adjustment quickly, or quietly underflow to zero, - -- or overflow naturally. - - function Scaling (X : T; Adjustment : UI) return T is - begin - if X = 0.0 or else Adjustment = 0 then - return X; - end if; - - -- Nonzero x essentially, just multiply repeatedly by Rad ** (+-2**n) - - declare - Y : T := X; - Ex : UI := Adjustment; - - -- Y * Rad ** Ex is invariant - - begin - if Ex < 0 then - while Ex <= -Log_Power (Expbits'Last) loop - Y := Y * R_Neg_Power (Expbits'Last); - Ex := Ex + Log_Power (Expbits'Last); - end loop; - - -- -64 < Ex <= 0 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ex <= -Log_Power (N) then - Y := Y * R_Neg_Power (N); - Ex := Ex + Log_Power (N); - end if; - - -- -Log_Power (N) < Ex <= 0 - - end loop; - - -- Ex = 0 - - else - -- Ex >= 0 - - while Ex >= Log_Power (Expbits'Last) loop - Y := Y * R_Power (Expbits'Last); - Ex := Ex - Log_Power (Expbits'Last); - end loop; - - -- 0 <= Ex < 64 - - for N in reverse Expbits'First .. Expbits'Last - 1 loop - if Ex >= Log_Power (N) then - Y := Y * R_Power (N); - Ex := Ex - Log_Power (N); - end if; - - -- 0 <= Ex < Log_Power (N) - - end loop; - - -- Ex = 0 - - end if; - - return Y; - end; - end Scaling; - - ---------- - -- Succ -- - ---------- - - function Succ (X : T) return T is - X_Frac : T; - X_Exp : UI; - X1, X2 : T; - - begin - -- Treat zero specially since it has a zero exponent - - if X = 0.0 then - X1 := 2.0 ** T'Machine_Emin; - - -- Following loop generates smallest denormal - - loop - X2 := T'Machine (X1 / 2.0); - exit when X2 = 0.0; - X1 := X2; - end loop; - - return X1; - - -- Special treatment for largest positive number - - elsif X = T'Last then - - -- If not generating infinities, we raise a constraint error - - if T'Machine_Overflows then - raise Constraint_Error with "Succ of largest negative number"; - - -- Otherwise generate a positive infinity - - else - return X / (X - X); - end if; - - -- For infinities, return unchanged - - elsif X < T'First or else X > T'Last then - return X; - - -- Add to the given number a number equivalent to the value - -- of its least significant bit. Given that the most significant bit - -- represents a value of 1.0 * radix ** (exp - 1), the value we want - -- is obtained by shifting this by (mantissa-1) bits to the right, - -- i.e. decreasing the exponent by that amount. - - else - Decompose (X, X_Frac, X_Exp); - - -- A special case, if the number we had was a negative power of two, - -- then we want to add half of what we would otherwise add, since the - -- exponent is going to be reduced. - - -- Note that X_Frac has the same sign as X, so if X_Frac is -0.5, - -- then we know that we have a negative number (and hence a negative - -- power of 2). - - if X_Frac = -0.5 then - return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1); - - -- Otherwise the exponent is unchanged - - else - return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa); - end if; - end if; - end Succ; - - ---------------- - -- Truncation -- - ---------------- - - -- The basic approach is to compute - - -- T'Machine (RM1 + N) - RM1 - - -- where N >= 0.0 and RM1 = radix ** (mantissa - 1) - - -- This works provided that the intermediate result (RM1 + N) does not - -- have extra precision (which is why we call Machine). When we compute - -- RM1 + N, the exponent of N will be normalized and the mantissa shifted - -- appropriately so the lower order bits, which cannot contribute to the - -- integer part of N, fall off on the right. When we subtract RM1 again, - -- the significant bits of N are shifted to the left, and what we have is - -- an integer, because only the first e bits are different from zero - -- (assuming binary radix here). - - function Truncation (X : T) return T is - Result : T; - - begin - Result := abs X; - - if Result >= Radix_To_M_Minus_1 then - return Machine (X); - - else - Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1; - - if Result > abs X then - Result := Result - 1.0; - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end if; - end Truncation; - - ----------------------- - -- Unbiased_Rounding -- - ----------------------- - - function Unbiased_Rounding (X : T) return T is - Abs_X : constant T := abs X; - Result : T; - Tail : T; - - begin - Result := Truncation (Abs_X); - Tail := Abs_X - Result; - - if Tail > 0.5 then - Result := Result + 1.0; - - elsif Tail = 0.5 then - Result := 2.0 * Truncation ((Result / 2.0) + 0.5); - end if; - - if X > 0.0 then - return Result; - - elsif X < 0.0 then - return -Result; - - -- For zero case, make sure sign of zero is preserved - - else - return X; - end if; - end Unbiased_Rounding; - - ----------- - -- Valid -- - ----------- - - function Valid (X : not null access T) return Boolean is - IEEE_Emin : constant Integer := T'Machine_Emin - 1; - IEEE_Emax : constant Integer := T'Machine_Emax - 1; - - IEEE_Bias : constant Integer := -(IEEE_Emin - 1); - - subtype IEEE_Exponent_Range is - Integer range IEEE_Emin - 1 .. IEEE_Emax + 1; - - -- The implementation of this floating point attribute uses a - -- representation type Float_Rep that allows direct access to the - -- exponent and mantissa parts of a floating point number. - - -- The Float_Rep type is an array of Float_Word elements. This - -- representation is chosen to make it possible to size the type based - -- on a generic parameter. Since the array size is known at compile - -- time, efficient code can still be generated. The size of Float_Word - -- elements should be large enough to allow accessing the exponent in - -- one read, but small enough so that all floating point object sizes - -- are a multiple of the Float_Word'Size. - - -- The following conditions must be met for all possible instantiations - -- of the attributes package: - - -- - T'Size is an integral multiple of Float_Word'Size - - -- - The exponent and sign are completely contained in a single - -- component of Float_Rep, named Most_Significant_Word (MSW). - - -- - The sign occupies the most significant bit of the MSW and the - -- exponent is in the following bits. Unused bits (if any) are in - -- the least significant part. - - type Float_Word is mod 2**Positive'Min (System.Word_Size, 32); - type Rep_Index is range 0 .. 7; - - Rep_Words : constant Positive := - (T'Size + Float_Word'Size - 1) / Float_Word'Size; - Rep_Last : constant Rep_Index := - Rep_Index'Min - (Rep_Index (Rep_Words - 1), - (T'Mantissa + 16) / Float_Word'Size); - -- Determine the number of Float_Words needed for representing the - -- entire floating-point value. Do not take into account excessive - -- padding, as occurs on IA-64 where 80 bits floats get padded to 128 - -- bits. In general, the exponent field cannot be larger than 15 bits, - -- even for 128-bit floating-point types, so the final format size - -- won't be larger than T'Mantissa + 16. - - type Float_Rep is - array (Rep_Index range 0 .. Rep_Index (Rep_Words - 1)) of Float_Word; - - pragma Suppress_Initialization (Float_Rep); - -- This pragma suppresses the generation of an initialization procedure - -- for type Float_Rep when operating in Initialize/Normalize_Scalars - -- mode. This is not just a matter of efficiency, but of functionality, - -- since Valid has a pragma Inline_Always, which is not permitted if - -- there are nested subprograms present. - - Most_Significant_Word : constant Rep_Index := - Rep_Last * Standard'Default_Bit_Order; - -- Finding the location of the Exponent_Word is a bit tricky. In general - -- we assume Word_Order = Bit_Order. - - Exponent_Factor : constant Float_Word := - 2**(Float_Word'Size - 1) / - Float_Word (IEEE_Emax - IEEE_Emin + 3) * - Boolean'Pos (Most_Significant_Word /= 2) + - Boolean'Pos (Most_Significant_Word = 2); - -- Factor that the extracted exponent needs to be divided by to be in - -- range 0 .. IEEE_Emax - IEEE_Emin + 2. Special case: Exponent_Factor - -- is 1 for x86/IA64 double extended (GCC adds unused bits to the type). - - Exponent_Mask : constant Float_Word := - Float_Word (IEEE_Emax - IEEE_Emin + 2) * - Exponent_Factor; - -- Value needed to mask out the exponent field. This assumes that the - -- range IEEE_Emin - 1 .. IEEE_Emax + contains 2**N values, for some N - -- in Natural. - - function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T); - - type Float_Access is access all T; - function To_Address is - new Ada.Unchecked_Conversion (Float_Access, System.Address); - - XA : constant System.Address := To_Address (Float_Access (X)); - - R : Float_Rep; - pragma Import (Ada, R); - for R'Address use XA; - -- R is a view of the input floating-point parameter. Note that we - -- must avoid copying the actual bits of this parameter in float - -- form (since it may be a signalling NaN). - - E : constant IEEE_Exponent_Range := - Integer ((R (Most_Significant_Word) and Exponent_Mask) / - Exponent_Factor) - - IEEE_Bias; - -- Mask/Shift T to only get bits from the exponent. Then convert biased - -- value to integer value. - - SR : Float_Rep; - -- Float_Rep representation of significant of X.all - - begin - if T'Denorm then - - -- All denormalized numbers are valid, so the only invalid numbers - -- are overflows and NaNs, both with exponent = Emax + 1. - - return E /= IEEE_Emax + 1; - - end if; - - -- All denormalized numbers except 0.0 are invalid - - -- Set exponent of X to zero, so we end up with the significand, which - -- definitely is a valid number and can be converted back to a float. - - SR := R; - SR (Most_Significant_Word) := - (SR (Most_Significant_Word) - and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor; - - return (E in IEEE_Emin .. IEEE_Emax) or else - ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0); - end Valid; - -end System.Fat_Gen; diff --git a/gcc/ada/s-fatgen.ads b/gcc/ada/s-fatgen.ads deleted file mode 100644 index 88f641b..0000000 --- a/gcc/ada/s-fatgen.ads +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ G E N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This generic package provides a target independent implementation of the --- floating-point attributes that denote functions. The implementations here --- are portable, but very slow. The runtime contains a set of instantiations --- of this package for all predefined floating-point types, and these should --- be replaced by efficient assembly language code where possible. - -generic - type T is digits <>; - -package System.Fat_Gen is - pragma Pure; - - subtype UI is Integer; - -- The runtime representation of universal integer for the purposes of - -- this package is integer. The expander generates conversions for the - -- actual type used. For functions returning universal integer, there - -- is no problem, since the result always is in range of integer. For - -- input arguments, the expander has to do some special casing to deal - -- with the (very annoying) cases of out of range values. If we used - -- Long_Long_Integer to represent universal, then there would be no - -- problem, but the resulting inefficiency would be annoying. - - function Adjacent (X, Towards : T) return T; - - function Ceiling (X : T) return T; - - function Compose (Fraction : T; Exponent : UI) return T; - - function Copy_Sign (Value, Sign : T) return T; - - function Exponent (X : T) return UI; - - function Floor (X : T) return T; - - function Fraction (X : T) return T; - - function Leading_Part (X : T; Radix_Digits : UI) return T; - - function Machine (X : T) return T; - - function Machine_Rounding (X : T) return T; - - function Model (X : T) return T; - - function Pred (X : T) return T; - - function Remainder (X, Y : T) return T; - - function Rounding (X : T) return T; - - function Scaling (X : T; Adjustment : UI) return T; - - function Succ (X : T) return T; - - function Truncation (X : T) return T; - - function Unbiased_Rounding (X : T) return T; - - function Valid (X : not null access T) return Boolean; - -- This function checks if the object of type T referenced by X is valid, - -- and returns True/False accordingly. The parameter is passed by reference - -- (access) here, as the object of type T may be an abnormal value that - -- cannot be passed in a floating-point register, and the whole point of - -- 'Valid is to prevent exceptions. Note that the object of type T must - -- have the natural alignment for type T. - - type S is new String (1 .. T'Size / Character'Size); - type P is access all S with Storage_Size => 0; - -- Buffer and access types used to initialize temporaries for validity - -- checks, if the value to be checked has reverse scalar storage order, or - -- is not known to be properly aligned (for example it appears in a packed - -- record). In this case, we cannot call Valid since Valid assumes proper - -- full alignment. Instead, we copy the value to a temporary location using - -- type S (we cannot simply do a copy of a T value, because the value might - -- be invalid, in which case it might not be possible to copy it through a - -- floating point register). - -private - pragma Inline (Machine); - pragma Inline (Model); - - -- Note: previously the validity checking subprograms (Unaligned_Valid and - -- Valid) were also inlined, but this was changed since there were some - -- problems with this inlining in optimized mode, and in any case it seems - -- better to avoid this inlining (space and robustness considerations). - -end System.Fat_Gen; diff --git a/gcc/ada/s-fatlfl.ads b/gcc/ada/s-fatlfl.ads deleted file mode 100644 index 1f5cd5e..0000000 --- a/gcc/ada/s-fatlfl.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ L F L T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for the type Long_Float. - -with System.Fat_Gen; - -package System.Fat_LFlt is - pragma Pure; - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_Long_Float is new System.Fat_Gen (Long_Float); - -end System.Fat_LFlt; diff --git a/gcc/ada/s-fatllf.ads b/gcc/ada/s-fatllf.ads deleted file mode 100644 index 03dee60..0000000 --- a/gcc/ada/s-fatllf.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ L L F -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for the type Long_Long_Float. - -with System.Fat_Gen; - -package System.Fat_LLF is - pragma Pure; - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_Long_Long_Float is new System.Fat_Gen (Long_Long_Float); - -end System.Fat_LLF; diff --git a/gcc/ada/s-fatsfl.ads b/gcc/ada/s-fatsfl.ads deleted file mode 100644 index 63f3a43..0000000 --- a/gcc/ada/s-fatsfl.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F A T _ S F L T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the floating-point attribute --- runtime routines for the type Short_Float. - -with System.Fat_Gen; - -package System.Fat_SFlt is - pragma Pure; - - -- Note the only entity from this package that is accessed by Rtsfind - -- is the name of the package instantiation. Entities within this package - -- (i.e. the individual floating-point attribute routines) are accessed - -- by name using selected notation. - - package Attr_Short_Float is new System.Fat_Gen (Short_Float); - -end System.Fat_SFlt; diff --git a/gcc/ada/s-ficobl.ads b/gcc/ada/s-ficobl.ads deleted file mode 100644 index a3b4bcf..0000000 --- a/gcc/ada/s-ficobl.ads +++ /dev/null @@ -1,159 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F I L E _ C O N T R O L _ B L O C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the declaration of the basic file control block --- shared between Text_IO, Sequential_IO, Direct_IO and Streams.Stream_IO. --- The actual control blocks are derived from this block by extension. The --- control block is itself derived from Ada.Streams.Root_Stream_Type which --- facilitates implementation of Stream_IO.Stream and Text_Streams.Stream. - -with Ada.Streams; -with Interfaces.C_Streams; -with System.CRTL; - -package System.File_Control_Block is - pragma Preelaborate; - - ---------------------------- - -- Ada File Control Block -- - ---------------------------- - - -- The Ada file control block is an abstract extension of the root - -- stream type. This allows a file to be treated directly as a stream - -- for the purposes of Stream_IO, or stream operations on a text file. - -- The individual I/O packages extend this type with package specific - -- fields to create the concrete types to which the routines in this - -- package can be applied. - - -- The type File_Type in the individual packages is an access to the - -- extended file control block. The value is null if the file is not - -- open, and a pointer to the control block if the file is open. - - type Pstring is access all String; - -- Used to hold name and form strings - - type File_Mode is (In_File, Inout_File, Out_File, Append_File); - subtype Read_File_Mode is File_Mode range In_File .. Inout_File; - -- File mode (union of file modes permitted by individual packages, - -- the types File_Mode in the individual packages are declared to - -- allow easy conversion to and from this general type. - - type Shared_Status_Type is (Yes, No, None); - -- This type is used to define the sharing status of a file. The default - -- setting of None is used if no "shared=xxx" appears in the form string - -- when a file is created or opened. For a file with Shared_Status set to - -- None, Use_Error will be raised if any other file is opened or created - -- with the same full name. Yes/No are set in response to the presence - -- of "shared=yes" or "shared=no" in the form string. In either case it - -- is permissible to have multiple files opened with the same full name. - -- All files opened simultaneously with "shared=yes" will share the same - -- stream with the semantics specified in the RM for file sharing. All - -- files opened with "shared=no" will have their own stream. - - type AFCB is tagged; - type AFCB_Ptr is access all AFCB'Class; - - type AFCB is abstract new Ada.Streams.Root_Stream_Type with record - - Stream : Interfaces.C_Streams.FILEs; - -- The file descriptor - - Name : Pstring; - -- A pointer to the file name. The file name is null for temporary - -- files, and also for standard files (stdin, stdout, stderr). The - -- name is always NUL-terminated if it is non-null. - - Encoding : System.CRTL.Filename_Encoding; - -- Encoding used to specified the filename - - Form : Pstring; - -- A pointer to the form string. This is the string used in the - -- fopen call, and must be supplied by the caller (there are no - -- defaults at this level). The string is always null-terminated. - - Mode : File_Mode; - -- The file mode. No checks are made that the mode is consistent - -- with the form used to fopen the file. - - Is_Regular_File : Boolean; - -- A flag indicating if the file is a regular file - - Is_Temporary_File : Boolean; - -- A flag set only for temporary files (i.e. files created using the - -- Create function with a null name parameter). - - Is_System_File : Boolean; - -- A flag set only for system files (stdin, stdout, stderr) - - Text_Encoding : Interfaces.C_Streams.Content_Encoding; - -- A flag set to describe file content encoding - - Shared_Status : Shared_Status_Type; - -- Indicates sharing status of file, see description of type above - - Access_Method : Character; - -- Set to 'Q', 'S', 'T', 'D' for Sequential_IO, Stream_IO, Text_IO, - -- Direct_IO file (used to validate file sharing request). - - Next : AFCB_Ptr; - Prev : AFCB_Ptr; - -- All open files are kept on a doubly linked chain, with these - -- pointers used to maintain the next and previous pointers. - - end record; - - ---------------------------------- - -- Primitive Operations of AFCB -- - ---------------------------------- - - -- Note that we inherit the abstract operations Read and Write from - -- the base type. These must be overridden by the individual file - -- access methods to provide Stream Read/Write access. - - function AFCB_Allocate (Control_Block : AFCB) return AFCB_Ptr is abstract; - -- Given a control block, allocate space for a control block of the same - -- type on the heap, and return the pointer to this allocated block. Note - -- that the argument Control_Block is not used other than as the argument - -- that controls which version of AFCB_Allocate is called. - - procedure AFCB_Close (File : not null access AFCB) is abstract; - -- Performs any specialized close actions on a file before the file is - -- actually closed at the system level. This is called by Close, and - -- the reason we need the primitive operation is for the automatic - -- close operations done as part of finalization. - - procedure AFCB_Free (File : not null access AFCB) is abstract; - -- Frees the AFCB referenced by the given parameter. It is not necessary - -- to free the strings referenced by the Form and Name fields, but if the - -- extension has any other heap objects, they must be freed as well. This - -- procedure must be overridden by each individual file package. - -end System.File_Control_Block; diff --git a/gcc/ada/s-filatt.ads b/gcc/ada/s-filatt.ads deleted file mode 100644 index ba23e36..0000000 --- a/gcc/ada/s-filatt.ads +++ /dev/null @@ -1,71 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F I L E _ A T T R I B U T E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 binding to the GNAT file attribute query functions - -with System.OS_Constants; -with System.Storage_Elements; - -package System.File_Attributes is - - type File_Attributes is private; - - procedure Reset_Attributes (A : access File_Attributes); - - function Error_Attributes (A : access File_Attributes) return Integer; - - function File_Exists_Attr - (N : System.Address; - A : access File_Attributes) return Integer; - - function Is_Regular_File_Attr - (N : System.Address; - A : access File_Attributes) return Integer; - - function Is_Directory_Attr - (N : System.Address; - A : access File_Attributes) return Integer; - -private - package SOSC renames System.OS_Constants; - - type File_Attributes is new - System.Storage_Elements.Storage_Array - (1 .. SOSC.SIZEOF_struct_file_attributes); - for File_Attributes'Alignment use Standard'Maximum_Alignment; - - pragma Import (C, Reset_Attributes, "__gnat_reset_attributes"); - pragma Import (C, Error_Attributes, "__gnat_error_attributes"); - pragma Import (C, File_Exists_Attr, "__gnat_file_exists_attr"); - pragma Import (C, Is_Regular_File_Attr, "__gnat_is_regular_file_attr"); - pragma Import (C, Is_Directory_Attr, "__gnat_is_directory_attr"); - -end System.File_Attributes; diff --git a/gcc/ada/s-fileio.adb b/gcc/ada/s-fileio.adb deleted file mode 100644 index c8b44bd..0000000 --- a/gcc/ada/s-fileio.adb +++ /dev/null @@ -1,1322 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F I L E _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Finalization; use Ada.Finalization; -with Ada.IO_Exceptions; use Ada.IO_Exceptions; -with Ada.Unchecked_Deallocation; - -with Interfaces.C_Streams; use Interfaces.C_Streams; - -with System.Case_Util; use System.Case_Util; -with System.CRTL; -with System.OS_Lib; -with System.Soft_Links; - -package body System.File_IO is - - use System.File_Control_Block; - - package SSL renames System.Soft_Links; - - use type CRTL.size_t; - - ---------------------- - -- Global Variables -- - ---------------------- - - Open_Files : AFCB_Ptr; - -- This points to a list of AFCB's for all open files. This is a doubly - -- linked list, with the Prev pointer of the first entry, and the Next - -- pointer of the last entry containing null. Note that this global - -- variable must be properly protected to provide thread safety. - - type Temp_File_Record; - type Temp_File_Record_Ptr is access all Temp_File_Record; - - type Temp_File_Record is record - File : AFCB_Ptr; - Next : aliased Temp_File_Record_Ptr; - Name : String (1 .. max_path_len + 1); - end record; - -- One of these is allocated for each temporary file created - - Temp_Files : aliased Temp_File_Record_Ptr; - -- Points to list of names of temporary files. Note that this global - -- variable must be properly protected to provide thread safety. - - procedure Free is new Ada.Unchecked_Deallocation - (Temp_File_Record, Temp_File_Record_Ptr); - - type File_IO_Clean_Up_Type is new Limited_Controlled with null record; - -- The closing of all open files and deletion of temporary files is an - -- action that takes place at the end of execution of the main program. - -- This action is implemented using a library level object that gets - -- finalized at the end of program execution. Note that the type is - -- limited, in order to stop the compiler optimizing away the declaration - -- which would be allowed in the non-limited case. - - procedure Finalize (V : in out File_IO_Clean_Up_Type); - -- This is the finalize operation that is used to do the cleanup - - File_IO_Clean_Up_Object : File_IO_Clean_Up_Type; - pragma Warnings (Off, File_IO_Clean_Up_Object); - -- This is the single object of the type that triggers the finalization - -- call. Since it is at the library level, this happens just before the - -- environment task is finalized. - - text_translation_required : Boolean; - for text_translation_required'Size use Character'Size; - pragma Import - (C, text_translation_required, "__gnat_text_translation_required"); - -- If true, add appropriate suffix to control string for Open - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Free_String is new Ada.Unchecked_Deallocation (String, Pstring); - - subtype Fopen_String is String (1 .. 4); - -- Holds open string (longest is "w+b" & nul) - - procedure Fopen_Mode - (Namestr : String; - Mode : File_Mode; - Text : Boolean; - Creat : Boolean; - Amethod : Character; - Fopstr : out Fopen_String); - -- Determines proper open mode for a file to be opened in the given Ada - -- mode. Namestr is the NUL-terminated file name. Text is true for a text - -- file and false otherwise, and Creat is true for a create call, and False - -- for an open call. The value stored in Fopstr is a nul-terminated string - -- suitable for a call to fopen or freopen. Amethod is the character - -- designating the access method from the Access_Method field of the FCB. - - function Errno_Message - (Name : String; - Errno : Integer := OS_Lib.Errno) return String; - -- Return Errno_Message for Errno, with file name prepended - - procedure Raise_Device_Error - (File : AFCB_Ptr; - Errno : Integer := OS_Lib.Errno); - pragma No_Return (Raise_Device_Error); - -- Clear error indication on File and raise Device_Error with an exception - -- message providing errno information. - - ---------------- - -- Append_Set -- - ---------------- - - procedure Append_Set (File : AFCB_Ptr) is - begin - if File.Mode = Append_File then - if fseek (File.Stream, 0, SEEK_END) /= 0 then - Raise_Device_Error (File); - end if; - end if; - end Append_Set; - - ---------------- - -- Chain_File -- - ---------------- - - procedure Chain_File (File : AFCB_Ptr) is - begin - -- Take a task lock, to protect the global data value Open_Files - - SSL.Lock_Task.all; - - -- Do the chaining operation locked - - File.Next := Open_Files; - File.Prev := null; - Open_Files := File; - - if File.Next /= null then - File.Next.Prev := File; - end if; - - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Chain_File; - - --------------------- - -- Check_File_Open -- - --------------------- - - procedure Check_File_Open (File : AFCB_Ptr) is - begin - if File = null then - raise Status_Error with "file not open"; - end if; - end Check_File_Open; - - ----------------------- - -- Check_Read_Status -- - ----------------------- - - procedure Check_Read_Status (File : AFCB_Ptr) is - begin - if File = null then - raise Status_Error with "file not open"; - elsif File.Mode not in Read_File_Mode then - raise Mode_Error with "file not readable"; - end if; - end Check_Read_Status; - - ------------------------ - -- Check_Write_Status -- - ------------------------ - - procedure Check_Write_Status (File : AFCB_Ptr) is - begin - if File = null then - raise Status_Error with "file not open"; - elsif File.Mode = In_File then - raise Mode_Error with "file not writable"; - end if; - end Check_Write_Status; - - ----------- - -- Close -- - ----------- - - procedure Close (File_Ptr : access AFCB_Ptr) is - Close_Status : int := 0; - Dup_Strm : Boolean := False; - Errno : Integer := 0; - - File : AFCB_Ptr renames File_Ptr.all; - - begin - -- Take a task lock, to protect the global variables Open_Files and - -- Temp_Files, and the chains they point to. - - SSL.Lock_Task.all; - - Check_File_Open (File); - AFCB_Close (File); - - -- Sever the association between the given file and its associated - -- external file. The given file is left closed. Do not perform system - -- closes on the standard input, output and error files and also do not - -- attempt to close a stream that does not exist (signalled by a null - -- stream value -- happens in some error situations). - - if not File.Is_System_File and then File.Stream /= NULL_Stream then - - -- Do not do an fclose if this is a shared file and there is at least - -- one other instance of the stream that is open. - - if File.Shared_Status = Yes then - declare - P : AFCB_Ptr; - - begin - P := Open_Files; - while P /= null loop - if P /= File and then File.Stream = P.Stream then - Dup_Strm := True; - exit; - end if; - - P := P.Next; - end loop; - end; - end if; - - -- Do the fclose unless this was a duplicate in the shared case - - if not Dup_Strm then - Close_Status := fclose (File.Stream); - - if Close_Status /= 0 then - Errno := OS_Lib.Errno; - end if; - end if; - end if; - - -- Dechain file from list of open files and then free the storage - - if File.Prev = null then - Open_Files := File.Next; - else - File.Prev.Next := File.Next; - end if; - - if File.Next /= null then - File.Next.Prev := File.Prev; - end if; - - -- If it's a temp file, remove the corresponding record from Temp_Files, - -- and delete the file. There are unlikely to be large numbers of temp - -- files open, so a linear search is sufficiently efficient. Note that - -- we don't need to check for end of list, because the file must be - -- somewhere on the list. Note that as for Finalize, we ignore any - -- errors while attempting the unlink operation. - - if File.Is_Temporary_File then - declare - Temp : access Temp_File_Record_Ptr := Temp_Files'Access; - -- Note the double indirection here - - Discard : int; - New_Temp : Temp_File_Record_Ptr; - - begin - while Temp.all.all.File /= File loop - Temp := Temp.all.all.Next'Access; - end loop; - - Discard := unlink (Temp.all.all.Name'Address); - New_Temp := Temp.all.all.Next; - Free (Temp.all); - Temp.all := New_Temp; - end; - end if; - - -- Deallocate some parts of the file structure that were kept in heap - -- storage with the exception of system files (standard input, output - -- and error) since they had some information allocated in the stack. - - if not File.Is_System_File then - Free_String (File.Name); - Free_String (File.Form); - AFCB_Free (File); - end if; - - File := null; - - if Close_Status /= 0 then - Raise_Device_Error (null, Errno); - end if; - - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Close; - - ------------ - -- Delete -- - ------------ - - procedure Delete (File_Ptr : access AFCB_Ptr) is - File : AFCB_Ptr renames File_Ptr.all; - - begin - Check_File_Open (File); - - if not File.Is_Regular_File then - raise Use_Error with "cannot delete non-regular file"; - end if; - - declare - Filename : aliased constant String := File.Name.all; - Is_Temporary_File : constant Boolean := File.Is_Temporary_File; - - begin - Close (File_Ptr); - - -- Now unlink the external file. Note that we use the full name in - -- this unlink, because the working directory may have changed since - -- we did the open, and we want to unlink the right file. However, if - -- it's a temporary file, then closing it already unlinked it. - - if not Is_Temporary_File then - if unlink (Filename'Address) = -1 then - raise Use_Error with OS_Lib.Errno_Message; - end if; - end if; - end; - end Delete; - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File (File : AFCB_Ptr) return Boolean is - begin - Check_File_Open (File); - - if feof (File.Stream) /= 0 then - return True; - - else - Check_Read_Status (File); - - if ungetc (fgetc (File.Stream), File.Stream) = EOF then - clearerr (File.Stream); - return True; - else - return False; - end if; - end if; - end End_Of_File; - - ------------------- - -- Errno_Message -- - ------------------- - - function Errno_Message - (Name : String; - Errno : Integer := OS_Lib.Errno) return String - is - begin - return Name & ": " & OS_Lib.Errno_Message (Err => Errno); - end Errno_Message; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (V : in out File_IO_Clean_Up_Type) is - pragma Warnings (Off, V); - - Fptr1 : aliased AFCB_Ptr; - Fptr2 : AFCB_Ptr; - - Discard : int; - - begin - -- Take a lock to protect global Open_Files data structure - - SSL.Lock_Task.all; - - -- First close all open files (the slightly complex form of this loop is - -- required because Close nulls out its argument). - - Fptr1 := Open_Files; - while Fptr1 /= null loop - Fptr2 := Fptr1.Next; - Close (Fptr1'Access); - Fptr1 := Fptr2; - end loop; - - -- Now unlink all temporary files. We do not bother to free the blocks - -- because we are just about to terminate the program. We also ignore - -- any errors while attempting these unlink operations. - - while Temp_Files /= null loop - Discard := unlink (Temp_Files.Name'Address); - Temp_Files := Temp_Files.Next; - end loop; - - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Finalize; - - ----------- - -- Flush -- - ----------- - - procedure Flush (File : AFCB_Ptr) is - begin - Check_Write_Status (File); - - if fflush (File.Stream) /= 0 then - Raise_Device_Error (File); - end if; - end Flush; - - ---------------- - -- Fopen_Mode -- - ---------------- - - -- The fopen mode to be used is shown by the following table: - - -- OPEN CREATE - -- Append_File "r+" "w+" - -- In_File "r" "w+" - -- Out_File (Direct_IO, Stream_IO) "r+" [*] "w" - -- Out_File (others) "w" "w" - -- Inout_File "r+" "w+" - - -- [*] Except that for Out_File, if the file exists and is a fifo (i.e. a - -- named pipe), we use "w" instead of "r+". This is necessary to make a - -- write to the fifo block until a reader is ready. - - -- Note: we do not use "a" or "a+" for Append_File, since this would not - -- work in the case of stream files, where even if in append file mode, - -- you can reset to earlier points in the file. The caller must use the - -- Append_Set routine to deal with the necessary positioning. - - -- Note: in several cases, the fopen mode used allows reading and writing, - -- but the setting of the Ada mode is more restrictive. For instance, - -- Create in In_File mode uses "w+" which allows writing, but the Ada mode - -- In_File will cause any write operations to be rejected with Mode_Error - -- in any case. - - -- Note: for the Out_File/Open cases for other than the Direct_IO case, an - -- initial call will be made by the caller to first open the file in "r" - -- mode to be sure that it exists. The real open, in "w" mode, will then - -- destroy this file. This is peculiar, but that's what Ada semantics - -- require and the ACATS tests insist on. - - -- If text file translation is required, then either "b" or "t" is appended - -- to the mode, depending on the setting of Text. - - procedure Fopen_Mode - (Namestr : String; - Mode : File_Mode; - Text : Boolean; - Creat : Boolean; - Amethod : Character; - Fopstr : out Fopen_String) - is - Fptr : Positive; - - function is_fifo (Path : Address) return Integer; - pragma Import (C, is_fifo, "__gnat_is_fifo"); - - begin - case Mode is - when In_File => - if Creat then - Fopstr (1) := 'w'; - Fopstr (2) := '+'; - Fptr := 3; - else - Fopstr (1) := 'r'; - Fptr := 2; - end if; - - when Out_File => - if Amethod in 'D' | 'S' - and then not Creat - and then is_fifo (Namestr'Address) = 0 - then - Fopstr (1) := 'r'; - Fopstr (2) := '+'; - Fptr := 3; - else - Fopstr (1) := 'w'; - Fptr := 2; - end if; - - when Append_File - | Inout_File - => - Fopstr (1) := (if Creat then 'w' else 'r'); - Fopstr (2) := '+'; - Fptr := 3; - end case; - - -- If text_translation_required is true then we need to append either a - -- "t" or "b" to the string to get the right mode. - - if text_translation_required then - Fopstr (Fptr) := (if Text then 't' else 'b'); - Fptr := Fptr + 1; - end if; - - Fopstr (Fptr) := ASCII.NUL; - end Fopen_Mode; - - ---------- - -- Form -- - ---------- - - function Form (File : AFCB_Ptr) return String is - begin - if File = null then - raise Status_Error with "Form: file not open"; - else - return File.Form.all (1 .. File.Form'Length - 1); - end if; - end Form; - - ------------------ - -- Form_Boolean -- - ------------------ - - function Form_Boolean - (Form : String; - Keyword : String; - Default : Boolean) return Boolean - is - V1, V2 : Natural; - pragma Unreferenced (V2); - - begin - Form_Parameter (Form, Keyword, V1, V2); - - if V1 = 0 then - return Default; - elsif Form (V1) = 'y' then - return True; - elsif Form (V1) = 'n' then - return False; - else - raise Use_Error with "invalid Form"; - end if; - end Form_Boolean; - - ------------------ - -- Form_Integer -- - ------------------ - - function Form_Integer - (Form : String; - Keyword : String; - Default : Integer) return Integer - is - V1, V2 : Natural; - V : Integer; - - begin - Form_Parameter (Form, Keyword, V1, V2); - - if V1 = 0 then - return Default; - - else - V := 0; - - for J in V1 .. V2 loop - if Form (J) not in '0' .. '9' then - raise Use_Error with "invalid Form"; - else - V := V * 10 + Character'Pos (Form (J)) - Character'Pos ('0'); - end if; - - if V > 999_999 then - raise Use_Error with "invalid Form"; - end if; - end loop; - - return V; - end if; - end Form_Integer; - - -------------------- - -- Form_Parameter -- - -------------------- - - procedure Form_Parameter - (Form : String; - Keyword : String; - Start : out Natural; - Stop : out Natural) - is - Klen : constant Integer := Keyword'Length; - - begin - for J in Form'First + Klen .. Form'Last - 1 loop - if Form (J) = '=' - and then Form (J - Klen .. J - 1) = Keyword - then - Start := J + 1; - Stop := Start - 1; - while Form (Stop + 1) /= ASCII.NUL - and then Form (Stop + 1) /= ',' - loop - Stop := Stop + 1; - end loop; - - return; - end if; - end loop; - - Start := 0; - Stop := 0; - end Form_Parameter; - - ------------- - -- Is_Open -- - ------------- - - function Is_Open (File : AFCB_Ptr) return Boolean is - begin - -- We return True if the file is open, and the underlying file stream is - -- usable. In particular on Windows an application linked with -mwindows - -- option set does not have a console attached. In this case standard - -- files (Current_Output, Current_Error, Current_Input) are not created. - -- We want Is_Open (Current_Output) to return False in this case. - - return File /= null and then fileno (File.Stream) /= -1; - end Is_Open; - - ------------------- - -- Make_Buffered -- - ------------------- - - procedure Make_Buffered - (File : AFCB_Ptr; - Buf_Siz : Interfaces.C_Streams.size_t) - is - status : Integer; - pragma Unreferenced (status); - - begin - status := setvbuf (File.Stream, Null_Address, IOFBF, Buf_Siz); - end Make_Buffered; - - ------------------------ - -- Make_Line_Buffered -- - ------------------------ - - procedure Make_Line_Buffered - (File : AFCB_Ptr; - Line_Siz : Interfaces.C_Streams.size_t) - is - status : Integer; - pragma Unreferenced (status); - - begin - status := setvbuf (File.Stream, Null_Address, IOLBF, Line_Siz); - -- No error checking??? - end Make_Line_Buffered; - - --------------------- - -- Make_Unbuffered -- - --------------------- - - procedure Make_Unbuffered (File : AFCB_Ptr) is - status : Integer; - pragma Unreferenced (status); - - begin - status := setvbuf (File.Stream, Null_Address, IONBF, 0); - -- No error checking??? - end Make_Unbuffered; - - ---------- - -- Mode -- - ---------- - - function Mode (File : AFCB_Ptr) return File_Mode is - begin - if File = null then - raise Status_Error with "Mode: file not open"; - else - return File.Mode; - end if; - end Mode; - - ---------- - -- Name -- - ---------- - - function Name (File : AFCB_Ptr) return String is - begin - if File = null then - raise Status_Error with "Name: file not open"; - else - return File.Name.all (1 .. File.Name'Length - 1); - end if; - end Name; - - ---------- - -- Open -- - ---------- - - procedure Open - (File_Ptr : in out AFCB_Ptr; - Dummy_FCB : AFCB'Class; - Mode : File_Mode; - Name : String; - Form : String; - Amethod : Character; - Creat : Boolean; - Text : Boolean; - C_Stream : FILEs := NULL_Stream) - is - pragma Warnings (Off, Dummy_FCB); - -- Yes we know this is never assigned a value. That's intended, since - -- all we ever use of this value is the tag for dispatching purposes. - - procedure Tmp_Name (Buffer : Address); - pragma Import (C, Tmp_Name, "__gnat_tmp_name"); - -- Set buffer (a String address) with a temporary filename - - function Get_Case_Sensitive return Integer; - pragma Import (C, Get_Case_Sensitive, - "__gnat_get_file_names_case_sensitive"); - - procedure Record_AFCB; - -- Create and record new AFCB into the runtime, note that the - -- implementation uses the variables below which corresponds to the - -- status of the opened file. - - File_Names_Case_Sensitive : constant Boolean := Get_Case_Sensitive /= 0; - -- Set to indicate whether the operating system convention is for file - -- names to be case sensitive (e.g., in Unix, set True), or not case - -- sensitive (e.g., in Windows, set False). Declared locally to avoid - -- breaking the Preelaborate rule that disallows function calls at the - -- library level. - - Stream : FILEs := C_Stream; - -- Stream which we open in response to this request - - Shared : Shared_Status_Type; - -- Setting of Shared_Status field for file - - Fopstr : aliased Fopen_String; - -- Mode string used in fopen call - - Formstr : aliased String (1 .. Form'Length + 1); - -- Form string with ASCII.NUL appended, folded to lower case - - Text_Encoding : Content_Encoding; - - Tempfile : constant Boolean := Name = ""; - -- Indicates temporary file case, which is indicated by an empty file - -- name. - - Namelen : constant Integer := max_path_len; - -- Length required for file name, not including final ASCII.NUL. - -- Note that we used to reference L_tmpnam here, which is not reliable - -- since __gnat_tmp_name does not always use tmpnam. - - Namestr : aliased String (1 .. Namelen + 1); - -- Name as given or temporary file name with ASCII.NUL appended - - Fullname : aliased String (1 .. max_path_len + 1); - -- Full name (as required for Name function, and as stored in the - -- control block in the Name field) with ASCII.NUL appended. - - Full_Name_Len : Integer; - -- Length of name actually stored in Fullname - - Encoding : CRTL.Filename_Encoding; - -- Filename encoding specified into the form parameter - - ----------------- - -- Record_AFCB -- - ----------------- - - procedure Record_AFCB is - begin - File_Ptr := AFCB_Allocate (Dummy_FCB); - - -- Note that we cannot use an aggregate here as File_Ptr is a - -- class-wide access to a limited type (Root_Stream_Type). - - File_Ptr.Is_Regular_File := is_regular_file (fileno (Stream)) /= 0; - File_Ptr.Is_System_File := False; - File_Ptr.Text_Encoding := Text_Encoding; - File_Ptr.Shared_Status := Shared; - File_Ptr.Access_Method := Amethod; - File_Ptr.Stream := Stream; - File_Ptr.Form := new String'(Formstr); - File_Ptr.Name := new String'(Fullname - (1 .. Full_Name_Len)); - File_Ptr.Mode := Mode; - File_Ptr.Is_Temporary_File := Tempfile; - File_Ptr.Encoding := Encoding; - - Chain_File (File_Ptr); - Append_Set (File_Ptr); - end Record_AFCB; - - -- Start of processing for Open - - begin - if File_Ptr /= null then - raise Status_Error with "file already open"; - end if; - - -- Acquire form string, setting required NUL terminator - - Formstr (1 .. Form'Length) := Form; - Formstr (Formstr'Last) := ASCII.NUL; - - -- Convert form string to lower case - - for J in Formstr'Range loop - if Formstr (J) in 'A' .. 'Z' then - Formstr (J) := Character'Val (Character'Pos (Formstr (J)) + 32); - end if; - end loop; - - -- Acquire setting of shared parameter - - declare - V1, V2 : Natural; - - begin - Form_Parameter (Formstr, "shared", V1, V2); - - if V1 = 0 then - Shared := None; - elsif Formstr (V1 .. V2) = "yes" then - Shared := Yes; - elsif Formstr (V1 .. V2) = "no" then - Shared := No; - else - raise Use_Error with "invalid Form"; - end if; - end; - - -- Acquire setting of encoding parameter - - declare - V1, V2 : Natural; - - begin - Form_Parameter (Formstr, "encoding", V1, V2); - - if V1 = 0 then - Encoding := CRTL.Unspecified; - elsif Formstr (V1 .. V2) = "utf8" then - Encoding := CRTL.UTF8; - elsif Formstr (V1 .. V2) = "8bits" then - Encoding := CRTL.ASCII_8bits; - else - raise Use_Error with "invalid Form"; - end if; - end; - - -- Acquire setting of text_translation parameter. Only needed if this is - -- a [Wide_[Wide_]]Text_IO file, in which case we default to True, but - -- if the Form says Text_Translation=No, we use binary mode, so new-line - -- will be just LF, even on Windows. - - if Text then - Text_Encoding := Default_Text; - else - Text_Encoding := None; - end if; - - if Text_Encoding in Text_Content_Encoding then - declare - V1, V2 : Natural; - - begin - Form_Parameter (Formstr, "text_translation", V1, V2); - - if V1 = 0 then - null; - elsif Formstr (V1 .. V2) = "no" then - Text_Encoding := None; - elsif Formstr (V1 .. V2) = "text" - or else Formstr (V1 .. V2) = "yes" - then - Text_Encoding := Interfaces.C_Streams.Text; - elsif Formstr (V1 .. V2) = "wtext" then - Text_Encoding := Wtext; - elsif Formstr (V1 .. V2) = "u8text" then - Text_Encoding := U8text; - elsif Formstr (V1 .. V2) = "u16text" then - Text_Encoding := U16text; - else - raise Use_Error with "invalid Form"; - end if; - end; - end if; - - -- If we were given a stream (call from xxx.C_Streams.Open), then set - -- the full name to the given one, and skip to end of processing. - - if Stream /= NULL_Stream then - Full_Name_Len := Name'Length + 1; - Fullname (1 .. Full_Name_Len - 1) := Name; - Fullname (Full_Name_Len) := ASCII.NUL; - - -- Normal case of Open or Create - - else - -- If temporary file case, get temporary file name and add to the - -- list of temporary files to be deleted on exit. - - if Tempfile then - if not Creat then - raise Name_Error with "opening temp file without creating it"; - end if; - - Tmp_Name (Namestr'Address); - - if Namestr (1) = ASCII.NUL then - raise Use_Error with "invalid temp file name"; - end if; - - -- Normal case of non-empty name given (i.e. not a temp file) - - else - if Name'Length > Namelen then - raise Name_Error with "file name too long"; - end if; - - Namestr (1 .. Name'Length) := Name; - Namestr (Name'Length + 1) := ASCII.NUL; - end if; - - -- Get full name in accordance with the advice of RM A.8.2(22) - - full_name (Namestr'Address, Fullname'Address); - - if Fullname (1) = ASCII.NUL then - raise Use_Error with Errno_Message (Name); - end if; - - Full_Name_Len := 1; - while Full_Name_Len < Fullname'Last - and then Fullname (Full_Name_Len) /= ASCII.NUL - loop - Full_Name_Len := Full_Name_Len + 1; - end loop; - - -- Fullname is generated by calling system's full_name. The problem - -- is, full_name does nothing about the casing, so a file name - -- comparison may generally speaking not be valid on non-case- - -- sensitive systems, and in particular we get unexpected failures - -- on Windows/Vista because of this. So we use s-casuti to force - -- the name to lower case. - - if not File_Names_Case_Sensitive then - To_Lower (Fullname (1 .. Full_Name_Len)); - end if; - - -- If Shared=None or Shared=Yes, then check for the existence of - -- another file with exactly the same full name. - - if Shared /= No then - declare - P : AFCB_Ptr; - - begin - -- Take a task lock to protect Open_Files - - SSL.Lock_Task.all; - - -- Search list of open files - - P := Open_Files; - while P /= null loop - if Fullname (1 .. Full_Name_Len) = P.Name.all then - - -- If we get a match, and either file has Shared=None, - -- then raise Use_Error, since we don't allow two files - -- of the same name to be opened unless they specify the - -- required sharing mode. - - if Shared = None - or else P.Shared_Status = None - then - raise Use_Error with "reopening shared file"; - - -- If both files have Shared=Yes, then we acquire the - -- stream from the located file to use as our stream. - - elsif Shared = Yes - and then P.Shared_Status = Yes - then - Stream := P.Stream; - - Record_AFCB; - pragma Assert (not Tempfile); - - exit; - - -- Otherwise one of the files has Shared=Yes and one has - -- Shared=No. If the current file has Shared=No then all - -- is well but we don't want to share any other file's - -- stream. If the current file has Shared=Yes, we would - -- like to share a stream, but not from a file that has - -- Shared=No, so either way, we just continue the search. - - else - null; - end if; - end if; - - P := P.Next; - end loop; - - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end; - end if; - - -- Open specified file if we did not find an existing stream, - -- otherwise we just return as there is nothing more to be done. - - if Stream /= NULL_Stream then - return; - - else - Fopen_Mode - (Namestr => Namestr, - Mode => Mode, - Text => Text_Encoding in Text_Content_Encoding, - Creat => Creat, - Amethod => Amethod, - Fopstr => Fopstr); - - -- A special case, if we are opening (OPEN case) a file and the - -- mode returned by Fopen_Mode is not "r" or "r+", then we first - -- make sure that the file exists as required by Ada semantics. - - if not Creat and then Fopstr (1) /= 'r' then - if file_exists (Namestr'Address) = 0 then - raise Name_Error with Errno_Message (Name); - end if; - end if; - - -- Now open the file. Note that we use the name as given in the - -- original Open call for this purpose, since that seems the - -- clearest implementation of the intent. It would presumably - -- work to use the full name here, but if there is any difference, - -- then we should use the name used in the call. - - -- Note: for a corresponding delete, we will use the full name, - -- since by the time of the delete, the current working directory - -- may have changed and we do not want to delete a different file. - - Stream := - fopen (Namestr'Address, Fopstr'Address, Encoding); - - if Stream = NULL_Stream then - - -- Raise Name_Error if trying to open a non-existent file. - -- Otherwise raise Use_Error. - - -- Should we raise Device_Error for ENOSPC??? - - declare - function Is_File_Not_Found_Error - (Errno_Value : Integer) return Integer; - pragma Import - (C, Is_File_Not_Found_Error, - "__gnat_is_file_not_found_error"); - -- Non-zero when the given errno value indicates a non- - -- existing file. - - Errno : constant Integer := OS_Lib.Errno; - Message : constant String := Errno_Message (Name, Errno); - - begin - if Is_File_Not_Found_Error (Errno) /= 0 then - raise Name_Error with Message; - else - raise Use_Error with Message; - end if; - end; - end if; - end if; - end if; - - -- Stream has been successfully located or opened, so now we are - -- committed to completing the opening of the file. Allocate block on - -- heap and fill in its fields. - - Record_AFCB; - - if Tempfile then - -- Chain to temp file list, ensuring thread safety with a lock - - begin - SSL.Lock_Task.all; - Temp_Files := - new Temp_File_Record' - (File => File_Ptr, Name => Namestr, Next => Temp_Files); - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end; - end if; - end Open; - - ------------------------ - -- Raise_Device_Error -- - ------------------------ - - procedure Raise_Device_Error - (File : AFCB_Ptr; - Errno : Integer := OS_Lib.Errno) - is - begin - -- Clear error status so that the same error is not reported twice - - if File /= null then - clearerr (File.Stream); - end if; - - raise Device_Error with OS_Lib.Errno_Message (Err => Errno); - end Raise_Device_Error; - - -------------- - -- Read_Buf -- - -------------- - - procedure Read_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is - Nread : size_t; - - begin - Nread := fread (Buf, 1, Siz, File.Stream); - - if Nread = Siz then - return; - - elsif ferror (File.Stream) /= 0 then - Raise_Device_Error (File); - - elsif Nread = 0 then - raise End_Error; - - else -- 0 < Nread < Siz - raise Data_Error with "not enough data read"; - end if; - end Read_Buf; - - procedure Read_Buf - (File : AFCB_Ptr; - Buf : Address; - Siz : Interfaces.C_Streams.size_t; - Count : out Interfaces.C_Streams.size_t) - is - begin - Count := fread (Buf, 1, Siz, File.Stream); - - if Count = 0 and then ferror (File.Stream) /= 0 then - Raise_Device_Error (File); - end if; - end Read_Buf; - - ----------- - -- Reset -- - ----------- - - -- The reset which does not change the mode simply does a rewind - - procedure Reset (File_Ptr : access AFCB_Ptr) is - File : AFCB_Ptr renames File_Ptr.all; - begin - Check_File_Open (File); - Reset (File_Ptr, File.Mode); - end Reset; - - -- The reset with a change in mode is done using freopen, and is not - -- permitted except for regular files (since otherwise there is no name for - -- the freopen, and in any case it seems meaningless). - - procedure Reset (File_Ptr : access AFCB_Ptr; Mode : File_Mode) is - File : AFCB_Ptr renames File_Ptr.all; - Fopstr : aliased Fopen_String; - - begin - Check_File_Open (File); - - -- Change of mode not allowed for shared file or file with no name or - -- file that is not a regular file, or for a system file. Note that we - -- allow the "change" of mode if it is not in fact doing a change. - - if Mode /= File.Mode then - if File.Shared_Status = Yes then - raise Use_Error with "cannot change mode of shared file"; - elsif File.Name'Length <= 1 then - raise Use_Error with "cannot change mode of temp file"; - elsif File.Is_System_File then - raise Use_Error with "cannot change mode of system file"; - elsif not File.Is_Regular_File then - raise Use_Error with "cannot change mode of non-regular file"; - end if; - end if; - - -- For In_File or Inout_File for a regular file, we can just do a rewind - -- if the mode is unchanged, which is more efficient than doing a full - -- reopen. - - if Mode = File.Mode - and then Mode in Read_File_Mode - then - rewind (File.Stream); - - -- Here the change of mode is permitted, we do it by reopening the file - -- in the new mode and replacing the stream with a new stream. - - else - Fopen_Mode - (Namestr => File.Name.all, - Mode => Mode, - Text => File.Text_Encoding in Text_Content_Encoding, - Creat => False, - Amethod => File.Access_Method, - Fopstr => Fopstr); - - File.Stream := freopen - (File.Name.all'Address, Fopstr'Address, File.Stream, - File.Encoding); - - if File.Stream = NULL_Stream then - Close (File_Ptr); - raise Use_Error; - else - File.Mode := Mode; - Append_Set (File); - end if; - end if; - end Reset; - - --------------- - -- Write_Buf -- - --------------- - - procedure Write_Buf (File : AFCB_Ptr; Buf : Address; Siz : size_t) is - begin - -- Note: for most purposes, the Siz and 1 parameters in the fwrite call - -- could be reversed, but we have encountered systems where this is a - -- better choice, since for some file formats, reversing the parameters - -- results in records of one byte each. - - SSL.Abort_Defer.all; - - if fwrite (Buf, Siz, 1, File.Stream) /= 1 then - if Siz /= 0 then - SSL.Abort_Undefer.all; - Raise_Device_Error (File); - end if; - end if; - - SSL.Abort_Undefer.all; - end Write_Buf; - -end System.File_IO; diff --git a/gcc/ada/s-fileio.ads b/gcc/ada/s-fileio.ads deleted file mode 100644 index f084d8d..0000000 --- a/gcc/ada/s-fileio.ads +++ /dev/null @@ -1,255 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F I L E _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides support for the routines described in (RM A.8.2) --- which are common to Text_IO, Direct_IO, Sequential_IO and Stream_IO. - -with Interfaces.C_Streams; - -with System.File_Control_Block; - -package System.File_IO is - pragma Preelaborate; - - package FCB renames System.File_Control_Block; - package ICS renames Interfaces.C_Streams; - - --------------------- - -- File Management -- - --------------------- - - procedure Open - (File_Ptr : in out FCB.AFCB_Ptr; - Dummy_FCB : FCB.AFCB'Class; - Mode : FCB.File_Mode; - Name : String; - Form : String; - Amethod : Character; - Creat : Boolean; - Text : Boolean; - C_Stream : ICS.FILEs := ICS.NULL_Stream); - -- This routine is used for both Open and Create calls: - -- - -- File_Ptr is the file type, which must be null on entry - -- (i.e. the file must be closed before the call). - -- - -- Dummy_FCB is a default initialized file control block of appropriate - -- type. Note that the tag of this record indicates the type and length - -- of the control block. This control block is used only for the purpose - -- of providing the controlling argument for calling the write version - -- of Allocate_AFCB. It has no other purpose, and its fields are never - -- read or written. - -- - -- Mode is the required mode - -- - -- Name is the file name, with a null string indicating that a temporary - -- file is to be created (only permitted in create mode, not open mode). - -- - -- Creat is True for a create call, and false for an open call - -- - -- Text is set True to open the file in text mode (w+t or r+t) instead - -- of the usual binary mode open (w+b or r+b). - -- - -- Form is the form string given in the open or create call, this is - -- stored in the AFCB. - -- - -- Amethod indicates the access method: - -- - -- D = Direct_IO - -- Q = Sequential_IO - -- S = Stream_IO - -- T = Text_IO - -- W = Wide_Text_IO - -- ??? Wide_Wide_Text_IO ??? - -- - -- C_Stream is left at its default value for the normal case of an - -- Open or Create call as defined in the RM. The only time this is - -- non-null is for the Open call from Ada.xxx_IO.C_Streams.Open. - -- - -- On return, if the open/create succeeds, then the fields of File are - -- filled in, and this value is copied to the heap. File_Ptr points to - -- this allocated file control block. If the open/create fails, then the - -- fields of File are undefined, and File_Ptr is unchanged. - - procedure Close (File_Ptr : access FCB.AFCB_Ptr); - -- The file is closed, all storage associated with it is released, and - -- File is set to null. Note that this routine calls AFCB_Close to perform - -- any specialized close actions, then closes the file at the system level, - -- then frees the mode and form strings, and finally calls AFCB_Free to - -- free the file control block itself, setting File.all to null. Note that - -- for this assignment to be done in all cases, including those where - -- an exception is raised, we can't use an IN OUT parameter (which would - -- not be copied back in case of abnormal return). - - procedure Delete (File_Ptr : access FCB.AFCB_Ptr); - -- The indicated file is unlinked - - procedure Reset (File_Ptr : access FCB.AFCB_Ptr; Mode : FCB.File_Mode); - -- The file is reset, and the mode changed as indicated - - procedure Reset (File_Ptr : access FCB.AFCB_Ptr); - -- The files is reset, and the mode is unchanged - - function Mode (File : FCB.AFCB_Ptr) return FCB.File_Mode; - -- Returns the mode as supplied by create, open or reset - - function Name (File : FCB.AFCB_Ptr) return String; - -- Returns the file name as supplied by Open or Create. Raises Use_Error - -- if used with temporary files or standard files. - - function Form (File : FCB.AFCB_Ptr) return String; - -- Returns the form as supplied by create, open or reset The string is - -- normalized to all lower case letters. - - function Is_Open (File : FCB.AFCB_Ptr) return Boolean; - -- Determines if file is open or not - - ---------------------- - -- Utility Routines -- - ---------------------- - - -- Some internal routines not defined in A.8.2. These are routines which - -- provide required common functionality shared by separate packages. - - procedure Chain_File (File : FCB.AFCB_Ptr); - -- Used to chain the given file into the list of open files. Normally this - -- is done implicitly by Open. Chain_File is used for the special cases of - -- the system files defined by Text_IO (stdin, stdout, stderr) which are - -- not opened in the normal manner. Note that the caller is responsible - -- for task lock out to protect the global data structures if this is - -- necessary (it is needed for the calls from within this unit itself, - -- but not required for the calls from Text_IO and [Wide_]Wide_Text_IO - -- that are made during elaboration of the environment task). - - procedure Check_File_Open (File : FCB.AFCB_Ptr); - -- If the current file is not open, then Status_Error is raised. Otherwise - -- control returns normally (with File pointing to the control block for - -- the open file. - - procedure Check_Read_Status (File : FCB.AFCB_Ptr); - -- If the current file is not open, then Status_Error is raised. If the - -- file is open, then the mode is checked to make sure that reading is - -- permitted, and if not Mode_Error is raised, otherwise control returns - -- normally. - - procedure Check_Write_Status (File : FCB.AFCB_Ptr); - -- If the current file is not open, then Status_Error is raised. If the - -- file is open, then the mode is checked to ensure that writing is - -- permitted, and if not Mode_Error is raised, otherwise control returns - -- normally. - - function End_Of_File (File : FCB.AFCB_Ptr) return Boolean; - -- File must be opened in read mode. True is returned if the stream is - -- currently positioned at the end of file, otherwise False is returned. - -- The position of the stream is not affected. - - procedure Flush (File : FCB.AFCB_Ptr); - -- Flushes the stream associated with the given file. The file must be open - -- and in write mode (if not, an appropriate exception is raised) - - function Form_Boolean - (Form : String; - Keyword : String; - Default : Boolean) return Boolean; - -- Searches form string for an entry of the form keyword=xx where xx is - -- either yes/no or y/n. Returns True if yes or y is found, False if no or - -- n is found. If the keyword parameter is not found, returns the value - -- given as Default. May raise Use_Error if a form string syntax error is - -- detected. Keyword and Form must be in lower case. - - function Form_Integer - (Form : String; - Keyword : String; - Default : Integer) return Integer; - -- Searches form string for an entry of the form Keyword=xx where xx is an - -- unsigned decimal integer in the range 0 to 999_999. Returns this integer - -- value if it is found. If the keyword parameter is not found, returns the - -- value given as Default. Raise Use_Error if a form string syntax error is - -- detected. Keyword and Form must be in lower case. - - procedure Form_Parameter - (Form : String; - Keyword : String; - Start : out Natural; - Stop : out Natural); - -- Searches form string for an entry of the form Keyword=xx and if found - -- Sets Start and Stop to the first and last characters of xx. Keyword - -- and Form must be in lower case. If no entry matches, then Start and - -- Stop are set to zero on return. Use_Error is raised if a malformed - -- string is detected, but there is no guarantee of full syntax checking. - - procedure Read_Buf - (File : FCB.AFCB_Ptr; - Buf : Address; - Siz : Interfaces.C_Streams.size_t); - -- Reads Siz bytes from File.Stream into Buf. The caller has checked - -- that the file is open in read mode. Raises an exception if Siz bytes - -- cannot be read (End_Error if no data was read, Data_Error if a partial - -- buffer was read, Device_Error if an error occurs). - - procedure Read_Buf - (File : FCB.AFCB_Ptr; - Buf : Address; - Siz : Interfaces.C_Streams.size_t; - Count : out Interfaces.C_Streams.size_t); - -- Reads Siz bytes from File.Stream into Buf. The caller has checked that - -- the file is open in read mode. Device Error is raised if an error - -- occurs. Count is the actual number of bytes read, which may be less - -- than Siz if the end of file is encountered. - - procedure Append_Set (File : FCB.AFCB_Ptr); - -- If the mode of the file is Append_File, then the file is positioned at - -- the end of file using fseek, otherwise this call has no effect. - - procedure Write_Buf - (File : FCB.AFCB_Ptr; - Buf : Address; - Siz : Interfaces.C_Streams.size_t); - -- Writes size_t bytes to File.Stream from Buf. The caller has checked that - -- the file is open in write mode. Raises Device_Error if the complete - -- buffer cannot be written. - - procedure Make_Unbuffered (File : FCB.AFCB_Ptr); - - procedure Make_Line_Buffered - (File : FCB.AFCB_Ptr; - Line_Siz : Interfaces.C_Streams.size_t); - - procedure Make_Buffered - (File : FCB.AFCB_Ptr; - Buf_Siz : Interfaces.C_Streams.size_t); - -private - pragma Inline (Check_Read_Status); - pragma Inline (Check_Write_Status); - pragma Inline (Mode); - -end System.File_IO; diff --git a/gcc/ada/s-finmas.adb b/gcc/ada/s-finmas.adb deleted file mode 100644 index c5ddff7..0000000 --- a/gcc/ada/s-finmas.adb +++ /dev/null @@ -1,554 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; use Ada.Exceptions; - -with System.Address_Image; -with System.HTable; use System.HTable; -with System.IO; use System.IO; -with System.Soft_Links; use System.Soft_Links; -with System.Storage_Elements; use System.Storage_Elements; - -package body System.Finalization_Masters is - - -- Finalize_Address hash table types. In general, masters are homogeneous - -- collections of controlled objects. Rare cases such as allocations on a - -- subpool require heterogeneous masters. The following table provides a - -- relation between object address and its Finalize_Address routine. - - type Header_Num is range 0 .. 127; - - function Hash (Key : System.Address) return Header_Num; - - -- Address --> Finalize_Address_Ptr - - package Finalize_Address_Table is new Simple_HTable - (Header_Num => Header_Num, - Element => Finalize_Address_Ptr, - No_Element => null, - Key => System.Address, - Hash => Hash, - Equal => "="); - - --------------------------- - -- Add_Offset_To_Address -- - --------------------------- - - function Add_Offset_To_Address - (Addr : System.Address; - Offset : System.Storage_Elements.Storage_Offset) return System.Address - is - begin - return System.Storage_Elements."+" (Addr, Offset); - end Add_Offset_To_Address; - - ------------ - -- Attach -- - ------------ - - procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is - begin - Lock_Task.all; - Attach_Unprotected (N, L); - Unlock_Task.all; - - -- Note: No need to unlock in case of an exception because the above - -- code can never raise one. - end Attach; - - ------------------------ - -- Attach_Unprotected -- - ------------------------ - - procedure Attach_Unprotected - (N : not null FM_Node_Ptr; - L : not null FM_Node_Ptr) - is - begin - L.Next.Prev := N; - N.Next := L.Next; - L.Next := N; - N.Prev := L; - end Attach_Unprotected; - - --------------- - -- Base_Pool -- - --------------- - - function Base_Pool - (Master : Finalization_Master) return Any_Storage_Pool_Ptr - is - begin - return Master.Base_Pool; - end Base_Pool; - - ----------------------------------------- - -- Delete_Finalize_Address_Unprotected -- - ----------------------------------------- - - procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is - begin - Finalize_Address_Table.Remove (Obj); - end Delete_Finalize_Address_Unprotected; - - ------------ - -- Detach -- - ------------ - - procedure Detach (N : not null FM_Node_Ptr) is - begin - Lock_Task.all; - Detach_Unprotected (N); - Unlock_Task.all; - - -- Note: No need to unlock in case of an exception because the above - -- code can never raise one. - end Detach; - - ------------------------ - -- Detach_Unprotected -- - ------------------------ - - procedure Detach_Unprotected (N : not null FM_Node_Ptr) is - begin - if N.Prev /= null and then N.Next /= null then - N.Prev.Next := N.Next; - N.Next.Prev := N.Prev; - N.Prev := null; - N.Next := null; - end if; - end Detach_Unprotected; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Master : in out Finalization_Master) is - Cleanup : Finalize_Address_Ptr; - Curr_Ptr : FM_Node_Ptr; - Ex_Occur : Exception_Occurrence; - Obj_Addr : Address; - Raised : Boolean := False; - - function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean; - -- Determine whether a list contains only one element, the dummy head - - ------------------- - -- Is_Empty_List -- - ------------------- - - function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is - begin - return L.Next = L and then L.Prev = L; - end Is_Empty_List; - - -- Start of processing for Finalize - - begin - Lock_Task.all; - - -- Synchronization: - -- Read - allocation, finalization - -- Write - finalization - - if Master.Finalization_Started then - Unlock_Task.all; - - -- Double finalization may occur during the handling of stand alone - -- libraries or the finalization of a pool with subpools. Due to the - -- potential aliasing of masters in these two cases, do not process - -- the same master twice. - - return; - end if; - - -- Lock the master to prevent any allocations while the objects are - -- being finalized. The master remains locked because either the master - -- is explicitly deallocated or the associated access type is about to - -- go out of scope. - - -- Synchronization: - -- Read - allocation, finalization - -- Write - finalization - - Master.Finalization_Started := True; - - while not Is_Empty_List (Master.Objects'Unchecked_Access) loop - Curr_Ptr := Master.Objects.Next; - - -- Synchronization: - -- Write - allocation, deallocation, finalization - - Detach_Unprotected (Curr_Ptr); - - -- Skip the list header in order to offer proper object layout for - -- finalization. - - Obj_Addr := Curr_Ptr.all'Address + Header_Size; - - -- Retrieve TSS primitive Finalize_Address depending on the master's - -- mode of operation. - - -- Synchronization: - -- Read - allocation, finalization - -- Write - outside - - if Master.Is_Homogeneous then - - -- Synchronization: - -- Read - finalization - -- Write - allocation, outside - - Cleanup := Master.Finalize_Address; - - else - -- Synchronization: - -- Read - finalization - -- Write - allocation, deallocation - - Cleanup := Finalize_Address_Unprotected (Obj_Addr); - end if; - - begin - Cleanup (Obj_Addr); - exception - when Fin_Occur : others => - if not Raised then - Raised := True; - Save_Occurrence (Ex_Occur, Fin_Occur); - end if; - end; - - -- When the master is a heterogeneous collection, destroy the object - -- - Finalize_Address pair since it is no longer needed. - - -- Synchronization: - -- Read - finalization - -- Write - outside - - if not Master.Is_Homogeneous then - - -- Synchronization: - -- Read - finalization - -- Write - allocation, deallocation, finalization - - Delete_Finalize_Address_Unprotected (Obj_Addr); - end if; - end loop; - - Unlock_Task.all; - - -- If the finalization of a particular object failed or Finalize_Address - -- was not set, reraise the exception now. - - if Raised then - Reraise_Occurrence (Ex_Occur); - end if; - end Finalize; - - ---------------------- - -- Finalize_Address -- - ---------------------- - - function Finalize_Address - (Master : Finalization_Master) return Finalize_Address_Ptr - is - begin - return Master.Finalize_Address; - end Finalize_Address; - - ---------------------------------- - -- Finalize_Address_Unprotected -- - ---------------------------------- - - function Finalize_Address_Unprotected - (Obj : System.Address) return Finalize_Address_Ptr - is - begin - return Finalize_Address_Table.Get (Obj); - end Finalize_Address_Unprotected; - - -------------------------- - -- Finalization_Started -- - -------------------------- - - function Finalization_Started - (Master : Finalization_Master) return Boolean - is - begin - return Master.Finalization_Started; - end Finalization_Started; - - ---------- - -- Hash -- - ---------- - - function Hash (Key : System.Address) return Header_Num is - begin - return - Header_Num - (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length)); - end Hash; - - ----------------- - -- Header_Size -- - ----------------- - - function Header_Size return System.Storage_Elements.Storage_Count is - begin - return FM_Node'Size / Storage_Unit; - end Header_Size; - - ---------------- - -- Initialize -- - ---------------- - - overriding procedure Initialize (Master : in out Finalization_Master) is - begin - -- The dummy head must point to itself in both directions - - Master.Objects.Next := Master.Objects'Unchecked_Access; - Master.Objects.Prev := Master.Objects'Unchecked_Access; - end Initialize; - - -------------------- - -- Is_Homogeneous -- - -------------------- - - function Is_Homogeneous (Master : Finalization_Master) return Boolean is - begin - return Master.Is_Homogeneous; - end Is_Homogeneous; - - ------------- - -- Objects -- - ------------- - - function Objects (Master : Finalization_Master) return FM_Node_Ptr is - begin - return Master.Objects'Unrestricted_Access; - end Objects; - - ------------------ - -- Print_Master -- - ------------------ - - procedure Print_Master (Master : Finalization_Master) is - Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access; - Head_Seen : Boolean := False; - N_Ptr : FM_Node_Ptr; - - begin - -- Output the basic contents of a master - - -- Master : 0x123456789 - -- Is_Hmgen : TURE FALSE - -- Base_Pool: null 0x123456789 - -- Fin_Addr : null 0x123456789 - -- Fin_Start: TRUE FALSE - - Put ("Master : "); - Put_Line (Address_Image (Master'Address)); - - Put ("Is_Hmgen : "); - Put_Line (Master.Is_Homogeneous'Img); - - Put ("Base_Pool: "); - if Master.Base_Pool = null then - Put_Line ("null"); - else - Put_Line (Address_Image (Master.Base_Pool'Address)); - end if; - - Put ("Fin_Addr : "); - if Master.Finalize_Address = null then - Put_Line ("null"); - else - Put_Line (Address_Image (Master.Finalize_Address'Address)); - end if; - - Put ("Fin_Start: "); - Put_Line (Master.Finalization_Started'Img); - - -- Output all chained elements. The format is the following: - - -- ^ ? null - -- |Header: 0x123456789 (dummy head) - -- | Prev: 0x123456789 - -- | Next: 0x123456789 - -- V - - -- ^ - the current element points back to the correct element - -- ? - the current element points back to an erroneous element - -- n - the current element points back to null - - -- Header - the address of the list header - -- Prev - the address of the list header which the current element - -- points back to - -- Next - the address of the list header which the current element - -- points to - -- (dummy head) - present if dummy head - - N_Ptr := Head; - while N_Ptr /= null loop -- Should never be null - Put_Line ("V"); - - -- We see the head initially; we want to exit when we see the head a - -- second time. - - if N_Ptr = Head then - exit when Head_Seen; - - Head_Seen := True; - end if; - - -- The current element is null. This should never happen since the - -- list is circular. - - if N_Ptr.Prev = null then - Put_Line ("null (ERROR)"); - - -- The current element points back to the correct element - - elsif N_Ptr.Prev.Next = N_Ptr then - Put_Line ("^"); - - -- The current element points to an erroneous element - - else - Put_Line ("? (ERROR)"); - end if; - - -- Output the header and fields - - Put ("|Header: "); - Put (Address_Image (N_Ptr.all'Address)); - - -- Detect the dummy head - - if N_Ptr = Head then - Put_Line (" (dummy head)"); - else - Put_Line (""); - end if; - - Put ("| Prev: "); - - if N_Ptr.Prev = null then - Put_Line ("null"); - else - Put_Line (Address_Image (N_Ptr.Prev.all'Address)); - end if; - - Put ("| Next: "); - - if N_Ptr.Next = null then - Put_Line ("null"); - else - Put_Line (Address_Image (N_Ptr.Next.all'Address)); - end if; - - N_Ptr := N_Ptr.Next; - end loop; - end Print_Master; - - ------------------- - -- Set_Base_Pool -- - ------------------- - - procedure Set_Base_Pool - (Master : in out Finalization_Master; - Pool_Ptr : Any_Storage_Pool_Ptr) - is - begin - Master.Base_Pool := Pool_Ptr; - end Set_Base_Pool; - - -------------------------- - -- Set_Finalize_Address -- - -------------------------- - - procedure Set_Finalize_Address - (Master : in out Finalization_Master; - Fin_Addr_Ptr : Finalize_Address_Ptr) - is - begin - -- Synchronization: - -- Read - finalization - -- Write - allocation, outside - - Lock_Task.all; - Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr); - Unlock_Task.all; - end Set_Finalize_Address; - - -------------------------------------- - -- Set_Finalize_Address_Unprotected -- - -------------------------------------- - - procedure Set_Finalize_Address_Unprotected - (Master : in out Finalization_Master; - Fin_Addr_Ptr : Finalize_Address_Ptr) - is - begin - if Master.Finalize_Address = null then - Master.Finalize_Address := Fin_Addr_Ptr; - end if; - end Set_Finalize_Address_Unprotected; - - ---------------------------------------------------- - -- Set_Heterogeneous_Finalize_Address_Unprotected -- - ---------------------------------------------------- - - procedure Set_Heterogeneous_Finalize_Address_Unprotected - (Obj : System.Address; - Fin_Addr_Ptr : Finalize_Address_Ptr) - is - begin - Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr); - end Set_Heterogeneous_Finalize_Address_Unprotected; - - -------------------------- - -- Set_Is_Heterogeneous -- - -------------------------- - - procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is - begin - -- Synchronization: - -- Read - finalization - -- Write - outside - - Lock_Task.all; - Master.Is_Homogeneous := False; - Unlock_Task.all; - end Set_Is_Heterogeneous; - -end System.Finalization_Masters; diff --git a/gcc/ada/s-finmas.ads b/gcc/ada/s-finmas.ads deleted file mode 100644 index 28f862f..0000000 --- a/gcc/ada/s-finmas.ads +++ /dev/null @@ -1,206 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Finalization; -with System.Storage_Elements; -with System.Storage_Pools; - -pragma Compiler_Unit_Warning; - -package System.Finalization_Masters is - pragma Preelaborate; - - -- A reference to primitive Finalize_Address. The expander generates an - -- implementation of this procedure for each controlled and class-wide - -- type. Since controlled objects are simply viewed as addresses once - -- allocated through a master, Finalize_Address provides a backward - -- indirection from an address to a type-specific context. - - type Finalize_Address_Ptr is access procedure (Obj : System.Address); - - -- Heterogeneous collection type structure - - type FM_Node is private; - type FM_Node_Ptr is access all FM_Node; - pragma No_Strict_Aliasing (FM_Node_Ptr); - - -- A reference to any derivation from Root_Storage_Pool. Since this type - -- may not be used to allocate objects, its storage size is zero. - - type Any_Storage_Pool_Ptr is - access System.Storage_Pools.Root_Storage_Pool'Class; - for Any_Storage_Pool_Ptr'Storage_Size use 0; - - -- Finalization master type structure. A unique master is associated with - -- each access-to-controlled or access-to-class-wide type. Masters also act - -- as components of subpools. By default, a master contains objects of the - -- same designated type but it may also accommodate heterogeneous objects. - - type Finalization_Master is - new Ada.Finalization.Limited_Controlled with private; - - -- A reference to a finalization master. Since this type may not be used - -- to allocate objects, its storage size is zero. - - type Finalization_Master_Ptr is access all Finalization_Master; - for Finalization_Master_Ptr'Storage_Size use 0; - - procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr); - -- Compiler interface, do not call from withing the run-time. Prepend a - -- node to a specific finalization master. - - procedure Attach_Unprotected - (N : not null FM_Node_Ptr; - L : not null FM_Node_Ptr); - -- Prepend a node to a specific finalization master - - procedure Delete_Finalize_Address_Unprotected (Obj : System.Address); - -- Destroy the relation pair object - Finalize_Address from the internal - -- hash table. - - procedure Detach (N : not null FM_Node_Ptr); - -- Compiler interface, do not call from within the run-time. Remove a node - -- from an arbitrary finalization master. - - procedure Detach_Unprotected (N : not null FM_Node_Ptr); - -- Remove a node from an arbitrary finalization master - - overriding procedure Finalize (Master : in out Finalization_Master); - -- Lock the master to prevent allocations during finalization. Iterate over - -- the list of allocated controlled objects, finalizing each one by calling - -- its specific Finalize_Address. In the end, deallocate the dummy head. - - function Finalize_Address - (Master : Finalization_Master) return Finalize_Address_Ptr; - -- Return a reference to the TSS primitive Finalize_Address associated with - -- a master. - - function Finalize_Address_Unprotected - (Obj : System.Address) return Finalize_Address_Ptr; - -- Retrieve the Finalize_Address primitive associated with a particular - -- object. - - function Finalization_Started (Master : Finalization_Master) return Boolean; - -- Return the finalization status of a master - - function Header_Size return System.Storage_Elements.Storage_Count; - -- Return the size of type FM_Node as Storage_Count - - function Is_Homogeneous (Master : Finalization_Master) return Boolean; - -- Return the behavior flag of a master - - function Objects (Master : Finalization_Master) return FM_Node_Ptr; - -- Return the header of the doubly-linked list of controlled objects - - procedure Print_Master (Master : Finalization_Master); - -- Debug routine, outputs the contents of a master - - procedure Set_Finalize_Address - (Master : in out Finalization_Master; - Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Compiler interface, do not call from within the run-time. Set the clean - -- up routine of a finalization master - - procedure Set_Finalize_Address_Unprotected - (Master : in out Finalization_Master; - Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Set the clean up routine of a finalization master - - procedure Set_Heterogeneous_Finalize_Address_Unprotected - (Obj : System.Address; - Fin_Addr_Ptr : Finalize_Address_Ptr); - -- Add a relation pair object - Finalize_Address to the internal hash - -- table. This is done in the context of allocation on a heterogeneous - -- finalization master where a single master services multiple anonymous - -- access-to-controlled types. - - procedure Set_Is_Heterogeneous (Master : in out Finalization_Master); - -- Mark the master as being a heterogeneous collection of objects - -private - -- Heterogeneous collection type structure - - type FM_Node is record - Prev : FM_Node_Ptr := null; - Next : FM_Node_Ptr := null; - end record; - - -- Finalization master type structure. A unique master is associated with - -- each access-to-controlled or access-to-class-wide type. Masters also act - -- as components of subpools. By default, a master contains objects of the - -- same designated type but it may also accommodate heterogeneous objects. - - type Finalization_Master is - new Ada.Finalization.Limited_Controlled with - record - Is_Homogeneous : Boolean := True; - -- A flag which controls the behavior of the master. A value of False - -- denotes a heterogeneous collection. - - Base_Pool : Any_Storage_Pool_Ptr := null; - -- A reference to the pool which this finalization master services. This - -- field is used in conjunction with the build-in-place machinery. - - Objects : aliased FM_Node; - -- A doubly linked list which contains the headers of all controlled - -- objects allocated in a [sub]pool. - - Finalize_Address : Finalize_Address_Ptr := null; - -- A reference to the routine reponsible for object finalization. This - -- is used only when the master is in homogeneous mode. - - Finalization_Started : Boolean := False; - -- A flag used to detect allocations which occur during the finalization - -- of a master. The allocations must raise Program_Error. This scenario - -- may arise in a multitask environment. - end record; - - -- Since RTSfind cannot contain names of the form RE_"+", the following - -- routine serves as a wrapper around System.Storage_Elements."+". - - function Add_Offset_To_Address - (Addr : System.Address; - Offset : System.Storage_Elements.Storage_Offset) return System.Address; - - function Base_Pool - (Master : Finalization_Master) return Any_Storage_Pool_Ptr; - -- Return a reference to the underlying storage pool on which the master - -- operates. - - overriding procedure Initialize (Master : in out Finalization_Master); - -- Initialize the dummy head of a finalization master - - procedure Set_Base_Pool - (Master : in out Finalization_Master; - Pool_Ptr : Any_Storage_Pool_Ptr); - -- Set the underlying pool of a finalization master - -end System.Finalization_Masters; diff --git a/gcc/ada/s-finroo.adb b/gcc/ada/s-finroo.adb deleted file mode 100644 index ec87923..0000000 --- a/gcc/ada/s-finroo.adb +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F I N A L I Z A T I O N _ R O O T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Finalization_Root is - - -- It should not be possible to call any of these subprograms - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (Object : in out Root_Controlled) is - begin - raise Program_Error; - end Adjust; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Object : in out Root_Controlled) is - begin - raise Program_Error; - end Finalize; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Object : in out Root_Controlled) is - begin - raise Program_Error; - end Initialize; - -end System.Finalization_Root; diff --git a/gcc/ada/s-finroo.ads b/gcc/ada/s-finroo.ads deleted file mode 100644 index 0e1a16f..0000000 --- a/gcc/ada/s-finroo.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . F I N A L I Z A T I O N _ R O O T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit provides the basic support for controlled (finalizable) types - -package System.Finalization_Root is - pragma Preelaborate; - - -- The base for types Controlled and Limited_Controlled declared in Ada. - -- Finalization. - - type Root_Controlled is abstract tagged null record; - - procedure Adjust (Object : in out Root_Controlled); - procedure Finalize (Object : in out Root_Controlled); - procedure Initialize (Object : in out Root_Controlled); - -end System.Finalization_Root; diff --git a/gcc/ada/s-flocon-none.adb b/gcc/ada/s-flocon-none.adb deleted file mode 100644 index 29e984a..0000000 --- a/gcc/ada/s-flocon-none.adb +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F L O A T _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation does nothing and can be used when the floating point --- unit is fully under control. - -package body System.Float_Control is - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - null; - end Reset; - -end System.Float_Control; diff --git a/gcc/ada/s-flocon.adb b/gcc/ada/s-flocon.adb deleted file mode 100644 index 970d556..0000000 --- a/gcc/ada/s-flocon.adb +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F L O A T _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation calls an imported function. - -package body System.Float_Control is - - ----------- - -- Reset -- - ----------- - - procedure Reset is - procedure Init_Float; - pragma Import (C, Init_Float, "__gnat_init_float"); - begin - Init_Float; - end Reset; - -end System.Float_Control; diff --git a/gcc/ada/s-flocon.ads b/gcc/ada/s-flocon.ads deleted file mode 100644 index fca271c..0000000 --- a/gcc/ada/s-flocon.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F L O A T _ C O N T R O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2011, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Control functions for floating-point unit - -package System.Float_Control is - pragma Pure; - -- This is not fully correct, but this unit is with-ed by pure units - -- (eg s-imgrea). - - procedure Reset; - pragma Inline (Reset); - -- Reset the floating-point processor to the default state needed to get - -- correct Ada semantics for the target. Some third party tools change - -- the settings for the floating-point processor. Reset can be called - -- to reset the floating-point processor into the mode required by GNAT - -- for correct operation. Use this call after a call to foreign code if - -- you suspect incorrect floating-point operation after the call. - -- - -- For example under Windows NT some system DLL calls change the default - -- FPU arithmetic to 64 bit precision mode. However, since in Ada 95 it - -- is required to provide full access to the floating-point types of the - -- architecture, GNAT requires full 80-bit precision mode, and Reset makes - -- sure this mode is established. - -- - -- Similarly on the PPC processor, it is important that overflow and - -- underflow exceptions be disabled. - -- - -- The call to Reset simply has no effect if the target environment - -- does not give rise to such concerns. -end System.Float_Control; diff --git a/gcc/ada/s-fore.adb b/gcc/ada/s-fore.adb deleted file mode 100644 index df8cdf2..0000000 --- a/gcc/ada/s-fore.adb +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F O R E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Fore is - - ---------- - -- Fore -- - ---------- - - function Fore (Lo, Hi : Long_Long_Float) return Natural is - T : Long_Long_Float := Long_Long_Float'Max (abs Lo, abs Hi); - R : Natural; - - begin - -- Initial value of 2 allows for sign and mandatory single digit - - R := 2; - - -- Loop to increase Fore as needed to include full range of values - - while T >= 10.0 loop - T := T / 10.0; - R := R + 1; - end loop; - - return R; - end Fore; -end System.Fore; diff --git a/gcc/ada/s-fore.ads b/gcc/ada/s-fore.ads deleted file mode 100644 index f334d96..0000000 --- a/gcc/ada/s-fore.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . F O R E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for the 'Fore attribute - -package System.Fore is - pragma Pure; - - function Fore (Lo, Hi : Long_Long_Float) return Natural; - -- Compute Fore attribute value for a fixed-point type. The parameters - -- are the low and high bounds values, converted to Long_Long_Float. - -end System.Fore; diff --git a/gcc/ada/s-gearop.adb b/gcc/ada/s-gearop.adb deleted file mode 100644 index b6d6f22..0000000 --- a/gcc/ada/s-gearop.adb +++ /dev/null @@ -1,934 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ A R R A Y _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2006-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Numerics; use Ada.Numerics; -package body System.Generic_Array_Operations is - function Check_Unit_Last - (Index : Integer; - Order : Positive; - First : Integer) return Integer; - pragma Inline_Always (Check_Unit_Last); - -- Compute index of last element returned by Unit_Vector or Unit_Matrix. - -- A separate function is needed to allow raising Constraint_Error before - -- declaring the function result variable. The result variable needs to be - -- declared first, to allow front-end inlining. - - -------------- - -- Diagonal -- - -------------- - - function Diagonal (A : Matrix) return Vector is - N : constant Natural := Natural'Min (A'Length (1), A'Length (2)); - begin - return R : Vector (A'First (1) .. A'First (1) + N - 1) do - for J in 0 .. N - 1 loop - R (R'First + J) := A (A'First (1) + J, A'First (2) + J); - end loop; - end return; - end Diagonal; - - -------------------------- - -- Square_Matrix_Length -- - -------------------------- - - function Square_Matrix_Length (A : Matrix) return Natural is - begin - if A'Length (1) /= A'Length (2) then - raise Constraint_Error with "matrix is not square"; - else - return A'Length (1); - end if; - end Square_Matrix_Length; - - --------------------- - -- Check_Unit_Last -- - --------------------- - - function Check_Unit_Last - (Index : Integer; - Order : Positive; - First : Integer) return Integer - is - begin - -- Order the tests carefully to avoid overflow - - if Index < First - or else First > Integer'Last - Order + 1 - or else Index > First + (Order - 1) - then - raise Constraint_Error; - end if; - - return First + (Order - 1); - end Check_Unit_Last; - - --------------------- - -- Back_Substitute -- - --------------------- - - procedure Back_Substitute (M, N : in out Matrix) is - pragma Assert (M'First (1) = N'First (1) - and then - M'Last (1) = N'Last (1)); - - procedure Sub_Row - (M : in out Matrix; - Target : Integer; - Source : Integer; - Factor : Scalar); - -- Elementary row operation that subtracts Factor * M (Source, <>) from - -- M (Target, <>) - - ------------- - -- Sub_Row -- - ------------- - - procedure Sub_Row - (M : in out Matrix; - Target : Integer; - Source : Integer; - Factor : Scalar) - is - begin - for J in M'Range (2) loop - M (Target, J) := M (Target, J) - Factor * M (Source, J); - end loop; - end Sub_Row; - - -- Local declarations - - Max_Col : Integer := M'Last (2); - - -- Start of processing for Back_Substitute - - begin - Do_Rows : for Row in reverse M'Range (1) loop - Find_Non_Zero : for Col in reverse M'First (2) .. Max_Col loop - if Is_Non_Zero (M (Row, Col)) then - - -- Found first non-zero element, so subtract a multiple of this - -- element from all higher rows, to reduce all other elements - -- in this column to zero. - - declare - -- We can't use a for loop, as we'd need to iterate to - -- Row - 1, but that expression will overflow if M'First - -- equals Integer'First, which is true for aggregates - -- without explicit bounds.. - - J : Integer := M'First (1); - - begin - while J < Row loop - Sub_Row (N, J, Row, (M (J, Col) / M (Row, Col))); - Sub_Row (M, J, Row, (M (J, Col) / M (Row, Col))); - J := J + 1; - end loop; - end; - - -- Avoid potential overflow in the subtraction below - - exit Do_Rows when Col = M'First (2); - - Max_Col := Col - 1; - - exit Find_Non_Zero; - end if; - end loop Find_Non_Zero; - end loop Do_Rows; - end Back_Substitute; - - ----------------------- - -- Forward_Eliminate -- - ----------------------- - - procedure Forward_Eliminate - (M : in out Matrix; - N : in out Matrix; - Det : out Scalar) - is - pragma Assert (M'First (1) = N'First (1) - and then - M'Last (1) = N'Last (1)); - - -- The following are variations of the elementary matrix row operations: - -- row switching, row multiplication and row addition. Because in this - -- algorithm the addition factor is always a negated value, we chose to - -- use row subtraction instead. Similarly, instead of multiplying by - -- a reciprocal, we divide. - - procedure Sub_Row - (M : in out Matrix; - Target : Integer; - Source : Integer; - Factor : Scalar); - -- Subtrace Factor * M (Source, <>) from M (Target, <>) - - procedure Divide_Row - (M, N : in out Matrix; - Row : Integer; - Scale : Scalar); - -- Divide M (Row) and N (Row) by Scale, and update Det - - procedure Switch_Row - (M, N : in out Matrix; - Row_1 : Integer; - Row_2 : Integer); - -- Exchange M (Row_1) and N (Row_1) with M (Row_2) and N (Row_2), - -- negating Det in the process. - - ------------- - -- Sub_Row -- - ------------- - - procedure Sub_Row - (M : in out Matrix; - Target : Integer; - Source : Integer; - Factor : Scalar) - is - begin - for J in M'Range (2) loop - M (Target, J) := M (Target, J) - Factor * M (Source, J); - end loop; - end Sub_Row; - - ---------------- - -- Divide_Row -- - ---------------- - - procedure Divide_Row - (M, N : in out Matrix; - Row : Integer; - Scale : Scalar) - is - begin - Det := Det * Scale; - - for J in M'Range (2) loop - M (Row, J) := M (Row, J) / Scale; - end loop; - - for J in N'Range (2) loop - N (Row - M'First (1) + N'First (1), J) := - N (Row - M'First (1) + N'First (1), J) / Scale; - end loop; - end Divide_Row; - - ---------------- - -- Switch_Row -- - ---------------- - - procedure Switch_Row - (M, N : in out Matrix; - Row_1 : Integer; - Row_2 : Integer) - is - procedure Swap (X, Y : in out Scalar); - -- Exchange the values of X and Y - - ---------- - -- Swap -- - ---------- - - procedure Swap (X, Y : in out Scalar) is - T : constant Scalar := X; - begin - X := Y; - Y := T; - end Swap; - - -- Start of processing for Switch_Row - - begin - if Row_1 /= Row_2 then - Det := Zero - Det; - - for J in M'Range (2) loop - Swap (M (Row_1, J), M (Row_2, J)); - end loop; - - for J in N'Range (2) loop - Swap (N (Row_1 - M'First (1) + N'First (1), J), - N (Row_2 - M'First (1) + N'First (1), J)); - end loop; - end if; - end Switch_Row; - - -- Local declarations - - Row : Integer := M'First (1); - - -- Start of processing for Forward_Eliminate - - begin - Det := One; - - for J in M'Range (2) loop - declare - Max_Row : Integer := Row; - Max_Abs : Real'Base := 0.0; - - begin - -- Find best pivot in column J, starting in row Row - - for K in Row .. M'Last (1) loop - declare - New_Abs : constant Real'Base := abs M (K, J); - begin - if Max_Abs < New_Abs then - Max_Abs := New_Abs; - Max_Row := K; - end if; - end; - end loop; - - if Max_Abs > 0.0 then - Switch_Row (M, N, Row, Max_Row); - - -- The temporaries below are necessary to force a copy of the - -- value and avoid improper aliasing. - - declare - Scale : constant Scalar := M (Row, J); - begin - Divide_Row (M, N, Row, Scale); - end; - - for U in Row + 1 .. M'Last (1) loop - declare - Factor : constant Scalar := M (U, J); - begin - Sub_Row (N, U, Row, Factor); - Sub_Row (M, U, Row, Factor); - end; - end loop; - - exit when Row >= M'Last (1); - - Row := Row + 1; - - else - -- Set zero (note that we do not have literals) - - Det := Zero; - end if; - end; - end loop; - end Forward_Eliminate; - - ------------------- - -- Inner_Product -- - ------------------- - - function Inner_Product - (Left : Left_Vector; - Right : Right_Vector) return Result_Scalar - is - R : Result_Scalar := Zero; - - begin - if Left'Length /= Right'Length then - raise Constraint_Error with - "vectors are of different length in inner product"; - end if; - - for J in Left'Range loop - R := R + Left (J) * Right (J - Left'First + Right'First); - end loop; - - return R; - end Inner_Product; - - ------------- - -- L2_Norm -- - ------------- - - function L2_Norm (X : X_Vector) return Result_Real'Base is - Sum : Result_Real'Base := 0.0; - - begin - for J in X'Range loop - Sum := Sum + Result_Real'Base (abs X (J))**2; - end loop; - - return Sqrt (Sum); - end L2_Norm; - - ---------------------------------- - -- Matrix_Elementwise_Operation -- - ---------------------------------- - - function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix is - begin - return R : Result_Matrix (X'Range (1), X'Range (2)) do - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Operation (X (J, K)); - end loop; - end loop; - end return; - end Matrix_Elementwise_Operation; - - ---------------------------------- - -- Vector_Elementwise_Operation -- - ---------------------------------- - - function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector is - begin - return R : Result_Vector (X'Range) do - for J in R'Range loop - R (J) := Operation (X (J)); - end loop; - end return; - end Vector_Elementwise_Operation; - - ----------------------------------------- - -- Matrix_Matrix_Elementwise_Operation -- - ----------------------------------------- - - function Matrix_Matrix_Elementwise_Operation - (Left : Left_Matrix; - Right : Right_Matrix) return Result_Matrix - is - begin - return R : Result_Matrix (Left'Range (1), Left'Range (2)) do - if Left'Length (1) /= Right'Length (1) - or else - Left'Length (2) /= Right'Length (2) - then - raise Constraint_Error with - "matrices are of different dimension in elementwise operation"; - end if; - - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := - Operation - (Left (J, K), - Right - (J - R'First (1) + Right'First (1), - K - R'First (2) + Right'First (2))); - end loop; - end loop; - end return; - end Matrix_Matrix_Elementwise_Operation; - - ------------------------------------------------ - -- Matrix_Matrix_Scalar_Elementwise_Operation -- - ------------------------------------------------ - - function Matrix_Matrix_Scalar_Elementwise_Operation - (X : X_Matrix; - Y : Y_Matrix; - Z : Z_Scalar) return Result_Matrix - is - begin - return R : Result_Matrix (X'Range (1), X'Range (2)) do - if X'Length (1) /= Y'Length (1) - or else - X'Length (2) /= Y'Length (2) - then - raise Constraint_Error with - "matrices are of different dimension in elementwise operation"; - end if; - - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := - Operation - (X (J, K), - Y (J - R'First (1) + Y'First (1), - K - R'First (2) + Y'First (2)), - Z); - end loop; - end loop; - end return; - end Matrix_Matrix_Scalar_Elementwise_Operation; - - ----------------------------------------- - -- Vector_Vector_Elementwise_Operation -- - ----------------------------------------- - - function Vector_Vector_Elementwise_Operation - (Left : Left_Vector; - Right : Right_Vector) return Result_Vector - is - begin - return R : Result_Vector (Left'Range) do - if Left'Length /= Right'Length then - raise Constraint_Error with - "vectors are of different length in elementwise operation"; - end if; - - for J in R'Range loop - R (J) := Operation (Left (J), Right (J - R'First + Right'First)); - end loop; - end return; - end Vector_Vector_Elementwise_Operation; - - ------------------------------------------------ - -- Vector_Vector_Scalar_Elementwise_Operation -- - ------------------------------------------------ - - function Vector_Vector_Scalar_Elementwise_Operation - (X : X_Vector; - Y : Y_Vector; - Z : Z_Scalar) return Result_Vector is - begin - return R : Result_Vector (X'Range) do - if X'Length /= Y'Length then - raise Constraint_Error with - "vectors are of different length in elementwise operation"; - end if; - - for J in R'Range loop - R (J) := Operation (X (J), Y (J - X'First + Y'First), Z); - end loop; - end return; - end Vector_Vector_Scalar_Elementwise_Operation; - - ----------------------------------------- - -- Matrix_Scalar_Elementwise_Operation -- - ----------------------------------------- - - function Matrix_Scalar_Elementwise_Operation - (Left : Left_Matrix; - Right : Right_Scalar) return Result_Matrix - is - begin - return R : Result_Matrix (Left'Range (1), Left'Range (2)) do - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Operation (Left (J, K), Right); - end loop; - end loop; - end return; - end Matrix_Scalar_Elementwise_Operation; - - ----------------------------------------- - -- Vector_Scalar_Elementwise_Operation -- - ----------------------------------------- - - function Vector_Scalar_Elementwise_Operation - (Left : Left_Vector; - Right : Right_Scalar) return Result_Vector - is - begin - return R : Result_Vector (Left'Range) do - for J in R'Range loop - R (J) := Operation (Left (J), Right); - end loop; - end return; - end Vector_Scalar_Elementwise_Operation; - - ----------------------------------------- - -- Scalar_Matrix_Elementwise_Operation -- - ----------------------------------------- - - function Scalar_Matrix_Elementwise_Operation - (Left : Left_Scalar; - Right : Right_Matrix) return Result_Matrix - is - begin - return R : Result_Matrix (Right'Range (1), Right'Range (2)) do - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Operation (Left, Right (J, K)); - end loop; - end loop; - end return; - end Scalar_Matrix_Elementwise_Operation; - - ----------------------------------------- - -- Scalar_Vector_Elementwise_Operation -- - ----------------------------------------- - - function Scalar_Vector_Elementwise_Operation - (Left : Left_Scalar; - Right : Right_Vector) return Result_Vector - is - begin - return R : Result_Vector (Right'Range) do - for J in R'Range loop - R (J) := Operation (Left, Right (J)); - end loop; - end return; - end Scalar_Vector_Elementwise_Operation; - - ---------- - -- Sqrt -- - ---------- - - function Sqrt (X : Real'Base) return Real'Base is - Root, Next : Real'Base; - - begin - -- Be defensive: any comparisons with NaN values will yield False. - - if not (X > 0.0) then - if X = 0.0 then - return X; - else - raise Argument_Error; - end if; - - elsif X > Real'Base'Last then - - -- X is infinity, which is its own square root - - return X; - end if; - - -- Compute an initial estimate based on: - - -- X = M * R**E and Sqrt (X) = Sqrt (M) * R**(E / 2.0), - - -- where M is the mantissa, R is the radix and E the exponent. - - -- By ignoring the mantissa and ignoring the case of an odd - -- exponent, we get a final error that is at most R. In other words, - -- the result has about a single bit precision. - - Root := Real'Base (Real'Machine_Radix) ** (Real'Exponent (X) / 2); - - -- Because of the poor initial estimate, use the Babylonian method of - -- computing the square root, as it is stable for all inputs. Every step - -- will roughly double the precision of the result. Just a few steps - -- suffice in most cases. Eight iterations should give about 2**8 bits - -- of precision. - - for J in 1 .. 8 loop - Next := (Root + X / Root) / 2.0; - exit when Root = Next; - Root := Next; - end loop; - - return Root; - end Sqrt; - - --------------------------- - -- Matrix_Matrix_Product -- - --------------------------- - - function Matrix_Matrix_Product - (Left : Left_Matrix; - Right : Right_Matrix) return Result_Matrix - is - begin - return R : Result_Matrix (Left'Range (1), Right'Range (2)) do - if Left'Length (2) /= Right'Length (1) then - raise Constraint_Error with - "incompatible dimensions in matrix multiplication"; - end if; - - for J in R'Range (1) loop - for K in R'Range (2) loop - declare - S : Result_Scalar := Zero; - - begin - for M in Left'Range (2) loop - S := S + Left (J, M) * - Right - (M - Left'First (2) + Right'First (1), K); - end loop; - - R (J, K) := S; - end; - end loop; - end loop; - end return; - end Matrix_Matrix_Product; - - ---------------------------- - -- Matrix_Vector_Solution -- - ---------------------------- - - function Matrix_Vector_Solution (A : Matrix; X : Vector) return Vector is - N : constant Natural := A'Length (1); - MA : Matrix := A; - MX : Matrix (A'Range (1), 1 .. 1); - R : Vector (A'Range (2)); - Det : Scalar; - - begin - if A'Length (2) /= N then - raise Constraint_Error with "matrix is not square"; - end if; - - if X'Length /= N then - raise Constraint_Error with "incompatible vector length"; - end if; - - for J in 0 .. MX'Length (1) - 1 loop - MX (MX'First (1) + J, 1) := X (X'First + J); - end loop; - - Forward_Eliminate (MA, MX, Det); - - if Det = Zero then - raise Constraint_Error with "matrix is singular"; - end if; - - Back_Substitute (MA, MX); - - for J in 0 .. R'Length - 1 loop - R (R'First + J) := MX (MX'First (1) + J, 1); - end loop; - - return R; - end Matrix_Vector_Solution; - - ---------------------------- - -- Matrix_Matrix_Solution -- - ---------------------------- - - function Matrix_Matrix_Solution (A, X : Matrix) return Matrix is - N : constant Natural := A'Length (1); - MA : Matrix (A'Range (2), A'Range (2)); - MB : Matrix (A'Range (2), X'Range (2)); - Det : Scalar; - - begin - if A'Length (2) /= N then - raise Constraint_Error with "matrix is not square"; - end if; - - if X'Length (1) /= N then - raise Constraint_Error with "matrices have unequal number of rows"; - end if; - - for J in 0 .. A'Length (1) - 1 loop - for K in MA'Range (2) loop - MA (MA'First (1) + J, K) := A (A'First (1) + J, K); - end loop; - - for K in MB'Range (2) loop - MB (MB'First (1) + J, K) := X (X'First (1) + J, K); - end loop; - end loop; - - Forward_Eliminate (MA, MB, Det); - - if Det = Zero then - raise Constraint_Error with "matrix is singular"; - end if; - - Back_Substitute (MA, MB); - - return MB; - end Matrix_Matrix_Solution; - - --------------------------- - -- Matrix_Vector_Product -- - --------------------------- - - function Matrix_Vector_Product - (Left : Matrix; - Right : Right_Vector) return Result_Vector - is - begin - return R : Result_Vector (Left'Range (1)) do - if Left'Length (2) /= Right'Length then - raise Constraint_Error with - "incompatible dimensions in matrix-vector multiplication"; - end if; - - for J in Left'Range (1) loop - declare - S : Result_Scalar := Zero; - - begin - for K in Left'Range (2) loop - S := S + Left (J, K) - * Right (K - Left'First (2) + Right'First); - end loop; - - R (J) := S; - end; - end loop; - end return; - end Matrix_Vector_Product; - - ------------------- - -- Outer_Product -- - ------------------- - - function Outer_Product - (Left : Left_Vector; - Right : Right_Vector) return Matrix - is - begin - return R : Matrix (Left'Range, Right'Range) do - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := Left (J) * Right (K); - end loop; - end loop; - end return; - end Outer_Product; - - ----------------- - -- Swap_Column -- - ----------------- - - procedure Swap_Column (A : in out Matrix; Left, Right : Integer) is - Temp : Scalar; - begin - for J in A'Range (1) loop - Temp := A (J, Left); - A (J, Left) := A (J, Right); - A (J, Right) := Temp; - end loop; - end Swap_Column; - - --------------- - -- Transpose -- - --------------- - - procedure Transpose (A : Matrix; R : out Matrix) is - begin - for J in R'Range (1) loop - for K in R'Range (2) loop - R (J, K) := A (K - R'First (2) + A'First (1), - J - R'First (1) + A'First (2)); - end loop; - end loop; - end Transpose; - - ------------------------------- - -- Update_Matrix_With_Matrix -- - ------------------------------- - - procedure Update_Matrix_With_Matrix (X : in out X_Matrix; Y : Y_Matrix) is - begin - if X'Length (1) /= Y'Length (1) - or else - X'Length (2) /= Y'Length (2) - then - raise Constraint_Error with - "matrices are of different dimension in update operation"; - end if; - - for J in X'Range (1) loop - for K in X'Range (2) loop - Update (X (J, K), Y (J - X'First (1) + Y'First (1), - K - X'First (2) + Y'First (2))); - end loop; - end loop; - end Update_Matrix_With_Matrix; - - ------------------------------- - -- Update_Vector_With_Vector -- - ------------------------------- - - procedure Update_Vector_With_Vector (X : in out X_Vector; Y : Y_Vector) is - begin - if X'Length /= Y'Length then - raise Constraint_Error with - "vectors are of different length in update operation"; - end if; - - for J in X'Range loop - Update (X (J), Y (J - X'First + Y'First)); - end loop; - end Update_Vector_With_Vector; - - ----------------- - -- Unit_Matrix -- - ----------------- - - function Unit_Matrix - (Order : Positive; - First_1 : Integer := 1; - First_2 : Integer := 1) return Matrix - is - begin - return R : Matrix (First_1 .. Check_Unit_Last (First_1, Order, First_1), - First_2 .. Check_Unit_Last (First_2, Order, First_2)) - do - R := (others => (others => Zero)); - - for J in 0 .. Order - 1 loop - R (First_1 + J, First_2 + J) := One; - end loop; - end return; - end Unit_Matrix; - - ----------------- - -- Unit_Vector -- - ----------------- - - function Unit_Vector - (Index : Integer; - Order : Positive; - First : Integer := 1) return Vector - is - begin - return R : Vector (First .. Check_Unit_Last (Index, Order, First)) do - R := (others => Zero); - R (Index) := One; - end return; - end Unit_Vector; - - --------------------------- - -- Vector_Matrix_Product -- - --------------------------- - - function Vector_Matrix_Product - (Left : Left_Vector; - Right : Matrix) return Result_Vector - is - begin - return R : Result_Vector (Right'Range (2)) do - if Left'Length /= Right'Length (1) then - raise Constraint_Error with - "incompatible dimensions in vector-matrix multiplication"; - end if; - - for J in Right'Range (2) loop - declare - S : Result_Scalar := Zero; - - begin - for K in Right'Range (1) loop - S := S + Left (K - Right'First (1) - + Left'First) * Right (K, J); - end loop; - - R (J) := S; - end; - end loop; - end return; - end Vector_Matrix_Product; - -end System.Generic_Array_Operations; diff --git a/gcc/ada/s-gearop.ads b/gcc/ada/s-gearop.ads deleted file mode 100644 index 7e252ee..0000000 --- a/gcc/ada/s-gearop.ads +++ /dev/null @@ -1,502 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ A R R A Y _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2006-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System.Generic_Array_Operations is -pragma Pure (Generic_Array_Operations); - - --------------------- - -- Back_Substitute -- - --------------------- - - generic - type Scalar is private; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - with function "-" (Left, Right : Scalar) return Scalar is <>; - with function "*" (Left, Right : Scalar) return Scalar is <>; - with function "/" (Left, Right : Scalar) return Scalar is <>; - with function Is_Non_Zero (X : Scalar) return Boolean is <>; - procedure Back_Substitute (M, N : in out Matrix); - - -------------- - -- Diagonal -- - -------------- - - generic - type Scalar is private; - type Vector is array (Integer range <>) of Scalar; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - function Diagonal (A : Matrix) return Vector; - - ----------------------- - -- Forward_Eliminate -- - ----------------------- - - -- Use elementary row operations to put square matrix M in row echolon - -- form. Identical row operations are performed on matrix N, must have the - -- same number of rows as M. - - generic - type Scalar is private; - type Real is digits <>; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - with function "abs" (Right : Scalar) return Real'Base is <>; - with function "-" (Left, Right : Scalar) return Scalar is <>; - with function "*" (Left, Right : Scalar) return Scalar is <>; - with function "/" (Left, Right : Scalar) return Scalar is <>; - Zero : Scalar; - One : Scalar; - procedure Forward_Eliminate - (M : in out Matrix; - N : in out Matrix; - Det : out Scalar); - - -------------------------- - -- Square_Matrix_Length -- - -------------------------- - - generic - type Scalar is private; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - function Square_Matrix_Length (A : Matrix) return Natural; - -- If A is non-square, raise Constraint_Error, else return its dimension - - ---------------------------------- - -- Vector_Elementwise_Operation -- - ---------------------------------- - - generic - type X_Scalar is private; - type Result_Scalar is private; - type X_Vector is array (Integer range <>) of X_Scalar; - type Result_Vector is array (Integer range <>) of Result_Scalar; - with function Operation (X : X_Scalar) return Result_Scalar; - function Vector_Elementwise_Operation (X : X_Vector) return Result_Vector; - - ---------------------------------- - -- Matrix_Elementwise_Operation -- - ---------------------------------- - - generic - type X_Scalar is private; - type Result_Scalar is private; - type X_Matrix is array (Integer range <>, Integer range <>) of X_Scalar; - type Result_Matrix is array (Integer range <>, Integer range <>) - of Result_Scalar; - with function Operation (X : X_Scalar) return Result_Scalar; - function Matrix_Elementwise_Operation (X : X_Matrix) return Result_Matrix; - - ----------------------------------------- - -- Vector_Vector_Elementwise_Operation -- - ----------------------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Vector is array (Integer range <>) of Left_Scalar; - type Right_Vector is array (Integer range <>) of Right_Scalar; - type Result_Vector is array (Integer range <>) of Result_Scalar; - with function Operation - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar; - function Vector_Vector_Elementwise_Operation - (Left : Left_Vector; - Right : Right_Vector) return Result_Vector; - - ------------------------------------------------ - -- Vector_Vector_Scalar_Elementwise_Operation -- - ------------------------------------------------ - - generic - type X_Scalar is private; - type Y_Scalar is private; - type Z_Scalar is private; - type Result_Scalar is private; - type X_Vector is array (Integer range <>) of X_Scalar; - type Y_Vector is array (Integer range <>) of Y_Scalar; - type Result_Vector is array (Integer range <>) of Result_Scalar; - with function Operation - (X : X_Scalar; - Y : Y_Scalar; - Z : Z_Scalar) return Result_Scalar; - function Vector_Vector_Scalar_Elementwise_Operation - (X : X_Vector; - Y : Y_Vector; - Z : Z_Scalar) return Result_Vector; - - ----------------------------------------- - -- Matrix_Matrix_Elementwise_Operation -- - ----------------------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Matrix is array (Integer range <>, Integer range <>) - of Left_Scalar; - type Right_Matrix is array (Integer range <>, Integer range <>) - of Right_Scalar; - type Result_Matrix is array (Integer range <>, Integer range <>) - of Result_Scalar; - with function Operation - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar; - function Matrix_Matrix_Elementwise_Operation - (Left : Left_Matrix; - Right : Right_Matrix) return Result_Matrix; - - ------------------------------------------------ - -- Matrix_Matrix_Scalar_Elementwise_Operation -- - ------------------------------------------------ - - generic - type X_Scalar is private; - type Y_Scalar is private; - type Z_Scalar is private; - type Result_Scalar is private; - type X_Matrix is array (Integer range <>, Integer range <>) of X_Scalar; - type Y_Matrix is array (Integer range <>, Integer range <>) of Y_Scalar; - type Result_Matrix is array (Integer range <>, Integer range <>) - of Result_Scalar; - with function Operation - (X : X_Scalar; - Y : Y_Scalar; - Z : Z_Scalar) return Result_Scalar; - function Matrix_Matrix_Scalar_Elementwise_Operation - (X : X_Matrix; - Y : Y_Matrix; - Z : Z_Scalar) return Result_Matrix; - - ----------------------------------------- - -- Vector_Scalar_Elementwise_Operation -- - ----------------------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Vector is array (Integer range <>) of Left_Scalar; - type Result_Vector is array (Integer range <>) of Result_Scalar; - with function Operation - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar; - function Vector_Scalar_Elementwise_Operation - (Left : Left_Vector; - Right : Right_Scalar) return Result_Vector; - - ----------------------------------------- - -- Matrix_Scalar_Elementwise_Operation -- - ----------------------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Matrix is array (Integer range <>, Integer range <>) - of Left_Scalar; - type Result_Matrix is array (Integer range <>, Integer range <>) - of Result_Scalar; - with function Operation - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar; - function Matrix_Scalar_Elementwise_Operation - (Left : Left_Matrix; - Right : Right_Scalar) return Result_Matrix; - - ----------------------------------------- - -- Scalar_Vector_Elementwise_Operation -- - ----------------------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Right_Vector is array (Integer range <>) of Right_Scalar; - type Result_Vector is array (Integer range <>) of Result_Scalar; - with function Operation - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar; - function Scalar_Vector_Elementwise_Operation - (Left : Left_Scalar; - Right : Right_Vector) return Result_Vector; - - ----------------------------------------- - -- Scalar_Matrix_Elementwise_Operation -- - ----------------------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Right_Matrix is array (Integer range <>, Integer range <>) - of Right_Scalar; - type Result_Matrix is array (Integer range <>, Integer range <>) - of Result_Scalar; - with function Operation - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar; - function Scalar_Matrix_Elementwise_Operation - (Left : Left_Scalar; - Right : Right_Matrix) return Result_Matrix; - - ------------------- - -- Inner_Product -- - ------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Vector is array (Integer range <>) of Left_Scalar; - type Right_Vector is array (Integer range <>) of Right_Scalar; - Zero : Result_Scalar; - with function "*" - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar is <>; - with function "+" - (Left : Result_Scalar; - Right : Result_Scalar) return Result_Scalar is <>; - function Inner_Product - (Left : Left_Vector; - Right : Right_Vector) return Result_Scalar; - - ------------- - -- L2_Norm -- - ------------- - - generic - type X_Scalar is private; - type Result_Real is digits <>; - type X_Vector is array (Integer range <>) of X_Scalar; - with function "abs" (Right : X_Scalar) return Result_Real is <>; - with function Sqrt (X : Result_Real'Base) return Result_Real'Base is <>; - function L2_Norm (X : X_Vector) return Result_Real'Base; - - ------------------- - -- Outer_Product -- - ------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Vector is array (Integer range <>) of Left_Scalar; - type Right_Vector is array (Integer range <>) of Right_Scalar; - type Matrix is array (Integer range <>, Integer range <>) - of Result_Scalar; - with function "*" - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar is <>; - function Outer_Product - (Left : Left_Vector; - Right : Right_Vector) return Matrix; - - --------------------------- - -- Matrix_Vector_Product -- - --------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Matrix is array (Integer range <>, Integer range <>) - of Left_Scalar; - type Right_Vector is array (Integer range <>) of Right_Scalar; - type Result_Vector is array (Integer range <>) of Result_Scalar; - Zero : Result_Scalar; - with function "*" - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar is <>; - with function "+" - (Left : Result_Scalar; - Right : Result_Scalar) return Result_Scalar is <>; - function Matrix_Vector_Product - (Left : Matrix; - Right : Right_Vector) return Result_Vector; - - --------------------------- - -- Vector_Matrix_Product -- - --------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Vector is array (Integer range <>) of Left_Scalar; - type Matrix is array (Integer range <>, Integer range <>) - of Right_Scalar; - type Result_Vector is array (Integer range <>) of Result_Scalar; - Zero : Result_Scalar; - with function "*" - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar is <>; - with function "+" - (Left : Result_Scalar; - Right : Result_Scalar) return Result_Scalar is <>; - function Vector_Matrix_Product - (Left : Left_Vector; - Right : Matrix) return Result_Vector; - - --------------------------- - -- Matrix_Matrix_Product -- - --------------------------- - - generic - type Left_Scalar is private; - type Right_Scalar is private; - type Result_Scalar is private; - type Left_Matrix is array (Integer range <>, Integer range <>) - of Left_Scalar; - type Right_Matrix is array (Integer range <>, Integer range <>) - of Right_Scalar; - type Result_Matrix is array (Integer range <>, Integer range <>) - of Result_Scalar; - Zero : Result_Scalar; - with function "*" - (Left : Left_Scalar; - Right : Right_Scalar) return Result_Scalar is <>; - with function "+" - (Left : Result_Scalar; - Right : Result_Scalar) return Result_Scalar is <>; - function Matrix_Matrix_Product - (Left : Left_Matrix; - Right : Right_Matrix) return Result_Matrix; - - ---------------------------- - -- Matrix_Vector_Solution -- - ---------------------------- - - generic - type Scalar is private; - Zero : Scalar; - type Vector is array (Integer range <>) of Scalar; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - with procedure Back_Substitute (M, N : in out Matrix) is <>; - with procedure Forward_Eliminate - (M : in out Matrix; - N : in out Matrix; - Det : out Scalar) is <>; - function Matrix_Vector_Solution (A : Matrix; X : Vector) return Vector; - - ---------------------------- - -- Matrix_Matrix_Solution -- - ---------------------------- - - generic - type Scalar is private; - Zero : Scalar; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - with procedure Back_Substitute (M, N : in out Matrix) is <>; - with procedure Forward_Eliminate - (M : in out Matrix; - N : in out Matrix; - Det : out Scalar) is <>; - function Matrix_Matrix_Solution (A : Matrix; X : Matrix) return Matrix; - - ---------- - -- Sqrt -- - ---------- - - generic - type Real is digits <>; - function Sqrt (X : Real'Base) return Real'Base; - - ----------------- - -- Swap_Column -- - ----------------- - - generic - type Scalar is private; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - procedure Swap_Column (A : in out Matrix; Left, Right : Integer); - - --------------- - -- Transpose -- - --------------- - - generic - type Scalar is private; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - procedure Transpose (A : Matrix; R : out Matrix); - - ------------------------------- - -- Update_Vector_With_Vector -- - ------------------------------- - - generic - type X_Scalar is private; - type Y_Scalar is private; - type X_Vector is array (Integer range <>) of X_Scalar; - type Y_Vector is array (Integer range <>) of Y_Scalar; - with procedure Update (X : in out X_Scalar; Y : Y_Scalar); - procedure Update_Vector_With_Vector (X : in out X_Vector; Y : Y_Vector); - - ------------------------------- - -- Update_Matrix_With_Matrix -- - ------------------------------- - - generic - type X_Scalar is private; - type Y_Scalar is private; - type X_Matrix is array (Integer range <>, Integer range <>) of X_Scalar; - type Y_Matrix is array (Integer range <>, Integer range <>) of Y_Scalar; - with procedure Update (X : in out X_Scalar; Y : Y_Scalar); - procedure Update_Matrix_With_Matrix (X : in out X_Matrix; Y : Y_Matrix); - - ----------------- - -- Unit_Matrix -- - ----------------- - - generic - type Scalar is private; - type Matrix is array (Integer range <>, Integer range <>) of Scalar; - Zero : Scalar; - One : Scalar; - function Unit_Matrix - (Order : Positive; - First_1 : Integer := 1; - First_2 : Integer := 1) return Matrix; - - ----------------- - -- Unit_Vector -- - ----------------- - - generic - type Scalar is private; - type Vector is array (Integer range <>) of Scalar; - Zero : Scalar; - One : Scalar; - function Unit_Vector - (Index : Integer; - Order : Positive; - First : Integer := 1) return Vector; - -end System.Generic_Array_Operations; diff --git a/gcc/ada/s-geveop.adb b/gcc/ada/s-geveop.adb deleted file mode 100644 index e040324..0000000 --- a/gcc/ada/s-geveop.adb +++ /dev/null @@ -1,133 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ V E C T O R _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; use System; -with System.Address_Operations; use System.Address_Operations; -with System.Storage_Elements; use System.Storage_Elements; - -with Ada.Unchecked_Conversion; - -package body System.Generic_Vector_Operations is - - IU : constant Integer := Integer (Storage_Unit); - VU : constant Address := Address (Vectors.Vector'Size / IU); - EU : constant Address := Address (Element_Array'Component_Size / IU); - - ---------------------- - -- Binary_Operation -- - ---------------------- - - procedure Binary_Operation - (R, X, Y : System.Address; - Length : System.Storage_Elements.Storage_Count) - is - RA : Address := R; - XA : Address := X; - YA : Address := Y; - -- Address of next element to process in R, X and Y - - VI : constant Integer_Address := To_Integer (VU); - - Unaligned : constant Integer_Address := - Boolean'Pos (ModA (OrA (OrA (RA, XA), YA), VU) /= 0) - 1; - -- Zero iff one or more argument addresses is not aligned, else all 1's - - type Vector_Ptr is access all Vectors.Vector; - type Element_Ptr is access all Element; - - function VP is new Ada.Unchecked_Conversion (Address, Vector_Ptr); - function EP is new Ada.Unchecked_Conversion (Address, Element_Ptr); - - SA : constant Address := - AddA (XA, To_Address - ((Integer_Address (Length) / VI * VI) and Unaligned)); - -- First address of argument X to start serial processing - - begin - while XA < SA loop - VP (RA).all := Vector_Op (VP (XA).all, VP (YA).all); - XA := AddA (XA, VU); - YA := AddA (YA, VU); - RA := AddA (RA, VU); - end loop; - - while XA < X + Length loop - EP (RA).all := Element_Op (EP (XA).all, EP (YA).all); - XA := AddA (XA, EU); - YA := AddA (YA, EU); - RA := AddA (RA, EU); - end loop; - end Binary_Operation; - - ---------------------- - -- Unary_Operation -- - ---------------------- - - procedure Unary_Operation - (R, X : System.Address; - Length : System.Storage_Elements.Storage_Count) - is - RA : Address := R; - XA : Address := X; - -- Address of next element to process in R and X - - VI : constant Integer_Address := To_Integer (VU); - - Unaligned : constant Integer_Address := - Boolean'Pos (ModA (OrA (RA, XA), VU) /= 0) - 1; - -- Zero iff one or more argument addresses is not aligned, else all 1's - - type Vector_Ptr is access all Vectors.Vector; - type Element_Ptr is access all Element; - - function VP is new Ada.Unchecked_Conversion (Address, Vector_Ptr); - function EP is new Ada.Unchecked_Conversion (Address, Element_Ptr); - - SA : constant Address := - AddA (XA, To_Address - ((Integer_Address (Length) / VI * VI) and Unaligned)); - -- First address of argument X to start serial processing - - begin - while XA < SA loop - VP (RA).all := Vector_Op (VP (XA).all); - XA := AddA (XA, VU); - RA := AddA (RA, VU); - end loop; - - while XA < X + Length loop - EP (RA).all := Element_Op (EP (XA).all); - XA := AddA (XA, EU); - RA := AddA (RA, EU); - end loop; - end Unary_Operation; - -end System.Generic_Vector_Operations; diff --git a/gcc/ada/s-geveop.ads b/gcc/ada/s-geveop.ads deleted file mode 100644 index 3796bc9..0000000 --- a/gcc/ada/s-geveop.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . G E N E R I C _ V E C T O R _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains generic procedures for vector operations on arrays. --- If the arguments are aligned on word boundaries and the word size is a --- multiple M of the element size, the operations will be done M elements --- at a time using vector operations on a word. - --- All routines assume argument arrays have the same length, and arguments --- with mode "in" do not alias arguments with mode "out" or "in out". --- If the number N of elements to be processed is not a multiple of M --- the final N rem M elements will be processed one item at a time. - -with System.Vectors; -with System.Storage_Elements; - -generic - type Element is (<>); - type Index is (<>); - type Element_Array is array (Index range <>) of Element; - -package System.Generic_Vector_Operations is - pragma Pure; - - generic - with function Element_Op (X, Y : Element) return Element; - with function Vector_Op (X, Y : Vectors.Vector) return Vectors.Vector; - procedure Binary_Operation - (R, X, Y : System.Address; - Length : System.Storage_Elements.Storage_Count); - - generic - with function Element_Op (X : Element) return Element; - with function Vector_Op (X : Vectors.Vector) return Vectors.Vector; - procedure Unary_Operation - (R, X : System.Address; - Length : System.Storage_Elements.Storage_Count); -end System.Generic_Vector_Operations; diff --git a/gcc/ada/s-gloloc-mingw.adb b/gcc/ada/s-gloloc-mingw.adb deleted file mode 100644 index b6050cb4..0000000 --- a/gcc/ada/s-gloloc-mingw.adb +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . G L O B A L _ L O C K S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This implementation is specific to NT - -with System.OS_Interface; -with System.Task_Lock; -with System.Win32; - -with Interfaces.C.Strings; - -package body System.Global_Locks is - - package TSL renames System.Task_Lock; - package OSI renames System.OS_Interface; - package ICS renames Interfaces.C.Strings; - - subtype Lock_File_Entry is Win32.HANDLE; - - Last_Lock : Lock_Type := Null_Lock; - Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; - - ----------------- - -- Create_Lock -- - ----------------- - - procedure Create_Lock (Lock : out Lock_Type; Name : String) is - L : Lock_Type; - - begin - TSL.Lock; - Last_Lock := Last_Lock + 1; - L := Last_Lock; - TSL.Unlock; - - if L > Lock_Table'Last then - raise Lock_Error; - end if; - - Lock_Table (L) := - OSI.CreateMutex (null, Win32.FALSE, ICS.New_String (Name)); - Lock := L; - end Create_Lock; - - ------------------ - -- Acquire_Lock -- - ------------------ - - procedure Acquire_Lock (Lock : in out Lock_Type) is - use type Win32.DWORD; - - Res : Win32.DWORD; - - begin - Res := OSI.WaitForSingleObject (Lock_Table (Lock), OSI.Wait_Infinite); - - if Res = OSI.WAIT_FAILED then - raise Lock_Error; - end if; - end Acquire_Lock; - - ------------------ - -- Release_Lock -- - ------------------ - - procedure Release_Lock (Lock : in out Lock_Type) is - use type Win32.BOOL; - - Res : Win32.BOOL; - - begin - Res := OSI.ReleaseMutex (Lock_Table (Lock)); - - if Res = Win32.FALSE then - raise Lock_Error; - end if; - end Release_Lock; - -end System.Global_Locks; diff --git a/gcc/ada/s-gloloc.adb b/gcc/ada/s-gloloc.adb deleted file mode 100644 index 6dfc527..0000000 --- a/gcc/ada/s-gloloc.adb +++ /dev/null @@ -1,149 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . G L O B A L _ L O C K S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Soft_Links; - -package body System.Global_Locks is - - type String_Access is access String; - - Dir_Separator : Character; - pragma Import (C, Dir_Separator, "__gnat_dir_separator"); - - type Lock_File_Entry is record - Dir : String_Access; - File : String_Access; - end record; - - Last_Lock : Lock_Type := Null_Lock; - Lock_Table : array (Lock_Type range 1 .. 15) of Lock_File_Entry; - - procedure Lock_File - (Dir : String; - File : String; - Wait : Duration := 0.1; - Retries : Natural := Natural'Last); - -- Create a lock file File in directory Dir. If the file cannot be - -- locked because someone already owns the lock, this procedure - -- waits Wait seconds and retries at most Retries times. If the file - -- still cannot be locked, Lock_Error is raised. The default is to try - -- every second, almost forever (Natural'Last times). - - ------------------ - -- Acquire_Lock -- - ------------------ - - procedure Acquire_Lock (Lock : in out Lock_Type) is - begin - Lock_File - (Lock_Table (Lock).Dir.all, - Lock_Table (Lock).File.all); - end Acquire_Lock; - - ----------------- - -- Create_Lock -- - ----------------- - - procedure Create_Lock (Lock : out Lock_Type; Name : String) is - L : Lock_Type; - - begin - System.Soft_Links.Lock_Task.all; - Last_Lock := Last_Lock + 1; - L := Last_Lock; - System.Soft_Links.Unlock_Task.all; - - if L > Lock_Table'Last then - raise Lock_Error; - end if; - - for J in reverse Name'Range loop - if Name (J) = Dir_Separator then - Lock_Table (L).Dir := new String'(Name (Name'First .. J - 1)); - Lock_Table (L).File := new String'(Name (J + 1 .. Name'Last)); - exit; - end if; - end loop; - - if Lock_Table (L).Dir = null then - Lock_Table (L).Dir := new String'("."); - Lock_Table (L).File := new String'(Name); - end if; - - Lock := L; - end Create_Lock; - - --------------- - -- Lock_File -- - --------------- - - procedure Lock_File - (Dir : String; - File : String; - Wait : Duration := 0.1; - Retries : Natural := Natural'Last) - is - C_Dir : aliased String := Dir & ASCII.NUL; - C_File : aliased String := File & ASCII.NUL; - - function Try_Lock (Dir, File : System.Address) return Integer; - pragma Import (C, Try_Lock, "__gnat_try_lock"); - - begin - for I in 0 .. Retries loop - if Try_Lock (C_Dir'Address, C_File'Address) = 1 then - return; - end if; - - exit when I = Retries; - delay Wait; - end loop; - - raise Lock_Error; - end Lock_File; - - ------------------ - -- Release_Lock -- - ------------------ - - procedure Release_Lock (Lock : in out Lock_Type) is - S : aliased String := - Lock_Table (Lock).Dir.all & Dir_Separator & - Lock_Table (Lock).File.all & ASCII.NUL; - - procedure unlink (A : System.Address); - pragma Import (C, unlink, "unlink"); - - begin - unlink (S'Address); - end Release_Lock; - -end System.Global_Locks; diff --git a/gcc/ada/s-gloloc.ads b/gcc/ada/s-gloloc.ads deleted file mode 100644 index 4a0aa22..0000000 --- a/gcc/ada/s-gloloc.ads +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . G L O B A L _ L O C K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - - -- This package contains the necessary routines to provide - -- reliable system wide locking capability. - -package System.Global_Locks is - - Lock_Error : exception; - -- Exception raised if a request cannot be executed on a lock - - type Lock_Type is private; - -- Such a lock is a global lock between partitions. This lock is - -- uniquely defined between the partitions because of its name. - - Null_Lock : constant Lock_Type; - -- This needs comments ??? - - procedure Create_Lock (Lock : out Lock_Type; Name : String); - -- Create or retrieve a global lock for the current partition using - -- its Name. - - procedure Acquire_Lock (Lock : in out Lock_Type); - -- If the lock cannot be acquired because someone already owns it, this - -- procedure is supposed to wait and retry forever. - - procedure Release_Lock (Lock : in out Lock_Type); - -private - - type Lock_Type is new Natural; - - Null_Lock : constant Lock_Type := 0; - -end System.Global_Locks; diff --git a/gcc/ada/s-htable.adb b/gcc/ada/s-htable.adb deleted file mode 100644 index f72b6492..0000000 --- a/gcc/ada/s-htable.adb +++ /dev/null @@ -1,412 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . H T A B L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Deallocation; -with System.String_Hash; - -package body System.HTable is - - ------------------- - -- Static_HTable -- - ------------------- - - package body Static_HTable is - - Table : array (Header_Num) of Elmt_Ptr; - - Iterator_Index : Header_Num; - Iterator_Ptr : Elmt_Ptr; - Iterator_Started : Boolean := False; - - function Get_Non_Null return Elmt_Ptr; - -- Returns Null_Ptr if Iterator_Started is false or the Table is empty. - -- Returns Iterator_Ptr if non null, or the next non null element in - -- table if any. - - --------- - -- Get -- - --------- - - function Get (K : Key) return Elmt_Ptr is - Elmt : Elmt_Ptr; - - begin - Elmt := Table (Hash (K)); - loop - if Elmt = Null_Ptr then - return Null_Ptr; - - elsif Equal (Get_Key (Elmt), K) then - return Elmt; - - else - Elmt := Next (Elmt); - end if; - end loop; - end Get; - - --------------- - -- Get_First -- - --------------- - - function Get_First return Elmt_Ptr is - begin - Iterator_Started := True; - Iterator_Index := Table'First; - Iterator_Ptr := Table (Iterator_Index); - return Get_Non_Null; - end Get_First; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next return Elmt_Ptr is - begin - if not Iterator_Started then - return Null_Ptr; - else - Iterator_Ptr := Next (Iterator_Ptr); - return Get_Non_Null; - end if; - end Get_Next; - - ------------------ - -- Get_Non_Null -- - ------------------ - - function Get_Non_Null return Elmt_Ptr is - begin - while Iterator_Ptr = Null_Ptr loop - if Iterator_Index = Table'Last then - Iterator_Started := False; - return Null_Ptr; - end if; - - Iterator_Index := Iterator_Index + 1; - Iterator_Ptr := Table (Iterator_Index); - end loop; - - return Iterator_Ptr; - end Get_Non_Null; - - ------------- - -- Present -- - ------------- - - function Present (K : Key) return Boolean is - begin - return Get (K) /= Null_Ptr; - end Present; - - ------------ - -- Remove -- - ------------ - - procedure Remove (K : Key) is - Index : constant Header_Num := Hash (K); - Elmt : Elmt_Ptr; - Next_Elmt : Elmt_Ptr; - - begin - Elmt := Table (Index); - - if Elmt = Null_Ptr then - return; - - elsif Equal (Get_Key (Elmt), K) then - Table (Index) := Next (Elmt); - - else - loop - Next_Elmt := Next (Elmt); - - if Next_Elmt = Null_Ptr then - return; - - elsif Equal (Get_Key (Next_Elmt), K) then - Set_Next (Elmt, Next (Next_Elmt)); - return; - - else - Elmt := Next_Elmt; - end if; - end loop; - end if; - end Remove; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - begin - -- Use an aggregate for efficiency reasons - - Table := (others => Null_Ptr); - end Reset; - - --------- - -- Set -- - --------- - - procedure Set (E : Elmt_Ptr) is - Index : Header_Num; - begin - Index := Hash (Get_Key (E)); - Set_Next (E, Table (Index)); - Table (Index) := E; - end Set; - - ------------------------ - -- Set_If_Not_Present -- - ------------------------ - - function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is - K : Key renames Get_Key (E); - -- Note that it is important to use a renaming here rather than - -- define a constant initialized by the call, because the latter - -- construct runs into bootstrap problems with earlier versions - -- of the GNAT compiler. - - Index : constant Header_Num := Hash (K); - Elmt : Elmt_Ptr; - - begin - Elmt := Table (Index); - loop - if Elmt = Null_Ptr then - Set_Next (E, Table (Index)); - Table (Index) := E; - return True; - - elsif Equal (Get_Key (Elmt), K) then - return False; - - else - Elmt := Next (Elmt); - end if; - end loop; - end Set_If_Not_Present; - - end Static_HTable; - - ------------------- - -- Simple_HTable -- - ------------------- - - package body Simple_HTable is - - type Element_Wrapper; - type Elmt_Ptr is access all Element_Wrapper; - type Element_Wrapper is record - K : Key; - E : Element; - Next : Elmt_Ptr; - end record; - - procedure Free is new - Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); - - procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - function Next (E : Elmt_Ptr) return Elmt_Ptr; - function Get_Key (E : Elmt_Ptr) return Key; - - package Tab is new Static_HTable ( - Header_Num => Header_Num, - Element => Element_Wrapper, - Elmt_Ptr => Elmt_Ptr, - Null_Ptr => null, - Set_Next => Set_Next, - Next => Next, - Key => Key, - Get_Key => Get_Key, - Hash => Hash, - Equal => Equal); - - --------- - -- Get -- - --------- - - function Get (K : Key) return Element is - Tmp : constant Elmt_Ptr := Tab.Get (K); - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get; - - --------------- - -- Get_First -- - --------------- - - function Get_First return Element is - Tmp : constant Elmt_Ptr := Tab.Get_First; - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get_First; - - procedure Get_First (K : in out Key; E : out Element) is - Tmp : constant Elmt_Ptr := Tab.Get_First; - begin - if Tmp = null then - E := No_Element; - else - K := Tmp.K; - E := Tmp.E; - end if; - end Get_First; - - ------------- - -- Get_Key -- - ------------- - - function Get_Key (E : Elmt_Ptr) return Key is - begin - return E.K; - end Get_Key; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next return Element is - Tmp : constant Elmt_Ptr := Tab.Get_Next; - begin - if Tmp = null then - return No_Element; - else - return Tmp.E; - end if; - end Get_Next; - - procedure Get_Next (K : in out Key; E : out Element) is - Tmp : constant Elmt_Ptr := Tab.Get_Next; - begin - if Tmp = null then - E := No_Element; - else - K := Tmp.K; - E := Tmp.E; - end if; - end Get_Next; - - ---------- - -- Next -- - ---------- - - function Next (E : Elmt_Ptr) return Elmt_Ptr is - begin - return E.Next; - end Next; - - ------------ - -- Remove -- - ------------ - - procedure Remove (K : Key) is - Tmp : Elmt_Ptr; - - begin - Tmp := Tab.Get (K); - - if Tmp /= null then - Tab.Remove (K); - Free (Tmp); - end if; - end Remove; - - ----------- - -- Reset -- - ----------- - - procedure Reset is - E1, E2 : Elmt_Ptr; - - begin - E1 := Tab.Get_First; - while E1 /= null loop - E2 := Tab.Get_Next; - Free (E1); - E1 := E2; - end loop; - - Tab.Reset; - end Reset; - - --------- - -- Set -- - --------- - - procedure Set (K : Key; E : Element) is - Tmp : constant Elmt_Ptr := Tab.Get (K); - begin - if Tmp = null then - Tab.Set (new Element_Wrapper'(K, E, null)); - else - Tmp.E := E; - end if; - end Set; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is - begin - E.Next := Next; - end Set_Next; - end Simple_HTable; - - ---------- - -- Hash -- - ---------- - - function Hash (Key : String) return Header_Num is - type Uns is mod 2 ** 32; - - function Hash_Fun is - new System.String_Hash.Hash (Character, String, Uns); - - begin - return Header_Num'First + - Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length); - end Hash; - -end System.HTable; diff --git a/gcc/ada/s-htable.ads b/gcc/ada/s-htable.ads deleted file mode 100644 index 86fb563..0000000 --- a/gcc/ada/s-htable.ads +++ /dev/null @@ -1,222 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . H T A B L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Hash table searching routines - --- This package contains two separate packages. The Simple_HTable package --- provides a very simple abstraction that associates one element to one --- key value and takes care of all allocations automatically using the heap. --- The Static_HTable package provides a more complex interface that allows --- complete control over allocation. - -pragma Compiler_Unit_Warning; - -package System.HTable is - pragma Preelaborate; - - ------------------- - -- Simple_HTable -- - ------------------- - - -- A simple hash table abstraction, easy to instantiate, easy to use. - -- The table associates one element to one key with the procedure Set. - -- Get retrieves the Element stored for a given Key. The efficiency of - -- retrieval is function of the size of the Table parameterized by - -- Header_Num and the hashing function Hash. - - generic - type Header_Num is range <>; - -- An integer type indicating the number and range of hash headers - - type Element is private; - -- The type of element to be stored - - No_Element : Element; - -- The object that is returned by Get when no element has been set for - -- a given key - - type Key is private; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; - - package Simple_HTable is - - procedure Set (K : Key; E : Element); - -- Associates an element with a given key. Overrides any previously - -- associated element. - - procedure Reset; - -- Removes and frees all elements in the table - - function Get (K : Key) return Element; - -- Returns the Element associated with a key or No_Element if the - -- given key has no associated element. - - procedure Remove (K : Key); - -- Removes the latest inserted element pointer associated with the - -- given key if any, does nothing if none. - - function Get_First return Element; - -- Returns No_Element if the HTable is empty, otherwise returns one - -- non specified element. There is no guarantee that two calls to this - -- function will return the same element. - - function Get_Next return Element; - -- Returns a non-specified element that has not been returned by the - -- same function since the last call to Get_First or No_Element if - -- there is no such element. If there is no call to Set in between - -- Get_Next calls, all the elements of the HTable will be traversed. - - procedure Get_First (K : in out Key; E : out Element); - -- This version of the iterator returns a key/element pair. A non- - -- specified entry is returned, and there is no guarantee that two - -- calls to this procedure will return the same element. If the table - -- is empty, E is set to No_Element, and K is unchanged, otherwise - -- K and E are set to the first returned entry. - - procedure Get_Next (K : in out Key; E : out Element); - -- This version of the iterator returns a key/element pair. It returns - -- a non-specified element that has not been returned since the last - -- call to Get_First. If there is no remaining element, then E is set - -- to No_Element, and the value in K is unchanged, otherwise K and E - -- are set to the next entry. If there is no call to Set in between - -- Get_Next calls, all the elements of the HTable will be traversed. - - end Simple_HTable; - - ------------------- - -- Static_HTable -- - ------------------- - - -- A low-level Hash-Table abstraction, not as easy to instantiate as - -- Simple_HTable but designed to allow complete control over the - -- allocation of necessary data structures. Particularly useful when - -- dynamic allocation is not desired. The model is that each Element - -- contains its own Key that can be retrieved by Get_Key. Furthermore, - -- Element provides a link that can be used by the HTable for linking - -- elements with same hash codes: - - -- Element - - -- +-------------------+ - -- | Key | - -- +-------------------+ - -- : other data : - -- +-------------------+ - -- | Next Elmt | - -- +-------------------+ - - generic - type Header_Num is range <>; - -- An integer type indicating the number and range of hash headers - - type Element (<>) is limited private; - -- The type of element to be stored. This is historically part of the - -- interface, even though it is not used at all in the operations of - -- the package. - - pragma Warnings (Off, Element); - -- We have to kill warnings here, because Element is and always - -- has been unreferenced, but we cannot remove it at this stage, - -- since this unit is in wide use, and it certainly seems harmless. - - type Elmt_Ptr is private; - -- The type used to reference an element (will usually be an access - -- type, but could be some other form of type such as an integer type). - - Null_Ptr : Elmt_Ptr; - -- The null value of the Elmt_Ptr type - - with procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr); - with function Next (E : Elmt_Ptr) return Elmt_Ptr; - -- The type must provide an internal link for the sake of the - -- staticness of the HTable. - - type Key is limited private; - with function Get_Key (E : Elmt_Ptr) return Key; - with function Hash (F : Key) return Header_Num; - with function Equal (F1, F2 : Key) return Boolean; - - package Static_HTable is - - procedure Reset; - -- Resets the hash table by setting all its elements to Null_Ptr. The - -- effect is to clear the hash table so that it can be reused. For the - -- most common case where Elmt_Ptr is an access type, and Null_Ptr is - -- null, this is only needed if the same table is reused in a new - -- context. If Elmt_Ptr is other than an access type, or Null_Ptr is - -- other than null, then Reset must be called before the first use - -- of the hash table. - - procedure Set (E : Elmt_Ptr); - -- Insert the element pointer in the HTable - - function Get (K : Key) return Elmt_Ptr; - -- Returns the latest inserted element pointer with the given Key - -- or null if none. - - function Present (K : Key) return Boolean; - -- True if an element whose Get_Key is K is in the table - - function Set_If_Not_Present (E : Elmt_Ptr) return Boolean; - -- If Present (Get_Key (E)), returns False. Otherwise, does Set (E), and - -- then returns True. Present (Get_Key (E)) is always True afterward, - -- and the result True indicates E is newly Set. - - procedure Remove (K : Key); - -- Removes the latest inserted element pointer associated with the - -- given key if any, does nothing if none. - - function Get_First return Elmt_Ptr; - -- Returns Null_Ptr if the HTable is empty, otherwise returns one - -- non specified element. There is no guarantee that two calls to this - -- function will return the same element. - - function Get_Next return Elmt_Ptr; - -- Returns a non-specified element that has not been returned by the - -- same function since the last call to Get_First or Null_Ptr if - -- there is no such element or Get_First has never been called. If - -- there is no call to 'Set' in between Get_Next calls, all the - -- elements of the HTable will be traversed. - - end Static_HTable; - - ---------- - -- Hash -- - ---------- - - -- A generic hashing function working on String keys - - generic - type Header_Num is range <>; - function Hash (Key : String) return Header_Num; - -end System.HTable; diff --git a/gcc/ada/s-imenne.adb b/gcc/ada/s-imenne.adb deleted file mode 100644 index 9f2a56e..0000000 --- a/gcc/ada/s-imenne.adb +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M _ N E W -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; - -package body System.Img_Enum_New is - - ------------------------- - -- Image_Enumeration_8 -- - ------------------------- - - procedure Image_Enumeration_8 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - is - pragma Assert (S'First = 1); - - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - begin - S (1 .. Next - Start) := Names (Start .. Next - 1); - P := Next - Start; - end Image_Enumeration_8; - - -------------------------- - -- Image_Enumeration_16 -- - -------------------------- - - procedure Image_Enumeration_16 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - is - pragma Assert (S'First = 1); - - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - begin - S (1 .. Next - Start) := Names (Start .. Next - 1); - P := Next - Start; - end Image_Enumeration_16; - - -------------------------- - -- Image_Enumeration_32 -- - -------------------------- - - procedure Image_Enumeration_32 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address) - is - pragma Assert (S'First = 1); - - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - begin - S (1 .. Next - Start) := Names (Start .. Next - 1); - P := Next - Start; - end Image_Enumeration_32; - -end System.Img_Enum_New; diff --git a/gcc/ada/s-imenne.ads b/gcc/ada/s-imenne.ads deleted file mode 100644 index 3726720..0000000 --- a/gcc/ada/s-imenne.ads +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M _ N E W -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Enumeration_Type'Image for all enumeration types except those in package --- Standard (where we have no opportunity to build image tables), and in --- package System (where it is too early to start building image tables). --- Special routines exist for the enumeration types in these packages. - --- This is the new version of the package, for use by compilers built after --- Nov 21st, 2007, which provides procedures that avoid using the secondary --- stack. The original package System.Img_Enum is maintained in the sources --- for bootstrapping with older versions of the compiler which expect to find --- functions in this package. - -pragma Compiler_Unit_Warning; - -package System.Img_Enum_New is - pragma Pure; - - procedure Image_Enumeration_8 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Used to compute Enum'Image (Str) where Enum is some enumeration type - -- other than those defined in package Standard. Names is a string with - -- a lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address of - -- an array of type array (0 .. N) of Natural_8, where N is the number of - -- enumeration literals in the type. The Indexes values are the starting - -- subscript of each enumeration literal, indexed by Pos values, with an - -- extra entry at the end containing Names'Length + 1. The reason that - -- Indexes is passed by address is that the actual type is created on the - -- fly by the expander. The desired 'Image value is stored in S (1 .. P) - -- and P is set on return. The caller guarantees that S is long enough to - -- hold the result and that the lower bound is 1. - - procedure Image_Enumeration_16 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Identical to Set_Image_Enumeration_8 except that it handles types using - -- array (0 .. Num) of Natural_16 for the Indexes table. - - procedure Image_Enumeration_32 - (Pos : Natural; - S : in out String; - P : out Natural; - Names : String; - Indexes : System.Address); - -- Identical to Set_Image_Enumeration_8 except that it handles types using - -- array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Img_Enum_New; diff --git a/gcc/ada/s-imgbiu.adb b/gcc/ada/s-imgbiu.adb deleted file mode 100644 index 66c76f5..0000000 --- a/gcc/ada/s-imgbiu.adb +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ B I U -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Img_BIU is - - ----------------------------- - -- Set_Image_Based_Integer -- - ----------------------------- - - procedure Set_Image_Based_Integer - (V : Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Based_Unsigned (Unsigned (V), B, W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Based_Unsigned (Unsigned (-V), B, W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Based_Integer; - - ------------------------------ - -- Set_Image_Based_Unsigned -- - ------------------------------ - - procedure Set_Image_Based_Unsigned - (V : Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - BU : constant Unsigned := Unsigned (B); - Hex : constant array - (Unsigned range 0 .. 15) of Character := "0123456789ABCDEF"; - - procedure Set_Digits (T : Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Unsigned) is - begin - if T >= BU then - Set_Digits (T / BU); - P := P + 1; - S (P) := Hex (T mod BU); - else - P := P + 1; - S (P) := Hex (T); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Based_Unsigned - - begin - - if B >= 10 then - P := P + 1; - S (P) := '1'; - end if; - - P := P + 1; - S (P) := Character'Val (Character'Pos ('0') + B mod 10); - - P := P + 1; - S (P) := '#'; - - Set_Digits (V); - - P := P + 1; - S (P) := '#'; - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := Start + W; - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Based_Unsigned; - -end System.Img_BIU; diff --git a/gcc/ada/s-imgbiu.ads b/gcc/ada/s-imgbiu.ads deleted file mode 100644 index 987b8b0..0000000 --- a/gcc/ada/s-imgbiu.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ B I U -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Contains the routine for computing the image in based format of signed and --- unsigned integers whose size <= Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. - -with System.Unsigned_Types; - -package System.Img_BIU is - pragma Pure; - - procedure Set_Image_Based_Integer - (V : Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the signed image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes a leading minus sign if necessary, but no leading - -- spaces unless W is positive, in which case leading spaces are output if - -- necessary to ensure that the output string is no less than W characters - -- long. The caller promises that the buffer is large enough and no check - -- is made for this. Constraint_Error will not necessarily be raised if - -- this is violated, since it is perfectly valid to compile this unit with - -- checks off. - - procedure Set_Image_Based_Unsigned - (V : System.Unsigned_Types.Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the unsigned image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes no leading spaces unless W is positive, in which case - -- leading spaces are output if necessary to ensure that the output string - -- is no less than W characters long. The caller promises that the buffer - -- is large enough and no check is made for this. Constraint_Error will not - -- necessarily be raised if this is violated, since it is perfectly valid - -- to compile this unit with checks off). - -end System.Img_BIU; diff --git a/gcc/ada/s-imgboo.adb b/gcc/ada/s-imgboo.adb deleted file mode 100644 index 1fc21e7..0000000 --- a/gcc/ada/s-imgboo.adb +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ B O O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Img_Bool is - - ------------------- - -- Image_Boolean -- - ------------------- - - procedure Image_Boolean - (V : Boolean; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - if V then - S (1 .. 4) := "TRUE"; - P := 4; - else - S (1 .. 5) := "FALSE"; - P := 5; - end if; - end Image_Boolean; - -end System.Img_Bool; diff --git a/gcc/ada/s-imgboo.ads b/gcc/ada/s-imgboo.ads deleted file mode 100644 index e97e87d..0000000 --- a/gcc/ada/s-imgboo.ads +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ B O O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Boolean'Image - -package System.Img_Bool is - pragma Pure; - - procedure Image_Boolean - (V : Boolean; - S : in out String; - P : out Natural); - -- Computes Boolean'Image (V) and stores the result in S (1 .. P) - -- setting the resulting value of P. The caller guarantees that S - -- is long enough to hold the result, and that S'First is 1. - -end System.Img_Bool; diff --git a/gcc/ada/s-imgcha.adb b/gcc/ada/s-imgcha.adb deleted file mode 100644 index bd60dc2..0000000 --- a/gcc/ada/s-imgcha.adb +++ /dev/null @@ -1,180 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Img_Char is - - --------------------- - -- Image_Character -- - --------------------- - - procedure Image_Character - (V : Character; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - subtype Cname is String (1 .. 3); - - subtype C0_Range is Character - range Character'Val (16#00#) .. Character'Val (16#1F#); - - C0 : constant array (C0_Range) of Cname := - (Character'Val (16#00#) => "NUL", - Character'Val (16#01#) => "SOH", - Character'Val (16#02#) => "STX", - Character'Val (16#03#) => "ETX", - Character'Val (16#04#) => "EOT", - Character'Val (16#05#) => "ENQ", - Character'Val (16#06#) => "ACK", - Character'Val (16#07#) => "BEL", - Character'Val (16#08#) => "BS ", - Character'Val (16#09#) => "HT ", - Character'Val (16#0A#) => "LF ", - Character'Val (16#0B#) => "VT ", - Character'Val (16#0C#) => "FF ", - Character'Val (16#0D#) => "CR ", - Character'Val (16#0E#) => "SO ", - Character'Val (16#0F#) => "SI ", - Character'Val (16#10#) => "DLE", - Character'Val (16#11#) => "DC1", - Character'Val (16#12#) => "DC2", - Character'Val (16#13#) => "DC3", - Character'Val (16#14#) => "DC4", - Character'Val (16#15#) => "NAK", - Character'Val (16#16#) => "SYN", - Character'Val (16#17#) => "ETB", - Character'Val (16#18#) => "CAN", - Character'Val (16#19#) => "EM ", - Character'Val (16#1A#) => "SUB", - Character'Val (16#1B#) => "ESC", - Character'Val (16#1C#) => "FS ", - Character'Val (16#1D#) => "GS ", - Character'Val (16#1E#) => "RS ", - Character'Val (16#1F#) => "US "); - - subtype C1_Range is Character - range Character'Val (16#7F#) .. Character'Val (16#9F#); - - C1 : constant array (C1_Range) of Cname := - (Character'Val (16#7F#) => "DEL", - Character'Val (16#80#) => "res", - Character'Val (16#81#) => "res", - Character'Val (16#82#) => "BPH", - Character'Val (16#83#) => "NBH", - Character'Val (16#84#) => "res", - Character'Val (16#85#) => "NEL", - Character'Val (16#86#) => "SSA", - Character'Val (16#87#) => "ESA", - Character'Val (16#88#) => "HTS", - Character'Val (16#89#) => "HTJ", - Character'Val (16#8A#) => "VTS", - Character'Val (16#8B#) => "PLD", - Character'Val (16#8C#) => "PLU", - Character'Val (16#8D#) => "RI ", - Character'Val (16#8E#) => "SS2", - Character'Val (16#8F#) => "SS3", - Character'Val (16#90#) => "DCS", - Character'Val (16#91#) => "PU1", - Character'Val (16#92#) => "PU2", - Character'Val (16#93#) => "STS", - Character'Val (16#94#) => "CCH", - Character'Val (16#95#) => "MW ", - Character'Val (16#96#) => "SPA", - Character'Val (16#97#) => "EPA", - Character'Val (16#98#) => "SOS", - Character'Val (16#99#) => "res", - Character'Val (16#9A#) => "SCI", - Character'Val (16#9B#) => "CSI", - Character'Val (16#9C#) => "ST ", - Character'Val (16#9D#) => "OSC", - Character'Val (16#9E#) => "PM ", - Character'Val (16#9F#) => "APC"); - - begin - -- Control characters are represented by their names (RM 3.5(32)) - - if V in C0_Range then - S (1 .. 3) := C0 (V); - P := (if S (3) = ' ' then 2 else 3); - - elsif V in C1_Range then - S (1 .. 3) := C1 (V); - - if S (1) /= 'r' then - P := (if S (3) = ' ' then 2 else 3); - - -- Special case, res means RESERVED_nnn where nnn is the three digit - -- decimal value corresponding to the code position (more efficient - -- to compute than to store). - - else - declare - VP : constant Natural := Character'Pos (V); - begin - S (1 .. 9) := "RESERVED_"; - S (10) := Character'Val (48 + VP / 100); - S (11) := Character'Val (48 + (VP / 10) mod 10); - S (12) := Character'Val (48 + VP mod 10); - P := 12; - end; - end if; - - -- Normal characters yield the character enclosed in quotes (RM 3.5(32)) - - else - S (1) := '''; - S (2) := V; - S (3) := '''; - P := 3; - end if; - end Image_Character; - - ------------------------ - -- Image_Character_05 -- - ------------------------ - - procedure Image_Character_05 - (V : Character; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - if V = Character'Val (16#00AD#) then - P := 11; - S (1 .. P) := "SOFT_HYPHEN"; - else - Image_Character (V, S, P); - end if; - end Image_Character_05; - -end System.Img_Char; diff --git a/gcc/ada/s-imgcha.ads b/gcc/ada/s-imgcha.ads deleted file mode 100644 index 6faf2f3..0000000 --- a/gcc/ada/s-imgcha.ads +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Character'Image - -package System.Img_Char is - pragma Pure; - - procedure Image_Character - (V : Character; - S : in out String; - P : out Natural); - -- Computes Character'Image (V) and stores the result in S (1 .. P) - -- setting the resulting value of P. The caller guarantees that S is - -- long enough to hold the result, and that S'First is 1. - - procedure Image_Character_05 - (V : Character; - S : in out String; - P : out Natural); - -- Computes Character'Image (V) and stores the result in S (1 .. P) - -- setting the resulting value of P. The caller guarantees that S is - -- long enough to hold the result, and that S'First is 1. This version - -- is for use in Ada 2005 and beyond, where soft hyphen is a non-graphic - -- and results in "SOFT_HYPHEN" as the output. - -end System.Img_Char; diff --git a/gcc/ada/s-imgdec.adb b/gcc/ada/s-imgdec.adb deleted file mode 100644 index bbd2943..0000000 --- a/gcc/ada/s-imgdec.adb +++ /dev/null @@ -1,420 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Img_Int; use System.Img_Int; - -package body System.Img_Dec is - - ------------------- - -- Image_Decimal -- - ------------------- - - procedure Image_Decimal - (V : Integer; - S : in out String; - P : out Natural; - Scale : Integer) - is - pragma Assert (S'First = 1); - - begin - -- Add space at start for non-negative numbers - - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Decimal (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); - end Image_Decimal; - - ------------------------ - -- Set_Decimal_Digits -- - ------------------------ - - procedure Set_Decimal_Digits - (Digs : in out String; - NDigs : Natural; - S : out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural) - is - Minus : constant Boolean := (Digs (Digs'First) = '-'); - -- Set True if input is negative - - Zero : Boolean := (Digs (Digs'First + 1) = '0'); - -- Set True if input is exactly zero (only case when a leading zero - -- is permitted in the input string given to this procedure). This - -- flag can get set later if rounding causes the value to become zero. - - FD : Natural := 2; - -- First digit position of digits remaining to be processed - - LD : Natural := NDigs; - -- Last digit position of digits remaining to be processed - - ND : Natural := NDigs - 1; - -- Number of digits remaining to be processed (LD - FD + 1) - - Digits_Before_Point : Integer := ND - Scale; - -- Number of digits before decimal point in the input value. This - -- value can be negative if the input value is less than 0.1, so - -- it is an indication of the current exponent. Digits_Before_Point - -- is adjusted if the rounding step generates an extra digit. - - Digits_After_Point : constant Natural := Integer'Max (1, Aft); - -- Digit positions after decimal point in result string - - Expon : Integer; - -- Integer value of exponent - - procedure Round (N : Integer); - -- Round the number in Digs. N is the position of the last digit to be - -- retained in the rounded position (rounding is based on Digs (N + 1) - -- FD, LD, ND are reset as necessary if required. Note that if the - -- result value rounds up (e.g. 9.99 => 10.0), an extra digit can be - -- placed in the sign position as a result of the rounding, this is - -- the case in which FD is adjusted. The call to Round has no effect - -- if N is outside the range FD .. LD. - - procedure Set (C : Character); - pragma Inline (Set); - -- Sets character C in output buffer - - procedure Set_Blanks_And_Sign (N : Integer); - -- Sets leading blanks and minus sign if needed. N is the number of - -- positions to be filled (a minus sign is output even if N is zero - -- or negative, For a positive value, if N is non-positive, then - -- a leading blank is filled. - - procedure Set_Digits (S, E : Natural); - pragma Inline (Set_Digits); - -- Set digits S through E from Digs, no effect if S > E - - procedure Set_Zeroes (N : Integer); - pragma Inline (Set_Zeroes); - -- Set N zeroes, no effect if N is negative - - ----------- - -- Round -- - ----------- - - procedure Round (N : Integer) is - D : Character; - - begin - -- Nothing to do if rounding past the last digit we have - - if N >= LD then - return; - - -- Cases of rounding before the initial digit - - elsif N < FD then - - -- The result is zero, unless we are rounding just before - -- the first digit, and the first digit is five or more. - - if N = 1 and then Digs (Digs'First + 1) >= '5' then - Digs (Digs'First) := '1'; - else - Digs (Digs'First) := '0'; - Zero := True; - end if; - - Digits_Before_Point := Digits_Before_Point + 1; - FD := 1; - LD := 1; - ND := 1; - - -- Normal case of rounding an existing digit - - else - LD := N; - ND := LD - 1; - - if Digs (N + 1) >= '5' then - for J in reverse 2 .. N loop - D := Character'Succ (Digs (J)); - - if D <= '9' then - Digs (J) := D; - return; - else - Digs (J) := '0'; - end if; - end loop; - - -- Here the rounding overflows into the sign position. That's - -- OK, because we already captured the value of the sign and - -- we are in any case destroying the value in the Digs buffer - - Digs (Digs'First) := '1'; - FD := 1; - ND := ND + 1; - Digits_Before_Point := Digits_Before_Point + 1; - end if; - end if; - end Round; - - --------- - -- Set -- - --------- - - procedure Set (C : Character) is - begin - P := P + 1; - S (P) := C; - end Set; - - ------------------------- - -- Set_Blanks_And_Sign -- - ------------------------- - - procedure Set_Blanks_And_Sign (N : Integer) is - W : Integer := N; - - begin - if Minus then - W := W - 1; - - for J in 1 .. W loop - Set (' '); - end loop; - - Set ('-'); - - else - for J in 1 .. W loop - Set (' '); - end loop; - end if; - end Set_Blanks_And_Sign; - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (S, E : Natural) is - begin - for J in S .. E loop - Set (Digs (J)); - end loop; - end Set_Digits; - - ---------------- - -- Set_Zeroes -- - ---------------- - - procedure Set_Zeroes (N : Integer) is - begin - for J in 1 .. N loop - Set ('0'); - end loop; - end Set_Zeroes; - - -- Start of processing for Set_Decimal_Digits - - begin - -- Case of exponent given - - if Exp > 0 then - Set_Blanks_And_Sign (Fore - 1); - Round (Digits_After_Point + 2); - Set (Digs (FD)); - FD := FD + 1; - ND := ND - 1; - Set ('.'); - - if ND >= Digits_After_Point then - Set_Digits (FD, FD + Digits_After_Point - 1); - else - Set_Digits (FD, LD); - Set_Zeroes (Digits_After_Point - ND); - end if; - - -- Calculate exponent. The number of digits before the decimal point - -- in the input is Digits_Before_Point, and the number of digits - -- before the decimal point in the output is 1, so we can get the - -- exponent as the difference between these two values. The one - -- exception is for the value zero, which by convention has an - -- exponent of +0. - - Expon := (if Zero then 0 else Digits_Before_Point - 1); - Set ('E'); - ND := 0; - - if Expon >= 0 then - Set ('+'); - Set_Image_Integer (Expon, Digs, ND); - else - Set ('-'); - Set_Image_Integer (-Expon, Digs, ND); - end if; - - Set_Zeroes (Exp - ND - 1); - Set_Digits (1, ND); - return; - - -- Case of no exponent given. To make these cases clear, we use - -- examples. For all the examples, we assume Fore = 2, Aft = 3. - -- A P in the example input string is an implied zero position, - -- not included in the input string. - - else - -- Round at correct position - -- Input: 4PP => unchanged - -- Input: 400.03 => unchanged - -- Input 3.4567 => 3.457 - -- Input: 9.9999 => 10.000 - -- Input: 0.PPP5 => 0.001 - -- Input: 0.PPP4 => 0 - -- Input: 0.00003 => 0 - - Round (LD - (Scale - Digits_After_Point)); - - -- No digits before point in input - -- Input: .123 Output: 0.123 - -- Input: .PP3 Output: 0.003 - - if Digits_Before_Point <= 0 then - Set_Blanks_And_Sign (Fore - 1); - Set ('0'); - Set ('.'); - - declare - DA : Natural := Digits_After_Point; - -- Digits remaining to output after point - - LZ : constant Integer := Integer'Min (DA, -Digits_Before_Point); - -- Number of leading zeroes after point. Note: there used to be - -- a Max of this result with zero, but that's redundant, since - -- we know DA is positive, and because of the test above, we - -- know that -Digits_Before_Point >= 0. - - begin - Set_Zeroes (LZ); - DA := DA - LZ; - - if DA < ND then - - -- Note: it is definitely possible for the above condition - -- to be True, for example: - - -- V => 1234, Scale => 5, Fore => 0, After => 1, Exp => 0 - - -- but in this case DA = 0, ND = 1, FD = 1, FD + DA-1 = 0 - -- so the arguments in the call are (1, 0) meaning that no - -- digits are output. - - -- No obvious example exists where the following call to - -- Set_Digits actually outputs some digits, but we lack a - -- proof that no such example exists. - - -- So it is safer to retain this call, even though as a - -- result it is hard (or perhaps impossible) to create a - -- coverage test for the inlined code of the call. - - Set_Digits (FD, FD + DA - 1); - - else - Set_Digits (FD, LD); - Set_Zeroes (DA - ND); - end if; - end; - - -- At least one digit before point in input - - else - -- Less digits in input than are needed before point - -- Input: 1PP Output: 100.000 - - if ND < Digits_Before_Point then - - -- Special case, if the input is the single digit 0, then we - -- do not want 000.000, but instead 0.000. - - if ND = 1 and then Digs (FD) = '0' then - Set_Blanks_And_Sign (Fore - 1); - Set ('0'); - - -- Normal case where we need to output scaling zeroes - - else - Set_Blanks_And_Sign (Fore - Digits_Before_Point); - Set_Digits (FD, LD); - Set_Zeroes (Digits_Before_Point - ND); - end if; - - -- Set period and zeroes after the period - - Set ('.'); - Set_Zeroes (Digits_After_Point); - - -- Input has full amount of digits before decimal point - - else - Set_Blanks_And_Sign (Fore - Digits_Before_Point); - Set_Digits (FD, FD + Digits_Before_Point - 1); - Set ('.'); - Set_Digits (FD + Digits_Before_Point, LD); - Set_Zeroes (Digits_After_Point - (ND - Digits_Before_Point)); - end if; - end if; - end if; - end Set_Decimal_Digits; - - ----------------------- - -- Set_Image_Decimal -- - ----------------------- - - procedure Set_Image_Decimal - (V : Integer; - S : in out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural) - is - Digs : String := Integer'Image (V); - -- Sign and digits of decimal value - - begin - Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); - end Set_Image_Decimal; - -end System.Img_Dec; diff --git a/gcc/ada/s-imgdec.ads b/gcc/ada/s-imgdec.ads deleted file mode 100644 index 1bc2135..0000000 --- a/gcc/ada/s-imgdec.ads +++ /dev/null @@ -1,83 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ D E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Image for decimal fixed types where the size of the corresponding integer --- type does not exceed Integer'Size (also used for Text_IO.Decimal_IO output) - -package System.Img_Dec is - pragma Pure; - - procedure Image_Decimal - (V : Integer; - S : in out String; - P : out Natural; - Scale : Integer); - -- Computes fixed_type'Image (V), where V is the integer value (in units of - -- delta) of a decimal type whose Scale is as given and stores the result - -- S (1 .. P), updating P to the value of L. The image is given by the - -- rules in RM 3.5(34) for fixed-point type image functions. The caller - -- guarantees that S is long enough to hold the result. S need not have a - -- lower bound of 1. - - procedure Set_Image_Decimal - (V : Integer; - S : in out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural); - -- Sets the image of V, where V is the integer value (in units of delta) - -- of a decimal type with the given Scale, starting at S (P + 1), updating - -- P to point to the last character stored, the caller promises that the - -- buffer is large enough and no check is made for this. Constraint_Error - -- will not necessarily be raised if this requirement is violated, since - -- it is perfectly valid to compile this unit with checks off. The Fore, - -- Aft and Exp values can be set to any valid values for the case of use - -- by Text_IO.Decimal_IO. Note that there is no leading space stored. - - procedure Set_Decimal_Digits - (Digs : in out String; - NDigs : Natural; - S : out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural); - -- This procedure has the same semantics as Set_Image_Decimal, except that - -- the value in Digs (1 .. NDigs) is given as a string of decimal digits - -- preceded by either a minus sign or a space (i.e. the integer image of - -- the value in units of delta). The call may destroy the value in Digs, - -- which is why Digs is in-out (this happens if rounding is required). - -- Set_Decimal_Digits is shared by all the decimal image routines. - -end System.Img_Dec; diff --git a/gcc/ada/s-imgenu.adb b/gcc/ada/s-imgenu.adb deleted file mode 100644 index 96d1332..0000000 --- a/gcc/ada/s-imgenu.adb +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M -- --- -- --- B o d y -- --- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; - -package body System.Img_Enum is - - ------------------------- - -- Image_Enumeration_8 -- - ------------------------- - - function Image_Enumeration_8 - (Pos : Natural; - Names : String; - Indexes : System.Address) - return String - is - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - subtype Result_Type is String (1 .. Next - Start); - -- We need this result type to force the result to have the - -- required lower bound of 1, rather than the slice bounds. - - begin - return Result_Type (Names (Start .. Next - 1)); - end Image_Enumeration_8; - - -------------------------- - -- Image_Enumeration_16 -- - -------------------------- - - function Image_Enumeration_16 - (Pos : Natural; - Names : String; - Indexes : System.Address) - return String - is - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - subtype Result_Type is String (1 .. Next - Start); - -- We need this result type to force the result to have the - -- required lower bound of 1, rather than the slice bounds. - - begin - return Result_Type (Names (Start .. Next - 1)); - end Image_Enumeration_16; - - -------------------------- - -- Image_Enumeration_32 -- - -------------------------- - - function Image_Enumeration_32 - (Pos : Natural; - Names : String; - Indexes : System.Address) - return String - is - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - Start : constant Natural := Natural (IndexesT (Pos)); - Next : constant Natural := Natural (IndexesT (Pos + 1)); - - subtype Result_Type is String (1 .. Next - Start); - -- We need this result type to force the result to have the - -- required lower bound of 1, rather than the slice bounds. - - begin - return Result_Type (Names (Start .. Next - 1)); - end Image_Enumeration_32; - -end System.Img_Enum; diff --git a/gcc/ada/s-imgenu.ads b/gcc/ada/s-imgenu.ads deleted file mode 100644 index ef5474a..0000000 --- a/gcc/ada/s-imgenu.ads +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ E N U M -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Enumeration_Type'Image for all enumeration types except those in package --- Standard (where we have no opportunity to build image tables), and in --- package System (where it is too early to start building image tables). --- Special routines exist for the enumeration types in these packages. - --- Note: this is an obsolete package, replaced by System.Img_Enum_New, which --- provides procedures instead of functions for these enumeration image calls. --- The reason we maintain this package is that when bootstrapping with old --- compilers, the old compiler will search for this unit, expecting to find --- these functions. The new compiler will search for procedures in the new --- version of the unit. - -pragma Compiler_Unit_Warning; - -package System.Img_Enum is - pragma Pure; - - function Image_Enumeration_8 - (Pos : Natural; - Names : String; - Indexes : System.Address) return String; - -- Used to compute Enum'Image (Str) where Enum is some enumeration type - -- other than those defined in package Standard. Names is a string with a - -- lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address of an - -- array of type array (0 .. N) of Natural_8, where N is the number of - -- enumeration literals in the type. The Indexes values are the starting - -- subscript of each enumeration literal, indexed by Pos values, with an - -- extra entry at the end containing Names'Length + 1. The reason that - -- Indexes is passed by address is that the actual type is created on the - -- fly by the expander. The value returned is the desired 'Image value. - - function Image_Enumeration_16 - (Pos : Natural; - Names : String; - Indexes : System.Address) return String; - -- Identical to Image_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_16 for the Indexes table. - - function Image_Enumeration_32 - (Pos : Natural; - Names : String; - Indexes : System.Address) return String; - -- Identical to Image_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Img_Enum; diff --git a/gcc/ada/s-imgint.adb b/gcc/ada/s-imgint.adb deleted file mode 100644 index 0d19e56..0000000 --- a/gcc/ada/s-imgint.adb +++ /dev/null @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ I N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Img_Int is - - procedure Set_Digits - (T : Integer; - S : in out String; - P : in out Natural); - -- Set digits of absolute value of T, which is zero or negative. We work - -- with the negative of the value so that the largest negative number is - -- not a special case. - - ------------------- - -- Image_Integer -- - ------------------- - - procedure Image_Integer - (V : Integer; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - begin - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Integer (V, S, P); - end Image_Integer; - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits - (T : Integer; - S : in out String; - P : in out Natural) - is - begin - if T <= -10 then - Set_Digits (T / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 - (T rem 10)); - else - P := P + 1; - S (P) := Character'Val (48 - T); - end if; - end Set_Digits; - - ----------------------- - -- Set_Image_Integer -- - ----------------------- - - procedure Set_Image_Integer - (V : Integer; - S : in out String; - P : in out Natural) - is - begin - if V >= 0 then - Set_Digits (-V, S, P); - else - P := P + 1; - S (P) := '-'; - Set_Digits (V, S, P); - end if; - end Set_Image_Integer; - -end System.Img_Int; diff --git a/gcc/ada/s-imgint.ads b/gcc/ada/s-imgint.ads deleted file mode 100644 index 3d141f9..0000000 --- a/gcc/ada/s-imgint.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ I N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for supporting the Image attribute for --- signed integer types up to Size Integer'Size, and also for conversion --- operations required in Text_IO.Integer_IO for such types. - -package System.Img_Int is - pragma Pure; - - procedure Image_Integer - (V : Integer; - S : in out String; - P : out Natural); - -- Computes Integer'Image (V) and stores the result in S (1 .. P) - -- setting the resulting value of P. The caller guarantees that S - -- is long enough to hold the result, and that S'First is 1. - - procedure Set_Image_Integer - (V : Integer; - S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Integer'Image (V) except that no leading space is stored when V is - -- non-negative. The caller guarantees that S is long enough to hold the - -- result. S need not have a lower bound of 1. - -end System.Img_Int; diff --git a/gcc/ada/s-imgllb.adb b/gcc/ada/s-imgllb.adb deleted file mode 100644 index 3f0da25..0000000 --- a/gcc/ada/s-imgllb.adb +++ /dev/null @@ -1,161 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L B -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Img_LLB is - - --------------------------------------- - -- Set_Image_Based_Long_Long_Integer -- - --------------------------------------- - - procedure Set_Image_Based_Long_Long_Integer - (V : Long_Long_Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Based_Long_Long_Unsigned - (Long_Long_Unsigned (V), B, W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Based_Long_Long_Unsigned - (Long_Long_Unsigned (-V), B, W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Based_Long_Long_Integer; - - ---------------------------------------- - -- Set_Image_Based_Long_Long_Unsigned -- - ---------------------------------------- - - procedure Set_Image_Based_Long_Long_Unsigned - (V : Long_Long_Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - BU : constant Long_Long_Unsigned := Long_Long_Unsigned (B); - Hex : constant array - (Long_Long_Unsigned range 0 .. 15) of Character := - "0123456789ABCDEF"; - - procedure Set_Digits (T : Long_Long_Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Long_Long_Unsigned) is - begin - if T >= BU then - Set_Digits (T / BU); - P := P + 1; - S (P) := Hex (T mod BU); - else - P := P + 1; - S (P) := Hex (T); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Based_Long_Long_Unsigned - - begin - - if B >= 10 then - P := P + 1; - S (P) := '1'; - end if; - - P := P + 1; - S (P) := Character'Val (Character'Pos ('0') + B mod 10); - - P := P + 1; - S (P) := '#'; - - Set_Digits (V); - - P := P + 1; - S (P) := '#'; - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := Start + W; - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Based_Long_Long_Unsigned; - -end System.Img_LLB; diff --git a/gcc/ada/s-imgllb.ads b/gcc/ada/s-imgllb.ads deleted file mode 100644 index 9c94baa..0000000 --- a/gcc/ada/s-imgllb.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L B -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Contains the routine for computing the image in based format of signed and --- unsigned integers whose size > Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. - -with System.Unsigned_Types; - -package System.Img_LLB is - pragma Preelaborate; - - procedure Set_Image_Based_Long_Long_Integer - (V : Long_Long_Integer; - B : Natural; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the signed image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes a leading minus sign if necessary, but no leading - -- spaces unless W is positive, in which case leading spaces are output if - -- necessary to ensure that the output string is no less than W characters - -- long. The caller promises that the buffer is large enough and no check - -- is made for this. Constraint_Error will not necessarily be raised if - -- this is violated, since it is perfectly valid to compile this unit with - -- checks off. - - procedure Set_Image_Based_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; - B : Natural; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the unsigned image of V in based format, using base value B (2..16) - -- starting at S (P + 1), updating P to point to the last character stored. - -- The image includes no leading spaces unless W is positive, in which case - -- leading spaces are output if necessary to ensure that the output string - -- is no less than W characters long. The caller promises that the buffer - -- is large enough and no check is made for this. Constraint_Error will not - -- necessarily be raised if this is violated, since it is perfectly valid - -- to compile this unit with checks off). - -end System.Img_LLB; diff --git a/gcc/ada/s-imglld.adb b/gcc/ada/s-imglld.adb deleted file mode 100644 index bc938c8..0000000 --- a/gcc/ada/s-imglld.adb +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Img_Dec; use System.Img_Dec; - -package body System.Img_LLD is - - ----------------------------- - -- Image_Long_Long_Decimal -- - ---------------------------- - - procedure Image_Long_Long_Decimal - (V : Long_Long_Integer; - S : in out String; - P : out Natural; - Scale : Integer) - is - pragma Assert (S'First = 1); - - begin - -- Add space at start for non-negative numbers - - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Long_Long_Decimal - (V, S, P, Scale, 1, Integer'Max (1, Scale), 0); - end Image_Long_Long_Decimal; - - --------------------------------- - -- Set_Image_Long_Long_Decimal -- - --------------------------------- - - procedure Set_Image_Long_Long_Decimal - (V : Long_Long_Integer; - S : in out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural) - is - Digs : String := Long_Long_Integer'Image (V); - -- Sign and digits of decimal value - - begin - Set_Decimal_Digits (Digs, Digs'Length, S, P, Scale, Fore, Aft, Exp); - end Set_Image_Long_Long_Decimal; - -end System.Img_LLD; diff --git a/gcc/ada/s-imglld.ads b/gcc/ada/s-imglld.ads deleted file mode 100644 index 86b146b..0000000 --- a/gcc/ada/s-imglld.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Image for decimal fixed types where the size of the corresponding integer --- type does exceeds Integer'Size (also used for Text_IO.Decimal_IO output) - -package System.Img_LLD is - pragma Pure; - - procedure Image_Long_Long_Decimal - (V : Long_Long_Integer; - S : in out String; - P : out Natural; - Scale : Integer); - -- Computes fixed_type'Image (V), where V is the integer value (in units of - -- delta) of a decimal type whose Scale is as given and store the result in - -- S (P + 1 .. L), updating P to the value of L. The image is given by the - -- rules in RM 3.5(34) for fixed-point type image functions. The caller - -- guarantees that S is long enough to hold the result. S need not have a - -- lower bound of 1. - - procedure Set_Image_Long_Long_Decimal - (V : Long_Long_Integer; - S : in out String; - P : in out Natural; - Scale : Integer; - Fore : Natural; - Aft : Natural; - Exp : Natural); - -- Sets the image of V, where V is the integer value (in units of delta) - -- of a decimal type with the given Scale, starting at S (P + 1), updating - -- P to point to the last character stored, the caller promises that the - -- buffer is large enough and no check is made for this. Constraint_Error - -- will not necessarily be raised if this requirement is violated, since - -- it is perfectly valid to compile this unit with checks off. The Fore, - -- Aft and Exp values can be set to any valid values for the case of use - -- by Text_IO.Decimal_IO. Note that there is no leading space stored. - -end System.Img_LLD; diff --git a/gcc/ada/s-imglli.adb b/gcc/ada/s-imglli.adb deleted file mode 100644 index 6c4a783..0000000 --- a/gcc/ada/s-imglli.adb +++ /dev/null @@ -1,102 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L I -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Img_LLI is - - procedure Set_Digits - (T : Long_Long_Integer; - S : in out String; - P : in out Natural); - -- Set digits of absolute value of T, which is zero or negative. We work - -- with the negative of the value so that the largest negative number is - -- not a special case. - - ----------------------------- - -- Image_Long_Long_Integer -- - ----------------------------- - - procedure Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - begin - if V >= 0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Long_Long_Integer (V, S, P); - end Image_Long_Long_Integer; - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits - (T : Long_Long_Integer; - S : in out String; - P : in out Natural) - is - begin - if T <= -10 then - Set_Digits (T / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 - (T rem 10)); - else - P := P + 1; - S (P) := Character'Val (48 - T); - end if; - end Set_Digits; - - --------------------------------- - -- Set_Image_Long_Long_Integer -- - -------------------------------- - - procedure Set_Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : in out Natural) is - begin - if V >= 0 then - Set_Digits (-V, S, P); - else - P := P + 1; - S (P) := '-'; - Set_Digits (V, S, P); - end if; - end Set_Image_Long_Long_Integer; - -end System.Img_LLI; diff --git a/gcc/ada/s-imglli.ads b/gcc/ada/s-imglli.ads deleted file mode 100644 index 8695d95..0000000 --- a/gcc/ada/s-imglli.ads +++ /dev/null @@ -1,57 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for supporting the Image attribute for --- signed integer types larger than Size Integer'Size, and also for conversion --- operations required in Text_IO.Integer_IO for such types. - -package System.Img_LLI is - pragma Pure; - - procedure Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : out Natural); - -- Computes Long_Long_Integer'Image (V) and stores the result in - -- S (1 .. P) setting the resulting value of P. The caller guarantees - -- that S is long enough to hold the result, and that S'First is 1. - - procedure Set_Image_Long_Long_Integer - (V : Long_Long_Integer; - S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Long_Long_Integer'Image (V) except that no leading space is stored - -- when V is non-negative. The caller guarantees that S is long enough to - -- hold the result. S need not have a lower bound of 1. - -end System.Img_LLI; diff --git a/gcc/ada/s-imgllu.adb b/gcc/ada/s-imgllu.adb deleted file mode 100644 index a70908a..0000000 --- a/gcc/ada/s-imgllu.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L U -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Img_LLU is - - ------------------------------ - -- Image_Long_Long_Unsigned -- - ------------------------------ - - procedure Image_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - S (1) := ' '; - P := 1; - Set_Image_Long_Long_Unsigned (V, S, P); - end Image_Long_Long_Unsigned; - - ---------------------------------- - -- Set_Image_Long_Long_Unsigned -- - ---------------------------------- - - procedure Set_Image_Long_Long_Unsigned - (V : Long_Long_Unsigned; - S : in out String; - P : in out Natural) - is - begin - if V >= 10 then - Set_Image_Long_Long_Unsigned (V / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 + (V rem 10)); - - else - P := P + 1; - S (P) := Character'Val (48 + V); - end if; - end Set_Image_Long_Long_Unsigned; - -end System.Img_LLU; diff --git a/gcc/ada/s-imgllu.ads b/gcc/ada/s-imgllu.ads deleted file mode 100644 index f9220c7..0000000 --- a/gcc/ada/s-imgllu.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for supporting the Image attribute for --- unsigned (modular) integer types larger than Size Unsigned'Size, and also --- for conversion operations required in Text_IO.Modular_IO for such types. - -with System.Unsigned_Types; - -package System.Img_LLU is - pragma Pure; - - procedure Image_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; - S : in out String; - P : out Natural); - pragma Inline (Image_Long_Long_Unsigned); - - -- Computes Long_Long_Unsigned'Image (V) and stores the result in - -- S (1 .. P) setting the resulting value of P. The caller guarantees - -- that S is long enough to hold the result, and that S'First is 1. - - procedure Set_Image_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; - S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Long_Long_Unsigned'Image (V) except that no leading space is stored. - -- The caller guarantees that S is long enough to hold the result. S need - -- not have a lower bound of 1. - -end System.Img_LLU; diff --git a/gcc/ada/s-imgllw.adb b/gcc/ada/s-imgllw.adb deleted file mode 100644 index 78d8674..0000000 --- a/gcc/ada/s-imgllw.adb +++ /dev/null @@ -1,140 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L W -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Img_LLW is - - --------------------------------------- - -- Set_Image_Width_Long_Long_Integer -- - --------------------------------------- - - procedure Set_Image_Width_Long_Long_Integer - (V : Long_Long_Integer; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Width_Long_Long_Unsigned - (Long_Long_Unsigned (V), W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Width_Long_Long_Unsigned - (Long_Long_Unsigned (-V), W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Width_Long_Long_Integer; - - ---------------------------------------- - -- Set_Image_Width_Long_Long_Unsigned -- - ---------------------------------------- - - procedure Set_Image_Width_Long_Long_Unsigned - (V : Long_Long_Unsigned; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - - procedure Set_Digits (T : Long_Long_Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Long_Long_Unsigned) is - begin - if T >= 10 then - Set_Digits (T / 10); - P := P + 1; - S (P) := Character'Val (T mod 10 + Character'Pos ('0')); - else - P := P + 1; - S (P) := Character'Val (T + Character'Pos ('0')); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Width_Long_Long_Unsigned - - begin - Set_Digits (V); - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := P + (W - (P - Start)); - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Width_Long_Long_Unsigned; - -end System.Img_LLW; diff --git a/gcc/ada/s-imgllw.ads b/gcc/ada/s-imgllw.ads deleted file mode 100644 index baf4a38..0000000 --- a/gcc/ada/s-imgllw.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ L L W -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Contains the routine for computing the image of signed and unsigned --- integers whose size > Integer'Size for use by Text_IO.Integer_IO, --- Text_IO.Modular_IO. - -with System.Unsigned_Types; - -package System.Img_LLW is - pragma Pure; - - procedure Set_Image_Width_Long_Long_Integer - (V : Long_Long_Integer; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the signed image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes - -- a leading minus sign if necessary, but no leading spaces unless W is - -- positive, in which case leading spaces are output if necessary to ensure - -- that the output string is no less than W characters long. The caller - -- promises that the buffer is large enough and no check is made for this. - -- Constraint_Error will not necessarily be raised if this is violated, - -- since it is perfectly valid to compile this unit with checks off. - - procedure Set_Image_Width_Long_Long_Unsigned - (V : System.Unsigned_Types.Long_Long_Unsigned; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the unsigned image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes no - -- leading spaces unless W is positive, in which case leading spaces are - -- output if necessary to ensure that the output string is no less than - -- W characters long. The caller promises that the buffer is large enough - -- and no check is made for this. Constraint_Error will not necessarily be - -- raised if this is violated, since it is perfectly valid to compile this - -- unit with checks off. - -end System.Img_LLW; diff --git a/gcc/ada/s-imgrea.adb b/gcc/ada/s-imgrea.adb deleted file mode 100644 index 62ec93a..0000000 --- a/gcc/ada/s-imgrea.adb +++ /dev/null @@ -1,699 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ R E A L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Img_LLU; use System.Img_LLU; -with System.Img_Uns; use System.Img_Uns; -with System.Powten_Table; use System.Powten_Table; -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Float_Control; - -package body System.Img_Real is - - -- The following defines the maximum number of digits that we can convert - -- accurately. This is limited by the precision of Long_Long_Float, and - -- also by the number of digits we can hold in Long_Long_Unsigned, which - -- is the integer type we use as an intermediate for the result. - - -- We assume that in practice, the limitation will come from the digits - -- value, rather than the integer value. This is true for typical IEEE - -- implementations, and at worst, the only loss is for some precision - -- in very high precision floating-point output. - - -- Note that in the following, the "-2" accounts for the sign and one - -- extra digits, since we need the maximum number of 9's that can be - -- supported, e.g. for the normal 64 bit case, Long_Long_Integer'Width - -- is 21, since the maximum value (approx 1.6 * 10**19) has 20 digits, - -- but the maximum number of 9's that can be supported is 19. - - Maxdigs : constant := - Natural'Min - (Long_Long_Unsigned'Width - 2, Long_Long_Float'Digits); - - Unsdigs : constant := Unsigned'Width - 2; - -- Number of digits that can be converted using type Unsigned - -- See above for the explanation of the -2. - - Maxscaling : constant := 5000; - -- Max decimal scaling required during conversion of floating-point - -- numbers to decimal. This is used to defend against infinite - -- looping in the conversion, as can be caused by erroneous executions. - -- The largest exponent used on any current system is 2**16383, which - -- is approximately 10**4932, and the highest number of decimal digits - -- is about 35 for 128-bit floating-point formats, so 5000 leaves - -- enough room for scaling such values - - function Is_Negative (V : Long_Long_Float) return Boolean; - pragma Import (Intrinsic, Is_Negative); - - -------------------------- - -- Image_Floating_Point -- - -------------------------- - - procedure Image_Floating_Point - (V : Long_Long_Float; - S : in out String; - P : out Natural; - Digs : Natural) - is - pragma Assert (S'First = 1); - - begin - -- Decide whether a blank should be prepended before the call to - -- Set_Image_Real. We generate a blank for positive values, and - -- also for positive zeroes. For negative zeroes, we generate a - -- space only if Signed_Zeroes is True (the RM only permits the - -- output of -0.0 on targets where this is the case). We can of - -- course still see a -0.0 on a target where Signed_Zeroes is - -- False (since this attribute refers to the proper handling of - -- negative zeroes, not to their existence). We do not generate - -- a blank for positive infinity, since we output an explicit +. - - if (not Is_Negative (V) and then V <= Long_Long_Float'Last) - or else (not Long_Long_Float'Signed_Zeros and then V = -0.0) - then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Real (V, S, P, 1, Digs - 1, 3); - end Image_Floating_Point; - - -------------------------------- - -- Image_Ordinary_Fixed_Point -- - -------------------------------- - - procedure Image_Ordinary_Fixed_Point - (V : Long_Long_Float; - S : in out String; - P : out Natural; - Aft : Natural) - is - pragma Assert (S'First = 1); - - begin - -- Output space at start if non-negative - - if V >= 0.0 then - S (1) := ' '; - P := 1; - else - P := 0; - end if; - - Set_Image_Real (V, S, P, 1, Aft, 0); - end Image_Ordinary_Fixed_Point; - - -------------------- - -- Set_Image_Real -- - -------------------- - - procedure Set_Image_Real - (V : Long_Long_Float; - S : out String; - P : in out Natural; - Fore : Natural; - Aft : Natural; - Exp : Natural) - is - NFrac : constant Natural := Natural'Max (Aft, 1); - Sign : Character; - X : Long_Long_Float; - Scale : Integer; - Expon : Integer; - - Field_Max : constant := 255; - -- This should be the same value as Ada.[Wide_]Text_IO.Field'Last. - -- It is not worth dragging in Ada.Text_IO to pick up this value, - -- since it really should never be necessary to change it. - - Digs : String (1 .. 2 * Field_Max + 16); - -- Array used to hold digits of converted integer value. This is a - -- large enough buffer to accommodate ludicrous values of Fore and Aft. - - Ndigs : Natural; - -- Number of digits stored in Digs (and also subscript of last digit) - - procedure Adjust_Scale (S : Natural); - -- Adjusts the value in X by multiplying or dividing by a power of - -- ten so that it is in the range 10**(S-1) <= X < 10**S. Includes - -- adding 0.5 to round the result, readjusting if the rounding causes - -- the result to wander out of the range. Scale is adjusted to reflect - -- the power of ten used to divide the result (i.e. one is added to - -- the scale value for each division by 10.0, or one is subtracted - -- for each multiplication by 10.0). - - procedure Convert_Integer; - -- Takes the value in X, outputs integer digits into Digs. On return, - -- Ndigs is set to the number of digits stored. The digits are stored - -- in Digs (1 .. Ndigs), - - procedure Set (C : Character); - -- Sets character C in output buffer - - procedure Set_Blanks_And_Sign (N : Integer); - -- Sets leading blanks and minus sign if needed. N is the number of - -- positions to be filled (a minus sign is output even if N is zero - -- or negative, but for a positive value, if N is non-positive, then - -- the call has no effect). - - procedure Set_Digs (S, E : Natural); - -- Set digits S through E from Digs buffer. No effect if S > E - - procedure Set_Special_Fill (N : Natural); - -- After outputting +Inf, -Inf or NaN, this routine fills out the - -- rest of the field with * characters. The argument is the number - -- of characters output so far (either 3 or 4) - - procedure Set_Zeros (N : Integer); - -- Set N zeros, no effect if N is negative - - pragma Inline (Set); - pragma Inline (Set_Digs); - pragma Inline (Set_Zeros); - - ------------------ - -- Adjust_Scale -- - ------------------ - - procedure Adjust_Scale (S : Natural) is - Lo : Natural; - Hi : Natural; - Mid : Natural; - XP : Long_Long_Float; - - begin - -- Cases where scaling up is required - - if X < Powten (S - 1) then - - -- What we are looking for is a power of ten to multiply X by - -- so that the result lies within the required range. - - loop - XP := X * Powten (Maxpow); - exit when XP >= Powten (S - 1) or else Scale < -Maxscaling; - X := XP; - Scale := Scale - Maxpow; - end loop; - - -- The following exception is only raised in case of erroneous - -- execution, where a number was considered valid but still - -- fails to scale up. One situation where this can happen is - -- when a system which is supposed to be IEEE-compliant, but - -- has been reconfigured to flush denormals to zero. - - if Scale < -Maxscaling then - raise Constraint_Error; - end if; - - -- Here we know that we must multiply by at least 10**1 and that - -- 10**Maxpow takes us too far: binary search to find right one. - - -- Because of roundoff errors, it is possible for the value - -- of XP to be just outside of the interval when Lo >= Hi. In - -- that case we adjust explicitly by a factor of 10. This - -- can only happen with a value that is very close to an - -- exact power of 10. - - Lo := 1; - Hi := Maxpow; - - loop - Mid := (Lo + Hi) / 2; - XP := X * Powten (Mid); - - if XP < Powten (S - 1) then - - if Lo >= Hi then - Mid := Mid + 1; - XP := XP * 10.0; - exit; - - else - Lo := Mid + 1; - end if; - - elsif XP >= Powten (S) then - - if Lo >= Hi then - Mid := Mid - 1; - XP := XP / 10.0; - exit; - - else - Hi := Mid - 1; - end if; - - else - exit; - end if; - end loop; - - X := XP; - Scale := Scale - Mid; - - -- Cases where scaling down is required - - elsif X >= Powten (S) then - - -- What we are looking for is a power of ten to divide X by - -- so that the result lies within the required range. - - loop - XP := X / Powten (Maxpow); - exit when XP < Powten (S) or else Scale > Maxscaling; - X := XP; - Scale := Scale + Maxpow; - end loop; - - -- The following exception is only raised in case of erroneous - -- execution, where a number was considered valid but still - -- fails to scale up. One situation where this can happen is - -- when a system which is supposed to be IEEE-compliant, but - -- has been reconfigured to flush denormals to zero. - - if Scale > Maxscaling then - raise Constraint_Error; - end if; - - -- Here we know that we must divide by at least 10**1 and that - -- 10**Maxpow takes us too far, binary search to find right one. - - Lo := 1; - Hi := Maxpow; - - loop - Mid := (Lo + Hi) / 2; - XP := X / Powten (Mid); - - if XP < Powten (S - 1) then - - if Lo >= Hi then - XP := XP * 10.0; - Mid := Mid - 1; - exit; - - else - Hi := Mid - 1; - end if; - - elsif XP >= Powten (S) then - - if Lo >= Hi then - XP := XP / 10.0; - Mid := Mid + 1; - exit; - - else - Lo := Mid + 1; - end if; - - else - exit; - end if; - end loop; - - X := XP; - Scale := Scale + Mid; - - -- Here we are already scaled right - - else - null; - end if; - - -- Round, readjusting scale if needed. Note that if a readjustment - -- occurs, then it is never necessary to round again, because there - -- is no possibility of such a second rounding causing a change. - - X := X + 0.5; - - if X >= Powten (S) then - X := X / 10.0; - Scale := Scale + 1; - end if; - - end Adjust_Scale; - - --------------------- - -- Convert_Integer -- - --------------------- - - procedure Convert_Integer is - begin - -- Use Unsigned routine if possible, since on many machines it will - -- be significantly more efficient than the Long_Long_Unsigned one. - - if X < Powten (Unsdigs) then - Ndigs := 0; - Set_Image_Unsigned - (Unsigned (Long_Long_Float'Truncation (X)), - Digs, Ndigs); - - -- But if we want more digits than fit in Unsigned, we have to use - -- the Long_Long_Unsigned routine after all. - - else - Ndigs := 0; - Set_Image_Long_Long_Unsigned - (Long_Long_Unsigned (Long_Long_Float'Truncation (X)), - Digs, Ndigs); - end if; - end Convert_Integer; - - --------- - -- Set -- - --------- - - procedure Set (C : Character) is - begin - P := P + 1; - S (P) := C; - end Set; - - ------------------------- - -- Set_Blanks_And_Sign -- - ------------------------- - - procedure Set_Blanks_And_Sign (N : Integer) is - begin - if Sign = '-' then - for J in 1 .. N - 1 loop - Set (' '); - end loop; - - Set ('-'); - - else - for J in 1 .. N loop - Set (' '); - end loop; - end if; - end Set_Blanks_And_Sign; - - -------------- - -- Set_Digs -- - -------------- - - procedure Set_Digs (S, E : Natural) is - begin - for J in S .. E loop - Set (Digs (J)); - end loop; - end Set_Digs; - - ---------------------- - -- Set_Special_Fill -- - ---------------------- - - procedure Set_Special_Fill (N : Natural) is - F : Natural; - - begin - F := Fore + 1 + Aft - N; - - if Exp /= 0 then - F := F + Exp + 1; - end if; - - for J in 1 .. F loop - Set ('*'); - end loop; - end Set_Special_Fill; - - --------------- - -- Set_Zeros -- - --------------- - - procedure Set_Zeros (N : Integer) is - begin - for J in 1 .. N loop - Set ('0'); - end loop; - end Set_Zeros; - - -- Start of processing for Set_Image_Real - - begin - -- We call the floating-point processor reset routine so that we can - -- be sure the floating-point processor is properly set for conversion - -- calls. This is notably need on Windows, where calls to the operating - -- system randomly reset the processor into 64-bit mode. - - System.Float_Control.Reset; - - Scale := 0; - - -- Deal with invalid values first, - - if not V'Valid then - - -- Note that we're taking our chances here, as V might be - -- an invalid bit pattern resulting from erroneous execution - -- (caused by using uninitialized variables for example). - - -- No matter what, we'll at least get reasonable behavior, - -- converting to infinity or some other value, or causing an - -- exception to be raised is fine. - - -- If the following test succeeds, then we definitely have - -- an infinite value, so we print Inf. - - if V > Long_Long_Float'Last then - Set ('+'); - Set ('I'); - Set ('n'); - Set ('f'); - Set_Special_Fill (4); - - -- In all other cases we print NaN - - elsif V < Long_Long_Float'First then - Set ('-'); - Set ('I'); - Set ('n'); - Set ('f'); - Set_Special_Fill (4); - - else - Set ('N'); - Set ('a'); - Set ('N'); - Set_Special_Fill (3); - end if; - - return; - end if; - - -- Positive values - - if V > 0.0 then - X := V; - Sign := '+'; - - -- Negative values - - elsif V < 0.0 then - X := -V; - Sign := '-'; - - -- Zero values - - elsif V = 0.0 then - if Long_Long_Float'Signed_Zeros and then Is_Negative (V) then - Sign := '-'; - else - Sign := '+'; - end if; - - Set_Blanks_And_Sign (Fore - 1); - Set ('0'); - Set ('.'); - Set_Zeros (NFrac); - - if Exp /= 0 then - Set ('E'); - Set ('+'); - Set_Zeros (Natural'Max (1, Exp - 1)); - end if; - - return; - - else - -- It should not be possible for a NaN to end up here. - -- Either the 'Valid test has failed, or we have some form - -- of erroneous execution. Raise Constraint_Error instead of - -- attempting to go ahead printing the value. - - raise Constraint_Error; - end if; - - -- X and Sign are set here, and X is known to be a valid, - -- non-zero floating-point number. - - -- Case of non-zero value with Exp = 0 - - if Exp = 0 then - - -- First step is to multiply by 10 ** Nfrac to get an integer - -- value to be output, an then add 0.5 to round the result. - - declare - NF : Natural := NFrac; - - begin - loop - -- If we are larger than Powten (Maxdigs) now, then - -- we have too many significant digits, and we have - -- not even finished multiplying by NFrac (NF shows - -- the number of unaccounted-for digits). - - if X >= Powten (Maxdigs) then - - -- In this situation, we only to generate a reasonable - -- number of significant digits, and then zeroes after. - -- So first we rescale to get: - - -- 10 ** (Maxdigs - 1) <= X < 10 ** Maxdigs - - -- and then convert the resulting integer - - Adjust_Scale (Maxdigs); - Convert_Integer; - - -- If that caused rescaling, then add zeros to the end - -- of the number to account for this scaling. Also add - -- zeroes to account for the undone multiplications - - for J in 1 .. Scale + NF loop - Ndigs := Ndigs + 1; - Digs (Ndigs) := '0'; - end loop; - - exit; - - -- If multiplication is complete, then convert the resulting - -- integer after rounding (note that X is non-negative) - - elsif NF = 0 then - X := X + 0.5; - Convert_Integer; - exit; - - -- Otherwise we can go ahead with the multiplication. If it - -- can be done in one step, then do it in one step. - - elsif NF < Maxpow then - X := X * Powten (NF); - NF := 0; - - -- If it cannot be done in one step, then do partial scaling - - else - X := X * Powten (Maxpow); - NF := NF - Maxpow; - end if; - end loop; - end; - - -- If number of available digits is less or equal to NFrac, - -- then we need an extra zero before the decimal point. - - if Ndigs <= NFrac then - Set_Blanks_And_Sign (Fore - 1); - Set ('0'); - Set ('.'); - Set_Zeros (NFrac - Ndigs); - Set_Digs (1, Ndigs); - - -- Normal case with some digits before the decimal point - - else - Set_Blanks_And_Sign (Fore - (Ndigs - NFrac)); - Set_Digs (1, Ndigs - NFrac); - Set ('.'); - Set_Digs (Ndigs - NFrac + 1, Ndigs); - end if; - - -- Case of non-zero value with non-zero Exp value - - else - -- If NFrac is less than Maxdigs, then all the fraction digits are - -- significant, so we can scale the resulting integer accordingly. - - if NFrac < Maxdigs then - Adjust_Scale (NFrac + 1); - Convert_Integer; - - -- Otherwise, we get the maximum number of digits available - - else - Adjust_Scale (Maxdigs); - Convert_Integer; - - for J in 1 .. NFrac - Maxdigs + 1 loop - Ndigs := Ndigs + 1; - Digs (Ndigs) := '0'; - Scale := Scale - 1; - end loop; - end if; - - Set_Blanks_And_Sign (Fore - 1); - Set (Digs (1)); - Set ('.'); - Set_Digs (2, Ndigs); - - -- The exponent is the scaling factor adjusted for the digits - -- that we output after the decimal point, since these were - -- included in the scaled digits that we output. - - Expon := Scale + NFrac; - - Set ('E'); - Ndigs := 0; - - if Expon >= 0 then - Set ('+'); - Set_Image_Unsigned (Unsigned (Expon), Digs, Ndigs); - else - Set ('-'); - Set_Image_Unsigned (Unsigned (-Expon), Digs, Ndigs); - end if; - - Set_Zeros (Exp - Ndigs - 1); - Set_Digs (1, Ndigs); - end if; - - end Set_Image_Real; - -end System.Img_Real; diff --git a/gcc/ada/s-imgrea.ads b/gcc/ada/s-imgrea.ads deleted file mode 100644 index 3c4f64f..0000000 --- a/gcc/ada/s-imgrea.ads +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ R E A L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Image for fixed and float types (also used for Float_IO/Fixed_IO output) - -package System.Img_Real is - pragma Pure; - - procedure Image_Ordinary_Fixed_Point - (V : Long_Long_Float; - S : in out String; - P : out Natural; - Aft : Natural); - -- Computes fixed_type'Image (V) and returns the result in S (1 .. P) - -- updating P on return. The result is computed according to the rules for - -- image for fixed-point types (RM 3.5(34)), where Aft is the value of the - -- Aft attribute for the fixed-point type. This function is used only for - -- ordinary fixed point (see package System.Img_Dec for handling of decimal - -- fixed-point). The caller guarantees that S is long enough to hold the - -- result and has a lower bound of 1. - - procedure Image_Floating_Point - (V : Long_Long_Float; - S : in out String; - P : out Natural; - Digs : Natural); - -- Computes fixed_type'Image (V) and returns the result in S (1 .. P) - -- updating P on return. The result is computed according to the rules for - -- image for floating-point types (RM 3.5(33)), where Digs is the value of - -- the Digits attribute for the floating-point type. The caller guarantees - -- that S is long enough to hold the result and has a lower bound of 1. - - procedure Set_Image_Real - (V : Long_Long_Float; - S : out String; - P : in out Natural; - Fore : Natural; - Aft : Natural; - Exp : Natural); - -- Sets the image of V starting at S (P + 1), updating P to point to the - -- last character stored, the caller promises that the buffer is large - -- enough and no check is made for this. Constraint_Error will not - -- necessarily be raised if this is violated, since it is perfectly valid - -- to compile this unit with checks off). The Fore, Aft and Exp values - -- can be set to any valid values for the case of use from Text_IO. Note - -- that no space is stored at the start for non-negative values. - -end System.Img_Real; diff --git a/gcc/ada/s-imguns.adb b/gcc/ada/s-imguns.adb deleted file mode 100644 index c466db3..0000000 --- a/gcc/ada/s-imguns.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ U N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Img_Uns is - - -------------------- - -- Image_Unsigned -- - -------------------- - - procedure Image_Unsigned - (V : System.Unsigned_Types.Unsigned; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - begin - S (1) := ' '; - P := 1; - Set_Image_Unsigned (V, S, P); - end Image_Unsigned; - - ------------------------ - -- Set_Image_Unsigned -- - ------------------------ - - procedure Set_Image_Unsigned - (V : Unsigned; - S : in out String; - P : in out Natural) - is - begin - if V >= 10 then - Set_Image_Unsigned (V / 10, S, P); - P := P + 1; - S (P) := Character'Val (48 + (V rem 10)); - - else - P := P + 1; - S (P) := Character'Val (48 + V); - end if; - end Set_Image_Unsigned; - -end System.Img_Uns; diff --git a/gcc/ada/s-imguns.ads b/gcc/ada/s-imguns.ads deleted file mode 100644 index 134f916..0000000 --- a/gcc/ada/s-imguns.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ U N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines for supporting the Image attribute for --- modular integer types up to size Unsigned'Size, and also for conversion --- operations required in Text_IO.Modular_IO for such types. - -with System.Unsigned_Types; - -package System.Img_Uns is - pragma Pure; - - procedure Image_Unsigned - (V : System.Unsigned_Types.Unsigned; - S : in out String; - P : out Natural); - pragma Inline (Image_Unsigned); - -- Computes Unsigned'Image (V) and stores the result in S (1 .. P) setting - -- the resulting value of P. The caller guarantees that S is long enough to - -- hold the result, and that S'First is 1. - - procedure Set_Image_Unsigned - (V : System.Unsigned_Types.Unsigned; - S : in out String; - P : in out Natural); - -- Stores the image of V in S starting at S (P + 1), P is updated to point - -- to the last character stored. The value stored is identical to the value - -- of Unsigned'Image (V) except that no leading space is stored. The caller - -- guarantees that S is long enough to hold the result. S need not have a - -- lower bound of 1. - -end System.Img_Uns; diff --git a/gcc/ada/s-imgwch.adb b/gcc/ada/s-imgwch.adb deleted file mode 100644 index 44cca39..0000000 --- a/gcc/ada/s-imgwch.adb +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ W C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces; use Interfaces; - -with System.Img_Char; use System.Img_Char; - -package body System.Img_WChar is - - -------------------------- - -- Image_Wide_Character -- - -------------------------- - - procedure Image_Wide_Character - (V : Wide_Character; - S : in out String; - P : out Natural; - Ada_2005 : Boolean) - is - pragma Assert (S'First = 1); - - begin - -- Annoying Ada 95 incompatibility with FFFE/FFFF - - if V >= Wide_Character'Val (16#FFFE#) - and then not Ada_2005 - then - if V = Wide_Character'Val (16#FFFE#) then - S (1 .. 4) := "FFFE"; - else - S (1 .. 4) := "FFFF"; - end if; - - P := 4; - - -- Deal with annoying Ada 95 incompatibility with soft hyphen - - elsif V = Wide_Character'Val (16#00AD#) - and then not Ada_2005 - then - P := 3; - S (1) := '''; - S (2) := Character'Val (16#00AD#); - S (3) := '''; - - -- Normal case, same as Wide_Wide_Character - - else - Image_Wide_Wide_Character - (Wide_Wide_Character'Val (Wide_Character'Pos (V)), S, P); - end if; - end Image_Wide_Character; - - ------------------------------- - -- Image_Wide_Wide_Character -- - ------------------------------- - - procedure Image_Wide_Wide_Character - (V : Wide_Wide_Character; - S : in out String; - P : out Natural) - is - pragma Assert (S'First = 1); - - Val : Unsigned_32 := Wide_Wide_Character'Pos (V); - - begin - -- If in range of standard Character, use Character routine. Use the - -- Ada 2005 version, since either we are called directly in Ada 2005 - -- mode for Wide_Wide_Character, or this is the Wide_Character case - -- which already took care of the Soft_Hyphen glitch. - - if Val <= 16#FF# then - Image_Character_05 - (Character'Val (Wide_Wide_Character'Pos (V)), S, P); - - -- Otherwise value returned is Hex_hhhhhhhh - - else - declare - Hex : constant array (Unsigned_32 range 0 .. 15) of Character := - "0123456789ABCDEF"; - - begin - S (1 .. 4) := "Hex_"; - - for J in reverse 5 .. 12 loop - S (J) := Hex (Val mod 16); - Val := Val / 16; - end loop; - - P := 12; - end; - end if; - end Image_Wide_Wide_Character; - -end System.Img_WChar; diff --git a/gcc/ada/s-imgwch.ads b/gcc/ada/s-imgwch.ads deleted file mode 100644 index 6fbe67a..0000000 --- a/gcc/ada/s-imgwch.ads +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ W C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Wide_[Wide_]Character'Image - -package System.Img_WChar is - pragma Pure; - - procedure Image_Wide_Character - (V : Wide_Character; - S : in out String; - P : out Natural; - Ada_2005 : Boolean); - -- Computes Wide_Character'Image (V) and stores the result in S (1 .. P) - -- setting the resulting value of P. The caller guarantees that S is long - -- enough to hold the result, and that S'First is 1. The parameter Ada_2005 - -- is True if operating in Ada 2005 mode (or beyond). This is required to - -- deal with the annoying FFFE/FFFF incompatibility. - - procedure Image_Wide_Wide_Character - (V : Wide_Wide_Character; - S : in out String; - P : out Natural); - -- Computes Wide_Wide_Character'Image (V) and stores the result in - -- S (1 .. P) setting the resulting value of P. The caller guarantees - -- that S is long enough to hold the result, and that S'First is 1. - -end System.Img_WChar; diff --git a/gcc/ada/s-imgwiu.adb b/gcc/ada/s-imgwiu.adb deleted file mode 100644 index 022f75c..0000000 --- a/gcc/ada/s-imgwiu.adb +++ /dev/null @@ -1,138 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ W I U -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Img_WIU is - - ----------------------------- - -- Set_Image_Width_Integer -- - ----------------------------- - - procedure Set_Image_Width_Integer - (V : Integer; - W : Integer; - S : out String; - P : in out Natural) - is - Start : Natural; - - begin - -- Positive case can just use the unsigned circuit directly - - if V >= 0 then - Set_Image_Width_Unsigned (Unsigned (V), W, S, P); - - -- Negative case has to set a minus sign. Note also that we have to be - -- careful not to generate overflow with the largest negative number. - - else - P := P + 1; - S (P) := ' '; - Start := P; - - declare - pragma Suppress (Overflow_Check); - pragma Suppress (Range_Check); - begin - Set_Image_Width_Unsigned (Unsigned (-V), W - 1, S, P); - end; - - -- Set minus sign in last leading blank location. Because of the - -- code above, there must be at least one such location. - - while S (Start + 1) = ' ' loop - Start := Start + 1; - end loop; - - S (Start) := '-'; - end if; - - end Set_Image_Width_Integer; - - ------------------------------ - -- Set_Image_Width_Unsigned -- - ------------------------------ - - procedure Set_Image_Width_Unsigned - (V : Unsigned; - W : Integer; - S : out String; - P : in out Natural) - is - Start : constant Natural := P; - F, T : Natural; - - procedure Set_Digits (T : Unsigned); - -- Set digits of absolute value of T - - ---------------- - -- Set_Digits -- - ---------------- - - procedure Set_Digits (T : Unsigned) is - begin - if T >= 10 then - Set_Digits (T / 10); - P := P + 1; - S (P) := Character'Val (T mod 10 + Character'Pos ('0')); - else - P := P + 1; - S (P) := Character'Val (T + Character'Pos ('0')); - end if; - end Set_Digits; - - -- Start of processing for Set_Image_Width_Unsigned - - begin - Set_Digits (V); - - -- Add leading spaces if required by width parameter - - if P - Start < W then - F := P; - P := P + (W - (P - Start)); - T := P; - - while F > Start loop - S (T) := S (F); - T := T - 1; - F := F - 1; - end loop; - - for J in Start + 1 .. T loop - S (J) := ' '; - end loop; - end if; - - end Set_Image_Width_Unsigned; - -end System.Img_WIU; diff --git a/gcc/ada/s-imgwiu.ads b/gcc/ada/s-imgwiu.ads deleted file mode 100644 index 9eb006f..0000000 --- a/gcc/ada/s-imgwiu.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I M G _ W I U -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Contains the routine for computing the image of signed and unsigned --- integers whose size <= Integer'Size for use by Text_IO.Integer_IO --- and Text_IO.Modular_IO. - -with System.Unsigned_Types; - -package System.Img_WIU is - pragma Pure; - - procedure Set_Image_Width_Integer - (V : Integer; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the signed image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes - -- a leading minus sign if necessary, but no leading spaces unless W is - -- positive, in which case leading spaces are output if necessary to ensure - -- that the output string is no less than W characters long. The caller - -- promises that the buffer is large enough and no check is made for this. - -- Constraint_Error will not necessarily be raised if this is violated, - -- since it is perfectly valid to compile this unit with checks off. - - procedure Set_Image_Width_Unsigned - (V : System.Unsigned_Types.Unsigned; - W : Integer; - S : out String; - P : in out Natural); - -- Sets the unsigned image of V in decimal format, starting at S (P + 1), - -- updating P to point to the last character stored. The image includes no - -- leading spaces unless W is positive, in which case leading spaces are - -- output if necessary to ensure that the output string is no less than - -- W characters long. The caller promises that the buffer is large enough - -- and no check is made for this. Constraint_Error will not necessarily be - -- raised if this is violated, since it is perfectly valid to compile this - -- unit with checks off. - -end System.Img_WIU; diff --git a/gcc/ada/s-io.adb b/gcc/ada/s-io.adb deleted file mode 100644 index d8fd5f5..0000000 --- a/gcc/ada/s-io.adb +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.IO is - - Current_Out : File_Type := Stdout; - pragma Atomic (Current_Out); - -- Current output file (modified by Set_Output) - - -------------- - -- New_Line -- - -------------- - - procedure New_Line (Spacing : Positive := 1) is - begin - for J in 1 .. Spacing loop - Put (ASCII.LF); - end loop; - end New_Line; - - --------- - -- Put -- - --------- - - procedure Put (X : Integer) is - procedure Put_Int (X : Integer); - pragma Import (C, Put_Int, "put_int"); - - procedure Put_Int_Err (X : Integer); - pragma Import (C, Put_Int_Err, "put_int_stderr"); - - begin - case Current_Out is - when Stdout => Put_Int (X); - when Stderr => Put_Int_Err (X); - end case; - end Put; - - procedure Put (C : Character) is - procedure Put_Char (C : Character); - pragma Import (C, Put_Char, "put_char"); - - procedure Put_Char_Stderr (C : Character); - pragma Import (C, Put_Char_Stderr, "put_char_stderr"); - - begin - case Current_Out is - when Stdout => Put_Char (C); - when Stderr => Put_Char_Stderr (C); - end case; - end Put; - - procedure Put (S : String) is - begin - for J in S'Range loop - Put (S (J)); - end loop; - end Put; - - -------------- - -- Put_Line -- - -------------- - - procedure Put_Line (S : String) is - begin - Put (S); - New_Line; - end Put_Line; - - --------------------- - -- Standard_Output -- - --------------------- - - function Standard_Output return File_Type is - begin - return Stdout; - end Standard_Output; - - -------------------- - -- Standard_Error -- - -------------------- - - function Standard_Error return File_Type is - begin - return Stderr; - end Standard_Error; - - ---------------- - -- Set_Output -- - ---------------- - - procedure Set_Output (File : File_Type) is - begin - Current_Out := File; - end Set_Output; - -end System.IO; diff --git a/gcc/ada/s-io.ads b/gcc/ada/s-io.ads deleted file mode 100644 index 71897ad..0000000 --- a/gcc/ada/s-io.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- A simple text I/O package, used for diagnostic output in the runtime, --- This package is also preelaborated, unlike Text_Io, and can thus be --- with'ed by preelaborated library units. It includes only Put routines --- for character, integer, string and a new line function - -package System.IO is - pragma Preelaborate; - - procedure Put (X : Integer); - - procedure Put (C : Character); - - procedure Put (S : String); - procedure Put_Line (S : String); - - procedure New_Line (Spacing : Positive := 1); - - type File_Type is limited private; - - function Standard_Error return File_Type; - function Standard_Output return File_Type; - - procedure Set_Output (File : File_Type); - -private - - type File_Type is (Stdout, Stderr); - -- Stdout = Standard_Output, Stderr = Standard_Error - - pragma Inline (Standard_Error); - pragma Inline (Standard_Output); - -end System.IO; diff --git a/gcc/ada/s-llflex.ads b/gcc/ada/s-llflex.ads deleted file mode 100644 index 9504e78..0000000 --- a/gcc/ada/s-llflex.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . L O N G _ L O N G _ F L O A T _ E X P O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains an instantiation of the exponentiation operator --- between two long long floats. - -with Ada.Numerics.Long_Long_Elementary_Functions; - -package System.Long_Long_Float_Expon is - - function Expon_LLF (Left, Right : Long_Long_Float) return Long_Long_Float - renames Ada.Numerics.Long_Long_Elementary_Functions."**"; - -end System.Long_Long_Float_Expon; diff --git a/gcc/ada/s-maccod.ads b/gcc/ada/s-maccod.ads deleted file mode 100644 index 353cb05..0000000 --- a/gcc/ada/s-maccod.ads +++ /dev/null @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . M A C H I N E _ C O D E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides machine code support, both for intrinsic machine --- operations, and also for machine code statements. See GNAT documentation --- for full details. - -package System.Machine_Code is - pragma No_Elaboration_Code_All; - pragma Pure; - - -- All identifiers in this unit are implementation defined - - pragma Implementation_Defined; - - type Asm_Input_Operand is private; - type Asm_Output_Operand is private; - -- These types are never used directly, they are declared only so that - -- the calls to Asm are type correct according to Ada semantic rules. - - No_Input_Operands : constant Asm_Input_Operand; - No_Output_Operands : constant Asm_Output_Operand; - - type Asm_Input_Operand_List is - array (Integer range <>) of Asm_Input_Operand; - - type Asm_Output_Operand_List is - array (Integer range <>) of Asm_Output_Operand; - - type Asm_Insn is private; - -- This type is not used directly. It is declared only so that the - -- aggregates used in code statements are type correct by Ada rules. - - procedure Asm ( - Template : String; - Outputs : Asm_Output_Operand_List; - Inputs : Asm_Input_Operand_List; - Clobber : String := ""; - Volatile : Boolean := False); - - procedure Asm ( - Template : String; - Outputs : Asm_Output_Operand := No_Output_Operands; - Inputs : Asm_Input_Operand_List; - Clobber : String := ""; - Volatile : Boolean := False); - - procedure Asm ( - Template : String; - Outputs : Asm_Output_Operand_List; - Inputs : Asm_Input_Operand := No_Input_Operands; - Clobber : String := ""; - Volatile : Boolean := False); - - procedure Asm ( - Template : String; - Outputs : Asm_Output_Operand := No_Output_Operands; - Inputs : Asm_Input_Operand := No_Input_Operands; - Clobber : String := ""; - Volatile : Boolean := False); - - function Asm ( - Template : String; - Outputs : Asm_Output_Operand_List; - Inputs : Asm_Input_Operand_List; - Clobber : String := ""; - Volatile : Boolean := False) return Asm_Insn; - - function Asm ( - Template : String; - Outputs : Asm_Output_Operand := No_Output_Operands; - Inputs : Asm_Input_Operand_List; - Clobber : String := ""; - Volatile : Boolean := False) return Asm_Insn; - - function Asm ( - Template : String; - Outputs : Asm_Output_Operand_List; - Inputs : Asm_Input_Operand := No_Input_Operands; - Clobber : String := ""; - Volatile : Boolean := False) return Asm_Insn; - - function Asm ( - Template : String; - Outputs : Asm_Output_Operand := No_Output_Operands; - Inputs : Asm_Input_Operand := No_Input_Operands; - Clobber : String := ""; - Volatile : Boolean := False) return Asm_Insn; - - pragma Import (Intrinsic, Asm); - -private - - type Asm_Input_Operand is new Integer; - type Asm_Output_Operand is new Integer; - type Asm_Insn is new Integer; - -- All three of these types are dummy types, to meet the requirements of - -- type consistency. No values of these types are ever referenced. - - No_Input_Operands : constant Asm_Input_Operand := 0; - No_Output_Operands : constant Asm_Output_Operand := 0; - -end System.Machine_Code; diff --git a/gcc/ada/s-mantis.adb b/gcc/ada/s-mantis.adb deleted file mode 100644 index 04f6e5a..0000000 --- a/gcc/ada/s-mantis.adb +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M A N T I S S A -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Mantissa is - - -------------------- - -- Mantissa_Value -- - -------------------- - - function Mantissa_Value (First, Last : Integer) return Natural is - Result : Natural := 0; - - Val : Integer := Integer'Max (abs First - 1, abs Last); - -- Note: First-1 allows for twos complement largest neg number - - begin - while Val /= 0 loop - Val := Val / 2; - Result := Result + 1; - end loop; - - return Result; - end Mantissa_Value; - -end System.Mantissa; diff --git a/gcc/ada/s-mantis.ads b/gcc/ada/s-mantis.ads deleted file mode 100644 index 5169299..0000000 --- a/gcc/ada/s-mantis.ads +++ /dev/null @@ -1,42 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M A N T I S S A -- --- -- --- S p e c -- --- -- --- Copyright (C) 1996-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for typ'Mantissa where typ is a --- fixed-point type with non-static bounds. - -package System.Mantissa is - pragma Pure; - - function Mantissa_Value (First, Last : Integer) return Natural; - -- Compute Mantissa value from the given arguments, which are the First - -- and Last value of the fixed-point type, in Integer'Integer_Value form. - -end System.Mantissa; diff --git a/gcc/ada/s-mastop.adb b/gcc/ada/s-mastop.adb deleted file mode 100644 index 73be3e9..0000000 --- a/gcc/ada/s-mastop.adb +++ /dev/null @@ -1,108 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- B o d y -- --- (Dummy version) -- --- -- --- Copyright (C) 1999-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This dummy version of System.Machine_State_Operations is used on targets --- for which zero cost exception handling is not implemented. - -pragma Compiler_Unit_Warning; - -package body System.Machine_State_Operations is - - -- Turn off warnings since many unused parameters - - pragma Warnings (Off); - - ---------------------------- - -- Allocate_Machine_State -- - ---------------------------- - - function Allocate_Machine_State return Machine_State is - begin - return Machine_State (Null_Address); - end Allocate_Machine_State; - - ---------------- - -- Fetch_Code -- - ---------------- - - function Fetch_Code (Loc : Code_Loc) return Code_Loc is - begin - return Loc; - end Fetch_Code; - - ------------------------ - -- Free_Machine_State -- - ------------------------ - - procedure Free_Machine_State (M : in out Machine_State) is - begin - M := Machine_State (Null_Address); - end Free_Machine_State; - - ------------------ - -- Get_Code_Loc -- - ------------------ - - function Get_Code_Loc (M : Machine_State) return Code_Loc is - begin - return Null_Address; - end Get_Code_Loc; - - -------------------------- - -- Machine_State_Length -- - -------------------------- - - function Machine_State_Length - return System.Storage_Elements.Storage_Offset is - begin - return 0; - end Machine_State_Length; - - --------------- - -- Pop_Frame -- - --------------- - - procedure Pop_Frame (M : Machine_State) is - begin - null; - end Pop_Frame; - - ----------------------- - -- Set_Machine_State -- - ----------------------- - - procedure Set_Machine_State (M : Machine_State) is - begin - null; - end Set_Machine_State; - -end System.Machine_State_Operations; diff --git a/gcc/ada/s-mastop.ads b/gcc/ada/s-mastop.ads deleted file mode 100644 index 216d79b..0000000 --- a/gcc/ada/s-mastop.ads +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.MACHINE_STATE_OPERATIONS -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with System.Exception_Tables. - -with System.Storage_Elements; - -package System.Machine_State_Operations is - - subtype Code_Loc is System.Address; - -- Code location used in building exception tables and for call addresses - -- when propagating an exception (also traceback table) Values of this - -- type are created by using Label'Address or extracted from machine - -- states using Get_Code_Loc. - - type Machine_State is new System.Address; - -- The table based exception handling approach (see a-except.adb) isolates - -- the target dependent aspects using an abstract data type interface - -- to the type Machine_State, which is represented as a System.Address - -- value (presumably implemented as a pointer to an appropriate record - -- structure). - - function Machine_State_Length return System.Storage_Elements.Storage_Offset; - -- Function to determine the length of the Storage_Array needed to hold - -- a machine state. The machine state will always be maximally aligned. - -- The value returned is a constant that will be used to allocate space - -- for a machine state value. - - function Allocate_Machine_State return Machine_State; - -- Allocate the required space for a Machine_State - - procedure Free_Machine_State (M : in out Machine_State); - -- Free the dynamic memory taken by Machine_State - - -- The initial value of type Machine_State is created by the low level - -- routine that actually raises an exception using the special builtin - -- _builtin_machine_state. This value will typically encode the value of - -- the program counter, and relevant registers. The following operations - -- are defined on Machine_State values: - - function Get_Code_Loc (M : Machine_State) return Code_Loc; - -- This function extracts the program counter value from a machine state, - -- which the caller uses for searching the exception tables, and also for - -- recording entries in the traceback table. The call returns a value of - -- Null_Loc if the machine state represents the outer level, or some other - -- frame for which no information can be provided. - - procedure Pop_Frame (M : Machine_State); - -- This procedure pops the machine state M so that it represents the - -- call point, as though the current subprogram had returned. It changes - -- only the value referenced by M, and does not affect the current stack - -- environment. - - function Fetch_Code (Loc : Code_Loc) return Code_Loc; - -- Some architectures (notably HPUX) use a descriptor to describe a - -- subprogram address. This function computes the actual starting - -- address of the code from Loc. - -- - -- Do not add pragma Inline to this function: there is a curious - -- interaction between rtsfind and front-end inlining. The exception - -- declaration in s-auxdec calls rtsfind, which forces several other system - -- packages to be compiled. Some of those have a pragma Inline, and we - -- compile the corresponding bodies so that inlining can take place. One - -- of these packages is s-mastop, which depends on s-auxdec, which is still - -- being compiled: we have not seen all the declarations in it yet, so we - -- get confused semantic errors ??? - - procedure Set_Machine_State (M : Machine_State); - -- This routine sets M from the current machine state. It is called when an - -- exception is initially signalled to initialize the state. - -end System.Machine_State_Operations; diff --git a/gcc/ada/s-memcop.ads b/gcc/ada/s-memcop.ads deleted file mode 100644 index fc2403f..0000000 --- a/gcc/ada/s-memcop.ads +++ /dev/null @@ -1,72 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y _ C O P Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides general block copy mechanisms analogous to those --- provided by the C routines memcpy and memmove allowing for copies with --- and without possible overlap of the operands. - --- The idea is to allow a configurable run-time to provide this capability --- for use by the compiler without dragging in C-run time routines. - -with System.CRTL; --- The above with is contrary to the intent ??? - -package System.Memory_Copy is - pragma Preelaborate; - - procedure memcpy (S1 : Address; S2 : Address; N : System.CRTL.size_t) - renames System.CRTL.memcpy; - -- Copies N storage units from area starting at S2 to area starting - -- at S1 without any check for buffer overflow. The memory areas - -- must not overlap, or the result of this call is undefined. - - procedure memmove (S1 : Address; S2 : Address; N : System.CRTL.size_t) - renames System.CRTL.memmove; - -- Copies N storage units from area starting at S2 to area starting - -- at S1 without any check for buffer overflow. The difference between - -- this memmove and memcpy is that with memmove, the storage areas may - -- overlap (forwards or backwards) and the result is correct (i.e. it - -- is as if S2 is first moved to a temporary area, and then this area - -- is copied to S1 in a separate step). - - -- In the standard library, these are just interfaced to the C routines. - -- But in the HI-E (high integrity version) they may be reprogrammed to - -- meet certification requirements (and marked High_Integrity). - - -- Note that in high integrity mode these routines are by default not - -- available, and the HI-E compiler will as a result generate implicit - -- loops (which will violate the restriction No_Implicit_Loops). - -end System.Memory_Copy; diff --git a/gcc/ada/s-memory-mingw.adb b/gcc/ada/s-memory-mingw.adb deleted file mode 100644 index 31fe0d8..0000000 --- a/gcc/ada/s-memory-mingw.adb +++ /dev/null @@ -1,221 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version provides ways to limit the amount of used memory for systems --- that do not have OS support for that. - --- The amount of available memory available for dynamic allocation is limited --- by setting the environment variable GNAT_MEMORY_LIMIT to the number of --- kilobytes that can be used. --- --- Windows is currently using this version. - -with Ada.Exceptions; -with System.Soft_Links; - -package body System.Memory is - - use Ada.Exceptions; - use System.Soft_Links; - - function c_malloc (Size : size_t) return System.Address; - pragma Import (C, c_malloc, "malloc"); - - procedure c_free (Ptr : System.Address); - pragma Import (C, c_free, "free"); - - function c_realloc - (Ptr : System.Address; Size : size_t) return System.Address; - pragma Import (C, c_realloc, "realloc"); - - function msize (Ptr : System.Address) return size_t; - pragma Import (C, msize, "_msize"); - - function getenv (Str : String) return System.Address; - pragma Import (C, getenv); - - function atoi (Str : System.Address) return Integer; - pragma Import (C, atoi); - - Available_Memory : size_t := 0; - -- Amount of memory that is available for heap allocations. - -- A value of 0 means that the amount is not yet initialized. - - Msize_Accuracy : constant := 4096; - -- Defines the amount of memory to add to requested allocation sizes, - -- because malloc may return a bigger block than requested. As msize - -- is used when by Free, it must be used on allocation as well. To - -- prevent underflow of available_memory we need to use a reserve. - - procedure Check_Available_Memory (Size : size_t); - -- This routine must be called while holding the task lock. When the - -- memory limit is not yet initialized, it will be set to the value of - -- the GNAT_MEMORY_LIMIT environment variable or to unlimited if that - -- does not exist. If the size is larger than the amount of available - -- memory, the task lock will be freed and a storage_error exception - -- will be raised. - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - Actual_Size : size_t := Size; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - -- Change size from zero to non-zero. We still want a proper pointer - -- for the zero case because pointers to zero length objects have to - -- be distinct, but we can't just go ahead and allocate zero bytes, - -- since some malloc's return zero for a zero argument. - - if Size = 0 then - Actual_Size := 1; - end if; - - Lock_Task.all; - - if Actual_Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_malloc (Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Alloc; - - ---------------------------- - -- Check_Available_Memory -- - ---------------------------- - - procedure Check_Available_Memory (Size : size_t) is - Gnat_Memory_Limit : System.Address; - - begin - if Available_Memory = 0 then - - -- The amount of available memory hasn't been initialized yet - - Gnat_Memory_Limit := getenv ("GNAT_MEMORY_LIMIT" & ASCII.NUL); - - if Gnat_Memory_Limit /= System.Null_Address then - Available_Memory := - size_t (atoi (Gnat_Memory_Limit)) * 1024 + Msize_Accuracy; - else - Available_Memory := size_t'Last; - end if; - end if; - - if Size >= Available_Memory then - - -- There is a memory overflow - - Unlock_Task.all; - Raise_Exception - (Storage_Error'Identity, "heap memory limit exceeded"); - end if; - end Check_Available_Memory; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - begin - Lock_Task.all; - - if Ptr /= System.Null_Address then - Available_Memory := Available_Memory + msize (Ptr); - end if; - - c_free (Ptr); - - Unlock_Task.all; - end Free; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - Actual_Size : constant size_t := Size; - Old_Size : size_t; - - begin - if Size = size_t'Last then - Raise_Exception (Storage_Error'Identity, "object too large"); - end if; - - Lock_Task.all; - - Old_Size := msize (Ptr); - - -- Conservative check - no need to try to be precise here - - if Size + Msize_Accuracy >= Available_Memory then - Check_Available_Memory (Size + Msize_Accuracy); - end if; - - Result := c_realloc (Ptr, Actual_Size); - - if Result /= System.Null_Address then - Available_Memory := Available_Memory + Old_Size - msize (Result); - end if; - - Unlock_Task.all; - - if Result = System.Null_Address then - Raise_Exception (Storage_Error'Identity, "heap exhausted"); - end if; - - return Result; - end Realloc; - -end System.Memory; diff --git a/gcc/ada/s-memory.adb b/gcc/ada/s-memory.adb deleted file mode 100644 index 870b68a..0000000 --- a/gcc/ada/s-memory.adb +++ /dev/null @@ -1,163 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 2001-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default implementation of this package - --- This implementation assumes that the underlying malloc/free/realloc --- implementation is thread safe, and thus, no additional lock is required. --- Note that we still need to defer abort because on most systems, an --- asynchronous signal (as used for implementing asynchronous abort of --- task) cannot safely be handled while malloc is executing. - --- If you are not using Ada constructs containing the "abort" keyword, then --- you can remove the calls to Abort_Defer.all and Abort_Undefer.all from --- this unit. - -pragma Compiler_Unit_Warning; - -with System.CRTL; -with System.Parameters; -with System.Soft_Links; - -package body System.Memory is - - use System.Soft_Links; - - function c_malloc (Size : System.CRTL.size_t) return System.Address - renames System.CRTL.malloc; - - procedure c_free (Ptr : System.Address) - renames System.CRTL.free; - - function c_realloc - (Ptr : System.Address; Size : System.CRTL.size_t) return System.Address - renames System.CRTL.realloc; - - ----------- - -- Alloc -- - ----------- - - function Alloc (Size : size_t) return System.Address is - Result : System.Address; - begin - -- A previous version moved the check for size_t'Last below, into the - -- "if Result = System.Null_Address...". So malloc(size_t'Last) should - -- return Null_Address, and then we can check for that special value. - -- However, that doesn't work on VxWorks, because malloc(size_t'Last) - -- prints an unwanted warning message before returning Null_Address. - -- Note that the branch is correctly predicted on modern hardware, so - -- there is negligible overhead. - - if Size = size_t'Last then - raise Storage_Error with "object too large"; - end if; - - if Parameters.No_Abort then - Result := c_malloc (System.CRTL.size_t (Size)); - else - Abort_Defer.all; - Result := c_malloc (System.CRTL.size_t (Size)); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - - -- If Size = 0, we can't allocate 0 bytes, because then two different - -- allocators, one of which has Size = 0, could return pointers that - -- compare equal, which is wrong. (Nonnull pointers compare equal if - -- and only if they designate the same object, and two different - -- allocators allocate two different objects). - - -- malloc(0) is defined to allocate a non-zero-sized object (in which - -- case we won't get here, and all is well) or NULL, in which case we - -- get here. We also get here in case of error. So check for the - -- zero-size case, and allocate 1 byte. Otherwise, raise - -- Storage_Error. - - -- We check for zero size here, rather than at the start, for - -- efficiency. - - if Size = 0 then - return Alloc (1); - end if; - - raise Storage_Error with "heap exhausted"; - end if; - - return Result; - end Alloc; - - ---------- - -- Free -- - ---------- - - procedure Free (Ptr : System.Address) is - begin - if Parameters.No_Abort then - c_free (Ptr); - else - Abort_Defer.all; - c_free (Ptr); - Abort_Undefer.all; - end if; - end Free; - - ------------- - -- Realloc -- - ------------- - - function Realloc - (Ptr : System.Address; - Size : size_t) - return System.Address - is - Result : System.Address; - begin - if Size = size_t'Last then - raise Storage_Error with "object too large"; - end if; - - if Parameters.No_Abort then - Result := c_realloc (Ptr, System.CRTL.size_t (Size)); - else - Abort_Defer.all; - Result := c_realloc (Ptr, System.CRTL.size_t (Size)); - Abort_Undefer.all; - end if; - - if Result = System.Null_Address then - raise Storage_Error with "heap exhausted"; - end if; - - return Result; - end Realloc; - -end System.Memory; diff --git a/gcc/ada/s-memory.ads b/gcc/ada/s-memory.ads deleted file mode 100644 index a8c1251..0000000 --- a/gcc/ada/s-memory.ads +++ /dev/null @@ -1,107 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M E M O R Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the low level memory allocation/deallocation --- mechanisms used by GNAT. - --- To provide an alternate implementation, simply recompile the modified --- body of this package with gnatmake -u -a -g s-memory.adb and make sure --- that the ali and object files for this unit are found in the object --- search path. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -pragma Compiler_Unit_Warning; - -package System.Memory is - pragma Elaborate_Body; - - type size_t is mod 2 ** Standard'Address_Size; - -- Note: the reason we redefine this here instead of using the - -- definition in Interfaces.C is that we do not want to drag in - -- all of Interfaces.C just because System.Memory is used. - - function Alloc (Size : size_t) return System.Address; - -- This is the low level allocation routine. Given a size in storage - -- units, it returns the address of a maximally aligned block of - -- memory. The implementation of this routine is guaranteed to be - -- task safe, and also aborts are deferred if necessary. - -- - -- If Size is set to size_t'Last on entry, then a Storage_Error - -- exception is raised with a message "object too large". - -- - -- If Size is set to zero on entry, then a minimal (but non-zero) - -- size block is allocated. - -- - -- Note: this is roughly equivalent to the standard C malloc call - -- with the additional semantics as described above. - - procedure Free (Ptr : System.Address); - -- This is the low level free routine. It frees a block previously - -- allocated with a call to Alloc. As in the case of Alloc, this - -- call is guaranteed task safe, and aborts are deferred. - -- - -- Note: this is roughly equivalent to the standard C free call - -- with the additional semantics as described above. - - function Realloc - (Ptr : System.Address; - Size : size_t) return System.Address; - -- This is the low level reallocation routine. It takes an existing - -- block address returned by a previous call to Alloc or Realloc, - -- and reallocates the block. The size can either be increased or - -- decreased. If possible the reallocation is done in place, so that - -- the returned result is the same as the value of Ptr on entry. - -- However, it may be necessary to relocate the block to another - -- address, in which case the information is copied to the new - -- block, and the old block is freed. The implementation of this - -- routine is guaranteed to be task safe, and also aborts are - -- deferred as necessary. - -- - -- If Size is set to size_t'Last on entry, then a Storage_Error - -- exception is raised with a message "object too large". - -- - -- If Size is set to zero on entry, then a minimal (but non-zero) - -- size block is allocated. - -- - -- Note: this is roughly equivalent to the standard C realloc call - -- with the additional semantics as described above. - -private - - -- The following names are used from the generated compiler code - - pragma Export (C, Alloc, "__gnat_malloc"); - pragma Export (C, Free, "__gnat_free"); - pragma Export (C, Realloc, "__gnat_realloc"); - -end System.Memory; diff --git a/gcc/ada/s-mmap.adb b/gcc/ada/s-mmap.adb deleted file mode 100644 index aee0ebe..0000000 --- a/gcc/ada/s-mmap.adb +++ /dev/null @@ -1,576 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -with System.Strings; use System.Strings; - -with System.Mmap.OS_Interface; use System.Mmap.OS_Interface; - -package body System.Mmap is - - type Mapped_File_Record is record - Current_Region : Mapped_Region; - -- The legacy API enables only one region to be mapped, directly - -- associated with the mapped file. This references this region. - - File : System_File; - -- Underlying OS-level file - end record; - - type Mapped_Region_Record is record - File : Mapped_File; - -- The file this region comes from. Be careful: for reading file, it is - -- valid to have it closed before one of its regions is free'd. - - Write : Boolean; - -- Whether the file this region comes from is open for writing. - - Data : Str_Access; - -- Unbounded access to the mapped content. - - System_Offset : File_Size; - -- Position in the file of the first byte actually mapped in memory - - User_Offset : File_Size; - -- Position in the file of the first byte requested by the user - - System_Size : File_Size; - -- Size of the region actually mapped in memory - - User_Size : File_Size; - -- Size of the region requested by the user - - Mapped : Boolean; - -- Whether this region is actually memory mapped - - Mutable : Boolean; - -- If the file is opened for reading, wheter this region is writable - - Buffer : System.Strings.String_Access; - -- When this region is not actually memory mapped, contains the - -- requested bytes. - - Mapping : System_Mapping; - -- Underlying OS-level data for the mapping, if any - end record; - - Invalid_Mapped_Region_Record : constant Mapped_Region_Record := - (null, False, null, 0, 0, 0, 0, False, False, null, - Invalid_System_Mapping); - Invalid_Mapped_File_Record : constant Mapped_File_Record := - (Invalid_Mapped_Region, Invalid_System_File); - - Empty_String : constant String := ""; - -- Used to provide a valid empty Data for empty files, for instanc. - - procedure Dispose is new Ada.Unchecked_Deallocation - (Mapped_File_Record, Mapped_File); - procedure Dispose is new Ada.Unchecked_Deallocation - (Mapped_Region_Record, Mapped_Region); - - function Convert is new Ada.Unchecked_Conversion - (Standard.System.Address, Str_Access); - - procedure Compute_Data (Region : Mapped_Region); - -- Fill the Data field according to system and user offsets. The region - -- must actually be mapped or bufferized. - - procedure From_Disk (Region : Mapped_Region); - -- Read a region of some file from the disk - - procedure To_Disk (Region : Mapped_Region); - -- Write the region of the file back to disk if necessary, and free memory - - ---------------------------- - -- Open_Read_No_Exception -- - ---------------------------- - - function Open_Read_No_Exception - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return Mapped_File - is - File : constant System_File := - Open_Read (Filename, Use_Mmap_If_Available); - begin - if File = Invalid_System_File then - return Invalid_Mapped_File; - end if; - - return new Mapped_File_Record' - (Current_Region => Invalid_Mapped_Region, - File => File); - end Open_Read_No_Exception; - - --------------- - -- Open_Read -- - --------------- - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return Mapped_File - is - Res : constant Mapped_File := - Open_Read_No_Exception (Filename, Use_Mmap_If_Available); - begin - if Res = Invalid_Mapped_File then - raise Ada.IO_Exceptions.Name_Error - with "Cannot open " & Filename; - else - return Res; - end if; - end Open_Read; - - ---------------- - -- Open_Write -- - ---------------- - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return Mapped_File - is - File : constant System_File := - Open_Write (Filename, Use_Mmap_If_Available); - begin - if File = Invalid_System_File then - raise Ada.IO_Exceptions.Name_Error - with "Cannot open " & Filename; - else - return new Mapped_File_Record' - (Current_Region => Invalid_Mapped_Region, - File => File); - end if; - end Open_Write; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out Mapped_File) is - begin - -- Closing a closed file is allowed and should do nothing - - if File = Invalid_Mapped_File then - return; - end if; - - if File.Current_Region /= null then - Free (File.Current_Region); - end if; - - if File.File /= Invalid_System_File then - Close (File.File); - end if; - - Dispose (File); - end Close; - - ---------- - -- Free -- - ---------- - - procedure Free (Region : in out Mapped_Region) is - Ignored : Integer; - pragma Unreferenced (Ignored); - begin - -- Freeing an already free'd file is allowed and should do nothing - - if Region = Invalid_Mapped_Region then - return; - end if; - - if Region.Mapping /= Invalid_System_Mapping then - Dispose_Mapping (Region.Mapping); - end if; - To_Disk (Region); - Dispose (Region); - end Free; - - ---------- - -- Read -- - ---------- - - procedure Read - (File : Mapped_File; - Region : in out Mapped_Region; - Offset : File_Size := 0; - Length : File_Size := 0; - Mutable : Boolean := False) - is - File_Length : constant File_Size := Mmap.Length (File); - - Req_Offset : constant File_Size := Offset; - Req_Length : File_Size := Length; - -- Offset and Length of the region to map, used to adjust mapping - -- bounds, reflecting what the user will see. - - Region_Allocated : Boolean := False; - begin - -- If this region comes from another file, or simply if the file is - -- writeable, we cannot re-use this mapping: free it first. - - if Region /= Invalid_Mapped_Region - and then - (Region.File /= File or else File.File.Write) - then - Free (Region); - end if; - - if Region = Invalid_Mapped_Region then - Region := new Mapped_Region_Record'(Invalid_Mapped_Region_Record); - Region_Allocated := True; - end if; - - Region.File := File; - - if Req_Offset >= File_Length then - -- If the requested offset goes beyond file size, map nothing - - Req_Length := 0; - - elsif Length = 0 - or else - Length > File_Length - Req_Offset - then - -- If Length is 0 or goes beyond file size, map till end of file - - Req_Length := File_Length - Req_Offset; - - else - Req_Length := Length; - end if; - - -- Past this point, the offset/length the user will see is fixed. On the - -- other hand, the system offset/length is either already defined, from - -- a previous mapping, or it is set to 0. In the latter case, the next - -- step will set them according to the mapping. - - Region.User_Offset := Req_Offset; - Region.User_Size := Req_Length; - - -- If the requested region is inside an already mapped region, adjust - -- user-requested data and do nothing else. - - if (File.File.Write or else Region.Mutable = Mutable) - and then - Req_Offset >= Region.System_Offset - and then - (Req_Offset + Req_Length - <= Region.System_Offset + Region.System_Size) - then - Region.User_Offset := Req_Offset; - Compute_Data (Region); - return; - - elsif Region.Buffer /= null then - -- Otherwise, as we are not going to re-use the buffer, free it - - System.Strings.Free (Region.Buffer); - Region.Buffer := null; - - elsif Region.Mapping /= Invalid_System_Mapping then - -- Otherwise, there is a memory mapping that we need to unmap. - Dispose_Mapping (Region.Mapping); - end if; - - -- mmap() will sometimes return NULL when the file exists but is empty, - -- which is not what we want, so in the case of a zero length file we - -- fall back to read(2)/write(2)-based mode. - - if File_Length > 0 and then File.File.Mapped then - - Region.System_Offset := Req_Offset; - Region.System_Size := Req_Length; - Create_Mapping - (File.File, - Region.System_Offset, Region.System_Size, - Mutable, - Region.Mapping); - Region.Mapped := True; - Region.Mutable := Mutable; - - else - -- There is no alignment requirement when manually reading the file. - - Region.System_Offset := Req_Offset; - Region.System_Size := Req_Length; - Region.Mapped := False; - Region.Mutable := True; - From_Disk (Region); - end if; - - Region.Write := File.File.Write; - Compute_Data (Region); - - exception - when others => - -- Before propagating any exception, free any region we allocated - -- here. - - if Region_Allocated then - Dispose (Region); - end if; - raise; - end Read; - - ---------- - -- Read -- - ---------- - - procedure Read - (File : Mapped_File; - Offset : File_Size := 0; - Length : File_Size := 0; - Mutable : Boolean := False) - is - begin - Read (File, File.Current_Region, Offset, Length, Mutable); - end Read; - - ---------- - -- Read -- - ---------- - - function Read - (File : Mapped_File; - Offset : File_Size := 0; - Length : File_Size := 0; - Mutable : Boolean := False) return Mapped_Region - is - Region : Mapped_Region := Invalid_Mapped_Region; - begin - Read (File, Region, Offset, Length, Mutable); - return Region; - end Read; - - ------------ - -- Length -- - ------------ - - function Length (File : Mapped_File) return File_Size is - begin - return File.File.Length; - end Length; - - ------------ - -- Offset -- - ------------ - - function Offset (Region : Mapped_Region) return File_Size is - begin - return Region.User_Offset; - end Offset; - - ------------ - -- Offset -- - ------------ - - function Offset (File : Mapped_File) return File_Size is - begin - return Offset (File.Current_Region); - end Offset; - - ---------- - -- Last -- - ---------- - - function Last (Region : Mapped_Region) return Integer is - begin - return Integer (Region.User_Size); - end Last; - - ---------- - -- Last -- - ---------- - - function Last (File : Mapped_File) return Integer is - begin - return Last (File.Current_Region); - end Last; - - ------------------- - -- To_Str_Access -- - ------------------- - - function To_Str_Access - (Str : System.Strings.String_Access) return Str_Access is - begin - if Str = null then - return null; - else - return Convert (Str.all'Address); - end if; - end To_Str_Access; - - ---------- - -- Data -- - ---------- - - function Data (Region : Mapped_Region) return Str_Access is - begin - return Region.Data; - end Data; - - ---------- - -- Data -- - ---------- - - function Data (File : Mapped_File) return Str_Access is - begin - return Data (File.Current_Region); - end Data; - - ---------------- - -- Is_Mutable -- - ---------------- - - function Is_Mutable (Region : Mapped_Region) return Boolean is - begin - return Region.Mutable or Region.Write; - end Is_Mutable; - - ---------------- - -- Is_Mmapped -- - ---------------- - - function Is_Mmapped (File : Mapped_File) return Boolean is - begin - return File.File.Mapped; - end Is_Mmapped; - - ------------------- - -- Get_Page_Size -- - ------------------- - - function Get_Page_Size return Integer is - Result : constant File_Size := Get_Page_Size; - begin - return Integer (Result); - end Get_Page_Size; - - --------------------- - -- Read_Whole_File -- - --------------------- - - function Read_Whole_File - (Filename : String; - Empty_If_Not_Found : Boolean := False) - return System.Strings.String_Access - is - File : Mapped_File := Open_Read (Filename); - Region : Mapped_Region renames File.Current_Region; - Result : String_Access; - begin - Read (File); - - if Region.Data /= null then - Result := new String'(String - (Region.Data (1 .. Last (Region)))); - - elsif Region.Buffer /= null then - Result := Region.Buffer; - Region.Buffer := null; -- So that it is not deallocated - end if; - - Close (File); - - return Result; - - exception - when Ada.IO_Exceptions.Name_Error => - if Empty_If_Not_Found then - return new String'(""); - else - return null; - end if; - - when others => - Close (File); - return null; - end Read_Whole_File; - - --------------- - -- From_Disk -- - --------------- - - procedure From_Disk (Region : Mapped_Region) is - begin - pragma Assert (Region.File.all /= Invalid_Mapped_File_Record); - pragma Assert (Region.Buffer = null); - - Region.Buffer := Read_From_Disk - (Region.File.File, Region.User_Offset, Region.User_Size); - Region.Mapped := False; - end From_Disk; - - ------------- - -- To_Disk -- - ------------- - - procedure To_Disk (Region : Mapped_Region) is - begin - if Region.Write and then Region.Buffer /= null then - pragma Assert (Region.File.all /= Invalid_Mapped_File_Record); - Write_To_Disk - (Region.File.File, - Region.User_Offset, Region.User_Size, - Region.Buffer); - end if; - - System.Strings.Free (Region.Buffer); - Region.Buffer := null; - end To_Disk; - - ------------------ - -- Compute_Data -- - ------------------ - - procedure Compute_Data (Region : Mapped_Region) is - Base_Data : Str_Access; - -- Address of the first byte actually mapped in memory - - Data_Shift : constant Integer := - Integer (Region.User_Offset - Region.System_Offset); - begin - if Region.User_Size = 0 then - Region.Data := Convert (Empty_String'Address); - return; - elsif Region.Mapped then - Base_Data := Convert (Region.Mapping.Address); - else - Base_Data := Convert (Region.Buffer.all'Address); - end if; - Region.Data := Convert (Base_Data (Data_Shift + 1)'Address); - end Compute_Data; - -end System.Mmap; diff --git a/gcc/ada/s-mmap.ads b/gcc/ada/s-mmap.ads deleted file mode 100644 index 7719367..0000000 --- a/gcc/ada/s-mmap.ads +++ /dev/null @@ -1,283 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides memory mapping of files. Depending on your operating --- system, this might provide a more efficient method for accessing the --- contents of files. --- A description of memory-mapping is available on the sqlite page, at: --- http://www.sqlite.org/mmap.html --- --- The traditional method for reading a file is to allocate a buffer in the --- application address space, then open the file and copy its contents. When --- memory mapping is available though, the application asks the operating --- system to return a pointer to the requested page, if possible. If the --- requested page has been or can be mapped into the application address --- space, the system returns a pointer to that page for the application to --- use without having to copy anything. Skipping the copy step is what makes --- memory mapped I/O faster. --- --- When memory mapping is not available, this package automatically falls --- back to the traditional copy method. --- --- Example of use for this package, when reading a file that can be fully --- mapped --- --- declare --- File : Mapped_File; --- Str : Str_Access; --- begin --- File := Open_Read ("/tmp/file_on_disk"); --- Read (File); -- read the whole file --- Str := Data (File); --- for S in 1 .. Last (File) loop --- Put (Str (S)); --- end loop; --- Close (File); --- end; --- --- When the file is big, or you only want to access part of it at a given --- time, you can use the following type of code. - --- declare --- File : Mapped_File; --- Str : Str_Access; --- Offs : File_Size := 0; --- Page : constant Integer := Get_Page_Size; --- begin --- File := Open_Read ("/tmp/file_on_disk"); --- while Offs < Length (File) loop --- Read (File, Offs, Length => Long_Integer (Page) * 4); --- Str := Data (File); --- --- -- Print characters for this chunk: --- for S in Integer (Offs - Offset (File)) + 1 .. Last (File) loop --- Put (Str (S)); --- end loop; --- --- -- Since we are reading multiples of Get_Page_Size, we can simplify --- -- with --- -- for S in 1 .. Last (File) loop ... --- --- Offs := Offs + Long_Integer (Last (File)); --- end loop; - -with Interfaces.C; - -with System.Strings; - -package System.Mmap is - - type Mapped_File is private; - -- File to be mapped in memory. - - -- This package will use the fastest possible algorithm to load the - -- file in memory. On systems that support it, the file is not really - -- loaded in memory. Instead, a call to the mmap() system call (or - -- CreateFileMapping()) will keep the file on disk, but make it - -- accessible as if it was in memory. - - -- When the system does not support it, the file is actually loaded in - -- memory through calls to read(), and written back with write() when you - -- close it. This is of course much slower. - - -- Legacy: each mapped file has a "default" mapped region in it. - - type Mapped_Region is private; - -- A representation of part of a file in memory. Actual reading/writing - -- is done through a mapped region. After being returned by Read, a mapped - -- region must be free'd when done. If the original Mapped_File was open - -- for reading, it can be closed before the mapped region is free'd. - - Invalid_Mapped_File : constant Mapped_File; - Invalid_Mapped_Region : constant Mapped_Region; - - type Unconstrained_String is new String (Positive); - type Str_Access is access all Unconstrained_String; - pragma No_Strict_Aliasing (Str_Access); - - type File_Size is new Interfaces.C.size_t; - - function To_Str_Access - (Str : System.Strings.String_Access) return Str_Access; - -- Convert Str. The returned value points to the same memory block, but no - -- longer includes the bounds, which you need to manage yourself - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return Mapped_File; - -- Open a file for reading. The same file can be shared by multiple - -- processes, that will see each others's changes as they occur. - -- Any attempt to write the data might result in a segmentation fault, - -- depending on how the file is open. - -- Name_Error is raised if the file does not exist. - -- Filename should be compatible with the filesystem. - - function Open_Read_No_Exception - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return Mapped_File; - -- Like Open_Read but return Invalid_Mapped_File in case of error - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return Mapped_File; - -- Open a file for writing. - -- You cannot change the length of the file. - -- Name_Error is raised if the file does not exist - -- Filename should be compatible with the filesystem. - - procedure Close (File : in out Mapped_File); - -- Close the file, and unmap the memory that is used for the region - -- contained in File. If the system does not support the unmmap() system - -- call or equivalent, or these were not available for the file itself, - -- then the file is written back to the disk if it was opened for writing. - - procedure Free (Region : in out Mapped_Region); - -- Unmap the memory that is used for this region and deallocate the region - - procedure Read - (File : Mapped_File; - Region : in out Mapped_Region; - Offset : File_Size := 0; - Length : File_Size := 0; - Mutable : Boolean := False); - -- Read a specific part of File and set Region to the corresponding mapped - -- region, or re-use it if possible. - -- Offset is the number of bytes since the beginning of the file at which - -- we should start reading. Length is the number of bytes that should be - -- read. If set to 0, as much of the file as possible is read (presumably - -- the whole file unless you are reading a _huge_ file). - -- Note that no (un)mapping is is done if that part of the file is already - -- available through Region. - -- If the file was opened for writing, any modification you do to the - -- data stored in File will be stored on disk (either immediately when the - -- file is opened through a mmap() system call, or when the file is closed - -- otherwise). - -- Mutable is processed only for reading files. If set to True, the - -- data can be modified, even through it will not be carried through the - -- underlying file, nor it is guaranteed to be carried through remapping. - -- This function takes care of page size alignment issues. The accessors - -- below only expose the region that has been requested by this call, even - -- if more bytes were actually mapped by this function. - -- TODO??? Enable to have a private copy for readable files - - function Read - (File : Mapped_File; - Offset : File_Size := 0; - Length : File_Size := 0; - Mutable : Boolean := False) return Mapped_Region; - -- Likewise, return a new mapped region - - procedure Read - (File : Mapped_File; - Offset : File_Size := 0; - Length : File_Size := 0; - Mutable : Boolean := False); - -- Likewise, use the legacy "default" region in File - - function Length (File : Mapped_File) return File_Size; - -- Size of the file on the disk - - function Offset (Region : Mapped_Region) return File_Size; - -- Return the offset, in the physical file on disk, corresponding to the - -- requested mapped region. The first byte in the file has offest 0. - - function Offset (File : Mapped_File) return File_Size; - -- Likewise for the region contained in File - - function Last (Region : Mapped_Region) return Integer; - -- Return the number of requested bytes mapped in this region. It is - -- erroneous to access Data for indices outside 1 .. Last (Region). - -- Such accesses may cause Storage_Error to be raised. - - function Last (File : Mapped_File) return Integer; - -- Return the number of requested bytes mapped in the region contained in - -- File. It is erroneous to access Data for indices outside of 1 .. Last - -- (File); such accesses may cause Storage_Error to be raised. - - function Data (Region : Mapped_Region) return Str_Access; - pragma Inline (Data); - -- The data mapped in Region as requested. The result is an unconstrained - -- string, so you cannot use the usual 'First and 'Last attributes. - -- Instead, these are respectively 1 and Size. - - function Data (File : Mapped_File) return Str_Access; - pragma Inline (Data); - -- Likewise for the region contained in File - - function Is_Mutable (Region : Mapped_Region) return Boolean; - -- Return whether it is safe to change bytes in Data (Region). This is true - -- for regions from writeable files, for regions mapped with the "Mutable" - -- flag set, and for regions that are copied in a buffer. Note that it is - -- not specified whether empty regions are mutable or not, since there is - -- no byte no modify. - - function Is_Mmapped (File : Mapped_File) return Boolean; - -- Whether regions for this file are opened through an mmap() system call - -- or equivalent. This is in general irrelevant to your application, unless - -- the file can be accessed by multiple concurrent processes or tasks. In - -- such a case, and if the file is indeed mmap-ed, then the various parts - -- of the file can be written simulatenously, and thus you cannot ensure - -- the integrity of the file. If the file is not mmapped, the latest - -- process to Close it overwrite what other processes have done. - - function Get_Page_Size return Integer; - -- Returns the number of bytes in a page. Once a file is mapped from the - -- disk, its offset and Length should be multiples of this page size (which - -- is ensured by this package in any case). Knowing this page size allows - -- you to map as much memory as possible at once, thus potentially reducing - -- the number of system calls to read the file by chunks. - - function Read_Whole_File - (Filename : String; - Empty_If_Not_Found : Boolean := False) - return System.Strings.String_Access; - -- Returns the whole contents of the file. - -- The returned string must be freed by the user. - -- This is a convenience function, which is of course slower than the ones - -- above since we also need to allocate some memory, actually read the file - -- and copy the bytes. - -- If the file does not exist, null is returned. However, if - -- Empty_If_Not_Found is True, then the empty string is returned instead. - -- Filename should be compatible with the filesystem. - -private - pragma Inline (Data, Length, Last, Offset, Is_Mmapped, To_Str_Access); - - type Mapped_File_Record; - type Mapped_File is access Mapped_File_Record; - - type Mapped_Region_Record; - type Mapped_Region is access Mapped_Region_Record; - - Invalid_Mapped_File : constant Mapped_File := null; - Invalid_Mapped_Region : constant Mapped_Region := null; - -end System.Mmap; diff --git a/gcc/ada/s-mmauni-long.ads b/gcc/ada/s-mmauni-long.ads deleted file mode 100644 index f7fa0bd..0000000 --- a/gcc/ada/s-mmauni-long.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . U N I X -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Declaration of off_t/mmap/munmap. This particular implementation --- supposes off_t is long. - -with System.OS_Lib; -with Interfaces.C; - -package System.Mmap.Unix is - - type Mmap_Prot is new Interfaces.C.int; --- PROT_NONE : constant Mmap_Prot := 16#00#; --- PROT_EXEC : constant Mmap_Prot := 16#04#; - PROT_READ : constant Mmap_Prot := 16#01#; - PROT_WRITE : constant Mmap_Prot := 16#02#; - - type Mmap_Flags is new Interfaces.C.int; --- MAP_NONE : constant Mmap_Flags := 16#00#; --- MAP_FIXED : constant Mmap_Flags := 16#10#; - MAP_SHARED : constant Mmap_Flags := 16#01#; - MAP_PRIVATE : constant Mmap_Flags := 16#02#; - - type off_t is new Long_Integer; - - function Mmap (Start : Address := Null_Address; - Length : Interfaces.C.size_t; - Prot : Mmap_Prot := PROT_READ; - Flags : Mmap_Flags := MAP_PRIVATE; - Fd : System.OS_Lib.File_Descriptor; - Offset : off_t) return Address; - pragma Import (C, Mmap, "mmap"); - - function Munmap (Start : Address; - Length : Interfaces.C.size_t) return Integer; - pragma Import (C, Munmap, "munmap"); - - function Is_Mapping_Available return Boolean is (True); - -- Wheter memory mapping is actually available on this system. It is an - -- error to use Create_Mapping and Dispose_Mapping if this is False. -end System.Mmap.Unix; diff --git a/gcc/ada/s-mmosin-mingw.adb b/gcc/ada/s-mmosin-mingw.adb deleted file mode 100644 index b850630..0000000 --- a/gcc/ada/s-mmosin-mingw.adb +++ /dev/null @@ -1,345 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with System.Strings; use System.Strings; - -with System.OS_Lib; -pragma Unreferenced (System.OS_Lib); --- Only used to generate same runtime dependencies and same binder file on --- GNU/Linux and Windows. - -package body System.Mmap.OS_Interface is - - use Win; - - function Align - (Addr : File_Size) return File_Size; - -- Align some offset/length to the lowest page boundary - - function Open_Common - (Filename : String; - Use_Mmap_If_Available : Boolean; - Write : Boolean) return System_File; - - function From_UTF8 (Path : String) return Wide_String; - -- Convert from UTF-8 to Wide_String - - --------------- - -- From_UTF8 -- - --------------- - - function From_UTF8 (Path : String) return Wide_String is - function MultiByteToWideChar - (Codepage : Interfaces.C.unsigned; - Flags : Interfaces.C.unsigned; - Mbstr : Address; - Mb : Natural; - Wcstr : Address; - Wc : Natural) return Integer; - pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar"); - - Current_Codepage : Interfaces.C.unsigned; - pragma Import (C, Current_Codepage, "__gnat_current_codepage"); - - Len : Natural; - begin - -- Compute length of the result - Len := MultiByteToWideChar - (Current_Codepage, 0, Path'Address, Path'Length, Null_Address, 0); - if Len = 0 then - raise Constraint_Error; - end if; - - declare - -- Declare result - Res : Wide_String (1 .. Len); - begin - -- And compute it - Len := MultiByteToWideChar - (Current_Codepage, 0, - Path'Address, Path'Length, - Res'Address, Len); - if Len = 0 then - raise Constraint_Error; - end if; - return Res; - end; - end From_UTF8; - - ----------------- - -- Open_Common -- - ----------------- - - function Open_Common - (Filename : String; - Use_Mmap_If_Available : Boolean; - Write : Boolean) return System_File - is - dwDesiredAccess, dwShareMode : DWORD; - PageFlags : DWORD; - - W_Filename : constant Wide_String := - From_UTF8 (Filename) & Wide_Character'Val (0); - File_Handle, Mapping_Handle : HANDLE; - - SizeH : aliased DWORD; - Size : File_Size; - begin - if Write then - dwDesiredAccess := GENERIC_READ + GENERIC_WRITE; - dwShareMode := 0; - PageFlags := Win.PAGE_READWRITE; - else - dwDesiredAccess := GENERIC_READ; - dwShareMode := Win.FILE_SHARE_READ; - PageFlags := Win.PAGE_READONLY; - end if; - - -- Actually open the file - - File_Handle := CreateFile - (W_Filename'Address, dwDesiredAccess, dwShareMode, - null, OPEN_EXISTING, Win.FILE_ATTRIBUTE_NORMAL, 0); - - if File_Handle = Win.INVALID_HANDLE_VALUE then - return Invalid_System_File; - end if; - - -- Compute its size - - Size := File_Size (Win.GetFileSize (File_Handle, SizeH'Access)); - - if Size = Win.INVALID_FILE_SIZE then - return Invalid_System_File; - end if; - - if SizeH /= 0 and then File_Size'Size > 32 then - Size := Size + (File_Size (SizeH) * 2 ** 32); - end if; - - -- Then create a mapping object, if needed. On Win32, file memory - -- mapping is always available. - - if Use_Mmap_If_Available then - Mapping_Handle := - Win.CreateFileMapping - (File_Handle, null, PageFlags, - 0, DWORD (Size), Standard.System.Null_Address); - else - Mapping_Handle := Win.INVALID_HANDLE_VALUE; - end if; - - return - (Handle => File_Handle, - Mapped => Use_Mmap_If_Available, - Mapping_Handle => Mapping_Handle, - Write => Write, - Length => Size); - end Open_Common; - - --------------- - -- Open_Read -- - --------------- - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - begin - return Open_Common (Filename, Use_Mmap_If_Available, False); - end Open_Read; - - ---------------- - -- Open_Write -- - ---------------- - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - begin - return Open_Common (Filename, Use_Mmap_If_Available, True); - end Open_Write; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out System_File) is - Ignored : BOOL; - pragma Unreferenced (Ignored); - begin - Ignored := CloseHandle (File.Mapping_Handle); - Ignored := CloseHandle (File.Handle); - File.Handle := Win.INVALID_HANDLE_VALUE; - File.Mapping_Handle := Win.INVALID_HANDLE_VALUE; - end Close; - - -------------------- - -- Read_From_Disk -- - -------------------- - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access - is - Buffer : String_Access := new String (1 .. Integer (Length)); - - Pos : DWORD; - NbRead : aliased DWORD; - pragma Unreferenced (Pos); - begin - Pos := Win.SetFilePointer - (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); - - if Win.ReadFile - (File.Handle, Buffer.all'Address, - DWORD (Length), NbRead'Unchecked_Access, null) = Win.FALSE - then - System.Strings.Free (Buffer); - raise Ada.IO_Exceptions.Device_Error; - end if; - return Buffer; - end Read_From_Disk; - - ------------------- - -- Write_To_Disk -- - ------------------- - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access) - is - Pos : DWORD; - NbWritten : aliased DWORD; - pragma Unreferenced (Pos); - begin - pragma Assert (File.Write); - Pos := Win.SetFilePointer - (File.Handle, LONG (Offset), null, Win.FILE_BEGIN); - - if Win.WriteFile - (File.Handle, Buffer.all'Address, - DWORD (Length), NbWritten'Unchecked_Access, null) = Win.FALSE - then - raise Ada.IO_Exceptions.Device_Error; - end if; - end Write_To_Disk; - - -------------------- - -- Create_Mapping -- - -------------------- - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping) - is - Flags : DWORD; - begin - if File.Write then - Flags := Win.FILE_MAP_WRITE; - elsif Mutable then - Flags := Win.FILE_MAP_COPY; - else - Flags := Win.FILE_MAP_READ; - end if; - - -- Adjust offset and mapping length to account for the required - -- alignment of offset on page boundary. - - declare - Queried_Offset : constant File_Size := Offset; - begin - Offset := Align (Offset); - - -- First extend the length to compensate the offset shift, then align - -- it on the upper page boundary, so that the whole queried area is - -- covered. - - Length := Length + Queried_Offset - Offset; - Length := Align (Length + Get_Page_Size - 1); - - -- But do not exceed the length of the file - if Offset + Length > File.Length then - Length := File.Length - Offset; - end if; - end; - - if Length > File_Size (Integer'Last) then - raise Ada.IO_Exceptions.Device_Error; - else - Mapping := Invalid_System_Mapping; - Mapping.Address := - Win.MapViewOfFile - (File.Mapping_Handle, Flags, - 0, DWORD (Offset), SIZE_T (Length)); - Mapping.Length := Length; - end if; - end Create_Mapping; - - --------------------- - -- Dispose_Mapping -- - --------------------- - - procedure Dispose_Mapping - (Mapping : in out System_Mapping) - is - Ignored : BOOL; - pragma Unreferenced (Ignored); - begin - Ignored := Win.UnmapViewOfFile (Mapping.Address); - Mapping := Invalid_System_Mapping; - end Dispose_Mapping; - - ------------------- - -- Get_Page_Size -- - ------------------- - - function Get_Page_Size return File_Size is - SystemInfo : aliased SYSTEM_INFO; - begin - GetSystemInfo (SystemInfo'Unchecked_Access); - return File_Size (SystemInfo.dwAllocationGranularity); - end Get_Page_Size; - - ----------- - -- Align -- - ----------- - - function Align - (Addr : File_Size) return File_Size is - begin - return Addr - Addr mod Get_Page_Size; - end Align; - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/s-mmosin-mingw.ads b/gcc/ada/s-mmosin-mingw.ads deleted file mode 100644 index ad296c1..0000000 --- a/gcc/ada/s-mmosin-mingw.ads +++ /dev/null @@ -1,235 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- OS pecularities abstraction package for Win32 systems. - -package System.Mmap.OS_Interface is - - -- The Win package contains copy of definition found in recent System.Win32 - -- unit provided with the GNAT compiler. The copy is needed to be able to - -- compile this unit with older compilers. Note that this internal Win - -- package can be removed when GNAT 6.1.0 is not supported anymore. - - package Win is - - subtype PVOID is Standard.System.Address; - - type HANDLE is new Interfaces.C.ptrdiff_t; - - type WORD is new Interfaces.C.unsigned_short; - type DWORD is new Interfaces.C.unsigned_long; - type LONG is new Interfaces.C.long; - type SIZE_T is new Interfaces.C.size_t; - - type BOOL is new Interfaces.C.int; - for BOOL'Size use Interfaces.C.int'Size; - - FALSE : constant := 0; - - GENERIC_READ : constant := 16#80000000#; - GENERIC_WRITE : constant := 16#40000000#; - OPEN_EXISTING : constant := 3; - - type OVERLAPPED is record - Internal : DWORD; - InternalHigh : DWORD; - Offset : DWORD; - OffsetHigh : DWORD; - hEvent : HANDLE; - end record; - - type SECURITY_ATTRIBUTES is record - nLength : DWORD; - pSecurityDescriptor : PVOID; - bInheritHandle : BOOL; - end record; - - type SYSTEM_INFO is record - dwOemId : DWORD; - dwPageSize : DWORD; - lpMinimumApplicationAddress : PVOID; - lpMaximumApplicationAddress : PVOID; - dwActiveProcessorMask : PVOID; - dwNumberOfProcessors : DWORD; - dwProcessorType : DWORD; - dwAllocationGranularity : DWORD; - wProcessorLevel : WORD; - wProcessorRevision : WORD; - end record; - type LP_SYSTEM_INFO is access all SYSTEM_INFO; - - INVALID_HANDLE_VALUE : constant HANDLE := -1; - FILE_BEGIN : constant := 0; - FILE_SHARE_READ : constant := 16#00000001#; - FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#; - FILE_MAP_COPY : constant := 1; - FILE_MAP_READ : constant := 4; - FILE_MAP_WRITE : constant := 2; - PAGE_READONLY : constant := 16#0002#; - PAGE_READWRITE : constant := 16#0004#; - INVALID_FILE_SIZE : constant := 16#FFFFFFFF#; - - function CreateFile - (lpFileName : Standard.System.Address; - dwDesiredAccess : DWORD; - dwShareMode : DWORD; - lpSecurityAttributes : access SECURITY_ATTRIBUTES; - dwCreationDisposition : DWORD; - dwFlagsAndAttributes : DWORD; - hTemplateFile : HANDLE) return HANDLE; - pragma Import (Stdcall, CreateFile, "CreateFileW"); - - function WriteFile - (hFile : HANDLE; - lpBuffer : Standard.System.Address; - nNumberOfBytesToWrite : DWORD; - lpNumberOfBytesWritten : access DWORD; - lpOverlapped : access OVERLAPPED) return BOOL; - pragma Import (Stdcall, WriteFile, "WriteFile"); - - function ReadFile - (hFile : HANDLE; - lpBuffer : Standard.System.Address; - nNumberOfBytesToRead : DWORD; - lpNumberOfBytesRead : access DWORD; - lpOverlapped : access OVERLAPPED) return BOOL; - pragma Import (Stdcall, ReadFile, "ReadFile"); - - function CloseHandle (hObject : HANDLE) return BOOL; - pragma Import (Stdcall, CloseHandle, "CloseHandle"); - - function GetFileSize - (hFile : HANDLE; lpFileSizeHigh : access DWORD) return DWORD; - pragma Import (Stdcall, GetFileSize, "GetFileSize"); - - function SetFilePointer - (hFile : HANDLE; - lDistanceToMove : LONG; - lpDistanceToMoveHigh : access LONG; - dwMoveMethod : DWORD) return DWORD; - pragma Import (Stdcall, SetFilePointer, "SetFilePointer"); - - function CreateFileMapping - (hFile : HANDLE; - lpSecurityAttributes : access SECURITY_ATTRIBUTES; - flProtect : DWORD; - dwMaximumSizeHigh : DWORD; - dwMaximumSizeLow : DWORD; - lpName : Standard.System.Address) return HANDLE; - pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingW"); - - function MapViewOfFile - (hFileMappingObject : HANDLE; - dwDesiredAccess : DWORD; - dwFileOffsetHigh : DWORD; - dwFileOffsetLow : DWORD; - dwNumberOfBytesToMap : SIZE_T) return Standard.System.Address; - pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile"); - - function UnmapViewOfFile - (lpBaseAddress : Standard.System.Address) return BOOL; - pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile"); - - procedure GetSystemInfo (lpSystemInfo : LP_SYSTEM_INFO); - pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); - - end Win; - - type System_File is record - Handle : Win.HANDLE; - - Mapped : Boolean; - -- Whether mapping is requested by the user and available on the system - - Mapping_Handle : Win.HANDLE; - - Write : Boolean; - -- Whether this file can be written to - - Length : File_Size; - -- Length of the file. Used to know what can be mapped in the file - end record; - - type System_Mapping is record - Address : Standard.System.Address; - Length : File_Size; - end record; - - Invalid_System_File : constant System_File := - (Win.INVALID_HANDLE_VALUE, False, Win.INVALID_HANDLE_VALUE, False, 0); - Invalid_System_Mapping : constant System_Mapping := - (Standard.System.Null_Address, 0); - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Open a file for reading and return the corresponding System_File. Return - -- Invalid_System_File if unsuccessful. - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Likewise for writing to a file - - procedure Close (File : in out System_File); - -- Close a system file - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access; - -- Read a fragment of a file. It is up to the caller to free the result - -- when done with it. - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access); - -- Write some content to a fragment of a file - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping); - -- Create a memory mapping for the given File, for the area starting at - -- Offset and containing Length bytes. Store it to Mapping. - -- Note that Offset and Length may be modified according to the system - -- needs (for boudaries, for instance). The caller must cope with actually - -- wider mapped areas. - - procedure Dispose_Mapping - (Mapping : in out System_Mapping); - -- Unmap a previously-created mapping - - function Get_Page_Size return File_Size; - -- Return the number of bytes in a system page. - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/s-mmosin-unix.adb b/gcc/ada/s-mmosin-unix.adb deleted file mode 100644 index 634d980..0000000 --- a/gcc/ada/s-mmosin-unix.adb +++ /dev/null @@ -1,229 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with System; use System; - -with System.OS_Lib; use System.OS_Lib; -with System.Mmap.Unix; use System.Mmap.Unix; - -package body System.Mmap.OS_Interface is - - function Align - (Addr : File_Size) return File_Size; - -- Align some offset/length to the lowest page boundary - - function Is_Mapping_Available return Boolean renames - System.Mmap.Unix.Is_Mapping_Available; - -- Wheter memory mapping is actually available on this system. It is an - -- error to use Create_Mapping and Dispose_Mapping if this is False. - - --------------- - -- Open_Read -- - --------------- - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - Fd : constant File_Descriptor := - Open_Read (Filename, Binary); - begin - if Fd = Invalid_FD then - return Invalid_System_File; - end if; - return - (Fd => Fd, - Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, - Write => False, - Length => File_Size (File_Length (Fd))); - end Open_Read; - - ---------------- - -- Open_Write -- - ---------------- - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File is - Fd : constant File_Descriptor := - Open_Read_Write (Filename, Binary); - begin - if Fd = Invalid_FD then - return Invalid_System_File; - end if; - return - (Fd => Fd, - Mapped => Use_Mmap_If_Available and then Is_Mapping_Available, - Write => True, - Length => File_Size (File_Length (Fd))); - end Open_Write; - - ----------- - -- Close -- - ----------- - - procedure Close (File : in out System_File) is - begin - Close (File.Fd); - File.Fd := Invalid_FD; - end Close; - - -------------------- - -- Read_From_Disk -- - -------------------- - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access - is - Buffer : String_Access := new String (1 .. Integer (Length)); - begin - -- ??? Lseek offset should be a size_t instead of a Long_Integer - - Lseek (File.Fd, Long_Integer (Offset), Seek_Set); - if System.OS_Lib.Read (File.Fd, Buffer.all'Address, Integer (Length)) - /= Integer (Length) - then - System.Strings.Free (Buffer); - raise Ada.IO_Exceptions.Device_Error; - end if; - return Buffer; - end Read_From_Disk; - - ------------------- - -- Write_To_Disk -- - ------------------- - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access) is - begin - pragma Assert (File.Write); - Lseek (File.Fd, Long_Integer (Offset), Seek_Set); - if System.OS_Lib.Write (File.Fd, Buffer.all'Address, Integer (Length)) - /= Integer (Length) - then - raise Ada.IO_Exceptions.Device_Error; - end if; - end Write_To_Disk; - - -------------------- - -- Create_Mapping -- - -------------------- - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping) - is - Prot : Mmap_Prot; - Flags : Mmap_Flags; - begin - if File.Write then - Prot := PROT_READ + PROT_WRITE; - Flags := MAP_SHARED; - else - Prot := PROT_READ; - if Mutable then - Prot := Prot + PROT_WRITE; - end if; - Flags := MAP_PRIVATE; - end if; - - -- Adjust offset and mapping length to account for the required - -- alignment of offset on page boundary. - - declare - Queried_Offset : constant File_Size := Offset; - begin - Offset := Align (Offset); - - -- First extend the length to compensate the offset shift, then align - -- it on the upper page boundary, so that the whole queried area is - -- covered. - - Length := Length + Queried_Offset - Offset; - Length := Align (Length + Get_Page_Size - 1); - end; - - if Length > File_Size (Integer'Last) then - raise Ada.IO_Exceptions.Device_Error; - else - Mapping := - (Address => System.Mmap.Unix.Mmap - (Offset => off_t (Offset), - Length => Interfaces.C.size_t (Length), - Prot => Prot, - Flags => Flags, - Fd => File.Fd), - Length => Length); - end if; - end Create_Mapping; - - --------------------- - -- Dispose_Mapping -- - --------------------- - - procedure Dispose_Mapping - (Mapping : in out System_Mapping) - is - Ignored : Integer; - pragma Unreferenced (Ignored); - begin - Ignored := Munmap - (Mapping.Address, Interfaces.C.size_t (Mapping.Length)); - Mapping := Invalid_System_Mapping; - end Dispose_Mapping; - - ------------------- - -- Get_Page_Size -- - ------------------- - - function Get_Page_Size return File_Size is - function Internal return Integer; - pragma Import (C, Internal, "getpagesize"); - begin - return File_Size (Internal); - end Get_Page_Size; - - ----------- - -- Align -- - ----------- - - function Align - (Addr : File_Size) return File_Size is - begin - return Addr - Addr mod Get_Page_Size; - end Align; - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/s-mmosin-unix.ads b/gcc/ada/s-mmosin-unix.ads deleted file mode 100644 index 002bf77..0000000 --- a/gcc/ada/s-mmosin-unix.ads +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . M M A P . O S _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2016, AdaCore -- --- -- --- This library is free software; you can redistribute it and/or modify it -- --- under terms of the GNU General Public License as published by the Free -- --- Software Foundation; either version 3, or (at your option) any later -- --- version. This library is distributed in the hope that it will be useful, -- --- but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHAN- -- --- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.OS_Lib; - --- OS pecularities abstraction package for Unix systems. - -package System.Mmap.OS_Interface is - - type System_File is record - Fd : System.OS_Lib.File_Descriptor; - - Mapped : Boolean; - -- Whether mapping is requested by the user and available on the system - - Write : Boolean; - -- Whether this file can be written to - - Length : File_Size; - -- Length of the file. Used to know what can be mapped in the file - end record; - - type System_Mapping is record - Address : Standard.System.Address; - Length : File_Size; - end record; - - Invalid_System_File : constant System_File := - (System.OS_Lib.Invalid_FD, False, False, 0); - Invalid_System_Mapping : constant System_Mapping := - (Standard.System.Null_Address, 0); - - function Open_Read - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Open a file for reading and return the corresponding System_File. Return - -- Invalid_System_File if unsuccessful. - - function Open_Write - (Filename : String; - Use_Mmap_If_Available : Boolean := True) return System_File; - -- Likewise for writing to a file - - procedure Close (File : in out System_File); - -- Close a system file - - function Read_From_Disk - (File : System_File; - Offset, Length : File_Size) return System.Strings.String_Access; - -- Read a fragment of a file. It is up to the caller to free the result - -- when done with it. - - procedure Write_To_Disk - (File : System_File; - Offset, Length : File_Size; - Buffer : System.Strings.String_Access); - -- Write some content to a fragment of a file - - procedure Create_Mapping - (File : System_File; - Offset, Length : in out File_Size; - Mutable : Boolean; - Mapping : out System_Mapping); - -- Create a memory mapping for the given File, for the area starting at - -- Offset and containing Length bytes. Store it to Mapping. - -- Note that Offset and Length may be modified according to the system - -- needs (for boudaries, for instance). The caller must cope with actually - -- wider mapped areas. - - procedure Dispose_Mapping - (Mapping : in out System_Mapping); - -- Unmap a previously-created mapping - - function Get_Page_Size return File_Size; - -- Return the number of bytes in a system page. - -end System.Mmap.OS_Interface; diff --git a/gcc/ada/s-multip.adb b/gcc/ada/s-multip.adb deleted file mode 100644 index 239d5e0..0000000 --- a/gcc/ada/s-multip.adb +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . M U L T I P R O C E S S O R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2010-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- ------------------------------------------------------------------------------- - -with Interfaces.C; use Interfaces.C; - -package body System.Multiprocessors is - - -------------------- - -- Number_Of_CPUs -- - -------------------- - - function Number_Of_CPUs return CPU is - begin - if CPU'Last = 1 then - return 1; - else - declare - function Gnat_Number_Of_CPUs return int; - pragma Import (C, Gnat_Number_Of_CPUs, "__gnat_number_of_cpus"); - begin - return CPU (Gnat_Number_Of_CPUs); - end; - end if; - end Number_Of_CPUs; - -end System.Multiprocessors; diff --git a/gcc/ada/s-multip.ads b/gcc/ada/s-multip.ads deleted file mode 100644 index 7eb8dd6..0000000 --- a/gcc/ada/s-multip.ads +++ /dev/null @@ -1,28 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . M U L T I P R O C E S S O R S -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -package System.Multiprocessors is - pragma Preelaborate (Multiprocessors); - - type CPU_Range is range 0 .. 2 ** 16 - 1; - - subtype CPU is CPU_Range range 1 .. CPU_Range'Last; - - Not_A_Specific_CPU : constant CPU_Range := 0; - - function Number_Of_CPUs return CPU; - -- Number of available CPUs - -end System.Multiprocessors; diff --git a/gcc/ada/s-objrea.adb b/gcc/ada/s-objrea.adb deleted file mode 100644 index 451abcd..0000000 --- a/gcc/ada/s-objrea.adb +++ /dev/null @@ -1,2246 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . O B J E C T _ R E A D E R -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -with Interfaces.C; - -with System.CRTL; - -package body System.Object_Reader is - use Interfaces; - use Interfaces.C; - use System.Mmap; - - SSU : constant := System.Storage_Unit; - - function To_int32 is new Ada.Unchecked_Conversion (uint32, int32); - - function Trim_Trailing_Nuls (Str : String) return String; - -- Return a copy of a string with any trailing NUL characters truncated - - procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32); - -- Check that the SIZE bytes at the current offset are still in the stream - - ------------------------------------- - -- ELF object file format handling -- - ------------------------------------- - - generic - type uword is mod <>; - - package ELF_Ops is - - -- ELF version codes - - ELFCLASS32 : constant := 1; -- 32 bit ELF - ELFCLASS64 : constant := 2; -- 64 bit ELF - - -- ELF machine codes - - EM_NONE : constant := 0; -- No machine - EM_SPARC : constant := 2; -- SUN SPARC - EM_386 : constant := 3; -- Intel 80386 - EM_MIPS : constant := 8; -- MIPS RS3000 Big-Endian - EM_MIPS_RS3_LE : constant := 10; -- MIPS RS3000 Little-Endian - EM_SPARC32PLUS : constant := 18; -- Sun SPARC 32+ - EM_PPC : constant := 20; -- PowerPC - EM_PPC64 : constant := 21; -- PowerPC 64-bit - EM_ARM : constant := 40; -- ARM - EM_SPARCV9 : constant := 43; -- SPARC v9 64-bit - EM_IA_64 : constant := 50; -- Intel Merced - EM_X86_64 : constant := 62; -- AMD x86-64 architecture - - EN_NIDENT : constant := 16; - - type E_Ident_Type is array (0 .. EN_NIDENT - 1) of uint8; - - type Header is record - E_Ident : E_Ident_Type; -- Magic number and other info - E_Type : uint16; -- Object file type - E_Machine : uint16; -- Architecture - E_Version : uint32; -- Object file version - E_Entry : uword; -- Entry point virtual address - E_Phoff : uword; -- Program header table file offset - E_Shoff : uword; -- Section header table file offset - E_Flags : uint32; -- Processor-specific flags - E_Ehsize : uint16; -- ELF header size in bytes - E_Phentsize : uint16; -- Program header table entry size - E_Phnum : uint16; -- Program header table entry count - E_Shentsize : uint16; -- Section header table entry size - E_Shnum : uint16; -- Section header table entry count - E_Shstrndx : uint16; -- Section header string table index - end record; - - type Section_Header is record - Sh_Name : uint32; -- Section name string table index - Sh_Type : uint32; -- Section type - Sh_Flags : uword; -- Section flags - Sh_Addr : uword; -- Section virtual addr at execution - Sh_Offset : uword; -- Section file offset - Sh_Size : uword; -- Section size in bytes - Sh_Link : uint32; -- Link to another section - Sh_Info : uint32; -- Additional section information - Sh_Addralign : uword; -- Section alignment - Sh_Entsize : uword; -- Entry size if section holds table - end record; - - SHF_ALLOC : constant := 2; - - type Symtab_Entry32 is record - St_Name : uint32; -- Name (string table index) - St_Value : uint32; -- Value - St_Size : uint32; -- Size in bytes - St_Info : uint8; -- Type and binding attributes - St_Other : uint8; -- Undefined - St_Shndx : uint16; -- Defining section - end record; - - type Symtab_Entry64 is record - St_Name : uint32; -- Name (string table index) - St_Info : uint8; -- Type and binding attributes - St_Other : uint8; -- Undefined - St_Shndx : uint16; -- Defining section - St_Value : uint64; -- Value - St_Size : uint64; -- Size in bytes - end record; - - function Read_Header (F : in out Mapped_Stream) return Header; - -- Read a header from an ELF format object - - function First_Symbol - (Obj : in out ELF_Object_File) return Object_Symbol; - -- Return the first element in the symbol table, or Null_Symbol if the - -- symbol table is empty. - - function Read_Symbol - (Obj : in out ELF_Object_File; - Off : Offset) return Object_Symbol; - -- Read a symbol at offset Off - - function Name - (Obj : in out ELF_Object_File; - Sym : Object_Symbol) return String_Ptr_Len; - -- Return the name of the symbol - - function Name - (Obj : in out ELF_Object_File; - Sec : Object_Section) return String; - -- Return the name of a section - - function Get_Section - (Obj : in out ELF_Object_File; - Shnum : uint32) return Object_Section; - -- Fetch a section by index from zero - - function Initialize - (F : Mapped_File; - Hdr : Header; - In_Exception : Boolean) return ELF_Object_File; - -- Initialize an object file - - end ELF_Ops; - - ----------------------------------- - -- PECOFF object format handling -- - ----------------------------------- - - package PECOFF_Ops is - - -- Constants and data layout are taken from the document "Microsoft - -- Portable Executable and Common Object File Format Specification" - -- Revision 8.1. - - Signature_Loc_Offset : constant := 16#3C#; - -- Offset of pointer to the file signature - - Size_Of_Standard_Header_Fields : constant := 16#18#; - -- Length in bytes of the standard header record - - Function_Symbol_Type : constant := 16#20#; - -- Type field value indicating a symbol refers to a function - - Not_Function_Symbol_Type : constant := 16#00#; - -- Type field value indicating a symbol does not refer to a function - - type Magic_Array is array (0 .. 3) of uint8; - -- Array of magic numbers from the header - - -- Magic numbers for PECOFF variants - - VARIANT_PE32 : constant := 16#010B#; - VARIANT_PE32_PLUS : constant := 16#020B#; - - -- PECOFF machine codes - - IMAGE_FILE_MACHINE_I386 : constant := 16#014C#; - IMAGE_FILE_MACHINE_IA64 : constant := 16#0200#; - IMAGE_FILE_MACHINE_AMD64 : constant := 16#8664#; - - -- PECOFF Data layout - - type Header is record - Magics : Magic_Array; - Machine : uint16; - NumberOfSections : uint16; - TimeDateStamp : uint32; - PointerToSymbolTable : uint32; - NumberOfSymbols : uint32; - SizeOfOptionalHeader : uint16; - Characteristics : uint16; - Variant : uint16; - end record; - - pragma Pack (Header); - - type Optional_Header_PE32 is record - Magic : uint16; - MajorLinkerVersion : uint8; - MinorLinkerVersion : uint8; - SizeOfCode : uint32; - SizeOfInitializedData : uint32; - SizeOfUninitializedData : uint32; - AddressOfEntryPoint : uint32; - BaseOfCode : uint32; - BaseOfData : uint32; -- Note: not in PE32+ - ImageBase : uint32; - SectionAlignment : uint32; - FileAlignment : uint32; - MajorOperatingSystemVersion : uint16; - MinorOperationSystemVersion : uint16; - MajorImageVersion : uint16; - MinorImageVersion : uint16; - MajorSubsystemVersion : uint16; - MinorSubsystemVersion : uint16; - Win32VersionValue : uint32; - SizeOfImage : uint32; - SizeOfHeaders : uint32; - Checksum : uint32; - Subsystem : uint16; - DllCharacteristics : uint16; - SizeOfStackReserve : uint32; - SizeOfStackCommit : uint32; - SizeOfHeapReserve : uint32; - SizeOfHeapCommit : uint32; - LoaderFlags : uint32; - NumberOfRvaAndSizes : uint32; - end record; - pragma Pack (Optional_Header_PE32); - pragma Assert (Optional_Header_PE32'Size = 96 * SSU); - - type Optional_Header_PE64 is record - Magic : uint16; - MajorLinkerVersion : uint8; - MinorLinkerVersion : uint8; - SizeOfCode : uint32; - SizeOfInitializedData : uint32; - SizeOfUninitializedData : uint32; - AddressOfEntryPoint : uint32; - BaseOfCode : uint32; - ImageBase : uint64; - SectionAlignment : uint32; - FileAlignment : uint32; - MajorOperatingSystemVersion : uint16; - MinorOperationSystemVersion : uint16; - MajorImageVersion : uint16; - MinorImageVersion : uint16; - MajorSubsystemVersion : uint16; - MinorSubsystemVersion : uint16; - Win32VersionValue : uint32; - SizeOfImage : uint32; - SizeOfHeaders : uint32; - Checksum : uint32; - Subsystem : uint16; - DllCharacteristics : uint16; - SizeOfStackReserve : uint64; - SizeOfStackCommit : uint64; - SizeOfHeapReserve : uint64; - SizeOfHeapCommit : uint64; - LoaderFlags : uint32; - NumberOfRvaAndSizes : uint32; - end record; - pragma Pack (Optional_Header_PE64); - pragma Assert (Optional_Header_PE64'Size = 112 * SSU); - - subtype Name_Str is String (1 .. 8); - - type Section_Header is record - Name : Name_Str; - VirtualSize : uint32; - VirtualAddress : uint32; - SizeOfRawData : uint32; - PointerToRawData : uint32; - PointerToRelocations : uint32; - PointerToLinenumbers : uint32; - NumberOfRelocations : uint16; - NumberOfLinenumbers : uint16; - Characteristics : uint32; - end record; - - pragma Pack (Section_Header); - - IMAGE_SCN_CNT_CODE : constant := 16#0020#; - - type Symtab_Entry is record - Name : Name_Str; - Value : uint32; - SectionNumber : int16; - TypeField : uint16; - StorageClass : uint8; - NumberOfAuxSymbols : uint8; - end record; - - pragma Pack (Symtab_Entry); - - type Auxent_Section is record - Length : uint32; - NumberOfRelocations : uint16; - NumberOfLinenumbers : uint16; - CheckSum : uint32; - Number : uint16; - Selection : uint8; - Unused1 : uint8; - Unused2 : uint8; - Unused3 : uint8; - end record; - - for Auxent_Section'Size use 18 * 8; - - function Read_Header (F : in out Mapped_Stream) return Header; - -- Read the object file header - - function First_Symbol - (Obj : in out PECOFF_Object_File) return Object_Symbol; - -- Return the first element in the symbol table, or Null_Symbol if the - -- symbol table is empty. - - function Read_Symbol - (Obj : in out PECOFF_Object_File; - Off : Offset) return Object_Symbol; - -- Read a symbol at offset Off - - function Name - (Obj : in out PECOFF_Object_File; - Sym : Object_Symbol) return String_Ptr_Len; - -- Return the name of the symbol - - function Name - (Obj : in out PECOFF_Object_File; - Sec : Object_Section) return String; - -- Return the name of a section - - function Get_Section - (Obj : in out PECOFF_Object_File; - Index : uint32) return Object_Section; - -- Fetch a section by index from zero - - function Initialize - (F : Mapped_File; - Hdr : Header; - In_Exception : Boolean) return PECOFF_Object_File; - -- Initialize an object file - - end PECOFF_Ops; - - ------------------------------------- - -- XCOFF-32 object format handling -- - ------------------------------------- - - package XCOFF32_Ops is - - -- XCOFF Data layout - - type Header is record - f_magic : uint16; - f_nscns : uint16; - f_timdat : uint32; - f_symptr : uint32; - f_nsyms : uint32; - f_opthdr : uint16; - f_flags : uint16; - end record; - - type Auxiliary_Header is record - o_mflag : uint16; - o_vstamp : uint16; - o_tsize : uint32; - o_dsize : uint32; - o_bsize : uint32; - o_entry : uint32; - o_text_start : uint32; - o_data_start : uint32; - o_toc : uint32; - o_snentry : uint16; - o_sntext : uint16; - o_sndata : uint16; - o_sntoc : uint16; - o_snloader : uint16; - o_snbss : uint16; - o_algntext : uint16; - o_algndata : uint16; - o_modtype : uint16; - o_cpuflag : uint8; - o_cputype : uint8; - o_maxstack : uint32; - o_maxdata : uint32; - o_debugger : uint32; - o_flags : uint8; - o_sntdata : uint16; - o_sntbss : uint16; - end record; - pragma Unreferenced (Auxiliary_Header); - -- Not used, but not removed (just in case) - - subtype Name_Str is String (1 .. 8); - - type Section_Header is record - s_name : Name_Str; - s_paddr : uint32; - s_vaddr : uint32; - s_size : uint32; - s_scnptr : uint32; - s_relptr : uint32; - s_lnnoptr : uint32; - s_nreloc : uint16; - s_nlnno : uint16; - s_flags : uint32; - end record; - - pragma Pack (Section_Header); - - STYP_TEXT : constant := 16#0020#; - - type Symbol_Entry is record - n_name : Name_Str; - n_value : uint32; - n_scnum : uint16; - n_type : uint16; - n_sclass : uint8; - n_numaux : uint8; - end record; - for Symbol_Entry'Size use 18 * 8; - - type Aux_Entry is record - x_scnlen : uint32; - x_parmhash : uint32; - x_snhash : uint16; - x_smtyp : uint8; - x_smclass : uint8; - x_stab : uint32; - x_snstab : uint16; - end record; - for Aux_Entry'Size use 18 * 8; - - pragma Pack (Aux_Entry); - - C_EXT : constant := 2; - C_HIDEXT : constant := 107; - C_WEAKEXT : constant := 111; - - XTY_LD : constant := 2; - -- Magic constant should be documented, especially since it's changed??? - - function Read_Header (F : in out Mapped_Stream) return Header; - -- Read the object file header - - function First_Symbol - (Obj : in out XCOFF32_Object_File) return Object_Symbol; - -- Return the first element in the symbol table, or Null_Symbol if the - -- symbol table is empty. - - function Read_Symbol - (Obj : in out XCOFF32_Object_File; - Off : Offset) return Object_Symbol; - -- Read a symbol at offset Off - - function Name - (Obj : in out XCOFF32_Object_File; - Sym : Object_Symbol) return String_Ptr_Len; - -- Return the name of the symbol - - function Name - (Obj : in out XCOFF32_Object_File; - Sec : Object_Section) return String; - -- Return the name of a section - - function Initialize - (F : Mapped_File; - Hdr : Header; - In_Exception : Boolean) return XCOFF32_Object_File; - -- Initialize an object file - - function Get_Section - (Obj : in out XCOFF32_Object_File; - Index : uint32) return Object_Section; - -- Fetch a section by index from zero - - end XCOFF32_Ops; - - ------------- - -- ELF_Ops -- - ------------- - - package body ELF_Ops is - - function Get_String_Table (Obj : in out ELF_Object_File) - return Object_Section; - -- Fetch the section containing the string table - - function Get_Symbol_Table (Obj : in out ELF_Object_File) - return Object_Section; - -- Fetch the section containing the symbol table - - function Read_Section_Header - (Obj : in out ELF_Object_File; - Shnum : uint32) return Section_Header; - -- Read the header for an ELF format object section indexed from zero - - ------------------ - -- First_Symbol -- - ------------------ - - function First_Symbol - (Obj : in out ELF_Object_File) return Object_Symbol - is - begin - if Obj.Symtab_Last = 0 then - return Null_Symbol; - else - return Read_Symbol (Obj, 0); - end if; - end First_Symbol; - - ----------------- - -- Get_Section -- - ----------------- - - function Get_Section - (Obj : in out ELF_Object_File; - Shnum : uint32) return Object_Section - is - SHdr : constant Section_Header := Read_Section_Header (Obj, Shnum); - begin - return (Shnum, - Offset (SHdr.Sh_Offset), - uint64 (SHdr.Sh_Addr), - uint64 (SHdr.Sh_Size), - (SHdr.Sh_Flags and SHF_ALLOC) /= 0); - end Get_Section; - - ------------------------ - -- Get_String_Table -- - ------------------------ - - function Get_String_Table - (Obj : in out ELF_Object_File) return Object_Section - is - begin - -- All cases except MIPS IRIX, string table located in .strtab - - if Obj.Arch /= MIPS then - return Get_Section (Obj, ".strtab"); - - -- On IRIX only .dynstr is available - - else - return Get_Section (Obj, ".dynstr"); - end if; - end Get_String_Table; - - ------------------------ - -- Get_Symbol_Table -- - ------------------------ - - function Get_Symbol_Table - (Obj : in out ELF_Object_File) return Object_Section - is - begin - -- All cases except MIPS IRIX, symbol table located in .symtab - - if Obj.Arch /= MIPS then - return Get_Section (Obj, ".symtab"); - - -- On IRIX, symbol table located somewhere other than .symtab - - else - return Get_Section (Obj, ".dynsym"); - end if; - end Get_Symbol_Table; - - ---------------- - -- Initialize -- - ---------------- - - function Initialize - (F : Mapped_File; - Hdr : Header; - In_Exception : Boolean) return ELF_Object_File - is - Res : ELF_Object_File - (Format => (case uword'Size is - when 64 => ELF64, - when 32 => ELF32, - when others => raise Program_Error)); - Sec : Object_Section; - begin - Res.MF := F; - Res.In_Exception := In_Exception; - Res.Num_Sections := uint32 (Hdr.E_Shnum); - - case Hdr.E_Machine is - when EM_SPARC - | EM_SPARC32PLUS - => - Res.Arch := SPARC; - - when EM_386 => - Res.Arch := i386; - - when EM_MIPS - | EM_MIPS_RS3_LE - => - Res.Arch := MIPS; - - when EM_PPC => - Res.Arch := PPC; - - when EM_PPC64 => - Res.Arch := PPC64; - - when EM_SPARCV9 => - Res.Arch := SPARC64; - - when EM_IA_64 => - Res.Arch := IA64; - - when EM_X86_64 => - Res.Arch := x86_64; - - when others => - raise Format_Error with "unrecognized architecture"; - end case; - - -- Map section table and section string table - Res.Sectab_Stream := Create_Stream - (F, File_Size (Hdr.E_Shoff), - File_Size (Hdr.E_Shnum) * File_Size (Hdr.E_Shentsize)); - Sec := Get_Section (Res, uint32 (Hdr.E_Shstrndx)); - Res.Secstr_Stream := Create_Stream (Res, Sec); - - -- Map symbol and string table - Sec := Get_Symbol_Table (Res); - Res.Symtab_Stream := Create_Stream (Res, Sec); - Res.Symtab_Last := Offset (Sec.Size); - - Sec := Get_String_Table (Res); - Res.Symstr_Stream := Create_Stream (Res, Sec); - - return Res; - end Initialize; - - ----------------- - -- Read_Header -- - ----------------- - - function Read_Header (F : in out Mapped_Stream) return Header is - Hdr : Header; - begin - Seek (F, 0); - Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); - return Hdr; - end Read_Header; - - ------------------------- - -- Read_Section_Header -- - ------------------------- - - function Read_Section_Header - (Obj : in out ELF_Object_File; - Shnum : uint32) return Section_Header - is - Shdr : Section_Header; - begin - Seek (Obj.Sectab_Stream, Offset (Shnum * Section_Header'Size / SSU)); - Read_Raw (Obj.Sectab_Stream, Shdr'Address, Section_Header'Size / SSU); - return Shdr; - end Read_Section_Header; - - ----------------- - -- Read_Symbol -- - ----------------- - - function Read_Symbol - (Obj : in out ELF_Object_File; - Off : Offset) return Object_Symbol - is - ST_Entry32 : Symtab_Entry32; - ST_Entry64 : Symtab_Entry64; - Res : Object_Symbol; - - begin - Seek (Obj.Symtab_Stream, Off); - - case uword'Size is - when 32 => - Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address, - uint32 (ST_Entry32'Size / SSU)); - Res := (Off, - Off + ST_Entry32'Size / SSU, - uint64 (ST_Entry32.St_Value), - uint64 (ST_Entry32.St_Size)); - - when 64 => - Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address, - uint32 (ST_Entry64'Size / SSU)); - Res := (Off, - Off + ST_Entry64'Size / SSU, - ST_Entry64.St_Value, - ST_Entry64.St_Size); - - when others => - raise Program_Error; - end case; - - return Res; - end Read_Symbol; - - ---------- - -- Name -- - ---------- - - function Name - (Obj : in out ELF_Object_File; - Sec : Object_Section) return String - is - SHdr : Section_Header; - begin - SHdr := Read_Section_Header (Obj, Sec.Num); - return Offset_To_String (Obj.Secstr_Stream, Offset (SHdr.Sh_Name)); - end Name; - - function Name - (Obj : in out ELF_Object_File; - Sym : Object_Symbol) return String_Ptr_Len - is - ST_Entry32 : Symtab_Entry32; - ST_Entry64 : Symtab_Entry64; - Name_Off : Offset; - - begin - -- Test that this symbol is not null - - if Sym = Null_Symbol then - return (null, 0); - end if; - - -- Read the symbol table entry - - Seek (Obj.Symtab_Stream, Sym.Off); - - case uword'Size is - when 32 => - Read_Raw (Obj.Symtab_Stream, ST_Entry32'Address, - uint32 (ST_Entry32'Size / SSU)); - Name_Off := Offset (ST_Entry32.St_Name); - - when 64 => - Read_Raw (Obj.Symtab_Stream, ST_Entry64'Address, - uint32 (ST_Entry64'Size / SSU)); - Name_Off := Offset (ST_Entry64.St_Name); - - when others => - raise Program_Error; - end case; - - -- Fetch the name from the string table - - Seek (Obj.Symstr_Stream, Name_Off); - return Read (Obj.Symstr_Stream); - end Name; - - end ELF_Ops; - - package ELF32_Ops is new ELF_Ops (uint32); - package ELF64_Ops is new ELF_Ops (uint64); - - ---------------- - -- PECOFF_Ops -- - ---------------- - - package body PECOFF_Ops is - - function Decode_Name - (Obj : in out PECOFF_Object_File; - Raw_Name : String) return String; - -- A section name is an 8 byte field padded on the right with null - -- characters, or a '\' followed by an ASCII decimal string indicating - -- an offset in to the string table. This routine decodes this - - function Get_Section_Virtual_Address - (Obj : in out PECOFF_Object_File; - Index : uint32) return uint64; - -- Fetch the address at which a section is loaded - - function Read_Section_Header - (Obj : in out PECOFF_Object_File; - Index : uint32) return Section_Header; - -- Read a header from section table - - function String_Table - (Obj : in out PECOFF_Object_File; - Index : Offset) return String; - -- Return an entry from the string table - - ----------------- - -- Decode_Name -- - ----------------- - - function Decode_Name - (Obj : in out PECOFF_Object_File; - Raw_Name : String) return String - is - Name_Or_Ref : constant String := Trim_Trailing_Nuls (Raw_Name); - Off : Offset; - - begin - -- We should never find a symbol with a zero length name. If we do it - -- probably means we are not parsing the symbol table correctly. If - -- this happens we raise a fatal error. - - if Name_Or_Ref'Length = 0 then - raise Format_Error with - "found zero length symbol in symbol table"; - end if; - - if Name_Or_Ref (1) /= '/' then - return Name_Or_Ref; - else - Off := Offset'Value (Name_Or_Ref (2 .. Name_Or_Ref'Last)); - return String_Table (Obj, Off); - end if; - end Decode_Name; - - ------------------ - -- First_Symbol -- - ------------------ - - function First_Symbol - (Obj : in out PECOFF_Object_File) return Object_Symbol is - begin - -- Return Null_Symbol in the case that the symbol table is empty - - if Obj.Symtab_Last = 0 then - return Null_Symbol; - end if; - - return Read_Symbol (Obj, 0); - end First_Symbol; - - ----------------- - -- Get_Section -- - ----------------- - - function Get_Section - (Obj : in out PECOFF_Object_File; - Index : uint32) return Object_Section - is - Sec : constant Section_Header := Read_Section_Header (Obj, Index); - begin - -- Use VirtualSize instead of SizeOfRawData. The latter is rounded to - -- the page size, so it may add garbage to the content. On the other - -- side, the former may be larger than the latter in case of 0 - -- padding. - - return (Index, - Offset (Sec.PointerToRawData), - uint64 (Sec.VirtualAddress) + Obj.ImageBase, - uint64 (Sec.VirtualSize), - (Sec.Characteristics and IMAGE_SCN_CNT_CODE) /= 0); - end Get_Section; - - --------------------------------- - -- Get_Section_Virtual_Address -- - --------------------------------- - - function Get_Section_Virtual_Address - (Obj : in out PECOFF_Object_File; - Index : uint32) return uint64 - is - Sec : Section_Header; - - begin - -- Try cache - - if Index = Obj.GSVA_Sec then - return Obj.GSVA_Addr; - end if; - - Obj.GSVA_Sec := Index; - Sec := Read_Section_Header (Obj, Index); - Obj.GSVA_Addr := Obj.ImageBase + uint64 (Sec.VirtualAddress); - return Obj.GSVA_Addr; - end Get_Section_Virtual_Address; - - ---------------- - -- Initialize -- - ---------------- - - function Initialize - (F : Mapped_File; - Hdr : Header; - In_Exception : Boolean) return PECOFF_Object_File - is - Res : PECOFF_Object_File - (Format => (case Hdr.Variant is - when PECOFF_Ops.VARIANT_PE32 => PECOFF, - when PECOFF_Ops.VARIANT_PE32_PLUS => PECOFF_PLUS, - when others => raise Program_Error - with "unrecognized PECOFF variant")); - Symtab_Size : constant Offset := - Offset (Hdr.NumberOfSymbols) * (Symtab_Entry'Size / SSU); - Strtab_Size : uint32; - Hdr_Offset : Offset; - Opt_Offset : File_Size; - Opt_Stream : Mapped_Stream; - begin - Res.MF := F; - Res.In_Exception := In_Exception; - - case Hdr.Machine is - when PECOFF_Ops.IMAGE_FILE_MACHINE_I386 => - Res.Arch := i386; - when PECOFF_Ops.IMAGE_FILE_MACHINE_IA64 => - Res.Arch := IA64; - when PECOFF_Ops.IMAGE_FILE_MACHINE_AMD64 => - Res.Arch := x86_64; - when others => - raise Format_Error with "unrecognized architecture"; - end case; - - Res.Num_Sections := uint32 (Hdr.NumberOfSections); - - -- Map symbol table and the first following word (which is the length - -- of the string table). - - Res.Symtab_Last := Symtab_Size; - Res.Symtab_Stream := Create_Stream - (F, - File_Size (Hdr.PointerToSymbolTable), - File_Size (Symtab_Size + 4)); - - -- Map string table. The first 4 bytes are the length of the string - -- table and are part of it. - - Seek (Res.Symtab_Stream, Symtab_Size); - Strtab_Size := Read (Res.Symtab_Stream); - Res.Symstr_Stream := Create_Stream - (F, - File_Size (Hdr.PointerToSymbolTable) + File_Size (Symtab_Size), - File_Size (Strtab_Size)); - - -- Map section table - - Opt_Stream := Create_Stream (Res.Mf, Signature_Loc_Offset, 4); - Hdr_Offset := Offset (uint32'(Read (Opt_Stream))); - Close (Opt_Stream); - Res.Sectab_Stream := Create_Stream - (F, - File_Size (Hdr_Offset + - Size_Of_Standard_Header_Fields + - Offset (Hdr.SizeOfOptionalHeader)), - File_Size (Res.Num_Sections) - * File_Size (Section_Header'Size / SSU)); - - -- Read optional header and extract image base - - Opt_Offset := File_Size (Hdr_Offset + Size_Of_Standard_Header_Fields); - - if Res.Format = PECOFF then - declare - Opt_32 : Optional_Header_PE32; - begin - Opt_Stream := Create_Stream - (Res.Mf, Opt_Offset, Opt_32'Size / SSU); - Read_Raw - (Opt_Stream, Opt_32'Address, uint32 (Opt_32'Size / SSU)); - Res.ImageBase := uint64 (Opt_32.ImageBase); - Close (Opt_Stream); - end; - - else - declare - Opt_64 : Optional_Header_PE64; - begin - Opt_Stream := Create_Stream - (Res.Mf, Opt_Offset, Opt_64'Size / SSU); - Read_Raw - (Opt_Stream, Opt_64'Address, uint32 (Opt_64'Size / SSU)); - Res.ImageBase := Opt_64.ImageBase; - Close (Opt_Stream); - end; - end if; - - return Res; - end Initialize; - - ----------------- - -- Read_Symbol -- - ----------------- - - function Read_Symbol - (Obj : in out PECOFF_Object_File; - Off : Offset) return Object_Symbol - is - ST_Entry : Symtab_Entry; - ST_Last : Symtab_Entry; - Aux_Entry : Auxent_Section; - Sz : constant Offset := ST_Entry'Size / SSU; - Result : Object_Symbol; - Noff : Offset; - Sym_Off : Offset; - - begin - -- Seek to the successor of Prev - - Noff := Off; - - loop - Sym_Off := Noff; - - Seek (Obj.Symtab_Stream, Sym_Off); - Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, uint32 (Sz)); - - -- Skip AUX entries - - Noff := Noff + Offset (1 + ST_Entry.NumberOfAuxSymbols) * Sz; - - exit when ST_Entry.TypeField = Function_Symbol_Type - and then ST_Entry.SectionNumber > 0; - - if Noff >= Obj.Symtab_Last then - return Null_Symbol; - end if; - end loop; - - -- Construct the symbol - - Result := - (Off => Sym_Off, - Next => Noff, - Value => uint64 (ST_Entry.Value), - Size => 0); - - -- Set the size as accurately as possible - - -- The size of a symbol is not directly available so we try scanning - -- to the next function and assuming the code ends there. - - loop - -- Read symbol and AUX entries - - Sym_Off := Noff; - Seek (Obj.Symtab_Stream, Sym_Off); - Read_Raw (Obj.Symtab_Stream, ST_Last'Address, uint32 (Sz)); - - for I in 1 .. ST_Last.NumberOfAuxSymbols loop - Read_Raw (Obj.Symtab_Stream, Aux_Entry'Address, uint32 (Sz)); - end loop; - - Noff := Noff + Offset (1 + ST_Last.NumberOfAuxSymbols) * Sz; - - if ST_Last.TypeField = Function_Symbol_Type then - if ST_Last.SectionNumber = ST_Entry.SectionNumber - and then ST_Last.Value >= ST_Entry.Value - then - -- Symbol is a function past ST_Entry - - Result.Size := uint64 (ST_Last.Value - ST_Entry.Value); - - else - -- Not correlated function - - Result.Next := Sym_Off; - end if; - - exit; - - elsif ST_Last.SectionNumber = ST_Entry.SectionNumber - and then ST_Last.TypeField = Not_Function_Symbol_Type - and then ST_Last.StorageClass = 3 - and then ST_Last.NumberOfAuxSymbols = 1 - then - -- Symbol is a section - - Result.Size := uint64 (ST_Last.Value + Aux_Entry.Length - - ST_Entry.Value); - Result.Next := Noff; - exit; - end if; - - exit when Noff >= Obj.Symtab_Last; - end loop; - - -- Relocate the address - - Result.Value := - Result.Value + Get_Section_Virtual_Address - (Obj, uint32 (ST_Entry.SectionNumber - 1)); - - return Result; - end Read_Symbol; - - ------------------ - -- Read_Header -- - ------------------ - - function Read_Header (F : in out Mapped_Stream) return Header is - Hdr : Header; - Off : int32; - - begin - -- Skip the MSDOS stub, and seek directly to the file offset - - Seek (F, Signature_Loc_Offset); - Off := Read (F); - - -- Read the COFF file header - - Seek (F, Offset (Off)); - Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); - return Hdr; - end Read_Header; - - ------------------------- - -- Read_Section_Header -- - ------------------------- - - function Read_Section_Header - (Obj : in out PECOFF_Object_File; - Index : uint32) return Section_Header - is - Sec : Section_Header; - begin - Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU)); - Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU); - return Sec; - end Read_Section_Header; - - ---------- - -- Name -- - ---------- - - function Name - (Obj : in out PECOFF_Object_File; - Sec : Object_Section) return String - is - Shdr : constant Section_Header := Read_Section_Header (Obj, Sec.Num); - begin - return Decode_Name (Obj, Shdr.Name); - end Name; - - ------------------- - -- String_Table -- - ------------------- - - function String_Table - (Obj : in out PECOFF_Object_File; - Index : Offset) return String is - begin - -- An index of zero is used to represent an empty string, as the - -- first word of the string table is specified to contain the length - -- of the table rather than its contents. - - if Index = 0 then - return ""; - - else - return Offset_To_String (Obj.Symstr_Stream, Index); - end if; - end String_Table; - - ---------- - -- Name -- - ---------- - - function Name - (Obj : in out PECOFF_Object_File; - Sym : Object_Symbol) return String_Ptr_Len - is - ST_Entry : Symtab_Entry; - - begin - Seek (Obj.Symtab_Stream, Sym.Off); - Read_Raw (Obj.Symtab_Stream, ST_Entry'Address, ST_Entry'Size / SSU); - - declare - -- Symbol table entries are packed and Table_Entry.Name may not be - -- sufficiently aligned to interpret as a 32 bit word, so it is - -- copied to a temporary - - Aligned_Name : Name_Str := ST_Entry.Name; - for Aligned_Name'Alignment use 4; - - First_Word : uint32; - pragma Import (Ada, First_Word); - -- Suppress initialization in Normalized_Scalars mode - for First_Word'Address use Aligned_Name (1)'Address; - - Second_Word : uint32; - pragma Import (Ada, Second_Word); - -- Suppress initialization in Normalized_Scalars mode - for Second_Word'Address use Aligned_Name (5)'Address; - - begin - if First_Word = 0 then - -- Second word is an offset in the symbol table - if Second_Word = 0 then - return (null, 0); - else - Seek (Obj.Symstr_Stream, int64 (Second_Word)); - return Read (Obj.Symstr_Stream); - end if; - else - -- Inlined symbol name - Seek (Obj.Symtab_Stream, Sym.Off); - return To_String_Ptr_Len (Read (Obj.Symtab_Stream), 8); - end if; - end; - end Name; - - end PECOFF_Ops; - - ----------------- - -- XCOFF32_Ops -- - ----------------- - - package body XCOFF32_Ops is - - function Read_Section_Header - (Obj : in out XCOFF32_Object_File; - Index : uint32) return Section_Header; - -- Read a header from section table - - ----------------- - -- Read_Symbol -- - ----------------- - - function Read_Symbol - (Obj : in out XCOFF32_Object_File; - Off : Offset) return Object_Symbol - is - Sym : Symbol_Entry; - Sz : constant Offset := Symbol_Entry'Size / SSU; - Aux : Aux_Entry; - Result : Object_Symbol; - Noff : Offset; - Sym_Off : Offset; - - procedure Read_LD_Symbol; - -- Read the next LD symbol - - -------------------- - -- Read_LD_Symbol -- - -------------------- - - procedure Read_LD_Symbol is - begin - loop - Sym_Off := Noff; - - Read_Raw (Obj.Symtab_Stream, Sym'Address, uint32 (Sz)); - - Noff := Noff + Offset (1 + Sym.n_numaux) * Sz; - - for J in 1 .. Sym.n_numaux loop - Read_Raw (Obj.Symtab_Stream, Aux'Address, uint32 (Sz)); - end loop; - - exit when Noff >= Obj.Symtab_Last; - - exit when Sym.n_numaux = 1 - and then Sym.n_scnum /= 0 - and then (Sym.n_sclass = C_EXT - or else Sym.n_sclass = C_HIDEXT - or else Sym.n_sclass = C_WEAKEXT) - and then Aux.x_smtyp = XTY_LD; - end loop; - end Read_LD_Symbol; - - -- Start of processing for Read_Symbol - - begin - Seek (Obj.Symtab_Stream, Off); - Noff := Off; - Read_LD_Symbol; - - if Noff >= Obj.Symtab_Last then - return Null_Symbol; - end if; - - -- Construct the symbol - - Result := (Off => Sym_Off, - Next => Noff, - Value => uint64 (Sym.n_value), - Size => 0); - - -- Look for the next symbol to compute the size - - Read_LD_Symbol; - - if Noff >= Obj.Symtab_Last then - return Null_Symbol; - end if; - - Result.Size := uint64 (Sym.n_value) - Result.Value; - Result.Next := Sym_Off; - return Result; - end Read_Symbol; - - ------------------ - -- First_Symbol -- - ------------------ - - function First_Symbol - (Obj : in out XCOFF32_Object_File) return Object_Symbol - is - begin - -- Return Null_Symbol in the case that the symbol table is empty - - if Obj.Symtab_Last = 0 then - return Null_Symbol; - end if; - - return Read_Symbol (Obj, 0); - end First_Symbol; - - ---------------- - -- Initialize -- - ---------------- - - function Initialize - (F : Mapped_File; - Hdr : Header; - In_Exception : Boolean) return XCOFF32_Object_File - is - Res : XCOFF32_Object_File (Format => XCOFF32); - Strtab_Sz : uint32; - begin - Res.Mf := F; - Res.In_Exception := In_Exception; - - Res.Arch := PPC; - - -- Map sections table - Res.Num_Sections := uint32 (Hdr.f_nscns); - Res.Sectab_Stream := Create_Stream - (F, - File_Size (Header'Size / SSU) + File_Size (Hdr.f_opthdr), - File_Size (Hdr.f_nscns) * (Section_Header'Size / SSU)); - - -- Map symbols table - Res.Symtab_Last := Offset (Hdr.f_nscns) * (Symbol_Entry'Size / SSU); - Res.Symtab_Stream := Create_Stream - (F, - File_Size (Hdr.f_symptr), - File_Size (Res.Symtab_Last) + 4); - - -- Map string table - Seek (Res.Symtab_Stream, Res.Symtab_Last); - Strtab_Sz := Read (Res.Symtab_Stream); - Res.Symstr_Stream := Create_Stream - (F, - File_Size (Res.Symtab_Last) + 4, - File_Size (Strtab_Sz) - 4); - - return Res; - end Initialize; - - ----------------- - -- Get_Section -- - ----------------- - - function Get_Section - (Obj : in out XCOFF32_Object_File; - Index : uint32) return Object_Section - is - Sec : constant Section_Header := Read_Section_Header (Obj, Index); - begin - return (Index, Offset (Sec.s_scnptr), - uint64 (Sec.s_vaddr), - uint64 (Sec.s_size), - (Sec.s_flags and STYP_TEXT) /= 0); - end Get_Section; - - ----------------- - -- Read_Header -- - ----------------- - - function Read_Header (F : in out Mapped_Stream) return Header is - Hdr : Header; - begin - Seek (F, 0); - Read_Raw (F, Hdr'Address, uint32 (Hdr'Size / SSU)); - return Hdr; - end Read_Header; - - ------------------------- - -- Read_Section_Header -- - ------------------------- - - function Read_Section_Header - (Obj : in out XCOFF32_Object_File; - Index : uint32) return Section_Header - is - Sec : Section_Header; - - begin - -- Seek to the end of the object header - - Seek (Obj.Sectab_Stream, Offset (Index * Section_Header'Size / SSU)); - - -- Read the section - - Read_Raw (Obj.Sectab_Stream, Sec'Address, Section_Header'Size / SSU); - - return Sec; - end Read_Section_Header; - - ---------- - -- Name -- - ---------- - - function Name - (Obj : in out XCOFF32_Object_File; - Sec : Object_Section) return String - is - Hdr : Section_Header; - begin - Hdr := Read_Section_Header (Obj, Sec.Num); - return Trim_Trailing_Nuls (Hdr.s_name); - end Name; - - ---------- - -- Name -- - ---------- - - function Name - (Obj : in out XCOFF32_Object_File; - Sym : Object_Symbol) return String_Ptr_Len - is - Symbol : Symbol_Entry; - - begin - Seek (Obj.Symtab_Stream, Sym.Off); - Read_Raw (Obj.Symtab_Stream, Symbol'Address, Symbol'Size / SSU); - - declare - First_Word : uint32; - pragma Import (Ada, First_Word); - -- Suppress initialization in Normalized_Scalars mode - for First_Word'Address use Symbol.n_name (1)'Address; - - Second_Word : uint32; - pragma Import (Ada, Second_Word); - -- Suppress initialization in Normalized_Scalars mode - for Second_Word'Address use Symbol.n_name (5)'Address; - - begin - if First_Word = 0 then - if Second_Word = 0 then - return (null, 0); - else - Seek (Obj.Symstr_Stream, int64 (Second_Word)); - return Read (Obj.Symstr_Stream); - end if; - else - Seek (Obj.Symtab_Stream, Sym.Off); - return To_String_Ptr_Len (Read (Obj.Symstr_Stream), 8); - end if; - end; - end Name; - end XCOFF32_Ops; - - ---------- - -- Arch -- - ---------- - - function Arch (Obj : Object_File) return Object_Arch is - begin - return Obj.Arch; - end Arch; - - function Create_Stream - (Mf : Mapped_File; - File_Offset : File_Size; - File_Length : File_Size) - return Mapped_Stream - is - Region : Mapped_Region; - begin - Read (Mf, Region, File_Offset, File_Length, False); - return (Region, 0, Offset (File_Length)); - end Create_Stream; - - function Create_Stream - (Obj : Object_File; - Sec : Object_Section) return Mapped_Stream is - begin - return Create_Stream (Obj.Mf, File_Size (Sec.Off), File_Size (Sec.Size)); - end Create_Stream; - - procedure Tell (Obj : in out Mapped_Stream; Off : out Offset) is - begin - Off := Obj.Off; - end Tell; - - function Tell (Obj : Mapped_Stream) return Offset is - begin - return Obj.Off; - end Tell; - - function Length (Obj : Mapped_Stream) return Offset is - begin - return Obj.Len; - end Length; - - ----------- - -- Close -- - ----------- - - procedure Close (S : in out Mapped_Stream) is - begin - Free (S.Region); - end Close; - - procedure Close (Obj : in out Object_File) is - begin - Close (Obj.Symtab_Stream); - Close (Obj.Symstr_Stream); - Close (Obj.Sectab_Stream); - - case Obj.Format is - when ELF => - Close (Obj.Secstr_Stream); - when Any_PECOFF => - null; - when XCOFF32 => - null; - end case; - - Close (Obj.Mf); - end Close; - - ------------------------ - -- Strip_Leading_Char -- - ------------------------ - - function Strip_Leading_Char - (Obj : in out Object_File; - Sym : String_Ptr_Len) return Positive is - begin - if (Obj.Format = PECOFF and then Sym.Ptr (1) = '_') - or else - (Obj.Format = XCOFF32 and then Sym.Ptr (1) = '.') - then - return 2; - else - return 1; - end if; - end Strip_Leading_Char; - - ---------------------- - -- Decoded_Ada_Name -- - ---------------------- - - function Decoded_Ada_Name - (Obj : in out Object_File; - Sym : String_Ptr_Len) return String - is - procedure gnat_decode - (Coded_Name_Addr : Address; - Ada_Name_Addr : Address; - Verbose : int); - pragma Import (C, gnat_decode, "__gnat_decode"); - - subtype size_t is Interfaces.C.size_t; - - Sym_Name : constant String := - String (Sym.Ptr (1 .. Sym.Len)) & ASCII.NUL; - Decoded : char_array (0 .. size_t (Sym.Len) * 2 + 60); - Off : Natural; - begin - -- In the PECOFF case most but not all symbol table entries have an - -- extra leading underscore. In this case we trim it. - - Off := Strip_Leading_Char (Obj, Sym); - - gnat_decode (Sym_Name (Off)'Address, Decoded'Address, 0); - - return To_Ada (Decoded); - end Decoded_Ada_Name; - - ------------------ - -- First_Symbol -- - ------------------ - - function First_Symbol (Obj : in out Object_File) return Object_Symbol is - begin - case Obj.Format is - when ELF32 => return ELF32_Ops.First_Symbol (Obj); - when ELF64 => return ELF64_Ops.First_Symbol (Obj); - when Any_PECOFF => return PECOFF_Ops.First_Symbol (Obj); - when XCOFF32 => return XCOFF32_Ops.First_Symbol (Obj); - end case; - end First_Symbol; - - ------------ - -- Format -- - ------------ - - function Format (Obj : Object_File) return Object_Format is - begin - return Obj.Format; - end Format; - - ---------------------- - -- Get_Load_Address -- - ---------------------- - - function Get_Load_Address (Obj : Object_File) return uint64 is - begin - raise Format_Error with "Get_Load_Address not implemented"; - return 0; - end Get_Load_Address; - - ----------------- - -- Get_Section -- - ----------------- - - function Get_Section - (Obj : in out Object_File; - Shnum : uint32) return Object_Section is - begin - case Obj.Format is - when ELF32 => return ELF32_Ops.Get_Section (Obj, Shnum); - when ELF64 => return ELF64_Ops.Get_Section (Obj, Shnum); - when Any_PECOFF => return PECOFF_Ops.Get_Section (Obj, Shnum); - when XCOFF32 => return XCOFF32_Ops.Get_Section (Obj, Shnum); - end case; - end Get_Section; - - function Get_Section - (Obj : in out Object_File; - Sec_Name : String) return Object_Section - is - Sec : Object_Section; - - begin - for J in 0 .. Obj.Num_Sections - 1 loop - Sec := Get_Section (Obj, J); - - if Name (Obj, Sec) = Sec_Name then - return Sec; - end if; - end loop; - - if Obj.In_Exception then - return Null_Section; - else - raise Format_Error with "could not find section in object file"; - end if; - end Get_Section; - - ----------------------- - -- Get_Memory_Bounds -- - ----------------------- - - procedure Get_Memory_Bounds - (Obj : in out Object_File; - Low, High : out uint64) is - Sec : Object_Section; - begin - -- First set as an empty range - Low := uint64'Last; - High := uint64'First; - - for Idx in 1 .. Num_Sections (Obj) loop - Sec := Get_Section (Obj, Idx - 1); - if Sec.Flag_Alloc then - if Sec.Addr < Low then - Low := Sec.Addr; - end if; - if Sec.Addr + Sec.Size > High then - High := Sec.Addr + Sec.Size; - end if; - end if; - end loop; - end Get_Memory_Bounds; - - ---------- - -- Name -- - ---------- - - function Name - (Obj : in out Object_File; - Sec : Object_Section) return String is - begin - case Obj.Format is - when ELF32 => return ELF32_Ops.Name (Obj, Sec); - when ELF64 => return ELF64_Ops.Name (Obj, Sec); - when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sec); - when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sec); - end case; - end Name; - - function Name - (Obj : in out Object_File; - Sym : Object_Symbol) return String_Ptr_Len is - begin - case Obj.Format is - when ELF32 => return ELF32_Ops.Name (Obj, Sym); - when ELF64 => return ELF64_Ops.Name (Obj, Sym); - when Any_PECOFF => return PECOFF_Ops.Name (Obj, Sym); - when XCOFF32 => return XCOFF32_Ops.Name (Obj, Sym); - end case; - end Name; - - ----------------- - -- Next_Symbol -- - ----------------- - - function Next_Symbol - (Obj : in out Object_File; - Prev : Object_Symbol) return Object_Symbol is - begin - -- Test whether we've reached the end of the symbol table - - if Prev.Next >= Obj.Symtab_Last then - return Null_Symbol; - end if; - - return Read_Symbol (Obj, Prev.Next); - end Next_Symbol; - - --------- - -- Num -- - --------- - - function Num (Sec : Object_Section) return uint32 is - begin - return Sec.Num; - end Num; - - ------------------ - -- Num_Sections -- - ------------------ - - function Num_Sections (Obj : Object_File) return uint32 is - begin - return Obj.Num_Sections; - end Num_Sections; - - --------- - -- Off -- - --------- - - function Off (Sec : Object_Section) return Offset is - begin - return Sec.Off; - end Off; - - function Off (Sym : Object_Symbol) return Offset is - begin - return Sym.Off; - end Off; - - ---------------------- - -- Offset_To_String -- - ---------------------- - - function Offset_To_String - (S : in out Mapped_Stream; - Off : Offset) return String - is - Buf : Buffer; - begin - Seek (S, Off); - Read_C_String (S, Buf); - return To_String (Buf); - end Offset_To_String; - - ---------- - -- Open -- - ---------- - - function Open - (File_Name : String; - In_Exception : Boolean := False) return Object_File_Access - is - F : Mapped_File; - Hdr_Stream : Mapped_Stream; - - begin - -- Open the file - - F := Open_Read_No_Exception (File_Name); - - if F = Invalid_Mapped_File then - if In_Exception then - return null; - else - raise IO_Error with "could not open object file"; - end if; - end if; - - Hdr_Stream := Create_Stream (F, 0, 4096); - - declare - Hdr : constant ELF32_Ops.Header := ELF32_Ops.Read_Header (Hdr_Stream); - - begin - -- Look for the magic numbers for the ELF case - - if Hdr.E_Ident (0) = 16#7F# and then - Hdr.E_Ident (1) = Character'Pos ('E') and then - Hdr.E_Ident (2) = Character'Pos ('L') and then - Hdr.E_Ident (3) = Character'Pos ('F') and then - Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS32 - then - Close (Hdr_Stream); - return new Object_File' - (ELF32_Ops.Initialize (F, Hdr, In_Exception)); - end if; - end; - - declare - Hdr : constant ELF64_Ops.Header := - ELF64_Ops.Read_Header (Hdr_Stream); - - begin - -- Look for the magic numbers for the ELF case - - if Hdr.E_Ident (0) = 16#7F# and then - Hdr.E_Ident (1) = Character'Pos ('E') and then - Hdr.E_Ident (2) = Character'Pos ('L') and then - Hdr.E_Ident (3) = Character'Pos ('F') and then - Hdr.E_Ident (4) = ELF32_Ops.ELFCLASS64 - then - Close (Hdr_Stream); - return new Object_File' - (ELF64_Ops.Initialize (F, Hdr, In_Exception)); - end if; - end; - - declare - Hdr : constant PECOFF_Ops.Header := - PECOFF_Ops.Read_Header (Hdr_Stream); - - begin - -- Test the magic numbers - - if Hdr.Magics (0) = Character'Pos ('P') and then - Hdr.Magics (1) = Character'Pos ('E') and then - Hdr.Magics (2) = 0 and then - Hdr.Magics (3) = 0 - then - Close (Hdr_Stream); - return new Object_File' - (PECOFF_Ops.Initialize (F, Hdr, In_Exception)); - end if; - - exception - -- If this is not a PECOFF file then we've done a seek and read to a - -- random address, possibly raising IO_Error - - when IO_Error => - null; - end; - - declare - Hdr : constant XCOFF32_Ops.Header := - XCOFF32_Ops.Read_Header (Hdr_Stream); - - begin - -- Test the magic numbers - - if Hdr.f_magic = 8#0737# then - Close (Hdr_Stream); - return new Object_File' - (XCOFF32_Ops.Initialize (F, Hdr, In_Exception)); - end if; - end; - - Close (Hdr_Stream); - - if In_Exception then - return null; - else - raise Format_Error with "unrecognized object format"; - end if; - end Open; - - ---------- - -- Read -- - ---------- - - function Read (S : in out Mapped_Stream) return Mmap.Str_Access - is - function To_Str_Access is - new Ada.Unchecked_Conversion (Address, Str_Access); - begin - return To_Str_Access (Data (S.Region) (Natural (S.Off + 1))'Address); - end Read; - - function Read (S : in out Mapped_Stream) return String_Ptr_Len is - begin - return To_String_Ptr_Len (Read (S)); - end Read; - - procedure Check_Read_Offset (S : in out Mapped_Stream; Size : uint32) is - begin - if S.Off + Offset (Size) > Offset (Last (S.Region)) then - raise IO_Error with "could not read from object file"; - end if; - end Check_Read_Offset; - - procedure Read_Raw - (S : in out Mapped_Stream; - Addr : Address; - Size : uint32) - is - function To_Str_Access is - new Ada.Unchecked_Conversion (Address, Str_Access); - - Sz : constant Offset := Offset (Size); - begin - -- Check size - - pragma Debug (Check_Read_Offset (S, Size)); - - -- Copy data - - To_Str_Access (Addr) (1 .. Positive (Sz)) := - Data (S.Region) (Positive (S.Off + 1) .. Positive (S.Off + Sz)); - - -- Update offset - - S.Off := S.Off + Sz; - end Read_Raw; - - function Read (S : in out Mapped_Stream) return uint8 is - Data : uint8; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - function Read (S : in out Mapped_Stream) return uint16 is - Data : uint16; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - function Read (S : in out Mapped_Stream) return uint32 is - Data : uint32; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - function Read (S : in out Mapped_Stream) return uint64 is - Data : uint64; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - function Read (S : in out Mapped_Stream) return int8 is - Data : int8; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - function Read (S : in out Mapped_Stream) return int16 is - Data : int16; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - function Read (S : in out Mapped_Stream) return int32 is - Data : int32; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - function Read (S : in out Mapped_Stream) return int64 is - Data : int64; - begin - Read_Raw (S, Data'Address, Data'Size / SSU); - return Data; - end Read; - - ------------------ - -- Read_Address -- - ------------------ - - function Read_Address - (Obj : Object_File; S : in out Mapped_Stream) return uint64 is - Address_32 : uint32; - Address_64 : uint64; - - begin - case Obj.Arch is - when i386 - | MIPS - | PPC - | SPARC - => - Address_32 := Read (S); - return uint64 (Address_32); - - when IA64 - | PPC64 - | SPARC64 - | x86_64 - => - Address_64 := Read (S); - return Address_64; - - when Unknown => - raise Format_Error with "unrecognized machine architecture"; - end case; - end Read_Address; - - ------------------- - -- Read_C_String -- - ------------------- - - procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer) is - J : Integer := 0; - - begin - loop - -- Handle overflow case - - if J = B'Last then - B (J) := 0; - exit; - end if; - - B (J) := Read (S); - exit when B (J) = 0; - J := J + 1; - end loop; - end Read_C_String; - - ------------------- - -- Read_C_String -- - ------------------- - - function Read_C_String (S : in out Mapped_Stream) return Str_Access is - Res : constant Str_Access := Read (S); - - begin - for J in Res'Range loop - if S.Off + Offset (J - 1) > Offset (Last (S.Region)) then - raise IO_Error with "could not read from object file"; - end if; - - if Res (J) = ASCII.NUL then - S.Off := S.Off + Offset (J); - return Res; - end if; - end loop; - - -- Overflow case - raise Constraint_Error; - end Read_C_String; - - ----------------- - -- Read_LEB128 -- - ----------------- - - function Read_LEB128 (S : in out Mapped_Stream) return uint32 is - B : uint8; - Shift : Integer := 0; - Res : uint32 := 0; - - begin - loop - B := Read (S); - Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift); - exit when (B and 16#80#) = 0; - Shift := Shift + 7; - end loop; - - return Res; - end Read_LEB128; - - function Read_LEB128 (S : in out Mapped_Stream) return int32 is - B : uint8; - Shift : Integer := 0; - Res : uint32 := 0; - - begin - loop - B := Read (S); - Res := Res or Shift_Left (uint32 (B and 16#7f#), Shift); - Shift := Shift + 7; - exit when (B and 16#80#) = 0; - end loop; - - if Shift < 32 and then (Res and Shift_Left (1, Shift - 1)) /= 0 then - Res := Res or Shift_Left (-1, Shift); - end if; - - return To_int32 (Res); - end Read_LEB128; - - ----------------- - -- Read_Symbol -- - ----------------- - - function Read_Symbol - (Obj : in out Object_File; - Off : Offset) return Object_Symbol is - begin - case Obj.Format is - when ELF32 => return ELF32_Ops.Read_Symbol (Obj, Off); - when ELF64 => return ELF64_Ops.Read_Symbol (Obj, Off); - when Any_PECOFF => return PECOFF_Ops.Read_Symbol (Obj, Off); - when XCOFF32 => return XCOFF32_Ops.Read_Symbol (Obj, Off); - end case; - end Read_Symbol; - - ---------- - -- Seek -- - ---------- - - procedure Seek (S : in out Mapped_Stream; Off : Offset) is - begin - if Off < 0 or else Off > Offset (Last (S.Region)) then - raise IO_Error with "could not seek to offset in object file"; - end if; - - S.Off := Off; - end Seek; - - ---------- - -- Size -- - ---------- - - function Size (Sec : Object_Section) return uint64 is - begin - return Sec.Size; - end Size; - - function Size (Sym : Object_Symbol) return uint64 is - begin - return Sym.Size; - end Size; - - ------------ - -- Strlen -- - ------------ - - function Strlen (Buf : Buffer) return int32 is - begin - return int32 (CRTL.strlen (Buf'Address)); - end Strlen; - - ----------- - -- Spans -- - ----------- - - function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean is - begin - return Addr >= Sym.Value and then Addr < Sym.Value + Sym.Size; - end Spans; - - --------------- - -- To_String -- - --------------- - - function To_String (Buf : Buffer) return String is - Result : String (1 .. Integer (CRTL.strlen (Buf'Address))); - for Result'Address use Buf'Address; - pragma Import (Ada, Result); - - begin - return Result; - end To_String; - - ----------------------- - -- To_String_Ptr_Len -- - ----------------------- - - function To_String_Ptr_Len - (Ptr : Mmap.Str_Access; - Max_Len : Natural := Natural'Last) return String_Ptr_Len is - begin - for I in 1 .. Max_Len loop - if Ptr (I) = ASCII.NUL then - return (Ptr, I - 1); - end if; - end loop; - return (Ptr, Max_Len); - end To_String_Ptr_Len; - - ------------------------ - -- Trim_Trailing_Nuls -- - ------------------------ - - function Trim_Trailing_Nuls (Str : String) return String is - begin - for J in Str'Range loop - if Str (J) = ASCII.NUL then - return Str (Str'First .. J - 1); - end if; - end loop; - - return Str; - end Trim_Trailing_Nuls; - - ----------- - -- Value -- - ----------- - - function Value (Sym : Object_Symbol) return uint64 is - begin - return Sym.Value; - end Value; - -end System.Object_Reader; diff --git a/gcc/ada/s-objrea.ads b/gcc/ada/s-objrea.ads deleted file mode 100644 index 1d48536..0000000 --- a/gcc/ada/s-objrea.ads +++ /dev/null @@ -1,451 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . O B J E C T _ R E A D E R -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements a simple, minimal overhead reader for object files --- composed of sections of untyped heterogeneous binary data. - -with Interfaces; -with System.Mmap; - -package System.Object_Reader is - - -------------- - -- Limits -- - -------------- - - BUFFER_SIZE : constant := 8 * 1024; - - ------------------ - -- Object files -- - ------------------ - - type Object_File (<>) is private; - - type Object_File_Access is access Object_File; - - --------------------- - -- Object sections -- - ---------------------- - - type Object_Section is private; - - Null_Section : constant Object_Section; - - -------------------- - -- Object symbols -- - -------------------- - - type Object_Symbol is private; - - ------------------------ - -- Object format type -- - ------------------------ - - type Object_Format is - (ELF32, - -- Object format is 32-bit ELF - - ELF64, - -- Object format is 64-bit ELF - - PECOFF, - -- Object format is Microsoft PECOFF - - PECOFF_PLUS, - -- Object format is Microsoft PECOFF+ - - XCOFF32); - -- Object format is AIX 32-bit XCOFF - - -- PECOFF | PECOFF_PLUS appears so often as a case choice, would - -- seem a good idea to have a subtype name covering these two choices ??? - - ------------------------------ - -- Object architecture type -- - ------------------------------ - - type Object_Arch is - (Unknown, - -- The target architecture has not yet been determined - - SPARC, - -- 32-bit SPARC - - SPARC64, - -- 64-bit SPARC - - i386, - -- Intel IA32 - - MIPS, - -- MIPS Technologies MIPS - - x86_64, - -- x86-64 (64-bit AMD/Intel) - - IA64, - -- Intel IA64 - - PPC, - -- 32-bit PowerPC - - PPC64); - -- 64-bit PowerPC - - ------------------ - -- Target types -- - ------------------ - - subtype Offset is Interfaces.Integer_64; - - subtype uint8 is Interfaces.Unsigned_8; - subtype uint16 is Interfaces.Unsigned_16; - subtype uint32 is Interfaces.Unsigned_32; - subtype uint64 is Interfaces.Unsigned_64; - - subtype int8 is Interfaces.Integer_8; - subtype int16 is Interfaces.Integer_16; - subtype int32 is Interfaces.Integer_32; - subtype int64 is Interfaces.Integer_64; - - type Buffer is array (0 .. BUFFER_SIZE - 1) of uint8; - - type String_Ptr_Len is record - Ptr : Mmap.Str_Access; - Len : Natural; - end record; - -- A string made from a pointer and a length. Not all strings for name - -- are C strings: COFF inlined symbol names have a max length of 8. - - ------------------------------------------- - -- Operations on buffers of untyped data -- - ------------------------------------------- - - function To_String (Buf : Buffer) return String; - -- Construct string from C style null-terminated string stored in a buffer - - function To_String_Ptr_Len - (Ptr : Mmap.Str_Access; - Max_Len : Natural := Natural'Last) return String_Ptr_Len; - -- Convert PTR to a String_Ptr_Len. - - function Strlen (Buf : Buffer) return int32; - -- Return the length of a C style null-terminated string - - ------------------------- - -- Opening and closing -- - ------------------------- - - function Open - (File_Name : String; - In_Exception : Boolean := False) return Object_File_Access; - -- Open the object file and initialize the reader. In_Exception is true - -- when the parsing is done as part of an exception handler decorator. In - -- this mode we do not want to raise an exception. - - procedure Close (Obj : in out Object_File); - -- Close the object file - - ----------------------- - -- Sequential access -- - ----------------------- - - type Mapped_Stream is private; - -- Provide an abstraction of a stream on a memory mapped file - - function Create_Stream (Mf : System.Mmap.Mapped_File; - File_Offset : System.Mmap.File_Size; - File_Length : System.Mmap.File_Size) - return Mapped_Stream; - -- Create a stream from Mf - - procedure Close (S : in out Mapped_Stream); - -- Close the stream (deallocate memory) - - procedure Read_Raw - (S : in out Mapped_Stream; - Addr : Address; - Size : uint32); - pragma Inline (Read_Raw); - -- Read a number of fixed sized records - - procedure Seek (S : in out Mapped_Stream; Off : Offset); - -- Seek to an absolute offset in bytes - - procedure Tell (Obj : in out Mapped_Stream; Off : out Offset) - with Inline; - function Tell (Obj : Mapped_Stream) return Offset - with Inline; - -- Fetch the current offset - - function Length (Obj : Mapped_Stream) return Offset - with Inline; - -- Length of the stream - - function Read (S : in out Mapped_Stream) return Mmap.Str_Access; - -- Provide a pointer in memory at the current offset - - function Read (S : in out Mapped_Stream) return String_Ptr_Len; - -- Provide a pointer in memory at the current offset - - function Read (S : in out Mapped_Stream) return uint8; - function Read (S : in out Mapped_Stream) return uint16; - function Read (S : in out Mapped_Stream) return uint32; - function Read (S : in out Mapped_Stream) return uint64; - function Read (S : in out Mapped_Stream) return int8; - function Read (S : in out Mapped_Stream) return int16; - function Read (S : in out Mapped_Stream) return int32; - function Read (S : in out Mapped_Stream) return int64; - -- Read a scalar - - function Read_Address - (Obj : Object_File; S : in out Mapped_Stream) return uint64; - -- Read either a 64 or 32 bit address from the file stream depending on the - -- address size of the target architecture and promote it to a 64 bit type. - - function Read_LEB128 (S : in out Mapped_Stream) return uint32; - function Read_LEB128 (S : in out Mapped_Stream) return int32; - -- Read a value encoding in Little-Endian Base 128 format - - procedure Read_C_String (S : in out Mapped_Stream; B : out Buffer); - function Read_C_String (S : in out Mapped_Stream) return Mmap.Str_Access; - -- Read a C style NULL terminated string - - function Offset_To_String - (S : in out Mapped_Stream; - Off : Offset) return String; - -- Construct a string from a C style NULL terminated string located at an - -- offset into the object file. - - ------------------------ - -- Object information -- - ------------------------ - - function Arch (Obj : Object_File) return Object_Arch; - -- Return the object architecture - - function Format (Obj : Object_File) return Object_Format; - -- Return the object file format - - function Get_Load_Address (Obj : Object_File) return uint64; - -- Return the load address defined in Obj. May raise Format_Error if not - -- implemented - - function Num_Sections (Obj : Object_File) return uint32; - -- Return the number of sections composing the object file - - function Get_Section - (Obj : in out Object_File; - Shnum : uint32) return Object_Section; - -- Return the Nth section (numbered from zero) - - function Get_Section - (Obj : in out Object_File; - Sec_Name : String) return Object_Section; - -- Return a section by name - - function Create_Stream - (Obj : Object_File; - Sec : Object_Section) return Mapped_Stream; - -- Create a stream for section Sec - - procedure Get_Memory_Bounds - (Obj : in out Object_File; - Low, High : out uint64); - -- Return the low and high addresses of the code for the object file. Can - -- be used to check if an address in within this object file. This - -- procedure is not efficient and the result should be saved to avoid - -- recomputation. - - ------------------------- - -- Section information -- - ------------------------- - - function Name - (Obj : in out Object_File; - Sec : Object_Section) return String; - -- Return the name of a section as a string - - function Size (Sec : Object_Section) return uint64; - -- Return the size of a section in bytes - - function Num (Sec : Object_Section) return uint32; - -- Return the index of a section from zero - - function Off (Sec : Object_Section) return Offset; - -- Return the byte offset of the section within the object - - ------------------------------ - -- Symbol table information -- - ------------------------------ - - Null_Symbol : constant Object_Symbol; - -- An empty symbol table entry. - - function First_Symbol (Obj : in out Object_File) return Object_Symbol; - -- Return the first element in the symbol table or Null_Symbol if the - -- symbol table is empty. - - function Next_Symbol - (Obj : in out Object_File; - Prev : Object_Symbol) return Object_Symbol; - -- Return the element following Prev in the symbol table, or Null_Symbol if - -- Prev is the last symbol in the table. - - function Read_Symbol - (Obj : in out Object_File; - Off : Offset) return Object_Symbol; - -- Read symbol at Off - - function Name - (Obj : in out Object_File; - Sym : Object_Symbol) return String_Ptr_Len; - -- Return the name of the symbol - - function Decoded_Ada_Name - (Obj : in out Object_File; - Sym : String_Ptr_Len) return String; - -- Return the decoded name of a symbol encoded as per exp_dbug.ads - - function Strip_Leading_Char - (Obj : in out Object_File; - Sym : String_Ptr_Len) return Positive; - -- Return the index of the first character to decode the name. This can - -- strip one character for ABI with a prefix (like x86 for PECOFF). - - function Value (Sym : Object_Symbol) return uint64; - -- Return the name of the symbol - - function Size (Sym : Object_Symbol) return uint64; - -- Return the size of the symbol in bytes - - function Spans (Sym : Object_Symbol; Addr : uint64) return Boolean; - -- Determine whether a particular address corresponds to the range - -- referenced by this symbol. - - function Off (Sym : Object_Symbol) return Offset; - -- Return the offset of the symbol. - - ---------------- - -- Exceptions -- - ---------------- - - IO_Error : exception; - -- Input/Output error reading file - - Format_Error : exception; - -- Encountered a problem parsing the object - -private - type Mapped_Stream is record - Region : System.Mmap.Mapped_Region; - Off : Offset; - Len : Offset; - end record; - - subtype ELF is Object_Format range ELF32 .. ELF64; - subtype Any_PECOFF is Object_Format range PECOFF .. PECOFF_PLUS; - - type Object_File (Format : Object_Format) is record - Mf : System.Mmap.Mapped_File := - System.Mmap.Invalid_Mapped_File; - Arch : Object_Arch := Unknown; - - Num_Sections : uint32 := 0; - -- Number of sections - - Symtab_Last : Offset; -- Last offset of symbol table - - In_Exception : Boolean := False; - -- True if the parsing is done as part of an exception handler - - Sectab_Stream : Mapped_Stream; - -- Section table - - Symtab_Stream : Mapped_Stream; - -- Symbol table - - Symstr_Stream : Mapped_Stream; - -- Symbol strings - - case Format is - when ELF => - Secstr_Stream : Mapped_Stream; - -- Section strings - when Any_PECOFF => - ImageBase : uint64; -- ImageBase value from header - - -- Cache for latest result of Get_Section_Virtual_Address - - GSVA_Sec : uint32 := uint32'Last; - GSVA_Addr : uint64; - when XCOFF32 => - null; - end case; - end record; - - subtype ELF_Object_File is Object_File; -- with - -- Predicate => ELF_Object_File.Format in ELF; - subtype PECOFF_Object_File is Object_File; -- with - -- Predicate => PECOFF_Object_File.Format in Any_PECOFF; - subtype XCOFF32_Object_File is Object_File; -- with - -- Predicate => XCOFF32_Object_File.Format in XCOFF32; - -- ???Above predicates cause the compiler to crash when instantiating - -- ELF64_Ops (see package body). - - type Object_Section is record - Num : uint32 := 0; - -- Section index in the section table - - Off : Offset := 0; - -- First byte of the section in the object file - - Addr : uint64 := 0; - -- Load address of the section. Valid only when Flag_Alloc is true. - - Size : uint64 := 0; - -- Length of the section in bytes - - Flag_Alloc : Boolean := False; - -- True if the section is mapped in memory by the OS loader - end record; - - Null_Section : constant Object_Section := (0, 0, 0, 0, False); - - type Object_Symbol is record - Off : Offset := 0; -- Offset of underlying symbol on disk - Next : Offset := 0; -- Offset of the following symbol - Value : uint64 := 0; -- Value associated with this symbol - Size : uint64 := 0; -- Size of the referenced entity - end record; - - Null_Symbol : constant Object_Symbol := (0, 0, 0, 0); -end System.Object_Reader; diff --git a/gcc/ada/s-os_lib.adb b/gcc/ada/s-os_lib.adb deleted file mode 100644 index da357e7..0000000 --- a/gcc/ada/s-os_lib.adb +++ /dev/null @@ -1,3083 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . O S _ L I B -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; -with System; use System; -with System.Case_Util; -with System.CRTL; -with System.Soft_Links; - -package body System.OS_Lib is - - subtype size_t is CRTL.size_t; - - procedure Strncpy (dest, src : System.Address; n : size_t) - renames CRTL.strncpy; - - -- Imported procedures Dup and Dup2 are used in procedures Spawn and - -- Non_Blocking_Spawn. - - function Dup (Fd : File_Descriptor) return File_Descriptor; - pragma Import (C, Dup, "__gnat_dup"); - - procedure Dup2 (Old_Fd, New_Fd : File_Descriptor); - pragma Import (C, Dup2, "__gnat_dup2"); - - function Copy_Attributes - (From : System.Address; - To : System.Address; - Mode : Integer) return Integer; - pragma Import (C, Copy_Attributes, "__gnat_copy_attribs"); - -- Mode = 0 - copy only time stamps. - -- Mode = 1 - copy time stamps and read/write/execute attributes - -- Mode = 2 - copy read/write/execute attributes - - On_Windows : constant Boolean := Directory_Separator = '\'; - -- An indication that we are on Windows. Used in Normalize_Pathname, to - -- deal with drive letters in the beginning of absolute paths. - - package SSL renames System.Soft_Links; - - -- The following are used by Create_Temp_File - - First_Temp_File_Name : constant String := "GNAT-TEMP-000000.TMP"; - -- Used to initialize Current_Temp_File_Name and Temp_File_Name_Last_Digit - - Current_Temp_File_Name : String := First_Temp_File_Name; - -- Name of the temp file last created - - Temp_File_Name_Last_Digit : constant Positive := - First_Temp_File_Name'Last - 4; - -- Position of the last digit in Current_Temp_File_Name - - Max_Attempts : constant := 100; - -- The maximum number of attempts to create a new temp file - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Args_Length (Args : Argument_List) return Natural; - -- Returns total number of characters needed to create a string of all Args - -- terminated by ASCII.NUL characters. - - procedure Create_Temp_File_Internal - (FD : out File_Descriptor; - Name : out String_Access; - Stdout : Boolean); - -- Internal routine to implement two Create_Temp_File routines. If Stdout - -- is set to True the created descriptor is stdout-compatible, otherwise - -- it might not be depending on the OS. The first two parameters are as - -- in Create_Temp_File. - - function C_String_Length (S : Address) return Integer; - -- Returns the length of C (null-terminated) string at S, or 0 for - -- Null_Address. - - procedure Spawn_Internal - (Program_Name : String; - Args : Argument_List; - Result : out Integer; - Pid : out Process_Id; - Blocking : Boolean); - -- Internal routine to implement the two Spawn (blocking/non blocking) - -- routines. If Blocking is set to True then the spawn is blocking - -- otherwise it is non blocking. In this latter case the Pid contains the - -- process id number. The first three parameters are as in Spawn. Note that - -- Spawn_Internal normalizes the argument list before calling the low level - -- system spawn routines (see Normalize_Arguments). - -- - -- Note: Normalize_Arguments is designed to do nothing if it is called more - -- than once, so calling Normalize_Arguments before calling one of the - -- spawn routines is fine. - - function To_Path_String_Access - (Path_Addr : Address; - Path_Len : Integer) return String_Access; - -- Converts a C String to an Ada String. We could do this making use of - -- Interfaces.C.Strings but we prefer not to import that entire package - - --------- - -- "<" -- - --------- - - function "<" (X, Y : OS_Time) return Boolean is - begin - return Long_Integer (X) < Long_Integer (Y); - end "<"; - - ---------- - -- "<=" -- - ---------- - - function "<=" (X, Y : OS_Time) return Boolean is - begin - return Long_Integer (X) <= Long_Integer (Y); - end "<="; - - --------- - -- ">" -- - --------- - - function ">" (X, Y : OS_Time) return Boolean is - begin - return Long_Integer (X) > Long_Integer (Y); - end ">"; - - ---------- - -- ">=" -- - ---------- - - function ">=" (X, Y : OS_Time) return Boolean is - begin - return Long_Integer (X) >= Long_Integer (Y); - end ">="; - - ----------------- - -- Args_Length -- - ----------------- - - function Args_Length (Args : Argument_List) return Natural is - Len : Natural := 0; - - begin - for J in Args'Range loop - Len := Len + Args (J)'Length + 1; -- One extra for ASCII.NUL - end loop; - - return Len; - end Args_Length; - - ----------------------------- - -- Argument_String_To_List -- - ----------------------------- - - function Argument_String_To_List - (Arg_String : String) return Argument_List_Access - is - Max_Args : constant Integer := Arg_String'Length; - New_Argv : Argument_List (1 .. Max_Args); - Idx : Integer; - New_Argc : Natural := 0; - - Cleaned : String (1 .. Arg_String'Length); - Cleaned_Idx : Natural; - -- A cleaned up version of the argument. This function is taking - -- backslash escapes when computing the bounds for arguments. It is - -- then removing the extra backslashes from the argument. - - Backslash_Is_Sep : constant Boolean := Directory_Separator = '\'; - -- Whether '\' is a directory separator (as on Windows), or a way to - -- quote special characters. - - begin - Idx := Arg_String'First; - - loop - exit when Idx > Arg_String'Last; - - declare - Backqd : Boolean := False; - Quoted : Boolean := False; - - begin - Cleaned_Idx := Cleaned'First; - - loop - -- An unquoted space is the end of an argument - - if not (Backqd or Quoted) - and then Arg_String (Idx) = ' ' - then - exit; - - -- Start of a quoted string - - elsif not (Backqd or Quoted) - and then Arg_String (Idx) = '"' - then - Quoted := True; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - - -- End of a quoted string and end of an argument - - elsif (Quoted and not Backqd) - and then Arg_String (Idx) = '"' - then - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - Idx := Idx + 1; - exit; - - -- Turn off backquoting after advancing one character - - elsif Backqd then - Backqd := False; - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - - -- Following character is backquoted - - elsif not Backslash_Is_Sep and then Arg_String (Idx) = '\' then - Backqd := True; - - else - Cleaned (Cleaned_Idx) := Arg_String (Idx); - Cleaned_Idx := Cleaned_Idx + 1; - end if; - - Idx := Idx + 1; - exit when Idx > Arg_String'Last; - end loop; - - -- Found an argument - - New_Argc := New_Argc + 1; - New_Argv (New_Argc) := - new String'(Cleaned (Cleaned'First .. Cleaned_Idx - 1)); - - -- Skip extraneous spaces - - while Idx <= Arg_String'Last and then Arg_String (Idx) = ' ' loop - Idx := Idx + 1; - end loop; - end; - end loop; - - return new Argument_List'(New_Argv (1 .. New_Argc)); - end Argument_String_To_List; - - --------------------- - -- C_String_Length -- - --------------------- - - function C_String_Length (S : Address) return Integer is - begin - if S = Null_Address then - return 0; - else - return Integer (CRTL.strlen (S)); - end if; - end C_String_Length; - - ----------- - -- Close -- - ----------- - - procedure Close (FD : File_Descriptor) is - use CRTL; - Discard : constant int := close (int (FD)); - begin - null; - end Close; - - procedure Close (FD : File_Descriptor; Status : out Boolean) is - use CRTL; - begin - Status := (close (int (FD)) = 0); - end Close; - - --------------- - -- Copy_File -- - --------------- - - procedure Copy_File - (Name : String; - Pathname : String; - Success : out Boolean; - Mode : Copy_Mode := Copy; - Preserve : Attribute := Time_Stamps) - is - From : File_Descriptor; - To : File_Descriptor; - - Copy_Error : exception; - -- Internal exception raised to signal error in copy - - function Build_Path (Dir : String; File : String) return String; - -- Returns pathname Dir concatenated with File adding the directory - -- separator only if needed. - - procedure Copy (From : File_Descriptor; To : File_Descriptor); - -- Read data from From and place them into To. In both cases the - -- operations uses the current file position. Raises Constraint_Error - -- if a problem occurs during the copy. - - procedure Copy_To (To_Name : String); - -- Does a straight copy from source to designated destination file - - ---------------- - -- Build_Path -- - ---------------- - - function Build_Path (Dir : String; File : String) return String is - function Is_Dirsep (C : Character) return Boolean; - pragma Inline (Is_Dirsep); - -- Returns True if C is a directory separator. On Windows we - -- handle both styles of directory separator. - - --------------- - -- Is_Dirsep -- - --------------- - - function Is_Dirsep (C : Character) return Boolean is - begin - return C = Directory_Separator or else C = '/'; - end Is_Dirsep; - - -- Local variables - - Base_File_Ptr : Integer; - -- The base file name is File (Base_File_Ptr + 1 .. File'Last) - - Res : String (1 .. Dir'Length + File'Length + 1); - - -- Start of processing for Build_Path - - begin - -- Find base file name - - Base_File_Ptr := File'Last; - while Base_File_Ptr >= File'First loop - exit when Is_Dirsep (File (Base_File_Ptr)); - Base_File_Ptr := Base_File_Ptr - 1; - end loop; - - declare - Base_File : String renames - File (Base_File_Ptr + 1 .. File'Last); - - begin - Res (1 .. Dir'Length) := Dir; - - if Is_Dirsep (Dir (Dir'Last)) then - Res (Dir'Length + 1 .. Dir'Length + Base_File'Length) := - Base_File; - return Res (1 .. Dir'Length + Base_File'Length); - - else - Res (Dir'Length + 1) := Directory_Separator; - Res (Dir'Length + 2 .. Dir'Length + 1 + Base_File'Length) := - Base_File; - return Res (1 .. Dir'Length + 1 + Base_File'Length); - end if; - end; - end Build_Path; - - ---------- - -- Copy -- - ---------- - - procedure Copy (From : File_Descriptor; To : File_Descriptor) is - Buf_Size : constant := 200_000; - type Buf is array (1 .. Buf_Size) of Character; - type Buf_Ptr is access Buf; - - Buffer : Buf_Ptr; - R : Integer; - W : Integer; - - Status_From : Boolean; - Status_To : Boolean; - -- Statuses for the calls to Close - - procedure Free is new Ada.Unchecked_Deallocation (Buf, Buf_Ptr); - - begin - -- Check for invalid descriptors, making sure that we do not - -- accidentally leave an open file descriptor around. - - if From = Invalid_FD then - if To /= Invalid_FD then - Close (To, Status_To); - end if; - - raise Copy_Error; - - elsif To = Invalid_FD then - Close (From, Status_From); - raise Copy_Error; - end if; - - -- Allocate the buffer on the heap - - Buffer := new Buf; - - loop - R := Read (From, Buffer (1)'Address, Buf_Size); - - -- On some systems, the buffer may not be full. So, we need to try - -- again until there is nothing to read. - - exit when R = 0; - - W := Write (To, Buffer (1)'Address, R); - - if W < R then - - -- Problem writing data, could be a disk full. Close files - -- without worrying about status, since we are raising a - -- Copy_Error exception in any case. - - Close (From, Status_From); - Close (To, Status_To); - - Free (Buffer); - - raise Copy_Error; - end if; - end loop; - - Close (From, Status_From); - Close (To, Status_To); - - Free (Buffer); - - if not (Status_From and Status_To) then - raise Copy_Error; - end if; - end Copy; - - ------------- - -- Copy_To -- - ------------- - - procedure Copy_To (To_Name : String) is - C_From : String (1 .. Name'Length + 1); - C_To : String (1 .. To_Name'Length + 1); - - begin - From := Open_Read (Name, Binary); - - -- Do not clobber destination file if source file could not be opened - - if From /= Invalid_FD then - To := Create_File (To_Name, Binary); - end if; - - Copy (From, To); - - -- Copy attributes - - C_From (1 .. Name'Length) := Name; - C_From (C_From'Last) := ASCII.NUL; - - C_To (1 .. To_Name'Length) := To_Name; - C_To (C_To'Last) := ASCII.NUL; - - case Preserve is - when Time_Stamps => - if Copy_Attributes (C_From'Address, C_To'Address, 0) = -1 then - raise Copy_Error; - end if; - - when Full => - if Copy_Attributes (C_From'Address, C_To'Address, 1) = -1 then - raise Copy_Error; - end if; - - when None => - null; - end case; - end Copy_To; - - -- Start of processing for Copy_File - - begin - Success := True; - - -- The source file must exist - - if not Is_Regular_File (Name) then - raise Copy_Error; - end if; - - -- The source file exists - - case Mode is - - -- Copy case, target file must not exist - - when Copy => - - -- If the target file exists, we have an error - - if Is_Regular_File (Pathname) then - raise Copy_Error; - - -- Case of target is a directory - - elsif Is_Directory (Pathname) then - declare - Dest : constant String := Build_Path (Pathname, Name); - - begin - -- If target file exists, we have an error, else do copy - - if Is_Regular_File (Dest) then - raise Copy_Error; - else - Copy_To (Dest); - end if; - end; - - -- Case of normal copy to file (destination does not exist) - - else - Copy_To (Pathname); - end if; - - -- Overwrite case (destination file may or may not exist) - - when Overwrite => - if Is_Directory (Pathname) then - Copy_To (Build_Path (Pathname, Name)); - else - Copy_To (Pathname); - end if; - - -- Append case (destination file may or may not exist) - - when Append => - - -- Appending to existing file - - if Is_Regular_File (Pathname) then - - -- Append mode and destination file exists, append data at the - -- end of Pathname. But if we fail to open source file, do not - -- touch destination file at all. - - From := Open_Read (Name, Binary); - if From /= Invalid_FD then - To := Open_Read_Write (Pathname, Binary); - end if; - - Lseek (To, 0, Seek_End); - - Copy (From, To); - - -- Appending to directory, not allowed - - elsif Is_Directory (Pathname) then - raise Copy_Error; - - -- Appending when target file does not exist - - else - Copy_To (Pathname); - end if; - end case; - - -- All error cases are caught here - - exception - when Copy_Error => - Success := False; - end Copy_File; - - procedure Copy_File - (Name : C_File_Name; - Pathname : C_File_Name; - Success : out Boolean; - Mode : Copy_Mode := Copy; - Preserve : Attribute := Time_Stamps) - is - Ada_Name : String_Access := - To_Path_String_Access - (Name, C_String_Length (Name)); - Ada_Pathname : String_Access := - To_Path_String_Access - (Pathname, C_String_Length (Pathname)); - - begin - Copy_File (Ada_Name.all, Ada_Pathname.all, Success, Mode, Preserve); - Free (Ada_Name); - Free (Ada_Pathname); - end Copy_File; - - -------------------------- - -- Copy_File_Attributes -- - -------------------------- - - procedure Copy_File_Attributes - (From : String; - To : String; - Success : out Boolean; - Copy_Timestamp : Boolean := True; - Copy_Permissions : Boolean := True) - is - F : aliased String (1 .. From'Length + 1); - T : aliased String (1 .. To'Length + 1); - - Mode : Integer; - - begin - if Copy_Timestamp then - if Copy_Permissions then - Mode := 1; - else - Mode := 0; - end if; - else - if Copy_Permissions then - Mode := 2; - else - Success := True; - return; -- nothing to do - end if; - end if; - - F (1 .. From'Length) := From; - F (F'Last) := ASCII.NUL; - - T (1 .. To'Length) := To; - T (T'Last) := ASCII.NUL; - - Success := Copy_Attributes (F'Address, T'Address, Mode) /= -1; - end Copy_File_Attributes; - - ---------------------- - -- Copy_Time_Stamps -- - ---------------------- - - procedure Copy_Time_Stamps - (Source : String; - Dest : String; - Success : out Boolean) - is - begin - if Is_Regular_File (Source) and then Is_Writable_File (Dest) then - declare - C_Source : String (1 .. Source'Length + 1); - C_Dest : String (1 .. Dest'Length + 1); - - begin - C_Source (1 .. Source'Length) := Source; - C_Source (C_Source'Last) := ASCII.NUL; - - C_Dest (1 .. Dest'Length) := Dest; - C_Dest (C_Dest'Last) := ASCII.NUL; - - if Copy_Attributes (C_Source'Address, C_Dest'Address, 0) = -1 then - Success := False; - else - Success := True; - end if; - end; - - else - Success := False; - end if; - end Copy_Time_Stamps; - - procedure Copy_Time_Stamps - (Source : C_File_Name; - Dest : C_File_Name; - Success : out Boolean) - is - Ada_Source : String_Access := - To_Path_String_Access - (Source, C_String_Length (Source)); - Ada_Dest : String_Access := - To_Path_String_Access - (Dest, C_String_Length (Dest)); - - begin - Copy_Time_Stamps (Ada_Source.all, Ada_Dest.all, Success); - Free (Ada_Source); - Free (Ada_Dest); - end Copy_Time_Stamps; - - ----------------- - -- Create_File -- - ----------------- - - function Create_File - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor - is - function C_Create_File - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - pragma Import (C, C_Create_File, "__gnat_open_create"); - begin - return C_Create_File (Name, Fmode); - end Create_File; - - function Create_File - (Name : String; - Fmode : Mode) return File_Descriptor - is - C_Name : String (1 .. Name'Length + 1); - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return Create_File (C_Name (C_Name'First)'Address, Fmode); - end Create_File; - - --------------------- - -- Create_New_File -- - --------------------- - - function Create_New_File - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor - is - function C_Create_New_File - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - pragma Import (C, C_Create_New_File, "__gnat_open_new"); - begin - return C_Create_New_File (Name, Fmode); - end Create_New_File; - - function Create_New_File - (Name : String; - Fmode : Mode) return File_Descriptor - is - C_Name : String (1 .. Name'Length + 1); - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return Create_New_File (C_Name (C_Name'First)'Address, Fmode); - end Create_New_File; - - ----------------------------- - -- Create_Output_Text_File -- - ----------------------------- - - function Create_Output_Text_File (Name : String) return File_Descriptor is - function C_Create_File (Name : C_File_Name) return File_Descriptor; - pragma Import (C, C_Create_File, "__gnat_create_output_file"); - - C_Name : String (1 .. Name'Length + 1); - - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return C_Create_File (C_Name (C_Name'First)'Address); - end Create_Output_Text_File; - - ---------------------- - -- Create_Temp_File -- - ---------------------- - - procedure Create_Temp_File - (FD : out File_Descriptor; - Name : out Temp_File_Name) - is - function Open_New_Temp - (Name : System.Address; - Fmode : Mode) return File_Descriptor; - pragma Import (C, Open_New_Temp, "__gnat_open_new_temp"); - - begin - FD := Open_New_Temp (Name'Address, Binary); - end Create_Temp_File; - - procedure Create_Temp_File - (FD : out File_Descriptor; - Name : out String_Access) - is - begin - Create_Temp_File_Internal (FD, Name, Stdout => False); - end Create_Temp_File; - - ----------------------------- - -- Create_Temp_Output_File -- - ----------------------------- - - procedure Create_Temp_Output_File - (FD : out File_Descriptor; - Name : out String_Access) - is - begin - Create_Temp_File_Internal (FD, Name, Stdout => True); - end Create_Temp_Output_File; - - ------------------------------- - -- Create_Temp_File_Internal -- - ------------------------------- - - procedure Create_Temp_File_Internal - (FD : out File_Descriptor; - Name : out String_Access; - Stdout : Boolean) - is - Pos : Positive; - Attempts : Natural := 0; - Current : String (Current_Temp_File_Name'Range); - - function Create_New_Output_Text_File - (Name : String) return File_Descriptor; - -- Similar to Create_Output_Text_File, except it fails if the file - -- already exists. We need this behavior to ensure we don't accidentally - -- open a temp file that has just been created by a concurrently running - -- process. There is no point exposing this function, as it's generally - -- not particularly useful. - - --------------------------------- - -- Create_New_Output_Text_File -- - --------------------------------- - - function Create_New_Output_Text_File - (Name : String) return File_Descriptor - is - function C_Create_File (Name : C_File_Name) return File_Descriptor; - pragma Import (C, C_Create_File, "__gnat_create_output_file_new"); - - C_Name : String (1 .. Name'Length + 1); - - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return C_Create_File (C_Name (C_Name'First)'Address); - end Create_New_Output_Text_File; - - -- Start of processing for Create_Temp_File_Internal - - begin - -- Loop until a new temp file can be created - - File_Loop : loop - Locked : begin - - -- We need to protect global variable Current_Temp_File_Name - -- against concurrent access by different tasks. - - SSL.Lock_Task.all; - - -- Start at the last digit - - Pos := Temp_File_Name_Last_Digit; - - Digit_Loop : - loop - -- Increment the digit by one - - case Current_Temp_File_Name (Pos) is - when '0' .. '8' => - Current_Temp_File_Name (Pos) := - Character'Succ (Current_Temp_File_Name (Pos)); - exit Digit_Loop; - - when '9' => - - -- For 9, set the digit to 0 and go to the previous digit - - Current_Temp_File_Name (Pos) := '0'; - Pos := Pos - 1; - - when others => - - -- If it is not a digit, then there are no available - -- temp file names. Return Invalid_FD. There is almost no - -- chance that this code will be ever be executed, since - -- it would mean that there are one million temp files in - -- the same directory. - - SSL.Unlock_Task.all; - FD := Invalid_FD; - Name := null; - exit File_Loop; - end case; - end loop Digit_Loop; - - Current := Current_Temp_File_Name; - - -- We can now release the lock, because we are no longer accessing - -- Current_Temp_File_Name. - - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked; - - -- Attempt to create the file - - if Stdout then - FD := Create_New_Output_Text_File (Current); - else - FD := Create_New_File (Current, Binary); - end if; - - if FD /= Invalid_FD then - Name := new String'(Current); - exit File_Loop; - end if; - - if not Is_Regular_File (Current) then - - -- If the file does not already exist and we are unable to create - -- it, we give up after Max_Attempts. Otherwise, we try again with - -- the next available file name. - - Attempts := Attempts + 1; - - if Attempts >= Max_Attempts then - FD := Invalid_FD; - Name := null; - exit File_Loop; - end if; - end if; - end loop File_Loop; - end Create_Temp_File_Internal; - - ------------------------- - -- Current_Time_String -- - ------------------------- - - function Current_Time_String return String is - subtype S23 is String (1 .. 23); - -- Holds current time in ISO 8601 format YYYY-MM-DD HH:MM:SS.SS + NUL - - procedure Current_Time_String (Time : System.Address); - pragma Import (C, Current_Time_String, "__gnat_current_time_string"); - -- Puts current time into Time in above ISO 8601 format - - Result23 : aliased S23; - -- Current time in ISO 8601 format - - begin - Current_Time_String (Result23'Address); - return Result23 (1 .. 19); - end Current_Time_String; - - ----------------- - -- Delete_File -- - ----------------- - - procedure Delete_File (Name : Address; Success : out Boolean) is - R : Integer; - begin - R := System.CRTL.unlink (Name); - Success := (R = 0); - end Delete_File; - - procedure Delete_File (Name : String; Success : out Boolean) is - C_Name : String (1 .. Name'Length + 1); - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - Delete_File (C_Name'Address, Success); - end Delete_File; - - ------------------- - -- Errno_Message -- - ------------------- - - function Errno_Message - (Err : Integer := Errno; - Default : String := "") return String - is - function strerror (errnum : Integer) return System.Address; - pragma Import (C, strerror, "strerror"); - - C_Msg : constant System.Address := strerror (Err); - - begin - if C_Msg = Null_Address then - if Default /= "" then - return Default; - - else - -- Note: for bootstrap reasons, it is impractical - -- to use Integer'Image here. - - declare - Val : Integer; - First : Integer; - - Buf : String (1 .. 20); - -- Buffer large enough to hold image of largest Integer values - - begin - Val := abs Err; - First := Buf'Last; - loop - Buf (First) := - Character'Val (Character'Pos ('0') + Val mod 10); - Val := Val / 10; - exit when Val = 0; - First := First - 1; - end loop; - - if Err < 0 then - First := First - 1; - Buf (First) := '-'; - end if; - - return "errno = " & Buf (First .. Buf'Last); - end; - end if; - - else - declare - Msg : String (1 .. Integer (CRTL.strlen (C_Msg))); - for Msg'Address use C_Msg; - pragma Import (Ada, Msg); - begin - return Msg; - end; - end if; - end Errno_Message; - - --------------------- - -- File_Time_Stamp -- - --------------------- - - function File_Time_Stamp (FD : File_Descriptor) return OS_Time is - function File_Time (FD : File_Descriptor) return OS_Time; - pragma Import (C, File_Time, "__gnat_file_time_fd"); - begin - return File_Time (FD); - end File_Time_Stamp; - - function File_Time_Stamp (Name : C_File_Name) return OS_Time is - function File_Time (Name : Address) return OS_Time; - pragma Import (C, File_Time, "__gnat_file_time_name"); - begin - return File_Time (Name); - end File_Time_Stamp; - - function File_Time_Stamp (Name : String) return OS_Time is - F_Name : String (1 .. Name'Length + 1); - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return File_Time_Stamp (F_Name'Address); - end File_Time_Stamp; - - --------------------------- - -- Get_Debuggable_Suffix -- - --------------------------- - - function Get_Debuggable_Suffix return String_Access is - procedure Get_Suffix_Ptr (Length, Ptr : Address); - pragma Import (C, Get_Suffix_Ptr, "__gnat_get_debuggable_suffix_ptr"); - - Result : String_Access; - Suffix_Length : Integer; - Suffix_Ptr : Address; - - begin - Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); - Result := new String (1 .. Suffix_Length); - - if Suffix_Length > 0 then - Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length)); - end if; - - return Result; - end Get_Debuggable_Suffix; - - --------------------------- - -- Get_Executable_Suffix -- - --------------------------- - - function Get_Executable_Suffix return String_Access is - procedure Get_Suffix_Ptr (Length, Ptr : Address); - pragma Import (C, Get_Suffix_Ptr, "__gnat_get_executable_suffix_ptr"); - - Result : String_Access; - Suffix_Length : Integer; - Suffix_Ptr : Address; - - begin - Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); - Result := new String (1 .. Suffix_Length); - - if Suffix_Length > 0 then - Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length)); - end if; - - return Result; - end Get_Executable_Suffix; - - ----------------------- - -- Get_Object_Suffix -- - ----------------------- - - function Get_Object_Suffix return String_Access is - procedure Get_Suffix_Ptr (Length, Ptr : Address); - pragma Import (C, Get_Suffix_Ptr, "__gnat_get_object_suffix_ptr"); - - Result : String_Access; - Suffix_Length : Integer; - Suffix_Ptr : Address; - - begin - Get_Suffix_Ptr (Suffix_Length'Address, Suffix_Ptr'Address); - Result := new String (1 .. Suffix_Length); - - if Suffix_Length > 0 then - Strncpy (Result.all'Address, Suffix_Ptr, size_t (Suffix_Length)); - end if; - - return Result; - end Get_Object_Suffix; - - ---------------------------------- - -- Get_Target_Debuggable_Suffix -- - ---------------------------------- - - function Get_Target_Debuggable_Suffix return String_Access is - Target_Exec_Ext_Ptr : Address; - pragma Import - (C, Target_Exec_Ext_Ptr, "__gnat_target_debuggable_extension"); - - Result : String_Access; - Suffix_Length : Integer; - - begin - Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr)); - Result := new String (1 .. Suffix_Length); - - if Suffix_Length > 0 then - Strncpy - (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length)); - end if; - - return Result; - end Get_Target_Debuggable_Suffix; - - ---------------------------------- - -- Get_Target_Executable_Suffix -- - ---------------------------------- - - function Get_Target_Executable_Suffix return String_Access is - Target_Exec_Ext_Ptr : Address; - pragma Import - (C, Target_Exec_Ext_Ptr, "__gnat_target_executable_extension"); - - Result : String_Access; - Suffix_Length : Integer; - - begin - Suffix_Length := Integer (CRTL.strlen (Target_Exec_Ext_Ptr)); - Result := new String (1 .. Suffix_Length); - - if Suffix_Length > 0 then - Strncpy - (Result.all'Address, Target_Exec_Ext_Ptr, size_t (Suffix_Length)); - end if; - - return Result; - end Get_Target_Executable_Suffix; - - ------------------------------ - -- Get_Target_Object_Suffix -- - ------------------------------ - - function Get_Target_Object_Suffix return String_Access is - Target_Object_Ext_Ptr : Address; - pragma Import - (C, Target_Object_Ext_Ptr, "__gnat_target_object_extension"); - - Result : String_Access; - Suffix_Length : Integer; - - begin - Suffix_Length := Integer (CRTL.strlen (Target_Object_Ext_Ptr)); - Result := new String (1 .. Suffix_Length); - - if Suffix_Length > 0 then - Strncpy - (Result.all'Address, Target_Object_Ext_Ptr, size_t (Suffix_Length)); - end if; - - return Result; - end Get_Target_Object_Suffix; - - ------------ - -- Getenv -- - ------------ - - function Getenv (Name : String) return String_Access is - procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); - pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); - - Env_Value_Ptr : aliased Address; - Env_Value_Length : aliased Integer; - F_Name : aliased String (1 .. Name'Length + 1); - Result : String_Access; - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - - Get_Env_Value_Ptr - (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); - - Result := new String (1 .. Env_Value_Length); - - if Env_Value_Length > 0 then - Strncpy - (Result.all'Address, Env_Value_Ptr, size_t (Env_Value_Length)); - end if; - - return Result; - end Getenv; - - ------------ - -- GM_Day -- - ------------ - - function GM_Day (Date : OS_Time) return Day_Type is - D : Day_Type; - - Y : Year_Type; - Mo : Month_Type; - H : Hour_Type; - Mn : Minute_Type; - S : Second_Type; - pragma Unreferenced (Y, Mo, H, Mn, S); - - begin - GM_Split (Date, Y, Mo, D, H, Mn, S); - return D; - end GM_Day; - - ------------- - -- GM_Hour -- - ------------- - - function GM_Hour (Date : OS_Time) return Hour_Type is - H : Hour_Type; - - Y : Year_Type; - Mo : Month_Type; - D : Day_Type; - Mn : Minute_Type; - S : Second_Type; - pragma Unreferenced (Y, Mo, D, Mn, S); - - begin - GM_Split (Date, Y, Mo, D, H, Mn, S); - return H; - end GM_Hour; - - --------------- - -- GM_Minute -- - --------------- - - function GM_Minute (Date : OS_Time) return Minute_Type is - Mn : Minute_Type; - - Y : Year_Type; - Mo : Month_Type; - D : Day_Type; - H : Hour_Type; - S : Second_Type; - pragma Unreferenced (Y, Mo, D, H, S); - - begin - GM_Split (Date, Y, Mo, D, H, Mn, S); - return Mn; - end GM_Minute; - - -------------- - -- GM_Month -- - -------------- - - function GM_Month (Date : OS_Time) return Month_Type is - Mo : Month_Type; - - Y : Year_Type; - D : Day_Type; - H : Hour_Type; - Mn : Minute_Type; - S : Second_Type; - pragma Unreferenced (Y, D, H, Mn, S); - - begin - GM_Split (Date, Y, Mo, D, H, Mn, S); - return Mo; - end GM_Month; - - --------------- - -- GM_Second -- - --------------- - - function GM_Second (Date : OS_Time) return Second_Type is - S : Second_Type; - - Y : Year_Type; - Mo : Month_Type; - D : Day_Type; - H : Hour_Type; - Mn : Minute_Type; - pragma Unreferenced (Y, Mo, D, H, Mn); - - begin - GM_Split (Date, Y, Mo, D, H, Mn, S); - return S; - end GM_Second; - - -------------- - -- GM_Split -- - -------------- - - procedure GM_Split - (Date : OS_Time; - Year : out Year_Type; - Month : out Month_Type; - Day : out Day_Type; - Hour : out Hour_Type; - Minute : out Minute_Type; - Second : out Second_Type) - is - procedure To_GM_Time - (P_Time_T : Address; - P_Year : Address; - P_Month : Address; - P_Day : Address; - P_Hours : Address; - P_Mins : Address; - P_Secs : Address); - pragma Import (C, To_GM_Time, "__gnat_to_gm_time"); - - T : OS_Time := Date; - Y : Integer; - Mo : Integer; - D : Integer; - H : Integer; - Mn : Integer; - S : Integer; - - begin - -- Use the global lock because To_GM_Time is not thread safe - - Locked_Processing : begin - SSL.Lock_Task.all; - To_GM_Time - (P_Time_T => T'Address, - P_Year => Y'Address, - P_Month => Mo'Address, - P_Day => D'Address, - P_Hours => H'Address, - P_Mins => Mn'Address, - P_Secs => S'Address); - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Locked_Processing; - - Year := Y + 1900; - Month := Mo + 1; - Day := D; - Hour := H; - Minute := Mn; - Second := S; - end GM_Split; - - ---------------- - -- GM_Time_Of -- - ---------------- - - function GM_Time_Of - (Year : Year_Type; - Month : Month_Type; - Day : Day_Type; - Hour : Hour_Type; - Minute : Minute_Type; - Second : Second_Type) return OS_Time - is - procedure To_OS_Time - (P_Time_T : Address; - P_Year : Integer; - P_Month : Integer; - P_Day : Integer; - P_Hours : Integer; - P_Mins : Integer; - P_Secs : Integer); - pragma Import (C, To_OS_Time, "__gnat_to_os_time"); - - Result : OS_Time; - - begin - To_OS_Time - (P_Time_T => Result'Address, - P_Year => Year - 1900, - P_Month => Month - 1, - P_Day => Day, - P_Hours => Hour, - P_Mins => Minute, - P_Secs => Second); - return Result; - end GM_Time_Of; - - ------------- - -- GM_Year -- - ------------- - - function GM_Year (Date : OS_Time) return Year_Type is - Y : Year_Type; - - Mo : Month_Type; - D : Day_Type; - H : Hour_Type; - Mn : Minute_Type; - S : Second_Type; - pragma Unreferenced (Mo, D, H, Mn, S); - - begin - GM_Split (Date, Y, Mo, D, H, Mn, S); - return Y; - end GM_Year; - - ---------------------- - -- Is_Absolute_Path -- - ---------------------- - - function Is_Absolute_Path (Name : String) return Boolean is - function Is_Absolute_Path - (Name : Address; - Length : Integer) return Integer; - pragma Import (C, Is_Absolute_Path, "__gnat_is_absolute_path"); - begin - return Is_Absolute_Path (Name'Address, Name'Length) /= 0; - end Is_Absolute_Path; - - ------------------ - -- Is_Directory -- - ------------------ - - function Is_Directory (Name : C_File_Name) return Boolean is - function Is_Directory (Name : Address) return Integer; - pragma Import (C, Is_Directory, "__gnat_is_directory"); - begin - return Is_Directory (Name) /= 0; - end Is_Directory; - - function Is_Directory (Name : String) return Boolean is - F_Name : String (1 .. Name'Length + 1); - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Directory (F_Name'Address); - end Is_Directory; - - ----------------------------- - -- Is_Read_Accessible_File -- - ----------------------------- - - function Is_Read_Accessible_File (Name : String) return Boolean is - function Is_Read_Accessible_File (Name : Address) return Integer; - pragma Import - (C, Is_Read_Accessible_File, "__gnat_is_read_accessible_file"); - F_Name : String (1 .. Name'Length + 1); - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Read_Accessible_File (F_Name'Address) /= 0; - end Is_Read_Accessible_File; - - ---------------------------- - -- Is_Owner_Readable_File -- - ---------------------------- - - function Is_Owner_Readable_File (Name : C_File_Name) return Boolean is - function Is_Readable_File (Name : Address) return Integer; - pragma Import (C, Is_Readable_File, "__gnat_is_readable_file"); - begin - return Is_Readable_File (Name) /= 0; - end Is_Owner_Readable_File; - - function Is_Owner_Readable_File (Name : String) return Boolean is - F_Name : String (1 .. Name'Length + 1); - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Owner_Readable_File (F_Name'Address); - end Is_Owner_Readable_File; - - ------------------------ - -- Is_Executable_File -- - ------------------------ - - function Is_Executable_File (Name : C_File_Name) return Boolean is - function Is_Executable_File (Name : Address) return Integer; - pragma Import (C, Is_Executable_File, "__gnat_is_executable_file"); - begin - return Is_Executable_File (Name) /= 0; - end Is_Executable_File; - - function Is_Executable_File (Name : String) return Boolean is - F_Name : String (1 .. Name'Length + 1); - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Executable_File (F_Name'Address); - end Is_Executable_File; - - --------------------- - -- Is_Regular_File -- - --------------------- - - function Is_Regular_File (Name : C_File_Name) return Boolean is - function Is_Regular_File (Name : Address) return Integer; - pragma Import (C, Is_Regular_File, "__gnat_is_regular_file"); - begin - return Is_Regular_File (Name) /= 0; - end Is_Regular_File; - - function Is_Regular_File (Name : String) return Boolean is - F_Name : String (1 .. Name'Length + 1); - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Regular_File (F_Name'Address); - end Is_Regular_File; - - ---------------------- - -- Is_Symbolic_Link -- - ---------------------- - - function Is_Symbolic_Link (Name : C_File_Name) return Boolean is - function Is_Symbolic_Link (Name : Address) return Integer; - pragma Import (C, Is_Symbolic_Link, "__gnat_is_symbolic_link"); - begin - return Is_Symbolic_Link (Name) /= 0; - end Is_Symbolic_Link; - - function Is_Symbolic_Link (Name : String) return Boolean is - F_Name : String (1 .. Name'Length + 1); - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Symbolic_Link (F_Name'Address); - end Is_Symbolic_Link; - - ------------------------------ - -- Is_Write_Accessible_File -- - ------------------------------ - - function Is_Write_Accessible_File (Name : String) return Boolean is - function Is_Write_Accessible_File (Name : Address) return Integer; - pragma Import - (C, Is_Write_Accessible_File, "__gnat_is_write_accessible_file"); - F_Name : String (1 .. Name'Length + 1); - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Write_Accessible_File (F_Name'Address) /= 0; - end Is_Write_Accessible_File; - - ---------------------------- - -- Is_Owner_Writable_File -- - ---------------------------- - - function Is_Owner_Writable_File (Name : C_File_Name) return Boolean is - function Is_Writable_File (Name : Address) return Integer; - pragma Import (C, Is_Writable_File, "__gnat_is_writable_file"); - begin - return Is_Writable_File (Name) /= 0; - end Is_Owner_Writable_File; - - function Is_Owner_Writable_File (Name : String) return Boolean is - F_Name : String (1 .. Name'Length + 1); - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - return Is_Owner_Writable_File (F_Name'Address); - end Is_Owner_Writable_File; - - ---------- - -- Kill -- - ---------- - - procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True) is - SIGKILL : constant := 9; - SIGINT : constant := 2; - - procedure C_Kill (Pid : Process_Id; Sig_Num : Integer; Close : Integer); - pragma Import (C, C_Kill, "__gnat_kill"); - - begin - if Hard_Kill then - C_Kill (Pid, SIGKILL, 1); - else - C_Kill (Pid, SIGINT, 1); - end if; - end Kill; - - ----------------------- - -- Kill_Process_Tree -- - ----------------------- - - procedure Kill_Process_Tree - (Pid : Process_Id; Hard_Kill : Boolean := True) - is - SIGKILL : constant := 9; - SIGINT : constant := 2; - - procedure C_Kill_PT (Pid : Process_Id; Sig_Num : Integer); - pragma Import (C, C_Kill_PT, "__gnat_killprocesstree"); - - begin - if Hard_Kill then - C_Kill_PT (Pid, SIGKILL); - else - C_Kill_PT (Pid, SIGINT); - end if; - end Kill_Process_Tree; - - ------------------------- - -- Locate_Exec_On_Path -- - ------------------------- - - function Locate_Exec_On_Path - (Exec_Name : String) return String_Access - is - function Locate_Exec_On_Path (C_Exec_Name : Address) return Address; - pragma Import (C, Locate_Exec_On_Path, "__gnat_locate_exec_on_path"); - - C_Exec_Name : String (1 .. Exec_Name'Length + 1); - Path_Addr : Address; - Path_Len : Integer; - Result : String_Access; - - begin - C_Exec_Name (1 .. Exec_Name'Length) := Exec_Name; - C_Exec_Name (C_Exec_Name'Last) := ASCII.NUL; - - Path_Addr := Locate_Exec_On_Path (C_Exec_Name'Address); - Path_Len := C_String_Length (Path_Addr); - - if Path_Len = 0 then - return null; - - else - Result := To_Path_String_Access (Path_Addr, Path_Len); - CRTL.free (Path_Addr); - - -- Always return an absolute path name - - if not Is_Absolute_Path (Result.all) then - declare - Absolute_Path : constant String := - Normalize_Pathname (Result.all, Resolve_Links => False); - begin - Free (Result); - Result := new String'(Absolute_Path); - end; - end if; - - return Result; - end if; - end Locate_Exec_On_Path; - - ------------------------- - -- Locate_Regular_File -- - ------------------------- - - function Locate_Regular_File - (File_Name : C_File_Name; - Path : C_File_Name) return String_Access - is - function Locate_Regular_File - (C_File_Name, Path_Val : Address) return Address; - pragma Import (C, Locate_Regular_File, "__gnat_locate_regular_file"); - - Path_Addr : Address; - Path_Len : Integer; - Result : String_Access; - - begin - Path_Addr := Locate_Regular_File (File_Name, Path); - Path_Len := C_String_Length (Path_Addr); - - if Path_Len = 0 then - return null; - - else - Result := To_Path_String_Access (Path_Addr, Path_Len); - CRTL.free (Path_Addr); - return Result; - end if; - end Locate_Regular_File; - - function Locate_Regular_File - (File_Name : String; - Path : String) return String_Access - is - C_File_Name : String (1 .. File_Name'Length + 1); - C_Path : String (1 .. Path'Length + 1); - Result : String_Access; - - begin - C_File_Name (1 .. File_Name'Length) := File_Name; - C_File_Name (C_File_Name'Last) := ASCII.NUL; - - C_Path (1 .. Path'Length) := Path; - C_Path (C_Path'Last) := ASCII.NUL; - - Result := Locate_Regular_File (C_File_Name'Address, C_Path'Address); - - -- Always return an absolute path name - - if Result /= null and then not Is_Absolute_Path (Result.all) then - declare - Absolute_Path : constant String := Normalize_Pathname (Result.all); - begin - Free (Result); - Result := new String'(Absolute_Path); - end; - end if; - - return Result; - end Locate_Regular_File; - - ------------------------ - -- Non_Blocking_Spawn -- - ------------------------ - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List) return Process_Id - is - Junk : Integer; - pragma Warnings (Off, Junk); - Pid : Process_Id; - - begin - Spawn_Internal (Program_Name, Args, Junk, Pid, Blocking => False); - return Pid; - end Non_Blocking_Spawn; - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Output_File_Descriptor : File_Descriptor; - Err_To_Out : Boolean := True) return Process_Id - is - Pid : Process_Id; - Saved_Error : File_Descriptor := Invalid_FD; -- prevent warning - Saved_Output : File_Descriptor; - - begin - if Output_File_Descriptor = Invalid_FD then - return Invalid_Pid; - end if; - - -- Set standard output and, if specified, error to the temporary file - - Saved_Output := Dup (Standout); - Dup2 (Output_File_Descriptor, Standout); - - if Err_To_Out then - Saved_Error := Dup (Standerr); - Dup2 (Output_File_Descriptor, Standerr); - end if; - - -- Spawn the program - - Pid := Non_Blocking_Spawn (Program_Name, Args); - - -- Restore the standard output and error - - Dup2 (Saved_Output, Standout); - - if Err_To_Out then - Dup2 (Saved_Error, Standerr); - end if; - - -- And close the saved standard output and error file descriptors - - Close (Saved_Output); - - if Err_To_Out then - Close (Saved_Error); - end if; - - return Pid; - end Non_Blocking_Spawn; - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Output_File : String; - Err_To_Out : Boolean := True) return Process_Id - is - Output_File_Descriptor : constant File_Descriptor := - Create_Output_Text_File (Output_File); - Result : Process_Id; - - begin - -- Do not attempt to spawn if the output file could not be created - - if Output_File_Descriptor = Invalid_FD then - return Invalid_Pid; - - else - Result := - Non_Blocking_Spawn - (Program_Name, Args, Output_File_Descriptor, Err_To_Out); - - -- Close the file just created for the output, as the file descriptor - -- cannot be used anywhere, being a local value. It is safe to do - -- that, as the file descriptor has been duplicated to form - -- standard output and error of the spawned process. - - Close (Output_File_Descriptor); - - return Result; - end if; - end Non_Blocking_Spawn; - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Stdout_File : String; - Stderr_File : String) return Process_Id - is - Stderr_FD : constant File_Descriptor := - Create_Output_Text_File (Stderr_File); - Stdout_FD : constant File_Descriptor := - Create_Output_Text_File (Stdout_File); - - Result : Process_Id; - Saved_Error : File_Descriptor; - Saved_Output : File_Descriptor; - - Dummy_Status : Boolean; - - begin - -- Do not attempt to spawn if the output files could not be created - - if Stdout_FD = Invalid_FD or else Stderr_FD = Invalid_FD then - return Invalid_Pid; - end if; - - -- Set standard output and error to the specified files - - Saved_Output := Dup (Standout); - Dup2 (Stdout_FD, Standout); - - Saved_Error := Dup (Standerr); - Dup2 (Stderr_FD, Standerr); - - Set_Close_On_Exec (Saved_Output, True, Dummy_Status); - Set_Close_On_Exec (Saved_Error, True, Dummy_Status); - - -- Close the files just created for the output, as the file descriptors - -- cannot be used anywhere, being local values. It is safe to do that, - -- as the file descriptors have been duplicated to form standard output - -- and standard error of the spawned process. - - Close (Stdout_FD); - Close (Stderr_FD); - - -- Spawn the program - - Result := Non_Blocking_Spawn (Program_Name, Args); - - -- Restore the standard output and error - - Dup2 (Saved_Output, Standout); - Dup2 (Saved_Error, Standerr); - - -- And close the saved standard output and error file descriptors - - Close (Saved_Output); - Close (Saved_Error); - - return Result; - end Non_Blocking_Spawn; - - ------------------------------- - -- Non_Blocking_Wait_Process -- - ------------------------------- - - procedure Non_Blocking_Wait_Process - (Pid : out Process_Id; Success : out Boolean) - is - Status : Integer; - - function Portable_No_Block_Wait (S : Address) return Process_Id; - pragma Import - (C, Portable_No_Block_Wait, "__gnat_portable_no_block_wait"); - - begin - Pid := Portable_No_Block_Wait (Status'Address); - Success := (Status = 0); - - if Pid = 0 then - Pid := Invalid_Pid; - end if; - end Non_Blocking_Wait_Process; - - ------------------------- - -- Normalize_Arguments -- - ------------------------- - - procedure Normalize_Arguments (Args : in out Argument_List) is - procedure Quote_Argument (Arg : in out String_Access); - -- Add quote around argument if it contains spaces (or HT characters) - - C_Argument_Needs_Quote : Integer; - pragma Import (C, C_Argument_Needs_Quote, "__gnat_argument_needs_quote"); - Argument_Needs_Quote : constant Boolean := C_Argument_Needs_Quote /= 0; - - -------------------- - -- Quote_Argument -- - -------------------- - - procedure Quote_Argument (Arg : in out String_Access) is - J : Positive := 1; - Quote_Needed : Boolean := False; - Res : String (1 .. Arg'Length * 2); - - begin - if Arg (Arg'First) /= '"' or else Arg (Arg'Last) /= '"' then - - -- Starting quote - - Res (J) := '"'; - - for K in Arg'Range loop - - J := J + 1; - - if Arg (K) = '"' then - Res (J) := '\'; - J := J + 1; - Res (J) := '"'; - Quote_Needed := True; - - elsif Arg (K) = ' ' or else Arg (K) = ASCII.HT then - Res (J) := Arg (K); - Quote_Needed := True; - - else - Res (J) := Arg (K); - end if; - end loop; - - if Quote_Needed then - - -- Case of null terminated string - - if Res (J) = ASCII.NUL then - - -- If the string ends with \, double it - - if Res (J - 1) = '\' then - Res (J) := '\'; - J := J + 1; - end if; - - -- Put a quote just before the null at the end - - Res (J) := '"'; - J := J + 1; - Res (J) := ASCII.NUL; - - -- If argument is terminated by '\', then double it. Otherwise - -- the ending quote will be taken as-is. This is quite strange - -- spawn behavior from Windows, but this is what we see. - - else - if Res (J) = '\' then - J := J + 1; - Res (J) := '\'; - end if; - - -- Ending quote - - J := J + 1; - Res (J) := '"'; - end if; - - declare - Old : String_Access := Arg; - - begin - Arg := new String'(Res (1 .. J)); - Free (Old); - end; - end if; - - end if; - end Quote_Argument; - - -- Start of processing for Normalize_Arguments - - begin - if Argument_Needs_Quote then - for K in Args'Range loop - if Args (K) /= null and then Args (K)'Length /= 0 then - Quote_Argument (Args (K)); - end if; - end loop; - end if; - end Normalize_Arguments; - - ------------------------ - -- Normalize_Pathname -- - ------------------------ - - function Normalize_Pathname - (Name : String; - Directory : String := ""; - Resolve_Links : Boolean := True; - Case_Sensitive : Boolean := True) return String - is - procedure Get_Current_Dir - (Dir : System.Address; - Length : System.Address); - pragma Import (C, Get_Current_Dir, "__gnat_get_current_dir"); - - function Get_File_Names_Case_Sensitive return Integer; - pragma Import - (C, Get_File_Names_Case_Sensitive, - "__gnat_get_file_names_case_sensitive"); - - Max_Path : Integer; - pragma Import (C, Max_Path, "__gnat_max_path_len"); - -- Maximum length of a path name - - function Readlink - (Path : System.Address; - Buf : System.Address; - Bufsiz : size_t) return Integer; - pragma Import (C, Readlink, "__gnat_readlink"); - - function To_Canonical_File_Spec - (Host_File : System.Address) return System.Address; - pragma Import - (C, To_Canonical_File_Spec, "__gnat_to_canonical_file_spec"); - -- Convert possible foreign file syntax to canonical form - - Fold_To_Lower_Case : constant Boolean := - not Case_Sensitive - and then Get_File_Names_Case_Sensitive = 0; - - function Final_Value (S : String) return String; - -- Make final adjustment to the returned string. This function strips - -- trailing directory separators, and folds returned string to lower - -- case if required. - - function Get_Directory (Dir : String) return String; - -- If Dir is not empty, return it, adding a directory separator - -- if not already present, otherwise return current working directory - -- with terminating directory separator. - - ----------------- - -- Final_Value -- - ----------------- - - function Final_Value (S : String) return String is - S1 : String := S; - -- We may need to fold S to lower case, so we need a variable - - Last : Natural; - - begin - if Fold_To_Lower_Case then - System.Case_Util.To_Lower (S1); - end if; - - -- Remove trailing directory separator, if any - - Last := S1'Last; - - if Last > 1 - and then (S1 (Last) = '/' - or else - S1 (Last) = Directory_Separator) - then - -- Special case for Windows: C:\ - - if Last = 3 - and then S1 (1) /= Directory_Separator - and then S1 (2) = ':' - then - null; - - else - Last := Last - 1; - end if; - end if; - - return S1 (1 .. Last); - end Final_Value; - - ------------------- - -- Get_Directory -- - ------------------- - - function Get_Directory (Dir : String) return String is - begin - -- Directory given, add directory separator if needed - - if Dir'Length > 0 then - declare - Result : String := - Normalize_Pathname - (Dir, "", Resolve_Links, Case_Sensitive) & - Directory_Separator; - Last : Positive := Result'Last - 1; - - begin - -- On Windows, change all '/' to '\' - - if On_Windows then - for J in Result'First .. Last - 1 loop - if Result (J) = '/' then - Result (J) := Directory_Separator; - end if; - end loop; - end if; - - -- Include additional directory separator, if needed - - if Result (Last) /= Directory_Separator then - Last := Last + 1; - end if; - - return Result (Result'First .. Last); - end; - - -- Directory name not given, get current directory - - else - declare - Buffer : String (1 .. Max_Path + 2); - Path_Len : Natural := Max_Path; - - begin - Get_Current_Dir (Buffer'Address, Path_Len'Address); - - if Path_Len = 0 then - raise Program_Error; - end if; - - if Buffer (Path_Len) /= Directory_Separator then - Path_Len := Path_Len + 1; - Buffer (Path_Len) := Directory_Separator; - end if; - - -- By default, the drive letter on Windows is in upper case - - if On_Windows - and then Path_Len >= 2 - and then Buffer (2) = ':' - then - System.Case_Util.To_Upper (Buffer (1 .. 1)); - end if; - - return Buffer (1 .. Path_Len); - end; - end if; - end Get_Directory; - - -- Local variables - - Max_Iterations : constant := 500; - - Canonical_File_Addr : System.Address; - Canonical_File_Len : Integer; - - End_Path : Natural := 0; - Finish : Positive; - Last : Positive; - Link_Buffer : String (1 .. Max_Path + 2); - Path_Buffer : String (1 .. Max_Path + Max_Path + 2); - Start : Natural; - Status : Integer; - The_Name : String (1 .. Name'Length + 1); - - -- Start of processing for Normalize_Pathname - - begin - -- Special case, return null if name is null, or if it is bigger than - -- the biggest name allowed. - - if Name'Length = 0 or else Name'Length > Max_Path then - return ""; - end if; - - -- First, convert possible foreign file spec to Unix file spec. If no - -- conversion is required, all this does is put Name at the beginning - -- of Path_Buffer unchanged. - - File_Name_Conversion : begin - The_Name (1 .. Name'Length) := Name; - The_Name (The_Name'Last) := ASCII.NUL; - - Canonical_File_Addr := To_Canonical_File_Spec (The_Name'Address); - Canonical_File_Len := Integer (CRTL.strlen (Canonical_File_Addr)); - - -- If syntax conversion has failed, return an empty string to - -- indicate the failure. - - if Canonical_File_Len = 0 then - return ""; - end if; - - declare - subtype Path_String is String (1 .. Canonical_File_Len); - Canonical_File : Path_String; - for Canonical_File'Address use Canonical_File_Addr; - pragma Import (Ada, Canonical_File); - - begin - Path_Buffer (1 .. Canonical_File_Len) := Canonical_File; - End_Path := Canonical_File_Len; - Last := 1; - end; - end File_Name_Conversion; - - -- Replace all '/' by Directory Separators (this is for Windows) - - if Directory_Separator /= '/' then - for Index in 1 .. End_Path loop - if Path_Buffer (Index) = '/' then - Path_Buffer (Index) := Directory_Separator; - end if; - end loop; - end if; - - -- Resolve directory names for Windows - - if On_Windows then - - -- On Windows, if we have an absolute path starting with a directory - -- separator, we need to have the drive letter appended in front. - - -- On Windows, Get_Current_Dir will return a suitable directory name - -- (path starting with a drive letter on Windows). So we take this - -- drive letter and prepend it to the current path. - - if Path_Buffer (1) = Directory_Separator - and then Path_Buffer (2) /= Directory_Separator - then - declare - Cur_Dir : constant String := Get_Directory (""); - -- Get the current directory to get the drive letter - - begin - if Cur_Dir'Length > 2 - and then Cur_Dir (Cur_Dir'First + 1) = ':' - then - Path_Buffer (3 .. End_Path + 2) := - Path_Buffer (1 .. End_Path); - Path_Buffer (1 .. 2) := - Cur_Dir (Cur_Dir'First .. Cur_Dir'First + 1); - End_Path := End_Path + 2; - end if; - end; - - -- We have a drive letter, ensure it is upper-case - - elsif Path_Buffer (1) in 'a' .. 'z' - and then Path_Buffer (2) = ':' - then - System.Case_Util.To_Upper (Path_Buffer (1 .. 1)); - end if; - end if; - - -- On Windows, remove all double-quotes that are possibly part of the - -- path but can cause problems with other methods. - - if On_Windows then - declare - Index : Natural; - - begin - Index := Path_Buffer'First; - for Current in Path_Buffer'First .. End_Path loop - if Path_Buffer (Current) /= '"' then - Path_Buffer (Index) := Path_Buffer (Current); - Index := Index + 1; - end if; - end loop; - - End_Path := Index - 1; - end; - end if; - - -- Start the conversions - - -- If this is not finished after Max_Iterations, give up and return an - -- empty string. - - for J in 1 .. Max_Iterations loop - - -- If we don't have an absolute pathname, prepend the directory - -- Reference_Dir. - - if Last = 1 - and then not Is_Absolute_Path (Path_Buffer (1 .. End_Path)) - then - declare - Reference_Dir : constant String := Get_Directory (Directory); - Ref_Dir_Len : constant Natural := Reference_Dir'Length; - -- Current directory name specified and its length - - begin - Path_Buffer (Ref_Dir_Len + 1 .. Ref_Dir_Len + End_Path) := - Path_Buffer (1 .. End_Path); - End_Path := Ref_Dir_Len + End_Path; - Path_Buffer (1 .. Ref_Dir_Len) := Reference_Dir; - Last := Ref_Dir_Len; - end; - end if; - - Start := Last + 1; - Finish := Last; - - -- Ensure that Windows network drives are kept, e.g: \\server\drive-c - - if Start = 2 - and then Directory_Separator = '\' - and then Path_Buffer (1 .. 2) = "\\" - then - Start := 3; - end if; - - -- If we have traversed the full pathname, return it - - if Start > End_Path then - return Final_Value (Path_Buffer (1 .. End_Path)); - end if; - - -- Remove duplicate directory separators - - while Path_Buffer (Start) = Directory_Separator loop - if Start = End_Path then - return Final_Value (Path_Buffer (1 .. End_Path - 1)); - - else - Path_Buffer (Start .. End_Path - 1) := - Path_Buffer (Start + 1 .. End_Path); - End_Path := End_Path - 1; - end if; - end loop; - - -- Find the end of the current field: last character or the one - -- preceding the next directory separator. - - while Finish < End_Path - and then Path_Buffer (Finish + 1) /= Directory_Separator - loop - Finish := Finish + 1; - end loop; - - -- Remove "." field - - if Start = Finish and then Path_Buffer (Start) = '.' then - if Start = End_Path then - if Last = 1 then - return (1 => Directory_Separator); - else - if Fold_To_Lower_Case then - System.Case_Util.To_Lower (Path_Buffer (1 .. Last - 1)); - end if; - - return Path_Buffer (1 .. Last - 1); - end if; - else - Path_Buffer (Last + 1 .. End_Path - 2) := - Path_Buffer (Last + 3 .. End_Path); - End_Path := End_Path - 2; - end if; - - -- Remove ".." fields - - elsif Finish = Start + 1 - and then Path_Buffer (Start .. Finish) = ".." - then - Start := Last; - loop - Start := Start - 1; - exit when Start < 1 - or else Path_Buffer (Start) = Directory_Separator; - end loop; - - if Start <= 1 then - if Finish = End_Path then - return (1 => Directory_Separator); - - else - Path_Buffer (1 .. End_Path - Finish) := - Path_Buffer (Finish + 1 .. End_Path); - End_Path := End_Path - Finish; - Last := 1; - end if; - - else - if Finish = End_Path then - return Final_Value (Path_Buffer (1 .. Start - 1)); - - else - Path_Buffer (Start + 1 .. Start + End_Path - Finish - 1) := - Path_Buffer (Finish + 2 .. End_Path); - End_Path := Start + End_Path - Finish - 1; - Last := Start; - end if; - end if; - - -- Check if current field is a symbolic link - - elsif Resolve_Links then - declare - Saved : constant Character := Path_Buffer (Finish + 1); - - begin - Path_Buffer (Finish + 1) := ASCII.NUL; - Status := - Readlink - (Path => Path_Buffer'Address, - Buf => Link_Buffer'Address, - Bufsiz => Link_Buffer'Length); - Path_Buffer (Finish + 1) := Saved; - end; - - -- Not a symbolic link, move to the next field, if any - - if Status <= 0 then - Last := Finish + 1; - - -- Replace symbolic link with its value - - else - if Is_Absolute_Path (Link_Buffer (1 .. Status)) then - Path_Buffer (Status + 1 .. End_Path - (Finish - Status)) := - Path_Buffer (Finish + 1 .. End_Path); - End_Path := End_Path - (Finish - Status); - Path_Buffer (1 .. Status) := Link_Buffer (1 .. Status); - Last := 1; - - else - Path_Buffer - (Last + Status + 1 .. End_Path - Finish + Last + Status) := - Path_Buffer (Finish + 1 .. End_Path); - End_Path := End_Path - Finish + Last + Status; - Path_Buffer (Last + 1 .. Last + Status) := - Link_Buffer (1 .. Status); - end if; - end if; - - else - Last := Finish + 1; - end if; - end loop; - - -- Too many iterations: give up - - -- This can happen when there is a circularity in the symbolic links: A - -- is a symbolic link for B, which itself is a symbolic link, and the - -- target of B or of another symbolic link target of B is A. In this - -- case, we return an empty string to indicate failure to resolve. - - return ""; - end Normalize_Pathname; - - ----------------- - -- Open_Append -- - ----------------- - - function Open_Append - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor - is - function C_Open_Append - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - pragma Import (C, C_Open_Append, "__gnat_open_append"); - begin - return C_Open_Append (Name, Fmode); - end Open_Append; - - function Open_Append - (Name : String; - Fmode : Mode) return File_Descriptor - is - C_Name : String (1 .. Name'Length + 1); - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return Open_Append (C_Name (C_Name'First)'Address, Fmode); - end Open_Append; - - --------------- - -- Open_Read -- - --------------- - - function Open_Read - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor - is - function C_Open_Read - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - pragma Import (C, C_Open_Read, "__gnat_open_read"); - begin - return C_Open_Read (Name, Fmode); - end Open_Read; - - function Open_Read - (Name : String; - Fmode : Mode) return File_Descriptor - is - C_Name : String (1 .. Name'Length + 1); - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return Open_Read (C_Name (C_Name'First)'Address, Fmode); - end Open_Read; - - --------------------- - -- Open_Read_Write -- - --------------------- - - function Open_Read_Write - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor - is - function C_Open_Read_Write - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - pragma Import (C, C_Open_Read_Write, "__gnat_open_rw"); - begin - return C_Open_Read_Write (Name, Fmode); - end Open_Read_Write; - - function Open_Read_Write - (Name : String; - Fmode : Mode) return File_Descriptor - is - C_Name : String (1 .. Name'Length + 1); - begin - C_Name (1 .. Name'Length) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - return Open_Read_Write (C_Name (C_Name'First)'Address, Fmode); - end Open_Read_Write; - - ------------- - -- OS_Exit -- - ------------- - - procedure OS_Exit (Status : Integer) is - begin - OS_Exit_Ptr (Status); - raise Program_Error; - end OS_Exit; - - --------------------- - -- OS_Exit_Default -- - --------------------- - - procedure OS_Exit_Default (Status : Integer) is - procedure GNAT_OS_Exit (Status : Integer); - pragma Import (C, GNAT_OS_Exit, "__gnat_os_exit"); - pragma No_Return (GNAT_OS_Exit); - begin - GNAT_OS_Exit (Status); - end OS_Exit_Default; - - -------------------- - -- Pid_To_Integer -- - -------------------- - - function Pid_To_Integer (Pid : Process_Id) return Integer is - begin - return Integer (Pid); - end Pid_To_Integer; - - ---------- - -- Read -- - ---------- - - function Read - (FD : File_Descriptor; - A : System.Address; - N : Integer) return Integer - is - begin - return - Integer (System.CRTL.read - (System.CRTL.int (FD), - System.CRTL.chars (A), - System.CRTL.size_t (N))); - end Read; - - ----------------- - -- Rename_File -- - ----------------- - - procedure Rename_File - (Old_Name : C_File_Name; - New_Name : C_File_Name; - Success : out Boolean) - is - function rename (From, To : Address) return Integer; - pragma Import (C, rename, "__gnat_rename"); - R : Integer; - - begin - R := rename (Old_Name, New_Name); - Success := (R = 0); - end Rename_File; - - procedure Rename_File - (Old_Name : String; - New_Name : String; - Success : out Boolean) - is - C_Old_Name : String (1 .. Old_Name'Length + 1); - C_New_Name : String (1 .. New_Name'Length + 1); - - begin - C_Old_Name (1 .. Old_Name'Length) := Old_Name; - C_Old_Name (C_Old_Name'Last) := ASCII.NUL; - C_New_Name (1 .. New_Name'Length) := New_Name; - C_New_Name (C_New_Name'Last) := ASCII.NUL; - Rename_File (C_Old_Name'Address, C_New_Name'Address, Success); - end Rename_File; - - ----------------------- - -- Set_Close_On_Exec -- - ----------------------- - - procedure Set_Close_On_Exec - (FD : File_Descriptor; - Close_On_Exec : Boolean; - Status : out Boolean) - is - function C_Set_Close_On_Exec - (FD : File_Descriptor; Close_On_Exec : System.CRTL.int) - return System.CRTL.int; - pragma Import (C, C_Set_Close_On_Exec, "__gnat_set_close_on_exec"); - begin - Status := C_Set_Close_On_Exec (FD, Boolean'Pos (Close_On_Exec)) = 0; - end Set_Close_On_Exec; - - -------------------- - -- Set_Executable -- - -------------------- - - procedure Set_Executable (Name : String; Mode : Positive := S_Owner) is - procedure C_Set_Executable (Name : C_File_Name; Mode : Integer); - pragma Import (C, C_Set_Executable, "__gnat_set_executable"); - C_Name : aliased String (Name'First .. Name'Last + 1); - - begin - C_Name (Name'Range) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - C_Set_Executable (C_Name (C_Name'First)'Address, Mode); - end Set_Executable; - - ------------------------------------- - -- Set_File_Last_Modify_Time_Stamp -- - ------------------------------------- - - procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time) is - procedure C_Set_File_Time (Name : C_File_Name; Time : OS_Time); - pragma Import (C, C_Set_File_Time, "__gnat_set_file_time_name"); - C_Name : aliased String (Name'First .. Name'Last + 1); - - begin - C_Name (Name'Range) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - C_Set_File_Time (C_Name'Address, Time); - end Set_File_Last_Modify_Time_Stamp; - - ---------------------- - -- Set_Non_Readable -- - ---------------------- - - procedure Set_Non_Readable (Name : String) is - procedure C_Set_Non_Readable (Name : C_File_Name); - pragma Import (C, C_Set_Non_Readable, "__gnat_set_non_readable"); - C_Name : aliased String (Name'First .. Name'Last + 1); - - begin - C_Name (Name'Range) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - C_Set_Non_Readable (C_Name (C_Name'First)'Address); - end Set_Non_Readable; - - ---------------------- - -- Set_Non_Writable -- - ---------------------- - - procedure Set_Non_Writable (Name : String) is - procedure C_Set_Non_Writable (Name : C_File_Name); - pragma Import (C, C_Set_Non_Writable, "__gnat_set_non_writable"); - C_Name : aliased String (Name'First .. Name'Last + 1); - - begin - C_Name (Name'Range) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - C_Set_Non_Writable (C_Name (C_Name'First)'Address); - end Set_Non_Writable; - - ------------------ - -- Set_Readable -- - ------------------ - - procedure Set_Readable (Name : String) is - procedure C_Set_Readable (Name : C_File_Name); - pragma Import (C, C_Set_Readable, "__gnat_set_readable"); - C_Name : aliased String (Name'First .. Name'Last + 1); - - begin - C_Name (Name'Range) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - C_Set_Readable (C_Name (C_Name'First)'Address); - end Set_Readable; - - -------------------- - -- Set_Writable -- - -------------------- - - procedure Set_Writable (Name : String) is - procedure C_Set_Writable (Name : C_File_Name); - pragma Import (C, C_Set_Writable, "__gnat_set_writable"); - C_Name : aliased String (Name'First .. Name'Last + 1); - - begin - C_Name (Name'Range) := Name; - C_Name (C_Name'Last) := ASCII.NUL; - C_Set_Writable (C_Name (C_Name'First)'Address); - end Set_Writable; - - ------------ - -- Setenv -- - ------------ - - procedure Setenv (Name : String; Value : String) is - F_Name : String (1 .. Name'Length + 1); - F_Value : String (1 .. Value'Length + 1); - - procedure Set_Env_Value (Name, Value : System.Address); - pragma Import (C, Set_Env_Value, "__gnat_setenv"); - - begin - F_Name (1 .. Name'Length) := Name; - F_Name (F_Name'Last) := ASCII.NUL; - - F_Value (1 .. Value'Length) := Value; - F_Value (F_Value'Last) := ASCII.NUL; - - Set_Env_Value (F_Name'Address, F_Value'Address); - end Setenv; - - ----------- - -- Spawn -- - ----------- - - function Spawn - (Program_Name : String; - Args : Argument_List) return Integer - is - Junk : Process_Id; - pragma Warnings (Off, Junk); - Result : Integer; - - begin - Spawn_Internal (Program_Name, Args, Result, Junk, Blocking => True); - return Result; - end Spawn; - - procedure Spawn - (Program_Name : String; - Args : Argument_List; - Success : out Boolean) - is - begin - Success := (Spawn (Program_Name, Args) = 0); - end Spawn; - - procedure Spawn - (Program_Name : String; - Args : Argument_List; - Output_File_Descriptor : File_Descriptor; - Return_Code : out Integer; - Err_To_Out : Boolean := True) - is - Saved_Error : File_Descriptor := Invalid_FD; -- prevent compiler warning - Saved_Output : File_Descriptor; - - begin - -- Set standard output and error to the temporary file - - Saved_Output := Dup (Standout); - Dup2 (Output_File_Descriptor, Standout); - - if Err_To_Out then - Saved_Error := Dup (Standerr); - Dup2 (Output_File_Descriptor, Standerr); - end if; - - -- Spawn the program - - Return_Code := Spawn (Program_Name, Args); - - -- Restore the standard output and error - - Dup2 (Saved_Output, Standout); - - if Err_To_Out then - Dup2 (Saved_Error, Standerr); - end if; - - -- And close the saved standard output and error file descriptors - - Close (Saved_Output); - - if Err_To_Out then - Close (Saved_Error); - end if; - end Spawn; - - procedure Spawn - (Program_Name : String; - Args : Argument_List; - Output_File : String; - Success : out Boolean; - Return_Code : out Integer; - Err_To_Out : Boolean := True) - is - FD : File_Descriptor; - - begin - Success := True; - Return_Code := 0; - - FD := Create_Output_Text_File (Output_File); - - if FD = Invalid_FD then - Success := False; - return; - end if; - - Spawn (Program_Name, Args, FD, Return_Code, Err_To_Out); - - Close (FD, Success); - end Spawn; - - -------------------- - -- Spawn_Internal -- - -------------------- - - procedure Spawn_Internal - (Program_Name : String; - Args : Argument_List; - Result : out Integer; - Pid : out Process_Id; - Blocking : Boolean) - is - procedure Spawn (Args : Argument_List); - -- Call Spawn with given argument list - - N_Args : Argument_List (Args'Range); - -- Normalized arguments - - ----------- - -- Spawn -- - ----------- - - procedure Spawn (Args : Argument_List) is - type Chars is array (Positive range <>) of aliased Character; - type Char_Ptr is access constant Character; - - Command_Len : constant Positive := - Program_Name'Length + 1 + Args_Length (Args); - Command_Last : Natural := 0; - Command : aliased Chars (1 .. Command_Len); - -- Command contains all characters of the Program_Name and Args, all - -- terminated by ASCII.NUL characters. - - Arg_List_Len : constant Positive := Args'Length + 2; - Arg_List_Last : Natural := 0; - Arg_List : aliased array (1 .. Arg_List_Len) of Char_Ptr; - -- List with pointers to NUL-terminated strings of the Program_Name - -- and the Args and terminated with a null pointer. We rely on the - -- default initialization for the last null pointer. - - procedure Add_To_Command (S : String); - -- Add S and a NUL character to Command, updating Last - - function Portable_Spawn (Args : Address) return Integer; - pragma Import (C, Portable_Spawn, "__gnat_portable_spawn"); - - function Portable_No_Block_Spawn (Args : Address) return Process_Id; - pragma Import - (C, Portable_No_Block_Spawn, "__gnat_portable_no_block_spawn"); - - -------------------- - -- Add_To_Command -- - -------------------- - - procedure Add_To_Command (S : String) is - First : constant Natural := Command_Last + 1; - - begin - Command_Last := Command_Last + S'Length; - - -- Move characters one at a time, because Command has aliased - -- components. - - -- But not volatile, so why is this necessary ??? - - for J in S'Range loop - Command (First + J - S'First) := S (J); - end loop; - - Command_Last := Command_Last + 1; - Command (Command_Last) := ASCII.NUL; - - Arg_List_Last := Arg_List_Last + 1; - Arg_List (Arg_List_Last) := Command (First)'Access; - end Add_To_Command; - - -- Start of processing for Spawn - - begin - Add_To_Command (Program_Name); - - for J in Args'Range loop - Add_To_Command (Args (J).all); - end loop; - - if Blocking then - Pid := Invalid_Pid; - Result := Portable_Spawn (Arg_List'Address); - else - Pid := Portable_No_Block_Spawn (Arg_List'Address); - Result := Boolean'Pos (Pid /= Invalid_Pid); - end if; - end Spawn; - - -- Start of processing for Spawn_Internal - - begin - -- Copy arguments into a local structure - - for K in N_Args'Range loop - N_Args (K) := new String'(Args (K).all); - end loop; - - -- Normalize those arguments - - Normalize_Arguments (N_Args); - - -- Call spawn using the normalized arguments - - Spawn (N_Args); - - -- Free arguments list - - for K in N_Args'Range loop - Free (N_Args (K)); - end loop; - end Spawn_Internal; - - --------------------------- - -- To_Path_String_Access -- - --------------------------- - - function To_Path_String_Access - (Path_Addr : Address; - Path_Len : Integer) return String_Access - is - subtype Path_String is String (1 .. Path_Len); - type Path_String_Access is access Path_String; - - function Address_To_Access is new Ada.Unchecked_Conversion - (Source => Address, Target => Path_String_Access); - - Path_Access : constant Path_String_Access := - Address_To_Access (Path_Addr); - - Return_Val : String_Access; - - begin - Return_Val := new String (1 .. Path_Len); - - for J in 1 .. Path_Len loop - Return_Val (J) := Path_Access (J); - end loop; - - return Return_Val; - end To_Path_String_Access; - - ------------------ - -- Wait_Process -- - ------------------ - - procedure Wait_Process (Pid : out Process_Id; Success : out Boolean) is - Status : Integer; - - function Portable_Wait (S : Address) return Process_Id; - pragma Import (C, Portable_Wait, "__gnat_portable_wait"); - - begin - Pid := Portable_Wait (Status'Address); - Success := (Status = 0); - end Wait_Process; - - ----------- - -- Write -- - ----------- - - function Write - (FD : File_Descriptor; - A : System.Address; - N : Integer) return Integer - is - begin - return - Integer (System.CRTL.write - (System.CRTL.int (FD), - System.CRTL.chars (A), - System.CRTL.size_t (N))); - end Write; - -end System.OS_Lib; diff --git a/gcc/ada/s-os_lib.ads b/gcc/ada/s-os_lib.ads deleted file mode 100644 index 5fba00a..0000000 --- a/gcc/ada/s-os_lib.ads +++ /dev/null @@ -1,1111 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . O S _ L I B -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Operating system interface facilities - --- This package contains types and procedures for interfacing to the --- underlying OS. It is used by the GNAT compiler and by tools associated --- with the GNAT compiler, and therefore works for the various operating --- systems to which GNAT has been ported. This package will undoubtedly grow --- as new services are needed by various tools. - --- This package tends to use fairly low-level Ada in order to not bring in --- large portions of the RTL. For example, functions return access to string --- as part of avoiding functions returning unconstrained types. - --- Except where specifically noted, these routines are portable across all --- GNAT implementations on all supported operating systems. - --- Note: this package is in the System hierarchy so that it can be directly --- be used by other predefined packages. User access to this package is via --- a renaming of this package in GNAT.OS_Lib (file g-os_lib.ads). - -pragma Compiler_Unit_Warning; - -with System; -with System.Strings; - -package System.OS_Lib is - pragma Preelaborate; - - ----------------------- - -- String Operations -- - ----------------------- - - -- These are reexported from package Strings (which was introduced to - -- avoid different packages declaring different types unnecessarily). - -- See package System.Strings for details. - - subtype String_Access is Strings.String_Access; - - function "=" (Left : String_Access; Right : String_Access) return Boolean - renames Strings."="; - - procedure Free (X : in out String_Access) renames Strings.Free; - - subtype String_List is Strings.String_List; - - function "=" (Left : String_List; Right : String_List) return Boolean - renames Strings."="; - - function "&" (Left : String_Access; Right : String_Access) - return String_List renames Strings."&"; - function "&" (Left : String_Access; Right : String_List) - return String_List renames Strings."&"; - function "&" (Left : String_List; Right : String_Access) - return String_List renames Strings."&"; - function "&" (Left : String_List; Right : String_List) - return String_List renames Strings."&"; - - subtype String_List_Access is Strings.String_List_Access; - - function "=" - (Left : String_List_Access; - Right : String_List_Access) return Boolean renames Strings."="; - - procedure Free (Arg : in out String_List_Access) renames Strings.Free; - - --------------------- - -- Time/Date Stuff -- - --------------------- - - type OS_Time is private; - -- The OS's notion of time is represented by the private type OS_Time. This - -- is the type returned by the File_Time_Stamp functions to obtain the time - -- stamp of a specified file. Functions and a procedure (modeled after the - -- similar subprograms in package Calendar) are provided for extracting - -- information from a value of this type. Although these are called GM, the - -- intention in the case of time stamps is not that they provide GMT times - -- in all cases but rather the actual (time-zone independent) time stamp of - -- the file (of course in Unix systems, this *is* in GMT form). - - Invalid_Time : constant OS_Time; - -- A special unique value used to flag an invalid time stamp value - - function "<" (X : OS_Time; Y : OS_Time) return Boolean; - function ">" (X : OS_Time; Y : OS_Time) return Boolean; - function ">=" (X : OS_Time; Y : OS_Time) return Boolean; - function "<=" (X : OS_Time; Y : OS_Time) return Boolean; - -- Basic comparison operators on OS_Time with obvious meanings. Note that - -- these have Intrinsic convention, so for example it is not permissible - -- to create accesses to any of these functions. - - subtype Year_Type is Integer range 1900 .. 2099; - subtype Month_Type is Integer range 1 .. 12; - subtype Day_Type is Integer range 1 .. 31; - subtype Hour_Type is Integer range 0 .. 23; - subtype Minute_Type is Integer range 0 .. 59; - subtype Second_Type is Integer range 0 .. 59; - -- Declarations similar to those in Calendar, breaking down the time - - function Current_Time return OS_Time; - -- Return the system clock value as OS_Time - - function Current_Time_String return String; - -- Returns current local time in the form YYYY-MM-DD HH:MM:SS. The result - -- has bounds 1 .. 19. - - function GM_Year (Date : OS_Time) return Year_Type; - function GM_Month (Date : OS_Time) return Month_Type; - function GM_Day (Date : OS_Time) return Day_Type; - function GM_Hour (Date : OS_Time) return Hour_Type; - function GM_Minute (Date : OS_Time) return Minute_Type; - function GM_Second (Date : OS_Time) return Second_Type; - -- Functions to extract information from OS_Time value in GMT form - - procedure GM_Split - (Date : OS_Time; - Year : out Year_Type; - Month : out Month_Type; - Day : out Day_Type; - Hour : out Hour_Type; - Minute : out Minute_Type; - Second : out Second_Type); - -- Analogous to the Split routine in Ada.Calendar, takes an OS_Time and - -- provides a representation of it as a set of component parts, to be - -- interpreted as a date point in UTC. - - function GM_Time_Of - (Year : Year_Type; - Month : Month_Type; - Day : Day_Type; - Hour : Hour_Type; - Minute : Minute_Type; - Second : Second_Type) return OS_Time; - -- Analogous to the Time_Of routine in Ada.Calendar, takes a set of time - -- component parts to be interpreted in the local time zone, and returns - -- an OS_Time. Returns Invalid_Time if the creation fails. - - ---------------- - -- File Stuff -- - ---------------- - - -- These routines give access to the open/creat/close/read/write level of - -- I/O routines in the typical C library (these functions are not part of - -- the ANSI C standard, but are typically available in all systems). See - -- also package Interfaces.C_Streams for access to the stream level - -- routines. - - -- Note on file names. If a file name is passed as type String in any of - -- the following specifications, then the name is a normal Ada string and - -- need not be NUL-terminated. However, a trailing NUL character is - -- permitted, and will be ignored (more accurately, the NUL and any - -- characters that follow it will be ignored). - - type File_Descriptor is new Integer; - -- Corresponds to the int file handle values used in the C routines - - Standin : constant File_Descriptor := 0; - Standout : constant File_Descriptor := 1; - Standerr : constant File_Descriptor := 2; - -- File descriptors for standard input output files - - Invalid_FD : constant File_Descriptor := -1; - -- File descriptor returned when error in opening/creating file - - procedure Close (FD : File_Descriptor; Status : out Boolean); - -- Close file referenced by FD. Status is False if the underlying service - -- failed. Reasons for failure include: disk full, disk quotas exceeded - -- and invalid file descriptor (the file may have been closed twice). - - procedure Close (FD : File_Descriptor); - -- Close file referenced by FD. This form is used when the caller wants to - -- ignore any possible error (see above for error cases). - - type Copy_Mode is - (Copy, - -- Copy the file. It is an error if the target file already exists. The - -- time stamps and other file attributes are preserved in the copy. - - Overwrite, - -- If the target file exists, the file is replaced otherwise the file - -- is just copied. The time stamps and other file attributes are - -- preserved in the copy. - - Append); - -- If the target file exists, the contents of the source file is - -- appended at the end. Otherwise the source file is just copied. The - -- time stamps and other file attributes are preserved if the - -- destination file does not exist. - - type Attribute is - (Time_Stamps, - -- Copy time stamps from source file to target file. All other - -- attributes are set to normal default values for file creation. - - Full, - -- All attributes are copied from the source file to the target file. - -- This includes the timestamps, and for example also includes - -- read/write/execute attributes in Unix systems. - - None); - -- No attributes are copied. All attributes including the time stamp - -- values are set to normal default values for file creation. - - -- Note: The default is Time_Stamps, which corresponds to the normal - -- default on Windows style systems. Full corresponds to the typical - -- effect of "cp -p" on Unix systems, and None corresponds to the typical - -- effect of "cp" on Unix systems. - - -- Note: Time_Stamps and Full are not supported on VxWorks 5 - - procedure Copy_File - (Name : String; - Pathname : String; - Success : out Boolean; - Mode : Copy_Mode := Copy; - Preserve : Attribute := Time_Stamps); - -- Copy a file. Name must designate a single file (no wild cards allowed). - -- Pathname can be a filename or directory name. In the latter case Name - -- is copied into the directory preserving the same file name. Mode - -- defines the kind of copy, see above with the default being a normal - -- copy in which the target file must not already exist. Success is set to - -- True or False indicating if the copy is successful (depending on the - -- specified Mode). - - procedure Copy_File_Attributes - (From : String; - To : String; - Success : out Boolean; - Copy_Timestamp : Boolean := True; - Copy_Permissions : Boolean := True); - -- Copy some of the file attributes from one file to another. Both files - -- must exist, or Success is set to False. - - procedure Copy_Time_Stamps - (Source : String; - Dest : String; - Success : out Boolean); - -- Copy Source file time stamps (last modification and last access time - -- stamps) to Dest file. Source and Dest must be valid filenames, - -- furthermore Dest must be writable. Success will be set to True if the - -- operation was successful and False otherwise. - -- - -- Note: this procedure is not supported on VxWorks 5. On this platform, - -- Success is always set to False. - - type Mode is (Binary, Text); - for Mode'Size use Integer'Size; - for Mode use (Binary => 0, Text => 1); - -- Used in all the Open and Create calls to specify if the file is to be - -- opened in binary mode or text mode. In systems like Unix, this has no - -- effect, but in systems capable of text mode translation, the use of - -- Text as the mode parameter causes the system to do CR/LF translation - -- and also to recognize the DOS end of file character on input. The use - -- of Text where appropriate allows programs to take a portable Unix view - -- of DOS-format files and process them appropriately. - - function Create_File - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Creates new file with given name for writing, returning file descriptor - -- for subsequent use in Write calls. If the file already exists, it is - -- overwritten. File descriptor returned is Invalid_FD if file cannot be - -- successfully created. - - function Create_New_File - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Create new file with given name for writing, returning file descriptor - -- for subsequent use in Write calls. This differs from Create_File in - -- that it fails if the file already exists. File descriptor returned is - -- Invalid_FD if the file exists or cannot be created. - - function Create_Output_Text_File (Name : String) return File_Descriptor; - -- Creates new text file with given name suitable to redirect standard - -- output, returning file descriptor. File descriptor returned is - -- Invalid_FD if file cannot be successfully created. - - Temp_File_Len : constant Integer := 12; - -- Length of name returned by Create_Temp_File call (GNAT-XXXXXX & NUL) - - subtype Temp_File_Name is String (1 .. Temp_File_Len); - -- String subtype set by Create_Temp_File - - procedure Create_Temp_File - (FD : out File_Descriptor; - Name : out Temp_File_Name); - -- Create and open for writing a temporary file in the current working - -- directory. The name of the file and the File Descriptor are returned. - -- The File Descriptor returned is Invalid_FD in the case of failure. No - -- mode parameter is provided. Since this is a temporary file, there is no - -- point in doing text translation on it. - -- - -- On some operating systems, the maximum number of temp files that can be - -- created with this procedure may be limited. When the maximum is reached, - -- this procedure returns Invalid_FD. On some operating systems, there may - -- be a race condition between processes trying to create temp files at the - -- same time in the same directory using this procedure. - - procedure Create_Temp_File - (FD : out File_Descriptor; - Name : out String_Access); - -- Create and open for writing a temporary file in the current working - -- directory. The name of the file and the File Descriptor are returned. - -- It is the responsibility of the caller to deallocate the access value - -- returned in Name. - -- - -- The file is opened in binary mode (no text translation). - -- - -- This procedure will always succeed if the current working directory is - -- writable. If the current working directory is not writable, then - -- Invalid_FD is returned for the file descriptor and null for the Name. - -- There is no race condition problem between processes trying to create - -- temp files at the same time in the same directory. - - procedure Create_Temp_Output_File - (FD : out File_Descriptor; - Name : out String_Access); - -- Create and open for writing a temporary file in the current working - -- directory suitable to redirect standard output. The name of the file and - -- the File Descriptor are returned. It is the responsibility of the caller - -- to deallocate the access value returned in Name. - -- - -- The file is opened in text mode - -- - -- This procedure will always succeed if the current working directory is - -- writable. If the current working directory is not writable, then - -- Invalid_FD is returned for the file descriptor and null for the Name. - -- There is no race condition problem between processes trying to create - -- temp files at the same time in the same directory. - - procedure Delete_File (Name : String; Success : out Boolean); - -- Deletes file. Success is set True or False indicating if the delete is - -- successful. - - function File_Length (FD : File_Descriptor) return Long_Integer; - pragma Import (C, File_Length, "__gnat_file_length_long"); - - type Large_File_Size is range -2**63 .. 2**63 - 1; - -- Maximum supported size for a file (8 exabytes = 8 million terabytes, - -- should be enough to accommodate all possible needs for quite a while). - - function File_Length64 (FD : File_Descriptor) return Large_File_Size; - pragma Import (C, File_Length64, "__gnat_file_length"); - -- Get length of file from file descriptor FD - - function File_Time_Stamp (Name : String) return OS_Time; - -- Given the name of a file or directory, Name, obtains and returns the - -- time stamp. This function can be used for an unopened file. Returns - -- Invalid_Time if Name doesn't correspond to an existing file. - - function File_Time_Stamp (FD : File_Descriptor) return OS_Time; - -- Get time stamp of file from file descriptor FD Returns Invalid_Time is - -- FD doesn't correspond to an existing file. - - function Get_Debuggable_Suffix return String_Access; - -- Return the debuggable suffix convention. Usually this is the same as - -- the convention for Get_Executable_Suffix. The result is allocated on - -- the heap and should be freed after use to avoid storage leaks. - - function Get_Executable_Suffix return String_Access; - -- Return the executable suffix convention. The result is allocated on the - -- heap and should be freed after use to avoid storage leaks. - - function Get_Object_Suffix return String_Access; - -- Return the object suffix convention. The result is allocated on the heap - -- and should be freed after use to avoid storage leaks. - - function Get_Target_Debuggable_Suffix return String_Access; - -- Return the target debuggable suffix convention. Usually this is the same - -- as the convention for Get_Executable_Suffix. The result is allocated on - -- the heap and should be freed after use to avoid storage leaks. - - function Get_Target_Executable_Suffix return String_Access; - -- Return the target executable suffix convention. The result is allocated - -- on the heap and should be freed after use to avoid storage leaks. - - function Get_Target_Object_Suffix return String_Access; - -- Return the target object suffix convention. The result is allocated on - -- the heap and should be freed after use to avoid storage leaks. - - function Is_Absolute_Path (Name : String) return Boolean; - -- Returns True if Name is an absolute path name, i.e. it designates a - -- file or directory absolutely rather than relative to another directory. - - function Is_Directory (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of a directory. - -- Returns True if so, False otherwise. Name may be an absolute path - -- name or a relative path name, including a simple file name. If it is - -- a relative path name, it is relative to the current working directory. - - function Is_Executable_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is executable. Returns True if so, False otherwise. Note that this - -- function simply interrogates the file attributes (e.g. using the C - -- function stat), so it does not indicate a situation in which a file may - -- not actually be readable due to some other process having exclusive - -- access. - - function Is_Owner_Readable_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is readable. Returns True if so, False otherwise. Note that this - -- function simply interrogates the file attributes (e.g. using the C - -- function stat), so it does not indicate a situation in which a file may - -- not actually be readable due to some other process having exclusive - -- access. - - function Is_Regular_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing - -- regular file. Returns True if so, False otherwise. Name may be an - -- absolute path name or a relative path name, including a simple file - -- name. If it is a relative path name, it is relative to the current - -- working directory. - - function Is_Symbolic_Link (Name : String) return Boolean; - -- Determines if the given string, Name, is the path of a symbolic link on - -- systems that support it. Returns True if so, False if the path is not a - -- symbolic link or if the system does not support symbolic links. - -- - -- A symbolic link is an indirect pointer to a file; its directory entry - -- contains the name of the file to which it is linked. Symbolic links may - -- span file systems and may refer to directories. - - function Is_Owner_Writable_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is writable. Returns True if so, False otherwise. Note that this - -- function simply interrogates the file attributes (e.g. using the C - -- function stat), so it does not indicate a situation in which a file may - -- not actually be writable due to some other process having exclusive - -- access. - - function Is_Read_Accessible_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is readable. Returns True if so, False otherwise. - - function Is_Write_Accessible_File (Name : String) return Boolean; - -- Determines if the given string, Name, is the name of an existing file - -- that is writable. Returns True if so, False otherwise. - - function Is_Readable_File (Name : String) return Boolean - renames Is_Read_Accessible_File; - function Is_Writable_File (Name : String) return Boolean - renames Is_Write_Accessible_File; - -- These subprograms provided for backward compatibility and should not be - -- used. Use Is_Owner_Readable_File/Is_Owner_Writable_File or - -- Is_Read_Accessible_File/Is_Write_Accessible_File instead. - - function Locate_Exec_On_Path (Exec_Name : String) return String_Access; - -- Try to locate an executable whose name is given by Exec_Name in the - -- directories listed in the environment Path. If the Exec_Name does not - -- have the executable suffix, it will be appended before the search. - -- Otherwise works like Locate_Regular_File below. If the executable is - -- not found, null is returned. - -- - -- Note that this function allocates memory for the returned value. This - -- memory needs to be deallocated after use. - - function Locate_Regular_File - (File_Name : String; - Path : String) return String_Access; - -- Try to locate a regular file whose name is given by File_Name in the - -- directories listed in Path. If a file is found, its full pathname is - -- returned; otherwise, a null pointer is returned. If the File_Name given - -- is an absolute pathname, then Locate_Regular_File just checks that the - -- file exists and is a regular file. Otherwise, if the File_Name given - -- includes directory information, Locate_Regular_File first checks if the - -- file exists relative to the current directory. If it does not, or if - -- the File_Name given is a simple file name, the Path argument is parsed - -- according to OS conventions, and for each directory in the Path a check - -- is made if File_Name is a relative pathname of a regular file from that - -- directory. - -- - -- Note that this function allocates some memory for the returned value. - -- This memory needs to be deallocated after use. - - Seek_Cur : constant := 1; - Seek_End : constant := 2; - Seek_Set : constant := 0; - -- Used to indicate origin for Lseek call - - procedure Lseek - (FD : File_Descriptor; - offset : Long_Integer; - origin : Integer); - pragma Import (C, Lseek, "__gnat_lseek"); - -- Sets the current file pointer to the indicated offset value, relative - -- to the current position (origin = SEEK_CUR), end of file (origin = - -- SEEK_END), or start of file (origin = SEEK_SET). - - function Normalize_Pathname - (Name : String; - Directory : String := ""; - Resolve_Links : Boolean := True; - Case_Sensitive : Boolean := True) return String; - -- Returns a file name as an absolute path name, resolving all relative - -- directories, and symbolic links. If Name is a relative path, it is - -- interpreted relative to Directory, or to the current directory if - -- Directory is the empty string (the default). The result returned is - -- the normalized name of the file, containing no "." or ".." components, - -- and no duplicated directory separators. For most cases, if two file - -- names designate the same file through different paths, - -- Normalize_Pathname will return the same canonical name in both cases. - -- However, there are cases when this is not true; for example, this is - -- not true in Unix for two hard links designating the same file. - -- - -- On Windows, the returned path will start with a drive letter. If - -- Directory is empty (the default) and Name is a relative path or an - -- absolute path without drive letter, the letter of the current drive - -- will start the returned path. If Case_Sensitive is True (the default), - -- then this drive letter will be forced to upper case ("C:\..."). - -- - -- If Resolve_Links is set to True, then the symbolic links, on systems - -- that support them, will be fully converted to the name of the file or - -- directory pointed to. This is slightly less efficient, since it - -- requires system calls. - -- - -- If Name cannot be resolved, is invalid (for example if it is too big) or - -- is null on entry (for example if there is symbolic link circularity, - -- e.g. A is a symbolic link for B, and B is a symbolic link for A), then - -- Normalize_Pathname returns an empty string. - -- - -- For case-sensitive file systems, the value of Case_Sensitive parameter - -- is ignored. For file systems that are not case-sensitive, such as - -- Windows, if this parameter is set to False, then the file and directory - -- names are folded to lower case. This allows checking whether two files - -- are the same by applying this function to their names and comparing the - -- results. If Case_Sensitive is set to True, this function does not change - -- the casing of file and directory names. - - function Open_Append - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Opens file Name for appending, returning its file descriptor. File - -- descriptor returned is Invalid_FD if the file cannot be successfully - -- opened. - - function Open_Read - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Open file Name for reading, returning its file descriptor. File - -- descriptor returned is Invalid_FD if the file cannot be opened. - - function Open_Read_Write - (Name : String; - Fmode : Mode) return File_Descriptor; - -- Open file Name for both reading and writing, returning its file - -- descriptor. File descriptor returned is Invalid_FD if the file - -- cannot be opened. - - function Read - (FD : File_Descriptor; - A : System.Address; - N : Integer) return Integer; - -- Read N bytes to address A from file referenced by FD. Returned value is - -- count of bytes actually read, which can be less than N at EOF. - - procedure Rename_File - (Old_Name : String; - New_Name : String; - Success : out Boolean); - -- Rename a file. Success is set True or False indicating if the rename is - -- successful or not. - -- - -- WARNING: In one very important respect, this function is significantly - -- non-portable. If New_Name already exists then on Unix systems, the call - -- deletes the existing file, and the call signals success. On Windows, the - -- call fails, without doing the rename operation. See also the procedure - -- Ada.Directories.Rename, which portably provides the windows semantics, - -- i.e. fails if the output file already exists. - - -- The following defines the mode for the Copy_File procedure below. Note - -- that "time stamps and other file attributes" in the descriptions below - -- refers to the creation and last modification times, and also the file - -- access (read/write/execute) status flags. - - procedure Set_Close_On_Exec - (FD : File_Descriptor; - Close_On_Exec : Boolean; - Status : out Boolean); - -- When Close_On_Exec is True, mark FD to be closed automatically when new - -- program is executed by the calling process (i.e. prevent FD from being - -- inherited by child processes). When Close_On_Exec is False, mark FD to - -- not be closed on exec (i.e. allow it to be inherited). Status is False - -- if the operation could not be performed. - - S_Owner : constant := 1; - S_Group : constant := 2; - S_Others : constant := 4; - -- Constants for use in Mode parameter to Set_Executable - - procedure Set_Executable (Name : String; Mode : Positive := S_Owner); - -- Change permissions on the file given by Name to make it executable - -- for its owner, group or others, according to the setting of Mode. - -- As indicated, the default if no Mode parameter is given is owner. - - procedure Set_File_Last_Modify_Time_Stamp (Name : String; Time : OS_Time); - -- Given the name of a file or directory, Name, set the last modification - -- time stamp. This function must be used for an unopened file. - - procedure Set_Non_Readable (Name : String); - -- Change permissions on the named file to make it non-readable for - -- its owner. The writable and executable permissions are not - -- modified. - - procedure Set_Non_Writable (Name : String); - -- Change permissions on the named file to make it non-writable for its - -- owner. The readable and executable permissions are not modified. - - procedure Set_Read_Only (Name : String) renames Set_Non_Writable; - -- This renaming is provided for backwards compatibility with previous - -- versions. The use of Set_Non_Writable is preferred (clearer name). - - procedure Set_Readable (Name : String); - -- Change permissions on the named file to make it readable for its - -- owner. - - procedure Set_Writable (Name : String); - -- Change permissions on the named file to make it writable for its owner - - function Write - (FD : File_Descriptor; - A : System.Address; - N : Integer) return Integer; - -- Write N bytes from address A to file referenced by FD. The returned - -- value is the number of bytes written, which can be less than N if a - -- disk full condition was detected. - - -- The following section contains low-level routines using addresses to - -- pass file name and executable name. In each routine the name must be - -- Nul-Terminated. For complete documentation refer to the equivalent - -- routine (using String in place of C_File_Name) defined above. - - subtype C_File_Name is System.Address; - -- This subtype is used to document that a parameter is the address of a - -- null-terminated string containing the name of a file. - - procedure Copy_File - (Name : C_File_Name; - Pathname : C_File_Name; - Success : out Boolean; - Mode : Copy_Mode := Copy; - Preserve : Attribute := Time_Stamps); - - procedure Copy_Time_Stamps - (Source : C_File_Name; - Dest : C_File_Name; - Success : out Boolean); - - function Create_File - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - - function Create_New_File - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - - procedure Delete_File (Name : C_File_Name; Success : out Boolean); - - function File_Time_Stamp (Name : C_File_Name) return OS_Time; - - function Is_Directory (Name : C_File_Name) return Boolean; - function Is_Executable_File (Name : C_File_Name) return Boolean; - function Is_Owner_Readable_File (Name : C_File_Name) return Boolean; - function Is_Regular_File (Name : C_File_Name) return Boolean; - function Is_Symbolic_Link (Name : C_File_Name) return Boolean; - function Is_Owner_Writable_File (Name : C_File_Name) return Boolean; - - function Locate_Regular_File - (File_Name : C_File_Name; - Path : C_File_Name) return String_Access; - - function Open_Append - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - - function Open_Read - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - - function Open_Read_Write - (Name : C_File_Name; - Fmode : Mode) return File_Descriptor; - - procedure Rename_File - (Old_Name : C_File_Name; - New_Name : C_File_Name; - Success : out Boolean); - - ------------------ - -- Subprocesses -- - ------------------ - - subtype Argument_List is String_List; - -- Type used for argument list in call to Spawn. The lower bound of the - -- array should be 1, and the length of the array indicates the number of - -- arguments. - - subtype Argument_List_Access is String_List_Access; - -- Type used to return Argument_List without dragging in secondary stack. - -- Note that there is a Free procedure declared for this subtype which - -- frees the array and all referenced strings. - - type Process_Id is private; - -- A private type used to identify a process activated by the following - -- non-blocking calls. The only meaningful operation on this type is a - -- comparison for equality. - - Invalid_Pid : constant Process_Id; - -- A special value used to indicate errors, as described below - - function Current_Process_Id return Process_Id; - -- Returns the current process id or Invalid_Pid if not supported by the - -- runtime. - - function Argument_String_To_List - (Arg_String : String) return Argument_List_Access; - -- Take a string that is a program and its arguments and parse it into an - -- Argument_List. Note that the result is allocated on the heap, and must - -- be freed by the programmer (when it is no longer needed) to avoid - -- memory leaks. - -- On Windows, backslashes are used as directory separators. On Unix, - -- however, they are used to escape the following character, so that for - -- instance "-d=name\ with\ space" is a single argument. In the result - -- list, the backslashes have been cleaned up when needed. The previous - -- example will thus result a single-element array, where the element is - -- "-d=name with space" (Unix) or "-d=name\ with\ space" (windows). - - procedure Kill (Pid : Process_Id; Hard_Kill : Boolean := True); - -- Kill the process designated by Pid. Does nothing if Pid is Invalid_Pid - -- or on platforms where it is not supported, such as VxWorks. Hard_Kill - -- is True by default, and when True the process is terminated immediately. - -- If Hard_Kill is False, then a signal SIGINT is sent to the process on - -- POSIX OS or a ctrl-C event on Windows, allowing the process a chance to - -- terminate properly using a corresponding handler. - - procedure Kill_Process_Tree (Pid : Process_Id; Hard_Kill : Boolean := True); - -- Kill the process designated by Pid and all it's children processes. - -- Does nothing if Pid is Invalid_Pid or on platforms where it is not - -- supported, such as VxWorks. Hard_Kill is True by default, and when True - -- the processes are terminated immediately. If Hard_Kill is False, then a - -- signal SIGINT is sent to the processes on POSIX OS or a ctrl-C event - -- on Windows, allowing the processes a chance to terminate properly - -- using a corresponding handler. - -- - -- Note that this routine is not atomic and is supported only on Linux - -- and Windows. On other OS it will only kill the process identified by - -- Pid. - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List) return Process_Id; - -- This is a non blocking call. The Process_Id of the spawned process is - -- returned. Parameters are to be used as in Spawn. If Invalid_Pid is - -- returned the program could not be spawned. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - -- - -- This function will always return Invalid_Pid under VxWorks, since there - -- is no notion of executables under this OS. - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Output_File_Descriptor : File_Descriptor; - Err_To_Out : Boolean := True) return Process_Id; - -- Similar to the procedure above, but redirects the output to the file - -- designated by Output_File_Descriptor. If Err_To_Out is True, then the - -- Standard Error output is also redirected. Invalid_Pid is returned - -- if the program could not be spawned successfully. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - -- - -- This function will always return Invalid_Pid under VxWorks, since there - -- is no notion of executables under this OS. - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Output_File : String; - Err_To_Out : Boolean := True) return Process_Id; - -- Similar to the procedure above, but saves the output of the command to - -- a file with the name Output_File. - -- - -- Invalid_Pid is returned if the output file could not be created or if - -- the program could not be spawned successfully. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - -- - -- This function will always return Invalid_Pid under VxWorks, since there - -- is no notion of executables under this OS. - - function Non_Blocking_Spawn - (Program_Name : String; - Args : Argument_List; - Stdout_File : String; - Stderr_File : String) return Process_Id; - -- Similar to the procedure above, but saves the standard output of the - -- command to a file with the name Stdout_File and the standard output - -- of the command to a file with the name Stderr_File. - - procedure Normalize_Arguments (Args : in out Argument_List); - -- Normalize all arguments in the list. This ensure that the argument list - -- is compatible with the running OS and will works fine with Spawn and - -- Non_Blocking_Spawn for example. If Normalize_Arguments is called twice - -- on the same list it will do nothing the second time. Note that Spawn - -- and Non_Blocking_Spawn call Normalize_Arguments automatically, but - -- since there is a guarantee that a second call does nothing, this - -- internal call will have no effect if Normalize_Arguments is called - -- before calling Spawn. The call to Normalize_Arguments assumes that the - -- individual referenced arguments in Argument_List are on the heap, and - -- may free them and reallocate if they are modified. - - function Pid_To_Integer (Pid : Process_Id) return Integer; - -- Convert a process id to an Integer. Useful for writing hash functions - -- for type Process_Id or to compare two Process_Id (e.g. for sorting). - - procedure Spawn - (Program_Name : String; - Args : Argument_List; - Success : out Boolean); - -- This procedure spawns a program with a given list of arguments. The - -- first parameter of is the name of the executable. The second parameter - -- contains the arguments to be passed to this program. Success is False - -- if the named program could not be spawned or its execution completed - -- unsuccessfully. Note that the caller will be blocked until the - -- execution of the spawned program is complete. For maximum portability, - -- use a full path name for the Program_Name argument. On some systems - -- (notably Unix systems) a simple file name may also work (if the - -- executable can be located in the path). - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - -- - -- Note: Arguments in Args that contain spaces and/or quotes such as - -- "--GCC=gcc -v" or "--GCC=""gcc -v""" are not portable across all - -- operating systems, and would not have the desired effect if they were - -- passed directly to the operating system. To avoid this problem, Spawn - -- makes an internal call to Normalize_Arguments, which ensures that such - -- arguments are modified in a manner that ensures that the desired effect - -- is obtained on all operating systems. The caller may call - -- Normalize_Arguments explicitly before the call (e.g. to print out the - -- exact form of arguments passed to the operating system). In this case - -- the guarantee a second call to Normalize_Arguments has no effect - -- ensures that the internal call will not affect the result. Note that - -- the implicit call to Normalize_Arguments may free and reallocate some - -- of the individual arguments. - -- - -- This function will always set Success to False under VxWorks and other - -- similar operating systems which have no notion of the concept of - -- dynamically executable file. Otherwise Success is set True if the exit - -- status of the spawned process is zero. - - function Spawn - (Program_Name : String; - Args : Argument_List) return Integer; - -- Similar to the above procedure, but returns the actual status returned - -- by the operating system, or -1 under VxWorks and any other similar - -- operating systems which have no notion of separately spawnable programs. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - - procedure Spawn - (Program_Name : String; - Args : Argument_List; - Output_File_Descriptor : File_Descriptor; - Return_Code : out Integer; - Err_To_Out : Boolean := True); - -- Similar to the procedure above, but redirects the output to the file - -- designated by Output_File_Descriptor. If Err_To_Out is True, then the - -- Standard Error output is also redirected. - -- Return_Code is set to the status code returned by the operating system - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - - procedure Spawn - (Program_Name : String; - Args : Argument_List; - Output_File : String; - Success : out Boolean; - Return_Code : out Integer; - Err_To_Out : Boolean := True); - -- Similar to the procedure above, but saves the output of the command to - -- a file with the name Output_File. - -- - -- Success is set to True if the command is executed and its output - -- successfully written to the file. If Success is True, then Return_Code - -- will be set to the status code returned by the operating system. - -- Otherwise, Return_Code is undefined. - -- - -- Spawning processes from tasking programs is not recommended. See - -- "NOTE: Spawn in tasking programs" below. - - procedure Wait_Process (Pid : out Process_Id; Success : out Boolean); - -- Wait for the completion of any of the processes created by previous - -- calls to Non_Blocking_Spawn. The caller will be suspended until one of - -- these processes terminates (normally or abnormally). If any of these - -- subprocesses terminates prior to the call to Wait_Process (and has not - -- been returned by a previous call to Wait_Process), then the call to - -- Wait_Process is immediate. Pid identifies the process that has - -- terminated (matching the value returned from Non_Blocking_Spawn). - -- Success is set to True if this sub-process terminated successfully. If - -- Pid = Invalid_Pid, there were no subprocesses left to wait on. - -- - -- This function will always set success to False under VxWorks, since - -- there is no notion of executables under this OS. - - procedure Non_Blocking_Wait_Process - (Pid : out Process_Id; Success : out Boolean); - -- Same as Wait_Process, except if there are no completed child processes, - -- return immediately without blocking, and return Invalid_Pid in Pid. - -- Not supported on all platforms; Success = False if not supported. - - ------------------------------------- - -- NOTE: Spawn in Tasking Programs -- - ------------------------------------- - - -- Spawning processes in tasking programs using the above Spawn and - -- Non_Blocking_Spawn subprograms is not recommended, because there are - -- subtle interactions between creating a process and signals/locks that - -- can cause trouble. These issues are not specific to Ada; they depend - -- primarily on the operating system. - - -- If you need to spawn processes in a tasking program, you will need to - -- understand the semantics of your operating system, and you are likely to - -- write non-portable code, because operating systems differ in this area. - - -- The Spawn and Non_Blocking_Spawn subprograms call the following - -- operating system functions: - - -- On Windows: spawnvp (blocking) or CreateProcess (non-blocking) - - -- On Solaris: fork1, followed in the child process by execv - - -- On other Unix-like systems: fork, followed in the child - -- process by execv. - - -- On vxworks, spawning of processes is not supported - - -- For details, look at the functions __gnat_portable_spawn and - -- __gnat_portable_no_block_spawn in adaint.c. - - -- You should read the operating-system-specific documentation for the - -- above functions, paying special attention to subtle interactions with - -- threading, signals, locks, and file descriptors. Most of the issues are - -- related to the fact that on Unix, there is a window of time between fork - -- and execv; Windows does not have this problem, because spawning is done - -- in a single operation. - - -- On Posix-compliant systems, such as Linux, fork duplicates just the - -- calling thread. (On Solaris, fork1 is the Posix-compliant version of - -- fork.) - - -- You should avoid using signals while spawning. This includes signals - -- used internally by the Ada run-time system, such as timer signals used - -- to implement delay statements. - - -- It is best to spawn any subprocesses very early, before the parent - -- process creates tasks, locks, or installs signal handlers. Certainly - -- avoid doing simultaneous spawns from multiple threads of the same - -- process. - - -- There is no problem spawning a subprocess that uses tasking: the - -- problems are caused only by tasking in the parent. - - -- If the parent is using tasking, and needs to spawn subprocesses at - -- arbitrary times, one technique is for the parent to spawn (very early) - -- a particular spawn-manager subprocess whose job is to spawn other - -- processes. The spawn-manager must avoid tasking. The parent sends - -- messages to the spawn-manager requesting it to spawn processes, using - -- whatever inter-process communication mechanism you like, such as - -- sockets. - - -- In short, mixing spawning of subprocesses with tasking is a tricky - -- business, and should be avoided if possible, but if it is necessary, - -- the above guidelines should be followed, and you should beware of - -- portability problems. - - ------------------- - -- Miscellaneous -- - ------------------- - - function Errno return Integer; - pragma Import (C, Errno, "__get_errno"); - -- Return the task-safe last error number - - function Errno_Message - (Err : Integer := Errno; - Default : String := "") return String; - -- Return a message describing the given Errno value. If none is provided - -- by the system, return Default if not empty, else return a generic - -- message indicating the numeric errno value. - - function Getenv (Name : String) return String_Access; - -- Get the value of the environment variable. Returns an access to the - -- empty string if the environment variable does not exist or has an - -- explicit null value (in some operating systems these are distinct - -- cases, in others they are not; this interface abstracts away that - -- difference. The argument is allocated on the heap (even in the null - -- case), and needs to be freed explicitly when no longer needed to avoid - -- memory leaks. - - procedure OS_Abort; - pragma Import (C, OS_Abort, "abort"); - pragma No_Return (OS_Abort); - -- Exit to OS signalling an abort (traceback or other appropriate - -- diagnostic information should be given if possible, or entry made to - -- the debugger if that is possible). - - procedure OS_Exit (Status : Integer); - pragma No_Return (OS_Exit); - -- Exit to OS with given status code (program is terminated). Note that - -- this is abrupt termination. All tasks are immediately terminated. There - -- are no finalization or other Ada-specific cleanup actions performed. On - -- systems with atexit handlers (such as Unix and Windows), atexit handlers - -- are called. - - type OS_Exit_Subprogram is access procedure (Status : Integer); - - procedure OS_Exit_Default (Status : Integer); - pragma No_Return (OS_Exit_Default); - -- Default implementation of procedure OS_Exit - - OS_Exit_Ptr : OS_Exit_Subprogram := OS_Exit_Default'Access; - -- OS_Exit is implemented through this access value. It it then possible to - -- change the implementation of OS_Exit by redirecting OS_Exit_Ptr to an - -- other implementation. - - procedure Set_Errno (Errno : Integer); - pragma Import (C, Set_Errno, "__set_errno"); - -- Set the task-safe error number - - procedure Setenv (Name : String; Value : String); - -- Set the value of the environment variable Name to Value. This call - -- modifies the current environment, but does not modify the parent - -- process environment. After a call to Setenv, Getenv (Name) will always - -- return a String_Access referencing the same String as Value. This is - -- true also for the null string case (the actual effect may be to either - -- set an explicit null as the value, or to remove the entry, this is - -- operating system dependent). Note that any following calls to Spawn - -- will pass an environment to the spawned process that includes the - -- changes made by Setenv calls. - - Directory_Separator : constant Character; - -- The character that is used to separate parts of a pathname - - Path_Separator : constant Character; - -- The character to separate paths in an environment variable value - -private - pragma Import (C, Path_Separator, "__gnat_path_separator"); - pragma Import (C, Directory_Separator, "__gnat_dir_separator"); - pragma Import (C, Current_Time, "__gnat_current_time"); - pragma Import (C, Current_Process_Id, "__gnat_current_process_id"); - - type OS_Time is - range -(2 ** (Standard'Address_Size - Integer'(1))) .. - +(2 ** (Standard'Address_Size - Integer'(1)) - 1); - -- Type used for timestamps in the compiler. This type is used to hold - -- time stamps, but may have a different representation than C's time_t. - -- This type needs to match the declaration of OS_Time in adaint.h. - - -- Add pragma Inline statements for comparison operations on OS_Time. It - -- would actually be nice to use pragma Import (Intrinsic) here, but this - -- was not properly supported till GNAT 3.15a, so that would cause - -- bootstrap path problems. To be changed later ??? - - Invalid_Time : constant OS_Time := -1; - -- This value should match the return value from __gnat_file_time_* - - pragma Inline ("<"); - pragma Inline (">"); - pragma Inline ("<="); - pragma Inline (">="); - - type Process_Id is new Integer; - Invalid_Pid : constant Process_Id := -1; - -end System.OS_Lib; diff --git a/gcc/ada/s-osprim-darwin.adb b/gcc/ada/s-osprim-darwin.adb deleted file mode 100644 index 688371d..0000000 --- a/gcc/ada/s-osprim-darwin.adb +++ /dev/null @@ -1,169 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for darwin - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type struct_timezone is record - tz_minuteswest : Integer; - tz_dsttime : Integer; - end record; - pragma Convention (C, struct_timezone); - type struct_timezone_ptr is access all struct_timezone; - - type time_t is new Long_Integer; - - type struct_timeval is record - tv_sec : time_t; - tv_usec : Integer; - end record; - pragma Convention (C, struct_timeval); - - function gettimeofday - (tv : not null access struct_timeval; - tz : struct_timezone_ptr) return Integer; - pragma Import (C, gettimeofday, "gettimeofday"); - - type timespec is record - tv_sec : time_t; - tv_nsec : Long_Integer; - end record; - pragma Convention (C, timespec); - - function nanosleep (rqtp, rmtp : not null access timespec) return Integer; - pragma Import (C, nanosleep, "nanosleep"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - Result : Integer; - pragma Unreferenced (Result); - - begin - -- The return codes for gettimeofday are as follows (from man pages): - -- EPERM settimeofday is called by someone other than the superuser - -- EINVAL Timezone (or something else) is invalid - -- EFAULT One of tv or tz pointed outside accessible address space - - -- None of these codes signal a potential clock skew, hence the return - -- value is never checked. - - Result := gettimeofday (TV'Access, null); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - - Result : Integer; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Request := To_Timespec (Rel_Time); - Result := nanosleep (Request'Access, Remaind'Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-mingw.adb b/gcc/ada/s-osprim-mingw.adb deleted file mode 100644 index 6d4f2bf..0000000 --- a/gcc/ada/s-osprim-mingw.adb +++ /dev/null @@ -1,413 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the NT version of this package - -with System.Task_Lock; -with System.Win32.Ext; - -package body System.OS_Primitives is - - use System.Task_Lock; - use System.Win32; - use System.Win32.Ext; - - ---------------------------------------- - -- Data for the high resolution clock -- - ---------------------------------------- - - Tick_Frequency : aliased LARGE_INTEGER; - -- Holds frequency of high-performance counter used by Clock - -- Windows NT uses a 1_193_182 Hz counter on PCs. - - Base_Monotonic_Ticks : LARGE_INTEGER; - -- Holds the Tick count for the base monotonic time - - Base_Monotonic_Clock : Duration; - -- Holds the current clock for monotonic clock's base time - - type Clock_Data is record - Base_Ticks : LARGE_INTEGER; - -- Holds the Tick count for the base time - - Base_Time : Long_Long_Integer; - -- Holds the base time used to check for system time change, used with - -- the standard clock. - - Base_Clock : Duration; - -- Holds the current clock for the standard clock's base time - end record; - - type Clock_Data_Access is access all Clock_Data; - - -- Two base clock buffers. This is used to be able to update a buffer while - -- the other buffer is read. The point is that we do not want to use a lock - -- inside the Clock routine for performance reasons. We still use a lock - -- in the Get_Base_Time which is called very rarely. Current is a pointer, - -- the pragma Atomic is there to ensure that the value can be set or read - -- atomically. That's it, when Get_Base_Time has updated a buffer the - -- switch to the new value is done by changing Current pointer. - - First, Second : aliased Clock_Data; - - Current : Clock_Data_Access := First'Access; - pragma Atomic (Current); - - -- The following signature is to detect change on the base clock data - -- above. The signature is a modular type, it will wrap around without - -- raising an exception. We would need to have exactly 2**32 updates of - -- the base data for the changes to get undetected. - - type Signature_Type is mod 2**32; - Signature : Signature_Type := 0; - pragma Atomic (Signature); - - function Monotonic_Clock return Duration; - pragma Export (Ada, Monotonic_Clock, "__gnat_monotonic_clock"); - -- Return "absolute" time, represented as an offset relative to "the Unix - -- Epoch", which is Jan 1, 1970 00:00:00 UTC. This clock implementation is - -- immune to the system's clock changes. Export this function so that it - -- can be imported from s-taprop-mingw.adb without changing the shared - -- spec (s-osprim.ads). - - procedure Get_Base_Time (Data : in out Clock_Data); - -- Retrieve the base time and base ticks. These values will be used by - -- clock to compute the current time by adding to it a fraction of the - -- performance counter. This is for the implementation of a high-resolution - -- clock. Note that this routine does not change the base monotonic values - -- used by the monotonic clock. - - ----------- - -- Clock -- - ----------- - - -- This implementation of clock provides high resolution timer values - -- using QueryPerformanceCounter. This call return a 64 bits values (based - -- on the 8253 16 bits counter). This counter is updated every 1/1_193_182 - -- times per seconds. The call to QueryPerformanceCounter takes 6 - -- microsecs to complete. - - function Clock return Duration is - Max_Shift : constant Duration := 2.0; - Hundreds_Nano_In_Sec : constant Long_Long_Float := 1.0E7; - Data : Clock_Data; - Current_Ticks : aliased LARGE_INTEGER; - Elap_Secs_Tick : Duration; - Elap_Secs_Sys : Duration; - Now : aliased Long_Long_Integer; - Sig1, Sig2 : Signature_Type; - - begin - -- Try ten times to get a coherent set of base data. For this we just - -- check that the signature hasn't changed during the copy of the - -- current data. - -- - -- This loop will always be done once if there is no interleaved call - -- to Get_Base_Time. - - for K in 1 .. 10 loop - Sig1 := Signature; - Data := Current.all; - Sig2 := Signature; - exit when Sig1 = Sig2; - end loop; - - if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then - return 0.0; - end if; - - GetSystemTimeAsFileTime (Now'Access); - - Elap_Secs_Sys := - Duration (Long_Long_Float (abs (Now - Data.Base_Time)) / - Hundreds_Nano_In_Sec); - - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / - Long_Long_Float (Tick_Frequency)); - - -- If we have a shift of more than Max_Shift seconds we resynchronize - -- the Clock. This is probably due to a manual Clock adjustment, a DST - -- adjustment or an NTP synchronisation. And we want to adjust the time - -- for this system (non-monotonic) clock. - - if abs (Elap_Secs_Sys - Elap_Secs_Tick) > Max_Shift then - Get_Base_Time (Data); - - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - Data.Base_Ticks) / - Long_Long_Float (Tick_Frequency)); - end if; - - return Data.Base_Clock + Elap_Secs_Tick; - end Clock; - - ------------------- - -- Get_Base_Time -- - ------------------- - - procedure Get_Base_Time (Data : in out Clock_Data) is - - -- The resolution for GetSystemTime is 1 millisecond - - -- The time to get both base times should take less than 1 millisecond. - -- Therefore, the elapsed time reported by GetSystemTime between both - -- actions should be null. - - epoch_1970 : constant := 16#19D_B1DE_D53E_8000#; -- win32 UTC epoch - system_time_ns : constant := 100; -- 100 ns per tick - Sec_Unit : constant := 10#1#E9; - - Max_Elapsed : constant LARGE_INTEGER := - LARGE_INTEGER (Tick_Frequency / 100_000); - -- Look for a precision of 0.01 ms - - Sig : constant Signature_Type := Signature; - - Loc_Ticks, Ctrl_Ticks : aliased LARGE_INTEGER; - Loc_Time, Ctrl_Time : aliased Long_Long_Integer; - Elapsed : LARGE_INTEGER; - Current_Max : LARGE_INTEGER := LARGE_INTEGER'Last; - New_Data : Clock_Data_Access; - - begin - -- Here we must be sure that both of these calls are done in a short - -- amount of time. Both are base time and should in theory be taken - -- at the very same time. - - -- The goal of the following loop is to synchronize the system time - -- with the Win32 performance counter by getting a base offset for both. - -- Using these offsets it is then possible to compute actual time using - -- a performance counter which has a better precision than the Win32 - -- time API. - - -- Try at most 10 times to reach the best synchronisation (below 1 - -- millisecond) otherwise the runtime will use the best value reached - -- during the runs. - - Lock; - - -- First check that the current value has not been updated. This - -- could happen if another task has called Clock at the same time - -- and that Max_Shift has been reached too. - -- - -- But if the current value has been changed just before we entered - -- into the critical section, we can safely return as the current - -- base data (time, clock, ticks) have already been updated. - - if Sig /= Signature then - Unlock; - return; - end if; - - -- Check for the unused data buffer and set New_Data to point to it - - if Current = First'Access then - New_Data := Second'Access; - else - New_Data := First'Access; - end if; - - for K in 1 .. 10 loop - if QueryPerformanceCounter (Loc_Ticks'Access) = Win32.FALSE then - pragma Assert - (Standard.False, - "Could not query high performance counter in Clock"); - null; - end if; - - GetSystemTimeAsFileTime (Ctrl_Time'Access); - - -- Scan for clock tick, will take up to 16ms/1ms depending on PC. - -- This cannot be an infinite loop or the system hardware is badly - -- damaged. - - loop - GetSystemTimeAsFileTime (Loc_Time'Access); - - if QueryPerformanceCounter (Ctrl_Ticks'Access) = Win32.FALSE then - pragma Assert - (Standard.False, - "Could not query high performance counter in Clock"); - null; - end if; - - exit when Loc_Time /= Ctrl_Time; - Loc_Ticks := Ctrl_Ticks; - end loop; - - -- Check elapsed Performance Counter between samples - -- to choose the best one. - - Elapsed := Ctrl_Ticks - Loc_Ticks; - - if Elapsed < Current_Max then - New_Data.Base_Time := Loc_Time; - New_Data.Base_Ticks := Loc_Ticks; - Current_Max := Elapsed; - - -- Exit the loop when we have reached the expected precision - - exit when Elapsed <= Max_Elapsed; - end if; - end loop; - - New_Data.Base_Clock := - Duration - (Long_Long_Float - ((New_Data.Base_Time - epoch_1970) * system_time_ns) / - Long_Long_Float (Sec_Unit)); - - -- At this point all the base values have been set into the new data - -- record. Change the pointer (atomic operation) to these new values. - - Current := New_Data; - Data := New_Data.all; - - -- Set new signature for this data set - - Signature := Signature + 1; - - Unlock; - - exception - when others => - Unlock; - raise; - end Get_Base_Time; - - --------------------- - -- Monotonic_Clock -- - --------------------- - - function Monotonic_Clock return Duration is - Current_Ticks : aliased LARGE_INTEGER; - Elap_Secs_Tick : Duration; - - begin - if QueryPerformanceCounter (Current_Ticks'Access) = Win32.FALSE then - return 0.0; - - else - Elap_Secs_Tick := - Duration (Long_Long_Float (Current_Ticks - Base_Monotonic_Ticks) / - Long_Long_Float (Tick_Frequency)); - return Base_Monotonic_Clock + Elap_Secs_Tick; - end if; - end Monotonic_Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay (Time : Duration; Mode : Integer) is - function Mode_Clock return Duration; - pragma Inline (Mode_Clock); - -- Return the current clock value using either the monotonic clock or - -- standard clock depending on the Mode value. - - ---------------- - -- Mode_Clock -- - ---------------- - - function Mode_Clock return Duration is - begin - case Mode is - when Absolute_RT => return Monotonic_Clock; - when others => return Clock; - end case; - end Mode_Clock; - - -- Local Variables - - Base_Time : constant Duration := Mode_Clock; - -- Base_Time is used to detect clock set backward, in this case we - -- cannot ensure the delay accuracy. - - Rel_Time : Duration; - Abs_Time : Duration; - Check_Time : Duration := Base_Time; - - -- Start of processing for Timed Delay - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Sleep (DWORD (Rel_Time * 1000.0)); - Check_Time := Mode_Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - Initialized : Boolean := False; - - procedure Initialize is - begin - if Initialized then - return; - end if; - - Initialized := True; - - -- Get starting time as base - - if QueryPerformanceFrequency (Tick_Frequency'Access) = Win32.FALSE then - raise Program_Error with - "cannot get high performance counter frequency"; - end if; - - Get_Base_Time (Current.all); - - -- Keep base clock and ticks for the monotonic clock. These values - -- should never be changed to ensure proper behavior of the monotonic - -- clock. - - Base_Monotonic_Clock := Current.Base_Clock; - Base_Monotonic_Ticks := Current.Base_Ticks; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-posix.adb b/gcc/ada/s-osprim-posix.adb deleted file mode 100644 index 04344d3..0000000 --- a/gcc/ada/s-osprim-posix.adb +++ /dev/null @@ -1,172 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for POSIX-like operating systems - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type time_t is new Long_Integer; - - type timespec is record - tv_sec : time_t; - tv_nsec : Long_Integer; - end record; - pragma Convention (C, timespec); - - function nanosleep (rqtp, rmtp : not null access timespec) return Integer; - pragma Import (C, nanosleep, "nanosleep"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - - type timeval is array (1 .. 3) of Long_Integer; - -- The timeval array is sized to contain Long_Long_Integer sec and - -- Long_Integer usec. If Long_Long_Integer'Size = Long_Integer'Size then - -- it will be overly large but that will not effect the implementation - -- since it is not accessed directly. - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access Long_Long_Integer; - usec : not null access Long_Integer); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased Long_Long_Integer; - usec : aliased Long_Integer; - TV : aliased timeval; - Result : Integer; - pragma Unreferenced (Result); - - function gettimeofday - (Tv : access timeval; - Tz : System.Address := System.Null_Address) return Integer; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - -- The return codes for gettimeofday are as follows (from man pages): - -- EPERM settimeofday is called by someone other than the superuser - -- EINVAL Timezone (or something else) is invalid - -- EFAULT One of tv or tz pointed outside accessible address space - - -- None of these codes signal a potential clock skew, hence the return - -- value is never checked. - - Result := gettimeofday (TV'Access, System.Null_Address); - timeval_to_duration (TV'Access, sec'Access, usec'Access); - return Duration (sec) + Duration (usec) / Micro; - end Clock; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return 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_Integer (Long_Long_Integer (F * 10#1#E9))); - end To_Timespec; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - - Result : Integer; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Request := To_Timespec (Rel_Time); - Result := nanosleep (Request'Access, Remaind'Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-solaris.adb b/gcc/ada/s-osprim-solaris.adb deleted file mode 100644 index 3bddaa5..0000000 --- a/gcc/ada/s-osprim-solaris.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version uses gettimeofday and select --- This file is suitable for Solaris (32 and 64 bits). - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type struct_timeval is record - tv_sec : Long_Integer; - tv_usec : Long_Integer; - end record; - pragma Convention (C, struct_timeval); - - procedure gettimeofday - (tv : not null access struct_timeval; - tz : Address := Null_Address); - pragma Import (C, gettimeofday, "gettimeofday"); - - procedure C_select - (n : Integer := 0; - readfds, - writefds, - exceptfds : Address := Null_Address; - timeout : not null access struct_timeval); - pragma Import (C, C_select, "select"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - begin - gettimeofday (TV'Access); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - timeval : aliased struct_timeval; - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - timeval.tv_sec := Long_Integer (Rel_Time); - - if Duration (timeval.tv_sec) > Rel_Time then - timeval.tv_sec := timeval.tv_sec - 1; - end if; - - timeval.tv_usec := - Long_Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); - - C_select (timeout => timeval'Unchecked_Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-unix.adb b/gcc/ada/s-osprim-unix.adb deleted file mode 100644 index 732a15c..0000000 --- a/gcc/ada/s-osprim-unix.adb +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version uses gettimeofday and select --- This file is suitable for OpenNT, Dec Unix and SCO UnixWare. - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type struct_timeval is record - tv_sec : Integer; - tv_usec : Integer; - end record; - pragma Convention (C, struct_timeval); - - procedure gettimeofday - (tv : not null access struct_timeval; - tz : Address := Null_Address); - pragma Import (C, gettimeofday, "gettimeofday"); - - procedure C_select - (n : Integer := 0; - readfds, - writefds, - exceptfds : Address := Null_Address; - timeout : not null access struct_timeval); - pragma Import (C, C_select, "select"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TV : aliased struct_timeval; - - begin - gettimeofday (TV'Access); - return Duration (TV.tv_sec) + Duration (TV.tv_usec) / 10#1#E6; - end Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - timeval : aliased struct_timeval; - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - timeval.tv_sec := Integer (Rel_Time); - - if Duration (timeval.tv_sec) > Rel_Time then - timeval.tv_sec := timeval.tv_sec - 1; - end if; - - timeval.tv_usec := - Integer ((Rel_Time - Duration (timeval.tv_sec)) * 10#1#E6); - - C_select (timeout => timeval'Unchecked_Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-vxworks.adb b/gcc/ada/s-osprim-vxworks.adb deleted file mode 100644 index 92dfc99..0000000 --- a/gcc/ada/s-osprim-vxworks.adb +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for VxWorks targets - -with System.OS_Interface; --- Since the thread library is part of the VxWorks kernel, using OS_Interface --- is not a problem here, as long as we only use System.OS_Interface as a --- set of C imported routines: using Ada routines from this package would --- create a dependency on libgnarl in libgnat, which is not desirable. - -with System.OS_Constants; -with Interfaces.C; - -package body System.OS_Primitives is - - use System.OS_Interface; - use type Interfaces.C.int; - - package OSC renames System.OS_Constants; - - ------------------------ - -- Internal functions -- - ------------------------ - - function To_Clock_Ticks (D : Duration) return int; - -- Convert a duration value (in seconds) into clock ticks. - -- Note that this routine is duplicated from System.OS_Interface since - -- as explained above, we do not want to depend on libgnarl - - function To_Clock_Ticks (D : Duration) return int is - Ticks : Long_Long_Integer; - Rate_Duration : Duration; - Ticks_Duration : Duration; - - begin - if D < 0.0 then - return -1; - end if; - - -- Ensure that the duration can be converted to ticks - -- at the current clock tick rate without overflowing. - - Rate_Duration := Duration (sysClkRateGet); - - if D > (Duration'Last / Rate_Duration) then - Ticks := Long_Long_Integer (int'Last); - else - Ticks_Duration := D * Rate_Duration; - Ticks := Long_Long_Integer (Ticks_Duration); - - if Ticks_Duration > Duration (Ticks) then - Ticks := Ticks + 1; - end if; - - if Ticks > Long_Long_Integer (int'Last) then - Ticks := Long_Long_Integer (int'Last); - end if; - end if; - - return int (Ticks); - end To_Clock_Ticks; - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - TS : aliased timespec; - Result : int; - begin - Result := clock_gettime (OSC.CLOCK_RT_Ada, TS'Unchecked_Access); - pragma Assert (Result = 0); - return Duration (TS.ts_sec) + Duration (TS.ts_nsec) / 10#1#E9; - end Clock; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - Ticks : int; - - Result : int; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Ticks := To_Clock_Ticks (Rel_Time); - - if Mode = Relative and then Ticks < int'Last then - -- The first tick will delay anytime between 0 and - -- 1 / sysClkRateGet seconds, so we need to add one to - -- be on the safe side. - - Ticks := Ticks + 1; - end if; - - Result := taskDelay (Ticks); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim-x32.adb b/gcc/ada/s-osprim-x32.adb deleted file mode 100644 index b457f5b..0000000 --- a/gcc/ada/s-osprim-x32.adb +++ /dev/null @@ -1,167 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2013-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version is for Linux/x32 - -package body System.OS_Primitives is - - -- ??? These definitions are duplicated from System.OS_Interface - -- because we don't want to depend on any package. Consider removing - -- these declarations in System.OS_Interface and move these ones in - -- the spec. - - type time_t is new Long_Long_Integer; - - type timespec is record - tv_sec : time_t; - tv_nsec : Long_Long_Integer; - end record; - pragma Convention (C, timespec); - - function nanosleep (rqtp, rmtp : not null access timespec) return Integer; - pragma Import (C, nanosleep, "nanosleep"); - - ----------- - -- Clock -- - ----------- - - function Clock return Duration is - type timeval is array (1 .. 2) of Long_Long_Integer; - - procedure timeval_to_duration - (T : not null access timeval; - sec : not null access Long_Integer; - usec : not null access Long_Integer); - pragma Import (C, timeval_to_duration, "__gnat_timeval_to_duration"); - - Micro : constant := 10**6; - sec : aliased Long_Integer; - usec : aliased Long_Integer; - TV : aliased timeval; - Result : Integer; - pragma Unreferenced (Result); - - function gettimeofday - (Tv : access timeval; - Tz : System.Address := System.Null_Address) return Integer; - pragma Import (C, gettimeofday, "gettimeofday"); - - begin - -- The return codes for gettimeofday are as follows (from man pages): - -- EPERM settimeofday is called by someone other than the superuser - -- EINVAL Timezone (or something else) is invalid - -- EFAULT One of tv or tz pointed outside accessible address space - - -- None of these codes signal a potential clock skew, hence the return - -- value is never checked. - - Result := gettimeofday (TV'Access, System.Null_Address); - timeval_to_duration (TV'Access, sec'Access, usec'Access); - return Duration (sec) + Duration (usec) / Micro; - end Clock; - - ----------------- - -- To_Timespec -- - ----------------- - - function To_Timespec (D : Duration) return 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_Integer (F * 10#1#E9)); - end To_Timespec; - - ----------------- - -- Timed_Delay -- - ----------------- - - procedure Timed_Delay - (Time : Duration; - Mode : Integer) - is - Request : aliased timespec; - Remaind : aliased timespec; - Rel_Time : Duration; - Abs_Time : Duration; - Base_Time : constant Duration := Clock; - Check_Time : Duration := Base_Time; - - Result : Integer; - pragma Unreferenced (Result); - - begin - if Mode = Relative then - Rel_Time := Time; - Abs_Time := Time + Check_Time; - else - Rel_Time := Time - Check_Time; - Abs_Time := Time; - end if; - - if Rel_Time > 0.0 then - loop - Request := To_Timespec (Rel_Time); - Result := nanosleep (Request'Access, Remaind'Access); - Check_Time := Clock; - - exit when Abs_Time <= Check_Time or else Check_Time < Base_Time; - - Rel_Time := Abs_Time - Check_Time; - end loop; - end if; - end Timed_Delay; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - begin - null; - end Initialize; - -end System.OS_Primitives; diff --git a/gcc/ada/s-osprim.ads b/gcc/ada/s-osprim.ads deleted file mode 100644 index ad4ffbe..0000000 --- a/gcc/ada/s-osprim.ads +++ /dev/null @@ -1,85 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . O S _ P R I M I T I V E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides low level primitives used to implement clock and --- delays in non tasking applications. - --- The choice of the real clock/delay implementation (depending on whether --- tasking is involved or not) is done via soft links (see s-soflin.ads) - --- NEVER add any dependency to tasking packages here - -package System.OS_Primitives is - pragma Preelaborate; - - Max_Sensible_Delay : constant Duration := - Duration'Min (183 * 24 * 60 * 60.0, - Duration'Last); - -- Max of half a year delay, needed to prevent exceptions for large delay - -- values. It seems unlikely that any test will notice this restriction, - -- except in the case of applications setting the clock at run time (see - -- s-tastim.adb). Also note that a larger value might cause problems (e.g - -- overflow, or more likely OS limitation in the primitives used). In the - -- case where half a year is too long (which occurs in high integrity mode - -- with 32-bit words, and possibly on some specific ports of GNAT), - -- Duration'Last is used instead. - - procedure Initialize; - -- Initialize global settings related to this package. This procedure - -- should be called before any other subprograms in this package. Note - -- that this procedure can be called several times. - - function Clock return Duration; - pragma Inline (Clock); - -- Returns "absolute" time, represented as an offset relative to "the - -- Epoch", which is Jan 1, 1970 00:00:00 UTC on UNIX systems. This - -- implementation is affected by system's clock changes. - - Relative : constant := 0; - Absolute_Calendar : constant := 1; - Absolute_RT : constant := 2; - -- Values for Mode call below. Note that the compiler (exp_ch9.adb) relies - -- on these values. So any change here must be reflected in corresponding - -- changes in the compiler. - - procedure Timed_Delay (Time : Duration; Mode : Integer); - -- Implements the semantics of the delay statement when no tasking is used - -- in the application. - -- - -- Mode is one of the three values above - -- - -- Time is a relative or absolute duration value, depending on Mode. - -- - -- Note that currently Ada.Real_Time always uses the tasking run time, - -- so this procedure should never be called with Mode set to Absolute_RT. - -- This may change in future or bare board implementations. - -end System.OS_Primitives; diff --git a/gcc/ada/s-pack03.adb b/gcc/ada/s-pack03.adb deleted file mode 100644 index b081dc2..0000000 --- a/gcc/ada/s-pack03.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_03 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_03; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_03 -- - ------------ - - function Get_03 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_03 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_03; - - ------------ - -- Set_03 -- - ------------ - - procedure Set_03 - (Arr : System.Address; - N : Natural; - E : Bits_03; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_03; - -end System.Pack_03; diff --git a/gcc/ada/s-pack03.ads b/gcc/ada/s-pack03.ads deleted file mode 100644 index 265246c..0000000 --- a/gcc/ada/s-pack03.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 3 - -package System.Pack_03 is - pragma Preelaborate; - - Bits : constant := 3; - - type Bits_03 is mod 2 ** Bits; - for Bits_03'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_03 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_03 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_03 - (Arr : System.Address; - N : Natural; - E : Bits_03; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_03; diff --git a/gcc/ada/s-pack05.adb b/gcc/ada/s-pack05.adb deleted file mode 100644 index 645c3a7..0000000 --- a/gcc/ada/s-pack05.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_05 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_05; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_05 -- - ------------ - - function Get_05 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_05 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_05; - - ------------ - -- Set_05 -- - ------------ - - procedure Set_05 - (Arr : System.Address; - N : Natural; - E : Bits_05; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_05; - -end System.Pack_05; diff --git a/gcc/ada/s-pack05.ads b/gcc/ada/s-pack05.ads deleted file mode 100644 index 567bdc7..0000000 --- a/gcc/ada/s-pack05.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 5 - -package System.Pack_05 is - pragma Preelaborate; - - Bits : constant := 5; - - type Bits_05 is mod 2 ** Bits; - for Bits_05'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_05 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_05 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_05 - (Arr : System.Address; - N : Natural; - E : Bits_05; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_05; diff --git a/gcc/ada/s-pack06.adb b/gcc/ada/s-pack06.adb deleted file mode 100644 index e467af0..0000000 --- a/gcc/ada/s-pack06.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_06 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_06; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_06 or SetU_06 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_06 -- - ------------ - - function Get_06 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_06 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_06; - - ------------- - -- GetU_06 -- - ------------- - - function GetU_06 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_06 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_06; - - ------------ - -- Set_06 -- - ------------ - - procedure Set_06 - (Arr : System.Address; - N : Natural; - E : Bits_06; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_06; - - ------------- - -- SetU_06 -- - ------------- - - procedure SetU_06 - (Arr : System.Address; - N : Natural; - E : Bits_06; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_06; - -end System.Pack_06; diff --git a/gcc/ada/s-pack06.ads b/gcc/ada/s-pack06.ads deleted file mode 100644 index 9db4734..0000000 --- a/gcc/ada/s-pack06.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 6 - -package System.Pack_06 is - pragma Preelaborate; - - Bits : constant := 6; - - type Bits_06 is mod 2 ** Bits; - for Bits_06'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_06 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_06 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_06 - (Arr : System.Address; - N : Natural; - E : Bits_06; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_06 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_06 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_06 - (Arr : System.Address; - N : Natural; - E : Bits_06; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_06; diff --git a/gcc/ada/s-pack07.adb b/gcc/ada/s-pack07.adb deleted file mode 100644 index 45ba8bd..0000000 --- a/gcc/ada/s-pack07.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 7 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_07 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_07; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_07 -- - ------------ - - function Get_07 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_07 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_07; - - ------------ - -- Set_07 -- - ------------ - - procedure Set_07 - (Arr : System.Address; - N : Natural; - E : Bits_07; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_07; - -end System.Pack_07; diff --git a/gcc/ada/s-pack07.ads b/gcc/ada/s-pack07.ads deleted file mode 100644 index a0fa35d..0000000 --- a/gcc/ada/s-pack07.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 7 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 7 - -package System.Pack_07 is - pragma Preelaborate; - - Bits : constant := 7; - - type Bits_07 is mod 2 ** Bits; - for Bits_07'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_07 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_07 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_07 - (Arr : System.Address; - N : Natural; - E : Bits_07; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_07; diff --git a/gcc/ada/s-pack09.adb b/gcc/ada/s-pack09.adb deleted file mode 100644 index e0360bb..0000000 --- a/gcc/ada/s-pack09.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 9 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_09 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_09; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_09 -- - ------------ - - function Get_09 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_09 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_09; - - ------------ - -- Set_09 -- - ------------ - - procedure Set_09 - (Arr : System.Address; - N : Natural; - E : Bits_09; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_09; - -end System.Pack_09; diff --git a/gcc/ada/s-pack09.ads b/gcc/ada/s-pack09.ads deleted file mode 100644 index 78defe0..0000000 --- a/gcc/ada/s-pack09.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 0 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 9 - -package System.Pack_09 is - pragma Preelaborate; - - Bits : constant := 9; - - type Bits_09 is mod 2 ** Bits; - for Bits_09'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_09 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_09 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_09 - (Arr : System.Address; - N : Natural; - E : Bits_09; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_09; diff --git a/gcc/ada/s-pack10.adb b/gcc/ada/s-pack10.adb deleted file mode 100644 index 402c9fa..0000000 --- a/gcc/ada/s-pack10.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 0 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_10 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_10; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_10 or SetU_10 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_10 -- - ------------ - - function Get_10 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_10 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_10; - - ------------- - -- GetU_10 -- - ------------- - - function GetU_10 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_10 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_10; - - ------------ - -- Set_10 -- - ------------ - - procedure Set_10 - (Arr : System.Address; - N : Natural; - E : Bits_10; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_10; - - ------------- - -- SetU_10 -- - ------------- - - procedure SetU_10 - (Arr : System.Address; - N : Natural; - E : Bits_10; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_10; - -end System.Pack_10; diff --git a/gcc/ada/s-pack10.ads b/gcc/ada/s-pack10.ads deleted file mode 100644 index dc4113e..0000000 --- a/gcc/ada/s-pack10.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 0 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 10 - -package System.Pack_10 is - pragma Preelaborate; - - Bits : constant := 10; - - type Bits_10 is mod 2 ** Bits; - for Bits_10'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_10 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_10 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_10 - (Arr : System.Address; - N : Natural; - E : Bits_10; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_10 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_10 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_10 - (Arr : System.Address; - N : Natural; - E : Bits_10; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_10; diff --git a/gcc/ada/s-pack11.adb b/gcc/ada/s-pack11.adb deleted file mode 100644 index 23edceb..0000000 --- a/gcc/ada/s-pack11.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_11 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_11; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_11 -- - ------------ - - function Get_11 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_11 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_11; - - ------------ - -- Set_11 -- - ------------ - - procedure Set_11 - (Arr : System.Address; - N : Natural; - E : Bits_11; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_11; - -end System.Pack_11; diff --git a/gcc/ada/s-pack11.ads b/gcc/ada/s-pack11.ads deleted file mode 100644 index e812a00..0000000 --- a/gcc/ada/s-pack11.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 11 - -package System.Pack_11 is - pragma Preelaborate; - - Bits : constant := 11; - - type Bits_11 is mod 2 ** Bits; - for Bits_11'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_11 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_11 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_11 - (Arr : System.Address; - N : Natural; - E : Bits_11; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_11; diff --git a/gcc/ada/s-pack12.adb b/gcc/ada/s-pack12.adb deleted file mode 100644 index 69b090d..0000000 --- a/gcc/ada/s-pack12.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_12 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_12; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_12 or SetU_12 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_12 -- - ------------ - - function Get_12 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_12 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_12; - - ------------- - -- GetU_12 -- - ------------- - - function GetU_12 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_12 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_12; - - ------------ - -- Set_12 -- - ------------ - - procedure Set_12 - (Arr : System.Address; - N : Natural; - E : Bits_12; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_12; - - ------------- - -- SetU_12 -- - ------------- - - procedure SetU_12 - (Arr : System.Address; - N : Natural; - E : Bits_12; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_12; - -end System.Pack_12; diff --git a/gcc/ada/s-pack12.ads b/gcc/ada/s-pack12.ads deleted file mode 100644 index ae0af7e..0000000 --- a/gcc/ada/s-pack12.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 12 - -package System.Pack_12 is - pragma Preelaborate; - - Bits : constant := 12; - - type Bits_12 is mod 2 ** Bits; - for Bits_12'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_12 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_12 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_12 - (Arr : System.Address; - N : Natural; - E : Bits_12; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_12 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_12 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_12 - (Arr : System.Address; - N : Natural; - E : Bits_12; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_12; diff --git a/gcc/ada/s-pack13.adb b/gcc/ada/s-pack13.adb deleted file mode 100644 index 0970d69..0000000 --- a/gcc/ada/s-pack13.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_13 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_13; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_13 -- - ------------ - - function Get_13 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_13 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_13; - - ------------ - -- Set_13 -- - ------------ - - procedure Set_13 - (Arr : System.Address; - N : Natural; - E : Bits_13; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_13; - -end System.Pack_13; diff --git a/gcc/ada/s-pack13.ads b/gcc/ada/s-pack13.ads deleted file mode 100644 index f58fbf7..0000000 --- a/gcc/ada/s-pack13.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 13 - -package System.Pack_13 is - pragma Preelaborate; - - Bits : constant := 13; - - type Bits_13 is mod 2 ** Bits; - for Bits_13'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_13 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_13 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_13 - (Arr : System.Address; - N : Natural; - E : Bits_13; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_13; diff --git a/gcc/ada/s-pack14.adb b/gcc/ada/s-pack14.adb deleted file mode 100644 index 8cae0d7..0000000 --- a/gcc/ada/s-pack14.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_14 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_14; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_14 or SetU_14 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_14 -- - ------------ - - function Get_14 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_14 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_14; - - ------------- - -- GetU_14 -- - ------------- - - function GetU_14 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_14 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_14; - - ------------ - -- Set_14 -- - ------------ - - procedure Set_14 - (Arr : System.Address; - N : Natural; - E : Bits_14; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_14; - - ------------- - -- SetU_14 -- - ------------- - - procedure SetU_14 - (Arr : System.Address; - N : Natural; - E : Bits_14; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_14; - -end System.Pack_14; diff --git a/gcc/ada/s-pack14.ads b/gcc/ada/s-pack14.ads deleted file mode 100644 index 72cd783..0000000 --- a/gcc/ada/s-pack14.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 14 - -package System.Pack_14 is - pragma Preelaborate; - - Bits : constant := 14; - - type Bits_14 is mod 2 ** Bits; - for Bits_14'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_14 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_14 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_14 - (Arr : System.Address; - N : Natural; - E : Bits_14; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_14 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_14 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_14 - (Arr : System.Address; - N : Natural; - E : Bits_14; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_14; diff --git a/gcc/ada/s-pack15.adb b/gcc/ada/s-pack15.adb deleted file mode 100644 index 4df1841..0000000 --- a/gcc/ada/s-pack15.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_15 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_15; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_15 -- - ------------ - - function Get_15 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_15 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_15; - - ------------ - -- Set_15 -- - ------------ - - procedure Set_15 - (Arr : System.Address; - N : Natural; - E : Bits_15; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_15; - -end System.Pack_15; diff --git a/gcc/ada/s-pack15.ads b/gcc/ada/s-pack15.ads deleted file mode 100644 index 787ca7e..0000000 --- a/gcc/ada/s-pack15.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 15 - -package System.Pack_15 is - pragma Preelaborate; - - Bits : constant := 15; - - type Bits_15 is mod 2 ** Bits; - for Bits_15'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_15 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_15 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_15 - (Arr : System.Address; - N : Natural; - E : Bits_15; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_15; diff --git a/gcc/ada/s-pack17.adb b/gcc/ada/s-pack17.adb deleted file mode 100644 index 0fc4938..0000000 --- a/gcc/ada/s-pack17.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 7 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_17 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_17; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_17 -- - ------------ - - function Get_17 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_17 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_17; - - ------------ - -- Set_17 -- - ------------ - - procedure Set_17 - (Arr : System.Address; - N : Natural; - E : Bits_17; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_17; - -end System.Pack_17; diff --git a/gcc/ada/s-pack17.ads b/gcc/ada/s-pack17.ads deleted file mode 100644 index 9234b1e..0000000 --- a/gcc/ada/s-pack17.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 7 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 17 - -package System.Pack_17 is - pragma Preelaborate; - - Bits : constant := 17; - - type Bits_17 is mod 2 ** Bits; - for Bits_17'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_17 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_17 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_17 - (Arr : System.Address; - N : Natural; - E : Bits_17; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_17; diff --git a/gcc/ada/s-pack18.adb b/gcc/ada/s-pack18.adb deleted file mode 100644 index 5e2e33f..0000000 --- a/gcc/ada/s-pack18.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_18 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_18; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_18 or SetU_18 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_18 -- - ------------ - - function Get_18 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_18 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_18; - - ------------- - -- GetU_18 -- - ------------- - - function GetU_18 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_18 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_18; - - ------------ - -- Set_18 -- - ------------ - - procedure Set_18 - (Arr : System.Address; - N : Natural; - E : Bits_18; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_18; - - ------------- - -- SetU_18 -- - ------------- - - procedure SetU_18 - (Arr : System.Address; - N : Natural; - E : Bits_18; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_18; - -end System.Pack_18; diff --git a/gcc/ada/s-pack18.ads b/gcc/ada/s-pack18.ads deleted file mode 100644 index 051d992..0000000 --- a/gcc/ada/s-pack18.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 18 - -package System.Pack_18 is - pragma Preelaborate; - - Bits : constant := 18; - - type Bits_18 is mod 2 ** Bits; - for Bits_18'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_18 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_18 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_18 - (Arr : System.Address; - N : Natural; - E : Bits_18; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_18 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_18 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_18 - (Arr : System.Address; - N : Natural; - E : Bits_18; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_18; diff --git a/gcc/ada/s-pack19.adb b/gcc/ada/s-pack19.adb deleted file mode 100644 index 3a9c2e7..0000000 --- a/gcc/ada/s-pack19.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 9 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_19 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_19; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_19 -- - ------------ - - function Get_19 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_19 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_19; - - ------------ - -- Set_19 -- - ------------ - - procedure Set_19 - (Arr : System.Address; - N : Natural; - E : Bits_19; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_19; - -end System.Pack_19; diff --git a/gcc/ada/s-pack19.ads b/gcc/ada/s-pack19.ads deleted file mode 100644 index 03dedb4..0000000 --- a/gcc/ada/s-pack19.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 1 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 19 - -package System.Pack_19 is - pragma Preelaborate; - - Bits : constant := 19; - - type Bits_19 is mod 2 ** Bits; - for Bits_19'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_19 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_19 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_19 - (Arr : System.Address; - N : Natural; - E : Bits_19; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_19; diff --git a/gcc/ada/s-pack20.adb b/gcc/ada/s-pack20.adb deleted file mode 100644 index b0b9b4b..0000000 --- a/gcc/ada/s-pack20.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 0 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_20 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_20; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_20 or SetU_20 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_20 -- - ------------ - - function Get_20 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_20 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_20; - - ------------- - -- GetU_20 -- - ------------- - - function GetU_20 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_20 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_20; - - ------------ - -- Set_20 -- - ------------ - - procedure Set_20 - (Arr : System.Address; - N : Natural; - E : Bits_20; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_20; - - ------------- - -- SetU_20 -- - ------------- - - procedure SetU_20 - (Arr : System.Address; - N : Natural; - E : Bits_20; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_20; - -end System.Pack_20; diff --git a/gcc/ada/s-pack20.ads b/gcc/ada/s-pack20.ads deleted file mode 100644 index e75f828..0000000 --- a/gcc/ada/s-pack20.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 0 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 20 - -package System.Pack_20 is - pragma Preelaborate; - - Bits : constant := 20; - - type Bits_20 is mod 2 ** Bits; - for Bits_20'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_20 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_20 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_20 - (Arr : System.Address; - N : Natural; - E : Bits_20; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_20 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_20 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_20 - (Arr : System.Address; - N : Natural; - E : Bits_20; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_20; diff --git a/gcc/ada/s-pack21.adb b/gcc/ada/s-pack21.adb deleted file mode 100644 index 8357a69..0000000 --- a/gcc/ada/s-pack21.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_21 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_21; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_21 -- - ------------ - - function Get_21 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_21 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_21; - - ------------ - -- Set_21 -- - ------------ - - procedure Set_21 - (Arr : System.Address; - N : Natural; - E : Bits_21; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_21; - -end System.Pack_21; diff --git a/gcc/ada/s-pack21.ads b/gcc/ada/s-pack21.ads deleted file mode 100644 index 0454df0..0000000 --- a/gcc/ada/s-pack21.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 21 - -package System.Pack_21 is - pragma Preelaborate; - - Bits : constant := 21; - - type Bits_21 is mod 2 ** Bits; - for Bits_21'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_21 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_21 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_21 - (Arr : System.Address; - N : Natural; - E : Bits_21; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_21; diff --git a/gcc/ada/s-pack22.adb b/gcc/ada/s-pack22.adb deleted file mode 100644 index ae27d67..0000000 --- a/gcc/ada/s-pack22.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_22 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_22; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_22 or SetU_22 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_22 -- - ------------ - - function Get_22 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_22 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_22; - - ------------- - -- GetU_22 -- - ------------- - - function GetU_22 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_22 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_22; - - ------------ - -- Set_22 -- - ------------ - - procedure Set_22 - (Arr : System.Address; - N : Natural; - E : Bits_22; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_22; - - ------------- - -- SetU_22 -- - ------------- - - procedure SetU_22 - (Arr : System.Address; - N : Natural; - E : Bits_22; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_22; - -end System.Pack_22; diff --git a/gcc/ada/s-pack22.ads b/gcc/ada/s-pack22.ads deleted file mode 100644 index 7504ba8..0000000 --- a/gcc/ada/s-pack22.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 22 - -package System.Pack_22 is - pragma Preelaborate; - - Bits : constant := 22; - - type Bits_22 is mod 2 ** Bits; - for Bits_22'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_22 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_22 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_22 - (Arr : System.Address; - N : Natural; - E : Bits_22; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_22 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_22 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_22 - (Arr : System.Address; - N : Natural; - E : Bits_22; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_22; diff --git a/gcc/ada/s-pack23.adb b/gcc/ada/s-pack23.adb deleted file mode 100644 index 85f4af9..0000000 --- a/gcc/ada/s-pack23.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_23 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_23; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_23 -- - ------------ - - function Get_23 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_23 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_23; - - ------------ - -- Set_23 -- - ------------ - - procedure Set_23 - (Arr : System.Address; - N : Natural; - E : Bits_23; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_23; - -end System.Pack_23; diff --git a/gcc/ada/s-pack23.ads b/gcc/ada/s-pack23.ads deleted file mode 100644 index 9057453..0000000 --- a/gcc/ada/s-pack23.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 23 - -package System.Pack_23 is - pragma Preelaborate; - - Bits : constant := 23; - - type Bits_23 is mod 2 ** Bits; - for Bits_23'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_23 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_23 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_23 - (Arr : System.Address; - N : Natural; - E : Bits_23; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_23; diff --git a/gcc/ada/s-pack24.adb b/gcc/ada/s-pack24.adb deleted file mode 100644 index 96cbabf..0000000 --- a/gcc/ada/s-pack24.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_24 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_24; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_24 or SetU_24 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_24 -- - ------------ - - function Get_24 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_24 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_24; - - ------------- - -- GetU_24 -- - ------------- - - function GetU_24 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_24 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_24; - - ------------ - -- Set_24 -- - ------------ - - procedure Set_24 - (Arr : System.Address; - N : Natural; - E : Bits_24; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_24; - - ------------- - -- SetU_24 -- - ------------- - - procedure SetU_24 - (Arr : System.Address; - N : Natural; - E : Bits_24; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_24; - -end System.Pack_24; diff --git a/gcc/ada/s-pack24.ads b/gcc/ada/s-pack24.ads deleted file mode 100644 index fde2fa3..0000000 --- a/gcc/ada/s-pack24.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 24 - -package System.Pack_24 is - pragma Preelaborate; - - Bits : constant := 24; - - type Bits_24 is mod 2 ** Bits; - for Bits_24'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_24 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_24 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_24 - (Arr : System.Address; - N : Natural; - E : Bits_24; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_24 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_24 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_24 - (Arr : System.Address; - N : Natural; - E : Bits_24; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_24; diff --git a/gcc/ada/s-pack25.adb b/gcc/ada/s-pack25.adb deleted file mode 100644 index e3df996..0000000 --- a/gcc/ada/s-pack25.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_25 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_25; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_25 -- - ------------ - - function Get_25 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_25 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_25; - - ------------ - -- Set_25 -- - ------------ - - procedure Set_25 - (Arr : System.Address; - N : Natural; - E : Bits_25; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_25; - -end System.Pack_25; diff --git a/gcc/ada/s-pack25.ads b/gcc/ada/s-pack25.ads deleted file mode 100644 index d59beeb..0000000 --- a/gcc/ada/s-pack25.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 25 - -package System.Pack_25 is - pragma Preelaborate; - - Bits : constant := 25; - - type Bits_25 is mod 2 ** Bits; - for Bits_25'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_25 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_25 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_25 - (Arr : System.Address; - N : Natural; - E : Bits_25; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_25; diff --git a/gcc/ada/s-pack26.adb b/gcc/ada/s-pack26.adb deleted file mode 100644 index d7edc14..0000000 --- a/gcc/ada/s-pack26.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_26 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_26; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_26 or SetU_26 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_26 -- - ------------ - - function Get_26 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_26 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_26; - - ------------- - -- GetU_26 -- - ------------- - - function GetU_26 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_26 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_26; - - ------------ - -- Set_26 -- - ------------ - - procedure Set_26 - (Arr : System.Address; - N : Natural; - E : Bits_26; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_26; - - ------------- - -- SetU_26 -- - ------------- - - procedure SetU_26 - (Arr : System.Address; - N : Natural; - E : Bits_26; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_26; - -end System.Pack_26; diff --git a/gcc/ada/s-pack26.ads b/gcc/ada/s-pack26.ads deleted file mode 100644 index 979e892..0000000 --- a/gcc/ada/s-pack26.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 26 - -package System.Pack_26 is - pragma Preelaborate; - - Bits : constant := 26; - - type Bits_26 is mod 2 ** Bits; - for Bits_26'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_26 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_26 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_26 - (Arr : System.Address; - N : Natural; - E : Bits_26; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_26 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_26 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_26 - (Arr : System.Address; - N : Natural; - E : Bits_26; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_26; diff --git a/gcc/ada/s-pack27.adb b/gcc/ada/s-pack27.adb deleted file mode 100644 index 0a15d87..0000000 --- a/gcc/ada/s-pack27.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 7 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_27 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_27; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_27 -- - ------------ - - function Get_27 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_27 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_27; - - ------------ - -- Set_27 -- - ------------ - - procedure Set_27 - (Arr : System.Address; - N : Natural; - E : Bits_27; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_27; - -end System.Pack_27; diff --git a/gcc/ada/s-pack27.ads b/gcc/ada/s-pack27.ads deleted file mode 100644 index da77d57..0000000 --- a/gcc/ada/s-pack27.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 7 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 27 - -package System.Pack_27 is - pragma Preelaborate; - - Bits : constant := 27; - - type Bits_27 is mod 2 ** Bits; - for Bits_27'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_27 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_27 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_27 - (Arr : System.Address; - N : Natural; - E : Bits_27; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_27; diff --git a/gcc/ada/s-pack28.adb b/gcc/ada/s-pack28.adb deleted file mode 100644 index 35daf6d..0000000 --- a/gcc/ada/s-pack28.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_28 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_28; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_28 or SetU_28 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_28 -- - ------------ - - function Get_28 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_28 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_28; - - ------------- - -- GetU_28 -- - ------------- - - function GetU_28 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_28 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_28; - - ------------ - -- Set_28 -- - ------------ - - procedure Set_28 - (Arr : System.Address; - N : Natural; - E : Bits_28; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_28; - - ------------- - -- SetU_28 -- - ------------- - - procedure SetU_28 - (Arr : System.Address; - N : Natural; - E : Bits_28; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_28; - -end System.Pack_28; diff --git a/gcc/ada/s-pack28.ads b/gcc/ada/s-pack28.ads deleted file mode 100644 index 996ff25..0000000 --- a/gcc/ada/s-pack28.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 28 - -package System.Pack_28 is - pragma Preelaborate; - - Bits : constant := 28; - - type Bits_28 is mod 2 ** Bits; - for Bits_28'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_28 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_28 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_28 - (Arr : System.Address; - N : Natural; - E : Bits_28; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_28 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_28 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_28 - (Arr : System.Address; - N : Natural; - E : Bits_28; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_28; diff --git a/gcc/ada/s-pack29.adb b/gcc/ada/s-pack29.adb deleted file mode 100644 index 73bc62f..0000000 --- a/gcc/ada/s-pack29.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 9 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_29 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_29; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_29 -- - ------------ - - function Get_29 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_29 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_29; - - ------------ - -- Set_29 -- - ------------ - - procedure Set_29 - (Arr : System.Address; - N : Natural; - E : Bits_29; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_29; - -end System.Pack_29; diff --git a/gcc/ada/s-pack29.ads b/gcc/ada/s-pack29.ads deleted file mode 100644 index 47bcb23..0000000 --- a/gcc/ada/s-pack29.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 2 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 29 - -package System.Pack_29 is - pragma Preelaborate; - - Bits : constant := 29; - - type Bits_29 is mod 2 ** Bits; - for Bits_29'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_29 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_29 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_29 - (Arr : System.Address; - N : Natural; - E : Bits_29; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_29; diff --git a/gcc/ada/s-pack30.adb b/gcc/ada/s-pack30.adb deleted file mode 100644 index ceab502..0000000 --- a/gcc/ada/s-pack30.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 0 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_30 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_30; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_30 or SetU_30 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_30 -- - ------------ - - function Get_30 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_30 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_30; - - ------------- - -- GetU_30 -- - ------------- - - function GetU_30 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_30 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_30; - - ------------ - -- Set_30 -- - ------------ - - procedure Set_30 - (Arr : System.Address; - N : Natural; - E : Bits_30; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_30; - - ------------- - -- SetU_30 -- - ------------- - - procedure SetU_30 - (Arr : System.Address; - N : Natural; - E : Bits_30; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_30; - -end System.Pack_30; diff --git a/gcc/ada/s-pack30.ads b/gcc/ada/s-pack30.ads deleted file mode 100644 index aa85850..0000000 --- a/gcc/ada/s-pack30.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 0 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 30 - -package System.Pack_30 is - pragma Preelaborate; - - Bits : constant := 30; - - type Bits_30 is mod 2 ** Bits; - for Bits_30'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_30 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_30 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_30 - (Arr : System.Address; - N : Natural; - E : Bits_30; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_30 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_30 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_30 - (Arr : System.Address; - N : Natural; - E : Bits_30; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_30; diff --git a/gcc/ada/s-pack31.adb b/gcc/ada/s-pack31.adb deleted file mode 100644 index d0eada3..0000000 --- a/gcc/ada/s-pack31.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_31 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_31; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_31 -- - ------------ - - function Get_31 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_31 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_31; - - ------------ - -- Set_31 -- - ------------ - - procedure Set_31 - (Arr : System.Address; - N : Natural; - E : Bits_31; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_31; - -end System.Pack_31; diff --git a/gcc/ada/s-pack31.ads b/gcc/ada/s-pack31.ads deleted file mode 100644 index 5667e6f..0000000 --- a/gcc/ada/s-pack31.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 31 - -package System.Pack_31 is - pragma Preelaborate; - - Bits : constant := 31; - - type Bits_31 is mod 2 ** Bits; - for Bits_31'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_31 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_31 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_31 - (Arr : System.Address; - N : Natural; - E : Bits_31; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_31; diff --git a/gcc/ada/s-pack33.adb b/gcc/ada/s-pack33.adb deleted file mode 100644 index 0cbbf65..0000000 --- a/gcc/ada/s-pack33.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_33 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_33; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_33 -- - ------------ - - function Get_33 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_33 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_33; - - ------------ - -- Set_33 -- - ------------ - - procedure Set_33 - (Arr : System.Address; - N : Natural; - E : Bits_33; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_33; - -end System.Pack_33; diff --git a/gcc/ada/s-pack33.ads b/gcc/ada/s-pack33.ads deleted file mode 100644 index 085298b..0000000 --- a/gcc/ada/s-pack33.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 33 - -package System.Pack_33 is - pragma Preelaborate; - - Bits : constant := 33; - - type Bits_33 is mod 2 ** Bits; - for Bits_33'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_33 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_33 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_33 - (Arr : System.Address; - N : Natural; - E : Bits_33; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_33; diff --git a/gcc/ada/s-pack34.adb b/gcc/ada/s-pack34.adb deleted file mode 100644 index b97c63d..0000000 --- a/gcc/ada/s-pack34.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_34 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_34; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_34 or SetU_34 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_34 -- - ------------ - - function Get_34 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_34 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_34; - - ------------- - -- GetU_34 -- - ------------- - - function GetU_34 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_34 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_34; - - ------------ - -- Set_34 -- - ------------ - - procedure Set_34 - (Arr : System.Address; - N : Natural; - E : Bits_34; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_34; - - ------------- - -- SetU_34 -- - ------------- - - procedure SetU_34 - (Arr : System.Address; - N : Natural; - E : Bits_34; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_34; - -end System.Pack_34; diff --git a/gcc/ada/s-pack34.ads b/gcc/ada/s-pack34.ads deleted file mode 100644 index 668f806..0000000 --- a/gcc/ada/s-pack34.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 34 - -package System.Pack_34 is - pragma Preelaborate; - - Bits : constant := 34; - - type Bits_34 is mod 2 ** Bits; - for Bits_34'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_34 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_34 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_34 - (Arr : System.Address; - N : Natural; - E : Bits_34; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_34 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_34 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_34 - (Arr : System.Address; - N : Natural; - E : Bits_34; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_34; diff --git a/gcc/ada/s-pack35.adb b/gcc/ada/s-pack35.adb deleted file mode 100644 index 98bbd85..0000000 --- a/gcc/ada/s-pack35.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_35 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_35; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_35 -- - ------------ - - function Get_35 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_35 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_35; - - ------------ - -- Set_35 -- - ------------ - - procedure Set_35 - (Arr : System.Address; - N : Natural; - E : Bits_35; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_35; - -end System.Pack_35; diff --git a/gcc/ada/s-pack35.ads b/gcc/ada/s-pack35.ads deleted file mode 100644 index a1e8e0c..0000000 --- a/gcc/ada/s-pack35.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 35 - -package System.Pack_35 is - pragma Preelaborate; - - Bits : constant := 35; - - type Bits_35 is mod 2 ** Bits; - for Bits_35'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_35 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_35 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_35 - (Arr : System.Address; - N : Natural; - E : Bits_35; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_35; diff --git a/gcc/ada/s-pack36.adb b/gcc/ada/s-pack36.adb deleted file mode 100644 index 9303a50..0000000 --- a/gcc/ada/s-pack36.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_36 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_36; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_36 or SetU_36 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_36 -- - ------------ - - function Get_36 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_36 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_36; - - ------------- - -- GetU_36 -- - ------------- - - function GetU_36 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_36 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_36; - - ------------ - -- Set_36 -- - ------------ - - procedure Set_36 - (Arr : System.Address; - N : Natural; - E : Bits_36; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_36; - - ------------- - -- SetU_36 -- - ------------- - - procedure SetU_36 - (Arr : System.Address; - N : Natural; - E : Bits_36; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_36; - -end System.Pack_36; diff --git a/gcc/ada/s-pack36.ads b/gcc/ada/s-pack36.ads deleted file mode 100644 index 456c7fa..0000000 --- a/gcc/ada/s-pack36.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 36 - -package System.Pack_36 is - pragma Preelaborate; - - Bits : constant := 36; - - type Bits_36 is mod 2 ** Bits; - for Bits_36'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_36 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_36 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_36 - (Arr : System.Address; - N : Natural; - E : Bits_36; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_36 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_36 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_36 - (Arr : System.Address; - N : Natural; - E : Bits_36; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_36; diff --git a/gcc/ada/s-pack37.adb b/gcc/ada/s-pack37.adb deleted file mode 100644 index ec4a21a..0000000 --- a/gcc/ada/s-pack37.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 7 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_37 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_37; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_37 -- - ------------ - - function Get_37 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_37 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_37; - - ------------ - -- Set_37 -- - ------------ - - procedure Set_37 - (Arr : System.Address; - N : Natural; - E : Bits_37; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_37; - -end System.Pack_37; diff --git a/gcc/ada/s-pack37.ads b/gcc/ada/s-pack37.ads deleted file mode 100644 index 8b80843..0000000 --- a/gcc/ada/s-pack37.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 7 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 37 - -package System.Pack_37 is - pragma Preelaborate; - - Bits : constant := 37; - - type Bits_37 is mod 2 ** Bits; - for Bits_37'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_37 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_37 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_37 - (Arr : System.Address; - N : Natural; - E : Bits_37; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_37; diff --git a/gcc/ada/s-pack38.adb b/gcc/ada/s-pack38.adb deleted file mode 100644 index b12166e..0000000 --- a/gcc/ada/s-pack38.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_38 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_38; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_38 or SetU_38 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_38 -- - ------------ - - function Get_38 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_38 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_38; - - ------------- - -- GetU_38 -- - ------------- - - function GetU_38 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_38 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_38; - - ------------ - -- Set_38 -- - ------------ - - procedure Set_38 - (Arr : System.Address; - N : Natural; - E : Bits_38; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_38; - - ------------- - -- SetU_38 -- - ------------- - - procedure SetU_38 - (Arr : System.Address; - N : Natural; - E : Bits_38; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_38; - -end System.Pack_38; diff --git a/gcc/ada/s-pack38.ads b/gcc/ada/s-pack38.ads deleted file mode 100644 index f2a9889..0000000 --- a/gcc/ada/s-pack38.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 38 - -package System.Pack_38 is - pragma Preelaborate; - - Bits : constant := 38; - - type Bits_38 is mod 2 ** Bits; - for Bits_38'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_38 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_38 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_38 - (Arr : System.Address; - N : Natural; - E : Bits_38; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_38 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_38 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_38 - (Arr : System.Address; - N : Natural; - E : Bits_38; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_38; diff --git a/gcc/ada/s-pack39.adb b/gcc/ada/s-pack39.adb deleted file mode 100644 index 85c942a..0000000 --- a/gcc/ada/s-pack39.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 9 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_39 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_39; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_39 -- - ------------ - - function Get_39 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_39 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_39; - - ------------ - -- Set_39 -- - ------------ - - procedure Set_39 - (Arr : System.Address; - N : Natural; - E : Bits_39; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_39; - -end System.Pack_39; diff --git a/gcc/ada/s-pack39.ads b/gcc/ada/s-pack39.ads deleted file mode 100644 index 8ba083d..0000000 --- a/gcc/ada/s-pack39.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 3 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 39 - -package System.Pack_39 is - pragma Preelaborate; - - Bits : constant := 39; - - type Bits_39 is mod 2 ** Bits; - for Bits_39'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_39 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_39 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_39 - (Arr : System.Address; - N : Natural; - E : Bits_39; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_39; diff --git a/gcc/ada/s-pack40.adb b/gcc/ada/s-pack40.adb deleted file mode 100644 index 993fc95..0000000 --- a/gcc/ada/s-pack40.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 0 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_40 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_40; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_40 or SetU_40 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_40 -- - ------------ - - function Get_40 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_40 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_40; - - ------------- - -- GetU_40 -- - ------------- - - function GetU_40 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_40 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_40; - - ------------ - -- Set_40 -- - ------------ - - procedure Set_40 - (Arr : System.Address; - N : Natural; - E : Bits_40; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_40; - - ------------- - -- SetU_40 -- - ------------- - - procedure SetU_40 - (Arr : System.Address; - N : Natural; - E : Bits_40; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_40; - -end System.Pack_40; diff --git a/gcc/ada/s-pack40.ads b/gcc/ada/s-pack40.ads deleted file mode 100644 index 1f30ee3..0000000 --- a/gcc/ada/s-pack40.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 0 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 40 - -package System.Pack_40 is - pragma Preelaborate; - - Bits : constant := 40; - - type Bits_40 is mod 2 ** Bits; - for Bits_40'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_40 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_40 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_40 - (Arr : System.Address; - N : Natural; - E : Bits_40; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_40 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_40 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_40 - (Arr : System.Address; - N : Natural; - E : Bits_40; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_40; diff --git a/gcc/ada/s-pack41.adb b/gcc/ada/s-pack41.adb deleted file mode 100644 index dd580c0..0000000 --- a/gcc/ada/s-pack41.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_41 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_41; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_41 -- - ------------ - - function Get_41 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_41 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_41; - - ------------ - -- Set_41 -- - ------------ - - procedure Set_41 - (Arr : System.Address; - N : Natural; - E : Bits_41; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_41; - -end System.Pack_41; diff --git a/gcc/ada/s-pack41.ads b/gcc/ada/s-pack41.ads deleted file mode 100644 index 8dcae70..0000000 --- a/gcc/ada/s-pack41.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 41 - -package System.Pack_41 is - pragma Preelaborate; - - Bits : constant := 41; - - type Bits_41 is mod 2 ** Bits; - for Bits_41'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_41 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_41 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_41 - (Arr : System.Address; - N : Natural; - E : Bits_41; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_41; diff --git a/gcc/ada/s-pack42.adb b/gcc/ada/s-pack42.adb deleted file mode 100644 index bc8285a..0000000 --- a/gcc/ada/s-pack42.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_42 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_42; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_42 or SetU_42 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_42 -- - ------------ - - function Get_42 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_42 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_42; - - ------------- - -- GetU_42 -- - ------------- - - function GetU_42 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_42 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_42; - - ------------ - -- Set_42 -- - ------------ - - procedure Set_42 - (Arr : System.Address; - N : Natural; - E : Bits_42; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_42; - - ------------- - -- SetU_42 -- - ------------- - - procedure SetU_42 - (Arr : System.Address; - N : Natural; - E : Bits_42; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_42; - -end System.Pack_42; diff --git a/gcc/ada/s-pack42.ads b/gcc/ada/s-pack42.ads deleted file mode 100644 index 73872fd..0000000 --- a/gcc/ada/s-pack42.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 42 - -package System.Pack_42 is - pragma Preelaborate; - - Bits : constant := 42; - - type Bits_42 is mod 2 ** Bits; - for Bits_42'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_42 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_42 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_42 - (Arr : System.Address; - N : Natural; - E : Bits_42; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_42 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_42 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_42 - (Arr : System.Address; - N : Natural; - E : Bits_42; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_42; diff --git a/gcc/ada/s-pack43.adb b/gcc/ada/s-pack43.adb deleted file mode 100644 index 509cb00..0000000 --- a/gcc/ada/s-pack43.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_43 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_43; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_43 -- - ------------ - - function Get_43 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_43 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_43; - - ------------ - -- Set_43 -- - ------------ - - procedure Set_43 - (Arr : System.Address; - N : Natural; - E : Bits_43; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_43; - -end System.Pack_43; diff --git a/gcc/ada/s-pack43.ads b/gcc/ada/s-pack43.ads deleted file mode 100644 index f82678f..0000000 --- a/gcc/ada/s-pack43.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 43 - -package System.Pack_43 is - pragma Preelaborate; - - Bits : constant := 43; - - type Bits_43 is mod 2 ** Bits; - for Bits_43'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_43 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_43 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_43 - (Arr : System.Address; - N : Natural; - E : Bits_43; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_43; diff --git a/gcc/ada/s-pack44.adb b/gcc/ada/s-pack44.adb deleted file mode 100644 index f7fe185..0000000 --- a/gcc/ada/s-pack44.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_44 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_44; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_44 or SetU_44 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_44 -- - ------------ - - function Get_44 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_44 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_44; - - ------------- - -- GetU_44 -- - ------------- - - function GetU_44 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_44 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_44; - - ------------ - -- Set_44 -- - ------------ - - procedure Set_44 - (Arr : System.Address; - N : Natural; - E : Bits_44; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_44; - - ------------- - -- SetU_44 -- - ------------- - - procedure SetU_44 - (Arr : System.Address; - N : Natural; - E : Bits_44; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_44; - -end System.Pack_44; diff --git a/gcc/ada/s-pack44.ads b/gcc/ada/s-pack44.ads deleted file mode 100644 index 89b3f3e..0000000 --- a/gcc/ada/s-pack44.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 44 - -package System.Pack_44 is - pragma Preelaborate; - - Bits : constant := 44; - - type Bits_44 is mod 2 ** Bits; - for Bits_44'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_44 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_44 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_44 - (Arr : System.Address; - N : Natural; - E : Bits_44; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_44 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_44 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_44 - (Arr : System.Address; - N : Natural; - E : Bits_44; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_44; diff --git a/gcc/ada/s-pack45.adb b/gcc/ada/s-pack45.adb deleted file mode 100644 index 2247312..0000000 --- a/gcc/ada/s-pack45.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_45 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_45; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_45 -- - ------------ - - function Get_45 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_45 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_45; - - ------------ - -- Set_45 -- - ------------ - - procedure Set_45 - (Arr : System.Address; - N : Natural; - E : Bits_45; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_45; - -end System.Pack_45; diff --git a/gcc/ada/s-pack45.ads b/gcc/ada/s-pack45.ads deleted file mode 100644 index 2340d48..0000000 --- a/gcc/ada/s-pack45.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 45 - -package System.Pack_45 is - pragma Preelaborate; - - Bits : constant := 45; - - type Bits_45 is mod 2 ** Bits; - for Bits_45'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_45 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_45 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_45 - (Arr : System.Address; - N : Natural; - E : Bits_45; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_45; diff --git a/gcc/ada/s-pack46.adb b/gcc/ada/s-pack46.adb deleted file mode 100644 index c2b45f0..0000000 --- a/gcc/ada/s-pack46.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_46 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_46; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_46 or SetU_46 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_46 -- - ------------ - - function Get_46 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_46 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_46; - - ------------- - -- GetU_46 -- - ------------- - - function GetU_46 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_46 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_46; - - ------------ - -- Set_46 -- - ------------ - - procedure Set_46 - (Arr : System.Address; - N : Natural; - E : Bits_46; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_46; - - ------------- - -- SetU_46 -- - ------------- - - procedure SetU_46 - (Arr : System.Address; - N : Natural; - E : Bits_46; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_46; - -end System.Pack_46; diff --git a/gcc/ada/s-pack46.ads b/gcc/ada/s-pack46.ads deleted file mode 100644 index 6ab8dfe..0000000 --- a/gcc/ada/s-pack46.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 46 - -package System.Pack_46 is - pragma Preelaborate; - - Bits : constant := 46; - - type Bits_46 is mod 2 ** Bits; - for Bits_46'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_46 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_46 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_46 - (Arr : System.Address; - N : Natural; - E : Bits_46; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_46 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_46 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_46 - (Arr : System.Address; - N : Natural; - E : Bits_46; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_46; diff --git a/gcc/ada/s-pack47.adb b/gcc/ada/s-pack47.adb deleted file mode 100644 index d63e35d..0000000 --- a/gcc/ada/s-pack47.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 7 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_47 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_47; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_47 -- - ------------ - - function Get_47 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_47 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_47; - - ------------ - -- Set_47 -- - ------------ - - procedure Set_47 - (Arr : System.Address; - N : Natural; - E : Bits_47; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_47; - -end System.Pack_47; diff --git a/gcc/ada/s-pack47.ads b/gcc/ada/s-pack47.ads deleted file mode 100644 index f924965..0000000 --- a/gcc/ada/s-pack47.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 7 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 47 - -package System.Pack_47 is - pragma Preelaborate; - - Bits : constant := 47; - - type Bits_47 is mod 2 ** Bits; - for Bits_47'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_47 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_47 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_47 - (Arr : System.Address; - N : Natural; - E : Bits_47; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_47; diff --git a/gcc/ada/s-pack48.adb b/gcc/ada/s-pack48.adb deleted file mode 100644 index 780a157..0000000 --- a/gcc/ada/s-pack48.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_48 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_48; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_48 or SetU_48 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_48 -- - ------------ - - function Get_48 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_48 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_48; - - ------------- - -- GetU_48 -- - ------------- - - function GetU_48 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_48 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_48; - - ------------ - -- Set_48 -- - ------------ - - procedure Set_48 - (Arr : System.Address; - N : Natural; - E : Bits_48; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_48; - - ------------- - -- SetU_48 -- - ------------- - - procedure SetU_48 - (Arr : System.Address; - N : Natural; - E : Bits_48; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_48; - -end System.Pack_48; diff --git a/gcc/ada/s-pack48.ads b/gcc/ada/s-pack48.ads deleted file mode 100644 index ba1008e..0000000 --- a/gcc/ada/s-pack48.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 48 - -package System.Pack_48 is - pragma Preelaborate; - - Bits : constant := 48; - - type Bits_48 is mod 2 ** Bits; - for Bits_48'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_48 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_48 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_48 - (Arr : System.Address; - N : Natural; - E : Bits_48; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_48 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_48 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_48 - (Arr : System.Address; - N : Natural; - E : Bits_48; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_48; diff --git a/gcc/ada/s-pack49.adb b/gcc/ada/s-pack49.adb deleted file mode 100644 index a9cad23..0000000 --- a/gcc/ada/s-pack49.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 9 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_49 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_49; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_49 -- - ------------ - - function Get_49 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_49 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_49; - - ------------ - -- Set_49 -- - ------------ - - procedure Set_49 - (Arr : System.Address; - N : Natural; - E : Bits_49; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_49; - -end System.Pack_49; diff --git a/gcc/ada/s-pack49.ads b/gcc/ada/s-pack49.ads deleted file mode 100644 index 649e550..0000000 --- a/gcc/ada/s-pack49.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 4 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 49 - -package System.Pack_49 is - pragma Preelaborate; - - Bits : constant := 49; - - type Bits_49 is mod 2 ** Bits; - for Bits_49'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_49 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_49 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_49 - (Arr : System.Address; - N : Natural; - E : Bits_49; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_49; diff --git a/gcc/ada/s-pack50.adb b/gcc/ada/s-pack50.adb deleted file mode 100644 index 7cc04e6..0000000 --- a/gcc/ada/s-pack50.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 0 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_50 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_50; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_50 or SetU_50 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_50 -- - ------------ - - function Get_50 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_50 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_50; - - ------------- - -- GetU_50 -- - ------------- - - function GetU_50 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_50 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_50; - - ------------ - -- Set_50 -- - ------------ - - procedure Set_50 - (Arr : System.Address; - N : Natural; - E : Bits_50; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_50; - - ------------- - -- SetU_50 -- - ------------- - - procedure SetU_50 - (Arr : System.Address; - N : Natural; - E : Bits_50; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_50; - -end System.Pack_50; diff --git a/gcc/ada/s-pack50.ads b/gcc/ada/s-pack50.ads deleted file mode 100644 index 699165b..0000000 --- a/gcc/ada/s-pack50.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 0 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 50 - -package System.Pack_50 is - pragma Preelaborate; - - Bits : constant := 50; - - type Bits_50 is mod 2 ** Bits; - for Bits_50'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_50 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_50 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_50 - (Arr : System.Address; - N : Natural; - E : Bits_50; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_50 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_50 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_50 - (Arr : System.Address; - N : Natural; - E : Bits_50; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_50; diff --git a/gcc/ada/s-pack51.adb b/gcc/ada/s-pack51.adb deleted file mode 100644 index 5617a98..0000000 --- a/gcc/ada/s-pack51.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_51 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_51; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_51 -- - ------------ - - function Get_51 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_51 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_51; - - ------------ - -- Set_51 -- - ------------ - - procedure Set_51 - (Arr : System.Address; - N : Natural; - E : Bits_51; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_51; - -end System.Pack_51; diff --git a/gcc/ada/s-pack51.ads b/gcc/ada/s-pack51.ads deleted file mode 100644 index 99bdd51..0000000 --- a/gcc/ada/s-pack51.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 51 - -package System.Pack_51 is - pragma Preelaborate; - - Bits : constant := 51; - - type Bits_51 is mod 2 ** Bits; - for Bits_51'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_51 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_51 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_51 - (Arr : System.Address; - N : Natural; - E : Bits_51; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_51; diff --git a/gcc/ada/s-pack52.adb b/gcc/ada/s-pack52.adb deleted file mode 100644 index 5adf132..0000000 --- a/gcc/ada/s-pack52.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_52 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_52; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_52 or SetU_52 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_52 -- - ------------ - - function Get_52 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_52 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_52; - - ------------- - -- GetU_52 -- - ------------- - - function GetU_52 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_52 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_52; - - ------------ - -- Set_52 -- - ------------ - - procedure Set_52 - (Arr : System.Address; - N : Natural; - E : Bits_52; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_52; - - ------------- - -- SetU_52 -- - ------------- - - procedure SetU_52 - (Arr : System.Address; - N : Natural; - E : Bits_52; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_52; - -end System.Pack_52; diff --git a/gcc/ada/s-pack52.ads b/gcc/ada/s-pack52.ads deleted file mode 100644 index fab35ee..0000000 --- a/gcc/ada/s-pack52.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 52 - -package System.Pack_52 is - pragma Preelaborate; - - Bits : constant := 52; - - type Bits_52 is mod 2 ** Bits; - for Bits_52'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_52 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_52 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_52 - (Arr : System.Address; - N : Natural; - E : Bits_52; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_52 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_52 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_52 - (Arr : System.Address; - N : Natural; - E : Bits_52; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_52; diff --git a/gcc/ada/s-pack53.adb b/gcc/ada/s-pack53.adb deleted file mode 100644 index 471d1fc..0000000 --- a/gcc/ada/s-pack53.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_53 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_53; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_53 -- - ------------ - - function Get_53 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_53 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_53; - - ------------ - -- Set_53 -- - ------------ - - procedure Set_53 - (Arr : System.Address; - N : Natural; - E : Bits_53; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_53; - -end System.Pack_53; diff --git a/gcc/ada/s-pack53.ads b/gcc/ada/s-pack53.ads deleted file mode 100644 index 380278c..0000000 --- a/gcc/ada/s-pack53.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 53 - -package System.Pack_53 is - pragma Preelaborate; - - Bits : constant := 53; - - type Bits_53 is mod 2 ** Bits; - for Bits_53'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_53 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_53 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_53 - (Arr : System.Address; - N : Natural; - E : Bits_53; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_53; diff --git a/gcc/ada/s-pack54.adb b/gcc/ada/s-pack54.adb deleted file mode 100644 index 5d02941..0000000 --- a/gcc/ada/s-pack54.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_54 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_54; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_54 or SetU_54 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_54 -- - ------------ - - function Get_54 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_54 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_54; - - ------------- - -- GetU_54 -- - ------------- - - function GetU_54 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_54 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_54; - - ------------ - -- Set_54 -- - ------------ - - procedure Set_54 - (Arr : System.Address; - N : Natural; - E : Bits_54; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_54; - - ------------- - -- SetU_54 -- - ------------- - - procedure SetU_54 - (Arr : System.Address; - N : Natural; - E : Bits_54; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_54; - -end System.Pack_54; diff --git a/gcc/ada/s-pack54.ads b/gcc/ada/s-pack54.ads deleted file mode 100644 index 5ee9a88..0000000 --- a/gcc/ada/s-pack54.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 54 - -package System.Pack_54 is - pragma Preelaborate; - - Bits : constant := 54; - - type Bits_54 is mod 2 ** Bits; - for Bits_54'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_54 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_54 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_54 - (Arr : System.Address; - N : Natural; - E : Bits_54; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_54 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_54 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_54 - (Arr : System.Address; - N : Natural; - E : Bits_54; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_54; diff --git a/gcc/ada/s-pack55.adb b/gcc/ada/s-pack55.adb deleted file mode 100644 index be264e1..0000000 --- a/gcc/ada/s-pack55.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_55 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_55; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_55 -- - ------------ - - function Get_55 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_55 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_55; - - ------------ - -- Set_55 -- - ------------ - - procedure Set_55 - (Arr : System.Address; - N : Natural; - E : Bits_55; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_55; - -end System.Pack_55; diff --git a/gcc/ada/s-pack55.ads b/gcc/ada/s-pack55.ads deleted file mode 100644 index 8dce9fa..0000000 --- a/gcc/ada/s-pack55.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 55 - -package System.Pack_55 is - pragma Preelaborate; - - Bits : constant := 55; - - type Bits_55 is mod 2 ** Bits; - for Bits_55'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_55 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_55 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_55 - (Arr : System.Address; - N : Natural; - E : Bits_55; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_55; diff --git a/gcc/ada/s-pack56.adb b/gcc/ada/s-pack56.adb deleted file mode 100644 index fd34211..0000000 --- a/gcc/ada/s-pack56.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 6 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_56 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_56; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_56 or SetU_56 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_56 -- - ------------ - - function Get_56 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_56 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_56; - - ------------- - -- GetU_56 -- - ------------- - - function GetU_56 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_56 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_56; - - ------------ - -- Set_56 -- - ------------ - - procedure Set_56 - (Arr : System.Address; - N : Natural; - E : Bits_56; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_56; - - ------------- - -- SetU_56 -- - ------------- - - procedure SetU_56 - (Arr : System.Address; - N : Natural; - E : Bits_56; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_56; - -end System.Pack_56; diff --git a/gcc/ada/s-pack56.ads b/gcc/ada/s-pack56.ads deleted file mode 100644 index 5e6578b..0000000 --- a/gcc/ada/s-pack56.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 6 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 56 - -package System.Pack_56 is - pragma Preelaborate; - - Bits : constant := 56; - - type Bits_56 is mod 2 ** Bits; - for Bits_56'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_56 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_56 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_56 - (Arr : System.Address; - N : Natural; - E : Bits_56; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_56 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_56 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_56 - (Arr : System.Address; - N : Natural; - E : Bits_56; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_56; diff --git a/gcc/ada/s-pack57.adb b/gcc/ada/s-pack57.adb deleted file mode 100644 index b477b2e..0000000 --- a/gcc/ada/s-pack57.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 7 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_57 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_57; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_57 -- - ------------ - - function Get_57 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_57 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_57; - - ------------ - -- Set_57 -- - ------------ - - procedure Set_57 - (Arr : System.Address; - N : Natural; - E : Bits_57; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_57; - -end System.Pack_57; diff --git a/gcc/ada/s-pack57.ads b/gcc/ada/s-pack57.ads deleted file mode 100644 index aff3c50..0000000 --- a/gcc/ada/s-pack57.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 7 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 57 - -package System.Pack_57 is - pragma Preelaborate; - - Bits : constant := 57; - - type Bits_57 is mod 2 ** Bits; - for Bits_57'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_57 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_57 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_57 - (Arr : System.Address; - N : Natural; - E : Bits_57; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_57; diff --git a/gcc/ada/s-pack58.adb b/gcc/ada/s-pack58.adb deleted file mode 100644 index 1aeb450..0000000 --- a/gcc/ada/s-pack58.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 8 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_58 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_58; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_58 or SetU_58 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_58 -- - ------------ - - function Get_58 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_58 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_58; - - ------------- - -- GetU_58 -- - ------------- - - function GetU_58 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_58 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_58; - - ------------ - -- Set_58 -- - ------------ - - procedure Set_58 - (Arr : System.Address; - N : Natural; - E : Bits_58; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_58; - - ------------- - -- SetU_58 -- - ------------- - - procedure SetU_58 - (Arr : System.Address; - N : Natural; - E : Bits_58; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_58; - -end System.Pack_58; diff --git a/gcc/ada/s-pack58.ads b/gcc/ada/s-pack58.ads deleted file mode 100644 index 503d990..0000000 --- a/gcc/ada/s-pack58.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 8 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 58 - -package System.Pack_58 is - pragma Preelaborate; - - Bits : constant := 58; - - type Bits_58 is mod 2 ** Bits; - for Bits_58'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_58 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_58 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_58 - (Arr : System.Address; - N : Natural; - E : Bits_58; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_58 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_58 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_58 - (Arr : System.Address; - N : Natural; - E : Bits_58; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_58; diff --git a/gcc/ada/s-pack59.adb b/gcc/ada/s-pack59.adb deleted file mode 100644 index 35199ce..0000000 --- a/gcc/ada/s-pack59.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 9 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_59 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_59; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_59 -- - ------------ - - function Get_59 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_59 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_59; - - ------------ - -- Set_59 -- - ------------ - - procedure Set_59 - (Arr : System.Address; - N : Natural; - E : Bits_59; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_59; - -end System.Pack_59; diff --git a/gcc/ada/s-pack59.ads b/gcc/ada/s-pack59.ads deleted file mode 100644 index 2abbbf2..0000000 --- a/gcc/ada/s-pack59.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 5 9 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 59 - -package System.Pack_59 is - pragma Preelaborate; - - Bits : constant := 59; - - type Bits_59 is mod 2 ** Bits; - for Bits_59'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_59 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_59 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_59 - (Arr : System.Address; - N : Natural; - E : Bits_59; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_59; diff --git a/gcc/ada/s-pack60.adb b/gcc/ada/s-pack60.adb deleted file mode 100644 index e909f71..0000000 --- a/gcc/ada/s-pack60.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 0 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_60 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_60; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_60 or SetU_60 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_60 -- - ------------ - - function Get_60 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_60 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_60; - - ------------- - -- GetU_60 -- - ------------- - - function GetU_60 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_60 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_60; - - ------------ - -- Set_60 -- - ------------ - - procedure Set_60 - (Arr : System.Address; - N : Natural; - E : Bits_60; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_60; - - ------------- - -- SetU_60 -- - ------------- - - procedure SetU_60 - (Arr : System.Address; - N : Natural; - E : Bits_60; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_60; - -end System.Pack_60; diff --git a/gcc/ada/s-pack60.ads b/gcc/ada/s-pack60.ads deleted file mode 100644 index bc48868..0000000 --- a/gcc/ada/s-pack60.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 0 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 60 - -package System.Pack_60 is - pragma Preelaborate; - - Bits : constant := 60; - - type Bits_60 is mod 2 ** Bits; - for Bits_60'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_60 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_60 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_60 - (Arr : System.Address; - N : Natural; - E : Bits_60; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_60 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_60 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_60 - (Arr : System.Address; - N : Natural; - E : Bits_60; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_60; diff --git a/gcc/ada/s-pack61.adb b/gcc/ada/s-pack61.adb deleted file mode 100644 index cd29c81..0000000 --- a/gcc/ada/s-pack61.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 1 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_61 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_61; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_61 -- - ------------ - - function Get_61 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_61 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_61; - - ------------ - -- Set_61 -- - ------------ - - procedure Set_61 - (Arr : System.Address; - N : Natural; - E : Bits_61; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_61; - -end System.Pack_61; diff --git a/gcc/ada/s-pack61.ads b/gcc/ada/s-pack61.ads deleted file mode 100644 index ac309a2..0000000 --- a/gcc/ada/s-pack61.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 1 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 61 - -package System.Pack_61 is - pragma Preelaborate; - - Bits : constant := 61; - - type Bits_61 is mod 2 ** Bits; - for Bits_61'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_61 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_61 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_61 - (Arr : System.Address; - N : Natural; - E : Bits_61; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_61; diff --git a/gcc/ada/s-pack62.adb b/gcc/ada/s-pack62.adb deleted file mode 100644 index b13754d..0000000 --- a/gcc/ada/s-pack62.adb +++ /dev/null @@ -1,250 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_62 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_62; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - -- The following declarations are for the case where the address - -- passed to GetU_62 or SetU_62 is not guaranteed to be aligned. - -- These routines are used when the packed array is itself a - -- component of a packed record, and therefore may not be aligned. - - type ClusterU is new Cluster; - for ClusterU'Alignment use 1; - - type ClusterU_Ref is access ClusterU; - - type Rev_ClusterU is new ClusterU - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_ClusterU_Ref is access Rev_ClusterU; - - ------------ - -- Get_62 -- - ------------ - - function Get_62 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_62 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_62; - - ------------- - -- GetU_62 -- - ------------- - - function GetU_62 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_62 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end GetU_62; - - ------------ - -- Set_62 -- - ------------ - - procedure Set_62 - (Arr : System.Address; - N : Natural; - E : Bits_62; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_62; - - ------------- - -- SetU_62 -- - ------------- - - procedure SetU_62 - (Arr : System.Address; - N : Natural; - E : Bits_62; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : ClusterU_Ref with Address => A'Address, Import; - RC : Rev_ClusterU_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end SetU_62; - -end System.Pack_62; diff --git a/gcc/ada/s-pack62.ads b/gcc/ada/s-pack62.ads deleted file mode 100644 index b8b19f4..0000000 --- a/gcc/ada/s-pack62.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 62 - -package System.Pack_62 is - pragma Preelaborate; - - Bits : constant := 62; - - type Bits_62 is mod 2 ** Bits; - for Bits_62'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_62 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_62 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_62 - (Arr : System.Address; - N : Natural; - E : Bits_62; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - - function GetU_62 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_62 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. This version - -- is used when Arr may represent an unaligned address. - - procedure SetU_62 - (Arr : System.Address; - N : Natural; - E : Bits_62; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. This version - -- is used when Arr may represent an unaligned address - -end System.Pack_62; diff --git a/gcc/ada/s-pack63.adb b/gcc/ada/s-pack63.adb deleted file mode 100644 index 109f914..0000000 --- a/gcc/ada/s-pack63.adb +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Elements; -with System.Unsigned_Types; - -package body System.Pack_63 is - - subtype Bit_Order is System.Bit_Order; - Reverse_Bit_Order : constant Bit_Order := - Bit_Order'Val (1 - Bit_Order'Pos (System.Default_Bit_Order)); - - subtype Ofs is System.Storage_Elements.Storage_Offset; - subtype Uns is System.Unsigned_Types.Unsigned; - subtype N07 is System.Unsigned_Types.Unsigned range 0 .. 7; - - use type System.Storage_Elements.Storage_Offset; - use type System.Unsigned_Types.Unsigned; - - type Cluster is record - E0, E1, E2, E3, E4, E5, E6, E7 : Bits_63; - end record; - - for Cluster use record - E0 at 0 range 0 * Bits .. 0 * Bits + Bits - 1; - E1 at 0 range 1 * Bits .. 1 * Bits + Bits - 1; - E2 at 0 range 2 * Bits .. 2 * Bits + Bits - 1; - E3 at 0 range 3 * Bits .. 3 * Bits + Bits - 1; - E4 at 0 range 4 * Bits .. 4 * Bits + Bits - 1; - E5 at 0 range 5 * Bits .. 5 * Bits + Bits - 1; - E6 at 0 range 6 * Bits .. 6 * Bits + Bits - 1; - E7 at 0 range 7 * Bits .. 7 * Bits + Bits - 1; - end record; - - for Cluster'Size use Bits * 8; - - for Cluster'Alignment use Integer'Min (Standard'Maximum_Alignment, - 1 + - 1 * Boolean'Pos (Bits mod 2 = 0) + - 2 * Boolean'Pos (Bits mod 4 = 0)); - -- Use maximum possible alignment, given the bit field size, since this - -- will result in the most efficient code possible for the field. - - type Cluster_Ref is access Cluster; - - type Rev_Cluster is new Cluster - with Bit_Order => Reverse_Bit_Order, - Scalar_Storage_Order => Reverse_Bit_Order; - type Rev_Cluster_Ref is access Rev_Cluster; - - ------------ - -- Get_63 -- - ------------ - - function Get_63 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_63 - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => return RC.E0; - when 1 => return RC.E1; - when 2 => return RC.E2; - when 3 => return RC.E3; - when 4 => return RC.E4; - when 5 => return RC.E5; - when 6 => return RC.E6; - when 7 => return RC.E7; - end case; - - else - case N07 (Uns (N) mod 8) is - when 0 => return C.E0; - when 1 => return C.E1; - when 2 => return C.E2; - when 3 => return C.E3; - when 4 => return C.E4; - when 5 => return C.E5; - when 6 => return C.E6; - when 7 => return C.E7; - end case; - end if; - end Get_63; - - ------------ - -- Set_63 -- - ------------ - - procedure Set_63 - (Arr : System.Address; - N : Natural; - E : Bits_63; - Rev_SSO : Boolean) - is - A : constant System.Address := Arr + Bits * Ofs (Uns (N) / 8); - C : Cluster_Ref with Address => A'Address, Import; - RC : Rev_Cluster_Ref with Address => A'Address, Import; - begin - if Rev_SSO then - case N07 (Uns (N) mod 8) is - when 0 => RC.E0 := E; - when 1 => RC.E1 := E; - when 2 => RC.E2 := E; - when 3 => RC.E3 := E; - when 4 => RC.E4 := E; - when 5 => RC.E5 := E; - when 6 => RC.E6 := E; - when 7 => RC.E7 := E; - end case; - else - case N07 (Uns (N) mod 8) is - when 0 => C.E0 := E; - when 1 => C.E1 := E; - when 2 => C.E2 := E; - when 3 => C.E3 := E; - when 4 => C.E4 := E; - when 5 => C.E5 := E; - when 6 => C.E6 := E; - when 7 => C.E7 := E; - end case; - end if; - end Set_63; - -end System.Pack_63; diff --git a/gcc/ada/s-pack63.ads b/gcc/ada/s-pack63.ads deleted file mode 100644 index c59678b..0000000 --- a/gcc/ada/s-pack63.ads +++ /dev/null @@ -1,60 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A C K _ 6 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Handling of packed arrays with Component_Size = 63 - -package System.Pack_63 is - pragma Preelaborate; - - Bits : constant := 63; - - type Bits_63 is mod 2 ** Bits; - for Bits_63'Size use Bits; - - -- In all subprograms below, Rev_SSO is set True if the array has the - -- non-default scalar storage order. - - function Get_63 - (Arr : System.Address; - N : Natural; - Rev_SSO : Boolean) return Bits_63 with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is extracted and returned. - - procedure Set_63 - (Arr : System.Address; - N : Natural; - E : Bits_63; - Rev_SSO : Boolean) with Inline; - -- Arr is the address of the packed array, N is the zero-based - -- subscript. This element is set to the given value. - -end System.Pack_63; diff --git a/gcc/ada/s-parame-hpux.ads b/gcc/ada/s-parame-hpux.ads deleted file mode 100644 index f20cfbe..0000000 --- a/gcc/ada/s-parame-hpux.ads +++ /dev/null @@ -1,199 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the HP version of this package - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := False; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of Types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this may not be true - -- of all targets. - - ptr_bits : constant := Standard'Address_Size; - subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address - - C_Malloc_Linkname : constant String := "__gnat_malloc"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Max_Attribute_Count : constant := 32; - -- Number of task attributes stored in the task control block - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 200; - -- This constant specifies the default number of characters to allow - -- in an exception message (200 is minimum required by RM 11.4.1(18)). - -end System.Parameters; diff --git a/gcc/ada/s-parame-rtems.adb b/gcc/ada/s-parame-rtems.adb deleted file mode 100644 index aa13114..0000000 --- a/gcc/ada/s-parame-rtems.adb +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2009 Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the RTEMS specific version - -with Interfaces.C; - -package body System.Parameters is - - function ada_pthread_minimum_stack_size return Interfaces.C.size_t; - pragma Import (C, ada_pthread_minimum_stack_size, - "_ada_pthread_minimum_stack_size"); - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - begin - return Size_Type (ada_pthread_minimum_stack_size); - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - - begin - return Size_Type (ada_pthread_minimum_stack_size); - end Minimum_Stack_Size; - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - - else - return Size; - end if; - end Adjust_Storage_Size; - -end System.Parameters; diff --git a/gcc/ada/s-parame-vxworks.adb b/gcc/ada/s-parame-vxworks.adb deleted file mode 100644 index c27b092..0000000 --- a/gcc/ada/s-parame-vxworks.adb +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version used on all VxWorks targets - -package body System.Parameters is - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - else - return Size; - end if; - end Adjust_Storage_Size; - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - Default_Stack_Size : Integer; - pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); - begin - if Default_Stack_Size = -1 then - if Stack_Check_Limits then - return 32 * 1024; - -- Extra stack to allow for 12K exception area. - else - return 20 * 1024; - end if; - else - return Size_Type (Default_Stack_Size); - end if; - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - begin - return 8 * 1024; - end Minimum_Stack_Size; - -end System.Parameters; diff --git a/gcc/ada/s-parame-vxworks.ads b/gcc/ada/s-parame-vxworks.ads deleted file mode 100644 index 919361a..0000000 --- a/gcc/ada/s-parame-vxworks.ads +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default VxWorks version of the package - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 14_336; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - -- This value is chosen as the VxWorks default stack size is 20kB, - -- and a little more than 4kB is necessary for the run time. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this may not be true - -- of all targets. - - ptr_bits : constant := Standard'Address_Size; - subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address - - C_Malloc_Linkname : constant String := "__gnat_malloc"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Max_Attribute_Count : constant := 16; - -- Number of task attributes stored in the task control block - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 32; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 200; - -- This constant specifies the default number of characters to allow - -- in an exception message (200 is minimum required by RM 11.4.1(18)). - -end System.Parameters; diff --git a/gcc/ada/s-parame.adb b/gcc/ada/s-parame.adb deleted file mode 100644 index 9a40c6f..0000000 --- a/gcc/ada/s-parame.adb +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default (used on all native platforms) version of this package - -pragma Compiler_Unit_Warning; - -package body System.Parameters is - - ------------------------- - -- Adjust_Storage_Size -- - ------------------------- - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type is - begin - if Size = Unspecified_Size then - return Default_Stack_Size; - elsif Size < Minimum_Stack_Size then - return Minimum_Stack_Size; - else - return Size; - end if; - end Adjust_Storage_Size; - - ------------------------ - -- Default_Stack_Size -- - ------------------------ - - function Default_Stack_Size return Size_Type is - Default_Stack_Size : Integer; - pragma Import (C, Default_Stack_Size, "__gl_default_stack_size"); - begin - if Default_Stack_Size = -1 then - return 2 * 1024 * 1024; - else - return Size_Type (Default_Stack_Size); - end if; - end Default_Stack_Size; - - ------------------------ - -- Minimum_Stack_Size -- - ------------------------ - - function Minimum_Stack_Size return Size_Type is - begin - -- 12K is required for stack-checking to work reliably on most platforms - -- when using the GCC scheme to propagate an exception in the ZCX case. - -- 16K is the value of PTHREAD_STACK_MIN under Linux, so is a reasonable - -- default. - - return 16 * 1024; - end Minimum_Stack_Size; - -end System.Parameters; diff --git a/gcc/ada/s-parame.ads b/gcc/ada/s-parame.ads deleted file mode 100644 index f48c7e0..0000000 --- a/gcc/ada/s-parame.ads +++ /dev/null @@ -1,201 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P A R A M E T E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Default version used when no target-specific version is provided - --- This package defines some system dependent parameters for GNAT. These --- are values that are referenced by the runtime library and are therefore --- relevant to the target machine. - --- The parameters whose value is defined in the spec are not generally --- expected to be changed. If they are changed, it will be necessary to --- recompile the run-time library. - --- The parameters which are defined by functions can be changed by modifying --- the body of System.Parameters in file s-parame.adb. A change to this body --- requires only rebinding and relinking of the application. - --- Note: do not introduce any pragma Inline statements into this unit, since --- otherwise the relinking and rebinding capability would be deactivated. - -pragma Compiler_Unit_Warning; - -package System.Parameters is - pragma Pure; - - --------------------------------------- - -- Task And Stack Allocation Control -- - --------------------------------------- - - type Task_Storage_Size is new Integer; - -- Type used in tasking units for task storage size - - type Size_Type is new Task_Storage_Size; - -- Type used to provide task storage size to runtime - - Unspecified_Size : constant Size_Type := Size_Type'First; - -- Value used to indicate that no size type is set - - subtype Percentage is Size_Type range -1 .. 100; - Dynamic : constant Size_Type := -1; - -- The secondary stack ratio is a constant between 0 and 100 which - -- determines the percentage of the allocated task stack that is - -- used by the secondary stack (the rest being the primary stack). - -- The special value of minus one indicates that the secondary - -- stack is to be allocated from the heap instead. - - Sec_Stack_Percentage : constant Percentage := Dynamic; - -- This constant defines the handling of the secondary stack - - Sec_Stack_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - -- Convenient Boolean for testing for dynamic secondary stack - - function Default_Stack_Size return Size_Type; - -- Default task stack size used if none is specified - - function Minimum_Stack_Size return Size_Type; - -- Minimum task stack size permitted - - function Adjust_Storage_Size (Size : Size_Type) return Size_Type; - -- Given the storage size stored in the TCB, return the Storage_Size - -- value required by the RM for the Storage_Size attribute. The - -- required adjustment is as follows: - -- - -- when Size = Unspecified_Size, return Default_Stack_Size - -- when Size < Minimum_Stack_Size, return Minimum_Stack_Size - -- otherwise return given Size - - Default_Env_Stack_Size : constant Size_Type := 8_192_000; - -- Assumed size of the environment task, if no other information - -- is available. This value is used when stack checking is - -- enabled and no GNAT_STACK_LIMIT environment variable is set. - - Stack_Grows_Down : constant Boolean := True; - -- This constant indicates whether the stack grows up (False) or - -- down (True) in memory as functions are called. It is used for - -- proper implementation of the stack overflow check. - - ---------------------------------------------- - -- Characteristics of types in Interfaces.C -- - ---------------------------------------------- - - long_bits : constant := Long_Integer'Size; - -- Number of bits in type long and unsigned_long. The normal convention - -- is that this is the same as type Long_Integer, but this may not be true - -- of all targets. - - ptr_bits : constant := Standard'Address_Size; - subtype C_Address is System.Address; - -- Number of bits in Interfaces.C pointers, normally a standard address - - C_Malloc_Linkname : constant String := "__gnat_malloc"; - -- Name of runtime function used to allocate such a pointer - - ---------------------------------------------- - -- Behavior of Pragma Finalize_Storage_Only -- - ---------------------------------------------- - - -- Garbage_Collected is a Boolean constant whose value indicates the - -- effect of the pragma Finalize_Storage_Entry on a controlled type. - - -- Garbage_Collected = False - - -- The system releases all storage on program termination only, - -- but not other garbage collection occurs, so finalization calls - -- are omitted only for outer level objects can be omitted if - -- pragma Finalize_Storage_Only is used. - - -- Garbage_Collected = True - - -- The system provides full garbage collection, so it is never - -- necessary to release storage for controlled objects for which - -- a pragma Finalize_Storage_Only is used. - - Garbage_Collected : constant Boolean := False; - -- The storage mode for this system (release on program exit) - - --------------------- - -- Tasking Profile -- - --------------------- - - -- In the following sections, constant parameters are defined to - -- allow some optimizations and fine tuning within the tasking run time - -- based on restrictions on the tasking features. - - ---------------------- - -- Locking Strategy -- - ---------------------- - - Single_Lock : constant Boolean := False; - -- Indicates whether a single lock should be used within the tasking - -- run-time to protect internal structures. If True, a single lock - -- will be used, meaning less locking/unlocking operations, but also - -- more global contention. In general, Single_Lock should be set to - -- True on single processor machines, and to False to multi-processor - -- systems, but this can vary from application to application and also - -- depends on the scheduling policy. - - ------------------- - -- Task Abortion -- - ------------------- - - No_Abort : constant Boolean := False; - -- This constant indicates whether abort statements and asynchronous - -- transfer of control (ATC) are disallowed. If set to True, it is - -- assumed that neither construct is used, and the run time does not - -- need to defer/undefer abort and check for pending actions at - -- completion points. A value of True for No_Abort corresponds to: - -- pragma Restrictions (No_Abort_Statements); - -- pragma Restrictions (Max_Asynchronous_Select_Nesting => 0); - - --------------------- - -- Task Attributes -- - --------------------- - - Max_Attribute_Count : constant := 32; - -- Number of task attributes stored in the task control block - - ----------------------- - -- Task Image Length -- - ----------------------- - - Max_Task_Image_Length : constant := 256; - -- This constant specifies the maximum length of a task's image - - ------------------------------ - -- Exception Message Length -- - ------------------------------ - - Default_Exception_Msg_Max_Length : constant := 200; - -- This constant specifies the default number of characters to allow - -- in an exception message (200 is minimum required by RM 11.4.1(18)). - -end System.Parameters; diff --git a/gcc/ada/s-parint.adb b/gcc/ada/s-parint.adb deleted file mode 100644 index 53cc49c..0000000 --- a/gcc/ada/s-parint.adb +++ /dev/null @@ -1,320 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- --- -- --- B o d y -- --- (Dummy body for non-distributed case) -- --- -- --- Copyright (C) 1995-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Partition_Interface is - - pragma Warnings (Off); -- suppress warnings for unreferenced formals - - M : constant := 7; - - type String_Access is access String; - - -- To have a minimal implementation of U'Partition_ID - - type Pkg_Node; - type Pkg_List is access Pkg_Node; - type Pkg_Node is record - Name : String_Access; - Subp_Info : System.Address; - Subp_Info_Len : Integer; - Next : Pkg_List; - end record; - - Pkg_Head : Pkg_List; - Pkg_Tail : Pkg_List; - - function getpid return Integer; - pragma Import (C, getpid); - - PID : constant Integer := getpid; - - function Lower (S : String) return String; - - Passive_Prefix : constant String := "SP__"; - -- String prepended in top of shared passive packages - - procedure Check - (Name : Unit_Name; - Version : String; - RCI : Boolean := True) - is - begin - null; - end Check; - - ----------------------------- - -- Get_Active_Partition_Id -- - ----------------------------- - - function Get_Active_Partition_ID - (Name : Unit_Name) return System.RPC.Partition_ID - is - P : Pkg_List := Pkg_Head; - N : String := Lower (Name); - - begin - while P /= null loop - if P.Name.all = N then - return Get_Local_Partition_ID; - end if; - - P := P.Next; - end loop; - - return M; - end Get_Active_Partition_ID; - - ------------------------ - -- Get_Active_Version -- - ------------------------ - - function Get_Active_Version (Name : Unit_Name) return String is - begin - return ""; - end Get_Active_Version; - - ---------------------------- - -- Get_Local_Partition_Id -- - ---------------------------- - - function Get_Local_Partition_ID return System.RPC.Partition_ID is - begin - return System.RPC.Partition_ID (PID mod M); - end Get_Local_Partition_ID; - - ------------------------------ - -- Get_Passive_Partition_ID -- - ------------------------------ - - function Get_Passive_Partition_ID - (Name : Unit_Name) return System.RPC.Partition_ID - is - begin - return Get_Local_Partition_ID; - end Get_Passive_Partition_ID; - - ------------------------- - -- Get_Passive_Version -- - ------------------------- - - function Get_Passive_Version (Name : Unit_Name) return String is - begin - return ""; - end Get_Passive_Version; - - ------------------ - -- Get_RAS_Info -- - ------------------ - - procedure Get_RAS_Info - (Name : Unit_Name; - Subp_Id : Subprogram_Id; - Proxy_Address : out Interfaces.Unsigned_64) - is - LName : constant String := Lower (Name); - N : Pkg_List; - begin - N := Pkg_Head; - while N /= null loop - if N.Name.all = LName then - declare - subtype Subprogram_Array is RCI_Subp_Info_Array - (First_RCI_Subprogram_Id .. - First_RCI_Subprogram_Id + N.Subp_Info_Len - 1); - Subprograms : Subprogram_Array; - for Subprograms'Address use N.Subp_Info; - pragma Import (Ada, Subprograms); - begin - Proxy_Address := - Interfaces.Unsigned_64 (Subprograms (Integer (Subp_Id)).Addr); - return; - end; - end if; - N := N.Next; - end loop; - Proxy_Address := 0; - end Get_RAS_Info; - - ------------------------------ - -- Get_RCI_Package_Receiver -- - ------------------------------ - - function Get_RCI_Package_Receiver - (Name : Unit_Name) return Interfaces.Unsigned_64 - is - begin - return 0; - end Get_RCI_Package_Receiver; - - ------------------------------- - -- Get_Unique_Remote_Pointer -- - ------------------------------- - - procedure Get_Unique_Remote_Pointer - (Handler : in out RACW_Stub_Type_Access) - is - begin - null; - end Get_Unique_Remote_Pointer; - - ----------- - -- Lower -- - ----------- - - function Lower (S : String) return String is - T : String := S; - - begin - for J in T'Range loop - if T (J) in 'A' .. 'Z' then - T (J) := Character'Val (Character'Pos (T (J)) - - Character'Pos ('A') + - Character'Pos ('a')); - end if; - end loop; - - return T; - end Lower; - - ------------------------------------- - -- Raise_Program_Error_Unknown_Tag -- - ------------------------------------- - - procedure Raise_Program_Error_Unknown_Tag - (E : Ada.Exceptions.Exception_Occurrence) - is - begin - raise Program_Error with Ada.Exceptions.Exception_Message (E); - end Raise_Program_Error_Unknown_Tag; - - ----------------- - -- RCI_Locator -- - ----------------- - - package body RCI_Locator is - - ----------------------------- - -- Get_Active_Partition_ID -- - ----------------------------- - - function Get_Active_Partition_ID return System.RPC.Partition_ID is - P : Pkg_List := Pkg_Head; - N : String := Lower (RCI_Name); - - begin - while P /= null loop - if P.Name.all = N then - return Get_Local_Partition_ID; - end if; - - P := P.Next; - end loop; - - return M; - end Get_Active_Partition_ID; - - ------------------------------ - -- Get_RCI_Package_Receiver -- - ------------------------------ - - function Get_RCI_Package_Receiver return Interfaces.Unsigned_64 is - begin - return 0; - end Get_RCI_Package_Receiver; - - end RCI_Locator; - - ------------------------------ - -- Register_Passive_Package -- - ------------------------------ - - procedure Register_Passive_Package - (Name : Unit_Name; - Version : String := "") - is - begin - Register_Receiving_Stub - (Passive_Prefix & Name, null, Version, System.Null_Address, 0); - end Register_Passive_Package; - - ----------------------------- - -- Register_Receiving_Stub -- - ----------------------------- - - procedure Register_Receiving_Stub - (Name : Unit_Name; - Receiver : RPC_Receiver; - Version : String := ""; - Subp_Info : System.Address; - Subp_Info_Len : Integer) - is - N : constant Pkg_List := - new Pkg_Node'(new String'(Lower (Name)), - Subp_Info, Subp_Info_Len, - Next => null); - begin - if Pkg_Tail = null then - Pkg_Head := N; - else - Pkg_Tail.Next := N; - end if; - Pkg_Tail := N; - end Register_Receiving_Stub; - - --------- - -- Run -- - --------- - - procedure Run - (Main : Main_Subprogram_Type := null) - is - begin - if Main /= null then - Main.all; - end if; - end Run; - - -------------------- - -- Same_Partition -- - -------------------- - - function Same_Partition - (Left : not null access RACW_Stub_Type; - Right : not null access RACW_Stub_Type) return Boolean - is - pragma Unreferenced (Left); - pragma Unreferenced (Right); - begin - return True; - end Same_Partition; - -end System.Partition_Interface; diff --git a/gcc/ada/s-parint.ads b/gcc/ada/s-parint.ads deleted file mode 100644 index a6257cc..0000000 --- a/gcc/ada/s-parint.ads +++ /dev/null @@ -1,191 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P A R T I T I O N _ I N T E R F A C E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -with Ada.Exceptions; -with Ada.Streams; -with Interfaces; -with System.RPC; - -package System.Partition_Interface is - pragma Elaborate_Body; - - type DSA_Implementation_Name is (No_DSA, GARLIC_DSA, PolyORB_DSA); - DSA_Implementation : constant DSA_Implementation_Name := No_DSA; - -- Identification of this DSA implementation variant - - PCS_Version : constant := 1; - -- Version of the PCS API (for Exp_Dist consistency check) - -- - -- This version number is matched against corresponding element of - -- Exp_Dist.PCS_Version_Number to ensure that the versions of Exp_Dist - -- and the PCS are consistent. - - -- RCI receiving stubs contain a table of descriptors for all user - -- subprograms exported by the unit. - - type Subprogram_Id is new Natural; - First_RCI_Subprogram_Id : constant := 2; - - type RCI_Subp_Info is record - Addr : System.Address; - -- Local address of the proxy object - end record; - - type RCI_Subp_Info_Access is access all RCI_Subp_Info; - type RCI_Subp_Info_Array is array (Integer range <>) of - aliased RCI_Subp_Info; - - subtype Unit_Name is String; - -- Name of Ada units - - type Main_Subprogram_Type is access procedure; - - type RACW_Stub_Type is tagged record - Origin : RPC.Partition_ID; - Receiver : Interfaces.Unsigned_64; - Addr : Interfaces.Unsigned_64; - Asynchronous : Boolean; - end record; - - type RACW_Stub_Type_Access is access RACW_Stub_Type; - -- This type is used by the expansion to implement distributed objects. - -- Do not change its definition or its layout without updating - -- exp_dist.adb. - - type RAS_Proxy_Type is tagged limited record - All_Calls_Remote : Boolean; - Receiver : System.Address; - Subp_Id : Subprogram_Id; - end record; - - type RAS_Proxy_Type_Access is access RAS_Proxy_Type; - pragma No_Strict_Aliasing (RAS_Proxy_Type_Access); - -- This type is used by the expansion to implement distributed objects. - -- Do not change its definition or its layout without updating - -- Exp_Dist.Build_Remote_Subprogram_Proxy_Type. - - -- The Request_Access type is used for communication between the PCS - -- and the RPC receiver generated by the compiler: it contains all the - -- necessary information for the receiver to process an incoming call. - - type RST_Access is access all Ada.Streams.Root_Stream_Type'Class; - type Request_Access is record - Params : RST_Access; - -- A stream describing the called subprogram and its parameters - - Result : RST_Access; - -- A stream where the result, raised exception, or out values, - -- are marshalled. - end record; - - procedure Check - (Name : Unit_Name; - Version : String; - RCI : Boolean := True); - -- Use by the main subprogram to check that a remote receiver - -- unit has the same version than the caller's one. - - function Same_Partition - (Left : not null access RACW_Stub_Type; - Right : not null access RACW_Stub_Type) return Boolean; - -- Determine whether Left and Right correspond to objects instantiated - -- on the same partition, for enforcement of E.4(19). - - function Get_Active_Partition_ID (Name : Unit_Name) return RPC.Partition_ID; - -- Similar in some respects to RCI_Locator.Get_Active_Partition_ID - - function Get_Active_Version (Name : Unit_Name) return String; - -- Similar in some respects to Get_Active_Partition_ID - - function Get_Local_Partition_ID return RPC.Partition_ID; - -- Return the Partition_ID of the current partition - - function Get_Passive_Partition_ID - (Name : Unit_Name) return RPC.Partition_ID; - -- Return the Partition_ID of the given shared passive partition - - function Get_Passive_Version (Name : Unit_Name) return String; - -- Return the version corresponding to a shared passive unit - - function Get_RCI_Package_Receiver - (Name : Unit_Name) return Interfaces.Unsigned_64; - -- Similar in some respects to RCI_Locator.Get_RCI_Package_Receiver - - procedure Get_Unique_Remote_Pointer - (Handler : in out RACW_Stub_Type_Access); - -- Get a unique pointer on a remote object - - procedure Raise_Program_Error_Unknown_Tag - (E : Ada.Exceptions.Exception_Occurrence); - pragma No_Return (Raise_Program_Error_Unknown_Tag); - -- Raise Program_Error with the same message as E one - - type RPC_Receiver is access procedure (R : Request_Access); - procedure Register_Receiving_Stub - (Name : Unit_Name; - Receiver : RPC_Receiver; - Version : String := ""; - Subp_Info : System.Address; - Subp_Info_Len : Integer); - -- Register the fact that the Name receiving stub is now elaborated. - -- Register the access value to the package RPC_Receiver procedure. - - procedure Get_RAS_Info - (Name : Unit_Name; - Subp_Id : Subprogram_Id; - Proxy_Address : out Interfaces.Unsigned_64); - -- Look up the address of the proxy object for the given subprogram - -- in the named unit, or Null_Address if not present on the local - -- partition. - - procedure Register_Passive_Package - (Name : Unit_Name; - Version : String := ""); - -- Register a passive package - - generic - RCI_Name : String; - Version : String; - package RCI_Locator is - pragma Unreferenced (Version); - - function Get_RCI_Package_Receiver return Interfaces.Unsigned_64; - function Get_Active_Partition_ID return RPC.Partition_ID; - end RCI_Locator; - -- RCI package information caching - - procedure Run (Main : Main_Subprogram_Type := null); - -- Run the main subprogram - -end System.Partition_Interface; diff --git a/gcc/ada/s-pooglo.adb b/gcc/ada/s-pooglo.adb deleted file mode 100644 index e4dcdb0..0000000 --- a/gcc/ada/s-pooglo.adb +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O O L _ G L O B A L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Pools; use System.Storage_Pools; -with System.Memory; - -package body System.Pool_Global is - - package SSE renames System.Storage_Elements; - - -------------- - -- Allocate -- - -------------- - - overriding procedure Allocate - (Pool : in out Unbounded_No_Reclaim_Pool; - Address : out System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - use SSE; - pragma Warnings (Off, Pool); - - Aligned_Size : Storage_Count := Storage_Size; - Aligned_Address : System.Address; - Allocated : System.Address; - - begin - if Alignment > Standard'System_Allocator_Alignment then - Aligned_Size := Aligned_Size + Alignment; - end if; - - Allocated := Memory.Alloc (Memory.size_t (Aligned_Size)); - - -- The call to Alloc returns an address whose alignment is compatible - -- with the worst case alignment requirement for the machine; thus the - -- Alignment argument can be safely ignored. - - if Allocated = Null_Address then - raise Storage_Error; - end if; - - -- Case where alignment requested is greater than the alignment that is - -- guaranteed to be provided by the system allocator. - - if Alignment > Standard'System_Allocator_Alignment then - - -- Realign the returned address - - Aligned_Address := To_Address - (To_Integer (Allocated) + Integer_Address (Alignment) - - (To_Integer (Allocated) mod Integer_Address (Alignment))); - - -- Save the block address - - declare - Saved_Address : System.Address; - pragma Import (Ada, Saved_Address); - for Saved_Address'Address use - Aligned_Address - - Storage_Offset (System.Address'Size / Storage_Unit); - begin - Saved_Address := Allocated; - end; - - Address := Aligned_Address; - - else - Address := Allocated; - end if; - end Allocate; - - ---------------- - -- Deallocate -- - ---------------- - - overriding procedure Deallocate - (Pool : in out Unbounded_No_Reclaim_Pool; - Address : System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - use System.Storage_Elements; - pragma Warnings (Off, Pool); - pragma Warnings (Off, Storage_Size); - - begin - -- Case where the alignment of the block exceeds the guaranteed - -- alignment required by the system storage allocator, meaning that - -- this was specially wrapped at allocation time. - - if Alignment > Standard'System_Allocator_Alignment then - - -- Retrieve the block address - - declare - Saved_Address : System.Address; - pragma Import (Ada, Saved_Address); - for Saved_Address'Address use - Address - Storage_Offset (System.Address'Size / Storage_Unit); - begin - Memory.Free (Saved_Address); - end; - - else - Memory.Free (Address); - end if; - end Deallocate; - - ------------------ - -- Storage_Size -- - ------------------ - - overriding function Storage_Size - (Pool : Unbounded_No_Reclaim_Pool) - return SSE.Storage_Count - is - pragma Warnings (Off, Pool); - - begin - -- Intuitively, should return System.Memory_Size. But on Sun/Alsys, - -- System.Memory_Size > System.Max_Int, which means all you can do with - -- it is raise CONSTRAINT_ERROR... - - return SSE.Storage_Count'Last; - end Storage_Size; - -end System.Pool_Global; diff --git a/gcc/ada/s-pooglo.ads b/gcc/ada/s-pooglo.ads deleted file mode 100644 index 99100f8..0000000 --- a/gcc/ada/s-pooglo.ads +++ /dev/null @@ -1,79 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O O L _ G L O B A L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Storage pool corresponding to default global storage pool used for types --- for which no storage pool is specified. - -with System; -with System.Storage_Pools; -with System.Storage_Elements; - -package System.Pool_Global is - pragma Elaborate_Body; - -- Needed to ensure that library routines can execute allocators - - -- Allocation strategy: - - -- Call to malloc/free for each Allocate/Deallocate - -- No user specifiable size - -- No automatic reclaim - -- Minimal overhead - - -- Pool simulating the allocation/deallocation strategy used by the - -- compiler for access types globally declared. - - type Unbounded_No_Reclaim_Pool is new - System.Storage_Pools.Root_Storage_Pool with null record; - - overriding function Storage_Size - (Pool : Unbounded_No_Reclaim_Pool) - return System.Storage_Elements.Storage_Count; - - overriding procedure Allocate - (Pool : in out Unbounded_No_Reclaim_Pool; - Address : out System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - overriding procedure Deallocate - (Pool : in out Unbounded_No_Reclaim_Pool; - Address : System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - -- Pool object used by the compiler when implicit Storage Pool objects are - -- explicitly referred to. For instance when writing something like: - -- for T'Storage_Pool use Q'Storage_Pool; - -- and Q'Storage_Pool hasn't been defined explicitly. - - Global_Pool_Object : aliased Unbounded_No_Reclaim_Pool; - -end System.Pool_Global; diff --git a/gcc/ada/s-pooloc.adb b/gcc/ada/s-pooloc.adb deleted file mode 100644 index ebada30..0000000 --- a/gcc/ada/s-pooloc.adb +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O O L _ L O C A L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Memory; - -with Ada.Unchecked_Conversion; - -package body System.Pool_Local is - - package SSE renames System.Storage_Elements; - use type SSE.Storage_Offset; - - Pointer_Size : constant SSE.Storage_Offset := Address'Size / Storage_Unit; - Pointers_Size : constant SSE.Storage_Offset := 2 * Pointer_Size; - - type Acc_Address is access all Address; - function To_Acc_Address is - new Ada.Unchecked_Conversion (Address, Acc_Address); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Next (A : Address) return Acc_Address; - pragma Inline (Next); - -- Given an address of a block, return an access to the next block - - function Prev (A : Address) return Acc_Address; - pragma Inline (Prev); - -- Given an address of a block, return an access to the previous block - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Pool : in out Unbounded_Reclaim_Pool; - Address : out System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - pragma Warnings (Off, Alignment); - - Allocated : constant System.Address := - Memory.Alloc - (Memory.size_t (Storage_Size + Pointers_Size)); - - begin - -- The call to Alloc returns an address whose alignment is compatible - -- with the worst case alignment requirement for the machine; thus the - -- Alignment argument can be safely ignored. - - if Allocated = Null_Address then - raise Storage_Error; - else - Address := Allocated + Pointers_Size; - Next (Allocated).all := Pool.First; - Prev (Allocated).all := Null_Address; - - if Pool.First /= Null_Address then - Prev (Pool.First).all := Allocated; - end if; - - Pool.First := Allocated; - end if; - end Allocate; - - ---------------- - -- Deallocate -- - ---------------- - - procedure Deallocate - (Pool : in out Unbounded_Reclaim_Pool; - Address : System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - pragma Warnings (Off, Storage_Size); - pragma Warnings (Off, Alignment); - - Allocated : constant System.Address := Address - Pointers_Size; - - begin - if Prev (Allocated).all = Null_Address then - Pool.First := Next (Allocated).all; - - -- Comment needed - - if Pool.First /= Null_Address then - Prev (Pool.First).all := Null_Address; - end if; - else - Next (Prev (Allocated).all).all := Next (Allocated).all; - end if; - - if Next (Allocated).all /= Null_Address then - Prev (Next (Allocated).all).all := Prev (Allocated).all; - end if; - - Memory.Free (Allocated); - end Deallocate; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (Pool : in out Unbounded_Reclaim_Pool) is - N : System.Address := Pool.First; - Allocated : System.Address; - - begin - while N /= Null_Address loop - Allocated := N; - N := Next (N).all; - Memory.Free (Allocated); - end loop; - end Finalize; - - ---------- - -- Next -- - ---------- - - function Next (A : Address) return Acc_Address is - begin - return To_Acc_Address (A); - end Next; - - ---------- - -- Prev -- - ---------- - - function Prev (A : Address) return Acc_Address is - begin - return To_Acc_Address (A + Pointer_Size); - end Prev; - -end System.Pool_Local; diff --git a/gcc/ada/s-pooloc.ads b/gcc/ada/s-pooloc.ads deleted file mode 100644 index 1e7c8ac..0000000 --- a/gcc/ada/s-pooloc.ads +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O O L _ L O C A L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Storage pool for use with local objects with automatic reclaim - -with System.Storage_Elements; -with System.Pool_Global; - -package System.Pool_Local is - pragma Elaborate_Body; - -- Needed to ensure that library routines can execute allocators - - ---------------------------- - -- Unbounded_Reclaim_Pool -- - ---------------------------- - - -- Allocation strategy: - - -- Call to malloc/free for each Allocate/Deallocate - -- No user specifiable size - -- Space of allocated objects is reclaimed at pool finalization - -- Manages a list of allocated objects - - type Unbounded_Reclaim_Pool is new - System.Pool_Global.Unbounded_No_Reclaim_Pool with - record - First : System.Address := Null_Address; - end record; - - -- function Storage_Size is inherited - - procedure Allocate - (Pool : in out Unbounded_Reclaim_Pool; - Address : out System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - procedure Deallocate - (Pool : in out Unbounded_Reclaim_Pool; - Address : System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - procedure Finalize (Pool : in out Unbounded_Reclaim_Pool); - -end System.Pool_Local; diff --git a/gcc/ada/s-poosiz.adb b/gcc/ada/s-poosiz.adb deleted file mode 100644 index da3a0c5..0000000 --- a/gcc/ada/s-poosiz.adb +++ /dev/null @@ -1,412 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P O O L _ S I Z E -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Soft_Links; - -with Ada.Unchecked_Conversion; - -package body System.Pool_Size is - - package SSE renames System.Storage_Elements; - use type SSE.Storage_Offset; - - -- Even though these storage pools are typically only used by a single - -- task, if multiple tasks are declared at the same or a more nested scope - -- as the storage pool, there still may be concurrent access. The current - -- implementation of Stack_Bounded_Pool always uses a global lock for - -- protecting access. This should eventually be replaced by an atomic - -- linked list implementation for efficiency reasons. - - package SSL renames System.Soft_Links; - - type Storage_Count_Access is access SSE.Storage_Count; - function To_Storage_Count_Access is - new Ada.Unchecked_Conversion (Address, Storage_Count_Access); - - SC_Size : constant := SSE.Storage_Count'Object_Size / System.Storage_Unit; - - package Variable_Size_Management is - - -- Embedded pool that manages allocation of variable-size data - - -- This pool is used as soon as the Elmt_Size of the pool object is 0 - - -- Allocation is done on the first chunk long enough for the request. - -- Deallocation just puts the freed chunk at the beginning of the list. - - procedure Initialize (Pool : in out Stack_Bounded_Pool); - procedure Allocate - (Pool : in out Stack_Bounded_Pool; - Address : out System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count); - - procedure Deallocate - (Pool : in out Stack_Bounded_Pool; - Address : System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count); - end Variable_Size_Management; - - package Vsize renames Variable_Size_Management; - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Pool : in out Stack_Bounded_Pool; - Address : out System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - begin - SSL.Lock_Task.all; - - if Pool.Elmt_Size = 0 then - Vsize.Allocate (Pool, Address, Storage_Size, Alignment); - - elsif Pool.First_Free /= 0 then - Address := Pool.The_Pool (Pool.First_Free)'Address; - Pool.First_Free := To_Storage_Count_Access (Address).all; - - elsif - Pool.First_Empty <= (Pool.Pool_Size - Pool.Aligned_Elmt_Size + 1) - then - Address := Pool.The_Pool (Pool.First_Empty)'Address; - Pool.First_Empty := Pool.First_Empty + Pool.Aligned_Elmt_Size; - - else - raise Storage_Error; - end if; - - SSL.Unlock_Task.all; - - exception - when others => - SSL.Unlock_Task.all; - raise; - end Allocate; - - ---------------- - -- Deallocate -- - ---------------- - - procedure Deallocate - (Pool : in out Stack_Bounded_Pool; - Address : System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - begin - SSL.Lock_Task.all; - - if Pool.Elmt_Size = 0 then - Vsize.Deallocate (Pool, Address, Storage_Size, Alignment); - - else - To_Storage_Count_Access (Address).all := Pool.First_Free; - Pool.First_Free := Address - Pool.The_Pool'Address + 1; - end if; - - SSL.Unlock_Task.all; - exception - when others => - SSL.Unlock_Task.all; - raise; - end Deallocate; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Pool : in out Stack_Bounded_Pool) is - - -- Define the appropriate alignment for allocations. This is the - -- maximum of the requested alignment, and the alignment required - -- for Storage_Count values. The latter test is to ensure that we - -- can properly reference the linked list pointers for free lists. - - Align : constant SSE.Storage_Count := - SSE.Storage_Count'Max - (SSE.Storage_Count'Alignment, Pool.Alignment); - - begin - if Pool.Elmt_Size = 0 then - Vsize.Initialize (Pool); - - else - Pool.First_Free := 0; - Pool.First_Empty := 1; - - -- Compute the size to allocate given the size of the element and - -- the possible alignment requirement as defined above. - - Pool.Aligned_Elmt_Size := - SSE.Storage_Count'Max (SC_Size, - ((Pool.Elmt_Size + Align - 1) / Align) * Align); - end if; - end Initialize; - - ------------------ - -- Storage_Size -- - ------------------ - - function Storage_Size - (Pool : Stack_Bounded_Pool) return SSE.Storage_Count - is - begin - return Pool.Pool_Size; - end Storage_Size; - - ------------------------------ - -- Variable_Size_Management -- - ------------------------------ - - package body Variable_Size_Management is - - Minimum_Size : constant := 2 * SC_Size; - - procedure Set_Size - (Pool : Stack_Bounded_Pool; - Chunk, Size : SSE.Storage_Count); - -- Update the field 'size' of a chunk of available storage - - procedure Set_Next - (Pool : Stack_Bounded_Pool; - Chunk, Next : SSE.Storage_Count); - -- Update the field 'next' of a chunk of available storage - - function Size - (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) return SSE.Storage_Count; - -- Fetch the field 'size' of a chunk of available storage - - function Next - (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) return SSE.Storage_Count; - -- Fetch the field 'next' of a chunk of available storage - - function Chunk_Of - (Pool : Stack_Bounded_Pool; - Addr : System.Address) return SSE.Storage_Count; - -- Give the chunk number in the pool from its Address - - -------------- - -- Allocate -- - -------------- - - procedure Allocate - (Pool : in out Stack_Bounded_Pool; - Address : out System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - Chunk : SSE.Storage_Count; - New_Chunk : SSE.Storage_Count; - Prev_Chunk : SSE.Storage_Count; - Our_Align : constant SSE.Storage_Count := - SSE.Storage_Count'Max (SSE.Storage_Count'Alignment, - Alignment); - Align_Size : constant SSE.Storage_Count := - SSE.Storage_Count'Max ( - Minimum_Size, - ((Storage_Size + Our_Align - 1) / Our_Align) * - Our_Align); - - begin - -- Look for the first big enough chunk - - Prev_Chunk := Pool.First_Free; - Chunk := Next (Pool, Prev_Chunk); - - while Chunk /= 0 and then Size (Pool, Chunk) < Align_Size loop - Prev_Chunk := Chunk; - Chunk := Next (Pool, Chunk); - end loop; - - -- Raise storage_error if no big enough chunk available - - if Chunk = 0 then - raise Storage_Error; - end if; - - -- When the chunk is bigger than what is needed, take appropriate - -- amount and build a new shrinked chunk with the remainder. - - if Size (Pool, Chunk) - Align_Size > Minimum_Size then - New_Chunk := Chunk + Align_Size; - Set_Size (Pool, New_Chunk, Size (Pool, Chunk) - Align_Size); - Set_Next (Pool, New_Chunk, Next (Pool, Chunk)); - Set_Next (Pool, Prev_Chunk, New_Chunk); - - -- If the chunk is the right size, just delete it from the chain - - else - Set_Next (Pool, Prev_Chunk, Next (Pool, Chunk)); - end if; - - Address := Pool.The_Pool (Chunk)'Address; - end Allocate; - - -------------- - -- Chunk_Of -- - -------------- - - function Chunk_Of - (Pool : Stack_Bounded_Pool; - Addr : System.Address) return SSE.Storage_Count - is - begin - return 1 + abs (Addr - Pool.The_Pool (1)'Address); - end Chunk_Of; - - ---------------- - -- Deallocate -- - ---------------- - - procedure Deallocate - (Pool : in out Stack_Bounded_Pool; - Address : System.Address; - Storage_Size : SSE.Storage_Count; - Alignment : SSE.Storage_Count) - is - pragma Warnings (Off, Pool); - - Align_Size : constant SSE.Storage_Count := - ((Storage_Size + Alignment - 1) / Alignment) * - Alignment; - Chunk : constant SSE.Storage_Count := Chunk_Of (Pool, Address); - - begin - -- Attach the freed chunk to the chain - - Set_Size (Pool, Chunk, - SSE.Storage_Count'Max (Align_Size, Minimum_Size)); - Set_Next (Pool, Chunk, Next (Pool, Pool.First_Free)); - Set_Next (Pool, Pool.First_Free, Chunk); - - end Deallocate; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Pool : in out Stack_Bounded_Pool) is - begin - Pool.First_Free := 1; - - if Pool.Pool_Size > Minimum_Size then - Set_Next (Pool, Pool.First_Free, Pool.First_Free + Minimum_Size); - Set_Size (Pool, Pool.First_Free, 0); - Set_Size (Pool, Pool.First_Free + Minimum_Size, - Pool.Pool_Size - Minimum_Size); - Set_Next (Pool, Pool.First_Free + Minimum_Size, 0); - end if; - end Initialize; - - ---------- - -- Next -- - ---------- - - function Next - (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) return SSE.Storage_Count - is - begin - pragma Warnings (Off); - -- Kill alignment warnings, we are careful to make sure - -- that the alignment is correct. - - return To_Storage_Count_Access - (Pool.The_Pool (Chunk + SC_Size)'Address).all; - - pragma Warnings (On); - end Next; - - -------------- - -- Set_Next -- - -------------- - - procedure Set_Next - (Pool : Stack_Bounded_Pool; - Chunk, Next : SSE.Storage_Count) - is - begin - pragma Warnings (Off); - -- Kill alignment warnings, we are careful to make sure - -- that the alignment is correct. - - To_Storage_Count_Access - (Pool.The_Pool (Chunk + SC_Size)'Address).all := Next; - - pragma Warnings (On); - end Set_Next; - - -------------- - -- Set_Size -- - -------------- - - procedure Set_Size - (Pool : Stack_Bounded_Pool; - Chunk, Size : SSE.Storage_Count) - is - begin - pragma Warnings (Off); - -- Kill alignment warnings, we are careful to make sure - -- that the alignment is correct. - - To_Storage_Count_Access - (Pool.The_Pool (Chunk)'Address).all := Size; - - pragma Warnings (On); - end Set_Size; - - ---------- - -- Size -- - ---------- - - function Size - (Pool : Stack_Bounded_Pool; - Chunk : SSE.Storage_Count) return SSE.Storage_Count - is - begin - pragma Warnings (Off); - -- Kill alignment warnings, we are careful to make sure - -- that the alignment is correct. - - return To_Storage_Count_Access (Pool.The_Pool (Chunk)'Address).all; - - pragma Warnings (On); - end Size; - - end Variable_Size_Management; -end System.Pool_Size; diff --git a/gcc/ada/s-poosiz.ads b/gcc/ada/s-poosiz.ads deleted file mode 100644 index 0e83dd6..0000000 --- a/gcc/ada/s-poosiz.ads +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O O L _ S I Z E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Storage_Pools; -with System.Storage_Elements; - -package System.Pool_Size is - pragma Elaborate_Body; - -- Needed to ensure that library routines can execute allocators - - ------------------------ - -- Stack_Bounded_Pool -- - ------------------------ - - -- Allocation strategy: - - -- Pool is a regular stack array, no use of malloc - -- user specified size - -- Space of pool is globally reclaimed by normal stack management - - -- Used in the compiler for access types with 'STORAGE_SIZE rep. clause - -- Only used for allocating objects of the same type. - - type Stack_Bounded_Pool - (Pool_Size : System.Storage_Elements.Storage_Count; - Elmt_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is - new System.Storage_Pools.Root_Storage_Pool with record - First_Free : System.Storage_Elements.Storage_Count; - First_Empty : System.Storage_Elements.Storage_Count; - Aligned_Elmt_Size : System.Storage_Elements.Storage_Count; - The_Pool : System.Storage_Elements.Storage_Array - (1 .. Pool_Size); - end record; - - overriding function Storage_Size - (Pool : Stack_Bounded_Pool) return System.Storage_Elements.Storage_Count; - - overriding procedure Allocate - (Pool : in out Stack_Bounded_Pool; - Address : out System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - overriding procedure Deallocate - (Pool : in out Stack_Bounded_Pool; - Address : System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - overriding procedure Initialize (Pool : in out Stack_Bounded_Pool); - -end System.Pool_Size; diff --git a/gcc/ada/s-powtab.ads b/gcc/ada/s-powtab.ads deleted file mode 100644 index 5a84b50..0000000 --- a/gcc/ada/s-powtab.ads +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . P O W T E N _ T A B L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 powers of ten table used for real conversions - -package System.Powten_Table is - pragma Pure; - - Maxpow : constant := 22; - -- The number of entries in this table is chosen to include powers of ten - -- that are exactly representable with long_long_float. Assuming that on - -- all targets we have 53 bits of mantissa for the type, the upper bound is - -- given by 53/(log 5). If the scaling factor for a string is greater than - -- Maxpow, it can be obtained by several multiplications, which is less - -- efficient than with a bigger table, but avoids anomalies at end points. - - Powten : constant array (0 .. Maxpow) of Long_Long_Float := - (00 => 1.0E+00, - 01 => 1.0E+01, - 02 => 1.0E+02, - 03 => 1.0E+03, - 04 => 1.0E+04, - 05 => 1.0E+05, - 06 => 1.0E+06, - 07 => 1.0E+07, - 08 => 1.0E+08, - 09 => 1.0E+09, - 10 => 1.0E+10, - 11 => 1.0E+11, - 12 => 1.0E+12, - 13 => 1.0E+13, - 14 => 1.0E+14, - 15 => 1.0E+15, - 16 => 1.0E+16, - 17 => 1.0E+17, - 18 => 1.0E+18, - 19 => 1.0E+19, - 20 => 1.0E+20, - 21 => 1.0E+21, - 22 => 1.0E+22); - -end System.Powten_Table; diff --git a/gcc/ada/s-purexc.ads b/gcc/ada/s-purexc.ads deleted file mode 100644 index 946d21d..0000000 --- a/gcc/ada/s-purexc.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . P U R E _ E X C E P T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2000-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides an interface for raising predefined exceptions with --- an exception message. It can be used from Pure units. This unit is for --- internal use only, it is not generally available to applications. - -pragma Compiler_Unit_Warning; - -package System.Pure_Exceptions is - pragma Pure; - - type Exception_Type is limited null record; - -- Type used to specify which exception to raise - - -- Really Exception_Type is Exception_Id, but Exception_Id can't be - -- used directly since it is declared in the non-pure unit Ada.Exceptions, - - -- Exception_Id is in fact simply a pointer to the type Exception_Data - -- declared in System.Standard_Library (which is also non-pure). So what - -- we do is to define it here as a by reference type (any by reference - -- type would do), and then Import the definitions from Standard_Library. - -- Since this is a by reference type, these will be passed by reference, - -- which has the same effect as passing a pointer. - - -- This type is not private because keeping it by reference would require - -- defining it in a way (e.g. using a tagged type) that would drag in other - -- run-time files, which is unwanted in the case of e.g. Ravenscar, where - -- we want to minimize the number of run-time files needed by default. - - CE : constant Exception_Type; -- Constraint_Error - PE : constant Exception_Type; -- Program_Error - SE : constant Exception_Type; -- Storage_Error - TE : constant Exception_Type; -- Tasking_Error - -- One of these constants is used in the call to specify the exception - - procedure Raise_Exception (E : Exception_Type; Message : String); - pragma Import (Ada, Raise_Exception, "__gnat_raise_exception"); - pragma No_Return (Raise_Exception); - -- Raise specified exception with specified message - -private - pragma Import (C, CE, "constraint_error"); - pragma Import (C, PE, "program_error"); - pragma Import (C, SE, "storage_error"); - pragma Import (C, TE, "tasking_error"); - -- References to the exception structures in the standard library - -end System.Pure_Exceptions; diff --git a/gcc/ada/s-rannum.adb b/gcc/ada/s-rannum.adb deleted file mode 100644 index c024249..0000000 --- a/gcc/ada/s-rannum.adb +++ /dev/null @@ -1,693 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R A N D O M _ N U M B E R S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- -- --- The implementation here is derived from a C-program for MT19937, with -- --- initialization improved 2002/1/26. As required, the following notice is -- --- copied from the original program. -- --- -- --- Copyright (C) 1997 - 2002, Makoto Matsumoto and Takuji Nishimura, -- --- All rights reserved. -- --- -- --- Redistribution and use in source and binary forms, with or without -- --- modification, are permitted provided that the following conditions -- --- are met: -- --- -- --- 1. Redistributions of source code must retain the above copyright -- --- notice, this list of conditions and the following disclaimer. -- --- -- --- 2. Redistributions in binary form must reproduce the above copyright -- --- notice, this list of conditions and the following disclaimer in the -- --- documentation and/or other materials provided with the distribution.-- --- -- --- 3. The names of its contributors may not be used to endorse or promote -- --- products derived from this software without specific prior written -- --- permission. -- --- -- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -- --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -- --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -- --- A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -- --- OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -- --- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED -- --- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -- --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -- --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -- --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -- --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -- --- -- ------------------------------------------------------------------------------- - ------------------------------------------------------------------------------- --- -- --- This is an implementation of the Mersenne Twister, twisted generalized -- --- feedback shift register of rational normal form, with state-bit -- --- reflection and tempering. This version generates 32-bit integers with a -- --- period of 2**19937 - 1 (a Mersenne prime, hence the name). For -- --- applications requiring more than 32 bits (up to 64), we concatenate two -- --- 32-bit numbers. -- --- -- --- See http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/emt.html for -- --- details. -- --- -- --- In contrast to the original code, we do not generate random numbers in -- --- batches of N. Measurement seems to show this has very little if any -- --- effect on performance, and it may be marginally better for real-time -- --- applications with hard deadlines. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -with System.Random_Seed; - -with Interfaces; use Interfaces; - -use Ada; - -package body System.Random_Numbers with - SPARK_Mode => Off -is - Image_Numeral_Length : constant := Max_Image_Width / N; - - subtype Image_String is String (1 .. Max_Image_Width); - - ---------------------------- - -- Algorithmic Parameters -- - ---------------------------- - - Lower_Mask : constant := 2**31 - 1; - Upper_Mask : constant := 2**31; - - Matrix_A : constant array (State_Val range 0 .. 1) of State_Val - := (0, 16#9908b0df#); - -- The twist transformation is represented by a matrix of the form - -- - -- [ 0 I(31) ] - -- [ _a ] - -- - -- where 0 is a 31x31 block of 0s, I(31) is the 31x31 identity matrix and - -- _a is a particular bit row-vector, represented here by a 32-bit integer. - -- If integer x represents a row vector of bits (with x(0), the units bit, - -- last), then - -- x * A = [0 x(31..1)] xor Matrix_A(x(0)). - - U : constant := 11; - S : constant := 7; - B_Mask : constant := 16#9d2c5680#; - T : constant := 15; - C_Mask : constant := 16#efc60000#; - L : constant := 18; - -- The tempering shifts and bit masks, in the order applied - - Seed0 : constant := 5489; - -- Default seed, used to initialize the state vector when Reset not called - - Seed1 : constant := 19650218; - -- Seed used to initialize the state vector when calling Reset with an - -- initialization vector. - - Mult0 : constant := 1812433253; - -- Multiplier for a modified linear congruential generator used to - -- initialize the state vector when calling Reset with a single integer - -- seed. - - Mult1 : constant := 1664525; - Mult2 : constant := 1566083941; - -- Multipliers for two modified linear congruential generators used to - -- initialize the state vector when calling Reset with an initialization - -- vector. - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Init (Gen : Generator; Initiator : Unsigned_32); - -- Perform a default initialization of the state of Gen. The resulting - -- state is identical for identical values of Initiator. - - procedure Insert_Image - (S : in out Image_String; - Index : Integer; - V : State_Val); - -- Insert image of V into S, in the Index'th 11-character substring - - function Extract_Value (S : String; Index : Integer) return State_Val; - -- Treat S as a sequence of 11-character decimal numerals and return - -- the result of converting numeral #Index (numbering from 0) - - function To_Unsigned is - new Unchecked_Conversion (Integer_32, Unsigned_32); - function To_Unsigned is - new Unchecked_Conversion (Integer_64, Unsigned_64); - - ------------ - -- Random -- - ------------ - - function Random (Gen : Generator) return Unsigned_32 is - G : Generator renames Gen.Writable.Self.all; - Y : State_Val; - I : Integer; -- should avoid use of identifier I ??? - - begin - I := G.I; - - if I < N - M then - Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); - Y := G.S (I + M) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); - I := I + 1; - - elsif I < N - 1 then - Y := (G.S (I) and Upper_Mask) or (G.S (I + 1) and Lower_Mask); - Y := G.S (I + (M - N)) - xor Shift_Right (Y, 1) - xor Matrix_A (Y and 1); - I := I + 1; - - elsif I = N - 1 then - Y := (G.S (I) and Upper_Mask) or (G.S (0) and Lower_Mask); - Y := G.S (M - 1) xor Shift_Right (Y, 1) xor Matrix_A (Y and 1); - I := 0; - - else - Init (G, Seed0); - return Random (Gen); - end if; - - G.S (G.I) := Y; - G.I := I; - - Y := Y xor Shift_Right (Y, U); - Y := Y xor (Shift_Left (Y, S) and B_Mask); - Y := Y xor (Shift_Left (Y, T) and C_Mask); - Y := Y xor Shift_Right (Y, L); - - return Y; - end Random; - - generic - type Unsigned is mod <>; - type Real is digits <>; - with function Random (G : Generator) return Unsigned is <>; - function Random_Float_Template (Gen : Generator) return Real; - pragma Inline (Random_Float_Template); - -- Template for a random-number generator implementation that delivers - -- values of type Real in the range [0 .. 1], using values from Gen, - -- assuming that Unsigned is large enough to hold the bits of a mantissa - -- for type Real. - - --------------------------- - -- Random_Float_Template -- - --------------------------- - - function Random_Float_Template (Gen : Generator) return Real is - - pragma Compile_Time_Error - (Unsigned'Last <= 2**(Real'Machine_Mantissa - 1), - "insufficiently large modular type used to hold mantissa"); - - begin - -- This code generates random floating-point numbers from unsigned - -- integers. Assuming that Real'Machine_Radix = 2, it can deliver all - -- machine values of type Real (as implied by Real'Machine_Mantissa and - -- Real'Machine_Emin), which is not true of the standard method (to - -- which we fall back for nonbinary radix): computing Real() / (+1). To do so, we first extract an - -- (M-1)-bit significand (where M is Real'Machine_Mantissa), and then - -- decide on a normalized exponent by repeated coin flips, decrementing - -- from 0 as long as we flip heads (1 bits). This process yields the - -- proper geometric distribution for the exponent: in a uniformly - -- distributed set of floating-point numbers, 1/2 of them will be in - -- (0.5, 1], 1/4 will be in (0.25, 0.5], and so forth. It makes a - -- further adjustment at binade boundaries (see comments below) to give - -- the effect of selecting a uniformly distributed real deviate in - -- [0..1] and then rounding to the nearest representable floating-point - -- number. The algorithm attempts to be stingy with random integers. In - -- the worst case, it can consume roughly -Real'Machine_Emin/32 32-bit - -- integers, but this case occurs with probability around - -- 2**Machine_Emin, and the expected number of calls to integer-valued - -- Random is 1. For another discussion of the issues addressed by this - -- process, see Allen Downey's unpublished paper at - -- http://allendowney.com/research/rand/downey07randfloat.pdf. - - if Real'Machine_Radix /= 2 then - return Real'Machine - (Real (Unsigned'(Random (Gen))) * 2.0**(-Unsigned'Size)); - - else - declare - type Bit_Count is range 0 .. 4; - - subtype T is Real'Base; - - Trailing_Ones : constant array (Unsigned_32 range 0 .. 15) - of Bit_Count := - (2#00000# => 0, 2#00001# => 1, 2#00010# => 0, 2#00011# => 2, - 2#00100# => 0, 2#00101# => 1, 2#00110# => 0, 2#00111# => 3, - 2#01000# => 0, 2#01001# => 1, 2#01010# => 0, 2#01011# => 2, - 2#01100# => 0, 2#01101# => 1, 2#01110# => 0, 2#01111# => 4); - - Pow_Tab : constant array (Bit_Count range 0 .. 3) of Real - := (0 => 2.0**(0 - T'Machine_Mantissa), - 1 => 2.0**(-1 - T'Machine_Mantissa), - 2 => 2.0**(-2 - T'Machine_Mantissa), - 3 => 2.0**(-3 - T'Machine_Mantissa)); - - Extra_Bits : constant Natural := - (Unsigned'Size - T'Machine_Mantissa + 1); - -- Random bits left over after selecting mantissa - - Mantissa : Unsigned; - - X : Real; -- Scaled mantissa - R : Unsigned_32; -- Supply of random bits - R_Bits : Natural; -- Number of bits left in R - K : Bit_Count; -- Next decrement to exponent - - begin - Mantissa := Random (Gen) / 2**Extra_Bits; - R := Unsigned_32 (Mantissa mod 2**Extra_Bits); - R_Bits := Extra_Bits; - X := Real (2**(T'Machine_Mantissa - 1) + Mantissa); -- Exact - - if Extra_Bits < 4 and then R < 2 ** Extra_Bits - 1 then - - -- We got lucky and got a zero in our few extra bits - - K := Trailing_Ones (R); - - else - Find_Zero : loop - - -- R has R_Bits unprocessed random bits, a multiple of 4. - -- X needs to be halved for each trailing one bit. The - -- process stops as soon as a 0 bit is found. If R_Bits - -- becomes zero, reload R. - - -- Process 4 bits at a time for speed: the two iterations - -- on average with three tests each was still too slow, - -- probably because the branches are not predictable. - -- This loop now will only execute once 94% of the cases, - -- doing more bits at a time will not help. - - while R_Bits >= 4 loop - K := Trailing_Ones (R mod 16); - - exit Find_Zero when K < 4; -- Exits 94% of the time - - R_Bits := R_Bits - 4; - X := X / 16.0; - R := R / 16; - end loop; - - -- Do not allow us to loop endlessly even in the (very - -- unlikely) case that Random (Gen) keeps yielding all ones. - - exit Find_Zero when X = 0.0; - R := Random (Gen); - R_Bits := 32; - end loop Find_Zero; - end if; - - -- K has the count of trailing ones not reflected yet in X. The - -- following multiplication takes care of that, as well as the - -- correction to move the radix point to the left of the mantissa. - -- Doing it at the end avoids repeated rounding errors in the - -- exceedingly unlikely case of ever having a subnormal result. - - X := X * Pow_Tab (K); - - -- The smallest value in each binade is rounded to by 0.75 of - -- the span of real numbers as its next larger neighbor, and - -- 1.0 is rounded to by half of the span of real numbers as its - -- next smaller neighbor. To account for this, when we encounter - -- the smallest number in a binade, we substitute the smallest - -- value in the next larger binade with probability 1/2. - - if Mantissa = 0 and then Unsigned_32'(Random (Gen)) mod 2 = 0 then - X := 2.0 * X; - end if; - - return X; - end; - end if; - end Random_Float_Template; - - ------------ - -- Random -- - ------------ - - function Random (Gen : Generator) return Float is - function F is new Random_Float_Template (Unsigned_32, Float); - begin - return F (Gen); - end Random; - - function Random (Gen : Generator) return Long_Float is - function F is new Random_Float_Template (Unsigned_64, Long_Float); - begin - return F (Gen); - end Random; - - function Random (Gen : Generator) return Unsigned_64 is - begin - return Shift_Left (Unsigned_64 (Unsigned_32'(Random (Gen))), 32) - or Unsigned_64 (Unsigned_32'(Random (Gen))); - end Random; - - --------------------- - -- Random_Discrete -- - --------------------- - - function Random_Discrete - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype - is - begin - if Max = Min then - return Max; - - elsif Max < Min then - raise Constraint_Error; - - elsif Result_Subtype'Base'Size > 32 then - declare - -- In the 64-bit case, we have to be careful, since not all 64-bit - -- unsigned values are representable in GNAT's root_integer type. - -- Ignore different-size warnings here since GNAT's handling - -- is correct. - - pragma Warnings ("Z"); - function Conv_To_Unsigned is - new Unchecked_Conversion (Result_Subtype'Base, Unsigned_64); - function Conv_To_Result is - new Unchecked_Conversion (Unsigned_64, Result_Subtype'Base); - pragma Warnings ("z"); - - N : constant Unsigned_64 := - Conv_To_Unsigned (Max) - Conv_To_Unsigned (Min) + 1; - - X, Slop : Unsigned_64; - - begin - if N = 0 then - return Conv_To_Result (Conv_To_Unsigned (Min) + Random (Gen)); - - else - Slop := Unsigned_64'Last rem N + 1; - - loop - X := Random (Gen); - exit when Slop = N or else X <= Unsigned_64'Last - Slop; - end loop; - - return Conv_To_Result (Conv_To_Unsigned (Min) + X rem N); - end if; - end; - - elsif Result_Subtype'Pos (Max) - Result_Subtype'Pos (Min) = - 2 ** 32 - 1 - then - return Result_Subtype'Val - (Result_Subtype'Pos (Min) + Unsigned_32'Pos (Random (Gen))); - else - declare - N : constant Unsigned_32 := - Unsigned_32 (Result_Subtype'Pos (Max) - - Result_Subtype'Pos (Min) + 1); - Slop : constant Unsigned_32 := Unsigned_32'Last rem N + 1; - X : Unsigned_32; - - begin - loop - X := Random (Gen); - exit when Slop = N or else X <= Unsigned_32'Last - Slop; - end loop; - - return - Result_Subtype'Val - (Result_Subtype'Pos (Min) + Unsigned_32'Pos (X rem N)); - end; - end if; - end Random_Discrete; - - ------------------ - -- Random_Float -- - ------------------ - - function Random_Float (Gen : Generator) return Result_Subtype is - begin - if Result_Subtype'Base'Digits > Float'Digits then - return Result_Subtype'Machine (Result_Subtype - (Long_Float'(Random (Gen)))); - else - return Result_Subtype'Machine (Result_Subtype - (Float'(Random (Gen)))); - end if; - end Random_Float; - - ----------- - -- Reset -- - ----------- - - procedure Reset (Gen : Generator) is - begin - Init (Gen, Unsigned_32'Mod (Random_Seed.Get_Seed)); - end Reset; - - procedure Reset (Gen : Generator; Initiator : Integer_32) is - begin - Init (Gen, To_Unsigned (Initiator)); - end Reset; - - procedure Reset (Gen : Generator; Initiator : Unsigned_32) is - begin - Init (Gen, Initiator); - end Reset; - - procedure Reset (Gen : Generator; Initiator : Integer) is - begin - -- This is probably an unnecessary precaution against future change, but - -- since the test is a static expression, no extra code is involved. - - if Integer'Size <= 32 then - Init (Gen, To_Unsigned (Integer_32 (Initiator))); - - else - declare - Initiator1 : constant Unsigned_64 := - To_Unsigned (Integer_64 (Initiator)); - Init0 : constant Unsigned_32 := - Unsigned_32 (Initiator1 mod 2 ** 32); - Init1 : constant Unsigned_32 := - Unsigned_32 (Shift_Right (Initiator1, 32)); - begin - Reset (Gen, Initialization_Vector'(Init0, Init1)); - end; - end if; - end Reset; - - procedure Reset (Gen : Generator; Initiator : Initialization_Vector) is - G : Generator renames Gen.Writable.Self.all; - I, J : Integer; - - begin - Init (G, Seed1); - I := 1; - J := 0; - - if Initiator'Length > 0 then - for K in reverse 1 .. Integer'Max (N, Initiator'Length) loop - G.S (I) := - (G.S (I) xor ((G.S (I - 1) - xor Shift_Right (G.S (I - 1), 30)) * Mult1)) - + Initiator (J + Initiator'First) + Unsigned_32 (J); - - I := I + 1; - J := J + 1; - - if I >= N then - G.S (0) := G.S (N - 1); - I := 1; - end if; - - if J >= Initiator'Length then - J := 0; - end if; - end loop; - end if; - - for K in reverse 1 .. N - 1 loop - G.S (I) := - (G.S (I) xor ((G.S (I - 1) - xor Shift_Right (G.S (I - 1), 30)) * Mult2)) - - Unsigned_32 (I); - I := I + 1; - - if I >= N then - G.S (0) := G.S (N - 1); - I := 1; - end if; - end loop; - - G.S (0) := Upper_Mask; - end Reset; - - procedure Reset (Gen : Generator; From_State : Generator) is - G : Generator renames Gen.Writable.Self.all; - begin - G.S := From_State.S; - G.I := From_State.I; - end Reset; - - procedure Reset (Gen : Generator; From_State : State) is - G : Generator renames Gen.Writable.Self.all; - begin - G.I := 0; - G.S := From_State; - end Reset; - - procedure Reset (Gen : Generator; From_Image : String) is - G : Generator renames Gen.Writable.Self.all; - begin - G.I := 0; - - for J in 0 .. N - 1 loop - G.S (J) := Extract_Value (From_Image, J); - end loop; - end Reset; - - ---------- - -- Save -- - ---------- - - procedure Save (Gen : Generator; To_State : out State) is - Gen2 : Generator; - - begin - if Gen.I = N then - Init (Gen2, 5489); - To_State := Gen2.S; - - else - To_State (0 .. N - 1 - Gen.I) := Gen.S (Gen.I .. N - 1); - To_State (N - Gen.I .. N - 1) := Gen.S (0 .. Gen.I - 1); - end if; - end Save; - - ----------- - -- Image -- - ----------- - - function Image (Of_State : State) return String is - Result : Image_String; - - begin - Result := (others => ' '); - - for J in Of_State'Range loop - Insert_Image (Result, J, Of_State (J)); - end loop; - - return Result; - end Image; - - function Image (Gen : Generator) return String is - Result : Image_String; - - begin - Result := (others => ' '); - for J in 0 .. N - 1 loop - Insert_Image (Result, J, Gen.S ((J + Gen.I) mod N)); - end loop; - - return Result; - end Image; - - ----------- - -- Value -- - ----------- - - function Value (Coded_State : String) return State is - Gen : Generator; - S : State; - begin - Reset (Gen, Coded_State); - Save (Gen, S); - return S; - end Value; - - ---------- - -- Init -- - ---------- - - procedure Init (Gen : Generator; Initiator : Unsigned_32) is - G : Generator renames Gen.Writable.Self.all; - begin - G.S (0) := Initiator; - - for I in 1 .. N - 1 loop - G.S (I) := - (G.S (I - 1) xor Shift_Right (G.S (I - 1), 30)) * Mult0 - + Unsigned_32 (I); - end loop; - - G.I := 0; - end Init; - - ------------------ - -- Insert_Image -- - ------------------ - - procedure Insert_Image - (S : in out Image_String; - Index : Integer; - V : State_Val) - is - Value : constant String := State_Val'Image (V); - begin - S (Index * 11 + 1 .. Index * 11 + Value'Length) := Value; - end Insert_Image; - - ------------------- - -- Extract_Value -- - ------------------- - - function Extract_Value (S : String; Index : Integer) return State_Val is - Start : constant Integer := S'First + Index * Image_Numeral_Length; - begin - return State_Val'Value (S (Start .. Start + Image_Numeral_Length - 1)); - end Extract_Value; - -end System.Random_Numbers; diff --git a/gcc/ada/s-rannum.ads b/gcc/ada/s-rannum.ads deleted file mode 100644 index a986311..0000000 --- a/gcc/ada/s-rannum.ads +++ /dev/null @@ -1,162 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R A N D O M _ N U M B E R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Extended pseudo-random number generation - --- This package provides a type representing pseudo-random number generators, --- and subprograms to extract various uniform distributions of numbers --- from them. It also provides types for representing initialization values --- and snapshots of internal generator state, which permit reproducible --- pseudo-random streams. - --- The generator currently provided by this package has an extremely long --- period (at least 2**19937-1), and passes the Big Crush test suite, with the --- exception of the two linear complexity tests. Therefore, it is suitable --- for simulations, but should not be used as a cryptographic pseudo-random --- source without additional processing. - --- Note: this package is in the System hierarchy so that it can be directly --- used by other predefined packages. User access to this package is via --- the package GNAT.Random_Numbers (file g-rannum.ads), which also extends --- its capabilities. The interfaces are different so as to include in --- System.Random_Numbers only the definitions necessary to implement the --- standard random-number packages Ada.Numerics.Float_Random and --- Ada.Numerics.Discrete_Random. - --- Note: this package is marked SPARK_Mode Off, because functions Random work --- by side-effect to change the value of the generator, hence they should not --- be called from SPARK code. - -with Interfaces; - -package System.Random_Numbers with - SPARK_Mode => Off -is - type Generator is limited private; - -- Generator encodes the current state of a random number stream, it is - -- provided as input to produce the next random number, and updated so - -- that it is ready to produce the next one. - - type State is private; - -- A non-limited version of a Generator's internal state - - function Random (Gen : Generator) return Float; - function Random (Gen : Generator) return Long_Float; - -- Return pseudo-random numbers uniformly distributed on [0.0 .. 1.0) - - function Random (Gen : Generator) return Interfaces.Unsigned_32; - function Random (Gen : Generator) return Interfaces.Unsigned_64; - -- Return pseudo-random numbers uniformly distributed on T'First .. T'Last - -- for builtin integer types. - - generic - type Result_Subtype is (<>); - Default_Min : Result_Subtype := Result_Subtype'Val (0); - function Random_Discrete - (Gen : Generator; - Min : Result_Subtype := Default_Min; - Max : Result_Subtype := Result_Subtype'Last) return Result_Subtype; - -- Returns pseudo-random numbers uniformly distributed on Min .. Max - - generic - type Result_Subtype is digits <>; - function Random_Float (Gen : Generator) return Result_Subtype; - -- Returns pseudo-random numbers uniformly distributed on [0 .. 1) - - type Initialization_Vector is - array (Integer range <>) of Interfaces.Unsigned_32; - -- Provides the most general initialization values for a generator (used - -- in Reset). In general, there is little point in providing more than - -- a certain number of values (currently 624). - - procedure Reset (Gen : Generator); - -- Re-initialize the state of Gen from the time of day - - procedure Reset (Gen : Generator; Initiator : Initialization_Vector); - procedure Reset (Gen : Generator; Initiator : Interfaces.Integer_32); - procedure Reset (Gen : Generator; Initiator : Interfaces.Unsigned_32); - procedure Reset (Gen : Generator; Initiator : Integer); - -- Re-initialize Gen based on the Initiator in various ways. Identical - -- values of Initiator cause identical sequences of values. - - procedure Reset (Gen : Generator; From_State : Generator); - -- Causes the state of Gen to be identical to that of From_State; Gen - -- and From_State will produce identical sequences of values subsequently. - - procedure Reset (Gen : Generator; From_State : State); - procedure Save (Gen : Generator; To_State : out State); - -- The sequence - -- Save (Gen2, S); Reset (Gen1, S) - -- has the same effect as Reset (Gen2, Gen1). - - procedure Reset (Gen : Generator; From_Image : String); - function Image (Gen : Generator) return String; - -- The call - -- Reset (Gen2, Image (Gen1)) - -- has the same effect as Reset (Gen2, Gen1); - - Max_Image_Width : constant := 11 * 624; - -- Maximum possible length of result of Image (...) - - function Image (Of_State : State) return String; - -- A String representation of Of_State. Identical to the result of - -- Image (Gen), if Of_State has been set with Save (Gen, Of_State). - - function Value (Coded_State : String) return State; - -- Inverse of Image on States - -private - - N : constant := 624; - -- The number of 32-bit integers in the shift register - - M : constant := 397; - -- Feedback distance from the current position - - subtype State_Val is Interfaces.Unsigned_32; - type State is array (0 .. N - 1) of State_Val; - - type Writable_Access (Self : access Generator) is limited null record; - -- Auxiliary type to make Generator a self-referential type - - type Generator is limited record - Writable : Writable_Access (Generator'Access); - -- This self reference allows functions to modify Generator arguments - - S : State := (others => 0); - -- The shift register, a circular buffer - - I : Integer := N; - -- Current starting position in shift register S (N means uninitialized) - -- We should avoid using the identifier I here ??? - end record; - -end System.Random_Numbers; diff --git a/gcc/ada/s-ransee.adb b/gcc/ada/s-ransee.adb deleted file mode 100644 index 3f97ca3..0000000 --- a/gcc/ada/s-ransee.adb +++ /dev/null @@ -1,55 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R A N D O M _ S E E D -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Version used on all systems except Ravenscar where Calendar is unavailable - -with Ada.Calendar; use Ada.Calendar; -with Ada.Unchecked_Conversion; - -package body System.Random_Seed is - - Y2K : constant Time := - Time_Of (Year => 2000, Month => 1, Day => 1, Seconds => 0.0); - -- First day of Year 2000, to get a duration - - function To_U64 is - new Ada.Unchecked_Conversion (Duration, Interfaces.Unsigned_64); - - -------------- - -- Get_Seed -- - -------------- - - function Get_Seed return Interfaces.Unsigned_64 is - begin - return To_U64 (Clock - Y2K); - end Get_Seed; - -end System.Random_Seed; diff --git a/gcc/ada/s-ransee.ads b/gcc/ada/s-ransee.ads deleted file mode 100644 index 8e4071f..0000000 --- a/gcc/ada/s-ransee.ads +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R A N D O M _ S E E D -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provide a seed for pseudo-random number generation using --- the clock. - --- There are two separate implementations of this package: --- o one based on Ada.Calendar --- o one based on Ada.Real_Time - --- This is required because Ada.Calendar cannot be used on Ravenscar, but --- Ada.Real_Time drags in the whole tasking runtime on regular platforms. - -with Interfaces; - -package System.Random_Seed is - - function Get_Seed return Interfaces.Unsigned_64; - -- Get a seed based on the clock - -end System.Random_Seed; diff --git a/gcc/ada/s-regexp.adb b/gcc/ada/s-regexp.adb deleted file mode 100644 index 58a63a2..0000000 --- a/gcc/ada/s-regexp.adb +++ /dev/null @@ -1,1729 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . R E G E X P -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; -with System.Case_Util; - -package body System.Regexp is - - Initial_Max_States_In_Primary_Table : constant := 100; - -- Initial size for the number of states in the indefinite state - -- machine. The number of states will be increased as needed. - -- - -- This is also used as the maximal number of meta states (groups of - -- states) in the secondary table. - - Open_Paren : constant Character := '('; - Close_Paren : constant Character := ')'; - Open_Bracket : constant Character := '['; - Close_Bracket : constant Character := ']'; - - type State_Index is new Natural; - type Column_Index is new Natural; - - type Regexp_Array is array - (State_Index range <>, Column_Index range <>) of State_Index; - -- First index is for the state number. Second index is for the character - -- type. Contents is the new State. - - type Regexp_Array_Access is access Regexp_Array; - -- Use this type through the functions Set below, so that it can grow - -- dynamically depending on the needs. - - type Mapping is array (Character'Range) of Column_Index; - -- Mapping between characters and column in the Regexp_Array - - type Boolean_Array is array (State_Index range <>) of Boolean; - - type Regexp_Value - (Alphabet_Size : Column_Index; - Num_States : State_Index) is - record - Map : Mapping; - Case_Sensitive : Boolean; - States : Regexp_Array (1 .. Num_States, 0 .. Alphabet_Size); - Is_Final : Boolean_Array (1 .. Num_States); - end record; - -- Deterministic finite-state machine - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Set - (Table : in out Regexp_Array_Access; - State : State_Index; - Column : Column_Index; - Value : State_Index); - -- Sets a value in the table. If the table is too small, reallocate it - -- dynamically so that (State, Column) is a valid index in it. - - function Get - (Table : Regexp_Array_Access; - State : State_Index; - Column : Column_Index) return State_Index; - -- Returns the value in the table at (State, Column). If this index does - -- not exist in the table, returns zero. - - procedure Free is new Ada.Unchecked_Deallocation - (Regexp_Array, Regexp_Array_Access); - - ------------ - -- Adjust -- - ------------ - - procedure Adjust (R : in out Regexp) is - Tmp : Regexp_Access; - begin - if R.R /= null then - Tmp := new Regexp_Value (Alphabet_Size => R.R.Alphabet_Size, - Num_States => R.R.Num_States); - Tmp.all := R.R.all; - R.R := Tmp; - end if; - end Adjust; - - ------------- - -- Compile -- - ------------- - - function Compile - (Pattern : String; - Glob : Boolean := False; - Case_Sensitive : Boolean := True) return Regexp - is - S : String := Pattern; - -- The pattern which is really compiled (when the pattern is case - -- insensitive, we convert this string to lower-cases - - Map : Mapping := (others => 0); - -- Mapping between characters and columns in the tables - - Alphabet_Size : Column_Index := 0; - -- Number of significant characters in the regular expression. - -- This total does not include special operators, such as *, (, ... - - procedure Check_Well_Formed_Pattern; - -- Check that the pattern to compile is well-formed, so that subsequent - -- code can rely on this without performing each time the checks to - -- avoid accessing the pattern outside its bounds. However, not all - -- well-formedness rules are checked. In particular, rules about special - -- characters not being treated as regular characters are not checked. - - procedure Create_Mapping; - -- Creates a mapping between characters in the regexp and columns - -- in the tables representing the regexp. Test that the regexp is - -- well-formed Modifies Alphabet_Size and Map - - procedure Create_Primary_Table - (Table : out Regexp_Array_Access; - Num_States : out State_Index; - Start_State : out State_Index; - End_State : out State_Index); - -- Creates the first version of the regexp (this is a non deterministic - -- finite state machine, which is unadapted for a fast pattern - -- matching algorithm). We use a recursive algorithm to process the - -- parenthesis sub-expressions. - -- - -- Table : at the end of the procedure : Column 0 is for any character - -- ('.') and the last columns are for no character (closure). Num_States - -- is set to the number of states in the table Start_State is the number - -- of the starting state in the regexp End_State is the number of the - -- final state when the regexp matches. - - procedure Create_Primary_Table_Glob - (Table : out Regexp_Array_Access; - Num_States : out State_Index; - Start_State : out State_Index; - End_State : out State_Index); - -- Same function as above, but it deals with the second possible - -- grammar for 'globbing pattern', which is a kind of subset of the - -- whole regular expression grammar. - - function Create_Secondary_Table - (First_Table : Regexp_Array_Access; - Start_State : State_Index; - End_State : State_Index) return Regexp; - -- Creates the definitive table representing the regular expression - -- This is actually a transformation of the primary table First_Table, - -- where every state is grouped with the states in its 'no-character' - -- columns. The transitions between the new states are then recalculated - -- and if necessary some new states are created. - -- - -- Note that the resulting finite-state machine is not optimized in - -- terms of the number of states : it would be more time-consuming to - -- add a third pass to reduce the number of states in the machine, with - -- no speed improvement... - - procedure Raise_Exception (M : String; Index : Integer); - pragma No_Return (Raise_Exception); - -- Raise an exception, indicating an error at character Index in S - - ------------------------------- - -- Check_Well_Formed_Pattern -- - ------------------------------- - - procedure Check_Well_Formed_Pattern is - J : Integer; - - Past_Elmt : Boolean := False; - -- Set to True everywhere an elmt has been parsed, if Glob=False, - -- meaning there can be now an occurrence of '*', '+' and '?'. - - Past_Term : Boolean := False; - -- Set to True everywhere a term has been parsed, if Glob=False, - -- meaning there can be now an occurrence of '|'. - - Parenthesis_Level : Integer := 0; - Curly_Level : Integer := 0; - - Last_Open : Integer := S'First - 1; - -- The last occurrence of an opening parenthesis, if Glob=False, - -- or the last occurrence of an opening curly brace, if Glob=True. - - procedure Raise_Exception_If_No_More_Chars (K : Integer := 0); - -- If no more characters are raised, call Raise_Exception - - -------------------------------------- - -- Raise_Exception_If_No_More_Chars -- - -------------------------------------- - - procedure Raise_Exception_If_No_More_Chars (K : Integer := 0) is - begin - if J + K > S'Last then - Raise_Exception ("Ill-formed pattern while parsing", J); - end if; - end Raise_Exception_If_No_More_Chars; - - -- Start of processing for Check_Well_Formed_Pattern - - begin - J := S'First; - while J <= S'Last loop - case S (J) is - when Open_Bracket => - J := J + 1; - Raise_Exception_If_No_More_Chars; - - if not Glob then - if S (J) = '^' then - J := J + 1; - Raise_Exception_If_No_More_Chars; - end if; - end if; - - -- The first character never has a special meaning - - if S (J) = ']' or else S (J) = '-' then - J := J + 1; - Raise_Exception_If_No_More_Chars; - end if; - - -- The set of characters cannot be empty - - if S (J) = ']' then - Raise_Exception - ("Set of characters cannot be empty in regular " - & "expression", J); - end if; - - declare - Possible_Range_Start : Boolean := True; - -- Set True everywhere a range character '-' can occur - - begin - loop - exit when S (J) = Close_Bracket; - - -- The current character should be followed by a - -- closing bracket. - - Raise_Exception_If_No_More_Chars (1); - - if S (J) = '-' - and then S (J + 1) /= Close_Bracket - then - if not Possible_Range_Start then - Raise_Exception - ("No mix of ranges is allowed in " - & "regular expression", J); - end if; - - J := J + 1; - Raise_Exception_If_No_More_Chars; - - -- Range cannot be followed by '-' character, - -- except as last character in the set. - - Possible_Range_Start := False; - - else - Possible_Range_Start := True; - end if; - - if S (J) = '\' then - J := J + 1; - Raise_Exception_If_No_More_Chars; - end if; - - J := J + 1; - end loop; - end; - - -- A closing bracket can end an elmt or term - - Past_Elmt := True; - Past_Term := True; - - when Close_Bracket => - - -- A close bracket must follow a open_bracket, and cannot be - -- found alone on the line. - - Raise_Exception - ("Incorrect character ']' in regular expression", J); - - when '\' => - if J < S'Last then - J := J + 1; - - -- Any character can be an elmt or a term - - Past_Elmt := True; - Past_Term := True; - - else - -- \ not allowed at the end of the regexp - - Raise_Exception - ("Incorrect character '\' in regular expression", J); - end if; - - when Open_Paren => - if not Glob then - Parenthesis_Level := Parenthesis_Level + 1; - Last_Open := J; - - -- An open parenthesis does not end an elmt or term - - Past_Elmt := False; - Past_Term := False; - end if; - - when Close_Paren => - if not Glob then - Parenthesis_Level := Parenthesis_Level - 1; - - if Parenthesis_Level < 0 then - Raise_Exception - ("')' is not associated with '(' in regular " - & "expression", J); - end if; - - if J = Last_Open + 1 then - Raise_Exception - ("Empty parentheses not allowed in regular " - & "expression", J); - end if; - - if not Past_Term then - Raise_Exception - ("Closing parenthesis not allowed here in regular " - & "expression", J); - end if; - - -- A closing parenthesis can end an elmt or term - - Past_Elmt := True; - Past_Term := True; - end if; - - when '{' => - if Glob then - Curly_Level := Curly_Level + 1; - Last_Open := J; - - else - -- Any character can be an elmt or a term - - Past_Elmt := True; - Past_Term := True; - end if; - - -- No need to check for ',' as the code always accepts them - - when '}' => - if Glob then - Curly_Level := Curly_Level - 1; - - if Curly_Level < 0 then - Raise_Exception - ("'}' is not associated with '{' in regular " - & "expression", J); - end if; - - if J = Last_Open + 1 then - Raise_Exception - ("Empty curly braces not allowed in regular " - & "expression", J); - end if; - - else - -- Any character can be an elmt or a term - - Past_Elmt := True; - Past_Term := True; - end if; - - when '*' | '?' | '+' => - if not Glob then - - -- These operators must apply to an elmt sub-expression, - -- and cannot be found if one has not just been parsed. - - if not Past_Elmt then - Raise_Exception - ("'*', '+' and '?' operators must be " - & "applied to an element in regular expression", J); - end if; - - Past_Elmt := False; - Past_Term := True; - end if; - - when '|' => - if not Glob then - - -- This operator must apply to a term sub-expression, - -- and cannot be found if one has not just been parsed. - - if not Past_Term then - Raise_Exception - ("'|' operator must be " - & "applied to a term in regular expression", J); - end if; - - Past_Elmt := False; - Past_Term := False; - end if; - - when others => - if not Glob then - - -- Any character can be an elmt or a term - - Past_Elmt := True; - Past_Term := True; - end if; - end case; - - J := J + 1; - end loop; - - -- A closing parenthesis must follow an open parenthesis - - if Parenthesis_Level /= 0 then - Raise_Exception - ("'(' must always be associated with a ')'", J); - end if; - - -- A closing curly brace must follow an open curly brace - - if Curly_Level /= 0 then - Raise_Exception - ("'{' must always be associated with a '}'", J); - end if; - end Check_Well_Formed_Pattern; - - -------------------- - -- Create_Mapping -- - -------------------- - - procedure Create_Mapping is - - procedure Add_In_Map (C : Character); - -- Add a character in the mapping, if it is not already defined - - ---------------- - -- Add_In_Map -- - ---------------- - - procedure Add_In_Map (C : Character) is - begin - if Map (C) = 0 then - Alphabet_Size := Alphabet_Size + 1; - Map (C) := Alphabet_Size; - end if; - end Add_In_Map; - - J : Integer := S'First; - Parenthesis_Level : Integer := 0; - Curly_Level : Integer := 0; - Last_Open : Integer := S'First - 1; - - -- Start of processing for Create_Mapping - - begin - while J <= S'Last loop - case S (J) is - when Open_Bracket => - J := J + 1; - - if S (J) = '^' then - J := J + 1; - end if; - - if S (J) = ']' or else S (J) = '-' then - J := J + 1; - end if; - - -- The first character never has a special meaning - - loop - if J > S'Last then - Raise_Exception - ("Ran out of characters while parsing ", J); - end if; - - exit when S (J) = Close_Bracket; - - if S (J) = '-' - and then S (J + 1) /= Close_Bracket - then - declare - Start : constant Integer := J - 1; - - begin - J := J + 1; - - if S (J) = '\' then - J := J + 1; - end if; - - for Char in S (Start) .. S (J) loop - Add_In_Map (Char); - end loop; - end; - else - if S (J) = '\' then - J := J + 1; - end if; - - Add_In_Map (S (J)); - end if; - - J := J + 1; - end loop; - - -- A close bracket must follow a open_bracket and cannot be - -- found alone on the line - - when Close_Bracket => - Raise_Exception - ("Incorrect character ']' in regular expression", J); - - when '\' => - if J < S'Last then - J := J + 1; - Add_In_Map (S (J)); - - else - -- Back slash \ not allowed at the end of the regexp - - Raise_Exception - ("Incorrect character '\' in regular expression", J); - end if; - - when Open_Paren => - if not Glob then - Parenthesis_Level := Parenthesis_Level + 1; - Last_Open := J; - else - Add_In_Map (Open_Paren); - end if; - - when Close_Paren => - if not Glob then - Parenthesis_Level := Parenthesis_Level - 1; - - if Parenthesis_Level < 0 then - Raise_Exception - ("')' is not associated with '(' in regular " - & "expression", J); - end if; - - if J = Last_Open + 1 then - Raise_Exception - ("Empty parenthesis not allowed in regular " - & "expression", J); - end if; - - else - Add_In_Map (Close_Paren); - end if; - - when '.' => - if Glob then - Add_In_Map ('.'); - end if; - - when '{' => - if not Glob then - Add_In_Map (S (J)); - else - Curly_Level := Curly_Level + 1; - end if; - - when '}' => - if not Glob then - Add_In_Map (S (J)); - else - Curly_Level := Curly_Level - 1; - end if; - - when '*' | '?' => - if not Glob then - if J = S'First then - Raise_Exception - ("'*', '+', '?' and '|' operators cannot be in " - & "first position in regular expression", J); - end if; - end if; - - when '|' | '+' => - if not Glob then - if J = S'First then - - -- These operators must apply to a sub-expression, - -- and cannot be found at the beginning of the line - - Raise_Exception - ("'*', '+', '?' and '|' operators cannot be in " - & "first position in regular expression", J); - end if; - - else - Add_In_Map (S (J)); - end if; - - when others => - Add_In_Map (S (J)); - end case; - - J := J + 1; - end loop; - - -- A closing parenthesis must follow an open parenthesis - - if Parenthesis_Level /= 0 then - Raise_Exception - ("'(' must always be associated with a ')'", J); - end if; - - if Curly_Level /= 0 then - Raise_Exception - ("'{' must always be associated with a '}'", J); - end if; - end Create_Mapping; - - -------------------------- - -- Create_Primary_Table -- - -------------------------- - - procedure Create_Primary_Table - (Table : out Regexp_Array_Access; - Num_States : out State_Index; - Start_State : out State_Index; - End_State : out State_Index) - is - Empty_Char : constant Column_Index := Alphabet_Size + 1; - - Current_State : State_Index := 0; - -- Index of the last created state - - procedure Add_Empty_Char - (State : State_Index; - To_State : State_Index); - -- Add a empty-character transition from State to To_State - - procedure Create_Repetition - (Repetition : Character; - Start_Prev : State_Index; - End_Prev : State_Index; - New_Start : out State_Index; - New_End : in out State_Index); - -- Create the table in case we have a '*', '+' or '?'. - -- Start_Prev .. End_Prev should indicate respectively the start and - -- end index of the previous expression, to which '*', '+' or '?' is - -- applied. - - procedure Create_Simple - (Start_Index : Integer; - End_Index : Integer; - Start_State : out State_Index; - End_State : out State_Index); - -- Fill the table for the regexp Simple. This is the recursive - -- procedure called to handle () expressions If End_State = 0, then - -- the call to Create_Simple creates an independent regexp, not a - -- concatenation Start_Index .. End_Index is the starting index in - -- the string S. - -- - -- Warning: it may look like we are creating too many empty-string - -- transitions, but they are needed to get the correct regexp. - -- The table is filled as follow ( s means start-state, e means - -- end-state) : - -- - -- regexp state_num | a b * empty_string - -- ------- ------------------------------ - -- a 1 (s) | 2 - - - - -- 2 (e) | - - - - - -- - -- ab 1 (s) | 2 - - - - -- 2 | - - - 3 - -- 3 | - 4 - - - -- 4 (e) | - - - - - -- - -- a|b 1 | 2 - - - - -- 2 | - - - 6 - -- 3 | - 4 - - - -- 4 | - - - 6 - -- 5 (s) | - - - 1,3 - -- 6 (e) | - - - - - -- - -- a* 1 | 2 - - - - -- 2 | - - - 4 - -- 3 (s) | - - - 1,4 - -- 4 (e) | - - - 3 - -- - -- (a) 1 (s) | 2 - - - - -- 2 (e) | - - - - - -- - -- a+ 1 | 2 - - - - -- 2 | - - - 4 - -- 3 (s) | - - - 1 - -- 4 (e) | - - - 3 - -- - -- a? 1 | 2 - - - - -- 2 | - - - 4 - -- 3 (s) | - - - 1,4 - -- 4 (e) | - - - - - -- - -- . 1 (s) | 2 2 2 - - -- 2 (e) | - - - - - - function Next_Sub_Expression - (Start_Index : Integer; - End_Index : Integer) return Integer; - -- Returns the index of the last character of the next sub-expression - -- in Simple. Index cannot be greater than End_Index. - - -------------------- - -- Add_Empty_Char -- - -------------------- - - procedure Add_Empty_Char - (State : State_Index; - To_State : State_Index) - is - J : Column_Index := Empty_Char; - - begin - while Get (Table, State, J) /= 0 loop - J := J + 1; - end loop; - - Set (Table, State, J, To_State); - end Add_Empty_Char; - - ----------------------- - -- Create_Repetition -- - ----------------------- - - procedure Create_Repetition - (Repetition : Character; - Start_Prev : State_Index; - End_Prev : State_Index; - New_Start : out State_Index; - New_End : in out State_Index) - is - begin - New_Start := Current_State + 1; - - if New_End /= 0 then - Add_Empty_Char (New_End, New_Start); - end if; - - Current_State := Current_State + 2; - New_End := Current_State; - - Add_Empty_Char (End_Prev, New_End); - Add_Empty_Char (New_Start, Start_Prev); - - if Repetition /= '+' then - Add_Empty_Char (New_Start, New_End); - end if; - - if Repetition /= '?' then - Add_Empty_Char (New_End, New_Start); - end if; - end Create_Repetition; - - ------------------- - -- Create_Simple -- - ------------------- - - procedure Create_Simple - (Start_Index : Integer; - End_Index : Integer; - Start_State : out State_Index; - End_State : out State_Index) - is - J : Integer := Start_Index; - Last_Start : State_Index := 0; - - begin - Start_State := 0; - End_State := 0; - while J <= End_Index loop - case S (J) is - when Open_Paren => - declare - J_Start : constant Integer := J + 1; - Next_Start : State_Index; - Next_End : State_Index; - - begin - J := Next_Sub_Expression (J, End_Index); - Create_Simple (J_Start, J - 1, Next_Start, Next_End); - - if J < End_Index - and then (S (J + 1) = '*' or else - S (J + 1) = '+' or else - S (J + 1) = '?') - then - J := J + 1; - Create_Repetition - (S (J), - Next_Start, - Next_End, - Last_Start, - End_State); - - else - Last_Start := Next_Start; - - if End_State /= 0 then - Add_Empty_Char (End_State, Last_Start); - end if; - - End_State := Next_End; - end if; - end; - - when '|' => - declare - Start_Prev : constant State_Index := Start_State; - End_Prev : constant State_Index := End_State; - Start_J : constant Integer := J + 1; - Start_Next : State_Index := 0; - End_Next : State_Index := 0; - - begin - J := Next_Sub_Expression (J, End_Index); - - -- Create a new state for the start of the alternative - - Current_State := Current_State + 1; - Last_Start := Current_State; - Start_State := Last_Start; - - -- Create the tree for the second part of alternative - - Create_Simple (Start_J, J, Start_Next, End_Next); - - -- Create the end state - - Add_Empty_Char (Last_Start, Start_Next); - Add_Empty_Char (Last_Start, Start_Prev); - Current_State := Current_State + 1; - End_State := Current_State; - Add_Empty_Char (End_Prev, End_State); - Add_Empty_Char (End_Next, End_State); - end; - - when Open_Bracket => - Current_State := Current_State + 1; - - declare - Next_State : State_Index := Current_State + 1; - - begin - J := J + 1; - - if S (J) = '^' then - J := J + 1; - - Next_State := 0; - - for Column in 0 .. Alphabet_Size loop - Set (Table, Current_State, Column, - Value => Current_State + 1); - end loop; - end if; - - -- Automatically add the first character - - if S (J) = '-' or else S (J) = ']' then - Set (Table, Current_State, Map (S (J)), - Value => Next_State); - J := J + 1; - end if; - - -- Loop till closing bracket found - - loop - exit when S (J) = Close_Bracket; - - if S (J) = '-' - and then S (J + 1) /= ']' - then - declare - Start : constant Integer := J - 1; - - begin - J := J + 1; - - if S (J) = '\' then - J := J + 1; - end if; - - for Char in S (Start) .. S (J) loop - Set (Table, Current_State, Map (Char), - Value => Next_State); - end loop; - end; - - else - if S (J) = '\' then - J := J + 1; - end if; - - Set (Table, Current_State, Map (S (J)), - Value => Next_State); - end if; - J := J + 1; - end loop; - end; - - Current_State := Current_State + 1; - - -- If the next symbol is a special symbol - - if J < End_Index - and then (S (J + 1) = '*' or else - S (J + 1) = '+' or else - S (J + 1) = '?') - then - J := J + 1; - Create_Repetition - (S (J), - Current_State - 1, - Current_State, - Last_Start, - End_State); - - else - Last_Start := Current_State - 1; - - if End_State /= 0 then - Add_Empty_Char (End_State, Last_Start); - end if; - - End_State := Current_State; - end if; - - when Close_Bracket - | Close_Paren - | '*' | '+' | '?' - => - Raise_Exception - ("Incorrect character in regular expression :", J); - - when others => - Current_State := Current_State + 1; - - -- Create the state for the symbol S (J) - - if S (J) = '.' then - for K in 0 .. Alphabet_Size loop - Set (Table, Current_State, K, - Value => Current_State + 1); - end loop; - - else - if S (J) = '\' then - J := J + 1; - end if; - - Set (Table, Current_State, Map (S (J)), - Value => Current_State + 1); - end if; - - Current_State := Current_State + 1; - - -- If the next symbol is a special symbol - - if J < End_Index - and then (S (J + 1) = '*' or else - S (J + 1) = '+' or else - S (J + 1) = '?') - then - J := J + 1; - Create_Repetition - (S (J), - Current_State - 1, - Current_State, - Last_Start, - End_State); - - else - Last_Start := Current_State - 1; - - if End_State /= 0 then - Add_Empty_Char (End_State, Last_Start); - end if; - - End_State := Current_State; - end if; - end case; - - if Start_State = 0 then - Start_State := Last_Start; - end if; - - J := J + 1; - end loop; - end Create_Simple; - - ------------------------- - -- Next_Sub_Expression -- - ------------------------- - - function Next_Sub_Expression - (Start_Index : Integer; - End_Index : Integer) return Integer - is - J : Integer := Start_Index; - Start_On_Alter : Boolean := False; - - begin - if S (J) = '|' then - Start_On_Alter := True; - end if; - - loop - exit when J = End_Index; - J := J + 1; - - case S (J) is - when '\' => - J := J + 1; - - when Open_Bracket => - loop - J := J + 1; - exit when S (J) = Close_Bracket; - - if S (J) = '\' then - J := J + 1; - end if; - end loop; - - when Open_Paren => - J := Next_Sub_Expression (J, End_Index); - - when Close_Paren => - return J; - - when '|' => - if Start_On_Alter then - return J - 1; - end if; - - when others => - null; - end case; - end loop; - - return J; - end Next_Sub_Expression; - - -- Start of processing for Create_Primary_Table - - begin - Table.all := (others => (others => 0)); - Create_Simple (S'First, S'Last, Start_State, End_State); - Num_States := Current_State; - end Create_Primary_Table; - - ------------------------------- - -- Create_Primary_Table_Glob -- - ------------------------------- - - procedure Create_Primary_Table_Glob - (Table : out Regexp_Array_Access; - Num_States : out State_Index; - Start_State : out State_Index; - End_State : out State_Index) - is - Empty_Char : constant Column_Index := Alphabet_Size + 1; - - Current_State : State_Index := 0; - -- Index of the last created state - - procedure Add_Empty_Char - (State : State_Index; - To_State : State_Index); - -- Add a empty-character transition from State to To_State - - procedure Create_Simple - (Start_Index : Integer; - End_Index : Integer; - Start_State : out State_Index; - End_State : out State_Index); - -- Fill the table for the S (Start_Index .. End_Index). - -- This is the recursive procedure called to handle () expressions - - -------------------- - -- Add_Empty_Char -- - -------------------- - - procedure Add_Empty_Char - (State : State_Index; - To_State : State_Index) - is - J : Column_Index; - - begin - J := Empty_Char; - while Get (Table, State, J) /= 0 loop - J := J + 1; - end loop; - - Set (Table, State, J, Value => To_State); - end Add_Empty_Char; - - ------------------- - -- Create_Simple -- - ------------------- - - procedure Create_Simple - (Start_Index : Integer; - End_Index : Integer; - Start_State : out State_Index; - End_State : out State_Index) - is - J : Integer; - Last_Start : State_Index := 0; - - begin - Start_State := 0; - End_State := 0; - - J := Start_Index; - while J <= End_Index loop - case S (J) is - when Open_Bracket => - Current_State := Current_State + 1; - - declare - Next_State : State_Index := Current_State + 1; - - begin - J := J + 1; - - if S (J) = '^' then - J := J + 1; - Next_State := 0; - - for Column in 0 .. Alphabet_Size loop - Set (Table, Current_State, Column, - Value => Current_State + 1); - end loop; - end if; - - -- Automatically add the first character - - if S (J) = '-' or else S (J) = ']' then - Set (Table, Current_State, Map (S (J)), - Value => Current_State); - J := J + 1; - end if; - - -- Loop till closing bracket found - - loop - exit when S (J) = Close_Bracket; - - if S (J) = '-' - and then S (J + 1) /= ']' - then - declare - Start : constant Integer := J - 1; - - begin - J := J + 1; - - if S (J) = '\' then - J := J + 1; - end if; - - for Char in S (Start) .. S (J) loop - Set (Table, Current_State, Map (Char), - Value => Next_State); - end loop; - end; - - else - if S (J) = '\' then - J := J + 1; - end if; - - Set (Table, Current_State, Map (S (J)), - Value => Next_State); - end if; - J := J + 1; - end loop; - end; - - Last_Start := Current_State; - Current_State := Current_State + 1; - - if End_State /= 0 then - Add_Empty_Char (End_State, Last_Start); - end if; - - End_State := Current_State; - - when '{' => - declare - End_Sub : Integer; - Start_Regexp_Sub : State_Index; - End_Regexp_Sub : State_Index; - Create_Start : State_Index := 0; - - Create_End : State_Index := 0; - -- Initialized to avoid junk warning - - begin - while S (J) /= '}' loop - - -- First step : find sub pattern - - End_Sub := J + 1; - while S (End_Sub) /= ',' - and then S (End_Sub) /= '}' - loop - End_Sub := End_Sub + 1; - end loop; - - -- Second step : create a sub pattern - - Create_Simple - (J + 1, - End_Sub - 1, - Start_Regexp_Sub, - End_Regexp_Sub); - - J := End_Sub; - - -- Third step : create an alternative - - if Create_Start = 0 then - Current_State := Current_State + 1; - Create_Start := Current_State; - Add_Empty_Char (Create_Start, Start_Regexp_Sub); - Current_State := Current_State + 1; - Create_End := Current_State; - Add_Empty_Char (End_Regexp_Sub, Create_End); - - else - Current_State := Current_State + 1; - Add_Empty_Char (Current_State, Create_Start); - Create_Start := Current_State; - Add_Empty_Char (Create_Start, Start_Regexp_Sub); - Add_Empty_Char (End_Regexp_Sub, Create_End); - end if; - end loop; - - if End_State /= 0 then - Add_Empty_Char (End_State, Create_Start); - end if; - - End_State := Create_End; - Last_Start := Create_Start; - end; - - when '*' => - Current_State := Current_State + 1; - - if End_State /= 0 then - Add_Empty_Char (End_State, Current_State); - end if; - - Add_Empty_Char (Current_State, Current_State + 1); - Add_Empty_Char (Current_State, Current_State + 3); - Last_Start := Current_State; - - Current_State := Current_State + 1; - - for K in 0 .. Alphabet_Size loop - Set (Table, Current_State, K, - Value => Current_State + 1); - end loop; - - Current_State := Current_State + 1; - Add_Empty_Char (Current_State, Current_State + 1); - - Current_State := Current_State + 1; - Add_Empty_Char (Current_State, Last_Start); - End_State := Current_State; - - when others => - Current_State := Current_State + 1; - - if S (J) = '?' then - for K in 0 .. Alphabet_Size loop - Set (Table, Current_State, K, - Value => Current_State + 1); - end loop; - - else - if S (J) = '\' then - J := J + 1; - end if; - - -- Create the state for the symbol S (J) - - Set (Table, Current_State, Map (S (J)), - Value => Current_State + 1); - end if; - - Last_Start := Current_State; - Current_State := Current_State + 1; - - if End_State /= 0 then - Add_Empty_Char (End_State, Last_Start); - end if; - - End_State := Current_State; - end case; - - if Start_State = 0 then - Start_State := Last_Start; - end if; - - J := J + 1; - end loop; - end Create_Simple; - - -- Start of processing for Create_Primary_Table_Glob - - begin - Table.all := (others => (others => 0)); - Create_Simple (S'First, S'Last, Start_State, End_State); - Num_States := Current_State; - end Create_Primary_Table_Glob; - - ---------------------------- - -- Create_Secondary_Table -- - ---------------------------- - - function Create_Secondary_Table - (First_Table : Regexp_Array_Access; - Start_State : State_Index; - End_State : State_Index) return Regexp - is - Last_Index : constant State_Index := First_Table'Last (1); - - type Meta_State is array (0 .. Last_Index) of Boolean; - pragma Pack (Meta_State); - -- Whether a state from first_table belongs to a metastate. - - No_States : constant Meta_State := (others => False); - - type Meta_States_Array is array (State_Index range <>) of Meta_State; - type Meta_States_List is access all Meta_States_Array; - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Meta_States_Array, Meta_States_List); - Meta_States : Meta_States_List; - -- Components of meta-states. A given state might belong to - -- several meta-states. - -- This array grows dynamically. - - type Char_To_State is array (0 .. Alphabet_Size) of State_Index; - type Meta_States_Transition_Arr is - array (State_Index range <>) of Char_To_State; - type Meta_States_Transition is access all Meta_States_Transition_Arr; - procedure Unchecked_Free is new Ada.Unchecked_Deallocation - (Meta_States_Transition_Arr, Meta_States_Transition); - Table : Meta_States_Transition; - -- Documents the transitions between each meta-state. The - -- first index is the meta-state, the second column is the - -- character seen in the input, the value is the new meta-state. - - Temp_State_Not_Null : Boolean; - - Current_State : State_Index := 1; - -- The current meta-state we are creating - - Nb_State : State_Index := 1; - -- The total number of meta-states created so far. - - procedure Closure - (Meta_State : State_Index; - State : State_Index); - -- Compute the closure of the state (that is every other state which - -- has a empty-character transition) and add it to the state - - procedure Ensure_Meta_State (Meta : State_Index); - -- grows the Meta_States array as needed to make sure that there - -- is enough space to store the new meta state. - - ----------------------- - -- Ensure_Meta_State -- - ----------------------- - - procedure Ensure_Meta_State (Meta : State_Index) is - Tmp : Meta_States_List := Meta_States; - Tmp2 : Meta_States_Transition := Table; - - begin - if Meta_States = null then - Meta_States := new Meta_States_Array - (1 .. State_Index'Max (Last_Index, Meta) + 1); - Meta_States (Meta_States'Range) := (others => No_States); - - Table := new Meta_States_Transition_Arr - (1 .. State_Index'Max (Last_Index, Meta) + 1); - Table.all := (others => (others => 0)); - - elsif Meta > Meta_States'Last then - Meta_States := new Meta_States_Array - (1 .. State_Index'Max (2 * Tmp'Last, Meta)); - Meta_States (Tmp'Range) := Tmp.all; - Meta_States (Tmp'Last + 1 .. Meta_States'Last) := - (others => No_States); - Unchecked_Free (Tmp); - - Table := new Meta_States_Transition_Arr - (1 .. State_Index'Max (2 * Tmp2'Last, Meta) + 1); - Table (Tmp2'Range) := Tmp2.all; - Table (Tmp2'Last + 1 .. Table'Last) := - (others => (others => 0)); - Unchecked_Free (Tmp2); - end if; - end Ensure_Meta_State; - - ------------- - -- Closure -- - ------------- - - procedure Closure - (Meta_State : State_Index; - State : State_Index) - is - begin - if not Meta_States (Meta_State)(State) then - Meta_States (Meta_State)(State) := True; - - -- For each transition on empty-character - - for Column in Alphabet_Size + 1 .. First_Table'Last (2) loop - exit when First_Table (State, Column) = 0; - Closure (Meta_State, First_Table (State, Column)); - end loop; - end if; - end Closure; - - -- Start of processing for Create_Secondary_Table - - begin - -- Create a new state - - Ensure_Meta_State (Current_State); - Closure (Current_State, Start_State); - - while Current_State <= Nb_State loop - - -- We will be trying, below, to create the next meta-state - - Ensure_Meta_State (Nb_State + 1); - - -- For every character in the regexp, calculate the possible - -- transitions from Current_State. - - for Column in 0 .. Alphabet_Size loop - Temp_State_Not_Null := False; - - for K in Meta_States (Current_State)'Range loop - if Meta_States (Current_State)(K) - and then First_Table (K, Column) /= 0 - then - Closure (Nb_State + 1, First_Table (K, Column)); - Temp_State_Not_Null := True; - end if; - end loop; - - -- If at least one transition existed - - if Temp_State_Not_Null then - - -- Check if this new state corresponds to an old one - - for K in 1 .. Nb_State loop - if Meta_States (K) = Meta_States (Nb_State + 1) then - Table (Current_State)(Column) := K; - - -- Reset data, for the next time we try that state - - Meta_States (Nb_State + 1) := No_States; - exit; - end if; - end loop; - - -- If not, create a new state - - if Table (Current_State)(Column) = 0 then - Nb_State := Nb_State + 1; - Ensure_Meta_State (Nb_State + 1); - Table (Current_State)(Column) := Nb_State; - end if; - end if; - end loop; - - Current_State := Current_State + 1; - end loop; - - -- Returns the regexp - - declare - R : Regexp_Access; - - begin - R := new Regexp_Value (Alphabet_Size => Alphabet_Size, - Num_States => Nb_State); - R.Map := Map; - R.Case_Sensitive := Case_Sensitive; - - for S in 1 .. Nb_State loop - R.Is_Final (S) := Meta_States (S)(End_State); - end loop; - - for State in 1 .. Nb_State loop - for K in 0 .. Alphabet_Size loop - R.States (State, K) := Table (State)(K); - end loop; - end loop; - - Unchecked_Free (Meta_States); - Unchecked_Free (Table); - - return (Ada.Finalization.Controlled with R => R); - end; - end Create_Secondary_Table; - - --------------------- - -- Raise_Exception -- - --------------------- - - procedure Raise_Exception (M : String; Index : Integer) is - begin - raise Error_In_Regexp with M & " at offset" & Index'Img; - end Raise_Exception; - - -- Start of processing for Compile - - begin - -- Special case for the empty string: it always matches, and the - -- following processing would fail on it. - - if S = "" then - return (Ada.Finalization.Controlled with - R => new Regexp_Value' - (Alphabet_Size => 0, - Num_States => 1, - Map => (others => 0), - States => (others => (others => 1)), - Is_Final => (others => True), - Case_Sensitive => True)); - end if; - - if not Case_Sensitive then - System.Case_Util.To_Lower (S); - end if; - - -- Check the pattern is well-formed before any treatment - - Check_Well_Formed_Pattern; - - Create_Mapping; - - -- Creates the primary table - - declare - Table : Regexp_Array_Access; - Num_States : State_Index; - Start_State : State_Index; - End_State : State_Index; - R : Regexp; - - begin - Table := new Regexp_Array (1 .. Initial_Max_States_In_Primary_Table, - 0 .. Alphabet_Size + 10); - if not Glob then - Create_Primary_Table (Table, Num_States, Start_State, End_State); - else - Create_Primary_Table_Glob - (Table, Num_States, Start_State, End_State); - end if; - - -- Creates the secondary table - - R := Create_Secondary_Table (Table, Start_State, End_State); - Free (Table); - return R; - end; - end Compile; - - -------------- - -- Finalize -- - -------------- - - procedure Finalize (R : in out Regexp) is - procedure Free is new - Ada.Unchecked_Deallocation (Regexp_Value, Regexp_Access); - begin - Free (R.R); - end Finalize; - - --------- - -- Get -- - --------- - - function Get - (Table : Regexp_Array_Access; - State : State_Index; - Column : Column_Index) return State_Index - is - begin - if State <= Table'Last (1) - and then Column <= Table'Last (2) - then - return Table (State, Column); - else - return 0; - end if; - end Get; - - ----------- - -- Match -- - ----------- - - function Match (S : String; R : Regexp) return Boolean is - Current_State : State_Index := 1; - - begin - if R.R = null then - raise Constraint_Error; - end if; - - for Char in S'Range loop - - if R.R.Case_Sensitive then - Current_State := R.R.States (Current_State, R.R.Map (S (Char))); - else - Current_State := - R.R.States (Current_State, - R.R.Map (System.Case_Util.To_Lower (S (Char)))); - end if; - - if Current_State = 0 then - return False; - end if; - - end loop; - - return R.R.Is_Final (Current_State); - end Match; - - --------- - -- Set -- - --------- - - procedure Set - (Table : in out Regexp_Array_Access; - State : State_Index; - Column : Column_Index; - Value : State_Index) - is - New_Lines : State_Index; - New_Columns : Column_Index; - New_Table : Regexp_Array_Access; - - begin - if State <= Table'Last (1) - and then Column <= Table'Last (2) - then - Table (State, Column) := Value; - else - -- Doubles the size of the table until it is big enough that - -- (State, Column) is a valid index. - - New_Lines := Table'Last (1) * (State / Table'Last (1) + 1); - New_Columns := Table'Last (2) * (Column / Table'Last (2) + 1); - New_Table := new Regexp_Array (Table'First (1) .. New_Lines, - Table'First (2) .. New_Columns); - New_Table.all := (others => (others => 0)); - - for J in Table'Range (1) loop - for K in Table'Range (2) loop - New_Table (J, K) := Table (J, K); - end loop; - end loop; - - Free (Table); - Table := New_Table; - Table (State, Column) := Value; - end if; - end Set; - -end System.Regexp; diff --git a/gcc/ada/s-regexp.ads b/gcc/ada/s-regexp.ads deleted file mode 100644 index 0155b43..0000000 --- a/gcc/ada/s-regexp.ads +++ /dev/null @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . R E G E X P -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Simple Regular expression matching - --- This package provides a simple implementation of a regular expression --- pattern matching algorithm, using a subset of the syntax of regular --- expressions copied from familiar Unix style utilities. - --- Note: this package is in the System hierarchy so that it can be directly --- be used by other predefined packages. User access to this package is via --- a renaming of this package in GNAT.Regexp (file g-regexp.ads). - -with Ada.Finalization; - -package System.Regexp is - - -- The regular expression must first be compiled, using the Compile - -- function, which creates a finite state matching table, allowing - -- very fast matching once the expression has been compiled. - - -- The following is the form of a regular expression, expressed in Ada - -- reference manual style BNF is as follows - - -- regexp ::= term - - -- regexp ::= term | term -- alternation (term or term ...) - - -- term ::= item - - -- term ::= item item ... -- concatenation (item then item) - - -- item ::= elmt -- match elmt - -- item ::= elmt * -- zero or more elmt's - -- item ::= elmt + -- one or more elmt's - -- item ::= elmt ? -- matches elmt or nothing - - -- elmt ::= nchr -- matches given character - -- elmt ::= [nchr nchr ...] -- matches any character listed - -- elmt ::= [^ nchr nchr ...] -- matches any character not listed - -- elmt ::= [char - char] -- matches chars in given range - -- elmt ::= . -- matches any single character - -- elmt ::= ( regexp ) -- parens used for grouping - - -- char ::= any character, including special characters - -- nchr ::= any character except \()[].*+?^ or \char to match char - -- ... is used to indication repetition (one or more terms) - - -- See also regexp(1) man page on Unix systems for further details - - -- A second kind of regular expressions is provided. This one is more - -- like the wild card patterns used in file names by the Unix shell (or - -- DOS prompt) command lines. The grammar is the following: - - -- regexp ::= term - - -- term ::= elmt - -- term ::= elmt elmt ... -- concatenation (elmt then elmt) - -- term ::= {elmt, elmt, ...} -- alternation (matches any of elmt) - - -- elmt ::= * -- any string of 0 or more characters - -- elmt ::= ? -- matches any character - -- elmt ::= char - -- elmt ::= [^ char char ...] -- matches any character not listed - -- elmt ::= [char char ...] -- matches any character listed - -- elmt ::= [char - char] -- matches any character in given range - - -- \char is also supported by this grammar. - - -- Important note : This package was mainly intended to match regular - -- expressions against file names. The whole string has to match the - -- regular expression. If only a substring matches, then the function - -- Match will return False. - - type Regexp is private; - -- Private type used to represent a regular expression - - Error_In_Regexp : exception; - -- Exception raised when an error is found in the regular expression - - function Compile - (Pattern : String; - Glob : Boolean := False; - Case_Sensitive : Boolean := True) return Regexp; - -- Compiles a regular expression S. If the syntax of the given - -- expression is invalid (does not match above grammar), Error_In_Regexp - -- is raised. If Glob is True, the pattern is considered as a 'globbing - -- pattern', that is a pattern as given by the second grammar above. - -- As a special case, if Pattern is the empty string it will always - -- match. - - function Match (S : String; R : Regexp) return Boolean; - -- True if S matches R, otherwise False. Raises Constraint_Error if - -- R is an uninitialized regular expression value. - -private - type Regexp_Value; - - type Regexp_Access is access Regexp_Value; - - type Regexp is new Ada.Finalization.Controlled with record - R : Regexp_Access := null; - end record; - - pragma Finalize_Storage_Only (Regexp); - - procedure Finalize (R : in out Regexp); - -- Free the memory occupied by R - - procedure Adjust (R : in out Regexp); - -- Called after an assignment (do a copy of the Regexp_Access.all) - -end System.Regexp; diff --git a/gcc/ada/s-regpat.adb b/gcc/ada/s-regpat.adb deleted file mode 100644 index 9ea4e36..0000000 --- a/gcc/ada/s-regpat.adb +++ /dev/null @@ -1,3754 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- G N A T . R E G P A T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1999-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is an altered Ada 95 version of the original V8 style regular --- expression library written in C by Henry Spencer. Apart from the --- translation to Ada, the interface has been considerably changed to --- use the Ada String type instead of C-style nul-terminated strings. - --- Beware that some of this code is subtly aware of the way operator --- precedence is structured in regular expressions. Serious changes in --- regular-expression syntax might require a total rethink. - -with System.IO; use System.IO; -with Ada.Characters.Handling; use Ada.Characters.Handling; -with Ada.Unchecked_Conversion; - -package body System.Regpat is - - Debug : constant Boolean := False; - -- Set to True to activate debug traces. This is normally set to constant - -- False to simply delete all the trace code. It is to be edited to True - -- for internal debugging of the package. - - ---------------------------- - -- Implementation details -- - ---------------------------- - - -- This is essentially a linear encoding of a nondeterministic - -- finite-state machine, also known as syntax charts or - -- "railroad normal form" in parsing technology. - - -- Each node is an opcode plus a "next" pointer, possibly plus an - -- operand. "Next" pointers of all nodes except BRANCH implement - -- concatenation; a "next" pointer with a BRANCH on both ends of it - -- is connecting two alternatives. - - -- The operand of some types of node is a literal string; for others, - -- it is a node leading into a sub-FSM. In particular, the operand of - -- a BRANCH node is the first node of the branch. - -- (NB this is *not* a tree structure: the tail of the branch connects - -- to the thing following the set of BRANCHes). - - -- You can see the exact byte-compiled version by using the Dump - -- subprogram. However, here are a few examples: - - -- (a|b): 1 : BRANCH (next at 9) - -- 4 : EXACT (next at 17) operand=a - -- 9 : BRANCH (next at 17) - -- 12 : EXACT (next at 17) operand=b - -- 17 : EOP (next at 0) - -- - -- (ab)*: 1 : CURLYX (next at 25) { 0, 32767} - -- 8 : OPEN 1 (next at 12) - -- 12 : EXACT (next at 18) operand=ab - -- 18 : CLOSE 1 (next at 22) - -- 22 : WHILEM (next at 0) - -- 25 : NOTHING (next at 28) - -- 28 : EOP (next at 0) - - -- The opcodes are: - - type Opcode is - - -- Name Operand? Meaning - - (EOP, -- no End of program - MINMOD, -- no Next operator is not greedy - - -- Classes of characters - - ANY, -- no Match any one character except newline - SANY, -- no Match any character, including new line - ANYOF, -- class Match any character in this class - EXACT, -- str Match this string exactly - EXACTF, -- str Match this string (case-folding is one) - NOTHING, -- no Match empty string - SPACE, -- no Match any whitespace character - NSPACE, -- no Match any non-whitespace character - DIGIT, -- no Match any numeric character - NDIGIT, -- no Match any non-numeric character - ALNUM, -- no Match any alphanumeric character - NALNUM, -- no Match any non-alphanumeric character - - -- Branches - - BRANCH, -- node Match this alternative, or the next - - -- Simple loops (when the following node is one character in length) - - STAR, -- node Match this simple thing 0 or more times - PLUS, -- node Match this simple thing 1 or more times - CURLY, -- 2num node Match this simple thing between n and m times. - - -- Complex loops - - CURLYX, -- 2num node Match this complex thing {n,m} times - -- The nums are coded on two characters each - - WHILEM, -- no Do curly processing and see if rest matches - - -- Matches after or before a word - - BOL, -- no Match "" at beginning of line - MBOL, -- no Same, assuming multiline (match after \n) - SBOL, -- no Same, assuming single line (don't match at \n) - EOL, -- no Match "" at end of line - MEOL, -- no Same, assuming multiline (match before \n) - SEOL, -- no Same, assuming single line (don't match at \n) - - BOUND, -- no Match "" at any word boundary - NBOUND, -- no Match "" at any word non-boundary - - -- Parenthesis groups handling - - REFF, -- num Match some already matched string, folded - OPEN, -- num Mark this point in input as start of #n - CLOSE); -- num Analogous to OPEN - - for Opcode'Size use 8; - - -- Opcode notes: - - -- BRANCH - -- The set of branches constituting a single choice are hooked - -- together with their "next" pointers, since precedence prevents - -- anything being concatenated to any individual branch. The - -- "next" pointer of the last BRANCH in a choice points to the - -- thing following the whole choice. This is also where the - -- final "next" pointer of each individual branch points; each - -- branch starts with the operand node of a BRANCH node. - - -- STAR,PLUS - -- '?', and complex '*' and '+', are implemented with CURLYX. - -- branches. Simple cases (one character per match) are implemented with - -- STAR and PLUS for speed and to minimize recursive plunges. - - -- OPEN,CLOSE - -- ...are numbered at compile time. - - -- EXACT, EXACTF - -- There are in fact two arguments, the first one is the length (minus - -- one of the string argument), coded on one character, the second - -- argument is the string itself, coded on length + 1 characters. - - -- A node is one char of opcode followed by two chars of "next" pointer. - -- "Next" pointers are stored as two 8-bit pieces, high order first. The - -- value is a positive offset from the opcode of the node containing it. - -- An operand, if any, simply follows the node. (Note that much of the - -- code generation knows about this implicit relationship.) - - -- Using two bytes for the "next" pointer is vast overkill for most - -- things, but allows patterns to get big without disasters. - - Next_Pointer_Bytes : constant := 3; - -- Points after the "next pointer" data. An instruction is therefore: - -- 1 byte: instruction opcode - -- 2 bytes: pointer to next instruction - -- * bytes: optional data for the instruction - - ----------------------- - -- Character classes -- - ----------------------- - -- This is the implementation for character classes ([...]) in the - -- syntax for regular expressions. Each character (0..256) has an - -- entry into the table. This makes for a very fast matching - -- algorithm. - - type Class_Byte is mod 256; - type Character_Class is array (Class_Byte range 0 .. 31) of Class_Byte; - - type Bit_Conversion_Array is array (Class_Byte range 0 .. 7) of Class_Byte; - Bit_Conversion : constant Bit_Conversion_Array := - (1, 2, 4, 8, 16, 32, 64, 128); - - type Std_Class is (ANYOF_NONE, - ANYOF_ALNUM, -- Alphanumeric class [a-zA-Z0-9] - ANYOF_NALNUM, - ANYOF_SPACE, -- Space class [ \t\n\r\f] - ANYOF_NSPACE, - ANYOF_DIGIT, -- Digit class [0-9] - ANYOF_NDIGIT, - ANYOF_ALNUMC, -- Alphanumeric class [a-zA-Z0-9] - ANYOF_NALNUMC, - ANYOF_ALPHA, -- Alpha class [a-zA-Z] - ANYOF_NALPHA, - ANYOF_ASCII, -- Ascii class (7 bits) 0..127 - ANYOF_NASCII, - ANYOF_CNTRL, -- Control class - ANYOF_NCNTRL, - ANYOF_GRAPH, -- Graphic class - ANYOF_NGRAPH, - ANYOF_LOWER, -- Lower case class [a-z] - ANYOF_NLOWER, - ANYOF_PRINT, -- printable class - ANYOF_NPRINT, - ANYOF_PUNCT, -- - ANYOF_NPUNCT, - ANYOF_UPPER, -- Upper case class [A-Z] - ANYOF_NUPPER, - ANYOF_XDIGIT, -- Hexadecimal digit - ANYOF_NXDIGIT - ); - - procedure Set_In_Class - (Bitmap : in out Character_Class; - C : Character); - -- Set the entry to True for C in the class Bitmap - - function Get_From_Class - (Bitmap : Character_Class; - C : Character) return Boolean; - -- Return True if the entry is set for C in the class Bitmap - - procedure Reset_Class (Bitmap : out Character_Class); - -- Clear all the entries in the class Bitmap - - pragma Inline (Set_In_Class); - pragma Inline (Get_From_Class); - pragma Inline (Reset_Class); - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function "=" (Left : Character; Right : Opcode) return Boolean; - - function Is_Alnum (C : Character) return Boolean; - -- Return True if C is an alphanum character or an underscore ('_') - - function Is_White_Space (C : Character) return Boolean; - -- Return True if C is a whitespace character - - function Is_Printable (C : Character) return Boolean; - -- Return True if C is a printable character - - function Operand (P : Pointer) return Pointer; - -- Return a pointer to the first operand of the node at P - - function String_Length - (Program : Program_Data; - P : Pointer) return Program_Size; - -- Return the length of the string argument of the node at P - - function String_Operand (P : Pointer) return Pointer; - -- Return a pointer to the string argument of the node at P - - procedure Bitmap_Operand - (Program : Program_Data; - P : Pointer; - Op : out Character_Class); - -- Return a pointer to the string argument of the node at P - - function Get_Next - (Program : Program_Data; - IP : Pointer) return Pointer; - -- Dig the next instruction pointer out of a node - - procedure Optimize (Self : in out Pattern_Matcher); - -- Optimize a Pattern_Matcher by noting certain special cases - - function Read_Natural - (Program : Program_Data; - IP : Pointer) return Natural; - -- Return the 2-byte natural coded at position IP - - -- All of the subprograms above are tiny and should be inlined - - pragma Inline ("="); - pragma Inline (Is_Alnum); - pragma Inline (Is_White_Space); - pragma Inline (Get_Next); - pragma Inline (Operand); - pragma Inline (Read_Natural); - pragma Inline (String_Length); - pragma Inline (String_Operand); - - type Expression_Flags is record - Has_Width, -- Known never to match null string - Simple, -- Simple enough to be STAR/PLUS operand - SP_Start : Boolean; -- Starts with * or + - end record; - - Worst_Expression : constant Expression_Flags := (others => False); - -- Worst case - - procedure Dump_Until - (Program : Program_Data; - Index : in out Pointer; - Till : Pointer; - Indent : Natural; - Do_Print : Boolean := True); - -- Dump the program until the node Till (not included) is met. Every line - -- is indented with Index spaces at the beginning Dumps till the end if - -- Till is 0. - - procedure Dump_Operation - (Program : Program_Data; - Index : Pointer; - Indent : Natural); - -- Same as above, but only dumps a single operation, and compute its - -- indentation from the program. - - --------- - -- "=" -- - --------- - - function "=" (Left : Character; Right : Opcode) return Boolean is - begin - return Character'Pos (Left) = Opcode'Pos (Right); - end "="; - - -------------------- - -- Bitmap_Operand -- - -------------------- - - procedure Bitmap_Operand - (Program : Program_Data; - P : Pointer; - Op : out Character_Class) - is - function Convert is new Ada.Unchecked_Conversion - (Program_Data, Character_Class); - - begin - Op (0 .. 31) := Convert (Program (P + Next_Pointer_Bytes .. P + 34)); - end Bitmap_Operand; - - ------------- - -- Compile -- - ------------- - - procedure Compile - (Matcher : out Pattern_Matcher; - Expression : String; - Final_Code_Size : out Program_Size; - Flags : Regexp_Flags := No_Flags) - is - -- We can't allocate space until we know how big the compiled form - -- will be, but we can't compile it (and thus know how big it is) - -- until we've got a place to put the code. So we cheat: we compile - -- it twice, once with code generation turned off and size counting - -- turned on, and once "for real". - - -- This also means that we don't allocate space until we are sure - -- that the thing really will compile successfully, and we never - -- have to move the code and thus invalidate pointers into it. - - -- Beware that the optimization-preparation code in here knows - -- about some of the structure of the compiled regexp. - - PM : Pattern_Matcher renames Matcher; - Program : Program_Data renames PM.Program; - - Emit_Ptr : Pointer := Program_First; - - Parse_Pos : Natural := Expression'First; -- Input-scan pointer - Parse_End : constant Natural := Expression'Last; - - ---------------------------- - -- Subprograms for Create -- - ---------------------------- - - procedure Emit (B : Character); - -- Output the Character B to the Program. If code-generation is - -- disabled, simply increments the program counter. - - function Emit_Node (Op : Opcode) return Pointer; - -- If code-generation is enabled, Emit_Node outputs the - -- opcode Op and reserves space for a pointer to the next node. - -- Return value is the location of new opcode, i.e. old Emit_Ptr. - - procedure Emit_Natural (IP : Pointer; N : Natural); - -- Split N on two characters at position IP - - procedure Emit_Class (Bitmap : Character_Class); - -- Emits a character class - - procedure Case_Emit (C : Character); - -- Emit C, after converting is to lower-case if the regular - -- expression is case insensitive. - - procedure Parse - (Parenthesized : Boolean; - Capturing : Boolean; - Flags : out Expression_Flags; - IP : out Pointer); - -- Parse regular expression, i.e. main body or parenthesized thing. - -- Caller must absorb opening parenthesis. Capturing should be set to - -- True when we have an open parenthesis from which we want the user - -- to extra text. - - procedure Parse_Branch - (Flags : out Expression_Flags; - First : Boolean; - IP : out Pointer); - -- Implements the concatenation operator and handles '|'. - -- First should be true if this is the first item of the alternative. - - procedure Parse_Piece - (Expr_Flags : out Expression_Flags; - IP : out Pointer); - -- Parse something followed by possible [*+?] - - procedure Parse_Atom - (Expr_Flags : out Expression_Flags; - IP : out Pointer); - -- Parse_Atom is the lowest level parse procedure. - -- - -- Optimization: Gobbles an entire sequence of ordinary characters so - -- that it can turn them into a single node, which is smaller to store - -- and faster to run. Backslashed characters are exceptions, each - -- becoming a separate node; the code is simpler that way and it's - -- not worth fixing. - - procedure Insert_Operator - (Op : Opcode; - Operand : Pointer; - Greedy : Boolean := True); - -- Insert_Operator inserts an operator in front of an already-emitted - -- operand and relocates the operand. This applies to PLUS and STAR. - -- If Minmod is True, then the operator is non-greedy. - - function Insert_Operator_Before - (Op : Opcode; - Operand : Pointer; - Greedy : Boolean; - Opsize : Pointer) return Pointer; - -- Insert an operator before Operand (and move the latter forward in the - -- program). Opsize is the size needed to represent the operator. This - -- returns the position at which the operator was inserted, and moves - -- Emit_Ptr after the new position of the operand. - - procedure Insert_Curly_Operator - (Op : Opcode; - Min : Natural; - Max : Natural; - Operand : Pointer; - Greedy : Boolean := True); - -- Insert an operator for CURLY ({Min}, {Min,} or {Min,Max}). - -- If Minmod is True, then the operator is non-greedy. - - procedure Link_Tail (P, Val : Pointer); - -- Link_Tail sets the next-pointer at the end of a node chain - - procedure Link_Operand_Tail (P, Val : Pointer); - -- Link_Tail on operand of first argument; noop if operand-less - - procedure Fail (M : String); - pragma No_Return (Fail); - -- Fail with a diagnostic message, if possible - - function Is_Curly_Operator (IP : Natural) return Boolean; - -- Return True if IP is looking at a '{' that is the beginning - -- of a curly operator, i.e. it matches {\d+,?\d*} - - function Is_Mult (IP : Natural) return Boolean; - -- Return True if C is a regexp multiplier: '+', '*' or '?' - - procedure Get_Curly_Arguments - (IP : Natural; - Min : out Natural; - Max : out Natural; - Greedy : out Boolean); - -- Parse the argument list for a curly operator. - -- It is assumed that IP is indeed pointing at a valid operator. - -- So what is IP and how come IP is not referenced in the body ??? - - procedure Parse_Character_Class (IP : out Pointer); - -- Parse a character class. - -- The calling subprogram should consume the opening '[' before. - - procedure Parse_Literal - (Expr_Flags : out Expression_Flags; - IP : out Pointer); - -- Parse_Literal encodes a string of characters to be matched exactly - - function Parse_Posix_Character_Class return Std_Class; - -- Parse a posix character class, like [:alpha:] or [:^alpha:]. - -- The caller is supposed to absorb the opening [. - - pragma Inline (Is_Mult); - pragma Inline (Emit_Natural); - pragma Inline (Parse_Character_Class); -- since used only once - - --------------- - -- Case_Emit -- - --------------- - - procedure Case_Emit (C : Character) is - begin - if (Flags and Case_Insensitive) /= 0 then - Emit (To_Lower (C)); - - else - -- Dump current character - - Emit (C); - end if; - end Case_Emit; - - ---------- - -- Emit -- - ---------- - - procedure Emit (B : Character) is - begin - if Emit_Ptr <= PM.Size then - Program (Emit_Ptr) := B; - end if; - - Emit_Ptr := Emit_Ptr + 1; - end Emit; - - ---------------- - -- Emit_Class -- - ---------------- - - procedure Emit_Class (Bitmap : Character_Class) is - subtype Program31 is Program_Data (0 .. 31); - - function Convert is new Ada.Unchecked_Conversion - (Character_Class, Program31); - - begin - -- What is the mysterious constant 31 here??? Can't it be expressed - -- symbolically (size of integer - 1 or some such???). In any case - -- it should be declared as a constant (and referenced presumably - -- as this constant + 1 below. - - if Emit_Ptr + 31 <= PM.Size then - Program (Emit_Ptr .. Emit_Ptr + 31) := Convert (Bitmap); - end if; - - Emit_Ptr := Emit_Ptr + 32; - end Emit_Class; - - ------------------ - -- Emit_Natural -- - ------------------ - - procedure Emit_Natural (IP : Pointer; N : Natural) is - begin - if IP + 1 <= PM.Size then - Program (IP + 1) := Character'Val (N / 256); - Program (IP) := Character'Val (N mod 256); - end if; - end Emit_Natural; - - --------------- - -- Emit_Node -- - --------------- - - function Emit_Node (Op : Opcode) return Pointer is - Result : constant Pointer := Emit_Ptr; - - begin - if Emit_Ptr + 2 <= PM.Size then - Program (Emit_Ptr) := Character'Val (Opcode'Pos (Op)); - Program (Emit_Ptr + 1) := ASCII.NUL; - Program (Emit_Ptr + 2) := ASCII.NUL; - end if; - - Emit_Ptr := Emit_Ptr + Next_Pointer_Bytes; - return Result; - end Emit_Node; - - ---------- - -- Fail -- - ---------- - - procedure Fail (M : String) is - begin - raise Expression_Error with M; - end Fail; - - ------------------------- - -- Get_Curly_Arguments -- - ------------------------- - - procedure Get_Curly_Arguments - (IP : Natural; - Min : out Natural; - Max : out Natural; - Greedy : out Boolean) - is - pragma Unreferenced (IP); - - Save_Pos : Natural := Parse_Pos + 1; - - begin - Min := 0; - Max := Max_Curly_Repeat; - - while Expression (Parse_Pos) /= '}' - and then Expression (Parse_Pos) /= ',' - loop - Parse_Pos := Parse_Pos + 1; - end loop; - - Min := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); - - if Expression (Parse_Pos) = ',' then - Save_Pos := Parse_Pos + 1; - while Expression (Parse_Pos) /= '}' loop - Parse_Pos := Parse_Pos + 1; - end loop; - - if Save_Pos /= Parse_Pos then - Max := Natural'Value (Expression (Save_Pos .. Parse_Pos - 1)); - end if; - - else - Max := Min; - end if; - - if Parse_Pos < Expression'Last - and then Expression (Parse_Pos + 1) = '?' - then - Greedy := False; - Parse_Pos := Parse_Pos + 1; - - else - Greedy := True; - end if; - end Get_Curly_Arguments; - - --------------------------- - -- Insert_Curly_Operator -- - --------------------------- - - procedure Insert_Curly_Operator - (Op : Opcode; - Min : Natural; - Max : Natural; - Operand : Pointer; - Greedy : Boolean := True) - is - Old : Pointer; - begin - Old := Insert_Operator_Before (Op, Operand, Greedy, Opsize => 7); - Emit_Natural (Old + Next_Pointer_Bytes, Min); - Emit_Natural (Old + Next_Pointer_Bytes + 2, Max); - end Insert_Curly_Operator; - - ---------------------------- - -- Insert_Operator_Before -- - ---------------------------- - - function Insert_Operator_Before - (Op : Opcode; - Operand : Pointer; - Greedy : Boolean; - Opsize : Pointer) return Pointer - is - Dest : constant Pointer := Emit_Ptr; - Old : Pointer; - Size : Pointer := Opsize; - - begin - -- If not greedy, we have to emit another opcode first - - if not Greedy then - Size := Size + Next_Pointer_Bytes; - end if; - - -- Move the operand in the byte-compilation, so that we can insert - -- the operator before it. - - if Emit_Ptr + Size <= PM.Size then - Program (Operand + Size .. Emit_Ptr + Size) := - Program (Operand .. Emit_Ptr); - end if; - - -- Insert the operator at the position previously occupied by the - -- operand. - - Emit_Ptr := Operand; - - if not Greedy then - Old := Emit_Node (MINMOD); - Link_Tail (Old, Old + Next_Pointer_Bytes); - end if; - - Old := Emit_Node (Op); - Emit_Ptr := Dest + Size; - return Old; - end Insert_Operator_Before; - - --------------------- - -- Insert_Operator -- - --------------------- - - procedure Insert_Operator - (Op : Opcode; - Operand : Pointer; - Greedy : Boolean := True) - is - Discard : Pointer; - pragma Warnings (Off, Discard); - begin - Discard := Insert_Operator_Before - (Op, Operand, Greedy, Opsize => Next_Pointer_Bytes); - end Insert_Operator; - - ----------------------- - -- Is_Curly_Operator -- - ----------------------- - - function Is_Curly_Operator (IP : Natural) return Boolean is - Scan : Natural := IP; - - begin - if Expression (Scan) /= '{' - or else Scan + 2 > Expression'Last - or else not Is_Digit (Expression (Scan + 1)) - then - return False; - end if; - - Scan := Scan + 1; - - -- The first digit - - loop - Scan := Scan + 1; - - if Scan > Expression'Last then - return False; - end if; - - exit when not Is_Digit (Expression (Scan)); - end loop; - - if Expression (Scan) = ',' then - loop - Scan := Scan + 1; - - if Scan > Expression'Last then - return False; - end if; - - exit when not Is_Digit (Expression (Scan)); - end loop; - end if; - - return Expression (Scan) = '}'; - end Is_Curly_Operator; - - ------------- - -- Is_Mult -- - ------------- - - function Is_Mult (IP : Natural) return Boolean is - C : constant Character := Expression (IP); - - begin - return C = '*' - or else C = '+' - or else C = '?' - or else (C = '{' and then Is_Curly_Operator (IP)); - end Is_Mult; - - ----------------------- - -- Link_Operand_Tail -- - ----------------------- - - procedure Link_Operand_Tail (P, Val : Pointer) is - begin - if P <= PM.Size and then Program (P) = BRANCH then - Link_Tail (Operand (P), Val); - end if; - end Link_Operand_Tail; - - --------------- - -- Link_Tail -- - --------------- - - procedure Link_Tail (P, Val : Pointer) is - Scan : Pointer; - Temp : Pointer; - Offset : Pointer; - - begin - -- Find last node (the size of the pattern matcher might be too - -- small, so don't try to read past its end). - - Scan := P; - while Scan + Next_Pointer_Bytes <= PM.Size loop - Temp := Get_Next (Program, Scan); - exit when Temp = Scan; - Scan := Temp; - end loop; - - Offset := Val - Scan; - - Emit_Natural (Scan + 1, Natural (Offset)); - end Link_Tail; - - ----------- - -- Parse -- - ----------- - - -- Combining parenthesis handling with the base level of regular - -- expression is a trifle forced, but the need to tie the tails of the - -- the branches to what follows makes it hard to avoid. - - procedure Parse - (Parenthesized : Boolean; - Capturing : Boolean; - Flags : out Expression_Flags; - IP : out Pointer) - is - E : String renames Expression; - Br, Br2 : Pointer; - Ender : Pointer; - Par_No : Natural; - New_Flags : Expression_Flags; - Have_Branch : Boolean := False; - - begin - Flags := (Has_Width => True, others => False); -- Tentatively - - -- Make an OPEN node, if parenthesized - - if Parenthesized and then Capturing then - if Matcher.Paren_Count > Max_Paren_Count then - Fail ("too many ()"); - end if; - - Par_No := Matcher.Paren_Count + 1; - Matcher.Paren_Count := Matcher.Paren_Count + 1; - IP := Emit_Node (OPEN); - Emit (Character'Val (Par_No)); - else - IP := 0; - Par_No := 0; - end if; - - -- Pick up the branches, linking them together - - Parse_Branch (New_Flags, True, Br); - - if Br = 0 then - IP := 0; - return; - end if; - - if Parse_Pos <= Parse_End - and then E (Parse_Pos) = '|' - then - Insert_Operator (BRANCH, Br); - Have_Branch := True; - end if; - - if IP /= 0 then - Link_Tail (IP, Br); -- OPEN -> first - else - IP := Br; - end if; - - if not New_Flags.Has_Width then - Flags.Has_Width := False; - end if; - - Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; - - while Parse_Pos <= Parse_End - and then (E (Parse_Pos) = '|') - loop - Parse_Pos := Parse_Pos + 1; - Parse_Branch (New_Flags, False, Br); - - if Br = 0 then - IP := 0; - return; - end if; - - Link_Tail (IP, Br); -- BRANCH -> BRANCH - - if not New_Flags.Has_Width then - Flags.Has_Width := False; - end if; - - Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; - end loop; - - -- Make a closing node, and hook it on the end - - if Parenthesized then - if Capturing then - Ender := Emit_Node (CLOSE); - Emit (Character'Val (Par_No)); - Link_Tail (IP, Ender); - - else - -- Need to keep looking after the closing parenthesis - Ender := Emit_Ptr; - end if; - - else - Ender := Emit_Node (EOP); - Link_Tail (IP, Ender); - end if; - - if Have_Branch and then Emit_Ptr <= PM.Size + 1 then - - -- Hook the tails of the branches to the closing node - - Br := IP; - loop - Link_Operand_Tail (Br, Ender); - Br2 := Get_Next (Program, Br); - exit when Br2 = Br; - Br := Br2; - end loop; - end if; - - -- Check for proper termination - - if Parenthesized then - if Parse_Pos > Parse_End or else E (Parse_Pos) /= ')' then - Fail ("unmatched ()"); - end if; - - Parse_Pos := Parse_Pos + 1; - - elsif Parse_Pos <= Parse_End then - if E (Parse_Pos) = ')' then - Fail ("unmatched ')'"); - else - Fail ("junk on end"); -- "Can't happen" - end if; - end if; - end Parse; - - ---------------- - -- Parse_Atom -- - ---------------- - - procedure Parse_Atom - (Expr_Flags : out Expression_Flags; - IP : out Pointer) - is - C : Character; - - begin - -- Tentatively set worst expression case - - Expr_Flags := Worst_Expression; - - C := Expression (Parse_Pos); - Parse_Pos := Parse_Pos + 1; - - case (C) is - when '^' => - IP := - Emit_Node - (if (Flags and Multiple_Lines) /= 0 then MBOL - elsif (Flags and Single_Line) /= 0 then SBOL - else BOL); - - when '$' => - IP := - Emit_Node - (if (Flags and Multiple_Lines) /= 0 then MEOL - elsif (Flags and Single_Line) /= 0 then SEOL - else EOL); - - when '.' => - IP := - Emit_Node - (if (Flags and Single_Line) /= 0 then SANY else ANY); - - Expr_Flags.Has_Width := True; - Expr_Flags.Simple := True; - - when '[' => - Parse_Character_Class (IP); - Expr_Flags.Has_Width := True; - Expr_Flags.Simple := True; - - when '(' => - declare - New_Flags : Expression_Flags; - - begin - if Parse_Pos <= Parse_End - 1 - and then Expression (Parse_Pos) = '?' - and then Expression (Parse_Pos + 1) = ':' - then - Parse_Pos := Parse_Pos + 2; - - -- Non-capturing parenthesis - - Parse (True, False, New_Flags, IP); - - else - -- Capturing parenthesis - - Parse (True, True, New_Flags, IP); - Expr_Flags.Has_Width := - Expr_Flags.Has_Width or else New_Flags.Has_Width; - Expr_Flags.SP_Start := - Expr_Flags.SP_Start or else New_Flags.SP_Start; - if IP = 0 then - return; - end if; - end if; - end; - - when '|' | ASCII.LF | ')' => - Fail ("internal urp"); -- Supposed to be caught earlier - - when '?' | '+' | '*' => - Fail (C & " follows nothing"); - - when '{' => - if Is_Curly_Operator (Parse_Pos - 1) then - Fail (C & " follows nothing"); - else - Parse_Literal (Expr_Flags, IP); - end if; - - when '\' => - if Parse_Pos > Parse_End then - Fail ("trailing \"); - end if; - - Parse_Pos := Parse_Pos + 1; - - case Expression (Parse_Pos - 1) is - when 'b' => - IP := Emit_Node (BOUND); - - when 'B' => - IP := Emit_Node (NBOUND); - - when 's' => - IP := Emit_Node (SPACE); - Expr_Flags.Simple := True; - Expr_Flags.Has_Width := True; - - when 'S' => - IP := Emit_Node (NSPACE); - Expr_Flags.Simple := True; - Expr_Flags.Has_Width := True; - - when 'd' => - IP := Emit_Node (DIGIT); - Expr_Flags.Simple := True; - Expr_Flags.Has_Width := True; - - when 'D' => - IP := Emit_Node (NDIGIT); - Expr_Flags.Simple := True; - Expr_Flags.Has_Width := True; - - when 'w' => - IP := Emit_Node (ALNUM); - Expr_Flags.Simple := True; - Expr_Flags.Has_Width := True; - - when 'W' => - IP := Emit_Node (NALNUM); - Expr_Flags.Simple := True; - Expr_Flags.Has_Width := True; - - when 'A' => - IP := Emit_Node (SBOL); - - when 'G' => - IP := Emit_Node (SEOL); - - when '0' .. '9' => - IP := Emit_Node (REFF); - - declare - Save : constant Natural := Parse_Pos - 1; - - begin - while Parse_Pos <= Expression'Last - and then Is_Digit (Expression (Parse_Pos)) - loop - Parse_Pos := Parse_Pos + 1; - end loop; - - Emit (Character'Val (Natural'Value - (Expression (Save .. Parse_Pos - 1)))); - end; - - when others => - Parse_Pos := Parse_Pos - 1; - Parse_Literal (Expr_Flags, IP); - end case; - - when others => - Parse_Literal (Expr_Flags, IP); - end case; - end Parse_Atom; - - ------------------ - -- Parse_Branch -- - ------------------ - - procedure Parse_Branch - (Flags : out Expression_Flags; - First : Boolean; - IP : out Pointer) - is - E : String renames Expression; - Chain : Pointer; - Last : Pointer; - New_Flags : Expression_Flags; - - Discard : Pointer; - pragma Warnings (Off, Discard); - - begin - Flags := Worst_Expression; -- Tentatively - IP := (if First then Emit_Ptr else Emit_Node (BRANCH)); - - Chain := 0; - while Parse_Pos <= Parse_End - and then E (Parse_Pos) /= ')' - and then E (Parse_Pos) /= ASCII.LF - and then E (Parse_Pos) /= '|' - loop - Parse_Piece (New_Flags, Last); - - if Last = 0 then - IP := 0; - return; - end if; - - Flags.Has_Width := Flags.Has_Width or else New_Flags.Has_Width; - - if Chain = 0 then -- First piece - Flags.SP_Start := Flags.SP_Start or else New_Flags.SP_Start; - else - Link_Tail (Chain, Last); - end if; - - Chain := Last; - end loop; - - -- Case where loop ran zero CURLY - - if Chain = 0 then - Discard := Emit_Node (NOTHING); - end if; - end Parse_Branch; - - --------------------------- - -- Parse_Character_Class -- - --------------------------- - - procedure Parse_Character_Class (IP : out Pointer) is - Bitmap : Character_Class; - Invert : Boolean := False; - In_Range : Boolean := False; - Named_Class : Std_Class := ANYOF_NONE; - Value : Character; - Last_Value : Character := ASCII.NUL; - - begin - Reset_Class (Bitmap); - - -- Do we have an invert character class ? - - if Parse_Pos <= Parse_End - and then Expression (Parse_Pos) = '^' - then - Invert := True; - Parse_Pos := Parse_Pos + 1; - end if; - - -- First character can be ] or - without closing the class - - if Parse_Pos <= Parse_End - and then (Expression (Parse_Pos) = ']' - or else Expression (Parse_Pos) = '-') - then - Set_In_Class (Bitmap, Expression (Parse_Pos)); - Parse_Pos := Parse_Pos + 1; - end if; - - -- While we don't have the end of the class - - while Parse_Pos <= Parse_End - and then Expression (Parse_Pos) /= ']' - loop - Named_Class := ANYOF_NONE; - Value := Expression (Parse_Pos); - Parse_Pos := Parse_Pos + 1; - - -- Do we have a Posix character class - if Value = '[' then - Named_Class := Parse_Posix_Character_Class; - - elsif Value = '\' then - if Parse_Pos = Parse_End then - Fail ("Trailing \"); - end if; - Value := Expression (Parse_Pos); - Parse_Pos := Parse_Pos + 1; - - case Value is - when 'w' => Named_Class := ANYOF_ALNUM; - when 'W' => Named_Class := ANYOF_NALNUM; - when 's' => Named_Class := ANYOF_SPACE; - when 'S' => Named_Class := ANYOF_NSPACE; - when 'd' => Named_Class := ANYOF_DIGIT; - when 'D' => Named_Class := ANYOF_NDIGIT; - when 'n' => Value := ASCII.LF; - when 'r' => Value := ASCII.CR; - when 't' => Value := ASCII.HT; - when 'f' => Value := ASCII.FF; - when 'e' => Value := ASCII.ESC; - when 'a' => Value := ASCII.BEL; - - -- when 'x' => ??? hexadecimal value - -- when 'c' => ??? control character - -- when '0'..'9' => ??? octal character - - when others => null; - end case; - end if; - - -- Do we have a character class? - - if Named_Class /= ANYOF_NONE then - - -- A range like 'a-\d' or 'a-[:digit:] is not a range - - if In_Range then - Set_In_Class (Bitmap, Last_Value); - Set_In_Class (Bitmap, '-'); - In_Range := False; - end if; - - -- Expand the range - - case Named_Class is - when ANYOF_NONE => null; - - when ANYOF_ALNUM | ANYOF_ALNUMC => - for Value in Class_Byte'Range loop - if Is_Alnum (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NALNUM | ANYOF_NALNUMC => - for Value in Class_Byte'Range loop - if not Is_Alnum (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_SPACE => - for Value in Class_Byte'Range loop - if Is_White_Space (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NSPACE => - for Value in Class_Byte'Range loop - if not Is_White_Space (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_DIGIT => - for Value in Class_Byte'Range loop - if Is_Digit (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NDIGIT => - for Value in Class_Byte'Range loop - if not Is_Digit (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_ALPHA => - for Value in Class_Byte'Range loop - if Is_Letter (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NALPHA => - for Value in Class_Byte'Range loop - if not Is_Letter (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_ASCII => - for Value in 0 .. 127 loop - Set_In_Class (Bitmap, Character'Val (Value)); - end loop; - - when ANYOF_NASCII => - for Value in 128 .. 255 loop - Set_In_Class (Bitmap, Character'Val (Value)); - end loop; - - when ANYOF_CNTRL => - for Value in Class_Byte'Range loop - if Is_Control (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NCNTRL => - for Value in Class_Byte'Range loop - if not Is_Control (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_GRAPH => - for Value in Class_Byte'Range loop - if Is_Graphic (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NGRAPH => - for Value in Class_Byte'Range loop - if not Is_Graphic (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_LOWER => - for Value in Class_Byte'Range loop - if Is_Lower (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NLOWER => - for Value in Class_Byte'Range loop - if not Is_Lower (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_PRINT => - for Value in Class_Byte'Range loop - if Is_Printable (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NPRINT => - for Value in Class_Byte'Range loop - if not Is_Printable (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_PUNCT => - for Value in Class_Byte'Range loop - if Is_Printable (Character'Val (Value)) - and then not Is_White_Space (Character'Val (Value)) - and then not Is_Alnum (Character'Val (Value)) - then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NPUNCT => - for Value in Class_Byte'Range loop - if not Is_Printable (Character'Val (Value)) - or else Is_White_Space (Character'Val (Value)) - or else Is_Alnum (Character'Val (Value)) - then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_UPPER => - for Value in Class_Byte'Range loop - if Is_Upper (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NUPPER => - for Value in Class_Byte'Range loop - if not Is_Upper (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_XDIGIT => - for Value in Class_Byte'Range loop - if Is_Hexadecimal_Digit (Character'Val (Value)) then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - when ANYOF_NXDIGIT => - for Value in Class_Byte'Range loop - if not Is_Hexadecimal_Digit - (Character'Val (Value)) - then - Set_In_Class (Bitmap, Character'Val (Value)); - end if; - end loop; - - end case; - - -- Not a character range - - elsif not In_Range then - Last_Value := Value; - - if Parse_Pos > Expression'Last then - Fail ("Empty character class []"); - end if; - - if Expression (Parse_Pos) = '-' - and then Parse_Pos < Parse_End - and then Expression (Parse_Pos + 1) /= ']' - then - Parse_Pos := Parse_Pos + 1; - - -- Do we have a range like '\d-a' and '[:space:]-a' - -- which is not a real range - - if Named_Class /= ANYOF_NONE then - Set_In_Class (Bitmap, '-'); - else - In_Range := True; - end if; - - else - Set_In_Class (Bitmap, Value); - - end if; - - -- Else in a character range - - else - if Last_Value > Value then - Fail ("Invalid Range [" & Last_Value'Img - & "-" & Value'Img & "]"); - end if; - - while Last_Value <= Value loop - Set_In_Class (Bitmap, Last_Value); - Last_Value := Character'Succ (Last_Value); - end loop; - - In_Range := False; - - end if; - - end loop; - - -- Optimize case-insensitive ranges (put the upper case or lower - -- case character into the bitmap) - - if (Flags and Case_Insensitive) /= 0 then - for C in Character'Range loop - if Get_From_Class (Bitmap, C) then - Set_In_Class (Bitmap, To_Lower (C)); - Set_In_Class (Bitmap, To_Upper (C)); - end if; - end loop; - end if; - - -- Optimize inverted classes - - if Invert then - for J in Bitmap'Range loop - Bitmap (J) := not Bitmap (J); - end loop; - end if; - - Parse_Pos := Parse_Pos + 1; - - -- Emit the class - - IP := Emit_Node (ANYOF); - Emit_Class (Bitmap); - end Parse_Character_Class; - - ------------------- - -- Parse_Literal -- - ------------------- - - -- This is a bit tricky due to quoted chars and due to - -- the multiplier characters '*', '+', and '?' that - -- take the SINGLE char previous as their operand. - - -- On entry, the character at Parse_Pos - 1 is going to go - -- into the string, no matter what it is. It could be - -- following a \ if Parse_Atom was entered from the '\' case. - - -- Basic idea is to pick up a good char in C and examine - -- the next char. If Is_Mult (C) then twiddle, if it's a \ - -- then frozzle and if it's another magic char then push C and - -- terminate the string. If none of the above, push C on the - -- string and go around again. - - -- Start_Pos is used to remember where "the current character" - -- starts in the string, if due to an Is_Mult we need to back - -- up and put the current char in a separate 1-character string. - -- When Start_Pos is 0, C is the only char in the string; - -- this is used in Is_Mult handling, and in setting the SIMPLE - -- flag at the end. - - procedure Parse_Literal - (Expr_Flags : out Expression_Flags; - IP : out Pointer) - is - Start_Pos : Natural := 0; - C : Character; - Length_Ptr : Pointer; - - Has_Special_Operator : Boolean := False; - - begin - Parse_Pos := Parse_Pos - 1; -- Look at current character - - IP := - Emit_Node - (if (Flags and Case_Insensitive) /= 0 then EXACTF else EXACT); - - Length_Ptr := Emit_Ptr; - Emit_Ptr := String_Operand (IP); - - Parse_Loop : - loop - C := Expression (Parse_Pos); -- Get current character - - case C is - when '.' | '[' | '(' | ')' | '|' | ASCII.LF | '$' | '^' => - - if Start_Pos = 0 then - Start_Pos := Parse_Pos; - Emit (C); -- First character is always emitted - else - exit Parse_Loop; -- Else we are done - end if; - - when '?' | '+' | '*' | '{' => - - if Start_Pos = 0 then - Start_Pos := Parse_Pos; - Emit (C); -- First character is always emitted - - -- Are we looking at an operator, or is this - -- simply a normal character ? - - elsif not Is_Mult (Parse_Pos) then - Start_Pos := Parse_Pos; - Case_Emit (C); - - else - -- We've got something like "abc?d". Mark this as a - -- special case. What we want to emit is a first - -- constant string for "ab", then one for "c" that will - -- ultimately be transformed with a CURLY operator, A - -- special case has to be handled for "a?", since there - -- is no initial string to emit. - - Has_Special_Operator := True; - exit Parse_Loop; - end if; - - when '\' => - Start_Pos := Parse_Pos; - - if Parse_Pos = Parse_End then - Fail ("Trailing \"); - - else - case Expression (Parse_Pos + 1) is - when 'b' | 'B' | 's' | 'S' | 'd' | 'D' - | 'w' | 'W' | '0' .. '9' | 'G' | 'A' - => exit Parse_Loop; - when 'n' => Emit (ASCII.LF); - when 't' => Emit (ASCII.HT); - when 'r' => Emit (ASCII.CR); - when 'f' => Emit (ASCII.FF); - when 'e' => Emit (ASCII.ESC); - when 'a' => Emit (ASCII.BEL); - when others => Emit (Expression (Parse_Pos + 1)); - end case; - - Parse_Pos := Parse_Pos + 1; - end if; - - when others => - Start_Pos := Parse_Pos; - Case_Emit (C); - end case; - - Parse_Pos := Parse_Pos + 1; - exit Parse_Loop when Parse_Pos > Parse_End - or else Emit_Ptr - Length_Ptr = 254; - end loop Parse_Loop; - - -- Is the string followed by a '*+?{' operator ? If yes, and if there - -- is an initial string to emit, do it now. - - if Has_Special_Operator - and then Emit_Ptr >= Length_Ptr + Next_Pointer_Bytes - then - Emit_Ptr := Emit_Ptr - 1; - Parse_Pos := Start_Pos; - end if; - - if Length_Ptr <= PM.Size then - Program (Length_Ptr) := Character'Val (Emit_Ptr - Length_Ptr - 2); - end if; - - Expr_Flags.Has_Width := True; - - -- Slight optimization when there is a single character - - if Emit_Ptr = Length_Ptr + 2 then - Expr_Flags.Simple := True; - end if; - end Parse_Literal; - - ----------------- - -- Parse_Piece -- - ----------------- - - -- Note that the branching code sequences used for '?' and the - -- general cases of '*' and + are somewhat optimized: they use - -- the same NOTHING node as both the endmarker for their branch - -- list and the body of the last branch. It might seem that - -- this node could be dispensed with entirely, but the endmarker - -- role is not redundant. - - procedure Parse_Piece - (Expr_Flags : out Expression_Flags; - IP : out Pointer) - is - Op : Character; - New_Flags : Expression_Flags; - Greedy : Boolean := True; - - begin - Parse_Atom (New_Flags, IP); - - if IP = 0 then - return; - end if; - - if Parse_Pos > Parse_End - or else not Is_Mult (Parse_Pos) - then - Expr_Flags := New_Flags; - return; - end if; - - Op := Expression (Parse_Pos); - - Expr_Flags := - (if Op /= '+' - then (SP_Start => True, others => False) - else (Has_Width => True, others => False)); - - -- Detect non greedy operators in the easy cases - - if Op /= '{' - and then Parse_Pos + 1 <= Parse_End - and then Expression (Parse_Pos + 1) = '?' - then - Greedy := False; - Parse_Pos := Parse_Pos + 1; - end if; - - -- Generate the byte code - - case Op is - when '*' => - - if New_Flags.Simple then - Insert_Operator (STAR, IP, Greedy); - else - Link_Tail (IP, Emit_Node (WHILEM)); - Insert_Curly_Operator - (CURLYX, 0, Max_Curly_Repeat, IP, Greedy); - Link_Tail (IP, Emit_Node (NOTHING)); - end if; - - when '+' => - - if New_Flags.Simple then - Insert_Operator (PLUS, IP, Greedy); - else - Link_Tail (IP, Emit_Node (WHILEM)); - Insert_Curly_Operator - (CURLYX, 1, Max_Curly_Repeat, IP, Greedy); - Link_Tail (IP, Emit_Node (NOTHING)); - end if; - - when '?' => - if New_Flags.Simple then - Insert_Curly_Operator (CURLY, 0, 1, IP, Greedy); - else - Link_Tail (IP, Emit_Node (WHILEM)); - Insert_Curly_Operator (CURLYX, 0, 1, IP, Greedy); - Link_Tail (IP, Emit_Node (NOTHING)); - end if; - - when '{' => - declare - Min, Max : Natural; - - begin - Get_Curly_Arguments (Parse_Pos, Min, Max, Greedy); - - if New_Flags.Simple then - Insert_Curly_Operator (CURLY, Min, Max, IP, Greedy); - else - Link_Tail (IP, Emit_Node (WHILEM)); - Insert_Curly_Operator (CURLYX, Min, Max, IP, Greedy); - Link_Tail (IP, Emit_Node (NOTHING)); - end if; - end; - - when others => - null; - end case; - - Parse_Pos := Parse_Pos + 1; - - if Parse_Pos <= Parse_End - and then Is_Mult (Parse_Pos) - then - Fail ("nested *+{"); - end if; - end Parse_Piece; - - --------------------------------- - -- Parse_Posix_Character_Class -- - --------------------------------- - - function Parse_Posix_Character_Class return Std_Class is - Invert : Boolean := False; - Class : Std_Class := ANYOF_NONE; - E : String renames Expression; - - -- Class names. Note that code assumes that the length of all - -- classes starting with the same letter have the same length. - - Alnum : constant String := "alnum:]"; - Alpha : constant String := "alpha:]"; - Ascii_C : constant String := "ascii:]"; - Cntrl : constant String := "cntrl:]"; - Digit : constant String := "digit:]"; - Graph : constant String := "graph:]"; - Lower : constant String := "lower:]"; - Print : constant String := "print:]"; - Punct : constant String := "punct:]"; - Space : constant String := "space:]"; - Upper : constant String := "upper:]"; - Word : constant String := "word:]"; - Xdigit : constant String := "xdigit:]"; - - begin - -- Case of character class specified - - if Parse_Pos <= Parse_End - and then Expression (Parse_Pos) = ':' - then - Parse_Pos := Parse_Pos + 1; - - -- Do we have something like: [[:^alpha:]] - - if Parse_Pos <= Parse_End - and then Expression (Parse_Pos) = '^' - then - Invert := True; - Parse_Pos := Parse_Pos + 1; - end if; - - -- Check for class names based on first letter - - case Expression (Parse_Pos) is - when 'a' => - - -- All 'a' classes have the same length (Alnum'Length) - - if Parse_Pos + Alnum'Length - 1 <= Parse_End then - if - E (Parse_Pos .. Parse_Pos + Alnum'Length - 1) = Alnum - then - Class := - (if Invert then ANYOF_NALNUMC else ANYOF_ALNUMC); - Parse_Pos := Parse_Pos + Alnum'Length; - - elsif - E (Parse_Pos .. Parse_Pos + Alpha'Length - 1) = Alpha - then - Class := - (if Invert then ANYOF_NALPHA else ANYOF_ALPHA); - Parse_Pos := Parse_Pos + Alpha'Length; - - elsif E (Parse_Pos .. Parse_Pos + Ascii_C'Length - 1) = - Ascii_C - then - Class := - (if Invert then ANYOF_NASCII else ANYOF_ASCII); - Parse_Pos := Parse_Pos + Ascii_C'Length; - else - Fail ("Invalid character class: " & E); - end if; - - else - Fail ("Invalid character class: " & E); - end if; - - when 'c' => - if Parse_Pos + Cntrl'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Cntrl'Length - 1) = Cntrl - then - Class := (if Invert then ANYOF_NCNTRL else ANYOF_CNTRL); - Parse_Pos := Parse_Pos + Cntrl'Length; - else - Fail ("Invalid character class: " & E); - end if; - - when 'd' => - if Parse_Pos + Digit'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Digit'Length - 1) = Digit - then - Class := (if Invert then ANYOF_NDIGIT else ANYOF_DIGIT); - Parse_Pos := Parse_Pos + Digit'Length; - end if; - - when 'g' => - if Parse_Pos + Graph'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Graph'Length - 1) = Graph - then - Class := (if Invert then ANYOF_NGRAPH else ANYOF_GRAPH); - Parse_Pos := Parse_Pos + Graph'Length; - else - Fail ("Invalid character class: " & E); - end if; - - when 'l' => - if Parse_Pos + Lower'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Lower'Length - 1) = Lower - then - Class := (if Invert then ANYOF_NLOWER else ANYOF_LOWER); - Parse_Pos := Parse_Pos + Lower'Length; - else - Fail ("Invalid character class: " & E); - end if; - - when 'p' => - - -- All 'p' classes have the same length - - if Parse_Pos + Print'Length - 1 <= Parse_End then - if - E (Parse_Pos .. Parse_Pos + Print'Length - 1) = Print - then - Class := - (if Invert then ANYOF_NPRINT else ANYOF_PRINT); - Parse_Pos := Parse_Pos + Print'Length; - - elsif - E (Parse_Pos .. Parse_Pos + Punct'Length - 1) = Punct - then - Class := - (if Invert then ANYOF_NPUNCT else ANYOF_PUNCT); - Parse_Pos := Parse_Pos + Punct'Length; - - else - Fail ("Invalid character class: " & E); - end if; - - else - Fail ("Invalid character class: " & E); - end if; - - when 's' => - if Parse_Pos + Space'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Space'Length - 1) = Space - then - Class := (if Invert then ANYOF_NSPACE else ANYOF_SPACE); - Parse_Pos := Parse_Pos + Space'Length; - else - Fail ("Invalid character class: " & E); - end if; - - when 'u' => - if Parse_Pos + Upper'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Upper'Length - 1) = Upper - then - Class := (if Invert then ANYOF_NUPPER else ANYOF_UPPER); - Parse_Pos := Parse_Pos + Upper'Length; - else - Fail ("Invalid character class: " & E); - end if; - - when 'w' => - if Parse_Pos + Word'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Word'Length - 1) = Word - then - Class := (if Invert then ANYOF_NALNUM else ANYOF_ALNUM); - Parse_Pos := Parse_Pos + Word'Length; - else - Fail ("Invalid character class: " & E); - end if; - - when 'x' => - if Parse_Pos + Xdigit'Length - 1 <= Parse_End - and then - E (Parse_Pos .. Parse_Pos + Xdigit'Length - 1) = Xdigit - then - Class := (if Invert then ANYOF_NXDIGIT else ANYOF_XDIGIT); - Parse_Pos := Parse_Pos + Xdigit'Length; - - else - Fail ("Invalid character class: " & E); - end if; - - when others => - Fail ("Invalid character class: " & E); - end case; - - -- Character class not specified - - else - return ANYOF_NONE; - end if; - - return Class; - end Parse_Posix_Character_Class; - - -- Local Declarations - - Result : Pointer; - - Expr_Flags : Expression_Flags; - pragma Unreferenced (Expr_Flags); - - -- Start of processing for Compile - - begin - Parse (False, False, Expr_Flags, Result); - - if Result = 0 then - Fail ("Couldn't compile expression"); - end if; - - Final_Code_Size := Emit_Ptr - 1; - - -- Do we want to actually compile the expression, or simply get the - -- code size ??? - - if Emit_Ptr <= PM.Size then - Optimize (PM); - end if; - - PM.Flags := Flags; - end Compile; - - function Compile - (Expression : String; - Flags : Regexp_Flags := No_Flags) return Pattern_Matcher - is - -- Assume the compiled regexp will fit in 1000 chars. If it does not we - -- will have to compile a second time once the correct size is known. If - -- it fits, we save a significant amount of time by avoiding the second - -- compilation. - - Dummy : Pattern_Matcher (1000); - Size : Program_Size; - - begin - Compile (Dummy, Expression, Size, Flags); - - if Size <= Dummy.Size then - return Pattern_Matcher' - (Size => Size, - First => Dummy.First, - Anchored => Dummy.Anchored, - Must_Have => Dummy.Must_Have, - Must_Have_Length => Dummy.Must_Have_Length, - Paren_Count => Dummy.Paren_Count, - Flags => Dummy.Flags, - Program => - Dummy.Program - (Dummy.Program'First .. Dummy.Program'First + Size - 1)); - else - -- We have to recompile now that we know the size - -- ??? Can we use Ada 2005's return construct ? - - declare - Result : Pattern_Matcher (Size); - begin - Compile (Result, Expression, Size, Flags); - return Result; - end; - end if; - end Compile; - - procedure Compile - (Matcher : out Pattern_Matcher; - Expression : String; - Flags : Regexp_Flags := No_Flags) - is - Size : Program_Size; - - begin - Compile (Matcher, Expression, Size, Flags); - - if Size > Matcher.Size then - raise Expression_Error with "Pattern_Matcher is too small"; - end if; - end Compile; - - -------------------- - -- Dump_Operation -- - -------------------- - - procedure Dump_Operation - (Program : Program_Data; - Index : Pointer; - Indent : Natural) - is - Current : Pointer := Index; - begin - Dump_Until (Program, Current, Current + 1, Indent); - end Dump_Operation; - - ---------------- - -- Dump_Until -- - ---------------- - - procedure Dump_Until - (Program : Program_Data; - Index : in out Pointer; - Till : Pointer; - Indent : Natural; - Do_Print : Boolean := True) - is - function Image (S : String) return String; - -- Remove leading space - - ----------- - -- Image -- - ----------- - - function Image (S : String) return String is - begin - if S (S'First) = ' ' then - return S (S'First + 1 .. S'Last); - else - return S; - end if; - end Image; - - -- Local variables - - Op : Opcode; - Next : Pointer; - Length : Pointer; - Local_Indent : Natural := Indent; - - -- Start of processing for Dump_Until - - begin - while Index < Till loop - Op := Opcode'Val (Character'Pos ((Program (Index)))); - Next := Get_Next (Program, Index); - - if Do_Print then - declare - Point : constant String := Pointer'Image (Index); - begin - Put ((1 .. 4 - Point'Length => ' ') - & Point & ":" - & (1 .. Local_Indent * 2 => ' ') & Opcode'Image (Op)); - end; - - -- Print the parenthesis number - - if Op = OPEN or else Op = CLOSE or else Op = REFF then - Put (Image (Natural'Image - (Character'Pos - (Program (Index + Next_Pointer_Bytes))))); - end if; - - if Next = Index then - Put (" (-)"); - else - Put (" (" & Image (Pointer'Image (Next)) & ")"); - end if; - end if; - - case Op is - when ANYOF => - declare - Bitmap : Character_Class; - Last : Character := ASCII.NUL; - Current : Natural := 0; - Current_Char : Character; - - begin - Bitmap_Operand (Program, Index, Bitmap); - - if Do_Print then - Put ("["); - - while Current <= 255 loop - Current_Char := Character'Val (Current); - - -- First item in a range - - if Get_From_Class (Bitmap, Current_Char) then - Last := Current_Char; - - -- Search for the last item in the range - - loop - Current := Current + 1; - exit when Current > 255; - Current_Char := Character'Val (Current); - exit when - not Get_From_Class (Bitmap, Current_Char); - end loop; - - if not Is_Graphic (Last) then - Put (Last'Img); - else - Put (Last); - end if; - - if Character'Succ (Last) /= Current_Char then - Put ("\-" & Character'Pred (Current_Char)); - end if; - - else - Current := Current + 1; - end if; - end loop; - - Put_Line ("]"); - end if; - - Index := Index + Next_Pointer_Bytes + Bitmap'Length; - end; - - when EXACT | EXACTF => - Length := String_Length (Program, Index); - if Do_Print then - Put (" (" & Image (Program_Size'Image (Length + 1)) - & " chars) <" - & String (Program (String_Operand (Index) - .. String_Operand (Index) - + Length))); - Put_Line (">"); - end if; - - Index := String_Operand (Index) + Length + 1; - - -- Node operand - - when BRANCH | STAR | PLUS => - if Do_Print then - New_Line; - end if; - - Index := Index + Next_Pointer_Bytes; - Dump_Until (Program, Index, Pointer'Min (Next, Till), - Local_Indent + 1, Do_Print); - - when CURLY | CURLYX => - if Do_Print then - Put_Line - (" {" - & Image (Natural'Image - (Read_Natural (Program, Index + Next_Pointer_Bytes))) - & "," - & Image (Natural'Image (Read_Natural (Program, Index + 5))) - & "}"); - end if; - - Index := Index + 7; - Dump_Until (Program, Index, Pointer'Min (Next, Till), - Local_Indent + 1, Do_Print); - - when OPEN => - if Do_Print then - New_Line; - end if; - - Index := Index + 4; - Local_Indent := Local_Indent + 1; - - when CLOSE | REFF => - if Do_Print then - New_Line; - end if; - - Index := Index + 4; - - if Op = CLOSE then - Local_Indent := Local_Indent - 1; - end if; - - when others => - Index := Index + Next_Pointer_Bytes; - - if Do_Print then - New_Line; - end if; - - exit when Op = EOP; - end case; - end loop; - end Dump_Until; - - ---------- - -- Dump -- - ---------- - - procedure Dump (Self : Pattern_Matcher) is - Program : Program_Data renames Self.Program; - Index : Pointer := Program'First; - - -- Start of processing for Dump - - begin - Put_Line ("Must start with (Self.First) = " - & Character'Image (Self.First)); - - if (Self.Flags and Case_Insensitive) /= 0 then - Put_Line (" Case_Insensitive mode"); - end if; - - if (Self.Flags and Single_Line) /= 0 then - Put_Line (" Single_Line mode"); - end if; - - if (Self.Flags and Multiple_Lines) /= 0 then - Put_Line (" Multiple_Lines mode"); - end if; - - Dump_Until (Program, Index, Self.Program'Last + 1, 0); - end Dump; - - -------------------- - -- Get_From_Class -- - -------------------- - - function Get_From_Class - (Bitmap : Character_Class; - C : Character) return Boolean - is - Value : constant Class_Byte := Character'Pos (C); - begin - return - (Bitmap (Value / 8) and Bit_Conversion (Value mod 8)) /= 0; - end Get_From_Class; - - -------------- - -- Get_Next -- - -------------- - - function Get_Next (Program : Program_Data; IP : Pointer) return Pointer is - begin - return IP + Pointer (Read_Natural (Program, IP + 1)); - end Get_Next; - - -------------- - -- Is_Alnum -- - -------------- - - function Is_Alnum (C : Character) return Boolean is - begin - return Is_Alphanumeric (C) or else C = '_'; - end Is_Alnum; - - ------------------ - -- Is_Printable -- - ------------------ - - function Is_Printable (C : Character) return Boolean is - begin - -- Printable if space or graphic character or other whitespace - -- Other white space includes (HT/LF/VT/FF/CR = codes 9-13) - - return C in Character'Val (32) .. Character'Val (126) - or else C in ASCII.HT .. ASCII.CR; - end Is_Printable; - - -------------------- - -- Is_White_Space -- - -------------------- - - function Is_White_Space (C : Character) return Boolean is - begin - -- Note: HT = 9, LF = 10, VT = 11, FF = 12, CR = 13 - - return C = ' ' or else C in ASCII.HT .. ASCII.CR; - end Is_White_Space; - - ----------- - -- Match -- - ----------- - - procedure Match - (Self : Pattern_Matcher; - Data : String; - Matches : out Match_Array; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) - is - Program : Program_Data renames Self.Program; -- Shorter notation - - First_In_Data : constant Integer := Integer'Max (Data_First, Data'First); - Last_In_Data : constant Integer := Integer'Min (Data_Last, Data'Last); - - -- Global work variables - - Input_Pos : Natural; -- String-input pointer - BOL_Pos : Natural; -- Beginning of input, for ^ check - Matched : Boolean := False; -- Until proven True - - Matches_Full : Match_Array (0 .. Natural'Max (Self.Paren_Count, - Matches'Last)); - -- Stores the value of all the parenthesis pairs. - -- We do not use directly Matches, so that we can also use back - -- references (REFF) even if Matches is too small. - - type Natural_Array is array (Match_Count range <>) of Natural; - Matches_Tmp : Natural_Array (Matches_Full'Range); - -- Save the opening position of parenthesis - - Last_Paren : Natural := 0; - -- Last parenthesis seen - - Greedy : Boolean := True; - -- True if the next operator should be greedy - - type Current_Curly_Record; - type Current_Curly_Access is access all Current_Curly_Record; - type Current_Curly_Record is record - Paren_Floor : Natural; -- How far back to strip parenthesis data - Cur : Integer; -- How many instances of scan we've matched - Min : Natural; -- Minimal number of scans to match - Max : Natural; -- Maximal number of scans to match - Greedy : Boolean; -- Whether to work our way up or down - Scan : Pointer; -- The thing to match - Next : Pointer; -- What has to match after it - Lastloc : Natural; -- Where we started matching this scan - Old_Cc : Current_Curly_Access; -- Before we started this one - end record; - -- Data used to handle the curly operator and the plus and star - -- operators for complex expressions. - - Current_Curly : Current_Curly_Access := null; - -- The curly currently being processed - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Index (Start : Positive; C : Character) return Natural; - -- Find character C in Data starting at Start and return position - - function Repeat - (IP : Pointer; - Max : Natural := Natural'Last) return Natural; - -- Repeatedly match something simple, report how many - -- It only matches on things of length 1. - -- Starting from Input_Pos, it matches at most Max CURLY. - - function Try (Pos : Positive) return Boolean; - -- Try to match at specific point - - function Match (IP : Pointer) return Boolean; - -- This is the main matching routine. Conceptually the strategy - -- is simple: check to see whether the current node matches, - -- call self recursively to see whether the rest matches, - -- and then act accordingly. - -- - -- In practice Match makes some effort to avoid recursion, in - -- particular by going through "ordinary" nodes (that don't - -- need to know whether the rest of the match failed) by - -- using a loop instead of recursion. - -- Why is the above comment part of the spec rather than body ??? - - function Match_Whilem return Boolean; - -- Return True if a WHILEM matches the Current_Curly - - function Recurse_Match (IP : Pointer; From : Natural) return Boolean; - pragma Inline (Recurse_Match); - -- Calls Match recursively. It saves and restores the parenthesis - -- status and location in the input stream correctly, so that - -- backtracking is possible - - function Match_Simple_Operator - (Op : Opcode; - Scan : Pointer; - Next : Pointer; - Greedy : Boolean) return Boolean; - -- Return True it the simple operator (possibly non-greedy) matches - - Dump_Indent : Integer := -1; - procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True); - procedure Dump_Error (Msg : String); - -- Debug: print the current context - - pragma Inline (Index); - pragma Inline (Repeat); - - -- These are two complex functions, but used only once - - pragma Inline (Match_Whilem); - pragma Inline (Match_Simple_Operator); - - ----------- - -- Index -- - ----------- - - function Index (Start : Positive; C : Character) return Natural is - begin - for J in Start .. Last_In_Data loop - if Data (J) = C then - return J; - end if; - end loop; - - return 0; - end Index; - - ------------------- - -- Recurse_Match -- - ------------------- - - function Recurse_Match (IP : Pointer; From : Natural) return Boolean is - L : constant Natural := Last_Paren; - Tmp_F : constant Match_Array := - Matches_Full (From + 1 .. Matches_Full'Last); - Start : constant Natural_Array := - Matches_Tmp (From + 1 .. Matches_Tmp'Last); - Input : constant Natural := Input_Pos; - - Dump_Indent_Save : constant Integer := Dump_Indent; - - begin - if Match (IP) then - return True; - end if; - - Last_Paren := L; - Matches_Full (Tmp_F'Range) := Tmp_F; - Matches_Tmp (Start'Range) := Start; - Input_Pos := Input; - Dump_Indent := Dump_Indent_Save; - return False; - end Recurse_Match; - - ------------------ - -- Dump_Current -- - ------------------ - - procedure Dump_Current (Scan : Pointer; Prefix : Boolean := True) is - Length : constant := 10; - Pos : constant String := Integer'Image (Input_Pos); - - begin - if Prefix then - Put ((1 .. 5 - Pos'Length => ' ')); - Put (Pos & " <" - & Data (Input_Pos - .. Integer'Min (Last_In_Data, Input_Pos + Length - 1))); - Put ((1 .. Length - 1 - Last_In_Data + Input_Pos => ' ')); - Put ("> |"); - - else - Put (" "); - end if; - - Dump_Operation (Program, Scan, Indent => Dump_Indent); - end Dump_Current; - - ---------------- - -- Dump_Error -- - ---------------- - - procedure Dump_Error (Msg : String) is - begin - Put (" | "); - Put ((1 .. Dump_Indent * 2 => ' ')); - Put_Line (Msg); - end Dump_Error; - - ----------- - -- Match -- - ----------- - - function Match (IP : Pointer) return Boolean is - Scan : Pointer := IP; - Next : Pointer; - Op : Opcode; - Result : Boolean; - - begin - Dump_Indent := Dump_Indent + 1; - - State_Machine : - loop - pragma Assert (Scan /= 0); - - -- Determine current opcode and count its usage in debug mode - - Op := Opcode'Val (Character'Pos (Program (Scan))); - - -- Calculate offset of next instruction. Second character is most - -- significant in Program_Data. - - Next := Get_Next (Program, Scan); - - if Debug then - Dump_Current (Scan); - end if; - - case Op is - when EOP => - Dump_Indent := Dump_Indent - 1; - return True; -- Success - - when BRANCH => - if Program (Next) /= BRANCH then - Next := Operand (Scan); -- No choice, avoid recursion - - else - loop - if Recurse_Match (Operand (Scan), 0) then - Dump_Indent := Dump_Indent - 1; - return True; - end if; - - Scan := Get_Next (Program, Scan); - exit when Scan = 0 or else Program (Scan) /= BRANCH; - end loop; - - exit State_Machine; - end if; - - when NOTHING => - null; - - when BOL => - exit State_Machine when Input_Pos /= BOL_Pos - and then ((Self.Flags and Multiple_Lines) = 0 - or else Data (Input_Pos - 1) /= ASCII.LF); - - when MBOL => - exit State_Machine when Input_Pos /= BOL_Pos - and then Data (Input_Pos - 1) /= ASCII.LF; - - when SBOL => - exit State_Machine when Input_Pos /= BOL_Pos; - - when EOL => - - -- A combination of MEOL and SEOL - - if (Self.Flags and Multiple_Lines) = 0 then - - -- Single line mode - - exit State_Machine when Input_Pos <= Data'Last; - - elsif Input_Pos <= Last_In_Data then - exit State_Machine when Data (Input_Pos) /= ASCII.LF; - else - exit State_Machine when Last_In_Data /= Data'Last; - end if; - - when MEOL => - if Input_Pos <= Last_In_Data then - exit State_Machine when Data (Input_Pos) /= ASCII.LF; - else - exit State_Machine when Last_In_Data /= Data'Last; - end if; - - when SEOL => - - -- If there is a character before Data'Last (even if - -- Last_In_Data stops before then), we can't have the - -- end of the line. - - exit State_Machine when Input_Pos <= Data'Last; - - when BOUND | NBOUND => - - -- Was last char in word ? - - declare - N : Boolean := False; - Ln : Boolean := False; - - begin - if Input_Pos /= First_In_Data then - N := Is_Alnum (Data (Input_Pos - 1)); - end if; - - Ln := - (if Input_Pos > Last_In_Data - then False - else Is_Alnum (Data (Input_Pos))); - - if Op = BOUND then - if N = Ln then - exit State_Machine; - end if; - else - if N /= Ln then - exit State_Machine; - end if; - end if; - end; - - when SPACE => - exit State_Machine when Input_Pos > Last_In_Data - or else not Is_White_Space (Data (Input_Pos)); - Input_Pos := Input_Pos + 1; - - when NSPACE => - exit State_Machine when Input_Pos > Last_In_Data - or else Is_White_Space (Data (Input_Pos)); - Input_Pos := Input_Pos + 1; - - when DIGIT => - exit State_Machine when Input_Pos > Last_In_Data - or else not Is_Digit (Data (Input_Pos)); - Input_Pos := Input_Pos + 1; - - when NDIGIT => - exit State_Machine when Input_Pos > Last_In_Data - or else Is_Digit (Data (Input_Pos)); - Input_Pos := Input_Pos + 1; - - when ALNUM => - exit State_Machine when Input_Pos > Last_In_Data - or else not Is_Alnum (Data (Input_Pos)); - Input_Pos := Input_Pos + 1; - - when NALNUM => - exit State_Machine when Input_Pos > Last_In_Data - or else Is_Alnum (Data (Input_Pos)); - Input_Pos := Input_Pos + 1; - - when ANY => - exit State_Machine when Input_Pos > Last_In_Data - or else Data (Input_Pos) = ASCII.LF; - Input_Pos := Input_Pos + 1; - - when SANY => - exit State_Machine when Input_Pos > Last_In_Data; - Input_Pos := Input_Pos + 1; - - when EXACT => - declare - Opnd : Pointer := String_Operand (Scan); - Current : Positive := Input_Pos; - Last : constant Pointer := - Opnd + String_Length (Program, Scan); - - begin - while Opnd <= Last loop - exit State_Machine when Current > Last_In_Data - or else Program (Opnd) /= Data (Current); - Current := Current + 1; - Opnd := Opnd + 1; - end loop; - - Input_Pos := Current; - end; - - when EXACTF => - declare - Opnd : Pointer := String_Operand (Scan); - Current : Positive := Input_Pos; - - Last : constant Pointer := - Opnd + String_Length (Program, Scan); - - begin - while Opnd <= Last loop - exit State_Machine when Current > Last_In_Data - or else Program (Opnd) /= To_Lower (Data (Current)); - Current := Current + 1; - Opnd := Opnd + 1; - end loop; - - Input_Pos := Current; - end; - - when ANYOF => - declare - Bitmap : Character_Class; - begin - Bitmap_Operand (Program, Scan, Bitmap); - exit State_Machine when Input_Pos > Last_In_Data - or else not Get_From_Class (Bitmap, Data (Input_Pos)); - Input_Pos := Input_Pos + 1; - end; - - when OPEN => - declare - No : constant Natural := - Character'Pos (Program (Operand (Scan))); - begin - Matches_Tmp (No) := Input_Pos; - end; - - when CLOSE => - declare - No : constant Natural := - Character'Pos (Program (Operand (Scan))); - - begin - Matches_Full (No) := (Matches_Tmp (No), Input_Pos - 1); - - if Last_Paren < No then - Last_Paren := No; - end if; - end; - - when REFF => - declare - No : constant Natural := - Character'Pos (Program (Operand (Scan))); - - Data_Pos : Natural; - - begin - -- If we haven't seen that parenthesis yet - - if Last_Paren < No then - Dump_Indent := Dump_Indent - 1; - - if Debug then - Dump_Error ("REFF: No match, backtracking"); - end if; - - return False; - end if; - - Data_Pos := Matches_Full (No).First; - - while Data_Pos <= Matches_Full (No).Last loop - if Input_Pos > Last_In_Data - or else Data (Input_Pos) /= Data (Data_Pos) - then - Dump_Indent := Dump_Indent - 1; - - if Debug then - Dump_Error ("REFF: No match, backtracking"); - end if; - - return False; - end if; - - Input_Pos := Input_Pos + 1; - Data_Pos := Data_Pos + 1; - end loop; - end; - - when MINMOD => - Greedy := False; - - when STAR | PLUS | CURLY => - declare - Greed : constant Boolean := Greedy; - begin - Greedy := True; - Result := Match_Simple_Operator (Op, Scan, Next, Greed); - Dump_Indent := Dump_Indent - 1; - return Result; - end; - - when CURLYX => - - -- Looking at something like: - - -- 1: CURLYX {n,m} (->4) - -- 2: code for complex thing (->3) - -- 3: WHILEM (->0) - -- 4: NOTHING - - declare - Min : constant Natural := - Read_Natural (Program, Scan + Next_Pointer_Bytes); - Max : constant Natural := - Read_Natural - (Program, Scan + Next_Pointer_Bytes + 2); - Cc : aliased Current_Curly_Record; - - Has_Match : Boolean; - - begin - Cc := (Paren_Floor => Last_Paren, - Cur => -1, - Min => Min, - Max => Max, - Greedy => Greedy, - Scan => Scan + 7, - Next => Next, - Lastloc => 0, - Old_Cc => Current_Curly); - Greedy := True; - Current_Curly := Cc'Unchecked_Access; - - Has_Match := Match (Next - Next_Pointer_Bytes); - - -- Start on the WHILEM - - Current_Curly := Cc.Old_Cc; - Dump_Indent := Dump_Indent - 1; - - if not Has_Match then - if Debug then - Dump_Error ("CURLYX failed..."); - end if; - end if; - - return Has_Match; - end; - - when WHILEM => - Result := Match_Whilem; - Dump_Indent := Dump_Indent - 1; - - if Debug and then not Result then - Dump_Error ("WHILEM: no match, backtracking"); - end if; - - return Result; - end case; - - Scan := Next; - end loop State_Machine; - - if Debug then - Dump_Error ("failed..."); - Dump_Indent := Dump_Indent - 1; - end if; - - -- If we get here, there is no match. For successful matches when EOP - -- is the terminating point. - - return False; - end Match; - - --------------------------- - -- Match_Simple_Operator -- - --------------------------- - - function Match_Simple_Operator - (Op : Opcode; - Scan : Pointer; - Next : Pointer; - Greedy : Boolean) return Boolean - is - Next_Char : Character := ASCII.NUL; - Next_Char_Known : Boolean := False; - No : Integer; -- Can be negative - Min : Natural; - Max : Natural := Natural'Last; - Operand_Code : Pointer; - Old : Natural; - Last_Pos : Natural; - Save : constant Natural := Input_Pos; - - begin - -- Lookahead to avoid useless match attempts when we know what - -- character comes next. - - if Program (Next) = EXACT then - Next_Char := Program (String_Operand (Next)); - Next_Char_Known := True; - end if; - - -- Find the minimal and maximal values for the operator - - case Op is - when STAR => - Min := 0; - Operand_Code := Operand (Scan); - - when PLUS => - Min := 1; - Operand_Code := Operand (Scan); - - when others => - Min := Read_Natural (Program, Scan + Next_Pointer_Bytes); - Max := Read_Natural (Program, Scan + Next_Pointer_Bytes + 2); - Operand_Code := Scan + 7; - end case; - - if Debug then - Dump_Current (Operand_Code, Prefix => False); - end if; - - -- Non greedy operators - - if not Greedy then - - -- Test we can repeat at least Min times - - if Min /= 0 then - No := Repeat (Operand_Code, Min); - - if No < Min then - if Debug then - Dump_Error ("failed... matched" & No'Img & " times"); - end if; - - return False; - end if; - end if; - - Old := Input_Pos; - - -- Find the place where 'next' could work - - if Next_Char_Known then - - -- Last position to check - - if Max = Natural'Last then - Last_Pos := Last_In_Data; - else - Last_Pos := Input_Pos + Max; - - if Last_Pos > Last_In_Data then - Last_Pos := Last_In_Data; - end if; - end if; - - -- Look for the first possible opportunity - - if Debug then - Dump_Error ("Next_Char must be " & Next_Char); - end if; - - loop - -- Find the next possible position - - while Input_Pos <= Last_Pos - and then Data (Input_Pos) /= Next_Char - loop - Input_Pos := Input_Pos + 1; - end loop; - - if Input_Pos > Last_Pos then - return False; - end if; - - -- Check that we still match if we stop at the position we - -- just found. - - declare - Num : constant Natural := Input_Pos - Old; - - begin - Input_Pos := Old; - - if Debug then - Dump_Error ("Would we still match at that position?"); - end if; - - if Repeat (Operand_Code, Num) < Num then - return False; - end if; - end; - - -- Input_Pos now points to the new position - - if Match (Get_Next (Program, Scan)) then - return True; - end if; - - Old := Input_Pos; - Input_Pos := Input_Pos + 1; - end loop; - - -- We do not know what the next character is - - else - while Max >= Min loop - if Debug then - Dump_Error ("Non-greedy repeat, N=" & Min'Img); - Dump_Error ("Do we still match Next if we stop here?"); - end if; - - -- If the next character matches - - if Recurse_Match (Next, 1) then - return True; - end if; - - Input_Pos := Save + Min; - - -- Could not or did not match -- move forward - - if Repeat (Operand_Code, 1) /= 0 then - Min := Min + 1; - else - if Debug then - Dump_Error ("Non-greedy repeat failed..."); - end if; - - return False; - end if; - end loop; - end if; - - return False; - - -- Greedy operators - - else - No := Repeat (Operand_Code, Max); - - if Debug and then No < Min then - Dump_Error ("failed... matched" & No'Img & " times"); - end if; - - -- ??? Perl has some special code here in case the next - -- instruction is of type EOL, since $ and \Z can match before - -- *and* after newline at the end. - - -- ??? Perl has some special code here in case (paren) is True - - -- Else, if we don't have any parenthesis - - while No >= Min loop - if not Next_Char_Known - or else (Input_Pos <= Last_In_Data - and then Data (Input_Pos) = Next_Char) - then - if Match (Next) then - return True; - end if; - end if; - - -- Could not or did not work, we back up - - No := No - 1; - Input_Pos := Save + No; - end loop; - - return False; - end if; - end Match_Simple_Operator; - - ------------------ - -- Match_Whilem -- - ------------------ - - -- This is really hard to understand, because after we match what we - -- are trying to match, we must make sure the rest of the REx is going - -- to match for sure, and to do that we have to go back UP the parse - -- tree by recursing ever deeper. And if it fails, we have to reset - -- our parent's current state that we can try again after backing off. - - function Match_Whilem return Boolean is - Cc : constant Current_Curly_Access := Current_Curly; - - N : constant Natural := Cc.Cur + 1; - Ln : Natural := 0; - - Lastloc : constant Natural := Cc.Lastloc; - -- Detection of 0-len - - begin - -- If degenerate scan matches "", assume scan done - - if Input_Pos = Cc.Lastloc - and then N >= Cc.Min - then - -- Temporarily restore the old context, and check that we - -- match was comes after CURLYX. - - Current_Curly := Cc.Old_Cc; - - if Current_Curly /= null then - Ln := Current_Curly.Cur; - end if; - - if Match (Cc.Next) then - return True; - end if; - - if Current_Curly /= null then - Current_Curly.Cur := Ln; - end if; - - Current_Curly := Cc; - return False; - end if; - - -- First, just match a string of min scans - - if N < Cc.Min then - Cc.Cur := N; - Cc.Lastloc := Input_Pos; - - if Debug then - Dump_Error - ("Tests that we match at least" & Cc.Min'Img & " N=" & N'Img); - end if; - - if Match (Cc.Scan) then - return True; - end if; - - Cc.Cur := N - 1; - Cc.Lastloc := Lastloc; - - if Debug then - Dump_Error ("failed..."); - end if; - - return False; - end if; - - -- Prefer next over scan for minimal matching - - if not Cc.Greedy then - Current_Curly := Cc.Old_Cc; - - if Current_Curly /= null then - Ln := Current_Curly.Cur; - end if; - - if Recurse_Match (Cc.Next, Cc.Paren_Floor) then - return True; - end if; - - if Current_Curly /= null then - Current_Curly.Cur := Ln; - end if; - - Current_Curly := Cc; - - -- Maximum greed exceeded ? - - if N >= Cc.Max then - if Debug then - Dump_Error ("failed..."); - end if; - return False; - end if; - - -- Try scanning more and see if it helps - Cc.Cur := N; - Cc.Lastloc := Input_Pos; - - if Debug then - Dump_Error ("Next failed, what about Current?"); - end if; - - if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then - return True; - end if; - - Cc.Cur := N - 1; - Cc.Lastloc := Lastloc; - return False; - end if; - - -- Prefer scan over next for maximal matching - - if N < Cc.Max then -- more greed allowed ? - Cc.Cur := N; - Cc.Lastloc := Input_Pos; - - if Debug then - Dump_Error ("Recurse at current position"); - end if; - - if Recurse_Match (Cc.Scan, Cc.Paren_Floor) then - return True; - end if; - end if; - - -- Failed deeper matches of scan, so see if this one works - - Current_Curly := Cc.Old_Cc; - - if Current_Curly /= null then - Ln := Current_Curly.Cur; - end if; - - if Debug then - Dump_Error ("Failed matching for later positions"); - end if; - - if Match (Cc.Next) then - return True; - end if; - - if Current_Curly /= null then - Current_Curly.Cur := Ln; - end if; - - Current_Curly := Cc; - Cc.Cur := N - 1; - Cc.Lastloc := Lastloc; - - if Debug then - Dump_Error ("failed..."); - end if; - - return False; - end Match_Whilem; - - ------------ - -- Repeat -- - ------------ - - function Repeat - (IP : Pointer; - Max : Natural := Natural'Last) return Natural - is - Scan : Natural := Input_Pos; - Last : Natural; - Op : constant Opcode := Opcode'Val (Character'Pos (Program (IP))); - Count : Natural; - C : Character; - Is_First : Boolean := True; - Bitmap : Character_Class; - - begin - if Max = Natural'Last or else Scan + Max - 1 > Last_In_Data then - Last := Last_In_Data; - else - Last := Scan + Max - 1; - end if; - - case Op is - when ANY => - while Scan <= Last - and then Data (Scan) /= ASCII.LF - loop - Scan := Scan + 1; - end loop; - - when SANY => - Scan := Last + 1; - - when EXACT => - - -- The string has only one character if Repeat was called - - C := Program (String_Operand (IP)); - while Scan <= Last - and then C = Data (Scan) - loop - Scan := Scan + 1; - end loop; - - when EXACTF => - - -- The string has only one character if Repeat was called - - C := Program (String_Operand (IP)); - while Scan <= Last - and then To_Lower (C) = Data (Scan) - loop - Scan := Scan + 1; - end loop; - - when ANYOF => - if Is_First then - Bitmap_Operand (Program, IP, Bitmap); - Is_First := False; - end if; - - while Scan <= Last - and then Get_From_Class (Bitmap, Data (Scan)) - loop - Scan := Scan + 1; - end loop; - - when ALNUM => - while Scan <= Last - and then Is_Alnum (Data (Scan)) - loop - Scan := Scan + 1; - end loop; - - when NALNUM => - while Scan <= Last - and then not Is_Alnum (Data (Scan)) - loop - Scan := Scan + 1; - end loop; - - when SPACE => - while Scan <= Last - and then Is_White_Space (Data (Scan)) - loop - Scan := Scan + 1; - end loop; - - when NSPACE => - while Scan <= Last - and then not Is_White_Space (Data (Scan)) - loop - Scan := Scan + 1; - end loop; - - when DIGIT => - while Scan <= Last - and then Is_Digit (Data (Scan)) - loop - Scan := Scan + 1; - end loop; - - when NDIGIT => - while Scan <= Last - and then not Is_Digit (Data (Scan)) - loop - Scan := Scan + 1; - end loop; - - when others => - raise Program_Error; - end case; - - Count := Scan - Input_Pos; - Input_Pos := Scan; - return Count; - end Repeat; - - --------- - -- Try -- - --------- - - function Try (Pos : Positive) return Boolean is - begin - Input_Pos := Pos; - Last_Paren := 0; - Matches_Full := (others => No_Match); - - if Match (Program_First) then - Matches_Full (0) := (Pos, Input_Pos - 1); - return True; - end if; - - return False; - end Try; - - -- Start of processing for Match - - begin - -- Do we have the regexp Never_Match? - - if Self.Size = 0 then - Matches := (others => No_Match); - return; - end if; - - -- If there is a "must appear" string, look for it - - if Self.Must_Have_Length > 0 then - declare - First : constant Character := Program (Self.Must_Have); - Must_First : constant Pointer := Self.Must_Have; - Must_Last : constant Pointer := - Must_First + Pointer (Self.Must_Have_Length - 1); - Next_Try : Natural := Index (First_In_Data, First); - - begin - while Next_Try /= 0 - and then Data (Next_Try .. Next_Try + Self.Must_Have_Length - 1) - = String (Program (Must_First .. Must_Last)) - loop - Next_Try := Index (Next_Try + 1, First); - end loop; - - if Next_Try = 0 then - Matches := (others => No_Match); - return; -- Not present - end if; - end; - end if; - - -- Mark beginning of line for ^ - - BOL_Pos := Data'First; - - -- Simplest case first: an anchored match need be tried only once - - if Self.Anchored and then (Self.Flags and Multiple_Lines) = 0 then - Matched := Try (First_In_Data); - - elsif Self.Anchored then - declare - Next_Try : Natural := First_In_Data; - begin - -- Test the first position in the buffer - Matched := Try (Next_Try); - - -- Else only test after newlines - - if not Matched then - while Next_Try <= Last_In_Data loop - while Next_Try <= Last_In_Data - and then Data (Next_Try) /= ASCII.LF - loop - Next_Try := Next_Try + 1; - end loop; - - Next_Try := Next_Try + 1; - - if Next_Try <= Last_In_Data then - Matched := Try (Next_Try); - exit when Matched; - end if; - end loop; - end if; - end; - - elsif Self.First /= ASCII.NUL then - -- We know what char it must start with - - declare - Next_Try : Natural := Index (First_In_Data, Self.First); - - begin - while Next_Try /= 0 loop - Matched := Try (Next_Try); - exit when Matched; - Next_Try := Index (Next_Try + 1, Self.First); - end loop; - end; - - else - -- Messy cases: try all locations (including for the empty string) - - Matched := Try (First_In_Data); - - if not Matched then - for S in First_In_Data + 1 .. Last_In_Data loop - Matched := Try (S); - exit when Matched; - end loop; - end if; - end if; - - -- Matched has its value - - for J in Last_Paren + 1 .. Matches'Last loop - Matches_Full (J) := No_Match; - end loop; - - Matches := Matches_Full (Matches'Range); - end Match; - - ----------- - -- Match -- - ----------- - - function Match - (Self : Pattern_Matcher; - Data : String; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Natural - is - Matches : Match_Array (0 .. 0); - - begin - Match (Self, Data, Matches, Data_First, Data_Last); - if Matches (0) = No_Match then - return Data'First - 1; - else - return Matches (0).First; - end if; - end Match; - - function Match - (Self : Pattern_Matcher; - Data : String; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Boolean - is - Matches : Match_Array (0 .. 0); - - begin - Match (Self, Data, Matches, Data_First, Data_Last); - return Matches (0).First >= Data'First; - end Match; - - procedure Match - (Expression : String; - Data : String; - Matches : out Match_Array; - Size : Program_Size := Auto_Size; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) - is - PM : Pattern_Matcher (Size); - Finalize_Size : Program_Size; - pragma Unreferenced (Finalize_Size); - begin - if Size = 0 then - Match (Compile (Expression), Data, Matches, Data_First, Data_Last); - else - Compile (PM, Expression, Finalize_Size); - Match (PM, Data, Matches, Data_First, Data_Last); - end if; - end Match; - - ----------- - -- Match -- - ----------- - - function Match - (Expression : String; - Data : String; - Size : Program_Size := Auto_Size; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Natural - is - PM : Pattern_Matcher (Size); - Final_Size : Program_Size; - pragma Unreferenced (Final_Size); - begin - if Size = 0 then - return Match (Compile (Expression), Data, Data_First, Data_Last); - else - Compile (PM, Expression, Final_Size); - return Match (PM, Data, Data_First, Data_Last); - end if; - end Match; - - ----------- - -- Match -- - ----------- - - function Match - (Expression : String; - Data : String; - Size : Program_Size := Auto_Size; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Boolean - is - Matches : Match_Array (0 .. 0); - PM : Pattern_Matcher (Size); - Final_Size : Program_Size; - pragma Unreferenced (Final_Size); - begin - if Size = 0 then - Match (Compile (Expression), Data, Matches, Data_First, Data_Last); - else - Compile (PM, Expression, Final_Size); - Match (PM, Data, Matches, Data_First, Data_Last); - end if; - - return Matches (0).First >= Data'First; - end Match; - - ------------- - -- Operand -- - ------------- - - function Operand (P : Pointer) return Pointer is - begin - return P + Next_Pointer_Bytes; - end Operand; - - -------------- - -- Optimize -- - -------------- - - procedure Optimize (Self : in out Pattern_Matcher) is - Scan : Pointer; - Program : Program_Data renames Self.Program; - - begin - -- Start with safe defaults (no optimization): - -- * No known first character of match - -- * Does not necessarily start at beginning of line - -- * No string known that has to appear in data - - Self.First := ASCII.NUL; - Self.Anchored := False; - Self.Must_Have := Program'Last + 1; - Self.Must_Have_Length := 0; - - Scan := Program_First; -- First instruction (can be anything) - - if Program (Scan) = EXACT then - Self.First := Program (String_Operand (Scan)); - - elsif Program (Scan) = BOL - or else Program (Scan) = SBOL - or else Program (Scan) = MBOL - then - Self.Anchored := True; - end if; - end Optimize; - - ----------------- - -- Paren_Count -- - ----------------- - - function Paren_Count (Regexp : Pattern_Matcher) return Match_Count is - begin - return Regexp.Paren_Count; - end Paren_Count; - - ----------- - -- Quote -- - ----------- - - function Quote (Str : String) return String is - S : String (1 .. Str'Length * 2); - Last : Natural := 0; - - begin - for J in Str'Range loop - case Str (J) is - when '^' | '$' | '|' | '*' | '+' | '?' | '{' | - '}' | '[' | ']' | '(' | ')' | '\' | '.' => - - S (Last + 1) := '\'; - S (Last + 2) := Str (J); - Last := Last + 2; - - when others => - S (Last + 1) := Str (J); - Last := Last + 1; - end case; - end loop; - - return S (1 .. Last); - end Quote; - - ------------------ - -- Read_Natural -- - ------------------ - - function Read_Natural - (Program : Program_Data; - IP : Pointer) return Natural - is - begin - return Character'Pos (Program (IP)) + - 256 * Character'Pos (Program (IP + 1)); - end Read_Natural; - - ----------------- - -- Reset_Class -- - ----------------- - - procedure Reset_Class (Bitmap : out Character_Class) is - begin - Bitmap := (others => 0); - end Reset_Class; - - ------------------ - -- Set_In_Class -- - ------------------ - - procedure Set_In_Class - (Bitmap : in out Character_Class; - C : Character) - is - Value : constant Class_Byte := Character'Pos (C); - begin - Bitmap (Value / 8) := Bitmap (Value / 8) - or Bit_Conversion (Value mod 8); - end Set_In_Class; - - ------------------- - -- String_Length -- - ------------------- - - function String_Length - (Program : Program_Data; - P : Pointer) return Program_Size - is - begin - pragma Assert (Program (P) = EXACT or else Program (P) = EXACTF); - return Character'Pos (Program (P + Next_Pointer_Bytes)); - end String_Length; - - -------------------- - -- String_Operand -- - -------------------- - - function String_Operand (P : Pointer) return Pointer is - begin - return P + 4; - end String_Operand; - -end System.Regpat; diff --git a/gcc/ada/s-regpat.ads b/gcc/ada/s-regpat.ads deleted file mode 100644 index 5c8bf5e..0000000 --- a/gcc/ada/s-regpat.ads +++ /dev/null @@ -1,649 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT LIBRARY COMPONENTS -- --- -- --- S Y S T E M . R E G P A T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1986 by University of Toronto. -- --- Copyright (C) 1996-2014, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package implements roughly the same set of regular expressions as --- are available in the Perl or Python programming languages. - --- This is an extension of the original V7 style regular expression library --- written in C by Henry Spencer. Apart from the translation to Ada, the --- interface has been considerably changed to use the Ada String type --- instead of C-style nul-terminated strings. - --- Note: this package is in the System hierarchy so that it can be directly --- be used by other predefined packages. User access to this package is via --- a renaming of this package in GNAT.Regpat (file g-regpat.ads). - -package System.Regpat is - pragma Preelaborate; - - -- The grammar is the following: - - -- regexp ::= expr - -- ::= ^ expr -- anchor at the beginning of string - -- ::= expr $ -- anchor at the end of string - - -- expr ::= term - -- ::= term | term -- alternation (term or term ...) - - -- term ::= item - -- ::= item item ... -- concatenation (item then item) - - -- item ::= elmt -- match elmt - -- ::= elmt * -- zero or more elmt's - -- ::= elmt + -- one or more elmt's - -- ::= elmt ? -- matches elmt or nothing - -- ::= elmt *? -- zero or more times, minimum number - -- ::= elmt +? -- one or more times, minimum number - -- ::= elmt ?? -- zero or one time, minimum number - -- ::= elmt { num } -- matches elmt exactly num times - -- ::= elmt { num , } -- matches elmt at least num times - -- ::= elmt { num , num2 } -- matches between num and num2 times - -- ::= elmt { num }? -- matches elmt exactly num times - -- ::= elmt { num , }? -- matches elmt at least num times - -- non-greedy version - -- ::= elmt { num , num2 }? -- matches between num and num2 times - -- non-greedy version - - -- elmt ::= nchr -- matches given character - -- ::= [range range ...] -- matches any character listed - -- ::= [^ range range ...] -- matches any character not listed - -- ::= . -- matches any single character - -- -- except newlines - -- ::= ( expr ) -- parenthesis used for grouping - -- ::= (?: expr ) -- non-capturing parenthesis - -- ::= \ num -- reference to num-th capturing - -- parenthesis - - -- range ::= char - char -- matches chars in given range - -- ::= nchr - -- ::= [: posix :] -- any character in the POSIX range - -- ::= [:^ posix :] -- not in the POSIX range - - -- posix ::= alnum -- alphanumeric characters - -- ::= alpha -- alphabetic characters - -- ::= ascii -- ascii characters (0 .. 127) - -- ::= cntrl -- control chars (0..31, 127..159) - -- ::= digit -- digits ('0' .. '9') - -- ::= graph -- graphic chars (32..126, 160..255) - -- ::= lower -- lower case characters - -- ::= print -- printable characters (32..127) - -- -- and whitespaces (9 .. 13) - -- ::= punct -- printable, except alphanumeric - -- ::= space -- space characters - -- ::= upper -- upper case characters - -- ::= word -- alphanumeric characters - -- ::= xdigit -- hexadecimal chars (0..9, a..f) - - -- char ::= any character, including special characters - -- ASCII.NUL is not supported. - - -- nchr ::= any character except \()[].*+?^ or \char to match char - -- \n means a newline (ASCII.LF) - -- \t means a tab (ASCII.HT) - -- \r means a return (ASCII.CR) - -- \b matches the empty string at the beginning or end of a - -- word. A word is defined as a set of alphanumerical - -- characters (see \w below). - -- \B matches the empty string only when *not* at the - -- beginning or end of a word. - -- \d matches any digit character ([0-9]) - -- \D matches any non digit character ([^0-9]) - -- \s matches any white space character. This is equivalent - -- to [ \t\n\r\f\v] (tab, form-feed, vertical-tab,... - -- \S matches any non-white space character. - -- \w matches any alphanumeric character or underscore. - -- This include accented letters, as defined in the - -- package Ada.Characters.Handling. - -- \W matches any non-alphanumeric character. - -- \A match the empty string only at the beginning of the - -- string, whatever flags are used for Compile (the - -- behavior of ^ can change, see Regexp_Flags below). - -- \G match the empty string only at the end of the - -- string, whatever flags are used for Compile (the - -- behavior of $ can change, see Regexp_Flags below). - -- ... ::= is used to indication repetition (one or more terms) - - -- Embedded newlines are not matched by the ^ operator. - -- It is possible to retrieve the substring matched a parenthesis - -- expression. Although the depth of parenthesis is not limited in the - -- regexp, only the first 9 substrings can be retrieved. - - -- The highest value possible for the arguments to the curly operator ({}) - -- are given by the constant Max_Curly_Repeat below. - - -- The operators '*', '+', '?' and '{}' always match the longest possible - -- substring. They all have a non-greedy version (with an extra ? after the - -- operator), which matches the shortest possible substring. - - -- For instance: - -- regexp="<.*>" string="

title

" matches="

title

" - -- regexp="<.*?>" string="

title

" matches="

" - -- - -- '{' and '}' are only considered as special characters if they appear - -- in a substring that looks exactly like '{n}', '{n,m}' or '{n,}', where - -- n and m are digits. No space is allowed. In other contexts, the curly - -- braces will simply be treated as normal characters. - - -- Compiling Regular Expressions - -- ============================= - - -- To use this package, you first need to compile the regular expression - -- (a string) into a byte-code program, in a Pattern_Matcher structure. - -- This first step checks that the regexp is valid, and optimizes the - -- matching algorithms of the second step. - - -- Two versions of the Compile subprogram are given: one in which this - -- package will compute itself the best possible size to allocate for the - -- byte code; the other where you must allocate enough memory yourself. An - -- exception is raised if there is not enough memory. - - -- declare - -- Regexp : String := "a|b"; - - -- Matcher : Pattern_Matcher := Compile (Regexp); - -- -- The size for matcher is automatically allocated - - -- Matcher2 : Pattern_Matcher (1000); - -- -- Some space is allocated directly. - - -- begin - -- Compile (Matcher2, Regexp); - -- ... - -- end; - - -- Note that the second version is significantly faster, since with the - -- first version the regular expression has in fact to be compiled twice - -- (first to compute the size, then to generate the byte code). - - -- Note also that you cannot use the function version of Compile if you - -- specify the size of the Pattern_Matcher, since the discriminants will - -- most probably be different and you will get a Constraint_Error - - -- Matching Strings - -- ================ - - -- Once the regular expression has been compiled, you can use it as often - -- as needed to match strings. - - -- Several versions of the Match subprogram are provided, with different - -- parameters and return results. - - -- See the description under each of these subprograms - - -- Here is a short example showing how to get the substring matched by - -- the first parenthesis pair. - - -- declare - -- Matches : Match_Array (0 .. 1); - -- Regexp : String := "a(b|c)d"; - -- Str : String := "gacdg"; - - -- begin - -- Match (Compile (Regexp), Str, Matches); - -- return Str (Matches (1).First .. Matches (1).Last); - -- -- returns 'c' - -- end; - - -- Finding all occurrences - -- ======================= - - -- Finding all the occurrences of a regular expression in a string cannot - -- be done by simply passing a slice of the string. This wouldn't work for - -- anchored regular expressions (the ones starting with "^" or ending with - -- "$"). - -- Instead, you need to use the last parameter to Match (Data_First), as in - -- the following loop: - - -- declare - -- Str : String := - -- "-- first line" & ASCII.LF & "-- second line"; - -- Matches : Match_Array (0 .. 0); - -- Regexp : Pattern_Matcher := Compile ("^--", Multiple_Lines); - -- Current : Natural := Str'First; - -- begin - -- loop - -- Match (Regexp, Str, Matches, Current); - -- exit when Matches (0) = No_Match; - -- - -- -- Process the match at position Matches (0).First - -- - -- Current := Matches (0).Last + 1; - -- end loop; - -- end; - - -- String Substitution - -- =================== - - -- No subprogram is currently provided for string substitution. - -- However, this is easy to simulate with the parenthesis groups, as - -- shown below. - - -- This example swaps the first two words of the string: - - -- declare - -- Regexp : String := "([a-z]+) +([a-z]+)"; - -- Str : String := " first second third "; - -- Matches : Match_Array (0 .. 2); - - -- begin - -- Match (Compile (Regexp), Str, Matches); - -- return Str (Str'First .. Matches (1).First - 1) - -- & Str (Matches (2).First .. Matches (2).Last) - -- & " " - -- & Str (Matches (1).First .. Matches (1).Last) - -- & Str (Matches (2).Last + 1 .. Str'Last); - -- -- returns " second first third " - -- end; - - --------------- - -- Constants -- - --------------- - - Expression_Error : exception; - -- This exception is raised when trying to compile an invalid regular - -- expression. All subprograms taking an expression as parameter may raise - -- Expression_Error. - - Max_Paren_Count : constant := 255; - -- Maximum number of parenthesis in a regular expression. This is limited - -- by the size of a Character, as found in the byte-compiled version of - -- regular expressions. - - Max_Curly_Repeat : constant := 32767; - -- Maximum number of repetition for the curly operator. The digits in the - -- {n}, {n,} and {n,m } operators cannot be higher than this constant, - -- since they have to fit on two characters in the byte-compiled version of - -- regular expressions. - - Max_Program_Size : constant := 2**15 - 1; - -- Maximum size that can be allocated for a program - - type Program_Size is range 0 .. Max_Program_Size; - for Program_Size'Size use 16; - -- Number of bytes allocated for the byte-compiled version of a regular - -- expression. The size required depends on the complexity of the regular - -- expression in a complex manner that is undocumented (other than in the - -- body of the Compile procedure). Normally the size is automatically set - -- and the programmer need not be concerned about it. There are two - -- exceptions to this. First in the calls to Match, it is possible to - -- specify a non-zero size that is known to be large enough. This can - -- slightly increase the efficiency by avoiding a copy. Second, in the case - -- of calling compile, it is possible using the procedural form of Compile - -- to use a single Pattern_Matcher variable for several different - -- expressions by setting its size sufficiently large. - - Auto_Size : constant := 0; - -- Used in calls to Match to indicate that the Size should be set to - -- a value appropriate to the expression being used automatically. - - type Regexp_Flags is mod 256; - for Regexp_Flags'Size use 8; - -- Flags that can be given at compile time to specify default - -- properties for the regular expression. - - No_Flags : constant Regexp_Flags; - Case_Insensitive : constant Regexp_Flags; - -- The automaton is optimized so that the matching is done in a case - -- insensitive manner (upper case characters and lower case characters - -- are all treated the same way). - - Single_Line : constant Regexp_Flags; - -- Treat the Data we are matching as a single line. This means that - -- ^ and $ will ignore \n (unless Multiple_Lines is also specified), - -- and that '.' will match \n. - - Multiple_Lines : constant Regexp_Flags; - -- Treat the Data as multiple lines. This means that ^ and $ will also - -- match on internal newlines (ASCII.LF), in addition to the beginning - -- and end of the string. - -- - -- This can be combined with Single_Line. - - ----------------- - -- Match_Array -- - ----------------- - - subtype Match_Count is Natural range 0 .. Max_Paren_Count; - - type Match_Location is record - First : Natural := 0; - Last : Natural := 0; - end record; - - type Match_Array is array (Match_Count range <>) of Match_Location; - -- Used for regular expressions that can contain parenthesized - -- subexpressions. Certain Match subprograms below produce Matches of type - -- Match_Array. Each component of Matches is set to the subrange of the - -- matches substring, or to No_Match if no match. Matches (N) is for the - -- N'th parenthesized subexpressions; Matches (0) is for the whole - -- expression. - -- - -- Non-capturing parenthesis (introduced with (?:...)) can not be - -- retrieved and do not count in the match array index. - -- - -- For instance, if your regular expression is: "a((b*)c+)(d+)", then - -- 12 3 - -- Matches (0) is for "a((b*)c+)(d+)" (the entire expression) - -- Matches (1) is for "(b*)c+" - -- Matches (2) is for "b*" - -- Matches (3) is for "d+" - -- - -- The number of parenthesis groups that can be retrieved is limited only - -- by Max_Paren_Count. - -- - -- Normally, the bounds of the Matches actual parameter will be - -- 0 .. Paren_Count (Regexp), to get all the matches. However, it is fine - -- if Matches is shorter than that on either end; missing components will - -- be ignored. Thus, in the above example, you could use 2 .. 2 if all you - -- care about it the second parenthesis pair "b*". Likewise, if - -- Matches'Last > Paren_Count (Regexp), the extra components will be set to - -- No_Match. - - No_Match : constant Match_Location := (First => 0, Last => 0); - -- The No_Match constant is (0, 0) to differentiate between matching a null - -- string at position 1, which uses (1, 0) and no match at all. - - --------------------------------- - -- Pattern_Matcher Compilation -- - --------------------------------- - - -- The subprograms here are used to precompile regular expressions for use - -- in subsequent Match calls. Precompilation improves efficiency if the - -- same regular expression is to be used in more than one Match call. - - type Pattern_Matcher (Size : Program_Size) is private; - -- Type used to represent a regular expression compiled into byte code - - Never_Match : constant Pattern_Matcher; - -- A regular expression that never matches anything - - function Compile - (Expression : String; - Flags : Regexp_Flags := No_Flags) return Pattern_Matcher; - -- Compile a regular expression into internal code - -- - -- Raises Expression_Error if Expression is not a legal regular expression - -- - -- The appropriate size is calculated automatically to correspond to the - -- provided expression. This is the normal default method of compilation. - -- Note that it is generally not possible to assign the result of two - -- different calls to this Compile function to the same Pattern_Matcher - -- variable, since the sizes will differ. - -- - -- Flags is the default value to use to set properties for Expression - -- (e.g. case sensitivity,...). - - procedure Compile - (Matcher : out Pattern_Matcher; - Expression : String; - Final_Code_Size : out Program_Size; - Flags : Regexp_Flags := No_Flags); - -- Compile a regular expression into internal code - - -- This procedure is significantly faster than the Compile function since - -- it avoids the extra step of precomputing the required size. - -- - -- However, it requires the user to provide a Pattern_Matcher variable - -- whose size is preset to a large enough value. One advantage of this - -- approach, in addition to the improved efficiency, is that the same - -- Pattern_Matcher variable can be used to hold the compiled code for - -- several different regular expressions by setting a size that is large - -- enough to accommodate all possibilities. - -- - -- In this version of the procedure call, the actual required code size is - -- returned. Also if Matcher.Size is zero on entry, then the resulting code - -- is not stored. A call with Matcher.Size set to Auto_Size can thus be - -- used to determine the space required for compiling the given regular - -- expression. - -- - -- This function raises Storage_Error if Matcher is too small to hold - -- the resulting code (i.e. Matcher.Size has too small a value). - -- - -- Expression_Error is raised if the string Expression does not contain - -- a valid regular expression. - -- - -- Flags is the default value to use to set properties for Expression (case - -- sensitivity,...). - - procedure Compile - (Matcher : out Pattern_Matcher; - Expression : String; - Flags : Regexp_Flags := No_Flags); - -- Same procedure as above, expect it does not return the final - -- program size, and Matcher.Size cannot be Auto_Size. - - function Paren_Count (Regexp : Pattern_Matcher) return Match_Count; - pragma Inline (Paren_Count); - -- Return the number of parenthesis pairs in Regexp. - -- - -- This is the maximum index that will be filled if a Match_Array is - -- used as an argument to Match. - -- - -- Thus, if you want to be sure to get all the parenthesis, you should - -- do something like: - -- - -- declare - -- Regexp : Pattern_Matcher := Compile ("a(b*)(c+)"); - -- Matched : Match_Array (0 .. Paren_Count (Regexp)); - -- begin - -- Match (Regexp, "a string", Matched); - -- end; - - ------------- - -- Quoting -- - ------------- - - function Quote (Str : String) return String; - -- Return a version of Str so that every special character is quoted. - -- The resulting string can be used in a regular expression to match - -- exactly Str, whatever character was present in Str. - - -------------- - -- Matching -- - -------------- - - -- The Match subprograms are given a regular expression in string - -- form, and perform the corresponding match. The following parameters - -- are present in all forms of the Match call. - - -- Expression contains the regular expression to be matched as a string - - -- Data contains the string to be matched - - -- Data_First is the lower bound for the match, i.e. Data (Data_First) - -- will be the first character to be examined. If Data_First is set to - -- the special value of -1 (the default), then the first character to - -- be examined is Data (Data_First). However, the regular expression - -- character ^ (start of string) still refers to the first character - -- of the full string (Data (Data'First)), which is why there is a - -- separate mechanism for specifying Data_First. - - -- Data_Last is the upper bound for the match, i.e. Data (Data_Last) - -- will be the last character to be examined. If Data_Last is set to - -- the special value of Positive'Last (the default), then the last - -- character to be examined is Data (Data_Last). However, the regular - -- expression character $ (end of string) still refers to the last - -- character of the full string (Data (Data'Last)), which is why there - -- is a separate mechanism for specifying Data_Last. - - -- Note: the use of Data_First and Data_Last is not equivalent to - -- simply passing a slice as Expression because of the handling of - -- regular expression characters ^ and $. - - -- Size is the size allocated for the compiled byte code. Normally - -- this is defaulted to Auto_Size which means that the appropriate - -- size is allocated automatically. It is possible to specify an - -- explicit size, which must be sufficiently large. This slightly - -- increases the efficiency by avoiding the extra step of computing - -- the appropriate size. - - -- The following exceptions can be raised in calls to Match - -- - -- Storage_Error is raised if a non-zero value is given for Size - -- and it is too small to hold the compiled byte code. - -- - -- Expression_Error is raised if the given expression is not a legal - -- regular expression. - - procedure Match - (Expression : String; - Data : String; - Matches : out Match_Array; - Size : Program_Size := Auto_Size; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last); - -- This version returns the result of the match stored in Match_Array; - -- see comments under Match_Array above for details. - - function Match - (Expression : String; - Data : String; - Size : Program_Size := Auto_Size; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Natural; - -- This version returns the position where Data matches, or if there is - -- no match, then the value Data'First - 1. - - function Match - (Expression : String; - Data : String; - Size : Program_Size := Auto_Size; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Boolean; - -- This version returns True if the match succeeds, False otherwise - - ------------------------------------------------ - -- Matching a Pre-Compiled Regular Expression -- - ------------------------------------------------ - - -- The following functions are significantly faster if you need to reuse - -- the same regular expression multiple times, since you only have to - -- compile it once. For these functions you must first compile the - -- expression with a call to Compile as previously described. - - -- The parameters Data, Data_First and Data_Last are as described - -- in the previous section. - - function Match - (Self : Pattern_Matcher; - Data : String; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Natural; - -- Match Data using the given pattern matcher. Returns the position - -- where Data matches, or (Data'First - 1) if there is no match. - - function Match - (Self : Pattern_Matcher; - Data : String; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last) return Boolean; - -- Return True if Data matches using the given pattern matcher - - pragma Inline (Match); - -- All except the last one below - - procedure Match - (Self : Pattern_Matcher; - Data : String; - Matches : out Match_Array; - Data_First : Integer := -1; - Data_Last : Positive := Positive'Last); - -- Match Data using the given pattern matcher and store result in Matches; - -- see comments under Match_Array above for details. - - ----------- - -- Debug -- - ----------- - - procedure Dump (Self : Pattern_Matcher); - -- Dump the compiled version of the regular expression matched by Self - --------------------------- --- Private Declarations -- --------------------------- - -private - - subtype Pointer is Program_Size; - -- The Pointer type is used to point into Program_Data - - -- Note that the pointer type is not necessarily 2 bytes - -- although it is stored in the program using 2 bytes - - type Program_Data is array (Pointer range <>) of Character; - - Program_First : constant := 1; - - -- The "internal use only" fields in regexp are present to pass info from - -- compile to execute that permits the execute phase to run lots faster on - -- simple cases. They are: - - -- First character that must begin a match or ASCII.NUL - -- Anchored true iff match must start at beginning of line - -- Must_Have pointer to string that match must include or null - -- Must_Have_Length length of Must_Have string - - -- First and Anchored permit very fast decisions on suitable starting - -- points for a match, cutting down the work a lot. Must_Have permits fast - -- rejection of lines that cannot possibly match. - - -- The Must_Have tests are costly enough that Optimize supplies a Must_Have - -- only if the r.e. contains something potentially expensive (at present, - -- the only such thing detected is * or at the start of the r.e., which can - -- involve a lot of backup). The length is supplied because the test in - -- Execute needs it and Optimize is computing it anyway. - - -- The initialization is meant to fail-safe in case the user of this - -- package tries to use an uninitialized matcher. This takes advantage - -- of the knowledge that ASCII.NUL translates to the end-of-program (EOP) - -- instruction code of the state machine. - - No_Flags : constant Regexp_Flags := 0; - Case_Insensitive : constant Regexp_Flags := 1; - Single_Line : constant Regexp_Flags := 2; - Multiple_Lines : constant Regexp_Flags := 4; - - type Pattern_Matcher (Size : Pointer) is record - First : Character := ASCII.NUL; -- internal use only - Anchored : Boolean := False; -- internal use only - Must_Have : Pointer := 0; -- internal use only - Must_Have_Length : Natural := 0; -- internal use only - Paren_Count : Natural := 0; -- # paren groups - Flags : Regexp_Flags := No_Flags; - Program : Program_Data (Program_First .. Size) := - (others => ASCII.NUL); - end record; - - Never_Match : constant Pattern_Matcher := - (0, ASCII.NUL, False, 0, 0, 0, No_Flags, (others => ASCII.NUL)); - -end System.Regpat; diff --git a/gcc/ada/s-resfil.adb b/gcc/ada/s-resfil.adb deleted file mode 100644 index b36ff94..0000000 --- a/gcc/ada/s-resfil.adb +++ /dev/null @@ -1,525 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R E S P O N S E _ F I L E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Deallocation; - -with System.OS_Lib; use System.OS_Lib; - -package body System.Response_File is - - type File_Rec; - type File_Ptr is access File_Rec; - type File_Rec is record - Name : String_Access; - Next : File_Ptr; - Prev : File_Ptr; - end record; - -- To build a stack of response file names - - procedure Free is new Ada.Unchecked_Deallocation (File_Rec, File_Ptr); - - type Argument_List_Access is access Argument_List; - procedure Free is new Ada.Unchecked_Deallocation - (Argument_List, Argument_List_Access); - -- Free only the allocated Argument_List, not allocated String components - - -------------------- - -- Arguments_From -- - -------------------- - - function Arguments_From - (Response_File_Name : String; - Recursive : Boolean := False; - Ignore_Non_Existing_Files : Boolean := False) - return Argument_List - is - First_File : File_Ptr := null; - Last_File : File_Ptr := null; - -- The stack of response files - - Arguments : Argument_List_Access := new Argument_List (1 .. 4); - Last_Arg : Natural := 0; - - procedure Add_Argument (Arg : String); - -- Add argument Arg to argument list Arguments, increasing Arguments - -- if necessary. - - procedure Recurse (File_Name : String); - -- Get the arguments from the file and call itself recursively if one of - -- the arguments starts with character '@'. - - ------------------ - -- Add_Argument -- - ------------------ - - procedure Add_Argument (Arg : String) is - begin - if Last_Arg = Arguments'Last then - declare - New_Arguments : constant Argument_List_Access := - new Argument_List (1 .. Arguments'Last * 2); - begin - New_Arguments (Arguments'Range) := Arguments.all; - Arguments.all := (others => null); - Free (Arguments); - Arguments := New_Arguments; - end; - end if; - - Last_Arg := Last_Arg + 1; - Arguments (Last_Arg) := new String'(Arg); - end Add_Argument; - - ------------- - -- Recurse -- - ------------- - - procedure Recurse (File_Name : String) is - -- Open the response file. If not found, fail or report a warning, - -- depending on the value of Ignore_Non_Existing_Files. - - FD : constant File_Descriptor := Open_Read (File_Name, Text); - - Buffer_Size : constant := 1500; - Buffer : String (1 .. Buffer_Size); - - Buffer_Length : Natural; - - Buffer_Cursor : Natural; - - End_Of_File_Reached : Boolean; - - Line : String (1 .. Max_Line_Length + 1); - Last : Natural; - - First_Char : Positive; - -- Index of the first character of an argument in Line - - Last_Char : Natural; - -- Index of the last character of an argument in Line - - In_String : Boolean; - -- True when inside a quoted string - - Arg : Positive; - - function End_Of_File return Boolean; - -- True when the end of the response file has been reached - - procedure Get_Buffer; - -- Read one buffer from the response file - - procedure Get_Line; - -- Get one line from the response file - - ----------------- - -- End_Of_File -- - ----------------- - - function End_Of_File return Boolean is - begin - return End_Of_File_Reached and then Buffer_Cursor > Buffer_Length; - end End_Of_File; - - ---------------- - -- Get_Buffer -- - ---------------- - - procedure Get_Buffer is - begin - Buffer_Length := Read (FD, Buffer (1)'Address, Buffer'Length); - End_Of_File_Reached := Buffer_Length < Buffer'Length; - Buffer_Cursor := 1; - end Get_Buffer; - - -------------- - -- Get_Line -- - -------------- - - procedure Get_Line is - Ch : Character; - - begin - Last := 0; - - if End_Of_File then - return; - end if; - - loop - Ch := Buffer (Buffer_Cursor); - - exit when Ch = ASCII.CR or else - Ch = ASCII.LF or else - Ch = ASCII.FF; - - Last := Last + 1; - Line (Last) := Ch; - - if Last = Line'Last then - return; - end if; - - Buffer_Cursor := Buffer_Cursor + 1; - - if Buffer_Cursor > Buffer_Length then - Get_Buffer; - - if End_Of_File then - return; - end if; - end if; - end loop; - - loop - Ch := Buffer (Buffer_Cursor); - - exit when Ch /= ASCII.HT and then - Ch /= ASCII.LF and then - Ch /= ASCII.FF; - - Buffer_Cursor := Buffer_Cursor + 1; - - if Buffer_Cursor > Buffer_Length then - Get_Buffer; - - if End_Of_File then - return; - end if; - end if; - end loop; - end Get_Line; - - -- Start of processing for Recurse - - begin - Last_Arg := 0; - - if FD = Invalid_FD then - if Ignore_Non_Existing_Files then - return; - else - raise File_Does_Not_Exist; - end if; - end if; - - -- Put the response file name on the stack - - if First_File = null then - First_File := - new File_Rec' - (Name => new String'(File_Name), - Next => null, - Prev => null); - Last_File := First_File; - - else - declare - Current : File_Ptr := First_File; - - begin - loop - if Current.Name.all = File_Name then - raise Circularity_Detected; - end if; - - Current := Current.Next; - exit when Current = null; - end loop; - - Last_File.Next := - new File_Rec' - (Name => new String'(File_Name), - Next => null, - Prev => Last_File); - Last_File := Last_File.Next; - end; - end if; - - End_Of_File_Reached := False; - Get_Buffer; - - -- Read the response file line by line - - Line_Loop : - while not End_Of_File loop - Get_Line; - - if Last = Line'Last then - raise Line_Too_Long; - end if; - - First_Char := 1; - - -- Get each argument on the line - - Arg_Loop : - loop - -- First, skip any white space - - while First_Char <= Last loop - exit when Line (First_Char) /= ' ' and then - Line (First_Char) /= ASCII.HT; - First_Char := First_Char + 1; - end loop; - - exit Arg_Loop when First_Char > Last; - - Last_Char := First_Char; - In_String := False; - - -- Get the character one by one - - Character_Loop : - while Last_Char <= Last loop - - -- Inside a string, check only for '"' - - if In_String then - if Line (Last_Char) = '"' then - - -- Remove the '"' - - Line (Last_Char .. Last - 1) := - Line (Last_Char + 1 .. Last); - Last := Last - 1; - - -- End of string is end of argument - - if Last_Char > Last or else - Line (Last_Char) = ' ' or else - Line (Last_Char) = ASCII.HT - then - In_String := False; - - Last_Char := Last_Char - 1; - exit Character_Loop; - - else - -- If there are two consecutive '"', the quoted - -- string is not closed - - In_String := Line (Last_Char) = '"'; - - if In_String then - Last_Char := Last_Char + 1; - end if; - end if; - - else - Last_Char := Last_Char + 1; - end if; - - elsif Last_Char = Last then - - -- An opening '"' at the end of the line is an error - - if Line (Last) = '"' then - raise No_Closing_Quote; - - else - -- The argument ends with the line - - exit Character_Loop; - end if; - - elsif Line (Last_Char) = '"' then - - -- Entering a quoted string: remove the '"' - - In_String := True; - Line (Last_Char .. Last - 1) := - Line (Last_Char + 1 .. Last); - Last := Last - 1; - - else - -- Outside quoted strings, white space ends the argument - - exit Character_Loop - when Line (Last_Char + 1) = ' ' or else - Line (Last_Char + 1) = ASCII.HT; - - Last_Char := Last_Char + 1; - end if; - end loop Character_Loop; - - -- It is an error to not close a quoted string before the end - -- of the line. - - if In_String then - raise No_Closing_Quote; - end if; - - -- Add the argument to the list - - declare - Arg : String (1 .. Last_Char - First_Char + 1); - begin - Arg := Line (First_Char .. Last_Char); - Add_Argument (Arg); - end; - - -- Next argument, if line is not finished - - First_Char := Last_Char + 1; - end loop Arg_Loop; - end loop Line_Loop; - - Close (FD); - - -- If Recursive is True, check for any argument starting with '@' - - if Recursive then - Arg := 1; - while Arg <= Last_Arg loop - - if Arguments (Arg)'Length > 0 and then - Arguments (Arg) (1) = '@' - then - -- Ignore argument '@' with no file name - - if Arguments (Arg)'Length = 1 then - Arguments (Arg .. Last_Arg - 1) := - Arguments (Arg + 1 .. Last_Arg); - Last_Arg := Last_Arg - 1; - - else - -- Save the current arguments and get those in the new - -- response file. - - declare - Inc_File_Name : constant String := - Arguments (Arg) (2 .. Arguments (Arg)'Last); - Current_Arguments : constant Argument_List := - Arguments (1 .. Last_Arg); - begin - Recurse (Inc_File_Name); - - -- Insert the new arguments where the new response - -- file was imported. - - declare - New_Arguments : constant Argument_List := - Arguments (1 .. Last_Arg); - New_Last_Arg : constant Positive := - Current_Arguments'Length + - New_Arguments'Length - 1; - - begin - -- Grow Arguments if it is not large enough - - if Arguments'Last < New_Last_Arg then - Last_Arg := Arguments'Last; - Free (Arguments); - - while Last_Arg < New_Last_Arg loop - Last_Arg := Last_Arg * 2; - end loop; - - Arguments := new Argument_List (1 .. Last_Arg); - end if; - - Last_Arg := New_Last_Arg; - - Arguments (1 .. Last_Arg) := - Current_Arguments (1 .. Arg - 1) & - New_Arguments & - Current_Arguments - (Arg + 1 .. Current_Arguments'Last); - - Arg := Arg + New_Arguments'Length; - end; - end; - end if; - - else - Arg := Arg + 1; - end if; - end loop; - end if; - - -- Remove the response file name from the stack - - if First_File = Last_File then - System.Strings.Free (First_File.Name); - Free (First_File); - First_File := null; - Last_File := null; - - else - System.Strings.Free (Last_File.Name); - Last_File := Last_File.Prev; - Free (Last_File.Next); - end if; - - exception - when others => - Close (FD); - - raise; - end Recurse; - - -- Start of processing for Arguments_From - - begin - -- The job is done by procedure Recurse - - Recurse (Response_File_Name); - - -- Free Arguments before returning the result - - declare - Result : constant Argument_List := Arguments (1 .. Last_Arg); - begin - Free (Arguments); - return Result; - end; - - exception - when others => - - -- When an exception occurs, deallocate everything - - Free (Arguments); - - while First_File /= null loop - Last_File := First_File.Next; - System.Strings.Free (First_File.Name); - Free (First_File); - First_File := Last_File; - end loop; - - raise; - end Arguments_From; - -end System.Response_File; diff --git a/gcc/ada/s-resfil.ads b/gcc/ada/s-resfil.ads deleted file mode 100644 index fbb7f7af..0000000 --- a/gcc/ada/s-resfil.ads +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R E S P O N S E _ F I L E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2007-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides facilities for getting command line arguments --- from a text file, called a "response file". --- --- Using a response file allow passing a set of arguments to an executable --- longer than the maximum allowed by the system on the command line. - -pragma Compiler_Unit_Warning; - -with System.Strings; - -package System.Response_File is - - subtype String_Access is System.Strings.String_Access; - -- type String_Access is access all String; - - procedure Free (S : in out String_Access) renames System.Strings.Free; - -- To deallocate a String - - subtype Argument_List is System.Strings.String_List; - -- type String_List is array (Positive range <>) of String_Access; - - Max_Line_Length : constant := 4096; - -- The maximum length of lines in a response file - - File_Does_Not_Exist : exception; - -- Raise by Arguments_From when a response file cannot be found - - Line_Too_Long : exception; - -- Raise by Arguments_From when a line in the response file is longer than - -- Max_Line_Length. - - No_Closing_Quote : exception; - -- Raise by Arguments_From when a quoted string does not end before the - -- end of the line. - - Circularity_Detected : exception; - -- Raise by Arguments_From when Recursive is True and the same response - -- file is reading itself, either directly or indirectly. - - function Arguments_From - (Response_File_Name : String; - Recursive : Boolean := False; - Ignore_Non_Existing_Files : Boolean := False) - return Argument_List; - -- Read response file with name Response_File_Name and return the argument - -- it contains as an Argument_List. It is the responsibility of the caller - -- to deallocate the strings in the Argument_List if desired. When - -- Recursive is True, any argument of the form @file_name indicates the - -- name of another response file and is replaced by the arguments in this - -- response file. - -- - -- Each nonempty line of the response file contains one or several - -- arguments separated by white space. Empty lines or lines containing only - -- white space are ignored. Arguments containing white space or a double - -- quote ('"')must be quoted. A double quote inside a quote string is - -- indicated by two consecutive double quotes. Example: "-Idir with quote - -- "" and spaces". Non-white-space characters immediately before or after a - -- quoted string are part of the same argument. Ex: -Idir" with "spaces - -- - -- When a response file cannot be found, exception File_Does_Not_Exist is - -- raised if Ignore_Non_Existing_Files is False, otherwise the response - -- file is ignored. Exception Line_Too_Long is raised when a line of a - -- response file is longer than Max_Line_Length. Exception No_Closing_Quote - -- is raised when a quoted argument is not closed before the end of the - -- line. Exception Circularity_Detected is raised when a Recursive is True - -- and a response file is reading itself, either directly or indirectly. - -end System.Response_File; diff --git a/gcc/ada/s-restri.adb b/gcc/ada/s-restri.adb deleted file mode 100644 index bd87b17..0000000 --- a/gcc/ada/s-restri.adb +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . R E S T R I C T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.Restrictions is - use Rident; - - ------------------- - -- Abort_Allowed -- - ------------------- - - function Abort_Allowed return Boolean is - begin - return Run_Time_Restrictions.Violated (No_Abort_Statements) - or else - Run_Time_Restrictions.Violated (Max_Asynchronous_Select_Nesting); - end Abort_Allowed; - - --------------------- - -- Tasking_Allowed -- - --------------------- - - function Tasking_Allowed return Boolean is - begin - return Run_Time_Restrictions.Violated (Max_Tasks) - or else - Run_Time_Restrictions.Violated (No_Tasking); - end Tasking_Allowed; - -end System.Restrictions; diff --git a/gcc/ada/s-restri.ads b/gcc/ada/s-restri.ads deleted file mode 100644 index 66c6584..0000000 --- a/gcc/ada/s-restri.ads +++ /dev/null @@ -1,77 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . R E S T R I C T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 run-time interface for checking the set of --- restrictions that applies to the current partition. The information --- comes both from explicit restriction pragmas present, and also from --- compile time checking. - --- The package simply contains an instantiation of System.Rident, but --- with names discarded, so that we do not have image tables for the --- large restriction enumeration types at run time. - -pragma Compiler_Unit_Warning; - -with System.Rident; - -package System.Restrictions is - pragma Preelaborate; - - pragma Discard_Names; - package Rident is new System.Rident; - -- Instantiate a copy of System.Rident without enumeration image names - - Run_Time_Restrictions : Rident.Restrictions_Info; - -- Restrictions as set by the user, or detected by the binder. See details - -- in package System.Rident for what restrictions are included in the list - -- and the format of the information. - -- - -- Note that a restriction which is both Set and Violated at run-time means - -- that the violation was detected as part of the Ada run-time and not as - -- part of user code. - - ------------------ - -- Subprograms -- - ----------------- - - function Abort_Allowed return Boolean; - pragma Inline (Abort_Allowed); - -- Tests to see if abort is allowed by the current restrictions settings. - -- For abort to be allowed, either No_Abort_Statements must be False, or - -- Max_Asynchronous_Select_Nesting must be non-zero. - - function Tasking_Allowed return Boolean; - pragma Inline (Tasking_Allowed); - -- Tests to see if tasking operations are allowed by the current - -- restrictions settings. For tasking to be allowed, No_Tasking must - -- be False, and Max_Tasks must not be set to zero. - -end System.Restrictions; diff --git a/gcc/ada/s-rident.ads b/gcc/ada/s-rident.ads deleted file mode 100644 index cd88593..0000000 --- a/gcc/ada/s-rident.ads +++ /dev/null @@ -1,642 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . R I D E N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package defines the set of restriction identifiers. It is a generic --- package that is instantiated by the compiler/binder in package Rident, and --- is instantiated in package System.Restrictions for use at run-time. - --- The reason that we make this a generic package is so that in the case of --- the instantiation in Rident for use at compile time and bind time, we can --- generate normal image tables for the enumeration types, which are needed --- for diagnostic and informational messages. At run-time we really do not --- want to waste the space for these image tables, and they are not needed, --- so we can do the instantiation under control of Discard_Names to remove --- the tables. - ---------------------------------------------------- --- Note On Compile/Run-Time Consistency Checking -- ---------------------------------------------------- - --- This unit is with'ed by the run-time (to make System.Restrictions which is --- used for run-time access to restriction information), by the compiler (to --- determine what restrictions are implemented and what their category is) and --- by the binder (in processing ali files, and generating the information used --- at run-time to access restriction information). - --- Normally the version of System.Rident referenced in all three contexts --- should be the same. However, problems could arise in certain inconsistent --- builds that used inconsistent versions of the compiler and run-time. This --- sort of thing is not strictly correct, but it does arise when short-cuts --- are taken in build procedures. - --- Previously, this kind of inconsistency could cause a significant problem. --- If versions of System.Rident accessed by the compiler and binder differed, --- then the binder could fail to recognize the R (restrictions line) in the --- ali file, leading to bind errors when restrictions were added or removed. - --- The latest implementation avoids both this problem by using a named --- scheme for recording restrictions, rather than a positional scheme which --- fails completely if restrictions are added or subtracted. Now the worst --- that happens at bind time in inconsistent builds is that unrecognized --- restrictions are ignored, and the consistency checking for restrictions --- might be incomplete, which is no big deal. - -pragma Compiler_Unit_Warning; - -generic -package System.Rident is - pragma Preelaborate; - - -- The following enumeration type defines the set of restriction - -- identifiers that are implemented in GNAT. - - -- To add a new restriction identifier, add an entry with the name to be - -- used in the pragma, and add calls to the Restrict.Check_Restriction - -- routine as appropriate. - - type Restriction_Id is - - -- The following cases are checked for consistency in the binder. The - -- binder will check that every unit either has the restriction set, or - -- does not violate the restriction. - - (Simple_Barriers, -- Ada 2012 (D.7 (10.9/3)) - Pure_Barriers, -- GNAT - No_Abort_Statements, -- (RM D.7(5), H.4(3)) - No_Access_Parameter_Allocators, -- Ada 2012 (RM H.4 (8.3/3)) - No_Access_Subprograms, -- (RM H.4(17)) - No_Allocators, -- (RM H.4(7)) - No_Anonymous_Allocators, -- Ada 2012 (RM H.4(8/1)) - No_Asynchronous_Control, -- (RM J.13(3/2) - No_Calendar, -- GNAT - No_Coextensions, -- Ada 2012 (RM H.4(8.2/3)) - No_Default_Stream_Attributes, -- Ada 2012 (RM 13.12.1(4/2)) - No_Delay, -- (RM H.4(21)) - No_Direct_Boolean_Operators, -- GNAT - No_Dispatch, -- (RM H.4(19)) - No_Dispatching_Calls, -- GNAT - No_Dynamic_Attachment, -- Ada 2012 (RM E.7(10/3)) - No_Dynamic_Priorities, -- (RM D.9(9)) - No_Enumeration_Maps, -- GNAT - No_Entry_Calls_In_Elaboration_Code, -- GNAT - No_Entry_Queue, -- GNAT (Ravenscar) - No_Exception_Handlers, -- GNAT - No_Exception_Propagation, -- GNAT - No_Exception_Registration, -- GNAT - No_Exceptions, -- (RM H.4(12)) - No_Finalization, -- GNAT - No_Fixed_IO, -- GNAT - No_Fixed_Point, -- (RM H.4(15)) - No_Floating_Point, -- (RM H.4(14)) - No_IO, -- (RM H.4(20)) - No_Implicit_Conditionals, -- GNAT - No_Implicit_Dynamic_Code, -- GNAT - No_Implicit_Heap_Allocations, -- (RM D.8(8), H.4(3)) - No_Implicit_Task_Allocations, -- GNAT - No_Implicit_Protected_Object_Allocations, -- GNAT - No_Initialize_Scalars, -- GNAT - No_Local_Allocators, -- (RM H.4(8)) - No_Local_Timing_Events, -- (RM D.7(10.2/2)) - No_Local_Protected_Objects, -- Ada 2012 (D.7(10/1.3)) - No_Long_Long_Integers, -- GNAT - No_Multiple_Elaboration, -- GNAT - No_Nested_Finalization, -- (RM D.7(4)) - No_Protected_Type_Allocators, -- Ada 2012 (D.7 (10.3/2)) - No_Protected_Types, -- (RM H.4(5)) - No_Recursion, -- (RM H.4(22)) - No_Reentrancy, -- (RM H.4(23)) - No_Relative_Delay, -- Ada 2012 (D.7 (10.5/3)) - No_Requeue_Statements, -- Ada 2012 (D.7 (10.6/3)) - No_Secondary_Stack, -- GNAT - No_Select_Statements, -- Ada 2012 (D.7 (10.7/4)) - No_Specific_Termination_Handlers, -- (RM D.7(10.7/2)) - No_Standard_Allocators_After_Elaboration, -- Ada 2012 (RM D.7(19.1/2)) - No_Standard_Storage_Pools, -- GNAT - No_Stream_Optimizations, -- GNAT - No_Streams, -- GNAT - No_Task_Allocators, -- (RM D.7(7)) - No_Task_Attributes_Package, -- GNAT - No_Task_At_Interrupt_Priority, -- GNAT - No_Task_Hierarchy, -- (RM D.7(3), H.4(3)) - No_Task_Termination, -- GNAT (Ravenscar) - No_Tasking, -- GNAT - No_Terminate_Alternatives, -- (RM D.7(6)) - No_Unchecked_Access, -- (RM H.4(18)) - No_Unchecked_Conversion, -- (RM J.13(4/2)) - No_Unchecked_Deallocation, -- (RM J.13(5/2)) - Static_Priorities, -- GNAT - Static_Storage_Size, -- GNAT - - -- The following require consistency checking with special rules. See - -- individual routines in unit Bcheck for details of what is required. - - No_Default_Initialization, -- GNAT - - -- The following cases do not require consistency checking and if used - -- as a configuration pragma within a specific unit, apply only to that - -- unit (e.g. if used in the package spec, do not apply to the body) - - -- Note: No_Elaboration_Code is handled specially. Like the other - -- non-partition-wide restrictions, it can only be set in a unit that - -- is part of the extended main source unit (body/spec/subunits). But - -- it is sticky, in that if it is found anywhere within any of these - -- units, it applies to all units in this extended main source. - - Immediate_Reclamation, -- (RM H.4(10)) - No_Dynamic_Sized_Objects, -- GNAT - No_Implementation_Aspect_Specifications, -- Ada 2012 AI-241 - No_Implementation_Attributes, -- Ada 2005 AI-257 - No_Implementation_Identifiers, -- Ada 2012 AI-246 - No_Implementation_Pragmas, -- Ada 2005 AI-257 - No_Implementation_Restrictions, -- GNAT - No_Implementation_Units, -- Ada 2012 AI-242 - No_Implicit_Aliasing, -- GNAT - No_Implicit_Loops, -- GNAT - No_Elaboration_Code, -- GNAT - No_Obsolescent_Features, -- Ada 2005 AI-368 - No_Wide_Characters, -- GNAT - SPARK_05, -- GNAT - - -- The following cases require a parameter value - - No_Specification_Of_Aspect, -- 2012 (RM 13.12.1 (6.1/3)) - No_Use_Of_Attribute, -- 2012 (RM 13.12.1 (6.2/3)) - No_Use_Of_Pragma, -- 2012 (RM 13.12.1 (6.3/3)) - - -- The following entries are fully checked at compile/bind time, which - -- means that the compiler can in general tell the minimum value which - -- could be used with a restrictions pragma. The binder can deduce the - -- appropriate minimum value for the partition by taking the maximum - -- value required by any unit. - - Max_Protected_Entries, -- (RM D.7(14)) - Max_Select_Alternatives, -- (RM D.7(12)) - Max_Task_Entries, -- (RM D.7(13), H.4(3)) - - -- The following entries are also fully checked at compile/bind time, - -- and the compiler can also at least in some cases tell the minimum - -- value which could be used with a restriction pragma. The difference - -- is that the contributions are additive, so the binder deduces this - -- value by adding the unit contributions. - - Max_Tasks, -- (RM D.7(19), H.4(3)) - - -- The following entries are checked at compile time only for zero/ - -- nonzero entries. This means that the compiler can tell at compile - -- time if a restriction value of zero is (would be) violated, but that - -- the compiler cannot distinguish between different non-zero values. - - Max_Asynchronous_Select_Nesting, -- (RM D.7(18), H.4(3)) - Max_Entry_Queue_Length, -- Ada 2012 (RM D.7 (19.1/2)) - - -- The remaining entries are not checked at compile/bind time - - Max_Storage_At_Blocking, -- (RM D.7(17)) - - Not_A_Restriction_Id); - - -- Synonyms permitted for historical purposes of compatibility. - -- Must be coordinated with Restrict.Process_Restriction_Synonym. - - Boolean_Entry_Barriers : Restriction_Id renames Simple_Barriers; - Max_Entry_Queue_Depth : Restriction_Id renames Max_Entry_Queue_Length; - No_Dynamic_Interrupts : Restriction_Id renames No_Dynamic_Attachment; - No_Requeue : Restriction_Id renames No_Requeue_Statements; - No_Task_Attributes : Restriction_Id renames No_Task_Attributes_Package; - SPARK : Restriction_Id renames SPARK_05; - - subtype All_Restrictions is Restriction_Id range - Simple_Barriers .. Max_Storage_At_Blocking; - -- All restrictions (excluding only Not_A_Restriction_Id) - - subtype All_Boolean_Restrictions is Restriction_Id range - Simple_Barriers .. SPARK_05; - -- All restrictions which do not take a parameter - - subtype Partition_Boolean_Restrictions is All_Boolean_Restrictions range - Simple_Barriers .. Static_Storage_Size; - -- Boolean restrictions that are checked for partition consistency. - -- Note that all parameter restrictions are checked for partition - -- consistency by default, so this distinction is only needed in the - -- case of Boolean restrictions. - - subtype Cunit_Boolean_Restrictions is All_Boolean_Restrictions range - Immediate_Reclamation .. SPARK_05; - -- Boolean restrictions that are not checked for partition consistency - -- and that thus apply only to the current unit. Note that for these - -- restrictions, the compiler does not apply restrictions found in - -- with'ed units, parent specs etc. to the main unit, and vice versa. - - subtype All_Parameter_Restrictions is - Restriction_Id range - No_Specification_Of_Aspect .. Max_Storage_At_Blocking; - -- All restrictions that take a parameter - - subtype Integer_Parameter_Restrictions is - Restriction_Id range - Max_Protected_Entries .. Max_Storage_At_Blocking; - -- All restrictions taking an integer parameter - - subtype Checked_Parameter_Restrictions is - All_Parameter_Restrictions range - Max_Protected_Entries .. Max_Entry_Queue_Length; - -- These are the parameter restrictions that can be at least partially - -- checked at compile/binder time. Minimally, the compiler can detect - -- violations of a restriction pragma with a value of zero reliably. - - subtype Checked_Max_Parameter_Restrictions is - Checked_Parameter_Restrictions range - Max_Protected_Entries .. Max_Task_Entries; - -- Restrictions with parameters that can be checked in some cases by - -- maximizing among statically detected instances where the compiler - -- can determine the count. - - subtype Checked_Add_Parameter_Restrictions is - Checked_Parameter_Restrictions range - Max_Tasks .. Max_Tasks; - -- Restrictions with parameters that can be checked in some cases by - -- summing the statically detected instances where the compiler can - -- determine the count. - - subtype Checked_Val_Parameter_Restrictions is - Checked_Parameter_Restrictions range - Max_Protected_Entries .. Max_Tasks; - -- Restrictions with parameter where the count is known at least in some - -- cases by the compiler/binder. - - subtype Checked_Zero_Parameter_Restrictions is - Checked_Parameter_Restrictions range - Max_Asynchronous_Select_Nesting .. Max_Entry_Queue_Length; - -- Restrictions with parameters where the compiler can detect the use of - -- the feature, and hence violations of a restriction specifying a value - -- of zero, but cannot detect specific values other than zero/nonzero. - - subtype Unchecked_Parameter_Restrictions is - All_Parameter_Restrictions range - Max_Storage_At_Blocking .. Max_Storage_At_Blocking; - -- Restrictions with parameters where the compiler cannot ever detect - -- corresponding compile time usage, so the binder and compiler never - -- detect violations of any restriction. - - ------------------------------------- - -- Restriction Status Declarations -- - ------------------------------------- - - -- The following declarations are used to record the current status or - -- restrictions (for the current unit, or related units, at compile time, - -- and for all units in a partition at bind time or run time). - - type Restriction_Flags is array (All_Restrictions) of Boolean; - type Restriction_Values is array (All_Parameter_Restrictions) of Natural; - type Parameter_Flags is array (All_Parameter_Restrictions) of Boolean; - - type Restrictions_Info is record - Set : Restriction_Flags; - -- An entry is True in the Set array if a restrictions pragma has been - -- encountered for the given restriction. If the value is True for a - -- parameter restriction, then the corresponding entry in the Value - -- array gives the minimum value encountered for any such restriction. - - Value : Restriction_Values; - -- If the entry for a parameter restriction in Set is True (i.e. a - -- restrictions pragma for the restriction has been encountered), then - -- the corresponding entry in the Value array is the minimum value - -- specified by any such restrictions pragma. Note that a restrictions - -- pragma specifying a value greater than Int'Last is simply ignored. - - Violated : Restriction_Flags; - -- An entry is True in the violations array if the compiler has detected - -- a violation of the restriction. For a parameter restriction, the - -- Count and Unknown arrays have additional information. - - Count : Restriction_Values; - -- If an entry for a parameter restriction is True in Violated, the - -- corresponding entry in the Count array may record additional - -- information. If the actual minimum count is known (by taking - -- maximums, or sums, depending on the restriction), it will be - -- recorded in this array. If not, then the value will remain zero. - -- The value is also zero for a non-violated restriction. - - Unknown : Parameter_Flags; - -- If an entry for a parameter restriction is True in Violated, the - -- corresponding entry in the Unknown array may record additional - -- information. If the actual count is not known by the compiler (but - -- is known to be non-zero), then the entry in Unknown will be True. - -- This indicates that the value in Count is not known to be exact, - -- and the actual violation count may be higher. - - -- Note: If Violated (K) is True, then either Count (K) > 0 or - -- Unknown (K) = True. It is possible for both these to be set. - -- For example, if Count (K) = 3 and Unknown (K) is True, it means - -- that the actual violation count is at least 3 but might be higher. - end record; - - No_Restrictions : constant Restrictions_Info := - (Set => (others => False), - Value => (others => 0), - Violated => (others => False), - Count => (others => 0), - Unknown => (others => False)); - -- Used to initialize Restrictions_Info variables - - ---------------------------------- - -- Profile Definitions and Data -- - ---------------------------------- - - -- Note: to add a profile, modify the following declarations appropriately, - -- add Name_xxx to Snames, and add a branch to the conditions for pragmas - -- Profile and Profile_Warnings in the body of Sem_Prag. - - type Profile_Name is - (No_Profile, - No_Implementation_Extensions, - Restricted_Tasking, - Restricted, - Ravenscar, - GNAT_Extended_Ravenscar, - GNAT_Ravenscar_EDF); - -- Names of recognized profiles. No_Profile is used to indicate that a - -- restriction came from pragma Restrictions[_Warning], as opposed to - -- pragma Profile[_Warning]. Restricted_Tasking is a non-user profile that - -- contaings the minimal set of restrictions to trigger the user of the - -- restricted tasking runtime. Restricted is the corresponding user profile - -- that also restrict protected types. - - subtype Profile_Name_Actual is Profile_Name - range No_Implementation_Extensions .. Profile_Name'Last; - -- Actual used profile names - - type Profile_Data is record - Set : Restriction_Flags; - -- Set to True if given restriction must be set for the profile, and - -- False if it need not be set (False does not mean that it must not be - -- set, just that it need not be set). If the flag is True for a - -- parameter restriction, then the Value array gives the maximum value - -- permitted by the profile. - - Value : Restriction_Values; - -- An entry in this array is meaningful only if the corresponding flag - -- in Set is True. In that case, the value in this array is the maximum - -- value of the parameter permitted by the profile. - end record; - - Profile_Info : constant array (Profile_Name_Actual) of Profile_Data := ( - - -- No_Implementation_Extensions profile - - No_Implementation_Extensions => - - (Set => - (No_Implementation_Aspect_Specifications => True, - No_Implementation_Attributes => True, - No_Implementation_Identifiers => True, - No_Implementation_Pragmas => True, - No_Implementation_Units => True, - others => False), - - -- Value settings for Restricted profile (none - - Value => - (others => 0)), - - -- Restricted_Tasking Profile - - Restricted_Tasking => - - -- Restrictions for Restricted_Tasking profile - - (Set => - (No_Abort_Statements => True, - No_Asynchronous_Control => True, - No_Dynamic_Attachment => True, - No_Dynamic_Priorities => True, - No_Local_Protected_Objects => True, - No_Protected_Type_Allocators => True, - No_Requeue_Statements => True, - No_Task_Allocators => True, - No_Task_Attributes_Package => True, - No_Task_Hierarchy => True, - No_Terminate_Alternatives => True, - Max_Asynchronous_Select_Nesting => True, - Max_Select_Alternatives => True, - Max_Task_Entries => True, - others => False), - - -- Value settings for Restricted_Tasking profile - - Value => - (Max_Asynchronous_Select_Nesting => 0, - Max_Select_Alternatives => 0, - Max_Task_Entries => 0, - others => 0)), - - -- Restricted Profile - - Restricted => - - -- Restrictions for Restricted profile - - (Set => - (No_Abort_Statements => True, - No_Asynchronous_Control => True, - No_Dynamic_Attachment => True, - No_Dynamic_Priorities => True, - No_Entry_Queue => True, - No_Local_Protected_Objects => True, - No_Protected_Type_Allocators => True, - No_Requeue_Statements => True, - No_Task_Allocators => True, - No_Task_Attributes_Package => True, - No_Task_Hierarchy => True, - No_Terminate_Alternatives => True, - Max_Asynchronous_Select_Nesting => True, - Max_Protected_Entries => True, - Max_Select_Alternatives => True, - Max_Task_Entries => True, - others => False), - - -- Value settings for Restricted profile - - Value => - (Max_Asynchronous_Select_Nesting => 0, - Max_Protected_Entries => 1, - Max_Select_Alternatives => 0, - Max_Task_Entries => 0, - others => 0)), - - -- Ravenscar Profile - - -- Note: the table entries here only represent the - -- required restriction profile for Ravenscar. The - -- full Ravenscar profile also requires: - - -- pragma Dispatching_Policy (FIFO_Within_Priorities); - -- pragma Locking_Policy (Ceiling_Locking); - -- pragma Detect_Blocking; - - Ravenscar => - - -- Restrictions for Ravenscar = Restricted profile .. - - (Set => - (No_Abort_Statements => True, - No_Asynchronous_Control => True, - No_Dynamic_Attachment => True, - No_Dynamic_Priorities => True, - No_Entry_Queue => True, - No_Local_Protected_Objects => True, - No_Protected_Type_Allocators => True, - No_Requeue_Statements => True, - No_Task_Allocators => True, - No_Task_Attributes_Package => True, - No_Task_Hierarchy => True, - No_Terminate_Alternatives => True, - Max_Asynchronous_Select_Nesting => True, - Max_Protected_Entries => True, - Max_Select_Alternatives => True, - Max_Task_Entries => True, - - -- plus these additional restrictions: - - No_Calendar => True, - No_Implicit_Heap_Allocations => True, - No_Local_Timing_Events => True, - No_Relative_Delay => True, - No_Select_Statements => True, - No_Specific_Termination_Handlers => True, - No_Task_Termination => True, - Simple_Barriers => True, - others => False), - - -- Value settings for Ravenscar (same as Restricted) - - Value => - (Max_Asynchronous_Select_Nesting => 0, - Max_Protected_Entries => 1, - Max_Select_Alternatives => 0, - Max_Task_Entries => 0, - others => 0)), - - GNAT_Extended_Ravenscar => - - -- Restrictions for GNAT_Extended_Ravenscar = - -- Restricted profile .. - - (Set => - (No_Abort_Statements => True, - No_Asynchronous_Control => True, - No_Dynamic_Attachment => True, - No_Dynamic_Priorities => True, - No_Local_Protected_Objects => True, - No_Protected_Type_Allocators => True, - No_Requeue_Statements => True, - No_Task_Allocators => True, - No_Task_Attributes_Package => True, - No_Task_Hierarchy => True, - No_Terminate_Alternatives => True, - Max_Asynchronous_Select_Nesting => True, - Max_Select_Alternatives => True, - Max_Task_Entries => True, - - -- plus these additional restrictions: - - No_Implicit_Task_Allocations => True, - No_Implicit_Protected_Object_Allocations - => True, - No_Local_Timing_Events => True, - No_Select_Statements => True, - No_Specific_Termination_Handlers => True, - No_Task_Termination => True, - Pure_Barriers => True, - others => False), - - -- Value settings for Ravenscar (same as Restricted) - - Value => - (Max_Asynchronous_Select_Nesting => 0, - Max_Select_Alternatives => 0, - Max_Task_Entries => 0, - others => 0)), - - -- GNAT_Ravenscar_EDF Profile - - -- Note: the table entries here only represent the - -- required restriction profile for GNAT_Ravenscar_EDF. - -- The full GNAT_Ravenscar_EDF profile also requires: - - -- pragma Dispatching_Policy (EDF_Across_Priorities); - -- pragma Locking_Policy (Ceiling_Locking); - -- pragma Detect_Blocking; - - GNAT_Ravenscar_EDF => - - -- Restrictions for Ravenscar = Restricted profile .. - - (Set => - (No_Abort_Statements => True, - No_Asynchronous_Control => True, - No_Dynamic_Attachment => True, - No_Dynamic_Priorities => True, - No_Entry_Queue => True, - No_Local_Protected_Objects => True, - No_Protected_Type_Allocators => True, - No_Requeue_Statements => True, - No_Task_Allocators => True, - No_Task_Attributes_Package => True, - No_Task_Hierarchy => True, - No_Terminate_Alternatives => True, - Max_Asynchronous_Select_Nesting => True, - Max_Protected_Entries => True, - Max_Select_Alternatives => True, - Max_Task_Entries => True, - - -- plus these additional restrictions: - - No_Calendar => True, - No_Implicit_Heap_Allocations => True, - No_Local_Timing_Events => True, - No_Relative_Delay => True, - No_Select_Statements => True, - No_Specific_Termination_Handlers => True, - No_Task_Termination => True, - Simple_Barriers => True, - others => False), - - -- Value settings for Ravenscar (same as Restricted) - - Value => - (Max_Asynchronous_Select_Nesting => 0, - Max_Protected_Entries => 1, - Max_Select_Alternatives => 0, - Max_Task_Entries => 0, - others => 0))); - -end System.Rident; diff --git a/gcc/ada/s-rpc.adb b/gcc/ada/s-rpc.adb deleted file mode 100644 index 1ffb9b9..0000000 --- a/gcc/ada/s-rpc.adb +++ /dev/null @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . R P C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: this is a dummy implementation which does not support distribution. --- All the bodies but one therefore raise an exception as defined below. --- Establish_RPC_Receiver is callable, so that the ACVC scripts can simulate --- the presence of a master partition to run a test which is otherwise not --- distributed. - --- The GLADE distribution package includes a replacement for this file - -package body System.RPC is - - CRLF : constant String := ASCII.CR & ASCII.LF; - - Msg : constant String := - CRLF & "Distribution support not installed in your environment" & - CRLF & "For information on GLADE, contact Ada Core Technologies"; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : in out Params_Stream_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - begin - raise Program_Error with Msg; - end Read; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : in out Params_Stream_Type; - Item : Ada.Streams.Stream_Element_Array) - is - begin - raise Program_Error with Msg; - end Write; - - ------------ - -- Do_RPC -- - ------------ - - procedure Do_RPC - (Partition : Partition_ID; - Params : access Params_Stream_Type; - Result : access Params_Stream_Type) - is - begin - raise Program_Error with Msg; - end Do_RPC; - - ------------ - -- Do_APC -- - ------------ - - procedure Do_APC - (Partition : Partition_ID; - Params : access Params_Stream_Type) - is - begin - raise Program_Error with Msg; - end Do_APC; - - ---------------------------- - -- Establish_RPC_Receiver -- - ---------------------------- - - procedure Establish_RPC_Receiver - (Partition : Partition_ID; - Receiver : RPC_Receiver) - is - pragma Unreferenced (Partition, Receiver); - begin - null; - end Establish_RPC_Receiver; - -end System.RPC; diff --git a/gcc/ada/s-rpc.ads b/gcc/ada/s-rpc.ads deleted file mode 100644 index 2c23e5c..0000000 --- a/gcc/ada/s-rpc.ads +++ /dev/null @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . R P C -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Note: this is a dummy implementation which does not support distribution. --- The GLADE distribution package includes a replacement for this file which --- has a different private - -with Ada.Streams; - -package System.RPC is - - type Partition_ID is range 0 .. Integer'Last; - - Communication_Error : exception; - - type Params_Stream_Type - (Initial_Size : Ada.Streams.Stream_Element_Count) is new - Ada.Streams.Root_Stream_Type with private; - - overriding procedure Read - (Stream : in out Params_Stream_Type; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - - overriding procedure Write - (Stream : in out Params_Stream_Type; - Item : Ada.Streams.Stream_Element_Array); - - -- Synchronous call - - procedure Do_RPC - (Partition : Partition_ID; - Params : access Params_Stream_Type; - Result : access Params_Stream_Type); - - -- Asynchronous call - - procedure Do_APC - (Partition : Partition_ID; - Params : access Params_Stream_Type); - - -- The handler for incoming RPCs - - type RPC_Receiver is - access procedure - (Params : access Params_Stream_Type; - Result : access Params_Stream_Type); - - procedure Establish_RPC_Receiver ( - Partition : Partition_ID; - Receiver : RPC_Receiver); - -private - - type Params_Stream_Type - (Initial_Size : Ada.Streams.Stream_Element_Count) is new - Ada.Streams.Root_Stream_Type with null record; - -end System.RPC; diff --git a/gcc/ada/s-scaval.adb b/gcc/ada/s-scaval.adb deleted file mode 100644 index 632e30e..0000000 --- a/gcc/ada/s-scaval.adb +++ /dev/null @@ -1,328 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S C A L A R _ V A L U E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body System.Scalar_Values is - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Mode1 : Character; Mode2 : Character) is - C1 : Character := Mode1; - C2 : Character := Mode2; - - procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); - pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); - - subtype String2 is String (1 .. 2); - type String2_Ptr is access all String2; - - Env_Value_Ptr : aliased String2_Ptr; - Env_Value_Length : aliased Integer; - - EV_Val : aliased constant String := - "GNAT_INIT_SCALARS" & ASCII.NUL; - - B : Byte1; - - EFloat : constant Boolean := Long_Long_Float'Size > Long_Float'Size; - -- Set True if we are on an x86 with 96-bit floats for extended - - AFloat : constant Boolean := - Long_Float'Size = 48 and then Long_Long_Float'Size = 48; - -- Set True if we are on an AAMP with 48-bit extended floating point - - type ByteLF is array (0 .. 7 - 2 * Boolean'Pos (AFloat)) of Byte1; - - for ByteLF'Component_Size use 8; - - -- Type used to hold Long_Float values on all targets and to initialize - -- 48-bit Long_Float values used on AAMP. On AAMP, this type is 6 bytes. - -- On other targets the type is 8 bytes, and type Byte8 is used for - -- values that are then converted to ByteLF. - - pragma Warnings (Off); -- why ??? - function To_ByteLF is new Ada.Unchecked_Conversion (Byte8, ByteLF); - pragma Warnings (On); - - type ByteLLF is - array (0 .. 7 + 4 * Boolean'Pos (EFloat) - 2 * Boolean'Pos (AFloat)) - of Byte1; - - for ByteLLF'Component_Size use 8; - - -- Type used to initialize Long_Long_Float values used on x86 and - -- any other target with the same 80-bit floating-point values that - -- GCC always stores in 96-bits. Note that we are assuming Intel - -- format little-endian addressing for this type. On non-Intel - -- architectures, this is the same length as Byte8 and holds - -- a Long_Float value. - - -- The following variables are used to initialize the float values - -- by overlay. We can't assign directly to the float values, since - -- we may be assigning signalling Nan's that will cause a trap if - -- loaded into a floating-point register. - - IV_Isf : aliased Byte4; -- Initialize short float - IV_Ifl : aliased Byte4; -- Initialize float - IV_Ilf : aliased ByteLF; -- Initialize long float - IV_Ill : aliased ByteLLF; -- Initialize long long float - - for IV_Isf'Address use IS_Isf'Address; - for IV_Ifl'Address use IS_Ifl'Address; - for IV_Ilf'Address use IS_Ilf'Address; - for IV_Ill'Address use IS_Ill'Address; - - -- The following pragmas are used to suppress initialization - - pragma Import (Ada, IV_Isf); - pragma Import (Ada, IV_Ifl); - pragma Import (Ada, IV_Ilf); - pragma Import (Ada, IV_Ill); - - begin - -- Acquire environment variable value if necessary - - if C1 = 'E' and then C2 = 'V' then - Get_Env_Value_Ptr - (EV_Val'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); - - -- Ignore if length is not 2 - - if Env_Value_Length /= 2 then - C1 := 'I'; - C2 := 'N'; - - -- Length is 2, see if it is a valid value - - else - -- Acquire two characters and fold to upper case - - C1 := Env_Value_Ptr (1); - C2 := Env_Value_Ptr (2); - - if C1 in 'a' .. 'z' then - C1 := Character'Val (Character'Pos (C1) - 32); - end if; - - if C2 in 'a' .. 'z' then - C2 := Character'Val (Character'Pos (C2) - 32); - end if; - - -- IN/LO/HI are ok values - - if (C1 = 'I' and then C2 = 'N') - or else - (C1 = 'L' and then C2 = 'O') - or else - (C1 = 'H' and then C2 = 'I') - then - null; - - -- Try for valid hex digits - - elsif (C1 in '0' .. '9' or else C1 in 'A' .. 'Z') - or else - (C2 in '0' .. '9' or else C2 in 'A' .. 'Z') - then - null; - - -- Otherwise environment value is bad, ignore and use IN (invalid) - - else - C1 := 'I'; - C2 := 'N'; - end if; - end if; - end if; - - -- IN (invalid value) - - if C1 = 'I' and then C2 = 'N' then - IS_Is1 := 16#80#; - IS_Is2 := 16#8000#; - IS_Is4 := 16#8000_0000#; - IS_Is8 := 16#8000_0000_0000_0000#; - - IS_Iu1 := 16#FF#; - IS_Iu2 := 16#FFFF#; - IS_Iu4 := 16#FFFF_FFFF#; - IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; - - IS_Iz1 := 16#00#; - IS_Iz2 := 16#0000#; - IS_Iz4 := 16#0000_0000#; - IS_Iz8 := 16#0000_0000_0000_0000#; - - if AFloat then - IV_Isf := 16#FFFF_FF00#; - IV_Ifl := 16#FFFF_FF00#; - IV_Ilf := (0, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#); - - else - IV_Isf := IS_Iu4; - IV_Ifl := IS_Iu4; - IV_Ilf := To_ByteLF (IS_Iu8); - end if; - - if EFloat then - IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#C0#, 16#FF#, 16#FF#, 0, 0); - end if; - - -- LO (Low values) - - elsif C1 = 'L' and then C2 = 'O' then - IS_Is1 := 16#80#; - IS_Is2 := 16#8000#; - IS_Is4 := 16#8000_0000#; - IS_Is8 := 16#8000_0000_0000_0000#; - - IS_Iu1 := 16#00#; - IS_Iu2 := 16#0000#; - IS_Iu4 := 16#0000_0000#; - IS_Iu8 := 16#0000_0000_0000_0000#; - - IS_Iz1 := 16#00#; - IS_Iz2 := 16#0000#; - IS_Iz4 := 16#0000_0000#; - IS_Iz8 := 16#0000_0000_0000_0000#; - - if AFloat then - IV_Isf := 16#0000_0001#; - IV_Ifl := 16#0000_0001#; - IV_Ilf := (1, 0, 0, 0, 0, 0); - - else - IV_Isf := 16#FF80_0000#; - IV_Ifl := 16#FF80_0000#; - IV_Ilf := To_ByteLF (16#FFF0_0000_0000_0000#); - end if; - - if EFloat then - IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#FF#, 0, 0); - end if; - - -- HI (High values) - - elsif C1 = 'H' and then C2 = 'I' then - IS_Is1 := 16#7F#; - IS_Is2 := 16#7FFF#; - IS_Is4 := 16#7FFF_FFFF#; - IS_Is8 := 16#7FFF_FFFF_FFFF_FFFF#; - - IS_Iu1 := 16#FF#; - IS_Iu2 := 16#FFFF#; - IS_Iu4 := 16#FFFF_FFFF#; - IS_Iu8 := 16#FFFF_FFFF_FFFF_FFFF#; - - IS_Iz1 := 16#FF#; - IS_Iz2 := 16#FFFF#; - IS_Iz4 := 16#FFFF_FFFF#; - IS_Iz8 := 16#FFFF_FFFF_FFFF_FFFF#; - - if AFloat then - IV_Isf := 16#7FFF_FFFF#; - IV_Ifl := 16#7FFF_FFFF#; - IV_Ilf := (16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#FF#, 16#7F#); - - else - IV_Isf := 16#7F80_0000#; - IV_Ifl := 16#7F80_0000#; - IV_Ilf := To_ByteLF (16#7FF0_0000_0000_0000#); - end if; - - if EFloat then - IV_Ill := (0, 0, 0, 0, 0, 0, 0, 16#80#, 16#FF#, 16#7F#, 0, 0); - end if; - - -- -Shh (hex byte) - - else - -- Convert the two hex digits (we know they are valid here) - - B := 16 * (Character'Pos (C1) - - (if C1 in '0' .. '9' - then Character'Pos ('0') - else Character'Pos ('A') - 10)) - + (Character'Pos (C2) - - (if C2 in '0' .. '9' - then Character'Pos ('0') - else Character'Pos ('A') - 10)); - - -- Initialize data values from the hex value - - IS_Is1 := B; - IS_Is2 := 2**8 * Byte2 (IS_Is1) + Byte2 (IS_Is1); - IS_Is4 := 2**16 * Byte4 (IS_Is2) + Byte4 (IS_Is2); - IS_Is8 := 2**32 * Byte8 (IS_Is4) + Byte8 (IS_Is4); - - IS_Iu1 := IS_Is1; - IS_Iu2 := IS_Is2; - IS_Iu4 := IS_Is4; - IS_Iu8 := IS_Is8; - - IS_Iz1 := IS_Is1; - IS_Iz2 := IS_Is2; - IS_Iz4 := IS_Is4; - IS_Iz8 := IS_Is8; - - IV_Isf := IS_Is4; - IV_Ifl := IS_Is4; - - if AFloat then - IV_Ill := (B, B, B, B, B, B); - else - IV_Ilf := To_ByteLF (IS_Is8); - end if; - - if EFloat then - IV_Ill := (B, B, B, B, B, B, B, B, B, B, B, B); - end if; - end if; - - -- If no separate Long_Long_Float, then use Long_Float value as - -- Long_Long_Float initial value. - - if not EFloat then - declare - pragma Warnings (Off); -- why??? - function To_ByteLLF is - new Ada.Unchecked_Conversion (ByteLF, ByteLLF); - pragma Warnings (On); - begin - IV_Ill := To_ByteLLF (IV_Ilf); - end; - end if; - end Initialize; - -end System.Scalar_Values; diff --git a/gcc/ada/s-scaval.ads b/gcc/ada/s-scaval.ads deleted file mode 100644 index 9ebbd50..0000000 --- a/gcc/ada/s-scaval.ads +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S C A L A R _ V A L U E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2001-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package defines the constants used for initializing scalar values --- when pragma Initialize_Scalars is used. The actual values are defined --- in the binder generated file. This package contains the Ada names that --- are used by the generated code, which are linked to the actual values --- by the use of pragma Import. - -package System.Scalar_Values is - - -- Note: logically this package should be Pure since it can be accessed - -- from pure units, but the IS_xxx variables below get set at run time, - -- so they have to be library level variables. In fact we only ever - -- access this from generated code, and the compiler knows that it is - -- OK to access this unit from generated code. - - type Byte1 is mod 2 ** 8; - type Byte2 is mod 2 ** 16; - type Byte4 is mod 2 ** 32; - type Byte8 is mod 2 ** 64; - - -- The explicit initializations here are not really required, since these - -- variables are always set by System.Scalar_Values.Initialize. - - IS_Is1 : Byte1 := 0; -- Initialize 1 byte signed - IS_Is2 : Byte2 := 0; -- Initialize 2 byte signed - IS_Is4 : Byte4 := 0; -- Initialize 4 byte signed - IS_Is8 : Byte8 := 0; -- Initialize 8 byte signed - -- For the above cases, the undefined value (set by the binder -Sin switch) - -- is the largest negative number (1 followed by all zero bits). - - IS_Iu1 : Byte1 := 0; -- Initialize 1 byte unsigned - IS_Iu2 : Byte2 := 0; -- Initialize 2 byte unsigned - IS_Iu4 : Byte4 := 0; -- Initialize 4 byte unsigned - IS_Iu8 : Byte8 := 0; -- Initialize 8 byte unsigned - -- For the above cases, the undefined value (set by the binder -Sin switch) - -- is the largest unsigned number (all 1 bits). - - IS_Iz1 : Byte1 := 0; -- Initialize 1 byte zeroes - IS_Iz2 : Byte2 := 0; -- Initialize 2 byte zeroes - IS_Iz4 : Byte4 := 0; -- Initialize 4 byte zeroes - IS_Iz8 : Byte8 := 0; -- Initialize 8 byte zeroes - -- For the above cases, the undefined value (set by the binder -Sin switch) - -- is the zero (all 0 bits). This is used when zero is known to be an - -- invalid value. - - -- The float definitions are aliased, because we use overlays to set them - - IS_Isf : aliased Short_Float := 0.0; -- Initialize short float - IS_Ifl : aliased Float := 0.0; -- Initialize float - IS_Ilf : aliased Long_Float := 0.0; -- Initialize long float - IS_Ill : aliased Long_Long_Float := 0.0; -- Initialize long long float - - procedure Initialize (Mode1 : Character; Mode2 : Character); - -- This procedure is called from the binder when Initialize_Scalars mode - -- is active. The arguments are the two characters from the -S switch, - -- with letters forced upper case. So for example if -S5a is given, then - -- Mode1 will be '5' and Mode2 will be 'A'. If the parameters are EV, - -- then this routine reads the environment variable GNAT_INIT_SCALARS. - -- The possible settings are the same as those for the -S switch (except - -- for EV), i.e. IN/LO/HO/xx, xx = 2 hex digits. If no -S switch is given - -- then the default of IN (invalid values) is passed on the call. - -end System.Scalar_Values; diff --git a/gcc/ada/s-secsta.adb b/gcc/ada/s-secsta.adb deleted file mode 100644 index 1cb1b1b..0000000 --- a/gcc/ada/s-secsta.adb +++ /dev/null @@ -1,547 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S E C O N D A R Y _ S T A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Soft_Links; -with System.Parameters; - -with Ada.Unchecked_Conversion; -with Ada.Unchecked_Deallocation; - -package body System.Secondary_Stack is - - package SSL renames System.Soft_Links; - - use type SSE.Storage_Offset; - use type System.Parameters.Size_Type; - - SS_Ratio_Dynamic : constant Boolean := - Parameters.Sec_Stack_Percentage = Parameters.Dynamic; - -- There are two entirely different implementations of the secondary - -- stack mechanism in this unit, and this Boolean is used to select - -- between them (at compile time, so the generated code will contain - -- only the code for the desired variant). If SS_Ratio_Dynamic is - -- True, then the secondary stack is dynamically allocated from the - -- heap in a linked list of chunks. If SS_Ration_Dynamic is False, - -- then the secondary stack is allocated statically by grabbing a - -- section of the primary stack and using it for this purpose. - - type Memory is array (SS_Ptr range <>) of SSE.Storage_Element; - for Memory'Alignment use Standard'Maximum_Alignment; - -- This is the type used for actual allocation of secondary stack - -- areas. We require maximum alignment for all such allocations. - - --------------------------------------------------------------- - -- Data Structures for Dynamically Allocated Secondary Stack -- - --------------------------------------------------------------- - - -- The following is a diagram of the data structures used for the - -- case of a dynamically allocated secondary stack, where the stack - -- is allocated as a linked list of chunks allocated from the heap. - - -- +------------------+ - -- | Next | - -- +------------------+ - -- | | Last (200) - -- | | - -- | | - -- | | - -- | | - -- | | - -- | | First (101) - -- +------------------+ - -- +----------> | | | - -- | +--------- | ------+ - -- | ^ | - -- | | | - -- | | V - -- | +------ | ---------+ - -- | | | | - -- | +------------------+ - -- | | | Last (100) - -- | | C | - -- | | H | - -- +-----------------+ | +------->| U | - -- | Current_Chunk ----+ | | N | - -- +-----------------+ | | K | - -- | Top --------+ | | First (1) - -- +-----------------+ +------------------+ - -- | Default_Size | | Prev | - -- +-----------------+ +------------------+ - -- - - type Chunk_Id (First, Last : SS_Ptr); - type Chunk_Ptr is access all Chunk_Id; - - type Chunk_Id (First, Last : SS_Ptr) is record - Prev, Next : Chunk_Ptr; - Mem : Memory (First .. Last); - end record; - - type Stack_Id is record - Top : SS_Ptr; - Default_Size : SSE.Storage_Count; - Current_Chunk : Chunk_Ptr; - end record; - - type Stack_Ptr is access Stack_Id; - -- Pointer to record used to represent a dynamically allocated secondary - -- stack descriptor for a secondary stack chunk. - - procedure Free is new Ada.Unchecked_Deallocation (Chunk_Id, Chunk_Ptr); - -- Free a dynamically allocated chunk - - function To_Stack_Ptr is new - Ada.Unchecked_Conversion (Address, Stack_Ptr); - function To_Addr is new - Ada.Unchecked_Conversion (Stack_Ptr, Address); - -- Convert to and from address stored in task data structures - - -------------------------------------------------------------- - -- Data Structures for Statically Allocated Secondary Stack -- - -------------------------------------------------------------- - - -- For the static case, the secondary stack is a single contiguous - -- chunk of storage, carved out of the primary stack, and represented - -- by the following data structure - - type Fixed_Stack_Id is record - Top : SS_Ptr; - -- Index of next available location in Mem. This is initialized to - -- 0, and then incremented on Allocate, and Decremented on Release. - - Last : SS_Ptr; - -- Length of usable Mem array, which is thus the index past the - -- last available location in Mem. Mem (Last-1) can be used. This - -- is used to check that the stack does not overflow. - - Max : SS_Ptr; - -- Maximum value of Top. Initialized to 0, and then may be incremented - -- on Allocate, but is never Decremented. The last used location will - -- be Mem (Max - 1), so Max is the maximum count of used stack space. - - Mem : Memory (0 .. 0); - -- This is the area that is actually used for the secondary stack. - -- Note that the upper bound is a dummy value properly defined by - -- the value of Last. We never actually allocate objects of type - -- Fixed_Stack_Id, so the bounds declared here do not matter. - end record; - - Dummy_Fixed_Stack : Fixed_Stack_Id; - pragma Warnings (Off, Dummy_Fixed_Stack); - -- Well it is not quite true that we never allocate an object of the - -- type. This dummy object is allocated for the purpose of getting the - -- offset of the Mem field via the 'Position attribute (such a nuisance - -- that we cannot apply this to a field of a type). - - type Fixed_Stack_Ptr is access Fixed_Stack_Id; - -- Pointer to record used to describe statically allocated sec stack - - function To_Fixed_Stack_Ptr is new - Ada.Unchecked_Conversion (Address, Fixed_Stack_Ptr); - -- Convert from address stored in task data structures - - ---------------------------------- - -- Minimum_Secondary_Stack_Size -- - ---------------------------------- - - function Minimum_Secondary_Stack_Size return Natural is - begin - return Dummy_Fixed_Stack.Mem'Position; - end Minimum_Secondary_Stack_Size; - - -------------- - -- Allocate -- - -------------- - - procedure SS_Allocate - (Addr : out Address; - Storage_Size : SSE.Storage_Count) - is - Max_Align : constant SS_Ptr := SS_Ptr (Standard'Maximum_Alignment); - Max_Size : constant SS_Ptr := - ((SS_Ptr (Storage_Size) + Max_Align - 1) / Max_Align) * - Max_Align; - - begin - -- Case of fixed allocation secondary stack - - if not SS_Ratio_Dynamic then - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - - begin - -- Check if max stack usage is increasing - - if Fixed_Stack.Top + Max_Size > Fixed_Stack.Max then - - -- If so, check if max size is exceeded - - if Fixed_Stack.Top + Max_Size > Fixed_Stack.Last then - raise Storage_Error; - end if; - - -- Record new max usage - - Fixed_Stack.Max := Fixed_Stack.Top + Max_Size; - end if; - - -- Set resulting address and update top of stack pointer - - Addr := Fixed_Stack.Mem (Fixed_Stack.Top)'Address; - Fixed_Stack.Top := Fixed_Stack.Top + Max_Size; - end; - - -- Case of dynamically allocated secondary stack - - else - declare - Stack : constant Stack_Ptr := - To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - Chunk : Chunk_Ptr; - - To_Be_Released_Chunk : Chunk_Ptr; - - begin - Chunk := Stack.Current_Chunk; - - -- The Current_Chunk may not be the good one if a lot of release - -- operations have taken place. Go down the stack if necessary. - - while Chunk.First > Stack.Top loop - Chunk := Chunk.Prev; - end loop; - - -- Find out if the available memory in the current chunk is - -- sufficient, if not, go to the next one and eventually create - -- the necessary room. - - while Chunk.Last - Stack.Top + 1 < Max_Size loop - if Chunk.Next /= null then - - -- Release unused non-first empty chunk - - if Chunk.Prev /= null and then Chunk.First = Stack.Top then - To_Be_Released_Chunk := Chunk; - Chunk := Chunk.Prev; - Chunk.Next := To_Be_Released_Chunk.Next; - To_Be_Released_Chunk.Next.Prev := Chunk; - Free (To_Be_Released_Chunk); - end if; - - -- Create new chunk of default size unless it is not sufficient - -- to satisfy the current request. - - elsif SSE.Storage_Count (Max_Size) <= Stack.Default_Size then - Chunk.Next := - new Chunk_Id - (First => Chunk.Last + 1, - Last => Chunk.Last + SS_Ptr (Stack.Default_Size)); - - Chunk.Next.Prev := Chunk; - - -- Otherwise create new chunk of requested size - - else - Chunk.Next := - new Chunk_Id - (First => Chunk.Last + 1, - Last => Chunk.Last + Max_Size); - - Chunk.Next.Prev := Chunk; - end if; - - Chunk := Chunk.Next; - Stack.Top := Chunk.First; - end loop; - - -- Resulting address is the address pointed by Stack.Top - - Addr := Chunk.Mem (Stack.Top)'Address; - Stack.Top := Stack.Top + Max_Size; - Stack.Current_Chunk := Chunk; - end; - end if; - end SS_Allocate; - - ------------- - -- SS_Free -- - ------------- - - procedure SS_Free (Stk : in out Address) is - begin - -- Case of statically allocated secondary stack, nothing to free - - if not SS_Ratio_Dynamic then - return; - - -- Case of dynamically allocated secondary stack - - else - declare - Stack : Stack_Ptr := To_Stack_Ptr (Stk); - Chunk : Chunk_Ptr; - - procedure Free is - new Ada.Unchecked_Deallocation (Stack_Id, Stack_Ptr); - - begin - Chunk := Stack.Current_Chunk; - - while Chunk.Prev /= null loop - Chunk := Chunk.Prev; - end loop; - - while Chunk.Next /= null loop - Chunk := Chunk.Next; - Free (Chunk.Prev); - end loop; - - Free (Chunk); - Free (Stack); - Stk := Null_Address; - end; - end if; - end SS_Free; - - ---------------- - -- SS_Get_Max -- - ---------------- - - function SS_Get_Max return Long_Long_Integer is - begin - if SS_Ratio_Dynamic then - return -1; - else - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - begin - return Long_Long_Integer (Fixed_Stack.Max); - end; - end if; - end SS_Get_Max; - - ------------- - -- SS_Info -- - ------------- - - procedure SS_Info is - begin - Put_Line ("Secondary Stack information:"); - - -- Case of fixed secondary stack - - if not SS_Ratio_Dynamic then - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - - begin - Put_Line (" Total size : " - & SS_Ptr'Image (Fixed_Stack.Last) - & " bytes"); - - Put_Line (" Current allocated space : " - & SS_Ptr'Image (Fixed_Stack.Top) - & " bytes"); - end; - - -- Case of dynamically allocated secondary stack - - else - declare - Stack : constant Stack_Ptr := - To_Stack_Ptr (SSL.Get_Sec_Stack_Addr.all); - Nb_Chunks : Integer := 1; - Chunk : Chunk_Ptr := Stack.Current_Chunk; - - begin - while Chunk.Prev /= null loop - Chunk := Chunk.Prev; - end loop; - - while Chunk.Next /= null loop - Nb_Chunks := Nb_Chunks + 1; - Chunk := Chunk.Next; - end loop; - - -- Current Chunk information - - -- Note that First of each chunk is one more than Last of the - -- previous one, so Chunk.Last is the total size of all chunks; we - -- don't need to walk all the chunks to compute the total size. - - Put_Line (" Total size : " - & SS_Ptr'Image (Chunk.Last) - & " bytes"); - - Put_Line (" Current allocated space : " - & SS_Ptr'Image (Stack.Top - 1) - & " bytes"); - - Put_Line (" Number of Chunks : " - & Integer'Image (Nb_Chunks)); - - Put_Line (" Default size of Chunks : " - & SSE.Storage_Count'Image (Stack.Default_Size)); - end; - end if; - end SS_Info; - - ------------- - -- SS_Init -- - ------------- - - procedure SS_Init - (Stk : in out Address; - Size : Natural := Default_Secondary_Stack_Size) - is - begin - -- Case of fixed size secondary stack - - if not SS_Ratio_Dynamic then - declare - Fixed_Stack : constant Fixed_Stack_Ptr := - To_Fixed_Stack_Ptr (Stk); - - begin - Fixed_Stack.Top := 0; - Fixed_Stack.Max := 0; - - if Size <= Dummy_Fixed_Stack.Mem'Position then - Fixed_Stack.Last := 0; - else - Fixed_Stack.Last := - SS_Ptr (Size) - Dummy_Fixed_Stack.Mem'Position; - end if; - end; - - -- Case of dynamically allocated secondary stack - - else - declare - Stack : Stack_Ptr; - begin - Stack := new Stack_Id; - Stack.Current_Chunk := new Chunk_Id (1, SS_Ptr (Size)); - Stack.Top := 1; - Stack.Default_Size := SSE.Storage_Count (Size); - Stk := To_Addr (Stack); - end; - end if; - end SS_Init; - - ------------- - -- SS_Mark -- - ------------- - - function SS_Mark return Mark_Id is - Sstk : constant System.Address := SSL.Get_Sec_Stack_Addr.all; - begin - if SS_Ratio_Dynamic then - return (Sstk => Sstk, Sptr => To_Stack_Ptr (Sstk).Top); - else - return (Sstk => Sstk, Sptr => To_Fixed_Stack_Ptr (Sstk).Top); - end if; - end SS_Mark; - - ---------------- - -- SS_Release -- - ---------------- - - procedure SS_Release (M : Mark_Id) is - begin - if SS_Ratio_Dynamic then - To_Stack_Ptr (M.Sstk).Top := M.Sptr; - else - To_Fixed_Stack_Ptr (M.Sstk).Top := M.Sptr; - end if; - end SS_Release; - - ------------------------- - -- Package Elaboration -- - ------------------------- - - -- Allocate a secondary stack for the main program to use - - -- We make sure that the stack has maximum alignment. Some systems require - -- this (e.g. Sparc), and in any case it is a good idea for efficiency. - - Stack : aliased Stack_Id; - for Stack'Alignment use Standard'Maximum_Alignment; - - Static_Secondary_Stack_Size : constant := 10 * 1024; - -- Static_Secondary_Stack_Size must be static so that Chunk is allocated - -- statically, and not via dynamic memory allocation. - - Chunk : aliased Chunk_Id (1, Static_Secondary_Stack_Size); - for Chunk'Alignment use Standard'Maximum_Alignment; - -- Default chunk used, unless gnatbind -D is specified with a value greater - -- than Static_Secondary_Stack_Size. - -begin - declare - Chunk_Address : Address; - Chunk_Access : Chunk_Ptr; - - begin - if Default_Secondary_Stack_Size <= Static_Secondary_Stack_Size then - - -- Normally we allocate the secondary stack for the main program - -- statically, using the default secondary stack size. - - Chunk_Access := Chunk'Access; - - else - -- Default_Secondary_Stack_Size was increased via gnatbind -D, so we - -- need to allocate a chunk dynamically. - - Chunk_Access := - new Chunk_Id (1, SS_Ptr (Default_Secondary_Stack_Size)); - end if; - - if SS_Ratio_Dynamic then - Stack.Top := 1; - Stack.Current_Chunk := Chunk_Access; - Stack.Default_Size := - SSE.Storage_Offset (Default_Secondary_Stack_Size); - System.Soft_Links.Set_Sec_Stack_Addr_NT (Stack'Address); - - else - Chunk_Address := Chunk_Access.all'Address; - SS_Init (Chunk_Address, Default_Secondary_Stack_Size); - System.Soft_Links.Set_Sec_Stack_Addr_NT (Chunk_Address); - end if; - end; -end System.Secondary_Stack; diff --git a/gcc/ada/s-secsta.ads b/gcc/ada/s-secsta.ads deleted file mode 100644 index c5a0ead..0000000 --- a/gcc/ada/s-secsta.ads +++ /dev/null @@ -1,123 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S E C O N D A R Y _ S T A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with System.Storage_Elements; - -package System.Secondary_Stack is - - package SSE renames System.Storage_Elements; - - Default_Secondary_Stack_Size : Natural := 10 * 1024; - -- Default size of a secondary stack. May be modified by binder -D switch - -- which causes the binder to generate an appropriate assignment in the - -- binder generated file. - - function Minimum_Secondary_Stack_Size return Natural; - -- The minimum size of the secondary stack so that the internal - -- requirements of the stack are met. - - procedure SS_Init - (Stk : in out Address; - Size : Natural := Default_Secondary_Stack_Size); - -- Initialize the secondary stack with a main stack of the given Size. - -- - -- If System.Parameters.Sec_Stack_Percentage equals Dynamic, Stk is really - -- an OUT parameter that will be allocated on the heap. Then all further - -- allocations which do not overflow the main stack will not generate - -- dynamic (de)allocation calls. If the main Stack overflows, a new - -- chuck of at least the same size will be allocated and linked to the - -- previous chunk. - -- - -- Otherwise (Sec_Stack_Percentage between 0 and 100), Stk is an IN - -- parameter that is already pointing to a Stack_Id. The secondary stack - -- in this case is fixed, and any attempt to allocate more than the initial - -- size will result in a Storage_Error being raised. - -- - -- Note: the reason that Stk is passed is that SS_Init is called before - -- the proper interface is established to obtain the address of the - -- stack using System.Soft_Links.Get_Sec_Stack_Addr. - - procedure SS_Allocate - (Addr : out Address; - Storage_Size : SSE.Storage_Count); - -- Allocate enough space for a 'Storage_Size' bytes object with Maximum - -- alignment. The address of the allocated space is returned in Addr. - - procedure SS_Free (Stk : in out Address); - -- Release the memory allocated for the Secondary Stack. That is - -- to say, all the allocated chunks. Upon return, Stk will be set - -- to System.Null_Address. - - type Mark_Id is private; - -- Type used to mark the stack for mark/release processing - - function SS_Mark return Mark_Id; - -- Return the Mark corresponding to the current state of the stack - - procedure SS_Release (M : Mark_Id); - -- Restore the state of the stack corresponding to the mark M. If an - -- additional chunk have been allocated, it will never be freed during a - -- ??? missing comment here - - function SS_Get_Max return Long_Long_Integer; - -- Return maximum used space in storage units for the current secondary - -- stack. For a dynamically allocated secondary stack, the returned - -- result is always -1. For a statically allocated secondary stack, - -- the returned value shows the largest amount of space allocated so - -- far during execution of the program to the current secondary stack, - -- i.e. the secondary stack for the current task. - - generic - with procedure Put_Line (S : String); - procedure SS_Info; - -- Debugging procedure used to print out secondary Stack allocation - -- information. This procedure is generic in order to avoid a direct - -- dependance on a particular IO package. - -private - SS_Pool : Integer; - -- Unused entity that is just present to ease the sharing of the pool - -- mechanism for specific allocation/deallocation in the compiler - - type SS_Ptr is new SSE.Integer_Address; - -- Stack pointer value for secondary stack - - type Mark_Id is record - Sstk : System.Address; - Sptr : SS_Ptr; - end record; - -- A mark value contains the address of the secondary stack structure, - -- as returned by System.Soft_Links.Get_Sec_Stack_Addr, and a stack - -- pointer value corresponding to the point of the mark call. - -end System.Secondary_Stack; diff --git a/gcc/ada/s-sequio.adb b/gcc/ada/s-sequio.adb deleted file mode 100644 index e47c75f..0000000 --- a/gcc/ada/s-sequio.adb +++ /dev/null @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S E Q U E N T I A L _ I O -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.File_IO; -with Ada.Unchecked_Deallocation; - -package body System.Sequential_IO is - - subtype AP is FCB.AFCB_Ptr; - - package FIO renames System.File_IO; - - ------------------- - -- AFCB_Allocate -- - ------------------- - - function AFCB_Allocate - (Control_Block : Sequential_AFCB) return FCB.AFCB_Ptr - is - pragma Warnings (Off, Control_Block); - - begin - return new Sequential_AFCB; - end AFCB_Allocate; - - ---------------- - -- AFCB_Close -- - ---------------- - - -- No special processing required for Sequential_IO close - - procedure AFCB_Close (File : not null access Sequential_AFCB) is - pragma Warnings (Off, File); - - begin - null; - end AFCB_Close; - - --------------- - -- AFCB_Free -- - --------------- - - procedure AFCB_Free (File : not null access Sequential_AFCB) is - - type FCB_Ptr is access all Sequential_AFCB; - - FT : FCB_Ptr := FCB_Ptr (File); - - procedure Free is new - Ada.Unchecked_Deallocation (Sequential_AFCB, FCB_Ptr); - - begin - Free (FT); - end AFCB_Free; - - ------------ - -- Create -- - ------------ - - procedure Create - (File : in out File_Type; - Mode : FCB.File_Mode := FCB.Out_File; - Name : String := ""; - Form : String := "") - is - Dummy_File_Control_Block : Sequential_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => Mode, - Name => Name, - Form => Form, - Amethod => 'Q', - Creat => True, - Text => False); - end Create; - - ---------- - -- Open -- - ---------- - - procedure Open - (File : in out File_Type; - Mode : FCB.File_Mode; - Name : String; - Form : String := "") - is - Dummy_File_Control_Block : Sequential_AFCB; - pragma Warnings (Off, Dummy_File_Control_Block); - -- Yes, we know this is never assigned a value, only the tag - -- is used for dispatching purposes, so that's expected. - - begin - FIO.Open (File_Ptr => AP (File), - Dummy_FCB => Dummy_File_Control_Block, - Mode => Mode, - Name => Name, - Form => Form, - Amethod => 'Q', - Creat => False, - Text => False); - end Open; - - ---------- - -- Read -- - ---------- - - -- Not used, since Sequential_IO files are not used as streams - - procedure Read - (File : in out Sequential_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset) - is - begin - raise Program_Error; - end Read; - - ----------- - -- Write -- - ----------- - - -- Not used, since Sequential_IO files are not used as streams - - procedure Write - (File : in out Sequential_AFCB; - Item : Ada.Streams.Stream_Element_Array) - is - begin - raise Program_Error; - end Write; - -end System.Sequential_IO; diff --git a/gcc/ada/s-sequio.ads b/gcc/ada/s-sequio.ads deleted file mode 100644 index 5cbe3d9..0000000 --- a/gcc/ada/s-sequio.ads +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S E Q U E N T I A L _ I O -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the declaration of the control block used for --- Sequential_IO. This must be declared at the outer library level. It also --- contains code that is shared between instances of Sequential_IO. - -with System.File_Control_Block; -with Ada.Streams; - -package System.Sequential_IO is - - package FCB renames System.File_Control_Block; - - type Sequential_AFCB is new FCB.AFCB with null record; - -- No additional fields required for Sequential_IO - - function AFCB_Allocate - (Control_Block : Sequential_AFCB) return FCB.AFCB_Ptr; - - procedure AFCB_Close (File : not null access Sequential_AFCB); - procedure AFCB_Free (File : not null access Sequential_AFCB); - - procedure Read - (File : in out Sequential_AFCB; - Item : out Ada.Streams.Stream_Element_Array; - Last : out Ada.Streams.Stream_Element_Offset); - -- Required overriding of Read, not actually used for Sequential_IO - - procedure Write - (File : in out Sequential_AFCB; - Item : Ada.Streams.Stream_Element_Array); - -- Required overriding of Write, not actually used for Sequential_IO - - type File_Type is access all Sequential_AFCB; - -- File_Type in individual instantiations is derived from this type - - procedure Create - (File : in out File_Type; - Mode : FCB.File_Mode := FCB.Out_File; - Name : String := ""; - Form : String := ""); - - procedure Open - (File : in out File_Type; - Mode : FCB.File_Mode; - Name : String; - Form : String := ""); - -end System.Sequential_IO; diff --git a/gcc/ada/s-shasto.adb b/gcc/ada/s-shasto.adb deleted file mode 100644 index 38787cc..0000000 --- a/gcc/ada/s-shasto.adb +++ /dev/null @@ -1,588 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S H A R E D _ M E M O R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with Ada.Streams; -with Ada.Streams.Stream_IO; - -with System.Global_Locks; -with System.Soft_Links; - -with System; -with System.CRTL; -with System.File_Control_Block; -with System.File_IO; -with System.HTable; - -with Ada.Unchecked_Deallocation; -with Ada.Unchecked_Conversion; - -package body System.Shared_Storage is - - package AS renames Ada.Streams; - - package IOX renames Ada.IO_Exceptions; - - package FCB renames System.File_Control_Block; - - package SFI renames System.File_IO; - - package SIO renames Ada.Streams.Stream_IO; - - type String_Access is access String; - procedure Free is new Ada.Unchecked_Deallocation - (Object => String, Name => String_Access); - - Dir : String_Access; - -- Holds the directory - - ------------------------------------------------ - -- Variables for Shared Variable Access Files -- - ------------------------------------------------ - - Max_Shared_Var_Files : constant := 20; - -- Maximum number of lock files that can be open - - Shared_Var_Files_Open : Natural := 0; - -- Number of shared variable access files currently open - - type File_Stream_Type is new AS.Root_Stream_Type with record - File : SIO.File_Type; - end record; - type File_Stream_Access is access all File_Stream_Type'Class; - - procedure Read - (Stream : in out File_Stream_Type; - Item : out AS.Stream_Element_Array; - Last : out AS.Stream_Element_Offset); - - procedure Write - (Stream : in out File_Stream_Type; - Item : AS.Stream_Element_Array); - - subtype Hash_Header is Natural range 0 .. 30; - -- Number of hash headers, related (for efficiency purposes only) to the - -- maximum number of lock files. - - type Shared_Var_File_Entry; - type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; - - type Shared_Var_File_Entry is record - Name : String_Access; - -- Name of variable, as passed to Read_File/Write_File routines - - Stream : File_Stream_Access; - -- Stream_IO file for the shared variable file - - Next : Shared_Var_File_Entry_Ptr; - Prev : Shared_Var_File_Entry_Ptr; - -- Links for LRU chain - end record; - - procedure Free is new Ada.Unchecked_Deallocation - (Object => Shared_Var_File_Entry, - Name => Shared_Var_File_Entry_Ptr); - - procedure Free is new Ada.Unchecked_Deallocation - (Object => File_Stream_Type'Class, - Name => File_Stream_Access); - - function To_AFCB_Ptr is - new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr); - - LRU_Head : Shared_Var_File_Entry_Ptr; - LRU_Tail : Shared_Var_File_Entry_Ptr; - -- As lock files are opened, they are organized into a least recently - -- used chain, which is a doubly linked list using the Next and Prev - -- fields of Shared_Var_File_Entry records. The field LRU_Head points - -- to the least recently used entry, whose prev pointer is null, and - -- LRU_Tail points to the most recently used entry, whose next pointer - -- is null. These pointers are null only if the list is empty. - - function Hash (F : String_Access) return Hash_Header; - function Equal (F1, F2 : String_Access) return Boolean; - -- Hash and equality functions for hash table - - package SFT is new System.HTable.Simple_HTable - (Header_Num => Hash_Header, - Element => Shared_Var_File_Entry_Ptr, - No_Element => null, - Key => String_Access, - Hash => Hash, - Equal => Equal); - - -------------------------------- - -- Variables for Lock Control -- - -------------------------------- - - Global_Lock : Global_Locks.Lock_Type; - - Lock_Count : Natural := 0; - -- Counts nesting of lock calls, 0 means lock is not held - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Initialize; - -- Called to initialize data structures for this package. - -- Has no effect except on the first call. - - procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String); - -- The first parameter is a pointer to a newly allocated SFE, whose - -- File field is already set appropriately. Fname is the name of the - -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE - -- completes the SFE value, and enters it into the hash table. If the - -- hash table is already full, the least recently used entry is first - -- closed and discarded. - - function Retrieve (File : String) return Shared_Var_File_Entry_Ptr; - -- Given a file name, this function searches the hash table to see if - -- the file is currently open. If so, then a pointer to the already - -- created entry is returned, after first moving it to the head of - -- the LRU chain. If not, then null is returned. - - function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; - -- As described above, this routine returns null if the - -- corresponding shared storage does not exist, and otherwise, if - -- the storage does exist, a Stream_Access value that references - -- the shared storage, ready to read the current value. - - function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; - -- As described above, this routine returns a Stream_Access value - -- that references the shared storage, ready to write the new - -- value. The storage is created by this call if it does not - -- already exist. - - procedure Shared_Var_Close (Var : SIO.Stream_Access); - -- This routine signals the end of a read/assign operation. It can - -- be useful to embrace a read/write operation between a call to - -- open and a call to close which protect the whole operation. - -- Otherwise, two simultaneous operations can result in the - -- raising of exception Data_Error by setting the access mode of - -- the variable in an incorrect mode. - - --------------- - -- Enter_SFE -- - --------------- - - procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is - Freed : Shared_Var_File_Entry_Ptr; - - begin - SFE.Name := new String'(Fname); - - -- Release least recently used entry if we have to - - if Shared_Var_Files_Open = Max_Shared_Var_Files then - Freed := LRU_Head; - - if Freed.Next /= null then - Freed.Next.Prev := null; - end if; - - LRU_Head := Freed.Next; - SFT.Remove (Freed.Name); - SIO.Close (Freed.Stream.File); - Free (Freed.Name); - Free (Freed.Stream); - Free (Freed); - - else - Shared_Var_Files_Open := Shared_Var_Files_Open + 1; - end if; - - -- Add new entry to hash table - - SFT.Set (SFE.Name, SFE); - - -- Add new entry at end of LRU chain - - if LRU_Head = null then - LRU_Head := SFE; - LRU_Tail := SFE; - - else - SFE.Prev := LRU_Tail; - LRU_Tail.Next := SFE; - LRU_Tail := SFE; - end if; - end Enter_SFE; - - ----------- - -- Equal -- - ----------- - - function Equal (F1, F2 : String_Access) return Boolean is - begin - return F1.all = F2.all; - end Equal; - - ---------- - -- Hash -- - ---------- - - function Hash (F : String_Access) return Hash_Header is - N : Natural := 0; - - begin - -- Add up characters of name, mod our table size - - for J in F'Range loop - N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); - end loop; - - return N; - end Hash; - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize is - procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); - pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); - - subtype size_t is CRTL.size_t; - - procedure Strncpy (dest, src : System.Address; n : size_t) - renames CRTL.strncpy; - - Dir_Name : aliased constant String := - "SHARED_MEMORY_DIRECTORY" & ASCII.NUL; - - Env_Value_Ptr : aliased Address; - Env_Value_Len : aliased Integer; - - begin - if Dir = null then - Get_Env_Value_Ptr - (Dir_Name'Address, Env_Value_Len'Address, Env_Value_Ptr'Address); - - Dir := new String (1 .. Env_Value_Len); - - if Env_Value_Len > 0 then - Strncpy (Dir.all'Address, Env_Value_Ptr, size_t (Env_Value_Len)); - end if; - - System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock"); - end if; - end Initialize; - - ---------- - -- Read -- - ---------- - - procedure Read - (Stream : in out File_Stream_Type; - Item : out AS.Stream_Element_Array; - Last : out AS.Stream_Element_Offset) - is - begin - SIO.Read (Stream.File, Item, Last); - - exception when others => - Last := Item'Last; - end Read; - - -------------- - -- Retrieve -- - -------------- - - function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is - SFE : Shared_Var_File_Entry_Ptr; - - begin - Initialize; - SFE := SFT.Get (File'Unrestricted_Access); - - if SFE /= null then - - -- Move to head of LRU chain - - if SFE = LRU_Tail then - null; - - elsif SFE = LRU_Head then - LRU_Head := LRU_Head.Next; - LRU_Head.Prev := null; - - else - SFE.Next.Prev := SFE.Prev; - SFE.Prev.Next := SFE.Next; - end if; - - SFE.Next := null; - SFE.Prev := LRU_Tail; - LRU_Tail.Next := SFE; - LRU_Tail := SFE; - end if; - - return SFE; - end Retrieve; - - ---------------------- - -- Shared_Var_Close -- - ---------------------- - - procedure Shared_Var_Close (Var : SIO.Stream_Access) is - pragma Warnings (Off, Var); - - begin - System.Soft_Links.Unlock_Task.all; - end Shared_Var_Close; - - --------------------- - -- Shared_Var_Lock -- - --------------------- - - procedure Shared_Var_Lock (Var : String) is - pragma Warnings (Off, Var); - - begin - System.Soft_Links.Lock_Task.all; - Initialize; - - if Lock_Count /= 0 then - Lock_Count := Lock_Count + 1; - System.Soft_Links.Unlock_Task.all; - - else - Lock_Count := 1; - System.Soft_Links.Unlock_Task.all; - System.Global_Locks.Acquire_Lock (Global_Lock); - end if; - - exception - when others => - System.Soft_Links.Unlock_Task.all; - raise; - end Shared_Var_Lock; - - ---------------------- - -- Shared_Var_Procs -- - ---------------------- - - package body Shared_Var_Procs is - - use type SIO.Stream_Access; - - ---------- - -- Read -- - ---------- - - procedure Read is - S : SIO.Stream_Access := null; - begin - S := Shared_Var_ROpen (Full_Name); - if S /= null then - Typ'Read (S, V); - Shared_Var_Close (S); - end if; - end Read; - - ------------ - -- Write -- - ------------ - - procedure Write is - S : SIO.Stream_Access := null; - begin - S := Shared_Var_WOpen (Full_Name); - Typ'Write (S, V); - Shared_Var_Close (S); - return; - end Write; - - end Shared_Var_Procs; - - ---------------------- - -- Shared_Var_ROpen -- - ---------------------- - - function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is - SFE : Shared_Var_File_Entry_Ptr; - - use type Ada.Streams.Stream_IO.File_Mode; - - begin - System.Soft_Links.Lock_Task.all; - SFE := Retrieve (Var); - - -- Here if file is not already open, try to open it - - if SFE = null then - declare - S : aliased constant String := Dir.all & Var; - - begin - SFE := new Shared_Var_File_Entry; - SFE.Stream := new File_Stream_Type; - SIO.Open (SFE.Stream.File, SIO.In_File, Name => S); - SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); - - -- File opened successfully, put new entry in hash table. Note - -- that in this case, file is positioned correctly for read. - - Enter_SFE (SFE, Var); - - exception - -- If we get an exception, it means that the file does not - -- exist, and in this case, we don't need the SFE and we - -- return null; - - when IOX.Name_Error => - Free (SFE); - System.Soft_Links.Unlock_Task.all; - return null; - end; - - -- Here if file is already open, set file for reading - - else - if SIO.Mode (SFE.Stream.File) /= SIO.In_File then - SIO.Set_Mode (SFE.Stream.File, SIO.In_File); - SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); - end if; - - SIO.Set_Index (SFE.Stream.File, 1); - end if; - - return SIO.Stream_Access (SFE.Stream); - - exception - when others => - System.Soft_Links.Unlock_Task.all; - raise; - end Shared_Var_ROpen; - - ----------------------- - -- Shared_Var_Unlock -- - ----------------------- - - procedure Shared_Var_Unlock (Var : String) is - pragma Warnings (Off, Var); - - begin - System.Soft_Links.Lock_Task.all; - Initialize; - Lock_Count := Lock_Count - 1; - - if Lock_Count = 0 then - System.Global_Locks.Release_Lock (Global_Lock); - end if; - System.Soft_Links.Unlock_Task.all; - - exception - when others => - System.Soft_Links.Unlock_Task.all; - raise; - end Shared_Var_Unlock; - - --------------------- - -- Share_Var_WOpen -- - --------------------- - - function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is - SFE : Shared_Var_File_Entry_Ptr; - - use type Ada.Streams.Stream_IO.File_Mode; - - begin - System.Soft_Links.Lock_Task.all; - SFE := Retrieve (Var); - - if SFE = null then - declare - S : aliased constant String := Dir.all & Var; - - begin - SFE := new Shared_Var_File_Entry; - SFE.Stream := new File_Stream_Type; - SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S); - SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); - - exception - -- If we get an exception, it means that the file does not - -- exist, and in this case, we create the file. - - when IOX.Name_Error => - - begin - SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S); - - exception - -- Error if we cannot create the file - - when others => - raise Program_Error with - "cannot create shared variable file for """ & S & '"'; - end; - end; - - -- Make new hash table entry for opened/created file. Note that - -- in both cases, the file is already in write mode at the start - -- of the file, ready to be written. - - Enter_SFE (SFE, Var); - - -- Here if file is already open, set file for writing - - else - if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then - SIO.Set_Mode (SFE.Stream.File, SIO.Out_File); - SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); - end if; - - SIO.Set_Index (SFE.Stream.File, 1); - end if; - - return SIO.Stream_Access (SFE.Stream); - - exception - when others => - System.Soft_Links.Unlock_Task.all; - raise; - end Shared_Var_WOpen; - - ----------- - -- Write -- - ----------- - - procedure Write - (Stream : in out File_Stream_Type; - Item : AS.Stream_Element_Array) - is - begin - SIO.Write (Stream.File, Item); - end Write; - -end System.Shared_Storage; diff --git a/gcc/ada/s-shasto.ads b/gcc/ada/s-shasto.ads deleted file mode 100644 index 51e49e8..0000000 --- a/gcc/ada/s-shasto.ads +++ /dev/null @@ -1,179 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S H A R E D _ S T O R A G E -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package manages the shared/persistent storage required for --- full implementation of variables in Shared_Passive packages, more --- precisely variables whose enclosing dynamic scope is a shared --- passive package. This implementation is specific to GNAT and GLADE --- provides a more general implementation not dedicated to file --- storage. - --- -------------------------- --- -- Shared Storage Model -- --- -------------------------- - --- The basic model used is that each partition that references the --- Shared_Passive package has a local copy of the package data that --- is initialized in accordance with the declarations of the package --- in the normal manner. The routines in System.Shared_Storage are --- then used to ensure that the values in these separate copies are --- properly synchronized with the state of the overall system. - --- In the GNAT implementation, this synchronization is ensured by --- maintaining a set of files, in a designated directory. The --- directory is designated by setting the environment variable --- SHARED_MEMORY_DIRECTORY. This variable must be set for all --- partitions. If the environment variable is not defined, then the --- current directory is used. - --- There is one storage for each variable. The name is the fully --- qualified name of the variable with all letters forced to lower --- case. For example, the variable Var in the shared passive package --- Pkg results in the storage name pkg.var. - --- If the storage does not exist, it indicates that no partition has --- assigned a new value, so that the initial value is the correct --- one. This is the critical component of the model. It means that --- there is no system-wide synchronization required for initializing --- the package, since the shared storages need not (and do not) --- reflect the initial state. There is therefore no issue of --- synchronizing initialization and read/write access. - --- ----------------------- --- -- Read/Write Access -- --- ----------------------- - --- The approach is as follows: - --- For each shared variable, var, an instantiation of the below generic --- package is created which provides Read and Write supporting procedures. - --- The routine Read in package System.Shared_Storage.Shared_Var_Procs --- ensures to assign variable V to the last written value among processes --- referencing it. A call to this procedure is generated by the expander --- before each read access to the shared variable. - --- The routine Write in package System.Shared_Storage.Shared_Var_Proc --- set a new value to the shared variable and, according to the used --- implementation, propagate this value among processes referencing it. --- A call to this procedure is generated by the expander after each --- assignment of the shared variable. - --- Note: a special circuit allows the use of stream attributes Read and --- Write for limited types (using the corresponding attribute for the --- full type), but there are limitations on the data that can be placed --- in shared passive partitions. See sem_smem.ads/adb for details. - --- ---------------------------------------------------------------- --- -- Handling of Protected Objects in Shared Passive Partitions -- --- ---------------------------------------------------------------- - --- In the context of GNAT, during the execution of a protected --- subprogram call, access is locked out using a locking mechanism --- per protected object, as provided by the GNAT.Lock_Files --- capability in the specific case of GNAT. This package contains the --- lock and unlock calls, and the expander generates a call to the --- lock routine before the protected call and a call to the unlock --- routine after the protected call. - --- Within the code of the protected subprogram, the access to the --- protected object itself uses the local copy, without any special --- synchronization. Since global access is locked out, no other task --- or partition can attempt to read or write this data as long as the --- lock is held. - --- The data in the local copy does however need synchronizing with --- the global values in the shared storage. This is achieved as --- follows: - --- The protected object generates a read and assignment routine as --- described for other shared passive variables. The code for the --- 'Read and 'Write attributes (not normally allowed, but allowed --- in this special case) simply reads or writes the values of the --- components in the protected record. - --- The lock call is followed by a call to the shared read routine to --- synchronize the local copy to contain the proper global value. - --- The unlock call in the procedure case only is preceded by a call --- to the shared assign routine to synchronize the global shared --- storages with the (possibly modified) local copy. - --- These calls to the read and assign routines, as well as the lock --- and unlock routines, are inserted by the expander (see exp_smem.adb). - -package System.Shared_Storage is - - procedure Shared_Var_Lock (Var : String); - -- This procedure claims the shared storage lock. It is used for - -- protected types in shared passive packages. A call to this - -- locking routine is generated as the first operation in the code - -- for the body of a protected subprogram, and it busy waits if - -- the lock is busy. - - procedure Shared_Var_Unlock (Var : String); - -- This procedure releases the shared storage lock obtained by a - -- prior call to the Shared_Var_Lock procedure, and is to be - -- generated as the last operation in the body of a protected - -- subprogram. - - -- This generic package is instantiated for each shared passive - -- variable. It provides supporting procedures called upon each - -- read or write access by the expanded code. - - generic - - type Typ is limited private; - -- Shared passive variable type - - V : in out Typ; - -- Shared passive variable - - Full_Name : String; - -- Shared passive variable storage name - - package Shared_Var_Procs is - - procedure Read; - -- Shared passive variable access routine. Each reference to the - -- shared variable, V, is preceded by a call to the corresponding - -- Read procedure, which either leaves the initial value unchanged - -- if the storage does not exist, or reads the current value from - -- the shared storage. - - procedure Write; - -- Shared passive variable assignment routine. Each assignment to - -- the shared variable, V, is followed by a call to the corresponding - -- Write procedure, which writes the new value to the shared storage. - - end Shared_Var_Procs; - -end System.Shared_Storage; diff --git a/gcc/ada/s-soflin.adb b/gcc/ada/s-soflin.adb deleted file mode 100644 index d1c10a0..0000000 --- a/gcc/ada/s-soflin.adb +++ /dev/null @@ -1,312 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S O F T _ L I N K S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get an --- infinite loop from the code within the Poll routine itself. - -with System.Parameters; - -pragma Warnings (Off); --- Disable warnings since System.Secondary_Stack is currently not Preelaborate -with System.Secondary_Stack; -pragma Warnings (On); - -package body System.Soft_Links is - - package SST renames System.Secondary_Stack; - - NT_TSD : TSD; - -- Note: we rely on the default initialization of NT_TSD - - -- Needed for Vx6Cert (Vx653mc) GOS cert and ravenscar-cert runtimes, - -- VxMILS cert, ravenscar-cert and full runtimes, Vx 5 default runtime - Stack_Limit : aliased System.Address := System.Null_Address; - - pragma Export (C, Stack_Limit, "__gnat_stack_limit"); - - -------------------- - -- Abort_Defer_NT -- - -------------------- - - procedure Abort_Defer_NT is - begin - null; - end Abort_Defer_NT; - - ---------------------- - -- Abort_Handler_NT -- - ---------------------- - - procedure Abort_Handler_NT is - begin - null; - end Abort_Handler_NT; - - ---------------------- - -- Abort_Undefer_NT -- - ---------------------- - - procedure Abort_Undefer_NT is - begin - null; - end Abort_Undefer_NT; - - ----------------- - -- Adafinal_NT -- - ----------------- - - procedure Adafinal_NT is - begin - -- Handle normal task termination by the environment task, but only - -- for the normal task termination. In the case of Abnormal and - -- Unhandled_Exception they must have been handled before, and the - -- task termination soft link must have been changed so the task - -- termination routine is not executed twice. - - Task_Termination_Handler.all (Ada.Exceptions.Null_Occurrence); - - -- Finalize all library-level controlled objects if needed - - if Finalize_Library_Objects /= null then - Finalize_Library_Objects.all; - end if; - end Adafinal_NT; - - --------------------------- - -- Check_Abort_Status_NT -- - --------------------------- - - function Check_Abort_Status_NT return Integer is - begin - return Boolean'Pos (False); - end Check_Abort_Status_NT; - - ------------------------ - -- Complete_Master_NT -- - ------------------------ - - procedure Complete_Master_NT is - begin - null; - end Complete_Master_NT; - - ---------------- - -- Create_TSD -- - ---------------- - - procedure Create_TSD (New_TSD : in out TSD) is - use Parameters; - SS_Ratio_Dynamic : constant Boolean := Sec_Stack_Percentage = Dynamic; - begin - if SS_Ratio_Dynamic then - SST.SS_Init - (New_TSD.Sec_Stack_Addr, SST.Default_Secondary_Stack_Size); - end if; - end Create_TSD; - - ----------------------- - -- Current_Master_NT -- - ----------------------- - - function Current_Master_NT return Integer is - begin - return 0; - end Current_Master_NT; - - ----------------- - -- Destroy_TSD -- - ----------------- - - procedure Destroy_TSD (Old_TSD : in out TSD) is - begin - SST.SS_Free (Old_TSD.Sec_Stack_Addr); - end Destroy_TSD; - - --------------------- - -- Enter_Master_NT -- - --------------------- - - procedure Enter_Master_NT is - begin - null; - end Enter_Master_NT; - - -------------------------- - -- Get_Current_Excep_NT -- - -------------------------- - - function Get_Current_Excep_NT return EOA is - begin - return NT_TSD.Current_Excep'Access; - end Get_Current_Excep_NT; - - ------------------------ - -- Get_GNAT_Exception -- - ------------------------ - - function Get_GNAT_Exception return Ada.Exceptions.Exception_Id is - begin - return Ada.Exceptions.Exception_Identity (Get_Current_Excep.all.all); - end Get_GNAT_Exception; - - --------------------------- - -- Get_Jmpbuf_Address_NT -- - --------------------------- - - function Get_Jmpbuf_Address_NT return Address is - begin - return NT_TSD.Jmpbuf_Address; - end Get_Jmpbuf_Address_NT; - - ----------------------------- - -- Get_Jmpbuf_Address_Soft -- - ----------------------------- - - function Get_Jmpbuf_Address_Soft return Address is - begin - return Get_Jmpbuf_Address.all; - end Get_Jmpbuf_Address_Soft; - - --------------------------- - -- Get_Sec_Stack_Addr_NT -- - --------------------------- - - function Get_Sec_Stack_Addr_NT return Address is - begin - return NT_TSD.Sec_Stack_Addr; - end Get_Sec_Stack_Addr_NT; - - ----------------------------- - -- Get_Sec_Stack_Addr_Soft -- - ----------------------------- - - function Get_Sec_Stack_Addr_Soft return Address is - begin - return Get_Sec_Stack_Addr.all; - end Get_Sec_Stack_Addr_Soft; - - ----------------------- - -- Get_Stack_Info_NT -- - ----------------------- - - function Get_Stack_Info_NT return Stack_Checking.Stack_Access is - begin - return NT_TSD.Pri_Stack_Info'Access; - end Get_Stack_Info_NT; - - ----------------------------- - -- Save_Library_Occurrence -- - ----------------------------- - - procedure Save_Library_Occurrence (E : EOA) is - use Ada.Exceptions; - begin - if not Library_Exception_Set then - Library_Exception_Set := True; - if E /= null then - Ada.Exceptions.Save_Occurrence (Library_Exception, E.all); - end if; - end if; - end Save_Library_Occurrence; - - --------------------------- - -- Set_Jmpbuf_Address_NT -- - --------------------------- - - procedure Set_Jmpbuf_Address_NT (Addr : Address) is - begin - NT_TSD.Jmpbuf_Address := Addr; - end Set_Jmpbuf_Address_NT; - - procedure Set_Jmpbuf_Address_Soft (Addr : Address) is - begin - Set_Jmpbuf_Address (Addr); - end Set_Jmpbuf_Address_Soft; - - --------------------------- - -- Set_Sec_Stack_Addr_NT -- - --------------------------- - - procedure Set_Sec_Stack_Addr_NT (Addr : Address) is - begin - NT_TSD.Sec_Stack_Addr := Addr; - end Set_Sec_Stack_Addr_NT; - - ----------------------------- - -- Set_Sec_Stack_Addr_Soft -- - ----------------------------- - - procedure Set_Sec_Stack_Addr_Soft (Addr : Address) is - begin - Set_Sec_Stack_Addr (Addr); - end Set_Sec_Stack_Addr_Soft; - - ------------------ - -- Task_Lock_NT -- - ------------------ - - procedure Task_Lock_NT is - begin - null; - end Task_Lock_NT; - - ------------------ - -- Task_Name_NT -- - ------------------- - - function Task_Name_NT return String is - begin - return "main_task"; - end Task_Name_NT; - - ------------------------- - -- Task_Termination_NT -- - ------------------------- - - procedure Task_Termination_NT (Excep : EO) is - pragma Unreferenced (Excep); - begin - null; - end Task_Termination_NT; - - -------------------- - -- Task_Unlock_NT -- - -------------------- - - procedure Task_Unlock_NT is - begin - null; - end Task_Unlock_NT; - -end System.Soft_Links; diff --git a/gcc/ada/s-soflin.ads b/gcc/ada/s-soflin.ads deleted file mode 100644 index 35dc962..0000000 --- a/gcc/ada/s-soflin.ads +++ /dev/null @@ -1,399 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S O F T _ L I N K S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains a set of subprogram access variables that access --- some low-level primitives that are different depending whether tasking is --- involved or not (e.g. the Get/Set_Jmpbuf_Address that needs to provide a --- different value for each task). To avoid dragging in the tasking runtimes --- all the time, we use a system of soft links where the links are --- initialized to non-tasking versions, and then if the tasking support is --- initialized, they are set to the real tasking versions. - -pragma Compiler_Unit_Warning; - -with Ada.Exceptions; -with System.Stack_Checking; - -package System.Soft_Links is - pragma Preelaborate; - - subtype EOA is Ada.Exceptions.Exception_Occurrence_Access; - subtype EO is Ada.Exceptions.Exception_Occurrence; - - function Current_Target_Exception return EO; - pragma Import - (Ada, Current_Target_Exception, "__gnat_current_target_exception"); - -- Import this subprogram from the private part of Ada.Exceptions - - -- First we have the access subprogram types used to establish the links. - -- The approach is to establish variables containing access subprogram - -- values, which by default point to dummy no tasking versions of routines. - - type No_Param_Proc is access procedure; - pragma Favor_Top_Level (No_Param_Proc); - pragma Suppress_Initialization (No_Param_Proc); - -- Some uninitialized objects of that type are initialized by the Binder - -- so it is important that such objects are not reset to null during - -- elaboration. - - type Addr_Param_Proc is access procedure (Addr : Address); - pragma Favor_Top_Level (Addr_Param_Proc); - type EO_Param_Proc is access procedure (Excep : EO); - pragma Favor_Top_Level (EO_Param_Proc); - - type Get_Address_Call is access function return Address; - pragma Favor_Top_Level (Get_Address_Call); - type Set_Address_Call is access procedure (Addr : Address); - pragma Favor_Top_Level (Set_Address_Call); - type Set_Address_Call2 is access procedure - (Self_ID : Address; Addr : Address); - pragma Favor_Top_Level (Set_Address_Call2); - - type Get_Integer_Call is access function return Integer; - pragma Favor_Top_Level (Get_Integer_Call); - type Set_Integer_Call is access procedure (Len : Integer); - pragma Favor_Top_Level (Set_Integer_Call); - - type Get_EOA_Call is access function return EOA; - pragma Favor_Top_Level (Get_EOA_Call); - type Set_EOA_Call is access procedure (Excep : EOA); - pragma Favor_Top_Level (Set_EOA_Call); - type Set_EO_Call is access procedure (Excep : EO); - pragma Favor_Top_Level (Set_EO_Call); - - type Special_EO_Call is access - procedure (Excep : EO := Current_Target_Exception); - pragma Favor_Top_Level (Special_EO_Call); - - type Timed_Delay_Call is access - procedure (Time : Duration; Mode : Integer); - pragma Favor_Top_Level (Timed_Delay_Call); - - type Get_Stack_Access_Call is access - function return Stack_Checking.Stack_Access; - pragma Favor_Top_Level (Get_Stack_Access_Call); - - type Task_Name_Call is access - function return String; - pragma Favor_Top_Level (Task_Name_Call); - - -- Suppress checks on all these types, since we know the corresponding - -- values can never be null (the soft links are always initialized). - - pragma Suppress (Access_Check, No_Param_Proc); - pragma Suppress (Access_Check, Addr_Param_Proc); - pragma Suppress (Access_Check, EO_Param_Proc); - pragma Suppress (Access_Check, Get_Address_Call); - pragma Suppress (Access_Check, Set_Address_Call); - pragma Suppress (Access_Check, Set_Address_Call2); - pragma Suppress (Access_Check, Get_Integer_Call); - pragma Suppress (Access_Check, Set_Integer_Call); - pragma Suppress (Access_Check, Get_EOA_Call); - pragma Suppress (Access_Check, Set_EOA_Call); - pragma Suppress (Access_Check, Timed_Delay_Call); - pragma Suppress (Access_Check, Get_Stack_Access_Call); - pragma Suppress (Access_Check, Task_Name_Call); - - -- The following one is not related to tasking/no-tasking but to the - -- traceback decorators for exceptions. - - type Traceback_Decorator_Wrapper_Call is access - function (Traceback : System.Address; - Len : Natural) - return String; - pragma Favor_Top_Level (Traceback_Decorator_Wrapper_Call); - - -- Declarations for the no tasking versions of the required routines - - procedure Abort_Defer_NT; - -- Defer task abort (non-tasking case, does nothing) - - procedure Abort_Undefer_NT; - -- Undefer task abort (non-tasking case, does nothing) - - procedure Abort_Handler_NT; - -- Handle task abort (non-tasking case, does nothing). Currently, no port - -- makes use of this, but we retain the interface for possible future use. - - function Check_Abort_Status_NT return Integer; - -- Returns Boolean'Pos (True) iff abort signal should raise - -- Standard'Abort_Signal. - - procedure Task_Lock_NT; - -- Lock out other tasks (non-tasking case, does nothing) - - procedure Task_Unlock_NT; - -- Release lock set by Task_Lock (non-tasking case, does nothing) - - procedure Task_Termination_NT (Excep : EO); - -- Handle task termination routines for the environment task (non-tasking - -- case, does nothing). - - procedure Adafinal_NT; - -- Shuts down the runtime system (non-tasking case) - - Abort_Defer : No_Param_Proc := Abort_Defer_NT'Access; - pragma Suppress (Access_Check, Abort_Defer); - -- Defer task abort (task/non-task case as appropriate) - - Abort_Undefer : No_Param_Proc := Abort_Undefer_NT'Access; - pragma Suppress (Access_Check, Abort_Undefer); - -- Undefer task abort (task/non-task case as appropriate) - - Abort_Handler : No_Param_Proc := Abort_Handler_NT'Access; - -- Handle task abort (task/non-task case as appropriate) - - Check_Abort_Status : Get_Integer_Call := Check_Abort_Status_NT'Access; - -- Called when Abort_Signal is delivered to the process. Checks to - -- see if signal should result in raising Standard'Abort_Signal. - - Lock_Task : No_Param_Proc := Task_Lock_NT'Access; - -- Locks out other tasks. Preceding a section of code by Task_Lock and - -- following it by Task_Unlock creates a critical region. This is used - -- for ensuring that a region of non-tasking code (such as code used to - -- allocate memory) is tasking safe. Note that it is valid for calls to - -- Task_Lock/Task_Unlock to be nested, and this must work properly, i.e. - -- only the corresponding outer level Task_Unlock will actually unlock. - -- This routine also prevents against asynchronous aborts (abort is - -- deferred). - - Unlock_Task : No_Param_Proc := Task_Unlock_NT'Access; - -- Releases lock previously set by call to Lock_Task. In the nested case, - -- all nested locks must be released before other tasks competing for the - -- tasking lock are released. - -- - -- In the non nested case, this routine terminates the protection against - -- asynchronous aborts introduced by Lock_Task (unless abort was already - -- deferred before the call to Lock_Task (e.g in a protected procedures). - -- - -- Note: the recommended protocol for using Lock_Task and Unlock_Task - -- is as follows: - -- - -- Locked_Processing : begin - -- System.Soft_Links.Lock_Task.all; - -- ... - -- System.Soft_Links.Unlock_Task.all; - -- - -- exception - -- when others => - -- System.Soft_Links.Unlock_Task.all; - -- raise; - -- end Locked_Processing; - -- - -- This ensures that the lock is not left set if an exception is raised - -- explicitly or implicitly during the critical locked region. - - Task_Termination_Handler : EO_Param_Proc := Task_Termination_NT'Access; - -- Handle task termination routines (task/non-task case as appropriate) - - Finalize_Library_Objects : No_Param_Proc; - pragma Export (C, Finalize_Library_Objects, - "__gnat_finalize_library_objects"); - -- Will be initialized by the binder - - Adafinal : No_Param_Proc := Adafinal_NT'Access; - -- Performs the finalization of the Ada Runtime - - function Get_Jmpbuf_Address_NT return Address; - procedure Set_Jmpbuf_Address_NT (Addr : Address); - - Get_Jmpbuf_Address : Get_Address_Call := Get_Jmpbuf_Address_NT'Access; - Set_Jmpbuf_Address : Set_Address_Call := Set_Jmpbuf_Address_NT'Access; - - function Get_Sec_Stack_Addr_NT return Address; - procedure Set_Sec_Stack_Addr_NT (Addr : Address); - - Get_Sec_Stack_Addr : Get_Address_Call := Get_Sec_Stack_Addr_NT'Access; - Set_Sec_Stack_Addr : Set_Address_Call := Set_Sec_Stack_Addr_NT'Access; - - function Get_Current_Excep_NT return EOA; - - Get_Current_Excep : Get_EOA_Call := Get_Current_Excep_NT'Access; - - function Get_Stack_Info_NT return Stack_Checking.Stack_Access; - - Get_Stack_Info : Get_Stack_Access_Call := Get_Stack_Info_NT'Access; - - -------------------------- - -- Master_Id Soft-Links -- - -------------------------- - - -- Soft-Links are used for procedures that manipulate Master_Ids because - -- a Master_Id must be generated for access to limited class-wide types, - -- whose root may be extended with task components. - - function Current_Master_NT return Integer; - procedure Enter_Master_NT; - procedure Complete_Master_NT; - - Current_Master : Get_Integer_Call := Current_Master_NT'Access; - Enter_Master : No_Param_Proc := Enter_Master_NT'Access; - Complete_Master : No_Param_Proc := Complete_Master_NT'Access; - - ---------------------- - -- Delay Soft-Links -- - ---------------------- - - -- Soft-Links are used for procedures that manipulate time to avoid - -- dragging the tasking run time when using delay statements. - - Timed_Delay : Timed_Delay_Call; - - -------------------------- - -- Task Name Soft-Links -- - -------------------------- - - function Task_Name_NT return String; - - Task_Name : Task_Name_Call := Task_Name_NT'Access; - - ------------------------------------- - -- Exception Tracebacks Soft-Links -- - ------------------------------------- - - Library_Exception : EO; - -- Library-level finalization routines use this common reference to store - -- the first library-level exception which occurs during finalization. - - Library_Exception_Set : Boolean := False; - -- Used in conjunction with Library_Exception, set when an exception has - -- been stored. - - Traceback_Decorator_Wrapper : Traceback_Decorator_Wrapper_Call; - -- Wrapper to the possible user specified traceback decorator to be - -- called during automatic output of exception data. - - -- The null value of this wrapper correspond sto the null value of the - -- current actual decorator. This is ensured first by the null initial - -- value of the corresponding variables, and then by Set_Trace_Decorator - -- in g-exctra.adb. - - pragma Atomic (Traceback_Decorator_Wrapper); - -- Since concurrent read/write operations may occur on this variable. - -- See the body of Tailored_Exception_Traceback in Ada.Exceptions for - -- a more detailed description of the potential problems. - - procedure Save_Library_Occurrence (E : EOA); - -- When invoked, this routine saves an exception occurrence into a hidden - -- reference. Subsequent calls will have no effect. - - ------------------------ - -- Task Specific Data -- - ------------------------ - - -- Here we define a single type that encapsulates the various task - -- specific data. This type is used to store the necessary data into the - -- Task_Control_Block or into a global variable in the non tasking case. - - type TSD is record - Pri_Stack_Info : aliased Stack_Checking.Stack_Info; - -- Information on stack (Base/Limit/Size) used by System.Stack_Checking. - -- If this TSD does not belong to the environment task, the Size field - -- must be initialized to the tasks requested stack size before the task - -- can do its first stack check. - - pragma Warnings (Off); - -- Needed because we are giving a non-static default to an object in - -- a preelaborated unit, which is formally not permitted, but OK here. - - Jmpbuf_Address : System.Address := System.Null_Address; - -- Address of jump buffer used to store the address of the current - -- longjmp/setjmp buffer for exception management. These buffers are - -- threaded into a stack, and the address here is the top of the stack. - -- A null address means that no exception handler is currently active. - - Sec_Stack_Addr : System.Address := System.Null_Address; - pragma Warnings (On); - -- Address of currently allocated secondary stack - - Current_Excep : aliased EO; - -- Exception occurrence that contains the information for the current - -- exception. Note that any exception in the same task destroys this - -- information, so the data in this variable must be copied out before - -- another exception can occur. - -- - -- Also act as a list of the active exceptions in the case of the GCC - -- exception mechanism, organized as a stack with the most recent first. - end record; - - procedure Create_TSD (New_TSD : in out TSD); - pragma Inline (Create_TSD); - -- Called from s-tassta when a new thread is created to perform - -- any required initialization of the TSD. - - procedure Destroy_TSD (Old_TSD : in out TSD); - pragma Inline (Destroy_TSD); - -- Called from s-tassta just before a thread is destroyed to perform - -- any required finalization. - - function Get_GNAT_Exception return Ada.Exceptions.Exception_Id; - pragma Inline (Get_GNAT_Exception); - -- This function obtains the Exception_Id from the Exception_Occurrence - -- referenced by the Current_Excep field of the task specific data, i.e. - -- the call is equivalent to - -- Exception_Identity (Get_Current_Exception.all) - - -- Export the Get/Set routines for the various Task Specific Data (TSD) - -- elements as callable subprograms instead of objects of access to - -- subprogram types. - - function Get_Jmpbuf_Address_Soft return Address; - procedure Set_Jmpbuf_Address_Soft (Addr : Address); - pragma Inline (Get_Jmpbuf_Address_Soft); - pragma Inline (Set_Jmpbuf_Address_Soft); - - function Get_Sec_Stack_Addr_Soft return Address; - procedure Set_Sec_Stack_Addr_Soft (Addr : Address); - pragma Inline (Get_Sec_Stack_Addr_Soft); - pragma Inline (Set_Sec_Stack_Addr_Soft); - - -- The following is a dummy record designed to mimic Communication_Block as - -- defined in s-tpobop.ads: - - -- type Communication_Block is record - -- Self : Task_Id; -- An access type - -- Enqueued : Boolean := True; - -- Cancelled : Boolean := False; - -- end record; - - -- The record is used in the construction of the predefined dispatching - -- primitive _disp_asynchronous_select in order to avoid the import of - -- System.Tasking.Protected_Objects.Operations. Note that this package - -- is always imported in the presence of interfaces since the dispatch - -- table uses entities from here. - - type Dummy_Communication_Block is record - Comp_1 : Address; -- Address and access have the same size - Comp_2 : Boolean; - Comp_3 : Boolean; - end record; - -end System.Soft_Links; diff --git a/gcc/ada/s-sopco3.adb b/gcc/ada/s-sopco3.adb deleted file mode 100644 index 9c4e005..0000000 --- a/gcc/ada/s-sopco3.adb +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 3 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package body System.String_Ops_Concat_3 is - - ------------------ - -- Str_Concat_3 -- - ------------------ - - function Str_Concat_3 (S1, S2, S3 : String) return String is - begin - if S1'Length = 0 then - return S2 & S3; - - else - declare - L12 : constant Natural := S1'Length + S2'Length; - L13 : constant Natural := L12 + S3'Length; - R : String (S1'First .. S1'First + L13 - 1); - - begin - R (S1'First .. S1'Last) := S1; - R (S1'Last + 1 .. S1'First + L12 - 1) := S2; - R (S1'First + L12 .. R'Last) := S3; - return R; - end; - end if; - end Str_Concat_3; - -end System.String_Ops_Concat_3; diff --git a/gcc/ada/s-sopco3.ads b/gcc/ada/s-sopco3.ads deleted file mode 100644 index 89dd9cf..0000000 --- a/gcc/ada/s-sopco3.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 3 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the function for concatenating three strings - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package System.String_Ops_Concat_3 is - pragma Pure; - - function Str_Concat_3 (S1, S2, S3 : String) return String; - -- Concatenate three strings and return resulting string - -end System.String_Ops_Concat_3; diff --git a/gcc/ada/s-sopco4.adb b/gcc/ada/s-sopco4.adb deleted file mode 100644 index fc3a740..0000000 --- a/gcc/ada/s-sopco4.adb +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 4 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package body System.String_Ops_Concat_4 is - - ------------------ - -- Str_Concat_4 -- - ------------------ - - function Str_Concat_4 (S1, S2, S3, S4 : String) return String is - begin - if S1'Length = 0 then - return S2 & S3 & S4; - - else - declare - L12 : constant Natural := S1'Length + S2'Length; - L13 : constant Natural := L12 + S3'Length; - L14 : constant Natural := L13 + S4'Length; - R : String (S1'First .. S1'First + L14 - 1); - - begin - R (S1'First .. S1'Last) := S1; - R (S1'Last + 1 .. S1'First + L12 - 1) := S2; - R (S1'First + L12 .. S1'First + L13 - 1) := S3; - R (S1'First + L13 .. R'Last) := S4; - return R; - end; - end if; - end Str_Concat_4; - -end System.String_Ops_Concat_4; diff --git a/gcc/ada/s-sopco4.ads b/gcc/ada/s-sopco4.ads deleted file mode 100644 index 79cd3dd..0000000 --- a/gcc/ada/s-sopco4.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 4 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the function for concatenating four strings - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package System.String_Ops_Concat_4 is - pragma Pure; - - function Str_Concat_4 (S1, S2, S3, S4 : String) return String; - -- Concatenate four strings and return resulting string - -end System.String_Ops_Concat_4; diff --git a/gcc/ada/s-sopco5.adb b/gcc/ada/s-sopco5.adb deleted file mode 100644 index 6be4d5b..0000000 --- a/gcc/ada/s-sopco5.adb +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 5 -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package body System.String_Ops_Concat_5 is - - ------------------ - -- Str_Concat_5 -- - ------------------ - - function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String is - begin - if S1'Length = 0 then - return S2 & S3 & S4 & S5; - - else - declare - L12 : constant Natural := S1'Length + S2'Length; - L13 : constant Natural := L12 + S3'Length; - L14 : constant Natural := L13 + S4'Length; - L15 : constant Natural := L14 + S5'Length; - R : String (S1'First .. S1'First + L15 - 1); - - begin - R (S1'First .. S1'Last) := S1; - R (S1'Last + 1 .. S1'First + L12 - 1) := S2; - R (S1'First + L12 .. S1'First + L13 - 1) := S3; - R (S1'First + L13 .. S1'First + L14 - 1) := S4; - R (S1'First + L14 .. R'Last) := S5; - return R; - end; - end if; - end Str_Concat_5; - -end System.String_Ops_Concat_5; diff --git a/gcc/ada/s-sopco5.ads b/gcc/ada/s-sopco5.ads deleted file mode 100644 index 2521279..0000000 --- a/gcc/ada/s-sopco5.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S _ C O N C A T _ 5 -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the function for concatenating five strings - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package System.String_Ops_Concat_5 is - pragma Pure; - - function Str_Concat_5 (S1, S2, S3, S4, S5 : String) return String; - -- Concatenate five strings and return resulting string - -end System.String_Ops_Concat_5; diff --git a/gcc/ada/s-spsufi.adb b/gcc/ada/s-spsufi.adb deleted file mode 100644 index e6baee0..0000000 --- a/gcc/ada/s-spsufi.adb +++ /dev/null @@ -1,89 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.STORAGE_POOLS.SUBPOOLS.FINALIZATION -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Deallocation; - -with System.Finalization_Masters; use System.Finalization_Masters; - -package body System.Storage_Pools.Subpools.Finalization is - - ----------------------------- - -- Finalize_And_Deallocate -- - ----------------------------- - - procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle) is - procedure Free is new Ada.Unchecked_Deallocation (SP_Node, SP_Node_Ptr); - - begin - -- Do nothing if the subpool was never created or never used. The latter - -- case may arise with an array of subpool implementations. - - if Subpool = null - or else Subpool.Owner = null - or else Subpool.Node = null - then - return; - end if; - - -- Clean up all controlled objects chained on the subpool's master - - Finalize (Subpool.Master); - - -- Remove the subpool from its owner's list of subpools - - Detach (Subpool.Node); - - -- Destroy the associated doubly linked list node which was created in - -- Set_Pool_Of_Subpools. - - Free (Subpool.Node); - - -- Dispatch to the user-defined implementation of Deallocate_Subpool. It - -- is important to first set Subpool.Owner to null, because RM-13.11.5 - -- requires that "The subpool no longer belongs to any pool" BEFORE - -- calling Deallocate_Subpool. The actual dispatching call required is: - -- - -- Deallocate_Subpool(Pool_of_Subpool(Subpool).all, Subpool); - -- - -- but that can't be taken literally, because Pool_of_Subpool will - -- return null. - - declare - Owner : constant Any_Storage_Pool_With_Subpools_Ptr := Subpool.Owner; - begin - Subpool.Owner := null; - Deallocate_Subpool (Owner.all, Subpool); - end; - - Subpool := null; - end Finalize_And_Deallocate; - -end System.Storage_Pools.Subpools.Finalization; diff --git a/gcc/ada/s-spsufi.ads b/gcc/ada/s-spsufi.ads deleted file mode 100644 index 319ed97..0000000 --- a/gcc/ada/s-spsufi.ads +++ /dev/null @@ -1,48 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- SYSTEM.STORAGE_POOLS.SUBPOOLS.FINALIZATION -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package System.Storage_Pools.Subpools.Finalization is - - -- The pragma is needed because package System.Storage_Pools.Subpools which - -- is already preelaborated now depends on this unit. - - pragma Preelaborate; - - procedure Finalize_And_Deallocate (Subpool : in out Subpool_Handle); - -- This routine performs the following actions: - -- 1) Finalize all objects chained on the subpool's master - -- 2) Remove the subpool from the owner's list of subpools - -- 3) Deallocate the doubly linked list node associated with the subpool - -- 4) Call Deallocate_Subpool - -end System.Storage_Pools.Subpools.Finalization; diff --git a/gcc/ada/s-stache.adb b/gcc/ada/s-stache.adb deleted file mode 100644 index 927e0ab..0000000 --- a/gcc/ada/s-stache.adb +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2013, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - --- As noted in the spec, this dummy body is present because otherwise we --- have bootstrapping path problems (there used to be a real body). - -package body System.Stack_Checking is -end System.Stack_Checking; diff --git a/gcc/ada/s-stache.ads b/gcc/ada/s-stache.ads deleted file mode 100644 index 374f676..0000000 --- a/gcc/ada/s-stache.ads +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2013, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a system-independent implementation of stack --- checking using comparison with stack base and limit. - --- This package defines basic types and objects. Operations related to --- stack checking can be found in package System.Stack_Checking.Operations. - -pragma Compiler_Unit_Warning; - -with System.Storage_Elements; - -package System.Stack_Checking is - pragma Preelaborate; - pragma Elaborate_Body; - -- This unit has a junk null body. The reason is that historically we - -- used to have a real body, and it causes bootstrapping path problems - -- to eliminate it, since the old body may still be present in the - -- compilation environment for a build. - - type Stack_Info is record - Limit : System.Address := System.Null_Address; - Base : System.Address := System.Null_Address; - Size : System.Storage_Elements.Storage_Offset := 0; - end record; - -- This record may be part of a larger data structure like the - -- task control block in the tasking case. - -- This specific layout has the advantage of being compatible with the - -- Intel x86 BOUNDS instruction. - - type Stack_Access is access all Stack_Info; - -- Unique local storage associated with a specific task. This storage is - -- used for the stack base and limit, and is returned by Checked_Self. - -- Only self may write this information, it may be read by any task. - -- At no time the address range Limit .. Base (or Base .. Limit for - -- upgrowing stack) may contain any address that is part of another stack. - -- The Stack_Access may be part of a larger data structure. - - Multi_Processor : constant Boolean := False; -- Not supported yet - -private - - Null_Stack_Info : aliased Stack_Info := - (Limit => System.Null_Address, - Base => System.Null_Address, - Size => 0); - -- Use explicit assignment to avoid elaboration code (call to init proc) - - Null_Stack : constant Stack_Access := Null_Stack_Info'Access; - -- Stack_Access value that will return a Stack_Base and Stack_Limit - -- that fail any stack check. - -end System.Stack_Checking; diff --git a/gcc/ada/s-stalib.adb b/gcc/ada/s-stalib.adb deleted file mode 100644 index 1b95c6a..0000000 --- a/gcc/ada/s-stalib.adb +++ /dev/null @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T A N D A R D _ L I B R A R Y -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - --- The purpose of this body is simply to ensure that the two with'ed units --- are properly included in the link. They are not with'ed from the spec --- of System.Standard_Library, since this would cause order of elaboration --- problems (Elaborate_Body would have the same problem). - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions if polling is on. - -pragma Warnings (Off); --- Kill warnings from unused withs. These unused with's are here to make --- sure the relevant units are loaded and properly elaborated. - -with System.Soft_Links; --- Referenced directly from generated code using external symbols so it --- must always be present in a build, even if no unit has a direct with --- of this unit. Also referenced from exception handling routines. --- This is needed for programs that don't use exceptions explicitly but --- direct calls to Ada.Exceptions are generated by gigi (for example, --- by calling __gnat_raise_constraint_error directly). - -with System.Memory; --- Referenced directly from generated code using external symbols, so it --- must always be present in a build, even if no unit has a direct with --- of this unit. - -pragma Warnings (On); - -package body System.Standard_Library is - - Runtime_Finalized : Boolean := False; - -- Set to True when adafinal is called. Used to ensure that subsequent - -- calls to adafinal after the first have no effect. - - -------------------------- - -- Abort_Undefer_Direct -- - -------------------------- - - procedure Abort_Undefer_Direct is - begin - System.Soft_Links.Abort_Undefer.all; - end Abort_Undefer_Direct; - - -------------- - -- Adafinal -- - -------------- - - procedure Adafinal is - begin - if not Runtime_Finalized then - Runtime_Finalized := True; - System.Soft_Links.Adafinal.all; - end if; - end Adafinal; - - ----------------- - -- Break_Start -- - ----------------- - - procedure Break_Start; - pragma Export (C, Break_Start, "__gnat_break_start"); - -- This is a dummy procedure that is called at the start of execution. - -- Its sole purpose is to provide a well defined point for the placement - -- of a main program breakpoint. This is not used anymore but kept for - -- bootstrapping issues (still referenced by old gnatbind generated files). - - procedure Break_Start is - begin - null; - end Break_Start; - -end System.Standard_Library; diff --git a/gcc/ada/s-stalib.ads b/gcc/ada/s-stalib.ads deleted file mode 100644 index d00d23b..0000000 --- a/gcc/ada/s-stalib.ads +++ /dev/null @@ -1,263 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T A N D A R D _ L I B R A R Y -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is included in all programs. It contains declarations that --- are required to be part of every Ada program. A special mechanism is --- required to ensure that these are loaded, since it may be the case in --- some programs that the only references to these required packages are --- from C code or from code generated directly by Gigi, and in both cases --- the binder is not aware of such references. - --- System.Standard_Library also includes data that must be present in every --- program, in particular data for all the standard exceptions, and also some --- subprograms that must be present in every program. - --- The binder unconditionally includes s-stalib.ali, which ensures that this --- package and the packages it references are included in all Ada programs, --- together with the included data. - -pragma Compiler_Unit_Warning; - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions if polling is on. - -with Ada.Unchecked_Conversion; - -package System.Standard_Library is - - -- Historical note: pragma Preelaborate was surrounded by a pair of pragma - -- Warnings (Off/On) to circumvent a bootstrap issue. - - pragma Preelaborate; - - subtype Big_String is String (1 .. Positive'Last); - pragma Suppress_Initialization (Big_String); - -- Type used to obtain string access to given address. Initialization is - -- suppressed, since we never want to have variables of this type, and - -- we never want to attempt initialiazation of virtual variables of this - -- type (e.g. when pragma Normalize_Scalars is used). - - type Big_String_Ptr is access all Big_String; - for Big_String_Ptr'Storage_Size use 0; - -- We use this access type to pass a pointer to an area of storage to be - -- accessed as a string. Of course when this pointer is used, it is the - -- responsibility of the accessor to ensure proper bounds. The storage - -- size clause ensures we do not allocate variables of this type. - - function To_Ptr is - new Ada.Unchecked_Conversion (System.Address, Big_String_Ptr); - - ------------------------------------- - -- Exception Declarations and Data -- - ------------------------------------- - - type Raise_Action is access procedure; - -- A pointer to a procedure used in the Raise_Hook field - - type Exception_Data; - type Exception_Data_Ptr is access all Exception_Data; - -- An equivalent of Exception_Id that is public - - -- The following record defines the underlying representation of exceptions - - -- WARNING: Any changes to this may need to be reflected in the following - -- locations in the compiler and runtime code: - - -- 1. The Internal_Exception routine in s-exctab.adb - -- 2. The processing in gigi that tests Not_Handled_By_Others - -- 3. Expand_N_Exception_Declaration in Exp_Ch11 - -- 4. The construction of the exception type in Cstand - - type Exception_Data is record - Not_Handled_By_Others : Boolean; - -- Normally set False, indicating that the exception is handled in the - -- usual way by others (i.e. an others handler handles the exception). - -- Set True to indicate that this exception is not caught by others - -- handlers, but must be explicitly named in a handler. This latter - -- setting is currently used by the Abort_Signal. - - Lang : Character; - -- A character indicating the language raising the exception. - -- Set to "A" for exceptions defined by an Ada program. - -- Set to "C" for imported C++ exceptions. - - Name_Length : Natural; - -- Length of fully expanded name of exception - - Full_Name : System.Address; - -- Fully expanded name of exception, null terminated - -- You can use To_Ptr to convert this to a string. - - HTable_Ptr : Exception_Data_Ptr; - -- Hash table pointer used to link entries together in the hash table - -- built (by Register_Exception in s-exctab.adb) for converting between - -- identities and names. - - Foreign_Data : Address; - -- Data for imported exceptions. Not used in the Ada case. This - -- represents the address of the RTTI for the C++ case. - - Raise_Hook : Raise_Action; - -- This field can be used to place a "hook" on an exception. If the - -- value is non-null, then it points to a procedure which is called - -- whenever the exception is raised. This call occurs immediately, - -- before any other actions taken by the raise (and in particular - -- before any unwinding of the stack occurs). - end record; - - -- Definitions for standard predefined exceptions defined in Standard, - - -- Why are the NULs necessary here, seems like they should not be - -- required, since Gigi is supposed to add a Nul to each name ??? - - Constraint_Error_Name : constant String := "CONSTRAINT_ERROR" & ASCII.NUL; - Program_Error_Name : constant String := "PROGRAM_ERROR" & ASCII.NUL; - Storage_Error_Name : constant String := "STORAGE_ERROR" & ASCII.NUL; - Tasking_Error_Name : constant String := "TASKING_ERROR" & ASCII.NUL; - Abort_Signal_Name : constant String := "_ABORT_SIGNAL" & ASCII.NUL; - - Numeric_Error_Name : constant String := "NUMERIC_ERROR" & ASCII.NUL; - -- This is used only in the Ada 83 case, but it is not worth having a - -- separate version of s-stalib.ads for use in Ada 83 mode. - - Constraint_Error_Def : aliased Exception_Data := - (Not_Handled_By_Others => False, - Lang => 'A', - Name_Length => Constraint_Error_Name'Length, - Full_Name => Constraint_Error_Name'Address, - HTable_Ptr => null, - Foreign_Data => Null_Address, - Raise_Hook => null); - - Numeric_Error_Def : aliased Exception_Data := - (Not_Handled_By_Others => False, - Lang => 'A', - Name_Length => Numeric_Error_Name'Length, - Full_Name => Numeric_Error_Name'Address, - HTable_Ptr => null, - Foreign_Data => Null_Address, - Raise_Hook => null); - - Program_Error_Def : aliased Exception_Data := - (Not_Handled_By_Others => False, - Lang => 'A', - Name_Length => Program_Error_Name'Length, - Full_Name => Program_Error_Name'Address, - HTable_Ptr => null, - Foreign_Data => Null_Address, - Raise_Hook => null); - - Storage_Error_Def : aliased Exception_Data := - (Not_Handled_By_Others => False, - Lang => 'A', - Name_Length => Storage_Error_Name'Length, - Full_Name => Storage_Error_Name'Address, - HTable_Ptr => null, - Foreign_Data => Null_Address, - Raise_Hook => null); - - Tasking_Error_Def : aliased Exception_Data := - (Not_Handled_By_Others => False, - Lang => 'A', - Name_Length => Tasking_Error_Name'Length, - Full_Name => Tasking_Error_Name'Address, - HTable_Ptr => null, - Foreign_Data => Null_Address, - Raise_Hook => null); - - Abort_Signal_Def : aliased Exception_Data := - (Not_Handled_By_Others => True, - Lang => 'A', - Name_Length => Abort_Signal_Name'Length, - Full_Name => Abort_Signal_Name'Address, - HTable_Ptr => null, - Foreign_Data => Null_Address, - Raise_Hook => null); - - pragma Export (C, Constraint_Error_Def, "constraint_error"); - pragma Export (C, Numeric_Error_Def, "numeric_error"); - pragma Export (C, Program_Error_Def, "program_error"); - pragma Export (C, Storage_Error_Def, "storage_error"); - pragma Export (C, Tasking_Error_Def, "tasking_error"); - pragma Export (C, Abort_Signal_Def, "_abort_signal"); - - Local_Partition_ID : Natural := 0; - -- This variable contains the local Partition_ID that will be used when - -- building exception occurrences. In distributed mode, it will be - -- set by each partition to the correct value during the elaboration. - - type Exception_Trace_Kind is - (RM_Convention, - -- No particular trace is requested, only unhandled exceptions - -- in the environment task (following the RM) will be printed. - -- This is the default behavior. - - Every_Raise, - -- Denotes the initial raise event for any exception occurrence, either - -- explicit or due to a specific language rule, within the context of a - -- task or not. - - Unhandled_Raise, - -- Denotes the raise events corresponding to exceptions for which there - -- is no user defined handler. This includes unhandled exceptions in - -- task bodies. - - Unhandled_Raise_In_Main - -- Same as Unhandled_Raise, except exceptions in task bodies are not - -- included. Same as RM_Convention, except (1) the message is printed as - -- soon as the environment task completes due to an unhandled exception - -- (before awaiting the termination of dependent tasks, and before - -- library-level finalization), and (2) a symbolic traceback is given - -- if possible. This is the default behavior if the binder switch -E is - -- used. - ); - -- Provide a way to denote different kinds of automatic traces related - -- to exceptions that can be requested. - - Exception_Trace : Exception_Trace_Kind := RM_Convention; - pragma Atomic (Exception_Trace); - -- By default, follow the RM convention - - ----------------- - -- Subprograms -- - ----------------- - - procedure Abort_Undefer_Direct; - pragma Inline (Abort_Undefer_Direct); - -- A little procedure that just calls Abort_Undefer.all, for use in - -- clean up procedures, which only permit a simple subprogram name. - - procedure Adafinal; - -- Performs the Ada Runtime finalization the first time it is invoked. - -- All subsequent calls are ignored. - -end System.Standard_Library; diff --git a/gcc/ada/s-stausa.adb b/gcc/ada/s-stausa.adb deleted file mode 100644 index 6ccc386..0000000 --- a/gcc/ada/s-stausa.adb +++ /dev/null @@ -1,566 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M - S T A C K _ U S A G E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2004-2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Parameters; -with System.CRTL; -with System.IO; - -package body System.Stack_Usage is - use System.Storage_Elements; - use System; - use System.IO; - use Interfaces; - - ----------------- - -- Stack_Slots -- - ----------------- - - -- Stackl_Slots is an internal data type to represent a sequence of real - -- stack slots initialized with a provided pattern, with operations to - -- abstract away the target call stack growth direction. - - type Stack_Slots is array (Integer range <>) of Pattern_Type; - for Stack_Slots'Component_Size use Pattern_Type'Object_Size; - - -- We will carefully handle the initializations ourselves and might want - -- to remap an initialized overlay later on with an address clause. - - pragma Suppress_Initialization (Stack_Slots); - - -- The abstract Stack_Slots operations all operate over the simple array - -- memory model: - - -- memory addresses increasing ----> - - -- Slots('First) Slots('Last) - -- | | - -- V V - -- +------------------------------------------------------------------+ - -- |####| |####| - -- +------------------------------------------------------------------+ - - -- What we call Top or Bottom always denotes call chain leaves or entry - -- points respectively, and their relative positions in the stack array - -- depends on the target stack growth direction: - - -- Stack_Grows_Down - - -- <----- calls push frames towards decreasing addresses - - -- Top(most) Slot Bottom(most) Slot - -- | | - -- V V - -- +------------------------------------------------------------------+ - -- |####| | leaf frame | ... | entry frame | - -- +------------------------------------------------------------------+ - - -- Stack_Grows_Up - - -- calls push frames towards increasing addresses -----> - - -- Bottom(most) Slot Top(most) Slot - -- | | - -- V V - -- +------------------------------------------------------------------+ - -- | entry frame | ... | leaf frame | |####| - -- +------------------------------------------------------------------+ - - ------------------- - -- Unit Services -- - ------------------- - - -- Now the implementation of the services offered by this unit, on top of - -- the Stack_Slots abstraction above. - - Index_Str : constant String := "Index"; - Task_Name_Str : constant String := "Task Name"; - Stack_Size_Str : constant String := "Stack Size"; - Actual_Size_Str : constant String := "Stack usage"; - - procedure Output_Result - (Result_Id : Natural; - Result : Task_Result; - Max_Stack_Size_Len : Natural; - Max_Actual_Use_Len : Natural); - -- Prints the result on the standard output. Result Id is the number of - -- the result in the array, and Result the contents of the actual result. - -- Max_Stack_Size_Len and Max_Actual_Use_Len are used for displaying the - -- proper layout. They hold the maximum length of the string representing - -- the Stack_Size and Actual_Use values. - - ---------------- - -- Initialize -- - ---------------- - - procedure Initialize (Buffer_Size : Natural) is - Stack_Size_Chars : System.Address; - - begin - -- Initialize the buffered result array - - Result_Array := new Result_Array_Type (1 .. Buffer_Size); - Result_Array.all := - (others => - (Task_Name => (others => ASCII.NUL), - Value => 0, - Stack_Size => 0)); - - -- Set the Is_Enabled flag to true, so that the task wrapper knows that - -- it has to handle dynamic stack analysis - - Is_Enabled := True; - - Stack_Size_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL); - - -- If variable GNAT_STACK_LIMIT is set, then we will take care of the - -- environment task, using GNAT_STASK_LIMIT as the size of the stack. - -- It doesn't make sens to process the stack when no bound is set (e.g. - -- limit is typically up to 4 GB). - - if Stack_Size_Chars /= Null_Address then - declare - My_Stack_Size : Integer; - - begin - My_Stack_Size := System.CRTL.atoi (Stack_Size_Chars) * 1024; - - Initialize_Analyzer - (Environment_Task_Analyzer, - "ENVIRONMENT TASK", - My_Stack_Size, - 0, - My_Stack_Size); - - Fill_Stack (Environment_Task_Analyzer); - - Compute_Environment_Task := True; - end; - - -- GNAT_STACK_LIMIT not set - - else - Compute_Environment_Task := False; - end if; - end Initialize; - - ---------------- - -- Fill_Stack -- - ---------------- - - procedure Fill_Stack (Analyzer : in out Stack_Analyzer) is - - -- Change the local variables and parameters of this function with - -- super-extra care. The more the stack frame size of this function is - -- big, the more an "instrumentation threshold at writing" error is - -- likely to happen. - - Current_Stack_Level : aliased Integer; - - Guard : constant := 256; - -- Guard space between the Current_Stack_Level'Address and the last - -- allocated byte on the stack. - begin - if Parameters.Stack_Grows_Down then - if Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size) > - To_Stack_Address (Current_Stack_Level'Address) - Guard - then - -- No room for a pattern - - Analyzer.Pattern_Size := 0; - return; - end if; - - Analyzer.Pattern_Limit := - Analyzer.Stack_Base - Stack_Address (Analyzer.Pattern_Size); - - if Analyzer.Stack_Base > - To_Stack_Address (Current_Stack_Level'Address) - Guard - then - -- Reduce pattern size to prevent local frame overwrite - - Analyzer.Pattern_Size := - Integer (To_Stack_Address (Current_Stack_Level'Address) - Guard - - Analyzer.Pattern_Limit); - end if; - - Analyzer.Pattern_Overlay_Address := - To_Address (Analyzer.Pattern_Limit); - else - if Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size) < - To_Stack_Address (Current_Stack_Level'Address) + Guard - then - -- No room for a pattern - - Analyzer.Pattern_Size := 0; - return; - end if; - - Analyzer.Pattern_Limit := - Analyzer.Stack_Base + Stack_Address (Analyzer.Pattern_Size); - - if Analyzer.Stack_Base < - To_Stack_Address (Current_Stack_Level'Address) + Guard - then - -- Reduce pattern size to prevent local frame overwrite - - Analyzer.Pattern_Size := - Integer - (Analyzer.Pattern_Limit - - (To_Stack_Address (Current_Stack_Level'Address) + Guard)); - end if; - - Analyzer.Pattern_Overlay_Address := - To_Address (Analyzer.Pattern_Limit - - Stack_Address (Analyzer.Pattern_Size)); - end if; - - -- Declare and fill the pattern buffer - - declare - Pattern : aliased Stack_Slots - (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); - for Pattern'Address use Analyzer.Pattern_Overlay_Address; - - begin - if System.Parameters.Stack_Grows_Down then - for J in reverse Pattern'Range loop - Pattern (J) := Analyzer.Pattern; - end loop; - - else - for J in Pattern'Range loop - Pattern (J) := Analyzer.Pattern; - end loop; - end if; - end; - end Fill_Stack; - - ------------------------- - -- Initialize_Analyzer -- - ------------------------- - - procedure Initialize_Analyzer - (Analyzer : in out Stack_Analyzer; - Task_Name : String; - Stack_Size : Natural; - Stack_Base : Stack_Address; - Pattern_Size : Natural; - Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#) - is - begin - -- Initialize the analyzer fields - - Analyzer.Stack_Base := Stack_Base; - Analyzer.Stack_Size := Stack_Size; - Analyzer.Pattern_Size := Pattern_Size; - Analyzer.Pattern := Pattern; - Analyzer.Result_Id := Next_Id; - Analyzer.Task_Name := (others => ' '); - - -- Compute the task name, and truncate if bigger than Task_Name_Length - - if Task_Name'Length <= Task_Name_Length then - Analyzer.Task_Name (1 .. Task_Name'Length) := Task_Name; - else - Analyzer.Task_Name := - Task_Name (Task_Name'First .. - Task_Name'First + Task_Name_Length - 1); - end if; - - Next_Id := Next_Id + 1; - end Initialize_Analyzer; - - ---------------- - -- Stack_Size -- - ---------------- - - function Stack_Size - (SP_Low : Stack_Address; - SP_High : Stack_Address) return Natural - is - begin - if SP_Low > SP_High then - return Natural (SP_Low - SP_High); - else - return Natural (SP_High - SP_Low); - end if; - end Stack_Size; - - -------------------- - -- Compute_Result -- - -------------------- - - procedure Compute_Result (Analyzer : in out Stack_Analyzer) is - - -- Change the local variables and parameters of this function with - -- super-extra care. The larger the stack frame size of this function - -- is, the more an "instrumentation threshold at reading" error is - -- likely to happen. - - Stack : Stack_Slots (1 .. Analyzer.Pattern_Size / Bytes_Per_Pattern); - for Stack'Address use Analyzer.Pattern_Overlay_Address; - - begin - -- Value if the pattern was not modified - - if Parameters.Stack_Grows_Down then - Analyzer.Topmost_Touched_Mark := - Analyzer.Pattern_Limit + Stack_Address (Analyzer.Pattern_Size); - else - Analyzer.Topmost_Touched_Mark := - Analyzer.Pattern_Limit - Stack_Address (Analyzer.Pattern_Size); - end if; - - if Analyzer.Pattern_Size = 0 then - return; - end if; - - -- Look backward from the topmost possible end of the marked stack to - -- the bottom of it. The first index not equals to the patterns marks - -- the beginning of the used stack. - - if System.Parameters.Stack_Grows_Down then - for J in Stack'Range loop - if Stack (J) /= Analyzer.Pattern then - Analyzer.Topmost_Touched_Mark := - To_Stack_Address (Stack (J)'Address); - exit; - end if; - end loop; - - else - for J in reverse Stack'Range loop - if Stack (J) /= Analyzer.Pattern then - Analyzer.Topmost_Touched_Mark := - To_Stack_Address (Stack (J)'Address); - exit; - end if; - end loop; - - end if; - end Compute_Result; - - --------------------- - -- Output_Result -- - --------------------- - - procedure Output_Result - (Result_Id : Natural; - Result : Task_Result; - Max_Stack_Size_Len : Natural; - Max_Actual_Use_Len : Natural) - is - Result_Id_Str : constant String := Natural'Image (Result_Id); - Stack_Size_Str : constant String := Natural'Image (Result.Stack_Size); - Actual_Use_Str : constant String := Natural'Image (Result.Value); - - Result_Id_Blanks : constant - String (1 .. Index_Str'Length - Result_Id_Str'Length) := - (others => ' '); - - Stack_Size_Blanks : constant - String (1 .. Max_Stack_Size_Len - Stack_Size_Str'Length) := - (others => ' '); - - Actual_Use_Blanks : constant - String (1 .. Max_Actual_Use_Len - Actual_Use_Str'Length) := - (others => ' '); - - begin - Set_Output (Standard_Error); - Put (Result_Id_Blanks & Natural'Image (Result_Id)); - Put (" | "); - Put (Result.Task_Name); - Put (" | "); - Put (Stack_Size_Blanks & Stack_Size_Str); - Put (" | "); - Put (Actual_Use_Blanks & Actual_Use_Str); - New_Line; - end Output_Result; - - --------------------- - -- Output_Results -- - --------------------- - - procedure Output_Results is - Max_Stack_Size : Natural := 0; - Max_Stack_Usage : Natural := 0; - Max_Stack_Size_Len, Max_Actual_Use_Len : Natural := 0; - - Task_Name_Blanks : constant - String - (1 .. Task_Name_Length - Task_Name_Str'Length) := - (others => ' '); - - begin - Set_Output (Standard_Error); - - if Compute_Environment_Task then - Compute_Result (Environment_Task_Analyzer); - Report_Result (Environment_Task_Analyzer); - end if; - - if Result_Array'Length > 0 then - - -- Computes the size of the largest strings that will get displayed, - -- in order to do correct column alignment. - - for J in Result_Array'Range loop - exit when J >= Next_Id; - - if Result_Array (J).Value > Max_Stack_Usage then - Max_Stack_Usage := Result_Array (J).Value; - end if; - - if Result_Array (J).Stack_Size > Max_Stack_Size then - Max_Stack_Size := Result_Array (J).Stack_Size; - end if; - end loop; - - Max_Stack_Size_Len := Natural'Image (Max_Stack_Size)'Length; - - Max_Actual_Use_Len := Natural'Image (Max_Stack_Usage)'Length; - - -- Display the output header. Blanks will be added in front of the - -- labels if needed. - - declare - Stack_Size_Blanks : constant - String (1 .. Max_Stack_Size_Len - - Stack_Size_Str'Length) := - (others => ' '); - - Stack_Usage_Blanks : constant - String (1 .. Max_Actual_Use_Len - - Actual_Size_Str'Length) := - (others => ' '); - - begin - if Stack_Size_Str'Length > Max_Stack_Size_Len then - Max_Stack_Size_Len := Stack_Size_Str'Length; - end if; - - if Actual_Size_Str'Length > Max_Actual_Use_Len then - Max_Actual_Use_Len := Actual_Size_Str'Length; - end if; - - Put - (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | " - & Stack_Size_Str & Stack_Size_Blanks & " | " - & Stack_Usage_Blanks & Actual_Size_Str); - end; - - New_Line; - - -- Now display the individual results - - for J in Result_Array'Range loop - exit when J >= Next_Id; - Output_Result - (J, Result_Array (J), Max_Stack_Size_Len, Max_Actual_Use_Len); - end loop; - - -- Case of no result stored, still display the labels - - else - Put - (Index_Str & " | " & Task_Name_Str & Task_Name_Blanks & " | " - & Stack_Size_Str & " | " & Actual_Size_Str); - New_Line; - end if; - end Output_Results; - - ------------------- - -- Report_Result -- - ------------------- - - procedure Report_Result (Analyzer : Stack_Analyzer) is - Result : Task_Result := (Task_Name => Analyzer.Task_Name, - Stack_Size => Analyzer.Stack_Size, - Value => 0); - begin - if Analyzer.Pattern_Size = 0 then - - -- If we have that result, it means that we didn't do any computation - -- at all (i.e. we used at least everything (and possibly more). - - Result.Value := Analyzer.Stack_Size; - - else - Result.Value := Stack_Size (Analyzer.Topmost_Touched_Mark, - Analyzer.Stack_Base); - end if; - - if Analyzer.Result_Id in Result_Array'Range then - - -- If the result can be stored, then store it in Result_Array - - Result_Array (Analyzer.Result_Id) := Result; - - else - -- If the result cannot be stored, then we display it right away - - declare - Result_Str_Len : constant Natural := - Natural'Image (Result.Value)'Length; - Size_Str_Len : constant Natural := - Natural'Image (Analyzer.Stack_Size)'Length; - - Max_Stack_Size_Len : Natural; - Max_Actual_Use_Len : Natural; - - begin - -- Take either the label size or the number image size for the - -- size of the column "Stack Size". - - Max_Stack_Size_Len := - (if Size_Str_Len > Stack_Size_Str'Length - then Size_Str_Len - else Stack_Size_Str'Length); - - -- Take either the label size or the number image size for the - -- size of the column "Stack Usage". - - Max_Actual_Use_Len := - (if Result_Str_Len > Actual_Size_Str'Length - then Result_Str_Len - else Actual_Size_Str'Length); - - Output_Result - (Analyzer.Result_Id, - Result, - Max_Stack_Size_Len, - Max_Actual_Use_Len); - end; - end if; - end Report_Result; - -end System.Stack_Usage; diff --git a/gcc/ada/s-stausa.ads b/gcc/ada/s-stausa.ads deleted file mode 100644 index c0449e8..0000000 --- a/gcc/ada/s-stausa.ads +++ /dev/null @@ -1,339 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNU ADA RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M - S T A C K _ U S A G E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2004-2011, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - -with System; -with System.Storage_Elements; -with System.Address_To_Access_Conversions; -with Interfaces; - -package System.Stack_Usage is - pragma Preelaborate; - - package SSE renames System.Storage_Elements; - - subtype Stack_Address is SSE.Integer_Address; - -- Address on the stack - - function To_Stack_Address - (Value : System.Address) return Stack_Address - renames System.Storage_Elements.To_Integer; - - Task_Name_Length : constant := 32; - -- The maximum length of task name displayed. - -- ??? Consider merging this variable with Max_Task_Image_Length. - - type Task_Result is record - Task_Name : String (1 .. Task_Name_Length); - - Value : Natural; - -- Amount of stack used. The value is calculated on the basis of the - -- mechanism used by GNAT to allocate it, and it is NOT a precise value. - - Stack_Size : Natural; - -- Size of the stack - end record; - - type Result_Array_Type is array (Positive range <>) of Task_Result; - - type Stack_Analyzer is private; - -- Type of the stack analyzer tool. It is used to fill a portion of the - -- stack with Pattern, and to compute the stack used after some execution. - - -- Usage: - - -- A typical use of the package is something like: - - -- A : Stack_Analyzer; - - -- task T is - -- pragma Storage_Size (A_Storage_Size); - -- end T; - - -- [...] - - -- Bottom_Of_Stack : aliased Integer; - -- -- Bottom_Of_Stack'Address will be used as an approximation of - -- -- the bottom of stack. A good practise is to avoid allocating - -- -- other local variables on this stack, as it would degrade - -- -- the quality of this approximation. - - -- begin - -- Initialize_Analyzer (A, - -- "Task t", - -- A_Storage_Size, - -- 0, - -- A_Storage_Size - A_Guard, - -- To_Stack_Address (Bottom_Of_Stack'Address)); - -- Fill_Stack (A); - -- Some_User_Code; - -- Compute_Result (A); - -- Report_Result (A); - -- end T; - - -- Errors: - -- - -- We are instrumenting the code to measure the stack used by the user - -- code. This method has a number of systematic errors, but several methods - -- can be used to evaluate or reduce those errors. Here are those errors - -- and the strategy that we use to deal with them: - - -- Bottom offset: - - -- Description: The procedure used to fill the stack with a given - -- pattern will itself have a stack frame. The value of the stack - -- pointer in this procedure is, therefore, different from the value - -- before the call to the instrumentation procedure. - - -- Strategy: The user of this package should measure the bottom of stack - -- before the call to Fill_Stack and pass it in parameter. The impact - -- is very minor unless the stack used is very small, but in this case - -- you aren't very interested by the figure. - - -- Instrumentation threshold at writing: - - -- Description: The procedure used to fill the stack with a given - -- pattern will itself have a stack frame. Therefore, it will - -- fill the stack after this stack frame. This part of the stack will - -- appear as used in the final measure. - - -- Strategy: As the user passes the value of the bottom of stack to - -- the instrumentation to deal with the bottom offset error, and as - -- the instrumentation procedure knows where the pattern filling start - -- on the stack, the difference between the two values is the minimum - -- stack usage that the method can measure. If, when the results are - -- computed, the pattern zone has been left untouched, we conclude - -- that the stack usage is inferior to this minimum stack usage. - - -- Instrumentation threshold at reading: - - -- Description: The procedure used to read the stack at the end of the - -- execution clobbers the stack by allocating its stack frame. If this - -- stack frame is bigger than the total stack used by the user code at - -- this point, it will increase the measured stack size. - - -- Strategy: We could augment this stack frame and see if it changes the - -- measure. However, this error should be negligible. - - -- Pattern zone overflow: - - -- Description: The stack grows outer than the topmost bound of the - -- pattern zone. In that case, the topmost region modified in the - -- pattern is not the maximum value of the stack pointer during the - -- execution. - - -- Strategy: At the end of the execution, the difference between the - -- topmost memory region modified in the pattern zone and the - -- topmost bound of the pattern zone can be understood as the - -- biggest allocation that the method could have detect, provided - -- that there is no "Untouched allocated zone" error and no "Pattern - -- usage in user code" error. If no object in the user code is likely - -- to have this size, this is not likely to happen. - - -- Pattern usage in user code: - - -- Description: The pattern can be found in the object of the user code. - -- Therefore, the address space where this object has been allocated - -- will appear as untouched. - - -- Strategy: Choose a pattern that is uncommon. 16#0000_0000# is the - -- worst choice; 16#DEAD_BEEF# can be a good one. A good choice is an - -- address which is not a multiple of 2, and which is not in the - -- target address space. You can also change the pattern to see if it - -- changes the measure. Note that this error *very* rarely influence - -- the measure of the total stack usage: to have some influence, the - -- pattern has to be used in the object that has been allocated on the - -- topmost address of the used stack. - - -- Stack overflow: - - -- Description: The pattern zone does not fit on the stack. This may - -- lead to an erroneous execution. - - -- Strategy: Specify a storage size that is bigger than the size of the - -- pattern. 2 times bigger should be enough. - - -- Augmentation of the user stack frames: - - -- Description: The use of instrumentation object or procedure may - -- augment the stack frame of the caller. - - -- Strategy: Do *not* inline the instrumentation procedures. Do *not* - -- allocate the Stack_Analyzer object on the stack. - - -- Untouched allocated zone: - - -- Description: The user code may allocate objects that it will never - -- touch. In that case, the pattern will not be changed. - - -- Strategy: There are no way to detect this error. Fortunately, this - -- error is really rare, and it is most probably a bug in the user - -- code, e.g. some uninitialized variable. It is (most of the time) - -- harmless: it influences the measure only if the untouched allocated - -- zone happens to be located at the topmost value of the stack - -- pointer for the whole execution. - - procedure Initialize (Buffer_Size : Natural); - pragma Export (C, Initialize, "__gnat_stack_usage_initialize"); - -- Initializes the size of the buffer that stores the results. Only the - -- first Buffer_Size results are stored. Any results that do not fit in - -- this buffer will be displayed on the fly. - - procedure Fill_Stack (Analyzer : in out Stack_Analyzer); - -- Fill an area of the stack with the pattern Analyzer.Pattern. The size - -- of this area is Analyzer.Size. After the call to this procedure, - -- the memory will look like that: - -- - -- Stack growing - -- ----------------------------------------------------------------------> - -- |<--------------------->|<----------------------------------->| - -- | Stack frames to | Memory filled with Analyzer.Pattern | - -- | Fill_Stack | | - -- ^ | ^ - -- Analyzer.Stack_Base | Analyzer.Pattern_Limit - -- ^ - -- Analyzer.Pattern_Limit +/- Analyzer.Pattern_Size - -- - - procedure Initialize_Analyzer - (Analyzer : in out Stack_Analyzer; - Task_Name : String; - Stack_Size : Natural; - Stack_Base : Stack_Address; - Pattern_Size : Natural; - Pattern : Interfaces.Unsigned_32 := 16#DEAD_BEEF#); - -- Should be called before any use of a Stack_Analyzer, to initialize it. - -- Max_Pattern_Size is the size of the pattern zone, might be smaller than - -- the full stack size Stack_Size in order to take into account e.g. the - -- secondary stack and a guard against overflow. The actual size taken - -- will be readjusted with data already used at the time the stack is - -- actually filled. - - Is_Enabled : Boolean := False; - -- When this flag is true, then stack analysis is enabled - - procedure Compute_Result (Analyzer : in out Stack_Analyzer); - -- Read the pattern zone and deduce the stack usage. It should be called - -- from the same frame as Fill_Stack. If Analyzer.Probe is not null, an - -- array of Unsigned_32 with Analyzer.Probe elements is allocated on - -- Compute_Result's stack frame. Probe can be used to detect the error: - -- "instrumentation threshold at reading". See above. After the call - -- to this procedure, the memory will look like: - -- - -- Stack growing - -- -----------------------------------------------------------------------> - -- |<---------------------->|<-------------->|<--------->|<--------->| - -- | Stack frames | Array of | used | Memory | - -- | to Compute_Result | Analyzer.Probe | during | filled | - -- | | elements | the | with | - -- | | | execution | pattern | - -- | | | - -- |<----------------------------------------------------> | - -- Stack used ^ - -- Pattern_Limit - - procedure Report_Result (Analyzer : Stack_Analyzer); - -- Store the results of the computation in memory, at the address - -- corresponding to the symbol __gnat_stack_usage_results. This is not - -- done inside Compute_Result in order to use as less stack as possible - -- within a task. - - procedure Output_Results; - -- Print the results computed so far on the standard output. Should be - -- called when all tasks are dead. - - pragma Export (C, Output_Results, "__gnat_stack_usage_output_results"); - -private - - package Unsigned_32_Addr is - new System.Address_To_Access_Conversions (Interfaces.Unsigned_32); - - subtype Pattern_Type is Interfaces.Unsigned_32; - Bytes_Per_Pattern : constant := Pattern_Type'Object_Size / Storage_Unit; - - type Stack_Analyzer is record - Task_Name : String (1 .. Task_Name_Length); - -- Name of the task - - Stack_Base : Stack_Address; - -- Address of the base of the stack, as given by the caller of - -- Initialize_Analyzer. - - Stack_Size : Natural; - -- Entire size of the analyzed stack - - Pattern_Size : Natural; - -- Size of the pattern zone - - Pattern : Pattern_Type; - -- Pattern used to recognize untouched memory - - Pattern_Limit : Stack_Address; - -- Bound of the pattern area farthest to the base - - Topmost_Touched_Mark : Stack_Address; - -- Topmost address of the pattern area whose value it is pointing - -- at has been modified during execution. If the systematic error are - -- compensated, it is the topmost value of the stack pointer during - -- the execution. - - Pattern_Overlay_Address : System.Address; - -- Address of the stack abstraction object we overlay over a - -- task's real stack, typically a pattern-initialized array. - - Result_Id : Positive; - -- Id of the result. If less than value given to gnatbind -u corresponds - -- to the location in the result array of result for the current task. - end record; - - Environment_Task_Analyzer : Stack_Analyzer; - - Compute_Environment_Task : Boolean; - - type Result_Array_Ptr is access all Result_Array_Type; - - Result_Array : Result_Array_Ptr; - pragma Export (C, Result_Array, "__gnat_stack_usage_results"); - -- Exported in order to have an easy accessible symbol in when debugging - - Next_Id : Positive := 1; - -- Id of the next stack analyzer - - function Stack_Size - (SP_Low : Stack_Address; - SP_High : Stack_Address) return Natural; - pragma Inline (Stack_Size); - -- Return the size of a portion of stack delimited by SP_High and SP_Low - -- (), i.e. the difference between SP_High and SP_Low. The storage element - -- pointed by SP_Low is not included in the size. Inlined to reduce the - -- size of the stack used by the instrumentation code. - -end System.Stack_Usage; diff --git a/gcc/ada/s-stchop-limit.ads b/gcc/ada/s-stchop-limit.ads deleted file mode 100644 index 237c0f9..0000000 --- a/gcc/ada/s-stchop-limit.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of this package is for implementations which use --- the stack limit approach (the limit of the stack is stored into a per --- thread variable). - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the binder --- does not handle references to this package. - -pragma Polling (Off); --- Turn off polling, we do not want polling to take place during stack --- checking operations. It causes infinite loops and other problems. - -package System.Stack_Checking.Operations is - pragma Preelaborate; - - procedure Initialize_Stack_Limit; - pragma Export (C, Initialize_Stack_Limit, - "__gnat_initialize_stack_limit"); - -- This procedure is called before elaboration to setup the stack limit - -- for the environment task and to register the hook to be called at - -- task creation. -end System.Stack_Checking.Operations; diff --git a/gcc/ada/s-stchop-rtems.adb b/gcc/ada/s-stchop-rtems.adb deleted file mode 100644 index ac0cfd0..0000000 --- a/gcc/ada/s-stchop-rtems.adb +++ /dev/null @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the RTEMS version of this package. --- This file should be kept synchronized with the general implementation --- provided by s-stchop.adb. - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the --- binder does not handle references to this package. - -with Ada.Exceptions; - -with Interfaces.C; use Interfaces.C; - -package body System.Stack_Checking.Operations is - - ---------------------------- - -- Invalidate_Stack_Cache -- - ---------------------------- - - procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is - pragma Warnings (Off, Any_Stack); - begin - Cache := Null_Stack; - end Invalidate_Stack_Cache; - - ----------------------------- - -- Notify_Stack_Attributes -- - ----------------------------- - - procedure Notify_Stack_Attributes - (Initial_SP : System.Address; - Size : System.Storage_Elements.Storage_Offset) - is - - -- RTEMS keeps all the information we need. - - pragma Unreferenced (Size); - pragma Unreferenced (Initial_SP); - - begin - null; - end Notify_Stack_Attributes; - - ----------------- - -- Stack_Check -- - ----------------- - - function Stack_Check - (Stack_Address : System.Address) return Stack_Access - is - pragma Unreferenced (Stack_Address); - - -- RTEMS has a routine to check if the stack is blown. - -- It returns a C99 bool. - function rtems_stack_checker_is_blown return Interfaces.C.unsigned_char; - pragma Import (C, - rtems_stack_checker_is_blown, "rtems_stack_checker_is_blown"); - - begin - -- RTEMS has a routine to check this. So use it. - - if rtems_stack_checker_is_blown /= 0 then - Ada.Exceptions.Raise_Exception - (E => Storage_Error'Identity, - Message => "stack overflow detected"); - end if; - - return null; - - end Stack_Check; - - ------------------------ - -- Update_Stack_Cache -- - ------------------------ - - procedure Update_Stack_Cache (Stack : Stack_Access) is - begin - if not Multi_Processor then - Cache := Stack; - end if; - end Update_Stack_Cache; - -end System.Stack_Checking.Operations; diff --git a/gcc/ada/s-stchop-vxworks.adb b/gcc/ada/s-stchop-vxworks.adb deleted file mode 100644 index 53f6c45..0000000 --- a/gcc/ada/s-stchop-vxworks.adb +++ /dev/null @@ -1,145 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the verson for VxWorks 5, VxWorks 6 Cert and VxWorks MILS - --- This file should be kept synchronized with the general implementation --- provided by s-stchop.adb. - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the --- binder does not handle references to this package. - -with System.Storage_Elements; use System.Storage_Elements; -with System.Parameters; use System.Parameters; -with Interfaces.C; - -package body System.Stack_Checking.Operations is - - -- In order to have stack checking working appropriately on VxWorks we need - -- to extract the stack size information from the VxWorks kernel itself. - - -- For VxWorks 5 & 6 the library for showing task-related information - -- needs to be linked into the VxWorks system, when using stack checking. - -- The taskShow library can be linked into the VxWorks system by either: - - -- * defining INCLUDE_SHOW_ROUTINES in config.h when using - -- configuration header files, or - - -- * selecting INCLUDE_TASK_SHOW when using the Tornado project - -- facility. - - -- VxWorks MILS includes the necessary routine in taskLib, so nothing - -- special needs to be done there. - - Stack_Limit : Address; - - pragma Import (C, Stack_Limit, "__gnat_stack_limit"); - - -- Stack_Limit contains the limit of the stack. This variable is later made - -- a task variable (by calling taskVarAdd) and then correctly set to the - -- stack limit of the task. Before being so initialized its value must be - -- valid so that any subprogram with stack checking enabled will run. We - -- use extreme values according to the direction of the stack. - - type Set_Stack_Limit_Proc_Acc is access procedure; - pragma Convention (C, Set_Stack_Limit_Proc_Acc); - - Set_Stack_Limit_Hook : Set_Stack_Limit_Proc_Acc; - pragma Import (C, Set_Stack_Limit_Hook, "__gnat_set_stack_limit_hook"); - -- Procedure to be called when a task is created to set stack - -- limit. - - procedure Set_Stack_Limit_For_Current_Task; - pragma Convention (C, Set_Stack_Limit_For_Current_Task); - -- Register Initial_SP as the initial stack pointer value for the current - -- task when it starts and Size as the associated stack area size. This - -- should be called once, after the soft-links have been initialized? - - ----------------------------- - -- Initialize_Stack_Limit -- - ----------------------------- - - procedure Initialize_Stack_Limit is - begin - - Set_Stack_Limit_For_Current_Task; - - -- Will be called by every created task - - Set_Stack_Limit_Hook := Set_Stack_Limit_For_Current_Task'Access; - end Initialize_Stack_Limit; - - -------------------------------------- - -- Set_Stack_Limit_For_Current_Task -- - -------------------------------------- - - procedure Set_Stack_Limit_For_Current_Task is - use Interfaces.C; - - type OS_Stack_Info is record - Size : Interfaces.C.int; - Base : System.Address; - Limit : System.Address; - end record; - pragma Convention (C, OS_Stack_Info); - -- Type representing the information that we want to extract from the - -- underlying kernel. - - procedure Get_Stack_Info (Stack : not null access OS_Stack_Info); - pragma Import (C, Get_Stack_Info, "__gnat_get_stack_info"); - -- Procedure that fills the stack information associated to the - -- currently executing task. - - Stack_Info : aliased OS_Stack_Info; - - Limit : System.Address; - - begin - - -- Get stack bounds from VxWorks - - Get_Stack_Info (Stack_Info'Access); - - if Stack_Grows_Down then - Limit := - Stack_Info.Base - Storage_Offset (Stack_Info.Size) + - Storage_Offset'(12_000); - else - Limit := - Stack_Info.Base + Storage_Offset (Stack_Info.Size) - - Storage_Offset'(12_000); - end if; - - Stack_Limit := Limit; - - end Set_Stack_Limit_For_Current_Task; -end System.Stack_Checking.Operations; diff --git a/gcc/ada/s-stchop.adb b/gcc/ada/s-stchop.adb deleted file mode 100644 index 05b13dc..0000000 --- a/gcc/ada/s-stchop.adb +++ /dev/null @@ -1,279 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the general implementation of this package. There is a VxWorks --- specific version of this package (s-stchop-vxworks.adb). This file should --- be kept synchronized with it. - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the --- binder does not handle references to this package. - -with System.Storage_Elements; use System.Storage_Elements; -with System.Parameters; use System.Parameters; -with System.Soft_Links; -with System.CRTL; - -package body System.Stack_Checking.Operations is - - Kilobyte : constant := 1024; - - function Set_Stack_Info - (Stack : not null access Stack_Access) return Stack_Access; - -- The function Set_Stack_Info is the actual function that updates the - -- cache containing a pointer to the Stack_Info. It may also be used for - -- detecting asynchronous abort in combination with Invalidate_Self_Cache. - -- - -- Set_Stack_Info should do the following things in order: - -- 1) Get the Stack_Access value for the current task - -- 2) Set Stack.all to the value obtained in 1) - -- 3) Optionally Poll to check for asynchronous abort - -- - -- This order is important because if at any time a write to the stack - -- cache is pending, that write should be followed by a Poll to prevent - -- losing signals. - -- - -- Note: This function must be compiled with Polling turned off - -- - -- Note: on systems with real thread-local storage, Set_Stack_Info should - -- return an access value for such local storage. In those cases the cache - -- will always be up-to-date. - - ---------------------------- - -- Invalidate_Stack_Cache -- - ---------------------------- - - procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access) is - pragma Warnings (Off, Any_Stack); - begin - Cache := Null_Stack; - end Invalidate_Stack_Cache; - - ----------------------------- - -- Notify_Stack_Attributes -- - ----------------------------- - - procedure Notify_Stack_Attributes - (Initial_SP : System.Address; - Size : System.Storage_Elements.Storage_Offset) - is - My_Stack : constant Stack_Access := Soft_Links.Get_Stack_Info.all; - - -- We piggyback on the 'Limit' field to store what will be used as the - -- 'Base' and leave the 'Size' alone to not interfere with the logic in - -- Set_Stack_Info below. - - pragma Unreferenced (Size); - - begin - My_Stack.Limit := Initial_SP; - end Notify_Stack_Attributes; - - -------------------- - -- Set_Stack_Info -- - -------------------- - - function Set_Stack_Info - (Stack : not null access Stack_Access) return Stack_Access - is - type Frame_Mark is null record; - Frame_Location : Frame_Mark; - Frame_Address : constant Address := Frame_Location'Address; - - My_Stack : Stack_Access; - Limit_Chars : System.Address; - Limit : Integer; - - begin - -- The order of steps 1 .. 3 is important, see specification - - -- 1) Get the Stack_Access value for the current task - - My_Stack := Soft_Links.Get_Stack_Info.all; - - if My_Stack.Base = Null_Address then - - -- First invocation, initialize based on the assumption that there - -- are Environment_Stack_Size bytes available beyond the current - -- frame address. - - if My_Stack.Size = 0 then - My_Stack.Size := Storage_Offset (Default_Env_Stack_Size); - - -- When the environment variable GNAT_STACK_LIMIT is set, set - -- Environment_Stack_Size to that number of kB. - - Limit_Chars := System.CRTL.getenv ("GNAT_STACK_LIMIT" & ASCII.NUL); - - if Limit_Chars /= Null_Address then - Limit := System.CRTL.atoi (Limit_Chars); - - if Limit >= 0 then - My_Stack.Size := Storage_Offset (Limit) * Kilobyte; - end if; - end if; - end if; - - -- If a stack base address has been registered, honor it. Fallback to - -- the address of a local object otherwise. - - My_Stack.Base := - (if My_Stack.Limit /= System.Null_Address - then My_Stack.Limit else Frame_Address); - - if Stack_Grows_Down then - - -- Prevent wrap-around on too big stack sizes - - My_Stack.Limit := My_Stack.Base - My_Stack.Size; - - if My_Stack.Limit > My_Stack.Base then - My_Stack.Limit := Address'First; - end if; - - else - My_Stack.Limit := My_Stack.Base + My_Stack.Size; - - -- Prevent wrap-around on too big stack sizes - - if My_Stack.Limit < My_Stack.Base then - My_Stack.Limit := Address'Last; - end if; - end if; - end if; - - -- 2) Set Stack.all to the value obtained in 1) - - Stack.all := My_Stack; - - -- 3) Optionally Poll to check for asynchronous abort - - if Soft_Links.Check_Abort_Status.all /= 0 then - raise Standard'Abort_Signal; - end if; - - -- Never trust the cached value, but return local copy - - return My_Stack; - end Set_Stack_Info; - - ----------------- - -- Stack_Check -- - ----------------- - - function Stack_Check - (Stack_Address : System.Address) return Stack_Access - is - type Frame_Marker is null record; - Marker : Frame_Marker; - Cached_Stack : constant Stack_Access := Cache; - Frame_Address : constant System.Address := Marker'Address; - - begin - -- The parameter may have wrapped around in System.Address arithmetics. - -- In that case, we have no other choices than raising the exception. - - if (Stack_Grows_Down and then - Stack_Address > Frame_Address) - or else - (not Stack_Grows_Down and then - Stack_Address < Frame_Address) - then - raise Storage_Error with "stack overflow detected"; - end if; - - -- This function first does a "cheap" check which is correct if it - -- succeeds. In case of failure, the full check is done. Ideally the - -- cheap check should be done in an optimized manner, or be inlined. - - if (Stack_Grows_Down and then - (Frame_Address <= Cached_Stack.Base - and then - Stack_Address > Cached_Stack.Limit)) - or else - (not Stack_Grows_Down and then - (Frame_Address >= Cached_Stack.Base - and then - Stack_Address < Cached_Stack.Limit)) - then - -- Cached_Stack is valid as it passed the stack check - - return Cached_Stack; - end if; - - Full_Check : - declare - My_Stack : constant Stack_Access := Set_Stack_Info (Cache'Access); - -- At this point Stack.all might already be invalid, so - -- it is essential to use our local copy of Stack. - - begin - if (Stack_Grows_Down and then - (not (Frame_Address <= My_Stack.Base))) - or else - (not Stack_Grows_Down and then - (not (Frame_Address >= My_Stack.Base))) - then - -- The returned Base is lower than the stored one, so assume that - -- the original one wasn't right and use the current Frame_Address - -- as new one. This allows Base to be initialized with the - -- Frame_Address as approximation. During initialization the - -- Frame_Address will be close to the stack base anyway: the - -- difference should be compensated for in the stack reserve. - - My_Stack.Base := Frame_Address; - end if; - - if (Stack_Grows_Down - and then Stack_Address < My_Stack.Limit) - or else - (not Stack_Grows_Down - and then Stack_Address > My_Stack.Limit) - then - raise Storage_Error with "stack overflow detected"; - end if; - - return My_Stack; - end Full_Check; - end Stack_Check; - - ------------------------ - -- Update_Stack_Cache -- - ------------------------ - - procedure Update_Stack_Cache (Stack : Stack_Access) is - begin - if not Multi_Processor then - Cache := Stack; - end if; - end Update_Stack_Cache; - -end System.Stack_Checking.Operations; diff --git a/gcc/ada/s-stchop.ads b/gcc/ada/s-stchop.ads deleted file mode 100644 index 014eddc4..0000000 --- a/gcc/ada/s-stchop.ads +++ /dev/null @@ -1,82 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T A C K _ C H E C K I N G . O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2009, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNARL was developed by the GNARL team at Florida State University. -- --- Extensive contributions were provided by Ada Core Technologies, Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides a implementation of stack checking operations using --- comparison with stack base and limit. - -pragma Restrictions (No_Elaboration_Code); --- We want to guarantee the absence of elaboration code because the binder --- does not handle references to this package. - -pragma Polling (Off); --- Turn off polling, we do not want polling to take place during stack --- checking operations. It causes infinite loops and other problems. - -with System.Storage_Elements; - -package System.Stack_Checking.Operations is - pragma Preelaborate; - - procedure Update_Stack_Cache (Stack : Stack_Access); - -- Set the stack cache for the current task. Note that this is only for - -- optimization purposes, nothing can be assumed about the contents of the - -- cache at any time, see Set_Stack_Info. - -- - -- The stack cache should contain the bounds of the current task. But - -- because the RTS is not aware of task switches, the stack cache may be - -- incorrect. So when the stack pointer is not within the bounds of the - -- stack cache, Stack_Check first update the cache (which is a costly - -- operation hence the need of a cache). - - procedure Invalidate_Stack_Cache (Any_Stack : Stack_Access); - -- Invalidate cache entries for the task T that owns Any_Stack. This causes - -- the Set_Stack_Info function to be called during the next stack check - -- done by T. This can be used to interrupt task T asynchronously. - -- Stack_Check should be called in loops for this to work reliably. - - function Stack_Check (Stack_Address : System.Address) return Stack_Access; - -- This version of Stack_Check should not be inlined - - procedure Notify_Stack_Attributes - (Initial_SP : System.Address; - Size : System.Storage_Elements.Storage_Offset); - -- Register Initial_SP as the initial stack pointer value for the current - -- task when it starts and Size as the associated stack area size. This - -- should be called once, after the soft-links have been initialized and - -- prior to the first "Stack_Check" call. - -private - Cache : aliased Stack_Access := Null_Stack; - - pragma Export (C, Cache, "_gnat_stack_cache"); - pragma Export (C, Stack_Check, "_gnat_stack_check"); - -end System.Stack_Checking.Operations; diff --git a/gcc/ada/s-stoele.adb b/gcc/ada/s-stoele.adb deleted file mode 100644 index 1cb5f92..0000000 --- a/gcc/ada/s-stoele.adb +++ /dev/null @@ -1,131 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T O R A G E _ E L E M E N T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; - -package body System.Storage_Elements is - - pragma Suppress (All_Checks); - - -- Conversion to/from address - - -- Note qualification below of To_Address to avoid ambiguities systems - -- where Address is a visible integer type. - - function To_Address is - new Ada.Unchecked_Conversion (Storage_Offset, Address); - function To_Offset is - new Ada.Unchecked_Conversion (Address, Storage_Offset); - - -- Conversion to/from integers - - -- These functions must be place first because they are inlined_always - -- and are used and inlined in other subprograms defined in this unit. - - ---------------- - -- To_Address -- - ---------------- - - function To_Address (Value : Integer_Address) return Address is - begin - return Address (Value); - end To_Address; - - ---------------- - -- To_Integer -- - ---------------- - - function To_Integer (Value : Address) return Integer_Address is - begin - return Integer_Address (Value); - end To_Integer; - - -- Address arithmetic - - --------- - -- "+" -- - --------- - - function "+" (Left : Address; Right : Storage_Offset) return Address is - begin - return Storage_Elements.To_Address - (To_Integer (Left) + To_Integer (To_Address (Right))); - end "+"; - - function "+" (Left : Storage_Offset; Right : Address) return Address is - begin - return Storage_Elements.To_Address - (To_Integer (To_Address (Left)) + To_Integer (Right)); - end "+"; - - --------- - -- "-" -- - --------- - - function "-" (Left : Address; Right : Storage_Offset) return Address is - begin - return Storage_Elements.To_Address - (To_Integer (Left) - To_Integer (To_Address (Right))); - end "-"; - - function "-" (Left, Right : Address) return Storage_Offset is - begin - return To_Offset (Storage_Elements.To_Address - (To_Integer (Left) - To_Integer (Right))); - end "-"; - - ----------- - -- "mod" -- - ----------- - - function "mod" - (Left : Address; - Right : Storage_Offset) return Storage_Offset - is - begin - if Right > 0 then - return Storage_Offset - (To_Integer (Left) mod Integer_Address (Right)); - - -- The negative case makes no sense since it is a case of a mod where - -- the left argument is unsigned and the right argument is signed. In - -- accordance with the (spirit of the) permission of RM 13.7.1(16), - -- we raise CE, and also include the zero case here. Yes, the RM says - -- PE, but this really is so obviously more like a constraint error. - - else - raise Constraint_Error; - end if; - end "mod"; - -end System.Storage_Elements; diff --git a/gcc/ada/s-stoele.ads b/gcc/ada/s-stoele.ads deleted file mode 100644 index bf773cb..0000000 --- a/gcc/ada/s-stoele.ads +++ /dev/null @@ -1,117 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T O R A G E _ E L E M E N T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. The copyright notice above, and the license provisions that follow -- --- apply solely to the implementation dependent sections of this file. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Warning: declarations in this package are ambiguous with respect to the --- extra declarations that can be introduced into System using Extend_System. --- It is a good idea to avoid use clauses for this package. - -pragma Compiler_Unit_Warning; - -package System.Storage_Elements is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada 2005, - -- this is Pure in any case (AI-362). - - -- We also add the pragma Pure_Function to the operations in this package, - -- because otherwise functions with parameters derived from Address are - -- treated as non-pure by the back-end (see exp_ch6.adb). This is because - -- in many cases such a parameter is used to hide read/out access to - -- objects, and it would be unsafe to treat such functions as pure. - - type Storage_Offset is range - -(2 ** (Integer'(Standard'Address_Size) - 1)) .. - +(2 ** (Integer'(Standard'Address_Size) - 1)) - Long_Long_Integer'(1); - -- Note: the reason for the Long_Long_Integer qualification here is to - -- avoid a bogus ambiguity when this unit is analyzed in an rtsfind - -- context. It may be possible to remove this in the future, but it is - -- certainly harmless in any case ??? - - subtype Storage_Count is Storage_Offset range 0 .. Storage_Offset'Last; - - type Storage_Element is mod 2 ** Storage_Unit; - for Storage_Element'Size use Storage_Unit; - - pragma Universal_Aliasing (Storage_Element); - -- This type is used by the expander to implement aggregate copy - - type Storage_Array is - array (Storage_Offset range <>) of aliased Storage_Element; - for Storage_Array'Component_Size use Storage_Unit; - - -- Address arithmetic - - function "+" (Left : Address; Right : Storage_Offset) return Address; - pragma Convention (Intrinsic, "+"); - pragma Inline_Always ("+"); - pragma Pure_Function ("+"); - - function "+" (Left : Storage_Offset; Right : Address) return Address; - pragma Convention (Intrinsic, "+"); - pragma Inline_Always ("+"); - pragma Pure_Function ("+"); - - function "-" (Left : Address; Right : Storage_Offset) return Address; - pragma Convention (Intrinsic, "-"); - pragma Inline_Always ("-"); - pragma Pure_Function ("-"); - - function "-" (Left, Right : Address) return Storage_Offset; - pragma Convention (Intrinsic, "-"); - pragma Inline_Always ("-"); - pragma Pure_Function ("-"); - - function "mod" - (Left : Address; - Right : Storage_Offset) return Storage_Offset; - pragma Convention (Intrinsic, "mod"); - pragma Inline_Always ("mod"); - pragma Pure_Function ("mod"); - - -- Conversion to/from integers - - type Integer_Address is mod Memory_Size; - - function To_Address (Value : Integer_Address) return Address; - pragma Convention (Intrinsic, To_Address); - pragma Inline_Always (To_Address); - pragma Pure_Function (To_Address); - - function To_Integer (Value : Address) return Integer_Address; - pragma Convention (Intrinsic, To_Integer); - pragma Inline_Always (To_Integer); - pragma Pure_Function (To_Integer); - -end System.Storage_Elements; diff --git a/gcc/ada/s-stopoo.adb b/gcc/ada/s-stopoo.adb deleted file mode 100644 index 3ac5beb..0000000 --- a/gcc/ada/s-stopoo.adb +++ /dev/null @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T O R A G E _ P O O L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Storage_Pools is - - ------------------ - -- Allocate_Any -- - ------------------ - - procedure Allocate_Any - (Pool : in out Root_Storage_Pool'Class; - Storage_Address : out System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is - begin - Allocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment); - end Allocate_Any; - - -------------------- - -- Deallocate_Any -- - -------------------- - - procedure Deallocate_Any - (Pool : in out Root_Storage_Pool'Class; - Storage_Address : System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is - begin - Deallocate (Pool, Storage_Address, Size_In_Storage_Elements, Alignment); - end Deallocate_Any; - -end System.Storage_Pools; diff --git a/gcc/ada/s-stopoo.ads b/gcc/ada/s-stopoo.ads deleted file mode 100644 index d6153ac..0000000 --- a/gcc/ada/s-stopoo.ads +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T O R A G E _ P O O L S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Finalization; -with System.Storage_Elements; - -package System.Storage_Pools is - pragma Preelaborate; - - type Root_Storage_Pool is abstract - new Ada.Finalization.Limited_Controlled with private; - pragma Preelaborable_Initialization (Root_Storage_Pool); - - procedure Allocate - (Pool : in out Root_Storage_Pool; - Storage_Address : out System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is abstract; - - procedure Deallocate - (Pool : in out Root_Storage_Pool; - Storage_Address : System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is abstract; - - function Storage_Size - (Pool : Root_Storage_Pool) - return System.Storage_Elements.Storage_Count - is abstract; - -private - type Root_Storage_Pool is abstract - new Ada.Finalization.Limited_Controlled with null record; - - type Root_Storage_Pool_Ptr is access all Root_Storage_Pool'Class; - for Root_Storage_Pool_Ptr'Storage_Size use 0; - -- Type of the BIP_Storage_Pool extra parameter (see Exp_Ch6). The - -- Storage_Size clause is necessary, because otherwise we have a - -- chicken&egg problem; we can't be creating collection finalization code - -- in this low-level package, because that involves Pool_Global, which - -- imports this package. - - -- ??? Are these two still needed? It might be possible to use Subpools. - -- Allocate_Any_Controlled / Deallocate_Any_Controlled for non-controlled - -- objects. - - -- The following two procedures support the use of class-wide pool - -- objects in storage pools. When a local type is given a class-wide - -- storage pool, allocation and deallocation for the type must dispatch - -- to the operation of the specific pool, which is achieved by a call - -- to these procedures. (When the pool type is specific, the back-end - -- generates a call to the statically identified operation of the type). - - procedure Allocate_Any - (Pool : in out Root_Storage_Pool'Class; - Storage_Address : out System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - - procedure Deallocate_Any - (Pool : in out Root_Storage_Pool'Class; - Storage_Address : System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - -end System.Storage_Pools; diff --git a/gcc/ada/s-stposu.adb b/gcc/ada/s-stposu.adb deleted file mode 100644 index abf2013..0000000 --- a/gcc/ada/s-stposu.adb +++ /dev/null @@ -1,828 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2011-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Exceptions; use Ada.Exceptions; -with Ada.Unchecked_Conversion; - -with System.Address_Image; -with System.Finalization_Masters; use System.Finalization_Masters; -with System.IO; use System.IO; -with System.Soft_Links; use System.Soft_Links; -with System.Storage_Elements; use System.Storage_Elements; - -with System.Storage_Pools.Subpools.Finalization; -use System.Storage_Pools.Subpools.Finalization; - -package body System.Storage_Pools.Subpools is - - Finalize_Address_Table_In_Use : Boolean := False; - -- This flag should be set only when a successful allocation on a subpool - -- has been performed and the associated Finalize_Address has been added to - -- the hash table in System.Finalization_Masters. - - function Address_To_FM_Node_Ptr is - new Ada.Unchecked_Conversion (Address, FM_Node_Ptr); - - procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr); - -- Attach a subpool node to a pool - - ----------------------------------- - -- Adjust_Controlled_Dereference -- - ----------------------------------- - - procedure Adjust_Controlled_Dereference - (Addr : in out System.Address; - Storage_Size : in out System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is - Header_And_Padding : constant Storage_Offset := - Header_Size_With_Padding (Alignment); - begin - -- Expose the two hidden pointers by shifting the address from the - -- start of the object to the FM_Node equivalent of the pointers. - - Addr := Addr - Header_And_Padding; - - -- Update the size of the object to include the two pointers - - Storage_Size := Storage_Size + Header_And_Padding; - end Adjust_Controlled_Dereference; - - -------------- - -- Allocate -- - -------------- - - overriding procedure Allocate - (Pool : in out Root_Storage_Pool_With_Subpools; - Storage_Address : out System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is - begin - -- Dispatch to the user-defined implementations of Allocate_From_Subpool - -- and Default_Subpool_For_Pool. - - Allocate_From_Subpool - (Root_Storage_Pool_With_Subpools'Class (Pool), - Storage_Address, - Size_In_Storage_Elements, - Alignment, - Default_Subpool_For_Pool - (Root_Storage_Pool_With_Subpools'Class (Pool))); - end Allocate; - - ----------------------------- - -- Allocate_Any_Controlled -- - ----------------------------- - - procedure Allocate_Any_Controlled - (Pool : in out Root_Storage_Pool'Class; - Context_Subpool : Subpool_Handle; - Context_Master : Finalization_Masters.Finalization_Master_Ptr; - Fin_Address : Finalization_Masters.Finalize_Address_Ptr; - Addr : out System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count; - Is_Controlled : Boolean; - On_Subpool : Boolean) - is - Is_Subpool_Allocation : constant Boolean := - Pool in Root_Storage_Pool_With_Subpools'Class; - - Master : Finalization_Master_Ptr := null; - N_Addr : Address; - N_Ptr : FM_Node_Ptr; - N_Size : Storage_Count; - Subpool : Subpool_Handle := null; - - Header_And_Padding : Storage_Offset; - -- This offset includes the size of a FM_Node plus any additional - -- padding due to a larger alignment. - - begin - -- Step 1: Pool-related runtime checks - - -- Allocation on a pool_with_subpools. In this scenario there is a - -- master for each subpool. The master of the access type is ignored. - - if Is_Subpool_Allocation then - - -- Case of an allocation without a Subpool_Handle. Dispatch to the - -- implementation of Default_Subpool_For_Pool. - - if Context_Subpool = null then - Subpool := - Default_Subpool_For_Pool - (Root_Storage_Pool_With_Subpools'Class (Pool)); - - -- Allocation with a Subpool_Handle - - else - Subpool := Context_Subpool; - end if; - - -- Ensure proper ownership and chaining of the subpool - - if Subpool.Owner /= - Root_Storage_Pool_With_Subpools'Class (Pool)'Unchecked_Access - or else Subpool.Node = null - or else Subpool.Node.Prev = null - or else Subpool.Node.Next = null - then - raise Program_Error with "incorrect owner of subpool"; - end if; - - Master := Subpool.Master'Unchecked_Access; - - -- Allocation on a simple pool. In this scenario there is a master for - -- each access-to-controlled type. No context subpool should be present. - - else - -- If the master is missing, then the expansion of the access type - -- failed to create one. This is a compiler bug. - - pragma Assert - (Context_Master /= null, "missing master in pool allocation"); - - -- If a subpool is present, then this is the result of erroneous - -- allocator expansion. This is not a serious error, but it should - -- still be detected. - - if Context_Subpool /= null then - raise Program_Error - with "subpool not required in pool allocation"; - end if; - - -- If the allocation is intended to be on a subpool, but the access - -- type's pool does not support subpools, then this is the result of - -- incorrect end-user code. - - if On_Subpool then - raise Program_Error - with "pool of access type does not support subpools"; - end if; - - Master := Context_Master; - end if; - - -- Step 2: Master, Finalize_Address-related runtime checks and size - -- calculations. - - -- Allocation of a descendant from [Limited_]Controlled, a class-wide - -- object or a record with controlled components. - - if Is_Controlled then - - -- Synchronization: - -- Read - allocation, finalization - -- Write - finalization - - Lock_Task.all; - - -- Do not allow the allocation of controlled objects while the - -- associated master is being finalized. - - if Finalization_Started (Master.all) then - raise Program_Error with "allocation after finalization started"; - end if; - - -- Check whether primitive Finalize_Address is available. If it is - -- not, then either the expansion of the designated type failed or - -- the expansion of the allocator failed. This is a compiler bug. - - pragma Assert - (Fin_Address /= null, "primitive Finalize_Address not available"); - - -- The size must account for the hidden header preceding the object. - -- Account for possible padding space before the header due to a - -- larger alignment. - - Header_And_Padding := Header_Size_With_Padding (Alignment); - - N_Size := Storage_Size + Header_And_Padding; - - -- Non-controlled allocation - - else - N_Size := Storage_Size; - end if; - - -- Step 3: Allocation of object - - -- For descendants of Root_Storage_Pool_With_Subpools, dispatch to the - -- implementation of Allocate_From_Subpool. - - if Is_Subpool_Allocation then - Allocate_From_Subpool - (Root_Storage_Pool_With_Subpools'Class (Pool), - N_Addr, N_Size, Alignment, Subpool); - - -- For descendants of Root_Storage_Pool, dispatch to the implementation - -- of Allocate. - - else - Allocate (Pool, N_Addr, N_Size, Alignment); - end if; - - -- Step 4: Attachment - - if Is_Controlled then - - -- Note that we already did "Lock_Task.all;" in Step 2 above - - -- Map the allocated memory into a FM_Node record. This converts the - -- top of the allocated bits into a list header. If there is padding - -- due to larger alignment, the header is placed right next to the - -- object: - - -- N_Addr N_Ptr - -- | | - -- V V - -- +-------+---------------+----------------------+ - -- |Padding| Header | Object | - -- +-------+---------------+----------------------+ - -- ^ ^ ^ - -- | +- Header_Size -+ - -- | | - -- +- Header_And_Padding --+ - - N_Ptr := - Address_To_FM_Node_Ptr (N_Addr + Header_And_Padding - Header_Size); - - -- Prepend the allocated object to the finalization master - - -- Synchronization: - -- Write - allocation, deallocation, finalization - - Attach_Unprotected (N_Ptr, Objects (Master.all)); - - -- Move the address from the hidden list header to the start of the - -- object. This operation effectively hides the list header. - - Addr := N_Addr + Header_And_Padding; - - -- Homogeneous masters service the following: - - -- 1) Allocations on / Deallocations from regular pools - -- 2) Named access types - -- 3) Most cases of anonymous access types usage - - -- Synchronization: - -- Read - allocation, finalization - -- Write - outside - - if Master.Is_Homogeneous then - - -- Synchronization: - -- Read - finalization - -- Write - allocation, outside - - Set_Finalize_Address_Unprotected (Master.all, Fin_Address); - - -- Heterogeneous masters service the following: - - -- 1) Allocations on / Deallocations from subpools - -- 2) Certain cases of anonymous access types usage - - else - -- Synchronization: - -- Read - finalization - -- Write - allocation, deallocation - - Set_Heterogeneous_Finalize_Address_Unprotected (Addr, Fin_Address); - Finalize_Address_Table_In_Use := True; - end if; - - Unlock_Task.all; - - -- Non-controlled allocation - - else - Addr := N_Addr; - end if; - - exception - when others => - - -- Unlock the task in case the allocation step failed and reraise the - -- exception. - - if Is_Controlled then - Unlock_Task.all; - end if; - - raise; - end Allocate_Any_Controlled; - - ------------ - -- Attach -- - ------------ - - procedure Attach (N : not null SP_Node_Ptr; L : not null SP_Node_Ptr) is - begin - -- Ensure that the node has not been attached already - - pragma Assert (N.Prev = null and then N.Next = null); - - Lock_Task.all; - - L.Next.Prev := N; - N.Next := L.Next; - L.Next := N; - N.Prev := L; - - Unlock_Task.all; - - -- Note: No need to unlock in case of an exception because the above - -- code can never raise one. - end Attach; - - ------------------------------- - -- Deallocate_Any_Controlled -- - ------------------------------- - - procedure Deallocate_Any_Controlled - (Pool : in out Root_Storage_Pool'Class; - Addr : System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count; - Is_Controlled : Boolean) - is - N_Addr : Address; - N_Ptr : FM_Node_Ptr; - N_Size : Storage_Count; - - Header_And_Padding : Storage_Offset; - -- This offset includes the size of a FM_Node plus any additional - -- padding due to a larger alignment. - - begin - -- Step 1: Detachment - - if Is_Controlled then - Lock_Task.all; - - begin - -- Destroy the relation pair object - Finalize_Address since it is - -- no longer needed. - - if Finalize_Address_Table_In_Use then - - -- Synchronization: - -- Read - finalization - -- Write - allocation, deallocation - - Delete_Finalize_Address_Unprotected (Addr); - end if; - - -- Account for possible padding space before the header due to a - -- larger alignment. - - Header_And_Padding := Header_Size_With_Padding (Alignment); - - -- N_Addr N_Ptr Addr (from input) - -- | | | - -- V V V - -- +-------+---------------+----------------------+ - -- |Padding| Header | Object | - -- +-------+---------------+----------------------+ - -- ^ ^ ^ - -- | +- Header_Size -+ - -- | | - -- +- Header_And_Padding --+ - - -- Convert the bits preceding the object into a list header - - N_Ptr := Address_To_FM_Node_Ptr (Addr - Header_Size); - - -- Detach the object from the related finalization master. This - -- action does not need to know the prior context used during - -- allocation. - - -- Synchronization: - -- Write - allocation, deallocation, finalization - - Detach_Unprotected (N_Ptr); - - -- Move the address from the object to the beginning of the list - -- header. - - N_Addr := Addr - Header_And_Padding; - - -- The size of the deallocated object must include the size of the - -- hidden list header. - - N_Size := Storage_Size + Header_And_Padding; - - Unlock_Task.all; - - exception - when others => - - -- Unlock the task in case the computations performed above - -- fail for some reason. - - Unlock_Task.all; - raise; - end; - else - N_Addr := Addr; - N_Size := Storage_Size; - end if; - - -- Step 2: Deallocation - - -- Dispatch to the proper implementation of Deallocate. This action - -- covers both Root_Storage_Pool and Root_Storage_Pool_With_Subpools - -- implementations. - - Deallocate (Pool, N_Addr, N_Size, Alignment); - end Deallocate_Any_Controlled; - - ------------------------------ - -- Default_Subpool_For_Pool -- - ------------------------------ - - function Default_Subpool_For_Pool - (Pool : in out Root_Storage_Pool_With_Subpools) - return not null Subpool_Handle - is - pragma Unreferenced (Pool); - begin - return raise Program_Error with - "default Default_Subpool_For_Pool called; must be overridden"; - end Default_Subpool_For_Pool; - - ------------ - -- Detach -- - ------------ - - procedure Detach (N : not null SP_Node_Ptr) is - begin - -- Ensure that the node is attached to some list - - pragma Assert (N.Next /= null and then N.Prev /= null); - - Lock_Task.all; - - N.Prev.Next := N.Next; - N.Next.Prev := N.Prev; - N.Prev := null; - N.Next := null; - - Unlock_Task.all; - - -- Note: No need to unlock in case of an exception because the above - -- code can never raise one. - end Detach; - - -------------- - -- Finalize -- - -------------- - - overriding procedure Finalize (Controller : in out Pool_Controller) is - begin - Finalize_Pool (Controller.Enclosing_Pool.all); - end Finalize; - - ------------------- - -- Finalize_Pool -- - ------------------- - - procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is - Curr_Ptr : SP_Node_Ptr; - Ex_Occur : Exception_Occurrence; - Raised : Boolean := False; - - function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean; - -- Determine whether a list contains only one element, the dummy head - - ------------------- - -- Is_Empty_List -- - ------------------- - - function Is_Empty_List (L : not null SP_Node_Ptr) return Boolean is - begin - return L.Next = L and then L.Prev = L; - end Is_Empty_List; - - -- Start of processing for Finalize_Pool - - begin - -- It is possible for multiple tasks to cause the finalization of a - -- common pool. Allow only one task to finalize the contents. - - if Pool.Finalization_Started then - return; - end if; - - -- Lock the pool to prevent the creation of additional subpools while - -- the available ones are finalized. The pool remains locked because - -- either it is about to be deallocated or the associated access type - -- is about to go out of scope. - - Pool.Finalization_Started := True; - - while not Is_Empty_List (Pool.Subpools'Unchecked_Access) loop - Curr_Ptr := Pool.Subpools.Next; - - -- Perform the following actions: - - -- 1) Finalize all objects chained on the subpool's master - -- 2) Remove the subpool from the owner's list of subpools - -- 3) Deallocate the doubly linked list node associated with the - -- subpool. - -- 4) Call Deallocate_Subpool - - begin - Finalize_And_Deallocate (Curr_Ptr.Subpool); - - exception - when Fin_Occur : others => - if not Raised then - Raised := True; - Save_Occurrence (Ex_Occur, Fin_Occur); - end if; - end; - end loop; - - -- If the finalization of a particular master failed, reraise the - -- exception now. - - if Raised then - Reraise_Occurrence (Ex_Occur); - end if; - end Finalize_Pool; - - ------------------------------ - -- Header_Size_With_Padding -- - ------------------------------ - - function Header_Size_With_Padding - (Alignment : System.Storage_Elements.Storage_Count) - return System.Storage_Elements.Storage_Count - is - Size : constant Storage_Count := Header_Size; - - begin - if Size mod Alignment = 0 then - return Size; - - -- Add enough padding to reach the nearest multiple of the alignment - -- rounding up. - - else - return ((Size + Alignment - 1) / Alignment) * Alignment; - end if; - end Header_Size_With_Padding; - - ---------------- - -- Initialize -- - ---------------- - - overriding procedure Initialize (Controller : in out Pool_Controller) is - begin - Initialize_Pool (Controller.Enclosing_Pool.all); - end Initialize; - - --------------------- - -- Initialize_Pool -- - --------------------- - - procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools) is - begin - -- The dummy head must point to itself in both directions - - Pool.Subpools.Next := Pool.Subpools'Unchecked_Access; - Pool.Subpools.Prev := Pool.Subpools'Unchecked_Access; - end Initialize_Pool; - - --------------------- - -- Pool_Of_Subpool -- - --------------------- - - function Pool_Of_Subpool - (Subpool : not null Subpool_Handle) - return access Root_Storage_Pool_With_Subpools'Class - is - begin - return Subpool.Owner; - end Pool_Of_Subpool; - - ---------------- - -- Print_Pool -- - ---------------- - - procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools) is - Head : constant SP_Node_Ptr := Pool.Subpools'Unrestricted_Access; - Head_Seen : Boolean := False; - SP_Ptr : SP_Node_Ptr; - - begin - -- Output the contents of the pool - - -- Pool : 0x123456789 - -- Subpools : 0x123456789 - -- Fin_Start : TRUE FALSE - -- Controller: OK NOK - - Put ("Pool : "); - Put_Line (Address_Image (Pool'Address)); - - Put ("Subpools : "); - Put_Line (Address_Image (Pool.Subpools'Address)); - - Put ("Fin_Start : "); - Put_Line (Pool.Finalization_Started'Img); - - Put ("Controlled: "); - if Pool.Controller.Enclosing_Pool = Pool'Unrestricted_Access then - Put_Line ("OK"); - else - Put_Line ("NOK (ERROR)"); - end if; - - SP_Ptr := Head; - while SP_Ptr /= null loop -- Should never be null - Put_Line ("V"); - - -- We see the head initially; we want to exit when we see the head a - -- second time. - - if SP_Ptr = Head then - exit when Head_Seen; - - Head_Seen := True; - end if; - - -- The current element is null. This should never happend since the - -- list is circular. - - if SP_Ptr.Prev = null then - Put_Line ("null (ERROR)"); - - -- The current element points back to the correct element - - elsif SP_Ptr.Prev.Next = SP_Ptr then - Put_Line ("^"); - - -- The current element points to an erroneous element - - else - Put_Line ("? (ERROR)"); - end if; - - -- Output the contents of the node - - Put ("|Header: "); - Put (Address_Image (SP_Ptr.all'Address)); - if SP_Ptr = Head then - Put_Line (" (dummy head)"); - else - Put_Line (""); - end if; - - Put ("| Prev: "); - - if SP_Ptr.Prev = null then - Put_Line ("null"); - else - Put_Line (Address_Image (SP_Ptr.Prev.all'Address)); - end if; - - Put ("| Next: "); - - if SP_Ptr.Next = null then - Put_Line ("null"); - else - Put_Line (Address_Image (SP_Ptr.Next.all'Address)); - end if; - - Put ("| Subp: "); - - if SP_Ptr.Subpool = null then - Put_Line ("null"); - else - Put_Line (Address_Image (SP_Ptr.Subpool.all'Address)); - end if; - - SP_Ptr := SP_Ptr.Next; - end loop; - end Print_Pool; - - ------------------- - -- Print_Subpool -- - ------------------- - - procedure Print_Subpool (Subpool : Subpool_Handle) is - begin - if Subpool = null then - Put_Line ("null"); - return; - end if; - - -- Output the contents of a subpool - - -- Owner : 0x123456789 - -- Master: 0x123456789 - -- Node : 0x123456789 - - Put ("Owner : "); - if Subpool.Owner = null then - Put_Line ("null"); - else - Put_Line (Address_Image (Subpool.Owner'Address)); - end if; - - Put ("Master: "); - Put_Line (Address_Image (Subpool.Master'Address)); - - Put ("Node : "); - if Subpool.Node = null then - Put ("null"); - - if Subpool.Owner = null then - Put_Line (" OK"); - else - Put_Line (" (ERROR)"); - end if; - else - Put_Line (Address_Image (Subpool.Node'Address)); - end if; - - Print_Master (Subpool.Master); - end Print_Subpool; - - ------------------------- - -- Set_Pool_Of_Subpool -- - ------------------------- - - procedure Set_Pool_Of_Subpool - (Subpool : not null Subpool_Handle; - To : in out Root_Storage_Pool_With_Subpools'Class) - is - N_Ptr : SP_Node_Ptr; - - begin - -- If the subpool is already owned, raise Program_Error. This is a - -- direct violation of the RM rules. - - if Subpool.Owner /= null then - raise Program_Error with "subpool already belongs to a pool"; - end if; - - -- Prevent the creation of a new subpool while the owner is being - -- finalized. This is a serious error. - - if To.Finalization_Started then - raise Program_Error - with "subpool creation after finalization started"; - end if; - - Subpool.Owner := To'Unchecked_Access; - - -- Create a subpool node and decorate it. Since this node is not - -- allocated on the owner's pool, it must be explicitly destroyed by - -- Finalize_And_Detach. - - N_Ptr := new SP_Node; - N_Ptr.Subpool := Subpool; - Subpool.Node := N_Ptr; - - Attach (N_Ptr, To.Subpools'Unchecked_Access); - - -- Mark the subpool's master as being a heterogeneous collection of - -- controlled objects. - - Set_Is_Heterogeneous (Subpool.Master); - end Set_Pool_Of_Subpool; - -end System.Storage_Pools.Subpools; diff --git a/gcc/ada/s-stposu.ads b/gcc/ada/s-stposu.ads deleted file mode 100644 index f473dc2..0000000 --- a/gcc/ada/s-stposu.ads +++ /dev/null @@ -1,358 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T O R A G E _ P O O L S . S U B P O O L S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2011-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Finalization; -with System.Finalization_Masters; -with System.Storage_Elements; - -package System.Storage_Pools.Subpools is - pragma Preelaborate; - - type Root_Storage_Pool_With_Subpools is abstract - new Root_Storage_Pool with private; - -- The base for all implementations of Storage_Pool_With_Subpools. This - -- type is Limited_Controlled by derivation. To use subpools, an access - -- type must be associated with an implementation descending from type - -- Root_Storage_Pool_With_Subpools. - - type Root_Subpool is abstract tagged limited private; - -- The base for all implementations of Subpool. Objects of this type are - -- managed by the pool_with_subpools. - - type Subpool_Handle is access all Root_Subpool'Class; - for Subpool_Handle'Storage_Size use 0; - -- Since subpools are limited types by definition, a handle is instead used - -- to manage subpool abstractions. - - overriding procedure Allocate - (Pool : in out Root_Storage_Pool_With_Subpools; - Storage_Address : out System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - -- Allocate an object described by Size_In_Storage_Elements and Alignment - -- on the default subpool of Pool. Controlled types allocated through this - -- routine will NOT be handled properly. - - procedure Allocate_From_Subpool - (Pool : in out Root_Storage_Pool_With_Subpools; - Storage_Address : out System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count; - Subpool : not null Subpool_Handle) is abstract; - - -- ??? This precondition causes errors in simple tests, disabled for now - - -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; - -- This routine requires implementation. Allocate an object described by - -- Size_In_Storage_Elements and Alignment on a subpool. - - function Create_Subpool - (Pool : in out Root_Storage_Pool_With_Subpools) - return not null Subpool_Handle is abstract; - -- This routine requires implementation. Create a subpool within the given - -- pool_with_subpools. - - overriding procedure Deallocate - (Pool : in out Root_Storage_Pool_With_Subpools; - Storage_Address : System.Address; - Size_In_Storage_Elements : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count) - is null; - - procedure Deallocate_Subpool - (Pool : in out Root_Storage_Pool_With_Subpools; - Subpool : in out Subpool_Handle) - is abstract; - -- This precondition causes errors in simple tests, disabled for now??? - -- with Pre'Class => Pool_Of_Subpool (Subpool) = Pool'Access; - - -- This routine requires implementation. Reclaim the storage a particular - -- subpool occupies in a pool_with_subpools. This routine is called by - -- Ada.Unchecked_Deallocate_Subpool. - - function Default_Subpool_For_Pool - (Pool : in out Root_Storage_Pool_With_Subpools) - return not null Subpool_Handle; - -- Return a common subpool which is used for object allocations without a - -- Subpool_Handle_Name in the allocator. The default implementation of this - -- routine raises Program_Error. - - function Pool_Of_Subpool - (Subpool : not null Subpool_Handle) - return access Root_Storage_Pool_With_Subpools'Class; - -- Return the owner of the subpool - - procedure Set_Pool_Of_Subpool - (Subpool : not null Subpool_Handle; - To : in out Root_Storage_Pool_With_Subpools'Class); - -- Set the owner of the subpool. This is intended to be called from - -- Create_Subpool or similar subpool constructors. Raises Program_Error - -- if the subpool already belongs to a pool. - - overriding function Storage_Size - (Pool : Root_Storage_Pool_With_Subpools) - return System.Storage_Elements.Storage_Count - is - (System.Storage_Elements.Storage_Count'Last); - -private - -- Model - -- Pool_With_Subpools SP_Node SP_Node SP_Node - -- +-->+--------------------+ +-----+ +-----+ +-----+ - -- | | Subpools -------->| ------->| ------->| -------> - -- | +--------------------+ +-----+ +-----+ +-----+ - -- | |Finalization_Started|<------ |<------- |<------- |<--- - -- | +--------------------+ +-----+ +-----+ +-----+ - -- +--- Controller.Encl_Pool| | nul | | + | | + | - -- | +--------------------+ +-----+ +--|--+ +--:--+ - -- | : : Dummy | ^ : - -- | : : | | : - -- | Root_Subpool V | - -- | +-------------+ | - -- +-------------------------------- Owner | | - -- FM_Node FM_Node +-------------+ | - -- +-----+ +-----+<-- Master.Objects| | - -- <------ |<------ | +-------------+ | - -- +-----+ +-----+ | Node -------+ - -- | ------>| -----> +-------------+ - -- +-----+ +-----+ : : - -- |ctrl | Dummy : : - -- | obj | - -- +-----+ - -- - -- SP_Nodes are created on the heap. FM_Nodes and associated objects are - -- created on the pool_with_subpools. - - type Any_Storage_Pool_With_Subpools_Ptr - is access all Root_Storage_Pool_With_Subpools'Class; - for Any_Storage_Pool_With_Subpools_Ptr'Storage_Size use 0; - - -- A pool controller is a special controlled object which ensures the - -- proper initialization and finalization of the enclosing pool. - - type Pool_Controller (Enclosing_Pool : Any_Storage_Pool_With_Subpools_Ptr) - is new Ada.Finalization.Limited_Controlled with null record; - - -- Subpool list types. Each pool_with_subpools contains a list of subpools. - -- This is an indirect doubly linked list since subpools are not supposed - -- to be allocatable by language design. - - type SP_Node; - type SP_Node_Ptr is access all SP_Node; - - type SP_Node is record - Prev : SP_Node_Ptr := null; - Next : SP_Node_Ptr := null; - Subpool : Subpool_Handle := null; - end record; - - -- Root_Storage_Pool_With_Subpools internal structure. The type uses a - -- special controller to perform initialization and finalization actions - -- on itself. This is necessary because the end user of this package may - -- decide to override Initialize and Finalize, thus disabling the desired - -- behavior. - - -- Pool_With_Subpools SP_Node SP_Node SP_Node - -- +-->+--------------------+ +-----+ +-----+ +-----+ - -- | | Subpools -------->| ------->| ------->| -------> - -- | +--------------------+ +-----+ +-----+ +-----+ - -- | |Finalization_Started| : : : : : : - -- | +--------------------+ - -- +--- Controller.Encl_Pool| - -- +--------------------+ - -- : End-user : - -- : components : - - type Root_Storage_Pool_With_Subpools is abstract - new Root_Storage_Pool with - record - Subpools : aliased SP_Node; - -- A doubly linked list of subpools - - Finalization_Started : Boolean := False; - pragma Atomic (Finalization_Started); - -- A flag which prevents the creation of new subpools while the master - -- pool is being finalized. The flag needs to be atomic because it is - -- accessed without Lock_Task / Unlock_Task. - - Controller : Pool_Controller - (Root_Storage_Pool_With_Subpools'Unchecked_Access); - -- A component which ensures that the enclosing pool is initialized and - -- finalized at the appropriate places. - end record; - - -- A subpool is an abstraction layer which sits on top of a pool. It - -- contains links to all controlled objects allocated on a particular - -- subpool. - - -- Pool_With_Subpools SP_Node SP_Node SP_Node - -- +-->+----------------+ +-----+ +-----+ +-----+ - -- | | Subpools ------>| ------->| ------->| -------> - -- | +----------------+ +-----+ +-----+ +-----+ - -- | : :<------ |<------- |<------- | - -- | : : +-----+ +-----+ +-----+ - -- | |null | | + | | + | - -- | +-----+ +--|--+ +--:--+ - -- | | ^ : - -- | Root_Subpool V | - -- | +-------------+ | - -- +---------------------------- Owner | | - -- +-------------+ | - -- .......... Master | | - -- +-------------+ | - -- | Node -------+ - -- +-------------+ - -- : End-user : - -- : components : - - type Root_Subpool is abstract tagged limited record - Owner : Any_Storage_Pool_With_Subpools_Ptr := null; - -- A reference to the master pool_with_subpools - - Master : aliased System.Finalization_Masters.Finalization_Master; - -- A heterogeneous collection of controlled objects - - Node : SP_Node_Ptr := null; - -- A link to the doubly linked list node which contains the subpool. - -- This back pointer is used in subpool deallocation. - end record; - - procedure Adjust_Controlled_Dereference - (Addr : in out System.Address; - Storage_Size : in out System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count); - -- Given the memory attributes of a heap-allocated object that is known to - -- be controlled, adjust the address and size of the object to include the - -- two hidden pointers inserted by the finalization machinery. - - -- ??? Once Storage_Pools.Allocate_Any is removed, this should be renamed - -- to Allocate_Any. - - procedure Allocate_Any_Controlled - (Pool : in out Root_Storage_Pool'Class; - Context_Subpool : Subpool_Handle; - Context_Master : Finalization_Masters.Finalization_Master_Ptr; - Fin_Address : Finalization_Masters.Finalize_Address_Ptr; - Addr : out System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count; - Is_Controlled : Boolean; - On_Subpool : Boolean); - -- Compiler interface. This version of Allocate handles all possible cases, - -- either on a pool or a pool_with_subpools, regardless of the controlled - -- status of the allocated object. Parameter usage: - -- - -- * Pool - The pool associated with the access type. Pool can be any - -- derivation from Root_Storage_Pool, including a pool_with_subpools. - -- - -- * Context_Subpool - The subpool handle name of an allocator. If no - -- subpool handle is present at the point of allocation, the actual - -- would be null. - -- - -- * Context_Master - The finalization master associated with the access - -- type. If the access type's designated type is not controlled, the - -- actual would be null. - -- - -- * Fin_Address - TSS routine Finalize_Address of the designated type. - -- If the designated type is not controlled, the actual would be null. - -- - -- * Addr - The address of the allocated object. - -- - -- * Storage_Size - The size of the allocated object. - -- - -- * Alignment - The alignment of the allocated object. - -- - -- * Is_Controlled - A flag which determines whether the allocated object - -- is controlled. When set to True, the machinery generates additional - -- data. - -- - -- * On_Subpool - A flag which determines whether the a subpool handle - -- name is present at the point of allocation. This is used for error - -- diagnostics. - - procedure Deallocate_Any_Controlled - (Pool : in out Root_Storage_Pool'Class; - Addr : System.Address; - Storage_Size : System.Storage_Elements.Storage_Count; - Alignment : System.Storage_Elements.Storage_Count; - Is_Controlled : Boolean); - -- Compiler interface. This version of Deallocate handles all possible - -- cases, either from a pool or a pool_with_subpools, regardless of the - -- controlled status of the deallocated object. Parameter usage: - -- - -- * Pool - The pool associated with the access type. Pool can be any - -- derivation from Root_Storage_Pool, including a pool_with_subpools. - -- - -- * Addr - The address of the allocated object. - -- - -- * Storage_Size - The size of the allocated object. - -- - -- * Alignment - The alignment of the allocated object. - -- - -- * Is_Controlled - A flag which determines whether the allocated object - -- is controlled. When set to True, the machinery generates additional - -- data. - - procedure Detach (N : not null SP_Node_Ptr); - -- Unhook a subpool node from an arbitrary subpool list - - overriding procedure Finalize (Controller : in out Pool_Controller); - -- Buffer routine, calls Finalize_Pool - - procedure Finalize_Pool (Pool : in out Root_Storage_Pool_With_Subpools); - -- Iterate over all subpools of Pool, detach them one by one and finalize - -- their masters. This action first detaches a controlled object from a - -- particular master, then invokes its Finalize_Address primitive. - - function Header_Size_With_Padding - (Alignment : System.Storage_Elements.Storage_Count) - return System.Storage_Elements.Storage_Count; - -- Given an arbitrary alignment, calculate the size of the header which - -- precedes a controlled object as the nearest multiple rounded up of the - -- alignment. - - overriding procedure Initialize (Controller : in out Pool_Controller); - -- Buffer routine, calls Initialize_Pool - - procedure Initialize_Pool (Pool : in out Root_Storage_Pool_With_Subpools); - -- Setup the doubly linked list of subpools - - procedure Print_Pool (Pool : Root_Storage_Pool_With_Subpools); - -- Debug routine, output the contents of a pool_with_subpools - - procedure Print_Subpool (Subpool : Subpool_Handle); - -- Debug routine, output the contents of a subpool - -end System.Storage_Pools.Subpools; diff --git a/gcc/ada/s-stratt-xdr.adb b/gcc/ada/s-stratt-xdr.adb deleted file mode 100644 index 1c5d3cf..0000000 --- a/gcc/ada/s-stratt-xdr.adb +++ /dev/null @@ -1,1901 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R E A M _ A T T R I B U T E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1996-2016, Free Software Foundation, Inc. -- --- -- --- GARLIC is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This file is an alternate version of s-stratt.adb based on the XDR --- standard. It is especially useful for exchanging streams between two --- different systems with different basic type representations and endianness. - -pragma Warnings (Off, "*not allowed in compiler unit"); --- This body is used only when rebuilding the runtime library, not when --- building the compiler, so it's OK to depend on features that would --- otherwise break bootstrap (e.g. IF-expressions). - -with Ada.IO_Exceptions; -with Ada.Streams; use Ada.Streams; -with Ada.Unchecked_Conversion; - -package body System.Stream_Attributes is - - pragma Suppress (Range_Check); - pragma Suppress (Overflow_Check); - - use UST; - - Data_Error : exception renames Ada.IO_Exceptions.End_Error; - -- Exception raised if insufficient data read (End_Error is mandated by - -- AI95-00132). - - SU : constant := System.Storage_Unit; - -- The code in this body assumes that SU = 8 - - BB : constant := 2 ** SU; -- Byte base - BL : constant := 2 ** SU - 1; -- Byte last - BS : constant := 2 ** (SU - 1); -- Byte sign - - US : constant := Unsigned'Size; -- Unsigned size - UB : constant := (US - 1) / SU + 1; -- Unsigned byte - UL : constant := 2 ** US - 1; -- Unsigned last - - subtype SE is Ada.Streams.Stream_Element; - subtype SEA is Ada.Streams.Stream_Element_Array; - subtype SEO is Ada.Streams.Stream_Element_Offset; - - generic function UC renames Ada.Unchecked_Conversion; - - type Field_Type is - record - E_Size : Integer; -- Exponent bit size - E_Bias : Integer; -- Exponent bias - F_Size : Integer; -- Fraction bit size - E_Last : Integer; -- Max exponent value - F_Mask : SE; -- Mask to apply on first fraction byte - E_Bytes : SEO; -- N. of exponent bytes completely used - F_Bytes : SEO; -- N. of fraction bytes completely used - F_Bits : Integer; -- N. of bits used on first fraction word - end record; - - type Precision is (Single, Double, Quadruple); - - Fields : constant array (Precision) of Field_Type := ( - - -- Single precision - - (E_Size => 8, - E_Bias => 127, - F_Size => 23, - E_Last => 2 ** 8 - 1, - F_Mask => 16#7F#, -- 2 ** 7 - 1, - E_Bytes => 2, - F_Bytes => 3, - F_Bits => 23 mod US), - - -- Double precision - - (E_Size => 11, - E_Bias => 1023, - F_Size => 52, - E_Last => 2 ** 11 - 1, - F_Mask => 16#0F#, -- 2 ** 4 - 1, - E_Bytes => 2, - F_Bytes => 7, - F_Bits => 52 mod US), - - -- Quadruple precision - - (E_Size => 15, - E_Bias => 16383, - F_Size => 112, - E_Last => 2 ** 8 - 1, - F_Mask => 16#FF#, -- 2 ** 8 - 1, - E_Bytes => 2, - F_Bytes => 14, - F_Bits => 112 mod US)); - - -- The representation of all items requires a multiple of four bytes - -- (or 32 bits) of data. The bytes are numbered 0 through n-1. The bytes - -- are read or written to some byte stream such that byte m always - -- precedes byte m+1. If the n bytes needed to contain the data are not - -- a multiple of four, then the n bytes are followed by enough (0 to 3) - -- residual zero bytes, r, to make the total byte count a multiple of 4. - - -- An XDR signed integer is a 32-bit datum that encodes an integer - -- in the range [-2147483648,2147483647]. The integer is represented - -- in two's complement notation. The most and least significant bytes - -- are 0 and 3, respectively. Integers are declared as follows: - - -- (MSB) (LSB) - -- +-------+-------+-------+-------+ - -- |byte 0 |byte 1 |byte 2 |byte 3 | - -- +-------+-------+-------+-------+ - -- <------------32 bits------------> - - SSI_L : constant := 1; - SI_L : constant := 2; - I_L : constant := 4; - LI_L : constant := 8; - LLI_L : constant := 8; - - subtype XDR_S_SSI is SEA (1 .. SSI_L); - subtype XDR_S_SI is SEA (1 .. SI_L); - subtype XDR_S_I is SEA (1 .. I_L); - subtype XDR_S_LI is SEA (1 .. LI_L); - subtype XDR_S_LLI is SEA (1 .. LLI_L); - - function Short_Short_Integer_To_XDR_S_SSI is - new Ada.Unchecked_Conversion (Short_Short_Integer, XDR_S_SSI); - function XDR_S_SSI_To_Short_Short_Integer is - new Ada.Unchecked_Conversion (XDR_S_SSI, Short_Short_Integer); - - function Short_Integer_To_XDR_S_SI is - new Ada.Unchecked_Conversion (Short_Integer, XDR_S_SI); - function XDR_S_SI_To_Short_Integer is - new Ada.Unchecked_Conversion (XDR_S_SI, Short_Integer); - - function Integer_To_XDR_S_I is - new Ada.Unchecked_Conversion (Integer, XDR_S_I); - function XDR_S_I_To_Integer is - new Ada.Unchecked_Conversion (XDR_S_I, Integer); - - function Long_Long_Integer_To_XDR_S_LI is - new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LI); - function XDR_S_LI_To_Long_Long_Integer is - new Ada.Unchecked_Conversion (XDR_S_LI, Long_Long_Integer); - - function Long_Long_Integer_To_XDR_S_LLI is - new Ada.Unchecked_Conversion (Long_Long_Integer, XDR_S_LLI); - function XDR_S_LLI_To_Long_Long_Integer is - new Ada.Unchecked_Conversion (XDR_S_LLI, Long_Long_Integer); - - -- An XDR unsigned integer is a 32-bit datum that encodes a nonnegative - -- integer in the range [0,4294967295]. It is represented by an unsigned - -- binary number whose most and least significant bytes are 0 and 3, - -- respectively. An unsigned integer is declared as follows: - - -- (MSB) (LSB) - -- +-------+-------+-------+-------+ - -- |byte 0 |byte 1 |byte 2 |byte 3 | - -- +-------+-------+-------+-------+ - -- <------------32 bits------------> - - SSU_L : constant := 1; - SU_L : constant := 2; - U_L : constant := 4; - LU_L : constant := 8; - LLU_L : constant := 8; - - subtype XDR_S_SSU is SEA (1 .. SSU_L); - subtype XDR_S_SU is SEA (1 .. SU_L); - subtype XDR_S_U is SEA (1 .. U_L); - subtype XDR_S_LU is SEA (1 .. LU_L); - subtype XDR_S_LLU is SEA (1 .. LLU_L); - - type XDR_SSU is mod BB ** SSU_L; - type XDR_SU is mod BB ** SU_L; - type XDR_U is mod BB ** U_L; - - function Short_Unsigned_To_XDR_S_SU is - new Ada.Unchecked_Conversion (Short_Unsigned, XDR_S_SU); - function XDR_S_SU_To_Short_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_SU, Short_Unsigned); - - function Unsigned_To_XDR_S_U is - new Ada.Unchecked_Conversion (Unsigned, XDR_S_U); - function XDR_S_U_To_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_U, Unsigned); - - function Long_Long_Unsigned_To_XDR_S_LU is - new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LU); - function XDR_S_LU_To_Long_Long_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_LU, Long_Long_Unsigned); - - function Long_Long_Unsigned_To_XDR_S_LLU is - new Ada.Unchecked_Conversion (Long_Long_Unsigned, XDR_S_LLU); - function XDR_S_LLU_To_Long_Long_Unsigned is - new Ada.Unchecked_Conversion (XDR_S_LLU, Long_Long_Unsigned); - - -- The standard defines the floating-point data type "float" (32 bits - -- or 4 bytes). The encoding used is the IEEE standard for normalized - -- single-precision floating-point numbers. - - -- The standard defines the encoding used for the double-precision - -- floating-point data type "double" (64 bits or 8 bytes). The encoding - -- used is the IEEE standard for normalized double-precision floating-point - -- numbers. - - SF_L : constant := 4; -- Single precision - F_L : constant := 4; -- Single precision - LF_L : constant := 8; -- Double precision - LLF_L : constant := 16; -- Quadruple precision - - TM_L : constant := 8; - subtype XDR_S_TM is SEA (1 .. TM_L); - type XDR_TM is mod BB ** TM_L; - - type XDR_SA is mod 2 ** Standard'Address_Size; - function To_XDR_SA is new UC (System.Address, XDR_SA); - function To_XDR_SA is new UC (XDR_SA, System.Address); - - -- Enumerations have the same representation as signed integers. - -- Enumerations are handy for describing subsets of the integers. - - -- Booleans are important enough and occur frequently enough to warrant - -- their own explicit type in the standard. Booleans are declared as - -- an enumeration, with FALSE = 0 and TRUE = 1. - - -- The standard defines a string of n (numbered 0 through n-1) ASCII - -- bytes to be the number n encoded as an unsigned integer (as described - -- above), and followed by the n bytes of the string. Byte m of the string - -- always precedes byte m+1 of the string, and byte 0 of the string always - -- follows the string's length. If n is not a multiple of four, then the - -- n bytes are followed by enough (0 to 3) residual zero bytes, r, to make - -- the total byte count a multiple of four. - - -- To fit with XDR string, do not consider character as an enumeration - -- type. - - C_L : constant := 1; - subtype XDR_S_C is SEA (1 .. C_L); - - -- Consider Wide_Character as an enumeration type - - WC_L : constant := 4; - subtype XDR_S_WC is SEA (1 .. WC_L); - type XDR_WC is mod BB ** WC_L; - - -- Consider Wide_Wide_Character as an enumeration type - - WWC_L : constant := 8; - subtype XDR_S_WWC is SEA (1 .. WWC_L); - type XDR_WWC is mod BB ** WWC_L; - - -- Optimization: if we already have the correct Bit_Order, then some - -- computations can be avoided since the source and the target will be - -- identical anyway. They will be replaced by direct unchecked - -- conversions. - - Optimize_Integers : constant Boolean := - Default_Bit_Order = High_Order_First; - - ----------------- - -- Block_IO_OK -- - ----------------- - - -- We must inhibit Block_IO, because in XDR mode, each element is output - -- according to XDR requirements, which is not at all the same as writing - -- the whole array in one block. - - function Block_IO_OK return Boolean is - begin - return False; - end Block_IO_OK; - - ---------- - -- I_AD -- - ---------- - - function I_AD (Stream : not null access RST) return Fat_Pointer is - FP : Fat_Pointer; - - begin - FP.P1 := I_AS (Stream).P1; - FP.P2 := I_AS (Stream).P1; - - return FP; - end I_AD; - - ---------- - -- I_AS -- - ---------- - - function I_AS (Stream : not null access RST) return Thin_Pointer is - S : XDR_S_TM; - L : SEO; - U : XDR_TM := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_TM (S (N)); - end loop; - - return (P1 => To_XDR_SA (XDR_SA (U))); - end if; - end I_AS; - - --------- - -- I_B -- - --------- - - function I_B (Stream : not null access RST) return Boolean is - begin - case I_SSU (Stream) is - when 0 => return False; - when 1 => return True; - when others => raise Data_Error; - end case; - end I_B; - - --------- - -- I_C -- - --------- - - function I_C (Stream : not null access RST) return Character is - S : XDR_S_C; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - -- Use Ada requirements on Character representation clause - - return Character'Val (S (1)); - end if; - end I_C; - - --------- - -- I_F -- - --------- - - function I_F (Stream : not null access RST) return Float is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Is_Positive : Boolean; - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Result : Float; - S : SEA (1 .. F_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Unsigned (S (F_L + 1 - F_Bytes) and F_Mask); - for N in F_L + 2 - F_Bytes .. F_L loop - Fraction := Fraction * BB + Long_Unsigned (S (N)); - end loop; - Result := Float'Scaling (Float (Fraction), -F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_F; - - --------- - -- I_I -- - --------- - - function I_I (Stream : not null access RST) return Integer is - S : XDR_S_I; - L : SEO; - U : XDR_U := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_I_To_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_U (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Integer (U); - - else - return Integer (-((XDR_U'Last xor U) + 1)); - end if; - end if; - end I_I; - - ---------- - -- I_LF -- - ---------- - - function I_LF (Stream : not null access RST) return Long_Float is - I : constant Precision := Double; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Is_Positive : Boolean; - Exponent : Long_Unsigned; - Fraction : Long_Long_Unsigned; - Result : Long_Float; - S : SEA (1 .. LF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Long_Unsigned (S (LF_L + 1 - F_Bytes) and F_Mask); - for N in LF_L + 2 - F_Bytes .. LF_L loop - Fraction := Fraction * BB + Long_Long_Unsigned (S (N)); - end loop; - - Result := Long_Float'Scaling (Long_Float (Fraction), -F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Long_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Long_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_LF; - - ---------- - -- I_LI -- - ---------- - - function I_LI (Stream : not null access RST) return Long_Integer is - S : XDR_S_LI; - L : SEO; - U : Unsigned := 0; - X : Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return Long_Integer (XDR_S_LI_To_Long_Long_Integer (S)); - - else - - -- Compute using machine unsigned - -- rather than long_long_unsigned - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Unsigned (U); - U := 0; - end if; - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Long_Integer (X); - else - return Long_Integer (-((Long_Unsigned'Last xor X) + 1)); - end if; - - end if; - end I_LI; - - ----------- - -- I_LLF -- - ----------- - - function I_LLF (Stream : not null access RST) return Long_Long_Float is - I : constant Precision := Quadruple; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Is_Positive : Boolean; - Exponent : Long_Unsigned; - Fraction_1 : Long_Long_Unsigned := 0; - Fraction_2 : Long_Long_Unsigned := 0; - Result : Long_Long_Float; - HF : constant Natural := F_Size / 2; - S : SEA (1 .. LLF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - for I in LLF_L - F_Bytes + 1 .. LLF_L - 7 loop - Fraction_1 := Fraction_1 * BB + Long_Long_Unsigned (S (I)); - end loop; - - for I in SEO (LLF_L - 6) .. SEO (LLF_L) loop - Fraction_2 := Fraction_2 * BB + Long_Long_Unsigned (S (I)); - end loop; - - Result := Long_Long_Float'Scaling (Long_Long_Float (Fraction_2), -HF); - Result := Long_Long_Float (Fraction_1) + Result; - Result := Long_Long_Float'Scaling (Result, HF - F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction_1 = 0 and then Fraction_2 = 0 then - null; - - -- Denormalized float - - else - Result := Long_Long_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Long_Long_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_LLF; - - ----------- - -- I_LLI -- - ----------- - - function I_LLI (Stream : not null access RST) return Long_Long_Integer is - S : XDR_S_LLI; - L : SEO; - U : Unsigned := 0; - X : Long_Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_LLI_To_Long_Long_Integer (S); - - else - -- Compute using machine unsigned for computing - -- rather than long_long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Long_Unsigned (U); - U := 0; - end if; - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Long_Long_Integer (X); - else - return Long_Long_Integer (-((Long_Long_Unsigned'Last xor X) + 1)); - end if; - end if; - end I_LLI; - - ----------- - -- I_LLU -- - ----------- - - function I_LLU (Stream : not null access RST) return Long_Long_Unsigned is - S : XDR_S_LLU; - L : SEO; - U : Unsigned := 0; - X : Long_Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_LLU_To_Long_Long_Unsigned (S); - - else - -- Compute using machine unsigned - -- rather than long_long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Long_Unsigned (U); - U := 0; - end if; - end loop; - - return X; - end if; - end I_LLU; - - ---------- - -- I_LU -- - ---------- - - function I_LU (Stream : not null access RST) return Long_Unsigned is - S : XDR_S_LU; - L : SEO; - U : Unsigned := 0; - X : Long_Unsigned := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return Long_Unsigned (XDR_S_LU_To_Long_Long_Unsigned (S)); - - else - -- Compute using machine unsigned - -- rather than long_unsigned. - - for N in S'Range loop - U := U * BB + Unsigned (S (N)); - - -- We have filled an unsigned - - if N mod UB = 0 then - X := Shift_Left (X, US) + Long_Unsigned (U); - U := 0; - end if; - end loop; - - return X; - end if; - end I_LU; - - ---------- - -- I_SF -- - ---------- - - function I_SF (Stream : not null access RST) return Short_Float is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Last : Integer renames Fields (I).E_Last; - F_Mask : SE renames Fields (I).F_Mask; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - Result : Short_Float; - S : SEA (1 .. SF_L); - L : SEO; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - end if; - - -- Extract Fraction, Sign and Exponent - - Fraction := Long_Unsigned (S (SF_L + 1 - F_Bytes) and F_Mask); - for N in SF_L + 2 - F_Bytes .. SF_L loop - Fraction := Fraction * BB + Long_Unsigned (S (N)); - end loop; - Result := Short_Float'Scaling (Short_Float (Fraction), -F_Size); - - if BS <= S (1) then - Is_Positive := False; - Exponent := Long_Unsigned (S (1) - BS); - else - Is_Positive := True; - Exponent := Long_Unsigned (S (1)); - end if; - - for N in 2 .. E_Bytes loop - Exponent := Exponent * BB + Long_Unsigned (S (N)); - end loop; - Exponent := Shift_Right (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - - -- NaN or Infinities - - if Integer (Exponent) = E_Last then - raise Constraint_Error; - - elsif Exponent = 0 then - - -- Signed zeros - - if Fraction = 0 then - null; - - -- Denormalized float - - else - Result := Short_Float'Scaling (Result, 1 - E_Bias); - end if; - - -- Normalized float - - else - Result := Short_Float'Scaling - (1.0 + Result, Integer (Exponent) - E_Bias); - end if; - - if not Is_Positive then - Result := -Result; - end if; - - return Result; - end I_SF; - - ---------- - -- I_SI -- - ---------- - - function I_SI (Stream : not null access RST) return Short_Integer is - S : XDR_S_SI; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SI_To_Short_Integer (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Integer (U); - else - return Short_Integer (-((XDR_SU'Last xor U) + 1)); - end if; - end if; - end I_SI; - - ----------- - -- I_SSI -- - ----------- - - function I_SSI (Stream : not null access RST) return Short_Short_Integer is - S : XDR_S_SSI; - L : SEO; - U : XDR_SSU; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SSI_To_Short_Short_Integer (S); - - else - U := XDR_SSU (S (1)); - - -- Test sign and apply two complement notation - - if S (1) < BL then - return Short_Short_Integer (U); - else - return Short_Short_Integer (-((XDR_SSU'Last xor U) + 1)); - end if; - end if; - end I_SSI; - - ----------- - -- I_SSU -- - ----------- - - function I_SSU (Stream : not null access RST) return Short_Short_Unsigned is - S : XDR_S_SSU; - L : SEO; - U : XDR_SSU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - U := XDR_SSU (S (1)); - return Short_Short_Unsigned (U); - end if; - end I_SSU; - - ---------- - -- I_SU -- - ---------- - - function I_SU (Stream : not null access RST) return Short_Unsigned is - S : XDR_S_SU; - L : SEO; - U : XDR_SU := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_SU_To_Short_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_SU (S (N)); - end loop; - - return Short_Unsigned (U); - end if; - end I_SU; - - --------- - -- I_U -- - --------- - - function I_U (Stream : not null access RST) return Unsigned is - S : XDR_S_U; - L : SEO; - U : XDR_U := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - elsif Optimize_Integers then - return XDR_S_U_To_Unsigned (S); - - else - for N in S'Range loop - U := U * BB + XDR_U (S (N)); - end loop; - - return Unsigned (U); - end if; - end I_U; - - ---------- - -- I_WC -- - ---------- - - function I_WC (Stream : not null access RST) return Wide_Character is - S : XDR_S_WC; - L : SEO; - U : XDR_WC := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_WC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Character representation clause - - return Wide_Character'Val (U); - end if; - end I_WC; - - ----------- - -- I_WWC -- - ----------- - - function I_WWC (Stream : not null access RST) return Wide_Wide_Character is - S : XDR_S_WWC; - L : SEO; - U : XDR_WWC := 0; - - begin - Ada.Streams.Read (Stream.all, S, L); - - if L /= S'Last then - raise Data_Error; - - else - for N in S'Range loop - U := U * BB + XDR_WWC (S (N)); - end loop; - - -- Use Ada requirements on Wide_Wide_Character representation clause - - return Wide_Wide_Character'Val (U); - end if; - end I_WWC; - - ---------- - -- W_AD -- - ---------- - - procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is - S : XDR_S_TM; - U : XDR_TM; - - begin - U := XDR_TM (To_XDR_SA (Item.P1)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - U := XDR_TM (To_XDR_SA (Item.P2)); - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AD; - - ---------- - -- W_AS -- - ---------- - - procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is - S : XDR_S_TM; - U : XDR_TM := XDR_TM (To_XDR_SA (Item.P1)); - - begin - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_AS; - - --------- - -- W_B -- - --------- - - procedure W_B (Stream : not null access RST; Item : Boolean) is - begin - if Item then - W_SSU (Stream, 1); - else - W_SSU (Stream, 0); - end if; - end W_B; - - --------- - -- W_C -- - --------- - - procedure W_C (Stream : not null access RST; Item : Character) is - S : XDR_S_C; - - pragma Assert (C_L = 1); - - begin - -- Use Ada requirements on Character representation clause - - S (1) := SE (Character'Pos (Item)); - - Ada.Streams.Write (Stream.all, S); - end W_C; - - --------- - -- W_F -- - --------- - - procedure W_F (Stream : not null access RST; Item : Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Float; - S : SEA (1 .. F_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Float'Scaling (F, F_Size + E_Bias - 1); - E := -E_Bias; - else - F := Float'Scaling (Float'Fraction (F), F_Size + 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse F_L - F_Bytes + 1 .. F_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (F_L - F_Bytes + 1) := S (F_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_F; - - --------- - -- W_I -- - --------- - - procedure W_I (Stream : not null access RST; Item : Integer) is - S : XDR_S_I; - U : XDR_U; - - begin - if Optimize_Integers then - S := Integer_To_XDR_S_I (Item); - - else - -- Test sign and apply two complement notation - - U := (if Item < 0 - then XDR_U'Last xor XDR_U (-(Item + 1)) - else XDR_U (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_I; - - ---------- - -- W_LF -- - ---------- - - procedure W_LF (Stream : not null access RST; Item : Long_Float) is - I : constant Precision := Double; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Long_Float; - S : SEA (1 .. LF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Long_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Long_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse LF_L - F_Bytes + 1 .. LF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (LF_L - F_Bytes + 1) := S (LF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LF; - - ---------- - -- W_LI -- - ---------- - - procedure W_LI (Stream : not null access RST; Item : Long_Integer) is - S : XDR_S_LI; - U : Unsigned; - X : Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LI (Long_Long_Integer (Item)); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Unsigned'Last xor Long_Unsigned (-(Item + 1)); - else - X := Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LI; - - ----------- - -- W_LLF -- - ----------- - - procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is - I : constant Precision := Quadruple; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - - HFS : constant Integer := F_Size / 2; - - Exponent : Long_Unsigned; - Fraction_1 : Long_Long_Unsigned; - Fraction_2 : Long_Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Long_Long_Float := Item; - S : SEA (1 .. LLF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - - if F < 0.0 then - F := -Item; - end if; - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction_1 := 0; - Fraction_2 := 0; - - else - E := Long_Long_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - F := Long_Long_Float'Scaling (F, E_Bias - 1); - E := -E_Bias; - else - F := Long_Long_Float'Scaling - (Long_Long_Float'Fraction (F), 1); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - F := Long_Long_Float'Scaling (F, F_Size - HFS); - Fraction_1 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - F := F - Long_Long_Float (Fraction_1); - F := Long_Long_Float'Scaling (F, HFS); - Fraction_2 := Long_Long_Unsigned (Long_Long_Float'Floor (F)); - end if; - - -- Store Fraction_1 - - for I in reverse LLF_L - F_Bytes + 1 .. LLF_L - 7 loop - S (I) := SE (Fraction_1 mod BB); - Fraction_1 := Fraction_1 / BB; - end loop; - - -- Store Fraction_2 - - for I in reverse LLF_L - 6 .. LLF_L loop - S (SEO (I)) := SE (Fraction_2 mod BB); - Fraction_2 := Fraction_2 / BB; - end loop; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLF; - - ----------- - -- W_LLI -- - ----------- - - procedure W_LLI - (Stream : not null access RST; - Item : Long_Long_Integer) - is - S : XDR_S_LLI; - U : Unsigned; - X : Long_Long_Unsigned; - - begin - if Optimize_Integers then - S := Long_Long_Integer_To_XDR_S_LLI (Item); - - else - -- Test sign and apply two complement notation - - if Item < 0 then - X := Long_Long_Unsigned'Last xor Long_Long_Unsigned (-(Item + 1)); - else - X := Long_Long_Unsigned (Item); - end if; - - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLI; - - ----------- - -- W_LLU -- - ----------- - - procedure W_LLU - (Stream : not null access RST; - Item : Long_Long_Unsigned) - is - S : XDR_S_LLU; - U : Unsigned; - X : Long_Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LLU (Item); - - else - -- Compute using machine unsigned rather than long_long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LLU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LLU; - - ---------- - -- W_LU -- - ---------- - - procedure W_LU (Stream : not null access RST; Item : Long_Unsigned) is - S : XDR_S_LU; - U : Unsigned; - X : Long_Unsigned := Item; - - begin - if Optimize_Integers then - S := Long_Long_Unsigned_To_XDR_S_LU (Long_Long_Unsigned (Item)); - - else - -- Compute using machine unsigned rather than long_unsigned - - for N in reverse S'Range loop - - -- We have filled an unsigned - - if (LU_L - N) mod UB = 0 then - U := Unsigned (X and UL); - X := Shift_Right (X, US); - end if; - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_LU; - - ---------- - -- W_SF -- - ---------- - - procedure W_SF (Stream : not null access RST; Item : Short_Float) is - I : constant Precision := Single; - E_Size : Integer renames Fields (I).E_Size; - E_Bias : Integer renames Fields (I).E_Bias; - E_Bytes : SEO renames Fields (I).E_Bytes; - F_Bytes : SEO renames Fields (I).F_Bytes; - F_Size : Integer renames Fields (I).F_Size; - F_Mask : SE renames Fields (I).F_Mask; - - Exponent : Long_Unsigned; - Fraction : Long_Unsigned; - Is_Positive : Boolean; - E : Integer; - F : Short_Float; - S : SEA (1 .. SF_L) := (others => 0); - - begin - if not Item'Valid then - raise Constraint_Error; - end if; - - -- Compute Sign - - Is_Positive := (0.0 <= Item); - F := abs (Item); - - -- Signed zero - - if F = 0.0 then - Exponent := 0; - Fraction := 0; - - else - E := Short_Float'Exponent (F) - 1; - - -- Denormalized float - - if E <= -E_Bias then - E := -E_Bias; - F := Short_Float'Scaling (F, F_Size + E_Bias - 1); - else - F := Short_Float'Scaling (F, F_Size - E); - end if; - - -- Compute Exponent and Fraction - - Exponent := Long_Unsigned (E + E_Bias); - Fraction := Long_Unsigned (F * 2.0) / 2; - end if; - - -- Store Fraction - - for I in reverse SF_L - F_Bytes + 1 .. SF_L loop - S (I) := SE (Fraction mod BB); - Fraction := Fraction / BB; - end loop; - - -- Remove implicit bit - - S (SF_L - F_Bytes + 1) := S (SF_L - F_Bytes + 1) and F_Mask; - - -- Store Exponent (not always at the beginning of a byte) - - Exponent := Shift_Left (Exponent, Integer (E_Bytes) * SU - E_Size - 1); - for N in reverse 1 .. E_Bytes loop - S (N) := SE (Exponent mod BB) + S (N); - Exponent := Exponent / BB; - end loop; - - -- Store Sign - - if not Is_Positive then - S (1) := S (1) + BS; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SF; - - ---------- - -- W_SI -- - ---------- - - procedure W_SI (Stream : not null access RST; Item : Short_Integer) is - S : XDR_S_SI; - U : XDR_SU; - - begin - if Optimize_Integers then - S := Short_Integer_To_XDR_S_SI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SU'Last xor XDR_SU (-(Item + 1)) - else XDR_SU (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SI; - - ----------- - -- W_SSI -- - ----------- - - procedure W_SSI - (Stream : not null access RST; - Item : Short_Short_Integer) - is - S : XDR_S_SSI; - U : XDR_SSU; - - begin - if Optimize_Integers then - S := Short_Short_Integer_To_XDR_S_SSI (Item); - - else - -- Test sign and apply two complement's notation - - U := (if Item < 0 - then XDR_SSU'Last xor XDR_SSU (-(Item + 1)) - else XDR_SSU (Item)); - - S (1) := SE (U); - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SSI; - - ----------- - -- W_SSU -- - ----------- - - procedure W_SSU - (Stream : not null access RST; - Item : Short_Short_Unsigned) - is - U : constant XDR_SSU := XDR_SSU (Item); - S : XDR_S_SSU; - - begin - S (1) := SE (U); - Ada.Streams.Write (Stream.all, S); - end W_SSU; - - ---------- - -- W_SU -- - ---------- - - procedure W_SU (Stream : not null access RST; Item : Short_Unsigned) is - S : XDR_S_SU; - U : XDR_SU := XDR_SU (Item); - - begin - if Optimize_Integers then - S := Short_Unsigned_To_XDR_S_SU (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_SU; - - --------- - -- W_U -- - --------- - - procedure W_U (Stream : not null access RST; Item : Unsigned) is - S : XDR_S_U; - U : XDR_U := XDR_U (Item); - - begin - if Optimize_Integers then - S := Unsigned_To_XDR_S_U (Item); - - else - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - if U /= 0 then - raise Data_Error; - end if; - end if; - - Ada.Streams.Write (Stream.all, S); - end W_U; - - ---------- - -- W_WC -- - ---------- - - procedure W_WC (Stream : not null access RST; Item : Wide_Character) is - S : XDR_S_WC; - U : XDR_WC; - - begin - -- Use Ada requirements on Wide_Character representation clause - - U := XDR_WC (Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WC; - - ----------- - -- W_WWC -- - ----------- - - procedure W_WWC - (Stream : not null access RST; Item : Wide_Wide_Character) - is - S : XDR_S_WWC; - U : XDR_WWC; - - begin - -- Use Ada requirements on Wide_Wide_Character representation clause - - U := XDR_WWC (Wide_Wide_Character'Pos (Item)); - - for N in reverse S'Range loop - S (N) := SE (U mod BB); - U := U / BB; - end loop; - - Ada.Streams.Write (Stream.all, S); - - if U /= 0 then - raise Data_Error; - end if; - end W_WWC; - -end System.Stream_Attributes; diff --git a/gcc/ada/s-stratt.adb b/gcc/ada/s-stratt.adb deleted file mode 100644 index 796665f..0000000 --- a/gcc/ada/s-stratt.adb +++ /dev/null @@ -1,708 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R E A M _ A T T R I B U T E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.IO_Exceptions; -with Ada.Streams; use Ada.Streams; -with Ada.Unchecked_Conversion; - -package body System.Stream_Attributes is - - Err : exception renames Ada.IO_Exceptions.End_Error; - -- Exception raised if insufficient data read (note that the RM implies - -- that Data_Error might be the appropriate choice, but AI95-00132 - -- decides with a binding interpretation that End_Error is preferred). - - SU : constant := System.Storage_Unit; - - subtype SEA is Ada.Streams.Stream_Element_Array; - subtype SEO is Ada.Streams.Stream_Element_Offset; - - generic function UC renames Ada.Unchecked_Conversion; - - -- Subtypes used to define Stream_Element_Array values that map - -- into the elementary types, using unchecked conversion. - - Thin_Pointer_Size : constant := System.Address'Size; - Fat_Pointer_Size : constant := System.Address'Size * 2; - - subtype S_AD is SEA (1 .. (Fat_Pointer_Size + SU - 1) / SU); - subtype S_AS is SEA (1 .. (Thin_Pointer_Size + SU - 1) / SU); - subtype S_B is SEA (1 .. (Boolean'Size + SU - 1) / SU); - subtype S_C is SEA (1 .. (Character'Size + SU - 1) / SU); - subtype S_F is SEA (1 .. (Float'Size + SU - 1) / SU); - subtype S_I is SEA (1 .. (Integer'Size + SU - 1) / SU); - subtype S_LF is SEA (1 .. (Long_Float'Size + SU - 1) / SU); - subtype S_LI is SEA (1 .. (Long_Integer'Size + SU - 1) / SU); - subtype S_LLF is SEA (1 .. (Long_Long_Float'Size + SU - 1) / SU); - subtype S_LLI is SEA (1 .. (Long_Long_Integer'Size + SU - 1) / SU); - subtype S_LLU is SEA (1 .. (UST.Long_Long_Unsigned'Size + SU - 1) / SU); - subtype S_LU is SEA (1 .. (UST.Long_Unsigned'Size + SU - 1) / SU); - subtype S_SF is SEA (1 .. (Short_Float'Size + SU - 1) / SU); - subtype S_SI is SEA (1 .. (Short_Integer'Size + SU - 1) / SU); - subtype S_SSI is SEA (1 .. (Short_Short_Integer'Size + SU - 1) / SU); - subtype S_SSU is SEA (1 .. (UST.Short_Short_Unsigned'Size + SU - 1) / SU); - subtype S_SU is SEA (1 .. (UST.Short_Unsigned'Size + SU - 1) / SU); - subtype S_U is SEA (1 .. (UST.Unsigned'Size + SU - 1) / SU); - subtype S_WC is SEA (1 .. (Wide_Character'Size + SU - 1) / SU); - subtype S_WWC is SEA (1 .. (Wide_Wide_Character'Size + SU - 1) / SU); - - -- Unchecked conversions from the elementary type to the stream type - - function From_AD is new UC (Fat_Pointer, S_AD); - function From_AS is new UC (Thin_Pointer, S_AS); - function From_F is new UC (Float, S_F); - function From_I is new UC (Integer, S_I); - function From_LF is new UC (Long_Float, S_LF); - function From_LI is new UC (Long_Integer, S_LI); - function From_LLF is new UC (Long_Long_Float, S_LLF); - function From_LLI is new UC (Long_Long_Integer, S_LLI); - function From_LLU is new UC (UST.Long_Long_Unsigned, S_LLU); - function From_LU is new UC (UST.Long_Unsigned, S_LU); - function From_SF is new UC (Short_Float, S_SF); - function From_SI is new UC (Short_Integer, S_SI); - function From_SSI is new UC (Short_Short_Integer, S_SSI); - function From_SSU is new UC (UST.Short_Short_Unsigned, S_SSU); - function From_SU is new UC (UST.Short_Unsigned, S_SU); - function From_U is new UC (UST.Unsigned, S_U); - function From_WC is new UC (Wide_Character, S_WC); - function From_WWC is new UC (Wide_Wide_Character, S_WWC); - - -- Unchecked conversions from the stream type to elementary type - - function To_AD is new UC (S_AD, Fat_Pointer); - function To_AS is new UC (S_AS, Thin_Pointer); - function To_F is new UC (S_F, Float); - function To_I is new UC (S_I, Integer); - function To_LF is new UC (S_LF, Long_Float); - function To_LI is new UC (S_LI, Long_Integer); - function To_LLF is new UC (S_LLF, Long_Long_Float); - function To_LLI is new UC (S_LLI, Long_Long_Integer); - function To_LLU is new UC (S_LLU, UST.Long_Long_Unsigned); - function To_LU is new UC (S_LU, UST.Long_Unsigned); - function To_SF is new UC (S_SF, Short_Float); - function To_SI is new UC (S_SI, Short_Integer); - function To_SSI is new UC (S_SSI, Short_Short_Integer); - function To_SSU is new UC (S_SSU, UST.Short_Short_Unsigned); - function To_SU is new UC (S_SU, UST.Short_Unsigned); - function To_U is new UC (S_U, UST.Unsigned); - function To_WC is new UC (S_WC, Wide_Character); - function To_WWC is new UC (S_WWC, Wide_Wide_Character); - - ----------------- - -- Block_IO_OK -- - ----------------- - - function Block_IO_OK return Boolean is - begin - return True; - end Block_IO_OK; - - ---------- - -- I_AD -- - ---------- - - function I_AD (Stream : not null access RST) return Fat_Pointer is - T : S_AD; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_AD (T); - end if; - end I_AD; - - ---------- - -- I_AS -- - ---------- - - function I_AS (Stream : not null access RST) return Thin_Pointer is - T : S_AS; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_AS (T); - end if; - end I_AS; - - --------- - -- I_B -- - --------- - - function I_B (Stream : not null access RST) return Boolean is - T : S_B; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return Boolean'Val (T (1)); - end if; - end I_B; - - --------- - -- I_C -- - --------- - - function I_C (Stream : not null access RST) return Character is - T : S_C; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return Character'Val (T (1)); - end if; - end I_C; - - --------- - -- I_F -- - --------- - - function I_F (Stream : not null access RST) return Float is - T : S_F; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_F (T); - end if; - end I_F; - - --------- - -- I_I -- - --------- - - function I_I (Stream : not null access RST) return Integer is - T : S_I; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_I (T); - end if; - end I_I; - - ---------- - -- I_LF -- - ---------- - - function I_LF (Stream : not null access RST) return Long_Float is - T : S_LF; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_LF (T); - end if; - end I_LF; - - ---------- - -- I_LI -- - ---------- - - function I_LI (Stream : not null access RST) return Long_Integer is - T : S_LI; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_LI (T); - end if; - end I_LI; - - ----------- - -- I_LLF -- - ----------- - - function I_LLF (Stream : not null access RST) return Long_Long_Float is - T : S_LLF; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_LLF (T); - end if; - end I_LLF; - - ----------- - -- I_LLI -- - ----------- - - function I_LLI (Stream : not null access RST) return Long_Long_Integer is - T : S_LLI; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_LLI (T); - end if; - end I_LLI; - - ----------- - -- I_LLU -- - ----------- - - function I_LLU - (Stream : not null access RST) return UST.Long_Long_Unsigned - is - T : S_LLU; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_LLU (T); - end if; - end I_LLU; - - ---------- - -- I_LU -- - ---------- - - function I_LU (Stream : not null access RST) return UST.Long_Unsigned is - T : S_LU; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_LU (T); - end if; - end I_LU; - - ---------- - -- I_SF -- - ---------- - - function I_SF (Stream : not null access RST) return Short_Float is - T : S_SF; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_SF (T); - end if; - end I_SF; - - ---------- - -- I_SI -- - ---------- - - function I_SI (Stream : not null access RST) return Short_Integer is - T : S_SI; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_SI (T); - end if; - end I_SI; - - ----------- - -- I_SSI -- - ----------- - - function I_SSI (Stream : not null access RST) return Short_Short_Integer is - T : S_SSI; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_SSI (T); - end if; - end I_SSI; - - ----------- - -- I_SSU -- - ----------- - - function I_SSU - (Stream : not null access RST) return UST.Short_Short_Unsigned - is - T : S_SSU; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_SSU (T); - end if; - end I_SSU; - - ---------- - -- I_SU -- - ---------- - - function I_SU (Stream : not null access RST) return UST.Short_Unsigned is - T : S_SU; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_SU (T); - end if; - end I_SU; - - --------- - -- I_U -- - --------- - - function I_U (Stream : not null access RST) return UST.Unsigned is - T : S_U; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_U (T); - end if; - end I_U; - - ---------- - -- I_WC -- - ---------- - - function I_WC (Stream : not null access RST) return Wide_Character is - T : S_WC; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_WC (T); - end if; - end I_WC; - - ----------- - -- I_WWC -- - ----------- - - function I_WWC (Stream : not null access RST) return Wide_Wide_Character is - T : S_WWC; - L : SEO; - - begin - Ada.Streams.Read (Stream.all, T, L); - - if L < T'Last then - raise Err; - else - return To_WWC (T); - end if; - end I_WWC; - - ---------- - -- W_AD -- - ---------- - - procedure W_AD (Stream : not null access RST; Item : Fat_Pointer) is - T : constant S_AD := From_AD (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_AD; - - ---------- - -- W_AS -- - ---------- - - procedure W_AS (Stream : not null access RST; Item : Thin_Pointer) is - T : constant S_AS := From_AS (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_AS; - - --------- - -- W_B -- - --------- - - procedure W_B (Stream : not null access RST; Item : Boolean) is - T : S_B; - begin - T (1) := Boolean'Pos (Item); - Ada.Streams.Write (Stream.all, T); - end W_B; - - --------- - -- W_C -- - --------- - - procedure W_C (Stream : not null access RST; Item : Character) is - T : S_C; - begin - T (1) := Character'Pos (Item); - Ada.Streams.Write (Stream.all, T); - end W_C; - - --------- - -- W_F -- - --------- - - procedure W_F (Stream : not null access RST; Item : Float) is - T : constant S_F := From_F (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_F; - - --------- - -- W_I -- - --------- - - procedure W_I (Stream : not null access RST; Item : Integer) is - T : constant S_I := From_I (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_I; - - ---------- - -- W_LF -- - ---------- - - procedure W_LF (Stream : not null access RST; Item : Long_Float) is - T : constant S_LF := From_LF (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_LF; - - ---------- - -- W_LI -- - ---------- - - procedure W_LI (Stream : not null access RST; Item : Long_Integer) is - T : constant S_LI := From_LI (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_LI; - - ----------- - -- W_LLF -- - ----------- - - procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float) is - T : constant S_LLF := From_LLF (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_LLF; - - ----------- - -- W_LLI -- - ----------- - - procedure W_LLI - (Stream : not null access RST; Item : Long_Long_Integer) - is - T : constant S_LLI := From_LLI (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_LLI; - - ----------- - -- W_LLU -- - ----------- - - procedure W_LLU - (Stream : not null access RST; Item : UST.Long_Long_Unsigned) - is - T : constant S_LLU := From_LLU (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_LLU; - - ---------- - -- W_LU -- - ---------- - - procedure W_LU - (Stream : not null access RST; Item : UST.Long_Unsigned) - is - T : constant S_LU := From_LU (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_LU; - - ---------- - -- W_SF -- - ---------- - - procedure W_SF (Stream : not null access RST; Item : Short_Float) is - T : constant S_SF := From_SF (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_SF; - - ---------- - -- W_SI -- - ---------- - - procedure W_SI (Stream : not null access RST; Item : Short_Integer) is - T : constant S_SI := From_SI (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_SI; - - ----------- - -- W_SSI -- - ----------- - - procedure W_SSI - (Stream : not null access RST; Item : Short_Short_Integer) - is - T : constant S_SSI := From_SSI (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_SSI; - - ----------- - -- W_SSU -- - ----------- - - procedure W_SSU - (Stream : not null access RST; Item : UST.Short_Short_Unsigned) - is - T : constant S_SSU := From_SSU (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_SSU; - - ---------- - -- W_SU -- - ---------- - - procedure W_SU - (Stream : not null access RST; Item : UST.Short_Unsigned) - is - T : constant S_SU := From_SU (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_SU; - - --------- - -- W_U -- - --------- - - procedure W_U (Stream : not null access RST; Item : UST.Unsigned) is - T : constant S_U := From_U (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_U; - - ---------- - -- W_WC -- - ---------- - - procedure W_WC (Stream : not null access RST; Item : Wide_Character) is - T : constant S_WC := From_WC (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_WC; - - ----------- - -- W_WWC -- - ----------- - - procedure W_WWC - (Stream : not null access RST; Item : Wide_Wide_Character) - is - T : constant S_WWC := From_WWC (Item); - begin - Ada.Streams.Write (Stream.all, T); - end W_WWC; - -end System.Stream_Attributes; diff --git a/gcc/ada/s-stratt.ads b/gcc/ada/s-stratt.ads deleted file mode 100644 index a831cdb..0000000 --- a/gcc/ada/s-stratt.ads +++ /dev/null @@ -1,207 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . S T R E A M _ A T T R I B U T E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the implementations of the stream attributes for --- elementary types. These are the subprograms that are directly accessed --- by occurrences of the stream attributes where the type is elementary. - --- We only provide the subprograms for the standard base types. For user --- defined types, the subprogram for the corresponding root type is called --- with an appropriate conversion. - -with System; -with System.Unsigned_Types; -with Ada.Streams; - -package System.Stream_Attributes is - pragma Preelaborate; - - pragma Suppress (Accessibility_Check, Stream_Attributes); - -- No need to check accessibility on arguments of subprograms - - package UST renames System.Unsigned_Types; - - subtype RST is Ada.Streams.Root_Stream_Type'Class; - - subtype SEC is Ada.Streams.Stream_Element_Count; - - -- Enumeration types are usually transferred using the routine for the - -- corresponding integer. The exception is that special routines are - -- provided for Boolean and the character types, in case the protocol - -- in use provides specially for these types. - - -- Access types use either a thin pointer (single address) or fat pointer - -- (double address) form. The following types are used to hold access - -- values using unchecked conversions. - - type Thin_Pointer is record - P1 : System.Address; - end record; - - type Fat_Pointer is record - P1 : System.Address; - P2 : System.Address; - end record; - - ------------------------------------ - -- Treatment of enumeration types -- - ------------------------------------ - - -- In this interface, there are no specific routines for general input - -- or output of enumeration types. Generally, enumeration types whose - -- representation is unsigned (no negative representation values) are - -- treated as unsigned integers, and enumeration types that do have - -- negative representation values are treated as signed integers. - - -- An exception is that there are specialized routines for Boolean, - -- Character, and Wide_Character types, but these specialized routines - -- are used only if the type in question has a standard representation. - -- For the case of a non-standard representation (one where the size of - -- the first subtype is specified, or where an enumeration representation - -- clause is given), these three types are treated like any other cases - -- of enumeration types, as described above. - - --------------------- - -- Input Functions -- - --------------------- - - -- Functions for S'Input attribute. These functions are also used for - -- S'Read, with the obvious transformation, since the input operation - -- is the same for all elementary types (no bounds or discriminants - -- are involved). - - function I_AD (Stream : not null access RST) return Fat_Pointer; - function I_AS (Stream : not null access RST) return Thin_Pointer; - function I_B (Stream : not null access RST) return Boolean; - function I_C (Stream : not null access RST) return Character; - function I_F (Stream : not null access RST) return Float; - function I_I (Stream : not null access RST) return Integer; - function I_LF (Stream : not null access RST) return Long_Float; - function I_LI (Stream : not null access RST) return Long_Integer; - function I_LLF (Stream : not null access RST) return Long_Long_Float; - function I_LLI (Stream : not null access RST) return Long_Long_Integer; - function I_LLU (Stream : not null access RST) return UST.Long_Long_Unsigned; - function I_LU (Stream : not null access RST) return UST.Long_Unsigned; - function I_SF (Stream : not null access RST) return Short_Float; - function I_SI (Stream : not null access RST) return Short_Integer; - function I_SSI (Stream : not null access RST) return Short_Short_Integer; - function I_SSU (Stream : not null access RST) return - UST.Short_Short_Unsigned; - function I_SU (Stream : not null access RST) return UST.Short_Unsigned; - function I_U (Stream : not null access RST) return UST.Unsigned; - function I_WC (Stream : not null access RST) return Wide_Character; - function I_WWC (Stream : not null access RST) return Wide_Wide_Character; - - ----------------------- - -- Output Procedures -- - ----------------------- - - -- Procedures for S'Write attribute. These procedures are also used for - -- 'Output, since for elementary types there is no difference between - -- 'Write and 'Output because there are no discriminants or bounds to - -- be written. - - procedure W_AD (Stream : not null access RST; Item : Fat_Pointer); - procedure W_AS (Stream : not null access RST; Item : Thin_Pointer); - procedure W_B (Stream : not null access RST; Item : Boolean); - procedure W_C (Stream : not null access RST; Item : Character); - procedure W_F (Stream : not null access RST; Item : Float); - procedure W_I (Stream : not null access RST; Item : Integer); - procedure W_LF (Stream : not null access RST; Item : Long_Float); - procedure W_LI (Stream : not null access RST; Item : Long_Integer); - procedure W_LLF (Stream : not null access RST; Item : Long_Long_Float); - procedure W_LLI (Stream : not null access RST; Item : Long_Long_Integer); - procedure W_LLU (Stream : not null access RST; Item : - UST.Long_Long_Unsigned); - procedure W_LU (Stream : not null access RST; Item : UST.Long_Unsigned); - procedure W_SF (Stream : not null access RST; Item : Short_Float); - procedure W_SI (Stream : not null access RST; Item : Short_Integer); - procedure W_SSI (Stream : not null access RST; Item : Short_Short_Integer); - procedure W_SSU (Stream : not null access RST; Item : - UST.Short_Short_Unsigned); - procedure W_SU (Stream : not null access RST; Item : UST.Short_Unsigned); - procedure W_U (Stream : not null access RST; Item : UST.Unsigned); - procedure W_WC (Stream : not null access RST; Item : Wide_Character); - procedure W_WWC (Stream : not null access RST; Item : Wide_Wide_Character); - - function Block_IO_OK return Boolean; - -- Package System.Stream_Attributes has several bodies - the default one - -- distributed with GNAT, and s-stratt-xdr.adb, which is based on the XDR - -- standard. Both bodies share the same spec. The role of this function is - -- to indicate whether the current version of System.Stream_Attributes - -- supports block IO. See System.Strings.Stream_Ops (s-ststop) for details. - -private - pragma Inline (I_AD); - pragma Inline (I_AS); - pragma Inline (I_B); - pragma Inline (I_C); - pragma Inline (I_F); - pragma Inline (I_I); - pragma Inline (I_LF); - pragma Inline (I_LI); - pragma Inline (I_LLF); - pragma Inline (I_LLI); - pragma Inline (I_LLU); - pragma Inline (I_LU); - pragma Inline (I_SF); - pragma Inline (I_SI); - pragma Inline (I_SSI); - pragma Inline (I_SSU); - pragma Inline (I_SU); - pragma Inline (I_U); - pragma Inline (I_WC); - pragma Inline (I_WWC); - - pragma Inline (W_AD); - pragma Inline (W_AS); - pragma Inline (W_B); - pragma Inline (W_C); - pragma Inline (W_F); - pragma Inline (W_I); - pragma Inline (W_LF); - pragma Inline (W_LI); - pragma Inline (W_LLF); - pragma Inline (W_LLI); - pragma Inline (W_LLU); - pragma Inline (W_LU); - pragma Inline (W_SF); - pragma Inline (W_SI); - pragma Inline (W_SSI); - pragma Inline (W_SSU); - pragma Inline (W_SU); - pragma Inline (W_U); - pragma Inline (W_WC); - pragma Inline (W_WWC); - - pragma Inline (Block_IO_OK); - -end System.Stream_Attributes; diff --git a/gcc/ada/s-strcom.adb b/gcc/ada/s-strcom.adb deleted file mode 100644 index 4388d80..0000000 --- a/gcc/ada/s-strcom.adb +++ /dev/null @@ -1,140 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ C O M P A R E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Conversion; - -package body System.String_Compare is - - type Word is mod 2 ** 32; - -- Used to process operands by words - - type Big_Words is array (Natural) of Word; - type Big_Words_Ptr is access Big_Words; - for Big_Words_Ptr'Storage_Size use 0; - -- Array type used to access by words - - type Byte is mod 2 ** 8; - -- Used to process operands by bytes - - type Big_Bytes is array (Natural) of Byte; - type Big_Bytes_Ptr is access Big_Bytes; - for Big_Bytes_Ptr'Storage_Size use 0; - -- Array type used to access by bytes - - function To_Big_Words is new - Ada.Unchecked_Conversion (System.Address, Big_Words_Ptr); - - function To_Big_Bytes is new - Ada.Unchecked_Conversion (System.Address, Big_Bytes_Ptr); - - ----------------- - -- Str_Compare -- - ----------------- - - function Str_Compare - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); - - begin - -- If operands are non-aligned, or length is too short, go by bytes - - if (((Left or Right) and 2#11#) /= 0) or else Compare_Len < 4 then - return Str_Compare_Bytes (Left, Right, Left_Len, Right_Len); - end if; - - -- Here we can go by words - - declare - LeftP : constant Big_Words_Ptr := To_Big_Words (Left); - RightP : constant Big_Words_Ptr := To_Big_Words (Right); - Clen4 : constant Natural := Compare_Len / 4 - 1; - Clen4F : constant Natural := Clen4 * 4; - - begin - for J in 0 .. Clen4 loop - if LeftP (J) /= RightP (J) then - return Str_Compare_Bytes - (Left + Address (4 * J), - Right + Address (4 * J), - 4, 4); - end if; - end loop; - - return Str_Compare_Bytes - (Left + Address (Clen4F), - Right + Address (Clen4F), - Left_Len - Clen4F, - Right_Len - Clen4F); - end; - end Str_Compare; - - ----------------------- - -- Str_Compare_Bytes -- - ----------------------- - - function Str_Compare_Bytes - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer - is - Compare_Len : constant Natural := Natural'Min (Left_Len, Right_Len); - - LeftP : constant Big_Bytes_Ptr := To_Big_Bytes (Left); - RightP : constant Big_Bytes_Ptr := To_Big_Bytes (Right); - - begin - for J in 0 .. Compare_Len - 1 loop - if LeftP (J) /= RightP (J) then - if LeftP (J) > RightP (J) then - return +1; - else - return -1; - end if; - end if; - end loop; - - if Left_Len = Right_Len then - return 0; - elsif Left_Len > Right_Len then - return +1; - else - return -1; - end if; - end Str_Compare_Bytes; - -end System.String_Compare; diff --git a/gcc/ada/s-strcom.ads b/gcc/ada/s-strcom.ads deleted file mode 100644 index 7458f5d..0000000 --- a/gcc/ada/s-strcom.ads +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ C O M P A R E -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime comparisons on strings - -pragma Compiler_Unit_Warning; - -package System.String_Compare is - - function Str_Compare - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Compare the string starting at address Left of length Left_Len - -- with the string starting at address Right of length Right_Len. - -- The comparison is in the normal Ada semantic sense of string - -- comparison. The result is -1,0,+1 for LeftRight respectively. This function works with 4 byte words - -- if the operands are aligned on 4-byte boundaries and long enough. - - function Str_Compare_Bytes - (Left : System.Address; - Right : System.Address; - Left_Len : Natural; - Right_Len : Natural) return Integer; - -- Same functionality as Str_Compare but always proceeds by bytes. - -- Used when the caller knows that the operands are unaligned, or - -- short enough that it makes no sense to go by words. - -end System.String_Compare; diff --git a/gcc/ada/s-strhas.adb b/gcc/ada/s-strhas.adb deleted file mode 100644 index 9ab5b6e..0000000 --- a/gcc/ada/s-strhas.adb +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ H A S H -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.String_Hash is - - -- Compute a hash value for a key. The approach here follows the algorithm - -- introduced in the ndbm substitute SDBM by Ozan Yigit and then reused in - -- GNU Awk (where they are implemented as a Duff's device). - - ---------- - -- Hash -- - ---------- - - function Hash (Key : Key_Type) return Hash_Type is - - pragma Compile_Time_Error - (Hash_Type'Modulus /= 2 ** 32 - or else Hash_Type'First /= 0 - or else Hash_Type'Last /= 2 ** 32 - 1, - "Hash_Type must be 32-bit modular with range 0 .. 2**32-1"); - - function Shift_Left - (Value : Hash_Type; - Amount : Natural) return Hash_Type; - pragma Import (Intrinsic, Shift_Left); - - H : Hash_Type; - - begin - H := 0; - for J in Key'Range loop - H := Char_Type'Pos (Key (J)) - + Shift_Left (H, 6) + Shift_Left (H, 16) - H; - end loop; - - return H; - end Hash; - -end System.String_Hash; diff --git a/gcc/ada/s-strhas.ads b/gcc/ada/s-strhas.ads deleted file mode 100644 index d0dd4c8..0000000 --- a/gcc/ada/s-strhas.ads +++ /dev/null @@ -1,64 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ H A S H -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 generic hashing function over strings, suitable for --- use with a string keyed hash table. In particular, it is the basis for the --- string hash functions in Ada.Containers. --- --- The algorithm used here is not appropriate for applications that require --- cryptographically strong hashes, or for application which wish to use very --- wide hash values as pseudo unique identifiers. In such cases please refer --- to GNAT.SHA1 and GNAT.MD5. --- --- Note: this package is in the System hierarchy so that it can be directly --- be used by other predefined packages. User access to this package is via --- a renaming of this package in GNAT.String_Hash (file g-strhas.ads). - -package System.String_Hash is - pragma Pure; - - generic - type Char_Type is (<>); - -- The character type composing the key string type - - type Key_Type is array (Positive range <>) of Char_Type; - -- The string type to use as a hash key - - type Hash_Type is mod <>; - -- The type to be returned as a hash value. This must be a 32-bit - -- unsigned type with full range 0 .. 2**32-1, no other type is allowed - -- for this instantiation (checked in the body by Compile_Time_Error). - - function Hash (Key : Key_Type) return Hash_Type; - pragma Inline (Hash); - -- Compute a hash value for a key - -end System.String_Hash; diff --git a/gcc/ada/s-string.adb b/gcc/ada/s-string.adb deleted file mode 100644 index 88439cc..0000000 --- a/gcc/ada/s-string.adb +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T R I N G S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1995-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.Strings is - - ---------- - -- Free -- - ---------- - - procedure Free (Arg : in out String_List_Access) is - - procedure Free_Array is new Ada.Unchecked_Deallocation - (Object => String_List, Name => String_List_Access); - - begin - -- First free all the String_Access components if any - - if Arg /= null then - for J in Arg'Range loop - Free (Arg (J)); - end loop; - end if; - - -- Now free the allocated array - - Free_Array (Arg); - end Free; - -end System.Strings; diff --git a/gcc/ada/s-string.ads b/gcc/ada/s-string.ads deleted file mode 100644 index ee05498..0000000 --- a/gcc/ada/s-string.ads +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . S T R I N G S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1995-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Common String access types and related subprograms - --- Note: this package is in the System hierarchy so that it can be directly --- be used by other predefined packages. User access to this package is via --- a renaming of this package in GNAT.String (file g-string.ads). - -pragma Compiler_Unit_Warning; - -with Ada.Unchecked_Deallocation; - -package System.Strings is - pragma Preelaborate; - - type String_Access is access all String; - -- General purpose string access type. Note that the caller is - -- responsible for freeing allocated strings to avoid memory leaks. - - procedure Free is new Ada.Unchecked_Deallocation - (Object => String, Name => String_Access); - -- This procedure is provided for freeing allocated values of type - -- String_Access. - - type String_List is array (Positive range <>) of String_Access; - type String_List_Access is access all String_List; - -- General purpose array and pointer for list of string accesses - - procedure Free (Arg : in out String_List_Access); - -- Frees the given array and all strings that its elements reference, - -- and then sets the argument to null. Provided for freeing allocated - -- values of this type. - -end System.Strings; diff --git a/gcc/ada/s-strops.adb b/gcc/ada/s-strops.adb deleted file mode 100644 index a822ea4..0000000 --- a/gcc/ada/s-strops.adb +++ /dev/null @@ -1,109 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package body System.String_Ops is - - ---------------- - -- Str_Concat -- - ---------------- - - function Str_Concat (X, Y : String) return String is - begin - if X'Length = 0 then - return Y; - - else - declare - L : constant Natural := X'Length + Y'Length; - R : String (X'First .. X'First + L - 1); - - begin - R (X'Range) := X; - R (X'First + X'Length .. R'Last) := Y; - return R; - end; - end if; - end Str_Concat; - - ------------------- - -- Str_Concat_CC -- - ------------------- - - function Str_Concat_CC (X, Y : Character) return String is - R : String (1 .. 2); - - begin - R (1) := X; - R (2) := Y; - return R; - end Str_Concat_CC; - - ------------------- - -- Str_Concat_CS -- - ------------------- - - function Str_Concat_CS (X : Character; Y : String) return String is - R : String (1 .. Y'Length + 1); - - begin - R (1) := X; - R (2 .. R'Last) := Y; - return R; - end Str_Concat_CS; - - ------------------- - -- Str_Concat_SC -- - ------------------- - - function Str_Concat_SC (X : String; Y : Character) return String is - begin - if X'Length = 0 then - return (1 => Y); - - else - declare - R : String (X'First .. X'Last + 1); - - begin - R (X'Range) := X; - R (R'Last) := Y; - return R; - end; - end if; - end Str_Concat_SC; - -end System.String_Ops; diff --git a/gcc/ada/s-strops.ads b/gcc/ada/s-strops.ads deleted file mode 100644 index 8e6d7b4..0000000 --- a/gcc/ada/s-strops.ads +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T R I N G _ O P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime operations on strings --- (other than runtime comparison, found in s-strcom.ads). - --- NOTE: This package is obsolescent. It is no longer used by the compiler --- which now generates concatenation inline. It is retained only because --- it may be used during bootstrapping using old versions of the compiler. - -pragma Compiler_Unit_Warning; - -package System.String_Ops is - pragma Pure; - - function Str_Concat (X, Y : String) return String; - -- Concatenate two strings and return resulting string - - function Str_Concat_SC (X : String; Y : Character) return String; - -- Concatenate string and character - - function Str_Concat_CS (X : Character; Y : String) return String; - -- Concatenate character and string - - function Str_Concat_CC (X, Y : Character) return String; - -- Concatenate two characters - -end System.String_Ops; diff --git a/gcc/ada/s-ststop.adb b/gcc/ada/s-ststop.adb deleted file mode 100644 index ea02065..0000000 --- a/gcc/ada/s-ststop.adb +++ /dev/null @@ -1,915 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2008-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Ada.Streams; use Ada.Streams; -with Ada.Streams.Stream_IO; use Ada.Streams.Stream_IO; -with Ada.Unchecked_Conversion; - -with System; use System; -with System.Storage_Elements; use System.Storage_Elements; -with System.Stream_Attributes; - -package body System.Strings.Stream_Ops is - - -- The following type describes the low-level IO mechanism used in package - -- Stream_Ops_Internal. - - type IO_Kind is (Byte_IO, Block_IO); - - -- The following package provides an IO framework for strings. Depending - -- on the version of System.Stream_Attributes as well as the size of - -- formal parameter Element_Type, the package will either utilize block - -- IO or element-by-element IO. - - generic - type Element_Type is private; - type Index_Type is range <>; - type Array_Type is array (Index_Type range <>) of Element_Type; - - package Stream_Ops_Internal is - function Input - (Strm : access Root_Stream_Type'Class; - IO : IO_Kind; - Max_Length : Long_Integer := Long_Integer'Last) return Array_Type; - -- Raises an exception if you try to read a String that is longer than - -- Max_Length. See expansion of Attribute_Input in Exp_Attr for details. - - procedure Output - (Strm : access Root_Stream_Type'Class; - Item : Array_Type; - IO : IO_Kind); - - procedure Read - (Strm : access Root_Stream_Type'Class; - Item : out Array_Type; - IO : IO_Kind); - - procedure Write - (Strm : access Root_Stream_Type'Class; - Item : Array_Type; - IO : IO_Kind); - end Stream_Ops_Internal; - - ------------------------- - -- Stream_Ops_Internal -- - ------------------------- - - package body Stream_Ops_Internal is - - -- The following value represents the number of BITS allocated for the - -- default block used in string IO. The sizes of all other types are - -- calculated relative to this value. - - Default_Block_Size : constant := 512 * 8; - - -- Shorthand notation for stream element and element type sizes - - ET_Size : constant Integer := Element_Type'Size; - SE_Size : constant Integer := Stream_Element'Size; - - -- The following constants describe the number of array elements or - -- stream elements that can fit into a default block. - - AE_In_Default_Block : constant Index_Type := - Index_Type (Default_Block_Size / ET_Size); - -- Number of array elements in a default block - - SE_In_Default_Block : constant Integer := Default_Block_Size / SE_Size; - -- Number of storage elements in a default block - - -- Buffer types - - subtype Default_Block is Stream_Element_Array - (1 .. Stream_Element_Offset (SE_In_Default_Block)); - - subtype Array_Block is - Array_Type (Index_Type range 1 .. AE_In_Default_Block); - - -- Conversions to and from Default_Block - - function To_Default_Block is - new Ada.Unchecked_Conversion (Array_Block, Default_Block); - - function To_Array_Block is - new Ada.Unchecked_Conversion (Default_Block, Array_Block); - - ----------- - -- Input -- - ----------- - - function Input - (Strm : access Root_Stream_Type'Class; - IO : IO_Kind; - Max_Length : Long_Integer := Long_Integer'Last) return Array_Type - is - pragma Unsuppress (All_Checks); - -- The above makes T'Class'Input robust in the case of bad data. The - -- declaration of Item below could raise Storage_Error if the length - -- is too big. - - begin - if Strm = null then - raise Constraint_Error; - end if; - - declare - Low, High : Index_Type'Base; - begin - -- Read the bounds of the string. Note that they could be out of - -- range of Index_Type in the case of empty arrays. - - Index_Type'Read (Strm, Low); - Index_Type'Read (Strm, High); - - if Long_Integer (High) - Long_Integer (Low) > Max_Length then - raise Constraint_Error; - end if; - - -- Read the character content of the string - - declare - Item : Array_Type (Low .. High); - begin - Read (Strm, Item, IO); - return Item; - end; - end; - end Input; - - ------------ - -- Output -- - ------------ - - procedure Output - (Strm : access Root_Stream_Type'Class; - Item : Array_Type; - IO : IO_Kind) - is - begin - if Strm = null then - raise Constraint_Error; - end if; - - -- Write the bounds of the string - - Index_Type'Write (Strm, Item'First); - Index_Type'Write (Strm, Item'Last); - - -- Write the character content of the string - - Write (Strm, Item, IO); - end Output; - - ---------- - -- Read -- - ---------- - - procedure Read - (Strm : access Root_Stream_Type'Class; - Item : out Array_Type; - IO : IO_Kind) - is - begin - if Strm = null then - raise Constraint_Error; - end if; - - -- Nothing to do if the desired string is empty - - if Item'Length = 0 then - return; - end if; - - -- Block IO - - if IO = Block_IO and then Stream_Attributes.Block_IO_OK then - declare - -- Determine the size in BITS of the block necessary to contain - -- the whole string. - - Block_Size : constant Natural := - Integer (Item'Last - Item'First + 1) * ET_Size; - - -- Item can be larger than what the default block can store, - -- determine the number of whole reads necessary to read the - -- string. - - Blocks : constant Natural := Block_Size / Default_Block_Size; - - -- The size of Item may not be a multiple of the default block - -- size, determine the size of the remaining chunk in BITS. - - Rem_Size : constant Natural := - Block_Size mod Default_Block_Size; - - -- String indexes - - Low : Index_Type := Item'First; - High : Index_Type := Low + AE_In_Default_Block - 1; - - -- End of stream error detection - - Last : Stream_Element_Offset := 0; - Sum : Stream_Element_Offset := 0; - - begin - -- Step 1: If the string is too large, read in individual - -- chunks the size of the default block. - - if Blocks > 0 then - declare - Block : Default_Block; - - begin - for Counter in 1 .. Blocks loop - Read (Strm.all, Block, Last); - Item (Low .. High) := To_Array_Block (Block); - - Low := High + 1; - High := Low + AE_In_Default_Block - 1; - Sum := Sum + Last; - Last := 0; - end loop; - end; - end if; - - -- Step 2: Read in any remaining elements - - if Rem_Size > 0 then - declare - subtype Rem_Block is Stream_Element_Array - (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); - - subtype Rem_Array_Block is - Array_Type (Index_Type range - 1 .. Index_Type (Rem_Size / ET_Size)); - - function To_Rem_Array_Block is new - Ada.Unchecked_Conversion (Rem_Block, Rem_Array_Block); - - Block : Rem_Block; - - begin - Read (Strm.all, Block, Last); - Item (Low .. Item'Last) := To_Rem_Array_Block (Block); - - Sum := Sum + Last; - end; - end if; - - -- Step 3: Potential error detection. The sum of all the - -- chunks is less than we initially wanted to read. In other - -- words, the stream does not contain enough elements to fully - -- populate Item. - - if (Integer (Sum) * SE_Size) / ET_Size < Item'Length then - raise End_Error; - end if; - end; - - -- Byte IO - - else - declare - E : Element_Type; - begin - for Index in Item'First .. Item'Last loop - Element_Type'Read (Strm, E); - Item (Index) := E; - end loop; - end; - end if; - end Read; - - ----------- - -- Write -- - ----------- - - procedure Write - (Strm : access Root_Stream_Type'Class; - Item : Array_Type; - IO : IO_Kind) - is - begin - if Strm = null then - raise Constraint_Error; - end if; - - -- Nothing to do if the input string is empty - - if Item'Length = 0 then - return; - end if; - - -- Block IO - - if IO = Block_IO and then Stream_Attributes.Block_IO_OK then - declare - -- Determine the size in BITS of the block necessary to contain - -- the whole string. - - Block_Size : constant Natural := Item'Length * ET_Size; - - -- Item can be larger than what the default block can store, - -- determine the number of whole writes necessary to output the - -- string. - - Blocks : constant Natural := Block_Size / Default_Block_Size; - - -- The size of Item may not be a multiple of the default block - -- size, determine the size of the remaining chunk. - - Rem_Size : constant Natural := - Block_Size mod Default_Block_Size; - - -- String indexes - - Low : Index_Type := Item'First; - High : Index_Type := Low + AE_In_Default_Block - 1; - - begin - -- Step 1: If the string is too large, write out individual - -- chunks the size of the default block. - - for Counter in 1 .. Blocks loop - Write (Strm.all, To_Default_Block (Item (Low .. High))); - Low := High + 1; - High := Low + AE_In_Default_Block - 1; - end loop; - - -- Step 2: Write out any remaining elements - - if Rem_Size > 0 then - declare - subtype Rem_Block is Stream_Element_Array - (1 .. Stream_Element_Offset (Rem_Size / SE_Size)); - - subtype Rem_Array_Block is - Array_Type (Index_Type range - 1 .. Index_Type (Rem_Size / ET_Size)); - - function To_Rem_Block is new - Ada.Unchecked_Conversion (Rem_Array_Block, Rem_Block); - - begin - Write (Strm.all, To_Rem_Block (Item (Low .. Item'Last))); - end; - end if; - end; - - -- Byte IO - - else - for Index in Item'First .. Item'Last loop - Element_Type'Write (Strm, Item (Index)); - end loop; - end if; - end Write; - end Stream_Ops_Internal; - - -- Specific instantiations for all Ada array types handled - - package Storage_Array_Ops is - new Stream_Ops_Internal - (Element_Type => Storage_Element, - Index_Type => Storage_Offset, - Array_Type => Storage_Array); - - package Stream_Element_Array_Ops is - new Stream_Ops_Internal - (Element_Type => Stream_Element, - Index_Type => Stream_Element_Offset, - Array_Type => Stream_Element_Array); - - package String_Ops is - new Stream_Ops_Internal - (Element_Type => Character, - Index_Type => Positive, - Array_Type => String); - - package Wide_String_Ops is - new Stream_Ops_Internal - (Element_Type => Wide_Character, - Index_Type => Positive, - Array_Type => Wide_String); - - package Wide_Wide_String_Ops is - new Stream_Ops_Internal - (Element_Type => Wide_Wide_Character, - Index_Type => Positive, - Array_Type => Wide_Wide_String); - - ------------------------- - -- Storage_Array_Input -- - ------------------------- - - function Storage_Array_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) return Storage_Array - is - begin - return Storage_Array_Ops.Input (Strm, Byte_IO); - end Storage_Array_Input; - - -------------------------------- - -- Storage_Array_Input_Blk_IO -- - -------------------------------- - - function Storage_Array_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) return Storage_Array - is - begin - return Storage_Array_Ops.Input (Strm, Block_IO); - end Storage_Array_Input_Blk_IO; - - -------------------------- - -- Storage_Array_Output -- - -------------------------- - - procedure Storage_Array_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Storage_Array) - is - begin - Storage_Array_Ops.Output (Strm, Item, Byte_IO); - end Storage_Array_Output; - - --------------------------------- - -- Storage_Array_Output_Blk_IO -- - --------------------------------- - - procedure Storage_Array_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Storage_Array) - is - begin - Storage_Array_Ops.Output (Strm, Item, Block_IO); - end Storage_Array_Output_Blk_IO; - - ------------------------ - -- Storage_Array_Read -- - ------------------------ - - procedure Storage_Array_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Storage_Array) - is - begin - Storage_Array_Ops.Read (Strm, Item, Byte_IO); - end Storage_Array_Read; - - ------------------------------- - -- Storage_Array_Read_Blk_IO -- - ------------------------------- - - procedure Storage_Array_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Storage_Array) - is - begin - Storage_Array_Ops.Read (Strm, Item, Block_IO); - end Storage_Array_Read_Blk_IO; - - ------------------------- - -- Storage_Array_Write -- - ------------------------- - - procedure Storage_Array_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Storage_Array) - is - begin - Storage_Array_Ops.Write (Strm, Item, Byte_IO); - end Storage_Array_Write; - - -------------------------------- - -- Storage_Array_Write_Blk_IO -- - -------------------------------- - - procedure Storage_Array_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Storage_Array) - is - begin - Storage_Array_Ops.Write (Strm, Item, Block_IO); - end Storage_Array_Write_Blk_IO; - - -------------------------------- - -- Stream_Element_Array_Input -- - -------------------------------- - - function Stream_Element_Array_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Stream_Element_Array - is - begin - return Stream_Element_Array_Ops.Input (Strm, Byte_IO); - end Stream_Element_Array_Input; - - --------------------------------------- - -- Stream_Element_Array_Input_Blk_IO -- - --------------------------------------- - - function Stream_Element_Array_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Stream_Element_Array - is - begin - return Stream_Element_Array_Ops.Input (Strm, Block_IO); - end Stream_Element_Array_Input_Blk_IO; - - --------------------------------- - -- Stream_Element_Array_Output -- - --------------------------------- - - procedure Stream_Element_Array_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Stream_Element_Array) - is - begin - Stream_Element_Array_Ops.Output (Strm, Item, Byte_IO); - end Stream_Element_Array_Output; - - ---------------------------------------- - -- Stream_Element_Array_Output_Blk_IO -- - ---------------------------------------- - - procedure Stream_Element_Array_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Stream_Element_Array) - is - begin - Stream_Element_Array_Ops.Output (Strm, Item, Block_IO); - end Stream_Element_Array_Output_Blk_IO; - - ------------------------------- - -- Stream_Element_Array_Read -- - ------------------------------- - - procedure Stream_Element_Array_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Stream_Element_Array) - is - begin - Stream_Element_Array_Ops.Read (Strm, Item, Byte_IO); - end Stream_Element_Array_Read; - - -------------------------------------- - -- Stream_Element_Array_Read_Blk_IO -- - -------------------------------------- - - procedure Stream_Element_Array_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Stream_Element_Array) - is - begin - Stream_Element_Array_Ops.Read (Strm, Item, Block_IO); - end Stream_Element_Array_Read_Blk_IO; - - -------------------------------- - -- Stream_Element_Array_Write -- - -------------------------------- - - procedure Stream_Element_Array_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Stream_Element_Array) - is - begin - Stream_Element_Array_Ops.Write (Strm, Item, Byte_IO); - end Stream_Element_Array_Write; - - --------------------------------------- - -- Stream_Element_Array_Write_Blk_IO -- - --------------------------------------- - - procedure Stream_Element_Array_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Stream_Element_Array) - is - begin - Stream_Element_Array_Ops.Write (Strm, Item, Block_IO); - end Stream_Element_Array_Write_Blk_IO; - - ------------------ - -- String_Input -- - ------------------ - - function String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) return String - is - begin - return String_Ops.Input (Strm, Byte_IO); - end String_Input; - - ------------------------- - -- String_Input_Blk_IO -- - ------------------------- - - function String_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) return String - is - begin - return String_Ops.Input (Strm, Block_IO); - end String_Input_Blk_IO; - - ------------------------- - -- String_Input_Tag -- - ------------------------- - - function String_Input_Tag - (Strm : access Ada.Streams.Root_Stream_Type'Class) return String - is - begin - return String_Ops.Input (Strm, Block_IO, Max_Length => 10_000); - end String_Input_Tag; - - ------------------- - -- String_Output -- - ------------------- - - procedure String_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String) - is - begin - String_Ops.Output (Strm, Item, Byte_IO); - end String_Output; - - -------------------------- - -- String_Output_Blk_IO -- - -------------------------- - - procedure String_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String) - is - begin - String_Ops.Output (Strm, Item, Block_IO); - end String_Output_Blk_IO; - - ----------------- - -- String_Read -- - ----------------- - - procedure String_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out String) - is - begin - String_Ops.Read (Strm, Item, Byte_IO); - end String_Read; - - ------------------------ - -- String_Read_Blk_IO -- - ------------------------ - - procedure String_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out String) - is - begin - String_Ops.Read (Strm, Item, Block_IO); - end String_Read_Blk_IO; - - ------------------ - -- String_Write -- - ------------------ - - procedure String_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String) - is - begin - String_Ops.Write (Strm, Item, Byte_IO); - end String_Write; - - ------------------------- - -- String_Write_Blk_IO -- - ------------------------- - - procedure String_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String) - is - begin - String_Ops.Write (Strm, Item, Block_IO); - end String_Write_Blk_IO; - - ----------------------- - -- Wide_String_Input -- - ----------------------- - - function Wide_String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String - is - begin - return Wide_String_Ops.Input (Strm, Byte_IO); - end Wide_String_Input; - - ------------------------------ - -- Wide_String_Input_Blk_IO -- - ------------------------------ - - function Wide_String_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_String - is - begin - return Wide_String_Ops.Input (Strm, Block_IO); - end Wide_String_Input_Blk_IO; - - ------------------------ - -- Wide_String_Output -- - ------------------------ - - procedure Wide_String_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String) - is - begin - Wide_String_Ops.Output (Strm, Item, Byte_IO); - end Wide_String_Output; - - ------------------------------- - -- Wide_String_Output_Blk_IO -- - ------------------------------- - - procedure Wide_String_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String) - is - begin - Wide_String_Ops.Output (Strm, Item, Block_IO); - end Wide_String_Output_Blk_IO; - - ---------------------- - -- Wide_String_Read -- - ---------------------- - - procedure Wide_String_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_String) - is - begin - Wide_String_Ops.Read (Strm, Item, Byte_IO); - end Wide_String_Read; - - ----------------------------- - -- Wide_String_Read_Blk_IO -- - ----------------------------- - - procedure Wide_String_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_String) - is - begin - Wide_String_Ops.Read (Strm, Item, Block_IO); - end Wide_String_Read_Blk_IO; - - ----------------------- - -- Wide_String_Write -- - ----------------------- - - procedure Wide_String_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String) - is - begin - Wide_String_Ops.Write (Strm, Item, Byte_IO); - end Wide_String_Write; - - ------------------------------ - -- Wide_String_Write_Blk_IO -- - ------------------------------ - - procedure Wide_String_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String) - is - begin - Wide_String_Ops.Write (Strm, Item, Block_IO); - end Wide_String_Write_Blk_IO; - - ---------------------------- - -- Wide_Wide_String_Input -- - ---------------------------- - - function Wide_Wide_String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String - is - begin - return Wide_Wide_String_Ops.Input (Strm, Byte_IO); - end Wide_Wide_String_Input; - - ----------------------------------- - -- Wide_Wide_String_Input_Blk_IO -- - ----------------------------------- - - function Wide_Wide_String_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) return Wide_Wide_String - is - begin - return Wide_Wide_String_Ops.Input (Strm, Block_IO); - end Wide_Wide_String_Input_Blk_IO; - - ----------------------------- - -- Wide_Wide_String_Output -- - ----------------------------- - - procedure Wide_Wide_String_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String) - is - begin - Wide_Wide_String_Ops.Output (Strm, Item, Byte_IO); - end Wide_Wide_String_Output; - - ------------------------------------ - -- Wide_Wide_String_Output_Blk_IO -- - ------------------------------------ - - procedure Wide_Wide_String_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String) - is - begin - Wide_Wide_String_Ops.Output (Strm, Item, Block_IO); - end Wide_Wide_String_Output_Blk_IO; - - --------------------------- - -- Wide_Wide_String_Read -- - --------------------------- - - procedure Wide_Wide_String_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_Wide_String) - is - begin - Wide_Wide_String_Ops.Read (Strm, Item, Byte_IO); - end Wide_Wide_String_Read; - - ---------------------------------- - -- Wide_Wide_String_Read_Blk_IO -- - ---------------------------------- - - procedure Wide_Wide_String_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_Wide_String) - is - begin - Wide_Wide_String_Ops.Read (Strm, Item, Block_IO); - end Wide_Wide_String_Read_Blk_IO; - - ---------------------------- - -- Wide_Wide_String_Write -- - ---------------------------- - - procedure Wide_Wide_String_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String) - is - begin - Wide_Wide_String_Ops.Write (Strm, Item, Byte_IO); - end Wide_Wide_String_Write; - - ----------------------------------- - -- Wide_Wide_String_Write_Blk_IO -- - ----------------------------------- - - procedure Wide_Wide_String_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String) - is - begin - Wide_Wide_String_Ops.Write (Strm, Item, Block_IO); - end Wide_Wide_String_Write_Blk_IO; - -end System.Strings.Stream_Ops; diff --git a/gcc/ada/s-ststop.ads b/gcc/ada/s-ststop.ads deleted file mode 100644 index f816400..0000000 --- a/gcc/ada/s-ststop.ads +++ /dev/null @@ -1,260 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . S T R I N G S . S T R E A M _ O P S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2017, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides subprogram implementations of stream attributes for --- the following types using a "block IO" approach in which the entire data --- item is written in one operation, instead of writing individual characters. - --- Ada.Stream_Element_Array --- Ada.String --- Ada.Wide_String --- Ada.Wide_Wide_String --- System.Storage_Array - --- Note: this routine is in Ada.Strings because historically it handled only --- the string types. It is not worth moving it at this stage. - --- The compiler will generate references to the subprograms in this package --- when expanding stream attributes for the above mentioned types. Example: - --- String'Output (Some_Stream, Some_String); - --- will be expanded into: - --- String_Output (Some_Stream, Some_String); --- or --- String_Output_Blk_IO (Some_Stream, Some_String); - --- String_Output form is used if pragma Restrictions (No_String_Optimziations) --- is active, which requires element by element operations. The BLK_IO form --- is used if this restriction is not set, allowing block optimization. - --- Note that if System.Stream_Attributes.Block_IO_OK is False, then the BLK_IO --- form is treated as equivalent to the normal case, so that the optimization --- is inhibited anyway, regardless of the setting of the restriction. This --- handles versions of System.Stream_Attributes (in particular the XDR version --- found in s-stratt-xdr) which do not permit block io optimization. - -pragma Compiler_Unit_Warning; - -with Ada.Streams; - -with System.Storage_Elements; - -package System.Strings.Stream_Ops is - - ------------------------------------- - -- Storage_Array stream operations -- - ------------------------------------- - - function Storage_Array_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return System.Storage_Elements.Storage_Array; - - function Storage_Array_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return System.Storage_Elements.Storage_Array; - - procedure Storage_Array_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : System.Storage_Elements.Storage_Array); - - procedure Storage_Array_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : System.Storage_Elements.Storage_Array); - - procedure Storage_Array_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out System.Storage_Elements.Storage_Array); - - procedure Storage_Array_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out System.Storage_Elements.Storage_Array); - - procedure Storage_Array_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : System.Storage_Elements.Storage_Array); - - procedure Storage_Array_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : System.Storage_Elements.Storage_Array); - - -------------------------------------------- - -- Stream_Element_Array stream operations -- - -------------------------------------------- - - function Stream_Element_Array_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Ada.Streams.Stream_Element_Array; - - function Stream_Element_Array_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Ada.Streams.Stream_Element_Array; - - procedure Stream_Element_Array_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Ada.Streams.Stream_Element_Array); - - procedure Stream_Element_Array_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Ada.Streams.Stream_Element_Array); - - procedure Stream_Element_Array_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Ada.Streams.Stream_Element_Array); - - procedure Stream_Element_Array_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Ada.Streams.Stream_Element_Array); - - procedure Stream_Element_Array_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Ada.Streams.Stream_Element_Array); - - procedure Stream_Element_Array_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Ada.Streams.Stream_Element_Array); - - ------------------------------ - -- String stream operations -- - ------------------------------ - - function String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return String; - - function String_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return String; - - function String_Input_Tag - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return String; - -- Same as String_Input_Blk_IO, except raises an exception for overly long - -- Strings. See expansion of Attribute_Input in Exp_Attr for details. - - procedure String_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String); - - procedure String_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String); - - procedure String_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out String); - - procedure String_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out String); - - procedure String_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String); - - procedure String_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : String); - - ----------------------------------- - -- Wide_String stream operations -- - ----------------------------------- - - function Wide_String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Wide_String; - - function Wide_String_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Wide_String; - - procedure Wide_String_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String); - - procedure Wide_String_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String); - - procedure Wide_String_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_String); - - procedure Wide_String_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_String); - - procedure Wide_String_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String); - - procedure Wide_String_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_String); - - ---------------------------------------- - -- Wide_Wide_String stream operations -- - ---------------------------------------- - - function Wide_Wide_String_Input - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Wide_Wide_String; - - function Wide_Wide_String_Input_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class) - return Wide_Wide_String; - - procedure Wide_Wide_String_Output - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String); - - procedure Wide_Wide_String_Output_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String); - - procedure Wide_Wide_String_Read - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_Wide_String); - - procedure Wide_Wide_String_Read_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : out Wide_Wide_String); - - procedure Wide_Wide_String_Write - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String); - - procedure Wide_Wide_String_Write_Blk_IO - (Strm : access Ada.Streams.Root_Stream_Type'Class; - Item : Wide_Wide_String); - -end System.Strings.Stream_Ops; diff --git a/gcc/ada/s-tasloc.adb b/gcc/ada/s-tasloc.adb deleted file mode 100644 index ce95b6d..0000000 --- a/gcc/ada/s-tasloc.adb +++ /dev/null @@ -1,54 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T A S K _ L O C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1997-2010, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Soft_Links; - -package body System.Task_Lock is - - ---------- - -- Lock -- - ---------- - - procedure Lock is - begin - System.Soft_Links.Lock_Task.all; - end Lock; - - ------------ - -- Unlock -- - ------------ - - procedure Unlock is - begin - System.Soft_Links.Unlock_Task.all; - end Unlock; - -end System.Task_Lock; diff --git a/gcc/ada/s-tasloc.ads b/gcc/ada/s-tasloc.ads deleted file mode 100644 index 5e370bb..0000000 --- a/gcc/ada/s-tasloc.ads +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T A S K _ L O C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 1998-2013, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Simple task lock and unlock routines - --- A small package containing a task lock and unlock routines for creating --- a critical region. The lock involved is a global lock, shared by all --- tasks, and by all calls to these routines, so these routines should be --- used with care to avoid unnecessary reduction of concurrency. - --- These routines may be used in a non-tasking program, and in that case --- they have no effect (they do NOT cause the tasking runtime to be loaded). - --- Note: this package is in the System hierarchy so that it can be directly --- be used by other predefined packages. User access to this package is via --- a renaming of this package in GNAT.Task_Lock (file g-tasloc.ads). - -package System.Task_Lock is - pragma Preelaborate; - - procedure Lock; - pragma Inline (Lock); - -- Acquires the global lock, starts the execution of a critical region - -- which no other task can enter until the locking task calls Unlock - - procedure Unlock; - pragma Inline (Unlock); - -- Releases the global lock, allowing another task to successfully - -- complete a Lock operation. Terminates the critical region. - -- - -- The recommended protocol for using these two procedures is as - -- follows: - -- - -- Locked_Processing : begin - -- Lock; - -- ... - -- TSL.Unlock; - -- - -- exception - -- when others => - -- Unlock; - -- raise; - -- end Locked_Processing; - -- - -- This ensures that the lock is not left set if an exception is raised - -- explicitly or implicitly during the critical locked region. - -- - -- Note on multiple calls to Lock: It is permissible to call Lock - -- more than once with no intervening Unlock from a single task, - -- and the lock will not be released until the corresponding number - -- of Unlock operations has been performed. For example: - -- - -- System.Task_Lock.Lock; -- acquires lock - -- System.Task_Lock.Lock; -- no effect - -- System.Task_Lock.Lock; -- no effect - -- System.Task_Lock.Unlock; -- no effect - -- System.Task_Lock.Unlock; -- no effect - -- System.Task_Lock.Unlock; -- releases lock - -- - -- However, as previously noted, the Task_Lock facility should only - -- be used for very local locks where the probability of conflict is - -- low, so usually this kind of nesting is not a good idea in any case. - -- In more complex locking situations, it is more appropriate to define - -- an appropriate protected type to provide the required locking. - -- - -- It is an error to call Unlock when there has been no prior call to - -- Lock. The effect of such an erroneous call is undefined, and may - -- result in deadlock, or other malfunction of the run-time system. - -end System.Task_Lock; diff --git a/gcc/ada/s-traceb-hpux.adb b/gcc/ada/s-traceb-hpux.adb deleted file mode 100644 index dcd6ad0..0000000 --- a/gcc/ada/s-traceb-hpux.adb +++ /dev/null @@ -1,627 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K -- --- (HP/UX Version) -- --- -- --- B o d y -- --- -- --- Copyright (C) 2009-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body System.Traceback is - - -- This package implements the backtracing facility by way of a dedicated - -- HP library for stack unwinding described in the "Runtime Architecture - -- Document". - - pragma Linker_Options ("/usr/lib/libcl.a"); - - -- The library basically offers services to fetch information about a - -- "previous" frame based on information about a "current" one. - - type Current_Frame_Descriptor is record - cur_fsz : Address; -- Frame size of current routine. - cur_sp : Address; -- The current value of stack pointer. - cur_rls : Address; -- PC-space of the caller. - cur_rlo : Address; -- PC-offset of the caller. - cur_dp : Address; -- Data Pointer of the current routine. - top_rp : Address; -- Initial value of RP. - top_mrp : Address; -- Initial value of MRP. - top_sr0 : Address; -- Initial value of sr0. - top_sr4 : Address; -- Initial value of sr4. - top_r3 : Address; -- Initial value of gr3. - cur_r19 : Address; -- GR19 value of the calling routine. - top_r4 : Address; -- Initial value of gr4. - dummy : Address; -- Reserved. - out_rlo : Address; -- PC-offset of the caller after get_previous. - end record; - - type Previous_Frame_Descriptor is record - prev_fsz : Address; -- frame size of calling routine. - prev_sp : Address; -- SP of calling routine. - prev_rls : Address; -- PC_space of calling routine's caller. - prev_rlo : Address; -- PC_offset of calling routine's caller. - prev_dp : Address; -- DP of calling routine. - udescr0 : Address; -- low word of calling routine's unwind desc. - udescr1 : Address; -- high word of calling routine's unwind desc. - ustart : Address; -- start of the unwind region. - uend : Address; -- end of the unwind region. - uw_index : Address; -- index into the unwind table. - prev_r19 : Address; -- GR19 value of the caller's caller. - top_r3 : Address; -- Caller's initial gr3. - top_r4 : Address; -- Caller's initial gr4. - end record; - - -- Provide useful shortcuts for the names - - subtype CFD is Current_Frame_Descriptor; - subtype PFD is Previous_Frame_Descriptor; - - -- Frames with dynamic stack allocation are handled using the associated - -- frame pointer, but HP compilers and GCC setup this pointer differently. - -- HP compilers set it to point at the top (highest address) of the static - -- part of the frame, whereas GCC sets it to point at the bottom of this - -- region. We have to fake the unwinder to compensate for this difference, - -- for which we'll need to access some subprograms unwind descriptors. - - type Bits_2_Value is mod 2 ** 2; - for Bits_2_Value'Size use 2; - - type Bits_4_Value is mod 2 ** 4; - for Bits_4_Value'Size use 4; - - type Bits_5_Value is mod 2 ** 5; - for Bits_5_Value'Size use 5; - - type Bits_27_Value is mod 2 ** 27; - for Bits_27_Value'Size use 27; - - type Unwind_Descriptor is record - cannot_unwind : Boolean; - mcode : Boolean; - mcode_save_restore : Boolean; - region_desc : Bits_2_Value; - reserved0 : Boolean; - entry_sr : Boolean; - entry_fr : Bits_4_Value; - entry_gr : Bits_5_Value; - - args_stored : Boolean; - variable_frame : Boolean; - separate_package_body : Boolean; - frame_extension_mcode : Boolean; - - stack_overflow_check : Boolean; - two_steps_sp_adjust : Boolean; - sr4_export : Boolean; - cxx_info : Boolean; - - cxx_try_catch : Boolean; - sched_entry_seq : Boolean; - reserved1 : Boolean; - save_sp : Boolean; - - save_rp : Boolean; - save_mrp : Boolean; - save_r19 : Boolean; - cleanups : Boolean; - - hpe_interrupt_marker : Boolean; - hpux_interrupt_marker : Boolean; - large_frame : Boolean; - alloca_frame : Boolean; - - reserved2 : Boolean; - frame_size : Bits_27_Value; - end record; - - for Unwind_Descriptor'Size use 64; - - for Unwind_Descriptor use record - cannot_unwind at 0 range 0 .. 0; - mcode at 0 range 1 .. 1; - mcode_save_restore at 0 range 2 .. 2; - region_desc at 0 range 3 .. 4; - reserved0 at 0 range 5 .. 5; - entry_sr at 0 range 6 .. 6; - entry_fr at 0 range 7 .. 10; - - entry_gr at 1 range 3 .. 7; - - args_stored at 2 range 0 .. 0; - variable_frame at 2 range 1 .. 1; - separate_package_body at 2 range 2 .. 2; - frame_extension_mcode at 2 range 3 .. 3; - stack_overflow_check at 2 range 4 .. 4; - two_steps_sp_adjust at 2 range 5 .. 5; - sr4_export at 2 range 6 .. 6; - cxx_info at 2 range 7 .. 7; - - cxx_try_catch at 3 range 0 .. 0; - sched_entry_seq at 3 range 1 .. 1; - reserved1 at 3 range 2 .. 2; - save_sp at 3 range 3 .. 3; - save_rp at 3 range 4 .. 4; - save_mrp at 3 range 5 .. 5; - save_r19 at 3 range 6 .. 6; - cleanups at 3 range 7 .. 7; - - hpe_interrupt_marker at 4 range 0 .. 0; - hpux_interrupt_marker at 4 range 1 .. 1; - large_frame at 4 range 2 .. 2; - alloca_frame at 4 range 3 .. 3; - - reserved2 at 4 range 4 .. 4; - frame_size at 4 range 5 .. 31; - end record; - - subtype UWD is Unwind_Descriptor; - type UWD_Ptr is access all UWD; - - function To_UWD_Access is new Ada.Unchecked_Conversion (Address, UWD_Ptr); - - -- The descriptor associated with a given code location is retrieved - -- using functions imported from the HP library, requiring the definition - -- of additional structures. - - type Unwind_Table_Region is record - Table_Start : Address; - Table_End : Address; - end record; - -- An Unwind Table region, which is a memory area containing Unwind - -- Descriptors. - - subtype UWT is Unwind_Table_Region; - - -- The subprograms imported below are provided by the HP library - - function U_get_unwind_table return UWT; - pragma Import (C, U_get_unwind_table, "U_get_unwind_table"); - -- Get the unwind table region associated with the current executable. - -- This function is actually documented as having an argument, but which - -- is only used for the MPE/iX targets. - - function U_get_shLib_unwind_table (r19 : Address) return UWT; - pragma Import (C, U_get_shLib_unwind_table, "U_get_shLib_unw_tbl"); - -- Return the unwind table region associated with a possible shared - -- library, as determined by the provided r19 value. - - function U_get_shLib_text_addr (r19 : Address) return Address; - pragma Import (C, U_get_shLib_text_addr, "U_get_shLib_text_addr"); - -- Return the address at which the code for a shared library begins, or - -- -1 if the value provided for r19 does not identify shared library code. - - function U_get_unwind_entry - (Pc : Address; - Space : Address; - Table_Start : Address; - Table_End : Address) return Address; - pragma Import (C, U_get_unwind_entry, "U_get_unwind_entry"); - -- Given the bounds of an unwind table, return the address of the - -- unwind descriptor associated with a code location/space. In the case - -- of shared library code, the offset from the beginning of the library - -- is expected as Pc. - - procedure U_init_frame_record (Frame : not null access CFD); - pragma Import (C, U_init_frame_record, "U_init_frame_record"); - - procedure U_prep_frame_rec_for_unwind (Frame : not null access CFD); - pragma Import (C, U_prep_frame_rec_for_unwind, - "U_prep_frame_rec_for_unwind"); - - -- Fetch the description data of the frame in which these two procedures - -- are called. - - function U_get_u_rlo - (Cur : not null access CFD; Prev : not null access PFD) return Integer; - pragma Import (C, U_get_u_rlo, "U_IS_STUB_OR_CALLX"); - -- From a complete current frame with a return location possibly located - -- into a linker generated stub, and basic information about the previous - -- frame, place the first non stub return location into the current frame. - -- Return -1 if something went wrong during the computation. - - function U_is_shared_pc (rlo : Address; r19 : Address) return Address; - pragma Import (C, U_is_shared_pc, "U_is_shared_pc"); - -- Return 0 if the provided return location does not correspond to code - -- in a shared library, or something non null otherwise. - - function U_get_previous_frame_x - (current_frame : not null access CFD; - previous_frame : not null access PFD; - previous_size : Integer) return Integer; - pragma Import (C, U_get_previous_frame_x, "U_get_previous_frame_x"); - -- Fetch the data describing the "previous" frame relatively to the - -- "current" one. "previous_size" should be the size of the "previous" - -- frame descriptor provided. - -- - -- The library provides a simpler interface without the size parameter - -- but it is not usable when frames with dynamically allocated space are - -- on the way. - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Same as the exported version, but takes Traceback as an Address - - ------------------ - -- C_Call_Chain -- - ------------------ - - function C_Call_Chain - (Traceback : System.Address; - Max_Len : Natural) return Natural - is - Val : Natural; - begin - Call_Chain (Traceback, Max_Len, Val); - return Val; - end C_Call_Chain; - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - type Tracebacks_Array is array (1 .. Max_Len) of System.Address; - pragma Suppress_Initialization (Tracebacks_Array); - - -- The code location returned by the unwinder is a return location but - -- what we need is a call point. Under HP-UX call instructions are 4 - -- bytes long and the return point they specify is 4 bytes beyond the - -- next instruction because of the delay slot. - - Call_Size : constant := 4; - DSlot_Size : constant := 4; - Rlo_Offset : constant := Call_Size + DSlot_Size; - - -- Moreover, the return point is passed via a register which two least - -- significant bits specify a privilege level that we will have to mask. - - Priv_Mask : constant := 16#00000003#; - - Frame : aliased CFD; - Code : System.Address; - J : Natural := 1; - Pop_Success : Boolean; - Trace : Tracebacks_Array; - for Trace'Address use Traceback; - - -- The backtracing process needs a set of subprograms : - - function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr; - -- Return an access to the unwind descriptor for the caller of - -- a given frame, using only the provided return location. - - function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr; - -- Return an access to the unwind descriptor for the user code caller - -- of a given frame, or null if the information is not available. - - function Pop_Frame (Frame : not null access CFD) return Boolean; - -- Update the provided machine state structure so that it reflects - -- the state one call frame "above" the initial one. - -- - -- Return True if the operation has been successful, False otherwise. - -- Failure typically occurs when the top of the call stack has been - -- reached. - - function Prepare_For_Unwind_Of - (Frame : not null access CFD) return Boolean; - -- Perform the necessary adaptations to the machine state before - -- calling the unwinder. Currently used for the specific case of - -- dynamically sized previous frames. - -- - -- Return True if everything went fine, or False otherwise. - - Program_UWT : constant UWT := U_get_unwind_table; - - --------------- - -- Pop_Frame -- - --------------- - - function Pop_Frame (Frame : not null access CFD) return Boolean is - Up_Frame : aliased PFD; - State_Ready : Boolean; - - begin - -- Check/adapt the state before calling the unwinder and return - -- if anything went wrong. - - State_Ready := Prepare_For_Unwind_Of (Frame); - - if not State_Ready then - return False; - end if; - - -- Now, safely call the unwinder and use the results - - if U_get_previous_frame_x (Frame, - Up_Frame'Access, - Up_Frame'Size) /= 0 - then - return False; - end if; - - -- In case a stub is on the way, the usual previous return location - -- (the one in prev_rlo) is the one in the stub and the "real" one - -- is placed in the "current" record, so let's take this one into - -- account. - - Frame.out_rlo := Frame.cur_rlo; - - Frame.cur_fsz := Up_Frame.prev_fsz; - Frame.cur_sp := Up_Frame.prev_sp; - Frame.cur_rls := Up_Frame.prev_rls; - Frame.cur_rlo := Up_Frame.prev_rlo; - Frame.cur_dp := Up_Frame.prev_dp; - Frame.cur_r19 := Up_Frame.prev_r19; - Frame.top_r3 := Up_Frame.top_r3; - Frame.top_r4 := Up_Frame.top_r4; - - return True; - end Pop_Frame; - - --------------------------------- - -- Prepare_State_For_Unwind_Of -- - --------------------------------- - - function Prepare_For_Unwind_Of - (Frame : not null access CFD) return Boolean - is - Caller_UWD : UWD_Ptr; - FP_Adjustment : Integer; - - begin - -- No need to bother doing anything if the stack is already fully - -- unwound. - - if Frame.cur_rlo = 0 then - return False; - end if; - - -- When ALLOCA_FRAME is set in an unwind descriptor, the unwinder - -- uses the value provided in current.top_r3 or current.top_r4 as - -- a frame pointer to compute the size of the frame. What decides - -- between r3 or r4 is the unwind descriptor LARGE_FRAME bit, with - -- r4 chosen if the bit is set. - - -- The size computed by the unwinder is STATIC_PART + (SP - FP), - -- which is correct with HP's frame pointer convention, but not - -- with GCC's one since we end up with the static part accounted - -- for twice. - - -- We have to compute r4 when it is required because the unwinder - -- has looked for it at a place where it was not if we went through - -- GCC frames. - - -- The size of the static part of a frame can be found in the - -- associated unwind descriptor. - - Caller_UWD := UWD_For_Caller_Of (Frame); - - -- If we cannot get it, we are unable to compute the potentially - -- necessary adjustments. We'd better not try to go on then. - - if Caller_UWD = null then - return False; - end if; - - -- If the caller frame is a GCC one, r3 is its frame pointer and - -- points to the bottom of the frame. The value to provide for r4 - -- can then be computed directly from the one of r3, compensating - -- for the static part of the frame. - - -- If the caller frame is an HP one, r3 is used to locate the - -- previous frame marker, that is it also points to the bottom of - -- the frame (this is why r3 cannot be used as the frame pointer in - -- the HP sense for large frames). The value to provide for r4 can - -- then also be computed from the one of r3 with the compensation - -- for the static part of the frame. - - FP_Adjustment := Integer (Caller_UWD.frame_size * 8); - Frame.top_r4 := Address (Integer (Frame.top_r3) + FP_Adjustment); - - return True; - end Prepare_For_Unwind_Of; - - ----------------------- - -- UWD_For_Caller_Of -- - ----------------------- - - function UWD_For_Caller_Of (Frame : not null access CFD) return UWD_Ptr - is - UWD_Access : UWD_Ptr; - - begin - -- First try the most direct path, using the return location data - -- associated with the frame. - - UWD_Access := UWD_For_RLO_Of (Frame); - - if UWD_Access /= null then - return UWD_Access; - end if; - - -- If we did not get a result, we might face an in-stub return - -- address. In this case U_get_previous_frame can tell us what the - -- first not-in-stub return point is. We cannot call it directly, - -- though, because we haven't computed the potentially necessary - -- frame pointer adjustments, which might lead to SEGV in some - -- circumstances. Instead, we directly call the libcl routine which - -- is called by U_get_previous_frame and which only requires few - -- information. Take care, however, that the information is provided - -- in the "current" argument, so we need to work on a copy to avoid - -- disturbing our caller. - - declare - U_Current : aliased CFD := Frame.all; - U_Previous : aliased PFD; - - begin - U_Previous.prev_dp := U_Current.cur_dp; - U_Previous.prev_rls := U_Current.cur_rls; - U_Previous.prev_sp := U_Current.cur_sp - U_Current.cur_fsz; - - if U_get_u_rlo (U_Current'Access, U_Previous'Access) /= -1 then - UWD_Access := UWD_For_RLO_Of (U_Current'Access); - end if; - end; - - return UWD_Access; - end UWD_For_Caller_Of; - - -------------------- - -- UWD_For_RLO_Of -- - -------------------- - - function UWD_For_RLO_Of (Frame : not null access CFD) return UWD_Ptr - is - UWD_Address : Address; - - -- The addresses returned by the library point to full descriptors - -- including the frame information bits but also the applicable PC - -- range. We need to account for this. - - Frame_Info_Offset : constant := 8; - - begin - -- First try to locate the descriptor in the program's unwind table - - UWD_Address := U_get_unwind_entry (Frame.cur_rlo, - Frame.cur_rls, - Program_UWT.Table_Start, - Program_UWT.Table_End); - - -- If we did not get it, we might have a frame from code in a - -- stub or shared library. For code in stub we would have to - -- compute the first non-stub return location but this is not - -- the role of this subprogram, so let's just try to see if we - -- can get a result from the tables in shared libraries. - - if UWD_Address = -1 - and then U_is_shared_pc (Frame.cur_rlo, Frame.cur_r19) /= 0 - then - declare - Shlib_UWT : constant UWT := - U_get_shLib_unwind_table (Frame.cur_r19); - Shlib_Start : constant Address := - U_get_shLib_text_addr (Frame.cur_r19); - Rlo_Offset : constant Address := - Frame.cur_rlo - Shlib_Start; - begin - UWD_Address := U_get_unwind_entry (Rlo_Offset, - Frame.cur_rls, - Shlib_UWT.Table_Start, - Shlib_UWT.Table_End); - end; - end if; - - if UWD_Address /= -1 then - return To_UWD_Access (UWD_Address + Frame_Info_Offset); - else - return null; - end if; - end UWD_For_RLO_Of; - - -- Start of processing for Call_Chain - - begin - -- Fetch the state for this subprogram's frame and pop it so that we - -- start with an initial out_rlo "here". - - U_init_frame_record (Frame'Access); - Frame.top_sr0 := 0; - Frame.top_sr4 := 0; - - U_prep_frame_rec_for_unwind (Frame'Access); - - Pop_Success := Pop_Frame (Frame'Access); - - -- Skip the requested number of frames - - for I in 1 .. Skip_Frames loop - Pop_Success := Pop_Frame (Frame'Access); - end loop; - - -- Loop popping frames and storing locations until either a problem - -- occurs, or the top of the call chain is reached, or the provided - -- array is full. - - loop - -- We have to test some conditions against the return location - -- as it is returned, so get it as is first. - - Code := Frame.out_rlo; - - exit when not Pop_Success or else Code = 0 or else J = Max_Len + 1; - - -- Compute the call point from the retrieved return location : - -- Mask the privilege bits and account for the delta between the - -- call site and the return point. - - Code := (Code and not Priv_Mask) - Rlo_Offset; - - if Code < Exclude_Min or else Code > Exclude_Max then - Trace (J) := Code; - J := J + 1; - end if; - - Pop_Success := Pop_Frame (Frame'Access); - end loop; - - Len := J - 1; - end Call_Chain; - - procedure Call_Chain - (Traceback : in out System.Traceback_Entries.Tracebacks_Array; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - begin - Call_Chain - (Traceback'Address, Max_Len, Len, - Exclude_Min, Exclude_Max, - - -- Skip one extra frame to skip the other Call_Chain entry as well - - Skip_Frames => Skip_Frames + 1); - end Call_Chain; - -end System.Traceback; diff --git a/gcc/ada/s-traceb-mastop.adb b/gcc/ada/s-traceb-mastop.adb deleted file mode 100644 index 1a00d97..0000000 --- a/gcc/ada/s-traceb-mastop.adb +++ /dev/null @@ -1,137 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2015, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version uses System.Machine_State_Operations routines - -with System.Machine_State_Operations; - -package body System.Traceback is - - use System.Machine_State_Operations; - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Same as the exported version, but takes Traceback as an Address - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - type Tracebacks_Array is array (1 .. Max_Len) of Code_Loc; - pragma Suppress_Initialization (Tracebacks_Array); - - M : Machine_State; - Code : Code_Loc; - - Trace : Tracebacks_Array; - for Trace'Address use Traceback; - - N_Skips : Natural := 0; - - begin - M := Allocate_Machine_State; - Set_Machine_State (M); - - -- Skip the requested number of frames - - loop - Code := Get_Code_Loc (M); - exit when Code = Null_Address or else N_Skips = Skip_Frames; - - Pop_Frame (M); - N_Skips := N_Skips + 1; - end loop; - - -- Now, record the frames outside the exclusion bounds, updating - -- the Len output value along the way. - - Len := 0; - loop - Code := Get_Code_Loc (M); - exit when Code = Null_Address or else Len = Max_Len; - - if Code < Exclude_Min or else Code > Exclude_Max then - Len := Len + 1; - Trace (Len) := Code; - end if; - - Pop_Frame (M); - end loop; - - Free_Machine_State (M); - end Call_Chain; - - procedure Call_Chain - (Traceback : in out System.Traceback_Entries.Tracebacks_Array; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - begin - Call_Chain - (Traceback'Address, Max_Len, Len, - Exclude_Min, Exclude_Max, - - -- Skip one extra frame to skip the other Call_Chain entry as well - - Skip_Frames => Skip_Frames + 1); - end Call_Chain; - - ------------------ - -- C_Call_Chain -- - ------------------ - - function C_Call_Chain - (Traceback : System.Address; - Max_Len : Natural) return Natural - is - Val : Natural; - begin - Call_Chain (Traceback, Max_Len, Val); - return Val; - end C_Call_Chain; - -end System.Traceback; diff --git a/gcc/ada/s-traceb.adb b/gcc/ada/s-traceb.adb deleted file mode 100644 index e467113..0000000 --- a/gcc/ada/s-traceb.adb +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default version of this package - --- Note: this unit must be compiled using -fno-optimize-sibling-calls. --- See comment below in body of Call_Chain for details on the reason. - -pragma Compiler_Unit_Warning; - -package body System.Traceback is - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Same as the exported version, but takes Traceback as an Address - - ------------------ - -- C_Call_Chain -- - ------------------ - - function C_Call_Chain - (Traceback : System.Address; - Max_Len : Natural) return Natural - is - Val : Natural; - begin - Call_Chain (Traceback, Max_Len, Val); - return Val; - end C_Call_Chain; - - ---------------- - -- Call_Chain -- - ---------------- - - function Backtrace - (Traceback : System.Address; - Len : Integer; - Exclude_Min : System.Address; - Exclude_Max : System.Address; - Skip_Frames : Integer) - return Integer; - pragma Import (C, Backtrace, "__gnat_backtrace"); - - procedure Call_Chain - (Traceback : System.Address; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - begin - -- Note: Backtrace relies on the following call actually creating a - -- stack frame. To ensure that this is the case, it is essential to - -- compile this unit without sibling call optimization. - - -- We want the underlying engine to skip its own frame plus the - -- ones we have been requested to skip ourselves. - - Len := Backtrace (Traceback => Traceback, - Len => Max_Len, - Exclude_Min => Exclude_Min, - Exclude_Max => Exclude_Max, - Skip_Frames => Skip_Frames + 1); - end Call_Chain; - - procedure Call_Chain - (Traceback : in out System.Traceback_Entries.Tracebacks_Array; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1) - is - begin - Call_Chain - (Traceback'Address, Max_Len, Len, - Exclude_Min, Exclude_Max, - - -- Skip one extra frame to skip the other Call_Chain entry as well - - Skip_Frames => Skip_Frames + 1); - end Call_Chain; - -end System.Traceback; diff --git a/gcc/ada/s-traceb.ads b/gcc/ada/s-traceb.ads deleted file mode 100644 index 283bd5c..0000000 --- a/gcc/ada/s-traceb.ads +++ /dev/null @@ -1,87 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 method for generating a traceback of the current --- execution location. The traceback shows the locations of calls in the call --- chain, up to either the top or a designated number of levels. - -pragma Compiler_Unit_Warning; - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with System.Exception_Tables. - -with System.Traceback_Entries; - -package System.Traceback is - - ---------------- - -- Call_Chain -- - ---------------- - - procedure Call_Chain - (Traceback : in out System.Traceback_Entries.Tracebacks_Array; - Max_Len : Natural; - Len : out Natural; - Exclude_Min : System.Address := System.Null_Address; - Exclude_Max : System.Address := System.Null_Address; - Skip_Frames : Natural := 1); - -- Store up to Max_Len code locations in Traceback, corresponding to the - -- current call chain. - -- - -- Traceback is an array of addresses where the result will be stored. - -- - -- Max_Len is the length of the Traceback array. If the call chain is - -- longer than this, then additional entries are discarded, and the - -- traceback is missing some of the highest level entries. - -- - -- Len is the number of addresses returned in the Traceback array - -- - -- Exclude_Min/Exclude_Max, if non null, provide a range of addresses - -- to ignore from the computation of the traceback. - -- - -- Skip_Frames says how many of the most recent calls should at least - -- be excluded from the result, regardless of the exclusion bounds and - -- starting with this procedure itself: 1 means exclude the frame for - -- this procedure, 2 means 1 + exclude the frame for this procedure's - -- caller, ... - -- - -- On return, the Traceback array is filled in, and Len indicates the - -- number of stored entries. The first entry is the most recent call, - -- and the last entry is the highest level call. - - function C_Call_Chain - (Traceback : System.Address; - Max_Len : Natural) return Natural; - pragma Export (C, C_Call_Chain, "system__traceback__c_call_chain"); - -- Version that can be used directly from C - -end System.Traceback; diff --git a/gcc/ada/s-traent.adb b/gcc/ada/s-traent.adb deleted file mode 100644 index 48abe8a..0000000 --- a/gcc/ada/s-traent.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2003-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions. - -pragma Compiler_Unit_Warning; - -package body System.Traceback_Entries is - - ------------ - -- PC_For -- - ------------ - - function PC_For (TB_Entry : Traceback_Entry) return System.Address is - begin - return TB_Entry; - end PC_For; - - ------------------ - -- TB_Entry_For -- - ------------------ - - function TB_Entry_For (PC : System.Address) return Traceback_Entry is - begin - return PC; - end TB_Entry_For; - -end System.Traceback_Entries; diff --git a/gcc/ada/s-traent.ads b/gcc/ada/s-traent.ads deleted file mode 100644 index 4d83426..0000000 --- a/gcc/ada/s-traent.ads +++ /dev/null @@ -1,67 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K _ E N T R I E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2003-2014, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package offers an abstraction of what is stored in traceback arrays --- for call-chain computation purposes. By default, as defined in this --- version of the package, an entry is a mere code location representing the --- address of a call instruction part of the call-chain. - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we get --- elaboration circularities with Ada.Exceptions. - -pragma Compiler_Unit_Warning; - -package System.Traceback_Entries is - pragma Preelaborate; - - subtype Traceback_Entry is System.Address; - -- This subtype defines what each traceback array entry contains - - Null_TB_Entry : constant Traceback_Entry := System.Null_Address; - -- This is the value to be used when initializing an entry - - type Tracebacks_Array is array (Positive range <>) of Traceback_Entry; - - function PC_For (TB_Entry : Traceback_Entry) return System.Address; - pragma Inline (PC_For); - -- Returns the address of the call instruction associated with the - -- provided entry. - - function TB_Entry_For (PC : System.Address) return Traceback_Entry; - pragma Inline (TB_Entry_For); - -- Returns an entry representing a frame for a call instruction at PC - -end System.Traceback_Entries; diff --git a/gcc/ada/s-trasym-dwarf.adb b/gcc/ada/s-trasym-dwarf.adb deleted file mode 100644 index 9655722..0000000 --- a/gcc/ada/s-trasym-dwarf.adb +++ /dev/null @@ -1,689 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support for targets using DWARF debug data - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on. - -with Ada.Unchecked_Deallocation; - -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with Ada.Containers.Generic_Array_Sort; - -with System.Address_To_Access_Conversions; -with System.Soft_Links; -with System.CRTL; -with System.Dwarf_Lines; -with System.Exception_Traces; -with System.Standard_Library; -with System.Traceback_Entries; -with System.Strings; -with System.Bounded_Strings; - -package body System.Traceback.Symbolic is - - use System.Bounded_Strings; - use System.Dwarf_Lines; - - subtype Big_String is String (Positive); - -- To deal with C strings - - package Big_String_Conv is new System.Address_To_Access_Conversions - (Big_String); - - type Module_Cache; - type Module_Cache_Acc is access all Module_Cache; - - type Module_Cache is record - Name : Strings.String_Access; - -- Name of the module - - C : Dwarf_Context (In_Exception => True); - -- Context to symbolize an address within this module - - Chain : Module_Cache_Acc; - end record; - - procedure Free is new Ada.Unchecked_Deallocation - (Module_Cache, - Module_Cache_Acc); - - Cache_Chain : Module_Cache_Acc; - -- Simply linked list of modules - - type Module_Array is array (Natural range <>) of Module_Cache_Acc; - type Module_Array_Acc is access Module_Array; - - Modules_Cache : Module_Array_Acc; - -- Sorted array of cached modules (if not null) - - Exec_Module : aliased Module_Cache; - -- Context for the executable - - type Init_State is (Uninitialized, Initialized, Failed); - Exec_Module_State : Init_State := Uninitialized; - -- How Exec_Module is initialized - - procedure Init_Exec_Module; - -- Initialize Exec_Module if not already initialized - - function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array; - Suppress_Hex : Boolean) return String; - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence; - Suppress_Hex : Boolean) return String; - -- Suppress_Hex means do not print any hexadecimal addresses, even if the - -- symbol is not available. - - function Lt (Left, Right : Module_Cache_Acc) return Boolean; - -- Sort function for Module_Cache - - procedure Init_Module - (Module : out Module_Cache; - Success : out Boolean; - Module_Name : String; - Load_Address : Address := Null_Address); - -- Initialize Module - - procedure Close_Module (Module : in out Module_Cache); - -- Finalize Module - - function Value (Item : System.Address) return String; - -- Return the String contained in Item, up until the first NUL character - - pragma Warnings (Off, "*Add_Module_To_Cache*"); - procedure Add_Module_To_Cache (Module_Name : String); - -- To be called by Build_Cache_For_All_Modules to add a new module to the - -- list. May not be referenced. - - package Module_Name is - - procedure Build_Cache_For_All_Modules; - -- Create the cache for all current modules - - function Get (Addr : access System.Address) return String; - -- Returns the module name for the given address, Addr may be updated - -- to be set relative to a shared library. This depends on the platform. - -- Returns an empty string for the main executable. - - function Is_Supported return Boolean; - pragma Inline (Is_Supported); - -- Returns True if Module_Name is supported, so if the traceback is - -- supported for shared libraries. - - end Module_Name; - - package body Module_Name is separate; - - function Executable_Name return String; - -- Returns the executable name as reported by argv[0]. If gnat_argv not - -- initialized or if argv[0] executable not found in path, function returns - -- an empty string. - - function Get_Executable_Load_Address return System.Address; - pragma Import - (C, - Get_Executable_Load_Address, - "__gnat_get_executable_load_address"); - -- Get the load address of the executable, or Null_Address if not known - - procedure Hexa_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Non-symbolic traceback (simply write addresses in hexa) - - procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Like the public Symbolic_Traceback_No_Lock except there is no provision - -- against concurrent accesses. - - procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Returns the Traceback for a given module - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Build string containing symbolic traceback for the given call chain - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String); - -- Likewise but using Module - - Max_String_Length : constant := 4096; - -- Arbitrary limit on Bounded_Str length - - ----------- - -- Value -- - ----------- - - function Value (Item : System.Address) return String is - begin - if Item /= Null_Address then - for J in Big_String'Range loop - if Big_String_Conv.To_Pointer (Item) (J) = ASCII.NUL then - return Big_String_Conv.To_Pointer (Item) (1 .. J - 1); - end if; - end loop; - end if; - - return ""; - end Value; - - ------------------------- - -- Add_Module_To_Cache -- - ------------------------- - - procedure Add_Module_To_Cache (Module_Name : String) is - Module : Module_Cache_Acc; - Success : Boolean; - begin - Module := new Module_Cache; - Init_Module (Module.all, Success, Module_Name); - if not Success then - Free (Module); - return; - end if; - Module.Chain := Cache_Chain; - Cache_Chain := Module; - end Add_Module_To_Cache; - - ---------------------- - -- Init_Exec_Module -- - ---------------------- - - procedure Init_Exec_Module is - begin - if Exec_Module_State = Uninitialized then - declare - Exec_Path : constant String := Executable_Name; - Exec_Load : constant Address := Get_Executable_Load_Address; - Success : Boolean; - begin - Init_Module (Exec_Module, Success, Exec_Path, Exec_Load); - - if Success then - Exec_Module_State := Initialized; - else - Exec_Module_State := Failed; - end if; - end; - end if; - end Init_Exec_Module; - - -------- - -- Lt -- - -------- - - function Lt (Left, Right : Module_Cache_Acc) return Boolean is - begin - return Low (Left.C) < Low (Right.C); - end Lt; - - ----------------------------- - -- Module_Cache_Array_Sort -- - ----------------------------- - - procedure Module_Cache_Array_Sort is new Ada.Containers.Generic_Array_Sort - (Natural, - Module_Cache_Acc, - Module_Array, - Lt); - - ------------------ - -- Enable_Cache -- - ------------------ - - procedure Enable_Cache (Include_Modules : Boolean := False) is - begin - -- Can be called at most once - if Cache_Chain /= null then - return; - end if; - - -- Add all modules - Init_Exec_Module; - Cache_Chain := Exec_Module'Access; - - if Include_Modules then - Module_Name.Build_Cache_For_All_Modules; - end if; - - -- Build and fill the array of modules - declare - Count : Natural; - Module : Module_Cache_Acc; - begin - for Phase in 1 .. 2 loop - Count := 0; - Module := Cache_Chain; - while Module /= null loop - Count := Count + 1; - - if Phase = 1 then - Enable_Cache (Module.C); - else - Modules_Cache (Count) := Module; - end if; - Module := Module.Chain; - end loop; - - if Phase = 1 then - Modules_Cache := new Module_Array (1 .. Count); - end if; - end loop; - end; - - -- Sort the array - Module_Cache_Array_Sort (Modules_Cache.all); - end Enable_Cache; - - --------------------- - -- Executable_Name -- - --------------------- - - function Executable_Name return String is - -- We have to import gnat_argv as an Address to match the type of - -- gnat_argv in the binder generated file. Otherwise, we get spurious - -- warnings about type mismatch when LTO is turned on. - - Gnat_Argv : System.Address; - pragma Import (C, Gnat_Argv, "gnat_argv"); - - type Argv_Array is array (0 .. 0) of System.Address; - package Conv is new System.Address_To_Access_Conversions (Argv_Array); - - function locate_exec_on_path (A : System.Address) return System.Address; - pragma Import (C, locate_exec_on_path, "__gnat_locate_exec_on_path"); - - begin - if Gnat_Argv = Null_Address then - return ""; - end if; - - declare - Addr : constant System.Address := - locate_exec_on_path (Conv.To_Pointer (Gnat_Argv) (0)); - Result : constant String := Value (Addr); - - begin - -- The buffer returned by locate_exec_on_path was allocated using - -- malloc, so we should use free to release the memory. - - if Addr /= Null_Address then - System.CRTL.free (Addr); - end if; - - return Result; - end; - end Executable_Name; - - ------------------ - -- Close_Module -- - ------------------ - - procedure Close_Module (Module : in out Module_Cache) is - begin - Close (Module.C); - Strings.Free (Module.Name); - end Close_Module; - - ----------------- - -- Init_Module -- - ----------------- - - procedure Init_Module - (Module : out Module_Cache; - Success : out Boolean; - Module_Name : String; - Load_Address : Address := Null_Address) - is - begin - -- Early return if the module is not known - - if Module_Name = "" then - Success := False; - return; - end if; - - Open (Module_Name, Module.C, Success); - - -- If a module can't be opened just return now, we just cannot give more - -- information in this case. - - if not Success then - return; - end if; - - Set_Load_Address (Module.C, Load_Address); - - Module.Name := new String'(Module_Name); - end Init_Module; - - ------------------------------- - -- Module_Symbolic_Traceback -- - ------------------------------- - - procedure Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - Success : Boolean := False; - begin - if Symbolic.Module_Name.Is_Supported then - Append (Res, '['); - Append (Res, Module.Name.all); - Append (Res, ']' & ASCII.LF); - end if; - - Dwarf_Lines.Symbolic_Traceback - (Module.C, - Traceback, - Suppress_Hex, - Success, - Res); - - if not Success then - Hexa_Traceback (Traceback, Suppress_Hex, Res); - end if; - - -- We must not allow an unhandled exception here, since this function - -- may be installed as a decorator for all automatic exceptions. - - exception - when others => - return; - end Module_Symbolic_Traceback; - - ------------------------------------- - -- Multi_Module_Symbolic_Traceback -- - ------------------------------------- - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - F : constant Natural := Traceback'First; - begin - if Traceback'Length = 0 or else Is_Full (Res) then - return; - end if; - - if Modules_Cache /= null then - -- Search in the cache - - declare - Addr : constant Address := Traceback (F); - Hi, Lo, Mid : Natural; - begin - Lo := Modules_Cache'First; - Hi := Modules_Cache'Last; - while Lo <= Hi loop - Mid := (Lo + Hi) / 2; - if Addr < Low (Modules_Cache (Mid).C) then - Hi := Mid - 1; - elsif Is_Inside (Modules_Cache (Mid).C, Addr) then - Multi_Module_Symbolic_Traceback - (Traceback, - Modules_Cache (Mid).all, - Suppress_Hex, - Res); - return; - else - Lo := Mid + 1; - end if; - end loop; - - -- Not found - Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); - Multi_Module_Symbolic_Traceback - (Traceback (F + 1 .. Traceback'Last), - Suppress_Hex, - Res); - end; - else - - -- First try the executable - if Is_Inside (Exec_Module.C, Traceback (F)) then - Multi_Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); - return; - end if; - - -- Otherwise, try a shared library - declare - Addr : aliased System.Address := Traceback (F); - M_Name : constant String := Module_Name.Get (Addr'Access); - Module : Module_Cache; - Success : Boolean; - begin - Init_Module (Module, Success, M_Name, System.Null_Address); - if Success then - Multi_Module_Symbolic_Traceback - (Traceback, - Module, - Suppress_Hex, - Res); - Close_Module (Module); - else - -- Module not found - Hexa_Traceback (Traceback (F .. F), Suppress_Hex, Res); - Multi_Module_Symbolic_Traceback - (Traceback (F + 1 .. Traceback'Last), - Suppress_Hex, - Res); - end if; - end; - end if; - end Multi_Module_Symbolic_Traceback; - - procedure Multi_Module_Symbolic_Traceback - (Traceback : Tracebacks_Array; - Module : Module_Cache; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - Pos : Positive; - begin - -- Will symbolize the first address... - - Pos := Traceback'First + 1; - - -- ... and all addresses in the same module - - Same_Module : - loop - exit Same_Module when Pos > Traceback'Last; - - -- Get address to check for corresponding module name - - exit Same_Module when not Is_Inside (Module.C, Traceback (Pos)); - - Pos := Pos + 1; - end loop Same_Module; - - Module_Symbolic_Traceback - (Traceback (Traceback'First .. Pos - 1), - Module, - Suppress_Hex, - Res); - Multi_Module_Symbolic_Traceback - (Traceback (Pos .. Traceback'Last), - Suppress_Hex, - Res); - end Multi_Module_Symbolic_Traceback; - - -------------------- - -- Hexa_Traceback -- - -------------------- - - procedure Hexa_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - use System.Traceback_Entries; - begin - if Suppress_Hex then - Append (Res, "..."); - Append (Res, ASCII.LF); - else - for J in Traceback'Range loop - Append_Address (Res, PC_For (Traceback (J))); - Append (Res, ASCII.LF); - end loop; - end if; - end Hexa_Traceback; - - -------------------------------- - -- Symbolic_Traceback_No_Lock -- - -------------------------------- - - procedure Symbolic_Traceback_No_Lock - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean; - Res : in out Bounded_String) - is - begin - if Symbolic.Module_Name.Is_Supported then - Multi_Module_Symbolic_Traceback (Traceback, Suppress_Hex, Res); - else - if Exec_Module_State = Failed then - Append (Res, "Call stack traceback locations:" & ASCII.LF); - Hexa_Traceback (Traceback, Suppress_Hex, Res); - else - Module_Symbolic_Traceback - (Traceback, - Exec_Module, - Suppress_Hex, - Res); - end if; - end if; - end Symbolic_Traceback_No_Lock; - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback - (Traceback : Tracebacks_Array; - Suppress_Hex : Boolean) return String - is - Res : Bounded_String (Max_Length => Max_String_Length); - begin - System.Soft_Links.Lock_Task.all; - Init_Exec_Module; - Symbolic_Traceback_No_Lock (Traceback, Suppress_Hex, Res); - System.Soft_Links.Unlock_Task.all; - - return To_String (Res); - - exception - when others => - System.Soft_Links.Unlock_Task.all; - raise; - end Symbolic_Traceback; - - function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is - begin - return Symbolic_Traceback (Traceback, Suppress_Hex => False); - end Symbolic_Traceback; - - function Symbolic_Traceback_No_Hex - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is - begin - return Symbolic_Traceback (Traceback, Suppress_Hex => True); - end Symbolic_Traceback_No_Hex; - - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence; - Suppress_Hex : Boolean) return String - is - begin - return Symbolic_Traceback - (Ada.Exceptions.Traceback.Tracebacks (E), - Suppress_Hex); - end Symbolic_Traceback; - - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence) return String - is - begin - return Symbolic_Traceback (E, Suppress_Hex => False); - end Symbolic_Traceback; - - function Symbolic_Traceback_No_Hex - (E : Ada.Exceptions.Exception_Occurrence) return String is - begin - return Symbolic_Traceback (E, Suppress_Hex => True); - end Symbolic_Traceback_No_Hex; - - Exception_Tracebacks_Symbolic : Integer; - pragma Import - (C, - Exception_Tracebacks_Symbolic, - "__gl_exception_tracebacks_symbolic"); - -- Boolean indicating whether symbolic tracebacks should be generated. - - use Standard_Library; -begin - -- If this version of this package is available, and the binder switch -Es - -- was given, then we want to use this as the decorator by default, and we - -- want to turn on tracing for Unhandled_Raise_In_Main. Note that the user - -- cannot have already set Exception_Trace, because the runtime library is - -- elaborated before user-defined code. - - if Exception_Tracebacks_Symbolic /= 0 then - Exception_Traces.Set_Trace_Decorator (Symbolic_Traceback'Access); - pragma Assert (Exception_Trace = RM_Convention); - Exception_Trace := Unhandled_Raise_In_Main; - end if; -end System.Traceback.Symbolic; diff --git a/gcc/ada/s-trasym.adb b/gcc/ada/s-trasym.adb deleted file mode 100644 index 070f9a9..0000000 --- a/gcc/ada/s-trasym.adb +++ /dev/null @@ -1,112 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1999-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the default implementation for platforms where the full capability --- is not supported. It returns tracebacks as lists of hexadecimal addresses --- of the form "0x...". - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on. - -with Ada.Exceptions.Traceback; use Ada.Exceptions.Traceback; -with System.Address_Image; - -package body System.Traceback.Symbolic is - - -- Note that Suppress_Hex is ignored in this version of this package. - - ------------------------ - -- Symbolic_Traceback -- - ------------------------ - - function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String - is - begin - if Traceback'Length = 0 then - return ""; - - else - declare - Img : String := System.Address_Image (Traceback (Traceback'First)); - - Result : String (1 .. (Img'Length + 3) * Traceback'Length); - Last : Natural := 0; - - begin - for J in Traceback'Range loop - Img := System.Address_Image (Traceback (J)); - Result (Last + 1 .. Last + 2) := "0x"; - Last := Last + 2; - Result (Last + 1 .. Last + Img'Length) := Img; - Last := Last + Img'Length + 1; - Result (Last) := ' '; - end loop; - - Result (Last) := ASCII.LF; - return Result (1 .. Last); - end; - end if; - end Symbolic_Traceback; - - -- "No_Hex" is ignored in this version, because otherwise we have nothing - -- at all to print. - - function Symbolic_Traceback_No_Hex - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String is - begin - return Symbolic_Traceback (Traceback); - end Symbolic_Traceback_No_Hex; - - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence) return String - is - begin - return Symbolic_Traceback (Ada.Exceptions.Traceback.Tracebacks (E)); - end Symbolic_Traceback; - - function Symbolic_Traceback_No_Hex - (E : Ada.Exceptions.Exception_Occurrence) return String is - begin - return Symbolic_Traceback (E); - end Symbolic_Traceback_No_Hex; - - ------------------ - -- Enable_Cache -- - ------------------ - - procedure Enable_Cache (Include_Modules : Boolean := False) is - begin - null; - end Enable_Cache; - -end System.Traceback.Symbolic; diff --git a/gcc/ada/s-trasym.ads b/gcc/ada/s-trasym.ads deleted file mode 100644 index ba9c89e..0000000 --- a/gcc/ada/s-trasym.ads +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . T R A C E B A C K . S Y M B O L I C -- --- -- --- S p e c -- --- -- --- Copyright (C) 1999-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Run-time symbolic traceback support - --- The routines provided in this package assume that your application has been --- compiled with debugging information turned on, since this information is --- used to build a symbolic traceback. - --- If you want to retrieve tracebacks from exception occurrences, it is also --- necessary to invoke the binder with -E switch. Please refer to the gnatbind --- documentation for more information. - --- Note that it is also possible (and often recommended) to compute symbolic --- traceback outside the program execution, which in addition allows you to --- distribute the executable with no debug info: --- --- - build your executable with debug info --- - archive this executable --- - strip a copy of the executable and distribute/deploy this version --- - at run time, compute absolute traceback (-bargs -E) from your --- executable and log it using Ada.Exceptions.Exception_Information --- - off line, compute the symbolic traceback using the executable archived --- with debug info and addr2line or gdb (using info line *) on the --- absolute addresses logged by your application. - --- In order to retrieve symbolic information, functions in this package will --- read on disk all the debug information of the executable file (found via --- Argument (0), and looked in the PATH if needed) or shared libraries using --- OS facilities, and load them in memory, causing a significant cpu and --- memory overhead. - -pragma Polling (Off); --- We must turn polling off for this unit, because otherwise we can get --- elaboration circularities when polling is turned on. - -with Ada.Exceptions; - -package System.Traceback.Symbolic is - pragma Elaborate_Body; - - function Symbolic_Traceback - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String; - function Symbolic_Traceback_No_Hex - (Traceback : System.Traceback_Entries.Tracebacks_Array) return String; - -- Build a string containing a symbolic traceback of the given call - -- chain. Note: These procedures may be installed by Set_Trace_Decorator, - -- to get a symbolic traceback on all exceptions raised (see - -- System.Exception_Traces). - - function Symbolic_Traceback - (E : Ada.Exceptions.Exception_Occurrence) return String; - function Symbolic_Traceback_No_Hex - (E : Ada.Exceptions.Exception_Occurrence) return String; - -- Build string containing symbolic traceback of given exception occurrence - - -- In the above, _No_Hex means do not print any hexadecimal addresses, even - -- if the symbol is not available. This is useful for getting deterministic - -- output from tests. - - procedure Enable_Cache (Include_Modules : Boolean := False); - -- Read symbolic information from binary files and cache them in memory. - -- This will speed up the above functions but will require more memory. If - -- Include_Modules is true, shared modules (or DLL) will also be cached. - -- This procedure may do nothing if not supported. The profile of this - -- subprogram may change in the future (new parameters can be added - -- with default value), but backward compatibility for direct calls - -- is supported. - -end System.Traceback.Symbolic; diff --git a/gcc/ada/s-tsmona-linux.adb b/gcc/ada/s-tsmona-linux.adb deleted file mode 100644 index 8c1f8b4..0000000 --- a/gcc/ada/s-tsmona-linux.adb +++ /dev/null @@ -1,190 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 . M O D U L E _ N A M E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2012-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the GNU/Linux specific version of this package -with Interfaces.C; use Interfaces.C; - -with System.Address_Operations; use System.Address_Operations; - -separate (System.Traceback.Symbolic) - -package body Module_Name is - - use System; - - pragma Linker_Options ("-ldl"); - - function Is_Shared_Lib (Base : Address) return Boolean; - -- Returns True if a shared library - - -- The principle is: - - -- 1. We get information about the module containing the address. - - -- 2. We check that the full pathname is pointing to a shared library. - - -- 3. for shared libraries, we return the non relocated address (so - -- the absolute address in the shared library). - - -- 4. we also return the full pathname of the module containing this - -- address. - - ------------------- - -- Is_Shared_Lib -- - ------------------- - - function Is_Shared_Lib (Base : Address) return Boolean is - EI_NIDENT : constant := 16; - type u16 is mod 2 ** 16; - - -- Just declare the needed header information, we just need to read the - -- type encoded in the second field. - - type Elf32_Ehdr is record - e_ident : char_array (1 .. EI_NIDENT); - e_type : u16; - end record; - - ET_DYN : constant := 3; -- A shared lib if e_type = ET_DYN - - Header : Elf32_Ehdr; - pragma Import (Ada, Header); - -- Suppress initialization in Normalized_Scalars mode - for Header'Address use Base; - - begin - return Header.e_type = ET_DYN; - exception - when others => - return False; - end Is_Shared_Lib; - - --------------------------------- - -- Build_Cache_For_All_Modules -- - --------------------------------- - - procedure Build_Cache_For_All_Modules is - type link_map; - type link_map_acc is access all link_map; - pragma Convention (C, link_map_acc); - - type link_map is record - l_addr : Address; - -- Base address of the shared object - - l_name : Address; - -- Null-terminated absolute file name - - l_ld : Address; - -- Dynamic section - - l_next, l_prev : link_map_acc; - -- Chain - end record; - pragma Convention (C, link_map); - - type r_debug_type is record - r_version : Integer; - r_map : link_map_acc; - end record; - pragma Convention (C, r_debug_type); - - r_debug : r_debug_type; - pragma Import (C, r_debug, "_r_debug"); - - lm : link_map_acc; - begin - lm := r_debug.r_map; - while lm /= null loop - if Big_String_Conv.To_Pointer (lm.l_name) (1) /= ASCII.NUL then - -- Discard non-file (like the executable itself or the gate). - Add_Module_To_Cache (Value (lm.l_name)); - end if; - lm := lm.l_next; - end loop; - end Build_Cache_For_All_Modules; - - --------- - -- Get -- - --------- - - function Get (Addr : access System.Address) return String is - - -- Dl_info record for Linux, used to get sym reloc offset - - type Dl_info is record - dli_fname : System.Address; - dli_fbase : System.Address; - dli_sname : System.Address; - dli_saddr : System.Address; - end record; - - function dladdr - (addr : System.Address; - info : not null access Dl_info) return int; - pragma Import (C, dladdr, "dladdr"); - -- This is a Linux extension and not POSIX - - info : aliased Dl_info; - - begin - if dladdr (Addr.all, info'Access) /= 0 then - - -- If we have a shared library we need to adjust the address to - -- be relative to the base address of the library. - - if Is_Shared_Lib (info.dli_fbase) then - Addr.all := SubA (Addr.all, info.dli_fbase); - end if; - - return Value (info.dli_fname); - - -- Not found, fallback to executable name - - else - return ""; - end if; - - exception - when others => - return ""; - end Get; - - ------------------ - -- Is_Supported -- - ------------------ - - function Is_Supported return Boolean is - begin - return True; - end Is_Supported; - -end Module_Name; diff --git a/gcc/ada/s-tsmona-mingw.adb b/gcc/ada/s-tsmona-mingw.adb deleted file mode 100644 index 46c35cd..0000000 --- a/gcc/ada/s-tsmona-mingw.adb +++ /dev/null @@ -1,93 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- 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 . M O D U L E _ N A M E -- --- -- --- B o d y -- --- -- --- Copyright (C) 2012-2017, AdaCore -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This is the Windows specific version of this package - -with System.Win32; use System.Win32; - -separate (System.Traceback.Symbolic) - -package body Module_Name is - - use System; - - --------------------------------- - -- Build_Cache_For_All_Modules -- - --------------------------------- - - procedure Build_Cache_For_All_Modules is - begin - null; - end Build_Cache_For_All_Modules; - - --------- - -- Get -- - --------- - - function Get (Addr : access System.Address) return String is - Res : DWORD; - hModule : aliased HANDLE; - Path : String (1 .. 1_024); - - begin - if GetModuleHandleEx - (GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, - Addr.all, - hModule'Access) = Win32.TRUE - then - Res := GetModuleFileName (hModule, Path'Address, Path'Length); - - if FreeLibrary (hModule) = Win32.FALSE then - null; - end if; - - if Res > 0 then - return Path (1 .. Positive (Res)); - end if; - end if; - - return ""; - - exception - when others => - return ""; - end Get; - - ------------------ - -- Is_Supported -- - ------------------ - - function Is_Supported return Boolean is - begin - return True; - end Is_Supported; - -end Module_Name; diff --git a/gcc/ada/s-unstyp.ads b/gcc/ada/s-unstyp.ads deleted file mode 100644 index f9ad385..0000000 --- a/gcc/ada/s-unstyp.ads +++ /dev/null @@ -1,215 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . U N S I G N E D _ T Y P E S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains definitions of standard unsigned types that --- correspond in size to the standard signed types declared in Standard, --- and (unlike the types in Interfaces) have corresponding names. It --- also contains some related definitions for other specialized types --- used by the compiler in connection with packed array types. - -pragma Compiler_Unit_Warning; - -package System.Unsigned_Types is - pragma Pure; - pragma No_Elaboration_Code_All; - - type Short_Short_Unsigned is mod 2 ** Short_Short_Integer'Size; - type Short_Unsigned is mod 2 ** Short_Integer'Size; - type Unsigned is mod 2 ** Integer'Size; - type Long_Unsigned is mod 2 ** Long_Integer'Size; - type Long_Long_Unsigned is mod 2 ** Long_Long_Integer'Size; - - type Float_Unsigned is mod 2 ** Float'Size; - -- Used in the implementation of Is_Negative intrinsic (see Exp_Intr) - - type Packed_Byte is mod 2 ** 8; - pragma Universal_Aliasing (Packed_Byte); - for Packed_Byte'Size use 8; - -- Component type for Packed_Bytes1, Packed_Bytes2 and Packed_Byte4 arrays. - -- As this type is used by the compiler to implement operations on user - -- packed array, it needs to be able to alias any type. - - type Packed_Bytes1 is array (Natural range <>) of aliased Packed_Byte; - for Packed_Bytes1'Alignment use 1; - for Packed_Bytes1'Component_Size use Packed_Byte'Size; - pragma Suppress_Initialization (Packed_Bytes1); - -- This is the type used to implement packed arrays where no alignment - -- is required. This includes the cases of 1,2,4 (where we use direct - -- masking operations), and all odd component sizes (where the clusters - -- are not aligned anyway, see, e.g. System.Pack_07 in file s-pack07 - -- for details. - - type Packed_Bytes2 is new Packed_Bytes1; - for Packed_Bytes2'Alignment use Integer'Min (2, Standard'Maximum_Alignment); - pragma Suppress_Initialization (Packed_Bytes2); - -- This is the type used to implement packed arrays where an alignment - -- of 2 (is possible) is helpful for maximum efficiency of the get and - -- set routines in the corresponding library unit. This is true of all - -- component sizes that are even but not divisible by 4 (other than 2 for - -- which we use direct masking operations). In such cases, the clusters - -- can be assumed to be 2-byte aligned if the array is aligned. See for - -- example System.Pack_10 in file s-pack10). - - type Packed_Bytes4 is new Packed_Bytes1; - for Packed_Bytes4'Alignment use Integer'Min (4, Standard'Maximum_Alignment); - pragma Suppress_Initialization (Packed_Bytes4); - -- This is the type used to implement packed arrays where an alignment - -- of 4 (if possible) is helpful for maximum efficiency of the get and - -- set routines in the corresponding library unit. This is true of all - -- component sizes that are divisible by 4 (other than powers of 2, which - -- are either handled by direct masking or not packed at all). In such - -- cases the clusters can be assumed to be 4-byte aligned if the array - -- is aligned (see System.Pack_12 in file s-pack12 as an example). - - type Bits_1 is mod 2**1; - type Bits_2 is mod 2**2; - type Bits_4 is mod 2**4; - -- Types used for packed array conversions - - subtype Bytes_F is Packed_Bytes4 (1 .. Float'Size / 8); - -- Type used in implementation of Is_Negative intrinsic (see Exp_Intr) - - function Shift_Left - (Value : Short_Short_Unsigned; - Amount : Natural) return Short_Short_Unsigned; - - function Shift_Right - (Value : Short_Short_Unsigned; - Amount : Natural) return Short_Short_Unsigned; - - function Shift_Right_Arithmetic - (Value : Short_Short_Unsigned; - Amount : Natural) return Short_Short_Unsigned; - - function Rotate_Left - (Value : Short_Short_Unsigned; - Amount : Natural) return Short_Short_Unsigned; - - function Rotate_Right - (Value : Short_Short_Unsigned; - Amount : Natural) return Short_Short_Unsigned; - - function Shift_Left - (Value : Short_Unsigned; - Amount : Natural) return Short_Unsigned; - - function Shift_Right - (Value : Short_Unsigned; - Amount : Natural) return Short_Unsigned; - - function Shift_Right_Arithmetic - (Value : Short_Unsigned; - Amount : Natural) return Short_Unsigned; - - function Rotate_Left - (Value : Short_Unsigned; - Amount : Natural) return Short_Unsigned; - - function Rotate_Right - (Value : Short_Unsigned; - Amount : Natural) return Short_Unsigned; - - function Shift_Left - (Value : Unsigned; - Amount : Natural) return Unsigned; - - function Shift_Right - (Value : Unsigned; - Amount : Natural) return Unsigned; - - function Shift_Right_Arithmetic - (Value : Unsigned; - Amount : Natural) return Unsigned; - - function Rotate_Left - (Value : Unsigned; - Amount : Natural) return Unsigned; - - function Rotate_Right - (Value : Unsigned; - Amount : Natural) return Unsigned; - - function Shift_Left - (Value : Long_Unsigned; - Amount : Natural) return Long_Unsigned; - - function Shift_Right - (Value : Long_Unsigned; - Amount : Natural) return Long_Unsigned; - - function Shift_Right_Arithmetic - (Value : Long_Unsigned; - Amount : Natural) return Long_Unsigned; - - function Rotate_Left - (Value : Long_Unsigned; - Amount : Natural) return Long_Unsigned; - - function Rotate_Right - (Value : Long_Unsigned; - Amount : Natural) return Long_Unsigned; - - function Shift_Left - (Value : Long_Long_Unsigned; - Amount : Natural) return Long_Long_Unsigned; - - function Shift_Right - (Value : Long_Long_Unsigned; - Amount : Natural) return Long_Long_Unsigned; - - function Shift_Right_Arithmetic - (Value : Long_Long_Unsigned; - Amount : Natural) return Long_Long_Unsigned; - - function Rotate_Left - (Value : Long_Long_Unsigned; - Amount : Natural) return Long_Long_Unsigned; - - function Rotate_Right - (Value : Long_Long_Unsigned; - Amount : Natural) return Long_Long_Unsigned; - - pragma Import (Intrinsic, Shift_Left); - pragma Import (Intrinsic, Shift_Right); - pragma Import (Intrinsic, Shift_Right_Arithmetic); - pragma Import (Intrinsic, Rotate_Left); - pragma Import (Intrinsic, Rotate_Right); - - -- The following definitions are obsolescent. They were needed by the - -- previous version of the compiler and runtime, but are not needed - -- by the current version. We retain them to help with bootstrap path - -- problems. Also they seem harmless, and if any user programs have - -- been using these types, why discombobulate them? - - subtype Packed_Bytes is Packed_Bytes4; - subtype Packed_Bytes_Unaligned is Packed_Bytes1; - -end System.Unsigned_Types; diff --git a/gcc/ada/s-utf_32.adb b/gcc/ada/s-utf_32.adb deleted file mode 100644 index cb41b2f..0000000 --- a/gcc/ada/s-utf_32.adb +++ /dev/null @@ -1,6356 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . U T F _ 3 2 -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -pragma Style_Checks (Off); --- Allow long lines in this unit. Note this could be more specific, but we --- keep this simple form because of bootstrap constraints ??? - --- pragma Warnings (Off, "non-static constant in preelaborated unit"); --- We need this to be pure, and the three constants in question are not a --- real problem, they are completely known at compile time. This pragma --- is commented out for now, because we still want to be able to bootstrap --- with old versions of the compiler that did not support this form. We --- have added additional pragma Warnings (Off/On) for now ??? - -package body System.UTF_32 is - - ---------------------- - -- Character Tables -- - ---------------------- - - -- Note these tables are derived from those given in AI-285. For details - -- see //www.ada-auth.org/cgi-bin/cvsweb.cgi/AIs/AI-00285.TXT?rev=1.22. - - type UTF_32_Range is record - Lo : UTF_32; - Hi : UTF_32; - end record; - - type UTF_32_Ranges is array (Positive range <>) of UTF_32_Range; - - -- The following array includes ranges for all codes with defined unicode - -- categories (a group of characters is in the same range if and only if - -- they share the same category, indicated in the comment). - - -- Note that we do not try to take care of FFFE/FFFF cases in this table - - Unicode_Ranges : constant UTF_32_Ranges := ( - (16#00000#, 16#0001F#), -- (Cc) .. - (16#00020#, 16#00020#), -- (Zs) SPACE .. SPACE - (16#00021#, 16#00023#), -- (Po) EXCLAMATION MARK .. NUMBER SIGN - (16#00024#, 16#00024#), -- (Sc) DOLLAR SIGN .. DOLLAR SIGN - (16#00025#, 16#00027#), -- (Po) PERCENT SIGN .. APOSTROPHE - (16#00028#, 16#00028#), -- (Ps) LEFT PARENTHESIS .. LEFT PARENTHESIS - (16#00029#, 16#00029#), -- (Pe) RIGHT PARENTHESIS .. RIGHT PARENTHESIS - (16#0002A#, 16#0002A#), -- (Po) ASTERISK .. ASTERISK - (16#0002B#, 16#0002B#), -- (Sm) PLUS SIGN .. PLUS SIGN - (16#0002C#, 16#0002C#), -- (Po) COMMA .. COMMA - (16#0002D#, 16#0002D#), -- (Pd) HYPHEN-MINUS .. HYPHEN-MINUS - (16#0002E#, 16#0002F#), -- (Po) FULL STOP .. SOLIDUS - (16#00030#, 16#00039#), -- (Nd) DIGIT ZERO .. DIGIT NINE - (16#0003A#, 16#0003B#), -- (Po) COLON .. SEMICOLON - (16#0003C#, 16#0003E#), -- (Sm) LESS-THAN SIGN .. GREATER-THAN SIGN - (16#0003F#, 16#00040#), -- (Po) QUESTION MARK .. COMMERCIAL AT - (16#00041#, 16#0005A#), -- (Lu) LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z - (16#0005B#, 16#0005B#), -- (Ps) LEFT SQUARE BRACKET .. LEFT SQUARE BRACKET - (16#0005C#, 16#0005C#), -- (Po) REVERSE SOLIDUS .. REVERSE SOLIDUS - (16#0005D#, 16#0005D#), -- (Pe) RIGHT SQUARE BRACKET .. RIGHT SQUARE BRACKET - (16#0005E#, 16#0005E#), -- (Sk) CIRCUMFLEX ACCENT .. CIRCUMFLEX ACCENT - (16#0005F#, 16#0005F#), -- (Pc) LOW LINE .. LOW LINE - (16#00060#, 16#00060#), -- (Sk) GRAVE ACCENT .. GRAVE ACCENT - (16#00061#, 16#0007A#), -- (Ll) LATIN SMALL LETTER A .. LATIN SMALL LETTER Z - (16#0007B#, 16#0007B#), -- (Ps) LEFT CURLY BRACKET .. LEFT CURLY BRACKET - (16#0007C#, 16#0007C#), -- (Sm) VERTICAL LINE .. VERTICAL LINE - (16#0007D#, 16#0007D#), -- (Pe) RIGHT CURLY BRACKET .. RIGHT CURLY BRACKET - (16#0007E#, 16#0007E#), -- (Sm) TILDE .. TILDE - (16#0007F#, 16#0009F#), -- (Cc) .. - (16#000A0#, 16#000A0#), -- (Zs) NO-BREAK SPACE .. NO-BREAK SPACE - (16#000A1#, 16#000A1#), -- (Po) INVERTED EXCLAMATION MARK .. INVERTED EXCLAMATION MARK - (16#000A2#, 16#000A5#), -- (Sc) CENT SIGN .. YEN SIGN - (16#000A6#, 16#000A7#), -- (So) BROKEN BAR .. SECTION SIGN - (16#000A8#, 16#000A8#), -- (Sk) DIAERESIS .. DIAERESIS - (16#000A9#, 16#000A9#), -- (So) COPYRIGHT SIGN .. COPYRIGHT SIGN - (16#000AA#, 16#000AA#), -- (Ll) FEMININE ORDINAL INDICATOR .. FEMININE ORDINAL INDICATOR - (16#000AB#, 16#000AB#), -- (Pi) LEFT-POINTING DOUBLE ANGLE QUOTATION MARK .. LEFT-POINTING DOUBLE ANGLE QUOTATION MARK - (16#000AC#, 16#000AC#), -- (Sm) NOT SIGN .. NOT SIGN - (16#000AD#, 16#000AD#), -- (Cf) SOFT HYPHEN .. SOFT HYPHEN - (16#000AE#, 16#000AE#), -- (So) REGISTERED SIGN .. REGISTERED SIGN - (16#000AF#, 16#000AF#), -- (Sk) MACRON .. MACRON - (16#000B0#, 16#000B0#), -- (So) DEGREE SIGN .. DEGREE SIGN - (16#000B1#, 16#000B1#), -- (Sm) PLUS-MINUS SIGN .. PLUS-MINUS SIGN - (16#000B2#, 16#000B3#), -- (No) SUPERSCRIPT TWO .. SUPERSCRIPT THREE - (16#000B4#, 16#000B4#), -- (Sk) ACUTE ACCENT .. ACUTE ACCENT - (16#000B5#, 16#000B5#), -- (Ll) MICRO SIGN .. MICRO SIGN - (16#000B6#, 16#000B6#), -- (So) PILCROW SIGN .. PILCROW SIGN - (16#000B7#, 16#000B7#), -- (Po) MIDDLE DOT .. MIDDLE DOT - (16#000B8#, 16#000B8#), -- (Sk) CEDILLA .. CEDILLA - (16#000B9#, 16#000B9#), -- (No) SUPERSCRIPT ONE .. SUPERSCRIPT ONE - (16#000BA#, 16#000BA#), -- (Ll) MASCULINE ORDINAL INDICATOR .. MASCULINE ORDINAL INDICATOR - (16#000BB#, 16#000BB#), -- (Pf) RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK .. RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK - (16#000BC#, 16#000BE#), -- (No) VULGAR FRACTION ONE QUARTER .. VULGAR FRACTION THREE QUARTERS - (16#000BF#, 16#000BF#), -- (Po) INVERTED QUESTION MARK .. INVERTED QUESTION MARK - (16#000C0#, 16#000D6#), -- (Lu) LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS - (16#000D7#, 16#000D7#), -- (Sm) MULTIPLICATION SIGN .. MULTIPLICATION SIGN - (16#000D8#, 16#000DE#), -- (Lu) LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN - (16#000DF#, 16#000F6#), -- (Ll) LATIN SMALL LETTER SHARP S .. LATIN SMALL LETTER O WITH DIAERESIS - (16#000F7#, 16#000F7#), -- (Sm) DIVISION SIGN .. DIVISION SIGN - (16#000F8#, 16#000FF#), -- (Ll) LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER Y WITH DIAERESIS - (16#00100#, 16#00100#), -- (Lu) LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON - (16#00101#, 16#00101#), -- (Ll) LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON - (16#00102#, 16#00102#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE - (16#00103#, 16#00103#), -- (Ll) LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE - (16#00104#, 16#00104#), -- (Lu) LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK - (16#00105#, 16#00105#), -- (Ll) LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK - (16#00106#, 16#00106#), -- (Lu) LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE - (16#00107#, 16#00107#), -- (Ll) LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE - (16#00108#, 16#00108#), -- (Lu) LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX - (16#00109#, 16#00109#), -- (Ll) LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX - (16#0010A#, 16#0010A#), -- (Lu) LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE - (16#0010B#, 16#0010B#), -- (Ll) LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE - (16#0010C#, 16#0010C#), -- (Lu) LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON - (16#0010D#, 16#0010D#), -- (Ll) LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON - (16#0010E#, 16#0010E#), -- (Lu) LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON - (16#0010F#, 16#0010F#), -- (Ll) LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON - (16#00110#, 16#00110#), -- (Lu) LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE - (16#00111#, 16#00111#), -- (Ll) LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE - (16#00112#, 16#00112#), -- (Lu) LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON - (16#00113#, 16#00113#), -- (Ll) LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON - (16#00114#, 16#00114#), -- (Lu) LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE - (16#00115#, 16#00115#), -- (Ll) LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE - (16#00116#, 16#00116#), -- (Lu) LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE - (16#00117#, 16#00117#), -- (Ll) LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE - (16#00118#, 16#00118#), -- (Lu) LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK - (16#00119#, 16#00119#), -- (Ll) LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK - (16#0011A#, 16#0011A#), -- (Lu) LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON - (16#0011B#, 16#0011B#), -- (Ll) LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON - (16#0011C#, 16#0011C#), -- (Lu) LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX - (16#0011D#, 16#0011D#), -- (Ll) LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX - (16#0011E#, 16#0011E#), -- (Lu) LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE - (16#0011F#, 16#0011F#), -- (Ll) LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE - (16#00120#, 16#00120#), -- (Lu) LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE - (16#00121#, 16#00121#), -- (Ll) LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE - (16#00122#, 16#00122#), -- (Lu) LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA - (16#00123#, 16#00123#), -- (Ll) LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA - (16#00124#, 16#00124#), -- (Lu) LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX - (16#00125#, 16#00125#), -- (Ll) LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX - (16#00126#, 16#00126#), -- (Lu) LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE - (16#00127#, 16#00127#), -- (Ll) LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE - (16#00128#, 16#00128#), -- (Lu) LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE - (16#00129#, 16#00129#), -- (Ll) LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE - (16#0012A#, 16#0012A#), -- (Lu) LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON - (16#0012B#, 16#0012B#), -- (Ll) LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON - (16#0012C#, 16#0012C#), -- (Lu) LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE - (16#0012D#, 16#0012D#), -- (Ll) LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE - (16#0012E#, 16#0012E#), -- (Lu) LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK - (16#0012F#, 16#0012F#), -- (Ll) LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK - (16#00130#, 16#00130#), -- (Lu) LATIN CAPITAL LETTER I WITH DOT ABOVE .. LATIN CAPITAL LETTER I WITH DOT ABOVE - (16#00131#, 16#00131#), -- (Ll) LATIN SMALL LETTER DOTLESS I .. LATIN SMALL LETTER DOTLESS I - (16#00132#, 16#00132#), -- (Lu) LATIN CAPITAL LIGATURE IJ .. LATIN CAPITAL LIGATURE IJ - (16#00133#, 16#00133#), -- (Ll) LATIN SMALL LIGATURE IJ .. LATIN SMALL LIGATURE IJ - (16#00134#, 16#00134#), -- (Lu) LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX - (16#00135#, 16#00135#), -- (Ll) LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX - (16#00136#, 16#00136#), -- (Lu) LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA - (16#00137#, 16#00138#), -- (Ll) LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER KRA - (16#00139#, 16#00139#), -- (Lu) LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE - (16#0013A#, 16#0013A#), -- (Ll) LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE - (16#0013B#, 16#0013B#), -- (Lu) LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA - (16#0013C#, 16#0013C#), -- (Ll) LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA - (16#0013D#, 16#0013D#), -- (Lu) LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON - (16#0013E#, 16#0013E#), -- (Ll) LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON - (16#0013F#, 16#0013F#), -- (Lu) LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT - (16#00140#, 16#00140#), -- (Ll) LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT - (16#00141#, 16#00141#), -- (Lu) LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE - (16#00142#, 16#00142#), -- (Ll) LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE - (16#00143#, 16#00143#), -- (Lu) LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE - (16#00144#, 16#00144#), -- (Ll) LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE - (16#00145#, 16#00145#), -- (Lu) LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA - (16#00146#, 16#00146#), -- (Ll) LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA - (16#00147#, 16#00147#), -- (Lu) LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON - (16#00148#, 16#00149#), -- (Ll) LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N PRECEDED BY APOSTROPHE - (16#0014A#, 16#0014A#), -- (Lu) LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG - (16#0014B#, 16#0014B#), -- (Ll) LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG - (16#0014C#, 16#0014C#), -- (Lu) LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON - (16#0014D#, 16#0014D#), -- (Ll) LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON - (16#0014E#, 16#0014E#), -- (Lu) LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE - (16#0014F#, 16#0014F#), -- (Ll) LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE - (16#00150#, 16#00150#), -- (Lu) LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE - (16#00151#, 16#00151#), -- (Ll) LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE - (16#00152#, 16#00152#), -- (Lu) LATIN CAPITAL LIGATURE OE .. LATIN CAPITAL LIGATURE OE - (16#00153#, 16#00153#), -- (Ll) LATIN SMALL LIGATURE OE .. LATIN SMALL LIGATURE OE - (16#00154#, 16#00154#), -- (Lu) LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE - (16#00155#, 16#00155#), -- (Ll) LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE - (16#00156#, 16#00156#), -- (Lu) LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA - (16#00157#, 16#00157#), -- (Ll) LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA - (16#00158#, 16#00158#), -- (Lu) LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON - (16#00159#, 16#00159#), -- (Ll) LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON - (16#0015A#, 16#0015A#), -- (Lu) LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE - (16#0015B#, 16#0015B#), -- (Ll) LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE - (16#0015C#, 16#0015C#), -- (Lu) LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX - (16#0015D#, 16#0015D#), -- (Ll) LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX - (16#0015E#, 16#0015E#), -- (Lu) LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA - (16#0015F#, 16#0015F#), -- (Ll) LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA - (16#00160#, 16#00160#), -- (Lu) LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON - (16#00161#, 16#00161#), -- (Ll) LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON - (16#00162#, 16#00162#), -- (Lu) LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA - (16#00163#, 16#00163#), -- (Ll) LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA - (16#00164#, 16#00164#), -- (Lu) LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON - (16#00165#, 16#00165#), -- (Ll) LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON - (16#00166#, 16#00166#), -- (Lu) LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE - (16#00167#, 16#00167#), -- (Ll) LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE - (16#00168#, 16#00168#), -- (Lu) LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE - (16#00169#, 16#00169#), -- (Ll) LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE - (16#0016A#, 16#0016A#), -- (Lu) LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON - (16#0016B#, 16#0016B#), -- (Ll) LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON - (16#0016C#, 16#0016C#), -- (Lu) LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE - (16#0016D#, 16#0016D#), -- (Ll) LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE - (16#0016E#, 16#0016E#), -- (Lu) LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE - (16#0016F#, 16#0016F#), -- (Ll) LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE - (16#00170#, 16#00170#), -- (Lu) LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE - (16#00171#, 16#00171#), -- (Ll) LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE - (16#00172#, 16#00172#), -- (Lu) LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK - (16#00173#, 16#00173#), -- (Ll) LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK - (16#00174#, 16#00174#), -- (Lu) LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX - (16#00175#, 16#00175#), -- (Ll) LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX - (16#00176#, 16#00176#), -- (Lu) LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX - (16#00177#, 16#00177#), -- (Ll) LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX - (16#00178#, 16#00179#), -- (Lu) LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Z WITH ACUTE - (16#0017A#, 16#0017A#), -- (Ll) LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE - (16#0017B#, 16#0017B#), -- (Lu) LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE - (16#0017C#, 16#0017C#), -- (Ll) LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE - (16#0017D#, 16#0017D#), -- (Lu) LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON - (16#0017E#, 16#00180#), -- (Ll) LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER B WITH STROKE - (16#00181#, 16#00182#), -- (Lu) LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH TOPBAR - (16#00183#, 16#00183#), -- (Ll) LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR - (16#00184#, 16#00184#), -- (Lu) LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX - (16#00185#, 16#00185#), -- (Ll) LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX - (16#00186#, 16#00187#), -- (Lu) LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER C WITH HOOK - (16#00188#, 16#00188#), -- (Ll) LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK - (16#00189#, 16#0018B#), -- (Lu) LATIN CAPITAL LETTER AFRICAN D .. LATIN CAPITAL LETTER D WITH TOPBAR - (16#0018C#, 16#0018D#), -- (Ll) LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER TURNED DELTA - (16#0018E#, 16#00191#), -- (Lu) LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER F WITH HOOK - (16#00192#, 16#00192#), -- (Ll) LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK - (16#00193#, 16#00194#), -- (Lu) LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER GAMMA - (16#00195#, 16#00195#), -- (Ll) LATIN SMALL LETTER HV .. LATIN SMALL LETTER HV - (16#00196#, 16#00198#), -- (Lu) LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER K WITH HOOK - (16#00199#, 16#0019B#), -- (Ll) LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER LAMBDA WITH STROKE - (16#0019C#, 16#0019D#), -- (Lu) LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER N WITH LEFT HOOK - (16#0019E#, 16#0019E#), -- (Ll) LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG - (16#0019F#, 16#001A0#), -- (Lu) LATIN CAPITAL LETTER O WITH MIDDLE TILDE .. LATIN CAPITAL LETTER O WITH HORN - (16#001A1#, 16#001A1#), -- (Ll) LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN - (16#001A2#, 16#001A2#), -- (Lu) LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI - (16#001A3#, 16#001A3#), -- (Ll) LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI - (16#001A4#, 16#001A4#), -- (Lu) LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK - (16#001A5#, 16#001A5#), -- (Ll) LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK - (16#001A6#, 16#001A7#), -- (Lu) LATIN LETTER YR .. LATIN CAPITAL LETTER TONE TWO - (16#001A8#, 16#001A8#), -- (Ll) LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO - (16#001A9#, 16#001A9#), -- (Lu) LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH - (16#001AA#, 16#001AB#), -- (Ll) LATIN LETTER REVERSED ESH LOOP .. LATIN SMALL LETTER T WITH PALATAL HOOK - (16#001AC#, 16#001AC#), -- (Lu) LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK - (16#001AD#, 16#001AD#), -- (Ll) LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK - (16#001AE#, 16#001AF#), -- (Lu) LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER U WITH HORN - (16#001B0#, 16#001B0#), -- (Ll) LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN - (16#001B1#, 16#001B3#), -- (Lu) LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER Y WITH HOOK - (16#001B4#, 16#001B4#), -- (Ll) LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK - (16#001B5#, 16#001B5#), -- (Lu) LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE - (16#001B6#, 16#001B6#), -- (Ll) LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE - (16#001B7#, 16#001B8#), -- (Lu) LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH REVERSED - (16#001B9#, 16#001BA#), -- (Ll) LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH WITH TAIL - (16#001BB#, 16#001BB#), -- (Lo) LATIN LETTER TWO WITH STROKE .. LATIN LETTER TWO WITH STROKE - (16#001BC#, 16#001BC#), -- (Lu) LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE - (16#001BD#, 16#001BF#), -- (Ll) LATIN SMALL LETTER TONE FIVE .. LATIN LETTER WYNN - (16#001C0#, 16#001C3#), -- (Lo) LATIN LETTER DENTAL CLICK .. LATIN LETTER RETROFLEX CLICK - (16#001C4#, 16#001C4#), -- (Lu) LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON - (16#001C5#, 16#001C5#), -- (Lt) LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON - (16#001C6#, 16#001C6#), -- (Ll) LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON - (16#001C7#, 16#001C7#), -- (Lu) LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ - (16#001C8#, 16#001C8#), -- (Lt) LATIN CAPITAL LETTER L WITH SMALL LETTER J .. LATIN CAPITAL LETTER L WITH SMALL LETTER J - (16#001C9#, 16#001C9#), -- (Ll) LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ - (16#001CA#, 16#001CA#), -- (Lu) LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ - (16#001CB#, 16#001CB#), -- (Lt) LATIN CAPITAL LETTER N WITH SMALL LETTER J .. LATIN CAPITAL LETTER N WITH SMALL LETTER J - (16#001CC#, 16#001CC#), -- (Ll) LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ - (16#001CD#, 16#001CD#), -- (Lu) LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON - (16#001CE#, 16#001CE#), -- (Ll) LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON - (16#001CF#, 16#001CF#), -- (Lu) LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON - (16#001D0#, 16#001D0#), -- (Ll) LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON - (16#001D1#, 16#001D1#), -- (Lu) LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON - (16#001D2#, 16#001D2#), -- (Ll) LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON - (16#001D3#, 16#001D3#), -- (Lu) LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON - (16#001D4#, 16#001D4#), -- (Ll) LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON - (16#001D5#, 16#001D5#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON - (16#001D6#, 16#001D6#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON - (16#001D7#, 16#001D7#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE - (16#001D8#, 16#001D8#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE - (16#001D9#, 16#001D9#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON - (16#001DA#, 16#001DA#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON - (16#001DB#, 16#001DB#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE - (16#001DC#, 16#001DD#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER TURNED E - (16#001DE#, 16#001DE#), -- (Lu) LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON - (16#001DF#, 16#001DF#), -- (Ll) LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON - (16#001E0#, 16#001E0#), -- (Lu) LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON - (16#001E1#, 16#001E1#), -- (Ll) LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON - (16#001E2#, 16#001E2#), -- (Lu) LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON - (16#001E3#, 16#001E3#), -- (Ll) LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON - (16#001E4#, 16#001E4#), -- (Lu) LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE - (16#001E5#, 16#001E5#), -- (Ll) LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE - (16#001E6#, 16#001E6#), -- (Lu) LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON - (16#001E7#, 16#001E7#), -- (Ll) LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON - (16#001E8#, 16#001E8#), -- (Lu) LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON - (16#001E9#, 16#001E9#), -- (Ll) LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON - (16#001EA#, 16#001EA#), -- (Lu) LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK - (16#001EB#, 16#001EB#), -- (Ll) LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK - (16#001EC#, 16#001EC#), -- (Lu) LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON - (16#001ED#, 16#001ED#), -- (Ll) LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON - (16#001EE#, 16#001EE#), -- (Lu) LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON - (16#001EF#, 16#001F0#), -- (Ll) LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER J WITH CARON - (16#001F1#, 16#001F1#), -- (Lu) LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ - (16#001F2#, 16#001F2#), -- (Lt) LATIN CAPITAL LETTER D WITH SMALL LETTER Z .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z - (16#001F3#, 16#001F3#), -- (Ll) LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ - (16#001F4#, 16#001F4#), -- (Lu) LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE - (16#001F5#, 16#001F5#), -- (Ll) LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE - (16#001F6#, 16#001F8#), -- (Lu) LATIN CAPITAL LETTER HWAIR .. LATIN CAPITAL LETTER N WITH GRAVE - (16#001F9#, 16#001F9#), -- (Ll) LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE - (16#001FA#, 16#001FA#), -- (Lu) LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE - (16#001FB#, 16#001FB#), -- (Ll) LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE - (16#001FC#, 16#001FC#), -- (Lu) LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE - (16#001FD#, 16#001FD#), -- (Ll) LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE - (16#001FE#, 16#001FE#), -- (Lu) LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE - (16#001FF#, 16#001FF#), -- (Ll) LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE - (16#00200#, 16#00200#), -- (Lu) LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE - (16#00201#, 16#00201#), -- (Ll) LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE - (16#00202#, 16#00202#), -- (Lu) LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE - (16#00203#, 16#00203#), -- (Ll) LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE - (16#00204#, 16#00204#), -- (Lu) LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE - (16#00205#, 16#00205#), -- (Ll) LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE - (16#00206#, 16#00206#), -- (Lu) LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE - (16#00207#, 16#00207#), -- (Ll) LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE - (16#00208#, 16#00208#), -- (Lu) LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE - (16#00209#, 16#00209#), -- (Ll) LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE - (16#0020A#, 16#0020A#), -- (Lu) LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE - (16#0020B#, 16#0020B#), -- (Ll) LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE - (16#0020C#, 16#0020C#), -- (Lu) LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE - (16#0020D#, 16#0020D#), -- (Ll) LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE - (16#0020E#, 16#0020E#), -- (Lu) LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE - (16#0020F#, 16#0020F#), -- (Ll) LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE - (16#00210#, 16#00210#), -- (Lu) LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE - (16#00211#, 16#00211#), -- (Ll) LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE - (16#00212#, 16#00212#), -- (Lu) LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE - (16#00213#, 16#00213#), -- (Ll) LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE - (16#00214#, 16#00214#), -- (Lu) LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE - (16#00215#, 16#00215#), -- (Ll) LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE - (16#00216#, 16#00216#), -- (Lu) LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE - (16#00217#, 16#00217#), -- (Ll) LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE - (16#00218#, 16#00218#), -- (Lu) LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW - (16#00219#, 16#00219#), -- (Ll) LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW - (16#0021A#, 16#0021A#), -- (Lu) LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW - (16#0021B#, 16#0021B#), -- (Ll) LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW - (16#0021C#, 16#0021C#), -- (Lu) LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH - (16#0021D#, 16#0021D#), -- (Ll) LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH - (16#0021E#, 16#0021E#), -- (Lu) LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON - (16#0021F#, 16#0021F#), -- (Ll) LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON - (16#00220#, 16#00220#), -- (Lu) LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG - (16#00221#, 16#00221#), -- (Ll) LATIN SMALL LETTER D WITH CURL .. LATIN SMALL LETTER D WITH CURL - (16#00222#, 16#00222#), -- (Lu) LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU - (16#00223#, 16#00223#), -- (Ll) LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU - (16#00224#, 16#00224#), -- (Lu) LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK - (16#00225#, 16#00225#), -- (Ll) LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK - (16#00226#, 16#00226#), -- (Lu) LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE - (16#00227#, 16#00227#), -- (Ll) LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE - (16#00228#, 16#00228#), -- (Lu) LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA - (16#00229#, 16#00229#), -- (Ll) LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA - (16#0022A#, 16#0022A#), -- (Lu) LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON - (16#0022B#, 16#0022B#), -- (Ll) LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON - (16#0022C#, 16#0022C#), -- (Lu) LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON - (16#0022D#, 16#0022D#), -- (Ll) LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON - (16#0022E#, 16#0022E#), -- (Lu) LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE - (16#0022F#, 16#0022F#), -- (Ll) LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE - (16#00230#, 16#00230#), -- (Lu) LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON - (16#00231#, 16#00231#), -- (Ll) LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON - (16#00232#, 16#00232#), -- (Lu) LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON - (16#00233#, 16#00236#), -- (Ll) LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER T WITH CURL - (16#00250#, 16#002AF#), -- (Ll) LATIN SMALL LETTER TURNED A .. LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL - (16#002B0#, 16#002C1#), -- (Lm) MODIFIER LETTER SMALL H .. MODIFIER LETTER REVERSED GLOTTAL STOP - (16#002C2#, 16#002C5#), -- (Sk) MODIFIER LETTER LEFT ARROWHEAD .. MODIFIER LETTER DOWN ARROWHEAD - (16#002C6#, 16#002D1#), -- (Lm) MODIFIER LETTER CIRCUMFLEX ACCENT .. MODIFIER LETTER HALF TRIANGULAR COLON - (16#002D2#, 16#002DF#), -- (Sk) MODIFIER LETTER CENTRED RIGHT HALF RING .. MODIFIER LETTER CROSS ACCENT - (16#002E0#, 16#002E4#), -- (Lm) MODIFIER LETTER SMALL GAMMA .. MODIFIER LETTER SMALL REVERSED GLOTTAL STOP - (16#002E5#, 16#002ED#), -- (Sk) MODIFIER LETTER EXTRA-HIGH TONE BAR .. MODIFIER LETTER UNASPIRATED - (16#002EE#, 16#002EE#), -- (Lm) MODIFIER LETTER DOUBLE APOSTROPHE .. MODIFIER LETTER DOUBLE APOSTROPHE - (16#002EF#, 16#002FF#), -- (Sk) MODIFIER LETTER LOW DOWN ARROWHEAD .. MODIFIER LETTER LOW LEFT ARROW - (16#00300#, 16#00357#), -- (Mn) COMBINING GRAVE ACCENT .. COMBINING RIGHT HALF RING ABOVE - (16#0035D#, 16#0036F#), -- (Mn) COMBINING DOUBLE BREVE .. COMBINING LATIN SMALL LETTER X - (16#00374#, 16#00375#), -- (Sk) GREEK NUMERAL SIGN .. GREEK LOWER NUMERAL SIGN - (16#0037A#, 16#0037A#), -- (Lm) GREEK YPOGEGRAMMENI .. GREEK YPOGEGRAMMENI - (16#0037E#, 16#0037E#), -- (Po) GREEK QUESTION MARK .. GREEK QUESTION MARK - (16#00384#, 16#00385#), -- (Sk) GREEK TONOS .. GREEK DIALYTIKA TONOS - (16#00386#, 16#00386#), -- (Lu) GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS - (16#00387#, 16#00387#), -- (Po) GREEK ANO TELEIA .. GREEK ANO TELEIA - (16#00388#, 16#0038A#), -- (Lu) GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS - (16#0038C#, 16#0038C#), -- (Lu) GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS - (16#0038E#, 16#0038F#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS - (16#00390#, 16#00390#), -- (Ll) GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS - (16#00391#, 16#003A1#), -- (Lu) GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO - (16#003A3#, 16#003AB#), -- (Lu) GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA - (16#003AC#, 16#003CE#), -- (Ll) GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS - (16#003D0#, 16#003D1#), -- (Ll) GREEK BETA SYMBOL .. GREEK THETA SYMBOL - (16#003D2#, 16#003D4#), -- (Lu) GREEK UPSILON WITH HOOK SYMBOL .. GREEK UPSILON WITH DIAERESIS AND HOOK SYMBOL - (16#003D5#, 16#003D7#), -- (Ll) GREEK PHI SYMBOL .. GREEK KAI SYMBOL - (16#003D8#, 16#003D8#), -- (Lu) GREEK LETTER ARCHAIC KOPPA .. GREEK LETTER ARCHAIC KOPPA - (16#003D9#, 16#003D9#), -- (Ll) GREEK SMALL LETTER ARCHAIC KOPPA .. GREEK SMALL LETTER ARCHAIC KOPPA - (16#003DA#, 16#003DA#), -- (Lu) GREEK LETTER STIGMA .. GREEK LETTER STIGMA - (16#003DB#, 16#003DB#), -- (Ll) GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA - (16#003DC#, 16#003DC#), -- (Lu) GREEK LETTER DIGAMMA .. GREEK LETTER DIGAMMA - (16#003DD#, 16#003DD#), -- (Ll) GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA - (16#003DE#, 16#003DE#), -- (Lu) GREEK LETTER KOPPA .. GREEK LETTER KOPPA - (16#003DF#, 16#003DF#), -- (Ll) GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA - (16#003E0#, 16#003E0#), -- (Lu) GREEK LETTER SAMPI .. GREEK LETTER SAMPI - (16#003E1#, 16#003E1#), -- (Ll) GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI - (16#003E2#, 16#003E2#), -- (Lu) COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI - (16#003E3#, 16#003E3#), -- (Ll) COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI - (16#003E4#, 16#003E4#), -- (Lu) COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI - (16#003E5#, 16#003E5#), -- (Ll) COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI - (16#003E6#, 16#003E6#), -- (Lu) COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI - (16#003E7#, 16#003E7#), -- (Ll) COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI - (16#003E8#, 16#003E8#), -- (Lu) COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI - (16#003E9#, 16#003E9#), -- (Ll) COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI - (16#003EA#, 16#003EA#), -- (Lu) COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA - (16#003EB#, 16#003EB#), -- (Ll) COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA - (16#003EC#, 16#003EC#), -- (Lu) COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA - (16#003ED#, 16#003ED#), -- (Ll) COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA - (16#003EE#, 16#003EE#), -- (Lu) COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI - (16#003EF#, 16#003F3#), -- (Ll) COPTIC SMALL LETTER DEI .. GREEK LETTER YOT - (16#003F4#, 16#003F4#), -- (Lu) GREEK CAPITAL THETA SYMBOL .. GREEK CAPITAL THETA SYMBOL - (16#003F5#, 16#003F5#), -- (Ll) GREEK LUNATE EPSILON SYMBOL .. GREEK LUNATE EPSILON SYMBOL - (16#003F6#, 16#003F6#), -- (Sm) GREEK REVERSED LUNATE EPSILON SYMBOL .. GREEK REVERSED LUNATE EPSILON SYMBOL - (16#003F7#, 16#003F7#), -- (Lu) GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO - (16#003F8#, 16#003F8#), -- (Ll) GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO - (16#003F9#, 16#003FA#), -- (Lu) GREEK CAPITAL LUNATE SIGMA SYMBOL .. GREEK CAPITAL LETTER SAN - (16#003FB#, 16#003FB#), -- (Ll) GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN - (16#00400#, 16#0042F#), -- (Lu) CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER YA - (16#00430#, 16#0045F#), -- (Ll) CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER DZHE - (16#00460#, 16#00460#), -- (Lu) CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA - (16#00461#, 16#00461#), -- (Ll) CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA - (16#00462#, 16#00462#), -- (Lu) CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT - (16#00463#, 16#00463#), -- (Ll) CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT - (16#00464#, 16#00464#), -- (Lu) CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E - (16#00465#, 16#00465#), -- (Ll) CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E - (16#00466#, 16#00466#), -- (Lu) CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS - (16#00467#, 16#00467#), -- (Ll) CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS - (16#00468#, 16#00468#), -- (Lu) CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS - (16#00469#, 16#00469#), -- (Ll) CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS - (16#0046A#, 16#0046A#), -- (Lu) CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS - (16#0046B#, 16#0046B#), -- (Ll) CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS - (16#0046C#, 16#0046C#), -- (Lu) CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS - (16#0046D#, 16#0046D#), -- (Ll) CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS - (16#0046E#, 16#0046E#), -- (Lu) CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI - (16#0046F#, 16#0046F#), -- (Ll) CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI - (16#00470#, 16#00470#), -- (Lu) CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI - (16#00471#, 16#00471#), -- (Ll) CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI - (16#00472#, 16#00472#), -- (Lu) CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA - (16#00473#, 16#00473#), -- (Ll) CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA - (16#00474#, 16#00474#), -- (Lu) CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA - (16#00475#, 16#00475#), -- (Ll) CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA - (16#00476#, 16#00476#), -- (Lu) CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - (16#00477#, 16#00477#), -- (Ll) CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - (16#00478#, 16#00478#), -- (Lu) CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK - (16#00479#, 16#00479#), -- (Ll) CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK - (16#0047A#, 16#0047A#), -- (Lu) CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA - (16#0047B#, 16#0047B#), -- (Ll) CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA - (16#0047C#, 16#0047C#), -- (Lu) CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO - (16#0047D#, 16#0047D#), -- (Ll) CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO - (16#0047E#, 16#0047E#), -- (Lu) CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT - (16#0047F#, 16#0047F#), -- (Ll) CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT - (16#00480#, 16#00480#), -- (Lu) CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA - (16#00481#, 16#00481#), -- (Ll) CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA - (16#00482#, 16#00482#), -- (So) CYRILLIC THOUSANDS SIGN .. CYRILLIC THOUSANDS SIGN - (16#00483#, 16#00486#), -- (Mn) COMBINING CYRILLIC TITLO .. COMBINING CYRILLIC PSILI PNEUMATA - (16#00488#, 16#00489#), -- (Me) COMBINING CYRILLIC HUNDRED THOUSANDS SIGN .. COMBINING CYRILLIC MILLIONS SIGN - (16#0048A#, 16#0048A#), -- (Lu) CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL - (16#0048B#, 16#0048B#), -- (Ll) CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL - (16#0048C#, 16#0048C#), -- (Lu) CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN - (16#0048D#, 16#0048D#), -- (Ll) CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN - (16#0048E#, 16#0048E#), -- (Lu) CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK - (16#0048F#, 16#0048F#), -- (Ll) CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK - (16#00490#, 16#00490#), -- (Lu) CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN - (16#00491#, 16#00491#), -- (Ll) CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN - (16#00492#, 16#00492#), -- (Lu) CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE - (16#00493#, 16#00493#), -- (Ll) CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE - (16#00494#, 16#00494#), -- (Lu) CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK - (16#00495#, 16#00495#), -- (Ll) CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK - (16#00496#, 16#00496#), -- (Lu) CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER - (16#00497#, 16#00497#), -- (Ll) CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER - (16#00498#, 16#00498#), -- (Lu) CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER - (16#00499#, 16#00499#), -- (Ll) CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER - (16#0049A#, 16#0049A#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER - (16#0049B#, 16#0049B#), -- (Ll) CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER - (16#0049C#, 16#0049C#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE - (16#0049D#, 16#0049D#), -- (Ll) CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE - (16#0049E#, 16#0049E#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE - (16#0049F#, 16#0049F#), -- (Ll) CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE - (16#004A0#, 16#004A0#), -- (Lu) CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA - (16#004A1#, 16#004A1#), -- (Ll) CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA - (16#004A2#, 16#004A2#), -- (Lu) CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER - (16#004A3#, 16#004A3#), -- (Ll) CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER - (16#004A4#, 16#004A4#), -- (Lu) CYRILLIC CAPITAL LIGATURE EN GHE .. CYRILLIC CAPITAL LIGATURE EN GHE - (16#004A5#, 16#004A5#), -- (Ll) CYRILLIC SMALL LIGATURE EN GHE .. CYRILLIC SMALL LIGATURE EN GHE - (16#004A6#, 16#004A6#), -- (Lu) CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK - (16#004A7#, 16#004A7#), -- (Ll) CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK - (16#004A8#, 16#004A8#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA - (16#004A9#, 16#004A9#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA - (16#004AA#, 16#004AA#), -- (Lu) CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER - (16#004AB#, 16#004AB#), -- (Ll) CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER - (16#004AC#, 16#004AC#), -- (Lu) CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER - (16#004AD#, 16#004AD#), -- (Ll) CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER - (16#004AE#, 16#004AE#), -- (Lu) CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U - (16#004AF#, 16#004AF#), -- (Ll) CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U - (16#004B0#, 16#004B0#), -- (Lu) CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE - (16#004B1#, 16#004B1#), -- (Ll) CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE - (16#004B2#, 16#004B2#), -- (Lu) CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER - (16#004B3#, 16#004B3#), -- (Ll) CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER - (16#004B4#, 16#004B4#), -- (Lu) CYRILLIC CAPITAL LIGATURE TE TSE .. CYRILLIC CAPITAL LIGATURE TE TSE - (16#004B5#, 16#004B5#), -- (Ll) CYRILLIC SMALL LIGATURE TE TSE .. CYRILLIC SMALL LIGATURE TE TSE - (16#004B6#, 16#004B6#), -- (Lu) CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER - (16#004B7#, 16#004B7#), -- (Ll) CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER - (16#004B8#, 16#004B8#), -- (Lu) CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE - (16#004B9#, 16#004B9#), -- (Ll) CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE - (16#004BA#, 16#004BA#), -- (Lu) CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA - (16#004BB#, 16#004BB#), -- (Ll) CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA - (16#004BC#, 16#004BC#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE - (16#004BD#, 16#004BD#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE - (16#004BE#, 16#004BE#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER - (16#004BF#, 16#004BF#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER - (16#004C0#, 16#004C1#), -- (Lu) CYRILLIC LETTER PALOCHKA .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE - (16#004C2#, 16#004C2#), -- (Ll) CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE - (16#004C3#, 16#004C3#), -- (Lu) CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK - (16#004C4#, 16#004C4#), -- (Ll) CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK - (16#004C5#, 16#004C5#), -- (Lu) CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL - (16#004C6#, 16#004C6#), -- (Ll) CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL - (16#004C7#, 16#004C7#), -- (Lu) CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK - (16#004C8#, 16#004C8#), -- (Ll) CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK - (16#004C9#, 16#004C9#), -- (Lu) CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL - (16#004CA#, 16#004CA#), -- (Ll) CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL - (16#004CB#, 16#004CB#), -- (Lu) CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE - (16#004CC#, 16#004CC#), -- (Ll) CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE - (16#004CD#, 16#004CD#), -- (Lu) CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL - (16#004CE#, 16#004CE#), -- (Ll) CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL - (16#004D0#, 16#004D0#), -- (Lu) CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE - (16#004D1#, 16#004D1#), -- (Ll) CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE - (16#004D2#, 16#004D2#), -- (Lu) CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS - (16#004D3#, 16#004D3#), -- (Ll) CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS - (16#004D4#, 16#004D4#), -- (Lu) CYRILLIC CAPITAL LIGATURE A IE .. CYRILLIC CAPITAL LIGATURE A IE - (16#004D5#, 16#004D5#), -- (Ll) CYRILLIC SMALL LIGATURE A IE .. CYRILLIC SMALL LIGATURE A IE - (16#004D6#, 16#004D6#), -- (Lu) CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE - (16#004D7#, 16#004D7#), -- (Ll) CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE - (16#004D8#, 16#004D8#), -- (Lu) CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA - (16#004D9#, 16#004D9#), -- (Ll) CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA - (16#004DA#, 16#004DA#), -- (Lu) CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS - (16#004DB#, 16#004DB#), -- (Ll) CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS - (16#004DC#, 16#004DC#), -- (Lu) CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS - (16#004DD#, 16#004DD#), -- (Ll) CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS - (16#004DE#, 16#004DE#), -- (Lu) CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS - (16#004DF#, 16#004DF#), -- (Ll) CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS - (16#004E0#, 16#004E0#), -- (Lu) CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE - (16#004E1#, 16#004E1#), -- (Ll) CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE - (16#004E2#, 16#004E2#), -- (Lu) CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON - (16#004E3#, 16#004E3#), -- (Ll) CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON - (16#004E4#, 16#004E4#), -- (Lu) CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS - (16#004E5#, 16#004E5#), -- (Ll) CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS - (16#004E6#, 16#004E6#), -- (Lu) CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS - (16#004E7#, 16#004E7#), -- (Ll) CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS - (16#004E8#, 16#004E8#), -- (Lu) CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O - (16#004E9#, 16#004E9#), -- (Ll) CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O - (16#004EA#, 16#004EA#), -- (Lu) CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS - (16#004EB#, 16#004EB#), -- (Ll) CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS - (16#004EC#, 16#004EC#), -- (Lu) CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS - (16#004ED#, 16#004ED#), -- (Ll) CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS - (16#004EE#, 16#004EE#), -- (Lu) CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON - (16#004EF#, 16#004EF#), -- (Ll) CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON - (16#004F0#, 16#004F0#), -- (Lu) CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS - (16#004F1#, 16#004F1#), -- (Ll) CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS - (16#004F2#, 16#004F2#), -- (Lu) CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE - (16#004F3#, 16#004F3#), -- (Ll) CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE - (16#004F4#, 16#004F4#), -- (Lu) CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS - (16#004F5#, 16#004F5#), -- (Ll) CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS - (16#004F8#, 16#004F8#), -- (Lu) CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS - (16#004F9#, 16#004F9#), -- (Ll) CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS - (16#00500#, 16#00500#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE - (16#00501#, 16#00501#), -- (Ll) CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE - (16#00502#, 16#00502#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE - (16#00503#, 16#00503#), -- (Ll) CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE - (16#00504#, 16#00504#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE - (16#00505#, 16#00505#), -- (Ll) CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE - (16#00506#, 16#00506#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE - (16#00507#, 16#00507#), -- (Ll) CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE - (16#00508#, 16#00508#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE - (16#00509#, 16#00509#), -- (Ll) CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE - (16#0050A#, 16#0050A#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE - (16#0050B#, 16#0050B#), -- (Ll) CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE - (16#0050C#, 16#0050C#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE - (16#0050D#, 16#0050D#), -- (Ll) CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE - (16#0050E#, 16#0050E#), -- (Lu) CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE - (16#0050F#, 16#0050F#), -- (Ll) CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE - (16#00531#, 16#00556#), -- (Lu) ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH - (16#00559#, 16#00559#), -- (Lm) ARMENIAN MODIFIER LETTER LEFT HALF RING .. ARMENIAN MODIFIER LETTER LEFT HALF RING - (16#0055A#, 16#0055F#), -- (Po) ARMENIAN APOSTROPHE .. ARMENIAN ABBREVIATION MARK - (16#00561#, 16#00587#), -- (Ll) ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LIGATURE ECH YIWN - (16#00589#, 16#00589#), -- (Po) ARMENIAN FULL STOP .. ARMENIAN FULL STOP - (16#0058A#, 16#0058A#), -- (Pd) ARMENIAN HYPHEN .. ARMENIAN HYPHEN - (16#00591#, 16#005A1#), -- (Mn) HEBREW ACCENT ETNAHTA .. HEBREW ACCENT PAZER - (16#005A3#, 16#005B9#), -- (Mn) HEBREW ACCENT MUNAH .. HEBREW POINT HOLAM - (16#005BB#, 16#005BD#), -- (Mn) HEBREW POINT QUBUTS .. HEBREW POINT METEG - (16#005BE#, 16#005BE#), -- (Po) HEBREW PUNCTUATION MAQAF .. HEBREW PUNCTUATION MAQAF - (16#005BF#, 16#005BF#), -- (Mn) HEBREW POINT RAFE .. HEBREW POINT RAFE - (16#005C0#, 16#005C0#), -- (Po) HEBREW PUNCTUATION PASEQ .. HEBREW PUNCTUATION PASEQ - (16#005C1#, 16#005C2#), -- (Mn) HEBREW POINT SHIN DOT .. HEBREW POINT SIN DOT - (16#005C3#, 16#005C3#), -- (Po) HEBREW PUNCTUATION SOF PASUQ .. HEBREW PUNCTUATION SOF PASUQ - (16#005C4#, 16#005C4#), -- (Mn) HEBREW MARK UPPER DOT .. HEBREW MARK UPPER DOT - (16#005D0#, 16#005EA#), -- (Lo) HEBREW LETTER ALEF .. HEBREW LETTER TAV - (16#005F0#, 16#005F2#), -- (Lo) HEBREW LIGATURE YIDDISH DOUBLE VAV .. HEBREW LIGATURE YIDDISH DOUBLE YOD - (16#005F3#, 16#005F4#), -- (Po) HEBREW PUNCTUATION GERESH .. HEBREW PUNCTUATION GERSHAYIM - (16#00600#, 16#00603#), -- (Cf) ARABIC NUMBER SIGN .. ARABIC SIGN SAFHA - (16#0060C#, 16#0060D#), -- (Po) ARABIC COMMA .. ARABIC DATE SEPARATOR - (16#0060E#, 16#0060F#), -- (So) ARABIC POETIC VERSE SIGN .. ARABIC SIGN MISRA - (16#00610#, 16#00615#), -- (Mn) ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM .. ARABIC SMALL HIGH TAH - (16#0061B#, 16#0061B#), -- (Po) ARABIC SEMICOLON .. ARABIC SEMICOLON - (16#0061F#, 16#0061F#), -- (Po) ARABIC QUESTION MARK .. ARABIC QUESTION MARK - (16#00621#, 16#0063A#), -- (Lo) ARABIC LETTER HAMZA .. ARABIC LETTER GHAIN - (16#00640#, 16#00640#), -- (Lm) ARABIC TATWEEL .. ARABIC TATWEEL - (16#00641#, 16#0064A#), -- (Lo) ARABIC LETTER FEH .. ARABIC LETTER YEH - (16#0064B#, 16#00658#), -- (Mn) ARABIC FATHATAN .. ARABIC MARK NOON GHUNNA - (16#00660#, 16#00669#), -- (Nd) ARABIC-INDIC DIGIT ZERO .. ARABIC-INDIC DIGIT NINE - (16#0066A#, 16#0066D#), -- (Po) ARABIC PERCENT SIGN .. ARABIC FIVE POINTED STAR - (16#0066E#, 16#0066F#), -- (Lo) ARABIC LETTER DOTLESS BEH .. ARABIC LETTER DOTLESS QAF - (16#00670#, 16#00670#), -- (Mn) ARABIC LETTER SUPERSCRIPT ALEF .. ARABIC LETTER SUPERSCRIPT ALEF - (16#00671#, 16#006D3#), -- (Lo) ARABIC LETTER ALEF WASLA .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE - (16#006D4#, 16#006D4#), -- (Po) ARABIC FULL STOP .. ARABIC FULL STOP - (16#006D5#, 16#006D5#), -- (Lo) ARABIC LETTER AE .. ARABIC LETTER AE - (16#006D6#, 16#006DC#), -- (Mn) ARABIC SMALL HIGH LIGATURE SAD WITH LAM WITH ALEF MAKSURA .. ARABIC SMALL HIGH SEEN - (16#006DD#, 16#006DD#), -- (Cf) ARABIC END OF AYAH .. ARABIC END OF AYAH - (16#006DE#, 16#006DE#), -- (Me) ARABIC START OF RUB EL HIZB .. ARABIC START OF RUB EL HIZB - (16#006DF#, 16#006E4#), -- (Mn) ARABIC SMALL HIGH ROUNDED ZERO .. ARABIC SMALL HIGH MADDA - (16#006E5#, 16#006E6#), -- (Lm) ARABIC SMALL WAW .. ARABIC SMALL YEH - (16#006E7#, 16#006E8#), -- (Mn) ARABIC SMALL HIGH YEH .. ARABIC SMALL HIGH NOON - (16#006E9#, 16#006E9#), -- (So) ARABIC PLACE OF SAJDAH .. ARABIC PLACE OF SAJDAH - (16#006EA#, 16#006ED#), -- (Mn) ARABIC EMPTY CENTRE LOW STOP .. ARABIC SMALL LOW MEEM - (16#006EE#, 16#006EF#), -- (Lo) ARABIC LETTER DAL WITH INVERTED V .. ARABIC LETTER REH WITH INVERTED V - (16#006F0#, 16#006F9#), -- (Nd) EXTENDED ARABIC-INDIC DIGIT ZERO .. EXTENDED ARABIC-INDIC DIGIT NINE - (16#006FA#, 16#006FC#), -- (Lo) ARABIC LETTER SHEEN WITH DOT BELOW .. ARABIC LETTER GHAIN WITH DOT BELOW - (16#006FD#, 16#006FE#), -- (So) ARABIC SIGN SINDHI AMPERSAND .. ARABIC SIGN SINDHI POSTPOSITION MEN - (16#006FF#, 16#006FF#), -- (Lo) ARABIC LETTER HEH WITH INVERTED V .. ARABIC LETTER HEH WITH INVERTED V - (16#00700#, 16#0070D#), -- (Po) SYRIAC END OF PARAGRAPH .. SYRIAC HARKLEAN ASTERISCUS - (16#0070F#, 16#0070F#), -- (Cf) SYRIAC ABBREVIATION MARK .. SYRIAC ABBREVIATION MARK - (16#00710#, 16#00710#), -- (Lo) SYRIAC LETTER ALAPH .. SYRIAC LETTER ALAPH - (16#00711#, 16#00711#), -- (Mn) SYRIAC LETTER SUPERSCRIPT ALAPH .. SYRIAC LETTER SUPERSCRIPT ALAPH - (16#00712#, 16#0072F#), -- (Lo) SYRIAC LETTER BETH .. SYRIAC LETTER PERSIAN DHALATH - (16#00730#, 16#0074A#), -- (Mn) SYRIAC PTHAHA ABOVE .. SYRIAC BARREKH - (16#0074D#, 16#0074F#), -- (Lo) SYRIAC LETTER SOGDIAN ZHAIN .. SYRIAC LETTER SOGDIAN FE - (16#00780#, 16#007A5#), -- (Lo) THAANA LETTER HAA .. THAANA LETTER WAAVU - (16#007A6#, 16#007B0#), -- (Mn) THAANA ABAFILI .. THAANA SUKUN - (16#007B1#, 16#007B1#), -- (Lo) THAANA LETTER NAA .. THAANA LETTER NAA - (16#00901#, 16#00902#), -- (Mn) DEVANAGARI SIGN CANDRABINDU .. DEVANAGARI SIGN ANUSVARA - (16#00903#, 16#00903#), -- (Mc) DEVANAGARI SIGN VISARGA .. DEVANAGARI SIGN VISARGA - (16#00904#, 16#00939#), -- (Lo) DEVANAGARI LETTER SHORT A .. DEVANAGARI LETTER HA - (16#0093C#, 16#0093C#), -- (Mn) DEVANAGARI SIGN NUKTA .. DEVANAGARI SIGN NUKTA - (16#0093D#, 16#0093D#), -- (Lo) DEVANAGARI SIGN AVAGRAHA .. DEVANAGARI SIGN AVAGRAHA - (16#0093E#, 16#00940#), -- (Mc) DEVANAGARI VOWEL SIGN AA .. DEVANAGARI VOWEL SIGN II - (16#00941#, 16#00948#), -- (Mn) DEVANAGARI VOWEL SIGN U .. DEVANAGARI VOWEL SIGN AI - (16#00949#, 16#0094C#), -- (Mc) DEVANAGARI VOWEL SIGN CANDRA O .. DEVANAGARI VOWEL SIGN AU - (16#0094D#, 16#0094D#), -- (Mn) DEVANAGARI SIGN VIRAMA .. DEVANAGARI SIGN VIRAMA - (16#00950#, 16#00950#), -- (Lo) DEVANAGARI OM .. DEVANAGARI OM - (16#00951#, 16#00954#), -- (Mn) DEVANAGARI STRESS SIGN UDATTA .. DEVANAGARI ACUTE ACCENT - (16#00958#, 16#00961#), -- (Lo) DEVANAGARI LETTER QA .. DEVANAGARI LETTER VOCALIC LL - (16#00962#, 16#00963#), -- (Mn) DEVANAGARI VOWEL SIGN VOCALIC L .. DEVANAGARI VOWEL SIGN VOCALIC LL - (16#00964#, 16#00965#), -- (Po) DEVANAGARI DANDA .. DEVANAGARI DOUBLE DANDA - (16#00966#, 16#0096F#), -- (Nd) DEVANAGARI DIGIT ZERO .. DEVANAGARI DIGIT NINE - (16#00970#, 16#00970#), -- (Po) DEVANAGARI ABBREVIATION SIGN .. DEVANAGARI ABBREVIATION SIGN - (16#00981#, 16#00981#), -- (Mn) BENGALI SIGN CANDRABINDU .. BENGALI SIGN CANDRABINDU - (16#00982#, 16#00983#), -- (Mc) BENGALI SIGN ANUSVARA .. BENGALI SIGN VISARGA - (16#00985#, 16#0098C#), -- (Lo) BENGALI LETTER A .. BENGALI LETTER VOCALIC L - (16#0098F#, 16#00990#), -- (Lo) BENGALI LETTER E .. BENGALI LETTER AI - (16#00993#, 16#009A8#), -- (Lo) BENGALI LETTER O .. BENGALI LETTER NA - (16#009AA#, 16#009B0#), -- (Lo) BENGALI LETTER PA .. BENGALI LETTER RA - (16#009B2#, 16#009B2#), -- (Lo) BENGALI LETTER LA .. BENGALI LETTER LA - (16#009B6#, 16#009B9#), -- (Lo) BENGALI LETTER SHA .. BENGALI LETTER HA - (16#009BC#, 16#009BC#), -- (Mn) BENGALI SIGN NUKTA .. BENGALI SIGN NUKTA - (16#009BD#, 16#009BD#), -- (Lo) BENGALI SIGN AVAGRAHA .. BENGALI SIGN AVAGRAHA - (16#009BE#, 16#009C0#), -- (Mc) BENGALI VOWEL SIGN AA .. BENGALI VOWEL SIGN II - (16#009C1#, 16#009C4#), -- (Mn) BENGALI VOWEL SIGN U .. BENGALI VOWEL SIGN VOCALIC RR - (16#009C7#, 16#009C8#), -- (Mc) BENGALI VOWEL SIGN E .. BENGALI VOWEL SIGN AI - (16#009CB#, 16#009CC#), -- (Mc) BENGALI VOWEL SIGN O .. BENGALI VOWEL SIGN AU - (16#009CD#, 16#009CD#), -- (Mn) BENGALI SIGN VIRAMA .. BENGALI SIGN VIRAMA - (16#009D7#, 16#009D7#), -- (Mc) BENGALI AU LENGTH MARK .. BENGALI AU LENGTH MARK - (16#009DC#, 16#009DD#), -- (Lo) BENGALI LETTER RRA .. BENGALI LETTER RHA - (16#009DF#, 16#009E1#), -- (Lo) BENGALI LETTER YYA .. BENGALI LETTER VOCALIC LL - (16#009E2#, 16#009E3#), -- (Mn) BENGALI VOWEL SIGN VOCALIC L .. BENGALI VOWEL SIGN VOCALIC LL - (16#009E6#, 16#009EF#), -- (Nd) BENGALI DIGIT ZERO .. BENGALI DIGIT NINE - (16#009F0#, 16#009F1#), -- (Lo) BENGALI LETTER RA WITH MIDDLE DIAGONAL .. BENGALI LETTER RA WITH LOWER DIAGONAL - (16#009F2#, 16#009F3#), -- (Sc) BENGALI RUPEE MARK .. BENGALI RUPEE SIGN - (16#009F4#, 16#009F9#), -- (No) BENGALI CURRENCY NUMERATOR ONE .. BENGALI CURRENCY DENOMINATOR SIXTEEN - (16#009FA#, 16#009FA#), -- (So) BENGALI ISSHAR .. BENGALI ISSHAR - (16#00A01#, 16#00A02#), -- (Mn) GURMUKHI SIGN ADAK BINDI .. GURMUKHI SIGN BINDI - (16#00A03#, 16#00A03#), -- (Mc) GURMUKHI SIGN VISARGA .. GURMUKHI SIGN VISARGA - (16#00A05#, 16#00A0A#), -- (Lo) GURMUKHI LETTER A .. GURMUKHI LETTER UU - (16#00A0F#, 16#00A10#), -- (Lo) GURMUKHI LETTER EE .. GURMUKHI LETTER AI - (16#00A13#, 16#00A28#), -- (Lo) GURMUKHI LETTER OO .. GURMUKHI LETTER NA - (16#00A2A#, 16#00A30#), -- (Lo) GURMUKHI LETTER PA .. GURMUKHI LETTER RA - (16#00A32#, 16#00A33#), -- (Lo) GURMUKHI LETTER LA .. GURMUKHI LETTER LLA - (16#00A35#, 16#00A36#), -- (Lo) GURMUKHI LETTER VA .. GURMUKHI LETTER SHA - (16#00A38#, 16#00A39#), -- (Lo) GURMUKHI LETTER SA .. GURMUKHI LETTER HA - (16#00A3C#, 16#00A3C#), -- (Mn) GURMUKHI SIGN NUKTA .. GURMUKHI SIGN NUKTA - (16#00A3E#, 16#00A40#), -- (Mc) GURMUKHI VOWEL SIGN AA .. GURMUKHI VOWEL SIGN II - (16#00A41#, 16#00A42#), -- (Mn) GURMUKHI VOWEL SIGN U .. GURMUKHI VOWEL SIGN UU - (16#00A47#, 16#00A48#), -- (Mn) GURMUKHI VOWEL SIGN EE .. GURMUKHI VOWEL SIGN AI - (16#00A4B#, 16#00A4D#), -- (Mn) GURMUKHI VOWEL SIGN OO .. GURMUKHI SIGN VIRAMA - (16#00A59#, 16#00A5C#), -- (Lo) GURMUKHI LETTER KHHA .. GURMUKHI LETTER RRA - (16#00A5E#, 16#00A5E#), -- (Lo) GURMUKHI LETTER FA .. GURMUKHI LETTER FA - (16#00A66#, 16#00A6F#), -- (Nd) GURMUKHI DIGIT ZERO .. GURMUKHI DIGIT NINE - (16#00A70#, 16#00A71#), -- (Mn) GURMUKHI TIPPI .. GURMUKHI ADDAK - (16#00A72#, 16#00A74#), -- (Lo) GURMUKHI IRI .. GURMUKHI EK ONKAR - (16#00A81#, 16#00A82#), -- (Mn) GUJARATI SIGN CANDRABINDU .. GUJARATI SIGN ANUSVARA - (16#00A83#, 16#00A83#), -- (Mc) GUJARATI SIGN VISARGA .. GUJARATI SIGN VISARGA - (16#00A85#, 16#00A8D#), -- (Lo) GUJARATI LETTER A .. GUJARATI VOWEL CANDRA E - (16#00A8F#, 16#00A91#), -- (Lo) GUJARATI LETTER E .. GUJARATI VOWEL CANDRA O - (16#00A93#, 16#00AA8#), -- (Lo) GUJARATI LETTER O .. GUJARATI LETTER NA - (16#00AAA#, 16#00AB0#), -- (Lo) GUJARATI LETTER PA .. GUJARATI LETTER RA - (16#00AB2#, 16#00AB3#), -- (Lo) GUJARATI LETTER LA .. GUJARATI LETTER LLA - (16#00AB5#, 16#00AB9#), -- (Lo) GUJARATI LETTER VA .. GUJARATI LETTER HA - (16#00ABC#, 16#00ABC#), -- (Mn) GUJARATI SIGN NUKTA .. GUJARATI SIGN NUKTA - (16#00ABD#, 16#00ABD#), -- (Lo) GUJARATI SIGN AVAGRAHA .. GUJARATI SIGN AVAGRAHA - (16#00ABE#, 16#00AC0#), -- (Mc) GUJARATI VOWEL SIGN AA .. GUJARATI VOWEL SIGN II - (16#00AC1#, 16#00AC5#), -- (Mn) GUJARATI VOWEL SIGN U .. GUJARATI VOWEL SIGN CANDRA E - (16#00AC7#, 16#00AC8#), -- (Mn) GUJARATI VOWEL SIGN E .. GUJARATI VOWEL SIGN AI - (16#00AC9#, 16#00AC9#), -- (Mc) GUJARATI VOWEL SIGN CANDRA O .. GUJARATI VOWEL SIGN CANDRA O - (16#00ACB#, 16#00ACC#), -- (Mc) GUJARATI VOWEL SIGN O .. GUJARATI VOWEL SIGN AU - (16#00ACD#, 16#00ACD#), -- (Mn) GUJARATI SIGN VIRAMA .. GUJARATI SIGN VIRAMA - (16#00AD0#, 16#00AD0#), -- (Lo) GUJARATI OM .. GUJARATI OM - (16#00AE0#, 16#00AE1#), -- (Lo) GUJARATI LETTER VOCALIC RR .. GUJARATI LETTER VOCALIC LL - (16#00AE2#, 16#00AE3#), -- (Mn) GUJARATI VOWEL SIGN VOCALIC L .. GUJARATI VOWEL SIGN VOCALIC LL - (16#00AE6#, 16#00AEF#), -- (Nd) GUJARATI DIGIT ZERO .. GUJARATI DIGIT NINE - (16#00AF1#, 16#00AF1#), -- (Sc) GUJARATI RUPEE SIGN .. GUJARATI RUPEE SIGN - (16#00B01#, 16#00B01#), -- (Mn) ORIYA SIGN CANDRABINDU .. ORIYA SIGN CANDRABINDU - (16#00B02#, 16#00B03#), -- (Mc) ORIYA SIGN ANUSVARA .. ORIYA SIGN VISARGA - (16#00B05#, 16#00B0C#), -- (Lo) ORIYA LETTER A .. ORIYA LETTER VOCALIC L - (16#00B0F#, 16#00B10#), -- (Lo) ORIYA LETTER E .. ORIYA LETTER AI - (16#00B13#, 16#00B28#), -- (Lo) ORIYA LETTER O .. ORIYA LETTER NA - (16#00B2A#, 16#00B30#), -- (Lo) ORIYA LETTER PA .. ORIYA LETTER RA - (16#00B32#, 16#00B33#), -- (Lo) ORIYA LETTER LA .. ORIYA LETTER LLA - (16#00B35#, 16#00B39#), -- (Lo) ORIYA LETTER VA .. ORIYA LETTER HA - (16#00B3C#, 16#00B3C#), -- (Mn) ORIYA SIGN NUKTA .. ORIYA SIGN NUKTA - (16#00B3D#, 16#00B3D#), -- (Lo) ORIYA SIGN AVAGRAHA .. ORIYA SIGN AVAGRAHA - (16#00B3E#, 16#00B3E#), -- (Mc) ORIYA VOWEL SIGN AA .. ORIYA VOWEL SIGN AA - (16#00B3F#, 16#00B3F#), -- (Mn) ORIYA VOWEL SIGN I .. ORIYA VOWEL SIGN I - (16#00B40#, 16#00B40#), -- (Mc) ORIYA VOWEL SIGN II .. ORIYA VOWEL SIGN II - (16#00B41#, 16#00B43#), -- (Mn) ORIYA VOWEL SIGN U .. ORIYA VOWEL SIGN VOCALIC R - (16#00B47#, 16#00B48#), -- (Mc) ORIYA VOWEL SIGN E .. ORIYA VOWEL SIGN AI - (16#00B4B#, 16#00B4C#), -- (Mc) ORIYA VOWEL SIGN O .. ORIYA VOWEL SIGN AU - (16#00B4D#, 16#00B4D#), -- (Mn) ORIYA SIGN VIRAMA .. ORIYA SIGN VIRAMA - (16#00B56#, 16#00B56#), -- (Mn) ORIYA AI LENGTH MARK .. ORIYA AI LENGTH MARK - (16#00B57#, 16#00B57#), -- (Mc) ORIYA AU LENGTH MARK .. ORIYA AU LENGTH MARK - (16#00B5C#, 16#00B5D#), -- (Lo) ORIYA LETTER RRA .. ORIYA LETTER RHA - (16#00B5F#, 16#00B61#), -- (Lo) ORIYA LETTER YYA .. ORIYA LETTER VOCALIC LL - (16#00B66#, 16#00B6F#), -- (Nd) ORIYA DIGIT ZERO .. ORIYA DIGIT NINE - (16#00B70#, 16#00B70#), -- (So) ORIYA ISSHAR .. ORIYA ISSHAR - (16#00B71#, 16#00B71#), -- (Lo) ORIYA LETTER WA .. ORIYA LETTER WA - (16#00B82#, 16#00B82#), -- (Mn) TAMIL SIGN ANUSVARA .. TAMIL SIGN ANUSVARA - (16#00B83#, 16#00B83#), -- (Lo) TAMIL SIGN VISARGA .. TAMIL SIGN VISARGA - (16#00B85#, 16#00B8A#), -- (Lo) TAMIL LETTER A .. TAMIL LETTER UU - (16#00B8E#, 16#00B90#), -- (Lo) TAMIL LETTER E .. TAMIL LETTER AI - (16#00B92#, 16#00B95#), -- (Lo) TAMIL LETTER O .. TAMIL LETTER KA - (16#00B99#, 16#00B9A#), -- (Lo) TAMIL LETTER NGA .. TAMIL LETTER CA - (16#00B9C#, 16#00B9C#), -- (Lo) TAMIL LETTER JA .. TAMIL LETTER JA - (16#00B9E#, 16#00B9F#), -- (Lo) TAMIL LETTER NYA .. TAMIL LETTER TTA - (16#00BA3#, 16#00BA4#), -- (Lo) TAMIL LETTER NNA .. TAMIL LETTER TA - (16#00BA8#, 16#00BAA#), -- (Lo) TAMIL LETTER NA .. TAMIL LETTER PA - (16#00BAE#, 16#00BB5#), -- (Lo) TAMIL LETTER MA .. TAMIL LETTER VA - (16#00BB7#, 16#00BB9#), -- (Lo) TAMIL LETTER SSA .. TAMIL LETTER HA - (16#00BBE#, 16#00BBF#), -- (Mc) TAMIL VOWEL SIGN AA .. TAMIL VOWEL SIGN I - (16#00BC0#, 16#00BC0#), -- (Mn) TAMIL VOWEL SIGN II .. TAMIL VOWEL SIGN II - (16#00BC1#, 16#00BC2#), -- (Mc) TAMIL VOWEL SIGN U .. TAMIL VOWEL SIGN UU - (16#00BC6#, 16#00BC8#), -- (Mc) TAMIL VOWEL SIGN E .. TAMIL VOWEL SIGN AI - (16#00BCA#, 16#00BCC#), -- (Mc) TAMIL VOWEL SIGN O .. TAMIL VOWEL SIGN AU - (16#00BCD#, 16#00BCD#), -- (Mn) TAMIL SIGN VIRAMA .. TAMIL SIGN VIRAMA - (16#00BD7#, 16#00BD7#), -- (Mc) TAMIL AU LENGTH MARK .. TAMIL AU LENGTH MARK - (16#00BE7#, 16#00BEF#), -- (Nd) TAMIL DIGIT ONE .. TAMIL DIGIT NINE - (16#00BF0#, 16#00BF2#), -- (No) TAMIL NUMBER TEN .. TAMIL NUMBER ONE THOUSAND - (16#00BF3#, 16#00BF8#), -- (So) TAMIL DAY SIGN .. TAMIL AS ABOVE SIGN - (16#00BF9#, 16#00BF9#), -- (Sc) TAMIL RUPEE SIGN .. TAMIL RUPEE SIGN - (16#00BFA#, 16#00BFA#), -- (So) TAMIL NUMBER SIGN .. TAMIL NUMBER SIGN - (16#00C01#, 16#00C03#), -- (Mc) TELUGU SIGN CANDRABINDU .. TELUGU SIGN VISARGA - (16#00C05#, 16#00C0C#), -- (Lo) TELUGU LETTER A .. TELUGU LETTER VOCALIC L - (16#00C0E#, 16#00C10#), -- (Lo) TELUGU LETTER E .. TELUGU LETTER AI - (16#00C12#, 16#00C28#), -- (Lo) TELUGU LETTER O .. TELUGU LETTER NA - (16#00C2A#, 16#00C33#), -- (Lo) TELUGU LETTER PA .. TELUGU LETTER LLA - (16#00C35#, 16#00C39#), -- (Lo) TELUGU LETTER VA .. TELUGU LETTER HA - (16#00C3E#, 16#00C40#), -- (Mn) TELUGU VOWEL SIGN AA .. TELUGU VOWEL SIGN II - (16#00C41#, 16#00C44#), -- (Mc) TELUGU VOWEL SIGN U .. TELUGU VOWEL SIGN VOCALIC RR - (16#00C46#, 16#00C48#), -- (Mn) TELUGU VOWEL SIGN E .. TELUGU VOWEL SIGN AI - (16#00C4A#, 16#00C4D#), -- (Mn) TELUGU VOWEL SIGN O .. TELUGU SIGN VIRAMA - (16#00C55#, 16#00C56#), -- (Mn) TELUGU LENGTH MARK .. TELUGU AI LENGTH MARK - (16#00C60#, 16#00C61#), -- (Lo) TELUGU LETTER VOCALIC RR .. TELUGU LETTER VOCALIC LL - (16#00C66#, 16#00C6F#), -- (Nd) TELUGU DIGIT ZERO .. TELUGU DIGIT NINE - (16#00C82#, 16#00C83#), -- (Mc) KANNADA SIGN ANUSVARA .. KANNADA SIGN VISARGA - (16#00C85#, 16#00C8C#), -- (Lo) KANNADA LETTER A .. KANNADA LETTER VOCALIC L - (16#00C8E#, 16#00C90#), -- (Lo) KANNADA LETTER E .. KANNADA LETTER AI - (16#00C92#, 16#00CA8#), -- (Lo) KANNADA LETTER O .. KANNADA LETTER NA - (16#00CAA#, 16#00CB3#), -- (Lo) KANNADA LETTER PA .. KANNADA LETTER LLA - (16#00CB5#, 16#00CB9#), -- (Lo) KANNADA LETTER VA .. KANNADA LETTER HA - (16#00CBC#, 16#00CBC#), -- (Mn) KANNADA SIGN NUKTA .. KANNADA SIGN NUKTA - (16#00CBD#, 16#00CBD#), -- (Lo) KANNADA SIGN AVAGRAHA .. KANNADA SIGN AVAGRAHA - (16#00CBE#, 16#00CBE#), -- (Mc) KANNADA VOWEL SIGN AA .. KANNADA VOWEL SIGN AA - (16#00CBF#, 16#00CBF#), -- (Mn) KANNADA VOWEL SIGN I .. KANNADA VOWEL SIGN I - (16#00CC0#, 16#00CC4#), -- (Mc) KANNADA VOWEL SIGN II .. KANNADA VOWEL SIGN VOCALIC RR - (16#00CC6#, 16#00CC6#), -- (Mn) KANNADA VOWEL SIGN E .. KANNADA VOWEL SIGN E - (16#00CC7#, 16#00CC8#), -- (Mc) KANNADA VOWEL SIGN EE .. KANNADA VOWEL SIGN AI - (16#00CCA#, 16#00CCB#), -- (Mc) KANNADA VOWEL SIGN O .. KANNADA VOWEL SIGN OO - (16#00CCC#, 16#00CCD#), -- (Mn) KANNADA VOWEL SIGN AU .. KANNADA SIGN VIRAMA - (16#00CD5#, 16#00CD6#), -- (Mc) KANNADA LENGTH MARK .. KANNADA AI LENGTH MARK - (16#00CDE#, 16#00CDE#), -- (Lo) KANNADA LETTER FA .. KANNADA LETTER FA - (16#00CE0#, 16#00CE1#), -- (Lo) KANNADA LETTER VOCALIC RR .. KANNADA LETTER VOCALIC LL - (16#00CE6#, 16#00CEF#), -- (Nd) KANNADA DIGIT ZERO .. KANNADA DIGIT NINE - (16#00D02#, 16#00D03#), -- (Mc) MALAYALAM SIGN ANUSVARA .. MALAYALAM SIGN VISARGA - (16#00D05#, 16#00D0C#), -- (Lo) MALAYALAM LETTER A .. MALAYALAM LETTER VOCALIC L - (16#00D0E#, 16#00D10#), -- (Lo) MALAYALAM LETTER E .. MALAYALAM LETTER AI - (16#00D12#, 16#00D28#), -- (Lo) MALAYALAM LETTER O .. MALAYALAM LETTER NA - (16#00D2A#, 16#00D39#), -- (Lo) MALAYALAM LETTER PA .. MALAYALAM LETTER HA - (16#00D3E#, 16#00D40#), -- (Mc) MALAYALAM VOWEL SIGN AA .. MALAYALAM VOWEL SIGN II - (16#00D41#, 16#00D43#), -- (Mn) MALAYALAM VOWEL SIGN U .. MALAYALAM VOWEL SIGN VOCALIC R - (16#00D46#, 16#00D48#), -- (Mc) MALAYALAM VOWEL SIGN E .. MALAYALAM VOWEL SIGN AI - (16#00D4A#, 16#00D4C#), -- (Mc) MALAYALAM VOWEL SIGN O .. MALAYALAM VOWEL SIGN AU - (16#00D4D#, 16#00D4D#), -- (Mn) MALAYALAM SIGN VIRAMA .. MALAYALAM SIGN VIRAMA - (16#00D57#, 16#00D57#), -- (Mc) MALAYALAM AU LENGTH MARK .. MALAYALAM AU LENGTH MARK - (16#00D60#, 16#00D61#), -- (Lo) MALAYALAM LETTER VOCALIC RR .. MALAYALAM LETTER VOCALIC LL - (16#00D66#, 16#00D6F#), -- (Nd) MALAYALAM DIGIT ZERO .. MALAYALAM DIGIT NINE - (16#00D82#, 16#00D83#), -- (Mc) SINHALA SIGN ANUSVARAYA .. SINHALA SIGN VISARGAYA - (16#00D85#, 16#00D96#), -- (Lo) SINHALA LETTER AYANNA .. SINHALA LETTER AUYANNA - (16#00D9A#, 16#00DB1#), -- (Lo) SINHALA LETTER ALPAPRAANA KAYANNA .. SINHALA LETTER DANTAJA NAYANNA - (16#00DB3#, 16#00DBB#), -- (Lo) SINHALA LETTER SANYAKA DAYANNA .. SINHALA LETTER RAYANNA - (16#00DBD#, 16#00DBD#), -- (Lo) SINHALA LETTER DANTAJA LAYANNA .. SINHALA LETTER DANTAJA LAYANNA - (16#00DC0#, 16#00DC6#), -- (Lo) SINHALA LETTER VAYANNA .. SINHALA LETTER FAYANNA - (16#00DCA#, 16#00DCA#), -- (Mn) SINHALA SIGN AL-LAKUNA .. SINHALA SIGN AL-LAKUNA - (16#00DCF#, 16#00DD1#), -- (Mc) SINHALA VOWEL SIGN AELA-PILLA .. SINHALA VOWEL SIGN DIGA AEDA-PILLA - (16#00DD2#, 16#00DD4#), -- (Mn) SINHALA VOWEL SIGN KETTI IS-PILLA .. SINHALA VOWEL SIGN KETTI PAA-PILLA - (16#00DD6#, 16#00DD6#), -- (Mn) SINHALA VOWEL SIGN DIGA PAA-PILLA .. SINHALA VOWEL SIGN DIGA PAA-PILLA - (16#00DD8#, 16#00DDF#), -- (Mc) SINHALA VOWEL SIGN GAETTA-PILLA .. SINHALA VOWEL SIGN GAYANUKITTA - (16#00DF2#, 16#00DF3#), -- (Mc) SINHALA VOWEL SIGN DIGA GAETTA-PILLA .. SINHALA VOWEL SIGN DIGA GAYANUKITTA - (16#00DF4#, 16#00DF4#), -- (Po) SINHALA PUNCTUATION KUNDDALIYA .. SINHALA PUNCTUATION KUNDDALIYA - (16#00E01#, 16#00E30#), -- (Lo) THAI CHARACTER KO KAI .. THAI CHARACTER SARA A - (16#00E31#, 16#00E31#), -- (Mn) THAI CHARACTER MAI HAN-AKAT .. THAI CHARACTER MAI HAN-AKAT - (16#00E32#, 16#00E33#), -- (Lo) THAI CHARACTER SARA AA .. THAI CHARACTER SARA AM - (16#00E34#, 16#00E3A#), -- (Mn) THAI CHARACTER SARA I .. THAI CHARACTER PHINTHU - (16#00E3F#, 16#00E3F#), -- (Sc) THAI CURRENCY SYMBOL BAHT .. THAI CURRENCY SYMBOL BAHT - (16#00E40#, 16#00E45#), -- (Lo) THAI CHARACTER SARA E .. THAI CHARACTER LAKKHANGYAO - (16#00E46#, 16#00E46#), -- (Lm) THAI CHARACTER MAIYAMOK .. THAI CHARACTER MAIYAMOK - (16#00E47#, 16#00E4E#), -- (Mn) THAI CHARACTER MAITAIKHU .. THAI CHARACTER YAMAKKAN - (16#00E4F#, 16#00E4F#), -- (Po) THAI CHARACTER FONGMAN .. THAI CHARACTER FONGMAN - (16#00E50#, 16#00E59#), -- (Nd) THAI DIGIT ZERO .. THAI DIGIT NINE - (16#00E5A#, 16#00E5B#), -- (Po) THAI CHARACTER ANGKHANKHU .. THAI CHARACTER KHOMUT - (16#00E81#, 16#00E82#), -- (Lo) LAO LETTER KO .. LAO LETTER KHO SUNG - (16#00E84#, 16#00E84#), -- (Lo) LAO LETTER KHO TAM .. LAO LETTER KHO TAM - (16#00E87#, 16#00E88#), -- (Lo) LAO LETTER NGO .. LAO LETTER CO - (16#00E8A#, 16#00E8A#), -- (Lo) LAO LETTER SO TAM .. LAO LETTER SO TAM - (16#00E8D#, 16#00E8D#), -- (Lo) LAO LETTER NYO .. LAO LETTER NYO - (16#00E94#, 16#00E97#), -- (Lo) LAO LETTER DO .. LAO LETTER THO TAM - (16#00E99#, 16#00E9F#), -- (Lo) LAO LETTER NO .. LAO LETTER FO SUNG - (16#00EA1#, 16#00EA3#), -- (Lo) LAO LETTER MO .. LAO LETTER LO LING - (16#00EA5#, 16#00EA5#), -- (Lo) LAO LETTER LO LOOT .. LAO LETTER LO LOOT - (16#00EA7#, 16#00EA7#), -- (Lo) LAO LETTER WO .. LAO LETTER WO - (16#00EAA#, 16#00EAB#), -- (Lo) LAO LETTER SO SUNG .. LAO LETTER HO SUNG - (16#00EAD#, 16#00EB0#), -- (Lo) LAO LETTER O .. LAO VOWEL SIGN A - (16#00EB1#, 16#00EB1#), -- (Mn) LAO VOWEL SIGN MAI KAN .. LAO VOWEL SIGN MAI KAN - (16#00EB2#, 16#00EB3#), -- (Lo) LAO VOWEL SIGN AA .. LAO VOWEL SIGN AM - (16#00EB4#, 16#00EB9#), -- (Mn) LAO VOWEL SIGN I .. LAO VOWEL SIGN UU - (16#00EBB#, 16#00EBC#), -- (Mn) LAO VOWEL SIGN MAI KON .. LAO SEMIVOWEL SIGN LO - (16#00EBD#, 16#00EBD#), -- (Lo) LAO SEMIVOWEL SIGN NYO .. LAO SEMIVOWEL SIGN NYO - (16#00EC0#, 16#00EC4#), -- (Lo) LAO VOWEL SIGN E .. LAO VOWEL SIGN AI - (16#00EC6#, 16#00EC6#), -- (Lm) LAO KO LA .. LAO KO LA - (16#00EC8#, 16#00ECD#), -- (Mn) LAO TONE MAI EK .. LAO NIGGAHITA - (16#00ED0#, 16#00ED9#), -- (Nd) LAO DIGIT ZERO .. LAO DIGIT NINE - (16#00EDC#, 16#00EDD#), -- (Lo) LAO HO NO .. LAO HO MO - (16#00F00#, 16#00F00#), -- (Lo) TIBETAN SYLLABLE OM .. TIBETAN SYLLABLE OM - (16#00F01#, 16#00F03#), -- (So) TIBETAN MARK GTER YIG MGO TRUNCATED A .. TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA - (16#00F04#, 16#00F12#), -- (Po) TIBETAN MARK INITIAL YIG MGO MDUN MA .. TIBETAN MARK RGYA GRAM SHAD - (16#00F13#, 16#00F17#), -- (So) TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN .. TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS - (16#00F18#, 16#00F19#), -- (Mn) TIBETAN ASTROLOGICAL SIGN -KHYUD PA .. TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS - (16#00F1A#, 16#00F1F#), -- (So) TIBETAN SIGN RDEL DKAR GCIG .. TIBETAN SIGN RDEL DKAR RDEL NAG - (16#00F20#, 16#00F29#), -- (Nd) TIBETAN DIGIT ZERO .. TIBETAN DIGIT NINE - (16#00F2A#, 16#00F33#), -- (No) TIBETAN DIGIT HALF ONE .. TIBETAN DIGIT HALF ZERO - (16#00F34#, 16#00F34#), -- (So) TIBETAN MARK BSDUS RTAGS .. TIBETAN MARK BSDUS RTAGS - (16#00F35#, 16#00F35#), -- (Mn) TIBETAN MARK NGAS BZUNG NYI ZLA .. TIBETAN MARK NGAS BZUNG NYI ZLA - (16#00F36#, 16#00F36#), -- (So) TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN .. TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN - (16#00F37#, 16#00F37#), -- (Mn) TIBETAN MARK NGAS BZUNG SGOR RTAGS .. TIBETAN MARK NGAS BZUNG SGOR RTAGS - (16#00F38#, 16#00F38#), -- (So) TIBETAN MARK CHE MGO .. TIBETAN MARK CHE MGO - (16#00F39#, 16#00F39#), -- (Mn) TIBETAN MARK TSA -PHRU .. TIBETAN MARK TSA -PHRU - (16#00F3A#, 16#00F3A#), -- (Ps) TIBETAN MARK GUG RTAGS GYON .. TIBETAN MARK GUG RTAGS GYON - (16#00F3B#, 16#00F3B#), -- (Pe) TIBETAN MARK GUG RTAGS GYAS .. TIBETAN MARK GUG RTAGS GYAS - (16#00F3C#, 16#00F3C#), -- (Ps) TIBETAN MARK ANG KHANG GYON .. TIBETAN MARK ANG KHANG GYON - (16#00F3D#, 16#00F3D#), -- (Pe) TIBETAN MARK ANG KHANG GYAS .. TIBETAN MARK ANG KHANG GYAS - (16#00F3E#, 16#00F3F#), -- (Mc) TIBETAN SIGN YAR TSHES .. TIBETAN SIGN MAR TSHES - (16#00F40#, 16#00F47#), -- (Lo) TIBETAN LETTER KA .. TIBETAN LETTER JA - (16#00F49#, 16#00F6A#), -- (Lo) TIBETAN LETTER NYA .. TIBETAN LETTER FIXED-FORM RA - (16#00F71#, 16#00F7E#), -- (Mn) TIBETAN VOWEL SIGN AA .. TIBETAN SIGN RJES SU NGA RO - (16#00F7F#, 16#00F7F#), -- (Mc) TIBETAN SIGN RNAM BCAD .. TIBETAN SIGN RNAM BCAD - (16#00F80#, 16#00F84#), -- (Mn) TIBETAN VOWEL SIGN REVERSED I .. TIBETAN MARK HALANTA - (16#00F85#, 16#00F85#), -- (Po) TIBETAN MARK PALUTA .. TIBETAN MARK PALUTA - (16#00F86#, 16#00F87#), -- (Mn) TIBETAN SIGN LCI RTAGS .. TIBETAN SIGN YANG RTAGS - (16#00F88#, 16#00F8B#), -- (Lo) TIBETAN SIGN LCE TSA CAN .. TIBETAN SIGN GRU MED RGYINGS - (16#00F90#, 16#00F97#), -- (Mn) TIBETAN SUBJOINED LETTER KA .. TIBETAN SUBJOINED LETTER JA - (16#00F99#, 16#00FBC#), -- (Mn) TIBETAN SUBJOINED LETTER NYA .. TIBETAN SUBJOINED LETTER FIXED-FORM RA - (16#00FBE#, 16#00FC5#), -- (So) TIBETAN KU RU KHA .. TIBETAN SYMBOL RDO RJE - (16#00FC6#, 16#00FC6#), -- (Mn) TIBETAN SYMBOL PADMA GDAN .. TIBETAN SYMBOL PADMA GDAN - (16#00FC7#, 16#00FCC#), -- (So) TIBETAN SYMBOL RDO RJE RGYA GRAM .. TIBETAN SYMBOL NOR BU BZHI -KHYIL - (16#00FCF#, 16#00FCF#), -- (So) TIBETAN SIGN RDEL NAG GSUM .. TIBETAN SIGN RDEL NAG GSUM - (16#01000#, 16#01021#), -- (Lo) MYANMAR LETTER KA .. MYANMAR LETTER A - (16#01023#, 16#01027#), -- (Lo) MYANMAR LETTER I .. MYANMAR LETTER E - (16#01029#, 16#0102A#), -- (Lo) MYANMAR LETTER O .. MYANMAR LETTER AU - (16#0102C#, 16#0102C#), -- (Mc) MYANMAR VOWEL SIGN AA .. MYANMAR VOWEL SIGN AA - (16#0102D#, 16#01030#), -- (Mn) MYANMAR VOWEL SIGN I .. MYANMAR VOWEL SIGN UU - (16#01031#, 16#01031#), -- (Mc) MYANMAR VOWEL SIGN E .. MYANMAR VOWEL SIGN E - (16#01032#, 16#01032#), -- (Mn) MYANMAR VOWEL SIGN AI .. MYANMAR VOWEL SIGN AI - (16#01036#, 16#01037#), -- (Mn) MYANMAR SIGN ANUSVARA .. MYANMAR SIGN DOT BELOW - (16#01038#, 16#01038#), -- (Mc) MYANMAR SIGN VISARGA .. MYANMAR SIGN VISARGA - (16#01039#, 16#01039#), -- (Mn) MYANMAR SIGN VIRAMA .. MYANMAR SIGN VIRAMA - (16#01040#, 16#01049#), -- (Nd) MYANMAR DIGIT ZERO .. MYANMAR DIGIT NINE - (16#0104A#, 16#0104F#), -- (Po) MYANMAR SIGN LITTLE SECTION .. MYANMAR SYMBOL GENITIVE - (16#01050#, 16#01055#), -- (Lo) MYANMAR LETTER SHA .. MYANMAR LETTER VOCALIC LL - (16#01056#, 16#01057#), -- (Mc) MYANMAR VOWEL SIGN VOCALIC R .. MYANMAR VOWEL SIGN VOCALIC RR - (16#01058#, 16#01059#), -- (Mn) MYANMAR VOWEL SIGN VOCALIC L .. MYANMAR VOWEL SIGN VOCALIC LL - (16#010A0#, 16#010C5#), -- (Lu) GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE - (16#010D0#, 16#010F8#), -- (Lo) GEORGIAN LETTER AN .. GEORGIAN LETTER ELIFI - (16#010FB#, 16#010FB#), -- (Po) GEORGIAN PARAGRAPH SEPARATOR .. GEORGIAN PARAGRAPH SEPARATOR - (16#01100#, 16#01159#), -- (Lo) HANGUL CHOSEONG KIYEOK .. HANGUL CHOSEONG YEORINHIEUH - (16#0115F#, 16#011A2#), -- (Lo) HANGUL CHOSEONG FILLER .. HANGUL JUNGSEONG SSANGARAEA - (16#011A8#, 16#011F9#), -- (Lo) HANGUL JONGSEONG KIYEOK .. HANGUL JONGSEONG YEORINHIEUH - (16#01200#, 16#01206#), -- (Lo) ETHIOPIC SYLLABLE HA .. ETHIOPIC SYLLABLE HO - (16#01208#, 16#01246#), -- (Lo) ETHIOPIC SYLLABLE LA .. ETHIOPIC SYLLABLE QO - (16#01248#, 16#01248#), -- (Lo) ETHIOPIC SYLLABLE QWA .. ETHIOPIC SYLLABLE QWA - (16#0124A#, 16#0124D#), -- (Lo) ETHIOPIC SYLLABLE QWI .. ETHIOPIC SYLLABLE QWE - (16#01250#, 16#01256#), -- (Lo) ETHIOPIC SYLLABLE QHA .. ETHIOPIC SYLLABLE QHO - (16#01258#, 16#01258#), -- (Lo) ETHIOPIC SYLLABLE QHWA .. ETHIOPIC SYLLABLE QHWA - (16#0125A#, 16#0125D#), -- (Lo) ETHIOPIC SYLLABLE QHWI .. ETHIOPIC SYLLABLE QHWE - (16#01260#, 16#01286#), -- (Lo) ETHIOPIC SYLLABLE BA .. ETHIOPIC SYLLABLE XO - (16#01288#, 16#01288#), -- (Lo) ETHIOPIC SYLLABLE XWA .. ETHIOPIC SYLLABLE XWA - (16#0128A#, 16#0128D#), -- (Lo) ETHIOPIC SYLLABLE XWI .. ETHIOPIC SYLLABLE XWE - (16#01290#, 16#012AE#), -- (Lo) ETHIOPIC SYLLABLE NA .. ETHIOPIC SYLLABLE KO - (16#012B0#, 16#012B0#), -- (Lo) ETHIOPIC SYLLABLE KWA .. ETHIOPIC SYLLABLE KWA - (16#012B2#, 16#012B5#), -- (Lo) ETHIOPIC SYLLABLE KWI .. ETHIOPIC SYLLABLE KWE - (16#012B8#, 16#012BE#), -- (Lo) ETHIOPIC SYLLABLE KXA .. ETHIOPIC SYLLABLE KXO - (16#012C0#, 16#012C0#), -- (Lo) ETHIOPIC SYLLABLE KXWA .. ETHIOPIC SYLLABLE KXWA - (16#012C2#, 16#012C5#), -- (Lo) ETHIOPIC SYLLABLE KXWI .. ETHIOPIC SYLLABLE KXWE - (16#012C8#, 16#012CE#), -- (Lo) ETHIOPIC SYLLABLE WA .. ETHIOPIC SYLLABLE WO - (16#012D0#, 16#012D6#), -- (Lo) ETHIOPIC SYLLABLE PHARYNGEAL A .. ETHIOPIC SYLLABLE PHARYNGEAL O - (16#012D8#, 16#012EE#), -- (Lo) ETHIOPIC SYLLABLE ZA .. ETHIOPIC SYLLABLE YO - (16#012F0#, 16#0130E#), -- (Lo) ETHIOPIC SYLLABLE DA .. ETHIOPIC SYLLABLE GO - (16#01310#, 16#01310#), -- (Lo) ETHIOPIC SYLLABLE GWA .. ETHIOPIC SYLLABLE GWA - (16#01312#, 16#01315#), -- (Lo) ETHIOPIC SYLLABLE GWI .. ETHIOPIC SYLLABLE GWE - (16#01318#, 16#0131E#), -- (Lo) ETHIOPIC SYLLABLE GGA .. ETHIOPIC SYLLABLE GGO - (16#01320#, 16#01346#), -- (Lo) ETHIOPIC SYLLABLE THA .. ETHIOPIC SYLLABLE TZO - (16#01348#, 16#0135A#), -- (Lo) ETHIOPIC SYLLABLE FA .. ETHIOPIC SYLLABLE FYA - (16#01361#, 16#01368#), -- (Po) ETHIOPIC WORDSPACE .. ETHIOPIC PARAGRAPH SEPARATOR - (16#01369#, 16#01371#), -- (Nd) ETHIOPIC DIGIT ONE .. ETHIOPIC DIGIT NINE - (16#01372#, 16#0137C#), -- (No) ETHIOPIC NUMBER TEN .. ETHIOPIC NUMBER TEN THOUSAND - (16#013A0#, 16#013F4#), -- (Lo) CHEROKEE LETTER A .. CHEROKEE LETTER YV - (16#01401#, 16#0166C#), -- (Lo) CANADIAN SYLLABICS E .. CANADIAN SYLLABICS CARRIER TTSA - (16#0166D#, 16#0166E#), -- (Po) CANADIAN SYLLABICS CHI SIGN .. CANADIAN SYLLABICS FULL STOP - (16#0166F#, 16#01676#), -- (Lo) CANADIAN SYLLABICS QAI .. CANADIAN SYLLABICS NNGAA - (16#01680#, 16#01680#), -- (Zs) OGHAM SPACE MARK .. OGHAM SPACE MARK - (16#01681#, 16#0169A#), -- (Lo) OGHAM LETTER BEITH .. OGHAM LETTER PEITH - (16#0169B#, 16#0169B#), -- (Ps) OGHAM FEATHER MARK .. OGHAM FEATHER MARK - (16#0169C#, 16#0169C#), -- (Pe) OGHAM REVERSED FEATHER MARK .. OGHAM REVERSED FEATHER MARK - (16#016A0#, 16#016EA#), -- (Lo) RUNIC LETTER FEHU FEOH FE F .. RUNIC LETTER X - (16#016EB#, 16#016ED#), -- (Po) RUNIC SINGLE PUNCTUATION .. RUNIC CROSS PUNCTUATION - (16#016EE#, 16#016F0#), -- (Nl) RUNIC ARLAUG SYMBOL .. RUNIC BELGTHOR SYMBOL - (16#01700#, 16#0170C#), -- (Lo) TAGALOG LETTER A .. TAGALOG LETTER YA - (16#0170E#, 16#01711#), -- (Lo) TAGALOG LETTER LA .. TAGALOG LETTER HA - (16#01712#, 16#01714#), -- (Mn) TAGALOG VOWEL SIGN I .. TAGALOG SIGN VIRAMA - (16#01720#, 16#01731#), -- (Lo) HANUNOO LETTER A .. HANUNOO LETTER HA - (16#01732#, 16#01734#), -- (Mn) HANUNOO VOWEL SIGN I .. HANUNOO SIGN PAMUDPOD - (16#01735#, 16#01736#), -- (Po) PHILIPPINE SINGLE PUNCTUATION .. PHILIPPINE DOUBLE PUNCTUATION - (16#01740#, 16#01751#), -- (Lo) BUHID LETTER A .. BUHID LETTER HA - (16#01752#, 16#01753#), -- (Mn) BUHID VOWEL SIGN I .. BUHID VOWEL SIGN U - (16#01760#, 16#0176C#), -- (Lo) TAGBANWA LETTER A .. TAGBANWA LETTER YA - (16#0176E#, 16#01770#), -- (Lo) TAGBANWA LETTER LA .. TAGBANWA LETTER SA - (16#01772#, 16#01773#), -- (Mn) TAGBANWA VOWEL SIGN I .. TAGBANWA VOWEL SIGN U - (16#01780#, 16#017B3#), -- (Lo) KHMER LETTER KA .. KHMER INDEPENDENT VOWEL QAU - (16#017B4#, 16#017B5#), -- (Cf) KHMER VOWEL INHERENT AQ .. KHMER VOWEL INHERENT AA - (16#017B6#, 16#017B6#), -- (Mc) KHMER VOWEL SIGN AA .. KHMER VOWEL SIGN AA - (16#017B7#, 16#017BD#), -- (Mn) KHMER VOWEL SIGN I .. KHMER VOWEL SIGN UA - (16#017BE#, 16#017C5#), -- (Mc) KHMER VOWEL SIGN OE .. KHMER VOWEL SIGN AU - (16#017C6#, 16#017C6#), -- (Mn) KHMER SIGN NIKAHIT .. KHMER SIGN NIKAHIT - (16#017C7#, 16#017C8#), -- (Mc) KHMER SIGN REAHMUK .. KHMER SIGN YUUKALEAPINTU - (16#017C9#, 16#017D3#), -- (Mn) KHMER SIGN MUUSIKATOAN .. KHMER SIGN BATHAMASAT - (16#017D4#, 16#017D6#), -- (Po) KHMER SIGN KHAN .. KHMER SIGN CAMNUC PII KUUH - (16#017D7#, 16#017D7#), -- (Lm) KHMER SIGN LEK TOO .. KHMER SIGN LEK TOO - (16#017D8#, 16#017DA#), -- (Po) KHMER SIGN BEYYAL .. KHMER SIGN KOOMUUT - (16#017DB#, 16#017DB#), -- (Sc) KHMER CURRENCY SYMBOL RIEL .. KHMER CURRENCY SYMBOL RIEL - (16#017DC#, 16#017DC#), -- (Lo) KHMER SIGN AVAKRAHASANYA .. KHMER SIGN AVAKRAHASANYA - (16#017DD#, 16#017DD#), -- (Mn) KHMER SIGN ATTHACAN .. KHMER SIGN ATTHACAN - (16#017E0#, 16#017E9#), -- (Nd) KHMER DIGIT ZERO .. KHMER DIGIT NINE - (16#017F0#, 16#017F9#), -- (No) KHMER SYMBOL LEK ATTAK SON .. KHMER SYMBOL LEK ATTAK PRAM-BUON - (16#01800#, 16#01805#), -- (Po) MONGOLIAN BIRGA .. MONGOLIAN FOUR DOTS - (16#01806#, 16#01806#), -- (Pd) MONGOLIAN TODO SOFT HYPHEN .. MONGOLIAN TODO SOFT HYPHEN - (16#01807#, 16#0180A#), -- (Po) MONGOLIAN SIBE SYLLABLE BOUNDARY MARKER .. MONGOLIAN NIRUGU - (16#0180B#, 16#0180D#), -- (Mn) MONGOLIAN FREE VARIATION SELECTOR ONE .. MONGOLIAN FREE VARIATION SELECTOR THREE - (16#0180E#, 16#0180E#), -- (Zs) MONGOLIAN VOWEL SEPARATOR .. MONGOLIAN VOWEL SEPARATOR - (16#01810#, 16#01819#), -- (Nd) MONGOLIAN DIGIT ZERO .. MONGOLIAN DIGIT NINE - (16#01820#, 16#01842#), -- (Lo) MONGOLIAN LETTER A .. MONGOLIAN LETTER CHI - (16#01843#, 16#01843#), -- (Lm) MONGOLIAN LETTER TODO LONG VOWEL SIGN .. MONGOLIAN LETTER TODO LONG VOWEL SIGN - (16#01844#, 16#01877#), -- (Lo) MONGOLIAN LETTER TODO E .. MONGOLIAN LETTER MANCHU ZHA - (16#01880#, 16#018A8#), -- (Lo) MONGOLIAN LETTER ALI GALI ANUSVARA ONE .. MONGOLIAN LETTER MANCHU ALI GALI BHA - (16#018A9#, 16#018A9#), -- (Mn) MONGOLIAN LETTER ALI GALI DAGALGA .. MONGOLIAN LETTER ALI GALI DAGALGA - (16#01900#, 16#0191C#), -- (Lo) LIMBU VOWEL-CARRIER LETTER .. LIMBU LETTER HA - (16#01920#, 16#01922#), -- (Mn) LIMBU VOWEL SIGN A .. LIMBU VOWEL SIGN U - (16#01923#, 16#01926#), -- (Mc) LIMBU VOWEL SIGN EE .. LIMBU VOWEL SIGN AU - (16#01927#, 16#01928#), -- (Mn) LIMBU VOWEL SIGN E .. LIMBU VOWEL SIGN O - (16#01929#, 16#0192B#), -- (Mc) LIMBU SUBJOINED LETTER YA .. LIMBU SUBJOINED LETTER WA - (16#01930#, 16#01931#), -- (Mc) LIMBU SMALL LETTER KA .. LIMBU SMALL LETTER NGA - (16#01932#, 16#01932#), -- (Mn) LIMBU SMALL LETTER ANUSVARA .. LIMBU SMALL LETTER ANUSVARA - (16#01933#, 16#01938#), -- (Mc) LIMBU SMALL LETTER TA .. LIMBU SMALL LETTER LA - (16#01939#, 16#0193B#), -- (Mn) LIMBU SIGN MUKPHRENG .. LIMBU SIGN SA-I - (16#01940#, 16#01940#), -- (So) LIMBU SIGN LOO .. LIMBU SIGN LOO - (16#01944#, 16#01945#), -- (Po) LIMBU EXCLAMATION MARK .. LIMBU QUESTION MARK - (16#01946#, 16#0194F#), -- (Nd) LIMBU DIGIT ZERO .. LIMBU DIGIT NINE - (16#01950#, 16#0196D#), -- (Lo) TAI LE LETTER KA .. TAI LE LETTER AI - (16#01970#, 16#01974#), -- (Lo) TAI LE LETTER TONE-2 .. TAI LE LETTER TONE-6 - (16#019E0#, 16#019FF#), -- (So) KHMER SYMBOL PATHAMASAT .. KHMER SYMBOL DAP-PRAM ROC - (16#01D00#, 16#01D2B#), -- (Ll) LATIN LETTER SMALL CAPITAL A .. CYRILLIC LETTER SMALL CAPITAL EL - (16#01D2C#, 16#01D61#), -- (Lm) MODIFIER LETTER CAPITAL A .. MODIFIER LETTER SMALL CHI - (16#01D62#, 16#01D6B#), -- (Ll) LATIN SUBSCRIPT SMALL LETTER I .. LATIN SMALL LETTER UE - (16#01E00#, 16#01E00#), -- (Lu) LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW - (16#01E01#, 16#01E01#), -- (Ll) LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW - (16#01E02#, 16#01E02#), -- (Lu) LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE - (16#01E03#, 16#01E03#), -- (Ll) LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE - (16#01E04#, 16#01E04#), -- (Lu) LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW - (16#01E05#, 16#01E05#), -- (Ll) LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW - (16#01E06#, 16#01E06#), -- (Lu) LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW - (16#01E07#, 16#01E07#), -- (Ll) LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW - (16#01E08#, 16#01E08#), -- (Lu) LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE - (16#01E09#, 16#01E09#), -- (Ll) LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE - (16#01E0A#, 16#01E0A#), -- (Lu) LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE - (16#01E0B#, 16#01E0B#), -- (Ll) LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE - (16#01E0C#, 16#01E0C#), -- (Lu) LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW - (16#01E0D#, 16#01E0D#), -- (Ll) LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW - (16#01E0E#, 16#01E0E#), -- (Lu) LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW - (16#01E0F#, 16#01E0F#), -- (Ll) LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW - (16#01E10#, 16#01E10#), -- (Lu) LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA - (16#01E11#, 16#01E11#), -- (Ll) LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA - (16#01E12#, 16#01E12#), -- (Lu) LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW - (16#01E13#, 16#01E13#), -- (Ll) LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW - (16#01E14#, 16#01E14#), -- (Lu) LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE - (16#01E15#, 16#01E15#), -- (Ll) LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE - (16#01E16#, 16#01E16#), -- (Lu) LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE - (16#01E17#, 16#01E17#), -- (Ll) LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE - (16#01E18#, 16#01E18#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW - (16#01E19#, 16#01E19#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW - (16#01E1A#, 16#01E1A#), -- (Lu) LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW - (16#01E1B#, 16#01E1B#), -- (Ll) LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW - (16#01E1C#, 16#01E1C#), -- (Lu) LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE - (16#01E1D#, 16#01E1D#), -- (Ll) LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE - (16#01E1E#, 16#01E1E#), -- (Lu) LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE - (16#01E1F#, 16#01E1F#), -- (Ll) LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE - (16#01E20#, 16#01E20#), -- (Lu) LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON - (16#01E21#, 16#01E21#), -- (Ll) LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON - (16#01E22#, 16#01E22#), -- (Lu) LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE - (16#01E23#, 16#01E23#), -- (Ll) LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE - (16#01E24#, 16#01E24#), -- (Lu) LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW - (16#01E25#, 16#01E25#), -- (Ll) LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW - (16#01E26#, 16#01E26#), -- (Lu) LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS - (16#01E27#, 16#01E27#), -- (Ll) LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS - (16#01E28#, 16#01E28#), -- (Lu) LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA - (16#01E29#, 16#01E29#), -- (Ll) LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA - (16#01E2A#, 16#01E2A#), -- (Lu) LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW - (16#01E2B#, 16#01E2B#), -- (Ll) LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW - (16#01E2C#, 16#01E2C#), -- (Lu) LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW - (16#01E2D#, 16#01E2D#), -- (Ll) LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW - (16#01E2E#, 16#01E2E#), -- (Lu) LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE - (16#01E2F#, 16#01E2F#), -- (Ll) LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE - (16#01E30#, 16#01E30#), -- (Lu) LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE - (16#01E31#, 16#01E31#), -- (Ll) LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE - (16#01E32#, 16#01E32#), -- (Lu) LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW - (16#01E33#, 16#01E33#), -- (Ll) LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW - (16#01E34#, 16#01E34#), -- (Lu) LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW - (16#01E35#, 16#01E35#), -- (Ll) LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW - (16#01E36#, 16#01E36#), -- (Lu) LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW - (16#01E37#, 16#01E37#), -- (Ll) LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW - (16#01E38#, 16#01E38#), -- (Lu) LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON - (16#01E39#, 16#01E39#), -- (Ll) LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON - (16#01E3A#, 16#01E3A#), -- (Lu) LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW - (16#01E3B#, 16#01E3B#), -- (Ll) LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW - (16#01E3C#, 16#01E3C#), -- (Lu) LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW - (16#01E3D#, 16#01E3D#), -- (Ll) LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW - (16#01E3E#, 16#01E3E#), -- (Lu) LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE - (16#01E3F#, 16#01E3F#), -- (Ll) LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE - (16#01E40#, 16#01E40#), -- (Lu) LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE - (16#01E41#, 16#01E41#), -- (Ll) LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE - (16#01E42#, 16#01E42#), -- (Lu) LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW - (16#01E43#, 16#01E43#), -- (Ll) LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW - (16#01E44#, 16#01E44#), -- (Lu) LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE - (16#01E45#, 16#01E45#), -- (Ll) LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE - (16#01E46#, 16#01E46#), -- (Lu) LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW - (16#01E47#, 16#01E47#), -- (Ll) LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW - (16#01E48#, 16#01E48#), -- (Lu) LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW - (16#01E49#, 16#01E49#), -- (Ll) LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW - (16#01E4A#, 16#01E4A#), -- (Lu) LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW - (16#01E4B#, 16#01E4B#), -- (Ll) LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW - (16#01E4C#, 16#01E4C#), -- (Lu) LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE - (16#01E4D#, 16#01E4D#), -- (Ll) LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE - (16#01E4E#, 16#01E4E#), -- (Lu) LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS - (16#01E4F#, 16#01E4F#), -- (Ll) LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS - (16#01E50#, 16#01E50#), -- (Lu) LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE - (16#01E51#, 16#01E51#), -- (Ll) LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE - (16#01E52#, 16#01E52#), -- (Lu) LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE - (16#01E53#, 16#01E53#), -- (Ll) LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE - (16#01E54#, 16#01E54#), -- (Lu) LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE - (16#01E55#, 16#01E55#), -- (Ll) LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE - (16#01E56#, 16#01E56#), -- (Lu) LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE - (16#01E57#, 16#01E57#), -- (Ll) LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE - (16#01E58#, 16#01E58#), -- (Lu) LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE - (16#01E59#, 16#01E59#), -- (Ll) LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE - (16#01E5A#, 16#01E5A#), -- (Lu) LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW - (16#01E5B#, 16#01E5B#), -- (Ll) LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW - (16#01E5C#, 16#01E5C#), -- (Lu) LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON - (16#01E5D#, 16#01E5D#), -- (Ll) LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON - (16#01E5E#, 16#01E5E#), -- (Lu) LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW - (16#01E5F#, 16#01E5F#), -- (Ll) LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW - (16#01E60#, 16#01E60#), -- (Lu) LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE - (16#01E61#, 16#01E61#), -- (Ll) LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE - (16#01E62#, 16#01E62#), -- (Lu) LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW - (16#01E63#, 16#01E63#), -- (Ll) LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW - (16#01E64#, 16#01E64#), -- (Lu) LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE - (16#01E65#, 16#01E65#), -- (Ll) LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE - (16#01E66#, 16#01E66#), -- (Lu) LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE - (16#01E67#, 16#01E67#), -- (Ll) LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE - (16#01E68#, 16#01E68#), -- (Lu) LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE - (16#01E69#, 16#01E69#), -- (Ll) LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE - (16#01E6A#, 16#01E6A#), -- (Lu) LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE - (16#01E6B#, 16#01E6B#), -- (Ll) LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE - (16#01E6C#, 16#01E6C#), -- (Lu) LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW - (16#01E6D#, 16#01E6D#), -- (Ll) LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW - (16#01E6E#, 16#01E6E#), -- (Lu) LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW - (16#01E6F#, 16#01E6F#), -- (Ll) LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW - (16#01E70#, 16#01E70#), -- (Lu) LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW - (16#01E71#, 16#01E71#), -- (Ll) LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW - (16#01E72#, 16#01E72#), -- (Lu) LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW - (16#01E73#, 16#01E73#), -- (Ll) LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW - (16#01E74#, 16#01E74#), -- (Lu) LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW - (16#01E75#, 16#01E75#), -- (Ll) LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW - (16#01E76#, 16#01E76#), -- (Lu) LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW - (16#01E77#, 16#01E77#), -- (Ll) LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW - (16#01E78#, 16#01E78#), -- (Lu) LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE - (16#01E79#, 16#01E79#), -- (Ll) LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE - (16#01E7A#, 16#01E7A#), -- (Lu) LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS - (16#01E7B#, 16#01E7B#), -- (Ll) LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS - (16#01E7C#, 16#01E7C#), -- (Lu) LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE - (16#01E7D#, 16#01E7D#), -- (Ll) LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE - (16#01E7E#, 16#01E7E#), -- (Lu) LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW - (16#01E7F#, 16#01E7F#), -- (Ll) LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW - (16#01E80#, 16#01E80#), -- (Lu) LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE - (16#01E81#, 16#01E81#), -- (Ll) LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE - (16#01E82#, 16#01E82#), -- (Lu) LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE - (16#01E83#, 16#01E83#), -- (Ll) LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE - (16#01E84#, 16#01E84#), -- (Lu) LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS - (16#01E85#, 16#01E85#), -- (Ll) LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS - (16#01E86#, 16#01E86#), -- (Lu) LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE - (16#01E87#, 16#01E87#), -- (Ll) LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE - (16#01E88#, 16#01E88#), -- (Lu) LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW - (16#01E89#, 16#01E89#), -- (Ll) LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW - (16#01E8A#, 16#01E8A#), -- (Lu) LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE - (16#01E8B#, 16#01E8B#), -- (Ll) LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE - (16#01E8C#, 16#01E8C#), -- (Lu) LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS - (16#01E8D#, 16#01E8D#), -- (Ll) LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS - (16#01E8E#, 16#01E8E#), -- (Lu) LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE - (16#01E8F#, 16#01E8F#), -- (Ll) LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE - (16#01E90#, 16#01E90#), -- (Lu) LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX - (16#01E91#, 16#01E91#), -- (Ll) LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX - (16#01E92#, 16#01E92#), -- (Lu) LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW - (16#01E93#, 16#01E93#), -- (Ll) LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW - (16#01E94#, 16#01E94#), -- (Lu) LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW - (16#01E95#, 16#01E9B#), -- (Ll) LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER LONG S WITH DOT ABOVE - (16#01EA0#, 16#01EA0#), -- (Lu) LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW - (16#01EA1#, 16#01EA1#), -- (Ll) LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW - (16#01EA2#, 16#01EA2#), -- (Lu) LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE - (16#01EA3#, 16#01EA3#), -- (Ll) LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE - (16#01EA4#, 16#01EA4#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE - (16#01EA5#, 16#01EA5#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE - (16#01EA6#, 16#01EA6#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE - (16#01EA7#, 16#01EA7#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE - (16#01EA8#, 16#01EA8#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EA9#, 16#01EA9#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EAA#, 16#01EAA#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE - (16#01EAB#, 16#01EAB#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE - (16#01EAC#, 16#01EAC#), -- (Lu) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW - (16#01EAD#, 16#01EAD#), -- (Ll) LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW - (16#01EAE#, 16#01EAE#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE - (16#01EAF#, 16#01EAF#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE - (16#01EB0#, 16#01EB0#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE - (16#01EB1#, 16#01EB1#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE - (16#01EB2#, 16#01EB2#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE - (16#01EB3#, 16#01EB3#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE - (16#01EB4#, 16#01EB4#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE - (16#01EB5#, 16#01EB5#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE - (16#01EB6#, 16#01EB6#), -- (Lu) LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW - (16#01EB7#, 16#01EB7#), -- (Ll) LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW - (16#01EB8#, 16#01EB8#), -- (Lu) LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW - (16#01EB9#, 16#01EB9#), -- (Ll) LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW - (16#01EBA#, 16#01EBA#), -- (Lu) LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE - (16#01EBB#, 16#01EBB#), -- (Ll) LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE - (16#01EBC#, 16#01EBC#), -- (Lu) LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE - (16#01EBD#, 16#01EBD#), -- (Ll) LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE - (16#01EBE#, 16#01EBE#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE - (16#01EBF#, 16#01EBF#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE - (16#01EC0#, 16#01EC0#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE - (16#01EC1#, 16#01EC1#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE - (16#01EC2#, 16#01EC2#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EC3#, 16#01EC3#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EC4#, 16#01EC4#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE - (16#01EC5#, 16#01EC5#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE - (16#01EC6#, 16#01EC6#), -- (Lu) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW - (16#01EC7#, 16#01EC7#), -- (Ll) LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW - (16#01EC8#, 16#01EC8#), -- (Lu) LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE - (16#01EC9#, 16#01EC9#), -- (Ll) LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE - (16#01ECA#, 16#01ECA#), -- (Lu) LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW - (16#01ECB#, 16#01ECB#), -- (Ll) LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW - (16#01ECC#, 16#01ECC#), -- (Lu) LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW - (16#01ECD#, 16#01ECD#), -- (Ll) LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW - (16#01ECE#, 16#01ECE#), -- (Lu) LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE - (16#01ECF#, 16#01ECF#), -- (Ll) LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE - (16#01ED0#, 16#01ED0#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE - (16#01ED1#, 16#01ED1#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE - (16#01ED2#, 16#01ED2#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE - (16#01ED3#, 16#01ED3#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE - (16#01ED4#, 16#01ED4#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - (16#01ED5#, 16#01ED5#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - (16#01ED6#, 16#01ED6#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE - (16#01ED7#, 16#01ED7#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE - (16#01ED8#, 16#01ED8#), -- (Lu) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW - (16#01ED9#, 16#01ED9#), -- (Ll) LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW - (16#01EDA#, 16#01EDA#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE - (16#01EDB#, 16#01EDB#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE - (16#01EDC#, 16#01EDC#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE - (16#01EDD#, 16#01EDD#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE - (16#01EDE#, 16#01EDE#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE - (16#01EDF#, 16#01EDF#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE - (16#01EE0#, 16#01EE0#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE - (16#01EE1#, 16#01EE1#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE - (16#01EE2#, 16#01EE2#), -- (Lu) LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW - (16#01EE3#, 16#01EE3#), -- (Ll) LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW - (16#01EE4#, 16#01EE4#), -- (Lu) LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW - (16#01EE5#, 16#01EE5#), -- (Ll) LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW - (16#01EE6#, 16#01EE6#), -- (Lu) LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE - (16#01EE7#, 16#01EE7#), -- (Ll) LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE - (16#01EE8#, 16#01EE8#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE - (16#01EE9#, 16#01EE9#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE - (16#01EEA#, 16#01EEA#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE - (16#01EEB#, 16#01EEB#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE - (16#01EEC#, 16#01EEC#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE - (16#01EED#, 16#01EED#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE - (16#01EEE#, 16#01EEE#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE - (16#01EEF#, 16#01EEF#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE - (16#01EF0#, 16#01EF0#), -- (Lu) LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW - (16#01EF1#, 16#01EF1#), -- (Ll) LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW - (16#01EF2#, 16#01EF2#), -- (Lu) LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE - (16#01EF3#, 16#01EF3#), -- (Ll) LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE - (16#01EF4#, 16#01EF4#), -- (Lu) LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW - (16#01EF5#, 16#01EF5#), -- (Ll) LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW - (16#01EF6#, 16#01EF6#), -- (Lu) LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE - (16#01EF7#, 16#01EF7#), -- (Ll) LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE - (16#01EF8#, 16#01EF8#), -- (Lu) LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE - (16#01EF9#, 16#01EF9#), -- (Ll) LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE - (16#01F00#, 16#01F07#), -- (Ll) GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI - (16#01F08#, 16#01F0F#), -- (Lu) GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI - (16#01F10#, 16#01F15#), -- (Ll) GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA - (16#01F18#, 16#01F1D#), -- (Lu) GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA - (16#01F20#, 16#01F27#), -- (Ll) GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI - (16#01F28#, 16#01F2F#), -- (Lu) GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI - (16#01F30#, 16#01F37#), -- (Ll) GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI - (16#01F38#, 16#01F3F#), -- (Lu) GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI - (16#01F40#, 16#01F45#), -- (Ll) GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA - (16#01F48#, 16#01F4D#), -- (Lu) GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA - (16#01F50#, 16#01F57#), -- (Ll) GREEK SMALL LETTER UPSILON WITH PSILI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI - (16#01F59#, 16#01F59#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA - (16#01F5B#, 16#01F5B#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA - (16#01F5D#, 16#01F5D#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA - (16#01F5F#, 16#01F5F#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI - (16#01F60#, 16#01F67#), -- (Ll) GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI - (16#01F68#, 16#01F6F#), -- (Lu) GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI - (16#01F70#, 16#01F7D#), -- (Ll) GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA - (16#01F80#, 16#01F87#), -- (Ll) GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - (16#01F88#, 16#01F8F#), -- (Lt) GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - (16#01F90#, 16#01F97#), -- (Ll) GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - (16#01F98#, 16#01F9F#), -- (Lt) GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - (16#01FA0#, 16#01FA7#), -- (Ll) GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - (16#01FA8#, 16#01FAF#), -- (Lt) GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - (16#01FB0#, 16#01FB4#), -- (Ll) GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI - (16#01FB6#, 16#01FB7#), -- (Ll) GREEK SMALL LETTER ALPHA WITH PERISPOMENI .. GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI - (16#01FB8#, 16#01FBB#), -- (Lu) GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH OXIA - (16#01FBC#, 16#01FBC#), -- (Lt) GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI - (16#01FBD#, 16#01FBD#), -- (Sk) GREEK KORONIS .. GREEK KORONIS - (16#01FBE#, 16#01FBE#), -- (Ll) GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI - (16#01FBF#, 16#01FC1#), -- (Sk) GREEK PSILI .. GREEK DIALYTIKA AND PERISPOMENI - (16#01FC2#, 16#01FC4#), -- (Ll) GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI - (16#01FC6#, 16#01FC7#), -- (Ll) GREEK SMALL LETTER ETA WITH PERISPOMENI .. GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI - (16#01FC8#, 16#01FCB#), -- (Lu) GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA - (16#01FCC#, 16#01FCC#), -- (Lt) GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI - (16#01FCD#, 16#01FCF#), -- (Sk) GREEK PSILI AND VARIA .. GREEK PSILI AND PERISPOMENI - (16#01FD0#, 16#01FD3#), -- (Ll) GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA - (16#01FD6#, 16#01FD7#), -- (Ll) GREEK SMALL LETTER IOTA WITH PERISPOMENI .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI - (16#01FD8#, 16#01FDB#), -- (Lu) GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH OXIA - (16#01FDD#, 16#01FDF#), -- (Sk) GREEK DASIA AND VARIA .. GREEK DASIA AND PERISPOMENI - (16#01FE0#, 16#01FE7#), -- (Ll) GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI - (16#01FE8#, 16#01FEC#), -- (Lu) GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER RHO WITH DASIA - (16#01FED#, 16#01FEF#), -- (Sk) GREEK DIALYTIKA AND VARIA .. GREEK VARIA - (16#01FF2#, 16#01FF4#), -- (Ll) GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI - (16#01FF6#, 16#01FF7#), -- (Ll) GREEK SMALL LETTER OMEGA WITH PERISPOMENI .. GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI - (16#01FF8#, 16#01FFB#), -- (Lu) GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA - (16#01FFC#, 16#01FFC#), -- (Lt) GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI - (16#01FFD#, 16#01FFE#), -- (Sk) GREEK OXIA .. GREEK DASIA - (16#02000#, 16#0200B#), -- (Zs) EN QUAD .. ZERO WIDTH SPACE - (16#0200C#, 16#0200F#), -- (Cf) ZERO WIDTH NON-JOINER .. RIGHT-TO-LEFT MARK - (16#02010#, 16#02015#), -- (Pd) HYPHEN .. HORIZONTAL BAR - (16#02016#, 16#02017#), -- (Po) DOUBLE VERTICAL LINE .. DOUBLE LOW LINE - (16#02018#, 16#02018#), -- (Pi) LEFT SINGLE QUOTATION MARK .. LEFT SINGLE QUOTATION MARK - (16#02019#, 16#02019#), -- (Pf) RIGHT SINGLE QUOTATION MARK .. RIGHT SINGLE QUOTATION MARK - (16#0201A#, 16#0201A#), -- (Ps) SINGLE LOW-9 QUOTATION MARK .. SINGLE LOW-9 QUOTATION MARK - (16#0201B#, 16#0201C#), -- (Pi) SINGLE HIGH-REVERSED-9 QUOTATION MARK .. LEFT DOUBLE QUOTATION MARK - (16#0201D#, 16#0201D#), -- (Pf) RIGHT DOUBLE QUOTATION MARK .. RIGHT DOUBLE QUOTATION MARK - (16#0201E#, 16#0201E#), -- (Ps) DOUBLE LOW-9 QUOTATION MARK .. DOUBLE LOW-9 QUOTATION MARK - (16#0201F#, 16#0201F#), -- (Pi) DOUBLE HIGH-REVERSED-9 QUOTATION MARK .. DOUBLE HIGH-REVERSED-9 QUOTATION MARK - (16#02020#, 16#02027#), -- (Po) DAGGER .. HYPHENATION POINT - (16#02028#, 16#02028#), -- (Zl) LINE SEPARATOR .. LINE SEPARATOR - (16#02029#, 16#02029#), -- (Zp) PARAGRAPH SEPARATOR .. PARAGRAPH SEPARATOR - (16#0202A#, 16#0202E#), -- (Cf) LEFT-TO-RIGHT EMBEDDING .. RIGHT-TO-LEFT OVERRIDE - (16#0202F#, 16#0202F#), -- (Zs) NARROW NO-BREAK SPACE .. NARROW NO-BREAK SPACE - (16#02030#, 16#02038#), -- (Po) PER MILLE SIGN .. CARET - (16#02039#, 16#02039#), -- (Pi) SINGLE LEFT-POINTING ANGLE QUOTATION MARK .. SINGLE LEFT-POINTING ANGLE QUOTATION MARK - (16#0203A#, 16#0203A#), -- (Pf) SINGLE RIGHT-POINTING ANGLE QUOTATION MARK .. SINGLE RIGHT-POINTING ANGLE QUOTATION MARK - (16#0203B#, 16#0203E#), -- (Po) REFERENCE MARK .. OVERLINE - (16#0203F#, 16#02040#), -- (Pc) UNDERTIE .. CHARACTER TIE - (16#02041#, 16#02043#), -- (Po) CARET INSERTION POINT .. HYPHEN BULLET - (16#02044#, 16#02044#), -- (Sm) FRACTION SLASH .. FRACTION SLASH - (16#02045#, 16#02045#), -- (Ps) LEFT SQUARE BRACKET WITH QUILL .. LEFT SQUARE BRACKET WITH QUILL - (16#02046#, 16#02046#), -- (Pe) RIGHT SQUARE BRACKET WITH QUILL .. RIGHT SQUARE BRACKET WITH QUILL - (16#02047#, 16#02051#), -- (Po) DOUBLE QUESTION MARK .. TWO ASTERISKS ALIGNED VERTICALLY - (16#02052#, 16#02052#), -- (Sm) COMMERCIAL MINUS SIGN .. COMMERCIAL MINUS SIGN - (16#02053#, 16#02053#), -- (Po) SWUNG DASH .. SWUNG DASH - (16#02054#, 16#02054#), -- (Pc) INVERTED UNDERTIE .. INVERTED UNDERTIE - (16#02057#, 16#02057#), -- (Po) QUADRUPLE PRIME .. QUADRUPLE PRIME - (16#0205F#, 16#0205F#), -- (Zs) MEDIUM MATHEMATICAL SPACE .. MEDIUM MATHEMATICAL SPACE - (16#02060#, 16#02063#), -- (Cf) WORD JOINER .. INVISIBLE SEPARATOR - (16#0206A#, 16#0206F#), -- (Cf) INHIBIT SYMMETRIC SWAPPING .. NOMINAL DIGIT SHAPES - (16#02070#, 16#02070#), -- (No) SUPERSCRIPT ZERO .. SUPERSCRIPT ZERO - (16#02071#, 16#02071#), -- (Ll) SUPERSCRIPT LATIN SMALL LETTER I .. SUPERSCRIPT LATIN SMALL LETTER I - (16#02074#, 16#02079#), -- (No) SUPERSCRIPT FOUR .. SUPERSCRIPT NINE - (16#0207A#, 16#0207C#), -- (Sm) SUPERSCRIPT PLUS SIGN .. SUPERSCRIPT EQUALS SIGN - (16#0207D#, 16#0207D#), -- (Ps) SUPERSCRIPT LEFT PARENTHESIS .. SUPERSCRIPT LEFT PARENTHESIS - (16#0207E#, 16#0207E#), -- (Pe) SUPERSCRIPT RIGHT PARENTHESIS .. SUPERSCRIPT RIGHT PARENTHESIS - (16#0207F#, 16#0207F#), -- (Ll) SUPERSCRIPT LATIN SMALL LETTER N .. SUPERSCRIPT LATIN SMALL LETTER N - (16#02080#, 16#02089#), -- (No) SUBSCRIPT ZERO .. SUBSCRIPT NINE - (16#0208A#, 16#0208C#), -- (Sm) SUBSCRIPT PLUS SIGN .. SUBSCRIPT EQUALS SIGN - (16#0208D#, 16#0208D#), -- (Ps) SUBSCRIPT LEFT PARENTHESIS .. SUBSCRIPT LEFT PARENTHESIS - (16#0208E#, 16#0208E#), -- (Pe) SUBSCRIPT RIGHT PARENTHESIS .. SUBSCRIPT RIGHT PARENTHESIS - (16#020A0#, 16#020B1#), -- (Sc) EURO-CURRENCY SIGN .. PESO SIGN - (16#020D0#, 16#020DC#), -- (Mn) COMBINING LEFT HARPOON ABOVE .. COMBINING FOUR DOTS ABOVE - (16#020DD#, 16#020E0#), -- (Me) COMBINING ENCLOSING CIRCLE .. COMBINING ENCLOSING CIRCLE BACKSLASH - (16#020E1#, 16#020E1#), -- (Mn) COMBINING LEFT RIGHT ARROW ABOVE .. COMBINING LEFT RIGHT ARROW ABOVE - (16#020E2#, 16#020E4#), -- (Me) COMBINING ENCLOSING SCREEN .. COMBINING ENCLOSING UPWARD POINTING TRIANGLE - (16#020E5#, 16#020EA#), -- (Mn) COMBINING REVERSE SOLIDUS OVERLAY .. COMBINING LEFTWARDS ARROW OVERLAY - (16#02100#, 16#02101#), -- (So) ACCOUNT OF .. ADDRESSED TO THE SUBJECT - (16#02102#, 16#02102#), -- (Lu) DOUBLE-STRUCK CAPITAL C .. DOUBLE-STRUCK CAPITAL C - (16#02103#, 16#02106#), -- (So) DEGREE CELSIUS .. CADA UNA - (16#02107#, 16#02107#), -- (Lu) EULER CONSTANT .. EULER CONSTANT - (16#02108#, 16#02109#), -- (So) SCRUPLE .. DEGREE FAHRENHEIT - (16#0210A#, 16#0210A#), -- (Ll) SCRIPT SMALL G .. SCRIPT SMALL G - (16#0210B#, 16#0210D#), -- (Lu) SCRIPT CAPITAL H .. DOUBLE-STRUCK CAPITAL H - (16#0210E#, 16#0210F#), -- (Ll) PLANCK CONSTANT .. PLANCK CONSTANT OVER TWO PI - (16#02110#, 16#02112#), -- (Lu) SCRIPT CAPITAL I .. SCRIPT CAPITAL L - (16#02113#, 16#02113#), -- (Ll) SCRIPT SMALL L .. SCRIPT SMALL L - (16#02114#, 16#02114#), -- (So) L B BAR SYMBOL .. L B BAR SYMBOL - (16#02115#, 16#02115#), -- (Lu) DOUBLE-STRUCK CAPITAL N .. DOUBLE-STRUCK CAPITAL N - (16#02116#, 16#02118#), -- (So) NUMERO SIGN .. SCRIPT CAPITAL P - (16#02119#, 16#0211D#), -- (Lu) DOUBLE-STRUCK CAPITAL P .. DOUBLE-STRUCK CAPITAL R - (16#0211E#, 16#02123#), -- (So) PRESCRIPTION TAKE .. VERSICLE - (16#02124#, 16#02124#), -- (Lu) DOUBLE-STRUCK CAPITAL Z .. DOUBLE-STRUCK CAPITAL Z - (16#02125#, 16#02125#), -- (So) OUNCE SIGN .. OUNCE SIGN - (16#02126#, 16#02126#), -- (Lu) OHM SIGN .. OHM SIGN - (16#02127#, 16#02127#), -- (So) INVERTED OHM SIGN .. INVERTED OHM SIGN - (16#02128#, 16#02128#), -- (Lu) BLACK-LETTER CAPITAL Z .. BLACK-LETTER CAPITAL Z - (16#02129#, 16#02129#), -- (So) TURNED GREEK SMALL LETTER IOTA .. TURNED GREEK SMALL LETTER IOTA - (16#0212A#, 16#0212D#), -- (Lu) KELVIN SIGN .. BLACK-LETTER CAPITAL C - (16#0212E#, 16#0212E#), -- (So) ESTIMATED SYMBOL .. ESTIMATED SYMBOL - (16#0212F#, 16#0212F#), -- (Ll) SCRIPT SMALL E .. SCRIPT SMALL E - (16#02130#, 16#02131#), -- (Lu) SCRIPT CAPITAL E .. SCRIPT CAPITAL F - (16#02132#, 16#02132#), -- (So) TURNED CAPITAL F .. TURNED CAPITAL F - (16#02133#, 16#02133#), -- (Lu) SCRIPT CAPITAL M .. SCRIPT CAPITAL M - (16#02134#, 16#02134#), -- (Ll) SCRIPT SMALL O .. SCRIPT SMALL O - (16#02135#, 16#02138#), -- (Lo) ALEF SYMBOL .. DALET SYMBOL - (16#02139#, 16#02139#), -- (Ll) INFORMATION SOURCE .. INFORMATION SOURCE - (16#0213A#, 16#0213B#), -- (So) ROTATED CAPITAL Q .. FACSIMILE SIGN - (16#0213D#, 16#0213D#), -- (Ll) DOUBLE-STRUCK SMALL GAMMA .. DOUBLE-STRUCK SMALL GAMMA - (16#0213E#, 16#0213F#), -- (Lu) DOUBLE-STRUCK CAPITAL GAMMA .. DOUBLE-STRUCK CAPITAL PI - (16#02140#, 16#02144#), -- (Sm) DOUBLE-STRUCK N-ARY SUMMATION .. TURNED SANS-SERIF CAPITAL Y - (16#02145#, 16#02145#), -- (Lu) DOUBLE-STRUCK ITALIC CAPITAL D .. DOUBLE-STRUCK ITALIC CAPITAL D - (16#02146#, 16#02149#), -- (Ll) DOUBLE-STRUCK ITALIC SMALL D .. DOUBLE-STRUCK ITALIC SMALL J - (16#0214A#, 16#0214A#), -- (So) PROPERTY LINE .. PROPERTY LINE - (16#0214B#, 16#0214B#), -- (Sm) TURNED AMPERSAND .. TURNED AMPERSAND - (16#02153#, 16#0215F#), -- (No) VULGAR FRACTION ONE THIRD .. FRACTION NUMERATOR ONE - (16#02160#, 16#02183#), -- (Nl) ROMAN NUMERAL ONE .. ROMAN NUMERAL REVERSED ONE HUNDRED - (16#02190#, 16#02194#), -- (Sm) LEFTWARDS ARROW .. LEFT RIGHT ARROW - (16#02195#, 16#02199#), -- (So) UP DOWN ARROW .. SOUTH WEST ARROW - (16#0219A#, 16#0219B#), -- (Sm) LEFTWARDS ARROW WITH STROKE .. RIGHTWARDS ARROW WITH STROKE - (16#0219C#, 16#0219F#), -- (So) LEFTWARDS WAVE ARROW .. UPWARDS TWO HEADED ARROW - (16#021A0#, 16#021A0#), -- (Sm) RIGHTWARDS TWO HEADED ARROW .. RIGHTWARDS TWO HEADED ARROW - (16#021A1#, 16#021A2#), -- (So) DOWNWARDS TWO HEADED ARROW .. LEFTWARDS ARROW WITH TAIL - (16#021A3#, 16#021A3#), -- (Sm) RIGHTWARDS ARROW WITH TAIL .. RIGHTWARDS ARROW WITH TAIL - (16#021A4#, 16#021A5#), -- (So) LEFTWARDS ARROW FROM BAR .. UPWARDS ARROW FROM BAR - (16#021A6#, 16#021A6#), -- (Sm) RIGHTWARDS ARROW FROM BAR .. RIGHTWARDS ARROW FROM BAR - (16#021A7#, 16#021AD#), -- (So) DOWNWARDS ARROW FROM BAR .. LEFT RIGHT WAVE ARROW - (16#021AE#, 16#021AE#), -- (Sm) LEFT RIGHT ARROW WITH STROKE .. LEFT RIGHT ARROW WITH STROKE - (16#021AF#, 16#021CD#), -- (So) DOWNWARDS ZIGZAG ARROW .. LEFTWARDS DOUBLE ARROW WITH STROKE - (16#021CE#, 16#021CF#), -- (Sm) LEFT RIGHT DOUBLE ARROW WITH STROKE .. RIGHTWARDS DOUBLE ARROW WITH STROKE - (16#021D0#, 16#021D1#), -- (So) LEFTWARDS DOUBLE ARROW .. UPWARDS DOUBLE ARROW - (16#021D2#, 16#021D2#), -- (Sm) RIGHTWARDS DOUBLE ARROW .. RIGHTWARDS DOUBLE ARROW - (16#021D3#, 16#021D3#), -- (So) DOWNWARDS DOUBLE ARROW .. DOWNWARDS DOUBLE ARROW - (16#021D4#, 16#021D4#), -- (Sm) LEFT RIGHT DOUBLE ARROW .. LEFT RIGHT DOUBLE ARROW - (16#021D5#, 16#021F3#), -- (So) UP DOWN DOUBLE ARROW .. UP DOWN WHITE ARROW - (16#021F4#, 16#022FF#), -- (Sm) RIGHT ARROW WITH SMALL CIRCLE .. Z NOTATION BAG MEMBERSHIP - (16#02300#, 16#02307#), -- (So) DIAMETER SIGN .. WAVY LINE - (16#02308#, 16#0230B#), -- (Sm) LEFT CEILING .. RIGHT FLOOR - (16#0230C#, 16#0231F#), -- (So) BOTTOM RIGHT CROP .. BOTTOM RIGHT CORNER - (16#02320#, 16#02321#), -- (Sm) TOP HALF INTEGRAL .. BOTTOM HALF INTEGRAL - (16#02322#, 16#02328#), -- (So) FROWN .. KEYBOARD - (16#02329#, 16#02329#), -- (Ps) LEFT-POINTING ANGLE BRACKET .. LEFT-POINTING ANGLE BRACKET - (16#0232A#, 16#0232A#), -- (Pe) RIGHT-POINTING ANGLE BRACKET .. RIGHT-POINTING ANGLE BRACKET - (16#0232B#, 16#0237B#), -- (So) ERASE TO THE LEFT .. NOT CHECK MARK - (16#0237C#, 16#0237C#), -- (Sm) RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW .. RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW - (16#0237D#, 16#0239A#), -- (So) SHOULDERED OPEN BOX .. CLEAR SCREEN SYMBOL - (16#0239B#, 16#023B3#), -- (Sm) LEFT PARENTHESIS UPPER HOOK .. SUMMATION BOTTOM - (16#023B4#, 16#023B4#), -- (Ps) TOP SQUARE BRACKET .. TOP SQUARE BRACKET - (16#023B5#, 16#023B5#), -- (Pe) BOTTOM SQUARE BRACKET .. BOTTOM SQUARE BRACKET - (16#023B6#, 16#023B6#), -- (Po) BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET .. BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET - (16#023B7#, 16#023D0#), -- (So) RADICAL SYMBOL BOTTOM .. VERTICAL LINE EXTENSION - (16#02400#, 16#02426#), -- (So) SYMBOL FOR NULL .. SYMBOL FOR SUBSTITUTE FORM TWO - (16#02440#, 16#0244A#), -- (So) OCR HOOK .. OCR DOUBLE BACKSLASH - (16#02460#, 16#0249B#), -- (No) CIRCLED DIGIT ONE .. NUMBER TWENTY FULL STOP - (16#0249C#, 16#024E9#), -- (So) PARENTHESIZED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z - (16#024EA#, 16#024FF#), -- (No) CIRCLED DIGIT ZERO .. NEGATIVE CIRCLED DIGIT ZERO - (16#02500#, 16#025B6#), -- (So) BOX DRAWINGS LIGHT HORIZONTAL .. BLACK RIGHT-POINTING TRIANGLE - (16#025B7#, 16#025B7#), -- (Sm) WHITE RIGHT-POINTING TRIANGLE .. WHITE RIGHT-POINTING TRIANGLE - (16#025B8#, 16#025C0#), -- (So) BLACK RIGHT-POINTING SMALL TRIANGLE .. BLACK LEFT-POINTING TRIANGLE - (16#025C1#, 16#025C1#), -- (Sm) WHITE LEFT-POINTING TRIANGLE .. WHITE LEFT-POINTING TRIANGLE - (16#025C2#, 16#025F7#), -- (So) BLACK LEFT-POINTING SMALL TRIANGLE .. WHITE CIRCLE WITH UPPER RIGHT QUADRANT - (16#025F8#, 16#025FF#), -- (Sm) UPPER LEFT TRIANGLE .. LOWER RIGHT TRIANGLE - (16#02600#, 16#02617#), -- (So) BLACK SUN WITH RAYS .. BLACK SHOGI PIECE - (16#02619#, 16#0266E#), -- (So) REVERSED ROTATED FLORAL HEART BULLET .. MUSIC NATURAL SIGN - (16#0266F#, 16#0266F#), -- (Sm) MUSIC SHARP SIGN .. MUSIC SHARP SIGN - (16#02670#, 16#0267D#), -- (So) WEST SYRIAC CROSS .. PARTIALLY-RECYCLED PAPER SYMBOL - (16#02680#, 16#02691#), -- (So) DIE FACE-1 .. BLACK FLAG - (16#026A0#, 16#026A1#), -- (So) WARNING SIGN .. HIGH VOLTAGE SIGN - (16#02701#, 16#02704#), -- (So) UPPER BLADE SCISSORS .. WHITE SCISSORS - (16#02706#, 16#02709#), -- (So) TELEPHONE LOCATION SIGN .. ENVELOPE - (16#0270C#, 16#02727#), -- (So) VICTORY HAND .. WHITE FOUR POINTED STAR - (16#02729#, 16#0274B#), -- (So) STRESS OUTLINED WHITE STAR .. HEAVY EIGHT TEARDROP-SPOKED PROPELLER ASTERISK - (16#0274D#, 16#0274D#), -- (So) SHADOWED WHITE CIRCLE .. SHADOWED WHITE CIRCLE - (16#0274F#, 16#02752#), -- (So) LOWER RIGHT DROP-SHADOWED WHITE SQUARE .. UPPER RIGHT SHADOWED WHITE SQUARE - (16#02756#, 16#02756#), -- (So) BLACK DIAMOND MINUS WHITE X .. BLACK DIAMOND MINUS WHITE X - (16#02758#, 16#0275E#), -- (So) LIGHT VERTICAL BAR .. HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT - (16#02761#, 16#02767#), -- (So) CURVED STEM PARAGRAPH SIGN ORNAMENT .. ROTATED FLORAL HEART BULLET - (16#02768#, 16#02768#), -- (Ps) MEDIUM LEFT PARENTHESIS ORNAMENT .. MEDIUM LEFT PARENTHESIS ORNAMENT - (16#02769#, 16#02769#), -- (Pe) MEDIUM RIGHT PARENTHESIS ORNAMENT .. MEDIUM RIGHT PARENTHESIS ORNAMENT - (16#0276A#, 16#0276A#), -- (Ps) MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT - (16#0276B#, 16#0276B#), -- (Pe) MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT - (16#0276C#, 16#0276C#), -- (Ps) MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT - (16#0276D#, 16#0276D#), -- (Pe) MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT - (16#0276E#, 16#0276E#), -- (Ps) HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT - (16#0276F#, 16#0276F#), -- (Pe) HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT - (16#02770#, 16#02770#), -- (Ps) HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT - (16#02771#, 16#02771#), -- (Pe) HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT - (16#02772#, 16#02772#), -- (Ps) LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT - (16#02773#, 16#02773#), -- (Pe) LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT - (16#02774#, 16#02774#), -- (Ps) MEDIUM LEFT CURLY BRACKET ORNAMENT .. MEDIUM LEFT CURLY BRACKET ORNAMENT - (16#02775#, 16#02775#), -- (Pe) MEDIUM RIGHT CURLY BRACKET ORNAMENT .. MEDIUM RIGHT CURLY BRACKET ORNAMENT - (16#02776#, 16#02793#), -- (No) DINGBAT NEGATIVE CIRCLED DIGIT ONE .. DINGBAT NEGATIVE CIRCLED SANS-SERIF NUMBER TEN - (16#02794#, 16#02794#), -- (So) HEAVY WIDE-HEADED RIGHTWARDS ARROW .. HEAVY WIDE-HEADED RIGHTWARDS ARROW - (16#02798#, 16#027AF#), -- (So) HEAVY SOUTH EAST ARROW .. NOTCHED LOWER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW - (16#027B1#, 16#027BE#), -- (So) NOTCHED UPPER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW .. OPEN-OUTLINED RIGHTWARDS ARROW - (16#027D0#, 16#027E5#), -- (Sm) WHITE DIAMOND WITH CENTRED DOT .. WHITE SQUARE WITH RIGHTWARDS TICK - (16#027E6#, 16#027E6#), -- (Ps) MATHEMATICAL LEFT WHITE SQUARE BRACKET .. MATHEMATICAL LEFT WHITE SQUARE BRACKET - (16#027E7#, 16#027E7#), -- (Pe) MATHEMATICAL RIGHT WHITE SQUARE BRACKET .. MATHEMATICAL RIGHT WHITE SQUARE BRACKET - (16#027E8#, 16#027E8#), -- (Ps) MATHEMATICAL LEFT ANGLE BRACKET .. MATHEMATICAL LEFT ANGLE BRACKET - (16#027E9#, 16#027E9#), -- (Pe) MATHEMATICAL RIGHT ANGLE BRACKET .. MATHEMATICAL RIGHT ANGLE BRACKET - (16#027EA#, 16#027EA#), -- (Ps) MATHEMATICAL LEFT DOUBLE ANGLE BRACKET .. MATHEMATICAL LEFT DOUBLE ANGLE BRACKET - (16#027EB#, 16#027EB#), -- (Pe) MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET .. MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET - (16#027F0#, 16#027FF#), -- (Sm) UPWARDS QUADRUPLE ARROW .. LONG RIGHTWARDS SQUIGGLE ARROW - (16#02800#, 16#028FF#), -- (So) BRAILLE PATTERN BLANK .. BRAILLE PATTERN DOTS-12345678 - (16#02900#, 16#02982#), -- (Sm) RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE .. Z NOTATION TYPE COLON - (16#02983#, 16#02983#), -- (Ps) LEFT WHITE CURLY BRACKET .. LEFT WHITE CURLY BRACKET - (16#02984#, 16#02984#), -- (Pe) RIGHT WHITE CURLY BRACKET .. RIGHT WHITE CURLY BRACKET - (16#02985#, 16#02985#), -- (Ps) LEFT WHITE PARENTHESIS .. LEFT WHITE PARENTHESIS - (16#02986#, 16#02986#), -- (Pe) RIGHT WHITE PARENTHESIS .. RIGHT WHITE PARENTHESIS - (16#02987#, 16#02987#), -- (Ps) Z NOTATION LEFT IMAGE BRACKET .. Z NOTATION LEFT IMAGE BRACKET - (16#02988#, 16#02988#), -- (Pe) Z NOTATION RIGHT IMAGE BRACKET .. Z NOTATION RIGHT IMAGE BRACKET - (16#02989#, 16#02989#), -- (Ps) Z NOTATION LEFT BINDING BRACKET .. Z NOTATION LEFT BINDING BRACKET - (16#0298A#, 16#0298A#), -- (Pe) Z NOTATION RIGHT BINDING BRACKET .. Z NOTATION RIGHT BINDING BRACKET - (16#0298B#, 16#0298B#), -- (Ps) LEFT SQUARE BRACKET WITH UNDERBAR .. LEFT SQUARE BRACKET WITH UNDERBAR - (16#0298C#, 16#0298C#), -- (Pe) RIGHT SQUARE BRACKET WITH UNDERBAR .. RIGHT SQUARE BRACKET WITH UNDERBAR - (16#0298D#, 16#0298D#), -- (Ps) LEFT SQUARE BRACKET WITH TICK IN TOP CORNER .. LEFT SQUARE BRACKET WITH TICK IN TOP CORNER - (16#0298E#, 16#0298E#), -- (Pe) RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER - (16#0298F#, 16#0298F#), -- (Ps) LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER - (16#02990#, 16#02990#), -- (Pe) RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER .. RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER - (16#02991#, 16#02991#), -- (Ps) LEFT ANGLE BRACKET WITH DOT .. LEFT ANGLE BRACKET WITH DOT - (16#02992#, 16#02992#), -- (Pe) RIGHT ANGLE BRACKET WITH DOT .. RIGHT ANGLE BRACKET WITH DOT - (16#02993#, 16#02993#), -- (Ps) LEFT ARC LESS-THAN BRACKET .. LEFT ARC LESS-THAN BRACKET - (16#02994#, 16#02994#), -- (Pe) RIGHT ARC GREATER-THAN BRACKET .. RIGHT ARC GREATER-THAN BRACKET - (16#02995#, 16#02995#), -- (Ps) DOUBLE LEFT ARC GREATER-THAN BRACKET .. DOUBLE LEFT ARC GREATER-THAN BRACKET - (16#02996#, 16#02996#), -- (Pe) DOUBLE RIGHT ARC LESS-THAN BRACKET .. DOUBLE RIGHT ARC LESS-THAN BRACKET - (16#02997#, 16#02997#), -- (Ps) LEFT BLACK TORTOISE SHELL BRACKET .. LEFT BLACK TORTOISE SHELL BRACKET - (16#02998#, 16#02998#), -- (Pe) RIGHT BLACK TORTOISE SHELL BRACKET .. RIGHT BLACK TORTOISE SHELL BRACKET - (16#02999#, 16#029D7#), -- (Sm) DOTTED FENCE .. BLACK HOURGLASS - (16#029D8#, 16#029D8#), -- (Ps) LEFT WIGGLY FENCE .. LEFT WIGGLY FENCE - (16#029D9#, 16#029D9#), -- (Pe) RIGHT WIGGLY FENCE .. RIGHT WIGGLY FENCE - (16#029DA#, 16#029DA#), -- (Ps) LEFT DOUBLE WIGGLY FENCE .. LEFT DOUBLE WIGGLY FENCE - (16#029DB#, 16#029DB#), -- (Pe) RIGHT DOUBLE WIGGLY FENCE .. RIGHT DOUBLE WIGGLY FENCE - (16#029DC#, 16#029FB#), -- (Sm) INCOMPLETE INFINITY .. TRIPLE PLUS - (16#029FC#, 16#029FC#), -- (Ps) LEFT-POINTING CURVED ANGLE BRACKET .. LEFT-POINTING CURVED ANGLE BRACKET - (16#029FD#, 16#029FD#), -- (Pe) RIGHT-POINTING CURVED ANGLE BRACKET .. RIGHT-POINTING CURVED ANGLE BRACKET - (16#029FE#, 16#02AFF#), -- (Sm) TINY .. N-ARY WHITE VERTICAL BAR - (16#02B00#, 16#02B0D#), -- (So) NORTH EAST WHITE ARROW .. UP DOWN BLACK ARROW - (16#02E80#, 16#02E99#), -- (So) CJK RADICAL REPEAT .. CJK RADICAL RAP - (16#02E9B#, 16#02EF3#), -- (So) CJK RADICAL CHOKE .. CJK RADICAL C-SIMPLIFIED TURTLE - (16#02F00#, 16#02FD5#), -- (So) KANGXI RADICAL ONE .. KANGXI RADICAL FLUTE - (16#02FF0#, 16#02FFB#), -- (So) IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT .. IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID - (16#03000#, 16#03000#), -- (Zs) IDEOGRAPHIC SPACE .. IDEOGRAPHIC SPACE - (16#03001#, 16#03003#), -- (Po) IDEOGRAPHIC COMMA .. DITTO MARK - (16#03004#, 16#03004#), -- (So) JAPANESE INDUSTRIAL STANDARD SYMBOL .. JAPANESE INDUSTRIAL STANDARD SYMBOL - (16#03005#, 16#03005#), -- (Lm) IDEOGRAPHIC ITERATION MARK .. IDEOGRAPHIC ITERATION MARK - (16#03006#, 16#03006#), -- (Lo) IDEOGRAPHIC CLOSING MARK .. IDEOGRAPHIC CLOSING MARK - (16#03007#, 16#03007#), -- (Nl) IDEOGRAPHIC NUMBER ZERO .. IDEOGRAPHIC NUMBER ZERO - (16#03008#, 16#03008#), -- (Ps) LEFT ANGLE BRACKET .. LEFT ANGLE BRACKET - (16#03009#, 16#03009#), -- (Pe) RIGHT ANGLE BRACKET .. RIGHT ANGLE BRACKET - (16#0300A#, 16#0300A#), -- (Ps) LEFT DOUBLE ANGLE BRACKET .. LEFT DOUBLE ANGLE BRACKET - (16#0300B#, 16#0300B#), -- (Pe) RIGHT DOUBLE ANGLE BRACKET .. RIGHT DOUBLE ANGLE BRACKET - (16#0300C#, 16#0300C#), -- (Ps) LEFT CORNER BRACKET .. LEFT CORNER BRACKET - (16#0300D#, 16#0300D#), -- (Pe) RIGHT CORNER BRACKET .. RIGHT CORNER BRACKET - (16#0300E#, 16#0300E#), -- (Ps) LEFT WHITE CORNER BRACKET .. LEFT WHITE CORNER BRACKET - (16#0300F#, 16#0300F#), -- (Pe) RIGHT WHITE CORNER BRACKET .. RIGHT WHITE CORNER BRACKET - (16#03010#, 16#03010#), -- (Ps) LEFT BLACK LENTICULAR BRACKET .. LEFT BLACK LENTICULAR BRACKET - (16#03011#, 16#03011#), -- (Pe) RIGHT BLACK LENTICULAR BRACKET .. RIGHT BLACK LENTICULAR BRACKET - (16#03012#, 16#03013#), -- (So) POSTAL MARK .. GETA MARK - (16#03014#, 16#03014#), -- (Ps) LEFT TORTOISE SHELL BRACKET .. LEFT TORTOISE SHELL BRACKET - (16#03015#, 16#03015#), -- (Pe) RIGHT TORTOISE SHELL BRACKET .. RIGHT TORTOISE SHELL BRACKET - (16#03016#, 16#03016#), -- (Ps) LEFT WHITE LENTICULAR BRACKET .. LEFT WHITE LENTICULAR BRACKET - (16#03017#, 16#03017#), -- (Pe) RIGHT WHITE LENTICULAR BRACKET .. RIGHT WHITE LENTICULAR BRACKET - (16#03018#, 16#03018#), -- (Ps) LEFT WHITE TORTOISE SHELL BRACKET .. LEFT WHITE TORTOISE SHELL BRACKET - (16#03019#, 16#03019#), -- (Pe) RIGHT WHITE TORTOISE SHELL BRACKET .. RIGHT WHITE TORTOISE SHELL BRACKET - (16#0301A#, 16#0301A#), -- (Ps) LEFT WHITE SQUARE BRACKET .. LEFT WHITE SQUARE BRACKET - (16#0301B#, 16#0301B#), -- (Pe) RIGHT WHITE SQUARE BRACKET .. RIGHT WHITE SQUARE BRACKET - (16#0301C#, 16#0301C#), -- (Pd) WAVE DASH .. WAVE DASH - (16#0301D#, 16#0301D#), -- (Ps) REVERSED DOUBLE PRIME QUOTATION MARK .. REVERSED DOUBLE PRIME QUOTATION MARK - (16#0301E#, 16#0301F#), -- (Pe) DOUBLE PRIME QUOTATION MARK .. LOW DOUBLE PRIME QUOTATION MARK - (16#03020#, 16#03020#), -- (So) POSTAL MARK FACE .. POSTAL MARK FACE - (16#03021#, 16#03029#), -- (Nl) HANGZHOU NUMERAL ONE .. HANGZHOU NUMERAL NINE - (16#0302A#, 16#0302F#), -- (Mn) IDEOGRAPHIC LEVEL TONE MARK .. HANGUL DOUBLE DOT TONE MARK - (16#03030#, 16#03030#), -- (Pd) WAVY DASH .. WAVY DASH - (16#03031#, 16#03035#), -- (Lm) VERTICAL KANA REPEAT MARK .. VERTICAL KANA REPEAT MARK LOWER HALF - (16#03036#, 16#03037#), -- (So) CIRCLED POSTAL MARK .. IDEOGRAPHIC TELEGRAPH LINE FEED SEPARATOR SYMBOL - (16#03038#, 16#0303A#), -- (Nl) HANGZHOU NUMERAL TEN .. HANGZHOU NUMERAL THIRTY - (16#0303B#, 16#0303B#), -- (Lm) VERTICAL IDEOGRAPHIC ITERATION MARK .. VERTICAL IDEOGRAPHIC ITERATION MARK - (16#0303C#, 16#0303C#), -- (Lo) MASU MARK .. MASU MARK - (16#0303D#, 16#0303D#), -- (Po) PART ALTERNATION MARK .. PART ALTERNATION MARK - (16#0303E#, 16#0303F#), -- (So) IDEOGRAPHIC VARIATION INDICATOR .. IDEOGRAPHIC HALF FILL SPACE - (16#03041#, 16#03096#), -- (Lo) HIRAGANA LETTER SMALL A .. HIRAGANA LETTER SMALL KE - (16#03099#, 16#0309A#), -- (Mn) COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK .. COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK - (16#0309B#, 16#0309C#), -- (Sk) KATAKANA-HIRAGANA VOICED SOUND MARK .. KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK - (16#0309D#, 16#0309E#), -- (Lm) HIRAGANA ITERATION MARK .. HIRAGANA VOICED ITERATION MARK - (16#0309F#, 16#0309F#), -- (Lo) HIRAGANA DIGRAPH YORI .. HIRAGANA DIGRAPH YORI - (16#030A0#, 16#030A0#), -- (Pd) KATAKANA-HIRAGANA DOUBLE HYPHEN .. KATAKANA-HIRAGANA DOUBLE HYPHEN - (16#030A1#, 16#030FA#), -- (Lo) KATAKANA LETTER SMALL A .. KATAKANA LETTER VO - (16#030FB#, 16#030FB#), -- (Pc) KATAKANA MIDDLE DOT .. KATAKANA MIDDLE DOT - (16#030FC#, 16#030FE#), -- (Lm) KATAKANA-HIRAGANA PROLONGED SOUND MARK .. KATAKANA VOICED ITERATION MARK - (16#030FF#, 16#030FF#), -- (Lo) KATAKANA DIGRAPH KOTO .. KATAKANA DIGRAPH KOTO - (16#03105#, 16#0312C#), -- (Lo) BOPOMOFO LETTER B .. BOPOMOFO LETTER GN - (16#03131#, 16#0318E#), -- (Lo) HANGUL LETTER KIYEOK .. HANGUL LETTER ARAEAE - (16#03190#, 16#03191#), -- (So) IDEOGRAPHIC ANNOTATION LINKING MARK .. IDEOGRAPHIC ANNOTATION REVERSE MARK - (16#03192#, 16#03195#), -- (No) IDEOGRAPHIC ANNOTATION ONE MARK .. IDEOGRAPHIC ANNOTATION FOUR MARK - (16#03196#, 16#0319F#), -- (So) IDEOGRAPHIC ANNOTATION TOP MARK .. IDEOGRAPHIC ANNOTATION MAN MARK - (16#031A0#, 16#031B7#), -- (Lo) BOPOMOFO LETTER BU .. BOPOMOFO FINAL LETTER H - (16#031F0#, 16#031FF#), -- (Lo) KATAKANA LETTER SMALL KU .. KATAKANA LETTER SMALL RO - (16#03200#, 16#0321E#), -- (So) PARENTHESIZED HANGUL KIYEOK .. PARENTHESIZED KOREAN CHARACTER O HU - (16#03220#, 16#03229#), -- (No) PARENTHESIZED IDEOGRAPH ONE .. PARENTHESIZED IDEOGRAPH TEN - (16#0322A#, 16#03243#), -- (So) PARENTHESIZED IDEOGRAPH MOON .. PARENTHESIZED IDEOGRAPH REACH - (16#03250#, 16#03250#), -- (So) PARTNERSHIP SIGN .. PARTNERSHIP SIGN - (16#03251#, 16#0325F#), -- (No) CIRCLED NUMBER TWENTY ONE .. CIRCLED NUMBER THIRTY FIVE - (16#03260#, 16#0327D#), -- (So) CIRCLED HANGUL KIYEOK .. CIRCLED KOREAN CHARACTER JUEUI - (16#0327F#, 16#0327F#), -- (So) KOREAN STANDARD SYMBOL .. KOREAN STANDARD SYMBOL - (16#03280#, 16#03289#), -- (No) CIRCLED IDEOGRAPH ONE .. CIRCLED IDEOGRAPH TEN - (16#0328A#, 16#032B0#), -- (So) CIRCLED IDEOGRAPH MOON .. CIRCLED IDEOGRAPH NIGHT - (16#032B1#, 16#032BF#), -- (No) CIRCLED NUMBER THIRTY SIX .. CIRCLED NUMBER FIFTY - (16#032C0#, 16#032FE#), -- (So) IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY .. CIRCLED KATAKANA WO - (16#03300#, 16#033FF#), -- (So) SQUARE APAATO .. SQUARE GAL - (16#03400#, 16#04DB5#), -- (Lo) .. - (16#04DC0#, 16#04DFF#), -- (So) HEXAGRAM FOR THE CREATIVE HEAVEN .. HEXAGRAM FOR BEFORE COMPLETION - (16#04E00#, 16#09FA5#), -- (Lo) .. - (16#0A000#, 16#0A48C#), -- (Lo) YI SYLLABLE IT .. YI SYLLABLE YYR - (16#0A490#, 16#0A4C6#), -- (So) YI RADICAL QOT .. YI RADICAL KE - (16#0AC00#, 16#0D7A3#), -- (Lo) .. - (16#0D800#, 16#0F8FF#), -- (Cs) .. - (16#0F900#, 16#0FA2D#), -- (Lo) CJK COMPATIBILITY IDEOGRAPH-F900 .. CJK COMPATIBILITY IDEOGRAPH-FA2D - (16#0FA30#, 16#0FA6A#), -- (Lo) CJK COMPATIBILITY IDEOGRAPH-FA30 .. CJK COMPATIBILITY IDEOGRAPH-FA6A - (16#0FB00#, 16#0FB06#), -- (Ll) LATIN SMALL LIGATURE FF .. LATIN SMALL LIGATURE ST - (16#0FB13#, 16#0FB17#), -- (Ll) ARMENIAN SMALL LIGATURE MEN NOW .. ARMENIAN SMALL LIGATURE MEN XEH - (16#0FB1D#, 16#0FB1D#), -- (Lo) HEBREW LETTER YOD WITH HIRIQ .. HEBREW LETTER YOD WITH HIRIQ - (16#0FB1E#, 16#0FB1E#), -- (Mn) HEBREW POINT JUDEO-SPANISH VARIKA .. HEBREW POINT JUDEO-SPANISH VARIKA - (16#0FB1F#, 16#0FB28#), -- (Lo) HEBREW LIGATURE YIDDISH YOD YOD PATAH .. HEBREW LETTER WIDE TAV - (16#0FB29#, 16#0FB29#), -- (Sm) HEBREW LETTER ALTERNATIVE PLUS SIGN .. HEBREW LETTER ALTERNATIVE PLUS SIGN - (16#0FB2A#, 16#0FB36#), -- (Lo) HEBREW LETTER SHIN WITH SHIN DOT .. HEBREW LETTER ZAYIN WITH DAGESH - (16#0FB38#, 16#0FB3C#), -- (Lo) HEBREW LETTER TET WITH DAGESH .. HEBREW LETTER LAMED WITH DAGESH - (16#0FB3E#, 16#0FB3E#), -- (Lo) HEBREW LETTER MEM WITH DAGESH .. HEBREW LETTER MEM WITH DAGESH - (16#0FB40#, 16#0FB41#), -- (Lo) HEBREW LETTER NUN WITH DAGESH .. HEBREW LETTER SAMEKH WITH DAGESH - (16#0FB43#, 16#0FB44#), -- (Lo) HEBREW LETTER FINAL PE WITH DAGESH .. HEBREW LETTER PE WITH DAGESH - (16#0FB46#, 16#0FBB1#), -- (Lo) HEBREW LETTER TSADI WITH DAGESH .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM - (16#0FBD3#, 16#0FD3D#), -- (Lo) ARABIC LETTER NG ISOLATED FORM .. ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM - (16#0FD3E#, 16#0FD3E#), -- (Ps) ORNATE LEFT PARENTHESIS .. ORNATE LEFT PARENTHESIS - (16#0FD3F#, 16#0FD3F#), -- (Pe) ORNATE RIGHT PARENTHESIS .. ORNATE RIGHT PARENTHESIS - (16#0FD50#, 16#0FD8F#), -- (Lo) ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM .. ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM - (16#0FD92#, 16#0FDC7#), -- (Lo) ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM .. ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM - (16#0FDF0#, 16#0FDFB#), -- (Lo) ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM .. ARABIC LIGATURE JALLAJALALOUHOU - (16#0FDFC#, 16#0FDFC#), -- (Sc) RIAL SIGN .. RIAL SIGN - (16#0FDFD#, 16#0FDFD#), -- (So) ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM .. ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM - (16#0FE00#, 16#0FE0F#), -- (Mn) VARIATION SELECTOR-1 .. VARIATION SELECTOR-16 - (16#0FE20#, 16#0FE23#), -- (Mn) COMBINING LIGATURE LEFT HALF .. COMBINING DOUBLE TILDE RIGHT HALF - (16#0FE30#, 16#0FE30#), -- (Po) PRESENTATION FORM FOR VERTICAL TWO DOT LEADER .. PRESENTATION FORM FOR VERTICAL TWO DOT LEADER - (16#0FE31#, 16#0FE32#), -- (Pd) PRESENTATION FORM FOR VERTICAL EM DASH .. PRESENTATION FORM FOR VERTICAL EN DASH - (16#0FE33#, 16#0FE34#), -- (Pc) PRESENTATION FORM FOR VERTICAL LOW LINE .. PRESENTATION FORM FOR VERTICAL WAVY LOW LINE - (16#0FE35#, 16#0FE35#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS - (16#0FE36#, 16#0FE36#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS - (16#0FE37#, 16#0FE37#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET - (16#0FE38#, 16#0FE38#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET - (16#0FE39#, 16#0FE39#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET - (16#0FE3A#, 16#0FE3A#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET - (16#0FE3B#, 16#0FE3B#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET - (16#0FE3C#, 16#0FE3C#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET - (16#0FE3D#, 16#0FE3D#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET - (16#0FE3E#, 16#0FE3E#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET - (16#0FE3F#, 16#0FE3F#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET - (16#0FE40#, 16#0FE40#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET - (16#0FE41#, 16#0FE41#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET - (16#0FE42#, 16#0FE42#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET - (16#0FE43#, 16#0FE43#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET - (16#0FE44#, 16#0FE44#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET - (16#0FE45#, 16#0FE46#), -- (Po) SESAME DOT .. WHITE SESAME DOT - (16#0FE47#, 16#0FE47#), -- (Ps) PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET - (16#0FE48#, 16#0FE48#), -- (Pe) PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET - (16#0FE49#, 16#0FE4C#), -- (Po) DASHED OVERLINE .. DOUBLE WAVY OVERLINE - (16#0FE4D#, 16#0FE4F#), -- (Pc) DASHED LOW LINE .. WAVY LOW LINE - (16#0FE50#, 16#0FE52#), -- (Po) SMALL COMMA .. SMALL FULL STOP - (16#0FE54#, 16#0FE57#), -- (Po) SMALL SEMICOLON .. SMALL EXCLAMATION MARK - (16#0FE58#, 16#0FE58#), -- (Pd) SMALL EM DASH .. SMALL EM DASH - (16#0FE59#, 16#0FE59#), -- (Ps) SMALL LEFT PARENTHESIS .. SMALL LEFT PARENTHESIS - (16#0FE5A#, 16#0FE5A#), -- (Pe) SMALL RIGHT PARENTHESIS .. SMALL RIGHT PARENTHESIS - (16#0FE5B#, 16#0FE5B#), -- (Ps) SMALL LEFT CURLY BRACKET .. SMALL LEFT CURLY BRACKET - (16#0FE5C#, 16#0FE5C#), -- (Pe) SMALL RIGHT CURLY BRACKET .. SMALL RIGHT CURLY BRACKET - (16#0FE5D#, 16#0FE5D#), -- (Ps) SMALL LEFT TORTOISE SHELL BRACKET .. SMALL LEFT TORTOISE SHELL BRACKET - (16#0FE5E#, 16#0FE5E#), -- (Pe) SMALL RIGHT TORTOISE SHELL BRACKET .. SMALL RIGHT TORTOISE SHELL BRACKET - (16#0FE5F#, 16#0FE61#), -- (Po) SMALL NUMBER SIGN .. SMALL ASTERISK - (16#0FE62#, 16#0FE62#), -- (Sm) SMALL PLUS SIGN .. SMALL PLUS SIGN - (16#0FE63#, 16#0FE63#), -- (Pd) SMALL HYPHEN-MINUS .. SMALL HYPHEN-MINUS - (16#0FE64#, 16#0FE66#), -- (Sm) SMALL LESS-THAN SIGN .. SMALL EQUALS SIGN - (16#0FE68#, 16#0FE68#), -- (Po) SMALL REVERSE SOLIDUS .. SMALL REVERSE SOLIDUS - (16#0FE69#, 16#0FE69#), -- (Sc) SMALL DOLLAR SIGN .. SMALL DOLLAR SIGN - (16#0FE6A#, 16#0FE6B#), -- (Po) SMALL PERCENT SIGN .. SMALL COMMERCIAL AT - (16#0FE70#, 16#0FE74#), -- (Lo) ARABIC FATHATAN ISOLATED FORM .. ARABIC KASRATAN ISOLATED FORM - (16#0FE76#, 16#0FEFC#), -- (Lo) ARABIC FATHA ISOLATED FORM .. ARABIC LIGATURE LAM WITH ALEF FINAL FORM - (16#0FEFF#, 16#0FEFF#), -- (Cf) ZERO WIDTH NO-BREAK SPACE .. ZERO WIDTH NO-BREAK SPACE - (16#0FF01#, 16#0FF03#), -- (Po) FULLWIDTH EXCLAMATION MARK .. FULLWIDTH NUMBER SIGN - (16#0FF04#, 16#0FF04#), -- (Sc) FULLWIDTH DOLLAR SIGN .. FULLWIDTH DOLLAR SIGN - (16#0FF05#, 16#0FF07#), -- (Po) FULLWIDTH PERCENT SIGN .. FULLWIDTH APOSTROPHE - (16#0FF08#, 16#0FF08#), -- (Ps) FULLWIDTH LEFT PARENTHESIS .. FULLWIDTH LEFT PARENTHESIS - (16#0FF09#, 16#0FF09#), -- (Pe) FULLWIDTH RIGHT PARENTHESIS .. FULLWIDTH RIGHT PARENTHESIS - (16#0FF0A#, 16#0FF0A#), -- (Po) FULLWIDTH ASTERISK .. FULLWIDTH ASTERISK - (16#0FF0B#, 16#0FF0B#), -- (Sm) FULLWIDTH PLUS SIGN .. FULLWIDTH PLUS SIGN - (16#0FF0C#, 16#0FF0C#), -- (Po) FULLWIDTH COMMA .. FULLWIDTH COMMA - (16#0FF0D#, 16#0FF0D#), -- (Pd) FULLWIDTH HYPHEN-MINUS .. FULLWIDTH HYPHEN-MINUS - (16#0FF0E#, 16#0FF0F#), -- (Po) FULLWIDTH FULL STOP .. FULLWIDTH SOLIDUS - (16#0FF10#, 16#0FF19#), -- (Nd) FULLWIDTH DIGIT ZERO .. FULLWIDTH DIGIT NINE - (16#0FF1A#, 16#0FF1B#), -- (Po) FULLWIDTH COLON .. FULLWIDTH SEMICOLON - (16#0FF1C#, 16#0FF1E#), -- (Sm) FULLWIDTH LESS-THAN SIGN .. FULLWIDTH GREATER-THAN SIGN - (16#0FF1F#, 16#0FF20#), -- (Po) FULLWIDTH QUESTION MARK .. FULLWIDTH COMMERCIAL AT - (16#0FF21#, 16#0FF3A#), -- (Lu) FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z - (16#0FF3B#, 16#0FF3B#), -- (Ps) FULLWIDTH LEFT SQUARE BRACKET .. FULLWIDTH LEFT SQUARE BRACKET - (16#0FF3C#, 16#0FF3C#), -- (Po) FULLWIDTH REVERSE SOLIDUS .. FULLWIDTH REVERSE SOLIDUS - (16#0FF3D#, 16#0FF3D#), -- (Pe) FULLWIDTH RIGHT SQUARE BRACKET .. FULLWIDTH RIGHT SQUARE BRACKET - (16#0FF3E#, 16#0FF3E#), -- (Sk) FULLWIDTH CIRCUMFLEX ACCENT .. FULLWIDTH CIRCUMFLEX ACCENT - (16#0FF3F#, 16#0FF3F#), -- (Pc) FULLWIDTH LOW LINE .. FULLWIDTH LOW LINE - (16#0FF40#, 16#0FF40#), -- (Sk) FULLWIDTH GRAVE ACCENT .. FULLWIDTH GRAVE ACCENT - (16#0FF41#, 16#0FF5A#), -- (Ll) FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z - (16#0FF5B#, 16#0FF5B#), -- (Ps) FULLWIDTH LEFT CURLY BRACKET .. FULLWIDTH LEFT CURLY BRACKET - (16#0FF5C#, 16#0FF5C#), -- (Sm) FULLWIDTH VERTICAL LINE .. FULLWIDTH VERTICAL LINE - (16#0FF5D#, 16#0FF5D#), -- (Pe) FULLWIDTH RIGHT CURLY BRACKET .. FULLWIDTH RIGHT CURLY BRACKET - (16#0FF5E#, 16#0FF5E#), -- (Sm) FULLWIDTH TILDE .. FULLWIDTH TILDE - (16#0FF5F#, 16#0FF5F#), -- (Ps) FULLWIDTH LEFT WHITE PARENTHESIS .. FULLWIDTH LEFT WHITE PARENTHESIS - (16#0FF60#, 16#0FF60#), -- (Pe) FULLWIDTH RIGHT WHITE PARENTHESIS .. FULLWIDTH RIGHT WHITE PARENTHESIS - (16#0FF61#, 16#0FF61#), -- (Po) HALFWIDTH IDEOGRAPHIC FULL STOP .. HALFWIDTH IDEOGRAPHIC FULL STOP - (16#0FF62#, 16#0FF62#), -- (Ps) HALFWIDTH LEFT CORNER BRACKET .. HALFWIDTH LEFT CORNER BRACKET - (16#0FF63#, 16#0FF63#), -- (Pe) HALFWIDTH RIGHT CORNER BRACKET .. HALFWIDTH RIGHT CORNER BRACKET - (16#0FF64#, 16#0FF64#), -- (Po) HALFWIDTH IDEOGRAPHIC COMMA .. HALFWIDTH IDEOGRAPHIC COMMA - (16#0FF65#, 16#0FF65#), -- (Pc) HALFWIDTH KATAKANA MIDDLE DOT .. HALFWIDTH KATAKANA MIDDLE DOT - (16#0FF66#, 16#0FF6F#), -- (Lo) HALFWIDTH KATAKANA LETTER WO .. HALFWIDTH KATAKANA LETTER SMALL TU - (16#0FF70#, 16#0FF70#), -- (Lm) HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK .. HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK - (16#0FF71#, 16#0FF9D#), -- (Lo) HALFWIDTH KATAKANA LETTER A .. HALFWIDTH KATAKANA LETTER N - (16#0FF9E#, 16#0FF9F#), -- (Lm) HALFWIDTH KATAKANA VOICED SOUND MARK .. HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK - (16#0FFA0#, 16#0FFBE#), -- (Lo) HALFWIDTH HANGUL FILLER .. HALFWIDTH HANGUL LETTER HIEUH - (16#0FFC2#, 16#0FFC7#), -- (Lo) HALFWIDTH HANGUL LETTER A .. HALFWIDTH HANGUL LETTER E - (16#0FFCA#, 16#0FFCF#), -- (Lo) HALFWIDTH HANGUL LETTER YEO .. HALFWIDTH HANGUL LETTER OE - (16#0FFD2#, 16#0FFD7#), -- (Lo) HALFWIDTH HANGUL LETTER YO .. HALFWIDTH HANGUL LETTER YU - (16#0FFDA#, 16#0FFDC#), -- (Lo) HALFWIDTH HANGUL LETTER EU .. HALFWIDTH HANGUL LETTER I - (16#0FFE0#, 16#0FFE1#), -- (Sc) FULLWIDTH CENT SIGN .. FULLWIDTH POUND SIGN - (16#0FFE2#, 16#0FFE2#), -- (Sm) FULLWIDTH NOT SIGN .. FULLWIDTH NOT SIGN - (16#0FFE3#, 16#0FFE3#), -- (Sk) FULLWIDTH MACRON .. FULLWIDTH MACRON - (16#0FFE4#, 16#0FFE4#), -- (So) FULLWIDTH BROKEN BAR .. FULLWIDTH BROKEN BAR - (16#0FFE5#, 16#0FFE6#), -- (Sc) FULLWIDTH YEN SIGN .. FULLWIDTH WON SIGN - (16#0FFE8#, 16#0FFE8#), -- (So) HALFWIDTH FORMS LIGHT VERTICAL .. HALFWIDTH FORMS LIGHT VERTICAL - (16#0FFE9#, 16#0FFEC#), -- (Sm) HALFWIDTH LEFTWARDS ARROW .. HALFWIDTH DOWNWARDS ARROW - (16#0FFED#, 16#0FFEE#), -- (So) HALFWIDTH BLACK SQUARE .. HALFWIDTH WHITE CIRCLE - (16#0FFF9#, 16#0FFFB#), -- (Cf) INTERLINEAR ANNOTATION ANCHOR .. INTERLINEAR ANNOTATION TERMINATOR - (16#0FFFC#, 16#0FFFD#), -- (So) OBJECT REPLACEMENT CHARACTER .. REPLACEMENT CHARACTER - (16#10000#, 16#1000B#), -- (Lo) LINEAR B SYLLABLE B008 A .. LINEAR B SYLLABLE B046 JE - (16#1000D#, 16#10026#), -- (Lo) LINEAR B SYLLABLE B036 JO .. LINEAR B SYLLABLE B032 QO - (16#10028#, 16#1003A#), -- (Lo) LINEAR B SYLLABLE B060 RA .. LINEAR B SYLLABLE B042 WO - (16#1003C#, 16#1003D#), -- (Lo) LINEAR B SYLLABLE B017 ZA .. LINEAR B SYLLABLE B074 ZE - (16#1003F#, 16#1004D#), -- (Lo) LINEAR B SYLLABLE B020 ZO .. LINEAR B SYLLABLE B091 TWO - (16#10050#, 16#1005D#), -- (Lo) LINEAR B SYMBOL B018 .. LINEAR B SYMBOL B089 - (16#10080#, 16#100FA#), -- (Lo) LINEAR B IDEOGRAM B100 MAN .. LINEAR B IDEOGRAM VESSEL B305 - (16#10100#, 16#10101#), -- (Po) AEGEAN WORD SEPARATOR LINE .. AEGEAN WORD SEPARATOR DOT - (16#10102#, 16#10102#), -- (So) AEGEAN CHECK MARK .. AEGEAN CHECK MARK - (16#10107#, 16#10133#), -- (No) AEGEAN NUMBER ONE .. AEGEAN NUMBER NINETY THOUSAND - (16#10137#, 16#1013F#), -- (So) AEGEAN WEIGHT BASE UNIT .. AEGEAN MEASURE THIRD SUBUNIT - (16#10300#, 16#1031E#), -- (Lo) OLD ITALIC LETTER A .. OLD ITALIC LETTER UU - (16#10320#, 16#10323#), -- (No) OLD ITALIC NUMERAL ONE .. OLD ITALIC NUMERAL FIFTY - (16#10330#, 16#10349#), -- (Lo) GOTHIC LETTER AHSA .. GOTHIC LETTER OTHAL - (16#1034A#, 16#1034A#), -- (Nl) GOTHIC LETTER NINE HUNDRED .. GOTHIC LETTER NINE HUNDRED - (16#10380#, 16#1039D#), -- (Lo) UGARITIC LETTER ALPA .. UGARITIC LETTER SSU - (16#1039F#, 16#1039F#), -- (Po) UGARITIC WORD DIVIDER .. UGARITIC WORD DIVIDER - (16#10400#, 16#10427#), -- (Lu) DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW - (16#10428#, 16#1044F#), -- (Ll) DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW - (16#10450#, 16#1049D#), -- (Lo) SHAVIAN LETTER PEEP .. OSMANYA LETTER OO - (16#104A0#, 16#104A9#), -- (Nd) OSMANYA DIGIT ZERO .. OSMANYA DIGIT NINE - (16#10800#, 16#10805#), -- (Lo) CYPRIOT SYLLABLE A .. CYPRIOT SYLLABLE JA - (16#10808#, 16#10808#), -- (Lo) CYPRIOT SYLLABLE JO .. CYPRIOT SYLLABLE JO - (16#1080A#, 16#10835#), -- (Lo) CYPRIOT SYLLABLE KA .. CYPRIOT SYLLABLE WO - (16#10837#, 16#10838#), -- (Lo) CYPRIOT SYLLABLE XA .. CYPRIOT SYLLABLE XE - (16#1083C#, 16#1083C#), -- (Lo) CYPRIOT SYLLABLE ZA .. CYPRIOT SYLLABLE ZA - (16#1083F#, 16#1083F#), -- (Lo) CYPRIOT SYLLABLE ZO .. CYPRIOT SYLLABLE ZO - (16#1D000#, 16#1D0F5#), -- (So) BYZANTINE MUSICAL SYMBOL PSILI .. BYZANTINE MUSICAL SYMBOL GORGON NEO KATO - (16#1D100#, 16#1D126#), -- (So) MUSICAL SYMBOL SINGLE BARLINE .. MUSICAL SYMBOL DRUM CLEF-2 - (16#1D12A#, 16#1D164#), -- (So) MUSICAL SYMBOL DOUBLE SHARP .. MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE - (16#1D165#, 16#1D166#), -- (Mc) MUSICAL SYMBOL COMBINING STEM .. MUSICAL SYMBOL COMBINING SPRECHGESANG STEM - (16#1D167#, 16#1D169#), -- (Mn) MUSICAL SYMBOL COMBINING TREMOLO-1 .. MUSICAL SYMBOL COMBINING TREMOLO-3 - (16#1D16A#, 16#1D16C#), -- (So) MUSICAL SYMBOL FINGERED TREMOLO-1 .. MUSICAL SYMBOL FINGERED TREMOLO-3 - (16#1D16D#, 16#1D172#), -- (Mc) MUSICAL SYMBOL COMBINING AUGMENTATION DOT .. MUSICAL SYMBOL COMBINING FLAG-5 - (16#1D173#, 16#1D17A#), -- (Cf) MUSICAL SYMBOL BEGIN BEAM .. MUSICAL SYMBOL END PHRASE - (16#1D17B#, 16#1D182#), -- (Mn) MUSICAL SYMBOL COMBINING ACCENT .. MUSICAL SYMBOL COMBINING LOURE - (16#1D183#, 16#1D184#), -- (So) MUSICAL SYMBOL ARPEGGIATO UP .. MUSICAL SYMBOL ARPEGGIATO DOWN - (16#1D185#, 16#1D18B#), -- (Mn) MUSICAL SYMBOL COMBINING DOIT .. MUSICAL SYMBOL COMBINING TRIPLE TONGUE - (16#1D18C#, 16#1D1A9#), -- (So) MUSICAL SYMBOL RINFORZANDO .. MUSICAL SYMBOL DEGREE SLASH - (16#1D1AA#, 16#1D1AD#), -- (Mn) MUSICAL SYMBOL COMBINING DOWN BOW .. MUSICAL SYMBOL COMBINING SNAP PIZZICATO - (16#1D1AE#, 16#1D1DD#), -- (So) MUSICAL SYMBOL PEDAL MARK .. MUSICAL SYMBOL PES SUBPUNCTIS - (16#1D300#, 16#1D356#), -- (So) MONOGRAM FOR EARTH .. TETRAGRAM FOR FOSTERING - (16#1D400#, 16#1D419#), -- (Lu) MATHEMATICAL BOLD CAPITAL A .. MATHEMATICAL BOLD CAPITAL Z - (16#1D41A#, 16#1D433#), -- (Ll) MATHEMATICAL BOLD SMALL A .. MATHEMATICAL BOLD SMALL Z - (16#1D434#, 16#1D44D#), -- (Lu) MATHEMATICAL ITALIC CAPITAL A .. MATHEMATICAL ITALIC CAPITAL Z - (16#1D44E#, 16#1D454#), -- (Ll) MATHEMATICAL ITALIC SMALL A .. MATHEMATICAL ITALIC SMALL G - (16#1D456#, 16#1D467#), -- (Ll) MATHEMATICAL ITALIC SMALL I .. MATHEMATICAL ITALIC SMALL Z - (16#1D468#, 16#1D481#), -- (Lu) MATHEMATICAL BOLD ITALIC CAPITAL A .. MATHEMATICAL BOLD ITALIC CAPITAL Z - (16#1D482#, 16#1D49B#), -- (Ll) MATHEMATICAL BOLD ITALIC SMALL A .. MATHEMATICAL BOLD ITALIC SMALL Z - (16#1D49C#, 16#1D49C#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL A .. MATHEMATICAL SCRIPT CAPITAL A - (16#1D49E#, 16#1D49F#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL C .. MATHEMATICAL SCRIPT CAPITAL D - (16#1D4A2#, 16#1D4A2#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL G .. MATHEMATICAL SCRIPT CAPITAL G - (16#1D4A5#, 16#1D4A6#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL J .. MATHEMATICAL SCRIPT CAPITAL K - (16#1D4A9#, 16#1D4AC#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL N .. MATHEMATICAL SCRIPT CAPITAL Q - (16#1D4AE#, 16#1D4B5#), -- (Lu) MATHEMATICAL SCRIPT CAPITAL S .. MATHEMATICAL SCRIPT CAPITAL Z - (16#1D4B6#, 16#1D4B9#), -- (Ll) MATHEMATICAL SCRIPT SMALL A .. MATHEMATICAL SCRIPT SMALL D - (16#1D4BB#, 16#1D4BB#), -- (Ll) MATHEMATICAL SCRIPT SMALL F .. MATHEMATICAL SCRIPT SMALL F - (16#1D4BD#, 16#1D4C3#), -- (Ll) MATHEMATICAL SCRIPT SMALL H .. MATHEMATICAL SCRIPT SMALL N - (16#1D4C5#, 16#1D4CF#), -- (Ll) MATHEMATICAL SCRIPT SMALL P .. MATHEMATICAL SCRIPT SMALL Z - (16#1D4D0#, 16#1D4E9#), -- (Lu) MATHEMATICAL BOLD SCRIPT CAPITAL A .. MATHEMATICAL BOLD SCRIPT CAPITAL Z - (16#1D4EA#, 16#1D503#), -- (Ll) MATHEMATICAL BOLD SCRIPT SMALL A .. MATHEMATICAL BOLD SCRIPT SMALL Z - (16#1D504#, 16#1D505#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL A .. MATHEMATICAL FRAKTUR CAPITAL B - (16#1D507#, 16#1D50A#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL D .. MATHEMATICAL FRAKTUR CAPITAL G - (16#1D50D#, 16#1D514#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL J .. MATHEMATICAL FRAKTUR CAPITAL Q - (16#1D516#, 16#1D51C#), -- (Lu) MATHEMATICAL FRAKTUR CAPITAL S .. MATHEMATICAL FRAKTUR CAPITAL Y - (16#1D51E#, 16#1D537#), -- (Ll) MATHEMATICAL FRAKTUR SMALL A .. MATHEMATICAL FRAKTUR SMALL Z - (16#1D538#, 16#1D539#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL A .. MATHEMATICAL DOUBLE-STRUCK CAPITAL B - (16#1D53B#, 16#1D53E#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL D .. MATHEMATICAL DOUBLE-STRUCK CAPITAL G - (16#1D540#, 16#1D544#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL I .. MATHEMATICAL DOUBLE-STRUCK CAPITAL M - (16#1D546#, 16#1D546#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL O .. MATHEMATICAL DOUBLE-STRUCK CAPITAL O - (16#1D54A#, 16#1D550#), -- (Lu) MATHEMATICAL DOUBLE-STRUCK CAPITAL S .. MATHEMATICAL DOUBLE-STRUCK CAPITAL Y - (16#1D552#, 16#1D56B#), -- (Ll) MATHEMATICAL DOUBLE-STRUCK SMALL A .. MATHEMATICAL DOUBLE-STRUCK SMALL Z - (16#1D56C#, 16#1D585#), -- (Lu) MATHEMATICAL BOLD FRAKTUR CAPITAL A .. MATHEMATICAL BOLD FRAKTUR CAPITAL Z - (16#1D586#, 16#1D59F#), -- (Ll) MATHEMATICAL BOLD FRAKTUR SMALL A .. MATHEMATICAL BOLD FRAKTUR SMALL Z - (16#1D5A0#, 16#1D5B9#), -- (Lu) MATHEMATICAL SANS-SERIF CAPITAL A .. MATHEMATICAL SANS-SERIF CAPITAL Z - (16#1D5BA#, 16#1D5D3#), -- (Ll) MATHEMATICAL SANS-SERIF SMALL A .. MATHEMATICAL SANS-SERIF SMALL Z - (16#1D5D4#, 16#1D5ED#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD CAPITAL Z - (16#1D5EE#, 16#1D607#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD SMALL A .. MATHEMATICAL SANS-SERIF BOLD SMALL Z - (16#1D608#, 16#1D621#), -- (Lu) MATHEMATICAL SANS-SERIF ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF ITALIC CAPITAL Z - (16#1D622#, 16#1D63B#), -- (Ll) MATHEMATICAL SANS-SERIF ITALIC SMALL A .. MATHEMATICAL SANS-SERIF ITALIC SMALL Z - (16#1D63C#, 16#1D655#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL Z - (16#1D656#, 16#1D66F#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL Z - (16#1D670#, 16#1D689#), -- (Lu) MATHEMATICAL MONOSPACE CAPITAL A .. MATHEMATICAL MONOSPACE CAPITAL Z - (16#1D68A#, 16#1D6A3#), -- (Ll) MATHEMATICAL MONOSPACE SMALL A .. MATHEMATICAL MONOSPACE SMALL Z - (16#1D6A8#, 16#1D6C0#), -- (Lu) MATHEMATICAL BOLD CAPITAL ALPHA .. MATHEMATICAL BOLD CAPITAL OMEGA - (16#1D6C1#, 16#1D6C1#), -- (Sm) MATHEMATICAL BOLD NABLA .. MATHEMATICAL BOLD NABLA - (16#1D6C2#, 16#1D6DA#), -- (Ll) MATHEMATICAL BOLD SMALL ALPHA .. MATHEMATICAL BOLD SMALL OMEGA - (16#1D6DB#, 16#1D6DB#), -- (Sm) MATHEMATICAL BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD PARTIAL DIFFERENTIAL - (16#1D6DC#, 16#1D6E1#), -- (Ll) MATHEMATICAL BOLD EPSILON SYMBOL .. MATHEMATICAL BOLD PI SYMBOL - (16#1D6E2#, 16#1D6FA#), -- (Lu) MATHEMATICAL ITALIC CAPITAL ALPHA .. MATHEMATICAL ITALIC CAPITAL OMEGA - (16#1D6FB#, 16#1D6FB#), -- (Sm) MATHEMATICAL ITALIC NABLA .. MATHEMATICAL ITALIC NABLA - (16#1D6FC#, 16#1D714#), -- (Ll) MATHEMATICAL ITALIC SMALL ALPHA .. MATHEMATICAL ITALIC SMALL OMEGA - (16#1D715#, 16#1D715#), -- (Sm) MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL - (16#1D716#, 16#1D71B#), -- (Ll) MATHEMATICAL ITALIC EPSILON SYMBOL .. MATHEMATICAL ITALIC PI SYMBOL - (16#1D71C#, 16#1D734#), -- (Lu) MATHEMATICAL BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL BOLD ITALIC CAPITAL OMEGA - (16#1D735#, 16#1D735#), -- (Sm) MATHEMATICAL BOLD ITALIC NABLA .. MATHEMATICAL BOLD ITALIC NABLA - (16#1D736#, 16#1D74E#), -- (Ll) MATHEMATICAL BOLD ITALIC SMALL ALPHA .. MATHEMATICAL BOLD ITALIC SMALL OMEGA - (16#1D74F#, 16#1D74F#), -- (Sm) MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL - (16#1D750#, 16#1D755#), -- (Ll) MATHEMATICAL BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL BOLD ITALIC PI SYMBOL - (16#1D756#, 16#1D76E#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA - (16#1D76F#, 16#1D76F#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD NABLA .. MATHEMATICAL SANS-SERIF BOLD NABLA - (16#1D770#, 16#1D788#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA - (16#1D789#, 16#1D789#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL - (16#1D78A#, 16#1D78F#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD PI SYMBOL - (16#1D790#, 16#1D7A8#), -- (Lu) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA - (16#1D7A9#, 16#1D7A9#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA .. MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA - (16#1D7AA#, 16#1D7C2#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA - (16#1D7C3#, 16#1D7C3#), -- (Sm) MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL - (16#1D7C4#, 16#1D7C9#), -- (Ll) MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL - (16#1D7CE#, 16#1D7FF#), -- (Nd) MATHEMATICAL BOLD DIGIT ZERO .. MATHEMATICAL MONOSPACE DIGIT NINE - (16#20000#, 16#2A6D6#), -- (Lo) .. - (16#2F800#, 16#2FA1D#), -- (Lo) CJK COMPATIBILITY IDEOGRAPH-2F800 .. CJK COMPATIBILITY IDEOGRAPH-2FA1D - (16#E0001#, 16#E0001#), -- (Cf) LANGUAGE TAG .. LANGUAGE TAG - (16#E0020#, 16#E007F#), -- (Cf) TAG SPACE .. CANCEL TAG - (16#E0100#, 16#E01EF#), -- (Mn) VARIATION SELECTOR-17 .. VARIATION SELECTOR-256 - (16#F0000#, 16#FFFFD#), -- (Co) .. - (16#100000#, 16#10FFFD#)); -- (Co) .. - - pragma Warnings (Off); - -- Temporary, until pragma at start can be activated ??? - - -- The following array is parallel to the Unicode_Ranges table above. For - -- each entry in the Unicode_Ranges table, there is a corresponding entry - -- in the following table indicating the corresponding unicode category. - - Unicode_Categories : constant array (Unicode_Ranges'Range) of Category := ( - Cc, -- (16#00000#, 16#0001F#) .. - Zs, -- (16#00020#, 16#00020#) SPACE .. SPACE - Po, -- (16#00021#, 16#00023#) EXCLAMATION MARK .. NUMBER SIGN - Sc, -- (16#00024#, 16#00024#) DOLLAR SIGN .. DOLLAR SIGN - Po, -- (16#00025#, 16#00027#) PERCENT SIGN .. APOSTROPHE - Ps, -- (16#00028#, 16#00028#) LEFT PARENTHESIS .. LEFT PARENTHESIS - Pe, -- (16#00029#, 16#00029#) RIGHT PARENTHESIS .. RIGHT PARENTHESIS - Po, -- (16#0002A#, 16#0002A#) ASTERISK .. ASTERISK - Sm, -- (16#0002B#, 16#0002B#) PLUS SIGN .. PLUS SIGN - Po, -- (16#0002C#, 16#0002C#) COMMA .. COMMA - Pd, -- (16#0002D#, 16#0002D#) HYPHEN-MINUS .. HYPHEN-MINUS - Po, -- (16#0002E#, 16#0002F#) FULL STOP .. SOLIDUS - Nd, -- (16#00030#, 16#00039#) DIGIT ZERO .. DIGIT NINE - Po, -- (16#0003A#, 16#0003B#) COLON .. SEMICOLON - Sm, -- (16#0003C#, 16#0003E#) LESS-THAN SIGN .. GREATER-THAN SIGN - Po, -- (16#0003F#, 16#00040#) QUESTION MARK .. COMMERCIAL AT - Lu, -- (16#00041#, 16#0005A#) LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z - Ps, -- (16#0005B#, 16#0005B#) LEFT SQUARE BRACKET .. LEFT SQUARE BRACKET - Po, -- (16#0005C#, 16#0005C#) REVERSE SOLIDUS .. REVERSE SOLIDUS - Pe, -- (16#0005D#, 16#0005D#) RIGHT SQUARE BRACKET .. RIGHT SQUARE BRACKET - Sk, -- (16#0005E#, 16#0005E#) CIRCUMFLEX ACCENT .. CIRCUMFLEX ACCENT - Pc, -- (16#0005F#, 16#0005F#) LOW LINE .. LOW LINE - Sk, -- (16#00060#, 16#00060#) GRAVE ACCENT .. GRAVE ACCENT - Ll, -- (16#00061#, 16#0007A#) LATIN SMALL LETTER A .. LATIN SMALL LETTER Z - Ps, -- (16#0007B#, 16#0007B#) LEFT CURLY BRACKET .. LEFT CURLY BRACKET - Sm, -- (16#0007C#, 16#0007C#) VERTICAL LINE .. VERTICAL LINE - Pe, -- (16#0007D#, 16#0007D#) RIGHT CURLY BRACKET .. RIGHT CURLY BRACKET - Sm, -- (16#0007E#, 16#0007E#) TILDE .. TILDE - Cc, -- (16#0007F#, 16#0009F#) .. - Zs, -- (16#000A0#, 16#000A0#) NO-BREAK SPACE .. NO-BREAK SPACE - Po, -- (16#000A1#, 16#000A1#) INVERTED EXCLAMATION MARK .. INVERTED EXCLAMATION MARK - Sc, -- (16#000A2#, 16#000A5#) CENT SIGN .. YEN SIGN - So, -- (16#000A6#, 16#000A7#) BROKEN BAR .. SECTION SIGN - Sk, -- (16#000A8#, 16#000A8#) DIAERESIS .. DIAERESIS - So, -- (16#000A9#, 16#000A9#) COPYRIGHT SIGN .. COPYRIGHT SIGN - Ll, -- (16#000AA#, 16#000AA#) FEMININE ORDINAL INDICATOR .. FEMININE ORDINAL INDICATOR - Pi, -- (16#000AB#, 16#000AB#) LEFT-POINTING DOUBLE ANGLE QUOTATION MARK .. LEFT-POINTING DOUBLE ANGLE QUOTATION MARK - Sm, -- (16#000AC#, 16#000AC#) NOT SIGN .. NOT SIGN - Cf, -- (16#000AD#, 16#000AD#) SOFT HYPHEN .. SOFT HYPHEN - So, -- (16#000AE#, 16#000AE#) REGISTERED SIGN .. REGISTERED SIGN - Sk, -- (16#000AF#, 16#000AF#) MACRON .. MACRON - So, -- (16#000B0#, 16#000B0#) DEGREE SIGN .. DEGREE SIGN - Sm, -- (16#000B1#, 16#000B1#) PLUS-MINUS SIGN .. PLUS-MINUS SIGN - No, -- (16#000B2#, 16#000B3#) SUPERSCRIPT TWO .. SUPERSCRIPT THREE - Sk, -- (16#000B4#, 16#000B4#) ACUTE ACCENT .. ACUTE ACCENT - Ll, -- (16#000B5#, 16#000B5#) MICRO SIGN .. MICRO SIGN - So, -- (16#000B6#, 16#000B6#) PILCROW SIGN .. PILCROW SIGN - Po, -- (16#000B7#, 16#000B7#) MIDDLE DOT .. MIDDLE DOT - Sk, -- (16#000B8#, 16#000B8#) CEDILLA .. CEDILLA - No, -- (16#000B9#, 16#000B9#) SUPERSCRIPT ONE .. SUPERSCRIPT ONE - Ll, -- (16#000BA#, 16#000BA#) MASCULINE ORDINAL INDICATOR .. MASCULINE ORDINAL INDICATOR - Pf, -- (16#000BB#, 16#000BB#) RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK .. RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK - No, -- (16#000BC#, 16#000BE#) VULGAR FRACTION ONE QUARTER .. VULGAR FRACTION THREE QUARTERS - Po, -- (16#000BF#, 16#000BF#) INVERTED QUESTION MARK .. INVERTED QUESTION MARK - Lu, -- (16#000C0#, 16#000D6#) LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS - Sm, -- (16#000D7#, 16#000D7#) MULTIPLICATION SIGN .. MULTIPLICATION SIGN - Lu, -- (16#000D8#, 16#000DE#) LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN - Ll, -- (16#000DF#, 16#000F6#) LATIN SMALL LETTER SHARP S .. LATIN SMALL LETTER O WITH DIAERESIS - Sm, -- (16#000F7#, 16#000F7#) DIVISION SIGN .. DIVISION SIGN - Ll, -- (16#000F8#, 16#000FF#) LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER Y WITH DIAERESIS - Lu, -- (16#00100#, 16#00100#) LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON - Ll, -- (16#00101#, 16#00101#) LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON - Lu, -- (16#00102#, 16#00102#) LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE - Ll, -- (16#00103#, 16#00103#) LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE - Lu, -- (16#00104#, 16#00104#) LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK - Ll, -- (16#00105#, 16#00105#) LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK - Lu, -- (16#00106#, 16#00106#) LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE - Ll, -- (16#00107#, 16#00107#) LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE - Lu, -- (16#00108#, 16#00108#) LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX - Ll, -- (16#00109#, 16#00109#) LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX - Lu, -- (16#0010A#, 16#0010A#) LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE - Ll, -- (16#0010B#, 16#0010B#) LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE - Lu, -- (16#0010C#, 16#0010C#) LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON - Ll, -- (16#0010D#, 16#0010D#) LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON - Lu, -- (16#0010E#, 16#0010E#) LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON - Ll, -- (16#0010F#, 16#0010F#) LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON - Lu, -- (16#00110#, 16#00110#) LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE - Ll, -- (16#00111#, 16#00111#) LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE - Lu, -- (16#00112#, 16#00112#) LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON - Ll, -- (16#00113#, 16#00113#) LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON - Lu, -- (16#00114#, 16#00114#) LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE - Ll, -- (16#00115#, 16#00115#) LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE - Lu, -- (16#00116#, 16#00116#) LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE - Ll, -- (16#00117#, 16#00117#) LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE - Lu, -- (16#00118#, 16#00118#) LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK - Ll, -- (16#00119#, 16#00119#) LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK - Lu, -- (16#0011A#, 16#0011A#) LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON - Ll, -- (16#0011B#, 16#0011B#) LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON - Lu, -- (16#0011C#, 16#0011C#) LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX - Ll, -- (16#0011D#, 16#0011D#) LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX - Lu, -- (16#0011E#, 16#0011E#) LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE - Ll, -- (16#0011F#, 16#0011F#) LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE - Lu, -- (16#00120#, 16#00120#) LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE - Ll, -- (16#00121#, 16#00121#) LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE - Lu, -- (16#00122#, 16#00122#) LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA - Ll, -- (16#00123#, 16#00123#) LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA - Lu, -- (16#00124#, 16#00124#) LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX - Ll, -- (16#00125#, 16#00125#) LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX - Lu, -- (16#00126#, 16#00126#) LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE - Ll, -- (16#00127#, 16#00127#) LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE - Lu, -- (16#00128#, 16#00128#) LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE - Ll, -- (16#00129#, 16#00129#) LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE - Lu, -- (16#0012A#, 16#0012A#) LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON - Ll, -- (16#0012B#, 16#0012B#) LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON - Lu, -- (16#0012C#, 16#0012C#) LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE - Ll, -- (16#0012D#, 16#0012D#) LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE - Lu, -- (16#0012E#, 16#0012E#) LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK - Ll, -- (16#0012F#, 16#0012F#) LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK - Lu, -- (16#00130#, 16#00130#) LATIN CAPITAL LETTER I WITH DOT ABOVE .. LATIN CAPITAL LETTER I WITH DOT ABOVE - Ll, -- (16#00131#, 16#00131#) LATIN SMALL LETTER DOTLESS I .. LATIN SMALL LETTER DOTLESS I - Lu, -- (16#00132#, 16#00132#) LATIN CAPITAL LIGATURE IJ .. LATIN CAPITAL LIGATURE IJ - Ll, -- (16#00133#, 16#00133#) LATIN SMALL LIGATURE IJ .. LATIN SMALL LIGATURE IJ - Lu, -- (16#00134#, 16#00134#) LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX - Ll, -- (16#00135#, 16#00135#) LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX - Lu, -- (16#00136#, 16#00136#) LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA - Ll, -- (16#00137#, 16#00138#) LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER KRA - Lu, -- (16#00139#, 16#00139#) LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE - Ll, -- (16#0013A#, 16#0013A#) LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE - Lu, -- (16#0013B#, 16#0013B#) LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA - Ll, -- (16#0013C#, 16#0013C#) LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA - Lu, -- (16#0013D#, 16#0013D#) LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON - Ll, -- (16#0013E#, 16#0013E#) LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON - Lu, -- (16#0013F#, 16#0013F#) LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT - Ll, -- (16#00140#, 16#00140#) LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT - Lu, -- (16#00141#, 16#00141#) LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE - Ll, -- (16#00142#, 16#00142#) LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE - Lu, -- (16#00143#, 16#00143#) LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE - Ll, -- (16#00144#, 16#00144#) LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE - Lu, -- (16#00145#, 16#00145#) LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA - Ll, -- (16#00146#, 16#00146#) LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA - Lu, -- (16#00147#, 16#00147#) LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON - Ll, -- (16#00148#, 16#00149#) LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N PRECEDED BY APOSTROPHE - Lu, -- (16#0014A#, 16#0014A#) LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG - Ll, -- (16#0014B#, 16#0014B#) LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG - Lu, -- (16#0014C#, 16#0014C#) LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON - Ll, -- (16#0014D#, 16#0014D#) LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON - Lu, -- (16#0014E#, 16#0014E#) LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE - Ll, -- (16#0014F#, 16#0014F#) LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE - Lu, -- (16#00150#, 16#00150#) LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE - Ll, -- (16#00151#, 16#00151#) LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE - Lu, -- (16#00152#, 16#00152#) LATIN CAPITAL LIGATURE OE .. LATIN CAPITAL LIGATURE OE - Ll, -- (16#00153#, 16#00153#) LATIN SMALL LIGATURE OE .. LATIN SMALL LIGATURE OE - Lu, -- (16#00154#, 16#00154#) LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE - Ll, -- (16#00155#, 16#00155#) LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE - Lu, -- (16#00156#, 16#00156#) LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA - Ll, -- (16#00157#, 16#00157#) LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA - Lu, -- (16#00158#, 16#00158#) LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON - Ll, -- (16#00159#, 16#00159#) LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON - Lu, -- (16#0015A#, 16#0015A#) LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE - Ll, -- (16#0015B#, 16#0015B#) LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE - Lu, -- (16#0015C#, 16#0015C#) LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX - Ll, -- (16#0015D#, 16#0015D#) LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX - Lu, -- (16#0015E#, 16#0015E#) LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA - Ll, -- (16#0015F#, 16#0015F#) LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA - Lu, -- (16#00160#, 16#00160#) LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON - Ll, -- (16#00161#, 16#00161#) LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON - Lu, -- (16#00162#, 16#00162#) LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA - Ll, -- (16#00163#, 16#00163#) LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA - Lu, -- (16#00164#, 16#00164#) LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON - Ll, -- (16#00165#, 16#00165#) LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON - Lu, -- (16#00166#, 16#00166#) LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE - Ll, -- (16#00167#, 16#00167#) LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE - Lu, -- (16#00168#, 16#00168#) LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE - Ll, -- (16#00169#, 16#00169#) LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE - Lu, -- (16#0016A#, 16#0016A#) LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON - Ll, -- (16#0016B#, 16#0016B#) LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON - Lu, -- (16#0016C#, 16#0016C#) LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE - Ll, -- (16#0016D#, 16#0016D#) LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE - Lu, -- (16#0016E#, 16#0016E#) LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE - Ll, -- (16#0016F#, 16#0016F#) LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE - Lu, -- (16#00170#, 16#00170#) LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE - Ll, -- (16#00171#, 16#00171#) LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE - Lu, -- (16#00172#, 16#00172#) LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK - Ll, -- (16#00173#, 16#00173#) LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK - Lu, -- (16#00174#, 16#00174#) LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX - Ll, -- (16#00175#, 16#00175#) LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX - Lu, -- (16#00176#, 16#00176#) LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX - Ll, -- (16#00177#, 16#00177#) LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX - Lu, -- (16#00178#, 16#00179#) LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Z WITH ACUTE - Ll, -- (16#0017A#, 16#0017A#) LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE - Lu, -- (16#0017B#, 16#0017B#) LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE - Ll, -- (16#0017C#, 16#0017C#) LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE - Lu, -- (16#0017D#, 16#0017D#) LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON - Ll, -- (16#0017E#, 16#00180#) LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER B WITH STROKE - Lu, -- (16#00181#, 16#00182#) LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH TOPBAR - Ll, -- (16#00183#, 16#00183#) LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR - Lu, -- (16#00184#, 16#00184#) LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX - Ll, -- (16#00185#, 16#00185#) LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX - Lu, -- (16#00186#, 16#00187#) LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER C WITH HOOK - Ll, -- (16#00188#, 16#00188#) LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK - Lu, -- (16#00189#, 16#0018B#) LATIN CAPITAL LETTER AFRICAN D .. LATIN CAPITAL LETTER D WITH TOPBAR - Ll, -- (16#0018C#, 16#0018D#) LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER TURNED DELTA - Lu, -- (16#0018E#, 16#00191#) LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER F WITH HOOK - Ll, -- (16#00192#, 16#00192#) LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK - Lu, -- (16#00193#, 16#00194#) LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER GAMMA - Ll, -- (16#00195#, 16#00195#) LATIN SMALL LETTER HV .. LATIN SMALL LETTER HV - Lu, -- (16#00196#, 16#00198#) LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER K WITH HOOK - Ll, -- (16#00199#, 16#0019B#) LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER LAMBDA WITH STROKE - Lu, -- (16#0019C#, 16#0019D#) LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER N WITH LEFT HOOK - Ll, -- (16#0019E#, 16#0019E#) LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG - Lu, -- (16#0019F#, 16#001A0#) LATIN CAPITAL LETTER O WITH MIDDLE TILDE .. LATIN CAPITAL LETTER O WITH HORN - Ll, -- (16#001A1#, 16#001A1#) LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN - Lu, -- (16#001A2#, 16#001A2#) LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI - Ll, -- (16#001A3#, 16#001A3#) LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI - Lu, -- (16#001A4#, 16#001A4#) LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK - Ll, -- (16#001A5#, 16#001A5#) LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK - Lu, -- (16#001A6#, 16#001A7#) LATIN LETTER YR .. LATIN CAPITAL LETTER TONE TWO - Ll, -- (16#001A8#, 16#001A8#) LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO - Lu, -- (16#001A9#, 16#001A9#) LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH - Ll, -- (16#001AA#, 16#001AB#) LATIN LETTER REVERSED ESH LOOP .. LATIN SMALL LETTER T WITH PALATAL HOOK - Lu, -- (16#001AC#, 16#001AC#) LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK - Ll, -- (16#001AD#, 16#001AD#) LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK - Lu, -- (16#001AE#, 16#001AF#) LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER U WITH HORN - Ll, -- (16#001B0#, 16#001B0#) LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN - Lu, -- (16#001B1#, 16#001B3#) LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER Y WITH HOOK - Ll, -- (16#001B4#, 16#001B4#) LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK - Lu, -- (16#001B5#, 16#001B5#) LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE - Ll, -- (16#001B6#, 16#001B6#) LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE - Lu, -- (16#001B7#, 16#001B8#) LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH REVERSED - Ll, -- (16#001B9#, 16#001BA#) LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH WITH TAIL - Lo, -- (16#001BB#, 16#001BB#) LATIN LETTER TWO WITH STROKE .. LATIN LETTER TWO WITH STROKE - Lu, -- (16#001BC#, 16#001BC#) LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE - Ll, -- (16#001BD#, 16#001BF#) LATIN SMALL LETTER TONE FIVE .. LATIN LETTER WYNN - Lo, -- (16#001C0#, 16#001C3#) LATIN LETTER DENTAL CLICK .. LATIN LETTER RETROFLEX CLICK - Lu, -- (16#001C4#, 16#001C4#) LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON - Lt, -- (16#001C5#, 16#001C5#) LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON - Ll, -- (16#001C6#, 16#001C6#) LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON - Lu, -- (16#001C7#, 16#001C7#) LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ - Lt, -- (16#001C8#, 16#001C8#) LATIN CAPITAL LETTER L WITH SMALL LETTER J .. LATIN CAPITAL LETTER L WITH SMALL LETTER J - Ll, -- (16#001C9#, 16#001C9#) LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ - Lu, -- (16#001CA#, 16#001CA#) LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ - Lt, -- (16#001CB#, 16#001CB#) LATIN CAPITAL LETTER N WITH SMALL LETTER J .. LATIN CAPITAL LETTER N WITH SMALL LETTER J - Ll, -- (16#001CC#, 16#001CC#) LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ - Lu, -- (16#001CD#, 16#001CD#) LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON - Ll, -- (16#001CE#, 16#001CE#) LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON - Lu, -- (16#001CF#, 16#001CF#) LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON - Ll, -- (16#001D0#, 16#001D0#) LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON - Lu, -- (16#001D1#, 16#001D1#) LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON - Ll, -- (16#001D2#, 16#001D2#) LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON - Lu, -- (16#001D3#, 16#001D3#) LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON - Ll, -- (16#001D4#, 16#001D4#) LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON - Lu, -- (16#001D5#, 16#001D5#) LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON - Ll, -- (16#001D6#, 16#001D6#) LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON - Lu, -- (16#001D7#, 16#001D7#) LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE - Ll, -- (16#001D8#, 16#001D8#) LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE - Lu, -- (16#001D9#, 16#001D9#) LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON - Ll, -- (16#001DA#, 16#001DA#) LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON - Lu, -- (16#001DB#, 16#001DB#) LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE - Ll, -- (16#001DC#, 16#001DD#) LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER TURNED E - Lu, -- (16#001DE#, 16#001DE#) LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON - Ll, -- (16#001DF#, 16#001DF#) LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON - Lu, -- (16#001E0#, 16#001E0#) LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON - Ll, -- (16#001E1#, 16#001E1#) LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON - Lu, -- (16#001E2#, 16#001E2#) LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON - Ll, -- (16#001E3#, 16#001E3#) LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON - Lu, -- (16#001E4#, 16#001E4#) LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE - Ll, -- (16#001E5#, 16#001E5#) LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE - Lu, -- (16#001E6#, 16#001E6#) LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON - Ll, -- (16#001E7#, 16#001E7#) LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON - Lu, -- (16#001E8#, 16#001E8#) LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON - Ll, -- (16#001E9#, 16#001E9#) LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON - Lu, -- (16#001EA#, 16#001EA#) LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK - Ll, -- (16#001EB#, 16#001EB#) LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK - Lu, -- (16#001EC#, 16#001EC#) LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON - Ll, -- (16#001ED#, 16#001ED#) LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON - Lu, -- (16#001EE#, 16#001EE#) LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON - Ll, -- (16#001EF#, 16#001F0#) LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER J WITH CARON - Lu, -- (16#001F1#, 16#001F1#) LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ - Lt, -- (16#001F2#, 16#001F2#) LATIN CAPITAL LETTER D WITH SMALL LETTER Z .. LATIN CAPITAL LETTER D WITH SMALL LETTER Z - Ll, -- (16#001F3#, 16#001F3#) LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ - Lu, -- (16#001F4#, 16#001F4#) LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE - Ll, -- (16#001F5#, 16#001F5#) LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE - Lu, -- (16#001F6#, 16#001F8#) LATIN CAPITAL LETTER HWAIR .. LATIN CAPITAL LETTER N WITH GRAVE - Ll, -- (16#001F9#, 16#001F9#) LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE - Lu, -- (16#001FA#, 16#001FA#) LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE - Ll, -- (16#001FB#, 16#001FB#) LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE - Lu, -- (16#001FC#, 16#001FC#) LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE - Ll, -- (16#001FD#, 16#001FD#) LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE - Lu, -- (16#001FE#, 16#001FE#) LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE - Ll, -- (16#001FF#, 16#001FF#) LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE - Lu, -- (16#00200#, 16#00200#) LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE - Ll, -- (16#00201#, 16#00201#) LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE - Lu, -- (16#00202#, 16#00202#) LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE - Ll, -- (16#00203#, 16#00203#) LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE - Lu, -- (16#00204#, 16#00204#) LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE - Ll, -- (16#00205#, 16#00205#) LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE - Lu, -- (16#00206#, 16#00206#) LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE - Ll, -- (16#00207#, 16#00207#) LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE - Lu, -- (16#00208#, 16#00208#) LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE - Ll, -- (16#00209#, 16#00209#) LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE - Lu, -- (16#0020A#, 16#0020A#) LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE - Ll, -- (16#0020B#, 16#0020B#) LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE - Lu, -- (16#0020C#, 16#0020C#) LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE - Ll, -- (16#0020D#, 16#0020D#) LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE - Lu, -- (16#0020E#, 16#0020E#) LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE - Ll, -- (16#0020F#, 16#0020F#) LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE - Lu, -- (16#00210#, 16#00210#) LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE - Ll, -- (16#00211#, 16#00211#) LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE - Lu, -- (16#00212#, 16#00212#) LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE - Ll, -- (16#00213#, 16#00213#) LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE - Lu, -- (16#00214#, 16#00214#) LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE - Ll, -- (16#00215#, 16#00215#) LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE - Lu, -- (16#00216#, 16#00216#) LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE - Ll, -- (16#00217#, 16#00217#) LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE - Lu, -- (16#00218#, 16#00218#) LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW - Ll, -- (16#00219#, 16#00219#) LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW - Lu, -- (16#0021A#, 16#0021A#) LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW - Ll, -- (16#0021B#, 16#0021B#) LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW - Lu, -- (16#0021C#, 16#0021C#) LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH - Ll, -- (16#0021D#, 16#0021D#) LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH - Lu, -- (16#0021E#, 16#0021E#) LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON - Ll, -- (16#0021F#, 16#0021F#) LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON - Lu, -- (16#00220#, 16#00220#) LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG - Ll, -- (16#00221#, 16#00221#) LATIN SMALL LETTER D WITH CURL .. LATIN SMALL LETTER D WITH CURL - Lu, -- (16#00222#, 16#00222#) LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU - Ll, -- (16#00223#, 16#00223#) LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU - Lu, -- (16#00224#, 16#00224#) LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK - Ll, -- (16#00225#, 16#00225#) LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK - Lu, -- (16#00226#, 16#00226#) LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE - Ll, -- (16#00227#, 16#00227#) LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE - Lu, -- (16#00228#, 16#00228#) LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA - Ll, -- (16#00229#, 16#00229#) LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA - Lu, -- (16#0022A#, 16#0022A#) LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON - Ll, -- (16#0022B#, 16#0022B#) LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON - Lu, -- (16#0022C#, 16#0022C#) LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON - Ll, -- (16#0022D#, 16#0022D#) LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON - Lu, -- (16#0022E#, 16#0022E#) LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE - Ll, -- (16#0022F#, 16#0022F#) LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE - Lu, -- (16#00230#, 16#00230#) LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON - Ll, -- (16#00231#, 16#00231#) LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON - Lu, -- (16#00232#, 16#00232#) LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON - Ll, -- (16#00233#, 16#00236#) LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER T WITH CURL - Ll, -- (16#00250#, 16#002AF#) LATIN SMALL LETTER TURNED A .. LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL - Lm, -- (16#002B0#, 16#002C1#) MODIFIER LETTER SMALL H .. MODIFIER LETTER REVERSED GLOTTAL STOP - Sk, -- (16#002C2#, 16#002C5#) MODIFIER LETTER LEFT ARROWHEAD .. MODIFIER LETTER DOWN ARROWHEAD - Lm, -- (16#002C6#, 16#002D1#) MODIFIER LETTER CIRCUMFLEX ACCENT .. MODIFIER LETTER HALF TRIANGULAR COLON - Sk, -- (16#002D2#, 16#002DF#) MODIFIER LETTER CENTRED RIGHT HALF RING .. MODIFIER LETTER CROSS ACCENT - Lm, -- (16#002E0#, 16#002E4#) MODIFIER LETTER SMALL GAMMA .. MODIFIER LETTER SMALL REVERSED GLOTTAL STOP - Sk, -- (16#002E5#, 16#002ED#) MODIFIER LETTER EXTRA-HIGH TONE BAR .. MODIFIER LETTER UNASPIRATED - Lm, -- (16#002EE#, 16#002EE#) MODIFIER LETTER DOUBLE APOSTROPHE .. MODIFIER LETTER DOUBLE APOSTROPHE - Sk, -- (16#002EF#, 16#002FF#) MODIFIER LETTER LOW DOWN ARROWHEAD .. MODIFIER LETTER LOW LEFT ARROW - Mn, -- (16#00300#, 16#00357#) COMBINING GRAVE ACCENT .. COMBINING RIGHT HALF RING ABOVE - Mn, -- (16#0035D#, 16#0036F#) COMBINING DOUBLE BREVE .. COMBINING LATIN SMALL LETTER X - Sk, -- (16#00374#, 16#00375#) GREEK NUMERAL SIGN .. GREEK LOWER NUMERAL SIGN - Lm, -- (16#0037A#, 16#0037A#) GREEK YPOGEGRAMMENI .. GREEK YPOGEGRAMMENI - Po, -- (16#0037E#, 16#0037E#) GREEK QUESTION MARK .. GREEK QUESTION MARK - Sk, -- (16#00384#, 16#00385#) GREEK TONOS .. GREEK DIALYTIKA TONOS - Lu, -- (16#00386#, 16#00386#) GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS - Po, -- (16#00387#, 16#00387#) GREEK ANO TELEIA .. GREEK ANO TELEIA - Lu, -- (16#00388#, 16#0038A#) GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS - Lu, -- (16#0038C#, 16#0038C#) GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS - Lu, -- (16#0038E#, 16#0038F#) GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS - Ll, -- (16#00390#, 16#00390#) GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS - Lu, -- (16#00391#, 16#003A1#) GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO - Lu, -- (16#003A3#, 16#003AB#) GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA - Ll, -- (16#003AC#, 16#003CE#) GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS - Ll, -- (16#003D0#, 16#003D1#) GREEK BETA SYMBOL .. GREEK THETA SYMBOL - Lu, -- (16#003D2#, 16#003D4#) GREEK UPSILON WITH HOOK SYMBOL .. GREEK UPSILON WITH DIAERESIS AND HOOK SYMBOL - Ll, -- (16#003D5#, 16#003D7#) GREEK PHI SYMBOL .. GREEK KAI SYMBOL - Lu, -- (16#003D8#, 16#003D8#) GREEK LETTER ARCHAIC KOPPA .. GREEK LETTER ARCHAIC KOPPA - Ll, -- (16#003D9#, 16#003D9#) GREEK SMALL LETTER ARCHAIC KOPPA .. GREEK SMALL LETTER ARCHAIC KOPPA - Lu, -- (16#003DA#, 16#003DA#) GREEK LETTER STIGMA .. GREEK LETTER STIGMA - Ll, -- (16#003DB#, 16#003DB#) GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA - Lu, -- (16#003DC#, 16#003DC#) GREEK LETTER DIGAMMA .. GREEK LETTER DIGAMMA - Ll, -- (16#003DD#, 16#003DD#) GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA - Lu, -- (16#003DE#, 16#003DE#) GREEK LETTER KOPPA .. GREEK LETTER KOPPA - Ll, -- (16#003DF#, 16#003DF#) GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA - Lu, -- (16#003E0#, 16#003E0#) GREEK LETTER SAMPI .. GREEK LETTER SAMPI - Ll, -- (16#003E1#, 16#003E1#) GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI - Lu, -- (16#003E2#, 16#003E2#) COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI - Ll, -- (16#003E3#, 16#003E3#) COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI - Lu, -- (16#003E4#, 16#003E4#) COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI - Ll, -- (16#003E5#, 16#003E5#) COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI - Lu, -- (16#003E6#, 16#003E6#) COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI - Ll, -- (16#003E7#, 16#003E7#) COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI - Lu, -- (16#003E8#, 16#003E8#) COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI - Ll, -- (16#003E9#, 16#003E9#) COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI - Lu, -- (16#003EA#, 16#003EA#) COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA - Ll, -- (16#003EB#, 16#003EB#) COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA - Lu, -- (16#003EC#, 16#003EC#) COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA - Ll, -- (16#003ED#, 16#003ED#) COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA - Lu, -- (16#003EE#, 16#003EE#) COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI - Ll, -- (16#003EF#, 16#003F3#) COPTIC SMALL LETTER DEI .. GREEK LETTER YOT - Lu, -- (16#003F4#, 16#003F4#) GREEK CAPITAL THETA SYMBOL .. GREEK CAPITAL THETA SYMBOL - Ll, -- (16#003F5#, 16#003F5#) GREEK LUNATE EPSILON SYMBOL .. GREEK LUNATE EPSILON SYMBOL - Sm, -- (16#003F6#, 16#003F6#) GREEK REVERSED LUNATE EPSILON SYMBOL .. GREEK REVERSED LUNATE EPSILON SYMBOL - Lu, -- (16#003F7#, 16#003F7#) GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO - Ll, -- (16#003F8#, 16#003F8#) GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO - Lu, -- (16#003F9#, 16#003FA#) GREEK CAPITAL LUNATE SIGMA SYMBOL .. GREEK CAPITAL LETTER SAN - Ll, -- (16#003FB#, 16#003FB#) GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN - Lu, -- (16#00400#, 16#0042F#) CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER YA - Ll, -- (16#00430#, 16#0045F#) CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER DZHE - Lu, -- (16#00460#, 16#00460#) CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA - Ll, -- (16#00461#, 16#00461#) CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA - Lu, -- (16#00462#, 16#00462#) CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT - Ll, -- (16#00463#, 16#00463#) CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT - Lu, -- (16#00464#, 16#00464#) CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E - Ll, -- (16#00465#, 16#00465#) CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E - Lu, -- (16#00466#, 16#00466#) CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS - Ll, -- (16#00467#, 16#00467#) CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS - Lu, -- (16#00468#, 16#00468#) CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS - Ll, -- (16#00469#, 16#00469#) CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS - Lu, -- (16#0046A#, 16#0046A#) CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS - Ll, -- (16#0046B#, 16#0046B#) CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS - Lu, -- (16#0046C#, 16#0046C#) CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS - Ll, -- (16#0046D#, 16#0046D#) CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS - Lu, -- (16#0046E#, 16#0046E#) CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI - Ll, -- (16#0046F#, 16#0046F#) CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI - Lu, -- (16#00470#, 16#00470#) CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI - Ll, -- (16#00471#, 16#00471#) CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI - Lu, -- (16#00472#, 16#00472#) CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA - Ll, -- (16#00473#, 16#00473#) CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA - Lu, -- (16#00474#, 16#00474#) CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA - Ll, -- (16#00475#, 16#00475#) CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA - Lu, -- (16#00476#, 16#00476#) CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - Ll, -- (16#00477#, 16#00477#) CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - Lu, -- (16#00478#, 16#00478#) CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK - Ll, -- (16#00479#, 16#00479#) CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK - Lu, -- (16#0047A#, 16#0047A#) CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA - Ll, -- (16#0047B#, 16#0047B#) CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA - Lu, -- (16#0047C#, 16#0047C#) CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO - Ll, -- (16#0047D#, 16#0047D#) CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO - Lu, -- (16#0047E#, 16#0047E#) CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT - Ll, -- (16#0047F#, 16#0047F#) CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT - Lu, -- (16#00480#, 16#00480#) CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA - Ll, -- (16#00481#, 16#00481#) CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA - So, -- (16#00482#, 16#00482#) CYRILLIC THOUSANDS SIGN .. CYRILLIC THOUSANDS SIGN - Mn, -- (16#00483#, 16#00486#) COMBINING CYRILLIC TITLO .. COMBINING CYRILLIC PSILI PNEUMATA - Me, -- (16#00488#, 16#00489#) COMBINING CYRILLIC HUNDRED THOUSANDS SIGN .. COMBINING CYRILLIC MILLIONS SIGN - Lu, -- (16#0048A#, 16#0048A#) CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL - Ll, -- (16#0048B#, 16#0048B#) CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL - Lu, -- (16#0048C#, 16#0048C#) CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN - Ll, -- (16#0048D#, 16#0048D#) CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN - Lu, -- (16#0048E#, 16#0048E#) CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK - Ll, -- (16#0048F#, 16#0048F#) CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK - Lu, -- (16#00490#, 16#00490#) CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN - Ll, -- (16#00491#, 16#00491#) CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN - Lu, -- (16#00492#, 16#00492#) CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE - Ll, -- (16#00493#, 16#00493#) CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE - Lu, -- (16#00494#, 16#00494#) CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK - Ll, -- (16#00495#, 16#00495#) CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK - Lu, -- (16#00496#, 16#00496#) CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER - Ll, -- (16#00497#, 16#00497#) CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER - Lu, -- (16#00498#, 16#00498#) CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER - Ll, -- (16#00499#, 16#00499#) CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER - Lu, -- (16#0049A#, 16#0049A#) CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER - Ll, -- (16#0049B#, 16#0049B#) CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER - Lu, -- (16#0049C#, 16#0049C#) CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE - Ll, -- (16#0049D#, 16#0049D#) CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE - Lu, -- (16#0049E#, 16#0049E#) CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE - Ll, -- (16#0049F#, 16#0049F#) CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE - Lu, -- (16#004A0#, 16#004A0#) CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA - Ll, -- (16#004A1#, 16#004A1#) CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA - Lu, -- (16#004A2#, 16#004A2#) CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER - Ll, -- (16#004A3#, 16#004A3#) CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER - Lu, -- (16#004A4#, 16#004A4#) CYRILLIC CAPITAL LIGATURE EN GHE .. CYRILLIC CAPITAL LIGATURE EN GHE - Ll, -- (16#004A5#, 16#004A5#) CYRILLIC SMALL LIGATURE EN GHE .. CYRILLIC SMALL LIGATURE EN GHE - Lu, -- (16#004A6#, 16#004A6#) CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK - Ll, -- (16#004A7#, 16#004A7#) CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK - Lu, -- (16#004A8#, 16#004A8#) CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA - Ll, -- (16#004A9#, 16#004A9#) CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA - Lu, -- (16#004AA#, 16#004AA#) CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER - Ll, -- (16#004AB#, 16#004AB#) CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER - Lu, -- (16#004AC#, 16#004AC#) CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER - Ll, -- (16#004AD#, 16#004AD#) CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER - Lu, -- (16#004AE#, 16#004AE#) CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U - Ll, -- (16#004AF#, 16#004AF#) CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U - Lu, -- (16#004B0#, 16#004B0#) CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE - Ll, -- (16#004B1#, 16#004B1#) CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE - Lu, -- (16#004B2#, 16#004B2#) CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER - Ll, -- (16#004B3#, 16#004B3#) CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER - Lu, -- (16#004B4#, 16#004B4#) CYRILLIC CAPITAL LIGATURE TE TSE .. CYRILLIC CAPITAL LIGATURE TE TSE - Ll, -- (16#004B5#, 16#004B5#) CYRILLIC SMALL LIGATURE TE TSE .. CYRILLIC SMALL LIGATURE TE TSE - Lu, -- (16#004B6#, 16#004B6#) CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER - Ll, -- (16#004B7#, 16#004B7#) CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER - Lu, -- (16#004B8#, 16#004B8#) CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE - Ll, -- (16#004B9#, 16#004B9#) CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE - Lu, -- (16#004BA#, 16#004BA#) CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA - Ll, -- (16#004BB#, 16#004BB#) CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA - Lu, -- (16#004BC#, 16#004BC#) CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE - Ll, -- (16#004BD#, 16#004BD#) CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE - Lu, -- (16#004BE#, 16#004BE#) CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER - Ll, -- (16#004BF#, 16#004BF#) CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER - Lu, -- (16#004C0#, 16#004C1#) CYRILLIC LETTER PALOCHKA .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE - Ll, -- (16#004C2#, 16#004C2#) CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE - Lu, -- (16#004C3#, 16#004C3#) CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK - Ll, -- (16#004C4#, 16#004C4#) CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK - Lu, -- (16#004C5#, 16#004C5#) CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL - Ll, -- (16#004C6#, 16#004C6#) CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL - Lu, -- (16#004C7#, 16#004C7#) CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK - Ll, -- (16#004C8#, 16#004C8#) CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK - Lu, -- (16#004C9#, 16#004C9#) CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL - Ll, -- (16#004CA#, 16#004CA#) CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL - Lu, -- (16#004CB#, 16#004CB#) CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE - Ll, -- (16#004CC#, 16#004CC#) CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE - Lu, -- (16#004CD#, 16#004CD#) CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL - Ll, -- (16#004CE#, 16#004CE#) CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL - Lu, -- (16#004D0#, 16#004D0#) CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE - Ll, -- (16#004D1#, 16#004D1#) CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE - Lu, -- (16#004D2#, 16#004D2#) CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS - Ll, -- (16#004D3#, 16#004D3#) CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS - Lu, -- (16#004D4#, 16#004D4#) CYRILLIC CAPITAL LIGATURE A IE .. CYRILLIC CAPITAL LIGATURE A IE - Ll, -- (16#004D5#, 16#004D5#) CYRILLIC SMALL LIGATURE A IE .. CYRILLIC SMALL LIGATURE A IE - Lu, -- (16#004D6#, 16#004D6#) CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE - Ll, -- (16#004D7#, 16#004D7#) CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE - Lu, -- (16#004D8#, 16#004D8#) CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA - Ll, -- (16#004D9#, 16#004D9#) CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA - Lu, -- (16#004DA#, 16#004DA#) CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS - Ll, -- (16#004DB#, 16#004DB#) CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS - Lu, -- (16#004DC#, 16#004DC#) CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS - Ll, -- (16#004DD#, 16#004DD#) CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS - Lu, -- (16#004DE#, 16#004DE#) CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS - Ll, -- (16#004DF#, 16#004DF#) CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS - Lu, -- (16#004E0#, 16#004E0#) CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE - Ll, -- (16#004E1#, 16#004E1#) CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE - Lu, -- (16#004E2#, 16#004E2#) CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON - Ll, -- (16#004E3#, 16#004E3#) CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON - Lu, -- (16#004E4#, 16#004E4#) CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS - Ll, -- (16#004E5#, 16#004E5#) CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS - Lu, -- (16#004E6#, 16#004E6#) CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS - Ll, -- (16#004E7#, 16#004E7#) CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS - Lu, -- (16#004E8#, 16#004E8#) CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O - Ll, -- (16#004E9#, 16#004E9#) CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O - Lu, -- (16#004EA#, 16#004EA#) CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS - Ll, -- (16#004EB#, 16#004EB#) CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS - Lu, -- (16#004EC#, 16#004EC#) CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS - Ll, -- (16#004ED#, 16#004ED#) CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS - Lu, -- (16#004EE#, 16#004EE#) CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON - Ll, -- (16#004EF#, 16#004EF#) CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON - Lu, -- (16#004F0#, 16#004F0#) CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS - Ll, -- (16#004F1#, 16#004F1#) CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS - Lu, -- (16#004F2#, 16#004F2#) CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE - Ll, -- (16#004F3#, 16#004F3#) CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE - Lu, -- (16#004F4#, 16#004F4#) CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS - Ll, -- (16#004F5#, 16#004F5#) CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS - Lu, -- (16#004F8#, 16#004F8#) CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS - Ll, -- (16#004F9#, 16#004F9#) CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS - Lu, -- (16#00500#, 16#00500#) CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE - Ll, -- (16#00501#, 16#00501#) CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE - Lu, -- (16#00502#, 16#00502#) CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE - Ll, -- (16#00503#, 16#00503#) CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE - Lu, -- (16#00504#, 16#00504#) CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE - Ll, -- (16#00505#, 16#00505#) CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE - Lu, -- (16#00506#, 16#00506#) CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE - Ll, -- (16#00507#, 16#00507#) CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE - Lu, -- (16#00508#, 16#00508#) CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE - Ll, -- (16#00509#, 16#00509#) CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE - Lu, -- (16#0050A#, 16#0050A#) CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE - Ll, -- (16#0050B#, 16#0050B#) CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE - Lu, -- (16#0050C#, 16#0050C#) CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE - Ll, -- (16#0050D#, 16#0050D#) CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE - Lu, -- (16#0050E#, 16#0050E#) CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE - Ll, -- (16#0050F#, 16#0050F#) CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE - Lu, -- (16#00531#, 16#00556#) ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH - Lm, -- (16#00559#, 16#00559#) ARMENIAN MODIFIER LETTER LEFT HALF RING .. ARMENIAN MODIFIER LETTER LEFT HALF RING - Po, -- (16#0055A#, 16#0055F#) ARMENIAN APOSTROPHE .. ARMENIAN ABBREVIATION MARK - Ll, -- (16#00561#, 16#00587#) ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LIGATURE ECH YIWN - Po, -- (16#00589#, 16#00589#) ARMENIAN FULL STOP .. ARMENIAN FULL STOP - Pd, -- (16#0058A#, 16#0058A#) ARMENIAN HYPHEN .. ARMENIAN HYPHEN - Mn, -- (16#00591#, 16#005A1#) HEBREW ACCENT ETNAHTA .. HEBREW ACCENT PAZER - Mn, -- (16#005A3#, 16#005B9#) HEBREW ACCENT MUNAH .. HEBREW POINT HOLAM - Mn, -- (16#005BB#, 16#005BD#) HEBREW POINT QUBUTS .. HEBREW POINT METEG - Po, -- (16#005BE#, 16#005BE#) HEBREW PUNCTUATION MAQAF .. HEBREW PUNCTUATION MAQAF - Mn, -- (16#005BF#, 16#005BF#) HEBREW POINT RAFE .. HEBREW POINT RAFE - Po, -- (16#005C0#, 16#005C0#) HEBREW PUNCTUATION PASEQ .. HEBREW PUNCTUATION PASEQ - Mn, -- (16#005C1#, 16#005C2#) HEBREW POINT SHIN DOT .. HEBREW POINT SIN DOT - Po, -- (16#005C3#, 16#005C3#) HEBREW PUNCTUATION SOF PASUQ .. HEBREW PUNCTUATION SOF PASUQ - Mn, -- (16#005C4#, 16#005C4#) HEBREW MARK UPPER DOT .. HEBREW MARK UPPER DOT - Lo, -- (16#005D0#, 16#005EA#) HEBREW LETTER ALEF .. HEBREW LETTER TAV - Lo, -- (16#005F0#, 16#005F2#) HEBREW LIGATURE YIDDISH DOUBLE VAV .. HEBREW LIGATURE YIDDISH DOUBLE YOD - Po, -- (16#005F3#, 16#005F4#) HEBREW PUNCTUATION GERESH .. HEBREW PUNCTUATION GERSHAYIM - Cf, -- (16#00600#, 16#00603#) ARABIC NUMBER SIGN .. ARABIC SIGN SAFHA - Po, -- (16#0060C#, 16#0060D#) ARABIC COMMA .. ARABIC DATE SEPARATOR - So, -- (16#0060E#, 16#0060F#) ARABIC POETIC VERSE SIGN .. ARABIC SIGN MISRA - Mn, -- (16#00610#, 16#00615#) ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM .. ARABIC SMALL HIGH TAH - Po, -- (16#0061B#, 16#0061B#) ARABIC SEMICOLON .. ARABIC SEMICOLON - Po, -- (16#0061F#, 16#0061F#) ARABIC QUESTION MARK .. ARABIC QUESTION MARK - Lo, -- (16#00621#, 16#0063A#) ARABIC LETTER HAMZA .. ARABIC LETTER GHAIN - Lm, -- (16#00640#, 16#00640#) ARABIC TATWEEL .. ARABIC TATWEEL - Lo, -- (16#00641#, 16#0064A#) ARABIC LETTER FEH .. ARABIC LETTER YEH - Mn, -- (16#0064B#, 16#00658#) ARABIC FATHATAN .. ARABIC MARK NOON GHUNNA - Nd, -- (16#00660#, 16#00669#) ARABIC-INDIC DIGIT ZERO .. ARABIC-INDIC DIGIT NINE - Po, -- (16#0066A#, 16#0066D#) ARABIC PERCENT SIGN .. ARABIC FIVE POINTED STAR - Lo, -- (16#0066E#, 16#0066F#) ARABIC LETTER DOTLESS BEH .. ARABIC LETTER DOTLESS QAF - Mn, -- (16#00670#, 16#00670#) ARABIC LETTER SUPERSCRIPT ALEF .. ARABIC LETTER SUPERSCRIPT ALEF - Lo, -- (16#00671#, 16#006D3#) ARABIC LETTER ALEF WASLA .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE - Po, -- (16#006D4#, 16#006D4#) ARABIC FULL STOP .. ARABIC FULL STOP - Lo, -- (16#006D5#, 16#006D5#) ARABIC LETTER AE .. ARABIC LETTER AE - Mn, -- (16#006D6#, 16#006DC#) ARABIC SMALL HIGH LIGATURE SAD WITH LAM WITH ALEF MAKSURA .. ARABIC SMALL HIGH SEEN - Cf, -- (16#006DD#, 16#006DD#) ARABIC END OF AYAH .. ARABIC END OF AYAH - Me, -- (16#006DE#, 16#006DE#) ARABIC START OF RUB EL HIZB .. ARABIC START OF RUB EL HIZB - Mn, -- (16#006DF#, 16#006E4#) ARABIC SMALL HIGH ROUNDED ZERO .. ARABIC SMALL HIGH MADDA - Lm, -- (16#006E5#, 16#006E6#) ARABIC SMALL WAW .. ARABIC SMALL YEH - Mn, -- (16#006E7#, 16#006E8#) ARABIC SMALL HIGH YEH .. ARABIC SMALL HIGH NOON - So, -- (16#006E9#, 16#006E9#) ARABIC PLACE OF SAJDAH .. ARABIC PLACE OF SAJDAH - Mn, -- (16#006EA#, 16#006ED#) ARABIC EMPTY CENTRE LOW STOP .. ARABIC SMALL LOW MEEM - Lo, -- (16#006EE#, 16#006EF#) ARABIC LETTER DAL WITH INVERTED V .. ARABIC LETTER REH WITH INVERTED V - Nd, -- (16#006F0#, 16#006F9#) EXTENDED ARABIC-INDIC DIGIT ZERO .. EXTENDED ARABIC-INDIC DIGIT NINE - Lo, -- (16#006FA#, 16#006FC#) ARABIC LETTER SHEEN WITH DOT BELOW .. ARABIC LETTER GHAIN WITH DOT BELOW - So, -- (16#006FD#, 16#006FE#) ARABIC SIGN SINDHI AMPERSAND .. ARABIC SIGN SINDHI POSTPOSITION MEN - Lo, -- (16#006FF#, 16#006FF#) ARABIC LETTER HEH WITH INVERTED V .. ARABIC LETTER HEH WITH INVERTED V - Po, -- (16#00700#, 16#0070D#) SYRIAC END OF PARAGRAPH .. SYRIAC HARKLEAN ASTERISCUS - Cf, -- (16#0070F#, 16#0070F#) SYRIAC ABBREVIATION MARK .. SYRIAC ABBREVIATION MARK - Lo, -- (16#00710#, 16#00710#) SYRIAC LETTER ALAPH .. SYRIAC LETTER ALAPH - Mn, -- (16#00711#, 16#00711#) SYRIAC LETTER SUPERSCRIPT ALAPH .. SYRIAC LETTER SUPERSCRIPT ALAPH - Lo, -- (16#00712#, 16#0072F#) SYRIAC LETTER BETH .. SYRIAC LETTER PERSIAN DHALATH - Mn, -- (16#00730#, 16#0074A#) SYRIAC PTHAHA ABOVE .. SYRIAC BARREKH - Lo, -- (16#0074D#, 16#0074F#) SYRIAC LETTER SOGDIAN ZHAIN .. SYRIAC LETTER SOGDIAN FE - Lo, -- (16#00780#, 16#007A5#) THAANA LETTER HAA .. THAANA LETTER WAAVU - Mn, -- (16#007A6#, 16#007B0#) THAANA ABAFILI .. THAANA SUKUN - Lo, -- (16#007B1#, 16#007B1#) THAANA LETTER NAA .. THAANA LETTER NAA - Mn, -- (16#00901#, 16#00902#) DEVANAGARI SIGN CANDRABINDU .. DEVANAGARI SIGN ANUSVARA - Mc, -- (16#00903#, 16#00903#) DEVANAGARI SIGN VISARGA .. DEVANAGARI SIGN VISARGA - Lo, -- (16#00904#, 16#00939#) DEVANAGARI LETTER SHORT A .. DEVANAGARI LETTER HA - Mn, -- (16#0093C#, 16#0093C#) DEVANAGARI SIGN NUKTA .. DEVANAGARI SIGN NUKTA - Lo, -- (16#0093D#, 16#0093D#) DEVANAGARI SIGN AVAGRAHA .. DEVANAGARI SIGN AVAGRAHA - Mc, -- (16#0093E#, 16#00940#) DEVANAGARI VOWEL SIGN AA .. DEVANAGARI VOWEL SIGN II - Mn, -- (16#00941#, 16#00948#) DEVANAGARI VOWEL SIGN U .. DEVANAGARI VOWEL SIGN AI - Mc, -- (16#00949#, 16#0094C#) DEVANAGARI VOWEL SIGN CANDRA O .. DEVANAGARI VOWEL SIGN AU - Mn, -- (16#0094D#, 16#0094D#) DEVANAGARI SIGN VIRAMA .. DEVANAGARI SIGN VIRAMA - Lo, -- (16#00950#, 16#00950#) DEVANAGARI OM .. DEVANAGARI OM - Mn, -- (16#00951#, 16#00954#) DEVANAGARI STRESS SIGN UDATTA .. DEVANAGARI ACUTE ACCENT - Lo, -- (16#00958#, 16#00961#) DEVANAGARI LETTER QA .. DEVANAGARI LETTER VOCALIC LL - Mn, -- (16#00962#, 16#00963#) DEVANAGARI VOWEL SIGN VOCALIC L .. DEVANAGARI VOWEL SIGN VOCALIC LL - Po, -- (16#00964#, 16#00965#) DEVANAGARI DANDA .. DEVANAGARI DOUBLE DANDA - Nd, -- (16#00966#, 16#0096F#) DEVANAGARI DIGIT ZERO .. DEVANAGARI DIGIT NINE - Po, -- (16#00970#, 16#00970#) DEVANAGARI ABBREVIATION SIGN .. DEVANAGARI ABBREVIATION SIGN - Mn, -- (16#00981#, 16#00981#) BENGALI SIGN CANDRABINDU .. BENGALI SIGN CANDRABINDU - Mc, -- (16#00982#, 16#00983#) BENGALI SIGN ANUSVARA .. BENGALI SIGN VISARGA - Lo, -- (16#00985#, 16#0098C#) BENGALI LETTER A .. BENGALI LETTER VOCALIC L - Lo, -- (16#0098F#, 16#00990#) BENGALI LETTER E .. BENGALI LETTER AI - Lo, -- (16#00993#, 16#009A8#) BENGALI LETTER O .. BENGALI LETTER NA - Lo, -- (16#009AA#, 16#009B0#) BENGALI LETTER PA .. BENGALI LETTER RA - Lo, -- (16#009B2#, 16#009B2#) BENGALI LETTER LA .. BENGALI LETTER LA - Lo, -- (16#009B6#, 16#009B9#) BENGALI LETTER SHA .. BENGALI LETTER HA - Mn, -- (16#009BC#, 16#009BC#) BENGALI SIGN NUKTA .. BENGALI SIGN NUKTA - Lo, -- (16#009BD#, 16#009BD#) BENGALI SIGN AVAGRAHA .. BENGALI SIGN AVAGRAHA - Mc, -- (16#009BE#, 16#009C0#) BENGALI VOWEL SIGN AA .. BENGALI VOWEL SIGN II - Mn, -- (16#009C1#, 16#009C4#) BENGALI VOWEL SIGN U .. BENGALI VOWEL SIGN VOCALIC RR - Mc, -- (16#009C7#, 16#009C8#) BENGALI VOWEL SIGN E .. BENGALI VOWEL SIGN AI - Mc, -- (16#009CB#, 16#009CC#) BENGALI VOWEL SIGN O .. BENGALI VOWEL SIGN AU - Mn, -- (16#009CD#, 16#009CD#) BENGALI SIGN VIRAMA .. BENGALI SIGN VIRAMA - Mc, -- (16#009D7#, 16#009D7#) BENGALI AU LENGTH MARK .. BENGALI AU LENGTH MARK - Lo, -- (16#009DC#, 16#009DD#) BENGALI LETTER RRA .. BENGALI LETTER RHA - Lo, -- (16#009DF#, 16#009E1#) BENGALI LETTER YYA .. BENGALI LETTER VOCALIC LL - Mn, -- (16#009E2#, 16#009E3#) BENGALI VOWEL SIGN VOCALIC L .. BENGALI VOWEL SIGN VOCALIC LL - Nd, -- (16#009E6#, 16#009EF#) BENGALI DIGIT ZERO .. BENGALI DIGIT NINE - Lo, -- (16#009F0#, 16#009F1#) BENGALI LETTER RA WITH MIDDLE DIAGONAL .. BENGALI LETTER RA WITH LOWER DIAGONAL - Sc, -- (16#009F2#, 16#009F3#) BENGALI RUPEE MARK .. BENGALI RUPEE SIGN - No, -- (16#009F4#, 16#009F9#) BENGALI CURRENCY NUMERATOR ONE .. BENGALI CURRENCY DENOMINATOR SIXTEEN - So, -- (16#009FA#, 16#009FA#) BENGALI ISSHAR .. BENGALI ISSHAR - Mn, -- (16#00A01#, 16#00A02#) GURMUKHI SIGN ADAK BINDI .. GURMUKHI SIGN BINDI - Mc, -- (16#00A03#, 16#00A03#) GURMUKHI SIGN VISARGA .. GURMUKHI SIGN VISARGA - Lo, -- (16#00A05#, 16#00A0A#) GURMUKHI LETTER A .. GURMUKHI LETTER UU - Lo, -- (16#00A0F#, 16#00A10#) GURMUKHI LETTER EE .. GURMUKHI LETTER AI - Lo, -- (16#00A13#, 16#00A28#) GURMUKHI LETTER OO .. GURMUKHI LETTER NA - Lo, -- (16#00A2A#, 16#00A30#) GURMUKHI LETTER PA .. GURMUKHI LETTER RA - Lo, -- (16#00A32#, 16#00A33#) GURMUKHI LETTER LA .. GURMUKHI LETTER LLA - Lo, -- (16#00A35#, 16#00A36#) GURMUKHI LETTER VA .. GURMUKHI LETTER SHA - Lo, -- (16#00A38#, 16#00A39#) GURMUKHI LETTER SA .. GURMUKHI LETTER HA - Mn, -- (16#00A3C#, 16#00A3C#) GURMUKHI SIGN NUKTA .. GURMUKHI SIGN NUKTA - Mc, -- (16#00A3E#, 16#00A40#) GURMUKHI VOWEL SIGN AA .. GURMUKHI VOWEL SIGN II - Mn, -- (16#00A41#, 16#00A42#) GURMUKHI VOWEL SIGN U .. GURMUKHI VOWEL SIGN UU - Mn, -- (16#00A47#, 16#00A48#) GURMUKHI VOWEL SIGN EE .. GURMUKHI VOWEL SIGN AI - Mn, -- (16#00A4B#, 16#00A4D#) GURMUKHI VOWEL SIGN OO .. GURMUKHI SIGN VIRAMA - Lo, -- (16#00A59#, 16#00A5C#) GURMUKHI LETTER KHHA .. GURMUKHI LETTER RRA - Lo, -- (16#00A5E#, 16#00A5E#) GURMUKHI LETTER FA .. GURMUKHI LETTER FA - Nd, -- (16#00A66#, 16#00A6F#) GURMUKHI DIGIT ZERO .. GURMUKHI DIGIT NINE - Mn, -- (16#00A70#, 16#00A71#) GURMUKHI TIPPI .. GURMUKHI ADDAK - Lo, -- (16#00A72#, 16#00A74#) GURMUKHI IRI .. GURMUKHI EK ONKAR - Mn, -- (16#00A81#, 16#00A82#) GUJARATI SIGN CANDRABINDU .. GUJARATI SIGN ANUSVARA - Mc, -- (16#00A83#, 16#00A83#) GUJARATI SIGN VISARGA .. GUJARATI SIGN VISARGA - Lo, -- (16#00A85#, 16#00A8D#) GUJARATI LETTER A .. GUJARATI VOWEL CANDRA E - Lo, -- (16#00A8F#, 16#00A91#) GUJARATI LETTER E .. GUJARATI VOWEL CANDRA O - Lo, -- (16#00A93#, 16#00AA8#) GUJARATI LETTER O .. GUJARATI LETTER NA - Lo, -- (16#00AAA#, 16#00AB0#) GUJARATI LETTER PA .. GUJARATI LETTER RA - Lo, -- (16#00AB2#, 16#00AB3#) GUJARATI LETTER LA .. GUJARATI LETTER LLA - Lo, -- (16#00AB5#, 16#00AB9#) GUJARATI LETTER VA .. GUJARATI LETTER HA - Mn, -- (16#00ABC#, 16#00ABC#) GUJARATI SIGN NUKTA .. GUJARATI SIGN NUKTA - Lo, -- (16#00ABD#, 16#00ABD#) GUJARATI SIGN AVAGRAHA .. GUJARATI SIGN AVAGRAHA - Mc, -- (16#00ABE#, 16#00AC0#) GUJARATI VOWEL SIGN AA .. GUJARATI VOWEL SIGN II - Mn, -- (16#00AC1#, 16#00AC5#) GUJARATI VOWEL SIGN U .. GUJARATI VOWEL SIGN CANDRA E - Mn, -- (16#00AC7#, 16#00AC8#) GUJARATI VOWEL SIGN E .. GUJARATI VOWEL SIGN AI - Mc, -- (16#00AC9#, 16#00AC9#) GUJARATI VOWEL SIGN CANDRA O .. GUJARATI VOWEL SIGN CANDRA O - Mc, -- (16#00ACB#, 16#00ACC#) GUJARATI VOWEL SIGN O .. GUJARATI VOWEL SIGN AU - Mn, -- (16#00ACD#, 16#00ACD#) GUJARATI SIGN VIRAMA .. GUJARATI SIGN VIRAMA - Lo, -- (16#00AD0#, 16#00AD0#) GUJARATI OM .. GUJARATI OM - Lo, -- (16#00AE0#, 16#00AE1#) GUJARATI LETTER VOCALIC RR .. GUJARATI LETTER VOCALIC LL - Mn, -- (16#00AE2#, 16#00AE3#) GUJARATI VOWEL SIGN VOCALIC L .. GUJARATI VOWEL SIGN VOCALIC LL - Nd, -- (16#00AE6#, 16#00AEF#) GUJARATI DIGIT ZERO .. GUJARATI DIGIT NINE - Sc, -- (16#00AF1#, 16#00AF1#) GUJARATI RUPEE SIGN .. GUJARATI RUPEE SIGN - Mn, -- (16#00B01#, 16#00B01#) ORIYA SIGN CANDRABINDU .. ORIYA SIGN CANDRABINDU - Mc, -- (16#00B02#, 16#00B03#) ORIYA SIGN ANUSVARA .. ORIYA SIGN VISARGA - Lo, -- (16#00B05#, 16#00B0C#) ORIYA LETTER A .. ORIYA LETTER VOCALIC L - Lo, -- (16#00B0F#, 16#00B10#) ORIYA LETTER E .. ORIYA LETTER AI - Lo, -- (16#00B13#, 16#00B28#) ORIYA LETTER O .. ORIYA LETTER NA - Lo, -- (16#00B2A#, 16#00B30#) ORIYA LETTER PA .. ORIYA LETTER RA - Lo, -- (16#00B32#, 16#00B33#) ORIYA LETTER LA .. ORIYA LETTER LLA - Lo, -- (16#00B35#, 16#00B39#) ORIYA LETTER VA .. ORIYA LETTER HA - Mn, -- (16#00B3C#, 16#00B3C#) ORIYA SIGN NUKTA .. ORIYA SIGN NUKTA - Lo, -- (16#00B3D#, 16#00B3D#) ORIYA SIGN AVAGRAHA .. ORIYA SIGN AVAGRAHA - Mc, -- (16#00B3E#, 16#00B3E#) ORIYA VOWEL SIGN AA .. ORIYA VOWEL SIGN AA - Mn, -- (16#00B3F#, 16#00B3F#) ORIYA VOWEL SIGN I .. ORIYA VOWEL SIGN I - Mc, -- (16#00B40#, 16#00B40#) ORIYA VOWEL SIGN II .. ORIYA VOWEL SIGN II - Mn, -- (16#00B41#, 16#00B43#) ORIYA VOWEL SIGN U .. ORIYA VOWEL SIGN VOCALIC R - Mc, -- (16#00B47#, 16#00B48#) ORIYA VOWEL SIGN E .. ORIYA VOWEL SIGN AI - Mc, -- (16#00B4B#, 16#00B4C#) ORIYA VOWEL SIGN O .. ORIYA VOWEL SIGN AU - Mn, -- (16#00B4D#, 16#00B4D#) ORIYA SIGN VIRAMA .. ORIYA SIGN VIRAMA - Mn, -- (16#00B56#, 16#00B56#) ORIYA AI LENGTH MARK .. ORIYA AI LENGTH MARK - Mc, -- (16#00B57#, 16#00B57#) ORIYA AU LENGTH MARK .. ORIYA AU LENGTH MARK - Lo, -- (16#00B5C#, 16#00B5D#) ORIYA LETTER RRA .. ORIYA LETTER RHA - Lo, -- (16#00B5F#, 16#00B61#) ORIYA LETTER YYA .. ORIYA LETTER VOCALIC LL - Nd, -- (16#00B66#, 16#00B6F#) ORIYA DIGIT ZERO .. ORIYA DIGIT NINE - So, -- (16#00B70#, 16#00B70#) ORIYA ISSHAR .. ORIYA ISSHAR - Lo, -- (16#00B71#, 16#00B71#) ORIYA LETTER WA .. ORIYA LETTER WA - Mn, -- (16#00B82#, 16#00B82#) TAMIL SIGN ANUSVARA .. TAMIL SIGN ANUSVARA - Lo, -- (16#00B83#, 16#00B83#) TAMIL SIGN VISARGA .. TAMIL SIGN VISARGA - Lo, -- (16#00B85#, 16#00B8A#) TAMIL LETTER A .. TAMIL LETTER UU - Lo, -- (16#00B8E#, 16#00B90#) TAMIL LETTER E .. TAMIL LETTER AI - Lo, -- (16#00B92#, 16#00B95#) TAMIL LETTER O .. TAMIL LETTER KA - Lo, -- (16#00B99#, 16#00B9A#) TAMIL LETTER NGA .. TAMIL LETTER CA - Lo, -- (16#00B9C#, 16#00B9C#) TAMIL LETTER JA .. TAMIL LETTER JA - Lo, -- (16#00B9E#, 16#00B9F#) TAMIL LETTER NYA .. TAMIL LETTER TTA - Lo, -- (16#00BA3#, 16#00BA4#) TAMIL LETTER NNA .. TAMIL LETTER TA - Lo, -- (16#00BA8#, 16#00BAA#) TAMIL LETTER NA .. TAMIL LETTER PA - Lo, -- (16#00BAE#, 16#00BB5#) TAMIL LETTER MA .. TAMIL LETTER VA - Lo, -- (16#00BB7#, 16#00BB9#) TAMIL LETTER SSA .. TAMIL LETTER HA - Mc, -- (16#00BBE#, 16#00BBF#) TAMIL VOWEL SIGN AA .. TAMIL VOWEL SIGN I - Mn, -- (16#00BC0#, 16#00BC0#) TAMIL VOWEL SIGN II .. TAMIL VOWEL SIGN II - Mc, -- (16#00BC1#, 16#00BC2#) TAMIL VOWEL SIGN U .. TAMIL VOWEL SIGN UU - Mc, -- (16#00BC6#, 16#00BC8#) TAMIL VOWEL SIGN E .. TAMIL VOWEL SIGN AI - Mc, -- (16#00BCA#, 16#00BCC#) TAMIL VOWEL SIGN O .. TAMIL VOWEL SIGN AU - Mn, -- (16#00BCD#, 16#00BCD#) TAMIL SIGN VIRAMA .. TAMIL SIGN VIRAMA - Mc, -- (16#00BD7#, 16#00BD7#) TAMIL AU LENGTH MARK .. TAMIL AU LENGTH MARK - Nd, -- (16#00BE7#, 16#00BEF#) TAMIL DIGIT ONE .. TAMIL DIGIT NINE - No, -- (16#00BF0#, 16#00BF2#) TAMIL NUMBER TEN .. TAMIL NUMBER ONE THOUSAND - So, -- (16#00BF3#, 16#00BF8#) TAMIL DAY SIGN .. TAMIL AS ABOVE SIGN - Sc, -- (16#00BF9#, 16#00BF9#) TAMIL RUPEE SIGN .. TAMIL RUPEE SIGN - So, -- (16#00BFA#, 16#00BFA#) TAMIL NUMBER SIGN .. TAMIL NUMBER SIGN - Mc, -- (16#00C01#, 16#00C03#) TELUGU SIGN CANDRABINDU .. TELUGU SIGN VISARGA - Lo, -- (16#00C05#, 16#00C0C#) TELUGU LETTER A .. TELUGU LETTER VOCALIC L - Lo, -- (16#00C0E#, 16#00C10#) TELUGU LETTER E .. TELUGU LETTER AI - Lo, -- (16#00C12#, 16#00C28#) TELUGU LETTER O .. TELUGU LETTER NA - Lo, -- (16#00C2A#, 16#00C33#) TELUGU LETTER PA .. TELUGU LETTER LLA - Lo, -- (16#00C35#, 16#00C39#) TELUGU LETTER VA .. TELUGU LETTER HA - Mn, -- (16#00C3E#, 16#00C40#) TELUGU VOWEL SIGN AA .. TELUGU VOWEL SIGN II - Mc, -- (16#00C41#, 16#00C44#) TELUGU VOWEL SIGN U .. TELUGU VOWEL SIGN VOCALIC RR - Mn, -- (16#00C46#, 16#00C48#) TELUGU VOWEL SIGN E .. TELUGU VOWEL SIGN AI - Mn, -- (16#00C4A#, 16#00C4D#) TELUGU VOWEL SIGN O .. TELUGU SIGN VIRAMA - Mn, -- (16#00C55#, 16#00C56#) TELUGU LENGTH MARK .. TELUGU AI LENGTH MARK - Lo, -- (16#00C60#, 16#00C61#) TELUGU LETTER VOCALIC RR .. TELUGU LETTER VOCALIC LL - Nd, -- (16#00C66#, 16#00C6F#) TELUGU DIGIT ZERO .. TELUGU DIGIT NINE - Mc, -- (16#00C82#, 16#00C83#) KANNADA SIGN ANUSVARA .. KANNADA SIGN VISARGA - Lo, -- (16#00C85#, 16#00C8C#) KANNADA LETTER A .. KANNADA LETTER VOCALIC L - Lo, -- (16#00C8E#, 16#00C90#) KANNADA LETTER E .. KANNADA LETTER AI - Lo, -- (16#00C92#, 16#00CA8#) KANNADA LETTER O .. KANNADA LETTER NA - Lo, -- (16#00CAA#, 16#00CB3#) KANNADA LETTER PA .. KANNADA LETTER LLA - Lo, -- (16#00CB5#, 16#00CB9#) KANNADA LETTER VA .. KANNADA LETTER HA - Mn, -- (16#00CBC#, 16#00CBC#) KANNADA SIGN NUKTA .. KANNADA SIGN NUKTA - Lo, -- (16#00CBD#, 16#00CBD#) KANNADA SIGN AVAGRAHA .. KANNADA SIGN AVAGRAHA - Mc, -- (16#00CBE#, 16#00CBE#) KANNADA VOWEL SIGN AA .. KANNADA VOWEL SIGN AA - Mn, -- (16#00CBF#, 16#00CBF#) KANNADA VOWEL SIGN I .. KANNADA VOWEL SIGN I - Mc, -- (16#00CC0#, 16#00CC4#) KANNADA VOWEL SIGN II .. KANNADA VOWEL SIGN VOCALIC RR - Mn, -- (16#00CC6#, 16#00CC6#) KANNADA VOWEL SIGN E .. KANNADA VOWEL SIGN E - Mc, -- (16#00CC7#, 16#00CC8#) KANNADA VOWEL SIGN EE .. KANNADA VOWEL SIGN AI - Mc, -- (16#00CCA#, 16#00CCB#) KANNADA VOWEL SIGN O .. KANNADA VOWEL SIGN OO - Mn, -- (16#00CCC#, 16#00CCD#) KANNADA VOWEL SIGN AU .. KANNADA SIGN VIRAMA - Mc, -- (16#00CD5#, 16#00CD6#) KANNADA LENGTH MARK .. KANNADA AI LENGTH MARK - Lo, -- (16#00CDE#, 16#00CDE#) KANNADA LETTER FA .. KANNADA LETTER FA - Lo, -- (16#00CE0#, 16#00CE1#) KANNADA LETTER VOCALIC RR .. KANNADA LETTER VOCALIC LL - Nd, -- (16#00CE6#, 16#00CEF#) KANNADA DIGIT ZERO .. KANNADA DIGIT NINE - Mc, -- (16#00D02#, 16#00D03#) MALAYALAM SIGN ANUSVARA .. MALAYALAM SIGN VISARGA - Lo, -- (16#00D05#, 16#00D0C#) MALAYALAM LETTER A .. MALAYALAM LETTER VOCALIC L - Lo, -- (16#00D0E#, 16#00D10#) MALAYALAM LETTER E .. MALAYALAM LETTER AI - Lo, -- (16#00D12#, 16#00D28#) MALAYALAM LETTER O .. MALAYALAM LETTER NA - Lo, -- (16#00D2A#, 16#00D39#) MALAYALAM LETTER PA .. MALAYALAM LETTER HA - Mc, -- (16#00D3E#, 16#00D40#) MALAYALAM VOWEL SIGN AA .. MALAYALAM VOWEL SIGN II - Mn, -- (16#00D41#, 16#00D43#) MALAYALAM VOWEL SIGN U .. MALAYALAM VOWEL SIGN VOCALIC R - Mc, -- (16#00D46#, 16#00D48#) MALAYALAM VOWEL SIGN E .. MALAYALAM VOWEL SIGN AI - Mc, -- (16#00D4A#, 16#00D4C#) MALAYALAM VOWEL SIGN O .. MALAYALAM VOWEL SIGN AU - Mn, -- (16#00D4D#, 16#00D4D#) MALAYALAM SIGN VIRAMA .. MALAYALAM SIGN VIRAMA - Mc, -- (16#00D57#, 16#00D57#) MALAYALAM AU LENGTH MARK .. MALAYALAM AU LENGTH MARK - Lo, -- (16#00D60#, 16#00D61#) MALAYALAM LETTER VOCALIC RR .. MALAYALAM LETTER VOCALIC LL - Nd, -- (16#00D66#, 16#00D6F#) MALAYALAM DIGIT ZERO .. MALAYALAM DIGIT NINE - Mc, -- (16#00D82#, 16#00D83#) SINHALA SIGN ANUSVARAYA .. SINHALA SIGN VISARGAYA - Lo, -- (16#00D85#, 16#00D96#) SINHALA LETTER AYANNA .. SINHALA LETTER AUYANNA - Lo, -- (16#00D9A#, 16#00DB1#) SINHALA LETTER ALPAPRAANA KAYANNA .. SINHALA LETTER DANTAJA NAYANNA - Lo, -- (16#00DB3#, 16#00DBB#) SINHALA LETTER SANYAKA DAYANNA .. SINHALA LETTER RAYANNA - Lo, -- (16#00DBD#, 16#00DBD#) SINHALA LETTER DANTAJA LAYANNA .. SINHALA LETTER DANTAJA LAYANNA - Lo, -- (16#00DC0#, 16#00DC6#) SINHALA LETTER VAYANNA .. SINHALA LETTER FAYANNA - Mn, -- (16#00DCA#, 16#00DCA#) SINHALA SIGN AL-LAKUNA .. SINHALA SIGN AL-LAKUNA - Mc, -- (16#00DCF#, 16#00DD1#) SINHALA VOWEL SIGN AELA-PILLA .. SINHALA VOWEL SIGN DIGA AEDA-PILLA - Mn, -- (16#00DD2#, 16#00DD4#) SINHALA VOWEL SIGN KETTI IS-PILLA .. SINHALA VOWEL SIGN KETTI PAA-PILLA - Mn, -- (16#00DD6#, 16#00DD6#) SINHALA VOWEL SIGN DIGA PAA-PILLA .. SINHALA VOWEL SIGN DIGA PAA-PILLA - Mc, -- (16#00DD8#, 16#00DDF#) SINHALA VOWEL SIGN GAETTA-PILLA .. SINHALA VOWEL SIGN GAYANUKITTA - Mc, -- (16#00DF2#, 16#00DF3#) SINHALA VOWEL SIGN DIGA GAETTA-PILLA .. SINHALA VOWEL SIGN DIGA GAYANUKITTA - Po, -- (16#00DF4#, 16#00DF4#) SINHALA PUNCTUATION KUNDDALIYA .. SINHALA PUNCTUATION KUNDDALIYA - Lo, -- (16#00E01#, 16#00E30#) THAI CHARACTER KO KAI .. THAI CHARACTER SARA A - Mn, -- (16#00E31#, 16#00E31#) THAI CHARACTER MAI HAN-AKAT .. THAI CHARACTER MAI HAN-AKAT - Lo, -- (16#00E32#, 16#00E33#) THAI CHARACTER SARA AA .. THAI CHARACTER SARA AM - Mn, -- (16#00E34#, 16#00E3A#) THAI CHARACTER SARA I .. THAI CHARACTER PHINTHU - Sc, -- (16#00E3F#, 16#00E3F#) THAI CURRENCY SYMBOL BAHT .. THAI CURRENCY SYMBOL BAHT - Lo, -- (16#00E40#, 16#00E45#) THAI CHARACTER SARA E .. THAI CHARACTER LAKKHANGYAO - Lm, -- (16#00E46#, 16#00E46#) THAI CHARACTER MAIYAMOK .. THAI CHARACTER MAIYAMOK - Mn, -- (16#00E47#, 16#00E4E#) THAI CHARACTER MAITAIKHU .. THAI CHARACTER YAMAKKAN - Po, -- (16#00E4F#, 16#00E4F#) THAI CHARACTER FONGMAN .. THAI CHARACTER FONGMAN - Nd, -- (16#00E50#, 16#00E59#) THAI DIGIT ZERO .. THAI DIGIT NINE - Po, -- (16#00E5A#, 16#00E5B#) THAI CHARACTER ANGKHANKHU .. THAI CHARACTER KHOMUT - Lo, -- (16#00E81#, 16#00E82#) LAO LETTER KO .. LAO LETTER KHO SUNG - Lo, -- (16#00E84#, 16#00E84#) LAO LETTER KHO TAM .. LAO LETTER KHO TAM - Lo, -- (16#00E87#, 16#00E88#) LAO LETTER NGO .. LAO LETTER CO - Lo, -- (16#00E8A#, 16#00E8A#) LAO LETTER SO TAM .. LAO LETTER SO TAM - Lo, -- (16#00E8D#, 16#00E8D#) LAO LETTER NYO .. LAO LETTER NYO - Lo, -- (16#00E94#, 16#00E97#) LAO LETTER DO .. LAO LETTER THO TAM - Lo, -- (16#00E99#, 16#00E9F#) LAO LETTER NO .. LAO LETTER FO SUNG - Lo, -- (16#00EA1#, 16#00EA3#) LAO LETTER MO .. LAO LETTER LO LING - Lo, -- (16#00EA5#, 16#00EA5#) LAO LETTER LO LOOT .. LAO LETTER LO LOOT - Lo, -- (16#00EA7#, 16#00EA7#) LAO LETTER WO .. LAO LETTER WO - Lo, -- (16#00EAA#, 16#00EAB#) LAO LETTER SO SUNG .. LAO LETTER HO SUNG - Lo, -- (16#00EAD#, 16#00EB0#) LAO LETTER O .. LAO VOWEL SIGN A - Mn, -- (16#00EB1#, 16#00EB1#) LAO VOWEL SIGN MAI KAN .. LAO VOWEL SIGN MAI KAN - Lo, -- (16#00EB2#, 16#00EB3#) LAO VOWEL SIGN AA .. LAO VOWEL SIGN AM - Mn, -- (16#00EB4#, 16#00EB9#) LAO VOWEL SIGN I .. LAO VOWEL SIGN UU - Mn, -- (16#00EBB#, 16#00EBC#) LAO VOWEL SIGN MAI KON .. LAO SEMIVOWEL SIGN LO - Lo, -- (16#00EBD#, 16#00EBD#) LAO SEMIVOWEL SIGN NYO .. LAO SEMIVOWEL SIGN NYO - Lo, -- (16#00EC0#, 16#00EC4#) LAO VOWEL SIGN E .. LAO VOWEL SIGN AI - Lm, -- (16#00EC6#, 16#00EC6#) LAO KO LA .. LAO KO LA - Mn, -- (16#00EC8#, 16#00ECD#) LAO TONE MAI EK .. LAO NIGGAHITA - Nd, -- (16#00ED0#, 16#00ED9#) LAO DIGIT ZERO .. LAO DIGIT NINE - Lo, -- (16#00EDC#, 16#00EDD#) LAO HO NO .. LAO HO MO - Lo, -- (16#00F00#, 16#00F00#) TIBETAN SYLLABLE OM .. TIBETAN SYLLABLE OM - So, -- (16#00F01#, 16#00F03#) TIBETAN MARK GTER YIG MGO TRUNCATED A .. TIBETAN MARK GTER YIG MGO -UM GTER TSHEG MA - Po, -- (16#00F04#, 16#00F12#) TIBETAN MARK INITIAL YIG MGO MDUN MA .. TIBETAN MARK RGYA GRAM SHAD - So, -- (16#00F13#, 16#00F17#) TIBETAN MARK CARET -DZUD RTAGS ME LONG CAN .. TIBETAN ASTROLOGICAL SIGN SGRA GCAN -CHAR RTAGS - Mn, -- (16#00F18#, 16#00F19#) TIBETAN ASTROLOGICAL SIGN -KHYUD PA .. TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS - So, -- (16#00F1A#, 16#00F1F#) TIBETAN SIGN RDEL DKAR GCIG .. TIBETAN SIGN RDEL DKAR RDEL NAG - Nd, -- (16#00F20#, 16#00F29#) TIBETAN DIGIT ZERO .. TIBETAN DIGIT NINE - No, -- (16#00F2A#, 16#00F33#) TIBETAN DIGIT HALF ONE .. TIBETAN DIGIT HALF ZERO - So, -- (16#00F34#, 16#00F34#) TIBETAN MARK BSDUS RTAGS .. TIBETAN MARK BSDUS RTAGS - Mn, -- (16#00F35#, 16#00F35#) TIBETAN MARK NGAS BZUNG NYI ZLA .. TIBETAN MARK NGAS BZUNG NYI ZLA - So, -- (16#00F36#, 16#00F36#) TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN .. TIBETAN MARK CARET -DZUD RTAGS BZHI MIG CAN - Mn, -- (16#00F37#, 16#00F37#) TIBETAN MARK NGAS BZUNG SGOR RTAGS .. TIBETAN MARK NGAS BZUNG SGOR RTAGS - So, -- (16#00F38#, 16#00F38#) TIBETAN MARK CHE MGO .. TIBETAN MARK CHE MGO - Mn, -- (16#00F39#, 16#00F39#) TIBETAN MARK TSA -PHRU .. TIBETAN MARK TSA -PHRU - Ps, -- (16#00F3A#, 16#00F3A#) TIBETAN MARK GUG RTAGS GYON .. TIBETAN MARK GUG RTAGS GYON - Pe, -- (16#00F3B#, 16#00F3B#) TIBETAN MARK GUG RTAGS GYAS .. TIBETAN MARK GUG RTAGS GYAS - Ps, -- (16#00F3C#, 16#00F3C#) TIBETAN MARK ANG KHANG GYON .. TIBETAN MARK ANG KHANG GYON - Pe, -- (16#00F3D#, 16#00F3D#) TIBETAN MARK ANG KHANG GYAS .. TIBETAN MARK ANG KHANG GYAS - Mc, -- (16#00F3E#, 16#00F3F#) TIBETAN SIGN YAR TSHES .. TIBETAN SIGN MAR TSHES - Lo, -- (16#00F40#, 16#00F47#) TIBETAN LETTER KA .. TIBETAN LETTER JA - Lo, -- (16#00F49#, 16#00F6A#) TIBETAN LETTER NYA .. TIBETAN LETTER FIXED-FORM RA - Mn, -- (16#00F71#, 16#00F7E#) TIBETAN VOWEL SIGN AA .. TIBETAN SIGN RJES SU NGA RO - Mc, -- (16#00F7F#, 16#00F7F#) TIBETAN SIGN RNAM BCAD .. TIBETAN SIGN RNAM BCAD - Mn, -- (16#00F80#, 16#00F84#) TIBETAN VOWEL SIGN REVERSED I .. TIBETAN MARK HALANTA - Po, -- (16#00F85#, 16#00F85#) TIBETAN MARK PALUTA .. TIBETAN MARK PALUTA - Mn, -- (16#00F86#, 16#00F87#) TIBETAN SIGN LCI RTAGS .. TIBETAN SIGN YANG RTAGS - Lo, -- (16#00F88#, 16#00F8B#) TIBETAN SIGN LCE TSA CAN .. TIBETAN SIGN GRU MED RGYINGS - Mn, -- (16#00F90#, 16#00F97#) TIBETAN SUBJOINED LETTER KA .. TIBETAN SUBJOINED LETTER JA - Mn, -- (16#00F99#, 16#00FBC#) TIBETAN SUBJOINED LETTER NYA .. TIBETAN SUBJOINED LETTER FIXED-FORM RA - So, -- (16#00FBE#, 16#00FC5#) TIBETAN KU RU KHA .. TIBETAN SYMBOL RDO RJE - Mn, -- (16#00FC6#, 16#00FC6#) TIBETAN SYMBOL PADMA GDAN .. TIBETAN SYMBOL PADMA GDAN - So, -- (16#00FC7#, 16#00FCC#) TIBETAN SYMBOL RDO RJE RGYA GRAM .. TIBETAN SYMBOL NOR BU BZHI -KHYIL - So, -- (16#00FCF#, 16#00FCF#) TIBETAN SIGN RDEL NAG GSUM .. TIBETAN SIGN RDEL NAG GSUM - Lo, -- (16#01000#, 16#01021#) MYANMAR LETTER KA .. MYANMAR LETTER A - Lo, -- (16#01023#, 16#01027#) MYANMAR LETTER I .. MYANMAR LETTER E - Lo, -- (16#01029#, 16#0102A#) MYANMAR LETTER O .. MYANMAR LETTER AU - Mc, -- (16#0102C#, 16#0102C#) MYANMAR VOWEL SIGN AA .. MYANMAR VOWEL SIGN AA - Mn, -- (16#0102D#, 16#01030#) MYANMAR VOWEL SIGN I .. MYANMAR VOWEL SIGN UU - Mc, -- (16#01031#, 16#01031#) MYANMAR VOWEL SIGN E .. MYANMAR VOWEL SIGN E - Mn, -- (16#01032#, 16#01032#) MYANMAR VOWEL SIGN AI .. MYANMAR VOWEL SIGN AI - Mn, -- (16#01036#, 16#01037#) MYANMAR SIGN ANUSVARA .. MYANMAR SIGN DOT BELOW - Mc, -- (16#01038#, 16#01038#) MYANMAR SIGN VISARGA .. MYANMAR SIGN VISARGA - Mn, -- (16#01039#, 16#01039#) MYANMAR SIGN VIRAMA .. MYANMAR SIGN VIRAMA - Nd, -- (16#01040#, 16#01049#) MYANMAR DIGIT ZERO .. MYANMAR DIGIT NINE - Po, -- (16#0104A#, 16#0104F#) MYANMAR SIGN LITTLE SECTION .. MYANMAR SYMBOL GENITIVE - Lo, -- (16#01050#, 16#01055#) MYANMAR LETTER SHA .. MYANMAR LETTER VOCALIC LL - Mc, -- (16#01056#, 16#01057#) MYANMAR VOWEL SIGN VOCALIC R .. MYANMAR VOWEL SIGN VOCALIC RR - Mn, -- (16#01058#, 16#01059#) MYANMAR VOWEL SIGN VOCALIC L .. MYANMAR VOWEL SIGN VOCALIC LL - Lu, -- (16#010A0#, 16#010C5#) GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE - Lo, -- (16#010D0#, 16#010F8#) GEORGIAN LETTER AN .. GEORGIAN LETTER ELIFI - Po, -- (16#010FB#, 16#010FB#) GEORGIAN PARAGRAPH SEPARATOR .. GEORGIAN PARAGRAPH SEPARATOR - Lo, -- (16#01100#, 16#01159#) HANGUL CHOSEONG KIYEOK .. HANGUL CHOSEONG YEORINHIEUH - Lo, -- (16#0115F#, 16#011A2#) HANGUL CHOSEONG FILLER .. HANGUL JUNGSEONG SSANGARAEA - Lo, -- (16#011A8#, 16#011F9#) HANGUL JONGSEONG KIYEOK .. HANGUL JONGSEONG YEORINHIEUH - Lo, -- (16#01200#, 16#01206#) ETHIOPIC SYLLABLE HA .. ETHIOPIC SYLLABLE HO - Lo, -- (16#01208#, 16#01246#) ETHIOPIC SYLLABLE LA .. ETHIOPIC SYLLABLE QO - Lo, -- (16#01248#, 16#01248#) ETHIOPIC SYLLABLE QWA .. ETHIOPIC SYLLABLE QWA - Lo, -- (16#0124A#, 16#0124D#) ETHIOPIC SYLLABLE QWI .. ETHIOPIC SYLLABLE QWE - Lo, -- (16#01250#, 16#01256#) ETHIOPIC SYLLABLE QHA .. ETHIOPIC SYLLABLE QHO - Lo, -- (16#01258#, 16#01258#) ETHIOPIC SYLLABLE QHWA .. ETHIOPIC SYLLABLE QHWA - Lo, -- (16#0125A#, 16#0125D#) ETHIOPIC SYLLABLE QHWI .. ETHIOPIC SYLLABLE QHWE - Lo, -- (16#01260#, 16#01286#) ETHIOPIC SYLLABLE BA .. ETHIOPIC SYLLABLE XO - Lo, -- (16#01288#, 16#01288#) ETHIOPIC SYLLABLE XWA .. ETHIOPIC SYLLABLE XWA - Lo, -- (16#0128A#, 16#0128D#) ETHIOPIC SYLLABLE XWI .. ETHIOPIC SYLLABLE XWE - Lo, -- (16#01290#, 16#012AE#) ETHIOPIC SYLLABLE NA .. ETHIOPIC SYLLABLE KO - Lo, -- (16#012B0#, 16#012B0#) ETHIOPIC SYLLABLE KWA .. ETHIOPIC SYLLABLE KWA - Lo, -- (16#012B2#, 16#012B5#) ETHIOPIC SYLLABLE KWI .. ETHIOPIC SYLLABLE KWE - Lo, -- (16#012B8#, 16#012BE#) ETHIOPIC SYLLABLE KXA .. ETHIOPIC SYLLABLE KXO - Lo, -- (16#012C0#, 16#012C0#) ETHIOPIC SYLLABLE KXWA .. ETHIOPIC SYLLABLE KXWA - Lo, -- (16#012C2#, 16#012C5#) ETHIOPIC SYLLABLE KXWI .. ETHIOPIC SYLLABLE KXWE - Lo, -- (16#012C8#, 16#012CE#) ETHIOPIC SYLLABLE WA .. ETHIOPIC SYLLABLE WO - Lo, -- (16#012D0#, 16#012D6#) ETHIOPIC SYLLABLE PHARYNGEAL A .. ETHIOPIC SYLLABLE PHARYNGEAL O - Lo, -- (16#012D8#, 16#012EE#) ETHIOPIC SYLLABLE ZA .. ETHIOPIC SYLLABLE YO - Lo, -- (16#012F0#, 16#0130E#) ETHIOPIC SYLLABLE DA .. ETHIOPIC SYLLABLE GO - Lo, -- (16#01310#, 16#01310#) ETHIOPIC SYLLABLE GWA .. ETHIOPIC SYLLABLE GWA - Lo, -- (16#01312#, 16#01315#) ETHIOPIC SYLLABLE GWI .. ETHIOPIC SYLLABLE GWE - Lo, -- (16#01318#, 16#0131E#) ETHIOPIC SYLLABLE GGA .. ETHIOPIC SYLLABLE GGO - Lo, -- (16#01320#, 16#01346#) ETHIOPIC SYLLABLE THA .. ETHIOPIC SYLLABLE TZO - Lo, -- (16#01348#, 16#0135A#) ETHIOPIC SYLLABLE FA .. ETHIOPIC SYLLABLE FYA - Po, -- (16#01361#, 16#01368#) ETHIOPIC WORDSPACE .. ETHIOPIC PARAGRAPH SEPARATOR - Nd, -- (16#01369#, 16#01371#) ETHIOPIC DIGIT ONE .. ETHIOPIC DIGIT NINE - No, -- (16#01372#, 16#0137C#) ETHIOPIC NUMBER TEN .. ETHIOPIC NUMBER TEN THOUSAND - Lo, -- (16#013A0#, 16#013F4#) CHEROKEE LETTER A .. CHEROKEE LETTER YV - Lo, -- (16#01401#, 16#0166C#) CANADIAN SYLLABICS E .. CANADIAN SYLLABICS CARRIER TTSA - Po, -- (16#0166D#, 16#0166E#) CANADIAN SYLLABICS CHI SIGN .. CANADIAN SYLLABICS FULL STOP - Lo, -- (16#0166F#, 16#01676#) CANADIAN SYLLABICS QAI .. CANADIAN SYLLABICS NNGAA - Zs, -- (16#01680#, 16#01680#) OGHAM SPACE MARK .. OGHAM SPACE MARK - Lo, -- (16#01681#, 16#0169A#) OGHAM LETTER BEITH .. OGHAM LETTER PEITH - Ps, -- (16#0169B#, 16#0169B#) OGHAM FEATHER MARK .. OGHAM FEATHER MARK - Pe, -- (16#0169C#, 16#0169C#) OGHAM REVERSED FEATHER MARK .. OGHAM REVERSED FEATHER MARK - Lo, -- (16#016A0#, 16#016EA#) RUNIC LETTER FEHU FEOH FE F .. RUNIC LETTER X - Po, -- (16#016EB#, 16#016ED#) RUNIC SINGLE PUNCTUATION .. RUNIC CROSS PUNCTUATION - Nl, -- (16#016EE#, 16#016F0#) RUNIC ARLAUG SYMBOL .. RUNIC BELGTHOR SYMBOL - Lo, -- (16#01700#, 16#0170C#) TAGALOG LETTER A .. TAGALOG LETTER YA - Lo, -- (16#0170E#, 16#01711#) TAGALOG LETTER LA .. TAGALOG LETTER HA - Mn, -- (16#01712#, 16#01714#) TAGALOG VOWEL SIGN I .. TAGALOG SIGN VIRAMA - Lo, -- (16#01720#, 16#01731#) HANUNOO LETTER A .. HANUNOO LETTER HA - Mn, -- (16#01732#, 16#01734#) HANUNOO VOWEL SIGN I .. HANUNOO SIGN PAMUDPOD - Po, -- (16#01735#, 16#01736#) PHILIPPINE SINGLE PUNCTUATION .. PHILIPPINE DOUBLE PUNCTUATION - Lo, -- (16#01740#, 16#01751#) BUHID LETTER A .. BUHID LETTER HA - Mn, -- (16#01752#, 16#01753#) BUHID VOWEL SIGN I .. BUHID VOWEL SIGN U - Lo, -- (16#01760#, 16#0176C#) TAGBANWA LETTER A .. TAGBANWA LETTER YA - Lo, -- (16#0176E#, 16#01770#) TAGBANWA LETTER LA .. TAGBANWA LETTER SA - Mn, -- (16#01772#, 16#01773#) TAGBANWA VOWEL SIGN I .. TAGBANWA VOWEL SIGN U - Lo, -- (16#01780#, 16#017B3#) KHMER LETTER KA .. KHMER INDEPENDENT VOWEL QAU - Cf, -- (16#017B4#, 16#017B5#) KHMER VOWEL INHERENT AQ .. KHMER VOWEL INHERENT AA - Mc, -- (16#017B6#, 16#017B6#) KHMER VOWEL SIGN AA .. KHMER VOWEL SIGN AA - Mn, -- (16#017B7#, 16#017BD#) KHMER VOWEL SIGN I .. KHMER VOWEL SIGN UA - Mc, -- (16#017BE#, 16#017C5#) KHMER VOWEL SIGN OE .. KHMER VOWEL SIGN AU - Mn, -- (16#017C6#, 16#017C6#) KHMER SIGN NIKAHIT .. KHMER SIGN NIKAHIT - Mc, -- (16#017C7#, 16#017C8#) KHMER SIGN REAHMUK .. KHMER SIGN YUUKALEAPINTU - Mn, -- (16#017C9#, 16#017D3#) KHMER SIGN MUUSIKATOAN .. KHMER SIGN BATHAMASAT - Po, -- (16#017D4#, 16#017D6#) KHMER SIGN KHAN .. KHMER SIGN CAMNUC PII KUUH - Lm, -- (16#017D7#, 16#017D7#) KHMER SIGN LEK TOO .. KHMER SIGN LEK TOO - Po, -- (16#017D8#, 16#017DA#) KHMER SIGN BEYYAL .. KHMER SIGN KOOMUUT - Sc, -- (16#017DB#, 16#017DB#) KHMER CURRENCY SYMBOL RIEL .. KHMER CURRENCY SYMBOL RIEL - Lo, -- (16#017DC#, 16#017DC#) KHMER SIGN AVAKRAHASANYA .. KHMER SIGN AVAKRAHASANYA - Mn, -- (16#017DD#, 16#017DD#) KHMER SIGN ATTHACAN .. KHMER SIGN ATTHACAN - Nd, -- (16#017E0#, 16#017E9#) KHMER DIGIT ZERO .. KHMER DIGIT NINE - No, -- (16#017F0#, 16#017F9#) KHMER SYMBOL LEK ATTAK SON .. KHMER SYMBOL LEK ATTAK PRAM-BUON - Po, -- (16#01800#, 16#01805#) MONGOLIAN BIRGA .. MONGOLIAN FOUR DOTS - Pd, -- (16#01806#, 16#01806#) MONGOLIAN TODO SOFT HYPHEN .. MONGOLIAN TODO SOFT HYPHEN - Po, -- (16#01807#, 16#0180A#) MONGOLIAN SIBE SYLLABLE BOUNDARY MARKER .. MONGOLIAN NIRUGU - Mn, -- (16#0180B#, 16#0180D#) MONGOLIAN FREE VARIATION SELECTOR ONE .. MONGOLIAN FREE VARIATION SELECTOR THREE - Zs, -- (16#0180E#, 16#0180E#) MONGOLIAN VOWEL SEPARATOR .. MONGOLIAN VOWEL SEPARATOR - Nd, -- (16#01810#, 16#01819#) MONGOLIAN DIGIT ZERO .. MONGOLIAN DIGIT NINE - Lo, -- (16#01820#, 16#01842#) MONGOLIAN LETTER A .. MONGOLIAN LETTER CHI - Lm, -- (16#01843#, 16#01843#) MONGOLIAN LETTER TODO LONG VOWEL SIGN .. MONGOLIAN LETTER TODO LONG VOWEL SIGN - Lo, -- (16#01844#, 16#01877#) MONGOLIAN LETTER TODO E .. MONGOLIAN LETTER MANCHU ZHA - Lo, -- (16#01880#, 16#018A8#) MONGOLIAN LETTER ALI GALI ANUSVARA ONE .. MONGOLIAN LETTER MANCHU ALI GALI BHA - Mn, -- (16#018A9#, 16#018A9#) MONGOLIAN LETTER ALI GALI DAGALGA .. MONGOLIAN LETTER ALI GALI DAGALGA - Lo, -- (16#01900#, 16#0191C#) LIMBU VOWEL-CARRIER LETTER .. LIMBU LETTER HA - Mn, -- (16#01920#, 16#01922#) LIMBU VOWEL SIGN A .. LIMBU VOWEL SIGN U - Mc, -- (16#01923#, 16#01926#) LIMBU VOWEL SIGN EE .. LIMBU VOWEL SIGN AU - Mn, -- (16#01927#, 16#01928#) LIMBU VOWEL SIGN E .. LIMBU VOWEL SIGN O - Mc, -- (16#01929#, 16#0192B#) LIMBU SUBJOINED LETTER YA .. LIMBU SUBJOINED LETTER WA - Mc, -- (16#01930#, 16#01931#) LIMBU SMALL LETTER KA .. LIMBU SMALL LETTER NGA - Mn, -- (16#01932#, 16#01932#) LIMBU SMALL LETTER ANUSVARA .. LIMBU SMALL LETTER ANUSVARA - Mc, -- (16#01933#, 16#01938#) LIMBU SMALL LETTER TA .. LIMBU SMALL LETTER LA - Mn, -- (16#01939#, 16#0193B#) LIMBU SIGN MUKPHRENG .. LIMBU SIGN SA-I - So, -- (16#01940#, 16#01940#) LIMBU SIGN LOO .. LIMBU SIGN LOO - Po, -- (16#01944#, 16#01945#) LIMBU EXCLAMATION MARK .. LIMBU QUESTION MARK - Nd, -- (16#01946#, 16#0194F#) LIMBU DIGIT ZERO .. LIMBU DIGIT NINE - Lo, -- (16#01950#, 16#0196D#) TAI LE LETTER KA .. TAI LE LETTER AI - Lo, -- (16#01970#, 16#01974#) TAI LE LETTER TONE-2 .. TAI LE LETTER TONE-6 - So, -- (16#019E0#, 16#019FF#) KHMER SYMBOL PATHAMASAT .. KHMER SYMBOL DAP-PRAM ROC - Ll, -- (16#01D00#, 16#01D2B#) LATIN LETTER SMALL CAPITAL A .. CYRILLIC LETTER SMALL CAPITAL EL - Lm, -- (16#01D2C#, 16#01D61#) MODIFIER LETTER CAPITAL A .. MODIFIER LETTER SMALL CHI - Ll, -- (16#01D62#, 16#01D6B#) LATIN SUBSCRIPT SMALL LETTER I .. LATIN SMALL LETTER UE - Lu, -- (16#01E00#, 16#01E00#) LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW - Ll, -- (16#01E01#, 16#01E01#) LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW - Lu, -- (16#01E02#, 16#01E02#) LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE - Ll, -- (16#01E03#, 16#01E03#) LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE - Lu, -- (16#01E04#, 16#01E04#) LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW - Ll, -- (16#01E05#, 16#01E05#) LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW - Lu, -- (16#01E06#, 16#01E06#) LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW - Ll, -- (16#01E07#, 16#01E07#) LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW - Lu, -- (16#01E08#, 16#01E08#) LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE - Ll, -- (16#01E09#, 16#01E09#) LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE - Lu, -- (16#01E0A#, 16#01E0A#) LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE - Ll, -- (16#01E0B#, 16#01E0B#) LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE - Lu, -- (16#01E0C#, 16#01E0C#) LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW - Ll, -- (16#01E0D#, 16#01E0D#) LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW - Lu, -- (16#01E0E#, 16#01E0E#) LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW - Ll, -- (16#01E0F#, 16#01E0F#) LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW - Lu, -- (16#01E10#, 16#01E10#) LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA - Ll, -- (16#01E11#, 16#01E11#) LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA - Lu, -- (16#01E12#, 16#01E12#) LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW - Ll, -- (16#01E13#, 16#01E13#) LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW - Lu, -- (16#01E14#, 16#01E14#) LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE - Ll, -- (16#01E15#, 16#01E15#) LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE - Lu, -- (16#01E16#, 16#01E16#) LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE - Ll, -- (16#01E17#, 16#01E17#) LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE - Lu, -- (16#01E18#, 16#01E18#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW - Ll, -- (16#01E19#, 16#01E19#) LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW - Lu, -- (16#01E1A#, 16#01E1A#) LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW - Ll, -- (16#01E1B#, 16#01E1B#) LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW - Lu, -- (16#01E1C#, 16#01E1C#) LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE - Ll, -- (16#01E1D#, 16#01E1D#) LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE - Lu, -- (16#01E1E#, 16#01E1E#) LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE - Ll, -- (16#01E1F#, 16#01E1F#) LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE - Lu, -- (16#01E20#, 16#01E20#) LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON - Ll, -- (16#01E21#, 16#01E21#) LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON - Lu, -- (16#01E22#, 16#01E22#) LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE - Ll, -- (16#01E23#, 16#01E23#) LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE - Lu, -- (16#01E24#, 16#01E24#) LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW - Ll, -- (16#01E25#, 16#01E25#) LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW - Lu, -- (16#01E26#, 16#01E26#) LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS - Ll, -- (16#01E27#, 16#01E27#) LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS - Lu, -- (16#01E28#, 16#01E28#) LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA - Ll, -- (16#01E29#, 16#01E29#) LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA - Lu, -- (16#01E2A#, 16#01E2A#) LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW - Ll, -- (16#01E2B#, 16#01E2B#) LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW - Lu, -- (16#01E2C#, 16#01E2C#) LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW - Ll, -- (16#01E2D#, 16#01E2D#) LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW - Lu, -- (16#01E2E#, 16#01E2E#) LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE - Ll, -- (16#01E2F#, 16#01E2F#) LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE - Lu, -- (16#01E30#, 16#01E30#) LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE - Ll, -- (16#01E31#, 16#01E31#) LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE - Lu, -- (16#01E32#, 16#01E32#) LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW - Ll, -- (16#01E33#, 16#01E33#) LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW - Lu, -- (16#01E34#, 16#01E34#) LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW - Ll, -- (16#01E35#, 16#01E35#) LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW - Lu, -- (16#01E36#, 16#01E36#) LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW - Ll, -- (16#01E37#, 16#01E37#) LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW - Lu, -- (16#01E38#, 16#01E38#) LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON - Ll, -- (16#01E39#, 16#01E39#) LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON - Lu, -- (16#01E3A#, 16#01E3A#) LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW - Ll, -- (16#01E3B#, 16#01E3B#) LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW - Lu, -- (16#01E3C#, 16#01E3C#) LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW - Ll, -- (16#01E3D#, 16#01E3D#) LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW - Lu, -- (16#01E3E#, 16#01E3E#) LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE - Ll, -- (16#01E3F#, 16#01E3F#) LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE - Lu, -- (16#01E40#, 16#01E40#) LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE - Ll, -- (16#01E41#, 16#01E41#) LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE - Lu, -- (16#01E42#, 16#01E42#) LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW - Ll, -- (16#01E43#, 16#01E43#) LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW - Lu, -- (16#01E44#, 16#01E44#) LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE - Ll, -- (16#01E45#, 16#01E45#) LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE - Lu, -- (16#01E46#, 16#01E46#) LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW - Ll, -- (16#01E47#, 16#01E47#) LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW - Lu, -- (16#01E48#, 16#01E48#) LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW - Ll, -- (16#01E49#, 16#01E49#) LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW - Lu, -- (16#01E4A#, 16#01E4A#) LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW - Ll, -- (16#01E4B#, 16#01E4B#) LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW - Lu, -- (16#01E4C#, 16#01E4C#) LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE - Ll, -- (16#01E4D#, 16#01E4D#) LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE - Lu, -- (16#01E4E#, 16#01E4E#) LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS - Ll, -- (16#01E4F#, 16#01E4F#) LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS - Lu, -- (16#01E50#, 16#01E50#) LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE - Ll, -- (16#01E51#, 16#01E51#) LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE - Lu, -- (16#01E52#, 16#01E52#) LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE - Ll, -- (16#01E53#, 16#01E53#) LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE - Lu, -- (16#01E54#, 16#01E54#) LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE - Ll, -- (16#01E55#, 16#01E55#) LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE - Lu, -- (16#01E56#, 16#01E56#) LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE - Ll, -- (16#01E57#, 16#01E57#) LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE - Lu, -- (16#01E58#, 16#01E58#) LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE - Ll, -- (16#01E59#, 16#01E59#) LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE - Lu, -- (16#01E5A#, 16#01E5A#) LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW - Ll, -- (16#01E5B#, 16#01E5B#) LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW - Lu, -- (16#01E5C#, 16#01E5C#) LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON - Ll, -- (16#01E5D#, 16#01E5D#) LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON - Lu, -- (16#01E5E#, 16#01E5E#) LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW - Ll, -- (16#01E5F#, 16#01E5F#) LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW - Lu, -- (16#01E60#, 16#01E60#) LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE - Ll, -- (16#01E61#, 16#01E61#) LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE - Lu, -- (16#01E62#, 16#01E62#) LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW - Ll, -- (16#01E63#, 16#01E63#) LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW - Lu, -- (16#01E64#, 16#01E64#) LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE - Ll, -- (16#01E65#, 16#01E65#) LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE - Lu, -- (16#01E66#, 16#01E66#) LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE - Ll, -- (16#01E67#, 16#01E67#) LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE - Lu, -- (16#01E68#, 16#01E68#) LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE - Ll, -- (16#01E69#, 16#01E69#) LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE - Lu, -- (16#01E6A#, 16#01E6A#) LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE - Ll, -- (16#01E6B#, 16#01E6B#) LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE - Lu, -- (16#01E6C#, 16#01E6C#) LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW - Ll, -- (16#01E6D#, 16#01E6D#) LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW - Lu, -- (16#01E6E#, 16#01E6E#) LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW - Ll, -- (16#01E6F#, 16#01E6F#) LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW - Lu, -- (16#01E70#, 16#01E70#) LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW - Ll, -- (16#01E71#, 16#01E71#) LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW - Lu, -- (16#01E72#, 16#01E72#) LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW - Ll, -- (16#01E73#, 16#01E73#) LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW - Lu, -- (16#01E74#, 16#01E74#) LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW - Ll, -- (16#01E75#, 16#01E75#) LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW - Lu, -- (16#01E76#, 16#01E76#) LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW - Ll, -- (16#01E77#, 16#01E77#) LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW - Lu, -- (16#01E78#, 16#01E78#) LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE - Ll, -- (16#01E79#, 16#01E79#) LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE - Lu, -- (16#01E7A#, 16#01E7A#) LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS - Ll, -- (16#01E7B#, 16#01E7B#) LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS - Lu, -- (16#01E7C#, 16#01E7C#) LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE - Ll, -- (16#01E7D#, 16#01E7D#) LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE - Lu, -- (16#01E7E#, 16#01E7E#) LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW - Ll, -- (16#01E7F#, 16#01E7F#) LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW - Lu, -- (16#01E80#, 16#01E80#) LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE - Ll, -- (16#01E81#, 16#01E81#) LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE - Lu, -- (16#01E82#, 16#01E82#) LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE - Ll, -- (16#01E83#, 16#01E83#) LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE - Lu, -- (16#01E84#, 16#01E84#) LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS - Ll, -- (16#01E85#, 16#01E85#) LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS - Lu, -- (16#01E86#, 16#01E86#) LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE - Ll, -- (16#01E87#, 16#01E87#) LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE - Lu, -- (16#01E88#, 16#01E88#) LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW - Ll, -- (16#01E89#, 16#01E89#) LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW - Lu, -- (16#01E8A#, 16#01E8A#) LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE - Ll, -- (16#01E8B#, 16#01E8B#) LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE - Lu, -- (16#01E8C#, 16#01E8C#) LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS - Ll, -- (16#01E8D#, 16#01E8D#) LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS - Lu, -- (16#01E8E#, 16#01E8E#) LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE - Ll, -- (16#01E8F#, 16#01E8F#) LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE - Lu, -- (16#01E90#, 16#01E90#) LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX - Ll, -- (16#01E91#, 16#01E91#) LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX - Lu, -- (16#01E92#, 16#01E92#) LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW - Ll, -- (16#01E93#, 16#01E93#) LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW - Lu, -- (16#01E94#, 16#01E94#) LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW - Ll, -- (16#01E95#, 16#01E9B#) LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER LONG S WITH DOT ABOVE - Lu, -- (16#01EA0#, 16#01EA0#) LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW - Ll, -- (16#01EA1#, 16#01EA1#) LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW - Lu, -- (16#01EA2#, 16#01EA2#) LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE - Ll, -- (16#01EA3#, 16#01EA3#) LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE - Lu, -- (16#01EA4#, 16#01EA4#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE - Ll, -- (16#01EA5#, 16#01EA5#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE - Lu, -- (16#01EA6#, 16#01EA6#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE - Ll, -- (16#01EA7#, 16#01EA7#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE - Lu, -- (16#01EA8#, 16#01EA8#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - Ll, -- (16#01EA9#, 16#01EA9#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - Lu, -- (16#01EAA#, 16#01EAA#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE - Ll, -- (16#01EAB#, 16#01EAB#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE - Lu, -- (16#01EAC#, 16#01EAC#) LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW - Ll, -- (16#01EAD#, 16#01EAD#) LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW - Lu, -- (16#01EAE#, 16#01EAE#) LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE - Ll, -- (16#01EAF#, 16#01EAF#) LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE - Lu, -- (16#01EB0#, 16#01EB0#) LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE - Ll, -- (16#01EB1#, 16#01EB1#) LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE - Lu, -- (16#01EB2#, 16#01EB2#) LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE - Ll, -- (16#01EB3#, 16#01EB3#) LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE - Lu, -- (16#01EB4#, 16#01EB4#) LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE - Ll, -- (16#01EB5#, 16#01EB5#) LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE - Lu, -- (16#01EB6#, 16#01EB6#) LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW - Ll, -- (16#01EB7#, 16#01EB7#) LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW - Lu, -- (16#01EB8#, 16#01EB8#) LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW - Ll, -- (16#01EB9#, 16#01EB9#) LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW - Lu, -- (16#01EBA#, 16#01EBA#) LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE - Ll, -- (16#01EBB#, 16#01EBB#) LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE - Lu, -- (16#01EBC#, 16#01EBC#) LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE - Ll, -- (16#01EBD#, 16#01EBD#) LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE - Lu, -- (16#01EBE#, 16#01EBE#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE - Ll, -- (16#01EBF#, 16#01EBF#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE - Lu, -- (16#01EC0#, 16#01EC0#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE - Ll, -- (16#01EC1#, 16#01EC1#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE - Lu, -- (16#01EC2#, 16#01EC2#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - Ll, -- (16#01EC3#, 16#01EC3#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - Lu, -- (16#01EC4#, 16#01EC4#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE - Ll, -- (16#01EC5#, 16#01EC5#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE - Lu, -- (16#01EC6#, 16#01EC6#) LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW - Ll, -- (16#01EC7#, 16#01EC7#) LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW - Lu, -- (16#01EC8#, 16#01EC8#) LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE - Ll, -- (16#01EC9#, 16#01EC9#) LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE - Lu, -- (16#01ECA#, 16#01ECA#) LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW - Ll, -- (16#01ECB#, 16#01ECB#) LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW - Lu, -- (16#01ECC#, 16#01ECC#) LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW - Ll, -- (16#01ECD#, 16#01ECD#) LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW - Lu, -- (16#01ECE#, 16#01ECE#) LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE - Ll, -- (16#01ECF#, 16#01ECF#) LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE - Lu, -- (16#01ED0#, 16#01ED0#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE - Ll, -- (16#01ED1#, 16#01ED1#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE - Lu, -- (16#01ED2#, 16#01ED2#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE - Ll, -- (16#01ED3#, 16#01ED3#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE - Lu, -- (16#01ED4#, 16#01ED4#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - Ll, -- (16#01ED5#, 16#01ED5#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - Lu, -- (16#01ED6#, 16#01ED6#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE - Ll, -- (16#01ED7#, 16#01ED7#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE - Lu, -- (16#01ED8#, 16#01ED8#) LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW - Ll, -- (16#01ED9#, 16#01ED9#) LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW - Lu, -- (16#01EDA#, 16#01EDA#) LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE - Ll, -- (16#01EDB#, 16#01EDB#) LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE - Lu, -- (16#01EDC#, 16#01EDC#) LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE - Ll, -- (16#01EDD#, 16#01EDD#) LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE - Lu, -- (16#01EDE#, 16#01EDE#) LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE - Ll, -- (16#01EDF#, 16#01EDF#) LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE - Lu, -- (16#01EE0#, 16#01EE0#) LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE - Ll, -- (16#01EE1#, 16#01EE1#) LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE - Lu, -- (16#01EE2#, 16#01EE2#) LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW - Ll, -- (16#01EE3#, 16#01EE3#) LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW - Lu, -- (16#01EE4#, 16#01EE4#) LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW - Ll, -- (16#01EE5#, 16#01EE5#) LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW - Lu, -- (16#01EE6#, 16#01EE6#) LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE - Ll, -- (16#01EE7#, 16#01EE7#) LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE - Lu, -- (16#01EE8#, 16#01EE8#) LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE - Ll, -- (16#01EE9#, 16#01EE9#) LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE - Lu, -- (16#01EEA#, 16#01EEA#) LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE - Ll, -- (16#01EEB#, 16#01EEB#) LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE - Lu, -- (16#01EEC#, 16#01EEC#) LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE - Ll, -- (16#01EED#, 16#01EED#) LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE - Lu, -- (16#01EEE#, 16#01EEE#) LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE - Ll, -- (16#01EEF#, 16#01EEF#) LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE - Lu, -- (16#01EF0#, 16#01EF0#) LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW - Ll, -- (16#01EF1#, 16#01EF1#) LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW - Lu, -- (16#01EF2#, 16#01EF2#) LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE - Ll, -- (16#01EF3#, 16#01EF3#) LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE - Lu, -- (16#01EF4#, 16#01EF4#) LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW - Ll, -- (16#01EF5#, 16#01EF5#) LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW - Lu, -- (16#01EF6#, 16#01EF6#) LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE - Ll, -- (16#01EF7#, 16#01EF7#) LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE - Lu, -- (16#01EF8#, 16#01EF8#) LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE - Ll, -- (16#01EF9#, 16#01EF9#) LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE - Ll, -- (16#01F00#, 16#01F07#) GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI - Lu, -- (16#01F08#, 16#01F0F#) GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI - Ll, -- (16#01F10#, 16#01F15#) GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA - Lu, -- (16#01F18#, 16#01F1D#) GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA - Ll, -- (16#01F20#, 16#01F27#) GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI - Lu, -- (16#01F28#, 16#01F2F#) GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI - Ll, -- (16#01F30#, 16#01F37#) GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI - Lu, -- (16#01F38#, 16#01F3F#) GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI - Ll, -- (16#01F40#, 16#01F45#) GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA - Lu, -- (16#01F48#, 16#01F4D#) GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA - Ll, -- (16#01F50#, 16#01F57#) GREEK SMALL LETTER UPSILON WITH PSILI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI - Lu, -- (16#01F59#, 16#01F59#) GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA - Lu, -- (16#01F5B#, 16#01F5B#) GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA - Lu, -- (16#01F5D#, 16#01F5D#) GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA - Lu, -- (16#01F5F#, 16#01F5F#) GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI - Ll, -- (16#01F60#, 16#01F67#) GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI - Lu, -- (16#01F68#, 16#01F6F#) GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI - Ll, -- (16#01F70#, 16#01F7D#) GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA - Ll, -- (16#01F80#, 16#01F87#) GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - Lt, -- (16#01F88#, 16#01F8F#) GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - Ll, -- (16#01F90#, 16#01F97#) GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - Lt, -- (16#01F98#, 16#01F9F#) GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - Ll, -- (16#01FA0#, 16#01FA7#) GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - Lt, -- (16#01FA8#, 16#01FAF#) GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - Ll, -- (16#01FB0#, 16#01FB4#) GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI - Ll, -- (16#01FB6#, 16#01FB7#) GREEK SMALL LETTER ALPHA WITH PERISPOMENI .. GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI - Lu, -- (16#01FB8#, 16#01FBB#) GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH OXIA - Lt, -- (16#01FBC#, 16#01FBC#) GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI - Sk, -- (16#01FBD#, 16#01FBD#) GREEK KORONIS .. GREEK KORONIS - Ll, -- (16#01FBE#, 16#01FBE#) GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI - Sk, -- (16#01FBF#, 16#01FC1#) GREEK PSILI .. GREEK DIALYTIKA AND PERISPOMENI - Ll, -- (16#01FC2#, 16#01FC4#) GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI - Ll, -- (16#01FC6#, 16#01FC7#) GREEK SMALL LETTER ETA WITH PERISPOMENI .. GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI - Lu, -- (16#01FC8#, 16#01FCB#) GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA - Lt, -- (16#01FCC#, 16#01FCC#) GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI - Sk, -- (16#01FCD#, 16#01FCF#) GREEK PSILI AND VARIA .. GREEK PSILI AND PERISPOMENI - Ll, -- (16#01FD0#, 16#01FD3#) GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA - Ll, -- (16#01FD6#, 16#01FD7#) GREEK SMALL LETTER IOTA WITH PERISPOMENI .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI - Lu, -- (16#01FD8#, 16#01FDB#) GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH OXIA - Sk, -- (16#01FDD#, 16#01FDF#) GREEK DASIA AND VARIA .. GREEK DASIA AND PERISPOMENI - Ll, -- (16#01FE0#, 16#01FE7#) GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI - Lu, -- (16#01FE8#, 16#01FEC#) GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER RHO WITH DASIA - Sk, -- (16#01FED#, 16#01FEF#) GREEK DIALYTIKA AND VARIA .. GREEK VARIA - Ll, -- (16#01FF2#, 16#01FF4#) GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI - Ll, -- (16#01FF6#, 16#01FF7#) GREEK SMALL LETTER OMEGA WITH PERISPOMENI .. GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI - Lu, -- (16#01FF8#, 16#01FFB#) GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA - Lt, -- (16#01FFC#, 16#01FFC#) GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI .. GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI - Sk, -- (16#01FFD#, 16#01FFE#) GREEK OXIA .. GREEK DASIA - Zs, -- (16#02000#, 16#0200B#) EN QUAD .. ZERO WIDTH SPACE - Cf, -- (16#0200C#, 16#0200F#) ZERO WIDTH NON-JOINER .. RIGHT-TO-LEFT MARK - Pd, -- (16#02010#, 16#02015#) HYPHEN .. HORIZONTAL BAR - Po, -- (16#02016#, 16#02017#) DOUBLE VERTICAL LINE .. DOUBLE LOW LINE - Pi, -- (16#02018#, 16#02018#) LEFT SINGLE QUOTATION MARK .. LEFT SINGLE QUOTATION MARK - Pf, -- (16#02019#, 16#02019#) RIGHT SINGLE QUOTATION MARK .. RIGHT SINGLE QUOTATION MARK - Ps, -- (16#0201A#, 16#0201A#) SINGLE LOW-9 QUOTATION MARK .. SINGLE LOW-9 QUOTATION MARK - Pi, -- (16#0201B#, 16#0201C#) SINGLE HIGH-REVERSED-9 QUOTATION MARK .. LEFT DOUBLE QUOTATION MARK - Pf, -- (16#0201D#, 16#0201D#) RIGHT DOUBLE QUOTATION MARK .. RIGHT DOUBLE QUOTATION MARK - Ps, -- (16#0201E#, 16#0201E#) DOUBLE LOW-9 QUOTATION MARK .. DOUBLE LOW-9 QUOTATION MARK - Pi, -- (16#0201F#, 16#0201F#) DOUBLE HIGH-REVERSED-9 QUOTATION MARK .. DOUBLE HIGH-REVERSED-9 QUOTATION MARK - Po, -- (16#02020#, 16#02027#) DAGGER .. HYPHENATION POINT - Zl, -- (16#02028#, 16#02028#) LINE SEPARATOR .. LINE SEPARATOR - Zp, -- (16#02029#, 16#02029#) PARAGRAPH SEPARATOR .. PARAGRAPH SEPARATOR - Cf, -- (16#0202A#, 16#0202E#) LEFT-TO-RIGHT EMBEDDING .. RIGHT-TO-LEFT OVERRIDE - Zs, -- (16#0202F#, 16#0202F#) NARROW NO-BREAK SPACE .. NARROW NO-BREAK SPACE - Po, -- (16#02030#, 16#02038#) PER MILLE SIGN .. CARET - Pi, -- (16#02039#, 16#02039#) SINGLE LEFT-POINTING ANGLE QUOTATION MARK .. SINGLE LEFT-POINTING ANGLE QUOTATION MARK - Pf, -- (16#0203A#, 16#0203A#) SINGLE RIGHT-POINTING ANGLE QUOTATION MARK .. SINGLE RIGHT-POINTING ANGLE QUOTATION MARK - Po, -- (16#0203B#, 16#0203E#) REFERENCE MARK .. OVERLINE - Pc, -- (16#0203F#, 16#02040#) UNDERTIE .. CHARACTER TIE - Po, -- (16#02041#, 16#02043#) CARET INSERTION POINT .. HYPHEN BULLET - Sm, -- (16#02044#, 16#02044#) FRACTION SLASH .. FRACTION SLASH - Ps, -- (16#02045#, 16#02045#) LEFT SQUARE BRACKET WITH QUILL .. LEFT SQUARE BRACKET WITH QUILL - Pe, -- (16#02046#, 16#02046#) RIGHT SQUARE BRACKET WITH QUILL .. RIGHT SQUARE BRACKET WITH QUILL - Po, -- (16#02047#, 16#02051#) DOUBLE QUESTION MARK .. TWO ASTERISKS ALIGNED VERTICALLY - Sm, -- (16#02052#, 16#02052#) COMMERCIAL MINUS SIGN .. COMMERCIAL MINUS SIGN - Po, -- (16#02053#, 16#02053#) SWUNG DASH .. SWUNG DASH - Pc, -- (16#02054#, 16#02054#) INVERTED UNDERTIE .. INVERTED UNDERTIE - Po, -- (16#02057#, 16#02057#) QUADRUPLE PRIME .. QUADRUPLE PRIME - Zs, -- (16#0205F#, 16#0205F#) MEDIUM MATHEMATICAL SPACE .. MEDIUM MATHEMATICAL SPACE - Cf, -- (16#02060#, 16#02063#) WORD JOINER .. INVISIBLE SEPARATOR - Cf, -- (16#0206A#, 16#0206F#) INHIBIT SYMMETRIC SWAPPING .. NOMINAL DIGIT SHAPES - No, -- (16#02070#, 16#02070#) SUPERSCRIPT ZERO .. SUPERSCRIPT ZERO - Ll, -- (16#02071#, 16#02071#) SUPERSCRIPT LATIN SMALL LETTER I .. SUPERSCRIPT LATIN SMALL LETTER I - No, -- (16#02074#, 16#02079#) SUPERSCRIPT FOUR .. SUPERSCRIPT NINE - Sm, -- (16#0207A#, 16#0207C#) SUPERSCRIPT PLUS SIGN .. SUPERSCRIPT EQUALS SIGN - Ps, -- (16#0207D#, 16#0207D#) SUPERSCRIPT LEFT PARENTHESIS .. SUPERSCRIPT LEFT PARENTHESIS - Pe, -- (16#0207E#, 16#0207E#) SUPERSCRIPT RIGHT PARENTHESIS .. SUPERSCRIPT RIGHT PARENTHESIS - Ll, -- (16#0207F#, 16#0207F#) SUPERSCRIPT LATIN SMALL LETTER N .. SUPERSCRIPT LATIN SMALL LETTER N - No, -- (16#02080#, 16#02089#) SUBSCRIPT ZERO .. SUBSCRIPT NINE - Sm, -- (16#0208A#, 16#0208C#) SUBSCRIPT PLUS SIGN .. SUBSCRIPT EQUALS SIGN - Ps, -- (16#0208D#, 16#0208D#) SUBSCRIPT LEFT PARENTHESIS .. SUBSCRIPT LEFT PARENTHESIS - Pe, -- (16#0208E#, 16#0208E#) SUBSCRIPT RIGHT PARENTHESIS .. SUBSCRIPT RIGHT PARENTHESIS - Sc, -- (16#020A0#, 16#020B1#) EURO-CURRENCY SIGN .. PESO SIGN - Mn, -- (16#020D0#, 16#020DC#) COMBINING LEFT HARPOON ABOVE .. COMBINING FOUR DOTS ABOVE - Me, -- (16#020DD#, 16#020E0#) COMBINING ENCLOSING CIRCLE .. COMBINING ENCLOSING CIRCLE BACKSLASH - Mn, -- (16#020E1#, 16#020E1#) COMBINING LEFT RIGHT ARROW ABOVE .. COMBINING LEFT RIGHT ARROW ABOVE - Me, -- (16#020E2#, 16#020E4#) COMBINING ENCLOSING SCREEN .. COMBINING ENCLOSING UPWARD POINTING TRIANGLE - Mn, -- (16#020E5#, 16#020EA#) COMBINING REVERSE SOLIDUS OVERLAY .. COMBINING LEFTWARDS ARROW OVERLAY - So, -- (16#02100#, 16#02101#) ACCOUNT OF .. ADDRESSED TO THE SUBJECT - Lu, -- (16#02102#, 16#02102#) DOUBLE-STRUCK CAPITAL C .. DOUBLE-STRUCK CAPITAL C - So, -- (16#02103#, 16#02106#) DEGREE CELSIUS .. CADA UNA - Lu, -- (16#02107#, 16#02107#) EULER CONSTANT .. EULER CONSTANT - So, -- (16#02108#, 16#02109#) SCRUPLE .. DEGREE FAHRENHEIT - Ll, -- (16#0210A#, 16#0210A#) SCRIPT SMALL G .. SCRIPT SMALL G - Lu, -- (16#0210B#, 16#0210D#) SCRIPT CAPITAL H .. DOUBLE-STRUCK CAPITAL H - Ll, -- (16#0210E#, 16#0210F#) PLANCK CONSTANT .. PLANCK CONSTANT OVER TWO PI - Lu, -- (16#02110#, 16#02112#) SCRIPT CAPITAL I .. SCRIPT CAPITAL L - Ll, -- (16#02113#, 16#02113#) SCRIPT SMALL L .. SCRIPT SMALL L - So, -- (16#02114#, 16#02114#) L B BAR SYMBOL .. L B BAR SYMBOL - Lu, -- (16#02115#, 16#02115#) DOUBLE-STRUCK CAPITAL N .. DOUBLE-STRUCK CAPITAL N - So, -- (16#02116#, 16#02118#) NUMERO SIGN .. SCRIPT CAPITAL P - Lu, -- (16#02119#, 16#0211D#) DOUBLE-STRUCK CAPITAL P .. DOUBLE-STRUCK CAPITAL R - So, -- (16#0211E#, 16#02123#) PRESCRIPTION TAKE .. VERSICLE - Lu, -- (16#02124#, 16#02124#) DOUBLE-STRUCK CAPITAL Z .. DOUBLE-STRUCK CAPITAL Z - So, -- (16#02125#, 16#02125#) OUNCE SIGN .. OUNCE SIGN - Lu, -- (16#02126#, 16#02126#) OHM SIGN .. OHM SIGN - So, -- (16#02127#, 16#02127#) INVERTED OHM SIGN .. INVERTED OHM SIGN - Lu, -- (16#02128#, 16#02128#) BLACK-LETTER CAPITAL Z .. BLACK-LETTER CAPITAL Z - So, -- (16#02129#, 16#02129#) TURNED GREEK SMALL LETTER IOTA .. TURNED GREEK SMALL LETTER IOTA - Lu, -- (16#0212A#, 16#0212D#) KELVIN SIGN .. BLACK-LETTER CAPITAL C - So, -- (16#0212E#, 16#0212E#) ESTIMATED SYMBOL .. ESTIMATED SYMBOL - Ll, -- (16#0212F#, 16#0212F#) SCRIPT SMALL E .. SCRIPT SMALL E - Lu, -- (16#02130#, 16#02131#) SCRIPT CAPITAL E .. SCRIPT CAPITAL F - So, -- (16#02132#, 16#02132#) TURNED CAPITAL F .. TURNED CAPITAL F - Lu, -- (16#02133#, 16#02133#) SCRIPT CAPITAL M .. SCRIPT CAPITAL M - Ll, -- (16#02134#, 16#02134#) SCRIPT SMALL O .. SCRIPT SMALL O - Lo, -- (16#02135#, 16#02138#) ALEF SYMBOL .. DALET SYMBOL - Ll, -- (16#02139#, 16#02139#) INFORMATION SOURCE .. INFORMATION SOURCE - So, -- (16#0213A#, 16#0213B#) ROTATED CAPITAL Q .. FACSIMILE SIGN - Ll, -- (16#0213D#, 16#0213D#) DOUBLE-STRUCK SMALL GAMMA .. DOUBLE-STRUCK SMALL GAMMA - Lu, -- (16#0213E#, 16#0213F#) DOUBLE-STRUCK CAPITAL GAMMA .. DOUBLE-STRUCK CAPITAL PI - Sm, -- (16#02140#, 16#02144#) DOUBLE-STRUCK N-ARY SUMMATION .. TURNED SANS-SERIF CAPITAL Y - Lu, -- (16#02145#, 16#02145#) DOUBLE-STRUCK ITALIC CAPITAL D .. DOUBLE-STRUCK ITALIC CAPITAL D - Ll, -- (16#02146#, 16#02149#) DOUBLE-STRUCK ITALIC SMALL D .. DOUBLE-STRUCK ITALIC SMALL J - So, -- (16#0214A#, 16#0214A#) PROPERTY LINE .. PROPERTY LINE - Sm, -- (16#0214B#, 16#0214B#) TURNED AMPERSAND .. TURNED AMPERSAND - No, -- (16#02153#, 16#0215F#) VULGAR FRACTION ONE THIRD .. FRACTION NUMERATOR ONE - Nl, -- (16#02160#, 16#02183#) ROMAN NUMERAL ONE .. ROMAN NUMERAL REVERSED ONE HUNDRED - Sm, -- (16#02190#, 16#02194#) LEFTWARDS ARROW .. LEFT RIGHT ARROW - So, -- (16#02195#, 16#02199#) UP DOWN ARROW .. SOUTH WEST ARROW - Sm, -- (16#0219A#, 16#0219B#) LEFTWARDS ARROW WITH STROKE .. RIGHTWARDS ARROW WITH STROKE - So, -- (16#0219C#, 16#0219F#) LEFTWARDS WAVE ARROW .. UPWARDS TWO HEADED ARROW - Sm, -- (16#021A0#, 16#021A0#) RIGHTWARDS TWO HEADED ARROW .. RIGHTWARDS TWO HEADED ARROW - So, -- (16#021A1#, 16#021A2#) DOWNWARDS TWO HEADED ARROW .. LEFTWARDS ARROW WITH TAIL - Sm, -- (16#021A3#, 16#021A3#) RIGHTWARDS ARROW WITH TAIL .. RIGHTWARDS ARROW WITH TAIL - So, -- (16#021A4#, 16#021A5#) LEFTWARDS ARROW FROM BAR .. UPWARDS ARROW FROM BAR - Sm, -- (16#021A6#, 16#021A6#) RIGHTWARDS ARROW FROM BAR .. RIGHTWARDS ARROW FROM BAR - So, -- (16#021A7#, 16#021AD#) DOWNWARDS ARROW FROM BAR .. LEFT RIGHT WAVE ARROW - Sm, -- (16#021AE#, 16#021AE#) LEFT RIGHT ARROW WITH STROKE .. LEFT RIGHT ARROW WITH STROKE - So, -- (16#021AF#, 16#021CD#) DOWNWARDS ZIGZAG ARROW .. LEFTWARDS DOUBLE ARROW WITH STROKE - Sm, -- (16#021CE#, 16#021CF#) LEFT RIGHT DOUBLE ARROW WITH STROKE .. RIGHTWARDS DOUBLE ARROW WITH STROKE - So, -- (16#021D0#, 16#021D1#) LEFTWARDS DOUBLE ARROW .. UPWARDS DOUBLE ARROW - Sm, -- (16#021D2#, 16#021D2#) RIGHTWARDS DOUBLE ARROW .. RIGHTWARDS DOUBLE ARROW - So, -- (16#021D3#, 16#021D3#) DOWNWARDS DOUBLE ARROW .. DOWNWARDS DOUBLE ARROW - Sm, -- (16#021D4#, 16#021D4#) LEFT RIGHT DOUBLE ARROW .. LEFT RIGHT DOUBLE ARROW - So, -- (16#021D5#, 16#021F3#) UP DOWN DOUBLE ARROW .. UP DOWN WHITE ARROW - Sm, -- (16#021F4#, 16#022FF#) RIGHT ARROW WITH SMALL CIRCLE .. Z NOTATION BAG MEMBERSHIP - So, -- (16#02300#, 16#02307#) DIAMETER SIGN .. WAVY LINE - Sm, -- (16#02308#, 16#0230B#) LEFT CEILING .. RIGHT FLOOR - So, -- (16#0230C#, 16#0231F#) BOTTOM RIGHT CROP .. BOTTOM RIGHT CORNER - Sm, -- (16#02320#, 16#02321#) TOP HALF INTEGRAL .. BOTTOM HALF INTEGRAL - So, -- (16#02322#, 16#02328#) FROWN .. KEYBOARD - Ps, -- (16#02329#, 16#02329#) LEFT-POINTING ANGLE BRACKET .. LEFT-POINTING ANGLE BRACKET - Pe, -- (16#0232A#, 16#0232A#) RIGHT-POINTING ANGLE BRACKET .. RIGHT-POINTING ANGLE BRACKET - So, -- (16#0232B#, 16#0237B#) ERASE TO THE LEFT .. NOT CHECK MARK - Sm, -- (16#0237C#, 16#0237C#) RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW .. RIGHT ANGLE WITH DOWNWARDS ZIGZAG ARROW - So, -- (16#0237D#, 16#0239A#) SHOULDERED OPEN BOX .. CLEAR SCREEN SYMBOL - Sm, -- (16#0239B#, 16#023B3#) LEFT PARENTHESIS UPPER HOOK .. SUMMATION BOTTOM - Ps, -- (16#023B4#, 16#023B4#) TOP SQUARE BRACKET .. TOP SQUARE BRACKET - Pe, -- (16#023B5#, 16#023B5#) BOTTOM SQUARE BRACKET .. BOTTOM SQUARE BRACKET - Po, -- (16#023B6#, 16#023B6#) BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET .. BOTTOM SQUARE BRACKET OVER TOP SQUARE BRACKET - So, -- (16#023B7#, 16#023D0#) RADICAL SYMBOL BOTTOM .. VERTICAL LINE EXTENSION - So, -- (16#02400#, 16#02426#) SYMBOL FOR NULL .. SYMBOL FOR SUBSTITUTE FORM TWO - So, -- (16#02440#, 16#0244A#) OCR HOOK .. OCR DOUBLE BACKSLASH - No, -- (16#02460#, 16#0249B#) CIRCLED DIGIT ONE .. NUMBER TWENTY FULL STOP - So, -- (16#0249C#, 16#024E9#) PARENTHESIZED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z - No, -- (16#024EA#, 16#024FF#) CIRCLED DIGIT ZERO .. NEGATIVE CIRCLED DIGIT ZERO - So, -- (16#02500#, 16#025B6#) BOX DRAWINGS LIGHT HORIZONTAL .. BLACK RIGHT-POINTING TRIANGLE - Sm, -- (16#025B7#, 16#025B7#) WHITE RIGHT-POINTING TRIANGLE .. WHITE RIGHT-POINTING TRIANGLE - So, -- (16#025B8#, 16#025C0#) BLACK RIGHT-POINTING SMALL TRIANGLE .. BLACK LEFT-POINTING TRIANGLE - Sm, -- (16#025C1#, 16#025C1#) WHITE LEFT-POINTING TRIANGLE .. WHITE LEFT-POINTING TRIANGLE - So, -- (16#025C2#, 16#025F7#) BLACK LEFT-POINTING SMALL TRIANGLE .. WHITE CIRCLE WITH UPPER RIGHT QUADRANT - Sm, -- (16#025F8#, 16#025FF#) UPPER LEFT TRIANGLE .. LOWER RIGHT TRIANGLE - So, -- (16#02600#, 16#02617#) BLACK SUN WITH RAYS .. BLACK SHOGI PIECE - So, -- (16#02619#, 16#0266E#) REVERSED ROTATED FLORAL HEART BULLET .. MUSIC NATURAL SIGN - Sm, -- (16#0266F#, 16#0266F#) MUSIC SHARP SIGN .. MUSIC SHARP SIGN - So, -- (16#02670#, 16#0267D#) WEST SYRIAC CROSS .. PARTIALLY-RECYCLED PAPER SYMBOL - So, -- (16#02680#, 16#02691#) DIE FACE-1 .. BLACK FLAG - So, -- (16#026A0#, 16#026A1#) WARNING SIGN .. HIGH VOLTAGE SIGN - So, -- (16#02701#, 16#02704#) UPPER BLADE SCISSORS .. WHITE SCISSORS - So, -- (16#02706#, 16#02709#) TELEPHONE LOCATION SIGN .. ENVELOPE - So, -- (16#0270C#, 16#02727#) VICTORY HAND .. WHITE FOUR POINTED STAR - So, -- (16#02729#, 16#0274B#) STRESS OUTLINED WHITE STAR .. HEAVY EIGHT TEARDROP-SPOKED PROPELLER ASTERISK - So, -- (16#0274D#, 16#0274D#) SHADOWED WHITE CIRCLE .. SHADOWED WHITE CIRCLE - So, -- (16#0274F#, 16#02752#) LOWER RIGHT DROP-SHADOWED WHITE SQUARE .. UPPER RIGHT SHADOWED WHITE SQUARE - So, -- (16#02756#, 16#02756#) BLACK DIAMOND MINUS WHITE X .. BLACK DIAMOND MINUS WHITE X - So, -- (16#02758#, 16#0275E#) LIGHT VERTICAL BAR .. HEAVY DOUBLE COMMA QUOTATION MARK ORNAMENT - So, -- (16#02761#, 16#02767#) CURVED STEM PARAGRAPH SIGN ORNAMENT .. ROTATED FLORAL HEART BULLET - Ps, -- (16#02768#, 16#02768#) MEDIUM LEFT PARENTHESIS ORNAMENT .. MEDIUM LEFT PARENTHESIS ORNAMENT - Pe, -- (16#02769#, 16#02769#) MEDIUM RIGHT PARENTHESIS ORNAMENT .. MEDIUM RIGHT PARENTHESIS ORNAMENT - Ps, -- (16#0276A#, 16#0276A#) MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED LEFT PARENTHESIS ORNAMENT - Pe, -- (16#0276B#, 16#0276B#) MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT .. MEDIUM FLATTENED RIGHT PARENTHESIS ORNAMENT - Ps, -- (16#0276C#, 16#0276C#) MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM LEFT-POINTING ANGLE BRACKET ORNAMENT - Pe, -- (16#0276D#, 16#0276D#) MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT .. MEDIUM RIGHT-POINTING ANGLE BRACKET ORNAMENT - Ps, -- (16#0276E#, 16#0276E#) HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY LEFT-POINTING ANGLE QUOTATION MARK ORNAMENT - Pe, -- (16#0276F#, 16#0276F#) HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT .. HEAVY RIGHT-POINTING ANGLE QUOTATION MARK ORNAMENT - Ps, -- (16#02770#, 16#02770#) HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY LEFT-POINTING ANGLE BRACKET ORNAMENT - Pe, -- (16#02771#, 16#02771#) HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT .. HEAVY RIGHT-POINTING ANGLE BRACKET ORNAMENT - Ps, -- (16#02772#, 16#02772#) LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT LEFT TORTOISE SHELL BRACKET ORNAMENT - Pe, -- (16#02773#, 16#02773#) LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT .. LIGHT RIGHT TORTOISE SHELL BRACKET ORNAMENT - Ps, -- (16#02774#, 16#02774#) MEDIUM LEFT CURLY BRACKET ORNAMENT .. MEDIUM LEFT CURLY BRACKET ORNAMENT - Pe, -- (16#02775#, 16#02775#) MEDIUM RIGHT CURLY BRACKET ORNAMENT .. MEDIUM RIGHT CURLY BRACKET ORNAMENT - No, -- (16#02776#, 16#02793#) DINGBAT NEGATIVE CIRCLED DIGIT ONE .. DINGBAT NEGATIVE CIRCLED SANS-SERIF NUMBER TEN - So, -- (16#02794#, 16#02794#) HEAVY WIDE-HEADED RIGHTWARDS ARROW .. HEAVY WIDE-HEADED RIGHTWARDS ARROW - So, -- (16#02798#, 16#027AF#) HEAVY SOUTH EAST ARROW .. NOTCHED LOWER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW - So, -- (16#027B1#, 16#027BE#) NOTCHED UPPER RIGHT-SHADOWED WHITE RIGHTWARDS ARROW .. OPEN-OUTLINED RIGHTWARDS ARROW - Sm, -- (16#027D0#, 16#027E5#) WHITE DIAMOND WITH CENTRED DOT .. WHITE SQUARE WITH RIGHTWARDS TICK - Ps, -- (16#027E6#, 16#027E6#) MATHEMATICAL LEFT WHITE SQUARE BRACKET .. MATHEMATICAL LEFT WHITE SQUARE BRACKET - Pe, -- (16#027E7#, 16#027E7#) MATHEMATICAL RIGHT WHITE SQUARE BRACKET .. MATHEMATICAL RIGHT WHITE SQUARE BRACKET - Ps, -- (16#027E8#, 16#027E8#) MATHEMATICAL LEFT ANGLE BRACKET .. MATHEMATICAL LEFT ANGLE BRACKET - Pe, -- (16#027E9#, 16#027E9#) MATHEMATICAL RIGHT ANGLE BRACKET .. MATHEMATICAL RIGHT ANGLE BRACKET - Ps, -- (16#027EA#, 16#027EA#) MATHEMATICAL LEFT DOUBLE ANGLE BRACKET .. MATHEMATICAL LEFT DOUBLE ANGLE BRACKET - Pe, -- (16#027EB#, 16#027EB#) MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET .. MATHEMATICAL RIGHT DOUBLE ANGLE BRACKET - Sm, -- (16#027F0#, 16#027FF#) UPWARDS QUADRUPLE ARROW .. LONG RIGHTWARDS SQUIGGLE ARROW - So, -- (16#02800#, 16#028FF#) BRAILLE PATTERN BLANK .. BRAILLE PATTERN DOTS-12345678 - Sm, -- (16#02900#, 16#02982#) RIGHTWARDS TWO-HEADED ARROW WITH VERTICAL STROKE .. Z NOTATION TYPE COLON - Ps, -- (16#02983#, 16#02983#) LEFT WHITE CURLY BRACKET .. LEFT WHITE CURLY BRACKET - Pe, -- (16#02984#, 16#02984#) RIGHT WHITE CURLY BRACKET .. RIGHT WHITE CURLY BRACKET - Ps, -- (16#02985#, 16#02985#) LEFT WHITE PARENTHESIS .. LEFT WHITE PARENTHESIS - Pe, -- (16#02986#, 16#02986#) RIGHT WHITE PARENTHESIS .. RIGHT WHITE PARENTHESIS - Ps, -- (16#02987#, 16#02987#) Z NOTATION LEFT IMAGE BRACKET .. Z NOTATION LEFT IMAGE BRACKET - Pe, -- (16#02988#, 16#02988#) Z NOTATION RIGHT IMAGE BRACKET .. Z NOTATION RIGHT IMAGE BRACKET - Ps, -- (16#02989#, 16#02989#) Z NOTATION LEFT BINDING BRACKET .. Z NOTATION LEFT BINDING BRACKET - Pe, -- (16#0298A#, 16#0298A#) Z NOTATION RIGHT BINDING BRACKET .. Z NOTATION RIGHT BINDING BRACKET - Ps, -- (16#0298B#, 16#0298B#) LEFT SQUARE BRACKET WITH UNDERBAR .. LEFT SQUARE BRACKET WITH UNDERBAR - Pe, -- (16#0298C#, 16#0298C#) RIGHT SQUARE BRACKET WITH UNDERBAR .. RIGHT SQUARE BRACKET WITH UNDERBAR - Ps, -- (16#0298D#, 16#0298D#) LEFT SQUARE BRACKET WITH TICK IN TOP CORNER .. LEFT SQUARE BRACKET WITH TICK IN TOP CORNER - Pe, -- (16#0298E#, 16#0298E#) RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. RIGHT SQUARE BRACKET WITH TICK IN BOTTOM CORNER - Ps, -- (16#0298F#, 16#0298F#) LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER .. LEFT SQUARE BRACKET WITH TICK IN BOTTOM CORNER - Pe, -- (16#02990#, 16#02990#) RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER .. RIGHT SQUARE BRACKET WITH TICK IN TOP CORNER - Ps, -- (16#02991#, 16#02991#) LEFT ANGLE BRACKET WITH DOT .. LEFT ANGLE BRACKET WITH DOT - Pe, -- (16#02992#, 16#02992#) RIGHT ANGLE BRACKET WITH DOT .. RIGHT ANGLE BRACKET WITH DOT - Ps, -- (16#02993#, 16#02993#) LEFT ARC LESS-THAN BRACKET .. LEFT ARC LESS-THAN BRACKET - Pe, -- (16#02994#, 16#02994#) RIGHT ARC GREATER-THAN BRACKET .. RIGHT ARC GREATER-THAN BRACKET - Ps, -- (16#02995#, 16#02995#) DOUBLE LEFT ARC GREATER-THAN BRACKET .. DOUBLE LEFT ARC GREATER-THAN BRACKET - Pe, -- (16#02996#, 16#02996#) DOUBLE RIGHT ARC LESS-THAN BRACKET .. DOUBLE RIGHT ARC LESS-THAN BRACKET - Ps, -- (16#02997#, 16#02997#) LEFT BLACK TORTOISE SHELL BRACKET .. LEFT BLACK TORTOISE SHELL BRACKET - Pe, -- (16#02998#, 16#02998#) RIGHT BLACK TORTOISE SHELL BRACKET .. RIGHT BLACK TORTOISE SHELL BRACKET - Sm, -- (16#02999#, 16#029D7#) DOTTED FENCE .. BLACK HOURGLASS - Ps, -- (16#029D8#, 16#029D8#) LEFT WIGGLY FENCE .. LEFT WIGGLY FENCE - Pe, -- (16#029D9#, 16#029D9#) RIGHT WIGGLY FENCE .. RIGHT WIGGLY FENCE - Ps, -- (16#029DA#, 16#029DA#) LEFT DOUBLE WIGGLY FENCE .. LEFT DOUBLE WIGGLY FENCE - Pe, -- (16#029DB#, 16#029DB#) RIGHT DOUBLE WIGGLY FENCE .. RIGHT DOUBLE WIGGLY FENCE - Sm, -- (16#029DC#, 16#029FB#) INCOMPLETE INFINITY .. TRIPLE PLUS - Ps, -- (16#029FC#, 16#029FC#) LEFT-POINTING CURVED ANGLE BRACKET .. LEFT-POINTING CURVED ANGLE BRACKET - Pe, -- (16#029FD#, 16#029FD#) RIGHT-POINTING CURVED ANGLE BRACKET .. RIGHT-POINTING CURVED ANGLE BRACKET - Sm, -- (16#029FE#, 16#02AFF#) TINY .. N-ARY WHITE VERTICAL BAR - So, -- (16#02B00#, 16#02B0D#) NORTH EAST WHITE ARROW .. UP DOWN BLACK ARROW - So, -- (16#02E80#, 16#02E99#) CJK RADICAL REPEAT .. CJK RADICAL RAP - So, -- (16#02E9B#, 16#02EF3#) CJK RADICAL CHOKE .. CJK RADICAL C-SIMPLIFIED TURTLE - So, -- (16#02F00#, 16#02FD5#) KANGXI RADICAL ONE .. KANGXI RADICAL FLUTE - So, -- (16#02FF0#, 16#02FFB#) IDEOGRAPHIC DESCRIPTION CHARACTER LEFT TO RIGHT .. IDEOGRAPHIC DESCRIPTION CHARACTER OVERLAID - Zs, -- (16#03000#, 16#03000#) IDEOGRAPHIC SPACE .. IDEOGRAPHIC SPACE - Po, -- (16#03001#, 16#03003#) IDEOGRAPHIC COMMA .. DITTO MARK - So, -- (16#03004#, 16#03004#) JAPANESE INDUSTRIAL STANDARD SYMBOL .. JAPANESE INDUSTRIAL STANDARD SYMBOL - Lm, -- (16#03005#, 16#03005#) IDEOGRAPHIC ITERATION MARK .. IDEOGRAPHIC ITERATION MARK - Lo, -- (16#03006#, 16#03006#) IDEOGRAPHIC CLOSING MARK .. IDEOGRAPHIC CLOSING MARK - Nl, -- (16#03007#, 16#03007#) IDEOGRAPHIC NUMBER ZERO .. IDEOGRAPHIC NUMBER ZERO - Ps, -- (16#03008#, 16#03008#) LEFT ANGLE BRACKET .. LEFT ANGLE BRACKET - Pe, -- (16#03009#, 16#03009#) RIGHT ANGLE BRACKET .. RIGHT ANGLE BRACKET - Ps, -- (16#0300A#, 16#0300A#) LEFT DOUBLE ANGLE BRACKET .. LEFT DOUBLE ANGLE BRACKET - Pe, -- (16#0300B#, 16#0300B#) RIGHT DOUBLE ANGLE BRACKET .. RIGHT DOUBLE ANGLE BRACKET - Ps, -- (16#0300C#, 16#0300C#) LEFT CORNER BRACKET .. LEFT CORNER BRACKET - Pe, -- (16#0300D#, 16#0300D#) RIGHT CORNER BRACKET .. RIGHT CORNER BRACKET - Ps, -- (16#0300E#, 16#0300E#) LEFT WHITE CORNER BRACKET .. LEFT WHITE CORNER BRACKET - Pe, -- (16#0300F#, 16#0300F#) RIGHT WHITE CORNER BRACKET .. RIGHT WHITE CORNER BRACKET - Ps, -- (16#03010#, 16#03010#) LEFT BLACK LENTICULAR BRACKET .. LEFT BLACK LENTICULAR BRACKET - Pe, -- (16#03011#, 16#03011#) RIGHT BLACK LENTICULAR BRACKET .. RIGHT BLACK LENTICULAR BRACKET - So, -- (16#03012#, 16#03013#) POSTAL MARK .. GETA MARK - Ps, -- (16#03014#, 16#03014#) LEFT TORTOISE SHELL BRACKET .. LEFT TORTOISE SHELL BRACKET - Pe, -- (16#03015#, 16#03015#) RIGHT TORTOISE SHELL BRACKET .. RIGHT TORTOISE SHELL BRACKET - Ps, -- (16#03016#, 16#03016#) LEFT WHITE LENTICULAR BRACKET .. LEFT WHITE LENTICULAR BRACKET - Pe, -- (16#03017#, 16#03017#) RIGHT WHITE LENTICULAR BRACKET .. RIGHT WHITE LENTICULAR BRACKET - Ps, -- (16#03018#, 16#03018#) LEFT WHITE TORTOISE SHELL BRACKET .. LEFT WHITE TORTOISE SHELL BRACKET - Pe, -- (16#03019#, 16#03019#) RIGHT WHITE TORTOISE SHELL BRACKET .. RIGHT WHITE TORTOISE SHELL BRACKET - Ps, -- (16#0301A#, 16#0301A#) LEFT WHITE SQUARE BRACKET .. LEFT WHITE SQUARE BRACKET - Pe, -- (16#0301B#, 16#0301B#) RIGHT WHITE SQUARE BRACKET .. RIGHT WHITE SQUARE BRACKET - Pd, -- (16#0301C#, 16#0301C#) WAVE DASH .. WAVE DASH - Ps, -- (16#0301D#, 16#0301D#) REVERSED DOUBLE PRIME QUOTATION MARK .. REVERSED DOUBLE PRIME QUOTATION MARK - Pe, -- (16#0301E#, 16#0301F#) DOUBLE PRIME QUOTATION MARK .. LOW DOUBLE PRIME QUOTATION MARK - So, -- (16#03020#, 16#03020#) POSTAL MARK FACE .. POSTAL MARK FACE - Nl, -- (16#03021#, 16#03029#) HANGZHOU NUMERAL ONE .. HANGZHOU NUMERAL NINE - Mn, -- (16#0302A#, 16#0302F#) IDEOGRAPHIC LEVEL TONE MARK .. HANGUL DOUBLE DOT TONE MARK - Pd, -- (16#03030#, 16#03030#) WAVY DASH .. WAVY DASH - Lm, -- (16#03031#, 16#03035#) VERTICAL KANA REPEAT MARK .. VERTICAL KANA REPEAT MARK LOWER HALF - So, -- (16#03036#, 16#03037#) CIRCLED POSTAL MARK .. IDEOGRAPHIC TELEGRAPH LINE FEED SEPARATOR SYMBOL - Nl, -- (16#03038#, 16#0303A#) HANGZHOU NUMERAL TEN .. HANGZHOU NUMERAL THIRTY - Lm, -- (16#0303B#, 16#0303B#) VERTICAL IDEOGRAPHIC ITERATION MARK .. VERTICAL IDEOGRAPHIC ITERATION MARK - Lo, -- (16#0303C#, 16#0303C#) MASU MARK .. MASU MARK - Po, -- (16#0303D#, 16#0303D#) PART ALTERNATION MARK .. PART ALTERNATION MARK - So, -- (16#0303E#, 16#0303F#) IDEOGRAPHIC VARIATION INDICATOR .. IDEOGRAPHIC HALF FILL SPACE - Lo, -- (16#03041#, 16#03096#) HIRAGANA LETTER SMALL A .. HIRAGANA LETTER SMALL KE - Mn, -- (16#03099#, 16#0309A#) COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK .. COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK - Sk, -- (16#0309B#, 16#0309C#) KATAKANA-HIRAGANA VOICED SOUND MARK .. KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK - Lm, -- (16#0309D#, 16#0309E#) HIRAGANA ITERATION MARK .. HIRAGANA VOICED ITERATION MARK - Lo, -- (16#0309F#, 16#0309F#) HIRAGANA DIGRAPH YORI .. HIRAGANA DIGRAPH YORI - Pd, -- (16#030A0#, 16#030A0#) KATAKANA-HIRAGANA DOUBLE HYPHEN .. KATAKANA-HIRAGANA DOUBLE HYPHEN - Lo, -- (16#030A1#, 16#030FA#) KATAKANA LETTER SMALL A .. KATAKANA LETTER VO - Pc, -- (16#030FB#, 16#030FB#) KATAKANA MIDDLE DOT .. KATAKANA MIDDLE DOT - Lm, -- (16#030FC#, 16#030FE#) KATAKANA-HIRAGANA PROLONGED SOUND MARK .. KATAKANA VOICED ITERATION MARK - Lo, -- (16#030FF#, 16#030FF#) KATAKANA DIGRAPH KOTO .. KATAKANA DIGRAPH KOTO - Lo, -- (16#03105#, 16#0312C#) BOPOMOFO LETTER B .. BOPOMOFO LETTER GN - Lo, -- (16#03131#, 16#0318E#) HANGUL LETTER KIYEOK .. HANGUL LETTER ARAEAE - So, -- (16#03190#, 16#03191#) IDEOGRAPHIC ANNOTATION LINKING MARK .. IDEOGRAPHIC ANNOTATION REVERSE MARK - No, -- (16#03192#, 16#03195#) IDEOGRAPHIC ANNOTATION ONE MARK .. IDEOGRAPHIC ANNOTATION FOUR MARK - So, -- (16#03196#, 16#0319F#) IDEOGRAPHIC ANNOTATION TOP MARK .. IDEOGRAPHIC ANNOTATION MAN MARK - Lo, -- (16#031A0#, 16#031B7#) BOPOMOFO LETTER BU .. BOPOMOFO FINAL LETTER H - Lo, -- (16#031F0#, 16#031FF#) KATAKANA LETTER SMALL KU .. KATAKANA LETTER SMALL RO - So, -- (16#03200#, 16#0321E#) PARENTHESIZED HANGUL KIYEOK .. PARENTHESIZED KOREAN CHARACTER O HU - No, -- (16#03220#, 16#03229#) PARENTHESIZED IDEOGRAPH ONE .. PARENTHESIZED IDEOGRAPH TEN - So, -- (16#0322A#, 16#03243#) PARENTHESIZED IDEOGRAPH MOON .. PARENTHESIZED IDEOGRAPH REACH - So, -- (16#03250#, 16#03250#) PARTNERSHIP SIGN .. PARTNERSHIP SIGN - No, -- (16#03251#, 16#0325F#) CIRCLED NUMBER TWENTY ONE .. CIRCLED NUMBER THIRTY FIVE - So, -- (16#03260#, 16#0327D#) CIRCLED HANGUL KIYEOK .. CIRCLED KOREAN CHARACTER JUEUI - So, -- (16#0327F#, 16#0327F#) KOREAN STANDARD SYMBOL .. KOREAN STANDARD SYMBOL - No, -- (16#03280#, 16#03289#) CIRCLED IDEOGRAPH ONE .. CIRCLED IDEOGRAPH TEN - So, -- (16#0328A#, 16#032B0#) CIRCLED IDEOGRAPH MOON .. CIRCLED IDEOGRAPH NIGHT - No, -- (16#032B1#, 16#032BF#) CIRCLED NUMBER THIRTY SIX .. CIRCLED NUMBER FIFTY - So, -- (16#032C0#, 16#032FE#) IDEOGRAPHIC TELEGRAPH SYMBOL FOR JANUARY .. CIRCLED KATAKANA WO - So, -- (16#03300#, 16#033FF#) SQUARE APAATO .. SQUARE GAL - Lo, -- (16#03400#, 16#04DB5#) .. - So, -- (16#04DC0#, 16#04DFF#) HEXAGRAM FOR THE CREATIVE HEAVEN .. HEXAGRAM FOR BEFORE COMPLETION - Lo, -- (16#04E00#, 16#09FA5#) .. - Lo, -- (16#0A000#, 16#0A48C#) YI SYLLABLE IT .. YI SYLLABLE YYR - So, -- (16#0A490#, 16#0A4C6#) YI RADICAL QOT .. YI RADICAL KE - Lo, -- (16#0AC00#, 16#0D7A3#) .. - Cs, -- (16#0D800#, 16#0F8FF#) .. - Lo, -- (16#0F900#, 16#0FA2D#) CJK COMPATIBILITY IDEOGRAPH-F900 .. CJK COMPATIBILITY IDEOGRAPH-FA2D - Lo, -- (16#0FA30#, 16#0FA6A#) CJK COMPATIBILITY IDEOGRAPH-FA30 .. CJK COMPATIBILITY IDEOGRAPH-FA6A - Ll, -- (16#0FB00#, 16#0FB06#) LATIN SMALL LIGATURE FF .. LATIN SMALL LIGATURE ST - Ll, -- (16#0FB13#, 16#0FB17#) ARMENIAN SMALL LIGATURE MEN NOW .. ARMENIAN SMALL LIGATURE MEN XEH - Lo, -- (16#0FB1D#, 16#0FB1D#) HEBREW LETTER YOD WITH HIRIQ .. HEBREW LETTER YOD WITH HIRIQ - Mn, -- (16#0FB1E#, 16#0FB1E#) HEBREW POINT JUDEO-SPANISH VARIKA .. HEBREW POINT JUDEO-SPANISH VARIKA - Lo, -- (16#0FB1F#, 16#0FB28#) HEBREW LIGATURE YIDDISH YOD YOD PATAH .. HEBREW LETTER WIDE TAV - Sm, -- (16#0FB29#, 16#0FB29#) HEBREW LETTER ALTERNATIVE PLUS SIGN .. HEBREW LETTER ALTERNATIVE PLUS SIGN - Lo, -- (16#0FB2A#, 16#0FB36#) HEBREW LETTER SHIN WITH SHIN DOT .. HEBREW LETTER ZAYIN WITH DAGESH - Lo, -- (16#0FB38#, 16#0FB3C#) HEBREW LETTER TET WITH DAGESH .. HEBREW LETTER LAMED WITH DAGESH - Lo, -- (16#0FB3E#, 16#0FB3E#) HEBREW LETTER MEM WITH DAGESH .. HEBREW LETTER MEM WITH DAGESH - Lo, -- (16#0FB40#, 16#0FB41#) HEBREW LETTER NUN WITH DAGESH .. HEBREW LETTER SAMEKH WITH DAGESH - Lo, -- (16#0FB43#, 16#0FB44#) HEBREW LETTER FINAL PE WITH DAGESH .. HEBREW LETTER PE WITH DAGESH - Lo, -- (16#0FB46#, 16#0FBB1#) HEBREW LETTER TSADI WITH DAGESH .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM - Lo, -- (16#0FBD3#, 16#0FD3D#) ARABIC LETTER NG ISOLATED FORM .. ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM - Ps, -- (16#0FD3E#, 16#0FD3E#) ORNATE LEFT PARENTHESIS .. ORNATE LEFT PARENTHESIS - Pe, -- (16#0FD3F#, 16#0FD3F#) ORNATE RIGHT PARENTHESIS .. ORNATE RIGHT PARENTHESIS - Lo, -- (16#0FD50#, 16#0FD8F#) ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM .. ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM - Lo, -- (16#0FD92#, 16#0FDC7#) ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM .. ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM - Lo, -- (16#0FDF0#, 16#0FDFB#) ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM .. ARABIC LIGATURE JALLAJALALOUHOU - Sc, -- (16#0FDFC#, 16#0FDFC#) RIAL SIGN .. RIAL SIGN - So, -- (16#0FDFD#, 16#0FDFD#) ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM .. ARABIC LIGATURE BISMILLAH AR-RAHMAN AR-RAHEEM - Mn, -- (16#0FE00#, 16#0FE0F#) VARIATION SELECTOR-1 .. VARIATION SELECTOR-16 - Mn, -- (16#0FE20#, 16#0FE23#) COMBINING LIGATURE LEFT HALF .. COMBINING DOUBLE TILDE RIGHT HALF - Po, -- (16#0FE30#, 16#0FE30#) PRESENTATION FORM FOR VERTICAL TWO DOT LEADER .. PRESENTATION FORM FOR VERTICAL TWO DOT LEADER - Pd, -- (16#0FE31#, 16#0FE32#) PRESENTATION FORM FOR VERTICAL EM DASH .. PRESENTATION FORM FOR VERTICAL EN DASH - Pc, -- (16#0FE33#, 16#0FE34#) PRESENTATION FORM FOR VERTICAL LOW LINE .. PRESENTATION FORM FOR VERTICAL WAVY LOW LINE - Ps, -- (16#0FE35#, 16#0FE35#) PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL LEFT PARENTHESIS - Pe, -- (16#0FE36#, 16#0FE36#) PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS .. PRESENTATION FORM FOR VERTICAL RIGHT PARENTHESIS - Ps, -- (16#0FE37#, 16#0FE37#) PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CURLY BRACKET - Pe, -- (16#0FE38#, 16#0FE38#) PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CURLY BRACKET - Ps, -- (16#0FE39#, 16#0FE39#) PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT TORTOISE SHELL BRACKET - Pe, -- (16#0FE3A#, 16#0FE3A#) PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT TORTOISE SHELL BRACKET - Ps, -- (16#0FE3B#, 16#0FE3B#) PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT BLACK LENTICULAR BRACKET - Pe, -- (16#0FE3C#, 16#0FE3C#) PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT BLACK LENTICULAR BRACKET - Ps, -- (16#0FE3D#, 16#0FE3D#) PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT DOUBLE ANGLE BRACKET - Pe, -- (16#0FE3E#, 16#0FE3E#) PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT DOUBLE ANGLE BRACKET - Ps, -- (16#0FE3F#, 16#0FE3F#) PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT ANGLE BRACKET - Pe, -- (16#0FE40#, 16#0FE40#) PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT ANGLE BRACKET - Ps, -- (16#0FE41#, 16#0FE41#) PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT CORNER BRACKET - Pe, -- (16#0FE42#, 16#0FE42#) PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT CORNER BRACKET - Ps, -- (16#0FE43#, 16#0FE43#) PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT WHITE CORNER BRACKET - Pe, -- (16#0FE44#, 16#0FE44#) PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT WHITE CORNER BRACKET - Po, -- (16#0FE45#, 16#0FE46#) SESAME DOT .. WHITE SESAME DOT - Ps, -- (16#0FE47#, 16#0FE47#) PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL LEFT SQUARE BRACKET - Pe, -- (16#0FE48#, 16#0FE48#) PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET .. PRESENTATION FORM FOR VERTICAL RIGHT SQUARE BRACKET - Po, -- (16#0FE49#, 16#0FE4C#) DASHED OVERLINE .. DOUBLE WAVY OVERLINE - Pc, -- (16#0FE4D#, 16#0FE4F#) DASHED LOW LINE .. WAVY LOW LINE - Po, -- (16#0FE50#, 16#0FE52#) SMALL COMMA .. SMALL FULL STOP - Po, -- (16#0FE54#, 16#0FE57#) SMALL SEMICOLON .. SMALL EXCLAMATION MARK - Pd, -- (16#0FE58#, 16#0FE58#) SMALL EM DASH .. SMALL EM DASH - Ps, -- (16#0FE59#, 16#0FE59#) SMALL LEFT PARENTHESIS .. SMALL LEFT PARENTHESIS - Pe, -- (16#0FE5A#, 16#0FE5A#) SMALL RIGHT PARENTHESIS .. SMALL RIGHT PARENTHESIS - Ps, -- (16#0FE5B#, 16#0FE5B#) SMALL LEFT CURLY BRACKET .. SMALL LEFT CURLY BRACKET - Pe, -- (16#0FE5C#, 16#0FE5C#) SMALL RIGHT CURLY BRACKET .. SMALL RIGHT CURLY BRACKET - Ps, -- (16#0FE5D#, 16#0FE5D#) SMALL LEFT TORTOISE SHELL BRACKET .. SMALL LEFT TORTOISE SHELL BRACKET - Pe, -- (16#0FE5E#, 16#0FE5E#) SMALL RIGHT TORTOISE SHELL BRACKET .. SMALL RIGHT TORTOISE SHELL BRACKET - Po, -- (16#0FE5F#, 16#0FE61#) SMALL NUMBER SIGN .. SMALL ASTERISK - Sm, -- (16#0FE62#, 16#0FE62#) SMALL PLUS SIGN .. SMALL PLUS SIGN - Pd, -- (16#0FE63#, 16#0FE63#) SMALL HYPHEN-MINUS .. SMALL HYPHEN-MINUS - Sm, -- (16#0FE64#, 16#0FE66#) SMALL LESS-THAN SIGN .. SMALL EQUALS SIGN - Po, -- (16#0FE68#, 16#0FE68#) SMALL REVERSE SOLIDUS .. SMALL REVERSE SOLIDUS - Sc, -- (16#0FE69#, 16#0FE69#) SMALL DOLLAR SIGN .. SMALL DOLLAR SIGN - Po, -- (16#0FE6A#, 16#0FE6B#) SMALL PERCENT SIGN .. SMALL COMMERCIAL AT - Lo, -- (16#0FE70#, 16#0FE74#) ARABIC FATHATAN ISOLATED FORM .. ARABIC KASRATAN ISOLATED FORM - Lo, -- (16#0FE76#, 16#0FEFC#) ARABIC FATHA ISOLATED FORM .. ARABIC LIGATURE LAM WITH ALEF FINAL FORM - Cf, -- (16#0FEFF#, 16#0FEFF#) ZERO WIDTH NO-BREAK SPACE .. ZERO WIDTH NO-BREAK SPACE - Po, -- (16#0FF01#, 16#0FF03#) FULLWIDTH EXCLAMATION MARK .. FULLWIDTH NUMBER SIGN - Sc, -- (16#0FF04#, 16#0FF04#) FULLWIDTH DOLLAR SIGN .. FULLWIDTH DOLLAR SIGN - Po, -- (16#0FF05#, 16#0FF07#) FULLWIDTH PERCENT SIGN .. FULLWIDTH APOSTROPHE - Ps, -- (16#0FF08#, 16#0FF08#) FULLWIDTH LEFT PARENTHESIS .. FULLWIDTH LEFT PARENTHESIS - Pe, -- (16#0FF09#, 16#0FF09#) FULLWIDTH RIGHT PARENTHESIS .. FULLWIDTH RIGHT PARENTHESIS - Po, -- (16#0FF0A#, 16#0FF0A#) FULLWIDTH ASTERISK .. FULLWIDTH ASTERISK - Sm, -- (16#0FF0B#, 16#0FF0B#) FULLWIDTH PLUS SIGN .. FULLWIDTH PLUS SIGN - Po, -- (16#0FF0C#, 16#0FF0C#) FULLWIDTH COMMA .. FULLWIDTH COMMA - Pd, -- (16#0FF0D#, 16#0FF0D#) FULLWIDTH HYPHEN-MINUS .. FULLWIDTH HYPHEN-MINUS - Po, -- (16#0FF0E#, 16#0FF0F#) FULLWIDTH FULL STOP .. FULLWIDTH SOLIDUS - Nd, -- (16#0FF10#, 16#0FF19#) FULLWIDTH DIGIT ZERO .. FULLWIDTH DIGIT NINE - Po, -- (16#0FF1A#, 16#0FF1B#) FULLWIDTH COLON .. FULLWIDTH SEMICOLON - Sm, -- (16#0FF1C#, 16#0FF1E#) FULLWIDTH LESS-THAN SIGN .. FULLWIDTH GREATER-THAN SIGN - Po, -- (16#0FF1F#, 16#0FF20#) FULLWIDTH QUESTION MARK .. FULLWIDTH COMMERCIAL AT - Lu, -- (16#0FF21#, 16#0FF3A#) FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z - Ps, -- (16#0FF3B#, 16#0FF3B#) FULLWIDTH LEFT SQUARE BRACKET .. FULLWIDTH LEFT SQUARE BRACKET - Po, -- (16#0FF3C#, 16#0FF3C#) FULLWIDTH REVERSE SOLIDUS .. FULLWIDTH REVERSE SOLIDUS - Pe, -- (16#0FF3D#, 16#0FF3D#) FULLWIDTH RIGHT SQUARE BRACKET .. FULLWIDTH RIGHT SQUARE BRACKET - Sk, -- (16#0FF3E#, 16#0FF3E#) FULLWIDTH CIRCUMFLEX ACCENT .. FULLWIDTH CIRCUMFLEX ACCENT - Pc, -- (16#0FF3F#, 16#0FF3F#) FULLWIDTH LOW LINE .. FULLWIDTH LOW LINE - Sk, -- (16#0FF40#, 16#0FF40#) FULLWIDTH GRAVE ACCENT .. FULLWIDTH GRAVE ACCENT - Ll, -- (16#0FF41#, 16#0FF5A#) FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z - Ps, -- (16#0FF5B#, 16#0FF5B#) FULLWIDTH LEFT CURLY BRACKET .. FULLWIDTH LEFT CURLY BRACKET - Sm, -- (16#0FF5C#, 16#0FF5C#) FULLWIDTH VERTICAL LINE .. FULLWIDTH VERTICAL LINE - Pe, -- (16#0FF5D#, 16#0FF5D#) FULLWIDTH RIGHT CURLY BRACKET .. FULLWIDTH RIGHT CURLY BRACKET - Sm, -- (16#0FF5E#, 16#0FF5E#) FULLWIDTH TILDE .. FULLWIDTH TILDE - Ps, -- (16#0FF5F#, 16#0FF5F#) FULLWIDTH LEFT WHITE PARENTHESIS .. FULLWIDTH LEFT WHITE PARENTHESIS - Pe, -- (16#0FF60#, 16#0FF60#) FULLWIDTH RIGHT WHITE PARENTHESIS .. FULLWIDTH RIGHT WHITE PARENTHESIS - Po, -- (16#0FF61#, 16#0FF61#) HALFWIDTH IDEOGRAPHIC FULL STOP .. HALFWIDTH IDEOGRAPHIC FULL STOP - Ps, -- (16#0FF62#, 16#0FF62#) HALFWIDTH LEFT CORNER BRACKET .. HALFWIDTH LEFT CORNER BRACKET - Pe, -- (16#0FF63#, 16#0FF63#) HALFWIDTH RIGHT CORNER BRACKET .. HALFWIDTH RIGHT CORNER BRACKET - Po, -- (16#0FF64#, 16#0FF64#) HALFWIDTH IDEOGRAPHIC COMMA .. HALFWIDTH IDEOGRAPHIC COMMA - Pc, -- (16#0FF65#, 16#0FF65#) HALFWIDTH KATAKANA MIDDLE DOT .. HALFWIDTH KATAKANA MIDDLE DOT - Lo, -- (16#0FF66#, 16#0FF6F#) HALFWIDTH KATAKANA LETTER WO .. HALFWIDTH KATAKANA LETTER SMALL TU - Lm, -- (16#0FF70#, 16#0FF70#) HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK .. HALFWIDTH KATAKANA-HIRAGANA PROLONGED SOUND MARK - Lo, -- (16#0FF71#, 16#0FF9D#) HALFWIDTH KATAKANA LETTER A .. HALFWIDTH KATAKANA LETTER N - Lm, -- (16#0FF9E#, 16#0FF9F#) HALFWIDTH KATAKANA VOICED SOUND MARK .. HALFWIDTH KATAKANA SEMI-VOICED SOUND MARK - Lo, -- (16#0FFA0#, 16#0FFBE#) HALFWIDTH HANGUL FILLER .. HALFWIDTH HANGUL LETTER HIEUH - Lo, -- (16#0FFC2#, 16#0FFC7#) HALFWIDTH HANGUL LETTER A .. HALFWIDTH HANGUL LETTER E - Lo, -- (16#0FFCA#, 16#0FFCF#) HALFWIDTH HANGUL LETTER YEO .. HALFWIDTH HANGUL LETTER OE - Lo, -- (16#0FFD2#, 16#0FFD7#) HALFWIDTH HANGUL LETTER YO .. HALFWIDTH HANGUL LETTER YU - Lo, -- (16#0FFDA#, 16#0FFDC#) HALFWIDTH HANGUL LETTER EU .. HALFWIDTH HANGUL LETTER I - Sc, -- (16#0FFE0#, 16#0FFE1#) FULLWIDTH CENT SIGN .. FULLWIDTH POUND SIGN - Sm, -- (16#0FFE2#, 16#0FFE2#) FULLWIDTH NOT SIGN .. FULLWIDTH NOT SIGN - Sk, -- (16#0FFE3#, 16#0FFE3#) FULLWIDTH MACRON .. FULLWIDTH MACRON - So, -- (16#0FFE4#, 16#0FFE4#) FULLWIDTH BROKEN BAR .. FULLWIDTH BROKEN BAR - Sc, -- (16#0FFE5#, 16#0FFE6#) FULLWIDTH YEN SIGN .. FULLWIDTH WON SIGN - So, -- (16#0FFE8#, 16#0FFE8#) HALFWIDTH FORMS LIGHT VERTICAL .. HALFWIDTH FORMS LIGHT VERTICAL - Sm, -- (16#0FFE9#, 16#0FFEC#) HALFWIDTH LEFTWARDS ARROW .. HALFWIDTH DOWNWARDS ARROW - So, -- (16#0FFED#, 16#0FFEE#) HALFWIDTH BLACK SQUARE .. HALFWIDTH WHITE CIRCLE - Cf, -- (16#0FFF9#, 16#0FFFB#) INTERLINEAR ANNOTATION ANCHOR .. INTERLINEAR ANNOTATION TERMINATOR - So, -- (16#0FFFC#, 16#0FFFD#) OBJECT REPLACEMENT CHARACTER .. REPLACEMENT CHARACTER - Lo, -- (16#10000#, 16#1000B#) LINEAR B SYLLABLE B008 A .. LINEAR B SYLLABLE B046 JE - Lo, -- (16#1000D#, 16#10026#) LINEAR B SYLLABLE B036 JO .. LINEAR B SYLLABLE B032 QO - Lo, -- (16#10028#, 16#1003A#) LINEAR B SYLLABLE B060 RA .. LINEAR B SYLLABLE B042 WO - Lo, -- (16#1003C#, 16#1003D#) LINEAR B SYLLABLE B017 ZA .. LINEAR B SYLLABLE B074 ZE - Lo, -- (16#1003F#, 16#1004D#) LINEAR B SYLLABLE B020 ZO .. LINEAR B SYLLABLE B091 TWO - Lo, -- (16#10050#, 16#1005D#) LINEAR B SYMBOL B018 .. LINEAR B SYMBOL B089 - Lo, -- (16#10080#, 16#100FA#) LINEAR B IDEOGRAM B100 MAN .. LINEAR B IDEOGRAM VESSEL B305 - Po, -- (16#10100#, 16#10101#) AEGEAN WORD SEPARATOR LINE .. AEGEAN WORD SEPARATOR DOT - So, -- (16#10102#, 16#10102#) AEGEAN CHECK MARK .. AEGEAN CHECK MARK - No, -- (16#10107#, 16#10133#) AEGEAN NUMBER ONE .. AEGEAN NUMBER NINETY THOUSAND - So, -- (16#10137#, 16#1013F#) AEGEAN WEIGHT BASE UNIT .. AEGEAN MEASURE THIRD SUBUNIT - Lo, -- (16#10300#, 16#1031E#) OLD ITALIC LETTER A .. OLD ITALIC LETTER UU - No, -- (16#10320#, 16#10323#) OLD ITALIC NUMERAL ONE .. OLD ITALIC NUMERAL FIFTY - Lo, -- (16#10330#, 16#10349#) GOTHIC LETTER AHSA .. GOTHIC LETTER OTHAL - Nl, -- (16#1034A#, 16#1034A#) GOTHIC LETTER NINE HUNDRED .. GOTHIC LETTER NINE HUNDRED - Lo, -- (16#10380#, 16#1039D#) UGARITIC LETTER ALPA .. UGARITIC LETTER SSU - Po, -- (16#1039F#, 16#1039F#) UGARITIC WORD DIVIDER .. UGARITIC WORD DIVIDER - Lu, -- (16#10400#, 16#10427#) DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW - Ll, -- (16#10428#, 16#1044F#) DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW - Lo, -- (16#10450#, 16#1049D#) SHAVIAN LETTER PEEP .. OSMANYA LETTER OO - Nd, -- (16#104A0#, 16#104A9#) OSMANYA DIGIT ZERO .. OSMANYA DIGIT NINE - Lo, -- (16#10800#, 16#10805#) CYPRIOT SYLLABLE A .. CYPRIOT SYLLABLE JA - Lo, -- (16#10808#, 16#10808#) CYPRIOT SYLLABLE JO .. CYPRIOT SYLLABLE JO - Lo, -- (16#1080A#, 16#10835#) CYPRIOT SYLLABLE KA .. CYPRIOT SYLLABLE WO - Lo, -- (16#10837#, 16#10838#) CYPRIOT SYLLABLE XA .. CYPRIOT SYLLABLE XE - Lo, -- (16#1083C#, 16#1083C#) CYPRIOT SYLLABLE ZA .. CYPRIOT SYLLABLE ZA - Lo, -- (16#1083F#, 16#1083F#) CYPRIOT SYLLABLE ZO .. CYPRIOT SYLLABLE ZO - So, -- (16#1D000#, 16#1D0F5#) BYZANTINE MUSICAL SYMBOL PSILI .. BYZANTINE MUSICAL SYMBOL GORGON NEO KATO - So, -- (16#1D100#, 16#1D126#) MUSICAL SYMBOL SINGLE BARLINE .. MUSICAL SYMBOL DRUM CLEF-2 - So, -- (16#1D12A#, 16#1D164#) MUSICAL SYMBOL DOUBLE SHARP .. MUSICAL SYMBOL ONE HUNDRED TWENTY-EIGHTH NOTE - Mc, -- (16#1D165#, 16#1D166#) MUSICAL SYMBOL COMBINING STEM .. MUSICAL SYMBOL COMBINING SPRECHGESANG STEM - Mn, -- (16#1D167#, 16#1D169#) MUSICAL SYMBOL COMBINING TREMOLO-1 .. MUSICAL SYMBOL COMBINING TREMOLO-3 - So, -- (16#1D16A#, 16#1D16C#) MUSICAL SYMBOL FINGERED TREMOLO-1 .. MUSICAL SYMBOL FINGERED TREMOLO-3 - Mc, -- (16#1D16D#, 16#1D172#) MUSICAL SYMBOL COMBINING AUGMENTATION DOT .. MUSICAL SYMBOL COMBINING FLAG-5 - Cf, -- (16#1D173#, 16#1D17A#) MUSICAL SYMBOL BEGIN BEAM .. MUSICAL SYMBOL END PHRASE - Mn, -- (16#1D17B#, 16#1D182#) MUSICAL SYMBOL COMBINING ACCENT .. MUSICAL SYMBOL COMBINING LOURE - So, -- (16#1D183#, 16#1D184#) MUSICAL SYMBOL ARPEGGIATO UP .. MUSICAL SYMBOL ARPEGGIATO DOWN - Mn, -- (16#1D185#, 16#1D18B#) MUSICAL SYMBOL COMBINING DOIT .. MUSICAL SYMBOL COMBINING TRIPLE TONGUE - So, -- (16#1D18C#, 16#1D1A9#) MUSICAL SYMBOL RINFORZANDO .. MUSICAL SYMBOL DEGREE SLASH - Mn, -- (16#1D1AA#, 16#1D1AD#) MUSICAL SYMBOL COMBINING DOWN BOW .. MUSICAL SYMBOL COMBINING SNAP PIZZICATO - So, -- (16#1D1AE#, 16#1D1DD#) MUSICAL SYMBOL PEDAL MARK .. MUSICAL SYMBOL PES SUBPUNCTIS - So, -- (16#1D300#, 16#1D356#) MONOGRAM FOR EARTH .. TETRAGRAM FOR FOSTERING - Lu, -- (16#1D400#, 16#1D419#) MATHEMATICAL BOLD CAPITAL A .. MATHEMATICAL BOLD CAPITAL Z - Ll, -- (16#1D41A#, 16#1D433#) MATHEMATICAL BOLD SMALL A .. MATHEMATICAL BOLD SMALL Z - Lu, -- (16#1D434#, 16#1D44D#) MATHEMATICAL ITALIC CAPITAL A .. MATHEMATICAL ITALIC CAPITAL Z - Ll, -- (16#1D44E#, 16#1D454#) MATHEMATICAL ITALIC SMALL A .. MATHEMATICAL ITALIC SMALL G - Ll, -- (16#1D456#, 16#1D467#) MATHEMATICAL ITALIC SMALL I .. MATHEMATICAL ITALIC SMALL Z - Lu, -- (16#1D468#, 16#1D481#) MATHEMATICAL BOLD ITALIC CAPITAL A .. MATHEMATICAL BOLD ITALIC CAPITAL Z - Ll, -- (16#1D482#, 16#1D49B#) MATHEMATICAL BOLD ITALIC SMALL A .. MATHEMATICAL BOLD ITALIC SMALL Z - Lu, -- (16#1D49C#, 16#1D49C#) MATHEMATICAL SCRIPT CAPITAL A .. MATHEMATICAL SCRIPT CAPITAL A - Lu, -- (16#1D49E#, 16#1D49F#) MATHEMATICAL SCRIPT CAPITAL C .. MATHEMATICAL SCRIPT CAPITAL D - Lu, -- (16#1D4A2#, 16#1D4A2#) MATHEMATICAL SCRIPT CAPITAL G .. MATHEMATICAL SCRIPT CAPITAL G - Lu, -- (16#1D4A5#, 16#1D4A6#) MATHEMATICAL SCRIPT CAPITAL J .. MATHEMATICAL SCRIPT CAPITAL K - Lu, -- (16#1D4A9#, 16#1D4AC#) MATHEMATICAL SCRIPT CAPITAL N .. MATHEMATICAL SCRIPT CAPITAL Q - Lu, -- (16#1D4AE#, 16#1D4B5#) MATHEMATICAL SCRIPT CAPITAL S .. MATHEMATICAL SCRIPT CAPITAL Z - Ll, -- (16#1D4B6#, 16#1D4B9#) MATHEMATICAL SCRIPT SMALL A .. MATHEMATICAL SCRIPT SMALL D - Ll, -- (16#1D4BB#, 16#1D4BB#) MATHEMATICAL SCRIPT SMALL F .. MATHEMATICAL SCRIPT SMALL F - Ll, -- (16#1D4BD#, 16#1D4C3#) MATHEMATICAL SCRIPT SMALL H .. MATHEMATICAL SCRIPT SMALL N - Ll, -- (16#1D4C5#, 16#1D4CF#) MATHEMATICAL SCRIPT SMALL P .. MATHEMATICAL SCRIPT SMALL Z - Lu, -- (16#1D4D0#, 16#1D4E9#) MATHEMATICAL BOLD SCRIPT CAPITAL A .. MATHEMATICAL BOLD SCRIPT CAPITAL Z - Ll, -- (16#1D4EA#, 16#1D503#) MATHEMATICAL BOLD SCRIPT SMALL A .. MATHEMATICAL BOLD SCRIPT SMALL Z - Lu, -- (16#1D504#, 16#1D505#) MATHEMATICAL FRAKTUR CAPITAL A .. MATHEMATICAL FRAKTUR CAPITAL B - Lu, -- (16#1D507#, 16#1D50A#) MATHEMATICAL FRAKTUR CAPITAL D .. MATHEMATICAL FRAKTUR CAPITAL G - Lu, -- (16#1D50D#, 16#1D514#) MATHEMATICAL FRAKTUR CAPITAL J .. MATHEMATICAL FRAKTUR CAPITAL Q - Lu, -- (16#1D516#, 16#1D51C#) MATHEMATICAL FRAKTUR CAPITAL S .. MATHEMATICAL FRAKTUR CAPITAL Y - Ll, -- (16#1D51E#, 16#1D537#) MATHEMATICAL FRAKTUR SMALL A .. MATHEMATICAL FRAKTUR SMALL Z - Lu, -- (16#1D538#, 16#1D539#) MATHEMATICAL DOUBLE-STRUCK CAPITAL A .. MATHEMATICAL DOUBLE-STRUCK CAPITAL B - Lu, -- (16#1D53B#, 16#1D53E#) MATHEMATICAL DOUBLE-STRUCK CAPITAL D .. MATHEMATICAL DOUBLE-STRUCK CAPITAL G - Lu, -- (16#1D540#, 16#1D544#) MATHEMATICAL DOUBLE-STRUCK CAPITAL I .. MATHEMATICAL DOUBLE-STRUCK CAPITAL M - Lu, -- (16#1D546#, 16#1D546#) MATHEMATICAL DOUBLE-STRUCK CAPITAL O .. MATHEMATICAL DOUBLE-STRUCK CAPITAL O - Lu, -- (16#1D54A#, 16#1D550#) MATHEMATICAL DOUBLE-STRUCK CAPITAL S .. MATHEMATICAL DOUBLE-STRUCK CAPITAL Y - Ll, -- (16#1D552#, 16#1D56B#) MATHEMATICAL DOUBLE-STRUCK SMALL A .. MATHEMATICAL DOUBLE-STRUCK SMALL Z - Lu, -- (16#1D56C#, 16#1D585#) MATHEMATICAL BOLD FRAKTUR CAPITAL A .. MATHEMATICAL BOLD FRAKTUR CAPITAL Z - Ll, -- (16#1D586#, 16#1D59F#) MATHEMATICAL BOLD FRAKTUR SMALL A .. MATHEMATICAL BOLD FRAKTUR SMALL Z - Lu, -- (16#1D5A0#, 16#1D5B9#) MATHEMATICAL SANS-SERIF CAPITAL A .. MATHEMATICAL SANS-SERIF CAPITAL Z - Ll, -- (16#1D5BA#, 16#1D5D3#) MATHEMATICAL SANS-SERIF SMALL A .. MATHEMATICAL SANS-SERIF SMALL Z - Lu, -- (16#1D5D4#, 16#1D5ED#) MATHEMATICAL SANS-SERIF BOLD CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD CAPITAL Z - Ll, -- (16#1D5EE#, 16#1D607#) MATHEMATICAL SANS-SERIF BOLD SMALL A .. MATHEMATICAL SANS-SERIF BOLD SMALL Z - Lu, -- (16#1D608#, 16#1D621#) MATHEMATICAL SANS-SERIF ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF ITALIC CAPITAL Z - Ll, -- (16#1D622#, 16#1D63B#) MATHEMATICAL SANS-SERIF ITALIC SMALL A .. MATHEMATICAL SANS-SERIF ITALIC SMALL Z - Lu, -- (16#1D63C#, 16#1D655#) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL Z - Ll, -- (16#1D656#, 16#1D66F#) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL A .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL Z - Lu, -- (16#1D670#, 16#1D689#) MATHEMATICAL MONOSPACE CAPITAL A .. MATHEMATICAL MONOSPACE CAPITAL Z - Ll, -- (16#1D68A#, 16#1D6A3#) MATHEMATICAL MONOSPACE SMALL A .. MATHEMATICAL MONOSPACE SMALL Z - Lu, -- (16#1D6A8#, 16#1D6C0#) MATHEMATICAL BOLD CAPITAL ALPHA .. MATHEMATICAL BOLD CAPITAL OMEGA - Sm, -- (16#1D6C1#, 16#1D6C1#) MATHEMATICAL BOLD NABLA .. MATHEMATICAL BOLD NABLA - Ll, -- (16#1D6C2#, 16#1D6DA#) MATHEMATICAL BOLD SMALL ALPHA .. MATHEMATICAL BOLD SMALL OMEGA - Sm, -- (16#1D6DB#, 16#1D6DB#) MATHEMATICAL BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD PARTIAL DIFFERENTIAL - Ll, -- (16#1D6DC#, 16#1D6E1#) MATHEMATICAL BOLD EPSILON SYMBOL .. MATHEMATICAL BOLD PI SYMBOL - Lu, -- (16#1D6E2#, 16#1D6FA#) MATHEMATICAL ITALIC CAPITAL ALPHA .. MATHEMATICAL ITALIC CAPITAL OMEGA - Sm, -- (16#1D6FB#, 16#1D6FB#) MATHEMATICAL ITALIC NABLA .. MATHEMATICAL ITALIC NABLA - Ll, -- (16#1D6FC#, 16#1D714#) MATHEMATICAL ITALIC SMALL ALPHA .. MATHEMATICAL ITALIC SMALL OMEGA - Sm, -- (16#1D715#, 16#1D715#) MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL ITALIC PARTIAL DIFFERENTIAL - Ll, -- (16#1D716#, 16#1D71B#) MATHEMATICAL ITALIC EPSILON SYMBOL .. MATHEMATICAL ITALIC PI SYMBOL - Lu, -- (16#1D71C#, 16#1D734#) MATHEMATICAL BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL BOLD ITALIC CAPITAL OMEGA - Sm, -- (16#1D735#, 16#1D735#) MATHEMATICAL BOLD ITALIC NABLA .. MATHEMATICAL BOLD ITALIC NABLA - Ll, -- (16#1D736#, 16#1D74E#) MATHEMATICAL BOLD ITALIC SMALL ALPHA .. MATHEMATICAL BOLD ITALIC SMALL OMEGA - Sm, -- (16#1D74F#, 16#1D74F#) MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL BOLD ITALIC PARTIAL DIFFERENTIAL - Ll, -- (16#1D750#, 16#1D755#) MATHEMATICAL BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL BOLD ITALIC PI SYMBOL - Lu, -- (16#1D756#, 16#1D76E#) MATHEMATICAL SANS-SERIF BOLD CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA - Sm, -- (16#1D76F#, 16#1D76F#) MATHEMATICAL SANS-SERIF BOLD NABLA .. MATHEMATICAL SANS-SERIF BOLD NABLA - Ll, -- (16#1D770#, 16#1D788#) MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA - Sm, -- (16#1D789#, 16#1D789#) MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD PARTIAL DIFFERENTIAL - Ll, -- (16#1D78A#, 16#1D78F#) MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD PI SYMBOL - Lu, -- (16#1D790#, 16#1D7A8#) MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA - Sm, -- (16#1D7A9#, 16#1D7A9#) MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA .. MATHEMATICAL SANS-SERIF BOLD ITALIC NABLA - Ll, -- (16#1D7AA#, 16#1D7C2#) MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA - Sm, -- (16#1D7C3#, 16#1D7C3#) MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PARTIAL DIFFERENTIAL - Ll, -- (16#1D7C4#, 16#1D7C9#) MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL - Nd, -- (16#1D7CE#, 16#1D7FF#) MATHEMATICAL BOLD DIGIT ZERO .. MATHEMATICAL MONOSPACE DIGIT NINE - Lo, -- (16#20000#, 16#2A6D6#) .. - Lo, -- (16#2F800#, 16#2FA1D#) CJK COMPATIBILITY IDEOGRAPH-2F800 .. CJK COMPATIBILITY IDEOGRAPH-2FA1D - Cf, -- (16#E0001#, 16#E0001#) LANGUAGE TAG .. LANGUAGE TAG - Cf, -- (16#E0020#, 16#E007F#) TAG SPACE .. CANCEL TAG - Mn, -- (16#E0100#, 16#E01EF#) VARIATION SELECTOR-17 .. VARIATION SELECTOR-256 - Co, -- (16#F0000#, 16#FFFFD#) .. - Co); -- (16#100000#, 16#10FFFD#) .. - - -- The following array includes all characters considered digits, i.e. - -- all characters from the Unicode table with categories: - - -- Number, Decimal Digit (Nd) - - UTF_32_Digits : constant UTF_32_Ranges := ( - (16#00030#, 16#00039#), -- DIGIT ZERO .. DIGIT NINE - (16#00660#, 16#00669#), -- ARABIC-INDIC DIGIT ZERO .. ARABIC-INDIC DIGIT NINE - (16#006F0#, 16#006F9#), -- EXTENDED ARABIC-INDIC DIGIT ZERO .. EXTENDED ARABIC-INDIC DIGIT NINE - (16#00966#, 16#0096F#), -- DEVANAGARI DIGIT ZERO .. DEVANAGARI DIGIT NINE - (16#009E6#, 16#009EF#), -- BENGALI DIGIT ZERO .. BENGALI DIGIT NINE - (16#00A66#, 16#00A6F#), -- GURMUKHI DIGIT ZERO .. GURMUKHI DIGIT NINE - (16#00AE6#, 16#00AEF#), -- GUJARATI DIGIT ZERO .. GUJARATI DIGIT NINE - (16#00B66#, 16#00B6F#), -- ORIYA DIGIT ZERO .. ORIYA DIGIT NINE - (16#00BE7#, 16#00BEF#), -- TAMIL DIGIT ONE .. TAMIL DIGIT NINE - (16#00C66#, 16#00C6F#), -- TELUGU DIGIT ZERO .. TELUGU DIGIT NINE - (16#00CE6#, 16#00CEF#), -- KANNADA DIGIT ZERO .. KANNADA DIGIT NINE - (16#00D66#, 16#00D6F#), -- MALAYALAM DIGIT ZERO .. MALAYALAM DIGIT NINE - (16#00E50#, 16#00E59#), -- THAI DIGIT ZERO .. THAI DIGIT NINE - (16#00ED0#, 16#00ED9#), -- LAO DIGIT ZERO .. LAO DIGIT NINE - (16#00F20#, 16#00F29#), -- TIBETAN DIGIT ZERO .. TIBETAN DIGIT NINE - (16#01040#, 16#01049#), -- MYANMAR DIGIT ZERO .. MYANMAR DIGIT NINE - (16#01369#, 16#01371#), -- ETHIOPIC DIGIT ONE .. ETHIOPIC DIGIT NINE - (16#017E0#, 16#017E9#), -- KHMER DIGIT ZERO .. KHMER DIGIT NINE - (16#01810#, 16#01819#), -- MONGOLIAN DIGIT ZERO .. MONGOLIAN DIGIT NINE - (16#01946#, 16#0194F#), -- LIMBU DIGIT ZERO .. LIMBU DIGIT NINE - (16#0FF10#, 16#0FF19#), -- FULLWIDTH DIGIT ZERO .. FULLWIDTH DIGIT NINE - (16#104A0#, 16#104A9#), -- OSMANYA DIGIT ZERO .. OSMANYA DIGIT NINE - (16#1D7CE#, 16#1D7FF#)); -- MATHEMATICAL BOLD DIGIT ZERO .. MATHEMATICAL MONOSPACE DIGIT NINE - - -- The following table includes all characters considered letters, i.e. - -- all characters from the Unicode table with categories: - - -- Letter, Uppercase (Lu) - -- Letter, Lowercase (Ll) - -- Letter, Titlecase (Lt) - -- Letter, Modifier (Lm) - -- Letter, Other (Lo) - -- Number, Letter (Nl) - - UTF_32_Letters : constant UTF_32_Ranges := ( - (16#00041#, 16#0005A#), -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z - (16#00061#, 16#0007A#), -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z - (16#000AA#, 16#000AA#), -- FEMININE ORDINAL INDICATOR .. FEMININE ORDINAL INDICATOR - (16#000B5#, 16#000B5#), -- MICRO SIGN .. MICRO SIGN - (16#000BA#, 16#000BA#), -- MASCULINE ORDINAL INDICATOR .. MASCULINE ORDINAL INDICATOR - (16#000C0#, 16#000D6#), -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS - (16#000D8#, 16#000F6#), -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN SMALL LETTER O WITH DIAERESIS - (16#000F8#, 16#00236#), -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER T WITH CURL - (16#00250#, 16#002C1#), -- LATIN SMALL LETTER TURNED A .. MODIFIER LETTER REVERSED GLOTTAL STOP - (16#002C6#, 16#002D1#), -- MODIFIER LETTER CIRCUMFLEX ACCENT .. MODIFIER LETTER HALF TRIANGULAR COLON - (16#002E0#, 16#002E4#), -- MODIFIER LETTER SMALL GAMMA .. MODIFIER LETTER SMALL REVERSED GLOTTAL STOP - (16#002EE#, 16#002EE#), -- MODIFIER LETTER DOUBLE APOSTROPHE .. MODIFIER LETTER DOUBLE APOSTROPHE - (16#0037A#, 16#0037A#), -- GREEK YPOGEGRAMMENI .. GREEK YPOGEGRAMMENI - (16#00386#, 16#00386#), -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS - (16#00388#, 16#0038A#), -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS - (16#0038C#, 16#0038C#), -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS - (16#0038E#, 16#003A1#), -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER RHO - (16#003A3#, 16#003CE#), -- GREEK CAPITAL LETTER SIGMA .. GREEK SMALL LETTER OMEGA WITH TONOS - (16#003D0#, 16#003F5#), -- GREEK BETA SYMBOL .. GREEK LUNATE EPSILON SYMBOL - (16#003F7#, 16#003FB#), -- GREEK CAPITAL LETTER SHO .. GREEK SMALL LETTER SAN - (16#00400#, 16#00481#), -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER KOPPA - (16#0048A#, 16#004CE#), -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL - (16#004D0#, 16#004F5#), -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS - (16#004F8#, 16#004F9#), -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS - (16#00500#, 16#0050F#), -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI TJE - (16#00531#, 16#00556#), -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH - (16#00559#, 16#00559#), -- ARMENIAN MODIFIER LETTER LEFT HALF RING .. ARMENIAN MODIFIER LETTER LEFT HALF RING - (16#00561#, 16#00587#), -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LIGATURE ECH YIWN - (16#005D0#, 16#005EA#), -- HEBREW LETTER ALEF .. HEBREW LETTER TAV - (16#005F0#, 16#005F2#), -- HEBREW LIGATURE YIDDISH DOUBLE VAV .. HEBREW LIGATURE YIDDISH DOUBLE YOD - (16#00621#, 16#0063A#), -- ARABIC LETTER HAMZA .. ARABIC LETTER GHAIN - (16#00640#, 16#0064A#), -- ARABIC TATWEEL .. ARABIC LETTER YEH - (16#0066E#, 16#0066F#), -- ARABIC LETTER DOTLESS BEH .. ARABIC LETTER DOTLESS QAF - (16#00671#, 16#006D3#), -- ARABIC LETTER ALEF WASLA .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE - (16#006D5#, 16#006D5#), -- ARABIC LETTER AE .. ARABIC LETTER AE - (16#006E5#, 16#006E6#), -- ARABIC SMALL WAW .. ARABIC SMALL YEH - (16#006EE#, 16#006EF#), -- ARABIC LETTER DAL WITH INVERTED V .. ARABIC LETTER REH WITH INVERTED V - (16#006FA#, 16#006FC#), -- ARABIC LETTER SHEEN WITH DOT BELOW .. ARABIC LETTER GHAIN WITH DOT BELOW - (16#006FF#, 16#006FF#), -- ARABIC LETTER HEH WITH INVERTED V .. ARABIC LETTER HEH WITH INVERTED V - (16#00710#, 16#00710#), -- SYRIAC LETTER ALAPH .. SYRIAC LETTER ALAPH - (16#00712#, 16#0072F#), -- SYRIAC LETTER BETH .. SYRIAC LETTER PERSIAN DHALATH - (16#0074D#, 16#0074F#), -- SYRIAC LETTER SOGDIAN ZHAIN .. SYRIAC LETTER SOGDIAN FE - (16#00780#, 16#007A5#), -- THAANA LETTER HAA .. THAANA LETTER WAAVU - (16#007B1#, 16#007B1#), -- THAANA LETTER NAA .. THAANA LETTER NAA - (16#00904#, 16#00939#), -- DEVANAGARI LETTER SHORT A .. DEVANAGARI LETTER HA - (16#0093D#, 16#0093D#), -- DEVANAGARI SIGN AVAGRAHA .. DEVANAGARI SIGN AVAGRAHA - (16#00950#, 16#00950#), -- DEVANAGARI OM .. DEVANAGARI OM - (16#00958#, 16#00961#), -- DEVANAGARI LETTER QA .. DEVANAGARI LETTER VOCALIC LL - (16#00985#, 16#0098C#), -- BENGALI LETTER A .. BENGALI LETTER VOCALIC L - (16#0098F#, 16#00990#), -- BENGALI LETTER E .. BENGALI LETTER AI - (16#00993#, 16#009A8#), -- BENGALI LETTER O .. BENGALI LETTER NA - (16#009AA#, 16#009B0#), -- BENGALI LETTER PA .. BENGALI LETTER RA - (16#009B2#, 16#009B2#), -- BENGALI LETTER LA .. BENGALI LETTER LA - (16#009B6#, 16#009B9#), -- BENGALI LETTER SHA .. BENGALI LETTER HA - (16#009BD#, 16#009BD#), -- BENGALI SIGN AVAGRAHA .. BENGALI SIGN AVAGRAHA - (16#009DC#, 16#009DD#), -- BENGALI LETTER RRA .. BENGALI LETTER RHA - (16#009DF#, 16#009E1#), -- BENGALI LETTER YYA .. BENGALI LETTER VOCALIC LL - (16#009F0#, 16#009F1#), -- BENGALI LETTER RA WITH MIDDLE DIAGONAL .. BENGALI LETTER RA WITH LOWER DIAGONAL - (16#00A05#, 16#00A0A#), -- GURMUKHI LETTER A .. GURMUKHI LETTER UU - (16#00A0F#, 16#00A10#), -- GURMUKHI LETTER EE .. GURMUKHI LETTER AI - (16#00A13#, 16#00A28#), -- GURMUKHI LETTER OO .. GURMUKHI LETTER NA - (16#00A2A#, 16#00A30#), -- GURMUKHI LETTER PA .. GURMUKHI LETTER RA - (16#00A32#, 16#00A33#), -- GURMUKHI LETTER LA .. GURMUKHI LETTER LLA - (16#00A35#, 16#00A36#), -- GURMUKHI LETTER VA .. GURMUKHI LETTER SHA - (16#00A38#, 16#00A39#), -- GURMUKHI LETTER SA .. GURMUKHI LETTER HA - (16#00A59#, 16#00A5C#), -- GURMUKHI LETTER KHHA .. GURMUKHI LETTER RRA - (16#00A5E#, 16#00A5E#), -- GURMUKHI LETTER FA .. GURMUKHI LETTER FA - (16#00A72#, 16#00A74#), -- GURMUKHI IRI .. GURMUKHI EK ONKAR - (16#00A85#, 16#00A8D#), -- GUJARATI LETTER A .. GUJARATI VOWEL CANDRA E - (16#00A8F#, 16#00A91#), -- GUJARATI LETTER E .. GUJARATI VOWEL CANDRA O - (16#00A93#, 16#00AA8#), -- GUJARATI LETTER O .. GUJARATI LETTER NA - (16#00AAA#, 16#00AB0#), -- GUJARATI LETTER PA .. GUJARATI LETTER RA - (16#00AB2#, 16#00AB3#), -- GUJARATI LETTER LA .. GUJARATI LETTER LLA - (16#00AB5#, 16#00AB9#), -- GUJARATI LETTER VA .. GUJARATI LETTER HA - (16#00ABD#, 16#00ABD#), -- GUJARATI SIGN AVAGRAHA .. GUJARATI SIGN AVAGRAHA - (16#00AD0#, 16#00AD0#), -- GUJARATI OM .. GUJARATI OM - (16#00AE0#, 16#00AE1#), -- GUJARATI LETTER VOCALIC RR .. GUJARATI LETTER VOCALIC LL - (16#00B05#, 16#00B0C#), -- ORIYA LETTER A .. ORIYA LETTER VOCALIC L - (16#00B0F#, 16#00B10#), -- ORIYA LETTER E .. ORIYA LETTER AI - (16#00B13#, 16#00B28#), -- ORIYA LETTER O .. ORIYA LETTER NA - (16#00B2A#, 16#00B30#), -- ORIYA LETTER PA .. ORIYA LETTER RA - (16#00B32#, 16#00B33#), -- ORIYA LETTER LA .. ORIYA LETTER LLA - (16#00B35#, 16#00B39#), -- ORIYA LETTER VA .. ORIYA LETTER HA - (16#00B3D#, 16#00B3D#), -- ORIYA SIGN AVAGRAHA .. ORIYA SIGN AVAGRAHA - (16#00B5C#, 16#00B5D#), -- ORIYA LETTER RRA .. ORIYA LETTER RHA - (16#00B5F#, 16#00B61#), -- ORIYA LETTER YYA .. ORIYA LETTER VOCALIC LL - (16#00B71#, 16#00B71#), -- ORIYA LETTER WA .. ORIYA LETTER WA - (16#00B83#, 16#00B83#), -- TAMIL SIGN VISARGA .. TAMIL SIGN VISARGA - (16#00B85#, 16#00B8A#), -- TAMIL LETTER A .. TAMIL LETTER UU - (16#00B8E#, 16#00B90#), -- TAMIL LETTER E .. TAMIL LETTER AI - (16#00B92#, 16#00B95#), -- TAMIL LETTER O .. TAMIL LETTER KA - (16#00B99#, 16#00B9A#), -- TAMIL LETTER NGA .. TAMIL LETTER CA - (16#00B9C#, 16#00B9C#), -- TAMIL LETTER JA .. TAMIL LETTER JA - (16#00B9E#, 16#00B9F#), -- TAMIL LETTER NYA .. TAMIL LETTER TTA - (16#00BA3#, 16#00BA4#), -- TAMIL LETTER NNA .. TAMIL LETTER TA - (16#00BA8#, 16#00BAA#), -- TAMIL LETTER NA .. TAMIL LETTER PA - (16#00BAE#, 16#00BB5#), -- TAMIL LETTER MA .. TAMIL LETTER VA - (16#00BB7#, 16#00BB9#), -- TAMIL LETTER SSA .. TAMIL LETTER HA - (16#00C05#, 16#00C0C#), -- TELUGU LETTER A .. TELUGU LETTER VOCALIC L - (16#00C0E#, 16#00C10#), -- TELUGU LETTER E .. TELUGU LETTER AI - (16#00C12#, 16#00C28#), -- TELUGU LETTER O .. TELUGU LETTER NA - (16#00C2A#, 16#00C33#), -- TELUGU LETTER PA .. TELUGU LETTER LLA - (16#00C35#, 16#00C39#), -- TELUGU LETTER VA .. TELUGU LETTER HA - (16#00C60#, 16#00C61#), -- TELUGU LETTER VOCALIC RR .. TELUGU LETTER VOCALIC LL - (16#00C85#, 16#00C8C#), -- KANNADA LETTER A .. KANNADA LETTER VOCALIC L - (16#00C8E#, 16#00C90#), -- KANNADA LETTER E .. KANNADA LETTER AI - (16#00C92#, 16#00CA8#), -- KANNADA LETTER O .. KANNADA LETTER NA - (16#00CAA#, 16#00CB3#), -- KANNADA LETTER PA .. KANNADA LETTER LLA - (16#00CB5#, 16#00CB9#), -- KANNADA LETTER VA .. KANNADA LETTER HA - (16#00CBD#, 16#00CBD#), -- KANNADA SIGN AVAGRAHA .. KANNADA SIGN AVAGRAHA - (16#00CDE#, 16#00CDE#), -- KANNADA LETTER FA .. KANNADA LETTER FA - (16#00CE0#, 16#00CE1#), -- KANNADA LETTER VOCALIC RR .. KANNADA LETTER VOCALIC LL - (16#00D05#, 16#00D0C#), -- MALAYALAM LETTER A .. MALAYALAM LETTER VOCALIC L - (16#00D0E#, 16#00D10#), -- MALAYALAM LETTER E .. MALAYALAM LETTER AI - (16#00D12#, 16#00D28#), -- MALAYALAM LETTER O .. MALAYALAM LETTER NA - (16#00D2A#, 16#00D39#), -- MALAYALAM LETTER PA .. MALAYALAM LETTER HA - (16#00D60#, 16#00D61#), -- MALAYALAM LETTER VOCALIC RR .. MALAYALAM LETTER VOCALIC LL - (16#00D85#, 16#00D96#), -- SINHALA LETTER AYANNA .. SINHALA LETTER AUYANNA - (16#00D9A#, 16#00DB1#), -- SINHALA LETTER ALPAPRAANA KAYANNA .. SINHALA LETTER DANTAJA NAYANNA - (16#00DB3#, 16#00DBB#), -- SINHALA LETTER SANYAKA DAYANNA .. SINHALA LETTER RAYANNA - (16#00DBD#, 16#00DBD#), -- SINHALA LETTER DANTAJA LAYANNA .. SINHALA LETTER DANTAJA LAYANNA - (16#00DC0#, 16#00DC6#), -- SINHALA LETTER VAYANNA .. SINHALA LETTER FAYANNA - (16#00E01#, 16#00E30#), -- THAI CHARACTER KO KAI .. THAI CHARACTER SARA A - (16#00E32#, 16#00E33#), -- THAI CHARACTER SARA AA .. THAI CHARACTER SARA AM - (16#00E40#, 16#00E46#), -- THAI CHARACTER SARA E .. THAI CHARACTER MAIYAMOK - (16#00E81#, 16#00E82#), -- LAO LETTER KO .. LAO LETTER KHO SUNG - (16#00E84#, 16#00E84#), -- LAO LETTER KHO TAM .. LAO LETTER KHO TAM - (16#00E87#, 16#00E88#), -- LAO LETTER NGO .. LAO LETTER CO - (16#00E8A#, 16#00E8A#), -- LAO LETTER SO TAM .. LAO LETTER SO TAM - (16#00E8D#, 16#00E8D#), -- LAO LETTER NYO .. LAO LETTER NYO - (16#00E94#, 16#00E97#), -- LAO LETTER DO .. LAO LETTER THO TAM - (16#00E99#, 16#00E9F#), -- LAO LETTER NO .. LAO LETTER FO SUNG - (16#00EA1#, 16#00EA3#), -- LAO LETTER MO .. LAO LETTER LO LING - (16#00EA5#, 16#00EA5#), -- LAO LETTER LO LOOT .. LAO LETTER LO LOOT - (16#00EA7#, 16#00EA7#), -- LAO LETTER WO .. LAO LETTER WO - (16#00EAA#, 16#00EAB#), -- LAO LETTER SO SUNG .. LAO LETTER HO SUNG - (16#00EAD#, 16#00EB0#), -- LAO LETTER O .. LAO VOWEL SIGN A - (16#00EB2#, 16#00EB3#), -- LAO VOWEL SIGN AA .. LAO VOWEL SIGN AM - (16#00EBD#, 16#00EBD#), -- LAO SEMIVOWEL SIGN NYO .. LAO SEMIVOWEL SIGN NYO - (16#00EC0#, 16#00EC4#), -- LAO VOWEL SIGN E .. LAO VOWEL SIGN AI - (16#00EC6#, 16#00EC6#), -- LAO KO LA .. LAO KO LA - (16#00EDC#, 16#00EDD#), -- LAO HO NO .. LAO HO MO - (16#00F00#, 16#00F00#), -- TIBETAN SYLLABLE OM .. TIBETAN SYLLABLE OM - (16#00F40#, 16#00F47#), -- TIBETAN LETTER KA .. TIBETAN LETTER JA - (16#00F49#, 16#00F6A#), -- TIBETAN LETTER NYA .. TIBETAN LETTER FIXED-FORM RA - (16#00F88#, 16#00F8B#), -- TIBETAN SIGN LCE TSA CAN .. TIBETAN SIGN GRU MED RGYINGS - (16#01000#, 16#01021#), -- MYANMAR LETTER KA .. MYANMAR LETTER A - (16#01023#, 16#01027#), -- MYANMAR LETTER I .. MYANMAR LETTER E - (16#01029#, 16#0102A#), -- MYANMAR LETTER O .. MYANMAR LETTER AU - (16#01050#, 16#01055#), -- MYANMAR LETTER SHA .. MYANMAR LETTER VOCALIC LL - (16#010A0#, 16#010C5#), -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE - (16#010D0#, 16#010F8#), -- GEORGIAN LETTER AN .. GEORGIAN LETTER ELIFI - (16#01100#, 16#01159#), -- HANGUL CHOSEONG KIYEOK .. HANGUL CHOSEONG YEORINHIEUH - (16#0115F#, 16#011A2#), -- HANGUL CHOSEONG FILLER .. HANGUL JUNGSEONG SSANGARAEA - (16#011A8#, 16#011F9#), -- HANGUL JONGSEONG KIYEOK .. HANGUL JONGSEONG YEORINHIEUH - (16#01200#, 16#01206#), -- ETHIOPIC SYLLABLE HA .. ETHIOPIC SYLLABLE HO - (16#01208#, 16#01246#), -- ETHIOPIC SYLLABLE LA .. ETHIOPIC SYLLABLE QO - (16#01248#, 16#01248#), -- ETHIOPIC SYLLABLE QWA .. ETHIOPIC SYLLABLE QWA - (16#0124A#, 16#0124D#), -- ETHIOPIC SYLLABLE QWI .. ETHIOPIC SYLLABLE QWE - (16#01250#, 16#01256#), -- ETHIOPIC SYLLABLE QHA .. ETHIOPIC SYLLABLE QHO - (16#01258#, 16#01258#), -- ETHIOPIC SYLLABLE QHWA .. ETHIOPIC SYLLABLE QHWA - (16#0125A#, 16#0125D#), -- ETHIOPIC SYLLABLE QHWI .. ETHIOPIC SYLLABLE QHWE - (16#01260#, 16#01286#), -- ETHIOPIC SYLLABLE BA .. ETHIOPIC SYLLABLE XO - (16#01288#, 16#01288#), -- ETHIOPIC SYLLABLE XWA .. ETHIOPIC SYLLABLE XWA - (16#0128A#, 16#0128D#), -- ETHIOPIC SYLLABLE XWI .. ETHIOPIC SYLLABLE XWE - (16#01290#, 16#012AE#), -- ETHIOPIC SYLLABLE NA .. ETHIOPIC SYLLABLE KO - (16#012B0#, 16#012B0#), -- ETHIOPIC SYLLABLE KWA .. ETHIOPIC SYLLABLE KWA - (16#012B2#, 16#012B5#), -- ETHIOPIC SYLLABLE KWI .. ETHIOPIC SYLLABLE KWE - (16#012B8#, 16#012BE#), -- ETHIOPIC SYLLABLE KXA .. ETHIOPIC SYLLABLE KXO - (16#012C0#, 16#012C0#), -- ETHIOPIC SYLLABLE KXWA .. ETHIOPIC SYLLABLE KXWA - (16#012C2#, 16#012C5#), -- ETHIOPIC SYLLABLE KXWI .. ETHIOPIC SYLLABLE KXWE - (16#012C8#, 16#012CE#), -- ETHIOPIC SYLLABLE WA .. ETHIOPIC SYLLABLE WO - (16#012D0#, 16#012D6#), -- ETHIOPIC SYLLABLE PHARYNGEAL A .. ETHIOPIC SYLLABLE PHARYNGEAL O - (16#012D8#, 16#012EE#), -- ETHIOPIC SYLLABLE ZA .. ETHIOPIC SYLLABLE YO - (16#012F0#, 16#0130E#), -- ETHIOPIC SYLLABLE DA .. ETHIOPIC SYLLABLE GO - (16#01310#, 16#01310#), -- ETHIOPIC SYLLABLE GWA .. ETHIOPIC SYLLABLE GWA - (16#01312#, 16#01315#), -- ETHIOPIC SYLLABLE GWI .. ETHIOPIC SYLLABLE GWE - (16#01318#, 16#0131E#), -- ETHIOPIC SYLLABLE GGA .. ETHIOPIC SYLLABLE GGO - (16#01320#, 16#01346#), -- ETHIOPIC SYLLABLE THA .. ETHIOPIC SYLLABLE TZO - (16#01348#, 16#0135A#), -- ETHIOPIC SYLLABLE FA .. ETHIOPIC SYLLABLE FYA - (16#013A0#, 16#013F4#), -- CHEROKEE LETTER A .. CHEROKEE LETTER YV - (16#01401#, 16#0166C#), -- CANADIAN SYLLABICS E .. CANADIAN SYLLABICS CARRIER TTSA - (16#0166F#, 16#01676#), -- CANADIAN SYLLABICS QAI .. CANADIAN SYLLABICS NNGAA - (16#01681#, 16#0169A#), -- OGHAM LETTER BEITH .. OGHAM LETTER PEITH - (16#016A0#, 16#016EA#), -- RUNIC LETTER FEHU FEOH FE F .. RUNIC LETTER X - (16#016EE#, 16#016F0#), -- RUNIC ARLAUG SYMBOL .. RUNIC BELGTHOR SYMBOL - (16#01700#, 16#0170C#), -- TAGALOG LETTER A .. TAGALOG LETTER YA - (16#0170E#, 16#01711#), -- TAGALOG LETTER LA .. TAGALOG LETTER HA - (16#01720#, 16#01731#), -- HANUNOO LETTER A .. HANUNOO LETTER HA - (16#01740#, 16#01751#), -- BUHID LETTER A .. BUHID LETTER HA - (16#01760#, 16#0176C#), -- TAGBANWA LETTER A .. TAGBANWA LETTER YA - (16#0176E#, 16#01770#), -- TAGBANWA LETTER LA .. TAGBANWA LETTER SA - (16#01780#, 16#017B3#), -- KHMER LETTER KA .. KHMER INDEPENDENT VOWEL QAU - (16#017D7#, 16#017D7#), -- KHMER SIGN LEK TOO .. KHMER SIGN LEK TOO - (16#017DC#, 16#017DC#), -- KHMER SIGN AVAKRAHASANYA .. KHMER SIGN AVAKRAHASANYA - (16#01820#, 16#01877#), -- MONGOLIAN LETTER A .. MONGOLIAN LETTER MANCHU ZHA - (16#01880#, 16#018A8#), -- MONGOLIAN LETTER ALI GALI ANUSVARA ONE .. MONGOLIAN LETTER MANCHU ALI GALI BHA - (16#01900#, 16#0191C#), -- LIMBU VOWEL-CARRIER LETTER .. LIMBU LETTER HA - (16#01950#, 16#0196D#), -- TAI LE LETTER KA .. TAI LE LETTER AI - (16#01970#, 16#01974#), -- TAI LE LETTER TONE-2 .. TAI LE LETTER TONE-6 - (16#01D00#, 16#01D6B#), -- LATIN LETTER SMALL CAPITAL A .. LATIN SMALL LETTER UE - (16#01E00#, 16#01E9B#), -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN SMALL LETTER LONG S WITH DOT ABOVE - (16#01EA0#, 16#01EF9#), -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER Y WITH TILDE - (16#01F00#, 16#01F15#), -- GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA - (16#01F18#, 16#01F1D#), -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA - (16#01F20#, 16#01F45#), -- GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA - (16#01F48#, 16#01F4D#), -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA - (16#01F50#, 16#01F57#), -- GREEK SMALL LETTER UPSILON WITH PSILI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI - (16#01F59#, 16#01F59#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA - (16#01F5B#, 16#01F5B#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA - (16#01F5D#, 16#01F5D#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA - (16#01F5F#, 16#01F7D#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK SMALL LETTER OMEGA WITH OXIA - (16#01F80#, 16#01FB4#), -- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI .. GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI - (16#01FB6#, 16#01FBC#), -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI .. GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI - (16#01FBE#, 16#01FBE#), -- GREEK PROSGEGRAMMENI .. GREEK PROSGEGRAMMENI - (16#01FC2#, 16#01FC4#), -- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI - (16#01FC6#, 16#01FCC#), -- GREEK SMALL LETTER ETA WITH PERISPOMENI .. GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI - (16#01FD0#, 16#01FD3#), -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA - (16#01FD6#, 16#01FDB#), -- GREEK SMALL LETTER IOTA WITH PERISPOMENI .. GREEK CAPITAL LETTER IOTA WITH OXIA - (16#01FE0#, 16#01FEC#), -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER RHO WITH DASIA - (16#01FF2#, 16#01FF4#), -- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI .. GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI - (16#01FF6#, 16#01FFC#), -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI .. GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI - (16#02071#, 16#02071#), -- SUPERSCRIPT LATIN SMALL LETTER I .. SUPERSCRIPT LATIN SMALL LETTER I - (16#0207F#, 16#0207F#), -- SUPERSCRIPT LATIN SMALL LETTER N .. SUPERSCRIPT LATIN SMALL LETTER N - (16#02102#, 16#02102#), -- DOUBLE-STRUCK CAPITAL C .. DOUBLE-STRUCK CAPITAL C - (16#02107#, 16#02107#), -- EULER CONSTANT .. EULER CONSTANT - (16#0210A#, 16#02113#), -- SCRIPT SMALL G .. SCRIPT SMALL L - (16#02115#, 16#02115#), -- DOUBLE-STRUCK CAPITAL N .. DOUBLE-STRUCK CAPITAL N - (16#02119#, 16#0211D#), -- DOUBLE-STRUCK CAPITAL P .. DOUBLE-STRUCK CAPITAL R - (16#02124#, 16#02124#), -- DOUBLE-STRUCK CAPITAL Z .. DOUBLE-STRUCK CAPITAL Z - (16#02126#, 16#02126#), -- OHM SIGN .. OHM SIGN - (16#02128#, 16#02128#), -- BLACK-LETTER CAPITAL Z .. BLACK-LETTER CAPITAL Z - (16#0212A#, 16#0212D#), -- KELVIN SIGN .. BLACK-LETTER CAPITAL C - (16#0212F#, 16#02131#), -- SCRIPT SMALL E .. SCRIPT CAPITAL F - (16#02133#, 16#02139#), -- SCRIPT CAPITAL M .. INFORMATION SOURCE - (16#0213D#, 16#0213F#), -- DOUBLE-STRUCK SMALL GAMMA .. DOUBLE-STRUCK CAPITAL PI - (16#02145#, 16#02149#), -- DOUBLE-STRUCK ITALIC CAPITAL D .. DOUBLE-STRUCK ITALIC SMALL J - (16#02160#, 16#02183#), -- ROMAN NUMERAL ONE .. ROMAN NUMERAL REVERSED ONE HUNDRED - (16#03005#, 16#03007#), -- IDEOGRAPHIC ITERATION MARK .. IDEOGRAPHIC NUMBER ZERO - (16#03021#, 16#03029#), -- HANGZHOU NUMERAL ONE .. HANGZHOU NUMERAL NINE - (16#03031#, 16#03035#), -- VERTICAL KANA REPEAT MARK .. VERTICAL KANA REPEAT MARK LOWER HALF - (16#03038#, 16#0303C#), -- HANGZHOU NUMERAL TEN .. MASU MARK - (16#03041#, 16#03096#), -- HIRAGANA LETTER SMALL A .. HIRAGANA LETTER SMALL KE - (16#0309D#, 16#0309F#), -- HIRAGANA ITERATION MARK .. HIRAGANA DIGRAPH YORI - (16#030A1#, 16#030FA#), -- KATAKANA LETTER SMALL A .. KATAKANA LETTER VO - (16#030FC#, 16#030FF#), -- KATAKANA-HIRAGANA PROLONGED SOUND MARK .. KATAKANA DIGRAPH KOTO - (16#03105#, 16#0312C#), -- BOPOMOFO LETTER B .. BOPOMOFO LETTER GN - (16#03131#, 16#0318E#), -- HANGUL LETTER KIYEOK .. HANGUL LETTER ARAEAE - (16#031A0#, 16#031B7#), -- BOPOMOFO LETTER BU .. BOPOMOFO FINAL LETTER H - (16#031F0#, 16#031FF#), -- KATAKANA LETTER SMALL KU .. KATAKANA LETTER SMALL RO - (16#03400#, 16#04DB5#), -- .. - (16#04E00#, 16#09FA5#), -- .. - (16#0A000#, 16#0A48C#), -- YI SYLLABLE IT .. YI SYLLABLE YYR - (16#0AC00#, 16#0D7A3#), -- .. - (16#0F900#, 16#0FA2D#), -- CJK COMPATIBILITY IDEOGRAPH-F900 .. CJK COMPATIBILITY IDEOGRAPH-FA2D - (16#0FA30#, 16#0FA6A#), -- CJK COMPATIBILITY IDEOGRAPH-FA30 .. CJK COMPATIBILITY IDEOGRAPH-FA6A - (16#0FB00#, 16#0FB06#), -- LATIN SMALL LIGATURE FF .. LATIN SMALL LIGATURE ST - (16#0FB13#, 16#0FB17#), -- ARMENIAN SMALL LIGATURE MEN NOW .. ARMENIAN SMALL LIGATURE MEN XEH - (16#0FB1D#, 16#0FB1D#), -- HEBREW LETTER YOD WITH HIRIQ .. HEBREW LETTER YOD WITH HIRIQ - (16#0FB1F#, 16#0FB28#), -- HEBREW LIGATURE YIDDISH YOD YOD PATAH .. HEBREW LETTER WIDE TAV - (16#0FB2A#, 16#0FB36#), -- HEBREW LETTER SHIN WITH SHIN DOT .. HEBREW LETTER ZAYIN WITH DAGESH - (16#0FB38#, 16#0FB3C#), -- HEBREW LETTER TET WITH DAGESH .. HEBREW LETTER LAMED WITH DAGESH - (16#0FB3E#, 16#0FB3E#), -- HEBREW LETTER MEM WITH DAGESH .. HEBREW LETTER MEM WITH DAGESH - (16#0FB40#, 16#0FB41#), -- HEBREW LETTER NUN WITH DAGESH .. HEBREW LETTER SAMEKH WITH DAGESH - (16#0FB43#, 16#0FB44#), -- HEBREW LETTER FINAL PE WITH DAGESH .. HEBREW LETTER PE WITH DAGESH - (16#0FB46#, 16#0FBB1#), -- HEBREW LETTER TSADI WITH DAGESH .. ARABIC LETTER YEH BARREE WITH HAMZA ABOVE FINAL FORM - (16#0FBD3#, 16#0FD3D#), -- ARABIC LETTER NG ISOLATED FORM .. ARABIC LIGATURE ALEF WITH FATHATAN ISOLATED FORM - (16#0FD50#, 16#0FD8F#), -- ARABIC LIGATURE TEH WITH JEEM WITH MEEM INITIAL FORM .. ARABIC LIGATURE MEEM WITH KHAH WITH MEEM INITIAL FORM - (16#0FD92#, 16#0FDC7#), -- ARABIC LIGATURE MEEM WITH JEEM WITH KHAH INITIAL FORM .. ARABIC LIGATURE NOON WITH JEEM WITH YEH FINAL FORM - (16#0FDF0#, 16#0FDFB#), -- ARABIC LIGATURE SALLA USED AS KORANIC STOP SIGN ISOLATED FORM .. ARABIC LIGATURE JALLAJALALOUHOU - (16#0FE70#, 16#0FE74#), -- ARABIC FATHATAN ISOLATED FORM .. ARABIC KASRATAN ISOLATED FORM - (16#0FE76#, 16#0FEFC#), -- ARABIC FATHA ISOLATED FORM .. ARABIC LIGATURE LAM WITH ALEF FINAL FORM - (16#0FF21#, 16#0FF3A#), -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z - (16#0FF41#, 16#0FF5A#), -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z - (16#0FF66#, 16#0FFBE#), -- HALFWIDTH KATAKANA LETTER WO .. HALFWIDTH HANGUL LETTER HIEUH - (16#0FFC2#, 16#0FFC7#), -- HALFWIDTH HANGUL LETTER A .. HALFWIDTH HANGUL LETTER E - (16#0FFCA#, 16#0FFCF#), -- HALFWIDTH HANGUL LETTER YEO .. HALFWIDTH HANGUL LETTER OE - (16#0FFD2#, 16#0FFD7#), -- HALFWIDTH HANGUL LETTER YO .. HALFWIDTH HANGUL LETTER YU - (16#0FFDA#, 16#0FFDC#), -- HALFWIDTH HANGUL LETTER EU .. HALFWIDTH HANGUL LETTER I - (16#10000#, 16#1000B#), -- LINEAR B SYLLABLE B008 A .. LINEAR B SYLLABLE B046 JE - (16#1000D#, 16#10026#), -- LINEAR B SYLLABLE B036 JO .. LINEAR B SYLLABLE B032 QO - (16#10028#, 16#1003A#), -- LINEAR B SYLLABLE B060 RA .. LINEAR B SYLLABLE B042 WO - (16#1003C#, 16#1003D#), -- LINEAR B SYLLABLE B017 ZA .. LINEAR B SYLLABLE B074 ZE - (16#1003F#, 16#1004D#), -- LINEAR B SYLLABLE B020 ZO .. LINEAR B SYLLABLE B091 TWO - (16#10050#, 16#1005D#), -- LINEAR B SYMBOL B018 .. LINEAR B SYMBOL B089 - (16#10080#, 16#100FA#), -- LINEAR B IDEOGRAM B100 MAN .. LINEAR B IDEOGRAM VESSEL B305 - (16#10300#, 16#1031E#), -- OLD ITALIC LETTER A .. OLD ITALIC LETTER UU - (16#10330#, 16#1034A#), -- GOTHIC LETTER AHSA .. GOTHIC LETTER NINE HUNDRED - (16#10380#, 16#1039D#), -- UGARITIC LETTER ALPA .. UGARITIC LETTER SSU - (16#10400#, 16#1049D#), -- DESERET CAPITAL LETTER LONG I .. OSMANYA LETTER OO - (16#10800#, 16#10805#), -- CYPRIOT SYLLABLE A .. CYPRIOT SYLLABLE JA - (16#10808#, 16#10808#), -- CYPRIOT SYLLABLE JO .. CYPRIOT SYLLABLE JO - (16#1080A#, 16#10835#), -- CYPRIOT SYLLABLE KA .. CYPRIOT SYLLABLE WO - (16#10837#, 16#10838#), -- CYPRIOT SYLLABLE XA .. CYPRIOT SYLLABLE XE - (16#1083C#, 16#1083C#), -- CYPRIOT SYLLABLE ZA .. CYPRIOT SYLLABLE ZA - (16#1083F#, 16#1083F#), -- CYPRIOT SYLLABLE ZO .. CYPRIOT SYLLABLE ZO - (16#1D400#, 16#1D454#), -- MATHEMATICAL BOLD CAPITAL A .. MATHEMATICAL ITALIC SMALL G - (16#1D456#, 16#1D49C#), -- MATHEMATICAL ITALIC SMALL I .. MATHEMATICAL SCRIPT CAPITAL A - (16#1D49E#, 16#1D49F#), -- MATHEMATICAL SCRIPT CAPITAL C .. MATHEMATICAL SCRIPT CAPITAL D - (16#1D4A2#, 16#1D4A2#), -- MATHEMATICAL SCRIPT CAPITAL G .. MATHEMATICAL SCRIPT CAPITAL G - (16#1D4A5#, 16#1D4A6#), -- MATHEMATICAL SCRIPT CAPITAL J .. MATHEMATICAL SCRIPT CAPITAL K - (16#1D4A9#, 16#1D4AC#), -- MATHEMATICAL SCRIPT CAPITAL N .. MATHEMATICAL SCRIPT CAPITAL Q - (16#1D4AE#, 16#1D4B9#), -- MATHEMATICAL SCRIPT CAPITAL S .. MATHEMATICAL SCRIPT SMALL D - (16#1D4BB#, 16#1D4BB#), -- MATHEMATICAL SCRIPT SMALL F .. MATHEMATICAL SCRIPT SMALL F - (16#1D4BD#, 16#1D4C3#), -- MATHEMATICAL SCRIPT SMALL H .. MATHEMATICAL SCRIPT SMALL N - (16#1D4C5#, 16#1D505#), -- MATHEMATICAL SCRIPT SMALL P .. MATHEMATICAL FRAKTUR CAPITAL B - (16#1D507#, 16#1D50A#), -- MATHEMATICAL FRAKTUR CAPITAL D .. MATHEMATICAL FRAKTUR CAPITAL G - (16#1D50D#, 16#1D514#), -- MATHEMATICAL FRAKTUR CAPITAL J .. MATHEMATICAL FRAKTUR CAPITAL Q - (16#1D516#, 16#1D51C#), -- MATHEMATICAL FRAKTUR CAPITAL S .. MATHEMATICAL FRAKTUR CAPITAL Y - (16#1D51E#, 16#1D539#), -- MATHEMATICAL FRAKTUR SMALL A .. MATHEMATICAL DOUBLE-STRUCK CAPITAL B - (16#1D53B#, 16#1D53E#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL D .. MATHEMATICAL DOUBLE-STRUCK CAPITAL G - (16#1D540#, 16#1D544#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL I .. MATHEMATICAL DOUBLE-STRUCK CAPITAL M - (16#1D546#, 16#1D546#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL O .. MATHEMATICAL DOUBLE-STRUCK CAPITAL O - (16#1D54A#, 16#1D550#), -- MATHEMATICAL DOUBLE-STRUCK CAPITAL S .. MATHEMATICAL DOUBLE-STRUCK CAPITAL Y - (16#1D552#, 16#1D6A3#), -- MATHEMATICAL DOUBLE-STRUCK SMALL A .. MATHEMATICAL MONOSPACE SMALL Z - (16#1D6A8#, 16#1D6C0#), -- MATHEMATICAL BOLD CAPITAL ALPHA .. MATHEMATICAL BOLD CAPITAL OMEGA - (16#1D6C2#, 16#1D6DA#), -- MATHEMATICAL BOLD SMALL ALPHA .. MATHEMATICAL BOLD SMALL OMEGA - (16#1D6DC#, 16#1D6FA#), -- MATHEMATICAL BOLD EPSILON SYMBOL .. MATHEMATICAL ITALIC CAPITAL OMEGA - (16#1D6FC#, 16#1D714#), -- MATHEMATICAL ITALIC SMALL ALPHA .. MATHEMATICAL ITALIC SMALL OMEGA - (16#1D716#, 16#1D734#), -- MATHEMATICAL ITALIC EPSILON SYMBOL .. MATHEMATICAL BOLD ITALIC CAPITAL OMEGA - (16#1D736#, 16#1D74E#), -- MATHEMATICAL BOLD ITALIC SMALL ALPHA .. MATHEMATICAL BOLD ITALIC SMALL OMEGA - (16#1D750#, 16#1D76E#), -- MATHEMATICAL BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD CAPITAL OMEGA - (16#1D770#, 16#1D788#), -- MATHEMATICAL SANS-SERIF BOLD SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD SMALL OMEGA - (16#1D78A#, 16#1D7A8#), -- MATHEMATICAL SANS-SERIF BOLD EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC CAPITAL OMEGA - (16#1D7AA#, 16#1D7C2#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL ALPHA .. MATHEMATICAL SANS-SERIF BOLD ITALIC SMALL OMEGA - (16#1D7C4#, 16#1D7C9#), -- MATHEMATICAL SANS-SERIF BOLD ITALIC EPSILON SYMBOL .. MATHEMATICAL SANS-SERIF BOLD ITALIC PI SYMBOL - (16#20000#, 16#2A6D6#), -- .. - (16#2F800#, 16#2FA1D#)); -- CJK COMPATIBILITY IDEOGRAPH-2F800 .. CJK COMPATIBILITY IDEOGRAPH-2FA1D - - -- The following table includes all characters considered spaces, i.e. - -- all characters from the Unicode table with categories: - - -- Separator, Space (Zs) - - UTF_32_Spaces : constant UTF_32_Ranges := ( - (16#00020#, 16#00020#), -- SPACE .. SPACE - (16#000A0#, 16#000A0#), -- NO-BREAK SPACE .. NO-BREAK SPACE - (16#01680#, 16#01680#), -- OGHAM SPACE MARK .. OGHAM SPACE MARK - (16#0180E#, 16#0180E#), -- MONGOLIAN VOWEL SEPARATOR .. MONGOLIAN VOWEL SEPARATOR - (16#02000#, 16#0200B#), -- EN QUAD .. ZERO WIDTH SPACE - (16#0202F#, 16#0202F#), -- NARROW NO-BREAK SPACE .. NARROW NO-BREAK SPACE - (16#0205F#, 16#0205F#), -- MEDIUM MATHEMATICAL SPACE .. MEDIUM MATHEMATICAL SPACE - (16#03000#, 16#03000#)); -- IDEOGRAPHIC SPACE .. IDEOGRAPHIC SPACE - - -- The following table includes all characters considered punctuation, - -- i.e. all characters from the Unicode table with categories: - - -- Punctuation, Connector (Pc) - - UTF_32_Punctuation : constant UTF_32_Ranges := ( - (16#0005F#, 16#0005F#), -- LOW LINE .. LOW LINE - (16#0203F#, 16#02040#), -- UNDERTIE .. CHARACTER TIE - (16#02054#, 16#02054#), -- INVERTED UNDERTIE .. INVERTED UNDERTIE - (16#030FB#, 16#030FB#), -- KATAKANA MIDDLE DOT .. KATAKANA MIDDLE DOT - (16#0FE33#, 16#0FE34#), -- PRESENTATION FORM FOR VERTICAL LOW LINE .. PRESENTATION FORM FOR VERTICAL WAVY LOW LINE - (16#0FE4D#, 16#0FE4F#), -- DASHED LOW LINE .. WAVY LOW LINE - (16#0FF3F#, 16#0FF3F#), -- FULLWIDTH LOW LINE .. FULLWIDTH LOW LINE - (16#0FF65#, 16#0FF65#)); -- HALFWIDTH KATAKANA MIDDLE DOT .. HALFWIDTH KATAKANA MIDDLE DOT - - -- The following table includes all characters considered as other format, - -- i.e. all characters from the Unicode table with categories: - - -- Other, Format (Cf) - - UTF_32_Other_Format : constant UTF_32_Ranges := ( - (16#000AD#, 16#000AD#), -- SOFT HYPHEN .. SOFT HYPHEN - (16#00600#, 16#00603#), -- ARABIC NUMBER SIGN .. ARABIC SIGN SAFHA - (16#006DD#, 16#006DD#), -- ARABIC END OF AYAH .. ARABIC END OF AYAH - (16#0070F#, 16#0070F#), -- SYRIAC ABBREVIATION MARK .. SYRIAC ABBREVIATION MARK - (16#017B4#, 16#017B5#), -- KHMER VOWEL INHERENT AQ .. KHMER VOWEL INHERENT AA - (16#0200C#, 16#0200F#), -- ZERO WIDTH NON-JOINER .. RIGHT-TO-LEFT MARK - (16#0202A#, 16#0202E#), -- LEFT-TO-RIGHT EMBEDDING .. RIGHT-TO-LEFT OVERRIDE - (16#02060#, 16#02063#), -- WORD JOINER .. INVISIBLE SEPARATOR - (16#0206A#, 16#0206F#), -- INHIBIT SYMMETRIC SWAPPING .. NOMINAL DIGIT SHAPES - (16#0FEFF#, 16#0FEFF#), -- ZERO WIDTH NO-BREAK SPACE .. ZERO WIDTH NO-BREAK SPACE - (16#0FFF9#, 16#0FFFB#), -- INTERLINEAR ANNOTATION ANCHOR .. INTERLINEAR ANNOTATION TERMINATOR - (16#1D173#, 16#1D17A#), -- MUSICAL SYMBOL BEGIN BEAM .. MUSICAL SYMBOL END PHRASE - (16#E0001#, 16#E0001#), -- LANGUAGE TAG .. LANGUAGE TAG - (16#E0020#, 16#E007F#)); -- TAG SPACE .. CANCEL TAG - - -- The following table includes all characters considered marks i.e. - -- all characters from the Unicode table with categories: - - -- Mark, Nonspacing (Mn) - -- Mark, Spacing Combining (Mc) - - UTF_32_Marks : constant UTF_32_Ranges := ( - (16#00300#, 16#00357#), -- COMBINING GRAVE ACCENT .. COMBINING RIGHT HALF RING ABOVE - (16#0035D#, 16#0036F#), -- COMBINING DOUBLE BREVE .. COMBINING LATIN SMALL LETTER X - (16#00483#, 16#00486#), -- COMBINING CYRILLIC TITLO .. COMBINING CYRILLIC PSILI PNEUMATA - (16#00591#, 16#005A1#), -- HEBREW ACCENT ETNAHTA .. HEBREW ACCENT PAZER - (16#005A3#, 16#005B9#), -- HEBREW ACCENT MUNAH .. HEBREW POINT HOLAM - (16#005BB#, 16#005BD#), -- HEBREW POINT QUBUTS .. HEBREW POINT METEG - (16#005BF#, 16#005BF#), -- HEBREW POINT RAFE .. HEBREW POINT RAFE - (16#005C1#, 16#005C2#), -- HEBREW POINT SHIN DOT .. HEBREW POINT SIN DOT - (16#005C4#, 16#005C4#), -- HEBREW MARK UPPER DOT .. HEBREW MARK UPPER DOT - (16#00610#, 16#00615#), -- ARABIC SIGN SALLALLAHOU ALAYHE WASSALLAM .. ARABIC SMALL HIGH TAH - (16#0064B#, 16#00658#), -- ARABIC FATHATAN .. ARABIC MARK NOON GHUNNA - (16#00670#, 16#00670#), -- ARABIC LETTER SUPERSCRIPT ALEF .. ARABIC LETTER SUPERSCRIPT ALEF - (16#006D6#, 16#006DC#), -- ARABIC SMALL HIGH LIGATURE SAD WITH LAM WITH ALEF MAKSURA .. ARABIC SMALL HIGH SEEN - (16#006DF#, 16#006E4#), -- ARABIC SMALL HIGH ROUNDED ZERO .. ARABIC SMALL HIGH MADDA - (16#006E7#, 16#006E8#), -- ARABIC SMALL HIGH YEH .. ARABIC SMALL HIGH NOON - (16#006EA#, 16#006ED#), -- ARABIC EMPTY CENTRE LOW STOP .. ARABIC SMALL LOW MEEM - (16#00711#, 16#00711#), -- SYRIAC LETTER SUPERSCRIPT ALAPH .. SYRIAC LETTER SUPERSCRIPT ALAPH - (16#00730#, 16#0074A#), -- SYRIAC PTHAHA ABOVE .. SYRIAC BARREKH - (16#007A6#, 16#007B0#), -- THAANA ABAFILI .. THAANA SUKUN - (16#00901#, 16#00903#), -- DEVANAGARI SIGN CANDRABINDU .. DEVANAGARI SIGN VISARGA - (16#0093C#, 16#0093C#), -- DEVANAGARI SIGN NUKTA .. DEVANAGARI SIGN NUKTA - (16#0093E#, 16#0094D#), -- DEVANAGARI VOWEL SIGN AA .. DEVANAGARI SIGN VIRAMA - (16#00951#, 16#00954#), -- DEVANAGARI STRESS SIGN UDATTA .. DEVANAGARI ACUTE ACCENT - (16#00962#, 16#00963#), -- DEVANAGARI VOWEL SIGN VOCALIC L .. DEVANAGARI VOWEL SIGN VOCALIC LL - (16#00981#, 16#00983#), -- BENGALI SIGN CANDRABINDU .. BENGALI SIGN VISARGA - (16#009BC#, 16#009BC#), -- BENGALI SIGN NUKTA .. BENGALI SIGN NUKTA - (16#009BE#, 16#009C4#), -- BENGALI VOWEL SIGN AA .. BENGALI VOWEL SIGN VOCALIC RR - (16#009C7#, 16#009C8#), -- BENGALI VOWEL SIGN E .. BENGALI VOWEL SIGN AI - (16#009CB#, 16#009CD#), -- BENGALI VOWEL SIGN O .. BENGALI SIGN VIRAMA - (16#009D7#, 16#009D7#), -- BENGALI AU LENGTH MARK .. BENGALI AU LENGTH MARK - (16#009E2#, 16#009E3#), -- BENGALI VOWEL SIGN VOCALIC L .. BENGALI VOWEL SIGN VOCALIC LL - (16#00A01#, 16#00A03#), -- GURMUKHI SIGN ADAK BINDI .. GURMUKHI SIGN VISARGA - (16#00A3C#, 16#00A3C#), -- GURMUKHI SIGN NUKTA .. GURMUKHI SIGN NUKTA - (16#00A3E#, 16#00A42#), -- GURMUKHI VOWEL SIGN AA .. GURMUKHI VOWEL SIGN UU - (16#00A47#, 16#00A48#), -- GURMUKHI VOWEL SIGN EE .. GURMUKHI VOWEL SIGN AI - (16#00A4B#, 16#00A4D#), -- GURMUKHI VOWEL SIGN OO .. GURMUKHI SIGN VIRAMA - (16#00A70#, 16#00A71#), -- GURMUKHI TIPPI .. GURMUKHI ADDAK - (16#00A81#, 16#00A83#), -- GUJARATI SIGN CANDRABINDU .. GUJARATI SIGN VISARGA - (16#00ABC#, 16#00ABC#), -- GUJARATI SIGN NUKTA .. GUJARATI SIGN NUKTA - (16#00ABE#, 16#00AC5#), -- GUJARATI VOWEL SIGN AA .. GUJARATI VOWEL SIGN CANDRA E - (16#00AC7#, 16#00AC9#), -- GUJARATI VOWEL SIGN E .. GUJARATI VOWEL SIGN CANDRA O - (16#00ACB#, 16#00ACD#), -- GUJARATI VOWEL SIGN O .. GUJARATI SIGN VIRAMA - (16#00AE2#, 16#00AE3#), -- GUJARATI VOWEL SIGN VOCALIC L .. GUJARATI VOWEL SIGN VOCALIC LL - (16#00B01#, 16#00B03#), -- ORIYA SIGN CANDRABINDU .. ORIYA SIGN VISARGA - (16#00B3C#, 16#00B3C#), -- ORIYA SIGN NUKTA .. ORIYA SIGN NUKTA - (16#00B3E#, 16#00B43#), -- ORIYA VOWEL SIGN AA .. ORIYA VOWEL SIGN VOCALIC R - (16#00B47#, 16#00B48#), -- ORIYA VOWEL SIGN E .. ORIYA VOWEL SIGN AI - (16#00B4B#, 16#00B4D#), -- ORIYA VOWEL SIGN O .. ORIYA SIGN VIRAMA - (16#00B56#, 16#00B57#), -- ORIYA AI LENGTH MARK .. ORIYA AU LENGTH MARK - (16#00B82#, 16#00B82#), -- TAMIL SIGN ANUSVARA .. TAMIL SIGN ANUSVARA - (16#00BBE#, 16#00BC2#), -- TAMIL VOWEL SIGN AA .. TAMIL VOWEL SIGN UU - (16#00BC6#, 16#00BC8#), -- TAMIL VOWEL SIGN E .. TAMIL VOWEL SIGN AI - (16#00BCA#, 16#00BCD#), -- TAMIL VOWEL SIGN O .. TAMIL SIGN VIRAMA - (16#00BD7#, 16#00BD7#), -- TAMIL AU LENGTH MARK .. TAMIL AU LENGTH MARK - (16#00C01#, 16#00C03#), -- TELUGU SIGN CANDRABINDU .. TELUGU SIGN VISARGA - (16#00C3E#, 16#00C44#), -- TELUGU VOWEL SIGN AA .. TELUGU VOWEL SIGN VOCALIC RR - (16#00C46#, 16#00C48#), -- TELUGU VOWEL SIGN E .. TELUGU VOWEL SIGN AI - (16#00C4A#, 16#00C4D#), -- TELUGU VOWEL SIGN O .. TELUGU SIGN VIRAMA - (16#00C55#, 16#00C56#), -- TELUGU LENGTH MARK .. TELUGU AI LENGTH MARK - (16#00C82#, 16#00C83#), -- KANNADA SIGN ANUSVARA .. KANNADA SIGN VISARGA - (16#00CBC#, 16#00CBC#), -- KANNADA SIGN NUKTA .. KANNADA SIGN NUKTA - (16#00CBE#, 16#00CC4#), -- KANNADA VOWEL SIGN AA .. KANNADA VOWEL SIGN VOCALIC RR - (16#00CC6#, 16#00CC8#), -- KANNADA VOWEL SIGN E .. KANNADA VOWEL SIGN AI - (16#00CCA#, 16#00CCD#), -- KANNADA VOWEL SIGN O .. KANNADA SIGN VIRAMA - (16#00CD5#, 16#00CD6#), -- KANNADA LENGTH MARK .. KANNADA AI LENGTH MARK - (16#00D02#, 16#00D03#), -- MALAYALAM SIGN ANUSVARA .. MALAYALAM SIGN VISARGA - (16#00D3E#, 16#00D43#), -- MALAYALAM VOWEL SIGN AA .. MALAYALAM VOWEL SIGN VOCALIC R - (16#00D46#, 16#00D48#), -- MALAYALAM VOWEL SIGN E .. MALAYALAM VOWEL SIGN AI - (16#00D4A#, 16#00D4D#), -- MALAYALAM VOWEL SIGN O .. MALAYALAM SIGN VIRAMA - (16#00D57#, 16#00D57#), -- MALAYALAM AU LENGTH MARK .. MALAYALAM AU LENGTH MARK - (16#00D82#, 16#00D83#), -- SINHALA SIGN ANUSVARAYA .. SINHALA SIGN VISARGAYA - (16#00DCA#, 16#00DCA#), -- SINHALA SIGN AL-LAKUNA .. SINHALA SIGN AL-LAKUNA - (16#00DCF#, 16#00DD4#), -- SINHALA VOWEL SIGN AELA-PILLA .. SINHALA VOWEL SIGN KETTI PAA-PILLA - (16#00DD6#, 16#00DD6#), -- SINHALA VOWEL SIGN DIGA PAA-PILLA .. SINHALA VOWEL SIGN DIGA PAA-PILLA - (16#00DD8#, 16#00DDF#), -- SINHALA VOWEL SIGN GAETTA-PILLA .. SINHALA VOWEL SIGN GAYANUKITTA - (16#00DF2#, 16#00DF3#), -- SINHALA VOWEL SIGN DIGA GAETTA-PILLA .. SINHALA VOWEL SIGN DIGA GAYANUKITTA - (16#00E31#, 16#00E31#), -- THAI CHARACTER MAI HAN-AKAT .. THAI CHARACTER MAI HAN-AKAT - (16#00E34#, 16#00E3A#), -- THAI CHARACTER SARA I .. THAI CHARACTER PHINTHU - (16#00E47#, 16#00E4E#), -- THAI CHARACTER MAITAIKHU .. THAI CHARACTER YAMAKKAN - (16#00EB1#, 16#00EB1#), -- LAO VOWEL SIGN MAI KAN .. LAO VOWEL SIGN MAI KAN - (16#00EB4#, 16#00EB9#), -- LAO VOWEL SIGN I .. LAO VOWEL SIGN UU - (16#00EBB#, 16#00EBC#), -- LAO VOWEL SIGN MAI KON .. LAO SEMIVOWEL SIGN LO - (16#00EC8#, 16#00ECD#), -- LAO TONE MAI EK .. LAO NIGGAHITA - (16#00F18#, 16#00F19#), -- TIBETAN ASTROLOGICAL SIGN -KHYUD PA .. TIBETAN ASTROLOGICAL SIGN SDONG TSHUGS - (16#00F35#, 16#00F35#), -- TIBETAN MARK NGAS BZUNG NYI ZLA .. TIBETAN MARK NGAS BZUNG NYI ZLA - (16#00F37#, 16#00F37#), -- TIBETAN MARK NGAS BZUNG SGOR RTAGS .. TIBETAN MARK NGAS BZUNG SGOR RTAGS - (16#00F39#, 16#00F39#), -- TIBETAN MARK TSA -PHRU .. TIBETAN MARK TSA -PHRU - (16#00F3E#, 16#00F3F#), -- TIBETAN SIGN YAR TSHES .. TIBETAN SIGN MAR TSHES - (16#00F71#, 16#00F84#), -- TIBETAN VOWEL SIGN AA .. TIBETAN MARK HALANTA - (16#00F86#, 16#00F87#), -- TIBETAN SIGN LCI RTAGS .. TIBETAN SIGN YANG RTAGS - (16#00F90#, 16#00F97#), -- TIBETAN SUBJOINED LETTER KA .. TIBETAN SUBJOINED LETTER JA - (16#00F99#, 16#00FBC#), -- TIBETAN SUBJOINED LETTER NYA .. TIBETAN SUBJOINED LETTER FIXED-FORM RA - (16#00FC6#, 16#00FC6#), -- TIBETAN SYMBOL PADMA GDAN .. TIBETAN SYMBOL PADMA GDAN - (16#0102C#, 16#01032#), -- MYANMAR VOWEL SIGN AA .. MYANMAR VOWEL SIGN AI - (16#01036#, 16#01039#), -- MYANMAR SIGN ANUSVARA .. MYANMAR SIGN VIRAMA - (16#01056#, 16#01059#), -- MYANMAR VOWEL SIGN VOCALIC R .. MYANMAR VOWEL SIGN VOCALIC LL - (16#01712#, 16#01714#), -- TAGALOG VOWEL SIGN I .. TAGALOG SIGN VIRAMA - (16#01732#, 16#01734#), -- HANUNOO VOWEL SIGN I .. HANUNOO SIGN PAMUDPOD - (16#01752#, 16#01753#), -- BUHID VOWEL SIGN I .. BUHID VOWEL SIGN U - (16#01772#, 16#01773#), -- TAGBANWA VOWEL SIGN I .. TAGBANWA VOWEL SIGN U - (16#017B6#, 16#017D3#), -- KHMER VOWEL SIGN AA .. KHMER SIGN BATHAMASAT - (16#017DD#, 16#017DD#), -- KHMER SIGN ATTHACAN .. KHMER SIGN ATTHACAN - (16#0180B#, 16#0180D#), -- MONGOLIAN FREE VARIATION SELECTOR ONE .. MONGOLIAN FREE VARIATION SELECTOR THREE - (16#018A9#, 16#018A9#), -- MONGOLIAN LETTER ALI GALI DAGALGA .. MONGOLIAN LETTER ALI GALI DAGALGA - (16#01920#, 16#0192B#), -- LIMBU VOWEL SIGN A .. LIMBU SUBJOINED LETTER WA - (16#01930#, 16#0193B#), -- LIMBU SMALL LETTER KA .. LIMBU SIGN SA-I - (16#020D0#, 16#020DC#), -- COMBINING LEFT HARPOON ABOVE .. COMBINING FOUR DOTS ABOVE - (16#020E1#, 16#020E1#), -- COMBINING LEFT RIGHT ARROW ABOVE .. COMBINING LEFT RIGHT ARROW ABOVE - (16#020E5#, 16#020EA#), -- COMBINING REVERSE SOLIDUS OVERLAY .. COMBINING LEFTWARDS ARROW OVERLAY - (16#0302A#, 16#0302F#), -- IDEOGRAPHIC LEVEL TONE MARK .. HANGUL DOUBLE DOT TONE MARK - (16#03099#, 16#0309A#), -- COMBINING KATAKANA-HIRAGANA VOICED SOUND MARK .. COMBINING KATAKANA-HIRAGANA SEMI-VOICED SOUND MARK - (16#0FB1E#, 16#0FB1E#), -- HEBREW POINT JUDEO-SPANISH VARIKA .. HEBREW POINT JUDEO-SPANISH VARIKA - (16#0FE00#, 16#0FE0F#), -- VARIATION SELECTOR-1 .. VARIATION SELECTOR-16 - (16#0FE20#, 16#0FE23#), -- COMBINING LIGATURE LEFT HALF .. COMBINING DOUBLE TILDE RIGHT HALF - (16#1D165#, 16#1D169#), -- MUSICAL SYMBOL COMBINING STEM .. MUSICAL SYMBOL COMBINING TREMOLO-3 - (16#1D16D#, 16#1D172#), -- MUSICAL SYMBOL COMBINING AUGMENTATION DOT .. MUSICAL SYMBOL COMBINING FLAG-5 - (16#1D17B#, 16#1D182#), -- MUSICAL SYMBOL COMBINING ACCENT .. MUSICAL SYMBOL COMBINING LOURE - (16#1D185#, 16#1D18B#), -- MUSICAL SYMBOL COMBINING DOIT .. MUSICAL SYMBOL COMBINING TRIPLE TONGUE - (16#1D1AA#, 16#1D1AD#), -- MUSICAL SYMBOL COMBINING DOWN BOW .. MUSICAL SYMBOL COMBINING SNAP PIZZICATO - (16#E0100#, 16#E01EF#)); -- VARIATION SELECTOR-17 .. VARIATION SELECTOR-256 - - -- The following table includes all characters considered non-graphic, - -- i.e. all characters from the Unicode table with categories: - - -- Other, Control (Cc) - -- Other, Private Use (Co) - -- Other, Surrogate (Cs) - -- Separator, Line (Zl) - -- Separator, Paragraph (Zp) - - -- Note that characters with relative positions FFFE and FFFF in their - -- planes are not included in this table (we really don't want to add - -- 32K entries for this purpose). Instead we handle these positions in - -- a completely different manner. - - -- Note: unassigned characters (category Cn) are deliberately NOT included - -- in the set of non-graphics, since the idea is that if any of these are - -- defined in the future, we don't want to have to modify the standard. - - -- Note that Other, Format (Cf) is also quite deliberately not included - -- in the list of categories above. This means that these characters can - -- be included in character and string literals. - - UTF_32_Non_Graphic : constant UTF_32_Ranges := ( - (16#00000#, 16#0001F#), -- .. - (16#0007F#, 16#0009F#), -- .. - (16#02028#, 16#02029#), -- LINE SEPARATOR .. PARAGRAPH SEPARATOR - (16#0D800#, 16#0DB7F#), -- .. - (16#0DB80#, 16#0DBFF#), -- .. - (16#0DC00#, 16#0DFFF#), -- .. - (16#0E000#, 16#0F8FF#), -- .. - (16#F0000#, 16#FFFFD#), -- .. - (16#100000#, 16#10FFFD#)); -- .. - - -- The following two tables define the mapping to upper case. The first - -- table gives the ranges of lower case letters. The corresponding entry - -- in Uppercase_Adjust shows the amount to be added to (or subtracted from - -- if the value is negative) the code value to get the corresponding upper - -- case letter. - -- - -- An entry is in this table if its 10646 has the string SMALL LETTER - -- the name, and there is a corresponding entry which has the string - -- CAPITAL LETTER in its name. - - Lower_Case_Letters : constant UTF_32_Ranges := ( - (16#00061#, 16#0007A#), -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z - (16#000E0#, 16#000F6#), -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS - (16#000F8#, 16#000FE#), -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN - (16#000FF#, 16#000FF#), -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS - (16#00101#, 16#00101#), -- LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON - (16#00103#, 16#00103#), -- LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE - (16#00105#, 16#00105#), -- LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK - (16#00107#, 16#00107#), -- LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE - (16#00109#, 16#00109#), -- LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX - (16#0010B#, 16#0010B#), -- LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE - (16#0010D#, 16#0010D#), -- LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON - (16#0010F#, 16#0010F#), -- LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON - (16#00111#, 16#00111#), -- LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE - (16#00113#, 16#00113#), -- LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON - (16#00115#, 16#00115#), -- LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE - (16#00117#, 16#00117#), -- LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE - (16#00119#, 16#00119#), -- LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK - (16#0011B#, 16#0011B#), -- LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON - (16#0011D#, 16#0011D#), -- LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX - (16#0011F#, 16#0011F#), -- LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE - (16#00121#, 16#00121#), -- LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE - (16#00123#, 16#00123#), -- LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA - (16#00125#, 16#00125#), -- LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX - (16#00127#, 16#00127#), -- LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE - (16#00129#, 16#00129#), -- LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE - (16#0012B#, 16#0012B#), -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON - (16#0012D#, 16#0012D#), -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE - (16#0012F#, 16#0012F#), -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK - (16#00133#, 16#00133#), -- LATIN SMALL LETTER I J .. LATIN SMALL LETTER I J - (16#00135#, 16#00135#), -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX - (16#00137#, 16#00137#), -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA - (16#0013A#, 16#0013A#), -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE - (16#0013C#, 16#0013C#), -- LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA - (16#0013E#, 16#0013E#), -- LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON - (16#00140#, 16#00140#), -- LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT - (16#00142#, 16#00142#), -- LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE - (16#00144#, 16#00144#), -- LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE - (16#00146#, 16#00146#), -- LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA - (16#00148#, 16#00148#), -- LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N WITH CARON - (16#0014B#, 16#0014B#), -- LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG - (16#0014D#, 16#0014D#), -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON - (16#0014F#, 16#0014F#), -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE - (16#00151#, 16#00151#), -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE - (16#00153#, 16#00153#), -- LATIN SMALL LETTER O E .. LATIN SMALL LETTER O E - (16#00155#, 16#00155#), -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE - (16#00157#, 16#00157#), -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA - (16#00159#, 16#00159#), -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON - (16#0015B#, 16#0015B#), -- LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE - (16#0015D#, 16#0015D#), -- LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX - (16#0015F#, 16#0015F#), -- LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA - (16#00161#, 16#00161#), -- LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON - (16#00163#, 16#00163#), -- LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA - (16#00165#, 16#00165#), -- LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON - (16#00167#, 16#00167#), -- LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE - (16#00169#, 16#00169#), -- LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE - (16#0016B#, 16#0016B#), -- LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON - (16#0016D#, 16#0016D#), -- LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE - (16#0016F#, 16#0016F#), -- LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE - (16#00171#, 16#00171#), -- LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE - (16#00173#, 16#00173#), -- LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK - (16#00175#, 16#00175#), -- LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX - (16#00177#, 16#00177#), -- LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX - (16#0017A#, 16#0017A#), -- LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE - (16#0017C#, 16#0017C#), -- LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE - (16#0017E#, 16#0017E#), -- LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER Z WITH CARON - (16#00183#, 16#00183#), -- LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR - (16#00185#, 16#00185#), -- LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX - (16#00188#, 16#00188#), -- LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK - (16#0018C#, 16#0018C#), -- LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER D WITH TOPBAR - (16#00192#, 16#00192#), -- LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK - (16#00199#, 16#00199#), -- LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER K WITH HOOK - (16#0019E#, 16#0019E#), -- LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG - (16#001A1#, 16#001A1#), -- LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN - (16#001A3#, 16#001A3#), -- LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI - (16#001A5#, 16#001A5#), -- LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK - (16#001A8#, 16#001A8#), -- LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO - (16#001AD#, 16#001AD#), -- LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK - (16#001B0#, 16#001B0#), -- LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN - (16#001B4#, 16#001B4#), -- LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK - (16#001B6#, 16#001B6#), -- LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE - (16#001B9#, 16#001B9#), -- LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH REVERSED - (16#001BD#, 16#001BD#), -- LATIN SMALL LETTER TONE FIVE .. LATIN SMALL LETTER TONE FIVE - (16#001C6#, 16#001C6#), -- LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON - (16#001C9#, 16#001C9#), -- LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ - (16#001CC#, 16#001CC#), -- LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ - (16#001CE#, 16#001CE#), -- LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON - (16#001D0#, 16#001D0#), -- LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON - (16#001D2#, 16#001D2#), -- LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON - (16#001D4#, 16#001D4#), -- LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON - (16#001D6#, 16#001D6#), -- LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON - (16#001D8#, 16#001D8#), -- LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE - (16#001DA#, 16#001DA#), -- LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON - (16#001DC#, 16#001DC#), -- LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE - (16#001DF#, 16#001DF#), -- LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON - (16#001E1#, 16#001E1#), -- LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON - (16#001E3#, 16#001E3#), -- LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON - (16#001E5#, 16#001E5#), -- LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE - (16#001E7#, 16#001E7#), -- LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON - (16#001E9#, 16#001E9#), -- LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON - (16#001EB#, 16#001EB#), -- LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK - (16#001ED#, 16#001ED#), -- LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON - (16#001EF#, 16#001EF#), -- LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER EZH WITH CARON - (16#001F3#, 16#001F3#), -- LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ - (16#001F5#, 16#001F5#), -- LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE - (16#001F9#, 16#001F9#), -- LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE - (16#001FB#, 16#001FB#), -- LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE - (16#001FD#, 16#001FD#), -- LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE - (16#001FF#, 16#001FF#), -- LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE - (16#00201#, 16#00201#), -- LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE - (16#00203#, 16#00203#), -- LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE - (16#00205#, 16#00205#), -- LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE - (16#00207#, 16#00207#), -- LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE - (16#00209#, 16#00209#), -- LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE - (16#0020B#, 16#0020B#), -- LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE - (16#0020D#, 16#0020D#), -- LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE - (16#0020F#, 16#0020F#), -- LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE - (16#00211#, 16#00211#), -- LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE - (16#00213#, 16#00213#), -- LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE - (16#00215#, 16#00215#), -- LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE - (16#00217#, 16#00217#), -- LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE - (16#00219#, 16#00219#), -- LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW - (16#0021B#, 16#0021B#), -- LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW - (16#0021D#, 16#0021D#), -- LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH - (16#0021F#, 16#0021F#), -- LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON - (16#00223#, 16#00223#), -- LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU - (16#00225#, 16#00225#), -- LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK - (16#00227#, 16#00227#), -- LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE - (16#00229#, 16#00229#), -- LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA - (16#0022B#, 16#0022B#), -- LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON - (16#0022D#, 16#0022D#), -- LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON - (16#0022F#, 16#0022F#), -- LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE - (16#00231#, 16#00231#), -- LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON - (16#00233#, 16#00233#), -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON - (16#00253#, 16#00253#), -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK - (16#00254#, 16#00254#), -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O - (16#00257#, 16#00257#), -- LATIN SMALL LETTER D WITH HOOK .. LATIN SMALL LETTER D WITH HOOK - (16#00258#, 16#00259#), -- LATIN SMALL LETTER REVERSED E .. LATIN SMALL LETTER SCHWA - (16#0025B#, 16#0025B#), -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E - (16#00260#, 16#00260#), -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK - (16#00263#, 16#00263#), -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA - (16#00268#, 16#00268#), -- LATIN SMALL LETTER I WITH STROKE .. LATIN SMALL LETTER I WITH STROKE - (16#00269#, 16#00269#), -- LATIN SMALL LETTER IOTA .. LATIN SMALL LETTER IOTA - (16#0026F#, 16#0026F#), -- LATIN SMALL LETTER TURNED M .. LATIN SMALL LETTER TURNED M - (16#00272#, 16#00272#), -- LATIN SMALL LETTER N WITH LEFT HOOK .. LATIN SMALL LETTER N WITH LEFT HOOK - (16#00283#, 16#00283#), -- LATIN SMALL LETTER ESH .. LATIN SMALL LETTER ESH - (16#00288#, 16#00288#), -- LATIN SMALL LETTER T WITH RETROFLEX HOOK .. LATIN SMALL LETTER T WITH RETROFLEX HOOK - (16#0028A#, 16#0028B#), -- LATIN SMALL LETTER UPSILON .. LATIN SMALL LETTER V WITH HOOK - (16#00292#, 16#00292#), -- LATIN SMALL LETTER EZH .. LATIN SMALL LETTER EZH - (16#003AC#, 16#003AC#), -- GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER ALPHA WITH TONOS - (16#003AD#, 16#003AF#), -- GREEK SMALL LETTER EPSILON WITH TONOS .. GREEK SMALL LETTER IOTA WITH TONOS - (16#003B1#, 16#003C1#), -- GREEK SMALL LETTER ALPHA .. GREEK SMALL LETTER RHO - (16#003C3#, 16#003CB#), -- GREEK SMALL LETTER SIGMA .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA - (16#003CC#, 16#003CC#), -- GREEK SMALL LETTER OMICRON WITH TONOS .. GREEK SMALL LETTER OMICRON WITH TONOS - (16#003CD#, 16#003CE#), -- GREEK SMALL LETTER UPSILON WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS - (16#003DB#, 16#003DB#), -- GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA - (16#003DD#, 16#003DD#), -- GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA - (16#003DF#, 16#003DF#), -- GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA - (16#003E1#, 16#003E1#), -- GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI - (16#003E3#, 16#003E3#), -- COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI - (16#003E5#, 16#003E5#), -- COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI - (16#003E7#, 16#003E7#), -- COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI - (16#003E9#, 16#003E9#), -- COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI - (16#003EB#, 16#003EB#), -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA - (16#003ED#, 16#003ED#), -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA - (16#003EF#, 16#003EF#), -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI - (16#003F8#, 16#003F8#), -- GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO - (16#003FB#, 16#003FB#), -- GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN - (16#00430#, 16#0044F#), -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA - (16#00450#, 16#0045F#), -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE - (16#00461#, 16#00461#), -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA - (16#00463#, 16#00463#), -- CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT - (16#00465#, 16#00465#), -- CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E - (16#00467#, 16#00467#), -- CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS - (16#00469#, 16#00469#), -- CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS - (16#0046B#, 16#0046B#), -- CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS - (16#0046D#, 16#0046D#), -- CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS - (16#0046F#, 16#0046F#), -- CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI - (16#00471#, 16#00471#), -- CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI - (16#00473#, 16#00473#), -- CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA - (16#00475#, 16#00475#), -- CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA - (16#00477#, 16#00477#), -- CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - (16#00479#, 16#00479#), -- CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK - (16#0047B#, 16#0047B#), -- CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA - (16#0047D#, 16#0047D#), -- CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO - (16#0047F#, 16#0047F#), -- CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT - (16#00481#, 16#00481#), -- CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA - (16#0048B#, 16#0048B#), -- CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL - (16#0048D#, 16#0048D#), -- CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN - (16#0048F#, 16#0048F#), -- CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK - (16#00491#, 16#00491#), -- CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN - (16#00493#, 16#00493#), -- CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE - (16#00495#, 16#00495#), -- CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK - (16#00497#, 16#00497#), -- CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER - (16#00499#, 16#00499#), -- CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER - (16#0049B#, 16#0049B#), -- CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER - (16#0049D#, 16#0049D#), -- CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE - (16#0049F#, 16#0049F#), -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE - (16#004A1#, 16#004A1#), -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA - (16#004A3#, 16#004A3#), -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER - (16#004A5#, 16#004A5#), -- CYRILLIC SMALL LETTER EN GE .. CYRILLIC SMALL LETTER EN GE - (16#004A7#, 16#004A7#), -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK - (16#004A9#, 16#004A9#), -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA - (16#004AB#, 16#004AB#), -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER - (16#004AD#, 16#004AD#), -- CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER - (16#004AF#, 16#004AF#), -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U - (16#004B1#, 16#004B1#), -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE - (16#004B3#, 16#004B3#), -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER - (16#004B5#, 16#004B5#), -- CYRILLIC SMALL LETTER TE TSE .. CYRILLIC SMALL LETTER TE TSE - (16#004B7#, 16#004B7#), -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER - (16#004B9#, 16#004B9#), -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE - (16#004BB#, 16#004BB#), -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA - (16#004BD#, 16#004BD#), -- CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE - (16#004BF#, 16#004BF#), -- CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER - (16#004C2#, 16#004C2#), -- CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE - (16#004C4#, 16#004C4#), -- CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK - (16#004C6#, 16#004C6#), -- CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL - (16#004C8#, 16#004C8#), -- CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK - (16#004CA#, 16#004CA#), -- CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL - (16#004CC#, 16#004CC#), -- CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE - (16#004CE#, 16#004CE#), -- CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL - (16#004D1#, 16#004D1#), -- CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE - (16#004D3#, 16#004D3#), -- CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS - (16#004D7#, 16#004D7#), -- CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE - (16#004D9#, 16#004D9#), -- CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA - (16#004DB#, 16#004DB#), -- CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS - (16#004DD#, 16#004DD#), -- CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS - (16#004DF#, 16#004DF#), -- CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS - (16#004E1#, 16#004E1#), -- CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE - (16#004E3#, 16#004E3#), -- CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON - (16#004E5#, 16#004E5#), -- CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS - (16#004E7#, 16#004E7#), -- CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS - (16#004E9#, 16#004E9#), -- CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O - (16#004EB#, 16#004EB#), -- CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS - (16#004ED#, 16#004ED#), -- CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS - (16#004EF#, 16#004EF#), -- CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON - (16#004F1#, 16#004F1#), -- CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS - (16#004F3#, 16#004F3#), -- CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE - (16#004F5#, 16#004F5#), -- CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS - (16#004F9#, 16#004F9#), -- CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS - (16#00501#, 16#00501#), -- CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE - (16#00503#, 16#00503#), -- CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE - (16#00505#, 16#00505#), -- CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE - (16#00507#, 16#00507#), -- CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE - (16#00509#, 16#00509#), -- CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE - (16#0050B#, 16#0050B#), -- CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE - (16#0050D#, 16#0050D#), -- CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE - (16#0050F#, 16#0050F#), -- CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE - (16#00561#, 16#00586#), -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LETTER FEH - (16#010D0#, 16#010F5#), -- GEORGIAN SMALL LETTER AN .. GEORGIAN SMALL LETTER HOE - (16#01E01#, 16#01E01#), -- LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW - (16#01E03#, 16#01E03#), -- LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE - (16#01E05#, 16#01E05#), -- LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW - (16#01E07#, 16#01E07#), -- LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW - (16#01E09#, 16#01E09#), -- LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE - (16#01E0B#, 16#01E0B#), -- LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE - (16#01E0D#, 16#01E0D#), -- LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW - (16#01E0F#, 16#01E0F#), -- LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW - (16#01E11#, 16#01E11#), -- LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA - (16#01E13#, 16#01E13#), -- LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW - (16#01E15#, 16#01E15#), -- LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE - (16#01E17#, 16#01E17#), -- LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE - (16#01E19#, 16#01E19#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW - (16#01E1B#, 16#01E1B#), -- LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW - (16#01E1D#, 16#01E1D#), -- LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE - (16#01E1F#, 16#01E1F#), -- LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE - (16#01E21#, 16#01E21#), -- LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON - (16#01E23#, 16#01E23#), -- LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE - (16#01E25#, 16#01E25#), -- LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW - (16#01E27#, 16#01E27#), -- LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS - (16#01E29#, 16#01E29#), -- LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA - (16#01E2B#, 16#01E2B#), -- LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW - (16#01E2D#, 16#01E2D#), -- LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW - (16#01E2F#, 16#01E2F#), -- LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE - (16#01E31#, 16#01E31#), -- LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE - (16#01E33#, 16#01E33#), -- LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW - (16#01E35#, 16#01E35#), -- LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW - (16#01E37#, 16#01E37#), -- LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW - (16#01E39#, 16#01E39#), -- LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON - (16#01E3B#, 16#01E3B#), -- LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW - (16#01E3D#, 16#01E3D#), -- LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW - (16#01E3F#, 16#01E3F#), -- LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE - (16#01E41#, 16#01E41#), -- LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE - (16#01E43#, 16#01E43#), -- LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW - (16#01E45#, 16#01E45#), -- LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE - (16#01E47#, 16#01E47#), -- LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW - (16#01E49#, 16#01E49#), -- LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW - (16#01E4B#, 16#01E4B#), -- LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW - (16#01E4D#, 16#01E4D#), -- LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE - (16#01E4F#, 16#01E4F#), -- LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS - (16#01E51#, 16#01E51#), -- LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE - (16#01E53#, 16#01E53#), -- LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE - (16#01E55#, 16#01E55#), -- LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE - (16#01E57#, 16#01E57#), -- LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE - (16#01E59#, 16#01E59#), -- LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE - (16#01E5B#, 16#01E5B#), -- LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW - (16#01E5D#, 16#01E5D#), -- LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON - (16#01E5F#, 16#01E5F#), -- LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW - (16#01E61#, 16#01E61#), -- LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE - (16#01E63#, 16#01E63#), -- LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW - (16#01E65#, 16#01E65#), -- LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE - (16#01E67#, 16#01E67#), -- LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE - (16#01E69#, 16#01E69#), -- LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE - (16#01E6B#, 16#01E6B#), -- LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE - (16#01E6D#, 16#01E6D#), -- LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW - (16#01E6F#, 16#01E6F#), -- LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW - (16#01E71#, 16#01E71#), -- LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW - (16#01E73#, 16#01E73#), -- LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW - (16#01E75#, 16#01E75#), -- LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW - (16#01E77#, 16#01E77#), -- LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW - (16#01E79#, 16#01E79#), -- LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE - (16#01E7B#, 16#01E7B#), -- LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS - (16#01E7D#, 16#01E7D#), -- LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE - (16#01E7F#, 16#01E7F#), -- LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW - (16#01E81#, 16#01E81#), -- LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE - (16#01E83#, 16#01E83#), -- LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE - (16#01E85#, 16#01E85#), -- LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS - (16#01E87#, 16#01E87#), -- LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE - (16#01E89#, 16#01E89#), -- LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW - (16#01E8B#, 16#01E8B#), -- LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE - (16#01E8D#, 16#01E8D#), -- LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS - (16#01E8F#, 16#01E8F#), -- LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE - (16#01E91#, 16#01E91#), -- LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX - (16#01E93#, 16#01E93#), -- LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW - (16#01E95#, 16#01E95#), -- LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER Z WITH LINE BELOW - (16#01EA1#, 16#01EA1#), -- LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW - (16#01EA3#, 16#01EA3#), -- LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE - (16#01EA5#, 16#01EA5#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE - (16#01EA7#, 16#01EA7#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE - (16#01EA9#, 16#01EA9#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EAB#, 16#01EAB#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE - (16#01EAD#, 16#01EAD#), -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW - (16#01EAF#, 16#01EAF#), -- LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE - (16#01EB1#, 16#01EB1#), -- LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE - (16#01EB3#, 16#01EB3#), -- LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE - (16#01EB5#, 16#01EB5#), -- LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE - (16#01EB7#, 16#01EB7#), -- LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW - (16#01EB9#, 16#01EB9#), -- LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW - (16#01EBB#, 16#01EBB#), -- LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE - (16#01EBD#, 16#01EBD#), -- LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE - (16#01EBF#, 16#01EBF#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE - (16#01EC1#, 16#01EC1#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE - (16#01EC3#, 16#01EC3#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EC5#, 16#01EC5#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE - (16#01EC7#, 16#01EC7#), -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW - (16#01EC9#, 16#01EC9#), -- LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE - (16#01ECB#, 16#01ECB#), -- LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW - (16#01ECD#, 16#01ECD#), -- LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW - (16#01ECF#, 16#01ECF#), -- LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE - (16#01ED1#, 16#01ED1#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE - (16#01ED3#, 16#01ED3#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE - (16#01ED5#, 16#01ED5#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - (16#01ED7#, 16#01ED7#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE - (16#01ED9#, 16#01ED9#), -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW - (16#01EDB#, 16#01EDB#), -- LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE - (16#01EDD#, 16#01EDD#), -- LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE - (16#01EDF#, 16#01EDF#), -- LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE - (16#01EE1#, 16#01EE1#), -- LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE - (16#01EE3#, 16#01EE3#), -- LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW - (16#01EE5#, 16#01EE5#), -- LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW - (16#01EE7#, 16#01EE7#), -- LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE - (16#01EE9#, 16#01EE9#), -- LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE - (16#01EEB#, 16#01EEB#), -- LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE - (16#01EED#, 16#01EED#), -- LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE - (16#01EEF#, 16#01EEF#), -- LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE - (16#01EF1#, 16#01EF1#), -- LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW - (16#01EF3#, 16#01EF3#), -- LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE - (16#01EF5#, 16#01EF5#), -- LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW - (16#01EF7#, 16#01EF7#), -- LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE - (16#01EF9#, 16#01EF9#), -- LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE - (16#01F00#, 16#01F07#), -- GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI - (16#01F10#, 16#01F15#), -- GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA - (16#01F20#, 16#01F27#), -- GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI - (16#01F30#, 16#01F37#), -- GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI - (16#01F40#, 16#01F45#), -- GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA - (16#01F51#, 16#01F51#), -- GREEK SMALL LETTER UPSILON WITH DASIA .. GREEK SMALL LETTER UPSILON WITH DASIA - (16#01F53#, 16#01F53#), -- GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA - (16#01F55#, 16#01F55#), -- GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA - (16#01F57#, 16#01F57#), -- GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI - (16#01F60#, 16#01F67#), -- GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI - (16#01F70#, 16#01F71#), -- GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER ALPHA WITH OXIA - (16#01F72#, 16#01F75#), -- GREEK SMALL LETTER EPSILON WITH VARIA .. GREEK SMALL LETTER ETA WITH OXIA - (16#01F76#, 16#01F77#), -- GREEK SMALL LETTER IOTA WITH VARIA .. GREEK SMALL LETTER IOTA WITH OXIA - (16#01F78#, 16#01F79#), -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA - (16#01F7A#, 16#01F7B#), -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA - (16#01F7C#, 16#01F7D#), -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA - (16#01FB0#, 16#01FB1#), -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON - (16#01FD0#, 16#01FD1#), -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON - (16#01FE0#, 16#01FE1#), -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON - (16#01FE5#, 16#01FE5#), -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA - (16#024D0#, 16#024E9#), -- CIRCLED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z - (16#0FF41#, 16#0FF5A#), -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z - (16#10428#, 16#1044F#), -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW - (16#E0061#, 16#E007A#)); -- TAG LATIN SMALL LETTER A .. TAG LATIN SMALL LETTER Z - - Lower_Case_Adjust : constant array (Lower_Case_Letters'Range) - of UTF_32'Base := ( - -32, -- LATIN SMALL LETTER A .. LATIN SMALL LETTER Z - -32, -- LATIN SMALL LETTER A WITH GRAVE .. LATIN SMALL LETTER O WITH DIAERESIS - -32, -- LATIN SMALL LETTER O WITH STROKE .. LATIN SMALL LETTER THORN - 121, -- LATIN SMALL LETTER Y WITH DIAERESIS .. LATIN SMALL LETTER Y WITH DIAERESIS - -1, -- LATIN SMALL LETTER A WITH MACRON .. LATIN SMALL LETTER A WITH MACRON - -1, -- LATIN SMALL LETTER A WITH BREVE .. LATIN SMALL LETTER A WITH BREVE - -1, -- LATIN SMALL LETTER A WITH OGONEK .. LATIN SMALL LETTER A WITH OGONEK - -1, -- LATIN SMALL LETTER C WITH ACUTE .. LATIN SMALL LETTER C WITH ACUTE - -1, -- LATIN SMALL LETTER C WITH CIRCUMFLEX .. LATIN SMALL LETTER C WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER C WITH DOT ABOVE .. LATIN SMALL LETTER C WITH DOT ABOVE - -1, -- LATIN SMALL LETTER C WITH CARON .. LATIN SMALL LETTER C WITH CARON - -1, -- LATIN SMALL LETTER D WITH CARON .. LATIN SMALL LETTER D WITH CARON - -1, -- LATIN SMALL LETTER D WITH STROKE .. LATIN SMALL LETTER D WITH STROKE - -1, -- LATIN SMALL LETTER E WITH MACRON .. LATIN SMALL LETTER E WITH MACRON - -1, -- LATIN SMALL LETTER E WITH BREVE .. LATIN SMALL LETTER E WITH BREVE - -1, -- LATIN SMALL LETTER E WITH DOT ABOVE .. LATIN SMALL LETTER E WITH DOT ABOVE - -1, -- LATIN SMALL LETTER E WITH OGONEK .. LATIN SMALL LETTER E WITH OGONEK - -1, -- LATIN SMALL LETTER E WITH CARON .. LATIN SMALL LETTER E WITH CARON - -1, -- LATIN SMALL LETTER G WITH CIRCUMFLEX .. LATIN SMALL LETTER G WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER G WITH BREVE .. LATIN SMALL LETTER G WITH BREVE - -1, -- LATIN SMALL LETTER G WITH DOT ABOVE .. LATIN SMALL LETTER G WITH DOT ABOVE - -1, -- LATIN SMALL LETTER G WITH CEDILLA .. LATIN SMALL LETTER G WITH CEDILLA - -1, -- LATIN SMALL LETTER H WITH CIRCUMFLEX .. LATIN SMALL LETTER H WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER H WITH STROKE .. LATIN SMALL LETTER H WITH STROKE - -1, -- LATIN SMALL LETTER I WITH TILDE .. LATIN SMALL LETTER I WITH TILDE - -1, -- LATIN SMALL LETTER I WITH MACRON .. LATIN SMALL LETTER I WITH MACRON - -1, -- LATIN SMALL LETTER I WITH BREVE .. LATIN SMALL LETTER I WITH BREVE - -1, -- LATIN SMALL LETTER I WITH OGONEK .. LATIN SMALL LETTER I WITH OGONEK - -1, -- LATIN SMALL LETTER I J .. LATIN SMALL LETTER I J - -1, -- LATIN SMALL LETTER J WITH CIRCUMFLEX .. LATIN SMALL LETTER J WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER K WITH CEDILLA .. LATIN SMALL LETTER K WITH CEDILLA - -1, -- LATIN SMALL LETTER L WITH ACUTE .. LATIN SMALL LETTER L WITH ACUTE - -1, -- LATIN SMALL LETTER L WITH CEDILLA .. LATIN SMALL LETTER L WITH CEDILLA - -1, -- LATIN SMALL LETTER L WITH CARON .. LATIN SMALL LETTER L WITH CARON - -1, -- LATIN SMALL LETTER L WITH MIDDLE DOT .. LATIN SMALL LETTER L WITH MIDDLE DOT - -1, -- LATIN SMALL LETTER L WITH STROKE .. LATIN SMALL LETTER L WITH STROKE - -1, -- LATIN SMALL LETTER N WITH ACUTE .. LATIN SMALL LETTER N WITH ACUTE - -1, -- LATIN SMALL LETTER N WITH CEDILLA .. LATIN SMALL LETTER N WITH CEDILLA - -1, -- LATIN SMALL LETTER N WITH CARON .. LATIN SMALL LETTER N WITH CARON - -1, -- LATIN SMALL LETTER ENG .. LATIN SMALL LETTER ENG - -1, -- LATIN SMALL LETTER O WITH MACRON .. LATIN SMALL LETTER O WITH MACRON - -1, -- LATIN SMALL LETTER O WITH BREVE .. LATIN SMALL LETTER O WITH BREVE - -1, -- LATIN SMALL LETTER O WITH DOUBLE ACUTE .. LATIN SMALL LETTER O WITH DOUBLE ACUTE - -1, -- LATIN SMALL LETTER O E .. LATIN SMALL LETTER O E - -1, -- LATIN SMALL LETTER R WITH ACUTE .. LATIN SMALL LETTER R WITH ACUTE - -1, -- LATIN SMALL LETTER R WITH CEDILLA .. LATIN SMALL LETTER R WITH CEDILLA - -1, -- LATIN SMALL LETTER R WITH CARON .. LATIN SMALL LETTER R WITH CARON - -1, -- LATIN SMALL LETTER S WITH ACUTE .. LATIN SMALL LETTER S WITH ACUTE - -1, -- LATIN SMALL LETTER S WITH CIRCUMFLEX .. LATIN SMALL LETTER S WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER S WITH CEDILLA .. LATIN SMALL LETTER S WITH CEDILLA - -1, -- LATIN SMALL LETTER S WITH CARON .. LATIN SMALL LETTER S WITH CARON - -1, -- LATIN SMALL LETTER T WITH CEDILLA .. LATIN SMALL LETTER T WITH CEDILLA - -1, -- LATIN SMALL LETTER T WITH CARON .. LATIN SMALL LETTER T WITH CARON - -1, -- LATIN SMALL LETTER T WITH STROKE .. LATIN SMALL LETTER T WITH STROKE - -1, -- LATIN SMALL LETTER U WITH TILDE .. LATIN SMALL LETTER U WITH TILDE - -1, -- LATIN SMALL LETTER U WITH MACRON .. LATIN SMALL LETTER U WITH MACRON - -1, -- LATIN SMALL LETTER U WITH BREVE .. LATIN SMALL LETTER U WITH BREVE - -1, -- LATIN SMALL LETTER U WITH RING ABOVE .. LATIN SMALL LETTER U WITH RING ABOVE - -1, -- LATIN SMALL LETTER U WITH DOUBLE ACUTE .. LATIN SMALL LETTER U WITH DOUBLE ACUTE - -1, -- LATIN SMALL LETTER U WITH OGONEK .. LATIN SMALL LETTER U WITH OGONEK - -1, -- LATIN SMALL LETTER W WITH CIRCUMFLEX .. LATIN SMALL LETTER W WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER Y WITH CIRCUMFLEX .. LATIN SMALL LETTER Y WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER Z WITH ACUTE .. LATIN SMALL LETTER Z WITH ACUTE - -1, -- LATIN SMALL LETTER Z WITH DOT ABOVE .. LATIN SMALL LETTER Z WITH DOT ABOVE - -1, -- LATIN SMALL LETTER Z WITH CARON .. LATIN SMALL LETTER Z WITH CARON - -1, -- LATIN SMALL LETTER B WITH TOPBAR .. LATIN SMALL LETTER B WITH TOPBAR - -1, -- LATIN SMALL LETTER TONE SIX .. LATIN SMALL LETTER TONE SIX - -1, -- LATIN SMALL LETTER C WITH HOOK .. LATIN SMALL LETTER C WITH HOOK - -1, -- LATIN SMALL LETTER D WITH TOPBAR .. LATIN SMALL LETTER D WITH TOPBAR - -1, -- LATIN SMALL LETTER F WITH HOOK .. LATIN SMALL LETTER F WITH HOOK - -1, -- LATIN SMALL LETTER K WITH HOOK .. LATIN SMALL LETTER K WITH HOOK - 130, -- LATIN SMALL LETTER N WITH LONG RIGHT LEG .. LATIN SMALL LETTER N WITH LONG RIGHT LEG - -1, -- LATIN SMALL LETTER O WITH HORN .. LATIN SMALL LETTER O WITH HORN - -1, -- LATIN SMALL LETTER OI .. LATIN SMALL LETTER OI - -1, -- LATIN SMALL LETTER P WITH HOOK .. LATIN SMALL LETTER P WITH HOOK - -1, -- LATIN SMALL LETTER TONE TWO .. LATIN SMALL LETTER TONE TWO - -1, -- LATIN SMALL LETTER T WITH HOOK .. LATIN SMALL LETTER T WITH HOOK - -1, -- LATIN SMALL LETTER U WITH HORN .. LATIN SMALL LETTER U WITH HORN - -1, -- LATIN SMALL LETTER Y WITH HOOK .. LATIN SMALL LETTER Y WITH HOOK - -1, -- LATIN SMALL LETTER Z WITH STROKE .. LATIN SMALL LETTER Z WITH STROKE - -1, -- LATIN SMALL LETTER EZH REVERSED .. LATIN SMALL LETTER EZH REVERSED - -1, -- LATIN SMALL LETTER TONE FIVE .. LATIN SMALL LETTER TONE FIVE - -2, -- LATIN SMALL LETTER DZ WITH CARON .. LATIN SMALL LETTER DZ WITH CARON - -2, -- LATIN SMALL LETTER LJ .. LATIN SMALL LETTER LJ - -2, -- LATIN SMALL LETTER NJ .. LATIN SMALL LETTER NJ - -1, -- LATIN SMALL LETTER A WITH CARON .. LATIN SMALL LETTER A WITH CARON - -1, -- LATIN SMALL LETTER I WITH CARON .. LATIN SMALL LETTER I WITH CARON - -1, -- LATIN SMALL LETTER O WITH CARON .. LATIN SMALL LETTER O WITH CARON - -1, -- LATIN SMALL LETTER U WITH CARON .. LATIN SMALL LETTER U WITH CARON - -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER U WITH DIAERESIS AND MACRON - -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER U WITH DIAERESIS AND ACUTE - -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND CARON .. LATIN SMALL LETTER U WITH DIAERESIS AND CARON - -1, -- LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE .. LATIN SMALL LETTER U WITH DIAERESIS AND GRAVE - -1, -- LATIN SMALL LETTER A WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER A WITH DIAERESIS AND MACRON - -1, -- LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER A WITH DOT ABOVE AND MACRON - -1, -- LATIN SMALL LETTER AE WITH MACRON .. LATIN SMALL LETTER AE WITH MACRON - -1, -- LATIN SMALL LETTER G WITH STROKE .. LATIN SMALL LETTER G WITH STROKE - -1, -- LATIN SMALL LETTER G WITH CARON .. LATIN SMALL LETTER G WITH CARON - -1, -- LATIN SMALL LETTER K WITH CARON .. LATIN SMALL LETTER K WITH CARON - -1, -- LATIN SMALL LETTER O WITH OGONEK .. LATIN SMALL LETTER O WITH OGONEK - -1, -- LATIN SMALL LETTER O WITH OGONEK AND MACRON .. LATIN SMALL LETTER O WITH OGONEK AND MACRON - -1, -- LATIN SMALL LETTER EZH WITH CARON .. LATIN SMALL LETTER EZH WITH CARON - -2, -- LATIN SMALL LETTER DZ .. LATIN SMALL LETTER DZ - -1, -- LATIN SMALL LETTER G WITH ACUTE .. LATIN SMALL LETTER G WITH ACUTE - -1, -- LATIN SMALL LETTER N WITH GRAVE .. LATIN SMALL LETTER N WITH GRAVE - -1, -- LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE .. LATIN SMALL LETTER A WITH RING ABOVE AND ACUTE - -1, -- LATIN SMALL LETTER AE WITH ACUTE .. LATIN SMALL LETTER AE WITH ACUTE - -1, -- LATIN SMALL LETTER O WITH STROKE AND ACUTE .. LATIN SMALL LETTER O WITH STROKE AND ACUTE - -1, -- LATIN SMALL LETTER A WITH DOUBLE GRAVE .. LATIN SMALL LETTER A WITH DOUBLE GRAVE - -1, -- LATIN SMALL LETTER A WITH INVERTED BREVE .. LATIN SMALL LETTER A WITH INVERTED BREVE - -1, -- LATIN SMALL LETTER E WITH DOUBLE GRAVE .. LATIN SMALL LETTER E WITH DOUBLE GRAVE - -1, -- LATIN SMALL LETTER E WITH INVERTED BREVE .. LATIN SMALL LETTER E WITH INVERTED BREVE - -1, -- LATIN SMALL LETTER I WITH DOUBLE GRAVE .. LATIN SMALL LETTER I WITH DOUBLE GRAVE - -1, -- LATIN SMALL LETTER I WITH INVERTED BREVE .. LATIN SMALL LETTER I WITH INVERTED BREVE - -1, -- LATIN SMALL LETTER O WITH DOUBLE GRAVE .. LATIN SMALL LETTER O WITH DOUBLE GRAVE - -1, -- LATIN SMALL LETTER O WITH INVERTED BREVE .. LATIN SMALL LETTER O WITH INVERTED BREVE - -1, -- LATIN SMALL LETTER R WITH DOUBLE GRAVE .. LATIN SMALL LETTER R WITH DOUBLE GRAVE - -1, -- LATIN SMALL LETTER R WITH INVERTED BREVE .. LATIN SMALL LETTER R WITH INVERTED BREVE - -1, -- LATIN SMALL LETTER U WITH DOUBLE GRAVE .. LATIN SMALL LETTER U WITH DOUBLE GRAVE - -1, -- LATIN SMALL LETTER U WITH INVERTED BREVE .. LATIN SMALL LETTER U WITH INVERTED BREVE - -1, -- LATIN SMALL LETTER S WITH COMMA BELOW .. LATIN SMALL LETTER S WITH COMMA BELOW - -1, -- LATIN SMALL LETTER T WITH COMMA BELOW .. LATIN SMALL LETTER T WITH COMMA BELOW - -1, -- LATIN SMALL LETTER YOGH .. LATIN SMALL LETTER YOGH - -1, -- LATIN SMALL LETTER H WITH CARON .. LATIN SMALL LETTER H WITH CARON - -1, -- LATIN SMALL LETTER OU .. LATIN SMALL LETTER OU - -1, -- LATIN SMALL LETTER Z WITH HOOK .. LATIN SMALL LETTER Z WITH HOOK - -1, -- LATIN SMALL LETTER A WITH DOT ABOVE .. LATIN SMALL LETTER A WITH DOT ABOVE - -1, -- LATIN SMALL LETTER E WITH CEDILLA .. LATIN SMALL LETTER E WITH CEDILLA - -1, -- LATIN SMALL LETTER O WITH DIAERESIS AND MACRON .. LATIN SMALL LETTER O WITH DIAERESIS AND MACRON - -1, -- LATIN SMALL LETTER O WITH TILDE AND MACRON .. LATIN SMALL LETTER O WITH TILDE AND MACRON - -1, -- LATIN SMALL LETTER O WITH DOT ABOVE .. LATIN SMALL LETTER O WITH DOT ABOVE - -1, -- LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON .. LATIN SMALL LETTER O WITH DOT ABOVE AND MACRON - -1, -- LATIN SMALL LETTER Y WITH MACRON .. LATIN SMALL LETTER Y WITH MACRON - -210, -- LATIN SMALL LETTER B WITH HOOK .. LATIN SMALL LETTER B WITH HOOK - -206, -- LATIN SMALL LETTER OPEN O .. LATIN SMALL LETTER OPEN O - -205, -- LATIN SMALL LETTER D WITH HOOK .. LATIN SMALL LETTER D WITH HOOK - -202, -- LATIN SMALL LETTER REVERSED E .. LATIN SMALL LETTER SCHWA - -203, -- LATIN SMALL LETTER OPEN E .. LATIN SMALL LETTER OPEN E - -205, -- LATIN SMALL LETTER G WITH HOOK .. LATIN SMALL LETTER G WITH HOOK - -207, -- LATIN SMALL LETTER GAMMA .. LATIN SMALL LETTER GAMMA - -209, -- LATIN SMALL LETTER I WITH STROKE .. LATIN SMALL LETTER I WITH STROKE - -211, -- LATIN SMALL LETTER IOTA .. LATIN SMALL LETTER IOTA - -211, -- LATIN SMALL LETTER TURNED M .. LATIN SMALL LETTER TURNED M - -213, -- LATIN SMALL LETTER N WITH LEFT HOOK .. LATIN SMALL LETTER N WITH LEFT HOOK - -218, -- LATIN SMALL LETTER ESH .. LATIN SMALL LETTER ESH - -218, -- LATIN SMALL LETTER T WITH RETROFLEX HOOK .. LATIN SMALL LETTER T WITH RETROFLEX HOOK - -217, -- LATIN SMALL LETTER UPSILON .. LATIN SMALL LETTER V WITH HOOK - -219, -- LATIN SMALL LETTER EZH .. LATIN SMALL LETTER EZH - -38, -- GREEK SMALL LETTER ALPHA WITH TONOS .. GREEK SMALL LETTER ALPHA WITH TONOS - -37, -- GREEK SMALL LETTER EPSILON WITH TONOS .. GREEK SMALL LETTER IOTA WITH TONOS - -32, -- GREEK SMALL LETTER ALPHA .. GREEK SMALL LETTER RHO - -32, -- GREEK SMALL LETTER SIGMA .. GREEK SMALL LETTER UPSILON WITH DIALYTIKA - -64, -- GREEK SMALL LETTER OMICRON WITH TONOS .. GREEK SMALL LETTER OMICRON WITH TONOS - -63, -- GREEK SMALL LETTER UPSILON WITH TONOS .. GREEK SMALL LETTER OMEGA WITH TONOS - -1, -- GREEK SMALL LETTER STIGMA .. GREEK SMALL LETTER STIGMA - -1, -- GREEK SMALL LETTER DIGAMMA .. GREEK SMALL LETTER DIGAMMA - -1, -- GREEK SMALL LETTER KOPPA .. GREEK SMALL LETTER KOPPA - -1, -- GREEK SMALL LETTER SAMPI .. GREEK SMALL LETTER SAMPI - -1, -- COPTIC SMALL LETTER SHEI .. COPTIC SMALL LETTER SHEI - -1, -- COPTIC SMALL LETTER FEI .. COPTIC SMALL LETTER FEI - -1, -- COPTIC SMALL LETTER KHEI .. COPTIC SMALL LETTER KHEI - -1, -- COPTIC SMALL LETTER HORI .. COPTIC SMALL LETTER HORI - -1, -- COPTIC SMALL LETTER GANGIA .. COPTIC SMALL LETTER GANGIA - -1, -- COPTIC SMALL LETTER SHIMA .. COPTIC SMALL LETTER SHIMA - -1, -- COPTIC SMALL LETTER DEI .. COPTIC SMALL LETTER DEI - -1, -- GREEK SMALL LETTER SHO .. GREEK SMALL LETTER SHO - -1, -- GREEK SMALL LETTER SAN .. GREEK SMALL LETTER SAN - -32, -- CYRILLIC SMALL LETTER A .. CYRILLIC SMALL LETTER YA - -80, -- CYRILLIC SMALL LETTER IE WITH GRAVE .. CYRILLIC SMALL LETTER DZHE - -1, -- CYRILLIC SMALL LETTER OMEGA .. CYRILLIC SMALL LETTER OMEGA - -1, -- CYRILLIC SMALL LETTER YAT .. CYRILLIC SMALL LETTER YAT - -1, -- CYRILLIC SMALL LETTER IOTIFIED E .. CYRILLIC SMALL LETTER IOTIFIED E - -1, -- CYRILLIC SMALL LETTER LITTLE YUS .. CYRILLIC SMALL LETTER LITTLE YUS - -1, -- CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS .. CYRILLIC SMALL LETTER IOTIFIED LITTLE YUS - -1, -- CYRILLIC SMALL LETTER BIG YUS .. CYRILLIC SMALL LETTER BIG YUS - -1, -- CYRILLIC SMALL LETTER IOTIFIED BIG YUS .. CYRILLIC SMALL LETTER IOTIFIED BIG YUS - -1, -- CYRILLIC SMALL LETTER KSI .. CYRILLIC SMALL LETTER KSI - -1, -- CYRILLIC SMALL LETTER PSI .. CYRILLIC SMALL LETTER PSI - -1, -- CYRILLIC SMALL LETTER FITA .. CYRILLIC SMALL LETTER FITA - -1, -- CYRILLIC SMALL LETTER IZHITSA .. CYRILLIC SMALL LETTER IZHITSA - -1, -- CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC SMALL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - -1, -- CYRILLIC SMALL LETTER UK .. CYRILLIC SMALL LETTER UK - -1, -- CYRILLIC SMALL LETTER ROUND OMEGA .. CYRILLIC SMALL LETTER ROUND OMEGA - -1, -- CYRILLIC SMALL LETTER OMEGA WITH TITLO .. CYRILLIC SMALL LETTER OMEGA WITH TITLO - -1, -- CYRILLIC SMALL LETTER OT .. CYRILLIC SMALL LETTER OT - -1, -- CYRILLIC SMALL LETTER KOPPA .. CYRILLIC SMALL LETTER KOPPA - -1, -- CYRILLIC SMALL LETTER SHORT I WITH TAIL .. CYRILLIC SMALL LETTER SHORT I WITH TAIL - -1, -- CYRILLIC SMALL LETTER SEMISOFT SIGN .. CYRILLIC SMALL LETTER SEMISOFT SIGN - -1, -- CYRILLIC SMALL LETTER ER WITH TICK .. CYRILLIC SMALL LETTER ER WITH TICK - -1, -- CYRILLIC SMALL LETTER GHE WITH UPTURN .. CYRILLIC SMALL LETTER GHE WITH UPTURN - -1, -- CYRILLIC SMALL LETTER GHE WITH STROKE .. CYRILLIC SMALL LETTER GHE WITH STROKE - -1, -- CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER GHE WITH MIDDLE HOOK - -1, -- CYRILLIC SMALL LETTER ZHE WITH DESCENDER .. CYRILLIC SMALL LETTER ZHE WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER ZE WITH DESCENDER .. CYRILLIC SMALL LETTER ZE WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER KA WITH DESCENDER .. CYRILLIC SMALL LETTER KA WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER KA WITH VERTICAL STROKE - -1, -- CYRILLIC SMALL LETTER KA WITH STROKE .. CYRILLIC SMALL LETTER KA WITH STROKE - -1, -- CYRILLIC SMALL LETTER BASHKIR KA .. CYRILLIC SMALL LETTER BASHKIR KA - -1, -- CYRILLIC SMALL LETTER EN WITH DESCENDER .. CYRILLIC SMALL LETTER EN WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER EN GE .. CYRILLIC SMALL LETTER EN GE - -1, -- CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK .. CYRILLIC SMALL LETTER PE WITH MIDDLE HOOK - -1, -- CYRILLIC SMALL LETTER ABKHASIAN HA .. CYRILLIC SMALL LETTER ABKHASIAN HA - -1, -- CYRILLIC SMALL LETTER ES WITH DESCENDER .. CYRILLIC SMALL LETTER ES WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER TE WITH DESCENDER .. CYRILLIC SMALL LETTER TE WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER STRAIGHT U .. CYRILLIC SMALL LETTER STRAIGHT U - -1, -- CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE .. CYRILLIC SMALL LETTER STRAIGHT U WITH STROKE - -1, -- CYRILLIC SMALL LETTER HA WITH DESCENDER .. CYRILLIC SMALL LETTER HA WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER TE TSE .. CYRILLIC SMALL LETTER TE TSE - -1, -- CYRILLIC SMALL LETTER CHE WITH DESCENDER .. CYRILLIC SMALL LETTER CHE WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC SMALL LETTER CHE WITH VERTICAL STROKE - -1, -- CYRILLIC SMALL LETTER SHHA .. CYRILLIC SMALL LETTER SHHA - -1, -- CYRILLIC SMALL LETTER ABKHASIAN CHE .. CYRILLIC SMALL LETTER ABKHASIAN CHE - -1, -- CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC SMALL LETTER ABKHASIAN CHE WITH DESCENDER - -1, -- CYRILLIC SMALL LETTER ZHE WITH BREVE .. CYRILLIC SMALL LETTER ZHE WITH BREVE - -1, -- CYRILLIC SMALL LETTER KA WITH HOOK .. CYRILLIC SMALL LETTER KA WITH HOOK - -1, -- CYRILLIC SMALL LETTER EL WITH TAIL .. CYRILLIC SMALL LETTER EL WITH TAIL - -1, -- CYRILLIC SMALL LETTER EN WITH HOOK .. CYRILLIC SMALL LETTER EN WITH HOOK - -1, -- CYRILLIC SMALL LETTER EN WITH TAIL .. CYRILLIC SMALL LETTER EN WITH TAIL - -1, -- CYRILLIC SMALL LETTER KHAKASSIAN CHE .. CYRILLIC SMALL LETTER KHAKASSIAN CHE - -1, -- CYRILLIC SMALL LETTER EM WITH TAIL .. CYRILLIC SMALL LETTER EM WITH TAIL - -1, -- CYRILLIC SMALL LETTER A WITH BREVE .. CYRILLIC SMALL LETTER A WITH BREVE - -1, -- CYRILLIC SMALL LETTER A WITH DIAERESIS .. CYRILLIC SMALL LETTER A WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER IE WITH BREVE .. CYRILLIC SMALL LETTER IE WITH BREVE - -1, -- CYRILLIC SMALL LETTER SCHWA .. CYRILLIC SMALL LETTER SCHWA - -1, -- CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS .. CYRILLIC SMALL LETTER SCHWA WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER ZHE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZHE WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER ZE WITH DIAERESIS .. CYRILLIC SMALL LETTER ZE WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER ABKHASIAN DZE .. CYRILLIC SMALL LETTER ABKHASIAN DZE - -1, -- CYRILLIC SMALL LETTER I WITH MACRON .. CYRILLIC SMALL LETTER I WITH MACRON - -1, -- CYRILLIC SMALL LETTER I WITH DIAERESIS .. CYRILLIC SMALL LETTER I WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER O WITH DIAERESIS .. CYRILLIC SMALL LETTER O WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER BARRED O .. CYRILLIC SMALL LETTER BARRED O - -1, -- CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS .. CYRILLIC SMALL LETTER BARRED O WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER E WITH DIAERESIS .. CYRILLIC SMALL LETTER E WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER U WITH MACRON .. CYRILLIC SMALL LETTER U WITH MACRON - -1, -- CYRILLIC SMALL LETTER U WITH DIAERESIS .. CYRILLIC SMALL LETTER U WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE .. CYRILLIC SMALL LETTER U WITH DOUBLE ACUTE - -1, -- CYRILLIC SMALL LETTER CHE WITH DIAERESIS .. CYRILLIC SMALL LETTER CHE WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER YERU WITH DIAERESIS .. CYRILLIC SMALL LETTER YERU WITH DIAERESIS - -1, -- CYRILLIC SMALL LETTER KOMI DE .. CYRILLIC SMALL LETTER KOMI DE - -1, -- CYRILLIC SMALL LETTER KOMI DJE .. CYRILLIC SMALL LETTER KOMI DJE - -1, -- CYRILLIC SMALL LETTER KOMI ZJE .. CYRILLIC SMALL LETTER KOMI ZJE - -1, -- CYRILLIC SMALL LETTER KOMI DZJE .. CYRILLIC SMALL LETTER KOMI DZJE - -1, -- CYRILLIC SMALL LETTER KOMI LJE .. CYRILLIC SMALL LETTER KOMI LJE - -1, -- CYRILLIC SMALL LETTER KOMI NJE .. CYRILLIC SMALL LETTER KOMI NJE - -1, -- CYRILLIC SMALL LETTER KOMI SJE .. CYRILLIC SMALL LETTER KOMI SJE - -1, -- CYRILLIC SMALL LETTER KOMI TJE .. CYRILLIC SMALL LETTER KOMI TJE - -48, -- ARMENIAN SMALL LETTER AYB .. ARMENIAN SMALL LETTER FEH - -48, -- GEORGIAN SMALL LETTER AN .. GEORGIAN SMALL LETTER HOE - -1, -- LATIN SMALL LETTER A WITH RING BELOW .. LATIN SMALL LETTER A WITH RING BELOW - -1, -- LATIN SMALL LETTER B WITH DOT ABOVE .. LATIN SMALL LETTER B WITH DOT ABOVE - -1, -- LATIN SMALL LETTER B WITH DOT BELOW .. LATIN SMALL LETTER B WITH DOT BELOW - -1, -- LATIN SMALL LETTER B WITH LINE BELOW .. LATIN SMALL LETTER B WITH LINE BELOW - -1, -- LATIN SMALL LETTER C WITH CEDILLA AND ACUTE .. LATIN SMALL LETTER C WITH CEDILLA AND ACUTE - -1, -- LATIN SMALL LETTER D WITH DOT ABOVE .. LATIN SMALL LETTER D WITH DOT ABOVE - -1, -- LATIN SMALL LETTER D WITH DOT BELOW .. LATIN SMALL LETTER D WITH DOT BELOW - -1, -- LATIN SMALL LETTER D WITH LINE BELOW .. LATIN SMALL LETTER D WITH LINE BELOW - -1, -- LATIN SMALL LETTER D WITH CEDILLA .. LATIN SMALL LETTER D WITH CEDILLA - -1, -- LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER D WITH CIRCUMFLEX BELOW - -1, -- LATIN SMALL LETTER E WITH MACRON AND GRAVE .. LATIN SMALL LETTER E WITH MACRON AND GRAVE - -1, -- LATIN SMALL LETTER E WITH MACRON AND ACUTE .. LATIN SMALL LETTER E WITH MACRON AND ACUTE - -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX BELOW - -1, -- LATIN SMALL LETTER E WITH TILDE BELOW .. LATIN SMALL LETTER E WITH TILDE BELOW - -1, -- LATIN SMALL LETTER E WITH CEDILLA AND BREVE .. LATIN SMALL LETTER E WITH CEDILLA AND BREVE - -1, -- LATIN SMALL LETTER F WITH DOT ABOVE .. LATIN SMALL LETTER F WITH DOT ABOVE - -1, -- LATIN SMALL LETTER G WITH MACRON .. LATIN SMALL LETTER G WITH MACRON - -1, -- LATIN SMALL LETTER H WITH DOT ABOVE .. LATIN SMALL LETTER H WITH DOT ABOVE - -1, -- LATIN SMALL LETTER H WITH DOT BELOW .. LATIN SMALL LETTER H WITH DOT BELOW - -1, -- LATIN SMALL LETTER H WITH DIAERESIS .. LATIN SMALL LETTER H WITH DIAERESIS - -1, -- LATIN SMALL LETTER H WITH CEDILLA .. LATIN SMALL LETTER H WITH CEDILLA - -1, -- LATIN SMALL LETTER H WITH BREVE BELOW .. LATIN SMALL LETTER H WITH BREVE BELOW - -1, -- LATIN SMALL LETTER I WITH TILDE BELOW .. LATIN SMALL LETTER I WITH TILDE BELOW - -1, -- LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE .. LATIN SMALL LETTER I WITH DIAERESIS AND ACUTE - -1, -- LATIN SMALL LETTER K WITH ACUTE .. LATIN SMALL LETTER K WITH ACUTE - -1, -- LATIN SMALL LETTER K WITH DOT BELOW .. LATIN SMALL LETTER K WITH DOT BELOW - -1, -- LATIN SMALL LETTER K WITH LINE BELOW .. LATIN SMALL LETTER K WITH LINE BELOW - -1, -- LATIN SMALL LETTER L WITH DOT BELOW .. LATIN SMALL LETTER L WITH DOT BELOW - -1, -- LATIN SMALL LETTER L WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER L WITH DOT BELOW AND MACRON - -1, -- LATIN SMALL LETTER L WITH LINE BELOW .. LATIN SMALL LETTER L WITH LINE BELOW - -1, -- LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER L WITH CIRCUMFLEX BELOW - -1, -- LATIN SMALL LETTER M WITH ACUTE .. LATIN SMALL LETTER M WITH ACUTE - -1, -- LATIN SMALL LETTER M WITH DOT ABOVE .. LATIN SMALL LETTER M WITH DOT ABOVE - -1, -- LATIN SMALL LETTER M WITH DOT BELOW .. LATIN SMALL LETTER M WITH DOT BELOW - -1, -- LATIN SMALL LETTER N WITH DOT ABOVE .. LATIN SMALL LETTER N WITH DOT ABOVE - -1, -- LATIN SMALL LETTER N WITH DOT BELOW .. LATIN SMALL LETTER N WITH DOT BELOW - -1, -- LATIN SMALL LETTER N WITH LINE BELOW .. LATIN SMALL LETTER N WITH LINE BELOW - -1, -- LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER N WITH CIRCUMFLEX BELOW - -1, -- LATIN SMALL LETTER O WITH TILDE AND ACUTE .. LATIN SMALL LETTER O WITH TILDE AND ACUTE - -1, -- LATIN SMALL LETTER O WITH TILDE AND DIAERESIS .. LATIN SMALL LETTER O WITH TILDE AND DIAERESIS - -1, -- LATIN SMALL LETTER O WITH MACRON AND GRAVE .. LATIN SMALL LETTER O WITH MACRON AND GRAVE - -1, -- LATIN SMALL LETTER O WITH MACRON AND ACUTE .. LATIN SMALL LETTER O WITH MACRON AND ACUTE - -1, -- LATIN SMALL LETTER P WITH ACUTE .. LATIN SMALL LETTER P WITH ACUTE - -1, -- LATIN SMALL LETTER P WITH DOT ABOVE .. LATIN SMALL LETTER P WITH DOT ABOVE - -1, -- LATIN SMALL LETTER R WITH DOT ABOVE .. LATIN SMALL LETTER R WITH DOT ABOVE - -1, -- LATIN SMALL LETTER R WITH DOT BELOW .. LATIN SMALL LETTER R WITH DOT BELOW - -1, -- LATIN SMALL LETTER R WITH DOT BELOW AND MACRON .. LATIN SMALL LETTER R WITH DOT BELOW AND MACRON - -1, -- LATIN SMALL LETTER R WITH LINE BELOW .. LATIN SMALL LETTER R WITH LINE BELOW - -1, -- LATIN SMALL LETTER S WITH DOT ABOVE .. LATIN SMALL LETTER S WITH DOT ABOVE - -1, -- LATIN SMALL LETTER S WITH DOT BELOW .. LATIN SMALL LETTER S WITH DOT BELOW - -1, -- LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN SMALL LETTER S WITH ACUTE AND DOT ABOVE - -1, -- LATIN SMALL LETTER S WITH CARON AND DOT ABOVE .. LATIN SMALL LETTER S WITH CARON AND DOT ABOVE - -1, -- LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN SMALL LETTER S WITH DOT BELOW AND DOT ABOVE - -1, -- LATIN SMALL LETTER T WITH DOT ABOVE .. LATIN SMALL LETTER T WITH DOT ABOVE - -1, -- LATIN SMALL LETTER T WITH DOT BELOW .. LATIN SMALL LETTER T WITH DOT BELOW - -1, -- LATIN SMALL LETTER T WITH LINE BELOW .. LATIN SMALL LETTER T WITH LINE BELOW - -1, -- LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER T WITH CIRCUMFLEX BELOW - -1, -- LATIN SMALL LETTER U WITH DIAERESIS BELOW .. LATIN SMALL LETTER U WITH DIAERESIS BELOW - -1, -- LATIN SMALL LETTER U WITH TILDE BELOW .. LATIN SMALL LETTER U WITH TILDE BELOW - -1, -- LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW .. LATIN SMALL LETTER U WITH CIRCUMFLEX BELOW - -1, -- LATIN SMALL LETTER U WITH TILDE AND ACUTE .. LATIN SMALL LETTER U WITH TILDE AND ACUTE - -1, -- LATIN SMALL LETTER U WITH MACRON AND DIAERESIS .. LATIN SMALL LETTER U WITH MACRON AND DIAERESIS - -1, -- LATIN SMALL LETTER V WITH TILDE .. LATIN SMALL LETTER V WITH TILDE - -1, -- LATIN SMALL LETTER V WITH DOT BELOW .. LATIN SMALL LETTER V WITH DOT BELOW - -1, -- LATIN SMALL LETTER W WITH GRAVE .. LATIN SMALL LETTER W WITH GRAVE - -1, -- LATIN SMALL LETTER W WITH ACUTE .. LATIN SMALL LETTER W WITH ACUTE - -1, -- LATIN SMALL LETTER W WITH DIAERESIS .. LATIN SMALL LETTER W WITH DIAERESIS - -1, -- LATIN SMALL LETTER W WITH DOT ABOVE .. LATIN SMALL LETTER W WITH DOT ABOVE - -1, -- LATIN SMALL LETTER W WITH DOT BELOW .. LATIN SMALL LETTER W WITH DOT BELOW - -1, -- LATIN SMALL LETTER X WITH DOT ABOVE .. LATIN SMALL LETTER X WITH DOT ABOVE - -1, -- LATIN SMALL LETTER X WITH DIAERESIS .. LATIN SMALL LETTER X WITH DIAERESIS - -1, -- LATIN SMALL LETTER Y WITH DOT ABOVE .. LATIN SMALL LETTER Y WITH DOT ABOVE - -1, -- LATIN SMALL LETTER Z WITH CIRCUMFLEX .. LATIN SMALL LETTER Z WITH CIRCUMFLEX - -1, -- LATIN SMALL LETTER Z WITH DOT BELOW .. LATIN SMALL LETTER Z WITH DOT BELOW - -1, -- LATIN SMALL LETTER Z WITH LINE BELOW .. LATIN SMALL LETTER Z WITH LINE BELOW - -1, -- LATIN SMALL LETTER A WITH DOT BELOW .. LATIN SMALL LETTER A WITH DOT BELOW - -1, -- LATIN SMALL LETTER A WITH HOOK ABOVE .. LATIN SMALL LETTER A WITH HOOK ABOVE - -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND ACUTE - -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND GRAVE - -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND TILDE - -1, -- LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER A WITH CIRCUMFLEX AND DOT BELOW - -1, -- LATIN SMALL LETTER A WITH BREVE AND ACUTE .. LATIN SMALL LETTER A WITH BREVE AND ACUTE - -1, -- LATIN SMALL LETTER A WITH BREVE AND GRAVE .. LATIN SMALL LETTER A WITH BREVE AND GRAVE - -1, -- LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN SMALL LETTER A WITH BREVE AND HOOK ABOVE - -1, -- LATIN SMALL LETTER A WITH BREVE AND TILDE .. LATIN SMALL LETTER A WITH BREVE AND TILDE - -1, -- LATIN SMALL LETTER A WITH BREVE AND DOT BELOW .. LATIN SMALL LETTER A WITH BREVE AND DOT BELOW - -1, -- LATIN SMALL LETTER E WITH DOT BELOW .. LATIN SMALL LETTER E WITH DOT BELOW - -1, -- LATIN SMALL LETTER E WITH HOOK ABOVE .. LATIN SMALL LETTER E WITH HOOK ABOVE - -1, -- LATIN SMALL LETTER E WITH TILDE .. LATIN SMALL LETTER E WITH TILDE - -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND ACUTE - -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND GRAVE - -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND TILDE - -1, -- LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER E WITH CIRCUMFLEX AND DOT BELOW - -1, -- LATIN SMALL LETTER I WITH HOOK ABOVE .. LATIN SMALL LETTER I WITH HOOK ABOVE - -1, -- LATIN SMALL LETTER I WITH DOT BELOW .. LATIN SMALL LETTER I WITH DOT BELOW - -1, -- LATIN SMALL LETTER O WITH DOT BELOW .. LATIN SMALL LETTER O WITH DOT BELOW - -1, -- LATIN SMALL LETTER O WITH HOOK ABOVE .. LATIN SMALL LETTER O WITH HOOK ABOVE - -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND ACUTE - -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND GRAVE - -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND TILDE - -1, -- LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN SMALL LETTER O WITH CIRCUMFLEX AND DOT BELOW - -1, -- LATIN SMALL LETTER O WITH HORN AND ACUTE .. LATIN SMALL LETTER O WITH HORN AND ACUTE - -1, -- LATIN SMALL LETTER O WITH HORN AND GRAVE .. LATIN SMALL LETTER O WITH HORN AND GRAVE - -1, -- LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER O WITH HORN AND HOOK ABOVE - -1, -- LATIN SMALL LETTER O WITH HORN AND TILDE .. LATIN SMALL LETTER O WITH HORN AND TILDE - -1, -- LATIN SMALL LETTER O WITH HORN AND DOT BELOW .. LATIN SMALL LETTER O WITH HORN AND DOT BELOW - -1, -- LATIN SMALL LETTER U WITH DOT BELOW .. LATIN SMALL LETTER U WITH DOT BELOW - -1, -- LATIN SMALL LETTER U WITH HOOK ABOVE .. LATIN SMALL LETTER U WITH HOOK ABOVE - -1, -- LATIN SMALL LETTER U WITH HORN AND ACUTE .. LATIN SMALL LETTER U WITH HORN AND ACUTE - -1, -- LATIN SMALL LETTER U WITH HORN AND GRAVE .. LATIN SMALL LETTER U WITH HORN AND GRAVE - -1, -- LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE .. LATIN SMALL LETTER U WITH HORN AND HOOK ABOVE - -1, -- LATIN SMALL LETTER U WITH HORN AND TILDE .. LATIN SMALL LETTER U WITH HORN AND TILDE - -1, -- LATIN SMALL LETTER U WITH HORN AND DOT BELOW .. LATIN SMALL LETTER U WITH HORN AND DOT BELOW - -1, -- LATIN SMALL LETTER Y WITH GRAVE .. LATIN SMALL LETTER Y WITH GRAVE - -1, -- LATIN SMALL LETTER Y WITH DOT BELOW .. LATIN SMALL LETTER Y WITH DOT BELOW - -1, -- LATIN SMALL LETTER Y WITH HOOK ABOVE .. LATIN SMALL LETTER Y WITH HOOK ABOVE - -1, -- LATIN SMALL LETTER Y WITH TILDE .. LATIN SMALL LETTER Y WITH TILDE - 8, -- GREEK SMALL LETTER ALPHA WITH PSILI .. GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI - 8, -- GREEK SMALL LETTER EPSILON WITH PSILI .. GREEK SMALL LETTER EPSILON WITH DASIA AND OXIA - 8, -- GREEK SMALL LETTER ETA WITH PSILI .. GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI - 8, -- GREEK SMALL LETTER IOTA WITH PSILI .. GREEK SMALL LETTER IOTA WITH DASIA AND PERISPOMENI - 8, -- GREEK SMALL LETTER OMICRON WITH PSILI .. GREEK SMALL LETTER OMICRON WITH DASIA AND OXIA - 8, -- GREEK SMALL LETTER UPSILON WITH DASIA .. GREEK SMALL LETTER UPSILON WITH DASIA - 8, -- GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND VARIA - 8, -- GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA .. GREEK SMALL LETTER UPSILON WITH DASIA AND OXIA - 8, -- GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK SMALL LETTER UPSILON WITH DASIA AND PERISPOMENI - 8, -- GREEK SMALL LETTER OMEGA WITH PSILI .. GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI - 74, -- GREEK SMALL LETTER ALPHA WITH VARIA .. GREEK SMALL LETTER ALPHA WITH OXIA - 86, -- GREEK SMALL LETTER EPSILON WITH VARIA .. GREEK SMALL LETTER ETA WITH OXIA - 100, -- GREEK SMALL LETTER IOTA WITH VARIA .. GREEK SMALL LETTER IOTA WITH OXIA - 128, -- GREEK SMALL LETTER OMICRON WITH VARIA .. GREEK SMALL LETTER OMICRON WITH OXIA - 112, -- GREEK SMALL LETTER UPSILON WITH VARIA .. GREEK SMALL LETTER UPSILON WITH OXIA - 126, -- GREEK SMALL LETTER OMEGA WITH VARIA .. GREEK SMALL LETTER OMEGA WITH OXIA - 8, -- GREEK SMALL LETTER ALPHA WITH VRACHY .. GREEK SMALL LETTER ALPHA WITH MACRON - 8, -- GREEK SMALL LETTER IOTA WITH VRACHY .. GREEK SMALL LETTER IOTA WITH MACRON - 8, -- GREEK SMALL LETTER UPSILON WITH VRACHY .. GREEK SMALL LETTER UPSILON WITH MACRON - 7, -- GREEK SMALL LETTER RHO WITH DASIA .. GREEK SMALL LETTER RHO WITH DASIA - -26, -- CIRCLED LATIN SMALL LETTER A .. CIRCLED LATIN SMALL LETTER Z - -32, -- FULLWIDTH LATIN SMALL LETTER A .. FULLWIDTH LATIN SMALL LETTER Z - -40, -- DESERET SMALL LETTER LONG I .. DESERET SMALL LETTER EW - -32); -- TAG LATIN SMALL LETTER A .. TAG LATIN SMALL LETTER Z - - -- The following is a list of the 10646 names for SMALL LETTER entries - -- that have no matching CAPITAL LETTER entry and are thus not folded - - -- LATIN SMALL LETTER SHARP S - -- LATIN SMALL LETTER DOTLESS I - -- LATIN SMALL LETTER KRA - -- LATIN SMALL LETTER N PRECEDED BY APOSTROPHE - -- LATIN SMALL LETTER LONG S - -- LATIN SMALL LETTER B WITH STROKE - -- LATIN SMALL LETTER TURNED DELTA - -- LATIN SMALL LETTER HV - -- LATIN SMALL LETTER L WITH BAR - -- LATIN SMALL LETTER LAMBDA WITH STROKE - -- LATIN SMALL LETTER T WITH PALATAL HOOK - -- LATIN SMALL LETTER EZH WITH TAIL - -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON - -- LATIN CAPITAL LETTER L WITH SMALL LETTER J - -- LATIN CAPITAL LETTER N WITH SMALL LETTER J - -- LATIN SMALL LETTER TURNED E - -- LATIN SMALL LETTER J WITH CARON - -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z - -- LATIN SMALL LETTER D WITH CURL - -- LATIN SMALL LETTER L WITH CURL - -- LATIN SMALL LETTER N WITH CURL - -- LATIN SMALL LETTER T WITH CURL - -- LATIN SMALL LETTER TURNED A - -- LATIN SMALL LETTER ALPHA - -- LATIN SMALL LETTER TURNED ALPHA - -- LATIN SMALL LETTER C WITH CURL - -- LATIN SMALL LETTER D WITH TAIL - -- LATIN SMALL LETTER SCHWA WITH HOOK - -- LATIN SMALL LETTER REVERSED OPEN E - -- LATIN SMALL LETTER REVERSED OPEN E WITH HOOK - -- LATIN SMALL LETTER CLOSED REVERSED OPEN E - -- LATIN SMALL LETTER DOTLESS J WITH STROKE - -- LATIN SMALL LETTER SCRIPT G - -- LATIN SMALL LETTER RAMS HORN - -- LATIN SMALL LETTER TURNED H - -- LATIN SMALL LETTER H WITH HOOK - -- LATIN SMALL LETTER HENG WITH HOOK - -- LATIN SMALL LETTER L WITH MIDDLE TILDE - -- LATIN SMALL LETTER L WITH BELT - -- LATIN SMALL LETTER L WITH RETROFLEX HOOK - -- LATIN SMALL LETTER LEZH - -- LATIN SMALL LETTER TURNED M WITH LONG LEG - -- LATIN SMALL LETTER M WITH HOOK - -- LATIN SMALL LETTER N WITH RETROFLEX HOOK - -- LATIN SMALL LETTER BARRED O - -- LATIN SMALL LETTER CLOSED OMEGA - -- LATIN SMALL LETTER PHI - -- LATIN SMALL LETTER TURNED R - -- LATIN SMALL LETTER TURNED R WITH LONG LEG - -- LATIN SMALL LETTER TURNED R WITH HOOK - -- LATIN SMALL LETTER R WITH LONG LEG - -- LATIN SMALL LETTER R WITH TAIL - -- LATIN SMALL LETTER R WITH FISHHOOK - -- LATIN SMALL LETTER REVERSED R WITH FISHHOOK - -- LATIN SMALL LETTER S WITH HOOK - -- LATIN SMALL LETTER DOTLESS J WITH STROKE AND HOOK - -- LATIN SMALL LETTER SQUAT REVERSED ESH - -- LATIN SMALL LETTER ESH WITH CURL - -- LATIN SMALL LETTER TURNED T - -- LATIN SMALL LETTER U BAR - -- LATIN SMALL LETTER TURNED V - -- LATIN SMALL LETTER TURNED W - -- LATIN SMALL LETTER TURNED Y - -- LATIN SMALL LETTER Z WITH RETROFLEX HOOK - -- LATIN SMALL LETTER Z WITH CURL - -- LATIN SMALL LETTER EZH WITH CURL - -- LATIN SMALL LETTER CLOSED OPEN E - -- LATIN SMALL LETTER J WITH CROSSED-TAIL - -- LATIN SMALL LETTER TURNED K - -- LATIN SMALL LETTER Q WITH HOOK - -- LATIN SMALL LETTER DZ DIGRAPH - -- LATIN SMALL LETTER DEZH DIGRAPH - -- LATIN SMALL LETTER DZ DIGRAPH WITH CURL - -- LATIN SMALL LETTER TS DIGRAPH - -- LATIN SMALL LETTER TESH DIGRAPH - -- LATIN SMALL LETTER TC DIGRAPH WITH CURL - -- LATIN SMALL LETTER FENG DIGRAPH - -- LATIN SMALL LETTER LS DIGRAPH - -- LATIN SMALL LETTER LZ DIGRAPH - -- LATIN SMALL LETTER TURNED H WITH FISHHOOK - -- LATIN SMALL LETTER TURNED H WITH FISHHOOK AND TAIL - -- COMBINING LATIN SMALL LETTER A - -- COMBINING LATIN SMALL LETTER E - -- COMBINING LATIN SMALL LETTER I - -- COMBINING LATIN SMALL LETTER O - -- COMBINING LATIN SMALL LETTER U - -- COMBINING LATIN SMALL LETTER C - -- COMBINING LATIN SMALL LETTER D - -- COMBINING LATIN SMALL LETTER H - -- COMBINING LATIN SMALL LETTER M - -- COMBINING LATIN SMALL LETTER R - -- COMBINING LATIN SMALL LETTER T - -- COMBINING LATIN SMALL LETTER V - -- COMBINING LATIN SMALL LETTER X - -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS - -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS - -- GREEK SMALL LETTER FINAL SIGMA - -- GREEK SMALL LETTER CURLED BETA - -- GREEK SMALL LETTER SCRIPT THETA - -- GREEK SMALL LETTER SCRIPT PHI - -- GREEK SMALL LETTER OMEGA PI - -- GREEK SMALL LETTER ARCHAIC KOPPA - -- GREEK SMALL LETTER SCRIPT KAPPA - -- GREEK SMALL LETTER TAILED RHO - -- GREEK SMALL LETTER LUNATE SIGMA - -- GEORGIAN SMALL LETTER FI - -- LIMBU SMALL LETTER KA - -- LIMBU SMALL LETTER NGA - -- LIMBU SMALL LETTER ANUSVARA - -- LIMBU SMALL LETTER TA - -- LIMBU SMALL LETTER NA - -- LIMBU SMALL LETTER PA - -- LIMBU SMALL LETTER MA - -- LIMBU SMALL LETTER RA - -- LIMBU SMALL LETTER LA - -- LATIN SMALL LETTER TURNED AE - -- LATIN SMALL LETTER TURNED OPEN E - -- LATIN SMALL LETTER TURNED I - -- LATIN SMALL LETTER SIDEWAYS O - -- LATIN SMALL LETTER SIDEWAYS OPEN O - -- LATIN SMALL LETTER SIDEWAYS O WITH STROKE - -- LATIN SMALL LETTER TURNED OE - -- LATIN SMALL LETTER TOP HALF O - -- LATIN SMALL LETTER BOTTOM HALF O - -- LATIN SMALL LETTER SIDEWAYS U - -- LATIN SMALL LETTER SIDEWAYS DIAERESIZED U - -- LATIN SMALL LETTER SIDEWAYS TURNED M - -- LATIN SUBSCRIPT SMALL LETTER I - -- LATIN SUBSCRIPT SMALL LETTER R - -- LATIN SUBSCRIPT SMALL LETTER U - -- LATIN SUBSCRIPT SMALL LETTER V - -- GREEK SUBSCRIPT SMALL LETTER BETA - -- GREEK SUBSCRIPT SMALL LETTER GAMMA - -- GREEK SUBSCRIPT SMALL LETTER RHO - -- GREEK SUBSCRIPT SMALL LETTER PHI - -- GREEK SUBSCRIPT SMALL LETTER CHI - -- LATIN SMALL LETTER UE - -- LATIN SMALL LETTER H WITH LINE BELOW - -- LATIN SMALL LETTER T WITH DIAERESIS - -- LATIN SMALL LETTER W WITH RING ABOVE - -- LATIN SMALL LETTER Y WITH RING ABOVE - -- LATIN SMALL LETTER A WITH RIGHT HALF RING - -- LATIN SMALL LETTER LONG S WITH DOT ABOVE - -- GREEK SMALL LETTER UPSILON WITH PSILI - -- GREEK SMALL LETTER UPSILON WITH PSILI AND VARIA - -- GREEK SMALL LETTER UPSILON WITH PSILI AND OXIA - -- GREEK SMALL LETTER UPSILON WITH PSILI AND PERISPOMENI - -- GREEK SMALL LETTER ALPHA WITH PSILI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH DASIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH PSILI AND VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH DASIA AND VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH PSILI AND OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH DASIA AND OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH PSILI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH DASIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH PSILI AND VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH DASIA AND VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH PSILI AND OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH DASIA AND OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH PSILI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH DASIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH PSILI AND VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH DASIA AND VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH PSILI AND OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH DASIA AND OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH PSILI AND PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH DASIA AND PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI - -- GREEK SMALL LETTER ALPHA WITH PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER ETA WITH PERISPOMENI - -- GREEK SMALL LETTER ETA WITH PERISPOMENI AND YPOGEGRAMMENI - -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND VARIA - -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND OXIA - -- GREEK SMALL LETTER IOTA WITH PERISPOMENI - -- GREEK SMALL LETTER IOTA WITH DIALYTIKA AND PERISPOMENI - -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND VARIA - -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND OXIA - -- GREEK SMALL LETTER RHO WITH PSILI - -- GREEK SMALL LETTER UPSILON WITH PERISPOMENI - -- GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND PERISPOMENI - -- GREEK SMALL LETTER OMEGA WITH VARIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH OXIA AND YPOGEGRAMMENI - -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI - -- GREEK SMALL LETTER OMEGA WITH PERISPOMENI AND YPOGEGRAMMENI - -- SUPERSCRIPT LATIN SMALL LETTER I - -- SUPERSCRIPT LATIN SMALL LETTER N - -- TURNED GREEK SMALL LETTER IOTA - -- PARENTHESIZED LATIN SMALL LETTER A - -- PARENTHESIZED LATIN SMALL LETTER B - -- PARENTHESIZED LATIN SMALL LETTER C - -- PARENTHESIZED LATIN SMALL LETTER D - -- PARENTHESIZED LATIN SMALL LETTER E - -- PARENTHESIZED LATIN SMALL LETTER F - -- PARENTHESIZED LATIN SMALL LETTER G - -- PARENTHESIZED LATIN SMALL LETTER H - -- PARENTHESIZED LATIN SMALL LETTER I - -- PARENTHESIZED LATIN SMALL LETTER J - -- PARENTHESIZED LATIN SMALL LETTER K - -- PARENTHESIZED LATIN SMALL LETTER L - -- PARENTHESIZED LATIN SMALL LETTER M - -- PARENTHESIZED LATIN SMALL LETTER N - -- PARENTHESIZED LATIN SMALL LETTER O - -- PARENTHESIZED LATIN SMALL LETTER P - -- PARENTHESIZED LATIN SMALL LETTER Q - -- PARENTHESIZED LATIN SMALL LETTER R - -- PARENTHESIZED LATIN SMALL LETTER S - -- PARENTHESIZED LATIN SMALL LETTER T - -- PARENTHESIZED LATIN SMALL LETTER U - -- PARENTHESIZED LATIN SMALL LETTER V - -- PARENTHESIZED LATIN SMALL LETTER W - -- PARENTHESIZED LATIN SMALL LETTER X - -- PARENTHESIZED LATIN SMALL LETTER Y - -- PARENTHESIZED LATIN SMALL LETTER Z - - -- The following two tables define the mapping to lower case. The first - -- table gives the ranges of upper case letters. The corresponding entry - -- in Lower_Case_Adjust shows the amount to be added to (or subtracted from - -- if the value is negative) the code value to get the corresponding lower - -- case letter. - - -- An entry is in this table if its 10646 has the string CAPITAL LETTER - -- the name, and there is a corresponding entry which has the string - -- SMALL LETTER in its name. - - Upper_Case_Letters : constant UTF_32_Ranges := ( - (16#00041#, 16#0005A#), -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z - (16#000C0#, 16#000D6#), -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS - (16#000D8#, 16#000DE#), -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN - (16#00100#, 16#00100#), -- LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON - (16#00102#, 16#00102#), -- LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE - (16#00104#, 16#00104#), -- LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK - (16#00106#, 16#00106#), -- LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE - (16#00108#, 16#00108#), -- LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX - (16#0010A#, 16#0010A#), -- LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE - (16#0010C#, 16#0010C#), -- LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON - (16#0010E#, 16#0010E#), -- LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON - (16#00110#, 16#00110#), -- LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE - (16#00112#, 16#00112#), -- LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON - (16#00114#, 16#00114#), -- LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE - (16#00116#, 16#00116#), -- LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE - (16#00118#, 16#00118#), -- LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK - (16#0011A#, 16#0011A#), -- LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON - (16#0011C#, 16#0011C#), -- LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX - (16#0011E#, 16#0011E#), -- LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE - (16#00120#, 16#00120#), -- LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE - (16#00122#, 16#00122#), -- LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA - (16#00124#, 16#00124#), -- LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX - (16#00126#, 16#00126#), -- LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE - (16#00128#, 16#00128#), -- LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE - (16#0012A#, 16#0012A#), -- LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON - (16#0012C#, 16#0012C#), -- LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE - (16#0012E#, 16#0012E#), -- LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK - (16#00132#, 16#00132#), -- LATIN CAPITAL LETTER I J .. LATIN CAPITAL LETTER I J - (16#00134#, 16#00134#), -- LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX - (16#00136#, 16#00136#), -- LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA - (16#00139#, 16#00139#), -- LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE - (16#0013B#, 16#0013B#), -- LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA - (16#0013D#, 16#0013D#), -- LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON - (16#0013F#, 16#0013F#), -- LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT - (16#00141#, 16#00141#), -- LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE - (16#00143#, 16#00143#), -- LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE - (16#00145#, 16#00145#), -- LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA - (16#00147#, 16#00147#), -- LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON - (16#0014A#, 16#0014A#), -- LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG - (16#0014C#, 16#0014C#), -- LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON - (16#0014E#, 16#0014E#), -- LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE - (16#00150#, 16#00150#), -- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE - (16#00152#, 16#00152#), -- LATIN CAPITAL LETTER O E .. LATIN CAPITAL LETTER O E - (16#00154#, 16#00154#), -- LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE - (16#00156#, 16#00156#), -- LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA - (16#00158#, 16#00158#), -- LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON - (16#0015A#, 16#0015A#), -- LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE - (16#0015C#, 16#0015C#), -- LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX - (16#0015E#, 16#0015E#), -- LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA - (16#00160#, 16#00160#), -- LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON - (16#00162#, 16#00162#), -- LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA - (16#00164#, 16#00164#), -- LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON - (16#00166#, 16#00166#), -- LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE - (16#00168#, 16#00168#), -- LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE - (16#0016A#, 16#0016A#), -- LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON - (16#0016C#, 16#0016C#), -- LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE - (16#0016E#, 16#0016E#), -- LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE - (16#00170#, 16#00170#), -- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE - (16#00172#, 16#00172#), -- LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK - (16#00174#, 16#00174#), -- LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX - (16#00176#, 16#00176#), -- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX - (16#00178#, 16#00178#), -- LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Y WITH DIAERESIS - (16#00179#, 16#00179#), -- LATIN CAPITAL LETTER Z WITH ACUTE .. LATIN CAPITAL LETTER Z WITH ACUTE - (16#0017B#, 16#0017B#), -- LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE - (16#0017D#, 16#0017D#), -- LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON - (16#00181#, 16#00181#), -- LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH HOOK - (16#00182#, 16#00182#), -- LATIN CAPITAL LETTER B WITH TOPBAR .. LATIN CAPITAL LETTER B WITH TOPBAR - (16#00184#, 16#00184#), -- LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX - (16#00186#, 16#00186#), -- LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER OPEN O - (16#00187#, 16#00187#), -- LATIN CAPITAL LETTER C WITH HOOK .. LATIN CAPITAL LETTER C WITH HOOK - (16#0018A#, 16#0018A#), -- LATIN CAPITAL LETTER D WITH HOOK .. LATIN CAPITAL LETTER D WITH HOOK - (16#0018B#, 16#0018B#), -- LATIN CAPITAL LETTER D WITH TOPBAR .. LATIN CAPITAL LETTER D WITH TOPBAR - (16#0018E#, 16#0018F#), -- LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER SCHWA - (16#00190#, 16#00190#), -- LATIN CAPITAL LETTER OPEN E .. LATIN CAPITAL LETTER OPEN E - (16#00191#, 16#00191#), -- LATIN CAPITAL LETTER F WITH HOOK .. LATIN CAPITAL LETTER F WITH HOOK - (16#00193#, 16#00193#), -- LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER G WITH HOOK - (16#00194#, 16#00194#), -- LATIN CAPITAL LETTER GAMMA .. LATIN CAPITAL LETTER GAMMA - (16#00196#, 16#00196#), -- LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER IOTA - (16#00197#, 16#00197#), -- LATIN CAPITAL LETTER I WITH STROKE .. LATIN CAPITAL LETTER I WITH STROKE - (16#00198#, 16#00198#), -- LATIN CAPITAL LETTER K WITH HOOK .. LATIN CAPITAL LETTER K WITH HOOK - (16#0019C#, 16#0019C#), -- LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER TURNED M - (16#0019D#, 16#0019D#), -- LATIN CAPITAL LETTER N WITH LEFT HOOK .. LATIN CAPITAL LETTER N WITH LEFT HOOK - (16#001A0#, 16#001A0#), -- LATIN CAPITAL LETTER O WITH HORN .. LATIN CAPITAL LETTER O WITH HORN - (16#001A2#, 16#001A2#), -- LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI - (16#001A4#, 16#001A4#), -- LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK - (16#001A7#, 16#001A7#), -- LATIN CAPITAL LETTER TONE TWO .. LATIN CAPITAL LETTER TONE TWO - (16#001A9#, 16#001A9#), -- LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH - (16#001AC#, 16#001AC#), -- LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK - (16#001AE#, 16#001AE#), -- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER T WITH RETROFLEX HOOK - (16#001AF#, 16#001AF#), -- LATIN CAPITAL LETTER U WITH HORN .. LATIN CAPITAL LETTER U WITH HORN - (16#001B1#, 16#001B2#), -- LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER V WITH HOOK - (16#001B3#, 16#001B3#), -- LATIN CAPITAL LETTER Y WITH HOOK .. LATIN CAPITAL LETTER Y WITH HOOK - (16#001B5#, 16#001B5#), -- LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE - (16#001B7#, 16#001B7#), -- LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH - (16#001B8#, 16#001B8#), -- LATIN CAPITAL LETTER EZH REVERSED .. LATIN CAPITAL LETTER EZH REVERSED - (16#001BC#, 16#001BC#), -- LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE - (16#001C4#, 16#001C4#), -- LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON - (16#001C7#, 16#001C7#), -- LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ - (16#001CA#, 16#001CA#), -- LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ - (16#001CD#, 16#001CD#), -- LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON - (16#001CF#, 16#001CF#), -- LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON - (16#001D1#, 16#001D1#), -- LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON - (16#001D3#, 16#001D3#), -- LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON - (16#001D5#, 16#001D5#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON - (16#001D7#, 16#001D7#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE - (16#001D9#, 16#001D9#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON - (16#001DB#, 16#001DB#), -- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE - (16#001DE#, 16#001DE#), -- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON - (16#001E0#, 16#001E0#), -- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON - (16#001E2#, 16#001E2#), -- LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON - (16#001E4#, 16#001E4#), -- LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE - (16#001E6#, 16#001E6#), -- LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON - (16#001E8#, 16#001E8#), -- LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON - (16#001EA#, 16#001EA#), -- LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK - (16#001EC#, 16#001EC#), -- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON - (16#001EE#, 16#001EE#), -- LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON - (16#001F1#, 16#001F1#), -- LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ - (16#001F4#, 16#001F4#), -- LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE - (16#001F8#, 16#001F8#), -- LATIN CAPITAL LETTER N WITH GRAVE .. LATIN CAPITAL LETTER N WITH GRAVE - (16#001FA#, 16#001FA#), -- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE - (16#001FC#, 16#001FC#), -- LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE - (16#001FE#, 16#001FE#), -- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE - (16#00200#, 16#00200#), -- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE - (16#00202#, 16#00202#), -- LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE - (16#00204#, 16#00204#), -- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE - (16#00206#, 16#00206#), -- LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE - (16#00208#, 16#00208#), -- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE - (16#0020A#, 16#0020A#), -- LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE - (16#0020C#, 16#0020C#), -- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE - (16#0020E#, 16#0020E#), -- LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE - (16#00210#, 16#00210#), -- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE - (16#00212#, 16#00212#), -- LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE - (16#00214#, 16#00214#), -- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE - (16#00216#, 16#00216#), -- LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE - (16#00218#, 16#00218#), -- LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW - (16#0021A#, 16#0021A#), -- LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW - (16#0021C#, 16#0021C#), -- LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH - (16#0021E#, 16#0021E#), -- LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON - (16#00220#, 16#00220#), -- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG - (16#00222#, 16#00222#), -- LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU - (16#00224#, 16#00224#), -- LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK - (16#00226#, 16#00226#), -- LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE - (16#00228#, 16#00228#), -- LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA - (16#0022A#, 16#0022A#), -- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON - (16#0022C#, 16#0022C#), -- LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON - (16#0022E#, 16#0022E#), -- LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE - (16#00230#, 16#00230#), -- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON - (16#00232#, 16#00232#), -- LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON - (16#00386#, 16#00386#), -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS - (16#00388#, 16#0038A#), -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS - (16#0038C#, 16#0038C#), -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS - (16#0038E#, 16#0038F#), -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS - (16#00391#, 16#003A1#), -- GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO - (16#003A3#, 16#003AB#), -- GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA - (16#003DA#, 16#003DA#), -- GREEK CAPITAL LETTER STIGMA .. GREEK CAPITAL LETTER STIGMA - (16#003DC#, 16#003DC#), -- GREEK CAPITAL LETTER DIGAMMA .. GREEK CAPITAL LETTER DIGAMMA - (16#003DE#, 16#003DE#), -- GREEK CAPITAL LETTER KOPPA .. GREEK CAPITAL LETTER KOPPA - (16#003E0#, 16#003E0#), -- GREEK CAPITAL LETTER SAMPI .. GREEK CAPITAL LETTER SAMPI - (16#003E2#, 16#003E2#), -- COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI - (16#003E4#, 16#003E4#), -- COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI - (16#003E6#, 16#003E6#), -- COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI - (16#003E8#, 16#003E8#), -- COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI - (16#003EA#, 16#003EA#), -- COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA - (16#003EC#, 16#003EC#), -- COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA - (16#003EE#, 16#003EE#), -- COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI - (16#003F7#, 16#003F7#), -- GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO - (16#003FA#, 16#003FA#), -- GREEK CAPITAL LETTER SAN .. GREEK CAPITAL LETTER SAN - (16#00400#, 16#0040F#), -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER DZHE - (16#00410#, 16#0042F#), -- CYRILLIC CAPITAL LETTER A .. CYRILLIC CAPITAL LETTER YA - (16#00460#, 16#00460#), -- CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA - (16#00462#, 16#00462#), -- CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT - (16#00464#, 16#00464#), -- CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E - (16#00466#, 16#00466#), -- CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS - (16#00468#, 16#00468#), -- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS - (16#0046A#, 16#0046A#), -- CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS - (16#0046C#, 16#0046C#), -- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS - (16#0046E#, 16#0046E#), -- CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI - (16#00470#, 16#00470#), -- CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI - (16#00472#, 16#00472#), -- CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA - (16#00474#, 16#00474#), -- CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA - (16#00476#, 16#00476#), -- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - (16#00478#, 16#00478#), -- CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK - (16#0047A#, 16#0047A#), -- CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA - (16#0047C#, 16#0047C#), -- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO - (16#0047E#, 16#0047E#), -- CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT - (16#00480#, 16#00480#), -- CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA - (16#0048A#, 16#0048A#), -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL - (16#0048C#, 16#0048C#), -- CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN - (16#0048E#, 16#0048E#), -- CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK - (16#00490#, 16#00490#), -- CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN - (16#00492#, 16#00492#), -- CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE - (16#00494#, 16#00494#), -- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK - (16#00496#, 16#00496#), -- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER - (16#00498#, 16#00498#), -- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER - (16#0049A#, 16#0049A#), -- CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER - (16#0049C#, 16#0049C#), -- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE - (16#0049E#, 16#0049E#), -- CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE - (16#004A0#, 16#004A0#), -- CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA - (16#004A2#, 16#004A2#), -- CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER - (16#004A4#, 16#004A4#), -- CYRILLIC CAPITAL LETTER EN GE .. CYRILLIC CAPITAL LETTER EN GE - (16#004A6#, 16#004A6#), -- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK - (16#004A8#, 16#004A8#), -- CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA - (16#004AA#, 16#004AA#), -- CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER - (16#004AC#, 16#004AC#), -- CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER - (16#004AE#, 16#004AE#), -- CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U - (16#004B0#, 16#004B0#), -- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE - (16#004B2#, 16#004B2#), -- CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER - (16#004B4#, 16#004B4#), -- CYRILLIC CAPITAL LETTER TE TSE .. CYRILLIC CAPITAL LETTER TE TSE - (16#004B6#, 16#004B6#), -- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER - (16#004B8#, 16#004B8#), -- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE - (16#004BA#, 16#004BA#), -- CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA - (16#004BC#, 16#004BC#), -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE - (16#004BE#, 16#004BE#), -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER - (16#004C1#, 16#004C1#), -- CYRILLIC CAPITAL LETTER ZHE WITH BREVE .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE - (16#004C3#, 16#004C3#), -- CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK - (16#004C5#, 16#004C5#), -- CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL - (16#004C7#, 16#004C7#), -- CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK - (16#004C9#, 16#004C9#), -- CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL - (16#004CB#, 16#004CB#), -- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE - (16#004CD#, 16#004CD#), -- CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL - (16#004D0#, 16#004D0#), -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE - (16#004D2#, 16#004D2#), -- CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS - (16#004D6#, 16#004D6#), -- CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE - (16#004D8#, 16#004D8#), -- CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA - (16#004DA#, 16#004DA#), -- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS - (16#004DC#, 16#004DC#), -- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS - (16#004DE#, 16#004DE#), -- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS - (16#004E0#, 16#004E0#), -- CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE - (16#004E2#, 16#004E2#), -- CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON - (16#004E4#, 16#004E4#), -- CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS - (16#004E6#, 16#004E6#), -- CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS - (16#004E8#, 16#004E8#), -- CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O - (16#004EA#, 16#004EA#), -- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS - (16#004EC#, 16#004EC#), -- CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS - (16#004EE#, 16#004EE#), -- CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON - (16#004F0#, 16#004F0#), -- CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS - (16#004F2#, 16#004F2#), -- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE - (16#004F4#, 16#004F4#), -- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS - (16#004F8#, 16#004F8#), -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS - (16#00500#, 16#00500#), -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE - (16#00502#, 16#00502#), -- CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE - (16#00504#, 16#00504#), -- CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE - (16#00506#, 16#00506#), -- CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE - (16#00508#, 16#00508#), -- CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE - (16#0050A#, 16#0050A#), -- CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE - (16#0050C#, 16#0050C#), -- CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE - (16#0050E#, 16#0050E#), -- CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE - (16#00531#, 16#00556#), -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH - (16#010A0#, 16#010C5#), -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE - (16#01E00#, 16#01E00#), -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW - (16#01E02#, 16#01E02#), -- LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE - (16#01E04#, 16#01E04#), -- LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW - (16#01E06#, 16#01E06#), -- LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW - (16#01E08#, 16#01E08#), -- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE - (16#01E0A#, 16#01E0A#), -- LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE - (16#01E0C#, 16#01E0C#), -- LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW - (16#01E0E#, 16#01E0E#), -- LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW - (16#01E10#, 16#01E10#), -- LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA - (16#01E12#, 16#01E12#), -- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW - (16#01E14#, 16#01E14#), -- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE - (16#01E16#, 16#01E16#), -- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE - (16#01E18#, 16#01E18#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW - (16#01E1A#, 16#01E1A#), -- LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW - (16#01E1C#, 16#01E1C#), -- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE - (16#01E1E#, 16#01E1E#), -- LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE - (16#01E20#, 16#01E20#), -- LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON - (16#01E22#, 16#01E22#), -- LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE - (16#01E24#, 16#01E24#), -- LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW - (16#01E26#, 16#01E26#), -- LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS - (16#01E28#, 16#01E28#), -- LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA - (16#01E2A#, 16#01E2A#), -- LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW - (16#01E2C#, 16#01E2C#), -- LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW - (16#01E2E#, 16#01E2E#), -- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE - (16#01E30#, 16#01E30#), -- LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE - (16#01E32#, 16#01E32#), -- LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW - (16#01E34#, 16#01E34#), -- LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW - (16#01E36#, 16#01E36#), -- LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW - (16#01E38#, 16#01E38#), -- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON - (16#01E3A#, 16#01E3A#), -- LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW - (16#01E3C#, 16#01E3C#), -- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW - (16#01E3E#, 16#01E3E#), -- LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE - (16#01E40#, 16#01E40#), -- LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE - (16#01E42#, 16#01E42#), -- LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW - (16#01E44#, 16#01E44#), -- LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE - (16#01E46#, 16#01E46#), -- LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW - (16#01E48#, 16#01E48#), -- LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW - (16#01E4A#, 16#01E4A#), -- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW - (16#01E4C#, 16#01E4C#), -- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE - (16#01E4E#, 16#01E4E#), -- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS - (16#01E50#, 16#01E50#), -- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE - (16#01E52#, 16#01E52#), -- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE - (16#01E54#, 16#01E54#), -- LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE - (16#01E56#, 16#01E56#), -- LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE - (16#01E58#, 16#01E58#), -- LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE - (16#01E5A#, 16#01E5A#), -- LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW - (16#01E5C#, 16#01E5C#), -- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON - (16#01E5E#, 16#01E5E#), -- LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW - (16#01E60#, 16#01E60#), -- LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE - (16#01E62#, 16#01E62#), -- LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW - (16#01E64#, 16#01E64#), -- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE - (16#01E66#, 16#01E66#), -- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE - (16#01E68#, 16#01E68#), -- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE - (16#01E6A#, 16#01E6A#), -- LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE - (16#01E6C#, 16#01E6C#), -- LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW - (16#01E6E#, 16#01E6E#), -- LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW - (16#01E70#, 16#01E70#), -- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW - (16#01E72#, 16#01E72#), -- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW - (16#01E74#, 16#01E74#), -- LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW - (16#01E76#, 16#01E76#), -- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW - (16#01E78#, 16#01E78#), -- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE - (16#01E7A#, 16#01E7A#), -- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS - (16#01E7C#, 16#01E7C#), -- LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE - (16#01E7E#, 16#01E7E#), -- LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW - (16#01E80#, 16#01E80#), -- LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE - (16#01E82#, 16#01E82#), -- LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE - (16#01E84#, 16#01E84#), -- LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS - (16#01E86#, 16#01E86#), -- LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE - (16#01E88#, 16#01E88#), -- LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW - (16#01E8A#, 16#01E8A#), -- LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE - (16#01E8C#, 16#01E8C#), -- LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS - (16#01E8E#, 16#01E8E#), -- LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE - (16#01E90#, 16#01E90#), -- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX - (16#01E92#, 16#01E92#), -- LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW - (16#01E94#, 16#01E94#), -- LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW - (16#01EA0#, 16#01EA0#), -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW - (16#01EA2#, 16#01EA2#), -- LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE - (16#01EA4#, 16#01EA4#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE - (16#01EA6#, 16#01EA6#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE - (16#01EA8#, 16#01EA8#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EAA#, 16#01EAA#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE - (16#01EAC#, 16#01EAC#), -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW - (16#01EAE#, 16#01EAE#), -- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE - (16#01EB0#, 16#01EB0#), -- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE - (16#01EB2#, 16#01EB2#), -- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE - (16#01EB4#, 16#01EB4#), -- LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE - (16#01EB6#, 16#01EB6#), -- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW - (16#01EB8#, 16#01EB8#), -- LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW - (16#01EBA#, 16#01EBA#), -- LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE - (16#01EBC#, 16#01EBC#), -- LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE - (16#01EBE#, 16#01EBE#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE - (16#01EC0#, 16#01EC0#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE - (16#01EC2#, 16#01EC2#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - (16#01EC4#, 16#01EC4#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE - (16#01EC6#, 16#01EC6#), -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW - (16#01EC8#, 16#01EC8#), -- LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE - (16#01ECA#, 16#01ECA#), -- LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW - (16#01ECC#, 16#01ECC#), -- LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW - (16#01ECE#, 16#01ECE#), -- LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE - (16#01ED0#, 16#01ED0#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE - (16#01ED2#, 16#01ED2#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE - (16#01ED4#, 16#01ED4#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - (16#01ED6#, 16#01ED6#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE - (16#01ED8#, 16#01ED8#), -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW - (16#01EDA#, 16#01EDA#), -- LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE - (16#01EDC#, 16#01EDC#), -- LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE - (16#01EDE#, 16#01EDE#), -- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE - (16#01EE0#, 16#01EE0#), -- LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE - (16#01EE2#, 16#01EE2#), -- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW - (16#01EE4#, 16#01EE4#), -- LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW - (16#01EE6#, 16#01EE6#), -- LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE - (16#01EE8#, 16#01EE8#), -- LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE - (16#01EEA#, 16#01EEA#), -- LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE - (16#01EEC#, 16#01EEC#), -- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE - (16#01EEE#, 16#01EEE#), -- LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE - (16#01EF0#, 16#01EF0#), -- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW - (16#01EF2#, 16#01EF2#), -- LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE - (16#01EF4#, 16#01EF4#), -- LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW - (16#01EF6#, 16#01EF6#), -- LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE - (16#01EF8#, 16#01EF8#), -- LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE - (16#01F08#, 16#01F0F#), -- GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI - (16#01F18#, 16#01F1D#), -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA - (16#01F28#, 16#01F2F#), -- GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI - (16#01F38#, 16#01F3F#), -- GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI - (16#01F48#, 16#01F4D#), -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA - (16#01F59#, 16#01F59#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA - (16#01F5B#, 16#01F5B#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA - (16#01F5D#, 16#01F5D#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA - (16#01F5F#, 16#01F5F#), -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI - (16#01F68#, 16#01F6F#), -- GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI - (16#01FB8#, 16#01FB9#), -- GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH MACRON - (16#01FBA#, 16#01FBB#), -- GREEK CAPITAL LETTER ALPHA WITH VARIA .. GREEK CAPITAL LETTER ALPHA WITH OXIA - (16#01FC8#, 16#01FCB#), -- GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA - (16#01FD8#, 16#01FD9#), -- GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH MACRON - (16#01FDA#, 16#01FDB#), -- GREEK CAPITAL LETTER IOTA WITH VARIA .. GREEK CAPITAL LETTER IOTA WITH OXIA - (16#01FE8#, 16#01FE9#), -- GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER UPSILON WITH MACRON - (16#01FEA#, 16#01FEB#), -- GREEK CAPITAL LETTER UPSILON WITH VARIA .. GREEK CAPITAL LETTER UPSILON WITH OXIA - (16#01FEC#, 16#01FEC#), -- GREEK CAPITAL LETTER RHO WITH DASIA .. GREEK CAPITAL LETTER RHO WITH DASIA - (16#01FF8#, 16#01FF9#), -- GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMICRON WITH OXIA - (16#01FFA#, 16#01FFB#), -- GREEK CAPITAL LETTER OMEGA WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA - (16#024B6#, 16#024CF#), -- CIRCLED LATIN CAPITAL LETTER A .. CIRCLED LATIN CAPITAL LETTER Z - (16#0FF21#, 16#0FF3A#), -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z - (16#10400#, 16#10427#), -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW - (16#E0041#, 16#E005A#)); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z - - Upper_Case_Adjust : constant array (Lower_Case_Letters'Range) - of UTF_32'Base := ( - 32, -- LATIN CAPITAL LETTER A .. LATIN CAPITAL LETTER Z - 32, -- LATIN CAPITAL LETTER A WITH GRAVE .. LATIN CAPITAL LETTER O WITH DIAERESIS - 32, -- LATIN CAPITAL LETTER O WITH STROKE .. LATIN CAPITAL LETTER THORN - 1, -- LATIN CAPITAL LETTER A WITH MACRON .. LATIN CAPITAL LETTER A WITH MACRON - 1, -- LATIN CAPITAL LETTER A WITH BREVE .. LATIN CAPITAL LETTER A WITH BREVE - 1, -- LATIN CAPITAL LETTER A WITH OGONEK .. LATIN CAPITAL LETTER A WITH OGONEK - 1, -- LATIN CAPITAL LETTER C WITH ACUTE .. LATIN CAPITAL LETTER C WITH ACUTE - 1, -- LATIN CAPITAL LETTER C WITH CIRCUMFLEX .. LATIN CAPITAL LETTER C WITH CIRCUMFLEX - 1, -- LATIN CAPITAL LETTER C WITH DOT ABOVE .. LATIN CAPITAL LETTER C WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER C WITH CARON .. LATIN CAPITAL LETTER C WITH CARON - 1, -- LATIN CAPITAL LETTER D WITH CARON .. LATIN CAPITAL LETTER D WITH CARON - 1, -- LATIN CAPITAL LETTER D WITH STROKE .. LATIN CAPITAL LETTER D WITH STROKE - 1, -- LATIN CAPITAL LETTER E WITH MACRON .. LATIN CAPITAL LETTER E WITH MACRON - 1, -- LATIN CAPITAL LETTER E WITH BREVE .. LATIN CAPITAL LETTER E WITH BREVE - 1, -- LATIN CAPITAL LETTER E WITH DOT ABOVE .. LATIN CAPITAL LETTER E WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER E WITH OGONEK .. LATIN CAPITAL LETTER E WITH OGONEK - 1, -- LATIN CAPITAL LETTER E WITH CARON .. LATIN CAPITAL LETTER E WITH CARON - 1, -- LATIN CAPITAL LETTER G WITH CIRCUMFLEX .. LATIN CAPITAL LETTER G WITH CIRCUMFLEX - 1, -- LATIN CAPITAL LETTER G WITH BREVE .. LATIN CAPITAL LETTER G WITH BREVE - 1, -- LATIN CAPITAL LETTER G WITH DOT ABOVE .. LATIN CAPITAL LETTER G WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER G WITH CEDILLA .. LATIN CAPITAL LETTER G WITH CEDILLA - 1, -- LATIN CAPITAL LETTER H WITH CIRCUMFLEX .. LATIN CAPITAL LETTER H WITH CIRCUMFLEX - 1, -- LATIN CAPITAL LETTER H WITH STROKE .. LATIN CAPITAL LETTER H WITH STROKE - 1, -- LATIN CAPITAL LETTER I WITH TILDE .. LATIN CAPITAL LETTER I WITH TILDE - 1, -- LATIN CAPITAL LETTER I WITH MACRON .. LATIN CAPITAL LETTER I WITH MACRON - 1, -- LATIN CAPITAL LETTER I WITH BREVE .. LATIN CAPITAL LETTER I WITH BREVE - 1, -- LATIN CAPITAL LETTER I WITH OGONEK .. LATIN CAPITAL LETTER I WITH OGONEK - 1, -- LATIN CAPITAL LETTER I J .. LATIN CAPITAL LETTER I J - 1, -- LATIN CAPITAL LETTER J WITH CIRCUMFLEX .. LATIN CAPITAL LETTER J WITH CIRCUMFLEX - 1, -- LATIN CAPITAL LETTER K WITH CEDILLA .. LATIN CAPITAL LETTER K WITH CEDILLA - 1, -- LATIN CAPITAL LETTER L WITH ACUTE .. LATIN CAPITAL LETTER L WITH ACUTE - 1, -- LATIN CAPITAL LETTER L WITH CEDILLA .. LATIN CAPITAL LETTER L WITH CEDILLA - 1, -- LATIN CAPITAL LETTER L WITH CARON .. LATIN CAPITAL LETTER L WITH CARON - 1, -- LATIN CAPITAL LETTER L WITH MIDDLE DOT .. LATIN CAPITAL LETTER L WITH MIDDLE DOT - 1, -- LATIN CAPITAL LETTER L WITH STROKE .. LATIN CAPITAL LETTER L WITH STROKE - 1, -- LATIN CAPITAL LETTER N WITH ACUTE .. LATIN CAPITAL LETTER N WITH ACUTE - 1, -- LATIN CAPITAL LETTER N WITH CEDILLA .. LATIN CAPITAL LETTER N WITH CEDILLA - 1, -- LATIN CAPITAL LETTER N WITH CARON .. LATIN CAPITAL LETTER N WITH CARON - 1, -- LATIN CAPITAL LETTER ENG .. LATIN CAPITAL LETTER ENG - 1, -- LATIN CAPITAL LETTER O WITH MACRON .. LATIN CAPITAL LETTER O WITH MACRON - 1, -- LATIN CAPITAL LETTER O WITH BREVE .. LATIN CAPITAL LETTER O WITH BREVE - 1, -- LATIN CAPITAL LETTER O WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER O WITH DOUBLE ACUTE - 1, -- LATIN CAPITAL LETTER O E .. LATIN CAPITAL LETTER O E - 1, -- LATIN CAPITAL LETTER R WITH ACUTE .. LATIN CAPITAL LETTER R WITH ACUTE - 1, -- LATIN CAPITAL LETTER R WITH CEDILLA .. LATIN CAPITAL LETTER R WITH CEDILLA - 1, -- LATIN CAPITAL LETTER R WITH CARON .. LATIN CAPITAL LETTER R WITH CARON - 1, -- LATIN CAPITAL LETTER S WITH ACUTE .. LATIN CAPITAL LETTER S WITH ACUTE - 1, -- LATIN CAPITAL LETTER S WITH CIRCUMFLEX .. LATIN CAPITAL LETTER S WITH CIRCUMFLEX - 1, -- LATIN CAPITAL LETTER S WITH CEDILLA .. LATIN CAPITAL LETTER S WITH CEDILLA - 1, -- LATIN CAPITAL LETTER S WITH CARON .. LATIN CAPITAL LETTER S WITH CARON - 1, -- LATIN CAPITAL LETTER T WITH CEDILLA .. LATIN CAPITAL LETTER T WITH CEDILLA - 1, -- LATIN CAPITAL LETTER T WITH CARON .. LATIN CAPITAL LETTER T WITH CARON - 1, -- LATIN CAPITAL LETTER T WITH STROKE .. LATIN CAPITAL LETTER T WITH STROKE - 1, -- LATIN CAPITAL LETTER U WITH TILDE .. LATIN CAPITAL LETTER U WITH TILDE - 1, -- LATIN CAPITAL LETTER U WITH MACRON .. LATIN CAPITAL LETTER U WITH MACRON - 1, -- LATIN CAPITAL LETTER U WITH BREVE .. LATIN CAPITAL LETTER U WITH BREVE - 1, -- LATIN CAPITAL LETTER U WITH RING ABOVE .. LATIN CAPITAL LETTER U WITH RING ABOVE - 1, -- LATIN CAPITAL LETTER U WITH DOUBLE ACUTE .. LATIN CAPITAL LETTER U WITH DOUBLE ACUTE - 1, -- LATIN CAPITAL LETTER U WITH OGONEK .. LATIN CAPITAL LETTER U WITH OGONEK - 1, -- LATIN CAPITAL LETTER W WITH CIRCUMFLEX .. LATIN CAPITAL LETTER W WITH CIRCUMFLEX - 1, -- LATIN CAPITAL LETTER Y WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Y WITH CIRCUMFLEX - -121, -- LATIN CAPITAL LETTER Y WITH DIAERESIS .. LATIN CAPITAL LETTER Y WITH DIAERESIS - 1, -- LATIN CAPITAL LETTER Z WITH ACUTE .. LATIN CAPITAL LETTER Z WITH ACUTE - 1, -- LATIN CAPITAL LETTER Z WITH DOT ABOVE .. LATIN CAPITAL LETTER Z WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER Z WITH CARON .. LATIN CAPITAL LETTER Z WITH CARON - 210, -- LATIN CAPITAL LETTER B WITH HOOK .. LATIN CAPITAL LETTER B WITH HOOK - 1, -- LATIN CAPITAL LETTER B WITH TOPBAR .. LATIN CAPITAL LETTER B WITH TOPBAR - 1, -- LATIN CAPITAL LETTER TONE SIX .. LATIN CAPITAL LETTER TONE SIX - 206, -- LATIN CAPITAL LETTER OPEN O .. LATIN CAPITAL LETTER OPEN O - 1, -- LATIN CAPITAL LETTER C WITH HOOK .. LATIN CAPITAL LETTER C WITH HOOK - 205, -- LATIN CAPITAL LETTER D WITH HOOK .. LATIN CAPITAL LETTER D WITH HOOK - 1, -- LATIN CAPITAL LETTER D WITH TOPBAR .. LATIN CAPITAL LETTER D WITH TOPBAR - 202, -- LATIN CAPITAL LETTER REVERSED E .. LATIN CAPITAL LETTER SCHWA - 203, -- LATIN CAPITAL LETTER OPEN E .. LATIN CAPITAL LETTER OPEN E - 1, -- LATIN CAPITAL LETTER F WITH HOOK .. LATIN CAPITAL LETTER F WITH HOOK - 205, -- LATIN CAPITAL LETTER G WITH HOOK .. LATIN CAPITAL LETTER G WITH HOOK - 207, -- LATIN CAPITAL LETTER GAMMA .. LATIN CAPITAL LETTER GAMMA - 211, -- LATIN CAPITAL LETTER IOTA .. LATIN CAPITAL LETTER IOTA - 209, -- LATIN CAPITAL LETTER I WITH STROKE .. LATIN CAPITAL LETTER I WITH STROKE - 1, -- LATIN CAPITAL LETTER K WITH HOOK .. LATIN CAPITAL LETTER K WITH HOOK - 211, -- LATIN CAPITAL LETTER TURNED M .. LATIN CAPITAL LETTER TURNED M - 213, -- LATIN CAPITAL LETTER N WITH LEFT HOOK .. LATIN CAPITAL LETTER N WITH LEFT HOOK - 1, -- LATIN CAPITAL LETTER O WITH HORN .. LATIN CAPITAL LETTER O WITH HORN - 1, -- LATIN CAPITAL LETTER OI .. LATIN CAPITAL LETTER OI - 1, -- LATIN CAPITAL LETTER P WITH HOOK .. LATIN CAPITAL LETTER P WITH HOOK - 1, -- LATIN CAPITAL LETTER TONE TWO .. LATIN CAPITAL LETTER TONE TWO - 218, -- LATIN CAPITAL LETTER ESH .. LATIN CAPITAL LETTER ESH - 1, -- LATIN CAPITAL LETTER T WITH HOOK .. LATIN CAPITAL LETTER T WITH HOOK - 218, -- LATIN CAPITAL LETTER T WITH RETROFLEX HOOK .. LATIN CAPITAL LETTER T WITH RETROFLEX HOOK - 1, -- LATIN CAPITAL LETTER U WITH HORN .. LATIN CAPITAL LETTER U WITH HORN - 217, -- LATIN CAPITAL LETTER UPSILON .. LATIN CAPITAL LETTER V WITH HOOK - 1, -- LATIN CAPITAL LETTER Y WITH HOOK .. LATIN CAPITAL LETTER Y WITH HOOK - 1, -- LATIN CAPITAL LETTER Z WITH STROKE .. LATIN CAPITAL LETTER Z WITH STROKE - 219, -- LATIN CAPITAL LETTER EZH .. LATIN CAPITAL LETTER EZH - 1, -- LATIN CAPITAL LETTER EZH REVERSED .. LATIN CAPITAL LETTER EZH REVERSED - 1, -- LATIN CAPITAL LETTER TONE FIVE .. LATIN CAPITAL LETTER TONE FIVE - 2, -- LATIN CAPITAL LETTER DZ WITH CARON .. LATIN CAPITAL LETTER DZ WITH CARON - 2, -- LATIN CAPITAL LETTER LJ .. LATIN CAPITAL LETTER LJ - 2, -- LATIN CAPITAL LETTER NJ .. LATIN CAPITAL LETTER NJ - 1, -- LATIN CAPITAL LETTER A WITH CARON .. LATIN CAPITAL LETTER A WITH CARON - 1, -- LATIN CAPITAL LETTER I WITH CARON .. LATIN CAPITAL LETTER I WITH CARON - 1, -- LATIN CAPITAL LETTER O WITH CARON .. LATIN CAPITAL LETTER O WITH CARON - 1, -- LATIN CAPITAL LETTER U WITH CARON .. LATIN CAPITAL LETTER U WITH CARON - 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND MACRON - 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND ACUTE - 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON .. LATIN CAPITAL LETTER U WITH DIAERESIS AND CARON - 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE .. LATIN CAPITAL LETTER U WITH DIAERESIS AND GRAVE - 1, -- LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER A WITH DIAERESIS AND MACRON - 1, -- LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER A WITH DOT ABOVE AND MACRON - 1, -- LATIN CAPITAL LETTER AE WITH MACRON .. LATIN CAPITAL LETTER AE WITH MACRON - 1, -- LATIN CAPITAL LETTER G WITH STROKE .. LATIN CAPITAL LETTER G WITH STROKE - 1, -- LATIN CAPITAL LETTER G WITH CARON .. LATIN CAPITAL LETTER G WITH CARON - 1, -- LATIN CAPITAL LETTER K WITH CARON .. LATIN CAPITAL LETTER K WITH CARON - 1, -- LATIN CAPITAL LETTER O WITH OGONEK .. LATIN CAPITAL LETTER O WITH OGONEK - 1, -- LATIN CAPITAL LETTER O WITH OGONEK AND MACRON .. LATIN CAPITAL LETTER O WITH OGONEK AND MACRON - 1, -- LATIN CAPITAL LETTER EZH WITH CARON .. LATIN CAPITAL LETTER EZH WITH CARON - 2, -- LATIN CAPITAL LETTER DZ .. LATIN CAPITAL LETTER DZ - 1, -- LATIN CAPITAL LETTER G WITH ACUTE .. LATIN CAPITAL LETTER G WITH ACUTE - 1, -- LATIN CAPITAL LETTER N WITH GRAVE .. LATIN CAPITAL LETTER N WITH GRAVE - 1, -- LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE .. LATIN CAPITAL LETTER A WITH RING ABOVE AND ACUTE - 1, -- LATIN CAPITAL LETTER AE WITH ACUTE .. LATIN CAPITAL LETTER AE WITH ACUTE - 1, -- LATIN CAPITAL LETTER O WITH STROKE AND ACUTE .. LATIN CAPITAL LETTER O WITH STROKE AND ACUTE - 1, -- LATIN CAPITAL LETTER A WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER A WITH DOUBLE GRAVE - 1, -- LATIN CAPITAL LETTER A WITH INVERTED BREVE .. LATIN CAPITAL LETTER A WITH INVERTED BREVE - 1, -- LATIN CAPITAL LETTER E WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER E WITH DOUBLE GRAVE - 1, -- LATIN CAPITAL LETTER E WITH INVERTED BREVE .. LATIN CAPITAL LETTER E WITH INVERTED BREVE - 1, -- LATIN CAPITAL LETTER I WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER I WITH DOUBLE GRAVE - 1, -- LATIN CAPITAL LETTER I WITH INVERTED BREVE .. LATIN CAPITAL LETTER I WITH INVERTED BREVE - 1, -- LATIN CAPITAL LETTER O WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER O WITH DOUBLE GRAVE - 1, -- LATIN CAPITAL LETTER O WITH INVERTED BREVE .. LATIN CAPITAL LETTER O WITH INVERTED BREVE - 1, -- LATIN CAPITAL LETTER R WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER R WITH DOUBLE GRAVE - 1, -- LATIN CAPITAL LETTER R WITH INVERTED BREVE .. LATIN CAPITAL LETTER R WITH INVERTED BREVE - 1, -- LATIN CAPITAL LETTER U WITH DOUBLE GRAVE .. LATIN CAPITAL LETTER U WITH DOUBLE GRAVE - 1, -- LATIN CAPITAL LETTER U WITH INVERTED BREVE .. LATIN CAPITAL LETTER U WITH INVERTED BREVE - 1, -- LATIN CAPITAL LETTER S WITH COMMA BELOW .. LATIN CAPITAL LETTER S WITH COMMA BELOW - 1, -- LATIN CAPITAL LETTER T WITH COMMA BELOW .. LATIN CAPITAL LETTER T WITH COMMA BELOW - 1, -- LATIN CAPITAL LETTER YOGH .. LATIN CAPITAL LETTER YOGH - 1, -- LATIN CAPITAL LETTER H WITH CARON .. LATIN CAPITAL LETTER H WITH CARON - -130, -- LATIN CAPITAL LETTER N WITH LONG RIGHT LEG .. LATIN CAPITAL LETTER N WITH LONG RIGHT LEG - 1, -- LATIN CAPITAL LETTER OU .. LATIN CAPITAL LETTER OU - 1, -- LATIN CAPITAL LETTER Z WITH HOOK .. LATIN CAPITAL LETTER Z WITH HOOK - 1, -- LATIN CAPITAL LETTER A WITH DOT ABOVE .. LATIN CAPITAL LETTER A WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER E WITH CEDILLA .. LATIN CAPITAL LETTER E WITH CEDILLA - 1, -- LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON .. LATIN CAPITAL LETTER O WITH DIAERESIS AND MACRON - 1, -- LATIN CAPITAL LETTER O WITH TILDE AND MACRON .. LATIN CAPITAL LETTER O WITH TILDE AND MACRON - 1, -- LATIN CAPITAL LETTER O WITH DOT ABOVE .. LATIN CAPITAL LETTER O WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON .. LATIN CAPITAL LETTER O WITH DOT ABOVE AND MACRON - 1, -- LATIN CAPITAL LETTER Y WITH MACRON .. LATIN CAPITAL LETTER Y WITH MACRON - 38, -- GREEK CAPITAL LETTER ALPHA WITH TONOS .. GREEK CAPITAL LETTER ALPHA WITH TONOS - 37, -- GREEK CAPITAL LETTER EPSILON WITH TONOS .. GREEK CAPITAL LETTER IOTA WITH TONOS - 64, -- GREEK CAPITAL LETTER OMICRON WITH TONOS .. GREEK CAPITAL LETTER OMICRON WITH TONOS - 63, -- GREEK CAPITAL LETTER UPSILON WITH TONOS .. GREEK CAPITAL LETTER OMEGA WITH TONOS - 32, -- GREEK CAPITAL LETTER ALPHA .. GREEK CAPITAL LETTER RHO - 32, -- GREEK CAPITAL LETTER SIGMA .. GREEK CAPITAL LETTER UPSILON WITH DIALYTIKA - 1, -- GREEK CAPITAL LETTER STIGMA .. GREEK CAPITAL LETTER STIGMA - 1, -- GREEK CAPITAL LETTER DIGAMMA .. GREEK CAPITAL LETTER DIGAMMA - 1, -- GREEK CAPITAL LETTER KOPPA .. GREEK CAPITAL LETTER KOPPA - 1, -- GREEK CAPITAL LETTER SAMPI .. GREEK CAPITAL LETTER SAMPI - 1, -- COPTIC CAPITAL LETTER SHEI .. COPTIC CAPITAL LETTER SHEI - 1, -- COPTIC CAPITAL LETTER FEI .. COPTIC CAPITAL LETTER FEI - 1, -- COPTIC CAPITAL LETTER KHEI .. COPTIC CAPITAL LETTER KHEI - 1, -- COPTIC CAPITAL LETTER HORI .. COPTIC CAPITAL LETTER HORI - 1, -- COPTIC CAPITAL LETTER GANGIA .. COPTIC CAPITAL LETTER GANGIA - 1, -- COPTIC CAPITAL LETTER SHIMA .. COPTIC CAPITAL LETTER SHIMA - 1, -- COPTIC CAPITAL LETTER DEI .. COPTIC CAPITAL LETTER DEI - 1, -- GREEK CAPITAL LETTER SHO .. GREEK CAPITAL LETTER SHO - 1, -- GREEK CAPITAL LETTER SAN .. GREEK CAPITAL LETTER SAN - 80, -- CYRILLIC CAPITAL LETTER IE WITH GRAVE .. CYRILLIC CAPITAL LETTER DZHE - 32, -- CYRILLIC CAPITAL LETTER A .. CYRILLIC CAPITAL LETTER YA - 1, -- CYRILLIC CAPITAL LETTER OMEGA .. CYRILLIC CAPITAL LETTER OMEGA - 1, -- CYRILLIC CAPITAL LETTER YAT .. CYRILLIC CAPITAL LETTER YAT - 1, -- CYRILLIC CAPITAL LETTER IOTIFIED E .. CYRILLIC CAPITAL LETTER IOTIFIED E - 1, -- CYRILLIC CAPITAL LETTER LITTLE YUS .. CYRILLIC CAPITAL LETTER LITTLE YUS - 1, -- CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS .. CYRILLIC CAPITAL LETTER IOTIFIED LITTLE YUS - 1, -- CYRILLIC CAPITAL LETTER BIG YUS .. CYRILLIC CAPITAL LETTER BIG YUS - 1, -- CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS .. CYRILLIC CAPITAL LETTER IOTIFIED BIG YUS - 1, -- CYRILLIC CAPITAL LETTER KSI .. CYRILLIC CAPITAL LETTER KSI - 1, -- CYRILLIC CAPITAL LETTER PSI .. CYRILLIC CAPITAL LETTER PSI - 1, -- CYRILLIC CAPITAL LETTER FITA .. CYRILLIC CAPITAL LETTER FITA - 1, -- CYRILLIC CAPITAL LETTER IZHITSA .. CYRILLIC CAPITAL LETTER IZHITSA - 1, -- CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT .. CYRILLIC CAPITAL LETTER IZHITSA WITH DOUBLE GRAVE ACCENT - 1, -- CYRILLIC CAPITAL LETTER UK .. CYRILLIC CAPITAL LETTER UK - 1, -- CYRILLIC CAPITAL LETTER ROUND OMEGA .. CYRILLIC CAPITAL LETTER ROUND OMEGA - 1, -- CYRILLIC CAPITAL LETTER OMEGA WITH TITLO .. CYRILLIC CAPITAL LETTER OMEGA WITH TITLO - 1, -- CYRILLIC CAPITAL LETTER OT .. CYRILLIC CAPITAL LETTER OT - 1, -- CYRILLIC CAPITAL LETTER KOPPA .. CYRILLIC CAPITAL LETTER KOPPA - 1, -- CYRILLIC CAPITAL LETTER SHORT I WITH TAIL .. CYRILLIC CAPITAL LETTER SHORT I WITH TAIL - 1, -- CYRILLIC CAPITAL LETTER SEMISOFT SIGN .. CYRILLIC CAPITAL LETTER SEMISOFT SIGN - 1, -- CYRILLIC CAPITAL LETTER ER WITH TICK .. CYRILLIC CAPITAL LETTER ER WITH TICK - 1, -- CYRILLIC CAPITAL LETTER GHE WITH UPTURN .. CYRILLIC CAPITAL LETTER GHE WITH UPTURN - 1, -- CYRILLIC CAPITAL LETTER GHE WITH STROKE .. CYRILLIC CAPITAL LETTER GHE WITH STROKE - 1, -- CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER GHE WITH MIDDLE HOOK - 1, -- CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZHE WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER ZE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ZE WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER KA WITH DESCENDER .. CYRILLIC CAPITAL LETTER KA WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER KA WITH VERTICAL STROKE - 1, -- CYRILLIC CAPITAL LETTER KA WITH STROKE .. CYRILLIC CAPITAL LETTER KA WITH STROKE - 1, -- CYRILLIC CAPITAL LETTER BASHKIR KA .. CYRILLIC CAPITAL LETTER BASHKIR KA - 1, -- CYRILLIC CAPITAL LETTER EN WITH DESCENDER .. CYRILLIC CAPITAL LETTER EN WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER EN GE .. CYRILLIC CAPITAL LETTER EN GE - 1, -- CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK .. CYRILLIC CAPITAL LETTER PE WITH MIDDLE HOOK - 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN HA .. CYRILLIC CAPITAL LETTER ABKHASIAN HA - 1, -- CYRILLIC CAPITAL LETTER ES WITH DESCENDER .. CYRILLIC CAPITAL LETTER ES WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER TE WITH DESCENDER .. CYRILLIC CAPITAL LETTER TE WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER STRAIGHT U .. CYRILLIC CAPITAL LETTER STRAIGHT U - 1, -- CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE .. CYRILLIC CAPITAL LETTER STRAIGHT U WITH STROKE - 1, -- CYRILLIC CAPITAL LETTER HA WITH DESCENDER .. CYRILLIC CAPITAL LETTER HA WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER TE TSE .. CYRILLIC CAPITAL LETTER TE TSE - 1, -- CYRILLIC CAPITAL LETTER CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER CHE WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE .. CYRILLIC CAPITAL LETTER CHE WITH VERTICAL STROKE - 1, -- CYRILLIC CAPITAL LETTER SHHA .. CYRILLIC CAPITAL LETTER SHHA - 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE - 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER .. CYRILLIC CAPITAL LETTER ABKHASIAN CHE WITH DESCENDER - 1, -- CYRILLIC CAPITAL LETTER ZHE WITH BREVE .. CYRILLIC CAPITAL LETTER ZHE WITH BREVE - 1, -- CYRILLIC CAPITAL LETTER KA WITH HOOK .. CYRILLIC CAPITAL LETTER KA WITH HOOK - 1, -- CYRILLIC CAPITAL LETTER EL WITH TAIL .. CYRILLIC CAPITAL LETTER EL WITH TAIL - 1, -- CYRILLIC CAPITAL LETTER EN WITH HOOK .. CYRILLIC CAPITAL LETTER EN WITH HOOK - 1, -- CYRILLIC CAPITAL LETTER EN WITH TAIL .. CYRILLIC CAPITAL LETTER EN WITH TAIL - 1, -- CYRILLIC CAPITAL LETTER KHAKASSIAN CHE .. CYRILLIC CAPITAL LETTER KHAKASSIAN CHE - 1, -- CYRILLIC CAPITAL LETTER EM WITH TAIL .. CYRILLIC CAPITAL LETTER EM WITH TAIL - 1, -- CYRILLIC CAPITAL LETTER A WITH BREVE .. CYRILLIC CAPITAL LETTER A WITH BREVE - 1, -- CYRILLIC CAPITAL LETTER A WITH DIAERESIS .. CYRILLIC CAPITAL LETTER A WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER IE WITH BREVE .. CYRILLIC CAPITAL LETTER IE WITH BREVE - 1, -- CYRILLIC CAPITAL LETTER SCHWA .. CYRILLIC CAPITAL LETTER SCHWA - 1, -- CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS .. CYRILLIC CAPITAL LETTER SCHWA WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZHE WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER ZE WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER ABKHASIAN DZE .. CYRILLIC CAPITAL LETTER ABKHASIAN DZE - 1, -- CYRILLIC CAPITAL LETTER I WITH MACRON .. CYRILLIC CAPITAL LETTER I WITH MACRON - 1, -- CYRILLIC CAPITAL LETTER I WITH DIAERESIS .. CYRILLIC CAPITAL LETTER I WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER O WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER BARRED O .. CYRILLIC CAPITAL LETTER BARRED O - 1, -- CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS .. CYRILLIC CAPITAL LETTER BARRED O WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER E WITH DIAERESIS .. CYRILLIC CAPITAL LETTER E WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER U WITH MACRON .. CYRILLIC CAPITAL LETTER U WITH MACRON - 1, -- CYRILLIC CAPITAL LETTER U WITH DIAERESIS .. CYRILLIC CAPITAL LETTER U WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE .. CYRILLIC CAPITAL LETTER U WITH DOUBLE ACUTE - 1, -- CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS .. CYRILLIC CAPITAL LETTER CHE WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS .. CYRILLIC CAPITAL LETTER YERU WITH DIAERESIS - 1, -- CYRILLIC CAPITAL LETTER KOMI DE .. CYRILLIC CAPITAL LETTER KOMI DE - 1, -- CYRILLIC CAPITAL LETTER KOMI DJE .. CYRILLIC CAPITAL LETTER KOMI DJE - 1, -- CYRILLIC CAPITAL LETTER KOMI ZJE .. CYRILLIC CAPITAL LETTER KOMI ZJE - 1, -- CYRILLIC CAPITAL LETTER KOMI DZJE .. CYRILLIC CAPITAL LETTER KOMI DZJE - 1, -- CYRILLIC CAPITAL LETTER KOMI LJE .. CYRILLIC CAPITAL LETTER KOMI LJE - 1, -- CYRILLIC CAPITAL LETTER KOMI NJE .. CYRILLIC CAPITAL LETTER KOMI NJE - 1, -- CYRILLIC CAPITAL LETTER KOMI SJE .. CYRILLIC CAPITAL LETTER KOMI SJE - 1, -- CYRILLIC CAPITAL LETTER KOMI TJE .. CYRILLIC CAPITAL LETTER KOMI TJE - 48, -- ARMENIAN CAPITAL LETTER AYB .. ARMENIAN CAPITAL LETTER FEH - 48, -- GEORGIAN CAPITAL LETTER AN .. GEORGIAN CAPITAL LETTER HOE - 1, -- LATIN CAPITAL LETTER A WITH RING BELOW .. LATIN CAPITAL LETTER A WITH RING BELOW - 1, -- LATIN CAPITAL LETTER B WITH DOT ABOVE .. LATIN CAPITAL LETTER B WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER B WITH DOT BELOW .. LATIN CAPITAL LETTER B WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER B WITH LINE BELOW .. LATIN CAPITAL LETTER B WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE .. LATIN CAPITAL LETTER C WITH CEDILLA AND ACUTE - 1, -- LATIN CAPITAL LETTER D WITH DOT ABOVE .. LATIN CAPITAL LETTER D WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER D WITH DOT BELOW .. LATIN CAPITAL LETTER D WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER D WITH LINE BELOW .. LATIN CAPITAL LETTER D WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER D WITH CEDILLA .. LATIN CAPITAL LETTER D WITH CEDILLA - 1, -- LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER D WITH CIRCUMFLEX BELOW - 1, -- LATIN CAPITAL LETTER E WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER E WITH MACRON AND GRAVE - 1, -- LATIN CAPITAL LETTER E WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER E WITH MACRON AND ACUTE - 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX BELOW - 1, -- LATIN CAPITAL LETTER E WITH TILDE BELOW .. LATIN CAPITAL LETTER E WITH TILDE BELOW - 1, -- LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE .. LATIN CAPITAL LETTER E WITH CEDILLA AND BREVE - 1, -- LATIN CAPITAL LETTER F WITH DOT ABOVE .. LATIN CAPITAL LETTER F WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER G WITH MACRON .. LATIN CAPITAL LETTER G WITH MACRON - 1, -- LATIN CAPITAL LETTER H WITH DOT ABOVE .. LATIN CAPITAL LETTER H WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER H WITH DOT BELOW .. LATIN CAPITAL LETTER H WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER H WITH DIAERESIS .. LATIN CAPITAL LETTER H WITH DIAERESIS - 1, -- LATIN CAPITAL LETTER H WITH CEDILLA .. LATIN CAPITAL LETTER H WITH CEDILLA - 1, -- LATIN CAPITAL LETTER H WITH BREVE BELOW .. LATIN CAPITAL LETTER H WITH BREVE BELOW - 1, -- LATIN CAPITAL LETTER I WITH TILDE BELOW .. LATIN CAPITAL LETTER I WITH TILDE BELOW - 1, -- LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE .. LATIN CAPITAL LETTER I WITH DIAERESIS AND ACUTE - 1, -- LATIN CAPITAL LETTER K WITH ACUTE .. LATIN CAPITAL LETTER K WITH ACUTE - 1, -- LATIN CAPITAL LETTER K WITH DOT BELOW .. LATIN CAPITAL LETTER K WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER K WITH LINE BELOW .. LATIN CAPITAL LETTER K WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER L WITH DOT BELOW .. LATIN CAPITAL LETTER L WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER L WITH DOT BELOW AND MACRON - 1, -- LATIN CAPITAL LETTER L WITH LINE BELOW .. LATIN CAPITAL LETTER L WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER L WITH CIRCUMFLEX BELOW - 1, -- LATIN CAPITAL LETTER M WITH ACUTE .. LATIN CAPITAL LETTER M WITH ACUTE - 1, -- LATIN CAPITAL LETTER M WITH DOT ABOVE .. LATIN CAPITAL LETTER M WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER M WITH DOT BELOW .. LATIN CAPITAL LETTER M WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER N WITH DOT ABOVE .. LATIN CAPITAL LETTER N WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER N WITH DOT BELOW .. LATIN CAPITAL LETTER N WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER N WITH LINE BELOW .. LATIN CAPITAL LETTER N WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER N WITH CIRCUMFLEX BELOW - 1, -- LATIN CAPITAL LETTER O WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER O WITH TILDE AND ACUTE - 1, -- LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS .. LATIN CAPITAL LETTER O WITH TILDE AND DIAERESIS - 1, -- LATIN CAPITAL LETTER O WITH MACRON AND GRAVE .. LATIN CAPITAL LETTER O WITH MACRON AND GRAVE - 1, -- LATIN CAPITAL LETTER O WITH MACRON AND ACUTE .. LATIN CAPITAL LETTER O WITH MACRON AND ACUTE - 1, -- LATIN CAPITAL LETTER P WITH ACUTE .. LATIN CAPITAL LETTER P WITH ACUTE - 1, -- LATIN CAPITAL LETTER P WITH DOT ABOVE .. LATIN CAPITAL LETTER P WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER R WITH DOT ABOVE .. LATIN CAPITAL LETTER R WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER R WITH DOT BELOW .. LATIN CAPITAL LETTER R WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON .. LATIN CAPITAL LETTER R WITH DOT BELOW AND MACRON - 1, -- LATIN CAPITAL LETTER R WITH LINE BELOW .. LATIN CAPITAL LETTER R WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER S WITH DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER S WITH DOT BELOW .. LATIN CAPITAL LETTER S WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH ACUTE AND DOT ABOVE - 1, -- LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH CARON AND DOT ABOVE - 1, -- LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE .. LATIN CAPITAL LETTER S WITH DOT BELOW AND DOT ABOVE - 1, -- LATIN CAPITAL LETTER T WITH DOT ABOVE .. LATIN CAPITAL LETTER T WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER T WITH DOT BELOW .. LATIN CAPITAL LETTER T WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER T WITH LINE BELOW .. LATIN CAPITAL LETTER T WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER T WITH CIRCUMFLEX BELOW - 1, -- LATIN CAPITAL LETTER U WITH DIAERESIS BELOW .. LATIN CAPITAL LETTER U WITH DIAERESIS BELOW - 1, -- LATIN CAPITAL LETTER U WITH TILDE BELOW .. LATIN CAPITAL LETTER U WITH TILDE BELOW - 1, -- LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW .. LATIN CAPITAL LETTER U WITH CIRCUMFLEX BELOW - 1, -- LATIN CAPITAL LETTER U WITH TILDE AND ACUTE .. LATIN CAPITAL LETTER U WITH TILDE AND ACUTE - 1, -- LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS .. LATIN CAPITAL LETTER U WITH MACRON AND DIAERESIS - 1, -- LATIN CAPITAL LETTER V WITH TILDE .. LATIN CAPITAL LETTER V WITH TILDE - 1, -- LATIN CAPITAL LETTER V WITH DOT BELOW .. LATIN CAPITAL LETTER V WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER W WITH GRAVE .. LATIN CAPITAL LETTER W WITH GRAVE - 1, -- LATIN CAPITAL LETTER W WITH ACUTE .. LATIN CAPITAL LETTER W WITH ACUTE - 1, -- LATIN CAPITAL LETTER W WITH DIAERESIS .. LATIN CAPITAL LETTER W WITH DIAERESIS - 1, -- LATIN CAPITAL LETTER W WITH DOT ABOVE .. LATIN CAPITAL LETTER W WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER W WITH DOT BELOW .. LATIN CAPITAL LETTER W WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER X WITH DOT ABOVE .. LATIN CAPITAL LETTER X WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER X WITH DIAERESIS .. LATIN CAPITAL LETTER X WITH DIAERESIS - 1, -- LATIN CAPITAL LETTER Y WITH DOT ABOVE .. LATIN CAPITAL LETTER Y WITH DOT ABOVE - 1, -- LATIN CAPITAL LETTER Z WITH CIRCUMFLEX .. LATIN CAPITAL LETTER Z WITH CIRCUMFLEX - 1, -- LATIN CAPITAL LETTER Z WITH DOT BELOW .. LATIN CAPITAL LETTER Z WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER Z WITH LINE BELOW .. LATIN CAPITAL LETTER Z WITH LINE BELOW - 1, -- LATIN CAPITAL LETTER A WITH DOT BELOW .. LATIN CAPITAL LETTER A WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER A WITH HOOK ABOVE .. LATIN CAPITAL LETTER A WITH HOOK ABOVE - 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND ACUTE - 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND GRAVE - 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND HOOK ABOVE - 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND TILDE - 1, -- LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER A WITH CIRCUMFLEX AND DOT BELOW - 1, -- LATIN CAPITAL LETTER A WITH BREVE AND ACUTE .. LATIN CAPITAL LETTER A WITH BREVE AND ACUTE - 1, -- LATIN CAPITAL LETTER A WITH BREVE AND GRAVE .. LATIN CAPITAL LETTER A WITH BREVE AND GRAVE - 1, -- LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE .. LATIN CAPITAL LETTER A WITH BREVE AND HOOK ABOVE - 1, -- LATIN CAPITAL LETTER A WITH BREVE AND TILDE .. LATIN CAPITAL LETTER A WITH BREVE AND TILDE - 1, -- LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW .. LATIN CAPITAL LETTER A WITH BREVE AND DOT BELOW - 1, -- LATIN CAPITAL LETTER E WITH DOT BELOW .. LATIN CAPITAL LETTER E WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER E WITH HOOK ABOVE .. LATIN CAPITAL LETTER E WITH HOOK ABOVE - 1, -- LATIN CAPITAL LETTER E WITH TILDE .. LATIN CAPITAL LETTER E WITH TILDE - 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND ACUTE - 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND GRAVE - 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND HOOK ABOVE - 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND TILDE - 1, -- LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER E WITH CIRCUMFLEX AND DOT BELOW - 1, -- LATIN CAPITAL LETTER I WITH HOOK ABOVE .. LATIN CAPITAL LETTER I WITH HOOK ABOVE - 1, -- LATIN CAPITAL LETTER I WITH DOT BELOW .. LATIN CAPITAL LETTER I WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER O WITH DOT BELOW .. LATIN CAPITAL LETTER O WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER O WITH HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HOOK ABOVE - 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND ACUTE - 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND GRAVE - 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND HOOK ABOVE - 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND TILDE - 1, -- LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW .. LATIN CAPITAL LETTER O WITH CIRCUMFLEX AND DOT BELOW - 1, -- LATIN CAPITAL LETTER O WITH HORN AND ACUTE .. LATIN CAPITAL LETTER O WITH HORN AND ACUTE - 1, -- LATIN CAPITAL LETTER O WITH HORN AND GRAVE .. LATIN CAPITAL LETTER O WITH HORN AND GRAVE - 1, -- LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER O WITH HORN AND HOOK ABOVE - 1, -- LATIN CAPITAL LETTER O WITH HORN AND TILDE .. LATIN CAPITAL LETTER O WITH HORN AND TILDE - 1, -- LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER O WITH HORN AND DOT BELOW - 1, -- LATIN CAPITAL LETTER U WITH DOT BELOW .. LATIN CAPITAL LETTER U WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER U WITH HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HOOK ABOVE - 1, -- LATIN CAPITAL LETTER U WITH HORN AND ACUTE .. LATIN CAPITAL LETTER U WITH HORN AND ACUTE - 1, -- LATIN CAPITAL LETTER U WITH HORN AND GRAVE .. LATIN CAPITAL LETTER U WITH HORN AND GRAVE - 1, -- LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE .. LATIN CAPITAL LETTER U WITH HORN AND HOOK ABOVE - 1, -- LATIN CAPITAL LETTER U WITH HORN AND TILDE .. LATIN CAPITAL LETTER U WITH HORN AND TILDE - 1, -- LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW .. LATIN CAPITAL LETTER U WITH HORN AND DOT BELOW - 1, -- LATIN CAPITAL LETTER Y WITH GRAVE .. LATIN CAPITAL LETTER Y WITH GRAVE - 1, -- LATIN CAPITAL LETTER Y WITH DOT BELOW .. LATIN CAPITAL LETTER Y WITH DOT BELOW - 1, -- LATIN CAPITAL LETTER Y WITH HOOK ABOVE .. LATIN CAPITAL LETTER Y WITH HOOK ABOVE - 1, -- LATIN CAPITAL LETTER Y WITH TILDE .. LATIN CAPITAL LETTER Y WITH TILDE - -8, -- GREEK CAPITAL LETTER ALPHA WITH PSILI .. GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI - -8, -- GREEK CAPITAL LETTER EPSILON WITH PSILI .. GREEK CAPITAL LETTER EPSILON WITH DASIA AND OXIA - -8, -- GREEK CAPITAL LETTER ETA WITH PSILI .. GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI - -8, -- GREEK CAPITAL LETTER IOTA WITH PSILI .. GREEK CAPITAL LETTER IOTA WITH DASIA AND PERISPOMENI - -8, -- GREEK CAPITAL LETTER OMICRON WITH PSILI .. GREEK CAPITAL LETTER OMICRON WITH DASIA AND OXIA - -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA - -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND VARIA - -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND OXIA - -8, -- GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI .. GREEK CAPITAL LETTER UPSILON WITH DASIA AND PERISPOMENI - -8, -- GREEK CAPITAL LETTER OMEGA WITH PSILI .. GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI - -8, -- GREEK CAPITAL LETTER ALPHA WITH VRACHY .. GREEK CAPITAL LETTER ALPHA WITH MACRON - -74, -- GREEK CAPITAL LETTER ALPHA WITH VARIA .. GREEK CAPITAL LETTER ALPHA WITH OXIA - -86, -- GREEK CAPITAL LETTER EPSILON WITH VARIA .. GREEK CAPITAL LETTER ETA WITH OXIA - -8, -- GREEK CAPITAL LETTER IOTA WITH VRACHY .. GREEK CAPITAL LETTER IOTA WITH MACRON - -100, -- GREEK CAPITAL LETTER IOTA WITH VARIA .. GREEK CAPITAL LETTER IOTA WITH OXIA - -8, -- GREEK CAPITAL LETTER UPSILON WITH VRACHY .. GREEK CAPITAL LETTER UPSILON WITH MACRON - -112, -- GREEK CAPITAL LETTER UPSILON WITH VARIA .. GREEK CAPITAL LETTER UPSILON WITH OXIA - -7, -- GREEK CAPITAL LETTER RHO WITH DASIA .. GREEK CAPITAL LETTER RHO WITH DASIA - -128, -- GREEK CAPITAL LETTER OMICRON WITH VARIA .. GREEK CAPITAL LETTER OMICRON WITH OXIA - -126, -- GREEK CAPITAL LETTER OMEGA WITH VARIA .. GREEK CAPITAL LETTER OMEGA WITH OXIA - 26, -- CIRCLED LATIN CAPITAL LETTER A .. CIRCLED LATIN CAPITAL LETTER Z - 32, -- FULLWIDTH LATIN CAPITAL LETTER A .. FULLWIDTH LATIN CAPITAL LETTER Z - 40, -- DESERET CAPITAL LETTER LONG I .. DESERET CAPITAL LETTER EW - 32); -- TAG LATIN CAPITAL LETTER A .. TAG LATIN CAPITAL LETTER Z - - pragma Warnings (On); - -- Temporary until pragma Warnings at start can be activated ??? - - -- The following is a list of the 10646 names for CAPITAL LETTER entries - -- that have no matching SMALL LETTER entry and are thus not folded - - -- LATIN CAPITAL LETTER I WITH DOT ABOVE - -- LATIN CAPITAL LETTER AFRICAN D - -- LATIN CAPITAL LETTER O WITH MIDDLE TILDE - -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z WITH CARON - -- LATIN CAPITAL LETTER L WITH SMALL LETTER J - -- LATIN CAPITAL LETTER N WITH SMALL LETTER J - -- LATIN CAPITAL LETTER D WITH SMALL LETTER Z - -- LATIN CAPITAL LETTER HWAIR - -- LATIN CAPITAL LETTER WYNN - -- GREEK CAPITAL LETTER UPSILON HOOK - -- GREEK CAPITAL LETTER UPSILON HOOK TONOS - -- GREEK CAPITAL LETTER UPSILON HOOK DIAERESIS - -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND VARIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND VARIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND OXIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND OXIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH PSILI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH DASIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH PSILI AND VARIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH DASIA AND VARIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH PSILI AND OXIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH DASIA AND OXIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND VARIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND VARIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND OXIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND OXIA AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH PSILI AND PERISPOMENI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH DASIA AND PERISPOMENI AND PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ALPHA WITH PROSGEGRAMMENI - -- GREEK CAPITAL LETTER ETA WITH PROSGEGRAMMENI - -- GREEK CAPITAL LETTER OMEGA WITH PROSGEGRAMMENI - - ----------------------- - -- Local Subprograms -- - ----------------------- - - function Range_Search (U : UTF_32; R : UTF_32_Ranges) return Natural; - -- Searches the given ranges (which must be in ascending order by Lo value) - -- and returns the index of the matching range in R if U matches one of the - -- ranges. If U matches none of the ranges, returns zero. - - ------------------ - -- Get_Category -- - ------------------ - - function Get_Category (U : UTF_32) return Category is - begin - -- Deal with FFFE/FFFF cases - - if U mod 16#1_0000# >= 16#FFFE# then - return Fe; - - -- Otherwise search table - - else - declare - Index : constant Integer := Range_Search (U, Unicode_Ranges); - begin - if Index = 0 then - return Cn; - else - return Unicode_Categories (Index); - end if; - end; - end if; - end Get_Category; - - --------------------- - -- Is_UTF_32_Digit -- - --------------------- - - function Is_UTF_32_Digit (U : UTF_32) return Boolean is - begin - return Range_Search (U, UTF_32_Digits) /= 0; - end Is_UTF_32_Digit; - - function Is_UTF_32_Digit (C : Category) return Boolean is - begin - return C = Nd; - end Is_UTF_32_Digit; - - ---------------------- - -- Is_UTF_32_Letter -- - ---------------------- - - function Is_UTF_32_Letter (U : UTF_32) return Boolean is - begin - return Range_Search (U, UTF_32_Letters) /= 0; - end Is_UTF_32_Letter; - - Letter : constant array (Category) of Boolean := - (Lu => True, - Ll => True, - Lt => True, - Lm => True, - Lo => True, - Nl => True, - others => False); - - function Is_UTF_32_Letter (C : Category) return Boolean is - begin - return Letter (C); - end Is_UTF_32_Letter; - - ------------------------------- - -- Is_UTF_32_Line_Terminator -- - ------------------------------- - - function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean is - begin - return U in 10 .. 13 -- Ascii.LF Ascii.VT Ascii.FF Ascii.CR - or else U = 16#00085# -- NEL - or else U = 16#02028# -- LINE SEPARATOR - or else U = 16#02029#; -- PARAGRAPH SEPARATOR - end Is_UTF_32_Line_Terminator; - - -------------------- - -- Is_UTF_32_Mark -- - -------------------- - - function Is_UTF_32_Mark (U : UTF_32) return Boolean is - begin - return Range_Search (U, UTF_32_Marks) /= 0; - end Is_UTF_32_Mark; - - function Is_UTF_32_Mark (C : Category) return Boolean is - begin - return C = Mn or else C = Mc; - end Is_UTF_32_Mark; - - --------------------------- - -- Is_UTF_32_Non_Graphic -- - --------------------------- - - function Is_UTF_32_Non_Graphic (U : UTF_32) return Boolean is - begin - -- We have to deal with FFFE/FFFF specially - - if U mod 16#1_0000# >= 16#FFFE# then - return True; - - -- Otherwise we can use the table - - else - return Range_Search (U, UTF_32_Non_Graphic) /= 0; - end if; - end Is_UTF_32_Non_Graphic; - - Non_Graphic : constant array (Category) of Boolean := - (Cc => True, - Co => True, - Cs => True, - Zl => True, - Zp => True, - Fe => True, - others => False); - - function Is_UTF_32_Non_Graphic (C : Category) return Boolean is - begin - return Non_Graphic (C); - end Is_UTF_32_Non_Graphic; - - --------------------- - -- Is_UTF_32_Other -- - --------------------- - - function Is_UTF_32_Other (U : UTF_32) return Boolean is - begin - return Range_Search (U, UTF_32_Other_Format) /= 0; - end Is_UTF_32_Other; - - function Is_UTF_32_Other (C : Category) return Boolean is - begin - return C = Cf; - end Is_UTF_32_Other; - - --------------------------- - -- Is_UTF_32_Punctuation -- - --------------------------- - - function Is_UTF_32_Punctuation (U : UTF_32) return Boolean is - begin - return Range_Search (U, UTF_32_Punctuation) /= 0; - end Is_UTF_32_Punctuation; - - function Is_UTF_32_Punctuation (C : Category) return Boolean is - begin - return C = Pc; - end Is_UTF_32_Punctuation; - - --------------------- - -- Is_UTF_32_Space -- - --------------------- - - function Is_UTF_32_Space (U : UTF_32) return Boolean is - begin - return Range_Search (U, UTF_32_Spaces) /= 0; - end Is_UTF_32_Space; - - function Is_UTF_32_Space (C : Category) return Boolean is - begin - return C = Zs; - end Is_UTF_32_Space; - - ------------------ - -- Range_Search -- - ------------------ - - function Range_Search (U : UTF_32; R : UTF_32_Ranges) return Natural is - Lo : Integer; - Hi : Integer; - Mid : Integer; - - begin - Lo := R'First; - Hi := R'Last; - - loop - Mid := (Lo + Hi) / 2; - - if U < R (Mid).Lo then - Hi := Mid - 1; - - if Hi < Lo then - return 0; - end if; - - elsif R (Mid).Hi < U then - Lo := Mid + 1; - - if Hi < Lo then - return 0; - end if; - - else - return Mid; - end if; - end loop; - end Range_Search; - - -------------------------- - -- UTF_32_To_Lower_Case -- - -------------------------- - - function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32 is - Index : constant Integer := Range_Search (U, Upper_Case_Letters); - begin - if Index = 0 then - return U; - else - return U + Upper_Case_Adjust (Index); - end if; - end UTF_32_To_Lower_Case; - - -------------------------- - -- UTF_32_To_Upper_Case -- - -------------------------- - - function UTF_32_To_Upper_Case (U : UTF_32) return UTF_32 is - Index : constant Integer := Range_Search (U, Lower_Case_Letters); - begin - if Index = 0 then - return U; - else - return U + Lower_Case_Adjust (Index); - end if; - end UTF_32_To_Upper_Case; - -end System.UTF_32; diff --git a/gcc/ada/s-utf_32.ads b/gcc/ada/s-utf_32.ads deleted file mode 100644 index 1d01fa5..0000000 --- a/gcc/ada/s-utf_32.ads +++ /dev/null @@ -1,212 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . U T F _ 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2005-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package is an internal package that provides basic character --- classification capabilities needed by the compiler for handling full --- 32-bit wide wide characters. We avoid the use of the actual type --- Wide_Wide_Character, since we want to use these routines in the compiler --- itself, and we want to be able to compile the compiler with old versions --- of GNAT that did not implement Wide_Wide_Character. - --- System.UTF_32 should not be directly used from an application program, but --- an equivalent package GNAT.UTF_32 can be used directly and provides exactly --- the same services. The reason this package is in System is so that it can --- with'ed by other packages in the Ada and System hierarchies. - -pragma Compiler_Unit_Warning; - -package System.UTF_32 is - pragma Pure; - - type UTF_32 is range 0 .. 16#7FFF_FFFF#; - -- So far, the only defined character codes are in 0 .. 16#01_FFFF# - - -- The following type defines the categories from the unicode definitions. - -- The one addition we make is Fe, which represents the characters FFFE - -- and FFFF in any of the planes. - - type Category is ( - Cc, -- Other, Control - Cf, -- Other, Format - Cn, -- Other, Not Assigned - Co, -- Other, Private Use - Cs, -- Other, Surrogate - Ll, -- Letter, Lowercase - Lm, -- Letter, Modifier - Lo, -- Letter, Other - Lt, -- Letter, Titlecase - Lu, -- Letter, Uppercase - Mc, -- Mark, Spacing Combining - Me, -- Mark, Enclosing - Mn, -- Mark, Nonspacing - Nd, -- Number, Decimal Digit - Nl, -- Number, Letter - No, -- Number, Other - Pc, -- Punctuation, Connector - Pd, -- Punctuation, Dash - Pe, -- Punctuation, Close - Pf, -- Punctuation, Final quote - Pi, -- Punctuation, Initial quote - Po, -- Punctuation, Other - Ps, -- Punctuation, Open - Sc, -- Symbol, Currency - Sk, -- Symbol, Modifier - Sm, -- Symbol, Math - So, -- Symbol, Other - Zl, -- Separator, Line - Zp, -- Separator, Paragraph - Zs, -- Separator, Space - Fe); -- relative position FFFE/FFFF in any plane - - function Get_Category (U : UTF_32) return Category; - -- Given a UTF32 code, returns corresponding Category, or Cn if - -- the code does not have an assigned unicode category. - - -- The following functions perform category tests corresponding to lexical - -- classes defined in the Ada standard. There are two interfaces for each - -- function. The second takes a Category (e.g. returned by Get_Category). - -- The first takes a UTF_32 code. The form taking the UTF_32 code is - -- typically more efficient than calling Get_Category, but if several - -- different tests are to be performed on the same code, it is more - -- efficient to use Get_Category to get the category, then test the - -- resulting category. - - function Is_UTF_32_Letter (U : UTF_32) return Boolean; - function Is_UTF_32_Letter (C : Category) return Boolean; - pragma Inline (Is_UTF_32_Letter); - -- Returns true iff U is a letter that can be used to start an identifier, - -- or if C is one of the corresponding categories, which are the following: - -- Letter, Uppercase (Lu) - -- Letter, Lowercase (Ll) - -- Letter, Titlecase (Lt) - -- Letter, Modifier (Lm) - -- Letter, Other (Lo) - -- Number, Letter (Nl) - - function Is_UTF_32_Digit (U : UTF_32) return Boolean; - function Is_UTF_32_Digit (C : Category) return Boolean; - pragma Inline (Is_UTF_32_Digit); - -- Returns true iff U is a digit that can be used to extend an identifier, - -- or if C is one of the corresponding categories, which are the following: - -- Number, Decimal_Digit (Nd) - - function Is_UTF_32_Line_Terminator (U : UTF_32) return Boolean; - pragma Inline (Is_UTF_32_Line_Terminator); - -- Returns true iff U is an allowed line terminator for source programs, - -- if U is in the category Zp (Separator, Paragraph), or Zl (Separator, - -- Line), or if U is a conventional line terminator (CR, LF, VT, FF). - -- There is no category version for this function, since the set of - -- characters does not correspond to a set of Unicode categories. - - function Is_UTF_32_Mark (U : UTF_32) return Boolean; - function Is_UTF_32_Mark (C : Category) return Boolean; - pragma Inline (Is_UTF_32_Mark); - -- Returns true iff U is a mark character which can be used to extend an - -- identifier, or if C is one of the corresponding categories, which are - -- the following: - -- Mark, Non-Spacing (Mn) - -- Mark, Spacing Combining (Mc) - - function Is_UTF_32_Other (U : UTF_32) return Boolean; - function Is_UTF_32_Other (C : Category) return Boolean; - pragma Inline (Is_UTF_32_Other); - -- Returns true iff U is an other format character, which means that it - -- can be used to extend an identifier, but is ignored for the purposes of - -- matching of identifiers, or if C is one of the corresponding categories, - -- which are the following: - -- Other, Format (Cf) - - function Is_UTF_32_Punctuation (U : UTF_32) return Boolean; - function Is_UTF_32_Punctuation (C : Category) return Boolean; - pragma Inline (Is_UTF_32_Punctuation); - -- Returns true iff U is a punctuation character that can be used to - -- separate pieces of an identifier, or if C is one of the corresponding - -- categories, which are the following: - -- Punctuation, Connector (Pc) - - function Is_UTF_32_Space (U : UTF_32) return Boolean; - function Is_UTF_32_Space (C : Category) return Boolean; - pragma Inline (Is_UTF_32_Space); - -- Returns true iff U is considered a space to be ignored, or if C is one - -- of the corresponding categories, which are the following: - -- Separator, Space (Zs) - - function Is_UTF_32_Non_Graphic (U : UTF_32) return Boolean; - function Is_UTF_32_Non_Graphic (C : Category) return Boolean; - pragma Inline (Is_UTF_32_Non_Graphic); - -- Returns true iff U is considered to be a non-graphic character, or if C - -- is one of the corresponding categories, which are the following: - -- Other, Control (Cc) - -- Other, Private Use (Co) - -- Other, Surrogate (Cs) - -- Separator, Line (Zl) - -- Separator, Paragraph (Zp) - -- FFFE or FFFF positions in any plane (Fe) - -- - -- Note that the Ada category format effector is subsumed by the above - -- list of Unicode categories. - -- - -- Note that Other, Unassigned (Cn) is quite deliberately not included - -- in the list of categories above. This means that should any of these - -- code positions be defined in future with graphic characters they will - -- be allowed without a need to change implementations or the standard. - -- - -- Note that Other, Format (Cf) is also quite deliberately not included - -- in the list of categories above. This means that these characters can - -- be included in character and string literals. - - -- The following function is used to fold to upper case, as required by - -- the Ada 2005 standard rules for identifier case folding. Two - -- identifiers are equivalent if they are identical after folding all - -- letters to upper case using this routine. A corresponding routine to - -- fold to lower case is also provided. - - function UTF_32_To_Lower_Case (U : UTF_32) return UTF_32; - pragma Inline (UTF_32_To_Lower_Case); - -- If U represents an upper case letter, returns the corresponding lower - -- case letter, otherwise U is returned unchanged. The folding rule is - -- simply that if the code corresponds to a 10646 entry whose name contains - -- the string CAPITAL LETTER, and there is a corresponding entry whose name - -- is the same but with CAPITAL LETTER replaced by SMALL LETTER, then the - -- code is folded to this SMALL LETTER code. Otherwise the input code is - -- returned unchanged. - - function UTF_32_To_Upper_Case (U : UTF_32) return UTF_32; - pragma Inline (UTF_32_To_Upper_Case); - -- If U represents a lower case letter, returns the corresponding lower - -- case letter, otherwise U is returned unchanged. The folding rule is - -- simply that if the code corresponds to a 10646 entry whose name contains - -- the string SMALL LETTER, and there is a corresponding entry whose name - -- is the same but with SMALL LETTER replaced by CAPITAL LETTER, then the - -- code is folded to this CAPITAL LETTER code. Otherwise the input code is - -- returned unchanged. - -end System.UTF_32; diff --git a/gcc/ada/s-valboo.adb b/gcc/ada/s-valboo.adb deleted file mode 100644 index 59c79ef..0000000 --- a/gcc/ada/s-valboo.adb +++ /dev/null @@ -1,59 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ B O O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Val_Util; use System.Val_Util; - -package body System.Val_Bool is - - ------------------- - -- Value_Boolean -- - ------------------- - - function Value_Boolean (Str : String) return Boolean is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - begin - Normalize_String (S, F, L); - - if S (F .. L) = "TRUE" then - return True; - - elsif S (F .. L) = "FALSE" then - return False; - - else - Bad_Value (Str); - end if; - end Value_Boolean; - -end System.Val_Bool; diff --git a/gcc/ada/s-valboo.ads b/gcc/ada/s-valboo.ads deleted file mode 100644 index 3b69924..0000000 --- a/gcc/ada/s-valboo.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ B O O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System.Val_Bool is - pragma Pure; - - function Value_Boolean (Str : String) return Boolean; - -- Computes Boolean'Value (Str) - -end System.Val_Bool; diff --git a/gcc/ada/s-valcha.adb b/gcc/ada/s-valcha.adb deleted file mode 100644 index 799145f..0000000 --- a/gcc/ada/s-valcha.adb +++ /dev/null @@ -1,76 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Val_Util; use System.Val_Util; - -package body System.Val_Char is - - --------------------- - -- Value_Character -- - --------------------- - - function Value_Character (Str : String) return Character is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - begin - Normalize_String (S, F, L); - - -- Accept any single character enclosed in quotes - - if L - F = 2 and then S (F) = ''' and then S (L) = ''' then - return Character'Val (Character'Pos (S (F + 1))); - - -- Check control character cases - - else - for C in Character'Val (16#00#) .. Character'Val (16#1F#) loop - if S (F .. L) = Character'Image (C) then - return C; - end if; - end loop; - - for C in Character'Val (16#7F#) .. Character'Val (16#9F#) loop - if S (F .. L) = Character'Image (C) then - return C; - end if; - end loop; - - if S (F .. L) = "SOFT_HYPHEN" then - return Character'Val (16#AD#); - end if; - - Bad_Value (Str); - end if; - end Value_Character; - -end System.Val_Char; diff --git a/gcc/ada/s-valcha.ads b/gcc/ada/s-valcha.ads deleted file mode 100644 index 193f9bd..0000000 --- a/gcc/ada/s-valcha.ads +++ /dev/null @@ -1,38 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System.Val_Char is - pragma Pure; - - function Value_Character (Str : String) return Character; - -- Computes Character'Value (Str) - -end System.Val_Char; diff --git a/gcc/ada/s-valdec.adb b/gcc/ada/s-valdec.adb deleted file mode 100644 index ecd7682..0000000 --- a/gcc/ada/s-valdec.adb +++ /dev/null @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ D E C -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Val_Real; use System.Val_Real; - -package body System.Val_Dec is - - ------------------ - -- Scan_Decimal -- - ------------------ - - -- For decimal types where Size < Integer'Size, it is fine to use - -- the floating-point circuit, since it certainly has sufficient - -- precision for any reasonable hardware, and we just don't support - -- things on junk hardware. - - function Scan_Decimal - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Scale : Integer) return Integer - is - Val : Long_Long_Float; - begin - Val := Scan_Real (Str, Ptr, Max); - return Integer (Val * 10.0 ** Scale); - end Scan_Decimal; - - ------------------- - -- Value_Decimal -- - ------------------- - - -- Again, we use the real circuit for this purpose - - function Value_Decimal (Str : String; Scale : Integer) return Integer is - begin - return Integer (Value_Real (Str) * 10.0 ** Scale); - end Value_Decimal; - -end System.Val_Dec; diff --git a/gcc/ada/s-valdec.ads b/gcc/ada/s-valdec.ads deleted file mode 100644 index 71c9812..0000000 --- a/gcc/ada/s-valdec.ads +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ D E C -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines for scanning decimal values where the size --- of the type is no greater than Standard.Integer'Size, for use in Text_IO. --- Decimal_IO, and the Value attribute for such decimal types. - -package System.Val_Dec is - pragma Pure; - - function Scan_Decimal - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Scale : Integer) return Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- real literal according to the syntax described in (RM 3.5(43)). The - -- substring scanned extends no further than Str (Max). There are three - -- cases for the return: - -- - -- If a valid real literal is found after scanning past any initial spaces, - -- then Ptr.all is updated past the last character of the literal (but - -- trailing spaces are not scanned out). The value returned is the value - -- Integer'Integer_Value (decimal-literal-value), using the given Scale - -- to determine this value. - -- - -- If no valid real literal is found, then Ptr.all points either to an - -- initial non-digit character, or to Max + 1 if the field is all spaces - -- and the exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the - -- pointer positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - - function Value_Decimal (Str : String; Scale : Integer) return Integer; - -- Used in computing X'Value (Str) where X is a decimal fixed-point type - -- whose size does not exceed Standard.Integer'Size. Str is the string - -- argument of the attribute. Constraint_Error is raised if the string - -- is malformed or if the value is out of range of Integer (not the - -- range of the fixed-point type, that check must be done by the caller. - -- Otherwise the value returned is the value Integer'Integer_Value - -- (decimal-literal-value), using Scale to determine this value. - -end System.Val_Dec; diff --git a/gcc/ada/s-valenu.adb b/gcc/ada/s-valenu.adb deleted file mode 100644 index 0de1a95..0000000 --- a/gcc/ada/s-valenu.adb +++ /dev/null @@ -1,155 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ E N U M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -with System.Val_Util; use System.Val_Util; - -package body System.Val_Enum is - - ------------------------- - -- Value_Enumeration_8 -- - ------------------------- - - function Value_Enumeration_8 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural - is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - Normalize_String (S, F, L); - - for J in 0 .. Num loop - if Names - (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1) = S (F .. L) - then - return J; - end if; - end loop; - - Bad_Value (Str); - end Value_Enumeration_8; - - -------------------------- - -- Value_Enumeration_16 -- - -------------------------- - - function Value_Enumeration_16 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural - is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - Normalize_String (S, F, L); - - for J in 0 .. Num loop - if Names - (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1) = S (F .. L) - then - return J; - end if; - end loop; - - Bad_Value (Str); - end Value_Enumeration_16; - - -------------------------- - -- Value_Enumeration_32 -- - -------------------------- - - function Value_Enumeration_32 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural - is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - Normalize_String (S, F, L); - - for J in 0 .. Num loop - if Names - (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1) = S (F .. L) - then - return J; - end if; - end loop; - - Bad_Value (Str); - end Value_Enumeration_32; - -end System.Val_Enum; diff --git a/gcc/ada/s-valenu.ads b/gcc/ada/s-valenu.ads deleted file mode 100644 index fa5d205..0000000 --- a/gcc/ada/s-valenu.ads +++ /dev/null @@ -1,80 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ E N U M -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 compute the Value attribute for enumeration types --- other than those in packages Standard and System. See unit Exp_Imgv for --- details of the format of constructed image tables. - -package System.Val_Enum is - pragma Pure; - - function Value_Enumeration_8 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural; - -- Used to compute Enum'Value (Str) where Enum is some enumeration type - -- other than those defined in package Standard. Names is a string with - -- a lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address - -- of an array of type array (0 .. N) of Natural_8, where N is the - -- number of enumeration literals in the type. The Indexes values are - -- the starting subscript of each enumeration literal, indexed by Pos - -- values, with an extra entry at the end containing Names'Length + 1. - -- The parameter Num is the value N - 1 (i.e. Enum'Pos (Enum'Last)). - -- The reason that Indexes is passed by address is that the actual type - -- is created on the fly by the expander. - -- - -- Str is the argument of the attribute function, and may have leading - -- and trailing spaces, and letters can be upper or lower case or mixed. - -- If the image is found in Names, then the corresponding Pos value is - -- returned. If not, Constraint_Error is raised. - - function Value_Enumeration_16 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural; - -- Identical to Value_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_16 for the Indexes table. - - function Value_Enumeration_32 - (Names : String; - Indexes : System.Address; - Num : Natural; - Str : String) - return Natural; - -- Identical to Value_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Val_Enum; diff --git a/gcc/ada/s-valint.adb b/gcc/ada/s-valint.adb deleted file mode 100644 index 1181297..0000000 --- a/gcc/ada/s-valint.adb +++ /dev/null @@ -1,118 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ I N T -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Uns; use System.Val_Uns; -with System.Val_Util; use System.Val_Util; - -package body System.Val_Int is - - ------------------ - -- Scan_Integer -- - ------------------ - - function Scan_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Integer - is - Uval : Unsigned; - -- Unsigned result - - Minus : Boolean := False; - -- Set to True if minus sign is present, otherwise to False - - Start : Positive; - -- Saves location of first non-blank (not used in this case) - - begin - Scan_Sign (Str, Ptr, Max, Minus, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - Uval := Scan_Raw_Unsigned (Str, Ptr, Max); - - -- Deal with overflow cases, and also with maximum negative number - - if Uval > Unsigned (Integer'Last) then - if Minus and then Uval = Unsigned (-(Integer'First)) then - return Integer'First; - else - Bad_Value (Str); - end if; - - -- Negative values - - elsif Minus then - return -(Integer (Uval)); - - -- Positive values - - else - return Integer (Uval); - end if; - end Scan_Integer; - - ------------------- - -- Value_Integer -- - ------------------- - - function Value_Integer (Str : String) return Integer is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Integer (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Integer; - P : aliased Integer := Str'First; - begin - V := Scan_Integer (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Integer; - -end System.Val_Int; diff --git a/gcc/ada/s-valint.ads b/gcc/ada/s-valint.ads deleted file mode 100644 index 08b229b..0000000 --- a/gcc/ada/s-valint.ads +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . V A L _ I N T -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines for scanning signed Integer values for use --- in Text_IO.Integer_IO, and the Value attribute. - -package System.Val_Int is - pragma Pure; - - function Scan_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). There are three cases for the - -- return: - -- - -- If a valid integer is found after scanning past any initial spaces, then - -- Ptr.all is updated past the last character of the integer (but trailing - -- spaces are not scanned out). - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - - function Value_Integer (Str : String) return Integer; - -- Used in computing X'Value (Str) where X is a signed integer type whose - -- base range does not exceed the base range of Integer. Str is the string - -- argument of the attribute. Constraint_Error is raised if the string is - -- malformed, or if the value is out of range. - -end System.Val_Int; diff --git a/gcc/ada/s-vallld.adb b/gcc/ada/s-vallld.adb deleted file mode 100644 index 0fef8a4..0000000 --- a/gcc/ada/s-vallld.adb +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ L L D -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Val_Real; use System.Val_Real; - -package body System.Val_LLD is - - ---------------------------- - -- Scan_Long_Long_Decimal -- - ---------------------------- - - -- We use the floating-point circuit for now, this will be OK on a PC, - -- but definitely does NOT have the required precision if the longest - -- float type is IEEE double. This must be fixed in the future ??? - - function Scan_Long_Long_Decimal - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Scale : Integer) return Long_Long_Integer - is - Val : Long_Long_Float; - begin - Val := Scan_Real (Str, Ptr, Max); - return Long_Long_Integer (Val * 10.0 ** Scale); - end Scan_Long_Long_Decimal; - - ----------------------------- - -- Value_Long_Long_Decimal -- - ----------------------------- - - -- Again we cheat and use floating-point ??? - - function Value_Long_Long_Decimal - (Str : String; - Scale : Integer) return Long_Long_Integer - is - begin - return Long_Long_Integer (Value_Real (Str) * 10.0 ** Scale); - end Value_Long_Long_Decimal; - -end System.Val_LLD; diff --git a/gcc/ada/s-vallld.ads b/gcc/ada/s-vallld.ads deleted file mode 100644 index c4d089b..0000000 --- a/gcc/ada/s-vallld.ads +++ /dev/null @@ -1,81 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ L L D -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines for scanning decimal values where the size --- of the type is greater than Standard.Integer'Size, for use in Text_IO. --- Decimal_IO, and the Value attribute for such decimal types. - -package System.Val_LLD is - pragma Pure; - - function Scan_Long_Long_Decimal - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Scale : Integer) return Long_Long_Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- real literal according to the syntax described in (RM 3.5(43)). The - -- substring scanned extends no further than Str (Max). There are three - -- cases for the return: - -- - -- If a valid real literal is found after scanning past any initial spaces, - -- then Ptr.all is updated past the last character of the literal (but - -- trailing spaces are not scanned out). The value returned is the value - -- Long_Long_Integer'Integer_Value (decimal-literal-value), using the given - -- Scale to determine this value. - -- - -- If no valid real literal is found, then Ptr.all points either to an - -- initial non-digit character, or to Max + 1 if the field is all spaces - -- and the exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the - -- pointer positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - - function Value_Long_Long_Decimal - (Str : String; - Scale : Integer) return Long_Long_Integer; - -- Used in computing X'Value (Str) where X is a decimal types whose size - -- exceeds Standard.Integer'Size. Str is the string argument of the - -- attribute. Constraint_Error is raised if the string is malformed - -- or if the value is out of range, otherwise the value returned is the - -- value Long_Long_Integer'Integer_Value (decimal-literal-value), using - -- the given Scale to determine this value. - -end System.Val_LLD; diff --git a/gcc/ada/s-vallli.adb b/gcc/ada/s-vallli.adb deleted file mode 100644 index bf0e15d..0000000 --- a/gcc/ada/s-vallli.adb +++ /dev/null @@ -1,120 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ L L I -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_LLU; use System.Val_LLU; -with System.Val_Util; use System.Val_Util; - -package body System.Val_LLI is - - ---------------------------- - -- Scan_Long_Long_Integer -- - ---------------------------- - - function Scan_Long_Long_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Integer - is - Uval : Long_Long_Unsigned; - -- Unsigned result - - Minus : Boolean := False; - -- Set to True if minus sign is present, otherwise to False - - Start : Positive; - -- Saves location of first non-blank - - begin - Scan_Sign (Str, Ptr, Max, Minus, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - Uval := Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); - - -- Deal with overflow cases, and also with maximum negative number - - if Uval > Long_Long_Unsigned (Long_Long_Integer'Last) then - if Minus - and then Uval = Long_Long_Unsigned (-(Long_Long_Integer'First)) - then - return Long_Long_Integer'First; - else - Bad_Value (Str); - end if; - - -- Negative values - - elsif Minus then - return -(Long_Long_Integer (Uval)); - - -- Positive values - - else - return Long_Long_Integer (Uval); - end if; - end Scan_Long_Long_Integer; - - ----------------------------- - -- Value_Long_Long_Integer -- - ----------------------------- - - function Value_Long_Long_Integer (Str : String) return Long_Long_Integer is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Long_Long_Integer (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Long_Long_Integer; - P : aliased Integer := Str'First; - begin - V := Scan_Long_Long_Integer (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Long_Long_Integer; - -end System.Val_LLI; diff --git a/gcc/ada/s-vallli.ads b/gcc/ada/s-vallli.ads deleted file mode 100644 index c1aceb3..0000000 --- a/gcc/ada/s-vallli.ads +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines for scanning signed Long_Long_Integer --- values for use in Text_IO.Integer_IO, and the Value attribute. - -package System.Val_LLI is - pragma Pure; - - function Scan_Long_Long_Integer - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Integer; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). There are three cases for the - -- return: - -- - -- If a valid integer is found after scanning past any initial spaces, then - -- Ptr.all is updated past the last character of the integer (but trailing - -- spaces are not scanned out). - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - - function Value_Long_Long_Integer (Str : String) return Long_Long_Integer; - -- Used in computing X'Value (Str) where X is a signed integer type whose - -- base range exceeds the base range of Integer. Str is the string argument - -- of the attribute. Constraint_Error is raised if the string is malformed, - -- or if the value is out of range. - -end System.Val_LLI; diff --git a/gcc/ada/s-valllu.adb b/gcc/ada/s-valllu.adb deleted file mode 100644 index 44dbff7..0000000 --- a/gcc/ada/s-valllu.adb +++ /dev/null @@ -1,330 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ L L U -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Util; use System.Val_Util; - -package body System.Val_LLU is - - --------------------------------- - -- Scan_Raw_Long_Long_Unsigned -- - --------------------------------- - - function Scan_Raw_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Unsigned - is - P : Integer; - -- Local copy of the pointer - - Uval : Long_Long_Unsigned; - -- Accumulated unsigned integer result - - Expon : Integer; - -- Exponent value - - Overflow : Boolean := False; - -- Set True if overflow is detected at any point - - Base_Char : Character; - -- Base character (# or :) in based case - - Base : Long_Long_Unsigned := 10; - -- Base value (reset in based case) - - Digit : Long_Long_Unsigned; - -- Digit value - - begin - -- We do not tolerate strings with Str'Last = Positive'Last - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - P := Ptr.all; - Uval := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Scan out digits of what is either the number or the base. - -- In either case, we are definitely scanning out in base 10. - - declare - Umax : constant := (Long_Long_Unsigned'Last - 9) / 10; - -- Max value which cannot overflow on accumulating next digit - - Umax10 : constant := Long_Long_Unsigned'Last / 10; - -- Numbers bigger than Umax10 overflow if multiplied by 10 - - begin - -- Loop through decimal digits - loop - exit when P > Max; - - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - -- Non-digit encountered - - if Digit > 9 then - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit; - end if; - - -- Accumulate result, checking for overflow - - else - if Uval <= Umax then - Uval := 10 * Uval + Digit; - - elsif Uval > Umax10 then - Overflow := True; - - else - Uval := 10 * Uval + Digit; - - if Uval < Umax10 then - Overflow := True; - end if; - end if; - - P := P + 1; - end if; - end loop; - end; - - Ptr.all := P; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - if P < Max and then (Str (P) = '#' or else Str (P) = ':') then - Base_Char := Str (P); - P := P + 1; - Base := Uval; - Uval := 0; - - -- Check base value. Overflow is set True if we find a bad base, or - -- a digit that is out of range of the base. That way, we scan out - -- the numeral that is still syntactically correct, though illegal. - -- We use a safe base of 16 for this scan, to avoid zero divide. - - if Base not in 2 .. 16 then - Overflow := True; - Base := 16; - end if; - - -- Scan out based integer - - declare - Umax : constant Long_Long_Unsigned := - (Long_Long_Unsigned'Last - Base + 1) / Base; - -- Max value which cannot overflow on accumulating next digit - - UmaxB : constant Long_Long_Unsigned := - Long_Long_Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - -- Loop to scan out based integer value - - loop - -- We require a digit at this stage - - if Str (P) in '0' .. '9' then - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - elsif Str (P) in 'A' .. 'F' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('A') - 10); - - elsif Str (P) in 'a' .. 'f' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('a') - 10); - - -- If we don't have a digit, then this is not a based number - -- after all, so we use the value we scanned out as the base - -- (now in Base), and the pointer to the base character was - -- already stored in Ptr.all. - - else - Uval := Base; - exit; - end if; - - -- If digit is too large, just signal overflow and continue. - -- The idea here is to keep scanning as long as the input is - -- syntactically valid, even if we have detected overflow - - if Digit >= Base then - Overflow := True; - - -- Here we accumulate the value, checking overflow - - elsif Uval <= Umax then - Uval := Base * Uval + Digit; - - elsif Uval > UmaxB then - Overflow := True; - - else - Uval := Base * Uval + Digit; - - if Uval < UmaxB then - Overflow := True; - end if; - end if; - - -- If at end of string with no base char, not a based number - -- but we signal Constraint_Error and set the pointer past - -- the end of the field, since this is what the ACVC tests - -- seem to require, see CE3704N, line 204. - - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - - -- If terminating base character, we are done with loop - - if Str (P) = Base_Char then - Ptr.all := P + 1; - exit; - - -- Deal with underscore - - elsif Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, True); - end if; - - end loop; - end; - end if; - - -- Come here with scanned unsigned value in Uval. The only remaining - -- required step is to deal with exponent if one is present. - - Expon := Scan_Exponent (Str, Ptr, Max); - - if Expon /= 0 and then Uval /= 0 then - - -- For non-zero value, scale by exponent value. No need to do this - -- efficiently, since use of exponent in integer literals is rare, - -- and in any case the exponent cannot be very large. - - declare - UmaxB : constant Long_Long_Unsigned := - Long_Long_Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - for J in 1 .. Expon loop - if Uval > UmaxB then - Overflow := True; - exit; - end if; - - Uval := Uval * Base; - end loop; - end; - end if; - - -- Return result, dealing with sign and overflow - - if Overflow then - Bad_Value (Str); - else - return Uval; - end if; - end Scan_Raw_Long_Long_Unsigned; - - ----------------------------- - -- Scan_Long_Long_Unsigned -- - ----------------------------- - - function Scan_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Unsigned - is - Start : Positive; - -- Save location of first non-blank character - - begin - Scan_Plus_Sign (Str, Ptr, Max, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - raise Constraint_Error; - end if; - - return Scan_Raw_Long_Long_Unsigned (Str, Ptr, Max); - end Scan_Long_Long_Unsigned; - - ------------------------------ - -- Value_Long_Long_Unsigned -- - ------------------------------ - - function Value_Long_Long_Unsigned - (Str : String) return Long_Long_Unsigned - is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Long_Long_Unsigned (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Long_Long_Unsigned; - P : aliased Integer := Str'First; - begin - V := Scan_Long_Long_Unsigned (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Long_Long_Unsigned; - -end System.Val_LLU; diff --git a/gcc/ada/s-valllu.ads b/gcc/ada/s-valllu.ads deleted file mode 100644 index 216ce21..0000000 --- a/gcc/ada/s-valllu.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines for scanning modular Long_Long_Unsigned --- values for use in Text_IO.Modular_IO, and the Value attribute. - -with System.Unsigned_Types; - -package System.Val_LLU is - pragma Pure; - - function Scan_Raw_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). Note: this does not scan - -- leading or trailing blanks, nor leading sign. - -- - -- There are three cases for the return: - -- - -- If a valid integer is found, then Ptr.all is updated past the last - -- character of the integer. - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_IO.Get. Note that the rules as stated in the RM would - -- seem to imply that for a case like: - -- - -- 8#12345670009# - -- - -- the pointer should be left at the first # having scanned out the longest - -- valid integer literal (8), but in fact in this case the pointer points - -- past the final # and Constraint_Error is raised. This is the behavior - -- expected for Text_IO and enforced by the ACATS tests. - -- - -- If a based literal is malformed in that a character other than a valid - -- hexadecimal digit is encountered during scanning out the digits after - -- the # (this includes the case of using the wrong terminator, : instead - -- of # or vice versa) there are two cases. If all the digits before the - -- non-digit are in range of the base, as in - -- - -- 8#100x00# - -- 8#100: - -- - -- then in this case, the "base" value before the initial # is returned as - -- the result, and the pointer points to the initial # character on return. - -- - -- If an out of range digit has been detected before the invalid character, - -- as in: - -- - -- 8#900x00# - -- 8#900: - -- - -- then the pointer is also left at the initial # character, but constraint - -- error is raised reflecting the encounter of an out of range digit. - -- - -- Finally if we have an unterminated fixed-point constant where the final - -- # or : character is missing, Constraint_Error is raised and the pointer - -- is left pointing past the last digit, as in: - -- - -- 8#22 - -- - -- This string results in a Constraint_Error with the pointer pointing - -- past the second 2. - -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- - -- Note: this routine should not be called with Str'Last = Positive'Last. - -- If this occurs Program_Error is raised with a message noting that this - -- case is not supported. Most such cases are eliminated by the caller. - - function Scan_Long_Long_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Long_Long_Unsigned; - -- Same as Scan_Raw_Long_Long_Unsigned, except scans optional leading - -- blanks, and an optional leading plus sign. - -- - -- Note: if a minus sign is present, Constraint_Error will be raised. - -- Note: trailing blanks are not scanned. - - function Value_Long_Long_Unsigned - (Str : String) return System.Unsigned_Types.Long_Long_Unsigned; - -- Used in computing X'Value (Str) where X is a modular integer type whose - -- modulus exceeds the range of System.Unsigned_Types.Unsigned. Str is the - -- string argument of the attribute. Constraint_Error is raised if the - -- string is malformed, or if the value is out of range. - -end System.Val_LLU; diff --git a/gcc/ada/s-valrea.adb b/gcc/ada/s-valrea.adb deleted file mode 100644 index 7284e60..0000000 --- a/gcc/ada/s-valrea.adb +++ /dev/null @@ -1,415 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ R E A L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Powten_Table; use System.Powten_Table; -with System.Val_Util; use System.Val_Util; -with System.Float_Control; - -package body System.Val_Real is - - --------------- - -- Scan_Real -- - --------------- - - function Scan_Real - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Float - is - P : Integer; - -- Local copy of string pointer - - Base : Long_Long_Float; - -- Base value - - Uval : Long_Long_Float; - -- Accumulated float result - - subtype Digs is Character range '0' .. '9'; - -- Used to check for decimal digit - - Scale : Integer := 0; - -- Power of Base to multiply result by - - Start : Positive; - -- Position of starting non-blank character - - Minus : Boolean; - -- Set to True if minus sign is present, otherwise to False - - Bad_Base : Boolean := False; - -- Set True if Base out of range or if out of range digit - - After_Point : Natural := 0; - -- Set to 1 after the point - - Num_Saved_Zeroes : Natural := 0; - -- This counts zeroes after the decimal point. A non-zero value means - -- that this number of previously scanned digits are zero. If the end - -- of the number is reached, these zeroes are simply discarded, which - -- ensures that trailing zeroes after the point never affect the value - -- (which might otherwise happen as a result of rounding). With this - -- processing in place, we can ensure that, for example, we get the - -- same exact result from 1.0E+49 and 1.0000000E+49. This is not - -- necessarily required in a case like this where the result is not - -- a machine number, but it is certainly a desirable behavior. - - procedure Scanf; - -- Scans integer literal value starting at current character position. - -- For each digit encountered, Uval is multiplied by 10.0, and the new - -- digit value is incremented. In addition Scale is decremented for each - -- digit encountered if we are after the point (After_Point = 1). The - -- longest possible syntactically valid numeral is scanned out, and on - -- return P points past the last character. On entry, the current - -- character is known to be a digit, so a numeral is definitely present. - - ----------- - -- Scanf -- - ----------- - - procedure Scanf is - Digit : Natural; - - begin - loop - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Save up trailing zeroes after the decimal point - - if Digit = 0 and then After_Point = 1 then - Num_Saved_Zeroes := Num_Saved_Zeroes + 1; - - -- Here for a non-zero digit - - else - -- First deal with any previously saved zeroes - - if Num_Saved_Zeroes /= 0 then - while Num_Saved_Zeroes > Maxpow loop - Uval := Uval * Powten (Maxpow); - Num_Saved_Zeroes := Num_Saved_Zeroes - Maxpow; - Scale := Scale - Maxpow; - end loop; - - Uval := Uval * Powten (Num_Saved_Zeroes); - Scale := Scale - Num_Saved_Zeroes; - - Num_Saved_Zeroes := 0; - end if; - - -- Accumulate new digit - - Uval := Uval * 10.0 + Long_Long_Float (Digit); - Scale := Scale - After_Point; - end if; - - -- Done if end of input field - - if P > Max then - return; - - -- Check next character - - elsif Str (P) not in Digs then - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - return; - end if; - end if; - end loop; - end Scanf; - - -- Start of processing for System.Scan_Real - - begin - -- We do not tolerate strings with Str'Last = Positive'Last - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - -- We call the floating-point processor reset routine so that we can - -- be sure the floating-point processor is properly set for conversion - -- calls. This is notably need on Windows, where calls to the operating - -- system randomly reset the processor into 64-bit mode. - - System.Float_Control.Reset; - - Scan_Sign (Str, Ptr, Max, Minus, Start); - P := Ptr.all; - Ptr.all := Start; - - -- If digit, scan numeral before point - - if Str (P) in Digs then - Uval := 0.0; - Scanf; - - -- Initial point, allowed only if followed by digit (RM 3.5(47)) - - elsif Str (P) = '.' - and then P < Max - and then Str (P + 1) in Digs - then - Uval := 0.0; - - -- Any other initial character is an error - - else - Bad_Value (Str); - end if; - - -- Deal with based case. We reognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - if P < Max and then (Str (P) = '#' or else Str (P) = ':') then - declare - Base_Char : constant Character := Str (P); - Digit : Natural; - Fdigit : Long_Long_Float; - - begin - -- Set bad base if out of range, and use safe base of 16.0, - -- to guard against division by zero in the loop below. - - if Uval < 2.0 or else Uval > 16.0 then - Bad_Base := True; - Uval := 16.0; - end if; - - Base := Uval; - Uval := 0.0; - P := P + 1; - - -- Special check to allow initial point (RM 3.5(49)) - - if Str (P) = '.' then - After_Point := 1; - P := P + 1; - end if; - - -- Loop to scan digits of based number. On entry to the loop we - -- must have a valid digit. If we don't, then we have an illegal - -- floating-point value, and we raise Constraint_Error, note that - -- Ptr at this stage was reset to the proper (Start) value. - - loop - if P > Max then - Bad_Value (Str); - - elsif Str (P) in Digs then - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - elsif Str (P) in 'A' .. 'F' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('A') - 10); - - elsif Str (P) in 'a' .. 'f' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('a') - 10); - - else - Bad_Value (Str); - end if; - - -- Save up trailing zeroes after the decimal point - - if Digit = 0 and then After_Point = 1 then - Num_Saved_Zeroes := Num_Saved_Zeroes + 1; - - -- Here for a non-zero digit - - else - -- First deal with any previously saved zeroes - - if Num_Saved_Zeroes /= 0 then - Uval := Uval * Base ** Num_Saved_Zeroes; - Scale := Scale - Num_Saved_Zeroes; - Num_Saved_Zeroes := 0; - end if; - - -- Now accumulate the new digit - - Fdigit := Long_Long_Float (Digit); - - if Fdigit >= Base then - Bad_Base := True; - else - Scale := Scale - After_Point; - Uval := Uval * Base + Fdigit; - end if; - end if; - - P := P + 1; - - if P > Max then - Bad_Value (Str); - - elsif Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, True); - - else - -- Skip past period after digit. Note that the processing - -- here will permit either a digit after the period, or the - -- terminating base character, as allowed in (RM 3.5(48)) - - if Str (P) = '.' and then After_Point = 0 then - P := P + 1; - After_Point := 1; - - if P > Max then - Bad_Value (Str); - end if; - end if; - - exit when Str (P) = Base_Char; - end if; - end loop; - - -- Based number successfully scanned out (point was found) - - Ptr.all := P + 1; - end; - - -- Non-based case, check for being at decimal point now. Note that - -- in Ada 95, we do not insist on a decimal point being present - - else - Base := 10.0; - After_Point := 1; - - if P <= Max and then Str (P) = '.' then - P := P + 1; - - -- Scan digits after point if any are present (RM 3.5(46)) - - if P <= Max and then Str (P) in Digs then - Scanf; - end if; - end if; - - Ptr.all := P; - end if; - - -- At this point, we have Uval containing the digits of the value as - -- an integer, and Scale indicates the negative of the number of digits - -- after the point. Base contains the base value (an integral value in - -- the range 2.0 .. 16.0). Test for exponent, must be at least one - -- character after the E for the exponent to be valid. - - Scale := Scale + Scan_Exponent (Str, Ptr, Max, Real => True); - - -- At this point the exponent has been scanned if one is present and - -- Scale is adjusted to include the exponent value. Uval contains the - -- the integral value which is to be multiplied by Base ** Scale. - - -- If base is not 10, use exponentiation for scaling - - if Base /= 10.0 then - Uval := Uval * Base ** Scale; - - -- For base 10, use power of ten table, repeatedly if necessary - - elsif Scale > 0 then - while Scale > Maxpow loop - Uval := Uval * Powten (Maxpow); - Scale := Scale - Maxpow; - end loop; - - -- Note that we still know that Scale > 0, since the loop - -- above leaves Scale in the range 1 .. Maxpow. - - Uval := Uval * Powten (Scale); - - elsif Scale < 0 then - while (-Scale) > Maxpow loop - Uval := Uval / Powten (Maxpow); - Scale := Scale + Maxpow; - end loop; - - -- Note that we still know that Scale < 0, since the loop - -- above leaves Scale in the range -Maxpow .. -1. - - Uval := Uval / Powten (-Scale); - end if; - - -- Here is where we check for a bad based number - - if Bad_Base then - Bad_Value (Str); - - -- If OK, then deal with initial minus sign, note that this processing - -- is done even if Uval is zero, so that -0.0 is correctly interpreted. - - else - if Minus then - return -Uval; - else - return Uval; - end if; - end if; - end Scan_Real; - - ---------------- - -- Value_Real -- - ---------------- - - function Value_Real (Str : String) return Long_Long_Float is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Real (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Long_Long_Float; - P : aliased Integer := Str'First; - begin - V := Scan_Real (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Real; - -end System.Val_Real; diff --git a/gcc/ada/s-valrea.ads b/gcc/ada/s-valrea.ads deleted file mode 100644 index 8d3603f..0000000 --- a/gcc/ada/s-valrea.ads +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ R E A L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package System.Val_Real is - pragma Pure; - - function Scan_Real - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Long_Long_Float; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- real literal according to the syntax described in (RM 3.5(43)). The - -- substring scanned extends no further than Str (Max). There are three - -- cases for the return: - -- - -- If a valid real is found after scanning past any initial spaces, then - -- Ptr.all is updated past the last character of the real (but trailing - -- spaces are not scanned out). - -- - -- If no valid real is found, then Ptr.all points either to an initial - -- non-blank character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid real is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the real literal, - -- and Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the - -- pointer positioned in Text_Io.Get - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- - -- Note: this routine should not be called with Str'Last = Positive'Last. - -- If this occurs Program_Error is raised with a message noting that this - -- case is not supported. Most such cases are eliminated by the caller. - - function Value_Real (Str : String) return Long_Long_Float; - -- Used in computing X'Value (Str) where X is a floating-point type or an - -- ordinary fixed-point type. Str is the string argument of the attribute. - -- Constraint_Error is raised if the string is malformed, or if the value - -- out of range of Long_Long_Float. - -end System.Val_Real; diff --git a/gcc/ada/s-valuns.adb b/gcc/ada/s-valuns.adb deleted file mode 100644 index 009d0bc..0000000 --- a/gcc/ada/s-valuns.adb +++ /dev/null @@ -1,325 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ U N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; -with System.Val_Util; use System.Val_Util; - -package body System.Val_Uns is - - ----------------------- - -- Scan_Raw_Unsigned -- - ----------------------- - - function Scan_Raw_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Unsigned - is - P : Integer; - -- Local copy of the pointer - - Uval : Unsigned; - -- Accumulated unsigned integer result - - Expon : Integer; - -- Exponent value - - Overflow : Boolean := False; - -- Set True if overflow is detected at any point - - Base_Char : Character; - -- Base character (# or :) in based case - - Base : Unsigned := 10; - -- Base value (reset in based case) - - Digit : Unsigned; - -- Digit value - - begin - -- We do not tolerate strings with Str'Last = Positive'Last - - if Str'Last = Positive'Last then - raise Program_Error with - "string upper bound is Positive'Last, not supported"; - end if; - - P := Ptr.all; - Uval := Character'Pos (Str (P)) - Character'Pos ('0'); - P := P + 1; - - -- Scan out digits of what is either the number or the base. - -- In either case, we are definitely scanning out in base 10. - - declare - Umax : constant := (Unsigned'Last - 9) / 10; - -- Max value which cannot overflow on accumulating next digit - - Umax10 : constant := Unsigned'Last / 10; - -- Numbers bigger than Umax10 overflow if multiplied by 10 - - begin - -- Loop through decimal digits - loop - exit when P > Max; - - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - -- Non-digit encountered - - if Digit > 9 then - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit; - end if; - - -- Accumulate result, checking for overflow - - else - if Uval <= Umax then - Uval := 10 * Uval + Digit; - - elsif Uval > Umax10 then - Overflow := True; - - else - Uval := 10 * Uval + Digit; - - if Uval < Umax10 then - Overflow := True; - end if; - end if; - - P := P + 1; - end if; - end loop; - end; - - Ptr.all := P; - - -- Deal with based case. We recognize either the standard '#' or the - -- allowed alternative replacement ':' (see RM J.2(3)). - - if P < Max and then (Str (P) = '#' or else Str (P) = ':') then - Base_Char := Str (P); - P := P + 1; - Base := Uval; - Uval := 0; - - -- Check base value. Overflow is set True if we find a bad base, or - -- a digit that is out of range of the base. That way, we scan out - -- the numeral that is still syntactically correct, though illegal. - -- We use a safe base of 16 for this scan, to avoid zero divide. - - if Base not in 2 .. 16 then - Overflow := True; - Base := 16; - end if; - - -- Scan out based integer - - declare - Umax : constant Unsigned := (Unsigned'Last - Base + 1) / Base; - -- Max value which cannot overflow on accumulating next digit - - UmaxB : constant Unsigned := Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - -- Loop to scan out based integer value - - loop - -- We require a digit at this stage - - if Str (P) in '0' .. '9' then - Digit := Character'Pos (Str (P)) - Character'Pos ('0'); - - elsif Str (P) in 'A' .. 'F' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('A') - 10); - - elsif Str (P) in 'a' .. 'f' then - Digit := - Character'Pos (Str (P)) - (Character'Pos ('a') - 10); - - -- If we don't have a digit, then this is not a based number - -- after all, so we use the value we scanned out as the base - -- (now in Base), and the pointer to the base character was - -- already stored in Ptr.all. - - else - Uval := Base; - exit; - end if; - - -- If digit is too large, just signal overflow and continue. - -- The idea here is to keep scanning as long as the input is - -- syntactically valid, even if we have detected overflow - - if Digit >= Base then - Overflow := True; - - -- Here we accumulate the value, checking overflow - - elsif Uval <= Umax then - Uval := Base * Uval + Digit; - - elsif Uval > UmaxB then - Overflow := True; - - else - Uval := Base * Uval + Digit; - - if Uval < UmaxB then - Overflow := True; - end if; - end if; - - -- If at end of string with no base char, not a based number - -- but we signal Constraint_Error and set the pointer past - -- the end of the field, since this is what the ACVC tests - -- seem to require, see CE3704N, line 204. - - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - - -- If terminating base character, we are done with loop - - if Str (P) = Base_Char then - Ptr.all := P + 1; - exit; - - -- Deal with underscore - - elsif Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, True); - end if; - - end loop; - end; - end if; - - -- Come here with scanned unsigned value in Uval. The only remaining - -- required step is to deal with exponent if one is present. - - Expon := Scan_Exponent (Str, Ptr, Max); - - if Expon /= 0 and then Uval /= 0 then - - -- For non-zero value, scale by exponent value. No need to do this - -- efficiently, since use of exponent in integer literals is rare, - -- and in any case the exponent cannot be very large. - - declare - UmaxB : constant Unsigned := Unsigned'Last / Base; - -- Numbers bigger than UmaxB overflow if multiplied by base - - begin - for J in 1 .. Expon loop - if Uval > UmaxB then - Overflow := True; - exit; - end if; - - Uval := Uval * Base; - end loop; - end; - end if; - - -- Return result, dealing with sign and overflow - - if Overflow then - Bad_Value (Str); - else - return Uval; - end if; - end Scan_Raw_Unsigned; - - ------------------- - -- Scan_Unsigned -- - ------------------- - - function Scan_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return Unsigned - is - Start : Positive; - -- Save location of first non-blank character - - begin - Scan_Plus_Sign (Str, Ptr, Max, Start); - - if Str (Ptr.all) not in '0' .. '9' then - Ptr.all := Start; - Bad_Value (Str); - end if; - - return Scan_Raw_Unsigned (Str, Ptr, Max); - end Scan_Unsigned; - - -------------------- - -- Value_Unsigned -- - -------------------- - - function Value_Unsigned (Str : String) return Unsigned is - begin - -- We have to special case Str'Last = Positive'Last because the normal - -- circuit ends up setting P to Str'Last + 1 which is out of bounds. We - -- deal with this by converting to a subtype which fixes the bounds. - - if Str'Last = Positive'Last then - declare - subtype NT is String (1 .. Str'Length); - begin - return Value_Unsigned (NT (Str)); - end; - - -- Normal case where Str'Last < Positive'Last - - else - declare - V : Unsigned; - P : aliased Integer := Str'First; - begin - V := Scan_Unsigned (Str, P'Access, Str'Last); - Scan_Trailing_Blanks (Str, P); - return V; - end; - end if; - end Value_Unsigned; - -end System.Val_Uns; diff --git a/gcc/ada/s-valuns.ads b/gcc/ada/s-valuns.ads deleted file mode 100644 index cdea740..0000000 --- a/gcc/ada/s-valuns.ads +++ /dev/null @@ -1,129 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ U N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines for scanning modular Unsigned --- values for use in Text_IO.Modular_IO, and the Value attribute. - -with System.Unsigned_Types; - -package System.Val_Uns is - pragma Pure; - - function Scan_Raw_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Unsigned; - -- This function scans the string starting at Str (Ptr.all) for a valid - -- integer according to the syntax described in (RM 3.5(43)). The substring - -- scanned extends no further than Str (Max). Note: this does not scan - -- leading or trailing blanks, nor leading sign. - -- - -- There are three cases for the return: - -- - -- If a valid integer is found, then Ptr.all is updated past the last - -- character of the integer. - -- - -- If no valid integer is found, then Ptr.all points either to an initial - -- non-digit character, or to Max + 1 if the field is all spaces and the - -- exception Constraint_Error is raised. - -- - -- If a syntactically valid integer is scanned, but the value is out of - -- range, or, in the based case, the base value is out of range or there - -- is an out of range digit, then Ptr.all points past the integer, and - -- Constraint_Error is raised. - -- - -- Note: these rules correspond to the requirements for leaving the pointer - -- positioned in Text_IO.Get. Note that the rules as stated in the RM would - -- seem to imply that for a case like: - -- - -- 8#12345670009# - -- - -- the pointer should be left at the first # having scanned out the longest - -- valid integer literal (8), but in fact in this case the pointer points - -- past the final # and Constraint_Error is raised. This is the behavior - -- expected for Text_IO and enforced by the ACATS tests. - -- - -- If a based literal is malformed in that a character other than a valid - -- hexadecimal digit is encountered during scanning out the digits after - -- the # (this includes the case of using the wrong terminator, : instead - -- of # or vice versa) there are two cases. If all the digits before the - -- non-digit are in range of the base, as in - -- - -- 8#100x00# - -- 8#100: - -- - -- then in this case, the "base" value before the initial # is returned as - -- the result, and the pointer points to the initial # character on return. - -- - -- If an out of range digit has been detected before the invalid character, - -- as in: - -- - -- 8#900x00# - -- 8#900: - -- - -- then the pointer is also left at the initial # character, but constraint - -- error is raised reflecting the encounter of an out of range digit. - -- - -- Finally if we have an unterminated fixed-point constant where the final - -- # or : character is missing, Constraint_Error is raised and the pointer - -- is left pointing past the last digit, as in: - -- - -- 8#22 - -- - -- This string results in a Constraint_Error with the pointer pointing - -- past the second 2. - -- - -- Note: if Str is empty, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. - -- - -- Note: this routine should not be called with Str'Last = Positive'Last. - -- If this occurs Program_Error is raised with a message noting that this - -- case is not supported. Most such cases are eliminated by the caller. - - function Scan_Unsigned - (Str : String; - Ptr : not null access Integer; - Max : Integer) return System.Unsigned_Types.Unsigned; - -- Same as Scan_Raw_Unsigned, except scans optional leading - -- blanks, and an optional leading plus sign. - -- - -- Note: if a minus sign is present, Constraint_Error will be raised. - -- Note: trailing blanks are not scanned. - - function Value_Unsigned - (Str : String) return System.Unsigned_Types.Unsigned; - -- Used in computing X'Value (Str) where X is a modular integer type whose - -- modulus does not exceed the range of System.Unsigned_Types.Unsigned. Str - -- is the string argument of the attribute. Constraint_Error is raised if - -- the string is malformed, or if the value is out of range. - -end System.Val_Uns; diff --git a/gcc/ada/s-valuti.adb b/gcc/ada/s-valuti.adb deleted file mode 100644 index 6d6b827..0000000 --- a/gcc/ada/s-valuti.adb +++ /dev/null @@ -1,334 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ U T I L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Case_Util; use System.Case_Util; - -package body System.Val_Util is - - --------------- - -- Bad_Value -- - --------------- - - procedure Bad_Value (S : String) is - begin - raise Constraint_Error with "bad input for 'Value: """ & S & '"'; - end Bad_Value; - - ---------------------- - -- Normalize_String -- - ---------------------- - - procedure Normalize_String - (S : in out String; - F, L : out Integer) - is - begin - F := S'First; - L := S'Last; - - -- Scan for leading spaces - - while F <= L and then S (F) = ' ' loop - F := F + 1; - end loop; - - -- Check for case when the string contained no characters - - if F > L then - Bad_Value (S); - end if; - - -- Scan for trailing spaces - - while S (L) = ' ' loop - L := L - 1; - end loop; - - -- Except in the case of a character literal, convert to upper case - - if S (F) /= ''' then - for J in F .. L loop - S (J) := To_Upper (S (J)); - end loop; - end if; - end Normalize_String; - - ------------------- - -- Scan_Exponent -- - ------------------- - - function Scan_Exponent - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Real : Boolean := False) return Integer - is - P : Natural := Ptr.all; - M : Boolean; - X : Integer; - - begin - if P >= Max - or else (Str (P) /= 'E' and then Str (P) /= 'e') - then - return 0; - end if; - - -- We have an E/e, see if sign follows - - P := P + 1; - - if Str (P) = '+' then - P := P + 1; - - if P > Max then - return 0; - else - M := False; - end if; - - elsif Str (P) = '-' then - P := P + 1; - - if P > Max or else not Real then - return 0; - else - M := True; - end if; - - else - M := False; - end if; - - if Str (P) not in '0' .. '9' then - return 0; - end if; - - -- Scan out the exponent value as an unsigned integer. Values larger - -- than (Integer'Last / 10) are simply considered large enough here. - -- This assumption is correct for all machines we know of (e.g. in the - -- case of 16 bit integers it allows exponents up to 3276, which is - -- large enough for the largest floating types in base 2.) - - X := 0; - - loop - if X < (Integer'Last / 10) then - X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0')); - end if; - - P := P + 1; - - exit when P > Max; - - if Str (P) = '_' then - Scan_Underscore (Str, P, Ptr, Max, False); - else - exit when Str (P) not in '0' .. '9'; - end if; - end loop; - - if M then - X := -X; - end if; - - Ptr.all := P; - return X; - end Scan_Exponent; - - -------------------- - -- Scan_Plus_Sign -- - -------------------- - - procedure Scan_Plus_Sign - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Start : out Positive) - is - P : Natural := Ptr.all; - - begin - if P > Max then - Bad_Value (Str); - end if; - - -- Scan past initial blanks - - while Str (P) = ' ' loop - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - end loop; - - Start := P; - - -- Skip past an initial plus sign - - if Str (P) = '+' then - P := P + 1; - - if P > Max then - Ptr.all := Start; - Bad_Value (Str); - end if; - end if; - - Ptr.all := P; - end Scan_Plus_Sign; - - --------------- - -- Scan_Sign -- - --------------- - - procedure Scan_Sign - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Minus : out Boolean; - Start : out Positive) - is - P : Natural := Ptr.all; - - begin - -- Deal with case of null string (all blanks). As per spec, we raise - -- constraint error, with Ptr unchanged, and thus > Max. - - if P > Max then - Bad_Value (Str); - end if; - - -- Scan past initial blanks - - while Str (P) = ' ' loop - P := P + 1; - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - end loop; - - Start := P; - - -- Remember an initial minus sign - - if Str (P) = '-' then - Minus := True; - P := P + 1; - - if P > Max then - Ptr.all := Start; - Bad_Value (Str); - end if; - - -- Skip past an initial plus sign - - elsif Str (P) = '+' then - Minus := False; - P := P + 1; - - if P > Max then - Ptr.all := Start; - Bad_Value (Str); - end if; - - else - Minus := False; - end if; - - Ptr.all := P; - end Scan_Sign; - - -------------------------- - -- Scan_Trailing_Blanks -- - -------------------------- - - procedure Scan_Trailing_Blanks (Str : String; P : Positive) is - begin - for J in P .. Str'Last loop - if Str (J) /= ' ' then - Bad_Value (Str); - end if; - end loop; - end Scan_Trailing_Blanks; - - --------------------- - -- Scan_Underscore -- - --------------------- - - procedure Scan_Underscore - (Str : String; - P : in out Natural; - Ptr : not null access Integer; - Max : Integer; - Ext : Boolean) - is - C : Character; - - begin - P := P + 1; - - -- If underscore is at the end of string, then this is an error and we - -- raise Constraint_Error, leaving the pointer past the underscore. This - -- seems a bit strange. It means e.g. that if the field is: - - -- 345_ - - -- that Constraint_Error is raised. You might think that the RM in this - -- case would scan out the 345 as a valid integer, leaving the pointer - -- at the underscore, but the ACVC suite clearly requires an error in - -- this situation (see for example CE3704M). - - if P > Max then - Ptr.all := P; - Bad_Value (Str); - end if; - - -- Similarly, if no digit follows the underscore raise an error. This - -- also catches the case of double underscore which is also an error. - - C := Str (P); - - if C in '0' .. '9' - or else (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f')) - then - return; - else - Ptr.all := P; - Bad_Value (Str); - end if; - end Scan_Underscore; - -end System.Val_Util; diff --git a/gcc/ada/s-valuti.ads b/gcc/ada/s-valuti.ads deleted file mode 100644 index a2db343..0000000 --- a/gcc/ada/s-valuti.ads +++ /dev/null @@ -1,126 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ U T I L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides some common utilities used by the s-valxxx files - -package System.Val_Util is - pragma Pure; - - procedure Bad_Value (S : String); - pragma No_Return (Bad_Value); - -- Raises constraint error with message: bad input for 'Value: "xxx" - - procedure Normalize_String - (S : in out String; - F, L : out Integer); - -- This procedure scans the string S setting F to be the index of the first - -- non-blank character of S and L to be the index of the last non-blank - -- character of S. Any lower case characters present in S will be folded to - -- their upper case equivalent except for character literals. If S consists - -- of entirely blanks then Constraint_Error is raised. - -- - -- Note: if S is the null string, F is set to S'First, L to S'Last - - procedure Scan_Sign - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Minus : out Boolean; - Start : out Positive); - -- The Str, Ptr, Max parameters are as for the scan routines (Str is the - -- string to be scanned starting at Ptr.all, and Max is the index of the - -- last character in the string). Scan_Sign first scans out any initial - -- blanks, raising Constraint_Error if the field is all blank. It then - -- checks for and skips an initial plus or minus, requiring a non-blank - -- character to follow (Constraint_Error is raised if plus or minus appears - -- at the end of the string or with a following blank). Minus is set True - -- if a minus sign was skipped, and False otherwise. On exit Ptr.all points - -- to the character after the sign, or to the first non-blank character - -- if no sign is present. Start is set to the point to the first non-blank - -- character (sign or digit after it). - -- - -- Note: if Str is null, i.e. if Max is less than Ptr, then this is a - -- special case of an all-blank string, and Ptr is unchanged, and hence - -- is greater than Max as required in this case. Constraint_Error is also - -- raised in this case. - -- - -- This routine must not be called with Str'Last = Positive'Last. There is - -- no check for this case, the caller must ensure this condition is met. - - procedure Scan_Plus_Sign - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Start : out Positive); - -- Same as Scan_Sign, but allows only plus, not minus. This is used for - -- modular types. - - function Scan_Exponent - (Str : String; - Ptr : not null access Integer; - Max : Integer; - Real : Boolean := False) return Integer; - -- Called to scan a possible exponent. Str, Ptr, Max are as described above - -- for Scan_Sign. If Ptr.all < Max and Str (Ptr.all) = 'E' or 'e', then an - -- exponent is scanned out, with the exponent value returned in Exp, and - -- Ptr.all updated to point past the exponent. If the exponent field is - -- incorrectly formed or not present, then Ptr.all is unchanged, and the - -- returned exponent value is zero. Real indicates whether a minus sign - -- is permitted (True = permitted). Very large exponents are handled by - -- returning a suitable large value. If the base is zero, then any value - -- is allowed, and otherwise the large value will either cause underflow - -- or overflow during the scaling process which is fine. - -- - -- This routine must not be called with Str'Last = Positive'Last. There is - -- no check for this case, the caller must ensure this condition is met. - - procedure Scan_Trailing_Blanks (Str : String; P : Positive); - -- Checks that the remainder of the field Str (P .. Str'Last) is all - -- blanks. Raises Constraint_Error if a non-blank character is found. - - procedure Scan_Underscore - (Str : String; - P : in out Natural; - Ptr : not null access Integer; - Max : Integer; - Ext : Boolean); - -- Called if an underscore is encountered while scanning digits. Str (P) - -- contains the underscore. Ptr it the pointer to be returned to the - -- ultimate caller of the scan routine, Max is the maximum subscript in - -- Str, and Ext indicates if extended digits are allowed. In the case - -- where the underscore is invalid, Constraint_Error is raised with Ptr - -- set appropriately, otherwise control returns with P incremented past - -- the underscore. - -- - -- This routine must not be called with Str'Last = Positive'Last. There is - -- no check for this case, the caller must ensure this condition is met. - -end System.Val_Util; diff --git a/gcc/ada/s-valwch.adb b/gcc/ada/s-valwch.adb deleted file mode 100644 index 87e8546..0000000 --- a/gcc/ada/s-valwch.adb +++ /dev/null @@ -1,175 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ W C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2012, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces; use Interfaces; -with System.Val_Util; use System.Val_Util; -with System.WCh_Cnv; use System.WCh_Cnv; -with System.WCh_Con; use System.WCh_Con; - -package body System.Val_WChar is - - -------------------------- - -- Value_Wide_Character -- - -------------------------- - - function Value_Wide_Character - (Str : String; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character - is - WC : constant Wide_Wide_Character := Value_Wide_Wide_Character (Str, EM); - WV : constant Unsigned_32 := Wide_Wide_Character'Pos (WC); - begin - if WV > 16#FFFF# then - Bad_Value (Str); - else - return Wide_Character'Val (WV); - end if; - end Value_Wide_Character; - - ------------------------------- - -- Value_Wide_Wide_Character -- - ------------------------------- - - function Value_Wide_Wide_Character - (Str : String; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character - is - F : Natural; - L : Natural; - S : String (Str'Range) := Str; - - begin - Normalize_String (S, F, L); - - -- Character literal case - - if S (F) = ''' and then S (L) = ''' then - - -- Must be at least three characters - - if L - F < 2 then - Bad_Value (Str); - - -- If just three characters, simple character case - - elsif L - F = 2 then - return Wide_Wide_Character'Val (Character'Pos (S (F + 1))); - - -- Only other possibility for quoted string is wide char sequence - - else - declare - P : Natural; - W : Wide_Wide_Character; - - function In_Char return Character; - -- Function for instantiations of Char_Sequence_To_UTF_32 - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - begin - P := P + 1; - - if P = Str'Last then - Bad_Value (Str); - end if; - - return Str (P); - end In_Char; - - function UTF_32 is - new Char_Sequence_To_UTF_32 (In_Char); - - begin - P := F + 1; - - -- Brackets encoding - - if S (F + 1) = '[' then - W := Wide_Wide_Character'Val (UTF_32 ('[', WCEM_Brackets)); - else - W := Wide_Wide_Character'Val (UTF_32 (S (F + 1), EM)); - end if; - - if P /= L - 1 then - Bad_Value (Str); - end if; - - return W; - end; - end if; - - -- Deal with Hex_hhhhhhhh cases for wide_[wide_]character cases - - elsif Str'Length = 12 - and then Str (Str'First .. Str'First + 3) = "Hex_" - then - declare - W : Unsigned_32 := 0; - - begin - for J in Str'First + 4 .. Str'First + 11 loop - W := W * 16 + Character'Pos (Str (J)); - - if Str (J) in '0' .. '9' then - W := W - Character'Pos ('0'); - elsif Str (J) in 'A' .. 'F' then - W := W - Character'Pos ('A') + 10; - elsif Str (J) in 'a' .. 'f' then - W := W - Character'Pos ('a') + 10; - else - Bad_Value (Str); - end if; - end loop; - - if W > 16#7FFF_FFFF# then - Bad_Value (Str); - else - return Wide_Wide_Character'Val (W); - end if; - end; - - -- Otherwise must be one of the special names for Character - - else - return - Wide_Wide_Character'Val (Character'Pos (Character'Value (Str))); - end if; - - exception - when Constraint_Error => - Bad_Value (Str); - end Value_Wide_Wide_Character; - -end System.Val_WChar; diff --git a/gcc/ada/s-valwch.ads b/gcc/ada/s-valwch.ads deleted file mode 100644 index 4bf9309..0000000 --- a/gcc/ada/s-valwch.ads +++ /dev/null @@ -1,53 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . V A L _ W C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- Processing for Wide_[Wide_]Value attribute - -with System.WCh_Con; - -package System.Val_WChar is - pragma Pure; - - function Value_Wide_Character - (Str : String; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character; - -- Computes Wide_Character'Value (Str). The parameter EM is the encoding - -- method used for any Wide_Character sequences in Str. Note that brackets - -- notation is always permitted. - - function Value_Wide_Wide_Character - (Str : String; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Wide_Character; - -- Computes Wide_Character'Value (Str). The parameter EM is the encoding - -- method used for any wide_character sequences in Str. Note that brackets - -- notation is always permitted. - -end System.Val_WChar; diff --git a/gcc/ada/s-veboop.adb b/gcc/ada/s-veboop.adb deleted file mode 100644 index dea318a..0000000 --- a/gcc/ada/s-veboop.adb +++ /dev/null @@ -1,125 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V E C T O R S . B O O L E A N _ O P E R A T I O N S -- --- -- --- B o d y -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Vectors.Boolean_Operations is - - SU : constant := Storage_Unit; - -- Convenient short hand, used throughout - - -- The coding of this unit depends on the fact that the Component_Size - -- of a normally declared array of Boolean is equal to Storage_Unit. We - -- can't use the Component_Size directly since it is non-static. The - -- following declaration checks that this declaration is correct - - type Boolean_Array is array (Integer range <>) of Boolean; - pragma Compile_Time_Error - (Boolean_Array'Component_Size /= SU, "run time compile failure"); - - -- NOTE: The boolean literals must be qualified here to avoid visibility - -- anomalies when this package is compiled through Rtsfind, in a context - -- that includes a user-defined type derived from boolean. - - True_Val : constant Vector := Standard.True'Enum_Rep - + Standard.True'Enum_Rep * 2**SU - + Standard.True'Enum_Rep * 2**(SU * 2) - + Standard.True'Enum_Rep * 2**(SU * 3) - + Standard.True'Enum_Rep * 2**(SU * 4) - + Standard.True'Enum_Rep * 2**(SU * 5) - + Standard.True'Enum_Rep * 2**(SU * 6) - + Standard.True'Enum_Rep * 2**(SU * 7); - -- This constant represents the bits to be flipped to perform a logical - -- "not" on a vector of booleans, independent of the actual - -- representation of True. - - -- The representations of (False, True) are assumed to be zero/one and - -- the maximum number of unpacked booleans per Vector is assumed to be 8. - - pragma Assert (Standard.False'Enum_Rep = 0); - pragma Assert (Standard.True'Enum_Rep = 1); - pragma Assert (Vector'Size / Storage_Unit <= 8); - - -- The reason we need to do these gymnastics is that no call to - -- Unchecked_Conversion can be made at the library level since this - -- unit is pure. Also a conversion from the array type to the Vector type - -- inside the body of "not" is inefficient because of alignment issues. - - ----------- - -- "not" -- - ----------- - - function "not" (Item : Vectors.Vector) return Vectors.Vector is - begin - return Item xor True_Val; - end "not"; - - ---------- - -- Nand -- - ---------- - - function Nand (Left, Right : Boolean) return Boolean is - begin - return not (Left and Right); - end Nand; - - function Nand (Left, Right : Vectors.Vector) return Vectors.Vector is - begin - return not (Left and Right); - end Nand; - - --------- - -- Nor -- - --------- - - function Nor (Left, Right : Boolean) return Boolean is - begin - return not (Left or Right); - end Nor; - - function Nor (Left, Right : Vectors.Vector) return Vectors.Vector is - begin - return not (Left or Right); - end Nor; - - ---------- - -- Nxor -- - ---------- - - function Nxor (Left, Right : Boolean) return Boolean is - begin - return not (Left xor Right); - end Nxor; - - function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector is - begin - return not (Left xor Right); - end Nxor; - -end System.Vectors.Boolean_Operations; diff --git a/gcc/ada/s-veboop.ads b/gcc/ada/s-veboop.ads deleted file mode 100644 index 9553dd1d9..0000000 --- a/gcc/ada/s-veboop.ads +++ /dev/null @@ -1,66 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V E C T O R S . B O O L E A N _ O P E R A T I O N S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains functions for runtime operations on boolean vectors - -package System.Vectors.Boolean_Operations is - pragma Pure; - - -- Although in general the boolean operations on arrays of booleans are - -- identical to operations on arrays of unsigned words of the same size, - -- for the "not" operator this is not the case as False is typically - -- represented by 0 and true by 1. - - function "not" (Item : Vectors.Vector) return Vectors.Vector; - - -- The three boolean operations "nand", "nor" and "nxor" are needed - -- for cases where the compiler moves boolean array operations into - -- the body of the loop that iterates over the array elements. - - -- Note the following equivalences: - -- (not X) or (not Y) = not (X and Y) = Nand (X, Y) - -- (not X) and (not Y) = not (X or Y) = Nor (X, Y) - -- (not X) xor (not Y) = X xor Y - -- X xor (not Y) = not (X xor Y) = Nxor (X, Y) - - function Nand (Left, Right : Boolean) return Boolean; - function Nor (Left, Right : Boolean) return Boolean; - function Nxor (Left, Right : Boolean) return Boolean; - - function Nand (Left, Right : Vectors.Vector) return Vectors.Vector; - function Nor (Left, Right : Vectors.Vector) return Vectors.Vector; - function Nxor (Left, Right : Vectors.Vector) return Vectors.Vector; - - pragma Inline_Always ("not"); - pragma Inline_Always (Nand); - pragma Inline_Always (Nor); - pragma Inline_Always (Nxor); -end System.Vectors.Boolean_Operations; diff --git a/gcc/ada/s-vector.ads b/gcc/ada/s-vector.ads deleted file mode 100644 index 4c529b2..0000000 --- a/gcc/ada/s-vector.ads +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- --- -- --- S Y S T E M . V E C T O R S -- --- -- --- S p e c -- --- -- --- Copyright (C) 2002-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package defines a datatype which is most efficient for performing --- logical operations on large arrays. See System.Generic_Vector_Operations. - --- In the future this package may also define operations such as element-wise --- addition, subtraction, multiplication, minimum and maximum of vector-sized --- packed arrays of Unsigned_8, Unsigned_16 and Unsigned_32 values. These --- operations could be implemented as system intrinsics on platforms with --- direct processor support for them. - -package System.Vectors is - pragma Pure; - - type Vector is mod 2**System.Word_Size; - for Vector'Alignment use Integer'Min - (Standard'Maximum_Alignment, System.Word_Size / System.Storage_Unit); - for Vector'Size use System.Word_Size; - -end System.Vectors; diff --git a/gcc/ada/s-vercon.adb b/gcc/ada/s-vercon.adb deleted file mode 100644 index 7c2f89f..0000000 --- a/gcc/ada/s-vercon.adb +++ /dev/null @@ -1,58 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . V E R S I O N _ C O N T R O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Version_Control is - - ------------------------ - -- Get_Version_String -- - ------------------------ - - function Get_Version_String - (V : System.Unsigned_Types.Unsigned) - return Version_String - is - S : Version_String; - D : Unsigned := V; - H : constant array (Unsigned range 0 .. 15) of Character := - "0123456789abcdef"; - - begin - for J in reverse 1 .. 8 loop - S (J) := H (D mod 16); - D := D / 16; - end loop; - - return S; - end Get_Version_String; - -end System.Version_Control; diff --git a/gcc/ada/s-vercon.ads b/gcc/ada/s-vercon.ads deleted file mode 100644 index 4513d9d..0000000 --- a/gcc/ada/s-vercon.ads +++ /dev/null @@ -1,52 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . V E R S I O N _ C O N T R O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This module contains the runtime routine for implementation of the --- Version and Body_Version attributes, as well as the string type that --- is returned as a result of using these attributes. - -with System.Unsigned_Types; - -package System.Version_Control is - pragma Pure; - - subtype Version_String is String (1 .. 8); - -- Eight character string returned by Get_version_String; - - function Get_Version_String - (V : System.Unsigned_Types.Unsigned) - return Version_String; - -- The version information in the executable file is stored as unsigned - -- integers. This routine converts the unsigned integer into an eight - -- character string containing its hexadecimal digits (with lower case - -- letters). - -end System.Version_Control; diff --git a/gcc/ada/s-wchcnv.adb b/gcc/ada/s-wchcnv.adb deleted file mode 100644 index ffbb991..0000000 --- a/gcc/ada/s-wchcnv.adb +++ /dev/null @@ -1,465 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ C N V -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -with Interfaces; use Interfaces; -with System.WCh_Con; use System.WCh_Con; -with System.WCh_JIS; use System.WCh_JIS; - -package body System.WCh_Cnv is - - ----------------------------- - -- Char_Sequence_To_UTF_32 -- - ----------------------------- - - function Char_Sequence_To_UTF_32 - (C : Character; - EM : System.WCh_Con.WC_Encoding_Method) return UTF_32_Code - is - B1 : Unsigned_32; - C1 : Character; - U : Unsigned_32; - W : Unsigned_32; - - procedure Get_Hex (N : Character); - -- If N is a hex character, then set B1 to 16 * B1 + character N. - -- Raise Constraint_Error if character N is not a hex character. - - procedure Get_UTF_Byte; - pragma Inline (Get_UTF_Byte); - -- Used to interpret a 2#10xxxxxx# continuation byte in UTF-8 mode. - -- Reads a byte, and raises CE if the first two bits are not 10. - -- Otherwise shifts W 6 bits left and or's in the 6 xxxxxx bits. - - ------------- - -- Get_Hex -- - ------------- - - procedure Get_Hex (N : Character) is - B2 : constant Unsigned_32 := Character'Pos (N); - begin - if B2 in Character'Pos ('0') .. Character'Pos ('9') then - B1 := B1 * 16 + B2 - Character'Pos ('0'); - elsif B2 in Character'Pos ('A') .. Character'Pos ('F') then - B1 := B1 * 16 + B2 - (Character'Pos ('A') - 10); - elsif B2 in Character'Pos ('a') .. Character'Pos ('f') then - B1 := B1 * 16 + B2 - (Character'Pos ('a') - 10); - else - raise Constraint_Error; - end if; - end Get_Hex; - - ------------------ - -- Get_UTF_Byte -- - ------------------ - - procedure Get_UTF_Byte is - begin - U := Unsigned_32 (Character'Pos (In_Char)); - - if (U and 2#11000000#) /= 2#10_000000# then - raise Constraint_Error; - end if; - - W := Shift_Left (W, 6) or (U and 2#00111111#); - end Get_UTF_Byte; - - -- Start of processing for Char_Sequence_To_UTF_32 - - begin - case EM is - when WCEM_Hex => - if C /= ASCII.ESC then - return Character'Pos (C); - - else - B1 := 0; - Get_Hex (In_Char); - Get_Hex (In_Char); - Get_Hex (In_Char); - Get_Hex (In_Char); - - return UTF_32_Code (B1); - end if; - - when WCEM_Upper => - if C > ASCII.DEL then - return 256 * Character'Pos (C) + Character'Pos (In_Char); - else - return Character'Pos (C); - end if; - - when WCEM_Shift_JIS => - if C > ASCII.DEL then - return Wide_Character'Pos (Shift_JIS_To_JIS (C, In_Char)); - else - return Character'Pos (C); - end if; - - when WCEM_EUC => - if C > ASCII.DEL then - return Wide_Character'Pos (EUC_To_JIS (C, In_Char)); - else - return Character'Pos (C); - end if; - - when WCEM_UTF8 => - - -- Note: for details of UTF8 encoding see RFC 3629 - - U := Unsigned_32 (Character'Pos (C)); - - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - if (U and 2#10000000#) = 2#00000000# then - return Character'Pos (C); - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - elsif (U and 2#11100000#) = 2#110_00000# then - W := U and 2#00011111#; - Get_UTF_Byte; - return UTF_32_Code (W); - - -- 16#00_0800#-16#00_ffff#: 1110xxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11110000#) = 2#1110_0000# then - W := U and 2#00001111#; - Get_UTF_Byte; - Get_UTF_Byte; - return UTF_32_Code (W); - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11111000#) = 2#11110_000# then - W := U and 2#00000111#; - - for K in 1 .. 3 loop - Get_UTF_Byte; - end loop; - - return UTF_32_Code (W); - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - elsif (U and 2#11111100#) = 2#111110_00# then - W := U and 2#00000011#; - - for K in 1 .. 4 loop - Get_UTF_Byte; - end loop; - - return UTF_32_Code (W); - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx 10xxxxxx - - elsif (U and 2#11111110#) = 2#1111110_0# then - W := U and 2#00000001#; - - for K in 1 .. 5 loop - Get_UTF_Byte; - end loop; - - return UTF_32_Code (W); - - else - raise Constraint_Error; - end if; - - when WCEM_Brackets => - if C /= '[' then - return Character'Pos (C); - end if; - - if In_Char /= '"' then - raise Constraint_Error; - end if; - - B1 := 0; - Get_Hex (In_Char); - Get_Hex (In_Char); - - C1 := In_Char; - - if C1 /= '"' then - Get_Hex (C1); - Get_Hex (In_Char); - - C1 := In_Char; - - if C1 /= '"' then - Get_Hex (C1); - Get_Hex (In_Char); - - C1 := In_Char; - - if C1 /= '"' then - Get_Hex (C1); - Get_Hex (In_Char); - - if B1 > Unsigned_32 (UTF_32_Code'Last) then - raise Constraint_Error; - end if; - - if In_Char /= '"' then - raise Constraint_Error; - end if; - end if; - end if; - end if; - - if In_Char /= ']' then - raise Constraint_Error; - end if; - - return UTF_32_Code (B1); - end case; - end Char_Sequence_To_UTF_32; - - -------------------------------- - -- Char_Sequence_To_Wide_Char -- - -------------------------------- - - function Char_Sequence_To_Wide_Char - (C : Character; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character - is - function Char_Sequence_To_UTF is new Char_Sequence_To_UTF_32 (In_Char); - - U : constant UTF_32_Code := Char_Sequence_To_UTF (C, EM); - - begin - if U > 16#FFFF# then - raise Constraint_Error; - else - return Wide_Character'Val (U); - end if; - end Char_Sequence_To_Wide_Char; - - ----------------------------- - -- UTF_32_To_Char_Sequence -- - ----------------------------- - - procedure UTF_32_To_Char_Sequence - (Val : UTF_32_Code; - EM : System.WCh_Con.WC_Encoding_Method) - is - Hexc : constant array (UTF_32_Code range 0 .. 15) of Character := - "0123456789ABCDEF"; - - C1, C2 : Character; - U : Unsigned_32; - - begin - -- Raise CE for invalid UTF_32_Code - - if not Val'Valid then - raise Constraint_Error; - end if; - - -- Processing depends on encoding mode - - case EM is - when WCEM_Hex => - if Val < 256 then - Out_Char (Character'Val (Val)); - elsif Val <= 16#FFFF# then - Out_Char (ASCII.ESC); - Out_Char (Hexc (Val / (16**3))); - Out_Char (Hexc ((Val / (16**2)) mod 16)); - Out_Char (Hexc ((Val / 16) mod 16)); - Out_Char (Hexc (Val mod 16)); - else - raise Constraint_Error; - end if; - - when WCEM_Upper => - if Val < 128 then - Out_Char (Character'Val (Val)); - elsif Val < 16#8000# or else Val > 16#FFFF# then - raise Constraint_Error; - else - Out_Char (Character'Val (Val / 256)); - Out_Char (Character'Val (Val mod 256)); - end if; - - when WCEM_Shift_JIS => - if Val < 128 then - Out_Char (Character'Val (Val)); - elsif Val <= 16#FFFF# then - JIS_To_Shift_JIS (Wide_Character'Val (Val), C1, C2); - Out_Char (C1); - Out_Char (C2); - else - raise Constraint_Error; - end if; - - when WCEM_EUC => - if Val < 128 then - Out_Char (Character'Val (Val)); - elsif Val <= 16#FFFF# then - JIS_To_EUC (Wide_Character'Val (Val), C1, C2); - Out_Char (C1); - Out_Char (C2); - else - raise Constraint_Error; - end if; - - when WCEM_UTF8 => - - -- Note: for details of UTF8 encoding see RFC 3629 - - U := Unsigned_32 (Val); - - -- 16#00_0000#-16#00_007F#: 0xxxxxxx - - if U <= 16#00_007F# then - Out_Char (Character'Val (U)); - - -- 16#00_0080#-16#00_07FF#: 110xxxxx 10xxxxxx - - elsif U <= 16#00_07FF# then - Out_Char (Character'Val (2#11000000# or Shift_Right (U, 6))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- 16#00_0800#-16#00_FFFF#: 1110xxxx 10xxxxxx 10xxxxxx - - elsif U <= 16#00_FFFF# then - Out_Char (Character'Val (2#11100000# or Shift_Right (U, 12))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- 16#01_0000#-16#10_FFFF#: 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - - elsif U <= 16#10_FFFF# then - Out_Char (Character'Val (2#11110000# or Shift_Right (U, 18))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- 16#0020_0000#-16#03FF_FFFF#: 111110xx 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx - - elsif U <= 16#03FF_FFFF# then - Out_Char (Character'Val (2#11111000# or Shift_Right (U, 24))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - -- 16#0400_0000#-16#7FFF_FFFF#: 1111110x 10xxxxxx 10xxxxxx - -- 10xxxxxx 10xxxxxx 10xxxxxx - - elsif U <= 16#7FFF_FFFF# then - Out_Char (Character'Val (2#11111100# or Shift_Right (U, 30))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 24) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 18) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 12) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (Shift_Right (U, 6) - and 2#00111111#))); - Out_Char (Character'Val (2#10000000# or (U and 2#00111111#))); - - else - raise Constraint_Error; - end if; - - when WCEM_Brackets => - - -- Values in the range 0-255 are directly output. Note that there - -- is an issue with [ (16#5B#) since this will cause confusion - -- if the resulting string is interpreted using brackets encoding. - - -- One possibility would be to always output [ as ["5B"] but in - -- practice this is undesirable, since for example normal use of - -- Wide_Text_IO for output (much more common than input), really - -- does want to be able to say something like - - -- Put_Line ("Start of output [first run]"); - - -- and have it come out as intended, rather than contaminated by - -- a ["5B"] sequence in place of the left bracket. - - if Val < 256 then - Out_Char (Character'Val (Val)); - - -- Otherwise use brackets notation for vales greater than 255 - - else - Out_Char ('['); - Out_Char ('"'); - - if Val > 16#FFFF# then - if Val > 16#00FF_FFFF# then - Out_Char (Hexc (Val / 16 ** 7)); - Out_Char (Hexc ((Val / 16 ** 6) mod 16)); - end if; - - Out_Char (Hexc ((Val / 16 ** 5) mod 16)); - Out_Char (Hexc ((Val / 16 ** 4) mod 16)); - end if; - - Out_Char (Hexc ((Val / 16 ** 3) mod 16)); - Out_Char (Hexc ((Val / 16 ** 2) mod 16)); - Out_Char (Hexc ((Val / 16) mod 16)); - Out_Char (Hexc (Val mod 16)); - - Out_Char ('"'); - Out_Char (']'); - end if; - end case; - end UTF_32_To_Char_Sequence; - - -------------------------------- - -- Wide_Char_To_Char_Sequence -- - -------------------------------- - - procedure Wide_Char_To_Char_Sequence - (WC : Wide_Character; - EM : System.WCh_Con.WC_Encoding_Method) - is - procedure UTF_To_Char_Sequence is new UTF_32_To_Char_Sequence (Out_Char); - begin - UTF_To_Char_Sequence (Wide_Character'Pos (WC), EM); - end Wide_Char_To_Char_Sequence; - -end System.WCh_Cnv; diff --git a/gcc/ada/s-wchcnv.ads b/gcc/ada/s-wchcnv.ads deleted file mode 100644 index 82a620a..0000000 --- a/gcc/ada/s-wchcnv.ads +++ /dev/null @@ -1,116 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ C N V -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains generic subprograms used for converting between --- sequences of Character and Wide_Character. Wide_Wide_Character values --- are also handled, but represented using integer range types defined in --- this package, so that this package can be used from applications that --- are restricted to Ada 95 compatibility (such as the compiler itself). - --- All the algorithms for encoding and decoding are isolated in this package --- and in System.WCh_JIS and should not be duplicated elsewhere. The only --- exception to this is that GNAT.Decode_String and GNAT.Encode_String have --- their own circuits for UTF-8 conversions, for improved efficiency. - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -pragma Compiler_Unit_Warning; - -with System.WCh_Con; - -package System.WCh_Cnv is - pragma Pure; - - type UTF_32_Code is range 0 .. 16#7FFF_FFFF#; - for UTF_32_Code'Size use 32; - -- Range of allowed UTF-32 encoding values - - type UTF_32_String is array (Positive range <>) of UTF_32_Code; - - generic - with function In_Char return Character; - function Char_Sequence_To_Wide_Char - (C : Character; - EM : System.WCh_Con.WC_Encoding_Method) return Wide_Character; - -- C is the first character of a sequence of one or more characters which - -- represent a wide character sequence. Calling the function In_Char for - -- additional characters as required, Char_To_Wide_Char returns the - -- corresponding wide character value. Constraint_Error is raised if the - -- sequence of characters encountered is not a valid wide character - -- sequence for the given encoding method. - -- - -- Note on the use of brackets encoding (WCEM_Brackets). The brackets - -- encoding method is ambiguous in the context of this function, since - -- there is no way to tell if ["1234"] is eight unencoded characters or - -- one encoded character. In the context of Ada sources, any sequence - -- starting [" must be the start of an encoding (since that sequence is - -- not valid in Ada source otherwise). The routines in this package use - -- the same approach. If the input string contains the sequence [" then - -- this is assumed to be the start of a brackets encoding sequence, and - -- if it does not match the syntax, an error is raised. - - generic - with function In_Char return Character; - function Char_Sequence_To_UTF_32 - (C : Character; - EM : System.WCh_Con.WC_Encoding_Method) return UTF_32_Code; - -- This is similar to the above, but the function returns a code from - -- the full UTF_32 code set, which covers the full range of possible - -- values in Wide_Wide_Character. The result can be converted to - -- Wide_Wide_Character form using Wide_Wide_Character'Val. - - generic - with procedure Out_Char (C : Character); - procedure Wide_Char_To_Char_Sequence - (WC : Wide_Character; - EM : System.WCh_Con.WC_Encoding_Method); - -- Given a wide character, converts it into a sequence of one or - -- more characters, calling the given Out_Char procedure for each. - -- Constraint_Error is raised if the given wide character value is - -- not a valid value for the given encoding method. - -- - -- Note on brackets encoding (WCEM_Brackets). For the input routines above, - -- upper half characters can be represented as ["hh"] but this procedure - -- will only use brackets encodings for codes higher than 16#FF#, so upper - -- half characters will be output as single Character values. - - generic - with procedure Out_Char (C : Character); - procedure UTF_32_To_Char_Sequence - (Val : UTF_32_Code; - EM : System.WCh_Con.WC_Encoding_Method); - -- This is similar to the above, but the input value is a code from the - -- full UTF_32 code set, which covers the full range of possible values - -- in Wide_Wide_Character. To convert a Wide_Wide_Character value, the - -- caller can use Wide_Wide_Character'Pos in the call. - -end System.WCh_Cnv; diff --git a/gcc/ada/s-wchcon.adb b/gcc/ada/s-wchcon.adb deleted file mode 100644 index 55acd04..0000000 --- a/gcc/ada/s-wchcon.adb +++ /dev/null @@ -1,84 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . W C H _ C O N -- --- -- --- B o d y -- --- -- --- Copyright (C) 2005-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.WCh_Con is - - ---------------------------- - -- Get_WC_Encoding_Method -- - ---------------------------- - - function Get_WC_Encoding_Method (C : Character) return WC_Encoding_Method is - begin - for Method in WC_Encoding_Method loop - if C = WC_Encoding_Letters (Method) then - return Method; - end if; - end loop; - - raise Constraint_Error; - end Get_WC_Encoding_Method; - - function Get_WC_Encoding_Method (S : String) return WC_Encoding_Method is - begin - if S = "hex" then - return WCEM_Hex; - elsif S = "upper" then - return WCEM_Upper; - elsif S = "shift_jis" then - return WCEM_Shift_JIS; - elsif S = "euc" then - return WCEM_EUC; - elsif S = "utf8" then - return WCEM_UTF8; - elsif S = "brackets" then - return WCEM_Brackets; - else - raise Constraint_Error; - end if; - end Get_WC_Encoding_Method; - - -------------------------- - -- Is_Start_Of_Encoding -- - -------------------------- - - function Is_Start_Of_Encoding - (C : Character; - EM : WC_Encoding_Method) return Boolean - is - begin - return (EM in WC_Upper_Half_Encoding_Method - and then Character'Pos (C) >= 16#80#) - or else (EM in WC_ESC_Encoding_Method and then C = ASCII.ESC); - end Is_Start_Of_Encoding; - -end System.WCh_Con; diff --git a/gcc/ada/s-wchcon.ads b/gcc/ada/s-wchcon.ads deleted file mode 100644 index 7b081ac..0000000 --- a/gcc/ada/s-wchcon.ads +++ /dev/null @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- S Y S T E M . W C H _ C O N -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package defines the codes used to identify the encoding method for --- wide characters in string and character constants. This is needed both --- at compile time and at runtime (for the wide character runtime routines) - --- This unit may be used directly from an application program by providing --- an appropriate WITH, and the interface can be expected to remain stable. - -pragma Compiler_Unit_Warning; - -package System.WCh_Con is - pragma Pure; - - ------------------------------------- - -- Wide_Character Encoding Methods -- - ------------------------------------- - - -- A wide character encoding method is a method for uniquely representing - -- a Wide_Character or Wide_Wide_Character value using a one or more - -- Character values. Three types of encoding method are supported by GNAT: - - -- An escape encoding method uses ESC as the first character of the - -- sequence, and subsequent characters determine the wide character - -- value that is represented. Any character other than ESC stands - -- for itself as a single byte (i.e. any character in Latin-1, other - -- than ESC itself, is represented as a single character: itself). - - -- An upper half encoding method uses a character in the upper half - -- range (i.e. in the range 16#80# .. 16#FF#) as the first byte of - -- a wide character encoding sequence. Subsequent characters are - -- used to determine the wide character value that is represented. - -- Any character in the lower half (16#00# .. 16#7F#) represents - -- itself as a single character. - - -- The brackets notation, where a wide character is represented by the - -- sequence ["xx"] or ["xxxx"] or ["xxxxxx"] where xx are hexadecimal - -- characters. Note that currently this is the only encoding that - -- supports the full UTF-32 range. - - -- Note that GNAT does not currently support escape-in, escape-out - -- encoding methods, where an escape sequence is used to set a mode - -- used to recognize subsequent characters. All encoding methods use - -- individual character-by-character encodings, so that a sequence of - -- wide characters is represented by a sequence of encodings. - - -- To add new encoding methods, the following steps are required: - - -- 1. Define a code for a new value of type WC_Encoding_Method - -- 2. Adjust the definition of WC_Encoding_Method accordingly - -- 3. Provide appropriate conversion routines in System.WCh_Cnv - -- 4. Adjust definition of WC_Longest_Sequence if necessary - -- 5. Add an entry in WC_Encoding_Letters for the new method - -- 6. Add proper code to s-wchstw.adb, s-wchwts.adb, s-widwch.adb - -- 7. Update documentation (remember section on form strings) - - -- Note that the WC_Encoding_Method values must be kept ordered so that - -- the definitions of the subtypes WC_Upper_Half_Encoding_Method and - -- WC_ESC_Encoding_Method are still correct. - - --------------------------------- - -- Encoding Method Definitions -- - --------------------------------- - - type WC_Encoding_Method is range 1 .. 6; - -- Type covering the range of values used to represent wide character - -- encoding methods. An enumeration type might be a little neater, but - -- more trouble than it's worth, given the need to pass these values - -- from the compiler to the backend, and to record them in the ALI file. - - WCEM_Hex : constant WC_Encoding_Method := 1; - -- The wide character with code 16#abcd# is represented by the escape - -- sequence ESC a b c d (five characters, where abcd are ASCII hex - -- characters, using upper case for letters). This method is easy - -- to deal with in external environments that do not support wide - -- characters, and covers the whole 16-bit BMP. Codes larger than - -- 16#FFFF# are not representable using this encoding method. - - WCEM_Upper : constant WC_Encoding_Method := 2; - -- The wide character with encoding 16#abcd#, where the upper bit is on - -- (i.e. a is in the range 8-F) is represented as two bytes 16#ab# and - -- 16#cd#. The second byte may never be a format control character, but - -- is not required to be in the upper half. This method can be also used - -- for shift-JIS or EUC where the internal coding matches the external - -- coding. Codes larger than 16#FFFF# are not representable using this - -- encoding method. - - WCEM_Shift_JIS : constant WC_Encoding_Method := 3; - -- A wide character is represented by a two character sequence 16#ab# - -- and 16#cd#, with the restrictions described for upper half encoding - -- as described above. The internal character code is the corresponding - -- JIS character according to the standard algorithm for Shift-JIS - -- conversion. See the body of package System.JIS_Conversions for - -- further details. Codes larger than 16#FFFF are not representable - -- using this encoding method. - - WCEM_EUC : constant WC_Encoding_Method := 4; - -- A wide character is represented by a two character sequence 16#ab# and - -- 16#cd#, with both characters being in the upper half set. The internal - -- character code is the corresponding JIS character according to the EUC - -- encoding algorithm. See the body of package System.JIS_Conversions for - -- further details. Codes larger than 16#FFFF# are not representable using - -- this encoding method. - - WCEM_UTF8 : constant WC_Encoding_Method := 5; - -- An ISO 10646-1 BMP/Unicode wide character is represented in UCS - -- Transformation Format 8 (UTF-8), as defined in Annex R of ISO - -- 10646-1/Am.2. Depending on the character value, a Unicode character - -- is represented as the one to six byte sequence. - -- - -- 16#0000_0000#-16#0000_007f#: 2#0xxxxxxx# - -- 16#0000_0080#-16#0000_07ff#: 2#110xxxxx# 2#10xxxxxx# - -- 16#0000_0800#-16#0000_ffff#: 2#1110xxxx# 2#10xxxxxx# 2#10xxxxxx# - -- 16#0001_0000#-16#001F_FFFF#: 2#11110xxx# 2#10xxxxxx# 2#10xxxxxx# - -- 2#10xxxxxx# - -- 16#0020_0000#-16#03FF_FFFF#: 2#111110xx# 2#10xxxxxx# 2#10xxxxxx# - -- 2#10xxxxxx# 2#10xxxxxx# - -- 16#0400_0000#-16#7FFF_FFFF#: 2#1111110x# 2#10xxxxxx# 2#10xxxxxx# - -- 2#10xxxxxx# 2#10xxxxxx# 2#10xxxxxx# - -- - -- where the xxx bits correspond to the left-padded bits of the - -- 16-bit character value. Note that all lower half ASCII characters - -- are represented as ASCII bytes and all upper half characters and - -- other wide characters are represented as sequences of upper-half. This - -- encoding method can represent the entire range of Wide_Wide_Character. - - WCEM_Brackets : constant WC_Encoding_Method := 6; - -- A wide character is represented using one of the following sequences: - -- - -- ["xx"] - -- ["xxxx"] - -- ["xxxxxx"] - -- ["xxxxxxxx"] - -- - -- where xx are hexadecimal digits representing the character code. This - -- encoding method can represent the entire range of Wide_Wide_Character - -- but in the general case results in ambiguous representations (there is - -- no ambiguity in Ada sources, since the above sequences are illegal Ada). - - WC_Encoding_Letters : constant array (WC_Encoding_Method) of Character := - (WCEM_Hex => 'h', - WCEM_Upper => 'u', - WCEM_Shift_JIS => 's', - WCEM_EUC => 'e', - WCEM_UTF8 => '8', - WCEM_Brackets => 'b'); - -- Letters used for selection of wide character encoding method in the - -- compiler options (-gnatW? switch) and for Wide_Text_IO (WCEM parameter - -- in the form string). - - subtype WC_ESC_Encoding_Method is - WC_Encoding_Method range WCEM_Hex .. WCEM_Hex; - -- Encoding methods using an ESC character at the start of the sequence - - subtype WC_Upper_Half_Encoding_Method is - WC_Encoding_Method range WCEM_Upper .. WCEM_UTF8; - -- Encoding methods using an upper half character (16#80#..16#FF) at - -- the start of the sequence. - - WC_Longest_Sequence : constant := 12; - -- The longest number of characters that can be used for a wide character - -- or wide wide character sequence for any of the active encoding methods. - - WC_Longest_Sequences : constant array (WC_Encoding_Method) of Natural := - (WCEM_Hex => 5, - WCEM_Upper => 2, - WCEM_Shift_JIS => 2, - WCEM_EUC => 2, - WCEM_UTF8 => 6, - WCEM_Brackets => 12); - -- The longest number of characters that can be used for a wide character - -- or wide wide character sequence using the given encoding method. - - function Get_WC_Encoding_Method (C : Character) return WC_Encoding_Method; - -- Given a character C, returns corresponding encoding method (see array - -- WC_Encoding_Letters above). Raises Constraint_Error if not in list. - - function Get_WC_Encoding_Method (S : String) return WC_Encoding_Method; - -- Given a lower case string that is one of hex, upper, shift_jis, euc, - -- utf8, brackets, return the corresponding encoding method. Raises - -- Constraint_Error if not in list. - - function Is_Start_Of_Encoding - (C : Character; - EM : WC_Encoding_Method) return Boolean; - pragma Inline (Is_Start_Of_Encoding); - -- Returns True if the Character C is the start of a multi-character - -- encoding sequence for the given encoding method EM. If EM is set to - -- WCEM_Brackets, this function always returns False. - -end System.WCh_Con; diff --git a/gcc/ada/s-wchjis.adb b/gcc/ada/s-wchjis.adb deleted file mode 100644 index 6b4941c..0000000 --- a/gcc/ada/s-wchjis.adb +++ /dev/null @@ -1,189 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ J I S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -pragma Compiler_Unit_Warning; - -package body System.WCh_JIS is - - type Byte is mod 256; - - EUC_Hankaku_Kana : constant Byte := 16#8E#; - -- Prefix byte in EUC for Hankaku Kana (small Katakana). Such characters - -- in EUC are represented by a prefix byte followed by the code, which - -- is in the upper half (the corresponding JIS internal code is in the - -- range 16#0080# - 16#00FF#). - - function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character is - EUC1B : constant Byte := Character'Pos (EUC1); - EUC2B : constant Byte := Character'Pos (EUC2); - - begin - if EUC2B not in 16#A0# .. 16#FE# then - raise Constraint_Error; - end if; - - if EUC1B = EUC_Hankaku_Kana then - return Wide_Character'Val (EUC2B); - - else - if EUC1B not in 16#A0# .. 16#FE# then - raise Constraint_Error; - else - return Wide_Character'Val - (256 * Natural (EUC1B and 16#7F#) + Natural (EUC2B and 16#7F#)); - end if; - end if; - end EUC_To_JIS; - - ---------------- - -- JIS_To_EUC -- - ---------------- - - procedure JIS_To_EUC - (J : Wide_Character; - EUC1 : out Character; - EUC2 : out Character) - is - JIS1 : constant Natural := Wide_Character'Pos (J) / 256; - JIS2 : constant Natural := Wide_Character'Pos (J) rem 256; - - begin - -- Special case of small Katakana - - if JIS1 = 0 then - - -- The value must be in the range 16#80# to 16#FF# so that the upper - -- bit is set in both bytes. - - if JIS2 < 16#80# then - raise Constraint_Error; - end if; - - EUC1 := Character'Val (EUC_Hankaku_Kana); - EUC2 := Character'Val (JIS2); - - -- The upper bit of both characters must be clear, or this is not - -- a valid character for representation in EUC form. - - elsif JIS1 > 16#7F# or else JIS2 > 16#7F# then - raise Constraint_Error; - - -- Result is just the two characters with upper bits set - - else - EUC1 := Character'Val (JIS1 + 16#80#); - EUC2 := Character'Val (JIS2 + 16#80#); - end if; - end JIS_To_EUC; - - ---------------------- - -- JIS_To_Shift_JIS -- - ---------------------- - - procedure JIS_To_Shift_JIS - (J : Wide_Character; - SJ1 : out Character; - SJ2 : out Character) - is - JIS1 : Byte; - JIS2 : Byte; - - begin - -- The following is the required algorithm, it's hard to make any - -- more intelligent comments. This was copied from a public domain - -- C program called etos.c (author unknown). - - JIS1 := Byte (Natural (Wide_Character'Pos (J) / 256)); - JIS2 := Byte (Natural (Wide_Character'Pos (J) rem 256)); - - if JIS1 > 16#5F# then - JIS1 := JIS1 + 16#80#; - end if; - - if (JIS1 mod 2) = 0 then - SJ1 := Character'Val ((JIS1 - 16#30#) / 2 + 16#88#); - SJ2 := Character'Val (JIS2 + 16#7E#); - - else - if JIS2 >= 16#60# then - JIS2 := JIS2 + 16#01#; - end if; - - SJ1 := Character'Val ((JIS1 - 16#31#) / 2 + 16#89#); - SJ2 := Character'Val (JIS2 + 16#1F#); - end if; - end JIS_To_Shift_JIS; - - ---------------------- - -- Shift_JIS_To_JIS -- - ---------------------- - - function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character is - SJIS1 : Byte; - SJIS2 : Byte; - JIS1 : Byte; - JIS2 : Byte; - - begin - -- The following is the required algorithm, it's hard to make any - -- more intelligent comments. This was copied from a public domain - -- C program called stoj.c written by shige@csk.JUNET. - - SJIS1 := Character'Pos (SJ1); - SJIS2 := Character'Pos (SJ2); - - if SJIS1 >= 16#E0# then - SJIS1 := SJIS1 - 16#40#; - end if; - - if SJIS2 >= 16#9F# then - JIS1 := (SJIS1 - 16#88#) * 2 + 16#30#; - JIS2 := SJIS2 - 16#7E#; - - else - if SJIS2 >= 16#7F# then - SJIS2 := SJIS2 - 16#01#; - end if; - - JIS1 := (SJIS1 - 16#89#) * 2 + 16#31#; - JIS2 := SJIS2 - 16#1F#; - end if; - - if JIS1 not in 16#20# .. 16#7E# - or else JIS2 not in 16#20# .. 16#7E# - then - raise Constraint_Error; - else - return Wide_Character'Val (256 * Natural (JIS1) + Natural (JIS2)); - end if; - end Shift_JIS_To_JIS; - -end System.WCh_JIS; diff --git a/gcc/ada/s-wchjis.ads b/gcc/ada/s-wchjis.ads deleted file mode 100644 index 58b4bf1..0000000 --- a/gcc/ada/s-wchjis.ads +++ /dev/null @@ -1,78 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ J I S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines used for converting between internal --- JIS codes and the two external forms we support (EUC and Shift-JIS) - -pragma Compiler_Unit_Warning; - -package System.WCh_JIS is - pragma Pure; - - function EUC_To_JIS (EUC1, EUC2 : Character) return Wide_Character; - -- Given the two bytes of a EUC representation, return the - -- corresponding JIS code wide character. Raises Constraint_Error - -- if the two characters are not a valid EUC encoding. - - procedure JIS_To_EUC - (J : Wide_Character; - EUC1 : out Character; - EUC2 : out Character); - - -- Given a wide character in JIS form, produce the corresponding - -- two bytes of the EUC representation of this character. This is - -- only used if J is not in the normal ASCII range, i.e. on entry - -- we know that Wide_Character'Pos (J) >= 16#0080# and that we - -- thus require a two byte EUC representation (ASCII codes appear - -- unchanged as a single byte in EUC). No error checking is performed, - -- the input code is assumed to be in an appropriate range. - - procedure JIS_To_Shift_JIS - (J : Wide_Character; - SJ1 : out Character; - SJ2 : out Character); - -- Given a wide character code in JIS form, produce the corresponding - -- two bytes of the Shift-JIS representation of this character. This - -- is only used if J is not in the normal ASCII range, i.e. on entry - -- we know that Wide_Character'Pos (J) >= 16#0080# and that we - -- thus require a two byte EUC representation (ASCII codes appear - -- unchanged as a single byte in EUC). No error checking is performed, - -- the input code is assumed to be in an appropriate range (note in - -- particular that input codes in the range 16#0080#-16#00FF#, i.e. - -- Hankaku Kana, do not appear, since Shift JIS has no representation - -- for such codes. - - function Shift_JIS_To_JIS (SJ1, SJ2 : Character) return Wide_Character; - -- Given the two bytes of a Shift-JIS representation, return the - -- corresponding JIS code wide character. Raises Constraint_Error if - -- the two characters are not a valid shift-JIS encoding. - -end System.WCh_JIS; diff --git a/gcc/ada/s-wchstw.adb b/gcc/ada/s-wchstw.adb deleted file mode 100644 index e50f4c2..0000000 --- a/gcc/ada/s-wchstw.adb +++ /dev/null @@ -1,173 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ S T W -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_Cnv; use System.WCh_Cnv; - -package body System.WCh_StW is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Get_Next_Code - (S : String; - P : in out Natural; - V : out UTF_32_Code; - EM : WC_Encoding_Method); - -- Scans next character starting at S(P) and returns its value in V. On - -- exit P is updated past the last character read. Raises Constraint_Error - -- if the string is not well formed. Raises Constraint_Error if the code - -- value is greater than 16#7FFF_FFFF#. On entry P <= S'Last. - - ------------------- - -- Get_Next_Code -- - ------------------- - - procedure Get_Next_Code - (S : String; - P : in out Natural; - V : out UTF_32_Code; - EM : WC_Encoding_Method) - is - function In_Char return Character; - -- Function to return a character, bumping P, raises Constraint_Error - -- if P > S'Last on entry. - - function Get_UTF_32 is new Char_Sequence_To_UTF_32 (In_Char); - -- Function to get next UFT_32 value - - ------------- - -- In_Char -- - ------------- - - function In_Char return Character is - begin - if P > S'Last then - raise Constraint_Error with "badly formed wide character code"; - else - P := P + 1; - return S (P - 1); - end if; - end In_Char; - - -- Start of processing for Get_Next_Code - - begin - -- Check for wide character encoding - - case EM is - when WCEM_Hex => - if S (P) = ASCII.ESC then - V := Get_UTF_32 (In_Char, EM); - return; - end if; - - when WCEM_Upper | WCEM_Shift_JIS | WCEM_EUC | WCEM_UTF8 => - if S (P) >= Character'Val (16#80#) then - V := Get_UTF_32 (In_Char, EM); - return; - end if; - - when WCEM_Brackets => - if P + 2 <= S'Last - and then S (P) = '[' - and then S (P + 1) = '"' - and then S (P + 2) /= '"' - then - V := Get_UTF_32 (In_Char, EM); - return; - end if; - end case; - - -- If it is not a wide character code, just get it - - V := Character'Pos (S (P)); - P := P + 1; - end Get_Next_Code; - - --------------------------- - -- String_To_Wide_String -- - --------------------------- - - procedure String_To_Wide_String - (S : String; - R : out Wide_String; - L : out Natural; - EM : System.WCh_Con.WC_Encoding_Method) - is - SP : Natural; - V : UTF_32_Code; - - begin - pragma Assert (S'First = 1); - - SP := S'First; - L := 0; - while SP <= S'Last loop - Get_Next_Code (S, SP, V, EM); - - if V > 16#FFFF# then - raise Constraint_Error with - "out of range value for wide character"; - end if; - - L := L + 1; - R (L) := Wide_Character'Val (V); - end loop; - end String_To_Wide_String; - - -------------------------------- - -- String_To_Wide_Wide_String -- - -------------------------------- - - procedure String_To_Wide_Wide_String - (S : String; - R : out Wide_Wide_String; - L : out Natural; - EM : System.WCh_Con.WC_Encoding_Method) - is - pragma Assert (S'First = 1); - - SP : Natural; - V : UTF_32_Code; - - begin - SP := S'First; - L := 0; - while SP <= S'Last loop - Get_Next_Code (S, SP, V, EM); - L := L + 1; - R (L) := Wide_Wide_Character'Val (V); - end loop; - end String_To_Wide_Wide_String; - -end System.WCh_StW; diff --git a/gcc/ada/s-wchstw.ads b/gcc/ada/s-wchstw.ads deleted file mode 100644 index 7445c59..0000000 --- a/gcc/ada/s-wchstw.ads +++ /dev/null @@ -1,69 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ S T W -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used to convert strings to wide (wide) --- strings for use by wide (wide) image attribute. - -with System.WCh_Con; - -package System.WCh_StW is - pragma Pure; - - procedure String_To_Wide_String - (S : String; - R : out Wide_String; - L : out Natural; - EM : System.WCh_Con.WC_Encoding_Method); - -- This routine simply takes its argument and converts it to wide string - -- format, storing the result in R (1 .. L), with L being set appropriately - -- on return. The caller guarantees that R is long enough to accommodate - -- the result. This is used in the context of the Wide_Image attribute, - -- where the argument is the corresponding 'Image attribute. Any wide - -- character escape sequences in the string are converted to the - -- corresponding wide character value. No syntax checks are made, it is - -- assumed that any such sequences are validly formed (this must be assured - -- by the caller), and results from the fact that Wide_Image is only used - -- on strings that have been built by the compiler, such as images of - -- enumeration literals. If the method for encoding is a shift-in, - -- shift-out convention, then it is assumed that normal (non-wide - -- character) mode holds at the start and end of the argument string. EM - -- indicates the wide character encoding method. - -- Note: in the WCEM_Brackets case, the brackets escape sequence is used - -- only for codes greater than 16#FF#. - - procedure String_To_Wide_Wide_String - (S : String; - R : out Wide_Wide_String; - L : out Natural; - EM : System.WCh_Con.WC_Encoding_Method); - -- Same function with Wide_Wide_String output - -end System.WCh_StW; diff --git a/gcc/ada/s-wchwts.adb b/gcc/ada/s-wchwts.adb deleted file mode 100644 index 895221e..0000000 --- a/gcc/ada/s-wchwts.adb +++ /dev/null @@ -1,122 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ W T S -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.WCh_Con; use System.WCh_Con; -with System.WCh_Cnv; use System.WCh_Cnv; - -package body System.WCh_WtS is - - ----------------------- - -- Local Subprograms -- - ----------------------- - - procedure Store_UTF_32_Character - (U : UTF_32_Code; - S : out String; - P : in out Integer; - EM : WC_Encoding_Method); - -- Stores the string representation of the wide or wide wide character - -- whose code is given as U, starting at S (P + 1). P is incremented to - -- point to the last character stored. Raises CE if character cannot be - -- stored using the given encoding method. - - ---------------------------- - -- Store_UTF_32_Character -- - ---------------------------- - - procedure Store_UTF_32_Character - (U : UTF_32_Code; - S : out String; - P : in out Integer; - EM : WC_Encoding_Method) - is - procedure Out_Char (C : Character); - pragma Inline (Out_Char); - -- Procedure to increment P and store C at S (P) - - procedure Store_Chars is new UTF_32_To_Char_Sequence (Out_Char); - - -------------- - -- Out_Char -- - -------------- - - procedure Out_Char (C : Character) is - begin - P := P + 1; - S (P) := C; - end Out_Char; - - begin - Store_Chars (U, EM); - end Store_UTF_32_Character; - - --------------------------- - -- Wide_String_To_String -- - --------------------------- - - function Wide_String_To_String - (S : Wide_String; - EM : WC_Encoding_Method) return String - is - R : String (S'First .. S'First + 5 * S'Length); -- worst case length - RP : Natural; - - begin - RP := R'First - 1; - for SP in S'Range loop - Store_UTF_32_Character (Wide_Character'Pos (S (SP)), R, RP, EM); - end loop; - - return R (R'First .. RP); - end Wide_String_To_String; - - -------------------------------- - -- Wide_Wide_String_To_String -- - -------------------------------- - - function Wide_Wide_String_To_String - (S : Wide_Wide_String; - EM : WC_Encoding_Method) return String - is - R : String (S'First .. S'First + 7 * S'Length); -- worst case length - RP : Natural; - - begin - RP := R'First - 1; - - for SP in S'Range loop - Store_UTF_32_Character (Wide_Wide_Character'Pos (S (SP)), R, RP, EM); - end loop; - - return R (R'First .. RP); - end Wide_Wide_String_To_String; - -end System.WCh_WtS; diff --git a/gcc/ada/s-wchwts.ads b/gcc/ada/s-wchwts.ads deleted file mode 100644 index 56914e6..0000000 --- a/gcc/ada/s-wchwts.ads +++ /dev/null @@ -1,63 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W C H _ W T S -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used to convert wide strings and wide --- wide strings to strings for use by wide and wide wide character attributes --- (value, image etc.) and also by the numeric IO subpackages of --- Ada.Text_IO.Wide_Text_IO and Ada.Text_IO.Wide_Wide_Text_IO. - -with System.WCh_Con; - -package System.WCh_WtS is - pragma Pure; - - function Wide_String_To_String - (S : Wide_String; - EM : System.WCh_Con.WC_Encoding_Method) return String; - -- This routine simply takes its argument and converts it to a string, - -- using the internal compiler escape sequence convention (defined in - -- package Widechar) to translate characters that are out of range - -- of type String. In the context of the Wide_Value attribute, the - -- argument is the original attribute argument, and the result is used - -- in a call to the corresponding Value attribute function. If the method - -- for encoding is a shift-in, shift-out convention, then it is assumed - -- that normal (non-wide character) mode holds at the start and end of - -- the result string. EM indicates the wide character encoding method. - -- Note: in the WCEM_Brackets case, we only use the brackets encoding - -- for characters greater than 16#FF#. The lowest index of the returned - -- String is equal to S'First. - - function Wide_Wide_String_To_String - (S : Wide_Wide_String; - EM : System.WCh_Con.WC_Encoding_Method) return String; - -- Same processing, except for Wide_Wide_String - -end System.WCh_WtS; diff --git a/gcc/ada/s-widboo.adb b/gcc/ada/s-widboo.adb deleted file mode 100644 index a6e4663..0000000 --- a/gcc/ada/s-widboo.adb +++ /dev/null @@ -1,51 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ B O O L -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Wid_Bool is - - ------------------- - -- Width_Boolean -- - ------------------- - - function Width_Boolean (Lo, Hi : Boolean) return Natural is - begin - if Lo > Hi then - return 0; - - elsif Lo = False then - return 5; - - else - return 4; - end if; - end Width_Boolean; - -end System.Wid_Bool; diff --git a/gcc/ada/s-widboo.ads b/gcc/ada/s-widboo.ads deleted file mode 100644 index 9aa465b..0000000 --- a/gcc/ada/s-widboo.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ B O O L -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for Boolean'Width - -package System.Wid_Bool is - pragma Pure; - - function Width_Boolean (Lo, Hi : Boolean) return Natural; - -- Compute Width attribute for non-static type derived from Boolean. - -- The arguments are the low and high bounds for the type. - -end System.Wid_Bool; diff --git a/gcc/ada/s-widcha.adb b/gcc/ada/s-widcha.adb deleted file mode 100644 index c8fd299..0000000 --- a/gcc/ada/s-widcha.adb +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Wid_Char is - - --------------------- - -- Width_Character -- - --------------------- - - function Width_Character (Lo, Hi : Character) return Natural is - W : Natural; - - begin - W := 0; - - for C in Lo .. Hi loop - declare - S : constant String := Character'Image (C); - - begin - W := Natural'Max (W, S'Length); - end; - end loop; - - return W; - end Width_Character; - -end System.Wid_Char; diff --git a/gcc/ada/s-widcha.ads b/gcc/ada/s-widcha.ads deleted file mode 100644 index cfea764..0000000 --- a/gcc/ada/s-widcha.ads +++ /dev/null @@ -1,41 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for Character'Width - -package System.Wid_Char is - pragma Pure; - - function Width_Character (Lo, Hi : Character) return Natural; - -- Compute Width attribute for non-static type derived from Character. - -- The arguments are the low and high bounds for the type. - -end System.Wid_Char; diff --git a/gcc/ada/s-widenu.adb b/gcc/ada/s-widenu.adb deleted file mode 100644 index 0873142..0000000 --- a/gcc/ada/s-widenu.adb +++ /dev/null @@ -1,135 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ E N U M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Ada.Unchecked_Conversion; - -package body System.Wid_Enum is - - ------------------------- - -- Width_Enumeration_8 -- - ------------------------- - - function Width_Enumeration_8 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural) - return Natural - is - pragma Warnings (Off, Names); - - W : Natural; - - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - - for J in Lo .. Hi loop - W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); - end loop; - - return W; - end Width_Enumeration_8; - - -------------------------- - -- Width_Enumeration_16 -- - -------------------------- - - function Width_Enumeration_16 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural) - return Natural - is - pragma Warnings (Off, Names); - - W : Natural; - - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - - for J in Lo .. Hi loop - W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); - end loop; - - return W; - end Width_Enumeration_16; - - -------------------------- - -- Width_Enumeration_32 -- - -------------------------- - - function Width_Enumeration_32 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural) - return Natural - is - pragma Warnings (Off, Names); - - W : Natural; - - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - - for J in Lo .. Hi loop - W := Natural'Max (W, Natural (IndexesT (J + 1) - IndexesT (J))); - end loop; - - return W; - end Width_Enumeration_32; - -end System.Wid_Enum; diff --git a/gcc/ada/s-widenu.ads b/gcc/ada/s-widenu.ads deleted file mode 100644 index 3cdb532..0000000 --- a/gcc/ada/s-widenu.ads +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ E N U M -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for Enumeration_Type'Width - -package System.Wid_Enum is - pragma Pure; - - function Width_Enumeration_8 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural) - return Natural; - -- Used to compute Enum'Width where Enum is some enumeration subtype - -- other than those defined in package Standard. Names is a string with - -- a lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address - -- of an array of type array (0 .. N) of Natural_8, where N is the - -- number of enumeration literals in the type. The Indexes values are - -- the starting subscript of each enumeration literal, indexed by Pos - -- values, with an extra entry at the end containing Names'Length + 1. - -- The reason that Indexes is passed by address is that the actual type - -- is created on the fly by the expander. - -- - -- Lo and Hi are the Pos values of the lower and upper bounds of the - -- subtype. The result is the value of Width, i.e. the maximum value - -- of the length of any enumeration literal in the given range. - - function Width_Enumeration_16 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural) - return Natural; - -- Identical to Width_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_16 for the Indexes table. - - function Width_Enumeration_32 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural) - return Natural; - -- Identical to Width_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_32 for the Indexes table. - -end System.Wid_Enum; diff --git a/gcc/ada/s-widlli.adb b/gcc/ada/s-widlli.adb deleted file mode 100644 index 4d0aa3a..0000000 --- a/gcc/ada/s-widlli.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ L L I -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Wid_LLI is - - ----------------------------- - -- Width_Long_Long_Integer -- - ----------------------------- - - function Width_Long_Long_Integer - (Lo, Hi : Long_Long_Integer) - return Natural - is - W : Natural; - T : Long_Long_Integer; - - begin - if Lo > Hi then - return 0; - - else - -- Minimum value is 2, one for sign, one for digit - - W := 2; - - -- Get max of absolute values, but avoid bomb if we have the maximum - -- negative number (note that First + 1 has same digits as First) - - T := Long_Long_Integer'Max ( - abs (Long_Long_Integer'Max (Lo, Long_Long_Integer'First + 1)), - abs (Long_Long_Integer'Max (Hi, Long_Long_Integer'First + 1))); - - -- Increase value if more digits required - - while T >= 10 loop - T := T / 10; - W := W + 1; - end loop; - - return W; - end if; - - end Width_Long_Long_Integer; - -end System.Wid_LLI; diff --git a/gcc/ada/s-widlli.ads b/gcc/ada/s-widlli.ads deleted file mode 100644 index bbc3f03..0000000 --- a/gcc/ada/s-widlli.ads +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ L L I -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for Width attribute for all --- non-static signed integer subtypes. Note we only have one routine, --- since this seems a fairly marginal function. - -package System.Wid_LLI is - pragma Pure; - - function Width_Long_Long_Integer - (Lo, Hi : Long_Long_Integer) - return Natural; - -- Compute Width attribute for non-static type derived from a signed - -- Integer type. The arguments Lo, Hi are the bounds of the type. - -end System.Wid_LLI; diff --git a/gcc/ada/s-widllu.adb b/gcc/ada/s-widllu.adb deleted file mode 100644 index 8f30f80..0000000 --- a/gcc/ada/s-widllu.adb +++ /dev/null @@ -1,73 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ L L U -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.Unsigned_Types; use System.Unsigned_Types; - -package body System.Wid_LLU is - - ------------------------------ - -- Width_Long_Long_Unsigned -- - ------------------------------ - - function Width_Long_Long_Unsigned - (Lo, Hi : Long_Long_Unsigned) - return Natural - is - W : Natural; - T : Long_Long_Unsigned; - - begin - if Lo > Hi then - return 0; - - else - -- Minimum value is 2, one for sign, one for digit - - W := 2; - - -- Get max of absolute values, but avoid bomb if we have the maximum - -- negative number (note that First + 1 has same digits as First) - - T := Long_Long_Unsigned'Max (Lo, Hi); - - -- Increase value if more digits required - - while T >= 10 loop - T := T / 10; - W := W + 1; - end loop; - - return W; - end if; - - end Width_Long_Long_Unsigned; - -end System.Wid_LLU; diff --git a/gcc/ada/s-widllu.ads b/gcc/ada/s-widllu.ads deleted file mode 100644 index 7f1fd5d..0000000 --- a/gcc/ada/s-widllu.ads +++ /dev/null @@ -1,47 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ L L U -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for Width attribute for all --- non-static unsigned integer (modular integer) subtypes. Note we only --- have one routine, since this seems a fairly marginal function. - -with System.Unsigned_Types; - -package System.Wid_LLU is - pragma Pure; - - function Width_Long_Long_Unsigned - (Lo, Hi : System.Unsigned_Types.Long_Long_Unsigned) - return Natural; - -- Compute Width attribute for non-static type derived from a modular - -- integer type. The arguments Lo, Hi are the bounds of the type. - -end System.Wid_LLU; diff --git a/gcc/ada/s-widwch.adb b/gcc/ada/s-widwch.adb deleted file mode 100644 index 5d9df7b..0000000 --- a/gcc/ada/s-widwch.adb +++ /dev/null @@ -1,104 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ W C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.Wid_WChar is - - -------------------------- - -- Width_Wide_Character -- - -------------------------- - - function Width_Wide_Character - (Lo, Hi : Wide_Character) return Natural - is - W : Natural; - P : Natural; - - begin - W := 0; - for C in Lo .. Hi loop - P := Wide_Character'Pos (C); - - -- Here if we find a character in wide character range - -- Width is max value (12) for Hex_hhhhhhhh - - if P > 16#FF# then - return 12; - - -- If we are in character range then use length of character image - - else - declare - S : constant String := Character'Image (Character'Val (P)); - begin - W := Natural'Max (W, S'Length); - end; - end if; - end loop; - - return W; - end Width_Wide_Character; - - ------------------------------- - -- Width_Wide_Wide_Character -- - ------------------------------- - - function Width_Wide_Wide_Character - (Lo, Hi : Wide_Wide_Character) return Natural - is - W : Natural; - P : Natural; - - begin - W := 0; - for C in Lo .. Hi loop - P := Wide_Wide_Character'Pos (C); - - -- Here if we find a character in wide wide character range. - -- Width is max value (12) for Hex_hhhhhhhh - - if P > 16#FF# then - W := 12; - - -- If we are in character range then use length of character image - - else - declare - S : constant String := Character'Image (Character'Val (P)); - begin - W := Natural'Max (W, S'Length); - end; - end if; - end loop; - - return W; - end Width_Wide_Wide_Character; - -end System.Wid_WChar; diff --git a/gcc/ada/s-widwch.ads b/gcc/ada/s-widwch.ads deleted file mode 100644 index 244db86..0000000 --- a/gcc/ada/s-widwch.ads +++ /dev/null @@ -1,46 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I D _ W C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routines used for Wide_[Wide_]Character'Width - -package System.Wid_WChar is - pragma Pure; - - function Width_Wide_Character - (Lo, Hi : Wide_Character) return Natural; - -- Compute Width attribute for non-static type derived from Wide_Character. - -- The arguments are the low and high bounds for the type. - - function Width_Wide_Wide_Character - (Lo, Hi : Wide_Wide_Character) return Natural; - -- Same function for type derived from Wide_Wide_Character - -end System.Wid_WChar; diff --git a/gcc/ada/s-win32.ads b/gcc/ada/s-win32.ads deleted file mode 100644 index 6fafd52..0000000 --- a/gcc/ada/s-win32.ads +++ /dev/null @@ -1,342 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I N 3 2 -- --- -- --- S p e c -- --- -- --- Copyright (C) 2008-2013, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package plus its child provide the low level interface to the Win32 --- API. The core part of the Win32 API (common to RTX and Win32) is in this --- package, and an additional part of the Win32 API which is not supported by --- RTX is in package System.Win32.Ext. - -with Interfaces.C; - -package System.Win32 is - pragma Pure; - - ------------------- - -- General Types -- - ------------------- - - -- The LARGE_INTEGER type is actually a fixed point type - -- that only can represent integers. The reason for this is - -- easier conversion to Duration or other fixed point types. - -- (See System.OS_Primitives.Clock, mingw and rtx versions.) - - type LARGE_INTEGER is delta 1.0 range -2.0**63 .. 2.0**63 - 1.0; - - subtype PVOID is Address; - - type HANDLE is new Interfaces.C.ptrdiff_t; - - INVALID_HANDLE_VALUE : constant HANDLE := -1; - INVALID_FILE_SIZE : constant := 16#FFFFFFFF#; - - type DWORD is new Interfaces.C.unsigned_long; - type WORD is new Interfaces.C.unsigned_short; - type BYTE is new Interfaces.C.unsigned_char; - type LONG is new Interfaces.C.long; - type CHAR is new Interfaces.C.char; - - type BOOL is new Interfaces.C.int; - for BOOL'Size use Interfaces.C.int'Size; - - type Bits1 is range 0 .. 2 ** 1 - 1; - type Bits2 is range 0 .. 2 ** 2 - 1; - type Bits17 is range 0 .. 2 ** 17 - 1; - for Bits1'Size use 1; - for Bits2'Size use 2; - for Bits17'Size use 17; - - -- Note that the following clashes with standard names are to stay - -- compatible with the historical choice of following the C names. - - pragma Warnings (Off); - FALSE : constant := 0; - TRUE : constant := 1; - pragma Warnings (On); - - function GetLastError return DWORD; - pragma Import (Stdcall, GetLastError, "GetLastError"); - - ----------- - -- Files -- - ----------- - - CP_UTF8 : constant := 65001; - CP_ACP : constant := 0; - - GENERIC_READ : constant := 16#80000000#; - GENERIC_WRITE : constant := 16#40000000#; - - CREATE_NEW : constant := 1; - CREATE_ALWAYS : constant := 2; - OPEN_EXISTING : constant := 3; - OPEN_ALWAYS : constant := 4; - TRUNCATE_EXISTING : constant := 5; - - FILE_SHARE_DELETE : constant := 16#00000004#; - FILE_SHARE_READ : constant := 16#00000001#; - FILE_SHARE_WRITE : constant := 16#00000002#; - - FILE_BEGIN : constant := 0; - FILE_CURRENT : constant := 1; - FILE_END : constant := 2; - - PAGE_NOACCESS : constant := 16#0001#; - PAGE_READONLY : constant := 16#0002#; - PAGE_READWRITE : constant := 16#0004#; - PAGE_WRITECOPY : constant := 16#0008#; - PAGE_EXECUTE : constant := 16#0010#; - - FILE_MAP_ALL_ACCESS : constant := 16#F001f#; - FILE_MAP_READ : constant := 4; - FILE_MAP_WRITE : constant := 2; - FILE_MAP_COPY : constant := 1; - - FILE_ADD_FILE : constant := 16#0002#; - FILE_ADD_SUBDIRECTORY : constant := 16#0004#; - FILE_APPEND_DATA : constant := 16#0004#; - FILE_CREATE_PIPE_INSTANCE : constant := 16#0004#; - FILE_DELETE_CHILD : constant := 16#0040#; - FILE_EXECUTE : constant := 16#0020#; - FILE_LIST_DIRECTORY : constant := 16#0001#; - FILE_READ_ATTRIBUTES : constant := 16#0080#; - FILE_READ_DATA : constant := 16#0001#; - FILE_READ_EA : constant := 16#0008#; - FILE_TRAVERSE : constant := 16#0020#; - FILE_WRITE_ATTRIBUTES : constant := 16#0100#; - FILE_WRITE_DATA : constant := 16#0002#; - FILE_WRITE_EA : constant := 16#0010#; - STANDARD_RIGHTS_READ : constant := 16#20000#; - STANDARD_RIGHTS_WRITE : constant := 16#20000#; - SYNCHRONIZE : constant := 16#100000#; - - FILE_ATTRIBUTE_READONLY : constant := 16#00000001#; - FILE_ATTRIBUTE_HIDDEN : constant := 16#00000002#; - FILE_ATTRIBUTE_SYSTEM : constant := 16#00000004#; - FILE_ATTRIBUTE_DIRECTORY : constant := 16#00000010#; - FILE_ATTRIBUTE_ARCHIVE : constant := 16#00000020#; - FILE_ATTRIBUTE_DEVICE : constant := 16#00000040#; - FILE_ATTRIBUTE_NORMAL : constant := 16#00000080#; - FILE_ATTRIBUTE_TEMPORARY : constant := 16#00000100#; - FILE_ATTRIBUTE_SPARSE_FILE : constant := 16#00000200#; - FILE_ATTRIBUTE_REPARSE_POINT : constant := 16#00000400#; - FILE_ATTRIBUTE_COMPRESSED : constant := 16#00000800#; - FILE_ATTRIBUTE_OFFLINE : constant := 16#00001000#; - FILE_ATTRIBUTE_NOT_CONTENT_INDEXED : constant := 16#00002000#; - FILE_ATTRIBUTE_ENCRYPTED : constant := 16#00004000#; - FILE_ATTRIBUTE_VALID_FLAGS : constant := 16#00007fb7#; - FILE_ATTRIBUTE_VALID_SET_FLAGS : constant := 16#000031a7#; - - GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS : constant := 16#00000004#; - - type OVERLAPPED is record - Internal : DWORD; - InternalHigh : DWORD; - Offset : DWORD; - OffsetHigh : DWORD; - hEvent : HANDLE; - end record; - - type SECURITY_ATTRIBUTES is record - nLength : DWORD; - pSecurityDescriptor : PVOID; - bInheritHandle : BOOL; - end record; - - function CreateFileA - (lpFileName : Address; - dwDesiredAccess : DWORD; - dwShareMode : DWORD; - lpSecurityAttributes : access SECURITY_ATTRIBUTES; - dwCreationDisposition : DWORD; - dwFlagsAndAttributes : DWORD; - hTemplateFile : HANDLE) return HANDLE; - pragma Import (Stdcall, CreateFileA, "CreateFileA"); - - function CreateFile - (lpFileName : Address; - dwDesiredAccess : DWORD; - dwShareMode : DWORD; - lpSecurityAttributes : access SECURITY_ATTRIBUTES; - dwCreationDisposition : DWORD; - dwFlagsAndAttributes : DWORD; - hTemplateFile : HANDLE) return HANDLE; - pragma Import (Stdcall, CreateFile, "CreateFileW"); - - function GetFileSize - (hFile : HANDLE; - lpFileSizeHigh : access DWORD) return BOOL; - pragma Import (Stdcall, GetFileSize, "GetFileSize"); - - function SetFilePointer - (hFile : HANDLE; - lDistanceToMove : LONG; - lpDistanceToMoveHigh : access LONG; - dwMoveMethod : DWORD) return DWORD; - pragma Import (Stdcall, SetFilePointer, "SetFilePointer"); - - function WriteFile - (hFile : HANDLE; - lpBuffer : Address; - nNumberOfBytesToWrite : DWORD; - lpNumberOfBytesWritten : access DWORD; - lpOverlapped : access OVERLAPPED) return BOOL; - pragma Import (Stdcall, WriteFile, "WriteFile"); - - function ReadFile - (hFile : HANDLE; - lpBuffer : Address; - nNumberOfBytesToRead : DWORD; - lpNumberOfBytesRead : access DWORD; - lpOverlapped : access OVERLAPPED) return BOOL; - pragma Import (Stdcall, ReadFile, "ReadFile"); - - function CloseHandle (hObject : HANDLE) return BOOL; - pragma Import (Stdcall, CloseHandle, "CloseHandle"); - - function CreateFileMapping - (hFile : HANDLE; - lpSecurityAttributes : access SECURITY_ATTRIBUTES; - flProtect : DWORD; - dwMaximumSizeHigh : DWORD; - dwMaximumSizeLow : DWORD; - lpName : Address) return HANDLE; - pragma Import (Stdcall, CreateFileMapping, "CreateFileMappingA"); - - function MapViewOfFile - (hFileMappingObject : HANDLE; - dwDesiredAccess : DWORD; - dwFileOffsetHigh : DWORD; - dwFileOffsetLow : DWORD; - dwNumberOfBytesToMap : DWORD) return System.Address; - pragma Import (Stdcall, MapViewOfFile, "MapViewOfFile"); - - function UnmapViewOfFile (lpBaseAddress : System.Address) return BOOL; - pragma Import (Stdcall, UnmapViewOfFile, "UnmapViewOfFile"); - - function MultiByteToWideChar - (CodePage : WORD; - dwFlags : DWORD; - lpMultiByteStr : System.Address; - cchMultiByte : WORD; - lpWideCharStr : System.Address; - cchWideChar : WORD) return WORD; - pragma Import (Stdcall, MultiByteToWideChar, "MultiByteToWideChar"); - - ------------------------ - -- System Information -- - ------------------------ - - subtype ProcessorId is DWORD; - - type SYSTEM_INFO is record - dwOemId : DWORD; - dwPageSize : DWORD; - lpMinimumApplicationAddress : PVOID; - lpMaximumApplicationAddress : PVOID; - dwActiveProcessorMask : DWORD; - dwNumberOfProcessors : DWORD; - dwProcessorType : DWORD; - dwAllocationGranularity : DWORD; - dwReserved : DWORD; - end record; - - procedure GetSystemInfo (SI : access SYSTEM_INFO); - pragma Import (Stdcall, GetSystemInfo, "GetSystemInfo"); - - --------------------- - -- Time Management -- - --------------------- - - type SYSTEMTIME is record - wYear : WORD; - wMonth : WORD; - wDayOfWeek : WORD; - wDay : WORD; - wHour : WORD; - wMinute : WORD; - wSecond : WORD; - wMilliseconds : WORD; - end record; - - procedure GetSystemTime (pSystemTime : access SYSTEMTIME); - pragma Import (Stdcall, GetSystemTime, "GetSystemTime"); - - procedure GetSystemTimeAsFileTime (lpFileTime : access Long_Long_Integer); - pragma Import (Stdcall, GetSystemTimeAsFileTime, "GetSystemTimeAsFileTime"); - - function FileTimeToSystemTime - (lpFileTime : access Long_Long_Integer; - lpSystemTime : access SYSTEMTIME) return BOOL; - pragma Import (Stdcall, FileTimeToSystemTime, "FileTimeToSystemTime"); - - function SystemTimeToFileTime - (lpSystemTime : access SYSTEMTIME; - lpFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, SystemTimeToFileTime, "SystemTimeToFileTime"); - - function FileTimeToLocalFileTime - (lpFileTime : access Long_Long_Integer; - lpLocalFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, FileTimeToLocalFileTime, "FileTimeToLocalFileTime"); - - function LocalFileTimeToFileTime - (lpFileTime : access Long_Long_Integer; - lpLocalFileTime : access Long_Long_Integer) return BOOL; - pragma Import (Stdcall, LocalFileTimeToFileTime, "LocalFileTimeToFileTime"); - - procedure Sleep (dwMilliseconds : DWORD); - pragma Import (Stdcall, Sleep, External_Name => "Sleep"); - - function QueryPerformanceCounter - (lpPerformanceCount : access LARGE_INTEGER) return BOOL; - pragma Import - (Stdcall, QueryPerformanceCounter, "QueryPerformanceCounter"); - - ------------ - -- Module -- - ------------ - - function GetModuleHandleEx - (dwFlags : DWORD; - lpModuleName : Address; - phModule : access HANDLE) return BOOL; - pragma Import (Stdcall, GetModuleHandleEx, "GetModuleHandleExA"); - - function GetModuleFileName - (hModule : HANDLE; - lpFilename : Address; - nSize : DWORD) return DWORD; - pragma Import (Stdcall, GetModuleFileName, "GetModuleFileNameA"); - - function FreeLibrary (hModule : HANDLE) return BOOL; - pragma Import (Stdcall, FreeLibrary, "FreeLibrary"); - -end System.Win32; diff --git a/gcc/ada/s-winext.ads b/gcc/ada/s-winext.ads deleted file mode 100644 index 803a648..0000000 --- a/gcc/ada/s-winext.ads +++ /dev/null @@ -1,130 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W I N 3 2 . E X T -- --- -- --- S p e c -- --- -- --- Copyright (C) 2009-2011, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package provides the part of the low level Win32 interface which is --- not supported by RTX (but supported by regular Windows platforms). - -package System.Win32.Ext is - pragma Pure; - - --------------------- - -- Time Management -- - --------------------- - - function QueryPerformanceFrequency - (lpFrequency : access LARGE_INTEGER) return Win32.BOOL; - pragma Import - (Stdcall, QueryPerformanceFrequency, "QueryPerformanceFrequency"); - - --------------- - -- Processor -- - --------------- - - function SetThreadIdealProcessor - (hThread : HANDLE; - dwIdealProcessor : ProcessorId) return DWORD; - pragma Import (Stdcall, SetThreadIdealProcessor, "SetThreadIdealProcessor"); - - function SetThreadAffinityMask - (hThread : HANDLE; - dwThreadAffinityMask : DWORD) return DWORD; - pragma Import (Stdcall, SetThreadAffinityMask, "SetThreadAffinityMask"); - - -------------- - -- Com Port -- - -------------- - - DTR_CONTROL_DISABLE : constant := 16#0#; - RTS_CONTROL_DISABLE : constant := 16#0#; - NOPARITY : constant := 0; - ODDPARITY : constant := 1; - EVENPARITY : constant := 2; - ONESTOPBIT : constant := 0; - TWOSTOPBITS : constant := 2; - - type DCB is record - DCBLENGTH : DWORD; - BaudRate : DWORD; - fBinary : Bits1; - fParity : Bits1; - fOutxCtsFlow : Bits1; - fOutxDsrFlow : Bits1; - fDtrControl : Bits2; - fDsrSensitivity : Bits1; - fTXContinueOnXoff : Bits1; - fOutX : Bits1; - fInX : Bits1; - fErrorChar : Bits1; - fNull : Bits1; - fRtsControl : Bits2; - fAbortOnError : Bits1; - fDummy2 : Bits17; - wReserved : WORD; - XonLim : WORD; - XoffLim : WORD; - ByteSize : BYTE; - Parity : BYTE; - StopBits : BYTE; - XonChar : CHAR; - XoffChar : CHAR; - ErrorChar : CHAR; - EofChar : CHAR; - EvtChar : CHAR; - wReserved1 : WORD; - end record; - pragma Convention (C, DCB); - pragma Pack (DCB); - - type COMMTIMEOUTS is record - ReadIntervalTimeout : DWORD; - ReadTotalTimeoutMultiplier : DWORD; - ReadTotalTimeoutConstant : DWORD; - WriteTotalTimeoutMultiplier : DWORD; - WriteTotalTimeoutConstant : DWORD; - end record; - pragma Convention (C, COMMTIMEOUTS); - - function GetCommState - (hFile : HANDLE; - lpDCB : access DCB) return BOOL; - pragma Import (Stdcall, GetCommState, "GetCommState"); - - function SetCommState - (hFile : HANDLE; - lpDCB : access DCB) return BOOL; - pragma Import (Stdcall, SetCommState, "SetCommState"); - - function SetCommTimeouts - (hFile : HANDLE; - lpCommTimeouts : access COMMTIMEOUTS) return BOOL; - pragma Import (Stdcall, SetCommTimeouts, "SetCommTimeouts"); - -end System.Win32.Ext; diff --git a/gcc/ada/s-wwdcha.adb b/gcc/ada/s-wwdcha.adb deleted file mode 100644 index d7f40e3..0000000 --- a/gcc/ada/s-wwdcha.adb +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W W D _ C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -package body System.WWd_Char is - - -------------------------- - -- Wide_Width_Character -- - -------------------------- - - function Wide_Width_Character (Lo, Hi : Character) return Natural is - W : Natural; - - begin - W := 0; - for C in Lo .. Hi loop - declare - S : constant Wide_String := Character'Wide_Image (C); - begin - W := Natural'Max (W, S'Length); - end; - end loop; - - return W; - end Wide_Width_Character; - - ------------------------------- - -- Wide_Wide_Width_Character -- - ------------------------------- - - function Wide_Wide_Width_Character (Lo, Hi : Character) return Natural is - W : Natural; - - begin - W := 0; - for C in Lo .. Hi loop - declare - S : constant String := Character'Image (C); - begin - W := Natural'Max (W, S'Length); - end; - end loop; - - return W; - end Wide_Wide_Width_Character; - -end System.WWd_Char; diff --git a/gcc/ada/s-wwdcha.ads b/gcc/ada/s-wwdcha.ads deleted file mode 100644 index 04f171d..0000000 --- a/gcc/ada/s-wwdcha.ads +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W W D _ C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains the routine used for Character'Wide_[Wide_]Width - -package System.WWd_Char is - pragma Pure; - - function Wide_Width_Character (Lo, Hi : Character) return Natural; - -- Compute Wide_Width attribute for non-static type derived from - -- Character. The arguments are the low and high bounds for the type. - - function Wide_Wide_Width_Character (Lo, Hi : Character) return Natural; - -- Compute Wide_Wide_Width attribute for non-static type derived from - -- Character. The arguments are the low and high bounds for the type. - -end System.WWd_Char; diff --git a/gcc/ada/s-wwdenu.adb b/gcc/ada/s-wwdenu.adb deleted file mode 100644 index 5006ec5..0000000 --- a/gcc/ada/s-wwdenu.adb +++ /dev/null @@ -1,273 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W W D _ E N U M -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with System.WCh_StW; use System.WCh_StW; -with System.WCh_Con; use System.WCh_Con; - -with Ada.Unchecked_Conversion; - -package body System.WWd_Enum is - - ----------------------------------- - -- Wide_Wide_Width_Enumeration_8 -- - ----------------------------------- - - function Wide_Wide_Width_Enumeration_8 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : WC_Encoding_Method) return Natural - is - W : Natural; - - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - for J in Lo .. Hi loop - declare - S : constant String := - Names (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1); - WS : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String (S, WS, L, EM); - W := Natural'Max (W, L); - end; - end loop; - - return W; - end Wide_Wide_Width_Enumeration_8; - - ------------------------------------ - -- Wide_Wide_Width_Enumeration_16 -- - ------------------------------------ - - function Wide_Wide_Width_Enumeration_16 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : WC_Encoding_Method) return Natural - is - W : Natural; - - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - for J in Lo .. Hi loop - declare - S : constant String := - Names (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1); - WS : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String (S, WS, L, EM); - W := Natural'Max (W, L); - end; - end loop; - - return W; - end Wide_Wide_Width_Enumeration_16; - - ------------------------------------ - -- Wide_Wide_Width_Enumeration_32 -- - ------------------------------------ - - function Wide_Wide_Width_Enumeration_32 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : WC_Encoding_Method) return Natural - is - W : Natural; - - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - for J in Lo .. Hi loop - declare - S : constant String := - Names (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1); - WS : Wide_Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_Wide_String (S, WS, L, EM); - W := Natural'Max (W, L); - end; - end loop; - - return W; - end Wide_Wide_Width_Enumeration_32; - - ------------------------------ - -- Wide_Width_Enumeration_8 -- - ------------------------------ - - function Wide_Width_Enumeration_8 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : WC_Encoding_Method) return Natural - is - W : Natural; - - type Natural_8 is range 0 .. 2 ** 7 - 1; - type Index_Table is array (Natural) of Natural_8; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - for J in Lo .. Hi loop - declare - S : constant String := - Names (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1); - WS : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String (S, WS, L, EM); - W := Natural'Max (W, L); - end; - end loop; - - return W; - end Wide_Width_Enumeration_8; - - ------------------------------- - -- Wide_Width_Enumeration_16 -- - ------------------------------- - - function Wide_Width_Enumeration_16 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : WC_Encoding_Method) return Natural - is - W : Natural; - - type Natural_16 is range 0 .. 2 ** 15 - 1; - type Index_Table is array (Natural) of Natural_16; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - for J in Lo .. Hi loop - declare - S : constant String := - Names (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1); - WS : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String (S, WS, L, EM); - W := Natural'Max (W, L); - end; - end loop; - - return W; - end Wide_Width_Enumeration_16; - - ------------------------------- - -- Wide_Width_Enumeration_32 -- - ------------------------------- - - function Wide_Width_Enumeration_32 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : WC_Encoding_Method) return Natural - is - W : Natural; - - type Natural_32 is range 0 .. 2 ** 31 - 1; - type Index_Table is array (Natural) of Natural_32; - type Index_Table_Ptr is access Index_Table; - - function To_Index_Table_Ptr is - new Ada.Unchecked_Conversion (System.Address, Index_Table_Ptr); - - IndexesT : constant Index_Table_Ptr := To_Index_Table_Ptr (Indexes); - - begin - W := 0; - for J in Lo .. Hi loop - declare - S : constant String := - Names (Natural (IndexesT (J)) .. - Natural (IndexesT (J + 1)) - 1); - WS : Wide_String (1 .. S'Length); - L : Natural; - begin - String_To_Wide_String (S, WS, L, EM); - W := Natural'Max (W, L); - end; - end loop; - - return W; - end Wide_Width_Enumeration_32; - -end System.WWd_Enum; diff --git a/gcc/ada/s-wwdenu.ads b/gcc/ada/s-wwdenu.ads deleted file mode 100644 index c80cc4b..0000000 --- a/gcc/ada/s-wwdenu.ads +++ /dev/null @@ -1,98 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W W D _ E N U M -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines used for Enumeration_Type'Wide_[Wide_]Width - -with System.WCh_Con; - -package System.WWd_Enum is - pragma Pure; - - function Wide_Width_Enumeration_8 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; - -- Used to compute Enum'Wide_Width where Enum is an enumeration subtype - -- other than those defined in package Standard. Names is a string with - -- a lower bound of 1 containing the characters of all the enumeration - -- literals concatenated together in sequence. Indexes is the address - -- of an array of type array (0 .. N) of Natural_8, where N is the - -- number of enumeration literals in the type. The Indexes values are - -- the starting subscript of each enumeration literal, indexed by Pos - -- values, with an extra entry at the end containing Names'Length + 1. - -- The reason that Indexes is passed by address is that the actual type - -- is created on the fly by the expander. - -- - -- Lo and Hi are the Pos values of the lower and upper bounds of the - -- subtype. The result is the value of Width, i.e. the maximum value - -- of the length of any enumeration literal in the given range. The - -- fifth parameter, EM, is the wide character encoding method used in - -- the Names table. - - function Wide_Width_Enumeration_16 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; - -- Identical to Wide_Width_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_16 for the Indexes table. - - function Wide_Width_Enumeration_32 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; - -- Identical to Wide_Width_Enumeration_8 except that it handles types - -- using array (0 .. Num) of Natural_32 for the Indexes table. - - function Wide_Wide_Width_Enumeration_8 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; - -- Same function for Wide_Wide_Width attribute - - function Wide_Wide_Width_Enumeration_16 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; - -- Same function for Wide_Wide_Width attribute - - function Wide_Wide_Width_Enumeration_32 - (Names : String; - Indexes : System.Address; - Lo, Hi : Natural; - EM : System.WCh_Con.WC_Encoding_Method) return Natural; - -- Same function for Wide_Wide_Width attribute - -end System.WWd_Enum; diff --git a/gcc/ada/s-wwdwch.adb b/gcc/ada/s-wwdwch.adb deleted file mode 100644 index 001680e..0000000 --- a/gcc/ada/s-wwdwch.adb +++ /dev/null @@ -1,130 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W W D _ W C H A R -- --- -- --- B o d y -- --- -- --- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - -with Interfaces; use Interfaces; - -with System.WWd_Char; - -package body System.Wwd_WChar is - - ------------------------------------ - -- Wide_Wide_Width_Wide_Character -- - ------------------------------------ - - -- This is the case where we are talking about the Wide_Wide_Image of - -- a Wide_Character, which is always the same character sequence as the - -- Wide_Image of the same Wide_Character. - - function Wide_Wide_Width_Wide_Character - (Lo, Hi : Wide_Character) return Natural - is - begin - return Wide_Width_Wide_Character (Lo, Hi); - end Wide_Wide_Width_Wide_Character; - - ------------------------------------ - -- Wide_Wide_Width_Wide_Wide_Char -- - ------------------------------------ - - function Wide_Wide_Width_Wide_Wide_Char - (Lo, Hi : Wide_Wide_Character) return Natural - is - LV : constant Unsigned_32 := Wide_Wide_Character'Pos (Lo); - HV : constant Unsigned_32 := Wide_Wide_Character'Pos (Hi); - - begin - -- Return zero if empty range - - if LV > HV then - return 0; - - -- Return max value (12) for wide character (Hex_hhhhhhhh) - - elsif HV > 255 then - return 12; - - -- If any characters in normal character range, then use normal - -- Wide_Wide_Width attribute on this range to find out a starting point. - -- Otherwise start with zero. - - else - return - System.WWd_Char.Wide_Wide_Width_Character - (Lo => Character'Val (LV), - Hi => Character'Val (Unsigned_32'Min (255, HV))); - end if; - end Wide_Wide_Width_Wide_Wide_Char; - - ------------------------------- - -- Wide_Width_Wide_Character -- - ------------------------------- - - function Wide_Width_Wide_Character - (Lo, Hi : Wide_Character) return Natural - is - LV : constant Unsigned_32 := Wide_Character'Pos (Lo); - HV : constant Unsigned_32 := Wide_Character'Pos (Hi); - - begin - -- Return zero if empty range - - if LV > HV then - return 0; - - -- Return max value (12) for wide character (Hex_hhhhhhhh) - - elsif HV > 255 then - return 12; - - -- If any characters in normal character range, then use normal - -- Wide_Wide_Width attribute on this range to find out a starting point. - -- Otherwise start with zero. - - else - return - System.WWd_Char.Wide_Width_Character - (Lo => Character'Val (LV), - Hi => Character'Val (Unsigned_32'Min (255, HV))); - end if; - end Wide_Width_Wide_Character; - - ------------------------------------ - -- Wide_Width_Wide_Wide_Character -- - ------------------------------------ - - function Wide_Width_Wide_Wide_Character - (Lo, Hi : Wide_Wide_Character) return Natural - is - begin - return Wide_Wide_Width_Wide_Wide_Char (Lo, Hi); - end Wide_Width_Wide_Wide_Character; - -end System.Wwd_WChar; diff --git a/gcc/ada/s-wwdwch.ads b/gcc/ada/s-wwdwch.ads deleted file mode 100644 index ecdd93f..0000000 --- a/gcc/ada/s-wwdwch.ads +++ /dev/null @@ -1,61 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M . W W D _ W C H A R -- --- -- --- S p e c -- --- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- --- -- --- GNAT is free software; you can redistribute it and/or modify it under -- --- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This package contains routines for [Wide_]Wide_Character'[Wide_]Wide_Width - -package System.Wwd_WChar is - pragma Pure; - - function Wide_Width_Wide_Character - (Lo, Hi : Wide_Character) return Natural; - -- Compute Wide_Width attribute for non-static type derived from - -- Wide_Character. The arguments are the low and high bounds for - -- the type. EM is the wide-character encoding method. - - function Wide_Width_Wide_Wide_Character - (Lo, Hi : Wide_Wide_Character) return Natural; - -- Compute Wide_Width attribute for non-static type derived from - -- Wide_Wide_Character. The arguments are the low and high bounds for - -- the type. EM is the wide-character encoding method. - - function Wide_Wide_Width_Wide_Character - (Lo, Hi : Wide_Character) return Natural; - -- Compute Wide_Wide_Width attribute for non-static type derived from - -- Wide_Character. The arguments are the low and high bounds for - -- the type. EM is the wide-character encoding method. - - function Wide_Wide_Width_Wide_Wide_Char - (Lo, Hi : Wide_Wide_Character) return Natural; - -- Compute Wide_Wide_Width attribute for non-static type derived from - -- Wide_Wide_Character. The arguments are the low and high bounds for - -- the type. EM is the wide-character encoding method. - -end System.Wwd_WChar; diff --git a/gcc/ada/sequenio.ads b/gcc/ada/sequenio.ads deleted file mode 100644 index ad1d7fa1..0000000 --- a/gcc/ada/sequenio.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S E Q U E N T I A L _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Ada_2012; --- Explicit setting of Ada 2012 mode is required here, since we want to with a --- child unit (not possible in Ada 83 mode), and Sequential_IO is not --- considered to be an internal unit that is automatically compiled in Ada --- 2012 mode (since a user is allowed to redeclare Sequential_IO). - -with Ada.Sequential_IO; - -generic package Sequential_IO renames Ada.Sequential_IO; diff --git a/gcc/ada/system-aix.ads b/gcc/ada/system-aix.ads deleted file mode 100644 index 95815b4..0000000 --- a/gcc/ada/system-aix.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (AIX/PPC Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- 0 .. 126 corresponds to the system priority range 1 .. 127. - -- - -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use - -- of the entire range provided by the system. - -- - -- If the scheduling policy is SCHED_OTHER the only valid system priority - -- is 1 and that is the only value ever passed to the system, regardless of - -- how priorities are set by user programs. - - Max_Priority : constant Positive := 125; - Max_Interrupt_Priority : constant Positive := 126; - - subtype Any_Priority is Integer range 0 .. 126; - subtype Priority is Any_Priority range 0 .. 125; - subtype Interrupt_Priority is Any_Priority range 126 .. 126; - - Default_Priority : constant Priority := - (Priority'First + Priority'Last) / 2; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-darwin-arm.ads b/gcc/ada/system-darwin-arm.ads deleted file mode 100644 index 9b96bf9..0000000 --- a/gcc/ada/system-darwin-arm.ads +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Darwin/ARM Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- The values defined here are derived from the following Darwin - -- sources: - -- - -- Libc/pthreads/pthread.c - -- pthread_init calls host_info to retrieve the HOST_PRIORITY_INFO. - -- This file includes "pthread_internals". - -- Libc/pthreads/pthread_internals.h - -- This file includes . - -- xnu/osfmk/mach/mach.h - -- This file includes . - -- xnu/osfmk/mach/mach_types.h - -- This file includes . - -- xnu/osfmk/mach/host_info.h - -- This file contains the definition of the host_info_t data structure - -- and the function prototype for host_info. - -- xnu/osfmk/kern/host.c - -- This file defines the function host_info which sets the - -- priority_info field of struct host_info_t. This file includes - -- . - -- xnu/osfmk/kern/processor.h - -- This file includes . - -- xnu/osfmk/kern/sched.h - -- This file defines the values for each level of priority. - - Max_Interrupt_Priority : constant Positive := 63; - Max_Priority : constant Positive := Max_Interrupt_Priority - 1; - - subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; - subtype Priority is Any_Priority range 0 .. Max_Priority; - subtype Interrupt_Priority is Any_Priority - range Priority'Last + 1 .. Max_Interrupt_Priority; - - Default_Priority : constant Priority := - (Priority'Last - Priority'First) / 2; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-darwin-ppc.ads b/gcc/ada/system-darwin-ppc.ads deleted file mode 100644 index 7809e14..0000000 --- a/gcc/ada/system-darwin-ppc.ads +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Darwin/PPC Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- The values defined here are derived from the following Darwin - -- sources: - -- - -- Libc/pthreads/pthread.c - -- pthread_init calls host_info to retrieve the HOST_PRIORITY_INFO. - -- This file includes "pthread_internals". - -- Libc/pthreads/pthread_internals.h - -- This file includes . - -- xnu/osfmk/mach/mach.h - -- This file includes . - -- xnu/osfmk/mach/mach_types.h - -- This file includes . - -- xnu/osfmk/mach/host_info.h - -- This file contains the definition of the host_info_t data structure - -- and the function prototype for host_info. - -- xnu/osfmk/kern/host.c - -- This file defines the function host_info which sets the - -- priority_info field of struct host_info_t. This file includes - -- . - -- xnu/osfmk/kern/processor.h - -- This file includes . - -- xnu/osfmk/kern/sched.h - -- This file defines the values for each level of priority. - - Max_Interrupt_Priority : constant Positive := 63; - Max_Priority : constant Positive := Max_Interrupt_Priority - 1; - - subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; - subtype Priority is Any_Priority range 0 .. Max_Priority; - subtype Interrupt_Priority is Any_Priority - range Priority'Last + 1 .. Max_Interrupt_Priority; - - Default_Priority : constant Priority := - (Priority'Last - Priority'First) / 2; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := Word_Size = 64; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-darwin-x86.ads b/gcc/ada/system-darwin-x86.ads deleted file mode 100644 index 7fce587..0000000 --- a/gcc/ada/system-darwin-x86.ads +++ /dev/null @@ -1,174 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Darwin/x86 Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- The values defined here are derived from the following Darwin - -- sources: - -- - -- Libc/pthreads/pthread.c - -- pthread_init calls host_info to retrieve the HOST_PRIORITY_INFO. - -- This file includes "pthread_internals". - -- Libc/pthreads/pthread_internals.h - -- This file includes . - -- xnu/osfmk/mach/mach.h - -- This file includes . - -- xnu/osfmk/mach/mach_types.h - -- This file includes . - -- xnu/osfmk/mach/host_info.h - -- This file contains the definition of the host_info_t data structure - -- and the function prototype for host_info. - -- xnu/osfmk/kern/host.c - -- This file defines the function host_info which sets the - -- priority_info field of struct host_info_t. This file includes - -- . - -- xnu/osfmk/kern/processor.h - -- This file includes . - -- xnu/osfmk/kern/sched.h - -- This file defines the values for each level of priority. - - Max_Interrupt_Priority : constant Positive := 63; - Max_Priority : constant Positive := Max_Interrupt_Priority - 1; - - subtype Any_Priority is Integer range 0 .. Max_Interrupt_Priority; - subtype Priority is Any_Priority range 0 .. Max_Priority; - subtype Interrupt_Priority is Any_Priority - range Priority'Last + 1 .. Max_Interrupt_Priority; - - Default_Priority : constant Priority := - (Priority'Last - Priority'First) / 2; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-djgpp.ads b/gcc/ada/system-djgpp.ads deleted file mode 100644 index 4b0ecd9..0000000 --- a/gcc/ada/system-djgpp.ads +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (DJGPP Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := False; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-dragonfly-x86_64.ads b/gcc/ada/system-dragonfly-x86_64.ads deleted file mode 100644 index 2648b20..0000000 --- a/gcc/ada/system-dragonfly-x86_64.ads +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (DragonFly BSD/x86_64 Version) -- --- -- --- Copyright (C) 1992-2015, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-freebsd.ads b/gcc/ada/system-freebsd.ads deleted file mode 100644 index 4b71e38..0000000 --- a/gcc/ada/system-freebsd.ads +++ /dev/null @@ -1,149 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (FreeBSD Version) -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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 := - Bit_Order'Val (Standard'Default_Bit_Order); - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-hpux-ia64.ads b/gcc/ada/system-hpux-ia64.ads deleted file mode 100644 index b6581e8..0000000 --- a/gcc/ada/system-hpux-ia64.ads +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (HP-UX/ia64 Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := 64; - Memory_Size : constant := 2 ** 64; - - -- Address comparison - - function "<" (Left, Right : Address) return Boolean; - function "<=" (Left, Right : Address) return Boolean; - function ">" (Left, Right : Address) return Boolean; - function ">=" (Left, Right : Address) return Boolean; - function "=" (Left, Right : Address) return Boolean; - - pragma Import (Intrinsic, "<"); - pragma Import (Intrinsic, "<="); - pragma Import (Intrinsic, ">"); - pragma Import (Intrinsic, ">="); - pragma Import (Intrinsic, "="); - - -- Other System-Dependent Declarations - - type Bit_Order is (High_Order_First, Low_Order_First); - Default_Bit_Order : constant Bit_Order := High_Order_First; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-hpux.ads b/gcc/ada/system-hpux.ads deleted file mode 100644 index 852dcac..0000000 --- a/gcc/ada/system-hpux.ads +++ /dev/null @@ -1,223 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (HP-UX Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - -------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - -- For HP/UX DCE Threads, we use the full range of 31 priorities - -- in the Ada model, but map them by compression onto the more limited - -- range of priorities available in HP/UX. - -- For POSIX Threads, this table is ignored. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile with the command: - - -- $ gcc -c -O2 -gnatpgn system.ads - - -- then recompile the run-time parts that depend on this package: - - -- $ gnatmake -a -gnatn -O2 - - -- then force rebuilding your application if you need different options: - - -- $ gnatmake -f - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - - (Priority'First => 16, - - 1 => 17, - 2 => 18, - 3 => 18, - 4 => 18, - 5 => 18, - 6 => 19, - 7 => 19, - 8 => 19, - 9 => 20, - 10 => 20, - 11 => 21, - 12 => 21, - 13 => 22, - 14 => 23, - - Default_Priority => 24, - - 16 => 25, - 17 => 25, - 18 => 25, - 19 => 26, - 20 => 26, - 21 => 26, - 22 => 27, - 23 => 27, - 24 => 27, - 25 => 28, - 26 => 28, - 27 => 29, - 28 => 29, - 29 => 30, - - Priority'Last => 30, - - Interrupt_Priority => 31); - -end System; diff --git a/gcc/ada/system-linux-alpha.ads b/gcc/ada/system-linux-alpha.ads deleted file mode 100644 index e7815343..0000000 --- a/gcc/ada/system-linux-alpha.ads +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/alpha Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 / 1024.0; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-arm.ads b/gcc/ada/system-linux-arm.ads deleted file mode 100644 index e36f38d..0000000 --- a/gcc/ada/system-linux-arm.ads +++ /dev/null @@ -1,157 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/ARM Version) -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Long_Integer'Size; - - -- 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 := - Bit_Order'Val (Standard'Default_Bit_Order); - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- 0 .. 98 corresponds to the system priority range 1 .. 99. - -- - -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use - -- of the entire range provided by the system. - -- - -- If the scheduling policy is SCHED_OTHER the only valid system priority - -- is 1 and other values are simply ignored. - - Max_Priority : constant Positive := 97; - Max_Interrupt_Priority : constant Positive := 98; - - subtype Any_Priority is Integer range 0 .. 98; - subtype Priority is Any_Priority range 0 .. 97; - subtype Interrupt_Priority is Any_Priority range 98 .. 98; - - Default_Priority : constant Priority := 48; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-hppa.ads b/gcc/ada/system-linux-hppa.ads deleted file mode 100644 index 83aba27..0000000 --- a/gcc/ada/system-linux-hppa.ads +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU/Linux-HPPA Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-ia64.ads b/gcc/ada/system-linux-ia64.ads deleted file mode 100644 index 8fe4697..0000000 --- a/gcc/ada/system-linux-ia64.ads +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/ia64 Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- 0 .. 98 corresponds to the system priority range 1 .. 99. - -- - -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use - -- of the entire range provided by the system. - -- - -- If the scheduling policy is SCHED_OTHER the only valid system priority - -- is 1 and other values are simply ignored. - - Max_Priority : constant Positive := 97; - Max_Interrupt_Priority : constant Positive := 98; - - subtype Any_Priority is Integer range 0 .. 98; - subtype Priority is Any_Priority range 0 .. 97; - subtype Interrupt_Priority is Any_Priority range 98 .. 98; - - Default_Priority : constant Priority := 48; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-m68k.ads b/gcc/ada/system-linux-m68k.ads deleted file mode 100644 index 71d4f57..0000000 --- a/gcc/ada/system-linux-m68k.ads +++ /dev/null @@ -1,158 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU/Linux/m68k Version) -- --- -- --- Copyright (C) 2014-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Is the following actually true for GNU/Linux/m68k? - -- - -- 0 .. 98 corresponds to the system priority range 1 .. 99. - -- - -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use - -- of the entire range provided by the system. - -- - -- If the scheduling policy is SCHED_OTHER the only valid system priority - -- is 1 and other values are simply ignored. - - Max_Priority : constant Positive := 97; - Max_Interrupt_Priority : constant Positive := 98; - - subtype Any_Priority is Integer range 0 .. 98; - subtype Priority is Any_Priority range 0 .. 97; - subtype Interrupt_Priority is Any_Priority range 98 .. 98; - - Default_Priority : constant Priority := 48; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-mips.ads b/gcc/ada/system-linux-mips.ads deleted file mode 100644 index f165c94..0000000 --- a/gcc/ada/system-linux-mips.ads +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/MIPS Version) -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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 := - Bit_Order'Val (Standard'Default_Bit_Order); - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-ppc.ads b/gcc/ada/system-linux-ppc.ads deleted file mode 100644 index 367d09f..0000000 --- a/gcc/ada/system-linux-ppc.ads +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/PPC Version) -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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 := - Bit_Order'Val (Standard'Default_Bit_Order); - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- 0 .. 98 corresponds to the system priority range 1 .. 99. - -- - -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use - -- of the entire range provided by the system. - -- - -- If the scheduling policy is SCHED_OTHER the only valid system priority - -- is 1 and other values are simply ignored. - - Max_Priority : constant Positive := 97; - Max_Interrupt_Priority : constant Positive := 98; - - subtype Any_Priority is Integer range 0 .. 98; - subtype Priority is Any_Priority range 0 .. 97; - subtype Interrupt_Priority is Any_Priority range 98 .. 98; - - Default_Priority : constant Priority := 48; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-s390.ads b/gcc/ada/system-linux-s390.ads deleted file mode 100644 index 9bf8375..0000000 --- a/gcc/ada/system-linux-s390.ads +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/s390 Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Long_Integer'Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-sh4.ads b/gcc/ada/system-linux-sh4.ads deleted file mode 100644 index dcd28a0..0000000 --- a/gcc/ada/system-linux-sh4.ads +++ /dev/null @@ -1,155 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/sh4 Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- 0 .. 98 corresponds to the system priority range 1 .. 99. - -- - -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use - -- of the entire range provided by the system. - -- - -- If the scheduling policy is SCHED_OTHER the only valid system priority - -- is 1 and other values are simply ignored. - - Max_Priority : constant Positive := 97; - Max_Interrupt_Priority : constant Positive := 98; - - subtype Any_Priority is Integer range 0 .. 98; - subtype Priority is Any_Priority range 0 .. 97; - subtype Interrupt_Priority is Any_Priority range 98 .. 98; - - Default_Priority : constant Priority := 48; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-sparc.ads b/gcc/ada/system-linux-sparc.ads deleted file mode 100644 index 503adbe..0000000 --- a/gcc/ada/system-linux-sparc.ads +++ /dev/null @@ -1,147 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU/Linux-SPARC Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-linux-x86.ads b/gcc/ada/system-linux-x86.ads deleted file mode 100644 index 533d94e..0000000 --- a/gcc/ada/system-linux-x86.ads +++ /dev/null @@ -1,156 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (GNU-Linux/x86 Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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.000_001; - - -- Storage-related Declarations - - type Address is private; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Long_Integer'Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- 0 .. 98 corresponds to the system priority range 1 .. 99. - -- - -- If the scheduling policy is SCHED_FIFO or SCHED_RR the runtime makes use - -- of the entire range provided by the system. - -- - -- If the scheduling policy is SCHED_OTHER the only valid system priority - -- is 1 and other values are simply ignored. - - Max_Priority : constant Positive := 97; - Max_Interrupt_Priority : constant Positive := 98; - - subtype Any_Priority is Integer range 0 .. 98; - subtype Priority is Any_Priority range 0 .. 97; - subtype Interrupt_Priority is Any_Priority range 98 .. 98; - - Default_Priority : constant Priority := 48; - -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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-mingw.ads b/gcc/ada/system-mingw.ads deleted file mode 100644 index 82b5d0c..0000000 --- a/gcc/ada/system-mingw.ads +++ /dev/null @@ -1,200 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Windows Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - --------------------------- - -- Underlying Priorities -- - --------------------------- - - -- Important note: this section of the file must come AFTER the - -- definition of the system implementation parameters to ensure - -- that the value of these parameters is available for analysis - -- of the declarations here (using Rtsfind at compile time). - - -- The underlying priorities table provides a generalized mechanism - -- for mapping from Ada priorities to system priorities. In some - -- cases a 1-1 mapping is not the convenient or optimal choice. - - type Priorities_Mapping is array (Any_Priority) of Integer; - pragma Suppress_Initialization (Priorities_Mapping); - -- Suppress initialization in case gnat.adc specifies Normalize_Scalars - - Underlying_Priorities : constant Priorities_Mapping := - (Priority'First .. - Default_Priority - 8 => -15, - Default_Priority - 7 => -7, - Default_Priority - 6 => -6, - Default_Priority - 5 => -5, - Default_Priority - 4 => -4, - Default_Priority - 3 => -3, - Default_Priority - 2 => -2, - Default_Priority - 1 => -1, - Default_Priority => 0, - Default_Priority + 1 => 1, - Default_Priority + 2 => 2, - Default_Priority + 3 => 3, - Default_Priority + 4 => 4, - Default_Priority + 5 => 5, - Default_Priority + 6 .. - Priority'Last => 6, - Interrupt_Priority => 15); - -- The default mapping preserves the standard 31 priorities of the Ada - -- model, but maps them using compression onto the 7 priority levels - -- available in NT and on the 16 priority levels available in 2000/XP. - - -- To replace the default values of the Underlying_Priorities mapping, - -- copy this source file into your build directory, edit the file to - -- reflect your desired behavior, and recompile using Makefile.adalib - -- which can be found under the adalib directory of your gnat installation - - pragma Linker_Options ("-Wl,--stack=0x2000000"); - -- This is used to change the default stack (32 MB) size for non tasking - -- programs. We change this value for GNAT on Windows here because the - -- binutils on this platform have switched to a too low value for Ada - -- programs. Note that we also set the stack size for tasking programs in - -- System.Task_Primitives.Operations. - -end System; diff --git a/gcc/ada/system-rtems.ads b/gcc/ada/system-rtems.ads deleted file mode 100644 index ce1ce2b..0000000 --- a/gcc/ada/system-rtems.ads +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Compiler Version) -- --- -- --- Copyright (C) 1992-2016 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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 RTEMS. It is based as closely as possible on the --- generic version with the following exceptions: --- + priority definitions - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := Standard'Storage_Unit; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Standard'Address_Size; - - -- 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 := - Bit_Order'Val (Standard'Default_Bit_Order); - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- RTEMS POSIX threads support 256 priority levels with 255 being - -- logically the most important. Levels 0 and 255 are reserved. - -- - -- 255 is reserved for RTEMS system tasks - -- 247 - 254 correspond to hardware interrupt levels 0 .. 7 - -- 246 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. - -- 245 is used by the Interrupt_Manager task - -- 0 is reserved for the RTEMS IDLE task and really should not - -- be accessible from Ada but GNAT initializes - -- Current_Priority to 0 so it must be valid - - Max_Priority : constant Positive := 244; - Max_Interrupt_Priority : constant Positive := 254; - - subtype Any_Priority is Integer range 0 .. 254; - subtype Priority is Any_Priority range 0 .. 244; - subtype Interrupt_Priority is Any_Priority range 245 .. 254; - - 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; - -end System; diff --git a/gcc/ada/system-solaris-sparc.ads b/gcc/ada/system-solaris-sparc.ads deleted file mode 100644 index 79614aa..0000000 --- a/gcc/ada/system-solaris-sparc.ads +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (SUN Solaris Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-solaris-x86.ads b/gcc/ada/system-solaris-x86.ads deleted file mode 100644 index d598fe9..0000000 --- a/gcc/ada/system-solaris-x86.ads +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (x86 Solaris Version) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - Null_Address : constant Address; - - Storage_Unit : constant := 8; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Word_Size; - - -- 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - -end System; diff --git a/gcc/ada/system-vxworks-arm.ads b/gcc/ada/system-vxworks-arm.ads deleted file mode 100644 index 2b1fb8e..0000000 --- a/gcc/ada/system-vxworks-arm.ads +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks Version ARM) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 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 - - pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); - -- Pull in crtbegin/crtend objects and register exceptions for ZCX. - -- This is commented out by our Makefile for SJLJ runtimes. - - 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/system-vxworks-ppc.ads b/gcc/ada/system-vxworks-ppc.ads deleted file mode 100644 index 37b7d1d..0000000 --- a/gcc/ada/system-vxworks-ppc.ads +++ /dev/null @@ -1,169 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 5 Version PPC) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 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 - - pragma Linker_Options ("--specs=vxworks-gnat-crtbe-link.spec"); - -- Pull in crtbegin/crtend objects and register exceptions for ZCX. - -- This is commented out by our Makefile for SJLJ runtimes. - - pragma Linker_Options ("--specs=vxworks-ppc-link.spec"); - -- Setup proper set of -L's for this configuration - - 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/system-vxworks-x86.ads b/gcc/ada/system-vxworks-x86.ads deleted file mode 100644 index 22f42f3..0000000 --- a/gcc/ada/system-vxworks-x86.ads +++ /dev/null @@ -1,166 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (VxWorks 5 Version x86) -- --- -- --- Copyright (C) 1992-2016, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- 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; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - pragma Preelaborable_Initialization (Address); - 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; - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- Priority-related Declarations (RM D.1) - - -- Ada priorities are mapped to VxWorks priorities using the following - -- transformation: 255 - Ada Priority - - -- Ada priorities are used as follows: - - -- 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 - - pragma Linker_Options ("--specs=vxworks-x86-link.spec"); - -- Setup proper set of -L's for this configuration - - 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. - - Backend_Divide_Checks : constant Boolean := False; - Backend_Overflow_Checks : constant Boolean := True; - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := True; - Stack_Check_Limits : constant Boolean := False; - Support_Aggregates : constant Boolean := True; - Support_Atomic_Primitives : constant Boolean := True; - Support_Composite_Assign : constant Boolean := True; - Support_Composite_Compare : constant Boolean := True; - Support_Long_Shifts : constant Boolean := True; - Always_Compatible_Rep : constant Boolean := False; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := True; - Frontend_Exceptions : constant Boolean := True; - ZCX_By_Default : constant Boolean := False; - - Executable_Extension : constant String := ".out"; - -end System; diff --git a/gcc/ada/system.ads b/gcc/ada/system.ads deleted file mode 100644 index c35ee7c..0000000 --- a/gcc/ada/system.ads +++ /dev/null @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- S Y S T E M -- --- -- --- S p e c -- --- (Compiler Version) -- --- -- --- Copyright (C) 1992-2017, 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 3, 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. -- --- -- --- As a special exception under Section 7 of GPL version 3, you are granted -- --- additional permissions described in the GCC Runtime Library Exception, -- --- version 3.1, as published by the Free Software Foundation. -- --- -- --- You should have received a copy of the GNU General Public License and -- --- a copy of the GCC Runtime Library Exception along with this program; -- --- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- --- . -- --- -- --- GNAT was originally developed by the GNAT team at New York University. -- --- Extensive contributions were provided by Ada Core Technologies Inc. -- --- -- ------------------------------------------------------------------------------- - --- This version of System is a generic version that is used in building the --- compiler. Right now, we have a host/target problem if we try to use the --- "proper" System, and since the compiler itself does not care about most --- System parameters, this generic version works fine. - -pragma Restrictions (No_Implicit_Dynamic_Code); --- We want to avoid trampolines in the compiler, so it can be used in systems --- which prevent execution of code on the stack, e.g. in windows environments --- with DEP (Data Execution Protection) enabled. - -package System is - pragma Pure; - -- Note that we take advantage of the implementation permission to make - -- this unit Pure instead of Preelaborable; see RM 13.7.1(15). In Ada - -- 2005, this is Pure in any case (AI-362). - - pragma No_Elaboration_Code_All; - -- Allow the use of that restriction in units that WITH this unit - - 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 := 2 ** Integer'Size - 1; - - 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; - -- Note that we do NOT add pragma Preelaborable_Initialization in this - -- version of System, since it is used for the compiler only, and typical - -- earlier bootstrap compilers don't support this pragma. We don't need - -- it in this context, so there is no problem in omitting it. - Null_Address : constant Address; - - Storage_Unit : constant := Standard'Storage_Unit; - Word_Size : constant := Standard'Word_Size; - Memory_Size : constant := 2 ** Standard'Address_Size; - - -- 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 := - Bit_Order'Val (Standard'Default_Bit_Order); - pragma Warnings (Off, Default_Bit_Order); -- kill constant condition warning - - -- 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. - - -- This version of system.ads is used only for building the compiler. - -- We really ought to use the proper target system (i.e. the one that - -- corresponds to the host for the compiler), but that causes as yet - -- unsolved makefile problems. For the most part the setting of these - -- parameters is not too critical for the compiler version (e.g. we - -- do not use floating-point anyway in the compiler). - - 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; - Machine_Overflows : constant Boolean := False; - Machine_Rounds : constant Boolean := True; - Preallocated_Stacks : constant Boolean := False; - Signed_Zeros : constant Boolean := True; - Stack_Check_Default : constant Boolean := False; - Stack_Check_Probes : constant Boolean := False; - Stack_Check_Limits : 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; - Always_Compatible_Rep : constant Boolean := True; - Suppress_Standard_Library : constant Boolean := False; - Use_Ada_Main_Program_Name : constant Boolean := False; - Frontend_Exceptions : constant Boolean := False; - ZCX_By_Default : constant Boolean := True; - - -- Obsolete entries, to be removed eventually (bootstrap issues) - - Front_End_ZCX_Support : constant Boolean := False; - High_Integrity_Mode : constant Boolean := False; - Long_Shifts_Inlined : constant Boolean := True; - Functions_Return_By_DSP : constant Boolean := False; - Support_64_Bit_Divides : constant Boolean := True; - GCC_ZCX_Support : constant Boolean := True; - -end System; diff --git a/gcc/ada/text_io.ads b/gcc/ada/text_io.ads deleted file mode 100644 index 4c67d8d..0000000 --- a/gcc/ada/text_io.ads +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT RUN-TIME COMPONENTS -- --- -- --- T E X T _ I O -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -pragma Ada_2012; --- Explicit setting of Ada 2012 mode is required here, since we want to with a --- child unit (not possible in Ada 83 mode), and Text_IO is not considered to --- be an internal unit that is automatically compiled in Ada 2012 mode (since --- a user is allowed to redeclare Text_IO). - -with Ada.Text_IO; - -package Text_IO renames Ada.Text_IO; diff --git a/gcc/ada/unchconv.ads b/gcc/ada/unchconv.ads deleted file mode 100644 index 7937020..0000000 --- a/gcc/ada/unchconv.ads +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- U N C H E C K E D _ C O N V E R S I O N -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -generic - type Source (<>) is limited private; - type Target (<>) is limited private; - -function Unchecked_Conversion (S : Source) return Target; -pragma Import (Intrinsic, Unchecked_Conversion); -pragma Pure (Unchecked_Conversion); diff --git a/gcc/ada/unchdeal.ads b/gcc/ada/unchdeal.ads deleted file mode 100644 index 4735a52..0000000 --- a/gcc/ada/unchdeal.ads +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------- --- -- --- GNAT COMPILER COMPONENTS -- --- -- --- U N C H E C K E D _ D E A L L O C A T I O N -- --- -- --- S p e c -- --- -- --- This specification is derived from the Ada Reference Manual for use with -- --- GNAT. In accordance with the copyright of that document, you can freely -- --- copy and modify this specification, provided that if you redistribute a -- --- modified version, any changes that you have made are clearly indicated. -- --- -- ------------------------------------------------------------------------------- - -generic - type Object (<>) is limited private; - type Name is access Object; - -procedure Unchecked_Deallocation (X : in out Name); -pragma Import (Intrinsic, Unchecked_Deallocation); -- cgit v1.1